List as is

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: pacta.workflow.utils
 Title: Utility functions for PACTA workflows
-Version: 0.0.0.9012
+Version: 0.0.0.9013
 Authors@R: 
     c(person(given = "Alex",
              family = "Axthelm",

NAMESPACE

@@ -17,6 +17,8 @@ export(git_tag_info)
 export(inherit_params)
 export(is_git_path)
 export(merge_lists)
+export(modify_list_element)
+export(modify_single_list_element)
 export(parse_params)
 export(parse_raw_params)
 importFrom(logger,log_debug)

R/export_manifest.R

@@ -82,10 +82,20 @@ create_manifest <- function(
   return(manifest_list)
 }
 
-# Check that arguments are nicely coercible to JSON. called for side effect of
-# `stop` if not.
+#' check_arg_type
+#'
+#' Check that arguments are nicely coercible to JSON. Primarily a check that
+#' lists are composed of simple types (other lists, characters,
+#' numeric/integers, or logicals). Called for side effect of `stop` if not.
+#'
+#' @param arg object to check. Lists will be checked recursively, and must be
+#' named.
+#' @return the same object, unchanged. Function will throw an error if objects
+#' are not simple
 check_arg_type <- function(arg) {
   log_trace("Checking argument type")
+  # remove AsIs class if necessary
+  arg <- un_asis(arg)
   if (inherits(arg, "list")) {
     if (
       length(arg) != length(names(arg)) ||
@@ -113,3 +123,17 @@ check_arg_type <- function(arg) {
   }
   return(arg)
 }
+
+#' un_asis
+#'
+#' Remove AsIs class from object
+#'
+#' @param x an object (with the `AsIs` class)
+#' @return the same object, without AsIs class
+un_asis <- function(x) {
+  if (inherits(x, "AsIs")) {
+    log_trace("Removing AsIs class from object")
+    class(x) <- class(x)[-match("AsIs", class(x))]
+  }
+  return(x)
+}

R/modify_list_element.R

@@ -0,0 +1,84 @@
+#' modify_list_element
+#'
+#' Apply a function to a one or more elements of a list, given the positions of
+#' the elements.
+#'
+#' @param x List to modify
+#' @param positions (List or vector) Position of elements to modify, as a
+#' vector of indices
+#' @param function_to_apply Function to apply to elements
+#' @return modified list
+#' @examples
+# nolint start
+#' test_list <- list(a = 1L, b = list(ba = 2L, bb = 2.2), c = "a")
+#' results <- modify_list_element(
+#'   x = test_list,
+#'   position = list(
+#'     c("b", "bb"),
+#'     "a"
+#'   ),
+#'   function_to_apply = I
+#' )
+#' results
+# nolint end
+#' @export
+modify_list_element <- function(
+  x,
+  positions,
+  function_to_apply
+) {
+  # cast as list, if not already (if a simple vector was passed in)
+  if (!is.list(positions)) {
+    positions <- list(positions)
+  }
+  for (position in positions) {
+    x <- modify_single_list_element(
+      x = x,
+      position = position,
+      function_to_apply = function_to_apply
+    )
+  }
+  return(x)
+}
+
+#' modify_single_list_element
+#'
+#' Apply a function to a single element of a list, givin a vector of list
+#' indices.
+#'
+#' @param x List to modify
+#' @param position Position of element to modify, as a vector of indices
+#' @param function_to_apply Function to apply to element
+#' @return modified list
+#' @examples
+# nolint start
+#' test_list <- list(a = 1L, b = list(ba = 2L, bb = 2.2), c = "a")
+#' results <- modify_single_list_element(
+#'   x = test_list,
+#'   position = c("b", "bb"),
+#'   function_to_apply = I
+#' )
+#' results
+# nolint end
+#' @export
+modify_single_list_element <- function(
+  x,
+  position,
+  function_to_apply
+) {
+  if (length(position) == 1L) {
+    if (is.null(x[[position[[1L]]]])) {
+      log_warn("Element {position[[1L]]} is not found (NULL).")
+      warning("NULL list elements cannot be modified.")
+    } else {
+      x[[position]] <- function_to_apply(x[[position]])
+    }
+  } else {
+    x[[position[[1L]]]] <- modify_single_list_element(
+      x = x[[position[[1L]]]],
+      position = position[-1L],
+      function_to_apply = function_to_apply
+    )
+  }
+  return(invisible(x))
+}

R/parse_params.R

@@ -6,16 +6,19 @@
 #' @param inheritence_search_paths Paths to search for inherited parameters.
 #' See `inherit_params`.
 #' @param schema_file Path to JSON Schema file for validation.
+#' @param force_array Path in params list to force casting as JSON array.
+#' (Default empty)
 #' @return Parsed parameters as a standard R list.
 #' @export
 parse_params <- function(
   json,
   inheritence_search_paths = NULL,
-  schema_file = NULL
+  schema_file = NULL,
+  force_array = list()
 ) {
   log_trace("Parsing params.")
   if (length(json) == 1L && file.exists(json)) {
-    log_trace("Reading params from file: {json}.}")
+    log_trace("Reading params from file: {json}.")
   } else {
     log_trace("Reading params from string.")
   }
@@ -25,6 +28,13 @@ parse_params <- function(
     inheritence_search_paths
   )
 
+  # force array
+  full_params <- modify_list_element(
+    x = full_params,
+    positions = force_array,
+    function_to_apply = I
+  )
+
   if (!is.null(schema_file)) {
     if (requireNamespace("jsonvalidate", quietly = TRUE)) {
       log_trace("Validating parameters.")

R/parse_raw_params.R

@@ -141,7 +141,8 @@ parse_raw_params <- function(
   params <- parse_params(
     json = json,
     inheritence_search_paths = inheritence_search_paths,
-    schema_file = schema_file
+    schema_file = schema_file,
+    force_array = c("portfolio", "files")
   )
 
   return(params)