Refactor/perf batch 6

R/asFactorDS1.R

@@ -7,6 +7,7 @@
 #' are of type character.
 #' @param input.var.name the name of the variable that is to be converted to a factor.
 #' @return the levels of the input variable.
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 asFactorDS1 <- function(input.var.name=NULL){
@@ -24,7 +25,7 @@ asFactorDS1 <- function(input.var.name=NULL){
   nfilter.levels.max <- as.numeric(thr$nfilter.levels.max)         #
   ##################################################################
 
-  input.var <- eval(parse(text=input.var.name), envir = parent.frame())
+  input.var <- .loadServersideObject(input.var.name)
   factor.levels.present.in.source <- levels(factor(input.var))
   num.levels<-length(factor.levels.present.in.source)
 

R/asFactorDS2.R

@@ -15,11 +15,12 @@
 #' @param baseline.level a number indicating the baseline level to be used in the creation of the
 #' matrix of dummy variables.
 #' @return an object of class factor
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 asFactorDS2 <- function(input.var.name=NULL, all.unique.levels.transmit=NULL, fixed.dummy.vars=NULL, baseline.level=NULL){
 
-  input.var <- eval(parse(text=input.var.name), envir = parent.frame())
+  input.var <- .loadServersideObject(input.var.name)
 
   code.input <- all.unique.levels.transmit
   code.c <- unlist(strsplit(code.input, split=","))

R/asFactorSimpleDS.R

@@ -12,11 +12,12 @@
 #' of these things you will have to use the ds.asFactor function.
 #' @param input.var.name the name of the variable that is to be converted to a factor.
 #' @return an object of class factor
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 asFactorSimpleDS <- function(input.var.name=NULL){
 
-    input.var <- eval(parse(text=input.var.name), envir = parent.frame())
+    input.var <- .loadServersideObject(input.var.name)
 
     factor.obj <- factor(input.var)
 

R/changeRefGroupDS.R

@@ -7,16 +7,20 @@
 #' as this can introduce a mismatch of values if the vector is put back
 #' into a table that is not reordered in the same way. Such mismatch
 #' can render the results of operations on that table invalid.
-#' @param xvect a factor vector
+#' @param x a character string, the name of a factor vector.
 #' @param ref a character, the reference level
-#' @param reorderByRef a boolean that tells whether or not the new 
+#' @param reorderByRef a boolean that tells whether or not the new
 #' vector should be ordered by the reference group.
-#' @return  a factor of the same length as xvect
+#' @return  a factor of the same length as the input vector
 #' @author Isaeva, J., Gaye, A.
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
-changeRefGroupDS <- function(xvect, ref=NULL, reorderByRef=NULL){
-
+changeRefGroupDS <- function(x, ref=NULL, reorderByRef=NULL){
+
+  xvect <- .loadServersideObject(x)
+  .checkClass(obj = xvect, obj_name = x, permitted_classes = "factor")
+
   if(reorderByRef){
     temp_xvect = stats::relevel(xvect, ref)
     # now reorder puting the ref group first
@@ -26,7 +30,7 @@ changeRefGroupDS <- function(xvect, ref=NULL, reorderByRef=NULL){
   }else{
     new_xvect <- stats::relevel(xvect, ref)
   }
-  
+
   return(new_xvect)
-  
+
 }

R/reShapeDS.R

@@ -35,18 +35,16 @@
 #' @return a reshaped data.frame converted from long to wide format or from wide to
 #' long format which is written to the serverside and given the name provided as the
 #' <newobj> argument of \code{ds.reShape} or 'newObject' if no name is specified.
-#' In addition, two validity messages are returned to the clientside
-#' indicating whether <newobj> has been created in each data source and if so whether
-#' it is in a valid form (see header for \code{ds.reShape}.
 #' @author Demetris Avraam, Paul Burton for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 reShapeDS <- function(data.name, varying.transmit, v.names.transmit, timevar.name, idvar.name, drop.transmit, direction, sep){
 
   # Check Permissive Privacy Control Level.
   dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot'))
 
-  datatext <- paste0("data.frame(",data.name,")")
-  data <- eval(parse(text=datatext), envir = parent.frame())
+  data <- .loadServersideObject(data.name)
+  data <- data.frame(data)
 
   timevar <- timevar.name
   idvar <- idvar.name

tests/testthat/test-smk-asFactorDS1.R

@@ -21,7 +21,6 @@ set.standard.disclosure.settings()
 # Tests
 #
 
-# context("asFactorDS1::smk::simple")
 test_that("simple asFactorDS1", {
     input <- c(2.0, 1.0, 3.0, 3.0, 3.0, 1.0, 2.0, 2.0, 1.0, 2.0)
 
@@ -34,10 +33,6 @@ test_that("simple asFactorDS1", {
     expect_equal(res[3], "3")
 })
 
-#
-# Done
-#
-
-# context("asFactorDS1::smk::shutdown")
-
-# context("asFactorDS1::smk::done")
+test_that("asFactorDS1 errors when serverside object does not exist", {
+    expect_error(asFactorDS1("nonexistent_object"), regexp = "does not exist")
+})

tests/testthat/test-smk-asFactorDS2.R

@@ -20,99 +20,29 @@ set.standard.disclosure.settings()
 # Tests
 #
 
-# context("asFactorDS2::smk::simple")
-test_that("simple asFactorDS2, fixed.dummy.vars is FALSE", {
-    input                      <- c(2, 1, 3, 3, 3, 1, 2, 2, 1, 2)
-    all.unique.levels.transmit <- "1,2,3,4"
-    fixed.dummy.vars           <- FALSE
-    baseline.level             <- NULL
+test_that("simple asFactorDS2", {
+    input <- c(2, 1, 3, 3, 3, 1, 2, 2, 1, 2)
 
-    res <- asFactorDS2("input", all.unique.levels.transmit, fixed.dummy.vars, baseline.level)
+    res <- asFactorDS2("input", "1,2,3,4", FALSE, NULL)
 
     expect_equal(class(res), "factor")
     expect_length(res, 10)
-
-    res.levels <- levels(res)
-
-    expect_equal(class(res.levels), "character")
-    expect_length(res.levels, 4)
-
-    expect_equal(res.levels[1], "1")
-    expect_equal(res.levels[2], "2")
-    expect_equal(res.levels[3], "3")
-    expect_equal(res.levels[4], "4")
+    expect_equal(levels(res), c("1", "2", "3", "4"))
 })
 
-test_that("simple asFactorDS2, fixed.dummy.vars is TRUE", {
-    input                      <- c(2, 1, 3, 3, 3, 1, 2, 2, 1, 2)
-    all.unique.levels.transmit <- "1,2,3,4"
-    fixed.dummy.vars           <- TRUE
-    baseline.level             <- 1.0
-
-    res <- asFactorDS2("input", all.unique.levels.transmit, fixed.dummy.vars, baseline.level)
-
-    expect_length(res, 30)
-
-    res.class <- class(res)
-
-    if (base::getRversion() < '4.0.0')
-    {
-        expect_length(res.class, 1)
-        expect_true("matrix" %in% res.class)
-    }
-    else
-    {
-        expect_length(res.class, 2)
-        expect_true("matrix" %in% res.class)
-        expect_true("array" %in% res.class)
-    }
-
-    expect_equal(res[1], 1)
-    expect_equal(res[2], 0)
-    expect_equal(res[3], 0)
-    expect_equal(res[4], 0)
-    expect_equal(res[5], 0)
-    expect_equal(res[6], 0)
-    expect_equal(res[7], 1)
-    expect_equal(res[8], 1)
-    expect_equal(res[9], 0)
-    expect_equal(res[10], 1)
-    expect_equal(res[11], 0)
-    expect_equal(res[12], 0)
-    expect_equal(res[13], 1)
-    expect_equal(res[14], 1)
-    expect_equal(res[15], 1)
-    expect_equal(res[16], 0)
-    expect_equal(res[17], 0)
-    expect_equal(res[18], 0)
-    expect_equal(res[19], 0)
-    expect_equal(res[20], 0)
-    expect_equal(res[21], 0)
-    expect_equal(res[22], 0)
-    expect_equal(res[23], 0)
-    expect_equal(res[24], 0)
-    expect_equal(res[25], 0)
-    expect_equal(res[26], 0)
-    expect_equal(res[27], 0)
-    expect_equal(res[28], 0)
-    expect_equal(res[29], 0)
-    expect_equal(res[30], 0)
+test_that("asFactorDS2 with fixed dummy variables", {
+    input <- c(2, 1, 3, 3, 3, 1, 2, 2, 1, 2)
 
+    res <- asFactorDS2("input", "1,2,3,4", TRUE, 1)
 
-    res.colnames <- colnames(res)
-
-    expect_equal(class(res.colnames), "character")
-    expect_length(res.colnames, 3)
-
-    expect_equal(res.colnames[1], "DV2")
-    expect_equal(res.colnames[2], "DV3")
-    expect_equal(res.colnames[3], "DV4")
+    expect_true(is.matrix(res))
+    expect_equal(dim(res), c(10L, 3L))
+    expect_equal(colnames(res), c("DV2", "DV3", "DV4"))
+    expect_equal(unname(res[, "DV2"]), c(1, 0, 0, 0, 0, 0, 1, 1, 0, 1))
+    expect_equal(unname(res[, "DV3"]), c(0, 0, 1, 1, 1, 0, 0, 0, 0, 0))
+    expect_equal(unname(res[, "DV4"]), rep(0, 10))
 })
 
-#
-# Done
-#
-
-# context("asFactorDS2::smk::shutdown")
-
-# context("asFactorDS2::smk::done")
+test_that("asFactorDS2 errors when serverside object does not exist", {
+    expect_error(asFactorDS2("nonexistent_object", "1,2", FALSE, NULL), regexp = "does not exist")
+})

tests/testthat/test-smk-asFactorSimpleDS.R

@@ -20,38 +20,17 @@ set.standard.disclosure.settings()
 # Tests
 #
 
-# context("asFactorSimpleDS::smk::simple")
 test_that("simple asFactorSimpleDS", {
-    input <- c(2.0, 1.0, 3.0, 3.0, 3.0, 1.0, 2.0, 2.0, 1.0, 2.0)
+    input <- c(2, 1, 3, 3, 3, 1, 2, 2, 1, 2)
 
     res <- asFactorSimpleDS("input")
 
     expect_equal(class(res), "factor")
     expect_length(res, 10)
-    expect_true(res[1] == "2")
-    expect_true(res[2] == "1")
-    expect_true(res[3] == "3")
-    expect_true(res[4] == "3")
-    expect_true(res[5] == "3")
-    expect_true(res[6] == "1")
-    expect_true(res[7] == "2")
-    expect_true(res[8] == "2")
-    expect_true(res[9] == "1")
-    expect_true(res[10] == "2")
-
-    res.levels <- levels(res)
-
-    expect_equal(class(res.levels), "character")
-    expect_length(res.levels, 3)
-    expect_equal(res.levels[1], "1")
-    expect_equal(res.levels[2], "2")
-    expect_equal(res.levels[3], "3")
+    expect_equal(levels(res), c("1", "2", "3"))
+    expect_equal(as.character(res), as.character(input))
 })
 
-#
-# Done
-#
-
-# context("asFactorSimpleDS::smk::shutdown")
-
-# context("asFactorSimpleDS::smk::done")
+test_that("asFactorSimpleDS errors when serverside object does not exist", {
+    expect_error(asFactorSimpleDS("nonexistent_object"), regexp = "does not exist")
+})