R/plotting-functions.R

In DillonHammill/cytoSuite: Compensation, Gating & Visualisation Toolkit for Analysis of Flow Cytometry Data

#' Boxed Labels - Modified plotrix
#'
#' @param x,y  x and y position of the centers of the labels. \code{x} can be a
#'   xy.coords list.
#' @param bg The fill color of the rectangles on which the labels are displayed
#'   (see Details).
#' @param labels Text strings.
#' @param border Whether to draw borders around the rectangles.
#' @param xpad,ypad The proportion of the rectangles to the extent of the text
#'   within.
#' @param srt Rotation of the labels. if 90 or 270 degrees, the box will be
#'   rotated 90 degrees.
#' @param cex Character expansion. See \code{text}.
#' @param adj left/right adjustment. If this is set outside the function, the
#'   box will not be aligned properly.
#' @param xlog Whether the X axis is a log axis.
#' @param ylog Whether the y axis is a log axis.
#' @param alpha.bg Numeric [0,1] controlling the transparency of the background,
#'   set to 0.5 by default.
#' @param ... additional arguments passed to \code{text}.
#'
#' @author Dillon Hammill (Dillon.Hammill@anu.edu.au)
#'
#' @importFrom graphics par strwidth strheight rect text
#' @importFrom grDevices col2rgb adjustcolor
#' @importFrom utils modifyList
#'
#' @noRd
.boxed.labels <- function(x,
                          y = NA,
                          labels,
                          bg = ifelse(match(par("bg"), "transparent", 0),
                            "white", par("bg")
                          ),
                          border = NA,
                          xpad = 1.2,
                          ypad = 1.2,
                          srt = 0,
                          cex = 1,
                          adj = 0.5,
                          xlog = FALSE,
                          ylog = FALSE,
                          alpha.bg = 0.5, ...) {
  border <- NA
  oldpars <- par(c("cex", "xpd"))
  par(cex = cex, xpd = TRUE)
  if(all(is.na(y))){
    y <- x
  }
  box.adj <- adj + (xpad - 1) * cex * (0.5 - adj)
  if (srt == 90 || srt == 270) {
    bheights <- strwidth(labels)
    theights <- bheights * (1 - box.adj)
    bheights <- bheights * box.adj
    lwidths <- rwidths <- strheight(labels) * 0.5
  }
  else {
    lwidths <- strwidth(labels)
    rwidths <- lwidths * (1 - box.adj)
    lwidths <- lwidths * box.adj
    bheights <- theights <- strheight(labels) * 0.5
  }
  args <- list(
    x = x, y = y, labels = labels, srt = srt, adj = adj,
    col = ifelse(colSums(col2rgb(bg) * c(1, 1.4, 0.6)) <
      350, "white", "black")
  )
  args <- modifyList(args, list(...))
  if (xlog) {
    xpad <- xpad * 2
    xr <- exp(log(x) - lwidths * xpad)
    xl <- exp(log(x) + lwidths * xpad)
  }
  else {
    xr <- x - lwidths * xpad
    xl <- x + lwidths * xpad
  }
  if (ylog) {
    ypad <- ypad * 2
    yb <- exp(log(y) - bheights * ypad)
    yt <- exp(log(y) + theights * ypad)
  }
  else {
    yb <- y - bheights * ypad
    yt <- y + theights * ypad
  }
  rect(xr,
    yb,
    xl,
    yt,
    col = adjustcolor(col = bg, alpha.f = alpha.bg),
    border = border
  )
  do.call(text, args)
  par(cex = oldpars)
}

#' Get Appropriate Axes Labels for Transformed Channels - flowWorkspace
#'
#' @param x object of class \code{flowFrame} or \code{GatingHierarchy}.
#' @param ... additional arguments.
#'
#' @return list containing axis labels and breaks.
#'
#' @noRd
setGeneric(
  name = ".cyto_axes_text",
  def = function(x, ...) {
    standardGeneric(".cyto_axes_text")
  }
)

#' Get Appropriate Axes Labels for Transformed Channels - flowFrame Method
#'
#' @param x an object of class \code{flowFrame}.
#' @param channels name(s) of the channel(s) used to construct the plot.
#' @param trans object of class \code{"transformList"} or
#'   \code{"transformerList"} generated by estimateLogicle containing the
#'   transformations applied to the flowFrame.
#'
#' @return list containing axis labels and breaks.
#'
#' @importFrom flowCore transformList inverseLogicleTransform
#'
#' @noRd
setMethod(.cyto_axes_text,
  signature = "flowFrame",
  definition = function(x,
                          channels,
                          trans = NULL) {

    # Return NULL if trans is missing
    if (is.null(trans)) {
      return(NULL)
    } else {

      # trans of incorrect class
      if (!any(inherits(trans, "transformList") |
        inherits(trans, "transformerList"))) {
        stop("Supply a valid transformList/transformerList object to 'trans'.")
      }
    }

    # Convert transformerList to transformList
    if (inherits(trans, "transformerList")) {
      trns <- lapply(trans, `[[`, "transform")
      trans <- transformList(names(trns), trns)
    }

    # Assign x to fr
    fr <- x

    # Get list of axis breaks and labels
    axs <- lapply(channels, function(channel) {

      # Channel not included in trans
      if (!channel %in% names(trans@transforms)) {
        return(NULL)
      }

      # Range of values
      r <- as.vector(range(fr)[, channel])

      # Transformation Functions & Breaks
      trans.func <- trans@transforms[[channel]]@f
      inv.func <- inverseLogicleTransform(trans)@transforms[[channel]]@f
      raw <- inv.func(r)
      brks <- .cyto_axes_breaks(raw, n = 5, equal.space = FALSE)


      pos <- signif(trans.func(brks))
      label <- .cyto_axes_inverse(brks, drop.1 = TRUE)

      res <- list(label = label, at = pos)

      return(res)
    })
    names(axs) <- channels

    return(axs)
  }
)

#' Get Appropriate Axes Labels for Transformed Channels - GatingHierarchy Method
#'
#' @param x \code{GatingHiearchy}.
#' @param channels \code{character} name(s) of the channel(S) used to construct
#'   the plot.
#'
#' @return when there is transformation function associated with the given
#'   channel, it returns a list of that contains positions and labels to draw on
#'   the axis otherwise returns NULL.
#'
#' @importFrom flowWorkspace getTransformations getData
#'
#' @noRd
setMethod(.cyto_axes_text,
  signature = "GatingHierarchy",
  definition = function(x, channels) {

    # Assign x to gh
    gh <- x

    # Get list of axis breaks and labels
    axs <- lapply(channels, function(channel) {
      res <- gh@axis[[sampleNames(gh)]][[channel]]
      if (is.null(res)) {
        # try to grab trans and do inverse trans for axis label on the fly
        trans <- getTransformations(gh, channel, only.function = FALSE)
        if (is.null(trans)) {
          res <- NULL
        } else {
          inv.func <- trans[["inverse"]]
          trans.func <- trans[["transform"]]
          brk.func <- trans[["breaks"]]

          fr <- getData(gh, use.exprs = FALSE)
          r <- as.vector(range(fr)[, channel]) # range
          raw <- inv.func(r)
          brks <- brk.func(raw)
          pos <- signif(trans.func(brks))
          # format it
          label <- trans[["format"]](brks)

          res <- list(label = label, at = pos)
        }
      } else {
        # use the stored axis label if exists
        res$label <- .cyto_axes_inverse(as.numeric(res$label), drop.1 = TRUE)
      }

      return(res)
    })
    names(axs) <- channels

    return(axs)
  }
)

#' Generate the breaks that makes sense for flow data visualization -
#' flowWorkspace
#'
#' @param n desired number of breaks (the actual number will be different
#'   depending on the data range)
#' @param x the raw data values
#' @param equal.space whether breaks at equal-spaced intervals
#' @param trans.fun the transform function (only needed when equal.space is
#'   TRUE)
#' @param inverse.fun the inverse function (only needed when equal.space is
#'   TRUE)
#'
#' @return either 10^n intervals or equal-spaced(after transformed) intervals in
#'   raw scale.
#'
#' @noRd
.cyto_axes_breaks <- function(x,
                              n = 6,
                              equal.space = FALSE,
                              trans.fun, inverse.fun) {
  rng.raw <- range(x, na.rm = TRUE)
  if (equal.space) {
    rng <- trans.fun(rng.raw)
    min <- floor(rng[1])
    max <- ceiling(rng[2])
    if (max == min) {
      return(inverse.fun(min))
    }
    by <- (max - min) / (n - 1)

    myBreaks <- inverse.fun(seq(min, max, by = by))
  } else {
    # log10 (e.g. 0, 10, 1000, ...)
    base10raw <- unlist(lapply(2:n, function(e) 10^e))
    base10raw <- c(0, base10raw)
    myBreaks <- base10raw[base10raw > rng.raw[1] & base10raw < rng.raw[2]]
  }

  myBreaks
}

# copy from sfsmisc/flowWorkspace package
# modified to handle NA values
.cyto_axes_inverse <- function(x, drop.1 = FALSE, digits.fuzz = 7) {
  eT <- floor(log10(abs(x)) + 10^-digits.fuzz)
  mT <- signif(x / 10^eT, digits.fuzz)
  ss <- vector("list", length(x))

  for (i in seq(along = x)) ss[[i]] <- if (is.na(x[i])) {
      quote(NA)
    } else if (x[i] == 0) {
      quote(0)
    } else if (drop.1 && mT[i] == 1) {
      substitute(10^E, list(E = eT[i]))
    } else if (drop.1 && mT[i] == -1) {
      substitute(-10^E, list(E = eT[i]))
    } else {
      substitute(A %*% 10^E, list(A = mT[i], E = eT[i]))
    }

  do.call("expression", ss)
}

#' Get Axes Limits for cyto_plot
#'
#' @param x object of class \code{\link[flowCore:flowFrame-class]{flowFrame}}.
#' @param parent name of the parental node to extract from GatingHierarchy or
#'   GatingSet.
#' @param channels name of the channels or markers to be used to construct the
#'   plot.
#' @param overlay a \code{flowFrame}, \code{flowSet}, \code{list of flowFrames},
#'   \code{list of flowSets} or \code{list of flowFrame lists} containing
#'   populations to be overlayed onto the plot(s). Data for overlays will be
#'   merged with \code{x} prior to axis limit calculation to ensure that the
#'   axes limits are set based on all the data to be included in the plot.
#' @param limits indicates whether the limits of the "data" or limits of the
#'   "machine" should be returned. This argument will only influence the upper
#'   limit. The lower limit will always be set to 0, unless the data contains
#'   values below this limit. In such cases the lower limit of the data will be
#'   used instead. This argument is set to "machine" by default.
#'
#' @importFrom flowCore exprs flowSet parameters
#' @importFrom flowWorkspace pData getData
#'
#' @author Dillon Hammill, \email{Dillon.Hammill@anu.edu.au}
#'
#' @noRd
.cyto_plot_limits <- function(x,
                              parent = "root",
                              channels,
                              overlay = NULL,
                              limits = "machine") {

  # Missing channels
  if (missing(channels)) {
    stop("Supply the names of the channel(s) to calculate axes limits.")
  } else {
    channels <- cyto_channel_check(
      x = x,
      channels = channels,
      plot = FALSE
    )
  }

  # Incorrect limits argument
  if (!limits %in% c("data", "machine")) {
    stop("Limits argument should be either 'data' or 'machine'.")
  }

  # x is a flowFrame
  if (inherits(x, "flowFrame")) {
    fr <- x

    # x is a flowSet
  } else if (inherits(x, "flowSet")) {
    fr <- as(x, "flowFrame")

    if ("Original" %in% BiocGenerics::colnames(fr)) {
      fr <- suppressWarnings(
        fr[, -match("Original", BiocGenerics::colnames(fr))]
      )
    }

    # x is a GatingHierarchy
  } else if (inherits(x, "GatingHierarchy")) {
    fr <- getData(x, parent)

    # x is a GatingSet
  } else if (inherits(x, "GatingSet")) {
    fr <- as(getData(x, parent), "flowFrame")

    if ("Original" %in% BiocGenerics::colnames(fr)) {
      fr <- suppressWarnings(
        fr[, -match("Original", BiocGenerics::colnames(fr))]
      )
    }
  }

  # Extract summary stats
  sm <- pData(parameters(fr))

  lms <- lapply(channels, function(channel) {

    # Time parameter always uses data limits
    if(channel == "Time"){
      limits <- "data"
    }
    
    # Extract machine limits
    mlms <- vector()
    mlms[1] <- sm[sm$name == channel, "minRange"]
    mlms[2] <- sm[sm$name == channel, "maxRange"]

    if (mlms[1] > 0) {
      mlms <- c(0, mlms[2])
    }

    # Add 10% buffer on lower limit if transformed
    if (sm[sm$name == channel, "maxRange"] > 6) {
      if (mlms[1] > 0) {
        rng <- 0.1 * (mlms[2] - mlms[1])
        mlms <- c(mlms[1] - rng, mlms[2])
      }
    } else {
      rng <- 0.1 * (mlms[2] - mlms[1])
      mlms <- c(mlms[1] - rng, mlms[2])
    }

    # Machine limits
    if (limits == "machine") {
      lms <- mlms

      # Data limits
    } else if (limits == "data") {

      # No overlay
      if (is.null(overlay)) {

        # overlay
      } else if (!is.null(overlay)) {

        # Get merged flowFrame to calculate axes limits
        # flowFrame
        if (class(overlay) == "flowFrame") {
          fr <- as(flowSet(list(fr, overlay)), "flowFrame")

          # flowSet
        } else if (class(overlay) == "flowSet") {
          ov <- as(overlay, "flowFrame")

          if (is.na(match("Original", BiocGenerics::colnames(ov))) == FALSE) {
            ov <- ov[, -match("Original", BiocGenerics::colnames(ov))]
          }
          fr <- as(flowSet(list(fr, ov)), "flowFrame")

          # list
        } else if (class(overlay) == "list") {

          # list of flowFrames
          if (all(unlist(lapply(overlay, function(x) {
            class(x)
          })) == "flowFrame")) {
            fr <- as(flowSet(c(list(fr), overlay)), "flowFrame")
          }

          # list of flowSets
        } else if (all(unlist(lapply(overlay, function(x) {
          class(x)
        })) == "flowFrame")) {
          ov <- lapply(overlay, function(x) {
            as(x, "flowFrame")
          })

          if (!is.na(match("Original", BiocGenerics::colnames(ov[[1]])))) {
            ov <- lapply(ov, function(fr) {
              fr <- fr[, -match("Original", BiocGenerics::colnames(fr))]

              return(fr)
            })
          }
          fr <- as(flowSet(c(list(fr), ov)), "flowFrame")

          # list of lists
        } else if (all(unlist(lapply(overlay, function(x) {
          class(x)
        })) == "list")) {

          # flowFrame lists
          if (all(unlist(lapply(overlay, function(x) {
            lapply(x, class)
          })) == "flowFrame")) {
            fr.lst <- lapply(overlay, function(x) {
              as(flowSet(x), "flowFrame")
            })

            if (!is.na(
              match("Original", BiocGenerics::colnames(fr.lst[[1]]))
            )) {
              ov <- lapply(fr.lst, function(fr) {
                fr <- fr[, -match("Original", BiocGenerics::colnames(fr))]

                return(fr)
              })
            }
            fr <- as(flowSet(c(list(fr), ov)), "flowFrame")
          }

          # flowSet lists
          if (all(unlist(lapply(overlay, function(x) {
            lapply(x, class)
          })) == "flowSet")) {
            fr.lst <- lapply(overlay, function(x) {
              as(x, "flowFrame")
            })

            if (!is.na(
              match("Original", BiocGenerics::colnames(fr.lst[[1]]))
            )) {
              ov <- lapply(fr.lst, function(fr) {
                fr <- fr[, -match("Original", BiocGenerics::colnames(fr))]

                return(fr)
              })

              fr <- as(flowSet(c(list(fr), ov)), "flowFrame")
            }
          }
        }
      }

      # Limits from flowFrame
      lms <- range(exprs(fr)[, channel])
      lms <- c(mlms[1], lms[2] + (0.1 * (lms[2] - mlms[1])))
      
      # Limits for Time parameter
      if(channel == "Time"){
        lms <- c(0, range(exprs(fr)[, channel])[2])
      }
    }

    return(lms)
  })

  names(lms) <- channels

  return(lms)
}

#' Merge overlay for merged data
#'
#' @param x flowSet data to be merged.
#' @param overlay object generated by checkOverlay flowSet method (list of
#'   flowFrame lists).
#' @param group_by pData variables of x used to merge the data. To merge all
#'   samples set group_by to "all".
#' @param display numeric [0,1] to control the percentage of events to be
#'   plotted. Specifying a value for \code{display} can substantial improve
#'   plotting speed for less powerful machines.
#'
#' @importFrom flowCore sampleFilter Subset
#' @importFrom flowWorkspace sampleNames
#'
#' @noRd
.cyto_overlay_merge <- function(x,
                                overlay,
                                group_by = "all",
                                display = NULL) {

  # x is flowSet prior to merging
  if (!class(x)[1] %in% c("flowSet", "GatingSet") |
    length(overlay) != length(x)) {
    stop("Supply the original data prior to merging.")
  }

  # Extract pData
  pd <- pData(x)

  # Sort pd by group_by column names
  if (group_by[1] != "all") {
    pd <- pd[do.call("order", pd[group_by]), ]
  }

  # Find new indicies
  ind <- match(sampleNames(x), pd$name)
  ind <- ind[!is.na(ind)]

  # Reorder overlays based on group_by levels
  overlay <- overlay[ind]

  # List of group indicies - ind
  if (length(group_by) == 1 & group_by[1] == "all") {
    grps <- list(seq_len(length(x)))
  } else {

    # Groups
    if (length(group_by) == 1) {
      pd$mrg <- pd[, group_by]
    } else {
      pd$mrg <- do.call("paste", pd[, group_by])
    }

    # Get a list of indices per group
    grps <- lapply(unique(pd$mrg), function(x) {
      which(pd$mrg == x)
    })
  }

  # Subset overlay, merge & display
  overlay <- lapply(grps, function(x) {
    ov <- overlay[x]

    lapply(seq_len(length(ov[[1]])), function(x) {
      fr.lst <- lapply(ov, `[[`, x)

      # if same flowFrame return first only
      if (length(unique(fr.lst)) == 1 |
        length(unique(unlist(lapply(fr.lst, function(x) {
          x@description$GUID
        })))) == 1) {
        fr <- fr.lst[[1]]
      } else {
        fs <- flowSet(fr.lst)

        fr <- as(fs, "flowFrame")

        if ("Original" %in% BiocGenerics::colnames(fr)) {
          fr <- suppressWarnings(
            fr[, -match("Original", BiocGenerics::colnames(fr))]
          )
        }
      }

      if (!is.null(display)) {
        fr <- Subset(fr, sampleFilter(size = display * BiocGenerics::nrow(fr)))
      }

      return(fr)
    })
  })

  return(overlay)
}

#' Merge samples by pData
#'
#' @param x flowSet or GatingSet object
#' @param parent name of the parent population to extract from GatingSet object.
#' @param group_by names of pData variables to use for merging. Set to "all" to
#'   merge all samples in the flowSet.
#' @param display numeric [0,1] to control the percentage of events to be
#'   plotted. Specifying a value for \code{display} can substantial improve
#'   plotting speed for less powerful machines.
#'
#' @return list containing merged flowFrames, named with group.
#'
#' @importFrom flowWorkspace pData getData
#' @importFrom flowCore sampleFilter Subset
#'
#' @noRd
.cyto_merge <- function(x,
                        parent = "root",
                        group_by = "all",
                        display = NULL) {

  # check x
  if (inherits(x, "flowFrame") | inherits(x, "GatingHierarchy")) {
    stop("x must be either a flowSet or a GtaingSet object.")
  }

  # check group_by
  if (all(!group_by %in% c("all", colnames(pData(x))))) {
    stop("group_by should be the name of pData variables or 'all'.")
  }

  # Extract pData information
  pd <- pData(x)

  # Sort pd by group_by colnames
  if (!is.null(group_by)) {
    if (group_by[1] != "all") {
      pd <- pd[do.call("order", pd[group_by]), ]
    }
  }

  # flowSet for merging
  if (inherits(x, "GatingSet")) {
    fs <- getData(x, parent)
  } else {
    fs <- x
  }

  # group_by all samples
  if (length(group_by) == 1 & group_by[1] == "all") {
    pd$group_by <- rep("all", length(x))

    fr <- as(fs, "flowFrame")

    if ("Original" %in% BiocGenerics::colnames(fr)) {
      fr <- suppressWarnings(
        fr[, -match("Original", BiocGenerics::colnames(fr))]
      )
    }

    if (!is.null(display)) {
      fr <- Subset(fr, sampleFilter(size = display * BiocGenerics::nrow(fr)))
    }

    fr.lst <- list(fr)

    # group_by by one variable
  } else if (length(group_by) == 1) {
    pd$group_by <- pd[, group_by]

    fr.lst <- lapply(unique(pd$group_by), function(x) {
      fr <- as(fs[pd$name[pd$group_by == x]], "flowFrame")

      if ("Original" %in% BiocGenerics::colnames(fr)) {
        fr <- suppressWarnings(
          fr[, -match("Original", BiocGenerics::colnames(fr))]
        )
      }

      if (!is.null(display)) {
        fr <- Subset(fr, sampleFilter(size = display * BiocGenerics::nrow(fr)))
      }

      return(fr)
    })

    # group_by by multiple variables
  } else {
    pd$group_by <- do.call("paste", pd[, group_by])

    fr.lst <- lapply(unique(pd$group_by), function(x) {
      fr <- as(fs[pd$name[pd$group_by == x]], "flowFrame")

      if ("Original" %in% BiocGenerics::colnames(fr)) {
        fr <- suppressWarnings(
          fr[, -match("Original", BiocGenerics::colnames(fr))]
        )
      }

      if (!is.null(display)) {
        fr <- Subset(fr, sampleFilter(size = display * BiocGenerics::nrow(fr)))
      }

      return(fr)
    })
  }
  names(fr.lst) <- unique(pd$group_by)

  return(fr.lst)
}

#' Set plot margins
#'
#' @param x flowFrame or flowSet object to be plotted (post merging).
#' @param overlay object return by checkOverlay.
#' @param legend logical indicating whether a legend should be included in the
#'   plot.
#' @param legend_text text to be used in the legend, used to calculate required
#'   space.
#' @param title if NULL remove excess space above plot.
#'
#' @noRd
.cyto_plot_margins <- function(x,
                               overlay = NULL,
                               legend = NULL,
                               legend_text = NULL,
                               title = NA) {

  # plot margins
  if (!is.null(overlay) & legend != FALSE) {
    mrgn <- 7 + max(nchar(legend_text)) * 0.32

    # Remove excess sapce above if no main
    if (is.na(title)) {
      par(mar = c(5, 5, 2, mrgn) + 0.1)
    } else {
      par(mar = c(5, 5, 4, mrgn) + 0.1)
    }
  } else {

    # Remove excess space above if no main
    if (is.na(title)) {
      par(mar = c(5, 5, 2, 2) + 0.1)
    } else {
      par(mar = c(5, 5, 4, 2) + 0.1)
    }
  }
}

#' Set plot layout
#'
#' @param x object to be plotted.
#' @param layout grid dimensions c(nr, nc), NULL or FALSE.
#' @param density_stack degree of offset.
#' @param denisity_layers number of layers per plot.
#'
#' @importFrom grDevices n2mfrow
#'
#' @noRd
.cyto_plot_layout <- function(x,
                              layout = NULL,
                              density_stack = 0,
                              density_layers = 1) {

  # Number of samples
  smp <- length(x)

  # Stacking
  if (density_stack != 0) {
    if (density_layers == smp) {
      smp <- ceiling(smp / smp)
    } else {
      smp <- ceiling(smp / density_layers)
    }
  }

  # Plot layout
  if (is.null(layout)) {
    if (smp > 1) {
      mfrw <- c(grDevices::n2mfrow(smp)[2], grDevices::n2mfrow(smp)[1])
    } else {
      mfrw <- c(1, 1)
    }
  } else if (!is.null(layout)) {
    if (layout[1] == FALSE) {

      # Do nothing
    } else {
      mfrw <- layout
    }
  }

  return(mfrw)
}

#' Gate 1D with overlays
#'
#' @param x flowFrame (base).
#' @param channel used in the plot.
#' @param overlay list of flowFrames to overlay.
#' @param gates gate object(s).
#' @param trans transform object used by cyto_plot_label to calculate
#'   statistics.
#' @param density_stack degree of stacking.
#' @param label_text text to use in label.
#' @param label_stat statistic to use in label.
#' @param gate_line_col gate(s) colour(s).
#' @param gate_line_width gate(s) line width(s).
#' @param gate_line_type gate(s) line type(s).
#' @param label_text_font font(s) for labels.
#' @param label_text_size text size(s) for labels.
#' @param label_text_col text colour(s) for labels.
#' @param label_box_x x co-ordinate(s) for label(s).
#' @param label_box_y y co-ordinates for label(s).
#' @param label_box_alpha transparency for label(s).
#'
#' @importFrom flowCore parameters
#'
#' @noRd
.cyto_overlay_gate <- function(x,
                               channel = NULL,
                               overlay = NULL,
                               gates = NULL,
                               trans = NULL,
                               density_stack = NULL,
                               label_text = NA,
                               label_stat = NULL,
                               gate_line_col = "red",
                               gate_line_width = 2.5,
                               gate_line_type = 1,
                               label_text_font = 2,
                               label_text_size = 0.8,
                               label_text_col = "black",
                               label_box_x = NA,
                               label_box_y = NA,
                               label_box_alpha = 0.6, ...) {

  # Changing label position not yet supported...

  # Check class of x
  if (!inherits(x, "flowFrame")) {
    stop("x should be a flowFrame object.")
  }

  # Samples
  smp <- length(overlay) + 1

  # checkChannel
  channel <- cyto_channel_check(
    x = x,
    channels = channel,
    plot = TRUE
  )

  # list of gates
  if (inherits(gates, "filters")) {

    # Convert to list of gates
    gates <- lapply(seq_len(length(gates)), function(gate) gates[[gate]])

    # Must be rectangleGates for 1D plots
    if (!all(unlist(lapply(gates, class)) == "rectangleGate")) {
      stop("Only rectangleGate gates are supported in 1-D plots.")
    }
  } else if (inherits(gates, "list")) {

    # Must be rectangleGates for 1D plots
    if (!all(unlist(lapply(gates, class)) == "rectangleGate")) {
      stop("Only rectangleGate gates are supported in 1-D plots.")
    }
  } else if (inherits(gates, "rectangleGate")) {
    gates <- list(gates)
  } else {
    stop("Supplied gate(s) should be of class filters, list or rectangleGate.")
  }

  # rectangleGates should be in 1D only
  if (any(lapply(gates, function(x) length(flowCore::parameters(x))) == 2)) {

    # Some gates are in 2D - construct 1D gate
    ind <- unname(which(lapply(gates, function(x) {
      length(flowCore::parameters(x))
    }) == 2))

    # Convert these gates to 1D gates
    gts <- lapply(ind, function(x) {

      # Extract gate for channel
      gates[[x]][channel]
    })
    gates[ind] <- gts
  }

  # Find center x co-ord for label position in each gate
  if (all(is.na(label_box_x))) {
    label_box_x <- unlist(lapply(gates, function(x) {
      (unname(x@min) + unname(x@max)) / 2
    }))
  }

  # Find y co-ord for each sample
  if (all(is.na(label_box_y))) {
    label_box_y <- unlist(lapply(seq(1, smp), function(x) {
      (0.5 * density_stack * 100) + ((x - 1) * density_stack * 100)
    }))
  }

  # Plot gates
  cyto_plot_gate(gates,
    channels = channel,
    gate_line_col = gate_line_col,
    gate_line_width = gate_line_width,
    gate_line_type = gate_line_type
  )

  # List of flowFrames for cyto_plot_label
  fr.lst <- c(list(x), overlay)

  # Plot labels
  lapply(seq_len(length(gates)), function(x) {
    mapply(
      function(y,
                     label_text,
                     label_stat,
                     label_text_font,
                     label_text_col,
                     label_text_size,
                     label_box_x,
                     label_box_y,
                     label_box_alpha) {
        suppressMessages(cyto_plot_label(
          x = fr.lst[[y]],
          channels = channel,
          gates = gates[[x]],
          trans = trans,
          text_x = label_box_x[x],
          text_y = label_box_y[x],
          text = label_text,
          stat = label_stat,
          text_font = label_text_font,
          text_col = label_text_col,
          text_size = label_text_size,
          box_alpha = label_box_alpha
        ))
      }, seq_len(length(fr.lst)),
      label_text,
      label_stat,
      label_text_font,
      label_text_col,
      label_text_size,
      label_box_x,
      label_box_y,
      label_box_alpha
    )
  })
}

#' Get kernel density for a list of flowFrames
#'
#' @param x list of flowFrames.
#' @param channel channel to calculate kernel density.
#' @param adjust smoothing parameter passed to \code{density()}.
#' @param modal logical indicating whether densities should be normalised to
#'   mode.
#' @param density_stack degree of density stacking.
#'
#' @importFrom flowCore exprs
#' @importFrom stats density
#'
#' @noRd
.cyto_density <- function(x,
                          channel,
                          adjust = 1.5,
                          modal = TRUE,
                          density_stack = 0) {

  # x object of incorrect class
  if (!all(unlist(lapply(x, class)) %in% "flowFrame")) {
    stop("x should be a list of flowFrame objects.")
  }

  # Number of overlays
  ovn <- length(x) - 1

  # Get vector of density_stack values
  ofst <- seq(0, ovn * density_stack * 100, density_stack * 100)

  # Get a list of kernel densities
  frs.dens <- mapply(function(fr, ofst) {

    # Extract data
    fr.exprs <- flowCore::exprs(fr)[, channel]

    # Calculate kernel density
    fr.dens <- density(fr.exprs, adjust = adjust)

    # Normalise to mode
    if (length(x) != 1) {
      fr.dens$y <- (fr.dens$y / max(fr.dens$y)) * 100
    } else if (length(x) == 1 & modal == TRUE) {
      fr.dens$y <- (fr.dens$y / max(fr.dens$y)) * 100
    }

    # Adjust values for stacking
    if (ofst != 0) {
      fr.dens$y <- fr.dens$y + ofst
    }

    return(fr.dens)
  }, x, ofst, SIMPLIFY = FALSE)

  return(frs.dens)
}