R/utils.R

In dsTidyverseClient: 'DataSHIELD' 'Tidyverse' Clientside Package

#' Retrieve datasources if not specified
#'
#' @param datasources An optional list of data sources. If not provided, the function will attempt
#' to find available data sources.
#' @importFrom DSI datashield.connections_find
#' @return A list of data sources.
#' @noRd
.get_datasources <- function(datasources) {
  if (is.null(datasources)) {
    datasources <- datashield.connections_find()
  }
  return(datasources)
}

#' Verify that the provided data sources are of class 'DSConnection'.
#'
#' @param datasources A list of data sources.
#' @importFrom cli cli_abort
#' @noRd
.verify_datasources <- function(datasources) {
  is_connection_class <- sapply(datasources, function(x) inherits(unlist(x), "DSConnection"))
  if (!all(is_connection_class)) {
    cli_abort("The 'datasources' were expected to be a list of DSConnection-class objects")
  }
}

#' Set and verify data sources.
#'
#' @param datasources An optional list of data sources. If not provided, the function will attempt
#' to find available data sources.
#' @return A list of verified data sources.
#' @noRd
.set_datasources <- function(datasources) {
  datasources <- .get_datasources(datasources)
  .verify_datasources(datasources)
  return(datasources)
}


#' Set a new object or defaults to '.data' if no object is provided.
#'
#' @param newobj An optional new object name. If not provided, the function defaults to '.data'.
#' @return The provided new object name or '.data' if no object is provided.
#' @noRd
.set_new_obj <- function(.data, newobj) {
  if (is.null(newobj)) {
    newobj <- .data
  }
  return(newobj)
}

#' Generate an encoding key which is used for encoding and decoding strings to pass the R parser
#'
#' @return A list containing the encoding key, with 'input' specifying the characters to be encoded
#' and 'output' specifying their corresponding encoded values.
#' @noRd
.get_encode_dictionary <- function() {
  encode_list <- list(
    input = c("(", ")", "\"", ",", " ", "!", "&", "|", "'", "=", "+", "-", "*", "/", "^", ">", "<", "~", "\n"),
    output = c(
      "$LB$", "$RB$", "$QUOTE$", "$COMMA$", "$SPACE$", "$EXCL$", "$AND$", "$OR$",
      "$APO$", "$EQU$", "$ADD$", "$SUB$", "$MULT$", "$DIVIDE$", "$POWER$", "$GT$", "$LT$", "$TILDE$", "$LINE$"
    )
  )
  return(encode_list)
}

#' Remove List
#'
#' This function removes the 'list(' portion from a string.
#'
#' @param string A string containing the characters 'list('.
#' @return The string with 'list(' removed.
#' @noRd
.remove_list <- function(string) {
  if (string != "NULL") {
    string <- gsub("list\\(", "", string, fixed = FALSE)
    string <- substr(string, 1, nchar(string) - 1)
  }
}

#' Converts expressions to a string and remove the 'list(' portion.
#'
#' @param expr The expression to be converted.
#' @return The formatted arguments as a string.
#' @importFrom rlang quo_text
#' @noRd
.format_args_as_string <- function(expr) {
  neat_args_as_string <- .remove_list(quo_text(expr))
  return(neat_args_as_string)
}

#' Encode a string using the provided encoding key.
#'
#' @param input_string The string to be encoded.
#' @param encode_key The encoding key generated by '.get_encode_dictionary()'.
#' @return The encoded string.
#' @noRd
.encode_tidy_eval <- function(input_string, encode_key) {
  encode_vec <- encode_key$output
  names(encode_vec) <- encode_key$input
  split_string <- strsplit(input_string, "")[[1]]
  output_string <- sapply(split_string, function(char) {
    if (char %in% names(encode_vec)) {
      encode_vec[[char]]
    } else {
      char
    }
  })
  return(paste(output_string, collapse = ""))
}

#' Check Select Arguments
#'
#' @param .data Character specifying a serverside data frame or tibble.
#' @param newobj Optionally, character specifying name for new server-side data frame.
#' @return This function does not return a value but is used for argument validation.
#' @importFrom assertthat assert_that
#' @noRd
.check_tidy_args <- function(df.name = NULL, newobj, check_df = TRUE, check_obj = TRUE) {
  if (check_df) {
    assert_that(is.character(df.name))
  }

  if (check_obj) {
    assert_that(is.character(newobj))
  }
}

#' Create a Tidy Evaluation Call
#'
#' This function constructs a call object for a tidy evaluation function.
#' It allows for the dynamic creation of function calls in a tidyverse-compatible manner.
#'
#' @param tidy_select Encoded tidyselect arguments
#' @param fun_name The name of the function to be called (as a string), e.g., "select", "mutate".
#' @param other_args A list of additional arguments to be passed to the function (optional).
#' @return A call object that can be evaluated to perform the specified operation.
#' @noRd
.make_serverside_call <- function(fun_name, tidy_select, other_args) {
  if (!is.null(tidy_select)) {
    tidy_select <- .encode_tidy_eval(tidy_select, .get_encode_dictionary())
  }
  cally <- .build_cally(fun_name, c(list(tidy_select), other_args))
  return(cally)
}

#' Construct a Call Object
#'
#' This function constructs and returns a call object based on the provided
#' function name, dataframe name, tidyselect specification, and additional arguments.
#'
#' @param fun_name A character string representing the function name.
#' @param df.name The name of the dataframe.
#' @param tidy_select Tidyselect specification (e.g., column names or selection helpers).
#' @param other_args Additional arguments to be included in the call. If NULL, no additional arguments are added.
#' @importFrom rlang sym
#' @return A call object constructed from the provided arguments.
#' @noRd
.build_cally <- function(fun_name, other_args) {
  arg_list <- c(list(sym(fun_name)), other_args)
  return(as.call(arg_list))
}