diff --git a/NEWS.md b/NEWS.md index 05f1bb31..70257988 100644 --- a/NEWS.md +++ b/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 diff --git a/R/assertions.R b/R/assertions.R index 564a8297..2b8ed343 100644 --- a/R/assertions.R +++ b/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) + } } diff --git a/R/environment.R b/R/environment.R index f6d66482..962b9078 100644 --- a/R/environment.R +++ b/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 ) diff --git a/R/tpar.R b/R/tpar.R index 2d653040..e6e1e074 100644 --- a/R/tpar.R +++ b/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) } diff --git a/R/utils.R b/R/utils.R index c32b2cd3..983502db 100644 --- a/R/utils.R +++ b/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) }