full draft of subguides, for #183

NAMESPACE

@@ -29,8 +29,10 @@ S3method(hdci_,rvar)
 S3method(hdi_,distribution)
 S3method(hdi_,numeric)
 S3method(hdi_,rvar)
+S3method(is.na,ggdist_thickness)
 S3method(makeContent,dots_grob)
 S3method(mean,ggdist__weighted_sample)
+S3method(normalize_thickness,"NULL")
 S3method(normalize_thickness,data.frame)
 S3method(normalize_thickness,default)
 S3method(normalize_thickness,ggdist_thickness)
@@ -241,6 +243,7 @@ export(stat_slab)
 export(stat_slabinterval)
 export(stat_spike)
 export(subguide_axis)
+export(subguide_count)
 export(subguide_inside)
 export(subguide_none)
 export(subguide_outside)

R/auto_partial.R

@@ -84,7 +84,7 @@ NULL
 #' @importFrom rlang as_quosure enquos eval_tidy expr get_expr
 partial_self = function(name = NULL) {
   f = sys.function(-1L)
-  call = match.call(f, sys.call(-1L))
+  call = match.call(f, sys.call(-1L), TRUE, parent.frame(2L))
   f_quo = as_quosure(call[[1]], parent.frame(2L))
   default_args = lapply(call[-1], as_quosure, env = parent.frame(2L))
   name = name %||% deparse0(get_expr(call[[1]]))

R/geom_dotsinterval.R

@@ -13,6 +13,7 @@ dots_grob = function(data, x, y, xscale = 1,
   name = NULL, gp = gpar(), vp = NULL,
   dotsize = 1.07, stackratio = 1, binwidth = NA, layout = "bin",
   overlaps = "nudge", overflow = "keep",
+  subguide = "none",
   verbose = FALSE,
   orientation = "vertical"
 ) {
@@ -25,6 +26,7 @@ dots_grob = function(data, x, y, xscale = 1,
     xscale = xscale,
     dotsize = dotsize, stackratio = stackratio, binwidth = binwidth, layout = layout,
     overlaps = overlaps, overflow = overflow,
+    subguide = subguide,
     verbose = verbose,
     orientation = orientation,
     name = name, gp = gp, vp = vp, cl = "dots_grob"
@@ -44,6 +46,7 @@ makeContent.dots_grob = function(x) {
   layout = grob_$layout
   overlaps = grob_$overlaps
   overflow = grob_$overflow
+  subguide = grob_$subguide
 
   define_orientation_variables(orientation)
 
@@ -109,7 +112,7 @@ makeContent.dots_grob = function(x) {
   }
 
   # now, draw all the dotplots using the same bin width
-  children = do.call(gList, lapply(datas, function(d) {
+  dot_grobs = lapply(datas, function(d) {
     # bin the dots
     dot_positions = bin_dots(
       d$x, d$y,
@@ -150,9 +153,51 @@ makeContent.dots_grob = function(x) {
         lty = d$linetype
       )
     )
-  }))
+  })
 
-  setChildren(grob_, children)
+  # generate subguide if requested
+  subguide_grobs = if (identical(subguide, "none")) {
+    # quick exit, also avoid errors for multiple non-equal axes when not drawing them
+    list()
+  } else {
+    subguide_fun = match_function(subguide, "subguide_")
+    subguide_params = bind_rows(lapply(datas, `[`, i = 1, j = , drop = FALSE))
+    dlply_(
+      subguide_params[, c(y, ymin, ymax, "side", "justification", "scale")],
+      c(y, "side", "justification", "scale"),
+      function(d) {
+        if (nrow(unique(d)) > 1) {
+          cli_abort(c(
+            "Cannot draw a subguide for the dot count axis when multiple dots
+             geometries with different parameters are drawn on the same axis."
+          ))
+        }
+        d = d[1, ]
+
+        dot_height = binwidth * heightratio / stackratio
+        guide_height = max(d[[ymax]] - d[[y]], d[[y]] - d[[ymin]])
+        direction = switch_side(d$side, orientation, topright = 1, bottomleft = -1, both = 1)
+        both_adjust = if (d$side == "both") 2 else 1
+        not_both = if (d$side == "both") 0 else 1
+        max_count = guide_height / binwidth / heightratio * both_adjust + 1 - 1/stackratio
+
+        # construct a viewport such that the guide drawn in this viewport
+        # will have its data values at the correct locations
+        vp = viewport(just = c(0,0))
+        vp[[x]] = unit(0, "native")
+        vp[[y]] = unit(d[[y]] + dot_height / 2 * not_both * direction, "native")
+        vp[[width.]] = unit(1, "npc")
+        vp[[height]] = unit(guide_height - dot_height / both_adjust, "native") * direction
+
+
+        grobTree(
+          subguide_fun(c(1, max_count), orientation = orientation),
+          vp = vp
+        )
+      })
+  }
+
+  setChildren(grob_, do.call(gList, c(dot_grobs, subguide_grobs)))
 }
 
 
@@ -162,6 +207,7 @@ draw_slabs_dots = function(self, s_data, panel_params, coord,
   orientation, normalize, fill_type, na.rm,
   dotsize, stackratio, binwidth, layout,
   overlaps, overflow,
+  subguide,
   verbose,
   ...
 ) {
@@ -224,6 +270,7 @@ draw_slabs_dots = function(self, s_data, panel_params, coord,
     layout = layout,
     overlaps = overlaps,
     overflow = overflow,
+    subguide = subguide,
     verbose = verbose,
     orientation = orientation
   ))

R/geom_slabinterval.R

@@ -10,6 +10,11 @@
 #' @noRd
 normalize_thickness = function(x) UseMethod("normalize_thickness")
 
+#' @export
+normalize_thickness.NULL = function(x) {
+  NULL
+}
+
 #' @export
 normalize_thickness.default = function(x) {
   lower = NA_real_
@@ -76,7 +81,7 @@ rescale_slab_thickness = function(
   s_data = ggplot2::remove_missing(s_data, na.rm, c(height, "justification", "scale"), name = name, finite = TRUE)
   # side is a character vector, thus need finite = FALSE for it; x/y can be Inf here
   s_data = ggplot2::remove_missing(s_data, na.rm, c(x, y, "side"), name = name)
-  if (nrow(s_data) == 0) return(s_data)
+  if (nrow(s_data) == 0) return(list(data = s_data, subguide_params = data.frame()))
 
   min_height = min(s_data[[height]])
 
@@ -120,7 +125,7 @@ rescale_slab_thickness = function(
         d[[ymax]] = d[[y]] + (1 - d$justification) * thickness_scale
       },
       both = {
-        subguide_params[[ymin]] = d[[y]][[1]] - (0.5 - d$justification[[1]]) * thickness_scale
+        subguide_params[[ymin]] = d[[y]][[1]] + (0.5 - d$justification[[1]]) * thickness_scale
         subguide_params[[ymax]] = d[[y]][[1]] + (1 - d$justification[[1]]) * thickness_scale
         d[[ymin]] = d[[y]] - thickness * thickness_scale/2 + (0.5 - d$justification) * thickness_scale
         d[[ymax]] = d[[y]] + thickness * thickness_scale/2 + (0.5 - d$justification) * thickness_scale
@@ -220,19 +225,16 @@ draw_slabs = function(self, s_data, panel_params, coord,
         ))
       }
 
-      scale = scale_thickness_shared()
-      scale$train(c(d$thickness_lower, d$thickness_upper))
-
       # construct a viewport such that the guide drawn in this viewport
       # will have its data values at the correct locations
       vp = viewport(just = c(0,0))
       vp[[x]] = unit(0, "native")
-      vp[[y]] = unit(d[[y]], "native")
+      vp[[y]] = unit(d[[ymin]], "native")
       vp[[width.]] = unit(1, "npc")
       vp[[height]] = unit(d[[ymax]] - d[[ymin]], "native")
 
       grobTree(
-        subguide_fun(scale, orientation = orientation),
+        subguide_fun(c(d$thickness_lower, d$thickness_upper), orientation = orientation),
         vp = vp
       )
     })
@@ -770,7 +772,6 @@ GeomSlabinterval = ggproto("GeomSlabinterval", AbstractGeom,
     # must do this here: not setup_data, so it happens after the thickness scale
     # has been applied; and not draw_panel, because normalization may be applied
     # across panels.
-    data$thickness_orig = data$thickness # keep this around for drawing subguides
     switch(params$normalize,
       all = {
         # normalize so max height across all data is 1

R/scale_thickness.R

@@ -165,6 +165,7 @@ scale_type.ggdist_thickness = function(x) {
 # data type for thickness ---------------------------------------------------------------
 
 new_thickness = function(x = double(), lower = NA_real_, upper = NA_real_) {
+  if (length(x) < 1) x = double()
   stopifnot(is.double(x))
   if (length(lower) <= 1) lower = rep(lower, length(x))
   if (length(upper) <= 1) upper = rep(upper, length(x))
@@ -185,7 +186,6 @@ thickness = function(x = double(), lower = NA_real_, upper = NA_real_) {
 }
 
 
-
 # bounds ------------------------------------------------------------------
 
 thickness_lower = function(x) {
@@ -203,6 +203,11 @@ is_thickness = function(x) {
   inherits(x, "ggdist_thickness")
 }
 
+#' @export
+is.na.ggdist_thickness = function(x) {
+  is.na(field(x, "x"))
+}
+
 
 # formatting ------------------------------------------------------
 

R/subguide.R

@@ -5,7 +5,9 @@
 #' [geom_slabinterval()].
 #' Supports [automatic partial function application][automatic-partial-functions].
 #'
-#' @param scale A [ggplot2::Scale], typically an instance of [scale_thickness_shared()].
+#' @inheritParams scale_thickness
+#' @param values Values used to construct the scale used for this guide.
+#'    Typically provided automatically by [geom_slabinterval()].
 #' @param title The title of the scale shown on the sub-guide's axis.
 #' @param position Numeric value between `0` and `1` giving the position of the
 #'    guide relative to the axis: `0` causes the sub-guide to be drawn on the
@@ -41,8 +43,10 @@
 #' @family sub-guides
 #' @export
 subguide_axis = auto_partial(name = "subguide_axis", function(
-  scale,
+  values,
   title = NULL,
+  breaks = waiver(),
+  labels = waiver(),
   position = 0,
   just = 0,
   label_side = "topright",
@@ -53,6 +57,9 @@ subguide_axis = auto_partial(name = "subguide_axis", function(
   grob_width = switch(width., width = grobWidth, height = grobHeight)
   position = get_subguide_position(position, orientation)
 
+  scale = scale_thickness_shared(breaks = breaks, labels = labels, limits = range(values))
+  scale$train(values)
+
   break_positions = as.numeric(scale$map(scale$get_breaks()))
   break_labels = scale$get_labels()
 
@@ -92,16 +99,31 @@ subguide_axis = auto_partial(name = "subguide_axis", function(
 })
 
 #' @details
-#' [subguide_inside()] is a shortcut for `subguide_axis(label_side = "inside")`
+#' [subguide_inside()] is a shortcut for drawing labels inside of the chart
+#' region.
 #' @rdname subguide_axis
 #' @export
-subguide_inside = subguide_axis(label_side = "inside")
+subguide_inside = function(..., label_side = "inside") {
+  subguide_axis(..., label_side = label_side)
+}
 
 #' @details
-#' [subguide_outside()] is a shortcut for `subguide_axis(label_side = "outside", just = 1)`
+#' [subguide_outside()] is a shortcut for drawing labels outside of the chart
+#' region.
 #' @rdname subguide_axis
 #' @export
-subguide_outside = subguide_axis(label_side = "outside", just = 1)
+subguide_outside = function(..., label_side = "outside", just = 1) {
+  subguide_axis(..., label_side = label_side, just = just)
+}
+
+#' @details
+#' [subguide_count()] is a shortcut for drawing labels where each whole number
+#' is labeled, useful for labeling counts in [geom_dots()].
+#' @rdname subguide_axis
+#' @export
+subguide_count = function(..., breaks = scales::breaks_width(1)) {
+  subguide_axis(..., breaks = breaks)
+}
 
 #' Empty sub-guide for thickness scales
 #'
@@ -161,6 +183,7 @@ get_subguide_position = function(position, orientation) {
 
 #' Transform the combination of `position` and `side` into an axis position;
 #' i.e. one of `"left"` or `"right"`.
+#' @noRd
 get_subguide_axis_position = function(side, position, orientation) {
   switch(orientation,
     y = ,