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 01/22] 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 02/22] 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 03/22] 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 04/22] 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 05/22] 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 06/22] 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") From a77ac736691f4469b7e8596139bffae6d2ae7194 Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Mon, 21 Sep 2026 10:39:02 +0100 Subject: [PATCH 07/22] Removal of testthat 'skip's --- 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 3cb30a2e..d6355336 100644 --- a/tests/testthat/test-perf-meanDS.R +++ b/tests/testthat/test-perf-meanDS.R @@ -26,7 +26,7 @@ set.standard.disclosure.settings() # context("meanDS::perf::numeric") test_that("numeric meanDS - performance", { - skip_on_cran() +# skip_on_cran() input <- c(0.0, 1.0, 2.0, 3.0, 4.0) @@ -61,7 +61,7 @@ test_that("numeric meanDS - performance", { # context("meanDS::perf::numeric with NA") test_that("numeric meanDS, with NA - performance", { - skip_on_cran() +# skip_on_cran() input <- c(0.0, NA, 2.0, NA, 4.0) diff --git a/tests/testthat/test-perf-varDS.R b/tests/testthat/test-perf-varDS.R index 3870f0f3..d7e2131c 100644 --- a/tests/testthat/test-perf-varDS.R +++ b/tests/testthat/test-perf-varDS.R @@ -26,7 +26,7 @@ set.standard.disclosure.settings() # context("varDS::perf::numeric") test_that("numeric varDS - performance", { - skip_on_cran() +# skip_on_cran() input <- c(0.0, 1.0, 2.0, 3.0, 4.0) @@ -61,7 +61,7 @@ test_that("numeric varDS - performance", { # context("varDS::perf::numeric with NA") test_that("numeric varDS, with NA - performance", { - skip_on_cran() +# skip_on_cran() input <- c(0.0, NA, 2.0, NA, 4.0) From 648d72b0c87717e4a5d7137079e117371a2158aa Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Mon, 21 Sep 2026 11:37:27 +0100 Subject: [PATCH 08/22] Update perfence profile --- tests/testthat/perf_files/azure-pipeline_perf-profile.csv | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/testthat/perf_files/azure-pipeline_perf-profile.csv b/tests/testthat/perf_files/azure-pipeline_perf-profile.csv index 77f556bc..43418639 100644 --- a/tests/testthat/perf_files/azure-pipeline_perf-profile.csv +++ b/tests/testthat/perf_files/azure-pipeline_perf-profile.csv @@ -1,5 +1,5 @@ "refer_name","rate","lower_tolerance","upper_tolerance" -"meanDS::perf::numeric::0","2998.9844","0.5","2" -"meanDS::perf::numberAndNA::0","3027.3963","0.5","2" -"varDS::perf::numeric::0","3124.4088","0.5","2" -"varDS::perf::numberAndNA::0","3146.532","0.5","2" +"meanDS::perf::numeric::0","4497.0","0.5","2" +"meanDS::perf::numberAndNA::0","4542.0","0.5","2" +"varDS::perf::numeric::0","4584.0","0.5","2" +"varDS::perf::numberAndNA::0","4590.0","0.5","2" From d8d79695593170850fc5d3021656ccad4f608797 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 21 Sep 2026 13:20:29 +0200 Subject: [PATCH 09/22] refactor: tidied up PR --- R/getWGSRDS.R | 9 +- R/isValidDS.R | 27 +++- R/lexisDS2.R | 35 ++--- R/quantileMeanDS.R | 2 +- R/rangeDS.R | 8 +- R/recodeLevelsDS.R | 2 +- R/replaceNaDS.R | 2 +- R/rowColCalcDS.R | 25 +-- R/tableDS.R | 6 +- R/tableDS.assign.R | 4 +- R/tapplyDS.R | 1 - man/isValidDS.Rd | 11 +- man/rangeDS.Rd | 6 +- tests/testthat/test-perf-meanDS.R | 4 +- tests/testthat/test-perf-varDS.R | 4 +- tests/testthat/test-smk-elsplineDS.R | 11 -- tests/testthat/test-smk-getWGSRDS.R | 12 +- tests/testthat/test-smk-hetcorDS.R | 7 + tests/testthat/test-smk-isValidDS.R | 182 +++++++++------------- tests/testthat/test-smk-lexisDS1.R | 11 -- tests/testthat/test-smk-lexisDS2.R | 25 +-- tests/testthat/test-smk-lsplineDS.R | 11 -- tests/testthat/test-smk-metadataDS.R | 10 ++ tests/testthat/test-smk-nsDS.R | 11 -- tests/testthat/test-smk-qlsplineDS.R | 11 -- tests/testthat/test-smk-rangeDS.R | 14 +- tests/testthat/test-smk-rowColCalcDS.R | 6 + tests/testthat/test-smk-tableDS.R | 50 ++++-- tests/testthat/test-smk-tableDS.assign.R | 11 -- tests/testthat/test-smk-tableDS2.R | 11 -- tests/testthat/test-smk-tapplyDS.R | 12 ++ tests/testthat/test-smk-tapplyDS.assign.R | 12 ++ 32 files changed, 277 insertions(+), 276 deletions(-) diff --git a/R/getWGSRDS.R b/R/getWGSRDS.R index 619b66af..c23f13d0 100644 --- a/R/getWGSRDS.R +++ b/R/getWGSRDS.R @@ -54,20 +54,21 @@ #' 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")) + .checkClass(obj = firstPart, obj_name = firstPart.name, permitted_classes = "numeric") if (!is.na(secondPart)){ secondPart.name <- secondPart secondPart <- .loadServersideObject(secondPart) - .checkClass(obj = secondPart, obj_name = secondPart.name, permitted_classes = c("numeric", "integer")) + .checkClass(obj = secondPart, obj_name = secondPart.name, permitted_classes = "numeric") } if (!is.na(thirdPart)){ thirdPart.name <- thirdPart thirdPart <- .loadServersideObject(thirdPart) - .checkClass(obj = thirdPart, obj_name = thirdPart.name, permitted_classes = c("numeric", "integer")) + if (index == "bfa"){ + .checkClass(obj = thirdPart, obj_name = thirdPart.name, permitted_classes = "numeric") + } } # access the internal reference data diff --git a/R/isValidDS.R b/R/isValidDS.R index f45ccae7..3d5127a9 100644 --- a/R/isValidDS.R +++ b/R/isValidDS.R @@ -2,12 +2,33 @@ #' @title Checks if an input is valid #' @description Tells if an object on the server side is valid. #' @details This function checks if an object is valid. -#' @param obj, a vector (numeric, integer, factor, character), data.frame or matrix -#' @return a boolean, TRUE if input is valid or FALSE if not. +#' @param x a character string, the name of a vector (numeric, integer, factor, character, +#' logical), data.frame or matrix +#' @return a list with \code{valid}, a boolean that is TRUE if the input is valid or FALSE +#' if not, and \code{class}, the class of the input object for client-side consistency +#' checking #' @author Gaye, A. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #'@export #' -isValidDS <- function(obj) { +isValidDS <- function(x) { + + obj <- .loadServersideObject(x) + .checkClass( + obj = obj, + obj_name = x, + permitted_classes = c("character", "factor", "integer", "logical", "numeric", "data.frame", "matrix") + ) + + list(valid = .checkDisclosureSize(obj), class = class(obj)) +} + +#' Check a Server-Side Object Meets the Disclosure Size Threshold +#' +#' @param obj The object to check: a vector, data.frame or matrix. +#' @return A boolean, TRUE if the object meets the threshold or FALSE if not. +#' @noRd +.checkDisclosureSize <- function(obj) { # this filter sets the minimum number of observations that are allowed diff --git a/R/lexisDS2.R b/R/lexisDS2.R index 5696636d..d4366720 100644 --- a/R/lexisDS2.R +++ b/R/lexisDS2.R @@ -47,8 +47,8 @@ lexisDS2 <- function(datatext=NULL, intervalWidth, maxmaxtime, idCol, entryCol, #nfilter.string<-as.numeric(thr$nfilter.string) ############################################################# - starttime <- .loadServersideObject(entryCol) endtime <- .loadServersideObject(exitCol) + starttime <- if(is.null(entryCol)) rep(0, length(endtime)) else .loadServersideObject(entryCol) cens <- .loadServersideObject(statusCol) id.orig <- .loadServersideObject(idCol) @@ -73,39 +73,24 @@ lexisDS2 <- function(datatext=NULL, intervalWidth, maxmaxtime, idCol, entryCol, length.collapseDF <- length(idSeq) #IDENTIFY VARIABLES TO BE CARRIED WITH THE EXPANDED SURVIVAL DATA - - # 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 <- 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) - } - - if(!is.null(vartext)){ - col.names <- unlist(strsplit(vartext, split=",")) + + # 'vartext' takes precedence over 'datatext'. A data.frame name is unpacked into its + # columns and a single column such as D$var is named make.names("D$var"), matching + # how data.frame() named them when the names were parsed as R code. + carried.text <- if(is.null(vartext)) datatext else vartext + if(!is.null(carried.text)){ col.list <- list() - for(nm in col.names){ + for(nm in unlist(strsplit(carried.text, split=","))){ obj <- .loadServersideObject(nm) if(is.data.frame(obj)){ col.list <- c(col.list, as.list(obj)) }else{ - col.list[[make.names(nm)]] <- obj + col.list <- c(col.list, stats::setNames(list(obj), make.names(nm))) } } DF <- data.frame(col.list) } - + if(is.null(datatext)&&is.null(vartext)){ DF<-data.frame(SURVTIME,CENS) } diff --git a/R/quantileMeanDS.R b/R/quantileMeanDS.R index b6a54e91..e5358f46 100644 --- a/R/quantileMeanDS.R +++ b/R/quantileMeanDS.R @@ -16,7 +16,7 @@ quantileMeanDS <- function (x) { .checkClass(obj = xvect, obj_name = x, permitted_classes = c("numeric", "integer")) # check if the input vector is valid (i.e. meets DataSHIELD criteria) - check <- isValidDS(xvect) + check <- .checkDisclosureSize(xvect) if(check){ # if the input vector is valid diff --git a/R/rangeDS.R b/R/rangeDS.R index ec9183ea..6d87d83f 100644 --- a/R/rangeDS.R +++ b/R/rangeDS.R @@ -2,12 +2,16 @@ #' @title returns the minimum and maximum of a numeric vector #' @description this function is similar to R function \code{range} but instead to not return #' the real minimum and maximum, the computed values are multiplied by a very small random number. -#' @param xvect a numerical +#' @param x a character string, the name of a numeric or integer vector #' @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 #' -rangeDS <- function(xvect) { +rangeDS <- function(x) { + xvect <- .loadServersideObject(x) + .checkClass(obj = xvect, obj_name = x, permitted_classes = c("numeric", "integer")) + # back-up current .Random.seed and revert on.exit if (exists(x = ".Random.seed", envir = globalenv())) { assign(x = ".old_seed", value = .Random.seed, envir = parent.frame()); diff --git a/R/recodeLevelsDS.R b/R/recodeLevelsDS.R index 6878faa6..b4c47998 100644 --- a/R/recodeLevelsDS.R +++ b/R/recodeLevelsDS.R @@ -14,7 +14,7 @@ recodeLevelsDS <- function (x=NULL, classes=NULL){ dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot')) # check if the input vector is valid (i.e. meets DataSHIELD criteria) - check <- isValidDS(x) + check <- .checkDisclosureSize(x) if(check){ # generate the new variable with the specified levels diff --git a/R/replaceNaDS.R b/R/replaceNaDS.R index 62b91f99..707db8f6 100644 --- a/R/replaceNaDS.R +++ b/R/replaceNaDS.R @@ -21,7 +21,7 @@ replaceNaDS <- function(x, replacements){ xvect <- .loadServersideObject(x) # check if the input vector is valid (i.e. meets DataSHIELD criteria) - check <- dsBase::isValidDS(xvect) + check <- .checkDisclosureSize(xvect) # if the input vector is a factor convert it to numeric cls <- class(xvect) diff --git a/R/rowColCalcDS.R b/R/rowColCalcDS.R index 68f6d339..ad09ed60 100644 --- a/R/rowColCalcDS.R +++ b/R/rowColCalcDS.R @@ -13,9 +13,13 @@ #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' rowColCalcDS <- function (dataset.name, operation) { - + dataset <- .loadServersideObject(dataset.name) .checkClass(obj = dataset, obj_name = dataset.name, permitted_classes = c("data.frame", "matrix")) + column.classes <- lapply(as.data.frame(dataset), class) + if(!all(vapply(column.classes, function(cls) any(cls %in% c("numeric", "integer")), logical(1)))){ + stop("One or more columns of '", dataset.name, "' are not of numeric type", call. = FALSE) + } if(operation == 1){ result <- rowSums(dataset, na.rm=TRUE) @@ -29,15 +33,16 @@ rowColCalcDS <- function (dataset.name, operation) { if(operation == 4){ result <- colMeans(dataset, na.rm=TRUE) } - - # 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)) + + # check if the output is valid (i.e. meets DataSHIELD criteria) + check <- .checkDisclosureSize(result) + if(check){ + return(result) + }else{ + 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 f524cfbe..8f62c773 100644 --- a/R/tableDS.R +++ b/R/tableDS.R @@ -56,7 +56,7 @@ nfilter.tab<-as.numeric(thr$nfilter.tab) # if(!is.null(force.nfilter.transmit)) { -force.nfilter.active<-.loadServersideObject(force.nfilter.transmit) +force.nfilter.active<-as.numeric(force.nfilter.transmit) if(force.nfilter.active. -#------------------------------------------------------------------------------- - # # Set up # diff --git a/tests/testthat/test-smk-getWGSRDS.R b/tests/testthat/test-smk-getWGSRDS.R index 439f994c..dab37f42 100644 --- a/tests/testthat/test-smk-getWGSRDS.R +++ b/tests/testthat/test-smk-getWGSRDS.R @@ -156,27 +156,27 @@ test_that("getWGSRDS throws error when firstPart does not exist", { ) }) -test_that("getWGSRDS throws error when firstPart is not numeric or integer", { +test_that("getWGSRDS throws error when firstPart is not numeric", { 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" + regexp = "must be of type numeric\\." ) }) -test_that("getWGSRDS throws error when secondPart is not numeric or integer", { +test_that("getWGSRDS throws error when secondPart is not numeric", { 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" + regexp = "must be of type numeric\\." ) }) -test_that("getWGSRDS throws error when thirdPart is not numeric or integer", { +test_that("getWGSRDS throws error when thirdPart is not numeric", { 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" + regexp = "must be of type numeric\\." ) }) diff --git a/tests/testthat/test-smk-hetcorDS.R b/tests/testthat/test-smk-hetcorDS.R index fd5ca14e..168f1084 100644 --- a/tests/testthat/test-smk-hetcorDS.R +++ b/tests/testthat/test-smk-hetcorDS.R @@ -83,6 +83,13 @@ test_that("hetcorDS", { }) +test_that("hetcorDS throws error when object does not exist", { + expect_error( + hetcorDS(data = "nonexistent_object", ML = FALSE, std.err = TRUE, bins = 2, pd = TRUE, use = "complete.obs"), + regexp = "does not exist" + ) +}) + # # Done # diff --git a/tests/testthat/test-smk-isValidDS.R b/tests/testthat/test-smk-isValidDS.R index 81fc5ade..83937374 100644 --- a/tests/testthat/test-smk-isValidDS.R +++ b/tests/testthat/test-smk-isValidDS.R @@ -15,6 +15,8 @@ # context("isValidDS::smk::setup") +set.standard.disclosure.settings() + # # Tests # @@ -23,229 +25,195 @@ test_that("simple isValidDS, character", { input <- "value" - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, FALSE) }) test_that("simple isValidDS, character vector", { input <- c("value1", "value2", "value3", "value4") - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, TRUE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, TRUE) }) # context("isValidDS::smk::integer") test_that("simple isValidDS, integer", { input <- 1L - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, FALSE) }) test_that("simple isValidDS, integer vector", { input <- c(1L, 2L, 3L, 4L) - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, TRUE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, TRUE) }) # context("isValidDS::smk::numeric") test_that("simple isValidDS, numeric", { input <- 1.1 - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, FALSE) }) test_that("simple isValidDS, numeric vector", { input <- c(1.1, 2.1, 3.1, 4.1) - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, TRUE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, TRUE) }) # context("isValidDS::smk::logical") test_that("simple isValidDS, logical, FALSE", { input <- FALSE - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, FALSE) }) test_that("simple isValidDS, logical, TRUE", { input <- TRUE - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, FALSE) }) test_that("simple isValidDS, logical vector", { input <- c(FALSE, TRUE, FALSE, TRUE) - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, TRUE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, TRUE) }) test_that("simple isValidDS, factor", { input <- as.factor("a") - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, FALSE) }) test_that("simple isValidDS, factor vector", { input <- as.factor(c("a", "a", "a", "a", "b", "b", "b", "b")) - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, TRUE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, TRUE) }) test_that("simple isValidDS, factor vector", { input <- as.factor(c("a", "b", "c", "d", "e", "f")) - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, FALSE) }) # context("isValidDS::smk::data.frame") test_that("simple isValidDS, data.frame", { input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, TRUE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, TRUE) }) # context("isValidDS::smk::array") -test_that("simple isValidDS, array", { +test_that("isValidDS throws error for a 1-d array", { input <- array(c(0.0, 1.0, 2.0, 3.0, 4.0)) - res <- isValidDS(input) - - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) + expect_error(isValidDS("input"), regexp = "must be of type") }) # context("isValidDS::smk::matrix") test_that("simple isValidDS, matrix", { input <- matrix(c(0.0, 1.0, 2.0, 3.0, 4.0)) - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, TRUE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, TRUE) }) # context("isValidDS::smk::data.matrix") test_that("simple isValidDS, data.matrix", { input <- data.matrix(data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0))) - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, TRUE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, TRUE) }) # context("isValidDS::smk::date") -test_that("simple isValidDS, date", { +test_that("isValidDS throws error for a date", { input <- Sys.Date() - res <- isValidDS(input) - - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) + expect_error(isValidDS("input"), regexp = "must be of type") }) -# context("isValidDS::smk::formula") -test_that("simple isValidDS, formula", { - input <- X ~ A + B +test_that("isValidDS returns the class of the input", { + input <- c(1.1, 2.1, 3.1, 4.1) - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) + expect_equal(res$class, "numeric") }) -# context("isValidDS::smk::environment") -test_that("simple isValidDS, environment", { - input <- environment() - - res <- isValidDS(input) - - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) +test_that("isValidDS throws error when object does not exist", { + expect_error(isValidDS("nonexistent_object"), regexp = "does not exist") }) -# context("isValidDS::smk::NA") test_that("special isValidDS, NA", { input <- NA - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) + expect_equal(res$valid, FALSE) }) -# context("isValidDS::smk::NULL") test_that("special isValidDS, NULL", { input <- NULL - res <- isValidDS(input) - - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) + expect_error(isValidDS("input"), regexp = "must be of type") }) - -# -# Done -# - -# context("isValidDS::smk::shutdown") - -# context("isValidDS::smk::done") diff --git a/tests/testthat/test-smk-lexisDS1.R b/tests/testthat/test-smk-lexisDS1.R index d5539611..c0453a77 100644 --- a/tests/testthat/test-smk-lexisDS1.R +++ b/tests/testthat/test-smk-lexisDS1.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-lexisDS2.R b/tests/testthat/test-smk-lexisDS2.R index 8e0c10fc..b29655cb 100644 --- a/tests/testthat/test-smk-lexisDS2.R +++ b/tests/testthat/test-smk-lexisDS2.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 # @@ -79,6 +68,20 @@ test_that("lexisDS2 throws error when object does not exist", { ) }) +# context("lexisDS2::smk::no.entryCol") +test_that("simple lexisDS2, entryCol not given defaults entry times to 0", { + D <- data.frame(id = 1:6, end = rep(5, 6), status = rep(1, 6)) + + res <- lexisDS2( + datatext = NULL, intervalWidth = "10", maxmaxtime = 10, + idCol = "D$id", entryCol = NULL, exitCol = "D$end", statusCol = "D$status", vartext = NULL + ) + + expect_equal(class(res), "list") + expect_equal(nrow(res$expanded.table), 6) + expect_true(all(res$expanded.table$SURVTIME == 5)) +}) + # # Done # diff --git a/tests/testthat/test-smk-lsplineDS.R b/tests/testthat/test-smk-lsplineDS.R index 2d52ca57..88aa44e1 100644 --- a/tests/testthat/test-smk-lsplineDS.R +++ b/tests/testthat/test-smk-lsplineDS.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-metadataDS.R b/tests/testthat/test-smk-metadataDS.R index 4b0ab042..12cf94e5 100644 --- a/tests/testthat/test-smk-metadataDS.R +++ b/tests/testthat/test-smk-metadataDS.R @@ -46,6 +46,16 @@ test_that("simple metadataDS, list of vectors", { expect_length(res, 0) }) +test_that("metadataDS throws error when object does not exist", { + expect_error(metadataDS("nonexistent_object"), regexp = "does not exist") +}) + +test_that("metadataDS throws error when column does not exist", { + input <- list(v1 = c(0.0, 1.0, 2.0)) + + expect_error(metadataDS("input$nonexistent_column"), regexp = "not found in 'input'") +}) + # # Done # diff --git a/tests/testthat/test-smk-nsDS.R b/tests/testthat/test-smk-nsDS.R index 07badac9..1f21383a 100644 --- a/tests/testthat/test-smk-nsDS.R +++ b/tests/testthat/test-smk-nsDS.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-qlsplineDS.R b/tests/testthat/test-smk-qlsplineDS.R index 42066853..4eea279c 100644 --- a/tests/testthat/test-smk-qlsplineDS.R +++ b/tests/testthat/test-smk-qlsplineDS.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-rangeDS.R b/tests/testthat/test-smk-rangeDS.R index c59c9d32..31f58566 100644 --- a/tests/testthat/test-smk-rangeDS.R +++ b/tests/testthat/test-smk-rangeDS.R @@ -25,7 +25,7 @@ set.random.seed.setting(1234) test_that("numeric rangeDS", { input <- c(0.0, 1.0, 2.0, 3.0, 4.0, 4.0, 3.0, 2.0, 1.0, 0.0) - res <- rangeDS(input) + res <- rangeDS("input") expect_length(res, 2) expect_equal(class(res), "numeric") @@ -37,7 +37,7 @@ test_that("numeric rangeDS", { test_that("character rangeDS", { input <- c(0.0, NA, 2.0, NA, 4.0, NA, 3.0, NA, 1.0, NA) - res <- rangeDS(input) + res <- rangeDS("input") expect_length(res, 2) expect_equal(class(res), "numeric") @@ -45,6 +45,16 @@ test_that("character rangeDS", { expect_equal(res[2], 4.12446, tolerance = 1e-6) }) +test_that("rangeDS throws error when object does not exist", { + expect_error(rangeDS("nonexistent_object"), regexp = "does not exist") +}) + +test_that("rangeDS throws error when object is not numeric", { + input <- c("a", "b", "c") + + expect_error(rangeDS("input"), regexp = "must be of type numeric or integer") +}) + # # Done # diff --git a/tests/testthat/test-smk-rowColCalcDS.R b/tests/testthat/test-smk-rowColCalcDS.R index d7b89470..f0d563b6 100644 --- a/tests/testthat/test-smk-rowColCalcDS.R +++ b/tests/testthat/test-smk-rowColCalcDS.R @@ -89,6 +89,12 @@ test_that("rowColCalcDS throws error when object is not data.frame or matrix", { ) }) +test_that("rowColCalcDS throws error when a column is not numeric", { + input <- data.frame(v1 = c(1.0, 2.0, 3.0, 4.0), v2 = c("a", "b", "c", "d")) + + expect_error(rowColCalcDS("input", 1), regexp = "are not of numeric type") +}) + # # Done # diff --git a/tests/testthat/test-smk-tableDS.R b/tests/testthat/test-smk-tableDS.R index 6ffdb46c..bcb77d76 100644 --- a/tests/testthat/test-smk-tableDS.R +++ b/tests/testthat/test-smk-tableDS.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 # @@ -51,6 +40,45 @@ test_that("tableDS throws error when object does not exist", { ) }) +test_that("tableDS accepts a forced nfilter given as a number", { + input <- factor(rep(c("a", "b"), each = 5)) + + res <- tableDS("input", NULL, NULL, "a,b", NULL, NULL, NULL, "no", "3") + + expect_equal(class(res), "table") + expect_equal(as.vector(res), c(5, 5)) +}) + +test_that("tableDS throws error when forced nfilter is below nfilter.tab", { + input <- factor(rep(c("a", "b"), each = 5)) + + expect_error( + tableDS("input", NULL, NULL, "a,b", NULL, NULL, NULL, "no", "1"), + regexp = "force.nfilter is non-null it must be >= to nfilter.tab" + ) +}) + +test_that("tableDS excludes levels given as literal values", { + input <- factor(rep(c("a", "b", "c"), each = 5)) + + res <- tableDS("input", NULL, NULL, "a,b,c", NULL, NULL, "a", "no", NULL) + + expect_equal(names(res), c("b", "c")) + expect_equal(as.vector(res), c(5, 5)) +}) + +test_that("tableDS treats NA in a list of excluded values as missing", { + input <- factor(c(rep(c("a", "b"), each = 5), rep(NA, 5))) + + expect_warning( + res <- tableDS("input", NULL, NULL, "a,b", NULL, NULL, "a,NA", "always", NULL), + regexp = "'exclude' containing NA" + ) + + expect_equal(names(res), "b") + expect_equal(as.vector(res), 5) +}) + # # Done # diff --git a/tests/testthat/test-smk-tableDS.assign.R b/tests/testthat/test-smk-tableDS.assign.R index a284ed28..c20b5e01 100644 --- a/tests/testthat/test-smk-tableDS.assign.R +++ b/tests/testthat/test-smk-tableDS.assign.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-tableDS2.R b/tests/testthat/test-smk-tableDS2.R index 7f842297..c787816c 100644 --- a/tests/testthat/test-smk-tableDS2.R +++ b/tests/testthat/test-smk-tableDS2.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-tapplyDS.R b/tests/testthat/test-smk-tapplyDS.R index 7925b49a..32f2ae14 100644 --- a/tests/testthat/test-smk-tapplyDS.R +++ b/tests/testthat/test-smk-tapplyDS.R @@ -158,6 +158,18 @@ test_that("simple tapplyDS, quantile", { expect_equal(res[[2]][[15]], 2.0) }) +test_that("tapplyDS throws error when X does not exist", { + index <- as.factor(c(1, 2, 1, 2, 1, 2, 1, 2)) + + expect_error(tapplyDS("nonexistent_object", "index", "mean"), regexp = "does not exist") +}) + +test_that("tapplyDS throws error when INDEX does not exist", { + x <- c(1, 2, 1, 2, 1, 2, 1, 2) + + expect_error(tapplyDS("x", "nonexistent_object", "mean"), regexp = "does not exist") +}) + # # Done # diff --git a/tests/testthat/test-smk-tapplyDS.assign.R b/tests/testthat/test-smk-tapplyDS.assign.R index 7d899a2e..abb155a7 100644 --- a/tests/testthat/test-smk-tapplyDS.assign.R +++ b/tests/testthat/test-smk-tapplyDS.assign.R @@ -51,6 +51,18 @@ test_that("simple tapplyDS.assign", { expect_equal(res$N[[2]], 4) }) +test_that("tapplyDS.assign throws error when X does not exist", { + index <- factor(c(1, 2, 1, 2, 1, 2, 1, 2)) + + expect_error(tapplyDS.assign("nonexistent_object", "index", "mean"), regexp = "does not exist") +}) + +test_that("tapplyDS.assign throws error when INDEX does not exist", { + x <- c(1, 2, 1, 2, 1, 2, 1, 2) + + expect_error(tapplyDS.assign("x", "nonexistent_object", "mean"), regexp = "does not exist") +}) + # # Done # From 6dbf845d68924b636377ad23dfbd5bd681b6ad34 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 21 Sep 2026 13:21:13 +0200 Subject: [PATCH 10/22] chore: ignore plots --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index f4edd3a2..dba745c0 100644 --- a/.gitignore +++ b/.gitignore @@ -8,3 +8,4 @@ .Rapp.history .claude .idea +tests/testthat/Rplots.pdf From 41046bd043eb742738571860264702bdefd08960 Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Mon, 21 Sep 2026 12:34:49 +0100 Subject: [PATCH 11/22] Fix setting of PERF.PROFILE env variable --- azure-pipelines.yml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/azure-pipelines.yml b/azure-pipelines.yml index 94c767e9..3d412045 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -27,8 +27,7 @@ variables: branchName: $(Build.SourceBranchName) test_filter: '*' _r_check_system_clock_: 0 - PERF_PROFILE: 'azure-pipeline' - + perf.profile: 'azure-pipeline' ######################################################################################### @@ -184,7 +183,7 @@ jobs: # R output and messages are redirected by sink() to test_console_output.txt # junit reporter output is to test_results.xml - sudo R -q -e ' + sudo env PERF_PROFILE=$PERF_PROFILE R -q -e ' library(covr); write.csv( coverage_to_list( From 1923a11d90f111bf09170c997fd9328aa5ed18b1 Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Mon, 21 Sep 2026 13:36:03 +0100 Subject: [PATCH 12/22] Update to Circle CI code coverage --- .circleci/config.yml | 22 ++++++---------------- azure-pipelines.yml | 4 ++-- 2 files changed, 8 insertions(+), 18 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index ec6d40e9..f944e3ab 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -26,22 +26,12 @@ jobs: - run: command: | echo "options(Ncpus=4)" >> ~/.Rprofile - sudo Rscript -e "install.packages('RANN', dependencies=TRUE)" - sudo Rscript -e "install.packages('stringr', dependencies=TRUE)" - sudo Rscript -e "install.packages('lme4', dependencies=TRUE)" - sudo Rscript -e "install.packages('dplyr', dependencies=TRUE)" - sudo Rscript -e "install.packages('reshape2', dependencies=TRUE)" - sudo Rscript -e "install.packages('polycor', dependencies=TRUE)" - sudo Rscript -e "install.packages('splines', dependencies=TRUE)" - sudo Rscript -e "install.packages('gamlss', dependencies=TRUE)" - sudo Rscript -e "install.packages('gamlss.dist', dependencies=TRUE)" - sudo Rscript -e "install.packages('mice', dependencies=TRUE)" - sudo Rscript -e "install.packages('childsds', dependencies=TRUE)" - sudo Rscript -e "install.packages('xml2', dependencies=TRUE)" - sudo Rscript -e "install.packages('covr', dependencies=TRUE)" - sudo Rscript -e "install.packages('devtools', dependencies=TRUE)" - sudo Rscript -e "install.packages('DSI', dependencies=TRUE)" - sudo Rscript -e "install.packages('DSLite', 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> - run: command: | sudo Rscript -e 'library(covr); covr::codecov(token = "'$CODECOV_TOKEN'")' diff --git a/azure-pipelines.yml b/azure-pipelines.yml index 3d412045..77679f06 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -49,13 +49,13 @@ schedules: displayName: Weekly build - latest release branches: include: - - 6.3.4 + - 6.3.5 always: true - cron: "0 1 * * *" displayName: Nightly build - development branchs branches: include: - - v6.3.5-dev + - v6.3.6-dev - v6.4.0-dev - v7.0.0-dev always: true From f670258ea21afdb6692417c29a056266b1bebc38 Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Mon, 21 Sep 2026 13:40:36 +0100 Subject: [PATCH 13/22] Fixed Comments, I hope --- .circleci/config.yml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index f944e3ab..278e2716 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -27,10 +27,10 @@ jobs: command: | echo "options(Ncpus=4)" >> ~/.Rprofile - # 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. +# 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> - run: command: | From eec1ebe5cb8f935b0cbad5ea9b6c2928db86cc72 Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Mon, 21 Sep 2026 13:42:57 +0100 Subject: [PATCH 14/22] Fixed Comments --- .circleci/config.yml | 5 ----- 1 file changed, 5 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 278e2716..404c595c 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -26,11 +26,6 @@ jobs: - run: command: | echo "options(Ncpus=4)" >> ~/.Rprofile - -# 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> - run: command: | From c867e6e0130667d72d3c11d63945f5248f3940bb Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Mon, 21 Sep 2026 14:07:24 +0100 Subject: [PATCH 15/22] Fixed Comments --- .circleci/config.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 404c595c..7ee4e084 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -26,7 +26,8 @@ jobs: - run: command: | echo "options(Ncpus=4)" >> ~/.Rprofile - 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> + + 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)" - run: command: | sudo Rscript -e 'library(covr); covr::codecov(token = "'$CODECOV_TOKEN'")' From 824fb5dc2f6ba6c37ecb98a3d5120b157728edeb Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Mon, 21 Sep 2026 14:38:07 +0100 Subject: [PATCH 16/22] Fix CircleCI performance --- tests/testthat/perf_files/azure-pipeline_perf-profile.csv | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/perf_files/azure-pipeline_perf-profile.csv b/tests/testthat/perf_files/azure-pipeline_perf-profile.csv index 43418639..7b8753a1 100644 --- a/tests/testthat/perf_files/azure-pipeline_perf-profile.csv +++ b/tests/testthat/perf_files/azure-pipeline_perf-profile.csv @@ -1,5 +1,5 @@ "refer_name","rate","lower_tolerance","upper_tolerance" "meanDS::perf::numeric::0","4497.0","0.5","2" "meanDS::perf::numberAndNA::0","4542.0","0.5","2" -"varDS::perf::numeric::0","4584.0","0.5","2" -"varDS::perf::numberAndNA::0","4590.0","0.5","2" +"varDS::perf::numeric::0","6220.0","0.5","2" +"varDS::perf::numberAndNA::0","6250.0","0.5","2" From 45778954b86d59c12ee13a3830ffbb0ee5afe166 Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Mon, 21 Sep 2026 15:15:43 +0100 Subject: [PATCH 17/22] Added debugging output --- tests/testthat/test-perf-varDS.R | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/tests/testthat/test-perf-varDS.R b/tests/testthat/test-perf-varDS.R index d7e2131c..daffd00b 100644 --- a/tests/testthat/test-perf-varDS.R +++ b/tests/testthat/test-perf-varDS.R @@ -51,6 +51,8 @@ test_that("numeric varDS - performance", { print(paste("varDS::perf::numeric::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) } + write(.current.rate, stderr()) + .reference.rate <- perf.reference.rate("varDS::perf::numeric::0") .reference.tolerance.lower <- perf.reference.tolerance.lower("varDS::perf::numeric::0") .reference.tolerance.upper <- perf.reference.tolerance.upper("varDS::perf::numeric::0") @@ -86,10 +88,16 @@ test_that("numeric varDS, with NA - performance", { print(paste("varDS::perf::numberAndNA::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) } + write(.current.rate, stderr()) + .reference.rate <- perf.reference.rate("varDS::perf::numberAndNA::0") .reference.tolerance.lower <- perf.reference.tolerance.lower("varDS::perf::numberAndNA::0") .reference.tolerance.upper <- perf.reference.tolerance.upper("varDS::perf::numberAndNA::0") + write(.current.rate, stderr()) + write(.reference.rate * .reference.tolerance.lower, stderr()) + write(.reference.rate * .reference.tolerance.upper, stderr()) + expect_gt(.current.rate, .reference.rate * .reference.tolerance.lower, label = "Observed rate", expected.label = "lower threshold on rate") expect_lt(.current.rate, .reference.rate * .reference.tolerance.upper, label = "Observed rate", expected.label = "upper threshold on rate") }) From cfead15bef74ed047b8bfa145c6ce1be98b10e2e Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Mon, 21 Sep 2026 15:34:39 +0100 Subject: [PATCH 18/22] Added debugging output --- tests/testthat/test-perf-varDS.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/tests/testthat/test-perf-varDS.R b/tests/testthat/test-perf-varDS.R index daffd00b..3b7b0fac 100644 --- a/tests/testthat/test-perf-varDS.R +++ b/tests/testthat/test-perf-varDS.R @@ -51,7 +51,7 @@ test_that("numeric varDS - performance", { print(paste("varDS::perf::numeric::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) } - write(.current.rate, stderr()) + expect_equal(.current.rate, 0.0) .reference.rate <- perf.reference.rate("varDS::perf::numeric::0") .reference.tolerance.lower <- perf.reference.tolerance.lower("varDS::perf::numeric::0") @@ -88,15 +88,15 @@ test_that("numeric varDS, with NA - performance", { print(paste("varDS::perf::numberAndNA::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) } - write(.current.rate, stderr()) + expect_equal(.current.rate, 0.0) .reference.rate <- perf.reference.rate("varDS::perf::numberAndNA::0") .reference.tolerance.lower <- perf.reference.tolerance.lower("varDS::perf::numberAndNA::0") .reference.tolerance.upper <- perf.reference.tolerance.upper("varDS::perf::numberAndNA::0") - write(.current.rate, stderr()) - write(.reference.rate * .reference.tolerance.lower, stderr()) - write(.reference.rate * .reference.tolerance.upper, stderr()) + expect_equal(.current.rate, 0.0) + expect_equal(.reference.rate * .reference.tolerance.lower, 0.0) + expect_equal(.reference.rate * .reference.tolerance.upper, 0.0) expect_gt(.current.rate, .reference.rate * .reference.tolerance.lower, label = "Observed rate", expected.label = "lower threshold on rate") expect_lt(.current.rate, .reference.rate * .reference.tolerance.upper, label = "Observed rate", expected.label = "upper threshold on rate") From a3540d1b0aef77930f600f674cd5b66d3f83aa77 Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Mon, 21 Sep 2026 15:59:42 +0100 Subject: [PATCH 19/22] Remove debug code and adjust perf profile --- tests/testthat/perf_files/azure-pipeline_perf-profile.csv | 4 ++-- tests/testthat/test-perf-varDS.R | 8 -------- 2 files changed, 2 insertions(+), 10 deletions(-) diff --git a/tests/testthat/perf_files/azure-pipeline_perf-profile.csv b/tests/testthat/perf_files/azure-pipeline_perf-profile.csv index 7b8753a1..d1fcd743 100644 --- a/tests/testthat/perf_files/azure-pipeline_perf-profile.csv +++ b/tests/testthat/perf_files/azure-pipeline_perf-profile.csv @@ -1,5 +1,5 @@ "refer_name","rate","lower_tolerance","upper_tolerance" "meanDS::perf::numeric::0","4497.0","0.5","2" "meanDS::perf::numberAndNA::0","4542.0","0.5","2" -"varDS::perf::numeric::0","6220.0","0.5","2" -"varDS::perf::numberAndNA::0","6250.0","0.5","2" +"varDS::perf::numeric::0","6373.0","0.5","2" +"varDS::perf::numberAndNA::0","25090.0","0.5","2" diff --git a/tests/testthat/test-perf-varDS.R b/tests/testthat/test-perf-varDS.R index 3b7b0fac..d7e2131c 100644 --- a/tests/testthat/test-perf-varDS.R +++ b/tests/testthat/test-perf-varDS.R @@ -51,8 +51,6 @@ test_that("numeric varDS - performance", { print(paste("varDS::perf::numeric::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) } - expect_equal(.current.rate, 0.0) - .reference.rate <- perf.reference.rate("varDS::perf::numeric::0") .reference.tolerance.lower <- perf.reference.tolerance.lower("varDS::perf::numeric::0") .reference.tolerance.upper <- perf.reference.tolerance.upper("varDS::perf::numeric::0") @@ -88,16 +86,10 @@ test_that("numeric varDS, with NA - performance", { print(paste("varDS::perf::numberAndNA::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) } - expect_equal(.current.rate, 0.0) - .reference.rate <- perf.reference.rate("varDS::perf::numberAndNA::0") .reference.tolerance.lower <- perf.reference.tolerance.lower("varDS::perf::numberAndNA::0") .reference.tolerance.upper <- perf.reference.tolerance.upper("varDS::perf::numberAndNA::0") - expect_equal(.current.rate, 0.0) - expect_equal(.reference.rate * .reference.tolerance.lower, 0.0) - expect_equal(.reference.rate * .reference.tolerance.upper, 0.0) - expect_gt(.current.rate, .reference.rate * .reference.tolerance.lower, label = "Observed rate", expected.label = "lower threshold on rate") expect_lt(.current.rate, .reference.rate * .reference.tolerance.upper, label = "Observed rate", expected.label = "upper threshold on rate") }) From 68f60165685482336b98711231b4743111e1ce91 Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Mon, 21 Sep 2026 17:00:43 +0100 Subject: [PATCH 20/22] Update logging --- tests/testthat/test-perf-meanDS.R | 8 ++++---- tests/testthat/test-perf-varDS.R | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/tests/testthat/test-perf-meanDS.R b/tests/testthat/test-perf-meanDS.R index d6355336..617b0481 100644 --- a/tests/testthat/test-perf-meanDS.R +++ b/tests/testthat/test-perf-meanDS.R @@ -45,10 +45,10 @@ test_that("numeric meanDS - performance", { .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) .reference.rate <- perf.reference.rate("meanDS::perf::numeric::0") if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { - print(paste("meanDS::perf::numeric::0 ", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper())) + write(paste("meanDS::perf::numeric::0 ", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper()), stderr()) perf.reference.save("meanDS::perf::numeric::0", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper()) } else { - print(paste("meanDS::perf::numeric::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + write(paste("meanDS::perf::numeric::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = ''), stderr()) } .reference.rate <- perf.reference.rate("meanDS::perf::numeric::0") @@ -80,10 +80,10 @@ test_that("numeric meanDS, with NA - performance", { .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) .reference.rate <- perf.reference.rate("meanDS::perf::numberAndNA::0") if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { - print(paste("meanDS::perf::numberAndNA::0 ", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper())) + write(paste("meanDS::perf::numberAndNA::0 ", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper()), stderr()) perf.reference.save("meanDS::perf::numberAndNA::0", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper()) } else { - print(paste("meanDS::perf::numberAndNA::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + write(paste("meanDS::perf::numberAndNA::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = ''), stderr()) } .reference.rate <- perf.reference.rate("meanDS::perf::numberAndNA::0") diff --git a/tests/testthat/test-perf-varDS.R b/tests/testthat/test-perf-varDS.R index d7e2131c..2bb8205d 100644 --- a/tests/testthat/test-perf-varDS.R +++ b/tests/testthat/test-perf-varDS.R @@ -45,10 +45,10 @@ test_that("numeric varDS - performance", { .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) .reference.rate <- perf.reference.rate("varDS::perf::numeric::0") if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { - print(paste("varDS::perf::numeric::0 ", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper())) + write(paste("varDS::perf::numeric::0 ", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper()), stderr()) perf.reference.save("varDS::perf::numeric::0", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper()) } else { - print(paste("varDS::perf::numeric::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + write((paste("varDS::perf::numeric::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = ''), stderr()) } .reference.rate <- perf.reference.rate("varDS::perf::numeric::0") @@ -80,10 +80,10 @@ test_that("numeric varDS, with NA - performance", { .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) .reference.rate <- perf.reference.rate("varDS::perf::numberAndNA::0") if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { - print(paste("varDS::perf::numberAndNA::0 ", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper())) + write(paste("varDS::perf::numberAndNA::0 ", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper()), stderr()) perf.reference.save("varDS::perf::numberAndNA::0", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper()) } else { - print(paste("varDS::perf::numberAndNA::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + write(paste("varDS::perf::numberAndNA::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = ''), stderr()) } .reference.rate <- perf.reference.rate("varDS::perf::numberAndNA::0") From fd3db55e55839b83685337cc1959f0d891d8cb0f Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Mon, 21 Sep 2026 17:15:10 +0100 Subject: [PATCH 21/22] Fix code typo --- tests/testthat/test-perf-varDS.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-perf-varDS.R b/tests/testthat/test-perf-varDS.R index 2bb8205d..4f1f18e0 100644 --- a/tests/testthat/test-perf-varDS.R +++ b/tests/testthat/test-perf-varDS.R @@ -48,7 +48,7 @@ test_that("numeric varDS - performance", { write(paste("varDS::perf::numeric::0 ", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper()), stderr()) perf.reference.save("varDS::perf::numeric::0", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper()) } else { - write((paste("varDS::perf::numeric::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = ''), stderr()) + write(paste("varDS::perf::numeric::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = ''), stderr()) } .reference.rate <- perf.reference.rate("varDS::perf::numeric::0") From 59d76dec279903cda453b6a3b2e6f0f8664aef30 Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Mon, 21 Sep 2026 17:33:20 +0100 Subject: [PATCH 22/22] Fix perf profile --- tests/testthat/perf_files/azure-pipeline_perf-profile.csv | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/perf_files/azure-pipeline_perf-profile.csv b/tests/testthat/perf_files/azure-pipeline_perf-profile.csv index d1fcd743..5267505e 100644 --- a/tests/testthat/perf_files/azure-pipeline_perf-profile.csv +++ b/tests/testthat/perf_files/azure-pipeline_perf-profile.csv @@ -2,4 +2,4 @@ "meanDS::perf::numeric::0","4497.0","0.5","2" "meanDS::perf::numberAndNA::0","4542.0","0.5","2" "varDS::perf::numeric::0","6373.0","0.5","2" -"varDS::perf::numberAndNA::0","25090.0","0.5","2" +"varDS::perf::numberAndNA::0","4500.0","0.5","2"