From 7934950d7b3a2ca2388ee5c67bcb015c1400027f Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 16 Apr 2026 18:57:48 +0200 Subject: [PATCH 1/6] refactor: batch-10 server-side splines, tables, misc functions --- R/elsplineDS.R | 2 +- R/getWGSRDS.R | 10 +++++---- R/hetcorDS.R | 2 +- R/lexisDS1.R | 2 +- R/lexisDS2.R | 24 +++++++++++++-------- R/lsplineDS.R | 2 +- R/metadataDS.R | 2 +- R/nsDS.R | 2 +- R/qlsplineDS.R | 2 +- R/rowColCalcDS.R | 14 +++++++------ R/tableDS.R | 8 +++---- R/tableDS.assign.R | 6 +++--- R/tableDS2.R | 10 ++++----- R/tapplyDS.R | 12 ++++++----- R/tapplyDS.assign.R | 29 +++++++++++++------------- man/rowColCalcDS.Rd | 4 ++-- tests/testthat/test-smk-rowColCalcDS.R | 8 +++---- 17 files changed, 75 insertions(+), 64 deletions(-) diff --git a/R/elsplineDS.R b/R/elsplineDS.R index c4dcfda8..7b30dd7e 100644 --- a/R/elsplineDS.R +++ b/R/elsplineDS.R @@ -54,7 +54,7 @@ elsplineDS <- function(x = x, n = n, marginal = FALSE, names = NULL){ structure(rval, knots = knots, marginal = marginal, class = c("lspline", "matrix")) } - x <- eval(parse(text=x), envir = parent.frame()) + x <- .loadServersideObject(x) stopifnot(n >= 2) k <- seq(min(x, na.rm = TRUE), max(x, na.rm = TRUE), length.out = n + 1)[-c(1, n + 1)] diff --git a/R/getWGSRDS.R b/R/getWGSRDS.R index 225ce433..7b27a35c 100644 --- a/R/getWGSRDS.R +++ b/R/getWGSRDS.R @@ -53,11 +53,13 @@ #' getWGSRDS <- function(sex, firstPart, secondPart, index, standing=NA, thirdPart=NA){ - sex <- eval(parse(text=sex), envir = parent.frame()) - firstPart <- eval(parse(text=firstPart), envir = parent.frame()) - secondPart <- eval(parse(text=secondPart), envir = parent.frame()) + sex <- .loadServersideObject(sex) + firstPart <- .loadServersideObject(firstPart) + if (!is.na(secondPart)){ + secondPart <- .loadServersideObject(secondPart) + } if (!is.na(thirdPart)){ - thirdPart <- eval(parse(text=thirdPart), envir = parent.frame()) + thirdPart <- .loadServersideObject(thirdPart) } # access the internal reference data diff --git a/R/hetcorDS.R b/R/hetcorDS.R index d561ce30..61b4f4cf 100644 --- a/R/hetcorDS.R +++ b/R/hetcorDS.R @@ -28,7 +28,7 @@ #' hetcorDS <- function(data, ML, std.err, bins, pd, use){ - data <- eval(parse(text=data), envir = parent.frame()) + data <- .loadServersideObject(data) out <- polycor::hetcor(data = data, ML = ML, std.err = std.err, bins = bins, pd = pd, use = use) diff --git a/R/lexisDS1.R b/R/lexisDS1.R index 6c0f8de7..8a1aac9c 100644 --- a/R/lexisDS1.R +++ b/R/lexisDS1.R @@ -28,7 +28,7 @@ lexisDS1 <- function(exitCol=NULL){ stop(errorMessage, call. = FALSE) } - exposure <- eval(parse(text=exitCol), envir = parent.frame()) + exposure <- .loadServersideObject(exitCol) max.time <- max(exposure, na.rm=TRUE) random.multiplier <- stats::runif(1,1.01,1.05) diff --git a/R/lexisDS2.R b/R/lexisDS2.R index d63989d2..02f8168f 100644 --- a/R/lexisDS2.R +++ b/R/lexisDS2.R @@ -46,10 +46,10 @@ lexisDS2 <- function(datatext=NULL, intervalWidth, maxmaxtime, idCol, entryCol, #nfilter.string<-as.numeric(thr$nfilter.string) ############################################################# - starttime <- eval(parse(text=entryCol), envir = parent.frame()) - endtime <- eval(parse(text=exitCol), envir = parent.frame()) - cens <- eval(parse(text=statusCol), envir = parent.frame()) - id.orig <- eval(parse(text=idCol), envir = parent.frame()) + starttime <- .loadServersideObject(entryCol) + endtime <- .loadServersideObject(exitCol) + cens <- .loadServersideObject(statusCol) + id.orig <- .loadServersideObject(idCol) starttime <- as.numeric(starttime) endtime <- as.numeric(endtime) @@ -74,13 +74,19 @@ lexisDS2 <- function(datatext=NULL, intervalWidth, maxmaxtime, idCol, entryCol, #IDENTIFY VARIABLES TO BE CARRIED WITH THE EXPANDED SURVIVAL DATA if(is.null(vartext)){ - datatext2<-paste0("data.frame(",datatext,")") - DF <- eval(parse(text=datatext2), envir = parent.frame()) + col.names <- unlist(strsplit(datatext, split=",")) + col.list <- vector("list", length(col.names)) + for(i in seq_along(col.names)) col.list[[i]] <- .loadServersideObject(col.names[i]) + DF <- data.frame(col.list) + colnames(DF) <- col.names } - + if(!is.null(vartext)){ - vartext2<-paste0("data.frame(",vartext,")") - DF<-eval(parse(text=vartext2), envir = parent.frame()) + col.names <- unlist(strsplit(vartext, split=",")) + col.list <- vector("list", length(col.names)) + for(i in seq_along(col.names)) col.list[[i]] <- .loadServersideObject(col.names[i]) + DF <- data.frame(col.list) + colnames(DF) <- col.names } if(is.null(datatext)&&is.null(vartext)){ diff --git a/R/lsplineDS.R b/R/lsplineDS.R index 86475bba..d8dbce8c 100644 --- a/R/lsplineDS.R +++ b/R/lsplineDS.R @@ -51,7 +51,7 @@ lsplineDS <- function(x = x, knots = NULL, marginal = FALSE, names = NULL){ structure(rval, knots = knots, marginal = marginal, class = c("lspline", "matrix")) } - x <- eval(parse(text=x), envir = parent.frame()) + x <- .loadServersideObject(x) out <- lspline_copy(x = x, knots = knots, marginal = marginal, names = names) diff --git a/R/metadataDS.R b/R/metadataDS.R index a416ed61..3c303176 100644 --- a/R/metadataDS.R +++ b/R/metadataDS.R @@ -16,7 +16,7 @@ metadataDS <- function(x) if ((! is.character(x)) || (length(x) != 1)) stop("Variable's name isn't be single character vector", call. = FALSE) - x.var <- eval(parse(text=x), envir = parent.frame()) + x.var <- .loadServersideObject(x) if (is.null(x.var)) stop("Variable can't be NULL", call. = FALSE) diff --git a/R/nsDS.R b/R/nsDS.R index 6314c4b8..a12227c6 100644 --- a/R/nsDS.R +++ b/R/nsDS.R @@ -33,7 +33,7 @@ nsDS <- function(x, df, knots, intercept, Boundary.knots){ thr <- dsBase::listDisclosureSettingsDS() nfilter.tab <- as.numeric(thr$nfilter.tab) - x <- eval(parse(text=x), envir = parent.frame()) + x <- .loadServersideObject(x) if(is.null(Boundary.knots)){ Boundary.knots <- range(x, na.rm=TRUE) diff --git a/R/qlsplineDS.R b/R/qlsplineDS.R index 3df267f8..254b09c9 100644 --- a/R/qlsplineDS.R +++ b/R/qlsplineDS.R @@ -59,7 +59,7 @@ qlsplineDS <- function(x = x, q = q, na.rm = TRUE, marginal = FALSE, names = NUL structure(rval, knots = knots, marginal = marginal, class = c("lspline", "matrix")) } - x <- eval(parse(text=x), envir = parent.frame()) + x <- .loadServersideObject(x) if (length(q) == 1 && q >= 2) { q <- seq(0, 1, length.out = q + 1)[-c(1, q + 1)] diff --git a/R/rowColCalcDS.R b/R/rowColCalcDS.R index e7a35832..396f8d9f 100644 --- a/R/rowColCalcDS.R +++ b/R/rowColCalcDS.R @@ -4,15 +4,17 @@ #' 'rowMeans' and 'colMeans'. #' @details the output is returned to the user only the number of entries in the #' output vector is greater or equal to the allowed size. -#' @param dataset an array of two or more dimensions. +#' @param dataset.name a character string providing the name of a server-side array of two or more dimensions. #' @param operation an integer that indicates the operation to carry out: #' 1 for 'rowSums', 2 for 'colSums', 3 for 'rowMeans' or 4 for 'colMeans' #' @return a numeric vector #' @export #' @author Gaye, A. #' -rowColCalcDS <- function (dataset, operation) { - +rowColCalcDS <- function (dataset.name, operation) { + + dataset <- .loadServersideObject(dataset.name) + if(operation == 1){ result <- rowSums(dataset, na.rm=TRUE) } @@ -25,7 +27,7 @@ rowColCalcDS <- function (dataset, operation) { if(operation == 4){ result <- colMeans(dataset, na.rm=TRUE) } - + # check if the output is valid (i.e. meets DataSHIELD criteria) check <- isValidDS(result) if(check){ @@ -34,7 +36,7 @@ rowColCalcDS <- function (dataset, operation) { resultNA <- rep(NA, length(result)) return(resultNA) } - + return(result) - + } \ No newline at end of file diff --git a/R/tableDS.R b/R/tableDS.R index c190ffc3..6f059f52 100644 --- a/R/tableDS.R +++ b/R/tableDS.R @@ -55,7 +55,7 @@ nfilter.tab<-as.numeric(thr$nfilter.tab) # if(!is.null(force.nfilter.transmit)) { -force.nfilter.active<-eval(parse(text=force.nfilter.transmit), envir = parent.frame()) +force.nfilter.active<-.loadServersideObject(force.nfilter.transmit) if(force.nfilter.active Date: Thu, 16 Apr 2026 19:26:54 +0200 Subject: [PATCH 2/6] refactor: add server-side .checkClass for getWGSRDS, rowColCalcDS --- R/getWGSRDS.R | 7 +++++++ R/rowColCalcDS.R | 1 + 2 files changed, 8 insertions(+) diff --git a/R/getWGSRDS.R b/R/getWGSRDS.R index 7b27a35c..c308d6d8 100644 --- a/R/getWGSRDS.R +++ b/R/getWGSRDS.R @@ -53,13 +53,20 @@ #' getWGSRDS <- function(sex, firstPart, secondPart, index, standing=NA, thirdPart=NA){ + sex.name <- sex + firstPart.name <- firstPart sex <- .loadServersideObject(sex) firstPart <- .loadServersideObject(firstPart) + .checkClass(obj = firstPart, obj_name = firstPart.name, permitted_classes = c("numeric", "integer")) if (!is.na(secondPart)){ + secondPart.name <- secondPart secondPart <- .loadServersideObject(secondPart) + .checkClass(obj = secondPart, obj_name = secondPart.name, permitted_classes = c("numeric", "integer")) } if (!is.na(thirdPart)){ + thirdPart.name <- thirdPart thirdPart <- .loadServersideObject(thirdPart) + .checkClass(obj = thirdPart, obj_name = thirdPart.name, permitted_classes = c("numeric", "integer")) } # access the internal reference data diff --git a/R/rowColCalcDS.R b/R/rowColCalcDS.R index 396f8d9f..bbc0c9e7 100644 --- a/R/rowColCalcDS.R +++ b/R/rowColCalcDS.R @@ -14,6 +14,7 @@ rowColCalcDS <- function (dataset.name, operation) { dataset <- .loadServersideObject(dataset.name) + .checkClass(obj = dataset, obj_name = dataset.name, permitted_classes = c("data.frame", "matrix")) if(operation == 1){ result <- rowSums(dataset, na.rm=TRUE) From cbbfb0aa26dcb9b990709a9610559e85a0c48176 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 16 Apr 2026 19:50:10 +0200 Subject: [PATCH 3/6] docs: updated authorship --- R/elsplineDS.R | 1 + R/getWGSRDS.R | 1 + R/hetcorDS.R | 1 + R/lexisDS1.R | 1 + R/lexisDS2.R | 1 + R/lsplineDS.R | 1 + R/metadataDS.R | 1 + R/nsDS.R | 1 + R/qlsplineDS.R | 1 + R/rowColCalcDS.R | 1 + R/tableDS.R | 1 + R/tableDS.assign.R | 1 + R/tableDS2.R | 1 + R/tapplyDS.R | 1 + R/tapplyDS.assign.R | 1 + 15 files changed, 15 insertions(+) diff --git a/R/elsplineDS.R b/R/elsplineDS.R index 7b30dd7e..4248a044 100644 --- a/R/elsplineDS.R +++ b/R/elsplineDS.R @@ -18,6 +18,7 @@ #' @return an object of class "lspline" and "matrix", which its name is specified by the #' \code{newobj} argument (or its default name "elspline.newobj"), is assigned on the serverside. #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' elsplineDS <- function(x = x, n = n, marginal = FALSE, names = NULL){ diff --git a/R/getWGSRDS.R b/R/getWGSRDS.R index c308d6d8..619b66af 100644 --- a/R/getWGSRDS.R +++ b/R/getWGSRDS.R @@ -49,6 +49,7 @@ #' @return \code{ds.getWGSR} assigns a numeric vector that includes the z-scores for the #' specified index. #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' getWGSRDS <- function(sex, firstPart, secondPart, index, standing=NA, thirdPart=NA){ diff --git a/R/hetcorDS.R b/R/hetcorDS.R index 61b4f4cf..1dd26dae 100644 --- a/R/hetcorDS.R +++ b/R/hetcorDS.R @@ -24,6 +24,7 @@ #' any missing data were handled: "complete.obs" or "pairwise.complete.obs"; TRUE for ML estimates, #' FALSE for two-step estimates. #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' hetcorDS <- function(data, ML, std.err, bins, pd, use){ diff --git a/R/lexisDS1.R b/R/lexisDS1.R index 8a1aac9c..45bea015 100644 --- a/R/lexisDS1.R +++ b/R/lexisDS1.R @@ -7,6 +7,7 @@ #' @param exitCol a character string specifying the variable holding the time that each individual is censored or fails #' #' @author Burton PR +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' #' @return List with `max.time` #' @export diff --git a/R/lexisDS2.R b/R/lexisDS2.R index 02f8168f..69a2367b 100644 --- a/R/lexisDS2.R +++ b/R/lexisDS2.R @@ -31,6 +31,7 @@ #' 'data' argument is set the full data.frame will be expanded and carried forward #' #' @author Burton PR +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' #' @return List with `expanded.table` #' @export diff --git a/R/lsplineDS.R b/R/lsplineDS.R index d8dbce8c..22d8bdae 100644 --- a/R/lsplineDS.R +++ b/R/lsplineDS.R @@ -15,6 +15,7 @@ #' @return an object of class "lspline" and "matrix", which its name is specified by the #' \code{newobj} argument (or its default name "lspline.newobj"), is assigned on the serverside. #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' lsplineDS <- function(x = x, knots = NULL, marginal = FALSE, names = NULL){ diff --git a/R/metadataDS.R b/R/metadataDS.R index 3c303176..95f22866 100644 --- a/R/metadataDS.R +++ b/R/metadataDS.R @@ -6,6 +6,7 @@ #' @return a list containing the metadata. The elements of the list will depend #' on the metadata available. #' @author Stuart Wheater, for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' metadataDS <- function(x) diff --git a/R/nsDS.R b/R/nsDS.R index a12227c6..0c12d7ae 100644 --- a/R/nsDS.R +++ b/R/nsDS.R @@ -25,6 +25,7 @@ #' arguments to ns, and explicitly give the knots, Boundary.knots etc for use by predict.ns(). #' The object is assigned at each serverside. #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' nsDS <- function(x, df, knots, intercept, Boundary.knots){ diff --git a/R/qlsplineDS.R b/R/qlsplineDS.R index 254b09c9..55a56abf 100644 --- a/R/qlsplineDS.R +++ b/R/qlsplineDS.R @@ -23,6 +23,7 @@ #' @return an object of class "lspline" and "matrix", which its name is specified by the #' \code{newobj} argument (or its default name "qlspline.newobj"), is assigned on the serverside. #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' qlsplineDS <- function(x = x, q = q, na.rm = TRUE, marginal = FALSE, names = NULL){ diff --git a/R/rowColCalcDS.R b/R/rowColCalcDS.R index bbc0c9e7..b1f865dd 100644 --- a/R/rowColCalcDS.R +++ b/R/rowColCalcDS.R @@ -10,6 +10,7 @@ #' @return a numeric vector #' @export #' @author Gaye, A. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' rowColCalcDS <- function (dataset.name, operation) { diff --git a/R/tableDS.R b/R/tableDS.R index 6f059f52..f524cfbe 100644 --- a/R/tableDS.R +++ b/R/tableDS.R @@ -33,6 +33,7 @@ #' of \code{ds.table}. Fully specified by argument of \code{ds.table} #' @return For information see help for \code{ds.table} #' @author Paul Burton for DataSHIELD Development Team, 13/11/2019 +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export tableDS<-function(rvar.transmit, cvar.transmit, stvar.transmit, rvar.all.unique.levels.transmit, cvar.all.unique.levels.transmit, stvar.all.unique.levels.transmit, exclude.transmit, useNA.transmit, force.nfilter.transmit){ diff --git a/R/tableDS.assign.R b/R/tableDS.assign.R index 01d41805..ab676367 100644 --- a/R/tableDS.assign.R +++ b/R/tableDS.assign.R @@ -33,6 +33,7 @@ #' of \code{ds.table}. Fully specified by argument of \code{ds.table} #' @return For information see help for \code{ds.table} #' @author Paul Burton for DataSHIELD Development Team, 13/11/2019 +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export tableDS.assign<-function(rvar.transmit, cvar.transmit, stvar.transmit, rvar.all.unique.levels.transmit, cvar.all.unique.levels.transmit, stvar.all.unique.levels.transmit, exclude.transmit, useNA.transmit){ diff --git a/R/tableDS2.R b/R/tableDS2.R index 3f58dccd..81886679 100644 --- a/R/tableDS2.R +++ b/R/tableDS2.R @@ -28,6 +28,7 @@ #' For more information see help for \code{ds.table} #' @return For information see help for \code{ds.table} #' @author Paul Burton for DataSHIELD Development Team, 13/11/2019 +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export tableDS2 <- function(newobj,rvar.transmit,cvar.transmit,stvar.transmit){ diff --git a/R/tapplyDS.R b/R/tapplyDS.R index 3da0a3a3..5b620144 100644 --- a/R/tapplyDS.R +++ b/R/tapplyDS.R @@ -13,6 +13,7 @@ #' @return an array of the summarized values created by the tapplyDS function. This array #' is returned to the clientside. It has the same number of dimensions as INDEX. #' @author Paul Burton, Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export tapplyDS <- function(X.name, INDEX.names.transmit, FUN.name){ diff --git a/R/tapplyDS.assign.R b/R/tapplyDS.assign.R index 2983f31f..a3917973 100644 --- a/R/tapplyDS.assign.R +++ b/R/tapplyDS.assign.R @@ -13,6 +13,7 @@ #' @return an array of the summarized values created by the \code{tapplyDS.assign} function. This #' array is written as a newobj on the serverside. It has the same number of dimensions as INDEX. #' @author Paul Burton, Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export tapplyDS.assign <- function(X.name, INDEX.names.transmit, FUN.name){ From 5fb83af613e5d7da0c4053aca4a41c88f1a74acf Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 16 Apr 2026 19:50:52 +0200 Subject: [PATCH 4/6] docs: redocumented --- man/elsplineDS.Rd | 2 ++ man/getWGSRDS.Rd | 2 ++ man/hetcorDS.Rd | 2 ++ man/lexisDS1.Rd | 2 ++ man/lexisDS2.Rd | 2 ++ man/lsplineDS.Rd | 2 ++ man/metadataDS.Rd | 2 ++ man/nsDS.Rd | 2 ++ man/qlsplineDS.Rd | 2 ++ man/rowColCalcDS.Rd | 2 ++ man/tableDS.Rd | 2 ++ man/tableDS.assign.Rd | 2 ++ man/tableDS2.Rd | 2 ++ man/tapplyDS.Rd | 2 ++ man/tapplyDS.assign.Rd | 2 ++ 15 files changed, 30 insertions(+) diff --git a/man/elsplineDS.Rd b/man/elsplineDS.Rd index 1d0c7fd5..d3a81fe5 100644 --- a/man/elsplineDS.Rd +++ b/man/elsplineDS.Rd @@ -36,4 +36,6 @@ range of x into n equal-width intervals. } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/getWGSRDS.Rd b/man/getWGSRDS.Rd index 4ecc45b2..98aa2f36 100644 --- a/man/getWGSRDS.Rd +++ b/man/getWGSRDS.Rd @@ -69,4 +69,6 @@ data. } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/hetcorDS.Rd b/man/hetcorDS.Rd index 2745ce65..5c558936 100644 --- a/man/hetcorDS.Rd +++ b/man/hetcorDS.Rd @@ -44,4 +44,6 @@ variables, and polychoric correlations between ordinal variables. } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/lexisDS1.Rd b/man/lexisDS1.Rd index da419723..9b560add 100644 --- a/man/lexisDS1.Rd +++ b/man/lexisDS1.Rd @@ -21,4 +21,6 @@ For more details see the extensive header for ds.lexis. } \author{ Burton PR + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/lexisDS2.Rd b/man/lexisDS2.Rd index 51ca6851..6b9ca122 100644 --- a/man/lexisDS2.Rd +++ b/man/lexisDS2.Rd @@ -62,4 +62,6 @@ For more details see the extensive header for ds.lexis. } \author{ Burton PR + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/lsplineDS.Rd b/man/lsplineDS.Rd index 23445b51..af17aa0f 100644 --- a/man/lsplineDS.Rd +++ b/man/lsplineDS.Rd @@ -33,4 +33,6 @@ in slope as compared to the previous segment. } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/metadataDS.Rd b/man/metadataDS.Rd index f7749090..5851b7a3 100644 --- a/man/metadataDS.Rd +++ b/man/metadataDS.Rd @@ -21,4 +21,6 @@ The function returns the metadata, obtained from attributes function. } \author{ Stuart Wheater, for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/nsDS.Rd b/man/nsDS.Rd index 302bd919..060ff5a3 100644 --- a/man/nsDS.Rd +++ b/man/nsDS.Rd @@ -44,4 +44,6 @@ A primary use is in modeling formula to directly specify a natural spline term i } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/qlsplineDS.Rd b/man/qlsplineDS.Rd index aa14326a..63c81831 100644 --- a/man/qlsplineDS.Rd +++ b/man/qlsplineDS.Rd @@ -42,4 +42,6 @@ probabilities directly (the vector is passed to argument probs of quantile). } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/rowColCalcDS.Rd b/man/rowColCalcDS.Rd index 260a4011..aaf4c93d 100644 --- a/man/rowColCalcDS.Rd +++ b/man/rowColCalcDS.Rd @@ -25,4 +25,6 @@ output vector is greater or equal to the allowed size. } \author{ Gaye, A. + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/tableDS.Rd b/man/tableDS.Rd index 752eb815..7314c2ee 100644 --- a/man/tableDS.Rd +++ b/man/tableDS.Rd @@ -67,4 +67,6 @@ in native R. } \author{ Paul Burton for DataSHIELD Development Team, 13/11/2019 + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/tableDS.assign.Rd b/man/tableDS.assign.Rd index 8214ab3d..4989ec5d 100644 --- a/man/tableDS.assign.Rd +++ b/man/tableDS.assign.Rd @@ -65,4 +65,6 @@ in native R. } \author{ Paul Burton for DataSHIELD Development Team, 13/11/2019 + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/tableDS2.Rd b/man/tableDS2.Rd index 86e27027..1538d621 100644 --- a/man/tableDS2.Rd +++ b/man/tableDS2.Rd @@ -47,4 +47,6 @@ in DataSHIELD and the \code{table} function in native R. } \author{ Paul Burton for DataSHIELD Development Team, 13/11/2019 + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/tapplyDS.Rd b/man/tapplyDS.Rd index b72ed2f5..c7d62d84 100644 --- a/man/tapplyDS.Rd +++ b/man/tapplyDS.Rd @@ -31,4 +31,6 @@ see details for \code{ds.tapply} function } \author{ Paul Burton, Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/tapplyDS.assign.Rd b/man/tapplyDS.assign.Rd index f57d4f03..7beac224 100644 --- a/man/tapplyDS.assign.Rd +++ b/man/tapplyDS.assign.Rd @@ -31,4 +31,6 @@ see details for \code{ds.tapply.assign} function } \author{ Paul Burton, Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } From f7b5267bb69c0f43084a7919c3cf801c2fd4414e Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Tue, 15 Sep 2026 21:27:28 +0200 Subject: [PATCH 5/6] tidied up refactor --- R/lexisDS2.R | 34 ++++++--- R/rowColCalcDS.R | 13 ++-- R/tapplyDS.assign.R | 16 ++--- tests/testthat/test-smk-elsplineDS.R | 49 +++++++++++++ tests/testthat/test-smk-getWGSRDS.R | 31 +++++++++ tests/testthat/test-smk-lexisDS1.R | 50 ++++++++++++++ tests/testthat/test-smk-lexisDS2.R | 88 ++++++++++++++++++++++++ tests/testthat/test-smk-lsplineDS.R | 49 +++++++++++++ tests/testthat/test-smk-nsDS.R | 48 +++++++++++++ tests/testthat/test-smk-qlsplineDS.R | 48 +++++++++++++ tests/testthat/test-smk-rowColCalcDS.R | 15 ++++ tests/testthat/test-smk-tableDS.R | 60 ++++++++++++++++ tests/testthat/test-smk-tableDS.assign.R | 50 ++++++++++++++ tests/testthat/test-smk-tableDS2.R | 54 +++++++++++++++ 14 files changed, 581 insertions(+), 24 deletions(-) create mode 100644 tests/testthat/test-smk-elsplineDS.R create mode 100644 tests/testthat/test-smk-lexisDS1.R create mode 100644 tests/testthat/test-smk-lexisDS2.R create mode 100644 tests/testthat/test-smk-lsplineDS.R create mode 100644 tests/testthat/test-smk-nsDS.R create mode 100644 tests/testthat/test-smk-qlsplineDS.R create mode 100644 tests/testthat/test-smk-tableDS.R create mode 100644 tests/testthat/test-smk-tableDS.assign.R create mode 100644 tests/testthat/test-smk-tableDS2.R diff --git a/R/lexisDS2.R b/R/lexisDS2.R index 69a2367b..5696636d 100644 --- a/R/lexisDS2.R +++ b/R/lexisDS2.R @@ -73,23 +73,39 @@ lexisDS2 <- function(datatext=NULL, intervalWidth, maxmaxtime, idCol, entryCol, length.collapseDF <- length(idSeq) #IDENTIFY VARIABLES TO BE CARRIED WITH THE EXPANDED SURVIVAL DATA - - if(is.null(vartext)){ + + # loads each comma-separated name; whole data.frame names are unpacked into + # their own columns (matching data.frame()'s handling of a data.frame argument), + # single columns are added under their make.names()-sanitised name (matching + # data.frame()'s default naming for a non-symbol argument such as D$var) + if(is.null(vartext) && !is.null(datatext)){ col.names <- unlist(strsplit(datatext, split=",")) - col.list <- vector("list", length(col.names)) - for(i in seq_along(col.names)) col.list[[i]] <- .loadServersideObject(col.names[i]) + col.list <- list() + for(nm in col.names){ + obj <- .loadServersideObject(nm) + if(is.data.frame(obj)){ + col.list <- c(col.list, as.list(obj)) + }else{ + col.list[[make.names(nm)]] <- obj + } + } DF <- data.frame(col.list) - colnames(DF) <- col.names } if(!is.null(vartext)){ col.names <- unlist(strsplit(vartext, split=",")) - col.list <- vector("list", length(col.names)) - for(i in seq_along(col.names)) col.list[[i]] <- .loadServersideObject(col.names[i]) + col.list <- list() + for(nm in col.names){ + obj <- .loadServersideObject(nm) + if(is.data.frame(obj)){ + col.list <- c(col.list, as.list(obj)) + }else{ + col.list[[make.names(nm)]] <- obj + } + } DF <- data.frame(col.list) - colnames(DF) <- col.names } - + if(is.null(datatext)&&is.null(vartext)){ DF<-data.frame(SURVTIME,CENS) } diff --git a/R/rowColCalcDS.R b/R/rowColCalcDS.R index b1f865dd..68f6d339 100644 --- a/R/rowColCalcDS.R +++ b/R/rowColCalcDS.R @@ -30,13 +30,12 @@ rowColCalcDS <- function (dataset.name, operation) { result <- colMeans(dataset, na.rm=TRUE) } - # check if the output is valid (i.e. meets DataSHIELD criteria) - check <- isValidDS(result) - if(check){ - return(result) - }else{ - resultNA <- rep(NA, length(result)) - return(resultNA) + # check if the output is valid (i.e. meets DataSHIELD criteria); result is + # always numeric, so only the numeric-vector branch of isValidDS applies + thr <- dsBase::listDisclosureSettingsDS() + nfilter.tab <- as.numeric(thr$nfilter.tab) + if(length(result) > 0 && length(result) < nfilter.tab){ + result <- rep(NA, length(result)) } return(result) diff --git a/R/tapplyDS.assign.R b/R/tapplyDS.assign.R index a3917973..5f2978ff 100644 --- a/R/tapplyDS.assign.R +++ b/R/tapplyDS.assign.R @@ -28,29 +28,29 @@ tapplyDS.assign <- function(X.name, INDEX.names.transmit, FUN.name){ studysideMessage <- "ERROR: X.name must be specified as a character string" stop(studysideMessage, call. = FALSE) } - + INDEX.factors <- unlist(strsplit(INDEX.names.transmit, split=",")) - + num.factors <- length(INDEX.factors) - + # test that output vector and indexing factor all have the same length length.2.test <- length(X) - + length.test.vector <- rep(NA, num.factors) - + for(g in 1:num.factors){ active.factor.name <- INDEX.factors[g] active.factor <- .loadServersideObject(active.factor.name) length.test.vector[g] <- length(active.factor) } - + for(h in 1:num.factors){ if(length.2.test!=length.test.vector[h]){ return.message <- "Error: the output variable and all indexing factors must be of equal length" stop(return.message, call. = FALSE) - } + } } - + # convert INDEX.names format from transmittable to actionable form (a list of vectors) INDEX <- vector("list", num.factors) for(g in 1:num.factors){ diff --git a/tests/testthat/test-smk-elsplineDS.R b/tests/testthat/test-smk-elsplineDS.R new file mode 100644 index 00000000..abc895c1 --- /dev/null +++ b/tests/testthat/test-smk-elsplineDS.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("elsplineDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("elsplineDS::smk") +test_that("simple elsplineDS", { + input <- seq(1, 30, by = 1) + + res <- elsplineDS("input", 3) + + expect_equal(class(res), c("lspline", "matrix")) + expect_equal(dim(res), c(30, 3)) + expect_equal(unname(res[1, ]), c(1, 0, 0)) + expect_equal(unname(res[30, ]), c(10.66667, 9.666667, 9.666667), tolerance = 1e-6) +}) + +test_that("elsplineDS throws error when object does not exist", { + expect_error( + elsplineDS("nonexistent_object", 3), + regexp = "does not exist" + ) +}) + +# +# Done +# + +# context("elsplineDS::smk::shutdown") + +# context("elsplineDS::smk::done") diff --git a/tests/testthat/test-smk-getWGSRDS.R b/tests/testthat/test-smk-getWGSRDS.R index 73d0eda1..439f994c 100644 --- a/tests/testthat/test-smk-getWGSRDS.R +++ b/tests/testthat/test-smk-getWGSRDS.R @@ -149,6 +149,37 @@ test_that("simple getWGSRDS - mfa", { expect_true(is.na(res[10])) }) +test_that("getWGSRDS throws error when firstPart does not exist", { + expect_error( + getWGSRDS("data$sex", "nonexistent_object", "data$age", "hfa", NA, NA), + regexp = "does not exist" + ) +}) + +test_that("getWGSRDS throws error when firstPart is not numeric or integer", { + bad_input <- factor(c("a", "b")) + expect_error( + getWGSRDS("data$sex", "bad_input", "data$age", "hfa", NA, NA), + regexp = "must be of type numeric or integer" + ) +}) + +test_that("getWGSRDS throws error when secondPart is not numeric or integer", { + bad_input <- factor(c("a", "b")) + expect_error( + getWGSRDS("data$sex", "data$height", "bad_input", "hfa", NA, NA), + regexp = "must be of type numeric or integer" + ) +}) + +test_that("getWGSRDS throws error when thirdPart is not numeric or integer", { + bad_input <- factor(c("a", "b")) + expect_error( + getWGSRDS("data$sex", "data$weight", "data$height", "bfa", NA, "bad_input"), + regexp = "must be of type numeric or integer" + ) +}) + # # Done # diff --git a/tests/testthat/test-smk-lexisDS1.R b/tests/testthat/test-smk-lexisDS1.R new file mode 100644 index 00000000..d5539611 --- /dev/null +++ b/tests/testthat/test-smk-lexisDS1.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("lexisDS1::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("lexisDS1::smk") +test_that("simple lexisDS1", { + input <- c(1, 5, 3, 9, 2) + + res <- lexisDS1("input") + + expect_equal(class(res), "list") + expect_equal(names(res), "max.time") + # max.time is the max exposure time masked by a random +1%-5% increment + expect_gte(res$max.time, 9 * 1.01) + expect_lte(res$max.time, 9 * 1.05) +}) + +test_that("lexisDS1 throws error when object does not exist", { + expect_error( + lexisDS1("nonexistent_object"), + regexp = "does not exist" + ) +}) + +# +# Done +# + +# context("lexisDS1::smk::shutdown") + +# context("lexisDS1::smk::done") diff --git a/tests/testthat/test-smk-lexisDS2.R b/tests/testthat/test-smk-lexisDS2.R new file mode 100644 index 00000000..8e0c10fc --- /dev/null +++ b/tests/testthat/test-smk-lexisDS2.R @@ -0,0 +1,88 @@ +#------------------------------------------------------------------------------- +# 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("lexisDS2::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("lexisDS2::smk::datatext") +test_that("simple lexisDS2, datatext names a whole data.frame", { + D <- data.frame(id = 1:6, start = rep(0, 6), end = rep(5, 6), status = rep(1, 6), extra = 101:106) + + res <- lexisDS2( + datatext = "D", intervalWidth = "10", maxmaxtime = 10, + idCol = "D$id", entryCol = "D$start", exitCol = "D$end", statusCol = "D$status", vartext = NULL + ) + + expect_equal(class(res), "list") + # carried-forward columns must keep D's own column names, not be corrupted + # or misaligned by the data.frame construction (see lexisDS2 datatext/vartext handling) + expect_true(all(c("id", "start", "end", "status", "extra") %in% names(res$expanded.table))) + expect_equal(res$expanded.table$extra, 101:106) + expect_equal(nrow(res$expanded.table), 6) +}) + +# context("lexisDS2::smk::vartext") +test_that("simple lexisDS2, vartext names individual $-qualified columns", { + D <- data.frame(id = 1:6, start = rep(0, 6), end = rep(5, 6), status = rep(1, 6), extra = 101:106, extra2 = 201:206) + + res <- lexisDS2( + datatext = NULL, intervalWidth = "10", maxmaxtime = 10, + idCol = "D$id", entryCol = "D$start", exitCol = "D$end", statusCol = "D$status", + vartext = "D$extra,D$extra2" + ) + + expect_equal(class(res), "list") + expect_true(all(c("D.extra", "D.extra2") %in% names(res$expanded.table))) + expect_equal(res$expanded.table$D.extra, 101:106) + expect_equal(res$expanded.table$D.extra2, 201:206) +}) + +# context("lexisDS2::smk::no.carry.forward") +test_that("simple lexisDS2, no datatext or vartext", { + D <- data.frame(id = 1:6, start = rep(0, 6), end = rep(5, 6), status = rep(1, 6)) + + res <- lexisDS2( + datatext = NULL, intervalWidth = "10", maxmaxtime = 10, + idCol = "D$id", entryCol = "D$start", exitCol = "D$end", statusCol = "D$status", vartext = NULL + ) + + expect_equal(class(res), "list") + expect_equal(nrow(res$expanded.table), 6) +}) + +test_that("lexisDS2 throws error when object does not exist", { + D <- data.frame(id = 1:6, start = rep(0, 6), end = rep(5, 6), status = rep(1, 6)) + + expect_error( + lexisDS2( + datatext = NULL, intervalWidth = "10", maxmaxtime = 10, + idCol = "D$id", entryCol = "D$start", exitCol = "nonexistent_object", statusCol = "D$status", vartext = NULL + ), + regexp = "does not exist" + ) +}) + +# +# Done +# + +# context("lexisDS2::smk::shutdown") + +# context("lexisDS2::smk::done") diff --git a/tests/testthat/test-smk-lsplineDS.R b/tests/testthat/test-smk-lsplineDS.R new file mode 100644 index 00000000..2d52ca57 --- /dev/null +++ b/tests/testthat/test-smk-lsplineDS.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("lsplineDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("lsplineDS::smk") +test_that("simple lsplineDS", { + input <- seq(1, 30, by = 1) + + res <- lsplineDS("input", knots = c(10, 20)) + + expect_equal(class(res), c("lspline", "matrix")) + expect_equal(dim(res), c(30, 3)) + expect_equal(unname(res[1, ]), c(1, 0, 0)) + expect_equal(unname(res[30, ]), c(10, 10, 10)) +}) + +test_that("lsplineDS throws error when object does not exist", { + expect_error( + lsplineDS("nonexistent_object", knots = c(10, 20)), + regexp = "does not exist" + ) +}) + +# +# Done +# + +# context("lsplineDS::smk::shutdown") + +# context("lsplineDS::smk::done") diff --git a/tests/testthat/test-smk-nsDS.R b/tests/testthat/test-smk-nsDS.R new file mode 100644 index 00000000..07badac9 --- /dev/null +++ b/tests/testthat/test-smk-nsDS.R @@ -0,0 +1,48 @@ +#------------------------------------------------------------------------------- +# 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("nsDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("nsDS::smk") +test_that("simple nsDS", { + input <- seq(1, 30, by = 1) + + res <- nsDS("input", df = 3, knots = NULL, intercept = FALSE, Boundary.knots = NULL) + + expect_equal(class(res), c("ns", "basis", "matrix")) + expect_equal(dim(res), c(30, 3)) + expect_equal(unname(res[1, ]), c(0, 0, 0)) +}) + +test_that("nsDS throws error when object does not exist", { + expect_error( + nsDS("nonexistent_object", df = 3, knots = NULL, intercept = FALSE, Boundary.knots = NULL), + regexp = "does not exist" + ) +}) + +# +# Done +# + +# context("nsDS::smk::shutdown") + +# context("nsDS::smk::done") diff --git a/tests/testthat/test-smk-qlsplineDS.R b/tests/testthat/test-smk-qlsplineDS.R new file mode 100644 index 00000000..42066853 --- /dev/null +++ b/tests/testthat/test-smk-qlsplineDS.R @@ -0,0 +1,48 @@ +#------------------------------------------------------------------------------- +# 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("qlsplineDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("qlsplineDS::smk") +test_that("simple qlsplineDS", { + input <- seq(1, 30, by = 1) + + res <- qlsplineDS("input", q = 3, na.rm = TRUE, marginal = FALSE) + + expect_equal(class(res), c("lspline", "matrix")) + expect_equal(dim(res), c(30, 3)) + expect_equal(unname(res[1, ]), c(1, 0, 0)) +}) + +test_that("qlsplineDS throws error when object does not exist", { + expect_error( + qlsplineDS("nonexistent_object", q = 3, na.rm = TRUE, marginal = FALSE), + regexp = "does not exist" + ) +}) + +# +# Done +# + +# context("qlsplineDS::smk::shutdown") + +# context("qlsplineDS::smk::done") diff --git a/tests/testthat/test-smk-rowColCalcDS.R b/tests/testthat/test-smk-rowColCalcDS.R index aa1a3276..d7b89470 100644 --- a/tests/testthat/test-smk-rowColCalcDS.R +++ b/tests/testthat/test-smk-rowColCalcDS.R @@ -74,6 +74,21 @@ test_that("simple rowColCalcDS, operation 4", { expect_equal(res[4], 6.5) }) +test_that("rowColCalcDS throws error when object does not exist", { + expect_error( + rowColCalcDS("nonexistent_object", 1), + regexp = "does not exist" + ) +}) + +test_that("rowColCalcDS throws error when object is not data.frame or matrix", { + bad_input <- list(a = 1:3, b = 4:6) + expect_error( + rowColCalcDS("bad_input", 1), + regexp = "must be of type data.frame or matrix" + ) +}) + # # Done # diff --git a/tests/testthat/test-smk-tableDS.R b/tests/testthat/test-smk-tableDS.R new file mode 100644 index 00000000..6ffdb46c --- /dev/null +++ b/tests/testthat/test-smk-tableDS.R @@ -0,0 +1,60 @@ +#------------------------------------------------------------------------------- +# 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("tableDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("tableDS::smk::1D") +test_that("simple tableDS, 1D", { + input <- factor(rep(c("a", "b"), each = 5)) + + res <- tableDS("input", NULL, NULL, "a,b", NULL, NULL, NULL, "no", NULL) + + expect_equal(class(res), "table") + expect_equal(as.vector(res), c(5, 5)) + expect_equal(names(res), c("a", "b")) +}) + +# context("tableDS::smk::2D") +test_that("simple tableDS, 2D", { + rvar <- factor(rep(c("a", "b"), each = 10)) + cvar <- factor(rep(rep(c("x", "y"), each = 5), 2)) + + res <- tableDS("rvar", "cvar", NULL, "a,b", "x,y", NULL, NULL, "no", NULL) + + expect_equal(class(res), "table") + expect_equal(dim(res), c(2L, 2L)) + expect_equal(as.vector(res), c(5, 5, 5, 5)) +}) + +test_that("tableDS throws error when object does not exist", { + expect_error( + tableDS("nonexistent_object", NULL, NULL, "a,b", NULL, NULL, NULL, "no", NULL), + regexp = "does not exist" + ) +}) + +# +# Done +# + +# context("tableDS::smk::shutdown") + +# context("tableDS::smk::done") diff --git a/tests/testthat/test-smk-tableDS.assign.R b/tests/testthat/test-smk-tableDS.assign.R new file mode 100644 index 00000000..a284ed28 --- /dev/null +++ b/tests/testthat/test-smk-tableDS.assign.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("tableDS.assign::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("tableDS.assign::smk") +test_that("simple tableDS.assign", { + rvar <- factor(rep(c("a", "b"), each = 10)) + cvar <- factor(rep(rep(c("x", "y"), each = 5), 2)) + + res <- tableDS.assign("rvar", "cvar", NULL, "a,b", "x,y", NULL, NULL, "no") + + expect_equal(class(res), "list") + expect_equal(names(res), c("table", "counts", "dim", "dimnames")) + expect_equal(res$dim, c(2L, 2L)) + expect_equal(res$counts, c(5, 5, 5, 5)) +}) + +test_that("tableDS.assign throws error when object does not exist", { + expect_error( + tableDS.assign("nonexistent_object", NULL, NULL, "a,b", NULL, NULL, NULL, "no"), + regexp = "does not exist" + ) +}) + +# +# Done +# + +# context("tableDS.assign::smk::shutdown") + +# context("tableDS.assign::smk::done") diff --git a/tests/testthat/test-smk-tableDS2.R b/tests/testthat/test-smk-tableDS2.R new file mode 100644 index 00000000..7f842297 --- /dev/null +++ b/tests/testthat/test-smk-tableDS2.R @@ -0,0 +1,54 @@ +#------------------------------------------------------------------------------- +# 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("tableDS2::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("tableDS2::smk") +test_that("simple tableDS2", { + rvar <- factor(rep(c("a", "b"), each = 10)) + cvar <- factor(rep(rep(c("x", "y"), each = 5), 2)) + res.assign <- tableDS.assign("rvar", "cvar", NULL, "a,b", "x,y", NULL, NULL, "no") + + res <- tableDS2("res.assign", "rvar", "cvar", NULL) + + expect_equal(class(res), "list") + expect_equal( + names(res), + c("table.cell.IDs", "table.dim", "table.dimnames", "table.structure_and_cell.order") + ) + expect_equal(res$table.dim, c(2L, 2L)) + expect_equal(res$table.cell.IDs, 1:4) +}) + +test_that("tableDS2 throws error when object does not exist", { + expect_error( + tableDS2("nonexistent_object", "rvar", "cvar", NULL), + regexp = "does not exist" + ) +}) + +# +# Done +# + +# context("tableDS2::smk::shutdown") + +# context("tableDS2::smk::done") From 754f3352856259fca55a9da228ccab1d71f62b58 Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Fri, 18 Sep 2026 14:35:48 +0100 Subject: [PATCH 6/6] Remove skip --- tests/testthat/test-perf-meanDS.R | 4 ++-- tests/testthat/test-perf-varDS.R | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-perf-meanDS.R b/tests/testthat/test-perf-meanDS.R index 53e4c7af..3cb30a2e 100644 --- a/tests/testthat/test-perf-meanDS.R +++ b/tests/testthat/test-perf-meanDS.R @@ -13,8 +13,8 @@ # # avoid performance tests on CRAN and GitHub Actions -testthat::skip_on_cran() -testthat::skip_on_ci() +# testthat::skip_on_cran() +# testthat::skip_on_ci() # context("meanDS::perf::setup") diff --git a/tests/testthat/test-perf-varDS.R b/tests/testthat/test-perf-varDS.R index 9df6c0f6..3870f0f3 100644 --- a/tests/testthat/test-perf-varDS.R +++ b/tests/testthat/test-perf-varDS.R @@ -13,8 +13,8 @@ # # avoid performance tests on CRAN and GitHub Actions -testthat::skip_on_cran() -testthat::skip_on_ci() +# testthat::skip_on_cran() +# testthat::skip_on_ci() # context("varDS::perf::setup")