Merge pull request #451 from datashield/v7.0-dev-feat-colnames

V7.0 dev feat colnames

Author: timcadman

pull_request_template .github/pull_request_templatepull_request_template renamed to .github/pull_request_template

@@ -25,6 +25,7 @@ export(changeRefGroupDS)
 export(checkNegValueDS)
 export(checkPermissivePrivacyControlLevel)
 export(classDS)
+export(colnamesDS)
 export(completeCasesDS)
 export(corDS)
 export(corTestDS)
@@ -139,3 +140,5 @@ import(gamlss.dist)
 import(mice)
 importFrom(gamlss.dist,pST3)
 importFrom(gamlss.dist,qST3)
+importFrom(glue,glue)
+importFrom(glue,glue_collapse)

NAMESPACE

@@ -0,0 +1,20 @@
+## Instructions & checklist for PR author
+
+### Description of changes
+[Add descriptions of changes made]
+
+### Refactor instructions
+- [ ] Replaced  `x <- eval(parse(text = x.name), envir = parent.frame())` with `x <- .loadServersideObject(x)`
+- [ ] If necessary, check the class of the object using `.checkClass()`
+
+### Testing instructions
+- [ ] Writen server-side unit tests for unhappy flow
+- [ ] Run `devtools::test(filter = "smk-|disc|arg")` and check it passes
+- [ ] Run `devtools::check(args = '--no-tests')` and check it passes (we run tests separately to skip performance checks)
+- [ ] Run `devtools::build()` and check it builds without errors
+
+## Instructions & checklist for PR reviewers
+- [ ] Run `devtools::test(filter = "smk-|disc|arg")` and check it passes
+- [ ] Run `devtools::check(args = '--no-tests')` and check it passes (we run tests separately to skip performance checks)
+- [ ] Run `devtools::build()` and check it builds without errors
+

PULL_REQUEST_TEMPLATE.md

@@ -0,0 +1,17 @@
+#'
+#' @title Returns the column names of a data frame or matrix
+#' @description This function is similar to R function \code{colnames}.
+#' @details The function returns the column names of the input dataframe or matrix
+#' @param x a string character, the name of a dataframe or matrix
+#' @return the column names of the input object
+#' @author Demetris Avraam, for DataSHIELD Development Team
+#' @export
+#'
+colnamesDS <- function(x){
+  x.val <- .loadServersideObject(x)
+  .checkClass(obj = x.val, obj_name = x, permitted_classes = c("data.frame", "matrix"))
+  out <- colnames(x.val)
+  return(out)
+}
+#AGGREGATE FUNCTION
+# colnamesDS

R/colnamesDS.R

@@ -0,0 +1,42 @@
+#' 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.
+#'
+#' @param x A character string naming the object to be retrieved.
+#' @return The evaluated R object referred to by `x`.
+#' @noRd
+.loadServersideObject <- function(x) {
+  tryCatch(
+    get(x, envir = parent.frame(2)),
+    error = function(e) {
+      stop("The server-side object", " '", x, "' ", "does not exist")
+    }
+  )
+}
+
+#' Check Class of a Server-Side Object
+#'
+#' Verifies that a given object is of an allowed class. If not, raises an informative error
+#' message listing the permitted classes and the actual class of the object.
+#'
+#' @param obj The object whose class should be checked.
+#' @param obj_name A character string with the name of the object (used in error messages).
+#' @param permitted_classes A character vector of allowed class names.
+#' @importFrom glue glue glue_collapse
+#' @return Invisibly returns `TRUE` if the class check passes; otherwise throws an error.
+#' @noRd
+.checkClass <- function(obj, obj_name, permitted_classes) {
+  typ <- class(obj)
+
+  if (!any(permitted_classes %in% typ)) {
+    msg <- glue(
+      "The server-side object must be of type {glue_collapse(permitted_classes, sep = ', ', last = ' or ')}. ",
+      "'{obj_name}' is type {glue_collapse(typ, sep = ', ', last = ' and ')}."
+    )
+
+    stop(msg, call. = FALSE)
+  }
+
+  invisible(TRUE)
+}

R/utils.R

@@ -0,0 +1,67 @@
+#-------------------------------------------------------------------------------
+# 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 <http://www.gnu.org/licenses/>.
+#-------------------------------------------------------------------------------
+
+#
+# Set up
+#
+
+# context("colnamesDS::smk::setup")
+
+#
+# Tests
+#
+
+# context("colnamesDS::smk::data.frame")
+test_that("simple colnamesDS, data.frame", {
+    input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0))
+
+    res <- colnamesDS("input")
+
+    expect_equal(class(res), "character")
+    expect_length(res, 2)
+    expect_true("v1" %in% res)
+    expect_true("v2" %in% res)
+})
+
+# context("colnamesDS::smk::data.matrix")
+test_that("simple colnamesDS, data.matrix", {
+    input <- data.matrix(data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)))
+
+    res <- colnamesDS("input")
+
+    expect_equal(class(res), "character")
+    expect_length(res, 2)
+    expect_true("v1" %in% res)
+    expect_true("v2" %in% res)
+})
+
+test_that("colnamesDS throws error when object does not exist", {
+  expect_error(
+    colnamesDS("nonexistent_object"),
+    regexp = "does not exist"
+  )
+})
+
+test_that("colnamesDS throws error when object is not data.frame or matrix", {
+  bad_input <- list(a = 1:3, b = 4:6)
+  expect_error(
+    colnamesDS("bad_input"),
+    regexp = "must be of type data.frame or matrix"
+  )
+})
+
+#
+# Done
+#
+
+# context("colnamesDS::smk::shutdown")
+
+# context("colnamesDS::smk::done")

man/colnamesDS.Rd

@@ -0,0 +1,69 @@
+
+#-------------------------------------------------------------------------------
+# Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved.
+#
+# This program and the accompanying materials
+# are made available under the terms of the GNU Public License v3.0.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program.  If not, see <http://www.gnu.org/licenses/>.
+#-------------------------------------------------------------------------------
+
+#
+# Set up
+#
+
+## When .loadServersideObject is called, the actual data exists two levels below the function,
+## i.e. data in global env --> ds function --> .loadServersideObject. We recreate this in
+## the test environment with a wrapper function.
+.dsFunctionWrapper <- function(x) {
+  .loadServersideObject(x)
+}
+
+# context("utils::smk::setup")
+test_that(".loadServersideObject() returns existing object", {
+  test_df <- data.frame(a = 1:3)
+  result <- .dsFunctionWrapper("test_df")
+  expect_identical(result, test_df)
+})
+
+test_that(".loadServersideObject() throws error for missing object", {
+  expect_error(
+    .dsFunctionWrapper("test_df"),
+    regexp = "does not exist"
+  )
+})
+
+test_that(".checkClass() passes for correct class", {
+  df <- data.frame(a = 1)
+  expect_invisible(
+    .checkClass(df, "df", c("data.frame", "matrix"))
+  )
+})
+
+test_that(".checkClass() throws informative error for wrong class with one target class", {
+  x <- list(a = 1)
+  expect_error(
+    .checkClass(x, "x", "data.frame"),
+    regexp = "The server-side object must be of type data.frame. 'x' is type list."
+  )
+})
+
+test_that(".checkClass() throws informative error for wrong class with three target classes", {
+  x <- list(a = 1)
+  expect_error(
+    .checkClass(x, "x", c("data.frame", "matrix", "unicorn")),
+    regexp = "The server-side object must be of type data.frame, matrix or unicorn. 'x' is type list."
+  )
+})
+
+test_that(".checkClass() throws informative error for three target classes and three actual classes", {
+  x <- tibble(a = 1)
+  expect_error(
+    .checkClass(x, "x", c("Boolean", "unicorn", "donkey")),
+    regexp = "The server-side object must be of type Boolean, unicorn or donkey. 'x' is type tbl_df, tbl and data.frame."
+  )
+})
+
+# context("utils::smk::shutdown")
+# context("utils::smk::done")