Refactor/perf batch 8

R/rBinomDS.R

@@ -24,6 +24,7 @@
 #' also returns a vector reporting the length of the pseudorandom vector
 #' created in each source.
 #' @author Paul Burton for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 rBinomDS<-function (n, size = 1, prob = 0.5){
 
@@ -34,13 +35,11 @@ rBinomDS<-function (n, size = 1, prob = 0.5){
 #first convert their names into the corresponding active vectors
 
 	if(is.character(size)){
-	command.text<-size
-	size<-eval(parse(text=command.text), envir = parent.frame())
+	size<-.loadServersideObject(size)
 	}
 
 	if(is.character(prob)){
-	command.text<-prob
-	prob<-eval(parse(text=command.text), envir = parent.frame())
+	prob<-.loadServersideObject(prob)
 	}
 
 	stats::rbinom(n, size=size, prob=prob)

R/rNormDS.R

@@ -29,6 +29,7 @@
 #' also returns a vector reporting the length of the pseudorandom vector
 #' created in each source.
 #' @author Paul Burton for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 rNormDS<-function (n, mean = 0, sd = 1, force.output.to.k.decimal.places=9){
 
@@ -39,13 +40,11 @@ rNormDS<-function (n, mean = 0, sd = 1, force.output.to.k.decimal.places=9){
 #first convert their names into the corresponding active vectors
 
 	if(is.character(mean)){
-	command.text<-mean
-	mean<-eval(parse(text=command.text), envir = parent.frame())
+	mean<-.loadServersideObject(mean)
 	}
 
 	if(is.character(sd)){
-	command.text<-sd
-	sd<-eval(parse(text=command.text), envir = parent.frame())
+	sd<-.loadServersideObject(sd)
 	}
 
 	random.number.vector<-stats::rnorm(n, mean=mean, sd=sd)

R/rPoisDS.R

@@ -20,6 +20,7 @@
 #' also returns a vector reporting the length of the pseudorandom vector
 #' created in each source.
 #' @author Paul Burton for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 rPoisDS<-function (n, lambda = 1){
 
@@ -30,8 +31,7 @@ rPoisDS<-function (n, lambda = 1){
 #first convert its name into the corresponding active vectors
 
 	if(is.character(lambda)){
-	command.text<-lambda
-	lambda<-eval(parse(text=command.text), envir = parent.frame())
+	lambda<-.loadServersideObject(lambda)
 	}
 
 	stats::rpois(n, lambda=lambda)

R/rUnifDS.R

@@ -29,6 +29,7 @@
 #' also returns a vector reporting the length of the pseudorandom vector
 #' created in each source.
 #' @author Paul Burton for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 rUnifDS<-function (n, min = 0, max = 1, force.output.to.k.decimal.places=9){
 
@@ -39,13 +40,11 @@ rUnifDS<-function (n, min = 0, max = 1, force.output.to.k.decimal.places=9){
 #first convert their names into the corresponding active vectors
 
 	if(is.character(min)){
-	command.text<-min
-	min<-eval(parse(text=command.text), envir = parent.frame())
+	min<-.loadServersideObject(min)
 	}
 
 	if(is.character(max)){
-	command.text<-max
-	max<-eval(parse(text=command.text), envir = parent.frame())
+	max<-.loadServersideObject(max)
 	}
 
 	random.number.vector<-stats::runif(n, min=min, max=max)

R/sampleDS.R

@@ -30,6 +30,7 @@
 #' 'newobj.sample') which is written to the serverside. For further details see 
 #' help for ds.sample and native R help for sample().
 #' @author Paul Burton, for DataSHIELD Development Team, 15/4/2020
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 sampleDS <- function(x.transmit, size.transmit, replace.transmit=NULL, prob.transmit=NULL){
 
@@ -82,7 +83,7 @@ sampleDS <- function(x.transmit, size.transmit, replace.transmit=NULL, prob.tran
   #Activate <x> and <prob> if they are character strings
   if(is.character(x.transmit))
   {
-      x.active<-eval(parse(text=x.transmit), envir = parent.frame())
+      x.active<-.loadServersideObject(x.transmit)
 
   	if(is.data.frame(x.active)||is.matrix(x.active))
   		{
@@ -152,7 +153,7 @@ sampleDS <- function(x.transmit, size.transmit, replace.transmit=NULL, prob.tran
   prob.active<-NULL
   if(is.character(prob.transmit))
   {
-      prob.active<-eval(parse(text=prob.transmit), envir = parent.frame())
+      prob.active<-.loadServersideObject(prob.transmit)
   }
 
   #Check size <= length(x.active) if replace.transmit==FALSE

R/setSeedDS.R

@@ -32,13 +32,18 @@
 #' .Random.seed on each data source that is the true current state of the
 #' random seed in each source.
 #' @author Paul Burton for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 setSeedDS<-function (seedtext=NULL, kind = NULL, normal.kind = NULL)
 {
     # Check Permissive Privacy Control Level.
     dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'avocado'))
 
-    seed<-eval(parse(text=seedtext), envir = parent.frame())
+    if(is.null(seedtext) || seedtext == "NULL"){
+        seed <- NULL
+    } else {
+        seed <- as.integer(seedtext)
+    }
     set.seed(seed,kind,normal.kind)
     return(list(seed.as.set=.Random.seed))
 }

tests/testthat/test-smk-rBinomDS.R

@@ -15,6 +15,8 @@
 
 # context("rBinomDS::smk::setup")
 
+set.standard.disclosure.settings()
+
 #
 # Tests
 #
@@ -58,6 +60,14 @@ test_that("simple rBinomDS, direct", {
     expect_true(res[8] >= 0)
 })
 
+test_that("rBinomDS fails when size references nonexistent object", {
+    expect_error(rBinomDS(8, "nonexistent_obj", 0.5), "does not exist")
+})
+
+test_that("rBinomDS fails when prob references nonexistent object", {
+    expect_error(rBinomDS(8, 1, "nonexistent_obj"), "does not exist")
+})
+
 #
 # Done
 #

tests/testthat/test-smk-rNormDS.R

@@ -15,6 +15,8 @@
 
 # context("rNormDS::smk::setup")
 
+set.standard.disclosure.settings()
+
 #
 # Tests
 #
@@ -58,6 +60,14 @@ test_that("simple rNormDS, direct", {
     expect_true(res[8] >= 0)
 })
 
+test_that("rNormDS fails when mean references nonexistent object", {
+    expect_error(rNormDS(8, "nonexistent_obj", 1, 9), "does not exist")
+})
+
+test_that("rNormDS fails when sd references nonexistent object", {
+    expect_error(rNormDS(8, 0, "nonexistent_obj", 9), "does not exist")
+})
+
 #
 # Done
 #

tests/testthat/test-smk-rPoisDS.R

@@ -15,6 +15,8 @@
 
 # context("rPoisDS::smk::setup")
 
+set.standard.disclosure.settings()
+
 #
 # Tests
 #
@@ -56,6 +58,10 @@ test_that("simple rPoisDS, direct", {
     expect_true(res[8] >= 0)
 })
 
+test_that("rPoisDS fails when lambda references nonexistent object", {
+    expect_error(rPoisDS(8, "nonexistent_obj"), "does not exist")
+})
+
 #
 # Done
 #

tests/testthat/test-smk-rUnifDS.R

@@ -15,6 +15,8 @@
 
 # context("rUnifDS::smk::setup")
 
+set.standard.disclosure.settings()
+
 #
 # Tests
 #
@@ -58,6 +60,14 @@ test_that("simple rUnifDS, direct", {
     expect_true(res[8] >= 0)
 })
 
+test_that("rUnifDS fails when min references nonexistent object", {
+    expect_error(rUnifDS(8, "nonexistent_obj", 1, 9), "does not exist")
+})
+
+test_that("rUnifDS fails when max references nonexistent object", {
+    expect_error(rUnifDS(8, 0, "nonexistent_obj", 9), "does not exist")
+})
+
 #
 # Done
 #

tests/testthat/test-smk-sampleDS.R

@@ -46,6 +46,16 @@ test_that("simple sampleDS", {
     expect_length(res$sampling.order, 16)
 })
 
+test_that("sampleDS fails when x references nonexistent object", {
+    expect_error(sampleDS("nonexistent_obj", 5, FALSE, NULL), "does not exist")
+})
+
+test_that("sampleDS fails when prob references nonexistent object", {
+    x <- c(1:32)
+
+    expect_error(sampleDS("x", 5, FALSE, "nonexistent_obj"), "does not exist")
+})
+
 #
 # Done
 #

tests/testthat/test-smk-setSeedDS.R

@@ -15,6 +15,8 @@
 
 # context("setSeedDS::smk::setup")
 
+set.standard.disclosure.settings()
+
 #
 # Tests
 #
@@ -32,6 +34,14 @@ test_that("simple setSeedDS", {
     expect_length(res$seed.as.set, 626)
 })
 
+test_that("setSeedDS works with numeric string", {
+    res <- setSeedDS("42", NULL, NULL)
+
+    expect_equal(class(res), "list")
+    expect_length(res, 1)
+    expect_length(res$seed.as.set, 626)
+})
+
 #
 # Done
 #