(perf:) Miscellaneous performance improvements

NEWS.md

@@ -311,6 +311,10 @@ not 'at'`. The free-facet code path listed the eligible types by name, so
 - Gradient legends drawn below the plot (e.g. `legend = "bottom!"`) no longer
   ride up over the x-axis under dynamic themes. (#719 @grantmcdermott)
 
+### Internals
+
+- Performance improvemnts. (#723 @grantmcdermott)
+
 ## v0.7.0
 
 **tinyplot** v0.7.0 is a big release with many new features, including major

R/assertions.R

@@ -40,9 +40,8 @@ check_true = function(x, null.ok = FALSE) {
 }
 
 assert_true = function(x, null.ok = FALSE, name = as.character(substitute(x))) {
-  msg = sprintf("`%s` must be true.", name)
   if (!isTRUE(check_true(x, null.ok = null.ok))) {
-    stop(msg, call. = FALSE)
+    stop(sprintf("`%s` must be true.", name), call. = FALSE)
   }
 }
 
@@ -57,9 +56,8 @@ check_string = function(x, null.ok = FALSE) {
 }
 
 assert_string = function(x, null.ok = FALSE, name = as.character(substitute(x))) {
-  msg = sprintf("`%s` must be a string.", name)
   if (!isTRUE(check_string(x, null.ok = null.ok))) {
-    stop(msg, call. = FALSE)
+    stop(sprintf("`%s` must be a string.", name), call. = FALSE)
   }
 }
 
@@ -74,9 +72,8 @@ check_flag = function(x, null.ok = FALSE) {
 }
 
 assert_flag = function(x, null.ok = FALSE, name = as.character(substitute(x))) {
-  msg = sprintf("`%s` must be a logical flag.", name)
   if (!isTRUE(check_flag(x, null.ok = null.ok))) {
-    stop(msg, call. = FALSE)
+    stop(sprintf("`%s` must be a logical flag.", name), call. = FALSE)
   }
 }
 
@@ -146,8 +143,8 @@ assert_length = function(x, len = 1, null.ok = FALSE, name = as.character(substi
   if (is.null(x) && isTRUE(null.ok)) {
     return(invisible(TRUE))
   }
-  msg = sprintf("`%s` must be one of these lengths: %s", name, paste(len, collapse = ", "))
   if (!length(x) %in% len) {
+    msg = sprintf("`%s` must be one of these lengths: %s", name, paste(len, collapse = ", "))
     stop(msg, call. = FALSE)
   }
 }
@@ -165,8 +162,9 @@ assert_logical = function(x, null.ok = FALSE, name = as.character(substitute(x))
   if (is.null(x) && isTRUE(null.ok)) {
     return(invisible(TRUE))
   }
-  msg = sprintf("`%s` must be a logical vector", name)
-  if (!is.logical(x)) stop(msg, call. = FALSE)
+  if (!is.logical(x)) {
+    stop(sprintf("`%s` must be a logical vector", name), call. = FALSE)
+  }
 }
 
 
@@ -197,9 +195,9 @@ assert_integerish = function(x, len = NULL, lower = NULL, upper = NULL, null.ok
   if (isTRUE(null.ok) && is.null(x)) {
     return(invisible())
   }
-  msg = sprintf("`%s` must be integer-ish", name)
   if (is.null(x) && !isTRUE(null.ok)) stop(sprintf("%s should not be NULL.", name), call. = FALSE)
   if (!isTRUE(check_integerish(x, len = len, lower = lower, upper = upper, null.ok = null.ok))) {
+    msg = sprintf("`%s` must be integer-ish", name)
     if (!is.numeric(x)) msg = paste0(msg, "; it is not numeric")
     if (!is.null(len) && length(x) != len) msg = paste0(msg, sprintf("; its length must be %s", len))
     if (!is.null(lower) && any(x < lower)) msg = paste0(msg, sprintf("; all values must be greater than or equal to %s", lower))
@@ -229,8 +227,8 @@ check_numeric = function(x, len = NULL, lower = NULL, upper = NULL, null.ok = TR
 }
 
 assert_numeric = function(x, len = NULL, lower = NULL, upper = NULL, null.ok = FALSE, name = as.character(substitute(x))) {
-  msg = sprintf("`%s` must be numeric", name)
   if (!isTRUE(check_numeric(x, len = len, lower = lower, upper = upper, null.ok = null.ok))) {
+    msg = sprintf("`%s` must be numeric", name)
     if (!is.null(len) && length(x) != len) msg = paste0(msg, sprintf("; its length must be %s", len))
     if (!is.null(lower) && any(x < lower)) msg = paste0(msg, sprintf("; all values must be greater than or equal to %s", lower))
     if (!is.null(upper) && any(x > upper)) msg = paste0(msg, sprintf("; all values must be less than or equal to %s", upper))
@@ -239,12 +237,17 @@ assert_numeric = function(x, len = NULL, lower = NULL, upper = NULL, null.ok = F
 }
 
 assert_data_frame = function(x, min_rows = 0, min_cols = 0, name = as.character(substitute(x))) {
-  msg = sprintf("`%s` must be a data.frame.", name)
-  if (!is.data.frame(x)) stop(msg, call. = FALSE)
-  msg = sprintf("Number of rows in `%s` must be at least `%s`", name, min_rows)
-  if (nrow(x) < min_rows) stop(msg, call. = FALSE)
-  msg = sprintf("Number of columns in `%s` must be at least `%s`", name, min_cols)
-  if (ncol(x) < min_cols) stop(msg, call. = FALSE)
+  if (!is.data.frame(x)) {
+    stop(sprintf("`%s` must be a data.frame.", name), call. = FALSE)
+  }
+  if (nrow(x) < min_rows) {
+    msg = sprintf("Number of rows in `%s` must be at least `%s`", name, min_rows)
+    stop(msg, call. = FALSE)
+  }
+  if (ncol(x) < min_cols) {
+    msg = sprintf("Number of columns in `%s` must be at least `%s`", name, min_cols)
+    stop(msg, call. = FALSE)
+  }
 }
 
 

R/environment.R

@@ -36,5 +36,6 @@ set_environment_variable(
   .saved_par_first = NULL,
   .last_call = NULL,
   .tpar_hooks = NULL,
-  .registered_themes = NULL
+  .registered_themes = NULL,
+  .base_par_names = NULL
 )

R/tpar.R

@@ -215,17 +215,41 @@ tpar = function(..., hook = FALSE) {
 }
 
 
+# Names that base par() recognises. Querying par() for anything else emits a
+# warning, and raising then suppressing it costs about four times the lookup
+# itself. Most tpar parameters are tinyplot's own (grid.bg, palette, x/yaxr,
+# ...), so without this guard every plot pays that penalty a dozen times over.
+#
+# Cached in .tinyplot_env on first use rather than at load time: par() needs an
+# open device, and calling it from .onLoad would open one as a side effect
+# (writing a stray Rplots.pdf). The name set does not vary by device, so a
+# single per-session cache is safe.
+base_par_names = function() {
+  # read directly rather than via get_environment_variable(): this sits on a
+  # path hit ~24 times per plot, where the helper's overhead is measurable
+  bpn = .tinyplot_env[[".base_par_names"]]
+  if (is.null(bpn)) {
+    # no.readonly = FALSE is the full set, including the read-only pars
+    # (cin, cra, csi, cxy, din, page); those cannot be set but are valid to
+    # query, so they belong here
+    bpn = names(par(no.readonly = FALSE))
+    set_environment_variable(.base_par_names = bpn)
+  }
+  return(bpn)
+}
+
 # Two levels of priority: .tpar[["name"]] -> par("name")
 get_tpar = function(opts, default = NULL, tpar_list = NULL) {
   if (is.null(tpar_list)) tpar_list = .tpar
   # parameter priority
   # .tpar[["name"]] -> par("name")
+  bpn = base_par_names()
   for (o in opts) {
     tp = tpar_list[[o]]
     if (!is.null(tp)) {
       return(tp)
-    } else {
-      p = suppressWarnings(par(o))
+    } else if (o %in% bpn) {
+      p = par(o)
       if (!is.null(p)) {
         return(p)
       }

R/utils.R

@@ -112,9 +112,15 @@ env2env = function(source_env, target_env, keys = NULL) {
   if (is.null(keys)) {
     keys = ls(source_env, all.names = TRUE)
   }
-  for (nm in keys) {
-    assign(nm, source_env[[nm]], envir = target_env)
-  }
+  ## copy in one shot rather than one assign() per key: a single plot moves a
+  ## few hundred keys across ~20 calls, where the loop is about 4x slower.
+  ## ifnotfound preserves the old behaviour of writing NULL for an absent key,
+  ## and mget()'s inherits = FALSE default matches `[[` on an environment.
+  list2env(
+    mget(keys, envir = source_env, ifnotfound = list(NULL)),
+    envir = target_env
+  )
+  invisible(NULL)
 }