diff --git a/.Rbuildignore b/.Rbuildignore index 59863e10..4b349a88 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -11,3 +11,5 @@ ^\.circleci/config\.yml$ ^\.github$ ^cran-comments\.md$ +^pull_request_template$ +PULL_REQUEST_TEMPLATE.md diff --git a/.github/pull_request_template b/.github/pull_request_template new file mode 100644 index 00000000..561614a9 --- /dev/null +++ b/.github/pull_request_template @@ -0,0 +1,15 @@ +## Description +[Write a description of the changes you have made] + +## Checklist (all items may not apply) + +### Refactor +- [ ] Replace `eval(parse(text = x), envir = parent.frame())` with `.loadServersideObject()` +- [ ] Where appropriate, check object class using `.checkClass() +- [ ] Check whether additional checks are required on the server-side + +### Testing +- [ ] Writen server-side unit tests for unhappy flow +- [ ] Run and passed `devtools::test(filter = "smk-|disc|arg")` +- [ ] Run and passed `devtools::check(args = '--no-tests')` (we run tests separately to skip performance checks) +- [ ] Run and passed `devtools::build` diff --git a/DESCRIPTION b/DESCRIPTION index d00d8a10..52c47835 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -5,7 +5,7 @@ Description: Base 'DataSHIELD' functions for the server side. 'DataSHIELD' is a been designed to only share non disclosive summary statistics, with built in automated output checking based on statistical disclosure control. With data sites setting the threshold values for the automated output checks. For more details, see 'citation("dsBase")'. -Version: 6.3.4 +Version: 7.0.0.9000 Authors@R: c(person(given = "Paul", family = "Burton", role = c("aut"), @@ -71,10 +71,12 @@ Imports: gamlss, gamlss.dist, mice, - childsds + childsds, + glue Suggests: spelling, - testthat -RoxygenNote: 7.3.3 + testthat (>= 3.0.0) +RoxygenNote: 8.0.0 Encoding: UTF-8 Language: en-GB +Config/testthat/edition: 3 diff --git a/NAMESPACE b/NAMESPACE index 897148d1..21bac77d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -39,6 +39,7 @@ export(densityGridDS) export(dimDS) export(dmtC2SDS) export(elsplineDS) +export(expDS) export(extractQuantilesDS1) export(extractQuantilesDS2) export(gamlssDS) @@ -72,6 +73,7 @@ export(listDS) export(listDisclosureSettingsDS) export(lmerSLMADS.assign) export(lmerSLMADS2) +export(logDS) export(lsDS) export(lsplineDS) export(matrixDS) @@ -140,3 +142,5 @@ import(gamlss.dist) import(mice) importFrom(gamlss.dist,pST3) importFrom(gamlss.dist,qST3) +importFrom(glue,glue) +importFrom(glue,glue_collapse) diff --git a/PULL_REQUEST_TEMPLATE.md b/PULL_REQUEST_TEMPLATE.md new file mode 100644 index 00000000..1cbc8c4a --- /dev/null +++ b/PULL_REQUEST_TEMPLATE.md @@ -0,0 +1,20 @@ +## Instructions & checklist for PR author + +### Description of changes +[Add descriptions of changes made] + +### Refactor instructions +- [ ] Replaced `x <- eval(parse(text = x.name), envir = parent.frame())` with `x <- .loadServersideObject(x)` +- [ ] If necessary, check the class of the object using `.checkClass()` + +### Testing instructions +- [ ] Writen server-side unit tests for unhappy flow +- [ ] Run `devtools::test(filter = "smk-|disc|arg")` and check it passes +- [ ] Run `devtools::check(args = '--no-tests')` and check it passes (we run tests separately to skip performance checks) +- [ ] Run `devtools::build()` and check it builds without errors + +## Instructions & checklist for PR reviewers +- [ ] Run `devtools::test(filter = "smk-|disc|arg")` and check it passes +- [ ] Run `devtools::check(args = '--no-tests')` and check it passes (we run tests separately to skip performance checks) +- [ ] Run `devtools::build()` and check it builds without errors + diff --git a/R/absDS.R b/R/absDS.R index 1f7dc518..7a6afb29 100644 --- a/R/absDS.R +++ b/R/absDS.R @@ -9,15 +9,14 @@ #' which is written to the serverside. The output object is of class numeric #' or integer. #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' absDS <- function(x) { - x.var <- eval(parse(text = x), envir = parent.frame()) + x.var <- .loadServersideObject(x) + .checkClass(obj = x.var, obj_name = x, permitted_classes = c("numeric", "integer")) - # compute the absolute values of x out <- abs(x.var) - - # assign the outcome to the data servers return(out) } # ASSIGN FUNCTION diff --git a/R/asCharacterDS.R b/R/asCharacterDS.R index f8e0d1ec..41313afa 100644 --- a/R/asCharacterDS.R +++ b/R/asCharacterDS.R @@ -10,10 +10,11 @@ #' "ascharacter.newobj") which is written to the serverside. For further #' details see help on the clientside function \code{ds.asCharacter} #' @author Amadou Gaye, Paul Burton, Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' asCharacterDS <- function(x.name) { - x <- eval(parse(text = x.name), envir = parent.frame()) + x <- .loadServersideObject(x.name) output <- as.character(x) return(output) diff --git a/R/asDataMatrixDS.R b/R/asDataMatrixDS.R index 3fff528b..a05b937f 100644 --- a/R/asDataMatrixDS.R +++ b/R/asDataMatrixDS.R @@ -15,17 +15,12 @@ #' "asdatamatrix.newobj") which is written to the serverside. For further #' details see help on the clientside function \code{ds.asDataMatrix} #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export asDataMatrixDS <- function(x.name) { - if (is.character(x.name)) { - x <- eval(parse(text = x.name), envir = parent.frame()) - } else { - studysideMessage <- "ERROR: x.name must be specified as a character string" - stop(studysideMessage, call. = FALSE) - } + x <- .loadServersideObject(x.name) output <- data.matrix(x) - return(output) } # ASSIGN FUNCTION diff --git a/R/asIntegerDS.R b/R/asIntegerDS.R index 432c9991..476f1c9c 100644 --- a/R/asIntegerDS.R +++ b/R/asIntegerDS.R @@ -11,21 +11,14 @@ #' "asinteger.newobj") which is written to the serverside. For further #' details see help on the clientside function \code{ds.asInteger}. #' @author Amadou Gaye, Paul Burton, Demetris Avraam, for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' asIntegerDS <- function(x.name){ - - if(is.character(x.name)){ - x <- eval(parse(text=x.name), envir = parent.frame()) - }else{ - studysideMessage <- "ERROR: x.name must be specified as a character string" - stop(studysideMessage, call. = FALSE) - } + x <- .loadServersideObject(x.name) output <- as.integer(as.character(x)) - return(output) - } # ASSIGN FUNCTION # asIntegerDS diff --git a/R/asListDS.R b/R/asListDS.R index 31da5f0b..f912594e 100644 --- a/R/asListDS.R +++ b/R/asListDS.R @@ -20,26 +20,13 @@ #' coerces objects to list depends on the class of the object, but in general #' the class of the output object should usually be 'list' #' @author Amadou Gaye, Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export asListDS <- function (x.name, newobj){ + x <- .loadServersideObject(x.name) - newobj.class <- NULL - if(is.character(x.name)){ - active.text<-paste0(newobj,"<-as.list(",x.name,")") - eval(parse(text=active.text), envir = parent.frame()) - - active.text2<-paste0("class(",newobj,")") - assign("newobj.class", eval(parse(text=active.text2), envir = parent.frame())) - - }else{ - studysideMessage<-"ERROR: x.name must be specified as a character string" - stop(studysideMessage, call. = FALSE) - } - - return.message<-paste0("New object <",newobj,"> created") - object.class.text<-paste0("Class of <",newobj,"> is '",newobj.class,"'") - - return(list(return.message=return.message,class.of.newobj=object.class.text)) + result <- as.list(x) + assign(newobj, result, envir = parent.frame()) } -# AGGEGATE FUNCTION +# AGGREGATE FUNCTION # asListDS diff --git a/R/asLogicalDS.R b/R/asLogicalDS.R index 4a1725f5..18347d78 100644 --- a/R/asLogicalDS.R +++ b/R/asLogicalDS.R @@ -1,32 +1,21 @@ -#' @title Coerces an R object into class numeric -#' @description this function is based on the native R function \code{as.numeric} +#' @title Coerces an R object into class logical +#' @description this function is based on the native R function \code{as.logical} #' @details See help for function \code{as.logical} in native R #' @param x.name the name of the input object to be coerced to class -#' numeric. Must be specified in inverted commas. But this argument is +#' logical. Must be specified in inverted commas. But this argument is #' usually specified directly by argument of the clientside function -#' \code{ds.aslogical} +#' \code{ds.asLogical} #' @return the object specified by the argument (or its default name #' .logic) which is written to the serverside. For further #' details see help on the clientside function \code{ds.asLogical} #' @author Amadou Gaye, Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export asLogicalDS <- function (x.name){ - -if(is.character(x.name)){ - x<-eval(parse(text=x.name), envir = parent.frame()) - - }else{ - studysideMessage<-"ERROR: x.name must be specified as a character string" - stop(studysideMessage, call. = FALSE) - } - - if(!is.numeric(x)&&!is.integer(x)&&!is.character(x)&&!is.matrix(x)){ - studysideMessage<-"ERROR: for ds.asLogical function, x.name must specify an input object of class numeric, integer, character or matrix" - stop(studysideMessage, call. = FALSE) - } + x <- .loadServersideObject(x.name) + .checkClass(obj = x, obj_name = x.name, permitted_classes = c("numeric", "integer", "character", "matrix")) output <- as.logical(x) - return(output) } #ASSIGN FUNCTION diff --git a/R/asMatrixDS.R b/R/asMatrixDS.R index 61f23dc6..e14388d1 100644 --- a/R/asMatrixDS.R +++ b/R/asMatrixDS.R @@ -9,19 +9,12 @@ #' .mat) which is written to the serverside. For further #' details see help on the clientside function \code{ds.asMatrix} #' @author Amadou Gaye, Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export asMatrixDS <- function (x.name){ - -if(is.character(x.name)){ - x<-eval(parse(text=x.name), envir = parent.frame()) - - }else{ - studysideMessage<-"ERROR: x.name must be specified as a character string" - stop(studysideMessage, call. = FALSE) - } + x <- .loadServersideObject(x.name) output <- as.matrix(x) - return(output) } #ASSIGN FUNCTION diff --git a/R/asNumericDS.R b/R/asNumericDS.R index 8b41e5e1..85a608af 100644 --- a/R/asNumericDS.R +++ b/R/asNumericDS.R @@ -11,16 +11,11 @@ #' .num) which is written to the serverside. For further #' details see help on the clientside function \code{ds.asNumeric}. #' @author Amadou Gaye, Paul Burton, Demetris Avraam, for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' asNumericDS <- function(x.name){ - - if(is.character(x.name)){ - x <- eval(parse(text=x.name), envir = parent.frame()) - }else{ - studysideMessage <- "ERROR: x.name must be specified as a character string" - stop(studysideMessage, call. = FALSE) - } + x <- .loadServersideObject(x.name) # Check that it doesn't match any non-number numbers_only <- function(vec) !grepl("\\D", vec) @@ -36,7 +31,6 @@ asNumericDS <- function(x.name){ } return(output) - } # ASSIGN FUNCTION # asNumericDS diff --git a/R/classDS.R b/R/classDS.R index 16720b80..a33e49a3 100644 --- a/R/classDS.R +++ b/R/classDS.R @@ -5,18 +5,13 @@ #' @param x a string character, the name of an object #' @return the class of the input object #' @author Stuart Wheater, for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' classDS <- function(x){ - - x.val <- eval(parse(text=x), envir = parent.frame()) - - # find the class of the input object + x.val <- .loadServersideObject(x) out <- class(x.val) - - # return the class return(out) - } #AGGREGATE FUNCTION # classDS diff --git a/R/colnamesDS.R b/R/colnamesDS.R index eb1bffb9..6dc2e99e 100644 --- a/R/colnamesDS.R +++ b/R/colnamesDS.R @@ -8,15 +8,10 @@ #' @export #' colnamesDS <- function(x){ - - x.val <- eval(parse(text=x), envir = parent.frame()) - - # find the dim of the input dataframe or matrix + x.val <- .loadServersideObject(x) + .checkClass(obj = x.val, obj_name = x, permitted_classes = c("data.frame", "matrix")) out <- colnames(x.val) - - # return the dimension return(out) - } #AGGREGATE FUNCTION # colnamesDS diff --git a/R/completeCasesDS.R b/R/completeCasesDS.R index 6e1837f6..25e6e1b5 100644 --- a/R/completeCasesDS.R +++ b/R/completeCasesDS.R @@ -31,6 +31,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 +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' completeCasesDS <- function(x1.transmit){ @@ -111,10 +112,9 @@ completeCasesDS <- function(x1.transmit){ } #Activate target object - #x1.transmit is the name of a serverside data.frame, matrix or vector - x1.use <- eval(parse(text=x1.transmit), envir = parent.frame()) + x1.use <- .loadServersideObject(x1.transmit) complete.rows <- stats::complete.cases(x1.use) - + if(is.matrix(x1.use) || is.data.frame(x1.use)){ output.object <- x1.use[complete.rows,] }else if(is.atomic(x1.use) || is.factor(x1.use)){ diff --git a/R/dimDS.R b/R/dimDS.R index 3b51ed49..c27db5b5 100644 --- a/R/dimDS.R +++ b/R/dimDS.R @@ -3,20 +3,16 @@ #' @description This function is similar to R function \code{dim}. #' @details The function returns the dimension of the input dataframe or matrix #' @param x a string character, the name of a dataframe or matrix -#' @return the dimension of the input object +#' @return a list with two elements: \code{dim} (the dimension of the input object) +#' and \code{class} (the class of the input object, for client-side consistency checking) #' @author Demetris Avraam, for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' dimDS <- function(x){ - - x.var <- eval(parse(text=x), envir = parent.frame()) - - # find the dim of the input dataframe or matrix - out <- dim(x.var) - - # return the dimension - return(out) - + x.val <- .loadServersideObject(x) + .checkClass(obj = x.val, obj_name = x, permitted_classes = c("data.frame", "matrix")) + list(dim = dim(x.val), class = class(x.val)) } #AGGREGATE FUNCTION # dimDS diff --git a/R/expDS.R b/R/expDS.R new file mode 100644 index 00000000..3c6b53c3 --- /dev/null +++ b/R/expDS.R @@ -0,0 +1,22 @@ +#' +#' @title Computes the exponential values of the input variable +#' @description This function is similar to R function \code{exp}. +#' @details The function computes the exponential values of an input numeric +#' or integer vector. +#' @param x a string character, the name of a numeric or integer vector +#' @return the object specified by the \code{newobj} argument +#' of \code{ds.exp} (or default name \code{exp.newobj}) +#' which is written to the serverside. The output object is of class numeric. +#' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +#' @export +#' +expDS <- function(x) { + x.var <- .loadServersideObject(x) + .checkClass(obj = x.var, obj_name = x, permitted_classes = c("numeric", "integer")) + + out <- exp(x.var) + return(out) +} +# ASSIGN FUNCTION +# expDS diff --git a/R/isNaDS.R b/R/isNaDS.R index 917c420b..3c73f019 100644 --- a/R/isNaDS.R +++ b/R/isNaDS.R @@ -1,19 +1,20 @@ -#' -#' @title Checks if a vector is empty -#' @description this function is similar to R function \code{is.na} but instead of a vector +#' +#' @title Checks if a vector is empty +#' @description this function is similar to R function \code{is.na} but instead of a vector #' of booleans it returns just one boolean to tell if all the element are missing values. -#' @param xvect a numerical or character vector -#' @return the integer '1' if the vector contains on NAs and '0' otherwise +#' @param x a character string, the name of a server-side vector +#' @return a list with two elements: \code{is.na} (TRUE if the vector contains +#' only NAs, FALSE otherwise) 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 #' -isNaDS <- function(xvect){ - +isNaDS <- function(x){ + xvect <- .loadServersideObject(x) + .checkClass(obj = xvect, obj_name = x, permitted_classes = c("character", "factor", "integer", "logical", "numeric", "data.frame", "matrix")) out <- is.na(xvect) total <- sum(out, na.rm=TRUE) - if(total==(1*length(out))){ - return(TRUE) - }else{ - return(FALSE) - } + is_na <- total == (1 * length(out)) + list(is.na = is_na, class = class(xvect)) } diff --git a/R/lengthDS.R b/R/lengthDS.R index 7e4b8997..0441e67c 100644 --- a/R/lengthDS.R +++ b/R/lengthDS.R @@ -3,20 +3,17 @@ #' @description This function is similar to R function \code{length}. #' @details The function returns the length of the input vector or list. #' @param x a string character, the name of a vector or list -#' @return a numeric, the number of elements of the input vector or list. +#' @return a list with two elements: \code{length} (the number of elements of the input +#' vector or list) and \code{class} (the class of the input object, for client-side +#' consistency checking) #' @author Demetris Avraam, for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' lengthDS <- function(x){ - - x.var <- eval(parse(text=x), envir = parent.frame()) - - # find the length of the input vector or list - out <- length(x.var) - - # return output length - return(out) - + x.val <- .loadServersideObject(x) + .checkClass(obj = x.val, obj_name = x, permitted_classes = c("character", "factor", "integer", "logical", "numeric", "list", "data.frame", "array", "matrix")) + list(length = length(x.val), class = class(x.val)) } #AGGREGATE FUNCTION # lengthDS diff --git a/R/levelsDS.R b/R/levelsDS.R index bdb374d5..33c33ec6 100644 --- a/R/levelsDS.R +++ b/R/levelsDS.R @@ -3,42 +3,36 @@ #' @description This function is similar to R function \code{levels}. #' @details The function returns the levels of the input vector or list. #' @param x a factor vector -#' @return a list, the factor levels present in the vector +#' @return a list with one element: \code{Levels} (the factor levels present +#' in the vector) #' @author Alex Westerberg, for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' levelsDS <- function(x){ - + + x.val <- .loadServersideObject(x) + .checkClass(obj = x.val, obj_name = x, permitted_classes = "factor") + # Check Permissive Privacy Control Level. dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot')) - + ################################################################## #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) # - #nfilter.stringShort <- as.numeric(thr$nfilter.stringShort) # - #nfilter.kNN <- as.numeric(thr$nfilter.kNN) # - #nfilter.noise <- as.numeric(thr$nfilter.noise) # nfilter.levels.density <- as.numeric(thr$nfilter.levels.density) # - #nfilter.levels.max <- as.numeric(thr$nfilter.levels.max) # ################################################################## - + # find the levels of the input vector - out <- levels(x) - input.length <- length(x) + out <- levels(x.val) + input.length <- length(x.val) output.length <- length(out) - studysideMessage <- "VALID ANALYSIS" if((input.length * nfilter.levels.density) < output.length) { - out <- NA - studysideMessage <- "FAILED: Result length less than nfilter.levels.density of input length." - stop(studysideMessage, call. = FALSE) + stop("FAILED: Result length less than nfilter.levels.density of input length.", call. = FALSE) } - - out.obj <- list(Levels=out,ValidityMessage=studysideMessage) + + out.obj <- list(Levels=out) return(out.obj) } #AGGREGATE FUNCTION diff --git a/R/logDS.R b/R/logDS.R new file mode 100644 index 00000000..6912f9dc --- /dev/null +++ b/R/logDS.R @@ -0,0 +1,24 @@ +#' +#' @title Computes the logarithm values of the input variable +#' @description This function is similar to R function \code{log}. +#' @details The function computes the logarithm values of an input numeric +#' or integer vector. By default natural logarithms are computed. +#' @param x a string character, the name of a numeric or integer vector +#' @param base a positive number, the base for which logarithms are computed. +#' Default \code{exp(1)}. +#' @return the object specified by the \code{newobj} argument +#' of \code{ds.log} (or default name \code{log.newobj}) +#' which is written to the serverside. The output object is of class numeric. +#' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +#' @export +#' +logDS <- function(x, base=exp(1)) { + x.var <- .loadServersideObject(x) + .checkClass(obj = x.var, obj_name = x, permitted_classes = c("numeric", "integer")) + + out <- log(x.var, base = base) + return(out) +} +# ASSIGN FUNCTION +# logDS diff --git a/R/namesDS.R b/R/namesDS.R index 144c7270..a32aa916 100644 --- a/R/namesDS.R +++ b/R/namesDS.R @@ -16,6 +16,7 @@ #' @return \code{namesDS} returns to the client-side the names #' of a list object stored on the server-side. #' @author Amadou Gaye, updated by Paul Burton 25/06/2020 +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' namesDS <- function(xname.transmit){ @@ -50,14 +51,14 @@ nfilter.stringShort<-as.numeric(thr$nfilter.stringShort) # stop(studysideMessage, call. = FALSE) } - list.obj<-eval(parse(text=xname.transmit), envir = parent.frame()) - - trace.message<-class(list.obj) - + list.obj <- .loadServersideObject(xname.transmit) if(!is.list(list.obj)){ - error.message <- "The input object is not of class " - stop(paste0(error.message,trace.message), call. = FALSE) + stop( + "The input object is not of class . '", xname.transmit, "' is type ", + paste(class(list.obj), collapse = ", "), + call. = FALSE + ) } diff --git a/R/numNaDS.R b/R/numNaDS.R index 5f369b90..95011e25 100644 --- a/R/numNaDS.R +++ b/R/numNaDS.R @@ -1,15 +1,17 @@ -#' +#' #' @title Counts the number of missing values -#' @description this function just counts the number of missing entries -#' in a vector. -#' @param xvect a vector -#' @return an integer, the number of missing values +#' @description this function just counts the number of missing entries +#' in a vector. +#' @param x a character string, the name of a server-side vector +#' @return a list with two elements: \code{numNA} (an integer, the number of +#' missing values) 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 #' -numNaDS <- function(xvect){ - +numNaDS <- function(x){ + xvect <- .loadServersideObject(x) out <- length(which(is.na(xvect))) - return (out) - + list(numNA = out, class = class(xvect)) } diff --git a/R/sqrtDS.R b/R/sqrtDS.R index b44fd0cc..50e3c712 100644 --- a/R/sqrtDS.R +++ b/R/sqrtDS.R @@ -9,18 +9,15 @@ #' which is written to the server-side. The output object is of class numeric #' or integer. #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' sqrtDS <- function(x){ + x.var <- .loadServersideObject(x) + .checkClass(obj = x.var, obj_name = x, permitted_classes = c("numeric", "integer")) - x.var <- eval(parse(text=x), envir = parent.frame()) - - # compute the square root values of x out <- sqrt(x.var) - - # assign the outcome to the data servers return(out) - } # ASSIGN FUNCTION # sqrtDS diff --git a/R/uniqueDS.R b/R/uniqueDS.R index 6834ff8a..23290d3b 100644 --- a/R/uniqueDS.R +++ b/R/uniqueDS.R @@ -6,26 +6,12 @@ #' @return the object specified by the \code{newobj} argument #' which is written to the server-side. #' @author Stuart Wheater for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' uniqueDS <- function(x.name.transmit = NULL){ - # Check 'x.name.transmit' contains a name - if (is.null(x.name.transmit)) - stop("Variable's name can't be NULL", call. = FALSE) - - if ((! is.character(x.name.transmit)) || (length(x.name.transmit) != 1)) - stop("Variable's name isn't a single character vector", call. = FALSE) - - # Check object exists - x.value <- eval(parse(text=x.name.transmit), envir = parent.frame()) - - if (is.null(x.value)) - stop("Variable can't be NULL", call. = FALSE) - - # Compute the unique's value + x.value <- .loadServersideObject(x.name.transmit) out <- base::unique(x.value) - - # assign the outcome to the data servers return(out) } # ASSIGN FUNCTION diff --git a/R/utils.R b/R/utils.R new file mode 100644 index 00000000..b96d8735 --- /dev/null +++ b/R/utils.R @@ -0,0 +1,67 @@ +#' Load a Server-Side Object by Name +#' +#' Retrieves a server-side object using `get()`. Supports both simple object +#' names (e.g. "D") and `$` column access (e.g. "D$LAB_TSC"). When `$` is +#' present, the object is retrieved first, then the named column is extracted +#' using `[[`. +#' +#' @param x A character string naming the object, optionally with "$column" syntax. +#' @return The retrieved R object, or the specified column if `$` syntax is used. +#' @noRd +.loadServersideObject <- function(x) { + if (!is.character(x) || length(x) != 1) { + stop("The input must be a single character string", call. = FALSE) + } + + env <- parent.frame(2) + + hasColumn <- grepl("$", x, fixed = TRUE) + + if(hasColumn) { + parts <- unlist(strsplit(x, "$", fixed = TRUE)) + obj_name <- parts[1] + col_name <- parts[2] + } else { + obj_name <- x + } + + obj <- tryCatch( + get(obj_name, envir = env), + error = function(e) stop("The server-side object '", x, "' does not exist") + ) + + if (hasColumn) { + obj <- obj[[col_name]] + if (is.null(obj)) { + stop("Column '", col_name, "' not found in '", obj_name, "'", call. = FALSE) + } + } + + return(obj) +} + +#' Check Class of a Server-Side Object +#' +#' Verifies that a given object is of an allowed class. If not, raises an informative error +#' message listing the permitted classes and the actual class of the object. +#' +#' @param obj The object whose class should be checked. +#' @param obj_name A character string with the name of the object (used in error messages). +#' @param permitted_classes A character vector of allowed class names. +#' @importFrom glue glue glue_collapse +#' @return Invisibly returns `TRUE` if the class check passes; otherwise throws an error. +#' @noRd +.checkClass <- function(obj, obj_name, permitted_classes) { + typ <- class(obj) + + if (!any(permitted_classes %in% typ)) { + msg <- glue( + "The server-side object must be of type {glue_collapse(permitted_classes, sep = ', ', last = ' or ')}. ", + "'{obj_name}' is type {glue_collapse(typ, sep = ', ', last = ' and ')}." + ) + + stop(msg, call. = FALSE) + } + + invisible(TRUE) +} diff --git a/azure-pipelines.yml b/azure-pipelines.yml index abbcc444..a0e6a96c 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -104,7 +104,7 @@ jobs: sudo apt-get install -qq pkg-config -y sudo apt-get install -qq libxml2-dev libcurl4-openssl-dev libssl-dev libgit2-dev libharfbuzz-dev libfribidi-dev libfontconfig1-dev -y - sudo apt-get install -qq libfreetype6-dev libpng-dev libtiff5-dev libjpeg-dev -y + sudo apt-get install -qq libfreetype6-dev libpng-dev libtiff5-dev libjpeg-dev libuv1-dev -y sudo apt-get install -qq r-base -y sudo R -e "install.packages('devtools', dependencies=TRUE)" sudo R -e "install.packages('RANN', dependencies=TRUE)" diff --git a/inst/DATASHIELD b/inst/DATASHIELD index c9dd9390..8753f19d 100644 --- a/inst/DATASHIELD +++ b/inst/DATASHIELD @@ -149,8 +149,8 @@ AssignMethods: c=dsBase::vectorDS, complete.cases=stats::complete.cases, list=base::list, - exp=base::exp, - log=base::log, + expDS, + logDS, sqrt=base::sqrt, abs=base::abs, sin=base::sin, diff --git a/man/absDS.Rd b/man/absDS.Rd index 633845dc..ae347019 100644 --- a/man/absDS.Rd +++ b/man/absDS.Rd @@ -24,4 +24,6 @@ or integer vector. } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/asCharacterDS.Rd b/man/asCharacterDS.Rd index 67ac5bd8..5ad9b618 100644 --- a/man/asCharacterDS.Rd +++ b/man/asCharacterDS.Rd @@ -25,4 +25,6 @@ See help for function \code{as.character} in native R } \author{ Amadou Gaye, Paul Burton, Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/asDataMatrixDS.Rd b/man/asDataMatrixDS.Rd index 3170e9af..65ab80e3 100644 --- a/man/asDataMatrixDS.Rd +++ b/man/asDataMatrixDS.Rd @@ -31,4 +31,6 @@ original class } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/asIntegerDS.Rd b/man/asIntegerDS.Rd index d3ecf5b1..1c3b8b53 100644 --- a/man/asIntegerDS.Rd +++ b/man/asIntegerDS.Rd @@ -26,4 +26,6 @@ in the help file of the clientside function \code{ds.asInteger}. } \author{ Amadou Gaye, Paul Burton, Demetris Avraam, for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/asListDS.Rd b/man/asListDS.Rd index ff2fd7be..a2fc5a1c 100644 --- a/man/asListDS.Rd +++ b/man/asListDS.Rd @@ -37,4 +37,6 @@ and so additional information can be found in the help for \code{as.list} } \author{ Amadou Gaye, Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/asLogicalDS.Rd b/man/asLogicalDS.Rd index 561c9d2b..c107a6a3 100644 --- a/man/asLogicalDS.Rd +++ b/man/asLogicalDS.Rd @@ -2,15 +2,15 @@ % Please edit documentation in R/asLogicalDS.R \name{asLogicalDS} \alias{asLogicalDS} -\title{Coerces an R object into class numeric} +\title{Coerces an R object into class logical} \usage{ asLogicalDS(x.name) } \arguments{ \item{x.name}{the name of the input object to be coerced to class -numeric. Must be specified in inverted commas. But this argument is +logical. Must be specified in inverted commas. But this argument is usually specified directly by argument of the clientside function -\code{ds.aslogical}} +\code{ds.asLogical}} } \value{ the object specified by the argument (or its default name @@ -18,11 +18,13 @@ the object specified by the argument (or its default name details see help on the clientside function \code{ds.asLogical} } \description{ -this function is based on the native R function \code{as.numeric} +this function is based on the native R function \code{as.logical} } \details{ See help for function \code{as.logical} in native R } \author{ Amadou Gaye, Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/asMatrixDS.Rd b/man/asMatrixDS.Rd index 833088d7..64146932 100644 --- a/man/asMatrixDS.Rd +++ b/man/asMatrixDS.Rd @@ -25,4 +25,6 @@ See help for function \code{as.matrix} in native R } \author{ Amadou Gaye, Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/asNumericDS.Rd b/man/asNumericDS.Rd index 2467160c..06ca5da9 100644 --- a/man/asNumericDS.Rd +++ b/man/asNumericDS.Rd @@ -26,4 +26,6 @@ in the help file of the clientside function \code{ds.asNumeric}. } \author{ Amadou Gaye, Paul Burton, Demetris Avraam, for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/classDS.Rd b/man/classDS.Rd index c1a51f83..030958cf 100644 --- a/man/classDS.Rd +++ b/man/classDS.Rd @@ -20,4 +20,6 @@ The function returns the class of an object } \author{ Stuart Wheater, for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/completeCasesDS.Rd b/man/completeCasesDS.Rd index 792c73a0..8bc0ed08 100644 --- a/man/completeCasesDS.Rd +++ b/man/completeCasesDS.Rd @@ -47,4 +47,6 @@ under help("complete.cases") in native R. } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/dimDS.Rd b/man/dimDS.Rd index c14d82af..f7119f68 100644 --- a/man/dimDS.Rd +++ b/man/dimDS.Rd @@ -10,7 +10,8 @@ dimDS(x) \item{x}{a string character, the name of a dataframe or matrix} } \value{ -the dimension of the input object +a list with two elements: \code{dim} (the dimension of the input object) + and \code{class} (the class of the input object, for client-side consistency checking) } \description{ This function is similar to R function \code{dim}. @@ -20,4 +21,6 @@ The function returns the dimension of the input dataframe or matrix } \author{ Demetris Avraam, for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/expDS.Rd b/man/expDS.Rd new file mode 100644 index 00000000..6ca53eea --- /dev/null +++ b/man/expDS.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/expDS.R +\name{expDS} +\alias{expDS} +\title{Computes the exponential values of the input variable} +\usage{ +expDS(x) +} +\arguments{ +\item{x}{a string character, the name of a numeric or integer vector} +} +\value{ +the object specified by the \code{newobj} argument +of \code{ds.exp} (or default name \code{exp.newobj}) +which is written to the serverside. The output object is of class numeric. +} +\description{ +This function is similar to R function \code{exp}. +} +\details{ +The function computes the exponential values of an input numeric +or integer vector. +} +\author{ +DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +} diff --git a/man/isNaDS.Rd b/man/isNaDS.Rd index b4954850..faae7cfb 100644 --- a/man/isNaDS.Rd +++ b/man/isNaDS.Rd @@ -4,18 +4,22 @@ \alias{isNaDS} \title{Checks if a vector is empty} \usage{ -isNaDS(xvect) +isNaDS(x) } \arguments{ -\item{xvect}{a numerical or character vector} +\item{x}{a character string, the name of a server-side vector} } \value{ -the integer '1' if the vector contains on NAs and '0' otherwise +a list with two elements: \code{is.na} (TRUE if the vector contains + only NAs, FALSE otherwise) and \code{class} (the class of the input object, + for client-side consistency checking) } \description{ -this function is similar to R function \code{is.na} but instead of a vector +this function is similar to R function \code{is.na} but instead of a vector of booleans it returns just one boolean to tell if all the element are missing values. } \author{ Gaye, A. + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/lengthDS.Rd b/man/lengthDS.Rd index 75498994..18a6a32e 100644 --- a/man/lengthDS.Rd +++ b/man/lengthDS.Rd @@ -10,7 +10,9 @@ lengthDS(x) \item{x}{a string character, the name of a vector or list} } \value{ -a numeric, the number of elements of the input vector or list. +a list with two elements: \code{length} (the number of elements of the input + vector or list) and \code{class} (the class of the input object, for client-side + consistency checking) } \description{ This function is similar to R function \code{length}. @@ -20,4 +22,6 @@ The function returns the length of the input vector or list. } \author{ Demetris Avraam, for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/levelsDS.Rd b/man/levelsDS.Rd index 7046a117..4002c73c 100644 --- a/man/levelsDS.Rd +++ b/man/levelsDS.Rd @@ -10,7 +10,8 @@ levelsDS(x) \item{x}{a factor vector} } \value{ -a list, the factor levels present in the vector +a list with one element: \code{Levels} (the factor levels present + in the vector) } \description{ This function is similar to R function \code{levels}. @@ -20,4 +21,6 @@ The function returns the levels of the input vector or list. } \author{ Alex Westerberg, for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/logDS.Rd b/man/logDS.Rd new file mode 100644 index 00000000..7c6d26d8 --- /dev/null +++ b/man/logDS.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/logDS.R +\name{logDS} +\alias{logDS} +\title{Computes the logarithm values of the input variable} +\usage{ +logDS(x, base = exp(1)) +} +\arguments{ +\item{x}{a string character, the name of a numeric or integer vector} + +\item{base}{a positive number, the base for which logarithms are computed. +Default \code{exp(1)}.} +} +\value{ +the object specified by the \code{newobj} argument +of \code{ds.log} (or default name \code{log.newobj}) +which is written to the serverside. The output object is of class numeric. +} +\description{ +This function is similar to R function \code{log}. +} +\details{ +The function computes the logarithm values of an input numeric +or integer vector. By default natural logarithms are computed. +} +\author{ +DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +} diff --git a/man/namesDS.Rd b/man/namesDS.Rd index 951bfdd0..8eb4ad0c 100644 --- a/man/namesDS.Rd +++ b/man/namesDS.Rd @@ -31,4 +31,6 @@ is formally of double class "glm" and "ls" but responds TRUE to is.list(), } \author{ Amadou Gaye, updated by Paul Burton 25/06/2020 + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/numNaDS.Rd b/man/numNaDS.Rd index 0162a630..572507fa 100644 --- a/man/numNaDS.Rd +++ b/man/numNaDS.Rd @@ -4,18 +4,22 @@ \alias{numNaDS} \title{Counts the number of missing values} \usage{ -numNaDS(xvect) +numNaDS(x) } \arguments{ -\item{xvect}{a vector} +\item{x}{a character string, the name of a server-side vector} } \value{ -an integer, the number of missing values +a list with two elements: \code{numNA} (an integer, the number of + missing values) and \code{class} (the class of the input object, for + client-side consistency checking) } \description{ -this function just counts the number of missing entries +this function just counts the number of missing entries in a vector. } \author{ Gaye, A. + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/sqrtDS.Rd b/man/sqrtDS.Rd index 79f044a0..099b8dad 100644 --- a/man/sqrtDS.Rd +++ b/man/sqrtDS.Rd @@ -24,4 +24,6 @@ or integer vector. } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/uniqueDS.Rd b/man/uniqueDS.Rd index 4168fd1b..4efedf80 100644 --- a/man/uniqueDS.Rd +++ b/man/uniqueDS.Rd @@ -21,4 +21,6 @@ The function computes the uniques values of a variable. } \author{ Stuart Wheater for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/tests/testthat/perf_files/default_perf_profile.csv b/tests/testthat/perf_files/default_perf_profile.csv index 77f556bc..7ab03037 100644 --- a/tests/testthat/perf_files/default_perf_profile.csv +++ b/tests/testthat/perf_files/default_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","11557.1204746495","0.5","2" +"meanDS::perf::numberAndNA::0","11718.8520447749","0.5","2" +"varDS::perf::numeric::0","12758.5511531009","0.5","2" +"varDS::perf::numberAndNA::0","12545.8819532662","0.5","2" diff --git a/tests/testthat/perf_files/hp-laptop_quay.csv b/tests/testthat/perf_files/hp-laptop_quay.csv index 487b248f..7ab03037 100644 --- a/tests/testthat/perf_files/hp-laptop_quay.csv +++ b/tests/testthat/perf_files/hp-laptop_quay.csv @@ -1,5 +1,5 @@ "refer_name","rate","lower_tolerance","upper_tolerance" -"meanDS::perf::numeric::0","8874.24924669612","0.5","2" -"meanDS::perf::numberAndNA::0","8946.22935183172","0.5","2" -"varDS::perf::numeric::0","10029.1022487173","0.5","2" -"varDS::perf::numberAndNA::0","10014.7789085673","0.5","2" +"meanDS::perf::numeric::0","11557.1204746495","0.5","2" +"meanDS::perf::numberAndNA::0","11718.8520447749","0.5","2" +"varDS::perf::numeric::0","12758.5511531009","0.5","2" +"varDS::perf::numberAndNA::0","12545.8819532662","0.5","2" diff --git a/tests/testthat/perf_files/performance_refactor_profile.csv b/tests/testthat/perf_files/performance_refactor_profile.csv new file mode 100644 index 00000000..ab12f3e8 --- /dev/null +++ b/tests/testthat/perf_files/performance_refactor_profile.csv @@ -0,0 +1,5 @@ +"refer_name","rate","lower_tolerance","upper_tolerance" +"meanDS::perf::numeric::0","11557.1204746495","0.5","10000" +"meanDS::perf::numberAndNA::0","11718.8520447749","0.5","10000" +"varDS::perf::numeric::0","12758.5511531009","0.5","10000" +"varDS::perf::numberAndNA::0","12545.8819532662","0.5","10000" diff --git a/tests/testthat/perf_tests/README.md b/tests/testthat/perf_tests/README.md new file mode 100644 index 00000000..33dac773 --- /dev/null +++ b/tests/testthat/perf_tests/README.md @@ -0,0 +1,48 @@ +# Performance Tests + +Performance tests measure the throughput (operations per second) of server-side functions and compare against baseline rates stored in profile CSV files. + +## How it works + +Each performance test: + +1. Runs a function in a loop for 30 seconds and calculates the current rate (ops/sec). +2. Looks up the baseline rate for that test in the active profile CSV. +3. If no entry exists, a new one is saved to the profile using the current rate and the profile-level default tolerances. +4. Asserts that the current rate falls within `[baseline * lower_tolerance, baseline * upper_tolerance]`. + +## Profiles + +Profile CSVs live in `perf_files/` and contain columns: + +| Column | Description | +|--------|-------------| +| `refer_name` | Unique test identifier (e.g. `meanDS::perf::numeric::0`) | +| `rate` | Baseline ops/sec | +| `lower_tolerance` | Multiplier for the lower bound (e.g. `0.5` = 50% of baseline) | +| `upper_tolerance` | Multiplier for the upper bound (e.g. `2.0` = 200% of baseline) | + +Available profiles: + +- `default_perf_profile.csv` -- default baseline +- `performance_refactor_profile.csv` -- for local development; no effective upper limit +- `azure-pipeline.csv`, `circleci.csv` -- CI-specific baselines + +## Switching profiles + +Set `.perf.reference.filename` in `setup.R` before sourcing `perf_rate.R`: + +```r +.perf.reference.filename <- "perf_files/performance_refactor_profile.csv" +source("perf_tests/perf_rate.R") +``` + +If not set, `perf_rate.R` defaults to `perf_files/default_perf_profile.csv`. + +## Self-populating entries + +When a test has no entry in the active profile, `perf.reference.save()` creates one using the current measured rate and the profile-level tolerances (`perf.profile.tolerance.lower/upper()`), which are read from the first row of the profile CSV. This means new tests automatically inherit the tolerance policy of whichever profile is active. + +## Skipping + +Performance tests are skipped on CRAN (`skip_on_cran()`) and CI (`skip_on_ci()`) by default, since results are hardware-dependent. diff --git a/tests/testthat/perf_tests/perf_rate.R b/tests/testthat/perf_tests/perf_rate.R index 1884cda8..584de1b0 100644 --- a/tests/testthat/perf_tests/perf_rate.R +++ b/tests/testthat/perf_tests/perf_rate.R @@ -8,7 +8,7 @@ # along with this program. If not, see . #------------------------------------------------------------------------------- -.perf.reference.filename <- 'perf_files/default_perf_profile.csv' +.perf.reference.filename <- getOption("perf.profile", "perf_files/default_perf_profile.csv") .perf.reference <- NULL @@ -16,6 +16,20 @@ .perf.reference <<- read.csv(.perf.reference.filename, header = TRUE, sep = ",") } +perf.profile.tolerance.lower <- function() { + if (is.null(.perf.reference)) + .load.pref() + + return(as.numeric(.perf.reference$lower_tolerance[1])) +} + +perf.profile.tolerance.upper <- function() { + if (is.null(.perf.reference)) + .load.pref() + + return(as.numeric(.perf.reference$upper_tolerance[1])) +} + perf.reference.save <- function(perf.ref.name, rate, tolerance.lower, tolerance.upper) { if (is.null(.perf.reference)) load.pref() diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index e7a0549e..b5ab705f 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -11,7 +12,7 @@ # Datashield test suite set up # -context("setup - start") +# context("setup - start") library(RANN) library(stringr) @@ -20,6 +21,7 @@ library(lme4) source("disclosure/set_disclosure_settings.R") source("random/set_random_seed_settings.R") +options(perf.profile = "perf_files/performance_refactor_profile.csv") source("perf_tests/perf_rate.R") -context("setup - done") +# context("setup - done") diff --git a/tests/testthat/teardown.R b/tests/testthat/teardown.R index 2a5a788c..1088bcbe 100644 --- a/tests/testthat/teardown.R +++ b/tests/testthat/teardown.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # Copyright (c) 2018-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. @@ -8,6 +9,6 @@ # along with this program. If not, see . #------------------------------------------------------------------------------- -context("teardown - start") +# context("teardown - start") -context("teardown - done") +# context("teardown - done") diff --git a/tests/testthat/test-arg-asIntegerDS.R b/tests/testthat/test-arg-asIntegerDS.R index 5bd6ed58..a3635bfd 100644 --- a/tests/testthat/test-arg-asIntegerDS.R +++ b/tests/testthat/test-arg-asIntegerDS.R @@ -1,5 +1,5 @@ #------------------------------------------------------------------------------- -# Copyright (c) 2024 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2024-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. @@ -12,21 +12,21 @@ # Set up # -context("asIntegerDS::arg::setup") +# context("asIntegerDS::arg::setup") # # Tests # -context("asIntegerDS::arg::direct input numeric") +# context("asIntegerDS::arg::direct input numeric") test_that("simple asIntegerDS non-input", { - expect_error(asIntegerDS(1.0), "ERROR: x.name must be specified as a character string", fixed = TRUE) + expect_error(asIntegerDS(1.0), "The input must be a single character string", fixed = TRUE) }) # # Done # -context("asIntegerDS::arg::shutdown") +# context("asIntegerDS::arg::shutdown") -context("asIntegerDS::arg::done") +# context("asIntegerDS::arg::done") diff --git a/tests/testthat/test-arg-asLogicalDS.R b/tests/testthat/test-arg-asLogicalDS.R index 7887ca74..d778e010 100644 --- a/tests/testthat/test-arg-asLogicalDS.R +++ b/tests/testthat/test-arg-asLogicalDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,35 +13,35 @@ # Set up # -context("asLogicalDS::arg::setup") +# context("asLogicalDS::arg::setup") # # Tests # -context("asLogicalDS::arg::direct input numeric") +# context("asLogicalDS::arg::direct input numeric") test_that("simple asLogicalDS non-input", { - expect_error(asLogicalDS(1.0), "ERROR: x.name must be specified as a character string", fixed = TRUE) + expect_error(asLogicalDS(1.0), "The input must be a single character string", fixed = TRUE) }) -context("asLogicalDS::arg::input NULL") +# context("asLogicalDS::arg::input NULL") test_that("simple asLogicalDS NULL", { input <- NULL - expect_error(asLogicalDS("input"), "ERROR: for ds.asLogical function, x.name must specify an input object of class numeric, integer, character or matrix", fixed = TRUE) + expect_error(asLogicalDS("input"), "The server-side object must be of type numeric, integer, character or matrix. 'input' is type NULL.", fixed = TRUE) }) -context("asLogicalDS::arg::input NA") +# context("asLogicalDS::arg::input NA") test_that("simple asLogicalDS NA", { input <- NA - expect_error(asLogicalDS("input"), "ERROR: for ds.asLogical function, x.name must specify an input object of class numeric, integer, character or matrix", fixed = TRUE) + expect_error(asLogicalDS("input"), "The server-side object must be of type numeric, integer, character or matrix. 'input' is type logical.", fixed = TRUE) }) # # Done # -context("asLogicalDS::arg::shutdown") +# context("asLogicalDS::arg::shutdown") -context("asLogicalDS::arg::done") +# context("asLogicalDS::arg::done") diff --git a/tests/testthat/test-arg-dataFrameFillDS.R b/tests/testthat/test-arg-dataFrameFillDS.R index d11cacd8..19c710aa 100644 --- a/tests/testthat/test-arg-dataFrameFillDS.R +++ b/tests/testthat/test-arg-dataFrameFillDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("dataFrameFillDS::arg::setup") +# context("dataFrameFillDS::arg::setup") # # Tests # -context("dataFrameFillDS::arg") +# context("dataFrameFillDS::arg") test_that("simple dataFrameFillDS, ascending, numeric", { df <- data.frame(v1 = c(-2.0, -3.0, 4.0, 2.0, 1.0, 0.0, -1.0, 3.0), v2 = c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0)) allNames.transmit <- "v1,v2,v3,v4,v5,v6,v7" @@ -45,10 +46,10 @@ test_that("simple dataFrameFillDS, ascending, numeric", { # Shutdown # -context("dataFrameFillDS::arg::shutdown") +# context("dataFrameFillDS::arg::shutdown") # # Done # -context("dataFrameFillDS::arg::done") +# context("dataFrameFillDS::arg::done") diff --git a/tests/testthat/test-arg-dataFrameSortDS.R b/tests/testthat/test-arg-dataFrameSortDS.R index 6f193172..a720588d 100644 --- a/tests/testthat/test-arg-dataFrameSortDS.R +++ b/tests/testthat/test-arg-dataFrameSortDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("dataFrameSortDS::arg::setup") +# context("dataFrameSortDS::arg::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("dataFrameSortDS::arg") +# context("dataFrameSortDS::arg") test_that("simple dataFrameSortDS, factor error check", { df <- data.frame(v1 = as.factor(c("a", "b", "c", "d", "b", "e", "f", "f")), v2 = c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0)) sort.key.name <- "df$v1" @@ -34,10 +35,10 @@ test_that("simple dataFrameSortDS, factor error check", { # Shutdown # -context("dataFrameSortDS::arg::shutdown") +# context("dataFrameSortDS::arg::shutdown") # # Done # -context("dataFrameSortDS::arg::done") +# context("dataFrameSortDS::arg::done") diff --git a/tests/testthat/test-arg-uniqueDS.R b/tests/testthat/test-arg-uniqueDS.R index 1c1a1133..bff02d5d 100644 --- a/tests/testthat/test-arg-uniqueDS.R +++ b/tests/testthat/test-arg-uniqueDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,37 +13,31 @@ # Set up # -context("uniqueDS::arg::setup") +# context("uniqueDS::arg::setup") # # Tests # -context("uniqueDS::arg::simple null argument") -test_that("simple uniqueDS for NULL", { - expect_error(uniqueDS(NULL), "Variable's name can't be NULL", fixed = TRUE) +# context("uniqueDS::arg::null argument") +test_that("uniqueDS errors for NULL argument", { + expect_error(uniqueDS(NULL), "must be a single character string", fixed = TRUE) }) -context("uniqueDS::arg::null value") -test_that("simple uniqueDS for NULL", { - input <- NULL - expect_error(uniqueDS("input"), "Variable can't be NULL", fixed = TRUE) +# context("uniqueDS::arg::not character value") +test_that("uniqueDS errors for non-character argument", { + expect_error(uniqueDS(17), "must be a single character string", fixed = TRUE) }) -context("uniqueDS::arg::not character value") -test_that("simple uniqueDS for NULL", { - expect_error(uniqueDS(17), "Variable's name isn't a single character vector", fixed = TRUE) -}) - -context("uniqueDS::arg::missing value") -test_that("simple uniqueDS for NULL", { - expect_error(uniqueDS("input"), "object 'input' not found", fixed = TRUE) +# context("uniqueDS::arg::missing value") +test_that("uniqueDS errors for nonexistent object", { + expect_error(uniqueDS("nonexistent_object"), "does not exist") }) # # Done # -context("uniqueDS::arg::shutdown") +# context("uniqueDS::arg::shutdown") -context("uniqueDS::arg::done") +# context("uniqueDS::arg::done") diff --git a/tests/testthat/test-disc-meanDS.R b/tests/testthat/test-disc-meanDS.R index 0d5b0ddc..22864733 100644 --- a/tests/testthat/test-disc-meanDS.R +++ b/tests/testthat/test-disc-meanDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("meanDS::disc::setup") +# context("meanDS::disc::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("meanDS::disc::numeric with below nfilter.tab values") +# context("meanDS::disc::numeric with below nfilter.tab values") test_that("numeric meanDS, with below nfilter.tab values", { input <- c(NA, NA, 2.0, NA, 4.0) @@ -31,6 +32,6 @@ test_that("numeric meanDS, with below nfilter.tab values", { # Done # -context("meanDS::disc::shutdown") +# context("meanDS::disc::shutdown") -context("meanDS::disc::done") +# context("meanDS::disc::done") diff --git a/tests/testthat/test-disc-varDS.R b/tests/testthat/test-disc-varDS.R index ed7d0384..3b60a771 100644 --- a/tests/testthat/test-disc-varDS.R +++ b/tests/testthat/test-disc-varDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("varDS::disc::setup") +# context("varDS::disc::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("varDS::disc::numeric with below nfilter.tab values") +# context("varDS::disc::numeric with below nfilter.tab values") test_that("numeric varDS, with below nfilter.tab values", { input <- c(NA, NA, 2.0, NA, 4.0) @@ -31,6 +32,6 @@ test_that("numeric varDS, with below nfilter.tab values", { # Done # -context("varDS::disc::shutdown") +# context("varDS::disc::shutdown") -context("varDS::disc::done") +# context("varDS::disc::done") diff --git a/tests/testthat/test-perf-meanDS.R b/tests/testthat/test-perf-meanDS.R index 794e61b2..59266cb2 100644 --- a/tests/testthat/test-perf-meanDS.R +++ b/tests/testthat/test-perf-meanDS.R @@ -1,5 +1,5 @@ #------------------------------------------------------------------------------- -# Copyright (c) 2024 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2024-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. @@ -16,7 +16,7 @@ testthat::skip_on_cran() testthat::skip_on_ci() -context("meanDS::perf::setup") +# context("meanDS::perf::setup") set.standard.disclosure.settings() @@ -24,7 +24,7 @@ set.standard.disclosure.settings() # Tests # -context("meanDS::perf::numeric") +# context("meanDS::perf::numeric") test_that("numeric meanDS - performance", { skip_on_cran() @@ -45,8 +45,8 @@ 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, 0.5, 2.0)) - perf.reference.save("meanDS::perf::numeric::0", .current.rate, 0.5, 2.0) + print(paste("meanDS::perf::numeric::0 ", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper())) + 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 = '')) } @@ -59,7 +59,7 @@ test_that("numeric meanDS - performance", { expect_lt(.current.rate, .reference.rate * .reference.tolerance.upper, label = "Observed rate", expected.label = "upper threshold on rate") }) -context("meanDS::perf::numeric with NA") +# context("meanDS::perf::numeric with NA") test_that("numeric meanDS, with NA - performance", { skip_on_cran() @@ -80,8 +80,8 @@ 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, 0.5, 2.0)) - perf.reference.save("meanDS::perf::numberAndNA::0", .current.rate, 0.5, 2.0) + print(paste("meanDS::perf::numberAndNA::0 ", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper())) + 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 = '')) } @@ -98,6 +98,6 @@ test_that("numeric meanDS, with NA - performance", { # Done # -context("meanDS::perf::shutdown") +# context("meanDS::perf::shutdown") -context("meanDS::perf::done") +# context("meanDS::perf::done") diff --git a/tests/testthat/test-perf-varDS.R b/tests/testthat/test-perf-varDS.R index d468c5da..10fff94a 100644 --- a/tests/testthat/test-perf-varDS.R +++ b/tests/testthat/test-perf-varDS.R @@ -1,5 +1,5 @@ #------------------------------------------------------------------------------- -# Copyright (c) 2024 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2024-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. @@ -16,7 +16,7 @@ testthat::skip_on_cran() testthat::skip_on_ci() -context("varDS::perf::setup") +# context("varDS::perf::setup") set.standard.disclosure.settings() @@ -24,7 +24,7 @@ set.standard.disclosure.settings() # Tests # -context("varDS::perf::numeric") +# context("varDS::perf::numeric") test_that("numeric varDS - performance", { skip_on_cran() @@ -45,8 +45,8 @@ 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, 0.5, 2.0)) - perf.reference.save("varDS::perf::numeric::0", .current.rate, 0.5, 2.0) + print(paste("varDS::perf::numeric::0 ", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper())) + 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 = '')) } @@ -59,7 +59,7 @@ test_that("numeric varDS - performance", { expect_lt(.current.rate, .reference.rate * .reference.tolerance.upper, label = "Observed rate", expected.label = "upper threshold on rate") }) -context("varDS::perf::numeric with NA") +# context("varDS::perf::numeric with NA") test_that("numeric varDS, with NA - performance", { skip_on_cran() @@ -80,8 +80,8 @@ 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, 0.5, 2.0)) - perf.reference.save("varDS::perf::numberAndNA::0", .current.rate, 0.5, 2.0) + print(paste("varDS::perf::numberAndNA::0 ", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper())) + 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 = '')) } @@ -98,6 +98,6 @@ test_that("numeric varDS, with NA - performance", { # Done # -context("varDS::perf::shutdown") +# context("varDS::perf::shutdown") -context("varDS::perf::done") +# context("varDS::perf::done") diff --git a/tests/testthat/test-smk-BooleDS.R b/tests/testthat/test-smk-BooleDS.R index dd10c782..5fcfa4ee 100644 --- a/tests/testthat/test-smk-BooleDS.R +++ b/tests/testthat/test-smk-BooleDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("BooleDS::smk::setup") +# context("BooleDS::smk::setup") # # Tests # -context("BooleDS::smk::simple equal") +# context("BooleDS::smk::simple equal") test_that("simple BooleDS, equal numeric", { 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)) @@ -47,7 +48,7 @@ test_that("simple BooleDS, equal logical", { expect_equal(res[5], FALSE) }) -context("BooleDS::smk::simple not-equal") +# context("BooleDS::smk::simple not-equal") test_that("simple BooleDS, not-equal numeric", { 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)) @@ -76,7 +77,7 @@ test_that("simple BooleDS, not-equal logical", { expect_equal(res[5], TRUE) }) -context("BooleDS::smk::simple less-than") +# context("BooleDS::smk::simple less-than") test_that("simple BooleDS, less-than numeric", { 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)) @@ -105,7 +106,7 @@ test_that("simple BooleDS, less-than logical", { expect_equal(res[5], FALSE) }) -context("BooleDS::smk::simple less-than-equal") +# context("BooleDS::smk::simple less-than-equal") test_that("simple BooleDS, less-than-equal numeric", { 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)) @@ -134,7 +135,7 @@ test_that("simple BooleDS, less-than-equal logical", { expect_equal(res[5], FALSE) }) -context("BooleDS::smk::simple greater-than") +# context("BooleDS::smk::simple greater-than") test_that("simple BooleDS, greater-than numeric", { 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)) @@ -163,7 +164,7 @@ test_that("simple BooleDS, greater-than logical", { expect_equal(res[5], TRUE) }) -context("BooleDS::smk::simple greater-than-equal") +# context("BooleDS::smk::simple greater-than-equal") test_that("simple BooleDS, greater-than-equal numeric", { 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)) @@ -192,7 +193,7 @@ test_that("simple BooleDS, greater-than-equal logical", { expect_equal(res[5], TRUE) }) -context("BooleDS::smk::na-check numeric") +# context("BooleDS::smk::na-check numeric") test_that("na-check BooleDS, numeric, NA=NA", { input <- data.frame(v1 = c(0.0, NA, 2.0, 3.0, NA), v2 = c(NA, 3.0, 2.0, 1.0, NA)) @@ -235,7 +236,7 @@ test_that("na-check BooleDS, numeric, NA=1", { expect_equal(res[5], 1) }) -context("BooleDS::smk::na-check logical") +# context("BooleDS::smk::na-check logical") test_that("na-check BooleDS, logical, NA=NA", { input <- data.frame(v1 = c(0.0, NA, 2.0, 3.0, NA), v2 = c(NA, 3.0, 2.0, 1.0, NA)) @@ -282,6 +283,6 @@ test_that("na-check BooleDS, logical, NA=1", { # Done # -context("BooleDS::smk::shutdown") +# context("BooleDS::smk::shutdown") -context("BooleDS::smk::done") +# context("BooleDS::smk::done") diff --git a/tests/testthat/test-smk-absDS.R b/tests/testthat/test-smk-absDS.R index c9c1cca9..6b2f9a76 100644 --- a/tests/testthat/test-smk-absDS.R +++ b/tests/testthat/test-smk-absDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,23 +13,13 @@ # Set up # -context("absDS::smk::setup") +# context("absDS::smk::setup") # # Tests # -context("absDS::smk::special") -test_that("simple absDS, NA", { - input <- NA - - res <- absDS("input") - - expect_equal(class(res), "integer") - expect_length(res, 1) - expect_true(is.na(res)) -}) - +# context("absDS::smk::special") test_that("simple absDS, NaN", { input <- NaN @@ -59,7 +50,7 @@ test_that("simple absDS, -Inf", { expect_true(is.infinite(res)) }) -context("absDS::smk::numeric") +# context("absDS::smk::numeric") test_that("simple absDS, numeric 0.0", { input <- 0.0 @@ -90,7 +81,7 @@ test_that("simple absDS, numeric -10.0", { expect_equal(res, 10.0) }) -context("absDS::smk::integer") +# context("absDS::smk::integer") test_that("simple absDS, integer 0L", { input <- 0L @@ -121,7 +112,7 @@ test_that("simple absDS, integer -10L", { expect_equal(res, 10L) }) -context("absDS::smk::special vector") +# context("absDS::smk::special vector") test_that("simple absDS", { input <- c(NA, NaN, Inf, -Inf) @@ -135,7 +126,7 @@ test_that("simple absDS", { expect_true(is.infinite(res[4])) }) -context("absDS::smk::numeric vector") +# context("absDS::smk::numeric vector") test_that("simple absDS", { input <- c(0.0, 4.0, 9.0, -10.0, -50.0, -20.0) @@ -151,7 +142,7 @@ test_that("simple absDS", { expect_equal(res[6], 20.0) }) -context("absDS::smk::integer vector") +# context("absDS::smk::integer vector") test_that("simple absDS", { input <- c(0L, 4L, 9L, -10L, -50L, -20L) @@ -166,11 +157,10 @@ test_that("simple absDS", { expect_equal(res[5], 50L) expect_equal(res[6], 20L) }) - # # Done # -context("absDS::smk::shutdown") +# context("absDS::smk::shutdown") -context("absDS::smk::done") +# context("absDS::smk::done") diff --git a/tests/testthat/test-smk-asCharacterDS.R b/tests/testthat/test-smk-asCharacterDS.R index a37c7a82..40cdaf73 100644 --- a/tests/testthat/test-smk-asCharacterDS.R +++ b/tests/testthat/test-smk-asCharacterDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("asCharacterDS::smk::setup") +# context("asCharacterDS::smk::setup") # # Tests # -context("asCharacterDS::smk::numeric") +# context("asCharacterDS::smk::numeric") test_that("numeric asCharacterDS", { input <- 3.141 @@ -29,7 +30,7 @@ test_that("numeric asCharacterDS", { expect_equal(res, "3.141") }) -context("asCharacterDS::smk::numeric vector") +# context("asCharacterDS::smk::numeric vector") test_that("numeric vector asCharacterDS", { input <- c(0.0, 1.0, 2.0, 3.0, 4.0) @@ -44,7 +45,7 @@ test_that("numeric vector asCharacterDS", { expect_equal(res[5], "4") }) -context("asCharacterDS::smk::logical") +# context("asCharacterDS::smk::logical") test_that("logical asCharacterDS - FALSE", { input <- FALSE @@ -65,7 +66,7 @@ test_that("logical asCharacterDS - TRUE", { expect_equal(res, "TRUE") }) -context("asCharacterDS::smk::logical vector") +# context("asCharacterDS::smk::logical vector") test_that("logical vector asCharacterDS", { input <- c(TRUE, FALSE, TRUE, FALSE, TRUE) @@ -84,6 +85,6 @@ test_that("logical vector asCharacterDS", { # Done # -context("asCharacterDS::smk::shutdown") +# context("asCharacterDS::smk::shutdown") -context("asCharacterDS::smk::done") +# context("asCharacterDS::smk::done") diff --git a/tests/testthat/test-smk-asDataMatrixDS.R b/tests/testthat/test-smk-asDataMatrixDS.R index 6c4f567c..6529b1ab 100644 --- a/tests/testthat/test-smk-asDataMatrixDS.R +++ b/tests/testthat/test-smk-asDataMatrixDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("asDataMatrixDS::smk::setup") +# context("asDataMatrixDS::smk::setup") # # Tests # -context("asDataMatrixDS::smk::simple") +# context("asDataMatrixDS::smk::simple") test_that("simple asDataMatrixDS", { 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)) @@ -54,11 +55,10 @@ test_that("simple asDataMatrixDS", { expect_equal(res.colnames[1], "v1") expect_equal(res.colnames[2], "v2") }) - # # Done # -context("asDataMatrixDS::smk::shutdown") +# context("asDataMatrixDS::smk::shutdown") -context("asDataMatrixDS::smk::done") +# context("asDataMatrixDS::smk::done") diff --git a/tests/testthat/test-smk-asFactorDS1.R b/tests/testthat/test-smk-asFactorDS1.R index fd59cefc..a990d4ff 100644 --- a/tests/testthat/test-smk-asFactorDS1.R +++ b/tests/testthat/test-smk-asFactorDS1.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("asFactorDS1::smk::setup") +# context("asFactorDS1::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("asFactorDS1::smk::simple") +# context("asFactorDS1::smk::simple") test_that("simple asFactorDS1", { input <- c(2.0, 1.0, 3.0, 3.0, 3.0, 1.0, 2.0, 2.0, 1.0, 2.0) @@ -37,6 +38,6 @@ test_that("simple asFactorDS1", { # Done # -context("asFactorDS1::smk::shutdown") +# context("asFactorDS1::smk::shutdown") -context("asFactorDS1::smk::done") +# context("asFactorDS1::smk::done") diff --git a/tests/testthat/test-smk-asFactorDS2.R b/tests/testthat/test-smk-asFactorDS2.R index db4a3876..1c761d4d 100644 --- a/tests/testthat/test-smk-asFactorDS2.R +++ b/tests/testthat/test-smk-asFactorDS2.R @@ -12,7 +12,7 @@ # Set up # -context("asFactorDS2::smk::setup") +# context("asFactorDS2::smk::setup") set.standard.disclosure.settings() @@ -20,7 +20,7 @@ set.standard.disclosure.settings() # Tests # -context("asFactorDS2::smk::simple") +# context("asFactorDS2::smk::simple") test_that("simple asFactorDS2, fixed.dummy.vars is FALSE", { input <- c(2, 1, 3, 3, 3, 1, 2, 2, 1, 2) all.unique.levels.transmit <- "1,2,3,4" @@ -113,6 +113,6 @@ test_that("simple asFactorDS2, fixed.dummy.vars is TRUE", { # Done # -context("asFactorDS2::smk::shutdown") +# context("asFactorDS2::smk::shutdown") -context("asFactorDS2::smk::done") +# context("asFactorDS2::smk::done") diff --git a/tests/testthat/test-smk-asFactorSimpleDS.R b/tests/testthat/test-smk-asFactorSimpleDS.R index bafe51b3..7e871da3 100644 --- a/tests/testthat/test-smk-asFactorSimpleDS.R +++ b/tests/testthat/test-smk-asFactorSimpleDS.R @@ -12,7 +12,7 @@ # Set up # -context("asFactorSimpleDS::smk::setup") +# context("asFactorSimpleDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +20,7 @@ set.standard.disclosure.settings() # Tests # -context("asFactorSimpleDS::smk::simple") +# context("asFactorSimpleDS::smk::simple") test_that("simple asFactorSimpleDS", { input <- c(2.0, 1.0, 3.0, 3.0, 3.0, 1.0, 2.0, 2.0, 1.0, 2.0) @@ -52,6 +52,6 @@ test_that("simple asFactorSimpleDS", { # Done # -context("asFactorSimpleDS::smk::shutdown") +# context("asFactorSimpleDS::smk::shutdown") -context("asFactorSimpleDS::smk::done") +# context("asFactorSimpleDS::smk::done") diff --git a/tests/testthat/test-smk-asIntegerDS.R b/tests/testthat/test-smk-asIntegerDS.R index 902bc198..1fc8445b 100644 --- a/tests/testthat/test-smk-asIntegerDS.R +++ b/tests/testthat/test-smk-asIntegerDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("asIntegerDS::smk::setup") +# context("asIntegerDS::smk::setup") # # Tests # -context("asIntegerDS::smk::numeric") +# context("asIntegerDS::smk::numeric") test_that("numeric asIntegerDS", { input <- 3.141 @@ -29,7 +30,7 @@ test_that("numeric asIntegerDS", { expect_equal(res, 3) }) -context("asIntegerDS::smk::numeric vector") +# context("asIntegerDS::smk::numeric vector") test_that("numeric vector asIntegerDS", { input <- c(0.1, 1.1, 2.1, 3.1, 4.1) @@ -44,7 +45,7 @@ test_that("numeric vector asIntegerDS", { expect_equal(res[5], 4) }) -context("asIntegerDS::smk::character") +# context("asIntegerDS::smk::character") test_that("character asIntegerDS - FALSE", { input <- "101" @@ -55,7 +56,7 @@ test_that("character asIntegerDS - FALSE", { expect_equal(res, 101) }) -context("asIntegerDS::smk::character vector") +# context("asIntegerDS::smk::character vector") test_that("character vector asIntegerDS", { input <- c("101", "202", "303", "404", "505") @@ -69,11 +70,10 @@ test_that("character vector asIntegerDS", { expect_equal(res[4], 404) expect_equal(res[5], 505) }) - # # Done # -context("asIntegerDS::smk::shutdown") +# context("asIntegerDS::smk::shutdown") -context("asIntegerDS::smk::done") +# context("asIntegerDS::smk::done") diff --git a/tests/testthat/test-smk-asListDS.R b/tests/testthat/test-smk-asListDS.R index 7caa9368..1ac8ac68 100644 --- a/tests/testthat/test-smk-asListDS.R +++ b/tests/testthat/test-smk-asListDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("asListDS::smk::setup") +# context("asListDS::smk::setup") # # Tests # -context("asListDS::smk::simple") +# context("asListDS::smk::simple") test_that("simple asListDS", { input <- list(v1 = c(1, 2, 3), v2 = c(4, 5, 6)) newobj.name <- 'newobj' @@ -28,19 +29,13 @@ test_that("simple asListDS", { res <- asListDS("input", newobj.name) expect_true(exists("newobj")) - - expect_equal(class(res), "list") - expect_length(res, 2) - expect_equal(res[[1]], "New object created") - expect_equal(res[[2]], "Class of is 'list'") - expect_equal(res$return.message, "New object created") - expect_equal(res$class.of.newobj, "Class of is 'list'") + expect_equal(class(newobj), "list") + expect_length(newobj, 2) }) - # # Done # -context("asListDS::smk::shutdown") +# context("asListDS::smk::shutdown") -context("asListDS::smk::done") +# context("asListDS::smk::done") diff --git a/tests/testthat/test-smk-asLogicalDS.R b/tests/testthat/test-smk-asLogicalDS.R index d931ad2b..41ef866e 100644 --- a/tests/testthat/test-smk-asLogicalDS.R +++ b/tests/testthat/test-smk-asLogicalDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("asLogicalDS::smk::setup") +# context("asLogicalDS::smk::setup") # # Tests # -context("asLogicalDS::smk::integer") +# context("asLogicalDS::smk::integer") test_that("simple asLogicalDS integer - FALSE", { input <- 0L @@ -39,7 +40,7 @@ test_that("simple asLogicalDS integer - TRUE", { expect_equal(res, TRUE) }) -context("asLogicalDS::smk::integer vector") +# context("asLogicalDS::smk::integer vector") test_that("simple asLogicalDS integer vector", { input <- c(1L, 0L, 1L, 0L, 1L) @@ -54,7 +55,7 @@ test_that("simple asLogicalDS integer vector", { expect_equal(res[5], TRUE) }) -context("asLogicalDS::smk::numeric") +# context("asLogicalDS::smk::numeric") test_that("simple asLogicalDS numeric - FALSE", { input <- 0.0 @@ -75,7 +76,7 @@ test_that("simple asLogicalDS numeric - TRUE", { expect_equal(res, TRUE) }) -context("asLogicalDS::smk::numeric vector") +# context("asLogicalDS::smk::numeric vector") test_that("simple asLogicalDS numeric vector", { input <- c(1.0, 0.0, 1.0, 0.0, 1.0) @@ -90,7 +91,7 @@ test_that("simple asLogicalDS numeric vector", { expect_equal(res[5], TRUE) }) -context("asLogicalDS::smk::character") +# context("asLogicalDS::smk::character") test_that("simple asLogicalDS, character - FALSE", { input <- "F" @@ -165,11 +166,10 @@ test_that("simple asLogicalDS, character vector", { expect_equal(res[5], FALSE) expect_equal(res[6], FALSE) }) - # # Done # -context("asLogicalDS::smk::shutdown") +# context("asLogicalDS::smk::shutdown") -context("asLogicalDS::smk::done") +# context("asLogicalDS::smk::done") diff --git a/tests/testthat/test-smk-asMatrixDS.R b/tests/testthat/test-smk-asMatrixDS.R index 6d873a5f..ba759e27 100644 --- a/tests/testthat/test-smk-asMatrixDS.R +++ b/tests/testthat/test-smk-asMatrixDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("asMatrixDS::smk::setup") +# context("asMatrixDS::smk::setup") # # Tests # -context("asMatrixDS::smk::simple") +# context("asMatrixDS::smk::simple") test_that("simple asMatrixDS", { 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)) @@ -54,11 +55,10 @@ test_that("simple asMatrixDS", { expect_equal(res.colnames[1], "v1") expect_equal(res.colnames[2], "v2") }) - # # Done # -context("asMatrixDS::smk::shutdown") +# context("asMatrixDS::smk::shutdown") -context("asMatrixDS::smk::done") +# context("asMatrixDS::smk::done") diff --git a/tests/testthat/test-smk-asNumericDS.R b/tests/testthat/test-smk-asNumericDS.R index d1e8d57c..4ace90f5 100644 --- a/tests/testthat/test-smk-asNumericDS.R +++ b/tests/testthat/test-smk-asNumericDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("asNumericDS::smk::setup") +# context("asNumericDS::smk::setup") # # Tests # -context("asNumericDS::smk::character") +# context("asNumericDS::smk::character") test_that("character asNumericDS - FALSE", { input <- "101" @@ -29,7 +30,7 @@ test_that("character asNumericDS - FALSE", { expect_equal(res, 101) }) -context("asNumericDS::smk::character vector") +# context("asNumericDS::smk::character vector") test_that("character vector asNumericDS", { input <- c("101", "202", "303", "404", "505") @@ -44,7 +45,7 @@ test_that("character vector asNumericDS", { expect_equal(res[5], 505) }) -context("asNumericDS::smk::character 'non numeric' vector") +# context("asNumericDS::smk::character 'non numeric' vector") test_that("character 'non numeric' vector asNumericDS", { input <- c("aa", "bb", "cc", "dd", "ee") @@ -59,7 +60,7 @@ test_that("character 'non numeric' vector asNumericDS", { expect_equal(res[5], 5) }) -context("asNumericDS::smk::factor vector") +# context("asNumericDS::smk::factor vector") test_that("factor vector asNumericDS", { vec <- c("101", "202", "303", "404", "505") input <- as.factor(vec) @@ -75,7 +76,7 @@ test_that("factor vector asNumericDS", { expect_equal(res[5], 505) }) -context("asNumericDS::smk::factor rev vector") +# context("asNumericDS::smk::factor rev vector") test_that("factor vector asNumericDS", { vec <- c("505", "404", "303", "202", "101") input <- as.factor(vec) @@ -91,7 +92,7 @@ test_that("factor vector asNumericDS", { expect_equal(res[5], 101) }) -context("asNumericDS::smk::factor numeric levels vector") +# context("asNumericDS::smk::factor numeric levels vector") test_that("factor numeric levels vector asNumericDS", { vec <- c("aa", "bb", "cc", "dd", "ee") input <- as.factor(vec) @@ -108,7 +109,7 @@ test_that("factor numeric levels vector asNumericDS", { expect_equal(res[5], 55) }) -context("asNumericDS::smk::factor vector with only numbers in its values") +# context("asNumericDS::smk::factor vector with only numbers in its values") test_that("factor vector with only numbers in its values asNumericDS", { input <- as.factor(c('1','1','2','2','1')) @@ -123,7 +124,7 @@ test_that("factor vector with only numbers in its values asNumericDS", { expect_equal(res[5], 1) }) -context("asNumericDS::smk::factor vector with only characters in its values") +# context("asNumericDS::smk::factor vector with only characters in its values") test_that("factor vector with only characters in its values asNumericDS", { input <- as.factor(c('b','b','a','a','b')) @@ -138,7 +139,7 @@ test_that("factor vector with only characters in its values asNumericDS", { expect_equal(res[5], 2) }) -context("asNumericDS::smk::character vector with only numbers in its values") +# context("asNumericDS::smk::character vector with only numbers in its values") test_that("factor vector with only numbers in its values asNumericDS", { input <- c('1','1','2','2','1') @@ -153,7 +154,7 @@ test_that("factor vector with only numbers in its values asNumericDS", { expect_equal(res[5], 1) }) -context("asNumericDS::smk::character vector with only characters in its values") +# context("asNumericDS::smk::character vector with only characters in its values") test_that("character vector with only characters in its values asNumericDS", { input <- c('b','b','a','a','b') @@ -168,7 +169,7 @@ test_that("character vector with only characters in its values asNumericDS", { expect_equal(res[5], 2) }) -context("asNumericDS::smk::character vector with strings having characters and numbers") +# context("asNumericDS::smk::character vector with strings having characters and numbers") test_that("character vector with strings having characters and numbers asNumericDS", { input <- c('b1','b2','1a','a','b') @@ -183,7 +184,7 @@ test_that("character vector with strings having characters and numbers asNumeric expect_equal(res[5], 3) }) -context("asNumericDS::smk::logical vector") +# context("asNumericDS::smk::logical vector") test_that("logical vector asNumericDS", { input <- c(TRUE, TRUE, FALSE, TRUE) @@ -197,7 +198,7 @@ test_that("logical vector asNumericDS", { expect_equal(res[4], 1) }) -context("asNumericDS::smk::logical character vector") +# context("asNumericDS::smk::logical character vector") test_that("logical vector character asNumericDS", { input <- c("TRUE", "TRUE", "FALSE", "TRUE") @@ -211,7 +212,7 @@ test_that("logical vector character asNumericDS", { expect_equal(res[4], 2) }) -context("asNumericDS::smk::integer vector") +# context("asNumericDS::smk::integer vector") test_that("integer vector asNumericDS", { input <- as.integer(c('1','1','2','2','1')) @@ -225,11 +226,10 @@ test_that("integer vector asNumericDS", { expect_equal(res[4], 2) expect_equal(res[5], 1) }) - # # Done # -context("asNumericDS::smk::shutdown") +# context("asNumericDS::smk::shutdown") -context("asNumericDS::smk::done") +# context("asNumericDS::smk::done") diff --git a/tests/testthat/test-smk-aucDS.R b/tests/testthat/test-smk-aucDS.R index 800bbcf4..bcbbada1 100644 --- a/tests/testthat/test-smk-aucDS.R +++ b/tests/testthat/test-smk-aucDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("aucDS::smk::setup") +# context("aucDS::smk::setup") # # Tests @@ -31,7 +32,7 @@ test_that("aucDS", { expect_equal(class(res$AUC), "numeric") expect_equal(res$AUC, 0.6767515, tolerance=1e-07) expect_equal(class(res$se), "numeric") - expect_equal(res$se, 0.02065186, tolerance=1e-08) + expect_equal(res$se, 0.02065186, tolerance=1e-07) }) @@ -39,6 +40,6 @@ test_that("aucDS", { # Done # -context("aucDS::smk::shutdown") +# context("aucDS::smk::shutdown") -context("aucDS::smk::done") +# context("aucDS::smk::done") diff --git a/tests/testthat/test-smk-bp_standardsDS.R b/tests/testthat/test-smk-bp_standardsDS.R index 906dd34f..fe8b9bc1 100644 --- a/tests/testthat/test-smk-bp_standardsDS.R +++ b/tests/testthat/test-smk-bp_standardsDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("bp_standardsDS::smk::setup") +# context("bp_standardsDS::smk::setup") # # Tests # -context("bp_standardsDS::smk::systolic") +# context("bp_standardsDS::smk::systolic") test_that("systolic bp_standardsDS", { sex <- c(2, 2, 2, 2, 2, 1, 2, 1, 2, 1) @@ -46,7 +47,7 @@ test_that("systolic bp_standardsDS", { }) -context("bp_standardsDS::smk::diastolic") +# context("bp_standardsDS::smk::diastolic") test_that("diastolic bp_standardsDS", { sex <- c(2, 2, 2, 2, 2, 1, 2, 1, 2, 1) @@ -79,6 +80,6 @@ test_that("diastolic bp_standardsDS", { # Done # -context("bp_standardsDS::smk::shutdown") +# context("bp_standardsDS::smk::shutdown") -context("bp_standardsDS::smk::done") +# context("bp_standardsDS::smk::done") diff --git a/tests/testthat/test-smk-cDS.R b/tests/testthat/test-smk-cDS.R index b3df1a65..0f9842fc 100644 --- a/tests/testthat/test-smk-cDS.R +++ b/tests/testthat/test-smk-cDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("cDS::smk::setup") +# context("cDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("cDS::smk::numeric list") +# context("cDS::smk::numeric list") test_that("numeric list cDS", { input <- list(a=0.0, b=1.0, c=2.0, d=3.0) @@ -34,7 +35,7 @@ test_that("numeric list cDS", { expect_equal(res[[4]], 3.0) }) -context("cDS::smk::character list") +# context("cDS::smk::character list") test_that("character list cDS", { input <- list(a="0.0", b="1.0", c="2.0", d="3.0") @@ -48,7 +49,7 @@ test_that("character list cDS", { expect_equal(res[[4]], "3.0") }) -context("cDS::smk::numeric list small") +# context("cDS::smk::numeric list small") test_that("single numeric list small cDS", { input <- list(a=0, b=1) @@ -60,7 +61,7 @@ test_that("single numeric list small cDS", { expect_equal(res[[2]], NA) }) -context("cDS::smk::empty list") +# context("cDS::smk::empty list") test_that("empty list cDS", { input <- list() @@ -74,6 +75,6 @@ test_that("empty list cDS", { # Done # -context("cDS::smk::shutdown") +# context("cDS::smk::shutdown") -context("cDS::smk::done") +# context("cDS::smk::done") diff --git a/tests/testthat/test-smk-cbindDS.R b/tests/testthat/test-smk-cbindDS.R index c1ed0a2f..11fe1ef3 100644 --- a/tests/testthat/test-smk-cbindDS.R +++ b/tests/testthat/test-smk-cbindDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("cbindDS::smk::setup") +# context("cbindDS::smk::setup") # # Tests # -context("cbindDS::smk::simple") +# context("cbindDS::smk::simple") test_that("simple cbindDS", { inputs <- 'input1,input2' input1 <- c(0.0, 1.0, 2.0, 3.0) @@ -44,6 +45,6 @@ test_that("simple cbindDS", { # Done # -context("cbindDS::smk::shutdown") +# context("cbindDS::smk::shutdown") -context("cbindDS::smk::done") +# context("cbindDS::smk::done") diff --git a/tests/testthat/test-smk-changeRefGroupDS.R b/tests/testthat/test-smk-changeRefGroupDS.R index 0bdd87ae..3d94fde7 100644 --- a/tests/testthat/test-smk-changeRefGroupDS.R +++ b/tests/testthat/test-smk-changeRefGroupDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("changeRefGroupDS::smk::setup") +# context("changeRefGroupDS::smk::setup") # # Tests # -context("changeRefGroupDS::smk") +# context("changeRefGroupDS::smk") test_that("simple changeRefGroupDS, reorderByRef is FALSE", { x <- c(8, 1, 6, 1, 4, 1, 2, 1) xf <- as.factor(x) @@ -107,6 +108,6 @@ test_that("simple changeRefGroupDS, reorderByRef is TRUE", { # Done # -context("changeRefGroupDS::smk::shutdown") +# context("changeRefGroupDS::smk::shutdown") -context("changeRefGroupDS::smk::done") +# context("changeRefGroupDS::smk::done") diff --git a/tests/testthat/test-smk-checkNegValueDS.R b/tests/testthat/test-smk-checkNegValueDS.R index 52b64cce..487a9709 100644 --- a/tests/testthat/test-smk-checkNegValueDS.R +++ b/tests/testthat/test-smk-checkNegValueDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("checkNegValueDS::smk::setup") +# context("checkNegValueDS::smk::setup") # # Tests # -context("checkNegValueDS::smk::with no neg") +# context("checkNegValueDS::smk::with no neg") test_that("simple checkNegValueDS, with no neg and no NA", { input <- c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0) @@ -39,7 +40,7 @@ test_that("simple checkNegValueDS, with no neg and NA", { expect_equal(res, FALSE) }) -context("checkNegValueDS::smk::with neg") +# context("checkNegValueDS::smk::with neg") test_that("simple checkNegValueDS, with neg and no NA", { input <- c(0.0, -1.0, -2.0, 3.0, -4.0, 5.0, -6.0, 7.0) @@ -64,6 +65,6 @@ test_that("simple checkNegValueDS, with neg and NA", { # Done # -context("checkNegValueDS::smk::shutdown") +# context("checkNegValueDS::smk::shutdown") -context("checkNegValueDS::smk::done") +# context("checkNegValueDS::smk::done") diff --git a/tests/testthat/test-smk-classDS.R b/tests/testthat/test-smk-classDS.R index 4b3d71b3..a3eb79d3 100644 --- a/tests/testthat/test-smk-classDS.R +++ b/tests/testthat/test-smk-classDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("classDS::smk::setup") +# context("classDS::smk::setup") # # Tests # -context("classDS::smk::character") +# context("classDS::smk::character") test_that("simple classDS, character", { input <- "value" @@ -39,7 +40,7 @@ test_that("simple classDS, character vector", { expect_equal(res, "character") }) -context("classDS::smk::integer") +# context("classDS::smk::integer") test_that("simple classDS, integer", { input <- 1L @@ -60,7 +61,7 @@ test_that("simple classDS, integer vector", { expect_equal(res, "integer") }) -context("classDS::smk::numeric") +# context("classDS::smk::numeric") test_that("simple classDS, numeric", { input <- 1.1 @@ -81,7 +82,7 @@ test_that("simple classDS, numeric vector", { expect_equal(res, "numeric") }) -context("classDS::smk::logical") +# context("classDS::smk::logical") test_that("simple classDS, logical, FALSE", { input <- FALSE @@ -112,7 +113,7 @@ test_that("simple classDS, logical vector", { expect_equal(res, "logical") }) -context("classDS::smk::data.frame") +# context("classDS::smk::data.frame") test_that("simple classDS, 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)) @@ -123,7 +124,7 @@ test_that("simple classDS, data.frame", { expect_equal(res, "data.frame") }) -context("classDS::smk::array") +# context("classDS::smk::array") test_that("simple classDS, array", { input <- array(c(0.0, 1.0, 2.0, 3.0, 4.0)) @@ -134,7 +135,7 @@ test_that("simple classDS, array", { expect_equal(res, "array") }) -context("classDS::smk::matrix") +# context("classDS::smk::matrix") test_that("simple classDS, matrix", { input <- matrix(c(0.0, 1.0, 2.0, 3.0, 4.0)) @@ -154,7 +155,7 @@ test_that("simple classDS, matrix", { } }) -context("classDS::smk::data.matrix") +# context("classDS::smk::data.matrix") test_that("simple classDS, 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))) @@ -174,7 +175,7 @@ test_that("simple classDS, data.matrix", { } }) -context("classDS::smk::date") +# context("classDS::smk::date") test_that("simple classDS, date", { input <- Sys.Date() @@ -185,7 +186,7 @@ test_that("simple classDS, date", { expect_equal(res, "Date") }) -context("classDS::smk::formula") +# context("classDS::smk::formula") test_that("simple classDS, formula", { input <- X ~ A + B @@ -196,7 +197,7 @@ test_that("simple classDS, formula", { expect_equal(res, "formula") }) -context("classDS::smk::environment") +# context("classDS::smk::environment") test_that("simple classDS, environment", { input <- environment() @@ -207,7 +208,7 @@ test_that("simple classDS, environment", { expect_equal(res, "environment") }) -context("classDS::smk::NA") +# context("classDS::smk::NA") test_that("special classDS, NA", { input <- NA @@ -218,7 +219,7 @@ test_that("special classDS, NA", { expect_equal(res, "logical") }) -context("classDS::smk::NULL") +# context("classDS::smk::NULL") test_that("special classDS, NULL", { input <- NULL @@ -229,10 +230,17 @@ test_that("special classDS, NULL", { expect_equal(res, "NULL") }) +test_that("classDS throws error when object does not exist", { + expect_error( + classDS("nonexistent_object"), + regexp = "does not exist" + ) +}) + # # Done # -context("classDS::smk::shutdown") +# context("classDS::smk::shutdown") -context("classDS::smk::done") +# context("classDS::smk::done") diff --git a/tests/testthat/test-smk-colnamesDS.R b/tests/testthat/test-smk-colnamesDS.R index 2c4d3e3c..36c4ceef 100644 --- a/tests/testthat/test-smk-colnamesDS.R +++ b/tests/testthat/test-smk-colnamesDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("colnamesDS::smk::setup") +# context("colnamesDS::smk::setup") # # Tests # -context("colnamesDS::smk::data.frame") +# context("colnamesDS::smk::data.frame") test_that("simple colnamesDS, 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)) @@ -30,7 +31,7 @@ test_that("simple colnamesDS, data.frame", { expect_true("v2" %in% res) }) -context("colnamesDS::smk::data.matrix") +# context("colnamesDS::smk::data.matrix") test_that("simple colnamesDS, 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))) @@ -42,10 +43,25 @@ test_that("simple colnamesDS, data.matrix", { expect_true("v2" %in% res) }) +test_that("colnamesDS throws error when object does not exist", { + expect_error( + colnamesDS("nonexistent_object"), + regexp = "does not exist" + ) +}) + +test_that("colnamesDS throws error when object is not data.frame or matrix", { + bad_input <- list(a = 1:3, b = 4:6) + expect_error( + colnamesDS("bad_input"), + regexp = "must be of type data.frame or matrix" + ) +}) + # # Done # -context("colnamesDS::smk::shutdown") +# context("colnamesDS::smk::shutdown") -context("colnamesDS::smk::done") +# context("colnamesDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-completeCasesDS.R b/tests/testthat/test-smk-completeCasesDS.R index 68bedebf..81ca9e29 100644 --- a/tests/testthat/test-smk-completeCasesDS.R +++ b/tests/testthat/test-smk-completeCasesDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("completeCasesDS::smk::setup") +# context("completeCasesDS::smk::setup") # # Tests # -context("completeCasesDS::smk::vector") +# context("completeCasesDS::smk::vector") test_that("simple completeCasesDS, vector, with no NAs", { input <- c(1.1, 2.1, 3.1, 4.1) @@ -44,7 +45,7 @@ test_that("simple completeCasesDS, vector, with NAs", { expect_equal(res[3], 4.1) }) -context("completeCasesDS::smk::data.frame") +# context("completeCasesDS::smk::data.frame") test_that("simple completeCasesDS, data.frame, with no NAs", { 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)) @@ -93,7 +94,7 @@ test_that("simple completeCasesDS, data.frame, with NAs", { expect_equal(res.colnames[2], "v2") }) -context("completeCasesDS::smk::matrix") +# context("completeCasesDS::smk::matrix") test_that("simple completeCasesDS, matrix, with no NAs", { input <- matrix(c(0.0, 1.0, 2.0, 3.0, 4.0)) @@ -120,7 +121,7 @@ test_that("simple completeCasesDS, matrix, with NAs", { expect_equal(res[3], 4.0) }) -context("completeCasesDS::smk::data.matrix") +# context("completeCasesDS::smk::data.matrix") test_that("simple completeCasesDS, data.matrix, with no NAs", { 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))) @@ -189,10 +190,17 @@ test_that("simple completeCasesDS, data.matrix, with NAs", { expect_equal(res.colnames[2], "v2") }) +test_that("completeCasesDS throws error when object does not exist", { + expect_error( + completeCasesDS("nonexistent_object"), + regexp = "does not exist" + ) +}) + # # Done # -context("completeCasesDS::smk::shutdown") +# context("completeCasesDS::smk::shutdown") -context("completeCasesDS::smk::done") +# context("completeCasesDS::smk::done") diff --git a/tests/testthat/test-smk-corDS.R b/tests/testthat/test-smk-corDS.R index c0c4c06e..bdc3607c 100644 --- a/tests/testthat/test-smk-corDS.R +++ b/tests/testthat/test-smk-corDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("corDS::smk::setup") +# context("corDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -#context("corDS::smk::pairwise without na") +# context("corDS::smk::pairwise without na") #test_that("simple corDS, pairwise, full", { # x <- c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0) # y <- c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0) @@ -280,7 +281,7 @@ set.standard.disclosure.settings() # expect_equal(res$sums.of.squares[4], 141.06) #}) -#context("corDS::smk::pairwise with na") +# context("corDS::smk::pairwise with na") #test_that("simple corDS, pairwise, some", { # x <- c(0.0, NA, 2.0, 3.0, NA, 5.0, NA, 7.0) # y <- c(0.0, 1.0, NA, 3.0, 4.0, NA, NA, 7.0) @@ -367,7 +368,7 @@ set.standard.disclosure.settings() # expect_equal(res$sums.of.squares[4], 75.0) #}) -context("corDS::smk::casewise without na") +# context("corDS::smk::casewise without na") test_that("simple corDS, casewise, full", { x <- c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0) y <- c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0) @@ -629,7 +630,7 @@ test_that("simple corDS, casewise, some", { expect_equal(res$sums.of.squares[4], 141.06) }) -context("corDS::smk::casewise with na") +# context("corDS::smk::casewise with na") test_that("simple corDS, casewise, some", { x <- c(0.0, NA, 2.0, 3.0, NA, 5.0, NA, 7.0) y <- c(0.0, 1.0, NA, 3.0, 4.0, NA, NA, 7.0) @@ -721,6 +722,6 @@ test_that("simple corDS, casewise, some", { # Done # -context("corDS::smk::shutdown") +# context("corDS::smk::shutdown") -context("corDS::smk::done") +# context("corDS::smk::done") diff --git a/tests/testthat/test-smk-corTestDS.R b/tests/testthat/test-smk-corTestDS.R index a36e2082..b500a085 100644 --- a/tests/testthat/test-smk-corTestDS.R +++ b/tests/testthat/test-smk-corTestDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("corTestDS::smk::setup") +# context("corTestDS::smk::setup") # # Tests @@ -20,7 +21,7 @@ context("corTestDS::smk::setup") ########### -context("corTestDS::smk::without na, pearson") +# context("corTestDS::smk::without na, pearson") test_that("simple corTestDS, full, without na, pearson", { x <- c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0) y <- c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0) @@ -180,7 +181,7 @@ test_that("simple corTestDS, some, pearson, without na, pearson", { expect_equal(res$`Correlation test`$conf.int[[2]], 0.9998169, tolerance = 1e-6) }) -context("corTestDS::smk::with na, pearson") +# context("corTestDS::smk::with na, pearson") test_that("simple corTestDS, some, with na, pearson", { x <- c(NA, 1.0, 2.0, 3.0, NA, 5.0, NA, 7.0) y <- c(0.0, 1.0, NA, 3.0, 4.0, NA, NA, 7.0) @@ -229,7 +230,7 @@ test_that("simple corTestDS, some, with na, pearson", { expect_equal(res$`Correlation test`$data.name[[1]], "x.var and y.var") }) -context("corTestDS::smk::without na, kendall") +# context("corTestDS::smk::without na, kendall") test_that("simple corTestDS, full, without na, kendall", { x <- c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0) y <- c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0) @@ -253,8 +254,8 @@ test_that("simple corTestDS, full, without na, kendall", { expect_equal(class(res$`Correlation test`$p.value), "numeric") expect_length(res$`Correlation test`$p.value, 1) - expect_equal(res$`Correlation test`$p.value[[1]], 4.96e-05) - + expect_equal(res$`Correlation test`$p.value[[1]], 4.960317e-05, tolerance = 1e-6) + expect_equal(class(res$`Correlation test`$estimate), "numeric") expect_length(res$`Correlation test`$estimate, 1) expect_equal(res$`Correlation test`$estimate[[1]], 1.0) @@ -345,7 +346,7 @@ test_that("simple corTestDS, some, kendall, without na, kendall", { expect_equal(class(res$`Correlation test`$p.value), "numeric") expect_length(res$`Correlation test`$p.value, 1) - expect_equal(res$`Correlation test`$p.value[[1]], 4.96e-05) + expect_equal(res$`Correlation test`$p.value[[1]], 4.960317e-05, tolerance = 1e-6) expect_equal(class(res$`Correlation test`$estimate), "numeric") expect_length(res$`Correlation test`$estimate, 1) @@ -368,7 +369,7 @@ test_that("simple corTestDS, some, kendall, without na, kendall", { expect_equal(res$`Correlation test`$data.name[[1]], "x.var and y.var") }) -context("corTestDS::smk::with na, kendall") +# context("corTestDS::smk::with na, kendall") test_that("simple corTestDS, some, with na, kendall", { x <- c(0.0, NA, 2.0, 3.0, NA, 5.0, NA, 7.0) y <- c(0.0, 1.0, NA, 3.0, 4.0, NA, NA, 7.0) @@ -415,7 +416,7 @@ test_that("simple corTestDS, some, with na, kendall", { expect_equal(res$`Correlation test`$data.name[[1]], "x.var and y.var") }) -context("corTestDS::smk::without na, spearman") +# context("corTestDS::smk::without na, spearman") test_that("simple corTestDS, full, without na, spearman", { x <- c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0) y <- c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0) @@ -439,7 +440,7 @@ test_that("simple corTestDS, full, without na, spearman", { expect_equal(class(res$`Correlation test`$p.value), "numeric") expect_length(res$`Correlation test`$p.value, 1) - expect_equal(res$`Correlation test`$p.value[[1]], 4.96e-05) + expect_equal(res$`Correlation test`$p.value[[1]], 4.960317e-05, tolerance = 1e-6) expect_equal(class(res$`Correlation test`$estimate), "numeric") expect_length(res$`Correlation test`$estimate, 1) @@ -485,7 +486,7 @@ test_that("simple corTestDS, neg. full, without na, spearman", { expect_equal(class(res$`Correlation test`$p.value), "numeric") expect_length(res$`Correlation test`$p.value, 1) - expect_equal(res$`Correlation test`$p.value[[1]], 4.96e-05) + expect_equal(res$`Correlation test`$p.value[[1]], 4.960317e-05, tolerance = 1e-6) expect_equal(class(res$`Correlation test`$estimate), "numeric") expect_length(res$`Correlation test`$estimate, 1) @@ -531,11 +532,11 @@ test_that("simple corTestDS, some, spearman, without na, spearman", { expect_equal(class(res$`Correlation test`$p.value), "numeric") expect_length(res$`Correlation test`$p.value, 1) - expect_equal(res$`Correlation test`$p.value[[1]], 4.96e-05) + expect_equal(res$`Correlation test`$p.value[[1]], 4.960317e-05, tolerance = 1e-6) expect_equal(class(res$`Correlation test`$estimate), "numeric") expect_length(res$`Correlation test`$estimate, 1) - expect_equal(res$`Correlation test`$estimate[[1]], 1.0) + expect_equal(res$`Correlation test`$estimate[[1]], 1.0, tolerance = 1e-6) expect_equal(class(res$`Correlation test`$null.value), "numeric") expect_length(res$`Correlation test`$null.value, 1) @@ -554,7 +555,7 @@ test_that("simple corTestDS, some, spearman, without na, spearman", { expect_equal(res$`Correlation test`$data.name[[1]], "x.var and y.var") }) -context("corTestDS::smk::with na, spearman") +# context("corTestDS::smk::with na, spearman") test_that("simple corTestDS, some, with na, spearman", { x <- c(0.0, NA, 2.0, 3.0, NA, 5.0, NA, 7.0) y <- c(0.0, 1.0, NA, 3.0, 4.0, NA, NA, 7.0) @@ -605,7 +606,7 @@ test_that("simple corTestDS, some, with na, spearman", { # Done # -context("corTestDS::smk::shutdown") +# context("corTestDS::smk::shutdown") -context("corTestDS::smk::done") +# context("corTestDS::smk::done") diff --git a/tests/testthat/test-smk-covDS.R b/tests/testthat/test-smk-covDS.R index da05102c..ce731938 100644 --- a/tests/testthat/test-smk-covDS.R +++ b/tests/testthat/test-smk-covDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("covDS::smk::setup") +# context("covDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("covDS::smk::casewise.complete") +# context("covDS::smk::casewise.complete") test_that("numeric covDS, casewise.complete", { input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0), v2 = c(7.0, 6.0, 5.0, 4.0, 3.0, 2.0, 1.0, 0.0)) @@ -123,7 +124,7 @@ test_that("numeric covDS, casewise.complete", { expect_true(is.na(res$errorMessage)) }) -context("covDS::smk::pairwise.complete") +# context("covDS::smk::pairwise.complete") test_that("numeric covDS, pairwise.complete", { input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0), v2 = c(7.0, 6.0, 5.0, 4.0, 3.0, 2.0, 1.0, 0.0)) @@ -235,6 +236,6 @@ test_that("numeric covDS, pairwise.complete", { # Done # -context("covDS::smk::shutdown") +# context("covDS::smk::shutdown") -context("covDS::smk::done") +# context("covDS::smk::done") diff --git a/tests/testthat/test-smk-dataFrameDS.R b/tests/testthat/test-smk-dataFrameDS.R index af6ff6d5..18fc3b4b 100644 --- a/tests/testthat/test-smk-dataFrameDS.R +++ b/tests/testthat/test-smk-dataFrameDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("dataFrameDS::smk::setup") +# context("dataFrameDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("dataFrameDS::smk") +# 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) @@ -81,10 +82,10 @@ test_that("simple dataFrameDS, strAsFactors is TRUE", { # Stutdown # -context("dataFrameDS::smk::shutdown") +# context("dataFrameDS::smk::shutdown") # # Done # -context("dataFrameDS::smk::done") +# context("dataFrameDS::smk::done") diff --git a/tests/testthat/test-smk-dataFrameFillDS.R b/tests/testthat/test-smk-dataFrameFillDS.R index 5cc880f7..8da7a882 100644 --- a/tests/testthat/test-smk-dataFrameFillDS.R +++ b/tests/testthat/test-smk-dataFrameFillDS.R @@ -1,6 +1,6 @@ - #------------------------------------------------------------------------------- # 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. @@ -13,13 +13,13 @@ # Set up # -context("dataFrameFillDS::smk::setup") +# context("dataFrameFillDS::smk::setup") # # Tests # -context("dataFrameFillDS::smk") +# context("dataFrameFillDS::smk") test_that("simple dataFrameFillDS, ascending, numeric", { df <- data.frame(v1 = c(-2.0, -3.0, 4.0, 2.0, 1.0, 0.0, -1.0, 3.0), v2 = c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0)) allNames.transmit <- "v1,v2,v3,v4,v5,v6,v7" @@ -94,10 +94,10 @@ test_that("simple dataFrameFillDS, ascending, numeric", { # Shutdown # -context("dataFrameFillDS::smk::shutdown") +# context("dataFrameFillDS::smk::shutdown") # # Done # -context("dataFrameFillDS::smk::done") +# context("dataFrameFillDS::smk::done") diff --git a/tests/testthat/test-smk-dataFrameSortDS.R b/tests/testthat/test-smk-dataFrameSortDS.R index b81965e0..39a7378b 100644 --- a/tests/testthat/test-smk-dataFrameSortDS.R +++ b/tests/testthat/test-smk-dataFrameSortDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("dataFrameSortDS::smk::setup") +# context("dataFrameSortDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("dataFrameSortDS::smk::numeric input") +# context("dataFrameSortDS::smk::numeric input") test_that("simple dataFrameSortDS, ascending, default", { df <- data.frame(v1 = c(-2.0, -3.0, 4.0, 2.0, 1.0, 0.0, -1.0, 3.0), v2 = c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0)) sort.key.name <- "df$v1" @@ -243,7 +244,7 @@ test_that("simple dataFrameSortDS, descending, alphabetic", { expect_equal(res$v2[8], 6.0) }) -context("dataFrameSortDS::smk::string input") +# context("dataFrameSortDS::smk::string input") test_that("simple dataFrameSortDS, ascending, default", { df <- data.frame(v1 = c("-2.0", "-3.0", "4.0", "2.0", "1.0", "0.0", "-1.0", "3.0"), v2 = c("0.0", "1.0", "2.0", "3.0", "4.0", "5.0", "6.0", "7.0"), stringsAsFactors = FALSE) sort.key.name <- "df$v1" @@ -471,6 +472,6 @@ test_that("simple dataFrameSortDS, descending, alphabetic", { # Done # -context("dataFrameSortDS::smk::shutdown") +# context("dataFrameSortDS::smk::shutdown") -context("dataFrameSortDS::smk::done") +# context("dataFrameSortDS::smk::done") diff --git a/tests/testthat/test-smk-dataFrameSubsetDS1.R b/tests/testthat/test-smk-dataFrameSubsetDS1.R index 93dbca26..c519cefa 100644 --- a/tests/testthat/test-smk-dataFrameSubsetDS1.R +++ b/tests/testthat/test-smk-dataFrameSubsetDS1.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("gamlssDS::smk::setup") +# context("gamlssDS::smk::setup") set.standard.disclosure.settings() @@ -21,7 +22,7 @@ set.standard.disclosure.settings() # Tests # -context("dataFrameSubsetDS1::smk::test1") +# context("dataFrameSubsetDS1::smk::test1") test_that("test1 dataFrameSubsetDS1", { D <- as.data.frame(matrix(NA, nrow=20, ncol=3)) @@ -42,7 +43,7 @@ test_that("test1 dataFrameSubsetDS1", { }) -context("dataFrameSubsetDS1::smk::test2") +# context("dataFrameSubsetDS1::smk::test2") test_that("test2 dataFrameSubsetDS1", { D <- as.data.frame(matrix(NA, nrow=20, ncol=3)) @@ -77,6 +78,6 @@ test_that("test2 dataFrameSubsetDS1", { # Done # -context("dataFrameSubsetDS1::smk::shutdown") +# context("dataFrameSubsetDS1::smk::shutdown") -context("dataFrameSubsetDS1::smk::done") +# context("dataFrameSubsetDS1::smk::done") diff --git a/tests/testthat/test-smk-dataFrameSubsetDS2.R b/tests/testthat/test-smk-dataFrameSubsetDS2.R index 619da16c..c93dc595 100644 --- a/tests/testthat/test-smk-dataFrameSubsetDS2.R +++ b/tests/testthat/test-smk-dataFrameSubsetDS2.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("gamlssDS::smk::setup") +# contect("gamlssDS::smk::setup") set.standard.disclosure.settings() @@ -21,7 +22,7 @@ set.standard.disclosure.settings() # Tests # -context("dataFrameSubsetDS2::smk::test1") +# contect("dataFrameSubsetDS2::smk::test1") test_that("test1 dataFrameSubsetDS2", { D <- as.data.frame(matrix(NA, nrow=20, ncol=3)) @@ -47,7 +48,7 @@ test_that("test1 dataFrameSubsetDS2", { }) -context("dataFrameSubsetDS2::smk::test2") +# contect("dataFrameSubsetDS2::smk::test2") test_that("test2 dataFrameSubsetDS2", { D <- as.data.frame(matrix(NA, nrow=20, ncol=3)) @@ -74,6 +75,6 @@ test_that("test2 dataFrameSubsetDS2", { # Done # -context("dataFrameSubsetDS2::smk::shutdown") +# contect("dataFrameSubsetDS2::smk::shutdown") -context("dataFrameSubsetDS2::smk::done") +# contect("dataFrameSubsetDS2::smk::done") diff --git a/tests/testthat/test-smk-densityGridDS.R b/tests/testthat/test-smk-densityGridDS.R index 612386bb..2c075a4b 100644 --- a/tests/testthat/test-smk-densityGridDS.R +++ b/tests/testthat/test-smk-densityGridDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("densityGridDS::smk::setup") +# context("densityGridDS::smk::setup") set.standard.disclosure.settings() @@ -21,7 +22,7 @@ set.standard.disclosure.settings() # Tests # -context("densityGridDS::smk") +# context("densityGridDS::smk") test_that("densityGridDS", { xvect <- c(11.95, 10.06, 9.98, 9.50, 12.26, 9.66, 11.08, 12.29, 11.00, 9.91, @@ -53,6 +54,6 @@ test_that("densityGridDS", { # Done # -context("densityGridDS::smk::shutdown") +# context("densityGridDS::smk::shutdown") -context("densityGridDS::smk::done") +# context("densityGridDS::smk::done") diff --git a/tests/testthat/test-smk-dimDS.R b/tests/testthat/test-smk-dimDS.R index 5dbdb6de..c45d07fb 100644 --- a/tests/testthat/test-smk-dimDS.R +++ b/tests/testthat/test-smk-dimDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,40 +13,65 @@ # Set up # -context("dimDS::smk::setup") +# context("dimDS::smk::setup") # # Tests # -context("dimDS::smk::numeric") +# context("dimDS::smk::numeric") test_that("numeric dimDS", { 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 <- dimDS("input") - expect_length(res, 2) - expect_equal(class(res), "integer") - expect_equal(res[1], 5) - expect_equal(res[2], 2) + expect_equal(class(res), "list") + expect_equal(res$dim[1], 5) + expect_equal(res$dim[2], 2) + expect_equal(res$class, "data.frame") }) -context("dimDS::smk::character") +# context("dimDS::smk::character") test_that("character dimDS", { 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"), stringsAsFactors = FALSE) res <- dimDS("input") - expect_length(res, 2) - expect_equal(class(res), "integer") - expect_equal(res[1], 5) - expect_equal(res[2], 2) + expect_equal(class(res), "list") + expect_equal(res$dim[1], 5) + expect_equal(res$dim[2], 2) + expect_equal(res$class, "data.frame") +}) + +test_that("dimDS with matrix", { + input <- matrix(1:6, nrow = 2, ncol = 3) + + res <- dimDS("input") + + expect_equal(res$dim[1], 2) + expect_equal(res$dim[2], 3) + expect_true("matrix" %in% res$class) +}) + +test_that("dimDS throws error when object does not exist", { + expect_error( + dimDS("nonexistent_object"), + regexp = "does not exist" + ) +}) + +test_that("dimDS throws error when object is not data.frame or matrix", { + bad_input <- c(1, 2, 3) + expect_error( + dimDS("bad_input"), + regexp = "must be of type data.frame or matrix" + ) }) # # Done # -context("dimDS::smk::shutdown") +# context("dimDS::smk::shutdown") -context("dimDS::smk::done") +# context("dimDS::smk::done") diff --git a/tests/testthat/test-smk-expDS.R b/tests/testthat/test-smk-expDS.R new file mode 100644 index 00000000..4c359470 --- /dev/null +++ b/tests/testthat/test-smk-expDS.R @@ -0,0 +1,46 @@ +#------------------------------------------------------------------------------- +# 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("expDS::smk::setup") + +# +# Tests +# + +# context("expDS::smk::numeric") +test_that("expDS computes exponential for numeric vector", { + input <- c(0.0, 1.0, 2.0, -1.0) + + res <- expDS("input") + + expect_equal(res, exp(input)) + expect_true(is.numeric(res)) +}) + +# context("expDS::smk::integer") +test_that("expDS computes exponential for integer vector", { + input <- as.integer(c(0, 1, 2, 3)) + + res <- expDS("input") + + expect_equal(res, exp(input)) +}) +# +# Done +# + +# context("expDS::smk::shutdown") + +# context("expDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-extract.R b/tests/testthat/test-smk-extract.R index bd471a67..9b1af851 100644 --- a/tests/testthat/test-smk-extract.R +++ b/tests/testthat/test-smk-extract.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("extract::smk::setup") +# context("extract::smk::setup") # # Tests # -context("extract::smk::simple") +# context("extract::smk::simple") test_that("simple extract no holder", { input <- "variable" @@ -45,7 +46,7 @@ test_that("simple extract", { expect_equal(res$elements, "variable") }) -context("extract::smk::simple vector") +# context("extract::smk::simple vector") test_that("simple extract no holder, vector", { input <- c("v1", "v2", "v3", "v4") @@ -107,6 +108,6 @@ test_that("simple extract, mixed, vector", { # Done # -context("extract::smk::shutdown") +# context("extract::smk::shutdown") -context("extract::smk::done") +# context("extract::smk::done") diff --git a/tests/testthat/test-smk-gamlssDS.R b/tests/testthat/test-smk-gamlssDS.R index 636e0f26..de284148 100644 --- a/tests/testthat/test-smk-gamlssDS.R +++ b/tests/testthat/test-smk-gamlssDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("gamlssDS::smk::setup") +# context("gamlssDS::smk::setup") set.standard.disclosure.settings() @@ -21,7 +22,7 @@ set.standard.disclosure.settings() # Tests # -context("gamlssDS::smk::birthweight") +# context("gamlssDS::smk::birthweight") test_that("birthweight gamlssDS", { D <- as.data.frame(matrix(NA, nrow=20, ncol=2)) @@ -88,6 +89,6 @@ test_that("birthweight gamlssDS", { # Done # -context("gamlssDS::smk::shutdown") +# context("gamlssDS::smk::shutdown") -context("gamlssDS::smk::done") +# context("gamlssDS::smk::done") diff --git a/tests/testthat/test-smk-getWGSRDS.R b/tests/testthat/test-smk-getWGSRDS.R index 0036fcdf..73d0eda1 100644 --- a/tests/testthat/test-smk-getWGSRDS.R +++ b/tests/testthat/test-smk-getWGSRDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("getWGSRDS::smk::setup") +# context("getWGSRDS::smk::setup") # # Tests # -context("getWGSRDS::smk::simple") +# context("getWGSRDS::smk::simple") data <- data.frame( age = c(6.0, 42.0, 23.0, 18.0, 52.0, 36.0, 30.0, NA, 29.0, 54.0), @@ -152,6 +153,6 @@ test_that("simple getWGSRDS - mfa", { # Done # -context("getWGSRDS::smk::shutdown") +# context("getWGSRDS::smk::shutdown") -context("getWGSRDS::smk::done") +# context("getWGSRDS::smk::done") diff --git a/tests/testthat/test-smk-hetcorDS.R b/tests/testthat/test-smk-hetcorDS.R index f78d14cc..fd5ca14e 100644 --- a/tests/testthat/test-smk-hetcorDS.R +++ b/tests/testthat/test-smk-hetcorDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("hetcorDS::smk::setup") +# context("hetcorDS::smk::setup") set.standard.disclosure.settings() @@ -21,7 +22,7 @@ set.standard.disclosure.settings() # Tests # -context("hetcorDS::smk") +# context("hetcorDS::smk") test_that("hetcorDS", { D <- as.data.frame(matrix(NA, nrow=20, ncol=3)) @@ -86,6 +87,6 @@ test_that("hetcorDS", { # Done # -context("hetcorDS::smk::shutdown") +# context("hetcorDS::smk::shutdown") -context("hetcorDS::smk::done") \ No newline at end of file +# context("hetcorDS::smk::done") diff --git a/tests/testthat/test-smk-igb_standardsDS.R b/tests/testthat/test-smk-igb_standardsDS.R index 114c88d9..bd3a8f79 100644 --- a/tests/testthat/test-smk-igb_standardsDS.R +++ b/tests/testthat/test-smk-igb_standardsDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("igb_standardsDS::smk::setup") +# context("igb_standardsDS::smk::setup") # # Tests # -context("igb_standardsDS::smk::simple") +# context("igb_standardsDS::smk::simple") data <- data.frame( gagebrth = c(287, 287, 287, 280, 280, 280, 280, 266, 266, 259, @@ -157,6 +158,6 @@ test_that("igb_standardsDS - igb_centile2value", { # Done # -context("igb_standardsDS::smk::shutdown") +# context("igb_standardsDS::smk::shutdown") -context("igb_standardsDS::smk::done") +# context("igb_standardsDS::smk::done") diff --git a/tests/testthat/test-smk-isNaDS.R b/tests/testthat/test-smk-isNaDS.R index e5922d27..33012766 100644 --- a/tests/testthat/test-smk-isNaDS.R +++ b/tests/testthat/test-smk-isNaDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,78 +13,85 @@ # Set up # -context("isNaDS::smk::setup") +# context("isNaDS::smk::setup") # # Tests # -context("isNaDS::smk::numeric vector") +# context("isNaDS::smk::numeric vector") test_that("numeric vector isNaDS", { input <- c(0.1, 1.1, 2.1, 3.1, 4.1) - res <- isNaDS(input) + res <- isNaDS("input") - expect_length(res, 1) - expect_equal(class(res), "logical") - expect_equal(res, FALSE) + expect_length(res$is.na, 1) + expect_equal(class(res$is.na), "logical") + expect_equal(res$is.na, FALSE) }) test_that("numeric vector isNaDS - with NA single", { input <- c(0.1, NA, 2.1, 3.1, 4.1) - res <- isNaDS(input) + res <- isNaDS("input") - expect_length(res, 1) - expect_equal(class(res), "logical") - expect_equal(res, FALSE) + expect_length(res$is.na, 1) + expect_equal(class(res$is.na), "logical") + expect_equal(res$is.na, FALSE) }) test_that("numeric vector isNaDS - with NA all", { input <- c(NA, NA, NA, NA, NA) - res <- isNaDS(input) + res <- isNaDS("input") - expect_length(res, 1) - expect_equal(class(res), "logical") - expect_equal(res, TRUE) + expect_length(res$is.na, 1) + expect_equal(class(res$is.na), "logical") + expect_equal(res$is.na, TRUE) }) -context("isNaDS::smk::character vector") +# context("isNaDS::smk::character vector") test_that("character vector isNaDS", { input <- c("101", "202", "303", "404", "505") - res <- isNaDS(input) + res <- isNaDS("input") - expect_length(res, 1) - expect_equal(class(res), "logical") - expect_equal(res, FALSE) + expect_length(res$is.na, 1) + expect_equal(class(res$is.na), "logical") + expect_equal(res$is.na, FALSE) }) test_that("character vector isNaDS - with NA single", { input <- c("101", NA, "303", "404", "505") - res <- isNaDS(input) + res <- isNaDS("input") - expect_length(res, 1) - expect_equal(class(res), "logical") - expect_equal(res, FALSE) + expect_length(res$is.na, 1) + expect_equal(class(res$is.na), "logical") + expect_equal(res$is.na, FALSE) }) test_that("character vector isNaDS - with NA all", { input <- c(NA, NA, NA, NA, NA) - res <- isNaDS(input) + res <- isNaDS("input") - expect_length(res, 1) - expect_equal(class(res), "logical") - expect_equal(res, TRUE) + expect_length(res$is.na, 1) + expect_equal(class(res$is.na), "logical") + expect_equal(res$is.na, TRUE) +}) + +test_that("isNaDS throws error when object does not exist", { + expect_error( + isNaDS("nonexistent_object"), + regexp = "does not exist" + ) }) # # Done # -context("isNaDS::smk::shutdown") +# context("isNaDS::smk::shutdown") -context("isNaDS::smk::done") +# context("isNaDS::smk::done") diff --git a/tests/testthat/test-smk-isValidDS.R b/tests/testthat/test-smk-isValidDS.R index c2d3af51..81fc5ade 100644 --- a/tests/testthat/test-smk-isValidDS.R +++ b/tests/testthat/test-smk-isValidDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("isValidDS::smk::setup") +# context("isValidDS::smk::setup") # # Tests # -context("isValidDS::smk::character") +# context("isValidDS::smk::character") test_that("simple isValidDS, character", { input <- "value" @@ -39,7 +40,7 @@ test_that("simple isValidDS, character vector", { expect_equal(res, TRUE) }) -context("isValidDS::smk::integer") +# context("isValidDS::smk::integer") test_that("simple isValidDS, integer", { input <- 1L @@ -60,7 +61,7 @@ test_that("simple isValidDS, integer vector", { expect_equal(res, TRUE) }) -context("isValidDS::smk::numeric") +# context("isValidDS::smk::numeric") test_that("simple isValidDS, numeric", { input <- 1.1 @@ -81,7 +82,7 @@ test_that("simple isValidDS, numeric vector", { expect_equal(res, TRUE) }) -context("isValidDS::smk::logical") +# context("isValidDS::smk::logical") test_that("simple isValidDS, logical, FALSE", { input <- FALSE @@ -142,7 +143,7 @@ test_that("simple isValidDS, factor vector", { expect_equal(res, FALSE) }) -context("isValidDS::smk::data.frame") +# 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)) @@ -153,7 +154,7 @@ test_that("simple isValidDS, data.frame", { expect_equal(res, TRUE) }) -context("isValidDS::smk::array") +# context("isValidDS::smk::array") test_that("simple isValidDS, array", { input <- array(c(0.0, 1.0, 2.0, 3.0, 4.0)) @@ -164,7 +165,7 @@ test_that("simple isValidDS, array", { expect_equal(res, FALSE) }) -context("isValidDS::smk::matrix") +# context("isValidDS::smk::matrix") test_that("simple isValidDS, matrix", { input <- matrix(c(0.0, 1.0, 2.0, 3.0, 4.0)) @@ -175,7 +176,7 @@ test_that("simple isValidDS, matrix", { expect_equal(res, TRUE) }) -context("isValidDS::smk::data.matrix") +# 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))) @@ -186,7 +187,7 @@ test_that("simple isValidDS, data.matrix", { expect_equal(res, TRUE) }) -context("isValidDS::smk::date") +# context("isValidDS::smk::date") test_that("simple isValidDS, date", { input <- Sys.Date() @@ -197,7 +198,7 @@ test_that("simple isValidDS, date", { expect_equal(res, FALSE) }) -context("isValidDS::smk::formula") +# context("isValidDS::smk::formula") test_that("simple isValidDS, formula", { input <- X ~ A + B @@ -208,7 +209,7 @@ test_that("simple isValidDS, formula", { expect_equal(res, FALSE) }) -context("isValidDS::smk::environment") +# context("isValidDS::smk::environment") test_that("simple isValidDS, environment", { input <- environment() @@ -219,7 +220,7 @@ test_that("simple isValidDS, environment", { expect_equal(res, FALSE) }) -context("isValidDS::smk::NA") +# context("isValidDS::smk::NA") test_that("special isValidDS, NA", { input <- NA @@ -230,7 +231,7 @@ test_that("special isValidDS, NA", { expect_equal(res, FALSE) }) -context("isValidDS::smk::NULL") +# context("isValidDS::smk::NULL") test_that("special isValidDS, NULL", { input <- NULL @@ -245,6 +246,6 @@ test_that("special isValidDS, NULL", { # Done # -context("isValidDS::smk::shutdown") +# context("isValidDS::smk::shutdown") -context("isValidDS::smk::done") +# context("isValidDS::smk::done") diff --git a/tests/testthat/test-smk-kurtosisDS1.R b/tests/testthat/test-smk-kurtosisDS1.R index 62f10307..fe939107 100644 --- a/tests/testthat/test-smk-kurtosisDS1.R +++ b/tests/testthat/test-smk-kurtosisDS1.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("kurtosisDS1::smk::setup") +# context("kurtosisDS1::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("kurtosisDS1::smk::method 1") +# context("kurtosisDS1::smk::method 1") test_that("simple kurtosisDS1, method 1", { input <- c(0.0, 1.0, 1.0, 1.0, 2.0, 2.0, 2.0, 3.0, 4.0) @@ -36,7 +37,7 @@ test_that("simple kurtosisDS1, method 1", { expect_equal(res$ValidityMessage, "VALID ANALYSIS") }) -context("kurtosisDS1::smk::method 2") +# context("kurtosisDS1::smk::method 2") test_that("simple kurtosisDS1, method 2", { input <- c(0.0, 1.0, 1.0, 1.0, 2.0, 2.0, 2.0, 3.0, 4.0) @@ -52,7 +53,7 @@ test_that("simple kurtosisDS1, method 2", { expect_equal(res$ValidityMessage, "VALID ANALYSIS") }) -context("kurtosisDS1::smk::method 3") +# context("kurtosisDS1::smk::method 3") test_that("simple kurtosisDS1, method 3", { input <- c(0.0, 1.0, 1.0, 1.0, 2.0, 2.0, 2.0, 3.0, 4.0) @@ -72,6 +73,6 @@ test_that("simple kurtosisDS1, method 3", { # Done # -context("kurtosisDS1::smk::shutdown") +# context("kurtosisDS1::smk::shutdown") -context("kurtosisDS1::smk::done") +# context("kurtosisDS1::smk::done") diff --git a/tests/testthat/test-smk-kurtosisDS2.R b/tests/testthat/test-smk-kurtosisDS2.R index 24833388..8f122a6e 100644 --- a/tests/testthat/test-smk-kurtosisDS2.R +++ b/tests/testthat/test-smk-kurtosisDS2.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("kurtosisDS2::smk::setup") +# context("kurtosisDS2::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("kurtosisDS2::smk") +# context("kurtosisDS2::smk") test_that("simple kurtosisDS2", { input <- c(1.0, 2.0, 2.0, 3.0, 3.0) global.mean <- 2.5 @@ -43,6 +44,6 @@ test_that("simple kurtosisDS2", { # Done # -context("kurtosisDS2::smk::shutdown") +# context("kurtosisDS2::smk::shutdown") -context("kurtosisDS2::smk::done") +# context("kurtosisDS2::smk::done") diff --git a/tests/testthat/test-smk-lengthDS.R b/tests/testthat/test-smk-lengthDS.R index d7cd2bda..d91fafd9 100644 --- a/tests/testthat/test-smk-lengthDS.R +++ b/tests/testthat/test-smk-lengthDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,20 +13,57 @@ # Set up # -context("lengthDS::smk::setup") +# context("lengthDS::smk::setup") # # Tests # -context("lengthDS::smk::data.frame") +# context("lengthDS::smk::vector") +test_that("simple lengthDS, numeric vector", { + input <- c(0.0, 1.0, 2.0, 3.0, 4.0) + + res <- lengthDS("input") + + expect_equal(class(res), "list") + expect_equal(res$length, 5) + expect_equal(res$class, "numeric") +}) + +test_that("simple lengthDS, character vector", { + input <- c("0.0", "1.0", "2.0", "3.0", "4.0") + + res <- lengthDS("input") + + expect_equal(class(res), "list") + expect_equal(res$length, 5) + expect_equal(res$class, "character") +}) + +test_that("simple lengthDS, list", { + input <- list(a = 1, b = 2, c = 3) + + res <- lengthDS("input") + + expect_equal(res$length, 3) + expect_equal(res$class, "list") +}) + +test_that("lengthDS throws error when object does not exist", { + expect_error( + lengthDS("nonexistent_object"), + regexp = "does not exist" + ) +}) + test_that("simple lengthDS, numeric 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 <- lengthDS("input") - expect_equal(class(res), "integer") - expect_equal(res, 2) + expect_equal(class(res), "list") + expect_equal(res$length, 2) + expect_equal(res$class, "data.frame") }) test_that("simple lengthDS, character data.frame", { @@ -33,33 +71,35 @@ test_that("simple lengthDS, character data.frame", { res <- lengthDS("input") - expect_equal(class(res), "integer") - expect_equal(res, 2) + expect_equal(class(res), "list") + expect_equal(res$length, 2) + expect_equal(res$class, "data.frame") }) -context("lengthDS::smk::vector") -test_that("simple lengthDS, numeric vector", { - input <- c(0.0, 1.0, 2.0, 3.0, 4.0) +test_that("simple lengthDS, matrix", { + input <- matrix(1:6, nrow = 2, ncol = 3) res <- lengthDS("input") - expect_equal(class(res), "integer") - expect_equal(res, 5) + expect_equal(class(res), "list") + expect_equal(res$length, 6) + expect_equal(res$class, c("matrix", "array")) }) -test_that("simple lengthDS, character vector", { - input <- c("0.0", "1.0", "2.0", "3.0", "4.0") +test_that("simple lengthDS, array", { + input <- array(1:24, dim = c(2, 3, 4)) res <- lengthDS("input") - expect_equal(class(res), "integer") - expect_equal(res, 5) + expect_equal(class(res), "list") + expect_equal(res$length, 24) + expect_equal(res$class, "array") }) # # Done # -context("lengthDS::smk::shutdown") +# context("lengthDS::smk::shutdown") -context("lengthDS::smk::done") +# context("lengthDS::smk::done") diff --git a/tests/testthat/test-smk-levelsDS.R b/tests/testthat/test-smk-levelsDS.R index e1b93daa..43fd7658 100644 --- a/tests/testthat/test-smk-levelsDS.R +++ b/tests/testthat/test-smk-levelsDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("levelsDS::smk::setup") +# context("levelsDS::smk::setup") set.standard.disclosure.settings() @@ -20,13 +21,13 @@ set.standard.disclosure.settings() # Tests # -context("levelsDS::smk::numeric vector") +# context("levelsDS::smk::numeric vector") test_that("numeric vector levelsDS", { input <- as.factor(c(0, 1, 2, 1, 2, 3, 1, 2, 1, 0, 1, 2, 0)) - res <- levelsDS(input) + res <- levelsDS("input") - expect_length(res, 2) + expect_length(res, 1) expect_equal(class(res), "list") expect_equal(class(res$Levels), "character") expect_length(res$Levels, 4) @@ -34,14 +35,36 @@ test_that("numeric vector levelsDS", { expect_equal(res$Levels[2], "1") expect_equal(res$Levels[3], "2") expect_equal(res$Levels[4], "3") - expect_equal(class(res$ValidityMessage), "character") - expect_equal(res$ValidityMessage, "VALID ANALYSIS") +}) + +test_that("levelsDS throws error when object does not exist", { + expect_error( + levelsDS("nonexistent_object"), + regexp = "does not exist" + ) +}) + +test_that("levelsDS throws error when object is not a factor", { + bad_input <- c(1, 2, 3) + expect_error( + levelsDS("bad_input"), + regexp = "must be of type factor" + ) +}) + +test_that("levelsDS blocks when levels density exceeds threshold", { + input <- factor(1:10, levels = 1:10) + + expect_error( + levelsDS("input"), + regexp = "nfilter.levels.density" + ) }) # # Done # -context("levelsDS::smk::shutdown") +# context("levelsDS::smk::shutdown") -context("levelsDS::smk::done") +# context("levelsDS::smk::done") diff --git a/tests/testthat/test-smk-listDS.R b/tests/testthat/test-smk-listDS.R index f1e12e94..dfd0a171 100644 --- a/tests/testthat/test-smk-listDS.R +++ b/tests/testthat/test-smk-listDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("listDS::smk::setup") +# context("listDS::smk::setup") # # Tests # -context("listDS::smk::simple") +# context("listDS::smk::simple") test_that("simple listDS", { input <- list(v1 = c(1, 2, 3), v2 = c(4, 5, 6)) eltnames <- c('n1', 'n2') @@ -42,6 +43,6 @@ test_that("simple listDS", { # Done # -context("listDS::smk::shutdown") +# context("listDS::smk::shutdown") -context("listDS::smk::done") +# context("listDS::smk::done") diff --git a/tests/testthat/test-smk-listDisclosureSettingsDS.R b/tests/testthat/test-smk-listDisclosureSettingsDS.R index 4ee63cf0..b680b3b3 100644 --- a/tests/testthat/test-smk-listDisclosureSettingsDS.R +++ b/tests/testthat/test-smk-listDisclosureSettingsDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("listDisclosureSettingsDS::smk::setup") +# context("listDisclosureSettingsDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("listDisclosureSettingsDS::smk") +# context("listDisclosureSettingsDS::smk") test_that("simple listDisclosureSettingsDS", { res <- listDisclosureSettingsDS() @@ -70,6 +71,6 @@ test_that("simple listDisclosureSettingsDS", { # Done # -context("listDisclosureSettingsDS::smk::shutdown") +# context("listDisclosureSettingsDS::smk::shutdown") -context("listDisclosureSettingsDS::smk::done") +# context("listDisclosureSettingsDS::smk::done") diff --git a/tests/testthat/test-smk-logDS.R b/tests/testthat/test-smk-logDS.R new file mode 100644 index 00000000..d56ea1c9 --- /dev/null +++ b/tests/testthat/test-smk-logDS.R @@ -0,0 +1,54 @@ +#------------------------------------------------------------------------------- +# 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("logDS::smk::setup") + +# +# Tests +# + +# context("logDS::smk::numeric") +test_that("logDS computes natural log for numeric vector", { + input <- c(1.0, exp(1), exp(2)) + + res <- logDS("input") + + expect_equal(res, log(input)) + expect_true(is.numeric(res)) +}) + +test_that("logDS computes log with custom base", { + input <- c(1.0, 10.0, 100.0) + + res <- logDS("input", base = 10) + + expect_equal(res, log(input, base = 10)) +}) + +# context("logDS::smk::integer") +test_that("logDS computes log for integer vector", { + input <- as.integer(c(1, 2, 3, 4)) + + res <- logDS("input") + + expect_equal(res, log(input)) +}) +# +# Done +# + +# context("logDS::smk::shutdown") + +# context("logDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-lsDS.R b/tests/testthat/test-smk-lsDS.R index 077ee9fe..b96eb0ec 100644 --- a/tests/testthat/test-smk-lsDS.R +++ b/tests/testthat/test-smk-lsDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("lsDS::smk::setup") +# context("lsDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("lsDS::smk::simple") +# context("lsDS::smk::simple") test_that("simple lsDS", { .GlobalEnv$test.obj <- "value" @@ -36,7 +37,7 @@ test_that("simple lsDS", { expect_true("test.obj" %in% res$objects.found) }) -context("lsDS::smk::simple") +# context("lsDS::smk::simple") test_that("simple lsDS", { .GlobalEnv$test.obj <- "value" @@ -58,6 +59,6 @@ test_that("simple lsDS", { # Done # -context("lsDS::smk::shutdown") +# context("lsDS::smk::shutdown") -context("lsDS::smk::done") +# context("lsDS::smk::done") diff --git a/tests/testthat/test-smk-meanDS.R b/tests/testthat/test-smk-meanDS.R index befc82ba..e6d81a73 100644 --- a/tests/testthat/test-smk-meanDS.R +++ b/tests/testthat/test-smk-meanDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("meanDS::smk::setup") +# context("meanDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("meanDS::smk::numeric") +# context("meanDS::smk::numeric") test_that("numeric meanDS", { input <- c(0.0, 1.0, 2.0, 3.0, 4.0) @@ -40,7 +41,7 @@ test_that("numeric meanDS", { expect_equal(res$ValidityMessage, "VALID ANALYSIS") }) -context("meanDS::smk::numeric with NA") +# context("meanDS::smk::numeric with NA") test_that("numeric meanDS, with NA", { input <- c(0.0, NA, 2.0, NA, 4.0) @@ -60,7 +61,7 @@ test_that("numeric meanDS, with NA", { expect_equal(res$ValidityMessage, "VALID ANALYSIS") }) -context("meanDS::smk::numeric with all NA") +# context("meanDS::smk::numeric with all NA") test_that("numeric meanDS, with all NA", { input <- c(NA, NA, NA, NA, NA) @@ -84,6 +85,6 @@ test_that("numeric meanDS, with all NA", { # Done # -context("meanDS::smk::shutdown") +# context("meanDS::smk::shutdown") -context("meanDS::smk::done") +# context("meanDS::smk::done") diff --git a/tests/testthat/test-smk-messageDS.R b/tests/testthat/test-smk-messageDS.R index 871d2747..91ec685b 100644 --- a/tests/testthat/test-smk-messageDS.R +++ b/tests/testthat/test-smk-messageDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("messageDS::smk::setup") +# context("messageDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("messageDS::smk") +# context("messageDS::smk") test_that("simple messageDS", { expect_warning(base::rm("object"), "object 'object' not found", fixed = TRUE) @@ -28,7 +29,7 @@ test_that("simple messageDS", { expect_equal(class(res), "character") expect_length(res, 1) - expect_equal(res, "Error: the object does not exist in this datasource", fixed = TRUE) + expect_equal(res, "Error: the object does not exist in this datasource") }) test_that("simple messageDS", { @@ -38,7 +39,7 @@ test_that("simple messageDS", { expect_equal(class(res), "character") expect_length(res, 1) - expect_equal(res, "ALL OK: there are no studysideMessage(s) on this datasource", fixed = TRUE) + expect_equal(res, "ALL OK: there are no studysideMessage(s) on this datasource") }) test_that("simple messageDS", { @@ -48,7 +49,7 @@ test_that("simple messageDS", { expect_equal(class(res), "character") expect_length(res, 1) - expect_equal(res, "Outcome object is a list without names. So a studysideMessage may be hidden. Please check output is OK", fixed = TRUE) + expect_equal(res, "Outcome object is a list without names. So a studysideMessage may be hidden. Please check output is OK") }) @@ -59,7 +60,7 @@ test_that("simple messageDS", { expect_equal(class(res), "character") expect_length(res, 1) - expect_equal(res, "Outcome object is a list without names. So a studysideMessage may be hidden. Please check output is OK", fixed = TRUE) + expect_equal(res, "Outcome object is a list without names. So a studysideMessage may be hidden. Please check output is OK") }) test_that("simple messageDS", { @@ -69,7 +70,7 @@ test_that("simple messageDS", { expect_equal(class(res), "character") expect_length(res, 1) - expect_equal(res, "ALL OK: there are no studysideMessage(s) on this datasource", fixed = TRUE) + expect_equal(res, "ALL OK: there are no studysideMessage(s) on this datasource") }) test_that("simple messageDS", { @@ -79,13 +80,13 @@ test_that("simple messageDS", { expect_equal(class(res), "character") expect_length(res, 1) - expect_equal(res, "NOT ALL OK: there are studysideMessage(s) on this datasource", fixed = TRUE) + expect_equal(res, "NOT ALL OK: there are studysideMessage(s) on this datasource") }) # # Done # -context("messageDS::smk::shutdown") +# context("messageDS::smk::shutdown") -context("messageDS::smk::done") +# context("messageDS::smk::done") diff --git a/tests/testthat/test-smk-metadataDS.R b/tests/testthat/test-smk-metadataDS.R index 1c4a3dab..4b0ab042 100644 --- a/tests/testthat/test-smk-metadataDS.R +++ b/tests/testthat/test-smk-metadataDS.R @@ -1,5 +1,5 @@ #------------------------------------------------------------------------------- -# Copyright (c) 2024 Arjuna Technologies, 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. @@ -12,7 +12,7 @@ # Set up # -context("metadataDS::smk::setup") +# context("metadataDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +20,7 @@ set.standard.disclosure.settings() # Tests # -context("metadataDS::smk::list") +# context("metadataDS::smk::list") test_that("simple metadataDS, list of values", { input <- list(v1 = 0.0, v2 = 1.0) @@ -36,7 +36,7 @@ test_that("simple metadataDS, list of values", { expect_true("v2" %in% res$names) }) -context("metadataDS::smk::list field") +# context("metadataDS::smk::list field") test_that("simple metadataDS, list of vectors", { input <- list(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) @@ -50,6 +50,6 @@ test_that("simple metadataDS, list of vectors", { # Done # -context("metadataDS::smk::shutdown") +# context("metadataDS::smk::shutdown") -context("metadataDS::smk::done") +# context("metadataDS::smk::done") diff --git a/tests/testthat/test-smk-miceDS.R b/tests/testthat/test-smk-miceDS.R index 3c5af832..3b584da5 100644 --- a/tests/testthat/test-smk-miceDS.R +++ b/tests/testthat/test-smk-miceDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,27 +13,27 @@ # Set up # -context("miceDS::smk::setup") +# context("miceDS::smk::setup") # # Tests # -context("miceDS::smk") +# context("miceDS::smk") test_that("miceDS", { load(file = 'data_files/CNSIM/CNSIM1.rda') D <- study1 - res <- miceDS(data='D', m=1, maxit=5, method=NULL, post=NULL, predictorMatrix=NULL, seed=NA, - ncol.pred.mat=NULL, newobj_mids='mids_object', newobj_df='impSet') + expect_warning(res <- miceDS(data='D', m=1, maxit=5, method=NULL, post=NULL, predictorMatrix=NULL, seed=NA, + ncol.pred.mat=NULL, newobj_mids='mids_object', newobj_df='impSet'), "Number of logged events: 1") - expect_equal(class(res), "list") + expect_true(all(class(res) %in% c("list"))) expect_length(res, 3) - expect_true("character" %in% class(res$method)) + expect_true(all(class(res$method) %in% c("character"))) expect_equal(as.character(res$method), c("pmm","pmm","pmm","pmm","pmm","","","","","","polyreg")) - expect_true("matrix" %in% class(res$predictorMatrix)) - expect_true("array" %in% class(res$predictorMatrix)) + expect_true(all(class(res$predictorMatrix) %in% c("matrix", "array"))) + expect_true(all(class(res$predictorMatrix) %in% c("matrix", "array"))) expect_equal(as.numeric(res$predictorMatrix[,1]), c(0,1,1,1,1,1,1,1,1,1,1)) expect_equal(as.numeric(res$predictorMatrix[,2]), c(1,0,1,1,1,1,1,1,1,1,1)) expect_equal(as.numeric(res$predictorMatrix[,3]), c(1,1,0,1,1,1,1,1,1,1,1)) @@ -53,6 +54,6 @@ test_that("miceDS", { # Done # -context("miceDS::smk::shutdown") +# context("miceDS::smk::shutdown") -context("miceDS::smk::done") +# context("miceDS::smk::done") diff --git a/tests/testthat/test-smk-minMaxRandDS.R b/tests/testthat/test-smk-minMaxRandDS.R index e5a9fe77..0e057e5a 100644 --- a/tests/testthat/test-smk-minMaxRandDS.R +++ b/tests/testthat/test-smk-minMaxRandDS.R @@ -1,5 +1,5 @@ #------------------------------------------------------------------------------- -# Copyright (c) 2024 Arjuna Technologies, 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. @@ -12,7 +12,7 @@ # Set up # -context("minMaxRandDS::smk::setup") +# context("minMaxRandDS::smk::setup") # # Tests @@ -33,6 +33,6 @@ test_that("minMaxRandDS", { # Done # -context("minMaxRandDS::smk::shutdown") +# context("minMaxRandDS::smk::shutdown") -context("minMaxRandDS::smk::done") +# context("minMaxRandDS::smk::done") diff --git a/tests/testthat/test-smk-namesDS.R b/tests/testthat/test-smk-namesDS.R index 238c26d3..fe1134d5 100644 --- a/tests/testthat/test-smk-namesDS.R +++ b/tests/testthat/test-smk-namesDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("namesDS::smk::setup") +# context("namesDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("namesDS::smk::list of atoms") +# context("namesDS::smk::list of atoms") test_that("simple namesDS, data.frame", { input <- list(v1 = 0.0, v2 = 1.0) @@ -32,7 +33,7 @@ test_that("simple namesDS, data.frame", { expect_true("v2" %in% res) }) -context("namesDS::smk::list of vectors") +# context("namesDS::smk::list of vectors") test_that("simple namesDS, data.matrix", { input <- list(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) @@ -44,10 +45,25 @@ test_that("simple namesDS, data.matrix", { expect_true("v2" %in% res) }) +test_that("namesDS throws error when object does not exist", { + expect_error( + namesDS("nonexistent_object"), + regexp = "does not exist" + ) +}) + +test_that("namesDS throws error when object is not a list", { + bad_input <- c(1, 2, 3) + expect_error( + namesDS("bad_input"), + regexp = "not of class " + ) +}) + # # Done # -context("namesDS::smk::shutdown") +# context("namesDS::smk::shutdown") -context("namesDS::smk::done") +# context("namesDS::smk::done") diff --git a/tests/testthat/test-smk-numNaDS.R b/tests/testthat/test-smk-numNaDS.R index 5de3dc46..5040c94c 100644 --- a/tests/testthat/test-smk-numNaDS.R +++ b/tests/testthat/test-smk-numNaDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,37 +13,44 @@ # Set up # -context("numNaDS::smk::setup") +# context("numNaDS::smk::setup") # # Tests # -context("numNaDS::smk::simple") +# context("numNaDS::smk::simple") test_that("simple numNaDS", { input <- c(NA, 1, NA, 2, NA) - res <- numNaDS(input) + res <- numNaDS("input") - expect_equal(class(res), "integer") - expect_length(res, 1) - expect_equal(res, 3) + expect_equal(class(res$numNA), "integer") + expect_length(res$numNA, 1) + expect_equal(res$numNA, 3) }) -test_that("simple numNaDS", { +test_that("simple numNaDS, single NA", { input <- NA - res <- numNaDS(input) + res <- numNaDS("input") + + expect_equal(class(res$numNA), "integer") + expect_length(res$numNA, 1) + expect_equal(res$numNA, 1) +}) - expect_equal(class(res), "integer") - expect_length(res, 1) - expect_equal(res, 1) +test_that("numNaDS throws error when object does not exist", { + expect_error( + numNaDS("nonexistent_object"), + regexp = "does not exist" + ) }) # # Done # -context("numNaDS::smk::shutdown") +# context("numNaDS::smk::shutdown") -context("numNaDS::smk::done") +# context("numNaDS::smk::done") diff --git a/tests/testthat/test-smk-quantileMeanDS.R b/tests/testthat/test-smk-quantileMeanDS.R index 7ca9ac18..33eb0c6f 100644 --- a/tests/testthat/test-smk-quantileMeanDS.R +++ b/tests/testthat/test-smk-quantileMeanDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("quantileMeanDS::smk::setup") +# context("quantileMeanDS::smk::setup") # # Tests # -context("quantileMeanDS::smk") +# context("quantileMeanDS::smk") test_that("numeric quantileMeanDS", { input <- c(0.0, 1.0, 2.0, 3.0, 4.0) @@ -49,7 +50,7 @@ test_that("numeric quantileMeanDS", { expect_equal(res.names[[8]], "Mean") }) -context("quantileMeanDS::smk::with NA") +# context("quantileMeanDS::smk::with NA") test_that("numeric quantileMeanDS, with NA", { input <- c(0.0, NA, 2.0, NA, 4.0) @@ -84,6 +85,6 @@ test_that("numeric quantileMeanDS, with NA", { # Done # -context("quantileMeanDS::smk::shutdown") +# context("quantileMeanDS::smk::shutdown") -context("quantileMeanDS::smk::done") +# context("quantileMeanDS::smk::done") diff --git a/tests/testthat/test-smk-rBinomDS.R b/tests/testthat/test-smk-rBinomDS.R index d52ff3e7..9cff07d0 100644 --- a/tests/testthat/test-smk-rBinomDS.R +++ b/tests/testthat/test-smk-rBinomDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("rBinomDS::smk::setup") +# context("rBinomDS::smk::setup") # # Tests # -context("rBinomDS::smk::simple") +# context("rBinomDS::smk::simple") test_that("simple rBinomDS, by name", { n <- 8 size <- 32 @@ -61,6 +62,6 @@ test_that("simple rBinomDS, direct", { # Done # -context("rBinomDS::smk::shutdown") +# context("rBinomDS::smk::shutdown") -context("rBinomDS::smk::done") +# context("rBinomDS::smk::done") diff --git a/tests/testthat/test-smk-rNormDS.R b/tests/testthat/test-smk-rNormDS.R index c5b62afc..484ef851 100644 --- a/tests/testthat/test-smk-rNormDS.R +++ b/tests/testthat/test-smk-rNormDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("rNormDS::smk::setup") +# context("rNormDS::smk::setup") # # Tests # -context("rNormDS::smk::simple") +# context("rNormDS::smk::simple") test_that("simple rNormDS, by name", { n <- 8 mean <- 32.0 @@ -61,6 +62,6 @@ test_that("simple rNormDS, direct", { # Done # -context("rNormDS::smk::shutdown") +# context("rNormDS::smk::shutdown") -context("rNormDS::smk::done") +# context("rNormDS::smk::done") diff --git a/tests/testthat/test-smk-rPoisDS.R b/tests/testthat/test-smk-rPoisDS.R index a5d5c1fd..c2cf55bf 100644 --- a/tests/testthat/test-smk-rPoisDS.R +++ b/tests/testthat/test-smk-rPoisDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("rPoisDS::smk::setup") +# context("rPoisDS::smk::setup") # # Tests # -context("rPoisDS::smk::simple") +# context("rPoisDS::smk::simple") test_that("simple rPoisDS, by name", { n <- 8 lambda <- 32 @@ -59,6 +60,6 @@ test_that("simple rPoisDS, direct", { # Done # -context("rPoisDS::smk::shutdown") +# context("rPoisDS::smk::shutdown") -context("rPoisDS::smk::done") +# context("rPoisDS::smk::done") diff --git a/tests/testthat/test-smk-rUnifDS.R b/tests/testthat/test-smk-rUnifDS.R index a0e8d306..87c208c4 100644 --- a/tests/testthat/test-smk-rUnifDS.R +++ b/tests/testthat/test-smk-rUnifDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("rUnifDS::smk::setup") +# context("rUnifDS::smk::setup") # # Tests # -context("rUnifDS::smk::simple") +# context("rUnifDS::smk::simple") test_that("simple rUnifDS, by name", { n <- 8 min <- 2 @@ -61,6 +62,6 @@ test_that("simple rUnifDS, direct", { # Done # -context("rUnifDS::smk::shutdown") +# context("rUnifDS::smk::shutdown") -context("rUnifDS::smk::done") +# context("rUnifDS::smk::done") diff --git a/tests/testthat/test-smk-rangeDS.R b/tests/testthat/test-smk-rangeDS.R index ef04d6b1..c59c9d32 100644 --- a/tests/testthat/test-smk-rangeDS.R +++ b/tests/testthat/test-smk-rangeDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("rangeDS::smk::setup") +# context("rangeDS::smk::setup") set.random.seed.setting(1234) @@ -20,7 +21,7 @@ set.random.seed.setting(1234) # Tests # -context("rangeDS::smk::without NAs") +# context("rangeDS::smk::without NAs") 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) @@ -32,7 +33,7 @@ test_that("numeric rangeDS", { expect_equal(res[2], 4.12446, tolerance = 1e-6) }) -context("rangeDS::smk::with NAs") +# context("rangeDS::smk::with NAs") test_that("character rangeDS", { input <- c(0.0, NA, 2.0, NA, 4.0, NA, 3.0, NA, 1.0, NA) @@ -48,6 +49,6 @@ test_that("character rangeDS", { # Done # -context("rangeDS::smk::shutdown") +# context("rangeDS::smk::shutdown") -context("rangeDS::smk::done") +# context("rangeDS::smk::done") diff --git a/tests/testthat/test-smk-rbindDS.R b/tests/testthat/test-smk-rbindDS.R index 846b31bc..7f757a1e 100644 --- a/tests/testthat/test-smk-rbindDS.R +++ b/tests/testthat/test-smk-rbindDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("rbindDS::smk::setup") +# context("rbindDS::smk::setup") # # Tests # -context("rbindDS::smk::simple") +# context("rbindDS::smk::simple") test_that("simple rbindDS", { inputs <- 'input1, input2' input1 <- c(0.0, 1.0, 2.0, 3.0) @@ -61,6 +62,6 @@ test_that("simple rbindDS", { # Done # -context("rbindDS::smk::shutdown") +# context("rbindDS::smk::shutdown") -context("rbindDS::smk::done") +# context("rbindDS::smk::done") diff --git a/tests/testthat/test-smk-recodeLevelsDS.R b/tests/testthat/test-smk-recodeLevelsDS.R index 2eaef21b..9e365836 100644 --- a/tests/testthat/test-smk-recodeLevelsDS.R +++ b/tests/testthat/test-smk-recodeLevelsDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("recodeLevelsDS::smk::setup") +# context("recodeLevelsDS::smk::setup") # # Tests @@ -41,6 +42,6 @@ test_that("simple recodeLevelsDS", { # Done # -context("recodeLevelsDS::smk::shutdown") +# context("recodeLevelsDS::smk::shutdown") -context("recodeLevelsDS::smk::done") +# context("recodeLevelsDS::smk::done") diff --git a/tests/testthat/test-smk-recodeValuesDS.R b/tests/testthat/test-smk-recodeValuesDS.R index 14e7cb98..09b9e2f3 100644 --- a/tests/testthat/test-smk-recodeValuesDS.R +++ b/tests/testthat/test-smk-recodeValuesDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("recodeValuesDS::smk::setup") +# context("recodeValuesDS::smk::setup") set.standard.disclosure.settings() @@ -126,6 +127,6 @@ test_that("simple recodeValuesDS, character input with missings", { # Done # -context("recodeValuesDS::smk::shutdown") +# context("recodeValuesDS::smk::shutdown") -context("recodeValuesDS::smk::done") +# context("recodeValuesDS::smk::done") diff --git a/tests/testthat/test-smk-replaceNaDS.R b/tests/testthat/test-smk-replaceNaDS.R index f092b9cd..b2b4cfff 100644 --- a/tests/testthat/test-smk-replaceNaDS.R +++ b/tests/testthat/test-smk-replaceNaDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("replaceNaDS::smk::setup") +# context("replaceNaDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("replaceNaDS::smk") +# context("replaceNaDS::smk") 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) @@ -43,6 +44,6 @@ test_that("simple replaceNaDS", { # Done # -context("replaceNaDS::smk::shutdown") +# context("replaceNaDS::smk::shutdown") -context("replaceNaDS::smk::done") +# context("replaceNaDS::smk::done") diff --git a/tests/testthat/test-smk-rmDS.R b/tests/testthat/test-smk-rmDS.R index 7bab6da2..0053b72c 100644 --- a/tests/testthat/test-smk-rmDS.R +++ b/tests/testthat/test-smk-rmDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("rmDS::smk::setup") +# context("rmDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("rmDS::smk::single") +# context("rmDS::smk::single") test_that("single rmDS", { expect_false(exists("input")) @@ -34,13 +35,13 @@ test_that("single rmDS", { expect_equal(class(res), "list") expect_length(res, 4) - expect_equal(res$return.message, "Object(s) 'input' was deleted.", fixed = TRUE) - expect_equal(res$deleted.objects, "input", fixed = TRUE) - expect_equal(res$missing.objects, "", fixed = TRUE) - expect_equal(res$problem.objects, "", fixed = TRUE) + expect_equal(res$return.message, "Object(s) 'input' was deleted.") + expect_equal(res$deleted.objects, "input") + expect_equal(res$missing.objects, "") + expect_equal(res$problem.objects, "") }) -context("rmDS::smk::multiple") +# context("rmDS::smk::multiple") test_that("multiple rmDS", { expect_false(exists("input1")) expect_false(exists("input2")) @@ -59,13 +60,13 @@ test_that("multiple rmDS", { expect_equal(class(res), "list") expect_length(res, 4) - expect_equal(res$return.message, "Object(s) 'input1,input2' was deleted.", fixed = TRUE) - expect_equal(res$deleted.objects, "input1,input2", fixed = TRUE) - expect_equal(res$missing.objects, "", fixed = TRUE) - expect_equal(res$problem.objects, "", fixed = TRUE) + expect_equal(res$return.message, "Object(s) 'input1,input2' was deleted.") + expect_equal(res$deleted.objects, "input1,input2") + expect_equal(res$missing.objects, "") + expect_equal(res$problem.objects, "") }) -context("rmDS::smk::single missing") +# context("rmDS::smk::single missing") test_that("single missing rmDS", { expect_false(exists("input")) @@ -75,14 +76,14 @@ test_that("single missing rmDS", { expect_equal(class(res), "list") expect_length(res, 4) - expect_equal(res$return.message, "Object(s) 'input' which are missing.", fixed = TRUE) - expect_equal(res$deleted.objects, "", fixed = TRUE) - expect_equal(res$missing.objects, "input", fixed = TRUE) - expect_equal(res$problem.objects, "", fixed = TRUE) + expect_equal(res$return.message, "Object(s) 'input' which are missing.") + expect_equal(res$deleted.objects, "") + expect_equal(res$missing.objects, "input") + expect_equal(res$problem.objects, "") }) -context("rmDS::smk::multiple missing") +# context("rmDS::smk::multiple missing") test_that("multiple missing rmDS", { expect_false(exists("input1")) expect_false(exists("input2")) @@ -94,13 +95,13 @@ test_that("multiple missing rmDS", { expect_equal(class(res), "list") expect_length(res, 4) - expect_equal(res$return.message, "Object(s) 'input1,input2' which are missing.", fixed = TRUE) - expect_equal(res$deleted.objects, "", fixed = TRUE) - expect_equal(res$missing.objects, "input1,input2", fixed = TRUE) - expect_equal(res$problem.objects, "", fixed = TRUE) + expect_equal(res$return.message, "Object(s) 'input1,input2' which are missing.") + expect_equal(res$deleted.objects, "") + expect_equal(res$missing.objects, "input1,input2") + expect_equal(res$problem.objects, "") }) -context("rmDS::smk::multiple mixed") +# context("rmDS::smk::multiple mixed") test_that("multiple mixed rmDS", { expect_false(exists("input1")) expect_false(exists("input2")) @@ -114,16 +115,16 @@ test_that("multiple mixed rmDS", { expect_equal(class(res), "list") expect_length(res, 4) - expect_equal(res$return.message, "Object(s) 'input1' was deleted. 'input2' which are missing.", fixed = TRUE) - expect_equal(res$deleted.objects, "input1", fixed = TRUE) - expect_equal(res$missing.objects, "input2", fixed = TRUE) - expect_equal(res$problem.objects, "", fixed = TRUE) + expect_equal(res$return.message, "Object(s) 'input1' was deleted. 'input2' which are missing.") + expect_equal(res$deleted.objects, "input1") + expect_equal(res$missing.objects, "input2") + expect_equal(res$problem.objects, "") }) # # Done # -context("rmDS::smk::shutdown") +# context("rmDS::smk::shutdown") -context("rmDS::smk::done") +# context("rmDS::smk::done") diff --git a/tests/testthat/test-smk-rowColCalcDS.R b/tests/testthat/test-smk-rowColCalcDS.R index c951a73b..615aa2ff 100644 --- a/tests/testthat/test-smk-rowColCalcDS.R +++ b/tests/testthat/test-smk-rowColCalcDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("rowColCalcDS::smk::setup") +# context("rowColCalcDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("rowColCalcDS::smk") +# context("rowColCalcDS::smk") 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) @@ -77,6 +78,6 @@ test_that("simple rowColCalcDS, operation 4", { # Done # -context("rowColCalcDS::smk::shutdown") +# context("rowColCalcDS::smk::shutdown") -context("rowColCalcDS::smk::done") +# context("rowColCalcDS::smk::done") diff --git a/tests/testthat/test-smk-sampleDS.R b/tests/testthat/test-smk-sampleDS.R index b30f86e6..e3927518 100644 --- a/tests/testthat/test-smk-sampleDS.R +++ b/tests/testthat/test-smk-sampleDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("sampleDS::smk::setup") +# context("sampleDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("sampleDS::smk::simple") +# context("sampleDS::smk::simple") test_that("simple sampleDS", { x <- c(1:32) size <- 16 @@ -49,6 +50,6 @@ test_that("simple sampleDS", { # Done # -context("sampleDS::smk::shutdown") +# context("sampleDS::smk::shutdown") -context("sampleDS::smk::done") +# context("sampleDS::smk::done") diff --git a/tests/testthat/test-smk-seqDS.R b/tests/testthat/test-smk-seqDS.R index b0660b58..7cdd62eb 100644 --- a/tests/testthat/test-smk-seqDS.R +++ b/tests/testthat/test-smk-seqDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("seqDS::smk::setup") +# context("seqDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("seqDS::smk") +# context("seqDS::smk") test_that("simple seqDS", { FROM.value.char <- "1" TO.value.char <- "12" @@ -121,6 +122,6 @@ test_that("simple seqDS", { # Done # -context("seqDS::smk::shutdown") +# context("seqDS::smk::shutdown") -context("seqDS::smk::done") +# context("seqDS::smk::done") diff --git a/tests/testthat/test-smk-setFilterDS.R b/tests/testthat/test-smk-setFilterDS.R index 2b32a6f9..93e54b7e 100644 --- a/tests/testthat/test-smk-setFilterDS.R +++ b/tests/testthat/test-smk-setFilterDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("setFilterDS::smk::setup") +# context("setFilterDS::smk::setup") set.standard.disclosure.settings @@ -20,7 +21,7 @@ set.standard.disclosure.settings # Tests # -context("setFilterDS::smk::simple") +# context("setFilterDS::smk::simple") test_that("simple setFilterDS", { res <- setFilterDS() @@ -43,6 +44,6 @@ test_that("simple setFilterDS", { # Done # -context("setFilterDS::smk::shutdown") +# context("setFilterDS::smk::shutdown") -context("setFilterDS::smk::done") +# context("setFilterDS::smk::done") diff --git a/tests/testthat/test-smk-setSeedDS.R b/tests/testthat/test-smk-setSeedDS.R index 6db3d8bc..0cdbf2e9 100644 --- a/tests/testthat/test-smk-setSeedDS.R +++ b/tests/testthat/test-smk-setSeedDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("setSeedDS::smk::setup") +# context("setSeedDS::smk::setup") # # Tests # -context("setSeedDS::smk::simple") +# context("setSeedDS::smk::simple") test_that("simple setSeedDS", { seedtext <- "19" kind <- NULL @@ -35,6 +36,6 @@ test_that("simple setSeedDS", { # Done # -context("setSeedDS::smk::shutdown") +# context("setSeedDS::smk::shutdown") -context("setSeedDS::smk::done") +# context("setSeedDS::smk::done") diff --git a/tests/testthat/test-smk-skewnessDS1.R b/tests/testthat/test-smk-skewnessDS1.R index 76f8d4fd..562c3f65 100644 --- a/tests/testthat/test-smk-skewnessDS1.R +++ b/tests/testthat/test-smk-skewnessDS1.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("skewnessDS1::smk::setup") +# context("skewnessDS1::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("skewnessDS1::smk::method 1") +# context("skewnessDS1::smk::method 1") test_that("simple skewnessDS1, method 1", { input <- c(0.0, 1.0, 1.0, 1.0, 2.0, 2.0, 2.0, 3.0, 4.0) @@ -36,7 +37,7 @@ test_that("simple skewnessDS1, method 1", { expect_equal(res$ValidityMessage, "VALID ANALYSIS") }) -context("skewnessDS1::smk::method 2") +# context("skewnessDS1::smk::method 2") test_that("simple skewnessDS1, method 2", { input <- c(0.0, 1.0, 1.0, 1.0, 2.0, 2.0, 2.0, 3.0, 4.0) @@ -52,7 +53,7 @@ test_that("simple skewnessDS1, method 2", { expect_equal(res$ValidityMessage, "VALID ANALYSIS") }) -context("skewnessDS1::smk::method 3") +# context("skewnessDS1::smk::method 3") test_that("simple skewnessDS1, method 3", { input <- c(0.0, 1.0, 1.0, 1.0, 2.0, 2.0, 2.0, 3.0, 4.0) @@ -61,7 +62,7 @@ test_that("simple skewnessDS1, method 3", { expect_length(res, 3) expect_equal(class(res), "list") expect_equal(class(res$Skewness), "numeric") - expect_equal(res$Skewness, 0.371380, tolerance = 1e-6) + expect_equal(res$Skewness, 0.3713805, tolerance = 1e-6) expect_equal(class(res$Nvalid), "integer") expect_equal(res$Nvalid,9) expect_equal(class(res$ValidityMessage), "character") @@ -72,6 +73,6 @@ test_that("simple skewnessDS1, method 3", { # Done # -context("skewnessDS1::smk::shutdown") +# context("skewnessDS1::smk::shutdown") -context("skewnessDS1::smk::done") +# context("skewnessDS1::smk::done") diff --git a/tests/testthat/test-smk-skewnessDS2.R b/tests/testthat/test-smk-skewnessDS2.R index 1966109d..9e59061d 100644 --- a/tests/testthat/test-smk-skewnessDS2.R +++ b/tests/testthat/test-smk-skewnessDS2.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("skewnessDS2::smk::setup") +# context("skewnessDS2::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("skewnessDS2::smk") +# context("skewnessDS2::smk") test_that("simple skewnessDS2", { input <- c(1.0, 2.0, 2.0, 3.0, 3.0) global.mean <- 2.5 @@ -43,6 +44,6 @@ test_that("simple skewnessDS2", { # Done # -context("skewnessDS2::smk::shutdown") +# context("skewnessDS2::smk::shutdown") -context("skewnessDS2::smk::done") +# context("skewnessDS2::smk::done") diff --git a/tests/testthat/test-smk-sqrtDS.R b/tests/testthat/test-smk-sqrtDS.R index 2689d375..273baec1 100644 --- a/tests/testthat/test-smk-sqrtDS.R +++ b/tests/testthat/test-smk-sqrtDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,23 +13,13 @@ # Set up # -context("sqrtDS::smk::setup") +# context("sqrtDS::smk::setup") # # Tests # -context("sqrtDS::smk::special") -test_that("simple sqrtDS, NA", { - input <- NA - - res <- sqrtDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_true(is.na(res)) -}) - +# context("sqrtDS::smk::special") test_that("simple sqrtDS, NaN", { input <- NaN @@ -59,7 +50,7 @@ test_that("simple sqrtDS, -Inf", { expect_true(is.nan(res)) }) -context("sqrtDS::smk::numeric") +# context("sqrtDS::smk::numeric") test_that("simple sqrtDS, numeric 0.0", { input <- 0.0 @@ -90,7 +81,7 @@ test_that("simple sqrtDS, numeric -10.0", { expect_true(is.nan(res)) }) -context("sqrtDS::smk::integer") +# context("sqrtDS::smk::integer") test_that("simple sqrtDS, integer 0L", { input <- 0L @@ -121,7 +112,7 @@ test_that("simple sqrtDS, integer -10L", { expect_true(is.nan(res)) }) -context("sqrtDS::smk::special vector") +# context("sqrtDS::smk::special vector") test_that("simple sqrtDS", { input <- c(NA, NaN, Inf, -Inf) @@ -134,7 +125,7 @@ test_that("simple sqrtDS", { expect_true(is.nan(res[4])) }) -context("sqrtDS::smk::numeric vector") +# context("sqrtDS::smk::numeric vector") test_that("simple sqrtDS", { input <- c(0.0, 4.0, 9.0, -10.0, -50.0, -20.0) @@ -150,7 +141,7 @@ test_that("simple sqrtDS", { expect_true(is.nan(res[6])) }) -context("sqrtDS::smk::integer vector") +# context("sqrtDS::smk::integer vector") test_that("simple sqrtDS", { input <- c(0L, 4L, 9L, -10L, -50L, -20L) @@ -165,11 +156,10 @@ test_that("simple sqrtDS", { expect_true(is.nan(res[5])) expect_true(is.nan(res[6])) }) - # # Done # -context("sqrtDS::smk::shutdown") +# context("sqrtDS::smk::shutdown") -context("sqrtDS::smk::done") +# context("sqrtDS::smk::done") diff --git a/tests/testthat/test-smk-subsetByClassDS.R b/tests/testthat/test-smk-subsetByClassDS.R index 8de5114b..82ccab5d 100644 --- a/tests/testthat/test-smk-subsetByClassDS.R +++ b/tests/testthat/test-smk-subsetByClassDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("subsetByClassDS::smk::setup") +# context("subsetByClassDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("subsetByClassDS::smk") +# context("subsetByClassDS::smk") test_that("simple subsetByClassDS, data.frame, unspecified variables", { data <- data.frame(v1 = factor(c(0, 0, 0, 1, 1, 1, 2, 1, 2, 2)), v2 = c(4.0, 0.0, 3.0, 1.0, 2.0, 2.0, 1.0, 3.0, 0.0, 4.0), v3 = c(1:10), v4 = c(1:10)) variables <- NULL @@ -82,6 +83,6 @@ test_that("simple subsetByClassDS, factor vector, specified variables", { # Done # -context("subsetByClassDS::smk::shutdown") +# context("subsetByClassDS::smk::shutdown") -context("subsetByClassDS::smk::done") +# context("subsetByClassDS::smk::done") diff --git a/tests/testthat/test-smk-subsetDS.R b/tests/testthat/test-smk-subsetDS.R index f34119c4..53d291c4 100644 --- a/tests/testthat/test-smk-subsetDS.R +++ b/tests/testthat/test-smk-subsetDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("subsetDS::smk::setup") +# context("subsetDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("subsetDS::smk") +# context("subsetDS::smk") test_that("simple subsetDS, no NAs", { data <- data.frame(v1 = c(0, 0, 1, 1, 2, 2, 3, 3, 4, 4), v2 = c(4.0, 0.0, 3.0, 1.0, 2.0, 2.0, 1.0, 3.0, 0.0, 4.0)) complt <- FALSE @@ -120,6 +121,6 @@ test_that("simple subsetDS, NAs, complete.case TRUE", { # Done # -context("subsetDS::smk::shutdown") +# context("subsetDS::smk::shutdown") -context("subsetDS::smk::done") +# context("subsetDS::smk::done") diff --git a/tests/testthat/test-smk-tapplyDS.R b/tests/testthat/test-smk-tapplyDS.R index 5824713d..7925b49a 100644 --- a/tests/testthat/test-smk-tapplyDS.R +++ b/tests/testthat/test-smk-tapplyDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("tapplyDS::smk::setup") +# context("tapplyDS::smk::setup") set.standard.disclosure.settings() @@ -161,6 +162,6 @@ test_that("simple tapplyDS, quantile", { # Done # -context("tapplyDS::smk::shutdown") +# context("tapplyDS::smk::shutdown") -context("tapplyDS::smk::done") +# context("tapplyDS::smk::done") diff --git a/tests/testthat/test-smk-tapplyDS.assign.R b/tests/testthat/test-smk-tapplyDS.assign.R index 90c57654..7d899a2e 100644 --- a/tests/testthat/test-smk-tapplyDS.assign.R +++ b/tests/testthat/test-smk-tapplyDS.assign.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("tapplyDS.assign::smk::setup") +# context("tapplyDS.assign::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("tapplyDS.assign::smk::simple") +# context("tapplyDS.assign::smk::simple") test_that("simple tapplyDS.assign", { x <- c(1, 2, 1, 2, 1, 2, 1, 2) index <- factor(c(1, 2, 1, 2, 1, 2, 1, 2)) @@ -54,6 +55,6 @@ test_that("simple tapplyDS.assign", { # Done # -context("tapplyDS.assign::smk::shutdown") +# context("tapplyDS.assign::smk::shutdown") -context("tapplyDS.assign::smk::done") +# context("tapplyDS.assign::smk::done") diff --git a/tests/testthat/test-smk-testObjExistsDS.R b/tests/testthat/test-smk-testObjExistsDS.R index 6dd2780d..705948d0 100644 --- a/tests/testthat/test-smk-testObjExistsDS.R +++ b/tests/testthat/test-smk-testObjExistsDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("testObjExistsDS::smk::setup") +# context("testObjExistsDS::smk::setup") # # Tests # -context("testObjExistsDS::smk::character") +# context("testObjExistsDS::smk::character") test_that("simple testObjExistsDS, character", { input <- "value" @@ -41,7 +42,7 @@ test_that("simple testObjExistsDS, character vector", { expect_equal(res$test.obj.class, "character") }) -context("testObjExistsDS::smk::integer") +# context("testObjExistsDS::smk::integer") test_that("simple testObjExistsDS, integer", { input <- 1L @@ -64,7 +65,7 @@ test_that("simple testObjExistsDS, integer vector", { expect_equal(res$test.obj.class, "integer") }) -context("testObjExistsDS::smk::numeric") +# context("testObjExistsDS::smk::numeric") test_that("simple testObjExistsDS, numeric", { input <- 1.1 @@ -87,7 +88,7 @@ test_that("simple testObjExistsDS, numeric vector", { expect_equal(res$test.obj.class, "numeric") }) -context("testObjExistsDS::smk::logical") +# context("testObjExistsDS::smk::logical") test_that("simple testObjExistsDS, logical, FALSE", { input <- FALSE @@ -121,7 +122,7 @@ test_that("simple testObjExistsDS, logical vector", { expect_equal(res$test.obj.class, "logical") }) -context("testObjExistsDS::smk::data.frame") +# context("testObjExistsDS::smk::data.frame") test_that("simple testObjExistsDS, 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)) @@ -133,7 +134,7 @@ test_that("simple testObjExistsDS, data.frame", { expect_equal(res$test.obj.class, "data.frame") }) -context("testObjExistsDS::smk::array") +# context("testObjExistsDS::smk::array") test_that("simple testObjExistsDS, array", { input <- array(c(0.0, 1.0, 2.0, 3.0, 4.0)) @@ -145,7 +146,7 @@ test_that("simple testObjExistsDS, array", { expect_equal(res$test.obj.class, "array") }) -context("testObjExistsDS::smk::matrix") +# context("testObjExistsDS::smk::matrix") test_that("simple testObjExistsDS, matrix", { input <- matrix(c(0.0, 1.0, 2.0, 3.0, 4.0)) @@ -167,7 +168,7 @@ test_that("simple testObjExistsDS, matrix", { } }) -context("testObjExistsDS::smk::data.matrix") +# context("testObjExistsDS::smk::data.matrix") test_that("simple testObjExistsDS, 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))) @@ -190,7 +191,7 @@ test_that("simple testObjExistsDS, data.matrix", { } }) -context("testObjExistsDS::smk::date") +# context("testObjExistsDS::smk::date") test_that("simple testObjExistsDS, date", { input <- Sys.Date() @@ -202,7 +203,7 @@ test_that("simple testObjExistsDS, date", { expect_equal(res$test.obj.class, "Date") }) -context("testObjExistsDS::smk::formula") +# context("testObjExistsDS::smk::formula") test_that("simple testObjExistsDS, formula", { input <- X ~ A + B @@ -214,7 +215,7 @@ test_that("simple testObjExistsDS, formula", { expect_equal(res$test.obj.class, "formula") }) -context("testObjExistsDS::smk::environment") +# context("testObjExistsDS::smk::environment") test_that("simple testObjExistsDS, environment", { input <- environment() @@ -226,7 +227,7 @@ test_that("simple testObjExistsDS, environment", { expect_equal(res$test.obj.class, "environment") }) -context("testObjExistsDS::smk::NA") +# context("testObjExistsDS::smk::NA") test_that("special testObjExistsDS, NA", { input <- NA @@ -238,7 +239,7 @@ test_that("special testObjExistsDS, NA", { expect_equal(res$test.obj.class, "logical") }) -context("testObjExistsDS::smk::NULL") +# context("testObjExistsDS::smk::NULL") test_that("special testObjExistsDS, NULL", { input <- NULL @@ -250,7 +251,7 @@ test_that("special testObjExistsDS, NULL", { expect_equal(res$test.obj.class, "NULL") }) -context("testObjExistsDS::smk::not exists") +# context("testObjExistsDS::smk::not exists") test_that("special testObjExistsDS, not exists", { res <- testObjExistsDS("XXXinputXXX") @@ -264,6 +265,6 @@ test_that("special testObjExistsDS, not exists", { # Done # -context("testObjExistsDS::smk::shutdown") +# context("testObjExistsDS::smk::shutdown") -context("testObjExistsDS::smk::done") +# context("testObjExistsDS::smk::done") diff --git a/tests/testthat/test-smk-unListDS.R b/tests/testthat/test-smk-unListDS.R index 316806d3..b8f814fe 100644 --- a/tests/testthat/test-smk-unListDS.R +++ b/tests/testthat/test-smk-unListDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("unListDS::smk::setup") +# context("unListDS::smk::setup") # # Tests # -context("unListDS::smk::simple") +# context("unListDS::smk::simple") test_that("simple unListDS", { input <- list(v1 = c(1, 2, 3), v2 = c(4, 5, 6)) @@ -49,6 +50,6 @@ test_that("simple unListDS", { # Done # -context("unListDS::smk::shutdown") +# context("unListDS::smk::shutdown") -context("unListDS::smk::done") +# context("unListDS::smk::done") diff --git a/tests/testthat/test-smk-uniqueDS.R b/tests/testthat/test-smk-uniqueDS.R index 2bad97cf..3f4b908c 100644 --- a/tests/testthat/test-smk-uniqueDS.R +++ b/tests/testthat/test-smk-uniqueDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,13 +13,13 @@ # Set up # -context("uniqueDS::smk::setup") +# context("uniqueDS::smk::setup") # # Tests # -context("uniqueDS::smk::simple for vector") +# context("uniqueDS::smk::simple for vector") test_that("simple uniqueDS for vector", { input <- c(1, 2, 3, 2, 3, 6) @@ -32,7 +33,7 @@ test_that("simple uniqueDS for vector", { expect_equal(res[[4]], 6) }) -context("uniqueDS::smk::simple for vector") +# context("uniqueDS::smk::simple for vector") test_that("simple uniqueDS for list", { input <- list(a=1, b=2, c=3, d=2, e=3, f=6) @@ -52,6 +53,6 @@ test_that("simple uniqueDS for list", { # Done # -context("uniqueDS::smk::shutdown") +# context("uniqueDS::smk::shutdown") -context("uniqueDS::smk::done") +# context("uniqueDS::smk::done") diff --git a/tests/testthat/test-smk-utils.R b/tests/testthat/test-smk-utils.R new file mode 100644 index 00000000..131454e1 --- /dev/null +++ b/tests/testthat/test-smk-utils.R @@ -0,0 +1,83 @@ + +#------------------------------------------------------------------------------- +# Copyright (c) 2019-2022 University of 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 +# + +## When .loadServersideObject is called, the actual data exists two levels below the function, +## i.e. data in global env --> ds function --> .loadServersideObject. We recreate this in +## the test environment with a wrapper function. +.dsFunctionWrapper <- function(x) { + .loadServersideObject(x) +} + +# context("utils::smk::setup") +test_that(".loadServersideObject() returns existing object", { + test_df <- data.frame(a = 1:3) + result <- .dsFunctionWrapper("test_df") + expect_identical(result, test_df) +}) + +test_that(".loadServersideObject() extracts column with $ syntax", { + test_df <- data.frame(a = 1:3, b = 4:6) + result <- .dsFunctionWrapper("test_df$b") + expect_identical(result, 4:6) +}) + +test_that(".loadServersideObject() throws error for nonexistent column", { + test_df <- data.frame(a = 1:3) + expect_error( + .dsFunctionWrapper("test_df$nonexistent"), + regexp = "Column 'nonexistent' not found in 'test_df'" + ) +}) + +test_that(".loadServersideObject() throws error for missing object", { + expect_error( + .dsFunctionWrapper("no_such_object"), + regexp = "does not exist" + ) +}) + +test_that(".checkClass() passes for correct class", { + df <- data.frame(a = 1) + expect_invisible( + .checkClass(df, "df", c("data.frame", "matrix")) + ) +}) + +test_that(".checkClass() throws informative error for wrong class with one target class", { + x <- list(a = 1) + expect_error( + .checkClass(x, "x", "data.frame"), + regexp = "The server-side object must be of type data.frame. 'x' is type list." + ) +}) + +test_that(".checkClass() throws informative error for wrong class with three target classes", { + x <- list(a = 1) + expect_error( + .checkClass(x, "x", c("data.frame", "matrix", "unicorn")), + regexp = "The server-side object must be of type data.frame, matrix or unicorn. 'x' is type list." + ) +}) + +test_that(".checkClass() throws informative error for three target classes and three actual classes", { + x <- tibble(a = 1) + expect_error( + .checkClass(x, "x", c("Boolean", "unicorn", "donkey")), + regexp = "The server-side object must be of type Boolean, unicorn or donkey. 'x' is type tbl_df, tbl and data.frame." + ) +}) + +# context("utils::smk::shutdown") +# context("utils::smk::done") diff --git a/tests/testthat/test-smk-varDS.R b/tests/testthat/test-smk-varDS.R index 34ba8670..517b8d8f 100644 --- a/tests/testthat/test-smk-varDS.R +++ b/tests/testthat/test-smk-varDS.R @@ -1,5 +1,6 @@ #------------------------------------------------------------------------------- # 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. @@ -12,7 +13,7 @@ # Set up # -context("varDS::smk::setup") +# context("varDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("varDS::smk::numeric") +# context("varDS::smk::numeric") test_that("numeric varDS", { input <- c(0.0, 1.0, 2.0, 3.0, 4.0) @@ -42,7 +43,7 @@ test_that("numeric varDS", { expect_equal(res$ValidityMessage, "VALID ANALYSIS") }) -context("varDS::smk::numeric with NA") +# context("varDS::smk::numeric with NA") test_that("numeric varDS, with NA", { input <- c(0.0, NA, 2.0, NA, 4.0) @@ -64,7 +65,7 @@ test_that("numeric varDS, with NA", { expect_equal(res$ValidityMessage, "VALID ANALYSIS") }) -context("varDS::smk::numeric with all NA") +# context("varDS::smk::numeric with all NA") test_that("numeric varDS, with all NA", { input <- c(NA, NA, NA, NA, NA) @@ -90,6 +91,6 @@ test_that("numeric varDS, with all NA", { # Done # -context("varDS::smk::shutdown") +# context("varDS::smk::shutdown") -context("varDS::smk::done") +# context("varDS::smk::done") diff --git a/tests/testthat/test-smk-vectorDS.R b/tests/testthat/test-smk-vectorDS.R index d6ef7ff2..3d4b48c6 100644 --- a/tests/testthat/test-smk-vectorDS.R +++ b/tests/testthat/test-smk-vectorDS.R @@ -1,5 +1,5 @@ #------------------------------------------------------------------------------- -# Copyright (c) 2024 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. +# Copyright (c) 2024-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. @@ -12,7 +12,7 @@ # Set up # -context("vectorDS::smk::setup") +# context("vectorDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +20,7 @@ set.standard.disclosure.settings() # Tests # -context("vectorDS::smk::numeric list") +# context("vectorDS::smk::numeric list") test_that("numeric list vectorDS", { input <- list(a=0.0, b=1.0, c=2.0, d=3.0) @@ -34,7 +34,7 @@ test_that("numeric list vectorDS", { expect_equal(res[[4]], 3.0) }) -context("vectorDS::smk::character list") +# context("vectorDS::smk::character list") test_that("character list vectorDS", { input <- list(a="0.0", b="1.0", c="2.0", d="3.0") @@ -48,7 +48,7 @@ test_that("character list vectorDS", { expect_equal(res[[4]], "3.0") }) -context("vectorDS::smk::numeric list small") +# context("vectorDS::smk::numeric list small") test_that("single numeric list small vectorDS", { input <- list(a=0, b=1) @@ -60,7 +60,7 @@ test_that("single numeric list small vectorDS", { expect_equal(res[[2]], 1) }) -context("vectorDS::smk::empty list") +# context("vectorDS::smk::empty list") test_that("empty list vectorDS", { input <- list() @@ -74,6 +74,6 @@ test_that("empty list vectorDS", { # Done # -context("vectorDS::smk::shutdown") +# context("vectorDS::smk::shutdown") -context("vectorDS::smk::done") +# context("vectorDS::smk::done")