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/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/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/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/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/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/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-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")