diff --git a/.Rbuildignore b/.Rbuildignore index ae214709..a80e032c 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -24,3 +24,4 @@ inst/user2025 #inst/tinytest/ Makefile ^.devcontainer +Rplots.pdf diff --git a/NAMESPACE b/NAMESPACE index 8da8515d..07e97949 100644 --- a/NAMESPACE +++ b/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) diff --git a/NEWS.md b/NEWS.md index d1863e24..1d76a7f8 100644 --- a/NEWS.md +++ b/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, diff --git a/R/by_aesthetics.R b/R/by_aesthetics.R index 400b9e87..9216bd26 100755 --- a/R/by_aesthetics.R +++ b/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) -} diff --git a/R/draw_legend.R b/R/draw_legend.R index 7269f835..b8ddee0e 100644 --- a/R/draw_legend.R +++ b/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!" } diff --git a/R/facet.R b/R/facet.R index 68e36863..0a1a1fcb 100644 --- a/R/facet.R +++ b/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") ) } diff --git a/R/flip.R b/R/flip.R new file mode 100644 index 00000000..c1787c47 --- /dev/null +++ b/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) + } + } +} diff --git a/R/lim.R b/R/lim.R index 46ed59e2..46d9c0e4 100644 --- a/R/lim.R +++ b/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") + ) +} diff --git a/R/sanitize.R b/R/sanitize.R deleted file mode 100644 index 5d4aa811..00000000 --- a/R/sanitize.R +++ /dev/null @@ -1,139 +0,0 @@ -sanitize_ribbon.alpha = function(ribbon.alpha) { - assert_numeric(ribbon.alpha, len = 1, lower = 0, upper = 1, null.ok = TRUE) - if (is.null(ribbon.alpha)) ribbon.alpha = .tpar[["ribbon.alpha"]] - return(ribbon.alpha) -} - - - -sanitize_type = function(type, x, y, dots) { - if (inherits(type, "tinyplot_type")) { - return(type) - } - - known_types = c( - "p", "l", "o", "b", "c", "h", "j", "s", "S", "n", - "abline", - "area", - "bar", "barplot", - "box", "boxplot", - "density", - "errorbar", - "function", - "glm", - "hist", "histogram", - "hline", - "j", "jitter", - "lines", - "lm", - "loess", - "pointrange", - "points", - "polygon", "polypath", - "qq", - "rect", - "ribbon", - "ridge", - "rug", - "segments", - "spine", "spineplot", - "spline", - "summary", - "text", - "violin", - "vline" - ) - assert_choice(type, known_types, null.ok = TRUE) - - if (is.null(type)) { - if (!is.null(x) && (is.factor(x) || is.character(x)) && !(is.factor(y) || is.character(y))) { - # enforce boxplot type for y ~ factor(x) - type = type_boxplot - } else if (is.factor(y) || is.character(y)) { - # enforce spineplot type for factor(y) ~ x - type = type_spineplot - } else { - type = "p" - } - } - - if (is.character(type)) type = switch(type, - "abline" = type_abline, - "area" = type_area, - "bar" = type_barplot, - "barplot" = type_barplot, - "box" = type_boxplot, - "boxplot" = type_boxplot, - "density" = type_density, - "errorbar" = type_errorbar, - "function" = type_function, - "glm" = type_glm, - "hist" = type_histogram, - "histogram" = type_histogram, - "hline" = type_hline, - "j" = type_jitter, - "jitter" = type_jitter, - "lines" = type_lines, - "lm" = type_lm, - "loess" = type_loess, - "p" = type_points, - "pointrange" = type_pointrange, - "points" = type_points, - "polygon" = type_polygon, - "polypath" = type_polypath, - "qq" = type_qq, - "rect" = type_rect, - "ribbon" = type_ribbon, - "ridge" = type_ridge, - "rug" = type_rug, - "segments" = type_segments, - "spine" = type_spineplot, - "spineplot" = type_spineplot, - "spline" = type_spline, - "summary" = type_summary, - "text" = type_text, - "violin" = type_violin, - "vline" = type_vline, - type # default case - ) - - if (is.function(type)) { - args = intersect(names(formals(type)), names(dots)) - args = if (length(args) >= 1L) dots[args] else list() - type = do.call(type, args) - type$dots = dots[setdiff(names(dots), names(args))] - } - - if (inherits(type, "tinyplot_type")) return(type) - - out = list(draw = NULL, data = NULL, name = type) - return(out) -} - - - -sanitize_axes = function(axes, xaxt, yaxt, frame.plot) { - ## handle defaults of axes, xaxt, yaxt, frame.plot - ## - convert axes to character if necessary - ## - set defaults of xaxt/yaxt (if these are NULL) based on axes - ## - set logical axes based on xaxt/yaxt - ## - set frame.plot default based on xaxt/yaxt - if (isFALSE(axes)) { - axes = xaxt = yaxt = "none" - } else if (isTRUE(axes)) { - axes = "standard" - if (is.null(xaxt)) xaxt = get_tpar("xaxt", default = "standard") - if (is.null(yaxt)) yaxt = get_tpar("yaxt", default = "standard") - } else { - xaxt = yaxt = axes - } - axis_types = c("standard", "none", "labels", "ticks", "axis") - axes = match.arg(axes, axis_types) - xaxt = match.arg(xaxt, axis_types) - yaxt = match.arg(yaxt, axis_types) - xaxt = substr(match.arg(xaxt, axis_types), 1L, 1L) - yaxt = substr(match.arg(yaxt, axis_types), 1L, 1L) - axes = any(c(xaxt, yaxt) != "n") - if (is.null(frame.plot) || !is.logical(frame.plot)) frame.plot = all(c(xaxt, yaxt) %in% c("s", "a")) - return(list(axes = axes, xaxt = xaxt, yaxt = yaxt, frame.plot = frame.plot)) -} diff --git a/R/sanitize_axes.R b/R/sanitize_axes.R new file mode 100644 index 00000000..a04dceff --- /dev/null +++ b/R/sanitize_axes.R @@ -0,0 +1,28 @@ +sanitize_axes = function(settings) { + env2env(settings, environment(), c("axes", "xaxt", "yaxt", "frame.plot")) + ## handle defaults of axes, xaxt, yaxt, frame.plot + ## - convert axes to character if necessary + ## - set defaults of xaxt/yaxt (if these are NULL) based on axes + ## - set logical axes based on xaxt/yaxt + ## - set frame.plot default based on xaxt/yaxt + if (isFALSE(axes)) { + axes = xaxt = yaxt = "none" + } else if (isTRUE(axes)) { + axes = "standard" + if (is.null(xaxt)) xaxt = get_tpar("xaxt", default = "standard") + if (is.null(yaxt)) yaxt = get_tpar("yaxt", default = "standard") + } else { + xaxt = yaxt = axes + } + axis_types = c("standard", "none", "labels", "ticks", "axis") + axes = match.arg(axes, axis_types) + xaxt = match.arg(xaxt, axis_types) + yaxt = match.arg(yaxt, axis_types) + xaxt = substr(match.arg(xaxt, axis_types), 1L, 1L) + yaxt = substr(match.arg(yaxt, axis_types), 1L, 1L) + axes = any(c(xaxt, yaxt) != "n") + if (is.null(frame.plot) || !is.logical(frame.plot)) frame.plot = all(c(xaxt, yaxt) %in% c("s", "a")) + + + env2env(environment(), settings, c("axes", "xaxt", "yaxt", "frame.plot")) +} diff --git a/R/sanitize_datapoints.R b/R/sanitize_datapoints.R new file mode 100644 index 00000000..c8f0e425 --- /dev/null +++ b/R/sanitize_datapoints.R @@ -0,0 +1,44 @@ +sanitize_datapoints = function(settings) { + # potentially useful variables + env2env(settings, environment(), c("x", "xmin", "xmax", "xaxt", "y", "ymin", "ymax", "ygroup", "facet", "null_by", "by", "type")) + + ## coerce character variables to factors + if (!is.null(x) && is.character(x)) x = factor(x) + if (!is.null(y) && is.character(y)) y = factor(y) + + if (is.null(x)) { + ## Special catch for rect and segment plots without a specified y-var + if (type %in% c("rect", "segments")) { + x = rep(NA, length(x)) + } + } + + if (is.null(y)) { + ## Special catch for area and interval plots without a specified y-var + if (type %in% c("rect", "segments", "pointrange", "errorbar", "ribbon")) { + y = rep(NA, length(x)) + } else if (type == "boxplot") { + y = x + x = rep.int("", length(y)) + xaxt = "a" + } else if (!(type %in% c("histogram", "barplot", "density", "function"))) { + y = x + x = seq_along(x) + } + } + + datapoints = list( + x = x, xmin = xmin, xmax = xmax, + y = y, ymin = ymin, ymax = ymax, ygroup = ygroup + ) + datapoints = Filter(function(z) length(z) > 0, datapoints) + datapoints = data.frame(datapoints) + if (nrow(datapoints) > 0) { + datapoints[["rowid"]] = seq_len(nrow(datapoints)) + datapoints[["facet"]] = if (!is.null(facet)) facet else "" + datapoints[["by"]] = if (!null_by) by else "" + } + + # potentially modified variables + env2env(environment(), settings, c("x", "y", "xaxt", "datapoints")) +} diff --git a/R/sanitize_facet.R b/R/sanitize_facet.R new file mode 100644 index 00000000..baddd8a5 --- /dev/null +++ b/R/sanitize_facet.R @@ -0,0 +1,29 @@ +sanitize_facet = function(settings) { + env2env( + settings, + environment(), + c("facet", "by", "null_facet", "facet_attr", "facet_by") + ) + + # flag if facet=="by" (i.e., facet matches the grouping variable) + facet_by = FALSE + 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 + } 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_attr = attributes(facet) # TODO: better way to restore facet attributes? + null_facet = is.null(facet) + + # update settings + env2env( + environment(), + settings, + c("facet", "null_facet", "facet_attr", "facet_by", "by") + ) +} diff --git a/R/sanitize_ribbon_alpha.R b/R/sanitize_ribbon_alpha.R new file mode 100644 index 00000000..7bc273e8 --- /dev/null +++ b/R/sanitize_ribbon_alpha.R @@ -0,0 +1,5 @@ +sanitize_ribbon_alpha = function(ribbon.alpha) { + assert_numeric(ribbon.alpha, len = 1, lower = 0, upper = 1, null.ok = TRUE) + if (is.null(ribbon.alpha)) ribbon.alpha = .tpar[["ribbon.alpha"]] + return(ribbon.alpha) +} diff --git a/R/sanitize_type.R b/R/sanitize_type.R new file mode 100644 index 00000000..c9c7377b --- /dev/null +++ b/R/sanitize_type.R @@ -0,0 +1,111 @@ +sanitize_type = function(settings) { + env2env(settings, environment(), c("type", "dots", "x", "y")) + + if (inherits(type, "tinyplot_type")) { + settings$type = type$name + settings$type_draw = type$draw + settings$type_data = type$data + return(invisible(NULL)) + } + + known_types = c( + "p", "l", "o", "b", "c", "h", "j", "s", "S", "n", + "abline", + "area", + "bar", "barplot", + "box", "boxplot", + "density", + "errorbar", + "function", + "glm", + "hist", "histogram", + "hline", + "j", "jitter", + "lines", + "lm", + "loess", + "pointrange", + "points", + "polygon", "polypath", + "qq", + "rect", + "ribbon", + "ridge", + "rug", + "segments", + "spine", "spineplot", + "spline", + "summary", + "text", + "violin", + "vline" + ) + assert_choice(type, known_types, null.ok = TRUE) + + if (is.null(type)) { + if (!is.null(x) && (is.factor(x) || is.character(x)) && !(is.factor(y) || is.character(y))) { + # enforce boxplot type for y ~ factor(x) + type = type_boxplot + } else if (is.factor(y) || is.character(y)) { + # enforce spineplot type for factor(y) ~ x + type = type_spineplot + } else { + type = "p" + } + } + + if (is.character(type)) { + type = switch(type, + "abline" = type_abline, + "area" = type_area, + "bar" = type_barplot, + "barplot" = type_barplot, + "box" = type_boxplot, + "boxplot" = type_boxplot, + "density" = type_density, + "errorbar" = type_errorbar, + "function" = type_function, + "glm" = type_glm, + "hist" = type_histogram, + "histogram" = type_histogram, + "hline" = type_hline, + "j" = type_jitter, + "jitter" = type_jitter, + "lines" = type_lines, + "lm" = type_lm, + "loess" = type_loess, + "p" = type_points, + "pointrange" = type_pointrange, + "points" = type_points, + "polygon" = type_polygon, + "polypath" = type_polypath, + "qq" = type_qq, + "rect" = type_rect, + "ribbon" = type_ribbon, + "ridge" = type_ridge, + "rug" = type_rug, + "segments" = type_segments, + "spine" = type_spineplot, + "spineplot" = type_spineplot, + "spline" = type_spline, + "summary" = type_summary, + "text" = type_text, + "violin" = type_violin, + "vline" = type_vline, + type # default case + ) + } + + if (is.function(type)) { + args = intersect(names(formals(type)), names(dots)) + args = if (length(args) >= 1L) dots[args] else list() + type = do.call(type, args) + type$dots = dots[setdiff(names(dots), names(args))] + } + + if (inherits(type, "tinyplot_type")) { + settings$type = type$name + settings$type_draw = type$draw + settings$type_data = type$data + } +} diff --git a/R/sanitize_xylab.R b/R/sanitize_xylab.R index f1d3600f..6ea3a3af 100644 --- a/R/sanitize_xylab.R +++ b/R/sanitize_xylab.R @@ -1,7 +1,14 @@ -sanitize_xylab = function( - x, xlab = NULL, x_dep = NULL, xmin_dep = NULL, xmax_dep = NULL, - y, ylab = NULL, y_dep = NULL, ymin_dep = NULL, ymax_dep = NULL, - type = NULL) { +sanitize_xylab = function(settings) { + env2env( + settings, + environment(), + c( + "type", + "x", "xlab", "x_dep", "xmin_dep", "xmax_dep", + "y", "ylab", "y_dep", "ymin_dep", "ymax_dep" + ) + ) + out_xlab = NULL out_ylab = NULL @@ -49,6 +56,6 @@ sanitize_xylab = function( out_ylab = NULL } - out = list(xlab = out_xlab, ylab = out_ylab) - return(out) + settings$xlab = out_xlab + settings$ylab = out_ylab } diff --git a/R/setup_device.R b/R/setup_device.R index e3837748..76441fca 100644 --- a/R/setup_device.R +++ b/R/setup_device.R @@ -1,4 +1,6 @@ -setup_device = function(file, width, height) { +setup_device = function(settings) { + env2env(settings, environment(), c("file", "width", "height")) + # write to file if (!is.null(file)) { filepath = file @@ -30,7 +32,7 @@ setup_device = function(file, width, height) { dop$new = FALSE # catch for some interfaces par(dop) - # interactive plot with user-specified width/height + # interactive plot with user-specified width/height } else if (!is.null(width) || !is.null(height)) { devwidth = width devheight = height diff --git a/R/tinyplot.R b/R/tinyplot.R index 597b8f05..4906d4df 100644 --- a/R/tinyplot.R +++ b/R/tinyplot.R @@ -370,7 +370,7 @@ #' @importFrom grDevices axisTicks adjustcolor cairo_pdf colorRampPalette extendrange palette palette.colors palette.pals hcl.colors hcl.pals xy.coords png jpeg pdf svg dev.off dev.new dev.list #' @importFrom graphics abline arrows axis Axis axTicks box boxplot grconvertX grconvertY hist lines mtext par plot.default plot.new plot.window points polygon polypath segments rect text title #' @importFrom utils modifyList head tail -#' @importFrom stats na.omit +#' @importFrom stats na.omit setNames #' @importFrom tools file_ext #' #' @examples @@ -680,7 +680,6 @@ tinyplot.default = function( # Ephemeral theme if (!is.null(theme)) { - # browser() if (is.character(theme) && length(theme) == 1) { tinytheme(theme) } else if (is.list(theme)) { @@ -696,299 +695,220 @@ tinyplot.default = function( # - ## devices and files ----- + ## settings container ----- # - # Write plot to output file or window with fixed dimensions - setup_device(file = file, width = width, height = height) - if (!is.null(file)) on.exit(dev.off(), add = TRUE) + dots = list(...) + + settings_list = list( + # save call to check user input later + call = match.call(), + + # save to file & device dimensions + file = file, + width = width, + height = height, + + # deparsed input for use in labels + by_dep = deparse1(substitute(by)), + cex_dep = if (!is.null(cex)) deparse1(substitute(cex)) else NULL, + facet_dep = deparse1(substitute(facet)), + x_dep = if (is.null(x)) NULL else deparse1(substitute(x)), + xmax_dep = if (is.null(xmax)) NULL else deparse1(substitute(xmax)), + xmin_dep = if (is.null(xmin)) NULL else deparse1(substitute(xmin)), + y_dep = if (is.null(y)) NULL else deparse1(substitute(y)), + ymax_dep = if (is.null(ymax)) NULL else deparse1(substitute(ymax)), + ymin_dep = if (is.null(ymin)) NULL else deparse1(substitute(ymin)), + + # types + type = type, + type_data = NULL, + type_draw = NULL, + type_name = NULL, + + # type-specific settings + bubble = FALSE, + ygroup = NULL, # for type_ridge() + + # data points and labels + x = x, + xmax = xmax, + xmin = xmin, + xlab = xlab, + xlabs = NULL, + y = y, + ymax = ymax, + ymin = ymin, + ylab = ylab, + ylabs = NULL, + + # axes + axes = axes, + xaxt = xaxt, + xaxb = xaxb, + xaxl = xaxl, + xaxs = xaxs, + yaxt = yaxt, + yaxb = yaxb, + yaxl = yaxl, + yaxs = yaxs, + frame.plot = frame.plot, + xlim = xlim, + ylim = ylim, + + # flags to check user input (useful later on) + null_by = is.null(by), + null_xlim = is.null(xlim), + null_ylim = is.null(ylim), + # when palette functions need pre-processing this check raises error + null_palette = tryCatch(is.null(palette), error = function(e) FALSE), + was_area_type = identical(type, "area"), # mostly for legend + x_by = identical(x, by), # for "boxplot", "spineplot" and "ridges" + + + # unevaluated expressions with side effects + draw = substitute(draw), + facet = facet, + facet.args = facet.args, + palette = substitute(palette), + legend = if (add) FALSE else substitute(legend), + + # aesthetics + lty = lty, + lwd = lwd, + col = col, + bg = bg, + log = log, + fill = fill, + alpha = alpha, + cex = cex, + pch = if (is.null(pch)) get_tpar("pch", default = NULL) else pch, + + # ribbon.alpha overwritten by some type_data() functions + # sanitize_ribbon_alpha: returns default alpha transparency for ribbon-type plots + ribbon.alpha = sanitize_ribbon_alpha(NULL), + + # misc + flip = flip, + by = by, + dots = dots, + type_info = list() # pass type-specific info from type_data to type_draw + ) + settings = new.env() + list2env(settings_list, settings) # - ## deparsed expressions for labels ----- + ## devices and files ----- # - - x_dep = if (is.null(x)) NULL else deparse1(substitute(x)) - xmin_dep = if (is.null(xmin)) NULL else deparse1(substitute(xmin)) - xmax_dep = if (is.null(xmax)) NULL else deparse1(substitute(xmax)) - y_dep = if (is.null(y)) NULL else deparse1(substitute(y)) - ymin_dep = if (is.null(ymin)) NULL else deparse1(substitute(ymin)) - ymax_dep = if (is.null(ymax)) NULL else deparse1(substitute(ymax)) - by_dep = deparse1(substitute(by)) - cex_dep = if (!is.null(cex)) deparse1(substitute(cex)) else NULL - facet_dep = deparse1(substitute(facet)) + # Write plot to output file or window with fixed dimensions + setup_device(settings) + if (!is.null(settings$file)) on.exit(dev.off(), add = TRUE) # ## sanitize arguments ----- # - # init variables - xlabs = ylabs = NULL - ygroup = NULL # type_ridge() - bubble = FALSE - - # ellipsis - dots = list(...) + # extract legend_args from dots + if ("legend_args" %in% names(dots)) { + settings$legend_args = settings$dots[["legend_args"]] + settings$dots$legend_args = NULL # avoid passing both directly and via ... + } else { + settings$legend_args = list(x = NULL) + } - # draw - draw = substitute(draw) + # alias: bg = fill + if (is.null(bg) && !is.null(fill)) settings$bg = fill - # type - # sanitize_type: validates/converts type argument and returns list with name, data, and draw components - type = sanitize_type(type, x, y, dots) - if ("dots" %in% names(type)) dots = type$dots - type_data = type$data - type_draw = type$draw - type = type$name + # validate types and returns a list with name, data, and draw components + sanitize_type(settings) - # area flag (mostly for legend) - was_area_type = identical(type, "area") - - # legend - if (add) legend = FALSE - if (!exists("legend_args")) { - legend_args = dots[["legend_args"]] - dots[["legend_args"]] = NULL - } - if (is.null(legend_args)) legend_args = list(x = NULL) - legend = substitute(legend) + # standardize axis arguments and returns consistent axes, xaxt, yaxt, frame.plot + sanitize_axes(settings) - # palette - palette = substitute(palette) + # generate appropriate axis labels based on input data and plot type + sanitize_xylab(settings) - # themes - if (is.null(palette)) palette = get_tpar("palette", default = NULL) - if (is.null(pch)) pch = get_tpar("pch", default = NULL) - - # alias: bg = fill - if (is.null(bg) && !is.null(fill)) bg = fill - - # ribbon.alpha is overwritten by some type_data() functions - # sanitize_ribbon.alpha: returns default alpha transparency value for ribbon-type plots - ribbon.alpha = sanitize_ribbon.alpha(NULL) - - # by - null_by = is.null(by) - if (!null_by && is.character(by)) by = factor(by) - x_by = identical(x, by) # flag if x==by (currently only used for "boxplot", "spineplot" and "ridges" types) - - # plot limits - # flag(s) indicating whether x/ylim was set by the user (needed later for - # special case where facets are free but still want to set x/ylim manually) - xlim_user = !is.null(xlim) - ylim_user = !is.null(ylim) - - # axes - # sanitize_axes: standardizes axis arguments and returns consistent axes, xaxt, yaxt, frame.plot values - tmp = sanitize_axes(axes, xaxt, yaxt, frame.plot) - list2env(tmp[c("axes", "xaxt", "yaxt", "frame.plot")], environment()) - rm("tmp") - - # xlab & ylab - # sanitize_xylab: generates appropriate axis labels based on input data and plot type - tmp = sanitize_xylab( - x = x, xlab = xlab, x_dep = x_dep, xmin_dep = xmin_dep, xmax_dep = xmax_dep, - y = y, ylab = ylab, y_dep = y_dep, ymin_dep = ymin_dep, ymax_dep = ymax_dep, - type = type - ) - xlab = tmp$xlab - ylab = tmp$ylab - rm("tmp") - - # facet - facet_by = FALSE # flag if facet=="by" (i.e., facet matches the grouping variable) - 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 - } 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") - } + # palette default + if (is.null(settings$palette)) { + settings$palette = get_tpar("palette", default = NULL) } - facet_attr = attributes(facet) # TODO: better way to restore facet attributes? - null_facet = is.null(facet) + # by: coerce character groups to factor + if (!settings$null_by && is.character(settings$by)) { + settings$by = factor(settings$by) + } - # - ## datapoints: x, y, etc. ----- - # + # flag if x==by, currently only used for + # - ## coerce character variables to factors - if (!is.null(x) && is.character(x)) x = factor(x) - if (!is.null(y) && is.character(y)) y = factor(y) - if (is.null(x)) { - ## Special catch for rect and segment plots without a specified y-var - if (type %in% c("rect", "segments")) { - x = rep(NA, length(x)) - } - } + # facet: parse facet formula and prepares variables when facet==by + sanitize_facet(settings) - if (is.null(y)) { - ## Special catch for area and interval plots without a specified y-var - if (type %in% c("rect", "segments", "pointrange", "errorbar", "ribbon")) { - y = rep(NA, length(x)) - } else if (type == "boxplot") { - y = x - x = rep.int("", length(y)) - xaxt = "a" - } else if (!(type %in% c("histogram", "barplot", "density", "function"))) { - y = x - x = seq_along(x) - } - } - - datapoints = list( - x = x, xmin = xmin, xmax = xmax, - y = y, ymin = ymin, ymax = ymax, ygroup = ygroup - ) - datapoints = Filter(function(z) length(z) > 0, datapoints) - datapoints = data.frame(datapoints) - if (nrow(datapoints) > 0) { - datapoints[["rowid"]] = seq_len(nrow(datapoints)) - datapoints[["facet"]] = if (!is.null(facet)) facet else "" - datapoints[["by"]] = if (!null_by) by else "" - } + # x / y processing + # convert characters to factors + # set x automatically when omitted (ex: rect) + # set y automatically when omitted (ex: boxplots) + # combine x, y, xmax, by, facet etc. into a single `datapoints` data.frame + sanitize_datapoints(settings) # ## transform datapoints using type_data() ----- # - # type_info: initialize a list to pass type-specific information from type_data() to type_draw() - type_info = list() - - if (!is.null(type_data)) { - fargs = list( - datapoints = datapoints, - bg = bg, - by = by, - col = col, - log = log, - lty = lty, - lwd = lwd, - cex = cex, - facet = facet, - facet_by = facet_by, - facet.args = facet.args, - legend_args = legend_args, - null_by = null_by, - null_facet = null_facet, - palette = palette, - ribbon.alpha = ribbon.alpha, - xaxt = xaxt, - xaxb = xaxb, - xaxl = xaxl, - xlab = xlab, - xlabs = xlabs, - xlim = xlim, - yaxt = yaxt, - yaxb = yaxb, - yaxl = yaxl, - ylab = ylab, - ylim = ylim - ) - fargs = c(fargs, dots) - list2env(do.call(type_data, fargs), environment()) + if (!is.null(settings$type_data)) { + settings$type_data(settings, ...) } + # flip -> swap x and y after type_data, except for boxplots (which has its own bespoke flip logic) + flip_datapoints(settings) - # flip -> swap x and y, except for boxplots (which has its own bespoke flip logic) - assert_flag(flip) - if (isTRUE(flip)) { - if (type == "boxplot") { - # boxplot: let horizontal=TRUE do most work; only swap labels - swap_variables(environment(), c("xlab", "ylab")) - } else { - swap_variables( - environment(), - c("xlim", "ylim"), - c("xlab", "ylab"), - c("xlabs", "ylabs"), - c("xaxt", "yaxt"), - c("xaxs", "yaxs"), - c("xaxb", "yaxb"), - c("xaxl", "yaxl")) - if (!is.null(log)) log = chartr("xy", "yx", log) - datapoints = swap_columns(datapoints, "x", "y") - datapoints = swap_columns(datapoints, "xmin", "ymin") - datapoints = swap_columns(datapoints, "xmax", "ymax") - } - } - # ## bubble plot ----- # - # catch some simple aesthetics for bubble plots before the standard "by" # grouping sanitizers (actually: will only be used for dual_legend plots but # easiest to assign/determine now) - if (bubble) { - datapoints[["cex"]] = cex - bubble_pch = if (!is.null(pch) && length(pch)==1) pch else par("pch") - bubble_alpha = if (!is.null(alpha)) alpha else 1 - bubble_bg_alpha = if (!is.null(bg) && length(bg)==1 && is.numeric(bg) && bg > 0 && bg <=1) bg else 1 - } + sanitize_bubble(settings) + # ## axis breaks and limits ----- # - - # 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 - } # do this after computing yaxb because limits will depend on the previous calculations - fargs = lim_args( - datapoints = datapoints, - xlim = xlim, ylim = ylim, - xaxb = xaxb, yaxb = yaxb, - xlim_user = xlim_user, ylim_user = ylim_user, - type = type - )[c("xlim", "ylim")] - list2env(fargs, environment()) + lim_args(settings) + + + # + ## facets: count ----- + # + + # facet_layout processes facet simplification, attribute restoration, and layout + facet_layout(settings) # ## aesthetics by group ----- # + by_aesthetics(settings) - 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) - } - - ngrps = if (null_by) 1L else if (is.factor(by)) nlevels(by) else if (by_continuous) 100L else 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( - ngrps = ngrps, col = col, palette = palette, - gradient = by_continuous, ordered = by_ordered, alpha = alpha - ) - bg = by_bg( - adjustcolor = adjustcolor, alpha = alpha, bg = bg, by = by, by_continuous = by_continuous, - by_ordered = by_ordered, col = col, fill = fill, palette = substitute(palette), - ribbon.alpha = ribbon.alpha, ngrps = ngrps, type = type - ) + + # + ## make settings available in the environment directly ----- + # + env2env(settings, environment()) + + + # + ## legends ----- + # + # legend labels ncolors = length(col) lgnd_labs = rep(NA, times = ncolors) if (isTRUE(by_continuous)) { @@ -1011,25 +931,6 @@ tinyplot.default = function( lgnd_labs[pidx] = pbyvar } - - # - ## facets: count ----- - # - - # before legend becase it requires `cex_fct_adj` - if (length(unique(datapoints$facet)) == 1) { - datapoints[["facet"]] = NULL - } - attributes(datapoints$facet) = facet_attr ## TODO: better solution for restoring facet attributes? - fargs = facet_layout(facet = datapoints$facet, facet.args = facet.args, add = add) - fargs = fargs[c("facets", "ifacet", "nfacets", "nfacet_rows", "nfacet_cols", "oxaxis", "oyaxis", "cex_fct_adj")] - list2env(fargs, environment()) - - - # - ## legends ----- - # - # simple indicator variables for later use has_legend = FALSE dual_legend = bubble && !null_by && !isFALSE(legend) @@ -1239,8 +1140,8 @@ tinyplot.default = function( # axes args axes = axes, flip = flip, frame.plot = frame.plot, oxaxis = oxaxis, oyaxis = oyaxis, - xlabs = xlabs, xlim = xlim, xlim_user = xlim_user, xaxt = xaxt, xaxs = xaxs, xaxb = xaxb, xaxl = xaxl, - ylabs = ylabs, ylim = ylim, ylim_user = ylim_user, yaxt = yaxt, yaxs = yaxs, yaxb = yaxb, yaxl = yaxl, + xlabs = xlabs, xlim = xlim, null_xlim = null_xlim, xaxt = xaxt, xaxs = xaxs, xaxb = xaxb, xaxl = xaxl, + ylabs = ylabs, ylim = ylim, null_ylim = null_ylim, yaxt = yaxt, yaxs = yaxs, yaxb = yaxb, yaxl = yaxl, asp = asp, log = log, # other args (in approx. alphabetical + group ordering) dots = dots, @@ -1264,8 +1165,8 @@ tinyplot.default = function( nfacets = nfacets, nfacet_cols = nfacet_cols, nfacet_rows = nfacet_rows, axes = axes, flip = flip, frame.plot = frame.plot, oxaxis = oxaxis, oyaxis = oyaxis, - xlabs = xlabs, xlim = xlim, xlim_user = xlim_user, xaxt = xaxt, xaxs = xaxs, xaxb = xaxb, xaxl = xaxl, - ylabs = ylabs, ylim = ylim, ylim_user = ylim_user, yaxt = yaxt, yaxs = yaxs, yaxb = yaxb, yaxl = yaxl, + xlabs = xlabs, xlim = xlim, null_xlim = null_xlim, xaxt = xaxt, xaxs = xaxs, xaxb = xaxb, xaxl = xaxl, + ylabs = ylabs, ylim = ylim, null_ylim = null_ylim, yaxt = yaxt, yaxs = yaxs, yaxb = yaxb, yaxl = yaxl, asp = asp, log = log, dots = dots, draw = draw, diff --git a/R/type_abline.R b/R/type_abline.R index 5b039474..0e4a4c27 100644 --- a/R/type_abline.R +++ b/R/type_abline.R @@ -5,14 +5,14 @@ #' While `type_abline`, `type_hline`, and `type_vline` can be called in a base #' plot layer, we expect that they will typically be called as subsequent #' layers via [`tinyplot_add`]. -#' @section Recycling logic: +#' @section Recycling logic: #' The recycling behaviour of the line parameters (i.e., `a`, `b`, `h`, or `v`) #' is adaptive, depending on whether `by` or `facet` grouping is detected. While #' this leads to different recycling scenarios, the underlying code logic #' follows sensible heuristics designed to match user expectations. -#' +#' #' Parameter lengths must equal one of four options: -#' +#' #' 1. Single value (i.e., length = 1), i.e. simplest case where the same line is #' applied uniformly across all groups and facets. Uses the default user colour #' (e.g. `"black"`, or `tpar("palette.qualitative")[1]` if a theme is set). @@ -31,66 +31,69 @@ #' will give six separate lines, with the first three (`21:23`) coloured by #' group in the first facet, and second three (`24:26`) coloured by by group #' in the second facet. -#' +#' #' Alongside these general rules, we also try to accomodate special cases when #' other aesthetic parameters like `lwd` or `lty` are invoked by the user. See #' Examples. -#' +#' #' @param a,b the intercept (default: `a` = 0) and slope (default: `b` = 1) #' terms. Numerics of length 1, or equal to the number of groups or number of #' facets (or the product thereof). #' @examples #' # #' ## abline -#' +#' #' tinyplot(x = -10:10, y = rnorm(21) + -10:10, grid = TRUE) #' tinyplot_add(type = "abline") #' # same as... #' # tinyplot_add(type = type_abline(a = 0, b = 1)) -#' +#' #' # customize by passing bespoke intercept and slope values #' tinyplot_add(type = type_abline(a = -1, b = -0.5)) -#' +#' #' # note that calling as abline & co. as a base plot layer will still lead to #' # axes limits that respect the range of the data #' tinyplot(x = -10:10, y = -10:10, grid = TRUE, type = "abline") -#' +#' #' # #' ## hline and vline #' #' # Base plot layer #' tinyplot(mpg ~ hp | cyl, facet = "by", data = mtcars, ylim = c(0, 40)) -#' +#' #' # Add horizontal lines at the (default) 0 y-intercept #' tinyplot_add(type = "hline", col = "grey") -#' +#' #' # Note that group+facet aesthetics will be inherited. We can use this to -#' # add customized lines (here: the mean `mpg` for each `cyl` group) +#' # add customized lines (here: the mean `mpg` for each `cyl` group) #' tinyplot_add(type = type_hline(with(mtcars, tapply(mpg, cyl, mean))), lty = 2) -#' +#' #' # Similar idea for vline #' tinyplot_add(type = type_vline(with(mtcars, tapply(hp, cyl, mean))), lty = 2) -#' +#' #' # #' ## Recycling logic -#' +#' #' # length(h) == no. of groups #' tinyplot(mpg ~ wt | factor(cyl), data = mtcars, type = type_hline(h = 21:23)) -#' +#' #' # length(h) == no. of facets #' tinyplot(mpg ~ wt, facet = ~am, data = mtcars, type = type_hline(h = c(20, 30))) -#' +#' #' # length(h) == no. of groups x no. of facets -#' tinyplot(mpg ~ wt | factor(cyl), facet = ~am, data = mtcars, -#' type = type_hline(h = 21:26)) -#' +#' tinyplot(mpg ~ wt | factor(cyl), +#' facet = ~am, data = mtcars, +#' type = type_hline(h = 21:26)) +#' #' # special adjustment case (here: lwd by group) -#' tinyplot(mpg ~ wt | factor(cyl), facet = ~am, data = mtcars, -#' type = type_hline(c(20, 30)), lwd = c(21, 14, 7)) -#' +#' tinyplot(mpg ~ wt | factor(cyl), +#' facet = ~am, data = mtcars, +#' type = type_hline(c(20, 30)), lwd = c(21, 14, 7)) +#' #' @export type_abline = function(a = 0, b = 1) { - data_abline = function(datapoints, lwd, lty, col, ...) { + data_abline = function(settings, ...) { + env2env(settings, environment(), c("datapoints", "lwd", "lty", "col")) if (nrow(datapoints) == 0) { msg = "`type_abline() only works on existing plots with x and y data points." stop(msg, call. = FALSE) @@ -100,27 +103,25 @@ type_abline = function(a = 0, b = 1) { ul_lwd = length(unique(lwd)) ul_lty = length(unique(lty)) ul_col = length(unique(col)) - return(list(type_info = list(ul_lty = ul_lty, ul_lwd = ul_lwd, ul_col = ul_col))) + type_info = list(ul_lty = ul_lty, ul_lwd = ul_lwd, ul_col = ul_col) + env2env(environment(), settings, "type_info") } draw_abline = function() { - fun = function( - ifacet, iby, data_facet, icol, ilty, ilwd, - ngrps, nfacets, by_continuous, facet_by, - type_info, - ... - ) { - + fun = function(ifacet, iby, data_facet, icol, ilty, ilwd, + ngrps, nfacets, by_continuous, facet_by, + type_info, + ...) { # flag for aesthetics by groups grp_aes = type_info[["ul_col"]] == 1 || type_info[["ul_lty"]] == ngrps || type_info[["ul_lwd"]] == ngrps - + if (length(a) != 1) { - if (!length(a) %in% c(ngrps, nfacets, ngrps*nfacets)) { + if (!length(a) %in% c(ngrps, nfacets, ngrps * nfacets)) { msg = "Length of 'a' must be 1, or equal to the number of facets or number of groups (or product thereof)." stop(msg, call. = FALSE) } if (!facet_by && length(a) == nfacets) { a = a[ifacet] - if (!grp_aes && type_info[["ul_col"]]!=ngrps) { + if (!grp_aes && type_info[["ul_col"]] != ngrps) { icol = 1 } else if (by_continuous) { icol = 1 @@ -133,15 +134,15 @@ type_abline = function(a = 0, b = 1) { } else if (!grp_aes) { icol = 1 } - + if (length(b) != 1) { - if (!length(b) %in% c(ngrps, nfacets, ngrps*nfacets)) { + if (!length(b) %in% c(ngrps, nfacets, ngrps * nfacets)) { msg = "Length of 'b' must be 1, or equal to the number of facets or number of groups (or product thereof)." stop(msg, call. = FALSE) } if (!facet_by && length(b) == nfacets) { b = b[ifacet] - if (!grp_aes && type_info[["ul_col"]]!=ngrps) { + if (!grp_aes && type_info[["ul_col"]] != ngrps) { icol = 1 } else if (by_continuous) { icol = 1 @@ -154,8 +155,8 @@ type_abline = function(a = 0, b = 1) { } else if (!grp_aes) { icol = 1 } - - if (type_info[["ul_col"]]!=1 && !(type_info[["ul_lty"]]==ngrps || type_info[["ul_lwd"]]==ngrps)) { + + if (type_info[["ul_col"]] != 1 && !(type_info[["ul_lty"]] == ngrps || type_info[["ul_lwd"]] == ngrps)) { icol = 1 } diff --git a/R/type_area.R b/R/type_area.R index 4c83cc0b..c9ba59fb 100644 --- a/R/type_area.R +++ b/R/type_area.R @@ -1,29 +1,36 @@ #' @rdname type_ribbon #' @export type_area = function(alpha = NULL) { - out = list( - draw = NULL, - data = data_area(alpha = alpha), - name = "area" - ) - class(out) = "tinyplot_type" - return(out) + out = list( + draw = NULL, + data = data_area(alpha = alpha), + name = "area" + ) + class(out) = "tinyplot_type" + return(out) } data_area = function(alpha = alpha) { ribbon.alpha = if (is.null(alpha)) .tpar[["ribbon.alpha"]] else (alpha) - fun = function(datapoints, ...) { + fun = function(settings, ...) { + env2env(settings, environment(), "datapoints") datapoints$ymax = datapoints$y datapoints$ymin = rep.int(0, nrow(datapoints)) - out = list( - datapoints = datapoints, - ymax = datapoints$ymax, - ymin = datapoints$ymin, - type = "ribbon", - ribbon.alpha = ribbon.alpha - ) - return(out) + ymax = datapoints$ymax + ymin = datapoints$ymin + type = "ribbon" + + # ribbon.alpha comes from parent scope, so assign it locally + ribbon.alpha = ribbon.alpha + + env2env(environment(), settings, c( + "datapoints", + "ymax", + "ymin", + "type", + "ribbon.alpha" + )) } return(fun) } diff --git a/R/type_barplot.R b/R/type_barplot.R index cea11c0d..df8de8a0 100644 --- a/R/type_barplot.R +++ b/R/type_barplot.R @@ -78,9 +78,17 @@ type_barplot = function(width = 5/6, beside = FALSE, center = FALSE, FUN = NULL, #' @importFrom stats aggregate data_barplot = function(width = 5/6, beside = FALSE, center = FALSE, FUN = NULL, xlevels = NULL, xaxlabels = NULL, drop.zeros = FALSE) { - fun = function(datapoints, col, bg, lty, lwd, palette, xlab = NULL, ylab = NULL, xlim = NULL, ylim = NULL, xaxt = NULL, yaxl = NULL, yaxt = NULL, axes = TRUE, null_by, facet_by, ...) { + fun = function(settings, ...) { + env2env( + settings, + environment(), + c( + "datapoints", "null_by", "facet_by", + "xlab", "ylab", "xlim", "ylim", "yaxl", "xaxt", + "null_palette", "col", "bg" + ) + ) - ## tabulate/aggregate datapoints if (is.null(datapoints$y)) { xlab = ylab @@ -131,7 +139,7 @@ data_barplot = function(width = 5/6, beside = FALSE, center = FALSE, FUN = NULL, ## default color palette ngrps = length(unique(datapoints$by)) - if (ngrps == 1L && is.null(palette)) { + if (ngrps == 1L && null_palette) { if (is.null(col)) col = par("fg") if (is.null(bg)) bg = "grey" } else { @@ -186,25 +194,28 @@ data_barplot = function(width = 5/6, beside = FALSE, center = FALSE, FUN = NULL, yaxl = paste0("abs_", yaxl) } } - - out = list( - datapoints = datapoints, - xlab = xlab, - ylab = ylab, - xlim = xlim, - ylim = ylim, - axes = FALSE, #FIXME - axes = TRUE, - xlabs = xlabs, - frame.plot = FALSE, - xaxs = "r", - xaxt = if (xaxt == "s") "l" else xaxt, - yaxl = yaxl, - yaxs = "i", - col = col, - bg = bg - ) - return(out) + + axes = TRUE + frame.plot = FALSE + xaxs = "r" + xaxt = if (xaxt == "s") "l" else xaxt + yaxs = "i" + env2env(environment(), settings, c( + "datapoints", + "xlab", + "ylab", + "xlim", + "ylim", + "axes", + "xlabs", + "frame.plot", + "xaxs", + "xaxt", + "yaxl", + "yaxs", + "col", + "bg" + )) } return(fun) } diff --git a/R/type_boxplot.R b/R/type_boxplot.R index 19584370..898858a0 100644 --- a/R/type_boxplot.R +++ b/R/type_boxplot.R @@ -94,7 +94,8 @@ draw_boxplot = function(range, width, varwidth, notch, outline, boxwex, staplewe data_boxplot = function() { - fun = function(datapoints, bg, col, palette, null_by, null_facet, ...) { + fun = function(settings, ...) { + env2env(settings, environment(), c("datapoints", "by", "facet", "null_facet", "null_palette", "x", "col", "bg", "null_by")) # Convert x to factor if it's not already datapoints$x = as.factor(datapoints$x) @@ -114,31 +115,35 @@ data_boxplot = function() { xord = order(datapoints$by, datapoints$facet, datapoints$x) } - if (length(unique(datapoints[["by"]])) == 1 && is.null(palette)) { + # Check if user provided palette before substitute) + if (length(unique(datapoints[["by"]])) == 1 && null_palette) { if (is.null(col)) col = par("fg") if (is.null(bg)) bg = "lightgray" } else { - bg = "by" + if (is.null(bg)) bg = "by" } # Reorder x, y, ymin, and ymax based on the order determined datapoints = datapoints[xord,] # Return the result as a list called 'out' - out = list( - x = datapoints$x, - y = datapoints$y, - ymin = datapoints$ymin, - ymax = datapoints$ymax, - xlabs = xlabs, - datapoints = datapoints, - col = col, - bg = bg) - - if (length(unique(datapoints$by)) > 1) out[["by"]] = datapoints$by - if (length(unique(datapoints$facet)) > 1) out[["facet"]] = datapoints$facet - - return(out) + x = datapoints$x + y = datapoints$y + ymin = datapoints$ymin + ymax = datapoints$ymax + by = if (length(unique(datapoints$by)) > 1) datapoints$by else by + facet = if (length(unique(datapoints$facet)) > 1) datapoints$facet else facet + env2env(environment(), settings, c( + "x", + "y", + "ymin", + "ymax", + "xlabs", + "datapoints", + "col", + "bg", + "by", + "facet")) } return(fun) } diff --git a/R/type_bubble.R b/R/type_bubble.R new file mode 100644 index 00000000..53e3977e --- /dev/null +++ b/R/type_bubble.R @@ -0,0 +1,15 @@ +sanitize_bubble = function(settings) { + env2env(settings, environment(), c("datapoints", "pch", "alpha", "bg", "cex", "bubble")) + if (bubble) { + datapoints[["cex"]] = cex + bubble_pch = if (!is.null(pch) && length(pch)==1) pch else par("pch") + bubble_alpha = if (!is.null(alpha)) alpha else 1 + bubble_bg_alpha = if (!is.null(bg) && length(bg)==1 && is.numeric(bg) && bg > 0 && bg <=1) bg else 1 + } + + bubble_pch = if (bubble) bubble_pch else NULL + bubble_alpha = if (bubble) bubble_alpha else NULL + bubble_bg_alpha = if (bubble) bubble_bg_alpha else NULL + + env2env(environment(), settings, c("datapoints", "bubble_pch", "bubble_alpha", "bubble_bg_alpha")) +} diff --git a/R/type_density.R b/R/type_density.R index bdfe4217..d4bd9b23 100644 --- a/R/type_density.R +++ b/R/type_density.R @@ -111,8 +111,8 @@ type_density = function( data_density = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512, joint.bw = "none", alpha = NULL) { - fun = function(by, facet, ylab, col, bg, ribbon.alpha, datapoints, ...) { - + 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) if (is.null(ylab)) ylab = "Density" @@ -150,17 +150,20 @@ data_density = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512, # flags for legend and fill dtype = if (!is.null(bg)) "ribbon" else "l" dwas_area_type = !is.null(bg) - - out = list( - ylab = ylab, - type = dtype, - was_area_type = dwas_area_type, - ribbon.alpha = ribbon.alpha, - datapoints = datapoints, - by = if (length(unique(datapoints$by)) == 1) by else datapoints$by, - facet = if (length(unique(datapoints$facet)) == 1) facet else datapoints$facet - ) - return(out) + + type = dtype + was_area_type = dwas_area_type + by = if (length(unique(datapoints$by)) == 1) by else datapoints$by + facet = if (length(unique(datapoints$facet)) == 1) facet else datapoints$facet + env2env(environment(), settings, c( + "ylab", + "type", + "was_area_type", + "ribbon.alpha", + "datapoints", + "by", + "facet" + )) } return(fun) } diff --git a/R/type_function.R b/R/type_function.R index 397742e8..408e74fa 100644 --- a/R/type_function.R +++ b/R/type_function.R @@ -10,7 +10,7 @@ #' @param ... Additional arguments are passed to the `lines()` function, #' ex: `type="p"`, `col="pink"`. #' @importFrom stats dnorm -#' +#' #' @examples #' # Plot the normal density (default function) #' tinyplot(x = -4:4, type = "function") @@ -26,7 +26,7 @@ #' fun = dnorm, #' col = "pink", type = "p", pch = 3 #' )) -#' +#' #' # Custom function example #' ## (Here using `function(x)`, but you could also use the shorter `\(x)` #' ## anonymous function syntax introduced in R 4.1.0) @@ -37,7 +37,9 @@ type_function = function(fun = dnorm, args = list(), n = 101, ...) { assert_function(fun) lines_args = list(...) data_function = function(args, fun) { - funky = function(xlim, ylim, datapoints, ...) { + funky = function(settings, ...) { + env2env(settings, environment(), c("xlim", "ylim", "datapoints")) + if (nrow(datapoints) == 0 || !"x" %in% names(datapoints)) { stop("Need to provide x values to plot the function.", call. = FALSE) } @@ -52,8 +54,7 @@ type_function = function(fun = dnorm, args = list(), n = 101, ...) { tmp = do.call(fun, tmp) ylim = c(min(tmp), max(tmp)) } - out = list(xlim = xlim, ylim = ylim) - return(out) + env2env(environment(), settings, c("xlim", "ylim")) } } draw_function = function() { diff --git a/R/type_glm.R b/R/type_glm.R index e2fd00bd..579e3681 100644 --- a/R/type_glm.R +++ b/R/type_glm.R @@ -1,8 +1,8 @@ #' Generalized linear model plot type -#' +#' #' @description Type function for plotting a generalized model fit. #' Arguments are passed to \code{\link[stats]{glm}}. -#' +#' #' @param se logical. If TRUE, confidence intervals are drawn. #' @inheritParams stats::glm #' @inheritParams stats::predict.glm @@ -11,7 +11,7 @@ #' @examples #' # "glm" type convenience string #' tinyplot(am ~ mpg, data = mtcars, type = "glm") -#' +#' #' # Use `type_glm()` to pass extra arguments for customization #' tinyplot(am ~ mpg, data = mtcars, type = type_glm(family = "binomial")) #' @export @@ -28,10 +28,13 @@ type_glm = function(family = "gaussian", se = TRUE, level = 0.95, type = "respon data_glm = function(family, se, level, type, ...) { - fun = function(datapoints, ...) { + fun = function(settings, ...) { + env2env(settings, environment(), "datapoints") dat = split(datapoints, list(datapoints$facet, datapoints$by)) dat = lapply(dat, function(x) { - if (nrow(x) == 0) return(x) + if (nrow(x) == 0) { + return(x) + } if (nrow(x) < 3) { x$y = NA return(x) @@ -47,7 +50,6 @@ data_glm = function(family, se, level, type, ...) { nd$y = p$estimate nd$ymax = p$conf.high nd$ymin = p$conf.low - } else { nd$y = predict(fit, newdata = nd, type = type) nd = ci(nd$y, nd$se, level, fit$df.residual, backtransform = stats::family(fit)$linkinv) @@ -59,8 +61,7 @@ data_glm = function(family, se, level, type, ...) { }) datapoints = do.call(rbind, dat) datapoints = datapoints[order(datapoints$facet, datapoints$by, datapoints$x), ] - out = list(datapoints = datapoints) - return(out) + env2env(environment(), settings, "datapoints") } return(fun) } diff --git a/R/type_histogram.R b/R/type_histogram.R index 209b1ef6..52adf080 100644 --- a/R/type_histogram.R +++ b/R/type_histogram.R @@ -1,5 +1,5 @@ #' Histogram plot type -#' +#' #' @md #' @description Type function for histogram plots. `type_hist` is an alias for #' `type_histogram`. @@ -28,53 +28,57 @@ #' @examples #' # "histogram"/"hist" type convenience string(s) #' tinyplot(Nile, type = "histogram") -#' +#' #' # Use `type_histogram()` to pass extra arguments for customization #' tinyplot(Nile, type = type_histogram(breaks = 30)) #' tinyplot(Nile, type = type_histogram(breaks = 30, freq = FALSE)) #' # etc. -#' +#' #' # Grouped histogram example #' tinyplot( -#' ~Petal.Width | Species, +#' ~ Petal.Width | Species, #' type = "histogram", #' data = iris #' ) -#' +#' #' # Faceted version #' tinyplot( -#' ~Petal.Width, facet = ~Species, +#' ~Petal.Width, +#' facet = ~Species, #' type = "histogram", #' data = iris #' ) -#' +#' #' # For visualizing faceted histograms across varying scales, you may also wish #' # to impose free histogram breaks too (i.e., calculate breaks separately for #' # each group). Compare: -#' +#' #' # free facet scales + shared histogram breaks, versus... #' tinyplot( -#' ~Petal.Width, facet = ~Species, +#' ~Petal.Width, +#' facet = ~Species, #' facet.args = list(free = TRUE), #' type = type_histogram(), #' data = iris #' ) #' # ... free facet scales + free histogram breaks #' tinyplot( -#' ~Petal.Width, facet = ~Species, +#' ~Petal.Width, +#' facet = ~Species, #' facet.args = list(free = TRUE), #' type = type_histogram(free = TRUE), #' data = iris #' ) -#' +#' #' @export type_histogram = function(breaks = "Sturges", freq = NULL, right = TRUE, free.breaks = FALSE, drop.zeros = TRUE) { out = list( - data = data_histogram(breaks = breaks, - free.breaks = free.breaks, drop.zeros = drop.zeros, - freq = freq, right = right), + data = data_histogram( + breaks = breaks, + free.breaks = free.breaks, drop.zeros = drop.zeros, + freq = freq, right = right), draw = draw_rect(), name = "histogram" ) @@ -90,17 +94,17 @@ type_hist = type_histogram data_histogram = function(breaks = "Sturges", free.breaks = FALSE, drop.zeros = TRUE, freq = NULL, right = TRUE) { - hbreaks = breaks hfree.breaks = free.breaks hdrop.zeros = drop.zeros hfreq = freq hright = right - - fun = function(by, facet, ylab, col, bg, ribbon.alpha, datapoints, .breaks = hbreaks, .freebreaks = hfree.breaks, .freq = hfreq, .right = hright, .drop.zeros = hdrop.zeros, ...) { - + + fun = function(settings, .breaks = hbreaks, .freebreaks = hfree.breaks, .freq = hfreq, .right = hright, .drop.zeros = hdrop.zeros, ...) { + env2env(settings, environment(), c("palette", "bg", "col", "plot", "datapoints", "ymin", "ymax", "xmin", "xmax", "freq", "ylab", "xlab", "facet", "ribbon.alpha")) + hbreaks = ifelse(!sapply(.breaks, is.null), .breaks, "Sturges") - + if (is.null(by) && is.null(palette)) { if (is.null(col)) col = par("fg") if (is.null(bg)) bg = "lightgray" @@ -111,7 +115,7 @@ data_histogram = function(breaks = "Sturges", if (!.freebreaks) xbreaks = hist(datapoints$x, breaks = hbreaks, right = .right, plot = FALSE)$breaks datapoints = split(datapoints, list(datapoints$by, datapoints$facet)) datapoints = Filter(function(k) nrow(k) > 0, datapoints) - + datapoints = lapply(datapoints, function(k) { if (.freebreaks) xbreaks = breaks h = hist(k$x, breaks = xbreaks, right = .right, plot = FALSE) @@ -120,10 +124,10 @@ data_histogram = function(breaks = "Sturges", nzidx = which(h$counts > 0) h$density = h$density[nzidx] h$counts = h$counts[nzidx] - h$breaks = h$breaks[c(1, nzidx+1)] + h$breaks = h$breaks[c(1, nzidx + 1)] h$mids = h$mids[nzidx] } - freq = if(!is.null(.freq)) .freq else is.null(.freq) && h$equidist + freq = if (!is.null(.freq)) .freq else is.null(.freq) && h$equidist out = data.frame( by = k$by[1], # already split facet = k$facet[1], # already split @@ -136,26 +140,34 @@ data_histogram = function(breaks = "Sturges", return(out) }) datapoints = do.call(rbind, datapoints) - + if (is.null(ylab)) { ylab = ifelse(datapoints$freq[1], "Frequency", "Density") } - out = list( - x = c(datapoints$xmin, datapoints$xmax), - y = c(datapoints$ymin, datapoints$ymax), - ymin = datapoints$ymin, - ymax = datapoints$ymax, - xmin = datapoints$xmin, - xmax = datapoints$xmax, - ylab = ylab, - col = col, - bg = bg, - datapoints = datapoints, - by = if (length(unique(datapoints$by)) == 1) by else datapoints$by, - facet = if (length(unique(datapoints$facet)) == 1) facet else datapoints$facet - ) - return(out) + # browser() + x = c(datapoints$xmin, datapoints$xmax) + y = c(datapoints$ymin, datapoints$ymax) + ymin = datapoints$ymin + ymax = datapoints$ymax + xmin = datapoints$xmin + xmax = datapoints$xmax + by = if (length(unique(datapoints$by)) == 1) by else datapoints$by + facet = if (length(unique(datapoints$facet)) == 1) facet else datapoints$facet + env2env(environment(), settings, c( + "x", + "y", + "ymin", + "ymax", + "xmin", + "xmax", + "ylab", + "col", + "bg", + "datapoints", + "by", + "facet" + )) } return(fun) } diff --git a/R/type_hline.R b/R/type_hline.R index 5e392b09..3ac9bece 100644 --- a/R/type_hline.R +++ b/R/type_hline.R @@ -4,7 +4,9 @@ #' @export type_hline = function(h = 0) { assert_numeric(h) - data_hline = function(datapoints, lwd, lty, col, ...) { + data_hline = function(settings, ...) { + env2env(settings, environment(), c("lwd", "lty", "col", "datapoints")) + if (nrow(datapoints) == 0) { msg = "`type_hline() only works on existing plots with x and y data points." stop(msg, call. = FALSE) @@ -14,27 +16,25 @@ type_hline = function(h = 0) { ul_lwd = length(unique(lwd)) ul_lty = length(unique(lty)) ul_col = length(unique(col)) - return(list(type_info = list(ul_lty = ul_lty, ul_lwd = ul_lwd, ul_col = ul_col))) + type_info = list(ul_lty = ul_lty, ul_lwd = ul_lwd, ul_col = ul_col) + env2env(environment(), settings, "type_info") } draw_hline = function() { - fun = function( - ifacet, iby, data_facet, icol, ilty, ilwd, - ngrps, nfacets, by_continuous, facet_by, - type_info, - ... - ) { - + fun = function(ifacet, iby, data_facet, icol, ilty, ilwd, + ngrps, nfacets, by_continuous, facet_by, + type_info, + ...) { # flag for aesthetics by groups grp_aes = type_info[["ul_col"]] == 1 || type_info[["ul_lty"]] == ngrps || type_info[["ul_lwd"]] == ngrps - + if (length(h) != 1) { - if (!length(h) %in% c(ngrps, nfacets, ngrps*nfacets)) { + if (!length(h) %in% c(ngrps, nfacets, ngrps * nfacets)) { msg = "Length of 'h' must be 1, or equal to the number of facets or number of groups (or product thereof)." stop(msg, call. = FALSE) } if (!facet_by && length(h) == nfacets) { h = h[ifacet] - if (!grp_aes && type_info[["ul_col"]]!=ngrps) { + if (!grp_aes && type_info[["ul_col"]] != ngrps) { icol = 1 } else if (by_continuous) { icol = 1 diff --git a/R/type_jitter.R b/R/type_jitter.R index 57339df3..85b870e7 100644 --- a/R/type_jitter.R +++ b/R/type_jitter.R @@ -8,23 +8,25 @@ #' @examples #' # "jitter" type convenience string #' tinyplot(Sepal.Length ~ Species, data = iris, type = "jitter") -#' +#' #' # Use `type_jitter()` to pass extra arguments for customization #' tinyplot(Sepal.Length ~ Species, data = iris, type = type_jitter(factor = 0.5)) #' @export type_jitter = function(factor = 1, amount = NULL) { - out = list( - draw = draw_points(), - data = data_jitter(factor = factor, amount = amount), - name = "p" - ) - class(out) = "tinyplot_type" - return(out) + out = list( + draw = draw_points(), + data = data_jitter(factor = factor, amount = amount), + name = "p" + ) + class(out) = "tinyplot_type" + return(out) } data_jitter = function(factor, amount) { - fun = function(datapoints, ...) { + fun = function(settings, ...) { + env2env(settings, environment(), "datapoints") + x = datapoints$x y = datapoints$y if (is.factor(x)) { @@ -49,14 +51,12 @@ data_jitter = function(factor, amount) { datapoints$x = x datapoints$y = y - out = list( - datapoints = datapoints, - x = x, - y = y, - xlabs = xlabs, - ylabs = ylabs - ) - return(out) + env2env(environment(), settings, c( + "datapoints", + "x", + "y", + "xlabs", + "ylabs" + )) } } - diff --git a/R/type_lm.R b/R/type_lm.R index bcf598f7..9bf4a627 100644 --- a/R/type_lm.R +++ b/R/type_lm.R @@ -2,17 +2,17 @@ #' #' @description Type function for plotting a linear model fit. #' Arguments are passed to \code{\link[stats]{lm}}. -#' +#' #' @inheritParams type_glm #' @importFrom stats lm predict #' @examples #' # "lm" type convenience string #' tinyplot(Sepal.Width ~ Petal.Width, data = iris, type = "lm") -#' +#' #' # Grouped model fits (here: illustrating an example of Simpson's paradox) #' tinyplot(Sepal.Width ~ Petal.Width | Species, data = iris, type = "lm") #' tinyplot_add(type = "p") -#' +#' #' # Use `type_lm()` to pass extra arguments for customization #' tinyplot(Sepal.Width ~ Petal.Width, data = iris, type = type_lm(level = 0.8)) #' @export @@ -29,10 +29,13 @@ type_lm = function(se = TRUE, level = 0.95) { data_lm = function(se, level, ...) { - fun = function(datapoints, ...) { + fun = function(settings, ...) { + env2env(settings, environment(), "datapoints") dat = split(datapoints, list(datapoints$facet, datapoints$by)) dat = lapply(dat, function(x) { - if (nrow(x) == 0) return(x) + if (nrow(x) == 0) { + return(x) + } if (nrow(x) < 3) { x$y = NA return(x) @@ -54,9 +57,7 @@ data_lm = function(se, level, ...) { }) datapoints = do.call(rbind, dat) datapoints = datapoints[order(datapoints$facet, datapoints$by, datapoints$x), ] - out = list(datapoints = datapoints) - return(out) + env2env(environment(), settings, "datapoints") } return(fun) } - diff --git a/R/type_loess.R b/R/type_loess.R index 3f751d31..eea85e6b 100644 --- a/R/type_loess.R +++ b/R/type_loess.R @@ -1,8 +1,8 @@ #' Local polynomial regression plot type -#' +#' #' @description Type function for plotting a LOESS (LOcal regrESSion) fit. #' Arguments are passed to \code{\link[stats]{loess}}. -#' +#' #' @inheritParams stats::loess #' @param se logical. If `TRUE` (the default), confidence intervals are drawn. #' @param level the confidence level required if `se = TRUE`. Default is 0.95. @@ -10,7 +10,7 @@ #' @examples #' # "loess" type convenience string #' tinyplot(dist ~ speed, data = cars, type = "loess") -#' +#' #' # Use `type_loess()` to pass extra arguments for customization #' tinyplot(dist ~ speed, data = cars, type = type_loess(span = 0.5, degree = 1)) #' @export @@ -20,8 +20,7 @@ type_loess = function( family = "gaussian", control = loess.control(), se = TRUE, - level = 0.95 - ) { + level = 0.95) { out = list( draw = draw_ribbon(), data = data_loess(span = span, degree = degree, family = family, control = control, se = se, level = level), @@ -33,7 +32,8 @@ type_loess = function( data_loess = function(span, degree, family, control, se, level, ...) { - fun = function(datapoints, ...) { + fun = function(settings, ...) { + env2env(settings, environment(), "datapoints") datapoints = split(datapoints, list(datapoints$facet, datapoints$by)) datapoints = Filter(function(k) nrow(k) > 0, datapoints) datapoints = lapply(datapoints, function(dat) { @@ -51,9 +51,7 @@ data_loess = function(span, degree, family, control, se, level, ...) { }) datapoints = do.call(rbind, datapoints) datapoints = datapoints[order(datapoints$facet, datapoints$by, datapoints$x), ] - out = list(datapoints = datapoints) - return(out) + env2env(environment(), settings, "datapoints") } return(fun) } - diff --git a/R/type_pointrange.R b/R/type_pointrange.R index 340d5a4b..49be5874 100644 --- a/R/type_pointrange.R +++ b/R/type_pointrange.R @@ -16,19 +16,18 @@ type_pointrange = function(dodge = 0, fixed.pos = FALSE) { draw_pointrange = function() { fun = function( - ix, - iy, - ixmin, - iymin, - ixmax, - iymax, - icol, - ibg, - ipch, - ilwd, - icex, - ... - ) { + ix, + iy, + ixmin, + iymin, + ixmax, + iymax, + icol, + ibg, + ipch, + ilwd, + icex, + ...) { segments( x0 = ixmin, y0 = iymin, @@ -52,7 +51,9 @@ draw_pointrange = function() { data_pointrange = function(dodge, fixed.pos) { - fun = function(datapoints, xlabs, ...) { + fun = function(settings, ...) { + env2env(settings, environment(), c("datapoints", "xlabs")) + if (is.character(datapoints$x)) { datapoints$x = as.factor(datapoints$x) } @@ -91,13 +92,12 @@ data_pointrange = function(dodge, fixed.pos) { } } - out = list( - x = datapoints$x, - xlabs = xlabs, - datapoints = datapoints - ) - - return(out) + x = datapoints$x + env2env(environment(), settings, c( + "x", + "xlabs", + "datapoints" + )) } return(fun) } diff --git a/R/type_points.R b/R/type_points.R index 6ed592d8..53e868e2 100644 --- a/R/type_points.R +++ b/R/type_points.R @@ -3,34 +3,33 @@ #' @description Type function for plotting points, i.e. a scatter plot. #' @param clim Numeric giving the lower and upper limits of the character #' expansion (`cex`) normalization for bubble charts. -#' +#' #' @examples #' # "p" type convenience character string #' tinyplot(Sepal.Length ~ Petal.Length, data = iris, type = "p") -#' +#' #' # Same result with type_points() #' tinyplot(Sepal.Length ~ Petal.Length, data = iris, type = type_points()) -#' +#' #' # Note: Specifying the type here is redundant. Like base plot, tinyplot #' # automatically produces a scatter plot if x and y are numeric #' tinyplot(Sepal.Length ~ Petal.Length, data = iris) -#' +#' #' # Grouped scatter plot example #' tinyplot(Sepal.Length ~ Petal.Length | Species, data = iris) -#' +#' #' # Continuous grouping (with gradient legend) #' tinyplot(Sepal.Length ~ Petal.Length | Sepal.Width, data = iris, pch = 19) -#' +#' #' # Bubble chart version #' tinyplot(Sepal.Length ~ Petal.Length, data = iris, cex = iris$Sepal.Width) -#' +#' #' # Fancier version with dual legends and extra customization #' tinyplot(Sepal.Length ~ Petal.Length | Species, -#' data = iris, -#' cex = iris$Sepal.Width, clim = c(1, 5), -#' pch = 21, fill = 0.3) -#' -#' +#' data = iris, +#' cex = iris$Sepal.Width, clim = c(1, 5), +#' pch = 21, fill = 0.3) +#' #' @export type_points = function(clim = c(0.5, 2.5)) { out = list( @@ -43,7 +42,9 @@ type_points = function(clim = c(0.5, 2.5)) { } data_points = function(clim = c(0.5, 2.5)) { - fun = function(datapoints, legend_args, cex = NULL, ...) { + fun = function(settings, cex = NULL, ...) { + env2env(settings, environment(), c("datapoints", "cex", "legend_args")) + # catch for factors (we should still be able to "force" plot these with points) if (is.factor(datapoints$x)) { xlvls = levels(datapoints$x) @@ -65,11 +66,11 @@ data_points = function(clim = c(0.5, 2.5)) { bubble = FALSE bubble_cex = 1 if (!is.null(cex) && length(cex) == nrow(datapoints)) { - bubble = TRUE + bubble = TRUE ## Identify the pretty break points for our bubble labels bubble_labs = pretty(cex, n = 5) len_labs = length(bubble_labs) - cex = rescale_num(sqrt(c(bubble_labs, cex))/pi, to = clim) + cex = rescale_num(sqrt(c(bubble_labs, cex)) / pi, to = clim) bubble_cex = cex[1:len_labs] cex = cex[(len_labs+1):length(cex)] # catch for cases where pretty breaks leads to smallest category of 0 @@ -83,34 +84,32 @@ data_points = function(clim = c(0.5, 2.5)) { legend_args[["y.intersp"]] = sapply(bubble_cex / 2.5, max, 1) } } - - out = list( - datapoints = datapoints, - xlabs = xlabs, - ylabs = ylabs, - cex = cex, - bubble = bubble, - bubble_cex = bubble_cex, - legend_args = legend_args - ) - return(out) + + env2env(environment(), settings, c( + "datapoints", + "xlabs", + "ylabs", + "cex", + "bubble", + "bubble_cex", + "legend_args" + )) } } draw_points = function() { - fun = function(ix, iy, icol, ibg, ipch, ilwd, icex, ...) { + fun = function(ix, iy, icol, ibg, ipch, ilwd, icex, ...) { # browser() - points( - x = ix, - y = iy, - col = icol, - bg = ibg, - type = "p", - pch = ipch, - lwd = ilwd, - cex = icex - ) - } - return(fun) + points( + x = ix, + y = iy, + col = icol, + bg = ibg, + type = "p", + pch = ipch, + lwd = ilwd, + cex = icex + ) + } + return(fun) } - diff --git a/R/type_qq.R b/R/type_qq.R index 7e13f656..8b2536d2 100644 --- a/R/type_qq.R +++ b/R/type_qq.R @@ -13,14 +13,15 @@ #' @export type_qq = function(distribution = qnorm) { data_qq = function(distribution) { - fun = function(datapoints, ...) { + fun = function(settings, ...) { + env2env(settings, environment(), "datapoints") + y = sort(datapoints$y) x = datapoints$x x = distribution(ppoints(x)) datapoints$x = x datapoints$y = y - out = list(datapoints = datapoints) - return(out) + env2env(environment(), settings, "datapoints") } } diff --git a/R/type_ribbon.R b/R/type_ribbon.R index 8ae70d85..b3028447 100644 --- a/R/type_ribbon.R +++ b/R/type_ribbon.R @@ -1,51 +1,51 @@ #' Ribbon and area plot types -#' +#' #' @param alpha numeric value between 0 and 1 specifying the opacity of ribbon shading -#' If no `alpha` value is provided, then will default to `tpar("ribbon.alpha")` -#' (i.e., probably `0.2` unless this has been overridden by the user in their global +#' If no `alpha` value is provided, then will default to `tpar("ribbon.alpha")` +#' (i.e., probably `0.2` unless this has been overridden by the user in their global #' settings.) #' -#' @description Type constructor functions for producing polygon ribbons, which +#' @description Type constructor functions for producing polygon ribbons, which #' define a `y` interval (usually spanning from `ymin` to `ymax`) for each #' `x` value. Area plots are a special case of ribbon plot where `ymin` is #' set to 0 and `ymax` is set to `y`. -#' +#' #' @examples -#' x = 1:100/10 +#' x = 1:100 / 10 #' y = sin(x) -#' +#' #' # #' ## Ribbon plots -#' +#' #' # "ribbon" convenience string -#' tinyplot(x = x, ymin = y-1, ymax = y+1, type = "ribbon") +#' tinyplot(x = x, ymin = y - 1, ymax = y + 1, type = "ribbon") #' # Same result with type_ribbon() #' tinyplot(x = x, ymin = y-1, ymax = y+1, type = type_ribbon()) -#' +#' #' # y will be added as a line if it is specified #' tinyplot(x = x, y = y, ymin = y-1, ymax = y+1, type = "ribbon") #' #' # #' ## Area plots -#' +#' #' # "area" type convenience string #' tinyplot(x, y, type = "area") -#' +#' #' # Same result with type_area() #' tinyplot(x, y, type = type_area()) -#' +#' #' # Area plots are often used for time series charts #' tinyplot(AirPassengers, type = "area") #' @export type_ribbon = function(alpha = NULL) { - out = list( - draw = draw_ribbon(), - data = data_ribbon(ribbon.alpha = alpha), - name = "ribbon" - ) - class(out) = "tinyplot_type" - return(out) + out = list( + draw = draw_ribbon(), + data = data_ribbon(ribbon.alpha = alpha), + name = "ribbon" + ) + class(out) = "tinyplot_type" + return(out) } @@ -65,8 +65,9 @@ draw_ribbon = function() { data_ribbon = function(ribbon.alpha = NULL) { - ribbon.alpha = sanitize_ribbon.alpha(ribbon.alpha) - fun = function(datapoints, xlabs, null_by, null_facet, ...) { + ribbon.alpha = sanitize_ribbon_alpha(ribbon.alpha) + fun = function(settings, ...) { + env2env(settings, environment(), c("datapoints", "xlabs", "null_by", "null_facet")) # Convert x to factor if it's not already if (is.character(datapoints$x)) { datapoints$x = as.factor(datapoints$x) @@ -92,25 +93,27 @@ data_ribbon = function(ribbon.alpha = NULL) { } # Reorder x, y, ymin, and ymax based on the order determined - datapoints = datapoints[xord,] + datapoints = datapoints[xord, ] - # Catch for missing ymin and ymax - if (is.null(datapoints$ymin)) datapoints$ymin = datapoints$y + # Catch for missing ymin and ymax + if (is.null(datapoints$ymin)) datapoints$ymin = datapoints$y if (is.null(datapoints$ymax)) datapoints$ymax = datapoints$y - out = list( - x = datapoints$x, - y = datapoints$y, - ymin = datapoints$ymin, - ymax = datapoints$ymax, - xlabs = xlabs, - datapoints = datapoints, - ribbon.alpha = ribbon.alpha) + x = datapoints$x + y = datapoints$y + ymin = datapoints$ymin + ymax = datapoints$ymax + by = if (length(unique(datapoints$by)) > 1) datapoints$by else NULL + facet = if (length(unique(datapoints$facet)) > 1) datapoints$facet else NULL + + # ribbon.alpha comes from parent scope, so assign it locally + ribbon.alpha = ribbon.alpha - if (length(unique(datapoints$by)) > 1) out[["by"]] = datapoints$by - if (length(unique(datapoints$facet)) > 1) out[["facet"]] = datapoints$facet + vars_to_copy = c("x", "y", "ymin", "ymax", "xlabs", "datapoints", "ribbon.alpha") + if (!is.null(by)) vars_to_copy = c(vars_to_copy, "by") + if (!is.null(facet)) vars_to_copy = c(vars_to_copy, "facet") - return(out) + env2env(environment(), settings, vars_to_copy) } return(fun) } diff --git a/R/type_ridge.R b/R/type_ridge.R index aa492980..c8a171b1 100644 --- a/R/type_ridge.R +++ b/R/type_ridge.R @@ -252,7 +252,9 @@ data_ridge = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512, col = NULL, alpha = NULL ) { - fun = function(datapoints, yaxt = NULL, null_by, ...) { + fun = function(settings, ...) { + env2env(settings, environment(), c("datapoints", "yaxt", "xaxt", "null_by")) + # catch for special cases anyby = !null_by x_by = anyby && identical(datapoints$x, datapoints$by) @@ -389,26 +391,30 @@ data_ridge = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512, if (is.null(col) && (!anyby || x_by)) col = "black" - out = list( - datapoints = datapoints, - yaxt = "n", - ylim = c(min(datapoints$ymin), max(datapoints$ymax)), - type_info = list( - gradient = gradient, - palette = palette, - breaks = breaks, - probs = probs, - manbreaks = manbreaks, - yaxt = yaxt, - raster = raster, - x_by = x_by, - y_by = y_by, - fill_by = fill_by, - col = col, - alpha = alpha - ) + # Save original yaxt for type_info before overwriting + yaxt_orig = yaxt + yaxt = "n" + ylim = c(min(datapoints$ymin), max(datapoints$ymax)) + type_info = list( + gradient = gradient, + palette = palette, + breaks = breaks, + probs = probs, + manbreaks = manbreaks, + yaxt = yaxt_orig, + raster = raster, + x_by = x_by, + y_by = y_by, + fill_by = fill_by, + col = col, + alpha = alpha ) - return(out) + env2env(environment(), settings, c( + "datapoints", + "yaxt", + "ylim", + "type_info" + )) } return(fun) } diff --git a/R/type_rug.R b/R/type_rug.R index 57359fb1..85d7ee93 100644 --- a/R/type_rug.R +++ b/R/type_rug.R @@ -33,12 +33,14 @@ #' @importFrom graphics rug #' @export type_rug = function(ticksize = 0.03, side = 1, quiet = getOption("warn") < 0, jitter = FALSE, amount = NULL) { - data_rug = function(datapoints, ...) { + data_rug = function(settings, ...) { + env2env(settings, environment(), "datapoints") if (nrow(datapoints) == 0) { msg = "`type_rug() only works on existing plots with x and y data points." stop(msg, call. = FALSE) } - return(datapoints) + + env2env(environment(), settings, "datapoints") } draw_rug = function(.ticksize = ticksize, .side = side, .quiet = quiet, .jitter = jitter, .amount = amount) { fun = function(ix, iy, icol, ilwd, ...) { diff --git a/R/type_spineplot.R b/R/type_spineplot.R index f28c5bd1..7edcb192 100644 --- a/R/type_spineplot.R +++ b/R/type_spineplot.R @@ -78,15 +78,8 @@ type_spineplot = function(breaks = NULL, tol.ylab = 0.05, off = NULL, xlevels = #' @importFrom grDevices nclass.Sturges data_spineplot = function(off = NULL, breaks = NULL, xlevels = xlevels, ylevels = ylevels, xaxlabels = NULL, yaxlabels = NULL, weights = NULL) { - fun = function( - datapoints, - by = NULL, col = NULL, bg = NULL, palette = NULL, - facet = NULL, facet.args = NULL, - xlim = NULL, ylim = NULL, - axes = TRUE, xaxt = NULL, yaxt = NULL, xaxb = NULL, yaxb = NULL, - null_by, null_facet, - ... - ) { + fun = function(settings, ...) { + env2env(settings, environment(), c("datapoints", "xlim", "ylim", "facet", "facet.args", "by", "xaxb", "yaxb", "null_by", "null_facet", "null_palette", "col", "bg", "axes", "xaxt", "yaxt")) ## process weights if (!is.null(weights)) { @@ -246,48 +239,51 @@ data_spineplot = function(off = NULL, breaks = NULL, xlevels = xlevels, ylevels if (isTRUE(y_by)) datapoints$by = factor(rep_len(yaxlabels, nrow(datapoints))) ## grayscale flag - grayscale = null_by && is.null(palette) && is.null(.tpar[["palette.qualitative"]]) - - out = list( - x = c(datapoints$xmin, datapoints$xmax), - y = c(datapoints$ymin, datapoints$ymax), - ymin = datapoints$ymin, - ymax = datapoints$ymax, - xmin = datapoints$xmin, - xmax = datapoints$xmax, - col = col, - bg = bg, - datapoints = datapoints, - by = if (null_by) by else datapoints$by, - facet = if (null_facet) facet else datapoints$facet, - axes = FALSE, - frame.plot = FALSE, - xaxt = "n", - yaxt = "n", - xaxs = "i", - yaxs = "i", - ylabs = yaxlabels, - type_info = list( - off = off, - x.categorical = x.categorical, - nx = nx, - ny = ny, - xat = xat, - yat = yat, - xaxlabels = xaxlabels, - yaxlabels = yaxlabels, - breaks = breaks, - axes = axes, - xaxt = xaxt, - yaxt = yaxt, - grayscale = grayscale, - x_by = x_by, - y_by = y_by - ), - facet.args = facet.args + grayscale = null_by && null_palette && is.null(.tpar[["palette.qualitative"]]) + + x = c(datapoints$xmin, datapoints$xmax) + y = c(datapoints$ymin, datapoints$ymax) + ymin = datapoints$ymin + ymax = datapoints$ymax + xmin = datapoints$xmin + xmax = datapoints$xmax + by = if (null_by) by else datapoints$by + facet = if (null_facet) facet else datapoints$facet + + # Save original values for type_info before overwriting + axes_orig = axes + xaxt_orig = xaxt + yaxt_orig = yaxt + + axes = FALSE + frame.plot = FALSE + xaxt = "n" + yaxt = "n" + xaxs = "i" + yaxs = "i" + ylabs = yaxlabels + type_info = list( + off = off, + x.categorical = x.categorical, + nx = nx, + ny = ny, + xat = xat, + yat = yat, + xaxlabels = xaxlabels, + yaxlabels = yaxlabels, + breaks = breaks, + axes = axes_orig, + xaxt = xaxt_orig, + yaxt = yaxt_orig, + grayscale = grayscale, + x_by = x_by, + y_by = y_by ) - - return(out) + env2env(environment(), settings, c( + "x", "y", "ymin", "ymax", "xmin", "xmax", "col", "bg", "datapoints", + "by", "facet", "axes", "frame.plot", "xaxt", "yaxt", "xaxs", "yaxs", + "ylabs", "type_info", "facet.args" + )) } return(fun) diff --git a/R/type_spline.R b/R/type_spline.R index 332db948..b1527ea0 100644 --- a/R/type_spline.R +++ b/R/type_spline.R @@ -1,28 +1,27 @@ #' Spline plot type -#' +#' #' @description Type function for plotting a cubic (or Hermite) spline interpolation. #' Arguments are passed to \code{\link[stats]{spline}}; see this latter function #' for default argument values. -#' +#' #' @inheritParams stats::spline #' @inherit stats::spline details #' @importFrom stats spline #' @examples #' # "spline" type convenience string #' tinyplot(dist ~ speed, data = cars, type = "spline") -#' +#' #' # Use `type_spline()` to pass extra arguments for customization -#' tinyplot(dist ~ speed, data = cars, type = type_spline(method = "natural", n = 25), +#' tinyplot(dist ~ speed, +#' data = cars, type = type_spline(method = "natural", n = 25), #' add = TRUE, lty = 2) #' @export -type_spline = function( - n = NULL, - method = "fmm", - xmin = NULL, - xmax = NULL, - xout = NULL, - ties = mean - ) { +type_spline = function(n = NULL, + method = "fmm", + xmin = NULL, + xmax = NULL, + xout = NULL, + ties = mean) { out = list( draw = draw_lines(), data = data_spline(method = method, ties = ties, n = n, xmin = xmin, xmax = xmax, xout = xout), @@ -34,10 +33,12 @@ type_spline = function( data_spline = function(n, method, xmin, xmax, xout, ties, ...) { - fun = function(datapoints, ...) { + fun = function(settings, ...) { + env2env(settings, environment(), "datapoints") + datapoints = split(datapoints, list(datapoints$facet, datapoints$by), drop = TRUE) datapoints = lapply(datapoints, function(dat) { - if (is.null(n)) n = 3*length(dat$x) + if (is.null(n)) n = 3 * length(dat$x) if (is.null(xmax)) xmax = max(dat$x) if (is.null(xmin)) xmin = min(dat$x) if (is.null(xout)) { @@ -52,9 +53,7 @@ data_spline = function(n, method, xmin, xmax, xout, ties, ...) { return(fit) }) datapoints = do.call(rbind, datapoints) - out = list(datapoints = datapoints) - return(out) + env2env(environment(), settings, "datapoints") } return(fun) } - diff --git a/R/type_summary.R b/R/type_summary.R index 90d9fcdf..059609f9 100644 --- a/R/type_summary.R +++ b/R/type_summary.R @@ -16,30 +16,33 @@ #' @examples #' # Plot the mean chick weight over time #' tinyplot(weight ~ Time, data = ChickWeight, type = "summary") -#' +#' #' # Note: "mean" is the default function, so these are also equivalent: #' # tinyplot(weight ~ Time, data = ChickWeight, type = type_summary()) #' # tinyplot(weight ~ Time, data = ChickWeight, type = type_summary(mean)) -#' +#' #' # Plot the median instead #' tinyplot(weight ~ Time, data = ChickWeight, type = type_summary(median)) -#' +#' #' # Works with groups and/or facets too #' tinyplot(weight ~ Time | Diet, facet = "by", data = ChickWeight, type = "summary") #' #' # Custom/complex function example #' tinyplot( -#' weight ~ Time | Diet, facet = "by", data = ChickWeight, -#' type = type_summary(function(y) quantile(y, probs = 0.9)/max(y)) +#' weight ~ Time | Diet, +#' facet = "by", data = ChickWeight, +#' type = type_summary(function(y) quantile(y, probs = 0.9) / max(y)) #' ) -#' +#' #' @importFrom stats ave #' @export type_summary = function(fun = mean, ...) { assert_function(fun) lines_args = list(...) data_summary = function(fun) { - funky = function(datapoints, ...) { + funky = function(settings, ...) { + env2env(settings, environment(), c("datapoints", "by", "facet")) + datapoints = split(datapoints, list(datapoints$facet, datapoints$by), drop = TRUE) datapoints = lapply(datapoints, function(dat) { newy = ave(dat$y, dat$x, FUN = fun) @@ -48,8 +51,7 @@ type_summary = function(fun = mean, ...) { return(dat) }) datapoints = do.call(rbind, datapoints) - out = list(datapoints = datapoints) - return(out) + env2env(environment(), settings, "datapoints") } return(funky) } diff --git a/R/type_text.R b/R/type_text.R index 90ca2819..425bf81e 100644 --- a/R/type_text.R +++ b/R/type_text.R @@ -85,7 +85,8 @@ type_text = function( } data_text = function(labels = NULL, clim = c(0.5, 2.5)) { - fun = function(datapoints, legend_args, cex = NULL, ...) { + fun = function(settings, cex = NULL, ...) { + env2env(settings, environment(), "datapoints") if (is.null(labels)) { labels = datapoints$y } @@ -124,13 +125,12 @@ data_text = function(labels = NULL, clim = c(0.5, 2.5)) { } } - out = list( - datapoints = datapoints, - cex = cex, - bubble = bubble, - bubble_cex = bubble_cex - ) - return(out) + env2env(environment(), settings, c( + "datapoints", + "cex", + "bubble", + "bubble_cex" + )) } return(fun) } diff --git a/R/type_violin.R b/R/type_violin.R index 30b66561..d9e3db2a 100644 --- a/R/type_violin.R +++ b/R/type_violin.R @@ -78,7 +78,9 @@ type_violin = function( data_violin = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512, joint.bw = "none", trim = FALSE, width = 0.9) { - fun = function(datapoints, by, facet, ylab, col, bg, palette, log, null_by, null_facet, ...) { + fun = function(settings, ...) { + env2env(settings, environment(), c("datapoints", "by", "null_palette", "facet", "ylab", "col", "bg", "log", "null_by", "null_facet")) + # Handle ordering based on by and facet variables ngrps = if (null_by) 1 else length(unique(datapoints$by)) @@ -122,7 +124,7 @@ data_violin = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512, xord = order(datapoints$by, datapoints$facet, datapoints$x) } - if (length(unique(datapoints[["by"]])) == 1 && is.null(palette)) { + if (length(unique(datapoints[["by"]])) == 1 && null_palette) { if (is.null(col)) col = par("fg") if (is.null(bg)) bg = "lightgray" } else if (is.null(bg)) { @@ -202,17 +204,18 @@ data_violin = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512, }) datapoints = do.call(rbind, datapoints) datapoints = datapoints[1:(nrow(datapoints)-1), ] - - out = list( - datapoints = datapoints, - by = if (length(unique(datapoints$by)) == 1) by else datapoints$by, - facet = if (length(unique(datapoints$facet)) == 1) facet else datapoints$facet, - ylab = ylab, - xlabs = xlabs, - col = col, - bg = bg - ) - return(out) + + by = if (length(unique(datapoints$by)) == 1) by else datapoints$by + facet = if (length(unique(datapoints$facet)) == 1) facet else datapoints$facet + env2env(environment(), settings, c( + "datapoints", + "by", + "facet", + "ylab", + "xlabs", + "col", + "bg" + )) } return(fun) } diff --git a/R/type_vline.R b/R/type_vline.R index aefad8f0..25748211 100644 --- a/R/type_vline.R +++ b/R/type_vline.R @@ -4,7 +4,8 @@ #' @export type_vline = function(v = 0) { assert_numeric(v) - data_vline = function(datapoints, lwd, lty, col, ...) { + data_vline = function(settings, ...) { + env2env(settings, environment(), c("datapoints", "lwd", "lty", "col")) if (nrow(datapoints) == 0) { msg = "`type_vline() only works on existing plots with x and y data points." stop(msg, call. = FALSE) @@ -14,27 +15,26 @@ type_vline = function(v = 0) { ul_lwd = length(unique(lwd)) ul_lty = length(unique(lty)) ul_col = length(unique(col)) - return(list(type_info = list(ul_lty = ul_lty, ul_lwd = ul_lwd, ul_col = ul_col))) + + type_info = list(ul_lty = ul_lty, ul_lwd = ul_lwd, ul_col = ul_col) + env2env(environment(), settings, "type_info") } draw_vline = function() { - fun = function( - ifacet, iby, data_facet, icol, ilty, ilwd, - ngrps, nfacets, by_continuous, facet_by, - type_info, - ... - ) { - + fun = function(ifacet, iby, data_facet, icol, ilty, ilwd, + ngrps, nfacets, by_continuous, facet_by, + type_info, + ...) { # flag for aesthetics by groups grp_aes = type_info[["ul_col"]] == 1 || type_info[["ul_lty"]] == ngrps || type_info[["ul_lwd"]] == ngrps - + if (length(v) != 1) { - if (!length(v) %in% c(ngrps, nfacets, ngrps*nfacets)) { + if (!length(v) %in% c(ngrps, nfacets, ngrps * nfacets)) { msg = "Length of 'v' must be 1, or equal to the number of facets or number of groups (or product thereof)." stop(msg, call. = FALSE) } if (!facet_by && length(v) == nfacets) { v = v[ifacet] - if (!grp_aes && type_info[["ul_col"]]!=ngrps) { + if (!grp_aes && type_info[["ul_col"]] != ngrps) { icol = 1 } else if (by_continuous) { icol = 1 @@ -47,7 +47,7 @@ type_vline = function(v = 0) { } else if (!grp_aes) { icol = 1 } - + abline(v = v, col = icol, lty = ilty, lwd = ilwd) } return(fun) diff --git a/R/utils.R b/R/utils.R index 9443a7c2..371efe95 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,9 +1,35 @@ -rescale_num = function(x, from = NULL, to = NULL) { - if (is.null(from)) from = range(x) - if (is.null(to)) to = c(0, 1) - (x - from[1]) / diff(from) * diff(to) + to[1] +## Null coalescing operator +if (getRversion() <= "4.4.0") { + `%||%` = function(x, y) if (is.null(x)) y else x +} + + +## Function that computes an appropriate bandwidth kernel based on a string +## input +bw_fun = function(kernel, x) { + kernel = tolower(kernel) + switch(kernel, + nrd0 = bw.nrd0(x), + nrd = bw.nrd(x), + ucv = bw.ucv(x), + bcv = bw.bcv(x), + sj = bw.SJ(x), + stop("Invalid `bw` string. Choose from 'nrd0', 'nrd', 'ucv', 'bcv', or 'SJ'.") + ) +} + + +# Assign (inject) elements from one environment into another +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) + } } + ## Function for efficiently checking whether a vector has more than n unique ## values (uses a hash set approach for large vectors to check sequentially) more_than_n_unique = function(x, n, small_vec_len = 1e3L) { @@ -29,27 +55,15 @@ more_than_n_unique = function(x, n, small_vec_len = 1e3L) { } -## Null coalescing operator -if (getRversion() <= "4.4.0") { - `%||%` = function(x, y) if (is.null(x)) y else x -} - - -## Function that computes an appropriate bandwidth kernel based on a string -## input -bw_fun = function(kernel, x) { - kernel = tolower(kernel) - switch(kernel, - nrd0 = bw.nrd0(x), - nrd = bw.nrd(x), - ucv = bw.ucv(x), - bcv = bw.bcv(x), - sj = bw.SJ(x), - stop("Invalid `bw` string. Choose from 'nrd0', 'nrd', 'ucv', 'bcv', or 'SJ'.") - ) +# Rescale numeric (used for continuous legends, etc.) +rescale_num = function(x, from = NULL, to = NULL) { + if (is.null(from)) from = range(x) + if (is.null(to)) to = c(0, 1) + (x - from[1]) / diff(from) * diff(to) + to[1] } +# Convenience function for swapping variables (e.g., use in flipped plots) swap_variables = function(env, ...) { pairs = list(...) for (p in pairs) { @@ -59,6 +73,7 @@ swap_variables = function(env, ...) { } } +# Convenience function for swapping columns (e.g., use in flipped plots) swap_columns = function(dp, a, b) { va = dp[[a]] vb = dp[[b]] diff --git a/R/zzz.R b/R/zzz.R index 0274023e..fa359b63 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -10,58 +10,92 @@ globalVariables(c( "add", + "alpha", "asp", "axes", + "bg", + "bubble", + "bubble_alpha", + "bubble_bg_alpha", + "bubble_cex", "by_continuous", + "by_dep", "by_ordered", - "bubble_cex", + "cex", + "cex_dep", "cex_fct_adj", + "data", + "datapoints", "dots", "draw", + "facet", + "facet.args", + "facet_attr", "facet_bg", "facet_border", + "facet_by", "facet_col", "facet_font", "facet_newlines", "facet_rect", "facet_text", - "facet.args", - "facet", "facets", "fill", "flip", "frame.plot", "has_legend", + "height", "iby", "ifacet", + "lty", + "lwd", "nfacet_cols", "nfacet_rows", "nfacets", "ngrps", + "null_by", + "null_facet", + "null_palette", + "null_xlim", + "null_ylim", "oxaxis", "oyaxis", + "pch", "ribbon.alpha", "split_data", "tpars", "type", + "type_info", + "was_area_type", + "width", "x", + "x_by", + "x_dep", + "xaxb", "xaxl", "xaxs", "xaxt", + "xlab", "xlabs", "xlim", - "xlim_user", "xlvls", "xmax", + "xmax_dep", "xmin", + "xmin_dep", "y", + "y_dep", + "yaxb", "yaxl", "yaxs", "yaxt", + "ygroup", + "ylab", "ylabs", "ylim", - "ylim_user", "ymax", - "ymin" + "ymax_dep", + "ymin", + "ymin_dep" )) } diff --git a/man/facet.Rd b/man/facet.Rd index 5e0bd34d..0c226cb7 100644 --- a/man/facet.Rd +++ b/man/facet.Rd @@ -29,14 +29,14 @@ draw_facet_window( oyaxis, xlabs, xlim, - xlim_user, + null_xlim, xaxt, xaxs, xaxb, xaxl, ylabs, ylim, - ylim_user, + null_ylim, yaxt, yaxs, yaxb, @@ -57,7 +57,10 @@ draw_facet_window( tpars = NULL ) -facet_layout(facet, add = FALSE, facet.args = list()) +facet_layout(settings) +} +\arguments{ +\item{settings}{A list of settings as created by \code{tinyplot()}.} } \description{ Internal functions called from \code{tinyplot} in order to draw the diff --git a/man/type_abline.Rd b/man/type_abline.Rd index 8051d9a2..e6dbcdb1 100644 --- a/man/type_abline.Rd +++ b/man/type_abline.Rd @@ -91,7 +91,7 @@ tinyplot(mpg ~ hp | cyl, facet = "by", data = mtcars, ylim = c(0, 40)) tinyplot_add(type = "hline", col = "grey") # Note that group+facet aesthetics will be inherited. We can use this to -# add customized lines (here: the mean `mpg` for each `cyl` group) +# add customized lines (here: the mean `mpg` for each `cyl` group) tinyplot_add(type = type_hline(with(mtcars, tapply(mpg, cyl, mean))), lty = 2) # Similar idea for vline @@ -107,11 +107,13 @@ tinyplot(mpg ~ wt | factor(cyl), data = mtcars, type = type_hline(h = 21:23)) tinyplot(mpg ~ wt, facet = ~am, data = mtcars, type = type_hline(h = c(20, 30))) # length(h) == no. of groups x no. of facets -tinyplot(mpg ~ wt | factor(cyl), facet = ~am, data = mtcars, - type = type_hline(h = 21:26)) +tinyplot(mpg ~ wt | factor(cyl), + facet = ~am, data = mtcars, + type = type_hline(h = 21:26)) # special adjustment case (here: lwd by group) -tinyplot(mpg ~ wt | factor(cyl), facet = ~am, data = mtcars, - type = type_hline(c(20, 30)), lwd = c(21, 14, 7)) +tinyplot(mpg ~ wt | factor(cyl), + facet = ~am, data = mtcars, + type = type_hline(c(20, 30)), lwd = c(21, 14, 7)) } diff --git a/man/type_histogram.Rd b/man/type_histogram.Rd index dc5e78f4..02115fbf 100644 --- a/man/type_histogram.Rd +++ b/man/type_histogram.Rd @@ -73,14 +73,15 @@ tinyplot(Nile, type = type_histogram(breaks = 30, freq = FALSE)) # Grouped histogram example tinyplot( - ~Petal.Width | Species, + ~ Petal.Width | Species, type = "histogram", data = iris ) # Faceted version tinyplot( - ~Petal.Width, facet = ~Species, + ~Petal.Width, + facet = ~Species, type = "histogram", data = iris ) @@ -91,14 +92,16 @@ tinyplot( # free facet scales + shared histogram breaks, versus... tinyplot( - ~Petal.Width, facet = ~Species, + ~Petal.Width, + facet = ~Species, facet.args = list(free = TRUE), type = type_histogram(), data = iris ) # ... free facet scales + free histogram breaks tinyplot( - ~Petal.Width, facet = ~Species, + ~Petal.Width, + facet = ~Species, facet.args = list(free = TRUE), type = type_histogram(free = TRUE), data = iris diff --git a/man/type_points.Rd b/man/type_points.Rd index 3e9d1745..5a93ecc0 100644 --- a/man/type_points.Rd +++ b/man/type_points.Rd @@ -35,9 +35,8 @@ tinyplot(Sepal.Length ~ Petal.Length, data = iris, cex = iris$Sepal.Width) # Fancier version with dual legends and extra customization tinyplot(Sepal.Length ~ Petal.Length | Species, - data = iris, - cex = iris$Sepal.Width, clim = c(1, 5), - pch = 21, fill = 0.3) - + data = iris, + cex = iris$Sepal.Width, clim = c(1, 5), + pch = 21, fill = 0.3) } diff --git a/man/type_ribbon.Rd b/man/type_ribbon.Rd index 412b1de8..910f2008 100644 --- a/man/type_ribbon.Rd +++ b/man/type_ribbon.Rd @@ -22,14 +22,14 @@ define a \code{y} interval (usually spanning from \code{ymin} to \code{ymax}) fo set to 0 and \code{ymax} is set to \code{y}. } \examples{ -x = 1:100/10 +x = 1:100 / 10 y = sin(x) # ## Ribbon plots # "ribbon" convenience string -tinyplot(x = x, ymin = y-1, ymax = y+1, type = "ribbon") +tinyplot(x = x, ymin = y - 1, ymax = y + 1, type = "ribbon") # Same result with type_ribbon() tinyplot(x = x, ymin = y-1, ymax = y+1, type = type_ribbon()) @@ -38,7 +38,7 @@ tinyplot(x = x, y = y, ymin = y-1, ymax = y+1, type = "ribbon") # ## Area plots - + # "area" type convenience string tinyplot(x, y, type = "area") diff --git a/man/type_spline.Rd b/man/type_spline.Rd index 7c4468c6..7055dcc0 100644 --- a/man/type_spline.Rd +++ b/man/type_spline.Rd @@ -70,6 +70,7 @@ The inputs can contain missing values which are deleted, so at least tinyplot(dist ~ speed, data = cars, type = "spline") # Use `type_spline()` to pass extra arguments for customization -tinyplot(dist ~ speed, data = cars, type = type_spline(method = "natural", n = 25), +tinyplot(dist ~ speed, + data = cars, type = type_spline(method = "natural", n = 25), add = TRUE, lty = 2) } diff --git a/man/type_summary.Rd b/man/type_summary.Rd index 3d103904..70e17e74 100644 --- a/man/type_summary.Rd +++ b/man/type_summary.Rd @@ -35,8 +35,9 @@ tinyplot(weight ~ Time | Diet, facet = "by", data = ChickWeight, type = "summary # Custom/complex function example tinyplot( - weight ~ Time | Diet, facet = "by", data = ChickWeight, - type = type_summary(function(y) quantile(y, probs = 0.9)/max(y)) + weight ~ Time | Diet, + facet = "by", data = ChickWeight, + type = type_summary(function(y) quantile(y, probs = 0.9) / max(y)) ) } diff --git a/vignettes/introduction.qmd b/vignettes/introduction.qmd index 11f3bfe7..9fdaf403 100644 --- a/vignettes/introduction.qmd +++ b/vignettes/introduction.qmd @@ -478,6 +478,7 @@ keystrokes by typing `plt_add()` instead of `tinyplot_add()`: #| eval: false plt_add(type = "lm") ``` + ::: A related---but distinct---concept to adding plot layers is _drawing_ on a plot. diff --git a/vignettes/types.qmd b/vignettes/types.qmd index 4ce53173..a248e9c1 100644 --- a/vignettes/types.qmd +++ b/vignettes/types.qmd @@ -166,8 +166,8 @@ tinyplot(Temp ~ Wind | Month, data = aq, facet = "by", type = "lm") It is easy to add custom types to **tinyplot**. Users who need highly customized plots, or developers who want to add support to their package or functions, only -need to define three simple functions: `data_typename()`, `draw_typename()`, and -`type_typename()`. +need to define three simple functions: `data_()`, `draw_()`, and +`type_()`. In this section, we explain the role of each of these functions and present a minimalist example of a custom type. Interested readers may refer to @@ -177,36 +177,44 @@ custom type. The three functions that we need to define for a new type are: -1. `data_*()`: Function factory. - - Accepts a list of internal objects - - Inputs must include `...` - - `datapoints` Is the most important object. It is a data frame with the datapoints to plot. - - Other objects that can be modified by `data_*()` include: `by`, `facet`, `ylab`, `palette` - - Returns a named list with modified versions of those objects. -2. `draw_*()`: Function factory. - - Accepts information about data point values and aesthetics. +1. `data_()`: Data function factory. + - Must take two arguments: + - `settings` is a special internal environment containing useful parameters that can be read or modified by `tinyplot` functions, including `datapoints`, `by`, `facet`, `xlab`, `ylab`, `xlim`, `ylim`, `palette`, and many more (see below) + - `...` + - Defines the data that will be passed on to the plotting functions (including any necessary transformations). Note that this function should modify the `settings` environment in-place; it does not need to return anything +2. `draw_()`: Drawing function factory. + - Accepts information about data point values and aesthetics. - Inputs must include `...` - The `i` prefix in argument names indicates that we are operating on a subgroup of the data, identified by `facet` or using the `|` operator in a formula. - Available arguments are: `ibg`, `icol`, `ilty`, `ilwd`, `ipch`, `ix`, `ixmax`, `ixmin`, `iy`, `iymax`, `iymin`, `cex`, `dots`, `type`, `x_by`, `i`, `facet_by`, `by_data`, `facet_data`, `flip` - Returns a function which can call base R to draw the plot. -3. `type_*()`: A wrapper function that returns a named list with three elements: +3. `type_()`: A wrapper function that returns a named list with three elements: - `draw` - `data` - `name` -Here is a minimalist example of a custom type that logs both `x` and `y` and -plots lines. +### A minimal example + +Here is a minimal example of a custom type that logs both `x` and `y` and +plots points. Note how we use `env2env()` to extract variables from the `settings` +environment, modify them, and copy the modified values back: ```{r} #| layout-ncol: 2 type_log = function(base = exp(1)) { data_log = function() { - fun = function(datapoints, ...) { + fun = function(settings, ...) { + # Extract datapoints from settings environment + datapoints = settings$datapoints + + # Transform the data datapoints$x = log(datapoints$x, base = base) datapoints$y = log(datapoints$y, base = base) datapoints = datapoints[order(datapoints$x), ] - return(list(datapoints = datapoints, ...)) + + # Assign (inject) modified datapoints back to settings + settings$datapoints = datapoints } return(fun) } @@ -238,7 +246,9 @@ tinyplot(mpg ~ wt | factor(am), data = mtcars, type = type_log(base = 10), main = "Log 10") ``` -To underscore what we said above, the **tinyplot** +### More examples + +The **tinyplot** [source code](https://github.com/grantmcdermott/tinyplot/tree/main/R) contains many examples of type constructor functions that should provide a helpful starting point for custom plot types. Failing that, the **tinyplot** @@ -246,3 +256,33 @@ team are always happy to help guide users on how to create their own types and re-purpose existing **tinyplot** code. Just let us know by [raising an issue](https://github.com/grantmcdermott/tinyplot/issues) on our GitHub repo. + + +### Available settings + +To see what parameters are available in the `settings` environment, we can create +a simple `type_error()` that stops with the names of all available settings: + +```{r} +#| error: true +type_error = function() { + data_error = function() { + fun = function(settings, ...) { + stop(paste(names(settings), collapse = ", ")) + } + return(fun) + } + + out = list( + data = data_error() + ) + class(out) = "tinyplot_type" + return(out) +} + +tinyplot(mpg ~ wt, data = mtcars, type = type_error()) +``` + +As we can see, the `settings` environment contains many parameters that custom +types can use as inputs or modify as needed. +