initial implementation of geom_blurdots for #63

DESCRIPTION

@@ -85,6 +85,7 @@ Collate:
     "geom.R"
     "geom_slabinterval.R"
     "geom_dotsinterval.R"
+    "geom_blurdots.R"
     "geom_interval.R"
     "geom_lineribbon.R"
     "geom_pointinterval.R"

NAMESPACE

@@ -82,6 +82,7 @@ S3method(vec_ptype_full,ggdist_partial_colour_ramp)
 S3method(vec_ptype_full,ggdist_thickness)
 S3method(weights,ggdist__weighted_sample)
 export(AbstractStatSlabinterval)
+export(GeomBlurdots)
 export(GeomDots)
 export(GeomDotsinterval)
 export(GeomInterval)
@@ -133,6 +134,7 @@ export(facet_title_right_horizontal)
 export(find_dotplot_binwidth)
 export(from_broom_names)
 export(from_ggmcmc_names)
+export(geom_blurdots)
 export(geom_dots)
 export(geom_dotsinterval)
 export(geom_interval)

NEWS.md

@@ -10,6 +10,8 @@ New features and enhancements:
   intervals, highest density intervals, and highest density continuous intervals),
   and all point summaries (mean, median, and mode) (#41). This includes support
   for the upcoming weighted random variable type in the *posterior* package.
+* Blurry dotplots are now supported using `geom_blurdots()`, which accepts a
+  `blur` aesthetic to set the standard deviation of the blur on each dot (#63).
 * The `at` parameter to `stat_spike()` (or its names) now determines values of
   an `at` computed variable, which can be mapped onto aesthetics via `after_stat()`
   to more easily label spikes. (#203; thanks @mattansb for the suggestion).

R/geom_blurdots.R

@@ -0,0 +1,143 @@
+# Geom for blurry dotplots
+#
+# Author: mjskay
+###############################################################################
+
+
+# blur functions ---------------------------------------------------------------
+
+blur_type_gaussian = function(x, r, sd) {
+  pnorm(x + r, 0, sd) - pnorm(x - r, 0, sd)
+}
+
+blur_type_interval = function(x, r, sd) {
+  ifelse(
+    x < r, 1,
+    ifelse(
+      x < 2 * sd, 0.5,
+      0
+    )
+  )
+}
+
+
+# grob construction -------------------------------------------------------
+
+make_blurry_points_grob = function(
+  x = 0.5,
+  y = 0.5,
+  ...,  # ignored
+  col = "gray65",
+  fill = "gray65",
+  fontsize = 11,
+  lwd = 1,
+  lty = "solid",
+  axis = "x",
+  sd = 0,
+  n = 100,
+  blur_type = blur_type_gaussian
+) {
+  # ensure r and sd are in the same units -- that way when we apply the blur function
+  # (which only takes numerics) everything will line up correctly
+  r = unit(fontsize / font_size_ratio / 2, "points")
+  sd = convertUnit(unit(sd %||% 0, "native"), unitTo = "points", axisFrom = axis, typeFrom = "dimension")
+
+  grobs = .mapply(list(x, y, fill, sd, lwd, lty), NULL, FUN = function(x, y, fill, sd, lwd, lty) {
+    blur_width = 2 * sd + r
+    blur_x = seq(0, as.numeric(blur_width), length.out = n)
+    grad_colors = alpha(fill, c(blur_type(blur_x, as.numeric(r), as.numeric(sd)), 0))
+    grad = radialGradient(grad_colors, r2 = blur_width)
+
+    h = 2 * r
+    w = 2 * blur_width
+    blurry_fill = rectGrob(
+      x = x, y = y,
+      height = if (axis == "x") h else w,
+      width = if (axis == "x") w else h,
+      gp = gpar(fill = grad, col = NA)
+    )
+    outline = circleGrob(
+      x = x, y = y, r = r,
+      gp = gpar(col = col, fill = NA, lwd = lwd, lty = lty)
+    )
+
+    grobTree(blurry_fill, outline)
+  })
+
+  do.call(grobTree, grobs)
+}
+
+# geom_blurdots ----------------------------------------------------------
+#' @rdname ggdist-ggproto
+#' @format NULL
+#' @usage NULL
+#' @import ggplot2
+#' @export
+GeomBlurdots = ggproto("GeomBlurdots", GeomDots,
+
+  ## aesthetics --------------------------------------------------------------
+
+  aes_docs = {
+    aes_docs = GeomDots$aes_docs
+    dots_aes_i = which(startsWith(names(aes_docs), "Dots-specific"))
+    aes_docs[[dots_aes_i]] = defaults(list(
+      blur = 'The blur associated with each dot, expressed as a standard deviation in data units.'
+    ), aes_docs[[dots_aes_i]])
+    aes_docs
+  },
+
+  hidden_aes = union("shape", GeomDots$hidden_aes),
+
+  default_aes = defaults(aes(
+    blur = 0
+  ), GeomDots$default_aes),
+
+  default_key_aes = defaults(aes(
+    colour = NA
+  ), GeomDots$default_key_aes),
+
+  ## other methods -----------------------------------------------------------
+
+  setup_data = function(self, data, params) {
+    define_orientation_variables(params$orientation)
+
+    data = ggproto_parent(GeomDots, self)$setup_data(data, params)
+
+    # add an xmin/xmax to dots based on blur sd so that the full extent of
+    # blurred dots is drawn
+    data[["blur"]] = data[["blur"]] %||% params$blur
+    if (!is.null(data[["blur"]])) {
+      slab_i = which(data$datatype == "slab")
+      data[slab_i, xmin] = data[slab_i, x] - 2 * data[slab_i, "blur"]
+      data[slab_i, xmax] = data[slab_i, x] + 2 * data[slab_i, "blur"]
+    }
+
+    data
+  },
+
+  draw_slabs = function(self, s_data, panel_params, coord, orientation, ...) {
+    define_orientation_variables(orientation)
+
+    if (!is.null(s_data[["blur"]])) {
+      # blur is expressed in terms of data coordinates, need to translate
+      # into standardized space
+      xscale = max(panel_params[[x.range]]) - min(panel_params[[x.range]])
+      s_data$blur = s_data$blur / xscale
+      s_data$blur[is.na(s_data$blur)] = 0
+    }
+
+    ggproto_parent(GeomDots, self)$draw_slabs(s_data, panel_params, coord, orientation, ...)
+  },
+
+  make_points_grob = make_blurry_points_grob
+)
+
+#' @title Blurry dot plot (geom)
+#' @description
+#' Variant of [geom_dots()] for creating blurry dotplots. Accepts a `blur`
+#' aesthetic that gives the standard deviation of the blur applied to the dots.
+#' Requires a graphics engine supporting radial gradients. Unlike [geom_dots()],
+#' all dots must be circular, so this geom does not support the `shape` aesthetic.
+#' @eval rd_dotsinterval_shortcut_geom("blurdots", "blurry dot", title = FALSE, describe = FALSE)
+#' @export
+geom_blurdots = make_geom(GeomBlurdots)

R/geom_dotsinterval.R

@@ -15,7 +15,8 @@ dots_grob = function(data, x, y, xscale = 1,
   overlaps = "nudge", overflow = "keep",
   subguide = "none",
   verbose = FALSE,
-  orientation = "vertical"
+  orientation = "vertical",
+  make_points_grob = make_points_grob
 ) {
   # drop the dist columns because they can be expensive and we don't need them
   # after this point
@@ -32,11 +33,15 @@ dots_grob = function(data, x, y, xscale = 1,
     subguide = subguide,
     verbose = verbose,
     orientation = orientation,
+    make_points_grob = make_points_grob,
     name = name, gp = gp, vp = vp, cl = "dots_grob"
   )
 }
 
 
+dot_size_ratio = 1.07                  # historical fudge factor based on old stackratio
+font_size_ratio = 1.43/dot_size_ratio  # manual fudge factor for point size in ggplot
+
 #' @export
 makeContent.dots_grob = function(x) {
   grob_ = x
@@ -50,13 +55,11 @@ makeContent.dots_grob = function(x) {
   overlaps = grob_$overlaps
   overflow = grob_$overflow
   subguide = grob_$subguide
+  stackratio = grob_$stackratio
+  make_points_grob = grob_$make_points_grob
 
   define_orientation_variables(orientation)
 
-  dot_size_ratio = 1.07                  # historical fudge factor based on old stackratio
-  font_size_ratio = 1.43/dot_size_ratio  # manual fudge factor for point size in ggplot
-  stackratio = grob_$stackratio
-
   # ratio between width of the bins (binwidth)
   # and the vertical spacing of dots (y_spacing)
   # this is a bit different from a raw stackratio since we want to account
@@ -149,16 +152,18 @@ makeContent.dots_grob = function(x) {
     )
 
     # generate grob for this dotplot
-    pointsGrob(
-      dot_positions$x, dot_positions$y, pch = d$shape,
-      gp = gpar(
-        col = alpha(d$colour, d$alpha),
-        fill = alpha(d$fill, d$alpha),
-        fontfamily = d$family,
-        fontsize = dot_fontsize,
-        lwd = lwd,
-        lty = d$linetype
-      )
+    make_points_grob(
+      dot_positions$x,
+      dot_positions$y,
+      pch = d$shape,
+      col = alpha(d$colour, d$alpha),
+      fill = alpha(d$fill, d$alpha),
+      fontfamily = d$family,
+      fontsize = dot_fontsize,
+      lwd = lwd,
+      lty = d$linetype,
+      sd = d[["blur"]],
+      axis = x
     )
   })
 
@@ -210,6 +215,32 @@ makeContent.dots_grob = function(x) {
   setChildren(grob_, do.call(gList, c(dot_grobs, subguide_grobs)))
 }
 
+make_points_grob = function(
+  x,
+  y,
+  pch,
+  col,
+  fill,
+  fontfamily,
+  fontsize,
+  lwd,
+  lty,
+  ...  # ignored
+) {
+  pointsGrob(
+    x = x,
+    y = y,
+    pch = pch,
+    gp = gpar(
+      col = col,
+      fill = fill,
+      fontfamily = fontfamily,
+      fontsize = fontsize,
+      lwd = lwd,
+      lty = lty
+    )
+  )
+}
 
 # panel drawing function -------------------------------------------------------
 
@@ -283,7 +314,8 @@ draw_slabs_dots = function(self, s_data, panel_params, coord,
     overflow = overflow,
     subguide = subguide,
     verbose = verbose,
-    orientation = orientation
+    orientation = orientation,
+    make_points_grob = self$make_points_grob
   ))
 }
 
@@ -537,8 +569,9 @@ GeomDotsinterval = ggproto("GeomDotsinterval", GeomSlabinterval,
     # apply smooths --- must do this here in case resulting data exceeds boundaries of
     # original data, meaning scales must be adjusted
     smooth = match_function(params$smooth %||% "none", prefix = "smooth_")
-    s_data = data[data$datatype == "slab", c("group", x, y)]
-    data[data$datatype == "slab", x] = ave(s_data[[x]], s_data[, c("group", y)], FUN = smooth)
+    slab_i = which(data$datatype == "slab")
+    s_data = data[slab_i, c("group", x, y)]
+    data[slab_i, x] = ave(s_data[[x]], s_data[, c("group", y)], FUN = smooth)
 
     data
   },
@@ -565,7 +598,9 @@ GeomDotsinterval = ggproto("GeomDotsinterval", GeomSlabinterval,
       s_key_data$size = 2
       draw_key_point(s_key_data, params, size)
     }
-  }
+  },
+
+  make_points_grob = make_points_grob
 )
 
 #' @rdname geom_dotsinterval

R/rd_dotsinterval.R

@@ -7,20 +7,26 @@
 
 # shortcut stats/geoms ----------------------------------------------------
 
-rd_dotsinterval_shortcut_geom = function(geom_name, chart_type, from_name = "dotsinterval") {
+rd_dotsinterval_shortcut_geom = function(
+  geom_name,
+  chart_type,
+  from_name = "dotsinterval",
+  title = TRUE,
+  describe = TRUE
+) {
   geom = get(paste0("Geom", title_case(geom_name)))
 
   c(
-    glue_doc('@title <<title_case(chart_type)>> plot (shortcut geom)'),
-    glue_doc('
+    if (title) glue_doc('@title <<title_case(chart_type)>> plot (shortcut geom)'),
+    if (describe) glue_doc('
       @description
       Shortcut version of [geom_dotsinterval()] for creating <<chart_type>> plots.
       Geoms based on [geom_dotsinterval()] create dotplots that automatically
       ensure the plot fits within the available space.
 
       Roughly equivalent to:
       '),
-    rd_shortcut_geom(geom_name, from_name),
+    if (describe) rd_shortcut_geom(geom_name, from_name),
     '@inheritParams geom_dotsinterval',
     glue_doc('
       @return A [ggplot2::Geom] representing a <<chart_type>> geometry which can

man-roxygen/details-dotsinterval-family.R

@@ -13,7 +13,7 @@
 #'   `dotsinterval` family) or the `shape` or `slab_shape` aesthetic (when using the `dots` family)
 #' }
 #'
-#' Stat and geoms include in this family include:
+#' Stats and geoms in this family include:
 #'
 #'  - [geom_dots()]: dotplots on raw data. Ensures the dotplot fits within available space by reducing the size
 #'    of the dots automatically (may result in very small dots).
@@ -22,9 +22,11 @@
 #'    (`binwidth = unit(1.5, "mm")`), allowing dots to overlap instead of getting very small.
 #'  - [stat_dots()]: dotplots on raw data, \pkg{distributional} objects, and [posterior::rvar()]s
 #'  - [geom_dotsinterval()]: dotplot + interval plots on raw data with already-calculated
-#'    intervals (rarely useful directly)
+#'    intervals (rarely useful directly).
 #'  - [stat_dotsinterval()]: dotplot + interval plots on raw data, \pkg{distributional} objects,
-#'    and [posterior::rvar()]s (will calculate intervals for you)
+#'    and [posterior::rvar()]s (will calculate intervals for you).
+#'  - [geom_blurdots()]: blurry dotplots that allow the standard deviation of a blur applied to
+#'    each dot to be specified using the `blur` aesthetic.
 #'
 #' [stat_dots()] and [stat_dotsinterval()], when used with the `quantiles` argument,
 #' are particularly useful for constructing quantile dotplots, which can be an effective way to communicate uncertainty