Merge pull request #590 from crsh/violin-plots

Violin plots

DESCRIPTION

@@ -61,7 +61,7 @@ SystemRequirements: Rendering the document template requires
   such as TinyTeX (>= 0.12; https://yihui.org/tinytex/)
 License: MIT + file LICENSE
 Encoding: UTF-8
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 VignetteBuilder: knitr, R.rsp
 Language: en-US
 Roxygen: list(markdown = TRUE)

NAMESPACE

@@ -59,6 +59,8 @@ S3method(apa_table,data.frame)
 S3method(apa_table,default)
 S3method(apa_table,list)
 S3method(apa_table,matrix)
+S3method(apa_violinplot,afex_aov)
+S3method(apa_violinplot,default)
 S3method(beautify_terms,character)
 S3method(beautify_terms,data.frame)
 S3method(beautify_terms,factor)
@@ -90,6 +92,7 @@ export(apa_p)
 export(apa_prepare_doc)
 export(apa_print)
 export(apa_table)
+export(apa_violinplot)
 export(beautify_terms)
 export(ci)
 export(cite_r)

R/apa_factorial_plot.R

@@ -22,7 +22,7 @@
 #' @param intercept Numeric. Adds a horizontal line at height `intercept` to the plot. Can be either a single value or a matrix. For the matrix
 #'    case, multiple lines are drawn, where the dimensions of the matrix determine the number of lines to be drawn.
 #' @param plot Character. A vector specifying which elements of the plot should be plotted. Available options are
-#'  `c("points", "error_bars", "bars", "swarms", "lines")`.
+#'  `c("points", "error_bars", "bars", "swarms", "violins", "lines")`.
 #' @param jit Numeric. Determines the amount of horizontal displacement. Defaults to `0.3`, defaults to `0.4` if `plot = "bars"`.
 #' @param args_x_axis An optional `list` that contains further arguments that may be passed to [axis()] for customizing the *x* axis.
 #' @param args_y_axis An optional `list` that contains further arguments that may be passed to [axis()] for customizing the *y* axis.
@@ -31,6 +31,8 @@
 #' @param args_points An optional `list` that contains further arguments that may be passed to [points()].
 #' @param args_lines An optional `list` that contains further arguments that may be passed to [lines()].
 #' @param args_swarm An optional `list` that contains further arguments to customize the [points()] of the beeswarm.
+#' @param args_violins An optional `list` that contains further arguments to customize the [[polygon()]] used for violins.
+#' @param args_density An optional `list` that contains further arguments to customize the [[density()]] plotted as violins.
 #' @param args_error_bars An optional `list` that contains further arguments that may be passed to [arrows()].
 #' @param args_legend An optional `list` that contains further arguments that may be passed to [legend()]
 #' @param xlab Character or expression. Label for *x* axis.
@@ -51,14 +53,15 @@
 #' ## Customization of plot elements
 #'
 #' [apa_factorial_plot()] and its descendants [apa_barplot()], [apa_lineplot()],
-#' and [apa_beeplot()] are wrapper functions that sequentially call:
+#' [apa_beeplot()], and [apa_violinplot()] are wrapper functions that sequentially call:
 #'
 #' - [plot.new()],
 #' - [plot.window()],
 #' - [axis()] (once for *x* axis, once for *y* axis),
 #' - [title()] for axis labels and titles,
 #' - [rect()] for bars in bar plots,
 #' - [points()] for bee swarms,
+#' - [density()] and [polygon()] for violins,
 #' - [lines()] for lines connecting central tendency points,
 #' - [arrows()] for error bars,
 #' - [points()] for tendency points,
@@ -108,6 +111,8 @@ apa_factorial_plot.default <- function(
   , args_points = NULL
   , args_lines = NULL
   , args_swarm = NULL
+  , args_violins = NULL
+  , args_density = NULL
   , args_error_bars = NULL
   , args_legend = NULL
   , plot = NULL
@@ -143,6 +148,8 @@ apa_factorial_plot.default <- function(
   if(!is.null(args_points)) validate(args_points, check_class = "list")
   if(!is.null(args_lines)) validate(args_lines, check_class = "list")
   if(!is.null(args_swarm)) validate(args_swarm, check_class = "list")
+  if(!is.null(args_violins)) validate(args_violins, check_class = "list")
+  if(!is.null(args_density)) validate(args_density, check_class = "list")
   if(!is.null(args_error_bars)) validate(args_error_bars, check_class = "list")
   if(!is.null(args_legend)) validate(args_legend, check_class = "list")
   if(!is.null(plot)) validate(plot, check_class = "character")
@@ -216,6 +223,8 @@ apa_factorial_plot.default <- function(
        , args_rect = args_rect
        , args_points = args_points
        , args_swarm = args_swarm
+       , args_violins = args_violins
+       , args_density = args_density
        , args_lines = args_lines
        , args_error_bars = args_error_bars
        , args_legend = args_legend
@@ -556,10 +565,13 @@ apa_factorial_plot_single <- function(aggregated, y.values, id, dv, factors, int
     aggregated$x <- aggregated$x - .5 + space/2 + (1-space)/(nlevels(aggregated[[factors[[2]]]])-1) * (as.integer(aggregated[[factors[2]]])-1)
   }
 
+
   # save parameters for multiple plot functions
   args_legend <- ellipsis$args_legend
   args_points <- ellipsis$args_points
   args_swarm <- ellipsis$args_swarm
+  args_violins <- ellipsis$args_violins
+  args_density <- ellipsis$args_density
   args_lines <- ellipsis$args_lines
   args_x_axis <- ellipsis$args_x_axis
   args_y_axis <- ellipsis$args_y_axis
@@ -572,6 +584,14 @@ apa_factorial_plot_single <- function(aggregated, y.values, id, dv, factors, int
   for(i in whitelist)
     args_plot_window[[i]] <- ellipsis[[i]]
 
+
+  ## default colors for tendency points (which are inherited by swarm points)
+  bg.colors <- grey(
+    seq(from = 0, to = 1, length.out = nlevels(aggregated[[factors[2]]])) ^ 0.6
+  )
+
+
+
   # new plot area
   plot.new()
 
@@ -740,11 +760,6 @@ apa_factorial_plot_single <- function(aggregated, y.values, id, dv, factors, int
     agg.y <- tapply(aggregated[["swarmy"]], list(aggregated[[factors[1]]], aggregated[[factors[2]]]), as.numeric)
   }
 
-  ## default colors for tendency points (which are inherited by swarm points)
-  nc <- nlevels(aggregated[[factors[2]]])-1
-  if(nc==0) nc <- 1
-  bg.colors <- grey((0:nc/(nc)) ^ 0.6)
-
   # prepare (tendency) points
   args_points <- defaults(
     args_points
@@ -760,6 +775,53 @@ apa_factorial_plot_single <- function(aggregated, y.values, id, dv, factors, int
     )
   )
 
+  if("violins" %in% ellipsis$plot) {
+    args_violins <- defaults(
+      args_violins
+      , set.if.null = list(
+        border = args_points$col
+        , col  = brighten(args_points$bg, factor = .9)
+      )
+    )
+
+    args_violins$border <- rep(args_violins$border, each = nlevels(aggregated[[factors[1L]]]))
+    args_violins$col    <- rep(args_violins$col,    each = nlevels(aggregated[[factors[1L]]]))
+
+
+    merged <- merge(x = aggregated, y.values[, c(factors, "x"), drop = FALSE], sort = FALSE)
+
+    x1 <- split(
+      x = merged[[dv]]
+      , f = merged[, factors, drop = FALSE]
+    )
+
+    if(is.null(ellipsis$args_density)) ellipsis$args_density <- list()
+    x2 <- lapply(x1, function(x) {
+      args_density <- defaults(ellipsis$args_density, set = list(x = x))
+      do.call(what = "density", args_density)
+    })
+
+    x_offset <- lapply(
+      split(
+        x = merged[["x"]]
+        , f = merged[, factors, drop = FALSE]
+      )
+      , FUN = mean
+    )
+
+    max_density <- max(sapply(X = x2, FUN = function(x) {max(x$y)}))
+
+    for (i in seq_along(x2)) {
+      polygon(
+        x = x_offset[[i]] + c(x2[[i]]$y, rev(-x2[[i]]$y)) / max_density * ellipsis$jit / (if(onedim) 1 else nlevels(aggregated[[factors[2L]]])-1)
+        , y = c(x2[[i]]$x, rev(x2[[i]]$x))
+        , col = args_violins$col[i]
+        , border = args_violins$border[i]
+      )
+    }
+  }
+
+
 
   if("swarms" %in% ellipsis$plot){
     args_swarm <- defaults(
@@ -885,6 +947,8 @@ apa_factorial_plot_single <- function(aggregated, y.values, id, dv, factors, int
       , args_rect = args_rect
       , args_points = args_points
       , args_swarm = args_swarm
+      , args_violins = args_violins
+      , args_density = args_density
       , args_lines = args_lines
       , args_error_bars = args_error_bars
       , args_legend = args_legend

R/apa_lineplot.R

@@ -20,7 +20,7 @@
 #'  , id = "block"
 #'  , dv = "yield"
 #'  , factors = c("N", "P")
-#'  , args.legend = list(x = "center")
+#'  , args_legend = list(x = "center")
 #'  , jit = 0
 #' )
 #'

R/apa_violinplot.R

@@ -0,0 +1,124 @@
+#' Violin Plots for Factorial Designs that Conform to APA Guidelines
+#'
+#' Creates one or more violin plots from a `data.frame` containing data from
+#' a factorial design and sets APA-friendly defaults.
+#'
+#' @inherit apa_factorial_plot
+#' @inheritDotParams apa_factorial_plot
+#'
+#' @family plots for factorial designs
+#' @examples
+#' apa_violinplot(
+#'    data = npk
+#'    , id = "block"
+#'    , dv = "yield"
+#'    , factors = c("N")
+#' )
+#'
+#' apa_violinplot(
+#'   data = npk
+#'   , id = "block"
+#'   , dv = "yield"
+#'   , factors = c("N", "P")
+#'   , args_legend = list(x = "center")
+#'   , jit = 0.1
+#' )
+#'
+#'
+#' @import grDevices
+#' @import graphics
+#' @rdname apa_violinplot
+#' @export
+
+apa_violinplot <- function(data, ...){
+  UseMethod("apa_violinplot", data)
+}
+
+
+
+#' @rdname apa_violinplot
+#' @export
+
+apa_violinplot.default <- function(
+  data
+  , id
+  , factors = NULL
+  , dv
+  , tendency = mean
+  , dispersion = conf_int
+  , level = 0.95
+  , fun_aggregate = mean
+  , na.rm = TRUE
+  , use = "all.obs"
+  , intercept = NULL
+  , args_x_axis = NULL
+  , args_y_axis = NULL
+  , args_title = NULL
+  , args_points = NULL
+  , args_lines = NULL
+  , args_error_bars = NULL
+  , args_legend = NULL
+  , jit = .3
+  , xlab = NULL
+  , ylab = NULL
+  , main = NULL
+  , ...
+){
+  ellipsis <- defaults(
+    list(...)
+    , set.if.null =list(
+      data = data
+      , id = id
+      , factors = factors
+      , dv = dv
+      , tendency = substitute(tendency)
+      , dispersion = substitute(dispersion)
+      , level = level
+      , fun_aggregate = substitute(fun_aggregate)
+      , na.rm = na.rm
+      , use = use
+      , intercept = intercept
+      , args_x_axis = args_x_axis
+      , args_y_axis = args_y_axis
+      , args_points = args_points
+      , args_lines = args_lines
+      , args_error_bars = args_error_bars
+      , args_legend = args_legend
+      , jit = jit
+      , xlab = xlab
+      , ylab = ylab
+      , main = main
+      , plot = c("points", "violins", "error_bars")
+    )
+  )
+  do.call("apa_factorial_plot", ellipsis)
+}
+
+#' @rdname apa_violinplot
+#' @export
+
+apa_violinplot.afex_aov <- function(
+  data
+  , tendency = mean
+  , dispersion = conf_int
+  , fun_aggregate = mean
+  , ...
+){
+
+  ellipsis <- list(...)
+
+  ellipsis <- defaults(
+    ellipsis
+    , set = list(
+      data = data
+      , plot = c("points", "violins", "error_bars")
+      , tendency = substitute(tendency)
+      , dispersion = substitute(dispersion)
+      , fun_aggregate = substitute(fun_aggregate)
+    )
+  )
+  do.call("apa_factorial_plot.afex_aov", ellipsis)
+}
+
+
+

inst/NEWS.md

@@ -2,6 +2,8 @@
 
 - For ANOVA methods, *MSE*s are again returned if requested by the user (reported by @Sashpta, [#562](https://github.com/crsh/papaja/issues/562)). The global default for reporting *MSE*s now depends on the [**effectsize**](https://CRAN.r-project.org/package=effectsize) package: If **effectsize** is installed, the default for reporting *MSE*s is `FALSE`, if **effectsize** is not installed, the default is `TRUE`.
 - Added `apa_print()` support for analysis of deviance from the **car** package.
+- Added new plotting function `apa_violinplot()` for violin plots.
+- Accordingly, `apa_factorial_plot()` gained arguments `args_violins` and `args_density`.
 
 ### Existing functions