Refactor: performance improvement batch 1

.Rbuildignore

@@ -12,3 +12,4 @@
 ^\.github$
 ^cran-comments\.md$
 ^pull_request_template$
+PULL_REQUEST_TEMPLATE.md

NAMESPACE

@@ -39,6 +39,7 @@ export(densityGridDS)
 export(dimDS)
 export(dmtC2SDS)
 export(elsplineDS)
+export(expDS)
 export(extractQuantilesDS1)
 export(extractQuantilesDS2)
 export(gamlssDS)
@@ -72,6 +73,7 @@ export(listDS)
 export(listDisclosureSettingsDS)
 export(lmerSLMADS.assign)
 export(lmerSLMADS2)
+export(logDS)
 export(lsDS)
 export(lsplineDS)
 export(matrixDS)

R/absDS.R

@@ -12,12 +12,10 @@
 #' @export
 #'
 absDS <- function(x) {
-  x.var <- eval(parse(text = x), envir = parent.frame())
+  x.var <- .loadServersideObject(x)
+  .checkClass(obj = x.var, obj_name = x, permitted_classes = c("numeric", "integer"))
 
-  # compute the absolute values of x
   out <- abs(x.var)
-
-  # assign the outcome to the data servers
   return(out)
 }
 # ASSIGN FUNCTION

R/asCharacterDS.R

@@ -13,7 +13,7 @@
 #' @export
 #'
 asCharacterDS <- function(x.name) {
-  x <- eval(parse(text = x.name), envir = parent.frame())
+  x <- .loadServersideObject(x.name)
 
   output <- as.character(x)
   return(output)

R/asDataMatrixDS.R

@@ -17,15 +17,9 @@
 #' @author Paul Burton for DataSHIELD Development Team
 #' @export
 asDataMatrixDS <- function(x.name) {
-  if (is.character(x.name)) {
-    x <- eval(parse(text = x.name), envir = parent.frame())
-  } else {
-    studysideMessage <- "ERROR: x.name must be specified as a character string"
-    stop(studysideMessage, call. = FALSE)
-  }
+  x <- .loadServersideObject(x.name)
 
   output <- data.matrix(x)
-
   return(output)
 }
 # ASSIGN FUNCTION

R/asIntegerDS.R

@@ -14,18 +14,10 @@
 #' @export
 #'
 asIntegerDS <- function(x.name){
-
-  if(is.character(x.name)){
-    x <- eval(parse(text=x.name), envir = parent.frame())
-  }else{
-    studysideMessage <- "ERROR: x.name must be specified as a character string"
-    stop(studysideMessage, call. = FALSE)
-  }
+  x <- .loadServersideObject(x.name)
 
   output <- as.integer(as.character(x))
-
   return(output)
-
 }
 # ASSIGN FUNCTION
 # asIntegerDS

R/asListDS.R

@@ -22,24 +22,10 @@
 #' @author Amadou Gaye, Paul Burton for DataSHIELD Development Team
 #' @export
 asListDS <- function (x.name, newobj){
+  x <- .loadServersideObject(x.name)
 
-    newobj.class <- NULL
-    if(is.character(x.name)){
-        active.text<-paste0(newobj,"<-as.list(",x.name,")")
-        eval(parse(text=active.text), envir = parent.frame())
-
-        active.text2<-paste0("class(",newobj,")")
-        assign("newobj.class", eval(parse(text=active.text2), envir = parent.frame()))
-
-    }else{
-        studysideMessage<-"ERROR: x.name must be specified as a character string"
-        stop(studysideMessage, call. = FALSE)
-    }
-
-    return.message<-paste0("New object <",newobj,"> created")
-    object.class.text<-paste0("Class of <",newobj,"> is '",newobj.class,"'")
-
-    return(list(return.message=return.message,class.of.newobj=object.class.text))
+  result <- as.list(x)
+  assign(newobj, result, envir = parent.frame())
 }
-# AGGEGATE FUNCTION
+# AGGREGATE FUNCTION
 # asListDS

R/asLogicalDS.R

@@ -1,32 +1,20 @@
-#' @title Coerces an R object into class numeric
-#' @description this function is based on the native R function \code{as.numeric}
+#' @title Coerces an R object into class logical
+#' @description this function is based on the native R function \code{as.logical}
 #' @details See help for function \code{as.logical} in native R
 #' @param x.name the name of the input object to be coerced to class
-#' numeric. Must be specified in inverted commas. But this argument is
+#' logical. Must be specified in inverted commas. But this argument is
 #' usually specified directly by <x.name> argument of the clientside function
-#' \code{ds.aslogical}
+#' \code{ds.asLogical}
 #' @return the object specified by the <newobj> argument (or its default name
 #' <x.name>.logic) which is written to the serverside. For further
 #' details see help on the clientside function \code{ds.asLogical}
 #' @author Amadou Gaye, Paul Burton for DataSHIELD Development Team
 #' @export
 asLogicalDS <- function (x.name){
-
-if(is.character(x.name)){
-	x<-eval(parse(text=x.name), envir = parent.frame())
-
-	}else{
-   studysideMessage<-"ERROR: x.name must be specified as a character string"
-   stop(studysideMessage, call. = FALSE)
-   }
-
-  if(!is.numeric(x)&&!is.integer(x)&&!is.character(x)&&!is.matrix(x)){
-  studysideMessage<-"ERROR: for ds.asLogical function, x.name must specify an input object of class numeric, integer, character or matrix"
-  stop(studysideMessage, call. = FALSE)
-  }
+  x <- .loadServersideObject(x.name)
+  .checkClass(obj = x, obj_name = x.name, permitted_classes = c("numeric", "integer", "character", "matrix"))
 
   output <- as.logical(x)
-
   return(output)
 }
 #ASSIGN FUNCTION

R/asMatrixDS.R

@@ -11,17 +11,9 @@
 #' @author Amadou Gaye, Paul Burton for DataSHIELD Development Team
 #' @export
 asMatrixDS <- function (x.name){
-
-if(is.character(x.name)){
-	x<-eval(parse(text=x.name), envir = parent.frame())
-
-	}else{
-   studysideMessage<-"ERROR: x.name must be specified as a character string"
-   stop(studysideMessage, call. = FALSE)
-   }
+  x <- .loadServersideObject(x.name)
 
   output <- as.matrix(x)
-
   return(output)
 }
 #ASSIGN FUNCTION

R/asNumericDS.R

@@ -14,13 +14,7 @@
 #' @export
 #'
 asNumericDS <- function(x.name){
-
-  if(is.character(x.name)){
-    x <- eval(parse(text=x.name), envir = parent.frame())
-  }else{
-    studysideMessage <- "ERROR: x.name must be specified as a character string"
-    stop(studysideMessage, call. = FALSE)
-  }
+  x <- .loadServersideObject(x.name)
 
   # Check that it doesn't match any non-number
   numbers_only <- function(vec) !grepl("\\D", vec)
@@ -36,7 +30,6 @@ asNumericDS <- function(x.name){
   }
 
   return(output)
-
 }
 # ASSIGN FUNCTION
 # asNumericDS

R/expDS.R

@@ -0,0 +1,21 @@
+#'
+#' @title Computes the exponential values of the input variable
+#' @description This function is similar to R function \code{exp}.
+#' @details The function computes the exponential values of an input numeric
+#' or integer vector.
+#' @param x a string character, the name of a numeric or integer vector
+#' @return the object specified by the \code{newobj} argument
+#' of \code{ds.exp} (or default name \code{exp.newobj})
+#' which is written to the serverside. The output object is of class numeric.
+#' @author DataSHIELD Development Team
+#' @export
+#'
+expDS <- function(x) {
+  x.var <- .loadServersideObject(x)
+  .checkClass(obj = x.var, obj_name = x, permitted_classes = c("numeric", "integer"))
+
+  out <- exp(x.var)
+  return(out)
+}
+# ASSIGN FUNCTION
+# expDS

R/logDS.R

@@ -0,0 +1,23 @@
+#'
+#' @title Computes the logarithm values of the input variable
+#' @description This function is similar to R function \code{log}.
+#' @details The function computes the logarithm values of an input numeric
+#' or integer vector. By default natural logarithms are computed.
+#' @param x a string character, the name of a numeric or integer vector
+#' @param base a positive number, the base for which logarithms are computed.
+#' Default \code{exp(1)}.
+#' @return the object specified by the \code{newobj} argument
+#' of \code{ds.log} (or default name \code{log.newobj})
+#' which is written to the serverside. The output object is of class numeric.
+#' @author DataSHIELD Development Team
+#' @export
+#'
+logDS <- function(x, base=exp(1)) {
+  x.var <- .loadServersideObject(x)
+  .checkClass(obj = x.var, obj_name = x, permitted_classes = c("numeric", "integer"))
+
+  out <- log(x.var, base = base)
+  return(out)
+}
+# ASSIGN FUNCTION
+# logDS

R/sqrtDS.R

@@ -12,15 +12,11 @@
 #' @export
 #'
 sqrtDS <- function(x){
+  x.var <- .loadServersideObject(x)
+  .checkClass(obj = x.var, obj_name = x, permitted_classes = c("numeric", "integer"))
 
-  x.var <- eval(parse(text=x), envir = parent.frame())
-
-  # compute the square root values of x
   out <- sqrt(x.var)
-
-  # assign the outcome to the data servers
   return(out)
-
 }
 # ASSIGN FUNCTION
 # sqrtDS

R/utils.R

@@ -1,18 +1,43 @@
 #' Load a Server-Side Object by Name
 #'
-#' Evaluates a character string referring to an object name and returns the corresponding
-#' object from the parent environment. If the object does not exist, an error is raised.
+#' Retrieves a server-side object using `get()`. Supports both simple object
+#' names (e.g. "D") and `$` column access (e.g. "D$LAB_TSC"). When `$` is
+#' present, the object is retrieved first, then the named column is extracted
+#' using `[[`.
 #'
-#' @param x A character string naming the object to be retrieved.
-#' @return The evaluated R object referred to by `x`.
+#' @param x A character string naming the object, optionally with "$column" syntax.
+#' @return The retrieved R object, or the specified column if `$` syntax is used.
 #' @noRd
 .loadServersideObject <- function(x) {
-  tryCatch(
-    get(x, envir = parent.frame(2)),
-    error = function(e) {
-      stop("The server-side object", " '", x, "' ", "does not exist")
-    }
+  if (!is.character(x) || length(x) != 1) {
+    stop("The input must be a single character string", call. = FALSE)
+  }
+
+  env <- parent.frame(2)
+
+  hasColumn <- grepl("$", x, fixed = TRUE)
+
+  if(hasColumn) {
+    parts <- unlist(strsplit(x, "$", fixed = TRUE))
+    obj_name <- parts[1]
+    col_name <- parts[2]
+  } else {
+    obj_name <- x
+  }
+
+  obj <- tryCatch(
+    get(obj_name, envir = env),
+    error = function(e) stop("The server-side object '", x, "' does not exist")
   )
+
+  if (hasColumn) {
+    obj <- obj[[col_name]]
+    if (is.null(obj)) {
+      stop("Column '", col_name, "' not found in '", obj_name, "'", call. = FALSE)
+    }
+  }
+
+  return(obj)
 }
 
 #' Check Class of a Server-Side Object

inst/DATASHIELD

@@ -149,8 +149,8 @@ AssignMethods:
     c=dsBase::vectorDS,
     complete.cases=stats::complete.cases,
     list=base::list,
-    exp=base::exp,
-    log=base::log,
+    expDS,
+    logDS,
     sqrt=base::sqrt,
     abs=base::abs,
     sin=base::sin,