Refactor batch 2

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

@@ -8,15 +8,9 @@
 #' @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

@@ -111,10 +111,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,15 @@
 #' @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
 #' @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/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/isNaDS.R

@@ -1,17 +1,18 @@
-#' 
-#' @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 TRUE if the vector contains only NAs, FALSE otherwise
 #' @author Gaye, A.
 #' @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))){
+  if(total == (1 * length(out))){
     return(TRUE)
   }else{
     return(FALSE)

R/lengthDS.R

@@ -3,20 +3,16 @@
 #' @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
 #' @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"))
+  list(length = length(x.val), class = class(x.val))
 }
 #AGGREGATE FUNCTION
 # lengthDS

R/levelsDS.R

@@ -8,27 +8,22 @@
 #' @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"
 

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