R/sm_forest2.R

In smin95/sesplot: Creating Standalone and Composite Plots in 'ggplot2' for Publications

#' Forest plot
#'
#' @param ...
#' A generic aesthetic parameter across points, lines and error bars. This
#' is optional.
#'
#' @param point.params
#' List of parameters for individual points, such as color, alpha, fill etc
#'
#' @param avgPoint.params
#' List of parameters for the average point, such as color, alpha, fill etc
#'
#' @param err.params
#' List of parameters for the error bar from the average point, such as color, alpha etc
#'
#' @param ref.params
#' List of parameters for the vertical reference line, such as color, alpha etc
#'
#' @param xintercept
#' Location of the vertical reference line along the x coordinate.
#'
#' @param sep_level
#' A numerical value that controls the level of the separation between
#' the individual points and the average point.
#' If it's 0, all of these are clustered together. If it's higher (and more positive),
#' the text annotations will increasingly go below the mean point. Default is set to 2. The values
#' can be negative so that the points can be above the mean point. There is no limit of
#' the range for this argument.
#'
#' @param point_jitter_width
#' A numerical value that determines the degree of the jitter for each point. If its 0,
#' all the points will have no jitter (aligned along the y-axis).
#'
#' @param errorbar_type
#' This argument determines the error bar type.
#' If it is set to 'se' , standard error bar will be shown.
#' If it is set to 'sd', the error bar will display standard deviation.
#' If it is set to 'ci' (default), the error bar will display 95\% confidence interval.
#'
#' @param points
#' If points is set TRUE, individual points are shown. If FALSE,
#' they are not shown.
#'
#' @param refLine
#' If it is set TRUE, the reference line at a specified location along the x-axis is shown.
#' If it is set FALSE, it is not shown.
#'
#' @param borders
#' If the border needs to be displayed, the input should be TRUE.
#' If the border is not needed, the input should be FALSE.
#'
#' @param legends
#' If the legend needs to be displayed, the input should be TRUE.
#' If the legend is not needed, the input should be FALSE.
#'
#' @param seed
#' Random seed
#'
#' @param forget
#' Forget the defaults when list() is called for a specific parameter (ex. point.params).
#' Set to TRUE when when users want to map aesthetics to different groups more flexibly..
#' Set to FALSE by default.
#'
#'
#' @return A forest plot generated using ggplot2
#' @import ggplot2 cowplot Hmisc
#' @importFrom stats sd
#' @importFrom utils modifyList
#' @export
#'
#' @examples
#' library(smplot2)
#' library(ggplot2)
#'
#' day1 = rnorm(20,0,1)
#' day2 = rnorm(20,5,1)
#' day3 = rnorm(20,6,1.5)
#' day4 = rnorm(20,7,2)
#' Subject <- rep(paste0('S',seq(1:20)), 4)
#' Data <- data.frame(Value = matrix(c(day1,day2,day3,day4),ncol=1))
#' Day <- rep(c('Day 1', 'Day 2', 'Day 3', 'Day 4'), each = length(day1))
#' df2 <- cbind(Subject, Data, Day)
#'
#' ggplot(data = df2, aes(x = Value, y = Day, color = Day, fill = Day)) +
#'  sm_forest(sep_level = 2, point_jitter_width = .12,
#'            errorbar_type = 'ci',
#'            point.params = list(alpha=0.2)) +
#'   scale_color_manual(values = sm_palette(4))

sm_forest <- function(...,
                      point.params = list(size=  2.5, alpha = 0.3),
                      avgPoint.params = list(size = 5.5,
                                             shape = 18),
                      err.params = list(color = 'black'),
                      ref.params = list(size = 0.4, color = 'gray80',
                                        linetype='dashed'),
                      xintercept = 0,
                      sep_level = 2,
                      point_jitter_width = 0,
                      errorbar_type = 'ci',
                      points = TRUE,
                      refLine = TRUE,
                      borders = TRUE,
                      legends = FALSE,
                      seed = NULL,
                      forget = FALSE
) {

  if (length(seed)) set.seed(seed)

  if (point_jitter_width == 0) {
    point_jitter_width <- 1e-10
  }

  params <- list(...)

  if (forget == FALSE) {
    point.params0 = list(size=  2.5, alpha = 0.3)
    point.params0  = modifyList(point.params0 , params)
    avgPoint.params0 = list(size = 5.5, shape = 18)
    avgPoint.params0 = modifyList(avgPoint.params0, params)
    err.params0 = list(color = 'black')
    err.params0 = modifyList(err.params0, params)
    ref.params0 = list(size = 0.4, color = 'gray80', linetype='dashed')

    point.params <- modifyList(point.params0, point.params)
    avgPoint.params <- modifyList(avgPoint.params0, avgPoint.params)
    err.params <- modifyList(err.params0, err.params)
    ref.params <- modifyList(ref.params0, ref.params)

  } else if (forget == TRUE){
    point.params <- modifyList(params, point.params)
    avgPoint.params <- modifyList(params, avgPoint.params)
    err.params <- modifyList(params, err.params)
    #ref.params <- modifyList(params, ref.params)
  }



  if (errorbar_type == 'se') {
    errPlot <- do.call('stat_summary',
                       modifyList(list(fun.data = mean_se,
                                       geom = 'linerange'), err.params))
  } else if (errorbar_type == 'sd') {
    errPlot <- do.call('stat_summary',
                       modifyList(list(fun = mean,
                                       fun.min = function(x) mean(x) - sd(x),
                                       fun.max = function(x) mean(x) + sd(x),
                                       geom = 'linerange'),
                                  err.params))
  } else if (errorbar_type == 'ci') {
    errPlot <- do.call('stat_summary',
                       modifyList(list(fun.data = mean_cl_boot,
                                       geom = 'linerange'), err.params))
  } else {
    stop('Wrong input argument for errorbar_type. Please write either "se", "sd" or "ci"')
  }


  position_nudge_vector <- c(-sep_level/10,0)

  refLinePlot <- do.call('geom_vline',
                         modifyList(list(xintercept=xintercept), ref.params))


  pointPlot <- do.call('geom_point',
                       modifyList(list(position = position_jitternudge(jitter.width=point_jitter_width,
                                                                       jitter.height=point_jitter_width,
                                                                       nudge.y = 0,
                                                                       nudge.x = position_nudge_vector[1])),
                                  point.params))

  avgPointPlot <- do.call('stat_summary',
                          modifyList(list(fun = mean,
                                          geom = 'point',
                                          position = position_nudge(y = position_nudge_vector[2])), avgPoint.params))



  if (points == FALSE) {
    pointPlot <- NULL
  }

  if (refLine == FALSE) {
    refLinePlot <- NULL
  }

  list(refLinePlot,pointPlot,avgPointPlot,errPlot,
       sm_hgrid(borders=borders,legends=legends))

}