Moved from matchability to summary.ism, etc

Various changes related to comments on #5

NAMESPACE

@@ -1,7 +1,10 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(print,summary.DenseMatrix)
+S3method(print,summary.InfinitySparseMatrix)
+S3method(summary,DenseMatrix)
+S3method(summary,InfinitySparseMatrix)
 export(SparseMMFromFactor)
-export(matchability)
 export(mlm)
 import(SparseM)
 import(methods)

R/InfinitySparseMatrix.R

@@ -29,3 +29,110 @@
 ##           }
 ##           )
 
+
+##' Given a distance matrix which has potentially been calipered,
+##' returns which observations are matchable and unmatchable
+##'
+##' @param object ISM, BISM or DenseMatrix
+##' @param ... Ignored.
+##' @return List of lists, $matchable$control, $matchable$treatment,
+##'   $unmatchable$control andd $unmatchable$treatment
+##' @export
+##' @name summary.ism
+summary.InfinitySparseMatrix <- function(object, ...) {
+  if (is(object, "BlockedInfinitySparseMatrix")) {
+    out <- lapply(levels(object@groups), function(x) summary(object[object@groups == x]))
+    class(out) <- "summary.BlockedInfinitySparseMatrix"
+    return(out)
+  }
+
+  out <- list()
+  d <- dim(object)
+
+  # Size of treatment and control groups
+  out$total$treatment <- d[1]
+  out$total$control <- d[2]
+
+  # Count of eligble and ineligible pairs.
+  num_elig <- num_eligible_matches(object)[[1]]
+  num_inelig <- prod(d) - num_elig
+  out$total$matchable <- num_elig
+  out$total$unmatchable <- num_inelig
+
+  finitedata <- is.finite(object@.Data)
+  matchabletreatment <- 1:d[1] %in% sort(unique(object@rows[finitedata]))
+  matchablecontrol   <- 1:d[2] %in% sort(unique(object@cols[finitedata]))
+  out$matchable$treatment <- object@rownames[matchabletreatment]
+  out$matchable$control <- object@colnames[matchablecontrol]
+  out$unmatchable$treatment <- object@rownames[!matchabletreatment]
+  out$unmatchable$control <- object@colnames[!matchablecontrol]
+
+  out$distances <- summary(object@.Data[finitedata])
+
+  #class(out) <- "summary.InfinitySparseMatrix"
+  out
+}
+
+##' @export
+##' @rdname summary.ism
+summary.DenseMatrix <- function(object, ...) {
+  out <- list()
+  d <- dim(object)
+
+  # Size of treatment and control groups
+  out$total$treatment <- d[1]
+  out$total$control <- d[2]
+
+  # Count of eligble and ineligible pairs.
+  num_elig <- num_eligible_matches(object)[[1]]
+  num_inelig <- prod(d) - num_elig
+  out$total$matchable <- num_elig
+  out$total$unmatchable <- num_inelig
+
+  matchabletreatment <- apply(object, 1, function(x) any(is.finite(x)))
+  matchablecontrol <- apply(object, 2, function(x) any(is.finite(x)))
+
+  out$matchable$treatment <- rownames(object)[matchabletreatment]
+  out$matchable$control <- colnames(object)[matchablecontrol]
+  out$unmatchable$treatment <- rownames(object)[!matchabletreatment]
+  out$unmatchable$control <- colnames(object)[!matchablecontrol]
+
+  out$distances <- summary(object)
+
+  class(out) <- "summary.DenseMatrix"
+  out
+}
+
+##' @export
+print.summary.InfinitySparseMatrix <- function(x, ...) {
+  ### NOT UPDATED
+  if (x$total$unmatchable == 0) {
+    cat(paste("All", sum(unlist(x$total)), "matches are eligible.\n"))
+  } else {
+    cat(paste("Out of", sum(unlist(x$total)),
+              "total potential eligible matches,", x$total$matchable,
+              "are eligible for matching and", x$total$unmatchable,
+              "matchings are prohibited.\n\n"))
+  }
+
+  if (x$total$unmatchable > 0) {
+    if (length(x$unmatchable$treatment) > 0) {
+      cat(paste("The following treatment group members are ineligible for any matches:\n"))
+      cat(paste(x$unmatchable$treatment, collapse=", "))
+      cat("\n\n")
+    }
+    if (length(x$unmatchable$control) > 0) {
+      cat(paste("The following control group members are ineligible for any matches:\n"))
+      cat(paste(x$unmatchable$control, collapse=", "))
+      cat("\n\n")
+    }
+  }
+}
+
+##' @export
+print.summary.DenseMatrix <- function(x, ...) {
+  ### NOT UPDATED
+  cat(paste0("All ", x$total, " potential matches (", x$dim[1],
+             " treatment members and ", x$dim[2],
+             " control members) are eligible.\n"))
+}

tests/testthat/test.InfinitySparseMatrix.R

@@ -1,4 +1,4 @@
-context("ISM indexing")
+context("InfintySparseMatrix tests")
 
 ## test_that("ISM indexing", {
 
@@ -17,3 +17,85 @@ context("ISM indexing")
 ##   # expect_equal(m, m[])
 ##   # expect_equal(m, m[,])
 ## })
+
+
+test_that("summary for ISM", {
+  set.seed(1)
+  d <- data.frame(z=rep(0:1, each=5),
+                  x=rnorm(10))
+  rownames(d) <- letters[1:10]
+  m1 <- match_on(z ~ x, data=d)
+  sm1 <- summary(m1)
+
+  m2 <- m1 + caliper(m1, width=1)
+  sm2 <- summary(m2)
+  expect_true(is(sm2, "summary.InfinitySparseMatrix"))
+  expect_true(is.list(sm2))
+  expect_equal(sm2$total$treatment, 5)
+  expect_equal(sm2$total$control, 5)
+  expect_equal(sm2$total$matchable, 12)
+  expect_equal(sm2$total$unmatchable, 25-12)
+  expect_equal(length(sm2$matchable$treatment), 5)
+  expect_equal(length(sm2$matchable$control), 4)
+  expect_equal(sm2$unmatchable$treatment, character(0))
+  expect_equal(sm2$unmatchable$control, "d")
+  expect_true(is(sm2$distances, "summaryDefault"))
+
+  m3 <- m2
+  m3[1:2] <- Inf
+  sm3 <- summary(m3)
+  ##  expect_equal(sm3$total$matchable, 10)
+  ##  expect_equal(sm3$total$unmatchable, 25-10)
+  ##  A bug in num_eligible_matches in optmatch was fixed. Until that
+  ##  gets pushed up so that the newest version of optmatch is
+  ##  installed, the above two tests will fail on `make test`. They
+  ##  should work interactively (with `make load`).
+  expect_equal(length(sm3$matchable$treatment), 4)
+  expect_equal(length(sm3$matchable$control), 4)
+  expect_equal(sm3$unmatchable$treatment, "f")
+  expect_equal(sm3$unmatchable$control, "d")
+  expect_true(is(sm3$distances, "summaryDefault"))
+  expect_true(all(is.finite(sm3$distances)))
+
+  m4 <- m1 + caliper(m1, width=.0001)
+  sm4 <- summary(m4)
+  expect_equal(sm4$matchable$treatment, character(0))
+  expect_equal(sm4$matchable$control, character(0))
+
+
+})
+
+test_that("summary for DenseMatrix", {
+  set.seed(1)
+  d <- data.frame(z=rep(0:1, each=5),
+                  x=rnorm(10))
+  rownames(d) <- letters[1:10]
+  m1 <- match_on(z ~ x, data=d)
+  sm1 <- summary(m1)
+  expect_true(is(sm1, "summary.DenseMatrix"))
+  expect_true(is.list(sm1))
+  expect_equal(sm1$total$treatment, 5)
+  expect_equal(sm1$total$control, 5)
+  expect_equal(sm1$total$matchable, 25)
+  expect_equal(sm1$total$unmatchable, 0)
+  expect_equal(length(sm1$matchable$treatment), 5)
+  expect_equal(length(sm1$matchable$control), 5)
+  expect_equal(sm1$unmatchable$treatment, character(0))
+  expect_equal(sm1$unmatchable$control, character(0))
+  expect_true(is(sm1$distances, "summaryDefault"))
+
+  m2 <- m1
+  m2[1,] <- Inf
+  sm2 <- summary(m2)
+  expect_true(is(sm2, "summary.DenseMatrix"))
+  expect_true(is.list(sm2))
+  expect_equal(sm2$total$treatment, 5)
+  expect_equal(sm2$total$control, 5)
+  expect_equal(sm2$total$matchable, 20)
+  expect_equal(sm2$total$unmatchable, 25-20)
+  expect_equal(length(sm2$matchable$treatment), 4)
+  expect_equal(length(sm2$matchable$control), 5)
+  expect_equal(sm2$unmatchable$treatment, "f")
+  expect_equal(sm2$unmatchable$control, character(0))
+  expect_true(is(sm2$distances, "summaryDefault"))
+})