#' 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)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.