R/mapGGChr.R

In idiogramFISH: Shiny App. Idiograms with Marks and Karyotype Indices

#' @name mapGGChr
#' @title FUNCTIONS mapGGChr and mapGGChrMark (for ggplot)
#' @aliases mapGGChrMark
#' @description Currently works for holocentrics when only one OTU. See vignette.
#' @description mapGGChr: reads a data.frame and produces coordinates for ggplot of chr.
#' @description mapGGChrMark: reads data.frames and produces data.frames for ggplot of chr. and marks
#'
#' @param dfChrSize character, name of data.frame with columns: chrSize
#' @param chrSpacing numeric, \code{1 - chrSpacing} will be the width of chr.
#' @param dfMarkPos (\code{mapGGChrMark}) name of data.frame of marks
#' @param squareness numeric, squareness
#' @param n numeric, vertices number for rounded portions
#'
#' @keywords data.frame size arm
#'
#' @return list
#' @rdname mapGGChr
#' @importFrom tidyr pivot_longer
#' @export
#'
mapGGChr <- function(dfChrSize, chrSpacing = 0.5, squareness = 4, n = 50) {
  pts <- seq(-pi / 2, pi * 1.5, length.out = n * 4)
  ptsl <- split(pts, sort(rep(1:4, each = length(pts) / 4, len = length(pts))))

  starts_with <- NULL

  if (chrSpacing > 0.95) {
    message(crayon::green("Use < 0.95 in chrSpacing"))
    chrSpacing <- 0.95
  }

  chrWidth <- 1 - chrSpacing

  chromosome_ns <- nrow(dfChrSize)
  chromRepVector <- rep(1, chromosome_ns)

  croytop <- list()

  for (i in seq_along(chromRepVector)) {
    croytop[i] <- list(c(
      ((dfChrSize[, "chrSize"])[i]),
      rep(0, 2),
      ((dfChrSize[, "chrSize"])[i])
    ))
  }

  xm <- matrix(rep(NA, length(chromRepVector) * 4), ncol = 4, nrow = length(chromRepVector))

  for (i in seq_along(chromRepVector)) {
    xm[i, ] <- c(
      rep(((chrSpacing * i + (i * chrWidth)) + chrWidth), 2),
      rep(((chrSpacing * i + (i * chrWidth))), 2)
    ) - chrWidth / 2
  }

  x <- base::split(xm, row(xm))

  ym <- t(sapply(croytop, function(x) {
    length(x)
    return(x)
  }))

  y <- base::split(ym, row(ym))

  xbind <- as.data.frame(do.call(rbind, x))

  xbind$Chr <- seq_along(xbind$V1)
  xDat <- tidyr::pivot_longer(xbind, names_to = "variable.x", values_to = "x", cols = starts_with("V"))

  ybind <- as.data.frame(do.call(rbind, croytop))
  ybind$id.y <- seq_along(ybind$V1)
  yDat <- tidyr::pivot_longer(ybind, names_to = "variable.y", values_to = "y", cols = starts_with("V"))

  dataChr <- cbind(xDat, yDat)
  dataChr <- dataChr[, c("Chr", "x", "y")]

  mapChrL <- list()
  mapChrL$dataChr <- dataChr
  mapChrL$xm <- xm
  mapChrL$ym <- ym
  mapChrL$chrWidth <- chrWidth

  if (squareness < 20) {
    r2 <- chrWidth / (squareness * 2)

    yfactor <- max(dfChrSize$chrSize) / chromosome_ns

    xyCoords <- makeRoundCoordXY(r2, yfactor, x, y, 1, length(y), n, ptsl)

    xbind <- as.data.frame(do.call(rbind, xyCoords$roundedX))

    xbind$Chr <- seq_along(xbind$V1)

    ybind <- as.data.frame(do.call(rbind, xyCoords$roundedY))

    ybind$id.y <- seq_along(ybind$V1)

    xDat <- tidyr::pivot_longer(xbind, names_to = "variable.x", values_to = "x", cols = starts_with("V"))

    yDat <- tidyr::pivot_longer(ybind, names_to = "variable.y", values_to = "y", cols = starts_with("V"))

    dataChr <- cbind(xDat, yDat)

    dataChr <- dataChr[, c("Chr", "x", "y")]

    mapChrL$dataChr <- dataChr
    mapChrL$rounded <- TRUE

    return(mapChrL)
  } else {
    return(mapChrL)
  }
}
#'
#' @rdname mapGGChr
#' @return list
#' @export
#'

mapGGChrMark <- function(dfChrSize, dfMarkPos, chrSpacing = 0.5, squareness = 4, n = 50) {
  pts <- seq(-pi / 2, pi * 1.5, length.out = n * 4)
  ptsl <- split(pts, sort(rep(1:4, each = length(pts) / 4, len = length(pts))))

  starts_with <- NULL

  mapChrL <- mapGGChr(dfChrSize, chrSpacing, squareness, n)

  if (requireNamespace("tidyr") == FALSE) {
    message(crayon::red("You need to install tidyr"))
    return(NULL)
  } else {
    requireNamespace("tidyr")
  }

  yMark1 <- xMark1 <- xMark2 <- NULL

  markNames <- character()

  for (m in seq_len(nrow(dfMarkPos))) {
    rowIndex <- dfMarkPos[, "chrName"][m]

    markName <- dfMarkPos[, "markName"][m]

    chrStart <- mapChrL$ym[rowIndex, 2]

    yinf <- chrStart + dfMarkPos[m, "markPos"]

    ysup <- chrStart + sum(dfMarkPos[m, "markPos"], dfMarkPos[m, "markSize"], na.rm = TRUE)

    yMark1[[m]] <- c(ysup, yinf, yinf, ysup)

    xMark1[[m]] <- mapChrL$xm[dfMarkPos[, "chrName"][m], ]

    xMark2[[m]] <- c(xMark1[[m]], markName)

    markNames <- c(markNames, markName)
  }

  xMarkSqDF <- as.data.frame(do.call(rbind, xMark2))

  colnames(xMarkSqDF)[5] <- "markName"

  xMarkSqDF$id <- seq_along(xMarkSqDF$V1)

  xDatMark <- tidyr::pivot_longer(xMarkSqDF, names_to = "variable", values_to = "x", cols = starts_with("V"))

  xDatMark$x <- as.numeric(xDatMark$x)

  yMark1DF <- as.data.frame(do.call(rbind, yMark1))
  yMark1DF$id.y <- seq_along(yMark1DF$V1)
  yDatMark <- tidyr::pivot_longer(yMark1DF, names_to = "variable.y", values_to = "y", cols = starts_with("V"))
  dataMark <- cbind(xDatMark, yDatMark)
  dataMark <- dataMark[, c("id", "markName", "x", "y")]

  mapChrL$dataMark <- dataMark

  if (squareness < 20) {
    chromosome_ns <- nrow(dfChrSize)

    r2 <- mapChrL$chrWidth / (squareness * 2)

    yfactor <- max(dfChrSize$chrSize) / chromosome_ns

    xyCoords <- makeRoundCoordXY(r2, yfactor, xMark1, yMark1, 1, length(yMark1), n, ptsl)

    xMarkSqDF <- as.data.frame(do.call(rbind, xyCoords$roundedX))

    xMarkSqDF$markName <- markNames

    xMarkSqDF$id <- seq_along(xMarkSqDF$V1)

    xDatMark <- tidyr::pivot_longer(xMarkSqDF, names_to = "variable", values_to = "x", cols = starts_with("V"))

    yMark1DF <- as.data.frame(do.call(rbind, xyCoords$roundedY))

    yMark1DF$id.y <- seq_along(yMark1DF$V1)
    yDatMark <- tidyr::pivot_longer(yMark1DF, names_to = "variable.y", values_to = "y", cols = starts_with("V"))
    dataMark <- cbind(xDatMark, yDatMark)
    dataMark <- dataMark[, c("id", "markName", "x", "y")]
    mapChrL$dataMark <- dataMark
    return(mapChrL)
  } else {
    return(mapChrL)
  }
}