diff --git a/R/BooleDS.R b/R/BooleDS.R index 0f54dfca..7081e32a 100644 --- a/R/BooleDS.R +++ b/R/BooleDS.R @@ -21,6 +21,7 @@ #' input vector are all converted to 1 or 0 respectively. #' #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' #' @return the levels of the input variable. #' @export @@ -50,8 +51,15 @@ thr <- dsBase::listDisclosureSettingsDS() # ##########CHECK NOT LONG SPECIFIED VECTOR############## -V1<-eval(parse(text=V1.name), envir = parent.frame()) -V2<-eval(parse(text=V2.name), envir = parent.frame()) +V1<-.loadServersideObject(V1.name) + +# V2 may be either a server-side object name or a literal scalar (e.g. "3", "-1") +V2.numeric <- suppressWarnings(as.numeric(V2.name)) +if(!is.na(V2.numeric)){ + V2 <- V2.numeric +}else{ + V2 <- .loadServersideObject(V2.name) +} if(is.character(V1)){ diff --git a/R/cDS.R b/R/cDS.R index 0b5b96ba..c326cf85 100644 --- a/R/cDS.R +++ b/R/cDS.R @@ -3,28 +3,30 @@ #' @description This function is similar to the R base function 'c'. #' @details Unlike the R base function 'c' on vector or list of certain #' length are allowed as output -#' @param objs a list which contains the the objects to concatenate. +#' @param x.names a character vector of object names to concatenate. #' @return a vector or list #' @author Gaye, A. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export -#' -cDS <- function (objs) { - +#' +cDS <- function (x.names) { + # Check Permissive Privacy Control Level. dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'avocado')) - - # this filter sets the minimum number of observations that are allowed + + # this filter sets the minimum number of observations that are allowed ############################################################# # MODULE 1: CAPTURE THE nfilter SETTINGS thr <- dsBase::listDisclosureSettingsDS() nfilter.tab <- as.numeric(thr$nfilter.tab) - #nfilter.glm <- as.numeric(thr$nfilter.glm) - #nfilter.subset <- as.numeric(thr$nfilter.subset) - #nfilter.string <- as.numeric(thr$nfilter.string) ############################################################# - - x <- unlist(objs) + + objs <- list() + for (i in seq_along(x.names)) { + objs[[i]] <- .loadServersideObject(x.names[i]) + } + x <- unlist(objs) # check if the output is valid and output accordingly if(length(x) < nfilter.tab){ diff --git a/R/cbindDS.R b/R/cbindDS.R index b7864864..c8717a2c 100644 --- a/R/cbindDS.R +++ b/R/cbindDS.R @@ -19,6 +19,7 @@ #' of \code{ds.cbind} (or default name \code{cbind.newobj}) #' which is written to the serverside. The output object is of class data.frame. #' @author Paul Burton and Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' cbindDS <- function(x.names.transmit=NULL, colnames.transmit=NULL){ @@ -28,11 +29,13 @@ cbindDS <- function(x.names.transmit=NULL, colnames.transmit=NULL){ x.names.input <- x.names.transmit x.names.act1 <- unlist(strsplit(x.names.input, split=",")) - x.names.act2 <- paste(x.names.act1, collapse=",") - - eval.code.x.names <- paste0("data.frame(", x.names.act2, ")") - - output.cbind <- eval(parse(text=eval.code.x.names), envir = parent.frame()) + + loaded.objects <- vector("list", length(x.names.act1)) + for(i in seq_along(x.names.act1)) { + loaded.objects[[i]] <- .loadServersideObject(x.names.act1[i]) + } + + output.cbind <- do.call(data.frame, loaded.objects) colnames.input <- colnames.transmit colnames.act1 <- unlist(strsplit(colnames.input, split=",")) diff --git a/R/dataFrameDS.R b/R/dataFrameDS.R index 7a2b36be..611bb1a8 100644 --- a/R/dataFrameDS.R +++ b/R/dataFrameDS.R @@ -35,6 +35,7 @@ #' serverside and named according to the argument of the clientside #' function ds.dataFrame() #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' dataFrameDS <- function(vectors=NULL, r.names=NULL, ch.rows=FALSE, ch.names=TRUE, clnames=NULL, strAsFactors=TRUE, completeCases=FALSE){ @@ -58,8 +59,12 @@ dataFrameDS <- function(vectors=NULL, r.names=NULL, ch.rows=FALSE, ch.names=TRUE r.names <- unlist(r.names) } - eval.code.vectors.names <- paste0("data.frame(", vectors, ")") - dtemp0 <- eval(parse(text=eval.code.vectors.names), envir = parent.frame()) + vectors.names <- unlist(strsplit(vectors, split=",")) + loaded.vectors <- vector("list", length(vectors.names)) + for(i in seq_along(vectors.names)) { + loaded.vectors[[i]] <- .loadServersideObject(vectors.names[i]) + } + dtemp0 <- do.call(data.frame, loaded.vectors) dtemp <- data.frame(dtemp0, row.names=r.names, check.rows=ch.rows, check.names=ch.names, stringsAsFactors=strAsFactors) diff --git a/R/dataFrameFillDS.R b/R/dataFrameFillDS.R index 75f093f5..7de8d805 100644 --- a/R/dataFrameFillDS.R +++ b/R/dataFrameFillDS.R @@ -17,11 +17,12 @@ #' The classes supported are 'numeric', 'integer', 'character', 'factor' and 'logical'. #' @return Nothing is returned to the client. The generated object is written to the serverside. #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' dataFrameFillDS <- function(df.name, allNames.transmit, class.vect.transmit, levels.vec.transmit){ - data <- eval(parse(text=df.name), envir = parent.frame()) + data <- .loadServersideObject(df.name) if(!is.null(allNames.transmit)){ allNames <- unlist(strsplit(allNames.transmit, split=",")) diff --git a/R/dataFrameSortDS.R b/R/dataFrameSortDS.R index a398a70b..9801d804 100644 --- a/R/dataFrameSortDS.R +++ b/R/dataFrameSortDS.R @@ -30,6 +30,7 @@ #' R environment as a data.frame named according to the argument(or with #' default name 'dataframesort.newobj') if no name is specified #' @author Paul Burton, with critical error identification by +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' Leire Abarrategui-Martinez, for DataSHIELD Development Team, 2/4/2020 #' @export #' @@ -65,9 +66,8 @@ dataFrameSortDS <- function(df.name=NULL,sort.key.name=NULL,sort.descending,sort stop(studysideMessage, call. = FALSE) } - df.name.2 <- paste0("data.frame(",df.name,")") - df2sort <- eval(parse(text=df.name.2), envir = parent.frame()) - sort.key <- eval(parse(text=sort.key.name), envir = parent.frame()) + df2sort <- data.frame(.loadServersideObject(df.name)) + sort.key <- .loadServersideObject(sort.key.name) # TYPE CHECK if(any(class(sort.key) %in% 'factor')){ diff --git a/R/dataFrameSubsetDS1.R b/R/dataFrameSubsetDS1.R index 4b3c9476..5f5e0c52 100644 --- a/R/dataFrameSubsetDS1.R +++ b/R/dataFrameSubsetDS1.R @@ -45,6 +45,7 @@ #' In consequence, it records error messages as studysideMessages which can only be #' retrieved using ds.message #' @author Paul Burton +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' dataFrameSubsetDS1 <- function(df.name=NULL,V1.name=NULL,V2.name=NULL,Boolean.operator.n=NULL,keep.cols=NULL,rm.cols=NULL,keep.NAs=NULL){ @@ -157,8 +158,7 @@ if(sum(is.na(keep.code.n))>0){ } } - df.name.2 <- paste0("data.frame(",df.name,")") - df2subset <- eval(parse(text=df.name.2), envir = parent.frame()) + df2subset <- data.frame(.loadServersideObject(df.name)) if(V1.name=="ONES"||V2.name=="ONES") { @@ -175,8 +175,16 @@ if(sum(is.na(keep.code.n))>0){ ONES<-V1 } } else { - V1 <- eval(parse(text=V1.name), envir = parent.frame()) - V2 <- eval(parse(text=V2.name), envir = parent.frame()) + V1 <- tryCatch(.loadServersideObject(V1.name), error = function(e) { + numeric.val <- suppressWarnings(as.numeric(V1.name)) + if (is.na(numeric.val)) stop(e) + numeric.val + }) + V2 <- tryCatch(.loadServersideObject(V2.name), error = function(e) { + numeric.val <- suppressWarnings(as.numeric(V2.name)) + if (is.na(numeric.val)) stop(e) + numeric.val + }) } ##########CHECK APPROPRIATE CLASSES ############## diff --git a/R/dataFrameSubsetDS2.R b/R/dataFrameSubsetDS2.R index 05938a60..ff1f2bee 100644 --- a/R/dataFrameSubsetDS2.R +++ b/R/dataFrameSubsetDS2.R @@ -54,6 +54,7 @@ #' without problems no studysideMessage will have been saved and ds.message("newobj") #' will return the message: "ALL OK: there are no studysideMessage(s) on this datasource". #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' dataFrameSubsetDS2<-function(df.name=NULL,V1.name=NULL, V2.name=NULL, Boolean.operator.n=NULL,keep.cols=NULL, rm.cols=NULL, keep.NAs=NULL){ @@ -177,8 +178,7 @@ if(!is.null(V2.name)){ } - df.name.2<-paste0("data.frame(",df.name,")") - df2subset <- eval(parse(text=df.name.2), envir = parent.frame()) + df2subset <- data.frame(.loadServersideObject(df.name)) if(V1.name=="ONES"||V2.name=="ONES") { @@ -195,8 +195,16 @@ if(!is.null(V2.name)){ ONES<-V1 } }else{ - V1<-eval(parse(text=V1.name), envir = parent.frame()) - V2<-eval(parse(text=V2.name), envir = parent.frame()) + V1<-tryCatch(.loadServersideObject(V1.name), error = function(e) { + numeric.val <- suppressWarnings(as.numeric(V1.name)) + if (is.na(numeric.val)) stop(e) + numeric.val + }) + V2<-tryCatch(.loadServersideObject(V2.name), error = function(e) { + numeric.val <- suppressWarnings(as.numeric(V2.name)) + if (is.na(numeric.val)) stop(e) + numeric.val + }) } diff --git a/R/listDS.R b/R/listDS.R index 162ae8b5..a08df9b8 100644 --- a/R/listDS.R +++ b/R/listDS.R @@ -3,17 +3,20 @@ #' @description this function is similar to R function 'list' #' @details Unlike the R function 'list' it takes also a vector of characters, #' the names of the elements in the output list. -#' @param input a list of objects to coerce into a list -#' @param eltnames a character list, the names of the elements in the list. +#' @param x.names a character vector of object names to coerce into a list. +#' @param eltnames a character vector, the names of the elements in the list. #' @return a list #' @author Gaye, A. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export -#' -listDS <-function (input=NULL, eltnames=NULL){ - - mylist <- input +#' +listDS <- function (x.names = NULL, eltnames = NULL) { + + mylist <- list() + for (i in seq_along(x.names)) { + mylist[[i]] <- .loadServersideObject(x.names[i]) + } names(mylist) <- unlist(eltnames) return(mylist) - } \ No newline at end of file diff --git a/R/mergeDS.R b/R/mergeDS.R index ce05ab7b..2cc6a2c8 100644 --- a/R/mergeDS.R +++ b/R/mergeDS.R @@ -51,6 +51,7 @@ #' without problems no studysideMessage will have been saved and ds.message() #' will return the message: "ALL OK: there are no studysideMessage(s) on this datasource". #' @author Paul Burton, Demetris Avraam, for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export mergeDS <- function(x.name, y.name, by.x.names.transmit, by.y.names.transmit, all.x, all.y, sort, suffixes.transmit, no.dups, incomparables){ @@ -78,19 +79,12 @@ mergeDS <- function(x.name, y.name, by.x.names.transmit, by.y.names.transmit, al } # activate data frame names - x.data.frame <- eval(parse(text=x.name), envir = parent.frame()) - y.data.frame <- eval(parse(text=y.name), envir = parent.frame()) + x.data.frame <- .loadServersideObject(x.name) + y.data.frame <- .loadServersideObject(y.name) # check data.frames are valid data.frames - if(!is.data.frame(x.data.frame)){ - studysideMessage <- "Error: x.name must specify a data.frame" - stop(studysideMessage, call. = FALSE) - } - - if(!is.data.frame(y.data.frame)){ - studysideMessage <- "Error: y.name must specify a data.frame" - stop(studysideMessage, call. = FALSE) - } + .checkClass(obj = x.data.frame, obj_name = x.name, permitted_classes = c("data.frame")) + .checkClass(obj = y.data.frame, obj_name = y.name, permitted_classes = c("data.frame")) # manage by.x.names and by.y.names # check text to be activated is not too long because of disclosure risk diff --git a/R/rbindDS.R b/R/rbindDS.R index 71e88b17..131b863c 100644 --- a/R/rbindDS.R +++ b/R/rbindDS.R @@ -32,6 +32,7 @@ #' without problems no studysideMessage will have been saved and ds.message("") #' will return the message: "ALL OK: there are no studysideMessage(s) on this datasource". #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export rbindDS<-function(x.names.transmit=NULL,colnames.transmit=NULL){ @@ -60,7 +61,7 @@ rbindDS<-function(x.names.transmit=NULL,colnames.transmit=NULL){ rbind.matrix<-NULL for(k in numobj:1){ - object.2.rbind<-eval(parse(text=x.names.active[k]), envir = parent.frame()) + object.2.rbind<-.loadServersideObject(x.names.active[k]) #coerce all input objects to data.matrix (like as.matrix but stays as numeric if numeric) object.2.rbind<-data.matrix(object.2.rbind) diff --git a/R/recodeValuesDS.R b/R/recodeValuesDS.R index d22a7862..20017d38 100644 --- a/R/recodeValuesDS.R +++ b/R/recodeValuesDS.R @@ -26,6 +26,7 @@ #' initially specified in calling ds.recodeValues. The output object (the required #' recoded variable called is written to the serverside. #' @author Paul Burton, Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' recodeValuesDS <- function(var.name.text=NULL, values2replace.text=NULL, new.values.text=NULL, missing=NULL){ @@ -59,7 +60,7 @@ recodeValuesDS <- function(var.name.text=NULL, values2replace.text=NULL, new.val stop(studysideMessage, call. = FALSE) } - var2recode <- eval(parse(text=var.name.text), envir = parent.frame()) + var2recode <- .loadServersideObject(var.name.text) values2replace <- unlist(strsplit(values2replace.text, split=",")) new.values <- unlist(strsplit(new.values.text, split=",")) @@ -68,13 +69,10 @@ recodeValuesDS <- function(var.name.text=NULL, values2replace.text=NULL, new.val # get the class of the input variable var.class <- class(var2recode) - - # if the class of the input variable is not factor, numeric, character or integer then + + # if the class of the input variable is not factor, numeric, character or integer then # stop and return an error message - if (!(var.class %in% c('factor', 'character', 'numeric', 'integer'))){ - studysideMessage <- "Error: The variable to recode must be either a factor, a character, a numeric or an integer" - stop(studysideMessage, call. = FALSE) - } + .checkClass(obj = var2recode, obj_name = var.name.text, permitted_classes = c('factor', 'character', 'numeric', 'integer')) # recode using the recode function from the dplyr package if (var.class == 'factor'){ diff --git a/R/repDS.R b/R/repDS.R index 61b4e3ea..994d4d22 100644 --- a/R/repDS.R +++ b/R/repDS.R @@ -88,6 +88,7 @@ #' without problems no studysideMessage will have been saved and ds.message("newobj") #' will return the message: "ALL OK: there are no studysideMessage(s) on this datasource". #' @author Paul Burton for DataSHIELD Development Team, 14/10/2019 +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' repDS <- function(x1.transmit, times.transmit, length.out.transmit, each.transmit, @@ -175,7 +176,7 @@ if(source.x1=="serverside") { #x1.transmit is the name of a serverside vector or scalar -x1.use<-eval(parse(text=x1.transmit), envir = parent.frame()) +x1.use<-.loadServersideObject(x1.transmit) } if(source.x1=="clientside") @@ -276,7 +277,7 @@ else { #times.transmit is the name of a serverside vector or scalar - times.use<-eval(parse(text=times.transmit), envir = parent.frame()) + times.use<-.loadServersideObject(times.transmit) } if(source.times=="clientside") @@ -364,7 +365,7 @@ else if(source.length.out=="serverside") { #length.out.transmit is the name of the serverside vector or scalar - length.out.temp<-eval(parse(text=length.out.transmit), envir = parent.frame()) + length.out.temp<-.loadServersideObject(length.out.transmit) arg.is.vector<-FALSE if(length(length.out.temp)>=2)arg.is.vector<-TRUE @@ -460,7 +461,7 @@ else if(source.each=="serverside") { #each.transmit is the name of the serverside vector or scalar - each.use<-eval(parse(text=each.transmit), envir = parent.frame()) + each.use<-.loadServersideObject(each.transmit) } if(source.each=="clientside") diff --git a/R/replaceNaDS.R b/R/replaceNaDS.R index 007e12ce..62b91f99 100644 --- a/R/replaceNaDS.R +++ b/R/replaceNaDS.R @@ -8,15 +8,18 @@ #' it might be more sensible to replace all missing values by one specific value e.g. #' replace all missing values in a vector by the mean or median value. Once the missing #' values have been replaced a new vector is created. -#' @param xvect a character, the name of the vector to process. +#' @param x a character, the name of the vector to process. #' @param replacements a vector which contains the replacement value(s), a vector one or #' more values for each study. #' @return a new vector without missing values #' @author Amadou Gaye, Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' -replaceNaDS <- function(xvect, replacements){ - +replaceNaDS <- function(x, replacements){ + + xvect <- .loadServersideObject(x) + # check if the input vector is valid (i.e. meets DataSHIELD criteria) check <- dsBase::isValidDS(xvect) diff --git a/R/seqDS.R b/R/seqDS.R index 97df7c3e..56113e4a 100644 --- a/R/seqDS.R +++ b/R/seqDS.R @@ -45,6 +45,7 @@ #' without problems no studysideMessage will have been saved and ds.message("") #' will return the message: "ALL OK: there are no studysideMessage(s) on this datasource". #' @author Paul Burton for DataSHIELD Development Team, 17/9/2019 +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export seqDS <- function(FROM.value.char,TO.value.char,BY.value.char,LENGTH.OUT.value.char,ALONG.WITH.name) { @@ -65,8 +66,9 @@ nfilter.subset<-as.numeric(thr$nfilter.subset) # ######################################################################### - if(is.character(FROM.value.char)&&is.numeric(eval(parse(text=FROM.value.char), envir = parent.frame()))){ - FROM<-eval(parse(text=FROM.value.char), envir = parent.frame()) + FROM.eval <- tryCatch(.loadServersideObject(FROM.value.char), error = function(e) as.numeric(FROM.value.char)) + if(is.character(FROM.value.char)&&is.numeric(FROM.eval)){ + FROM<-FROM.eval }else{ studysideMessage<-"ERROR: FROM.value.char must be specified as a real number in inverted commas eg '-3.74' or '0'" stop(studysideMessage, call. = FALSE) @@ -74,9 +76,10 @@ nfilter.subset<-as.numeric(thr$nfilter.subset) # if(!is.null(TO.value.char)) { - if(is.character(TO.value.char)&&is.numeric(eval(parse(text=TO.value.char), envir = parent.frame()))) + TO.eval <- tryCatch(.loadServersideObject(TO.value.char), error = function(e) as.numeric(TO.value.char)) + if(is.character(TO.value.char)&&is.numeric(TO.eval)) { - TO<-eval(parse(text=TO.value.char), envir = parent.frame()) + TO<-TO.eval }else{ studysideMessage<-"ERROR: TO.value.char must be specified as a real number in inverted commas eg '-3.74' or '0'" stop(studysideMessage, call. = FALSE) @@ -88,16 +91,18 @@ nfilter.subset<-as.numeric(thr$nfilter.subset) # TO<-NULL } - if(is.character(BY.value.char)&&is.numeric(eval(parse(text=BY.value.char), envir = parent.frame()))){ - BY<-eval(parse(text=BY.value.char), envir = parent.frame()) + BY.eval <- tryCatch(.loadServersideObject(BY.value.char), error = function(e) as.numeric(BY.value.char)) + if(is.character(BY.value.char)&&is.numeric(BY.eval)){ + BY<-BY.eval }else{ studysideMessage<-"ERROR: BY.value.char must be specified as a real number in inverted commas eg '-3.74' or '0'" stop(studysideMessage, call. = FALSE) } if(!is.null(LENGTH.OUT.value.char)){ - if(is.character(LENGTH.OUT.value.char)&&is.numeric(eval(parse(text=LENGTH.OUT.value.char), envir = parent.frame()))){ - LENGTH.OUT<-eval(parse(text=LENGTH.OUT.value.char), envir = parent.frame()) + LENGTH.OUT.eval <- tryCatch(.loadServersideObject(LENGTH.OUT.value.char), error = function(e) as.numeric(LENGTH.OUT.value.char)) + if(is.character(LENGTH.OUT.value.char)&&is.numeric(LENGTH.OUT.eval)){ + LENGTH.OUT<-LENGTH.OUT.eval }else{ studysideMessage<-"ERROR: If LENGTH.OUT.value.char is non-NULL, it must specify a positive integer in inverted commas eg '14'" stop(studysideMessage, call. = FALSE) @@ -110,7 +115,7 @@ nfilter.subset<-as.numeric(thr$nfilter.subset) # if(!is.null(ALONG.WITH.name)){ if(is.character(ALONG.WITH.name)){ - ALONG.WITH<-eval(parse(text=ALONG.WITH.name), envir = parent.frame()) + ALONG.WITH<-.loadServersideObject(ALONG.WITH.name) }else{ studysideMessage<-"ERROR: If ALONG.WITH.name is non-NULL, it must specify the name of a serverside vector in inverted commas" stop(studysideMessage, call. = FALSE) diff --git a/R/unListDS.R b/R/unListDS.R index 79e853a8..be0130b1 100644 --- a/R/unListDS.R +++ b/R/unListDS.R @@ -31,17 +31,13 @@ #' function - one should check as far as one can #' the nature of the output from a call to ds.unList - e.g. ds.class, ds.length etc #' @author Amadou Gaye (2016), Paul Burton (19/09/2019) for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' unListDS <- function(x.name) { - if (is.character(x.name)) { - listvar<-eval(parse(text=x.name), envir = parent.frame()) - } else { - studysideMessage<-"ERROR: x.name must be specified as a character string" - stop(studysideMessage, call. = FALSE) - } - + listvar <- .loadServersideObject(x.name) + outvar<-unlist(listvar) return(outvar) diff --git a/man/cDS.Rd b/man/cDS.Rd index 7b4e448a..e3da7bf2 100644 --- a/man/cDS.Rd +++ b/man/cDS.Rd @@ -4,10 +4,10 @@ \alias{cDS} \title{Concatenates objects into a vector or list} \usage{ -cDS(objs) +cDS(x.names) } \arguments{ -\item{objs}{a list which contains the the objects to concatenate.} +\item{x.names}{a character vector of object names to concatenate.} } \value{ a vector or list @@ -21,4 +21,6 @@ length are allowed as output } \author{ Gaye, A. + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/listDS.Rd b/man/listDS.Rd index 36b1c236..4f0401a1 100644 --- a/man/listDS.Rd +++ b/man/listDS.Rd @@ -4,12 +4,12 @@ \alias{listDS} \title{Coerce objects into a list} \usage{ -listDS(input = NULL, eltnames = NULL) +listDS(x.names = NULL, eltnames = NULL) } \arguments{ -\item{input}{a list of objects to coerce into a list} +\item{x.names}{a character vector of object names to coerce into a list.} -\item{eltnames}{a character list, the names of the elements in the list.} +\item{eltnames}{a character vector, the names of the elements in the list.} } \value{ a list @@ -23,4 +23,6 @@ the names of the elements in the output list. } \author{ Gaye, A. + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/replaceNaDS.Rd b/man/replaceNaDS.Rd index e44285bc..f6e26ed2 100644 --- a/man/replaceNaDS.Rd +++ b/man/replaceNaDS.Rd @@ -4,10 +4,10 @@ \alias{replaceNaDS} \title{Replaces the missing values in a vector} \usage{ -replaceNaDS(xvect, replacements) +replaceNaDS(x, replacements) } \arguments{ -\item{xvect}{a character, the name of the vector to process.} +\item{x}{a character, the name of the vector to process.} \item{replacements}{a vector which contains the replacement value(s), a vector one or more values for each study.} diff --git a/tests/testthat/test-smk-BooleDS.R b/tests/testthat/test-smk-BooleDS.R index 5fcfa4ee..685dc0fa 100644 --- a/tests/testthat/test-smk-BooleDS.R +++ b/tests/testthat/test-smk-BooleDS.R @@ -15,6 +15,8 @@ # context("BooleDS::smk::setup") +set.standard.disclosure.settings() + # # Tests # @@ -279,6 +281,24 @@ test_that("na-check BooleDS, logical, NA=1", { expect_equal(res[5], TRUE) }) +test_that("BooleDS errors when V1 object does not exist", { + input <- data.frame(v2 = c(1.0, 2.0, 3.0, 4.0, 5.0)) + + expect_error( + BooleDS("nonexistent$v1", "input$v2", 1, "NA", TRUE), + regexp = "does not exist" + ) +}) + +test_that("BooleDS errors when V2 object does not exist", { + input <- data.frame(v1 = c(1.0, 2.0, 3.0, 4.0, 5.0)) + + expect_error( + BooleDS("input$v1", "nonexistent$v2", 1, "NA", TRUE), + regexp = "does not exist" + ) +}) + # # Done # diff --git a/tests/testthat/test-smk-cDS.R b/tests/testthat/test-smk-cDS.R index 0f9842fc..518d9ac5 100644 --- a/tests/testthat/test-smk-cDS.R +++ b/tests/testthat/test-smk-cDS.R @@ -23,9 +23,9 @@ set.standard.disclosure.settings() # context("cDS::smk::numeric list") test_that("numeric list cDS", { - input <- list(a=0.0, b=1.0, c=2.0, d=3.0) + a <- 0.0; b <- 1.0; c <- 2.0; d <- 3.0 - res <- cDS(input) + res <- cDS(c("a", "b", "c", "d")) expect_length(res, 4) expect_equal(class(res), "numeric") @@ -37,9 +37,9 @@ test_that("numeric list cDS", { # context("cDS::smk::character list") test_that("character list cDS", { - input <- list(a="0.0", b="1.0", c="2.0", d="3.0") + a <- "0.0"; b <- "1.0"; c <- "2.0"; d <- "3.0" - res <- cDS(input) + res <- cDS(c("a", "b", "c", "d")) expect_length(res, 4) expect_equal(class(res), "character") @@ -51,9 +51,9 @@ test_that("character list cDS", { # context("cDS::smk::numeric list small") test_that("single numeric list small cDS", { - input <- list(a=0, b=1) + a <- 0; b <- 1 - res <- cDS(input) + res <- cDS(c("a", "b")) expect_length(res, 2) expect_equal(class(res), "logical") @@ -63,9 +63,7 @@ test_that("single numeric list small cDS", { # context("cDS::smk::empty list") test_that("empty list cDS", { - input <- list() - - res <- cDS(input) + res <- cDS(character(0)) expect_length(res, 0) expect_equal(class(res), "NULL") diff --git a/tests/testthat/test-smk-cbindDS.R b/tests/testthat/test-smk-cbindDS.R index 11fe1ef3..6a932cb3 100644 --- a/tests/testthat/test-smk-cbindDS.R +++ b/tests/testthat/test-smk-cbindDS.R @@ -15,36 +15,57 @@ # context("cbindDS::smk::setup") +set.standard.disclosure.settings() + # # Tests # -# context("cbindDS::smk::simple") -test_that("simple cbindDS", { - inputs <- 'input1,input2' - input1 <- c(0.0, 1.0, 2.0, 3.0) - input2 <- c(3.0, 2.0, 1.0, 0.0) - colnames <- 'v1,v2' +test_that("cbindDS combines vectors into a data.frame", { + a <- c(1, 2, 3, 4, 5) + b <- c(10, 20, 30, 40, 50) - res <- cbindDS(inputs, colnames) + res <- cbindDS("a,b", "a,b") expect_equal(class(res), "data.frame") - expect_length(res, 2) - expect_equal(class(res[1]), "data.frame") - expect_equal(class(res[2]), "data.frame") + expect_equal(nrow(res), 5) + expect_equal(ncol(res), 2) + expect_equal(colnames(res), c("a", "b")) + expect_equal(res$a, a) + expect_equal(res$b, b) +}) + +test_that("cbindDS combines data.frame columns via $ syntax", { + df <- data.frame(x = c(1, 2, 3, 4, 5), y = c(6, 7, 8, 9, 10)) - res.names <- names(res) + res <- cbindDS("df$x,df$y", "df$x,df$y") - expect_equal(class(res.names), "character") - expect_length(res.names, 2) - expect_equal(res.names[1], 'v1') - expect_equal(res.names[2], 'v2') + expect_equal(class(res), "data.frame") + expect_equal(nrow(res), 5) + expect_equal(ncol(res), 2) + expect_equal(colnames(res), c("x", "y")) + expect_equal(res$x, df$x) + expect_equal(res$y, df$y) +}) + +test_that("cbindDS makes duplicate column names unique", { + a <- c(1, 2, 3, 4, 5) + b <- c(10, 20, 30, 40, 50) + + res <- cbindDS("a,b", "v,v") + + expect_equal(colnames(res), c("v", "v.1")) +}) + +test_that("cbindDS errors when object does not exist", { + expect_error( + cbindDS("nonexistent_obj", "nonexistent_obj"), + regexp = "does not exist" + ) }) # # Done # -# context("cbindDS::smk::shutdown") - # context("cbindDS::smk::done") diff --git a/tests/testthat/test-smk-dataFrameDS.R b/tests/testthat/test-smk-dataFrameDS.R index 18fc3b4b..441e5ef9 100644 --- a/tests/testthat/test-smk-dataFrameDS.R +++ b/tests/testthat/test-smk-dataFrameDS.R @@ -21,68 +21,51 @@ set.standard.disclosure.settings() # Tests # -# context("dataFrameDS::smk") -test_that("simple dataFrameDS", { - v1 <- c(0.0, 1.0, 2.0, 3.0, 4.0) - v2 <- c(4.0, 3.0, 2.0, 1.0, 0.0) - vectors <- "v1,v2" - r.names <- NULL - ch.rows <- FALSE - ch.names <- FALSE - clnames <- "x1,x2" - strAsFactors <- FALSE - completeCases <- FALSE - - res <- dataFrameDS(vectors, r.names, ch.rows, ch.names, clnames, strAsFactors, completeCases) +test_that("dataFrameDS creates a data.frame from vectors", { + a <- c(1, 2, 3, 4, 5) + b <- c(10, 20, 30, 40, 50) + + res <- dataFrameDS("a,b", r.names=NULL, ch.rows=FALSE, ch.names=TRUE, + clnames="a,b", strAsFactors=TRUE, completeCases=FALSE) expect_equal(class(res), "data.frame") - expect_length(res, 2) - - res.classes <- colnames(res) - expect_length(res.classes, 2) - expect_equal(res.classes[1], "x1") - expect_equal(res.classes[2], "x2") - - for (index in 1:length(res)) - { - expect_equal(v1[index], res$x1[index], info = paste0('index=', index, ', column=x1')) - expect_equal(v2[index], res$x2[index], info = paste0('index=', index, ', column=x2')) - } + expect_equal(nrow(res), 5) + expect_equal(ncol(res), 2) + expect_equal(colnames(res), c("a", "b")) + expect_equal(res$a, a) + expect_equal(res$b, b) }) -test_that("simple dataFrameDS, strAsFactors is TRUE", { - v1 <- c(0.0, 1.0, 2.0, 3.0, 4.0) - v2 <- c(4.0, 3.0, 2.0, 1.0, 0.0) - vectors <- "v1,v2" - r.names <- NULL - ch.rows <- FALSE - ch.names <- FALSE - clnames <- "x1,x2" - strAsFactors <- TRUE - completeCases <- FALSE +test_that("dataFrameDS handles $ column name syntax", { + df <- data.frame(x = c(1, 2, 3, 4, 5), y = c(6, 7, 8, 9, 10)) - res <- dataFrameDS(vectors, r.names, ch.rows, ch.names, clnames, strAsFactors, completeCases) + res <- dataFrameDS("df$x,df$y", r.names=NULL, ch.rows=FALSE, ch.names=TRUE, + clnames="df$x,df$y", strAsFactors=TRUE, completeCases=FALSE) expect_equal(class(res), "data.frame") - expect_length(res, 2) - - res.classes <- colnames(res) - expect_length(res.classes, 2) - expect_equal(res.classes[1], "x1") - expect_equal(res.classes[2], "x2") - - for (index in 1:length(res)) - { - expect_equal(v1[index], res$x1[index], info = paste0('index=', index, ', column=x1')) - expect_equal(v2[index], res$x2[index], info = paste0('index=', index, ', column=x2')) - } + expect_equal(colnames(res), c("x", "y")) + expect_equal(res$x, df$x) + expect_equal(res$y, df$y) }) -# -# Stutdown -# +test_that("dataFrameDS removes rows with NAs when completeCases is TRUE", { + a <- c(1, NA, 3, 4, 5) + b <- c(10, 20, NA, 40, 50) + + res <- dataFrameDS("a,b", r.names=NULL, ch.rows=FALSE, ch.names=TRUE, + clnames="a,b", strAsFactors=TRUE, completeCases=TRUE) -# context("dataFrameDS::smk::shutdown") + expect_equal(class(res), "data.frame") + expect_equal(nrow(res), 3) +}) + +test_that("dataFrameDS errors when object does not exist", { + expect_error( + dataFrameDS("nonexistent_obj", r.names=NULL, ch.rows=FALSE, ch.names=TRUE, + clnames="nonexistent_obj", strAsFactors=TRUE, completeCases=FALSE), + regexp = "does not exist" + ) +}) # # Done diff --git a/tests/testthat/test-smk-dataFrameFillDS.R b/tests/testthat/test-smk-dataFrameFillDS.R index 8da7a882..326c6c85 100644 --- a/tests/testthat/test-smk-dataFrameFillDS.R +++ b/tests/testthat/test-smk-dataFrameFillDS.R @@ -90,6 +90,13 @@ test_that("simple dataFrameFillDS, ascending, numeric", { expect_equal(res.v6.levels[3], "3") }) +test_that("dataFrameFillDS errors when object does not exist", { + expect_error( + dataFrameFillDS("nonexistent_object", "a,b", "numeric,numeric", NULL), + regexp = "does not exist" + ) +}) + # # Shutdown # diff --git a/tests/testthat/test-smk-dataFrameSortDS.R b/tests/testthat/test-smk-dataFrameSortDS.R index 39a7378b..a61a4c62 100644 --- a/tests/testthat/test-smk-dataFrameSortDS.R +++ b/tests/testthat/test-smk-dataFrameSortDS.R @@ -468,6 +468,22 @@ test_that("simple dataFrameSortDS, descending, alphabetic", { expect_equal(res$v2[8], "6.0") }) +test_that("dataFrameSortDS errors when df does not exist", { + expect_error( + dataFrameSortDS("nonexistent", "nonexistent$v1", FALSE, "default"), + regexp = "does not exist" + ) +}) + +test_that("dataFrameSortDS errors when sort key does not exist", { + df <- data.frame(v1 = c(1, 2, 3, 4, 5, 6, 7, 8), v2 = c(1, 2, 3, 4, 5, 6, 7, 8)) + + expect_error( + dataFrameSortDS("df", "nonexistent$col", FALSE, "default"), + regexp = "does not exist" + ) +}) + # # Done # diff --git a/tests/testthat/test-smk-dataFrameSubsetDS1.R b/tests/testthat/test-smk-dataFrameSubsetDS1.R index c519cefa..b70c7993 100644 --- a/tests/testthat/test-smk-dataFrameSubsetDS1.R +++ b/tests/testthat/test-smk-dataFrameSubsetDS1.R @@ -74,6 +74,28 @@ test_that("test2 dataFrameSubsetDS1", { }) +test_that("dataFrameSubsetDS1 errors when df does not exist", { + expect_error( + dataFrameSubsetDS1(df.name="nonexistent", V1.name="x", V2.name="1", + Boolean.operator.n=1, keep.NAs=FALSE), + regexp = "does not exist" + ) +}) + +test_that("dataFrameSubsetDS1 errors when V1 object does not exist", { + D <- as.data.frame(matrix(NA, nrow=20, ncol=3)) + colnames(D) <- c('integer','numeric','binary') + D$integer <- rep(1, 20) + D$numeric <- rep(1, 20) + D$binary <- rep(1, 20) + + expect_error( + dataFrameSubsetDS1(df.name="D", V1.name="nonexistent$col", V2.name="1", + Boolean.operator.n=1, keep.NAs=FALSE), + regexp = "does not exist" + ) +}) + # # Done # diff --git a/tests/testthat/test-smk-dataFrameSubsetDS2.R b/tests/testthat/test-smk-dataFrameSubsetDS2.R index c93dc595..99968ee4 100644 --- a/tests/testthat/test-smk-dataFrameSubsetDS2.R +++ b/tests/testthat/test-smk-dataFrameSubsetDS2.R @@ -71,6 +71,28 @@ test_that("test2 dataFrameSubsetDS2", { }) +test_that("dataFrameSubsetDS2 errors when df does not exist", { + expect_error( + dataFrameSubsetDS2(df.name="nonexistent", V1.name="x", V2.name="1", + Boolean.operator.n=1, keep.NAs=FALSE), + regexp = "does not exist" + ) +}) + +test_that("dataFrameSubsetDS2 errors when V1 object does not exist", { + D <- as.data.frame(matrix(NA, nrow=20, ncol=3)) + colnames(D) <- c('integer','numeric','binary') + D$integer <- rep(1, 20) + D$numeric <- rep(1, 20) + D$binary <- rep(1, 20) + + expect_error( + dataFrameSubsetDS2(df.name="D", V1.name="nonexistent$col", V2.name="1", + Boolean.operator.n=1, keep.NAs=FALSE), + regexp = "does not exist" + ) +}) + # # Done # diff --git a/tests/testthat/test-smk-listDS.R b/tests/testthat/test-smk-listDS.R index dfd0a171..51e75550 100644 --- a/tests/testthat/test-smk-listDS.R +++ b/tests/testthat/test-smk-listDS.R @@ -21,10 +21,11 @@ # context("listDS::smk::simple") test_that("simple listDS", { - input <- list(v1 = c(1, 2, 3), v2 = c(4, 5, 6)) + v1 <- c(1, 2, 3) + v2 <- c(4, 5, 6) eltnames <- c('n1', 'n2') - res <- listDS(input, eltnames) + res <- listDS(c("v1", "v2"), eltnames) expect_equal(class(res), "list") expect_length(res, 2) diff --git a/tests/testthat/test-smk-mergeDS.R b/tests/testthat/test-smk-mergeDS.R new file mode 100644 index 00000000..1fbac070 --- /dev/null +++ b/tests/testthat/test-smk-mergeDS.R @@ -0,0 +1,80 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("mergeDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +test_that("mergeDS happy path, simple merge", { + x.df <- data.frame(id = c(1, 2, 3), val_x = c("a", "b", "c")) + y.df <- data.frame(id = c(1, 2, 3), val_y = c("d", "e", "f")) + + res <- mergeDS("x.df", "y.df", "id", "id", FALSE, FALSE, TRUE, ".x,.y", TRUE, NULL) + + expect_true(is.data.frame(res)) + expect_true("val_x" %in% colnames(res)) + expect_true("val_y" %in% colnames(res)) + expect_equal(nrow(res), 3) +}) + +test_that("mergeDS errors when x.name object does not exist", { + y.df <- data.frame(id = c(1, 2, 3), val_y = c("d", "e", "f")) + + expect_error( + mergeDS("nonexistent_object", "y.df", "id", "id", FALSE, FALSE, TRUE, ".x,.y", TRUE, NULL), + regexp = "does not exist" + ) +}) + +test_that("mergeDS errors when y.name object does not exist", { + x.df <- data.frame(id = c(1, 2, 3), val_x = c("a", "b", "c")) + + expect_error( + mergeDS("x.df", "nonexistent_object", "id", "id", FALSE, FALSE, TRUE, ".x,.y", TRUE, NULL), + regexp = "does not exist" + ) +}) + +test_that("mergeDS errors when x.name is not a data.frame", { + x.df <- c(1, 2, 3) + y.df <- data.frame(id = c(1, 2, 3), val_y = c("d", "e", "f")) + + expect_error( + mergeDS("x.df", "y.df", "id", "id", FALSE, FALSE, TRUE, ".x,.y", TRUE, NULL), + regexp = "must be of type" + ) +}) + +test_that("mergeDS errors when y.name is not a data.frame", { + x.df <- data.frame(id = c(1, 2, 3), val_x = c("a", "b", "c")) + y.df <- c(1, 2, 3) + + expect_error( + mergeDS("x.df", "y.df", "id", "id", FALSE, FALSE, TRUE, ".x,.y", TRUE, NULL), + regexp = "must be of type" + ) +}) + +# +# Done +# + +# context("mergeDS::smk::shutdown") + +# context("mergeDS::smk::done") diff --git a/tests/testthat/test-smk-rbindDS.R b/tests/testthat/test-smk-rbindDS.R index 7f757a1e..af99483b 100644 --- a/tests/testthat/test-smk-rbindDS.R +++ b/tests/testthat/test-smk-rbindDS.R @@ -15,53 +15,47 @@ # context("rbindDS::smk::setup") +set.standard.disclosure.settings() + # # Tests # -# context("rbindDS::smk::simple") -test_that("simple rbindDS", { - inputs <- 'input1, input2' - input1 <- c(0.0, 1.0, 2.0, 3.0) - input2 <- c(3.0, 2.0, 1.0, 0.0) - colnames <- 'v1' +test_that("rbindDS combines two data.frames by row", { + df1 <- data.frame(a = c(1, 2, 3), b = c(4, 5, 6)) + df2 <- data.frame(a = c(7, 8), b = c(9, 10)) - res <- rbindDS(inputs, colnames) + res <- rbindDS("df1,df2", "a,b") - res.class <- class(res) - if (base::getRversion() < '4.0.0') - { - expect_length(res.class, 1) - expect_true("matrix" %in% res.class) - } - else - { - expect_length(res.class, 2) - expect_true("matrix" %in% res.class) - expect_true("array" %in% res.class) - } + expect_true(is.matrix(res)) + expect_equal(nrow(res), 5) + expect_equal(ncol(res), 2) + expect_equal(colnames(res), c("a", "b")) + expect_equal(res[, "a"], c(1, 2, 3, 7, 8)) + expect_equal(res[, "b"], c(4, 5, 6, 9, 10)) +}) - expect_length(res, 8) - expect_equal(class(res[1]), "numeric") - expect_equal(class(res[2]), "numeric") - expect_equal(class(res[3]), "numeric") - expect_equal(class(res[4]), "numeric") - expect_equal(class(res[5]), "numeric") - expect_equal(class(res[6]), "numeric") - expect_equal(class(res[7]), "numeric") - expect_equal(class(res[8]), "numeric") +test_that("rbindDS combines vectors", { + v1 <- c(1, 2, 3) + v2 <- c(4, 5, 6) - res.colnames <- colnames(res) + res <- rbindDS("v1,v2", "V1") - expect_equal(class(res.colnames), "character") - expect_length(res.colnames, 1) - expect_equal(res.colnames[1], 'v1') + expect_true(is.matrix(res)) + expect_equal(nrow(res), 6) + expect_equal(ncol(res), 1) + expect_equal(colnames(res), "V1") +}) + +test_that("rbindDS errors when object does not exist", { + expect_error( + rbindDS("nonexistent_obj", "a"), + regexp = "does not exist" + ) }) # # Done # -# context("rbindDS::smk::shutdown") - # context("rbindDS::smk::done") diff --git a/tests/testthat/test-smk-recodeValuesDS.R b/tests/testthat/test-smk-recodeValuesDS.R index 09b9e2f3..dcbe39b5 100644 --- a/tests/testthat/test-smk-recodeValuesDS.R +++ b/tests/testthat/test-smk-recodeValuesDS.R @@ -123,6 +123,22 @@ test_that("simple recodeValuesDS, character input with missings", { expect_true(is.na(res[7])) }) +test_that("recodeValuesDS errors when object does not exist", { + expect_error( + recodeValuesDS("nonexistent_object", "1,2", "10,20", NULL), + regexp = "does not exist" + ) +}) + +test_that("recodeValuesDS errors when object has wrong type", { + input <- list(a = 1, b = 2) + + expect_error( + recodeValuesDS("input", "1,2", "10,20", NULL), + regexp = "must be of type" + ) +}) + # # Done # diff --git a/tests/testthat/test-smk-repDS.R b/tests/testthat/test-smk-repDS.R new file mode 100644 index 00000000..c4929f47 --- /dev/null +++ b/tests/testthat/test-smk-repDS.R @@ -0,0 +1,83 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# +# This program and the accompanying materials +# are made available under the terms of the GNU Public License v3.0. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("repDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +test_that("repDS with serverside scalar x1", { + myScalar <- 5 + + res <- repDS(x1.transmit="myScalar", times.transmit="3", length.out.transmit=NULL, + each.transmit=NULL, x1.includes.characters=FALSE, + source.x1="serverside", source.times="clientside", + source.length.out=NULL, source.each=NULL) + + expect_equal(res, c(5, 5, 5)) +}) + +test_that("repDS with serverside vector x1", { + myVec <- c(1, 2, 3) + + res <- repDS(x1.transmit="myVec", times.transmit="2", length.out.transmit=NULL, + each.transmit=NULL, x1.includes.characters=FALSE, + source.x1="serverside", source.times="clientside", + source.length.out=NULL, source.each=NULL) + + expect_equal(res, c(1, 2, 3, 1, 2, 3)) +}) + +test_that("repDS with clientside x1", { + res <- repDS(x1.transmit="7", times.transmit="4", length.out.transmit=NULL, + each.transmit=NULL, x1.includes.characters=FALSE, + source.x1="clientside", source.times="clientside", + source.length.out=NULL, source.each=NULL) + + expect_equal(res, c(7, 7, 7, 7)) +}) + +test_that("repDS errors when serverside x1 object does not exist", { + expect_error( + repDS(x1.transmit="nonexistent_obj", times.transmit="3", length.out.transmit=NULL, + each.transmit=NULL, x1.includes.characters=FALSE, + source.x1="serverside", source.times="clientside", + source.length.out=NULL, source.each=NULL), + regexp = "does not exist" + ) +}) + +test_that("repDS errors when serverside times object does not exist", { + myScalar <- 5 + + expect_error( + repDS(x1.transmit="myScalar", times.transmit="nonexistent_times", length.out.transmit=NULL, + each.transmit=NULL, x1.includes.characters=FALSE, + source.x1="serverside", source.times="serverside", + source.length.out=NULL, source.each=NULL), + regexp = "does not exist" + ) +}) + +# +# Done +# + +# context("repDS::smk::shutdown") + +# context("repDS::smk::done") diff --git a/tests/testthat/test-smk-replaceNaDS.R b/tests/testthat/test-smk-replaceNaDS.R index b2b4cfff..8d9c49d7 100644 --- a/tests/testthat/test-smk-replaceNaDS.R +++ b/tests/testthat/test-smk-replaceNaDS.R @@ -26,7 +26,7 @@ test_that("simple replaceNaDS", { input <- c(0.0, NA, 2.0, NA, 4.0, NA, 6.0, NA) replacements <- c(1.1, 3.3, 5.5, 7.7) - res <- replaceNaDS(input, replacements) + res <- replaceNaDS("input", replacements) expect_equal(class(res), "numeric") expect_length(res, 8) diff --git a/tests/testthat/test-smk-seqDS.R b/tests/testthat/test-smk-seqDS.R index 7cdd62eb..3a9edfb6 100644 --- a/tests/testthat/test-smk-seqDS.R +++ b/tests/testthat/test-smk-seqDS.R @@ -118,6 +118,23 @@ test_that("simple seqDS", { expect_equal(res[7], 1.5) }) +test_that("seqDS with ALONG.WITH server-side vector", { + myVec <- c(10, 20, 30, 40, 50) + + res <- seqDS("1", NULL, "1", NULL, "myVec") + + expect_equal(class(res), "numeric") + expect_length(res, 5) + expect_equal(res, c(1, 2, 3, 4, 5)) +}) + +test_that("seqDS errors when ALONG.WITH object does not exist", { + expect_error( + seqDS("1", NULL, "1", NULL, "nonexistent_obj"), + regexp = "does not exist" + ) +}) + # # Done #