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 1/3] 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 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 2/3] 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 3/3] 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})