Raincloudplots - movement model versus number of infection

data.R

dat <- structure(list(Move = structure(c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 
3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 
3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 
3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 
3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 
3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 
3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 
3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 
3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 
3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 
3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 
3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 
3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 
3L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 
4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 
4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 
4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 
4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 
4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 
4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 
4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 
4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 
4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 
4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 
4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 
4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L), .Label = c("OFF", "CRW", 
"HD", "FD"), class = "factor"), Infect = c(0, 0, 0, 0, 0, 4, 
1, 2, 1, 2, 0, 2, 1, 1, 1, 3, 0, 0, 0, 1, 1, 2, 1, 1, 0, 3, 0, 
1, 0, 1, 3, 2, 0, 1, 1, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 1, 0, 1, 
0, 0, 1, 1, 2, 2, 2, 1, 1, 2, 3, 2, 0, 4, 1, 1, 1, 1, 1, 2, 0, 
2, 1, 1, 2, 0, 0, 1, 0, 1, 2, 0, 2, 0, 1, 2, 2, 2, 1, 1, 1, 1, 
0, 0, 2, 1, 0, 1, 3, 0, 0, 1, 0, 0, 0, 1, 0, 0, 1, 3, 1, 0, 1, 
2, 1, 1, 0, 3, 1, 2, 2, 3, 0, 0, 1, 0, 1, 0, 2, 2, 1, 3, 3, 1, 
3, 1, 1, 1, 0, 0, 0, 3, 0, 0, 1, 3, 1, 1, 2, 2, 2, 2, 3, 3, 1, 
2, 1, 0, 0, 1, 2, 2, 0, 2, 2, 0, 1, 0, 1, 1, 0, 3, 2, 3, 0, 1, 
0, 1, 3, 2, 3, 0, 0, 0, 0, 1, 2, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 
0, 5, 1, 2, 2, 1, 0, 1, 0, 1, 1, 1, 1, 1, 2, 1, 3, 2, 2, 4, 1, 
0, 1, 1, 2, 1, 1, 2, 1, 0, 0, 3, 0, 0, 0, 2, 1, 0, 1, 3, 0, 1, 
1, 0, 0, 2, 2, 1, 1, 1, 2, 2, 1, 0, 1, 0, 1, 1, 1, 0, 2, 0, 1, 
1, 0, 1, 1, 0, 1, 1, 0, 1, 0, 3, 0, 3, 1, 1, 1, 0, 2, 0, 1, 0, 
0, 1, 1, 1, 1, 1, 0, 2, 2, 1, 1, 0, 1, 0, 2, 2, 1, 1, 1, 0, 2, 
0, 0, 1, 1, 0, 0, 2, 2, 1, 1, 1, 0, 0, 0, 0, 1, 2, 3, 2, 2, 1, 
1, 2, 2, 2, 2, 1, 0, 0, 2, 0, 1, 4, 1, 1, 2, 0, 2, 0, 0, 0, 0, 
1, 4, 1, 0, 1, 1, 1, 0, 2, 1, 2, 1, 3, 1, 1, 2, 3, 1, 1, 1, 1, 
1, 0, 1, 1, 0, 2, 4, 0, 1, 0, 0, 0, 0, 1, 0, 2, 2, 1, 1, 1, 2, 
2, 1, 2, 0, 0, 2, 1, 0, 2, 0, 3, 1, 2, 1, 0, 0, 1, 4, 1, 1, 0, 
0, 0, 3, 1, 0, 0, 3, 0, 1, 1, 1, 0, 1, 1, 0, 0, 1, 2, 2, 0, 1, 
1, 0, 1, 0, 3, 1, 1, 2, 2, 0, 0, 2, 1, 0, 0, 1, 2, 1, 0, 1, 0, 
0, 0, 0, 0, 1, 5, 1, 2, 0, 1, 0, 0, 1, 4, 2, 0, 2, 1, 1, 1, 1, 
1, 1, 1, 2, 2, 0, 1, 1, 4, 0, 1, 1, 0, 0, 1, 2, 2, 2, 1, 2, 1, 
2, 3, 2, 0, 1, 2, 1, 1, 1, 2, 1, 1, 2, 0, 3, 0, 0, 1, 2, 1, 1, 
3, 0, 0, 0, 1, 1, 0, 2, 1, 3, 2, 1, 0, 1, 0, 0, 1, 0, 1, 0, 0, 
1, 3, 0, 0, 0, 0, 1, 1, 1, 3, 0, 2, 2, 2, 0, 1, 0, 2, 3, 1, 0, 
0, 1, 2, 1, 0, 1, 1, 0, 0, 0, 0, 0, 1, 3, 0, 0, 1, 3, 1, 1, 0, 
0, 1, 0, 2, 1, 0, 1, 2, 1, 0, 1, 1, 1, 0, 1, 0, 2, 1, 0, 0, 0, 
0, 0, 2, 1, 0, 2, 0, 1, 0, 3, 3, 0, 0, 1, 1, 0, 1, 4, 0, 1, 4, 
2, 2, 1, 0, 2, 0, 0, 1, 1, 0, 2, 2, 0, 0, 0, 3, 2, 1, 2, 3, 1, 
0, 0, 1, 1, 2, 2, 0, 2, 0, 0, 0, 2, 2, 0, 1, 2, 0, 2, 1, 3, 2, 
0, 2, 1, 4, 1, 0, 4, 1, 2, 1, 1, 1, 2, 2, 2, 1, 5, 0, 3, 2, 1, 
1, 5, 0, 1, 1, 1, 5, 1, 1, 1, 0, 0, 1, 1, 0, 2, 4, 1, 1, 0, 1, 
0, 2, 0, 0, 1, 3, 1, 1, 2, 1, 2, 1, 1, 0, 0, 0, 4, 0, 3, 0, 3, 
1, 1, 0, 1, 1, 4, 0, 3, 2, 4, 2, 1, 2, 1, 0, 1, 0, 1, 0, 3, 2, 
0, 3, 3, 0, 1, 0, 2, 3, 0, 1, 0, 1, 0, 2, 0, 1, 1, 0, 0, 1, 1, 
2, 0, 1, 1, 1, 0, 4, 4, 0, 3, 2, 0, 2, 3, 2, 0, 0, 1, 1, 2, 1, 
0, 1, 1, 3, 1, 1, 0, 0, 0, 0, 0, 0, 0, 3, 1, 0, 1)), class = "data.frame", row.names = c(NA, 
-800L))

geom_flat_violin.R

## geom_flat_violin ------------------------------------------------------------------------------------
## copied from https://github.com/RainCloudPlots/RainCloudPlots/blob/master/tutorial_R/R_rainclouds.R

geom_flat_violin <- function(mapping = NULL, data = NULL, stat = "ydensity",
                             position = "dodge", trim = TRUE, scale = "area",
                             show.legend = NA, inherit.aes = TRUE, ...) {
  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomFlatViolin,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      trim = trim,
      scale = scale,
      ...
    )
  )
}

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
GeomFlatViolin <-
  ggproto("GeomFlatViolin", Geom,
          setup_data = function(data, params) {
            data$width <- data$width %||%
              params$width %||% (resolution(data$x, FALSE) * 0.9)
            
            # ymin, ymax, xmin, and xmax define the bounding rectangle for each group
            data %>%
              group_by(group) %>%
              mutate(ymin = min(y),
                     ymax = max(y),
                     xmin = x,
                     xmax = x + width / 2)
            
          },
          
          draw_group = function(data, panel_scales, coord) {
            # Find the points for the line to go all the way around
            data <- transform(data, xminv = x,
                              xmaxv = x + violinwidth * (xmax - x))
            
            # Make sure it's sorted properly to draw the outline
            newdata <- rbind(plyr::arrange(transform(data, x = xminv), y),
                             plyr::arrange(transform(data, x = xmaxv), -y))
            
            # Close the polygon: set first and last point the same
            # Needed for coord_polar and such
            newdata <- rbind(newdata, newdata[1,])
            
            ggplot2:::ggname("geom_flat_violin", GeomPolygon$draw_panel(newdata, panel_scales, coord))
          },
          
          draw_key = draw_key_polygon,
          
          default_aes = aes(weight = 1, colour = "grey20", fill = "white", size = 0.5,
                            alpha = NA, linetype = "solid"),
          
          required_aes = c("x", "y")
  )

ggtheme.R

## custom ggtheme --------------------------------------------------------------------------------------

library(ggplot2)

if ("extrafont" %in% rownames(installed.packages()))
{
  library(extrafont)
  #extrafont::font_import()
  extrafont::loadfonts(device = "win")
  base <- "Roboto Condensed"
} else {
  base <- "Gadugi"   
}

theme_custom <- function (base_size = 12, base_family = base)
{
  half_line <- base_size/2
  theme(line = element_line(colour = "black", size = 0.5, linetype = 1, lineend = "butt"), 
        rect = element_rect(fill = "white", colour = "black", size = 0.5, linetype = 1), 
        text = element_text(family = base_family, face = "plain", colour = "black", size = base_size, 
                            lineheight = 0.9, hjust = 0.5, vjust = 0.5, angle = 0, margin = margin(),  debug = FALSE), 
        axis.line = element_blank(), 
        axis.line.x = NULL, 
        axis.line.y = NULL, 
        axis.text = element_text(size = base_size, colour = "black"), 
        axis.text.x = element_text(margin = margin(t = 0.8 * half_line/2), vjust = 1), 
        axis.text.x.top = element_text(margin = margin(b = 0.8 * half_line/2), vjust = 0), 
        axis.text.y = element_text(margin = margin(r = 0.8 * half_line/2), hjust = 1), 
        axis.text.y.right = element_text(margin = margin(l = 0.8 * half_line/2), hjust = 0), 
        axis.ticks = element_line(colour = "black", size = 0.5), 
        axis.ticks.length = unit(half_line/1.25, "pt"), 
        axis.title.x = element_text(margin = unit(c(3, 0, 0, 0), "mm"), vjust = 1, size = base_size * 1.3), 
        axis.title.x.top = element_text(margin = margin(b = half_line), vjust = 0), 
        axis.title.y = element_text(angle = 90, margin = unit(c(0, 1, 0, 0), "mm"), vjust = 1, size = base_size * 1.3), 
        axis.title.y.right = element_text(angle = -90, margin = margin(l = half_line), vjust = 0), 
        legend.background = element_rect(colour = NA), 
        legend.spacing = unit(0.4, "cm"), 
        legend.spacing.x = NULL, 
        legend.spacing.y = NULL, 
        legend.margin = margin(0.2, 0.2, 0.2, 0.2, "cm"), 
        legend.key = element_rect(fill = "white", colour = "white"), 
        legend.key.size = unit(1.2, "lines"), 
        legend.key.height = NULL, 
        legend.key.width = NULL, 
        legend.text = element_text(size = rel(0.9)), 
        legend.text.align = NULL, 
        legend.title = element_text(hjust = 0, size = base_size), 
        legend.title.align = NULL, 
        legend.position = "right", 
        legend.direction = NULL, 
        legend.justification = "center", 
        legend.box = NULL, 
        legend.box.margin = margin(0, 0, 0, 0, "cm"), 
        legend.box.background = element_blank(), 
        legend.box.spacing = unit(0.4, "cm"), 
        panel.background = element_rect(fill = NA, colour = NA), 
        panel.border = element_rect(colour = "black", fill = NA, size = rel(1)),
        panel.grid = element_blank(),
        panel.grid.major = element_blank(), 
        panel.grid.minor = element_blank(), 
        panel.spacing = unit(base_size, "pt"), 
        panel.spacing.x = NULL, 
        panel.spacing.y = NULL, 
        panel.ontop = FALSE, 
        strip.background = element_rect(fill = "white", colour = "black"), 
        strip.text = element_text(colour = "black", size = base_size, face = "bold"), 
        strip.text.x = element_text(margin = margin(t = half_line, b = half_line)), 
        strip.text.y = element_text(angle = -90, margin = margin(l = half_line, r = half_line)), 
        strip.placement = "inside", 
        strip.placement.x = NULL, 
        strip.placement.y = NULL, 
        strip.switch.pad.grid = unit(0.1, "cm"), 
        strip.switch.pad.wrap = unit(0.1, "cm"), 
        plot.background = element_rect(colour = NA), 
        plot.title = element_text(size = base_size * 1.8, hjust = 0.5, vjust = 1, face = "bold", margin = margin(b = half_line * 1.2)), 
        plot.subtitle = element_text(size = base_size * 1.3, hjust = 0.5, vjust = 1, margin = margin(b = half_line * 0.9)), 
        plot.caption = element_text(size = rel(0.9), hjust = 1, vjust = 1, margin = margin(t = half_line * 0.9)), 
        plot.margin = margin(base_size, base_size, base_size, base_size), complete = T,
        plot.tag = element_text(size = rel(2), face = "bold", hjust = 0.5, vjust = 0.5), 
        plot.tag.position = "topleft")
}

theme_set(theme_custom())

hnudge.R

## horizontal nudge position adjustment ----------------------------------------------------------------
## (if "position_nudge requires the following missing aesthetics: y")
## copied from https://github.com/tidyverse/ggplot2/issues/2733

position_hnudge <- function(x = 0) {
  ggproto(NULL, PositionHNudge, x = x)
}

PositionHNudge <- ggproto("PositionHNudge", Position,
                          x = 0,
                          required_aes = "x",
                          setup_params = function(self, data) {
                            list(x = self$x)
                          },
                          compute_layer = function(data, params, panel) {
                            transform_position(data, function(x) x + params$x)
                          }
)

rainingcloudplot.R

library(tidyverse)

source("data.R")
source("geom_violin_plot.R")
source("hnudge.R")
source("ggtheme.R")

breaks <- c("OFF", "CRW", "HD", "FD")
cols <- c("#BF616A", "#D08770", "#A3BE8C", "#B48EAD")

ggplot(dat, aes(x = Move, y = Infect)) +
  geom_flat_violin(aes(fill = Move), color = NA, position = position_hnudge(x = 0.1), 
                   adjust = 1.25, trim = FALSE) +
  geom_boxplot(outlier.shape = NA, width = 0.1, colour = "gray20", fill = "NA") +
  geom_point(aes(x = as.numeric(Move) - 0.25, y = Infect, color = Move), 
             position = position_jitter(width = 0.15), size = 2, alpha = 0.35) +
  theme(legend.position = "none",
        axis.text.x = element_text(angle = 0, hjust = 0.5)) +
  labs(y = "# Infections", x = "Movement Model") +  
  scale_fill_manual(breaks = breaks, values = cols) + 
  scale_color_manual(breaks = breaks, values = cols)