Perf batch 1 v2

DESCRIPTION

@@ -71,7 +71,7 @@ Imports:
     gamlss,
     gamlss.dist,
     mice,
-    childsds, 
+    childsds,
     glue
 Suggests:
     spelling,

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/asFactorSimpleDS.R

@@ -16,7 +16,12 @@
 #'
 asFactorSimpleDS <- function(input.var.name=NULL){
 
-    input.var <- eval(parse(text=input.var.name), envir = parent.frame())
+    input.var <- .loadServersideObject(input.var.name)
+    .checkClass(
+        obj = input.var,
+        obj_name = input.var.name,
+        permitted_classes = c("numeric", "integer", "character", "factor")
+    )
 
     factor.obj <- factor(input.var)
 
@@ -27,4 +32,3 @@ asFactorSimpleDS <- function(input.var.name=NULL){
 
 #ASSIGN FUNCTION
 # asFactorSimpleDS
-

R/asIntegerDS.R

@@ -1,4 +1,4 @@
-#' 
+#'
 #' @title Coerces an R object into class integer
 #' @description This function is based on the native R function \code{as.integer}.
 #' @details See help for function \code{as.integer} in native R, and details section
@@ -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,17 @@
 #' @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())
+  result <- as.list(x)
+  assign(newobj, result, envir = parent.frame())
 
-        active.text2<-paste0("class(",newobj,")")
-        assign("newobj.class", eval(parse(text=active.text2), envir = parent.frame()))
+  newobj.class <- class(result)
 
-    }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.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))
+  return(list(return.message = return.message, class.of.newobj = object.class.text))
 }
-# 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

@@ -1,4 +1,4 @@
-#' 
+#'
 #' @title Coerces an R object into class numeric
 #' @description This function is based on the native R function \code{as.numeric}.
 #' @details See help for function \code{as.numeric} in native R, and details section
@@ -14,29 +14,22 @@
 #' @export
 #'
 asNumericDS <- function(x.name){
+  x <- .loadServersideObject(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)
-  }
-
   # Check that it doesn't match any non-number
   numbers_only <- function(vec) !grepl("\\D", vec)
-  
+
   logical <- numbers_only(x)
-  
+
   if((is.factor(x) & any(logical==FALSE)==FALSE) | (is.character(x) & any(logical==FALSE)==FALSE)){
     output <- as.numeric(as.character(x))
   }else if((is.factor(x) & any(logical==FALSE)==TRUE) | (is.character(x) & any(logical==FALSE)==TRUE)){
     output <- as.numeric(as.factor(x))
   }else{
     output <- as.numeric(x)
   }
-
-  return(output)
 
+  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

@@ -6,21 +6,17 @@
 #' @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.sqrt} (or default name \code{sqrt.newobj})
-#' which is written to the server-side. The output object is of class numeric 
+#' which is written to the server-side. The output object is of class numeric
 #' or integer.
 #' @author Demetris Avraam for DataSHIELD Development Team
 #' @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,29 @@
 #' 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()`, supporting both simple names
+#' (e.g. "D") and column access syntax (e.g. "D$LAB_TSC").
 #'
-#' @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.
 #' @noRd
 .loadServersideObject <- function(x) {
-  tryCatch(
-    get(x, envir = parent.frame(2)),
-    error = function(e) {
-      stop("The server-side object", " '", x, "' ", "does not exist")
-    }
+  env <- parent.frame(2)
+
+  parts <- unlist(strsplit(x, "$", fixed = TRUE))
+  obj_name <- parts[1]
+  has_column <- length(parts) > 1
+
+  obj <- tryCatch(
+    get(obj_name, envir = env),
+    error = function(e) stop("The server-side object '", x, "' does not exist")
   )
+
+  if (has_column) {
+    column_name <- parts[2]
+    obj <- obj[[column_name]]
+  }
+
+  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,