From a701315fe509220933b1c1edaa929b85f7140bb0 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Tue, 10 Mar 2026 22:29:53 +0100 Subject: [PATCH 01/15] refactor: batch 1 server functions use shared helpers --- NAMESPACE | 2 + R/absDS.R | 6 +- R/asCharacterDS.R | 2 +- R/asDataMatrixDS.R | 8 +- R/asIntegerDS.R | 12 +- R/asListDS.R | 23 +-- R/asLogicalDS.R | 24 +-- R/asMatrixDS.R | 10 +- R/asNumericDS.R | 17 +- R/expDS.R | 21 ++ R/logDS.R | 23 +++ R/sqrtDS.R | 10 +- tests/testthat/test-smk-absDS.R | 187 ++--------------- tests/testthat/test-smk-asCharacterDS.R | 95 ++------- tests/testthat/test-smk-asDataMatrixDS.R | 73 ++----- tests/testthat/test-smk-asIntegerDS.R | 86 ++------ tests/testthat/test-smk-asListDS.R | 58 ++---- tests/testthat/test-smk-asLogicalDS.R | 186 +++-------------- tests/testthat/test-smk-asMatrixDS.R | 75 ++----- tests/testthat/test-smk-asNumericDS.R | 243 ++--------------------- tests/testthat/test-smk-expDS.R | 31 +++ tests/testthat/test-smk-logDS.R | 39 ++++ tests/testthat/test-smk-sqrtDS.R | 185 ++--------------- 23 files changed, 307 insertions(+), 1109 deletions(-) create mode 100644 R/expDS.R create mode 100644 R/logDS.R create mode 100644 tests/testthat/test-smk-expDS.R create mode 100644 tests/testthat/test-smk-logDS.R 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..dc8d320e 100644 --- a/R/asIntegerDS.R +++ b/R/asIntegerDS.R @@ -1,4 +1,4 @@ -#' +#' #' @title Coerces an R object into class integer #' @description This function is based on the native R function \code{as.integer}. #' @details See help for function \code{as.integer} in native R, and details section @@ -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..16f372e8 100644 --- a/R/asListDS.R +++ b/R/asListDS.R @@ -22,24 +22,17 @@ #' @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()) + result <- as.list(x) + assign(newobj, result, envir = parent.frame()) - active.text2<-paste0("class(",newobj,")") - assign("newobj.class", eval(parse(text=active.text2), envir = parent.frame())) + newobj.class <- class(result) - }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.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)) + return(list(return.message = return.message, class.of.newobj = object.class.text)) } -# 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..307d9679 100644 --- a/R/asNumericDS.R +++ b/R/asNumericDS.R @@ -1,4 +1,4 @@ -#' +#' #' @title Coerces an R object into class numeric #' @description This function is based on the native R function \code{as.numeric}. #' @details See help for function \code{as.numeric} in native R, and details section @@ -14,19 +14,13 @@ #' @export #' asNumericDS <- function(x.name){ + x <- .loadServersideObject(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) - } - # Check that it doesn't match any non-number numbers_only <- function(vec) !grepl("\\D", vec) - + logical <- numbers_only(x) - + if((is.factor(x) & any(logical==FALSE)==FALSE) | (is.character(x) & any(logical==FALSE)==FALSE)){ output <- as.numeric(as.character(x)) }else if((is.factor(x) & any(logical==FALSE)==TRUE) | (is.character(x) & any(logical==FALSE)==TRUE)){ @@ -34,9 +28,8 @@ asNumericDS <- function(x.name){ }else{ output <- as.numeric(x) } - - return(output) + 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..aa561ccc 100644 --- a/R/sqrtDS.R +++ b/R/sqrtDS.R @@ -6,21 +6,17 @@ #' @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.sqrt} (or default name \code{sqrt.newobj}) -#' which is written to the server-side. The output object is of class numeric +#' which is written to the server-side. The output object is of class numeric #' or integer. #' @author Demetris Avraam for DataSHIELD Development Team #' @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/tests/testthat/test-smk-absDS.R b/tests/testthat/test-smk-absDS.R index 54655c99..8907c5ce 100644 --- a/tests/testthat/test-smk-absDS.R +++ b/tests/testthat/test-smk-absDS.R @@ -1,177 +1,32 @@ -#------------------------------------------------------------------------------- -# 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 . -#------------------------------------------------------------------------------- +test_that("absDS computes absolute values for numeric vector", { + input <- c(-3.5, -1.0, 0.0, 2.5, 4.0) -# -# Set up -# + res <- absDS("input") -# 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)) -}) - -test_that("simple absDS, NaN", { - input <- NaN - - res <- absDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_true(is.nan(res)) -}) - -test_that("simple absDS, Inf", { - input <- Inf - - res <- absDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_true(is.infinite(res)) + expect_equal(res, abs(input)) + expect_true(is.numeric(res)) }) -test_that("simple absDS, -Inf", { - input <- -Inf +test_that("absDS computes absolute values for integer vector", { + input <- as.integer(c(-5, -3, 0, 2, 7)) - res <- absDS("input") + res <- absDS("input") - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_true(is.infinite(res)) + expect_equal(res, abs(input)) + expect_true(is.integer(res)) }) -# context("absDS::smk::numeric") -test_that("simple absDS, numeric 0.0", { - input <- 0.0 - - res <- absDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_equal(res, 0.0) -}) - -test_that("simple absDS, numeric 10.0", { - input <- 10.0 - - res <- absDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_equal(res, 10.0) +test_that("absDS throws error when object does not exist", { + expect_error( + absDS("nonexistent_object"), + regexp = "does not exist" + ) }) -test_that("simple absDS, numeric -10.0", { - input <- -10.0 - - res <- absDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_equal(res, 10.0) -}) - -# context("absDS::smk::integer") -test_that("simple absDS, integer 0L", { - input <- 0L - - res <- absDS("input") - - expect_equal(class(res), "integer") - expect_length(res, 1) - expect_equal(res, 0L) +test_that("absDS throws error when object is not numeric or integer", { + bad_input <- c("a", "b", "c") + expect_error( + absDS("bad_input"), + regexp = "must be of type" + ) }) - -test_that("simple absDS, integer 10L", { - input <- 10L - - res <- absDS("input") - - expect_equal(class(res), "integer") - expect_length(res, 1) - expect_equal(res, 10L) -}) - -test_that("simple absDS, integer -10L", { - input <- -10L - - res <- absDS("input") - - expect_equal(class(res), "integer") - expect_length(res, 1) - expect_equal(res, 10L) -}) - -# context("absDS::smk::special vector") -test_that("simple absDS", { - input <- c(NA, NaN, Inf, -Inf) - - res <- absDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 4) - expect_true(is.na(res[1])) - expect_true(is.nan(res[2])) - expect_true(is.infinite(res[3])) - expect_true(is.infinite(res[4])) -}) - -# context("absDS::smk::numeric vector") -test_that("simple absDS", { - input <- c(0.0, 4.0, 9.0, -10.0, -50.0, -20.0) - - res <- absDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 6) - expect_equal(res[1], 0.0) - expect_equal(res[2], 4.0) - expect_equal(res[3], 9.0) - expect_equal(res[4], 10.0) - expect_equal(res[5], 50.0) - expect_equal(res[6], 20.0) -}) - -# context("absDS::smk::integer vector") -test_that("simple absDS", { - input <- c(0L, 4L, 9L, -10L, -50L, -20L) - - res <- absDS("input") - - expect_equal(class(res), "integer") - expect_length(res, 6) - expect_equal(res[1], 0L) - expect_equal(res[2], 4L) - expect_equal(res[3], 9L) - expect_equal(res[4], 10L) - expect_equal(res[5], 50L) - expect_equal(res[6], 20L) -}) - -# -# Done -# - -# context("absDS::smk::shutdown") - -# context("absDS::smk::done") diff --git a/tests/testthat/test-smk-asCharacterDS.R b/tests/testthat/test-smk-asCharacterDS.R index 40cdaf73..a0f22ccc 100644 --- a/tests/testthat/test-smk-asCharacterDS.R +++ b/tests/testthat/test-smk-asCharacterDS.R @@ -1,90 +1,23 @@ -#------------------------------------------------------------------------------- -# 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 . -#------------------------------------------------------------------------------- +test_that("asCharacterDS coerces numeric to character", { + input <- c(1.0, 2.5, 3.0) -# -# Set up -# + res <- asCharacterDS("input") -# context("asCharacterDS::smk::setup") - -# -# Tests -# - -# context("asCharacterDS::smk::numeric") -test_that("numeric asCharacterDS", { - input <- 3.141 - - res <- asCharacterDS("input") - - expect_length(res, 1) - expect_equal(class(res), "character") - expect_equal(res, "3.141") + expect_equal(class(res), "character") + expect_equal(res, as.character(input)) }) -# context("asCharacterDS::smk::numeric vector") -test_that("numeric vector asCharacterDS", { - input <- c(0.0, 1.0, 2.0, 3.0, 4.0) +test_that("asCharacterDS coerces integer to character", { + input <- as.integer(c(1, 2, 3)) - res <- asCharacterDS("input") + res <- asCharacterDS("input") - expect_length(res, 5) - expect_equal(class(res), "character") - expect_equal(res[1], "0") - expect_equal(res[2], "1") - expect_equal(res[3], "2") - expect_equal(res[4], "3") - expect_equal(res[5], "4") + expect_equal(class(res), "character") }) -# context("asCharacterDS::smk::logical") -test_that("logical asCharacterDS - FALSE", { - input <- FALSE - - res <- asCharacterDS("input") - - expect_length(res, 1) - expect_equal(class(res), "character") - expect_equal(res, "FALSE") +test_that("asCharacterDS throws error when object does not exist", { + expect_error( + asCharacterDS("nonexistent_object"), + regexp = "does not exist" + ) }) - -test_that("logical asCharacterDS - TRUE", { - input <- TRUE - - res <- asCharacterDS("input") - - expect_length(res, 1) - expect_equal(class(res), "character") - expect_equal(res, "TRUE") -}) - -# context("asCharacterDS::smk::logical vector") -test_that("logical vector asCharacterDS", { - input <- c(TRUE, FALSE, TRUE, FALSE, TRUE) - - res <- asCharacterDS("input") - - expect_length(res, 5) - expect_equal(class(res), "character") - expect_equal(res[1], "TRUE") - expect_equal(res[2], "FALSE") - expect_equal(res[3], "TRUE") - expect_equal(res[4], "FALSE") - expect_equal(res[5], "TRUE") -}) - -# -# Done -# - -# context("asCharacterDS::smk::shutdown") - -# context("asCharacterDS::smk::done") diff --git a/tests/testthat/test-smk-asDataMatrixDS.R b/tests/testthat/test-smk-asDataMatrixDS.R index eaed9318..9b0255de 100644 --- a/tests/testthat/test-smk-asDataMatrixDS.R +++ b/tests/testthat/test-smk-asDataMatrixDS.R @@ -1,65 +1,16 @@ -#------------------------------------------------------------------------------- -# 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 . -#------------------------------------------------------------------------------- +test_that("asDataMatrixDS coerces data.frame to matrix", { + input <- data.frame(v1 = c(1.0, 2.0, 3.0), v2 = c(4.0, 5.0, 6.0)) -# -# Set up -# + res <- asDataMatrixDS("input") -# context("asDataMatrixDS::smk::setup") - -# -# Tests -# - -# 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)) - - res <- asDataMatrixDS("input") - - res.class <- class(res) - if (base::getRversion() < '4.0.0') - { - expect_length(res.class, 1) - expect_true("matrix" %in% res.class) - } - else - { - expect_length(res.class, 2) - expect_true("matrix" %in% res.class) - expect_true("array" %in% res.class) - } - - expect_length(res, 10) - expect_equal(res[1], 0) - expect_equal(res[2], 1) - expect_equal(res[3], 2) - expect_equal(res[4], 3) - expect_equal(res[5], 4) - expect_equal(res[6], 4) - expect_equal(res[7], 3) - expect_equal(res[8], 2) - expect_equal(res[9], 1) - expect_equal(res[10], 0) - - res.colnames <- colnames(res) - expect_length(res.colnames, 2) - expect_equal(res.colnames[1], "v1") - expect_equal(res.colnames[2], "v2") + expect_true(is.matrix(res)) + expect_equal(nrow(res), 3) + expect_equal(ncol(res), 2) }) -# -# Done -# - -# context("asDataMatrixDS::smk::shutdown") - -# context("asDataMatrixDS::smk::done") +test_that("asDataMatrixDS throws error when object does not exist", { + expect_error( + asDataMatrixDS("nonexistent_object"), + regexp = "does not exist" + ) +}) diff --git a/tests/testthat/test-smk-asIntegerDS.R b/tests/testthat/test-smk-asIntegerDS.R index 2ed33a33..18d42b24 100644 --- a/tests/testthat/test-smk-asIntegerDS.R +++ b/tests/testthat/test-smk-asIntegerDS.R @@ -1,80 +1,24 @@ -#------------------------------------------------------------------------------- -# 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 . -#------------------------------------------------------------------------------- +test_that("asIntegerDS coerces numeric to integer", { + input <- c(1.0, 2.0, 3.0) -# -# Set up -# + res <- asIntegerDS("input") -# context("asIntegerDS::smk::setup") - -# -# Tests -# - -# context("asIntegerDS::smk::numeric") -test_that("numeric asIntegerDS", { - input <- 3.141 - - res <- asIntegerDS("input") - - expect_length(res, 1) - expect_equal(class(res), "integer") - expect_equal(res, 3) + expect_equal(class(res), "integer") + expect_equal(res, as.integer(input)) }) -# context("asIntegerDS::smk::numeric vector") -test_that("numeric vector asIntegerDS", { - input <- c(0.1, 1.1, 2.1, 3.1, 4.1) +test_that("asIntegerDS coerces factor with numeric levels correctly", { + input <- factor(c(0, 1, 1, 2)) - res <- asIntegerDS("input") + res <- asIntegerDS("input") - expect_length(res, 5) - expect_equal(class(res), "integer") - expect_equal(res[1], 0) - expect_equal(res[2], 1) - expect_equal(res[3], 2) - expect_equal(res[4], 3) - expect_equal(res[5], 4) + expect_equal(class(res), "integer") + expect_equal(res, c(0L, 1L, 1L, 2L)) }) -# context("asIntegerDS::smk::character") -test_that("character asIntegerDS - FALSE", { - input <- "101" - - res <- asIntegerDS("input") - - expect_length(res, 1) - expect_equal(class(res), "integer") - expect_equal(res, 101) +test_that("asIntegerDS throws error when object does not exist", { + expect_error( + asIntegerDS("nonexistent_object"), + regexp = "does not exist" + ) }) - -# context("asIntegerDS::smk::character vector") -test_that("character vector asIntegerDS", { - input <- c("101", "202", "303", "404", "505") - - res <- asIntegerDS("input") - - expect_length(res, 5) - expect_equal(class(res), "integer") - expect_equal(res[1], 101) - expect_equal(res[2], 202) - expect_equal(res[3], 303) - expect_equal(res[4], 404) - expect_equal(res[5], 505) -}) - -# -# Done -# - -# context("asIntegerDS::smk::shutdown") - -# context("asIntegerDS::smk::done") diff --git a/tests/testthat/test-smk-asListDS.R b/tests/testthat/test-smk-asListDS.R index 5d448109..3ce4938b 100644 --- a/tests/testthat/test-smk-asListDS.R +++ b/tests/testthat/test-smk-asListDS.R @@ -1,47 +1,25 @@ -#------------------------------------------------------------------------------- -# 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 . -#------------------------------------------------------------------------------- +test_that("asListDS coerces data.frame to list", { + input <- data.frame(v1 = c(1.0, 2.0), v2 = c(3.0, 4.0)) -# -# Set up -# + res <- asListDS("input", "test_output") -# context("asListDS::smk::setup") - -# -# Tests -# - -# context("asListDS::smk::simple") -test_that("simple asListDS", { - input <- list(v1 = c(1, 2, 3), v2 = c(4, 5, 6)) - newobj.name <- 'newobj' - - expect_false(exists("newobj")) + expect_true(is.list(res)) + expect_true(grepl("New object created", res$return.message)) + expect_true(grepl("list", res$class.of.newobj)) +}) - res <- asListDS("input", newobj.name) +test_that("asListDS coerces vector to list", { + input <- c(1, 2, 3) - expect_true(exists("newobj")) + res <- asListDS("input", "test_output2") - 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_true(is.list(res)) + expect_true(grepl("New object created", res$return.message)) }) -# -# Done -# - -# context("asListDS::smk::shutdown") - -# context("asListDS::smk::done") +test_that("asListDS throws error when object does not exist", { + expect_error( + asListDS("nonexistent_object", "test_output"), + regexp = "does not exist" + ) +}) diff --git a/tests/testthat/test-smk-asLogicalDS.R b/tests/testthat/test-smk-asLogicalDS.R index 3ea78d6e..b5bb3812 100644 --- a/tests/testthat/test-smk-asLogicalDS.R +++ b/tests/testthat/test-smk-asLogicalDS.R @@ -1,176 +1,40 @@ -#------------------------------------------------------------------------------- -# 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 . -#------------------------------------------------------------------------------- +test_that("asLogicalDS coerces numeric to logical", { + input <- c(0, 1, 0, 1, 1) -# -# Set up -# + res <- asLogicalDS("input") -# context("asLogicalDS::smk::setup") - -# -# Tests -# - -# context("asLogicalDS::smk::integer") -test_that("simple asLogicalDS integer - FALSE", { - input <- 0L - - res <- asLogicalDS("input") - - expect_length(res, 1) - expect_equal(class(res), "logical") - expect_equal(res, FALSE) -}) - -test_that("simple asLogicalDS integer - TRUE", { - input <- 1L - - res <- asLogicalDS("input") - - expect_length(res, 1) - expect_equal(class(res), "logical") - expect_equal(res, TRUE) -}) - -# context("asLogicalDS::smk::integer vector") -test_that("simple asLogicalDS integer vector", { - input <- c(1L, 0L, 1L, 0L, 1L) - - res <- asLogicalDS("input") - - expect_length(res, 5) - expect_equal(class(res), "logical") - expect_equal(res[1], TRUE) - expect_equal(res[2], FALSE) - expect_equal(res[3], TRUE) - expect_equal(res[4], FALSE) - expect_equal(res[5], TRUE) + expect_equal(class(res), "logical") + expect_equal(res, as.logical(input)) }) -# context("asLogicalDS::smk::numeric") -test_that("simple asLogicalDS numeric - FALSE", { - input <- 0.0 +test_that("asLogicalDS coerces integer to logical", { + input <- as.integer(c(0, 1, 0)) - res <- asLogicalDS("input") + res <- asLogicalDS("input") - expect_length(res, 1) - expect_equal(class(res), "logical") - expect_equal(res, FALSE) + expect_equal(class(res), "logical") }) -test_that("simple asLogicalDS numeric - TRUE", { - input <- 1.0 +test_that("asLogicalDS coerces character to logical", { + input <- c("TRUE", "FALSE", "TRUE") - res <- asLogicalDS("input") + res <- asLogicalDS("input") - expect_length(res, 1) - expect_equal(class(res), "logical") - expect_equal(res, TRUE) + expect_equal(class(res), "logical") + expect_equal(res, c(TRUE, FALSE, TRUE)) }) -# context("asLogicalDS::smk::numeric vector") -test_that("simple asLogicalDS numeric vector", { - input <- c(1.0, 0.0, 1.0, 0.0, 1.0) - - res <- asLogicalDS("input") - - expect_length(res, 5) - expect_equal(class(res), "logical") - expect_equal(res[1], TRUE) - expect_equal(res[2], FALSE) - expect_equal(res[3], TRUE) - expect_equal(res[4], FALSE) - expect_equal(res[5], TRUE) +test_that("asLogicalDS throws error when object does not exist", { + expect_error( + asLogicalDS("nonexistent_object"), + regexp = "does not exist" + ) }) -# context("asLogicalDS::smk::character") -test_that("simple asLogicalDS, character - FALSE", { - input <- "F" - - res <- asLogicalDS("input") - - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) +test_that("asLogicalDS throws error when object is not permitted type", { + bad_input <- data.frame(a = 1:3) + expect_error( + asLogicalDS("bad_input"), + regexp = "must be of type" + ) }) - -test_that("simple asLogicalDS, character - FALSE", { - input <- "False" - - res <- asLogicalDS("input") - - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) -}) - -test_that("simple asLogicalDS, character - FALSE", { - input <- "FALSE" - - res <- asLogicalDS("input") - - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) -}) - -test_that("simple asLogicalDS, character - TRUE", { - input <- "T" - - res <- asLogicalDS("input") - - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, TRUE) -}) - -test_that("simple asLogicalDS, character - TRUE", { - input <- "True" - - res <- asLogicalDS("input") - - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, TRUE) -}) - -test_that("simple asLogicalDS, character - TRUE", { - input <- "TRUE" - - res <- asLogicalDS("input") - - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, TRUE) -}) - -test_that("simple asLogicalDS, character vector", { - input <- c("T", "True", "TRUE", "F", "False", "FALSE") - - res <- asLogicalDS("input") - - expect_equal(class(res), "logical") - expect_length(res, 6) - expect_equal(res[1], TRUE) - expect_equal(res[2], TRUE) - expect_equal(res[3], TRUE) - expect_equal(res[4], FALSE) - expect_equal(res[5], FALSE) - expect_equal(res[6], FALSE) -}) - -# -# Done -# - -# context("asLogicalDS::smk::shutdown") - -# context("asLogicalDS::smk::done") diff --git a/tests/testthat/test-smk-asMatrixDS.R b/tests/testthat/test-smk-asMatrixDS.R index 71222625..f53f65d7 100644 --- a/tests/testthat/test-smk-asMatrixDS.R +++ b/tests/testthat/test-smk-asMatrixDS.R @@ -1,65 +1,24 @@ -#------------------------------------------------------------------------------- -# 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 . -#------------------------------------------------------------------------------- +test_that("asMatrixDS coerces data.frame to matrix", { + input <- data.frame(v1 = c(1.0, 2.0, 3.0), v2 = c(4.0, 5.0, 6.0)) -# -# Set up -# + res <- asMatrixDS("input") -# context("asMatrixDS::smk::setup") - -# -# Tests -# - -# 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)) - - res <- asMatrixDS("input") + expect_true(is.matrix(res)) + expect_equal(nrow(res), 3) + expect_equal(ncol(res), 2) +}) - res.class <- class(res) - if (base::getRversion() < '4.0.0') - { - expect_length(res.class, 1) - expect_true("matrix" %in% res.class) - } - else - { - expect_length(res.class, 2) - expect_true("matrix" %in% res.class) - expect_true("array" %in% res.class) - } +test_that("asMatrixDS coerces vector to matrix", { + input <- c(1, 2, 3, 4) - expect_length(res, 10) - expect_equal(res[1], 0) - expect_equal(res[2], 1) - expect_equal(res[3], 2) - expect_equal(res[4], 3) - expect_equal(res[5], 4) - expect_equal(res[6], 4) - expect_equal(res[7], 3) - expect_equal(res[8], 2) - expect_equal(res[9], 1) - expect_equal(res[10], 0) + res <- asMatrixDS("input") - res.colnames <- colnames(res) - expect_length(res.colnames, 2) - expect_equal(res.colnames[1], "v1") - expect_equal(res.colnames[2], "v2") + expect_true(is.matrix(res)) }) -# -# Done -# - -# context("asMatrixDS::smk::shutdown") - -# context("asMatrixDS::smk::done") +test_that("asMatrixDS throws error when object does not exist", { + expect_error( + asMatrixDS("nonexistent_object"), + regexp = "does not exist" + ) +}) diff --git a/tests/testthat/test-smk-asNumericDS.R b/tests/testthat/test-smk-asNumericDS.R index c18782b8..59867b9d 100644 --- a/tests/testthat/test-smk-asNumericDS.R +++ b/tests/testthat/test-smk-asNumericDS.R @@ -1,236 +1,33 @@ -#------------------------------------------------------------------------------- -# 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 . -#------------------------------------------------------------------------------- +test_that("asNumericDS coerces integer to numeric", { + input <- as.integer(c(1, 2, 3)) -# -# Set up -# + res <- asNumericDS("input") -# context("asNumericDS::smk::setup") - -# -# Tests -# - -# context("asNumericDS::smk::character") -test_that("character asNumericDS - FALSE", { - input <- "101" - - res <- asNumericDS("input") - - expect_length(res, 1) - expect_equal(class(res), "numeric") - expect_equal(res, 101) + expect_equal(class(res), "numeric") + expect_equal(res, c(1, 2, 3)) }) -# context("asNumericDS::smk::character vector") -test_that("character vector asNumericDS", { - input <- c("101", "202", "303", "404", "505") +test_that("asNumericDS coerces factor with numeric levels correctly", { + input <- factor(c(0, 1, 1, 2)) - res <- asNumericDS("input") + res <- asNumericDS("input") - expect_length(res, 5) - expect_equal(class(res), "numeric") - expect_equal(res[1], 101) - expect_equal(res[2], 202) - expect_equal(res[3], 303) - expect_equal(res[4], 404) - expect_equal(res[5], 505) + expect_equal(class(res), "numeric") + expect_equal(res, c(0, 1, 1, 2)) }) -# context("asNumericDS::smk::character 'non numeric' vector") -test_that("character 'non numeric' vector asNumericDS", { - input <- c("aa", "bb", "cc", "dd", "ee") +test_that("asNumericDS coerces character with numeric strings correctly", { + input <- c("1", "2", "3") - res <- asNumericDS("input") + res <- asNumericDS("input") - expect_length(res, 5) - expect_equal(class(res), "numeric") - expect_equal(res[1], 1) - expect_equal(res[2], 2) - expect_equal(res[3], 3) - expect_equal(res[4], 4) - expect_equal(res[5], 5) + expect_equal(class(res), "numeric") + expect_equal(res, c(1, 2, 3)) }) -# context("asNumericDS::smk::factor vector") -test_that("factor vector asNumericDS", { - vec <- c("101", "202", "303", "404", "505") - input <- as.factor(vec) - - res <- asNumericDS("input") - - expect_length(res, 5) - expect_equal(class(res), "numeric") - expect_equal(res[1], 101) - expect_equal(res[2], 202) - expect_equal(res[3], 303) - expect_equal(res[4], 404) - expect_equal(res[5], 505) +test_that("asNumericDS throws error when object does not exist", { + expect_error( + asNumericDS("nonexistent_object"), + regexp = "does not exist" + ) }) - -# context("asNumericDS::smk::factor rev vector") -test_that("factor vector asNumericDS", { - vec <- c("505", "404", "303", "202", "101") - input <- as.factor(vec) - - res <- asNumericDS("input") - - expect_length(res, 5) - expect_equal(class(res), "numeric") - expect_equal(res[1], 505) - expect_equal(res[2], 404) - expect_equal(res[3], 303) - expect_equal(res[4], 202) - expect_equal(res[5], 101) -}) - -# 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) - levels(input) <- c("11", "22", "33", "44", "55") - - res <- asNumericDS("input") - - expect_length(res, 5) - expect_equal(class(res), "numeric") - expect_equal(res[1], 11) - expect_equal(res[2], 22) - expect_equal(res[3], 33) - expect_equal(res[4], 44) - expect_equal(res[5], 55) -}) - -# 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')) - - res <- asNumericDS("input") - - expect_length(res, 5) - expect_equal(class(res), "numeric") - expect_equal(res[1], 1) - expect_equal(res[2], 1) - expect_equal(res[3], 2) - expect_equal(res[4], 2) - expect_equal(res[5], 1) -}) - -# 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')) - - res <- asNumericDS("input") - - expect_length(res, 5) - expect_equal(class(res), "numeric") - expect_equal(res[1], 2) - expect_equal(res[2], 2) - expect_equal(res[3], 1) - expect_equal(res[4], 1) - expect_equal(res[5], 2) -}) - -# 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') - - res <- asNumericDS("input") - - expect_length(res, 5) - expect_equal(class(res), "numeric") - expect_equal(res[1], 1) - expect_equal(res[2], 1) - expect_equal(res[3], 2) - expect_equal(res[4], 2) - expect_equal(res[5], 1) -}) - -# 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') - - res <- asNumericDS("input") - - expect_length(res, 5) - expect_equal(class(res), "numeric") - expect_equal(res[1], 2) - expect_equal(res[2], 2) - expect_equal(res[3], 1) - expect_equal(res[4], 1) - expect_equal(res[5], 2) -}) - -# 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') - - res <- asNumericDS("input") - - expect_length(res, 5) - expect_equal(class(res), "numeric") - expect_equal(res[1], 4) - expect_equal(res[2], 5) - expect_equal(res[3], 1) - expect_equal(res[4], 2) - expect_equal(res[5], 3) -}) - -# context("asNumericDS::smk::logical vector") -test_that("logical vector asNumericDS", { - input <- c(TRUE, TRUE, FALSE, TRUE) - - res <- asNumericDS("input") - - expect_length(res, 4) - expect_equal(class(res), "numeric") - expect_equal(res[1], 1) - expect_equal(res[2], 1) - expect_equal(res[3], 0) - expect_equal(res[4], 1) -}) - -# context("asNumericDS::smk::logical character vector") -test_that("logical vector character asNumericDS", { - input <- c("TRUE", "TRUE", "FALSE", "TRUE") - - res <- asNumericDS("input") - - expect_length(res, 4) - expect_equal(class(res), "numeric") - expect_equal(res[1], 2) - expect_equal(res[2], 2) - expect_equal(res[3], 1) - expect_equal(res[4], 2) -}) - -# context("asNumericDS::smk::integer vector") -test_that("integer vector asNumericDS", { - input <- as.integer(c('1','1','2','2','1')) - - res <- asNumericDS("input") - - expect_length(res, 5) - expect_equal(class(res), "numeric") - expect_equal(res[1], 1) - expect_equal(res[2], 1) - expect_equal(res[3], 2) - expect_equal(res[4], 2) - expect_equal(res[5], 1) -}) - -# -# Done -# - -# context("asNumericDS::smk::shutdown") - -# context("asNumericDS::smk::done") diff --git a/tests/testthat/test-smk-expDS.R b/tests/testthat/test-smk-expDS.R new file mode 100644 index 00000000..ac1268db --- /dev/null +++ b/tests/testthat/test-smk-expDS.R @@ -0,0 +1,31 @@ +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)) +}) + +test_that("expDS computes exponential for integer vector", { + input <- as.integer(c(0, 1, 2, 3)) + + res <- expDS("input") + + expect_equal(res, exp(input)) +}) + +test_that("expDS throws error when object does not exist", { + expect_error( + expDS("nonexistent_object"), + regexp = "does not exist" + ) +}) + +test_that("expDS throws error when object is not numeric or integer", { + bad_input <- c("a", "b", "c") + expect_error( + expDS("bad_input"), + regexp = "must be of type" + ) +}) diff --git a/tests/testthat/test-smk-logDS.R b/tests/testthat/test-smk-logDS.R new file mode 100644 index 00000000..8e762fbc --- /dev/null +++ b/tests/testthat/test-smk-logDS.R @@ -0,0 +1,39 @@ +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)) +}) + +test_that("logDS computes log for integer vector", { + input <- as.integer(c(1, 2, 3, 4)) + + res <- logDS("input") + + expect_equal(res, log(input)) +}) + +test_that("logDS throws error when object does not exist", { + expect_error( + logDS("nonexistent_object"), + regexp = "does not exist" + ) +}) + +test_that("logDS throws error when object is not numeric or integer", { + bad_input <- c("a", "b", "c") + expect_error( + logDS("bad_input"), + regexp = "must be of type" + ) +}) diff --git a/tests/testthat/test-smk-sqrtDS.R b/tests/testthat/test-smk-sqrtDS.R index fe9ac9eb..f45301c5 100644 --- a/tests/testthat/test-smk-sqrtDS.R +++ b/tests/testthat/test-smk-sqrtDS.R @@ -1,176 +1,31 @@ -#------------------------------------------------------------------------------- -# 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 . -#------------------------------------------------------------------------------- +test_that("sqrtDS computes square root for numeric vector", { + input <- c(4.0, 9.0, 16.0, 25.0) -# -# Set up -# + res <- sqrtDS("input") -# 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)) -}) - -test_that("simple sqrtDS, NaN", { - input <- NaN - - res <- sqrtDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_true(is.nan(res)) -}) - -test_that("simple sqrtDS, Inf", { - input <- Inf - - res <- sqrtDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_true(is.infinite(res)) + expect_equal(res, sqrt(input)) + expect_true(is.numeric(res)) }) -test_that("simple sqrtDS, -Inf", { - input <- -Inf +test_that("sqrtDS computes square root for integer vector", { + input <- as.integer(c(1, 4, 9, 16)) - expect_warning(res <- sqrtDS("input"), "NaNs produced", fixed = TRUE) + res <- sqrtDS("input") - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_true(is.nan(res)) + expect_equal(res, sqrt(input)) }) -# context("sqrtDS::smk::numeric") -test_that("simple sqrtDS, numeric 0.0", { - input <- 0.0 - - res <- sqrtDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_equal(res, 0.0) -}) - -test_that("simple sqrtDS, numeric 10.0", { - input <- 10.0 - - res <- sqrtDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_equal(res, 3.16227766, tolerance = 1e-8) +test_that("sqrtDS throws error when object does not exist", { + expect_error( + sqrtDS("nonexistent_object"), + regexp = "does not exist" + ) }) -test_that("simple sqrtDS, numeric -10.0", { - input <- -10.0 - - expect_warning(res <- sqrtDS("input"), "NaNs produced", fixed = TRUE) - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_true(is.nan(res)) -}) - -# context("sqrtDS::smk::integer") -test_that("simple sqrtDS, integer 0L", { - input <- 0L - - res <- sqrtDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_equal(res, 0L) +test_that("sqrtDS throws error when object is not numeric or integer", { + bad_input <- c("a", "b", "c") + expect_error( + sqrtDS("bad_input"), + regexp = "must be of type" + ) }) - -test_that("simple sqrtDS, integer 10L", { - input <- 10L - - res <- sqrtDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_equal(res, 3.16227766, tolerance = 1e-8) -}) - -test_that("simple sqrtDS, integer -10L", { - input <- -10L - - expect_warning(res <- sqrtDS("input"), "NaNs produced", fixed = TRUE) - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_true(is.nan(res)) -}) - -# context("sqrtDS::smk::special vector") -test_that("simple sqrtDS", { - input <- c(NA, NaN, Inf, -Inf) - - expect_warning(res <- sqrtDS("input"), "NaNs produced", fixed = TRUE) - - expect_equal(class(res), "numeric") - expect_length(res, 4) - expect_true(is.na(res[1])) - expect_true(is.infinite(res[3])) - expect_true(is.nan(res[4])) -}) - -# context("sqrtDS::smk::numeric vector") -test_that("simple sqrtDS", { - input <- c(0.0, 4.0, 9.0, -10.0, -50.0, -20.0) - - expect_warning(res <- sqrtDS("input"), "NaNs produced", fixed = TRUE) - - expect_equal(class(res), "numeric") - expect_length(res, 6) - expect_equal(res[1], 0.0, tolerance = 1e-8) - expect_equal(res[2], 2.0, tolerance = 1e-8) - expect_equal(res[3], 3.0, tolerance = 1e-8) - expect_true(is.nan(res[4])) - expect_true(is.nan(res[5])) - expect_true(is.nan(res[6])) -}) - -# context("sqrtDS::smk::integer vector") -test_that("simple sqrtDS", { - input <- c(0L, 4L, 9L, -10L, -50L, -20L) - - expect_warning(res <- sqrtDS("input"), "NaNs produced", fixed = TRUE) - - expect_equal(class(res), "numeric") - expect_length(res, 6) - expect_equal(res[1], 0.0, tolerance = 1e-8) - expect_equal(res[2], 2.0, tolerance = 1e-8) - expect_equal(res[3], 3.0, tolerance = 1e-8) - expect_true(is.nan(res[4])) - expect_true(is.nan(res[5])) - expect_true(is.nan(res[6])) -}) - -# -# Done -# - -# context("sqrtDS::smk::shutdown") - -# context("sqrtDS::smk::done") From bbe1177749b21aabdfbcd237f228e2c0aee3a2e4 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 12 Mar 2026 19:03:22 +0100 Subject: [PATCH 02/15] Fix server-side helpers and DATASHIELD method whitelisting --- DESCRIPTION | 2 +- R/asFactorSimpleDS.R | 8 ++++-- R/utils.R | 29 +++++++++++++++------- inst/DATASHIELD | 4 +-- man/asLogicalDS.Rd | 8 +++--- man/expDS.Rd | 26 +++++++++++++++++++ man/logDS.Rd | 29 ++++++++++++++++++++++ man/sqrtDS.Rd | 2 +- tests/testthat/test-smk-asFactorSimpleDS.R | 15 +++++++++++ 9 files changed, 104 insertions(+), 19 deletions(-) create mode 100644 man/expDS.Rd create mode 100644 man/logDS.Rd diff --git a/DESCRIPTION b/DESCRIPTION index a6737e2e..2f81906c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -71,7 +71,7 @@ Imports: gamlss, gamlss.dist, mice, - childsds, + childsds, glue Suggests: spelling, diff --git a/R/asFactorSimpleDS.R b/R/asFactorSimpleDS.R index 80a14b27..f6aad651 100644 --- a/R/asFactorSimpleDS.R +++ b/R/asFactorSimpleDS.R @@ -16,7 +16,12 @@ #' asFactorSimpleDS <- function(input.var.name=NULL){ - input.var <- eval(parse(text=input.var.name), envir = parent.frame()) + input.var <- .loadServersideObject(input.var.name) + .checkClass( + obj = input.var, + obj_name = input.var.name, + permitted_classes = c("numeric", "integer", "character", "factor") + ) factor.obj <- factor(input.var) @@ -27,4 +32,3 @@ asFactorSimpleDS <- function(input.var.name=NULL){ #ASSIGN FUNCTION # asFactorSimpleDS - diff --git a/R/utils.R b/R/utils.R index b004d330..03575700 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,18 +1,29 @@ #' 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()`, supporting both simple names +#' (e.g. "D") and column access syntax (e.g. "D$LAB_TSC"). #' -#' @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. #' @noRd .loadServersideObject <- function(x) { - tryCatch( - get(x, envir = parent.frame(2)), - error = function(e) { - stop("The server-side object", " '", x, "' ", "does not exist") - } + env <- parent.frame(2) + + parts <- unlist(strsplit(x, "$", fixed = TRUE)) + obj_name <- parts[1] + has_column <- length(parts) > 1 + + obj <- tryCatch( + get(obj_name, envir = env), + error = function(e) stop("The server-side object '", x, "' does not exist") ) + + if (has_column) { + column_name <- parts[2] + obj <- obj[[column_name]] + } + + 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/man/sqrtDS.Rd b/man/sqrtDS.Rd index 79f044a0..a552a4f1 100644 --- a/man/sqrtDS.Rd +++ b/man/sqrtDS.Rd @@ -12,7 +12,7 @@ sqrtDS(x) \value{ the object specified by the \code{newobj} argument of \code{ds.sqrt} (or default name \code{sqrt.newobj}) -which is written to the server-side. The output object is of class numeric +which is written to the server-side. The output object is of class numeric or integer. } \description{ diff --git a/tests/testthat/test-smk-asFactorSimpleDS.R b/tests/testthat/test-smk-asFactorSimpleDS.R index dd5a17dc..a7195be1 100644 --- a/tests/testthat/test-smk-asFactorSimpleDS.R +++ b/tests/testthat/test-smk-asFactorSimpleDS.R @@ -49,6 +49,21 @@ test_that("simple asFactorSimpleDS", { expect_equal(res.levels[3], "3") }) +test_that("asFactorSimpleDS throws error when object does not exist", { + expect_error( + asFactorSimpleDS("nonexistent_object"), + regexp = "does not exist" + ) +}) + +test_that("asFactorSimpleDS throws error when object is not numeric or character", { + bad_input <- list(a = 1, b = 2) + expect_error( + asFactorSimpleDS("bad_input"), + regexp = "must be of type" + ) +}) + # # Done # From 15394de6d2299e9e20904a8f735172a9b2c8da87 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 12 Mar 2026 20:51:02 +0100 Subject: [PATCH 03/15] remove object assigned message --- R/asListDS.R | 7 ------- 1 file changed, 7 deletions(-) diff --git a/R/asListDS.R b/R/asListDS.R index 16f372e8..4d29fb72 100644 --- a/R/asListDS.R +++ b/R/asListDS.R @@ -26,13 +26,6 @@ asListDS <- function (x.name, newobj){ result <- as.list(x) assign(newobj, result, envir = parent.frame()) - - newobj.class <- class(result) - - 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)) } # AGGREGATE FUNCTION # asListDS From 9f03b43506de2350878218684de29ac69f3470d6 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 12 Mar 2026 20:51:22 +0100 Subject: [PATCH 04/15] restore mistakenly deleted tests --- tests/testthat/test-smk-absDS.R | 195 ++++++++++++++-- tests/testthat/test-smk-asCharacterDS.R | 101 +++++++-- tests/testthat/test-smk-asDataMatrixDS.R | 77 ++++++- tests/testthat/test-smk-asFactorSimpleDS.R | 21 +- tests/testthat/test-smk-asIntegerDS.R | 92 ++++++-- tests/testthat/test-smk-asListDS.R | 57 +++-- tests/testthat/test-smk-asLogicalDS.R | 194 +++++++++++++--- tests/testthat/test-smk-asMatrixDS.R | 79 +++++-- tests/testthat/test-smk-asNumericDS.R | 249 +++++++++++++++++++-- tests/testthat/test-smk-expDS.R | 64 ++++-- tests/testthat/test-smk-logDS.R | 70 ++++-- tests/testthat/test-smk-sqrtDS.R | 193 ++++++++++++++-- 12 files changed, 1198 insertions(+), 194 deletions(-) diff --git a/tests/testthat/test-smk-absDS.R b/tests/testthat/test-smk-absDS.R index 8907c5ce..af56c36d 100644 --- a/tests/testthat/test-smk-absDS.R +++ b/tests/testthat/test-smk-absDS.R @@ -1,32 +1,189 @@ -test_that("absDS computes absolute values for numeric vector", { - input <- c(-3.5, -1.0, 0.0, 2.5, 4.0) +#------------------------------------------------------------------------------- +# 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 . +#------------------------------------------------------------------------------- - res <- absDS("input") +# +# Set up +# - expect_equal(res, abs(input)) - expect_true(is.numeric(res)) +# context("absDS::smk::setup") + +# +# Tests +# + +# context("absDS::smk::special") +test_that("simple absDS, NA", { + input <- NA + + expect_error(absDS("input"), regexp = "must be of type") +}) + +test_that("simple absDS, NaN", { + input <- NaN + + res <- absDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_true(is.nan(res)) +}) + +test_that("simple absDS, Inf", { + input <- Inf + + res <- absDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_true(is.infinite(res)) +}) + +test_that("simple absDS, -Inf", { + input <- -Inf + + res <- absDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_true(is.infinite(res)) +}) + +# context("absDS::smk::numeric") +test_that("simple absDS, numeric 0.0", { + input <- 0.0 + + res <- absDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_equal(res, 0.0) +}) + +test_that("simple absDS, numeric 10.0", { + input <- 10.0 + + res <- absDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_equal(res, 10.0) +}) + +test_that("simple absDS, numeric -10.0", { + input <- -10.0 + + res <- absDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_equal(res, 10.0) }) -test_that("absDS computes absolute values for integer vector", { - input <- as.integer(c(-5, -3, 0, 2, 7)) +# context("absDS::smk::integer") +test_that("simple absDS, integer 0L", { + input <- 0L - res <- absDS("input") + res <- absDS("input") - expect_equal(res, abs(input)) - expect_true(is.integer(res)) + expect_equal(class(res), "integer") + expect_length(res, 1) + expect_equal(res, 0L) }) +test_that("simple absDS, integer 10L", { + input <- 10L + + res <- absDS("input") + + expect_equal(class(res), "integer") + expect_length(res, 1) + expect_equal(res, 10L) +}) + +test_that("simple absDS, integer -10L", { + input <- -10L + + res <- absDS("input") + + expect_equal(class(res), "integer") + expect_length(res, 1) + expect_equal(res, 10L) +}) + +# context("absDS::smk::special vector") +test_that("simple absDS", { + input <- c(NA, NaN, Inf, -Inf) + + res <- absDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 4) + expect_true(is.na(res[1])) + expect_true(is.nan(res[2])) + expect_true(is.infinite(res[3])) + expect_true(is.infinite(res[4])) +}) + +# context("absDS::smk::numeric vector") +test_that("simple absDS", { + input <- c(0.0, 4.0, 9.0, -10.0, -50.0, -20.0) + + res <- absDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 6) + expect_equal(res[1], 0.0) + expect_equal(res[2], 4.0) + expect_equal(res[3], 9.0) + expect_equal(res[4], 10.0) + expect_equal(res[5], 50.0) + expect_equal(res[6], 20.0) +}) + +# context("absDS::smk::integer vector") +test_that("simple absDS", { + input <- c(0L, 4L, 9L, -10L, -50L, -20L) + + res <- absDS("input") + + expect_equal(class(res), "integer") + expect_length(res, 6) + expect_equal(res[1], 0L) + expect_equal(res[2], 4L) + expect_equal(res[3], 9L) + expect_equal(res[4], 10L) + expect_equal(res[5], 50L) + expect_equal(res[6], 20L) +}) + +# context("absDS::smk::error") test_that("absDS throws error when object does not exist", { - expect_error( - absDS("nonexistent_object"), - regexp = "does not exist" - ) + expect_error( + absDS("nonexistent_object"), + regexp = "does not exist" + ) }) test_that("absDS throws error when object is not numeric or integer", { - bad_input <- c("a", "b", "c") - expect_error( - absDS("bad_input"), - regexp = "must be of type" - ) + bad_input <- c("a", "b", "c") + expect_error( + absDS("bad_input"), + regexp = "must be of type" + ) }) + +# +# Done +# + +# context("absDS::smk::shutdown") + +# context("absDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-asCharacterDS.R b/tests/testthat/test-smk-asCharacterDS.R index a0f22ccc..6d615e77 100644 --- a/tests/testthat/test-smk-asCharacterDS.R +++ b/tests/testthat/test-smk-asCharacterDS.R @@ -1,23 +1,98 @@ -test_that("asCharacterDS coerces numeric to character", { - input <- c(1.0, 2.5, 3.0) +#------------------------------------------------------------------------------- +# 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 . +#------------------------------------------------------------------------------- - res <- asCharacterDS("input") +# +# Set up +# - expect_equal(class(res), "character") - expect_equal(res, as.character(input)) +# context("asCharacterDS::smk::setup") + +# +# Tests +# + +# context("asCharacterDS::smk::numeric") +test_that("numeric asCharacterDS", { + input <- 3.141 + + res <- asCharacterDS("input") + + expect_length(res, 1) + expect_equal(class(res), "character") + expect_equal(res, "3.141") +}) + +# context("asCharacterDS::smk::numeric vector") +test_that("numeric vector asCharacterDS", { + input <- c(0.0, 1.0, 2.0, 3.0, 4.0) + + res <- asCharacterDS("input") + + expect_length(res, 5) + expect_equal(class(res), "character") + expect_equal(res[1], "0") + expect_equal(res[2], "1") + expect_equal(res[3], "2") + expect_equal(res[4], "3") + expect_equal(res[5], "4") }) -test_that("asCharacterDS coerces integer to character", { - input <- as.integer(c(1, 2, 3)) +# context("asCharacterDS::smk::logical") +test_that("logical asCharacterDS - FALSE", { + input <- FALSE - res <- asCharacterDS("input") + res <- asCharacterDS("input") - expect_equal(class(res), "character") + expect_length(res, 1) + expect_equal(class(res), "character") + expect_equal(res, "FALSE") }) +test_that("logical asCharacterDS - TRUE", { + input <- TRUE + + res <- asCharacterDS("input") + + expect_length(res, 1) + expect_equal(class(res), "character") + expect_equal(res, "TRUE") +}) + +# context("asCharacterDS::smk::logical vector") +test_that("logical vector asCharacterDS", { + input <- c(TRUE, FALSE, TRUE, FALSE, TRUE) + + res <- asCharacterDS("input") + + expect_length(res, 5) + expect_equal(class(res), "character") + expect_equal(res[1], "TRUE") + expect_equal(res[2], "FALSE") + expect_equal(res[3], "TRUE") + expect_equal(res[4], "FALSE") + expect_equal(res[5], "TRUE") +}) + +# context("asCharacterDS::smk::error") test_that("asCharacterDS throws error when object does not exist", { - expect_error( - asCharacterDS("nonexistent_object"), - regexp = "does not exist" - ) + expect_error( + asCharacterDS("nonexistent_object"), + regexp = "does not exist" + ) }) + +# +# Done +# + +# context("asCharacterDS::smk::shutdown") + +# context("asCharacterDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-asDataMatrixDS.R b/tests/testthat/test-smk-asDataMatrixDS.R index 9b0255de..f5b3d70c 100644 --- a/tests/testthat/test-smk-asDataMatrixDS.R +++ b/tests/testthat/test-smk-asDataMatrixDS.R @@ -1,16 +1,73 @@ -test_that("asDataMatrixDS coerces data.frame to matrix", { - input <- data.frame(v1 = c(1.0, 2.0, 3.0), v2 = c(4.0, 5.0, 6.0)) +#------------------------------------------------------------------------------- +# 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 . +#------------------------------------------------------------------------------- - res <- asDataMatrixDS("input") +# +# Set up +# - expect_true(is.matrix(res)) - expect_equal(nrow(res), 3) - expect_equal(ncol(res), 2) +# context("asDataMatrixDS::smk::setup") + +# +# Tests +# + +# 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)) + + res <- asDataMatrixDS("input") + + res.class <- class(res) + if (base::getRversion() < '4.0.0') + { + expect_length(res.class, 1) + expect_true("matrix" %in% res.class) + } + else + { + expect_length(res.class, 2) + expect_true("matrix" %in% res.class) + expect_true("array" %in% res.class) + } + + expect_length(res, 10) + expect_equal(res[1], 0) + expect_equal(res[2], 1) + expect_equal(res[3], 2) + expect_equal(res[4], 3) + expect_equal(res[5], 4) + expect_equal(res[6], 4) + expect_equal(res[7], 3) + expect_equal(res[8], 2) + expect_equal(res[9], 1) + expect_equal(res[10], 0) + + res.colnames <- colnames(res) + expect_length(res.colnames, 2) + expect_equal(res.colnames[1], "v1") + expect_equal(res.colnames[2], "v2") }) +# context("asDataMatrixDS::smk::error") test_that("asDataMatrixDS throws error when object does not exist", { - expect_error( - asDataMatrixDS("nonexistent_object"), - regexp = "does not exist" - ) + expect_error( + asDataMatrixDS("nonexistent_object"), + regexp = "does not exist" + ) }) + +# +# Done +# + +# context("asDataMatrixDS::smk::shutdown") + +# context("asDataMatrixDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-asFactorSimpleDS.R b/tests/testthat/test-smk-asFactorSimpleDS.R index a7195be1..7d553685 100644 --- a/tests/testthat/test-smk-asFactorSimpleDS.R +++ b/tests/testthat/test-smk-asFactorSimpleDS.R @@ -49,19 +49,20 @@ test_that("simple asFactorSimpleDS", { expect_equal(res.levels[3], "3") }) +# context("asFactorSimpleDS::smk::error") test_that("asFactorSimpleDS throws error when object does not exist", { - expect_error( - asFactorSimpleDS("nonexistent_object"), - regexp = "does not exist" - ) + expect_error( + asFactorSimpleDS("nonexistent_object"), + regexp = "does not exist" + ) }) test_that("asFactorSimpleDS throws error when object is not numeric or character", { - bad_input <- list(a = 1, b = 2) - expect_error( - asFactorSimpleDS("bad_input"), - regexp = "must be of type" - ) + bad_input <- list(a = 1, b = 2) + expect_error( + asFactorSimpleDS("bad_input"), + regexp = "must be of type" + ) }) # @@ -70,4 +71,4 @@ test_that("asFactorSimpleDS throws error when object is not numeric or character # context("asFactorSimpleDS::smk::shutdown") -# context("asFactorSimpleDS::smk::done") +# context("asFactorSimpleDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-asIntegerDS.R b/tests/testthat/test-smk-asIntegerDS.R index 18d42b24..3517ea76 100644 --- a/tests/testthat/test-smk-asIntegerDS.R +++ b/tests/testthat/test-smk-asIntegerDS.R @@ -1,24 +1,88 @@ -test_that("asIntegerDS coerces numeric to integer", { - input <- c(1.0, 2.0, 3.0) +#------------------------------------------------------------------------------- +# 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 . +#------------------------------------------------------------------------------- - res <- asIntegerDS("input") +# +# Set up +# - expect_equal(class(res), "integer") - expect_equal(res, as.integer(input)) +# context("asIntegerDS::smk::setup") + +# +# Tests +# + +# context("asIntegerDS::smk::numeric") +test_that("numeric asIntegerDS", { + input <- 3.141 + + res <- asIntegerDS("input") + + expect_length(res, 1) + expect_equal(class(res), "integer") + expect_equal(res, 3) +}) + +# context("asIntegerDS::smk::numeric vector") +test_that("numeric vector asIntegerDS", { + input <- c(0.1, 1.1, 2.1, 3.1, 4.1) + + res <- asIntegerDS("input") + + expect_length(res, 5) + expect_equal(class(res), "integer") + expect_equal(res[1], 0) + expect_equal(res[2], 1) + expect_equal(res[3], 2) + expect_equal(res[4], 3) + expect_equal(res[5], 4) }) -test_that("asIntegerDS coerces factor with numeric levels correctly", { - input <- factor(c(0, 1, 1, 2)) +# context("asIntegerDS::smk::character") +test_that("character asIntegerDS - FALSE", { + input <- "101" - res <- asIntegerDS("input") + res <- asIntegerDS("input") - expect_equal(class(res), "integer") - expect_equal(res, c(0L, 1L, 1L, 2L)) + expect_length(res, 1) + expect_equal(class(res), "integer") + expect_equal(res, 101) }) +# context("asIntegerDS::smk::character vector") +test_that("character vector asIntegerDS", { + input <- c("101", "202", "303", "404", "505") + + res <- asIntegerDS("input") + + expect_length(res, 5) + expect_equal(class(res), "integer") + expect_equal(res[1], 101) + expect_equal(res[2], 202) + expect_equal(res[3], 303) + expect_equal(res[4], 404) + expect_equal(res[5], 505) +}) + +# context("asIntegerDS::smk::error") test_that("asIntegerDS throws error when object does not exist", { - expect_error( - asIntegerDS("nonexistent_object"), - regexp = "does not exist" - ) + expect_error( + asIntegerDS("nonexistent_object"), + regexp = "does not exist" + ) }) + +# +# Done +# + +# context("asIntegerDS::smk::shutdown") + +# context("asIntegerDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-asListDS.R b/tests/testthat/test-smk-asListDS.R index 3ce4938b..842f84d9 100644 --- a/tests/testthat/test-smk-asListDS.R +++ b/tests/testthat/test-smk-asListDS.R @@ -1,25 +1,50 @@ -test_that("asListDS coerces data.frame to list", { - input <- data.frame(v1 = c(1.0, 2.0), v2 = c(3.0, 4.0)) +#------------------------------------------------------------------------------- +# 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 . +#------------------------------------------------------------------------------- - res <- asListDS("input", "test_output") +# +# Set up +# - expect_true(is.list(res)) - expect_true(grepl("New object created", res$return.message)) - expect_true(grepl("list", res$class.of.newobj)) -}) +# context("asListDS::smk::setup") + +# +# Tests +# + +# context("asListDS::smk::simple") +test_that("simple asListDS", { + input <- list(v1 = c(1, 2, 3), v2 = c(4, 5, 6)) + newobj.name <- 'newobj' -test_that("asListDS coerces vector to list", { - input <- c(1, 2, 3) + expect_false(exists("newobj")) - res <- asListDS("input", "test_output2") + res <- asListDS("input", newobj.name) - expect_true(is.list(res)) - expect_true(grepl("New object created", res$return.message)) + expect_true(exists("newobj")) + expect_equal(class(newobj), "list") + expect_length(newobj, 2) }) +# context("asListDS::smk::error") test_that("asListDS throws error when object does not exist", { - expect_error( - asListDS("nonexistent_object", "test_output"), - regexp = "does not exist" - ) + expect_error( + asListDS("nonexistent_object", "test_output"), + regexp = "does not exist" + ) }) + +# +# Done +# + +# context("asListDS::smk::shutdown") + +# context("asListDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-asLogicalDS.R b/tests/testthat/test-smk-asLogicalDS.R index b5bb3812..02c6fce2 100644 --- a/tests/testthat/test-smk-asLogicalDS.R +++ b/tests/testthat/test-smk-asLogicalDS.R @@ -1,40 +1,184 @@ -test_that("asLogicalDS coerces numeric to logical", { - input <- c(0, 1, 0, 1, 1) +#------------------------------------------------------------------------------- +# 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 . +#------------------------------------------------------------------------------- - res <- asLogicalDS("input") +# +# Set up +# - expect_equal(class(res), "logical") - expect_equal(res, as.logical(input)) +# context("asLogicalDS::smk::setup") + +# +# Tests +# + +# context("asLogicalDS::smk::integer") +test_that("simple asLogicalDS integer - FALSE", { + input <- 0L + + res <- asLogicalDS("input") + + expect_length(res, 1) + expect_equal(class(res), "logical") + expect_equal(res, FALSE) }) -test_that("asLogicalDS coerces integer to logical", { - input <- as.integer(c(0, 1, 0)) +test_that("simple asLogicalDS integer - TRUE", { + input <- 1L - res <- asLogicalDS("input") + res <- asLogicalDS("input") - expect_equal(class(res), "logical") + expect_length(res, 1) + expect_equal(class(res), "logical") + expect_equal(res, TRUE) }) -test_that("asLogicalDS coerces character to logical", { - input <- c("TRUE", "FALSE", "TRUE") +# context("asLogicalDS::smk::integer vector") +test_that("simple asLogicalDS integer vector", { + input <- c(1L, 0L, 1L, 0L, 1L) - res <- asLogicalDS("input") + res <- asLogicalDS("input") - expect_equal(class(res), "logical") - expect_equal(res, c(TRUE, FALSE, TRUE)) + expect_length(res, 5) + expect_equal(class(res), "logical") + expect_equal(res[1], TRUE) + expect_equal(res[2], FALSE) + expect_equal(res[3], TRUE) + expect_equal(res[4], FALSE) + expect_equal(res[5], TRUE) }) -test_that("asLogicalDS throws error when object does not exist", { - expect_error( - asLogicalDS("nonexistent_object"), - regexp = "does not exist" - ) +# context("asLogicalDS::smk::numeric") +test_that("simple asLogicalDS numeric - FALSE", { + input <- 0.0 + + res <- asLogicalDS("input") + + expect_length(res, 1) + expect_equal(class(res), "logical") + expect_equal(res, FALSE) +}) + +test_that("simple asLogicalDS numeric - TRUE", { + input <- 1.0 + + res <- asLogicalDS("input") + + expect_length(res, 1) + expect_equal(class(res), "logical") + expect_equal(res, TRUE) +}) + +# context("asLogicalDS::smk::numeric vector") +test_that("simple asLogicalDS numeric vector", { + input <- c(1.0, 0.0, 1.0, 0.0, 1.0) + + res <- asLogicalDS("input") + + expect_length(res, 5) + expect_equal(class(res), "logical") + expect_equal(res[1], TRUE) + expect_equal(res[2], FALSE) + expect_equal(res[3], TRUE) + expect_equal(res[4], FALSE) + expect_equal(res[5], TRUE) +}) + +# context("asLogicalDS::smk::character") +test_that("simple asLogicalDS, character - FALSE", { + input <- "F" + + res <- asLogicalDS("input") + + expect_equal(class(res), "logical") + expect_length(res, 1) + expect_equal(res, FALSE) }) -test_that("asLogicalDS throws error when object is not permitted type", { - bad_input <- data.frame(a = 1:3) - expect_error( - asLogicalDS("bad_input"), - regexp = "must be of type" - ) +test_that("simple asLogicalDS, character - FALSE", { + input <- "False" + + res <- asLogicalDS("input") + + expect_equal(class(res), "logical") + expect_length(res, 1) + expect_equal(res, FALSE) }) + +test_that("simple asLogicalDS, character - FALSE", { + input <- "FALSE" + + res <- asLogicalDS("input") + + expect_equal(class(res), "logical") + expect_length(res, 1) + expect_equal(res, FALSE) +}) + +test_that("simple asLogicalDS, character - TRUE", { + input <- "T" + + res <- asLogicalDS("input") + + expect_equal(class(res), "logical") + expect_length(res, 1) + expect_equal(res, TRUE) +}) + +test_that("simple asLogicalDS, character - TRUE", { + input <- "True" + + res <- asLogicalDS("input") + + expect_equal(class(res), "logical") + expect_length(res, 1) + expect_equal(res, TRUE) +}) + +test_that("simple asLogicalDS, character - TRUE", { + input <- "TRUE" + + res <- asLogicalDS("input") + + expect_equal(class(res), "logical") + expect_length(res, 1) + expect_equal(res, TRUE) +}) + +test_that("simple asLogicalDS, character vector", { + input <- c("T", "True", "TRUE", "F", "False", "FALSE") + + res <- asLogicalDS("input") + + expect_equal(class(res), "logical") + expect_length(res, 6) + expect_equal(res[1], TRUE) + expect_equal(res[2], TRUE) + expect_equal(res[3], TRUE) + expect_equal(res[4], FALSE) + expect_equal(res[5], FALSE) + expect_equal(res[6], FALSE) +}) + +# context("asLogicalDS::smk::error") +test_that("asLogicalDS throws error when object does not exist", { + expect_error( + asLogicalDS("nonexistent_object"), + regexp = "does not exist" + ) +}) + +# +# Done +# + +# context("asLogicalDS::smk::shutdown") + +# context("asLogicalDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-asMatrixDS.R b/tests/testthat/test-smk-asMatrixDS.R index f53f65d7..96fc386a 100644 --- a/tests/testthat/test-smk-asMatrixDS.R +++ b/tests/testthat/test-smk-asMatrixDS.R @@ -1,24 +1,73 @@ -test_that("asMatrixDS coerces data.frame to matrix", { - input <- data.frame(v1 = c(1.0, 2.0, 3.0), v2 = c(4.0, 5.0, 6.0)) +#------------------------------------------------------------------------------- +# 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 . +#------------------------------------------------------------------------------- - res <- asMatrixDS("input") +# +# Set up +# - expect_true(is.matrix(res)) - expect_equal(nrow(res), 3) - expect_equal(ncol(res), 2) -}) +# context("asMatrixDS::smk::setup") + +# +# Tests +# + +# 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)) + + res <- asMatrixDS("input") -test_that("asMatrixDS coerces vector to matrix", { - input <- c(1, 2, 3, 4) + res.class <- class(res) + if (base::getRversion() < '4.0.0') + { + expect_length(res.class, 1) + expect_true("matrix" %in% res.class) + } + else + { + expect_length(res.class, 2) + expect_true("matrix" %in% res.class) + expect_true("array" %in% res.class) + } - res <- asMatrixDS("input") + expect_length(res, 10) + expect_equal(res[1], 0) + expect_equal(res[2], 1) + expect_equal(res[3], 2) + expect_equal(res[4], 3) + expect_equal(res[5], 4) + expect_equal(res[6], 4) + expect_equal(res[7], 3) + expect_equal(res[8], 2) + expect_equal(res[9], 1) + expect_equal(res[10], 0) - expect_true(is.matrix(res)) + res.colnames <- colnames(res) + expect_length(res.colnames, 2) + expect_equal(res.colnames[1], "v1") + expect_equal(res.colnames[2], "v2") }) +# context("asMatrixDS::smk::error") test_that("asMatrixDS throws error when object does not exist", { - expect_error( - asMatrixDS("nonexistent_object"), - regexp = "does not exist" - ) + expect_error( + asMatrixDS("nonexistent_object"), + regexp = "does not exist" + ) }) + +# +# Done +# + +# context("asMatrixDS::smk::shutdown") + +# context("asMatrixDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-asNumericDS.R b/tests/testthat/test-smk-asNumericDS.R index 59867b9d..427c4ae6 100644 --- a/tests/testthat/test-smk-asNumericDS.R +++ b/tests/testthat/test-smk-asNumericDS.R @@ -1,33 +1,244 @@ -test_that("asNumericDS coerces integer to numeric", { - input <- as.integer(c(1, 2, 3)) +#------------------------------------------------------------------------------- +# 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 . +#------------------------------------------------------------------------------- - res <- asNumericDS("input") +# +# Set up +# - expect_equal(class(res), "numeric") - expect_equal(res, c(1, 2, 3)) +# context("asNumericDS::smk::setup") + +# +# Tests +# + +# context("asNumericDS::smk::character") +test_that("character asNumericDS - FALSE", { + input <- "101" + + res <- asNumericDS("input") + + expect_length(res, 1) + expect_equal(class(res), "numeric") + expect_equal(res, 101) +}) + +# context("asNumericDS::smk::character vector") +test_that("character vector asNumericDS", { + input <- c("101", "202", "303", "404", "505") + + res <- asNumericDS("input") + + expect_length(res, 5) + expect_equal(class(res), "numeric") + expect_equal(res[1], 101) + expect_equal(res[2], 202) + expect_equal(res[3], 303) + expect_equal(res[4], 404) + expect_equal(res[5], 505) +}) + +# context("asNumericDS::smk::character 'non numeric' vector") +test_that("character 'non numeric' vector asNumericDS", { + input <- c("aa", "bb", "cc", "dd", "ee") + + res <- asNumericDS("input") + + expect_length(res, 5) + expect_equal(class(res), "numeric") + expect_equal(res[1], 1) + expect_equal(res[2], 2) + expect_equal(res[3], 3) + expect_equal(res[4], 4) + expect_equal(res[5], 5) +}) + +# context("asNumericDS::smk::factor vector") +test_that("factor vector asNumericDS", { + vec <- c("101", "202", "303", "404", "505") + input <- as.factor(vec) + + res <- asNumericDS("input") + + expect_length(res, 5) + expect_equal(class(res), "numeric") + expect_equal(res[1], 101) + expect_equal(res[2], 202) + expect_equal(res[3], 303) + expect_equal(res[4], 404) + expect_equal(res[5], 505) +}) + +# context("asNumericDS::smk::factor rev vector") +test_that("factor vector asNumericDS", { + vec <- c("505", "404", "303", "202", "101") + input <- as.factor(vec) + + res <- asNumericDS("input") + + expect_length(res, 5) + expect_equal(class(res), "numeric") + expect_equal(res[1], 505) + expect_equal(res[2], 404) + expect_equal(res[3], 303) + expect_equal(res[4], 202) + expect_equal(res[5], 101) }) -test_that("asNumericDS coerces factor with numeric levels correctly", { - input <- factor(c(0, 1, 1, 2)) +# 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) + levels(input) <- c("11", "22", "33", "44", "55") - res <- asNumericDS("input") + res <- asNumericDS("input") - expect_equal(class(res), "numeric") - expect_equal(res, c(0, 1, 1, 2)) + expect_length(res, 5) + expect_equal(class(res), "numeric") + expect_equal(res[1], 11) + expect_equal(res[2], 22) + expect_equal(res[3], 33) + expect_equal(res[4], 44) + expect_equal(res[5], 55) }) -test_that("asNumericDS coerces character with numeric strings correctly", { - input <- c("1", "2", "3") +# 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')) - res <- asNumericDS("input") + res <- asNumericDS("input") - expect_equal(class(res), "numeric") - expect_equal(res, c(1, 2, 3)) + expect_length(res, 5) + expect_equal(class(res), "numeric") + expect_equal(res[1], 1) + expect_equal(res[2], 1) + expect_equal(res[3], 2) + expect_equal(res[4], 2) + expect_equal(res[5], 1) }) +# 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')) + + res <- asNumericDS("input") + + expect_length(res, 5) + expect_equal(class(res), "numeric") + expect_equal(res[1], 2) + expect_equal(res[2], 2) + expect_equal(res[3], 1) + expect_equal(res[4], 1) + expect_equal(res[5], 2) +}) + +# 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') + + res <- asNumericDS("input") + + expect_length(res, 5) + expect_equal(class(res), "numeric") + expect_equal(res[1], 1) + expect_equal(res[2], 1) + expect_equal(res[3], 2) + expect_equal(res[4], 2) + expect_equal(res[5], 1) +}) + +# 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') + + res <- asNumericDS("input") + + expect_length(res, 5) + expect_equal(class(res), "numeric") + expect_equal(res[1], 2) + expect_equal(res[2], 2) + expect_equal(res[3], 1) + expect_equal(res[4], 1) + expect_equal(res[5], 2) +}) + +# 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') + + res <- asNumericDS("input") + + expect_length(res, 5) + expect_equal(class(res), "numeric") + expect_equal(res[1], 4) + expect_equal(res[2], 5) + expect_equal(res[3], 1) + expect_equal(res[4], 2) + expect_equal(res[5], 3) +}) + +# context("asNumericDS::smk::logical vector") +test_that("logical vector asNumericDS", { + input <- c(TRUE, TRUE, FALSE, TRUE) + + res <- asNumericDS("input") + + expect_length(res, 4) + expect_equal(class(res), "numeric") + expect_equal(res[1], 1) + expect_equal(res[2], 1) + expect_equal(res[3], 0) + expect_equal(res[4], 1) +}) + +# context("asNumericDS::smk::logical character vector") +test_that("logical vector character asNumericDS", { + input <- c("TRUE", "TRUE", "FALSE", "TRUE") + + res <- asNumericDS("input") + + expect_length(res, 4) + expect_equal(class(res), "numeric") + expect_equal(res[1], 2) + expect_equal(res[2], 2) + expect_equal(res[3], 1) + expect_equal(res[4], 2) +}) + +# context("asNumericDS::smk::integer vector") +test_that("integer vector asNumericDS", { + input <- as.integer(c('1','1','2','2','1')) + + res <- asNumericDS("input") + + expect_length(res, 5) + expect_equal(class(res), "numeric") + expect_equal(res[1], 1) + expect_equal(res[2], 1) + expect_equal(res[3], 2) + expect_equal(res[4], 2) + expect_equal(res[5], 1) +}) + +# context("asNumericDS::smk::error") test_that("asNumericDS throws error when object does not exist", { - expect_error( - asNumericDS("nonexistent_object"), - regexp = "does not exist" - ) + expect_error( + asNumericDS("nonexistent_object"), + regexp = "does not exist" + ) }) + +# +# Done +# + +# context("asNumericDS::smk::shutdown") + +# context("asNumericDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-expDS.R b/tests/testthat/test-smk-expDS.R index ac1268db..4f4aca8c 100644 --- a/tests/testthat/test-smk-expDS.R +++ b/tests/testthat/test-smk-expDS.R @@ -1,31 +1,63 @@ +#------------------------------------------------------------------------------- +# 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) + input <- c(0.0, 1.0, 2.0, -1.0) - res <- expDS("input") + res <- expDS("input") - expect_equal(res, exp(input)) - expect_true(is.numeric(res)) + 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)) + input <- as.integer(c(0, 1, 2, 3)) - res <- expDS("input") + res <- expDS("input") - expect_equal(res, exp(input)) + expect_equal(res, exp(input)) }) +# context("expDS::smk::error") test_that("expDS throws error when object does not exist", { - expect_error( - expDS("nonexistent_object"), - regexp = "does not exist" - ) + expect_error( + expDS("nonexistent_object"), + regexp = "does not exist" + ) }) test_that("expDS throws error when object is not numeric or integer", { - bad_input <- c("a", "b", "c") - expect_error( - expDS("bad_input"), - regexp = "must be of type" - ) + bad_input <- c("a", "b", "c") + expect_error( + expDS("bad_input"), + regexp = "must be of type" + ) }) + +# +# 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 index 8e762fbc..01b18d01 100644 --- a/tests/testthat/test-smk-logDS.R +++ b/tests/testthat/test-smk-logDS.R @@ -1,39 +1,71 @@ +#------------------------------------------------------------------------------- +# 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)) + input <- c(1.0, exp(1), exp(2)) - res <- logDS("input") + res <- logDS("input") - expect_equal(res, log(input)) - expect_true(is.numeric(res)) + 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) + input <- c(1.0, 10.0, 100.0) - res <- logDS("input", base = 10) + res <- logDS("input", base = 10) - expect_equal(res, log(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)) + input <- as.integer(c(1, 2, 3, 4)) - res <- logDS("input") + res <- logDS("input") - expect_equal(res, log(input)) + expect_equal(res, log(input)) }) +# context("logDS::smk::error") test_that("logDS throws error when object does not exist", { - expect_error( - logDS("nonexistent_object"), - regexp = "does not exist" - ) + expect_error( + logDS("nonexistent_object"), + regexp = "does not exist" + ) }) test_that("logDS throws error when object is not numeric or integer", { - bad_input <- c("a", "b", "c") - expect_error( - logDS("bad_input"), - regexp = "must be of type" - ) + bad_input <- c("a", "b", "c") + expect_error( + logDS("bad_input"), + regexp = "must be of type" + ) }) + +# +# 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 f45301c5..a7aa3641 100644 --- a/tests/testthat/test-smk-sqrtDS.R +++ b/tests/testthat/test-smk-sqrtDS.R @@ -1,31 +1,188 @@ -test_that("sqrtDS computes square root for numeric vector", { - input <- c(4.0, 9.0, 16.0, 25.0) +#------------------------------------------------------------------------------- +# 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 . +#------------------------------------------------------------------------------- - res <- sqrtDS("input") +# +# Set up +# - expect_equal(res, sqrt(input)) - expect_true(is.numeric(res)) +# context("sqrtDS::smk::setup") + +# +# Tests +# + +# context("sqrtDS::smk::special") +test_that("simple sqrtDS, NA", { + input <- NA + + expect_error(sqrtDS("input"), regexp = "must be of type") +}) + +test_that("simple sqrtDS, NaN", { + input <- NaN + + res <- sqrtDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_true(is.nan(res)) +}) + +test_that("simple sqrtDS, Inf", { + input <- Inf + + res <- sqrtDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_true(is.infinite(res)) +}) + +test_that("simple sqrtDS, -Inf", { + input <- -Inf + + expect_warning(res <- sqrtDS("input"), "NaNs produced", fixed = TRUE) + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_true(is.nan(res)) +}) + +# context("sqrtDS::smk::numeric") +test_that("simple sqrtDS, numeric 0.0", { + input <- 0.0 + + res <- sqrtDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_equal(res, 0.0) +}) + +test_that("simple sqrtDS, numeric 10.0", { + input <- 10.0 + + res <- sqrtDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_equal(res, 3.16227766, tolerance = 1e-8) +}) + +test_that("simple sqrtDS, numeric -10.0", { + input <- -10.0 + + expect_warning(res <- sqrtDS("input"), "NaNs produced", fixed = TRUE) + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_true(is.nan(res)) }) -test_that("sqrtDS computes square root for integer vector", { - input <- as.integer(c(1, 4, 9, 16)) +# context("sqrtDS::smk::integer") +test_that("simple sqrtDS, integer 0L", { + input <- 0L - res <- sqrtDS("input") + res <- sqrtDS("input") - expect_equal(res, sqrt(input)) + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_equal(res, 0L) }) +test_that("simple sqrtDS, integer 10L", { + input <- 10L + + res <- sqrtDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_equal(res, 3.16227766, tolerance = 1e-8) +}) + +test_that("simple sqrtDS, integer -10L", { + input <- -10L + + expect_warning(res <- sqrtDS("input"), "NaNs produced", fixed = TRUE) + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_true(is.nan(res)) +}) + +# context("sqrtDS::smk::special vector") +test_that("simple sqrtDS", { + input <- c(NA, NaN, Inf, -Inf) + + expect_warning(res <- sqrtDS("input"), "NaNs produced", fixed = TRUE) + + expect_equal(class(res), "numeric") + expect_length(res, 4) + expect_true(is.na(res[1])) + expect_true(is.infinite(res[3])) + expect_true(is.nan(res[4])) +}) + +# context("sqrtDS::smk::numeric vector") +test_that("simple sqrtDS", { + input <- c(0.0, 4.0, 9.0, -10.0, -50.0, -20.0) + + expect_warning(res <- sqrtDS("input"), "NaNs produced", fixed = TRUE) + + expect_equal(class(res), "numeric") + expect_length(res, 6) + expect_equal(res[1], 0.0, tolerance = 1e-8) + expect_equal(res[2], 2.0, tolerance = 1e-8) + expect_equal(res[3], 3.0, tolerance = 1e-8) + expect_true(is.nan(res[4])) + expect_true(is.nan(res[5])) + expect_true(is.nan(res[6])) +}) + +# context("sqrtDS::smk::integer vector") +test_that("simple sqrtDS", { + input <- c(0L, 4L, 9L, -10L, -50L, -20L) + + expect_warning(res <- sqrtDS("input"), "NaNs produced", fixed = TRUE) + + expect_equal(class(res), "numeric") + expect_length(res, 6) + expect_equal(res[1], 0.0, tolerance = 1e-8) + expect_equal(res[2], 2.0, tolerance = 1e-8) + expect_equal(res[3], 3.0, tolerance = 1e-8) + expect_true(is.nan(res[4])) + expect_true(is.nan(res[5])) + expect_true(is.nan(res[6])) +}) + +# context("sqrtDS::smk::error") test_that("sqrtDS throws error when object does not exist", { - expect_error( - sqrtDS("nonexistent_object"), - regexp = "does not exist" - ) + expect_error( + sqrtDS("nonexistent_object"), + regexp = "does not exist" + ) }) test_that("sqrtDS throws error when object is not numeric or integer", { - bad_input <- c("a", "b", "c") - expect_error( - sqrtDS("bad_input"), - regexp = "must be of type" - ) + bad_input <- c("a", "b", "c") + expect_error( + sqrtDS("bad_input"), + regexp = "must be of type" + ) }) + +# +# Done +# + +# context("sqrtDS::smk::shutdown") + +# context("sqrtDS::smk::done") \ No newline at end of file From 91f997dbf0570bbd5eb8f923efb913cd19d91f79 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 13 Mar 2026 11:46:21 +0100 Subject: [PATCH 05/15] Revert whitespace-only changes and fix test assertions --- DESCRIPTION | 2 +- R/asIntegerDS.R | 2 +- R/asNumericDS.R | 10 +++--- R/sqrtDS.R | 2 +- man/sqrtDS.Rd | 2 +- tests/testthat/test-smk-absDS.R | 2 +- tests/testthat/test-smk-asCharacterDS.R | 2 +- tests/testthat/test-smk-asDataMatrixDS.R | 4 +-- tests/testthat/test-smk-asFactorSimpleDS.R | 2 +- tests/testthat/test-smk-asIntegerDS.R | 2 +- tests/testthat/test-smk-asListDS.R | 2 +- tests/testthat/test-smk-asLogicalDS.R | 2 +- tests/testthat/test-smk-asMatrixDS.R | 4 +-- tests/testthat/test-smk-asNumericDS.R | 42 +++++++++++----------- tests/testthat/test-smk-sqrtDS.R | 2 +- 15 files changed, 41 insertions(+), 41 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 2f81906c..a6737e2e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -71,7 +71,7 @@ Imports: gamlss, gamlss.dist, mice, - childsds, + childsds, glue Suggests: spelling, diff --git a/R/asIntegerDS.R b/R/asIntegerDS.R index dc8d320e..b982ed88 100644 --- a/R/asIntegerDS.R +++ b/R/asIntegerDS.R @@ -1,4 +1,4 @@ -#' +#' #' @title Coerces an R object into class integer #' @description This function is based on the native R function \code{as.integer}. #' @details See help for function \code{as.integer} in native R, and details section diff --git a/R/asNumericDS.R b/R/asNumericDS.R index 307d9679..17b9fd34 100644 --- a/R/asNumericDS.R +++ b/R/asNumericDS.R @@ -1,4 +1,4 @@ -#' +#' #' @title Coerces an R object into class numeric #' @description This function is based on the native R function \code{as.numeric}. #' @details See help for function \code{as.numeric} in native R, and details section @@ -15,12 +15,12 @@ #' asNumericDS <- function(x.name){ x <- .loadServersideObject(x.name) - + # Check that it doesn't match any non-number numbers_only <- function(vec) !grepl("\\D", vec) - + logical <- numbers_only(x) - + if((is.factor(x) & any(logical==FALSE)==FALSE) | (is.character(x) & any(logical==FALSE)==FALSE)){ output <- as.numeric(as.character(x)) }else if((is.factor(x) & any(logical==FALSE)==TRUE) | (is.character(x) & any(logical==FALSE)==TRUE)){ @@ -28,7 +28,7 @@ asNumericDS <- function(x.name){ }else{ output <- as.numeric(x) } - + return(output) } # ASSIGN FUNCTION diff --git a/R/sqrtDS.R b/R/sqrtDS.R index aa561ccc..7643a532 100644 --- a/R/sqrtDS.R +++ b/R/sqrtDS.R @@ -6,7 +6,7 @@ #' @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.sqrt} (or default name \code{sqrt.newobj}) -#' which is written to the server-side. The output object is of class numeric +#' which is written to the server-side. The output object is of class numeric #' or integer. #' @author Demetris Avraam for DataSHIELD Development Team #' @export diff --git a/man/sqrtDS.Rd b/man/sqrtDS.Rd index a552a4f1..79f044a0 100644 --- a/man/sqrtDS.Rd +++ b/man/sqrtDS.Rd @@ -12,7 +12,7 @@ sqrtDS(x) \value{ the object specified by the \code{newobj} argument of \code{ds.sqrt} (or default name \code{sqrt.newobj}) -which is written to the server-side. The output object is of class numeric +which is written to the server-side. The output object is of class numeric or integer. } \description{ diff --git a/tests/testthat/test-smk-absDS.R b/tests/testthat/test-smk-absDS.R index af56c36d..8413bb15 100644 --- a/tests/testthat/test-smk-absDS.R +++ b/tests/testthat/test-smk-absDS.R @@ -186,4 +186,4 @@ test_that("absDS throws error when object is not numeric or integer", { # context("absDS::smk::shutdown") -# context("absDS::smk::done") \ No newline at end of file +# context("absDS::smk::done") diff --git a/tests/testthat/test-smk-asCharacterDS.R b/tests/testthat/test-smk-asCharacterDS.R index 6d615e77..1465f0f2 100644 --- a/tests/testthat/test-smk-asCharacterDS.R +++ b/tests/testthat/test-smk-asCharacterDS.R @@ -95,4 +95,4 @@ test_that("asCharacterDS throws error when object does not exist", { # context("asCharacterDS::smk::shutdown") -# context("asCharacterDS::smk::done") \ No newline at end of file +# context("asCharacterDS::smk::done") diff --git a/tests/testthat/test-smk-asDataMatrixDS.R b/tests/testthat/test-smk-asDataMatrixDS.R index f5b3d70c..90bd5e4d 100644 --- a/tests/testthat/test-smk-asDataMatrixDS.R +++ b/tests/testthat/test-smk-asDataMatrixDS.R @@ -51,7 +51,7 @@ test_that("simple asDataMatrixDS", { expect_equal(res[10], 0) res.colnames <- colnames(res) - expect_length(res.colnames, 2) + expect_length(res.colnames, 2) expect_equal(res.colnames[1], "v1") expect_equal(res.colnames[2], "v2") }) @@ -70,4 +70,4 @@ test_that("asDataMatrixDS throws error when object does not exist", { # context("asDataMatrixDS::smk::shutdown") -# context("asDataMatrixDS::smk::done") \ No newline at end of file +# context("asDataMatrixDS::smk::done") diff --git a/tests/testthat/test-smk-asFactorSimpleDS.R b/tests/testthat/test-smk-asFactorSimpleDS.R index 7d553685..49193900 100644 --- a/tests/testthat/test-smk-asFactorSimpleDS.R +++ b/tests/testthat/test-smk-asFactorSimpleDS.R @@ -71,4 +71,4 @@ test_that("asFactorSimpleDS throws error when object is not numeric or character # context("asFactorSimpleDS::smk::shutdown") -# context("asFactorSimpleDS::smk::done") \ No newline at end of file +# context("asFactorSimpleDS::smk::done") diff --git a/tests/testthat/test-smk-asIntegerDS.R b/tests/testthat/test-smk-asIntegerDS.R index 3517ea76..8417a8f5 100644 --- a/tests/testthat/test-smk-asIntegerDS.R +++ b/tests/testthat/test-smk-asIntegerDS.R @@ -85,4 +85,4 @@ test_that("asIntegerDS throws error when object does not exist", { # context("asIntegerDS::smk::shutdown") -# context("asIntegerDS::smk::done") \ No newline at end of file +# context("asIntegerDS::smk::done") diff --git a/tests/testthat/test-smk-asListDS.R b/tests/testthat/test-smk-asListDS.R index 842f84d9..f220dc63 100644 --- a/tests/testthat/test-smk-asListDS.R +++ b/tests/testthat/test-smk-asListDS.R @@ -47,4 +47,4 @@ test_that("asListDS throws error when object does not exist", { # context("asListDS::smk::shutdown") -# context("asListDS::smk::done") \ No newline at end of file +# context("asListDS::smk::done") diff --git a/tests/testthat/test-smk-asLogicalDS.R b/tests/testthat/test-smk-asLogicalDS.R index 02c6fce2..53fcba85 100644 --- a/tests/testthat/test-smk-asLogicalDS.R +++ b/tests/testthat/test-smk-asLogicalDS.R @@ -181,4 +181,4 @@ test_that("asLogicalDS throws error when object does not exist", { # context("asLogicalDS::smk::shutdown") -# context("asLogicalDS::smk::done") \ No newline at end of file +# context("asLogicalDS::smk::done") diff --git a/tests/testthat/test-smk-asMatrixDS.R b/tests/testthat/test-smk-asMatrixDS.R index 96fc386a..f5d5720c 100644 --- a/tests/testthat/test-smk-asMatrixDS.R +++ b/tests/testthat/test-smk-asMatrixDS.R @@ -51,7 +51,7 @@ test_that("simple asMatrixDS", { expect_equal(res[10], 0) res.colnames <- colnames(res) - expect_length(res.colnames, 2) + expect_length(res.colnames, 2) expect_equal(res.colnames[1], "v1") expect_equal(res.colnames[2], "v2") }) @@ -70,4 +70,4 @@ test_that("asMatrixDS throws error when object does not exist", { # context("asMatrixDS::smk::shutdown") -# context("asMatrixDS::smk::done") \ No newline at end of file +# context("asMatrixDS::smk::done") diff --git a/tests/testthat/test-smk-asNumericDS.R b/tests/testthat/test-smk-asNumericDS.R index 427c4ae6..3803e805 100644 --- a/tests/testthat/test-smk-asNumericDS.R +++ b/tests/testthat/test-smk-asNumericDS.R @@ -96,7 +96,7 @@ test_that("factor vector asNumericDS", { test_that("factor numeric levels vector asNumericDS", { vec <- c("aa", "bb", "cc", "dd", "ee") input <- as.factor(vec) - levels(input) <- c("11", "22", "33", "44", "55") + levels(input) <- c("11", "22", "33", "44", "55") res <- asNumericDS("input") @@ -111,10 +111,10 @@ test_that("factor numeric levels vector asNumericDS", { # 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')) - + input <- as.factor(c('1','1','2','2','1')) + res <- asNumericDS("input") - + expect_length(res, 5) expect_equal(class(res), "numeric") expect_equal(res[1], 1) @@ -126,10 +126,10 @@ test_that("factor vector with only numbers in its values asNumericDS", { # 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')) - + input <- as.factor(c('b','b','a','a','b')) + res <- asNumericDS("input") - + expect_length(res, 5) expect_equal(class(res), "numeric") expect_equal(res[1], 2) @@ -142,9 +142,9 @@ test_that("factor vector with only characters in its values asNumericDS", { # 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') - + res <- asNumericDS("input") - + expect_length(res, 5) expect_equal(class(res), "numeric") expect_equal(res[1], 1) @@ -157,9 +157,9 @@ test_that("factor vector with only numbers in its values asNumericDS", { # 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') - + res <- asNumericDS("input") - + expect_length(res, 5) expect_equal(class(res), "numeric") expect_equal(res[1], 2) @@ -172,9 +172,9 @@ test_that("character vector with only characters in its values asNumericDS", { # 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') - + res <- asNumericDS("input") - + expect_length(res, 5) expect_equal(class(res), "numeric") expect_equal(res[1], 4) @@ -187,9 +187,9 @@ test_that("character vector with strings having characters and numbers asNumeric # context("asNumericDS::smk::logical vector") test_that("logical vector asNumericDS", { input <- c(TRUE, TRUE, FALSE, TRUE) - + res <- asNumericDS("input") - + expect_length(res, 4) expect_equal(class(res), "numeric") expect_equal(res[1], 1) @@ -201,9 +201,9 @@ test_that("logical vector asNumericDS", { # context("asNumericDS::smk::logical character vector") test_that("logical vector character asNumericDS", { input <- c("TRUE", "TRUE", "FALSE", "TRUE") - + res <- asNumericDS("input") - + expect_length(res, 4) expect_equal(class(res), "numeric") expect_equal(res[1], 2) @@ -214,10 +214,10 @@ test_that("logical vector character asNumericDS", { # context("asNumericDS::smk::integer vector") test_that("integer vector asNumericDS", { - input <- as.integer(c('1','1','2','2','1')) - + input <- as.integer(c('1','1','2','2','1')) + res <- asNumericDS("input") - + expect_length(res, 5) expect_equal(class(res), "numeric") expect_equal(res[1], 1) @@ -241,4 +241,4 @@ test_that("asNumericDS throws error when object does not exist", { # context("asNumericDS::smk::shutdown") -# context("asNumericDS::smk::done") \ No newline at end of file +# context("asNumericDS::smk::done") diff --git a/tests/testthat/test-smk-sqrtDS.R b/tests/testthat/test-smk-sqrtDS.R index a7aa3641..30904237 100644 --- a/tests/testthat/test-smk-sqrtDS.R +++ b/tests/testthat/test-smk-sqrtDS.R @@ -185,4 +185,4 @@ test_that("sqrtDS throws error when object is not numeric or integer", { # context("sqrtDS::smk::shutdown") -# context("sqrtDS::smk::done") \ No newline at end of file +# context("sqrtDS::smk::done") From 4d2d6183ad69af1911bec93ad573b2ac3777d17e Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 16 Mar 2026 13:13:38 +0100 Subject: [PATCH 06/15] refactor: make column extraction clearer --- R/utils.R | 27 +++++++++++++++++---------- 1 file changed, 17 insertions(+), 10 deletions(-) diff --git a/R/utils.R b/R/utils.R index 03575700..84358dea 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,29 +1,36 @@ #' Load a Server-Side Object by Name #' -#' Retrieves a server-side object using `get()`, supporting both simple names -#' (e.g. "D") and column access syntax (e.g. "D$LAB_TSC"). +#' 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. +#' @return The retrieved R object, or the specified column if `$` syntax is used. #' @noRd .loadServersideObject <- function(x) { env <- parent.frame(2) - parts <- unlist(strsplit(x, "$", fixed = TRUE)) - obj_name <- parts[1] - has_column <- length(parts) > 1 + 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 (has_column) { - column_name <- parts[2] - obj <- obj[[column_name]] + if (hasColumn) { + obj <- obj[[col_name]] } - obj + return(obj) } #' Check Class of a Server-Side Object From b8010872f000b80276367c7452d41f0956b826de Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 16 Mar 2026 14:44:27 +0100 Subject: [PATCH 07/15] added error handling for missing columns --- R/utils.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/R/utils.R b/R/utils.R index 84358dea..91fa3844 100644 --- a/R/utils.R +++ b/R/utils.R @@ -28,6 +28,9 @@ if (hasColumn) { obj <- obj[[col_name]] + if (is.null(obj)) { + stop("Column '", col_name, "' not found in '", obj_name, "'", call. = FALSE) + } } return(obj) From f6f6b0d4659f1020d258b1b51f65d260391edada Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 16 Mar 2026 14:44:41 +0100 Subject: [PATCH 08/15] test: removed redundant checks --- tests/testthat/test-smk-absDS.R | 23 ----------------------- tests/testthat/test-smk-asCharacterDS.R | 8 -------- tests/testthat/test-smk-asDataMatrixDS.R | 9 --------- tests/testthat/test-smk-asIntegerDS.R | 9 --------- tests/testthat/test-smk-asListDS.R | 9 --------- tests/testthat/test-smk-asLogicalDS.R | 9 --------- tests/testthat/test-smk-asMatrixDS.R | 9 --------- tests/testthat/test-smk-asNumericDS.R | 9 --------- tests/testthat/test-smk-expDS.R | 17 ----------------- tests/testthat/test-smk-logDS.R | 17 ----------------- tests/testthat/test-smk-sqrtDS.R | 23 ----------------------- tests/testthat/test-smk-utils.R | 16 +++++++++++++++- 12 files changed, 15 insertions(+), 143 deletions(-) diff --git a/tests/testthat/test-smk-absDS.R b/tests/testthat/test-smk-absDS.R index 8413bb15..6b2f9a76 100644 --- a/tests/testthat/test-smk-absDS.R +++ b/tests/testthat/test-smk-absDS.R @@ -20,12 +20,6 @@ # # context("absDS::smk::special") -test_that("simple absDS, NA", { - input <- NA - - expect_error(absDS("input"), regexp = "must be of type") -}) - test_that("simple absDS, NaN", { input <- NaN @@ -163,23 +157,6 @@ test_that("simple absDS", { expect_equal(res[5], 50L) expect_equal(res[6], 20L) }) - -# context("absDS::smk::error") -test_that("absDS throws error when object does not exist", { - expect_error( - absDS("nonexistent_object"), - regexp = "does not exist" - ) -}) - -test_that("absDS throws error when object is not numeric or integer", { - bad_input <- c("a", "b", "c") - expect_error( - absDS("bad_input"), - regexp = "must be of type" - ) -}) - # # Done # diff --git a/tests/testthat/test-smk-asCharacterDS.R b/tests/testthat/test-smk-asCharacterDS.R index 1465f0f2..40cdaf73 100644 --- a/tests/testthat/test-smk-asCharacterDS.R +++ b/tests/testthat/test-smk-asCharacterDS.R @@ -81,14 +81,6 @@ test_that("logical vector asCharacterDS", { expect_equal(res[5], "TRUE") }) -# context("asCharacterDS::smk::error") -test_that("asCharacterDS throws error when object does not exist", { - expect_error( - asCharacterDS("nonexistent_object"), - regexp = "does not exist" - ) -}) - # # Done # diff --git a/tests/testthat/test-smk-asDataMatrixDS.R b/tests/testthat/test-smk-asDataMatrixDS.R index 90bd5e4d..6529b1ab 100644 --- a/tests/testthat/test-smk-asDataMatrixDS.R +++ b/tests/testthat/test-smk-asDataMatrixDS.R @@ -55,15 +55,6 @@ test_that("simple asDataMatrixDS", { expect_equal(res.colnames[1], "v1") expect_equal(res.colnames[2], "v2") }) - -# context("asDataMatrixDS::smk::error") -test_that("asDataMatrixDS throws error when object does not exist", { - expect_error( - asDataMatrixDS("nonexistent_object"), - regexp = "does not exist" - ) -}) - # # Done # diff --git a/tests/testthat/test-smk-asIntegerDS.R b/tests/testthat/test-smk-asIntegerDS.R index 8417a8f5..1fc8445b 100644 --- a/tests/testthat/test-smk-asIntegerDS.R +++ b/tests/testthat/test-smk-asIntegerDS.R @@ -70,15 +70,6 @@ test_that("character vector asIntegerDS", { expect_equal(res[4], 404) expect_equal(res[5], 505) }) - -# context("asIntegerDS::smk::error") -test_that("asIntegerDS throws error when object does not exist", { - expect_error( - asIntegerDS("nonexistent_object"), - regexp = "does not exist" - ) -}) - # # Done # diff --git a/tests/testthat/test-smk-asListDS.R b/tests/testthat/test-smk-asListDS.R index f220dc63..1ac8ac68 100644 --- a/tests/testthat/test-smk-asListDS.R +++ b/tests/testthat/test-smk-asListDS.R @@ -32,15 +32,6 @@ test_that("simple asListDS", { expect_equal(class(newobj), "list") expect_length(newobj, 2) }) - -# context("asListDS::smk::error") -test_that("asListDS throws error when object does not exist", { - expect_error( - asListDS("nonexistent_object", "test_output"), - regexp = "does not exist" - ) -}) - # # Done # diff --git a/tests/testthat/test-smk-asLogicalDS.R b/tests/testthat/test-smk-asLogicalDS.R index 53fcba85..41ef866e 100644 --- a/tests/testthat/test-smk-asLogicalDS.R +++ b/tests/testthat/test-smk-asLogicalDS.R @@ -166,15 +166,6 @@ test_that("simple asLogicalDS, character vector", { expect_equal(res[5], FALSE) expect_equal(res[6], FALSE) }) - -# context("asLogicalDS::smk::error") -test_that("asLogicalDS throws error when object does not exist", { - expect_error( - asLogicalDS("nonexistent_object"), - regexp = "does not exist" - ) -}) - # # Done # diff --git a/tests/testthat/test-smk-asMatrixDS.R b/tests/testthat/test-smk-asMatrixDS.R index f5d5720c..ba759e27 100644 --- a/tests/testthat/test-smk-asMatrixDS.R +++ b/tests/testthat/test-smk-asMatrixDS.R @@ -55,15 +55,6 @@ test_that("simple asMatrixDS", { expect_equal(res.colnames[1], "v1") expect_equal(res.colnames[2], "v2") }) - -# context("asMatrixDS::smk::error") -test_that("asMatrixDS throws error when object does not exist", { - expect_error( - asMatrixDS("nonexistent_object"), - regexp = "does not exist" - ) -}) - # # Done # diff --git a/tests/testthat/test-smk-asNumericDS.R b/tests/testthat/test-smk-asNumericDS.R index 3803e805..4ace90f5 100644 --- a/tests/testthat/test-smk-asNumericDS.R +++ b/tests/testthat/test-smk-asNumericDS.R @@ -226,15 +226,6 @@ test_that("integer vector asNumericDS", { expect_equal(res[4], 2) expect_equal(res[5], 1) }) - -# context("asNumericDS::smk::error") -test_that("asNumericDS throws error when object does not exist", { - expect_error( - asNumericDS("nonexistent_object"), - regexp = "does not exist" - ) -}) - # # Done # diff --git a/tests/testthat/test-smk-expDS.R b/tests/testthat/test-smk-expDS.R index 4f4aca8c..4c359470 100644 --- a/tests/testthat/test-smk-expDS.R +++ b/tests/testthat/test-smk-expDS.R @@ -37,23 +37,6 @@ test_that("expDS computes exponential for integer vector", { expect_equal(res, exp(input)) }) - -# context("expDS::smk::error") -test_that("expDS throws error when object does not exist", { - expect_error( - expDS("nonexistent_object"), - regexp = "does not exist" - ) -}) - -test_that("expDS throws error when object is not numeric or integer", { - bad_input <- c("a", "b", "c") - expect_error( - expDS("bad_input"), - regexp = "must be of type" - ) -}) - # # Done # diff --git a/tests/testthat/test-smk-logDS.R b/tests/testthat/test-smk-logDS.R index 01b18d01..d56ea1c9 100644 --- a/tests/testthat/test-smk-logDS.R +++ b/tests/testthat/test-smk-logDS.R @@ -45,23 +45,6 @@ test_that("logDS computes log for integer vector", { expect_equal(res, log(input)) }) - -# context("logDS::smk::error") -test_that("logDS throws error when object does not exist", { - expect_error( - logDS("nonexistent_object"), - regexp = "does not exist" - ) -}) - -test_that("logDS throws error when object is not numeric or integer", { - bad_input <- c("a", "b", "c") - expect_error( - logDS("bad_input"), - regexp = "must be of type" - ) -}) - # # Done # diff --git a/tests/testthat/test-smk-sqrtDS.R b/tests/testthat/test-smk-sqrtDS.R index 30904237..273baec1 100644 --- a/tests/testthat/test-smk-sqrtDS.R +++ b/tests/testthat/test-smk-sqrtDS.R @@ -20,12 +20,6 @@ # # context("sqrtDS::smk::special") -test_that("simple sqrtDS, NA", { - input <- NA - - expect_error(sqrtDS("input"), regexp = "must be of type") -}) - test_that("simple sqrtDS, NaN", { input <- NaN @@ -162,23 +156,6 @@ test_that("simple sqrtDS", { expect_true(is.nan(res[5])) expect_true(is.nan(res[6])) }) - -# context("sqrtDS::smk::error") -test_that("sqrtDS throws error when object does not exist", { - expect_error( - sqrtDS("nonexistent_object"), - regexp = "does not exist" - ) -}) - -test_that("sqrtDS throws error when object is not numeric or integer", { - bad_input <- c("a", "b", "c") - expect_error( - sqrtDS("bad_input"), - regexp = "must be of type" - ) -}) - # # 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" ) }) From e3c1f927a03d5abe1dc32f471c1282a301196eb5 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 16 Mar 2026 14:54:19 +0100 Subject: [PATCH 09/15] revert: shouldn't have touched these files --- R/asFactorSimpleDS.R | 8 ++----- tests/testthat/test-smk-asFactorSimpleDS.R | 25 ++++------------------ 2 files changed, 6 insertions(+), 27 deletions(-) diff --git a/R/asFactorSimpleDS.R b/R/asFactorSimpleDS.R index f6aad651..80a14b27 100644 --- a/R/asFactorSimpleDS.R +++ b/R/asFactorSimpleDS.R @@ -16,12 +16,7 @@ #' asFactorSimpleDS <- function(input.var.name=NULL){ - input.var <- .loadServersideObject(input.var.name) - .checkClass( - obj = input.var, - obj_name = input.var.name, - permitted_classes = c("numeric", "integer", "character", "factor") - ) + input.var <- eval(parse(text=input.var.name), envir = parent.frame()) factor.obj <- factor(input.var) @@ -32,3 +27,4 @@ asFactorSimpleDS <- function(input.var.name=NULL){ #ASSIGN FUNCTION # asFactorSimpleDS + diff --git a/tests/testthat/test-smk-asFactorSimpleDS.R b/tests/testthat/test-smk-asFactorSimpleDS.R index 49193900..bafe51b3 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. @@ -13,7 +12,7 @@ # Set up # -# context("asFactorSimpleDS::smk::setup") +context("asFactorSimpleDS::smk::setup") set.standard.disclosure.settings() @@ -21,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) @@ -49,26 +48,10 @@ test_that("simple asFactorSimpleDS", { expect_equal(res.levels[3], "3") }) -# context("asFactorSimpleDS::smk::error") -test_that("asFactorSimpleDS throws error when object does not exist", { - expect_error( - asFactorSimpleDS("nonexistent_object"), - regexp = "does not exist" - ) -}) - -test_that("asFactorSimpleDS throws error when object is not numeric or character", { - bad_input <- list(a = 1, b = 2) - expect_error( - asFactorSimpleDS("bad_input"), - regexp = "must be of type" - ) -}) - # # Done # -# context("asFactorSimpleDS::smk::shutdown") +context("asFactorSimpleDS::smk::shutdown") -# context("asFactorSimpleDS::smk::done") +context("asFactorSimpleDS::smk::done") From c6211ae4eec53ea1883efcb489d6d34b17c49a28 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 27 Mar 2026 12:31:13 +0100 Subject: [PATCH 10/15] test: updated test expectations to fit changed message --- tests/testthat/test-arg-asIntegerDS.R | 2 +- tests/testthat/test-arg-asLogicalDS.R | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) 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) }) # From 433af424bc832bb08a9e2b93f34bd5c75eaad0d3 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 27 Mar 2026 13:24:07 +0100 Subject: [PATCH 11/15] test: added performance profile| --- tests/testthat/perf_files/performance_refactor_profile.csv | 5 +++++ 1 file changed, 5 insertions(+) create mode 100644 tests/testthat/perf_files/performance_refactor_profile.csv 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" From 9facea0c0dc5b87623ecdd670ad92b96657b20a2 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 27 Mar 2026 13:29:34 +0100 Subject: [PATCH 12/15] added PR template to buildignore --- .Rbuildignore | 1 + 1 file changed, 1 insertion(+) 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 From bd188560d03cca35e1b1d1122625c58f46d76c80 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 27 Mar 2026 13:31:12 +0100 Subject: [PATCH 13/15] feat: validate input type in .loadServersideObject --- R/utils.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/R/utils.R b/R/utils.R index 91fa3844..b96d8735 100644 --- a/R/utils.R +++ b/R/utils.R @@ -9,6 +9,10 @@ #' @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) From 0c59ba95c9fe10bed8127cd631972189237efaab Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 27 Mar 2026 13:31:39 +0100 Subject: [PATCH 14/15] refactor: make perf test tolerances configurable via profile --- tests/testthat/perf_tests/README.md | 48 +++++++++++++++++++++++++++ tests/testthat/perf_tests/perf_rate.R | 16 ++++++++- tests/testthat/setup.R | 1 + tests/testthat/test-perf-meanDS.R | 8 ++--- tests/testthat/test-perf-varDS.R | 8 ++--- 5 files changed, 72 insertions(+), 9 deletions(-) create mode 100644 tests/testthat/perf_tests/README.md 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-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 = '')) } From b3fcee9037946cd585bd356fad5ce529e61f29c5 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 27 Mar 2026 13:31:55 +0100 Subject: [PATCH 15/15] chore: comment out deprecated context calls --- tests/testthat/test-smk-asFactorSimpleDS.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) 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")