R/cyto_plot-internal-helpers.R

In DillonHammill/CytoExploreR: Interactive Analysis of Cytometry Data

## AXES TEXT -------------------------------------------------------------------

#' Get Appropriate Axes Labels for Transformed Channels - flowFrame Method
#'
#' @param x list of \code{flowFrames}.
#' @param channels name(s) of the channel(s) used to construct the plot.
#' @param axes_trans object of class \code{"transformerList"} generated by
#'   \code{cyto_transform_} containing the transformations applied to the
#'   flowFrame.
#' @param axes_range named list of axes limits for each each axis (i.e.
#'   list(xlim,ylim)).
#' @param axes_limits either "auto", "data" or "machine".
#'
#' @return list containing axis labels and breaks.
#'
#' @importFrom methods is
#'
#' @noRd
.cyto_plot_axes_text <- function(x,
                                 channels,
                                 axes_trans = NA,
                                 axes_range = list(NA, NA),
                                 axes_limits = "data") {

  # Return NA if axes_trans is missing
  if (.all_na(axes_trans)) {
    return(NA)
  } else {
    # axes_trans of incorrect class
    if (!is(axes_trans, "transformerList")) {
      stop("Supply a valid transformerList object to 'axes_trans'.")
    }
  }

  # Assign x to fr
  fr_list <- x

  # TICKS - 10^-5 -> 10^5
  tcks <- c(
    sort(LAPPLY(
      c(1, 10, 100, 1000, 10000, 100000, 1000000, 10000000),
      function(z) {
        -seq(90, 10, -10) * z
      }
    )),
    seq(-9, 9, 1),
    LAPPLY(
      c(1, 10, 100, 1000, 10000, 100000, 1000000, 10000000),
      function(z) {
        seq(10, 90, 10) * z
      }
    )
  )

  # LABELS - 10^-5 -> 10^5
  lbls <- .cyto_plot_axes_labels(tcks)

  # PER CHANNEL
  axs <- lapply(channels, function(chan) {
    # LINEAR CHANNEL - NA
    if (!chan %in% names(axes_trans)) {
      return(NA)
    }
    # TRANSFORMED CHANNEL - TRANSFORMATIONS
    trans_func <- axes_trans[[chan]]$transform
    inv_func <- axes_trans[[chan]]$inverse
    # AXIS RANGE - LINEAR SCALE
    if (!.all_na(axes_range[[chan]])) {
      rng <- inv_func(1.02 * axes_range[[chan]])
    } else {
      rng <- inv_func(1.02 * .cyto_range(fr_list,
        channels = chan,
        axes_limits = axes_limits
      )[, chan])
    }
    # RESTRICT tcks & lbls by rng
    tks <- tcks[tcks > rng[1] & tcks < rng[2]]
    lbs <- lbls[tcks %in% tks]
    # BREAKS - TRANSFORMED SCALE
    brks <- signif(trans_func(tks))
    # BREAKS & LABELS
    return(list("label" = lbs, "at" = brks))
  })
  names(axs) <- channels

  return(axs)
}

#' Convert Ticks to Labels - Expressions
#' @noRd
.cyto_plot_axes_labels <- function(x) {
  res <- lapply(x, function(z) {
    if (z != 0) {
      pwr <- log10(abs(z))
    }
    if (z == 0) {
      quote(0)
    } else if (pwr == 0) {
      quote("")
    } else if (abs(pwr) %% 1 == 0) {
      if(z < 0) {
        substitute(-10^pwr)
      } else {
        substitute(10^pwr)
      }
    } else {
      quote("")
    }
  })
  do.call("expression", res)
}

## ARGUMENT HANDLERS -----------------------------------------------------------

#' Repeat and split arguments for use in cyto_plot
#'
#' Use with cyto_plot only!
#'
#' @param x named list of arguments
#'
#' @importFrom methods is
#'
#' @author Dillon Hammill (Dillon.Hammill@anu.edu.au)
#'
#' @noRd
.cyto_plot_args_split <- function(x) {

  # NUMBER OF PLOTS - N --------------------------------------------------------
  if (all(LAPPLY(x[["fr_list"]], is, "flowFrame"))) {
    N <- 1
    MTD <- "flowFrame"
  } else if (all(LAPPLY(x[["fr_list"]], function(z) {
    LAPPLY(z, function(y) {
      is(y, "flowFrame")
    })
  }))) {
    N <- length(x[["fr_list"]])
    MTD <- "flowSet"
  }

  # LAYERS PER PLOT - L --------------------------------------------------------
  if (MTD == "flowFrame") {
    L <- length(x[["fr_list"]])
  } else if (MTD == "flowSet") {
    L <- length(x[["fr_list"]][[1]])
  }

  # TOTAL LAYERS TO PLOT - TL -------------------------------------------------
  TL <- N * L

  # GATE COUNT PER LAYER - GC --------------------------------------------------
  if (MTD == "flowFrame") {
    if (all(LAPPLY(x[["gate"]], function(z) {
      .all_na(z)
    }))) {
      GC <- 0
    } else {
      GC <- length(x[["gate"]])
    }
  } else if (MTD == "flowSet") {
    if (all(LAPPLY(x[["gate"]][[1]], function(z) {
      .all_na(z)
    }))) {
      GC <- 0
    } else {
      GC <- length(x[["gate"]][[1]])
    }
  }

  # GATED POPULATIONS PER LAYER - GP -------------------------------------------
  GP <- c()
  if (MTD == "flowFrame") {
    if (GC != 0) {
      lapply(x[["gate"]], function(z) {
        if (class(z) == "quadGate") {
          GP <<- c(GP, 4)
        } else {
          GP <<- c(GP, 1)
        }
      })
    } else {
      GP <- 1
    }
  } else if (MTD == "flowSet") {
    if (GC != 0) {
      lapply(x[["gate"]][[1]], function(z) {
        if (class(z) == "quadGate") {
          GP <<- c(GP, 4)
        } else {
          GP <<- c(GP, 1)
        }
      })
    } else {
      GP <- 1
    }
  }

  # TOTAL GATED POPULATIONS PER LAYER - TGP ------------------------------------
  TGP <- sum(GP)

  # TOTAL POPULATIONS PER LAYER - TP -------------------------------------------
  if (GC != 0 & x[["negate"]] == TRUE) {
    if (MTD == "flowFrame") {
      # WATCH OUT FOR QUADGATES
      if (!"quadGate" %in% LAPPLY(x[["gate"]], "is")) {
        TP <- TGP + 1
      }
    } else if (MTD == "flowSet") {
      # WATCH OUT FOR QUADGATES
      if (!"quadGate" %in% LAPPLY(x[["gate"]][[1]], "is")) {
        TP <- TGP + 1
      }
    }
  } else {
    TP <- TGP
  }
  
  # ARGUMENTS NOT REPEATED -----------------------------------------------------

  # The following arguments are not repeated:
  # - arguments used to prepare the data - x, overlay, display, density_modal,
  #   density_stack, density_smooth
  # - arguments that MUST be the same in each plot - channels, axes_limits, popup,
  #   xlim, ylim, negate, density_cols, point_col_scale, point_cols, legend
  # - arguments already prepared - gate

  # CYTO_PLOT ARGUMENTS --------------------------------------------------------

  # AVAILABLE ARGUMENTS
  ARGS <- formalArgs(cyto_plot.flowSet)

  # REMOVE ARGUMENTS (SAME PER PLOT)
  ARGS <- ARGS[-match(c(
    "x",
    "overlay",
    "display",
    "channels",
    "gate",
    "axes_limits",
    "axes_limits_buffer",
    "popup",
    "xlim",
    "ylim",
    "negate",
    "density_modal",
    "density_stack",
    "density_smooth",
    "density_cols",
    "point_cols",
    "point_col_scale"
  ), ARGS)]

  # ARGUMENTS PER PLOT ---------------------------------------------------------

  # SINGLE LENGTH ARGUMENTS
  args <- c(
    "xlab",
    "ylab",
    ARGS[grepl("title", ARGS)],
    ARGS[grepl("axes_text_", ARGS)],
    ARGS[grepl("axes_label_", ARGS)],
    "label",
    "label_position",
    "legend",
    ARGS[grepl("border_", ARGS)]
  )

  # UPDATE AVAILABLE ARGUMENTS
  ARGS <- ARGS[-match(args, ARGS)]

  lapply(args, function(arg) {
    if (arg %in% names(x)) {
      res <- rep_len(x[[arg]], N)
      if (N == 1 & MTD == "flowSet") {
        res <- list(res)
      } else if (N > 1) {
        res <- split(res, rep_len(seq_len(N), N))
      }
      x[[arg]] <<- res
    }
  })

  # MULTIPLE LENGTH ARGUMENTS
  args <- c("axes_text")

  # UPDATE AVAILABLE ARGUMENTS
  ARGS <- ARGS[-match(args, ARGS)]

  lapply(args, function(arg) {
    if (arg %in% names(x)) {
      res <- rep_len(x[[arg]], N * 2)
      if (N == 1 & MTD == "flowSet") {
        res <- list(res)
      } else if (N > 1) {
        res <- split(res, rep(seq_len(N), length.out = N * 2, each = 2))
      }
      x[[arg]] <<- res
    }
  })

  # ARGUMENTS PER LAYER --------------------------------------------------------

  # CONTOUR_LINES (ADD ZEROS)
  args <- c("contour_lines")

  # UPDATE AVAILABLE ARGUMENTS
  ARGS <- ARGS[-match(args, ARGS)]

  lapply(args, function(arg) {
    if (arg %in% names(x)) {
      # FILL WITH ZEROS
      if (length(x[[arg]]) < L) {
        res <- rep(c(x[[arg]], rep(0, L)), length.out = L)
        res <- rep(res, N)
      } else {
        res <- rep(x[[arg]], length.out = TL)
      }
      if (N == 1 & MTD == "flowSet") {
        res <- list(res)
      } else if (N > 1) {
        res <- split(res, rep(seq_len(N), length.out = TL, each = L))
      }
      x[[arg]] <<- res
    }
  })

  # ARGUMENTS/LAYER
  args <- c(
    ARGS[grepl("density_fill", ARGS)],
    ARGS[grepl("density_line", ARGS)],
    ARGS[grepl("legend_", ARGS)],
    ARGS[grepl("point_", ARGS)],
    ARGS[grepl("contour_", ARGS)]
  )

  # UPDATE AVAILABLE ARGUMENTS
  ARGS <- ARGS[-match(args, ARGS)]

  lapply(args, function(arg) {
    if (arg %in% names(x)) {
      if (arg %in% c("point_col", "density_fill") &
        length(x[[arg]]) < L) {
        res <- rep(c(x[[arg]], rep(NA, length.out = L)), length.out = L)
        res <- rep(res, N)
      } else {
        res <- rep(x[[arg]], length.out = TL)
      }
      if (N == 1 & MTD == "flowSet") {
        res <- list(res)
      } else if (N > 1) {
        res <- split(res, rep(seq_len(N), length.out = TL, each = L))
      }
      x[[arg]] <<- res
    }
  })

  # ARGUMENTS PER GATE ---------------------------------------------------------

  # ARGUMENTS
  args <- ARGS[grepl("gate_line", ARGS)]

  # UPDATE AVAILABLE ARGUMENTS
  ARGS <- ARGS[-match(args, ARGS)]

  if (GC != 0) {
    lapply(args, function(arg) {
      if (arg %in% names(x)) {
        res <- rep(x[[arg]], length.out = GC * N)
        if (N == 1 & MTD == "flowSet") {
          res <- list(res)
        } else if (N > 1) {
          res <- split(res, rep(seq_len(N),
            length.out = GC * N,
            each = GC
          ))
        }
        x[[arg]] <<- res
      }
    })
  }

  # ARGUMENTS PER POPULATION ---------------------------------------------------

  # GATE_FILL ARGUMENTS
  args <- ARGS[grepl("gate_fill", ARGS)]

  # UPDATE AVAILABLE ARGUMENTS
  ARGS <- ARGS[-match(args, ARGS)]

  if (GC != 0) {
    lapply(args, function(arg) {
      if (arg %in% names(x)) {
        # GATE_FILL - WHITE
        if (arg == "gate_fill") {
          res <- rep(c(x[[arg]], rep("white", TGP * N)), length.out = TGP * N)
          # GATE_FILL_APLHA - ZERO
        } else if (arg == "gate_fill_alpha") {
          res <- rep(c(x[[arg]], rep(0, TGP * N)), length.out = TGP * N)
        }
        if (N == 1 & MTD == "flowSet") {
          res <- list(res)
        } else if (N > 1) {
          res <- split(res, rep(seq_len(N),
            length.out = TGP * N,
            each = TGP
          ))
        }
        x[[arg]] <<- res
      }
    })
  }

  # LABEL ARGUMENTS
  args <- ARGS[grepl("label_", ARGS)]

  # UPDATE AVAILABLE ARGUMENTS
  ARGS <- ARGS[-match(args, ARGS)]

  lapply(args, function(arg) {
    if (arg %in% names(x)) {
      if (arg %in% c(
        "label_text_x",
        "label_text_y"
      )) {
        res <- rep(c(x[[arg]], rep(NA, L * TP)), length.out = L * TP)
        res <- rep(res, N)
      } else if (MTD == "flowSet" & arg == "label_text") {
        res <- rep(c(x[[arg]], rep(NA, L * TP)), length.out = L * TP)
        res <- rep(res, N)
      } else {
        res <- rep(x[[arg]], length.out = TL * TP)
      }
      if (N == 1 & MTD == "flowSet") {
        res <- list(res)
      } else if (N > 1) {
        res <- split(res, rep(seq_len(N),
          length.out = TL * TP,
          each = L * TP
        ))
      }
      x[[arg]] <<- res
    }
  })

  return(x)
}

## POINT DENSITY COLOURS -------------------------------------------------------

#' Get density gradient colours for cyto_plot
#'
#' @param point_col_scale vector of ordered colours to use for point density
#'   colour scale.
#'
#' @return a list of colorRampPalette functions to be used in densCols.
#'
#' @author Dillon Hammill (Dillon.Hammill@anu.edu.au)
#'
#' @noRd
.cyto_plot_point_col_scale <- function(point_col_scale = NA) {

  # Pull down arguments to named list
  args <- .args_list()

  # Inherit arguments from cyto_plot_theme
  args <- .cyto_plot_theme_inherit(args)

  # Use default colour scale
  if (.all_na(args[["point_col_scale"]])) {
    args[["point_col_scale"]] <- .cyto_plot_colour_palette(type = "point_col_scale")
  }

  return(args[["point_col_scale"]])
}

## LAYOUT ----------------------------------------------------------------------

#' Set plot layout
#'
#' @param x list of flowFrame lists to be plotted.
#' @param layout grid dimensions c(nr, nc), NA 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 = NA,
                              density_stack = 0,
                              density_layers = NA) {

  # Number of samples
  smp <- length(x)

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

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

  return(mfrw)
}

## MARGINS ---------------------------------------------------------------------

#' Set plot margins
#'
#' @param x list of flowFrames or density objects to plot.
#' @param legend logical indicating whether a legend should be included in the
#'   plot.
#' @param title if NULL remove excess space above plot.
#' @param axes_text vector of logicals indicating whether the x and y axes
#'   should be included on the plot.
#' @param margins a vector of length 4 to control the margins around the bottom,
#'   left, top and right of the plot, set to NULL by default to let `cyto_plot`
#'   compute optimal margins.
#'
#' @importFrom methods is
#'
#' @noRd
.cyto_plot_margins <- function(x,
                               legend = FALSE,
                               legend_text = NA,
                               legend_text_size = 1,
                               title,
                               axes_text = list(TRUE, TRUE),
                               margins = NULL) {

  # Bypass setting margins on cyto_plot_grid
  if (!getOption("cyto_plot_grid")) {

    # Pull down arguments to named lis
    args <- .args_list()

    # Default margins
    if (is.null(margins)) {

      # Default starting point
      mar <- c(5.1, 5.1, 4.1, 2.1)

      # Make space for legend text on right
      if (length(x) > 1 &
        legend != FALSE &
        !.all_na(legend_text)) {
        mar[4] <- 7 + max(nchar(legend_text)) * 0.32 * mean(legend_text_size)
      }

      # Remove space above plot if no title
      if (.all_na(title)) {
        mar[3] <- 2.1
      }

      # Remove space below plot if x axis is missing
      if (!all(is(axes_text[[1]], "list"))) {
        if (.all_na(axes_text[[1]])) {
          # NA == FALSE returns NA not T/F
        } else if (all(axes_text[[1]] == FALSE)) {
          mar[1] <- 4.1
        }
      }

      # Remove space below plot if y axis is missing
      if (!all(is(axes_text[[2]], "list"))) {
        if (.all_na(axes_text[[2]])) {
          # NA == FALSE return NA not T/F
        } else if (all(axes_text[[2]] == FALSE)) {
          mar[2] <- 4.1
        }
      }
    } else {
      if (length(margins) != 4) {
        stop("'margins' must be a vector with 4 elements.")
      }
      mar <- margins
    }

    # Set update graphics parameter
    par("mar" = mar)
  }
}

## LEGEND ----------------------------------------------------------------------

#' Create a legend for cyto_plot
#'
#' \code{.cyto_plot_margins} will handle setting the plot margins to make space
#' for the legend.
#'
#' @param x list of flowFrame objects to include in the plot.
#' @param channels name of the channels or markers to be used to construct the
#'   plot.
#' @param legend logical indicating whether a legend should be included for
#'   plots including overlays, set to FALSE by default.
#' @param legend_text vector of labels to use for the legend.
#' @param legend_text_font numeric indicating the font to use for legend text,
#'   set to 2 for bold font by default. See \code{\link[graphics:par]{?par}}
#'   font for details.
#' @param legend_text_size character expansion for legend text, set to 1 by
#'   default.
#' @param legend_text_col colour to use for legend text, set to "black by
#'   default.
#' @param legend_line_col vector of line colours to use for legend.
#' @param legend_box_fill vector of fill colours to use for legend.
#' @param legend_point_col vector of colours to use for points in legend.
#' @param density_cols vector colours to draw from when selecting density fill
#'   colours if none are supplied to density_fill.
#' @param density_fill colour(s) used to fill polygons.
#' @param density_fill_alpha numeric [0,1] used to control fill transparency,
#'   set to 1 by default to remove transparency.
#' @param density_line_type line type(s) to use for border(s), set to solid
#'   lines by default.
#' @param density_line_width line width for border.
#' @param density_line_col colour(s) for border line, set to "black" by default.
#' @param point_shape point character to use for points, set to "." by default
#'   to maximise plotting speed.
#' @param point_size numeric specifying the degree of character expansion for
#'   points, set to 2 by default.
#' @param point_col_scale vector of colours to use for density gradient.
#' @param point_cols vector colours to draw from when selecting colours for
#'   points if none are supplied to point_col.
#' @param point_col colours to use for points, set to NA by default to blue-red
#'   density colour scale.
#' @param point_alpha numeric [0,1] used to control colour transparency, set to
#'   1 by default to remove transparency.
#'
#' @author Dillon Hammill, \email{Dillon.Hammill@anu.edu.au}
#'
#' @importFrom graphics legend strheight
#' @importFrom grDevices adjustcolor
#'
#' @noRd
.cyto_plot_legend <- function(x,
                              channels,
                              legend = "fill",
                              legend_text = NA,
                              legend_text_font = 1,
                              legend_text_size = 1,
                              legend_text_col = "black",
                              legend_line_type = NA,
                              legend_line_width = NA,
                              legend_line_col = NA,
                              legend_box_fill = NA,
                              legend_point_col = NA,
                              density_cols = NA,
                              density_fill = NA,
                              density_fill_alpha = 1,
                              density_line_type = 1,
                              density_line_width = 1,
                              density_line_col = "black",
                              point_shape = ".",
                              point_size = 2,
                              point_col_scale = NA,
                              point_cols = NA,
                              point_col = NA,
                              point_col_alpha = 1) {

  # ARGUMENTS ------------------------------------------------------------------

  # ARGUMENTS
  args <- .args_list()

  # CYTO_PLOT_THEME
  args <- .cyto_plot_theme_inherit(args)

  # UPDATE ARGUMENTS
  .args_update(args)

  # LEGEND_TEXT ----------------------------------------------------------------

  # Estimate legend height using strheight
  lgnd <- paste(legend_text, collapse = " \n ")
  lgnd_height <- strheight(lgnd,
    cex = legend_text_size,
    font = legend_text_font
  )

  # LEGEND POSITION ------------------------------------------------------------

  # Calculate y center of plot
  cnt <- par("usr")[3] + (par("usr")[4] - par("usr")[3]) / 2

  # Legend for 1D density distributions
  if (length(channels) == 1) {

    # Set default legend type to fill
    if (legend == TRUE) {
      legend <- "fill"
    }

    # Reverse legend text order for legend
    legend_text <- rev(legend_text)

    # Line legend
    if (legend == "line") {

      # Revert to density_line_col if no colours supplied
      if (.all_na(legend_line_col)) {
        legend_line_col <- density_line_col
      }

      # Revert to density_line_type if not specified
      if (.all_na(legend_line_type)) {
        legend_line_type <- density_line_type
      }

      # Revert to density_line_width if not specified
      if (.all_na(legend_line_width)) {
        legend_line_width <- density_line_width
      }

      # Construct legend
      legend(
        x = 1.07 * par("usr")[2],
        y = cnt + 0.52 * lgnd_height,
        legend = legend_text,
        text.font = rev(legend_text_font),
        cex = legend_text_size,
        text.col = rev(legend_text_col),
        col = rev(legend_line_col),
        lty = rev(legend_line_type),
        lwd = rev(legend_line_width),
        xpd = TRUE,
        bty = "n",
        x.intersp = 0.5
      )
      # Fill legend
    } else if (legend == "fill") {

      # COLOURS
      density_fill <- .cyto_plot_density_fill(x,
        density_fill = density_fill,
        density_cols = density_cols,
        density_fill_alpha = 1
      )

      # Revert to density_fill if no legend fill colours supplied
      if (.all_na(legend_box_fill)) {
        legend_box_fill <- density_fill
      }
      # Alpha adjust colours if suppplied directly to legend_box_fill
      if (!.all_na(legend_box_fill) &
        !all(density_fill_alpha == 1)) {
        legend_box_fill <- mapply(
          function(legend_box_fill,
                   density_fill_alpha) {
            adjustcolor(legend_box_fill, density_fill_alpha)
          }, legend_box_fill, density_fill_alpha
        )
      }

      # Construct legend
      legend(
        x = 1.07 * par("usr")[2],
        y = cnt + 0.52 * lgnd_height,
        legend = legend_text,
        fill = rev(legend_box_fill),
        xpd = TRUE,
        bty = "n",
        x.intersp = 0.5,
        cex = legend_text_size,
        text.col = rev(legend_text_col),
        text.font = rev(legend_text_font)
      )
    }

    # Legend for 2D scatter plot
  } else if (length(channels) == 2) {

    # CYTO_PLOT_POINT_COL_SCALE
    point_col_scale <- .cyto_plot_point_col_scale(point_col_scale)

    # Prepare point_col - alpha adjust later
    point_col <- .cyto_plot_point_col(x,
      channels = channels,
      point_col_scale = point_col_scale,
      point_cols = point_cols,
      point_col = point_col,
      point_col_alpha = 1
    )

    # Prepare point col - use first density colour
    point_col <- LAPPLY(point_col, function(z) {
      if (length(z) > 1) {
        return(point_col_scale[1])
      } else {
        return(z)
      }
    })

    # Revert to point_col if no legend point cols supplied
    if (.all_na(legend_point_col)) {
      legend_point_col <- point_col
    }

    # Alpha adjust colours supplied directly to legend_point_col
    if (!.all_na(legend_point_col) &
      !all(point_col_alpha == 1)) {
      legend_point_col <- mapply(function(col, alpha) {
        adjustcolor(col, alpha)
      }, legend_point_col, point_col_alpha)
    }

    legend(
      x = 1.08 * par("usr")[2],
      y = cnt + 0.6 * lgnd_height,
      legend = rev(legend_text),
      col = rev(legend_point_col),
      pch = rev(point_shape),
      pt.cex = rev(2 * point_size),
      xpd = TRUE,
      bty = "n",
      x.intersp = 0.7,
      cex = legend_text_size,
      text.col = rev(legend_text_col),
      text.font = rev(legend_text_font)
    )
  }
}

## THEME INHERIT ---------------------------------------------------------------

#' Inherit cyto_plot_theme arguments
#'
#' @param x list of named cyto_plot arguments.
#'
#' @return updated list of named arguments if cyto_plot_theme has been set.
#'
#' @author Dillon Hammill, \email{Dillon.Hammill@anu.edu.au}
#'
#' @noRd
.cyto_plot_theme_inherit <- function(x) {

  # extract cyto_plot_theme arguments
  args <- getOption("cyto_plot_theme")

  if (!is.null(args)) {
    lapply(names(args), function(y) {
      x[[y]] <<- args[[y]]
    })
  }

  return(x)
}

## TITLE -----------------------------------------------------------------------

#' Title for cyto_plot
#'
#' @param x flowFrame object.
#'
#' @author Dillon Hammill, \email{Dillon.Hammill@anu.edu.au}
#'
#' @noRd
.cyto_plot_title <- function(x,
                             channels,
                             overlay = NA,
                             title = "") {

  # x can be a list
  if (class(x) == "list") {
    if (length(x) > 1) {
      overlay <- x[2:length(x)]
      x <- x[[1]]
    }
  }

  # Pull down arguments to named list
  args <- .args_list()

  # Update arguments
  .args_update(args)

  # 1D density distributions
  if (length(channels) == 1) {

    # missing/empty replace with valid title
    if (.empty(title)) {

      # stacked/overlays lack a title
      if (.all_na(overlay)) {
        title <- cyto_names(x)
      } else {
        title <- NA
      }

      # NA will remove title in cyto_plot_empty
    } else if (.all_na(title)) {
      title <- NA
    }

    # 2D scatterplots
  } else if (length(channels) == 2) {

    # missing title replaced with sample name
    if (.empty(title)) {
      title <- cyto_names(x)
      # NA will remove title in cyto_plot_empty
    } else if (.all_na(title)) {
      title <- NA
    }
  }

  return(title)
}

## AXES LABELS -----------------------------------------------------------------

#' Get axes titles for cyto_plot
#'
#' @param x flowFrame object.
#'
#' @author Dillon Hammill, \email{Dillon.Hammill@anu.edu.au}
#'
#' @noRd
.cyto_plot_axes_label <- function(x,
                                  channels,
                                  xlab,
                                  ylab,
                                  density_modal = TRUE) {

  # Extract information about channels
  fr_data <- pData(parameters(x))
  fr_channels <- BiocGenerics::colnames(x)

  # 1D density distributions
  if (length(channels) == 1) {

    # x axis label
    if (missing(xlab) | .empty(xlab)) {
      # Marker assigned to channel
      if (!is.na(fr_data$desc[which(fr_channels == channels)])) {
        # Channel only if marker is identical
        if (fr_data$desc[which(fr_channels == channels)] == channels) {
          xlab <- paste(channels)
        } else {
          xlab <- paste(fr_data$desc[which(fr_channels == channels)],
            channels,
            sep = " "
          )
        }
        # No assigned marker to channel
      } else if (is.na(fr_data$desc[which(fr_channels == channels)])) {
        xlab <- paste(channels)
      }
    } else if (.all_na(xlab)) {
      xlab <- NA
    }

    # y axis label
    if (missing(ylab) | .empty(ylab)) {
      if (density_modal) {
        ylab <- "% of Mode"
      } else {
        ylab <- "Density"
      }
    } else if (.all_na(ylab)) {
      ylab <- NA
    }

    # 2D scatterplots
  } else if (length(channels) == 2) {

    # x axis label
    if (missing(xlab) | .empty(xlab)) {
      # Marker assigned to channel
      if (!is.na(fr_data$desc[which(fr_channels == channels[1])])) {
        # Channel only if marker is identical
        if (fr_data$desc[which(fr_channels == channels[1])] == channels[1]) {
          xlab <- paste(channels[1])
        } else {
          xlab <- paste(fr_data$desc[which(fr_channels == channels[1])],
            channels[1],
            sep = " "
          )
        }
        # No assigned marker to channel
      } else if (is.na(fr_data$desc[which(fr_channels == channels[1])])) {
        xlab <- paste(channels[1])
      }
    } else if (.all_na(xlab)) {
      xlab <- NA
    }

    # y axis label
    if (missing(ylab) | .empty(ylab)) {
      # Marker assigned to channel
      if (!is.na(fr_data$desc[which(fr_channels == channels[2])])) {
        # Channel only if marker matches
        if (fr_data$desc[which(fr_channels == channels[2])] == channels[2]) {
          ylab <- paste(channels[2])
        } else {
          ylab <- paste(fr_data$desc[which(fr_channels == channels[2])],
            channels[2],
            sep = " "
          )
        }

        # No assigned marker to channel
      } else if (is.na(fr_data$desc[which(fr_channels == channels[2])])) {
        ylab <- paste(channels[2])
      }
    } else if (.all_na(ylab)) {
      ylab <- NA
    }
  }

  return(list(xlab, ylab))
}

## DENSITY FILL ----------------------------------------------------------------

#' Get density fill colours for cyto_plot
#'
#' @param x list of flowFrame or density objects.
#' @param density_fill vector of colours to use for each layer.
#' @param density_cols vector of colls to use to select density_fill colours.
#'
#' @importFrom grDevices adjustcolor colorRampPalette
#'
#' @author Dillon Hammill, \email{Dillon.Hammill@anu.edu.au}
#'
#' @noRd
.cyto_plot_density_fill <- function(x,
                                    density_fill = NA,
                                    density_cols = NA,
                                    density_fill_alpha = 1) {

  # INHERIT CYTO_PLOT_THEME ----------------------------------------------------

  # Pull down arguments to named list
  args <- .args_list()

  # Inherit arguments from cyto_plot_theme
  args <- .cyto_plot_theme_inherit(args)

  # Update arguments
  .args_update(args)

  # GENERAL --------------------------------------------------------------------

  # Expected number of colours
  SMP <- length(x)

  # DENSITY_FILL ---------------------------------------------------------------

  # No density_cols supplied
  if (.all_na(density_cols)) {
    density_cols <- .cyto_plot_colour_palette(type = "density_cols")
  }

  # Make colorRampPalette
  if (class(density_cols) != "function") {
    cols <- colorRampPalette(density_cols)
  } else {
    cols <- density_cols
  }

  # No colours supplied to density_fill either
  if (.all_na(density_fill)) {

    # Pull out a single colour per layer
    density_fill <- cols(SMP)

    # Colours supplied manually to density_fill
  } else {

    # Too few colours supplied - pull others from cols
    if (length(density_fill) < SMP) {
      density_fill <- c(
        density_fill,
        cols(SMP - length(density_fill))
      )

      # Too many colours supplied
    } else if (length(density_fill) > SMP) {
      density_fill <- density_fill[seq_len(SMP)]
    }
  }

  # Adjust colors by density_fill_alpha
  density_fill <- mapply(function(density_fill, density_fill_alpha) {
    if (density_fill_alpha != 1) {
      adjustcolor(density_fill, density_fill_alpha)
    } else {
      density_fill
    }
  }, density_fill, density_fill_alpha, USE.NAMES = FALSE)

  return(density_fill)
}

## POINT COLOUR ----------------------------------------------------------------

#' Get point colours for cyto_plot
#'
#' @param x list of flowFrames.
#' @param channels used to construct the plot.
#' @param point_col_scale vector of colours to use for density gradient.
#' @param point_cols vector colours to select from when choosing a colour for
#'   each layer in x.
#' @param point_col vector of length x indicating colours to use for each layer.
#'   If NA set to default density gradient.
#' @param point_col_alpha transparency to use for point colours.
#'
#' @importFrom grDevices densCols colorRampPalette adjustcolor colorRamp rgb
#' @importFrom flowCore exprs
#' @importFrom methods is
#'
#' @author Dillon Hammill, \email{Dillon.Hammill@anu.edu.au}
#'
#' @noRd
.cyto_plot_point_col <- function(x,
                                 channels,
                                 point_col_scale,
                                 point_cols,
                                 point_col,
                                 point_col_alpha = 1) {
  
  # Expected number of colours
  SMP <- length(x)
  
  # Pull down arguments to named list
  args <- .args_list()
  
  # Inherit arguments from cyto_plot_theme - possibly remove?
  args <- .cyto_plot_theme_inherit(args)
  
  # Update arguments
  .args_update(args)
  
  # No colours supplied for density gradient
  if (.all_na(point_col_scale)) {
    point_col_scale <- .cyto_plot_colour_palette(type = "point_col_scale")
  }
  
  # Make colorRampPalette
  if (class(point_col_scale) != "function") {
    col_scale <- colorRampPalette(point_col_scale)
  } else {
    col_scale <- point_col_scale
  }
  
  # No colours supplied for selection
  if (.all_na(point_cols)) {
    point_cols <- .cyto_plot_colour_palette(type = "point_cols")
  }
  
  # Make colorRampPalette
  if (class(point_cols) != "function") {
    cols <- colorRampPalette(point_cols)
  } else {
    cols <- point_cols
  }
  
  # Repeat point_col arguments SMP times
  point_col <- rep(point_col, length.out = SMP)
  point_col_alpha <- rep(point_col_alpha, length.out = SMP)
  
  # Convert point_col to list
  if (!is(point_col, "list")) {
    point_col <- lapply(seq(1, SMP), function(z) {
      point_col[z]
    })
  }
  
  # First layer contains density gradient if no other colour is designated
  if (all(LAPPLY(point_col, ".all_na"))) {
    
    # Extract data
    fr_exprs <- exprs(x[[1]])[, channels]
    
    # Too few events for density computation
    if (!is.null(nrow(fr_exprs))) {
      if (nrow(fr_exprs) >= 2) {
        # Get density colour for each point
        point_col[[1]] <- suppressWarnings(
          densCols(fr_exprs,
                   colramp = col_scale
          )
        )
      }
    } else {
      point_col[[1]] <- point_col_scale[1]
    }
  }
  
  # Remaining colours are selected one per layer from point_cols
  if (any(LAPPLY(point_col, ".all_na"))) {
    
    # Number of layers missing colours
    n <- length(point_col[LAPPLY(point_col, ".all_na")])
    
    # Pull colours out of point_cols
    clrs <- cols(n)
    
    # Replace NA values in point_col with selected colours
    point_col[LAPPLY(point_col, ".all_na")] <- clrs
  }
  
  # RANGE CALIBRATION
  cyto_cal <- .cyto_calibrate_recall()
  
  # 1D COLOUR SCALE
  point_col <- lapply(point_col, function(z) {
    if (length(z) == 1) {
      # NAME OF CHANNEL/MARKER
      if (z %in% c(
        cyto_channels(x[[1]]),
        cyto_markers(x[[1]])
      )) {
        # CONVERT TO CHANNEL
        z <- cyto_channels_extract(
          x[[1]],
          z
        )
        # MATRIX
        fr_exprs <- exprs(x[[1]])
        # CALIBRATION
        if (!is.null(cyto_cal)) {
          if (z %in% colnames(cyto_cal)) {
            cyto_range <- c(
              min(cyto_cal[, z]),
              max(cyto_cal[, z])
            )
          } else {
            cyto_range <- c(
              min(fr_exprs[, z]),
              max(fr_exprs[, z])
            )
          }
        } else {
          cyto_range <- c(
            min(fr_exprs[, z]),
            max(fr_exprs[, z])
          )
        }
        # RESCALE
        rescale <- (fr_exprs[, z] - cyto_range[1]) /
          (cyto_range[2] - cyto_range[1])
        rescale[rescale > 1] <- 1
        rescale[rescale < 0] <- 0
        # POINT_COLOUR_SCALE
        col_scale <- colorRamp(point_col_scale)
        # POINT COLOURS
        col <- col_scale(rescale)
        col <- rgb(col[, 1],
                   col[, 2],
                   col[, 3],
                   maxColorValue = 255
        )
        return(col)
        # NAME OF A COLOUR
      } else {
        return(z)
      }
    } else {
      return(z)
    }
  })
  
  # Adjust colors by point_fill_alpha - REMOVE CHECK FOR ALPHA != 1
  lapply(seq_len(SMP), function(z) {
    point_col[[z]] <<- adjustcolor(point_col[[z]], point_col_alpha[z])
  })
  
  return(point_col)
}

## .CYTO_PLOT_COLOUR_PALETTE ---------------------------------------------------

#' cyto_plot colour palette
#'
#' @param type indicates whether to return the "point_cols", "point_col_scale"
#'   or "density_cols" colour palette.
#'
#' @author Dillon Hammill, \email{Dillon.Hammill@anu.edu.au}
#'
#' @noRd
.cyto_plot_colour_palette <- function(type = "point_cols") {
  # POINT COLOUR PALETTE
  if (type == "point_cols") {
    pal <- c(
      "grey25",
      "bisque4",
      "brown1",
      "red",
      "darkred",
      "chocolate",
      "orange",
      "yellow",
      "yellowgreen",
      "green",
      "limegreen",
      "turquoise",
      "aquamarine",
      "cyan",
      "cornflowerblue",
      "blue",
      "blueviolet",
      "purple4",
      "purple",
      "magenta",
      "deeppink"
    )

    # POINT COLOUR SCALE
  } else if (type == "point_col_scale") {
    pal <- c(
      "blue3",
      "blue",
      "turquoise",
      "green",
      "yellow",
      "orange",
      "red",
      "darkred"
    )
    # DENSITY COLOUR PALETTE
  } else if (type == "density_cols") {
    pal <- c(
      "grey50",
      "bisque4",
      "brown1",
      "red",
      "darkred",
      "chocolate",
      "orange",
      "yellow",
      "yellowgreen",
      "green",
      "limegreen",
      "turquoise",
      "aquamarine",
      "cyan",
      "cornflowerblue",
      "blue",
      "blueviolet",
      "purple4",
      "purple",
      "magenta",
      "deeppink"
    )
  }

  return(pal)
}