From 5e8e1d078cd13ba2c083751e0f187a6a359124d9 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Tue, 22 Sep 2026 12:34:28 +0200 Subject: [PATCH 1/2] refactor for last functions --- R/ds.auc.R | 15 ++------------- R/ds.bp_standards.R | 17 ++--------------- R/ds.exists.R | 11 ++--------- R/ds.igb_standards.R | 17 ++--------------- R/ds.listDisclosureSettings.R | 11 ++--------- R/ds.mdPattern.R | 26 ++++++++++++-------------- R/ds.rm.R | 11 ++--------- man/dot-pool_md_patterns.Rd | 20 -------------------- man/ds.auc.Rd | 2 ++ man/ds.bp_standards.Rd | 2 ++ man/ds.exists.Rd | 2 ++ man/ds.igb_standards.Rd | 2 ++ man/ds.listDisclosureSettings.Rd | 2 ++ man/ds.mdPattern.Rd | 12 +++++++++++- man/ds.rm.Rd | 2 ++ 15 files changed, 47 insertions(+), 105 deletions(-) delete mode 100644 man/dot-pool_md_patterns.Rd diff --git a/R/ds.auc.R b/R/ds.auc.R index ebfc5fc31..8b16502b1 100644 --- a/R/ds.auc.R +++ b/R/ds.auc.R @@ -11,19 +11,12 @@ #' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}. #' @return returns the AUC and its standard error #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' ds.auc <- function(pred=NULL, y=NULL, datasources=NULL){ - # look for DS connections - if(is.null(datasources)){ - datasources <- DSI::datashield.connections_find() - } - - # ensure datasources is a list of DSConnection-class - if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){ - stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE) - } + datasources <- .set_datasources(datasources) # verify that 'pred' was set if(is.null(pred)){ @@ -35,10 +28,6 @@ ds.auc <- function(pred=NULL, y=NULL, datasources=NULL){ stop("Please provide the name of the outcome variable", call.=FALSE) } - # check if the pred and y objects are defined in all the studies - defined.pred <- isDefined(datasources, pred) - defined.y <- isDefined(datasources, y) - cally <- call('aucDS', pred, y) output <- DSI::datashield.aggregate(datasources, cally) diff --git a/R/ds.bp_standards.R b/R/ds.bp_standards.R index ae76c54ca..fe9b69fa5 100644 --- a/R/ds.bp_standards.R +++ b/R/ds.bp_standards.R @@ -26,20 +26,13 @@ #' blood pressure in children and adolescents: #' https://www.nhlbi.nih.gov/sites/default/files/media/docs/hbp_ped.pdf #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @import data.table #' @export ds.bp_standards <- function(sex=NULL, age=NULL, height=NULL, bp=NULL, systolic=TRUE, newobj=NULL, datasources=NULL){ - # look for DS connections - if(is.null(datasources)){ - datasources <- DSI::datashield.connections_find() - } - - # ensure datasources is a list of DSConnection-class - if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){ - stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE) - } + datasources <- .set_datasources(datasources) # verify that 'sex' was set if(is.null(sex)){ @@ -61,12 +54,6 @@ ds.bp_standards <- function(sex=NULL, age=NULL, height=NULL, bp=NULL, systolic=T stop("Please provide the name of the blood pressure variable", call.=FALSE) } - # check if the input objects are defined in all the studies - defined.sex <- isDefined(datasources, sex) - defined.age <- isDefined(datasources, age) - defined.height <- isDefined(datasources, height) - defined.bp <- isDefined(datasources, bp) - # if no output object specified then provide a default name if(is.null(newobj)){ newobj <- "bp.newobj" diff --git a/R/ds.exists.R b/R/ds.exists.R index 6dff8b4c1..c284401f1 100644 --- a/R/ds.exists.R +++ b/R/ds.exists.R @@ -16,6 +16,7 @@ #' @return \code{ds.exists} returns a logical object. #' TRUE if the object is on the server-side and FALSE otherwise. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @seealso \code{\link{ds.class}} to check the type of an object. #' @seealso \code{\link{ds.length}} to check the length of an object. #' @seealso \code{\link{ds.dim}} to check the dimension of an object. @@ -61,15 +62,7 @@ #' ds.exists <- function(x=NULL, datasources=NULL){ - # look for DS connections - if(is.null(datasources)){ - datasources <- datashield.connections_find() - } - - # ensure datasources is a list of DSConnection-class - if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){ - stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE) - } + datasources <- .set_datasources(datasources) if(is.null(x)){ stop("Please provide the name of the input object!", call.=FALSE) diff --git a/R/ds.igb_standards.R b/R/ds.igb_standards.R index 89498a0ca..dd4023045 100644 --- a/R/ds.igb_standards.R +++ b/R/ds.igb_standards.R @@ -36,20 +36,13 @@ #' } #' @return assigns the converted measurement as a new object on the server-side #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' ds.igb_standards <- function(gagebrth=NULL, z=0, p=50, val=NULL, var=NULL, sex=NULL, fun='igb_value2zscore', newobj=NULL, datasources=NULL){ - # look for DS connections - if(is.null(datasources)){ - datasources <- datashield.connections_find() - } - - # ensure datasources is a list of DSConnection-class - if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){ - stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE) - } + datasources <- .set_datasources(datasources) # check if user has provided the name of the input variables if(is.null(gagebrth)){ @@ -59,10 +52,6 @@ ds.igb_standards <- function(gagebrth=NULL, z=0, p=50, val=NULL, var=NULL, sex=N stop("Please provide the name of the sex variable", call.=FALSE) } - # check if the input objects are defined in all the studies - isDefined(datasources, gagebrth) - isDefined(datasources, sex) - # check if the provided fun is valid if(!(fun %in% c("igb_centile2value","igb_zscore2value","igb_value2zscore","igb_value2centile"))){ stop("Please provide a valid fun", call.=FALSE) @@ -72,8 +61,6 @@ ds.igb_standards <- function(gagebrth=NULL, z=0, p=50, val=NULL, var=NULL, sex=N if(fun %in% c("igb_value2zscore","igb_value2centile")){ if(is.null(val)){ stop("Please provide the name of the val variable", call.=FALSE) - }else{ - isDefined(datasources, val) } } diff --git a/R/ds.listDisclosureSettings.R b/R/ds.listDisclosureSettings.R index 33c73875c..9848bcde2 100644 --- a/R/ds.listDisclosureSettings.R +++ b/R/ds.listDisclosureSettings.R @@ -57,6 +57,7 @@ #' @return \code{ds.listDisclosureSettings} returns a list containing the current settings of the #' \code{nfilters} in each study specified. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' @examples #' \dontrun{ @@ -100,15 +101,7 @@ #' } #' ds.listDisclosureSettings <- function(datasources=NULL){ - # look for DS connections - if(is.null(datasources)){ - datasources <- datashield.connections_find() - } - - # ensure datasources is a list of DSConnection-class - if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){ - stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE) - } + datasources <- .set_datasources(datasources) # CALL THE MAIN SERVER SIDE FUNCTION calltext <- call("listDisclosureSettingsDS") diff --git a/R/ds.mdPattern.R b/R/ds.mdPattern.R index af59498e2..b9786debe 100644 --- a/R/ds.mdPattern.R +++ b/R/ds.mdPattern.R @@ -46,6 +46,7 @@ #' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained #' after login. If the \code{datasources} argument is not specified, the default set of #' connections will be used: see \code{\link[DSI]{datashield.connections_default}}. +#' @template classConsistencyCheckTrue #' @return For type='split': A list with one element per study, each containing: #' \describe{ #' \item{pattern}{The missing data pattern matrix for that study} @@ -60,6 +61,7 @@ #' \item{message}{A message describing the validity status} #' } #' @author Xavier Escribà montagut for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' @examples #' \dontrun{ @@ -107,17 +109,9 @@ #' datashield.logout(connections) #' } #' -ds.mdPattern <- function(x = NULL, type = 'split', datasources = NULL){ +ds.mdPattern <- function(x = NULL, type = 'split', datasources = NULL, classConsistencyCheck = TRUE){ - # Look for DS connections - if(is.null(datasources)){ - datasources <- datashield.connections_find() - } - - # Ensure datasources is a list of DSConnection-class - if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){ - stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE) - } + datasources <- .set_datasources(datasources) if(is.null(x)){ stop("Please provide the name of a data frame or matrix!", call.=FALSE) @@ -130,10 +124,14 @@ ds.mdPattern <- function(x = NULL, type = 'split', datasources = NULL){ cally <- call("mdPatternDS", x) results <- DSI::datashield.aggregate(datasources, cally) + if(classConsistencyCheck){ + .checkClassConsistency(results) + } + # Process results based on type if(type == "split"){ # Return individual study results - return(results) + return(lapply(results, function(r) { r$class <- NULL; r })) } else if(type == "combine"){ # Pool results across studies @@ -172,7 +170,7 @@ ds.mdPattern <- function(x = NULL, type = 'split', datasources = NULL){ } # Pool the patterns - pooled_pattern <- .pool_md_patterns(patterns_list, study_names) + pooled_pattern <- .poolMdPatterns(patterns_list, study_names) # Check validity of pooled results # Get threshold from first study's results or use a default check @@ -213,8 +211,8 @@ ds.mdPattern <- function(x = NULL, type = 'split', datasources = NULL){ #' @param patterns_list List of pattern matrices from each study #' @param study_names Names of the studies #' @return Pooled pattern matrix -#' @keywords internal -.pool_md_patterns <- function(patterns_list, study_names){ +#' @noRd +.poolMdPatterns <- function(patterns_list, study_names){ # Initialize with first study's pattern structure pooled <- patterns_list[[1]] diff --git a/R/ds.rm.R b/R/ds.rm.R index e977afe5c..31fda6368 100644 --- a/R/ds.rm.R +++ b/R/ds.rm.R @@ -22,6 +22,7 @@ #' is successful the message \code{"Object(s) '' was deleted."} is returned #' to the client-side. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @examples #' \dontrun{ #' @@ -68,15 +69,7 @@ ds.rm<-function(x.names=NULL, datasources=NULL){ - # look for DS connections - if (is.null(datasources)) { - datasources <- datashield.connections_find() - } - - # ensure datasources is a list of DSConnection-class - if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){ - stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE) - } + datasources <- .set_datasources(datasources) if (is.null(x.names)) { stop("Please provide the names of the objects to be deleted (eg 'object.name') as the x.names argument", call.=FALSE) diff --git a/man/dot-pool_md_patterns.Rd b/man/dot-pool_md_patterns.Rd deleted file mode 100644 index baabf3e92..000000000 --- a/man/dot-pool_md_patterns.Rd +++ /dev/null @@ -1,20 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ds.mdPattern.R -\name{.pool_md_patterns} -\alias{.pool_md_patterns} -\title{Pool missing data patterns across studies} -\usage{ -.pool_md_patterns(patterns_list, study_names) -} -\arguments{ -\item{patterns_list}{List of pattern matrices from each study} - -\item{study_names}{Names of the studies} -} -\value{ -Pooled pattern matrix -} -\description{ -Internal function to pool md.pattern results from multiple studies -} -\keyword{internal} diff --git a/man/ds.auc.Rd b/man/ds.auc.Rd index 0ca1a5d37..133a904e2 100644 --- a/man/ds.auc.Rd +++ b/man/ds.auc.Rd @@ -28,4 +28,6 @@ The AUC determines the discriminative ability of a model. } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.bp_standards.Rd b/man/ds.bp_standards.Rd index edbdd06dd..ff7a31719 100644 --- a/man/ds.bp_standards.Rd +++ b/man/ds.bp_standards.Rd @@ -55,4 +55,6 @@ https://www.nhlbi.nih.gov/sites/default/files/media/docs/hbp_ped.pdf } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.exists.Rd b/man/ds.exists.Rd index 2352a2941..8bca339b0 100644 --- a/man/ds.exists.Rd +++ b/man/ds.exists.Rd @@ -79,4 +79,6 @@ Server function called: \code{exists} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.igb_standards.Rd b/man/ds.igb_standards.Rd index e9ab20f51..686041a65 100644 --- a/man/ds.igb_standards.Rd +++ b/man/ds.igb_standards.Rd @@ -70,4 +70,6 @@ standard is used. } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.listDisclosureSettings.Rd b/man/ds.listDisclosureSettings.Rd index 23ab83fd7..9baecbf8f 100644 --- a/man/ds.listDisclosureSettings.Rd +++ b/man/ds.listDisclosureSettings.Rd @@ -114,4 +114,6 @@ Server function called: \code{listDisclosureSettingsDS} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.mdPattern.Rd b/man/ds.mdPattern.Rd index b1bacc0b1..c2f4f4ea9 100644 --- a/man/ds.mdPattern.Rd +++ b/man/ds.mdPattern.Rd @@ -4,7 +4,12 @@ \alias{ds.mdPattern} \title{Display missing data patterns with disclosure control} \usage{ -ds.mdPattern(x = NULL, type = "split", datasources = NULL) +ds.mdPattern( + x = NULL, + type = "split", + datasources = NULL, + classConsistencyCheck = TRUE +) } \arguments{ \item{x}{a character string specifying the name of a data frame or matrix on the @@ -17,6 +22,9 @@ across studies.} \item{datasources}{a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login. If the \code{datasources} argument is not specified, the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.} + +\item{classConsistencyCheck}{logical. If TRUE, checks that the input object has the same +class across all studies. Default TRUE.} } \value{ For type='split': A list with one element per study, each containing: @@ -123,4 +131,6 @@ for disclosure control: } \author{ Xavier Escribà montagut for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/ds.rm.Rd b/man/ds.rm.Rd index a63786217..75df1aa7d 100644 --- a/man/ds.rm.Rd +++ b/man/ds.rm.Rd @@ -82,4 +82,6 @@ Server function called: \code{rmDS} } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } From 3a4bc5fb5eadcd4fd578d45f6d2b60066033efae Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Tue, 22 Sep 2026 12:34:43 +0200 Subject: [PATCH 2/2] added test coverage --- tests/testthat/test-arg-ds.auc.R | 3 + tests/testthat/test-perf-ds.auc.R | 52 +++++++++++ tests/testthat/test-perf-ds.bp_standards.R | 52 +++++++++++ tests/testthat/test-perf-ds.igb_standards.R | 52 +++++++++++ .../test-perf-ds.listDisclosureSettings.R | 50 ++++++++++ tests/testthat/test-perf-ds.mdPattern.R | 50 ++++++++++ tests/testthat/test-perf-ds.rm.R | 50 ++++++++++ tests/testthat/test-smk-ds.auc.R | 71 +++++++++++++++ tests/testthat/test-smk-ds.bp_standards.R | 56 ++++++++++++ tests/testthat/test-smk-ds.igb_standards.R | 56 ++++++++++++ tests/testthat/test-smk-ds.mdPattern.R | 91 +++++++++++++++++++ 11 files changed, 583 insertions(+) create mode 100644 tests/testthat/test-perf-ds.auc.R create mode 100644 tests/testthat/test-perf-ds.bp_standards.R create mode 100644 tests/testthat/test-perf-ds.igb_standards.R create mode 100644 tests/testthat/test-perf-ds.listDisclosureSettings.R create mode 100644 tests/testthat/test-perf-ds.mdPattern.R create mode 100644 tests/testthat/test-perf-ds.rm.R create mode 100644 tests/testthat/test-smk-ds.auc.R create mode 100644 tests/testthat/test-smk-ds.bp_standards.R create mode 100644 tests/testthat/test-smk-ds.igb_standards.R create mode 100644 tests/testthat/test-smk-ds.mdPattern.R diff --git a/tests/testthat/test-arg-ds.auc.R b/tests/testthat/test-arg-ds.auc.R index ade352110..55978417a 100644 --- a/tests/testthat/test-arg-ds.auc.R +++ b/tests/testthat/test-arg-ds.auc.R @@ -15,6 +15,8 @@ # context("ds.auc::arg::setup") +connect.studies.dataset.cnsim(list("LAB_TSC")) + # # Tests # @@ -33,4 +35,5 @@ test_that("ds.auc errors for null pred or y", { # # context("ds.auc::arg::shutdown") +disconnect.studies.dataset.cnsim() # context("ds.auc::arg::done") diff --git a/tests/testthat/test-perf-ds.auc.R b/tests/testthat/test-perf-ds.auc.R new file mode 100644 index 000000000..e961c8840 --- /dev/null +++ b/tests/testthat/test-perf-ds.auc.R @@ -0,0 +1,52 @@ + +# +# Set up +# + +# context("ds.auc::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TRIG", "DIS_DIAB")) +ds.glmSLMA('D$DIS_DIAB~D$LAB_TRIG', family = "binomial", newobj = "auc.glm") +ds.glmPredict("auc.glm", output.type = "link", se.fit = FALSE, newobj = "auc.pred") + +# +# Tests +# + +# context("ds.auc::perf::0") +test_that("performance", { + .durationSec <- perf.testduration() + .count <- 0 + .start.time <- Sys.time() + .current.time <- .start.time + + while (difftime(.current.time, .start.time, units = "secs")[[1]] < .durationSec) { + ds.auc(pred = "auc.pred$fit", y = "auc.glm$y") + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.auc::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.auc::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.auc::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.auc::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.auc::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.auc::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.auc::perf::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") +}) + +# +# Done +# + +# context("ds.auc::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.auc::perf::done") diff --git a/tests/testthat/test-perf-ds.bp_standards.R b/tests/testthat/test-perf-ds.bp_standards.R new file mode 100644 index 000000000..7771c8b22 --- /dev/null +++ b/tests/testthat/test-perf-ds.bp_standards.R @@ -0,0 +1,52 @@ + +# +# Set up +# + +# context("ds.bp_standards::perf::setup") +connect.studies.dataset.anthro(list("age", "sex", "weight", "height", "muac")) +ds.make("D$age/12", "age.years") +ds.make("D$muac*7", "bp.value") + +# +# Tests +# + +# context("ds.bp_standards::perf::0") +test_that("performance", { + .durationSec <- perf.testduration() + .count <- 0 + .start.time <- Sys.time() + .current.time <- .start.time + + while (difftime(.current.time, .start.time, units = "secs")[[1]] < .durationSec) { + ds.bp_standards(sex = "D$sex", age = "age.years", height = "D$height", bp = "bp.value", systolic = TRUE, newobj = "bp.out") + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.bp_standards::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.bp_standards::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.bp_standards::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.bp_standards::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.bp_standards::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.bp_standards::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.bp_standards::perf::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") +}) + +# +# Done +# + +# context("ds.bp_standards::perf::shutdown") +disconnect.studies.dataset.anthro() +# context("ds.bp_standards::perf::done") diff --git a/tests/testthat/test-perf-ds.igb_standards.R b/tests/testthat/test-perf-ds.igb_standards.R new file mode 100644 index 000000000..12dd2e6be --- /dev/null +++ b/tests/testthat/test-perf-ds.igb_standards.R @@ -0,0 +1,52 @@ + +# +# Set up +# + +# context("ds.igb_standards::perf::setup") +connect.studies.dataset.anthro(list("age", "sex", "weight", "height", "muac")) +ds.make("(D$age*0)+280", "gagebrth") +ds.recodeValues(var.name = "D$sex", values2replace.vector = c(1, 2), new.values.vector = c("Male", "Female"), newobj = "sex.label") + +# +# Tests +# + +# context("ds.igb_standards::perf::0") +test_that("performance", { + .durationSec <- perf.testduration() + .count <- 0 + .start.time <- Sys.time() + .current.time <- .start.time + + while (difftime(.current.time, .start.time, units = "secs")[[1]] < .durationSec) { + ds.igb_standards(gagebrth = "gagebrth", z = 0, p = 50, var = "lencm", sex = "sex.label", fun = "igb_centile2value", newobj = "igb.out") + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.igb_standards::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.igb_standards::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.igb_standards::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.igb_standards::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.igb_standards::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.igb_standards::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.igb_standards::perf::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") +}) + +# +# Done +# + +# context("ds.igb_standards::perf::shutdown") +disconnect.studies.dataset.anthro() +# context("ds.igb_standards::perf::done") diff --git a/tests/testthat/test-perf-ds.listDisclosureSettings.R b/tests/testthat/test-perf-ds.listDisclosureSettings.R new file mode 100644 index 000000000..9de207f1a --- /dev/null +++ b/tests/testthat/test-perf-ds.listDisclosureSettings.R @@ -0,0 +1,50 @@ + +# +# Set up +# + +# context("ds.listDisclosureSettings::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_HDL")) + +# +# Tests +# + +# context("ds.listDisclosureSettings::perf::0") +test_that("performance", { + .durationSec <- perf.testduration() + .count <- 0 + .start.time <- Sys.time() + .current.time <- .start.time + + while (difftime(.current.time, .start.time, units = "secs")[[1]] < .durationSec) { + ds.listDisclosureSettings() + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.listDisclosureSettings::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.listDisclosureSettings::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.listDisclosureSettings::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.listDisclosureSettings::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.listDisclosureSettings::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.listDisclosureSettings::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.listDisclosureSettings::perf::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") +}) + +# +# Done +# + +# context("ds.listDisclosureSettings::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.listDisclosureSettings::perf::done") diff --git a/tests/testthat/test-perf-ds.mdPattern.R b/tests/testthat/test-perf-ds.mdPattern.R new file mode 100644 index 000000000..3c17fb465 --- /dev/null +++ b/tests/testthat/test-perf-ds.mdPattern.R @@ -0,0 +1,50 @@ + +# +# Set up +# + +# context("ds.mdPattern::perf::setup") +connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_TRIG", "LAB_HDL")) + +# +# Tests +# + +# context("ds.mdPattern::perf::0") +test_that("performance", { + .durationSec <- perf.testduration() + .count <- 0 + .start.time <- Sys.time() + .current.time <- .start.time + + while (difftime(.current.time, .start.time, units = "secs")[[1]] < .durationSec) { + ds.mdPattern(x = "D", type = "split") + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.mdPattern::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.mdPattern::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.mdPattern::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.mdPattern::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.mdPattern::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.mdPattern::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.mdPattern::perf::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") +}) + +# +# Done +# + +# context("ds.mdPattern::perf::shutdown") +disconnect.studies.dataset.cnsim() +# context("ds.mdPattern::perf::done") diff --git a/tests/testthat/test-perf-ds.rm.R b/tests/testthat/test-perf-ds.rm.R new file mode 100644 index 000000000..20d3765bc --- /dev/null +++ b/tests/testthat/test-perf-ds.rm.R @@ -0,0 +1,50 @@ + +# +# Set up +# + +# context("ds.rm::perf::setup") +connect.studies.dataset.survival(list("survtime", "time.id", "female")) + +# +# Tests +# + +# context("ds.rm::perf::0") +test_that("performance", { + .durationSec <- perf.testduration() + .count <- 0 + .start.time <- Sys.time() + .current.time <- .start.time + + while (difftime(.current.time, .start.time, units = "secs")[[1]] < .durationSec) { + ds.rm("nonexistant_object") + + .count <- .count + 1 + .current.time <- Sys.time() + } + + .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) + .reference.rate <- perf.reference.rate("ds.rm::perf::0") + if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { + print(paste("ds.rm::perf::0 ", .current.rate, 0.5, 2.0)) + perf.reference.save("ds.rm::perf::0", .current.rate, 0.5, 2.0) + } else { + print(paste("ds.rm::perf::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + } + + .reference.rate <- perf.reference.rate("ds.rm::perf::0") + .reference.tolerance.lower <- perf.reference.tolerance.lower("ds.rm::perf::0") + .reference.tolerance.upper <- perf.reference.tolerance.upper("ds.rm::perf::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") +}) + +# +# Done +# + +# context("ds.rm::perf::shutdown") +disconnect.studies.dataset.survival() +# context("ds.rm::perf::done") diff --git a/tests/testthat/test-smk-ds.auc.R b/tests/testthat/test-smk-ds.auc.R new file mode 100644 index 000000000..4d99fe3e5 --- /dev/null +++ b/tests/testthat/test-smk-ds.auc.R @@ -0,0 +1,71 @@ + +# +# Set up +# + +# context("ds.auc::smk::setup") + +connect.studies.dataset.cnsim(list("LAB_TRIG", "DIS_DIAB")) + +test_that("setup", { + ds_expect_variables(c("D")) +}) + +ds.glmSLMA('D$DIS_DIAB~D$LAB_TRIG', family = "binomial", newobj = "auc.glm") +ds.glmPredict("auc.glm", output.type = "link", se.fit = FALSE, newobj = "auc.pred") + +# +# Tests +# + +# context("ds.auc::smk") +test_that("simple auc", { + res <- ds.auc(pred = "auc.pred$fit", y = "auc.glm$y") + + expect_length(res, 3) + for (study.res in res) { + expect_named(study.res, c("AUC", "se")) + expect_true(study.res$AUC > 0.5 && study.res$AUC < 1) + expect_true(study.res$se > 0) + } +}) + +test_that("fails if pred does not exist", { + expect_error( + ds.auc(pred = "nonexistent_object", y = "auc.glm$y"), + "There are some DataSHIELD errors, list them with datashield.errors()", + fixed = TRUE + ) + + res.errors <- DSI::datashield.errors() + for (study.errors in res.errors) { + expect_match(study.errors, "The server-side object 'nonexistent_object' does not exist") + } +}) + +test_that("fails if y does not exist", { + expect_error( + ds.auc(pred = "auc.pred$fit", y = "nonexistent_object"), + "There are some DataSHIELD errors, list them with datashield.errors()", + fixed = TRUE + ) + + res.errors <- DSI::datashield.errors() + for (study.errors in res.errors) { + expect_match(study.errors, "The server-side object 'nonexistent_object' does not exist") + } +}) + +# +# Done +# + +# context("ds.auc::smk::shutdown") + +test_that("shutdown", { + ds_expect_variables(c("D", "auc.glm", "auc.pred")) +}) + +disconnect.studies.dataset.cnsim() + +# context("ds.auc::smk::done") diff --git a/tests/testthat/test-smk-ds.bp_standards.R b/tests/testthat/test-smk-ds.bp_standards.R new file mode 100644 index 000000000..ab8a8baf4 --- /dev/null +++ b/tests/testthat/test-smk-ds.bp_standards.R @@ -0,0 +1,56 @@ + +# +# Set up +# + +# context("ds.bp_standards::smk::setup") + +connect.studies.dataset.anthro(list("age", "sex", "weight", "height", "muac")) + +test_that("setup", { + ds_expect_variables(c("D")) +}) + +ds.make("D$age/12", "age.years") +ds.make("D$muac*7", "bp.value") + +# +# Tests +# + +# context("ds.bp_standards::smk") +test_that("simple bp_standards", { + ds.bp_standards(sex = "D$sex", age = "age.years", height = "D$height", bp = "bp.value", systolic = TRUE, newobj = "bp.out") + + res.class <- ds.class("bp.out") + for (study.class in res.class) { + expect_equal(study.class, "list") + } +}) + +test_that("fails if an input does not exist", { + expect_error( + ds.bp_standards(sex = "D$sex", age = "age.years", height = "D$height", bp = "nonexistent_object", systolic = TRUE), + "There are some DataSHIELD errors, list them with datashield.errors()", + fixed = TRUE + ) + + res.errors <- DSI::datashield.errors() + for (study.errors in res.errors) { + expect_match(study.errors, "The server-side object 'nonexistent_object' does not exist") + } +}) + +# +# Done +# + +# context("ds.bp_standards::smk::shutdown") + +test_that("shutdown", { + ds_expect_variables(c("D", "age.years", "bp.value", "bp.out")) +}) + +disconnect.studies.dataset.anthro() + +# context("ds.bp_standards::smk::done") diff --git a/tests/testthat/test-smk-ds.igb_standards.R b/tests/testthat/test-smk-ds.igb_standards.R new file mode 100644 index 000000000..03d1454d3 --- /dev/null +++ b/tests/testthat/test-smk-ds.igb_standards.R @@ -0,0 +1,56 @@ + +# +# Set up +# + +# context("ds.igb_standards::smk::setup") + +connect.studies.dataset.anthro(list("age", "sex", "weight", "height", "muac")) + +test_that("setup", { + ds_expect_variables(c("D")) +}) + +ds.make("(D$age*0)+280", "gagebrth") +ds.recodeValues(var.name = "D$sex", values2replace.vector = c(1, 2), new.values.vector = c("Male", "Female"), newobj = "sex.label") + +# +# Tests +# + +# context("ds.igb_standards::smk") +test_that("simple igb_standards", { + ds.igb_standards(gagebrth = "gagebrth", z = 0, p = 50, var = "lencm", sex = "sex.label", fun = "igb_centile2value", newobj = "igb.out") + + res.class <- ds.class("igb.out") + for (study.class in res.class) { + expect_equal(study.class, "numeric") + } +}) + +test_that("fails if an input does not exist", { + expect_error( + ds.igb_standards(gagebrth = "nonexistent_object", z = 0, p = 50, var = "lencm", sex = "sex.label", fun = "igb_centile2value"), + "There are some DataSHIELD errors, list them with datashield.errors()", + fixed = TRUE + ) + + res.errors <- DSI::datashield.errors() + for (study.errors in res.errors) { + expect_match(study.errors, "The server-side object 'nonexistent_object' does not exist") + } +}) + +# +# Done +# + +# context("ds.igb_standards::smk::shutdown") + +test_that("shutdown", { + ds_expect_variables(c("D", "gagebrth", "sex.label", "igb.out")) +}) + +disconnect.studies.dataset.anthro() + +# context("ds.igb_standards::smk::done") diff --git a/tests/testthat/test-smk-ds.mdPattern.R b/tests/testthat/test-smk-ds.mdPattern.R new file mode 100644 index 000000000..725adfbe0 --- /dev/null +++ b/tests/testthat/test-smk-ds.mdPattern.R @@ -0,0 +1,91 @@ + +# +# Set up +# + +# context("ds.mdPattern::smk::setup") + +connect.studies.dataset.cnsim(list("LAB_TSC", "LAB_TRIG", "LAB_HDL")) + +test_that("setup", { + ds_expect_variables(c("D")) +}) + +# +# Tests +# + +# context("ds.mdPattern::smk::split") +test_that("simple mdPattern, split", { + res <- ds.mdPattern(x = "D", type = "split") + + expect_length(res, 3) + for (study.res in res) { + expect_named(study.res, c("pattern", "valid", "message")) + expect_true(is.matrix(study.res$pattern)) + } +}) + +# context("ds.mdPattern::smk::combine") +test_that("simple mdPattern, combine", { + warnings <- character() + res <- withCallingHandlers( + ds.mdPattern(x = "D", type = "combine"), + warning = function(w) { + warnings <<- c(warnings, conditionMessage(w)) + invokeRestart("muffleWarning") + } + ) + + expect_named(res, c("pattern", "valid", "message", "studies")) + expect_true(any(grepl("Disclosure control", warnings))) + expect_true(is.matrix(res$pattern)) +}) + +test_that("fails if the object does not exist", { + expect_error( + ds.mdPattern(x = "nonexistent_object"), + "There are some DataSHIELD errors, list them with datashield.errors()", + fixed = TRUE + ) + + res.errors <- DSI::datashield.errors() + for (study.errors in res.errors) { + expect_match(study.errors, "The server-side object 'nonexistent_object' does not exist") + } +}) + +test_that("fails if the object is not a data.frame or matrix", { + expect_error( + ds.mdPattern(x = "D$LAB_TSC"), + "There are some DataSHIELD errors, list them with datashield.errors()", + fixed = TRUE + ) + + res.errors <- DSI::datashield.errors() + for (study.errors in res.errors) { + expect_match(study.errors, "must be of type data.frame or matrix") + } +}) + +test_that("class consistency check aborts when classes differ across studies", { + ds.asDataMatrix(x.name = "D", newobj = "mixed.class", datasources = ds.test_env$connections[1]) + ds.assign(toAssign = "D", newobj = "mixed.class", datasources = ds.test_env$connections[2:3]) + + expect_error(ds.mdPattern(x = "mixed.class"), "not of the same class in all studies") + expect_no_error(ds.mdPattern(x = "mixed.class", classConsistencyCheck = FALSE)) +}) + +# +# Done +# + +# context("ds.mdPattern::smk::shutdown") + +test_that("shutdown", { + ds_expect_variables(c("D", "mixed.class")) +}) + +disconnect.studies.dataset.cnsim() + +# context("ds.mdPattern::smk::done")