Centralized and simplify xlab and ylab processing

R/by_aesthetics.R

@@ -274,7 +274,7 @@ gen_pal_fun = function(pal, gradient = FALSE, alpha = NULL, n = NULL) {
 by_pch = function(ngrps, type, pch = NULL) {
   no_pch = FALSE
   if (identical(type, "text")) {
-    pch <- rep(15, ngrps)
+    pch = rep(15, ngrps)
   } else if (!type %in% c("p", "b", "o", "pointrange", "errorbar", "boxplot", "qq")) {
     no_pch = TRUE
     pch = NULL

R/hooks.R

@@ -12,23 +12,23 @@
 #'   a list of functions.
 #' @param action `"replace"`, `"append"` or `"prepend"`
 #' @keywords internal
-set_hooks <- function(hooks, action = "append") {
-  old <- list()
+set_hooks = function(hooks, action = "append") {
+  old = list()
   for (hook_name in names(hooks)) {
-    old[[hook_name]] <- getHook(hook_name)
+    old[[hook_name]] = getHook(hook_name)
     setHook(hook_name, hooks[[hook_name]], action = action)
   }
   invisible(old)
 }
 
 #' @rdname set_hooks
 #' @keywords internal
-remove_hooks <- function(hooks) {
+remove_hooks = function(hooks) {
   for (hook_name in names(hooks)) {
-    hook <- getHook(hook_name)
+    hook = getHook(hook_name)
     if (length(hook) > 0) {
       for (fun in unlist(hooks[hook_name])) {
-        hook[sapply(hook, identical, fun)] <- NULL
+        hook[sapply(hook, identical, fun)] = NULL
       }
     }
     setHook(hook_name, hook, "replace")

R/sanitize.R

@@ -109,3 +109,31 @@ sanitize_type = function(type, x, y, dots) {
   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))
+}

R/sanitize_xylab.R

@@ -0,0 +1,54 @@
+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) {
+  out_xlab = NULL
+  out_ylab = NULL
+
+  is_boxplot = type %in% c("boxplot")
+  is_density = type %in% c("density")
+  is_frequency = type %in% c("histogram", "barplot", "function")
+  is_function = type %in% c("function")
+  is_range = type %in% c("rect", "segments", "pointrange")
+  is_ribbon = type %in% c("ribbon")
+  is_index = !is_frequency && !is_ribbon && !is_density
+
+  ##### xlab
+  if (!is.null(xlab)) {
+    out_xlab = xlab
+  } else if (!is.null(xmin_dep) && !is.null(xmax_dep)) {
+    out_xlab = sprintf("[%s, %s]", xmin_dep, xmax_dep)
+  } else if (is_boxplot && is.null(y)) {
+    out_xlab = ""
+  } else if (is_index && is.null(y) && !is.null(x)) {
+    out_xlab = "Index"
+  } else {
+    out_xlab = x_dep
+  }
+
+  ##### ylab
+  if (!is.null(ylab)) {
+    out_ylab = ylab
+  } else if (is_frequency && is.null(y) && !is.null(x)) {
+    out_ylab = "Frequency"
+  } else if (is_density && is.null(y) && !is.null(x)) {
+    out_ylab = "Density"
+  } else if (is_ribbon) {
+    if (!is.null(y_dep)) {
+      out_ylab = y_dep
+    } else if (!is.null(ymin_dep) && !is.null(ymax_dep)) {
+      out_ylab = sprintf("[%s, %s]", ymin_dep, ymax_dep)
+    }
+  } else if ((is_range || is_ribbon) && !is.null(ymin_dep) && !is.null(ymax_dep)) {
+    out_ylab = sprintf("[%s, %s]", ymin_dep, ymax_dep)
+  } else if (!is.null(y_dep)) {
+    out_ylab = y_dep
+  } else if (is.null(y) && !is.null(x_dep)) {
+    out_ylab = x_dep
+  } else {
+    out_ylab = NULL
+  }
+
+  out = list(xlab = out_xlab, ylab = out_ylab)
+  return(out)
+}

R/tinyplot.R

@@ -695,28 +695,10 @@ tinyplot.default = function(
   # will be overwritten by some type_data() functions and ignored by others
   ribbon.alpha = sanitize_ribbon.alpha(NULL)
 
-  ## 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"))
+  # axes
+  list2env(
+    sanitize_axes(axes, xaxt, yaxt, frame.plot),
+    environment())
 
   # Write plot to output file or window with fixed dimensions
   setup_device(file = file, width = width, height = height)
@@ -743,17 +725,14 @@ tinyplot.default = function(
   }
 
   # Capture deparsed expressions early, before x, y and by are evaluated
-  x_dep = if (!is.null(x)) {
-    deparse1(substitute(x))
-  } else if (type %in% c("rect", "segments")) {
-    x = NULL
-    NULL
-  }
-  y_dep = if (is.null(y)) {
-    deparse1(substitute(x))
-  } else {
-    deparse1(substitute(y))
-  }
+  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))
   null_by = is.null(by)
   cex_dep = if (!is.null(cex)) deparse1(substitute(cex)) else NULL
@@ -782,40 +761,33 @@ tinyplot.default = function(
   facet_attr = attributes(facet) ## TODO: better solution for restoring facet attributes?
   null_facet = is.null(facet)
 
+  # xlab & ylab
+  list2env(
+    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), 
+    environment())
+
   if (is.null(x)) {
     ## Special catch for rect and segment plots without a specified y-var
     if (type %in% c("rect", "segments")) {
-      xmin_dep = deparse(substitute(xmin))
-      xmax_dep = deparse(substitute(xmax))
-      x_dep = paste0("[", xmin_dep, ", ", xmax_dep, "]")
       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")) {
-      ymin_dep = deparse(substitute(ymin))
-      ymax_dep = deparse(substitute(ymax))
-      y_dep = paste0("[", ymin_dep, ", ", ymax_dep, "]")
       y = rep(NA, length(x))
-    } else if (type == "density") {
-      if (is.null(ylab)) ylab = "Density"
-    } else if (type == "function") {
-      if (is.null(ylab)) ylab = "Frequency"
     } else if (type == "boxplot") {
       y = x
       x = rep.int("", length(y))
-      xlab = ""
       xaxt = "a"
-    } else if (!(type %in% c("histogram", "barplot"))) {
+    } else if (!(type %in% c("histogram", "barplot", "density", "function"))) {
       y = x
       x = seq_along(x)
-      if (is.null(xlab)) xlab = "Index"
     }
   }
-
-  if (is.null(xlab)) xlab = x_dep
-  if (is.null(ylab) && type != "histogram") ylab = y_dep
 
   # 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)

R/type_barplot.R

@@ -98,7 +98,7 @@ data_barplot = function(width = 5/6, beside = FALSE, center = FALSE, FUN = NULL,
           if (anyNA(xlevels) || !all(xlevels %in% levels(datapoints$x))) warning("not all 'xlevels' correspond to levels of 'x'")
           datapoints$x = factor(datapoints$x, levels = xlevels)
         }
-        if (!is.null(xaxlabels)) levels(datapoints$x) <- xaxlabels
+        if (!is.null(xaxlabels)) levels(datapoints$x) = xaxlabels
         datapoints = aggregate(datapoints[, "y", drop = FALSE], datapoints[, c("x", "by", "facet")], FUN = FUN, drop = FALSE)
         datapoints$y[is.na(datapoints$y)] = 0 #FIXME: always?#
         if (!is.factor(datapoints$by)) datapoints$by = factor(datapoints$by)

R/type_qq.R

@@ -38,10 +38,10 @@ type_qq = function(distribution = qnorm) {
       )
 
       if (!is.null(ilty)) {
-        iy <- quantile(iy, c(0.25, 0.75))
-        ix <- quantile(ix, c(0.25, 0.75))
-        slope <- diff(iy) / diff(ix)
-        intercept <- iy[1] - slope * ix[1]
+        iy = quantile(iy, c(0.25, 0.75))
+        ix = quantile(ix, c(0.25, 0.75))
+        slope = diff(iy) / diff(ix)
+        intercept = iy[1] - slope * ix[1]
         abline(a = intercept, b = slope, lty = ilty, col = icol, lwd = ilwd)
       }
     }

R/type_text.R

@@ -21,7 +21,7 @@
 #'     adj = 0
 #'   )
 #' )
-#' 
+#'
 #' # to avoid clipping text at the plot region, we can use xpd = NA
 #' tinyplot(mpg ~ hp | factor(cyl),
 #'   data = mtcars,
@@ -47,23 +47,23 @@ type_text = function(labels, adj = NULL, pos = NULL, offset = 0.5, vfont = NULL,
 data_text = function(labels, clim = c(0.5, 2.5)) {
   fun = function(datapoints, legend_args, cex = NULL, ...) {
     if (length(labels) != 1 && length(labels) != nrow(datapoints)) {
-      msg <- sprintf("`labels` must be of length 1 or %s.", nrow(datapoints))
+      msg = sprintf("`labels` must be of length 1 or %s.", nrow(datapoints))
       stop(msg, call. = FALSE)
     }
     datapoints$labels = labels
-    
+
     # browser()
     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(c(bubble_labs, cex), to = clim)
-      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)]
+      cex = cex[(len_labs + 1):length(cex)]
       names(bubble_cex) = format(bubble_labs)
       if (max(clim) > 2.5) {
         legend_args[["x.intersp"]] = max(clim) / 2.5