Several performance improvements (#387)

* simplify pretty print

* simplify unit deparsing

* remove remaining uses of table()

* simplify how we cast into char for udunits

* convert only units that are different in c()

* update NEWS

NEWS.md

@@ -22,6 +22,8 @@
 
 * Add support for `brew` path discovery in macOS; #384
 
+* Several performance improvements; #387 addressing #386
+
 # version 0.8-5
 
 * avoid -Wformat-security warning on CRAN

R/arith.R

@@ -181,17 +181,16 @@ Ops.units <- function(e1, e2) {
     if (e2 == 0) {
       u <- units(as_units(1))
     } else {
-      if (any((table(units(e1)$denominator)*e2) %% 1 != 0) ||
-          any((table(units(e1)$numerator)*e2)   %% 1 != 0))
-            stop("powers not divisible") # work on wording
-      if (e2 > 0)
-        u <- .symbolic_units(
-          rep(unique(units(e1)$numerator),table(units(e1)$numerator)*e2),
-          rep(unique(units(e1)$denominator),table(units(e1)$denominator)*e2))
-      else
-        u <- .symbolic_units(
-          rep(unique(units(e1)$denominator),table(units(e1)$denominator)*abs(e2)),
-          rep(unique(units(e1)$numerator),table(units(e1)$numerator)*abs(e2)))
+      tbl_den <- tabulate(factor(units(e1)$denominator))
+      tbl_num <- tabulate(factor(units(e1)$numerator))
+      if (any((tbl_den*e2) %% 1 != 0) || any((tbl_num*e2) %% 1 != 0))
+        stop("powers not divisible") # work on wording
+      u <- if (e2 > 0) .symbolic_units(
+        rep(unique(units(e1)$numerator), tbl_num*e2),
+        rep(unique(units(e1)$denominator), tbl_den*e2))
+      else .symbolic_units(
+        rep(unique(units(e1)$denominator), tbl_den*abs(e2)),
+        rep(unique(units(e1)$numerator), tbl_num*abs(e2)))
     }
   } else { # pm:
     units(e2) <- units(e1)

R/misc.R

@@ -12,18 +12,28 @@ c.units <- function(..., recursive = FALSE, allow_mixed = units_options("allow_m
   args <- list(...)
   args[sapply(args, is.null)] <- NULL # remove NULLs
   u <- units(args[[1]])
+
   if (length(args) == 1)
-  	.as.units(NextMethod(), u)
-  else if (.units_are_convertible(args[-1], u)) {
-    args <- lapply(args, set_units, u, mode="standard")
-    .as.units(do.call(c, lapply(args, drop_units)), u)
-  } else if (allow_mixed)
-    do.call(c, lapply(args, mixed_units))
-  else
-  	stop("units are not convertible, and cannot be mixed; try setting units_options(allow_mixed = TRUE)?")
+    return(.as.units(NextMethod(), u))
+
+  dup <- c(TRUE, duplicated(lapply(args, units))[-1])
+
+  if (all(dup))
+    return(.as.units(do.call(c, lapply(args, drop_units)), u))
+
+  if (.units_are_convertible(args[!dup], u)) {
+    args[!dup] <- lapply(args[!dup], set_units, u, mode = "standard")
+    return(.as.units(do.call(c, lapply(args, drop_units)), u))
+  }
+
+  if (allow_mixed)
+    return(do.call(c, lapply(args, mixed_units)))
+
+  stop("units are not convertible, and cannot be mixed; try setting units_options(allow_mixed = TRUE)?")
 }
 
 .units_are_convertible = function(x, u) {
+  u <- ud_char(u)
 	for (i in seq_along(x))
 		if (! ud_are_convertible(units(x[[i]]), u))
 			return(FALSE)
@@ -50,21 +60,13 @@ rep.units = function(x, ...) {
 #' @param x object of class units
 #' @return length one character vector
 #' @examples
-#' u = as_units("kg m-2 s-1", implicit_exponents = TRUE)
+#' u = as_units("kg m-2 s-1")
 #' u
 #' deparse_unit(u)
 #' @export
 deparse_unit = function(x) {
   stopifnot(inherits(x, "units"))
-  u = units(x)
-  tn = table(u$numerator)
-  nm1 = names(tn)
-  vals1 = as.character(tn)
-  vals1[vals1 == "1"] = ""
-  td = - table(u$denominator)
-  nm2 = names(td)
-  vals2 = as.character(td)
-  paste(c(paste0(nm1, vals1), paste0(nm2, vals2)), collapse=" ")
+  as.character(units(x), neg_power=TRUE, prod_sep=" ")
 }
 # This should perhaps be an option in format.symbolic_units
 

R/mixed.R

@@ -101,10 +101,10 @@ as.character.mixed_symbolic_units = function(x, ...) {
 .cat_units_table <- function(x) {
   cat("Mixed units: ")
   if (!length(x)) return()
-
-  tbl = table(as.character(units(x)))
-  tbl = paste(names(tbl), " (", as.numeric(tbl), ")", sep = "")
-  cat(paste(tbl, collapse = ", "), "\n")
+  x <- as.character(units(x))
+  u <- unique(x)
+  n <- tabulate(factor(x, u))
+  cat(paste(u, " (", n, ")", sep = "", collapse = ", "), "\n")
 }
 
 #' @export

R/symbolic_units.R

@@ -46,38 +46,20 @@ Ops.symbolic_units <- function(e1, e2) {
 unitless <- .symbolic_units(vector("character"), vector("character"))
 
 .pretty_print_sequence <- function(terms, op, neg_power = FALSE, sep = "") {
-  # `fix` handles cases where a unit is actually an expression. We would have to
-  # deparse these to really do a pretty printing, but for now we leave them alone...
-  fix <- function(term) {
-    if (length(grep("/", term)) || length(grep("-", term)))
-      paste0("(", term, ")")
-    else
-      term
-  }
-  fixed <- vapply(terms, fix, "")
-  fixed_tbl <- table(fixed)
-
-  names <- names(fixed_tbl)
-  result <- vector("character", length(fixed_tbl))
-  for (i in seq_along(fixed_tbl)) {
-    name <- names[i]
-    value <- fixed_tbl[i]
-    if (value > 1 || (value == 1 && neg_power)) {
-	  if (neg_power)
-	  	value <- value * -1.
-      result[i] <- paste0(name, "^", value)
-    } else {
-      result[i] <- name
-    }
-  }
-
-  paste0(result, collapse = paste0(op, sep))
+  pwr_op <- if (op == " ") "" else "^"
+  sym <- unique(terms)
+  pwr <- tabulate(factor(terms, sym))
+  if (neg_power) pwr <- pwr * -1
+
+  for (i in seq_along(sym)) if (pwr[i] != 1)
+    sym[i] <- paste(sym[i], pwr[i], sep = pwr_op)
+  paste0(sym, collapse = paste0(op, sep))
 }
 
 #' @export
 as.character.symbolic_units <- function(x, ...,
 		neg_power = get(".units.negative_power", envir = .units_options),
-		escape_units = FALSE, plot_sep = "") {
+		escape_units = FALSE, prod_sep = "*", plot_sep = "") {
   sep <- plot_sep
 
   numerator <- x$numerator
@@ -97,7 +79,7 @@ as.character.symbolic_units <- function(x, ...,
   }
 
   num_str <- if (length(numerator) > 0)
-      .pretty_print_sequence(numerator, "*", FALSE, plot_sep)
+      .pretty_print_sequence(numerator, prod_sep, FALSE, plot_sep)
     else  { # only denominator:
       if (! neg_power)
 	    "1" # 1/cm^2/h
@@ -107,9 +89,7 @@ as.character.symbolic_units <- function(x, ...,
 
   denom_str <- if (length(denominator) > 0) {
     sep <- if (neg_power)
-      paste0("*", plot_sep)
-    else
-       "/"
+      paste0(prod_sep, plot_sep) else "/"
     .pretty_print_sequence(denominator, sep, neg_power, plot_sep)
   } else
     character(0)

R/udunits.R

@@ -20,10 +20,18 @@
 ud_are_convertible = function(x, y) {
 	stopifnot(inherits(x, c("character", "symbolic_units")), inherits(y, c("character", "symbolic_units")))
 	res <- try(R_ut_are_convertible(
-	  R_ut_parse(as.character(x)), R_ut_parse(as.character(y))), silent = TRUE)
+	  R_ut_parse(ud_char(x)), R_ut_parse(ud_char(y))), silent = TRUE)
 	! inherits(res, "try-error") && res
 }
 
+ud_char <- function(x) {
+  if (is.character(x)) return(x)
+  res <- paste(x$numerator, collapse=" ")
+  if (length(x$denominator))
+    res <- paste0(res, " (", paste(x$denominator, collapse=" "), ")-1")
+  res
+}
+
 ud_are_same <- function(x, y) {
   get_base <- function(x)
     tail(strsplit(R_ut_format(R_ut_parse(x), definition=TRUE), " ")[[1]], 1)