Subset bism

DESCRIPTION

@@ -1,5 +1,5 @@
 Package: optmatch
-Version: 0.10.8.9001
+Version: 0.10.8.9002
 Title: Functions for Optimal Matching
 Description: Distance based bipartite matching using minimum cost flow, oriented
     to matching of treatment and control groups in observational studies ('Hansen'

R/InfinitySparseMatrix.R

@@ -1103,3 +1103,34 @@ as.list.DenseMatrix <- function(x, ...) {
            })
   return(x)
 }
+
+##' This matches the syntax and semantics of
+##' subset for matrices.
+##'
+##' @title Subsetting for BlockedInfinitySparseMatrices
+##' @param x BlockedInfinitySparseMatrix to be subset or bound.
+##' @param subset Logical expression indicating rows to keep.
+##' @param select Logical expression indicating columns to keep.
+##' @param ... Other arguments are ignored.
+##' @return If groups has names, a BlockedInfinitySparseMatrix with only
+##'         the selected elements, otherwise an InfinitySparsematrix with
+##'         only the selected elements
+##' @rdname bism.subset
+##' @export
+subset.BlockedInfinitySparseMatrix <- function(x, subset, select, ...) {
+    subIsm <- callGeneric(as(x, "InfinitySparseMatrix"), subset, select)
+    oldNames <- names(x@groups)
+    if (!is.null(oldNames)) {   # we can use the groups names to subset groups
+        subNames <- oldNames[which((oldNames %in% subIsm@rownames) |
+                                   (oldNames %in% subIsm@colnames))]
+        subGroups <- x@groups[subNames]
+        subObj <- new("BlockedInfinitySparseMatrix",
+                      subIsm, groups = subGroups)
+    } else {
+        # since groups doesn't have names, we can't meaningfully subset it
+        # groups is meaningless for the subsetted matrix
+        # demote object to ISM
+        subObj <- subIsm
+    }
+    return(subObj)
+}

R/summary.ism.R

@@ -102,7 +102,7 @@ summary.BlockedInfinitySparseMatrix <- function(object, ...,
   out <- lapply(levels(object@groups),
                 function(x) {
                   thisgroup <- names(object@groups[object@groups == x])
-                  ism <- subset(object,
+                  ism <- subset.InfinitySparseMatrix(object,
                                 subset=object@rownames %in% thisgroup,
                                 select=object@colnames %in% thisgroup)
                   s <- summary(ism, ..., distanceSummary=distanceSummary)

tests/testthat/test.InfinitySparseMatrix.R

@@ -264,7 +264,7 @@ test_that("#190: agreement in dimension names", {
 
 })
 
-test_that("Subsetting", {
+test_that("ISM Subsetting", {
   m <- matrix(c(1,Inf, 2, 3), nrow = 2, ncol = 2)
   rownames(m) <- c("A", "B")
   colnames(m) <- c("C", "D")
@@ -400,6 +400,23 @@ test_that("BlockedISM addition", {
     "BlockedInfinitySparseMatrix")
 })
 
+test_that("BlockedISM Subsetting", {
+  Z <- rep(c(0,1), 8)
+  B <- rep(1:4, each = 4)
+
+  res.b <- exactMatch(Z ~ B)
+  sub.b <- subset(res.b,
+                   c(TRUE, FALSE, TRUE, FALSE, TRUE, FALSE, TRUE, FALSE),
+                   c(TRUE, FALSE, TRUE, FALSE, TRUE, FALSE, TRUE, FALSE))
+
+  expect_is(sub.b, "BlockedInfinitySparseMatrix")
+  expect_false(is.null(sub.b@groups))
+  expect_equal(names(sub.b@groups),
+               c("1", "2", "5", "6", "9", "10", "13", "14"))
+  expect_equal(rownames(sub.b), c("2", "6", "10", "14"))
+  expect_equal(colnames(sub.b), c("1", "5", "9", "13"))
+})
+
 test_that("Get subproblem size of each block", {
   Z <- rep(c(0,1), 8)
   B1 <- c(rep('a',3),rep('b', 3), rep('c', 6), rep('d', 4))