R/plot_funs.R

In DiscreteFWER: FWER-Based Multiple Testing Procedures with Adaptation for Discrete Tests

#' @name hist.DiscreteFWER
#' 
#' @title
#' Histogram of Raw P-Values
#' 
#' @description
#' Computes a histogram of the raw p-values of a `DiscreteFWER` object.
#' 
#' @param x          an object of class `DiscreteFWER`.
#' @param breaks     as in [`graphics::hist()`]; here, the Friedman-Diaconis
#'                   algorithm (`"FD"`) is used as default.
#' @param mode       single character string specifying for which $p$-values the
#'                   histogram is to be generated; must either be `"raw"` or
#'                   `"selected"`.
#' @param ...        further arguments to [`graphics::hist()`] or
#'                   [`graphics::plot.histogram()`], respectively.
#' 
#' @details
#' If `x` does not contain results of a selection approach, a warning is issued
#' and a histogram of the raw p-values is drawn. 
#' 
#' @return
#' An object of class `histogram`.
#'
#' @template example
#' @examples 
#' # d-Holm with critical values; using test results object
#' DHolm_crit <- DHolm(test_results, critical_values = TRUE)
#' hist(DHolm_crit)
#'
#' @importFrom graphics hist
#' @export
hist.DiscreteFWER <- function(
    x,
    breaks = "FD",
    mode = c("raw", "selected"),
    ...
) {
  if(!("DiscreteFWER" %in% class(x)))
    stop("'x' must be an object of class DiscreteFWER")
  
  mode <- match.arg(tolower(mode), c("raw", "selected"))
  
  # determine if selection was performed
  select <- exists('Select', x)
  select_mode <- mode == "selected"
  # warn if histogram is for selected p-values that were never computed
  if(select_mode && !select)
    warning("No selected p-values present in object. Using raw p-values.")
  
  # get values of ...-arguments
  lst <- list(...)
  
  # p-value type
  pv_type <- ifelse(
    test = select_mode, 
    yes = ifelse(select, "Selected and Scaled", "Raw"),
    no = "Raw"
  )
  
  # labels
  if(!exists('main', where = lst))
    lst$main <- paste("Histogram of", pv_type, "P-Values")
  if(!exists('xlab', where = lst))
    lst$xlab <- paste(pv_type, "P-Values")
  
  # add 'breaks' and 'plot' to 'lst' for 'do.call'
  lst$breaks <- breaks
  lst$x <- if(mode == "selected" && select)
    x$Select$Scaled else
      x$Data$Raw_pvalues
  
  # call 'hist'
  fig <- do.call(hist, lst)
  
  # add input data variable name to result
  fig$xname <- deparse(substitute(x))
  
  # output
  if(ifelse(exists('plot', lst), lst$plot, TRUE))
    return(invisible(fig)) else
      return(fig)
}


#' @name plot.DiscreteFWER
#' @title Plot Method for `DiscreteFWER` objects
#'
#' @description
#' Plots raw p-values of a `DiscreteFWER` object and highlights rejected and
#' accepted p-values. If calculated, the critical values are plotted, too.
#'
#' @param x          object of class `DiscreteFWER`.
#' @param col        numeric or character vector of length 3 indicating the
#'                   colours of the \enumerate{
#'                     \item rejected p-values
#'                     \item accepted p-values
#'                     \item critical values (if present).
#'                   }
#' @param pch        numeric or character vector of length 3 indicating the
#'                   point characters of the \enumerate{
#'                     \item rejected p-values
#'                     \item accepted p-values
#'                     \item critical values (if present and `type_crit`
#'                           is a plot type like `'p'`, `'b'` etc.).
#'                   }
#' @param lwd        numeric vector of length 3 indicating the thickness of the
#'                   points and lines; defaults to current `par()$lwd` setting.
#' @param type_crit  1-character string giving the type of plot desired for the
#'                   critical values (e.g.: `'p'`, `'l'` etc; see [`plot()`]).
#' @param legend     if `NULL`, no legend is plotted; otherwise expecting a
#'                   character string like `"topleft"` etc. or a numeric vector
#'                   of two elements indicating (x, y) coordinates.
#' @param cex        numeric vector of length 3 indicating the size of point
#'                   characters or lines of the \enumerate{
#'                     \item rejected p-values
#'                     \item accepted p-values
#'                     \item critical values (if present).
#'                   }
#'                   defaults to current `par()$cex` setting.
#' @param ...        further arguments to [`plot.default()`].
#' 
#' @return
#' A plot is created, but no value is returned.
#' 
#' @template example
#' @examples 
#' DBonf_fast <- DBonferroni(raw_pvalues, pCDFlist)
#' DBonf_crit <- DBonferroni(test_results, critical_values = TRUE)
#' DHolm_fast <- DHolm(test_results)
#' DHolm_crit <- DHolm(raw_pvalues, pCDFlist, critical_values = TRUE)
#' 
#' plot(DBonf_fast)
#' plot(DBonf_crit, xlim = c(1, 5), ylim = c(0, 0.4))
#' plot(DHolm_fast, col = c(2, 4), pch = c(2, 3), lwd = c(2, 2), 
#'      legend = "topleft", xlim = c(1, 5), ylim = c(0, 0.4))
#' plot(DHolm_crit, col = c(2, 4, 1), pch = c(1, 1, 4), lwd = c(1, 1, 2), 
#'      type_crit = 'o', legend = c(1, 0.4), lty = 1, xlim = c(1, 5), 
#'      ylim = c(0, 0.4))
#' 
#' @importFrom graphics plot lines points par
#' @importFrom checkmate assert assert_string check_character check_choice check_numeric
#' @export
plot.DiscreteFWER <- function(
  x,
  col = c(2, 4, 1),
  pch = c(20, 20, 17),
  lwd = rep(par()$lwd, 3),
  cex = rep(par()$cex, 3),
  type_crit = 'b',
  legend = NULL,
  ...
) {
  if(!("DiscreteFWER" %in% class(x)))
    stop("'x' must be an object of class DiscreteFWER")
  
  # make sure 'col' includes integers or colour strings
  assert(
    check_character(col, min.len = 1, max.len = 3, null.ok = TRUE),
    check_numeric(col, min.len = 1, max.len = 3, null.ok = TRUE)
  )
  
  # make sure 'pch' includes integers or colour strings
  assert(
    check_character(col, min.len = 1, max.len = 3, null.ok = TRUE),
    check_numeric(col, upper = 25, min.len = 1, max.len = 3, null.ok = TRUE)
  )
  
  # make sure 'type.crit' is a single character string
  assert_string(type_crit, null.ok = TRUE)
  
  # make sure 'legend' is a single string or a numerical vector of two values
  assert(
    check_choice(
      x = legend, 
      choices = c("bottomright", "bottom", "bottomleft", "left",
                  "topleft", "top", "topright", "right", "center"),
      null.ok = TRUE
    ),
    check_numeric(legend, len = 2, any.missing = FALSE)
  )
  
  # determine number of tests, selections and rejections
  n <- length(x$Data$Raw_pvalues)
  select <- exists('Select', x)
  m <- if(select) x$Select$Number else n
  
  # replace NAs in plot parameters with current par() settings
  col[is.na(col)] <- par()$col
  pch[is.na(pch)] <- par()$pch
  lwd[is.na(lwd)] <- par()$lwd
  cex[is.na(cex)] <- par()$cex
  
  # replicate shorter plot parameter vectors to avoid errors
  len <- 2L + as.integer(exists('Critical_values', where = x))
  col <- if(!is.null(col)) rep_len(col, len) else c( 2,  4,  1)[seq_len(len)]
  pch <- if(!is.null(pch)) rep_len(pch, len) else c(20, 20, 17)[seq_len(len)]
  lwd <- if(!is.null(lwd)) rep_len(lwd, len) else rep(par()$lwd, len)
  cex <- if(!is.null(cex)) rep_len(cex, len) else rep(par()$cex, len)
  
  # get values of ...-arguments
  lst <- list(...)
  
  # labels
  if(!exists('main', where = lst)) lst$main <- x$Data$Method
  if(!exists('xlab', where = lst)) {
    lst$xlab <- "Index"
    if(select) lst$xlab <- paste(lst$xlab, "(selected)")
  }
  if(!exists('ylab', where = lst)) {
    if(exists('Critical_values', where = x))
      lst$ylab <- "Sorted raw p-values / Critical values" else
        lst$ylab <- "Sorted raw p-values"
    if(select) lst$ylab <- paste(lst$ylab, "(selected, scaled)")
  }
  
  # start plotting with empty area
  lst$x <- if(select) x$Select$Scaled else x$Data$Raw_pvalues
  lst$col <- "NA"
  do.call(plot, lst)
  
  # plot critical values (if present and plotting is requested by the user)
  if(exists('Critical_values', where = x) && type_crit != 'n'){
    lines(x$Critical_values, col = col[3], lwd = lwd[3], pch = pch[3],
          type = type_crit, cex = cex[3], ...)
  }
  
  # plot accepted p-values
  if(select) {
    idx <- which(!(x$Select$Pvalues %in% x$Rejected))
    if(length(idx)) {
      y_acc <- sort(x$Select$Scaled[idx])
      x_acc <- (m - length(y_acc) + 1):m
    }
  } else {
    idx <- setdiff(seq_len(n), x$Indices)
    if(length(idx)) {
      y_acc <- sort(x$Data$Raw_pvalues[idx])
      x_acc <- setdiff(seq_len(n), seq_len(x$Num_rejected))
    }
  }
  if(length(idx))
    points(x_acc, y_acc, col = col[2], pch = pch[2],
           lwd = lwd[2], cex = cex[2], ...)
  
  # plot rejected p-values
  if(x$Num_rejected) {
    y_rej <- if(select) sort(x$Select$Scaled[-idx]) else sort(x$Rejected)
    points(seq_len(x$Num_rejected), y_rej, col = col[1], pch = pch[1],
           lwd = lwd[1], cex = cex[1], ...)
  }
  
  # plot legend
  if(!is.null(legend)) {
    idx <- 1:2
    lt <- rep(0, 3)
    if(exists('Critical_values', x) && type_crit != "n") {
      idx <- c(idx, 3)
      if(!(type_crit %in% c("p", "o", "b"))) pch[3] <- NA
      lt[3] <- if(type_crit %in% c('b', 'l', 'o')) {
        if(exists('lty', where = lst)) lst$lty else 1
      } else 0
    }
    len <- length(legend)
    if(len <= 2 & len >= 1) {
      if(len == 1){
        x <- legend
        y <- NULL
      }else{
        x <- legend[1]
        y <- legend[2]
      }
      legend(x, y, c("Rejected", "Accepted", "Critical values")[idx], col = c(col[idx], "darkgrey"), pch = pch[idx], lty = lt[idx], lwd = lwd[idx])
    } else warning("Expecting character string or numeric vector of one or two elements for creating a legend")
  }
}