MetaAnalysis.RVE <- function(
  data,
  measureType = "r",
  measureCol = "Corr",
  n = "n",
  grping1, grping2,
  published = "Published",
  PA = NULL,
  zTrans = F,
  user_beta = NULL)
{
  notes <- c()

  # Remove empty samples
  data$n <- data[[n]]
  data <- subset(data, data$n > 0)

  # Define grouping, effect-size and published columns
  data$grp1 <- data[[grping1]]
  data$grp2 <- data[[grping2]]
  data$Meas <- data[[measureCol]]
  MeasInit <- data$Meas
  data$published <- as.logical(data[[published]])
  grping1_lvls <- levels(data$grp1)

  nName <- n

  # Get sample variances
  if (zTrans) {
    data <- escalc(
      ri        = Meas,
      ni        = n,
      measure   = "ZCOR",
      data      = data,
      var.names = c("Meas", "Var")
    )
  } else if (measureType == "r") {
    data <- escalc(
      ri        = Meas,
      ni        = n,
      measure   = "COR",
      data      = data,
      var.names = c("Meas", "Var")
    )
  } else if (measureType == "k") {
    pci <- (data[[PA]] - data$Meas) / (1 - data$Meas)
    data$Var <- data[[PA]] * (1 - data[[PA]]) / ((1 - pci) ^ 2 * data$n)
  } else if (measureType == "p") {
    data$Var <- data$Meas * (1 - data$Meas) / (data$n + 1e-4)
  } else {
    stop("Unknown 'measureType' specified.")
  }

  # Remove any undefined data (and take notes)
  if (any(is.na(data$Meas))) {
    notes <- c(notes, paste0(
      "\tThe following rows were removed because the effect-size was undefined:\n\n"))
    notes <- c(notes, paste0(
      "\t * Grp 1 - ", data$grp1[is.na(data$Meas)], ", Grp 2 - ", data$grp2[is.na(data$Meas)],
      " (Original effect-size: ", MeasInit[is.na(data$Meas)], ")\n"))
    notes <- c(notes, "\n")
    data <- data[!is.na(data$Meas),]
  }

  # Make sure none of variances are 0, otherwise analysis will fail
  data$Var[data$Var == 0] <- 1e-9

  # Build random-effects models using Robust Variance Estimation
  # Also run sensitivity analysis on rho and conduct Egger's regression test for bias
  REModels <- list()
  rhoSensitivity <- list()
  eggersRegTest <- list()
  dataList <- list()
  for (grping in grping1_lvls) {
    if (sum(data$grp1 == grping) > 1)
    {
      data.grp = data[data$grp1 == grping,]

      # Calculate random effects model
      argList <- list(
        formula      = Meas ~ 1,
        data         = data.grp,
        studynum     = data.grp$grp2,
        var.eff.size = data.grp$Var,
        rho          = 0.8,
        small        = T,
        modelweights = "CORR"
      )
      REModels[[grping]] <- do.call(robu, argList)
      dataList[[grping]] <- data.grp

      if (!is.null(user_beta))
      {
        REModels[[grping]]$reg_table$b.r  <- user_beta[[grping]]$b.r
        REModels[[grping]]$reg_table$SE   <- user_beta[[grping]]$SE
        REModels[[grping]]$reg_table$CI.L <- user_beta[[grping]]$CI.L
        REModels[[grping]]$reg_table$CI.U <- user_beta[[grping]]$CI.U
        REModels[[grping]]$data.full$r.weights <- user_beta[[grping]]$mdlWeights
      }

      dataList[[grping]]$mdlWeights <- REModels[[grping]]$data.full$r.weights
      dataList[[grping]]$mdlWeights2 <- REModels[[grping]]$data.full$weights

      # Perform sensitivity analysis
      tmp <- capture.output(rhoSensitivity[[grping]] <- sensitivity(REModels[[grping]]))

      if (sum(data.grp$published) > 2 && measureType != "p") {
        # Conduct regression test
        eggersRegTest[[grping]] <- robu(
          formula      = Meas ~ 1 + sqrt(Var),
          data         = data.grp[data.grp$published,],
          studynum     = grp2,
          var.eff.size = Var,
          rho          = 0.8,
          small        = T,
          modelweights = "CORR",
          userweights  = REModels[[grping]]$data.full$r.weights[data.grp$published]
        )
      } else {
        eggersRegTest[[grping]] <- list(reg_table = list(prob = c(NaN,NaN)))
      }
    } else {
      data.grp = data[data$grp1 == grping,]
      dataList[[grping]] <- data.grp
      if (nrow(data.grp) > 0) dataList[[grping]]$mdlWeights <- 1
      notes <- c(notes, paste0("\tSkipped '", grping, "' - ", sum(data$grp1 == grping), " studies.\n"))
    }
  }

  crossTab <- table(data$grp1)
  data.grp <- data[data$grp1 %in% names(crossTab)[crossTab > 0], ]
  argList <- list(
    formula      = Meas ~ 1,
    data         = data.grp,
    studynum     = data.grp$grp2,
    var.eff.size = data.grp$Var,
    rho          = 0.8,
    small        = T,
    modelweights = "CORR"
  )
  REModels$overall <- do.call(robu, argList)
  dataList$overall <- data.grp

  if (!is.null(user_beta))
  {
    REModels$overall$reg_table$b.r  <- user_beta$overall$b.r
    REModels$overall$reg_table$SE   <- user_beta$overall$SE
    REModels$overall$reg_table$CI.L <- user_beta$overall$CI.L
    REModels$overall$reg_table$CI.U <- user_beta$overall$CI.U
    REModels$overall$data.full$r.weights <- user_beta$overall$mdlWeights
  }

  dataList$overall$mdlWeights <- REModels$overall$data.full$r.weights

  tmp <- capture.output(rhoSensitivity$overall <- sensitivity(REModels$overall))

  if (measureType != "p")
    eggersRegTest$overall <- robu(
      formula      = Meas ~ 1 + sqrt(Var),
      data         = data.grp[data.grp$published,],
      studynum     = grp2,
      var.eff.size = Var,
      rho          = 0.8,
      small        = T,
      modelweights = "CORR",
      userweights  = REModels$overall$data.full$r.weights[data.grp$published]
    )

  return(
    list(
      REModels = REModels,
      rhoSensitivity = rhoSensitivity,
      eggersRegTest = eggersRegTest,
      data = data,
      dataList = dataList,
      notes = notes,
      measureType = measureType,
      zTrans = zTrans
    )
  )
}

Summary.RVE <- function(
  RVEModel,
  fileName,
  studyName = "Authors"
)
{
  output <- c()

  # Unpack
  REModels <- RVEModel$REModels
  rhoSensitivity <- RVEModel$rhoSensitivity
  eggersRegTest <- RVEModel$eggersRegTest
  notes <- RVEModel$notes
  zTrans <- RVEModel$zTrans
  measureType <- RVEModel$measureType
  dataList <- RVEModel$dataList

  output <- c(output, "Notes\n-----\n", paste(notes, collapse = ""), "\n")

  # Get first level groupings
  grping1_lvls <- names(REModels)

  for (grping in grping1_lvls)
  {
    # Print group heading
    output <- c(output, "\n\n========", grping, "========\n\n")

    # Print model statistics and tests
    Q <- t(REModels[[grping]]$data.full$e) %*%
      diag(REModels[[grping]]$data.full$weights) %*%
      REModels[[grping]]$data.full$e

    if (zTrans) {
      output <- c(output, "\tEffect-size (z):          \t", REModels[[grping]]$reg_table$b.r, "\n")
      output <- c(output, "\tEffect-size (eff-size):   \t", tanh(REModels[[grping]]$reg_table$b.r), "\n")
      output <- c(output, "\tStandard error (z):       \t", REModels[[grping]]$reg_table$SE, "\n")
    } else if (measureType == "p") {
      output <- c(output, "\tEffect-size (log-odds):   \t", REModels[[grping]]$reg_table$b.r, "\n")
      output <- c(output, "\tEffect-size (eff-size):   \t", 1/(1+exp(-REModels[[grping]]$reg_table$b.r)), "\n")
      output <- c(output, "\tStandard error (log-odds):\t", REModels[[grping]]$reg_table$SE, "\n")
    } else {
      output <- c(output, "\tEffect-size (eff-size):   \t", REModels[[grping]]$reg_table$b.r, "\n")
      output <- c(output, "\tStandard error (eff-size):\t", REModels[[grping]]$reg_table$SE, "\n")
    }
    output <- c(output, "\tk (ind. samples):              \t", length(unique(dataList[[grping]]$grp2)), "\n")
    output <- c(output, "\tn (participants):         \t", sum(aggregate(n ~ grp2, data = dataList[[grping]], max)$n), "\n")
    output <- c(output, "\tp-value:                  \t", REModels[[grping]]$reg_table$prob, "\n")
    output <- c(output, "\tdf:                       \t", REModels[[grping]]$reg_table$dfs, "\n")
    output <- c(output, "\tI.sq:                     \t", REModels[[grping]]$mod_info$I.2, "\n")
    output <- c(output, "\tQ-test:                   \t", Q, "\n")
    output <- c(output, "\tTau.sq:                   \t", REModels[[grping]]$mod_info$tau.sq, "\n\n")

    output <- c(output, "\tEgger's Regression Test for Bias\n\n")

    if (is.nan(eggersRegTest[[grping]]$reg_table$prob[2])) {
      output <- c(output, "\t\tEgger's test not defined (probably not enough data)\n\n")
    } else {
      output <- c(output, "\t\tp-value:         \t", eggersRegTest[[grping]]$reg_table$prob[2],
                  if (eggersRegTest[[grping]]$reg_table$prob[2] < 0.05) "*" else "", "\n")
      output <- c(output, "\t\tdf:              \t", eggersRegTest[[grping]]$reg_table$dfs[2], "\n\n")
    }

    # Print sensitivity analysis
    output <- c(output, "\tIntra-study clustering sensitivity analysis:\n")
    output <- c(output, paste0("\t\t", capture.output(rhoSensitivity[[grping]]), sep = "\n"))
  }

  cat(output)
  capture.output(cat(output), file = fileName)

  flush.console()
  invisible()
}

forest.RVE <- function(
  RVEModel,
  studyNames,
  sampleNames,
  effSizeName,
  fileName,
  extraCol = NULL,
  extraColName = NULL,
  fullData = NULL
)
{
  # Unpack
  REModels <- RVEModel$REModels
  data <- RVEModel$data
  zTrans <-RVEModel$zTrans
  data$study <- as.character(data[[studyNames]])
  data$sample <- data[[sampleNames]]
  grping1_lvls <- levels(data$grp1)

  measScale <- 1
  if (RVEModel$measureType == "p")
  {
    measScale <- 100
  }
  data$Meas <- data$Meas * measScale

  if (!is.null(extraCol)) {
    data$extra <- data[[extraCol]]
  }

  if (zTrans) {
    transf <- tanh
  } else {
    transf <- function(x) {x}
  }

  # Get weights; summary effects and standard errors; and n sums for plotting
  effSize <- c()
  standErr <- c()
  ci.lb <- c()
  ci.ub <- c()
  nSum <- c()
  data$weight <- NA
  for (grping in grping1_lvls)
  {
    indx <- data$grp1 == grping & !is.na(data$n)
    if (sum(indx) > 1) {
      data$weight[indx] <- REModels[[grping]]$data.full$r.weights /
        sum(REModels[[grping]]$data.full$r.weights) * 100

      effSize[grping] <- REModels[[grping]]$reg_table$b.r
      standErr[grping] <- REModels[[grping]]$reg_table$SE
      ci.lb[grping] <- REModels[[grping]]$reg_table$CI.L
      ci.ub[grping] <- REModels[[grping]]$reg_table$CI.U
      nSum[grping] <- sum(aggregate(n ~ grp2, data = data[indx,], max)$n)
    } else {
      data$weight[indx] <- 100
      effSize[grping] <- NA
      standErr[grping] <- NA
      ci.lb[grping] <- NA
      ci.ub[grping] <- NA
      nSum[grping] <- NA
    }
  }

  # Sort data by level 1 and level 2 grouping and add an id
  data <- data %>% arrange(as.integer(grp1), study)
  data$ID <- 1:nrow(data)

  # Define headings for studies with multiple endpoints
  for (grping1 in grping1_lvls)
  {
    data.grp <- data[data$grp1 == grping1,]
    for (grping2 in unique(data.grp$grp2))
    {
      data.grp2 <- data.grp[data.grp$grp2 == grping2,]
      if (nrow(data.grp2) > 1) {
        minID <- min(data.grp2$ID)
        study <- data.grp2$study[1]
        indx <- data$grp1 == grping1 & data$grp2 == grping2
        data$study[indx] <- paste0("    ", data$sample[indx])
        data <- rbindlist(
          list(data,
               data.frame(grp1 = grping1, grp2 = grping2, study = study, ID = minID - 0.5,
                          n = max(data.grp2$n), weight = sum(data.grp2$weight), stringsAsFactors = F)),
          fill = T)
      }
    }
  }
  # Re-sort data
  data <- data %>% arrange(ID)

  # Define forest plot row formatting
  headingLocations <- c()
  summaryLocations <- c()
  sampleLocations <- c()

  for (grping in grping1_lvls)
  {
    if (length(headingLocations) == 0)
    {
      headingLocations <- 1
    }
    else
    {
      headingLocations <- c(headingLocations, max(c(sampleLocations, summaryLocations)) + 2)
    }
    sampleLocations <- c(
      sampleLocations,
      max(headingLocations) + seq(1,sum(data$grp1 == grping),length = sum(data$grp1 == grping))
    )
    # if (sum(data$grp1 == grping) != 1)
      summaryLocations <- c(summaryLocations, max(headingLocations) + sum(data$grp1 == grping) + 1)
  }
  maxLocations <- max(summaryLocations, sampleLocations, headingLocations)
  headingLocations <- maxLocations - headingLocations + 1
  sampleLocations <- maxLocations - sampleLocations + 1
  summaryLocations <- maxLocations - summaryLocations + 1

  # Add indent to study names for formatting
  data$study <- paste0("    ", data$study)

  # Split out study headings and samples
  studyHeadingLocations <- sampleLocations[is.na(data$Meas)]
  sampleLocations <- sampleLocations[!is.na(data$Meas)]
  studyHeadings <- data$study[is.na(data$Meas)]
  studyHeadingsN <- data$n[is.na(data$Meas)]
  studyHeadingsWeight <- round(data$weight[is.na(data$Meas)], 2)
  data <- data[!is.na(data$Meas),]

  # Reset zero variances to zero and unity correlations to unity
  if (!zTrans) {
    data$Meas[data$Meas == 1] <- 1-1e-8
    data$Var[data$Var < 1e-8] <- 0
  }

  # Initialise forest plot with sample effect-sizes and CIs
  cex = 1.5
  op <- par(mar=c(4,4,0,2))
  ylim <- c(-1, maxLocations+3)
  efac <- 0.4
  digits <- if (RVEModel$measureType == "p") 1 else 2
  slab.col <- rep("black", nrow(data))
  slab.col[grep("        ", data$study)] <- "dimgray"
  anno.pos <- 2.5 * measScale
  if (is.null(extraCol)) {
    ilab = cbind(data$n, format(round(data$weight,2), trim = F))
    ilab.xpos <- c(-1.9, -1.2) * measScale + if (RVEModel$measureType == "p") measScale else 0
    ilab.pos <- 2
    xlim <- c(if (RVEModel$measureType == "p") -4 else -5, 2.5) * measScale
    colLabels <- c("N", "Weight", paste(effSizeName, "[95% CI]"))
  } else {
    ilab = cbind(data$n, format(round(data$weight,2), trim = F), data$extra)
    ilab.xpos <- c(c(-1.9, -1.2) * measScale + if (RVEModel$measureType == "p") measScale else 0, 3 * measScale)
    ilab.pos <- 2
    xlim <- c(if (RVEModel$measureType == "p") -4 else -5, 3) * measScale
    colLabels <- c("N", "Weight", extraColName, paste(effSizeName, "[95% CI]"))
  }

  tiff(filename = fileName,
       width=18, height = 3+25*maxLocations/75, units = "cm", res = 600,
       compression = "lzw", pointsize = 6)
  forest.col(
    x = data$Meas,
    vi = data$Var * measScale^2,
    xlim = xlim,
    alim = c(if (RVEModel$measureType == "p") 0 else -1, 1) * measScale,
    ylim = ylim,
    digits = digits,
    xlab = effSizeName,
    slab = data$study,
    ilab = ilab,
    ilab.xpos = ilab.xpos,
    ilab.pos = ilab.pos,
    transf = transf,
    rows = sampleLocations,
    efac = efac,
    cex = cex,
    slab.col = slab.col,
    anno.pos = anno.pos,
    refline = if (RVEModel$measureType == "p") c(0, 0.25, 0.5, 0.75, 1)*measScale else 0
  )

  # Add study headings (level 2 groupings)
  if (length(studyHeadings) > 0) {
    text(
      x = xlim[1],
      y = studyHeadingLocations,
      labels = studyHeadings,
      cex = cex,
      pos = 4
    )
    text(
      x = ilab.xpos[1],
      y = studyHeadingLocations,
      labels = studyHeadingsN,
      cex = cex,
      pos = 2
    )
    text(
      x = ilab.xpos[2],
      y = studyHeadingLocations,
      labels = format(studyHeadingsWeight),
      cex = cex,
      pos = 2
    )
  }

  # Add level 1 grouping headings
  text(
    x = xlim[1],
    y = headingLocations,
    labels = grping1_lvls,
    cex = cex,
    pos = 4,
    font = 4
  )

  # Add level 1 group summaries and overall summary
  grpIncl <- grping1_lvls %in% names(REModels)
  text(
    x = c(rep(ilab.xpos[1], sum(grpIncl)), rep(ilab.xpos[2], sum(grpIncl))),
    y = rep(summaryLocations[grpIncl], 2),
    labels = c(nSum[grpIncl], rep("100.00", sum(grpIncl))),
    cex = cex,
    pos = ilab.pos,
    font = 2
  )
  text(
    x = c(ilab.xpos[1], ilab.xpos[2]),
    y = ylim[1],
    labels = c(sum(aggregate(n ~ grp2, data = data, max)$n), "100.00"),
    cex = cex,
    pos = ilab.pos,
    font = 2
  )

  if(sum(!grpIncl) > 0)
    text(
      x = c(rep(ilab.xpos[1], sum(!grpIncl)), rep(ilab.xpos[2], sum(!grpIncl))),
      y = rep(summaryLocations[!grpIncl], 2),
      labels =  rep("N/A", sum(!grpIncl)*2),
      cex = cex,
      pos = ilab.pos,
      font = 2
    )

  addpoly.col(
    x = effSize[grpIncl],
    ci.lb = ci.lb[grpIncl],
    ci.ub = ci.ub[grpIncl],
    rows = summaryLocations[grpIncl],
    cex = cex,
    mlab = rep("    RE Model", sum(grpIncl)),
    transf = transf,
    efac = efac,
    digits = digits,
    font = 2,
    anno.pos = anno.pos
  )
  addpoly.col(
    x = REModels$overall$reg_table$b.r,
    sei = REModels$overall$reg_table$SE,
    rows = ylim[1],
    cex = cex,
    mlab = "Overall RE Model",
    transf = transf,
    efac = efac,
    digits = digits,
    font = 2,
    anno.pos = anno.pos
  )

  # Add column labels
  text(
    x = c(ilab.xpos, anno.pos),
    y = maxLocations + 2,
    labels = colLabels,
    cex = cex,
    pos = ilab.pos,
    font = 2
  )

  dev.off()

  invisible()
}

funnel.RVE <- function(
  RVEModel,
  fileName,
  trimnfill = T,
  plotReg = T,
  effSizeName = "Cohen's kappa"
)
{
  # Unpack
  data <- RVEModel$data
  zTrans <- RVEModel$zTrans
  REModels <- RVEModel$REModels
  eggersRegTest <- RVEModel$eggersRegTest
  grping1_lvls <- names(REModels)
  grpIncl <- grping1_lvls %in% levels(data$grp1)
  overallB <- REModels$overall$reg_table$b.r
  data$standErr <- sqrt(data$Var)
  maxStandErr <- max(data$standErr, na.rm = T)

  if (plotReg)
  {
    # Get Egger's regression line
    xEgg <- seq(-1,1,0.001)
    mdl <- REModels$overall
    egg <- eggersRegTest$overall
    intercept <- -egg$reg_table$b.r[1]/egg$reg_table$b.r[2]
    gradient <- 1/egg$reg_table$b.r[2]
    regLine <- xEgg * gradient + intercept
    print(paste0("Egger's regression p-value: ", egg$reg_table$prob[2]))

    if (zTrans)
      regLine <- tanh(regLine)
  }

  if (trimnfill)
  {
    tnf <- meta::trimfill.default(
      data$Meas[data$published],
      data$standErr[data$published],
      left = T,
      sm = if (zTrans) "ZCOR" else "COR",
      ma.fixed = F,
      type = "L"
    )

    tnf_Meas <- tnf$TE[tnf$trimfill]
    tnf_standErr <- tnf$seTE[tnf$trimfill]
    tnf_study <- tnf$studlab[tnf$trimfill]

    if (zTrans)
    {
      tnf_standErr <- (tanh(tnf_Meas + tnf_standErr) - tanh(tnf_Meas - tnf_standErr)) / 2
      tnf_Meas <- tanh(tnf_Meas)
    }
  }

  if (zTrans)
  {
    data$standErr <- (tanh(data$Meas + sqrt(data$Var)) - tanh(data$Meas - sqrt(data$Var))) / 2
    data$Meas <- tanh(data$Meas)
    maxStandErr <- max(data$standErr)
    overallB <- tanh(overallB)
  }

  op <- par(mar = c(4,4,1,2))
  tiff(filename = fileName,
       width = 15, height = 12, units = "cm", res = 600,
       compression = "lzw", pointsize = 8)

  funnel(
    x = c(-99, -99),
    vi = c(99, 99),
    yaxis = "sei",
    xlim = c(-1, 1),
    ylim = c(0, maxStandErr),
    xlab = effSizeName,
    back = "white",
    shade = F,
    hlines = "white",
    pch = 1,
    cex = 1,
    refline = overallB
  )
  box()

  points(
    x = data$Meas[data$published],
    y = data$standErr[data$published],
    # pch = as.integer(data$grp1[data$published]),
    pch = 1,
    cex = 1
  )
  points(
    x = data$Meas[!data$published],
    y = data$standErr[!data$published],
    pch = 16,
    cex = 1
  )

  if (plotReg)
  {
    lines(xEgg[regLine >= 0], regLine[regLine >= 0], lty = 2)
  }

  if (trimnfill && length(tnf_Meas)>0)
  {
    points(
      x = tnf_Meas,
      y = tnf_standErr,
      pch = 17,
      cex = 1
    )

    crossTab <- table(data$grp1)
    data.grp <- data[data$grp1 %in% names(crossTab)[crossTab > 0], ]
    tnf.data.grp <- data.frame(
      grp2 = tnf_study,
      Meas = tnf_Meas,
      n = data$n[as.numeric(gsub("Filled: ", "", tnf_study))]
    )
    data.grp <- rbind.fill(data.grp, tnf.data.grp)

    data.grp <- escalc(
      ri        = Meas,
      ni        = n,
      measure   = if (zTrans) "ZCOR" else "COR",
      data      = data.grp,
      var.names = c("Meas", "Var")
    )
    argList <- list(
      formula      = Meas ~ 1,
      data         = data.grp,
      studynum     = data.grp$grp2,
      var.eff.size = data.grp$Var,
      rho          = 0.8,
      small        = T,
      modelweights = "CORR"
    )
    adjMdl <- do.call(robu, argList)
    lines(c(adjMdl$reg_table$b.r, adjMdl$reg_table$b.r), c(0, 10), lty = 2)
  }

  legend(
    x = "topleft",
    legend = eval(parse(text =
      paste0("expression('Published', 'Unpublished', 'Original estimate','Eggers regression line ('*italic('p')*' value = '*", as.character(round(egg$reg_table$prob[2], 3)), "*')')"))),
    pch = c(1, 16, NA, NA),
    lty = c(0, 0, 1, 2),
    col = "black",
    pt.cex = 1,
    bty = "n"
  )

  dev.off()

  invisible()
}

SensitivityAnalysis.RVE <- function(
  data,
  measureType = "r",
  measureCol = "Corr",
  sensitivityCol,
  n = "n",
  grping1, grping2,
  PA = NULL,
  zTrans = F,
  grpd = T)
{
  notes <- c()

  # Remove empty samples
  data$n <- data[[n]]
  data <- data[data$n > 0,]

  data$grp1 <- data[[grping1]]
  data$grp2 <- data[[grping2]]
  data$Meas <- data[[measureCol]]
  data$Sens <- data[[sensitivityCol]]
  IsBinary <- length(na.omit(unique(data$Sens))) <= 2
  MeasInit <- data$Meas
  SensInit <- data$Sens
  grping1_lvls <- levels(data$grp1)

  nName <- n

  # Get sample variances
  if (zTrans) {
    data <- escalc(
      ri        = Meas,
      ni        = n,
      measure   = "ZCOR",
      data      = data,
      var.names = c("Meas", "Var")
    )
  } else if (measureType == "r") {
    data <- escalc(
      ri        = Meas,
      ni        = n,
      measure   = "COR",
      data      = data,
      var.names = c("Meas", "Var")
    )
    data$Meas[data$Meas == 1] <- 1 - 1e-6
    data$Meas[data$Meas == 0] <- 1e-6
  } else if (measureType == "k") {
    pci <- (data[[PA]] - data$Meas) / (1 - data$Meas)
    data$Var <- data[[PA]] * (1 - data[[PA]]) / ((1 - pci) ^ 2 * data$n)
  } else if (measureType == "p") {
    data <- escalc(
      xi = Meas,
      ni = n,
      measure = "PLO",
      data = data,
      var.names = c("Meas", "Var")
    )
  } else {
    stop("Unknown 'measureType' specified.")
  }

  # Remove any undefined data (and take notes)
  if (any(is.na(data$Meas))) {
    notes <- c(notes, paste0(
      "\tThe following rows were removed because the effect-size was undefined:\n\n"))
    notes <- c(notes, paste0(
      "\t * ", data$grp1[is.na(data$Meas)], " - ", data$grp2[is.na(data$Meas)],
      " (", data$Meas[is.na(data$Meas)], ")\n"))
    notes <- c(notes, "\n")
    data <- data[!is.na(data$Meas),]
  }
  if (any(is.na(data$Sens))) {
    notes <- c(notes, paste0(
      "\tThe following rows were removed because the sensitivity variable was undefined:\n\n"))
    notes <- c(notes, paste0(
      "\t * ", data$grp1[is.na(data$Sens)], " - ", data$grp2[is.na(data$Sens)],
      " (", data$Sens[is.na(data$Sens)], ")\n"))
    notes <- c(notes, "\n")
    data <- data[!is.na(data$Sens),]
  }

  # Make sure none of variances are 0, otherwise analysis will fail
  data$Var[data$Var == 0] <- 1e-6

  # Remove first level groups with only 1 study
  for (grping in grping1_lvls)
    if (sum(data$grp1 == grping) < 1)
    {
      notes <- c(notes, paste0("\tRemoved '", grping, "' - ", sum(data$grp1 == grping), " studies.\n"))
      data <- data[data$grp1 != grping,]
      grping1_lvls <- grping1_lvls[grping1_lvls != grping]
    }

  # Build random-effects models using Robust Variance Estimation
  REModels <- list()
  dataList <- list()
  for (grping in grping1_lvls) {
    data.grp = data[data$grp1 == grping,]

    if ((!IsBinary || all(table(data.grp$Sens) >= 2)) && length(unique(data.grp$Sens)) > 1 && nrow(data.grp) > 2) {
      # Calculate random effects model
      argList <- list(
        formula      = Meas ~ 1 + Sens,
        data         = data.grp,
        studynum     = data.grp$grp2,
        var.eff.size = data.grp$Var,
        rho          = 0.8,
        small        = T,
        modelweights = "CORR"
      )
      REModels[[grping]] <- do.call(robu, argList)
      dataList[[grping]] <- data.grp
      dataList[[grping]]$mdlWeights <- REModels[[grping]]$data.full$r.weights
    } else {
      notes <- c(notes, paste0("\tSkipped '", grping, "' due to lack of data (we require at least 1 per group and 2 overall)\n"))
    }
  }

  if (grpd)
  {
    formula <- as.formula(Meas ~ 1 + Sens + grp1)
  }
  else
  {
    formula <- as.formula(Meas ~ 1 + Sens)
  }
  res <- try(
    {
      dataOA <- data
      if ((!IsBinary || all(table(dataOA$Sens) >= 2)) && length(unique(dataOA$Sens)) > 1 && nrow(dataOA) >= 2) {
        argList <- list(
          formula      = formula,
          data         = dataOA,
          studynum     = dataOA$grp2,
          var.eff.size = dataOA$Var,
          rho          = 0.8,
          small        = T,
          modelweights = "CORR"
        )
        REModels$overall <- do.call(robu, argList)
        dataList$overall <- dataOA
        dataList$overall$mdlWeights <- REModels$overall$data.full$r.weights
      }
    }
  )
  if (inherits(res, "try-error") || any(is.nan(REModels$overall$reg_table$prob))) {
    crossTab <- table(data$grp1)
    dataOA <- data[data$grp1 %in% names(crossTab)[crossTab > 1],]
    if ((!IsBinary || all(table(dataOA$Sens) >= 2)) && length(unique(dataOA$Sens)) > 1 && nrow(dataOA) >= 2 &&
        length(REModels) > 0) {
      argList <- list(
        formula      = formula,
        data         = dataOA,
        studynum     = dataOA$grp2,
        var.eff.size = dataOA$Var,
        rho          = 0.8,
        small        = T,
        modelweights = "CORR"
      )
      REModels$overall <- do.call(robu, argList)
      dataList$overall <- dataOA
      dataList$overall$mdlWeights <- REModels$overall$data.full$r.weights
    }
  }

  return(
    list(
      REModels = REModels,
      data = data,
      dataList = dataList,
      notes = notes,
      measureType = measureType,
      sensitivityCol = sensitivityCol,
      zTrans = zTrans
    )
  )
}

SensSummary.RVE <- function(
  RVEModel,
  fileName,
  isBinary = T,
  overallOnly = F,
  studyName = "Authors"
)
{
  output <- c()

  # Unpack
  REModels <- RVEModel$REModels
  notes <- RVEModel$notes
  zTrans <- RVEModel$zTrans
  measureType <- RVEModel$measureType
  sensCol <- RVEModel$sensitivityCol
  data <- RVEModel$data
  dataList <- RVEModel$dataList

  if (length(REModels) == 0) {
    output <- c(output, "Notes\n-----\n", paste(notes, collapse = ""), "\n\n")
    output <- c(output, "No models built - see notes\n")

    cat(output)
    capture.output(cat(output), file = fileName)

    return(invisible())
  }

  output <- c(output, "\n\n========", sensCol, "========")
  output <- c(output, "\nNotes\n-----\n", paste(notes, collapse = ""), "\n")

  # Determine relvant levels
  if (isBinary) {
    factors <- c(0, 1)
  } else {
    factors <- c(
      min(data$Sens),
      (min(data$Sens) + max(data$Sens))/2,
      max(data$Sens)
    )
    output <- c(output, "\tLine of best fit estimations\n")
  }

  # Get first level groupings
  grping1_lvls <- names(REModels)
  if (overallOnly) {
    grping1_lvls <- "overall"
  }

  probVec <- c()
  for (grping in grping1_lvls)
  {
    # Print group heading
    output <- c(output, "\n", grping, "\n-------\n\n")

    regTable <- REModels[[grping]]$reg_table
    data.grp <- dataList[[grping]]
    if (is.character(data.grp$Sens)) {
      data.grp$Sens <- as.integer(as.factor(data.grp$Sens))
    }
    if (isBinary) {
      posGrp <- data.grp$Sens == 1
    } else {
      posGrp <- rep(T, nrow(data.grp))
    }

    output <- c(output, "\tk_total:      \t", length(unique(data.grp$grp2)), "\n")
    output <- c(output, "\tk_posGrp:     \t", length(unique(data.grp$grp2[posGrp])), "\n")
    output <- c(output, "\tn_total:      \t", sum(aggregate(n ~ grp2, data = data.grp, max)$n), "\n")
    output <- c(output, "\tn_posGrp:     \t", sum(aggregate(n ~ grp2, data = data.grp[posGrp,], max)$n), "\n")
    output <- c(output, "\tb_0:          \t", regTable$b.r[1], "\n")
    output <- c(output, "\tb_1:          \t", regTable$b.r[2], "\n")
    output <- c(output, "\tCI(b_0):      \t(", regTable$CI.L[1], ", ", regTable$CI.U[1], ")\n")
    output <- c(output, "\tCI(b_1):      \t(", regTable$CI.L[2], ", ", regTable$CI.U[2], ")\n")
    output <- c(output, "\tSE(b_0):      \t", regTable$SE[1], "\n")
    output <- c(output, "\tSE(b_1):      \t", regTable$SE[2], "\n")
    output <- c(output, "\tdf_0:         \t", regTable$dfs[1], "\n")
    output <- c(output, "\tdf_1:         \t", regTable$dfs[2], "\n")
    output <- c(output, "\tt_0:          \t", regTable$t[1], "\n")
    output <- c(output, "\tt_1:          \t", regTable$t[2], "\n")
    output <- c(output, "\tp_0:          \t", regTable$prob[1], "\n")
    output <- c(output, "\tp_1:          \t", regTable$prob[2], "\n")
    output <- c(output, "\tTauSq:        \t", REModels[[grping]]$mod_info$tau.sq, "\n")
    output <- c(output, "\tISq:          \t", REModels[[grping]]$mod_info$I.2, "\n\n")

    roundDig <- 3
    if (is.na(regTable$prob[1]))
    {
      probString0 <- probString1 <- "NA"
    }
    else
    {
      probString0 <- paste0(round(regTable$prob[1],roundDig), if (regTable$prob[1] < 0.01) "***" else if (regTable$prob[1] < 0.05) "**" else if (regTable$prob[1] < 0.1) "*" else "")
      probString1 <- paste0(round(regTable$prob[2],roundDig), if (regTable$prob[2] < 0.01) "***" else if (regTable$prob[2] < 0.05) "**" else if (regTable$prob[2] < 0.1) "*" else "")
    }
    if (grping == "overall")
    {
      desc <- c(
        sensCol,
        length(unique(data.grp$grp2)),
        length(unique(data.grp$grp2[posGrp])),
        sum(aggregate(n ~ grp2, data = data.grp, max)$n),
        sum(aggregate(n ~ grp2, data = data.grp[posGrp,], max)$n),
        paste0(round(regTable$b.r[1],roundDig), " [", round(regTable$CI.L[1],roundDig), ", ", round(regTable$CI.U[1],roundDig), "]"),
        paste0(round(regTable$b.r[2],roundDig), " [", round(regTable$CI.L[2],roundDig), ", ", round(regTable$CI.U[2],roundDig), "]"),
        # round(regTable$SE[1],roundDig),
        # round(regTable$SE[2],roundDig),
        round(regTable$dfs[1],roundDig),
        round(regTable$dfs[2],roundDig),
        round(regTable$t[1],roundDig),
        round(regTable$t[2],roundDig),
        probString0,
        probString1,
        round(REModels[[grping]]$mod_info$tau.sq,roundDig),
        round(REModels[[grping]]$mod_info$I.2,roundDig)
      )
    }
    probVec[[grping]] <- probString1
  }

  cat(output)
  capture.output(cat(output), file = fileName)

  flush.console()
  return(list(text = output, matrix = probVec, desc = desc))
}

logit <- function(p)
{
  log(p / (1 - p))
}

sigmoid <- function(x)
{
  1 / (1 + exp(-x))
}

# Wilson score method
#
# Wilson, E. B. ‘Probable inference, the law of succession, and statistical inference’,
# Journal of the AmericanStatistical Association
#
p_CI <- function(n, p, z)
{
  list(
    (2 * n * p + z^2 + z * sqrt(z^2 + 4 * n * p * (1 - p))) / (2 * (n + z^2)),
    (2 * n * p + z^2 - z * sqrt(z^2 + 4 * n * p * (1 - p))) / (2 * (n + z^2))
  )
}


#!/usr/bin/Rscript

## recombine.r -- carries out a simulated recombination of chromosomes

## Author: David Eccles (gringer), 2008 <programming@gringer.org>

usage <- function(){
  cat("usage: ./recombine.r\n");
  cat("\nOther Options:\n");
  cat("-help               : Only display this help message\n");
  cat("\n");
}

argLoc <- 1;
while(!is.na(commandArgs(TRUE)[argLoc])){
  if(commandArgs(TRUE)[argLoc] == "-help"){
    usage();
    quit(save = "no", status=0);
  }
  argLoc <- argLoc + 1;
}

makeUniformChromosome <- function(colour = "NA"){
  if(colour == "NA"){
    colour = sample(colors(),1);
  }
  return(data.frame(Block = colour, Points = 0));
}

drawChromosome <- function(ChrX, xPos = 0.5, yPos = 0, scale = 1,
                           yScale = 0.5, new = TRUE){
  xLeft = xPos;
  yBottom = yPos;
  xRight = xPos + 0.05 * scale;
  if(new){
    plot.new();
  }
  for(i in 1:(dim(ChrX)[1])){
    if(i == dim(ChrX)[1]){
      rect(xLeft,yBottom+ChrX[i,2]*scale*yScale,xRight,
           yBottom+1*scale*yScale,
           col=as.character(ChrX[i,1]));
    } else {
      rect(xLeft,yBottom+ChrX[i,2]*scale*yScale,xRight,
           yBottom+ChrX[i+1,2]*scale*yScale,
           col=as.character(ChrX[i,1]));
    }
  }
}

recombine <- function(ChrX, ChrY, minPoints = 3, maxPoints = 4){
  result <- NULL;
  recombPoints <- sort(runif(sample(minPoints:maxPoints,1)));
  currentChr <- sample(c(0,1),1);
  startPos <- 0;
  newPoints <- NULL;
  for(endPos in c(recombPoints,1)){
    if(currentChr == 0){
      stopX <- c(ChrX$Points[-1],1);
      # list of recombination points on ChrX in the correct interval
      curPoints = which((ChrX$Points<=endPos) &
        (stopX >= startPos));
      newPoints <- ChrX[curPoints,];
    } else {
      stopY <- c(ChrY$Points[-1],1);
      # list of recombination points on ChrY in the correct interval
      curPoints = which((ChrY$Points<=endPos) &
        (stopY >= startPos));
      newPoints <- ChrY[curPoints,];
    }
    # set start recombination point to be where the recombination took place
    newPoints$Points[1] <- startPos;
    result <- rbind(result,newPoints);
    startPos <- endPos;
    currentChr <- (currentChr + 1) %% 2;
  }
  return(result);
}

# merges regions of the same colour
chrClean <- function(ChrX){
  result <- ChrX[1,];
  oldColour <- ChrX$Block[1];
  for(pos in 2:(dim(ChrX)[1])){
    if(oldColour != ChrX$Block[pos]){
##      cat(oldColour, "does not equal", ChrX$Block[pos],"\n");
      result <- rbind(result,ChrX[pos,]);
      oldColour <- ChrX$Block[pos];
    }
  }
  return(result);
}

# combines two chromosomes, so that regions of target colour common to
# both input chromosomes are in the result chromosome
chrUnion <- function(colourName, ChrX, ChrY, ChrOther = NULL, ...){
  if(is.null(ChrOther)){
    result <- rbind(ChrX, ChrY);
    result <- result[order(result$Points),];
    for(pos in 1:(dim(result)[1])){
      blockX <- ChrX$Block[max(which(ChrX$Points <= result$Points[pos]))];
      blockY <- ChrY$Block[max(which(ChrY$Points <= result$Points[pos]))];
      if(blockX == colourName){
        result$Block[pos] <- blockX;
      }
      if(blockY == colourName){
        result$Block[pos] <- blockY;
      }
    }
    result <- chrClean(result);
    return(result);
  } else {
    return(chrUnion(colourName, chrUnion(colourName, ChrX, ChrY), ChrOther, ...));
  }
}

## recombination descendancy, haplotype dilution
oc <- makeUniformChromosome("yellow");
g1 <- list(makeUniformChromosome("red"));
g2 <- list(
           chrClean(recombine(g1[[1]],oc)),
           chrClean(recombine(g1[[1]],oc))
           );
g2u<- chrUnion("red",g2[[1]],g2[[2]]);
g3 <- list(
           chrClean(recombine(g2[[1]],oc)),
           chrClean(recombine(g2[[1]],oc)),
           chrClean(recombine(g2[[2]],oc)),
           chrClean(recombine(g2[[2]],oc))
           );
g3u<- chrUnion("red",g3[[1]],g3[[2]],g3[[3]],g3[[4]]);
g4 <- list(
           chrClean(recombine(g3[[1]],oc)),
           chrClean(recombine(g3[[1]],oc)),
           chrClean(recombine(g3[[2]],oc)),
           chrClean(recombine(g3[[2]],oc)),
           chrClean(recombine(g3[[3]],oc)),
           chrClean(recombine(g3[[3]],oc)),
           chrClean(recombine(g3[[4]],oc)),
           chrClean(recombine(g3[[4]],oc))
           );
g4u<- chrUnion("red",g4[[1]],g4[[2]],g4[[3]],g4[[4]],
                g4[[5]],g4[[6]],g4[[7]],g4[[8]]);
g5 <- list(
           chrClean(recombine(g4[[1]],oc)),
           chrClean(recombine(g4[[1]],oc)),
           chrClean(recombine(g4[[2]],oc)),
           chrClean(recombine(g4[[2]],oc)),
           chrClean(recombine(g4[[3]],oc)),
           chrClean(recombine(g4[[3]],oc)),
           chrClean(recombine(g4[[4]],oc)),
           chrClean(recombine(g4[[4]],oc)),
           chrClean(recombine(g4[[5]],oc)),
           chrClean(recombine(g4[[5]],oc)),
           chrClean(recombine(g4[[6]],oc)),
           chrClean(recombine(g4[[6]],oc)),
           chrClean(recombine(g4[[7]],oc)),
           chrClean(recombine(g4[[7]],oc)),
           chrClean(recombine(g4[[8]],oc)),
           chrClean(recombine(g4[[8]],oc))
           );
g5u <- chrUnion("red",g5[[1]],g5[[2]],g5[[3]],g5[[4]],
                g5[[5]],g5[[6]],g5[[7]],g5[[8]],
                g5[[9]],g5[[10]],g5[[11]],g5[[12]],
                g5[[13]],g5[[14]],g5[[15]],g5[[16]]);

par(mar=c(0,0,0,0));
plot.new();
plot.window(xlim=c(0,1),ylim=c(0.2,1));
for(i in 1:8){
  drawChromosome(g5[[i*2-1]],xPos = (i-1)*0.125, yPos = 0.8,
                 scale = 0.4, new = FALSE);
  drawChromosome(g5[[i*2]],xPos = (i-1)*0.125+0.05, yPos = 0.8,
                 scale = 0.4, new = FALSE);
}
drawChromosome(g5u,xPos = (7)*0.125+0.125, yPos = 0.8, scale = 0.4, new = FALSE);
for(i in 1:4){
  drawChromosome(g4[[i*2-1]],xPos = (i-1)*0.25+0.0625, yPos = 0.58,
                 scale = 0.4, new = FALSE);
  drawChromosome(g4[[i*2]],xPos = (i-1)*0.25+0.0625+0.05, yPos = 0.58,
                 scale = 0.4, new = FALSE);
}
drawChromosome(g4u,xPos = (7)*0.125+0.095, yPos = 0.58, scale = 0.4, new = FALSE);
for(i in 1:2){
  drawChromosome(g3[[i*2-1]],xPos = (i-1)*0.5+0.1875, yPos = 0.4,
                 scale = 0.4, new = FALSE);
  drawChromosome(g3[[i*2]],xPos = (i-1)*0.5+0.1875+0.05, yPos = 0.4,
                 scale = 0.4, new = FALSE);
}
drawChromosome(g3u,xPos = (7)*0.125+0.065, yPos = 0.4, scale = 0.4, new = FALSE);
drawChromosome(g2[[1]],xPos = 0.4375, yPos = 0.22,
               scale = 0.4, new = FALSE);
drawChromosome(g2[[2]],xPos = 0.4375+0.05, yPos = 0.22,
               scale = 0.4, new = FALSE);
drawChromosome(g2u,xPos = (7)*0.125+0.035, yPos = 0.22, scale = 0.4, new = FALSE);
drawChromosome(g1[[1]],xPos = 0.0875, yPos = 0.22, scale = 0.4, new = FALSE);
arrows(x1=seq(0.035,0.91,length.out=8),
       x0=seq(0.035,0.91,length.out=8) + rep(c(0.015,-0.015),4),
       y1=0.79, y0=0.68, length = 0.1);
arrows(x1=seq(0.0975,0.8475,length.out=4),
       x0=seq(0.0975,0.8475,length.out=4) + rep(c(0.08,-0.08),2),
       y1=0.57, y0=0.5, length = 0.1);
arrows(x1=seq(0.2225,0.7225,length.out=2),
       x0=seq(0.2225,0.7225,length.out=2) + rep(c(0.2,-0.2),2),
       y1=0.39, y0=0.32, length = 0.1);
arrows(x1 = 0.42, x0 = 0.1275, y1 = 0.30, y0 = 0.30, length = 0.1);
arrows(x1 = 0.975, x0 = 0.875, y1 = 1.01, y0 = 0.21, length = 0);

## recombination ancestry, unbalanced haplotypes
g1 <- list(
           makeUniformChromosome("black"),
           makeUniformChromosome("red"),
           makeUniformChromosome("magenta"),
           makeUniformChromosome("blue"),
           makeUniformChromosome("cyan"),
           makeUniformChromosome("green"),
           makeUniformChromosome("yellow"),
           makeUniformChromosome("white"));
g2 <- list(
           recombine(g1[[1]],g1[[1]]),
           recombine(g1[[2]],g1[[2]]),
           recombine(g1[[3]],g1[[3]]),
           recombine(g1[[4]],g1[[4]]),
           recombine(g1[[5]],g1[[5]]),
           recombine(g1[[6]],g1[[6]]),
           recombine(g1[[7]],g1[[7]]),
           recombine(g1[[8]],g1[[8]]));
g3 <- list(
           recombine(g2[[1]],g2[[2]]),
           recombine(g2[[3]],g2[[4]]),
           recombine(g2[[5]],g2[[6]]),
           recombine(g2[[7]],g2[[8]]));
g4 <- list(
           recombine(g3[[1]],g3[[2]]),
           recombine(g3[[3]],g3[[4]]));
g5 <- list(
           recombine(g4[[1]],g4[[2]]));

pdf("recombination_ancestry.pdf",width=8,height=8);
par(mar=c(0,0,0,0));
plot.new();
plot.window(xlim=c(0,1),ylim=c(0.2,1));
for(i in 1:8){
  drawChromosome(g1[[i]],xPos = (i-1)*0.125, yPos = 0.8,
                 scale = 0.4, new = FALSE);
  drawChromosome(g1[[i]],xPos = (i-1)*0.125+0.05, yPos = 0.8,
                 scale = 0.4, new = FALSE);
}
for(i in 1:4){
  drawChromosome(g2[[i*2-1]],xPos = (i-1)*0.25+0.0625, yPos = 0.58,
                 scale = 0.4, new = FALSE);
  drawChromosome(g2[[i*2]],xPos = (i-1)*0.25+0.0625+0.05, yPos = 0.58,
                 scale = 0.4, new = FALSE);
}
for(i in 1:2){
  drawChromosome(g3[[i*2-1]],xPos = (i-1)*0.5+0.1875, yPos = 0.4,
                 scale = 0.4, new = FALSE);
  drawChromosome(g3[[i*2]],xPos = (i-1)*0.5+0.1875+0.05, yPos = 0.4,
                 scale = 0.4, new = FALSE);
}
drawChromosome(g4[[1]],xPos = 0.4375, yPos = 0.22,
               scale = 0.4, new = FALSE);
drawChromosome(g4[[2]],xPos = 0.4375+0.05, yPos = 0.22,
               scale = 0.4, new = FALSE);
drawChromosome(g5[[1]],xPos = 0.8375, yPos = 0.22, scale = 0.4, new = FALSE);
arrows(x0=seq(0.035,0.91,length.out=8),
       x1=seq(0.035,0.91,length.out=8) + rep(c(0.015,-0.015),4),
       y0=0.79, y1=0.68, length = 0.1);
arrows(x0=seq(0.0975,0.8475,length.out=4),
       x1=seq(0.0975,0.8475,length.out=4) + rep(c(0.08,-0.08),2),
       y0=0.57, y1=0.5, length = 0.1);
arrows(x0=seq(0.2225,0.7225,length.out=2),
       x1=seq(0.2225,0.7225,length.out=2) + rep(c(0.2,-0.2),2),
       y0=0.39, y1=0.32, length = 0.1);
arrows(x0 = 0.52, x1 = 0.82, y0 = 0.30, y1 = 0.30, length = 0.1);
dummy <- dev.off();


# <-- encoding UTF-8 -->
# Portal for the code of: Socioeconomic Status Inequality and Morbidity Rate Differences in China: Based on NHSS and CHARLS Data
# Author: Y. Jiang, H. Zheng, T. Zhao
# -------------------------------------------
## DOC STRING
#
# The script is the portal of all programs of our submtted paper;
# you may run this file, or follow the documentation, README, and comments to specific source files.
# Please refer to README.md for more information.
# and, all scripts & file I/O are encoded in UTF-8 (because Chinese charaters, in data and/or scripts, may be included & used)
#
# Tianhao Zhao (GitHub: Clpr)
# Dec 2018
# -------------------------------------------
## DEPENDENCY
#
# 1. readxl:    IO of xlsx files
# 2. plm:       panel data models
# 3. nlme:      GLS estimation of linear models
# 4. car:       VIFs, qqplots
# 5. ggplot2, plyr, maptools, mapproj, Cairo: map drawing
# 6. sqldf:     api of firendly sql enqury
# 7. nortest:   normality tests
# 8. purrr:     std lib, to do function operations
# 9. openxlsx:  easy xlsx I/O, no dependency on rJava
# 10. psych:    easier APIs for PCA
# -------------------------------------------

rm(list=ls()) # clear
setwd("C:/Users/Lenovo/OneDrive/GitHubProj/HealthInequality2018Dec")  # working directory

# -------------------------------------------
# Section 1: NHSS data processing & variable selection
cat("\nScript 1: NHSS data processing & variable selection")
# MISSION:
#       1. NHSS data I/O
#       2. NHSS data processing, missing values
#       3. collinearity between income & edu: resid(income ~ edu) --> income
#       4. NHSS (control) variable selection I: through single-variable regressions
#       5. NHSS (control) variable selection II: PCA
#       6. VIFs of final specifications
source("./scripts/proc_1_NHSS.r")
# LEGACY IN WORKSPACE:
#       1. df_NHSSraw:              raw NHSS dataset, consisting of all potential vars & useless vars; as backup
#       2. df_NHSS:                 processed NHSS dataset
#       3. li_Dat_NHSS:             datasets for every specification
#       3. li_DatPlm_NHSS:          panel-data for every specification
#       4. li_PCAres_NHSS:          PCA results
#       5. li_PCAk_NHSS:            numebr of components used in every specification
#       5. li_VIF_NHSS:             VIF results of final specifications
#       6. li_Eq_NHSS:              a list consisting of formula objects of final specifications
#       7. li_Xnames_NHSS:          a list of namelists of independents of every specification
#       7. envNHSS:                 environment variables of NHSS dataset
# NOTE: pls go to ./output/proc_1_NHSS/ for output results (if applicable)
# ---------------------------------------------

# ---------------------------------------------
# Section 2: NHSS data, descriptive statistics (basic and advanced)
cat("\nScript 2: NHSS data descriptive statistics")
# DEPENDENCY: using legacy of proc_1_NHSS.r
# MISSION:
#       1. NHSS data, general descriptive stats (mean, sd etc)
#       2. county-level (individual) Lorenz Curve & Gini coef of health outcomes
#       3. county-level (individual) Theil-I, Theil-II
#       4. county-level (individual) C.V., coefficient of variance
#       5. county-level (individual) Variance
#       6. NHSS data, the existence of the inequalities of health outcomes among areas in China (colored map)
#       7. NHSS data, the difference of (income & edu) among areas in china (colored map)
source("./scripts/proc_2_NHSS.r")
# LEGACY IN WORKSPACE:
#       1. li_Descript_NHSS:            tables of the descriptive statistics of NHSS data (only income & edu, we do not do this on normalized+centered principle components!)
#       2. df_InequalIdx_NHSS:          a table of different kinds of inequality indices of NHSS data
#       3. MapShapeCH:                  a dataset of Chinese GIS data; will be used later
#       4. func_DescrStat:              a function to do descriptive statistics
#       5. func_MapProv:                draws colored map based on Chinese GIS data; province level
#       6. func_SaveMap2PDF:            easy output method of the figures created by func_MapProv()
#       7. LorenzCurve:                 easy function to compute Lorenz curve & Gini coef
#       8. Theil:                       easy function to compute Theil-I/II index
#       9. TrapeInt:                    easy function to compute trapezium integral
# NOTE: pls go to ./output/proc_2_NHSS/ for output results (applicable)
# ---------------------------------------------

# ---------------------------------------------
# Section 3: NHSS data, econometric analysis (pool, fix, random, Hausman)
cat("\nScript 3: NHSS data, econometric analysis (pool, fix, random, Hausman)")
# DEPENDENCY: using legacy of proc_1_NHSS.r
#
# IMPORTANT NOTE: please refer to PanelAnalysisLogic.md under the ./docs directory to help understand how we designed this section !!! :)
#
# MISSION:
#       1. one-way fixed individual effect model & random individual effect model (FGLS estimators)
#       2. Hausman test & robust Hausman test (Wooldridge, 2010)
#       3. Residual QQplots & normality tests, one-way fixed individual effect model (only)
#       4. ROBUST: two-ways fixed effect model & Haussman test (to see if one-way & two-ways are consistent)
#       5. ROBUST: pooling, OLS
#       6. ROBUST: pooling, FGLS
#
#       5. ROBUST: add possible independent:
source("./scripts/proc_3_NHSS.r")
# LEGACY IN WORKSPACE:
# NOTE: pls go to ./output/proc_3_NHSS/ for output results (applicable)
# -------------------------------------------

# -------------------------------------------
# Section 4: CHARLS data processing & variable selection
cat("\nScript 4: CHARLS data processing & variable selection")
# MISSION:
#       1. CHARLS data I/O
#       2. CHARLS data processing, missing values
#       3. collinearity between income & edu: resid(income ~ edu) --> income
#       4. CHARLS (control) variable selection I: through single-variable regressions
#       5. CHARLS (control) variable selection II: AIC stepwise to FURTHER select control variables into final specifications
#       6. VIFs of final specifications
source("./scripts/proc_1_CHARLS.r")
# LEGACY IN WORKSPACE:
#       1. df_CHARLS_backup:            raw CHARLS dataset, consisting of all potential vars & useless vars; as backup
#       2. df_CHARLS:                   processed CHARLS dataset
#       3. dfp_CHARLS:                  a panel-data-type dataframe (converted from df_NHSS, used in package plm)
#       4. df_FinalSpecif_CHARLS:       a dataframe marking which variables in the final specifications
#       5. df_VIF_CHARLS:               VIF results of final specifications
#       6. li_Eq_CHARLS:                a list consisting of formula objects of final specifications
#       7. envCHARLS:                   environment variables of CHARLS dataset
# NOTE: pls go to ./output/proc_1_CHARLS/ for output results (if applicable)
# ---------------------------------------------

# ---------------------------------------------
# Section 5: CHARLS data, descriptive statistics (basic and advanced)
cat("\nScript 5: CHARLS data, descriptive statistics (basic and advanced)")
# DEPENDENCY: using legacy of proc_1_NHSS.r
# MISSION:
#       1. CHARLS data, general descriptive stats (mean, sd etc)
#       2. county-level (individual) Lorenz Curve & Gini coef of health outcomes
#       3. county-level (individual) Theil-I, Theil-II
#       4. county-level (individual) C.V., coefficient of variance
#       5. county-level (individual) Variance
#       6. CHARLS data, the existence of the inequalities of health outcomes among areas in China (colored map)
#       7. CHARLS data, the difference of (income & edu) among areas in china (colored map)
source("./scripts/proc_2_CHARLS.r")
# LEGACY IN WORKSPACE:
#       1. df_Descript_CHARLS:      a table of the descriptive statistics of NHSS data (final specification)
#       2. df_InequalIdx_CHARLS:    a table of different kinds of inequality indices of NHSS data
#       3. MapShapeCH:              a dataset of Chinese GIS data; will be used later
#       4. func_DescrStat:          a function to do descriptive statistics
#       5. func_MapProv:            draws colored map based on Chinese GIS data; province level
#       6. func_SaveMap2PDF:        easy output method of the figures created by func_MapProv()
#       7. LorenzCurve:             easy function to compute Lorenz curve & Gini coef
#       8. Theil:                   easy function to compute Theil-I/II index
#       9. TrapeInt:                easy function to compute trapezium integral
# NOTE: pls go to ./output/proc_2_CHARLS/ for output results (applicable)
# ---------------------------------------------

# ---------------------------------------------
# Section 6: CHARLS data, econometric analysis (pool, fix, random, Hausman)
cat("\nScript 3: CHARLS data, econometric analysis (pool, fix, random, Hausman)")
# DEPENDENCY: using legacy of proc_1_CHARLS.r
#
# IMPORTANT NOTE: please refer to PanelAnalysisLogic.md under the ./docs directory to help understand how we designed this section !!! :)
#
# MISSION:
#       1. one-way fixed individual effect model & random individual effect model (FGLS estimators)
#       2. Hausman test & robust Hausman test (Wooldridge, 2010)
#       3. Residual QQplots & normality tests, one-way fixed individual effect model (only)
#       4. ROBUST: two-ways fixed effect model & Haussman test (to see if one-way & two-ways are consistent)
#       5. ROBUST: pooling, OLS
#       6. ROBUST: pooling, FGLS
#
#       5. ROBUST: add possible independent:
source("./scripts/proc_3_CHARLS.r")
# LEGACY IN WORKSPACE:
# NOTE: pls go to ./output/proc_3_CHARLS/ for output results (applicable)
# -------------------------------------------


###############################################################################
# "Infection Rate Models for COVID-19:
#  Model Risk and Public Health News Sentiment Exposure Adjustments"
#
#  Ioannis Chalkiadakis, Kevin Hongxuan Yan, Gareth W. Peters, Pavel V. Shevchenko
#
#  Kevin Hongxuan Yan
#  March 2021
###############################################################################

####### read new data Y
setwd("./covid19modelrisk/data/covid19_infected/")

  y_GM=read.csv("COVID-19_confirmed__Germany.csv")[,2]
  y_IT=read.csv("COVID-19_confirmed__Italy.csv")[,2]
  y_JP=read.csv("COVID-19_confirmed__Japan.csv")[,2]
  y_SP=read.csv("COVID-19_confirmed__Spain.csv")[,2]
  y_UK=read.csv("COVID-19_confirmed__United Kingdom.csv")[,2]
  y_US=read.csv("COVID-19_confirmed__US.csv")[,2]
  y_AU=read.csv("COVID-19_confirmed_Australia.csv")[,2]

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")

pdf("UK_tplot.pdf", width = 16.5, height = 8.50)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y_UK,main=name[5],xlab="time",ylab="count",xaxt = 'n')
axis(1, at=c(0,100,length(y_UK)), labels=c("Jan/31","May/09","Aug/06"))   ### UK
dev.off()

pdf("GM_tplot.pdf", width = 16.5, height = 8.50)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y_GM,main=name[1],xlab="time",ylab="count",xaxt = 'n')
axis(1, at=c(0,100,length(y_GM)), labels=c("Jan/27","May/05","Aug/06"))   ### GM
dev.off()

pdf("IT_tplot.pdf", width = 16.5, height = 8.50)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y_IT,main=name[2],xlab="time",ylab="count",xaxt = 'n')
axis(1, at=c(0,100,length(y_IT)), labels=c("Jan/31","May/09","Aug/06"))   ### IT
dev.off()

pdf("SP_tplot.pdf", width = 16.5, height = 8.50)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y_SP,main=name[4],xlab="time",ylab="count",xaxt = 'n')
axis(1, at=c(0,100,length(y_SP)), labels=c("Feb/01","May/10","Aug/06"))   ### SP
dev.off()

pdf("US_tplot.pdf", width = 16.5, height = 8.50)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y_US,main=name[6],xlab="time",ylab="count",xaxt = 'n')
axis(1, at=c(0,100,length(y_US)), labels=c("Jan/22","Apr/30","Aug/06"))   ### US
dev.off()

pdf("JP_tplot.pdf", width = 16.5, height = 8.50)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y_JP,main=name[3],xlab="time",ylab="count",xaxt = 'n')
axis(1, at=c(0,100,length(y_JP)), labels=c("Jan/22","Apr/30","Aug/06"))   ### JP
dev.off()

pdf("AU_tplot.pdf", width = 16.5, height = 8.50)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y_AU,main=name[7],xlab="time",ylab="count",xaxt = 'n')
axis(1, at=c(0,100,length(y_AU)), labels=c("Jan/26","May/04","Aug/06"))   ### AU
dev.off()

####################  Violin plot

library(methods)
library(rstan)

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")
abn=c("GM","IT","JP","SP","UK","US","AU")

k=7

setwd("C:\\Users\\yhx19\\Desktop\\NEW RUN\\M2 Rdata")
load(paste("M2_",abn[k],".Rdata", sep=""))
Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , mean )
res=Epars_m-y
Res_2=(res-mean(res))/(sd(res))
R_2=cbind(Res_2,rep("M2",length(Res_2)))

setwd("C:\\Users\\yhx19\\Desktop\\NEW RUN\\M4 Rdata")
load(paste("M4_",abn[k],".Rdata", sep=""))
Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(7+N):(6+2*N)] , 2 , mean )
res=Epars_m-y
Res_4=(res-mean(res))/(sd(res))
R_4=cbind(Res_4,rep("M4",length(Res_4)))

setwd("C:\\Users\\yhx19\\Desktop\\NEW RUN\\M7 Rdata")
load(paste("M7_",abn[k],".Rdata", sep=""))
Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(7+N):(6+2*N)] , 2 , mean )
res=Epars_m-y
Res_7=(res-mean(res))/(sd(res))
R_7=cbind(Res_7,rep("M7",length(Res_7)))

setwd("C:\\Users\\yhx19\\Desktop\\NEW RUN\\M8 Rdata")
load(paste("M8_",abn[k],".Rdata", sep=""))
Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(8+N):(7+2*N)] , 2 , mean )
res=Epars_m-y
Res_8=(res-mean(res))/(sd(res))
R_8=cbind(Res_8,rep("M8",length(Res_8)))

setwd("C:\\Users\\yhx19\\Desktop\\NEW RUN\\M9 Rdata")
load(paste("M9_",abn[k],".Rdata", sep=""))
Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , mean )
res=Epars_m-y
Res_9=(res-mean(res))/(sd(res))
R_9=cbind(Res_9,rep("M9",length(Res_9)))

setwd("C:\\Users\\yhx19\\Desktop\\NEW RUN\\M10 Rdata")
load(paste("M10_",abn[k],".Rdata", sep=""))
Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(8+N):(7+2*N)] , 2 , mean )
res=Epars_m-y
Res_10=(res-mean(res))/(sd(res))
R_10=cbind(Res_10,rep("M10",length(Res_10)))

setwd("C:\\Users\\yhx19\\Desktop\\NEW RUN\\M11 Rdata")
load(paste("M11_",abn[k],".Rdata", sep=""))
Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(8+N):(7+2*N)] , 2 , mean )
res=Epars_m-y
Res_11=(res-mean(res))/(sd(res))
R_11=cbind(Res_11,rep("M11",length(Res_11)))

setwd("C:\\Users\\yhx19\\Desktop\\NEW RUN\\M12 Rdata")
load(paste("M12_",abn[k],".Rdata", sep=""))
Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(7+N):(6+2*N)] , 2 , mean )
res=Epars_m-y
Res_12=(res-mean(res))/(sd(res))
R_12=cbind(Res_12,rep("M12",length(Res_12)))

setwd("C:\\Users\\yhx19\\Desktop\\NEW RUN\\final plot")

pdf(paste(abn[k],"_plot.pdf",sep=""), width = 16.5, height = 8.50)

library("vioplot")
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
vioplot(Res_2,Res_4,Res_7,Res_8,Res_9,Res_10,Res_11,Res_12,names=c("M2","M4","M7","M8","M9","M10","M11","M12"))
title(paste("Residual plots for ",name[k],sep=""))

dev.off()

##############   boxplot   ########################################################################################################################################

library(methods)
library(rstan)

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")
abn=c("GM","IT","JP","SP","UK","US","AU")

k=3

setwd("C:\\Users\\yhx19\\Desktop\\NEW RUN\\M2 Rdata")    ##### change
load(paste("M2_",abn[k],".Rdata", sep=""))    ##### change
Epars <- as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)]

res_all=matrix(,nrow=dim(Epars)[1],ncol=dim(Epars)[2])
Y_m=matrix(rep(y,nrow=dim(Epars)[1]),nrow=dim(Epars)[1],ncol=dim(Epars)[2],byrow=T)
res_all=as.matrix(Epars-Y_m)

res_st=matrix(,nrow=dim(Epars)[1],ncol=dim(Epars)[2])
for (i in 1:dim(Epars)[1]){
res_st[i,]=(res_all[i,]-mean(res_all[i,]))/(sd(res_all[i,]))
}

setwd("C:\\Users\\yhx19\\Desktop\\NEW RUN\\final plot")

pdf(paste(abn[k],"_boxplot.pdf",sep=""), width = 16.5, height = 8.50)

par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
boxplot(res_st,xlab="time steps")
title(paste("M2 residual boxplots for ",name[k],sep=""))   ##### change

dev.off()

##############   NEW plot   ########################################################################################################################################
##############   NEW plot   ########################################################################################################################################

####### read new data Y
setwd("G:\\Covid paper\\additionalcountdataofinfectedcases\\new data")

  y_GM=read.csv("COVID-19_confirmed__Germany_latest_Feb.csv")[,2]
  y_IT=read.csv("COVID-19_confirmed__Italy_latest_Feb.csv")[,2]
  y_JP=read.csv("COVID-19_confirmed__Japan_latest_Feb.csv")[,2]
  y_SP=read.csv("COVID-19_confirmed__Spain_latest_Feb.csv")[,2]
  y_UK=read.csv("COVID-19_confirmed__United Kingdom_latest_Feb.csv")[,2]
  y_US=read.csv("COVID-19_confirmed__US_latest_Feb.csv")[,2]
  y_AU=read.csv("COVID-19_confirmed_Australia_latest_Feb.csv")[,2]

D_GM=c("Jan/27","May/05","Aug/13","Nov/21","Jan/10")
D_IT=c("Jan/31","May/09","Aug/17","Nov/25","Jan/14")
D_JP=c("Jan/22","Apr/30","Aug/08","Nov/16","Jan/5")
D_SP=c("Feb/01","May/10","Aug/18","Nov/26","Jan/15")
D_UK=c("Jan/31","May/09","Aug/17","Nov/25","Jan/14")
D_US=c("Jan/22","Apr/30","Aug/08","Nov/16","Jan/5")
D_AU=c("Jan/26","May/04","Aug/12","Nov/20","Jan/9")

Date=c(D_GM,D_IT,D_JP,D_SP,D_UK,D_US,D_AU)

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")

k=5
pdf("UK_tplot_LONG.pdf", width = 16.5, height = 8.50)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y_UK,main=name[5],xlab="time",ylab="count",xaxt = 'n')
axis(1, at=c(0,100,200,300,350), labels=c("Jan/31","May/09","Aug/17","Nov/25","Jan/14"))
   ### UK
dev.off()

k=1
pdf("GM_tplot_LONG.pdf", width = 16.5, height = 8.50)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y_GM,main=name[1],xlab="time",ylab="count",xaxt = 'n')
axis(1, at=c(0,100,200,300,350), labels=c("Jan/27","May/05","Aug/13","Nov/21","Jan/10"))
   ### GM
dev.off()

k=2
pdf("IT_tplot_LONG.pdf", width = 16.5, height = 8.50)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y_IT,main=name[2],xlab="time",ylab="count",xaxt = 'n')
axis(1, at=c(0,100,200,300,350), labels=c("Jan/31","May/09","Aug/17","Nov/25","Jan/14"))
   ### IT
dev.off()

k=4
pdf("SP_tplot_LONG.pdf", width = 16.5, height = 8.50)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y_SP,main=name[4],xlab="time",ylab="count",xaxt = 'n')
axis(1, at=c(0,100,200,300,350), labels=c("Feb/01","May/10","Aug/18","Nov/26","Jan/15"))
   ### SP
dev.off()

k=6
pdf("US_tplot_LONG.pdf", width = 16.5, height = 8.50)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y_US,main=name[6],xlab="time",ylab="count",xaxt = 'n')
axis(1, at=c(0,100,200,300,350), labels=c("Jan/22","Apr/30","Aug/08","Nov/16","Jan/5"))
   ### US
dev.off()

k=3
pdf("JP_tplot_LONG.pdf", width = 16.5, height = 8.50)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y_JP,main=name[3],xlab="time",ylab="count",xaxt = 'n')
axis(1, at=c(0,100,200,300,350), labels=c("Jan/22","Apr/30","Aug/08","Nov/16","Jan/5"))
   ### JP
dev.off()

k=7
pdf("AU_tplot_LONG.pdf", width = 16.5, height = 8.50)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y_AU,main=name[7],xlab="time",ylab="count",xaxt = 'n')
axis(1, at=c(0,100,200,300,350), labels=c("Jan/26","May/04","Aug/12","Nov/20","Jan/9"))
   ### AU
dev.off()


##
# layer_class.r
# Copyright (C) Jonathan Bramble 2011
#
# FBF-Optics is free software: you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the
# Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# FBF-Optics is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
# See the GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with this program.  If not, see <http://www.gnu.org/licenses/>.
#

#' An S4 class to represent a thin dielectric or metallic layer.
#'
#' @slot d Thickness of the layer in m
#' @slot eps The relative permittivity of the material as a complex number
#'

IsoLayer <- setClass("IsoLayer",
         representation(
           fitd="logical",
           dstart="numeric",
           dend="numeric",
           d="numeric",
           eps="complex"
         ),
         prototype(fitd=FALSE,dstart=0.0,dend=0.0,d=0.0,eps=0+0i)
)

setGeneric("d<-",function(x,value) standardGeneric("d<-"))
setReplaceMethod("d","IsoLayer", function(x,value) {x@d <- value; validObject(x); x})

#' An S4 class to represent anisotropic layer.
#'
#' @slot d Thickness of the layer in m
#' @slot epsx The relative permittivity of the material in the x direction
#' @slot epsy The relative permittivity of the material in the y direction
#' @slot epsz The relative permittivity of the material in the z direction
#' @slot theta angle of the molecular axis in relation to the prism axis - see diagram
#' @slot phi angle of the molecular axis in relation to the prism axis - see diagram
#' @slot S the order parameter for the layer
#'

AnisoLayer <- setClass("AnisoLayer",
                     representation(
                       d="numeric",
                       epsx="numeric",
                       epsy="numeric",
                       epsz="numeric",
                       theta="numeric",
                       phi="numeric",
                       S="numeric"
                     )
)

setMethod("show", signature(object="IsoLayer"),function(object){
  cat(" Isotropic Layer data \n")
})

setMethod("show", signature(object="AnisoLayer"),function(object){
  cat(" Anisotropic Layer data \n")
  cat(" Layer Thickness:", object@d , "\n")
  cat(" eps along x:", object@epsx , "\n")
  cat(" eps along y:", object@epsy , "\n")
  cat(" eps along z:", object@epsz , "\n")
  cat(" Theta angle:", object@theta, "\n")
  cat(" Phi angle:", object@phi , "\n")
  cat(" Order Parameter S:", object@S , "\n")
})


#functions used to calculate diversity statistics within populations
# make sure the output file is already written in format (header):
# population1   population2     statistic       chromosome      start   end     number_sites    number_variable_sites   calculated_stat
# e.g., write(c("pop1", "pop2", "stat", "chr", "start", "end", "number_sites", "number_variable_sites", "calculated_stat"), ncolumns=9, file=outname, sep="\t")

# input is simplified vcf (entire vcf) and 3-column popmap (ordered the same as the vcf) and output file name
# and the input simple vcf file name that contains the chr and start and end information
# only calculate for invariant sites and biallelic snps
heterozygosity <- function(xxx, popmap, outname, filename) {
        options(scipen=999)
        xxx <- xxx[nchar(xxx[,2]) == 1 & nchar(xxx[,3]) == 1, ]
        for(a in 1:nrow(popmap)) {
                output_rep <- c(popmap[a,1], "none", "heterozygosity", strsplit(filename, ":")[[1]][1],
                        as.numeric(strsplit(strsplit(filename, ":")[[1]][2], "-")[[1]][1]),
                        as.numeric(strsplit(strsplit(filename, "-")[[1]][2], ".simple")[[1]][1]))
                # select this individual
                a_rep <- xxx[,a+3]
                # remove missing genotypes
                a_rep <- a_rep[a_rep != "./."]
                # count number of sites
                a_total <- length(a_rep)
                # remove phasing information
                a_rep <- gsub("\\|", "/", a_rep)
                # find number of heterozygous sites
                a_het <- length(a_rep[a_rep == "0/1"])
                # add to output
                output_rep <- c(output_rep, a_total, a_het, a_het/a_total)
                write(output_rep, file=outname, append=T, ncolumns=9, sep="\t")
        }
}

# helper function to identify transition variants from biallelic alleles in rows (used in titv function)
transitions <- function(x1) {
	a_rep <- sort(x1)
	if(a_rep[1] == "A" & a_rep[2] == "G") {
		return(1)
	} else if(a_rep[1] == "C" & a_rep[2] == "T") {
		return(1)
	} else {
		return(0)
	}
}

# input is simplified vcf (entire vcf) and other files as in heterozygosity calcs, to calculate transition transversion ratio
titv <- function(xxx, popmap, outname, filename) {
        options(scipen=999)
        xxx <- xxx[nchar(xxx[,2]) == 1 & nchar(xxx[,3]) == 1, ]
        # filter to variable sites
        xxx <- xxx[xxx[,3] != ".", ]

        # sites used for titv
        # total sites used same as het sites
        a_total <- nrow(xxx)
        a_het <- a_total

        # find number of transitions using helper function
        total_transitions <- sum(apply(xxx[,2:3], 1, transitions))
        # calculate transition / transversion ratio
        titv_ratio <- total_transitions / (a_total - total_transitions)

        # output info
        output_rep <- c("all_inds", "none", "titv", strsplit(filename, ":")[[1]][1],
                        as.numeric(strsplit(strsplit(filename, ":")[[1]][2], "-")[[1]][1]),
                        as.numeric(strsplit(strsplit(filename, "-")[[1]][2], ".simple")[[1]][1]))

        output_rep <- output_rep <- c(output_rep, a_total, a_het, titv_ratio)
        write(output_rep, file=outname, append=T, ncolumns=9, sep="\t")

}

# input is one simplified vcfs,
# the popmap, and output file name
# and the input simple vcf file name that contains the chr and start and end information
# only for invariant sites and biallelic snps
# lastly, input number of sites needed to write file

create_fasta_from_vcf <- function(xxx, popmap, outname, filename, num_sites_needed) {
        options(scipen=999)
        # remove sites that are not either invariant or bi-allelic SNPs
        xxx <- xxx[nchar(xxx[,2]) == 1 & nchar(xxx[,3]) == 1, ]

        # keep going only if enough sites
        if(num_sites_needed <= nrow(xxx)) {
                # remove phasing information
                for(a in 4:ncol(xxx)) {
                        xxx[,a] <- gsub("\\|", "/", xxx[,a])
                }

                # define names of individuals in output fasta
                output_names_fasta <- paste(">", popmap[,1], sep="")

                # subset the genotypes from the allele info
                allele_info <- xxx[,2:3]
                genotypes <- xxx[,4:ncol(xxx)]

                # convert all numbers in genotypes to actual bases and ambiguities
                for(a in 1:nrow(genotypes)) {
                        if(allele_info[a,2] == ".") { # if non-polymorphic
                                genotypes[a,] <- gsub("0/0", allele_info[a,1], genotypes[a,])
                                genotypes[a,] <- gsub("\\./\\.", "?", genotypes[a,])
                        } else { # if polymorphic
                                both_genotypes <- sort(as.character(allele_info[a,]))
                                if(both_genotypes[1] == "A" & both_genotypes[2] == "C") { het = "M" }
                                if(both_genotypes[1] == "A" & both_genotypes[2] == "G") { het = "R" }
                                if(both_genotypes[1] == "A" & both_genotypes[2] == "T") { het = "W" }
                                if(both_genotypes[1] == "C" & both_genotypes[2] == "G") { het = "S" }
                                if(both_genotypes[1] == "C" & both_genotypes[2] == "T") { het = "Y" }
                                if(both_genotypes[1] == "G" & both_genotypes[2] == "T") { het = "K" }
                                genotypes[a,] <- gsub("0/0", allele_info[a,1], genotypes[a,])
                                genotypes[a,] <- gsub("\\./\\.", "?", genotypes[a,])
                                genotypes[a,] <- gsub("1/1", allele_info[a,2], genotypes[a,])
                                genotypes[a,] <- gsub("0/1", het, genotypes[a,])
                        }
                }

                  # write output
                for(a in 1:ncol(genotypes)) {
                        if(a == 1) {
                                write(output_names_fasta[a], file=outname, ncolumns=1)
                                write(paste(genotypes[,a], collapse=""), file=outname, ncolumns=1, append=T)
                        } else {
                                write(output_names_fasta[a], file=outname, ncolumns=1, append=T)
                                write(paste(genotypes[,a], collapse=""), file=outname, ncolumns=1, append=T)
                        }
                }
        }
}


calc_fct <- function(res, ncores = NULL, SourceSplit = NULL,
  dxy = 1, # in m
  tolerance = 1e-5, # digits for rounding
  checkArea = TRUE
  ){

  if(!is.null(ncores)) setDTthreads(ncores)

  # convert old versions
  sres <- as.character(substitute(res))
  res <- copy(res)
  if(is.null(attr(res, "Version"))){
    warning(paste0("Object '", sres[min(length(sres), 2)], "' has not yet been converted to version 4.2+"))
    convert(res)
  }

  for(g in 1:20) gc()

  # get relevant sources
  uSous <- res[, unique(Source)]
  Sources <- attr(res, "ModelInput")$Sources
  SourcesList <- lapply(uSous, function(x){
    out <- Sources[Sources[,1] %in% x,]
    attr(out, "area") <- getArea(out)
    out
    })
  names(SourcesList) <- uSous

  # get relevant sensors
  uSens <- res[, unique(Sensor)]
  Sensors <- attr(res, "ModelInput")$Sensors
  C_sens_all <- procSensors(Sensors)$Calc.Sensors
  C_sens <- C_sens_all[C_sens_all[, "Sensor Name"] %in% uSens, ]

  # get relevant catalogs
  uRn <- res[, unique(rn)]
  All_cats <- Catalogs(res)[Sensor %in% uSens & rn %in% uRn]
  # prepare catalogs
  Cat_Path <- CatPath(res)
  All_cats[, CatNum := as.integer(as.factor(Cat.Name))]
  C_cats <- All_cats[,{
    .(
      CatNameList = list(setNames(Cat.Name, PointSensor)),
      CatNums = paste(sort(unique(CatNum)), collapse = ","),
      Subset_seed = seed[1]
      )
  }, by = .(rn, Sensor)]

  # split sources into sub areas
  if(is.null(SourceSplit)) {
    # split
    SourceSplit <- splitSource(Sources[Sources[, 1] %in% uSous, ],
      dxy = dxy, tolerance = tolerance, checkArea = checkArea)
  } else {
    for(i in seq_along(SourceSplit)){
      for(j in seq_along(SourceSplit[[i]])){
        # allocate memory
        SourceSplit[[i]][[j]]$polygons <- alloc.col(SourceSplit[[i]][[j]]$polygons)
      }
    }
  }

  # copy original data.table & add columns
  Calc <- merge(res[,.(
    rn,
    Sensor,
    Source,
    # Subset_seed,
    WD,
    SensorHeight,
    Ustar,
    L,
    Zo,
    sUu,
    sVu,
    bw,
    C0,
    kv,
    A,
    alpha,
    MaxFetch,
    N0,
    fct = NA_real_
    )], C_cats, by = c("rn", "Sensor"))

  if(!is.null(ncores) && ncores > 1){
    # showConnections(T)
    # getConnection(3)
    cl <- parallel::makePSOCKcluster(ncores)
    on.exit(parallel::stopCluster(cl))
    parallel::clusterEvalQ(cl, {
      # library(data.table)
      # library(bLSmodelR)
      data.table::setDTthreads(1)
    })
    # call parallel
    InList <- lapply(seq_len(nrow(Calc)), function(x, y) y[x, ], y = as.data.frame(Calc))
    parallel::clusterExport(cl, c("SourceSplit", "SourcesList", "C_sens"), envir = environment())
    fct <- unlist(parallel::clusterApplyLB(cl, InList, .fct,
      C_Path = Cat_Path, parallel = TRUE))
    # fct <- unlist(parallel::clusterApplyLB(cl, InList, .fct,
    #   SouSp = SourceSplit, SouLi = SourcesList, c_sens = C_sens,
    #   C_Path = Cat_Path))
    parallel::stopCluster(cl)
    on.exit()
  } else {

    for(g in 1:20) gc()

    # loop over rows
    fct <- .fct(Calc, SouSp = SourceSplit, SouLi = SourcesList,
      c_sens = C_sens, C_Path = Cat_Path)
  }

  cbind(res, fct = fct)
}

# loop over rows
.fct <- function(DT, SouSp = SourceSplit, SouLi = SourcesList, c_sens = C_sens,
  C_Path = Cat_Path, parallel = FALSE){
  if(parallel){
    setDT(DT)
    for(i in seq_along(SouSp)){
      for(j in seq_along(SouSp[[i]])){
        # allocate memory
        SouSp[[i]][[j]]$polygons <- alloc.col(SouSp[[i]][[j]]$polygons)
      }
    }
  }

  DT[,{
    if(!parallel){
      cat("*** row", .BY[[1]], "\n")
    }
    # get source
    iSource <- SouSp[[Source]]
    # add inside tag
    for(j in seq_along(iSource)){
      iSource[[j]]$polygons[, isInside := FALSE]
    }

    # list with point sensor names
    Point_Sensor <- split(names(CatNameList[[1]]), CatNameList[[1]])

    # loop over Catalogs
    for(Cat_Name in unique(CatNameList[[1]])){
      # get Catalog
      Cat0 <- readCatalog(file.path(C_Path, Cat_Name))
      # initialize
      initializeCatalog(.SD, Catalog = Cat0)
      # get cat N0
      Cat_N0 <- attr(Cat0, "N0")
      # take subset
      if (Cat_N0 > N0) {
        env <- globalenv()
        oseed <- env$.Random.seed
        set.seed(Subset_seed, kind = "L'Ecuyer-CMRG")
        takeSub <- sample.int(Cat_N0, N0)
        if (is.null(oseed)) {
            rm(list = ".Random.seed", envir = env)
        } else {
            assign(".Random.seed", value = oseed, envir = env)
        }
        indexNew <- 1:N0
        names(indexNew) <- takeSub
        Cat0 <- Cat0[Traj_ID %in% takeSub, ]
        Cat0[, Traj_ID := indexNew[as.character(Traj_ID)]]
      }
      # rotate catalog
      rotateCatalog(Cat0, WD)

      # loop over point sensors
      for(ps in Point_Sensor[[Cat_Name]]){
        cat("|\t", ps, "\n")
        Sens_xy <- as.numeric(c_sens[c_sens[, "Point Sensor Name"] %in% ps,
          c("x-Coord (m)", "y-Coord (m)")])
        # copy catalog
        Cat <- Cat0[, .(x, y, inside = TRUE, inside0 = FALSE)]
        # add Sensor x & y
        Cat[, ":="(
          x = x + Sens_xy[1],
          y = y + Sens_xy[2]
          )]
        # get IDs inside, initial inside has to be TRUE
        tagNear(Cat, apply(SouLi[[Source[1]]][,2:3], 2, range))
        Cat[, inside0 := inside]
        # initialize all_check
        all_check <- 0
        # loop over sources
        for(jSrc in seq_along(iSource)){
          # jSrc <- 1
          iSource[[jSrc]]$polygons[(!isInside), isInside := {
            # copy from original inside
            Cat[, inside := inside0]
            # tag near
            tagNear(Cat[(inside)], .(x, y))
            C_sub <- Cat[(inside), .(x, y)]
            any(as.logical(.Call("pip", C_sub[, x], C_sub[, y], C_sub[, .N], x, y, length(x), PACKAGE = "bLSmodelR")))
          }, by = .(tile, polygon)]
          all_check <- all_check + iSource[[jSrc]]$polygons[, as.integer(all(isInside))]
        }
        # stop if all tiles covered
        if(all_check == length(iSource)) break
      }
      # stop if all tiles covered
      if(all_check == length(iSource)) break
    }
    # calculate & return fct
    .(
      fct = sum(
        unlist(
          lapply(iSource, function(X)
            X$polygons[(isInside), area[1], by = .(tile, polygon)][, sum(V1)]
          )
        )
      ) / attr(SouLi[[Source[1]]], "area")
    )
  }, by = .(.Row__ = seq_len(nrow(DT)))][order(.Row__), fct]
}

splitSource <- function(
  SourceIn,
  dxy = 1, # in m
  tolerance = 1e-5, # digits for rounding
  checkArea = TRUE
  ) {
  digits <- -floor(log10(tolerance))
  tol <- 10 ^ -digits

  setNumericRounding(2)

  # get source names
  uSourceNames <- unique(SourceIn[, 1])

  out <- lapply(uSourceNames, function(SourceName){
    # SourceName <- Source[1,1]
    Source <- SourceIn[SourceIn[, 1] %in% SourceName, ]
    # start lapply over polyID
    lapply(unique(Source[,4]), function(polyID){
      SubSource <- Source[Source[,4] %in% polyID,]
      xyMeans <- colMeans(SubSource[,2:3])
      SubSource[,2:3] <- round(sweep(SubSource[, 2:3], 2, xyMeans), digits - 1)
      Poly <- setNames(SubSource[,2:3], c("x", "y"))
      Poly_extr <- attr(procSources(SubSource), "SourceList")[[SourceName]][, 1:2]
      Poly_lines <- lapply(seq_len(nrow(Poly_extr) - 1), function(x) {
        list(
          p1 = as.numeric(Poly_extr[x, ]),
          p2 = as.numeric(Poly_extr[x + 1, ])
          )
      })
      # # possibly problems with values close to 0?
      # Poly_lines_dir <- lapply(Poly_lines, function(x){
      #   list(x = sign(x$p2[1] - x$p1[1]), y = sign(x$p2[2] - x$p1[2]))
      # })

      ##### Ablauf:
      # browser()
      # get BB (extended)
      BBoxOrig <- list(
        x = trunc(range(Poly$x)) + c(-1, 1),
        y = trunc(range(Poly$y)) + c(-1, 1)
        # x = range(Poly$x),
        # y = range(Poly$y)
        )
      BBdim <- lapply(BBoxOrig, diff)
      BBdim_ext <- lapply(BBdim, function(x) ceiling(x / dxy) * dxy)
      BBadd <- mapply("-", BBdim_ext, BBdim) / 2
      BBox <- mapply(function(x, y) x + c(-1, 1) * y, x = BBoxOrig, y = BBadd, SIMPLIFY = FALSE)

      # liste mit matrix mit dxy -> grid
      # x & y vectors
      x_seq <- seq(BBox$x[1], BBox$x[2], by = dxy)
      y_seq <- seq(BBox$y[1], BBox$y[2], by = dxy)

      # create matrix M
      dimx <- length(x_seq) - 1
      dimy <- length(y_seq) - 1
      M <- matrix(seq_len(dimx * dimy), ncol = dimy, nrow = dimx)

      ####### inside
      # create grids Gxy & G
      Gxy <- as.matrix(expand.grid(row = seq_along(x_seq), col = seq_along(y_seq), KEEP.OUT.ATTRS = FALSE))
      G <- as.matrix(expand.grid(x = x_seq, y = y_seq, KEEP.OUT.ATTRS = FALSE))

      # - check Eckpunkte inside
      corner_inside <- as.logical(.Call("pip", G[, 1], G[, 2], nrow(G), Poly[, 1],
        Poly[, 2], nrow(Poly), PACKAGE = "bLSmodelR"))
      corner_inside_index <- which(corner_inside)
      Gxy_inside <- Gxy[corner_inside,, drop = FALSE]

      # get tiles in M
      M_xy <- apply(Gxy_inside, 1, function(x){
        c(x[1] + c(-1, 0), x[2] + c(-1, 0))
      })
      M_xy[M_xy == 0] <- NA
      M_tiles <- apply(M_xy, 2, function(x){
        c(
          (x[3] - 1) * dimx + x[1],
          (x[3] - 1) * dimx + x[2],
          (x[4] - 1) * dimx + x[1],
          (x[4] - 1) * dimx + x[2]
          )
      })
      # count corners inside per tile
      Tiles_count <- table(M_tiles)

     ####### intersecting
      # get all points with x_i | y_j intersect mit source_poly
      vert <- lapply(x_seq, function(px) list(p1 = c(px, BBox$y[1]), p2 = c(px, BBox$y[2])))
      horiz <- lapply(y_seq, function(py) list(p1 = c(BBox$x[1], py), p2 = c(BBox$x[2], py)))

      # check vertical grid
      Vcheck <- do.call("rbind",
        lapply(seq_along(vert), function(v) do.call("rbind",
          lapply(seq_along(Poly_lines), function(i){
            cbind(inters(Poly_lines[[i]]$p1, Poly_lines[[i]]$p2, vert[[v]]$p1, vert[[v]]$p2, tol),
              Poly_lines_entry = i, Line_row = v, Line_col = NA)
      }))))
      # check horizontal grid
      Hcheck <- do.call("rbind",
        lapply(seq_along(horiz), function(v) do.call("rbind",
          lapply(seq_along(Poly_lines), function(i){
            cbind(inters(Poly_lines[[i]]$p1, Poly_lines[[i]]$p2, horiz[[v]]$p1, horiz[[v]]$p2, tol),
              Poly_lines_entry = i, Line_row = NA, Line_col = v)
      }))))

      # bind together
      All_points <- rbind(
        Vcheck[Vcheck[,3] == 1, ],
        Hcheck[Hcheck[,3] == 1, ]
        )

      # inters(Poly_lines[[1]]$p1, Poly_lines[[1]]$p2, horiz[[18]]$p1, horiz[[18]]$p2, tol)

      # find segment lines by x & y -> row, col
      Line_rows <- All_points[,"Line_row"]
      isna_row <- is.na(Line_rows)
      Line_rows[isna_row] <- findInterval(All_points[isna_row, 1], x_seq, rightmost.closed = TRUE)
      Line_cols <- All_points[,"Line_col"]
      isna_col <- is.na(Line_cols)
      Line_cols[isna_col] <- findInterval(All_points[isna_col, 2], y_seq, rightmost.closed = TRUE)

      # check exact matching
      Outer_rows <- abs(outer(All_points[, 1], x_seq, "-")) < tol
      Exact_rows <- as.logical(rowSums(Outer_rows) > 0)
      Outer_cols <- abs(outer(All_points[, 2], y_seq, "-")) < tol
      Exact_cols <- as.logical(rowSums(Outer_cols) > 0)
      # check for exact matches in foundIntervals
      if(any(Exact_rows[isna_row])){
        Line_rows[Exact_rows & isna_row] <- apply(Outer_rows[Exact_rows & isna_row, , drop = FALSE], 1, which)
      }
      if(any(Exact_cols[isna_col])){
        Line_cols[Exact_cols & isna_col] <- apply(Outer_cols[Exact_cols & isna_col, , drop = FALSE], 1, which)
      }

      # check exact corner
      Exact_corners <- Exact_rows & Exact_cols

      # round with digits
      All_points[, "x"] <- round(All_points[, "x"], digits - 1)
      All_points[, "y"] <- round(All_points[, "y"], digits - 1)

      # find Tiles to check: lines -> 2 Tiles
      Border_x <- rbind(
        data.table(
          row = Line_rows[Exact_rows & !Exact_corners],
          col = Line_cols[Exact_rows & !Exact_corners],
          Px = All_points[Exact_rows & !Exact_corners, 1],
          Py = All_points[Exact_rows & !Exact_corners, 2],
          Poly_lines_entry = All_points[Exact_rows & !Exact_corners, 4]
          ),
        data.table(
          row = Line_rows[Exact_rows & !Exact_corners] - 1,
          col = Line_cols[Exact_rows & !Exact_corners],
          Px = All_points[Exact_rows & !Exact_corners, 1],
          Py = All_points[Exact_rows & !Exact_corners, 2],
          Poly_lines_entry = All_points[Exact_rows & !Exact_corners, 4]
          ))
      Border_y <- rbind(
        data.table(
          row = Line_rows[Exact_cols & !Exact_corners],
          col = Line_cols[Exact_cols & !Exact_corners],
          Px = All_points[Exact_cols & !Exact_corners, 1],
          Py = All_points[Exact_cols & !Exact_corners, 2],
          Poly_lines_entry = All_points[Exact_cols & !Exact_corners, 4]
          ),
        data.table(
          row = Line_rows[Exact_cols & !Exact_corners],
          col = Line_cols[Exact_cols & !Exact_corners] - 1,
          Px = All_points[Exact_cols & !Exact_corners, 1],
          Py = All_points[Exact_cols & !Exact_corners, 2],
          Poly_lines_entry = All_points[Exact_cols & !Exact_corners, 4]
          ))

      # find Tiles to check: corners -> 4 Tiles
      Border_xy <- rbind(
        data.table(
          row = Line_rows[Exact_corners],
          col = Line_cols[Exact_corners],
          Px = All_points[Exact_corners, 1],
          Py = All_points[Exact_corners, 2],
          Poly_lines_entry = All_points[Exact_corners, 4]
          ),
        data.table(
          row = Line_rows[Exact_corners] - 1,
          col = Line_cols[Exact_corners],
          Px = All_points[Exact_corners, 1],
          Py = All_points[Exact_corners, 2],
          Poly_lines_entry = All_points[Exact_corners, 4]
          ),
        data.table(
          row = Line_rows[Exact_corners],
          col = Line_cols[Exact_corners] - 1,
          Px = All_points[Exact_corners, 1],
          Py = All_points[Exact_corners, 2],
          Poly_lines_entry = All_points[Exact_corners, 4]
          ),
        data.table(
          row = Line_rows[Exact_corners] - 1,
          col = Line_cols[Exact_corners] - 1,
          Px = All_points[Exact_corners, 1],
          Py = All_points[Exact_corners, 2],
          Poly_lines_entry = All_points[Exact_corners, 4]
          )
        )

      # gather all tiles
      Border_all <- rbind(Border_x,Border_y,Border_xy)

      # remove borders
      Border <- Border_all[
        row > 0 &
        col > 0 &
        row <= dimx &
        col <= dimy,]
      # add Tile number
      Border[, tile := (Border$col - 1) * dimx + Border$row]

      # get number of corners inside source
      Border[, nc := 0L]
      Border[as.character(tile) %chin% names(Tiles_count), nc := {
            t_c <- as.character(tile)
            Tiles_count[t_c[t_c %in% names(Tiles_count)]]
            }]

      # # -> was falls mehrere polygons? (eher unwahrsch.)
      # # einbauen: if(count(Poly_lines_entry) > 2) -> mehrere Polygons
      # if(polyID == 2)browser()

      # check & get polygons
      All <- Border[, {

        # borders
        x_le <- x_seq[row[1]]
        x_ri <- x_seq[row[1] + 1]
        y_lo <- y_seq[col[1]]
        y_hi <- y_seq[col[1] + 1]

        # any points inside?
        pts_inside <- suppressWarnings(do.call(rbind, lapply(seq_len(nrow(Poly)), function(i){
            if(Poly[i, 1] >= x_le & Poly[i, 1] <= x_ri &
              Poly[i, 2] >= y_lo & Poly[i, 2] <= y_hi ){
              data.table(Poly[i, ], label = paste0("L",c((i - 2) %% nrow(Poly) + 1, i)))
            } else {
              NULL
            }
          })))

        # get corners inside
        Corner <- as.data.table(G[corner_inside_index[which(colSums(M_tiles == .BY[[1]]) > 0)], , drop = FALSE])

        # get labels of corners
        Corner[, label := {
          LR <- c("L", "R")[(abs(x - x_ri) < tol) + 1]
          BT <- c("B", "T")[(abs(y - y_hi) < tol) + 1]
          paste0("C", sapply(paste0(LR,BT), switch,
            "LB" = 1,
            "RB" = 2,
            "RT" = 3,
            "LT" = 4
            ))
        }]

        # browser()

        # cat(.BY$tile,"\n")
        # if(.BY$tile == 14) browser() # -> Corner of Source Area!
        # if(.BY$tile == 18) browser() # -> sprintf of 0 results in -0.00 ???!!!

        # check if line corner is exactly on corner (klappt das so, falls beide lines entlang dem edge gehen???)
        fmt <- paste0("%1.", digits,"f")
        fmt_xy <- paste(fmt, fmt, sep = "::")
        crn_xy <- Corner[, sprintf(fmt_xy, abs(x) * sign(x), abs(y) * sign(y))]
        sd_xy <- sprintf(fmt_xy, abs(Px) * sign(Px), abs(Py) * sign(Py))
        if(any(sd_dup <- duplicated(sd_xy))){
          sd_check <- sd_xy[sd_dup]
          sd_remove <- sd_check[sd_check %in% crn_xy]
          if(length(sd_remove) > 0){
            # remove lines on corner
            SD0 <- .SD[!(sd_xy %in% sd_remove),
                .(x = Px, y = Py, label = paste0("L", Poly_lines_entry))]
            sd_xy <- sd_xy[!(sd_xy %in% sd_remove)]
          } else {
            # remove corners on line
            SD0 <- .SD[, .(x = Px, y = Py, label = paste0("L", Poly_lines_entry))]
          }
        } else if(.N > 1) {
          # remove corners on line
          SD0 <- .SD[, .(x = Px, y = Py, label = paste0("L", Poly_lines_entry))]
        } else {
          # corner lies ecaxtly on line corner
          SD0 <- NULL
          sd_xy <- NULL
        }

        # check if corner falls on line or on pnts inside
        if(is.null(pts_inside)){
          if(any(crn_xy %in% sd_xy)) {
            Corner0 <- Corner[!(crn_xy %in% sd_xy)]
          } else {
            Corner0 <- Corner
          }
        } else {
          inside_xy <- pts_inside[, sprintf(fmt_xy, abs(x) * sign(x), abs(y) * sign(y))]
          if(any(crn_xy %in% sd_xy, crn_xy %in% inside_xy)) {
            Corner0 <- Corner[!(crn_xy %in% sd_xy) & !(crn_xy %in% inside_xy)]
          } else {
            Corner0 <- Corner
          }
        }

        # rbind (unique nicht mehr noetig?)
        DT <- unique(rbind(
          Corner0,
          # Corner,
          # if(!is.null(SD0)) SD0[.N:1, ],
          SD0,
          pts_inside
          ))

        # plot(c(x_le, x_ri), c(y_lo, y_hi), type = "n")
        # rect(x_le, y_lo, x_ri, y_hi, lwd = 2, border = "darkgrey")
        # if(!is.null(pts_inside)) pts_inside[, points(x, y, col = "darkgreen")]
        # Corner[, points(x, y, pch = 20, cex = 1.5)]
        # PLE <- unique(Poly_lines_entry)
        # for(ple in seq_along(PLE)){
        #   points(Px[Poly_lines_entry == PLE[ple]], Py[Poly_lines_entry == PLE[ple]], type = "b", col = "red")
        # }

        # if(.BY$tile == 9721) browser()
        # if(polyID == 2 && .BY$tile == 187) browser()

        # go around corners
        if(DT[, .N > 0]){
          DT[, ":="(
            included = FALSE,
            rn = 1:.N,
            polygon = NA_character_,
            polygon_order = NA_integer_,
            edge = checkEdge(x, y, y_lo, x_ri, y_hi, x_le, tol),
            corners = nc[1]
            ) ]
          poly_order <- poly_number <- 1L
          # get first point
          pnt <- DT[1,]
          # set polygon values in DT
          DT[1, ":="(
            included = TRUE,
            polygon = letters[poly_number],
            polygon_order = poly_order
            )]
          while(DT[,any(!included)]){
            # get point label
            pnt_lbl <- pnt[, label]
            # check if corner or line
            if(grepl("C", pnt_lbl)){
              # corner
              if(pnt_lbl %in% c("C4", "C2")){
                # check matching x & best y
                pnt <- DT[!included & abs(x - pnt[, x]) < tol][
                  which.min(abs(y - pnt[, y]))]
              } else {
                # check matching y & best x
                pnt <- DT[!included & abs(y - pnt[, y]) < tol][
                  which.min(abs(x - pnt[, x]))]
              }
            } else {
              # line
              if(DT[!(included), pnt_lbl %chin% label]){
                # take next point with label
                pnt <- DT[!included & label %in% pnt_lbl]
              } else {
                # search for next point on corresponding edge
                if(pnt[, edge == 5]){
                  # point inside -> check for point repetition
                  pnt <- DT[!included & abs(x - pnt[,x]) < tol & abs(y - pnt[,y]) < tol]
                } else {
                  # check side for next point
                  Side <- pnt[, edge]
                  if(Side %in% c(2, 4)){
                    # check matching x & best y
                    pnt <- DT[!included & abs(x - pnt[, x]) < tol][
                      which.min(abs(y - pnt[, y]))]
                  } else {
                    # check matching y & best x
                    pnt <- DT[!included & abs(y - pnt[, y]) < tol][
                      which.min(abs(x - pnt[, x]))]
                  }
                }
              }
            }
            if(nrow(pnt)){
              # update poly_order
              poly_order <- poly_order + 1
              # set polygon values in DT
              DT[rn == pnt[, rn], ":="(
                included = TRUE,
                polygon = letters[poly_number],
                polygon_order = poly_order
                )]
            } else {
              # update poly_* for next polygon
              poly_order <- 1
              poly_number <- poly_number + 1
              pnt <- DT[!(included)][1,]
              DT[rn == pnt[, rn], ":="(
                included = TRUE,
                polygon = letters[poly_number],
                polygon_order = poly_order
                )]
            }
          }

          # DT[order(polygon_order)][,{
          #   polygon(x, y,
          #     col = c("#D63636", "#2E64EE", "green", "orange", "purple")[.BY$corners + 1])
          # }, by = .(corners, polygon)]

          # DT[order(polygon_order), plot(x, y, type = "b")]
          DT[order(polygon_order), ][, area := {
            ind <- c(.N, seq(.N - 1))
            abs(sum(x * y[ind] - x[ind] * y)) / 2
            }, by = polygon]
        } else {
          NULL
        }
      }, by = tile]

      # correct for xyMeans
      x_seq <- x_seq + xyMeans[1]
      y_seq <- y_seq + xyMeans[2]
      Poly$x <- Poly$x + xyMeans[1]
      Poly$y <- Poly$y + xyMeans[2]

      # output
      out <- list(
        x_seq = x_seq,
        y_seq = y_seq,
        polygons = rbind(
          All[, .(tile, polygon,
            x = x + xyMeans[1],
            y = y + xyMeans[2],
            corners, area)],
          data.table(tile = as.integer(names(Tiles_count[Tiles_count == 4])) %w/o% All[,unique(tile)])[, {
          col <- ceiling(tile / dimx)
          row <- tile - (col - 1) * dimx
          .(
            polygon = "a",
            x = x_seq[row + c(0, 1, 1, 0)],
            y = y_seq[col + c(0, 0, 1, 1)],
            corners = -1L,
            area = dxy * dxy
          )}, by = tile]),
        dxy = dxy,
        tolerance = tolerance,
        digits = digits,
        tol = tol,
        SourcePoly = Poly
        )

      if(checkArea && abs(getArea(SubSource) - out$polygons[,area[1], by = .(tile, polygon)][,sum(V1)]) > sqrt(tol)){
        x11()
        # plotM(out)
        plot(Poly$x[c(1:nrow(Poly),1)], Poly$y[c(1:nrow(Poly),1)], type = "l", lwd = 2)
          # ,xlim = c(-1, 1) + 711620, ylim = c(-1, 1) + 260850)
        plotPolys(out)
        stop("polygons area and total area differ by more than sqrt(tol)! try to set a better dxy..")
      } else {
        out
      }

    })
    # end lapply over polygon ID
  })
  # end lapply over sources
  setNames(out, uSourceNames)
}

inters <- function(l1_p1, l1_p2, l2_p1, l2_p2, tol = 1e-5){
  # rewrite as vectors
  # -> https://demonstrations.wolfram.com/IntersectionOfTwoLinesUsingVectors/
  # browser()
  VZ <- l1_p2 - l1_p1
  UW <- l2_p2 - l2_p1
  mvz <- sqrt(sum(VZ ^ 2))
  muw <- sqrt(sum(UW ^ 2))
  beta <- acos(sum(VZ * UW) / (mvz * muw))
  UV <- l2_p1 - l1_p1
  muv <- sqrt(sum(UV ^ 2))
  alpha <- acos(sum(UV * UW) / (muv * muw))

  out <- l1_p1 + muv * sin(alpha) / sin(beta) * VZ / mvz

  return(cbind(
    x = out[1],
    y = out[2],
    inside =
      (
        (
          (out[1] - l1_p1[1]) >= -tol &&
          (out[1] - l1_p2[1]) <= tol
        ) || (
          (out[1] - l1_p1[1]) <= tol &&
          (out[1] - l1_p2[1]) >= -tol
        )
      ) && (
        (
          (out[1] - l2_p1[1]) >= -tol &&
          (out[1] - l2_p2[1]) <= tol
        ) || (
          (out[1] - l2_p1[1]) <= tol &&
          (out[1] - l2_p2[1]) >= -tol
        )
      ) && (
        (
          (out[2] - l1_p1[2]) >= -tol &&
          (out[2] - l1_p2[2]) <= tol
        ) || (
          (out[2] - l1_p1[2]) <= tol &&
          (out[2] - l1_p2[2]) >= -tol
        )
      ) && (
        (
          (out[2] - l2_p1[2]) >= -tol &&
          (out[2] - l2_p2[2]) <= tol
        ) || (
          (out[2] - l2_p1[2]) <= tol &&
          (out[2] - l2_p2[2]) >= -tol
        )
      )
    ))
}

checkEdge <- function(x, y, y_lo, x_ri, y_hi, x_le, tol = 1e-5){
  out <- rep(1, length(x))
  out[abs(x - x_le) < tol] <- out[abs(x - x_le) < tol] * 11
  out[abs(y - y_hi) < tol] <- out[abs(y - y_hi) < tol] * 7
  out[abs(x - x_ri) < tol] <- out[abs(x - x_ri) < tol] * 5
  out[abs(y - y_lo) < tol] <- out[abs(y - y_lo) < tol] * 3
  sapply(as.character(out), switch,
    "3" = 1, "33" = 1,
    "5" = 2, "15" = 2,
    "7" = 3, "35" = 3,
    "11" = 4, "77" = 4, 5)
}

# plotM <- function(X, xlim = NULL, ylim = NULL, cex.text = 0.35){
#   plot(range(X$x_seq), range(X$y_seq),type = "n", xlim = xlim, ylim = ylim)
#   lines(X$SourcePoly$x[c(1:nrow(X$SourcePoly),1)],X$SourcePoly$y[c(1:nrow(X$SourcePoly),1)], lwd = 2)
#   abline(h = X$y_seq)
#   abline(h = X$y_seq[c(1, length(X$y_seq))], lwd = 2)
#   abline(v = X$x_seq)
#   abline(v = X$x_seq[c(1, length(X$x_seq))], lwd = 2)
#   X$polygons[,{
#     polygon(x, y,
#       col = c("lightgrey", "#D63636", "#2E64EE", "green", "orange", "purple")[.BY$corners + 2])
#   }, by = .(corners, tile, polygon)]
#   Tgrid <- expand.grid(X$x_seq[-1] - X$dxy/2, X$y_seq[-1] - X$dxy/2)
#   text(Tgrid[,1], Tgrid[,2], 1:nrow(Tgrid), cex = cex.text)
# }

plotPolys <- function(X, xlim = NULL, ylim = NULL, cex.text = 0.35,
  col = c("lightgrey", "#D63636", "#2E64EE", "green", "orange", "purple"),
  tileNumbers = TRUE){
  if(length(col) == 1) col <- rep(col , 6)
  X$polygons[,{
    polygon(x, y,
      col = col[.BY$corners + 2])
  }, by = .(corners, tile, polygon)]
  if(tileNumbers){
    Tgrid <- expand.grid(X$x_seq[-1] - X$dxy/2, X$y_seq[-1] - X$dxy/2)
    text(Tgrid[,1], Tgrid[,2], 1:nrow(Tgrid), cex = cex.text)
  }
}