Refactor/perf batch 4

R/BooleDS.R

@@ -21,6 +21,7 @@
 #' input vector are all converted to 1 or 0 respectively.
 #' 
 #' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' 
 #' @return the levels of the input variable.
 #' @export
@@ -50,8 +51,15 @@ thr <- dsBase::listDisclosureSettingsDS()                               #
 
 ##########CHECK NOT LONG SPECIFIED VECTOR##############
 
-V1<-eval(parse(text=V1.name), envir = parent.frame())
-V2<-eval(parse(text=V2.name), envir = parent.frame())
+V1<-.loadServersideObject(V1.name)
+
+# V2 may be either a server-side object name or a literal scalar (e.g. "3", "-1")
+V2.numeric <- suppressWarnings(as.numeric(V2.name))
+if(!is.na(V2.numeric)){
+  V2 <- V2.numeric
+}else{
+  V2 <- .loadServersideObject(V2.name)
+}
 
 
 if(is.character(V1)){

R/cDS.R

@@ -3,28 +3,30 @@
 #' @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)
   #############################################################
-
-  x <-  unlist(objs)
+
+  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
   if(length(x) < nfilter.tab){

R/cbindDS.R

@@ -19,6 +19,7 @@
 #' of \code{ds.cbind} (or default name \code{cbind.newobj})
 #' which is written to the serverside. The output object is of class data.frame.
 #' @author Paul Burton and Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #' 
 cbindDS <- function(x.names.transmit=NULL, colnames.transmit=NULL){
@@ -28,11 +29,13 @@ cbindDS <- function(x.names.transmit=NULL, colnames.transmit=NULL){
 
   x.names.input <- x.names.transmit
   x.names.act1 <- unlist(strsplit(x.names.input, split=","))
-  x.names.act2 <- paste(x.names.act1, collapse=",")
-
-  eval.code.x.names <- paste0("data.frame(", x.names.act2, ")")
-
-  output.cbind <- eval(parse(text=eval.code.x.names), envir = parent.frame())
+
+  loaded.objects <- vector("list", length(x.names.act1))
+  for(i in seq_along(x.names.act1)) {
+    loaded.objects[[i]] <- .loadServersideObject(x.names.act1[i])
+  }
+
+  output.cbind <- do.call(data.frame, loaded.objects)
 
   colnames.input <- colnames.transmit
   colnames.act1 <- unlist(strsplit(colnames.input, split=","))

R/dataFrameDS.R

@@ -35,6 +35,7 @@
 #' serverside and named according to the <newobj> argument of the clientside
 #' function ds.dataFrame()
 #' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 dataFrameDS <- function(vectors=NULL, r.names=NULL, ch.rows=FALSE, ch.names=TRUE, clnames=NULL, strAsFactors=TRUE, completeCases=FALSE){
@@ -58,8 +59,12 @@ dataFrameDS <- function(vectors=NULL, r.names=NULL, ch.rows=FALSE, ch.names=TRUE
     r.names <- unlist(r.names)
   }
 
-  eval.code.vectors.names <- paste0("data.frame(", vectors, ")")
-  dtemp0 <- eval(parse(text=eval.code.vectors.names), envir = parent.frame())
+  vectors.names <- unlist(strsplit(vectors, split=","))
+  loaded.vectors <- vector("list", length(vectors.names))
+  for(i in seq_along(vectors.names)) {
+    loaded.vectors[[i]] <- .loadServersideObject(vectors.names[i])
+  }
+  dtemp0 <- do.call(data.frame, loaded.vectors)
 
   dtemp <- data.frame(dtemp0, row.names=r.names, check.rows=ch.rows, check.names=ch.names,
                     stringsAsFactors=strAsFactors)

R/dataFrameFillDS.R

@@ -17,11 +17,12 @@
 #' The classes supported are 'numeric', 'integer', 'character', 'factor' and 'logical'.
 #' @return Nothing is returned to the client. The generated object is written to the serverside.
 #' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #' 
 dataFrameFillDS <- function(df.name, allNames.transmit, class.vect.transmit, levels.vec.transmit){
 
-  data <- eval(parse(text=df.name), envir = parent.frame())
+  data <- .loadServersideObject(df.name)
 
   if(!is.null(allNames.transmit)){
     allNames <- unlist(strsplit(allNames.transmit, split=","))

R/dataFrameSortDS.R

@@ -30,6 +30,7 @@
 #' R environment as a data.frame named according to the <newobj> argument(or with
 #' default name 'dataframesort.newobj') if no name is specified
 #' @author Paul Burton, with critical error identification by
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' Leire Abarrategui-Martinez, for DataSHIELD Development Team, 2/4/2020
 #' @export
 #'
@@ -65,9 +66,8 @@ dataFrameSortDS <- function(df.name=NULL,sort.key.name=NULL,sort.descending,sort
     stop(studysideMessage, call. = FALSE)
   }
 
-  df.name.2 <- paste0("data.frame(",df.name,")")
-  df2sort   <- eval(parse(text=df.name.2), envir = parent.frame())
-  sort.key  <- eval(parse(text=sort.key.name), envir = parent.frame())
+  df2sort   <- data.frame(.loadServersideObject(df.name))
+  sort.key  <- .loadServersideObject(sort.key.name)
 
   # TYPE CHECK
   if(any(class(sort.key) %in% 'factor')){

R/dataFrameSubsetDS1.R

@@ -45,6 +45,7 @@
 #' In consequence, it records error messages as studysideMessages which can only be
 #' retrieved using ds.message
 #' @author Paul Burton
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 dataFrameSubsetDS1 <- function(df.name=NULL,V1.name=NULL,V2.name=NULL,Boolean.operator.n=NULL,keep.cols=NULL,rm.cols=NULL,keep.NAs=NULL){
@@ -157,8 +158,7 @@ if(sum(is.na(keep.code.n))>0){
     }
   }
 
-  df.name.2 <- paste0("data.frame(",df.name,")")
-  df2subset <- eval(parse(text=df.name.2), envir = parent.frame())
+  df2subset <- data.frame(.loadServersideObject(df.name))
 
   if(V1.name=="ONES"||V2.name=="ONES")
   {
@@ -175,8 +175,16 @@ if(sum(is.na(keep.code.n))>0){
       ONES<-V1
     }
   } else {
-     V1 <- eval(parse(text=V1.name), envir = parent.frame())
-     V2 <- eval(parse(text=V2.name), envir = parent.frame())
+     V1 <- tryCatch(.loadServersideObject(V1.name), error = function(e) {
+       numeric.val <- suppressWarnings(as.numeric(V1.name))
+       if (is.na(numeric.val)) stop(e)
+       numeric.val
+     })
+     V2 <- tryCatch(.loadServersideObject(V2.name), error = function(e) {
+       numeric.val <- suppressWarnings(as.numeric(V2.name))
+       if (is.na(numeric.val)) stop(e)
+       numeric.val
+     })
   }
 
   ##########CHECK APPROPRIATE CLASSES ##############

R/dataFrameSubsetDS2.R

@@ -54,6 +54,7 @@
 #' without problems no studysideMessage will have been saved and ds.message("newobj")
 #' will return the message: "ALL OK: there are no studysideMessage(s) on this datasource".
 #' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 dataFrameSubsetDS2<-function(df.name=NULL,V1.name=NULL, V2.name=NULL, Boolean.operator.n=NULL,keep.cols=NULL, rm.cols=NULL, keep.NAs=NULL){
@@ -177,8 +178,7 @@ if(!is.null(V2.name)){
 }
 
 
-   df.name.2<-paste0("data.frame(",df.name,")")
-   df2subset <- eval(parse(text=df.name.2), envir = parent.frame())
+   df2subset <- data.frame(.loadServersideObject(df.name))
 
    if(V1.name=="ONES"||V2.name=="ONES")
    {
@@ -195,8 +195,16 @@ if(!is.null(V2.name)){
        ONES<-V1
      }
    }else{
-     V1<-eval(parse(text=V1.name), envir = parent.frame())
-     V2<-eval(parse(text=V2.name), envir = parent.frame())
+     V1<-tryCatch(.loadServersideObject(V1.name), error = function(e) {
+       numeric.val <- suppressWarnings(as.numeric(V1.name))
+       if (is.na(numeric.val)) stop(e)
+       numeric.val
+     })
+     V2<-tryCatch(.loadServersideObject(V2.name), error = function(e) {
+       numeric.val <- suppressWarnings(as.numeric(V2.name))
+       if (is.na(numeric.val)) stop(e)
+       numeric.val
+     })
    }
 
 

R/listDS.R

@@ -3,17 +3,20 @@
 #' @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)
-
 }

R/mergeDS.R

@@ -51,6 +51,7 @@
 #' without problems no studysideMessage will have been saved and ds.message(<newobj>)
 #' will return the message: "ALL OK: there are no studysideMessage(s) on this datasource".
 #' @author Paul Burton, Demetris Avraam, for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 mergeDS <- function(x.name, y.name, by.x.names.transmit, by.y.names.transmit, all.x, all.y,
 			 sort, suffixes.transmit, no.dups, incomparables){
@@ -78,19 +79,12 @@ mergeDS <- function(x.name, y.name, by.x.names.transmit, by.y.names.transmit, al
   }
 
 	# activate data frame names
-  x.data.frame <- eval(parse(text=x.name), envir = parent.frame())
-  y.data.frame <- eval(parse(text=y.name), envir = parent.frame())
+  x.data.frame <- .loadServersideObject(x.name)
+  y.data.frame <- .loadServersideObject(y.name)
 
   # check data.frames are valid data.frames
-  if(!is.data.frame(x.data.frame)){
-    studysideMessage <- "Error: x.name must specify a data.frame"
-    stop(studysideMessage, call. = FALSE)
-  }
-
-  if(!is.data.frame(y.data.frame)){
-    studysideMessage <- "Error: y.name must specify a data.frame"
-    stop(studysideMessage, call. = FALSE)
-  }
+  .checkClass(obj = x.data.frame, obj_name = x.name, permitted_classes = c("data.frame"))
+  .checkClass(obj = y.data.frame, obj_name = y.name, permitted_classes = c("data.frame"))
 
   # manage by.x.names and by.y.names
 	# check text to be activated is not too long because of disclosure risk

R/rbindDS.R

@@ -32,6 +32,7 @@
 #' without problems no studysideMessage will have been saved and ds.message("<newobj>")
 #' will return the message: "ALL OK: there are no studysideMessage(s) on this datasource".
 #' @author Paul Burton for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 rbindDS<-function(x.names.transmit=NULL,colnames.transmit=NULL){
 
@@ -60,7 +61,7 @@ rbindDS<-function(x.names.transmit=NULL,colnames.transmit=NULL){
 
   rbind.matrix<-NULL
   for(k in numobj:1){
-    object.2.rbind<-eval(parse(text=x.names.active[k]), envir = parent.frame())
+    object.2.rbind<-.loadServersideObject(x.names.active[k])
 
     #coerce all input objects to data.matrix (like as.matrix but stays as numeric if numeric)
     object.2.rbind<-data.matrix(object.2.rbind)

R/recodeValuesDS.R

@@ -26,6 +26,7 @@
 #' initially specified in calling ds.recodeValues. The output object (the required
 #' recoded variable called <newobj> is written to the serverside.
 #' @author Paul Burton, Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 recodeValuesDS <- function(var.name.text=NULL, values2replace.text=NULL, new.values.text=NULL, missing=NULL){
@@ -59,7 +60,7 @@ recodeValuesDS <- function(var.name.text=NULL, values2replace.text=NULL, new.val
     stop(studysideMessage, call. = FALSE)
   }
 
-  var2recode <- eval(parse(text=var.name.text), envir = parent.frame())
+  var2recode <- .loadServersideObject(var.name.text)
 
   values2replace <- unlist(strsplit(values2replace.text, split=","))
   new.values <- unlist(strsplit(new.values.text, split=","))
@@ -68,13 +69,10 @@ recodeValuesDS <- function(var.name.text=NULL, values2replace.text=NULL, new.val
 
   # get the class of the input variable
   var.class <- class(var2recode)
-  
-  # if the class of the input variable is not factor, numeric, character or integer then 
+
+  # if the class of the input variable is not factor, numeric, character or integer then
   # stop and return an error message
-  if (!(var.class %in% c('factor', 'character', 'numeric', 'integer'))){
-    studysideMessage <- "Error: The variable to recode must be either a factor, a character, a numeric or an integer"
-    stop(studysideMessage, call. = FALSE)
-  }
+  .checkClass(obj = var2recode, obj_name = var.name.text, permitted_classes = c('factor', 'character', 'numeric', 'integer'))
 
   # recode using the recode function from the dplyr package 
   if (var.class == 'factor'){

R/repDS.R

@@ -88,6 +88,7 @@
 #' without problems no studysideMessage will have been saved and ds.message("newobj")
 #' will return the message: "ALL OK: there are no studysideMessage(s) on this datasource".
 #' @author Paul Burton for DataSHIELD Development Team, 14/10/2019
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 repDS <- function(x1.transmit, times.transmit, length.out.transmit, each.transmit,
@@ -175,7 +176,7 @@ if(source.x1=="serverside")
 {
 #x1.transmit is the name of a serverside vector or scalar
 
-x1.use<-eval(parse(text=x1.transmit), envir = parent.frame())
+x1.use<-.loadServersideObject(x1.transmit)
 }
 
 if(source.x1=="clientside")
@@ -276,7 +277,7 @@ else
 	{
 	#times.transmit is the name of a serverside vector or scalar
 
-	times.use<-eval(parse(text=times.transmit), envir = parent.frame())
+	times.use<-.loadServersideObject(times.transmit)
 	}
 
 	if(source.times=="clientside")
@@ -364,7 +365,7 @@ else
 	if(source.length.out=="serverside")
 	{
 	#length.out.transmit is the name of the serverside vector or scalar
-	length.out.temp<-eval(parse(text=length.out.transmit), envir = parent.frame())
+	length.out.temp<-.loadServersideObject(length.out.transmit)
 
 	arg.is.vector<-FALSE
 	if(length(length.out.temp)>=2)arg.is.vector<-TRUE
@@ -460,7 +461,7 @@ else
 	if(source.each=="serverside")
 	{
 	#each.transmit is the name of the serverside vector or scalar
-	each.use<-eval(parse(text=each.transmit), envir = parent.frame())
+	each.use<-.loadServersideObject(each.transmit)
 	}
 
 	if(source.each=="clientside")