R/cyto_plot-helpers.R

Defines functions cyto_plot_theme_args cyto_plot_theme_reset cyto_plot_theme cyto_plot_complete cyto_plot_custom cyto_plot_layout cyto_plot_save_reset cyto_plot_save cyto_plot_record cyto_plot_reset cyto_plot_new cyto_plot_empty.list cyto_plot_empty.flowFrame cyto_plot_empty

Documented in cyto_plot_complete cyto_plot_custom cyto_plot_empty cyto_plot_empty.flowFrame cyto_plot_layout cyto_plot_new cyto_plot_record cyto_plot_reset cyto_plot_save cyto_plot_save_reset cyto_plot_theme cyto_plot_theme_args cyto_plot_theme_reset

## CYTO_PLOT_EMPTY -------------------------------------------------------------

#' Create an empty cyto_plot
#'
#' \code{cyto_plot_empty} generates to base for cyto_plot by creating an empty
#' plot with border, axes, axes_text and titles. Data is subsequently added to
#' this base layer with \code{cyto_plot_point} or \code{cyto_plot_density}.
#'
#' @param x object of class \code{\link[flowCore:flowFrame-class]{flowFrame}}.
#' @param channels name of the channel(s) or marker(s) to be used to construct
#'   the plot. The length of channels determines the type of plot to be
#'   constructed, either a 1-D density distribution for a single channel or a
#'   2-D scatterplot with blue-red colour scale for two channels.
#' @param axes_trans object of class
#'   \code{\link[flowCore:transformList-class]{transformList}} or
#'   \code{\link[flowWorkspace]{transformerList}} generated by
#'   \code{\link[flowCore:logicleTransform]{estimateLogicle}} which was used to
#'   transform the fluorescent channels of the supplied flowFrame. This
#'   transformation object will be used internally to ensure that the axes
#'   labels of the plot are appropriately transformed. The transformation object
#'   will NOT be applied to the flowFrame internally and should be applied to
#'   the flowFrame prior to plotting.
#' @param overlay a list of flowFrames to overlay onto the plot.
#' @param gate list of gate objects to be plotted, used internlaly to ensure
#'   gate co-ordinates are taken into account when computing axes limits.
#' @param xlim lower and upper limits of x axis (e.g. c(0,5)).
#' @param ylim lower and upper limits of y axis (e.g. c(0,5)).
#' @param axes_limits options include \code{"auto"}, \code{"data"} or
#'   \code{"machine"} to use optimised, data or machine limits respectively. Set
#'   to \code{"auto"} by default to use optimised axes ranges. Fine control over
#'   axes limits can be obtained by altering the \code{xlim} and \code{ylim}
#'   arguments.
#' @param axes_limits_buffer decimal indicating the percentage of buffering to
#'   add to either end of the axes limits, set to 0.03 by default.
#' @param title title to use for the plot, set to the name of the sample by
#'   default. Title can be removed by setting this argument to \code{NA}.
#' @param xlab x axis label.
#' @param ylab y axis label.
#' @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.
#' @param density_modal logical indicating whether density should be normalised
#'   to mode and presented as a percentage. Set to \code{TRUE} by default.
#' @param density_smooth smoothing parameter passed to
#'   \code{\link[stats:density]{density}} to adjust kernel density.
#' @param density_stack numeric [0,1] indicating the degree of offset for
#'   overlaid populations, set to 0.5 by default. #' @param density_cols vector
#'   colours to draw from when selecting density fill colours if none are
#'   supplied to density_fill.
#' @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 shape(s) to use for points in 2-D scatterplots, set to
#'   \code{"."} by default to maximise plotting speed.  See
#'   \code{\link[graphics:par]{pch}} for alternatives.
#' @param point_size numeric to control the size of points in 2-D scatter plots
#'   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 colour(s) to use for points in 2-D scatter plots, set to NA
#'   by default to use a blue-red density colour scale.
#' @param point_col_alpha numeric [0,1] to control point colour transparency in
#'   2-D scatter plots, set to 1 by default to use solid colours.
#' @param axes_text logical vector of length 2 indicating whether axis text
#'   should be included for the x and y axes respectively, set to
#'   \code{c(TRUE,TRUE)} by default to display axes text on both axes.
#' @param axes_text_font numeric indicating the font to use for axes, set to 1
#'   for plain font by default. See \code{\link[graphics:par]{?par}} font for
#'   details.
#' @param axes_text_size character expansion for axis text.
#' @param axes_text_col colour of axis text.
#' @param axes_label_text_font numeric indicating the font to use for title, set
#'   to 1 for plain font by default. See \code{\link[graphics:par]{?par}} font
#'   for details.
#' @param axes_label_text_size character expansion for axis labels.
#' @param axes_label_text_col colour of axis labels.
#' @param title_text_font numeric indicating the font to use for title, set to 2
#'   for bold font by default. See \code{\link[graphics:par]{?par}} font for
#'   details.
#' @param title_text_size character expansion for plot title.
#' @param title_text_col colour for plot title.
#' @param border_line_type line type to use for plot border, set to 1 by default
#'   for a sold border.
#' @param border_line_width line width for plot border, set to 1 by default.
#' @param border_line_col line colour for plot border, set to "black" by
#'   default.
#' @param border_fill colour to use for the plot background, set to "white" by
#'   default.
#' @param border_fill_alpha transparency to use for border_fill colour, set to 1
#'   by default to add no transparency.
#' @param legend can be either \code{"line"} or \code{"fill"} to indicate
#'   whether a legend should be constructed based on the density \code{"line"}
#'   or \code{"fill"}, set to FALSE by default to remove the legend.
#' @param legend_text vector of labels to use in the legend.
#' @param legend_text_font numeric to control the font of legend text, set to 1
#'   for plain font by default. See \code{\link[graphics:par]{font}} for
#'   alternatives.
#' @param legend_text_size numeric to control the size of text in the legend,
#'   set to 1 by default.
#' @param legend_text_col colour(s) to use for text in legend, set to
#'   \code{"black"} by default.
#' @param legend_line_type numeric to control the line type for line legends,
#'   set to 1 by default. Refer to \code{lty} in \code{\link[graphics:par]{par}}
#'   for alternatives.
#' @param legend_line_width numeric to control the line width in line legend,
#'   set to 1 by default. Refer to \code{lwd} in \code{\link[graphics:par]{par}}
#'   for alternatives.
#' @param legend_line_col colour(s) to use for the lines in 1-D plot legends
#'   when legend is set to \code{"line"}.
#' @param legend_box_fill fill colour(s) to use for the boxes in 1-D plot
#'   legends when legend is set to \code{"fill"}.
#' @param legend_point_col colour(s) to use for points in 2-D scatter plot
#'   legend.
#' @param ... not in use.
#'
#' @importFrom grDevices adjustcolor
#' @importFrom graphics plot box axis title par
#' @importFrom methods formalArgs is
#'
#' @author Dillon Hammill (Dillon.Hammill@anu.edu.au)
#'
#' @examples
#' library(CytoExploreRData)
#'
#' # Construct an empty 2D plot with black background
#' cyto_plot_empty(Activation[[32]],
#'   channels = c("FSC-A", "SSC-A"),
#'   border_fill = "black"
#' )
#'
#' # Construct an empty 1D plot
#' cyto_plot_empty(Activation[[32]],
#'   channels = c("FSC-A"),
#'   overlay = Activation[1:2]
#' )
#' @rdname cyto_plot_empty
#' @export
cyto_plot_empty <- function(x, ...) {
  UseMethod("cyto_plot_empty")
}

#' @rdname cyto_plot_empty
#' @export
cyto_plot_empty.flowFrame <- function(x,
                                      channels,
                                      axes_trans = NA,
                                      overlay = NA,
                                      gate = NA,
                                      xlim = NA,
                                      ylim = NA,
                                      axes_limits = "auto",
                                      axes_limits_buffer = 0.03,
                                      title,
                                      xlab,
                                      ylab,
                                      margins = NULL,
                                      density_modal = TRUE,
                                      density_smooth = 1.5,
                                      density_stack = 0.5,
                                      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,
                                      axes_text = c(TRUE, TRUE),
                                      axes_text_font = 1,
                                      axes_text_size = 1,
                                      axes_text_col = "black",
                                      axes_label_text_font = 1,
                                      axes_label_text_size = 1.1,
                                      axes_label_text_col = "black",
                                      title_text_font = 2,
                                      title_text_size = 1.1,
                                      title_text_col = "black",
                                      border_line_type = 1,
                                      border_line_width = 1,
                                      border_line_col = "black",
                                      border_fill = "white",
                                      border_fill_alpha = 1,
                                      legend = FALSE,
                                      legend_text,
                                      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,
                                      ...) {

  # GRAPHICAL PARAMETERS -------------------------------------------------------

  # Prevent scientific notation on axes - reset on exit
  scipen <- getOption("scipen")
  options(scipen = 100000000)
  on.exit(options(scipen = scipen))

  # Extract current graphics parameters
  pars <- par("mar")

  # Reset graphics parameters on exit
  on.exit(par(pars))

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

  # 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)

  # CHANNELS -------------------------------------------------------------------

  # Check channels
  channels <- cyto_channels_extract(
    x,
    channels
  )

  # LIST OF FLOWFRAMES ---------------------------------------------------------

  # Convert overlay to list of flowFrames
  if (!.all_na(overlay) &
    any(is(overlay, "flowFrame") |
      is(overlay, "flowSet"))) {
    overlay <- cyto_convert(overlay, "list of flowFrames")
  }

  # Combine x and overlay into list
  if (!.all_na(overlay)) {
    fr_list <- c(list(x), overlay)
  } else {
    fr_list <- list(x)
  }

  # SAMPLES
  smp <- length(fr_list)

  # AXES LIMITS ----------------------------------------------------------------

  # XLIM
  if (.all_na(xlim)) {
    # XLIM
    xlim <- .cyto_range(fr_list,
      channels = channels[1],
      axes_limits = axes_limits,
      buffer = axes_limits_buffer,
      plot = TRUE
    )[, 1]
  }
  
  # YLIM
  if (.all_na(ylim)) {
    # 1D PLOT
    if (length(channels) == 1) {
      # DENSITY
      fr_dens <- .cyto_density(fr_list,
        channel = channels,
        smooth = density_smooth,
        stack = density_stack,
        modal = density_modal
      )
      # YLIM
      ymin <- as.numeric(unlist(strsplit(names(fr_dens)[1], "-"))[1])
      ymax <- as.numeric(unlist(strsplit(names(fr_dens)[smp], "-"))[2])
      ylim <- c(ymin, ymax)
      # 2D PLOT
    } else if (length(channels) == 2) {
      # YLIM
      ylim <- .cyto_range(fr_list,
        channels = channels[2],
        axes_limits = axes_limits,
        buffer = axes_limits_buffer,
        plot = TRUE
      )[, 1]
    }
  }
  
  # GATE COORDS MUST BE WITHIN AXES LIMITS
  if(!.all_na(gate)){
    # GATE COORDS
    gate_coords <- .cyto_gate_coords(gate, channels)
  }
  
  # XLIM GATE COORD ADJUSTMENT
  if(!.all_na(gate)){
    # MIN & MAX GATE COORDS
    gate_xcoords <- gate_coords[, channels[1]]
    gate_xcoords <- c(min(gate_xcoords), max(gate_xcoords))
    # GATE COORDS BELOW XMIN
    if(is.finite(gate_xcoords[1]) & gate_xcoords[1] < xlim[1]){
      xlim[1] <- gate_xcoords[1]
    }
    # GATE COORDS ABOVE XMAX
    if(is.finite(gate_xcoords[2]) & gate_xcoords[2] > xlim[2]){
      xlim[2] <- gate_xcoords[2]
    }
  }
  
  # YLIM GATE COORD ADJUSTMENT
  if(length(channels) == 2){
    # GATE COORDS
    if(!.all_na(gate)){
      # MIN & MAX GATE COORDS
      gate_ycoords <- gate_coords[, channels[2]]
      gate_ycoords <- c(min(gate_ycoords), max(gate_ycoords))
      # GATE COORDS BELOW YMIN
      if(is.finite(gate_ycoords[1]) & gate_ycoords[1] < ylim[1]){
        ylim[1] <- gate_ycoords[1]
      }
      # GATE COORDS ABOVE YMAX
      if(is.finite(gate_ycoords[2]) & gate_ycoords[2] > ylim[2]){
        ylim[2] <- gate_ycoords[2]
      }
    }
  }
  
  # AXES TEXT ------------------------------------------------------------------

  # Convert axes_text to list - allows inheritance from cyto_plot
  if (!is(axes_text, "list")) {
    axes_text <- list(axes_text[1], axes_text[2])
  }

  # X axis breaks and labels -  can be inherited from cyto_plot
  if (!is(axes_text[[1]], "list")) {
    if (.all_na(axes_text[[1]])) {
      # NA == TRUE returns NA not T/F
    } else if (axes_text[[1]] == TRUE) {
      lims <- list(xlim)
      names(lims) <- channels[1]
      axes_text[[1]] <- .cyto_plot_axes_text(fr_list,
        channels = channels[1],
        axes_trans = axes_trans,
        axes_range = lims,
        axes_limits = axes_limits
      )[[1]]
    }
  }

  # Y axis breaks and labels - can be inherited from cyto_plot
  if (!is(axes_text[[2]], "list")) {
    if (.all_na(axes_text[[2]])) {
      # NA == TRUE returns NA not T/F
    } else if (axes_text[[2]] == TRUE) {
      if (length(channels) == 2) {
        lims <- list(ylim)
        names(lims) <- channels[2]
        axes_text[[2]] <- .cyto_plot_axes_text(fr_list,
          channels = channels[2],
          axes_trans = axes_trans,
          axes_range = lims,
          axes_limits = axes_limits
        )[[1]]
      } else {
        axes_text[[2]] <- NA
      }
    }
  }

  # Turn off y axis labels for stacked overlays
  if (!.all_na(overlay) &
    density_stack != 0 &
    length(channels) == 1) {
    axes_text <- list(axes_text[[1]], FALSE)
  }

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

  # AXES LABELS - missing replaced - NA removed
  axes_labels <- .cyto_plot_axes_label(x,
    channels = channels,
    xlab = xlab,
    ylab = ylab,
    density_modal = density_modal
  )
  xlab <- axes_labels[[1]]
  ylab <- axes_labels[[2]]

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

  # TITLE - missing replaced - NA removed
  title <- .cyto_plot_title(x,
    channels = channels,
    overlay = overlay,
    title = title
  )

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

  # Set plot margins - set par("mar")
  .cyto_plot_margins(c(list(x), overlay),
    legend = legend,
    legend_text = legend_text,
    legend_text_size = legend_text_size,
    title = title,
    axes_text = axes_text,
    margins = margins
  )

  # PLOT CONSTRUCTION ----------------------------------------------------------

  # Plot
  graphics::plot(1,
    type = "n",
    axes = FALSE,
    xlim = xlim,
    ylim = ylim,
    xlab = "",
    ylab = "",
    bty = "n"
  )

  # X AXIS - TRANSFORMED
  if (is(axes_text[[1]], "list")) {
    # MINOR TICKS
    mnr_ind <- which(as.character(axes_text[[1]]$label) == "")
    axis(1,
      at = axes_text[[1]]$at[mnr_ind],
      labels = axes_text[[1]]$label[mnr_ind],
      tck = -0.015
    )

    # MAJOR TICKS - MUST BE >2% XRANGE FROM ZERO
    mjr_ind <- which(as.character(axes_text[[1]]$label) != "")
    mjr <- list(
      "at" = axes_text[[1]]$at[mjr_ind],
      "label" = axes_text[[1]]$label[mjr_ind]
    )
    # Zero included on plot
    if (any(as.character(mjr$label) == "0")) {
      zero <- which(as.character(mjr$label) == "0")
      zero_break <- mjr$at[zero]
      zero_buffer <- c(
        zero_break - 0.02 * (xlim[2] - xlim[1]),
        zero_break + 0.02 * (xlim[2] - xlim[1])
      )
      mjr_ind <- c(
        zero,
        which(mjr$at < zero_buffer[1] |
          mjr$at > zero_buffer[2])
      )
    } else {
      mjr_ind <- seq_len(length(mjr$label))
    }

    axis(1,
      at = mjr$at[mjr_ind],
      labels = mjr$label[mjr_ind],
      font.axis = axes_text_font,
      col.axis = axes_text_col,
      cex.axis = axes_text_size,
      tck = -0.03
    )
    # X AXIS - UNTRANSFORMED
  } else if (.all_na(axes_text[[1]])) {
    axis(1,
      font.axis = axes_text_font,
      col.axis = axes_text_col,
      cex.axis = axes_text_size,
      tck = -0.03
    )
  }

  # Y AXIS - TRANSFORMED
  if (is(axes_text[[2]], "list")) {
    # MINOR TICKS
    mnr_ind <- which(as.character(axes_text[[2]]$label) == "")
    axis(2,
      at = axes_text[[2]]$at[mnr_ind],
      labels = axes_text[[2]]$label[mnr_ind],
      tck = -0.015
    )
    # MAJOR TICKS - MUST BE >2% yrange FROM ZERO
    mjr_ind <- which(as.character(axes_text[[2]]$label) != "")
    mjr <- list(
      "at" = axes_text[[2]]$at[mjr_ind],
      "label" = axes_text[[2]]$label[mjr_ind]
    )

    # Zero included on plot
    if (any(as.character(mjr$label) == "0")) {
      zero <- which(as.character(mjr$label) == "0")
      zero_break <- mjr$at[zero]
      zero_buffer <- c(
        zero_break - 0.02 * (ylim[2] - ylim[1]),
        zero_break + 0.02 * (ylim[2] - ylim[1])
      )
      mjr_ind <- c(
        zero,
        which(mjr$at < zero_buffer[1] |
          mjr$at > zero_buffer[2])
      )
    } else {
      mjr_ind <- seq_len(length(mjr$label))
    }

    axis(2,
      at = mjr$at[mjr_ind],
      labels = mjr$label[mjr_ind],
      font.axis = axes_text_font,
      col.axis = axes_text_col,
      cex.axis = axes_text_size,
      tck = -0.03
    )
    # Y AXIS - LINEAR
  } else if (.all_na(axes_text[[2]])) {
    axis(2,
      font.axis = axes_text_font,
      col.axis = axes_text_col,
      cex.axis = axes_text_size,
      tck = -0.03
    )
  }

  # BORDER
  box(
    which = "plot",
    lty = border_line_type,
    lwd = border_line_width,
    col = border_line_col
  )


  # BORDER_FILL
  if (border_fill != "white") {
    rect(par("usr")[1], par("usr")[3], par("usr")[2], par("usr")[4],
      col = adjustcolor(border_fill, border_fill_alpha),
      border = NA
    )
  }

  # TITLE
  if (!.all_na(title)) {
    title(
      main = title,
      cex.main = title_text_size,
      col.main = title_text_col,
      font.main = title_text_font
    )
  }

  # XLAB - position labels closer if axes text is missing
  if (!.all_na(xlab)) {
    if (is(axes_text[[1]], "list")) {
      title(
        xlab = xlab,
        font.lab = axes_label_text_font,
        col.lab = axes_label_text_col,
        cex.lab = axes_label_text_size
      )
    } else if (.all_na(axes_text[[1]])) {
      title(
        xlab = xlab,
        font.lab = axes_label_text_font,
        col.lab = axes_label_text_col,
        cex.lab = axes_label_text_size
      )
    } else if (axes_text[[1]] == FALSE) {
      title(
        xlab = xlab,
        font.lab = axes_label_text_font,
        col.lab = axes_label_text_col,
        cex.lab = axes_label_text_size,
        mgp = c(2, 0, 0)
      )
    }
  }

  # YLAB - position labels closer if axes text is missing
  if (!.all_na(ylab)) {
    if (is(axes_text[[2]], "list")) {
      title(
        ylab = ylab,
        font.lab = axes_label_text_font,
        col.lab = axes_label_text_col,
        cex.lab = axes_label_text_size
      )
    } else if (.all_na(axes_text[[2]])) {
      title(
        ylab = ylab,
        font.lab = axes_label_text_font,
        col.lab = axes_label_text_col,
        cex.lab = axes_label_text_size
      )
    } else if (axes_text[[2]] == FALSE) {
      title(
        ylab = ylab,
        font.lab = axes_label_text_font,
        col.lab = axes_label_text_col,
        cex.lab = axes_label_text_size,
        mgp = c(2, 0, 0)
      )
    }
  }

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

  # LEGEND - FALSE/"fill"/"line"
  if (legend != FALSE) {
    .cyto_plot_legend(fr_list,
      channels = channels,
      legend = legend,
      legend_text = legend_text,
      legend_text_font = legend_text_font,
      legend_text_size = legend_text_size,
      legend_text_col = legend_text_col,
      legend_line_type = legend_line_type,
      legend_line_width = legend_line_width,
      legend_line_col = legend_line_col,
      legend_box_fill = legend_box_fill,
      legend_point_col = legend_point_col,
      density_cols = density_cols,
      density_fill = density_fill,
      density_fill_alpha = density_fill_alpha,
      density_line_type = density_line_type,
      density_line_width = density_line_width,
      density_line_col = density_line_col,
      point_shape = point_shape,
      point_size = point_size,
      point_col_scale = point_col_scale,
      point_cols = point_cols,
      point_col = point_col,
      point_col_alpha = point_col_alpha
    )
  }
}

#' @noRd
#' @export
cyto_plot_empty.list <- function(x,
                                 channels,
                                 axes_trans = NA,
                                 gate = NA,
                                 xlim = NA,
                                 ylim = NA,
                                 axes_limits = "auto",
                                 title,
                                 xlab,
                                 ylab,
                                 margins = NULL,
                                 density_modal = TRUE,
                                 density_smooth = 1.5,
                                 density_stack = 0.5,
                                 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,
                                 axes_limits_buffer = 0.03,
                                 axes_text = c(TRUE, TRUE),
                                 axes_text_font = 1,
                                 axes_text_size = 1,
                                 axes_text_col = "black",
                                 axes_label_text_font = 1,
                                 axes_label_text_size = 1.1,
                                 axes_label_text_col = "black",
                                 title_text_font = 2,
                                 title_text_size = 1.1,
                                 title_text_col = "black",
                                 border_line_type = 1,
                                 border_line_width = 1,
                                 border_line_col = "black",
                                 border_fill = "white",
                                 border_fill_alpha = 1,
                                 legend = FALSE,
                                 legend_text,
                                 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,
                                 ...) {

  # CHECKS ---------------------------------------------------------------------

  # LIST OF FLOWFRAMES
  if (!all(LAPPLY(x, is, "flowFrame"))) {
    stop("'x' must be a list of flowFrame objects.")
  }

  # OVERLAY
  if (length(x) > 1) {
    overlay <- x[seq(2, length(x), 1)]
  } else {
    overlay <- NA
  }

  # X
  x <- x[[1]]

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

  # ARGUMENT LIST
  args <- .args_list()

  # CALL FLOWFRAME METHOD ------------------------------------------------------

  # CYTO_PLOT_EMPTY ARGUMENTS
  ARGS <- formalArgs("cyto_plot_empty.flowFrame")

  # CALL FLOWFRAME METHOD
  do.call("cyto_plot_empty.flowFrame", args[names(args) %in% ARGS])
}

## CYTO_PLOT_NEW ---------------------------------------------------------------

#' Open new graphics device for cyto_plot
#'
#' \code{cyto_plot_new} is used internally by cyto_plot to open an
#' OS-specific interactive garphics device to facilitate gate drawing. Mac users
#' will need to install \href{https://www.xquartz.org/}{XQuartz} for this
#' functionality.
#'
#' @param popup logical indicating whether a popup graphics device should be
#'   opened, set to TRUE by default.
#' @param ... additional arguments passed to
#'   \code{\link[grDevices:dev]{dev.new}}:
#'
#' @importFrom grDevices dev.cur dev.new
#'
#' @examples
#' \dontrun{
#' # Open platform-specific graphics device
#' cyto_plot_new()
#' }
#'
#' @author Dillon Hammill, \email{Dillon.Hammill@anu.edu.au}
#'
#' @export
cyto_plot_new <- function(popup = TRUE, ...){
  # Null graphics device -> RStudioGD
  if(dev.cur() == 1) {
    dev.new()
  }
  # Open popup window - either windows/X11/xquartz
  if(popup == TRUE & interactive() & getOption("CytoExploreR_interactive")){
    if(.Platform$OS.type == "windows"){
      suppressWarnings(dev.new(...))
    }else if (.Platform$OS.type == "unix") {
      if (Sys.info()["sysname"] == "Linux") {
        # Cairo needed for semi-transparency
        suppressWarnings(dev.new(type = "cairo", ...))
      }else if(Sys.info()["sysname"] == "Darwin"){
        suppressWarnings(dev.new(...))
      }
    }
  }
}

## CYTO_PLOT_RESET -------------------------------------------------------------

#' Reset all cyto_plot related settings
#'
#' @author Dillon Hammill (Dillon.Hammill@anu.edu.au)
#'
#' @importFrom grDevices dev.off dev.cur
#' @export
cyto_plot_reset <- function() {

  # Signals args called to cyto_plot - check if call is made twice
  options("cyto_plot_call" = NULL)

  # Signals if plots match in flowSet method
  options("cyto_plot_match" = NULL)

  # Create custom theme for cyto_plot
  options("cyto_plot_theme" = NULL)

  # Signal cyto_plot_save method has been called
  options("cyto_plot_save" = FALSE)

  # Signal which cyto_plot method has been called
  options("cyto_plot_method" = NULL)

  # Signal if a custom plot is being contructed - require cyto_plot_complete
  options("cyto_plot_custom" = FALSE)

  # Signal when cyto_plot_grid method is being called
  options("cyto_plot_grid" = FALSE)

  # Signal previous call to cyto_plot (same plot?)
  options("cyto_plot_call" = NULL)

  # Save label co-ordinates as list
  options("cyto_plot_label_coords" = NULL)
  
  # Turn off graphics device
  if(dev.cur() != 1){
    dev.off()
  }
  
  invisible(NULL)
}

## CYTO_PLOT_RECORD ------------------------------------------------------------

#' Record an existing cyto_plot
#'
#' \code{cyto_plot_record} will record an existing plot such that it can be
#' saved to an R object for future reference.
#'
#' @importFrom grDevices recordPlot
#'
#' @author Dillon Hammill (Dillon.Hammill@anu.edu.au)
#' 
#' @examples 
#' \dontrun{
#' 
#' # Load CytoExploreRData to acces data
#' library(CytoExploreRData)
#' 
#' # Activation flowSet
#' fs <- Activation
#' 
#' # Construct cyto_plot
#' cyto_plot(fs[[1]],
#'           channels = c("FSC-A", "SSC-A"))
#'           
#' # Record plot and save to object called p
#' p <- cyto_plot_record()
#' 
#' # Calling p will bring back the recorded plot
#' p
#' 
#' }
#'
#' @export
cyto_plot_record <- function(){
  recordPlot()
}

## CYTO_PLOT_SAVE --------------------------------------------------------------

#' Save High Resolution cyto_plot Images
#'
#' @param save_as name of the file to which the plot should be saved (including
#'   the file extension). Supported file formats include png, tiff, jpeg, svg
#'   and pdf.
#' @param width numeric indicating the width of exported plot in \code{units},
#'   set to 7 by default for image with width of 7 inches.
#' @param height numeric indicating the height of the exported plot in
#'   \code{units}, set to 7 by default for image with height of 7 inches.
#' @param units units to be used to set plot size, can be either pixels
#'   (\code{px}), inches (\code{inches}), centimetres (\code{cm}) or millimetres
#'   (\code{mm}). Set to \code{"in"} by default. Units cannot be altered for
#'   \code{svg} and \code{pdf} graphics devices.
#' @param res resolution in ppi, set to 300 by default.
#' @param multiple logical indicating whether multiple pages should be saved to
#'   separate numbered files, set to \code{TRUE} by default.
#' @param layout a vector or matrix defining the custom layout of the plot to be
#'   created using `cyto_plot_layout`, set to NULL by default to use standard
#'   `cyto_plot` layout. Custom layouts are required when making multiple
#'   `cyto_plot` calls in the same image.
#' @param ... additional arguments for the appropriate \code{png()},
#'   \code{tiff()}, \code{jpeg()}, \code{svg()} or \code{pdf} graphics devices.
#'
#' @importFrom tools file_ext file_path_sans_ext
#' @importFrom grDevices png tiff jpeg pdf svg
#'
#' @author Dillon Hammill (Dillon.Hammill@anu.edu.au)
#'
#' @examples
#' \dontrun{
#' library(CytoExploreRData)
#'
#' # Load samples into GatingSet
#' fs <- Activation
#' gs <- GatingSet(fs)
#'
#' # Apply compensation
#' gs <- cyto_compensate(gs)
#'
#' # Transform fluorescent channels
#' gs <- cyto_transform(gs)
#'
#' # Apply gatingTemplate
#' cyto_gatingTemplate_apply(gs, Activation_gatingTemplate)
#'
#' # Save png image of gating scheme after plotting
#' cyto_plot_save("Gating-Scheme.png",
#'   width = 20,
#'   height = 16
#' )
#' cyto_plot_gating_scheme(gs[[1]])
#'
#' # Save multiple pages to the same pdf file
#' cyto_plot_save("CD4-T-Cells.pdf",
#'   height = 8,
#'   width = 16,
#'   multiple = TRUE
#' )
#' cyto_plot(gs,
#'   parent = "CD4 T Cells",
#'   alias = "",
#'   channels = c("Alexa Fluor 647-A", "7-AAD-A"),
#'   layout = c(1, 2)
#' )
#' }
#' @seealso \code{\link[grDevices:cairo]{cairo}}
#' @seealso \code{\link[grDevices:png]{png}}
#'
#' @export
cyto_plot_save <- function(save_as,
                           width = 7,
                           height = 7,
                           units = "in",
                           res = 300,
                           multiple = FALSE,
                           layout = NULL,
                           ...) {

  # File missing extension
  if (file_ext(save_as) == "") {
    # Modify file name to export png by default
    save_as <- paste0(save_as, ".png")
  }

  # Save separate pages to separate number files
  if (multiple == TRUE & file_ext(save_as) != "pdf") {
    save_as <- paste0(
      file_path_sans_ext(save_as),
      "%03d", ".",
      file_ext(save_as)
    )
  }

  # PNG DEVICE
  if (file_ext(save_as) == "png") {
    png(
      filename = save_as,
      width = width,
      height = height,
      units = units,
      res = res,
      ...
    )
  # TIFF DEVICE
  } else if (file_ext(save_as) == "tiff") {
    tiff(
      filename = save_as,
      width = width,
      height = height,
      units = units,
      res = res,
      ...
    )
  # JPEG DEVICE
  } else if (file_ext(save_as) == "jpeg") {
    jpeg(
      filename = save_as,
      width = width,
      height = height,
      units = units,
      res = res,
      ...
    )
  # PDF DEVICE
  } else if (file_ext(save_as) == "pdf") {
    pdf(
      file = save_as,
      width = width,
      height = height,
      onefile = multiple,
      ...
    )
  } else if(file_ext(save_as) == "svg") {
    svg(
      filename = save_as,
      width = width,
      height = height,
      ...
    )
  } else {
    stop(paste("Can't save file to", file_ext(save_as), "format."))
  }

  # Set global option to notify cyto_plot when dev.off() is required for saving
  options("cyto_plot_save" = TRUE)
  
  # CYTO_PLOT_CUSTOM
  if(!is.null(layout)){
    cyto_plot_custom(layout = layout)
  }
  
}

## CYTO_PLOT_SAVE_RESET --------------------------------------------------------

#' Revert unwanted cyto_plot_save call
#'
#' @importFrom grDevices dev.off
#'
#' @examples
#'
#' # Unwanted cyto_plot_save call
#' cyto_plot_save("Mistake.png")
#'
#' # Revert unwanted cyto_plot_save call
#' cyto_plot_save_reset()
#' 
#' @author Dillon Hammill (Dillon.Hammill@anu.edu.au)
#'
#' @export
cyto_plot_save_reset <- function() {
  # TURN OFF GLOBAL OPTION
  options("cyto_plot_save" = FALSE)
  # TURN OFF GRAPHICS DEVICE
  dev.off()
}

## CYTO_PLOT_LAYOUT ------------------------------------------------------------

#' Set Panel Layout for cyto_plot
#'
#' \code{cyto_plot_layout()} sets the panel layout dimensions for combining
#' different types of cyto_plot plots. Make a call to \code{cyto_plot_layout()}
#' prior to making multiple calls to \code{cyto_plot()}.
#'
#' @param layout either a vector of the form c(nrow, ncol) defining the
#'   dimensions of the plot or a matrix defining a more sophisticated layout
#'   (see \code{\link[graphics]{layout}}). Vectors can optionally contain a
#'   third element to indicate whether plots should be placed in row (1) or
#'   column (2) order, set to row order by default.
#'
#' @importFrom graphics par layout
#'
#' @author Dillon Hammill (Dillon.Hammill@anu.edu.au)
#'
#' @examples
#' library(CytoExploreRData)
#'
#' # Load samples into GatingSet
#' fs <- Activation
#' gs <- GatingSet(fs)
#'
#' # Apply compensation
#' gs <- compensate(gs, fs[[1]]@description$SPILL)
#'
#' # Transform fluorescent channels
#' trans <- estimateLogicle(gs[[4]], cyto_fluor_channels(gs))
#' gs <- transform(gs, trans)
#'
#' # Apply gatingTemplate
#' gt <- Activation_gatingTemplate
#' gt_gating(gt, gs)
#'
#' # Set out plot layout
#' cyto_plot_layout(c(1,2))
#'
#' # Add 2D plot
#' cyto_plot(gs[[4]],
#'   parent = "CD4 T Cells",
#'   alias = "",
#'   channels = c("Alexa Fluor 647-A", "7-AAD-A"),
#'   layout = FALSE
#' )
#'
#' # Add 1D plot
#' cyto_plot(gs,
#'   parent = "CD4 T Cells",
#'   alias = "",
#'   channels = "7-AAD-A",
#'   density_stack = 0.6,
#'   layout = FALSE
#' )
#' @export
cyto_plot_layout <- function(layout = NULL) {

  # MESSAGE
  if(is.null(layout)){
    stop("Supply either a vector or matrix to construct a custom layout.")
  }
  
  # MATRIX
  if(is.matrix(layout)){
    layout(layout)
  # VECTOR  
  }else{
    # ROW ORDER
    if(length(layout) == 2){
      layout <- c(layout, 1)
    }
    # ROWS
    if (layout[3] == 1) {
      par(mfrow = c(layout[1], layout[2]))
    # COLUMNS
    } else if (layout[3] == 2) {
      par(mfcol = c(layout[1], layout[2]))
    }
  }

}

## CYTO_PLOT_CUSTOM ------------------------------------------------------------

#' Create custom cyto_plot
#'
#' Signal to \code{cyto_plot} that a custom plot is being created to ensure that
#' plots are appropraitely saved with \code{cyto_plot_save}.
#' \code{cyto_plot_custom} calls must be made before \code{cyto_plo_save} calls
#' and \code{cyto_plot} calls should be followed by a call to
#' \code{cyto_plot_complete} to indicate when the plot is complete and should be
#' saved.
#'
#' @param layout either a vector of the form c(nrow, ncol) defining the
#'   dimensions of the plot or a matrix defining a more sophisticated layout
#'   (see \code{\link[graphics]{layout}}). Vectors can optionally contain a
#'   third element to indicate whether plots should be placed in row (1) or
#'   column (2) order, set to row order by default.
#'   
#' @importFrom graphics par
#'   
#' @author Dillon Hammill (Dillon.Hammill@anu.edu.au)
#'
#' @examples
#' \dontrun{
#' library(CytoExploreRData)
#'
#' # Activation flowSet
#' fs <- Activation
#' 
#' # Save plot
#' cyto_plot_save("Test.png",
#'                height = 7,
#'                width = 14)
#'
#' # Create custom plot - 1D & 2D plot panels
#' cyto_plot_custom(layout = c(1,2))
#' cyto_plot(fs[[32]],
#'           channels = "FSC-A")
#' cyto_plot(fs[[32]],
#'           channels = c("FSC-A","SSC-A"))
#'
#' # Signal plot is complete and save
#' cyto_plot_complete()
#' }
#' @export
cyto_plot_custom <- function(layout = NULL){
  
  # Tell CytoExploreR - cyto_plot_save and layout resets
  options("cyto_plot_custom" = TRUE)
  
  # Set plot method
  options("cyto_plot_method" = "custom")
  
  # Set layout
  cyto_plot_layout(layout)
  
}

## CYTO_PLOT_COMPLETE ----------------------------------------------------------

#' Indicate Completion of Custom cyto_plot Layout for Saving
#'
#' @param layout either a vector of the form c(nrow, ncol) defining the
#'   dimensions of the plot or a matrix defining a more sophisticated layout
#'   (see \code{\link[graphics]{layout}}). Vectors can optionally contain a
#'   third element to indicate whether plots should be placed in row (1) or
#'   column (2) order, set to row order by default.
#'
#' @importFrom graphics par
#'
#' @author Dillon Hammill (Dillon.Hammill@anu.edu.au)
#'
#' @examples
#' library(CytoExploreRData)
#'
#' # Load samples into GatingSet
#' fs <- Activation
#' gs <- GatingSet(fs)
#'
#' # Apply compensation
#' gs <- compensate(gs, fs[[1]]@description$SPILL)
#'
#' # Transform fluorescent channels
#' trans <- estimateLogicle(gs[[4]], cyto_fluor_channels(gs))
#' gs <- transform(gs, trans)
#'
#' # Apply gatingTemplate
#' gt <- Activation_gatingTemplate
#' gt_gating(gt, gs)
#'
#' # Save custom plot
#' cyto_plot_save("Custom.png",
#'   height = 8,
#'   width = 16
#' )
#'
#' # Set out plot layout
#' cyto_plot_layout(c(1,2))
#'
#' # Add 2D plot
#' cyto_plot(gs[[4]],
#'   parent = "CD4 T Cells",
#'   alias = "",
#'   channels = c("Alexa Fluor 647-A", "7-AAD-A"),
#'   layout = FALSE
#' )
#'
#' # Add 1D plot
#' cyto_plot(gs,
#'   parent = "CD4 T Cells",
#'   alias = "",
#'   channels = "7-AAD-A",
#'   density_stack = 0.6,
#'   layout = FALSE
#' )
#'
#' # Signal that the plot is complete
#' cyto_plot_complete()
#' @export
cyto_plot_complete <- function(layout = NULL) {

  # Close graphics device (not RStudioGD or X11)
  if(!names(dev.cur()) %in% c("RStudioGD", 
                              "windows", 
                              "X11", 
                              "x11", 
                              "quartz")){
    dev.off()
  }

  # Reset cyto_plot_custom
  options("cyto_plot_custom" = FALSE)
  
  # Reset plot method
  options("cyto_plot_method" = NULL)
  
  # Turn off saving
  options("cyto_plot_save" = FALSE)
  
  # Reset layout - 1 x 1
  if(is.null(layout)){
    par("mfrow" = c(1,1))
    par("mfcol" = c(1,1))
  # Reset layout as supplied
  }else{
    # MATRIX
    if(is.matrix(layout)){
      layout(layout)
    # VECTOR
    }else{
      if(length(layout) == 2){
        layout <- c(layout, 1)
      }
    }
    # ROWS
    if (layout[3] == 1) {
      par(mfrow = c(layout[1], layout[2]))
    # COLUMNS
    } else if (layout[3] == 2) {
      par(mfcol = c(layout[1], layout[2]))
    }
  }
  
}

## CYTO_PLOT_THEME -------------------------------------------------------------

#' Create custom themes for cyto_plot
#'
#' \code{cyto_plot_theme} provides an easy way to alter the theme used by
#' \code{cyto_plot}. By calling \code{cyto_plot_theme} prior to plotting,
#' subsequent plots will inherit these arguments so there is no need to supply
#' them manually each time. For a complete list of supported arguments see
#' \code{cyto_plot_theme_args}.
#'
#' @param ... arguments supported by cyto_plot_theme.
#'
#' @examples
#' # Make all plots have a black background
#' cyto_plot_theme(border_fill = "black")
#'
#' # Black ground with custom colour scale for points and purple gates
#' cyto_plot_theme(
#'   border_fill = "black",
#'   point_col_scale = c(
#'     "cyan",
#'     "green",
#'     "yellow",
#'     "orange",
#'     "red",
#'     "darkred"
#'   ),
#'   gate_line_col = "magenta"
#' )
#'
#' # Reset to default setting
#' cyto_plot_theme_reset()
#' @author Dillon Hammill (Dillon.Hammill@anu.edu.au)
#'
#' @export
cyto_plot_theme <- function(...) {

  # cyto_plot will pull down these arguments

  # Arguments as named list
  args <- list(...)

  # Empty list set theme to NULL
  if (length(args) == 0) {
    args <- NULL
  } else {
    # Check supplied arguments are supported.
    if (!all(names(args) %in% cyto_plot_theme_args())) {
      lapply(names(args), function(x) {
        if (!x %in% cyto_plot_theme_args()) {
          message(paste(x, "is not a supported argument for cyto_plot_theme."))
        }
      })
    }

    # Restrict list to supported arguments only
    args <- args[names(args) %in% cyto_plot_theme_args()]
  }

  # Assign arguments to cyto_plot_theme option
  options("cyto_plot_theme" = args)
}

## CYTO_PLOT_THEME_RESET -------------------------------------------------------

#' Reset cyto_plot_theme to default settings
#'
#' @author Dillon Hammill (Dillon.Hammill@anu.edu.au)
#'
#' @export
cyto_plot_theme_reset <- function() {

  # Set cyto_plot_theme option to NULL
  options("cyto_plot_theme" = NULL)
}

## .CYTO_PLOT_THEME_ARGS -------------------------------------------------------

#' Get supported cyto_plot_theme arguments
#'
#' @return vector of argument names supported by cyto_plot_theme.
#'
#' @examples
#' cyto_plot_theme_args()
#' @author Dillon Hammill (Dillon.Hammill@anu.edu.au)
#'
#' @export
cyto_plot_theme_args <- function() {
  c(
    "axes_limits",
    "axes_limits_buffer",
    "margins",
    "popup",
    "density_modal",
    "density_smooth",
    "density_stack",
    "density_cols",
    "density_fill_alpha",
    "density_line_type",
    "density_line_width",
    "density_line_col",
    "axes_text",
    "axes_text_font",
    "axes_text_size",
    "axes_text_col",
    "axes_label_text_font",
    "axes_label_text_size",
    "axes_label_text_col",
    "title_text_font",
    "title_text_size",
    "title_text_col",
    "legend",
    "legend_text_font",
    "legend_text_size",
    "legend_text_col",
    "legend_line_col",
    "legend_box_fill",
    "gate_line_type",
    "gate_line_width",
    "gate_line_col",
    "gate_fill",
    "gate_fill_alpha",
    "label",
    "label_position",
    "label_text_font",
    "label_text_size",
    "label_text_col",
    "label_fill",
    "label_fill_alpha",
    "border_fill",
    "border_fill_alpha",
    "border_line_type",
    "border_line_width",
    "border_line_col",
    "point_shape",
    "point_size",
    "point_col_scale",
    "point_cols",
    "point_col_alpha",
    "contour_lines",
    "contour_line_type",
    "contour_line_width",
    "contour_line_col",
    "contour_line_alpha"
  )
}
DillonHammill/CytoExploreR documentation built on March 2, 2023, 7:34 a.m.