diff --git a/.Rbuildignore b/.Rbuildignore index 26e4d4d4..4b349a88 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -12,3 +12,4 @@ ^\.github$ ^cran-comments\.md$ ^pull_request_template$ +PULL_REQUEST_TEMPLATE.md diff --git a/NAMESPACE b/NAMESPACE index db4a5378..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) diff --git a/R/absDS.R b/R/absDS.R index 1f7dc518..cd7c4312 100644 --- a/R/absDS.R +++ b/R/absDS.R @@ -12,12 +12,10 @@ #' @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..e12b8fe5 100644 --- a/R/asCharacterDS.R +++ b/R/asCharacterDS.R @@ -13,7 +13,7 @@ #' @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..0e570778 100644 --- a/R/asDataMatrixDS.R +++ b/R/asDataMatrixDS.R @@ -17,15 +17,9 @@ #' @author Paul Burton for DataSHIELD Development Team #' @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..b982ed88 100644 --- a/R/asIntegerDS.R +++ b/R/asIntegerDS.R @@ -14,18 +14,10 @@ #' @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..4d29fb72 100644 --- a/R/asListDS.R +++ b/R/asListDS.R @@ -22,24 +22,10 @@ #' @author Amadou Gaye, Paul Burton for DataSHIELD Development Team #' @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..ef40d402 100644 --- a/R/asLogicalDS.R +++ b/R/asLogicalDS.R @@ -1,32 +1,20 @@ -#' @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 #' @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..33d1ba15 100644 --- a/R/asMatrixDS.R +++ b/R/asMatrixDS.R @@ -11,17 +11,9 @@ #' @author Amadou Gaye, Paul Burton for DataSHIELD Development Team #' @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..17b9fd34 100644 --- a/R/asNumericDS.R +++ b/R/asNumericDS.R @@ -14,13 +14,7 @@ #' @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 +30,6 @@ asNumericDS <- function(x.name){ } return(output) - } # ASSIGN FUNCTION # asNumericDS diff --git a/R/expDS.R b/R/expDS.R new file mode 100644 index 00000000..0590384e --- /dev/null +++ b/R/expDS.R @@ -0,0 +1,21 @@ +#' +#' @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 +#' @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/logDS.R b/R/logDS.R new file mode 100644 index 00000000..13b3a367 --- /dev/null +++ b/R/logDS.R @@ -0,0 +1,23 @@ +#' +#' @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 +#' @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/sqrtDS.R b/R/sqrtDS.R index b44fd0cc..7643a532 100644 --- a/R/sqrtDS.R +++ b/R/sqrtDS.R @@ -12,15 +12,11 @@ #' @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/utils.R b/R/utils.R index b004d330..b96d8735 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,18 +1,43 @@ #' Load a Server-Side Object by Name #' -#' Evaluates a character string referring to an object name and returns the corresponding -#' object from the parent environment. If the object does not exist, an error is raised. +#' 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 to be retrieved. -#' @return The evaluated R object referred to by `x`. +#' @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) { - tryCatch( - get(x, envir = parent.frame(2)), - error = function(e) { - stop("The server-side object", " '", x, "' ", "does not exist") - } + 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 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/asLogicalDS.Rd b/man/asLogicalDS.Rd index 561c9d2b..3f5ea2d3 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,7 +18,7 @@ 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 diff --git a/man/expDS.Rd b/man/expDS.Rd new file mode 100644 index 00000000..87ce96c8 --- /dev/null +++ b/man/expDS.Rd @@ -0,0 +1,26 @@ +% 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 +} diff --git a/man/logDS.Rd b/man/logDS.Rd new file mode 100644 index 00000000..5c8a8eb2 --- /dev/null +++ b/man/logDS.Rd @@ -0,0 +1,29 @@ +% 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 +} 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 c3e6b288..b5ab705f 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -21,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") diff --git a/tests/testthat/test-arg-asIntegerDS.R b/tests/testthat/test-arg-asIntegerDS.R index c2ebd028..a3635bfd 100644 --- a/tests/testthat/test-arg-asIntegerDS.R +++ b/tests/testthat/test-arg-asIntegerDS.R @@ -20,7 +20,7 @@ # 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) }) # diff --git a/tests/testthat/test-arg-asLogicalDS.R b/tests/testthat/test-arg-asLogicalDS.R index 33159504..d778e010 100644 --- a/tests/testthat/test-arg-asLogicalDS.R +++ b/tests/testthat/test-arg-asLogicalDS.R @@ -21,21 +21,21 @@ # 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") 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") 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) }) # diff --git a/tests/testthat/test-perf-meanDS.R b/tests/testthat/test-perf-meanDS.R index 4cee2473..59266cb2 100644 --- a/tests/testthat/test-perf-meanDS.R +++ b/tests/testthat/test-perf-meanDS.R @@ -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 = '')) } @@ -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 = '')) } diff --git a/tests/testthat/test-perf-varDS.R b/tests/testthat/test-perf-varDS.R index 459e6f03..10fff94a 100644 --- a/tests/testthat/test-perf-varDS.R +++ b/tests/testthat/test-perf-varDS.R @@ -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 = '')) } @@ -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 = '')) } diff --git a/tests/testthat/test-smk-absDS.R b/tests/testthat/test-smk-absDS.R index 54655c99..6b2f9a76 100644 --- a/tests/testthat/test-smk-absDS.R +++ b/tests/testthat/test-smk-absDS.R @@ -20,16 +20,6 @@ # # 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)) -}) - test_that("simple absDS, NaN", { input <- NaN @@ -167,7 +157,6 @@ test_that("simple absDS", { expect_equal(res[5], 50L) expect_equal(res[6], 20L) }) - # # Done # diff --git a/tests/testthat/test-smk-asDataMatrixDS.R b/tests/testthat/test-smk-asDataMatrixDS.R index eaed9318..6529b1ab 100644 --- a/tests/testthat/test-smk-asDataMatrixDS.R +++ b/tests/testthat/test-smk-asDataMatrixDS.R @@ -55,7 +55,6 @@ test_that("simple asDataMatrixDS", { expect_equal(res.colnames[1], "v1") expect_equal(res.colnames[2], "v2") }) - # # Done # diff --git a/tests/testthat/test-smk-asFactorSimpleDS.R b/tests/testthat/test-smk-asFactorSimpleDS.R index dd5a17dc..7e871da3 100644 --- a/tests/testthat/test-smk-asFactorSimpleDS.R +++ b/tests/testthat/test-smk-asFactorSimpleDS.R @@ -1,6 +1,5 @@ #------------------------------------------------------------------------------- # Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved. -# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved. # # This program and the accompanying materials # are made available under the terms of the GNU Public License v3.0. diff --git a/tests/testthat/test-smk-asIntegerDS.R b/tests/testthat/test-smk-asIntegerDS.R index 2ed33a33..1fc8445b 100644 --- a/tests/testthat/test-smk-asIntegerDS.R +++ b/tests/testthat/test-smk-asIntegerDS.R @@ -70,7 +70,6 @@ test_that("character vector asIntegerDS", { expect_equal(res[4], 404) expect_equal(res[5], 505) }) - # # Done # diff --git a/tests/testthat/test-smk-asListDS.R b/tests/testthat/test-smk-asListDS.R index 5d448109..1ac8ac68 100644 --- a/tests/testthat/test-smk-asListDS.R +++ b/tests/testthat/test-smk-asListDS.R @@ -29,15 +29,9 @@ 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 # diff --git a/tests/testthat/test-smk-asLogicalDS.R b/tests/testthat/test-smk-asLogicalDS.R index 3ea78d6e..41ef866e 100644 --- a/tests/testthat/test-smk-asLogicalDS.R +++ b/tests/testthat/test-smk-asLogicalDS.R @@ -166,7 +166,6 @@ test_that("simple asLogicalDS, character vector", { expect_equal(res[5], FALSE) expect_equal(res[6], FALSE) }) - # # Done # diff --git a/tests/testthat/test-smk-asMatrixDS.R b/tests/testthat/test-smk-asMatrixDS.R index 71222625..ba759e27 100644 --- a/tests/testthat/test-smk-asMatrixDS.R +++ b/tests/testthat/test-smk-asMatrixDS.R @@ -55,7 +55,6 @@ test_that("simple asMatrixDS", { expect_equal(res.colnames[1], "v1") expect_equal(res.colnames[2], "v2") }) - # # Done # diff --git a/tests/testthat/test-smk-asNumericDS.R b/tests/testthat/test-smk-asNumericDS.R index c18782b8..4ace90f5 100644 --- a/tests/testthat/test-smk-asNumericDS.R +++ b/tests/testthat/test-smk-asNumericDS.R @@ -226,7 +226,6 @@ test_that("integer vector asNumericDS", { expect_equal(res[4], 2) expect_equal(res[5], 1) }) - # # 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-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-sqrtDS.R b/tests/testthat/test-smk-sqrtDS.R index fe9ac9eb..273baec1 100644 --- a/tests/testthat/test-smk-sqrtDS.R +++ b/tests/testthat/test-smk-sqrtDS.R @@ -20,16 +20,6 @@ # # 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)) -}) - test_that("simple sqrtDS, NaN", { input <- NaN @@ -166,7 +156,6 @@ test_that("simple sqrtDS", { expect_true(is.nan(res[5])) expect_true(is.nan(res[6])) }) - # # Done # diff --git a/tests/testthat/test-smk-utils.R b/tests/testthat/test-smk-utils.R index 2bb2db76..131454e1 100644 --- a/tests/testthat/test-smk-utils.R +++ b/tests/testthat/test-smk-utils.R @@ -27,9 +27,23 @@ test_that(".loadServersideObject() returns existing object", { 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("test_df"), + .dsFunctionWrapper("no_such_object"), regexp = "does not exist" ) })