Convert once per distinct pair of units instead of once per value

NEWS.md

@@ -19,7 +19,13 @@
   addressing #440 @billdenney
 
 * Format units longer than 255 bytes in full instead of silently truncating
-  them, which made e.g. `convert_to_base()` fail on such units; @billdenney
+  them, which made e.g. `convert_to_base()` fail on such units; #444 @billdenney
+
+* Convert once per distinct pair of units instead of once per element in
+  `ud_convert()`, `ud_are_convertible()` and so in every conversion of `units`
+  objects, and parse each distinct unit once in `mixed_units()` and in
+  `set_units()` on mixed units; e.g., `set_units(x, km)` on 1e6 values takes
+  2 ms instead of 11 s; #445 @billdenney
 
 # version 1.0-1
 

R/mixed.R

@@ -32,7 +32,22 @@ mixed_units.units = function(x, values, ...) {
 mixed_units.numeric = function(x, values, ...) {
 	#stopifnot(length(x) == length(values), is.character(values), is.numeric(x))
 	stopifnot(is.character(values), is.numeric(x))
-	.as.mixed_units(mapply(set_units, x, values, mode = "standard", SIMPLIFY = FALSE))
+	if (!ud_recycles(x, values))
+		return(.as.mixed_units(mapply(set_units, x, values, mode = "standard", SIMPLIFY = FALSE)))
+
+	# one set_units() per distinct unit, split back into one units object per value
+	n <- max(length(x), length(values))
+	nm <- names(x)
+	attributes(x) <- NULL
+	x <- rep_len(x, n)
+	values <- rep_len(values, n)
+	out <- vector("list", n)
+	for (i in split(seq_len(n), match(values, unique(values)))) {
+		u <- set_units(x[i], values[[i[1L]]], mode = "standard")
+		out[i] <- lapply(as.numeric(u), .as.units, value = units(u))
+	}
+	names(out) <- nm # as mapply() names its result
+	.as.mixed_units(out)
 }
 
 #' @export
@@ -76,7 +91,7 @@ set_units.mixed_units = function(x, value, ..., mode = "standard") {
   cv <- data.frame(
     val = as.numeric(x), from = I(units(x)), to = value, idx = seq_along(x),
     stringsAsFactors = FALSE)
-  sp <- paste(cv$from, cv$to, sep=".")
+  sp <- paste(vapply(cv$from, .mixed_units_key, ""), cv$to, sep=".")
   sp <- factor(sp, levels=unique(sp))
 
   # grouped conversion
@@ -90,6 +105,10 @@ set_units.mixed_units = function(x, value, ..., mode = "standard") {
   cv[order(cv$idx), ]$val
 }
 
+# Grouping key for the units of one mixed_units element: ud_char() is much
+# cheaper than as.character(), which pretty-prints.
+.mixed_units_key <- function(u) if (is.null(u)) "NULL" else ud_char(u)
+
 #' @export
 as_units.mixed_units = function(x, ...) {
 	set_units(do.call(c, x), value = units(x[[1]]), mode = "standard")

R/udunits.R

@@ -22,7 +22,19 @@ ud_are_convertible <- function(from, to, ...) {
     warning("variables `x` and `y` were unfortunate names, and are deprecated",
             "; please use `from` and `to` instead")
   }
-  mapply(ud_convertible, ud_char(from), ud_char(to), USE.NAMES=FALSE)
+  from <- ud_char(from)
+  to <- ud_char(to)
+  if (!ud_recycles(from, to))
+    return(mapply(ud_convertible, from, to, USE.NAMES=FALSE))
+
+  # one check per distinct pair of units
+  n <- max(length(from), length(to))
+  from <- rep_len(from, n)
+  to <- rep_len(to, n)
+  out <- logical(n)
+  for (i in ud_pairs(from, to))
+    out[i] <- ud_convertible(from[[i[1L]]], to[[i[1L]]])
+  out
 }
 
 #' @param x numeric vector
@@ -45,7 +57,41 @@ ud_are_convertible <- function(from, to, ...) {
 #' ud_convert(32, "degF", "degC")
 ud_convert <- function(x, from, to) {
   if (!length(x)) return(x)
-  mapply(ud_convert_doubles, x, ud_char(from), ud_char(to))
+  from <- ud_char(from)
+  to <- ud_char(to)
+  if (!is.atomic(x) || !ud_recycles(x, from, to))
+    return(mapply(ud_convert_doubles, x, from, to))
+
+  # one conversion per distinct pair of units, results in the original order
+  n <- max(length(x), length(from), length(to))
+  nm <- names(x)
+  attributes(x) <- NULL
+  if (length(x) != n) x <- rep_len(x, n)
+  if (length(from) == 1L && length(to) == 1L) {
+    out <- ud_convert_doubles(x, from, to)
+  } else {
+    from <- rep_len(from, n)
+    to <- rep_len(to, n)
+    out <- numeric(n)
+    for (i in ud_pairs(from, to))
+      out[i] <- ud_convert_doubles(x[i], from[[i[1L]]], to[[i[1L]]])
+  }
+  names(out) <- nm # as mapply() names its result
+  out
+}
+
+# Whether the arguments recycle to a common length without mapply()'s
+# zero-length and not-a-multiple cases, which are left to mapply() itself.
+ud_recycles <- function(...) {
+  len <- lengths(list(...))
+  all(len > 0L) && all(max(len) %% len == 0L)
+}
+
+# Indices of each distinct (from, to) pair, in order of first appearance.
+ud_pairs <- function(from, to) {
+  uf <- unique(from)
+  pair <- match(from, uf) + length(uf) * (match(to, unique(to)) - 1) # double: no overflow
+  split(seq_along(pair), match(pair, unique(pair)))
 }
 
 ud_char <- function(x) {

tests/testthat/test_mixed.R

@@ -93,3 +93,29 @@ test_that("as.data.frame.mixed_units works", {
 
   expect_equal(df1, df2)
 })
+
+test_that("mixed_units() matches units made one by one", {
+  cases <- list(list(c(1, 2, 3, 4), c("m/s", "km/h", "mg/L", "g")),
+                list(c(a = 1, b = 2, c = 3), c("m", "m", "km")),
+                list(1:6, c("100 m", "2 km/h", "1", "%", "degC", "100 m")),
+                list(5, c("m", "ft", "m")),
+                list(c(1, NA, 3), "kg"))
+  for (a in cases)
+    expect_identical(unclass(mixed_units(a[[1]], a[[2]])),
+                     mapply(set_units, a[[1]], a[[2]], mode = "standard", SIMPLIFY = FALSE))
+})
+
+test_that("set_units() converts mixed units in order", {
+  x <- c(1, 1000, 2, 1, 3000)
+  from <- c("m", "mm", "m", "km", "mm")
+  s <- set_units(mixed_units(x, from), "m")
+  expect_equal(as.numeric(s), c(1, 1, 2, 1000, 3))
+  expect_identical(as.character(units(s)), rep("m", 5))
+
+  set.seed(1)
+  x <- rnorm(1000)
+  from <- sample(c("m", "mm", "km", "cm", "in", "ft"), 1000, replace = TRUE)
+  s <- set_units(mixed_units(x, from), "km")
+  expect_identical(as.numeric(s), ud_convert(x, from, "km"))
+  expect_identical(as.character(units(s)), rep("km", 1000))
+})

tests/testthat/test_udunits.R

@@ -50,3 +50,58 @@ test_that("units longer than 255 bytes are formatted in full", {
     remove_unit(syms)
   }
 })
+
+# element by element, as ud_convert() and ud_are_convertible() used to convert
+convert_each <- function(x, from, to)
+  mapply(units:::ud_convert_doubles, x, units:::ud_char(from), units:::ud_char(to))
+convertible_each <- function(from, to)
+  mapply(units:::ud_convertible, units:::ud_char(from), units:::ud_char(to),
+         USE.NAMES = FALSE)
+
+test_that("ud_convert() converts mixed units in order", {
+  x <- c(1, 1000, 2, 1, 3000)
+  from <- c("m", "mm", "m", "km", "mm")
+  expect_equal(ud_convert(x, from, "m"), c(1, 1, 2, 1000, 3))
+  expect_identical(ud_convert(x, from, "m"), convert_each(x, from, "m"))
+  expect_identical(ud_convert(c(32, 212, 0), "degF", c("degC", "degC", "K")),
+                   convert_each(c(32, 212, 0), "degF", c("degC", "degC", "K")))
+})
+
+test_that("ud_convert() and ud_are_convertible() match element by element results", {
+  xs <- list(1:5, c(a = 1, b = 2), c(1, NA, NaN, Inf, -Inf, 0), 5, matrix(1:4, 2),
+             TRUE, c(x = 3L))
+  pairs <- list(list("m", "km"), list(c("m", "mm", "km", "cm"), "m"),
+                list("degF", c("degC", "K")), list(c("m", "ft"), c("in", "mm")),
+                list(c("m/s", "km/h", "m/s"), "km/h"),
+                list(c("degC", "K", "degF", "degC"), "K"),
+                list(units(set_units(1, m/s)), "km/h"))
+  for (x in xs) for (p in pairs) # lengths that do not recycle evenly warn in both
+    expect_identical(suppressWarnings(ud_convert(x, p[[1]], p[[2]])),
+                     suppressWarnings(convert_each(x, p[[1]], p[[2]])))
+
+  families <- list(c("m", "mm", "km", "cm", "in", "ft"), c("degC", "degF", "K"),
+                   c("s", "min", "h", "d"))
+  set.seed(1)
+  for (k in 1:50) {
+    n <- sample(1:30, 1)
+    f <- families[[sample(length(families), 1)]]
+    from <- sample(f, sample(c(1, n), 1), replace = TRUE)
+    to <- sample(f, sample(c(1, n), 1), replace = TRUE)
+    x <- round(rnorm(n, 100, 50), 2)
+    expect_identical(ud_convert(x, from, to), convert_each(x, from, to))
+    from <- sample(c(unlist(families), "foo"), n, replace = TRUE)
+    expect_identical(ud_are_convertible(from, to), convertible_each(from, to))
+  }
+})
+
+test_that("ud_convert() keeps mapply()'s recycling, names and edge cases", {
+  expect_warning(res <- ud_convert(1:3, c("m", "mm"), "km"), "not a multiple")
+  expect_equal(res, c(1e-3, 2e-6, 3e-3))
+  expect_identical(names(ud_convert(c(a = 1, b = 2), c("m", "mm", "km", "cm"), "m")),
+                   c("a", "b", NA, NA))
+  expect_identical(ud_convert(numeric(0), "m", "km"), numeric(0))
+  expect_identical(ud_convert(1, character(0), "km"), list())
+  expect_identical(ud_are_convertible(character(0), character(0)), list())
+  expect_identical(ud_convert(list(1, 2), "m", "km"), c(0.001, 0.002))
+  expect_error(ud_convert(c(1, 2), c("m", "s"), "kg"), "Units not convertible")
+})