R/shift_function_plot.R

In GRousselet/rogme: Robust Graphical Methods For Group Comparisons

#' Plot percentile bootstrap shift function
#'
#' Plot one or more shift functions generated with \code{\link{shifthd}},
#' \code{\link{shiftdhd}}, \code{\link{shifthd_pbci}} or
#' \code{\link{shiftdhd_pbci}}. Assumes the median was estimated and is the
#' middle value. The function returns a list of ggplot objects, which can be
#' customised using the \href{http://docs.ggplot2.org/current/}{ggplot2}
#' package.
#'
#' Several themes are available:
#' \itemize{
#'   \item Theme 1 uses a minimalist design with the same colour for all quantiles.
#'   \item Theme 2 colour codes the sign of the differences.
#'   \item Theme 3 uses a greyscale gradient to code the quantiles.
#'   }
#'
#' @param data A list of data frames generated by \code{shifthd_pbci} or \code{shiftdhd_pbci}.
#' @param plot_theme One of 3 themes - default is 1.
#' @param symb_col Contour colour of quantile symbol.
#' @param symb_fill Fill colour(s) of quantile symbol. Defaults are "white" for theme 1,
#' c("darkviolet","darkorange2") for theme 2, c("white", "grey") for theme 3.
#' @param symb_size Size of quantile symbol - default = 5.
#' @param symb_shape Shape of the quantile symbol - default = 21 (disc).
#' @param diffint_col Colour of the lines marking the quantile difference intervals.
#' @param diffint_size Size of the lines marking the quantile difference intervals
#'   - default = .5.
#' @param q_line_col Colour of the line joining the quantiles.
#' @param q_line_alpha Alpha of the line joining the quantiles - default = .5.
#' @param q_line_size Size of the line joining the quantiles - default = 1.5.
#' @param theme2_alpha Alpha transparency for theme 2 - default c(0.4, 1)
#' @examples
#' plot_sf(out) # default plot
#' plot_sf(out, plot_theme = 2) # specify theme
#' plist <- plot_sf(out) # output list of ggplot objects
#'
#' # The plots can then be combined using \href{https://cran.r-project.org/web/packages/gridExtra/index.html}{gridExtra} or \href{https://cran.r-project.org/web/packages/cowplot/index.html}{cowplot} - for instance:
#' library(gridExtra)
#' do.call("grid.arrange", c(plist, ncol=2))
#' # To extract one object and for instance change a label:
#' p <- plist[[1]]
#' p + labs(y = "Difference")
#'
#' @export
plot_sf <- function(data = df,
                      plot_theme = 1,
                      symb_col = NULL,
                      symb_fill = NULL,
                      symb_size = 5,
                      symb_shape = 21,
                      diffint_col = NULL,
                      diffint_size = .5,
                      q_line_col = NULL,
                      q_line_alpha = .5,
                      q_line_size = 1.5,
                      theme2_alpha = NULL){
  # check input is a list of data frames
  if(!is.list(data)){
    stop("data must be a list")
  }
  for (pc in 1:length(data)) {
    if(!is.data.frame(data[[pc]])){
      stop("input data list must contain data.frames")
    }
  }
  plist <- vector("list", length(data)) # declare list of plot objects
  for (pc in 1:length(data)) {
    df <- data[[pc]]
    ylim <- max(max(abs(df$ci_upper)),max(abs(df$ci_lower)))
    ylim <- c(-ylim,ylim)
    midpt <- (nrow(df)-1) / 2 + 1
    if(df$q[midpt]!=0.5){
      warning("plot_sf() expects the middle of the quantiles to be the median")
    }
    xintercept <- df[midpt,2] # get median of group 1
    xplot = names(df)[2]
    # -------------------
    # get theme specific formatting
    if (plot_theme == 1){
      if (is.null(symb_col)){
        symb_col <- "#009E73"
      }
      if (is.null(symb_fill)){
        symb_fill <- "white"
      }
      if (is.null(diffint_col)){
        diffint_col <- "#009E73"
      }
      if (is.null(q_line_col)){
        q_line_col <- "#009E73"
      }
    }
    # ------
    if (plot_theme == 2){
      df$sign <- sign(df$difference) # add difference signs to data frame
      df$deco <- c(seq(1,midpt),seq(midpt-1,1)) # add code of quantiles to data frame
      if (is.null(symb_col)){
        symb_col <- "black"
      }
      if (is.null(symb_fill)){
        symb_fill <- c("darkviolet","darkorange2")
        if (length(unique(df$sign)) == 3){
          symb_fill <- c("darkviolet",q_line_col,"darkorange2")
        }
      }
      if (length(unique(df$sign)) == 1){
        if (unique(df$sign) == -1){
          symb_fill <- symb_fill[1]
        } else {
          symb_fill <- symb_fill[2]
        }
      }
      if (is.null(q_line_col)){
        q_line_col <- "grey50"
      }
      if (is.null(theme2_alpha)){
        theme2_alpha <- c(0.4, 1)
      }
    }
    # -----
    if (plot_theme == 3){ # add code of quantiles to data frame
      df$deco <- c(seq(1,midpt),seq(midpt-1,1))
      if (is.null(symb_col)){
        symb_col <- "black"
      }
      if (is.null(symb_fill)){
        symb_fill <- c("white","grey30")
      }
      if (is.null(diffint_col)){
        diffint_col <- "black"
      }
      if (is.null(q_line_col)){
        q_line_col <- "grey50"
      }
    }
    # -------------------
    if (isTRUE(all.equal(df$q, seq(0.1,0.9,0.1)))) {
      lab.x <- paste0("Deciles for ",names(df)[2])
      lab.y <- paste0("Decile differences:\n",names(df)[2]," - ",names(df)[3])
    } else {
      lab.x <- paste0("Quantiles for ",names(df)[2])
      lab.y <- paste0("Quantile differences:\n",names(df)[2]," - ",names(df)[3])
    }
    p <- ggplot(df, aes_string(x = xplot, y = "difference")) +
      # x=0 reference line
      geom_hline(yintercept = 0, linetype = 2, alpha = 0.5) +
      # y=median reference line
      geom_vline(xintercept = xintercept, linetype = 2, alpha = 0.5) +
      xlab(lab.x) +
      ylab(lab.y) +
      theme_bw() +
      theme(axis.text.x = element_text(size=14),
        axis.text.y = element_text(size=14),
        axis.title.x = element_text(size=16,face="bold"),
        axis.title.y = element_text(size=16,face="bold")) +
      scale_y_continuous(limits = ylim)
    #scale_x_continuous(breaks = xbreaks)
    # --------------------
    # apply theme
    if (plot_theme == 1){ # default with one colour
      p <- p +
        # vertical bars for uncertainty intervals
        geom_linerange(aes(ymin = ci_lower, ymax = ci_upper), colour = diffint_col,
          size = diffint_size) +
        # line joining the quantiles
        geom_line(colour = q_line_col, alpha = q_line_alpha, linetype = "solid",
          size = q_line_size) +
        # symbols marking the quantiles
        geom_point(colour = symb_col, size = symb_size, shape = symb_shape, fill = symb_fill)
    }
    if (plot_theme == 2){ # colour code the difference sign
      p <- p +
        # vertical bars for uncertainty intervals
        geom_linerange(aes(ymin = ci_lower, ymax = ci_upper), colour = "white",
          size = diffint_size) +
        geom_linerange(aes(ymin = ci_lower, ymax = ci_upper, colour = factor(sign),
          alpha = factor(deco)), size = diffint_size) +
        scale_color_manual(values = symb_fill, guide = FALSE) +
        scale_alpha_discrete(range = theme2_alpha, guide = FALSE) +
        # line joining the quantiles
        geom_line(colour = q_line_col, alpha = q_line_alpha, linetype = "solid",
          size = q_line_size) +
        # symbols marking the quantiles
        geom_point(colour = "black", fill = "white", size = symb_size, shape = symb_shape) +
        geom_point(aes(fill = factor(sign), alpha = factor(deco)), colour = symb_col,
          size = symb_size, shape = symb_shape) +
        scale_fill_manual(values = symb_fill, guide = FALSE) +
        scale_alpha_discrete(range = theme2_alpha, guide = FALSE)
    }
    if (plot_theme == 3){ # greyscale gradient for the quantiles
      p <- p +
        # vertical bars for uncertainty intervals
        geom_linerange(aes(ymin = ci_lower, ymax = ci_upper), colour = diffint_col,
          size = diffint_size) +
        # line joining the quantiles
        geom_line(colour = q_line_col, alpha = q_line_alpha, linetype = "solid",
          size = q_line_size) +
        # symbols marking the quantiles
        geom_point(aes(fill = deco), colour="black", size = symb_size, shape = symb_shape) +
        scale_fill_gradient(low = symb_fill[1], high = symb_fill[2], guide = FALSE)
    }
    # print(p)
    plist[[pc]] <- p
  }
  suppressMessages(plist)
}