diff --git a/DESCRIPTION b/DESCRIPTION index aa62b700..d733e042 100644 --- a/DESCRIPTION +++ b/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 diff --git a/NAMESPACE b/NAMESPACE index e4fd38c9..4bf3dc67 100644 --- a/NAMESPACE +++ b/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 +) diff --git a/R/asFactorDS1.R b/R/asFactorDS1.R index 6d4f0507..c6c0445a 100644 --- a/R/asFactorDS1.R +++ b/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) diff --git a/R/asFactorDS2.R b/R/asFactorDS2.R index 74af1d67..af45a47f 100644 --- a/R/asFactorDS2.R +++ b/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=",")) diff --git a/R/asFactorSimpleDS.R b/R/asFactorSimpleDS.R index 80a14b27..b23c8244 100644 --- a/R/asFactorSimpleDS.R +++ b/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) diff --git a/R/boxPlotGGDS.R b/R/boxPlotGGDS.R index 11b6fd90..6ee33824 100644 --- a/R/boxPlotGGDS.R +++ b/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() # diff --git a/R/boxPlotGG_data_TreatmentDS.R b/R/boxPlotGG_data_TreatmentDS.R index 7d6613d1..c3a18e67 100644 --- a/R/boxPlotGG_data_TreatmentDS.R +++ b/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){ diff --git a/R/boxPlotGG_data_Treatment_numericDS.R b/R/boxPlotGG_data_Treatment_numericDS.R index 7374ca7d..feff4f0e 100644 --- a/R/boxPlotGG_data_Treatment_numericDS.R +++ b/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) - + } \ No newline at end of file diff --git a/R/changeRefGroupDS.R b/R/changeRefGroupDS.R index b99cc0ee..4be99bf7 100644 --- a/R/changeRefGroupDS.R +++ b/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) - + } diff --git a/R/densityGridDS.R b/R/densityGridDS.R index 1569d5c1..1e16fc8a 100644 --- a/R/densityGridDS.R +++ b/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 diff --git a/R/gamlssDS.R b/R/gamlssDS.R index 533da0e1..1789b5af 100644 --- a/R/gamlssDS.R +++ b/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 diff --git a/R/glmDS1.R b/R/glmDS1.R index a76d615c..568e3070 100644 --- a/R/glmDS1.R +++ b/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)) diff --git a/R/glmDS2.R b/R/glmDS2.R index 9287075c..93e8edda 100644 --- a/R/glmDS2.R +++ b/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 } diff --git a/R/glmPredictDS.ag.R b/R/glmPredictDS.ag.R index c4474079..9a40804e 100644 --- a/R/glmPredictDS.ag.R +++ b/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 } diff --git a/R/glmPredictDS.as.R b/R/glmPredictDS.as.R index e25e3b50..84417fc9 100644 --- a/R/glmPredictDS.as.R +++ b/R/glmPredictDS.as.R @@ -32,6 +32,7 @@ #' For more details see DataSHIELD help for ds.glmPredict and help for #' 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.as <- function(glmname.transmit, newdataname.transmit, output.type,se.fit, dispersion, terms.transmit, na.action){ @@ -142,13 +143,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 } diff --git a/R/glmSLMADS1.R b/R/glmSLMADS1.R index 30346f4e..4cddefdb 100644 --- a/R/glmSLMADS1.R +++ b/R/glmSLMADS1.R @@ -17,6 +17,7 @@ #' such as test of model complexity (saturation). #' For more detailed information see help for ds.glmSLMA. #' @author Paul Burton for DataSHIELD Development Team (14/7/20) +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export glmSLMADS1<- function(formula, family, weights, offset, data){ @@ -51,7 +52,8 @@ final.family.object<-eval(parse(text=family)) 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")) } diff --git a/R/glmSLMADS2.R b/R/glmSLMADS2.R index 759263b5..58d1b374 100644 --- a/R/glmSLMADS2.R +++ b/R/glmSLMADS2.R @@ -22,6 +22,7 @@ #' in particular including the study-specific regression coefficients and their corresponding #' standard errors. #' @author Paul Burton for DataSHIELD Development Team (14/7/20) +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export glmSLMADS2 <- function(formula, family, offset, weights, newobj, dataName){ @@ -52,7 +53,8 @@ errorMessage2<-"No errors" # 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 } @@ -102,8 +104,7 @@ errorMessage2<-"No errors" #bringing back in the mg output saved from that previous call # mg <- stats::glm(formula2use, family=final.family.object, x=TRUE, offset=offset.to.use, weights=weights.to.use, data=dataDF) -activate.text<- paste0("mg<-",newobj) -eval(parse(text=activate.text)) +mg <- .loadServersideObject(newobj) y.vect<-mg$y X.mat<-mg$x diff --git a/R/glmSummaryDS.ag.R b/R/glmSummaryDS.ag.R index 880f5b79..7316eee4 100644 --- a/R/glmSummaryDS.ag.R +++ b/R/glmSummaryDS.ag.R @@ -17,6 +17,7 @@ #' elements (and only the non-disclosive elements) of a specified serverside glm #' and its corresponding summary_glm object. #' @author Paul Burton for DataSHIELD Development Team (20/7/20) +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export glmSummaryDS.ag <- function(x.transmit){ @@ -55,7 +56,7 @@ if(!string.safe) #create safe glm object with disclosive elements deleted for clientside ####################################################################### -input.obj<-eval(parse(text=x.transmit)) +input.obj <- .loadServersideObject(x.transmit) if (is.null(input.obj)) { @@ -90,7 +91,7 @@ glm.obj<-input.obj #create safe summary.glm object with disclosive elements deleted for clientside ############################################################################### -input.obj<-eval(parse(text=x.transmit)) +input.obj <- .loadServersideObject(x.transmit) summary.obj<-summary(input.obj) diff --git a/R/glmSummaryDS.as.R b/R/glmSummaryDS.as.R index 38cf4cf8..076ede7f 100644 --- a/R/glmSummaryDS.as.R +++ b/R/glmSummaryDS.as.R @@ -15,6 +15,7 @@ #' @return writes object to serverside which is precisely equivalent #' to summary(glm object) in native R #' @author Paul Burton for DataSHIELD Development Team (20/7/20) +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export glmSummaryDS.as <- function(x.transmit){ @@ -52,13 +53,13 @@ if(!string.safe) #create summary.glm object -input.obj<-eval(parse(text=x.transmit)) +input.obj <- .loadServersideObject(x.transmit) summary.obj<-summary(input.obj) #block na.action and deviance residual components of summary object -summary.obj[[12]]<-NA -summary.obj[[11]]<-NA +if (!is.null(summary.obj$na.action)) summary.obj$na.action<-NA +summary.obj$deviance.resid<-NA summary.obj<-summary.obj diff --git a/R/glmerSLMADS.assign.R b/R/glmerSLMADS.assign.R index df367ea1..2105fea7 100644 --- a/R/glmerSLMADS.assign.R +++ b/R/glmerSLMADS.assign.R @@ -29,6 +29,7 @@ #' @return writes glmerMod object summarising the fitted model to the serverside. #' For more detailed information see help for ds.glmerSLMA. #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export glmerSLMADS.assign <- function(formula, offset, weights, dataName, family, control_type=NULL, control_value.transmit=NULL, nAGQ=1L, verbose = 0, theta = NULL, fixef = NULL){ @@ -46,7 +47,8 @@ glmerSLMADS.assign <- function(formula, offset, weights, dataName, family, # 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 } diff --git a/R/glmerSLMADS2.R b/R/glmerSLMADS2.R index 8fe54f83..d4b15f8c 100644 --- a/R/glmerSLMADS2.R +++ b/R/glmerSLMADS2.R @@ -36,6 +36,7 @@ #' function ds.glmerSLMA #' @return all key model components see help for ds.glmerSLMA #' @author Tom Bishop, with some additions by Paul Burton +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export glmerSLMADS2 <- function(formula, offset, weights, dataName, family, control_type=NULL, control_value.transmit=NULL, nAGQ=1L, verbose = 0, theta = NULL, fixef = NULL){ @@ -53,7 +54,8 @@ glmerSLMADS2 <- function(formula, offset, weights, dataName, family, # 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 } diff --git a/R/heatmapPlotDS.R b/R/heatmapPlotDS.R index 349f57b9..d8afc61e 100644 --- a/R/heatmapPlotDS.R +++ b/R/heatmapPlotDS.R @@ -9,8 +9,8 @@ #' neighbours and the y-coordinate of the centroid is the average of the y-coordinates of the n nearest #' neighbours. The coordinates of the centroids return to the client side function and can be used for the #' plot of non-disclosive graphs (e.g. scatter plots, heatmap plots, contour plots, etc). -#' @param x the name of a numeric vector, the x-variable. -#' @param y the name of a numeric vector, the y-variable. +#' @param x.name a character string providing the name of a server-side numeric vector, the x-variable. +#' @param y.name a character string providing the name of a server-side numeric vector, the y-variable. #' @param k the number of the nearest neighbours for which their centroid is calculated if the #' \code{method.indicator} is equal to 1 (i.e. deterministic method). #' @param noise the percentage of the initial variance that is used as the variance of the embedded @@ -18,11 +18,18 @@ #' @param method.indicator a number equal to either 1 or 2. If the value is equal to 1 then the #' 'deterministic' method is used. If the value is set to 2 the 'probabilistic' method is used. #' @return a list with the x and y coordinates of the centroids if the deterministic method is used -#' or the x and y coordinated of the noisy data if the probabilistic method is used. +#' or the x and y coordinated of the noisy data if the probabilistic method is used, along with the +#' classes of the x and y inputs (\code{class.x} and \code{class.y}) #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export -#' -heatmapPlotDS <- function(x, y, k, noise, method.indicator){ +#' +heatmapPlotDS <- function(x.name, y.name, k, noise, method.indicator){ + + x <- .loadServersideObject(x.name) + y <- .loadServersideObject(y.name) + .checkClass(obj = x, obj_name = x.name, permitted_classes = c("numeric", "integer")) + .checkClass(obj = y, obj_name = y.name, permitted_classes = c("numeric", "integer")) ################################################################### # MODULE 1: CAPTURE THE nfilter SETTINGS # @@ -125,8 +132,8 @@ heatmapPlotDS <- function(x, y, k, noise, method.indicator){ } # Return a list with the x and y coordinates of the centroids - return(list(x.new, y.new)) - + return(list(x.new, y.new, class.x=class(x), class.y=class(y))) + } # AGGREGATE FUNCTION # heatmapPlotDS diff --git a/R/histogramDS1.R b/R/histogramDS1.R index 71ffc439..97e09780 100644 --- a/R/histogramDS1.R +++ b/R/histogramDS1.R @@ -7,7 +7,7 @@ #' function returns the minimum and maximum values of the vector with the scaled centroids. If the #' method.indicator is set to 3 (i.e. the 'probabilistic' method is used) the function returns the #' minimum and maximum values of the generated 'noisy' vector. -#' @param xvect the numeric vector for which the histogram is desired. +#' @param x a character string providing the name of the server-side numeric vector for which the histogram is desired. #' @param method.indicator a number equal to either 1, 2 or 3 indicating the method of disclosure #' control that is used for the generation of the histogram. If the value is equal to 1 then the #' 'smallCellsRule' is used. If the value is equal to 2 then the 'deterministic' method is used. @@ -16,11 +16,16 @@ #' \code{method.indicator} is equal to 2 (i.e. deterministic method). #' @param noise the percentage of the initial variance that is used as the variance of the embedded #' noise if the \code{method.indicator} is equal to 3 (i.e. probabilistic method). -#' @return a numeric vector which contains the minimum and the maximum values of the vector +#' @return a list with the numeric vector containing the minimum and the maximum values of the +#' vector (\code{range}) and the class of the input vector (\code{class}) #' @author Amadou Gaye, Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' -histogramDS1 <- function(xvect, method.indicator, k, noise){ +histogramDS1 <- function(x, method.indicator, k, noise){ + + xvect <- .loadServersideObject(x) + .checkClass(obj = xvect, obj_name = x, permitted_classes = c("numeric", "integer")) ################################################################## # MODULE 1: CAPTURE THE nfilter SETTINGS # @@ -43,110 +48,103 @@ histogramDS1 <- function(xvect, method.indicator, k, noise){ } else on.exit(if (exists(x = ".Random.seed", envir = globalenv())) remove(".Random.seed", envir = globalenv()), add = TRUE) - # print an error message if the input vector is not a numeric - if(!(is.numeric(xvect))){ - output <- "The input vector is not a numeric!" - }else{ - - if (method.indicator==1){ - - # the study-specific seed for random number generation - seed <- getOption("datashield.seed") - if (is.null(seed)) - stop("histogramDS1 requires 'datashield.seed' R option to operate", call.=FALSE) - set.seed(seed) - - rr <- c(min(xvect, na.rm=TRUE), max(xvect, na.rm=TRUE)) - if(rr[1] < 0){ min <- rr[1] * stats::runif(1, 1.01, 1.05) }else{ min <- rr[1] * stats::runif(1, 0.95, 0.99) } - if(rr[2] < 0){ max <- rr[2] * stats::runif(1, 0.95, 0.99) }else{ max <- rr[2] * stats::runif(1, 1.01, 1.05) } - - output <- c(min, max) - + if (method.indicator==1){ + + # the study-specific seed for random number generation + seed <- getOption("datashield.seed") + if (is.null(seed)) + stop("histogramDS1 requires 'datashield.seed' R option to operate", call.=FALSE) + set.seed(seed) + + rr <- c(min(xvect, na.rm=TRUE), max(xvect, na.rm=TRUE)) + if(rr[1] < 0){ min <- rr[1] * stats::runif(1, 1.01, 1.05) }else{ min <- rr[1] * stats::runif(1, 0.95, 0.99) } + if(rr[2] < 0){ max <- rr[2] * stats::runif(1, 0.95, 0.99) }else{ max <- rr[2] * stats::runif(1, 1.01, 1.05) } + + output <- c(min, max) + + } + + if(method.indicator==2){ + + # Remove any missing values + x <- stats::na.omit(xvect) + + # Standardise the variable + x.standardised <- (x-mean(x))/stats::sd(x) + + # Calculate the length of the variable after ommitting any NAs + N.data <- length(x) + + # Check if k is integer and has a value greater than or equal to the pre-specified threshold + # and less than or equal to the length of rows of data.complete minus the pre-specified threshold + if(k < nfilter.kNN | k > (N.data - nfilter.kNN)){ + stop(paste0("k must be greater than or equal to ", nfilter.kNN, " and less than or equal to ", (N.data-nfilter.kNN), "."), call.=FALSE) + }else{ + neighbours = k } - - if(method.indicator==2){ - - # Remove any missing values - x <- stats::na.omit(xvect) - - # Standardise the variable - x.standardised <- (x-mean(x))/stats::sd(x) - - # Calculate the length of the variable after ommitting any NAs - N.data <- length(x) - - # Check if k is integer and has a value greater than or equal to the pre-specified threshold - # and less than or equal to the length of rows of data.complete minus the pre-specified threshold - if(k < nfilter.kNN | k > (N.data - nfilter.kNN)){ - stop(paste0("k must be greater than or equal to ", nfilter.kNN, " and less than or equal to ", (N.data-nfilter.kNN), "."), call.=FALSE) - }else{ - neighbours = k - } - - # Find the k-1 nearest neighbours of each data point - nearest <- RANN::nn2(x.standardised, k = neighbours) - - # Calculate the centroid of each n nearest data points - x.centroid <- matrix() - for (i in 1:N.data){ - x.centroid[i] <- mean(x.standardised[nearest$nn.idx[i,1:neighbours]]) - } - - # Calculate the scaling factor - x.scalingFactor <- stats::sd(x.standardised)/stats::sd(x.centroid) - - # Apply the scaling factor to the centroids - x.masked <- x.centroid * x.scalingFactor - - # Shift the centroids back to the actual position and scale of the original data - x.new <- (x.masked * stats::sd(x)) + mean(x) - - # find the minimum and the maximum of the distribution - min <- min(x.new) - max <- max(x.new) - - output <- c(min, max) - + + # Find the k-1 nearest neighbours of each data point + nearest <- RANN::nn2(x.standardised, k = neighbours) + + # Calculate the centroid of each n nearest data points + x.centroid <- matrix() + for (i in 1:N.data){ + x.centroid[i] <- mean(x.standardised[nearest$nn.idx[i,1:neighbours]]) } - - if(method.indicator==3){ - - # Remove any missing values - x <- stats::na.omit(xvect) - - # Calculate the length of the variable after ommitting any NAs - N.data <- length(x) - - # Check if the percentage of the variance that is specified in the argument 'noise' - # and is used as the variance of the embedded noise is a greater - # than the minimum threshold specified in the filter 'nfilter.noise' - if(noise < nfilter.noise){ - stop(paste0("'noise' must be greater than or equal to ", nfilter.noise), call.=FALSE) - }else{ - percentage <- noise - } - - # the study-specific seed for random number generation - seed <- getOption("datashield.seed") - if (is.null(seed)) - stop("histogramDS requires 'datashield.seed' R option to operate", call.=FALSE) - set.seed(seed) - - # generate the noise-augmented vector - x.new <- x + stats::rnorm(N.data, mean=0, sd=sqrt(percentage*stats::var(x))) - - # find the minimum and the maximum of the distribution - min <- min(x.new) - max <- max(x.new) - - output <- c(min, max) - + + # Calculate the scaling factor + x.scalingFactor <- stats::sd(x.standardised)/stats::sd(x.centroid) + + # Apply the scaling factor to the centroids + x.masked <- x.centroid * x.scalingFactor + + # Shift the centroids back to the actual position and scale of the original data + x.new <- (x.masked * stats::sd(x)) + mean(x) + + # find the minimum and the maximum of the distribution + min <- min(x.new) + max <- max(x.new) + + output <- c(min, max) + + } + + if(method.indicator==3){ + + # Remove any missing values + x <- stats::na.omit(xvect) + + # Calculate the length of the variable after ommitting any NAs + N.data <- length(x) + + # Check if the percentage of the variance that is specified in the argument 'noise' + # and is used as the variance of the embedded noise is a greater + # than the minimum threshold specified in the filter 'nfilter.noise' + if(noise < nfilter.noise){ + stop(paste0("'noise' must be greater than or equal to ", nfilter.noise), call.=FALSE) + }else{ + percentage <- noise } - + + # the study-specific seed for random number generation + seed <- getOption("datashield.seed") + if (is.null(seed)) + stop("histogramDS requires 'datashield.seed' R option to operate", call.=FALSE) + set.seed(seed) + + # generate the noise-augmented vector + x.new <- x + stats::rnorm(N.data, mean=0, sd=sqrt(percentage*stats::var(x))) + + # find the minimum and the maximum of the distribution + min <- min(x.new) + max <- max(x.new) + + output <- c(min, max) + } - - return (output) - + + return(list(range=output, class=class(xvect))) + } # AGGREGATE FUNCTION # histogramDS1 diff --git a/R/histogramDS2.R b/R/histogramDS2.R index 001ab0dd..4e85b83f 100644 --- a/R/histogramDS2.R +++ b/R/histogramDS2.R @@ -6,7 +6,7 @@ #' size of a table. If a bin has less counts than this threshold then their counts #' and its density are replaced by a 0 value. #' @details Please find more details in the documentation of the clientside ds.histogram function. -#' @param xvect the numeric vector for which the histogram is desired. +#' @param x a character string providing the name of the server-side numeric vector for which the histogram is desired. #' @param num.breaks the number of breaks that the range of the variable is divided. #' @param min a numeric, the lower limit of the distribution. #' @param max a numeric, the upper limit of the distribution. @@ -20,9 +20,13 @@ #' noise if the \code{method.indicator} is equal to 3 (i.e. probabilistic method). #' @return a list with an object of class \code{histogram} and the number of invalid cells #' @author Amadou Gaye, Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' -histogramDS2 <- function (xvect, num.breaks, min, max, method.indicator, k, noise){ +histogramDS2 <- function (x, num.breaks, min, max, method.indicator, k, noise){ + + xvect <- .loadServersideObject(x) + .checkClass(obj = xvect, obj_name = x, permitted_classes = c("numeric", "integer")) ################################################################## # MODULE 1: CAPTURE THE nfilter SETTINGS # diff --git a/R/lmerSLMADS.assign.R b/R/lmerSLMADS.assign.R index 06b2bcd1..0aabe6b6 100644 --- a/R/lmerSLMADS.assign.R +++ b/R/lmerSLMADS.assign.R @@ -18,6 +18,7 @@ #' @return writes lmerMod object summarising the fitted model to the serverside. #' For more detailed information see help for ds.lmerSLMA. #' @author TDemetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export lmerSLMADS.assign <- function(formula, offset, weights, dataName, REML = TRUE, control_type, control_value.transmit, optimizer, verbose=0){ @@ -37,7 +38,8 @@ lmerSLMADS.assign <- function(formula, offset, weights, dataName, REML = TRUE, # 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 } @@ -124,39 +126,44 @@ lmerSLMADS.assign <- function(formula, offset, weights, dataName, REML = TRUE, ################################################################## #sort out offset and weights + # + # offset.to.use/weights.to.use are needed in two different environments: + # stats::glm() below resolves them via environment(formula2use), which is + # this function's *caller* (matching where the other formula variables are + # assigned, see the model.variables loop above); lme4::lmer() further down + # resolves them relative to its own call frame, i.e. this function's *own* + # frame. Assign to both so each modelling call finds them. if(is.null(offset)) { varname.offset<-NULL - #offset.to.use <- NULL - cbindtext.offset <- paste0("offset.to.use <- NULL") - eval(parse(text=cbindtext.offset), envir = parent.frame()) + offset.to.use <- NULL + assign("offset.to.use", NULL, envir = parent.frame()) }else{ varname.offset <- paste0(offset) } - + if(!(is.null(offset))) { - cbindtext.offset <- paste0("offset.to.use <- cbind(", offset,")") - eval(parse(text=cbindtext.offset), envir = parent.frame()) + cbindtext.offset <- paste0("cbind(", offset,")") + offset.to.use <- eval(parse(text=cbindtext.offset), envir = parent.frame()) + assign("offset.to.use", offset.to.use, envir = parent.frame()) } - + if(is.null(weights)) { varname.weights<-NULL - cbindtext.weights <- paste0("weights.to.use <- NULL") - eval(parse(text=cbindtext.weights), envir = parent.frame()) - #weights.to.use <- NULL + weights.to.use <- NULL + assign("weights.to.use", NULL, envir = parent.frame()) }else{ varname.weights <- paste0(weights) } - - + + if(!(is.null(weights))) { - cbindtext.weights <- paste0("weights.to.use <- cbind(", weights,")") - eval(parse(text=cbindtext.weights), envir = parent.frame()) - #cbindtext.weights <- paste0("cbind(", weights,")") - #weights.to.use <- eval(parse(text=cbindtext.weights), envir = parent.frame()) + cbindtext.weights <- paste0("cbind(", weights,")") + weights.to.use <- eval(parse(text=cbindtext.weights), envir = parent.frame()) + assign("weights.to.use", weights.to.use, envir = parent.frame()) } #### BEFORE going further we use the glm1 checks @@ -357,11 +364,10 @@ if(!is.null(optimizer)&&optimizer!="nloptwrap") } - mg <- lme4::lmer(formula2use, offset=offset, weights=weights, data=dataDF, REML = REML, verbose = verbose, control = control.obj) - #iterations <- utils::capture.output(try(mg <- lme4::lmer(formula2use, offset=offset.to.use, weights=weights.to.use, data=dataDF, REML = REML, verbose = verbose, control = control.obj))) + mg <- lme4::lmer(formula2use, offset=offset.to.use, weights=weights.to.use, data=dataDF, REML = REML, verbose = verbose, control = control.obj) outlist <- mg - + } #tidy up in parent.frame() eval(quote(rm(offset.to.use)), envir = parent.frame()) diff --git a/R/lmerSLMADS2.R b/R/lmerSLMADS2.R index 145f90b9..68bcb465 100644 --- a/R/lmerSLMADS2.R +++ b/R/lmerSLMADS2.R @@ -27,6 +27,7 @@ #' @param verbose see help for ds.lmerSLMA #' @return all key model components see help for ds.lmerSLMA #' @author Tom Bishop, with some additions by Paul Burton +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export lmerSLMADS2 <- function(formula, offset, weights, dataName, REML = TRUE, control_type, control_value.transmit, optimizer, verbose=0){ @@ -46,7 +47,8 @@ lmerSLMADS2 <- function(formula, offset, weights, dataName, REML = TRUE, # 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 } @@ -133,39 +135,44 @@ lmerSLMADS2 <- function(formula, offset, weights, dataName, REML = TRUE, ################################################################## #sort out offset and weights + # + # offset.to.use/weights.to.use are needed in two different environments: + # stats::glm() below resolves them via environment(formula2use), which is + # this function's *caller* (matching where the other formula variables are + # assigned, see the model.variables loop above); lme4::lmer() further down + # resolves them relative to its own call frame, i.e. this function's *own* + # frame. Assign to both so each modelling call finds them. if(is.null(offset)) { varname.offset<-NULL - #offset.to.use <- NULL - cbindtext.offset <- paste0("offset.to.use <- NULL") - eval(parse(text=cbindtext.offset), envir = parent.frame()) + offset.to.use <- NULL + assign("offset.to.use", NULL, envir = parent.frame()) }else{ varname.offset <- paste0(offset) } - + if(!(is.null(offset))) { - cbindtext.offset <- paste0("offset.to.use <- cbind(", offset,")") - eval(parse(text=cbindtext.offset), envir = parent.frame()) + cbindtext.offset <- paste0("cbind(", offset,")") + offset.to.use <- eval(parse(text=cbindtext.offset), envir = parent.frame()) + assign("offset.to.use", offset.to.use, envir = parent.frame()) } - + if(is.null(weights)) { varname.weights<-NULL - cbindtext.weights <- paste0("weights.to.use <- NULL") - eval(parse(text=cbindtext.weights), envir = parent.frame()) - #weights.to.use <- NULL + weights.to.use <- NULL + assign("weights.to.use", NULL, envir = parent.frame()) }else{ varname.weights <- paste0(weights) } - - + + if(!(is.null(weights))) { - cbindtext.weights <- paste0("weights.to.use <- cbind(", weights,")") - eval(parse(text=cbindtext.weights), envir = parent.frame()) - #cbindtext.weights <- paste0("cbind(", weights,")") - #weights.to.use <- eval(parse(text=cbindtext.weights), envir = parent.frame()) + cbindtext.weights <- paste0("cbind(", weights,")") + weights.to.use <- eval(parse(text=cbindtext.weights), envir = parent.frame()) + assign("weights.to.use", weights.to.use, envir = parent.frame()) } #### BEFORE going further we use the glm1 checks diff --git a/R/matrixDS.R b/R/matrixDS.R index bcdb6908..18951fbc 100644 --- a/R/matrixDS.R +++ b/R/matrixDS.R @@ -22,6 +22,7 @@ #' @return Output is the matrix A written #' to the serverside. For more details see help for ds.matrix #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' matrixDS <- function(mdata.transmit, from, nrows.transmit, ncols.transmit, byrow, dimnames){ @@ -92,7 +93,7 @@ if(!is.null(dimnames)) if(from=="serverside.vector"||from=="serverside.scalar") { -mdata<-eval(parse(text=mdata.transmit), envir = parent.frame()) +mdata <- .loadServersideObject(mdata.transmit) } diff --git a/R/matrixDetDS1.R b/R/matrixDetDS1.R index e6c3403c..b6fb40ce 100644 --- a/R/matrixDetDS1.R +++ b/R/matrixDetDS1.R @@ -11,42 +11,18 @@ #' @return Output is the determinant of the matrix identified by argument #' which is returned to the clientside. For more details see help for ds.matrixDet #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export matrixDetDS1 <- function(M1.name=NULL,logarithm){ -######################################################################### -# DataSHIELD MODULE: 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) # -#datashield.privacyLevel<-as.numeric(thr$datashield.privacyLevel) # -######################################################################### +dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'avocado', 'banana')) -#Check length of M1.name not so long as to provide a risk of hidden code -length.M1.name<-length(unlist(strsplit(M1.name,''))) +thr <- dsBase::listDisclosureSettingsDS() +nfilter.subset <- as.numeric(thr$nfilter.subset) -if(length.M1.name>nfilter.stringShort) - { - error.message<- - paste0("FAILED: M1.name is too long it could hide concealed code, please shorten to <= nfilter.stringShort = ", - nfilter.stringShort," characters") - stop(error.message, call. = FALSE) - } - -#EVAL M1 - -M1<-eval(parse(text=M1.name), envir = parent.frame()) - -if(!is.matrix(M1)&&!is.data.frame(M1)) - { - error.message<-"FAILED: M1 must be of class matrix or data.frame, please respecify" - stop(error.message, call. = FALSE) - } +M1 <- .loadServersideObject(M1.name) +.checkClass(obj = M1, obj_name = M1.name, permitted_classes = c("matrix", "data.frame")) #coerce to matrix if a data.frame if(is.data.frame(M1)) @@ -62,6 +38,12 @@ if(ncol(M1)!=nrow(M1)) stop(error.message, call. = FALSE) } +#Check matrix large enough to reduce disclosure risk +if(nrow(M1) #' which is written to the serverside. For more details see help for ds.matrixDet #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export matrixDetDS2 <- function(M1.name=NULL,logarithm){ -######################################################################### -# DataSHIELD MODULE: 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) # -#datashield.privacyLevel<-as.numeric(thr$datashield.privacyLevel) # -######################################################################### - -#Check length of M1.name not so long as to provide a risk of hidden code -length.M1.name<-length(unlist(strsplit(M1.name,''))) - -if(length.M1.name>nfilter.stringShort) - { - studysideMessage<- - paste0("FAILED: M1.name is too long it could hide concealed code, please shorten to <= nfilter.stringShort = ", - nfilter.stringShort," characters") - stop(studysideMessage, call. = FALSE) - } - -#EVAL M1 - -M1<-eval(parse(text=M1.name), envir = parent.frame()) - -if(!is.matrix(M1)&&!is.data.frame(M1)) - { - studysideMessage<-"FAILED: M1 must be of class matrix or data.frame, please respecify" - stop(studysideMessage, call. = FALSE) - } +M1 <- .loadServersideObject(M1.name) +.checkClass(obj = M1, obj_name = M1.name, permitted_classes = c("matrix", "data.frame")) #coerce to matrix if a data.frame if(is.data.frame(M1)) diff --git a/R/matrixDiagDS.R b/R/matrixDiagDS.R index c5b613bd..449538ba 100644 --- a/R/matrixDiagDS.R +++ b/R/matrixDiagDS.R @@ -17,6 +17,7 @@ #' (or default name diag_) which is written to the serverside. #' For more details see help for \code{ds.matrixDiag}. #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export matrixDiagDS <- function(x1.transmit,aim,nrows.transmit){ ######################################################################### @@ -65,7 +66,7 @@ if(aim=="serverside.vector.2.matrix"||aim=="serverside.scalar.2.matrix"||aim=="s { #x1 is name of the serverside vector, scalar or matrix -x1<-eval(parse(text=x1.transmit), envir = parent.frame()) +x1 <- .loadServersideObject(x1.transmit) #coerce to matrix if x1 is a data.frame if(is.data.frame(x1)) diff --git a/R/matrixDimnamesDS.R b/R/matrixDimnamesDS.R index 97653f24..36a2f566 100644 --- a/R/matrixDimnamesDS.R +++ b/R/matrixDimnamesDS.R @@ -18,6 +18,7 @@ #' (or default name diag_) with specified dimnames (row and column #' names) which is written to the serverside. #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export matrixDimnamesDS <- function(M1.name=NULL,dimnames){ @@ -28,23 +29,11 @@ thr<-dsBase::listDisclosureSettingsDS() # #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.stringShort<-as.numeric(thr$nfilter.stringShort) # #nfilter.kNN<-as.numeric(thr$nfilter.kNN) # #datashield.privacyLevel<-as.numeric(thr$datashield.privacyLevel) # ######################################################################### -#Check length of M1.name not so long as to provide a risk of hidden code -length.M1.name<-length(unlist(strsplit(M1.name,''))) - -if(length.M1.name>nfilter.stringShort) - { - studysideMessage<- - paste0("FAILED: M1.name is too long it could hide concealed code, please shorten to <= nfilter.stringShort = ", - nfilter.stringShort," characters") - stop(studysideMessage, call. = FALSE) - } - - #Check length of dimnames string not so long as to provide a risk of hidden code #This could legitimately be quite long so allow 2*nfilter.string @@ -61,15 +50,8 @@ if(!is.null(dimnames)) } } -#EVAL M1 - -M1<-eval(parse(text=M1.name), envir = parent.frame()) - -if(!is.matrix(M1)&&!is.data.frame(M1)) - { - studysideMessage<-"FAILED: M1 must be of class matrix or data.frame, please respecify" - stop(studysideMessage, call. = FALSE) - } +M1 <- .loadServersideObject(M1.name) +.checkClass(obj = M1, obj_name = M1.name, permitted_classes = c("matrix", "data.frame")) #coerce to matrix if a data.frame if(is.data.frame(M1)) diff --git a/R/matrixInvertDS.R b/R/matrixInvertDS.R index 5ce2b2c0..b87cb948 100644 --- a/R/matrixInvertDS.R +++ b/R/matrixInvertDS.R @@ -8,43 +8,13 @@ #' @return Output is the matrix representing the inverse of A which is written #' to the serverside. For more details see help for ds.matrixInvert #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' matrixInvertDS <- function(M1.name=NULL){ -######################################################################### -# DataSHIELD MODULE: 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) # -#datashield.privacyLevel<-as.numeric(thr$datashield.privacyLevel) # -######################################################################### - -#Check length of M1.name not so long as to provide a risk of hidden code -length.M1.name<-length(unlist(strsplit(M1.name,''))) - -if(length.M1.name>nfilter.stringShort) - { - studysideMessage<- - paste0("FAILED: M1.name is too long it could hide concealed code, please shorten to <= nfilter.stringShort = ", - nfilter.stringShort," characters") - stop(studysideMessage, call. = FALSE) - } - -#EVAL M1 - - -M1<-eval(parse(text=M1.name), envir = parent.frame()) - -if(!is.matrix(M1)&&!is.data.frame(M1)) - { - studysideMessage<-"FAILED: M1 must be of class matrix or data.frame, please respecify" - stop(studysideMessage, call. = FALSE) - } +M1 <- .loadServersideObject(M1.name) +.checkClass(obj = M1, obj_name = M1.name, permitted_classes = c("matrix", "data.frame")) #coerce to matrix if a data.frame if(is.data.frame(M1)) diff --git a/R/matrixMultDS.R b/R/matrixMultDS.R index 67f4ae64..240fead8 100644 --- a/R/matrixMultDS.R +++ b/R/matrixMultDS.R @@ -13,61 +13,16 @@ #' @return Output is the matrix representing the product of M1 and M2 which is written #' to the serverside. For more details see help for ds.matrixMult #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' matrixMultDS <- function(M1.name=NULL, M2.name=NULL){ -######################################################################### -# DataSHIELD MODULE: 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) # -#datashield.privacyLevel<-as.numeric(thr$datashield.privacyLevel) # -######################################################################### -#EVAL M1 and M2 +M1 <- .loadServersideObject(M1.name) +.checkClass(obj = M1, obj_name = M1.name, permitted_classes = c("matrix", "data.frame")) -#Check length of M1.name not so long as to provide a risk of hidden code -length.M1.name<-length(unlist(strsplit(M1.name,''))) - -if(length.M1.name>nfilter.stringShort) - { - studysideMessage<- - paste0("FAILED: M1.name is too long it could hide concealed code, please shorten to <= nfilter.stringShort = ", - nfilter.stringShort," characters") - stop(studysideMessage, call. = FALSE) - } - -#Check length of M2.name not so long as to provide a risk of hidden code -length.M2.name<-length(unlist(strsplit(M2.name,''))) - -if(length.M2.name>nfilter.stringShort) - { - studysideMessage<- - paste0("FAILED: M2.name is too long it could hide concealed code, please shorten to <= nfilter.stringShort = ", - nfilter.stringShort," characters") - stop(studysideMessage, call. = FALSE) - } - -M1<-eval(parse(text=M1.name), envir = parent.frame()) -M2<-eval(parse(text=M2.name), envir = parent.frame()) - - - -if(!is.matrix(M1)&&!is.data.frame(M1)) - { - studysideMessage<-"FAILED: M1 must be of class matrix or data.frame, please respecify" - stop(studysideMessage, call. = FALSE) - } - -if(!is.matrix(M2)&&!is.data.frame(M2)) - { - studysideMessage<-"FAILED: M2 must be of class matrix or data.frame, please respecify" - stop(studysideMessage, call. = FALSE) - } +M2 <- .loadServersideObject(M2.name) +.checkClass(obj = M2, obj_name = M2.name, permitted_classes = c("matrix", "data.frame")) if(is.data.frame(M1)) { diff --git a/R/matrixTransposeDS.R b/R/matrixTransposeDS.R index 595d1d97..d731119d 100644 --- a/R/matrixTransposeDS.R +++ b/R/matrixTransposeDS.R @@ -9,42 +9,13 @@ #' @return Output is the matrix representing the transpose of A which is written #' to the serverside. For more details see help for ds.matrixTranspose #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' matrixTransposeDS <- function(M1.name=NULL){ -######################################################################### -# DataSHIELD MODULE: 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) # -#datashield.privacyLevel<-as.numeric(thr$datashield.privacyLevel) # -######################################################################### -#Check length of M1.name not so long as to provide a risk of hidden code -length.M1.name<-length(unlist(strsplit(M1.name,''))) - -if(length.M1.name>nfilter.stringShort) - { - studysideMessage<- - paste0("FAILED: M1.name is too long it could hide concealed code, please shorten to <= nfilter.stringShort = ", - nfilter.stringShort," characters") - stop(studysideMessage, call. = FALSE) - } - - -#EVAL M1 - -M1<-eval(parse(text=M1.name), envir = parent.frame()) - -if(!is.matrix(M1)&&!is.data.frame(M1)) - { - studysideMessage<-"FAILED: M1 must be of class matrix or data.frame, please respecify" - stop(studysideMessage, call. = FALSE) - } +M1 <- .loadServersideObject(M1.name) +.checkClass(obj = M1, obj_name = M1.name, permitted_classes = c("matrix", "data.frame")) #coerce to matrix if a data.frame if(is.data.frame(M1)) diff --git a/R/miceDS.R b/R/miceDS.R index 98904dfe..7bf0bccd 100644 --- a/R/miceDS.R +++ b/R/miceDS.R @@ -43,7 +43,8 @@ #' The function also saves in each server the mids object and all completed datasets as #' dataframes. #' @author Demetris Avraam for DataSHIELD Development Team -#' @import mice +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +#' @import mice #' @export #' miceDS <- function(data=data, m=m, maxit=maxit, method=method, post=post, seed=seed, @@ -57,7 +58,8 @@ miceDS <- function(data=data, m=m, maxit=maxit, method=method, post=post, seed=s seed <- getOption("datashield.seed") } - data <- eval(parse(text=data), envir = parent.frame()) + data <- .loadServersideObject(data) + .checkClass(obj = data, obj_name = "data", permitted_classes = c("data.frame", "matrix")) if(!is.null(method)){ method <- unlist(stringr::str_split(method, pattern=",")) diff --git a/R/rBinomDS.R b/R/rBinomDS.R index 22bcbbf3..a79428f6 100644 --- a/R/rBinomDS.R +++ b/R/rBinomDS.R @@ -15,15 +15,11 @@ #' by argument of ds.rBinom - for details see help for ds.rBinom #' May be a scalar or a vector allowing the size to vary from #' observation to observation. -#' @return Writes the pseudorandom number vector with the characteristics specified -#' in the function call as a new serverside vector on the data source on which -#' it has been called. Also returns key information to the clientside: -#' the random seed as specified by you in each -#' source + (if requested) the full 626 length random seed vector this generated in -#' each source (see info for the argument ). It -#' also returns a vector reporting the length of the pseudorandom vector -#' created in each source. +#' @return the vector of pseudorandom numbers from a binomial distribution, which +#' is written to the serverside as the object named by the argument +#' of ds.rBinom. #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export rBinomDS<-function (n, size = 1, prob = 0.5){ @@ -34,13 +30,11 @@ rBinomDS<-function (n, size = 1, prob = 0.5){ #first convert their names into the corresponding active vectors if(is.character(size)){ - command.text<-size - size<-eval(parse(text=command.text), envir = parent.frame()) + size<-.loadServersideObject(size) } if(is.character(prob)){ - command.text<-prob - prob<-eval(parse(text=command.text), envir = parent.frame()) + prob<-.loadServersideObject(prob) } stats::rbinom(n, size=size, prob=prob) diff --git a/R/rNormDS.R b/R/rNormDS.R index f50a424e..c0795201 100644 --- a/R/rNormDS.R +++ b/R/rNormDS.R @@ -20,15 +20,12 @@ #' have k decimal places. If k = 9, no rounding occurs of native output. #' Default=9. Value specified by argument #' in ds.rNorm -#' @return Writes the pseudorandom number vector with the characteristics specified -#' in the function call as a new serverside vector on the data source on which -#' it has been called. Also returns key information to the clientside: -#' the random seed as specified by you in each -#' source + (if requested) the full 626 length random seed vector this generated in -#' each source (see info for the argument ). It -#' also returns a vector reporting the length of the pseudorandom vector -#' created in each source. +#' @return the numeric vector of pseudorandom numbers from a normal distribution, +#' rounded to decimal places if that is less +#' than 9, which is written to the serverside as the object named by the +#' argument of ds.rNorm. #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export rNormDS<-function (n, mean = 0, sd = 1, force.output.to.k.decimal.places=9){ @@ -39,13 +36,11 @@ rNormDS<-function (n, mean = 0, sd = 1, force.output.to.k.decimal.places=9){ #first convert their names into the corresponding active vectors if(is.character(mean)){ - command.text<-mean - mean<-eval(parse(text=command.text), envir = parent.frame()) + mean<-.loadServersideObject(mean) } if(is.character(sd)){ - command.text<-sd - sd<-eval(parse(text=command.text), envir = parent.frame()) + sd<-.loadServersideObject(sd) } random.number.vector<-stats::rnorm(n, mean=mean, sd=sd) diff --git a/R/rPoisDS.R b/R/rPoisDS.R index 3274078c..a7bf9533 100644 --- a/R/rPoisDS.R +++ b/R/rPoisDS.R @@ -11,15 +11,11 @@ #' distribution used to generate the random counts. Specified directly #' by the lambda argument in ds.rPois. May be a scalar or a vector allowing lambda #' to vary from observation to observation. -#' @return Writes the pseudorandom number vector with the characteristics specified -#' in the function call as a new serverside vector on the data source on which -#' it has been called. Also returns key information to the clientside: -#' the random seed as specified by you in each -#' source + (if requested) the full 626 length random seed vector this generated in -#' each source (see info for the argument ). It -#' also returns a vector reporting the length of the pseudorandom vector -#' created in each source. +#' @return the vector of pseudorandom non-negative integers from a Poisson +#' distribution, which is written to the serverside as the object named by the +#' argument of ds.rPois. #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export rPoisDS<-function (n, lambda = 1){ @@ -30,8 +26,7 @@ rPoisDS<-function (n, lambda = 1){ #first convert its name into the corresponding active vectors if(is.character(lambda)){ - command.text<-lambda - lambda<-eval(parse(text=command.text), envir = parent.frame()) + lambda<-.loadServersideObject(lambda) } stats::rpois(n, lambda=lambda) diff --git a/R/rUnifDS.R b/R/rUnifDS.R index 9f4463c6..1e9c9c10 100644 --- a/R/rUnifDS.R +++ b/R/rUnifDS.R @@ -20,15 +20,12 @@ #' have k decimal places. If k = 9, no rounding occurs of native output. #' Default=9. Value specified by argument #' in ds.rUnif -#' @return Writes the pseudorandom number vector with the characteristics specified -#' in the function call as a new serverside vector on the data source on which -#' it has been called. Also returns key information to the clientside: -#' the random seed as specified by you in each -#' source + (if requested) the full 626 length random seed vector this generated in -#' each source (see info for the argument ). It -#' also returns a vector reporting the length of the pseudorandom vector -#' created in each source. +#' @return the numeric vector of pseudorandom numbers from a uniform distribution, +#' rounded to decimal places if that is less +#' than 9, which is written to the serverside as the object named by the +#' argument of ds.rUnif. #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export rUnifDS<-function (n, min = 0, max = 1, force.output.to.k.decimal.places=9){ @@ -39,13 +36,11 @@ rUnifDS<-function (n, min = 0, max = 1, force.output.to.k.decimal.places=9){ #first convert their names into the corresponding active vectors if(is.character(min)){ - command.text<-min - min<-eval(parse(text=command.text), envir = parent.frame()) + min<-.loadServersideObject(min) } if(is.character(max)){ - command.text<-max - max<-eval(parse(text=command.text), envir = parent.frame()) + max<-.loadServersideObject(max) } random.number.vector<-stats::runif(n, min=min, max=max) diff --git a/R/reShapeDS.R b/R/reShapeDS.R index 2ec368a5..64acb279 100644 --- a/R/reShapeDS.R +++ b/R/reShapeDS.R @@ -35,18 +35,16 @@ #' @return a reshaped data.frame converted from long to wide format or from wide to #' long format which is written to the serverside and given the name provided as the #' argument of \code{ds.reShape} or 'newObject' if no name is specified. -#' In addition, two validity messages are returned to the clientside -#' indicating whether has been created in each data source and if so whether -#' it is in a valid form (see header for \code{ds.reShape}. #' @author Demetris Avraam, Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export reShapeDS <- function(data.name, varying.transmit, v.names.transmit, timevar.name, idvar.name, drop.transmit, direction, sep){ # Check Permissive Privacy Control Level. dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot')) - datatext <- paste0("data.frame(",data.name,")") - data <- eval(parse(text=datatext), envir = parent.frame()) + data <- .loadServersideObject(data.name) + data <- data.frame(data) timevar <- timevar.name idvar <- idvar.name diff --git a/R/sampleDS.R b/R/sampleDS.R index 1c5bd43f..213451dd 100644 --- a/R/sampleDS.R +++ b/R/sampleDS.R @@ -30,6 +30,7 @@ #' 'newobj.sample') which is written to the serverside. For further details see #' help for ds.sample and native R help for sample(). #' @author Paul Burton, for DataSHIELD Development Team, 15/4/2020 +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export sampleDS <- function(x.transmit, size.transmit, replace.transmit=NULL, prob.transmit=NULL){ @@ -82,7 +83,7 @@ sampleDS <- function(x.transmit, size.transmit, replace.transmit=NULL, prob.tran #Activate and if they are character strings if(is.character(x.transmit)) { - x.active<-eval(parse(text=x.transmit), envir = parent.frame()) + x.active<-.loadServersideObject(x.transmit) if(is.data.frame(x.active)||is.matrix(x.active)) { @@ -152,7 +153,7 @@ sampleDS <- function(x.transmit, size.transmit, replace.transmit=NULL, prob.tran prob.active<-NULL if(is.character(prob.transmit)) { - prob.active<-eval(parse(text=prob.transmit), envir = parent.frame()) + prob.active<-.loadServersideObject(prob.transmit) } #Check size <= length(x.active) if replace.transmit==FALSE diff --git a/R/scatterPlotDS.R b/R/scatterPlotDS.R index ab48be10..3599c8f0 100644 --- a/R/scatterPlotDS.R +++ b/R/scatterPlotDS.R @@ -14,8 +14,8 @@ #' and variance equal to 10% of the true variance of $x$ and $y$ respectively. To avoid inferential #' disclosure we fix the random number generator in a value that is specified by the input #' variables. Thus the function returns always the same noisy data for a given pair of variables. -#' @param x the name of a numeric vector, the x-variable. -#' @param y the name of a numeric vector, the y-variable. +#' @param x.name a character string providing the name of a server-side numeric vector, the x-variable. +#' @param y.name a character string providing the name of a server-side numeric vector, the y-variable. #' @param method.indicator an integer either 1 or 2. If the user selects the deterministic #' method in the client side function the method.indicator is set to 1 while if the user selects #' the probabilistic method this argument is set to 2. @@ -23,12 +23,19 @@ #' deterministic method is selected. #' @param noise the percentage of the initial variance that is used as the variance of the embedded #' noise if the probabilistic method is selected. -#' @return a list with the x and y coordinates of the data to be plot +#' @return a list with the x and y coordinates of the data to be plot, along with the classes of +#' the x and y inputs (\code{class.x} and \code{class.y}) #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' -scatterPlotDS <- function(x, y, method.indicator, k, noise){ - +scatterPlotDS <- function(x.name, y.name, method.indicator, k, noise){ + + x <- .loadServersideObject(x.name) + y <- .loadServersideObject(y.name) + .checkClass(obj = x, obj_name = x.name, permitted_classes = c("numeric", "integer")) + .checkClass(obj = y, obj_name = y.name, permitted_classes = c("numeric", "integer")) + ################################################################### # MODULE 1: CAPTURE THE nfilter SETTINGS # thr <- dsBase::listDisclosureSettingsDS() # @@ -131,8 +138,8 @@ scatterPlotDS <- function(x, y, method.indicator, k, noise){ } # Return a list with the x and y coordinates of the centroids - return(list(x.new, y.new)) - + return(list(x.new, y.new, class.x=class(x), class.y=class(y))) + } # AGGREGATE FUNCTION # scatterPlotDS diff --git a/R/setSeedDS.R b/R/setSeedDS.R index 6515d51a..bead37b7 100644 --- a/R/setSeedDS.R +++ b/R/setSeedDS.R @@ -32,13 +32,18 @@ #' .Random.seed on each data source that is the true current state of the #' random seed in each source. #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export setSeedDS<-function (seedtext=NULL, kind = NULL, normal.kind = NULL) { # Check Permissive Privacy Control Level. dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'avocado')) - seed<-eval(parse(text=seedtext), envir = parent.frame()) + if(is.null(seedtext) || seedtext == "NULL"){ + seed <- NULL + } else { + seed <- as.integer(seedtext) + } set.seed(seed,kind,normal.kind) return(list(seed.as.set=.Random.seed)) } diff --git a/azure-pipelines.yml b/azure-pipelines.yml index 7eb3e47e..94c767e9 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -108,19 +108,12 @@ jobs: sudo apt-get install -qq libxml2-dev libcurl4-openssl-dev libssl-dev libgit2-dev libharfbuzz-dev libfribidi-dev libfontconfig1-dev -y sudo apt-get install -qq libfreetype6-dev libpng-dev libtiff5-dev libjpeg-dev libuv1-dev -y sudo apt-get install -qq r-base -y - sudo R -e "install.packages('devtools', dependencies=TRUE)" - sudo R -e "install.packages('RANN', dependencies=TRUE)" - sudo R -e "install.packages('stringr', dependencies=TRUE)" - sudo R -e "install.packages('lme4', dependencies=TRUE)" - sudo R -e "install.packages('dplyr', dependencies=TRUE)" - sudo R -e "install.packages('reshape2', dependencies=TRUE)" - sudo R -e "install.packages('polycor', dependencies=TRUE)" - sudo R -e "install.packages('splines', dependencies=TRUE)" - sudo R -e "install.packages('gamlss', dependencies=TRUE)" - sudo R -e "install.packages('gamlss.dist', dependencies=TRUE)" - sudo R -e "install.packages('mice', dependencies=TRUE)" - sudo R -e "install.packages('data.table', dependencies=TRUE)" - sudo R -e "install.packages('childsds', dependencies=TRUE)" + + # Use Posit Public Package Manager, which serves precompiled binary packages + # for this Ubuntu release instead of source - so dependencies are downloaded + # rather than compiled (the slow part). The HTTPUserAgent option is what makes + # the manager hand back binaries. + sudo R -q -e "options(repos=c(CRAN=paste0('https://packagemanager.posit.co/cran/__linux__/', system('lsb_release -cs', intern=TRUE), '/latest')), HTTPUserAgent=sprintf('R/%s R (%s)', getRversion(), paste(getRversion(), R.version\$platform, R.version\$arch, R.version\$os)), Ncpus=4); install.packages(c('devtools','RANN','stringr','lme4','dplyr','reshape2','polycor','splines','gamlss','gamlss.dist','mice','data.table','childsds'), dependencies=TRUE)" displayName: 'Install all dependencies for dsBase' condition: succeeded() diff --git a/man/asFactorDS1.Rd b/man/asFactorDS1.Rd index f337a23e..69d8ca34 100644 --- a/man/asFactorDS1.Rd +++ b/man/asFactorDS1.Rd @@ -21,3 +21,6 @@ The function encodes the input vector as factor and returns its levels in ascending order if the levels are numerical or in alphabetical order if the levels are of type character. } +\author{ +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +} diff --git a/man/asFactorDS2.Rd b/man/asFactorDS2.Rd index 16b4a50f..006e2bac 100644 --- a/man/asFactorDS2.Rd +++ b/man/asFactorDS2.Rd @@ -37,3 +37,6 @@ The functions converts the input variable into a factor which is presented as a if the \code{fixed.dummy.vars} is set to FALSE or as a matrix with dummy variables if the \code{fixed.dummy.vars} is set to TRUE (see the help file of ds.asFactor.b for more details). } +\author{ +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +} diff --git a/man/asFactorSimpleDS.Rd b/man/asFactorSimpleDS.Rd index d0916749..2b234c9a 100644 --- a/man/asFactorSimpleDS.Rd +++ b/man/asFactorSimpleDS.Rd @@ -26,3 +26,6 @@ In addition, it does not allow you to create an array of binary dummy variables that is equivalent to a factor. If you need to do any of these things you will have to use the ds.asFactor function. } +\author{ +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +} diff --git a/man/boxPlotGGDS.Rd b/man/boxPlotGGDS.Rd index 3633b943..b0d325ac 100644 --- a/man/boxPlotGGDS.Rd +++ b/man/boxPlotGGDS.Rd @@ -4,10 +4,10 @@ \alias{boxPlotGGDS} \title{Create the identity stats and necessary data to draw a plot on the client} \usage{ -boxPlotGGDS(data_table, group = NULL, group2 = NULL) +boxPlotGGDS(data_table.name, group = NULL, group2 = NULL) } \arguments{ -\item{data_table}{\code{data frame} Table that holds the information to be plotted, arranged as: \cr +\item{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 @@ -29,3 +29,6 @@ is purely geometrical aspects of the plot, as a ggplot object contains all the d parameters are passed. There are three different cases depending if there are grouping variables. The outliers are also removed from the graphical parameters. } +\author{ +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +} diff --git a/man/boxPlotGG_data_TreatmentDS.Rd b/man/boxPlotGG_data_TreatmentDS.Rd index a1ba9781..a38e838e 100644 --- a/man/boxPlotGG_data_TreatmentDS.Rd +++ b/man/boxPlotGG_data_TreatmentDS.Rd @@ -4,10 +4,10 @@ \alias{boxPlotGG_data_TreatmentDS} \title{Arrange data frame to pass it to the boxplot function} \usage{ -boxPlotGG_data_TreatmentDS(table, variables, group = NULL, group2 = NULL) +boxPlotGG_data_TreatmentDS(table.name, variables, group = NULL, group2 = NULL) } \arguments{ -\item{table}{\code{data frame} Table that holds the information to be plotted later} +\item{table.name}{\code{character} Name of a server-side data frame that holds the information to be plotted later} \item{variables}{\code{character vector} Name of the column(s) of the data frame to include on the boxplot} @@ -26,3 +26,6 @@ boxPlotGG_data_TreatmentDS(table, variables, group = NULL, group2 = NULL) \description{ Arrange data frame to pass it to the boxplot function } +\author{ +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +} diff --git a/man/boxPlotGG_data_Treatment_numericDS.Rd b/man/boxPlotGG_data_Treatment_numericDS.Rd index 914493b6..d43e961d 100644 --- a/man/boxPlotGG_data_Treatment_numericDS.Rd +++ b/man/boxPlotGG_data_Treatment_numericDS.Rd @@ -4,17 +4,20 @@ \alias{boxPlotGG_data_Treatment_numericDS} \title{Arrange vector to pass it to the boxplot function} \usage{ -boxPlotGG_data_Treatment_numericDS(vector) +boxPlotGG_data_Treatment_numericDS(vector.name) } \arguments{ -\item{vector}{\code{numeric vector} Vector to arrange to be plotted later} +\item{vector.name}{\code{character} Name of a server-side numeric vector to arrange to be plotted later} } \value{ \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 } \description{ Arrange vector to pass it to the boxplot function } +\author{ +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +} diff --git a/man/changeRefGroupDS.Rd b/man/changeRefGroupDS.Rd index 05fe80cf..7183edc9 100644 --- a/man/changeRefGroupDS.Rd +++ b/man/changeRefGroupDS.Rd @@ -4,18 +4,18 @@ \alias{changeRefGroupDS} \title{Changes a reference level of a factor} \usage{ -changeRefGroupDS(xvect, ref = NULL, reorderByRef = NULL) +changeRefGroupDS(x, ref = NULL, reorderByRef = NULL) } \arguments{ -\item{xvect}{a factor vector} +\item{x}{a character string, the name of a factor vector.} \item{ref}{a character, the reference level} -\item{reorderByRef}{a boolean that tells whether or not the new +\item{reorderByRef}{a boolean that tells whether or not the new vector should be ordered by the reference group.} } \value{ -a factor of the same length as xvect +a factor of the same length as the input vector } \description{ This function is similar to R function \code{relevel}, @@ -30,4 +30,6 @@ can render the results of operations on that table invalid. } \author{ Isaeva, J., Gaye, A. + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/densityGridDS.Rd b/man/densityGridDS.Rd index 2b254acf..8a8c1ee0 100644 --- a/man/densityGridDS.Rd +++ b/man/densityGridDS.Rd @@ -5,8 +5,8 @@ \title{Generates a density grid with or without a priori defined limits} \usage{ densityGridDS( - xvect, - yvect, + x, + y, limits = FALSE, x.min = NULL, x.max = NULL, @@ -16,12 +16,12 @@ densityGridDS( ) } \arguments{ -\item{xvect}{a numerical vector} +\item{x}{a character string providing the name of a server-side numerical vector} -\item{yvect}{a numerical vector} +\item{y}{a character string providing the name of a server-side numerical vector} \item{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.} \item{x.min}{a minimum value for the x axis of the grid density object, if needed} @@ -35,7 +35,8 @@ If \code{limits} is set to "TRUE", limits defined by x.min, x.max, y.min and y.m \item{numints}{a number of intervals for the grid density object, by default is 20} } \value{ -a grid density matrix +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}) } \description{ Generates a density grid that can then be used for heatmap or contour plots. @@ -46,4 +47,6 @@ counts in table cells) are turn to 0. } \author{ Julia Isaeva, Amadou Gaye, Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/gamlssDS.Rd b/man/gamlssDS.Rd index 218eb4ac..ca538529 100644 --- a/man/gamlssDS.Rd +++ b/man/gamlssDS.Rd @@ -116,4 +116,6 @@ functions in native R gamlss package. } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/glmDS1.Rd b/man/glmDS1.Rd index e0b0b332..95ddb710 100644 --- a/man/glmDS1.Rd +++ b/man/glmDS1.Rd @@ -36,4 +36,6 @@ been specified. For more details please see the extensive header for ds.glm. } \author{ Burton PR for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/glmDS2.Rd b/man/glmDS2.Rd index 36731d5f..7edc7007 100644 --- a/man/glmDS2.Rd +++ b/man/glmDS2.Rd @@ -40,4 +40,6 @@ For more details please see the extensive header for ds.glm. } \author{ Paul Burton, for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/glmPredictDS.ag.Rd b/man/glmPredictDS.ag.Rd index 2de27645..cdeb0ef4 100644 --- a/man/glmPredictDS.ag.Rd +++ b/man/glmPredictDS.ag.Rd @@ -63,4 +63,6 @@ ds.glmPredict and glmPredict.as and help in native R for predict.glm } \author{ Paul Burton for DataSHIELD Development Team (20/7/20) + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/glmPredictDS.as.Rd b/man/glmPredictDS.as.Rd index 7395773e..ec757e8c 100644 --- a/man/glmPredictDS.as.Rd +++ b/man/glmPredictDS.as.Rd @@ -61,4 +61,6 @@ for predict.glm } \author{ Paul Burton for DataSHIELD Development Team (20/7/20) + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/glmSLMADS1.Rd b/man/glmSLMADS1.Rd index e08e7076..b8de3fb4 100644 --- a/man/glmSLMADS1.Rd +++ b/man/glmSLMADS1.Rd @@ -37,4 +37,6 @@ For more detailed information see help for ds.glmSLMA. } \author{ Paul Burton for DataSHIELD Development Team (14/7/20) + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/glmSLMADS2.Rd b/man/glmSLMADS2.Rd index d5cfa9b0..3b59bd15 100644 --- a/man/glmSLMADS2.Rd +++ b/man/glmSLMADS2.Rd @@ -43,4 +43,6 @@ For more detailed information see help for ds.glmSLMA. } \author{ Paul Burton for DataSHIELD Development Team (14/7/20) + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/glmSummaryDS.ag.Rd b/man/glmSummaryDS.ag.Rd index d64a6218..8b8632c9 100644 --- a/man/glmSummaryDS.ag.Rd +++ b/man/glmSummaryDS.ag.Rd @@ -32,4 +32,6 @@ and its corresponding summary_glm object. } \author{ Paul Burton for DataSHIELD Development Team (20/7/20) + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/glmSummaryDS.as.Rd b/man/glmSummaryDS.as.Rd index e2067100..68ddcce6 100644 --- a/man/glmSummaryDS.as.Rd +++ b/man/glmSummaryDS.as.Rd @@ -30,4 +30,6 @@ for glm() and summary.glm } \author{ Paul Burton for DataSHIELD Development Team (20/7/20) + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/glmerSLMADS.assign.Rd b/man/glmerSLMADS.assign.Rd index 6db1196d..a58f364e 100644 --- a/man/glmerSLMADS.assign.Rd +++ b/man/glmerSLMADS.assign.Rd @@ -67,4 +67,6 @@ from each single data source and saves the regression outcomes on the serverside } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/glmerSLMADS2.Rd b/man/glmerSLMADS2.Rd index aee4d44c..1086da95 100644 --- a/man/glmerSLMADS2.Rd +++ b/man/glmerSLMADS2.Rd @@ -74,4 +74,6 @@ glmes using the glmer engine can be obtained using R help for glmer and the lme4 } \author{ Tom Bishop, with some additions by Paul Burton + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/heatmapPlotDS.Rd b/man/heatmapPlotDS.Rd index 950dbace..f10c3e21 100644 --- a/man/heatmapPlotDS.Rd +++ b/man/heatmapPlotDS.Rd @@ -4,12 +4,12 @@ \alias{heatmapPlotDS} \title{Calculates the coordinates of the centroid of each n nearest neighbours} \usage{ -heatmapPlotDS(x, y, k, noise, method.indicator) +heatmapPlotDS(x.name, y.name, k, noise, method.indicator) } \arguments{ -\item{x}{the name of a numeric vector, the x-variable.} +\item{x.name}{a character string providing the name of a server-side numeric vector, the x-variable.} -\item{y}{the name of a numeric vector, the y-variable.} +\item{y.name}{a character string providing the name of a server-side numeric vector, the y-variable.} \item{k}{the number of the nearest neighbours for which their centroid is calculated if the \code{method.indicator} is equal to 1 (i.e. deterministic method).} @@ -22,7 +22,8 @@ noise if the \code{method.indicator} is equal to 2 (i.e. probabilistic method).} } \value{ a list with the x and y coordinates of the centroids if the deterministic method is used -or the x and y coordinated of the noisy data if the probabilistic method is used. +or the x and y coordinated of the noisy data if the probabilistic method is used, along with the +classes of the x and y inputs (\code{class.x} and \code{class.y}) } \description{ This function calculates the coordinates of the centroids for each n nearest neighbours. @@ -39,4 +40,6 @@ plot of non-disclosive graphs (e.g. scatter plots, heatmap plots, contour plots, } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/histogramDS1.Rd b/man/histogramDS1.Rd index a8e8a551..129ed632 100644 --- a/man/histogramDS1.Rd +++ b/man/histogramDS1.Rd @@ -4,10 +4,10 @@ \alias{histogramDS1} \title{returns the minimum and the maximum of the input numeric vector} \usage{ -histogramDS1(xvect, method.indicator, k, noise) +histogramDS1(x, method.indicator, k, noise) } \arguments{ -\item{xvect}{the numeric vector for which the histogram is desired.} +\item{x}{a character string providing the name of the server-side numeric vector for which the histogram is desired.} \item{method.indicator}{a number equal to either 1, 2 or 3 indicating the method of disclosure control that is used for the generation of the histogram. If the value is equal to 1 then the @@ -21,7 +21,8 @@ If the value is set to 3 then the 'probabilistic' method is used.} noise if the \code{method.indicator} is equal to 3 (i.e. probabilistic method).} } \value{ -a numeric vector which contains the minimum and the maximum values of the vector +a list with the numeric vector containing the minimum and the maximum values of the +vector (\code{range}) and the class of the input vector (\code{class}) } \description{ this function returns the minimum and maximum of the input numeric vector which @@ -34,4 +35,6 @@ minimum and maximum values of the generated 'noisy' vector. } \author{ Amadou Gaye, Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/histogramDS2.Rd b/man/histogramDS2.Rd index 76bf8ea3..17ea4261 100644 --- a/man/histogramDS2.Rd +++ b/man/histogramDS2.Rd @@ -4,10 +4,10 @@ \alias{histogramDS2} \title{Computes a histogram of the input variable without plotting.} \usage{ -histogramDS2(xvect, num.breaks, min, max, method.indicator, k, noise) +histogramDS2(x, num.breaks, min, max, method.indicator, k, noise) } \arguments{ -\item{xvect}{the numeric vector for which the histogram is desired.} +\item{x}{a character string providing the name of the server-side numeric vector for which the histogram is desired.} \item{num.breaks}{the number of breaks that the range of the variable is divided.} @@ -41,4 +41,6 @@ Please find more details in the documentation of the clientside ds.histogram fun } \author{ Amadou Gaye, Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/lmerSLMADS.assign.Rd b/man/lmerSLMADS.assign.Rd index cc2ff9f0..e47edd87 100644 --- a/man/lmerSLMADS.assign.Rd +++ b/man/lmerSLMADS.assign.Rd @@ -52,4 +52,6 @@ effects - on data from each single data source and saves the regression outcomes } \author{ TDemetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/lmerSLMADS2.Rd b/man/lmerSLMADS2.Rd index 98a29e1e..ba1f4260 100644 --- a/man/lmerSLMADS2.Rd +++ b/man/lmerSLMADS2.Rd @@ -61,4 +61,6 @@ the lme4 package } \author{ Tom Bishop, with some additions by Paul Burton + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/matrixDS.Rd b/man/matrixDS.Rd index 11a86cef..d674f5f9 100644 --- a/man/matrixDS.Rd +++ b/man/matrixDS.Rd @@ -43,4 +43,6 @@ and assigns the values of all its elements based on the argument } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/matrixDetDS1.Rd b/man/matrixDetDS1.Rd index ab20b8f9..5a97372e 100644 --- a/man/matrixDetDS1.Rd +++ b/man/matrixDetDS1.Rd @@ -28,4 +28,6 @@ possible if the number of columns and rows of A are the same. } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/matrixDetDS2.Rd b/man/matrixDetDS2.Rd index b238a3d9..97fd5b94 100644 --- a/man/matrixDetDS2.Rd +++ b/man/matrixDetDS2.Rd @@ -28,4 +28,6 @@ possible if the number of columns and rows of A are the same. } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/matrixDiagDS.Rd b/man/matrixDiagDS.Rd index 21910204..aeeb90c4 100644 --- a/man/matrixDiagDS.Rd +++ b/man/matrixDiagDS.Rd @@ -35,4 +35,6 @@ For details see help for function \code{ds.matrixDiag}. } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/matrixDimnamesDS.Rd b/man/matrixDimnamesDS.Rd index 814177a6..eb008317 100644 --- a/man/matrixDimnamesDS.Rd +++ b/man/matrixDimnamesDS.Rd @@ -35,4 +35,6 @@ function \code{ds.matrixDimnames} } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/matrixInvertDS.Rd b/man/matrixInvertDS.Rd index 2588e500..728edb18 100644 --- a/man/matrixInvertDS.Rd +++ b/man/matrixInvertDS.Rd @@ -23,4 +23,6 @@ is non-singular - positive definite (eg there is no row or column that is all ze } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/matrixMultDS.Rd b/man/matrixMultDS.Rd index cac0958e..7247c22d 100644 --- a/man/matrixMultDS.Rd +++ b/man/matrixMultDS.Rd @@ -29,4 +29,6 @@ is only valid if the number of columns of A is the same as the number of rows of } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/matrixTransposeDS.Rd b/man/matrixTransposeDS.Rd index c05aac4e..591c8c7f 100644 --- a/man/matrixTransposeDS.Rd +++ b/man/matrixTransposeDS.Rd @@ -24,4 +24,6 @@ vice versa. } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/miceDS.Rd b/man/miceDS.Rd index dd04c30c..e9496da8 100644 --- a/man/miceDS.Rd +++ b/man/miceDS.Rd @@ -78,4 +78,6 @@ package. } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/rBinomDS.Rd b/man/rBinomDS.Rd index 9a3fc25e..11c527a0 100644 --- a/man/rBinomDS.Rd +++ b/man/rBinomDS.Rd @@ -22,14 +22,9 @@ May be a scalar or a vector allowing the size to vary from observation to observation.} } \value{ -Writes the pseudorandom number vector with the characteristics specified -in the function call as a new serverside vector on the data source on which -it has been called. Also returns key information to the clientside: -the random seed as specified by you in each -source + (if requested) the full 626 length random seed vector this generated in -each source (see info for the argument ). It -also returns a vector reporting the length of the pseudorandom vector -created in each source. +the vector of pseudorandom numbers from a binomial distribution, which +is written to the serverside as the object named by the argument +of ds.rBinom. } \description{ primary serverside assign function called by ds.rBinom @@ -42,4 +37,6 @@ the function rbinom() in native R and its arguments are the same. } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/rNormDS.Rd b/man/rNormDS.Rd index ef7ea58d..2ae0d082 100644 --- a/man/rNormDS.Rd +++ b/man/rNormDS.Rd @@ -28,14 +28,10 @@ Default=9. Value specified by argument in ds.rNorm} } \value{ -Writes the pseudorandom number vector with the characteristics specified -in the function call as a new serverside vector on the data source on which -it has been called. Also returns key information to the clientside: -the random seed as specified by you in each -source + (if requested) the full 626 length random seed vector this generated in -each source (see info for the argument ). It -also returns a vector reporting the length of the pseudorandom vector -created in each source. +the numeric vector of pseudorandom numbers from a normal distribution, +rounded to decimal places if that is less +than 9, which is written to the serverside as the object named by the +argument of ds.rNorm. } \description{ primary serverside assign function called by ds.rNorm @@ -48,4 +44,6 @@ the function rnorm() in native R and its arguments are the same. } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/rPoisDS.Rd b/man/rPoisDS.Rd index 73fcdee0..d6c6edc1 100644 --- a/man/rPoisDS.Rd +++ b/man/rPoisDS.Rd @@ -16,14 +16,9 @@ by the lambda argument in ds.rPois. May be a scalar or a vector allowing lambda to vary from observation to observation.} } \value{ -Writes the pseudorandom number vector with the characteristics specified -in the function call as a new serverside vector on the data source on which -it has been called. Also returns key information to the clientside: -the random seed as specified by you in each -source + (if requested) the full 626 length random seed vector this generated in -each source (see info for the argument ). It -also returns a vector reporting the length of the pseudorandom vector -created in each source. +the vector of pseudorandom non-negative integers from a Poisson +distribution, which is written to the serverside as the object named by the + argument of ds.rPois. } \description{ primary serverside assign function called by ds.rPois @@ -37,4 +32,6 @@ and its arguments are the same. } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/rUnifDS.Rd b/man/rUnifDS.Rd index c9b448ea..491bcd07 100644 --- a/man/rUnifDS.Rd +++ b/man/rUnifDS.Rd @@ -28,14 +28,10 @@ Default=9. Value specified by argument in ds.rUnif} } \value{ -Writes the pseudorandom number vector with the characteristics specified -in the function call as a new serverside vector on the data source on which -it has been called. Also returns key information to the clientside: -the random seed as specified by you in each -source + (if requested) the full 626 length random seed vector this generated in -each source (see info for the argument ). It -also returns a vector reporting the length of the pseudorandom vector -created in each source. +the numeric vector of pseudorandom numbers from a uniform distribution, +rounded to decimal places if that is less +than 9, which is written to the serverside as the object named by the +argument of ds.rUnif. } \description{ primary serverside assign function called by ds.rUnif @@ -48,4 +44,6 @@ the function runif() in native R and its arguments are the same. } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/reShapeDS.Rd b/man/reShapeDS.Rd index 2a0ace77..d61b9f54 100644 --- a/man/reShapeDS.Rd +++ b/man/reShapeDS.Rd @@ -54,9 +54,6 @@ via argument of \code{ds.reShape} function} a reshaped data.frame converted from long to wide format or from wide to long format which is written to the serverside and given the name provided as the argument of \code{ds.reShape} or 'newObject' if no name is specified. -In addition, two validity messages are returned to the clientside -indicating whether has been created in each data source and if so whether -it is in a valid form (see header for \code{ds.reShape}. } \description{ Reshapes a data frame containing longitudinal or @@ -71,4 +68,6 @@ measurements in separate records. The reshaping can be in either direction } \author{ Demetris Avraam, Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/sampleDS.Rd b/man/sampleDS.Rd index c3d2ead7..aae770f8 100644 --- a/man/sampleDS.Rd +++ b/man/sampleDS.Rd @@ -54,4 +54,6 @@ help for ds.sample and native R help for sample(). } \author{ Paul Burton, for DataSHIELD Development Team, 15/4/2020 + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/scatterPlotDS.Rd b/man/scatterPlotDS.Rd index 7b2709fd..96a08442 100644 --- a/man/scatterPlotDS.Rd +++ b/man/scatterPlotDS.Rd @@ -4,12 +4,12 @@ \alias{scatterPlotDS} \title{Calculates the coordinates of the data to be plot} \usage{ -scatterPlotDS(x, y, method.indicator, k, noise) +scatterPlotDS(x.name, y.name, method.indicator, k, noise) } \arguments{ -\item{x}{the name of a numeric vector, the x-variable.} +\item{x.name}{a character string providing the name of a server-side numeric vector, the x-variable.} -\item{y}{the name of a numeric vector, the y-variable.} +\item{y.name}{a character string providing the name of a server-side numeric vector, the y-variable.} \item{method.indicator}{an integer either 1 or 2. If the user selects the deterministic method in the client side function the method.indicator is set to 1 while if the user selects @@ -22,7 +22,8 @@ deterministic method is selected.} noise if the probabilistic method is selected.} } \value{ -a list with the x and y coordinates of the data to be plot +a list with the x and y coordinates of the data to be plot, along with the classes of +the x and y inputs (\code{class.x} and \code{class.y}) } \description{ This function uses two disclosure control methods to generate non-disclosive @@ -44,4 +45,6 @@ variables. Thus the function returns always the same noisy data for a given pair } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/setSeedDS.Rd b/man/setSeedDS.Rd index 9c8c2740..6531b5f2 100644 --- a/man/setSeedDS.Rd +++ b/man/setSeedDS.Rd @@ -50,4 +50,6 @@ theoretical work with random number generators it is likely that the } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/tests/testthat/test-smk-asFactorDS1.R b/tests/testthat/test-smk-asFactorDS1.R index a990d4ff..e7f0abb8 100644 --- a/tests/testthat/test-smk-asFactorDS1.R +++ b/tests/testthat/test-smk-asFactorDS1.R @@ -21,7 +21,6 @@ set.standard.disclosure.settings() # Tests # -# context("asFactorDS1::smk::simple") test_that("simple asFactorDS1", { input <- c(2.0, 1.0, 3.0, 3.0, 3.0, 1.0, 2.0, 2.0, 1.0, 2.0) @@ -34,10 +33,6 @@ test_that("simple asFactorDS1", { expect_equal(res[3], "3") }) -# -# Done -# - -# context("asFactorDS1::smk::shutdown") - -# context("asFactorDS1::smk::done") +test_that("asFactorDS1 errors when serverside object does not exist", { + expect_error(asFactorDS1("nonexistent_object"), regexp = "does not exist") +}) diff --git a/tests/testthat/test-smk-asFactorDS2.R b/tests/testthat/test-smk-asFactorDS2.R index 1c761d4d..d9f2ae83 100644 --- a/tests/testthat/test-smk-asFactorDS2.R +++ b/tests/testthat/test-smk-asFactorDS2.R @@ -20,99 +20,29 @@ set.standard.disclosure.settings() # Tests # -# context("asFactorDS2::smk::simple") -test_that("simple asFactorDS2, fixed.dummy.vars is FALSE", { - input <- c(2, 1, 3, 3, 3, 1, 2, 2, 1, 2) - all.unique.levels.transmit <- "1,2,3,4" - fixed.dummy.vars <- FALSE - baseline.level <- NULL +test_that("simple asFactorDS2", { + input <- c(2, 1, 3, 3, 3, 1, 2, 2, 1, 2) - res <- asFactorDS2("input", all.unique.levels.transmit, fixed.dummy.vars, baseline.level) + res <- asFactorDS2("input", "1,2,3,4", FALSE, NULL) expect_equal(class(res), "factor") expect_length(res, 10) - - res.levels <- levels(res) - - expect_equal(class(res.levels), "character") - expect_length(res.levels, 4) - - expect_equal(res.levels[1], "1") - expect_equal(res.levels[2], "2") - expect_equal(res.levels[3], "3") - expect_equal(res.levels[4], "4") + expect_equal(levels(res), c("1", "2", "3", "4")) }) -test_that("simple asFactorDS2, fixed.dummy.vars is TRUE", { - input <- c(2, 1, 3, 3, 3, 1, 2, 2, 1, 2) - all.unique.levels.transmit <- "1,2,3,4" - fixed.dummy.vars <- TRUE - baseline.level <- 1.0 - - res <- asFactorDS2("input", all.unique.levels.transmit, fixed.dummy.vars, baseline.level) - - expect_length(res, 30) - - res.class <- class(res) - - if (base::getRversion() < '4.0.0') - { - expect_length(res.class, 1) - expect_true("matrix" %in% res.class) - } - else - { - expect_length(res.class, 2) - expect_true("matrix" %in% res.class) - expect_true("array" %in% res.class) - } - - expect_equal(res[1], 1) - expect_equal(res[2], 0) - expect_equal(res[3], 0) - expect_equal(res[4], 0) - expect_equal(res[5], 0) - expect_equal(res[6], 0) - expect_equal(res[7], 1) - expect_equal(res[8], 1) - expect_equal(res[9], 0) - expect_equal(res[10], 1) - expect_equal(res[11], 0) - expect_equal(res[12], 0) - expect_equal(res[13], 1) - expect_equal(res[14], 1) - expect_equal(res[15], 1) - expect_equal(res[16], 0) - expect_equal(res[17], 0) - expect_equal(res[18], 0) - expect_equal(res[19], 0) - expect_equal(res[20], 0) - expect_equal(res[21], 0) - expect_equal(res[22], 0) - expect_equal(res[23], 0) - expect_equal(res[24], 0) - expect_equal(res[25], 0) - expect_equal(res[26], 0) - expect_equal(res[27], 0) - expect_equal(res[28], 0) - expect_equal(res[29], 0) - expect_equal(res[30], 0) +test_that("asFactorDS2 with fixed dummy variables", { + input <- c(2, 1, 3, 3, 3, 1, 2, 2, 1, 2) + res <- asFactorDS2("input", "1,2,3,4", TRUE, 1) - res.colnames <- colnames(res) - - expect_equal(class(res.colnames), "character") - expect_length(res.colnames, 3) - - expect_equal(res.colnames[1], "DV2") - expect_equal(res.colnames[2], "DV3") - expect_equal(res.colnames[3], "DV4") + expect_true(is.matrix(res)) + expect_equal(dim(res), c(10L, 3L)) + expect_equal(colnames(res), c("DV2", "DV3", "DV4")) + expect_equal(unname(res[, "DV2"]), c(1, 0, 0, 0, 0, 0, 1, 1, 0, 1)) + expect_equal(unname(res[, "DV3"]), c(0, 0, 1, 1, 1, 0, 0, 0, 0, 0)) + expect_equal(unname(res[, "DV4"]), rep(0, 10)) }) -# -# Done -# - -# context("asFactorDS2::smk::shutdown") - -# context("asFactorDS2::smk::done") +test_that("asFactorDS2 errors when serverside object does not exist", { + expect_error(asFactorDS2("nonexistent_object", "1,2", FALSE, NULL), regexp = "does not exist") +}) diff --git a/tests/testthat/test-smk-asFactorSimpleDS.R b/tests/testthat/test-smk-asFactorSimpleDS.R index 7e871da3..97a3e36f 100644 --- a/tests/testthat/test-smk-asFactorSimpleDS.R +++ b/tests/testthat/test-smk-asFactorSimpleDS.R @@ -20,38 +20,17 @@ set.standard.disclosure.settings() # Tests # -# context("asFactorSimpleDS::smk::simple") test_that("simple asFactorSimpleDS", { - input <- c(2.0, 1.0, 3.0, 3.0, 3.0, 1.0, 2.0, 2.0, 1.0, 2.0) + input <- c(2, 1, 3, 3, 3, 1, 2, 2, 1, 2) res <- asFactorSimpleDS("input") expect_equal(class(res), "factor") expect_length(res, 10) - expect_true(res[1] == "2") - expect_true(res[2] == "1") - expect_true(res[3] == "3") - expect_true(res[4] == "3") - expect_true(res[5] == "3") - expect_true(res[6] == "1") - expect_true(res[7] == "2") - expect_true(res[8] == "2") - expect_true(res[9] == "1") - expect_true(res[10] == "2") - - res.levels <- levels(res) - - expect_equal(class(res.levels), "character") - expect_length(res.levels, 3) - expect_equal(res.levels[1], "1") - expect_equal(res.levels[2], "2") - expect_equal(res.levels[3], "3") + expect_equal(levels(res), c("1", "2", "3")) + expect_equal(as.character(res), as.character(input)) }) -# -# Done -# - -# context("asFactorSimpleDS::smk::shutdown") - -# context("asFactorSimpleDS::smk::done") +test_that("asFactorSimpleDS errors when serverside object does not exist", { + expect_error(asFactorSimpleDS("nonexistent_object"), regexp = "does not exist") +}) diff --git a/tests/testthat/test-smk-boxPlotGGDS.R b/tests/testthat/test-smk-boxPlotGGDS.R new file mode 100644 index 00000000..fe7db46e --- /dev/null +++ b/tests/testthat/test-smk-boxPlotGGDS.R @@ -0,0 +1,42 @@ +# +# Set up +# + +# context("boxPlotGGDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("boxPlotGGDS::smk") +test_that("boxPlotGGDS, no grouping", { + boxPlotRawData <- data.frame(x = rep("v1", 20), value = c(1:20)) + + res <- boxPlotGGDS("boxPlotRawData") + + expect_length(res, 2) + expect_equal(res[[2]], "no_group") +}) + +test_that("boxPlotGGDS, single grouping", { + boxPlotRawData <- data.frame(x = rep("v1", 20), value = c(1:20), group = factor(rep(c("a", "b"), 10))) + + res <- boxPlotGGDS("boxPlotRawData", group = "group") + + expect_length(res, 2) + expect_equal(res[[2]], "single_group") +}) + +test_that("boxPlotGGDS fails when data_table.name references nonexistent object", { + expect_error(boxPlotGGDS("nonexistent_obj"), "does not exist") +}) + +# +# Done +# + +# context("boxPlotGGDS::smk::shutdown") + +# context("boxPlotGGDS::smk::done") diff --git a/tests/testthat/test-smk-boxPlotGG_data_TreatmentDS.R b/tests/testthat/test-smk-boxPlotGG_data_TreatmentDS.R new file mode 100644 index 00000000..0deb5ff5 --- /dev/null +++ b/tests/testthat/test-smk-boxPlotGG_data_TreatmentDS.R @@ -0,0 +1,50 @@ +# +# Set up +# + +# context("boxPlotGG_data_TreatmentDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("boxPlotGG_data_TreatmentDS::smk") +test_that("boxPlotGG_data_TreatmentDS, no grouping", { + D <- data.frame(v1 = c(1:20), v2 = c(20:1)) + + res <- boxPlotGG_data_TreatmentDS("D", variables = c("v1", "v2")) + + expect_true(all(c("x", "value") %in% names(res))) +}) + +test_that("boxPlotGG_data_TreatmentDS, single grouping", { + D <- data.frame(v1 = c(1:20), group = factor(rep(c("a", "b"), 10))) + + res <- boxPlotGG_data_TreatmentDS("D", variables = c("v1"), group = "group") + + expect_true(all(c("x", "value", "group") %in% names(res))) +}) + +test_that("boxPlotGG_data_TreatmentDS fails when table.name references nonexistent object", { + expect_error(boxPlotGG_data_TreatmentDS("nonexistent_obj", variables = c("v1")), "does not exist") +}) + +test_that("boxPlotGG_data_TreatmentDS fails when a variable is not numeric or integer", { + D <- data.frame(v1 = c("a", "b", "c")) + expect_error(boxPlotGG_data_TreatmentDS("D", variables = c("v1")), "must be of type numeric or integer") +}) + +test_that("boxPlotGG_data_TreatmentDS fails when group is not a factor", { + D <- data.frame(v1 = c(1:20), group = c(1:20)) + expect_error(boxPlotGG_data_TreatmentDS("D", variables = c("v1"), group = "group"), "must be of type factor") +}) + +# +# Done +# + +# context("boxPlotGG_data_TreatmentDS::smk::shutdown") + +# context("boxPlotGG_data_TreatmentDS::smk::done") diff --git a/tests/testthat/test-smk-boxPlotGG_data_Treatment_numericDS.R b/tests/testthat/test-smk-boxPlotGG_data_Treatment_numericDS.R new file mode 100644 index 00000000..354de5cd --- /dev/null +++ b/tests/testthat/test-smk-boxPlotGG_data_Treatment_numericDS.R @@ -0,0 +1,38 @@ +# +# Set up +# + +# context("boxPlotGG_data_Treatment_numericDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("boxPlotGG_data_Treatment_numericDS::smk") +test_that("boxPlotGG_data_Treatment_numericDS", { + v1 <- c(1:20) + + res <- boxPlotGG_data_Treatment_numericDS("v1") + + expect_equal(unique(res$x), "v1") + expect_equal(res$value, v1) +}) + +test_that("boxPlotGG_data_Treatment_numericDS fails when vector.name references nonexistent object", { + expect_error(boxPlotGG_data_Treatment_numericDS("nonexistent_obj"), "does not exist") +}) + +test_that("boxPlotGG_data_Treatment_numericDS fails when vector is not numeric or integer", { + v1 <- c("a", "b", "c") + expect_error(boxPlotGG_data_Treatment_numericDS("v1"), "must be of type numeric or integer") +}) + +# +# Done +# + +# context("boxPlotGG_data_Treatment_numericDS::smk::shutdown") + +# context("boxPlotGG_data_Treatment_numericDS::smk::done") diff --git a/tests/testthat/test-smk-changeRefGroupDS.R b/tests/testthat/test-smk-changeRefGroupDS.R index 3d94fde7..3a3283ad 100644 --- a/tests/testthat/test-smk-changeRefGroupDS.R +++ b/tests/testthat/test-smk-changeRefGroupDS.R @@ -1,6 +1,5 @@ #------------------------------------------------------------------------------- # Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. -# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. # # This program and the accompanying materials # are made available under the terms of the GNU Public License v3.0. @@ -15,99 +14,41 @@ # context("changeRefGroupDS::smk::setup") +set.standard.disclosure.settings() + # # Tests # -# context("changeRefGroupDS::smk") -test_that("simple changeRefGroupDS, reorderByRef is FALSE", { - x <- c(8, 1, 6, 1, 4, 1, 2, 1) - xf <- as.factor(x) - ref <- 2 - reorderByRef <- FALSE +test_that("simple changeRefGroupDS", { + xf <- as.factor(c(8, 1, 6, 1, 4, 1, 2, 1)) - res <- changeRefGroupDS(xf, ref, reorderByRef) + res <- changeRefGroupDS("xf", ref = 2, reorderByRef = FALSE) expect_equal(class(res), "factor") expect_length(res, 8) - - res.num <- as.numeric(res) - - expect_equal(class(res.num), "numeric") - expect_length(res.num, 8) - - expect_equal(res.num[1], 5) - expect_equal(res.num[2], 2) - expect_equal(res.num[3], 4) - expect_equal(res.num[4], 2) - expect_equal(res.num[5], 3) - expect_equal(res.num[6], 2) - expect_equal(res.num[7], 1) - expect_equal(res.num[8], 2) - - res.levels <- levels(res) - - expect_equal(class(res.levels), "character") - expect_length(res.levels, 5) - expect_equal(res.levels[1], "2") - expect_equal(res.levels[2], "1") - expect_equal(res.levels[3], "4") - expect_equal(res.levels[4], "6") - expect_equal(res.levels[5], "8") + expect_equal(levels(res), c("2", "1", "4", "6", "8")) + expect_equal(as.character(res), c("8", "1", "6", "1", "4", "1", "2", "1")) }) -test_that("simple changeRefGroupDS, reorderByRef is TRUE", { - x <- rep(8, 1, 6, 1, 4, 1, 2, 1) - xf <- as.factor(x) - ref <- 1 - reorderByRef <- TRUE - - res <- changeRefGroupDS(xf, ref, reorderByRef) - - if (base::getRversion() < '4.1.0') - { - expect_equal(class(res), "integer") - expect_length(res, 6) - expect_equal(res[1], 1) - expect_equal(res[2], 1) - expect_equal(res[3], 1) - expect_equal(res[4], 1) - expect_equal(res[5], 1) - expect_equal(res[6], 1) - - res.levels <- levels(res) - - expect_true(is.null(res.levels)) - } - else - { - expect_equal(class(res), "factor") - expect_length(res, 6) +test_that("changeRefGroupDS with reorderByRef", { + xf <- as.factor(c(8, 1, 6, 1, 4, 1, 2, 1)) - res.num <- as.numeric(res) + res <- changeRefGroupDS("xf", ref = 2, reorderByRef = TRUE) - expect_equal(class(res.num), "numeric") - expect_length(res.num, 6) - - expect_equal(res.num[1], 1) - expect_equal(res.num[2], 1) - expect_equal(res.num[3], 1) - expect_equal(res.num[4], 1) - expect_equal(res.num[5], 1) - expect_equal(res.num[6], 1) - - res.levels <- levels(res) - - expect_equal(class(res.levels), "character") - expect_length(res.levels, 1) - expect_equal(res.levels[1], "8") - } + expect_equal(class(res), "factor") + expect_length(res, 8) + expect_equal(levels(res), c("2", "1", "4", "6", "8")) + expect_equal(as.character(res), c("2", "8", "1", "6", "1", "4", "1", "1")) }) -# -# Done -# - -# context("changeRefGroupDS::smk::shutdown") +test_that("changeRefGroupDS errors when serverside object does not exist", { + expect_error(changeRefGroupDS("nonexistent_object", ref = 1, reorderByRef = FALSE), + regexp = "does not exist") +}) -# context("changeRefGroupDS::smk::done") +test_that("changeRefGroupDS errors when object is not a factor", { + bad_input <- c(1, 2, 3) + expect_error(changeRefGroupDS("bad_input", ref = 1, reorderByRef = FALSE), + regexp = "must be of type") +}) diff --git a/tests/testthat/test-smk-densityGridDS.R b/tests/testthat/test-smk-densityGridDS.R index 2c075a4b..05efb14f 100644 --- a/tests/testthat/test-smk-densityGridDS.R +++ b/tests/testthat/test-smk-densityGridDS.R @@ -36,20 +36,43 @@ test_that("densityGridDS", { y.max <- NULL numints <- 3 - res <- densityGridDS(xvect=xvect, yvect=yvect, limits=FALSE, x.min=NULL, + res <- densityGridDS(x="xvect", y="yvect", limits=FALSE, x.min=NULL, x.max=NULL, y.min=NULL, y.max=NULL, numints=numints) - expect_equal(class(res), c("matrix","array")) - expect_equal(colnames(res), c("", "", "", "x.mids", "y.mids")) - expect_equal(as.numeric(round(res[1,], digits=3)), c(3.000, 0.000, 0.000, 8.798, 13.870)) - expect_equal(as.numeric(round(res[2,], digits=3)), c(4.000, 5.000, 0.000, 10.195, 16.870)) - expect_equal(as.numeric(round(res[3,], digits=3)), c(3.000, 0.000, 0.000, 11.592, 19.870)) - - expect_equal(names(dimnames(res))[2], "Number of invalid cells (cells with counts >0 and < nfilter.tab ) is 4") + expect_equal(class(res$grid), c("matrix","array")) + expect_equal(colnames(res$grid), c("", "", "", "x.mids", "y.mids")) + expect_equal(as.numeric(round(res$grid[1,], digits=3)), c(3.000, 0.000, 0.000, 8.798, 13.870)) + expect_equal(as.numeric(round(res$grid[2,], digits=3)), c(4.000, 5.000, 0.000, 10.195, 16.870)) + expect_equal(as.numeric(round(res$grid[3,], digits=3)), c(3.000, 0.000, 0.000, 11.592, 19.870)) + + expect_equal(names(dimnames(res$grid))[2], "Number of invalid cells (cells with counts >0 and < nfilter.tab ) is 4") + expect_equal(res$class.x, "numeric") + expect_equal(res$class.y, "numeric") }) +test_that("densityGridDS fails when x references nonexistent object", { + expect_error(densityGridDS(x="nonexistent_obj", y="yvect", numints=3), "does not exist") +}) + +test_that("densityGridDS fails when y references nonexistent object", { + yvect <- c(1:20) + expect_error(densityGridDS(x="yvect", y="nonexistent_obj", numints=3), "does not exist") +}) + +test_that("densityGridDS fails when x is not numeric or integer", { + xvect <- c("a", "b", "c") + yvect <- c(1, 2, 3) + expect_error(densityGridDS(x="xvect", y="yvect", numints=3), "must be of type numeric or integer") +}) + +test_that("densityGridDS fails when y is not numeric or integer", { + xvect <- c(1, 2, 3) + yvect <- c("a", "b", "c") + expect_error(densityGridDS(x="xvect", y="yvect", numints=3), "must be of type numeric or integer") +}) + # # Done # diff --git a/tests/testthat/test-smk-dmtC2SDS.R b/tests/testthat/test-smk-dmtC2SDS.R new file mode 100644 index 00000000..8021bae1 --- /dev/null +++ b/tests/testthat/test-smk-dmtC2SDS.R @@ -0,0 +1,30 @@ + +# +# Set up +# + +# context("dmtC2SDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +test_that("simple dmtC2SDS returns matrix", { + res <- dmtC2SDS( + dfdata.mat.transmit = "1,2,3,4", + inout.object.transmit = "MAT", + from = "clientside.matdftbl", + nrows.transmit = "2", + ncols.transmit = "2", + colnames.transmit = "a,b", + colclass.transmit = "numeric,numeric", + byrow = FALSE + ) + + expect_true(is.matrix(res)) + expect_equal(nrow(res), 2) + expect_equal(ncol(res), 2) + expect_equal(colnames(res), c("a", "b")) +}) diff --git a/tests/testthat/test-smk-glmDS1.R b/tests/testthat/test-smk-glmDS1.R new file mode 100644 index 00000000..69aa22fe --- /dev/null +++ b/tests/testthat/test-smk-glmDS1.R @@ -0,0 +1,63 @@ +# +# Set up +# + +# context("glmDS1::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("glmDS1::smk::gaussian") +test_that("simple glmDS1, gaussian", { + D <- data.frame( + y = c(4.1, 4.2, 3.9, 2.9, 3.6, 3.8, 4.2, 4.2, 2.5, 3.5, + 2.8, 3.7, 3.3, 3.3, 2.4, 3.5, 3.0, 3.1, 3.5, 3.4), + x = c(41.0, 41.0, 39.0, 38.9, 40.6, 41.0, 40.7, 41.4, 36.0, 39.0, + 37.6, 40.0, 40.3, 40.7, 37.0, 40.0, 41.6, 36.3, 39.3, 40.0) + ) + + expect_warning( + res <- glmDS1(formula = stats::as.formula("y ~ x"), family = "gaussian", + weights = NULL, offset = NULL, data = "D"), + regexp = "did not converge" + ) + + expect_equal(class(res), "list") + expect_length(res, 8) + expect_equal(res$dimX, c(20, 2)) + expect_equal(res$coef.names, c("(Intercept)", "x")) + expect_equal(res$y.invalid, 0) + expect_equal(res$Xpar.invalid, c(0, 0)) + expect_equal(res$w.invalid, 0) + expect_equal(res$o.invalid, 0) + expect_equal(res$glm.saturation.invalid, 0) + expect_equal(res$errorMessage, "No errors") +}) + +test_that("glmDS1 throws error when data does not exist", { + expect_error( + glmDS1(formula = stats::as.formula("y ~ x"), family = "gaussian", + weights = NULL, offset = NULL, data = "nonexistent_object"), + regexp = "does not exist" + ) +}) + +test_that("glmDS1 throws error when data is not a data.frame or matrix", { + bad_input <- c(1, 2, 3) + expect_error( + glmDS1(formula = stats::as.formula("y ~ x"), family = "gaussian", + weights = NULL, offset = NULL, data = "bad_input"), + regexp = "must be of type" + ) +}) + +# +# Done +# + +# context("glmDS1::smk::shutdown") + +# context("glmDS1::smk::done") diff --git a/tests/testthat/test-smk-glmDS2.R b/tests/testthat/test-smk-glmDS2.R new file mode 100644 index 00000000..ddf4f284 --- /dev/null +++ b/tests/testthat/test-smk-glmDS2.R @@ -0,0 +1,68 @@ +# +# Set up +# + +# context("glmDS2::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("glmDS2::smk::gaussian") +test_that("simple glmDS2, gaussian", { + D <- data.frame( + y = c(4.1, 4.2, 3.9, 2.9, 3.6, 3.8, 4.2, 4.2, 2.5, 3.5, + 2.8, 3.7, 3.3, 3.3, 2.4, 3.5, 3.0, 3.1, 3.5, 3.4), + x = c(41.0, 41.0, 39.0, 38.9, 40.6, 41.0, 40.7, 41.4, 36.0, 39.0, + 37.6, 40.0, 40.3, 40.7, 37.0, 40.0, 41.6, 36.3, 39.3, 40.0) + ) + + expect_warning( + res <- glmDS2(formula = stats::as.formula("y ~ x"), family = "gaussian", + beta.vect = "0,0", offset = NULL, weights = NULL, dataName = "D"), + regexp = "did not converge" + ) + + expect_equal(class(res), "list") + expect_length(res, 10) + expect_equal(res$family$family, "gaussian") + expect_equal(res$family$link, "identity") + expect_equal(dim(res$info.matrix), c(2, 2)) + expect_equal(as.numeric(res$info.matrix), c(20, 791.4, 791.4, 31369.1), tolerance = 1e-6) + expect_equal(dim(res$score.vect), c(2, 1)) + expect_equal(as.numeric(res$score.vect), c(68.9, 2738.75), tolerance = 1e-6) + expect_equal(res$numsubs, 20) + expect_equal(res$dev, 243, tolerance = 1) + expect_equal(res$Nvalid, 20) + expect_equal(res$Nmissing, 0) + expect_equal(res$Ntotal, 20) + expect_equal(res$disclosure.risk, 0) + expect_equal(res$errorMessage2, "No errors") +}) + +test_that("glmDS2 throws error when dataName does not exist", { + expect_error( + glmDS2(formula = stats::as.formula("y ~ x"), family = "gaussian", + beta.vect = "0,0", offset = NULL, weights = NULL, dataName = "nonexistent_object"), + regexp = "does not exist" + ) +}) + +test_that("glmDS2 throws error when dataName is not a data.frame or matrix", { + bad_input <- c(1, 2, 3) + expect_error( + glmDS2(formula = stats::as.formula("y ~ x"), family = "gaussian", + beta.vect = "0,0", offset = NULL, weights = NULL, dataName = "bad_input"), + regexp = "must be of type" + ) +}) + +# +# Done +# + +# context("glmDS2::smk::shutdown") + +# context("glmDS2::smk::done") diff --git a/tests/testthat/test-smk-glmPredictDS.ag.R b/tests/testthat/test-smk-glmPredictDS.ag.R new file mode 100644 index 00000000..073ec02c --- /dev/null +++ b/tests/testthat/test-smk-glmPredictDS.ag.R @@ -0,0 +1,61 @@ +# +# Set up +# + +# context("glmPredictDS.ag::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("glmPredictDS.ag::smk::gaussian") +test_that("simple glmPredictDS.ag, gaussian, response", { + D <- data.frame( + y = c(4.1, 4.2, 3.9, 2.9, 3.6, 3.8, 4.2, 4.2, 2.5, 3.5, + 2.8, 3.7, 3.3, 3.3, 2.4, 3.5, 3.0, 3.1, 3.5, 3.4), + x = c(41.0, 41.0, 39.0, 38.9, 40.6, 41.0, 40.7, 41.4, 36.0, 39.0, + 37.6, 40.0, 40.3, 40.7, 37.0, 40.0, 41.6, 36.3, 39.3, 40.0) + ) + my.glm.obj <- glm(y ~ x, family = gaussian(), data = D) + + res <- glmPredictDS.ag(glmname.transmit = "my.glm.obj", newdataname.transmit = NULL, + output.type = "response", se.fit = FALSE, dispersion = NULL, + terms.transmit = NULL, na.action = "na.pass") + + expect_equal(class(res), "list") + expect_length(res, 1) + sl <- res$safe.list + expect_equal(sl$glm.object, "my.glm.obj") + expect_null(sl$newdfname) + expect_equal(sl$output.type, "response") + expect_equal(sl$fit.Ntotal, 20) + expect_equal(sl$fit.Nvalid, 20) + expect_equal(sl$fit.Nmiss, 0) + expect_equal(sl$fit.mean, 3.445, tolerance = 1e-6) + expect_equal(sl$fit.sd, 0.6233470588, tolerance = 1e-6) + expect_equal( + as.numeric(sl$fit.quantiles), + c(2.6836344144, 2.8331262874, 3.3070966443, 3.5446612486, + 3.7242832665, 3.7857024081, 3.8714574361), + tolerance = 1e-6 + ) +}) + +test_that("glmPredictDS.ag throws error when glmname does not exist", { + expect_error( + glmPredictDS.ag(glmname.transmit = "nonexistent_object", newdataname.transmit = NULL, + output.type = "response", se.fit = FALSE, dispersion = NULL, + terms.transmit = NULL, na.action = "na.pass"), + regexp = "does not exist" + ) +}) + +# +# Done +# + +# context("glmPredictDS.ag::smk::shutdown") + +# context("glmPredictDS.ag::smk::done") diff --git a/tests/testthat/test-smk-glmPredictDS.as.R b/tests/testthat/test-smk-glmPredictDS.as.R new file mode 100644 index 00000000..25850d84 --- /dev/null +++ b/tests/testthat/test-smk-glmPredictDS.as.R @@ -0,0 +1,51 @@ +# +# Set up +# + +# context("glmPredictDS.as::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("glmPredictDS.as::smk::gaussian") +test_that("simple glmPredictDS.as, gaussian, response", { + D <- data.frame( + y = c(4.1, 4.2, 3.9, 2.9, 3.6, 3.8, 4.2, 4.2, 2.5, 3.5, + 2.8, 3.7, 3.3, 3.3, 2.4, 3.5, 3.0, 3.1, 3.5, 3.4), + x = c(41.0, 41.0, 39.0, 38.9, 40.6, 41.0, 40.7, 41.4, 36.0, 39.0, + 37.6, 40.0, 40.3, 40.7, 37.0, 40.0, 41.6, 36.3, 39.3, 40.0) + ) + my.glm.obj <- glm(y ~ x, family = gaussian(), data = D) + + res <- glmPredictDS.as(glmname.transmit = "my.glm.obj", newdataname.transmit = NULL, + output.type = "response", se.fit = FALSE, dispersion = NULL, + terms.transmit = NULL, na.action = "na.pass") + + expect_equal(class(res), "list") + expect_length(res, 1) + expect_length(res$fit, 20) + expect_equal(as.numeric(res$fit[1:5]), + c(3.7764315943, 3.7764315943, 3.3128909030, 3.2897138684, 3.6837234561), + tolerance = 1e-6) + expect_equal(mean(res$fit), 3.445, tolerance = 1e-6) +}) + +test_that("glmPredictDS.as throws error when glmname does not exist", { + expect_error( + glmPredictDS.as(glmname.transmit = "nonexistent_object", newdataname.transmit = NULL, + output.type = "response", se.fit = FALSE, dispersion = NULL, + terms.transmit = NULL, na.action = "na.pass"), + regexp = "does not exist" + ) +}) + +# +# Done +# + +# context("glmPredictDS.as::smk::shutdown") + +# context("glmPredictDS.as::smk::done") diff --git a/tests/testthat/test-smk-glmSLMADS1.R b/tests/testthat/test-smk-glmSLMADS1.R new file mode 100644 index 00000000..7496a5f8 --- /dev/null +++ b/tests/testthat/test-smk-glmSLMADS1.R @@ -0,0 +1,63 @@ +# +# Set up +# + +# context("glmSLMADS1::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("glmSLMADS1::smk::gaussian") +test_that("simple glmSLMADS1, gaussian", { + D <- data.frame( + y = c(4.1, 4.2, 3.9, 2.9, 3.6, 3.8, 4.2, 4.2, 2.5, 3.5, + 2.8, 3.7, 3.3, 3.3, 2.4, 3.5, 3.0, 3.1, 3.5, 3.4), + x = c(41.0, 41.0, 39.0, 38.9, 40.6, 41.0, 40.7, 41.4, 36.0, 39.0, + 37.6, 40.0, 40.3, 40.7, 37.0, 40.0, 41.6, 36.3, 39.3, 40.0) + ) + + expect_warning( + res <- glmSLMADS1(formula = stats::as.formula("y ~ x"), family = "gaussian", + weights = NULL, offset = NULL, data = "D"), + regexp = "did not converge" + ) + + expect_equal(class(res), "list") + expect_length(res, 8) + expect_equal(res$dimX, c(20, 2)) + expect_equal(res$coef.names, c("(Intercept)", "x")) + expect_equal(res$y.invalid, 0) + expect_equal(res$Xpar.invalid, c(0, 0)) + expect_equal(res$w.invalid, 0) + expect_equal(res$o.invalid, 0) + expect_equal(res$glm.saturation.invalid, 0) + expect_equal(res$errorMessage, "No errors") +}) + +test_that("glmSLMADS1 throws error when data does not exist", { + expect_error( + glmSLMADS1(formula = stats::as.formula("y ~ x"), family = "gaussian", + weights = NULL, offset = NULL, data = "nonexistent_object"), + regexp = "does not exist" + ) +}) + +test_that("glmSLMADS1 throws error when data is not a data.frame or matrix", { + bad_input <- c(1, 2, 3) + expect_error( + glmSLMADS1(formula = stats::as.formula("y ~ x"), family = "gaussian", + weights = NULL, offset = NULL, data = "bad_input"), + regexp = "must be of type" + ) +}) + +# +# Done +# + +# context("glmSLMADS1::smk::shutdown") + +# context("glmSLMADS1::smk::done") diff --git a/tests/testthat/test-smk-glmSLMADS2.R b/tests/testthat/test-smk-glmSLMADS2.R new file mode 100644 index 00000000..74c26fea --- /dev/null +++ b/tests/testthat/test-smk-glmSLMADS2.R @@ -0,0 +1,68 @@ +# +# Set up +# + +# context("glmSLMADS2::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("glmSLMADS2::smk::gaussian") +test_that("simple glmSLMADS2, gaussian", { + D <- data.frame( + y = c(4.1, 4.2, 3.9, 2.9, 3.6, 3.8, 4.2, 4.2, 2.5, 3.5, + 2.8, 3.7, 3.3, 3.3, 2.4, 3.5, 3.0, 3.1, 3.5, 3.4), + x = c(41.0, 41.0, 39.0, 38.9, 40.6, 41.0, 40.7, 41.4, 36.0, 39.0, + 37.6, 40.0, 40.3, 40.7, 37.0, 40.0, 41.6, 36.3, 39.3, 40.0) + ) + my.glm.obj <- glm(y ~ x, family = gaussian(), data = D, x = TRUE) + + res <- glmSLMADS2(formula = stats::as.formula("y ~ x"), family = "gaussian", + offset = NULL, weights = NULL, newobj = "my.glm.obj", dataName = "D") + + expect_equal(class(res), "list") + expect_length(res, 29) + expect_equal(res$rank, 2) + expect_equal(res$aic, 23.15387, tolerance = 1e-5) + expect_equal(res$iter, 2) + expect_true(res$converged) + expect_false(res$boundary) + expect_equal(res$data, "D") + expect_equal(res$Ntotal, 20) + expect_equal(res$Nvalid, 20) + expect_equal(res$Nmissing, 0) + expect_equal(dim(res$coefficients), c(2, 4)) + expect_equal(rownames(res$coefficients), c("(Intercept)", "x")) + expect_equal(res$coefficients[, "Estimate"], c(`(Intercept)` = -5.7261526, x = 0.2317703), tolerance = 1e-6) + expect_equal(res$family$family, "gaussian") +}) + +test_that("glmSLMADS2 throws error when dataName does not exist", { + # dataName is validated before newobj is loaded, so no glm object needs to exist here. + expect_error( + glmSLMADS2(formula = stats::as.formula("y ~ x"), family = "gaussian", + offset = NULL, weights = NULL, newobj = "my.glm.obj", dataName = "nonexistent_object"), + regexp = "does not exist" + ) +}) + +test_that("glmSLMADS2 throws error when dataName is not a data.frame or matrix", { + bad_input <- c(1, 2, 3) + + expect_error( + glmSLMADS2(formula = stats::as.formula("y ~ x"), family = "gaussian", + offset = NULL, weights = NULL, newobj = "my.glm.obj", dataName = "bad_input"), + regexp = "must be of type" + ) +}) + +# +# Done +# + +# context("glmSLMADS2::smk::shutdown") + +# context("glmSLMADS2::smk::done") diff --git a/tests/testthat/test-smk-glmSummaryDS.ag.R b/tests/testthat/test-smk-glmSummaryDS.ag.R new file mode 100644 index 00000000..0107db85 --- /dev/null +++ b/tests/testthat/test-smk-glmSummaryDS.ag.R @@ -0,0 +1,58 @@ +# +# Set up +# + +# context("glmSummaryDS.ag::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("glmSummaryDS.ag::smk::gaussian") +test_that("simple glmSummaryDS.ag, gaussian", { + D <- data.frame( + y = c(4.1, 4.2, 3.9, 2.9, 3.6, 3.8, 4.2, 4.2, 2.5, 3.5, + 2.8, 3.7, 3.3, 3.3, 2.4, 3.5, 3.0, 3.1, 3.5, 3.4), + x = c(41.0, 41.0, 39.0, 38.9, 40.6, 41.0, 40.7, 41.4, 36.0, 39.0, + 37.6, 40.0, 40.3, 40.7, 37.0, 40.0, 41.6, 36.3, 39.3, 40.0) + ) + my.glm.obj <- glm(y ~ x, family = gaussian(), data = D) + + res <- glmSummaryDS.ag(x.transmit = "my.glm.obj") + + expect_equal(class(res), "list") + expect_length(res, 2) + + expect_equal(class(res$glm.obj), c("glm", "lm")) + expect_equal(as.numeric(res$glm.obj$coefficients), c(-5.7261526, 0.2317703), tolerance = 1e-6) + expect_true(is.na(res$glm.obj$residuals)) + expect_true(is.na(res$glm.obj$fitted.values)) + expect_true(is.na(res$glm.obj$y)) + expect_true(is.na(res$glm.obj$x)) + expect_equal(res$glm.obj$data, c("y", "x")) + + expect_equal(class(res$glm.summary.obj), "summary.glm") + expect_length(res$glm.summary.obj, 18) + expect_true(is.na(res$glm.summary.obj$na.action)) + expect_true(is.na(res$glm.summary.obj$deviance.resid)) + expect_equal(dim(res$glm.summary.obj$coefficients), c(2, 4)) + expect_equal(res$glm.summary.obj$coefficients[, "Estimate"], + c(`(Intercept)` = -5.7261526, x = 0.2317703), tolerance = 1e-6) +}) + +test_that("glmSummaryDS.ag throws error when x does not exist", { + expect_error( + glmSummaryDS.ag(x.transmit = "nonexistent_object"), + regexp = "does not exist" + ) +}) + +# +# Done +# + +# context("glmSummaryDS.ag::smk::shutdown") + +# context("glmSummaryDS.ag::smk::done") diff --git a/tests/testthat/test-smk-glmSummaryDS.as.R b/tests/testthat/test-smk-glmSummaryDS.as.R new file mode 100644 index 00000000..6f2c9bb8 --- /dev/null +++ b/tests/testthat/test-smk-glmSummaryDS.as.R @@ -0,0 +1,51 @@ +# +# Set up +# + +# context("glmSummaryDS.as::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("glmSummaryDS.as::smk::gaussian") +test_that("simple glmSummaryDS.as, gaussian", { + D <- data.frame( + y = c(4.1, 4.2, 3.9, 2.9, 3.6, 3.8, 4.2, 4.2, 2.5, 3.5, + 2.8, 3.7, 3.3, 3.3, 2.4, 3.5, 3.0, 3.1, 3.5, 3.4), + x = c(41.0, 41.0, 39.0, 38.9, 40.6, 41.0, 40.7, 41.4, 36.0, 39.0, + 37.6, 40.0, 40.3, 40.7, 37.0, 40.0, 41.6, 36.3, 39.3, 40.0) + ) + my.glm.obj <- glm(y ~ x, family = gaussian(), data = D) + + res <- glmSummaryDS.as(x.transmit = "my.glm.obj") + + expect_equal(class(res), "summary.glm") + expect_length(res, 17) + expect_equal(res$aic, 23.15387, tolerance = 1e-5) + expect_equal(res$df.residual, 18) + expect_equal(res$null.deviance, 5.6295, tolerance = 1e-5) + + expect_true(is.na(res$deviance.resid)) + expect_null(res$na.action) + expect_equal(dim(res$coefficients), c(2, 4)) + expect_equal(rownames(res$coefficients), c("(Intercept)", "x")) + expect_equal(res$coefficients[, "Estimate"], c(`(Intercept)` = -5.7261526, x = 0.2317703), tolerance = 1e-6) +}) + +test_that("glmSummaryDS.as throws error when x does not exist", { + expect_error( + glmSummaryDS.as(x.transmit = "nonexistent_object"), + regexp = "does not exist" + ) +}) + +# +# Done +# + +# context("glmSummaryDS.as::smk::shutdown") + +# context("glmSummaryDS.as::smk::done") diff --git a/tests/testthat/test-smk-glmerSLMADS.assign.R b/tests/testthat/test-smk-glmerSLMADS.assign.R new file mode 100644 index 00000000..abe56803 --- /dev/null +++ b/tests/testthat/test-smk-glmerSLMADS.assign.R @@ -0,0 +1,65 @@ +# +# Set up +# + +# context("glmerSLMADS.assign::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("glmerSLMADS.assign::smk::binomial random intercept") +test_that("simple glmerSLMADS.assign, binomial random intercept", { + set.seed(7) + D <- data.frame( + group = factor(rep(1:5, each = 10)), + x = rep(1:10, times = 5) + ) + lp <- -1.5 + 0.35 * D$x + rep(rnorm(5, sd = 1.5), each = 10) + D$y <- rbinom(50, 1, plogis(lp)) + + res <- suppressWarnings( + glmerSLMADS.assign(formula = stats::as.formula("y ~ x + (1|group)"), + offset = NULL, weights = NULL, dataName = "D", family = "binomial", + control_type = NULL, control_value.transmit = NULL, + nAGQ = 1L, verbose = 0, theta = NULL, fixef = NULL) + ) + + expect_true(methods::is(res, "glmerMod")) + expect_equal(nobs(res), 50) + expect_equal(as.numeric(lme4::fixef(res)), c(-1.4299523, 0.2248647), tolerance = 1e-5) + + vc <- as.data.frame(lme4::VarCorr(res)) + expect_equal(vc$vcov, 2.7451347, tolerance = 1e-5) +}) + +test_that("glmerSLMADS.assign throws error when dataName does not exist", { + expect_error( + glmerSLMADS.assign(formula = stats::as.formula("y ~ x + (1|group)"), + offset = NULL, weights = NULL, dataName = "nonexistent_object", family = "binomial", + control_type = NULL, control_value.transmit = NULL, + nAGQ = 1L, verbose = 0, theta = NULL, fixef = NULL), + regexp = "does not exist" + ) +}) + +test_that("glmerSLMADS.assign throws error when dataName is not a data.frame or matrix", { + bad_input <- c(1, 2, 3) + expect_error( + glmerSLMADS.assign(formula = stats::as.formula("y ~ x + (1|group)"), + offset = NULL, weights = NULL, dataName = "bad_input", family = "binomial", + control_type = NULL, control_value.transmit = NULL, + nAGQ = 1L, verbose = 0, theta = NULL, fixef = NULL), + regexp = "must be of type" + ) +}) + +# +# Done +# + +# context("glmerSLMADS.assign::smk::shutdown") + +# context("glmerSLMADS.assign::smk::done") diff --git a/tests/testthat/test-smk-glmerSLMADS2.R b/tests/testthat/test-smk-glmerSLMADS2.R new file mode 100644 index 00000000..81b26fcb --- /dev/null +++ b/tests/testthat/test-smk-glmerSLMADS2.R @@ -0,0 +1,69 @@ +# +# Set up +# + +# context("glmerSLMADS2::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("glmerSLMADS2::smk::binomial random intercept") +test_that("simple glmerSLMADS2, binomial random intercept", { + set.seed(7) + D <- data.frame( + group = factor(rep(1:5, each = 10)), + x = rep(1:10, times = 5) + ) + lp <- -1.5 + 0.35 * D$x + rep(rnorm(5, sd = 1.5), each = 10) + D$y <- rbinom(50, 1, plogis(lp)) + + res <- suppressWarnings( + glmerSLMADS2(formula = stats::as.formula("y ~ x + (1|group)"), + offset = NULL, weights = NULL, dataName = "D", family = "binomial", + control_type = NULL, control_value.transmit = NULL, + nAGQ = 1L, verbose = 0, theta = NULL, fixef = NULL) + ) + + expect_equal(class(res), "summary.merMod") + expect_equal(res$errorMessage, "No errors") + expect_equal(res$disclosure.risk, 0) + expect_equal(res$Ntotal, 50) + expect_equal(res$Nvalid, 50) + expect_equal(res$Nmissing, 0) + expect_equal(dim(res$coefficients), c(2, 4)) + expect_equal(res$coefficients[, "Estimate"], + c(`(Intercept)` = -1.4299523, x = 0.2248647), tolerance = 1e-5) + expect_equal(res$family, "binomial") +}) + +test_that("glmerSLMADS2 throws error when dataName does not exist", { + expect_error( + glmerSLMADS2(formula = stats::as.formula("y ~ x + (1|group)"), + offset = NULL, weights = NULL, dataName = "nonexistent_object", family = "binomial", + control_type = NULL, control_value.transmit = NULL, + nAGQ = 1L, verbose = 0, theta = NULL, fixef = NULL), + regexp = "does not exist" + ) +}) + +test_that("glmerSLMADS2 throws error when dataName is not a data.frame or matrix", { + bad_input <- c(1, 2, 3) + expect_error( + glmerSLMADS2(formula = stats::as.formula("y ~ x + (1|group)"), + offset = NULL, weights = NULL, dataName = "bad_input", family = "binomial", + control_type = NULL, control_value.transmit = NULL, + nAGQ = 1L, verbose = 0, theta = NULL, fixef = NULL), + regexp = "must be of type" + ) +}) + +# +# Done +# + +# context("glmerSLMADS2::smk::shutdown") + +# context("glmerSLMADS2::smk::done") diff --git a/tests/testthat/test-smk-heatmapPlotDS.R b/tests/testthat/test-smk-heatmapPlotDS.R new file mode 100644 index 00000000..1313d608 --- /dev/null +++ b/tests/testthat/test-smk-heatmapPlotDS.R @@ -0,0 +1,55 @@ +# +# Set up +# + +# context("heatmapPlotDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("heatmapPlotDS::smk") +test_that("heatmapPlotDS, deterministic method", { + xvect <- c(1:20) + yvect <- c(20:1) + + res <- heatmapPlotDS("xvect", "yvect", k=3, noise=0.25, method.indicator=1) + + expect_length(res, 4) + expect_length(res[[1]], 20) + expect_length(res[[2]], 20) + expect_equal(res$class.x, "integer") + expect_equal(res$class.y, "integer") +}) + +test_that("heatmapPlotDS fails when x references nonexistent object", { + yvect <- c(20:1) + expect_error(heatmapPlotDS("nonexistent_obj", "yvect", k=3, noise=0.25, method.indicator=1), "does not exist") +}) + +test_that("heatmapPlotDS fails when y references nonexistent object", { + xvect <- c(1:20) + expect_error(heatmapPlotDS("xvect", "nonexistent_obj", k=3, noise=0.25, method.indicator=1), "does not exist") +}) + +test_that("heatmapPlotDS fails when x is not numeric or integer", { + xvect <- c("a", "b", "c") + yvect <- c(1, 2, 3) + expect_error(heatmapPlotDS("xvect", "yvect", k=3, noise=0.25, method.indicator=1), "must be of type numeric or integer") +}) + +test_that("heatmapPlotDS fails when y is not numeric or integer", { + xvect <- c(1, 2, 3) + yvect <- c("a", "b", "c") + expect_error(heatmapPlotDS("xvect", "yvect", k=3, noise=0.25, method.indicator=1), "must be of type numeric or integer") +}) + +# +# Done +# + +# context("heatmapPlotDS::smk::shutdown") + +# context("heatmapPlotDS::smk::done") diff --git a/tests/testthat/test-smk-histogramDS1.R b/tests/testthat/test-smk-histogramDS1.R new file mode 100644 index 00000000..10559b97 --- /dev/null +++ b/tests/testthat/test-smk-histogramDS1.R @@ -0,0 +1,40 @@ +# +# Set up +# + +# context("histogramDS1::smk::setup") + +set.standard.disclosure.settings() +set.random.seed.setting(1234) + +# +# Tests +# + +# context("histogramDS1::smk") +test_that("histogramDS1, smallCellsRule method", { + xvect <- c(1:100) + + res <- histogramDS1("xvect", method.indicator=1, k=3, noise=0.25) + + expect_length(res, 2) + expect_equal(res$class, "integer") + expect_length(res$range, 2) +}) + +test_that("histogramDS1 fails when x references nonexistent object", { + expect_error(histogramDS1("nonexistent_obj", method.indicator=1, k=3, noise=0.25), "does not exist") +}) + +test_that("histogramDS1 fails when x is not numeric or integer", { + xvect <- c("a", "b", "c") + expect_error(histogramDS1("xvect", method.indicator=1, k=3, noise=0.25), "must be of type numeric or integer") +}) + +# +# Done +# + +# context("histogramDS1::smk::shutdown") + +# context("histogramDS1::smk::done") diff --git a/tests/testthat/test-smk-histogramDS2.R b/tests/testthat/test-smk-histogramDS2.R new file mode 100644 index 00000000..da26d99a --- /dev/null +++ b/tests/testthat/test-smk-histogramDS2.R @@ -0,0 +1,39 @@ +# +# Set up +# + +# context("histogramDS2::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("histogramDS2::smk") +test_that("histogramDS2, smallCellsRule method", { + xvect <- c(1:100) + + res <- histogramDS2("xvect", num.breaks=10, min=1, max=100, method.indicator=1, k=3, noise=0.25) + + expect_length(res, 2) + expect_true(inherits(res$histobject, "histogram")) + expect_equal(res$invalidcells, 0) +}) + +test_that("histogramDS2 fails when x references nonexistent object", { + expect_error(histogramDS2("nonexistent_obj", num.breaks=10, min=1, max=100, method.indicator=1, k=3, noise=0.25), "does not exist") +}) + +test_that("histogramDS2 fails when x is not numeric or integer", { + xvect <- c("a", "b", "c") + expect_error(histogramDS2("xvect", num.breaks=10, min=1, max=100, method.indicator=1, k=3, noise=0.25), "must be of type numeric or integer") +}) + +# +# Done +# + +# context("histogramDS2::smk::shutdown") + +# context("histogramDS2::smk::done") diff --git a/tests/testthat/test-smk-lmerSLMADS.assign.R b/tests/testthat/test-smk-lmerSLMADS.assign.R new file mode 100644 index 00000000..6ef1a9c1 --- /dev/null +++ b/tests/testthat/test-smk-lmerSLMADS.assign.R @@ -0,0 +1,91 @@ +# +# Set up +# + +# context("lmerSLMADS.assign::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("lmerSLMADS.assign::smk::random intercept") +test_that("simple lmerSLMADS.assign, random intercept", { + set.seed(42) + D <- data.frame( + group = factor(rep(1:4, each = 6)), + x = rep(1:6, times = 4) + ) + D$y <- 2 + 0.5 * D$x + rep(rnorm(4, sd = 1), each = 6) + rnorm(24, sd = 0.3) + + res <- suppressWarnings( + lmerSLMADS.assign(formula = stats::as.formula("y ~ x + (1|group)"), + offset = NULL, weights = NULL, dataName = "D", REML = TRUE, + control_type = NULL, control_value.transmit = NULL, + optimizer = NULL, verbose = 0) + ) + + expect_true(methods::is(res, "lmerMod")) + expect_equal(nobs(res), 24) + expect_equal(as.numeric(lme4::fixef(res)), c(2.5942648, 0.4604968), tolerance = 1e-5) + expect_equal(sigma(res), 0.3874094, tolerance = 1e-5) + + vc <- as.data.frame(lme4::VarCorr(res)) + expect_equal(vc$vcov, c(0.7137558, 0.1500860), tolerance = 1e-5) +}) + +# context("lmerSLMADS.assign::smk::weighted") +test_that("simple lmerSLMADS.assign, with weights", { + set.seed(42) + D <- data.frame( + group = factor(rep(1:4, each = 6)), + x = rep(1:6, times = 4) + ) + D$y <- 2 + 0.5 * D$x + rep(rnorm(4, sd = 1), each = 6) + rnorm(24, sd = 0.3) + D$w <- rep(c(1, 2), times = 12) + + res <- suppressWarnings( + lmerSLMADS.assign(formula = stats::as.formula("y ~ x + (1|group)"), + offset = NULL, weights = "D$w", dataName = "D", REML = TRUE, + control_type = NULL, control_value.transmit = NULL, + optimizer = NULL, verbose = 0) + ) + + expect_true(methods::is(res, "lmerMod")) + expect_equal(nobs(res), 24) + expect_equal(as.numeric(lme4::fixef(res)), c(2.62267795897883, 0.4501480370479), tolerance = 1e-5) + expect_equal(sigma(res), 0.4786046, tolerance = 1e-5) + + vc <- as.data.frame(lme4::VarCorr(res)) + expect_equal(vc$vcov, c(0.631006576026455, 0.22906240776478), tolerance = 1e-5) +}) + +test_that("lmerSLMADS.assign throws error when dataName does not exist", { + expect_error( + lmerSLMADS.assign(formula = stats::as.formula("y ~ x + (1|group)"), + offset = NULL, weights = NULL, dataName = "nonexistent_object", REML = TRUE, + control_type = NULL, control_value.transmit = NULL, + optimizer = NULL, verbose = 0), + regexp = "does not exist" + ) +}) + +test_that("lmerSLMADS.assign throws error when dataName is not a data.frame or matrix", { + bad_input <- c(1, 2, 3) + expect_error( + lmerSLMADS.assign(formula = stats::as.formula("y ~ x + (1|group)"), + offset = NULL, weights = NULL, dataName = "bad_input", REML = TRUE, + control_type = NULL, control_value.transmit = NULL, + optimizer = NULL, verbose = 0), + regexp = "must be of type" + ) +}) + +# +# Done +# + +# context("lmerSLMADS.assign::smk::shutdown") + +# context("lmerSLMADS.assign::smk::done") diff --git a/tests/testthat/test-smk-lmerSLMADS2.R b/tests/testthat/test-smk-lmerSLMADS2.R new file mode 100644 index 00000000..4e09bbe3 --- /dev/null +++ b/tests/testthat/test-smk-lmerSLMADS2.R @@ -0,0 +1,68 @@ +# +# Set up +# + +# context("lmerSLMADS2::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("lmerSLMADS2::smk::random intercept") +test_that("simple lmerSLMADS2, random intercept", { + set.seed(42) + D <- data.frame( + group = factor(rep(1:4, each = 6)), + x = rep(1:6, times = 4) + ) + D$y <- 2 + 0.5 * D$x + rep(rnorm(4, sd = 1), each = 6) + rnorm(24, sd = 0.3) + + res <- suppressWarnings( + lmerSLMADS2(formula = stats::as.formula("y ~ x + (1|group)"), + offset = NULL, weights = NULL, dataName = "D", REML = TRUE, + control_type = NULL, control_value.transmit = NULL, + optimizer = NULL, verbose = 0) + ) + + expect_equal(class(res), "summary.merMod") + expect_equal(res$errorMessage, "No errors") + expect_equal(res$disclosure.risk, 0) + expect_equal(res$Ntotal, 24) + expect_equal(res$Nvalid, 24) + expect_equal(res$Nmissing, 0) + expect_equal(dim(res$coefficients), c(2, 3)) + expect_equal(res$coefficients[, "Estimate"], + c(`(Intercept)` = 2.5942648, x = 0.4604968), tolerance = 1e-5) + expect_equal(res$sigma, 0.3874094, tolerance = 1e-5) +}) + +test_that("lmerSLMADS2 throws error when dataName does not exist", { + expect_error( + lmerSLMADS2(formula = stats::as.formula("y ~ x + (1|group)"), + offset = NULL, weights = NULL, dataName = "nonexistent_object", REML = TRUE, + control_type = NULL, control_value.transmit = NULL, + optimizer = NULL, verbose = 0), + regexp = "does not exist" + ) +}) + +test_that("lmerSLMADS2 throws error when dataName is not a data.frame or matrix", { + bad_input <- c(1, 2, 3) + expect_error( + lmerSLMADS2(formula = stats::as.formula("y ~ x + (1|group)"), + offset = NULL, weights = NULL, dataName = "bad_input", REML = TRUE, + control_type = NULL, control_value.transmit = NULL, + optimizer = NULL, verbose = 0), + regexp = "must be of type" + ) +}) + +# +# Done +# + +# context("lmerSLMADS2::smk::shutdown") + +# context("lmerSLMADS2::smk::done") diff --git a/tests/testthat/test-smk-matrixDS.R b/tests/testthat/test-smk-matrixDS.R new file mode 100644 index 00000000..f986555b --- /dev/null +++ b/tests/testthat/test-smk-matrixDS.R @@ -0,0 +1,29 @@ + +# +# Set up +# + +# context("matrixDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +test_that("simple matrixDS, serverside.vector", { + mvec <- c(1, 2, 3, 4, 5, 6) + + res <- matrixDS("mvec", from = "serverside.vector", nrows.transmit = "2", ncols.transmit = "3", byrow = FALSE, dimnames = NULL) + + expect_true(is.matrix(res)) + expect_equal(nrow(res), 2) + expect_equal(ncol(res), 3) + expect_equal(res[1, 1], 1) + expect_equal(res[2, 1], 2) + expect_equal(res[1, 2], 3) +}) + +test_that("matrixDS errors when serverside object does not exist", { + expect_error(matrixDS("nonexistent_object", from = "serverside.vector", nrows.transmit = "2", ncols.transmit = "2", byrow = FALSE, dimnames = NULL), regexp = "does not exist") +}) diff --git a/tests/testthat/test-smk-matrixDetDS1.R b/tests/testthat/test-smk-matrixDetDS1.R new file mode 100644 index 00000000..37d39ac2 --- /dev/null +++ b/tests/testthat/test-smk-matrixDetDS1.R @@ -0,0 +1,44 @@ + +# +# Set up +# + +# context("matrixDetDS1::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +test_that("simple matrixDetDS1 passes with matrix of sufficient dimensions", { + M1 <- matrix(c(1, 2, 3, 4, 5, 6, 7, 8, 10), 3, 3) + res <- matrixDetDS1("M1", logarithm=FALSE) + + expect_true(is.list(res)) + expect_equal(res$matrix.determinant, determinant(M1, logarithm=FALSE)) +}) + +test_that("matrixDetDS1 errors when serverside object does not exist", { + expect_error(matrixDetDS1("nonexistent_object", logarithm=FALSE), regexp = "does not exist") +}) + +test_that("matrixDetDS1 errors when input is wrong type", { + bad_input <- c("a", "b", "c") + expect_error(matrixDetDS1("bad_input", logarithm=FALSE), regexp = "must be of type") +}) + +test_that("matrixDetDS1 errors when matrix is too small (disclosure guard)", { + M1x1 <- matrix(7, 1, 1) + M2x2 <- matrix(c(1, 2, 3, 4), 2, 2) + + expect_error(matrixDetDS1("M1x1", logarithm=FALSE), regexp = "too small") + expect_error(matrixDetDS1("M2x2", logarithm=FALSE), regexp = "too small") +}) + +test_that("matrixDetDS1 is blocked in non-permissive mode", { + options(datashield.privacyControlLevel = "non-permissive") + on.exit(options(datashield.privacyControlLevel = NULL), add = TRUE) + M1 <- matrix(c(1, 2, 3, 4, 5, 6, 7, 8, 10), 3, 3) + expect_error(matrixDetDS1("M1", logarithm=FALSE), regexp = "non-permissive") +}) diff --git a/tests/testthat/test-smk-matrixDetDS2.R b/tests/testthat/test-smk-matrixDetDS2.R new file mode 100644 index 00000000..bf20a3a9 --- /dev/null +++ b/tests/testthat/test-smk-matrixDetDS2.R @@ -0,0 +1,29 @@ + +# +# Set up +# + +# context("matrixDetDS2::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +test_that("simple matrixDetDS2", { + M1 <- matrix(c(1, 2, 3, 4), 2, 2) + + res <- matrixDetDS2("M1", logarithm=FALSE) + + expect_equal(res, determinant(M1, logarithm=FALSE)) +}) + +test_that("matrixDetDS2 errors when serverside object does not exist", { + expect_error(matrixDetDS2("nonexistent_object", logarithm=FALSE), regexp = "does not exist") +}) + +test_that("matrixDetDS2 errors when input is wrong type", { + bad_input <- c("a", "b", "c") + expect_error(matrixDetDS2("bad_input", logarithm=FALSE), regexp = "must be of type") +}) diff --git a/tests/testthat/test-smk-matrixDiagDS.R b/tests/testthat/test-smk-matrixDiagDS.R new file mode 100644 index 00000000..7c99fbd7 --- /dev/null +++ b/tests/testthat/test-smk-matrixDiagDS.R @@ -0,0 +1,26 @@ + +# +# Set up +# + +# context("matrixDiagDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +test_that("simple matrixDiagDS, serverside.matrix.2.vector", { + M1 <- matrix(c(1, 2, 3, 4), 2, 2) + + res <- matrixDiagDS("M1", aim = "serverside.matrix.2.vector", nrows.transmit = "-9") + + expect_equal(length(res), 2) + expect_equal(res[1], 1) + expect_equal(res[2], 4) +}) + +test_that("matrixDiagDS errors when serverside object does not exist", { + expect_error(matrixDiagDS("nonexistent_object", aim = "serverside.matrix.2.vector", nrows.transmit = "-9"), regexp = "does not exist") +}) diff --git a/tests/testthat/test-smk-matrixDimnamesDS.R b/tests/testthat/test-smk-matrixDimnamesDS.R new file mode 100644 index 00000000..c82427ac --- /dev/null +++ b/tests/testthat/test-smk-matrixDimnamesDS.R @@ -0,0 +1,34 @@ + +# +# Set up +# + +# context("matrixDimnamesDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +test_that("simple matrixDimnamesDS", { + M1 <- matrix(c(1, 2, 3, 4), 2, 2) + new.dimnames <- list(c("r1", "r2"), c("c1", "c2")) + + res <- matrixDimnamesDS("M1", dimnames = new.dimnames) + + expect_true(is.matrix(res)) + expect_equal(nrow(res), 2) + expect_equal(ncol(res), 2) + expect_equal(rownames(res), c("r1", "r2")) + expect_equal(colnames(res), c("c1", "c2")) +}) + +test_that("matrixDimnamesDS errors when serverside object does not exist", { + expect_error(matrixDimnamesDS("nonexistent_object", dimnames = list(c("r1"), c("c1"))), regexp = "does not exist") +}) + +test_that("matrixDimnamesDS errors when input is wrong type", { + bad_input <- c("a", "b", "c") + expect_error(matrixDimnamesDS("bad_input", dimnames = list(c("r1"), c("c1"))), regexp = "must be of type") +}) diff --git a/tests/testthat/test-smk-matrixInvertDS.R b/tests/testthat/test-smk-matrixInvertDS.R new file mode 100644 index 00000000..4d9f5ec8 --- /dev/null +++ b/tests/testthat/test-smk-matrixInvertDS.R @@ -0,0 +1,32 @@ + +# +# Set up +# + +# context("matrixInvertDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +test_that("simple matrixInvertDS", { + M1 <- matrix(c(1, 2, 3, 4), 2, 2) + + res <- matrixInvertDS("M1") + + expect_true(is.matrix(res)) + expect_equal(nrow(res), 2) + expect_equal(ncol(res), 2) + expect_equal(res, solve(M1)) +}) + +test_that("matrixInvertDS errors when serverside object does not exist", { + expect_error(matrixInvertDS("nonexistent_object"), regexp = "does not exist") +}) + +test_that("matrixInvertDS errors when input is wrong type", { + bad_input <- c("a", "b", "c") + expect_error(matrixInvertDS("bad_input"), regexp = "must be of type") +}) diff --git a/tests/testthat/test-smk-matrixMultDS.R b/tests/testthat/test-smk-matrixMultDS.R new file mode 100644 index 00000000..19eb58a1 --- /dev/null +++ b/tests/testthat/test-smk-matrixMultDS.R @@ -0,0 +1,34 @@ + +# +# Set up +# + +# context("matrixMultDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +test_that("simple matrixMultDS", { + M1 <- matrix(c(1, 2, 3, 4), 2, 2) + M2 <- matrix(c(5, 6, 7, 8), 2, 2) + + res <- matrixMultDS("M1", "M2") + + expect_true(is.matrix(res)) + expect_equal(nrow(res), 2) + expect_equal(ncol(res), 2) + expect_equal(res, M1 %*% M2) +}) + +test_that("matrixMultDS errors when serverside object does not exist", { + expect_error(matrixMultDS("nonexistent_object", "also_nonexistent"), regexp = "does not exist") +}) + +test_that("matrixMultDS errors when input is wrong type", { + bad_input <- c("a", "b", "c") + M2 <- matrix(c(1, 2, 3, 4), 2, 2) + expect_error(matrixMultDS("bad_input", "M2"), regexp = "must be of type") +}) diff --git a/tests/testthat/test-smk-matrixTransposeDS.R b/tests/testthat/test-smk-matrixTransposeDS.R new file mode 100644 index 00000000..c66d1366 --- /dev/null +++ b/tests/testthat/test-smk-matrixTransposeDS.R @@ -0,0 +1,32 @@ + +# +# Set up +# + +# context("matrixTransposeDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +test_that("simple matrixTransposeDS", { + M1 <- matrix(c(1, 2, 3, 4, 5, 6), 2, 3) + + res <- matrixTransposeDS("M1") + + expect_true(is.matrix(res)) + expect_equal(nrow(res), 3) + expect_equal(ncol(res), 2) + expect_equal(res, t(M1)) +}) + +test_that("matrixTransposeDS errors when serverside object does not exist", { + expect_error(matrixTransposeDS("nonexistent_object"), regexp = "does not exist") +}) + +test_that("matrixTransposeDS errors when input is wrong type", { + bad_input <- c("a", "b", "c") + expect_error(matrixTransposeDS("bad_input"), regexp = "must be of type") +}) diff --git a/tests/testthat/test-smk-rBinomDS.R b/tests/testthat/test-smk-rBinomDS.R index 9cff07d0..a25d1a5b 100644 --- a/tests/testthat/test-smk-rBinomDS.R +++ b/tests/testthat/test-smk-rBinomDS.R @@ -15,6 +15,8 @@ # context("rBinomDS::smk::setup") +set.standard.disclosure.settings() + # # Tests # @@ -58,6 +60,14 @@ test_that("simple rBinomDS, direct", { expect_true(res[8] >= 0) }) +test_that("rBinomDS fails when size references nonexistent object", { + expect_error(rBinomDS(8, "nonexistent_obj", 0.5), "does not exist") +}) + +test_that("rBinomDS fails when prob references nonexistent object", { + expect_error(rBinomDS(8, 1, "nonexistent_obj"), "does not exist") +}) + # # Done # diff --git a/tests/testthat/test-smk-rNormDS.R b/tests/testthat/test-smk-rNormDS.R index 484ef851..0182aab6 100644 --- a/tests/testthat/test-smk-rNormDS.R +++ b/tests/testthat/test-smk-rNormDS.R @@ -15,6 +15,8 @@ # context("rNormDS::smk::setup") +set.standard.disclosure.settings() + # # Tests # @@ -58,6 +60,14 @@ test_that("simple rNormDS, direct", { expect_true(res[8] >= 0) }) +test_that("rNormDS fails when mean references nonexistent object", { + expect_error(rNormDS(8, "nonexistent_obj", 1, 9), "does not exist") +}) + +test_that("rNormDS fails when sd references nonexistent object", { + expect_error(rNormDS(8, 0, "nonexistent_obj", 9), "does not exist") +}) + # # Done # diff --git a/tests/testthat/test-smk-rPoisDS.R b/tests/testthat/test-smk-rPoisDS.R index c2cf55bf..ee9de700 100644 --- a/tests/testthat/test-smk-rPoisDS.R +++ b/tests/testthat/test-smk-rPoisDS.R @@ -15,6 +15,8 @@ # context("rPoisDS::smk::setup") +set.standard.disclosure.settings() + # # Tests # @@ -56,6 +58,10 @@ test_that("simple rPoisDS, direct", { expect_true(res[8] >= 0) }) +test_that("rPoisDS fails when lambda references nonexistent object", { + expect_error(rPoisDS(8, "nonexistent_obj"), "does not exist") +}) + # # Done # diff --git a/tests/testthat/test-smk-rUnifDS.R b/tests/testthat/test-smk-rUnifDS.R index 87c208c4..7507db16 100644 --- a/tests/testthat/test-smk-rUnifDS.R +++ b/tests/testthat/test-smk-rUnifDS.R @@ -15,6 +15,8 @@ # context("rUnifDS::smk::setup") +set.standard.disclosure.settings() + # # Tests # @@ -58,6 +60,14 @@ test_that("simple rUnifDS, direct", { expect_true(res[8] >= 0) }) +test_that("rUnifDS fails when min references nonexistent object", { + expect_error(rUnifDS(8, "nonexistent_obj", 1, 9), "does not exist") +}) + +test_that("rUnifDS fails when max references nonexistent object", { + expect_error(rUnifDS(8, 0, "nonexistent_obj", 9), "does not exist") +}) + # # Done # diff --git a/tests/testthat/test-smk-reShapeDS.R b/tests/testthat/test-smk-reShapeDS.R new file mode 100644 index 00000000..c75d78db --- /dev/null +++ b/tests/testthat/test-smk-reShapeDS.R @@ -0,0 +1,49 @@ + +# +# Set up +# + +# context("reShapeDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +test_that("simple reShapeDS wide to long", { + wide_df <- data.frame( + id = 1:3, + sbp.1 = c(120, 130, 125), + sbp.2 = c(122, 135, 128) + ) + + res <- reShapeDS( + data.name = "wide_df", + varying.transmit = "sbp.1,sbp.2", + v.names.transmit = "sbp", + timevar.name = "time", + idvar.name = "id", + drop.transmit = NULL, + direction = "long", + sep = "." + ) + + expect_s3_class(res, "data.frame") + expect_equal(nrow(res), 6) + expect_true("sbp" %in% colnames(res)) + expect_true("time" %in% colnames(res)) +}) + +test_that("reShapeDS errors when serverside object does not exist", { + expect_error(reShapeDS( + data.name = "nonexistent_object", + varying.transmit = "sbp.1,sbp.2", + v.names.transmit = "sbp", + timevar.name = "time", + idvar.name = "id", + drop.transmit = NULL, + direction = "long", + sep = "." + ), regexp = "does not exist") +}) diff --git a/tests/testthat/test-smk-sampleDS.R b/tests/testthat/test-smk-sampleDS.R index e3927518..6fb5cdd9 100644 --- a/tests/testthat/test-smk-sampleDS.R +++ b/tests/testthat/test-smk-sampleDS.R @@ -46,6 +46,16 @@ test_that("simple sampleDS", { expect_length(res$sampling.order, 16) }) +test_that("sampleDS fails when x references nonexistent object", { + expect_error(sampleDS("nonexistent_obj", 5, FALSE, NULL), "does not exist") +}) + +test_that("sampleDS fails when prob references nonexistent object", { + x <- c(1:32) + + expect_error(sampleDS("x", 5, FALSE, "nonexistent_obj"), "does not exist") +}) + # # Done # diff --git a/tests/testthat/test-smk-scatterPlotDS.R b/tests/testthat/test-smk-scatterPlotDS.R new file mode 100644 index 00000000..7fee3d3e --- /dev/null +++ b/tests/testthat/test-smk-scatterPlotDS.R @@ -0,0 +1,55 @@ +# +# Set up +# + +# context("scatterPlotDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("scatterPlotDS::smk") +test_that("scatterPlotDS, deterministic method", { + xvect <- c(1:20) + yvect <- c(20:1) + + res <- scatterPlotDS("xvect", "yvect", method.indicator=1, k=3, noise=0.25) + + expect_length(res, 4) + expect_length(res[[1]], 20) + expect_length(res[[2]], 20) + expect_equal(res$class.x, "integer") + expect_equal(res$class.y, "integer") +}) + +test_that("scatterPlotDS fails when x references nonexistent object", { + yvect <- c(20:1) + expect_error(scatterPlotDS("nonexistent_obj", "yvect", method.indicator=1, k=3, noise=0.25), "does not exist") +}) + +test_that("scatterPlotDS fails when y references nonexistent object", { + xvect <- c(1:20) + expect_error(scatterPlotDS("xvect", "nonexistent_obj", method.indicator=1, k=3, noise=0.25), "does not exist") +}) + +test_that("scatterPlotDS fails when x is not numeric or integer", { + xvect <- c("a", "b", "c") + yvect <- c(1, 2, 3) + expect_error(scatterPlotDS("xvect", "yvect", method.indicator=1, k=3, noise=0.25), "must be of type numeric or integer") +}) + +test_that("scatterPlotDS fails when y is not numeric or integer", { + xvect <- c(1, 2, 3) + yvect <- c("a", "b", "c") + expect_error(scatterPlotDS("xvect", "yvect", method.indicator=1, k=3, noise=0.25), "must be of type numeric or integer") +}) + +# +# Done +# + +# context("scatterPlotDS::smk::shutdown") + +# context("scatterPlotDS::smk::done") diff --git a/tests/testthat/test-smk-setSeedDS.R b/tests/testthat/test-smk-setSeedDS.R index 0cdbf2e9..a87ab40b 100644 --- a/tests/testthat/test-smk-setSeedDS.R +++ b/tests/testthat/test-smk-setSeedDS.R @@ -15,6 +15,8 @@ # context("setSeedDS::smk::setup") +set.standard.disclosure.settings() + # # Tests # @@ -32,6 +34,18 @@ test_that("simple setSeedDS", { expect_length(res$seed.as.set, 626) }) +test_that("setSeedDS with \"NULL\" seedtext", { + res <- setSeedDS("NULL", NULL, NULL) + + expect_equal(class(res), "list") + expect_length(res, 1) + expect_length(res$seed.as.set, 626) +}) + +test_that("setSeedDS fails with non-numeric seedtext", { + expect_error(suppressWarnings(setSeedDS("abc", NULL, NULL)), "supplied seed is not a valid integer") +}) + # # Done #