Refactor/final fixes

R/ds.mdPattern.R

@@ -163,15 +163,17 @@ ds.mdPattern <- function(x = NULL, type = 'split', datasources = NULL, classCons
       stop("Cannot pool patterns: studies have different numbers of variables", call.=FALSE)
     }
 
+    # md.pattern orders variable columns by missingness, which differs across studies,
+    # so align them by name to study 1's order (the last, unnamed column stays last)
     var_names <- colnames(patterns_list[[1]])
-    if(length(patterns_list) > 1){
-      for(i in 2:length(patterns_list)){
-        if(!identical(colnames(patterns_list[[i]]), var_names)){
-          warning("Variable names differ across studies. Pooling by position.")
-          break
-        }
+    var_cols <- var_names[-length(var_names)]
+    patterns_list <- lapply(patterns_list, function(pattern){
+      study_vars <- colnames(pattern)[-ncol(pattern)]
+      if(!setequal(study_vars, var_cols)){
+        stop("Cannot pool patterns: studies have different variables", call.=FALSE)
       }
-    }
+      pattern[, c(match(var_cols, study_vars), ncol(pattern)), drop = FALSE]
+    })
 
     # Pool the patterns
     pooled_pattern <- .poolMdPatterns(patterns_list, study_names)

tests/testthat/test-smk-ds.cor.R

@@ -114,7 +114,7 @@ test_that("fails if the object is the wrong type", {
 
     res.errors <- DSI::datashield.errors()
     for (study.errors in res.errors) {
-        expect_match(study.errors, "The server-side object must be of type numeric, integer, matrix or data.frame. 'not_a_numeric' is type character.", fixed = TRUE)
+        expect_match(study.errors, "The server-side object must be of type numeric, integer, factor, matrix or data.frame. 'not_a_numeric' is type character.", fixed = TRUE)
     }
 
     ds.rm("not_a_numeric")
@@ -143,8 +143,14 @@ test_that("ds.cor ignores y with a warning when x is a data.frame", {
     expect_equal(res.xy, res.x)
 })
 
+test_that("cor accepts a factor variable", {
+    ds.asFactorSimple(input.var.name = "D$female", newobj.name = "female.factor")
+
+    expect_no_error(ds.cor(x = "female.factor", y = "D$survtime", type = "split"))
+})
+
 test_that("shutdown", {
-    ds_expect_variables(c("D"))
+    ds_expect_variables(c("D", "female.factor"))
 })
 
 disconnect.studies.dataset.survival()

tests/testthat/test-smk-ds.cov.R

@@ -87,7 +87,7 @@ test_that("fails if the object is the wrong type", {
 
     res.errors <- DSI::datashield.errors()
     for (study.errors in res.errors) {
-        expect_match(study.errors, "The server-side object must be of type numeric, integer, matrix or data.frame. 'not_a_numeric' is type character.", fixed = TRUE)
+        expect_match(study.errors, "The server-side object must be of type numeric, integer, factor, matrix or data.frame. 'not_a_numeric' is type character.", fixed = TRUE)
     }
 
     ds.rm("not_a_numeric")
@@ -116,8 +116,14 @@ test_that("error, x numeric vector requires y", {
     expect_match(res.errors[[1]], "If x is a numeric vector, y must also be a numeric vector")
 })
 
+test_that("cov accepts a factor variable", {
+    ds.asFactorSimple(input.var.name = "D$female", newobj.name = "female.factor")
+
+    expect_no_error(ds.cov(x = "female.factor", y = "D$survtime", type = "split"))
+})
+
 test_that("shutdown", {
-    ds_expect_variables(c("D"))
+    ds_expect_variables(c("D", "female.factor"))
 })
 
 disconnect.studies.dataset.survival()

tests/testthat/test-smk-ds.mdPattern.R

@@ -37,6 +37,29 @@ test_that("simple mdPattern, combine", {
     expect_true(is.matrix(res$pattern))
 })
 
+test_that("combine pools pattern counts by variable name, not column position", {
+    res.split <- ds.mdPattern(x = "D", type = "split")
+    res.combine <- suppressWarnings(ds.mdPattern(x = "D", type = "combine"))
+
+    # md.pattern rows are named by their count; the last row is a summary and
+    # suppressed rows have a non-numeric name, so both are dropped
+    count.by.pattern <- function(pattern){
+        var.names <- sort(colnames(pattern)[-ncol(pattern)])
+        rows <- pattern[-nrow(pattern), var.names, drop = FALSE]
+        counts <- suppressWarnings(as.numeric(rownames(rows)))
+        keep <- !is.na(counts)
+        keys <- apply(rows[keep, , drop = FALSE], 1, paste, collapse = "")
+        stats::setNames(counts[keep], keys)
+    }
+
+    per.study <- lapply(res.split, function(study.res) count.by.pattern(study.res$pattern))
+    expected <- tapply(unlist(per.study, use.names = FALSE), unlist(lapply(per.study, names)), sum)
+    actual <- tapply(count.by.pattern(res.combine$pattern), names(count.by.pattern(res.combine$pattern)), sum)
+
+    expect_setequal(names(actual), names(expected))
+    expect_equal(as.vector(actual[names(expected)]), as.vector(expected))
+})
+
 test_that("fails if the object does not exist", {
     expect_error(
         ds.mdPattern(x = "nonexistent_object"),