From 65d59040e868ce1071bb363b041f745beca5f904 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Sat, 11 Apr 2026 12:43:20 +0200 Subject: [PATCH 01/17] refactor: move checks to serverside --- R/corDS.R | 7 +++++-- R/corTestDS.R | 6 ++++-- R/covDS.R | 7 +++++-- R/kurtosisDS1.R | 5 +++-- R/kurtosisDS2.R | 5 +++-- R/meanDS.R | 7 +++++-- R/meanSdGpDS.R | 17 +++++++++++------ R/quantileMeanDS.R | 17 ++++++++++------- R/skewnessDS1.R | 5 +++-- R/skewnessDS2.R | 5 +++-- R/varDS.R | 7 +++++-- 11 files changed, 57 insertions(+), 31 deletions(-) diff --git a/R/corDS.R b/R/corDS.R index abc73145..0c3a84a0 100644 --- a/R/corDS.R +++ b/R/corDS.R @@ -27,9 +27,12 @@ corDS <- function(x=NULL, y=NULL){ nfilter.glm <- as.numeric(thr$nfilter.glm) ############################################################# - x.val <- eval(parse(text=x), envir = parent.frame()) + x.val <- .loadServersideObject(x) + .checkClass(obj = x.val, obj_name = x, permitted_classes = c("numeric", "integer", "matrix", "data.frame")) + if (!is.null(y)){ - y.val <- eval(parse(text=y), envir = parent.frame()) + y.val <- .loadServersideObject(y) + .checkClass(obj = y.val, obj_name = y, permitted_classes = c("numeric", "integer", "matrix", "data.frame")) } else{ y.val <- NULL diff --git a/R/corTestDS.R b/R/corTestDS.R index ef5aac33..521cbb55 100644 --- a/R/corTestDS.R +++ b/R/corTestDS.R @@ -17,8 +17,10 @@ #' corTestDS <- function(x, y, method, exact, conf.level){ - x.var <- eval(parse(text=x), envir = parent.frame()) - y.var <- eval(parse(text=y), envir = parent.frame()) + x.var <- .loadServersideObject(x) + .checkClass(obj = x.var, obj_name = x, permitted_classes = c("numeric", "integer")) + y.var <- .loadServersideObject(y) + .checkClass(obj = y.var, obj_name = y, permitted_classes = c("numeric", "integer")) # get the number of pairwise complete cases n <- sum(stats::complete.cases(x.var, y.var)) diff --git a/R/covDS.R b/R/covDS.R index 9f645b62..15e43830 100644 --- a/R/covDS.R +++ b/R/covDS.R @@ -36,9 +36,12 @@ covDS <- function(x=NULL, y=NULL, use=NULL){ #nfilter.string <- as.numeric(thr$nfilter.string) ############################################################# - x.val <- eval(parse(text=x), envir = parent.frame()) + x.val <- .loadServersideObject(x) + .checkClass(obj = x.val, obj_name = x, permitted_classes = c("numeric", "integer", "matrix", "data.frame")) + if (!is.null(y)){ - y.val <- eval(parse(text=y), envir = parent.frame()) + y.val <- .loadServersideObject(y) + .checkClass(obj = y.val, obj_name = y, permitted_classes = c("numeric", "integer", "matrix", "data.frame")) } else{ y.val <- NULL diff --git a/R/kurtosisDS1.R b/R/kurtosisDS1.R index 4f3f4e52..435ff6e2 100644 --- a/R/kurtosisDS1.R +++ b/R/kurtosisDS1.R @@ -19,8 +19,9 @@ kurtosisDS1 <- function (x, method){ nfilter.tab <- as.numeric(thr$nfilter.tab) ############################################################# - x <- eval(parse(text=x), envir = parent.frame()) - x <- x[stats::complete.cases(x)] + x.val <- .loadServersideObject(x) + .checkClass(obj = x.val, obj_name = x, permitted_classes = c("numeric", "integer")) + x <- x.val[stats::complete.cases(x.val)] if(length(x) < nfilter.tab){ kurtosis.out <- NA diff --git a/R/kurtosisDS2.R b/R/kurtosisDS2.R index 1d4e3fec..864ca5aa 100644 --- a/R/kurtosisDS2.R +++ b/R/kurtosisDS2.R @@ -23,8 +23,9 @@ kurtosisDS2 <- function(x, global.mean){ nfilter.tab <- as.numeric(thr$nfilter.tab) ############################################################# - x <- eval(parse(text=x), envir = parent.frame()) - x <- x[stats::complete.cases(x)] + x.val <- .loadServersideObject(x) + .checkClass(obj = x.val, obj_name = x, permitted_classes = c("numeric", "integer")) + x <- x.val[stats::complete.cases(x.val)] if(length(x) < nfilter.tab){ sum_quartics.out <- NA diff --git a/R/meanDS.R b/R/meanDS.R index 59d1bc4e..8e4f8998 100644 --- a/R/meanDS.R +++ b/R/meanDS.R @@ -3,12 +3,12 @@ #' @description Calculates the mean value. #' @details if the length of input vector is less than the set filter #' a missing value is returned. -#' @param xvect a vector +#' @param x a character string, the name of a numeric or integer vector #' @return a numeric, the statistical mean #' @author Gaye A, Burton PR #' @export #' -meanDS <- function(xvect){ +meanDS <- function(x){ ############################################################# # MODULE 1: CAPTURE THE nfilter SETTINGS @@ -19,6 +19,9 @@ meanDS <- function(xvect){ #nfilter.string <- as.numeric(thr$nfilter.string) ############################################################# + xvect <- .loadServersideObject(x) + .checkClass(obj = xvect, obj_name = x, permitted_classes = c("numeric", "integer")) + out.mean <- mean(xvect, na.rm=TRUE) out.numNa <- length(which(is.na(xvect))) out.totN <- length(xvect) diff --git a/R/meanSdGpDS.R b/R/meanSdGpDS.R index 41fdb721..2375250e 100644 --- a/R/meanSdGpDS.R +++ b/R/meanSdGpDS.R @@ -3,17 +3,17 @@ #' @description Server-side function called by ds.meanSdGp #' @details Computes the mean and standard deviation across groups defined by one #' factor -#' @param X a client-side supplied character string identifying the variable for which +#' @param x a client-side supplied character string identifying the variable for which #' means/SDs are to be calculated -#' @param INDEX a client-side supplied character string identifying the factor across +#' @param index a client-side supplied character string identifying the factor across #' which means/SDs are to be calculated #' @author Burton PR -#' +#' #' @return List with results from the group statistics #' @export #' -meanSdGpDS <- function (X, INDEX){ - +meanSdGpDS <- function (x, index){ + ############################################################# # MODULE 1: CAPTURE THE nfilter SETTINGS thr <- dsBase::listDisclosureSettingsDS() @@ -23,9 +23,14 @@ meanSdGpDS <- function (X, INDEX){ #nfilter.string <- as.numeric(thr$nfilter.string) ############################################################# + X <- .loadServersideObject(x) + .checkClass(obj = X, obj_name = x, permitted_classes = c("numeric", "integer")) + INDEX <- .loadServersideObject(index) + .checkClass(obj = INDEX, obj_name = index, permitted_classes = c("factor", "character", "integer")) + FUN.mean <- function(x) {mean(x,na.rm=TRUE)} FUN.var <- function(x) {stats::var(x,na.rm=TRUE)} - + #Strip missings from both X and INDEX analysis.matrix<-cbind(X,INDEX) diff --git a/R/quantileMeanDS.R b/R/quantileMeanDS.R index 79fe3a96..199aee81 100644 --- a/R/quantileMeanDS.R +++ b/R/quantileMeanDS.R @@ -2,18 +2,21 @@ #' @title Generates quantiles and mean information without maximum and minimum #' @description the probabilities 5%, 10%, 25%, 50%, 75%, 90%, 95% and the mean #' are used to compute the corresponding quantiles. -#' @param xvect a numerical vector -#' @return a numeric vector that represents the sample quantiles +#' @param x a character string, the name of a numeric or integer vector +#' @return a numeric vector that represents the sample quantiles #' @export #' @author Burton, P.; Gaye, A. -#' -quantileMeanDS <- function (xvect) { - +#' +quantileMeanDS <- function (x) { + + xvect <- .loadServersideObject(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) - + if(check){ - # if the input vector is valid + # if the input vector is valid qq <- stats::quantile(xvect,c(0.05,0.1,0.25,0.5,0.75,0.9,0.95), na.rm=TRUE) mm <- mean(xvect,na.rm=TRUE) quantile.obj <- c(qq, mm) diff --git a/R/skewnessDS1.R b/R/skewnessDS1.R index 19f95dfc..41b5b98e 100644 --- a/R/skewnessDS1.R +++ b/R/skewnessDS1.R @@ -19,8 +19,9 @@ skewnessDS1 <- function(x, method){ nfilter.tab <- as.numeric(thr$nfilter.tab) ############################################################# - x <- eval(parse(text=x), envir = parent.frame()) - x <- x[stats::complete.cases(x)] + x.val <- .loadServersideObject(x) + .checkClass(obj = x.val, obj_name = x, permitted_classes = c("numeric", "integer")) + x <- x.val[stats::complete.cases(x.val)] if(length(x) < nfilter.tab){ skewness.out <- NA diff --git a/R/skewnessDS2.R b/R/skewnessDS2.R index 8d1cb484..3d7224ef 100644 --- a/R/skewnessDS2.R +++ b/R/skewnessDS2.R @@ -23,8 +23,9 @@ skewnessDS2 <- function(x, global.mean){ nfilter.tab <- as.numeric(thr$nfilter.tab) ############################################################# - x <- eval(parse(text=x), envir = parent.frame()) - x <- x[stats::complete.cases(x)] + x.val <- .loadServersideObject(x) + .checkClass(obj = x.val, obj_name = x, permitted_classes = c("numeric", "integer")) + x <- x.val[stats::complete.cases(x.val)] if(length(x) < nfilter.tab){ sum_cubes.out <- NA diff --git a/R/varDS.R b/R/varDS.R index 390a9589..c508ba40 100644 --- a/R/varDS.R +++ b/R/varDS.R @@ -3,7 +3,7 @@ #' @description Calculates the variance. #' @details if the length of input vector is less than the set filter #' a missing value is returned. -#' @param xvect a vector +#' @param x a character string, the name of a numeric or integer vector #' @return a list, with the sum of the input variable, the sum of squares of the input variable, #' the number of missing values, the number of valid values, the number of total length of the #' variable, and a study message indicating whether the number of valid is less than the @@ -11,7 +11,7 @@ #' @author Amadou Gaye, Demetris Avraam, for DataSHIELD Development Team #' @export #' -varDS <- function(xvect){ +varDS <- function(x){ ############################################################# # MODULE 1: CAPTURE THE nfilter SETTINGS @@ -22,6 +22,9 @@ varDS <- function(xvect){ #nfilter.string <- as.numeric(thr$nfilter.string) ############################################################# + xvect <- .loadServersideObject(x) + .checkClass(obj = xvect, obj_name = x, permitted_classes = c("numeric", "integer")) + out.sum <- sum(xvect, na.rm=TRUE) out.sumSquares <- sum(xvect^2, na.rm=TRUE) out.numNa <- length(which(is.na(xvect))) From 073bedc21bf6ddccfddb3916220e938c0ebaf9ca Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Sat, 11 Apr 2026 12:43:28 +0200 Subject: [PATCH 02/17] test: update unit tests --- tests/testthat/test-smk-corDS.R | 10 ++++ tests/testthat/test-smk-corTestDS.R | 10 ++++ tests/testthat/test-smk-covDS.R | 10 ++++ tests/testthat/test-smk-kurtosisDS1.R | 9 ++++ tests/testthat/test-smk-kurtosisDS2.R | 9 ++++ tests/testthat/test-smk-meanDS.R | 15 ++++-- tests/testthat/test-smk-meanSdGpDS.R | 62 ++++++++++++++++++++++++ tests/testthat/test-smk-quantileMeanDS.R | 13 ++++- tests/testthat/test-smk-skewnessDS1.R | 9 ++++ tests/testthat/test-smk-skewnessDS2.R | 9 ++++ tests/testthat/test-smk-varDS.R | 15 ++++-- 11 files changed, 163 insertions(+), 8 deletions(-) create mode 100644 tests/testthat/test-smk-meanSdGpDS.R diff --git a/tests/testthat/test-smk-corDS.R b/tests/testthat/test-smk-corDS.R index bdc3607c..034a4b00 100644 --- a/tests/testthat/test-smk-corDS.R +++ b/tests/testthat/test-smk-corDS.R @@ -718,6 +718,16 @@ test_that("simple corDS, casewise, some", { expect_equal(res$sums.of.squares[4], 58.0) }) +test_that("corDS throws error when object does not exist", { + expect_error(corDS("nonexistent_x", "nonexistent_y"), regexp = "does not exist") +}) + +test_that("corDS throws error when object is of invalid type", { + bad_input <- list(a = 1:3, b = 4:6) + y <- c(1.0, 2.0, 3.0) + expect_error(corDS("bad_input", "y"), regexp = "must be of type") +}) + # # Done # diff --git a/tests/testthat/test-smk-corTestDS.R b/tests/testthat/test-smk-corTestDS.R index b500a085..2dbee274 100644 --- a/tests/testthat/test-smk-corTestDS.R +++ b/tests/testthat/test-smk-corTestDS.R @@ -602,6 +602,16 @@ test_that("simple corTestDS, some, with na, spearman", { expect_equal(res$`Correlation test`$data.name[[1]], "x.var and y.var") }) +test_that("corTestDS throws error when object does not exist", { + expect_error(corTestDS("nonexistent_x", "nonexistent_y", "pearson", NULL, 0.95), regexp = "does not exist") +}) + +test_that("corTestDS throws error when object is not numeric or integer", { + bad_input <- c("a", "b", "c") + y <- c(1.0, 2.0, 3.0) + expect_error(corTestDS("bad_input", "y", "pearson", NULL, 0.95), regexp = "must be of type numeric or integer") +}) + # # Done # diff --git a/tests/testthat/test-smk-covDS.R b/tests/testthat/test-smk-covDS.R index ce731938..64710a72 100644 --- a/tests/testthat/test-smk-covDS.R +++ b/tests/testthat/test-smk-covDS.R @@ -232,6 +232,16 @@ test_that("numeric covDS, pairwise.complete", { expect_true(is.na(res$errorMessage)) }) +test_that("covDS throws error when object does not exist", { + expect_error(covDS("nonexistent_x", "nonexistent_y", "pairwise.complete"), regexp = "does not exist") +}) + +test_that("covDS throws error when object is of invalid type", { + bad_input <- list(a = 1:3, b = 4:6) + y <- c(1.0, 2.0, 3.0) + expect_error(covDS("bad_input", "y", "pairwise.complete"), regexp = "must be of type") +}) + # # Done # diff --git a/tests/testthat/test-smk-kurtosisDS1.R b/tests/testthat/test-smk-kurtosisDS1.R index fe939107..53d9e277 100644 --- a/tests/testthat/test-smk-kurtosisDS1.R +++ b/tests/testthat/test-smk-kurtosisDS1.R @@ -69,6 +69,15 @@ test_that("simple kurtosisDS1, method 3", { expect_equal(res$ValidityMessage, "VALID ANALYSIS") }) +test_that("kurtosisDS1 throws error when object does not exist", { + expect_error(kurtosisDS1("nonexistent_object", 1), regexp = "does not exist") +}) + +test_that("kurtosisDS1 throws error when object is not numeric or integer", { + bad_input <- c("a", "b", "c") + expect_error(kurtosisDS1("bad_input", 1), regexp = "must be of type numeric or integer") +}) + # # Done # diff --git a/tests/testthat/test-smk-kurtosisDS2.R b/tests/testthat/test-smk-kurtosisDS2.R index 8f122a6e..f481b08f 100644 --- a/tests/testthat/test-smk-kurtosisDS2.R +++ b/tests/testthat/test-smk-kurtosisDS2.R @@ -40,6 +40,15 @@ test_that("simple kurtosisDS2", { expect_equal(res$ValidityMessage, "VALID ANALYSIS") }) +test_that("kurtosisDS2 throws error when object does not exist", { + expect_error(kurtosisDS2("nonexistent_object", 2.5), regexp = "does not exist") +}) + +test_that("kurtosisDS2 throws error when object is not numeric or integer", { + bad_input <- c("a", "b", "c") + expect_error(kurtosisDS2("bad_input", 2.5), regexp = "must be of type numeric or integer") +}) + # # Done # diff --git a/tests/testthat/test-smk-meanDS.R b/tests/testthat/test-smk-meanDS.R index e6d81a73..707218f9 100644 --- a/tests/testthat/test-smk-meanDS.R +++ b/tests/testthat/test-smk-meanDS.R @@ -25,7 +25,7 @@ set.standard.disclosure.settings() test_that("numeric meanDS", { input <- c(0.0, 1.0, 2.0, 3.0, 4.0) - res <- meanDS(input) + res <- meanDS("input") expect_length(res, 5) expect_equal(class(res), "list") @@ -45,7 +45,7 @@ test_that("numeric meanDS", { test_that("numeric meanDS, with NA", { input <- c(0.0, NA, 2.0, NA, 4.0) - res <- meanDS(input) + res <- meanDS("input") expect_length(res, 5) expect_equal(class(res), "list") @@ -65,7 +65,7 @@ test_that("numeric meanDS, with NA", { test_that("numeric meanDS, with all NA", { input <- c(NA, NA, NA, NA, NA) - res <- meanDS(input) + res <- meanDS("input") expect_length(res, 5) expect_equal(class(res), "list") @@ -81,6 +81,15 @@ test_that("numeric meanDS, with all NA", { expect_equal(res$ValidityMessage, "VALID ANALYSIS") }) +test_that("meanDS throws error when object does not exist", { + expect_error(meanDS("nonexistent_object"), regexp = "does not exist") +}) + +test_that("meanDS throws error when object is not numeric or integer", { + bad_input <- c("a", "b", "c") + expect_error(meanDS("bad_input"), regexp = "must be of type numeric or integer") +}) + # # Done # diff --git a/tests/testthat/test-smk-meanSdGpDS.R b/tests/testthat/test-smk-meanSdGpDS.R new file mode 100644 index 00000000..44a00ee2 --- /dev/null +++ b/tests/testthat/test-smk-meanSdGpDS.R @@ -0,0 +1,62 @@ +#------------------------------------------------------------------------------- +# 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("meanSdGpDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("meanSdGpDS::smk::numeric by factor") +test_that("simple meanSdGpDS, numeric by factor", { + x_var <- c(1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0, 9.0, 10.0) + index_var <- as.factor(c("A", "A", "A", "A", "A", "B", "B", "B", "B", "B")) + + res <- meanSdGpDS("x_var", "index_var") + + expect_equal(class(res), "list") + expect_true(res$Table_valid) + expect_equal(res$Nvalid, 10) + expect_equal(res$Nmissing, 0) + expect_equal(res$Ntotal, 10) + expect_equal(res$Mean_gp[["A"]], 3.0) + expect_equal(res$Mean_gp[["B"]], 8.0) +}) + +test_that("meanSdGpDS throws error when X does not exist", { + index_var <- as.factor(c("A", "A", "B", "B")) + expect_error(meanSdGpDS("nonexistent_x", "index_var"), regexp = "does not exist") +}) + +test_that("meanSdGpDS throws error when INDEX does not exist", { + x_var <- c(1.0, 2.0, 3.0, 4.0) + expect_error(meanSdGpDS("x_var", "nonexistent_index"), regexp = "does not exist") +}) + +test_that("meanSdGpDS throws error when X is not numeric or integer", { + bad_x <- c("a", "b", "c", "d") + index_var <- as.factor(c("A", "A", "B", "B")) + expect_error(meanSdGpDS("bad_x", "index_var"), regexp = "must be of type numeric or integer") +}) + +# +# Done +# + +# context("meanSdGpDS::smk::shutdown") + +# context("meanSdGpDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-quantileMeanDS.R b/tests/testthat/test-smk-quantileMeanDS.R index 33eb0c6f..f585cea3 100644 --- a/tests/testthat/test-smk-quantileMeanDS.R +++ b/tests/testthat/test-smk-quantileMeanDS.R @@ -23,7 +23,7 @@ test_that("numeric quantileMeanDS", { input <- c(0.0, 1.0, 2.0, 3.0, 4.0) - res <- quantileMeanDS(input) + res <- quantileMeanDS("input") expect_length(res, 8) expect_equal(class(res), "numeric") @@ -54,7 +54,7 @@ test_that("numeric quantileMeanDS", { test_that("numeric quantileMeanDS, with NA", { input <- c(0.0, NA, 2.0, NA, 4.0) - res <- quantileMeanDS(input) + res <- quantileMeanDS("input") expect_length(res, 8) expect_equal(class(res), "numeric") @@ -81,6 +81,15 @@ test_that("numeric quantileMeanDS, with NA", { expect_equal(res.names[[8]], "Mean") }) +test_that("quantileMeanDS throws error when object does not exist", { + expect_error(quantileMeanDS("nonexistent_object"), regexp = "does not exist") +}) + +test_that("quantileMeanDS throws error when object is not numeric or integer", { + bad_input <- c("a", "b", "c") + expect_error(quantileMeanDS("bad_input"), regexp = "must be of type numeric or integer") +}) + # # Done # diff --git a/tests/testthat/test-smk-skewnessDS1.R b/tests/testthat/test-smk-skewnessDS1.R index 562c3f65..48093a37 100644 --- a/tests/testthat/test-smk-skewnessDS1.R +++ b/tests/testthat/test-smk-skewnessDS1.R @@ -69,6 +69,15 @@ test_that("simple skewnessDS1, method 3", { expect_equal(res$ValidityMessage, "VALID ANALYSIS") }) +test_that("skewnessDS1 throws error when object does not exist", { + expect_error(skewnessDS1("nonexistent_object", 1), regexp = "does not exist") +}) + +test_that("skewnessDS1 throws error when object is not numeric or integer", { + bad_input <- c("a", "b", "c") + expect_error(skewnessDS1("bad_input", 1), regexp = "must be of type numeric or integer") +}) + # # Done # diff --git a/tests/testthat/test-smk-skewnessDS2.R b/tests/testthat/test-smk-skewnessDS2.R index 9e59061d..3c32f2e8 100644 --- a/tests/testthat/test-smk-skewnessDS2.R +++ b/tests/testthat/test-smk-skewnessDS2.R @@ -40,6 +40,15 @@ test_that("simple skewnessDS2", { expect_equal(res$ValidityMessage, "VALID ANALYSIS") }) +test_that("skewnessDS2 throws error when object does not exist", { + expect_error(skewnessDS2("nonexistent_object", 2.5), regexp = "does not exist") +}) + +test_that("skewnessDS2 throws error when object is not numeric or integer", { + bad_input <- c("a", "b", "c") + expect_error(skewnessDS2("bad_input", 2.5), regexp = "must be of type numeric or integer") +}) + # # Done # diff --git a/tests/testthat/test-smk-varDS.R b/tests/testthat/test-smk-varDS.R index 517b8d8f..b6049bb1 100644 --- a/tests/testthat/test-smk-varDS.R +++ b/tests/testthat/test-smk-varDS.R @@ -25,7 +25,7 @@ set.standard.disclosure.settings() test_that("numeric varDS", { input <- c(0.0, 1.0, 2.0, 3.0, 4.0) - res <- varDS(input) + res <- varDS("input") expect_length(res, 6) expect_equal(class(res), "list") @@ -47,7 +47,7 @@ test_that("numeric varDS", { test_that("numeric varDS, with NA", { input <- c(0.0, NA, 2.0, NA, 4.0) - res <- varDS(input) + res <- varDS("input") expect_length(res, 6) expect_equal(class(res), "list") @@ -69,7 +69,7 @@ test_that("numeric varDS, with NA", { test_that("numeric varDS, with all NA", { input <- c(NA, NA, NA, NA, NA) - res <- varDS(input) + res <- varDS("input") expect_length(res, 6) expect_equal(class(res), "list") @@ -87,6 +87,15 @@ test_that("numeric varDS, with all NA", { expect_equal(res$ValidityMessage, "VALID ANALYSIS") }) +test_that("varDS throws error when object does not exist", { + expect_error(varDS("nonexistent_object"), regexp = "does not exist") +}) + +test_that("varDS throws error when object is not numeric or integer", { + bad_input <- c("a", "b", "c") + expect_error(varDS("bad_input"), regexp = "must be of type numeric or integer") +}) + # # Done # From 7870e5b2d8b9630ef608bd5b0aec544134e3930f Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Sat, 11 Apr 2026 13:20:57 +0200 Subject: [PATCH 03/17] fixed unit tests --- tests/testthat/test-disc-meanDS.R | 2 +- tests/testthat/test-disc-varDS.R | 2 +- tests/testthat/test-perf-meanDS.R | 4 ++-- tests/testthat/test-perf-varDS.R | 4 ++-- tests/testthat/test-smk-meanDS.R | 4 ++-- tests/testthat/test-smk-meanSdGpDS.R | 4 ++-- tests/testthat/test-smk-varDS.R | 8 ++++---- 7 files changed, 14 insertions(+), 14 deletions(-) diff --git a/tests/testthat/test-disc-meanDS.R b/tests/testthat/test-disc-meanDS.R index 22864733..41e3d9f9 100644 --- a/tests/testthat/test-disc-meanDS.R +++ b/tests/testthat/test-disc-meanDS.R @@ -25,7 +25,7 @@ set.standard.disclosure.settings() test_that("numeric meanDS, with below nfilter.tab values", { input <- c(NA, NA, 2.0, NA, 4.0) - expect_error(meanDS(input), "FAILED: Nvalid less than nfilter.tab", fixed = TRUE) + expect_error(meanDS("input"), "FAILED: Nvalid less than nfilter.tab", fixed = TRUE) }) # diff --git a/tests/testthat/test-disc-varDS.R b/tests/testthat/test-disc-varDS.R index 3b60a771..28c8983d 100644 --- a/tests/testthat/test-disc-varDS.R +++ b/tests/testthat/test-disc-varDS.R @@ -25,7 +25,7 @@ set.standard.disclosure.settings() test_that("numeric varDS, with below nfilter.tab values", { input <- c(NA, NA, 2.0, NA, 4.0) - expect_error(varDS(input), "FAILED: Nvalid less than nfilter.tab", fixed = TRUE) + expect_error(varDS("input"), "FAILED: Nvalid less than nfilter.tab", fixed = TRUE) }) # diff --git a/tests/testthat/test-perf-meanDS.R b/tests/testthat/test-perf-meanDS.R index 59266cb2..648ff3d3 100644 --- a/tests/testthat/test-perf-meanDS.R +++ b/tests/testthat/test-perf-meanDS.R @@ -36,7 +36,7 @@ test_that("numeric meanDS - performance", { .current.time <- .start.time while (difftime(.current.time, .start.time, units = "secs")[[1]] < .durationSec) { - meanDS(input) + meanDS("input") .count <- .count + 1 .current.time <- Sys.time() @@ -71,7 +71,7 @@ test_that("numeric meanDS, with NA - performance", { .current.time <- .start.time while (difftime(.current.time, .start.time, units = "secs")[[1]] < .durationSec) { - meanDS(input) + meanDS("input") .count <- .count + 1 .current.time <- Sys.time() diff --git a/tests/testthat/test-perf-varDS.R b/tests/testthat/test-perf-varDS.R index 10fff94a..7abe84f6 100644 --- a/tests/testthat/test-perf-varDS.R +++ b/tests/testthat/test-perf-varDS.R @@ -36,7 +36,7 @@ test_that("numeric varDS - performance", { .current.time <- .start.time while (difftime(.current.time, .start.time, units = "secs")[[1]] < .durationSec) { - varDS(input) + varDS("input") .count <- .count + 1 .current.time <- Sys.time() @@ -71,7 +71,7 @@ test_that("numeric varDS, with NA - performance", { .current.time <- .start.time while (difftime(.current.time, .start.time, units = "secs")[[1]] < .durationSec) { - varDS(input) + varDS("input") .count <- .count + 1 .current.time <- Sys.time() diff --git a/tests/testthat/test-smk-meanDS.R b/tests/testthat/test-smk-meanDS.R index 707218f9..4a11f514 100644 --- a/tests/testthat/test-smk-meanDS.R +++ b/tests/testthat/test-smk-meanDS.R @@ -63,8 +63,8 @@ test_that("numeric meanDS, with NA", { # context("meanDS::smk::numeric with all NA") test_that("numeric meanDS, with all NA", { - input <- c(NA, NA, NA, NA, NA) - + input <- rep(NA_real_, 5) + res <- meanDS("input") expect_length(res, 5) diff --git a/tests/testthat/test-smk-meanSdGpDS.R b/tests/testthat/test-smk-meanSdGpDS.R index 44a00ee2..de3d4ecb 100644 --- a/tests/testthat/test-smk-meanSdGpDS.R +++ b/tests/testthat/test-smk-meanSdGpDS.R @@ -33,8 +33,8 @@ test_that("simple meanSdGpDS, numeric by factor", { expect_equal(res$Nvalid, 10) expect_equal(res$Nmissing, 0) expect_equal(res$Ntotal, 10) - expect_equal(res$Mean_gp[["A"]], 3.0) - expect_equal(res$Mean_gp[["B"]], 8.0) + expect_equal(as.numeric(res$Mean_gp)[1], 3.0) + expect_equal(as.numeric(res$Mean_gp)[2], 8.0) }) test_that("meanSdGpDS throws error when X does not exist", { diff --git a/tests/testthat/test-smk-varDS.R b/tests/testthat/test-smk-varDS.R index b6049bb1..bfe5ce2e 100644 --- a/tests/testthat/test-smk-varDS.R +++ b/tests/testthat/test-smk-varDS.R @@ -67,13 +67,13 @@ test_that("numeric varDS, with NA", { # context("varDS::smk::numeric with all NA") test_that("numeric varDS, with all NA", { - input <- c(NA, NA, NA, NA, NA) - + input <- rep(NA_real_, 5) + res <- varDS("input") - + expect_length(res, 6) expect_equal(class(res), "list") - expect_equal(class(res$Sum), "integer") + expect_equal(class(res$Sum), "numeric") expect_equal(res$Sum, 0) expect_equal(class(res$SumOfSquares), "numeric") expect_equal(res$SumOfSquares, 0) From 3c9432e9d20fc80ed3e8eb7213aabddd7572e952 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Sat, 11 Apr 2026 13:21:09 +0200 Subject: [PATCH 04/17] updated authorship --- R/corDS.R | 1 + R/corTestDS.R | 1 + R/covDS.R | 1 + R/kurtosisDS1.R | 1 + R/kurtosisDS2.R | 1 + R/meanDS.R | 1 + R/meanSdGpDS.R | 1 + R/quantileMeanDS.R | 1 + R/skewnessDS1.R | 1 + R/skewnessDS2.R | 1 + R/varDS.R | 1 + man/corDS.Rd | 2 ++ man/corTestDS.Rd | 2 ++ man/covDS.Rd | 2 ++ man/kurtosisDS1.Rd | 2 ++ man/kurtosisDS2.Rd | 2 ++ man/meanDS.Rd | 6 ++++-- man/meanSdGpDS.Rd | 8 +++++--- man/quantileMeanDS.Rd | 6 ++++-- man/skewnessDS1.Rd | 2 ++ man/skewnessDS2.Rd | 2 ++ man/varDS.Rd | 6 ++++-- 22 files changed, 42 insertions(+), 9 deletions(-) diff --git a/R/corDS.R b/R/corDS.R index 0c3a84a0..dc5a3986 100644 --- a/R/corDS.R +++ b/R/corDS.R @@ -16,6 +16,7 @@ #' by the 'nfilter.glm'). The second disclosure control checks that none of them is dichotomous with a #' level having fewer counts than the pre-specified 'nfilter.tab' threshold. #' @author Paul Burton, and Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' corDS <- function(x=NULL, y=NULL){ diff --git a/R/corTestDS.R b/R/corTestDS.R index 521cbb55..0b533e5d 100644 --- a/R/corTestDS.R +++ b/R/corTestDS.R @@ -13,6 +13,7 @@ #' 4 complete pairs of observations. #' @return the results of the correlation test. #' @author Demetris Avraam, for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' corTestDS <- function(x, y, method, exact, conf.level){ diff --git a/R/covDS.R b/R/covDS.R index 15e43830..90207905 100644 --- a/R/covDS.R +++ b/R/covDS.R @@ -23,6 +23,7 @@ #' counts than the pre-specified 'nfilter.tab' threshold. If any of the input variables do not pass the disclosure #' controls then all the output values are replaced with NAs. #' @author Amadou Gaye, Paul Burton, and Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' covDS <- function(x=NULL, y=NULL, use=NULL){ diff --git a/R/kurtosisDS1.R b/R/kurtosisDS1.R index 435ff6e2..d3419f65 100644 --- a/R/kurtosisDS1.R +++ b/R/kurtosisDS1.R @@ -9,6 +9,7 @@ #' @return a list including the kurtosis of the input numeric variable, the number of valid observations and #' the study-side validity message. #' @author Demetris Avraam, for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' kurtosisDS1 <- function (x, method){ diff --git a/R/kurtosisDS2.R b/R/kurtosisDS2.R index 864ca5aa..791e4f52 100644 --- a/R/kurtosisDS2.R +++ b/R/kurtosisDS2.R @@ -13,6 +13,7 @@ #' indicating indicating a valid analysis if the number of valid observations are above the protection filter #' nfilter.tab or invalid analysis otherwise. #' @author Demetris Avraam, for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' kurtosisDS2 <- function(x, global.mean){ diff --git a/R/meanDS.R b/R/meanDS.R index 8e4f8998..1cfc60a2 100644 --- a/R/meanDS.R +++ b/R/meanDS.R @@ -6,6 +6,7 @@ #' @param x a character string, the name of a numeric or integer vector #' @return a numeric, the statistical mean #' @author Gaye A, Burton PR +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' meanDS <- function(x){ diff --git a/R/meanSdGpDS.R b/R/meanSdGpDS.R index 2375250e..9d9ca432 100644 --- a/R/meanSdGpDS.R +++ b/R/meanSdGpDS.R @@ -8,6 +8,7 @@ #' @param index a client-side supplied character string identifying the factor across #' which means/SDs are to be calculated #' @author Burton PR +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' #' @return List with results from the group statistics #' @export diff --git a/R/quantileMeanDS.R b/R/quantileMeanDS.R index 199aee81..f94e430b 100644 --- a/R/quantileMeanDS.R +++ b/R/quantileMeanDS.R @@ -6,6 +6,7 @@ #' @return a numeric vector that represents the sample quantiles #' @export #' @author Burton, P.; Gaye, A. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' quantileMeanDS <- function (x) { diff --git a/R/skewnessDS1.R b/R/skewnessDS1.R index 41b5b98e..a52819df 100644 --- a/R/skewnessDS1.R +++ b/R/skewnessDS1.R @@ -9,6 +9,7 @@ #' @return a list including the skewness of the input numeric variable, the number of valid observations and #' the study-side validity message. #' @author Demetris Avraam, for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' skewnessDS1 <- function(x, method){ diff --git a/R/skewnessDS2.R b/R/skewnessDS2.R index 3d7224ef..d73f1791 100644 --- a/R/skewnessDS2.R +++ b/R/skewnessDS2.R @@ -13,6 +13,7 @@ #' indicating indicating a valid analysis if the number of valid observations are above the protection filter #' nfilter.tab or invalid analysis otherwise. #' @author Demetris Avraam, for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' skewnessDS2 <- function(x, global.mean){ diff --git a/R/varDS.R b/R/varDS.R index c508ba40..0e0475b4 100644 --- a/R/varDS.R +++ b/R/varDS.R @@ -9,6 +9,7 @@ #' variable, and a study message indicating whether the number of valid is less than the #' disclosure threshold #' @author Amadou Gaye, Demetris Avraam, for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' varDS <- function(x){ diff --git a/man/corDS.Rd b/man/corDS.Rd index 91e0a36d..b3b37363 100644 --- a/man/corDS.Rd +++ b/man/corDS.Rd @@ -32,4 +32,6 @@ variables } \author{ Paul Burton, and Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/corTestDS.Rd b/man/corTestDS.Rd index 83c8ecc0..28e7ab01 100644 --- a/man/corTestDS.Rd +++ b/man/corTestDS.Rd @@ -32,4 +32,6 @@ The function runs a two-sided correlation test } \author{ Demetris Avraam, for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/covDS.Rd b/man/covDS.Rd index 25b7d527..9600ce75 100644 --- a/man/covDS.Rd +++ b/man/covDS.Rd @@ -40,4 +40,6 @@ variables } \author{ Amadou Gaye, Paul Burton, and Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/kurtosisDS1.Rd b/man/kurtosisDS1.Rd index a6029a3d..34098514 100644 --- a/man/kurtosisDS1.Rd +++ b/man/kurtosisDS1.Rd @@ -25,4 +25,6 @@ The method is specified by the argument \code{method} in the client-side \code{d } \author{ Demetris Avraam, for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/kurtosisDS2.Rd b/man/kurtosisDS2.Rd index a61f16c4..9a6e1327 100644 --- a/man/kurtosisDS2.Rd +++ b/man/kurtosisDS2.Rd @@ -29,4 +29,6 @@ of x across all studies and the number of valid observations of the input variab } \author{ Demetris Avraam, for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/meanDS.Rd b/man/meanDS.Rd index 6802ad58..251d025b 100644 --- a/man/meanDS.Rd +++ b/man/meanDS.Rd @@ -4,10 +4,10 @@ \alias{meanDS} \title{Computes statistical mean of a vector} \usage{ -meanDS(xvect) +meanDS(x) } \arguments{ -\item{xvect}{a vector} +\item{x}{a character string, the name of a numeric or integer vector} } \value{ a numeric, the statistical mean @@ -21,4 +21,6 @@ a missing value is returned. } \author{ Gaye A, Burton PR + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/meanSdGpDS.Rd b/man/meanSdGpDS.Rd index 0b7cc1d5..031fdb14 100644 --- a/man/meanSdGpDS.Rd +++ b/man/meanSdGpDS.Rd @@ -4,13 +4,13 @@ \alias{meanSdGpDS} \title{MeanSdGpDS} \usage{ -meanSdGpDS(X, INDEX) +meanSdGpDS(x, index) } \arguments{ -\item{X}{a client-side supplied character string identifying the variable for which +\item{x}{a client-side supplied character string identifying the variable for which means/SDs are to be calculated} -\item{INDEX}{a client-side supplied character string identifying the factor across +\item{index}{a client-side supplied character string identifying the factor across which means/SDs are to be calculated} } \value{ @@ -25,4 +25,6 @@ factor } \author{ Burton PR + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/quantileMeanDS.Rd b/man/quantileMeanDS.Rd index 5781685d..1f453984 100644 --- a/man/quantileMeanDS.Rd +++ b/man/quantileMeanDS.Rd @@ -4,10 +4,10 @@ \alias{quantileMeanDS} \title{Generates quantiles and mean information without maximum and minimum} \usage{ -quantileMeanDS(xvect) +quantileMeanDS(x) } \arguments{ -\item{xvect}{a numerical vector} +\item{x}{a character string, the name of a numeric or integer vector} } \value{ a numeric vector that represents the sample quantiles @@ -18,4 +18,6 @@ are used to compute the corresponding quantiles. } \author{ Burton, P.; Gaye, A. + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/skewnessDS1.Rd b/man/skewnessDS1.Rd index 76f48fc0..fe2921d7 100644 --- a/man/skewnessDS1.Rd +++ b/man/skewnessDS1.Rd @@ -25,4 +25,6 @@ The method is specified by the argument \code{method} in the client-side \code{d } \author{ Demetris Avraam, for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/skewnessDS2.Rd b/man/skewnessDS2.Rd index 4537f001..12646548 100644 --- a/man/skewnessDS2.Rd +++ b/man/skewnessDS2.Rd @@ -29,4 +29,6 @@ of x across all studies and the number of valid observations of the input variab } \author{ Demetris Avraam, for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/varDS.Rd b/man/varDS.Rd index 1c485c9b..78c9b05c 100644 --- a/man/varDS.Rd +++ b/man/varDS.Rd @@ -4,10 +4,10 @@ \alias{varDS} \title{Computes the variance of vector} \usage{ -varDS(xvect) +varDS(x) } \arguments{ -\item{xvect}{a vector} +\item{x}{a character string, the name of a numeric or integer vector} } \value{ a list, with the sum of the input variable, the sum of squares of the input variable, @@ -24,4 +24,6 @@ a missing value is returned. } \author{ Amadou Gaye, Demetris Avraam, for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } From 8c44d302457d17175b4f92f1521f87f39a3d79a5 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 13 Apr 2026 12:50:17 +0200 Subject: [PATCH 05/17] refactor: return class for consistency checking, remove ValidityMessage --- R/corTestDS.R | 6 +++--- R/kurtosisDS1.R | 7 ++----- R/kurtosisDS2.R | 15 ++++++--------- R/quantileMeanDS.R | 6 +++--- R/skewnessDS1.R | 5 +---- R/skewnessDS2.R | 16 ++++++---------- 6 files changed, 21 insertions(+), 34 deletions(-) diff --git a/R/corTestDS.R b/R/corTestDS.R index 0b533e5d..547484c8 100644 --- a/R/corTestDS.R +++ b/R/corTestDS.R @@ -29,9 +29,9 @@ corTestDS <- function(x, y, method, exact, conf.level){ # runs a two-sided correlation test corTest <- stats::cor.test(x=x.var, y=y.var, method=method, exact=exact, conf.level=conf.level) - out <- list(n, corTest) - names(out) <- c("Number of pairwise complete cases", "Correlation test") - + out <- list(n, corTest, class = class(x.var)) + names(out)[1:2] <- c("Number of pairwise complete cases", "Correlation test") + # return the results return(out) diff --git a/R/kurtosisDS1.R b/R/kurtosisDS1.R index d3419f65..9789ae68 100644 --- a/R/kurtosisDS1.R +++ b/R/kurtosisDS1.R @@ -34,19 +34,16 @@ kurtosisDS1 <- function (x, method){ if(method==1){ kurtosis.out <- g2 - studysideMessage <- "VALID ANALYSIS" } if(method==2){ kurtosis.out <- ((length(x) + 1) * g2 + 6) * (length(x) - 1)/((length(x) - 2) * (length(x) - 3)) - studysideMessage <- "VALID ANALYSIS" } if(method==3){ kurtosis.out <- (g2 + 3) * (1 - 1/length(x))^2 - 3 - studysideMessage <- "VALID ANALYSIS" } } - - out.obj <- list(Kurtosis=kurtosis.out, Nvalid=length(x), ValidityMessage=studysideMessage) + + out.obj <- list(Kurtosis=kurtosis.out, Nvalid=length(x), class=class(x.val)) return(out.obj) } diff --git a/R/kurtosisDS2.R b/R/kurtosisDS2.R index 791e4f52..392641ed 100644 --- a/R/kurtosisDS2.R +++ b/R/kurtosisDS2.R @@ -29,16 +29,13 @@ kurtosisDS2 <- function(x, global.mean){ x <- x.val[stats::complete.cases(x.val)] if(length(x) < nfilter.tab){ - sum_quartics.out <- NA - sum_squares.out <- NA - studysideMessage <- "FAILED: Nvalid less than nfilter.tab" - }else{ - sum_quartics.out <- sum((x - global.mean)^4) - sum_squares.out <- sum((x - global.mean)^2) - studysideMessage <- "VALID ANALYSIS" + stop("FAILED: Nvalid less than nfilter.tab", call. = FALSE) } - - out.obj <- list(Sum.quartics=sum_quartics.out, Sum.squares=sum_squares.out, Nvalid=length(x), ValidityMessage=studysideMessage) + + sum_quartics.out <- sum((x - global.mean)^4) + sum_squares.out <- sum((x - global.mean)^2) + + out.obj <- list(Sum.quartics=sum_quartics.out, Sum.squares=sum_squares.out, Nvalid=length(x), class=class(x.val)) return(out.obj) } diff --git a/R/quantileMeanDS.R b/R/quantileMeanDS.R index f94e430b..26772caf 100644 --- a/R/quantileMeanDS.R +++ b/R/quantileMeanDS.R @@ -21,10 +21,10 @@ quantileMeanDS <- function (x) { qq <- stats::quantile(xvect,c(0.05,0.1,0.25,0.5,0.75,0.9,0.95), na.rm=TRUE) mm <- mean(xvect,na.rm=TRUE) quantile.obj <- c(qq, mm) - names(quantile.obj) <- c("5%","10%","25%","50%","75%","90%","95%","Mean") + names(quantile.obj) <- c("5%","10%","25%","50%","75%","90%","95%","Mean") }else{ quantile.obj <- NA } - - return(quantile.obj) + + return(list(quantiles = quantile.obj, class = class(xvect))) } diff --git a/R/skewnessDS1.R b/R/skewnessDS1.R index a52819df..59e13745 100644 --- a/R/skewnessDS1.R +++ b/R/skewnessDS1.R @@ -34,19 +34,16 @@ skewnessDS1 <- function(x, method){ if(method==1){ skewness.out <- g1 - studysideMessage <- "VALID ANALYSIS" } if(method==2){ skewness.out <- g1 * sqrt(length(x)*(length(x)-1))/(length(x)-2) - studysideMessage <- "VALID ANALYSIS" } if(method==3){ skewness.out <- g1 * ((length(x)-1)/(length(x)))^(3/2) - studysideMessage <- "VALID ANALYSIS" } } - out.obj <- list(Skewness=skewness.out, Nvalid=length(x), ValidityMessage=studysideMessage) + out.obj <- list(Skewness=skewness.out, Nvalid=length(x), class=class(x.val)) return(out.obj) } diff --git a/R/skewnessDS2.R b/R/skewnessDS2.R index d73f1791..dc58ae6c 100644 --- a/R/skewnessDS2.R +++ b/R/skewnessDS2.R @@ -29,17 +29,13 @@ skewnessDS2 <- function(x, global.mean){ x <- x.val[stats::complete.cases(x.val)] if(length(x) < nfilter.tab){ - sum_cubes.out <- NA - sum_squares.out <- NA - studysideMessage <- "FAILED: Nvalid less than nfilter.tab" - stop(studysideMessage, call. = FALSE) - }else{ - sum_cubes.out <- sum((x - global.mean)^3) - sum_squares.out <- sum((x - global.mean)^2) - studysideMessage <- "VALID ANALYSIS" + stop("FAILED: Nvalid less than nfilter.tab", call. = FALSE) } - - out.obj <- list(Sum.cubes=sum_cubes.out, Sum.squares=sum_squares.out, Nvalid=length(x), ValidityMessage=studysideMessage) + + sum_cubes.out <- sum((x - global.mean)^3) + sum_squares.out <- sum((x - global.mean)^2) + + out.obj <- list(Sum.cubes=sum_cubes.out, Sum.squares=sum_squares.out, Nvalid=length(x), class=class(x.val)) return(out.obj) } From cabc097f99f41d2ff1d19df18bc278febb686adf Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 13 Apr 2026 12:50:28 +0200 Subject: [PATCH 06/17] chore: set privacy level to permissive, fix expDS authorship --- R/expDS.R | 2 +- inst/DATASHIELD | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/expDS.R b/R/expDS.R index 3c6b53c3..2ba9e5bb 100644 --- a/R/expDS.R +++ b/R/expDS.R @@ -15,7 +15,7 @@ expDS <- function(x) { x.var <- .loadServersideObject(x) .checkClass(obj = x.var, obj_name = x, permitted_classes = c("numeric", "integer")) - out <- exp(x.var) +out <- exp(x.var) return(out) } # ASSIGN FUNCTION diff --git a/inst/DATASHIELD b/inst/DATASHIELD index 8753f19d..abcabf73 100644 --- a/inst/DATASHIELD +++ b/inst/DATASHIELD @@ -163,7 +163,7 @@ AssignMethods: unlist=base::unlist Options: datashield.privacyLevel=5, - default.datashield.privacyControlLevel="banana", + default.datashield.privacyControlLevel="permissive", default.nfilter.glm=0.33, default.nfilter.kNN=3, default.nfilter.string=80, From f8fffa2d2db34e1556d14d708143078e7d336c88 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 13 Apr 2026 14:10:08 +0200 Subject: [PATCH 07/17] refactor: return class for consistency checking, remove ValidityMessage --- R/meanDS.R | 5 +---- R/meanSdGpDS.R | 10 ++++++---- R/varDS.R | 9 ++------- 3 files changed, 9 insertions(+), 15 deletions(-) diff --git a/R/meanDS.R b/R/meanDS.R index 1cfc60a2..4fc3269c 100644 --- a/R/meanDS.R +++ b/R/meanDS.R @@ -27,14 +27,11 @@ meanDS <- function(x){ out.numNa <- length(which(is.na(xvect))) out.totN <- length(xvect) out.validN <- out.totN-out.numNa - studysideMessage <- "VALID ANALYSIS" - if((out.validN != 0) && (out.validN < nfilter.tab)){ - out.mean <- NA stop("FAILED: Nvalid less than nfilter.tab", call. = FALSE) } - out.obj <- list(EstimatedMean=out.mean,Nmissing=out.numNa,Nvalid=out.validN,Ntotal=out.totN,ValidityMessage=studysideMessage) + out.obj <- list(EstimatedMean=out.mean,Nmissing=out.numNa,Nvalid=out.validN,Ntotal=out.totN,class=class(xvect)) return(out.obj) } diff --git a/R/meanSdGpDS.R b/R/meanSdGpDS.R index 9d9ca432..eecf0dde 100644 --- a/R/meanSdGpDS.R +++ b/R/meanSdGpDS.R @@ -28,6 +28,8 @@ meanSdGpDS <- function (x, index){ .checkClass(obj = X, obj_name = x, permitted_classes = c("numeric", "integer")) INDEX <- .loadServersideObject(index) .checkClass(obj = INDEX, obj_name = index, permitted_classes = c("factor", "character", "integer")) + x.class <- class(X) + index.class <- class(INDEX) FUN.mean <- function(x) {mean(x,na.rm=TRUE)} FUN.var <- function(x) {stats::var(x,na.rm=TRUE)} @@ -120,8 +122,8 @@ meanSdGpDS <- function (x, index){ { table.valid<-TRUE cell.count.warning<-paste0("All tables valid") - result<-list(table.valid,ansmat.mean,ansmat.sd,ansmat.count,Nvalid,Nmissing,Ntotal,cell.count.warning) - names(result)<-list("Table_valid","Mean_gp","StDev_gp", "N_gp","Nvalid","Nmissing","Ntotal","Message") + result<-list(table.valid,ansmat.mean,ansmat.sd,ansmat.count,Nvalid,Nmissing,Ntotal,cell.count.warning,x.class,index.class) + names(result)<-list("Table_valid","Mean_gp","StDev_gp", "N_gp","Nvalid","Nmissing","Ntotal","Message","class.x","class.index") return(result) } @@ -129,8 +131,8 @@ meanSdGpDS <- function (x, index){ { table.valid<-FALSE cell.count.warning<-paste0("At least one group has between 1 and ", nfilter.tab-1, " observations. Please change groups") - result<-list(table.valid,Nvalid,Nmissing,Ntotal,cell.count.warning) - names(result)<-list("Table_valid","Nvalid","Nmissing","Ntotal","Warning") + result<-list(table.valid,Nvalid,Nmissing,Ntotal,cell.count.warning,x.class,index.class) + names(result)<-list("Table_valid","Nvalid","Nmissing","Ntotal","Warning","class.x","class.index") return(result) } diff --git a/R/varDS.R b/R/varDS.R index 0e0475b4..75a21c17 100644 --- a/R/varDS.R +++ b/R/varDS.R @@ -31,16 +31,11 @@ varDS <- function(x){ out.numNa <- length(which(is.na(xvect))) out.totN <- length(xvect) out.validN <- out.totN-out.numNa - studysideMessage <- "VALID ANALYSIS" - if((out.validN != 0) && (out.validN < nfilter.tab)){ - out.sum <- NA - out.sumSquares <- NA - studysideMessage <- "FAILED: Nvalid less than nfilter.tab" - stop(studysideMessage, call. = FALSE) + stop("FAILED: Nvalid less than nfilter.tab", call. = FALSE) } - out.obj <- list(Sum=out.sum,SumOfSquares=out.sumSquares,Nmissing=out.numNa,Nvalid=out.validN,Ntotal=out.totN,ValidityMessage=studysideMessage) + out.obj <- list(Sum=out.sum,SumOfSquares=out.sumSquares,Nmissing=out.numNa,Nvalid=out.validN,Ntotal=out.totN,class=class(xvect)) return(out.obj) } From e81a81b3a34634f1360e51ea5c4b83a14960fe7d Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 13 Apr 2026 14:58:01 +0200 Subject: [PATCH 08/17] fix: return class from corDS and covDS for consistency checking --- R/corDS.R | 2 +- R/covDS.R | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/corDS.R b/R/corDS.R index dc5a3986..fde5ad3d 100644 --- a/R/corDS.R +++ b/R/corDS.R @@ -169,7 +169,7 @@ corDS <- function(x=NULL, y=NULL){ } - return(list(sums.of.products=sums.of.products, sums=sums, complete.counts=complete.counts, na.counts=na.counts, sums.of.squares=sums.of.squares)) + return(list(sums.of.products=sums.of.products, sums=sums, complete.counts=complete.counts, na.counts=na.counts, sums.of.squares=sums.of.squares, class=class(x.val))) } # AGGREGATE FUNCTION diff --git a/R/covDS.R b/R/covDS.R index 90207905..b15b4a5a 100644 --- a/R/covDS.R +++ b/R/covDS.R @@ -302,7 +302,7 @@ covDS <- function(x=NULL, y=NULL, use=NULL){ } - return(list(sums.of.products=sums.of.products, sums=sums, complete.counts=complete.counts, na.counts=na.counts, errorMessage=errorMessage)) + return(list(sums.of.products=sums.of.products, sums=sums, complete.counts=complete.counts, na.counts=na.counts, errorMessage=errorMessage, class=class(x.val))) } # AGGREGATE FUNCTION From 05f68e6aeeac06487d73d073faf4da4d490dd646 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Tue, 14 Apr 2026 14:18:33 +0200 Subject: [PATCH 09/17] test: fixed test expectations --- tests/testthat/test-smk-cDS.R | 16 +++---- tests/testthat/test-smk-corDS.R | 8 ++-- tests/testthat/test-smk-corTestDS.R | 24 +++++----- tests/testthat/test-smk-covDS.R | 4 +- tests/testthat/test-smk-kurtosisDS1.R | 9 ++-- tests/testthat/test-smk-kurtosisDS2.R | 3 +- tests/testthat/test-smk-listDS.R | 5 +- tests/testthat/test-smk-meanDS.R | 9 ++-- tests/testthat/test-smk-quantileMeanDS.R | 58 ++++++++++++++---------- tests/testthat/test-smk-skewnessDS1.R | 9 ++-- tests/testthat/test-smk-skewnessDS2.R | 3 +- tests/testthat/test-smk-varDS.R | 9 ++-- 12 files changed, 76 insertions(+), 81 deletions(-) diff --git a/tests/testthat/test-smk-cDS.R b/tests/testthat/test-smk-cDS.R index 0f9842fc..518d9ac5 100644 --- a/tests/testthat/test-smk-cDS.R +++ b/tests/testthat/test-smk-cDS.R @@ -23,9 +23,9 @@ set.standard.disclosure.settings() # context("cDS::smk::numeric list") test_that("numeric list cDS", { - input <- list(a=0.0, b=1.0, c=2.0, d=3.0) + a <- 0.0; b <- 1.0; c <- 2.0; d <- 3.0 - res <- cDS(input) + res <- cDS(c("a", "b", "c", "d")) expect_length(res, 4) expect_equal(class(res), "numeric") @@ -37,9 +37,9 @@ test_that("numeric list cDS", { # context("cDS::smk::character list") test_that("character list cDS", { - input <- list(a="0.0", b="1.0", c="2.0", d="3.0") + a <- "0.0"; b <- "1.0"; c <- "2.0"; d <- "3.0" - res <- cDS(input) + res <- cDS(c("a", "b", "c", "d")) expect_length(res, 4) expect_equal(class(res), "character") @@ -51,9 +51,9 @@ test_that("character list cDS", { # context("cDS::smk::numeric list small") test_that("single numeric list small cDS", { - input <- list(a=0, b=1) + a <- 0; b <- 1 - res <- cDS(input) + res <- cDS(c("a", "b")) expect_length(res, 2) expect_equal(class(res), "logical") @@ -63,9 +63,7 @@ test_that("single numeric list small cDS", { # context("cDS::smk::empty list") test_that("empty list cDS", { - input <- list() - - res <- cDS(input) + res <- cDS(character(0)) expect_length(res, 0) expect_equal(class(res), "NULL") diff --git a/tests/testthat/test-smk-corDS.R b/tests/testthat/test-smk-corDS.R index 034a4b00..e86b6e2c 100644 --- a/tests/testthat/test-smk-corDS.R +++ b/tests/testthat/test-smk-corDS.R @@ -378,7 +378,7 @@ test_that("simple corDS, casewise, full", { res <- corDS("x", "y") expect_equal(class(res), "list") - expect_length(res, 5) + expect_length(res, 6) if (base::getRversion() < '4.0.0') { @@ -465,7 +465,7 @@ test_that("simple corDS, casewise, neg. full", { res <- corDS("x", "y") expect_equal(class(res), "list") - expect_length(res, 5) + expect_length(res, 6) if (base::getRversion() < '4.0.0') { @@ -552,7 +552,7 @@ test_that("simple corDS, casewise, some", { res <- corDS("x", "y") expect_equal(class(res), "list") - expect_length(res, 5) + expect_length(res, 6) if (base::getRversion() < '4.0.0') { @@ -640,7 +640,7 @@ test_that("simple corDS, casewise, some", { res <- corDS("x", "y") expect_equal(class(res), "list") - expect_length(res, 5) + expect_length(res, 6) if (base::getRversion() < '4.0.0') { diff --git a/tests/testthat/test-smk-corTestDS.R b/tests/testthat/test-smk-corTestDS.R index 2dbee274..cb54b62f 100644 --- a/tests/testthat/test-smk-corTestDS.R +++ b/tests/testthat/test-smk-corTestDS.R @@ -29,7 +29,7 @@ test_that("simple corTestDS, full, without na, pearson", { res <- corTestDS("x", "y", "pearson", NULL, 0.95) expect_equal(class(res), "list") - expect_length(res, 2) + expect_length(res, 3) expect_length(res$`Number of pairwise complete cases`, 1) expect_equal(res$`Number of pairwise complete cases`, 8) @@ -82,7 +82,7 @@ test_that("simple corTestDS, neg. full, without na, pearson", { res <- corTestDS("x", "y", "pearson", NULL, 0.95) expect_equal(class(res), "list") - expect_length(res, 2) + expect_length(res, 3) expect_length(res$`Number of pairwise complete cases`, 1) expect_equal(res$`Number of pairwise complete cases`, 8) @@ -135,7 +135,7 @@ test_that("simple corTestDS, some, pearson, without na, pearson", { res <- corTestDS("x", "y", "pearson", NULL, 0.95) expect_equal(class(res), "list") - expect_length(res, 2) + expect_length(res, 3) expect_length(res$`Number of pairwise complete cases`, 1) expect_equal(res$`Number of pairwise complete cases`, 8) @@ -189,7 +189,7 @@ test_that("simple corTestDS, some, with na, pearson", { res <- corTestDS("x", "y", "pearson", NULL, 0.95) expect_equal(class(res), "list") - expect_length(res, 2) + expect_length(res, 3) expect_length(res$`Number of pairwise complete cases`, 1) expect_equal(res$`Number of pairwise complete cases`, 3) @@ -238,7 +238,7 @@ test_that("simple corTestDS, full, without na, kendall", { res <- corTestDS("x", "y", "kendall", NULL, 0.95) expect_equal(class(res), "list") - expect_length(res, 2) + expect_length(res, 3) expect_length(res$`Number of pairwise complete cases`, 1) expect_equal(res$`Number of pairwise complete cases`, 8) @@ -284,7 +284,7 @@ test_that("simple corTestDS, neg. full, without na, kendall", { res <- corTestDS("x", "y", "kendall", NULL, 0.95) expect_equal(class(res), "list") - expect_length(res, 2) + expect_length(res, 3) expect_length(res$`Number of pairwise complete cases`, 1) expect_equal(res$`Number of pairwise complete cases`, 8) @@ -330,7 +330,7 @@ test_that("simple corTestDS, some, kendall, without na, kendall", { res <- corTestDS("x", "y", "kendall", NULL, 0.95) expect_equal(class(res), "list") - expect_length(res, 2) + expect_length(res, 3) expect_length(res$`Number of pairwise complete cases`, 1) expect_equal(res$`Number of pairwise complete cases`, 8) @@ -377,7 +377,7 @@ test_that("simple corTestDS, some, with na, kendall", { res <- corTestDS("x", "y", "kendall", NULL, 0.95) expect_equal(class(res), "list") - expect_length(res, 2) + expect_length(res, 3) expect_length(res$`Number of pairwise complete cases`, 1) expect_equal(res$`Number of pairwise complete cases`, 3) @@ -424,7 +424,7 @@ test_that("simple corTestDS, full, without na, spearman", { res <- corTestDS("x", "y", "spearman", NULL, 0.95) expect_equal(class(res), "list") - expect_length(res, 2) + expect_length(res, 3) expect_length(res$`Number of pairwise complete cases`, 1) expect_equal(res$`Number of pairwise complete cases`, 8) @@ -470,7 +470,7 @@ test_that("simple corTestDS, neg. full, without na, spearman", { res <- corTestDS("x", "y", "spearman", NULL, 0.95) expect_equal(class(res), "list") - expect_length(res, 2) + expect_length(res, 3) expect_length(res$`Number of pairwise complete cases`, 1) expect_equal(res$`Number of pairwise complete cases`, 8) @@ -516,7 +516,7 @@ test_that("simple corTestDS, some, spearman, without na, spearman", { res <- corTestDS("x", "y", "spearman", NULL, 0.95) expect_equal(class(res), "list") - expect_length(res, 2) + expect_length(res, 3) expect_length(res$`Number of pairwise complete cases`, 1) expect_equal(res$`Number of pairwise complete cases`, 8) @@ -563,7 +563,7 @@ test_that("simple corTestDS, some, with na, spearman", { res <- corTestDS("x", "y", "spearman", NULL, 0.95) expect_equal(class(res), "list") - expect_length(res, 2) + expect_length(res, 3) expect_length(res$`Number of pairwise complete cases`, 1) expect_equal(res$`Number of pairwise complete cases`, 3) diff --git a/tests/testthat/test-smk-covDS.R b/tests/testthat/test-smk-covDS.R index 64710a72..24352ac7 100644 --- a/tests/testthat/test-smk-covDS.R +++ b/tests/testthat/test-smk-covDS.R @@ -27,7 +27,7 @@ test_that("numeric covDS, casewise.complete", { res <- covDS("input$v1", "input$v2", "casewise.complete") - expect_length(res, 5) + expect_length(res, 6) expect_equal(class(res), "list") res.sums.of.products.class <- class(res$sums.of.products) @@ -130,7 +130,7 @@ test_that("numeric covDS, pairwise.complete", { res <- covDS("input$v1", "input$v2", "pairwise.complete") - expect_length(res, 5) + expect_length(res, 6) expect_equal(class(res), "list") res.sums.of.products.class <- class(res$sums.of.products) diff --git a/tests/testthat/test-smk-kurtosisDS1.R b/tests/testthat/test-smk-kurtosisDS1.R index 53d9e277..3a13786d 100644 --- a/tests/testthat/test-smk-kurtosisDS1.R +++ b/tests/testthat/test-smk-kurtosisDS1.R @@ -33,8 +33,7 @@ test_that("simple kurtosisDS1, method 1", { expect_equal(res$Kurtosis, -0.458210, tolerance = 1e-6) expect_equal(class(res$Nvalid), "integer") expect_equal(res$Nvalid,9) - expect_equal(class(res$ValidityMessage), "character") - expect_equal(res$ValidityMessage, "VALID ANALYSIS") + expect_equal(res$class, "numeric") }) # context("kurtosisDS1::smk::method 2") @@ -49,8 +48,7 @@ test_that("simple kurtosisDS1, method 2", { expect_equal(res$Kurtosis, 0.270076, tolerance = 1e-6) expect_equal(class(res$Nvalid), "integer") expect_equal(res$Nvalid,9) - expect_equal(class(res$ValidityMessage), "character") - expect_equal(res$ValidityMessage, "VALID ANALYSIS") + expect_equal(res$class, "numeric") }) # context("kurtosisDS1::smk::method 3") @@ -65,8 +63,7 @@ test_that("simple kurtosisDS1, method 3", { expect_equal(res$Kurtosis, -0.991672, tolerance = 1e-6) expect_equal(class(res$Nvalid), "integer") expect_equal(res$Nvalid,9) - expect_equal(class(res$ValidityMessage), "character") - expect_equal(res$ValidityMessage, "VALID ANALYSIS") + expect_equal(res$class, "numeric") }) test_that("kurtosisDS1 throws error when object does not exist", { diff --git a/tests/testthat/test-smk-kurtosisDS2.R b/tests/testthat/test-smk-kurtosisDS2.R index f481b08f..69a735a6 100644 --- a/tests/testthat/test-smk-kurtosisDS2.R +++ b/tests/testthat/test-smk-kurtosisDS2.R @@ -36,8 +36,7 @@ test_that("simple kurtosisDS2", { expect_equal(res$Sum.squares, 3.25, tolerance = 1e-6) expect_equal(class(res$Nvalid), "integer") expect_equal(res$Nvalid, 5) - expect_equal(class(res$ValidityMessage), "character") - expect_equal(res$ValidityMessage, "VALID ANALYSIS") + expect_equal(res$class, "numeric") }) test_that("kurtosisDS2 throws error when object does not exist", { diff --git a/tests/testthat/test-smk-listDS.R b/tests/testthat/test-smk-listDS.R index dfd0a171..51e75550 100644 --- a/tests/testthat/test-smk-listDS.R +++ b/tests/testthat/test-smk-listDS.R @@ -21,10 +21,11 @@ # context("listDS::smk::simple") test_that("simple listDS", { - input <- list(v1 = c(1, 2, 3), v2 = c(4, 5, 6)) + v1 <- c(1, 2, 3) + v2 <- c(4, 5, 6) eltnames <- c('n1', 'n2') - res <- listDS(input, eltnames) + res <- listDS(c("v1", "v2"), eltnames) expect_equal(class(res), "list") expect_length(res, 2) diff --git a/tests/testthat/test-smk-meanDS.R b/tests/testthat/test-smk-meanDS.R index 4a11f514..8bb47c69 100644 --- a/tests/testthat/test-smk-meanDS.R +++ b/tests/testthat/test-smk-meanDS.R @@ -37,8 +37,7 @@ test_that("numeric meanDS", { expect_equal(res$Nvalid, 5) expect_equal(class(res$Ntotal), "integer") expect_equal(res$Ntotal, 5) - expect_equal(class(res$ValidityMessage), "character") - expect_equal(res$ValidityMessage, "VALID ANALYSIS") + expect_equal(res$class, "numeric") }) # context("meanDS::smk::numeric with NA") @@ -57,8 +56,7 @@ test_that("numeric meanDS, with NA", { expect_equal(res$Nvalid, 3) expect_equal(class(res$Ntotal), "integer") expect_equal(res$Ntotal, 5) - expect_equal(class(res$ValidityMessage), "character") - expect_equal(res$ValidityMessage, "VALID ANALYSIS") + expect_equal(res$class, "numeric") }) # context("meanDS::smk::numeric with all NA") @@ -77,8 +75,7 @@ test_that("numeric meanDS, with all NA", { expect_equal(res$Nvalid, 0) expect_equal(class(res$Ntotal), "integer") expect_equal(res$Ntotal, 5) - expect_equal(class(res$ValidityMessage), "character") - expect_equal(res$ValidityMessage, "VALID ANALYSIS") + expect_equal(res$class, "numeric") }) test_that("meanDS throws error when object does not exist", { diff --git a/tests/testthat/test-smk-quantileMeanDS.R b/tests/testthat/test-smk-quantileMeanDS.R index f585cea3..d305c8de 100644 --- a/tests/testthat/test-smk-quantileMeanDS.R +++ b/tests/testthat/test-smk-quantileMeanDS.R @@ -25,18 +25,23 @@ test_that("numeric quantileMeanDS", { res <- quantileMeanDS("input") - expect_length(res, 8) - expect_equal(class(res), "numeric") - expect_equal(res[[1]], 0.2) - expect_equal(res[[2]], 0.4) - expect_equal(res[[3]], 1.0) - expect_equal(res[[4]], 2.0) - expect_equal(res[[5]], 3.0) - expect_equal(res[[6]], 3.6) - expect_equal(res[[7]], 3.8) - expect_equal(res[[8]], 2.0) - - res.names <- names(res) + expect_equal(class(res), "list") + expect_equal(res$class, "numeric") + + qq <- res$quantiles + + expect_length(qq, 8) + expect_equal(class(qq), "numeric") + expect_equal(qq[[1]], 0.2) + expect_equal(qq[[2]], 0.4) + expect_equal(qq[[3]], 1.0) + expect_equal(qq[[4]], 2.0) + expect_equal(qq[[5]], 3.0) + expect_equal(qq[[6]], 3.6) + expect_equal(qq[[7]], 3.8) + expect_equal(qq[[8]], 2.0) + + res.names <- names(qq) expect_length(res.names, 8) expect_equal(class(res.names), "character") @@ -56,18 +61,23 @@ test_that("numeric quantileMeanDS, with NA", { res <- quantileMeanDS("input") - expect_length(res, 8) - expect_equal(class(res), "numeric") - expect_equal(res[[1]], 0.2) - expect_equal(res[[2]], 0.4) - expect_equal(res[[3]], 1.0) - expect_equal(res[[4]], 2.0) - expect_equal(res[[5]], 3.0) - expect_equal(res[[6]], 3.6) - expect_equal(res[[7]], 3.8) - expect_equal(res[[8]], 2.0) - - res.names <- names(res) + expect_equal(class(res), "list") + expect_equal(res$class, "numeric") + + qq <- res$quantiles + + expect_length(qq, 8) + expect_equal(class(qq), "numeric") + expect_equal(qq[[1]], 0.2) + expect_equal(qq[[2]], 0.4) + expect_equal(qq[[3]], 1.0) + expect_equal(qq[[4]], 2.0) + expect_equal(qq[[5]], 3.0) + expect_equal(qq[[6]], 3.6) + expect_equal(qq[[7]], 3.8) + expect_equal(qq[[8]], 2.0) + + res.names <- names(qq) expect_length(res.names, 8) expect_equal(class(res.names), "character") diff --git a/tests/testthat/test-smk-skewnessDS1.R b/tests/testthat/test-smk-skewnessDS1.R index 48093a37..f5d3357b 100644 --- a/tests/testthat/test-smk-skewnessDS1.R +++ b/tests/testthat/test-smk-skewnessDS1.R @@ -33,8 +33,7 @@ test_that("simple skewnessDS1, method 1", { expect_equal(res$Skewness, 0.443147, tolerance = 1e-6) expect_equal(class(res$Nvalid), "integer") expect_equal(res$Nvalid,9) - expect_equal(class(res$ValidityMessage), "character") - expect_equal(res$ValidityMessage, "VALID ANALYSIS") + expect_equal(res$class, "numeric") }) # context("skewnessDS1::smk::method 2") @@ -49,8 +48,7 @@ test_that("simple skewnessDS1, method 2", { expect_equal(res$Skewness, 0.537175, tolerance = 1e-6) expect_equal(class(res$Nvalid), "integer") expect_equal(res$Nvalid,9) - expect_equal(class(res$ValidityMessage), "character") - expect_equal(res$ValidityMessage, "VALID ANALYSIS") + expect_equal(res$class, "numeric") }) # context("skewnessDS1::smk::method 3") @@ -65,8 +63,7 @@ test_that("simple skewnessDS1, method 3", { expect_equal(res$Skewness, 0.3713805, tolerance = 1e-6) expect_equal(class(res$Nvalid), "integer") expect_equal(res$Nvalid,9) - expect_equal(class(res$ValidityMessage), "character") - expect_equal(res$ValidityMessage, "VALID ANALYSIS") + expect_equal(res$class, "numeric") }) test_that("skewnessDS1 throws error when object does not exist", { diff --git a/tests/testthat/test-smk-skewnessDS2.R b/tests/testthat/test-smk-skewnessDS2.R index 3c32f2e8..9e2ccea4 100644 --- a/tests/testthat/test-smk-skewnessDS2.R +++ b/tests/testthat/test-smk-skewnessDS2.R @@ -36,8 +36,7 @@ test_that("simple skewnessDS2", { expect_equal(res$Sum.squares, 3.25, tolerance = 1e-6) expect_equal(class(res$Nvalid), "integer") expect_equal(res$Nvalid, 5) - expect_equal(class(res$ValidityMessage), "character") - expect_equal(res$ValidityMessage, "VALID ANALYSIS") + expect_equal(res$class, "numeric") }) test_that("skewnessDS2 throws error when object does not exist", { diff --git a/tests/testthat/test-smk-varDS.R b/tests/testthat/test-smk-varDS.R index bfe5ce2e..51eac8e2 100644 --- a/tests/testthat/test-smk-varDS.R +++ b/tests/testthat/test-smk-varDS.R @@ -39,8 +39,7 @@ test_that("numeric varDS", { expect_equal(res$Nvalid, 5) expect_equal(class(res$Ntotal), "integer") expect_equal(res$Ntotal, 5) - expect_equal(class(res$ValidityMessage), "character") - expect_equal(res$ValidityMessage, "VALID ANALYSIS") + expect_equal(res$class, "numeric") }) # context("varDS::smk::numeric with NA") @@ -61,8 +60,7 @@ test_that("numeric varDS, with NA", { expect_equal(res$Nvalid, 3) expect_equal(class(res$Ntotal), "integer") expect_equal(res$Ntotal, 5) - expect_equal(class(res$ValidityMessage), "character") - expect_equal(res$ValidityMessage, "VALID ANALYSIS") + expect_equal(res$class, "numeric") }) # context("varDS::smk::numeric with all NA") @@ -83,8 +81,7 @@ test_that("numeric varDS, with all NA", { expect_equal(res$Nvalid, 0) expect_equal(class(res$Ntotal), "integer") expect_equal(res$Ntotal, 5) - expect_equal(class(res$ValidityMessage), "character") - expect_equal(res$ValidityMessage, "VALID ANALYSIS") + expect_equal(res$class, "numeric") }) test_that("varDS throws error when object does not exist", { From b8ba4805513de5d1aa590422687479e56bcdf87e Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Tue, 14 Apr 2026 14:19:15 +0200 Subject: [PATCH 10/17] docs: updated docs with authorship and parameters --- R/cDS.R | 22 ++++++++++++---------- R/lengthDS.R | 1 + R/listDS.R | 18 +++++++++++------- man/cDS.Rd | 6 ++++-- man/listDS.Rd | 8 +++++--- 5 files changed, 33 insertions(+), 22 deletions(-) diff --git a/R/cDS.R b/R/cDS.R index 0b5b96ba..dbc224b6 100644 --- a/R/cDS.R +++ b/R/cDS.R @@ -3,27 +3,29 @@ #' @description This function is similar to the R base function 'c'. #' @details Unlike the R base function 'c' on vector or list of certain #' length are allowed as output -#' @param objs a list which contains the the objects to concatenate. +#' @param x.names a character vector of object names to concatenate. #' @return a vector or list #' @author Gaye, A. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export -#' -cDS <- function (objs) { - +#' +cDS <- function (x.names) { + # Check Permissive Privacy Control Level. dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'avocado')) - - # this filter sets the minimum number of observations that are allowed + + # this filter sets the minimum number of observations that are allowed ############################################################# # MODULE 1: CAPTURE THE nfilter SETTINGS thr <- dsBase::listDisclosureSettingsDS() nfilter.tab <- as.numeric(thr$nfilter.tab) - #nfilter.glm <- as.numeric(thr$nfilter.glm) - #nfilter.subset <- as.numeric(thr$nfilter.subset) - #nfilter.string <- as.numeric(thr$nfilter.string) ############################################################# - + + objs <- list() + for (i in seq_along(x.names)) { + objs[[i]] <- .loadServersideObject(x.names[i]) + } x <- unlist(objs) # check if the output is valid and output accordingly diff --git a/R/lengthDS.R b/R/lengthDS.R index 1c793aa0..7975d7f8 100644 --- a/R/lengthDS.R +++ b/R/lengthDS.R @@ -1,3 +1,4 @@ + #' #' @title Returns the length of a vector or list #' @description This function is similar to R function \code{length}. diff --git a/R/listDS.R b/R/listDS.R index 162ae8b5..88706176 100644 --- a/R/listDS.R +++ b/R/listDS.R @@ -3,17 +3,21 @@ #' @description this function is similar to R function 'list' #' @details Unlike the R function 'list' it takes also a vector of characters, #' the names of the elements in the output list. -#' @param input a list of objects to coerce into a list -#' @param eltnames a character list, the names of the elements in the list. +#' @param x.names a character vector of object names to coerce into a list. +#' @param eltnames a character vector, the names of the elements in the list. #' @return a list #' @author Gaye, A. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export -#' -listDS <-function (input=NULL, eltnames=NULL){ - - mylist <- input +#' +listDS <-function (x.names=NULL, eltnames=NULL){ + + mylist <- list() + for (i in seq_along(x.names)) { + mylist[[i]] <- .loadServersideObject(x.names[i]) + } names(mylist) <- unlist(eltnames) return(mylist) - + } \ No newline at end of file diff --git a/man/cDS.Rd b/man/cDS.Rd index 7b4e448a..e3da7bf2 100644 --- a/man/cDS.Rd +++ b/man/cDS.Rd @@ -4,10 +4,10 @@ \alias{cDS} \title{Concatenates objects into a vector or list} \usage{ -cDS(objs) +cDS(x.names) } \arguments{ -\item{objs}{a list which contains the the objects to concatenate.} +\item{x.names}{a character vector of object names to concatenate.} } \value{ a vector or list @@ -21,4 +21,6 @@ length are allowed as output } \author{ Gaye, A. + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/listDS.Rd b/man/listDS.Rd index 36b1c236..4f0401a1 100644 --- a/man/listDS.Rd +++ b/man/listDS.Rd @@ -4,12 +4,12 @@ \alias{listDS} \title{Coerce objects into a list} \usage{ -listDS(input = NULL, eltnames = NULL) +listDS(x.names = NULL, eltnames = NULL) } \arguments{ -\item{input}{a list of objects to coerce into a list} +\item{x.names}{a character vector of object names to coerce into a list.} -\item{eltnames}{a character list, the names of the elements in the list.} +\item{eltnames}{a character vector, the names of the elements in the list.} } \value{ a list @@ -23,4 +23,6 @@ the names of the elements in the output list. } \author{ Gaye, A. + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } From 1ff323f41429ecb5fcb60f406c1a4bf0cfbac85a Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Tue, 14 Apr 2026 14:54:12 +0200 Subject: [PATCH 11/17] revert: remove batch-4 cDS/listDS work leaked onto batch-3 --- R/cDS.R | 22 ++++++++++------------ R/listDS.R | 18 +++++++----------- man/cDS.Rd | 6 ++---- man/listDS.Rd | 8 +++----- tests/testthat/test-smk-cDS.R | 16 +++++++++------- tests/testthat/test-smk-listDS.R | 5 ++--- 6 files changed, 33 insertions(+), 42 deletions(-) diff --git a/R/cDS.R b/R/cDS.R index dbc224b6..0b5b96ba 100644 --- a/R/cDS.R +++ b/R/cDS.R @@ -3,29 +3,27 @@ #' @description This function is similar to the R base function 'c'. #' @details Unlike the R base function 'c' on vector or list of certain #' length are allowed as output -#' @param x.names a character vector of object names to concatenate. +#' @param objs a list which contains the the objects to concatenate. #' @return a vector or list #' @author Gaye, A. -#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export -#' -cDS <- function (x.names) { - +#' +cDS <- function (objs) { + # Check Permissive Privacy Control Level. dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'avocado')) - - # this filter sets the minimum number of observations that are allowed + + # this filter sets the minimum number of observations that are allowed ############################################################# # MODULE 1: CAPTURE THE nfilter SETTINGS thr <- dsBase::listDisclosureSettingsDS() nfilter.tab <- as.numeric(thr$nfilter.tab) + #nfilter.glm <- as.numeric(thr$nfilter.glm) + #nfilter.subset <- as.numeric(thr$nfilter.subset) + #nfilter.string <- as.numeric(thr$nfilter.string) ############################################################# - - objs <- list() - for (i in seq_along(x.names)) { - objs[[i]] <- .loadServersideObject(x.names[i]) - } + x <- unlist(objs) # check if the output is valid and output accordingly diff --git a/R/listDS.R b/R/listDS.R index 88706176..162ae8b5 100644 --- a/R/listDS.R +++ b/R/listDS.R @@ -3,21 +3,17 @@ #' @description this function is similar to R function 'list' #' @details Unlike the R function 'list' it takes also a vector of characters, #' the names of the elements in the output list. -#' @param x.names a character vector of object names to coerce into a list. -#' @param eltnames a character vector, the names of the elements in the list. +#' @param input a list of objects to coerce into a list +#' @param eltnames a character list, the names of the elements in the list. #' @return a list #' @author Gaye, A. -#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export -#' -listDS <-function (x.names=NULL, eltnames=NULL){ - - mylist <- list() - for (i in seq_along(x.names)) { - mylist[[i]] <- .loadServersideObject(x.names[i]) - } +#' +listDS <-function (input=NULL, eltnames=NULL){ + + mylist <- input names(mylist) <- unlist(eltnames) return(mylist) - + } \ No newline at end of file diff --git a/man/cDS.Rd b/man/cDS.Rd index e3da7bf2..7b4e448a 100644 --- a/man/cDS.Rd +++ b/man/cDS.Rd @@ -4,10 +4,10 @@ \alias{cDS} \title{Concatenates objects into a vector or list} \usage{ -cDS(x.names) +cDS(objs) } \arguments{ -\item{x.names}{a character vector of object names to concatenate.} +\item{objs}{a list which contains the the objects to concatenate.} } \value{ a vector or list @@ -21,6 +21,4 @@ length are allowed as output } \author{ Gaye, A. - -Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/listDS.Rd b/man/listDS.Rd index 4f0401a1..36b1c236 100644 --- a/man/listDS.Rd +++ b/man/listDS.Rd @@ -4,12 +4,12 @@ \alias{listDS} \title{Coerce objects into a list} \usage{ -listDS(x.names = NULL, eltnames = NULL) +listDS(input = NULL, eltnames = NULL) } \arguments{ -\item{x.names}{a character vector of object names to coerce into a list.} +\item{input}{a list of objects to coerce into a list} -\item{eltnames}{a character vector, the names of the elements in the list.} +\item{eltnames}{a character list, the names of the elements in the list.} } \value{ a list @@ -23,6 +23,4 @@ the names of the elements in the output list. } \author{ Gaye, A. - -Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/tests/testthat/test-smk-cDS.R b/tests/testthat/test-smk-cDS.R index 518d9ac5..0f9842fc 100644 --- a/tests/testthat/test-smk-cDS.R +++ b/tests/testthat/test-smk-cDS.R @@ -23,9 +23,9 @@ set.standard.disclosure.settings() # context("cDS::smk::numeric list") test_that("numeric list cDS", { - a <- 0.0; b <- 1.0; c <- 2.0; d <- 3.0 + input <- list(a=0.0, b=1.0, c=2.0, d=3.0) - res <- cDS(c("a", "b", "c", "d")) + res <- cDS(input) expect_length(res, 4) expect_equal(class(res), "numeric") @@ -37,9 +37,9 @@ test_that("numeric list cDS", { # context("cDS::smk::character list") test_that("character list cDS", { - a <- "0.0"; b <- "1.0"; c <- "2.0"; d <- "3.0" + input <- list(a="0.0", b="1.0", c="2.0", d="3.0") - res <- cDS(c("a", "b", "c", "d")) + res <- cDS(input) expect_length(res, 4) expect_equal(class(res), "character") @@ -51,9 +51,9 @@ test_that("character list cDS", { # context("cDS::smk::numeric list small") test_that("single numeric list small cDS", { - a <- 0; b <- 1 + input <- list(a=0, b=1) - res <- cDS(c("a", "b")) + res <- cDS(input) expect_length(res, 2) expect_equal(class(res), "logical") @@ -63,7 +63,9 @@ test_that("single numeric list small cDS", { # context("cDS::smk::empty list") test_that("empty list cDS", { - res <- cDS(character(0)) + input <- list() + + res <- cDS(input) expect_length(res, 0) expect_equal(class(res), "NULL") diff --git a/tests/testthat/test-smk-listDS.R b/tests/testthat/test-smk-listDS.R index 51e75550..dfd0a171 100644 --- a/tests/testthat/test-smk-listDS.R +++ b/tests/testthat/test-smk-listDS.R @@ -21,11 +21,10 @@ # context("listDS::smk::simple") test_that("simple listDS", { - v1 <- c(1, 2, 3) - v2 <- c(4, 5, 6) + input <- list(v1 = c(1, 2, 3), v2 = c(4, 5, 6)) eltnames <- c('n1', 'n2') - res <- listDS(c("v1", "v2"), eltnames) + res <- listDS(input, eltnames) expect_equal(class(res), "list") expect_length(res, 2) From 0b6ab1aedc402105fb03391d4cf3adae9726250f Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Tue, 14 Apr 2026 18:36:55 +0200 Subject: [PATCH 12/17] fix: restore numeric-vector-requires-y guard in cor/covDS Server-side check preserves pre-refactor contract that was dropped when client-side validation moved to server. Redocument levelsDS. --- R/corDS.R | 6 +++++- R/covDS.R | 6 +++++- man/levelsDS.Rd | 5 ++--- 3 files changed, 12 insertions(+), 5 deletions(-) diff --git a/R/corDS.R b/R/corDS.R index fde5ad3d..f4e9fa23 100644 --- a/R/corDS.R +++ b/R/corDS.R @@ -38,7 +38,11 @@ corDS <- function(x=NULL, y=NULL){ else{ y.val <- NULL } - + + if (is.null(y.val) && any(class(x.val) %in% c("numeric", "integer"))) { + stop("If x is a numeric vector, y must also be a numeric vector.", call. = FALSE) + } + # create a data frame for the variables if (is.null(y.val)){ dataframe <- as.data.frame(x.val) diff --git a/R/covDS.R b/R/covDS.R index b15b4a5a..57a99ae2 100644 --- a/R/covDS.R +++ b/R/covDS.R @@ -47,7 +47,11 @@ covDS <- function(x=NULL, y=NULL, use=NULL){ else{ y.val <- NULL } - + + if (is.null(y.val) && any(class(x.val) %in% c("numeric", "integer"))) { + stop("If x is a numeric vector, y must also be a numeric vector.", call. = FALSE) + } + # create a data frame for the variables if (is.null(y.val)){ dataframe <- as.data.frame(x.val) diff --git a/man/levelsDS.Rd b/man/levelsDS.Rd index c54b7d13..4002c73c 100644 --- a/man/levelsDS.Rd +++ b/man/levelsDS.Rd @@ -10,9 +10,8 @@ levelsDS(x) \item{x}{a factor vector} } \value{ -a list with two elements: \code{Levels} (the factor levels present - in the vector) and \code{class} (the class of the input object, for - client-side consistency checking) +a list with one element: \code{Levels} (the factor levels present + in the vector) } \description{ This function is similar to R function \code{levels}. From 0c8409017b8dab6f1f38abf02389270fc22efb26 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Tue, 9 Jun 2026 18:03:56 +0200 Subject: [PATCH 13/17] revert: datashield privacy level to banana --- inst/DATASHIELD | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/DATASHIELD b/inst/DATASHIELD index abcabf73..8753f19d 100644 --- a/inst/DATASHIELD +++ b/inst/DATASHIELD @@ -163,7 +163,7 @@ AssignMethods: unlist=base::unlist Options: datashield.privacyLevel=5, - default.datashield.privacyControlLevel="permissive", + default.datashield.privacyControlLevel="banana", default.nfilter.glm=0.33, default.nfilter.kNN=3, default.nfilter.string=80, From c7825e16529a0188cc67d2c9c379c50db1828fc3 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 12 Jun 2026 10:02:35 +0200 Subject: [PATCH 14/17] chore: added files to ignore files --- .Rbuildignore | 2 ++ .gitignore | 2 ++ 2 files changed, 4 insertions(+) diff --git a/.Rbuildignore b/.Rbuildignore index 4b349a88..03475a99 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -13,3 +13,5 @@ ^cran-comments\.md$ ^pull_request_template$ PULL_REQUEST_TEMPLATE.md +.claude +.idea diff --git a/.gitignore b/.gitignore index 573f549b..f4edd3a2 100644 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,5 @@ .Rproj.user .DS_Store .Rapp.history +.claude +.idea From fde45bdea3cd21b3b9e5784a05435200208116f9 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 22 Jun 2026 15:25:58 +0200 Subject: [PATCH 15/17] docs: removed old message about validity check --- R/kurtosisDS1.R | 2 +- R/kurtosisDS2.R | 5 ++--- R/meanDS.R | 4 +++- R/quantileMeanDS.R | 4 +++- R/skewnessDS1.R | 2 +- R/skewnessDS2.R | 5 ++--- R/varDS.R | 4 ++-- man/kurtosisDS1.Rd | 2 +- man/kurtosisDS2.Rd | 5 ++--- man/meanDS.Rd | 4 +++- man/quantileMeanDS.Rd | 4 +++- man/skewnessDS1.Rd | 2 +- man/skewnessDS2.Rd | 5 ++--- man/varDS.Rd | 4 ++-- 14 files changed, 28 insertions(+), 24 deletions(-) diff --git a/R/kurtosisDS1.R b/R/kurtosisDS1.R index 9789ae68..a51caa43 100644 --- a/R/kurtosisDS1.R +++ b/R/kurtosisDS1.R @@ -7,7 +7,7 @@ #' @param method an integer between 1 and 3 selecting one of the algorithms for computing kurtosis #' detailed in the headers of the client-side \code{ds.kurtosis} function. #' @return a list including the kurtosis of the input numeric variable, the number of valid observations and -#' the study-side validity message. +#' \code{class}, the class of the input object for client-side consistency checking. #' @author Demetris Avraam, for DataSHIELD Development Team #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export diff --git a/R/kurtosisDS2.R b/R/kurtosisDS2.R index 392641ed..e7790329 100644 --- a/R/kurtosisDS2.R +++ b/R/kurtosisDS2.R @@ -9,9 +9,8 @@ #' @param global.mean a numeric, the combined mean of the input variable across all studies. #' @return a list including the sum of quartic differences between the values of x and the global mean of x across #' all studies, the sum of squared differences between the values of x and the global mean of x across all studies, -#' the number of valid observations (i.e. the length of x after excluding missing values), and a validity message -#' indicating indicating a valid analysis if the number of valid observations are above the protection filter -#' nfilter.tab or invalid analysis otherwise. +#' the number of valid observations (i.e. the length of x after excluding missing values), and \code{class}, +#' the class of the input object for client-side consistency checking. #' @author Demetris Avraam, for DataSHIELD Development Team #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export diff --git a/R/meanDS.R b/R/meanDS.R index 4fc3269c..576ec1b6 100644 --- a/R/meanDS.R +++ b/R/meanDS.R @@ -4,7 +4,9 @@ #' @details if the length of input vector is less than the set filter #' a missing value is returned. #' @param x a character string, the name of a numeric or integer vector -#' @return a numeric, the statistical mean +#' @return a list, with the estimated mean, the number of missing values, the number of +#' valid values, the total number of values, and \code{class}, the class of the input +#' object for client-side consistency checking #' @author Gaye A, Burton PR #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export diff --git a/R/quantileMeanDS.R b/R/quantileMeanDS.R index 26772caf..b6a54e91 100644 --- a/R/quantileMeanDS.R +++ b/R/quantileMeanDS.R @@ -3,7 +3,9 @@ #' @description the probabilities 5%, 10%, 25%, 50%, 75%, 90%, 95% and the mean #' are used to compute the corresponding quantiles. #' @param x a character string, the name of a numeric or integer vector -#' @return a numeric vector that represents the sample quantiles +#' @return a list, with \code{quantiles}, a numeric vector that represents the sample +#' quantiles, and \code{class}, the class of the input object for client-side consistency +#' checking #' @export #' @author Burton, P.; Gaye, A. #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands diff --git a/R/skewnessDS1.R b/R/skewnessDS1.R index 59e13745..64375375 100644 --- a/R/skewnessDS1.R +++ b/R/skewnessDS1.R @@ -7,7 +7,7 @@ #' @param method an integer between 1 and 3 selecting one of the algorithms for computing skewness #' detailed in the headers of the client-side \code{ds.skewness} function. #' @return a list including the skewness of the input numeric variable, the number of valid observations and -#' the study-side validity message. +#' \code{class}, the class of the input object for client-side consistency checking. #' @author Demetris Avraam, for DataSHIELD Development Team #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export diff --git a/R/skewnessDS2.R b/R/skewnessDS2.R index dc58ae6c..aad3088d 100644 --- a/R/skewnessDS2.R +++ b/R/skewnessDS2.R @@ -9,9 +9,8 @@ #' @param global.mean a numeric, the combined mean of the input variable across all studies. #' @return a list including the sum of cubed differences between the values of x and the global mean of x across #' all studies, the sum of squared differences between the values of x and the global mean of x across all studies, -#' the number of valid observations (i.e. the length of x after excluding missing values), and a validity message -#' indicating indicating a valid analysis if the number of valid observations are above the protection filter -#' nfilter.tab or invalid analysis otherwise. +#' the number of valid observations (i.e. the length of x after excluding missing values), and \code{class}, +#' the class of the input object for client-side consistency checking. #' @author Demetris Avraam, for DataSHIELD Development Team #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export diff --git a/R/varDS.R b/R/varDS.R index 75a21c17..eb9fcf0e 100644 --- a/R/varDS.R +++ b/R/varDS.R @@ -6,8 +6,8 @@ #' @param x a character string, the name of a numeric or integer vector #' @return a list, with the sum of the input variable, the sum of squares of the input variable, #' the number of missing values, the number of valid values, the number of total length of the -#' variable, and a study message indicating whether the number of valid is less than the -#' disclosure threshold +#' variable, and \code{class}, the class of the input object for client-side +#' consistency checking #' @author Amadou Gaye, Demetris Avraam, for DataSHIELD Development Team #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export diff --git a/man/kurtosisDS1.Rd b/man/kurtosisDS1.Rd index 34098514..239a3a43 100644 --- a/man/kurtosisDS1.Rd +++ b/man/kurtosisDS1.Rd @@ -14,7 +14,7 @@ detailed in the headers of the client-side \code{ds.kurtosis} function.} } \value{ a list including the kurtosis of the input numeric variable, the number of valid observations and -the study-side validity message. +\code{class}, the class of the input object for client-side consistency checking. } \description{ This function calculates the kurtosis of a numeric variable for each study separately. diff --git a/man/kurtosisDS2.Rd b/man/kurtosisDS2.Rd index 9a6e1327..19c07f95 100644 --- a/man/kurtosisDS2.Rd +++ b/man/kurtosisDS2.Rd @@ -14,9 +14,8 @@ kurtosisDS2(x, global.mean) \value{ a list including the sum of quartic differences between the values of x and the global mean of x across all studies, the sum of squared differences between the values of x and the global mean of x across all studies, -the number of valid observations (i.e. the length of x after excluding missing values), and a validity message -indicating indicating a valid analysis if the number of valid observations are above the protection filter -nfilter.tab or invalid analysis otherwise. +the number of valid observations (i.e. the length of x after excluding missing values), and \code{class}, +the class of the input object for client-side consistency checking. } \description{ This function calculates summary statistics that are returned to the client-side and diff --git a/man/meanDS.Rd b/man/meanDS.Rd index 251d025b..c92c0d51 100644 --- a/man/meanDS.Rd +++ b/man/meanDS.Rd @@ -10,7 +10,9 @@ meanDS(x) \item{x}{a character string, the name of a numeric or integer vector} } \value{ -a numeric, the statistical mean +a list, with the estimated mean, the number of missing values, the number of +valid values, the total number of values, and \code{class}, the class of the input +object for client-side consistency checking } \description{ Calculates the mean value. diff --git a/man/quantileMeanDS.Rd b/man/quantileMeanDS.Rd index 1f453984..2126ed58 100644 --- a/man/quantileMeanDS.Rd +++ b/man/quantileMeanDS.Rd @@ -10,7 +10,9 @@ quantileMeanDS(x) \item{x}{a character string, the name of a numeric or integer vector} } \value{ -a numeric vector that represents the sample quantiles +a list, with \code{quantiles}, a numeric vector that represents the sample +quantiles, and \code{class}, the class of the input object for client-side consistency +checking } \description{ the probabilities 5%, 10%, 25%, 50%, 75%, 90%, 95% and the mean diff --git a/man/skewnessDS1.Rd b/man/skewnessDS1.Rd index fe2921d7..d042c9ee 100644 --- a/man/skewnessDS1.Rd +++ b/man/skewnessDS1.Rd @@ -14,7 +14,7 @@ detailed in the headers of the client-side \code{ds.skewness} function.} } \value{ a list including the skewness of the input numeric variable, the number of valid observations and -the study-side validity message. +\code{class}, the class of the input object for client-side consistency checking. } \description{ This function calculates the skewness of a numeric variable for each study separately. diff --git a/man/skewnessDS2.Rd b/man/skewnessDS2.Rd index 12646548..9b5e7b9b 100644 --- a/man/skewnessDS2.Rd +++ b/man/skewnessDS2.Rd @@ -14,9 +14,8 @@ skewnessDS2(x, global.mean) \value{ a list including the sum of cubed differences between the values of x and the global mean of x across all studies, the sum of squared differences between the values of x and the global mean of x across all studies, -the number of valid observations (i.e. the length of x after excluding missing values), and a validity message -indicating indicating a valid analysis if the number of valid observations are above the protection filter -nfilter.tab or invalid analysis otherwise. +the number of valid observations (i.e. the length of x after excluding missing values), and \code{class}, +the class of the input object for client-side consistency checking. } \description{ This function calculates summary statistics that are returned to the client-side and diff --git a/man/varDS.Rd b/man/varDS.Rd index 78c9b05c..022923be 100644 --- a/man/varDS.Rd +++ b/man/varDS.Rd @@ -12,8 +12,8 @@ varDS(x) \value{ a list, with the sum of the input variable, the sum of squares of the input variable, the number of missing values, the number of valid values, the number of total length of the -variable, and a study message indicating whether the number of valid is less than the -disclosure threshold +variable, and \code{class}, the class of the input object for client-side +consistency checking } \description{ Calculates the variance. From 6d14225b1f0e02c544c788e508939335aa05b8ed Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 22 Jun 2026 15:32:13 +0200 Subject: [PATCH 16/17] revert whitespace changes --- R/expDS.R | 2 +- R/lengthDS.R | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/R/expDS.R b/R/expDS.R index 2ba9e5bb..3c6b53c3 100644 --- a/R/expDS.R +++ b/R/expDS.R @@ -15,7 +15,7 @@ expDS <- function(x) { x.var <- .loadServersideObject(x) .checkClass(obj = x.var, obj_name = x, permitted_classes = c("numeric", "integer")) -out <- exp(x.var) + out <- exp(x.var) return(out) } # ASSIGN FUNCTION diff --git a/R/lengthDS.R b/R/lengthDS.R index 47df21ce..0441e67c 100644 --- a/R/lengthDS.R +++ b/R/lengthDS.R @@ -1,4 +1,3 @@ - #' #' @title Returns the length of a vector or list #' @description This function is similar to R function \code{length}. From b16e72920189bc2e42c17904ebfbc646815d3b8a Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 22 Jun 2026 15:32:45 +0200 Subject: [PATCH 17/17] added class as additional returns --- R/corDS.R | 3 ++- R/corTestDS.R | 3 ++- R/covDS.R | 3 ++- man/corDS.Rd | 3 ++- man/corTestDS.Rd | 3 ++- man/covDS.Rd | 3 ++- 6 files changed, 12 insertions(+), 6 deletions(-) diff --git a/R/corDS.R b/R/corDS.R index f4e9fa23..6133b4e0 100644 --- a/R/corDS.R +++ b/R/corDS.R @@ -14,7 +14,8 @@ #' sum of squares of each variable. The first disclosure control checks that the number of variables is #' not bigger than a percentage of the individual-level records (the allowed percentage is pre-specified #' by the 'nfilter.glm'). The second disclosure control checks that none of them is dichotomous with a -#' level having fewer counts than the pre-specified 'nfilter.tab' threshold. +#' level having fewer counts than the pre-specified 'nfilter.tab' threshold. The list also includes +#' \code{class}, the class of the input object for client-side consistency checking. #' @author Paul Burton, and Demetris Avraam for DataSHIELD Development Team #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export diff --git a/R/corTestDS.R b/R/corTestDS.R index 547484c8..777bdce8 100644 --- a/R/corTestDS.R +++ b/R/corTestDS.R @@ -11,7 +11,8 @@ #' @param conf.level confidence level for the returned confidence interval. Currently #' only used for the Pearson product moment correlation coefficient if there are at least #' 4 complete pairs of observations. -#' @return the results of the correlation test. +#' @return a list with the results of the correlation test and \code{class}, the class of the +#' input object for client-side consistency checking. #' @author Demetris Avraam, for DataSHIELD Development Team #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export diff --git a/R/covDS.R b/R/covDS.R index 57a99ae2..fe25eabd 100644 --- a/R/covDS.R +++ b/R/covDS.R @@ -21,7 +21,8 @@ #' of variables is not bigger than a percentage of the individual-level records (the allowed percentage is pre-specified #' by the 'nfilter.glm'). The second disclosure control checks that none of them is dichotomous with a level having fewer #' counts than the pre-specified 'nfilter.tab' threshold. If any of the input variables do not pass the disclosure -#' controls then all the output values are replaced with NAs. +#' controls then all the output values are replaced with NAs. The list also includes \code{class}, the class +#' of the input object for client-side consistency checking. #' @author Amadou Gaye, Paul Burton, and Demetris Avraam for DataSHIELD Development Team #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export diff --git a/man/corDS.Rd b/man/corDS.Rd index b3b37363..6a734304 100644 --- a/man/corDS.Rd +++ b/man/corDS.Rd @@ -20,7 +20,8 @@ separately (columnwise) and the number of missing values casewise, and a vector sum of squares of each variable. The first disclosure control checks that the number of variables is not bigger than a percentage of the individual-level records (the allowed percentage is pre-specified by the 'nfilter.glm'). The second disclosure control checks that none of them is dichotomous with a -level having fewer counts than the pre-specified 'nfilter.tab' threshold. +level having fewer counts than the pre-specified 'nfilter.tab' threshold. The list also includes +\code{class}, the class of the input object for client-side consistency checking. } \description{ This function computes the sum of each vector of variable and the sum of the products diff --git a/man/corTestDS.Rd b/man/corTestDS.Rd index 28e7ab01..9c6d5cd2 100644 --- a/man/corTestDS.Rd +++ b/man/corTestDS.Rd @@ -22,7 +22,8 @@ only used for the Pearson product moment correlation coefficient if there are at 4 complete pairs of observations.} } \value{ -the results of the correlation test. +a list with the results of the correlation test and \code{class}, the class of the +input object for client-side consistency checking. } \description{ This function is similar to R function \code{cor.test}. diff --git a/man/covDS.Rd b/man/covDS.Rd index 9600ce75..4b067a16 100644 --- a/man/covDS.Rd +++ b/man/covDS.Rd @@ -28,7 +28,8 @@ whether or not the input variables pass the disclosure controls. The first discl of variables is not bigger than a percentage of the individual-level records (the allowed percentage is pre-specified by the 'nfilter.glm'). The second disclosure control checks that none of them is dichotomous with a level having fewer counts than the pre-specified 'nfilter.tab' threshold. If any of the input variables do not pass the disclosure -controls then all the output values are replaced with NAs. +controls then all the output values are replaced with NAs. The list also includes \code{class}, the class +of the input object for client-side consistency checking. } \description{ This function computes the sum of each vector of variable and the sum of the products of each two