diff --git a/R/ds.mdPattern.R b/R/ds.mdPattern.R index 98fa8ec1..0c083e94 100644 --- a/R/ds.mdPattern.R +++ b/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) diff --git a/tests/testthat/test-smk-ds.cor.R b/tests/testthat/test-smk-ds.cor.R index 44e97be2..aaa6eaf7 100644 --- a/tests/testthat/test-smk-ds.cor.R +++ b/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() diff --git a/tests/testthat/test-smk-ds.cov.R b/tests/testthat/test-smk-ds.cov.R index 8c2c0689..f9ba6569 100644 --- a/tests/testthat/test-smk-ds.cov.R +++ b/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() diff --git a/tests/testthat/test-smk-ds.mdPattern.R b/tests/testthat/test-smk-ds.mdPattern.R index b2367f87..077012c3 100644 --- a/tests/testthat/test-smk-ds.mdPattern.R +++ b/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"),