Merge pull request #470 from datashield/refactor/perf-batch-2

Refactor/perf batch 2

Author: timcadman

R/classDS.R

@@ -5,18 +5,13 @@
 #' @param x a string character, the name of an object
 #' @return the class of the input object
 #' @author Stuart Wheater, for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 classDS <- function(x){
-
-  x.val <- eval(parse(text=x), envir = parent.frame())
-
-  # find the class of the input object
+  x.val <- .loadServersideObject(x)
   out <- class(x.val)
-
-  # return the class
   return(out)
-
 }
 #AGGREGATE FUNCTION
 # classDS

R/completeCasesDS.R

@@ -31,6 +31,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
 #' 
 completeCasesDS <- function(x1.transmit){
@@ -111,10 +112,9 @@ completeCasesDS <- function(x1.transmit){
   }
 
   #Activate target object
-  #x1.transmit is the name of a serverside data.frame, matrix or vector
-  x1.use <- eval(parse(text=x1.transmit), envir = parent.frame())
+  x1.use <- .loadServersideObject(x1.transmit)
   complete.rows <- stats::complete.cases(x1.use)
-  
+
   if(is.matrix(x1.use) || is.data.frame(x1.use)){
     output.object <- x1.use[complete.rows,]
   }else if(is.atomic(x1.use) || is.factor(x1.use)){

R/dimDS.R

@@ -3,20 +3,16 @@
 #' @description This function is similar to R function \code{dim}.
 #' @details The function returns the dimension of the input dataframe or matrix
 #' @param x a string character, the name of a dataframe or matrix
-#' @return the dimension of the input object
+#' @return a list with two elements: \code{dim} (the dimension of the input object)
+#'   and \code{class} (the class of the input object, for client-side consistency checking)
 #' @author Demetris Avraam, for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 dimDS <- function(x){
-
-  x.var <- eval(parse(text=x), envir = parent.frame())
-
-  # find the dim of the input dataframe or matrix
-  out <- dim(x.var)
-
-  # return the dimension
-  return(out)
-
+  x.val <- .loadServersideObject(x)
+  .checkClass(obj = x.val, obj_name = x, permitted_classes = c("data.frame", "matrix"))
+  list(dim = dim(x.val), class = class(x.val))
 }
 #AGGREGATE FUNCTION
 # dimDS

R/isNaDS.R

@@ -1,19 +1,20 @@
-#' 
-#' @title Checks if a vector is empty 
-#' @description this function is similar to R function \code{is.na} but instead of a vector 
+#'
+#' @title Checks if a vector is empty
+#' @description this function is similar to R function \code{is.na} but instead of a vector
 #' of booleans it returns just one boolean to tell if all the element are missing values.
-#' @param xvect a numerical or character vector
-#' @return the integer '1' if the vector contains on NAs and '0'  otherwise
+#' @param x a character string, the name of a server-side vector
+#' @return a list with two elements: \code{is.na} (TRUE if the vector contains
+#'   only NAs, FALSE otherwise) and \code{class} (the class of the input object,
+#'   for client-side consistency checking)
 #' @author Gaye, A.
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
-isNaDS <- function(xvect){
-  
+isNaDS <- function(x){
+  xvect <- .loadServersideObject(x)
+  .checkClass(obj = xvect, obj_name = x, permitted_classes = c("character", "factor", "integer", "logical", "numeric", "data.frame", "matrix"))
   out <- is.na(xvect)
   total <- sum(out, na.rm=TRUE)
-  if(total==(1*length(out))){
-    return(TRUE)
-  }else{
-    return(FALSE)
-  }
+  is_na <- total == (1 * length(out))
+  list(is.na = is_na, class = class(xvect))
 }

R/lengthDS.R

@@ -3,20 +3,17 @@
 #' @description This function is similar to R function \code{length}.
 #' @details The function returns the length of the input vector or list.
 #' @param x a string character, the name of a vector or list
-#' @return a numeric, the number of elements of the input vector or list.
+#' @return a list with two elements: \code{length} (the number of elements of the input
+#'   vector or list) and \code{class} (the class of the input object, for client-side
+#'   consistency checking)
 #' @author Demetris Avraam, for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 lengthDS <- function(x){
-
-  x.var <- eval(parse(text=x), envir = parent.frame())
-
-  # find the length of the input vector or list
-  out <- length(x.var)
-
-  # return output length
-  return(out)
-
+  x.val <- .loadServersideObject(x)
+  .checkClass(obj = x.val, obj_name = x, permitted_classes = c("character", "factor", "integer", "logical", "numeric", "list", "data.frame"))
+  list(length = length(x.val), class = class(x.val))
 }
 #AGGREGATE FUNCTION
 # lengthDS

R/levelsDS.R

@@ -3,42 +3,36 @@
 #' @description This function is similar to R function \code{levels}.
 #' @details The function returns the levels of the input vector or list.
 #' @param x a factor vector
-#' @return a list, the factor levels present in the vector
+#' @return a list with one element: \code{Levels} (the factor levels present
+#'   in the vector)
 #' @author Alex Westerberg, for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 levelsDS <- function(x){
-  
+
+  x.val <- .loadServersideObject(x)
+  .checkClass(obj = x.val, obj_name = x, permitted_classes = "factor")
+
   # Check Permissive Privacy Control Level.
   dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot'))
-  
+
   ##################################################################
   #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)                #
-  #nfilter.stringShort <- as.numeric(thr$nfilter.stringShort)      #
-  #nfilter.kNN <- as.numeric(thr$nfilter.kNN)                      #
-  #nfilter.noise <- as.numeric(thr$nfilter.noise)                  #
   nfilter.levels.density <- as.numeric(thr$nfilter.levels.density) #
-  #nfilter.levels.max <- as.numeric(thr$nfilter.levels.max)        #
   ##################################################################
-  
+
   # find the levels of the input vector
-  out <- levels(x)
-  input.length     <- length(x)
+  out <- levels(x.val)
+  input.length     <- length(x.val)
   output.length    <- length(out)
-  studysideMessage <- "VALID ANALYSIS"
 
   if((input.length * nfilter.levels.density) < output.length) {
-    out <- NA
-    studysideMessage <- "FAILED: Result length less than nfilter.levels.density of input length."
-    stop(studysideMessage, call. = FALSE)
+    stop("FAILED: Result length less than nfilter.levels.density of input length.", call. = FALSE)
   }
-  
-  out.obj <- list(Levels=out,ValidityMessage=studysideMessage)
+
+  out.obj <- list(Levels=out)
   return(out.obj)
 }
 #AGGREGATE FUNCTION

R/namesDS.R

@@ -16,6 +16,7 @@
 #' @return \code{namesDS} returns to the client-side the names
 #' of a list object stored on the server-side.
 #' @author Amadou Gaye, updated by Paul Burton 25/06/2020
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 namesDS <- function(xname.transmit){
@@ -50,14 +51,14 @@ nfilter.stringShort<-as.numeric(thr$nfilter.stringShort)                #
     stop(studysideMessage, call. = FALSE)
   }
 
-  list.obj<-eval(parse(text=xname.transmit), envir = parent.frame())
-
-  trace.message<-class(list.obj)
-
+  list.obj <- .loadServersideObject(xname.transmit)
 
   if(!is.list(list.obj)){
-    error.message <- "The input object is not of class <list>"
-    stop(paste0(error.message,trace.message), call. = FALSE)
+    stop(
+      "The input object is not of class <list>. '", xname.transmit, "' is type ",
+      paste(class(list.obj), collapse = ", "),
+      call. = FALSE
+    )
   }
 
 

R/numNaDS.R

@@ -1,15 +1,17 @@
-#' 
+#'
 #' @title Counts the number of missing values
-#' @description this function just counts the number of missing entries 
-#' in a vector. 
-#' @param xvect a vector
-#' @return an integer, the number of missing values
+#' @description this function just counts the number of missing entries
+#' in a vector.
+#' @param x a character string, the name of a server-side vector
+#' @return a list with two elements: \code{numNA} (an integer, the number of
+#'   missing values) and \code{class} (the class of the input object, for
+#'   client-side consistency checking)
 #' @author Gaye, A.
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
-numNaDS <- function(xvect){
-  
+numNaDS <- function(x){
+  xvect <- .loadServersideObject(x)
   out <- length(which(is.na(xvect)))
-  return (out)
-  
+  list(numNA = out, class = class(xvect))
 }

R/uniqueDS.R

@@ -6,26 +6,12 @@
 #' @return the object specified by the \code{newobj} argument
 #' which is written to the server-side.
 #' @author Stuart Wheater for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 uniqueDS <- function(x.name.transmit = NULL){
-    # Check 'x.name.transmit' contains a name
-    if (is.null(x.name.transmit))
-        stop("Variable's name can't be NULL", call. = FALSE)
-
-    if ((! is.character(x.name.transmit)) || (length(x.name.transmit) != 1))
-        stop("Variable's name isn't a single character vector", call. = FALSE)
-
-    # Check object exists
-    x.value <- eval(parse(text=x.name.transmit), envir = parent.frame())
-
-    if (is.null(x.value))
-        stop("Variable can't be NULL", call. = FALSE)
-
-    # Compute the unique's value
+    x.value <- .loadServersideObject(x.name.transmit)
     out <- base::unique(x.value)
-
-    # assign the outcome to the data servers
     return(out)
 }
 # ASSIGN FUNCTION