diff --git a/.circleci/config.yml b/.circleci/config.yml index ec6d40e9..7ee4e084 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -26,22 +26,8 @@ jobs: - run: command: | echo "options(Ncpus=4)" >> ~/.Rprofile - sudo Rscript -e "install.packages('RANN', dependencies=TRUE)" - sudo Rscript -e "install.packages('stringr', dependencies=TRUE)" - sudo Rscript -e "install.packages('lme4', dependencies=TRUE)" - sudo Rscript -e "install.packages('dplyr', dependencies=TRUE)" - sudo Rscript -e "install.packages('reshape2', dependencies=TRUE)" - sudo Rscript -e "install.packages('polycor', dependencies=TRUE)" - sudo Rscript -e "install.packages('splines', dependencies=TRUE)" - sudo Rscript -e "install.packages('gamlss', dependencies=TRUE)" - sudo Rscript -e "install.packages('gamlss.dist', dependencies=TRUE)" - sudo Rscript -e "install.packages('mice', dependencies=TRUE)" - sudo Rscript -e "install.packages('childsds', dependencies=TRUE)" - sudo Rscript -e "install.packages('xml2', dependencies=TRUE)" - sudo Rscript -e "install.packages('covr', dependencies=TRUE)" - sudo Rscript -e "install.packages('devtools', dependencies=TRUE)" - sudo Rscript -e "install.packages('DSI', dependencies=TRUE)" - sudo Rscript -e "install.packages('DSLite', dependencies=TRUE)" + + 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)" - run: command: | sudo Rscript -e 'library(covr); covr::codecov(token = "'$CODECOV_TOKEN'")' diff --git a/.gitignore b/.gitignore index f4edd3a2..dba745c0 100644 --- a/.gitignore +++ b/.gitignore @@ -8,3 +8,4 @@ .Rapp.history .claude .idea +tests/testthat/Rplots.pdf diff --git a/R/elsplineDS.R b/R/elsplineDS.R index c4dcfda8..4248a044 100644 --- a/R/elsplineDS.R +++ b/R/elsplineDS.R @@ -18,6 +18,7 @@ #' @return an object of class "lspline" and "matrix", which its name is specified by the #' \code{newobj} argument (or its default name "elspline.newobj"), is assigned on the serverside. #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' elsplineDS <- function(x = x, n = n, marginal = FALSE, names = NULL){ @@ -54,7 +55,7 @@ elsplineDS <- function(x = x, n = n, marginal = FALSE, names = NULL){ structure(rval, knots = knots, marginal = marginal, class = c("lspline", "matrix")) } - x <- eval(parse(text=x), envir = parent.frame()) + x <- .loadServersideObject(x) stopifnot(n >= 2) k <- seq(min(x, na.rm = TRUE), max(x, na.rm = TRUE), length.out = n + 1)[-c(1, n + 1)] diff --git a/R/getWGSRDS.R b/R/getWGSRDS.R index 225ce433..c23f13d0 100644 --- a/R/getWGSRDS.R +++ b/R/getWGSRDS.R @@ -49,15 +49,26 @@ #' @return \code{ds.getWGSR} assigns a numeric vector that includes the z-scores for the #' specified index. #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' getWGSRDS <- function(sex, firstPart, secondPart, index, standing=NA, thirdPart=NA){ - sex <- eval(parse(text=sex), envir = parent.frame()) - firstPart <- eval(parse(text=firstPart), envir = parent.frame()) - secondPart <- eval(parse(text=secondPart), envir = parent.frame()) + firstPart.name <- firstPart + sex <- .loadServersideObject(sex) + firstPart <- .loadServersideObject(firstPart) + .checkClass(obj = firstPart, obj_name = firstPart.name, permitted_classes = "numeric") + if (!is.na(secondPart)){ + secondPart.name <- secondPart + secondPart <- .loadServersideObject(secondPart) + .checkClass(obj = secondPart, obj_name = secondPart.name, permitted_classes = "numeric") + } if (!is.na(thirdPart)){ - thirdPart <- eval(parse(text=thirdPart), envir = parent.frame()) + thirdPart.name <- thirdPart + thirdPart <- .loadServersideObject(thirdPart) + if (index == "bfa"){ + .checkClass(obj = thirdPart, obj_name = thirdPart.name, permitted_classes = "numeric") + } } # access the internal reference data diff --git a/R/hetcorDS.R b/R/hetcorDS.R index d561ce30..1dd26dae 100644 --- a/R/hetcorDS.R +++ b/R/hetcorDS.R @@ -24,11 +24,12 @@ #' any missing data were handled: "complete.obs" or "pairwise.complete.obs"; TRUE for ML estimates, #' FALSE for two-step estimates. #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' hetcorDS <- function(data, ML, std.err, bins, pd, use){ - data <- eval(parse(text=data), envir = parent.frame()) + data <- .loadServersideObject(data) out <- polycor::hetcor(data = data, ML = ML, std.err = std.err, bins = bins, pd = pd, use = use) diff --git a/R/isValidDS.R b/R/isValidDS.R index f45ccae7..3d5127a9 100644 --- a/R/isValidDS.R +++ b/R/isValidDS.R @@ -2,12 +2,33 @@ #' @title Checks if an input is valid #' @description Tells if an object on the server side is valid. #' @details This function checks if an object is valid. -#' @param obj, a vector (numeric, integer, factor, character), data.frame or matrix -#' @return a boolean, TRUE if input is valid or FALSE if not. +#' @param x a character string, the name of a vector (numeric, integer, factor, character, +#' logical), data.frame or matrix +#' @return a list with \code{valid}, a boolean that is TRUE if the input is valid or FALSE +#' if not, and \code{class}, the class of the input object for client-side consistency +#' checking #' @author Gaye, A. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #'@export #' -isValidDS <- function(obj) { +isValidDS <- function(x) { + + obj <- .loadServersideObject(x) + .checkClass( + obj = obj, + obj_name = x, + permitted_classes = c("character", "factor", "integer", "logical", "numeric", "data.frame", "matrix") + ) + + list(valid = .checkDisclosureSize(obj), class = class(obj)) +} + +#' Check a Server-Side Object Meets the Disclosure Size Threshold +#' +#' @param obj The object to check: a vector, data.frame or matrix. +#' @return A boolean, TRUE if the object meets the threshold or FALSE if not. +#' @noRd +.checkDisclosureSize <- function(obj) { # this filter sets the minimum number of observations that are allowed diff --git a/R/lexisDS1.R b/R/lexisDS1.R index 6c0f8de7..45bea015 100644 --- a/R/lexisDS1.R +++ b/R/lexisDS1.R @@ -7,6 +7,7 @@ #' @param exitCol a character string specifying the variable holding the time that each individual is censored or fails #' #' @author Burton PR +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' #' @return List with `max.time` #' @export @@ -28,7 +29,7 @@ lexisDS1 <- function(exitCol=NULL){ stop(errorMessage, call. = FALSE) } - exposure <- eval(parse(text=exitCol), envir = parent.frame()) + exposure <- .loadServersideObject(exitCol) max.time <- max(exposure, na.rm=TRUE) random.multiplier <- stats::runif(1,1.01,1.05) diff --git a/R/lexisDS2.R b/R/lexisDS2.R index d63989d2..d4366720 100644 --- a/R/lexisDS2.R +++ b/R/lexisDS2.R @@ -31,6 +31,7 @@ #' 'data' argument is set the full data.frame will be expanded and carried forward #' #' @author Burton PR +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' #' @return List with `expanded.table` #' @export @@ -46,10 +47,10 @@ lexisDS2 <- function(datatext=NULL, intervalWidth, maxmaxtime, idCol, entryCol, #nfilter.string<-as.numeric(thr$nfilter.string) ############################################################# - starttime <- eval(parse(text=entryCol), envir = parent.frame()) - endtime <- eval(parse(text=exitCol), envir = parent.frame()) - cens <- eval(parse(text=statusCol), envir = parent.frame()) - id.orig <- eval(parse(text=idCol), envir = parent.frame()) + endtime <- .loadServersideObject(exitCol) + starttime <- if(is.null(entryCol)) rep(0, length(endtime)) else .loadServersideObject(entryCol) + cens <- .loadServersideObject(statusCol) + id.orig <- .loadServersideObject(idCol) starttime <- as.numeric(starttime) endtime <- as.numeric(endtime) @@ -73,14 +74,21 @@ lexisDS2 <- function(datatext=NULL, intervalWidth, maxmaxtime, idCol, entryCol, #IDENTIFY VARIABLES TO BE CARRIED WITH THE EXPANDED SURVIVAL DATA - if(is.null(vartext)){ - datatext2<-paste0("data.frame(",datatext,")") - DF <- eval(parse(text=datatext2), envir = parent.frame()) - } - - if(!is.null(vartext)){ - vartext2<-paste0("data.frame(",vartext,")") - DF<-eval(parse(text=vartext2), envir = parent.frame()) + # 'vartext' takes precedence over 'datatext'. A data.frame name is unpacked into its + # columns and a single column such as D$var is named make.names("D$var"), matching + # how data.frame() named them when the names were parsed as R code. + carried.text <- if(is.null(vartext)) datatext else vartext + if(!is.null(carried.text)){ + col.list <- list() + for(nm in unlist(strsplit(carried.text, split=","))){ + obj <- .loadServersideObject(nm) + if(is.data.frame(obj)){ + col.list <- c(col.list, as.list(obj)) + }else{ + col.list <- c(col.list, stats::setNames(list(obj), make.names(nm))) + } + } + DF <- data.frame(col.list) } if(is.null(datatext)&&is.null(vartext)){ diff --git a/R/lsplineDS.R b/R/lsplineDS.R index 86475bba..22d8bdae 100644 --- a/R/lsplineDS.R +++ b/R/lsplineDS.R @@ -15,6 +15,7 @@ #' @return an object of class "lspline" and "matrix", which its name is specified by the #' \code{newobj} argument (or its default name "lspline.newobj"), is assigned on the serverside. #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' lsplineDS <- function(x = x, knots = NULL, marginal = FALSE, names = NULL){ @@ -51,7 +52,7 @@ lsplineDS <- function(x = x, knots = NULL, marginal = FALSE, names = NULL){ structure(rval, knots = knots, marginal = marginal, class = c("lspline", "matrix")) } - x <- eval(parse(text=x), envir = parent.frame()) + x <- .loadServersideObject(x) out <- lspline_copy(x = x, knots = knots, marginal = marginal, names = names) diff --git a/R/metadataDS.R b/R/metadataDS.R index a416ed61..95f22866 100644 --- a/R/metadataDS.R +++ b/R/metadataDS.R @@ -6,6 +6,7 @@ #' @return a list containing the metadata. The elements of the list will depend #' on the metadata available. #' @author Stuart Wheater, for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' metadataDS <- function(x) @@ -16,7 +17,7 @@ metadataDS <- function(x) if ((! is.character(x)) || (length(x) != 1)) stop("Variable's name isn't be single character vector", call. = FALSE) - x.var <- eval(parse(text=x), envir = parent.frame()) + x.var <- .loadServersideObject(x) if (is.null(x.var)) stop("Variable can't be NULL", call. = FALSE) diff --git a/R/nsDS.R b/R/nsDS.R index 6314c4b8..0c12d7ae 100644 --- a/R/nsDS.R +++ b/R/nsDS.R @@ -25,6 +25,7 @@ #' arguments to ns, and explicitly give the knots, Boundary.knots etc for use by predict.ns(). #' The object is assigned at each serverside. #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' nsDS <- function(x, df, knots, intercept, Boundary.knots){ @@ -33,7 +34,7 @@ nsDS <- function(x, df, knots, intercept, Boundary.knots){ thr <- dsBase::listDisclosureSettingsDS() nfilter.tab <- as.numeric(thr$nfilter.tab) - x <- eval(parse(text=x), envir = parent.frame()) + x <- .loadServersideObject(x) if(is.null(Boundary.knots)){ Boundary.knots <- range(x, na.rm=TRUE) diff --git a/R/qlsplineDS.R b/R/qlsplineDS.R index 3df267f8..55a56abf 100644 --- a/R/qlsplineDS.R +++ b/R/qlsplineDS.R @@ -23,6 +23,7 @@ #' @return an object of class "lspline" and "matrix", which its name is specified by the #' \code{newobj} argument (or its default name "qlspline.newobj"), is assigned on the serverside. #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' qlsplineDS <- function(x = x, q = q, na.rm = TRUE, marginal = FALSE, names = NULL){ @@ -59,7 +60,7 @@ qlsplineDS <- function(x = x, q = q, na.rm = TRUE, marginal = FALSE, names = NUL structure(rval, knots = knots, marginal = marginal, class = c("lspline", "matrix")) } - x <- eval(parse(text=x), envir = parent.frame()) + x <- .loadServersideObject(x) if (length(q) == 1 && q >= 2) { q <- seq(0, 1, length.out = q + 1)[-c(1, q + 1)] diff --git a/R/quantileMeanDS.R b/R/quantileMeanDS.R index b6a54e91..e5358f46 100644 --- a/R/quantileMeanDS.R +++ b/R/quantileMeanDS.R @@ -16,7 +16,7 @@ quantileMeanDS <- function (x) { .checkClass(obj = xvect, obj_name = x, permitted_classes = c("numeric", "integer")) # check if the input vector is valid (i.e. meets DataSHIELD criteria) - check <- isValidDS(xvect) + check <- .checkDisclosureSize(xvect) if(check){ # if the input vector is valid diff --git a/R/rangeDS.R b/R/rangeDS.R index ec9183ea..6d87d83f 100644 --- a/R/rangeDS.R +++ b/R/rangeDS.R @@ -2,12 +2,16 @@ #' @title returns the minimum and maximum of a numeric vector #' @description this function is similar to R function \code{range} but instead to not return #' the real minimum and maximum, the computed values are multiplied by a very small random number. -#' @param xvect a numerical +#' @param x a character string, the name of a numeric or integer vector #' @return a numeric vector which contains the minimum and the maximum values of the vector #' @author Amadou Gaye, Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' -rangeDS <- function(xvect) { +rangeDS <- function(x) { + xvect <- .loadServersideObject(x) + .checkClass(obj = xvect, obj_name = x, permitted_classes = c("numeric", "integer")) + # back-up current .Random.seed and revert on.exit if (exists(x = ".Random.seed", envir = globalenv())) { assign(x = ".old_seed", value = .Random.seed, envir = parent.frame()); diff --git a/R/recodeLevelsDS.R b/R/recodeLevelsDS.R index 6878faa6..b4c47998 100644 --- a/R/recodeLevelsDS.R +++ b/R/recodeLevelsDS.R @@ -14,7 +14,7 @@ recodeLevelsDS <- function (x=NULL, classes=NULL){ dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot')) # check if the input vector is valid (i.e. meets DataSHIELD criteria) - check <- isValidDS(x) + check <- .checkDisclosureSize(x) if(check){ # generate the new variable with the specified levels diff --git a/R/replaceNaDS.R b/R/replaceNaDS.R index 62b91f99..707db8f6 100644 --- a/R/replaceNaDS.R +++ b/R/replaceNaDS.R @@ -21,7 +21,7 @@ replaceNaDS <- function(x, replacements){ xvect <- .loadServersideObject(x) # check if the input vector is valid (i.e. meets DataSHIELD criteria) - check <- dsBase::isValidDS(xvect) + check <- .checkDisclosureSize(xvect) # if the input vector is a factor convert it to numeric cls <- class(xvect) diff --git a/R/rowColCalcDS.R b/R/rowColCalcDS.R index e7a35832..ad09ed60 100644 --- a/R/rowColCalcDS.R +++ b/R/rowColCalcDS.R @@ -4,15 +4,23 @@ #' 'rowMeans' and 'colMeans'. #' @details the output is returned to the user only the number of entries in the #' output vector is greater or equal to the allowed size. -#' @param dataset an array of two or more dimensions. +#' @param dataset.name a character string providing the name of a server-side array of two or more dimensions. #' @param operation an integer that indicates the operation to carry out: #' 1 for 'rowSums', 2 for 'colSums', 3 for 'rowMeans' or 4 for 'colMeans' #' @return a numeric vector #' @export #' @author Gaye, A. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' -rowColCalcDS <- function (dataset, operation) { +rowColCalcDS <- function (dataset.name, operation) { + dataset <- .loadServersideObject(dataset.name) + .checkClass(obj = dataset, obj_name = dataset.name, permitted_classes = c("data.frame", "matrix")) + column.classes <- lapply(as.data.frame(dataset), class) + if(!all(vapply(column.classes, function(cls) any(cls %in% c("numeric", "integer")), logical(1)))){ + stop("One or more columns of '", dataset.name, "' are not of numeric type", call. = FALSE) + } + if(operation == 1){ result <- rowSums(dataset, na.rm=TRUE) } @@ -27,7 +35,7 @@ rowColCalcDS <- function (dataset, operation) { } # check if the output is valid (i.e. meets DataSHIELD criteria) - check <- isValidDS(result) + check <- .checkDisclosureSize(result) if(check){ return(result) }else{ diff --git a/R/tableDS.R b/R/tableDS.R index c190ffc3..8f62c773 100644 --- a/R/tableDS.R +++ b/R/tableDS.R @@ -33,6 +33,7 @@ #' of \code{ds.table}. Fully specified by argument of \code{ds.table} #' @return For information see help for \code{ds.table} #' @author Paul Burton for DataSHIELD Development Team, 13/11/2019 +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export tableDS<-function(rvar.transmit, cvar.transmit, stvar.transmit, rvar.all.unique.levels.transmit, cvar.all.unique.levels.transmit, stvar.all.unique.levels.transmit, exclude.transmit, useNA.transmit, force.nfilter.transmit){ @@ -55,7 +56,7 @@ nfilter.tab<-as.numeric(thr$nfilter.tab) # if(!is.null(force.nfilter.transmit)) { -force.nfilter.active<-eval(parse(text=force.nfilter.transmit), envir = parent.frame()) +force.nfilter.active<-as.numeric(force.nfilter.transmit) if(force.nfilter.active argument of \code{ds.table} #' @return For information see help for \code{ds.table} #' @author Paul Burton for DataSHIELD Development Team, 13/11/2019 +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export tableDS.assign<-function(rvar.transmit, cvar.transmit, stvar.transmit, rvar.all.unique.levels.transmit, cvar.all.unique.levels.transmit, stvar.all.unique.levels.transmit, exclude.transmit, useNA.transmit){ #Activate via eval when needed #rvar -rvar<-eval(parse(text=rvar.transmit), envir = parent.frame()) +rvar<-.loadServersideObject(rvar.transmit) #coerce to factor if required if(!is.factor(rvar)) @@ -53,7 +54,7 @@ if(!is.factor(rvar)) #cvar if(!is.null(cvar.transmit)) { -cvar<-eval(parse(text=cvar.transmit), envir = parent.frame()) +cvar<-.loadServersideObject(cvar.transmit) #coerce to factor if required if(!is.factor(cvar)) @@ -73,7 +74,7 @@ cvar<-NULL #stvar if(!is.null(stvar.transmit)) { -stvar<-eval(parse(text=stvar.transmit), envir = parent.frame()) +stvar<-.loadServersideObject(stvar.transmit) #coerce to factor if required if(!is.factor(stvar)) @@ -93,8 +94,8 @@ stvar<-NULL #exclude if(!is.null(exclude.transmit)) { -exclude.text<-strsplit(exclude.transmit, split=",") -exclude<-eval(parse(text=exclude.text), envir = parent.frame()) +exclude<-unlist(strsplit(exclude.transmit, split=",")) +exclude[exclude=="NA"]<-NA } else { diff --git a/R/tableDS2.R b/R/tableDS2.R index 3ea4803b..81886679 100644 --- a/R/tableDS2.R +++ b/R/tableDS2.R @@ -28,19 +28,18 @@ #' For more information see help for \code{ds.table} #' @return For information see help for \code{ds.table} #' @author Paul Burton for DataSHIELD Development Team, 13/11/2019 +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export tableDS2 <- function(newobj,rvar.transmit,cvar.transmit,stvar.transmit){ -calltext1<-paste0("out.table.real<-",newobj,"[[2]]") -eval(parse(text=calltext1), envir = parent.frame()) +table.obj <- .loadServersideObject(newobj) +out.table.real <- table.obj[[2]] out.table.cell.IDs<-as.vector(1:length(out.table.real)) -calltext2<-paste0("out.table.dim<-",newobj,"[[3]]") -eval(parse(text=calltext2), envir = parent.frame()) +out.table.dim <- table.obj[[3]] -calltext3<-paste0("out.table.dimnames<-",newobj,"[[4]]") -eval(parse(text=calltext3), envir = parent.frame()) +out.table.dimnames <- table.obj[[4]] out.table.structure<-array(out.table.cell.IDs,dim=out.table.dim,dimnames=out.table.dimnames) diff --git a/R/tapplyDS.R b/R/tapplyDS.R index 363589b8..9baab3cc 100644 --- a/R/tapplyDS.R +++ b/R/tapplyDS.R @@ -13,6 +13,7 @@ #' @return an array of the summarized values created by the tapplyDS function. This array #' is returned to the clientside. It has the same number of dimensions as INDEX. #' @author Paul Burton, Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export tapplyDS <- function(X.name, INDEX.names.transmit, FUN.name){ @@ -22,7 +23,7 @@ tapplyDS <- function(X.name, INDEX.names.transmit, FUN.name){ nfilter.subset <- as.numeric(thr$nfilter.subset) if(is.character(X.name)){ - X <- eval(parse(text=X.name), envir = parent.frame()) + X <- .loadServersideObject(X.name) }else{ studysideMessage <- "ERROR: X.name must be specified as a character string" stop(studysideMessage, call. = FALSE) @@ -38,9 +39,8 @@ tapplyDS <- function(X.name, INDEX.names.transmit, FUN.name){ length.test.vector <- rep(NA, num.factors) for(g in 1:num.factors){ - activation.text.0 <- paste0("INDEX.factors[",g,"]") - active.factor.name <- eval(parse(text=activation.text.0)) - active.factor <- eval(parse(text=active.factor.name), envir = parent.frame()) + active.factor.name <- INDEX.factors[g] + active.factor <- .loadServersideObject(active.factor.name) length.test.vector[g] <- length(active.factor) } @@ -52,8 +52,10 @@ tapplyDS <- function(X.name, INDEX.names.transmit, FUN.name){ } # convert INDEX.names format from transmittable to actionable form (a list of vectors) - INDEX.names.list <- paste0("list(",INDEX.names.transmit,")") - INDEX <- eval(parse(text=INDEX.names.list), envir = parent.frame()) + INDEX <- vector("list", num.factors) + for(g in 1:num.factors){ + INDEX[[g]] <- .loadServersideObject(INDEX.factors[g]) + } # select complete cases on X and all INDEX factors only df <- as.data.frame(cbind(X, do.call(cbind, INDEX))) diff --git a/R/tapplyDS.assign.R b/R/tapplyDS.assign.R index 1e3ce77f..5f2978ff 100644 --- a/R/tapplyDS.assign.R +++ b/R/tapplyDS.assign.R @@ -13,6 +13,7 @@ #' @return an array of the summarized values created by the \code{tapplyDS.assign} function. This #' array is written as a newobj on the serverside. It has the same number of dimensions as INDEX. #' @author Paul Burton, Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export tapplyDS.assign <- function(X.name, INDEX.names.transmit, FUN.name){ @@ -22,7 +23,7 @@ tapplyDS.assign <- function(X.name, INDEX.names.transmit, FUN.name){ nfilter.subset <- as.numeric(thr$nfilter.subset) if(is.character(X.name)){ - X <- eval(parse(text=X.name), envir = parent.frame()) + X <- .loadServersideObject(X.name) }else{ studysideMessage <- "ERROR: X.name must be specified as a character string" stop(studysideMessage, call. = FALSE) @@ -38,9 +39,8 @@ tapplyDS.assign <- function(X.name, INDEX.names.transmit, FUN.name){ length.test.vector <- rep(NA, num.factors) for(g in 1:num.factors){ - activation.text.0 <- paste0("INDEX.factors[",g,"]") - active.factor.name <- eval(parse(text=activation.text.0)) - active.factor <- eval(parse(text=active.factor.name), envir = parent.frame()) + active.factor.name <- INDEX.factors[g] + active.factor <- .loadServersideObject(active.factor.name) length.test.vector[g] <- length(active.factor) } @@ -52,8 +52,10 @@ tapplyDS.assign <- function(X.name, INDEX.names.transmit, FUN.name){ } # convert INDEX.names format from transmittable to actionable form (a list of vectors) - INDEX.names.list <- paste0("list(",INDEX.names.transmit,")") - INDEX <- eval(parse(text=INDEX.names.list), envir = parent.frame()) + INDEX <- vector("list", num.factors) + for(g in 1:num.factors){ + INDEX[[g]] <- .loadServersideObject(INDEX.factors[g]) + } # select complete cases on X and all INDEX factors only df <- as.data.frame(cbind(X, do.call(cbind, INDEX))) diff --git a/azure-pipelines.yml b/azure-pipelines.yml index 94c767e9..77679f06 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -27,8 +27,7 @@ variables: branchName: $(Build.SourceBranchName) test_filter: '*' _r_check_system_clock_: 0 - PERF_PROFILE: 'azure-pipeline' - + perf.profile: 'azure-pipeline' ######################################################################################### @@ -50,13 +49,13 @@ schedules: displayName: Weekly build - latest release branches: include: - - 6.3.4 + - 6.3.5 always: true - cron: "0 1 * * *" displayName: Nightly build - development branchs branches: include: - - v6.3.5-dev + - v6.3.6-dev - v6.4.0-dev - v7.0.0-dev always: true @@ -184,7 +183,7 @@ jobs: # R output and messages are redirected by sink() to test_console_output.txt # junit reporter output is to test_results.xml - sudo R -q -e ' + sudo env PERF_PROFILE=$PERF_PROFILE R -q -e ' library(covr); write.csv( coverage_to_list( diff --git a/man/elsplineDS.Rd b/man/elsplineDS.Rd index 1d0c7fd5..d3a81fe5 100644 --- a/man/elsplineDS.Rd +++ b/man/elsplineDS.Rd @@ -36,4 +36,6 @@ range of x into n equal-width intervals. } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/getWGSRDS.Rd b/man/getWGSRDS.Rd index 4ecc45b2..98aa2f36 100644 --- a/man/getWGSRDS.Rd +++ b/man/getWGSRDS.Rd @@ -69,4 +69,6 @@ data. } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/hetcorDS.Rd b/man/hetcorDS.Rd index 2745ce65..5c558936 100644 --- a/man/hetcorDS.Rd +++ b/man/hetcorDS.Rd @@ -44,4 +44,6 @@ variables, and polychoric correlations between ordinal variables. } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/isValidDS.Rd b/man/isValidDS.Rd index fae92c96..33682d4c 100644 --- a/man/isValidDS.Rd +++ b/man/isValidDS.Rd @@ -4,13 +4,16 @@ \alias{isValidDS} \title{Checks if an input is valid} \usage{ -isValidDS(obj) +isValidDS(x) } \arguments{ -\item{obj, }{a vector (numeric, integer, factor, character), data.frame or matrix} +\item{x}{a character string, the name of a vector (numeric, integer, factor, character, +logical), data.frame or matrix} } \value{ -a boolean, TRUE if input is valid or FALSE if not. +a list with \code{valid}, a boolean that is TRUE if the input is valid or FALSE +if not, and \code{class}, the class of the input object for client-side consistency +checking } \description{ Tells if an object on the server side is valid. @@ -20,4 +23,6 @@ This function checks if an object is valid. } \author{ Gaye, A. + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/lexisDS1.Rd b/man/lexisDS1.Rd index da419723..9b560add 100644 --- a/man/lexisDS1.Rd +++ b/man/lexisDS1.Rd @@ -21,4 +21,6 @@ For more details see the extensive header for ds.lexis. } \author{ Burton PR + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/lexisDS2.Rd b/man/lexisDS2.Rd index 51ca6851..6b9ca122 100644 --- a/man/lexisDS2.Rd +++ b/man/lexisDS2.Rd @@ -62,4 +62,6 @@ For more details see the extensive header for ds.lexis. } \author{ Burton PR + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/lsplineDS.Rd b/man/lsplineDS.Rd index 23445b51..af17aa0f 100644 --- a/man/lsplineDS.Rd +++ b/man/lsplineDS.Rd @@ -33,4 +33,6 @@ in slope as compared to the previous segment. } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/metadataDS.Rd b/man/metadataDS.Rd index f7749090..5851b7a3 100644 --- a/man/metadataDS.Rd +++ b/man/metadataDS.Rd @@ -21,4 +21,6 @@ The function returns the metadata, obtained from attributes function. } \author{ Stuart Wheater, for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/nsDS.Rd b/man/nsDS.Rd index 302bd919..060ff5a3 100644 --- a/man/nsDS.Rd +++ b/man/nsDS.Rd @@ -44,4 +44,6 @@ A primary use is in modeling formula to directly specify a natural spline term i } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/qlsplineDS.Rd b/man/qlsplineDS.Rd index aa14326a..63c81831 100644 --- a/man/qlsplineDS.Rd +++ b/man/qlsplineDS.Rd @@ -42,4 +42,6 @@ probabilities directly (the vector is passed to argument probs of quantile). } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/rangeDS.Rd b/man/rangeDS.Rd index 9d0f13fa..b2f188e9 100644 --- a/man/rangeDS.Rd +++ b/man/rangeDS.Rd @@ -4,10 +4,10 @@ \alias{rangeDS} \title{returns the minimum and maximum of a numeric vector} \usage{ -rangeDS(xvect) +rangeDS(x) } \arguments{ -\item{xvect}{a numerical} +\item{x}{a character string, the name of a numeric or integer vector} } \value{ a numeric vector which contains the minimum and the maximum values of the vector @@ -18,4 +18,6 @@ the real minimum and maximum, the computed values are multiplied by a very small } \author{ Amadou Gaye, Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/rowColCalcDS.Rd b/man/rowColCalcDS.Rd index 28bd8b01..aaf4c93d 100644 --- a/man/rowColCalcDS.Rd +++ b/man/rowColCalcDS.Rd @@ -4,10 +4,10 @@ \alias{rowColCalcDS} \title{Computes sums and means of rows or columns of numeric arrays} \usage{ -rowColCalcDS(dataset, operation) +rowColCalcDS(dataset.name, operation) } \arguments{ -\item{dataset}{an array of two or more dimensions.} +\item{dataset.name}{a character string providing the name of a server-side array of two or more dimensions.} \item{operation}{an integer that indicates the operation to carry out: 1 for 'rowSums', 2 for 'colSums', 3 for 'rowMeans' or 4 for 'colMeans'} @@ -25,4 +25,6 @@ output vector is greater or equal to the allowed size. } \author{ Gaye, A. + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/tableDS.Rd b/man/tableDS.Rd index 752eb815..7314c2ee 100644 --- a/man/tableDS.Rd +++ b/man/tableDS.Rd @@ -67,4 +67,6 @@ in native R. } \author{ Paul Burton for DataSHIELD Development Team, 13/11/2019 + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/tableDS.assign.Rd b/man/tableDS.assign.Rd index 8214ab3d..4989ec5d 100644 --- a/man/tableDS.assign.Rd +++ b/man/tableDS.assign.Rd @@ -65,4 +65,6 @@ in native R. } \author{ Paul Burton for DataSHIELD Development Team, 13/11/2019 + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/tableDS2.Rd b/man/tableDS2.Rd index 86e27027..1538d621 100644 --- a/man/tableDS2.Rd +++ b/man/tableDS2.Rd @@ -47,4 +47,6 @@ in DataSHIELD and the \code{table} function in native R. } \author{ Paul Burton for DataSHIELD Development Team, 13/11/2019 + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/tapplyDS.Rd b/man/tapplyDS.Rd index b72ed2f5..c7d62d84 100644 --- a/man/tapplyDS.Rd +++ b/man/tapplyDS.Rd @@ -31,4 +31,6 @@ see details for \code{ds.tapply} function } \author{ Paul Burton, Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/tapplyDS.assign.Rd b/man/tapplyDS.assign.Rd index f57d4f03..7beac224 100644 --- a/man/tapplyDS.assign.Rd +++ b/man/tapplyDS.assign.Rd @@ -31,4 +31,6 @@ see details for \code{ds.tapply.assign} function } \author{ Paul Burton, Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/tests/testthat/perf_files/azure-pipeline_perf-profile.csv b/tests/testthat/perf_files/azure-pipeline_perf-profile.csv index 77f556bc..5267505e 100644 --- a/tests/testthat/perf_files/azure-pipeline_perf-profile.csv +++ b/tests/testthat/perf_files/azure-pipeline_perf-profile.csv @@ -1,5 +1,5 @@ "refer_name","rate","lower_tolerance","upper_tolerance" -"meanDS::perf::numeric::0","2998.9844","0.5","2" -"meanDS::perf::numberAndNA::0","3027.3963","0.5","2" -"varDS::perf::numeric::0","3124.4088","0.5","2" -"varDS::perf::numberAndNA::0","3146.532","0.5","2" +"meanDS::perf::numeric::0","4497.0","0.5","2" +"meanDS::perf::numberAndNA::0","4542.0","0.5","2" +"varDS::perf::numeric::0","6373.0","0.5","2" +"varDS::perf::numberAndNA::0","4500.0","0.5","2" diff --git a/tests/testthat/test-perf-meanDS.R b/tests/testthat/test-perf-meanDS.R index 53e4c7af..c8ecf405 100644 --- a/tests/testthat/test-perf-meanDS.R +++ b/tests/testthat/test-perf-meanDS.R @@ -26,7 +26,7 @@ set.standard.disclosure.settings() # context("meanDS::perf::numeric") test_that("numeric meanDS - performance", { - skip_on_cran() +# skip_on_cran() input <- c(0.0, 1.0, 2.0, 3.0, 4.0) @@ -45,10 +45,10 @@ test_that("numeric meanDS - performance", { .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) .reference.rate <- perf.reference.rate("meanDS::perf::numeric::0") if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { - print(paste("meanDS::perf::numeric::0 ", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper())) + write(paste("meanDS::perf::numeric::0 ", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper()), stderr()) perf.reference.save("meanDS::perf::numeric::0", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper()) } else { - print(paste("meanDS::perf::numeric::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + write(paste("meanDS::perf::numeric::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = ''), stderr()) } .reference.rate <- perf.reference.rate("meanDS::perf::numeric::0") @@ -61,7 +61,7 @@ test_that("numeric meanDS - performance", { # context("meanDS::perf::numeric with NA") test_that("numeric meanDS, with NA - performance", { - skip_on_cran() +# skip_on_cran() input <- c(0.0, NA, 2.0, NA, 4.0) @@ -80,10 +80,10 @@ test_that("numeric meanDS, with NA - performance", { .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) .reference.rate <- perf.reference.rate("meanDS::perf::numberAndNA::0") if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { - print(paste("meanDS::perf::numberAndNA::0 ", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper())) + write(paste("meanDS::perf::numberAndNA::0 ", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper()), stderr()) perf.reference.save("meanDS::perf::numberAndNA::0", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper()) } else { - print(paste("meanDS::perf::numberAndNA::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + write(paste("meanDS::perf::numberAndNA::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = ''), stderr()) } .reference.rate <- perf.reference.rate("meanDS::perf::numberAndNA::0") diff --git a/tests/testthat/test-perf-varDS.R b/tests/testthat/test-perf-varDS.R index 9df6c0f6..922db89a 100644 --- a/tests/testthat/test-perf-varDS.R +++ b/tests/testthat/test-perf-varDS.R @@ -26,7 +26,7 @@ set.standard.disclosure.settings() # context("varDS::perf::numeric") test_that("numeric varDS - performance", { - skip_on_cran() +# skip_on_cran() input <- c(0.0, 1.0, 2.0, 3.0, 4.0) @@ -45,10 +45,10 @@ test_that("numeric varDS - performance", { .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) .reference.rate <- perf.reference.rate("varDS::perf::numeric::0") if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { - print(paste("varDS::perf::numeric::0 ", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper())) + write(paste("varDS::perf::numeric::0 ", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper()), stderr()) perf.reference.save("varDS::perf::numeric::0", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper()) } else { - print(paste("varDS::perf::numeric::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + write(paste("varDS::perf::numeric::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = ''), stderr()) } .reference.rate <- perf.reference.rate("varDS::perf::numeric::0") @@ -61,7 +61,7 @@ test_that("numeric varDS - performance", { # context("varDS::perf::numeric with NA") test_that("numeric varDS, with NA - performance", { - skip_on_cran() +# skip_on_cran() input <- c(0.0, NA, 2.0, NA, 4.0) @@ -80,10 +80,10 @@ test_that("numeric varDS, with NA - performance", { .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) .reference.rate <- perf.reference.rate("varDS::perf::numberAndNA::0") if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { - print(paste("varDS::perf::numberAndNA::0 ", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper())) + write(paste("varDS::perf::numberAndNA::0 ", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper()), stderr()) perf.reference.save("varDS::perf::numberAndNA::0", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper()) } else { - print(paste("varDS::perf::numberAndNA::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) + write(paste("varDS::perf::numberAndNA::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = ''), stderr()) } .reference.rate <- perf.reference.rate("varDS::perf::numberAndNA::0") diff --git a/tests/testthat/test-smk-elsplineDS.R b/tests/testthat/test-smk-elsplineDS.R new file mode 100644 index 00000000..1acc8b51 --- /dev/null +++ b/tests/testthat/test-smk-elsplineDS.R @@ -0,0 +1,38 @@ +# +# Set up +# + +# context("elsplineDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("elsplineDS::smk") +test_that("simple elsplineDS", { + input <- seq(1, 30, by = 1) + + res <- elsplineDS("input", 3) + + expect_equal(class(res), c("lspline", "matrix")) + expect_equal(dim(res), c(30, 3)) + expect_equal(unname(res[1, ]), c(1, 0, 0)) + expect_equal(unname(res[30, ]), c(10.66667, 9.666667, 9.666667), tolerance = 1e-6) +}) + +test_that("elsplineDS throws error when object does not exist", { + expect_error( + elsplineDS("nonexistent_object", 3), + regexp = "does not exist" + ) +}) + +# +# Done +# + +# context("elsplineDS::smk::shutdown") + +# context("elsplineDS::smk::done") diff --git a/tests/testthat/test-smk-getWGSRDS.R b/tests/testthat/test-smk-getWGSRDS.R index 73d0eda1..dab37f42 100644 --- a/tests/testthat/test-smk-getWGSRDS.R +++ b/tests/testthat/test-smk-getWGSRDS.R @@ -149,6 +149,37 @@ test_that("simple getWGSRDS - mfa", { expect_true(is.na(res[10])) }) +test_that("getWGSRDS throws error when firstPart does not exist", { + expect_error( + getWGSRDS("data$sex", "nonexistent_object", "data$age", "hfa", NA, NA), + regexp = "does not exist" + ) +}) + +test_that("getWGSRDS throws error when firstPart is not numeric", { + bad_input <- factor(c("a", "b")) + expect_error( + getWGSRDS("data$sex", "bad_input", "data$age", "hfa", NA, NA), + regexp = "must be of type numeric\\." + ) +}) + +test_that("getWGSRDS throws error when secondPart is not numeric", { + bad_input <- factor(c("a", "b")) + expect_error( + getWGSRDS("data$sex", "data$height", "bad_input", "hfa", NA, NA), + regexp = "must be of type numeric\\." + ) +}) + +test_that("getWGSRDS throws error when thirdPart is not numeric", { + bad_input <- factor(c("a", "b")) + expect_error( + getWGSRDS("data$sex", "data$weight", "data$height", "bfa", NA, "bad_input"), + regexp = "must be of type numeric\\." + ) +}) + # # Done # diff --git a/tests/testthat/test-smk-hetcorDS.R b/tests/testthat/test-smk-hetcorDS.R index fd5ca14e..168f1084 100644 --- a/tests/testthat/test-smk-hetcorDS.R +++ b/tests/testthat/test-smk-hetcorDS.R @@ -83,6 +83,13 @@ test_that("hetcorDS", { }) +test_that("hetcorDS throws error when object does not exist", { + expect_error( + hetcorDS(data = "nonexistent_object", ML = FALSE, std.err = TRUE, bins = 2, pd = TRUE, use = "complete.obs"), + regexp = "does not exist" + ) +}) + # # Done # diff --git a/tests/testthat/test-smk-isValidDS.R b/tests/testthat/test-smk-isValidDS.R index 81fc5ade..83937374 100644 --- a/tests/testthat/test-smk-isValidDS.R +++ b/tests/testthat/test-smk-isValidDS.R @@ -15,6 +15,8 @@ # context("isValidDS::smk::setup") +set.standard.disclosure.settings() + # # Tests # @@ -23,229 +25,195 @@ test_that("simple isValidDS, character", { input <- "value" - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, FALSE) }) test_that("simple isValidDS, character vector", { input <- c("value1", "value2", "value3", "value4") - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, TRUE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, TRUE) }) # context("isValidDS::smk::integer") test_that("simple isValidDS, integer", { input <- 1L - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, FALSE) }) test_that("simple isValidDS, integer vector", { input <- c(1L, 2L, 3L, 4L) - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, TRUE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, TRUE) }) # context("isValidDS::smk::numeric") test_that("simple isValidDS, numeric", { input <- 1.1 - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, FALSE) }) test_that("simple isValidDS, numeric vector", { input <- c(1.1, 2.1, 3.1, 4.1) - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, TRUE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, TRUE) }) # context("isValidDS::smk::logical") test_that("simple isValidDS, logical, FALSE", { input <- FALSE - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, FALSE) }) test_that("simple isValidDS, logical, TRUE", { input <- TRUE - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, FALSE) }) test_that("simple isValidDS, logical vector", { input <- c(FALSE, TRUE, FALSE, TRUE) - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, TRUE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, TRUE) }) test_that("simple isValidDS, factor", { input <- as.factor("a") - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, FALSE) }) test_that("simple isValidDS, factor vector", { input <- as.factor(c("a", "a", "a", "a", "b", "b", "b", "b")) - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, TRUE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, TRUE) }) test_that("simple isValidDS, factor vector", { input <- as.factor(c("a", "b", "c", "d", "e", "f")) - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, FALSE) }) # context("isValidDS::smk::data.frame") test_that("simple isValidDS, data.frame", { input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, TRUE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, TRUE) }) # context("isValidDS::smk::array") -test_that("simple isValidDS, array", { +test_that("isValidDS throws error for a 1-d array", { input <- array(c(0.0, 1.0, 2.0, 3.0, 4.0)) - res <- isValidDS(input) - - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) + expect_error(isValidDS("input"), regexp = "must be of type") }) # context("isValidDS::smk::matrix") test_that("simple isValidDS, matrix", { input <- matrix(c(0.0, 1.0, 2.0, 3.0, 4.0)) - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, TRUE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, TRUE) }) # context("isValidDS::smk::data.matrix") test_that("simple isValidDS, data.matrix", { input <- data.matrix(data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0))) - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, TRUE) + expect_equal(class(res$valid), "logical") + expect_length(res$valid, 1) + expect_equal(res$valid, TRUE) }) # context("isValidDS::smk::date") -test_that("simple isValidDS, date", { +test_that("isValidDS throws error for a date", { input <- Sys.Date() - res <- isValidDS(input) - - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) + expect_error(isValidDS("input"), regexp = "must be of type") }) -# context("isValidDS::smk::formula") -test_that("simple isValidDS, formula", { - input <- X ~ A + B +test_that("isValidDS returns the class of the input", { + input <- c(1.1, 2.1, 3.1, 4.1) - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) + expect_equal(res$class, "numeric") }) -# context("isValidDS::smk::environment") -test_that("simple isValidDS, environment", { - input <- environment() - - res <- isValidDS(input) - - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) +test_that("isValidDS throws error when object does not exist", { + expect_error(isValidDS("nonexistent_object"), regexp = "does not exist") }) -# context("isValidDS::smk::NA") test_that("special isValidDS, NA", { input <- NA - res <- isValidDS(input) + res <- isValidDS("input") - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) + expect_equal(res$valid, FALSE) }) -# context("isValidDS::smk::NULL") test_that("special isValidDS, NULL", { input <- NULL - res <- isValidDS(input) - - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) + expect_error(isValidDS("input"), regexp = "must be of type") }) - -# -# Done -# - -# context("isValidDS::smk::shutdown") - -# context("isValidDS::smk::done") diff --git a/tests/testthat/test-smk-lexisDS1.R b/tests/testthat/test-smk-lexisDS1.R new file mode 100644 index 00000000..c0453a77 --- /dev/null +++ b/tests/testthat/test-smk-lexisDS1.R @@ -0,0 +1,39 @@ +# +# Set up +# + +# context("lexisDS1::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("lexisDS1::smk") +test_that("simple lexisDS1", { + input <- c(1, 5, 3, 9, 2) + + res <- lexisDS1("input") + + expect_equal(class(res), "list") + expect_equal(names(res), "max.time") + # max.time is the max exposure time masked by a random +1%-5% increment + expect_gte(res$max.time, 9 * 1.01) + expect_lte(res$max.time, 9 * 1.05) +}) + +test_that("lexisDS1 throws error when object does not exist", { + expect_error( + lexisDS1("nonexistent_object"), + regexp = "does not exist" + ) +}) + +# +# Done +# + +# context("lexisDS1::smk::shutdown") + +# context("lexisDS1::smk::done") diff --git a/tests/testthat/test-smk-lexisDS2.R b/tests/testthat/test-smk-lexisDS2.R new file mode 100644 index 00000000..b29655cb --- /dev/null +++ b/tests/testthat/test-smk-lexisDS2.R @@ -0,0 +1,91 @@ +# +# Set up +# + +# context("lexisDS2::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("lexisDS2::smk::datatext") +test_that("simple lexisDS2, datatext names a whole data.frame", { + D <- data.frame(id = 1:6, start = rep(0, 6), end = rep(5, 6), status = rep(1, 6), extra = 101:106) + + res <- lexisDS2( + datatext = "D", intervalWidth = "10", maxmaxtime = 10, + idCol = "D$id", entryCol = "D$start", exitCol = "D$end", statusCol = "D$status", vartext = NULL + ) + + expect_equal(class(res), "list") + # carried-forward columns must keep D's own column names, not be corrupted + # or misaligned by the data.frame construction (see lexisDS2 datatext/vartext handling) + expect_true(all(c("id", "start", "end", "status", "extra") %in% names(res$expanded.table))) + expect_equal(res$expanded.table$extra, 101:106) + expect_equal(nrow(res$expanded.table), 6) +}) + +# context("lexisDS2::smk::vartext") +test_that("simple lexisDS2, vartext names individual $-qualified columns", { + D <- data.frame(id = 1:6, start = rep(0, 6), end = rep(5, 6), status = rep(1, 6), extra = 101:106, extra2 = 201:206) + + res <- lexisDS2( + datatext = NULL, intervalWidth = "10", maxmaxtime = 10, + idCol = "D$id", entryCol = "D$start", exitCol = "D$end", statusCol = "D$status", + vartext = "D$extra,D$extra2" + ) + + expect_equal(class(res), "list") + expect_true(all(c("D.extra", "D.extra2") %in% names(res$expanded.table))) + expect_equal(res$expanded.table$D.extra, 101:106) + expect_equal(res$expanded.table$D.extra2, 201:206) +}) + +# context("lexisDS2::smk::no.carry.forward") +test_that("simple lexisDS2, no datatext or vartext", { + D <- data.frame(id = 1:6, start = rep(0, 6), end = rep(5, 6), status = rep(1, 6)) + + res <- lexisDS2( + datatext = NULL, intervalWidth = "10", maxmaxtime = 10, + idCol = "D$id", entryCol = "D$start", exitCol = "D$end", statusCol = "D$status", vartext = NULL + ) + + expect_equal(class(res), "list") + expect_equal(nrow(res$expanded.table), 6) +}) + +test_that("lexisDS2 throws error when object does not exist", { + D <- data.frame(id = 1:6, start = rep(0, 6), end = rep(5, 6), status = rep(1, 6)) + + expect_error( + lexisDS2( + datatext = NULL, intervalWidth = "10", maxmaxtime = 10, + idCol = "D$id", entryCol = "D$start", exitCol = "nonexistent_object", statusCol = "D$status", vartext = NULL + ), + regexp = "does not exist" + ) +}) + +# context("lexisDS2::smk::no.entryCol") +test_that("simple lexisDS2, entryCol not given defaults entry times to 0", { + D <- data.frame(id = 1:6, end = rep(5, 6), status = rep(1, 6)) + + res <- lexisDS2( + datatext = NULL, intervalWidth = "10", maxmaxtime = 10, + idCol = "D$id", entryCol = NULL, exitCol = "D$end", statusCol = "D$status", vartext = NULL + ) + + expect_equal(class(res), "list") + expect_equal(nrow(res$expanded.table), 6) + expect_true(all(res$expanded.table$SURVTIME == 5)) +}) + +# +# Done +# + +# context("lexisDS2::smk::shutdown") + +# context("lexisDS2::smk::done") diff --git a/tests/testthat/test-smk-lsplineDS.R b/tests/testthat/test-smk-lsplineDS.R new file mode 100644 index 00000000..88aa44e1 --- /dev/null +++ b/tests/testthat/test-smk-lsplineDS.R @@ -0,0 +1,38 @@ +# +# Set up +# + +# context("lsplineDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("lsplineDS::smk") +test_that("simple lsplineDS", { + input <- seq(1, 30, by = 1) + + res <- lsplineDS("input", knots = c(10, 20)) + + expect_equal(class(res), c("lspline", "matrix")) + expect_equal(dim(res), c(30, 3)) + expect_equal(unname(res[1, ]), c(1, 0, 0)) + expect_equal(unname(res[30, ]), c(10, 10, 10)) +}) + +test_that("lsplineDS throws error when object does not exist", { + expect_error( + lsplineDS("nonexistent_object", knots = c(10, 20)), + regexp = "does not exist" + ) +}) + +# +# Done +# + +# context("lsplineDS::smk::shutdown") + +# context("lsplineDS::smk::done") diff --git a/tests/testthat/test-smk-metadataDS.R b/tests/testthat/test-smk-metadataDS.R index 4b0ab042..12cf94e5 100644 --- a/tests/testthat/test-smk-metadataDS.R +++ b/tests/testthat/test-smk-metadataDS.R @@ -46,6 +46,16 @@ test_that("simple metadataDS, list of vectors", { expect_length(res, 0) }) +test_that("metadataDS throws error when object does not exist", { + expect_error(metadataDS("nonexistent_object"), regexp = "does not exist") +}) + +test_that("metadataDS throws error when column does not exist", { + input <- list(v1 = c(0.0, 1.0, 2.0)) + + expect_error(metadataDS("input$nonexistent_column"), regexp = "not found in 'input'") +}) + # # Done # diff --git a/tests/testthat/test-smk-nsDS.R b/tests/testthat/test-smk-nsDS.R new file mode 100644 index 00000000..1f21383a --- /dev/null +++ b/tests/testthat/test-smk-nsDS.R @@ -0,0 +1,37 @@ +# +# Set up +# + +# context("nsDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("nsDS::smk") +test_that("simple nsDS", { + input <- seq(1, 30, by = 1) + + res <- nsDS("input", df = 3, knots = NULL, intercept = FALSE, Boundary.knots = NULL) + + expect_equal(class(res), c("ns", "basis", "matrix")) + expect_equal(dim(res), c(30, 3)) + expect_equal(unname(res[1, ]), c(0, 0, 0)) +}) + +test_that("nsDS throws error when object does not exist", { + expect_error( + nsDS("nonexistent_object", df = 3, knots = NULL, intercept = FALSE, Boundary.knots = NULL), + regexp = "does not exist" + ) +}) + +# +# Done +# + +# context("nsDS::smk::shutdown") + +# context("nsDS::smk::done") diff --git a/tests/testthat/test-smk-qlsplineDS.R b/tests/testthat/test-smk-qlsplineDS.R new file mode 100644 index 00000000..4eea279c --- /dev/null +++ b/tests/testthat/test-smk-qlsplineDS.R @@ -0,0 +1,37 @@ +# +# Set up +# + +# context("qlsplineDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("qlsplineDS::smk") +test_that("simple qlsplineDS", { + input <- seq(1, 30, by = 1) + + res <- qlsplineDS("input", q = 3, na.rm = TRUE, marginal = FALSE) + + expect_equal(class(res), c("lspline", "matrix")) + expect_equal(dim(res), c(30, 3)) + expect_equal(unname(res[1, ]), c(1, 0, 0)) +}) + +test_that("qlsplineDS throws error when object does not exist", { + expect_error( + qlsplineDS("nonexistent_object", q = 3, na.rm = TRUE, marginal = FALSE), + regexp = "does not exist" + ) +}) + +# +# Done +# + +# context("qlsplineDS::smk::shutdown") + +# context("qlsplineDS::smk::done") diff --git a/tests/testthat/test-smk-rangeDS.R b/tests/testthat/test-smk-rangeDS.R index c59c9d32..31f58566 100644 --- a/tests/testthat/test-smk-rangeDS.R +++ b/tests/testthat/test-smk-rangeDS.R @@ -25,7 +25,7 @@ set.random.seed.setting(1234) test_that("numeric rangeDS", { input <- c(0.0, 1.0, 2.0, 3.0, 4.0, 4.0, 3.0, 2.0, 1.0, 0.0) - res <- rangeDS(input) + res <- rangeDS("input") expect_length(res, 2) expect_equal(class(res), "numeric") @@ -37,7 +37,7 @@ test_that("numeric rangeDS", { test_that("character rangeDS", { input <- c(0.0, NA, 2.0, NA, 4.0, NA, 3.0, NA, 1.0, NA) - res <- rangeDS(input) + res <- rangeDS("input") expect_length(res, 2) expect_equal(class(res), "numeric") @@ -45,6 +45,16 @@ test_that("character rangeDS", { expect_equal(res[2], 4.12446, tolerance = 1e-6) }) +test_that("rangeDS throws error when object does not exist", { + expect_error(rangeDS("nonexistent_object"), regexp = "does not exist") +}) + +test_that("rangeDS throws error when object is not numeric", { + input <- c("a", "b", "c") + + expect_error(rangeDS("input"), regexp = "must be of type numeric or integer") +}) + # # Done # diff --git a/tests/testthat/test-smk-rowColCalcDS.R b/tests/testthat/test-smk-rowColCalcDS.R index 615aa2ff..f0d563b6 100644 --- a/tests/testthat/test-smk-rowColCalcDS.R +++ b/tests/testthat/test-smk-rowColCalcDS.R @@ -25,7 +25,7 @@ set.standard.disclosure.settings() test_that("simple rowColCalcDS, operation 1", { input <- matrix(c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0), ncol = 2) - res <- rowColCalcDS(input, 1) + res <- rowColCalcDS("input", 1) expect_equal(class(res), "numeric") expect_length(res, 4) @@ -38,7 +38,7 @@ test_that("simple rowColCalcDS, operation 1", { test_that("simple rowColCalcDS, operation 2", { input <- matrix(c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0), ncol = 4) - res <- rowColCalcDS(input, 2) + res <- rowColCalcDS("input", 2) expect_equal(class(res), "numeric") expect_length(res, 4) @@ -51,7 +51,7 @@ test_that("simple rowColCalcDS, operation 2", { test_that("simple rowColCalcDS, operation 3", { input <- matrix(c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0), ncol = 2) - res <- rowColCalcDS(input, 3) + res <- rowColCalcDS("input", 3) expect_equal(class(res), "numeric") expect_length(res, 4) @@ -64,7 +64,7 @@ test_that("simple rowColCalcDS, operation 3", { test_that("simple rowColCalcDS, operation 4", { input <- matrix(c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0), ncol = 4) - res <- rowColCalcDS(input, 4) + res <- rowColCalcDS("input", 4) expect_equal(class(res), "numeric") expect_length(res, 4) @@ -74,6 +74,27 @@ test_that("simple rowColCalcDS, operation 4", { expect_equal(res[4], 6.5) }) +test_that("rowColCalcDS throws error when object does not exist", { + expect_error( + rowColCalcDS("nonexistent_object", 1), + regexp = "does not exist" + ) +}) + +test_that("rowColCalcDS throws error when object is not data.frame or matrix", { + bad_input <- list(a = 1:3, b = 4:6) + expect_error( + rowColCalcDS("bad_input", 1), + regexp = "must be of type data.frame or matrix" + ) +}) + +test_that("rowColCalcDS throws error when a column is not numeric", { + input <- data.frame(v1 = c(1.0, 2.0, 3.0, 4.0), v2 = c("a", "b", "c", "d")) + + expect_error(rowColCalcDS("input", 1), regexp = "are not of numeric type") +}) + # # Done # diff --git a/tests/testthat/test-smk-tableDS.R b/tests/testthat/test-smk-tableDS.R new file mode 100644 index 00000000..bcb77d76 --- /dev/null +++ b/tests/testthat/test-smk-tableDS.R @@ -0,0 +1,88 @@ +# +# Set up +# + +# context("tableDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("tableDS::smk::1D") +test_that("simple tableDS, 1D", { + input <- factor(rep(c("a", "b"), each = 5)) + + res <- tableDS("input", NULL, NULL, "a,b", NULL, NULL, NULL, "no", NULL) + + expect_equal(class(res), "table") + expect_equal(as.vector(res), c(5, 5)) + expect_equal(names(res), c("a", "b")) +}) + +# context("tableDS::smk::2D") +test_that("simple tableDS, 2D", { + rvar <- factor(rep(c("a", "b"), each = 10)) + cvar <- factor(rep(rep(c("x", "y"), each = 5), 2)) + + res <- tableDS("rvar", "cvar", NULL, "a,b", "x,y", NULL, NULL, "no", NULL) + + expect_equal(class(res), "table") + expect_equal(dim(res), c(2L, 2L)) + expect_equal(as.vector(res), c(5, 5, 5, 5)) +}) + +test_that("tableDS throws error when object does not exist", { + expect_error( + tableDS("nonexistent_object", NULL, NULL, "a,b", NULL, NULL, NULL, "no", NULL), + regexp = "does not exist" + ) +}) + +test_that("tableDS accepts a forced nfilter given as a number", { + input <- factor(rep(c("a", "b"), each = 5)) + + res <- tableDS("input", NULL, NULL, "a,b", NULL, NULL, NULL, "no", "3") + + expect_equal(class(res), "table") + expect_equal(as.vector(res), c(5, 5)) +}) + +test_that("tableDS throws error when forced nfilter is below nfilter.tab", { + input <- factor(rep(c("a", "b"), each = 5)) + + expect_error( + tableDS("input", NULL, NULL, "a,b", NULL, NULL, NULL, "no", "1"), + regexp = "force.nfilter is non-null it must be >= to nfilter.tab" + ) +}) + +test_that("tableDS excludes levels given as literal values", { + input <- factor(rep(c("a", "b", "c"), each = 5)) + + res <- tableDS("input", NULL, NULL, "a,b,c", NULL, NULL, "a", "no", NULL) + + expect_equal(names(res), c("b", "c")) + expect_equal(as.vector(res), c(5, 5)) +}) + +test_that("tableDS treats NA in a list of excluded values as missing", { + input <- factor(c(rep(c("a", "b"), each = 5), rep(NA, 5))) + + expect_warning( + res <- tableDS("input", NULL, NULL, "a,b", NULL, NULL, "a,NA", "always", NULL), + regexp = "'exclude' containing NA" + ) + + expect_equal(names(res), "b") + expect_equal(as.vector(res), 5) +}) + +# +# Done +# + +# context("tableDS::smk::shutdown") + +# context("tableDS::smk::done") diff --git a/tests/testthat/test-smk-tableDS.assign.R b/tests/testthat/test-smk-tableDS.assign.R new file mode 100644 index 00000000..c20b5e01 --- /dev/null +++ b/tests/testthat/test-smk-tableDS.assign.R @@ -0,0 +1,39 @@ +# +# Set up +# + +# context("tableDS.assign::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("tableDS.assign::smk") +test_that("simple tableDS.assign", { + rvar <- factor(rep(c("a", "b"), each = 10)) + cvar <- factor(rep(rep(c("x", "y"), each = 5), 2)) + + res <- tableDS.assign("rvar", "cvar", NULL, "a,b", "x,y", NULL, NULL, "no") + + expect_equal(class(res), "list") + expect_equal(names(res), c("table", "counts", "dim", "dimnames")) + expect_equal(res$dim, c(2L, 2L)) + expect_equal(res$counts, c(5, 5, 5, 5)) +}) + +test_that("tableDS.assign throws error when object does not exist", { + expect_error( + tableDS.assign("nonexistent_object", NULL, NULL, "a,b", NULL, NULL, NULL, "no"), + regexp = "does not exist" + ) +}) + +# +# Done +# + +# context("tableDS.assign::smk::shutdown") + +# context("tableDS.assign::smk::done") diff --git a/tests/testthat/test-smk-tableDS2.R b/tests/testthat/test-smk-tableDS2.R new file mode 100644 index 00000000..c787816c --- /dev/null +++ b/tests/testthat/test-smk-tableDS2.R @@ -0,0 +1,43 @@ +# +# Set up +# + +# context("tableDS2::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +# context("tableDS2::smk") +test_that("simple tableDS2", { + rvar <- factor(rep(c("a", "b"), each = 10)) + cvar <- factor(rep(rep(c("x", "y"), each = 5), 2)) + res.assign <- tableDS.assign("rvar", "cvar", NULL, "a,b", "x,y", NULL, NULL, "no") + + res <- tableDS2("res.assign", "rvar", "cvar", NULL) + + expect_equal(class(res), "list") + expect_equal( + names(res), + c("table.cell.IDs", "table.dim", "table.dimnames", "table.structure_and_cell.order") + ) + expect_equal(res$table.dim, c(2L, 2L)) + expect_equal(res$table.cell.IDs, 1:4) +}) + +test_that("tableDS2 throws error when object does not exist", { + expect_error( + tableDS2("nonexistent_object", "rvar", "cvar", NULL), + regexp = "does not exist" + ) +}) + +# +# Done +# + +# context("tableDS2::smk::shutdown") + +# context("tableDS2::smk::done") diff --git a/tests/testthat/test-smk-tapplyDS.R b/tests/testthat/test-smk-tapplyDS.R index 7925b49a..32f2ae14 100644 --- a/tests/testthat/test-smk-tapplyDS.R +++ b/tests/testthat/test-smk-tapplyDS.R @@ -158,6 +158,18 @@ test_that("simple tapplyDS, quantile", { expect_equal(res[[2]][[15]], 2.0) }) +test_that("tapplyDS throws error when X does not exist", { + index <- as.factor(c(1, 2, 1, 2, 1, 2, 1, 2)) + + expect_error(tapplyDS("nonexistent_object", "index", "mean"), regexp = "does not exist") +}) + +test_that("tapplyDS throws error when INDEX does not exist", { + x <- c(1, 2, 1, 2, 1, 2, 1, 2) + + expect_error(tapplyDS("x", "nonexistent_object", "mean"), regexp = "does not exist") +}) + # # Done # diff --git a/tests/testthat/test-smk-tapplyDS.assign.R b/tests/testthat/test-smk-tapplyDS.assign.R index 7d899a2e..abb155a7 100644 --- a/tests/testthat/test-smk-tapplyDS.assign.R +++ b/tests/testthat/test-smk-tapplyDS.assign.R @@ -51,6 +51,18 @@ test_that("simple tapplyDS.assign", { expect_equal(res$N[[2]], 4) }) +test_that("tapplyDS.assign throws error when X does not exist", { + index <- factor(c(1, 2, 1, 2, 1, 2, 1, 2)) + + expect_error(tapplyDS.assign("nonexistent_object", "index", "mean"), regexp = "does not exist") +}) + +test_that("tapplyDS.assign throws error when INDEX does not exist", { + x <- c(1, 2, 1, 2, 1, 2, 1, 2) + + expect_error(tapplyDS.assign("x", "nonexistent_object", "mean"), regexp = "does not exist") +}) + # # Done #