speeding up the scoreCaliper function by avoiding recreating vectors over and over

Author: markmfredrickson

R/match_on.R

@@ -763,9 +763,6 @@ scoreCaliper <- function(x, z, caliper) {
   # there may be a speed increase in pulling out the guts of that function and calling them directly
   control <- sort(control)
 
-  treatedids <- c()
-  controlids <- c()
-
   # NB: for reasons unknown, you must add the double.eps in the function
   # call, saving it in a variable (e.g. width.eps <- width +
   # .Machine$double.eps) will not work.
@@ -775,15 +772,39 @@ scoreCaliper <- function(x, z, caliper) {
   starts <- length(control) - findInterval(-(treated - caliper -
                                              .Machine$double.eps), rev(-control))
 
+  edges <- pmax(0, (stops - starts))
+  n <- sum(edges)
+
+  treatedids <- rep.int(1:k, times = edges)
+  controlids <- integer(n)
+
+  idx <- 1
   for (i in 1:k) {
-    if (starts[i] < length(control) && stops[i] > 0 && starts[i] < stops[i]) {
-      tmp <- seq(starts[i] + 1, stops[i])
-      controlids <- c(controlids, tmp)
-      treatedids <- c(treatedids, rep(i, length(tmp)))
+    if (starts[i] < length(control) && stops[i] > 0 && edges[i] > 0) {
+      tmp <- seq.int(starts[i] + 1, stops[i])
+      j <- length(tmp)
+      controlids[idx:(idx + j - 1)] <- tmp
+      idx <- idx + j
     }
   }
 
-  makeInfinitySparseMatrix(rep(0, length(treatedids)), controlids, treatedids, names(control), names(treated))
+  v <- integer(n)
+
+  # I noticed that if a control was not reachable by any treated unit it would
+  # not appear in the resulting matrix, so we set names explicitly if they don't exist.
+  if (is.null(names(control))) {
+    nmsc <- as.character(1:length(control))
+  } else {
+    nmsc <- names(control)
+  }
+
+  if (is.null(names(treated))) {
+    nmst <- as.character(1:k)
+  } else {
+    nmst <- names(treated)
+  }
+
+  makeInfinitySparseMatrix(v, controlids, treatedids, nmsc, nmst)
 }
 
 #' @details \bold{First argument (\code{x}): \code{matrix} or \code{InfinitySparseMatrix}.} These just return their

tests/testthat/test.match_on.R

@@ -359,6 +359,47 @@ test_that("Numeric: simple differences of scores", {
   expect_error(match_on(scores2, z = z2, caliper = c(1,2)), "scalar")
 })
 
+test_that("Score caliper edge cases", {
+  set.seed(203003)
+  n1 <- 500
+  n0 <- 300
+  n <- n1 + n0
+  x <- runif(n)
+  z <- c(rep(1, n1), rep(0, n0))
+
+  cal <- 0.2
+
+  sc <- scoreCaliper(x, z, cal)
+
+  # this should limit the number of edges
+  expect_true(length(sc) < 500 * 300)
+
+  # but it should look like a 500 by 300 matrix
+  expect_equal(dim(sc), c(n1, n0))
+
+  scm <- as.matrix(sc) # make it dense for testing
+
+  ## everyone should get matched
+  scmr <- rowSums(is.finite(scm))
+  scmc <- colSums(is.finite(scm))
+
+  expect_true(all(scmr > 0))
+  expect_true(all(scmc > 0))
+
+  # now introduce some extreme treated and control units
+  x2 <- x
+  x2[1] <- min(x) - 2 * cal
+  x2[n] <- max(x) + 2 * cal
+
+  sc2 <- scoreCaliper(x2, z, cal)
+  expect_true(length(sc2) < length(sc))
+  expect_equal(dim(sc2), c(n1, n0))
+
+  scm2 <- as.matrix(sc2) # make it dense for testing
+  expect_equivalent(rowSums(is.finite(scm2))[1], 0)
+  expect_equivalent(colSums(is.finite(scm2))[n0], 0)
+})
+
 test_that("Numeric, issues with vector names", {
   # #189