diff --git a/R/aucDS.R b/R/aucDS.R index 6afda830..7229212c 100644 --- a/R/aucDS.R +++ b/R/aucDS.R @@ -8,16 +8,13 @@ #' the complete cases that are used in the regression model. #' @return returns the AUC and its standard error #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' aucDS <- function(pred=pred, y=y){ - if(is.character(pred)){ - pred <- eval(parse(text = pred), envir = parent.frame()) - } - if(is.character(y)){ - y <- eval(parse(text = y), envir = parent.frame()) - } + pred <- .loadServersideObject(pred) + y <- .loadServersideObject(y) y <- as.numeric(as.character(y)) diff --git a/R/bp_standardsDS.R b/R/bp_standardsDS.R index f90e683e..8d6baec7 100644 --- a/R/bp_standardsDS.R +++ b/R/bp_standardsDS.R @@ -20,23 +20,16 @@ #' @note The z-scores of height based on CDC growth charts are calculated #' by the sds function from the childsds R package. #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @import childsds #' @export #' bp_standardsDS <- function(sex=sex, age=age, height=height, bp=bp, systolic=systolic){ - if(is.character(sex)){ - sex <- eval(parse(text = sex), envir = parent.frame()) - } - if(is.character(age)){ - age <- eval(parse(text = age), envir = parent.frame()) - } - if(is.character(height)){ - height <- eval(parse(text = height), envir = parent.frame()) - } - if(is.character(bp)){ - bp <- eval(parse(text = bp), envir = parent.frame()) - } + sex <- .loadServersideObject(sex) + age <- .loadServersideObject(age) + height <- .loadServersideObject(height) + bp <- .loadServersideObject(bp) # convert height to a Z-score relative to age and sex based on CDC growth charts Zht <- sds(value=height, age=age, sex=sex, male="1", female="2", diff --git a/R/igb_standardsDS.R b/R/igb_standardsDS.R index e30247cb..13a19afc 100644 --- a/R/igb_standardsDS.R +++ b/R/igb_standardsDS.R @@ -17,6 +17,7 @@ #' standard is used. #' @return assigns the converted measurement as a new object on the server-side #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @import dplyr #' @importFrom gamlss.dist qST3 pST3 #' @export @@ -228,15 +229,11 @@ igb_standardsDS <- function(gagebrth=gagebrth, z=z, p=p, val=val, var=var, sex=s # Start the analysis - if(is.character(gagebrth)){ - gagebrth <- eval(parse(text = gagebrth), envir = parent.frame()) - } - if(is.character(val)){ - val <- eval(parse(text = val), envir = parent.frame()) - } - if(is.character(sex)){ - sex <- eval(parse(text = sex), envir = parent.frame()) + gagebrth <- .loadServersideObject(gagebrth) + if(!is.null(val)){ + val <- .loadServersideObject(val) } + sex <- .loadServersideObject(sex) x.out <- rep(NA, t=length(sex)) idx.males <- which(sex=="Male") diff --git a/R/mdPatternDS.R b/R/mdPatternDS.R index 0f817034..66dbaaba 100644 --- a/R/mdPatternDS.R +++ b/R/mdPatternDS.R @@ -36,7 +36,9 @@ #' \item{pattern}{The missing data pattern matrix with disclosure control applied} #' \item{valid}{Logical indicating if all patterns meet disclosure requirements} #' \item{message}{A message describing the validity status} +#' \item{class}{The class of the input object, for client-side consistency checking} #' @author Xavier EscribĂ  montagut for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @import mice #' @export #' @@ -48,24 +50,8 @@ mdPatternDS <- function(x){ nfilter.tab <- as.numeric(thr$nfilter.tab) ############################################################# - # Parse the input data name with error handling - x.val <- tryCatch( - { - eval(parse(text=x), envir = parent.frame()) - }, - error = function(e) { - stop(paste0("Object '", x, "' does not exist on the server"), call. = FALSE) - } - ) - - # Check object class - typ <- class(x.val) - - # Check that input is a data frame or matrix - if(!("data.frame" %in% typ || "matrix" %in% typ)){ - stop(paste0("The input object must be of type 'data.frame' or 'matrix'. Current type: ", - paste(typ, collapse = ", ")), call. = FALSE) - } + x.val <- .loadServersideObject(x) + .checkClass(obj = x.val, obj_name = x, permitted_classes = c("data.frame", "matrix")) # Use x.val for further processing x <- x.val @@ -113,7 +99,8 @@ mdPatternDS <- function(x){ message = ifelse(validity == "valid", "Valid: all pattern counts meet disclosure requirements", paste0("Invalid: some pattern counts below threshold (", - nfilter.tab, ") have been suppressed")) + nfilter.tab, ") have been suppressed")), + class = class(x.val) )) } diff --git a/man/aucDS.Rd b/man/aucDS.Rd index 567f2e38..b1d4cb30 100644 --- a/man/aucDS.Rd +++ b/man/aucDS.Rd @@ -24,4 +24,6 @@ The AUC determines the discriminative ability of a model. } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/bp_standardsDS.Rd b/man/bp_standardsDS.Rd index 1b26b9f5..cfafb344 100644 --- a/man/bp_standardsDS.Rd +++ b/man/bp_standardsDS.Rd @@ -45,4 +45,6 @@ by the sds function from the childsds R package. } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/igb_standardsDS.Rd b/man/igb_standardsDS.Rd index 99fd30e0..4eed445d 100644 --- a/man/igb_standardsDS.Rd +++ b/man/igb_standardsDS.Rd @@ -46,4 +46,6 @@ standard is used. } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/mdPatternDS.Rd b/man/mdPatternDS.Rd index 1084565e..6295c024 100644 --- a/man/mdPatternDS.Rd +++ b/man/mdPatternDS.Rd @@ -15,6 +15,7 @@ A list containing: \item{pattern}{The missing data pattern matrix with disclosure control applied} \item{valid}{Logical indicating if all patterns meet disclosure requirements} \item{message}{A message describing the validity status} +\item{class}{The class of the input object, for client-side consistency checking} } \description{ This function is a serverside aggregate function that computes the @@ -51,4 +52,6 @@ suppressed in some studies. } \author{ Xavier EscribĂ  montagut for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/tests/testthat/test-arg-mdPatternDS.R b/tests/testthat/test-arg-mdPatternDS.R index 989deb76..e2ce112d 100644 --- a/tests/testthat/test-arg-mdPatternDS.R +++ b/tests/testthat/test-arg-mdPatternDS.R @@ -24,14 +24,22 @@ set.standard.disclosure.settings() test_that("mdPatternDS x NULL", { x <- NULL - expect_error(mdPatternDS(x), "The input object must be of type 'data.frame' or 'matrix'. Current type: NULL") + expect_error(mdPatternDS(x), "The input must be a single character string") }) # context("mdPatternDS::arg::x not valid variable") test_that("mdPatternDS x not variable", { x <- "not a variable" - expect_error(mdPatternDS(x), "Object 'not a variable' does not exist on the server") + expect_error(mdPatternDS(x), "does not exist") +}) + +# context("mdPatternDS::arg::x wrong type") +test_that("mdPatternDS x wrong type", { + x_val <- c(1.0, 2.0, 3.0) + x <- "x_val" + + expect_error(mdPatternDS(x), "must be of type data.frame or matrix") }) # diff --git a/tests/testthat/test-disc-mdPatternDS.R b/tests/testthat/test-disc-mdPatternDS.R index d10b004a..6f6a7c01 100644 --- a/tests/testthat/test-disc-mdPatternDS.R +++ b/tests/testthat/test-disc-mdPatternDS.R @@ -27,7 +27,7 @@ test_that("mdPatternDS: sample incomplete data.frame", { res <- mdPatternDS(x) - expect_length(res, 3) + expect_length(res, 4) expect_length(class(res), 1) expect_true(all(class(res) %in% c("list"))) expect_length(class(res$pattern), 2) diff --git a/tests/testthat/test-smk-aucDS.R b/tests/testthat/test-smk-aucDS.R index bcbbada1..c33d2eee 100644 --- a/tests/testthat/test-smk-aucDS.R +++ b/tests/testthat/test-smk-aucDS.R @@ -25,7 +25,7 @@ test_that("aucDS", { model <- glm(formula = D$DIS_DIAB~D$GENDER+D$PM_BMI_CONTINUOUS, family = 'binomial') pred <- predict(object = model, type = "link") - res <- aucDS(pred = pred, y = model$y) + res <- aucDS(pred = "pred", y = "model$y") expect_equal(class(res), "list") expect_length(res, 2) @@ -36,6 +36,18 @@ test_that("aucDS", { }) +test_that("aucDS throws error when pred does not exist", { + y <- c(0, 1, 0, 1) + + expect_error(aucDS(pred = "nonexistent_object", y = "y"), regexp = "does not exist") +}) + +test_that("aucDS throws error when y does not exist", { + pred <- c(0.1, 0.8, 0.3, 0.9) + + expect_error(aucDS(pred = "pred", y = "nonexistent_object"), regexp = "does not exist") +}) + # # Done # diff --git a/tests/testthat/test-smk-bp_standardsDS.R b/tests/testthat/test-smk-bp_standardsDS.R index fe8b9bc1..06fa5519 100644 --- a/tests/testthat/test-smk-bp_standardsDS.R +++ b/tests/testthat/test-smk-bp_standardsDS.R @@ -28,7 +28,7 @@ test_that("systolic bp_standardsDS", { bp <- c(118.54, 87.62, 72.13, 91.18, 88.47, 73.28, 100.27, 86.84, 103.51, 115.28) systolic <- TRUE - res <- bp_standardsDS(sex=sex, age=age, height=height, bp=bp, systolic=systolic) + res <- bp_standardsDS(sex="sex", age="age", height="height", bp="bp", systolic=systolic) expect_equal(class(res), "list") expect_length(res, 2) @@ -56,7 +56,7 @@ test_that("diastolic bp_standardsDS", { bp <- c(118.54, 87.62, 72.13, 91.18, 88.47, 73.28, 100.27, 86.84, 103.51, 115.28) systolic <- FALSE - res <- bp_standardsDS(sex=sex, age=age, height=height, bp=bp, systolic=systolic) + res <- bp_standardsDS(sex="sex", age="age", height="height", bp="bp", systolic=systolic) expect_equal(class(res), "list") expect_length(res, 2) @@ -76,6 +76,14 @@ test_that("diastolic bp_standardsDS", { }) +test_that("bp_standardsDS throws error when an input does not exist", { + sex <- c(2, 1) + age <- c(5.26, 7.73) + height <- c(113.57, 92.30) + + expect_error(bp_standardsDS(sex="sex", age="age", height="height", bp="nonexistent_object", systolic=TRUE), regexp = "does not exist") +}) + # # Done # diff --git a/tests/testthat/test-smk-igb_standardsDS.R b/tests/testthat/test-smk-igb_standardsDS.R index bd3a8f79..f3f11a16 100644 --- a/tests/testthat/test-smk-igb_standardsDS.R +++ b/tests/testthat/test-smk-igb_standardsDS.R @@ -154,6 +154,18 @@ test_that("igb_standardsDS - igb_centile2value", { }) +test_that("igb_standardsDS throws error when gagebrth does not exist", { + data <- data.frame(sex = c("Male", "Female")) + + expect_error(igb_standardsDS(gagebrth="nonexistent_object", z=0, p=50, val=NULL, var="lencm", sex="data$sex", fun="igb_centile2value"), regexp = "does not exist") +}) + +test_that("igb_standardsDS throws error when val does not exist", { + data <- data.frame(gagebrth = c(250, 270), sex = c("Male", "Female")) + + expect_error(igb_standardsDS(gagebrth="data$gagebrth", z=0, p=50, val="nonexistent_object", var="lencm", sex="data$sex", fun="igb_value2zscore"), regexp = "does not exist") +}) + # # Done # diff --git a/tests/testthat/test-smk-mdPatternDS.R b/tests/testthat/test-smk-mdPatternDS.R index ba682b1e..3e11a024 100644 --- a/tests/testthat/test-smk-mdPatternDS.R +++ b/tests/testthat/test-smk-mdPatternDS.R @@ -27,7 +27,7 @@ test_that("mdPatternDS: sample 1 complete data.frame", { res <- mdPatternDS(x) - expect_length(res, 3) + expect_length(res, 4) expect_length(class(res), 1) expect_true(all(class(res) %in% c("list"))) expect_length(class(res$pattern), 2) @@ -64,7 +64,7 @@ test_that("mdPatternDS: sample 2 complete data.frame", { res <- mdPatternDS(x) - expect_length(res, 3) + expect_length(res, 4) expect_length(class(res), 1) expect_true(all(class(res) %in% c("list"))) expect_length(class(res$pattern), 2)