From 6bed97d0958a25a7148714591551729400dccf46 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 23 Oct 2026 13:21:38 +0200 Subject: [PATCH 1/4] last couple of fixes --- R/corDS.R | 6 +++--- R/covDS.R | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/R/corDS.R b/R/corDS.R index 9653900a..aba34ece 100644 --- a/R/corDS.R +++ b/R/corDS.R @@ -30,17 +30,17 @@ corDS <- function(x=NULL, y=NULL){ ############################################################# x.val <- .loadServersideObject(x) - .checkClass(obj = x.val, obj_name = x, permitted_classes = c("numeric", "integer", "matrix", "data.frame")) + .checkClass(obj = x.val, obj_name = x, permitted_classes = c("numeric", "integer", "factor", "matrix", "data.frame")) if (!is.null(y) && !any(class(x.val) %in% c("matrix", "data.frame"))){ y.val <- .loadServersideObject(y) - .checkClass(obj = y.val, obj_name = y, permitted_classes = c("numeric", "integer", "matrix", "data.frame")) + .checkClass(obj = y.val, obj_name = y, permitted_classes = c("numeric", "integer", "factor", "matrix", "data.frame")) } else{ y.val <- NULL } - if (is.null(y.val) && any(class(x.val) %in% c("numeric", "integer"))) { + if (is.null(y.val) && any(class(x.val) %in% c("numeric", "integer", "factor"))) { stop("If x is a numeric vector, y must also be a numeric vector.", call. = FALSE) } diff --git a/R/covDS.R b/R/covDS.R index 84f8f66b..d31858dd 100644 --- a/R/covDS.R +++ b/R/covDS.R @@ -39,17 +39,17 @@ covDS <- function(x=NULL, y=NULL, use=NULL){ ############################################################# x.val <- .loadServersideObject(x) - .checkClass(obj = x.val, obj_name = x, permitted_classes = c("numeric", "integer", "matrix", "data.frame")) + .checkClass(obj = x.val, obj_name = x, permitted_classes = c("numeric", "integer", "factor", "matrix", "data.frame")) if (!is.null(y) && !any(class(x.val) %in% c("matrix", "data.frame"))){ y.val <- .loadServersideObject(y) - .checkClass(obj = y.val, obj_name = y, permitted_classes = c("numeric", "integer", "matrix", "data.frame")) + .checkClass(obj = y.val, obj_name = y, permitted_classes = c("numeric", "integer", "factor", "matrix", "data.frame")) } else{ y.val <- NULL } - if (is.null(y.val) && any(class(x.val) %in% c("numeric", "integer"))) { + if (is.null(y.val) && any(class(x.val) %in% c("numeric", "integer", "factor"))) { stop("If x is a numeric vector, y must also be a numeric vector.", call. = FALSE) } From d12edd16fa6867bc3f95aff8daf5dcfd3533c034 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 23 Oct 2026 13:21:48 +0200 Subject: [PATCH 2/4] remove asList from aggregate methods --- inst/DATASHIELD | 1 - 1 file changed, 1 deletion(-) diff --git a/inst/DATASHIELD b/inst/DATASHIELD index 7835a403..3e08f68e 100644 --- a/inst/DATASHIELD +++ b/inst/DATASHIELD @@ -1,6 +1,5 @@ AggregateMethods: asFactorDS1, - asListDS, aucDS, boxPlotGGDS, checkNegValueDS, From 411a74fb97749ad891a40b19e0ae66f1777fbb47 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 23 Oct 2026 13:21:54 +0200 Subject: [PATCH 3/4] update tests --- tests/testthat/test-smk-corDS.R | 10 ++++++++++ tests/testthat/test-smk-covDS.R | 10 ++++++++++ 2 files changed, 20 insertions(+) diff --git a/tests/testthat/test-smk-corDS.R b/tests/testthat/test-smk-corDS.R index ba51e096..059be9ad 100644 --- a/tests/testthat/test-smk-corDS.R +++ b/tests/testthat/test-smk-corDS.R @@ -764,6 +764,16 @@ test_that("corDS gives the same result for a matrix as for a data.frame", { expect_equal(res.matrix[names(res.matrix) != "class"], res.df[names(res.df) != "class"]) }) +test_that("corDS accepts a factor x, correlating on its level codes", { + fvar <- factor(c("m", "f", "m", "f", "m", "f", "m", "f", "m", "f")) + yvar <- c(1.0, 5.0, 2.0, 6.0, 3.0, 7.0, 2.0, 8.0, 1.0, 9.0) + + res <- corDS("fvar", "yvar") + + expect_equal(res$class, "factor") + expect_equal(res$sums[1, 2], sum(as.integer(fvar))) +}) + # # Done # diff --git a/tests/testthat/test-smk-covDS.R b/tests/testthat/test-smk-covDS.R index d44f98bb..9bb4e517 100644 --- a/tests/testthat/test-smk-covDS.R +++ b/tests/testthat/test-smk-covDS.R @@ -278,6 +278,16 @@ test_that("covDS gives the same result for a matrix as for a data.frame", { expect_equal(res.matrix[names(res.matrix) != "class"], res.df[names(res.df) != "class"]) }) +test_that("covDS accepts a factor x, using its level codes", { + fvar <- factor(c("m", "f", "m", "f", "m", "f", "m", "f", "m", "f")) + yvar <- c(1.0, 5.0, 2.0, 6.0, 3.0, 7.0, 2.0, 8.0, 1.0, 9.0) + + res <- covDS("fvar", "yvar", "pairwise.complete") + + expect_equal(res$class, "factor") + expect_equal(res$sums[1, 2], sum(as.integer(fvar))) +}) + # # Done # From d71fcf61787ce26ba4d410806861edcf55349b8c Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 29 Oct 2026 11:31:33 +0100 Subject: [PATCH 4/4] update and pin lme4 version and fix tests as estimates slightly changed --- DESCRIPTION | 2 +- R/glmSLMADS.assign.R | 4 ++-- tests/testthat/test-smk-glmerSLMADS.assign.R | 4 ++-- tests/testthat/test-smk-glmerSLMADS2.R | 2 +- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index f3411680..81cc2e1c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -63,7 +63,7 @@ Depends: Imports: RANN, stringr, - lme4, + lme4 (>= 2.1-0), dplyr, tibble, purrr, diff --git a/R/glmSLMADS.assign.R b/R/glmSLMADS.assign.R index 68fe6929..3448aed3 100644 --- a/R/glmSLMADS.assign.R +++ b/R/glmSLMADS.assign.R @@ -27,10 +27,10 @@ glmSLMADS.assign <- function(formula, family, offsetName, weightsName, dataName) # Correctly name offset, weights and data objects in function call # (to allow glmPredict to work correctly later) - calltext <- paste0("mg<-glm(formula,family=",family,",offset=", + calltext <- paste0("glm(formula,family=",family,",offset=", offsetName,",weights=",weightsName,",data=", dataName,",x=TRUE)") - eval(parse(text=calltext)) + mg <- eval(parse(text=calltext), envir = list(formula = formula), enclos = parent.frame()) # update the call object to include the actual formula mg$call$formula <- formula diff --git a/tests/testthat/test-smk-glmerSLMADS.assign.R b/tests/testthat/test-smk-glmerSLMADS.assign.R index 9277ffad..e675bb9d 100644 --- a/tests/testthat/test-smk-glmerSLMADS.assign.R +++ b/tests/testthat/test-smk-glmerSLMADS.assign.R @@ -29,10 +29,10 @@ test_that("simple glmerSLMADS.assign, binomial random intercept", { expect_true(methods::is(res, "glmerMod")) expect_equal(nobs(res), 50) - expect_equal(as.numeric(lme4::fixef(res)), c(-1.4299523, 0.2248647), tolerance = 1e-5) + expect_equal(as.numeric(lme4::fixef(res)), c(-1.4340652, 0.2255225), tolerance = 1e-5) vc <- as.data.frame(lme4::VarCorr(res)) - expect_equal(vc$vcov, 2.7451347, tolerance = 1e-5) + expect_equal(vc$vcov, 2.7493590, tolerance = 1e-5) }) test_that("glmerSLMADS.assign throws error when dataName does not exist", { diff --git a/tests/testthat/test-smk-glmerSLMADS2.R b/tests/testthat/test-smk-glmerSLMADS2.R index 94821cea..adb47e47 100644 --- a/tests/testthat/test-smk-glmerSLMADS2.R +++ b/tests/testthat/test-smk-glmerSLMADS2.R @@ -35,7 +35,7 @@ test_that("simple glmerSLMADS2, binomial random intercept", { expect_equal(res$Nmissing, 0) expect_equal(dim(res$coefficients), c(2, 4)) expect_equal(res$coefficients[, "Estimate"], - c(`(Intercept)` = -1.4299523, x = 0.2248647), tolerance = 1e-5) + c(`(Intercept)` = -1.4340652, x = 0.2255225), tolerance = 1e-5) expect_equal(res$family, "binomial") })