R/dlvPlot.R

Defines functions print.dlvPlot dlvPlot dlvTheme

Documented in dlvPlot dlvTheme print.dlvPlot

### XKCD styled plots
#require(xkcd)
#vignette("xkcd-intro")

### Histogram with dots
# http://stackoverflow.com/questions/16216312/how-to-plot-stacked-point-histograms-in-ggplot2-in-r


### Note: this is necessary to prevent Rcmd CHECK from throwing a note;
### otherwise it think these variables weren't defined yet.
# utils::globalVariables(c("y_density", "yMaxFromY"));

### Theme used for the plots

#' @rdname dlvPlot
#' @export dlvTheme
dlvTheme <- function(base_size = 11,
                     base_family = "",
                     ...) {
  ggplot2::"%+replace%"(ggplot2::theme_bw(base_size = base_size, base_family = base_family),
    ggplot2::theme(# axis.title        = element_blank(),
      # axis.text         = element_text(colour="#000000", size = rel(0.8)),
      # axis.ticks        = element_line(colour = "black"),
      # axis.title        = element_blank(),
      # legend.text       = element_text(size = rel(0.6)),
      # legend.key        = element_rect(colour = "grey80"),
      # legend.position   = "top",
      # legend.direction  = "horizontal",
      # legend.key.size   = unit(6, "mm"),
      # panel.background  = element_rect(fill = "white", colour = NA),
      # panel.border      = element_rect(fill = NA, colour = "grey50"),
      # panel.grid.major  = element_line(colour = "grey90", size = 0.2),
      # panel.grid.minor  = element_line(colour = "grey98", size = 0.5),
      # panel.margin      = unit(c(.5), "cm"),
      ...))
}



#' dlvPlot
#'
#' The dlvPlot function produces a dot-violin-line plot, and dlvTheme is the
#' default theme.
#'
#' This function creates Dot Violin Line plots. One image says more than a
#' thousand words; I suggest you run the example :-)
#'
#' @aliases dlvPlot dlvTheme
#' @param dat The dataframe containing x, y and z.
#' @param x Character value with the name of the predictor ('independent')
#' variable, must refer to a categorical variable (i.e. a factor).
#' @param y Character value with the name of the critetion ('dependent')
#' variable, must refer to a continuous variable (i.e. a numeric vector).
#' @param z Character value with the name of the moderator variable, must refer
#' to a categorical variable (i.e. a factor).
#' @param conf.level Confidence of confidence intervals.
#' @param jitter Logical value (i.e. TRUE or FALSE) whether or not to jitter
#' individual datapoints. Note that jitter cannot be combined with posDodge
#' (see below).
#' @param binnedDots Logical value indicating whether to use binning to display
#' the dots. Overrides jitter and dotsize.
#' @param binwidth Numeric value indicating how broadly to bin (larger values
#' is more binning, i.e. combining more dots into one big dot).
#' @param error Character value: "none", "lines" or "whiskers"; indicates
#' whether to show the confidence interval as lines with (whiskers) or without
#' (lines) horizontal whiskers or not at all (none)
#' @param dotsize Character value: "density" or "normal"; when "density", the
#' size of each dot corresponds to the density of the distribution at that
#' point.
#' @param singleColor The color to use when drawing one or more univariate
#' distributions (i.e. when no \code{z} is specified.
#' @param comparisonColors The colors to use when a \code{z} is specified. This
#' should be at least as many colors as \code{z} has levels. By default,
#' palette \code{Set1} from `RColorBrewer` is used.
#' @param densityDotBaseSize Numeric value indicating base size of dots when
#' their size corresponds to the density (bigger = larger dots).
#' @param normalDotBaseSize Numeric value indicating base size of dots when
#' their size is fixed (bigger = larger dots).
#' @param violinAlpha Numeric value indicating alpha value of violin layer (0 =
#' completely transparent, 1 = completely opaque).
#' @param dotAlpha Numeric value indicating alpha value of dot layer (0 =
#' completely transparent, 1 = completely opaque).
#' @param lineAlpha Numeric value indicating alpha value of the confidence
#' interval line layer (0 = completely transparent, 1 = completely opaque).
#' @param connectingLineAlpha Numeric value indicating alpha value of the layer
#' with the lines connecting the means (0 = completely transparent, 1 =
#' completely opaque).
#' @param meanDotSize Numeric value indicating the size of the dot used to
#' indicate the mean in the line layer.
#' @param posDodge Numeric value indicating the distance to dodge positions (0
#' for complete overlap).
#' @param errorType If the error is shown using lines, this argument indicates
#' Whether the errorbars should show the confidence interval
#' (\code{errorType='ci'}), the standard errors (\code{errorType='se'}), or
#' both (\code{errorType='both'}). In this last case, the standard error will
#' be wider than the confidence interval.
#' @param outputFile A file to which to save the plot.
#' @param outputWidth,outputHeight Width and height of saved plot (specified in
#' centimeters by default, see \code{ggsaveParams}).
#' @param ggsaveParams Parameters to pass to ggsave when saving the plot.
#' @param base_size,base_family,...  Passed on to the ggplot theme_grey()
#' function.
#' @return The behavior of this function depends on the arguments.
#'
#' If no x and z are provided and y is a character value, dlvPlot produces a
#' univariate plot for the numerical y variable.
#'
#' If no x and z are provided, and y is c character vector, dlvPlot produces
#' multiple Univariate plots, with variable names determining categories on
#' x-axis and with numerical y variables on y-axis
#'
#' If both x and y are a character value, and no z is provided, dlvPlot
#' produces a bivariate plot where factor x determines categories on x-axis
#' with numerical variable y on the y-axis (roughly a line plot with a single
#' line)
#'
#' Finally, if x, y and z are each a character value, dlvPlot produces
#' multivariate plot where factor x determines categories on x-axis, factor z
#' determines the different lines, and with the numerical y variable on the
#' y-axis
#'
#' An object is returned with the following elements: \item{dat.raw}{Raw
#' datafile provided when calling dlvPlot} \item{dat}{Transformed (long)
#' datafile dlvPlot uses} \item{descr}{Dataframe with extracted descriptives
#' used to plot the mean and confidence intervals} \item{yRange}{The range of
#' the Y variable used to construct the plot} \item{plot}{The plot itself}
#' @keywords utilities
#' @rdname dlvPlot
#' @examples
#'
#' ### Note: the 'not run' is simply because running takes a lot of time,
#' ###       but these examples are all safe to run!
#' \dontrun{
#' ### Create simple dataset
#' dat <- data.frame(x1 = factor(rep(c(0,1), 20)),
#'                   x2 = factor(c(rep(0, 20), rep(1, 20))),
#'                   y=rep(c(4,5), 20) + rnorm(40));
#' ### Generate a simple dlvPlot of y
#' dlvPlot(dat, y='y');
#' ### Now add a predictor
#' dlvPlot(dat, x='x1', y='y');
#' ### And finally also a moderator:
#' dlvPlot(dat, x='x1', y='y', z='x2');
#' ### The number of datapoints might be a bit clearer if we jitter
#' dlvPlot(dat, x='x1', y='y', z='x2', jitter=TRUE);
#' ### Although just dodging the density-sized dots might work better
#' dlvPlot(dat, x='x1', y='y', z='x2', posDodge=.3);
#' }
#'
#' @export dlvPlot
dlvPlot <- function(dat,
                    x = NULL,
                    y,
                    z = NULL,
                    conf.level = .95,
                    jitter = "FALSE",
                    binnedDots = TRUE,
                    binwidth = NULL,
                    error = "lines",
                    dotsize = "density",
                    singleColor = "black",
                    comparisonColors = rosetta::opts$get('dlvPlotCompCols'),
                    densityDotBaseSize = 3,
                    normalDotBaseSize = 1,
                    violinAlpha = .2,
                    dotAlpha = .4,
                    lineAlpha = 1,
                    connectingLineAlpha = 1,
                    meanDotSize = 5,
                    posDodge = 0.2,
                    errorType = "both",
                    outputFile = NULL,
                    outputWidth = 10,
                    outputHeight = 10,
                    ggsaveParams = list(units = 'cm',
                                        dpi = 300,
                                        type = "cairo")) {
  ### This function constructs a dot-line-violin plot.

  ### Create object to return results
  res <- list()


  ### Store data
  res$dat.raw <- dat

  ### Remove irrelevant variables
  res$dat <- dat <- data.frame(dat[, c(x, y, z)])


  ### Remove incomplete cases
  res$dat <- data.frame(dat[stats::complete.cases(dat),])


  ### Replace names again
  names(dat) <- names(res$dat) <- c(x, y, z)


  if (!is.null(x) & !(is.factor(dat[, x]))) {
    warning(
      "Error: variable x (', x,') is not of type factor. X must be a categorical ",
      "variable with a limited number of categories. If this is the case, but it's ",
      "simply stored as a numerical vector, use the 'factor' function to convert ",
      "it (see '?factor'). Trying to convert x myself now."
    )

    res$dat[[x]] <- factor(res$dat[[x]])

  }

  if (!is.null(z) & !(is.factor(dat[, z]))) {
    warning(
      "Error: variable z (', z,') is not of type factor. Z must be a categorical ",
      "variable with a limited number of categories. If this is the case, but it's ",
      "simply stored as a numerical vector, use the 'factor' function to convert ",
      "it (see '?factor'). Trying to convert z myself now."
    )

    res$dat[[z]] <- factor(res$dat[[z]])

  }

  if (is.null(x)) {
    ### We have no predictor variable - this means we construct univariate plots.

    ### Now check whether we have to construct one or several.
    if (length(y) == 1) {
      ###############################################################
      ### Constructing one univariate plot                        ###
      ###############################################################

      ### Store variable name in dataframe
      if (is.null(res$dat$variable)) {
        res$dat$variable <- y

        xVarName <- 'variable'

      }
      else {
        res$dat$variable_dlvPlot <- y

        xVarName <- 'variable_dlvPlot'

      }

      ### Store density at y value
      dens <- stats::density(res$dat[[y]], na.rm = TRUE)

      res$dat$y_density <-
        stats::approx(dens$x, dens$y, xout = res$dat[[y]])$y

      ### Multiply so that points at average density have size 1
      res$dat$y_density <- res$dat$y_density *
        (densityDotBaseSize / mean(res$dat$y_density, na.rm = TRUE))


      ### Construct dataframe with confidence interval info
      n <- nrow(res$dat)

      mean <- mean(res$dat[, y])

      sd <- stats::sd(res$dat[, y])

      se <- sd / sqrt(nrow(res$dat))

      criticalValue <- stats::qt(1 - ((1 - conf.level) / 2), df = n - 1)

      ci.lo <- mean - criticalValue * se

      ci.hi <- mean + criticalValue * se

      meanMinSE <- mean - se

      meanPlusSE <- mean + se

      res$descr <- data.frame(
        y = y,
        n = n,
        mean = mean,
        sd = sd,
        se = se,
        ci.lo = ci.lo,
        ci.hi = ci.hi,
        meanMinSE = meanMinSE,
        meanPlusSE = meanPlusSE
      )

      res$yRange = c(min(res$dat[[y]][!is.na(res$dat[[y]])]),
                     max(res$dat[[y]][!is.na(res$dat[[y]])]))


      ### Generate plot
      res$plot <- ggplot2::ggplot(data = res$dat,
                                  ggplot2::aes_string(x = xVarName, y =
                                                        y))

      res$plot <- res$plot +
        dlvTheme()

      res$plot <- res$plot +
        ggplot2::geom_violin(
          trim = FALSE,
          alpha = violinAlpha,
          fill = singleColor,
          linetype = "blank"
        )

      if (jitter) {
        res$plot <- res$plot +
          ggplot2::geom_jitter(
            position = ggplot2::position_jitter(width = .1, height = .01),
            alpha = dotAlpha
          )

      }
      else {
        if (binnedDots) {
          tempBinwidth <-
            ifelse(is.null(binwidth),
                   (res$yRange[2] - res$yRange[1]) / 30,
                   binwidth)

          res$plot <- res$plot +
            ggplot2::geom_dotplot(
              alpha = dotAlpha,
              show.legend = FALSE,
              binaxis = "y",
              binwidth = tempBinwidth,
              dotsize = normalDotBaseSize,
              stackdir = "center",
              color = singleColor,
              fill = singleColor,
              position = ggplot2::position_dodge(width =
                                                   posDodge)
            )

        }
        else if (dotsize == "density") {
          res$plot <- res$plot +
            ggplot2::geom_point(
              ggplot2::aes_string(size = 'y_density'),
              color = singleColor,
              alpha = dotAlpha,
              show.legend = FALSE
            )

        }
        else {
          res$plot <- res$plot +
            ggplot2::geom_point(alpha = dotAlpha, dotsize = normalDotBaseSize)

        }
      }
      if (error == "lines") {
        if (errorType == "ci") {
          res$plot <- res$plot +
            ggplot2::geom_pointrange(
              data = res$descr,
              ggplot2::aes_string(
                x = 'y',
                y = 'mean',
                ymin = 'ci.lo',
                ymax = 'ci.hi'
              ),
              color = singleColor,
              size = 1,
              alpha = lineAlpha
            )

        } else if (errorType == "se") {
          res$plot <- res$plot +
            ggplot2::geom_pointrange(
              data = res$descr,
              ggplot2::aes_string(
                x = 'y',
                y = 'mean',
                ymin = 'meanMinSE',
                ymax = 'meanPlusSE'
              ),
              color = singleColor,
              size = 1,
              alpha = lineAlpha
            )

        } else if (errorType == "both") {
          res$plot <- res$plot +
            ggplot2::geom_pointrange(
              data = res$descr,
              ggplot2::aes_string(
                x = 'y',
                y = 'mean',
                ymin = 'ci.lo',
                ymax = 'ci.hi'
              ),
              size = 1,
              alpha = lineAlpha
            )

          res$plot <- res$plot +
            ggplot2::geom_errorbar(
              data = res$descr,
              ggplot2::aes_string(
                x = 'y',
                ymin = 'meanMinSE',
                ymax = 'meanPlusSE'
              ),
              color = singleColor,
              size = 2,
              alpha = lineAlpha,
              width = 0,
              inherit.aes = FALSE
            )

        }
      }
      else if (error == "whiskers") {
        res$plot <- res$plot +
          ggplot2::geom_errorbar(
            data = res$descr,
            ggplot2::aes_string(
              x = 'y',
              y = 'mean',
              ymin = 'ci.lo',
              ymax = 'ci.hi'
            ),
            color = singleColor,
            size = 1,
            width = .1,
            alpha = lineAlpha
          )

      }
      res$plot <- res$plot +
        ggplot2::geom_point(
          data = res$descr,
          color = singleColor,
          ggplot2::aes_string(x = 'y', y = 'mean'),
          size = meanDotSize,
          alpha = lineAlpha
        )


    }
    else {
      ###############################################################
      ### Constructing several univariate plots                   ###
      ###############################################################

      ### Apparently, we have to construct several plots.
      ### First generate a dataframe where the variables names
      ### are stored in another variable that we can use to
      ### make categories on the x axis

      ### Store original dataframe
      res$dat.original <- res$dat

      res$dat <- data.frame()

      ### Create empty descriptives dataframe
      res$descr <- data.frame()


      ### Loop through original dataframe and construct new one
      for (currentVar in y) {
        tempDf <- data.frame(y = res$dat.original[, currentVar])

        tempDf$x <-  currentVar

        ### Store density for at y value
        dens <- stats::density(tempDf$y, na.rm = TRUE)

        tempDf$y_density <-
          stats::approx(dens$x, dens$y, xout = tempDf$y)$y

        tempDf$y_density <- tempDf$y_density *
          (densityDotBaseSize / mean(tempDf$y_density, na.rm = TRUE))

        ### Store y values and name of y variable in res$dat dataframe
        res$dat <- rbind(res$dat, tempDf)

        ### Get mean and confidence interval for descriptives table
        n <- nrow(tempDf)

        mean <- mean(tempDf$y)

        sd <- stats::sd(tempDf$y)

        se <- sd / sqrt(nrow(tempDf))

        criticalValue <- stats::qt(1 - ((1 - conf.level) / 2), df = n -
                                     1)

        ci.lo <- mean - criticalValue * se

        ci.hi <- mean + criticalValue * se

        meanMinSE <- mean - se

        meanPlusSE <- mean + se

        ### Add descriptives
        res$descr <- rbind(
          res$descr,
          data.frame(
            y = currentVar,
            n = n,
            mean = mean,
            sd = sd,
            se = se,
            ci.lo = ci.lo,
            ci.hi = ci.hi,
            meanMinSE = meanMinSE,
            meanPlusSE = meanPlusSE
          )
        )

      }

      res$yRange = c(min(res$dat[['y']][!is.na(res$dat[['y']])]),
                     max(res$dat[['y']][!is.na(res$dat[['y']])]))


      res$plot <- ggplot2::ggplot(data = res$dat, ggplot2::aes(x = x, y = y))

      res$plot <- res$plot + dlvTheme()

      res$plot <- res$plot +
        ggplot2::geom_violin(
          trim = FALSE,
          alpha = violinAlpha,
          fill = singleColor,
          linetype = "blank"
        )

      if (jitter) {
        res$plot <- res$plot +
          ggplot2::geom_jitter(
            position = ggplot2::position_jitter(width = .1, height = .01),
            color = singleColor,
            alpha = dotAlpha
          )

      }
      else {
        if (binnedDots) {
          tempBinwidth <-
            ifelse(is.null(binwidth),
                   (res$yRange[2] - res$yRange[1]) / 30,
                   binwidth)

          res$plot <- res$plot +
            ggplot2::geom_dotplot(
              alpha = dotAlpha,
              show.legend = FALSE,
              binaxis = "y",
              binwidth = tempBinwidth,
              dotsize = normalDotBaseSize,
              color = singleColor,
              fill = singleColor,
              stackdir = "center",
              position = ggplot2::position_dodge(width = posDodge)
            )

        }
        else if (dotsize == "density") {
          res$plot <- res$plot +
            ggplot2::geom_point(
              ggplot2::aes_string(size = 'y_density'),
              color = singleColor,
              alpha = dotAlpha,
              show.legend = FALSE
            )

        }
        else {
          res$plot <- res$plot +
            ggplot2::geom_point(alpha = dotAlpha,
                                color = singleColor,
                                dotsize = normalDotBaseSize)

        }
      }
      if (error == "lines") {
        if (errorType == "ci") {
          res$plot <- res$plot +
            ggplot2::geom_pointrange(
              data = res$descr,
              ggplot2::aes_string(
                x = 'x',
                y = 'mean',
                ymin = 'ci.lo',
                ymax = 'ci.hi'
              ),
              color = singleColor,
              size = 1,
              alpha = lineAlpha
            )

        } else if (errorType == "se") {
          res$plot <- res$plot +
            ggplot2::geom_pointrange(
              data = res$descr,
              ggplot2::aes_string(
                x = y,
                y = 'mean',
                ymin = 'meanMinSE',
                ymax = 'meanPlusSE'
              ),
              color = singleColor,
              size = 1,
              alpha = lineAlpha
            )

        } else if (errorType == "both") {
          res$plot <- res$plot +
            ggplot2::geom_pointrange(
              data = res$descr,
              ggplot2::aes_string(
                x = y,
                y = 'mean',
                ymin = 'ci.lo',
                ymax = 'ci.hi'
              ),
              color = singleColor,
              size = 1,
              alpha = lineAlpha
            )

          res$plot <- res$plot +
            ggplot2::geom_errorbar(
              data = res$descr,
              ggplot2::aes_string(
                x = y,
                y = 'mean',
                ymin = 'meanMinSE',
                ymax = 'meanPlusSE'
              ),
              color = singleColor,
              size = 2,
              alpha = lineAlpha,
              width = 0
            )

        }
      }
      else if (error == "whiskers") {
        res$plot <- res$plot +
          ggplot2::geom_errorbar(
            data = res$descr,
            ggplot2::aes(
              x = y,
              y = mean,
              ymin = ci.lo,
              ymax = ci.hi
            ),
            color = singleColor,
            size = 1,
            width = .1,
            alpha = lineAlpha
          )

      }
      res$plot <- res$plot +
        ggplot2::geom_point(
          data = res$descr,
          ggplot2::aes(x = y, y = mean),
          color = singleColor,
          size = meanDotSize,
          alpha = lineAlpha
        )


    }
  }
  else {
    ### We have a predictor variable, so check whether we have a moderator
    if (is.null(z)) {
      ###############################################################
      ### Constructing multivariate plot without moderator        ###
      ###############################################################

      ### Construct dataframe with confidence interval info
      res$descr <-
        plyr::ddply(
          .data = res$dat,
          .variables = c(x),
          .fun = function (dat, conf.level) {
            dat <- dat[stats::complete.cases(dat),]

            n <- nrow(dat)

            mean <- mean(dat[, y])

            sd <- stats::sd(dat[, y])

            se <- sd / sqrt(nrow(dat))

            criticalValue <-
              stats::qt(1 - ((1 - conf.level) / 2), df = n - 1)

            ci.lo <- mean - criticalValue * se

            ci.hi <- mean + criticalValue * se

            meanMinSE <- mean - se

            meanPlusSE <- mean + se

            rslt <- data.frame(
              x = dat[1, x],
              y = y,
              n = nrow(dat),
              mean = mean,
              sd = sd,
              se = se,
              ci.lo = ci.lo,
              ci.hi = ci.hi,
              meanMinSE = meanMinSE,
              meanPlusSE = meanPlusSE,
              numericX = as.numeric(dat[1, x])
            )

            rslt <- rslt[stats::complete.cases(rslt),]

            return(rslt)

          },
          conf.level = conf.level
        )

      ### Store densities; must be done for each group (value of x)
      ### separately
      res$dat <- plyr::ddply(
        .data = res$dat,
        .variables = c(x),
        .fun = function (dat) {
          ### Store density for at y value
          dens <-
            stats::density(dat[[y]], na.rm = TRUE)

          dat$y_density <-
            stats::approx(dens$x, dens$y, xout = dat[[y]])$y

          ### Multiply with densityDotBaseSize / mean (this allows
          ### control over the size of the dots)
          dat$y_density <- dat$y_density *
            (densityDotBaseSize / mean(dat$y_density, na.rm =
                                         TRUE))

          return(dat)

        }
      )


      res$yRange = c(min(res$dat[[y]][!is.na(res$dat[[y]])]),
                     max(res$dat[[y]][!is.na(res$dat[[y]])]))


      res$plot <- ggplot2::ggplot(data = res$dat,
                                  ggplot2::aes_string(x = x, y = y))

      res$plot <- res$plot + dlvTheme()

      res$plot <- res$plot +
        ggplot2::geom_violin(
          trim = FALSE,
          alpha = violinAlpha,
          fill = singleColor,
          linetype = "blank",
          position = ggplot2::position_dodge(width =
                                               posDodge)
        )

      if (jitter) {
        res$plot <- res$plot +
          ggplot2::geom_jitter(
            position = ggplot2::position_jitter(width = .1, height = .01),
            color = singleColor,
            alpha = dotAlpha
          )

      }
      else {
        if (binnedDots) {
          tempBinwidth <-
            ifelse(is.null(binwidth),
                   (res$yRange[2] - res$yRange[1]) / 30,
                   binwidth)

          res$plot <- res$plot +
            ggplot2::geom_dotplot(
              alpha = dotAlpha,
              show.legend = FALSE,
              binaxis = "y",
              binwidth = tempBinwidth,
              dotsize = normalDotBaseSize,
              color = singleColor,
              fill = singleColor,
              stackdir = "center",
              position = ggplot2::position_dodge(width =
                                                   posDodge)
            )

        }
        else if (dotsize == "density") {
          res$plot <- res$plot +
            ggplot2::geom_point(
              ggplot2::aes_string(size = 'y_density'),
              color = singleColor,
              alpha = dotAlpha,
              show.legend = FALSE
            )

        }
        else {
          res$plot <- res$plot +
            ggplot2::geom_point(alpha = dotAlpha,
                                color = singleColor,
                                dotsize = normalDotBaseSize)

        }
      }
      if (error == "lines") {
        if (errorType == "ci") {
          res$plot <- res$plot +
            ggplot2::geom_pointrange(
              data = res$descr,
              ggplot2::aes_string(
                x = 'x',
                y = 'mean',
                ymin = 'ci.lo',
                ymax = 'ci.hi'
              ),
              size = 1,
              alpha = lineAlpha,
              color = singleColor,
              inherit.aes = FALSE
            )

        } else if (errorType == "se") {
          res$plot <- res$plot +
            ggplot2::geom_pointrange(
              data = res$descr,
              ggplot2::aes_string(
                x = 'x',
                y = 'mean',
                ymin = 'meanMinSE',
                ymax = 'meanPlusSE'
              ),
              size = 1,
              alpha = lineAlpha,
              color = singleColor,
              inherit.aes = FALSE
            )

        } else if (errorType == "both") {
          res$plot <- res$plot +
            ggplot2::geom_pointrange(
              data = res$descr,
              ggplot2::aes_string(
                x = 'x',
                y = 'mean',
                ymin = 'ci.lo',
                ymax = 'ci.hi'
              ),
              size = 1,
              alpha = lineAlpha,
              color = singleColor,
              inherit.aes = FALSE
            )

          res$plot <- res$plot +
            ggplot2::geom_errorbar(
              data = res$descr,
              ggplot2::aes_string(x = 'x',
                                  ymin =
                                    'meanMinSE',
                                  ymax = 'meanPlusSE'),
              size = 2,
              alpha = lineAlpha,
              width = 0,
              color = singleColor,
              inherit.aes = FALSE
            )

        }
      }
      else if (error == "whiskers") {
        res$plot <- res$plot +
          ggplot2::geom_errorbar(
          data = res$descr,
          ggplot2::aes_string(
            x = 'x',
            y = 'mean',
            ymin = 'ci.lo',
            ymax = 'ci.hi'
          ),
          size = 1,
          width = .1,
          alpha = lineAlpha,
          color = singleColor,
          inherit.aes = FALSE
        )

      }
      res$plot <- res$plot + ggplot2::stat_summary(
        fun = mean,
        geom = "point",
        size = meanDotSize,
        color = singleColor,
        alpha = lineAlpha
      )

      res$plot <- res$plot + ggplot2::geom_line(
        data = res$descr,
        ggplot2::aes_string(x = 'x', y = 'mean', group =
                     NA),
        color = singleColor,
        size = 1,
        alpha = connectingLineAlpha
      )

    }
    else {
      ###############################################################
      ### Constructing multivariate plot with moderator           ###
      ###############################################################

      ### Construct dataframe with confidence interval info
      res$descr <- plyr::ddply(
        .data = res$dat,
        .variables = c(x, z),
        .fun = function (dat, conf.level) {
          dat <- dat[stats::complete.cases(dat),]

          n <- nrow(dat)

          mean <- mean(dat[, y])

          sd <- stats::sd(dat[, y])

          se <- sd / sqrt(nrow(dat))

          criticalValue <-
            stats::qt(1 - ((1 - conf.level) / 2), df = n - 1)

          ci.lo <- mean - criticalValue * se

          ci.hi <- mean + criticalValue * se

          meanMinSE <- mean - se

          meanPlusSE <- mean + se

          res <- data.frame(
            x = dat[1, x],
            y = y,
            z = dat[1, z],
            n = nrow(dat),
            mean = mean,
            sd = sd,
            se = se,
            ci.lo = ci.lo,
            ci.hi = ci.hi,
            meanMinSE = meanMinSE,
            meanPlusSE = meanPlusSE,
            numericX = as.numeric(dat[1, x])
          )

          return(res[stats::complete.cases(res),])

        },
        conf.level = conf.level
      )

      ### Store densities; must be done for each group (value of x)
      ### separately
      res$dat <- plyr::ddply(
        .data = res$dat,
        .variables = c(x, z),
        .fun = function (dat) {
          ### Store density for at y value
          dens <- stats::density(dat[[y]], na.rm = TRUE)

          dat$y_density <-
            stats::approx(dens$x, dens$y, xout = dat[[y]])$y

          ### Multiply with densityDotBaseSize / mean (this allows
          ### control over the size of the dots)
          dat$y_density <- dat$y_density *
            (densityDotBaseSize / mean(dat$y_density, na.rm =
                                         TRUE))

          return(dat)

        }
      )


      res$yRange = c(min(res$dat[[y]][!is.na(res$dat[[y]])]),
                     max(res$dat[[y]][!is.na(res$dat[[y]])]))


      res$plot <-
        ggplot2::ggplot(data = res$dat,
                        ggplot2::aes_string(
                           x = x,
                           y = y,
                           z = z,
                           colour = z,
                           fill = z,
                           group = paste0(x, ":", z)
                         ))

      res$plot <- res$plot + dlvTheme()

      res$plot <-
        res$plot + ggplot2::geom_violin(
          data = res$dat,
          ggplot2::aes_string(fill = z),
          alpha = violinAlpha,
          trim = FALSE,
          linetype = "blank",
          position = ggplot2::position_dodge(width =
                                      posDodge)
        )

      if (jitter) {
        res$plot <-
          res$plot + ggplot2::geom_jitter(position = ggplot2::position_jitter(width = .1, height =
                                                              .01),
                                 alpha = dotAlpha)

      }
      else {
        if (binnedDots) {
          tempBinwidth <- ifelse(is.null(binwidth),
                                 (res$yRange[2] - res$yRange[1]) / 30,
                                 binwidth)

          res$plot <-
            res$plot + ggplot2::geom_dotplot(
              alpha = dotAlpha,
              show.legend = FALSE,
              ggplot2::aes_string(fill = z),
              binaxis = "y",
              binwidth = tempBinwidth,
              dotsize = normalDotBaseSize,
              stackdir = "center",
              position = ggplot2::position_dodge(width =
                                          posDodge)
            )

        }
        else if (dotsize == "density") {
          res$plot <- res$plot + ggplot2::geom_point(
            ggplot2::aes_string(size = 'y_density'),
            alpha = dotAlpha,
            show.legend = FALSE,
            position = ggplot2::position_dodge(width =
                                        posDodge)
          )

        }
        else {
          res$plot <-
            res$plot + ggplot2::geom_point(
              alpha = dotAlpha,
              dotsize = normalDotBaseSize,
              position = ggplot2::position_dodge(width =
                                          posDodge)
            )

        }
      }
      if (error == "lines") {
        if (errorType == "ci") {
          res$plot <- res$plot + ggplot2::geom_pointrange(
            data = res$descr,
            ggplot2::aes_string(
              x = 'x',
              y = 'mean',
              ymin = 'ci.lo',
              ymax = 'ci.hi',
              group = 'z',
              color = 'z'
            ),
            size = 1,
            alpha = lineAlpha,
            position = ggplot2::position_dodge(width = posDodge),
            inherit.aes = FALSE
          )

        } else if (errorType == "se") {
          res$plot <- res$plot + ggplot2::geom_pointrange(
            data = res$descr,
            ggplot2::aes_string(
              x = 'x',
              y = 'mean',
              ymin = 'meanMinSE',
              ymax = 'meanPlusSE',
              group = 'z',
              color = 'z'
            ),
            size = 1,
            alpha = lineAlpha,
            position = ggplot2::position_dodge(width =
                                        posDodge),
            inherit.aes = FALSE
          )

        } else if (errorType == "both") {
          res$plot <- res$plot + ggplot2::geom_pointrange(
            data = res$descr,
            ggplot2::aes_string(
              x = 'x',
              y = 'mean',
              ymin = 'ci.lo',
              ymax = 'ci.hi',
              group = 'z',
              color = 'z'
            ),
            size = 1,
            alpha = lineAlpha,
            position = ggplot2::position_dodge(width =
                                        posDodge),
            inherit.aes = FALSE
          )

          res$plot <- res$plot + ggplot2::geom_errorbar(
            data = res$descr,
            ggplot2::aes_string(
              x = 'x',
              ymin = 'meanMinSE',
              ymax = 'meanPlusSE',
              group = 'z',
              color = 'z'
            ),
            size = 2,
            alpha = lineAlpha,
            width = 0,
            position = ggplot2::position_dodge(width =
                                        posDodge),
            inherit.aes = FALSE
          )

        }
      }
      else if (error == "whiskers") {
        res$plot <- res$plot + ggplot2::geom_errorbar(
          data = res$descr,
          ggplot2::aes_string(
            x = 'x',
            ymin = 'ci.lo',
            ymax = 'ci.hi',
            group = 'z',
            color = 'z'
          ),
          size = 1,
          width = .1,
          alpha = lineAlpha,
          position = ggplot2::position_dodge(width =
                                      posDodge),
          inherit.aes = FALSE
        )

      }
      res$plot <-
        res$plot + ggplot2::stat_summary(
          fun = mean,
          geom = "point",
          size = meanDotSize,
          position = ggplot2::position_dodge(width = posDodge)
        )

      res$plot <-
        res$plot + ggplot2::geom_line(
          data = res$descr,
          ggplot2::aes_string(x = 'x', y = 'mean', group = 'z'),
          size = 1,
          alpha = connectingLineAlpha,
          position = ggplot2::position_dodge(width = posDodge)
        )

      ### Add fill and color scales
      res$plot <-
        res$plot + ggplot2::scale_fill_manual(values = comparisonColors,
                                     name = z,
                                     labels = sort(unique(res$descr$z))) +
        ggplot2::scale_color_manual(values = comparisonColors,
                           name = z,
                           labels = sort(unique(res$descr$z)))
    }
  }

  assign('yMaxFromY', max(res$plot$data[, res$plot$labels$y]), envir = res$plot$plot_env)

  res$plot <- res$plot + ggplot2::aes_string(ymax = 'yMaxFromY')


  ### Set class of result
  class(res) <- c('dlvPlot')


  ### Save to a file, if desired
  if (!is.null(outputFile)) {
    ggsaveParameters <- c(
      list(
        filename = outputFile,
        plot = res$plot,
        width = outputWidth,
        height = outputHeight
      ),
      ggsaveParams
    )

    do.call(ggplot2::ggsave, ggsaveParameters)

  }

  ### Return result
  return(res)

}

#' @rdname dlvPlot
#' @method print dlvPlot
#' @export
print.dlvPlot <- function(x, ...) {
  print(x$plot, ...)

  invisible()

}

Try the rosetta package in your browser

Any scripts or data that you put into this service are public.

rosetta documentation built on March 7, 2023, 7:40 p.m.