Internal settings container

.Rbuildignore

@@ -24,3 +24,4 @@ inst/user2025
 #inst/tinytest/
 Makefile
 ^.devcontainer
+Rplots.pdf

NAMESPACE

@@ -117,6 +117,7 @@ importFrom(stats,predict)
 importFrom(stats,qnorm)
 importFrom(stats,qt)
 importFrom(stats,quantile)
+importFrom(stats,setNames)
 importFrom(stats,spline)
 importFrom(stats,terms)
 importFrom(stats,weighted.mean)

NEWS.md

@@ -6,6 +6,10 @@ where the formatting is also better._
 
 ## Dev version
 
+### Breaking change
+
+- Internal settings and parameters are now stored in an environment called `settings`, which can be accessed and modified by type-specific functions. This may require changes to users' custom type functions that previously accessed settings as passed arguments. This change was necessary to improve the modularity and maintainability of the codebase, and to add flexibility. (#473 @vincentarelbundock and @grantmcdermott)
+
 ### New features
 
 - `type_text()` gains a `family` argument for controlling the font family,

R/by_aesthetics.R

@@ -1,4 +1,83 @@
-by_col = function(ngrps = 1L, col = NULL, palette = NULL, gradient = NULL, ordered = NULL, alpha = NULL) {
+#
+## orchestration function -----
+#
+
+by_aesthetics = function(settings) {
+  env2env(
+    settings,
+    environment(),
+    c(
+      "datapoints", "by", "type", "null_by", "pch", "bg", "lty", "lwd",
+      "bubble", "cex", "alpha", "col", "fill", "ribbon.alpha"
+    )
+  )
+
+  by_ordered = FALSE
+  by_continuous = !null_by && inherits(datapoints$by, c("numeric", "integer"))
+  if (isTRUE(by_continuous) && type %in% c("l", "b", "o", "ribbon", "polygon", "polypath", "boxplot")) {
+    warning("\nContinuous legends not supported for this plot type. Reverting to discrete legend.")
+    by_continuous = FALSE
+  } else if (!null_by) {
+    by_ordered = is.ordered(by)
+  }
+
+  if (null_by) {
+    ngrps = 1L
+  } else if (is.factor(by)) {
+    ngrps = nlevels(by)
+  } else if (by_continuous) {
+    ngrps = 100L
+  } else {
+    ngrps = length(unique(by))
+  }
+
+  pch = by_pch(ngrps = ngrps, type = type, pch = pch)
+  lty = by_lty(ngrps = ngrps, type = type, lty = lty)
+  lwd = by_lwd(ngrps = ngrps, type = type, lwd = lwd)
+  cex = by_cex(ngrps = ngrps, type = type, bubble = bubble, cex = cex)
+
+  col = by_col(
+    col = col,
+    palette = settings$palette, # must use unevaluated palette
+    alpha = alpha,
+    by_ordered = by_ordered,
+    by_continuous = by_continuous,
+    ngrps = ngrps,
+    adjustcolor = adjustcolor
+  )
+
+  bg = by_bg(
+    bg = bg,
+    fill = fill,
+    col = col,
+    palette = settings$palette, # must use unevaluated palette
+    alpha = alpha,
+    by_ordered = by_ordered,
+    by_continuous = by_continuous,
+    ngrps = ngrps,
+    type = type,
+    by = by,
+    ribbon.alpha = ribbon.alpha,
+    adjustcolor = adjustcolor
+  )
+
+  # update settings
+  env2env(
+    environment(),
+    settings,
+    c("by_continuous", "by_ordered", "ngrps", "pch", "lty", "lwd", "cex", "col", "bg")
+  )
+}
+
+
+#
+## subsidiary functions -----
+#
+
+by_col = function(col, palette, alpha, by_ordered, by_continuous, ngrps, adjustcolor) {
+  ordered = by_ordered
+  gradient = by_continuous
+
   if (is.null(alpha)) alpha = 1
   if (is.null(ordered)) ordered = FALSE
   if (is.null(gradient)) gradient = FALSE
@@ -271,6 +350,38 @@ gen_pal_fun = function(pal, gradient = FALSE, alpha = NULL, n = NULL) {
 }
 
 
+by_bg = function(bg, fill, col, palette, alpha, by_ordered, by_continuous, ngrps, type, by, ribbon.alpha, adjustcolor) {
+  if (is.null(bg) && !is.null(fill)) bg = fill
+  if (!is.null(bg) && length(bg) == 1 && is.numeric(bg) && bg >= 0 && bg <= 1) {
+    alpha = bg
+    bg = "by"
+  }
+  if (!is.null(bg) && length(bg) == 1 && bg == "by") {
+    # use by_col processing, but with the bg-specific colors
+    bg = by_col(
+      col = NULL,
+      palette = palette,
+      alpha = alpha,
+      by_ordered = by_ordered,
+      by_continuous = by_continuous,
+      ngrps = ngrps,
+      adjustcolor = adjustcolor
+    )
+  } else if (length(bg) != ngrps) {
+    bg = rep(bg, ngrps)
+  }
+  if (type == "ribbon" || (type == "boxplot" && !is.null(by))) {
+    if (!is.null(bg)) {
+      bg = adjustcolor(bg, ribbon.alpha)
+    } else if (!is.null(col)) {
+      bg = adjustcolor(col, ribbon.alpha)
+    }
+  }
+
+  bg
+}
+
+
 by_pch = function(ngrps, type, pch = NULL) {
   no_pch = FALSE
   if (identical(type, "text")) {
@@ -427,43 +538,3 @@ by_cex = function(ngrps, type, bubble = FALSE, cex = NULL) {
 
 
 
-by_bg = function(
-    adjustcolor,
-    alpha,
-    bg,
-    by,
-    by_continuous,
-    by_ordered,
-    col,
-    fill,
-    ngrps,
-    palette,
-    ribbon.alpha,
-    type) {
-  if (is.null(bg) && !is.null(fill)) bg = fill
-  if (!is.null(bg) && length(bg) == 1 && is.numeric(bg) && bg >= 0 && bg <= 1) {
-    alpha = bg
-    bg = "by"
-  }
-  if (!is.null(bg) && length(bg) == 1 && bg == "by") {
-    bg = by_col(
-      ngrps = ngrps,
-      col = NULL,
-      palette = palette,
-      gradient = by_continuous,
-      ordered = by_ordered,
-      alpha = alpha
-    )
-  } else if (length(bg) != ngrps) {
-    bg = rep(bg, ngrps)
-  }
-  if (type == "ribbon" || (type == "boxplot" && !is.null(by))) {
-    if (!is.null(bg)) {
-      bg = adjustcolor(bg, ribbon.alpha)
-    } else if (!is.null(col)) {
-      bg = adjustcolor(col, ribbon.alpha)
-    }
-  }
-
-  return(bg)
-}

R/draw_legend.R

@@ -707,10 +707,10 @@ sanitize_legend = function(legend, legend_args) {
         lnms = names(largs)
         # check second position b/c first will be a symbol
         if (is.null(lnms)) {
-          largs = stats::setNames(largs, c("", "x"))
+          largs = setNames(largs, c("", "x"))
         } else if (length(largs) >= 2 && lnms[2] == "") {
           lnms[2] = "x"
-          largs = stats::setNames(largs, lnms)
+          largs = setNames(largs, lnms)
         } else {
           largs[["x"]] = "right!"
         }

R/facet.R

@@ -23,8 +23,8 @@ draw_facet_window = function(
     nfacets, nfacet_cols, nfacet_rows,
     # axes args
     axes, flip, frame.plot, oxaxis, oyaxis,
-    xlabs, xlim, xlim_user, xaxt, xaxs, xaxb, xaxl,
-    ylabs, ylim, ylim_user, yaxt, yaxs, yaxb, yaxl,
+    xlabs, xlim, null_xlim, xaxt, xaxs, xaxb, xaxl,
+    ylabs, ylim, null_ylim, yaxt, yaxs, yaxb, yaxl,
     asp, log,
     # other args (in approx. alphabetical + group ordering)
     dots,
@@ -302,8 +302,8 @@ draw_facet_window = function(
         # individual facet.
         xfree = split(c(x, xmin, xmax), facet)[[ii]]
         yfree = split(c(y, ymin, ymax), facet)[[ii]]
-        if (!xlim_user) xlim = range(xfree, na.rm = TRUE)
-        if (!ylim_user) ylim = range(yfree, na.rm = TRUE)
+        if (null_xlim) xlim = range(xfree, na.rm = TRUE)
+        if (null_ylim) ylim = range(yfree, na.rm = TRUE)
         xext = extendrange(xlim, f = 0.04)
         yext = extendrange(ylim, f = 0.04)
         # We'll save this in a special .fusr env var (list) that we'll re-use
@@ -518,7 +518,27 @@ draw_facet_window = function(
 
 #' @rdname facet
 #' @keywords internal
-facet_layout = function(facet, add = FALSE, facet.args = list()) {
+#' @param settings A list of settings as created by `tinyplot()`.
+facet_layout = function(settings) {
+  # Extract needed variables from settings
+  add = settings$add
+  facet.args = settings$facet.args
+  datapoints = settings$datapoints
+  facet_attr = settings$facet_attr
+
+  # Simplify facet if only one unique value
+  facet = datapoints$facet
+  if (!is.null(facet) && length(unique(facet)) == 1) {
+    facet = NULL
+    datapoints$facet = NULL
+  }
+
+  # Restore facet attributes
+  if (!is.null(facet)) {
+    attributes(facet) = facet_attr
+    attributes(datapoints$facet) = facet_attr
+  }
+
   nfacet_rows = 1
   nfacet_cols = 1
   if (!is.null(facet)) {
@@ -565,15 +585,11 @@ facet_layout = function(facet, add = FALSE, facet.args = list()) {
     cex_fct_adj = 1
   }
 
-  list(
-    facets = facets,
-    ifacet = ifacet,
-    nfacets = nfacets,
-    nfacet_rows = nfacet_rows,
-    nfacet_cols = nfacet_cols,
-    oxaxis = oxaxis,
-    oyaxis = oyaxis,
-    cex_fct_adj = cex_fct_adj
+  # update settings
+  env2env(
+    environment(),
+    settings,
+    c("datapoints", "facets", "ifacet", "nfacets", "nfacet_rows", "nfacet_cols", "oxaxis", "oyaxis", "cex_fct_adj")
   )
 }
 

R/flip.R

@@ -0,0 +1,54 @@
+swap_elements = function(env, a, b) {
+  # Swap two elements in an environment
+  val_a = if (exists(a, envir = env, inherits = FALSE)) env[[a]] else NULL
+  val_b = if (exists(b, envir = env, inherits = FALSE)) env[[b]] else NULL
+
+  assign(a, val_b, envir = env)
+  assign(b, val_a, envir = env)
+}
+
+
+swap_columns = function(dp, a, b) {
+  va = dp[[a]]
+  vb = dp[[b]]
+  dp[[a]] = if (!is.null(vb)) vb else NULL
+  dp[[b]] = if (!is.null(va)) va else NULL
+  dp
+}
+
+
+flip_datapoints = function(settings) {
+  env2env(settings, environment(), c("flip", "type", "datapoints", "log"))
+
+  assert_flag(flip)
+  if (isTRUE(flip)) {
+    if (type == "boxplot") {
+      # boxplot: let horizontal=TRUE do most work; only swap labels
+      swap_elements(settings, "xlab", "ylab")
+    } else {
+      datapoints = swap_columns(datapoints, "xmin", "ymin")
+      datapoints = swap_columns(datapoints, "xmax", "ymax")
+      datapoints = swap_columns(datapoints, "x", "y")
+
+      # Swap all the x/y settings in the environment
+      swap_elements(settings, "x", "y")
+      swap_elements(settings, "xaxb", "yaxb")
+      swap_elements(settings, "xaxl", "yaxl")
+      swap_elements(settings, "xaxs", "yaxs")
+      swap_elements(settings, "xaxt", "yaxt")
+      swap_elements(settings, "xlab", "ylab")
+      swap_elements(settings, "xlabs", "ylabs")
+      swap_elements(settings, "xlim", "ylim")
+      swap_elements(settings, "xmax", "ymax")
+      swap_elements(settings, "xmin", "ymin")
+
+      if (!is.null(log)) {
+        log = chartr("xy", "yx", log)
+        assign("log", log, envir = settings)
+      }
+
+      # Copy modified datapoints back
+      assign("datapoints", datapoints, envir = settings)
+    }
+  }
+}

R/lim.R

@@ -1,30 +1,49 @@
 # calculate limits of each plot
 
-lim_args = function(
-    datapoints,
-    xlim, ylim,
-    xaxb = NULL, yaxb = NULL,
-    xlim_user = FALSE, ylim_user = FALSE,
-    type
-) {
-
+lim_args = function(settings) {
+  env2env(
+    settings,
+    environment(),
+    c(
+      "xaxb", "xlabs", "xlim", "null_xlim", 
+      "yaxb", "ylabs", "ylim", "null_ylim",
+      "datapoints", "type"
+    )
+  )
+
+  # For cases where x/yaxb is provided and corresponding x/ylabs is not null...
+  # We can subset these here to provide breaks
+  if (!is.null(xaxb) && !is.null(xlabs)) {
+    xlabs = xlabs[names(xlabs) %in% xaxb]
+    xaxb = NULL # don't need this any more
+  }
+  if (!is.null(yaxb) && !is.null(ylabs)) {
+    ylabs = ylabs[names(ylabs) %in% yaxb]
+    yaxb = NULL # don't need this any more
+  }
+
   if (is.null(xlim)) {
-    xlim = range(c(datapoints[["x"]], datapoints[["xmin"]],
-                   datapoints[["xmax"]]), finite = TRUE)
+    xlim = range(c(
+      datapoints[["x"]], datapoints[["xmin"]],
+      datapoints[["xmax"]]), finite = TRUE)
   }
   if (is.null(ylim)) {
-    ylim = range(c(datapoints[["y"]], datapoints[["ymin"]],
-                   datapoints[["ymax"]]), finite = TRUE)
+    ylim = range(c(
+      datapoints[["y"]], datapoints[["ymin"]],
+      datapoints[["ymax"]]), finite = TRUE)
   }
 
   if (identical(type, "boxplot")) {
     xlim = xlim + c(-0.5, 0.5)
   }
-
-  if (!xlim_user && !is.null(xaxb) && type != "spineplot") xlim = range(c(xlim, xaxb))
-  if (!ylim_user && !is.null(yaxb) && type != "spineplot") ylim = range(c(ylim, yaxb))
 
-  out = list(xlim = xlim, ylim = ylim)
-  return(out)
-}
+  if (null_xlim && !is.null(xaxb) && type != "spineplot") xlim = range(c(xlim, xaxb))
+  if (null_ylim && !is.null(yaxb) && type != "spineplot") ylim = range(c(ylim, yaxb))
 
+  # update settings
+  env2env(
+    environment(),
+    settings,
+    c("xlim", "ylim", "xlabs", "ylabs", "xaxb", "yaxb")
+  )
+}