#' Build and plot dendrogram from gene panel
#'
#' Build and plot a dendrogram using correlation-based average linkage hierarchical
#'   clustering and only using a specified set of genes.  The output is the expected
#'   accuracy of mapping to each node in the tree, which gives an idea of the best-case
#'   expected results for mFISH analysis.
#'
#' @param dend dendrogram for mapping.  Ignored if medianDat is passed
#' @param refDat normalized data of the REFERENCE data set.  Ignored if medianDat is passed
#' @param mapDat normalized data of the MAPPING data set.  Default is to map the data onto itself.
#' @param medianDat representative value for each leaf and node.  If not entered, it is calculated
#' @param requiredGenes minimum number of genes required to be expressed in a cluster (column
#'   of medianDat) for the cluster to be included (default=2)
#' @param clusters  cluster calls for each cell
#' @param mappedAsReference if TRUE, returns the fraction of cells mapped to a node which are
#'   were orginally clustered from that node; if FALSE (default) returns the fraction of cells
#'   clustered under a node which are mapped to the correct node.
#' @param genesToMap which genes to include in the correlation mapping
#' @param plotdendro should the dendrogram be plotted (default = TRUE)
#' @param returnDendro should the dendrogram be returned (default = TRUE)
#' @param mar margins (for use with par)
#' @param main,ylab add title and labels to plot (default is NULL)
#' @param use,... additional parameters for cor
#'
#' @return a list where the first entry is the resulting tree and the second entry is the
#'   fraction of cells correctly mapping to each node using the inputted gene panel.
#'
#' @export
buildTreeFromGenePanel <- function(dend = NA,
                                   refDat = NA,
                                   mapDat = refDat,
                                   medianDat = NA,
                                   requiredGenes = 2,
                                   clusters = NA,
                                   mappedAsReference = FALSE,
                                   genesToMap = rownames(mapDat),
                                   plotdendro = TRUE,
                                   returndendro = TRUE,
                                   mar = c(12, 5, 5, 5),
                                   main = NULL,
                                   ylab = NULL,
                                   use = "p",
                                   ...) {
  library(dendextend)

  # Calculate the median, if needed.
  if (is.na(medianDat[1])) {
    names(clusters) <- colnames(refDat)
    medianDat <- do.call("cbind", tapply(
      names(clusters), clusters, function(x) rowMedians(refDat[, x])
    ))
    rownames(medianDat) <- rownames(refDat)
    if (!is.na(dend)) medianDat <- leafToNodeMedians(dend, medianDat)
  }
  gns <- intersect(genesToMap, intersect(rownames(mapDat), rownames(medianDat)))

  # Subset the data to relevant genes and clusters
  medianDat <- medianDat[gns, ]
  mapDat <- mapDat[gns, ]
  medianDat <- medianDat[, colSums(medianDat > 0) >= requiredGenes]
  kpDat <- (colSums(mapDat > 0) >= requiredGenes) & (is.element(clusters, colnames(medianDat)))
  mapDat <- mapDat[, kpDat]

  # Perform the correlation mapping
  facsCor <- corTreeMapping(medianDat = medianDat, mapDat = mapDat, use = use, ...)
  facsCl <- colnames(facsCor)[apply(facsCor, 1, which.max)]

  # Build a new tree based on mapping
  sCore <- function(x, use, ...) return(as.dist(1 - WGCNA::cor(x, use = use, ...)))
  dend <- getDend(medianDat, sCore, use = use, ...)

  # Which leaves have which nodes?
  has_any_labels <- function(sub_dend, the_labels) any(labels(sub_dend) %in% the_labels)
  node_labels <- NULL
  for (lab in labels(dend)) node_labels <- cbind(
      node_labels, noded_with_condition(dend, has_any_labels, the_labels = lab)
    )
  rownames(node_labels) <- get_nodes_attr(dend, "label")
  colnames(node_labels) <- labels(dend)

  # Swap the mapped and reference nodes if
  # mappedAsReference=TRUE
  clTmp <- as.character(clusters[kpDat])
  if (mappedAsReference) {
    temp <- clTmp
    clTmp <- facsCl
    facsCl <- temp
  }

  # Which clusters agree at the node level?
  agreeNodes <- apply(cbind(facsCl, clTmp), 1, function(lab, node_labels) {
    rowSums(node_labels[, lab]) == 2
  }, node_labels)
  colnames(agreeNodes) <- clTmp

  # Which clusters are in each nodes?
  isInNodes <- t(apply(node_labels, 1, function(node, cl, dend) {
    is.element(cl, labels(dend)[node])
  }, clTmp, dend))
  colnames(isInNodes) <- clTmp

  # For each node, plot the fraction of cells that
  # match if desired?
  fracAgree <- rowSums(agreeNodes) / rowSums(isInNodes)
  if (plotdendro) {
    par(mar = mar)
    dend %>% set("nodes_cex", 0) %>% set("branches_col", "grey") %>% plot()
    text(get_nodes_xy(dend)[, 1], get_nodes_xy(dend)[, 2], round(fracAgree * 100))
    title(main = main, ylab = ylab)
  }

  # Return the results (if desired)
  if (returndendro) return(list(dend, fracAgree))
}

#' Build a dendrogram from gene panel
#'
#' Build a dendrogram from an inputted data matrix.
#'
#' @param dat matrix of values (e.g., genes x clusters) for calculating the dendrogram
#' @param distFun function for calculating distance matrix (default is correlation-based)
#' @param ... additional variables for distFun
#'
#' @return dendrogram
#'
#' @export
getDend <- function(dat,
                    distFun = function(x) return(as.dist(1 - WGCNA::cor(x))),
                    ...) {
  distCor <- distFun(dat, ...)
  distCor[is.na(distCor)] <- max(distCor, na.rm = TRUE) * 1.2
  # Avoid crashing by setting NA values to hang off the side of the tree.
  avgClust <- hclust(distCor, method = "average")
  dend <- as.dendrogram(avgClust)
  dend <- labelDend(dend)[[1]]
  return(dend)
}

#' Label dendrogram nodes
#'
#' Add numeric node labels to a dendrogram.
#'
#' @param dend dendrogram object
#' @param distFun starting numeric node value (default=1)
#'
#' @return a list where the first item is the new dendrogram object and the
#'   second item is the final numeric node value.
#'
#' @export
labelDend <- function(dend, n = 1) {
  if (is.null(attr(dend, "label"))) {
    attr(dend, "label") <- paste0("n", n)
    n <- n + 1
  }
  if (length(dend) > 1) {
    for (i in 1:length(dend)) {
      tmp <- labelDend(dend[[i]], n)
      dend[[i]] <- tmp[[1]]
      n <- tmp[[2]]
    }
  }
  return(list(dend, n))
}

#' Summarize matrix
#'
#' Groups columns in a matrix by a specified group vector and summarizes using a specificed function.
#'   Optionally binarizes the matrix using a specified cutoff parameter.  This is a wrapper for tapply.
#'
#' @param mat matrix where the columns (e.g., samples) are going to be grouped
#' @param group vector of length dim(mat)[2] corresponding to the groups
#' @param scale either 'none' (default),'row', or 'column'
#' @param scaleQuantile what quantile of value should be set as 1 (default=1)
#' @param binarize should the data be binarized? (default=FALSE)
#' @param binMin minimum ON value for the binarized matrix (ignored if binarize=FALSE)
#' @param summaryFunction function (or function name) to be used for summarization
#' @param ... additional parameters for summaryFunction
#'
#' @return matrix of summarized values
#'
#' @export
summarizeMatrix <- function(mat,
                            group,
                            scale = "none",
                            scaleQuantile = 1,
                            binarize = FALSE,
                            binMin = 0.5,
                            summaryFunction = median,
                            ...) {

  # Make sure the names match up
  if (is.null(colnames(mat))) colnames(mat) <- names(group)
  if (is.null(colnames(mat))) colnames(mat) <- 1:length(group)
  names(group) <- colnames(mat)

  # Calculate the summary
  summaryFunction <- match.fun(summaryFunction)
  runFunction <- function(x, ...) {
    if (length(x) > 1) {
      return(apply(mat[, x], 1, summaryFunction, ...))
    }
    return(mat[, x])
  }
  summarizedMat <- do.call("cbind", tapply(names(group), group, runFunction, ...))
  if (is.factor(group)) summarizedMat <- summarizedMat[, levels(group)]
  rownames(summarizedMat) <- rownames(mat)

  # Scale the data if desired
  if (substr(scale, 1, 1) == "r") {
    for (i in 1:dim(summarizedMat)[1])
      summarizedMat[i, ] <- summarizedMat[i, ] /
        max(1e-06, quantile(summarizedMat[i, ], probs = scaleQuantile))
  }
  if (substr(scale, 1, 1) == "c") {
    for (i in 1:dim(summarizedMat)[2])
      summarizedMat[, i] <- summarizedMat[, i] /
        max(1e-06, quantile(summarizedMat[, i], probs = scaleQuantile))
  }

  # Binarize the data if desired
  if (binarize) {
    summarizedMat <- summarizedMat > binMin
    summarizedMat <- summarizedMat + 1 - 1
  }
  summarizedMat
}

#' Scale mFISH data and map to RNA-seq reference
#'
#' This function is a wrapper for several other functions which aim to scale mFISH data to
#'   more closely match RNA-seq data and then map the mFISH data to the closest reference
#'   classes.  There are several parameters allowing flexability in filtering and analysis.
#'
#' @param mapDat normalized data of the MAPPING data set.  Default is to map the data onto itself.
#' @param refSummaryDat normalized summary data of the REFERENCE data set (e.g., what to map against)
#' @param genesToMap which genes to include in the mapping (calculated in not entered)
#' @param mappingFunction which function to use for mapping (default is cellToClusterMapping_byCor)
#'   The function must include at least two parameters with the first one being mapped data and the
#'   second data the reference.  Additional parameters are okay.  Output must be a data frame where
#'   the first value is a mapped class.  Additional columns are okay and will be returned)
#' @param transform function for transformation of the data (default in none)
#' @param noiselevel scalar value at or below which all values are set to 0 (default is 0)
#' @param scaleFunction which function to use for scaling mapDat to refSummaryDat (default is setting
#'   90th quantile of mapDat to max of refSummaryDat and truncating higher mapDat values)
#' @param omitGenes genes to be included in the data frames but excluded from the mapping
#' @param metadata a data frame of possible metadata (additional columns are okay and ignored):
#' \describe{
#'   \item{area}{a vector of cell areas for normalization}
#'   \item{experiment}{a vector indicating if multiple experiments should be scaled separately}
#'   \item{x,y}{x (e.g., parallel to layer) and y (e.g., across cortical layers) coordinates in tissue}
#' }
#' @param integerWeights if not NULL (default) a vector of integers corresponding to how many times
#'   each gene should be counted as part of the correlation.  This is equivalent to calculating
#'   a weighted correlation, but only allows for integer weight values (for use with cor).
#' @param binarize should the data be binarized? (default=FALSE)
#' @param binMin minimum ON value for the binarized matrix (ignored if binarize=FALSE)
#' @param ... additional parameters for passthrough into other functions
#'
#' @return a list with the following entrees:
#' \describe{
#'   \item{mapDat}{mapDat data matrix is passed through}
#'   \item{scaleDat}{scaled mapDat data matrix}
#'   \item{mappingResults}{Results of the mapping and associated confidence values (if any)}
#'   \item{metadata=metadata}{metadata is passed through unchanged}
#'   \item{scaledX/Y}{scaled x and y coordinates (or unscaled if scaling was not performed)}
#' }
#'
#' @export
fishScaleAndMap <- function(mapDat,
                            refSummaryDat,
                            genesToMap = NULL,
                            mappingFunction = cellToClusterMapping_byCor,
                            transform = function(x) x,
                            noiselevel = 0,
                            scaleFunction = quantileTruncate,
							omitGenes = NULL,
                            metadata = data.frame(experiment = rep("all", dim(mapDat)[2])),
                            integerWeights = NULL,
                            binarize = FALSE,
                            binMin = 0.5,
                            ...) {

  # Setup
  mappingFunction <- match.fun(mappingFunction)
  scaleFunction <- match.fun(scaleFunction)
  transform <- match.fun(transform)
  if (is.null(genesToMap)) genesToMap <- colnames(mapDat)
  genesToMap <- intersect(genesToMap, rownames(refSummaryDat))
  params <- colnames(metadata)
  refSummaryDat <- refSummaryDat[genesToMap, ]
  mapDat <- mapDat[genesToMap, ]

  # Transform the data to be mapped
  scaleDat <- as.matrix(mapDat[genesToMap, ])
  scaleDat[scaleDat <= noiselevel] <- 0 # Set values less than or equal to noiselevel to 0
  if (is.element("area", params)) {
    # Account for spot area in gene expression calculation
    scaleDat <- t(t(scaleDat) / metadata$area) * mean(metadata$area)
  }
  scaleDat <- transform(scaleDat)

  # Scale to the reference data
  for (ex in unique(metadata$experiment)) {
    isExp <- metadata$experiment == ex
    for (g in genesToMap) scaleDat[g, isExp] <- scaleFunction(scaleDat[
        g, isExp
      ], maxVal = max(refSummaryDat[g, ]), ...)
  }

  # Binarize, if desired
  if (binarize) {
    scaleDat <- scaleDat > binMin
    scaleDat <- scaleDat + 1 - 1
  }

  # Omit genes and weight scaling, if desired
  genesToMap2 <- genesToMap
  if (!is.null(integerWeights)) genesToMap2 <- rep(genesToMap2, integerWeights)
  genesToMap2 <- genesToMap2[!is.element(genesToMap2, omitGenes)]

  # Map the map data to the reference data
  scaleDat2 <- scaleDat[genesToMap2, ]
  refSummaryDat2 <- refSummaryDat[genesToMap2, ]
  mappingResults <- mappingFunction(refSummaryDat2, scaleDat2, ...)

  # Scale x and y coordinates to (0,1) within experiment, if desired
  for (ex in unique(metadata$experiment)) {
    isExp <- metadata$experiment == ex
    metadata$x[isExp] <- metadata$x[isExp] - min(metadata$x[isExp])
    metadata$x[isExp] <- metadata$x[isExp] / max(metadata$x[isExp])
    metadata$y[isExp] <- metadata$y[isExp] - min(metadata$y[isExp])
    metadata$y[isExp] <- metadata$y[isExp] / max(metadata$y[isExp])
  }

  # Return the results
  out <- list(
    mapDat = mapDat, scaleDat = scaleDat,
    mappingResults = mappingResults, metadata = metadata,
    scaledX = metadata$x, scaledY = metadata$y
  )
}

#' Filter (subset) fishScaleAndMap object
#'
#' Subsets all components in a fishScaleAndMap object
#'
#' @param datFish a fishScaleAndMap output list
#' @param subset  a boolean or numeric vector of the elements to retain
#'
#' @return a fishScaleAndMap output subsetted to the requested elements
#'
#' @export
filterCells <- function(datFish,
                        subset) {
  ## Error checking
  if ((length(subset) != length(datFish$scaledX)) & (!is.numeric(subset))) {
    print("subset is incorrect format.  Returning original entry.")
    return(datFish)
  }
  if (is.numeric(subset)) subset <- intersect(subset, 1:length(datFish$scaledX))

  ## Subset all of the elements
  datFish$mapDat <- datFish$mapDat[, subset]
  datFish$scaleDat <- datFish$scaleDat[, subset]
  datFish$metadata <- datFish$metadata[subset, ]
  datFish$scaledX <- datFish$scaledX[subset]
  datFish$scaledY <- datFish$scaledY[subset]
  if (!is.null(datFish$mappingResults)) {
    datFish$mappingResults <- datFish$mappingResults[subset, ]
  }
  return(datFish)
}

#' Merge two fishScaleAndMap objects
#'
#' Merges all components of two fishScaleAndMap objects to create a new
#'   one. Note: only meta-data and mappingResults that is present in BOTH
#'   objects will be returned.
#'
#' @param datFish1 a fishScaleAndMap output list
#' @param datFish2 a second fishScaleAndMap output list.
#'
#' @return a new fishScaleAndMap output list with the two original ones merged
#'
#' @export
mergeFish <- function(datFish1,
                      datFish2) {
  datFish <- datFish1
  datFish$mapDat <- cbind(datFish1$mapDat, datFish2$mapDat)
  datFish$scaleDat <- cbind(datFish1$scaleDat, datFish2$scaleDat)
  datFish$metadata <- rbind(datFish1$metadata, datFish2$metadata)
  datFish$scaledX <- c(datFish1$scaledX, datFish2$scaledX)
  datFish$scaledY <- c(datFish1$scaledY, datFish2$scaledY)
  if ((!is.null(datFish1$mappingResults)) & (!is.null(datFish2$mappingResults))) {
    datFish$mappingResults <- rbind(datFish1$mappingResults, datFish2$mappingResults)
  }
  return(datFish)
}

#' Rotate coordinates
#'
#' Rotates the scaledX and scaledY elements of a fishScaleAndMap output list so that the
#'   axis of interest (e.g., cortical layer) is paralled with the x cooridate plan.
#'   Rotation code is from  https://stackoverflow.com/questions/15463462/rotate-graph-by-angle
#'
#' @param datFish a fishScaleAndMap output list
#' @param flatVector a TRUE/FALSE vector ordred in the same way as the elements (e.g., cells)
#'   in datIn where all TRUE values correspond to cells who should have the same Y coordinate
#'   (e.g., be in the same layer).  Alternatively a numeric vector of cell indices to include
#' @param flipVector a numeric vector of values to ensure proper reflection on Y-axes (e.g.,
#'   layer; default=NULL)
#' @param subset  a boolean or numeric vector of the elements to retain
#'
#' @return a fishScaleAndMap output list with updated scaledX and scaleY coordinates
#'
#' @export
rotateXY <- function(datFish,
                     flatVector = NULL,
                     flipVector = NULL,
                     subset = NULL) {

  ## Error checking
  datFishIn <- datFish
  if ((length(flatVector) != length(datFish$scaledX)) & (!is.numeric(flatVector))) {
    print("flatVector is incorrect format.  Returning original entry.")
    return(datFish)
  }
  if (!is.null(subset)) {
    if ((length(subset) != length(datFish$scaledX)) & (!is.numeric(subset))) {
      print("subset is incorrect format.  Returning original entry.")
      return(datFish)
    }
  }
  if (((length(flipVector) != length(datFish$scaledX)) &
    (!is.numeric(flipVector))) & (!is.null(flipVector))) {
    print("flipVector is incorrect format.  Returning original entry.")
    return(datFish)
  }
  if (is.numeric(flatVector)) {
    flatVector <- intersect(flatVector, 1:length(datFish$scaledX))
  }

  ## Subset the data if needed
  datFish <- datFishIn
  if (!is.null(subset)) {
    datFish <- filterCells(datFishIn, subset)
    flatVector <- flatVector[subset]
    flipVector <- flipVector[subset]
  }

  ## Caculate best angle
  v <- prcomp(cbind(datFish$scaledX, datFish$scaledY)[flatVector, ])$rotation
  beta <- as.numeric(atan(-v[2, 1]/v[1, 1]))

  ## Rotate coordinates (internal function)
  rotCor <- function(datFish,
                       beta) {
    M <- cbind(datFish$scaledX, datFish$scaledY)
    rotm <- matrix(c(cos(beta), sin(beta), -sin(beta), cos(beta)), ncol = 2) # rotation matrix
    M2.1 <- t(t(M) - c(M[1, 1], M[1, 2])) # shift points, so that turning point is (0,0)
    M2.2 <- t(rotm %*% (t(M2.1))) # rotate
    M2.3 <- t(t(M2.2) + c(M[1, 1], M[1, 2])) # shift back
    x <- M2.3[, 1]
    y <- M2.3[, 2]

    x <- x - min(x)
    x <- x / max(x)
    y <- y - min(y)
    y <- y / max(y)

    datFish$scaledX <- x
    datFish$scaledY <- y
    datFish
  }
  datFish2 <- rotCor(datFish, beta)

  if (!is.null(flipVector)) {
    if (sum(datFish2$scaledY * flipVector) < sum((1 - datFish2$scaledY) * flipVector)) {
      datFish2 <- rotCor(datFish, beta)# + pi) # Pi should not be needed
    }
  }
  datFish <- datFish2

  ## Unsubset and return the data
  if (is.null(subset)) return(datFish)

  datFishIn$scaledX[subset] <- datFish$scaledX
  datFishIn$scaledY[subset] <- datFish$scaledY
  datFishIn
}

#' Plot distributions
#'
#' Plot the distributions of cells across the tissue with overlaying color information.  This is
#'   a wrapper function for plot
#'
#' @param datIn  a fishScaleAndMap output list
#' @param group a character vector (or factor) indicating how to split the data (e.g., cluster
#'   call) or a metadata/mappingResults column name
#' @param groups a character vector of groups to show (default is levels of group)
#' @param colors a character vector (or factor) indicating how to color the plots (e.g., layer
#'   or gene expression) or a metadata/mappingResults column name (default is all black)
#' @param colormap function to use for the colormap for the data (default gray.colors)
#' @param maxrow maximum number of plots to show in one row (default=12)
#' @param xlim,ylim for plot, but will be calculated if not entered
#' @param pch,cex for plot.  Can be single values or vectors
#' @param main,xlab,ylab,... other parameters for plot (must be single values)
#' @param singlePlot should everything be plot on a single page (default=TRUE)
#'
#' @return Only returns if there is an error
#'
#' @export
plotDistributions <- function(datIn,
                              group,
                              groups = NULL,
                              colors = rep("black", dim(datIn$mapDat)[2]),
                              colormap = gray.colors,
                              maxrow = 12,
                              pch = 19,
                              cex = 1.5,
                              xlim = NULL, ylim = NULL,
                              main = "",
                              xlab = "", ylab = "",
			      singlePlot = TRUE,
                              ...) {
  colormap <- match.fun(colormap)
  meta <- cbind(datIn$metadata, datIn$mappingResults)
  if (length(group) == 1) {
    if (is.element(group, colnames(meta))) {
      group <- as.factor(meta[, group])
      if (is.null(groups)) groups <- levels(group)
    } else {
      return(paste(group, "is not an available column name for division."))
    }
  }
  if (length(colors) == 1) {
    if (is.element(colors, colnames(meta))) {
      colors <- as.numeric(as.factor(meta[, colors]))
      colors <- colormap(length(unique(colors)))[colors]
    } else {
      return(paste(colors, "is not an available column name for coloring."))
    }
  } else {
    colors <- as.numeric(as.factor(colors))
    colors <- colormap(length(unique(colors)))[colors]
  }

  if (is.null(xlim)) xlim <- range(datIn$scaledX)
  if (is.null(ylim)) ylim <- range(-datIn$scaledY)

  # Make the plot!
  if(singlePlot){
    ncolv <- min(length(groups), maxrow)
    nrowv <- ceiling(length(groups)/maxrow)
    par(mfrow = c(nrowv, ncolv))
  }
  for (gp in groups) {
    kp <- group == gp
    pch2 <- pch
    if (length(pch) > 1) pch2 <- pch[kp]
    cex2 <- cex
    if (length(cex) > 1) cex2 <- cex[kp]

    plot(datIn$scaledX[kp], -datIn$scaledY[kp],
      pch = pch2, col = colors[kp], xlim = xlim,
      ylim = ylim, main = paste(main, gp), xlab = xlab,
      ylab = ylab, cex = cex2, ...
    )
  }
}

#' Plot heatmap
#'
#' Plot the heatmap of cells ordering by a specified order.  This is a wrapper for heatmap.2
#'
#' @param datIn  a fishScaleAndMap output list
#' @param group a character vector (or factor) indicating how to order the heatmap (e.g., cluster
#'   call) or a metadata/mappingResults column name
#' @param groups a character vector of groups to show (default is levels of group)
#' @param grouplab label for the grouping in the heatmap (default is 'Grouping' or the value for group)
#' @param useScaled plot the scaled (TRUE) or unscaled (FALSE; default) values
#' @param capValue values above capValue will be capped at capValue (default is none)
#' @param colormap set of values to use for the colormap for the data (default heat_colors)
#' @param Rowv,Colv,dendrogram,trace,margins,rowsep,colsep,key,... other parameters for heatmap.2
#'   (some default values are different)
#'
#' @return Only returns if there is an error
#'
#' @export
plotHeatmap <- function(datIn,
                        group,
                        groups = NULL,
                        grouplab = "Grouping",
                        useScaled = FALSE,
                        capValue = Inf,
                        colormap = grey.colors(1000),
                        pch = 19,
                        xlim = NULL, ylim = NULL,
                        Rowv = FALSE,
                        Colv = FALSE,
                        dendrogram = "none",
                        trace = "none",
                        margins = c(6, 10),
                        rowsep = NULL,
                        sepwidth=c(0.4,0.4),
                        key = FALSE, ...) {
  library(gplots)

  if (useScaled) {
    plotDat <- datIn$scaleDat
  } else {
    plotDat <- datIn$mapDat
  }
  plotDat <- pmin(plotDat, capValue)

  meta <- cbind(datIn$metadata, datIn$mappingResults)
  if (length(group) == 1) {
    if (is.element(group, colnames(meta))) {
      if (grouplab == "Grouping") grouplab <- group
      group <- as.factor(meta[, group])
      if (is.null(groups)) groups <- levels(group)
    } else {
      return(paste(group, "is not an available column name for division."))
    }
  }

  # Update the cell order
  groups <- c(groups, setdiff(levels(group), groups))
  ord <- order(factor(group, levels = groups), -colSums(plotDat))
  plotDat <- plotDat[, ord]
  group <- group[ord]

  # Append the cluster name to the plot data and find colseps
  cn <- rep("", length(colnames(plotDat)))
  colseps <- NULL
  for (g in unique(as.character(group))){
    wg <- which(as.character(group)==g)
    cn[round(mean(wg))] <- g
    colseps <- c(colseps,min(wg)-1)
  }
  colnames(plotDat) <- paste(cn,colnames(plotDat))

  # Make the plot!
  heatmap.2(plotDat,
            Rowv = Rowv, Colv = Colv, dendrogram = dendrogram,
            trace = trace, margins = margins, rowsep = rowsep,
            colsep = colseps, key = key, col = colormap,
            ...
  )
}

#' Return top mapped correlation-based cluster and confidence
#'
#' Primary function for doing correlation-based mapping to cluster medians and also reporting the
#'   correlations and confidences.  This is wrapper for getTopMatch and corTreeMapping.
#'
#' @param medianDat representative value for each leaf and node.  If not entered, it is calculated
#' @param mapDat normalized data of the MAPPING data set.  Default is to map the data onto itself.
#' @param refDat normalized data of the REFERENCE data set.  Ignored if medianDat is passed
#' @param clusters  cluster calls for each cell.  Ignored if medianDat is passed
#' @param genesToMap which genes to include in the correlation mapping
#' @param use additional parameter for cor (use='p' as default)
#' @param method additional parameter for cor (method='p' as default)
#' @param returnCor should the correlation matrix be appended to the return?
#' @param ... not used
#'
#' @return data frame with the top match and associated correlation
#'
#' @export
cellToClusterMapping_byCor <- function(medianDat,
                                       mapDat,
                                       refDat = NA,
                                       clusters = NA,
                                       genesToMap = rownames(mapDat),
                                       use = "p",
                                       method = "p",
				       returnCor=FALSE,
                                       ...) {
  corVar <- corTreeMapping(
    medianDat = medianDat,
    mapDat = mapDat, refDat = refDat, clusters = clusters,
    genesToMap = genesToMap, use = use, method = method
  )
  corMatch <- getTopMatch(corVar)
  colnames(corMatch) <- c("Class", "Correlation")

  dex <- apply(corVar, 1, function(x) return(diff(sort(-x)[1:2])))
  corMatch$DifferenceBetweenTopTwoCorrelations <- dex
  if(returnCor)
    corMatch <- cbind(corMatch,corVar)
  corMatch
}

#' Quantile normalize, truncate, and scale
#'
#' Quantile normalize, truncate, and scale a numeric vector (e.g. mFISH data from one gene)
#'
#' @param x input data vector
#' @param qprob probs value to result from quantile (default=0.9)
#' @param maxVal max value for scaling (default=1)
#' @param truncate should data above the qprob threshold be truncated (default=yes)
#' @param ... not used
#'
#' @return scaled vector
#'
#' @export
quantileTruncate <- function(x,
                             qprob = 0.9,
                             maxVal = 1,
                             truncate = TRUE,
                             ...) {
  qs <- quantile(x[x > 0], probs = qprob, na.rm = TRUE)
  if (is.na(qs)) return(x)
  if (truncate) x[x > qs] <- qs
  x * maxVal / qs
}

#' Plot TSNE
#'
#' Plot a TSNE of the data, with assigned colors and labels from provided variables.  Note that this
#'   function is a modification of code from Pabloc (https://www.r-bloggers.com/author/pabloc/) from
#'   https://www.r-bloggers.com/playing-with-dimensions-from-clustering-pca-t-sne-to-carl-sagan/
#'
#' @param datIn  a fishScaleAndMap output list
#' @param colorGroup a character vector (or factor) indicating how to color the Tsne (e.g., cluster
#'   call) or a metadata/mappingResults column name (default=NULL)
#' @param labelGroup a character vector (or factor) indicating how to label the Tsne (e.g., cluster
#'   call) or a metadata/mappingResults column name (default=NULL)
#' @param useScaled plot the scaled (TRUE) or unscaled (FALSE; default) values
#' @param capValue values above capValue will be capped at capValue (default is none)
#' @param perplexity,theta other parameters for Rtsne
#' @param main title of the plot
#' @param maxNchar what is the maximum number of characters to display in the plot for each entry?
#' @param seed for reproducibility
#'
#' @return Only returns if there is an error
#'
#' @export
plotTsne <- function(datIn,
                     colorGroup = "none",
                     labelGroup = "none",
                     useScaled = FALSE,
                     capValue = Inf,
                     perplexity = 10,
                     theta = 0.5,
                     main = "TSNE plot",
                     maxNchar = 1000,
                     seed = 10) {
  library(Rtsne)
  library(ggplot2)

  # Get the data
  if (useScaled) {
    plotDat <- datIn$scaleDat
  } else {
    plotDat <- datIn$mapDat
  }
  plotDat <- pmin(plotDat, capValue)
  plotDat <- t(plotDat)

  # Color and label groups
  meta <- cbind(datIn$metadata, datIn$mappingResults)
  if (length(colorGroup) == 1) {
    if (is.element(colorGroup, colnames(meta))) {
      colorGroup <- as.factor(meta[, colorGroup])
    } else {
      colorGroup <- as.factor(rep("none", dim(meta)[1]))
    }
  }
  if (length(labelGroup) == 1) {
    if (is.element(labelGroup, colnames(meta))) {
      labelGroup <- as.factor(meta[, labelGroup])
    } else {
      labelGroup <- as.factor(rep("*", dim(meta)[1]))
    }
  }
  # Subset to maxNchar characters
  levs <- substr(levels(as.factor(labelGroup)), 1, maxNchar)
  labelGroup <- factor(as.character(substr(
    labelGroup, 1, maxNchar
  )), levels = as.character(unique(levs)))

  # Get the tsne corrdinates
  set.seed(seed)
  tsne_model_1 <- Rtsne(as.matrix(plotDat),
    check_duplicates = FALSE,
    pca = TRUE, perplexity = perplexity, theta = theta, dims = 2
  )
  d_tsne_1 <- as.data.frame(tsne_model_1$Y)

  # Make the plot!
  plot_k <- ggplot(d_tsne_1, aes_string(
    x = "V1", y = "V2",
    color = colorGroup, label = labelGroup
  )) +
    geom_text() + xlab("TSNE 1") + ylab("TSNE 2") +
    ggtitle(main) + theme(legend.title = element_blank())
  scale_colour_discrete()

  plot_k
}


# ==================================================================================================
# This file is part of the CLBlast project. The project is licensed under Apache Version 2.0. This
# project uses a tab-size of two spaces and a max-width of 100 characters per line.
#
# Author(s):
#   Cedric Nugteren <www.cedricnugteren.nl>
#
# This file implements the performance script for the Xsyrk routine
#
# ==================================================================================================

# Includes the common functions
args <- commandArgs(trailingOnly = FALSE)
thisfile <- (normalizePath(sub("--file=", "", args[grep("--file=", args)])))
source(file.path(dirname(thisfile), "common.r"))

# ==================================================================================================

# Settings
routine_name <- "xsyrk"
parameters <- c("-n","-k","-layout","-triangle","-transA",
                "-num_steps","-step","-runs","-precision")
precision <- 32

# Sets the names of the test-cases
test_names <- list(
  "multiples of 128",
  "multiples of 128 (+1)",
  "around n=k=512",
  "around n=k=2048",
  "layouts and transposing (n=k=1024)",
  "powers of 2"
)

# Defines the test-cases
test_values <- list(
  list(c( 128,  128, 102, 111, 111, 16, 128, num_runs, precision)),
  list(c( 129,  129, 102, 111, 111, 16, 128, num_runs, precision)),
  list(c( 512,  512, 102, 111, 111, 16, 1, num_runs, precision)),
  list(c(2048, 2048, 102, 111, 111, 16, 1, num_runs, precision)),
  list(
    c(1024, 1024, 101, 111, 111, 1, 0, num_runs, precision),
    c(1024, 1024, 101, 111, 112, 1, 0, num_runs, precision),
    c(1024, 1024, 101, 112, 111, 1, 0, num_runs, precision),
    c(1024, 1024, 101, 112, 112, 1, 0, num_runs, precision),
    c(1024, 1024, 102, 111, 111, 1, 0, num_runs, precision),
    c(1024, 1024, 102, 111, 112, 1, 0, num_runs, precision),
    c(1024, 1024, 102, 112, 111, 1, 0, num_runs, precision),
    c(1024, 1024, 102, 112, 112, 1, 0, num_runs, precision)
  ),
  list(
    c(   8,    8, 102, 111, 111, 1, 0, num_runs, precision),
    c(  16,   16, 102, 111, 111, 1, 0, num_runs, precision),
    c(  32,   32, 102, 111, 111, 1, 0, num_runs, precision),
    c(  64,   64, 102, 111, 111, 1, 0, num_runs, precision),
    c( 128,  128, 102, 111, 111, 1, 0, num_runs, precision),
    c( 256,  256, 102, 111, 111, 1, 0, num_runs, precision),
    c( 512,  512, 102, 111, 111, 1, 0, num_runs, precision),
    c(1024, 1024, 102, 111, 111, 1, 0, num_runs, precision),
    c(2048, 2048, 102, 111, 111, 1, 0, num_runs, precision),
    c(4096, 4096, 102, 111, 111, 1, 0, num_runs, precision),
    c(8192, 8192, 102, 111, 111, 1, 0, num_runs, precision)
  )
)

# Defines the x-labels corresponding to the test-cases
test_xlabels <- list(
  "matrix sizes (n=k)",
  "matrix sizes (n=k)",
  "matrix sizes (n=k)",
  "matrix sizes (n=k)",
  "layout (row/col), triangle (u/l), transA (n/y)",
  "matrix sizes (n=k)"
)

# Defines the x-axis of the test-cases
test_xaxis <- list(
  c("n", ""),
  c("n", ""),
  c("n", ""),
  c("n", ""),
  list(1:8, c("row,u,n", "row,u,y", "row,l,n", "row,l,y",
              "col,u,n", "col,u,y", "col,l,n", "col,l,y")),
  c("n", "x")
)

# ==================================================================================================

# Start the script
main(routine_name=routine_name, precision=precision, test_names=test_names, test_values=test_values,
     test_xlabels=test_xlabels, test_xaxis=test_xaxis, metric_gflops=TRUE)

# ==================================================================================================


setwd("P:/2019 0970 151 000/User Data/Faraz-Export IDAVE folders/Models2.5")
library(tidyverse)
library(h2o)
library(inspectdf)
tabna <- function(x){table(x, useNA = "ifany")}
##adding cihi vars
dfx <- readRDS("./dfx_v2.5.rds")

h2o.init()
dfx %>% inspect_na() %>% print(n=10)
dfx <- drop_na(dfx)

###backward compatibility save
# saveRDS(dfx, "./dfx_cln_oldR.rds", version = 2)
###

#############Train model on first 30 vars
#DATA IS READY TO USE
########################

new_resultFrame <-  function(){

return(data.frame(Model = character(),
Hit_Ratio = numeric(),
Mean_PerC_Error = numeric(),
LogLoss = numeric(),
AUC = numeric(),
AUCPR = numeric(),
Recall = numeric(),
Precision = numeric(),
Specificity = numeric(),
max_F1 = numeric(),
trshold = numeric(),
training_AUC = numeric(),
training_AUCPR = numeric(),
training_Recall = numeric(),
training_Precision = numeric(),
training_Spec = numeric(),
stringsAsFactors = FALSE))
}

add_cv_results <- function (myModel, modH){
# for tuning hyperparameters, using cross validation as
	idx <- nrow(modH) + 1
	tab2 <- myModel@model$cross_validation_metrics@metrics$cm$table
	tab1 <- myModel@model$training_metrics@metrics$cm$table

	modH[idx, 1] <- myModel@model_id
	modH[idx, 2] <- round(1- myModel@model$cross_validation_metrics@metrics$cm$table$Error[3], digits=3)
	modH[idx, 3] <- round(myModel@model$cross_validation_metrics@metrics$mean_per_class_error, digits=3)
	modH[idx, 4] <- round(myModel@model$cross_validation_metrics@metrics$logloss, digits=3)
	modH[idx, 5] <- round(myModel@model$cross_validation_metrics@metrics$AUC, digits = 3)
	modH[idx, 6] <- round(myModel@model$cross_validation_metrics@metrics$pr_auc, digits = 3)
	modH[idx, 7] <- round(tab2[2,2] / (tab2[2,2] + tab2[2,1]),digits=3)#recall
	modH[idx, 8] <- round(tab2[2,2] / (tab2[2,2] + tab2[1,2]),digits=3)# precision
	modH[idx, 9] <- round(tab2[1,1] / (tab2[1,1] + tab2[2,1]),digits=3)# Specificity
	modH[idx, 10] <- round(myModel@model$cross_validation_metrics@metrics$max_criteria_and_metric_scores$value[1], digits=3)
	modH[idx, 11] <- round(myModel@model$cross_validation_metrics@metrics$max_criteria_and_metric_scores$threshold[1], digits=3)
	modH[idx, 12] <- round(myModel@model$training_metrics@metrics$AUC, digits = 3)
	modH[idx, 13] <- round(myModel@model$training_metrics@metrics$pr_auc, digits = 3)
	modH[idx, 14] <- round(tab1[2,2] / (tab1[2,2] + tab1[2,1]),digits=3)#recall
	modH[idx, 15] <- round(tab1[2,2] / (tab1[2,2] + tab1[1,2]),digits=3)# precision
	modH[idx, 16] <- round(tab1[1,1] / (tab1[1,1] + tab1[2,1]),digits=3)# Specificity

	return(modH)
}

add_results <- function (myModel, modH){
	idx <- nrow(modH) + 1
	tab2 <- myModel@model$validation_metrics@metrics$cm$table
	tab1 <- myModel@model$training_metrics@metrics$cm$table

	modH[idx, 1] <- myModel@model_id
	modH[idx, 2] <- round(1- myModel@model$validation_metrics@metrics$cm$table$Error[3], digits=3)
	modH[idx, 3] <- round(myModel@model$validation_metrics@metrics$mean_per_class_error, digits=3)
	modH[idx, 4] <- round(myModel@model$validation_metrics@metrics$logloss, digits=3)
	modH[idx, 5] <- round(myModel@model$validation_metrics@metrics$AUC, digits = 3)
	modH[idx, 6] <- round(myModel@model$validation_metrics@metrics$pr_auc, digits = 3)
	modH[idx, 7] <- round(tab2[2,2] / (tab2[2,2] + tab2[2,1]),digits=3)#recall
	modH[idx, 8] <- round(tab2[2,2] / (tab2[2,2] + tab2[1,2]),digits=3)# precision
	modH[idx, 9] <- round(tab2[1,1] / (tab2[1,1] + tab2[2,1]),digits=3)# Specificity
	modH[idx, 10] <- round(myModel@model$validation_metrics@metrics$max_criteria_and_metric_scores$value[1], digits=3)
	modH[idx, 11] <- round(myModel@model$validation_metrics@metrics$max_criteria_and_metric_scores$threshold[1], digits=3)
	modH[idx, 12] <- round(myModel@model$training_metrics@metrics$AUC, digits = 3)
	modH[idx, 13] <- round(myModel@model$training_metrics@metrics$pr_auc, digits = 3)
	modH[idx, 14] <- round(tab1[2,2] / (tab1[2,2] + tab1[2,1]),digits=3)#recall
	modH[idx, 15] <- round(tab1[2,2] / (tab1[2,2] + tab1[1,2]),digits=3)# precision
	modH[idx, 16] <- round(tab1[1,1] / (tab1[1,1] + tab1[2,1]),digits=3)# Specificity

	return(modH)
}

add_test_results <- function (perf, modH){
	idx <- nrow(modH) + 1
	tab2 <- perf@metrics$cm$table

	modH[idx, 1] <- perf@metrics$model$name
	modH[idx, 2] <- round(1- perf@metrics$cm$table$Error[3], digits=3)
	modH[idx, 3] <- round(perf@metrics$mean_per_class_error, digits=3)
	modH[idx, 4] <- round(perf@metrics$logloss, digits=3)
	modH[idx, 5] <- round(perf@metrics$AUC, digits = 3)
	modH[idx, 6] <- round(perf@metrics$pr_auc, digits = 3)
	modH[idx, 7] <- round(tab2[2,2] / (tab2[2,2] + tab2[2,1]),digits=3)#recall
	modH[idx, 8] <- round(tab2[2,2] / (tab2[2,2] + tab2[1,2]),digits=3)# precision
	modH[idx, 9] <- round(tab2[1,1] / (tab2[1,1] + tab2[2,1]),digits=3)# Specificity
	modH[idx, 10] <- round(perf@metrics$max_criteria_and_metric_scores$value[1], digits=3)
	modH[idx, 11] <- round(perf@metrics$max_criteria_and_metric_scores$threshold[1], digits=3)

	return(modH)
}

#not using scu and patserv yet!
# varx <- 5:42
vary <- "alc_status"

df.hex  <- as.h2o(dfx)

df.split <- h2o.splitFrame(df.hex, ratios = c(0.8), seed = 1234)
train <- df.split[[1]]
test <- df.split[[2]] #not using this until best hyperparameters are chosen

sel_feat <- rownames(feat_rank)[1:30]

df.hex_gbmNew <- h2o.gbm(
training_frame = train,
x = sel_feat,
y = vary,
model_id = "gbm_first30MutINF",
nfolds = 5,
fold_assignment = "Stratified",
balance_classes = TRUE,
ntrees = 500,
stopping_rounds = 5,
stopping_tolerance = 1e-3, ##early stop if AUCPR did not improve at least 0.1% over 5 consecutive turns
stopping_metric = "AUCPR",
score_tree_interval = 5,
#score_each_iteration = T, #wrong if used with above argument (I guess!)
seed = 1234
)

# modH <- new_resultFrame()
modH <- add_cv_results(df.hex_gbmNew, modH)

sel_feat <- rownames(feat_rank)[1:40]

df.hex_gbmNew2 <- h2o.gbm(
training_frame = train,
x = sel_feat,
y = vary,
model_id = "gbm_first40",
nfolds = 5,
fold_assignment = "Stratified",
balance_classes = TRUE,
ntrees = 500,
stopping_rounds = 5,
stopping_tolerance = 1e-3, ##early stop if AUCPR did not improve at least 0.1% over 5 consecutive turns
stopping_metric = "AUCPR",
score_tree_interval = 5,
score_each_iteration = T,
seed = 1234
)

modH <- add_cv_results(df.hex_gbmNew2, modH)

##added

sel_feat <- rownames(feat_rank)[1:45]

df.hex_gbmNew22 <- h2o.gbm(
training_frame = train,
x = sel_feat,
y = vary,
model_id = "gbm_first45",
nfolds = 5,
fold_assignment = "Stratified",
balance_classes = TRUE,
ntrees = 500,
stopping_rounds = 5,
stopping_tolerance = 1e-3, ##early stop if AUCPR did not improve at least 0.1% over 5 consecutive turns
stopping_metric = "AUCPR",
score_tree_interval = 5,
score_each_iteration = T,
seed = 1234
)

modH <- add_cv_results(df.hex_gbmNew22, modH)
###

sel_feat <- rownames(feat_rank)[1:50]

df.hex_gbmNew3 <- h2o.gbm(
training_frame = train,
x = sel_feat,
y = vary,
model_id = "gbm_first50",
nfolds = 5,
fold_assignment = "Stratified",
balance_classes = TRUE,
ntrees = 500,
stopping_rounds = 5,
stopping_tolerance = 1e-3, ##early stop if AUCPR did not improve at least 0.1% over 5 consecutive turns
stopping_metric = "AUCPR",
score_tree_interval = 5,
score_each_iteration = T,
seed = 1234
)

modH <- add_cv_results(df.hex_gbmNew3, modH)

sel_feat <- rownames(feat_rank)[1:60]

df.hex_gbmNew4 <- h2o.gbm(
training_frame = train,
x = sel_feat,
y = vary,
model_id = "gbm_first60",
nfolds = 5,
fold_assignment = "Stratified",
balance_classes = TRUE,
ntrees = 500,
stopping_rounds = 5,
stopping_tolerance = 1e-3, ##early stop if AUCPR did not improve at least 0.1% over 5 consecutive turns
stopping_metric = "AUCPR",
score_tree_interval = 5,
score_each_iteration = T,
seed = 1234
)

modH <- add_cv_results(df.hex_gbmNew4, modH)

sel_feat <- rownames(feat_rank)[1:68]

df.hex_gbmNew5 <- h2o.gbm(
training_frame = train,
x = sel_feat,
y = vary,
model_id = "gbm_first70",
nfolds = 5,
fold_assignment = "Stratified",
balance_classes = TRUE,
ntrees = 500,
stopping_rounds = 5,
stopping_tolerance = 1e-3, ##early stop if AUCPR did not improve at least 0.1% over 5 consecutive turns
stopping_metric = "AUCPR",
score_tree_interval = 5,
score_each_iteration = T,
seed = 1234
)

modH <- add_cv_results(df.hex_gbmNew5, modH)

################
# Using other algorithms, Random Forest etc.,

sel_feat <- rownames(feat_rank)[1:40]

df_rf1 <- h2o.randomForest(
training_frame = train,
x = sel_feat,
y = vary,
model_id = "rf_first40",
nfolds = 5,
fold_assignment = "Stratified",
balance_classes = TRUE,
ntrees = 500,
stopping_rounds = 5,
stopping_tolerance = 1e-3, ##early stop if AUCPR did not improve at least 0.1% over 5 consecutive turns
stopping_metric = "AUCPR",
score_tree_interval = 5,
score_each_iteration = T,
seed = 1234
)

modH <- add_results(df_rf1, modH)

sel_feat <- rownames(feat_rank)[1:50]

df_rf2 <- h2o.randomForest(
training_frame = train,
validation_frame = test,
x = sel_feat,
y = vary,
model_id = "rf_first50",
nfolds = 5,
fold_assignment = "Stratified",
balance_classes = TRUE,
ntrees = 500,
stopping_rounds = 5,
stopping_tolerance = 1e-3, ##early stop if AUCPR did not improve at least 0.1% over 5 consecutive turns
stopping_metric = "AUCPR",
score_tree_interval = 5,
score_each_iteration = T,
seed = 1234
)

modH <- add_results(df_rf2, modH)

####Playing with sample per class a little bit
#Up sample the minrotity (probably the default but let's see!)
sel_feat <- rownames(feat_rank)[1:40]

df.hex_gbmNew2_2 <- h2o.gbm(
training_frame = train,
validation_frame = test,
x = sel_feat,
y = vary,
model_id = "gbm_first40_overSample",
nfolds = 5,
fold_assignment = "Stratified",
balance_classes = TRUE,
class_sampling_factors = c(1, 8.3),
ntrees = 500,
stopping_rounds = 5,
stopping_tolerance = 1e-3, ##early stop if AUCPR did not improve at least 0.1% over 5 consecutive turns
stopping_metric = "AUCPR",
score_tree_interval = 5,
score_each_iteration = T,
seed = 1234
)

modH <- add_results(df.hex_gbmNew2_2, modH)

df.hex_gbmNew2_3 <- h2o.gbm(
training_frame = train,
validation_frame = test,
x = sel_feat,
y = vary,
model_id = "gbm_first40_UnderSample",
nfolds = 5,
fold_assignment = "Stratified",
balance_classes = TRUE,
class_sampling_factors = c(0.12, 1),
ntrees = 500,
stopping_rounds = 5,
stopping_tolerance = 1e-3, ##early stop if AUCPR did not improve at least 0.1% over 5 consecutive turns
stopping_metric = "AUCPR",
score_tree_interval = 5,
score_each_iteration = T,
seed = 1234
)

modH <- add_results(df.hex_gbmNew2_3, modH)

##Not much difference between their results!----> use H2o balance_classes like before


rm(list=ls())
library(dplyr)
library(ggplot2)
library(tidyr)
library(ggpubr)
library(stats)
library(tibble)

# set dataset

dataset <- "SinghalOG"

# Colors
# https://www.w3schools.com/colors/colors_picker.asp
color_S <- "orange"
color_TP <- "springgreen4"
color_AI <- "#2BB07FFF"
color_SA <- "#38598CFF"
color_SI <- "yellow4" # 8b8b00

setwd(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset, sep=''))

# Read in data
load(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/Calcs_",dataset,".RData", sep=''))

metaData <- c("MEAN_COL_SCORE","Sequences","Columns","Dist_Pat","Pars_Info","Sing_Sites","Cons_Sites" ,"Chi2_Fail","Gaps_Ambig")

# Add column to name type of support
mLGL <- mutate(mLGL, supportType = case_when(TvS != 'a' ~ "dGLS"))
mLBF <- mutate(mLBF, supportType = case_when(TvS != 'a' ~ "BF"))

# Change from 2ln(BF) to ln(BF) by dividing all comparisons by 2 7-10
mLBF[7:10] <- mLBF[7:10]/2
# for singhal OG
mLBF[4] <- mLBF[4]/2

# Check number of NA
sum(is.na(mLBF$MEAN_COL_SCORE))

# Transform datasets - stack two comparisons, and add column for bf and gl
# Each dataset one hypothesis

reformatdf <- function(df,h,h1,s1,keepCols){
  # keepCols is a vector of the locus and support type column indices
  # Grab column number
  c1 <- match(h1,names(df))
  # Grab and rename column, add hypothesis column
  a.df <- df[,append(keepCols,c1)]
  names(a.df)[names(a.df) == h1] <- h
  a.df$Hypothesis <- rep(h1,length(a.df[,1]))
  c <- match(h,names(a.df))
  # Adjust direction of support if needed. ie if column is AIvSA, but you want to know SAvAI
  a.df[,c] <- a.df[,c]*(s1)
  return(a.df)
}

# reformat
keep <- c(1,seq(14,22))
AI.g <- bind_rows(reformatdf(mLGL,"AI","AIvSA",1,keep),
                  reformatdf(mLGL,"AI","AIvSI",1,keep))

SA.g <- bind_rows(reformatdf(mLGL,"SA","AIvSA",-1,keep),
                  reformatdf(mLGL,"SA","SAvSI",1,keep))

SI.g <- bind_rows(reformatdf(mLGL,"SI","AIvSI",-1,keep),
                  reformatdf(mLGL,"SI","SAvSI",-1,keep))

AI.b <- bind_rows(reformatdf(mLBF,"AI","AIvSA",1,keep),
                  reformatdf(mLBF,"AI","AIvSI",1,keep))

SA.b <- bind_rows(reformatdf(mLBF,"SA","AIvSA",-1,keep),
                  reformatdf(mLBF,"SA","SAvSI",1,keep))

SI.b <- bind_rows(reformatdf(mLBF,"SI","AIvSI",-1,keep),
                  reformatdf(mLBF,"SI","SAvSI",-1,keep))

keep <- c(1,seq(5,13)) # for SinghalOG
TS.g <- reformatdf(mLGL,"TS","TvS",-1,keep)
TS.b <- reformatdf(mLBF,"TS","TvS",-1,keep)

# MERGE - yea i could have merged first, but the function was already written and i didnt want to mess with it.

AI.a <- left_join(AI.g, AI.b, by=c("Locus","Hypothesis",metaData), suffix = c(".g", ".b"))
SA.a <- left_join(SA.g, SA.b, by=c("Locus","Hypothesis",metaData), suffix = c(".g", ".b"))
SI.a <- left_join(SI.g, SI.b, by=c("Locus","Hypothesis",metaData), suffix = c(".g", ".b"))
TS.a <- left_join(TS.g, TS.b, by=c("Locus","Hypothesis",metaData), suffix = c(".g", ".b"))

sapply(AI.a,typeof)

# Smash all together, then smash bf and gl together each in 1 column
all <- bind_rows(bind_rows(bind_rows(AI.a,SA.a),SI.a),TS.a) %>%
  mutate(BF=coalesce(AI.b,SA.b,SI.b,TS.b)) %>%
  mutate(GL=coalesce(AI.g,SA.g,SI.g,TS.g)) %>%
  select(-c(AI.b,SA.b,SI.b,TS.b,AI.g,SA.g,SI.g,TS.g))

TX <- bind_rows(bind_rows(AI.a,SA.a),SI.a) %>%
  mutate(BF=coalesce(AI.b,SA.b,SI.b)) %>%
  mutate(GL=coalesce(AI.g,SA.g,SI.g)) %>%
  select(-c(AI.b,SA.b,SI.b,AI.g,SA.g,SI.g))

TS <- TS.a %>%
  mutate(BF=coalesce(TS.b)) %>%
  mutate(GL=coalesce(TS.g)) %>%
  select(-c(TS.b,TS.g))

# Check number of NA
sum(is.na(all$BF))
sum(is.na(all$GL))

rm(AI.g,AI.b,SA.b,SA.g,SI.b,SI.g,TS.b,TS.g)
rm(AI.a,SA.a,SI.a,TS.a)
rm(mLBF,mLGL)

##################################################################################################
## Test correlation across all hypotheses
##################################################################################################
# http://www.sthda.com/english/wiki/correlation-test-between-two-variables-in-r
# https://rpubs.com/aaronsc32/spearman-rank-correlation
rm(null,null_rs,new,sig2tp05,emp_rs)
# Create null distribution
all <- TS
v <- "ts"

# Making these all absolute values

all$BF <- abs(all$BF)
all$GL <- abs(all$GL)

# start with all the meta data

null <- all %>% select(c(Locus,Hypothesis,metaData,BF,GL))

# Permute BF and GL in 1,000 seperate columns

for (n in 1:1000) {
  newcolname1 <- paste('BF',n,sep='')
  null[, newcolname1] <- sample(all$BF, replace = FALSE)
  newcolname2 <- paste('GL',n,sep='')
  null[, newcolname2] <- sample(all$GL, replace = FALSE)
}

# Create new dataset for spearman rank coefficients (repeat later with kendall?)

assign('null_rs', setNames(data.frame(1:1000), "replicate"))

# for meta data

for (x in metaData) {
  null_rs[,paste(x,'.b.null',sep='')] <- NA
  null_rs[,paste(x,'.g.null',sep='')] <- NA
}

# then for bf and gl - these should end up the same

null_rs[,'GL.b.null'] <- NA # bf replicated, gl same
null_rs[,'BF.g.null'] <- NA # gl replicated, bf same

# Add bf gl

for (n in 1:1000) {

  # Grab column names, calculate value
  colname1 <- paste('BF',n,sep='')
  cc1 <- cor(null[,'GL'],null[,colname1],method="spearman")
  nullcol1 <- paste('GL','.b.null',sep='')
  null_rs[n,nullcol1] <- cc1
  colname2 <- paste('GL',n,sep='')
  cc2 <- cor(null[,'BF'],null[,colname2],method="spearman")
  nullcol2 <- paste('BF','.g.null',sep='')
  null_rs[n,nullcol2] <- cc2

}

for (i in metaData) {

  # Calculate rs for all permuted columns in null dataset

  for (n in 1:1000) {

    # Grab column names, calculate value
    colname1 <- paste('BF',n,sep='')
    cc1 <- cor(null[,i],null[,colname1],method="spearman")
    nullcol1 <- paste(i,'.b.null',sep='')
    null_rs[n,nullcol1] <- cc1
    colname2 <- paste('GL',n,sep='')
    cc2 <- cor(null[,i],null[,colname2],method="spearman")
    nullcol2 <- paste(i,'.g.null',sep='')
    null_rs[n,nullcol2] <- cc2

  }
}

save(all,null,null_rs, file=paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/",dataset,"_CorrNullDistAbs_",v,".RData",sep=''))
save(null_rs, file=paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/",dataset,"_CorrNullDistAbs_",v,"_rs.RData",sep=''))

#load("/Users/ChatNoir/Projects/Squam/scripts/Graphing/CorrelationNullDist_rs.RData")

# Add row of emp scores

assign('emp_rs', setNames(data.frame('emp'), "replicate"))
empRow <- 1

# First bf and gl

# Grab column names, calculate value for BF GL there is only one value for both columns

i <- "BF"
cc1 <- cor(all[,i],all[,'GL'],method="spearman")
empcol1 <- paste(i,'.g.emp',sep='')
emp_rs[empRow,empcol1] <- cc1
i <- "GL"
empcol2 <- paste(i,'.b.emp',sep='')
emp_rs[empRow,empcol2] <- cc1

# Add all metadata emp for BF and GL

metaData <- c("MEAN_COL_SCORE","Sequences","Columns","Dist_Pat","Pars_Info","Sing_Sites","Cons_Sites" ,"Chi2_Fail","Gaps_Ambig")

for (i in metaData) {
  cc1 <- cor(all[,i],all[,'GL'],method="spearman")
  empcol1 <- paste(i,'.g.emp',sep='')
  emp_rs[empRow,empcol1] <- cc1
  cc2 <- cor(all[,i],all[,'BF'],method="spearman")
  empcol2 <- paste(i,'.b.emp',sep='')
  emp_rs[empRow,empcol2] <- cc2
}

# Add rows for quantile cut offs

emp_rs$replicate <- as.character(emp_rs$replicate)
emp_rs[2,1] <- "p0.025"
emp_rs[3,1] <- "p0.975"

# add gl and bf

emp_rs[2,'GL.b.emp'] <- quantile(null_rs$BF.g.null, c(0.025, 0.975))[[1]]
emp_rs[3,'GL.b.emp'] <- quantile(null_rs$BF.g.null, c(0.025, 0.975))[[2]]
emp_rs[2,'BF.g.emp'] <- quantile(null_rs$GL.b.null, c(0.025, 0.975))[[1]]
emp_rs[3,'BF.g.emp'] <- quantile(null_rs$GL.b.null, c(0.025, 0.975))[[2]]

for (i in metaData) {
  gl.n <- paste(i,'.g.null',sep='')
  gl.e <- paste(i,'.g.emp',sep='')
  g025 <- quantile(null_rs[,gl.n], c(0.025, 0.975))[[1]]
  g975 <- quantile(null_rs[,gl.n], c(0.025, 0.975))[[2]]
  emp_rs[2,gl.e] <- g025
  emp_rs[3,gl.e] <- g975
  bf.n <- paste(i,'.b.null',sep='')
  bf.e <- paste(i,'.b.emp',sep='')
  b025 <- quantile(null_rs[,bf.n], c(0.025, 0.975))[[1]]
  b975 <- quantile(null_rs[,bf.n], c(0.025, 0.975))[[2]]
  emp_rs[2,bf.e] <- b025
  emp_rs[3,bf.e] <- b975
}

# Create two boolean rows for significance

# Transform dataset from rows to columns

new <- data.frame(t(emp_rs))
colnames(new) <- as.character(unlist(new[1,]))
new <- new[-1,]
new$emp <- as.numeric(as.character(new$emp))
new$p0.025 <- as.numeric(as.character(new$p0.025))
new$p0.975 <- as.numeric(as.character(new$p0.975))
sig2tp05 <- new %>% rownames_to_column('metaData') %>%
  mutate(sig = case_when(emp < p0.025 ~ "Lower",
                                       emp > p0.975 ~ "Upper",
                                    emp >= p0.025 & emp <= p0.975 ~ "False"))

# Save null and emp rs
save(null_rs, emp_rs, sig2tp05,  file=paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/",dataset,"_CorrAbs_",v,"_rsvals.RData",sep=''))
write.csv(sig2tp05,paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/",dataset,"_CorrAbs_",v,"_rsvals.csv",sep=''))
#v <- 'tx'
#load(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/",dataset,"_Corr_",v,"_rsvals.RData",sep=''))


rm(list = ls())

library(parallel)

# devtools::load_all()

set.seed(1122)

n          <- 2e3
parameters <- lapply(1:n, function(x) rbeta(5, 1, 10))# runif(5))
datasets   <- lapply(parameters, function(x) {
  aphylo::raphylo(100, psi=x[1:2], mu=x[3:4], Pi = x[5])
})

try_phylo_mle <- function(...)
  tryCatch(phylo_mle(...), error = function(e) NA)

cl <- makeForkCluster(16)

# Old Version
system("git checkout master")
e0 <- clusterEvalQ(cl, {
  devtools::load_all()
})

ans_old <- parLapply(cl, datasets, try_phylo_mle)

# New version
system("git checkout multiple-start")
e0 <- clusterEvalQ(cl, {
  devtools::load_all()
  })

ans_new <- parLapply(cl, datasets, try_phylo_mle)

# Pi 0/1
system("git checkout mlePi01")
e0 <- clusterEvalQ(cl, {
  devtools::load_all()
  })

ans_Pi01 <- parLapply(cl, datasets, try_phylo_mle)

# Fixing pi
system("git checkout fixpi")
e0 <- clusterEvalQ(cl, {
  devtools::load_all()
})

ans_fixpi <- clusterMap(
  cl, try_phylo_mle,
  dat = datasets,
  Pi  = lapply(1:n, function(x) parameters[[x]][5]))

stopCluster(cl)
# Tabulating results -----------------------------------------------------------

extractme <- function(x) {
  if (inherits(x, "phylo_mle")) x[["ll"]]
  else NA
}

mle_old   <- unlist(sapply(ans_old, extractme))
mle_new   <- unlist(sapply(ans_new, extractme))
mle_Pi01  <- unlist(sapply(ans_Pi01, extractme))
mle_fixpi <- unlist(sapply(ans_fixpi, extractme))

loglikes <- data.frame(
  old   = mle_old,
  new   = mle_new,
  Pi01  = mle_Pi01,
  fixpi = mle_fixpi,
  largest = apply(cbind(mle_old, mle_new, mle_Pi01, mle_fixpi), 1, function(x) {
    if (any(is.na(x))) return("-")
    paste(c("old", "No fixed", "Pi 0/1", "Pi = Pi*")[which(x == max(x))], collapse="-")

  }), check.names = FALSE
)

biascalc <- function(x, y) {
  if (inherits(x, "phylo_mle"))
    x[["par"]] - y
  else rep(NA, 5)
}

biases <- rbind(
  data.frame(do.call(rbind, Map(biascalc, ans_old, parameters)), model = "MLE starting at {.05}^5"),
  data.frame(do.call(rbind, Map(biascalc, ans_new, parameters)), model = "MLE starting at {.05, .95}^5"),
  data.frame(do.call(rbind, Map(biascalc, ans_Pi01, parameters)), model = "MLE starting at {.05, .95}^4\n and comparing Pi 0/1"),
  data.frame(do.call(rbind, Map(biascalc, ans_fixpi, parameters)), model = "MLE starting at {.05, .95}^4\nandfixing Pi = Pi*")
)

# The new is larger than the old one,
table(loglikes$largest)

# But the size of the bias of the new one, is huge
oldpar <- par(no.readonly = TRUE)
par(mfrow = c(2, 2), oma = c(2,0,2,0))
invisible(by(biases, biases$model, function(x) {
  boxplot(x[,-6], ylim = c(-1, 1), main = unique(x$model))
  abline(h=0, lty="dashed", lwd=2)
}))
par(oldpar)
title(
  main="Bias distribution",
  sub = paste(
    paste("Each box represents", n, "simulations of annotated trees with 100 leafs."),
    "All parameters follow a Beta(1,10) distribution.",
    sep="\n"
  )
)


library(phyloseq)
library('reshape2')
library('ggplot2')

# chargement de mon fichier.
load(system.file("data_test", "robjects_600.Rdata", package="ExploreMetabar"))
tt <- sample_data(data)$SampleType %in% c('Feces', 'Freshwater', 'Skin' )
phy_obj <- phyloseq::prune_samples(tt, data)
phy_obj <- prune_taxa(taxa_sums(phy_obj) > 0, phy_obj)

metadata <- as.data.frame(as.matrix(sample_data(phy_obj)[, 'SampleType']))

o_table <- as.data.frame(as.matrix(otu_table(phy_obj)))
o_table <- t(o_table)

lst <- c()
for (src in c('Feces', 'Freshwater')){
  lst[[src]] <- 'source'
}

metadata$sourceSink <- metadata[["SampleType"]]
metadata$sourceSink <- dplyr::recode(metadata$sourceSink, !!!lst)

metadata$sourceSink <- dplyr::recode(metadata$sourceSink, 'Skin' = 'sink')

if(length(rownames(metadata)) != length(rownames(o_table))){
  stop('Number of samples in metadata differs from otu table.')
}

metadata <- apply(metadata,2,function(x) gsub("[[:punct:]]",'_',x))
metadata <- apply(metadata,2,function(x) gsub("[[:space:]]",'_',x))
metadata <- as.data.frame(metadata)

train <- which(metadata$sourceSink=='source')
test <- which(metadata$sourceSink=='sink')

envs <- metadata[["SampleType"]]

print(envs)
alpha1 <- alpha2 <- 0.001

source('R/SourceTracker.r')

st <- sourcetracker(o_table[train,], envs[train], rarefaction_depth=1000)

res <- predict(st, o_table[test,], alpha1=alpha1, alpha2=alpha2, rarefaction_depth=1000, burnin=10, nrestarts=4)

prop <- as.data.frame(res$proportions)
prop[,'SampleType'] <- as.vector(metadata[rownames(res$proportions), "SampleType"])

tmp <- reshape2::melt(prop, id.vars='SampleType')
ggplot2::ggplot(tmp, aes(x=variable, y=value, fill=variable)) +geom_boxplot()


#!/usr/bin/env Rscript
#
#  phyloseq_ordination_p5.r - generate p5 ordination graphic through phyloseq
#
#  Version 1.0.0 (December 24, 2015)
#
#  Copyright (c) 2014-- Lela Andrews
#
#  This software is provided 'as-is', without any express or implied
#  warranty. In no event will the authors be held liable for any damages
#  arising from the use of this software.
#
#  Permission is granted to anyone to use this software for any purpose,
#  including commercial applications, and to alter it and redistribute it
#  freely, subject to the following restrictions:
#
#  1. The origin of this software must not be misrepresented; you must not
#     claim that you wrote the original software. If you use this software
#     in a product, an acknowledgment in the product documentation would be
#     appreciated but is not required.
#  2. Altered source versions must be plainly marked as such, and must not be
#     misrepresented as being the original software.
#  3. This notice may not be removed or altered from any source distribution.
#

## Load libraries
library(phyloseq)
library(ggplot2)
library(scales)
library(grid)
library(plyr)
theme_set(theme_bw())

## Recieve input files from bash
args <- commandArgs(TRUE)

otufile=(args[1])
mapfile=(args[2])
treefile=(args[3])
factor=(args[4])

## Load data into phyloseq
map=import_qiime_sample_data(mapfile)
tree=read_tree(treefile)
otus=import_biom(otufile,parseFunction=parse_taxonomy_greengenes)
mergedata=merge_phyloseq(otus,tree,map)
MD=mergedata

## Filter taxa not present at least 5 times in at least 10% of samples
md0 = genefilter_sample(MD, filterfun_sample(function(x) x > 5), A = 0.1 * nsamples(MD))
MD1=prune_taxa(md0, MD)

## Ordinate command
MD.ord <- ordinate(MD1, "NMDS", "bray")

## Composite faceted ordination
dist = "bray"
ord_meths = c("DCA", "CCA", "RDA", "DPCoA", "NMDS", "MDS", "PCoA")
plist = llply(as.list(ord_meths), function(i, physeq, dist) {
    ordi = ordinate(physeq, method = i, distance = dist)
    plot_ordination(physeq, ordi, "samples", color = "Community")
}, MD1, dist)
names(plist) <- ord_meths
pdataframe = ldply(plist, function(x) {
    df = x$data[, 1:2]
    colnames(df) = c("Axis_1", "Axis_2")
    return(cbind(df, x$data))
})
names(pdataframe)[1] = "method"
p5 = ggplot(pdataframe, aes(Axis_1, Axis_2, color = "Community", fill = "Community"))
p5 = p5 + geom_point(size = 4) + geom_polygon()
p5 = p5 + facet_wrap(~method, scales = "free")
p5 = p5 + scale_fill_brewer(type = "qual", palette = "Set1")
p5 = p5 + scale_colour_brewer(type = "qual", palette = "Set1")

## Output pdf graphic
pdf(paste0(factor, "_composite_ordinations.pdf"))
plot(p5)
dev.off()


library(plyr)
source('formant_functions.r')

# LOAD THE VOWEL MEASUREMENTS
all_formant_data <- list()

all_formant_data[['PAC-Ayr']] <- read.csv('/projects/spade/datasets/datasets_static_formants/spade-PAC-Ayr_formants.csv')
all_formant_data[['ICE-Sco']] <- read.csv('/projects/spade/datasets/datasets_static_formants/spade-ICE-Sco_formants.csv')
all_formant_data[['LUCID']] <- read.csv('/projects/spade/datasets/datasets_static_formants/spade-LUCID_formants.csv')
all_formant_data[['UBC']] <- read.csv('/projects/spade/datasets/datasets_static_formants/spade-UBC_formants.csv')
all_formant_data[['Devon']] <- read.csv('/projects/spade/datasets/datasets_static_formants/spade-Devon_formants.csv')
all_formant_data[['Scottish-Polish']] <- read.csv('/projects/spade/datasets/datasets_static_formants/spade-Scottish-Polish_formants.csv')

measurement_point <- 0.33

for (corpus_name in names(all_formant_data)){
	print (corpus_name)
	formant_data <- all_formant_data[[corpus_name]]

	# NAME THE OUTPUT FILES
	prototypes_filename <- paste0('spade-',corpus_name,'/spade-',corpus_name,'_prototypes.csv')
	plot_filename <- paste0('spade-',corpus_name,'/corpus_means_for_prototypes_',corpus_name,'.pdf')

	# ADD AND RENAME DATA COLUMNS AS NEEDED
	formant_data$measurement <- measurement_point
	names(formant_data) <- gsub('phone_label', 'phone', names(formant_data))
	names(formant_data) <- gsub('phone_', '', names(formant_data))
	formant_data$A1A2diff <- with(formant_data, A1-A2)
	formant_data$A2A3diff <- with(formant_data, A2-A3)

	# THE PARAMETERS FOR THE PROTOTYPES
	proto_parameters <- c('F1','F2','F3','B1','B2','B3','A1A2diff','A2A3diff')

	# REMOVE ROWS WITH NA FOR COLUMNS WE NEED FOR PROTOTYPES AND OMIT PHONES WITH FEWER THAN 6 REMAINING TOKENS
	formant_data <- formant_data[complete.cases(formant_data[,proto_parameters]),]
	lofreq_phones <- names(table(formant_data$phone))[table(formant_data$phone)<6]
	if (length(lofreq_phones)){
		formant_data <- subset(formant_data, !phone%in%lofreq_phones)
		print (paste('omitting low-frequency phone', lofreq_phones))
	}

	# CALCULATE THE MEANS AND COVARIANCE MATRICES
	corpus_means_for_phones <- ddply(formant_data[,c('phone', proto_parameters)], .(phone), numcolwise(mean, na.rm=T))
	names(corpus_means_for_phones)[names(corpus_means_for_phones)%in%proto_parameters] <- paste(names(corpus_means_for_phones)[names(corpus_means_for_phones)%in%proto_parameters], measurement_point, sep='_')
	corpus_covmats_list <- findCovarianceMatrices(formant_data, parameters=proto_parameters, measurements=c(measurement_point),
	                                   write.to.file=FALSE, filename=NULL, data.frame(vowel_means=corpus_means_for_phones, measurement=measurement_point),
	                                   normalized=FALSE, pass_id='mixed', target_phones=unique(formant_data$phone))

	# FORMAT THE COVARIANCE MATRICES FOR THE OUTPUT AND COMBINE THEM WITH THE MEANS
	corpus_covmats <- c()
	for(p in names(corpus_covmats_list)){
	  	phone_matrix <- corpus_covmats_list[[p]]
	  	corpus_covmats <- rbind(corpus_covmats, data.frame(phone=p, phone_matrix))
	}
	phones_for_polyglot <- rbind(data.frame(type='means', corpus_means_for_phones), data.frame(type='matrix',corpus_covmats))

	# MAKE THE PROTOTYPE FILE
	write.table(phones_for_polyglot, file=prototypes_filename, row.names=F, sep=',', quote=FALSE)

	# PLOT THE MEANS
	cairo_pdf(plot_filename, h=6, w=6, onefile=T)
	for (i in 1:(length(proto_parameters)-1)){
		param1 <- paste(proto_parameters[i+1],'0.33',sep='_')
		param2 <- paste(proto_parameters[i],'0.33',sep='_')
		plot(corpus_means_for_phones[,param1], corpus_means_for_phones[,param2], main=paste(corpus_name, param1, 'vs.', param2), type='n', xlab=param1, ylab=param2,
		    xlim=rev(range(corpus_means_for_phones[,param1])), ylim=rev(range(corpus_means_for_phones[,param2])))
		text(corpus_means_for_phones[,param1], corpus_means_for_phones[,param2], labels=corpus_means_for_phones$phone)
	}
	dev.off()
}


suppressPackageStartupMessages(library(float))
suppressPackageStartupMessages(library(utils))

m = 10L
n = 3L

x = matrix(1:(m*n), m, n)
xs = fl(x)

stopifnot(identical(nrow(x), m))
stopifnot(identical(ncol(x), n))
stopifnot(identical(dim(x), c(m, n)))

p = paste(capture.output(print(xs)), collapse="\n")
truth = "# A float32 matrix: 10x3
      [,1] [,2] [,3]
 [1,]    1   11   21
 [2,]    2   12   22
 [3,]    3   13   23
 [4,]    4   14   24
 [5,]    5   15   25
 [6,]    6   16   26
 [7,]    7   17   27
 [8,]    8   18   28
 [9,]    9   19   29
[10,]   10   20   30"

stopifnot(identical(p, truth))


MergePathways <- function(file_dir, pattern = NULL) {
  # This function combine pathway files in a certain directory

  ## === input ===
  ### file_dir: pathway file directory (subnetworks)
  ### pattern: specific types of edges needed in the merged pathway; default as all edges

  ## == output ===
  ### merged pathway file

  # load files
  file_names = dir(file_dir,full.names = T)
  all_file = c()
  for (i in 1:length(file_names)) {
    tmp.file = read.delim(file_names[i],header = T,sep = ",")
    all_file = rbind(all_file, tmp.file[,1:6])
  }
  # generate adjacency matrix and get rid of the redundant linkages
  new_file = c()
  multi_linkage = c()
  unique_nodes = unique(c(as.character(as.matrix(all_file$node1)), as.character(as.matrix(all_file$node2))))
  adj.matrix = matrix(0, nrow = length(unique_nodes), ncol = length(unique_nodes),
                      dimnames = list(unique_nodes, unique_nodes))
  node1.list = as.character(as.matrix(all_file$node1))
  node2.list = as.character(as.matrix(all_file$node2))
  for (i in 1:dim(all_file)[1]) {
    current_state = adj.matrix[node1.list[i],node2.list[i]]
    if (current_state == 0) {
      adj.matrix[node1.list[i],node2.list[i]] = as.numeric(all_file$Subtype1[i])
      new_file = rbind(new_file, all_file[i,])
    } else {
      new_state = as.numeric(all_file$Subtype1[i])
      if (new_state != current_state) {
        if (is.null(dim(multi_linkage))) {
          multi_linkage = rbind(multi_linkage, c(node1.list[i], node2.list[i], new_state))
          new_file = rbind(new_file, all_file[i,])
        } else {
          flag = F
          for (j in 1:dim(multi_linkage)[1]) {
            if (multi_linkage[j,1] == node1.list[i] & node2.list[i] == multi_linkage[j,2] & new_state == multi_linkage[j,3]) {
              flag = T
              break
            }
          }
          if (!flag) {
            multi_linkage = rbind(multi_linkage, c(node1.list[i], node2.list[i], new_state))
            new_file = rbind(new_file, all_file[i,])
          }
        }
      }
    }
  }
  list(new_file,multi_linkage)
}


#script resamples original soil texture data and converts to values neeed for moistureMap.r (etc)

rm(list=ls())
library(raster)

#read munis.r as latlong
unzip(zipfile="Data/sim10_BRmunis_latlon_5km.zip",exdir="Data")  #unzip
munis.r <- raster("Data/sim10_BRmunis_latlon_5km.asc")
latlong <- "+proj=longlat +ellps=WGS84 +towgs84=0,0,0,0,0,0,0 +no_defs "
crs(munis.r) <- latlong

#note textura_wgs84.asc in zip file is 1.6GB!
unzip(zipfile="Data/textura_wgs84.zip",exdir="Data")  #unzip
vsoil<-raster("Data/textura_wgs84.asc")

#resample soil maps from ~250m resolution to 5km
vsoil.m<- resample(vsoil, munis.r, method='ngb')
vsoil.m<- mask(x=vsoil.m, mask=munis.r)
writeRaster(vsoil.m, "Data/soilT_2018-05-01", "ascii", "overwrite"=T)

#classify soil texture map for CRAFTY
#classification is shown in SoilClassification.docx
#plot(vsoil)
values(vsoil.m)[values(vsoil.m)==1] = 0
values(vsoil.m)[values(vsoil.m)==2] = 0
values(vsoil.m)[values(vsoil.m)==3] = 1
values(vsoil.m)[values(vsoil.m)==4] = 0.5
values(vsoil.m)[values(vsoil.m)==5] = 0.1

#write to file
writeRaster(vsoil.m, "Data/vsoil_2018-05-08", "ascii", "overwrite"=T)

unlink("Data/textura_wgs84.asc")  #large file so delete!
unlink("Data/sim10_BRmunis_latlon_5km.asc")


rm(list=ls())
library(dplyr)
library(ggplot2)
library(tidyr)
library(ggpubr)

# set dataset

dataset <- "Singhal"

setwd(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset, sep=''))

# Read in data
load(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/Calcs_",dataset,".RData", sep=''))

metaData <- c("MEAN_COL_SCORE","Sequences","Columns","Dist_Pat","Pars_Info","Sing_Sites","Cons_Sites" ,"Chi2_Fail","Gaps_Ambig")

# Add column to name type of support
mLGL <- mutate(mLGL, supportType = case_when(TvS != 'a' ~ "dGLS"))
mLBF <- mutate(mLBF, supportType = case_when(TvS != 'a' ~ "BF"))

# Change from 2ln(BF) to ln(BF) by dividing all comparisons by 2 7-10
mLBF[7:10] <- mLBF[7:10]/2

# Check number of NA
sum(is.na(mLBF$MEAN_COL_SCORE))

# Want to stack datasets so GL and BF columns have both comparisons for each hypothesis.

reformatdf <- function(df,h,h1,s1,keepCols){
  # keepCols is a vector of the locus and support type column indices
  # Grab column number
  c1 <- match(h1,names(df))
  # Grab and rename column, add hypothesis column
  a.df <- df[,append(keepCols,c1)]
  names(a.df)[names(a.df) == h1] <- h
  a.df$Hypothesis <- rep(h1,length(a.df[,1]))
  c <- match(h,names(a.df))
  # Adjust direction of support if needed. ie if column is AIvSA, but you want to know SAvAI
  a.df[,c] <- a.df[,c]*(s1)
  return(a.df)
}

# reformat
keep <- c(1,seq(14,22))
AI.g <- bind_rows(reformatdf(mLGL,"AI","AIvSA",1,keep),
                  reformatdf(mLGL,"AI","AIvSI",1,keep))

SA.g <- bind_rows(reformatdf(mLGL,"SA","AIvSA",-1,keep),
                  reformatdf(mLGL,"SA","SAvSI",1,keep))

SI.g <- bind_rows(reformatdf(mLGL,"SI","AIvSI",-1,keep),
                  reformatdf(mLGL,"SI","SAvSI",-1,keep))

AI.b <- bind_rows(reformatdf(mLBF,"AI","AIvSA",1,keep),
                  reformatdf(mLBF,"AI","AIvSI",1,keep))

SA.b <- bind_rows(reformatdf(mLBF,"SA","AIvSA",-1,keep),
                  reformatdf(mLBF,"SA","SAvSI",1,keep))

SI.b <- bind_rows(reformatdf(mLBF,"SI","AIvSI",-1,keep),
                  reformatdf(mLBF,"SI","SAvSI",-1,keep))

TS.g <- reformatdf(mLGL,"TS","TvS",-1,keep)
TS.b <- reformatdf(mLBF,"TS","TvS",-1,keep)

# MERGE - yea i could have merged first, but the function was already written and i didnt want to mess with it.

AI.a <- left_join(AI.g, AI.b, by=c("Locus","Hypothesis",metaData), suffix = c(".g", ".b"))
SA.a <- left_join(SA.g, SA.b, by=c("Locus","Hypothesis",metaData), suffix = c(".g", ".b"))
SI.a <- left_join(SI.g, SI.b, by=c("Locus","Hypothesis",metaData), suffix = c(".g", ".b"))
TS.a <- left_join(TS.g, TS.b, by=c("Locus","Hypothesis",metaData), suffix = c(".g", ".b"))

sapply(AI.a,typeof)

# Smash all together, then smash bf and gl together each in 1 column
all <- bind_rows(bind_rows(bind_rows(AI.a,SA.a),SI.a),TS.a) %>%
  mutate(BF=coalesce(AI.b,SA.b,SI.b,TS.b)) %>%
  mutate(GL=coalesce(AI.g,SA.g,SI.g,TS.g)) %>%
  select(-c(AI.b,SA.b,SI.b,TS.b,AI.g,SA.g,SI.g,TS.g))

TX <- bind_rows(bind_rows(AI.a,SA.a),SI.a) %>%
  mutate(BF=coalesce(AI.b,SA.b,SI.b)) %>%
  mutate(GL=coalesce(AI.g,SA.g,SI.g)) %>%
  select(-c(AI.b,SA.b,SI.b,AI.g,SA.g,SI.g))

TS <- TS.a %>%
  mutate(BF=coalesce(TS.b)) %>%
  mutate(GL=coalesce(TS.g)) %>%
  select(-c(TS.b,TS.g))

# Check number of NA
sum(is.na(all$BF))
sum(is.na(all$GL))

rm(AI.g,AI.b,SA.b,SA.g,SI.b,SI.g,TS.b,TS.g)

v <- 'tx'
load(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/",dataset,"_Corr_",v,"_rsvals.RData",sep=''))
#------------------------------------------------------------------------------------------------------------------------------------------------------

# Scatter ---------------------------------------------- Scatter BF vs dGLS --------------------------------------------------------------------------------------------------------

#------------------------------------------------------------------------------------------------------------------------------------------------------

## Scatter graph, colored by hypothesis

S <- function(df,xcol,ycol,x.tic,y.tic,cc,xlab,ylab){
  scat <- ggplot(df, aes(x=df[[xcol]],y=df[[ycol]])) +
    geom_point(alpha=1, aes(color=df$Hypothesis), size=0.5) + theme_bw() + theme(panel.border = element_blank()) +
    theme_classic() +
    theme(
      axis.text = element_text(size=14, color="black"),
      text = element_text(size=14),
      panel.border = element_blank(),
      panel.background = element_rect(fill = "transparent"), # bg of the panel
      plot.background = element_rect(fill = "transparent", color = NA), # bg of the plot
      panel.grid = element_blank(), # get rid of major grid
      plot.title = element_text(hjust = 0.5)
    ) +
    coord_cartesian(ylim=y.tic,xlim = x.tic) +
    scale_y_continuous(breaks = y.tic) +
    scale_x_continuous(breaks = x.tic) +
    labs(x=xlab,y=ylab,color="Hypothesis") +
    scale_color_manual(values=cc) +
    guides(colour = guide_legend(override.aes = list(size=2)))

  return(scat)
}

S.abs <- function(df,xcol,ycol,x.tic,y.tic,cc,xlab,ylab){
  scat <- ggplot(df, aes(x=abs(df[[xcol]]),y=df[[ycol]])) +
    geom_point(alpha=1, aes(color=df$Hypothesis), size=0.5) + theme_bw() + theme(panel.border = element_blank()) +
    theme_classic() +
    theme(
      axis.text = element_text(size=14, color="black"),
      text = element_text(size=14),
      panel.border = element_blank(),
      panel.background = element_rect(fill = "transparent"), # bg of the panel
      plot.background = element_rect(fill = "transparent", color = NA), # bg of the plot
      panel.grid = element_blank(), # get rid of major grid
      plot.title = element_text(hjust = 0.5)
    ) +
    coord_cartesian(ylim=y.tic,xlim = x.tic) +
    scale_y_continuous(breaks = y.tic) +
    scale_x_continuous(breaks = x.tic) +
    labs(x=xlab,y=ylab,color="Hypothesis") +
    scale_color_manual(values=cc) +
    guides(colour = guide_legend(override.aes = list(size=2)))

  return(scat)
}

# col numbers for metadata
hot <- 2 # alignment quality score
seq <- 3 # total number of taxa
col <- 4 # sites in alignment
dist <- 5 # distinct patterns
pi <- 6 # PI sites
sing <- 7 # singleton sites
cons <- 8 # constant sites
chi2 <- 9 # number of sequences that failed composition chi2 test
gaps <- 10 # number of sequences that contain 50% or more gaps/ambiguity
gl <- 11
hyp <- 12
bf <- 13 # max 180 for tox, all but 3 btw -50 and 20, 70 for tvs

yV <- gaps
yL <- "gaps"
#xV <- bf
#xL <- "ln(BF)"
#lines <- geom_vline(xintercept=c(-10,10),color=c("black"), linetype="dashed", size=0.5)
xV <- gl
xL <- "dGLS"
lines <- geom_vline(xintercept=c(-0.5,0.5),color=c("black"), linetype="dashed", size=0.5)

df <- AI.a
# Get max min for graph x = dgls y=bf
max(abs(df[[bf]]),na.rm = T)
max(abs(df[[gaps]]),na.rm = T)
x.lim <- 180
x.t <- seq(-x.lim,x.lim,40)
y.lim <- 8
y.t <- seq(0,8,2)

#quartz()
# Set colors
cc <- c('#1e7b59','#46d29f') # 3 up and 3 down from original
# 11 = gl, 13 = bf

AI.s <- S(AI.a,xV,yV,x.t,y.t,cc,xL,yL) +  lines

AI.s

# Set colors
cc <- c('#243a5b','#4975b6')

SA.s <- S(SA.a,xV,yV,x.t,y.t,cc,xL,yL) +  lines

SA.s

# Set colors
cc <- c('#4d4d00','#cccc00')

SI.s <- S(SI.a,xV,yV,x.t,y.t,cc,xL,yL) +  lines

SI.s

cc = color_TP
TS.s <- S(TS.a,xV,yV,x.t,y.t,cc,xL,yL) +  lines

TS.s

SP <- ggarrange(TS.s, AI.s, SA.s, SI.s, ncol=1, nrow=4, align="h")
SP
#yL <- "gaps"
ggsave(paste(dataset,"_scatter_",xL,"_",yL,".pdf",sep=""), plot=SP,width = 6, height = 9, units = "in", device = 'pdf',bg = "transparent")

# Get max min for graph

max(abs(min(mL$BF)),abs(max(mL$BF)),abs(min(mL$dGLS)),abs(max(mL$dGLS)))
limit <- 90
tic <- seq(-limit,limit,10)

# Names "TvS", "AIvSA", "AIvSI", "SAvAI", "SAvSI", "SIvAI", "SIvSA", "TvS_support"

color_S <- "orange"
color_TP <- "springgreen4"
color_AI <- "#2BB07FFF"
color_SA <- "#38598CFF"
color_SI <- "#C2DF23FF"

quartz()
# Set colors
color_h0 <- color_AI
color_h0 <- color_TP

graph_general <- ggplot(mL, aes(x=BF,y=MEAN_COL_SCORE)) +
  geom_point(alpha=0.5, color=color_h0, size=1) + theme_bw() + theme(panel.border = element_blank()) +
  theme_classic() +
  theme(
    axis.text = element_text(size=16, color="black"),
    text = element_text(size=20),
    legend.position = "none",
    panel.border = element_blank(),
    panel.background = element_rect(fill = "transparent"), # bg of the panel
    plot.background = element_rect(fill = "transparent", color = NA), # bg of the plot
    panel.grid = element_blank(), # get rid of major grid
    plot.title = element_text(hjust = 0.5)
  ) +
  coord_cartesian(ylim=tic,xlim = tic) +
  scale_y_continuous(breaks = tic) +
  scale_x_continuous(breaks = tic) +
  labs(x='ln(BF)',y='dGLS')

graph_general

graph_custom <- graph_general +
  geom_vline(xintercept=c(10,-10),color=c("gray"), linetype="dotted", size=0.5) +
  geom_hline(yintercept=c(0.5,-0.5),color=c("gray"), linetype="dotted", size=0.5) +
  ggtitle(paste(dataset,"\n",t,sep=""))
  #geom_abline(color=c("gray"), size=0.2, linetype="solid") +

graph_custom

ggsave(paste(dataset,"_scatter_",hypoth,".pdf",sep=""), plot=graph_custom,width = 9.5, height = 6, units = "in", device = 'pdf',bg = "transparent")


#########################################################################################################################
#                                                  Routing with R                                                       #
#                                                                                #
# Version: 0.1                                                                                #
# Author: Michalis Pavlis                                                                                #
# Licence: MIT                                                                                #
#                                                                                #
# lines_to_graph: Function to create a graph representation (directed, undirected) of the lines network                 #
#                                                                                #
# is_connected: Function to clean the line network by identifying the self-connected line segments                      #
#                                                                                #
# shortest_route_cost: Function to calculate the shortest route cost either in kilometres or minutes                    #
#                                                                                #
#########################################################################################################################

library(igraph)
library(FNN)
library(data.table)
library(sf)
library(parallel)

#########################################################################################################################
#                                           Check functions' arguments                                                  #
#########################################################################################################################

.check_values <- function(sf_df, column_name){
  if (any(is.na(sf_df[[column_name]]))) stop(paste("NA values were found in column", column_name))
  if (any(is.null(sf_df[[column_name]]))) stop(paste("NULL values were found in column", column_name))
}

.check_sf <- function(sf_df, geom_column){

  if (! is(sf_df, "sf")) stop("object class should be 'sf'")

  if (! geom_column %in% names(sf_df)) stop("provide geometry column")

  .check_values(sf_df, geom_column)

  p4str <- st_crs(sf_df)$proj4string
  if (is.na(p4str) || !nzchar(p4str)) stop("specify coordinate reference system")

  res <- grep("longlat", p4str, fixed = TRUE)
  if (length(res) != 0) stop("use projected reference system")

}

.check_line <- function(sf_df, geom_column){

  .check_sf(sf_df, geom_column)

  if (!is(sf_df[[geom_column]], "sfc_LINESTRING")){
    stop("the geometry column class should be 'sfc_LINESTRING'")
  }

}

.check_is_connected <- function(lines_sf, geom_column, allpoints, area_id){

  .check_line(lines_sf, geom_column)

  if (! allpoints %in% c(T, F)) stop("allpoints should be either True or False")

  if (!is.null(area_id)){
    if (! area_id %in% names(lines_sf)) stop(paste("the column", area_id, "was not found in lines_sf"))
    .check_values(lines_sf, area_id)
  }

}

.check_lines_to_graph <- function(lines_sf, geom_column, allpoints, area_id, weighted_graph,
                                speed_limit_column, direction_column, direction_lookup) {

  .check_is_connected(lines_sf, geom_column, allpoints, area_id)

  if (! allpoints %in% c(T, F)) stop("allpoints should either be True or False")

  if (! weighted_graph %in% c(T, F)) stop("weighted_graph should either be True or False")

  if (!is.null(speed_limit_column)){
    if (! speed_limit_column %in% names(lines_sf)) stop(paste("the column", speed_limit_column, "was not found in lines_sf"))
    if (! is(lines_sf[[speed_limit_column]], "numeric")) stop("the class of the speed limit column should be numeric")
    .check_values(lines_sf, speed_limit_column)
  }

  if (!is.null(direction_column)){
    if (! direction_column %in% names(lines_sf)) stop(paste("the column", direction_column, "was not found in lines_sf"))
    .check_values(lines_sf, direction_column)
    if (length(unique(lines_sf[[direction_column]])) != 3) stop(paste("only three values are expected in column", direction_column, "that represent back, forward and both traffic direction"))
    if (! length(direction_lookup[[1]]) == 3) stop("provide exactly three values for the first vector in the direction_lookup list: forward, opposite and both")
    if (! length(direction_lookup[[2]]) == 3) stop("provide exactly three values for the second vector in the direction_lookup list")
    if (! all(c("forward","opposite", "both") %in% direction_lookup[[1]])) stop("the only values expected in the first vector of direction_lookup are: forward, opposite and both")
    if (! all(direction_lookup[[2]] %in% unique(lines_sf[[direction_column]]))) stop(paste("the values provided in the second column of the direction_lookup table do not match with the values in", direction_column))
  }
}

.check_shortest_route <- function(origins_sf, destinations_sf, geom_column, id_column, lines_graph, lookup_table, join_by){

  .check_sf(origins_sf, geom_column)
  if (! is(origins_sf$geometry, "sfc_POINT")) stop("the class of the geometry column in origins_sf should be 'sfc_POINT'")

  .check_sf(destinations_sf, geom_column)
  if (! is(destinations_sf$geometry, "sfc_POINT")) stop("the class of the geometry column in destinations_sf should be 'sfc_POINT'")

  if (! identical(st_crs(origins_sf)$proj4string, st_crs(destinations_sf)$proj4string)){
    stop("origin and destination points are not in the same reference system")
  }

  if (! identical(st_crs(origins_sf)$proj4string, attributes(lines_graph)$proj4string)){
    stop("the road network is not in the same reference system with the point data")
  }

  if (! id_column %in% names(origins_sf)) stop("provide id field for origins_sf")
  .check_values(origins_sf, id_column)

  if (! id_column %in% names(destinations_sf)) stop("provide id field for destinations_sf")
  .check_values(destinations_sf, id_column)

  if (!is.null(lookup_table)){
    if (ncol(lookup_table) != 2){
      stop("the lookup table should have two columns")
    }
    if (!any(unique(origins_sf[[id_column]]) %in% unique(lookup_table[,1]))){
      stop(paste("there are no matching values between the field", id_column, "in origins_sf and the first column in the lookup_table"))
    }
    if (!any(unique(destinations_sf[[id_column]]) %in% unique(lookup_table[,2]))){
      stop(paste("there are no matching values between the", id_column, "field in destinations_sf and the second column in the lookup_table"))
    }
    .check_values(lookup_table, colnames(lookup_table)[1])
    .check_values(lookup_table, colnames(lookup_table)[2])
    if (!is.null(join_by)){
      warning("both lookup_table and join_by were provided, ignoring join_by")
    }
  }

  if (!is.null(join_by)){
    if (! join_by %in% names(origins_sf)){
      stop(paste("the field", join_by, "was not found in origins_sf"))
    }
    if (! join_by %in% names(destinations_sf)){
      stop(paste("the field", join_by, "was not found in destinations_sf"))
    }
    if (! any(origins_sf[[join_by]] %in% destinations_sf[[join_by]])){
      stop(paste("you are trying to join origins_sf and destinations_sf by", join_by, "but there are no common values"))
    }
    .check_values(origins_sf, join_by)
    .check_values(destinations_sf, join_by)
  }
}

#########################################################################################################################
#                                      Create graph from lines network                                                  #
#########################################################################################################################

lines_to_graph <- function(lines_sf, geom_column, allpoints = T,  area_id = NULL,
                           weighted_graph = F, speed_limit_column = NULL, direction_column = NULL,
                           direction_lookup = list(c("forward","opposite", "both"), c("F","T","B"))){

  ##### 1. Edge list functions ##########################################################################################

  edge_list_endpoints <- function(coords){
    n <- nrow(coords)
    c(paste(coords[1, ], collapse = " "), paste(coords[n, ], collapse = " "))
  }

  edge_list_allpoints <- function(coords){
    n <- nrow(coords)
    cbind(coords[-n, 1], coords[-n, 2], coords[-1, 1], coords[-1, 2])
  }

  edge_list_allpoints_back <- function(coords){
    n <- nrow(coords)
    coords <- coords[n:1, ]
    cbind(coords[-n, 1], coords[-n, 2], coords[-1, 1], coords[-1, 2])
  }

  ##### 2. Check inputs #################################################################################################

  .check_lines_to_graph(lines_sf, geom_column, allpoints, area_id, weighted_graph, speed_limit_column, direction_column, direction_lookup)

  ##### 3. Build edge list ##############################################################################################

  if (is.null(direction_column)){
    if (! allpoints){
	  edgelist <- do.call(rbind, lapply(1:nrow(lines_sf), function(x) edge_list_endpoints(unclass(lines_sf[[geom_column]][[x]]))))
    } else {
      edgelist <- do.call(rbind, lapply(1:nrow(lines_sf), function(x) cbind(x, edge_list_allpoints(unclass(lines_sf[[geom_column]][[x]])))))
    }
  } else {
    forward <- direction_lookup[[2]][which(direction_lookup[[1]] == "forward" | direction_lookup[[1]] == "both")]
    id_forward <- which(lines_sf[[direction_column]] %in% forward)

    opposite <- direction_lookup[[2]][which(direction_lookup[[1]] == "opposite" | direction_lookup[[1]] == "both")]
    id_opposite <- which(lines_sf[[direction_column]] %in% opposite)
    edgelist <- rbind(do.call(rbind, lapply(id_forward,
                                            function(x) cbind(x, edge_list_allpoints(unclass(lines_sf[[geom_column]][[x]]))))),
                      do.call(rbind, lapply(id_opposite,
                                            function(x) cbind(x, edge_list_allpoints_back(unclass(lines_sf[[geom_column]][[x]]))))))
  }

  ##### 4. Build graph ###################################################################################################

  if (is.null(direction_column)){
    lines_graph <- graph.edgelist(cbind(paste(edgelist[, 2], edgelist[, 3]), paste(edgelist[, 4], edgelist[, 5])), directed = F)
  } else {
    lines_graph <- graph.edgelist(cbind(paste(edgelist[, 2], edgelist[, 3]), paste(edgelist[, 4], edgelist[, 5])), directed = T)
  }
  E(lines_graph)$id <- edgelist[,1]
  if (weighted_graph){
    edge_length <- sqrt((edgelist[, 2] - edgelist[, 4]) ^ 2 + (edgelist[, 3] - edgelist[, 5]) ^ 2) / 1000
    if (!is.null(speed_limit_column)){
      edge_length <- ifelse(edge_length < 0.00001, 0.00001, edge_length)
      E(lines_graph)$weight <- 60 * edge_length / lines_sf[[speed_limit_column]][edgelist[,1]]
    } else {
      E(lines_graph)$weight <- edge_length
    }
  }

  # set area id as graph attribute
  if (!is.null(area_id)){
    E(lines_graph)$area_id <- lines_sf[[area_id]][edgelist[, 1]]
  }

  # V(lines_graph)$name <- 1:length(V(lines_graph))

  attr(lines_graph, "proj4string") <- st_crs(lines_sf)$proj4string

  lines_graph
}

#########################################################################################################################
#                                      Get connected parts of the road network                                          #
#########################################################################################################################

is_connected <- function(lines_sf, geom_column, allpoints = T, area_id = NULL, cores_nr = 1){

  ##### 1. Functions ####################################################################################################

  connected_edges <- function(G){
    graph_parts <- decompose.graph(G, min.vertices = 2)
    if (length(graph_parts) > 1){
      # Find road part with the highest number of vertices, extract id instead of name
      edges_id <- unique(E(graph_parts[[which.max(sapply(1:length(graph_parts), function(x) length(V(graph_parts[[x]]))))]])$id)
      return(edges_id)
    }
    return(unique(E(G)$id))
  }

  ##### 2. Check inputs #################################################################################################

  .check_is_connected(lines_sf, geom_column, allpoints, area_id)

  ##### 3. Main Function ################################################################################################

  if (!is.null(area_id)){
    lines_graph <- lines_to_graph(lines_sf = lines_sf, geom_column = geom_column, allpoints = allpoints, area_id = area_id)
    edges_id <- unlist(mclapply(unique(lines_sf[[area_id]]),
                                       function(x) connected_edges(subgraph.edges(lines_graph, which(E(lines_graph)$area_id == x))),
                                       mc.cores = cores_nr))
  } else {
    lines_graph <- lines_to_graph(lines_sf = lines_sf, geom_column = geom_column, allpoints = allpoints)
    edges_id <- connected_edges(lines_graph)
  }

  connected <- 1:nrow(lines_sf) %in% edges_id

  connected

}

#########################################################################################################################
#                                                Shortest Route Cost                                                    #
#########################################################################################################################

shortest_route_cost <- function(origins_sf, destinations_sf, lines_graph, geom_column, id_column, join_by = NULL, lookup_table = NULL, cores_nr = 1){

  ##### 1. Function #####################################################################################################

  calc_cost <- function(origins_id, destinations_id){

    o_node_ids <- origin_points[.(unique(origins_id)), .(get(id_column), origins_node_id), on = id_column, allow.cartesian = T]
    setnames(o_node_ids, 1, id_column)
    d_node_ids <- destination_points[.(unique(destinations_id)), .(get(id_column), destinations_node_id), on = id_column, allow.cartesian = T]
    setnames(d_node_ids, 1, id_column)

    o_unique_node_ids <- unique(o_node_ids$origins_node_id)
    d_unique_node_ids <- unique(d_node_ids$destinations_node_id)

    path_DT <- rbindlist(mclapply(o_unique_node_ids, function(o_id) list(rep(o_id, length(d_unique_node_ids)),
                                                                         d_unique_node_ids,
                                                                         as.numeric(shortest.paths(lines_graph, v = o_id, to = d_unique_node_ids))),
                                  mc.cores = cores_nr))
    setnames(path_DT, names(path_DT), c("origins_node_id", "destinations_node_id", "cost"))
    path_DT <- path_DT[o_node_ids, on = "origins_node_id", allow.cartesian = T]
    path_DT <- path_DT[d_node_ids, on = "destinations_node_id", allow.cartesian = T]
    setkeyv(path_DT, c(id_column, paste0("i.", id_column)))
    path_DT <- path_DT[, min(cost), by=c(id_column, paste0("i.", id_column))]

    path_DT$V1
  }

  ##### 2. Check inputs #################################################################################################

  .check_shortest_route(origins_sf, destinations_sf, geom_column, id_column, lines_graph, lookup_table, join_by)

  if (nrow(origins_sf) > nrow(destinations_sf) & !is_directed(lines_graph) & is.null(lookup_table)){
    origin_points <- destinations_sf
    destination_points <- origins_sf
  } else {
    origin_points <- origins_sf
    destination_points <- destinations_sf
  }

  ##### 3. Map origins and destinations to road network #################################################################

  line_vertices <- do.call(cbind, tstrsplit(V(lines_graph)$name, " "))
  storage.mode(line_vertices) <- "numeric"
  # Map origin and destination nodes to closest nodes
  setDT(origin_points)
  setDT(destination_points)
  origin_points[, origins_node_id := get.knnx(line_vertices, do.call(rbind, unclass(origin_points[[geom_column]])), 1)$nn.index[,1]]
  destination_points[, destinations_node_id := get.knnx(line_vertices, do.call(rbind, unclass(destination_points[[geom_column]])), 1)$nn.index[,1]]

  V(lines_graph)$name <- seq_along(V(lines_graph))

  ##### 4. Calculate shortest route cost ################################################################################

  setkeyv(origin_points, id_column)
  setkeyv(destination_points, id_column)

  if (!is.null(lookup_table)){
    out_DT <- as.data.table(lookup_table)
  } else  if (!is.null(join_by)){
    out_DT <- origin_points[, unique(id), keyby = join_by][destination_points[, unique(id), keyby = join_by], on = join_by, allow.cartesian = T]
  } else {
    unique_origins <- unique(origin_points[[id_column]])
    unique_destinations <- unique(destination_points[[id_column]])
    out_DT <- data.table(origins_id = rep(unique_origins, length(unique_destinations)),
                         destinations_id = do.call(rbind, lapply(unique_destinations,
                                                                 function(x) cbind(rep(x, length(unique_origins))))))
  }

  setnames(out_DT, 1:2, c("origins_id", "destinations_id"))
  setkeyv(out_DT, c("origins_id", "destinations_id"))
  out_DT[, cost := calc_cost(origins_id, destinations_id), by = origins_id]

  if (nrow(origins_sf) > nrow(destinations_sf) & !is_directed(lines_graph) & is.null(lookup_table)){
    setnames(out_DT, c("origins_id", "destinations_id"), c("destinations_id", "origins_id"))
  }

  out_DT

}


card <- fread('card.csv',
              header = T,
              stringsAsFactors = F,
              data.table = F,
              encoding = 'UTF-8')

## 한글 없애기 ##
data <- card %>% filter(! (selng_cascnt %in% grep('[ㄱ-힣]',unique(card$selng_cascnt), value = T)),
                        ! (salamt %in% grep('[ㄱ-힣]',unique(card$salamt), value = T))) %>%
  mutate(selng_cascnt = as.numeric(selng_cascnt),
         salamt = as.numeric(salamt)) %>%
  select(- c(adstrd_code, mrhst_induty_cl_code))

rm(list = c('card'))

data$receipt_dttm=data$receipt_dttm %>% as.character() %>% as.Date('%Y%m%d')

## 음수 값 확인 - 양수만 넣기##
data$selng_cascnt %>% summary()
data$salamt %>% summary()

data = data %>% filter(selng_cascnt > 0, salamt > 0) %>%
  mutate(receipt_dttm = ymd(receipt_dttm),
         week = week(receipt_dttm))

data %>% glimpse()

#코로나 시기를 새로운 period변수로 나타내 줍니다.
index1 = which(data$receipt_dttm == '2020-02-22') %>% max() #기
index2 = which(data$receipt_dttm == '2020-03-08') %>% max() #승
index3 = which(data$receipt_dttm == '2020-05-06') %>% max() #전-1
index4 = nrow(data) #전-2

data_period = data
data_period$period = c(rep(1, index1),
                       rep(2, index2 - index1),
                       rep(3, index3 - index2),
                       rep(4, index4 - index3))

##이상치 및 결측치 처리##

data_period %>% is.na() %>% colSums()

mean_amount=data_period %>%
  group_by(mrhst_induty_cl_nm) %>%
  summarise(N_amount=mean(selng_cascnt)) %>%
  arrange(N_amount)

mean_amount %>%
  ggplot(aes(x=1, y=N_amount))+
  geom_violin( color = "#1E3269",size=0.3)+theme_bw() +theme(plot.margin = margin(60,60,60,60))

categories_new=mean_amount %>%
  filter(N_amount>=quantile(mean_amount$N_amount)[2]) %>%
  arrange(desc(N_amount)) %>% select(mrhst_induty_cl_nm)%>%
  ungroup()

categories_new <- as.data.frame(categories_new)

data_period <- data_period %>%
  filter(mrhst_induty_cl_nm%in%
           as.matrix(categories_new,nrow = 1))