Density singletons

NEWS.md

@@ -107,6 +107,13 @@ a (custom) theme, e.g. `tinytheme("clean", facet.axes = "outer")`.
 
 ### Bug fixes
 
+- Density-based plots no longer error out on singleton groups, i.e. `by` and
+  `facet` combinations containing only one observation. Such groups are now
+  dropped, together with a warning reporting how many were removed. The
+  affected types---`type_density()`, `type_violin()`, and `type_ridge()`---also
+  gain a `singletons` argument for controlling this behaviour: option `"drop"`
+  removes them quietly, while `"none"` retains them (and so requires a numeric
+  `bw`). (#300 @grantmcdermott)
 - `flip = TRUE` now flips the drawn geometry of the single-letter line types,
   not just the axes: `type = "h"` draws horizontal segments to the baseline,
   and the step types `"s"` and `"S"` swap which coordinate moves first.

R/sanitize_facet.R

@@ -15,36 +15,42 @@ sanitize_facet = function(settings) {
   # prefixes, and the levels let facet_titles() restore a value's type after
   # splitting a composite title apart. See facet_var_list().
   facet_vars = NULL
-  if (!is.null(facet) && length(facet) == 1 && facet == "by") {
-    by = as.factor(by) ## if by==facet, then both need to be factors
-    facet = by
-    facet_by = TRUE
-    # facet titles inherit the "by" variable name (same as the legend title)
-    facet_vars = list(x = facet_var_list(by, legend_args[["title"]] %||% by_dep))
-  } else if (!is.null(facet) && inherits(facet, "formula")) {
-    facet = get_facet_fml(facet, data = data)
-    if (isTRUE(attr(facet, "facet_grid"))) {
-      facet.args[["nrow"]] = attr(facet, "facet_nrow")
-    }
-    facet_vars = attr(facet, "facet_vars")
-  } else if (!is.null(facet)) {
-    # recorded by tinyplot.formula(), else fall back to the deparsed input of
-    # the default method, e.g. facet = dat$fvar. (When called via
-    # tinyplot.formula(), facet_dep is just the forwarded "facet" placeholder,
-    # but that method has already recorded the real name.)
-    facet_vars = attr(facet, "facet_vars")
-    if (is.null(facet_vars) && !is.null(facet_dep) && !facet_dep %in% c("facet", "NULL")) {
-      facet_vars = list(x = facet_var_list(facet, facet_dep))
+
+  null_facet = TRUE
+  if (!is.null(facet)) {
+    null_facet = FALSE
+    if (length(facet) == 1 && facet == "by") {
+      by = as.factor(by) ## if by==facet, then both need to be factors
+      facet = by
+      facet_by = TRUE
+      # facet titles inherit the "by" variable name (same as the legend title)
+      facet_vars = list(x = facet_var_list(by, legend_args[["title"]] %||% by_dep))
+    } else if (inherits(facet, "formula")) {
+      facet = get_facet_fml(facet, data = data)
+      if (isTRUE(attr(facet, "facet_grid"))) {
+        facet.args[["nrow"]] = attr(facet, "facet_nrow")
+      }
+      facet_vars = attr(facet, "facet_vars")
+    } else {
+      # recorded by tinyplot.formula(), else fall back to the deparsed input of
+      # the default method, e.g. facet = dat$fvar. (When called via
+      # tinyplot.formula(), facet_dep is just the forwarded "facet" placeholder,
+      # but that method has already recorded the real name.)
+      facet_vars = attr(facet, "facet_vars")
+      if (is.null(facet_vars) && !is.null(facet_dep) && !facet_dep %in% c("facet", "NULL")) {
+        facet_vars = list(x = facet_var_list(facet, facet_dep))
+      }
     }
+    facet = as.factor(facet) # facets are *always* factors
   }
+
   # The variables travel as an attribute so that they survive the handover from
   # tinyplot.formula(), but they get stripped here: `facet` flows on into
   # `datapoints`, where a stray attribute would break identity checks against
   # `by` (e.g. type_violin()).
   if (!is.null(facet)) attr(facet, "facet_vars") = NULL
 
   facet_attr = attributes(facet) # TODO: better way to restore facet attributes?
-  null_facet = is.null(facet)
 
   # update settings
   env2env(

R/singletons.R

@@ -0,0 +1,34 @@
+## Shared singleton handling for the density-family types.
+##
+## type_density(), type_violin() and type_ridge() all estimate a density per
+## group, which means splitting `datapoints` on some combination of the primary
+## axis, `by` and `facet`, then discarding any cell too small to smooth.
+
+
+## Drop the split cells that are too small to estimate a density from.
+##
+## `datapoints` is the list returned by split(). `singletons` is one of "drop"
+## (silent), "warn" (drop, but say how many went), or "none" (keep them, and let
+## the bandwidth rules complain if they cannot cope).
+##
+## Note that this counts rows rather than filtering on them directly: split()
+## emits a cell for every level *combination*, so the 0-row cells it invents
+## have to be told apart from the 1-row cells the user actually supplied. Only
+## the latter are worth warning about; a plain Filter(nrow > 1) conflates the
+## two and reports groups that never existed.
+drop_singletons = function(datapoints, singletons) {
+    ## empty cells are an artefact of the split, never a user group, so they go
+    ## in every case
+    if (singletons == "none") {
+        return(Filter(function(k) nrow(k) > 0, datapoints))
+    }
+    nobs = vapply(datapoints, nrow, integer(1))
+    if (singletons == "warn" && any(nobs == 1L)) {
+        warning(
+            "Dropped ", sum(nobs == 1L), " singleton group(s). Densities ",
+            "require at least 2 observations.\n",
+            call. = FALSE
+        )
+    }
+    datapoints[nobs > 1L]
+}

R/type_density.R

@@ -30,6 +30,15 @@
 #'   left alone. Bandwidths shared across subgroups are reported once and named
 #'   as joint; individual bandwidths are reported per group, truncated after
 #'   three so the label stays legible.
+#' @param singletons character string indicating what to do with singleton
+#'   groups, i.e. combinations of `by` and `facet` that consist of only 1 row.
+#'   The default `"warn"` option removes any singleton cases and emits a
+#'   warning reporting how many there were. `"drop"` does the same thing, but
+#'   quietly. In either case the dropped groups may still be represented as
+#'   empty facets in your plot. Finally, `"none"` skips all singleton checks and
+#'   retains the affected groups; possibly leading to an error. Note that 
+#'   singletons require a numeric `bw`, since the data-driven bandwidth rules
+#'   need at least 2 observations.
 #'
 #' @section Bandwidth selection: While the choice of smoothing bandwidth will
 #'   always stand to affect a density visualization, it gains an added
@@ -116,9 +125,11 @@ type_density = function(
         n = 512,
         # more args from density here?
         echo.bw = FALSE,
-        alpha = NULL
+        alpha = NULL,
+        singletons = c("warn", "drop", "none")
     ) {
     kernel = match.arg(kernel, c("gaussian", "epanechnikov", "rectangular", "triangular", "biweight", "cosine", "optcosine"))
+    singletons = match.arg(singletons, c("warn", "drop", "none"))
     if (is.logical(joint.bw)) {
         joint.bw = ifelse(joint.bw, "mean", "none")
     }
@@ -127,7 +138,7 @@ type_density = function(
     out = list(
         data = data_density(bw = bw, adjust = adjust, kernel = kernel, n = n,
                             joint.bw = joint.bw, echo.bw = echo.bw,
-                            alpha = alpha),
+                            alpha = alpha, singletons = singletons),
         draw = NULL,
         name = "density"
     )
@@ -172,7 +183,7 @@ format_echo_vec = function(x, numeric = TRUE) {
 
 data_density = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512,
                         joint.bw = "none", echo.bw = character(0),
-                        alpha = NULL) {
+                        alpha = NULL, singletons = "warn") {
     fun = function(settings, ...) {
         env2env(settings, environment(), c("by", "bg", "facet", "ylab", "col", "ribbon.alpha", "datapoints"))
         ribbon.alpha = if (is.null(alpha)) .tpar[["ribbon.alpha"]] else (alpha)
@@ -182,7 +193,8 @@ data_density = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512,
         if (is.null(ylab)) ylab = "Density"
 
         datapoints = split(datapoints, list(datapoints$by, datapoints$facet))
-        datapoints = Filter(function(k) nrow(k) > 0, datapoints)
+        # datapoints = Filter(function(k) nrow(k) > 1, datapoints) # drop singletons (rather use dedicated function below)
+        datapoints = drop_singletons(datapoints, singletons)
 
         if (joint.bw == "none" || is.numeric(bw)) {
             dens_bw = bw

R/type_ridge.R

@@ -76,6 +76,15 @@
 #' 1, i.e. fully opaque. But for some `by` grouped plots (excepting the special
 #' cases where `by==y` or `by==x`), will default to 0.6.
 #'
+#' @param singletons character string indicating what to do with singleton
+#' groups, i.e. combinations of `y`, `by`, and `facet` that consist of only 1
+#' row. The default `"warn"` option removes any singleton cases and emits a
+#' warning reporting how many there were. `"drop"` does the same thing, but
+#' quietly. In either case the dropped groups may still be represented as empty
+#' ridge lines or facets in your plot. Finally, `"none"` skips all singleton
+#' checks and retains the affected groups; possibly leading to an error. Note
+#' that singletons require a numeric `bw`, since the data-driven bandwidth
+#' rules need at least 2 observations.
 #' @section Technical note on gradient fills:
 #'
 #' `tinyplot` uses two basic approaches for drawing gradient fills in ridge line
@@ -215,10 +224,12 @@ type_ridge = function(
     gradient = FALSE,
     raster = FALSE,
     col = NULL,
-    alpha = NULL
+    alpha = NULL,
+    singletons = c("warn", "drop", "none")
     ) {
 
   kernel = match.arg(kernel, c("gaussian", "epanechnikov", "rectangular", "triangular", "biweight", "cosine", "optcosine"))
+  singletons = match.arg(singletons, c("warn", "drop", "none"))
   if (is.logical(joint.bw)) {
     joint.bw = ifelse(joint.bw, "mean", "none")
   }
@@ -236,7 +247,8 @@ type_ridge = function(
                       ylevels = ylevels,
                       raster = raster,
                       col = col,
-                      alpha = alpha
+                      alpha = alpha,
+                      singletons = singletons
                       ),
     name = "ridge"
   )
@@ -256,7 +268,8 @@ data_ridge = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512,
                       ylevels = NULL,
                       raster = FALSE,
                       col = NULL,
-                      alpha = NULL
+                      alpha = NULL,
+                      singletons = "warn"
                       ) {
   fun = function(settings, ...) {
     env2env(settings, environment(), c("datapoints", "yaxt", "xaxt", "null_by"))
@@ -284,15 +297,16 @@ data_ridge = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512,
     if (isTRUE(x_by)) fill_by = FALSE
     # if (isTRUE(anyby) && is.null(alpha)) alpha = 0.6
 
+    if (!is.factor(datapoints$y)) datapoints$y = factor(datapoints$y)
     ## reorder levels of y-variable if requested
     if (!is.null(ylevels)) {
-      if (!is.factor(datapoints$y)) datapoints$y = factor(datapoints$y)
       datapoints$y = sanitize_xlevels(datapoints$y, ylevels, arg = "ylevels")
       if (y_by) datapoints$by = datapoints$y
     }
 
     ##
     datapoints = split(datapoints, list(datapoints$y, datapoints$by, datapoints$facet))
+    datapoints = drop_singletons(datapoints, singletons)
 
     if (joint.bw == "none" || is.numeric(bw)) {
         dens_bw = bw

R/type_violin.R

@@ -13,6 +13,15 @@
 #'   series colour(s)? Default is `TRUE`, which keeps single- and multi-group
 #'   displays consistent and lets the fill read cleanly over grid lines. Set to
 #'   `FALSE` to use the fully-saturated palette colour(s) instead.
+#' @param singletons character string indicating what to do with singleton
+#'   groups, i.e. combinations of `x`, `by`, and `facet` that consist of only 1
+#'   row. The default `"warn"` option removes any singleton cases and emits a
+#'   warning reporting how many there were. `"drop"` does the same thing, but
+#'   quietly. In either case the dropped groups may still be represented as
+#'   empty violins or facets in your plot. Finally, `"none"` skips all singleton
+#'   checks and retains the affected groups; possibly leading to an error. Note
+#'   that singletons require a numeric `bw`, since the data-driven bandwidth
+#'   rules need at least 2 observations.
 #' @inherit stats::density details
 #' @details See [`type_density`] for more details and considerations related to
 #'   bandwidth selection and kernel types.
@@ -64,17 +73,19 @@ type_violin = function(
         # more args from density here?
         trim = FALSE,
         width = 0.9,
-        lighten = TRUE
+        lighten = TRUE,
+        singletons = c("warn", "drop", "none")
     ) {
     kernel = match.arg(kernel, c("gaussian", "epanechnikov", "rectangular", "triangular", "biweight", "cosine", "optcosine"))
+    singletons = match.arg(singletons, c("warn", "drop", "none"))
     if (is.logical(joint.bw)) {
         joint.bw = ifelse(joint.bw, "mean", "none")
     }
     joint.bw = match.arg(joint.bw, c("mean", "full", "none"))
     out = list(
         data = data_violin(bw = bw, adjust = adjust, kernel = kernel, n = n,
                             joint.bw = joint.bw, trim = trim, width = width,
-                            lighten = lighten),
+                            lighten = lighten, singletons = singletons),
         # draw = NULL,
         # name = "polygon"
         draw = draw_polygon(density = NULL),
@@ -86,7 +97,7 @@ type_violin = function(
 
 data_violin = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512,
                         joint.bw = "none", trim = FALSE, width = 0.9,
-                        lighten = TRUE) {
+                        lighten = TRUE, singletons = "warn") {
     fun = function(settings, ...) {
         env2env(settings, environment(), c("datapoints", "by", "null_palette", "facet", "ylab", "col", "bg", "log", "null_by", "null_facet"))
         settings[["lighten"]] = lighten
@@ -147,7 +158,7 @@ data_violin = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512,
 
 
         datapoints = split(datapoints, list(datapoints$x, datapoints$by, datapoints$facet))
-        datapoints = Filter(function(k) nrow(k) > 0, datapoints)
+        datapoints = drop_singletons(datapoints, singletons)
 
         if (joint.bw == "none" || is.numeric(bw)) {
             dens_bw = bw