V7.0 dev

DESCRIPTION

@@ -79,7 +79,7 @@ Imports:
 Suggests:
     spelling,
     testthat (>= 3.0.0)
-RoxygenNote: 8.0.0
 Encoding: UTF-8
 Language: en-GB
 Config/testthat/edition: 3
+Config/roxygen2/version: 8.1.0

NAMESPACE

@@ -146,17 +146,27 @@ import(dplyr)
 import(gamlss)
 import(gamlss.dist)
 import(mice)
-importFrom(dplyr,"%>%")
-importFrom(dplyr,across)
-importFrom(dplyr,mutate)
-importFrom(dplyr,select)
-importFrom(gamlss.dist,pST3)
-importFrom(gamlss.dist,qST3)
-importFrom(glue,glue)
-importFrom(glue,glue_collapse)
-importFrom(purrr,imap)
-importFrom(purrr,map)
-importFrom(purrr,set_names)
+importFrom(dplyr,
+  "%>%",
+  across,
+  mutate,
+  select
+)
+importFrom(gamlss.dist,
+  pST3,
+  qST3
+)
+importFrom(glue,
+  glue,
+  glue_collapse
+)
+importFrom(purrr,
+  imap,
+  map,
+  set_names
+)
 importFrom(tibble,as_tibble)
-importFrom(tidyselect,all_of)
-importFrom(tidyselect,peek_vars)
+importFrom(tidyselect,
+  all_of,
+  peek_vars
+)

R/asFactorDS1.R

@@ -7,6 +7,7 @@
 #' are of type character.
 #' @param input.var.name the name of the variable that is to be converted to a factor.
 #' @return the levels of the input variable.
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 asFactorDS1 <- function(input.var.name=NULL){
@@ -24,7 +25,7 @@ asFactorDS1 <- function(input.var.name=NULL){
   nfilter.levels.max <- as.numeric(thr$nfilter.levels.max)         #
   ##################################################################
 
-  input.var <- eval(parse(text=input.var.name), envir = parent.frame())
+  input.var <- .loadServersideObject(input.var.name)
   factor.levels.present.in.source <- levels(factor(input.var))
   num.levels<-length(factor.levels.present.in.source)
 

R/asFactorDS2.R

@@ -15,11 +15,12 @@
 #' @param baseline.level a number indicating the baseline level to be used in the creation of the
 #' matrix of dummy variables.
 #' @return an object of class factor
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 asFactorDS2 <- function(input.var.name=NULL, all.unique.levels.transmit=NULL, fixed.dummy.vars=NULL, baseline.level=NULL){
 
-  input.var <- eval(parse(text=input.var.name), envir = parent.frame())
+  input.var <- .loadServersideObject(input.var.name)
 
   code.input <- all.unique.levels.transmit
   code.c <- unlist(strsplit(code.input, split=","))

R/asFactorSimpleDS.R

@@ -12,11 +12,12 @@
 #' of these things you will have to use the ds.asFactor function.
 #' @param input.var.name the name of the variable that is to be converted to a factor.
 #' @return an object of class factor
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 asFactorSimpleDS <- function(input.var.name=NULL){
 
-    input.var <- eval(parse(text=input.var.name), envir = parent.frame())
+    input.var <- .loadServersideObject(input.var.name)
 
     factor.obj <- factor(input.var)
 

R/boxPlotGGDS.R

@@ -5,7 +5,7 @@
 #' parameters are passed. There are three different cases depending if there are grouping variables. 
 #' The outliers are also removed from the graphical parameters.
 #'
-#' @param data_table \code{data frame} Table that holds the information to be plotted, arranged as: \cr
+#' @param data_table.name \code{character} Name of a server-side data frame that holds the information to be plotted, arranged as: \cr
 #' 
 #'  Column 'x': Names on the X axis of the boxplot, aka variables to plot \cr
 #'  Column 'value': Values for that variable (raw data of columns rbinded) \cr
@@ -18,11 +18,14 @@
 #' @return \code{list} with: \cr
 #' -\code{data frame} Geometrical parameters (identity stats of ggplot) \cr
 #' -\code{character} Type of plot (single_group, double_group or no_group) \cr
-#' 
+#'
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 
-boxPlotGGDS <- function(data_table, group = NULL, group2 = NULL){
-
+boxPlotGGDS <- function(data_table.name, group = NULL, group2 = NULL){
+
+  data_table <- .loadServersideObject(data_table.name)
+
   ###################################################################
   # MODULE 1: CAPTURE THE subset filter SETTINGS                    #
   thr <- dsBase::listDisclosureSettingsDS()                         #

R/boxPlotGG_data_TreatmentDS.R

@@ -1,42 +1,46 @@
 #' @title Arrange data frame to pass it to the boxplot function
 #'
-#' @param table \code{data frame} Table that holds the information to be plotted later
+#' @param table.name \code{character} Name of a server-side data frame that holds the information to be plotted later
 #' @param variables \code{character vector} Name of the column(s) of the data frame to include on the boxplot
-#' @param group \code{character} (default \code{NULL}) Name of the first grouping variable. 
-#' @param group2 \code{character} (default \code{NULL}) Name of the second grouping variable. 
+#' @param group \code{character} (default \code{NULL}) Name of the first grouping variable.
+#' @param group2 \code{character} (default \code{NULL}) Name of the second grouping variable.
 #'
 #' @return \code{data frame} with the following structure: \cr
-#' 
+#'
 #'  Column 'x': Names on the X axis of the boxplot, aka variables to plot \cr
 #'  Column 'value': Values for that variable (raw data of columns rbinded) \cr
 #'  Column 'group': (Optional) Values of the grouping variable \cr
 #'  Column 'group2': (Optional) Values of the second grouping variable \cr
-#'  
+#'
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 
-boxPlotGG_data_TreatmentDS <- function(table, variables, group = NULL, group2 = NULL){
+boxPlotGG_data_TreatmentDS <- function(table.name, variables, group = NULL, group2 = NULL){
+
+  table <- .loadServersideObject(table.name)
+
+  for(variable in variables){
+    .checkClass(obj = table[[variable]], obj_name = variable, permitted_classes = c("numeric", "integer"))
+  }
 
   if(is.null(group) & !is.null(group2)){
     group <- group2
     group2 <- NULL
   }
-  
+
   if(is.null(group2)){
     if(is.null(group)){
       data <- table[, c(variables)]
     }
     else{
-      if(! any(c("factor") %in% class(table[[group]]))) {
-        stop("Grouping variable must be of class factor")
-      }
+      .checkClass(obj = table[[group]], obj_name = group, permitted_classes = c("factor"))
       data <- table[, c(variables, group)]
     }
-    
+
   }
   else{
-    if((! any(c("factor") %in% class(table[[group]]))) | (! any(c("factor") %in% class(table[[group2]])))){
-      stop("Grouping variable must be of class factor")
-    }
+    .checkClass(obj = table[[group]], obj_name = group, permitted_classes = c("factor"))
+    .checkClass(obj = table[[group2]], obj_name = group2, permitted_classes = c("factor"))
     data <- table[, c(variables, group, group2)]
     # Handle case group == group2 
     if(group == group2){

R/boxPlotGG_data_Treatment_numericDS.R

@@ -1,18 +1,22 @@
 #' @title Arrange vector to pass it to the boxplot function
 #'
-#' @param vector \code{numeric vector} Vector to arrange to be plotted later
+#' @param vector.name \code{character} Name of a server-side numeric vector to arrange to be plotted later
 #'
 #' @return \code{data frame} with the following structure: \cr
-#' 
-#'  Column 'x': Names on the X axis of the boxplot, aka name of the vector (vector argument) \cr
+#'
+#'  Column 'x': Names on the X axis of the boxplot, aka name of the vector (vector.name argument) \cr
 #'  Column 'value': Values for that variable \cr
-#'  
+#'
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 
-boxPlotGG_data_Treatment_numericDS <- function(vector){
-
-  data <- data.frame(x = deparse(substitute(vector)), value = vector)
-
+boxPlotGG_data_Treatment_numericDS <- function(vector.name){
+
+  vector <- .loadServersideObject(vector.name)
+  .checkClass(obj = vector, obj_name = vector.name, permitted_classes = c("numeric", "integer"))
+
+  data <- data.frame(x = vector.name, value = vector)
+
   return(data)
-  
+
 }

R/changeRefGroupDS.R

@@ -7,16 +7,20 @@
 #' as this can introduce a mismatch of values if the vector is put back
 #' into a table that is not reordered in the same way. Such mismatch
 #' can render the results of operations on that table invalid.
-#' @param xvect a factor vector
+#' @param x a character string, the name of a factor vector.
 #' @param ref a character, the reference level
-#' @param reorderByRef a boolean that tells whether or not the new 
+#' @param reorderByRef a boolean that tells whether or not the new
 #' vector should be ordered by the reference group.
-#' @return  a factor of the same length as xvect
+#' @return  a factor of the same length as the input vector
 #' @author Isaeva, J., Gaye, A.
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
-changeRefGroupDS <- function(xvect, ref=NULL, reorderByRef=NULL){
-
+changeRefGroupDS <- function(x, ref=NULL, reorderByRef=NULL){
+
+  xvect <- .loadServersideObject(x)
+  .checkClass(obj = xvect, obj_name = x, permitted_classes = "factor")
+
   if(reorderByRef){
     temp_xvect = stats::relevel(xvect, ref)
     # now reorder puting the ref group first
@@ -26,7 +30,7 @@ changeRefGroupDS <- function(xvect, ref=NULL, reorderByRef=NULL){
   }else{
     new_xvect <- stats::relevel(xvect, ref)
   }
-  
+
   return(new_xvect)
-  
+
 }

R/densityGridDS.R

@@ -3,24 +3,31 @@
 #' @description Generates a density grid that can then be used for heatmap or contour plots.
 #' @details Invalid cells (cells with count < to the set filter value for the minimum allowed
 #' counts in table cells) are turn to 0.
-#' @param xvect a numerical vector
-#' @param yvect a numerical vector
+#' @param x a character string providing the name of a server-side numerical vector
+#' @param y a character string providing the name of a server-side numerical vector
 #' @param limits a logical expression for whether or not limits of the density grid are defined by
-#' a user. If \code{limits} is set to "FALSE", min and max of xvect and yvect are used as a range.
+#' a user. If \code{limits} is set to "FALSE", min and max of x and y are used as a range.
 #' If \code{limits} is set to "TRUE", limits defined by x.min, x.max, y.min and y.max are used.
 #' @param x.min a minimum value for the x axis of the grid density object, if needed
 #' @param x.max a maximum value for the x axis of the grid density object, if needed
 #' @param y.min a minimum value for the y axis of the grid density object, if needed
 #' @param y.max a maximum value for the y axis of the grid density object, if needed
 #' @param numints a number of intervals for the grid density object, by default is 20
-#' @return a grid density matrix
+#' @return a list with the grid density matrix (\code{grid}) and the classes of the x and y inputs
+#' (\code{class.x} and \code{class.y})
 #' @author Julia Isaeva, Amadou Gaye, Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
-#' 
-densityGridDS  <- function(xvect, yvect, limits=FALSE, x.min=NULL, x.max=NULL, y.min=NULL, y.max=NULL, numints=20){
-
+#'
+densityGridDS  <- function(x, y, limits=FALSE, x.min=NULL, x.max=NULL, y.min=NULL, y.max=NULL, numints=20){
+
+  xvect <- .loadServersideObject(x)
+  yvect <- .loadServersideObject(y)
+  .checkClass(obj = xvect, obj_name = x, permitted_classes = c("numeric", "integer"))
+  .checkClass(obj = yvect, obj_name = y, permitted_classes = c("numeric", "integer"))
+
   #############################################################
-  # MODULE 1: CAPTURE THE nfilter SETTINGS                    
+  # MODULE 1: CAPTURE THE nfilter SETTINGS
   thr <- dsBase::listDisclosureSettingsDS()				
   nfilter.tab <- as.numeric(thr$nfilter.tab)					
   #nfilter.glm <- as.numeric(thr$nfilter.glm)					
@@ -93,9 +100,9 @@ densityGridDS  <- function(xvect, yvect, limits=FALSE, x.min=NULL, x.max=NULL, y
 
   names(dimnames(grid.density.obj))[2] <- title.text
   names(dimnames(grid.density.obj))[1] <- ''
-  
-  return(grid.density.obj)
-  
+
+  return(list(grid=grid.density.obj, class.x=class(xvect), class.y=class(yvect)))
+
 }
 # AGGREGATE FUNCTION
 # densityGridDS

R/gamlssDS.R

@@ -69,6 +69,7 @@
 #' residuals (the normalised quantile residuals of the model) are not disclosed to 
 #' the client-side.
 #' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @import gamlss
 #' @import gamlss.dist
 #' @export
@@ -81,8 +82,9 @@ gamlssDS <- function(formula=formula, sigma.formula=sigma.formula, nu.formula=nu
 
   thr <- dsBase::listDisclosureSettingsDS()
   nfilter.glm <- as.numeric(thr$nfilter.glm)
-
-  data <- eval(parse(text = data), envir = parent.frame())
+
+  data <- .loadServersideObject(data)
+  .checkClass(obj = data, obj_name = "data", permitted_classes = c("data.frame", "matrix"))
 
   family <- gsub("left_parenthesis", "(", family, fixed = TRUE)
   family <- gsub("right_parenthesis", ")", family, fixed = TRUE)
@@ -187,8 +189,8 @@ gamlssDS <- function(formula=formula, sigma.formula=sigma.formula, nu.formula=nu
   base::assign(newobj, results$residuals, envir = parent.frame())
 
   if(centiles==TRUE){
-    xvar <- eval(parse(text=xvar), envir = parent.frame())
-    centiles_out <- gamlss::centiles(obj = results, xvar = xvar, points = FALSE, 
+    xvar <- .loadServersideObject(xvar)
+    centiles_out <- gamlss::centiles(obj = results, xvar = xvar, points = FALSE,
                                      save = TRUE)
   }else{
     centiles_out <- NA

R/glmDS1.R

@@ -19,6 +19,7 @@
 #' @return List with values from GLM model.
 #' 
 #' @author Burton PR for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 glmDS1 <- function(formula, family, weights, offset, data){
@@ -41,7 +42,8 @@ nfilter.glm <- as.numeric(thr$nfilter.glm)
   if(is.null(data)){
     dataTable <- NULL 
   }else{
-    dataTable <- eval(parse(text=data), envir = parent.frame())
+    dataTable <- .loadServersideObject(data)
+    .checkClass(obj = dataTable, obj_name = data, permitted_classes = c("data.frame", "matrix"))
   }
 
   formulatext <- Reduce(paste, deparse(formula))

R/glmDS2.R

@@ -20,6 +20,7 @@
 #' the data to be analysed under the specified model same 
 #' 
 #' @author Paul Burton, for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' 
 #' @return List with values from GLM model
 #' @export
@@ -39,7 +40,8 @@ glmDS2 <- function (formula, family, beta.vect, offset, weights, dataName) {
   # Same is done for offset and weights lower down function
 
   if(!is.null(dataName)){
-    dataDF <- eval(parse(text=dataName), envir = parent.frame())
+    dataDF <- .loadServersideObject(dataName)
+    .checkClass(obj = dataDF, obj_name = dataName, permitted_classes = c("data.frame", "matrix"))
   }else{
     dataDF <- NULL
   }

R/glmPredictDS.ag.R

@@ -34,6 +34,7 @@
 #' ds.glmPredict and glmPredict.as and help in native R for predict.glm
 #' predict.glm in native R
 #' @author Paul Burton for DataSHIELD Development Team (20/7/20)
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #' 
 glmPredictDS.ag <- function(glmname.transmit, newdataname.transmit,
@@ -148,13 +149,11 @@ if(!string.safe)
 }
 
 #Activate all arguments
-#glmobj<-eval(parse(text=glmname.transmit))
-glmobj<-get(glmname.transmit)
+glmobj <- .loadServersideObject(glmname.transmit)
 
 if(!is.null(newdataname.transmit))
 	{
-	newdf<-get(newdataname.transmit)
-#	newdf<-geeval(parse(text=newdataname.transmit))
+	newdf <- .loadServersideObject(newdataname.transmit)
 	}else{
 	newdf<-NULL
 	}