From 07b817e4b9c10f7afc4f9dbc9476f8115fdd3ef6 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Wed, 15 Apr 2026 13:13:31 +0200 Subject: [PATCH 01/30] refactor: batch-5 matrix server functions --- R/matrixDS.R | 3 +- R/matrixDiagDS.R | 3 +- R/matrixDimnamesDS.R | 26 ++-------- R/matrixInvertDS.R | 36 ++------------ R/matrixMultDS.R | 55 ++------------------- R/matrixTransposeDS.R | 35 ++----------- man/levelsDS.Rd | 5 +- man/matrixDS.Rd | 2 + man/matrixDiagDS.Rd | 2 + man/matrixDimnamesDS.Rd | 2 + man/matrixInvertDS.Rd | 2 + man/matrixMultDS.Rd | 2 + man/matrixTransposeDS.Rd | 2 + tests/testthat/test-smk-matrixDS.R | 39 +++++++++++++++ tests/testthat/test-smk-matrixDiagDS.R | 36 ++++++++++++++ tests/testthat/test-smk-matrixDimnamesDS.R | 44 +++++++++++++++++ tests/testthat/test-smk-matrixInvertDS.R | 42 ++++++++++++++++ tests/testthat/test-smk-matrixMultDS.R | 44 +++++++++++++++++ tests/testthat/test-smk-matrixTransposeDS.R | 42 ++++++++++++++++ 19 files changed, 280 insertions(+), 142 deletions(-) create mode 100644 tests/testthat/test-smk-matrixDS.R create mode 100644 tests/testthat/test-smk-matrixDiagDS.R create mode 100644 tests/testthat/test-smk-matrixDimnamesDS.R create mode 100644 tests/testthat/test-smk-matrixInvertDS.R create mode 100644 tests/testthat/test-smk-matrixMultDS.R create mode 100644 tests/testthat/test-smk-matrixTransposeDS.R diff --git a/R/matrixDS.R b/R/matrixDS.R index bcdb6908..18951fbc 100644 --- a/R/matrixDS.R +++ b/R/matrixDS.R @@ -22,6 +22,7 @@ #' @return Output is the matrix A written #' to the serverside. For more details see help for ds.matrix #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' matrixDS <- function(mdata.transmit, from, nrows.transmit, ncols.transmit, byrow, dimnames){ @@ -92,7 +93,7 @@ if(!is.null(dimnames)) if(from=="serverside.vector"||from=="serverside.scalar") { -mdata<-eval(parse(text=mdata.transmit), envir = parent.frame()) +mdata <- .loadServersideObject(mdata.transmit) } diff --git a/R/matrixDiagDS.R b/R/matrixDiagDS.R index c5b613bd..449538ba 100644 --- a/R/matrixDiagDS.R +++ b/R/matrixDiagDS.R @@ -17,6 +17,7 @@ #' (or default name diag_) which is written to the serverside. #' For more details see help for \code{ds.matrixDiag}. #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export matrixDiagDS <- function(x1.transmit,aim,nrows.transmit){ ######################################################################### @@ -65,7 +66,7 @@ if(aim=="serverside.vector.2.matrix"||aim=="serverside.scalar.2.matrix"||aim=="s { #x1 is name of the serverside vector, scalar or matrix -x1<-eval(parse(text=x1.transmit), envir = parent.frame()) +x1 <- .loadServersideObject(x1.transmit) #coerce to matrix if x1 is a data.frame if(is.data.frame(x1)) diff --git a/R/matrixDimnamesDS.R b/R/matrixDimnamesDS.R index 97653f24..36a2f566 100644 --- a/R/matrixDimnamesDS.R +++ b/R/matrixDimnamesDS.R @@ -18,6 +18,7 @@ #' (or default name diag_) with specified dimnames (row and column #' names) which is written to the serverside. #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export matrixDimnamesDS <- function(M1.name=NULL,dimnames){ @@ -28,23 +29,11 @@ thr<-dsBase::listDisclosureSettingsDS() # #nfilter.glm<-as.numeric(thr$nfilter.glm) # #nfilter.subset<-as.numeric(thr$nfilter.subset) # nfilter.string<-as.numeric(thr$nfilter.string) # -nfilter.stringShort<-as.numeric(thr$nfilter.stringShort) # +#nfilter.stringShort<-as.numeric(thr$nfilter.stringShort) # #nfilter.kNN<-as.numeric(thr$nfilter.kNN) # #datashield.privacyLevel<-as.numeric(thr$datashield.privacyLevel) # ######################################################################### -#Check length of M1.name not so long as to provide a risk of hidden code -length.M1.name<-length(unlist(strsplit(M1.name,''))) - -if(length.M1.name>nfilter.stringShort) - { - studysideMessage<- - paste0("FAILED: M1.name is too long it could hide concealed code, please shorten to <= nfilter.stringShort = ", - nfilter.stringShort," characters") - stop(studysideMessage, call. = FALSE) - } - - #Check length of dimnames string not so long as to provide a risk of hidden code #This could legitimately be quite long so allow 2*nfilter.string @@ -61,15 +50,8 @@ if(!is.null(dimnames)) } } -#EVAL M1 - -M1<-eval(parse(text=M1.name), envir = parent.frame()) - -if(!is.matrix(M1)&&!is.data.frame(M1)) - { - studysideMessage<-"FAILED: M1 must be of class matrix or data.frame, please respecify" - stop(studysideMessage, call. = FALSE) - } +M1 <- .loadServersideObject(M1.name) +.checkClass(obj = M1, obj_name = M1.name, permitted_classes = c("matrix", "data.frame")) #coerce to matrix if a data.frame if(is.data.frame(M1)) diff --git a/R/matrixInvertDS.R b/R/matrixInvertDS.R index 5ce2b2c0..b87cb948 100644 --- a/R/matrixInvertDS.R +++ b/R/matrixInvertDS.R @@ -8,43 +8,13 @@ #' @return Output is the matrix representing the inverse of A which is written #' to the serverside. For more details see help for ds.matrixInvert #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' matrixInvertDS <- function(M1.name=NULL){ -######################################################################### -# DataSHIELD MODULE: CAPTURE THE nfilter SETTINGS # -thr<-dsBase::listDisclosureSettingsDS() # -#nfilter.tab<-as.numeric(thr$nfilter.tab) # -#nfilter.glm<-as.numeric(thr$nfilter.glm) # -#nfilter.subset<-as.numeric(thr$nfilter.subset) # -#nfilter.string<-as.numeric(thr$nfilter.string) # -nfilter.stringShort<-as.numeric(thr$nfilter.stringShort) # -#nfilter.kNN<-as.numeric(thr$nfilter.kNN) # -#datashield.privacyLevel<-as.numeric(thr$datashield.privacyLevel) # -######################################################################### - -#Check length of M1.name not so long as to provide a risk of hidden code -length.M1.name<-length(unlist(strsplit(M1.name,''))) - -if(length.M1.name>nfilter.stringShort) - { - studysideMessage<- - paste0("FAILED: M1.name is too long it could hide concealed code, please shorten to <= nfilter.stringShort = ", - nfilter.stringShort," characters") - stop(studysideMessage, call. = FALSE) - } - -#EVAL M1 - - -M1<-eval(parse(text=M1.name), envir = parent.frame()) - -if(!is.matrix(M1)&&!is.data.frame(M1)) - { - studysideMessage<-"FAILED: M1 must be of class matrix or data.frame, please respecify" - stop(studysideMessage, call. = FALSE) - } +M1 <- .loadServersideObject(M1.name) +.checkClass(obj = M1, obj_name = M1.name, permitted_classes = c("matrix", "data.frame")) #coerce to matrix if a data.frame if(is.data.frame(M1)) diff --git a/R/matrixMultDS.R b/R/matrixMultDS.R index 67f4ae64..240fead8 100644 --- a/R/matrixMultDS.R +++ b/R/matrixMultDS.R @@ -13,61 +13,16 @@ #' @return Output is the matrix representing the product of M1 and M2 which is written #' to the serverside. For more details see help for ds.matrixMult #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' matrixMultDS <- function(M1.name=NULL, M2.name=NULL){ -######################################################################### -# DataSHIELD MODULE: CAPTURE THE nfilter SETTINGS # -thr<-dsBase::listDisclosureSettingsDS() # -#nfilter.tab<-as.numeric(thr$nfilter.tab) # -#nfilter.glm<-as.numeric(thr$nfilter.glm) # -#nfilter.subset<-as.numeric(thr$nfilter.subset) # -#nfilter.string<-as.numeric(thr$nfilter.string) # -nfilter.stringShort<-as.numeric(thr$nfilter.stringShort) # -#nfilter.kNN<-as.numeric(thr$nfilter.kNN) # -#datashield.privacyLevel<-as.numeric(thr$datashield.privacyLevel) # -######################################################################### -#EVAL M1 and M2 +M1 <- .loadServersideObject(M1.name) +.checkClass(obj = M1, obj_name = M1.name, permitted_classes = c("matrix", "data.frame")) -#Check length of M1.name not so long as to provide a risk of hidden code -length.M1.name<-length(unlist(strsplit(M1.name,''))) - -if(length.M1.name>nfilter.stringShort) - { - studysideMessage<- - paste0("FAILED: M1.name is too long it could hide concealed code, please shorten to <= nfilter.stringShort = ", - nfilter.stringShort," characters") - stop(studysideMessage, call. = FALSE) - } - -#Check length of M2.name not so long as to provide a risk of hidden code -length.M2.name<-length(unlist(strsplit(M2.name,''))) - -if(length.M2.name>nfilter.stringShort) - { - studysideMessage<- - paste0("FAILED: M2.name is too long it could hide concealed code, please shorten to <= nfilter.stringShort = ", - nfilter.stringShort," characters") - stop(studysideMessage, call. = FALSE) - } - -M1<-eval(parse(text=M1.name), envir = parent.frame()) -M2<-eval(parse(text=M2.name), envir = parent.frame()) - - - -if(!is.matrix(M1)&&!is.data.frame(M1)) - { - studysideMessage<-"FAILED: M1 must be of class matrix or data.frame, please respecify" - stop(studysideMessage, call. = FALSE) - } - -if(!is.matrix(M2)&&!is.data.frame(M2)) - { - studysideMessage<-"FAILED: M2 must be of class matrix or data.frame, please respecify" - stop(studysideMessage, call. = FALSE) - } +M2 <- .loadServersideObject(M2.name) +.checkClass(obj = M2, obj_name = M2.name, permitted_classes = c("matrix", "data.frame")) if(is.data.frame(M1)) { diff --git a/R/matrixTransposeDS.R b/R/matrixTransposeDS.R index 595d1d97..d731119d 100644 --- a/R/matrixTransposeDS.R +++ b/R/matrixTransposeDS.R @@ -9,42 +9,13 @@ #' @return Output is the matrix representing the transpose of A which is written #' to the serverside. For more details see help for ds.matrixTranspose #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' matrixTransposeDS <- function(M1.name=NULL){ -######################################################################### -# DataSHIELD MODULE: CAPTURE THE nfilter SETTINGS # -thr<-dsBase::listDisclosureSettingsDS() # -#nfilter.tab<-as.numeric(thr$nfilter.tab) # -#nfilter.glm<-as.numeric(thr$nfilter.glm) # -#nfilter.subset<-as.numeric(thr$nfilter.subset) # -#nfilter.string<-as.numeric(thr$nfilter.string) # -nfilter.stringShort<-as.numeric(thr$nfilter.stringShort) # -#nfilter.kNN<-as.numeric(thr$nfilter.kNN) # -#datashield.privacyLevel<-as.numeric(thr$datashield.privacyLevel) # -######################################################################### -#Check length of M1.name not so long as to provide a risk of hidden code -length.M1.name<-length(unlist(strsplit(M1.name,''))) - -if(length.M1.name>nfilter.stringShort) - { - studysideMessage<- - paste0("FAILED: M1.name is too long it could hide concealed code, please shorten to <= nfilter.stringShort = ", - nfilter.stringShort," characters") - stop(studysideMessage, call. = FALSE) - } - - -#EVAL M1 - -M1<-eval(parse(text=M1.name), envir = parent.frame()) - -if(!is.matrix(M1)&&!is.data.frame(M1)) - { - studysideMessage<-"FAILED: M1 must be of class matrix or data.frame, please respecify" - stop(studysideMessage, call. = FALSE) - } +M1 <- .loadServersideObject(M1.name) +.checkClass(obj = M1, obj_name = M1.name, permitted_classes = c("matrix", "data.frame")) #coerce to matrix if a data.frame if(is.data.frame(M1)) diff --git a/man/levelsDS.Rd b/man/levelsDS.Rd index c54b7d13..4002c73c 100644 --- a/man/levelsDS.Rd +++ b/man/levelsDS.Rd @@ -10,9 +10,8 @@ levelsDS(x) \item{x}{a factor vector} } \value{ -a list with two elements: \code{Levels} (the factor levels present - in the vector) and \code{class} (the class of the input object, for - client-side consistency checking) +a list with one element: \code{Levels} (the factor levels present + in the vector) } \description{ This function is similar to R function \code{levels}. diff --git a/man/matrixDS.Rd b/man/matrixDS.Rd index 11a86cef..d674f5f9 100644 --- a/man/matrixDS.Rd +++ b/man/matrixDS.Rd @@ -43,4 +43,6 @@ and assigns the values of all its elements based on the argument } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/matrixDiagDS.Rd b/man/matrixDiagDS.Rd index 21910204..aeeb90c4 100644 --- a/man/matrixDiagDS.Rd +++ b/man/matrixDiagDS.Rd @@ -35,4 +35,6 @@ For details see help for function \code{ds.matrixDiag}. } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/matrixDimnamesDS.Rd b/man/matrixDimnamesDS.Rd index 814177a6..eb008317 100644 --- a/man/matrixDimnamesDS.Rd +++ b/man/matrixDimnamesDS.Rd @@ -35,4 +35,6 @@ function \code{ds.matrixDimnames} } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/matrixInvertDS.Rd b/man/matrixInvertDS.Rd index 2588e500..728edb18 100644 --- a/man/matrixInvertDS.Rd +++ b/man/matrixInvertDS.Rd @@ -23,4 +23,6 @@ is non-singular - positive definite (eg there is no row or column that is all ze } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/matrixMultDS.Rd b/man/matrixMultDS.Rd index cac0958e..7247c22d 100644 --- a/man/matrixMultDS.Rd +++ b/man/matrixMultDS.Rd @@ -29,4 +29,6 @@ is only valid if the number of columns of A is the same as the number of rows of } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/matrixTransposeDS.Rd b/man/matrixTransposeDS.Rd index c05aac4e..591c8c7f 100644 --- a/man/matrixTransposeDS.Rd +++ b/man/matrixTransposeDS.Rd @@ -24,4 +24,6 @@ vice versa. } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/tests/testthat/test-smk-matrixDS.R b/tests/testthat/test-smk-matrixDS.R new file mode 100644 index 00000000..ba2b397e --- /dev/null +++ b/tests/testthat/test-smk-matrixDS.R @@ -0,0 +1,39 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("matrixDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +test_that("simple matrixDS, serverside.vector", { + mvec <- c(1, 2, 3, 4, 5, 6) + + res <- matrixDS("mvec", from = "serverside.vector", nrows.transmit = "2", ncols.transmit = "3", byrow = FALSE, dimnames = NULL) + + expect_true(is.matrix(res)) + expect_equal(nrow(res), 2) + expect_equal(ncol(res), 3) + expect_equal(res[1, 1], 1) + expect_equal(res[2, 1], 2) + expect_equal(res[1, 2], 3) +}) + +test_that("matrixDS errors when serverside object does not exist", { + expect_error(matrixDS("nonexistent_object", from = "serverside.vector", nrows.transmit = "2", ncols.transmit = "2", byrow = FALSE, dimnames = NULL), regexp = "does not exist") +}) diff --git a/tests/testthat/test-smk-matrixDiagDS.R b/tests/testthat/test-smk-matrixDiagDS.R new file mode 100644 index 00000000..cee4ba46 --- /dev/null +++ b/tests/testthat/test-smk-matrixDiagDS.R @@ -0,0 +1,36 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("matrixDiagDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +test_that("simple matrixDiagDS, serverside.matrix.2.vector", { + M1 <- matrix(c(1, 2, 3, 4), 2, 2) + + res <- matrixDiagDS("M1", aim = "serverside.matrix.2.vector", nrows.transmit = "-9") + + expect_equal(length(res), 2) + expect_equal(res[1], 1) + expect_equal(res[2], 4) +}) + +test_that("matrixDiagDS errors when serverside object does not exist", { + expect_error(matrixDiagDS("nonexistent_object", aim = "serverside.matrix.2.vector", nrows.transmit = "-9"), regexp = "does not exist") +}) diff --git a/tests/testthat/test-smk-matrixDimnamesDS.R b/tests/testthat/test-smk-matrixDimnamesDS.R new file mode 100644 index 00000000..b8dd59b8 --- /dev/null +++ b/tests/testthat/test-smk-matrixDimnamesDS.R @@ -0,0 +1,44 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("matrixDimnamesDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +test_that("simple matrixDimnamesDS", { + M1 <- matrix(c(1, 2, 3, 4), 2, 2) + new.dimnames <- list(c("r1", "r2"), c("c1", "c2")) + + res <- matrixDimnamesDS("M1", dimnames = new.dimnames) + + expect_true(is.matrix(res)) + expect_equal(nrow(res), 2) + expect_equal(ncol(res), 2) + expect_equal(rownames(res), c("r1", "r2")) + expect_equal(colnames(res), c("c1", "c2")) +}) + +test_that("matrixDimnamesDS errors when serverside object does not exist", { + expect_error(matrixDimnamesDS("nonexistent_object", dimnames = list(c("r1"), c("c1"))), regexp = "does not exist") +}) + +test_that("matrixDimnamesDS errors when input is wrong type", { + bad_input <- c("a", "b", "c") + expect_error(matrixDimnamesDS("bad_input", dimnames = list(c("r1"), c("c1"))), regexp = "must be of type") +}) diff --git a/tests/testthat/test-smk-matrixInvertDS.R b/tests/testthat/test-smk-matrixInvertDS.R new file mode 100644 index 00000000..514a39c7 --- /dev/null +++ b/tests/testthat/test-smk-matrixInvertDS.R @@ -0,0 +1,42 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("matrixInvertDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +test_that("simple matrixInvertDS", { + M1 <- matrix(c(1, 2, 3, 4), 2, 2) + + res <- matrixInvertDS("M1") + + expect_true(is.matrix(res)) + expect_equal(nrow(res), 2) + expect_equal(ncol(res), 2) + expect_equal(res, solve(M1)) +}) + +test_that("matrixInvertDS errors when serverside object does not exist", { + expect_error(matrixInvertDS("nonexistent_object"), regexp = "does not exist") +}) + +test_that("matrixInvertDS errors when input is wrong type", { + bad_input <- c("a", "b", "c") + expect_error(matrixInvertDS("bad_input"), regexp = "must be of type") +}) diff --git a/tests/testthat/test-smk-matrixMultDS.R b/tests/testthat/test-smk-matrixMultDS.R new file mode 100644 index 00000000..392daf74 --- /dev/null +++ b/tests/testthat/test-smk-matrixMultDS.R @@ -0,0 +1,44 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("matrixMultDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +test_that("simple matrixMultDS", { + M1 <- matrix(c(1, 2, 3, 4), 2, 2) + M2 <- matrix(c(5, 6, 7, 8), 2, 2) + + res <- matrixMultDS("M1", "M2") + + expect_true(is.matrix(res)) + expect_equal(nrow(res), 2) + expect_equal(ncol(res), 2) + expect_equal(res, M1 %*% M2) +}) + +test_that("matrixMultDS errors when serverside object does not exist", { + expect_error(matrixMultDS("nonexistent_object", "also_nonexistent"), regexp = "does not exist") +}) + +test_that("matrixMultDS errors when input is wrong type", { + bad_input <- c("a", "b", "c") + M2 <- matrix(c(1, 2, 3, 4), 2, 2) + expect_error(matrixMultDS("bad_input", "M2"), regexp = "must be of type") +}) diff --git a/tests/testthat/test-smk-matrixTransposeDS.R b/tests/testthat/test-smk-matrixTransposeDS.R new file mode 100644 index 00000000..50d41a1a --- /dev/null +++ b/tests/testthat/test-smk-matrixTransposeDS.R @@ -0,0 +1,42 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("matrixTransposeDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +test_that("simple matrixTransposeDS", { + M1 <- matrix(c(1, 2, 3, 4, 5, 6), 2, 3) + + res <- matrixTransposeDS("M1") + + expect_true(is.matrix(res)) + expect_equal(nrow(res), 3) + expect_equal(ncol(res), 2) + expect_equal(res, t(M1)) +}) + +test_that("matrixTransposeDS errors when serverside object does not exist", { + expect_error(matrixTransposeDS("nonexistent_object"), regexp = "does not exist") +}) + +test_that("matrixTransposeDS errors when input is wrong type", { + bad_input <- c("a", "b", "c") + expect_error(matrixTransposeDS("bad_input"), regexp = "must be of type") +}) From 0e5a8e7ff95a3afe94a69bc234196cd700f0dc0f Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Wed, 15 Apr 2026 15:22:27 +0200 Subject: [PATCH 02/30] refactor: batch-6 factor and recoding server functions --- R/asFactorDS1.R | 3 +- R/asFactorDS2.R | 3 +- R/asFactorSimpleDS.R | 3 +- R/changeRefGroupDS.R | 16 ++-- R/reShapeDS.R | 5 +- man/asFactorDS1.Rd | 3 + man/asFactorDS2.Rd | 3 + man/asFactorSimpleDS.Rd | 3 + man/changeRefGroupDS.Rd | 8 +- man/levelsDS.Rd | 5 +- man/reShapeDS.Rd | 2 + tests/testthat/test-smk-asFactorDS1.R | 11 +-- tests/testthat/test-smk-asFactorDS2.R | 96 ++------------------- tests/testthat/test-smk-asFactorSimpleDS.R | 33 ++------ tests/testthat/test-smk-changeRefGroupDS.R | 98 ++++------------------ tests/testthat/test-smk-dmtC2SDS.R | 40 +++++++++ tests/testthat/test-smk-reShapeDS.R | 46 ++++++++++ 17 files changed, 153 insertions(+), 225 deletions(-) create mode 100644 tests/testthat/test-smk-dmtC2SDS.R create mode 100644 tests/testthat/test-smk-reShapeDS.R diff --git a/R/asFactorDS1.R b/R/asFactorDS1.R index 6d4f0507..c6c0445a 100644 --- a/R/asFactorDS1.R +++ b/R/asFactorDS1.R @@ -7,6 +7,7 @@ #' are of type character. #' @param input.var.name the name of the variable that is to be converted to a factor. #' @return the levels of the input variable. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' asFactorDS1 <- function(input.var.name=NULL){ @@ -24,7 +25,7 @@ asFactorDS1 <- function(input.var.name=NULL){ nfilter.levels.max <- as.numeric(thr$nfilter.levels.max) # ################################################################## - input.var <- eval(parse(text=input.var.name), envir = parent.frame()) + input.var <- .loadServersideObject(input.var.name) factor.levels.present.in.source <- levels(factor(input.var)) num.levels<-length(factor.levels.present.in.source) diff --git a/R/asFactorDS2.R b/R/asFactorDS2.R index 74af1d67..af45a47f 100644 --- a/R/asFactorDS2.R +++ b/R/asFactorDS2.R @@ -15,11 +15,12 @@ #' @param baseline.level a number indicating the baseline level to be used in the creation of the #' matrix of dummy variables. #' @return an object of class factor +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' asFactorDS2 <- function(input.var.name=NULL, all.unique.levels.transmit=NULL, fixed.dummy.vars=NULL, baseline.level=NULL){ - input.var <- eval(parse(text=input.var.name), envir = parent.frame()) + input.var <- .loadServersideObject(input.var.name) code.input <- all.unique.levels.transmit code.c <- unlist(strsplit(code.input, split=",")) diff --git a/R/asFactorSimpleDS.R b/R/asFactorSimpleDS.R index 80a14b27..b23c8244 100644 --- a/R/asFactorSimpleDS.R +++ b/R/asFactorSimpleDS.R @@ -12,11 +12,12 @@ #' of these things you will have to use the ds.asFactor function. #' @param input.var.name the name of the variable that is to be converted to a factor. #' @return an object of class factor +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' asFactorSimpleDS <- function(input.var.name=NULL){ - input.var <- eval(parse(text=input.var.name), envir = parent.frame()) + input.var <- .loadServersideObject(input.var.name) factor.obj <- factor(input.var) diff --git a/R/changeRefGroupDS.R b/R/changeRefGroupDS.R index b99cc0ee..6b1aae3a 100644 --- a/R/changeRefGroupDS.R +++ b/R/changeRefGroupDS.R @@ -7,16 +7,20 @@ #' as this can introduce a mismatch of values if the vector is put back #' into a table that is not reordered in the same way. Such mismatch #' can render the results of operations on that table invalid. -#' @param xvect a factor vector +#' @param x a character string, the name of a factor vector. #' @param ref a character, the reference level -#' @param reorderByRef a boolean that tells whether or not the new +#' @param reorderByRef a boolean that tells whether or not the new #' vector should be ordered by the reference group. #' @return a factor of the same length as xvect #' @author Isaeva, J., Gaye, A. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' -changeRefGroupDS <- function(xvect, ref=NULL, reorderByRef=NULL){ - +changeRefGroupDS <- function(x, ref=NULL, reorderByRef=NULL){ + + xvect <- .loadServersideObject(x) + .checkClass(obj = xvect, obj_name = x, permitted_classes = "factor") + if(reorderByRef){ temp_xvect = stats::relevel(xvect, ref) # now reorder puting the ref group first @@ -26,7 +30,7 @@ changeRefGroupDS <- function(xvect, ref=NULL, reorderByRef=NULL){ }else{ new_xvect <- stats::relevel(xvect, ref) } - + return(new_xvect) - + } diff --git a/R/reShapeDS.R b/R/reShapeDS.R index 2ec368a5..524a346d 100644 --- a/R/reShapeDS.R +++ b/R/reShapeDS.R @@ -39,14 +39,15 @@ #' indicating whether has been created in each data source and if so whether #' it is in a valid form (see header for \code{ds.reShape}. #' @author Demetris Avraam, Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export reShapeDS <- function(data.name, varying.transmit, v.names.transmit, timevar.name, idvar.name, drop.transmit, direction, sep){ # Check Permissive Privacy Control Level. dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot')) - datatext <- paste0("data.frame(",data.name,")") - data <- eval(parse(text=datatext), envir = parent.frame()) + data <- .loadServersideObject(data.name) + data <- data.frame(data) timevar <- timevar.name idvar <- idvar.name diff --git a/man/asFactorDS1.Rd b/man/asFactorDS1.Rd index f337a23e..69d8ca34 100644 --- a/man/asFactorDS1.Rd +++ b/man/asFactorDS1.Rd @@ -21,3 +21,6 @@ The function encodes the input vector as factor and returns its levels in ascending order if the levels are numerical or in alphabetical order if the levels are of type character. } +\author{ +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +} diff --git a/man/asFactorDS2.Rd b/man/asFactorDS2.Rd index 16b4a50f..006e2bac 100644 --- a/man/asFactorDS2.Rd +++ b/man/asFactorDS2.Rd @@ -37,3 +37,6 @@ The functions converts the input variable into a factor which is presented as a if the \code{fixed.dummy.vars} is set to FALSE or as a matrix with dummy variables if the \code{fixed.dummy.vars} is set to TRUE (see the help file of ds.asFactor.b for more details). } +\author{ +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +} diff --git a/man/asFactorSimpleDS.Rd b/man/asFactorSimpleDS.Rd index d0916749..2b234c9a 100644 --- a/man/asFactorSimpleDS.Rd +++ b/man/asFactorSimpleDS.Rd @@ -26,3 +26,6 @@ In addition, it does not allow you to create an array of binary dummy variables that is equivalent to a factor. If you need to do any of these things you will have to use the ds.asFactor function. } +\author{ +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +} diff --git a/man/changeRefGroupDS.Rd b/man/changeRefGroupDS.Rd index 05fe80cf..b48be075 100644 --- a/man/changeRefGroupDS.Rd +++ b/man/changeRefGroupDS.Rd @@ -4,14 +4,14 @@ \alias{changeRefGroupDS} \title{Changes a reference level of a factor} \usage{ -changeRefGroupDS(xvect, ref = NULL, reorderByRef = NULL) +changeRefGroupDS(x, ref = NULL, reorderByRef = NULL) } \arguments{ -\item{xvect}{a factor vector} +\item{x}{a character string, the name of a factor vector.} \item{ref}{a character, the reference level} -\item{reorderByRef}{a boolean that tells whether or not the new +\item{reorderByRef}{a boolean that tells whether or not the new vector should be ordered by the reference group.} } \value{ @@ -30,4 +30,6 @@ can render the results of operations on that table invalid. } \author{ Isaeva, J., Gaye, A. + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/levelsDS.Rd b/man/levelsDS.Rd index c54b7d13..4002c73c 100644 --- a/man/levelsDS.Rd +++ b/man/levelsDS.Rd @@ -10,9 +10,8 @@ levelsDS(x) \item{x}{a factor vector} } \value{ -a list with two elements: \code{Levels} (the factor levels present - in the vector) and \code{class} (the class of the input object, for - client-side consistency checking) +a list with one element: \code{Levels} (the factor levels present + in the vector) } \description{ This function is similar to R function \code{levels}. diff --git a/man/reShapeDS.Rd b/man/reShapeDS.Rd index 2a0ace77..70515104 100644 --- a/man/reShapeDS.Rd +++ b/man/reShapeDS.Rd @@ -71,4 +71,6 @@ measurements in separate records. The reshaping can be in either direction } \author{ Demetris Avraam, Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/tests/testthat/test-smk-asFactorDS1.R b/tests/testthat/test-smk-asFactorDS1.R index a990d4ff..e7f0abb8 100644 --- a/tests/testthat/test-smk-asFactorDS1.R +++ b/tests/testthat/test-smk-asFactorDS1.R @@ -21,7 +21,6 @@ set.standard.disclosure.settings() # Tests # -# context("asFactorDS1::smk::simple") test_that("simple asFactorDS1", { input <- c(2.0, 1.0, 3.0, 3.0, 3.0, 1.0, 2.0, 2.0, 1.0, 2.0) @@ -34,10 +33,6 @@ test_that("simple asFactorDS1", { expect_equal(res[3], "3") }) -# -# Done -# - -# context("asFactorDS1::smk::shutdown") - -# context("asFactorDS1::smk::done") +test_that("asFactorDS1 errors when serverside object does not exist", { + expect_error(asFactorDS1("nonexistent_object"), regexp = "does not exist") +}) diff --git a/tests/testthat/test-smk-asFactorDS2.R b/tests/testthat/test-smk-asFactorDS2.R index 1c761d4d..1e842328 100644 --- a/tests/testthat/test-smk-asFactorDS2.R +++ b/tests/testthat/test-smk-asFactorDS2.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. # # This program and the accompanying materials # are made available under the terms of the GNU Public License v3.0. @@ -20,99 +21,16 @@ set.standard.disclosure.settings() # Tests # -# context("asFactorDS2::smk::simple") -test_that("simple asFactorDS2, fixed.dummy.vars is FALSE", { - input <- c(2, 1, 3, 3, 3, 1, 2, 2, 1, 2) - all.unique.levels.transmit <- "1,2,3,4" - fixed.dummy.vars <- FALSE - baseline.level <- NULL +test_that("simple asFactorDS2", { + input <- c(2, 1, 3, 3, 3, 1, 2, 2, 1, 2) - res <- asFactorDS2("input", all.unique.levels.transmit, fixed.dummy.vars, baseline.level) + res <- asFactorDS2("input", "1,2,3,4", FALSE, NULL) expect_equal(class(res), "factor") expect_length(res, 10) - - res.levels <- levels(res) - - expect_equal(class(res.levels), "character") - expect_length(res.levels, 4) - - expect_equal(res.levels[1], "1") - expect_equal(res.levels[2], "2") - expect_equal(res.levels[3], "3") - expect_equal(res.levels[4], "4") + expect_equal(levels(res), c("1", "2", "3", "4")) }) -test_that("simple asFactorDS2, fixed.dummy.vars is TRUE", { - input <- c(2, 1, 3, 3, 3, 1, 2, 2, 1, 2) - all.unique.levels.transmit <- "1,2,3,4" - fixed.dummy.vars <- TRUE - baseline.level <- 1.0 - - res <- asFactorDS2("input", all.unique.levels.transmit, fixed.dummy.vars, baseline.level) - - expect_length(res, 30) - - res.class <- class(res) - - if (base::getRversion() < '4.0.0') - { - expect_length(res.class, 1) - expect_true("matrix" %in% res.class) - } - else - { - expect_length(res.class, 2) - expect_true("matrix" %in% res.class) - expect_true("array" %in% res.class) - } - - expect_equal(res[1], 1) - expect_equal(res[2], 0) - expect_equal(res[3], 0) - expect_equal(res[4], 0) - expect_equal(res[5], 0) - expect_equal(res[6], 0) - expect_equal(res[7], 1) - expect_equal(res[8], 1) - expect_equal(res[9], 0) - expect_equal(res[10], 1) - expect_equal(res[11], 0) - expect_equal(res[12], 0) - expect_equal(res[13], 1) - expect_equal(res[14], 1) - expect_equal(res[15], 1) - expect_equal(res[16], 0) - expect_equal(res[17], 0) - expect_equal(res[18], 0) - expect_equal(res[19], 0) - expect_equal(res[20], 0) - expect_equal(res[21], 0) - expect_equal(res[22], 0) - expect_equal(res[23], 0) - expect_equal(res[24], 0) - expect_equal(res[25], 0) - expect_equal(res[26], 0) - expect_equal(res[27], 0) - expect_equal(res[28], 0) - expect_equal(res[29], 0) - expect_equal(res[30], 0) - - - res.colnames <- colnames(res) - - expect_equal(class(res.colnames), "character") - expect_length(res.colnames, 3) - - expect_equal(res.colnames[1], "DV2") - expect_equal(res.colnames[2], "DV3") - expect_equal(res.colnames[3], "DV4") +test_that("asFactorDS2 errors when serverside object does not exist", { + expect_error(asFactorDS2("nonexistent_object", "1,2", FALSE, NULL), regexp = "does not exist") }) - -# -# Done -# - -# context("asFactorDS2::smk::shutdown") - -# context("asFactorDS2::smk::done") diff --git a/tests/testthat/test-smk-asFactorSimpleDS.R b/tests/testthat/test-smk-asFactorSimpleDS.R index 7e871da3..a12df35b 100644 --- a/tests/testthat/test-smk-asFactorSimpleDS.R +++ b/tests/testthat/test-smk-asFactorSimpleDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. # # This program and the accompanying materials # are made available under the terms of the GNU Public License v3.0. @@ -20,38 +21,16 @@ set.standard.disclosure.settings() # Tests # -# context("asFactorSimpleDS::smk::simple") test_that("simple asFactorSimpleDS", { - input <- c(2.0, 1.0, 3.0, 3.0, 3.0, 1.0, 2.0, 2.0, 1.0, 2.0) + input <- c(2, 1, 3, 3, 3, 1, 2, 2, 1, 2) res <- asFactorSimpleDS("input") expect_equal(class(res), "factor") expect_length(res, 10) - expect_true(res[1] == "2") - expect_true(res[2] == "1") - expect_true(res[3] == "3") - expect_true(res[4] == "3") - expect_true(res[5] == "3") - expect_true(res[6] == "1") - expect_true(res[7] == "2") - expect_true(res[8] == "2") - expect_true(res[9] == "1") - expect_true(res[10] == "2") - - res.levels <- levels(res) - - expect_equal(class(res.levels), "character") - expect_length(res.levels, 3) - expect_equal(res.levels[1], "1") - expect_equal(res.levels[2], "2") - expect_equal(res.levels[3], "3") + expect_equal(levels(res), c("1", "2", "3")) }) -# -# Done -# - -# context("asFactorSimpleDS::smk::shutdown") - -# context("asFactorSimpleDS::smk::done") +test_that("asFactorSimpleDS errors when serverside object does not exist", { + expect_error(asFactorSimpleDS("nonexistent_object"), regexp = "does not exist") +}) diff --git a/tests/testthat/test-smk-changeRefGroupDS.R b/tests/testthat/test-smk-changeRefGroupDS.R index 3d94fde7..e6a8a4c0 100644 --- a/tests/testthat/test-smk-changeRefGroupDS.R +++ b/tests/testthat/test-smk-changeRefGroupDS.R @@ -15,99 +15,29 @@ # context("changeRefGroupDS::smk::setup") +set.standard.disclosure.settings() + # # Tests # -# context("changeRefGroupDS::smk") -test_that("simple changeRefGroupDS, reorderByRef is FALSE", { - x <- c(8, 1, 6, 1, 4, 1, 2, 1) - xf <- as.factor(x) - ref <- 2 - reorderByRef <- FALSE +test_that("simple changeRefGroupDS", { + xf <- as.factor(c(8, 1, 6, 1, 4, 1, 2, 1)) - res <- changeRefGroupDS(xf, ref, reorderByRef) + res <- changeRefGroupDS("xf", ref = 2, reorderByRef = FALSE) expect_equal(class(res), "factor") expect_length(res, 8) - - res.num <- as.numeric(res) - - expect_equal(class(res.num), "numeric") - expect_length(res.num, 8) - - expect_equal(res.num[1], 5) - expect_equal(res.num[2], 2) - expect_equal(res.num[3], 4) - expect_equal(res.num[4], 2) - expect_equal(res.num[5], 3) - expect_equal(res.num[6], 2) - expect_equal(res.num[7], 1) - expect_equal(res.num[8], 2) - - res.levels <- levels(res) - - expect_equal(class(res.levels), "character") - expect_length(res.levels, 5) - expect_equal(res.levels[1], "2") - expect_equal(res.levels[2], "1") - expect_equal(res.levels[3], "4") - expect_equal(res.levels[4], "6") - expect_equal(res.levels[5], "8") + expect_equal(levels(res)[1], "2") }) -test_that("simple changeRefGroupDS, reorderByRef is TRUE", { - x <- rep(8, 1, 6, 1, 4, 1, 2, 1) - xf <- as.factor(x) - ref <- 1 - reorderByRef <- TRUE - - res <- changeRefGroupDS(xf, ref, reorderByRef) - - if (base::getRversion() < '4.1.0') - { - expect_equal(class(res), "integer") - expect_length(res, 6) - expect_equal(res[1], 1) - expect_equal(res[2], 1) - expect_equal(res[3], 1) - expect_equal(res[4], 1) - expect_equal(res[5], 1) - expect_equal(res[6], 1) - - res.levels <- levels(res) - - expect_true(is.null(res.levels)) - } - else - { - expect_equal(class(res), "factor") - expect_length(res, 6) - - res.num <- as.numeric(res) - - expect_equal(class(res.num), "numeric") - expect_length(res.num, 6) - - expect_equal(res.num[1], 1) - expect_equal(res.num[2], 1) - expect_equal(res.num[3], 1) - expect_equal(res.num[4], 1) - expect_equal(res.num[5], 1) - expect_equal(res.num[6], 1) - - res.levels <- levels(res) - - expect_equal(class(res.levels), "character") - expect_length(res.levels, 1) - expect_equal(res.levels[1], "8") - } +test_that("changeRefGroupDS errors when serverside object does not exist", { + expect_error(changeRefGroupDS("nonexistent_object", ref = 1, reorderByRef = FALSE), + regexp = "does not exist") }) -# -# Done -# - -# context("changeRefGroupDS::smk::shutdown") - -# context("changeRefGroupDS::smk::done") +test_that("changeRefGroupDS errors when object is not a factor", { + bad_input <- c(1, 2, 3) + expect_error(changeRefGroupDS("bad_input", ref = 1, reorderByRef = FALSE), + regexp = "must be of type") +}) diff --git a/tests/testthat/test-smk-dmtC2SDS.R b/tests/testthat/test-smk-dmtC2SDS.R new file mode 100644 index 00000000..c3f30f7d --- /dev/null +++ b/tests/testthat/test-smk-dmtC2SDS.R @@ -0,0 +1,40 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("dmtC2SDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +test_that("simple dmtC2SDS returns matrix", { + res <- dmtC2SDS( + dfdata.mat.transmit = "1,2,3,4", + inout.object.transmit = "MAT", + from = "clientside.matdftbl", + nrows.transmit = "2", + ncols.transmit = "2", + colnames.transmit = "a,b", + colclass.transmit = "numeric,numeric", + byrow = FALSE + ) + + expect_true(is.matrix(res)) + expect_equal(nrow(res), 2) + expect_equal(ncol(res), 2) + expect_equal(colnames(res), c("a", "b")) +}) diff --git a/tests/testthat/test-smk-reShapeDS.R b/tests/testthat/test-smk-reShapeDS.R new file mode 100644 index 00000000..ffb1091f --- /dev/null +++ b/tests/testthat/test-smk-reShapeDS.R @@ -0,0 +1,46 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("reShapeDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +test_that("simple reShapeDS wide to long", { + wide_df <- data.frame( + id = 1:3, + sbp.1 = c(120, 130, 125), + sbp.2 = c(122, 135, 128) + ) + + res <- reShapeDS( + data.name = "wide_df", + varying.transmit = "sbp.1,sbp.2", + v.names.transmit = "sbp", + timevar.name = "time", + idvar.name = "id", + drop.transmit = NULL, + direction = "long", + sep = "." + ) + + expect_s3_class(res, "data.frame") + expect_equal(nrow(res), 6) + expect_true("sbp" %in% colnames(res)) + expect_true("time" %in% colnames(res)) +}) From 415966d3099e83a21611ca0e879d2821843627cb Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 16 Apr 2026 00:42:05 +0200 Subject: [PATCH 03/30] refactor: batch-7 first-pass modelling server functions --- R/gamlssDS.R | 10 ++++++---- R/glmPredictDS.ag.R | 7 +++---- R/glmPredictDS.as.R | 7 +++---- R/glmSummaryDS.ag.R | 5 +++-- R/glmSummaryDS.as.R | 3 ++- R/miceDS.R | 6 ++++-- man/gamlssDS.Rd | 2 ++ man/glmPredictDS.ag.Rd | 2 ++ man/glmPredictDS.as.Rd | 2 ++ man/glmSummaryDS.ag.Rd | 2 ++ man/glmSummaryDS.as.Rd | 2 ++ man/levelsDS.Rd | 5 ++--- man/miceDS.Rd | 2 ++ 13 files changed, 35 insertions(+), 20 deletions(-) diff --git a/R/gamlssDS.R b/R/gamlssDS.R index 533da0e1..1789b5af 100644 --- a/R/gamlssDS.R +++ b/R/gamlssDS.R @@ -69,6 +69,7 @@ #' residuals (the normalised quantile residuals of the model) are not disclosed to #' the client-side. #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @import gamlss #' @import gamlss.dist #' @export @@ -81,8 +82,9 @@ gamlssDS <- function(formula=formula, sigma.formula=sigma.formula, nu.formula=nu thr <- dsBase::listDisclosureSettingsDS() nfilter.glm <- as.numeric(thr$nfilter.glm) - - data <- eval(parse(text = data), envir = parent.frame()) + + data <- .loadServersideObject(data) + .checkClass(obj = data, obj_name = "data", permitted_classes = c("data.frame", "matrix")) family <- gsub("left_parenthesis", "(", family, fixed = TRUE) family <- gsub("right_parenthesis", ")", family, fixed = TRUE) @@ -187,8 +189,8 @@ gamlssDS <- function(formula=formula, sigma.formula=sigma.formula, nu.formula=nu base::assign(newobj, results$residuals, envir = parent.frame()) if(centiles==TRUE){ - xvar <- eval(parse(text=xvar), envir = parent.frame()) - centiles_out <- gamlss::centiles(obj = results, xvar = xvar, points = FALSE, + xvar <- .loadServersideObject(xvar) + centiles_out <- gamlss::centiles(obj = results, xvar = xvar, points = FALSE, save = TRUE) }else{ centiles_out <- NA diff --git a/R/glmPredictDS.ag.R b/R/glmPredictDS.ag.R index c4474079..9a40804e 100644 --- a/R/glmPredictDS.ag.R +++ b/R/glmPredictDS.ag.R @@ -34,6 +34,7 @@ #' ds.glmPredict and glmPredict.as and help in native R for predict.glm #' predict.glm in native R #' @author Paul Burton for DataSHIELD Development Team (20/7/20) +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' glmPredictDS.ag <- function(glmname.transmit, newdataname.transmit, @@ -148,13 +149,11 @@ if(!string.safe) } #Activate all arguments -#glmobj<-eval(parse(text=glmname.transmit)) -glmobj<-get(glmname.transmit) +glmobj <- .loadServersideObject(glmname.transmit) if(!is.null(newdataname.transmit)) { - newdf<-get(newdataname.transmit) -# newdf<-geeval(parse(text=newdataname.transmit)) + newdf <- .loadServersideObject(newdataname.transmit) }else{ newdf<-NULL } diff --git a/R/glmPredictDS.as.R b/R/glmPredictDS.as.R index e25e3b50..84417fc9 100644 --- a/R/glmPredictDS.as.R +++ b/R/glmPredictDS.as.R @@ -32,6 +32,7 @@ #' For more details see DataSHIELD help for ds.glmPredict and help for #' predict.glm in native R #' @author Paul Burton for DataSHIELD Development Team (20/7/20) +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export glmPredictDS.as <- function(glmname.transmit, newdataname.transmit, output.type,se.fit, dispersion, terms.transmit, na.action){ @@ -142,13 +143,11 @@ if(!string.safe) } #Activate all arguments -#glmobj<-eval(parse(text=glmname.transmit)) -glmobj<-get(glmname.transmit) +glmobj <- .loadServersideObject(glmname.transmit) if(!is.null(newdataname.transmit)) { - newdf<-get(newdataname.transmit) -# newdf<-geeval(parse(text=newdataname.transmit)) + newdf <- .loadServersideObject(newdataname.transmit) }else{ newdf<-NULL } diff --git a/R/glmSummaryDS.ag.R b/R/glmSummaryDS.ag.R index 880f5b79..7316eee4 100644 --- a/R/glmSummaryDS.ag.R +++ b/R/glmSummaryDS.ag.R @@ -17,6 +17,7 @@ #' elements (and only the non-disclosive elements) of a specified serverside glm #' and its corresponding summary_glm object. #' @author Paul Burton for DataSHIELD Development Team (20/7/20) +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export glmSummaryDS.ag <- function(x.transmit){ @@ -55,7 +56,7 @@ if(!string.safe) #create safe glm object with disclosive elements deleted for clientside ####################################################################### -input.obj<-eval(parse(text=x.transmit)) +input.obj <- .loadServersideObject(x.transmit) if (is.null(input.obj)) { @@ -90,7 +91,7 @@ glm.obj<-input.obj #create safe summary.glm object with disclosive elements deleted for clientside ############################################################################### -input.obj<-eval(parse(text=x.transmit)) +input.obj <- .loadServersideObject(x.transmit) summary.obj<-summary(input.obj) diff --git a/R/glmSummaryDS.as.R b/R/glmSummaryDS.as.R index 38cf4cf8..0025e74e 100644 --- a/R/glmSummaryDS.as.R +++ b/R/glmSummaryDS.as.R @@ -15,6 +15,7 @@ #' @return writes object to serverside which is precisely equivalent #' to summary(glm object) in native R #' @author Paul Burton for DataSHIELD Development Team (20/7/20) +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export glmSummaryDS.as <- function(x.transmit){ @@ -52,7 +53,7 @@ if(!string.safe) #create summary.glm object -input.obj<-eval(parse(text=x.transmit)) +input.obj <- .loadServersideObject(x.transmit) summary.obj<-summary(input.obj) diff --git a/R/miceDS.R b/R/miceDS.R index 98904dfe..7bf0bccd 100644 --- a/R/miceDS.R +++ b/R/miceDS.R @@ -43,7 +43,8 @@ #' The function also saves in each server the mids object and all completed datasets as #' dataframes. #' @author Demetris Avraam for DataSHIELD Development Team -#' @import mice +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +#' @import mice #' @export #' miceDS <- function(data=data, m=m, maxit=maxit, method=method, post=post, seed=seed, @@ -57,7 +58,8 @@ miceDS <- function(data=data, m=m, maxit=maxit, method=method, post=post, seed=s seed <- getOption("datashield.seed") } - data <- eval(parse(text=data), envir = parent.frame()) + data <- .loadServersideObject(data) + .checkClass(obj = data, obj_name = "data", permitted_classes = c("data.frame", "matrix")) if(!is.null(method)){ method <- unlist(stringr::str_split(method, pattern=",")) diff --git a/man/gamlssDS.Rd b/man/gamlssDS.Rd index 218eb4ac..ca538529 100644 --- a/man/gamlssDS.Rd +++ b/man/gamlssDS.Rd @@ -116,4 +116,6 @@ functions in native R gamlss package. } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/glmPredictDS.ag.Rd b/man/glmPredictDS.ag.Rd index 2de27645..cdeb0ef4 100644 --- a/man/glmPredictDS.ag.Rd +++ b/man/glmPredictDS.ag.Rd @@ -63,4 +63,6 @@ ds.glmPredict and glmPredict.as and help in native R for predict.glm } \author{ Paul Burton for DataSHIELD Development Team (20/7/20) + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/glmPredictDS.as.Rd b/man/glmPredictDS.as.Rd index 7395773e..ec757e8c 100644 --- a/man/glmPredictDS.as.Rd +++ b/man/glmPredictDS.as.Rd @@ -61,4 +61,6 @@ for predict.glm } \author{ Paul Burton for DataSHIELD Development Team (20/7/20) + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/glmSummaryDS.ag.Rd b/man/glmSummaryDS.ag.Rd index d64a6218..8b8632c9 100644 --- a/man/glmSummaryDS.ag.Rd +++ b/man/glmSummaryDS.ag.Rd @@ -32,4 +32,6 @@ and its corresponding summary_glm object. } \author{ Paul Burton for DataSHIELD Development Team (20/7/20) + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/glmSummaryDS.as.Rd b/man/glmSummaryDS.as.Rd index e2067100..68ddcce6 100644 --- a/man/glmSummaryDS.as.Rd +++ b/man/glmSummaryDS.as.Rd @@ -30,4 +30,6 @@ for glm() and summary.glm } \author{ Paul Burton for DataSHIELD Development Team (20/7/20) + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/levelsDS.Rd b/man/levelsDS.Rd index c54b7d13..4002c73c 100644 --- a/man/levelsDS.Rd +++ b/man/levelsDS.Rd @@ -10,9 +10,8 @@ levelsDS(x) \item{x}{a factor vector} } \value{ -a list with two elements: \code{Levels} (the factor levels present - in the vector) and \code{class} (the class of the input object, for - client-side consistency checking) +a list with one element: \code{Levels} (the factor levels present + in the vector) } \description{ This function is similar to R function \code{levels}. diff --git a/man/miceDS.Rd b/man/miceDS.Rd index dd04c30c..e9496da8 100644 --- a/man/miceDS.Rd +++ b/man/miceDS.Rd @@ -78,4 +78,6 @@ package. } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } From 07b11e137485b4cd3a2d1485d7454de7f2866ee7 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 16 Apr 2026 01:10:48 +0200 Subject: [PATCH 04/30] refactor: batch-7 second-pass modelling server functions --- R/glmDS1.R | 4 +++- R/glmDS2.R | 4 +++- R/glmSLMADS1.R | 4 +++- R/glmSLMADS2.R | 4 +++- R/glmerSLMADS.assign.R | 4 +++- R/glmerSLMADS2.R | 4 +++- R/lmerSLMADS.assign.R | 4 +++- R/lmerSLMADS2.R | 4 +++- man/glmDS1.Rd | 2 ++ man/glmDS2.Rd | 2 ++ man/glmSLMADS1.Rd | 2 ++ man/glmSLMADS2.Rd | 2 ++ man/glmerSLMADS.assign.Rd | 2 ++ man/glmerSLMADS2.Rd | 2 ++ man/lmerSLMADS.assign.Rd | 2 ++ man/lmerSLMADS2.Rd | 2 ++ 16 files changed, 40 insertions(+), 8 deletions(-) diff --git a/R/glmDS1.R b/R/glmDS1.R index a76d615c..568e3070 100644 --- a/R/glmDS1.R +++ b/R/glmDS1.R @@ -19,6 +19,7 @@ #' @return List with values from GLM model. #' #' @author Burton PR for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' glmDS1 <- function(formula, family, weights, offset, data){ @@ -41,7 +42,8 @@ nfilter.glm <- as.numeric(thr$nfilter.glm) if(is.null(data)){ dataTable <- NULL }else{ - dataTable <- eval(parse(text=data), envir = parent.frame()) + dataTable <- .loadServersideObject(data) + .checkClass(obj = dataTable, obj_name = data, permitted_classes = c("data.frame", "matrix")) } formulatext <- Reduce(paste, deparse(formula)) diff --git a/R/glmDS2.R b/R/glmDS2.R index 9287075c..93e8edda 100644 --- a/R/glmDS2.R +++ b/R/glmDS2.R @@ -20,6 +20,7 @@ #' the data to be analysed under the specified model same #' #' @author Paul Burton, for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' #' @return List with values from GLM model #' @export @@ -39,7 +40,8 @@ glmDS2 <- function (formula, family, beta.vect, offset, weights, dataName) { # Same is done for offset and weights lower down function if(!is.null(dataName)){ - dataDF <- eval(parse(text=dataName), envir = parent.frame()) + dataDF <- .loadServersideObject(dataName) + .checkClass(obj = dataDF, obj_name = dataName, permitted_classes = c("data.frame", "matrix")) }else{ dataDF <- NULL } diff --git a/R/glmSLMADS1.R b/R/glmSLMADS1.R index 30346f4e..4cddefdb 100644 --- a/R/glmSLMADS1.R +++ b/R/glmSLMADS1.R @@ -17,6 +17,7 @@ #' such as test of model complexity (saturation). #' For more detailed information see help for ds.glmSLMA. #' @author Paul Burton for DataSHIELD Development Team (14/7/20) +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export glmSLMADS1<- function(formula, family, weights, offset, data){ @@ -51,7 +52,8 @@ final.family.object<-eval(parse(text=family)) if(is.null(data)){ dataTable <- NULL }else{ - dataTable <- eval(parse(text=data), envir = parent.frame()) + dataTable <- .loadServersideObject(data) + .checkClass(obj = dataTable, obj_name = data, permitted_classes = c("data.frame", "matrix")) } diff --git a/R/glmSLMADS2.R b/R/glmSLMADS2.R index 759263b5..b7374296 100644 --- a/R/glmSLMADS2.R +++ b/R/glmSLMADS2.R @@ -22,6 +22,7 @@ #' in particular including the study-specific regression coefficients and their corresponding #' standard errors. #' @author Paul Burton for DataSHIELD Development Team (14/7/20) +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export glmSLMADS2 <- function(formula, family, offset, weights, newobj, dataName){ @@ -52,7 +53,8 @@ errorMessage2<-"No errors" # Same is done for offset and weights lower down function if(!is.null(dataName)){ - dataDF <- eval(parse(text=dataName), envir = parent.frame()) + dataDF <- .loadServersideObject(dataName) + .checkClass(obj = dataDF, obj_name = dataName, permitted_classes = c("data.frame", "matrix")) }else{ dataDF<-NULL } diff --git a/R/glmerSLMADS.assign.R b/R/glmerSLMADS.assign.R index df367ea1..2105fea7 100644 --- a/R/glmerSLMADS.assign.R +++ b/R/glmerSLMADS.assign.R @@ -29,6 +29,7 @@ #' @return writes glmerMod object summarising the fitted model to the serverside. #' For more detailed information see help for ds.glmerSLMA. #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export glmerSLMADS.assign <- function(formula, offset, weights, dataName, family, control_type=NULL, control_value.transmit=NULL, nAGQ=1L, verbose = 0, theta = NULL, fixef = NULL){ @@ -46,7 +47,8 @@ glmerSLMADS.assign <- function(formula, offset, weights, dataName, family, # Same is done for offset and weights lower down function if(!is.null(dataName)){ - dataDF <- eval(parse(text=dataName), envir = parent.frame()) + dataDF <- .loadServersideObject(dataName) + .checkClass(obj = dataDF, obj_name = dataName, permitted_classes = c("data.frame", "matrix")) }else{ dataDF <- NULL } diff --git a/R/glmerSLMADS2.R b/R/glmerSLMADS2.R index 8fe54f83..d4b15f8c 100644 --- a/R/glmerSLMADS2.R +++ b/R/glmerSLMADS2.R @@ -36,6 +36,7 @@ #' function ds.glmerSLMA #' @return all key model components see help for ds.glmerSLMA #' @author Tom Bishop, with some additions by Paul Burton +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export glmerSLMADS2 <- function(formula, offset, weights, dataName, family, control_type=NULL, control_value.transmit=NULL, nAGQ=1L, verbose = 0, theta = NULL, fixef = NULL){ @@ -53,7 +54,8 @@ glmerSLMADS2 <- function(formula, offset, weights, dataName, family, # Same is done for offset and weights lower down function if(!is.null(dataName)){ - dataDF <- eval(parse(text=dataName), envir = parent.frame()) + dataDF <- .loadServersideObject(dataName) + .checkClass(obj = dataDF, obj_name = dataName, permitted_classes = c("data.frame", "matrix")) }else{ dataDF <- NULL } diff --git a/R/lmerSLMADS.assign.R b/R/lmerSLMADS.assign.R index 06b2bcd1..2343fe59 100644 --- a/R/lmerSLMADS.assign.R +++ b/R/lmerSLMADS.assign.R @@ -18,6 +18,7 @@ #' @return writes lmerMod object summarising the fitted model to the serverside. #' For more detailed information see help for ds.lmerSLMA. #' @author TDemetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export lmerSLMADS.assign <- function(formula, offset, weights, dataName, REML = TRUE, control_type, control_value.transmit, optimizer, verbose=0){ @@ -37,7 +38,8 @@ lmerSLMADS.assign <- function(formula, offset, weights, dataName, REML = TRUE, # Same is done for offset and weights lower down function if(!is.null(dataName)){ - dataDF <- eval(parse(text=dataName), envir = parent.frame()) + dataDF <- .loadServersideObject(dataName) + .checkClass(obj = dataDF, obj_name = dataName, permitted_classes = c("data.frame", "matrix")) }else{ dataDF <- NULL } diff --git a/R/lmerSLMADS2.R b/R/lmerSLMADS2.R index 145f90b9..a60b67c2 100644 --- a/R/lmerSLMADS2.R +++ b/R/lmerSLMADS2.R @@ -27,6 +27,7 @@ #' @param verbose see help for ds.lmerSLMA #' @return all key model components see help for ds.lmerSLMA #' @author Tom Bishop, with some additions by Paul Burton +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export lmerSLMADS2 <- function(formula, offset, weights, dataName, REML = TRUE, control_type, control_value.transmit, optimizer, verbose=0){ @@ -46,7 +47,8 @@ lmerSLMADS2 <- function(formula, offset, weights, dataName, REML = TRUE, # Same is done for offset and weights lower down function if(!is.null(dataName)){ - dataDF <- eval(parse(text=dataName), envir = parent.frame()) + dataDF <- .loadServersideObject(dataName) + .checkClass(obj = dataDF, obj_name = dataName, permitted_classes = c("data.frame", "matrix")) }else{ dataDF <- NULL } diff --git a/man/glmDS1.Rd b/man/glmDS1.Rd index e0b0b332..95ddb710 100644 --- a/man/glmDS1.Rd +++ b/man/glmDS1.Rd @@ -36,4 +36,6 @@ been specified. For more details please see the extensive header for ds.glm. } \author{ Burton PR for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/glmDS2.Rd b/man/glmDS2.Rd index 36731d5f..7edc7007 100644 --- a/man/glmDS2.Rd +++ b/man/glmDS2.Rd @@ -40,4 +40,6 @@ For more details please see the extensive header for ds.glm. } \author{ Paul Burton, for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/glmSLMADS1.Rd b/man/glmSLMADS1.Rd index e08e7076..b8de3fb4 100644 --- a/man/glmSLMADS1.Rd +++ b/man/glmSLMADS1.Rd @@ -37,4 +37,6 @@ For more detailed information see help for ds.glmSLMA. } \author{ Paul Burton for DataSHIELD Development Team (14/7/20) + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/glmSLMADS2.Rd b/man/glmSLMADS2.Rd index d5cfa9b0..3b59bd15 100644 --- a/man/glmSLMADS2.Rd +++ b/man/glmSLMADS2.Rd @@ -43,4 +43,6 @@ For more detailed information see help for ds.glmSLMA. } \author{ Paul Burton for DataSHIELD Development Team (14/7/20) + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/glmerSLMADS.assign.Rd b/man/glmerSLMADS.assign.Rd index 6db1196d..a58f364e 100644 --- a/man/glmerSLMADS.assign.Rd +++ b/man/glmerSLMADS.assign.Rd @@ -67,4 +67,6 @@ from each single data source and saves the regression outcomes on the serverside } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/glmerSLMADS2.Rd b/man/glmerSLMADS2.Rd index aee4d44c..1086da95 100644 --- a/man/glmerSLMADS2.Rd +++ b/man/glmerSLMADS2.Rd @@ -74,4 +74,6 @@ glmes using the glmer engine can be obtained using R help for glmer and the lme4 } \author{ Tom Bishop, with some additions by Paul Burton + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/lmerSLMADS.assign.Rd b/man/lmerSLMADS.assign.Rd index cc2ff9f0..e47edd87 100644 --- a/man/lmerSLMADS.assign.Rd +++ b/man/lmerSLMADS.assign.Rd @@ -52,4 +52,6 @@ effects - on data from each single data source and saves the regression outcomes } \author{ TDemetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/lmerSLMADS2.Rd b/man/lmerSLMADS2.Rd index 98a29e1e..ba1f4260 100644 --- a/man/lmerSLMADS2.Rd +++ b/man/lmerSLMADS2.Rd @@ -61,4 +61,6 @@ the lme4 package } \author{ Tom Bishop, with some additions by Paul Burton + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } From 22b9b095669fb1a6732b22000fa3aea4616adf1b Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 16 Apr 2026 13:14:31 +0200 Subject: [PATCH 05/30] refactor: batch-8 server-side RNG and sampling functions --- R/rBinomDS.R | 6 ++---- R/rNormDS.R | 6 ++---- R/rPoisDS.R | 3 +-- R/rUnifDS.R | 6 ++---- R/sampleDS.R | 4 ++-- R/setSeedDS.R | 6 +++++- tests/testthat/test-smk-rBinomDS.R | 10 ++++++++++ tests/testthat/test-smk-rNormDS.R | 10 ++++++++++ tests/testthat/test-smk-rPoisDS.R | 6 ++++++ tests/testthat/test-smk-rUnifDS.R | 10 ++++++++++ tests/testthat/test-smk-sampleDS.R | 10 ++++++++++ tests/testthat/test-smk-setSeedDS.R | 10 ++++++++++ 12 files changed, 70 insertions(+), 17 deletions(-) diff --git a/R/rBinomDS.R b/R/rBinomDS.R index 22bcbbf3..bc60cf50 100644 --- a/R/rBinomDS.R +++ b/R/rBinomDS.R @@ -34,13 +34,11 @@ rBinomDS<-function (n, size = 1, prob = 0.5){ #first convert their names into the corresponding active vectors if(is.character(size)){ - command.text<-size - size<-eval(parse(text=command.text), envir = parent.frame()) + size<-.loadServersideObject(size) } if(is.character(prob)){ - command.text<-prob - prob<-eval(parse(text=command.text), envir = parent.frame()) + prob<-.loadServersideObject(prob) } stats::rbinom(n, size=size, prob=prob) diff --git a/R/rNormDS.R b/R/rNormDS.R index f50a424e..9184cb24 100644 --- a/R/rNormDS.R +++ b/R/rNormDS.R @@ -39,13 +39,11 @@ rNormDS<-function (n, mean = 0, sd = 1, force.output.to.k.decimal.places=9){ #first convert their names into the corresponding active vectors if(is.character(mean)){ - command.text<-mean - mean<-eval(parse(text=command.text), envir = parent.frame()) + mean<-.loadServersideObject(mean) } if(is.character(sd)){ - command.text<-sd - sd<-eval(parse(text=command.text), envir = parent.frame()) + sd<-.loadServersideObject(sd) } random.number.vector<-stats::rnorm(n, mean=mean, sd=sd) diff --git a/R/rPoisDS.R b/R/rPoisDS.R index 3274078c..9c42292c 100644 --- a/R/rPoisDS.R +++ b/R/rPoisDS.R @@ -30,8 +30,7 @@ rPoisDS<-function (n, lambda = 1){ #first convert its name into the corresponding active vectors if(is.character(lambda)){ - command.text<-lambda - lambda<-eval(parse(text=command.text), envir = parent.frame()) + lambda<-.loadServersideObject(lambda) } stats::rpois(n, lambda=lambda) diff --git a/R/rUnifDS.R b/R/rUnifDS.R index 9f4463c6..5ca52c55 100644 --- a/R/rUnifDS.R +++ b/R/rUnifDS.R @@ -39,13 +39,11 @@ rUnifDS<-function (n, min = 0, max = 1, force.output.to.k.decimal.places=9){ #first convert their names into the corresponding active vectors if(is.character(min)){ - command.text<-min - min<-eval(parse(text=command.text), envir = parent.frame()) + min<-.loadServersideObject(min) } if(is.character(max)){ - command.text<-max - max<-eval(parse(text=command.text), envir = parent.frame()) + max<-.loadServersideObject(max) } random.number.vector<-stats::runif(n, min=min, max=max) diff --git a/R/sampleDS.R b/R/sampleDS.R index 1c5bd43f..ef068916 100644 --- a/R/sampleDS.R +++ b/R/sampleDS.R @@ -82,7 +82,7 @@ sampleDS <- function(x.transmit, size.transmit, replace.transmit=NULL, prob.tran #Activate and if they are character strings if(is.character(x.transmit)) { - x.active<-eval(parse(text=x.transmit), envir = parent.frame()) + x.active<-.loadServersideObject(x.transmit) if(is.data.frame(x.active)||is.matrix(x.active)) { @@ -152,7 +152,7 @@ sampleDS <- function(x.transmit, size.transmit, replace.transmit=NULL, prob.tran prob.active<-NULL if(is.character(prob.transmit)) { - prob.active<-eval(parse(text=prob.transmit), envir = parent.frame()) + prob.active<-.loadServersideObject(prob.transmit) } #Check size <= length(x.active) if replace.transmit==FALSE diff --git a/R/setSeedDS.R b/R/setSeedDS.R index 6515d51a..75dbace3 100644 --- a/R/setSeedDS.R +++ b/R/setSeedDS.R @@ -38,7 +38,11 @@ setSeedDS<-function (seedtext=NULL, kind = NULL, normal.kind = NULL) # Check Permissive Privacy Control Level. dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'avocado')) - seed<-eval(parse(text=seedtext), envir = parent.frame()) + if(is.null(seedtext) || seedtext == "NULL"){ + seed <- NULL + } else { + seed <- as.integer(seedtext) + } set.seed(seed,kind,normal.kind) return(list(seed.as.set=.Random.seed)) } diff --git a/tests/testthat/test-smk-rBinomDS.R b/tests/testthat/test-smk-rBinomDS.R index 9cff07d0..a25d1a5b 100644 --- a/tests/testthat/test-smk-rBinomDS.R +++ b/tests/testthat/test-smk-rBinomDS.R @@ -15,6 +15,8 @@ # context("rBinomDS::smk::setup") +set.standard.disclosure.settings() + # # Tests # @@ -58,6 +60,14 @@ test_that("simple rBinomDS, direct", { expect_true(res[8] >= 0) }) +test_that("rBinomDS fails when size references nonexistent object", { + expect_error(rBinomDS(8, "nonexistent_obj", 0.5), "does not exist") +}) + +test_that("rBinomDS fails when prob references nonexistent object", { + expect_error(rBinomDS(8, 1, "nonexistent_obj"), "does not exist") +}) + # # Done # diff --git a/tests/testthat/test-smk-rNormDS.R b/tests/testthat/test-smk-rNormDS.R index 484ef851..0182aab6 100644 --- a/tests/testthat/test-smk-rNormDS.R +++ b/tests/testthat/test-smk-rNormDS.R @@ -15,6 +15,8 @@ # context("rNormDS::smk::setup") +set.standard.disclosure.settings() + # # Tests # @@ -58,6 +60,14 @@ test_that("simple rNormDS, direct", { expect_true(res[8] >= 0) }) +test_that("rNormDS fails when mean references nonexistent object", { + expect_error(rNormDS(8, "nonexistent_obj", 1, 9), "does not exist") +}) + +test_that("rNormDS fails when sd references nonexistent object", { + expect_error(rNormDS(8, 0, "nonexistent_obj", 9), "does not exist") +}) + # # Done # diff --git a/tests/testthat/test-smk-rPoisDS.R b/tests/testthat/test-smk-rPoisDS.R index c2cf55bf..ee9de700 100644 --- a/tests/testthat/test-smk-rPoisDS.R +++ b/tests/testthat/test-smk-rPoisDS.R @@ -15,6 +15,8 @@ # context("rPoisDS::smk::setup") +set.standard.disclosure.settings() + # # Tests # @@ -56,6 +58,10 @@ test_that("simple rPoisDS, direct", { expect_true(res[8] >= 0) }) +test_that("rPoisDS fails when lambda references nonexistent object", { + expect_error(rPoisDS(8, "nonexistent_obj"), "does not exist") +}) + # # Done # diff --git a/tests/testthat/test-smk-rUnifDS.R b/tests/testthat/test-smk-rUnifDS.R index 87c208c4..7507db16 100644 --- a/tests/testthat/test-smk-rUnifDS.R +++ b/tests/testthat/test-smk-rUnifDS.R @@ -15,6 +15,8 @@ # context("rUnifDS::smk::setup") +set.standard.disclosure.settings() + # # Tests # @@ -58,6 +60,14 @@ test_that("simple rUnifDS, direct", { expect_true(res[8] >= 0) }) +test_that("rUnifDS fails when min references nonexistent object", { + expect_error(rUnifDS(8, "nonexistent_obj", 1, 9), "does not exist") +}) + +test_that("rUnifDS fails when max references nonexistent object", { + expect_error(rUnifDS(8, 0, "nonexistent_obj", 9), "does not exist") +}) + # # Done # diff --git a/tests/testthat/test-smk-sampleDS.R b/tests/testthat/test-smk-sampleDS.R index e3927518..6fb5cdd9 100644 --- a/tests/testthat/test-smk-sampleDS.R +++ b/tests/testthat/test-smk-sampleDS.R @@ -46,6 +46,16 @@ test_that("simple sampleDS", { expect_length(res$sampling.order, 16) }) +test_that("sampleDS fails when x references nonexistent object", { + expect_error(sampleDS("nonexistent_obj", 5, FALSE, NULL), "does not exist") +}) + +test_that("sampleDS fails when prob references nonexistent object", { + x <- c(1:32) + + expect_error(sampleDS("x", 5, FALSE, "nonexistent_obj"), "does not exist") +}) + # # Done # diff --git a/tests/testthat/test-smk-setSeedDS.R b/tests/testthat/test-smk-setSeedDS.R index 0cdbf2e9..0e976bd7 100644 --- a/tests/testthat/test-smk-setSeedDS.R +++ b/tests/testthat/test-smk-setSeedDS.R @@ -15,6 +15,8 @@ # context("setSeedDS::smk::setup") +set.standard.disclosure.settings() + # # Tests # @@ -32,6 +34,14 @@ test_that("simple setSeedDS", { expect_length(res$seed.as.set, 626) }) +test_that("setSeedDS works with numeric string", { + res <- setSeedDS("42", NULL, NULL) + + expect_equal(class(res), "list") + expect_length(res, 1) + expect_length(res$seed.as.set, 626) +}) + # # Done # From 6600043822d69d12020d339496fe3eeb378ff5bb Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 16 Apr 2026 13:26:35 +0200 Subject: [PATCH 06/30] refactor: batch-9 server-side plotting functions --- R/boxPlotGGDS.R | 8 +++++--- R/densityGridDS.R | 13 ++++++++----- R/heatmapPlotDS.R | 9 ++++++--- R/histogramDS1.R | 6 ++++-- R/histogramDS2.R | 6 ++++-- R/scatterPlotDS.R | 11 +++++++---- tests/testthat/test-smk-densityGridDS.R | 11 ++++++++++- 7 files changed, 44 insertions(+), 20 deletions(-) diff --git a/R/boxPlotGGDS.R b/R/boxPlotGGDS.R index 11b6fd90..1cad869f 100644 --- a/R/boxPlotGGDS.R +++ b/R/boxPlotGGDS.R @@ -5,7 +5,7 @@ #' parameters are passed. There are three different cases depending if there are grouping variables. #' The outliers are also removed from the graphical parameters. #' -#' @param data_table \code{data frame} Table that holds the information to be plotted, arranged as: \cr +#' @param data_table.name \code{character} Name of a server-side data frame that holds the information to be plotted, arranged as: \cr #' #' Column 'x': Names on the X axis of the boxplot, aka variables to plot \cr #' Column 'value': Values for that variable (raw data of columns rbinded) \cr @@ -21,8 +21,10 @@ #' #' @export -boxPlotGGDS <- function(data_table, group = NULL, group2 = NULL){ - +boxPlotGGDS <- function(data_table.name, group = NULL, group2 = NULL){ + + data_table <- .loadServersideObject(data_table.name) + ################################################################### # MODULE 1: CAPTURE THE subset filter SETTINGS # thr <- dsBase::listDisclosureSettingsDS() # diff --git a/R/densityGridDS.R b/R/densityGridDS.R index 1569d5c1..2622c90d 100644 --- a/R/densityGridDS.R +++ b/R/densityGridDS.R @@ -3,8 +3,8 @@ #' @description Generates a density grid that can then be used for heatmap or contour plots. #' @details Invalid cells (cells with count < to the set filter value for the minimum allowed #' counts in table cells) are turn to 0. -#' @param xvect a numerical vector -#' @param yvect a numerical vector +#' @param x a character string providing the name of a server-side numerical vector +#' @param y a character string providing the name of a server-side numerical vector #' @param limits a logical expression for whether or not limits of the density grid are defined by #' a user. If \code{limits} is set to "FALSE", min and max of xvect and yvect are used as a range. #' If \code{limits} is set to "TRUE", limits defined by x.min, x.max, y.min and y.max are used. @@ -17,10 +17,13 @@ #' @author Julia Isaeva, Amadou Gaye, Demetris Avraam for DataSHIELD Development Team #' @export #' -densityGridDS <- function(xvect, yvect, limits=FALSE, x.min=NULL, x.max=NULL, y.min=NULL, y.max=NULL, numints=20){ - +densityGridDS <- function(x, y, limits=FALSE, x.min=NULL, x.max=NULL, y.min=NULL, y.max=NULL, numints=20){ + + xvect <- .loadServersideObject(x) + yvect <- .loadServersideObject(y) + ############################################################# - # MODULE 1: CAPTURE THE nfilter SETTINGS + # MODULE 1: CAPTURE THE nfilter SETTINGS thr <- dsBase::listDisclosureSettingsDS() nfilter.tab <- as.numeric(thr$nfilter.tab) #nfilter.glm <- as.numeric(thr$nfilter.glm) diff --git a/R/heatmapPlotDS.R b/R/heatmapPlotDS.R index 349f57b9..629bb6db 100644 --- a/R/heatmapPlotDS.R +++ b/R/heatmapPlotDS.R @@ -9,8 +9,8 @@ #' neighbours and the y-coordinate of the centroid is the average of the y-coordinates of the n nearest #' neighbours. The coordinates of the centroids return to the client side function and can be used for the #' plot of non-disclosive graphs (e.g. scatter plots, heatmap plots, contour plots, etc). -#' @param x the name of a numeric vector, the x-variable. -#' @param y the name of a numeric vector, the y-variable. +#' @param x.name a character string providing the name of a server-side numeric vector, the x-variable. +#' @param y.name a character string providing the name of a server-side numeric vector, the y-variable. #' @param k the number of the nearest neighbours for which their centroid is calculated if the #' \code{method.indicator} is equal to 1 (i.e. deterministic method). #' @param noise the percentage of the initial variance that is used as the variance of the embedded @@ -22,7 +22,10 @@ #' @author Demetris Avraam for DataSHIELD Development Team #' @export #' -heatmapPlotDS <- function(x, y, k, noise, method.indicator){ +heatmapPlotDS <- function(x.name, y.name, k, noise, method.indicator){ + + x <- .loadServersideObject(x.name) + y <- .loadServersideObject(y.name) ################################################################### # MODULE 1: CAPTURE THE nfilter SETTINGS # diff --git a/R/histogramDS1.R b/R/histogramDS1.R index 71ffc439..f9b1a940 100644 --- a/R/histogramDS1.R +++ b/R/histogramDS1.R @@ -7,7 +7,7 @@ #' function returns the minimum and maximum values of the vector with the scaled centroids. If the #' method.indicator is set to 3 (i.e. the 'probabilistic' method is used) the function returns the #' minimum and maximum values of the generated 'noisy' vector. -#' @param xvect the numeric vector for which the histogram is desired. +#' @param x a character string providing the name of the server-side numeric vector for which the histogram is desired. #' @param method.indicator a number equal to either 1, 2 or 3 indicating the method of disclosure #' control that is used for the generation of the histogram. If the value is equal to 1 then the #' 'smallCellsRule' is used. If the value is equal to 2 then the 'deterministic' method is used. @@ -20,7 +20,9 @@ #' @author Amadou Gaye, Demetris Avraam for DataSHIELD Development Team #' @export #' -histogramDS1 <- function(xvect, method.indicator, k, noise){ +histogramDS1 <- function(x, method.indicator, k, noise){ + + xvect <- .loadServersideObject(x) ################################################################## # MODULE 1: CAPTURE THE nfilter SETTINGS # diff --git a/R/histogramDS2.R b/R/histogramDS2.R index 001ab0dd..c753a17b 100644 --- a/R/histogramDS2.R +++ b/R/histogramDS2.R @@ -6,7 +6,7 @@ #' size of a table. If a bin has less counts than this threshold then their counts #' and its density are replaced by a 0 value. #' @details Please find more details in the documentation of the clientside ds.histogram function. -#' @param xvect the numeric vector for which the histogram is desired. +#' @param x a character string providing the name of the server-side numeric vector for which the histogram is desired. #' @param num.breaks the number of breaks that the range of the variable is divided. #' @param min a numeric, the lower limit of the distribution. #' @param max a numeric, the upper limit of the distribution. @@ -22,7 +22,9 @@ #' @author Amadou Gaye, Demetris Avraam for DataSHIELD Development Team #' @export #' -histogramDS2 <- function (xvect, num.breaks, min, max, method.indicator, k, noise){ +histogramDS2 <- function (x, num.breaks, min, max, method.indicator, k, noise){ + + xvect <- .loadServersideObject(x) ################################################################## # MODULE 1: CAPTURE THE nfilter SETTINGS # diff --git a/R/scatterPlotDS.R b/R/scatterPlotDS.R index ab48be10..dcab7fea 100644 --- a/R/scatterPlotDS.R +++ b/R/scatterPlotDS.R @@ -14,8 +14,8 @@ #' and variance equal to 10% of the true variance of $x$ and $y$ respectively. To avoid inferential #' disclosure we fix the random number generator in a value that is specified by the input #' variables. Thus the function returns always the same noisy data for a given pair of variables. -#' @param x the name of a numeric vector, the x-variable. -#' @param y the name of a numeric vector, the y-variable. +#' @param x.name a character string providing the name of a server-side numeric vector, the x-variable. +#' @param y.name a character string providing the name of a server-side numeric vector, the y-variable. #' @param method.indicator an integer either 1 or 2. If the user selects the deterministic #' method in the client side function the method.indicator is set to 1 while if the user selects #' the probabilistic method this argument is set to 2. @@ -27,8 +27,11 @@ #' @author Demetris Avraam for DataSHIELD Development Team #' @export #' -scatterPlotDS <- function(x, y, method.indicator, k, noise){ - +scatterPlotDS <- function(x.name, y.name, method.indicator, k, noise){ + + x <- .loadServersideObject(x.name) + y <- .loadServersideObject(y.name) + ################################################################### # MODULE 1: CAPTURE THE nfilter SETTINGS # thr <- dsBase::listDisclosureSettingsDS() # diff --git a/tests/testthat/test-smk-densityGridDS.R b/tests/testthat/test-smk-densityGridDS.R index 2c075a4b..b0b4f00c 100644 --- a/tests/testthat/test-smk-densityGridDS.R +++ b/tests/testthat/test-smk-densityGridDS.R @@ -36,7 +36,7 @@ test_that("densityGridDS", { y.max <- NULL numints <- 3 - res <- densityGridDS(xvect=xvect, yvect=yvect, limits=FALSE, x.min=NULL, + res <- densityGridDS(x="xvect", y="yvect", limits=FALSE, x.min=NULL, x.max=NULL, y.min=NULL, y.max=NULL, numints=numints) expect_equal(class(res), c("matrix","array")) @@ -50,6 +50,15 @@ test_that("densityGridDS", { }) +test_that("densityGridDS fails when x references nonexistent object", { + expect_error(densityGridDS(x="nonexistent_obj", y="yvect", numints=3), "does not exist") +}) + +test_that("densityGridDS fails when y references nonexistent object", { + yvect <- c(1:20) + expect_error(densityGridDS(x="yvect", y="nonexistent_obj", numints=3), "does not exist") +}) + # # Done # From 1ee564c0e68137c34a6b202b966ecd185d24b727 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 16 Apr 2026 16:43:01 +0200 Subject: [PATCH 07/30] docs: updated authorship --- R/rBinomDS.R | 1 + R/rNormDS.R | 1 + R/rPoisDS.R | 1 + R/rUnifDS.R | 1 + R/sampleDS.R | 1 + R/setSeedDS.R | 1 + 6 files changed, 6 insertions(+) diff --git a/R/rBinomDS.R b/R/rBinomDS.R index bc60cf50..9ec42361 100644 --- a/R/rBinomDS.R +++ b/R/rBinomDS.R @@ -24,6 +24,7 @@ #' also returns a vector reporting the length of the pseudorandom vector #' created in each source. #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export rBinomDS<-function (n, size = 1, prob = 0.5){ diff --git a/R/rNormDS.R b/R/rNormDS.R index 9184cb24..d201143a 100644 --- a/R/rNormDS.R +++ b/R/rNormDS.R @@ -29,6 +29,7 @@ #' also returns a vector reporting the length of the pseudorandom vector #' created in each source. #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export rNormDS<-function (n, mean = 0, sd = 1, force.output.to.k.decimal.places=9){ diff --git a/R/rPoisDS.R b/R/rPoisDS.R index 9c42292c..5bee2148 100644 --- a/R/rPoisDS.R +++ b/R/rPoisDS.R @@ -20,6 +20,7 @@ #' also returns a vector reporting the length of the pseudorandom vector #' created in each source. #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export rPoisDS<-function (n, lambda = 1){ diff --git a/R/rUnifDS.R b/R/rUnifDS.R index 5ca52c55..d20d189f 100644 --- a/R/rUnifDS.R +++ b/R/rUnifDS.R @@ -29,6 +29,7 @@ #' also returns a vector reporting the length of the pseudorandom vector #' created in each source. #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export rUnifDS<-function (n, min = 0, max = 1, force.output.to.k.decimal.places=9){ diff --git a/R/sampleDS.R b/R/sampleDS.R index ef068916..213451dd 100644 --- a/R/sampleDS.R +++ b/R/sampleDS.R @@ -30,6 +30,7 @@ #' 'newobj.sample') which is written to the serverside. For further details see #' help for ds.sample and native R help for sample(). #' @author Paul Burton, for DataSHIELD Development Team, 15/4/2020 +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export sampleDS <- function(x.transmit, size.transmit, replace.transmit=NULL, prob.transmit=NULL){ diff --git a/R/setSeedDS.R b/R/setSeedDS.R index 75dbace3..bead37b7 100644 --- a/R/setSeedDS.R +++ b/R/setSeedDS.R @@ -32,6 +32,7 @@ #' .Random.seed on each data source that is the true current state of the #' random seed in each source. #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export setSeedDS<-function (seedtext=NULL, kind = NULL, normal.kind = NULL) { From ce633041082d1ed2c87bfc74333c90bf6050212b Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 16 Apr 2026 16:44:35 +0200 Subject: [PATCH 08/30] docs: updated authorship --- R/densityGridDS.R | 1 + R/heatmapPlotDS.R | 1 + R/histogramDS1.R | 1 + R/histogramDS2.R | 1 + R/scatterPlotDS.R | 1 + 5 files changed, 5 insertions(+) diff --git a/R/densityGridDS.R b/R/densityGridDS.R index 2622c90d..a41245ac 100644 --- a/R/densityGridDS.R +++ b/R/densityGridDS.R @@ -15,6 +15,7 @@ #' @param numints a number of intervals for the grid density object, by default is 20 #' @return a grid density matrix #' @author Julia Isaeva, Amadou Gaye, Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' densityGridDS <- function(x, y, limits=FALSE, x.min=NULL, x.max=NULL, y.min=NULL, y.max=NULL, numints=20){ diff --git a/R/heatmapPlotDS.R b/R/heatmapPlotDS.R index 629bb6db..951c6755 100644 --- a/R/heatmapPlotDS.R +++ b/R/heatmapPlotDS.R @@ -20,6 +20,7 @@ #' @return a list with the x and y coordinates of the centroids if the deterministic method is used #' or the x and y coordinated of the noisy data if the probabilistic method is used. #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' heatmapPlotDS <- function(x.name, y.name, k, noise, method.indicator){ diff --git a/R/histogramDS1.R b/R/histogramDS1.R index f9b1a940..f99d2449 100644 --- a/R/histogramDS1.R +++ b/R/histogramDS1.R @@ -18,6 +18,7 @@ #' noise if the \code{method.indicator} is equal to 3 (i.e. probabilistic method). #' @return a numeric vector which contains the minimum and the maximum values of the vector #' @author Amadou Gaye, Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' histogramDS1 <- function(x, method.indicator, k, noise){ diff --git a/R/histogramDS2.R b/R/histogramDS2.R index c753a17b..f872d01a 100644 --- a/R/histogramDS2.R +++ b/R/histogramDS2.R @@ -20,6 +20,7 @@ #' noise if the \code{method.indicator} is equal to 3 (i.e. probabilistic method). #' @return a list with an object of class \code{histogram} and the number of invalid cells #' @author Amadou Gaye, Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' histogramDS2 <- function (x, num.breaks, min, max, method.indicator, k, noise){ diff --git a/R/scatterPlotDS.R b/R/scatterPlotDS.R index dcab7fea..60832ecc 100644 --- a/R/scatterPlotDS.R +++ b/R/scatterPlotDS.R @@ -25,6 +25,7 @@ #' noise if the probabilistic method is selected. #' @return a list with the x and y coordinates of the data to be plot #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' scatterPlotDS <- function(x.name, y.name, method.indicator, k, noise){ From 70cf83f924cd067cfb7687d26c2e1a6059db5612 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 16 Apr 2026 16:46:42 +0200 Subject: [PATCH 09/30] docs: redocumented --- man/rBinomDS.Rd | 2 ++ man/rNormDS.Rd | 2 ++ man/rPoisDS.Rd | 2 ++ man/rUnifDS.Rd | 2 ++ man/sampleDS.Rd | 2 ++ man/setSeedDS.Rd | 2 ++ 6 files changed, 12 insertions(+) diff --git a/man/rBinomDS.Rd b/man/rBinomDS.Rd index 9a3fc25e..b8d16755 100644 --- a/man/rBinomDS.Rd +++ b/man/rBinomDS.Rd @@ -42,4 +42,6 @@ the function rbinom() in native R and its arguments are the same. } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/rNormDS.Rd b/man/rNormDS.Rd index ef7ea58d..f4dd1f4f 100644 --- a/man/rNormDS.Rd +++ b/man/rNormDS.Rd @@ -48,4 +48,6 @@ the function rnorm() in native R and its arguments are the same. } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/rPoisDS.Rd b/man/rPoisDS.Rd index 73fcdee0..9d3d2dbe 100644 --- a/man/rPoisDS.Rd +++ b/man/rPoisDS.Rd @@ -37,4 +37,6 @@ and its arguments are the same. } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/rUnifDS.Rd b/man/rUnifDS.Rd index c9b448ea..f3ad01c8 100644 --- a/man/rUnifDS.Rd +++ b/man/rUnifDS.Rd @@ -48,4 +48,6 @@ the function runif() in native R and its arguments are the same. } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/sampleDS.Rd b/man/sampleDS.Rd index c3d2ead7..aae770f8 100644 --- a/man/sampleDS.Rd +++ b/man/sampleDS.Rd @@ -54,4 +54,6 @@ help for ds.sample and native R help for sample(). } \author{ Paul Burton, for DataSHIELD Development Team, 15/4/2020 + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/setSeedDS.Rd b/man/setSeedDS.Rd index 9c8c2740..6531b5f2 100644 --- a/man/setSeedDS.Rd +++ b/man/setSeedDS.Rd @@ -50,4 +50,6 @@ theoretical work with random number generators it is likely that the } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } From 5906be8163f324dba7cf9b8e1286d1b5eac99661 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 16 Apr 2026 16:47:05 +0200 Subject: [PATCH 10/30] docs: redocumented --- man/boxPlotGGDS.Rd | 4 ++-- man/densityGridDS.Rd | 10 ++++++---- man/heatmapPlotDS.Rd | 8 +++++--- man/histogramDS1.Rd | 6 ++++-- man/histogramDS2.Rd | 6 ++++-- man/scatterPlotDS.Rd | 8 +++++--- 6 files changed, 26 insertions(+), 16 deletions(-) diff --git a/man/boxPlotGGDS.Rd b/man/boxPlotGGDS.Rd index 3633b943..03f297a7 100644 --- a/man/boxPlotGGDS.Rd +++ b/man/boxPlotGGDS.Rd @@ -4,10 +4,10 @@ \alias{boxPlotGGDS} \title{Create the identity stats and necessary data to draw a plot on the client} \usage{ -boxPlotGGDS(data_table, group = NULL, group2 = NULL) +boxPlotGGDS(data_table.name, group = NULL, group2 = NULL) } \arguments{ -\item{data_table}{\code{data frame} Table that holds the information to be plotted, arranged as: \cr +\item{data_table.name}{\code{character} Name of a server-side data frame that holds the information to be plotted, arranged as: \cr Column 'x': Names on the X axis of the boxplot, aka variables to plot \cr Column 'value': Values for that variable (raw data of columns rbinded) \cr diff --git a/man/densityGridDS.Rd b/man/densityGridDS.Rd index 2b254acf..55ff7b3e 100644 --- a/man/densityGridDS.Rd +++ b/man/densityGridDS.Rd @@ -5,8 +5,8 @@ \title{Generates a density grid with or without a priori defined limits} \usage{ densityGridDS( - xvect, - yvect, + x, + y, limits = FALSE, x.min = NULL, x.max = NULL, @@ -16,9 +16,9 @@ densityGridDS( ) } \arguments{ -\item{xvect}{a numerical vector} +\item{x}{a character string providing the name of a server-side numerical vector} -\item{yvect}{a numerical vector} +\item{y}{a character string providing the name of a server-side numerical vector} \item{limits}{a logical expression for whether or not limits of the density grid are defined by a user. If \code{limits} is set to "FALSE", min and max of xvect and yvect are used as a range. @@ -46,4 +46,6 @@ counts in table cells) are turn to 0. } \author{ Julia Isaeva, Amadou Gaye, Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/heatmapPlotDS.Rd b/man/heatmapPlotDS.Rd index 950dbace..a8e21840 100644 --- a/man/heatmapPlotDS.Rd +++ b/man/heatmapPlotDS.Rd @@ -4,12 +4,12 @@ \alias{heatmapPlotDS} \title{Calculates the coordinates of the centroid of each n nearest neighbours} \usage{ -heatmapPlotDS(x, y, k, noise, method.indicator) +heatmapPlotDS(x.name, y.name, k, noise, method.indicator) } \arguments{ -\item{x}{the name of a numeric vector, the x-variable.} +\item{x.name}{a character string providing the name of a server-side numeric vector, the x-variable.} -\item{y}{the name of a numeric vector, the y-variable.} +\item{y.name}{a character string providing the name of a server-side numeric vector, the y-variable.} \item{k}{the number of the nearest neighbours for which their centroid is calculated if the \code{method.indicator} is equal to 1 (i.e. deterministic method).} @@ -39,4 +39,6 @@ plot of non-disclosive graphs (e.g. scatter plots, heatmap plots, contour plots, } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/histogramDS1.Rd b/man/histogramDS1.Rd index a8e8a551..ef91faef 100644 --- a/man/histogramDS1.Rd +++ b/man/histogramDS1.Rd @@ -4,10 +4,10 @@ \alias{histogramDS1} \title{returns the minimum and the maximum of the input numeric vector} \usage{ -histogramDS1(xvect, method.indicator, k, noise) +histogramDS1(x, method.indicator, k, noise) } \arguments{ -\item{xvect}{the numeric vector for which the histogram is desired.} +\item{x}{a character string providing the name of the server-side numeric vector for which the histogram is desired.} \item{method.indicator}{a number equal to either 1, 2 or 3 indicating the method of disclosure control that is used for the generation of the histogram. If the value is equal to 1 then the @@ -34,4 +34,6 @@ minimum and maximum values of the generated 'noisy' vector. } \author{ Amadou Gaye, Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/histogramDS2.Rd b/man/histogramDS2.Rd index 76bf8ea3..17ea4261 100644 --- a/man/histogramDS2.Rd +++ b/man/histogramDS2.Rd @@ -4,10 +4,10 @@ \alias{histogramDS2} \title{Computes a histogram of the input variable without plotting.} \usage{ -histogramDS2(xvect, num.breaks, min, max, method.indicator, k, noise) +histogramDS2(x, num.breaks, min, max, method.indicator, k, noise) } \arguments{ -\item{xvect}{the numeric vector for which the histogram is desired.} +\item{x}{a character string providing the name of the server-side numeric vector for which the histogram is desired.} \item{num.breaks}{the number of breaks that the range of the variable is divided.} @@ -41,4 +41,6 @@ Please find more details in the documentation of the clientside ds.histogram fun } \author{ Amadou Gaye, Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/scatterPlotDS.Rd b/man/scatterPlotDS.Rd index 7b2709fd..4f715d2c 100644 --- a/man/scatterPlotDS.Rd +++ b/man/scatterPlotDS.Rd @@ -4,12 +4,12 @@ \alias{scatterPlotDS} \title{Calculates the coordinates of the data to be plot} \usage{ -scatterPlotDS(x, y, method.indicator, k, noise) +scatterPlotDS(x.name, y.name, method.indicator, k, noise) } \arguments{ -\item{x}{the name of a numeric vector, the x-variable.} +\item{x.name}{a character string providing the name of a server-side numeric vector, the x-variable.} -\item{y}{the name of a numeric vector, the y-variable.} +\item{y.name}{a character string providing the name of a server-side numeric vector, the y-variable.} \item{method.indicator}{an integer either 1 or 2. If the user selects the deterministic method in the client side function the method.indicator is set to 1 while if the user selects @@ -44,4 +44,6 @@ variables. Thus the function returns always the same noisy data for a given pair } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } From 8aa7033df194755eaee8799add019f61217f1cc6 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 17 Jul 2026 12:34:10 +0200 Subject: [PATCH 11/30] tidied up PR --- R/matrixDetDS1.R | 35 ++------------------- R/matrixDetDS2.R | 35 ++------------------- man/matrixDetDS1.Rd | 2 ++ man/matrixDetDS2.Rd | 2 ++ tests/testthat/test-smk-matrixDS.R | 10 ------ tests/testthat/test-smk-matrixDetDS1.R | 30 ++++++++++++++++++ tests/testthat/test-smk-matrixDetDS2.R | 29 +++++++++++++++++ tests/testthat/test-smk-matrixDiagDS.R | 10 ------ tests/testthat/test-smk-matrixDimnamesDS.R | 10 ------ tests/testthat/test-smk-matrixInvertDS.R | 10 ------ tests/testthat/test-smk-matrixMultDS.R | 10 ------ tests/testthat/test-smk-matrixTransposeDS.R | 10 ------ 12 files changed, 69 insertions(+), 124 deletions(-) create mode 100644 tests/testthat/test-smk-matrixDetDS1.R create mode 100644 tests/testthat/test-smk-matrixDetDS2.R diff --git a/R/matrixDetDS1.R b/R/matrixDetDS1.R index e6c3403c..b0d2d6c6 100644 --- a/R/matrixDetDS1.R +++ b/R/matrixDetDS1.R @@ -11,42 +11,13 @@ #' @return Output is the determinant of the matrix identified by argument #' which is returned to the clientside. For more details see help for ds.matrixDet #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export matrixDetDS1 <- function(M1.name=NULL,logarithm){ -######################################################################### -# DataSHIELD MODULE: CAPTURE THE nfilter SETTINGS # -thr<-dsBase::listDisclosureSettingsDS() # -#nfilter.tab<-as.numeric(thr$nfilter.tab) # -#nfilter.glm<-as.numeric(thr$nfilter.glm) # -#nfilter.subset<-as.numeric(thr$nfilter.subset) # -#nfilter.string<-as.numeric(thr$nfilter.string) # -nfilter.stringShort<-as.numeric(thr$nfilter.stringShort) # -#nfilter.kNN<-as.numeric(thr$nfilter.kNN) # -#datashield.privacyLevel<-as.numeric(thr$datashield.privacyLevel) # -######################################################################### - -#Check length of M1.name not so long as to provide a risk of hidden code -length.M1.name<-length(unlist(strsplit(M1.name,''))) - -if(length.M1.name>nfilter.stringShort) - { - error.message<- - paste0("FAILED: M1.name is too long it could hide concealed code, please shorten to <= nfilter.stringShort = ", - nfilter.stringShort," characters") - stop(error.message, call. = FALSE) - } - -#EVAL M1 - -M1<-eval(parse(text=M1.name), envir = parent.frame()) - -if(!is.matrix(M1)&&!is.data.frame(M1)) - { - error.message<-"FAILED: M1 must be of class matrix or data.frame, please respecify" - stop(error.message, call. = FALSE) - } +M1 <- .loadServersideObject(M1.name) +.checkClass(obj = M1, obj_name = M1.name, permitted_classes = c("matrix", "data.frame")) #coerce to matrix if a data.frame if(is.data.frame(M1)) diff --git a/R/matrixDetDS2.R b/R/matrixDetDS2.R index a4355ab7..6e15e7d8 100644 --- a/R/matrixDetDS2.R +++ b/R/matrixDetDS2.R @@ -11,42 +11,13 @@ #' @return Output is the determinant of the matrix identified by argument #' which is written to the serverside. For more details see help for ds.matrixDet #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export matrixDetDS2 <- function(M1.name=NULL,logarithm){ -######################################################################### -# DataSHIELD MODULE: CAPTURE THE nfilter SETTINGS # -thr<-dsBase::listDisclosureSettingsDS() # -#nfilter.tab<-as.numeric(thr$nfilter.tab) # -#nfilter.glm<-as.numeric(thr$nfilter.glm) # -#nfilter.subset<-as.numeric(thr$nfilter.subset) # -#nfilter.string<-as.numeric(thr$nfilter.string) # -nfilter.stringShort<-as.numeric(thr$nfilter.stringShort) # -#nfilter.kNN<-as.numeric(thr$nfilter.kNN) # -#datashield.privacyLevel<-as.numeric(thr$datashield.privacyLevel) # -######################################################################### - -#Check length of M1.name not so long as to provide a risk of hidden code -length.M1.name<-length(unlist(strsplit(M1.name,''))) - -if(length.M1.name>nfilter.stringShort) - { - studysideMessage<- - paste0("FAILED: M1.name is too long it could hide concealed code, please shorten to <= nfilter.stringShort = ", - nfilter.stringShort," characters") - stop(studysideMessage, call. = FALSE) - } - -#EVAL M1 - -M1<-eval(parse(text=M1.name), envir = parent.frame()) - -if(!is.matrix(M1)&&!is.data.frame(M1)) - { - studysideMessage<-"FAILED: M1 must be of class matrix or data.frame, please respecify" - stop(studysideMessage, call. = FALSE) - } +M1 <- .loadServersideObject(M1.name) +.checkClass(obj = M1, obj_name = M1.name, permitted_classes = c("matrix", "data.frame")) #coerce to matrix if a data.frame if(is.data.frame(M1)) diff --git a/man/matrixDetDS1.Rd b/man/matrixDetDS1.Rd index ab20b8f9..5a97372e 100644 --- a/man/matrixDetDS1.Rd +++ b/man/matrixDetDS1.Rd @@ -28,4 +28,6 @@ possible if the number of columns and rows of A are the same. } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/matrixDetDS2.Rd b/man/matrixDetDS2.Rd index b238a3d9..97fd5b94 100644 --- a/man/matrixDetDS2.Rd +++ b/man/matrixDetDS2.Rd @@ -28,4 +28,6 @@ possible if the number of columns and rows of A are the same. } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/tests/testthat/test-smk-matrixDS.R b/tests/testthat/test-smk-matrixDS.R index ba2b397e..f986555b 100644 --- a/tests/testthat/test-smk-matrixDS.R +++ b/tests/testthat/test-smk-matrixDS.R @@ -1,13 +1,3 @@ -#------------------------------------------------------------------------------- -# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. -# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. -# -# This program and the accompanying materials -# are made available under the terms of the GNU Public License v3.0. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- # # Set up diff --git a/tests/testthat/test-smk-matrixDetDS1.R b/tests/testthat/test-smk-matrixDetDS1.R new file mode 100644 index 00000000..1f2624ca --- /dev/null +++ b/tests/testthat/test-smk-matrixDetDS1.R @@ -0,0 +1,30 @@ + +# +# Set up +# + +# context("matrixDetDS1::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +test_that("simple matrixDetDS1", { + M1 <- matrix(c(1, 2, 3, 4), 2, 2) + + res <- matrixDetDS1("M1", logarithm=FALSE) + + expect_true(is.list(res)) + expect_equal(res$matrix.determinant, determinant(M1, logarithm=FALSE)) +}) + +test_that("matrixDetDS1 errors when serverside object does not exist", { + expect_error(matrixDetDS1("nonexistent_object", logarithm=FALSE), regexp = "does not exist") +}) + +test_that("matrixDetDS1 errors when input is wrong type", { + bad_input <- c("a", "b", "c") + expect_error(matrixDetDS1("bad_input", logarithm=FALSE), regexp = "must be of type") +}) diff --git a/tests/testthat/test-smk-matrixDetDS2.R b/tests/testthat/test-smk-matrixDetDS2.R new file mode 100644 index 00000000..bf20a3a9 --- /dev/null +++ b/tests/testthat/test-smk-matrixDetDS2.R @@ -0,0 +1,29 @@ + +# +# Set up +# + +# context("matrixDetDS2::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +test_that("simple matrixDetDS2", { + M1 <- matrix(c(1, 2, 3, 4), 2, 2) + + res <- matrixDetDS2("M1", logarithm=FALSE) + + expect_equal(res, determinant(M1, logarithm=FALSE)) +}) + +test_that("matrixDetDS2 errors when serverside object does not exist", { + expect_error(matrixDetDS2("nonexistent_object", logarithm=FALSE), regexp = "does not exist") +}) + +test_that("matrixDetDS2 errors when input is wrong type", { + bad_input <- c("a", "b", "c") + expect_error(matrixDetDS2("bad_input", logarithm=FALSE), regexp = "must be of type") +}) diff --git a/tests/testthat/test-smk-matrixDiagDS.R b/tests/testthat/test-smk-matrixDiagDS.R index cee4ba46..7c99fbd7 100644 --- a/tests/testthat/test-smk-matrixDiagDS.R +++ b/tests/testthat/test-smk-matrixDiagDS.R @@ -1,13 +1,3 @@ -#------------------------------------------------------------------------------- -# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. -# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. -# -# This program and the accompanying materials -# are made available under the terms of the GNU Public License v3.0. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- # # Set up diff --git a/tests/testthat/test-smk-matrixDimnamesDS.R b/tests/testthat/test-smk-matrixDimnamesDS.R index b8dd59b8..c82427ac 100644 --- a/tests/testthat/test-smk-matrixDimnamesDS.R +++ b/tests/testthat/test-smk-matrixDimnamesDS.R @@ -1,13 +1,3 @@ -#------------------------------------------------------------------------------- -# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. -# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. -# -# This program and the accompanying materials -# are made available under the terms of the GNU Public License v3.0. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- # # Set up diff --git a/tests/testthat/test-smk-matrixInvertDS.R b/tests/testthat/test-smk-matrixInvertDS.R index 514a39c7..4d9f5ec8 100644 --- a/tests/testthat/test-smk-matrixInvertDS.R +++ b/tests/testthat/test-smk-matrixInvertDS.R @@ -1,13 +1,3 @@ -#------------------------------------------------------------------------------- -# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. -# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. -# -# This program and the accompanying materials -# are made available under the terms of the GNU Public License v3.0. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- # # Set up diff --git a/tests/testthat/test-smk-matrixMultDS.R b/tests/testthat/test-smk-matrixMultDS.R index 392daf74..19eb58a1 100644 --- a/tests/testthat/test-smk-matrixMultDS.R +++ b/tests/testthat/test-smk-matrixMultDS.R @@ -1,13 +1,3 @@ -#------------------------------------------------------------------------------- -# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. -# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. -# -# This program and the accompanying materials -# are made available under the terms of the GNU Public License v3.0. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- # # Set up diff --git a/tests/testthat/test-smk-matrixTransposeDS.R b/tests/testthat/test-smk-matrixTransposeDS.R index 50d41a1a..c66d1366 100644 --- a/tests/testthat/test-smk-matrixTransposeDS.R +++ b/tests/testthat/test-smk-matrixTransposeDS.R @@ -1,13 +1,3 @@ -#------------------------------------------------------------------------------- -# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. -# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. -# -# This program and the accompanying materials -# are made available under the terms of the GNU Public License v3.0. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- # # Set up From 598e7c6c6bbd77d426b09cb9fd75c14f0b4da974 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 17 Jul 2026 12:36:05 +0200 Subject: [PATCH 12/30] added stuart as author --- man/dsBase-package.Rd | 1 + 1 file changed, 1 insertion(+) diff --git a/man/dsBase-package.Rd b/man/dsBase-package.Rd index 725c4131..be7f5744 100644 --- a/man/dsBase-package.Rd +++ b/man/dsBase-package.Rd @@ -13,6 +13,7 @@ Base 'DataSHIELD' functions for the server side. 'DataSHIELD' is a software pack Authors: \itemize{ + \item Stuart Wheater \email{stuart.wheater@arjuna.com} (\href{https://orcid.org/0009-0003-2419-1964}{ORCID}) \item Paul Burton (\href{https://orcid.org/0000-0001-5799-9634}{ORCID}) \item Rebecca Wilson (\href{https://orcid.org/0000-0003-2294-593X}{ORCID}) \item Olly Butters (\href{https://orcid.org/0000-0003-0354-8461}{ORCID}) From 7df33f49ce82cf65b7b3906bca5d35e874e64501 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 17 Jul 2026 16:02:12 +0200 Subject: [PATCH 13/30] restored lost test coverage --- tests/testthat/test-smk-asFactorDS2.R | 14 ++++++++++++- tests/testthat/test-smk-asFactorSimpleDS.R | 2 +- tests/testthat/test-smk-changeRefGroupDS.R | 15 ++++++++++++-- tests/testthat/test-smk-dmtC2SDS.R | 10 ---------- tests/testthat/test-smk-reShapeDS.R | 23 ++++++++++++---------- 5 files changed, 40 insertions(+), 24 deletions(-) diff --git a/tests/testthat/test-smk-asFactorDS2.R b/tests/testthat/test-smk-asFactorDS2.R index 1e842328..d9f2ae83 100644 --- a/tests/testthat/test-smk-asFactorDS2.R +++ b/tests/testthat/test-smk-asFactorDS2.R @@ -1,6 +1,5 @@ #------------------------------------------------------------------------------- # Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. -# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. # # This program and the accompanying materials # are made available under the terms of the GNU Public License v3.0. @@ -31,6 +30,19 @@ test_that("simple asFactorDS2", { expect_equal(levels(res), c("1", "2", "3", "4")) }) +test_that("asFactorDS2 with fixed dummy variables", { + input <- c(2, 1, 3, 3, 3, 1, 2, 2, 1, 2) + + res <- asFactorDS2("input", "1,2,3,4", TRUE, 1) + + expect_true(is.matrix(res)) + expect_equal(dim(res), c(10L, 3L)) + expect_equal(colnames(res), c("DV2", "DV3", "DV4")) + expect_equal(unname(res[, "DV2"]), c(1, 0, 0, 0, 0, 0, 1, 1, 0, 1)) + expect_equal(unname(res[, "DV3"]), c(0, 0, 1, 1, 1, 0, 0, 0, 0, 0)) + expect_equal(unname(res[, "DV4"]), rep(0, 10)) +}) + test_that("asFactorDS2 errors when serverside object does not exist", { expect_error(asFactorDS2("nonexistent_object", "1,2", FALSE, NULL), regexp = "does not exist") }) diff --git a/tests/testthat/test-smk-asFactorSimpleDS.R b/tests/testthat/test-smk-asFactorSimpleDS.R index a12df35b..97a3e36f 100644 --- a/tests/testthat/test-smk-asFactorSimpleDS.R +++ b/tests/testthat/test-smk-asFactorSimpleDS.R @@ -1,6 +1,5 @@ #------------------------------------------------------------------------------- # Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. -# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. # # This program and the accompanying materials # are made available under the terms of the GNU Public License v3.0. @@ -29,6 +28,7 @@ test_that("simple asFactorSimpleDS", { expect_equal(class(res), "factor") expect_length(res, 10) expect_equal(levels(res), c("1", "2", "3")) + expect_equal(as.character(res), as.character(input)) }) test_that("asFactorSimpleDS errors when serverside object does not exist", { diff --git a/tests/testthat/test-smk-changeRefGroupDS.R b/tests/testthat/test-smk-changeRefGroupDS.R index e6a8a4c0..3a3283ad 100644 --- a/tests/testthat/test-smk-changeRefGroupDS.R +++ b/tests/testthat/test-smk-changeRefGroupDS.R @@ -1,6 +1,5 @@ #------------------------------------------------------------------------------- # Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. -# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. # # This program and the accompanying materials # are made available under the terms of the GNU Public License v3.0. @@ -28,7 +27,19 @@ test_that("simple changeRefGroupDS", { expect_equal(class(res), "factor") expect_length(res, 8) - expect_equal(levels(res)[1], "2") + expect_equal(levels(res), c("2", "1", "4", "6", "8")) + expect_equal(as.character(res), c("8", "1", "6", "1", "4", "1", "2", "1")) +}) + +test_that("changeRefGroupDS with reorderByRef", { + xf <- as.factor(c(8, 1, 6, 1, 4, 1, 2, 1)) + + res <- changeRefGroupDS("xf", ref = 2, reorderByRef = TRUE) + + expect_equal(class(res), "factor") + expect_length(res, 8) + expect_equal(levels(res), c("2", "1", "4", "6", "8")) + expect_equal(as.character(res), c("2", "8", "1", "6", "1", "4", "1", "1")) }) test_that("changeRefGroupDS errors when serverside object does not exist", { diff --git a/tests/testthat/test-smk-dmtC2SDS.R b/tests/testthat/test-smk-dmtC2SDS.R index c3f30f7d..8021bae1 100644 --- a/tests/testthat/test-smk-dmtC2SDS.R +++ b/tests/testthat/test-smk-dmtC2SDS.R @@ -1,13 +1,3 @@ -#------------------------------------------------------------------------------- -# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. -# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. -# -# This program and the accompanying materials -# are made available under the terms of the GNU Public License v3.0. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- # # Set up diff --git a/tests/testthat/test-smk-reShapeDS.R b/tests/testthat/test-smk-reShapeDS.R index ffb1091f..c75d78db 100644 --- a/tests/testthat/test-smk-reShapeDS.R +++ b/tests/testthat/test-smk-reShapeDS.R @@ -1,13 +1,3 @@ -#------------------------------------------------------------------------------- -# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. -# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. -# -# This program and the accompanying materials -# are made available under the terms of the GNU Public License v3.0. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- # # Set up @@ -44,3 +34,16 @@ test_that("simple reShapeDS wide to long", { expect_true("sbp" %in% colnames(res)) expect_true("time" %in% colnames(res)) }) + +test_that("reShapeDS errors when serverside object does not exist", { + expect_error(reShapeDS( + data.name = "nonexistent_object", + varying.transmit = "sbp.1,sbp.2", + v.names.transmit = "sbp", + timevar.name = "time", + idvar.name = "id", + drop.transmit = NULL, + direction = "long", + sep = "." + ), regexp = "does not exist") +}) From 55bed4e7fedde9d897f8190c4d29920a39700f3e Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 17 Jul 2026 16:02:31 +0200 Subject: [PATCH 14/30] fixed mistaken copywright addition --- R/changeRefGroupDS.R | 2 +- R/reShapeDS.R | 3 --- man/changeRefGroupDS.Rd | 2 +- man/reShapeDS.Rd | 3 --- 4 files changed, 2 insertions(+), 8 deletions(-) diff --git a/R/changeRefGroupDS.R b/R/changeRefGroupDS.R index 6b1aae3a..4be99bf7 100644 --- a/R/changeRefGroupDS.R +++ b/R/changeRefGroupDS.R @@ -11,7 +11,7 @@ #' @param ref a character, the reference level #' @param reorderByRef a boolean that tells whether or not the new #' vector should be ordered by the reference group. -#' @return a factor of the same length as xvect +#' @return a factor of the same length as the input vector #' @author Isaeva, J., Gaye, A. #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export diff --git a/R/reShapeDS.R b/R/reShapeDS.R index 524a346d..64acb279 100644 --- a/R/reShapeDS.R +++ b/R/reShapeDS.R @@ -35,9 +35,6 @@ #' @return a reshaped data.frame converted from long to wide format or from wide to #' long format which is written to the serverside and given the name provided as the #' argument of \code{ds.reShape} or 'newObject' if no name is specified. -#' In addition, two validity messages are returned to the clientside -#' indicating whether has been created in each data source and if so whether -#' it is in a valid form (see header for \code{ds.reShape}. #' @author Demetris Avraam, Paul Burton for DataSHIELD Development Team #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export diff --git a/man/changeRefGroupDS.Rd b/man/changeRefGroupDS.Rd index b48be075..7183edc9 100644 --- a/man/changeRefGroupDS.Rd +++ b/man/changeRefGroupDS.Rd @@ -15,7 +15,7 @@ changeRefGroupDS(x, ref = NULL, reorderByRef = NULL) vector should be ordered by the reference group.} } \value{ -a factor of the same length as xvect +a factor of the same length as the input vector } \description{ This function is similar to R function \code{relevel}, diff --git a/man/reShapeDS.Rd b/man/reShapeDS.Rd index 70515104..d61b9f54 100644 --- a/man/reShapeDS.Rd +++ b/man/reShapeDS.Rd @@ -54,9 +54,6 @@ via argument of \code{ds.reShape} function} a reshaped data.frame converted from long to wide format or from wide to long format which is written to the serverside and given the name provided as the argument of \code{ds.reShape} or 'newObject' if no name is specified. -In addition, two validity messages are returned to the clientside -indicating whether has been created in each data source and if so whether -it is in a valid form (see header for \code{ds.reShape}. } \description{ Reshapes a data frame containing longitudinal or From 7cb57fca3e62943efce65af6a6c1a49750289b8b Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 23 Jul 2026 17:26:53 +0200 Subject: [PATCH 15/30] add disclosure check for matrix assign function --- R/matrixDetDS1.R | 11 +++++++++++ tests/testthat/test-smk-matrixDetDS1.R | 22 +++++++++++++++++----- 2 files changed, 28 insertions(+), 5 deletions(-) diff --git a/R/matrixDetDS1.R b/R/matrixDetDS1.R index b0d2d6c6..b6fb40ce 100644 --- a/R/matrixDetDS1.R +++ b/R/matrixDetDS1.R @@ -16,6 +16,11 @@ matrixDetDS1 <- function(M1.name=NULL,logarithm){ +dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'avocado', 'banana')) + +thr <- dsBase::listDisclosureSettingsDS() +nfilter.subset <- as.numeric(thr$nfilter.subset) + M1 <- .loadServersideObject(M1.name) .checkClass(obj = M1, obj_name = M1.name, permitted_classes = c("matrix", "data.frame")) @@ -33,6 +38,12 @@ if(ncol(M1)!=nrow(M1)) stop(error.message, call. = FALSE) } +#Check matrix large enough to reduce disclosure risk +if(nrow(M1) Date: Thu, 23 Jul 2026 17:27:56 +0200 Subject: [PATCH 16/30] revert: add back in list check --- tests/testthat/test-smk-matrixDetDS1.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tests/testthat/test-smk-matrixDetDS1.R b/tests/testthat/test-smk-matrixDetDS1.R index efb72eb3..37d39ac2 100644 --- a/tests/testthat/test-smk-matrixDetDS1.R +++ b/tests/testthat/test-smk-matrixDetDS1.R @@ -14,6 +14,8 @@ set.standard.disclosure.settings() test_that("simple matrixDetDS1 passes with matrix of sufficient dimensions", { M1 <- matrix(c(1, 2, 3, 4, 5, 6, 7, 8, 10), 3, 3) res <- matrixDetDS1("M1", logarithm=FALSE) + + expect_true(is.list(res)) expect_equal(res$matrix.determinant, determinant(M1, logarithm=FALSE)) }) From 7b55676e3a7944b5e23fe054560cda9ca377d719 Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Mon, 31 Aug 2026 11:39:34 +0100 Subject: [PATCH 17/30] Integrate new approach to R package deployment, but Tim Cadman --- azure-pipelines.yml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/azure-pipelines.yml b/azure-pipelines.yml index 7eb3e47e..a55c2eb8 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -122,6 +122,12 @@ jobs: sudo R -e "install.packages('data.table', dependencies=TRUE)" sudo R -e "install.packages('childsds', dependencies=TRUE)" + # Use Posit Public Package Manager, which serves precompiled binary packages + # for this Ubuntu release instead of source - so dependencies are downloaded + # rather than compiled (the slow part). The HTTPUserAgent option is what makes + # the manager hand back binaries. + sudo R -q -e "options(repos=c(CRAN=paste0('https://packagemanager.posit.co/cran/__linux__/', system('lsb_release -cs', intern=TRUE), '/latest')), HTTPUserAgent=sprintf('R/%s R (%s)', getRversion(), paste(getRversion(), R.version\$platform, R.version\$arch, R.version\$os)), Ncpus=4); install.packages(c('devtools','RANN','stringr','lme4','dplyr','reshape2','polycor','splines','gamlss','gamlss.dist','mice','data.table','childsds'), dependencies=TRUE)" + displayName: 'Install all dependencies for dsBase' condition: succeeded() From 3ec93985ceab8f4644c41bd9f718748c9b82c254 Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Mon, 31 Aug 2026 11:39:34 +0100 Subject: [PATCH 18/30] Integrate new approach to R package deployment, by Tim Cadman --- azure-pipelines.yml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/azure-pipelines.yml b/azure-pipelines.yml index 7eb3e47e..a55c2eb8 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -122,6 +122,12 @@ jobs: sudo R -e "install.packages('data.table', dependencies=TRUE)" sudo R -e "install.packages('childsds', dependencies=TRUE)" + # Use Posit Public Package Manager, which serves precompiled binary packages + # for this Ubuntu release instead of source - so dependencies are downloaded + # rather than compiled (the slow part). The HTTPUserAgent option is what makes + # the manager hand back binaries. + sudo R -q -e "options(repos=c(CRAN=paste0('https://packagemanager.posit.co/cran/__linux__/', system('lsb_release -cs', intern=TRUE), '/latest')), HTTPUserAgent=sprintf('R/%s R (%s)', getRversion(), paste(getRversion(), R.version\$platform, R.version\$arch, R.version\$os)), Ncpus=4); install.packages(c('devtools','RANN','stringr','lme4','dplyr','reshape2','polycor','splines','gamlss','gamlss.dist','mice','data.table','childsds'), dependencies=TRUE)" + displayName: 'Install all dependencies for dsBase' condition: succeeded() From 662e933f8cf58ab2f41241eb0c0a5b495475fdcb Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Mon, 31 Aug 2026 13:33:42 +0100 Subject: [PATCH 19/30] Remove old package installation --- azure-pipelines.yml | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/azure-pipelines.yml b/azure-pipelines.yml index a55c2eb8..94c767e9 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -108,19 +108,6 @@ jobs: sudo apt-get install -qq libxml2-dev libcurl4-openssl-dev libssl-dev libgit2-dev libharfbuzz-dev libfribidi-dev libfontconfig1-dev -y sudo apt-get install -qq libfreetype6-dev libpng-dev libtiff5-dev libjpeg-dev libuv1-dev -y sudo apt-get install -qq r-base -y - sudo R -e "install.packages('devtools', dependencies=TRUE)" - sudo R -e "install.packages('RANN', dependencies=TRUE)" - sudo R -e "install.packages('stringr', dependencies=TRUE)" - sudo R -e "install.packages('lme4', dependencies=TRUE)" - sudo R -e "install.packages('dplyr', dependencies=TRUE)" - sudo R -e "install.packages('reshape2', dependencies=TRUE)" - sudo R -e "install.packages('polycor', dependencies=TRUE)" - sudo R -e "install.packages('splines', dependencies=TRUE)" - sudo R -e "install.packages('gamlss', dependencies=TRUE)" - sudo R -e "install.packages('gamlss.dist', dependencies=TRUE)" - sudo R -e "install.packages('mice', dependencies=TRUE)" - sudo R -e "install.packages('data.table', dependencies=TRUE)" - sudo R -e "install.packages('childsds', dependencies=TRUE)" # Use Posit Public Package Manager, which serves precompiled binary packages # for this Ubuntu release instead of source - so dependencies are downloaded From 2c8dc02368b44616c822f3b412916c296b32b1ba Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Thu, 3 Sep 2026 12:59:18 +0100 Subject: [PATCH 20/30] Upgrade to Roxygen 8.1.0 --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index aa62b700..cadb5399 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -79,7 +79,7 @@ Imports: Suggests: spelling, testthat (>= 3.0.0) -RoxygenNote: 8.0.0 +RoxygenNote: 8.1.0 Encoding: UTF-8 Language: en-GB Config/testthat/edition: 3 From d8f56e3f4d328ee33eb314d6488809fe77dc9be2 Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Thu, 3 Sep 2026 13:18:08 +0100 Subject: [PATCH 21/30] Updates to DESCRIPTION and NAMESPACE --- DESCRIPTION | 2 +- NAMESPACE | 36 +++++++++++++++++++++++------------- 2 files changed, 24 insertions(+), 14 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index cadb5399..d733e042 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -79,7 +79,7 @@ Imports: Suggests: spelling, testthat (>= 3.0.0) -RoxygenNote: 8.1.0 Encoding: UTF-8 Language: en-GB Config/testthat/edition: 3 +Config/roxygen2/version: 8.1.0 diff --git a/NAMESPACE b/NAMESPACE index e4fd38c9..4bf3dc67 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -146,17 +146,27 @@ import(dplyr) import(gamlss) import(gamlss.dist) import(mice) -importFrom(dplyr,"%>%") -importFrom(dplyr,across) -importFrom(dplyr,mutate) -importFrom(dplyr,select) -importFrom(gamlss.dist,pST3) -importFrom(gamlss.dist,qST3) -importFrom(glue,glue) -importFrom(glue,glue_collapse) -importFrom(purrr,imap) -importFrom(purrr,map) -importFrom(purrr,set_names) +importFrom(dplyr, + "%>%", + across, + mutate, + select +) +importFrom(gamlss.dist, + pST3, + qST3 +) +importFrom(glue, + glue, + glue_collapse +) +importFrom(purrr, + imap, + map, + set_names +) importFrom(tibble,as_tibble) -importFrom(tidyselect,all_of) -importFrom(tidyselect,peek_vars) +importFrom(tidyselect, + all_of, + peek_vars +) From 21e925248dce9aec5dda134bf14674d9bf009cb7 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Tue, 8 Sep 2026 11:28:20 +0200 Subject: [PATCH 22/30] added missing unit test coverage --- tests/testthat/Rplots.pdf | Bin 0 -> 5562 bytes tests/testthat/test-smk-glmDS1.R | 63 +++++++++++++ tests/testthat/test-smk-glmDS2.R | 68 ++++++++++++++ tests/testthat/test-smk-glmPredictDS.ag.R | 61 +++++++++++++ tests/testthat/test-smk-glmPredictDS.as.R | 51 +++++++++++ tests/testthat/test-smk-glmSLMADS1.R | 63 +++++++++++++ tests/testthat/test-smk-glmSLMADS2.R | 68 ++++++++++++++ tests/testthat/test-smk-glmSummaryDS.ag.R | 58 ++++++++++++ tests/testthat/test-smk-glmSummaryDS.as.R | 51 +++++++++++ tests/testthat/test-smk-glmerSLMADS.assign.R | 65 +++++++++++++ tests/testthat/test-smk-glmerSLMADS2.R | 69 ++++++++++++++ tests/testthat/test-smk-lmerSLMADS.assign.R | 91 +++++++++++++++++++ tests/testthat/test-smk-lmerSLMADS2.R | 68 ++++++++++++++ 13 files changed, 776 insertions(+) create mode 100644 tests/testthat/Rplots.pdf create mode 100644 tests/testthat/test-smk-glmDS1.R create mode 100644 tests/testthat/test-smk-glmDS2.R create mode 100644 tests/testthat/test-smk-glmPredictDS.ag.R create mode 100644 tests/testthat/test-smk-glmPredictDS.as.R create mode 100644 tests/testthat/test-smk-glmSLMADS1.R create mode 100644 tests/testthat/test-smk-glmSLMADS2.R create mode 100644 tests/testthat/test-smk-glmSummaryDS.ag.R create mode 100644 tests/testthat/test-smk-glmSummaryDS.as.R create mode 100644 tests/testthat/test-smk-glmerSLMADS.assign.R create mode 100644 tests/testthat/test-smk-glmerSLMADS2.R create mode 100644 tests/testthat/test-smk-lmerSLMADS.assign.R create mode 100644 tests/testthat/test-smk-lmerSLMADS2.R diff --git a/tests/testthat/Rplots.pdf b/tests/testthat/Rplots.pdf new file mode 100644 index 0000000000000000000000000000000000000000..ac3ab89f20cb92e29bf35287fb79c19aa27ae11c GIT binary patch literal 5562 zcmb7Ic{tSj+ZIKp#hyeAp|Osc7$jxig|RbajKOFYX34&<*$$Phtl2q|kS(OFS;k(Z zY#l_A2vPaXIH&VF%lp39_0Dz8AD{dCET8W)*ERQZ-(sd(Ix-Mhd4O2xTNZGYbqE zOUr@-b%{t%cMOUIG@+0^DP&rjDUskpL7|ECr}DD$vQQd!(2GEaBmkE$1JHOE`YoV; z-UbM^@byFk!J0@i5=(Fcf=!WbXcF)OEdUPuZ-U~#66kUCXd)U<{v#Z$Nx+k7M-ou! zARP=xlL!2P zGs6LVGAq&zf8kMNkKEq2_F+91UycaEsq2dtuyg3VV5}0keONx8Tm0Sn8fi+_`{h}` zdT(*tK@!_XkJmZ9U1P?pk>|GCz6be42AdFqzO82X|JY>@INCO`va$$XZxw53JxO@m zI1_X^$v-q$=;SDW{TiG0lf%~cdA)?POgH3zOCePf-Uvy$QT^_T?t)eVQ;H68`9HYM zl=4_zjQT|3^ss!4gwG4wxu|U@_oZ?=GgbD^P}9A$I*Mx#*i2f{49zMR?_21Rj_N6D!gKDkZvL7=^@1zlWK*y!CRHS*X0T@xmg3u zH;&(ka@dn**i>@a6f`lPfTx~5pT|720AYgNG_kT2p#OV{QnuKd} zq-M>8o(_;6wf;I%xYy%gUzb?xjhJ=aFFF&(rHrK22z58C%02YlK zE}}5O319 zL5}os9)aYP`SE1#oL1Vy{1i8qr`Ql-O~cE&Ql^<&+{Xvu0Wr+LMjTq##3?~FtB}Ps zY7PE6WNTiffR&pe$)mQIfE!~lp2B%?_SY{YxW_Sta*90@mtmG*XNlwXm#96fn(W+k zOZ^4+FYMD5Eb!HP`mh3lssd(-=aM(QYeY~+R>R76$ z@is@UiJ{w*N*V)$2DM9$nHHhKS6NEjLjZAmmWjj^vCUyj;axcoLmoFvn8mr{;l?sN z{^@y=hg71xYv3uX<_prCI}6>l=60oXAI{B}hiykYmx}1aUk@3`%ZekD$t`!KFlp|Z5?sqgn~=98M7=cBT{RBESV;<|gB<}9vHIfmwY z>D|T7M~&AvYa-^=(r{CQXX?C-FbFD|U$Lh1qfB^bhiAL?m(1zJF?WG_Aum3=`Blf( z?033|s2{tZnHh8T6-&Kw7t_VpKpeFbR%n3 zC;{*wacMK8#mfg&`#Ge=j0IG)MLYeFs=e`xN!XeG3L}q)HD6E*<8 z*WoYZMJJ!1WJBXflsTFVvuP9~=o)P=@`F97(^^pB$N$>TO{@aVnbH ztk`UNi#_(v;B|L6quz;Ty<}NQ2rIk6(sP=QLB_xUB__H!>uB3qSJA$c8oKc%BXS>|#eu zLY$iu%c0|+7?`jOGoIDe8mD%27&90HUd3ZGxORA(8&3ki?n#bZiEm@r&$-iJD*|CK zO^;vvyfcB|emPMqJ|SB@N7> zKfRkeKcAq?*%F`Z#K*gMbf*E@B900t>qn_|65dtu1zd$OfNo96E|AP!urjDyAZVD( zyf4FyUeC2p!(f{}DpxOC$3UN*ET?F344*i{JSyQfSKKU>YP=ZN(IWmfIJ{_eezLm6EcO98Lz;0vZi=_;&Bs_Kj4>h~QN|Euo#~Th>7tCm0?U zp=&30qj4A>28WeHrcK|Y`<=iHv5#6PCj-3%8v`8S?Q_y@Qsq-q2*X1;*CoJ9Yr8oo zgEg-OP~k0a)_z0!Y}{75MTTfPD&k%JinQ9h2j)D#9$(0b-VtK?K@mK~@lCWP27E_b ztGCDqXp~xO-^~?sBts)gZ71jM4%_n|1rrUaHz#*E22*Vq3x&_91qm{MBsqYr{w`93 zYk|i)b(y~Q#|>qqXYEnLegsY$jzUQUpiFz%#7T0mazklNhScfu;1&X+J#ayjI~VV}<)X-z( zQCrD{mk5+aE$6u|*)M^}XBrt!Xx8PLxpVIF__3UmV=Zd4d&q%3Qtf1-bTl!7x2@+B zR7prStnO)wCsP3XYJ|!2v>6T?z?INqju3W^i}&N?I8Hs&(Ma|YW#teqPvR_K#HdXs z2^I)7#Ofs%ciVF_YimPHjqV(KA;c3ocRw}HDi4-lX2xQgRdRXMaunnN_`+eVbNzn* z(7+M{S^6ShR-CMkb?&{vvrE-W9GgnJJj~&FsCY=?>0l!Pah__%YQAdzkwoQ4zRq}L zQI*ZF7smxwVo!7sA39?pj{*Md{+#|tR1yQj&&`oNA1hr$T)G+~)owXs=Xu`K+LNoE z?+NEy_O*Dnj*U;f>*yVw0Jfl`R}yoCL0s{y4yn9pSc{mMo~tNKB2-iuC;ahzmdG2CX5j4}9Tzs@C0nDn8hG&>;py|O zX1S6!l7~T`xUHl{L1amUnNLxSwY)EAN}D_%Eib+GQclMny_*&7W_E=Z`DBat zQNuM*%LyH23uR5;YGT~yBfsf#OLxS~Y0jF(g7!deAe2Q!nF-pwVU#kevuwMpbVBn& z(UCzorm%+K9$q8C6C0alP-Bp7knqBbN8)TA{}9vC`%UOBa+k8JVku*3V%f4RJ_Z|; zDytk@DDf>>A2S%89Mc(nTY6zMaCBs}uGG79dPEJAj)}Pb&f~+7Qu#XhBrdU6U^VlW za`fWVc!WZ~{5g4R_tg=B!OZdD@y{bKhRcR8=6|uc_uyk*R#~&=Uc^?xNy{!{-P~%; z#exA;6yW*oEQ>F=W7&+azwnloQy z7G^%eT)|v-Vm(UwIrnpisP9pg3GoTe@vzerK2@mIg_Cjvig<;V>l!dGMO)WlCt^Q0 z>IKyJ!W*35#Bo@)q9LRl!Vit^KihX?p{YMwX7JS2QyOv1ar{P{Beyf2W6_Cr!!qGA z$7GtMb8Pu+I_z=P%XPc%I6@ZwjeB5MlrxvRx%&ueqr4(R=H=tgtx3dZ#B@XX;tgsb z-VNVX_ZsCrlIe4RP26M(|GW_fF<_$pW2xVW%6 zKGA0TA>h?lUfv?ZyM}SS`M#YSI~!*f6B?Eqh=>)3Lj3VMt-5AB+}puB(La2Ti7k*V zTlaQXL~*HG*`hkt&2ijOr1E6tORU?L!IlJ}{WZ0z-G4B8j_Wt`kECg9s^Uc5nD-0n zTSDZtL~u=T(mrgT|B&6GsgQ+`Qnjw9DWQSt1-VDm$JE)v`opx_RE0hDoVvG?nl?@> z9$WN|3>yp?{Ft}>EdF_FWS~$YE8DS3*5K1fE;II_){sW0p0Ly-l_Jd|y&`K`8Cv@H z{qlM8x$fV~zt-i`b*D=YRpD&i=@>f_!_`jdLe1yT- zH%?Z1+$OVSXNR*xEK^LEbLb}Irp(PX<-APhfz9EN!dk=PdhDv~DpxiOfrW5u?FD$z zM6^LX<-DrF4db`jmonzE;mMyZo}RKemR-DCJYLvx^_cPNoGl4e@n%(~wB&Rz3q6h^ z);(zLg$-zQbzgOCbwO`t+D8OT48W;?)|`lY)YKtAK^+Zg*Lvg#y*r<3etSb)@#3~# zHZfa{;M6ej*|_)o=fI6t$56XAhavl1`-hL6$c2k9b}a|X3d{YhS1M)gR9iX;{h_rH zwV3O{pc+|ea6p5stAk0h)zIDhRbPTu?BjT1wL27H_1KcvF_WNIO7)o4qB3J4Lmx3- z!wN$wgK5G7zGWw+-#X=5;N-0u^uxY9EY+&dYIc0(^;F$ikhLroEc9CNQ8S4JrQ4I3 zrjqvIi7C?BtS;`M;UhykKE#9r+O)QIIgn!TMK8hH*uTQ{W6|WxCf}yY59_Z+tcoqI z?Y8liPHX*st-Axv`BAZf>4D07f-oJ$t>FIM#s>ZT(wg_rgJy%?hsH1k_9yoD%iNVg zS9q2eP(C|7YwMl%2_AXVi7h7-*QE(EMvF!Z2H)HH_~p5JwEr&;6Kew9b{udlwfO~H z%ZRtiV=2R89}`yuFQ4(Lsp~2%p7-xv+ZGy8wIU&Y^O<0McJn@0&eesS%*!d1<@fL3 zji8zh{nj#Xs*)ev8pqN9t$hsJlFrKG1px$`W0 zLKm6OGOI)jL^py}99H?V6$9pC_fkfzn=7-MPI-PD?*5iMyJGf|@K�xVfk4>yp)O z#bO-^Po1(Q@dnnt%N}ly-MhQZA0+?1%3&F(dU;v(;wPuJa23>4)%h#v{mq~!OTu4~ z9T5Xs8|Pl@c8Ld`2VZgA@%g4demkSMezsioy@X=C_f`d)G=@ zU+oXCqSwf;Hosf*Rk}K+JuwR=&B(0a_M6hZxh^!URjo-~Ne^23dU|txwK(1+Cx~e~ zVq@=LTetF`Ybf9kLr5D>^IkA`nj=JCTmO5q#^BZQB+O3$0M^2|x}s?=5Z&gn2g)me zaTq*>1XPBBy(k1S8jE%%10eG9U>5?-xFV4-K(HGTd4sm&B2g6js*A!9Q52jj7VQHB zlQCEq8iYflhy*+k>`X+{18JE^6pCgn0l+R8S}PKU1O&_C31k|pKxxrqO6i5-XnusOwND6aS9}w56Xu_7SVLzv{_BAvE9d?{RWa<$q!Fib^zl@b7UnMMslT|G*&ff5{~ikr*tR zNHbW0U~`Ngnl=L Date: Tue, 8 Sep 2026 13:55:42 +0200 Subject: [PATCH 23/30] fix: redact glmSummaryDS.as fields by name, not index --- R/glmSummaryDS.as.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/glmSummaryDS.as.R b/R/glmSummaryDS.as.R index 0025e74e..076ede7f 100644 --- a/R/glmSummaryDS.as.R +++ b/R/glmSummaryDS.as.R @@ -58,8 +58,8 @@ input.obj <- .loadServersideObject(x.transmit) summary.obj<-summary(input.obj) #block na.action and deviance residual components of summary object -summary.obj[[12]]<-NA -summary.obj[[11]]<-NA +if (!is.null(summary.obj$na.action)) summary.obj$na.action<-NA +summary.obj$deviance.resid<-NA summary.obj<-summary.obj From 18bf2017b877d274d071132a1c1788db2664569f Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Tue, 8 Sep 2026 13:56:01 +0200 Subject: [PATCH 24/30] fix: use resolved offset/weights in lmerSLMADS.assign fit --- R/lmerSLMADS.assign.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/R/lmerSLMADS.assign.R b/R/lmerSLMADS.assign.R index 2343fe59..29aaae34 100644 --- a/R/lmerSLMADS.assign.R +++ b/R/lmerSLMADS.assign.R @@ -359,8 +359,7 @@ if(!is.null(optimizer)&&optimizer!="nloptwrap") } - mg <- lme4::lmer(formula2use, offset=offset, weights=weights, data=dataDF, REML = REML, verbose = verbose, control = control.obj) - #iterations <- utils::capture.output(try(mg <- lme4::lmer(formula2use, offset=offset.to.use, weights=weights.to.use, data=dataDF, REML = REML, verbose = verbose, control = control.obj))) + mg <- lme4::lmer(formula2use, offset=offset.to.use, weights=weights.to.use, data=dataDF, REML = REML, verbose = verbose, control = control.obj) outlist <- mg From 64239af9daeeda29dd379712900a2d4ae8b24cdf Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Tue, 8 Sep 2026 13:56:26 +0200 Subject: [PATCH 25/30] use .loadServersideObject --- R/glmSLMADS2.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/R/glmSLMADS2.R b/R/glmSLMADS2.R index b7374296..58d1b374 100644 --- a/R/glmSLMADS2.R +++ b/R/glmSLMADS2.R @@ -104,8 +104,7 @@ errorMessage2<-"No errors" #bringing back in the mg output saved from that previous call # mg <- stats::glm(formula2use, family=final.family.object, x=TRUE, offset=offset.to.use, weights=weights.to.use, data=dataDF) -activate.text<- paste0("mg<-",newobj) -eval(parse(text=activate.text)) +mg <- .loadServersideObject(newobj) y.vect<-mg$y X.mat<-mg$x From 1fff70086121ce1a308045da1be5e0ebd7fffd58 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Tue, 8 Sep 2026 15:38:17 +0200 Subject: [PATCH 26/30] fixed environment issue --- R/lmerSLMADS.assign.R | 39 ++++++++++++++++++++++----------------- R/lmerSLMADS2.R | 37 +++++++++++++++++++++---------------- 2 files changed, 43 insertions(+), 33 deletions(-) diff --git a/R/lmerSLMADS.assign.R b/R/lmerSLMADS.assign.R index 29aaae34..0aabe6b6 100644 --- a/R/lmerSLMADS.assign.R +++ b/R/lmerSLMADS.assign.R @@ -126,39 +126,44 @@ lmerSLMADS.assign <- function(formula, offset, weights, dataName, REML = TRUE, ################################################################## #sort out offset and weights + # + # offset.to.use/weights.to.use are needed in two different environments: + # stats::glm() below resolves them via environment(formula2use), which is + # this function's *caller* (matching where the other formula variables are + # assigned, see the model.variables loop above); lme4::lmer() further down + # resolves them relative to its own call frame, i.e. this function's *own* + # frame. Assign to both so each modelling call finds them. if(is.null(offset)) { varname.offset<-NULL - #offset.to.use <- NULL - cbindtext.offset <- paste0("offset.to.use <- NULL") - eval(parse(text=cbindtext.offset), envir = parent.frame()) + offset.to.use <- NULL + assign("offset.to.use", NULL, envir = parent.frame()) }else{ varname.offset <- paste0(offset) } - + if(!(is.null(offset))) { - cbindtext.offset <- paste0("offset.to.use <- cbind(", offset,")") - eval(parse(text=cbindtext.offset), envir = parent.frame()) + cbindtext.offset <- paste0("cbind(", offset,")") + offset.to.use <- eval(parse(text=cbindtext.offset), envir = parent.frame()) + assign("offset.to.use", offset.to.use, envir = parent.frame()) } - + if(is.null(weights)) { varname.weights<-NULL - cbindtext.weights <- paste0("weights.to.use <- NULL") - eval(parse(text=cbindtext.weights), envir = parent.frame()) - #weights.to.use <- NULL + weights.to.use <- NULL + assign("weights.to.use", NULL, envir = parent.frame()) }else{ varname.weights <- paste0(weights) } - - + + if(!(is.null(weights))) { - cbindtext.weights <- paste0("weights.to.use <- cbind(", weights,")") - eval(parse(text=cbindtext.weights), envir = parent.frame()) - #cbindtext.weights <- paste0("cbind(", weights,")") - #weights.to.use <- eval(parse(text=cbindtext.weights), envir = parent.frame()) + cbindtext.weights <- paste0("cbind(", weights,")") + weights.to.use <- eval(parse(text=cbindtext.weights), envir = parent.frame()) + assign("weights.to.use", weights.to.use, envir = parent.frame()) } #### BEFORE going further we use the glm1 checks @@ -362,7 +367,7 @@ if(!is.null(optimizer)&&optimizer!="nloptwrap") mg <- lme4::lmer(formula2use, offset=offset.to.use, weights=weights.to.use, data=dataDF, REML = REML, verbose = verbose, control = control.obj) outlist <- mg - + } #tidy up in parent.frame() eval(quote(rm(offset.to.use)), envir = parent.frame()) diff --git a/R/lmerSLMADS2.R b/R/lmerSLMADS2.R index a60b67c2..68bcb465 100644 --- a/R/lmerSLMADS2.R +++ b/R/lmerSLMADS2.R @@ -135,39 +135,44 @@ lmerSLMADS2 <- function(formula, offset, weights, dataName, REML = TRUE, ################################################################## #sort out offset and weights + # + # offset.to.use/weights.to.use are needed in two different environments: + # stats::glm() below resolves them via environment(formula2use), which is + # this function's *caller* (matching where the other formula variables are + # assigned, see the model.variables loop above); lme4::lmer() further down + # resolves them relative to its own call frame, i.e. this function's *own* + # frame. Assign to both so each modelling call finds them. if(is.null(offset)) { varname.offset<-NULL - #offset.to.use <- NULL - cbindtext.offset <- paste0("offset.to.use <- NULL") - eval(parse(text=cbindtext.offset), envir = parent.frame()) + offset.to.use <- NULL + assign("offset.to.use", NULL, envir = parent.frame()) }else{ varname.offset <- paste0(offset) } - + if(!(is.null(offset))) { - cbindtext.offset <- paste0("offset.to.use <- cbind(", offset,")") - eval(parse(text=cbindtext.offset), envir = parent.frame()) + cbindtext.offset <- paste0("cbind(", offset,")") + offset.to.use <- eval(parse(text=cbindtext.offset), envir = parent.frame()) + assign("offset.to.use", offset.to.use, envir = parent.frame()) } - + if(is.null(weights)) { varname.weights<-NULL - cbindtext.weights <- paste0("weights.to.use <- NULL") - eval(parse(text=cbindtext.weights), envir = parent.frame()) - #weights.to.use <- NULL + weights.to.use <- NULL + assign("weights.to.use", NULL, envir = parent.frame()) }else{ varname.weights <- paste0(weights) } - - + + if(!(is.null(weights))) { - cbindtext.weights <- paste0("weights.to.use <- cbind(", weights,")") - eval(parse(text=cbindtext.weights), envir = parent.frame()) - #cbindtext.weights <- paste0("cbind(", weights,")") - #weights.to.use <- eval(parse(text=cbindtext.weights), envir = parent.frame()) + cbindtext.weights <- paste0("cbind(", weights,")") + weights.to.use <- eval(parse(text=cbindtext.weights), envir = parent.frame()) + assign("weights.to.use", weights.to.use, envir = parent.frame()) } #### BEFORE going further we use the glm1 checks From f1cd7782f02bbf92ff7d71b019e06835b6ab46ff Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 11 Sep 2026 13:34:23 +0200 Subject: [PATCH 27/30] Delete Rplots.pdf that entered by mistake --- tests/testthat/Rplots.pdf | Bin 5562 -> 0 bytes 1 file changed, 0 insertions(+), 0 deletions(-) delete mode 100644 tests/testthat/Rplots.pdf diff --git a/tests/testthat/Rplots.pdf b/tests/testthat/Rplots.pdf deleted file mode 100644 index ac3ab89f20cb92e29bf35287fb79c19aa27ae11c..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 5562 zcmb7Ic{tSj+ZIKp#hyeAp|Osc7$jxig|RbajKOFYX34&<*$$Phtl2q|kS(OFS;k(Z zY#l_A2vPaXIH&VF%lp39_0Dz8AD{dCET8W)*ERQZ-(sd(Ix-Mhd4O2xTNZGYbqE zOUr@-b%{t%cMOUIG@+0^DP&rjDUskpL7|ECr}DD$vQQd!(2GEaBmkE$1JHOE`YoV; z-UbM^@byFk!J0@i5=(Fcf=!WbXcF)OEdUPuZ-U~#66kUCXd)U<{v#Z$Nx+k7M-ou! zARP=xlL!2P zGs6LVGAq&zf8kMNkKEq2_F+91UycaEsq2dtuyg3VV5}0keONx8Tm0Sn8fi+_`{h}` zdT(*tK@!_XkJmZ9U1P?pk>|GCz6be42AdFqzO82X|JY>@INCO`va$$XZxw53JxO@m zI1_X^$v-q$=;SDW{TiG0lf%~cdA)?POgH3zOCePf-Uvy$QT^_T?t)eVQ;H68`9HYM zl=4_zjQT|3^ss!4gwG4wxu|U@_oZ?=GgbD^P}9A$I*Mx#*i2f{49zMR?_21Rj_N6D!gKDkZvL7=^@1zlWK*y!CRHS*X0T@xmg3u zH;&(ka@dn**i>@a6f`lPfTx~5pT|720AYgNG_kT2p#OV{QnuKd} zq-M>8o(_;6wf;I%xYy%gUzb?xjhJ=aFFF&(rHrK22z58C%02YlK zE}}5O319 zL5}os9)aYP`SE1#oL1Vy{1i8qr`Ql-O~cE&Ql^<&+{Xvu0Wr+LMjTq##3?~FtB}Ps zY7PE6WNTiffR&pe$)mQIfE!~lp2B%?_SY{YxW_Sta*90@mtmG*XNlwXm#96fn(W+k zOZ^4+FYMD5Eb!HP`mh3lssd(-=aM(QYeY~+R>R76$ z@is@UiJ{w*N*V)$2DM9$nHHhKS6NEjLjZAmmWjj^vCUyj;axcoLmoFvn8mr{;l?sN z{^@y=hg71xYv3uX<_prCI}6>l=60oXAI{B}hiykYmx}1aUk@3`%ZekD$t`!KFlp|Z5?sqgn~=98M7=cBT{RBESV;<|gB<}9vHIfmwY z>D|T7M~&AvYa-^=(r{CQXX?C-FbFD|U$Lh1qfB^bhiAL?m(1zJF?WG_Aum3=`Blf( z?033|s2{tZnHh8T6-&Kw7t_VpKpeFbR%n3 zC;{*wacMK8#mfg&`#Ge=j0IG)MLYeFs=e`xN!XeG3L}q)HD6E*<8 z*WoYZMJJ!1WJBXflsTFVvuP9~=o)P=@`F97(^^pB$N$>TO{@aVnbH ztk`UNi#_(v;B|L6quz;Ty<}NQ2rIk6(sP=QLB_xUB__H!>uB3qSJA$c8oKc%BXS>|#eu zLY$iu%c0|+7?`jOGoIDe8mD%27&90HUd3ZGxORA(8&3ki?n#bZiEm@r&$-iJD*|CK zO^;vvyfcB|emPMqJ|SB@N7> zKfRkeKcAq?*%F`Z#K*gMbf*E@B900t>qn_|65dtu1zd$OfNo96E|AP!urjDyAZVD( zyf4FyUeC2p!(f{}DpxOC$3UN*ET?F344*i{JSyQfSKKU>YP=ZN(IWmfIJ{_eezLm6EcO98Lz;0vZi=_;&Bs_Kj4>h~QN|Euo#~Th>7tCm0?U zp=&30qj4A>28WeHrcK|Y`<=iHv5#6PCj-3%8v`8S?Q_y@Qsq-q2*X1;*CoJ9Yr8oo zgEg-OP~k0a)_z0!Y}{75MTTfPD&k%JinQ9h2j)D#9$(0b-VtK?K@mK~@lCWP27E_b ztGCDqXp~xO-^~?sBts)gZ71jM4%_n|1rrUaHz#*E22*Vq3x&_91qm{MBsqYr{w`93 zYk|i)b(y~Q#|>qqXYEnLegsY$jzUQUpiFz%#7T0mazklNhScfu;1&X+J#ayjI~VV}<)X-z( zQCrD{mk5+aE$6u|*)M^}XBrt!Xx8PLxpVIF__3UmV=Zd4d&q%3Qtf1-bTl!7x2@+B zR7prStnO)wCsP3XYJ|!2v>6T?z?INqju3W^i}&N?I8Hs&(Ma|YW#teqPvR_K#HdXs z2^I)7#Ofs%ciVF_YimPHjqV(KA;c3ocRw}HDi4-lX2xQgRdRXMaunnN_`+eVbNzn* z(7+M{S^6ShR-CMkb?&{vvrE-W9GgnJJj~&FsCY=?>0l!Pah__%YQAdzkwoQ4zRq}L zQI*ZF7smxwVo!7sA39?pj{*Md{+#|tR1yQj&&`oNA1hr$T)G+~)owXs=Xu`K+LNoE z?+NEy_O*Dnj*U;f>*yVw0Jfl`R}yoCL0s{y4yn9pSc{mMo~tNKB2-iuC;ahzmdG2CX5j4}9Tzs@C0nDn8hG&>;py|O zX1S6!l7~T`xUHl{L1amUnNLxSwY)EAN}D_%Eib+GQclMny_*&7W_E=Z`DBat zQNuM*%LyH23uR5;YGT~yBfsf#OLxS~Y0jF(g7!deAe2Q!nF-pwVU#kevuwMpbVBn& z(UCzorm%+K9$q8C6C0alP-Bp7knqBbN8)TA{}9vC`%UOBa+k8JVku*3V%f4RJ_Z|; zDytk@DDf>>A2S%89Mc(nTY6zMaCBs}uGG79dPEJAj)}Pb&f~+7Qu#XhBrdU6U^VlW za`fWVc!WZ~{5g4R_tg=B!OZdD@y{bKhRcR8=6|uc_uyk*R#~&=Uc^?xNy{!{-P~%; z#exA;6yW*oEQ>F=W7&+azwnloQy z7G^%eT)|v-Vm(UwIrnpisP9pg3GoTe@vzerK2@mIg_Cjvig<;V>l!dGMO)WlCt^Q0 z>IKyJ!W*35#Bo@)q9LRl!Vit^KihX?p{YMwX7JS2QyOv1ar{P{Beyf2W6_Cr!!qGA z$7GtMb8Pu+I_z=P%XPc%I6@ZwjeB5MlrxvRx%&ueqr4(R=H=tgtx3dZ#B@XX;tgsb z-VNVX_ZsCrlIe4RP26M(|GW_fF<_$pW2xVW%6 zKGA0TA>h?lUfv?ZyM}SS`M#YSI~!*f6B?Eqh=>)3Lj3VMt-5AB+}puB(La2Ti7k*V zTlaQXL~*HG*`hkt&2ijOr1E6tORU?L!IlJ}{WZ0z-G4B8j_Wt`kECg9s^Uc5nD-0n zTSDZtL~u=T(mrgT|B&6GsgQ+`Qnjw9DWQSt1-VDm$JE)v`opx_RE0hDoVvG?nl?@> z9$WN|3>yp?{Ft}>EdF_FWS~$YE8DS3*5K1fE;II_){sW0p0Ly-l_Jd|y&`K`8Cv@H z{qlM8x$fV~zt-i`b*D=YRpD&i=@>f_!_`jdLe1yT- zH%?Z1+$OVSXNR*xEK^LEbLb}Irp(PX<-APhfz9EN!dk=PdhDv~DpxiOfrW5u?FD$z zM6^LX<-DrF4db`jmonzE;mMyZo}RKemR-DCJYLvx^_cPNoGl4e@n%(~wB&Rz3q6h^ z);(zLg$-zQbzgOCbwO`t+D8OT48W;?)|`lY)YKtAK^+Zg*Lvg#y*r<3etSb)@#3~# zHZfa{;M6ej*|_)o=fI6t$56XAhavl1`-hL6$c2k9b}a|X3d{YhS1M)gR9iX;{h_rH zwV3O{pc+|ea6p5stAk0h)zIDhRbPTu?BjT1wL27H_1KcvF_WNIO7)o4qB3J4Lmx3- z!wN$wgK5G7zGWw+-#X=5;N-0u^uxY9EY+&dYIc0(^;F$ikhLroEc9CNQ8S4JrQ4I3 zrjqvIi7C?BtS;`M;UhykKE#9r+O)QIIgn!TMK8hH*uTQ{W6|WxCf}yY59_Z+tcoqI z?Y8liPHX*st-Axv`BAZf>4D07f-oJ$t>FIM#s>ZT(wg_rgJy%?hsH1k_9yoD%iNVg zS9q2eP(C|7YwMl%2_AXVi7h7-*QE(EMvF!Z2H)HH_~p5JwEr&;6Kew9b{udlwfO~H z%ZRtiV=2R89}`yuFQ4(Lsp~2%p7-xv+ZGy8wIU&Y^O<0McJn@0&eesS%*!d1<@fL3 zji8zh{nj#Xs*)ev8pqN9t$hsJlFrKG1px$`W0 zLKm6OGOI)jL^py}99H?V6$9pC_fkfzn=7-MPI-PD?*5iMyJGf|@K�xVfk4>yp)O z#bO-^Po1(Q@dnnt%N}ly-MhQZA0+?1%3&F(dU;v(;wPuJa23>4)%h#v{mq~!OTu4~ z9T5Xs8|Pl@c8Ld`2VZgA@%g4demkSMezsioy@X=C_f`d)G=@ zU+oXCqSwf;Hosf*Rk}K+JuwR=&B(0a_M6hZxh^!URjo-~Ne^23dU|txwK(1+Cx~e~ zVq@=LTetF`Ybf9kLr5D>^IkA`nj=JCTmO5q#^BZQB+O3$0M^2|x}s?=5Z&gn2g)me zaTq*>1XPBBy(k1S8jE%%10eG9U>5?-xFV4-K(HGTd4sm&B2g6js*A!9Q52jj7VQHB zlQCEq8iYflhy*+k>`X+{18JE^6pCgn0l+R8S}PKU1O&_C31k|pKxxrqO6i5-XnusOwND6aS9}w56Xu_7SVLzv{_BAvE9d?{RWa<$q!Fib^zl@b7UnMMslT|G*&ff5{~ikr*tR zNHbW0U~`Ngnl=L Date: Mon, 14 Sep 2026 12:47:31 +0200 Subject: [PATCH 28/30] fixed tests and docs --- R/rBinomDS.R | 11 +++-------- R/rNormDS.R | 12 ++++-------- R/rPoisDS.R | 11 +++-------- R/rUnifDS.R | 12 ++++-------- man/rBinomDS.Rd | 11 +++-------- man/rNormDS.Rd | 12 ++++-------- man/rPoisDS.Rd | 11 +++-------- man/rUnifDS.Rd | 12 ++++-------- tests/testthat/test-smk-setSeedDS.R | 8 ++++++-- 9 files changed, 34 insertions(+), 66 deletions(-) diff --git a/R/rBinomDS.R b/R/rBinomDS.R index 9ec42361..a79428f6 100644 --- a/R/rBinomDS.R +++ b/R/rBinomDS.R @@ -15,14 +15,9 @@ #' by argument of ds.rBinom - for details see help for ds.rBinom #' May be a scalar or a vector allowing the size to vary from #' observation to observation. -#' @return Writes the pseudorandom number vector with the characteristics specified -#' in the function call as a new serverside vector on the data source on which -#' it has been called. Also returns key information to the clientside: -#' the random seed as specified by you in each -#' source + (if requested) the full 626 length random seed vector this generated in -#' each source (see info for the argument ). It -#' also returns a vector reporting the length of the pseudorandom vector -#' created in each source. +#' @return the vector of pseudorandom numbers from a binomial distribution, which +#' is written to the serverside as the object named by the argument +#' of ds.rBinom. #' @author Paul Burton for DataSHIELD Development Team #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export diff --git a/R/rNormDS.R b/R/rNormDS.R index d201143a..c0795201 100644 --- a/R/rNormDS.R +++ b/R/rNormDS.R @@ -20,14 +20,10 @@ #' have k decimal places. If k = 9, no rounding occurs of native output. #' Default=9. Value specified by argument #' in ds.rNorm -#' @return Writes the pseudorandom number vector with the characteristics specified -#' in the function call as a new serverside vector on the data source on which -#' it has been called. Also returns key information to the clientside: -#' the random seed as specified by you in each -#' source + (if requested) the full 626 length random seed vector this generated in -#' each source (see info for the argument ). It -#' also returns a vector reporting the length of the pseudorandom vector -#' created in each source. +#' @return the numeric vector of pseudorandom numbers from a normal distribution, +#' rounded to decimal places if that is less +#' than 9, which is written to the serverside as the object named by the +#' argument of ds.rNorm. #' @author Paul Burton for DataSHIELD Development Team #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export diff --git a/R/rPoisDS.R b/R/rPoisDS.R index 5bee2148..a7bf9533 100644 --- a/R/rPoisDS.R +++ b/R/rPoisDS.R @@ -11,14 +11,9 @@ #' distribution used to generate the random counts. Specified directly #' by the lambda argument in ds.rPois. May be a scalar or a vector allowing lambda #' to vary from observation to observation. -#' @return Writes the pseudorandom number vector with the characteristics specified -#' in the function call as a new serverside vector on the data source on which -#' it has been called. Also returns key information to the clientside: -#' the random seed as specified by you in each -#' source + (if requested) the full 626 length random seed vector this generated in -#' each source (see info for the argument ). It -#' also returns a vector reporting the length of the pseudorandom vector -#' created in each source. +#' @return the vector of pseudorandom non-negative integers from a Poisson +#' distribution, which is written to the serverside as the object named by the +#' argument of ds.rPois. #' @author Paul Burton for DataSHIELD Development Team #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export diff --git a/R/rUnifDS.R b/R/rUnifDS.R index d20d189f..1e9c9c10 100644 --- a/R/rUnifDS.R +++ b/R/rUnifDS.R @@ -20,14 +20,10 @@ #' have k decimal places. If k = 9, no rounding occurs of native output. #' Default=9. Value specified by argument #' in ds.rUnif -#' @return Writes the pseudorandom number vector with the characteristics specified -#' in the function call as a new serverside vector on the data source on which -#' it has been called. Also returns key information to the clientside: -#' the random seed as specified by you in each -#' source + (if requested) the full 626 length random seed vector this generated in -#' each source (see info for the argument ). It -#' also returns a vector reporting the length of the pseudorandom vector -#' created in each source. +#' @return the numeric vector of pseudorandom numbers from a uniform distribution, +#' rounded to decimal places if that is less +#' than 9, which is written to the serverside as the object named by the +#' argument of ds.rUnif. #' @author Paul Burton for DataSHIELD Development Team #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export diff --git a/man/rBinomDS.Rd b/man/rBinomDS.Rd index b8d16755..11c527a0 100644 --- a/man/rBinomDS.Rd +++ b/man/rBinomDS.Rd @@ -22,14 +22,9 @@ May be a scalar or a vector allowing the size to vary from observation to observation.} } \value{ -Writes the pseudorandom number vector with the characteristics specified -in the function call as a new serverside vector on the data source on which -it has been called. Also returns key information to the clientside: -the random seed as specified by you in each -source + (if requested) the full 626 length random seed vector this generated in -each source (see info for the argument ). It -also returns a vector reporting the length of the pseudorandom vector -created in each source. +the vector of pseudorandom numbers from a binomial distribution, which +is written to the serverside as the object named by the argument +of ds.rBinom. } \description{ primary serverside assign function called by ds.rBinom diff --git a/man/rNormDS.Rd b/man/rNormDS.Rd index f4dd1f4f..2ae0d082 100644 --- a/man/rNormDS.Rd +++ b/man/rNormDS.Rd @@ -28,14 +28,10 @@ Default=9. Value specified by argument in ds.rNorm} } \value{ -Writes the pseudorandom number vector with the characteristics specified -in the function call as a new serverside vector on the data source on which -it has been called. Also returns key information to the clientside: -the random seed as specified by you in each -source + (if requested) the full 626 length random seed vector this generated in -each source (see info for the argument ). It -also returns a vector reporting the length of the pseudorandom vector -created in each source. +the numeric vector of pseudorandom numbers from a normal distribution, +rounded to decimal places if that is less +than 9, which is written to the serverside as the object named by the +argument of ds.rNorm. } \description{ primary serverside assign function called by ds.rNorm diff --git a/man/rPoisDS.Rd b/man/rPoisDS.Rd index 9d3d2dbe..d6c6edc1 100644 --- a/man/rPoisDS.Rd +++ b/man/rPoisDS.Rd @@ -16,14 +16,9 @@ by the lambda argument in ds.rPois. May be a scalar or a vector allowing lambda to vary from observation to observation.} } \value{ -Writes the pseudorandom number vector with the characteristics specified -in the function call as a new serverside vector on the data source on which -it has been called. Also returns key information to the clientside: -the random seed as specified by you in each -source + (if requested) the full 626 length random seed vector this generated in -each source (see info for the argument ). It -also returns a vector reporting the length of the pseudorandom vector -created in each source. +the vector of pseudorandom non-negative integers from a Poisson +distribution, which is written to the serverside as the object named by the + argument of ds.rPois. } \description{ primary serverside assign function called by ds.rPois diff --git a/man/rUnifDS.Rd b/man/rUnifDS.Rd index f3ad01c8..491bcd07 100644 --- a/man/rUnifDS.Rd +++ b/man/rUnifDS.Rd @@ -28,14 +28,10 @@ Default=9. Value specified by argument in ds.rUnif} } \value{ -Writes the pseudorandom number vector with the characteristics specified -in the function call as a new serverside vector on the data source on which -it has been called. Also returns key information to the clientside: -the random seed as specified by you in each -source + (if requested) the full 626 length random seed vector this generated in -each source (see info for the argument ). It -also returns a vector reporting the length of the pseudorandom vector -created in each source. +the numeric vector of pseudorandom numbers from a uniform distribution, +rounded to decimal places if that is less +than 9, which is written to the serverside as the object named by the +argument of ds.rUnif. } \description{ primary serverside assign function called by ds.rUnif diff --git a/tests/testthat/test-smk-setSeedDS.R b/tests/testthat/test-smk-setSeedDS.R index 0e976bd7..a87ab40b 100644 --- a/tests/testthat/test-smk-setSeedDS.R +++ b/tests/testthat/test-smk-setSeedDS.R @@ -34,14 +34,18 @@ test_that("simple setSeedDS", { expect_length(res$seed.as.set, 626) }) -test_that("setSeedDS works with numeric string", { - res <- setSeedDS("42", NULL, NULL) +test_that("setSeedDS with \"NULL\" seedtext", { + res <- setSeedDS("NULL", NULL, NULL) expect_equal(class(res), "list") expect_length(res, 1) expect_length(res$seed.as.set, 626) }) +test_that("setSeedDS fails with non-numeric seedtext", { + expect_error(suppressWarnings(setSeedDS("abc", NULL, NULL)), "supplied seed is not a valid integer") +}) + # # Done # From a94e23d03d3e7c1096ec997d1221ea3c72e85a39 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 14 Sep 2026 16:32:29 +0200 Subject: [PATCH 29/30] added back missing class checks --- R/boxPlotGGDS.R | 3 +- R/boxPlotGG_data_TreatmentDS.R | 32 +-- R/boxPlotGG_data_Treatment_numericDS.R | 22 +- R/densityGridDS.R | 15 +- R/heatmapPlotDS.R | 11 +- R/histogramDS1.R | 197 +++++++++--------- R/histogramDS2.R | 1 + R/scatterPlotDS.R | 9 +- man/boxPlotGGDS.Rd | 3 + man/boxPlotGG_data_TreatmentDS.Rd | 7 +- man/boxPlotGG_data_Treatment_numericDS.Rd | 9 +- man/densityGridDS.Rd | 5 +- man/heatmapPlotDS.Rd | 3 +- man/histogramDS1.Rd | 3 +- man/scatterPlotDS.Rd | 3 +- tests/testthat/test-smk-boxPlotGGDS.R | 53 +++++ .../test-smk-boxPlotGG_data_TreatmentDS.R | 61 ++++++ ...t-smk-boxPlotGG_data_Treatment_numericDS.R | 49 +++++ tests/testthat/test-smk-densityGridDS.R | 28 ++- tests/testthat/test-smk-heatmapPlotDS.R | 66 ++++++ tests/testthat/test-smk-histogramDS1.R | 51 +++++ tests/testthat/test-smk-histogramDS2.R | 50 +++++ tests/testthat/test-smk-scatterPlotDS.R | 66 ++++++ 23 files changed, 592 insertions(+), 155 deletions(-) create mode 100644 tests/testthat/test-smk-boxPlotGGDS.R create mode 100644 tests/testthat/test-smk-boxPlotGG_data_TreatmentDS.R create mode 100644 tests/testthat/test-smk-boxPlotGG_data_Treatment_numericDS.R create mode 100644 tests/testthat/test-smk-heatmapPlotDS.R create mode 100644 tests/testthat/test-smk-histogramDS1.R create mode 100644 tests/testthat/test-smk-histogramDS2.R create mode 100644 tests/testthat/test-smk-scatterPlotDS.R diff --git a/R/boxPlotGGDS.R b/R/boxPlotGGDS.R index 1cad869f..6ee33824 100644 --- a/R/boxPlotGGDS.R +++ b/R/boxPlotGGDS.R @@ -18,7 +18,8 @@ #' @return \code{list} with: \cr #' -\code{data frame} Geometrical parameters (identity stats of ggplot) \cr #' -\code{character} Type of plot (single_group, double_group or no_group) \cr -#' +#' +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export boxPlotGGDS <- function(data_table.name, group = NULL, group2 = NULL){ diff --git a/R/boxPlotGG_data_TreatmentDS.R b/R/boxPlotGG_data_TreatmentDS.R index 7d6613d1..c3a18e67 100644 --- a/R/boxPlotGG_data_TreatmentDS.R +++ b/R/boxPlotGG_data_TreatmentDS.R @@ -1,42 +1,46 @@ #' @title Arrange data frame to pass it to the boxplot function #' -#' @param table \code{data frame} Table that holds the information to be plotted later +#' @param table.name \code{character} Name of a server-side data frame that holds the information to be plotted later #' @param variables \code{character vector} Name of the column(s) of the data frame to include on the boxplot -#' @param group \code{character} (default \code{NULL}) Name of the first grouping variable. -#' @param group2 \code{character} (default \code{NULL}) Name of the second grouping variable. +#' @param group \code{character} (default \code{NULL}) Name of the first grouping variable. +#' @param group2 \code{character} (default \code{NULL}) Name of the second grouping variable. #' #' @return \code{data frame} with the following structure: \cr -#' +#' #' Column 'x': Names on the X axis of the boxplot, aka variables to plot \cr #' Column 'value': Values for that variable (raw data of columns rbinded) \cr #' Column 'group': (Optional) Values of the grouping variable \cr #' Column 'group2': (Optional) Values of the second grouping variable \cr -#' +#' +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export -boxPlotGG_data_TreatmentDS <- function(table, variables, group = NULL, group2 = NULL){ +boxPlotGG_data_TreatmentDS <- function(table.name, variables, group = NULL, group2 = NULL){ + + table <- .loadServersideObject(table.name) + + for(variable in variables){ + .checkClass(obj = table[[variable]], obj_name = variable, permitted_classes = c("numeric", "integer")) + } if(is.null(group) & !is.null(group2)){ group <- group2 group2 <- NULL } - + if(is.null(group2)){ if(is.null(group)){ data <- table[, c(variables)] } else{ - if(! any(c("factor") %in% class(table[[group]]))) { - stop("Grouping variable must be of class factor") - } + .checkClass(obj = table[[group]], obj_name = group, permitted_classes = c("factor")) data <- table[, c(variables, group)] } - + } else{ - if((! any(c("factor") %in% class(table[[group]]))) | (! any(c("factor") %in% class(table[[group2]])))){ - stop("Grouping variable must be of class factor") - } + .checkClass(obj = table[[group]], obj_name = group, permitted_classes = c("factor")) + .checkClass(obj = table[[group2]], obj_name = group2, permitted_classes = c("factor")) data <- table[, c(variables, group, group2)] # Handle case group == group2 if(group == group2){ diff --git a/R/boxPlotGG_data_Treatment_numericDS.R b/R/boxPlotGG_data_Treatment_numericDS.R index 7374ca7d..feff4f0e 100644 --- a/R/boxPlotGG_data_Treatment_numericDS.R +++ b/R/boxPlotGG_data_Treatment_numericDS.R @@ -1,18 +1,22 @@ #' @title Arrange vector to pass it to the boxplot function #' -#' @param vector \code{numeric vector} Vector to arrange to be plotted later +#' @param vector.name \code{character} Name of a server-side numeric vector to arrange to be plotted later #' #' @return \code{data frame} with the following structure: \cr -#' -#' Column 'x': Names on the X axis of the boxplot, aka name of the vector (vector argument) \cr +#' +#' Column 'x': Names on the X axis of the boxplot, aka name of the vector (vector.name argument) \cr #' Column 'value': Values for that variable \cr -#' +#' +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export -boxPlotGG_data_Treatment_numericDS <- function(vector){ - - data <- data.frame(x = deparse(substitute(vector)), value = vector) - +boxPlotGG_data_Treatment_numericDS <- function(vector.name){ + + vector <- .loadServersideObject(vector.name) + .checkClass(obj = vector, obj_name = vector.name, permitted_classes = c("numeric", "integer")) + + data <- data.frame(x = vector.name, value = vector) + return(data) - + } \ No newline at end of file diff --git a/R/densityGridDS.R b/R/densityGridDS.R index a41245ac..1e16fc8a 100644 --- a/R/densityGridDS.R +++ b/R/densityGridDS.R @@ -6,22 +6,25 @@ #' @param x a character string providing the name of a server-side numerical vector #' @param y a character string providing the name of a server-side numerical vector #' @param limits a logical expression for whether or not limits of the density grid are defined by -#' a user. If \code{limits} is set to "FALSE", min and max of xvect and yvect are used as a range. +#' a user. If \code{limits} is set to "FALSE", min and max of x and y are used as a range. #' If \code{limits} is set to "TRUE", limits defined by x.min, x.max, y.min and y.max are used. #' @param x.min a minimum value for the x axis of the grid density object, if needed #' @param x.max a maximum value for the x axis of the grid density object, if needed #' @param y.min a minimum value for the y axis of the grid density object, if needed #' @param y.max a maximum value for the y axis of the grid density object, if needed #' @param numints a number of intervals for the grid density object, by default is 20 -#' @return a grid density matrix +#' @return a list with the grid density matrix (\code{grid}) and the classes of the x and y inputs +#' (\code{class.x} and \code{class.y}) #' @author Julia Isaeva, Amadou Gaye, Demetris Avraam for DataSHIELD Development Team #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export -#' +#' densityGridDS <- function(x, y, limits=FALSE, x.min=NULL, x.max=NULL, y.min=NULL, y.max=NULL, numints=20){ xvect <- .loadServersideObject(x) yvect <- .loadServersideObject(y) + .checkClass(obj = xvect, obj_name = x, permitted_classes = c("numeric", "integer")) + .checkClass(obj = yvect, obj_name = y, permitted_classes = c("numeric", "integer")) ############################################################# # MODULE 1: CAPTURE THE nfilter SETTINGS @@ -97,9 +100,9 @@ densityGridDS <- function(x, y, limits=FALSE, x.min=NULL, x.max=NULL, y.min=NUL names(dimnames(grid.density.obj))[2] <- title.text names(dimnames(grid.density.obj))[1] <- '' - - return(grid.density.obj) - + + return(list(grid=grid.density.obj, class.x=class(xvect), class.y=class(yvect))) + } # AGGREGATE FUNCTION # densityGridDS diff --git a/R/heatmapPlotDS.R b/R/heatmapPlotDS.R index 951c6755..d8afc61e 100644 --- a/R/heatmapPlotDS.R +++ b/R/heatmapPlotDS.R @@ -18,15 +18,18 @@ #' @param method.indicator a number equal to either 1 or 2. If the value is equal to 1 then the #' 'deterministic' method is used. If the value is set to 2 the 'probabilistic' method is used. #' @return a list with the x and y coordinates of the centroids if the deterministic method is used -#' or the x and y coordinated of the noisy data if the probabilistic method is used. +#' or the x and y coordinated of the noisy data if the probabilistic method is used, along with the +#' classes of the x and y inputs (\code{class.x} and \code{class.y}) #' @author Demetris Avraam for DataSHIELD Development Team #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export -#' +#' heatmapPlotDS <- function(x.name, y.name, k, noise, method.indicator){ x <- .loadServersideObject(x.name) y <- .loadServersideObject(y.name) + .checkClass(obj = x, obj_name = x.name, permitted_classes = c("numeric", "integer")) + .checkClass(obj = y, obj_name = y.name, permitted_classes = c("numeric", "integer")) ################################################################### # MODULE 1: CAPTURE THE nfilter SETTINGS # @@ -129,8 +132,8 @@ heatmapPlotDS <- function(x.name, y.name, k, noise, method.indicator){ } # Return a list with the x and y coordinates of the centroids - return(list(x.new, y.new)) - + return(list(x.new, y.new, class.x=class(x), class.y=class(y))) + } # AGGREGATE FUNCTION # heatmapPlotDS diff --git a/R/histogramDS1.R b/R/histogramDS1.R index f99d2449..97e09780 100644 --- a/R/histogramDS1.R +++ b/R/histogramDS1.R @@ -16,7 +16,8 @@ #' \code{method.indicator} is equal to 2 (i.e. deterministic method). #' @param noise the percentage of the initial variance that is used as the variance of the embedded #' noise if the \code{method.indicator} is equal to 3 (i.e. probabilistic method). -#' @return a numeric vector which contains the minimum and the maximum values of the vector +#' @return a list with the numeric vector containing the minimum and the maximum values of the +#' vector (\code{range}) and the class of the input vector (\code{class}) #' @author Amadou Gaye, Demetris Avraam for DataSHIELD Development Team #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export @@ -24,6 +25,7 @@ histogramDS1 <- function(x, method.indicator, k, noise){ xvect <- .loadServersideObject(x) + .checkClass(obj = xvect, obj_name = x, permitted_classes = c("numeric", "integer")) ################################################################## # MODULE 1: CAPTURE THE nfilter SETTINGS # @@ -46,110 +48,103 @@ histogramDS1 <- function(x, method.indicator, k, noise){ } else on.exit(if (exists(x = ".Random.seed", envir = globalenv())) remove(".Random.seed", envir = globalenv()), add = TRUE) - # print an error message if the input vector is not a numeric - if(!(is.numeric(xvect))){ - output <- "The input vector is not a numeric!" - }else{ - - if (method.indicator==1){ - - # the study-specific seed for random number generation - seed <- getOption("datashield.seed") - if (is.null(seed)) - stop("histogramDS1 requires 'datashield.seed' R option to operate", call.=FALSE) - set.seed(seed) - - rr <- c(min(xvect, na.rm=TRUE), max(xvect, na.rm=TRUE)) - if(rr[1] < 0){ min <- rr[1] * stats::runif(1, 1.01, 1.05) }else{ min <- rr[1] * stats::runif(1, 0.95, 0.99) } - if(rr[2] < 0){ max <- rr[2] * stats::runif(1, 0.95, 0.99) }else{ max <- rr[2] * stats::runif(1, 1.01, 1.05) } - - output <- c(min, max) - + if (method.indicator==1){ + + # the study-specific seed for random number generation + seed <- getOption("datashield.seed") + if (is.null(seed)) + stop("histogramDS1 requires 'datashield.seed' R option to operate", call.=FALSE) + set.seed(seed) + + rr <- c(min(xvect, na.rm=TRUE), max(xvect, na.rm=TRUE)) + if(rr[1] < 0){ min <- rr[1] * stats::runif(1, 1.01, 1.05) }else{ min <- rr[1] * stats::runif(1, 0.95, 0.99) } + if(rr[2] < 0){ max <- rr[2] * stats::runif(1, 0.95, 0.99) }else{ max <- rr[2] * stats::runif(1, 1.01, 1.05) } + + output <- c(min, max) + + } + + if(method.indicator==2){ + + # Remove any missing values + x <- stats::na.omit(xvect) + + # Standardise the variable + x.standardised <- (x-mean(x))/stats::sd(x) + + # Calculate the length of the variable after ommitting any NAs + N.data <- length(x) + + # Check if k is integer and has a value greater than or equal to the pre-specified threshold + # and less than or equal to the length of rows of data.complete minus the pre-specified threshold + if(k < nfilter.kNN | k > (N.data - nfilter.kNN)){ + stop(paste0("k must be greater than or equal to ", nfilter.kNN, " and less than or equal to ", (N.data-nfilter.kNN), "."), call.=FALSE) + }else{ + neighbours = k } - - if(method.indicator==2){ - - # Remove any missing values - x <- stats::na.omit(xvect) - - # Standardise the variable - x.standardised <- (x-mean(x))/stats::sd(x) - - # Calculate the length of the variable after ommitting any NAs - N.data <- length(x) - - # Check if k is integer and has a value greater than or equal to the pre-specified threshold - # and less than or equal to the length of rows of data.complete minus the pre-specified threshold - if(k < nfilter.kNN | k > (N.data - nfilter.kNN)){ - stop(paste0("k must be greater than or equal to ", nfilter.kNN, " and less than or equal to ", (N.data-nfilter.kNN), "."), call.=FALSE) - }else{ - neighbours = k - } - - # Find the k-1 nearest neighbours of each data point - nearest <- RANN::nn2(x.standardised, k = neighbours) - - # Calculate the centroid of each n nearest data points - x.centroid <- matrix() - for (i in 1:N.data){ - x.centroid[i] <- mean(x.standardised[nearest$nn.idx[i,1:neighbours]]) - } - - # Calculate the scaling factor - x.scalingFactor <- stats::sd(x.standardised)/stats::sd(x.centroid) - - # Apply the scaling factor to the centroids - x.masked <- x.centroid * x.scalingFactor - - # Shift the centroids back to the actual position and scale of the original data - x.new <- (x.masked * stats::sd(x)) + mean(x) - - # find the minimum and the maximum of the distribution - min <- min(x.new) - max <- max(x.new) - - output <- c(min, max) - + + # Find the k-1 nearest neighbours of each data point + nearest <- RANN::nn2(x.standardised, k = neighbours) + + # Calculate the centroid of each n nearest data points + x.centroid <- matrix() + for (i in 1:N.data){ + x.centroid[i] <- mean(x.standardised[nearest$nn.idx[i,1:neighbours]]) } - - if(method.indicator==3){ - - # Remove any missing values - x <- stats::na.omit(xvect) - - # Calculate the length of the variable after ommitting any NAs - N.data <- length(x) - - # Check if the percentage of the variance that is specified in the argument 'noise' - # and is used as the variance of the embedded noise is a greater - # than the minimum threshold specified in the filter 'nfilter.noise' - if(noise < nfilter.noise){ - stop(paste0("'noise' must be greater than or equal to ", nfilter.noise), call.=FALSE) - }else{ - percentage <- noise - } - - # the study-specific seed for random number generation - seed <- getOption("datashield.seed") - if (is.null(seed)) - stop("histogramDS requires 'datashield.seed' R option to operate", call.=FALSE) - set.seed(seed) - - # generate the noise-augmented vector - x.new <- x + stats::rnorm(N.data, mean=0, sd=sqrt(percentage*stats::var(x))) - - # find the minimum and the maximum of the distribution - min <- min(x.new) - max <- max(x.new) - - output <- c(min, max) - + + # Calculate the scaling factor + x.scalingFactor <- stats::sd(x.standardised)/stats::sd(x.centroid) + + # Apply the scaling factor to the centroids + x.masked <- x.centroid * x.scalingFactor + + # Shift the centroids back to the actual position and scale of the original data + x.new <- (x.masked * stats::sd(x)) + mean(x) + + # find the minimum and the maximum of the distribution + min <- min(x.new) + max <- max(x.new) + + output <- c(min, max) + + } + + if(method.indicator==3){ + + # Remove any missing values + x <- stats::na.omit(xvect) + + # Calculate the length of the variable after ommitting any NAs + N.data <- length(x) + + # Check if the percentage of the variance that is specified in the argument 'noise' + # and is used as the variance of the embedded noise is a greater + # than the minimum threshold specified in the filter 'nfilter.noise' + if(noise < nfilter.noise){ + stop(paste0("'noise' must be greater than or equal to ", nfilter.noise), call.=FALSE) + }else{ + percentage <- noise } - + + # the study-specific seed for random number generation + seed <- getOption("datashield.seed") + if (is.null(seed)) + stop("histogramDS requires 'datashield.seed' R option to operate", call.=FALSE) + set.seed(seed) + + # generate the noise-augmented vector + x.new <- x + stats::rnorm(N.data, mean=0, sd=sqrt(percentage*stats::var(x))) + + # find the minimum and the maximum of the distribution + min <- min(x.new) + max <- max(x.new) + + output <- c(min, max) + } - - return (output) - + + return(list(range=output, class=class(xvect))) + } # AGGREGATE FUNCTION # histogramDS1 diff --git a/R/histogramDS2.R b/R/histogramDS2.R index f872d01a..4e85b83f 100644 --- a/R/histogramDS2.R +++ b/R/histogramDS2.R @@ -26,6 +26,7 @@ histogramDS2 <- function (x, num.breaks, min, max, method.indicator, k, noise){ xvect <- .loadServersideObject(x) + .checkClass(obj = xvect, obj_name = x, permitted_classes = c("numeric", "integer")) ################################################################## # MODULE 1: CAPTURE THE nfilter SETTINGS # diff --git a/R/scatterPlotDS.R b/R/scatterPlotDS.R index 60832ecc..3599c8f0 100644 --- a/R/scatterPlotDS.R +++ b/R/scatterPlotDS.R @@ -23,7 +23,8 @@ #' deterministic method is selected. #' @param noise the percentage of the initial variance that is used as the variance of the embedded #' noise if the probabilistic method is selected. -#' @return a list with the x and y coordinates of the data to be plot +#' @return a list with the x and y coordinates of the data to be plot, along with the classes of +#' the x and y inputs (\code{class.x} and \code{class.y}) #' @author Demetris Avraam for DataSHIELD Development Team #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export @@ -32,6 +33,8 @@ scatterPlotDS <- function(x.name, y.name, method.indicator, k, noise){ x <- .loadServersideObject(x.name) y <- .loadServersideObject(y.name) + .checkClass(obj = x, obj_name = x.name, permitted_classes = c("numeric", "integer")) + .checkClass(obj = y, obj_name = y.name, permitted_classes = c("numeric", "integer")) ################################################################### # MODULE 1: CAPTURE THE nfilter SETTINGS # @@ -135,8 +138,8 @@ scatterPlotDS <- function(x.name, y.name, method.indicator, k, noise){ } # Return a list with the x and y coordinates of the centroids - return(list(x.new, y.new)) - + return(list(x.new, y.new, class.x=class(x), class.y=class(y))) + } # AGGREGATE FUNCTION # scatterPlotDS diff --git a/man/boxPlotGGDS.Rd b/man/boxPlotGGDS.Rd index 03f297a7..b0d325ac 100644 --- a/man/boxPlotGGDS.Rd +++ b/man/boxPlotGGDS.Rd @@ -29,3 +29,6 @@ is purely geometrical aspects of the plot, as a ggplot object contains all the d parameters are passed. There are three different cases depending if there are grouping variables. The outliers are also removed from the graphical parameters. } +\author{ +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +} diff --git a/man/boxPlotGG_data_TreatmentDS.Rd b/man/boxPlotGG_data_TreatmentDS.Rd index a1ba9781..a38e838e 100644 --- a/man/boxPlotGG_data_TreatmentDS.Rd +++ b/man/boxPlotGG_data_TreatmentDS.Rd @@ -4,10 +4,10 @@ \alias{boxPlotGG_data_TreatmentDS} \title{Arrange data frame to pass it to the boxplot function} \usage{ -boxPlotGG_data_TreatmentDS(table, variables, group = NULL, group2 = NULL) +boxPlotGG_data_TreatmentDS(table.name, variables, group = NULL, group2 = NULL) } \arguments{ -\item{table}{\code{data frame} Table that holds the information to be plotted later} +\item{table.name}{\code{character} Name of a server-side data frame that holds the information to be plotted later} \item{variables}{\code{character vector} Name of the column(s) of the data frame to include on the boxplot} @@ -26,3 +26,6 @@ boxPlotGG_data_TreatmentDS(table, variables, group = NULL, group2 = NULL) \description{ Arrange data frame to pass it to the boxplot function } +\author{ +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +} diff --git a/man/boxPlotGG_data_Treatment_numericDS.Rd b/man/boxPlotGG_data_Treatment_numericDS.Rd index 914493b6..d43e961d 100644 --- a/man/boxPlotGG_data_Treatment_numericDS.Rd +++ b/man/boxPlotGG_data_Treatment_numericDS.Rd @@ -4,17 +4,20 @@ \alias{boxPlotGG_data_Treatment_numericDS} \title{Arrange vector to pass it to the boxplot function} \usage{ -boxPlotGG_data_Treatment_numericDS(vector) +boxPlotGG_data_Treatment_numericDS(vector.name) } \arguments{ -\item{vector}{\code{numeric vector} Vector to arrange to be plotted later} +\item{vector.name}{\code{character} Name of a server-side numeric vector to arrange to be plotted later} } \value{ \code{data frame} with the following structure: \cr - Column 'x': Names on the X axis of the boxplot, aka name of the vector (vector argument) \cr + Column 'x': Names on the X axis of the boxplot, aka name of the vector (vector.name argument) \cr Column 'value': Values for that variable \cr } \description{ Arrange vector to pass it to the boxplot function } +\author{ +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +} diff --git a/man/densityGridDS.Rd b/man/densityGridDS.Rd index 55ff7b3e..8a8c1ee0 100644 --- a/man/densityGridDS.Rd +++ b/man/densityGridDS.Rd @@ -21,7 +21,7 @@ densityGridDS( \item{y}{a character string providing the name of a server-side numerical vector} \item{limits}{a logical expression for whether or not limits of the density grid are defined by -a user. If \code{limits} is set to "FALSE", min and max of xvect and yvect are used as a range. +a user. If \code{limits} is set to "FALSE", min and max of x and y are used as a range. If \code{limits} is set to "TRUE", limits defined by x.min, x.max, y.min and y.max are used.} \item{x.min}{a minimum value for the x axis of the grid density object, if needed} @@ -35,7 +35,8 @@ If \code{limits} is set to "TRUE", limits defined by x.min, x.max, y.min and y.m \item{numints}{a number of intervals for the grid density object, by default is 20} } \value{ -a grid density matrix +a list with the grid density matrix (\code{grid}) and the classes of the x and y inputs +(\code{class.x} and \code{class.y}) } \description{ Generates a density grid that can then be used for heatmap or contour plots. diff --git a/man/heatmapPlotDS.Rd b/man/heatmapPlotDS.Rd index a8e21840..f10c3e21 100644 --- a/man/heatmapPlotDS.Rd +++ b/man/heatmapPlotDS.Rd @@ -22,7 +22,8 @@ noise if the \code{method.indicator} is equal to 2 (i.e. probabilistic method).} } \value{ a list with the x and y coordinates of the centroids if the deterministic method is used -or the x and y coordinated of the noisy data if the probabilistic method is used. +or the x and y coordinated of the noisy data if the probabilistic method is used, along with the +classes of the x and y inputs (\code{class.x} and \code{class.y}) } \description{ This function calculates the coordinates of the centroids for each n nearest neighbours. diff --git a/man/histogramDS1.Rd b/man/histogramDS1.Rd index ef91faef..129ed632 100644 --- a/man/histogramDS1.Rd +++ b/man/histogramDS1.Rd @@ -21,7 +21,8 @@ If the value is set to 3 then the 'probabilistic' method is used.} noise if the \code{method.indicator} is equal to 3 (i.e. probabilistic method).} } \value{ -a numeric vector which contains the minimum and the maximum values of the vector +a list with the numeric vector containing the minimum and the maximum values of the +vector (\code{range}) and the class of the input vector (\code{class}) } \description{ this function returns the minimum and maximum of the input numeric vector which diff --git a/man/scatterPlotDS.Rd b/man/scatterPlotDS.Rd index 4f715d2c..96a08442 100644 --- a/man/scatterPlotDS.Rd +++ b/man/scatterPlotDS.Rd @@ -22,7 +22,8 @@ deterministic method is selected.} noise if the probabilistic method is selected.} } \value{ -a list with the x and y coordinates of the data to be plot +a list with the x and y coordinates of the data to be plot, along with the classes of +the x and y inputs (\code{class.x} and \code{class.y}) } \description{ This function uses two disclosure control methods to generate non-disclosive diff --git a/tests/testthat/test-smk-boxPlotGGDS.R b/tests/testthat/test-smk-boxPlotGGDS.R new file mode 100644 index 00000000..ff1a4070 --- /dev/null +++ b/tests/testthat/test-smk-boxPlotGGDS.R @@ -0,0 +1,53 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("boxPlotGGDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("boxPlotGGDS::smk") +test_that("boxPlotGGDS, no grouping", { + boxPlotRawData <- data.frame(x = rep("v1", 20), value = c(1:20)) + + res <- boxPlotGGDS("boxPlotRawData") + + expect_length(res, 2) + expect_equal(res[[2]], "no_group") +}) + +test_that("boxPlotGGDS, single grouping", { + boxPlotRawData <- data.frame(x = rep("v1", 20), value = c(1:20), group = factor(rep(c("a", "b"), 10))) + + res <- boxPlotGGDS("boxPlotRawData", group = "group") + + expect_length(res, 2) + expect_equal(res[[2]], "single_group") +}) + +test_that("boxPlotGGDS fails when data_table.name references nonexistent object", { + expect_error(boxPlotGGDS("nonexistent_obj"), "does not exist") +}) + +# +# Done +# + +# context("boxPlotGGDS::smk::shutdown") + +# context("boxPlotGGDS::smk::done") diff --git a/tests/testthat/test-smk-boxPlotGG_data_TreatmentDS.R b/tests/testthat/test-smk-boxPlotGG_data_TreatmentDS.R new file mode 100644 index 00000000..30510817 --- /dev/null +++ b/tests/testthat/test-smk-boxPlotGG_data_TreatmentDS.R @@ -0,0 +1,61 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("boxPlotGG_data_TreatmentDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("boxPlotGG_data_TreatmentDS::smk") +test_that("boxPlotGG_data_TreatmentDS, no grouping", { + D <- data.frame(v1 = c(1:20), v2 = c(20:1)) + + res <- boxPlotGG_data_TreatmentDS("D", variables = c("v1", "v2")) + + expect_true(all(c("x", "value") %in% names(res))) +}) + +test_that("boxPlotGG_data_TreatmentDS, single grouping", { + D <- data.frame(v1 = c(1:20), group = factor(rep(c("a", "b"), 10))) + + res <- boxPlotGG_data_TreatmentDS("D", variables = c("v1"), group = "group") + + expect_true(all(c("x", "value", "group") %in% names(res))) +}) + +test_that("boxPlotGG_data_TreatmentDS fails when table.name references nonexistent object", { + expect_error(boxPlotGG_data_TreatmentDS("nonexistent_obj", variables = c("v1")), "does not exist") +}) + +test_that("boxPlotGG_data_TreatmentDS fails when a variable is not numeric or integer", { + D <- data.frame(v1 = c("a", "b", "c")) + expect_error(boxPlotGG_data_TreatmentDS("D", variables = c("v1")), "must be of type numeric or integer") +}) + +test_that("boxPlotGG_data_TreatmentDS fails when group is not a factor", { + D <- data.frame(v1 = c(1:20), group = c(1:20)) + expect_error(boxPlotGG_data_TreatmentDS("D", variables = c("v1"), group = "group"), "must be of type factor") +}) + +# +# Done +# + +# context("boxPlotGG_data_TreatmentDS::smk::shutdown") + +# context("boxPlotGG_data_TreatmentDS::smk::done") diff --git a/tests/testthat/test-smk-boxPlotGG_data_Treatment_numericDS.R b/tests/testthat/test-smk-boxPlotGG_data_Treatment_numericDS.R new file mode 100644 index 00000000..58c14448 --- /dev/null +++ b/tests/testthat/test-smk-boxPlotGG_data_Treatment_numericDS.R @@ -0,0 +1,49 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("boxPlotGG_data_Treatment_numericDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("boxPlotGG_data_Treatment_numericDS::smk") +test_that("boxPlotGG_data_Treatment_numericDS", { + v1 <- c(1:20) + + res <- boxPlotGG_data_Treatment_numericDS("v1") + + expect_equal(unique(res$x), "v1") + expect_equal(res$value, v1) +}) + +test_that("boxPlotGG_data_Treatment_numericDS fails when vector.name references nonexistent object", { + expect_error(boxPlotGG_data_Treatment_numericDS("nonexistent_obj"), "does not exist") +}) + +test_that("boxPlotGG_data_Treatment_numericDS fails when vector is not numeric or integer", { + v1 <- c("a", "b", "c") + expect_error(boxPlotGG_data_Treatment_numericDS("v1"), "must be of type numeric or integer") +}) + +# +# Done +# + +# context("boxPlotGG_data_Treatment_numericDS::smk::shutdown") + +# context("boxPlotGG_data_Treatment_numericDS::smk::done") diff --git a/tests/testthat/test-smk-densityGridDS.R b/tests/testthat/test-smk-densityGridDS.R index b0b4f00c..05efb14f 100644 --- a/tests/testthat/test-smk-densityGridDS.R +++ b/tests/testthat/test-smk-densityGridDS.R @@ -39,13 +39,15 @@ test_that("densityGridDS", { res <- densityGridDS(x="xvect", y="yvect", limits=FALSE, x.min=NULL, x.max=NULL, y.min=NULL, y.max=NULL, numints=numints) - expect_equal(class(res), c("matrix","array")) - expect_equal(colnames(res), c("", "", "", "x.mids", "y.mids")) - expect_equal(as.numeric(round(res[1,], digits=3)), c(3.000, 0.000, 0.000, 8.798, 13.870)) - expect_equal(as.numeric(round(res[2,], digits=3)), c(4.000, 5.000, 0.000, 10.195, 16.870)) - expect_equal(as.numeric(round(res[3,], digits=3)), c(3.000, 0.000, 0.000, 11.592, 19.870)) - - expect_equal(names(dimnames(res))[2], "Number of invalid cells (cells with counts >0 and < nfilter.tab ) is 4") + expect_equal(class(res$grid), c("matrix","array")) + expect_equal(colnames(res$grid), c("", "", "", "x.mids", "y.mids")) + expect_equal(as.numeric(round(res$grid[1,], digits=3)), c(3.000, 0.000, 0.000, 8.798, 13.870)) + expect_equal(as.numeric(round(res$grid[2,], digits=3)), c(4.000, 5.000, 0.000, 10.195, 16.870)) + expect_equal(as.numeric(round(res$grid[3,], digits=3)), c(3.000, 0.000, 0.000, 11.592, 19.870)) + + expect_equal(names(dimnames(res$grid))[2], "Number of invalid cells (cells with counts >0 and < nfilter.tab ) is 4") + expect_equal(res$class.x, "numeric") + expect_equal(res$class.y, "numeric") }) @@ -59,6 +61,18 @@ test_that("densityGridDS fails when y references nonexistent object", { expect_error(densityGridDS(x="yvect", y="nonexistent_obj", numints=3), "does not exist") }) +test_that("densityGridDS fails when x is not numeric or integer", { + xvect <- c("a", "b", "c") + yvect <- c(1, 2, 3) + expect_error(densityGridDS(x="xvect", y="yvect", numints=3), "must be of type numeric or integer") +}) + +test_that("densityGridDS fails when y is not numeric or integer", { + xvect <- c(1, 2, 3) + yvect <- c("a", "b", "c") + expect_error(densityGridDS(x="xvect", y="yvect", numints=3), "must be of type numeric or integer") +}) + # # Done # diff --git a/tests/testthat/test-smk-heatmapPlotDS.R b/tests/testthat/test-smk-heatmapPlotDS.R new file mode 100644 index 00000000..b205a9e3 --- /dev/null +++ b/tests/testthat/test-smk-heatmapPlotDS.R @@ -0,0 +1,66 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("heatmapPlotDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("heatmapPlotDS::smk") +test_that("heatmapPlotDS, deterministic method", { + xvect <- c(1:20) + yvect <- c(20:1) + + res <- heatmapPlotDS("xvect", "yvect", k=3, noise=0.25, method.indicator=1) + + expect_length(res, 4) + expect_length(res[[1]], 20) + expect_length(res[[2]], 20) + expect_equal(res$class.x, "integer") + expect_equal(res$class.y, "integer") +}) + +test_that("heatmapPlotDS fails when x references nonexistent object", { + yvect <- c(20:1) + expect_error(heatmapPlotDS("nonexistent_obj", "yvect", k=3, noise=0.25, method.indicator=1), "does not exist") +}) + +test_that("heatmapPlotDS fails when y references nonexistent object", { + xvect <- c(1:20) + expect_error(heatmapPlotDS("xvect", "nonexistent_obj", k=3, noise=0.25, method.indicator=1), "does not exist") +}) + +test_that("heatmapPlotDS fails when x is not numeric or integer", { + xvect <- c("a", "b", "c") + yvect <- c(1, 2, 3) + expect_error(heatmapPlotDS("xvect", "yvect", k=3, noise=0.25, method.indicator=1), "must be of type numeric or integer") +}) + +test_that("heatmapPlotDS fails when y is not numeric or integer", { + xvect <- c(1, 2, 3) + yvect <- c("a", "b", "c") + expect_error(heatmapPlotDS("xvect", "yvect", k=3, noise=0.25, method.indicator=1), "must be of type numeric or integer") +}) + +# +# Done +# + +# context("heatmapPlotDS::smk::shutdown") + +# context("heatmapPlotDS::smk::done") diff --git a/tests/testthat/test-smk-histogramDS1.R b/tests/testthat/test-smk-histogramDS1.R new file mode 100644 index 00000000..670c4eda --- /dev/null +++ b/tests/testthat/test-smk-histogramDS1.R @@ -0,0 +1,51 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("histogramDS1::smk::setup") + +set.standard.disclosure.settings() +set.random.seed.setting(1234) + +# +# Tests +# + +# context("histogramDS1::smk") +test_that("histogramDS1, smallCellsRule method", { + xvect <- c(1:100) + + res <- histogramDS1("xvect", method.indicator=1, k=3, noise=0.25) + + expect_length(res, 2) + expect_equal(res$class, "integer") + expect_length(res$range, 2) +}) + +test_that("histogramDS1 fails when x references nonexistent object", { + expect_error(histogramDS1("nonexistent_obj", method.indicator=1, k=3, noise=0.25), "does not exist") +}) + +test_that("histogramDS1 fails when x is not numeric or integer", { + xvect <- c("a", "b", "c") + expect_error(histogramDS1("xvect", method.indicator=1, k=3, noise=0.25), "must be of type numeric or integer") +}) + +# +# Done +# + +# context("histogramDS1::smk::shutdown") + +# context("histogramDS1::smk::done") diff --git a/tests/testthat/test-smk-histogramDS2.R b/tests/testthat/test-smk-histogramDS2.R new file mode 100644 index 00000000..a0dd7c99 --- /dev/null +++ b/tests/testthat/test-smk-histogramDS2.R @@ -0,0 +1,50 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("histogramDS2::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("histogramDS2::smk") +test_that("histogramDS2, smallCellsRule method", { + xvect <- c(1:100) + + res <- histogramDS2("xvect", num.breaks=10, min=1, max=100, method.indicator=1, k=3, noise=0.25) + + expect_length(res, 2) + expect_true(inherits(res$histobject, "histogram")) + expect_equal(res$invalidcells, 0) +}) + +test_that("histogramDS2 fails when x references nonexistent object", { + expect_error(histogramDS2("nonexistent_obj", num.breaks=10, min=1, max=100, method.indicator=1, k=3, noise=0.25), "does not exist") +}) + +test_that("histogramDS2 fails when x is not numeric or integer", { + xvect <- c("a", "b", "c") + expect_error(histogramDS2("xvect", num.breaks=10, min=1, max=100, method.indicator=1, k=3, noise=0.25), "must be of type numeric or integer") +}) + +# +# Done +# + +# context("histogramDS2::smk::shutdown") + +# context("histogramDS2::smk::done") diff --git a/tests/testthat/test-smk-scatterPlotDS.R b/tests/testthat/test-smk-scatterPlotDS.R new file mode 100644 index 00000000..94efdb0a --- /dev/null +++ b/tests/testthat/test-smk-scatterPlotDS.R @@ -0,0 +1,66 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("scatterPlotDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("scatterPlotDS::smk") +test_that("scatterPlotDS, deterministic method", { + xvect <- c(1:20) + yvect <- c(20:1) + + res <- scatterPlotDS("xvect", "yvect", method.indicator=1, k=3, noise=0.25) + + expect_length(res, 4) + expect_length(res[[1]], 20) + expect_length(res[[2]], 20) + expect_equal(res$class.x, "integer") + expect_equal(res$class.y, "integer") +}) + +test_that("scatterPlotDS fails when x references nonexistent object", { + yvect <- c(20:1) + expect_error(scatterPlotDS("nonexistent_obj", "yvect", method.indicator=1, k=3, noise=0.25), "does not exist") +}) + +test_that("scatterPlotDS fails when y references nonexistent object", { + xvect <- c(1:20) + expect_error(scatterPlotDS("xvect", "nonexistent_obj", method.indicator=1, k=3, noise=0.25), "does not exist") +}) + +test_that("scatterPlotDS fails when x is not numeric or integer", { + xvect <- c("a", "b", "c") + yvect <- c(1, 2, 3) + expect_error(scatterPlotDS("xvect", "yvect", method.indicator=1, k=3, noise=0.25), "must be of type numeric or integer") +}) + +test_that("scatterPlotDS fails when y is not numeric or integer", { + xvect <- c(1, 2, 3) + yvect <- c("a", "b", "c") + expect_error(scatterPlotDS("xvect", "yvect", method.indicator=1, k=3, noise=0.25), "must be of type numeric or integer") +}) + +# +# Done +# + +# context("scatterPlotDS::smk::shutdown") + +# context("scatterPlotDS::smk::done") From 24f9939154fcadafca21fcb04ec53ec3f4501d87 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Tue, 15 Sep 2026 09:41:11 +0200 Subject: [PATCH 30/30] removed mistakenly added copywright --- tests/testthat/test-smk-boxPlotGGDS.R | 11 ----------- tests/testthat/test-smk-boxPlotGG_data_TreatmentDS.R | 11 ----------- .../test-smk-boxPlotGG_data_Treatment_numericDS.R | 11 ----------- tests/testthat/test-smk-heatmapPlotDS.R | 11 ----------- tests/testthat/test-smk-histogramDS1.R | 11 ----------- tests/testthat/test-smk-histogramDS2.R | 11 ----------- tests/testthat/test-smk-scatterPlotDS.R | 11 ----------- 7 files changed, 77 deletions(-) diff --git a/tests/testthat/test-smk-boxPlotGGDS.R b/tests/testthat/test-smk-boxPlotGGDS.R index ff1a4070..fe7db46e 100644 --- a/tests/testthat/test-smk-boxPlotGGDS.R +++ b/tests/testthat/test-smk-boxPlotGGDS.R @@ -1,14 +1,3 @@ -#------------------------------------------------------------------------------- -# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. -# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. -# -# This program and the accompanying materials -# are made available under the terms of the GNU Public License v3.0. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- - # # Set up # diff --git a/tests/testthat/test-smk-boxPlotGG_data_TreatmentDS.R b/tests/testthat/test-smk-boxPlotGG_data_TreatmentDS.R index 30510817..0deb5ff5 100644 --- a/tests/testthat/test-smk-boxPlotGG_data_TreatmentDS.R +++ b/tests/testthat/test-smk-boxPlotGG_data_TreatmentDS.R @@ -1,14 +1,3 @@ -#------------------------------------------------------------------------------- -# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. -# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. -# -# This program and the accompanying materials -# are made available under the terms of the GNU Public License v3.0. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- - # # Set up # diff --git a/tests/testthat/test-smk-boxPlotGG_data_Treatment_numericDS.R b/tests/testthat/test-smk-boxPlotGG_data_Treatment_numericDS.R index 58c14448..354de5cd 100644 --- a/tests/testthat/test-smk-boxPlotGG_data_Treatment_numericDS.R +++ b/tests/testthat/test-smk-boxPlotGG_data_Treatment_numericDS.R @@ -1,14 +1,3 @@ -#------------------------------------------------------------------------------- -# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. -# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. -# -# This program and the accompanying materials -# are made available under the terms of the GNU Public License v3.0. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- - # # Set up # diff --git a/tests/testthat/test-smk-heatmapPlotDS.R b/tests/testthat/test-smk-heatmapPlotDS.R index b205a9e3..1313d608 100644 --- a/tests/testthat/test-smk-heatmapPlotDS.R +++ b/tests/testthat/test-smk-heatmapPlotDS.R @@ -1,14 +1,3 @@ -#------------------------------------------------------------------------------- -# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. -# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. -# -# This program and the accompanying materials -# are made available under the terms of the GNU Public License v3.0. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- - # # Set up # diff --git a/tests/testthat/test-smk-histogramDS1.R b/tests/testthat/test-smk-histogramDS1.R index 670c4eda..10559b97 100644 --- a/tests/testthat/test-smk-histogramDS1.R +++ b/tests/testthat/test-smk-histogramDS1.R @@ -1,14 +1,3 @@ -#------------------------------------------------------------------------------- -# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. -# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. -# -# This program and the accompanying materials -# are made available under the terms of the GNU Public License v3.0. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- - # # Set up # diff --git a/tests/testthat/test-smk-histogramDS2.R b/tests/testthat/test-smk-histogramDS2.R index a0dd7c99..da26d99a 100644 --- a/tests/testthat/test-smk-histogramDS2.R +++ b/tests/testthat/test-smk-histogramDS2.R @@ -1,14 +1,3 @@ -#------------------------------------------------------------------------------- -# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. -# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. -# -# This program and the accompanying materials -# are made available under the terms of the GNU Public License v3.0. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- - # # Set up # diff --git a/tests/testthat/test-smk-scatterPlotDS.R b/tests/testthat/test-smk-scatterPlotDS.R index 94efdb0a..7fee3d3e 100644 --- a/tests/testthat/test-smk-scatterPlotDS.R +++ b/tests/testthat/test-smk-scatterPlotDS.R @@ -1,14 +1,3 @@ -#------------------------------------------------------------------------------- -# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. -# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. -# -# This program and the accompanying materials -# are made available under the terms of the GNU Public License v3.0. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- - # # Set up #