Refactor/perf batch 11

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))
 

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",

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")

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)
   ))
 }
 

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")
 })
 
 #

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)

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
 #

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
 #

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
 #

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)