teal.data coverage - 74.44%

Files
Source

## Callable ====
#'
#' @title A \code{Callable} class of objects
#'
#' @description Object that stores function name with its arguments. Methods to get call and run it.
#' @keywords internal
#'
Callable <- R6::R6Class( # nolint
  "Callable",

  ## __Public Methods ====
  public = list(
    #' @description
    #' Create a new \code{CallableCode} object
    #'
    #' @param env (\code{environment})\cr
    #'  environment where the call will be evaluated
    #'
    #' @return new \code{CallableCode} object
    initialize = function(env) {
      stopifnot(is.environment(env))
      private$env <- env
      logger::log_trace("Callable initialized.")
      invisible(self)
    },
    #' @description
    #' Assigns \code{x <- value} object to \code{env}. Assigned object can't
    #' be modified within local environment as it will be locked by using
    #' \code{lockBinding}. This also means that this object can't be reassigned
    #' which will throw an error.
    #' @param x (\code{character} value)\cr
    #'  name of the variable in class environment
    #' @param value (\code{data.frame})\cr
    #'  object to be assigned to \code{x}
    #'
    #' @return (\code{self}) invisibly for chaining.
    assign_to_env = function(x, value) {
      # assign variable once
      if (!exists(x, envir = private$env)) {
        assign(x, value, envir = private$env)

        # variable can't be modified
        lockBinding(sym = x, env = private$env)
        logger::log_trace("Callable$assign_to_env assigned '{ x }' to the environment.")
      }

      return(invisible(self))
    },
    #' @description
    #' Execute \code{Callable} function or code.
    #'
    #' @param return (\code{logical} value)\cr
    #'  whether to return an object
    #' @param args (\code{NULL} or named \code{list})\cr
    #'  supplied for callable functions only, these are dynamic arguments passed to function.
    #'  Dynamic arguments are executed in this call and are not saved which means that
    #'  \code{self$get_call()} won't include them later.
    #' @param try (\code{logical} value)\cr
    #'  whether perform function evaluation inside \code{try} clause
    #'
    #' @return nothing or output from function depending on \code{return}
    #' argument. If \code{run} fails it will return object of class \code{simple-error error}
    #' when \code{try = TRUE} or will stop if \code{try = FALSE}.
    run = function(return = TRUE, args = NULL, try = FALSE) {
      checkmate::assert_flag(return)
      checkmate::assert_list(args, names = "unique", min.len = 0, null.ok = TRUE)
      checkmate::assert_flag(try)

      # args are "dynamic" are used only to evaluate this call
      # - args not saved to private$call persistently
      expr <- self$get_call(deparse = FALSE, args = args)

      res <- tryCatch(
        eval(expr, envir = private$env),
        error = function(e) e
      )
      private$check_run_output(res, try = try)

      logger::log_trace("Callable$run callable has been run.")
      if (return) {
        return(res)
      } else {
        return(invisible(NULL))
      }
    },
    #' @description
    #' Check if evaluation of the function has not failed.
    #'
    #' @return (\code{logical}) \code{TRUE} if evaluation of the function failed or \code{FALSE}
    #'  if evaluation failed or function hasn't yet been called.
    is_failed = function() {
      return(private$failed)
    },
    #' @description
    #' Get error message from last function execution
    #'
    #' @return (\code{character}) object with error message or \code{character(0)} if last
    #'  function evaluation was successful.
    get_error_message = function() {
      return(private$error_msg)
    }
  ),

  ## __Private Fields ====
  private = list(
    call = NULL, # a call object
    env = NULL, # environment where function is called
    failed = FALSE,
    error_msg = character(0),
    ## __Private Methods ====

    # The deep clone function deep clones the environment of the Callable so
    # that it is distinct for the copy
    deep_clone = function(name, value) {
      deep_clone_r6(name, value)
    },
    # Checks output and handles error messages
    check_run_output = function(res, try) {
      if (inherits(res, "error")) {
        msg <- conditionMessage(res)
        is_locked <- grepl(pattern = "cannot change value of locked", x = msg)

        error_msg <- if (is_locked) {
          locked_var <- gsub("^.+\\'(.+)\\'$", "\\1", x = msg)
          sprintf(
            "Modification of the local variable '%1$s' is not allowed. %2$s '%1$s'",
            locked_var,
            "Please add proxy variable to CallableCode to obtain results depending on altered"
          )
        } else {
          msg
        }

        if (try) {
          private$failed <- TRUE
          private$error_msg <- error_msg
          logger::log_error("Callable$check_run_output { deparse1(error_msg) }.")
        } else {
          stop(error_msg, call. = FALSE)
        }
      } else {
        private$failed <- FALSE
        private$error_msg <- character(0)
      }
    }
  )
)

## MAETealDataset ====
#'
#' @title  R6 Class representing a `MultiAssayExperiment` object with its attributes
#'
#' @description `r lifecycle::badge("experimental")`
#' Any `MultiAssayExperiment` object can be stored inside this `MAETealDataset`.
#' Some attributes like colnames, dimension or column names for a specific type will
#' be automatically derived.
#'
#'
#' @param dataname (`character`)\cr
#'        A given name for the dataset it may not contain spaces
#' @param x (`MultiAssayExperiment`)\cr
#' @param keys optional, (`character`)\cr
#'        A vector of primary keys
#' @param code (`character` or `CodeClass`)\cr
#'        A character string defining the code needed to produce the data set in `x`.
#'        `initialize()` and `recreate()` accept code as `CodeClass`
#'        which is also needed to preserve the code uniqueness and correct order.
#' @param label (`character`)\cr
#'        Label to describe the dataset
#' @param vars (named `list`)) \cr
#'        In case when this object code depends on other `TealDataset` object(s) or
#'        other constant value, this/these object(s) should be included as named
#'        element(s) of the list. For example if this object code needs `ADSL`
#'        object we should specify `vars = list(ADSL = <adsl object>)`.
#'        It is recommended to include `TealDataset` or `TealDatasetConnector` objects to
#'        the `vars` list to preserve reproducibility. Please note that `vars`
#'        are included to this object as local `vars` and they cannot be modified
#'        within another dataset.
#' @param metadata (named `list` or `NULL`) \cr
#'        Field containing metadata about the dataset. Each element of the list
#'        should be atomic and of length one.
#'
#' @seealso [`TealDataset`]
#'
MAETealDataset <- R6::R6Class( # nolint
  "MAETealDataset",
  inherit = TealDataset,
  ## __Public Methods ====
  public = list(
    #' @description
    #' Create a new object of `MAETealDataset` class
    #'
    initialize = function(dataname,
                          x,
                          keys = character(0),
                          code = character(0),
                          label = character(0),
                          vars = list(),
                          metadata = NULL) {
      if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
        stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
      }
      checkmate::assert_string(dataname)
      stopifnot(inherits(x, "MultiAssayExperiment"))
      checkmate::assert_character(keys, any.missing = FALSE)
      checkmate::assert(
        checkmate::check_character(code, max.len = 1, any.missing = FALSE),
        checkmate::check_class(code, "CodeClass")
      )
      checkmate::assert_character(label, max.len = 1, null.ok = TRUE, any.missing = FALSE)
      checkmate::assert_list(vars, min.len = 0, names = "unique")

      # validate metadata as a list of length one atomic
      validate_metadata(metadata)

      private$.raw_data <- x
      private$metadata <- metadata
      private$set_dataname(dataname)
      self$set_vars(vars)
      self$set_dataset_label(label)
      self$set_keys(keys)

      # needed if recreating dataset - we need to preserve code order and uniqueness
      private$code <- CodeClass$new()
      if (is.character(code)) {
        self$set_code(code)
      } else {
        private$code$append(code)
      }

      logger::log_trace("MAETealDataset$initialize initialized dataset: { deparse1(self$get_dataname()) }.")

      return(invisible(self))
    },
    # ___ check ====
    #' @description
    #' Check to determine if the raw data is reproducible from the `get_code()` code.
    #' @return
    #' `TRUE` if the dataset generated from evaluating the
    #' `get_code()` code is identical to the raw data, else `FALSE`.
    check = function() {
      logger::log_trace(
        "TealDataset$check executing the code to reproduce dataset: { deparse1(self$get_dataname()) }..."
      )
      if (!checkmate::test_character(self$get_code(), len = 1, pattern = "\\w+")) {
        stop(
          sprintf(
            "Cannot check preprocessing code of '%s' - code is empty.",
            self$get_dataname()
          )
        )
      }

      new_set <- private$execute_code(
        code = self$get_code_class(),
        vars = private$vars
      )
      res_check <- tryCatch(
        {
          identical(self$get_raw_data(), new_set)
        },
        error = function(e) {
          FALSE
        }
      )
      logger::log_trace("TealDataset$check { deparse1(self$get_dataname()) } reproducibility result: { res_check }.")

      return(res_check)
    },
    #' @description
    #' Check if keys has been specified correctly for dataset. Set of `keys`
    #' should distinguish unique rows or be `character(0)`.
    #'
    #' @return `TRUE` if dataset has been already pulled, else `FALSE`
    check_keys = function(keys = private$.keys) {
      if (length(keys) > 0) {
        if (!all(keys %in% self$get_colnames())) {
          stop("Primary keys specifed for ", self$get_dataname(), " do not exist in the data.")
        }

        duplicates <- get_key_duplicates(as.data.frame(SummarizedExperiment::colData(self$get_raw_data())), keys)
        if (nrow(duplicates) > 0) {
          stop(
            "Duplicate primary key values found in the dataset '", self$get_dataname(), "' :\n",
            paste0(utils::capture.output(print(duplicates))[-c(1, 3)], collapse = "\n"),
            call. = FALSE
          )
        }
      }
    },
    #' @description
    #' Derive the column names
    #' @return `character` vector.
    get_colnames = function() {
      colnames(SummarizedExperiment::colData(private$.raw_data))
    },
    #' @description
    #' Derive the column labels
    #' @return `character` vector.
    get_column_labels = function() {
      vapply(
        X = SummarizedExperiment::colData(private$.raw_data),
        FUN.VALUE = character(1),
        FUN = function(x) {
          label <- attr(x, "label")
          if (length(label) != 1) {
            NA_character_
          } else {
            label
          }
        }
      )
    },
    #' @description
    #' Get the number of columns of the data
    #' @return `numeric` vector
    get_ncol = function() {
      ncol(SummarizedExperiment::colData(private$.raw_data))
    },
    #' @description
    #' Get the number of rows of the data
    #' @return `numeric` vector
    get_nrow = function() {
      nrow(SummarizedExperiment::colData(private$.raw_data))
    },
    #' @description
    #' Derive the row names
    #' @return `character` vector.
    get_rownames = function() {
      rownames(SummarizedExperiment::colData(private$.raw_data))
    },
    #' @description
    #' Prints this `MAETealDataset`.
    #' @param ... additional arguments to the printing method
    #'
    #' @return invisibly self
    print = function(...) {
      cat(sprintf("A MAETealDataset object containing data of %d subjects.\n", self$get_nrow()))
      print(MultiAssayExperiment::experiments(self$get_raw_data()))
      invisible(self)
    }
  ),
  ## __Private Fields ====
  private = list(
    .raw_data = NULL,
    get_class_colnames = function(class_type = "character") {
      checkmate::assert_string(class_type)

      return_cols <- private$.colnames[which(vapply(
        lapply(SummarizedExperiment::colData(private$.raw_data), class),
        function(x, target_class_name) any(x %in% target_class_name),
        logical(1),
        target_class_name = class_type
      ))]

      return(return_cols)
    },

    # Evaluate script code to modify data or to reproduce data
    #
    # @param code (`CodeClass`) the object storing the code to execute
    # @param vars (named `list`) additional pre-requisite vars to execute code
    # @return (`environment`) which stores modified `x`
    execute_code = function(code, vars = list()) {
      stopifnot(inherits(code, "CodeClass"))
      checkmate::assert_list(vars, min.len = 0, names = "unique")

      execution_environment <- new.env(parent = parent.env(globalenv()))

      # set up environment for execution
      for (vars_idx in seq_along(vars)) {
        var_name <- names(vars)[[vars_idx]]
        var_value <- vars[[vars_idx]]
        if (inherits(var_value, "TealDatasetConnector") || inherits(var_value, "TealDataset")) {
          var_value <- get_raw_data(var_value)
        }
        assign(envir = execution_environment, x = var_name, value = var_value)
      }

      # execute
      code$eval(envir = execution_environment)

      if (!inherits(execution_environment[[self$get_dataname()]], "MultiAssayExperiment")) {
        out_msg <- sprintf(
          "\n%s\n\n - Code from %s needs to return a MultiAssayExperiment assigned to an object of dataset name.",
          self$get_code(),
          self$get_dataname()
        )

        rlang::with_options(
          .expr = stop(out_msg, call. = FALSE),
          warning.length = max(min(8170, nchar(out_msg) + 30), 100)
        )
      }

      new_set <- execution_environment[[self$get_dataname()]]

      return(new_set)
    }
  )
)

#' S3 method to construct an `MAETealDataset` object from `MultiAssayExperiment`
#'
#' @rdname dataset
#'
#' @examples
#' # Simple example
#' utils::data(miniACC, package = "MultiAssayExperiment")
#' mae_d <- dataset(
#'   "MAE",
#'   miniACC,
#'   keys = c("STUDYID", "USUBJID"),
#'   metadata = list(type = "example")
#' )
#' mae_d$get_dataname()
#' mae_d$get_dataset_label()
#' mae_d$get_metadata()
#' mae_d$get_code()
#' mae_d$get_raw_data()
#' @export
dataset.MultiAssayExperiment <- function(dataname, # nolint
                                         x,
                                         keys = character(0),
                                         label = data_label(x),
                                         code = character(0),
                                         vars = list(),
                                         metadata = NULL) {
  if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
    stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
  }
  checkmate::assert_string(dataname)
  checkmate::assert(
    checkmate::check_character(code, max.len = 1, any.missing = FALSE),
    checkmate::check_class(code, "CodeClass")
  )
  checkmate::assert_list(vars, min.len = 0, names = "unique")

  MAETealDataset$new(
    dataname = dataname,
    x = x,
    keys = keys,
    code = code,
    label = label,
    vars = vars,
    metadata = metadata
  )
}

#' The constructor of `MAETealDataset`
#'
#' @description `r lifecycle::badge("deprecated")`
#'
#' @inheritParams dataset
#' @param x (`MultiAssayExperiment`)
#'
#' @examples
#' # Simple example
#' utils::data(miniACC, package = "MultiAssayExperiment")
#' mae_d <- dataset("MAE", miniACC)
#' mae_d$get_dataname()
#' mae_d$get_dataset_label()
#' mae_d$get_code()
#' mae_d$get_raw_data()
#' @export
mae_dataset <- function(dataname,
                        x,
                        label = data_label(x),
                        code = character(0),
                        vars = list()) {
  lifecycle::deprecate_soft(
    when = "0.10.1",
    what = "teal.data::mae_dataset()",
    with = "teal.data::dataset()"
  )

  if (!inherits(x, "MultiAssayExperiment")) {
    stop("Argument x must be a MultiAssayExperiment object")
  }

  dataset(
    dataname = dataname,
    x = x,
    code = code,
    label = label,
    vars = vars
  )
}

## JoinKeys ====
#'
#'
#' @title R6 Class to store relationships for joining datasets
#'
#' @description `r lifecycle::badge("stable")`
#' This class stores symmetric links between pairs of key-values
#' (e.g. column A of dataset X can be joined with column B of dataset Y). This relationship
#' is more general than the SQL foreign key relationship which also imposes constraints on the values
#' of these columns.
#' @param dataset_1 (`character`) one dataset name
#' @param dataset_2 (`character`) other dataset name
#'
#' @examples
#' x <- teal.data:::JoinKeys$new()
#' x$set(
#'   list(
#'     join_key("dataset_A", "dataset_B", c("col_1" = "col_a")),
#'     join_key("dataset_A", "dataset_C", c("col_2" = "col_x", "col_3" = "col_y"))
#'   )
#' )
#' x$get()
#' x$mutate("dataset_A", "dataset_B", c("col1" = "col10"))
#' x$get("dataset_A", "dataset_B")
JoinKeys <- R6::R6Class( # nolint
  classname = "JoinKeys",
  ## __Public Methods ====
  public = list(
    #' @description
    #' Create a new object of `JoinKeys`
    #' @return empty (`JoinKeys`)
    initialize = function() {
      logger::log_trace("JoinKeys initialized.")
      return(invisible(self))
    },
    #' @description
    #' Split the current `JoinKeys` object into a named list of join keys objects with an element for each dataset
    #' @return (`list`) a list of `JoinKeys` object
    split = function() {
      list_of_list_of_join_key_set <- lapply(
        names(self$get()),
        function(dataset_1) {
          lapply(
            names(self$get()[[dataset_1]]),
            function(dataset_2) join_key(dataset_1, dataset_2, self$get()[[dataset_1]][[dataset_2]])
          )
        }
      )
      res <- lapply(
        list_of_list_of_join_key_set,
        function(x) {
          y <- JoinKeys$new()
          y$set(x)
        }
      )
      names(res) <- names(self$get())

      logger::log_trace("JoinKeys$split keys split.")
      return(res)
    },
    #' @description
    #' Merging a list (or one) of `JoinKeys` objects into the current `JoinKeys` object
    #' @param x  `list` of `JoinKeys` objects or single `JoinKeys` object
    #' @return (`self`) invisibly for chaining
    merge = function(x) {
      if (inherits(x, "JoinKeys")) x <- list(x)
      checkmate::assert_list(x, types = "JoinKeys", min.len = 1)
      for (jk in x) {
        for (dataset_1 in names(jk$get())) {
          for (dataset_2 in names(jk$get()[[dataset_1]])) {
            self$mutate(dataset_1, dataset_2, jk$get()[[dataset_1]][[dataset_2]])
          }
        }
      }
      logger::log_trace("JoinKeys$merge keys merged.")
      return(invisible(self))
    },
    #' @description
    #' Get join keys between two datasets.
    #' @return (`character`) named character vector x with names(x) the
    #' columns of `dataset_1` and the values of `(x)` the corresponding join
    #' keys in `dataset_2` or `character(0)` if no relationship
    #' @details if one or both of `dataset_1` and `dataset_2` are missing then
    #' underlying keys structure is returned for further processing
    get = function(dataset_1, dataset_2) {
      if (missing(dataset_1) && missing(dataset_2)) {
        return(private$.keys)
      }
      if (missing(dataset_2)) {
        return(private$.keys[[dataset_1]])
      }
      if (missing(dataset_1)) {
        return(private$.keys[[dataset_2]])
      }
      if (is.null(private$.keys[[dataset_1]][[dataset_2]])) {
        return(character(0))
      }
      return(private$.keys[[dataset_1]][[dataset_2]])
    },
    #' @description
    #' Change join_keys for a given pair of dataset names (or
    #' add join_keys for given pair if it does not exist)
    #' @param val (named `character`) column names used to join
    #' @return (`self`) invisibly for chaining
    mutate = function(dataset_1, dataset_2, val) {
      checkmate::assert_string(dataset_1)
      checkmate::assert_string(dataset_2)
      checkmate::assert_character(val, any.missing = FALSE)

      private$join_pair(join_key(dataset_1, dataset_2, val))

      logger::log_trace(
        sprintf(
          "JoinKeys$mutate updated the keys between %s and %s to %s",
          dataset_1,
          dataset_2,
          paste(val, collapse = ", ")
        )
      )
      return(invisible(self))
    },
    #' @description
    #' Set up join keys basing on list of `JoinKeySet` objects.
    #' @param x  `list` of `JoinKeySet` objects (which are created using the `join_key` function)
    #' or single `JoinKeySet` objects
    #' @details Note that join keys are symmetric although the relationship only needs
    #' to be specified once
    #' @return (`self`) invisibly for chaining
    set = function(x) {
      if (length(private$.keys) > 0) {
        stop("Keys already set, please use JoinKeys$mutate() to change them")
      }
      if (inherits(x, "JoinKeySet")) {
        x <- list(x)
      }

      # check if any JoinKeySets share the same datasets but different values
      for (idx_1 in seq_along(x)) {
        for (idx_2 in seq_len(idx_1)) {
          private$check_compatible_keys(x[[idx_1]], x[[idx_2]])
        }
      }

      checkmate::assert_list(x, types = "JoinKeySet", min.len = 1)
      lapply(x, private$join_pair)

      logger::log_trace("JoinKeys$set keys are set.")
      return(invisible(self))
    },
    #' @description
    #' Prints this `JoinKeys`.
    #'
    #' @param ... additional arguments to the printing method
    #' @return invisibly self
    print = function(...) {
      check_ellipsis(...)
      keys_list <- self$get()
      if (length(keys_list) > 0) {
        cat(sprintf(
          "A JoinKeys object containing foreign keys between %s datasets:\n",
          length(keys_list)
        ))
        print(keys_list)
      } else {
        cat("An empty JoinKeys object.")
      }
      invisible(self)
    },
    #' @description
    #' Sets the parents of the datasets.
    #'
    #' @param named_list Named (`list`) of the parents datasets.
    #'
    #' @return (`self`) invisibly for chaining
    set_parents = function(named_list) {
      for (dataset in names(named_list)) {
        checkmate::assert(
          checkmate::check_null(self$get_parent(dataset)),
          checkmate::check_true(
            length(self$get_parent(dataset)) == 0 &&
              length(named_list[[dataset]]) == 0
          ),
          checkmate::check_true(self$get_parent(dataset) == named_list[[dataset]]),
          "Please check the difference between provided datasets parents and provided join_keys parents."
        )
        if (is.null(self$get_parent(dataset))) {
          private$parents[[dataset]] <- named_list[[dataset]]
        }
      }
      invisible(self)
    },
    #' @description
    #' Gets the parent of the desired dataset.
    #'
    #' @param dataname (`character`) name of the dataset.
    #' @return (`character`) the parent of the desired dataset
    get_parent = function(dataname) {
      if (missing(dataname)) {
        return(NULL)
      }
      private$parents[[dataname]]
    },
    #' @description
    #' Gets the parents of the datasets.
    #'
    #' @return (`list`) A named list of the parents of all datasets
    get_parents = function() {
      private$parents
    },
    #' @description
    #' Updates the keys of the datasets based on the parents.
    #'
    #' @return (`self`) invisibly for chaining
    update_keys_given_parents = function() {
      datanames <- names(self$get())
      duplicate_pairs <- list()
      for (d1 in datanames) {
        d1_pk <- self$get(d1, d1)
        d1_parent <- self$get_parent(d1)
        for (d2 in datanames) {
          if (paste(d2, d1) %in% duplicate_pairs) {
            next
          }
          if (length(self$get(d1, d2)) == 0) {
            d2_parent <- self$get_parent(d2)
            d2_pk <- self$get(d2, d2)

            fk <- if (identical(d1, d2_parent)) {
              # first is parent of second -> parent keys -> first keys
              d1_pk
            } else if (identical(d1_parent, d2)) {
              # second is parent of first -> parent keys -> second keys
              d2_pk
            } else if (identical(d1_parent, d2_parent) && length(d1_parent) > 0) {
              # both has the same parent -> parent keys
              self$get(d1_parent, d1_parent)
            } else {
              # cant find connection - leave empty
              next
            }
            self$mutate(d1, d2, fk)
            duplicate_pairs <- append(duplicate_pairs, paste(d1, d2))
          }
        }
      }
      # check parent child relation
      private$check_parent_child()

      invisible(self)
    }
  ),
  ## __Private Fields ====
  private = list(
    .keys = list(),
    parents = list(),
    join_pair = function(join_key) {
      dataset_1 <- join_key$dataset_1
      dataset_2 <- join_key$dataset_2
      keys <- join_key$keys

      if (is.null(private$.keys[[dataset_1]])) {
        private$.keys[[dataset_1]] <- list()
      }
      private$.keys[[dataset_1]][[dataset_2]] <- keys

      if (dataset_2 != dataset_1) {
        if (is.null(private$.keys[[dataset_2]])) {
          private$.keys[[dataset_2]] <- list()
        }

        if (length(keys) > 0) {
          keys <- setNames(names(keys), keys)
        }
        private$.keys[[dataset_2]][[dataset_1]] <- keys
      }
    },
    # helper function to deterimine if two key sets contain incompatible keys
    # return TRUE if compatible, throw error otherwise
    check_compatible_keys = function(join_key_1, join_key_2) {
      error_message <- function(dataset_1, dataset_2) {
        stop(
          paste("cannot specify multiple different join keys between datasets:", dataset_1, "and", dataset_2)
        )
      }


      # if first datasets and the second datasets match and keys
      # must contain the same named elements
      if (join_key_1$dataset_1 == join_key_2$dataset_1 && join_key_1$dataset_2 == join_key_2$dataset_2) {
        if (!identical(sort(join_key_1$keys), sort(join_key_2$keys))) {
          error_message(join_key_1$dataset_1, join_key_1$dataset_2)
        }
      }

      # if first dataset of join_key_1 matches second dataset of join_key_2
      # and the first dataset of join_key_2 must match second dataset of join_key_1
      # and keys must contain the same elements but with names and values swapped
      if (join_key_1$dataset_1 == join_key_2$dataset_2 && join_key_1$dataset_2 == join_key_2$dataset_1) {
        # have to handle empty case differently as names(character(0)) is NULL
        if (length(join_key_1$keys) == 0 && length(join_key_2$keys) == 0) {
          return(TRUE)
        }

        if (xor(length(join_key_1$keys) == 0, length(join_key_2$keys) == 0) ||
          !identical(sort(join_key_1$keys), sort(setNames(names(join_key_2$keys), join_key_2$keys)))) {
          error_message(join_key_1$dataset_1, join_key_1$dataset_2)
        }
      }

      # otherwise they are compatible
      return(TRUE)
    },
    # checks the parent child relations are valid
    check_parent_child = function() {
      if (!is.null(self$get_parents())) {
        parents <- self$get_parents()
        for (idx1 in seq_along(parents)) {
          name_from <- names(parents)[[idx1]]
          for (idx2 in seq_along(parents[[idx1]])) {
            name_to <- parents[[idx1]][[idx2]]
            keys_from <- self$get(name_from, name_to)
            keys_to <- self$get(name_to, name_from)
            if (length(keys_from) == 0 && length(keys_to) == 0) {
              stop(sprintf("No join keys from %s to its parent (%s) and vice versa", name_from, name_to))
            }
            if (length(keys_from) == 0) {
              stop(sprintf("No join keys from %s to its parent (%s)", name_from, name_to))
            }
            if (length(keys_to) == 0) {
              stop(sprintf("No join keys from %s parent name (%s) to %s", name_from, name_to, name_from))
            }
          }
        }
      }
    }
  )
)

# constructors ====

#' Create a `JoinKeys` out of a list of `JoinKeySet` objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param ... optional, a `JoinKeySet` objects created using the `join_key` function.
#' @details Note that join keys are symmetric although the relationship only needs
#' to be specified once.
#'
#' @return `JoinKeys`
#'
#' @export
#'
#' @examples
#' join_keys()
#' join_keys(
#'   join_key("dataset_A", "dataset_B", c("col_1" = "col_a")),
#'   join_key("dataset_A", "dataset_C", c("col_2" = "col_x", "col_3" = "col_y"))
#' )
#' join_keys(
#'   join_key("dataset_A", "dataset_B", c("col_1" = "col_a"))
#' )
join_keys <- function(...) {
  x <- list(...)

  res <- JoinKeys$new()
  if (length(x) > 0) {
    res$set(x)
  }

  res
}

# wrappers ====
#' Mutate `JoinKeys` with a new values
#'
#' @description `r lifecycle::badge("experimental")`
#' Mutate `JoinKeys` with a new values
#'
#' @param x (`JoinKeys`) object to be modified
#' @param dataset_1 (`character`) one dataset name
#' @param dataset_2 (`character`) other dataset name
#' @param val (named `character`) column names used to join
#'
#' @return modified `JoinKeys` object
#'
#' @export
mutate_join_keys <- function(x, dataset_1, dataset_2, val) {
  UseMethod("mutate_join_keys")
}

#' @rdname mutate_join_keys
#' @export
#' @examples
#' # JoinKeys ----
#'
#' x <- join_keys(
#'   join_key("dataset_A", "dataset_B", c("col_1" = "col_a")),
#'   join_key("dataset_A", "dataset_C", c("col_2" = "col_x", "col_3" = "col_y"))
#' )
#' x$get("dataset_A", "dataset_B")
#'
#' mutate_join_keys(x, "dataset_A", "dataset_B", c("col_1" = "col_10"))
#' x$get("dataset_A", "dataset_B")
mutate_join_keys.JoinKeys <- function(x, dataset_1, dataset_2, val) {
  x$mutate(dataset_1, dataset_2, val)
}

#' @rdname mutate_join_keys
#' @export
#' @examples
#' # TealData ----
#'
#' ADSL <- teal.data::example_cdisc_data("ADSL")
#' ADRS <- teal.data::example_cdisc_data("ADRS")
#'
#' x <- cdisc_data(
#'   cdisc_dataset("ADSL", ADSL),
#'   cdisc_dataset("ADRS", ADRS)
#' )
#' x$get_join_keys()$get("ADSL", "ADRS")
#'
#' mutate_join_keys(x, "ADSL", "ADRS", c("COLUMN1" = "COLUMN2"))
#' x$get_join_keys()$get("ADSL", "ADRS")
mutate_join_keys.TealData <- function(x, dataset_1, dataset_2, val) { # nolint
  x$mutate_join_keys(dataset_1, dataset_2, val)
}


#' Create a relationship between a pair of datasets
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @inheritParams mutate_join_keys
#' @param keys (optionally named `character`) where `names(keys)` are columns in `dataset_1`
#' with relationship to columns of `dataset_2` given by the elements in `keys`.
#' If `names(keys)` is `NULL` then the same column names are used for both `dataset_1`
#' and `dataset_2`.
#'
#' @return object of class `JoinKeySet` to be passed into `join_keys` function.
#'
#' @seealso [join_keys()]
#'
#' @export
join_key <- function(dataset_1, dataset_2, keys) {
  checkmate::assert_string(dataset_1)
  checkmate::assert_string(dataset_2)
  checkmate::assert_character(keys, any.missing = FALSE)

  if (length(keys) > 0) {
    if (is.null(names(keys))) {
      names(keys) <- keys
    }

    if (any(names(keys) == "")) {
      names(keys)[names(keys) == "" & keys != ""] <- keys[names(keys) == "" & keys != ""]
    }

    stopifnot(!is.null(names(keys)))
    stopifnot(!anyDuplicated(keys))
    stopifnot(!anyDuplicated(names(keys)))
  }

  if (dataset_1 == dataset_2 && any(names(keys) != keys)) {
    stop("Keys within a dataset must match exactly: keys = c('A' = 'B') are not allowed")
  }

  structure(
    list(
      dataset_1 = dataset_1,
      dataset_2 = dataset_2,
      keys = keys
    ),
    class = "JoinKeySet"
  )
}

#' Get Label Attributes of Variables in a \code{data.frame}
#'
#' Variable labels can be stored as a \code{label} attribute for each variable.
#' This functions returns a named character vector with the variable labels
#' (empty sting if not specified)
#'
#' @param x a \code{data.frame} object
#' @param fill boolean in case the \code{label} attribute does not exist if
#'   \code{TRUE} the variable names is returned, otherwise \code{NA}
#'
#' @source This function was taken 1-1 from
#' \href{https://cran.r-project.org/web/packages/formatters/index.html}{formatters} package, to reduce the complexity of
#' the dependency tree.
#'
#' @seealso [col_relabel()] [`col_labels<-`]
#'
#' @return a named character vector with the variable labels, the names
#'   correspond to the variable names
#'
#' @export
#'
#' @examples
#' x <- iris
#' col_labels(x)
#' col_labels(x) <- paste("label for", names(iris))
#' col_labels(x)
col_labels <- function(x, fill = FALSE) {
  stopifnot(is.data.frame(x))
  if (NCOL(x) == 0) {
    return(character())
  }

  y <- Map(function(col, colname) {
    label <- attr(col, "label")

    if (is.null(label)) {
      if (fill) {
        colname
      } else {
        NA_character_
      }
    } else {
      if (!is.character(label) && !(length(label) == 1)) {
        stop("label for variable ", colname, "is not a character string")
      }
      as.vector(label)
    }
  }, x, colnames(x))

  labels <- unlist(y, recursive = FALSE, use.names = TRUE)

  if (!is.character(labels)) {
    stop("label extraction failed")
  }

  labels
}

#' Set Label Attributes of All Variables in a \code{data.frame}
#'
#' Variable labels can be stored as a \code{label} attribute for each variable.
#' This functions sets all non-missing (non-NA) variable labels in a \code{data.frame}
#'
#' @inheritParams col_labels
#' @param value new variable labels, \code{NA} removes the variable label
#'
#' @source This function was taken 1-1 from
#' \href{https://cran.r-project.org/web/packages/formatters/index.html}{formatters} package, to reduce the complexity of
#' the dependency tree.
#'
#' @seealso [col_labels()] [col_relabel()]
#'
#' @return modifies the variable labels of \code{x}
#'
#' @export
#'
#' @examples
#' x <- iris
#' col_labels(x)
#' col_labels(x) <- paste("label for", names(iris))
#' col_labels(x)
#'
#' if (interactive()) {
#'   View(x) # in RStudio data viewer labels are displayed
#' }
`col_labels<-` <- function(x, value) {
  stopifnot(
    is.data.frame(x),
    is.character(value),
    ncol(x) == length(value)
  )

  theseq <- if (!is.null(names(value))) names(value) else seq_along(x)
  # across columns of x
  for (j in theseq) {
    attr(x[[j]], "label") <- if (!is.na(value[j])) {
      value[j]
    } else {
      NULL
    }
  }

  x
}

#' Copy and Change Variable Labels of a \code{data.frame}
#'
#' Relabel a subset of the variables
#'
#' @inheritParams col_labels<-
#' @param ... name-value pairs, where name corresponds to a variable name in
#'   \code{x} and the value to the new variable label
#'
#' @return a copy of \code{x} with changed labels according to \code{...}
#'
#' @source This function was taken 1-1 from
#' \href{https://cran.r-project.org/web/packages/formatters/index.html}{formatters} package, to reduce the complexity of
#' the dependency tree.
#'
#' @seealso [col_labels()] [`col_labels<-`]
#'
#' @export
#'
#' @examples
#' x <- col_relabel(iris, Sepal.Length = "Sepal Length of iris flower")
#' col_labels(x)
#'
col_relabel <- function(x, ...) {
  stopifnot(is.data.frame(x))
  if (missing(...)) {
    return(x)
  }
  dots <- list(...)
  varnames <- names(dots)
  stopifnot(!is.null(varnames))

  map_varnames <- match(varnames, colnames(x))

  if (any(is.na(map_varnames))) {
    stop("variables: ", paste(varnames[is.na(map_varnames)], collapse = ", "), " not found")
  }

  if (any(vapply(dots, Negate(is.character), logical(1)))) {
    stop("all variable labels must be of type character")
  }

  for (i in seq_along(map_varnames)) {
    attr(x[[map_varnames[[i]]]], "label") <- dots[[i]]
  }

  x
}

#' Retrieve raw data
#'
#' @param x (`TealDataset`, `TealDatasetConnector`, `TealDataAbstract`)\cr
#'   object
#' @param dataname (`character`)\cr
#'  Name of dataset to return raw data for.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @return `data.frame` with the raw data inserted into the R6 objects. In case of
#' `TealDataAbstract`, `list` of `data.frame` can be returned
#' if user doesn't specify `dataname` - (`get_raw_data` from all datasets).
#'
#' @export
get_raw_data <- function(x, dataname = NULL) {
  checkmate::assert_string(dataname, null.ok = TRUE)
  UseMethod("get_raw_data")
}

#' @export
#' @rdname get_raw_data
#' @examples
#'
#' # TealDataset ---------
#' ADSL <- teal.data::example_cdisc_data("ADSL")
#'
#' x <- dataset(dataname = "ADSL", x = ADSL)
#' get_raw_data(x)
get_raw_data.TealDataset <- function(x, dataname = NULL) {
  if (!is.null(dataname)) {
    warning("'dataname' argument ignored - TealDataset can contain only one dataset.")
  }
  x$get_raw_data()
}

#' @export
#' @rdname get_raw_data
#' @examples
#'
#' # TealDatasetConnector ---------
#' library(magrittr)
#' pull_fun_adsl <- callable_function(teal.data::example_cdisc_data) %>%
#'   set_args(list(dataname = "ADSL"))
#' dc <- dataset_connector("ADSL", pull_fun_adsl)
#' load_dataset(dc)
#' get_raw_data(dc)
get_raw_data.TealDatasetConnector <- function(x, dataname = NULL) { # nolint
  if (!is.null(dataname)) {
    warning("'dataname' argument ignored - TealDatasetConnector can contain only one dataset.")
  }
  x$get_raw_data()
}

#' @rdname get_raw_data
#' @export
#' @examples
#'
#' # TealData ----------------
#' adsl <- cdisc_dataset(
#'   dataname = "ADSL",
#'   x = teal.data::example_cdisc_data("ADSL"),
#'   code = "library(teal.data)\nADSL <- teal.data::example_cdisc_data(\"ADSL\")"
#' )
#'
#' adtte <- cdisc_dataset(
#'   dataname = "ADTTE",
#'   x = teal.data::example_cdisc_data("ADTTE"),
#'   code = "library(teal.data)\nADTTE <- teal.data::example_cdisc_data(\"ADTTE\")"
#' )
#'
#' rd <- teal.data:::TealData$new(adsl, adtte)
#' get_raw_data(rd)
#'
#' # TealDataConnector --------
#' library(magrittr)
#'
#' slice_cdisc_data <- function(dataname, n) {
#'   head(example_cdisc_data(dataname), n)
#' }
#'
#' random_data_connector <- function(dataname) {
#'   fun_dataset_connector(
#'     dataname = dataname,
#'     fun = slice_cdisc_data,
#'     fun_args = list(dataname = dataname),
#'   )
#' }
#'
#' open_fun <- callable_function(library)
#' open_fun$set_args(list(package = "teal.data"))
#'
#' con <- data_connection(open_fun = open_fun)
#' con$set_open_server(
#'   function(id, connection) {
#'     moduleServer(
#'       id = id,
#'       module = function(input, output, session) {
#'         connection$open(try = TRUE)
#'         return(invisible(connection))
#'       }
#'     )
#'   }
#' )
#'
#' rdc <- relational_data_connector(
#'   connection = con,
#'   connectors = list(random_data_connector("ADSL"), random_data_connector("ADLB"))
#' )
#'
#' rdc$set_ui(
#'   function(id, connection, connectors) {
#'     ns <- NS(id)
#'     tagList(
#'       connection$get_open_ui(ns("open_connection")),
#'       numericInput(inputId = ns("n"), label = "Choose number of records", min = 0, value = 1),
#'       do.call(
#'         what = "tagList",
#'         args = lapply(
#'           connectors,
#'           function(connector) {
#'             div(
#'               connector$get_ui(
#'                 id = ns(connector$get_dataname())
#'               ),
#'               br()
#'             )
#'           }
#'         )
#'       )
#'     )
#'   }
#' )
#'
#' rdc$set_server(
#'   function(id, connection, connectors) {
#'     moduleServer(
#'       id = id,
#'       module = function(input, output, session) {
#'         # opens connection
#'         connection$get_open_server()(id = "open_connection", connection = connection)
#'         if (connection$is_opened()) {
#'           for (connector in connectors) {
#'             set_args(connector, args = list(n = input$n))
#'             # pull each dataset
#'             connector$get_server()(id = connector$get_dataname())
#'             if (connector$is_failed()) {
#'               break
#'             }
#'           }
#'         }
#'       }
#'     )
#'   }
#' )
#'
#' \dontrun{
#' load_datasets(rdc)
#' get_raw_data(rdc)
#' }
#'
#' # TealData (with connectors) --------
#' drc <- cdisc_data(rdc)
#' \dontrun{
#' get_raw_data(drc)
#' }
get_raw_data.TealDataAbstract <- function(x, dataname = NULL) { # nolint
  if (!is.null(dataname)) {
    datasets_names <- x$get_datanames()
    if (dataname %in% datasets_names) {
      if (is_pulled(x$get_items(dataname))) {
        get_raw_data(
          get_dataset(x, dataname = dataname)
        )
      } else {
        stop(
          sprintf("'%s' has not been pulled yet\n - please use `load_dataset()` first.", dataname),
          call. = FALSE
        )
      }
    } else {
      stop("The dataname supplied does not exist.")
    }
  } else {
    lapply(
      get_datasets(x),
      get_raw_data
    )
  }
}

## `CodeClass` ====
#'
#' @title Code Class
#' @keywords internal
#'
#' @examples
#' cc <- teal.data:::CodeClass$new()
#' cc$set_code(c("foo <- function() {1}", "foo2 <- function() {2}"))
#' cc$get_code()
#' cc$get_code(deparse = FALSE)
#'
#' cc$set_code(c("DF <- data.frame(x = 1:10)", "DF$y <- 1"), "DF")
#' cc$set_code("DF$a <- foo()", "DF")
#'
#' # dependent dataset
#' cc$set_code(c("DF2 <- data.frame(x2 = 1:10)", "DF2$y2 <- DF$y"), "DF2", deps = "DF")
#'
#' cc$set_code("baz <- function() {2}")
#' cc$set_code("DF2$a <- baz()", "DF2")
#'
#' cc$get_code()
#' cc$get_code("DF")
#' cc$get_code("DF2")
#'
#'
#' x1 <- teal.data:::CodeClass$new()
#' x1$set_code("DF <- data.frame(x = 1:10)", "DF")
#' x1$get_code()
#'
#' x2 <- teal.data:::CodeClass$new()
#' x2$set_code(c("DF2 <- data.frame(x2 = 1:10)", "DF2$x2 <- DF$x"), "DF2", deps = "DF")
#' x2$get_code()
#'
#' x <- teal.data:::CodeClass$new()
#' x$append(x1)
#' x$append(x2)
#'
#' x$get_code()
#' x$get_code("DF")
#' x$get_code("DF2")
#' x$get_code(c("DF", "DF2"))
#'
#' x3 <- teal.data:::CodeClass$new()
#' x3$set_code("DF3 <- data.frame(x3 = 1:10) ", "DF3")
#' x3$get_code()
#'
#' x$append(x3)
#' x$get_code("DF3")
#'
#' # mutation simulation
#' x$set_code("DF3$x <- foo(DF$x)", "DF3", deps = "DF")
#' x$get_code("DF3")
CodeClass <- R6::R6Class( # nolint
  "CodeClass",
  ## __Public Methods ====
  public = list(
    #' @description
    #' `CodeClass` constructor
    #' @param code (`character`) vector of code text to be set
    #' @param dataname optional, (`character`) vector of `datanames` to assign code to. If empty then the code
    #' is considered to be "global"
    #' @param deps optional, (`character`) vector of `datanames` that given code depends on
    #' @return object of class `CodeClass`
    initialize = function(code = character(0), dataname = character(0), deps = character(0)) {
      if (length(code) > 0) {
        self$set_code(code, dataname, deps)
      }
      logger::log_trace("CodeClass initialized.")
      return(invisible(self))
    },
    #' @description
    #' Append `CodeClass` object to a given `CodeClass` object
    #' @param x (`CodeClass`) object to be appended
    #' @return changed `CodeClass` object
    append = function(x) {
      stopifnot(inherits(x, "CodeClass"))
      if (length(x$code) > 0) {
        for (code_i in x$code) {
          private$set_code_single(code_i)
        }
        logger::log_trace("CodeClass$append CodeClass appended.")
      }

      return(invisible(self))
    },
    #' @description
    #' Set code in form of character
    #' @param code (`character`) vector of code text to be set
    #' @param dataname optional, (`character`) vector of `datanames` to assign code to. If empty then the code
    #' is considered to be "global"
    #' @param deps optional, (`character`) vector of `datanames` that given code depends on
    #'
    #' @return changed `CodeClass` object
    set_code = function(code, dataname = character(0), deps = character(0)) {
      checkmate::assert_character(code, min.len = 1, any.missing = FALSE)
      checkmate::assert_character(dataname, any.missing = FALSE)
      stopifnot(!(dataname %in% deps))

      code <- pretty_code_string(code)

      for (code_single in code) {
        private$set_code_single(code_single, dataname, deps)
      }
      logger::log_trace("CodeClass$set_code code set.")
      return(invisible(self))
    },
    #' @description
    #' Get the code for a given data names
    #' @param dataname optional, (`character`) vector of `datanames` for which the code is extracted.
    #' If `NULL` then get the code for all data names
    #' @param deparse optional, (`logical`) whether to return the deparsed form of a call
    #' @return `character` or `list` of calls
    get_code = function(dataname = NULL, deparse = TRUE) {
      checkmate::assert_character(dataname, min.len = 1, null.ok = TRUE, any.missing = FALSE)
      checkmate::assert_flag(deparse)
      if (is.null(dataname)) {
        private$get_code_all(deparse = deparse)
      } else {
        private$get_code_dataname(dataname = dataname, deparse = deparse)
      }
    },
    #' @description
    #' Evaluates internal code within given environment
    #' @param envir (`environment`) environment in which code will be evaluated
    #' @return invisibly `NULL`
    eval = function(envir = new.env(parent = parent.env(.GlobalEnv))) {
      for (x in self$get_code(deparse = FALSE)) {
        out <- tryCatch(
          base::eval(x, envir = envir),
          error = function(e) e
        )

        if (inherits(out, "error")) {
          error_msg <- sprintf(
            "%s\n\nEvaluation of the code failed:\n %s", deparse1(x, collapse = "\n"), conditionMessage(out)
          )

          rlang::with_options(
            stop(error_msg, call. = FALSE),
            warning.length = max(min(8170, nchar(error_msg) + 30), 100)
          )
        }
      }
      logger::log_trace("CodeClass$eval successfuly evaluated the code.")
      return(invisible(NULL))
    }
  ),
  private = list(
    ## __Private Fields ====
    .code = list(),
    deps = list(),
    ## __Private Methods ====
    set_code_single = function(code,
                               dataname = attr(code, "dataname"),
                               deps = attr(code, "deps"),
                               id = attr(code, "id")) {
      if (is.null(dataname)) dataname <- character(0)
      if (is.null(deps)) deps <- character(0)
      if (is.null(id)) id <- digest::digest(c(private$.code, code))
      # Line shouldn't be added when it contains the same code and the same `dataname`
      # as a line already present in an object of `CodeClass`
      if (
        !id %in% unlist(lapply(private$.code, "attr", "id")) ||
          all(
            vapply(dataname, FUN.VALUE = logical(1), FUN = function(x) {
              !x %in% unlist(lapply(private$.code, "attr", "dataname"))
            })
          )
      ) {
        attr(code, "dataname") <- dataname
        attr(code, "deps") <- deps
        attr(code, "id") <- id

        private$.code <- base::append(private$.code, list(code))
      }
      return(invisible(NULL))
    },
    get_code_all = function(deparse) {
      private$get_code_idx(idx = seq_along(private$.code), deparse = deparse)
    },
    get_code_dataname = function(dataname, deparse) {
      # the lines of code we need for the dataname
      res <- integer(0)
      # the set of datanames we want code for code for initially just dataname
      datanames <- dataname

      # loop backwards along code
      for (idx in rev(seq_along(private$.code))) {
        code_entry <- private$.code[[idx]]

        # line of code is one we want if it is not empty and
        # has any dataname attribute in the vector datanames or dataname starts with * or is global code and
        # already have some lines of code selected
        if (
          (
            any(datanames %in% attr(code_entry, "dataname")) ||
              any(grepl("^[*]", attr(code_entry, "dataname"))) ||
              (length(res) > 0 && length(attr(code_entry, "dataname")) == 0)
          ) &&
            length(code_entry) > 0
        ) {
          # append to index of code we want
          res <- c(idx, res)

          # and update datasets we want for preceding code with additional datanames and deps
          datanames <- unique(c(datanames, attr(code_entry, "dataname"), attr(code_entry, "deps")))
        }
      }
      private$get_code_idx(idx = res, deparse = deparse)
    },
    get_code_idx = function(idx, deparse) {
      if (isFALSE(deparse)) {
        return(Filter(
          Negate(is.null),
          unname(unlist(lapply(
            private$.code[idx],
            function(x) sapply(x, function(i) text_to_call(i), simplify = FALSE)
          )))
        ))
      } else {
        return(paste0(unlist(private$.code[idx]), collapse = "\n"))
      }
    }
  ),

  ## __Active Fields ====
  active = list(
    #' @field code (`list`) Derive the code of the dataset.
    code = function() {
      private$.code
    }
  )
)


## Functions ====

# Convert named list to `CodeClass` utilizing both `TealDatasetConnector` and `TealDataset`
list_to_code_class <- function(x) {
  checkmate::assert_list(x, min.len = 0, names = "unique")

  res <- CodeClass$new()

  if (length(x) > 0) {
    for (var_idx in seq_along(x)) {
      var_value <- x[[var_idx]]
      var_name <- names(x)[[var_idx]]
      if (inherits(var_value, "TealDatasetConnector") || inherits(var_value, "TealDataset")) {
        res$append(var_value$get_code_class())
        if (var_name != var_value$get_dataname()) {
          res$set_code(
            deparse1(call("<-", as.name(var_name), as.name(var_value$get_dataname())), collapse = "\n"),
            dataname = var_value$get_dataname()
          )
        }
      } else {
        var_code <- deparse1(call("<-", as.name(var_name), var_value), collapse = "\n")
        res$set_code(var_code, var_name)
      }
    }
  }
  return(res)
}

#' Create call from string
#'
#' @param x (`character`) string containing the code.
#'
#' @return (`call`) object.
#' @keywords internal
text_to_call <- function(x) {
  parsed <- parse(text = x, keep.source = FALSE)
  if (length(parsed) == 0) {
    return(NULL)
  } else {
    return(as.list(as.call(parsed))[[1]])
  }
}

#' Format a vector of code into a string
#'
#' @param code_vector (`character`) vector containing lines of
#'   code to format into a string.
#'
#' @return (`character`) string containing the formatted code.
#' @keywords internal
pretty_code_string <- function(code_vector) {
  # in order to remove bad formatting: text -> code -> text
  unlist(lapply(
    code_vector,
    function(code_single) {
      if (length(parse(text = code_single, keep.source = FALSE)) == 0) {
        # if string code cannot be passed into expression (e.g. code comment) then pass on the string
        code_single
      } else {
        vapply(
          as.list(as.call(parse(text = code_single, keep.source = FALSE))),
          deparse1,
          character(1),
          collapse = "\n"
        )
      }
    }
  ))
}

## CallablePythonCode ====
#'
#' @title A `CallablePythonCode` class of objects
#' @keywords internal
#'
CallablePythonCode <- R6::R6Class( # nolint

  ## __Public Methods ====
  classname = "CallablePythonCode",
  inherit = CallableFunction,
  public = list(
    #' @description
    #' Create a new `CallablePythonCode` object
    #'
    #' @param fun (`function`)\cr
    #'  function to be evaluated in class. Function should be named
    #' @param env (\code{environment})\cr
    #'  environment where the result of python code evaluation are stored
    #' @return new `CallablePythonCode` object
    initialize = function(fun, env = new.env(parent = parent.env(globalenv()))) {
      if (!requireNamespace("reticulate", quietly = TRUE)) {
        stop("Cannot load package 'reticulate' - please install the package.", call. = FALSE)
      }
      if (utils::packageVersion("reticulate") < 1.22) {
        stop("Please upgrade package 'reticulate', teal.data requires version >= 1.22")
      }

      super$initialize(fun = fun, env = env)
      logger::log_trace("CallablePythonCode initialized.")
      return(invisible(self))
    },
    #' @description
    #'   For scripts and code that contain multiple objects, save the name
    #'   of the object that corresponds to the final dataset of interest.
    #'   This is required for running python scripts with `reticulate`.
    #'
    #' @param x (`character`) the name of the object produced by the code
    #'   or script.
    #'
    #' @return (`self`) invisibly for chaining.
    set_object = function(x) {
      private$object <- x
      private$refresh()
      logger::log_trace("CallablePythonCode$set_object object set.")
      return(invisible(self))
    },
    #' @description
    #'   Execute `Callable` python code.
    #'
    #' @param args (`NULL` or named `list`)\cr
    #'  supplied for callable functions only, these are dynamic arguments passed to
    #'  `reticulate::py_run_string` or `reticulate::py_run_file`. Dynamic arguments
    #'  are executed in this call and are not saved which means that `self$get_call()`
    #'  won't include them later.
    #' @param try (`logical` value)\cr
    #'  whether perform function evaluation inside `try` clause
    #'
    #' @return nothing or output from function depending on `return`
    #' argument. If `run` fails it will return object of class `simple-error` error
    #' when `try = TRUE` or will stop if `try = FALSE`.
    run = function(args = NULL, try = FALSE) {
      rlang::with_options(
        res <- super$run(args = args, try = try),
        reticulate.engine.environment = private$env
      )
      if (is.null(res)) {
        stop("The specified python object returned NULL or does not exist in the python code")
      }
      res
    }
  ),

  ## __Private Fields ====
  private = list(
    object = NULL,

    ## __Private Methods ====
    # @description
    # Refresh call with function name and saved arguments
    #
    # @return nothing
    refresh = function() {
      # replaced str2lang found at:
      # https://rlang.r-lib.org/reference/call2.html
      private$call <- as.call(
        c(rlang::parse_expr(private$fun_name), private$args)
      )

      private$call <- rlang::parse_expr(
        sprintf("%s[[%s]]", deparse1(private$call, collapse = "\n"), deparse1(private$object, collapse = "\n"))
      )
    }
  )
)
## PythonCodeClass ====
#'
#' @title A `CallablePythonCode` class of objects
#' @description `r lifecycle::badge("experimental")`
#'
PythonCodeClass <- R6::R6Class( # nolint
  classname = "PythonCodeClass",
  inherit = CodeClass,

  ## __Public Methods ====
  public = list(
    #' @description
    #'   Evaluates internal code within environment
    #'
    #' @param vars (named `list`) additional pre-requisite vars to execute code
    #' @param dataname (`character`) name of the data frame object to be returned
    #' @param envir (`environment`) environment in which code will be evaluated
    #'
    #' @return `data.frame` containing the mutated dataset
    eval = function(vars = list(), dataname = NULL, envir = new.env(parent = parent.env(.GlobalEnv))) {
      checkmate::assert_list(vars, min.len = 0, names = "unique")
      execution_environment <- envir

      for (vars_idx in seq_along(vars)) {
        var_name <- names(vars)[[vars_idx]]
        var_value <- vars[[vars_idx]]
        if (inherits(var_value, "TealDatasetConnector") || inherits(var_value, "TealDataset")) {
          var_value <- get_raw_data(var_value)
        }
        assign(envir = execution_environment, x = var_name, value = var_value)
      }

      # execute
      rlang::with_options(
        super$eval(envir = execution_environment),
        reticulate.engine.environment = execution_environment
      )

      # return early if only executing and not grabbing the dataset
      if (is.null(dataname)) {
        return(as.environment(as.list(execution_environment)))
      }

      if (!is.data.frame(execution_environment[[dataname]])) {
        out_msg <- sprintf(
          "\n%s\n\n - Code from %s needs to return a data.frame assigned to an object of dataset name.",
          self$get_code(),
          self$get_dataname()
        )

        rlang::with_options(
          .expr = stop(out_msg, call. = FALSE),
          warning.length = max(min(8170, nchar(out_msg) + 30), 100)
        )
      }

      new_set <- execution_environment[[dataname]]
      logger::log_trace("PythonCodeClass$eval successfuly evaluated the code.")

      return(new_set)
    }
  )
)

#' Python Code
#'
#' `r lifecycle::badge("experimental")`
#' Create a python code object directly from python code or a
#' script containing python code.
#'
#' @details
#'   Used to mutate dataset connector objects with python code. See
#'   [`mutate_dataset`] or [`mutate_data`] for details.
#'
#' @param code (`character`)\cr
#'   Code to mutate the dataset. Must contain the `dataset$dataname`.
#' @param script (`character`)\cr
#'   file that contains python Code that can be read using `reticulate::py_run_script`.
#'
#' @return (`PythonCodeClass`) object containing python code
#' @export
#'
#' @examples
#' \dontrun{
#' library(reticulate)
#' library(magrittr)
#'
#' # mutate dataset object
#'
#' random_data_connector <- function(dataname) {
#'   fun_dataset_connector(
#'     dataname = dataname,
#'     fun = teal.data::example_cdisc_data,
#'     fun_args = list(dataname = dataname),
#'   )
#' }
#' x <- random_data_connector(dataname = "ADSL")
#'
#' x %>% mutate_dataset(python_code("import pandas as pd
#' r.ADSL = pd.DataFrame({'x': [1]})"))
#'
#' x$get_code()
#' x$pull()
#' x$get_raw_data()
#'
#' # mutate data object
#'
#' y <- 8
#' tc <- cdisc_data(
#'   random_data_connector(dataname = "ADSL"),
#'   random_data_connector(dataname = "ADLB")
#' )
#'
#' tc %>% mutate_data(python_code("import pandas as pd
#' r.ADSL = pd.DataFrame({'STUDYID': [r.y], 'USUBJID': [r.y]})"), vars = list(y = y))
#'
#'
#' load_datasets(tc) # submit all
#' ds <- tc$get_dataset("ADSL")
#' ds$get_raw_data()
#' }
python_code <- function(code = character(0), script = character(0)) {
  if (!xor(missing(code), missing(script))) stop("Exactly one of 'code' and 'script' is required")

  if (length(script) > 0) {
    code <- deparse(call("py_run_file", script))
  } else {
    code <- deparse(call("py_run_string", code))
  }
  py <- PythonCodeClass$new()
  py$set_code(code)

  return(py)
}

# TealDataConnector ------
#'
#'
#' @title Manage multiple and `TealDatasetConnector` of the same type.
#'
#' @description `r lifecycle::badge("stable")`
#' Class manages `TealDatasetConnector` to specify additional dynamic arguments and to
#' open/close connection.
#'
#' @param connection (`TealDataConnection`)\cr
#'   connection to data source
#' @param connectors (`list` of `TealDatasetConnector` elements)\cr
#'   list with dataset connectors
#'
#' @examples
#' library(magrittr)
#'
#' random_data_connector <- function(dataname) {
#'   fun_dataset_connector(
#'     dataname = dataname,
#'     fun = teal.data::example_cdisc_data,
#'     fun_args = list(dataname = dataname),
#'   )
#' }
#'
#' open_fun <- callable_function(library)
#' open_fun$set_args(list(package = "teal.data"))
#'
#' con <- data_connection(open_fun = open_fun)
#' con$set_open_server(
#'   function(id, connection) {
#'     moduleServer(
#'       id = id,
#'       module = function(input, output, session) {
#'         connection$open(try = TRUE)
#'         return(invisible(connection))
#'       }
#'     )
#'   }
#' )
#'
#' x <- teal.data:::TealDataConnector$new(
#'   connection = con,
#'   connectors = list(
#'     random_data_connector(dataname = "ADSL"),
#'     random_data_connector(dataname = "ADLB")
#'   )
#' )
#'
#' x$set_ui(
#'   function(id, connection, connectors) {
#'     ns <- NS(id)
#'     tagList(
#'       connection$get_open_ui(ns("open_connection")),
#'       numericInput(inputId = ns("n"), label = "Choose number of records", min = 0, value = 1),
#'       do.call(
#'         what = "tagList",
#'         args = lapply(
#'           connectors,
#'           function(connector) {
#'             div(
#'               connector$get_ui(
#'                 id = ns(connector$get_dataname())
#'               ),
#'               br()
#'             )
#'           }
#'         )
#'       )
#'     )
#'   }
#' )
#'
#' x$set_server(
#'   function(id, connection, connectors) {
#'     moduleServer(
#'       id = id,
#'       module = function(input, output, session) {
#'         # opens connection
#'         connection$get_open_server()(id = "open_connection", connection = connection)
#'         if (connection$is_opened()) {
#'           for (connector in connectors) {
#'             set_args(connector, args = list(n = input$n))
#'             # pull each dataset
#'             connector$get_server()(id = connector$get_dataname())
#'             if (connector$is_failed()) {
#'               break
#'             }
#'           }
#'         }
#'       }
#'     )
#'   }
#' )
#' \dontrun{
#' x$launch()
#' x$get_datasets()
#' }
TealDataConnector <- R6::R6Class( # nolint
  classname = "TealDataConnector",
  inherit = TealDataAbstract,

  ## __Public Methods ====
  public = list(
    #' @description
    #' Create a new `TealDataConnector` object
    initialize = function(connection, connectors) {
      checkmate::assert_list(connectors, types = "TealDatasetConnector", min.len = 1)

      connectors_names <- vapply(connectors, get_dataname, character(1))
      connectors <- setNames(connectors, connectors_names)

      private$check_names(connectors_names)

      if (!missing(connection)) {
        stopifnot(inherits(connection, "TealDataConnection"))
        private$connection <- connection
      }

      private$datasets <- connectors

      private$pull_code <- CodeClass$new()
      private$mutate_code <- CodeClass$new()

      self$id <- sample.int(1e11, 1, useHash = TRUE)


      logger::log_trace(
        "TealDataConnector initialized with data: { paste(self$get_datanames(), collapse = ' ') }."
      )
      return(invisible(self))
    },
    #' @description
    #' Prints this `TealDataConnector`.
    #'
    #' @param ... additional arguments to the printing method
    #' @return invisibly self
    print = function(...) {
      check_ellipsis(...)

      cat(sprintf(
        "A currently %s %s object containing %d TealDataset/TealDatasetConnector object(s) as element(s).\n",
        ifelse(self$get_connection()$is_opened(), "opened", "not yet opened"),
        class(self)[1],
        length(private$datasets)
      ))
      cat(sprintf(
        "%d of which is/are loaded/pulled:\n",
        sum(vapply(private$datasets, function(x) x$is_pulled(), FUN.VALUE = logical(1)))
      ))

      for (i in seq_along(private$datasets)) {
        cat(sprintf("--> Element %d:\n", i))
        print(private$datasets[[i]])
      }

      invisible(self)
    },

    # ___ getters ====
    #' @description
    #' Get connection to data source
    #'
    #' @return connector's connection
    get_connection = function() {
      return(private$connection)
    },
    #' @description
    #' Get internal `CodeClass` object
    #'
    #' @return `CodeClass`
    get_code_class = function() {
      all_code <- CodeClass$new()

      open_connection_code <- if (!is.null(private$connection)) {
        private$connection$get_open_call(deparse = TRUE)
      } else {
        NULL
      }

      if (!is.null(open_connection_code)) {
        all_code$set_code(open_connection_code, dataname = "*open")
      }
      datasets_code_class <- private$get_datasets_code_class()
      all_code$append(datasets_code_class)

      close_connection_code <- if (!is.null(private$connection)) {
        private$connection$get_close_call(deparse = TRUE, silent = TRUE)
      } else {
        NULL
      }

      if (!is.null(close_connection_code)) {
        all_code$set_code(close_connection_code, dataname = "*close")
      }

      mutate_code_class <- private$get_mutate_code_class()
      all_code$append(mutate_code_class)

      return(all_code)
    },
    #' @description get the server function
    #'
    #' @return the `server` function
    get_server = function() {
      if (is.null(private$server)) {
        stop("No server function set yet. Please use set_server method first.")
      }
      function(id, connection = private$connection, connectors = private$datasets) {
        rv <- reactiveVal(NULL)
        moduleServer(
          id = id,
          module = function(input, output, session) {
            private$server(id = "data_input", connection = connection, connectors = connectors)
          }
        )

        if (self$is_pulled()) {
          return(rv(TRUE))
        } else {
          return(rv(FALSE))
        }
      }
    },
    #' @description get the `preopen` server function
    #'
    #' @return the `server` function
    get_preopen_server = function() {
      function(id, connection = private$connection) {
        if (!is.null(private$preopen_server)) {
          moduleServer(
            id = id,
            module = function(input, output, session) {
              private$preopen_server(id = "data_input", connection = connection)
            }
          )
        }
      }
    },
    #' @description
    #' Get Shiny module with inputs for all `TealDatasetConnector` objects
    #'
    #' @param id `character` shiny element id
    #'
    #' @return the `ui` function
    get_ui = function(id) {
      if (is.null(private$ui)) {
        stop("No UI set yet. Please use set_ui method first.")
      }
      x <- function(id, connection = private$connection, connectors = private$datasets) {
        ns <- NS(id)
        tags$div(
          h3("Data Connector for:", lapply(self$get_datanames(), code)),
          tags$div(
            id = ns("data_input"),
            private$ui(id = ns("data_input"), connection = connection, connectors = connectors)
          )
        )
      }
      x(id)
    },

    # ___ setters ====
    #' @description
    #' Set argument to the `pull_fun`
    #'
    #' @param args (named `list`)\cr
    #'  arguments values as separate list elements named by argument name. These arguments
    #'  are passed to each dataset.
    #'
    #' @return nothing
    set_pull_args = function(args) {
      lapply(private$datasets, function(x) set_args(x, args))
      logger::log_trace("TealDataConnector$set_pull_args pull args set.")
      return(invisible(NULL))
    },
    #' @description
    #' Set connector UI function
    #'
    #' @param f (`function`)\cr
    #'  shiny module as function. Inputs specified in this `ui` are passed to server module
    #'  defined by `set_server` method.
    #'
    #' @return nothing
    set_ui = function(f) {
      stopifnot(inherits(f, "function"))
      stopifnot("id" %in% names(formals(f)))
      stopifnot(all(c("connection", "connectors") %in% names(formals(f))) || "..." %in% names(formals(f)))
      private$ui <- f
      logger::log_trace("TealDataConnector$set_ui ui set.")
      return(invisible(NULL))
    },
    #' @description
    #' Set connector server function
    #'
    #' This function will be called after submit button will be hit. There is no possibility to
    #' specify some dynamic `ui` as `server` function is executed after hitting submit
    #' button.
    #'
    #' @param f (`function`)\cr
    #'  A shiny module server function that should load data from all connectors
    #'
    #' @return nothing
    set_server = function(f) {
      stopifnot(inherits(f, "function"))
      stopifnot(all(c("id", "connection", "connectors") %in% names(formals(f))))
      private$server <- f
      logger::log_trace("TealDataConnector$set_server server set.")
      return(invisible(NULL))
    },
    #' @description
    #' Set connector pre-open server function
    #'
    #' This function will be called before submit button will be hit.
    #'
    #' @param f (`function`)\cr
    #'  A shiny module server function
    #'
    #' @return nothing
    set_preopen_server = function(f) {
      stopifnot(inherits(f, "function"))
      stopifnot(all(c("id", "connection") %in% names(formals(f))))
      private$preopen_server <- f
      logger::log_trace("TealDataConnector$set_preopen_server preopen_server set.")
      return(invisible(NULL))
    },

    # ___ pull ====
    #' @description
    #' Load data from each `TealDatasetConnector`
    #'
    #' @param con_args (`NULL` or named `list`)\cr
    #'   additional dynamic arguments for connection function. `args` will be passed to each
    #'  `TealDatasetConnector` object to evaluate `CallableFunction` assigned to
    #'  this dataset. If `args` is null than default set of arguments will be used, otherwise
    #'  call will be executed on these arguments only (arguments set before will be ignored).
    #'  `pull` function doesn't update reproducible call, it's just evaluate function.
    #'
    #' @param args (`NULL` or named `list`)\cr
    #'  additional dynamic arguments to pull dataset. `args` will be passed to each
    #'  `TealDatasetConnector` object to evaluate `CallableFunction` assigned to
    #'  this dataset. If `args` is null than default set of arguments will be used, otherwise
    #'  call will be executed on these arguments only (arguments set before will be ignored).
    #'  `pull` function doesn't update reproducible call, it's just evaluate function.
    #'
    #' @param try (`logical` value)\cr
    #'  whether perform function evaluation inside `try` clause
    #'
    #' @return (`self`) invisibly for chaining. In order to get the data please use `get_datasets` method.
    pull = function(con_args = NULL, args = NULL, try = TRUE) {
      logger::log_trace("TealDataConnector$pull pulling data...")
      # open connection
      if (!is.null(private$connection)) {
        private$connection$open(args = con_args, try = try)

        conn <- private$connection$get_conn()
        for (connector in private$datasets) {
          connector$get_pull_callable()$assign_to_env("conn", conn)
        }
      }

      # load datasets
      for (dataset in private$datasets) {
        load_dataset(dataset, args = args)
      }

      # close connection
      if (!is.null(private$connection)) private$connection$close(silent = TRUE)

      logger::log_trace("TealDataConnector$pull data pulled.")

      return(invisible(self))
    },
    #' @description
    #' Run simple application that uses its `ui` and `server` fields to pull data from
    #' connection.
    #'
    #' Useful for debugging
    #'
    #' @return An object that represents the app
    launch = function() {
      # load TealDatasetConnector objects
      if (self$is_pulled()) {
        stop("All the datasets have already been pulled.")
      }

      shinyApp(
        ui = fluidPage(
          include_js_files(),
          theme = get_teal_bs_theme(),
          fluidRow(
            column(
              width = 8,
              offset = 2,
              tags$div(
                id = "data_inputs",
                self$get_ui(id = "data_connector"),
                actionButton("submit", "Submit"),
                `data-proxy-click` = "submit" # handled by jscode in custom.js - hit enter to submit
              ),
              shinyjs::hidden(
                tags$div(
                  id = "data_loaded",
                  div(
                    h3("Data successfully loaded."),
                    p("You can close this window and get back to R console.")
                  )
                )
              )
            )
          )
        ),
        server = function(input, output, session) {
          session$onSessionEnded(stopApp)
          self$get_preopen_server()(
            id = "data_connector",
            connection = private$connection
          )
          observeEvent(input$submit, {
            rv <- reactiveVal(NULL)
            rv(
              self$get_server()(
                id = "data_connector",
                connection = private$connection,
                connectors = private$datasets
              )
            )

            observeEvent(rv(), {
              if (self$is_pulled()) {
                removeUI(sprintf("#%s", session$ns("data_inputs")))
                shinyjs::show("data_loaded")
                stopApp()
              }
            })
          })
        }
      )
    },

    # ___ mutate ====
    #' @description
    #' Mutate data by code.
    #'
    #' @param ... parameters inherited from `TealDataAbstract`.
    #'
    #' @return Informational message to not use mutate_data() with `TealDataConnectors`.
    mutate = function(...) {
      stop("TealDataConnectors do not support mutate_data().
      Please use mutate_data() with teal_data() or cdisc_data()")
    },

    # ___ status ====
    #' @description
    #' Check if pull or connection has not failed.
    #'
    #' @return `TRUE` if pull or connection failed, else `FALSE`
    is_failed = function() {
      private$connection$is_failed() ||
        any(vapply(private$datasets, function(x) x$is_failed(), logical(1)))
    }
  ),
  ## __Private Fields ====
  private = list(
    server = NULL, # shiny server function
    preopen_server = NULL, # shiny server function
    ui = NULL, # shiny ui function
    connection = NULL, # TealDataConnection

    ## __Private Methods ====
    # adds open/close connection code at beginning/end of the dataset code
    append_connection_code = function() {
      lapply(
        private$datasets,
        function(connector) {
          dataset <- get_dataset(connector)
          try(
            dataset$set_code(code = paste(
              c(
                if (!is.null(private$connection)) private$connection$get_open_call(deparse = TRUE),
                get_code(dataset, deparse = TRUE, FUN.VALUE = character(1)),
                if (!is.null(private$connection)) private$connection$get_close_call(deparse = TRUE, silent = TRUE)
              ),
              collapse = "\n"
            ))
          )
        }
      )
    }
  )
)

#' The constructor for `TealDataConnector` class.
#'
#' @description `r lifecycle::badge("stable")`
#' @param connection (`TealDataConnection`)\cr
#'   connection to data source
#' @param connectors (`list` of `TealDatasetConnector` elements)\cr
#'   list with dataset connectors
#'
#' @examples
#' library(magrittr)
#' random_data_connector <- function(dataname) {
#'   fun_dataset_connector(
#'     dataname = dataname,
#'     fun = teal.data::example_cdisc_data,
#'     fun_args = list(dataname = dataname),
#'   )
#' }
#'
#' open_fun <- callable_function(library)
#' open_fun$set_args(list(package = "teal.data"))
#'
#' con <- data_connection(open_fun = open_fun)
#' con$set_open_server(
#'   function(id, connection) {
#'     moduleServer(
#'       id = id,
#'       module = function(input, output, session) {
#'         connection$open(try = TRUE)
#'         return(invisible(connection))
#'       }
#'     )
#'   }
#' )
#'
#' x <- relational_data_connector(
#'   connection = con,
#'   connectors = list(
#'     random_data_connector(dataname = "ADSL"),
#'     random_data_connector(dataname = "ADLB")
#'   )
#' )
#'
#' x$set_ui(
#'   function(id, connection, connectors) {
#'     ns <- NS(id)
#'     tagList(
#'       connection$get_open_ui(ns("open_connection")),
#'       numericInput(inputId = ns("n"), label = "Choose number of records", min = 0, value = 1),
#'       do.call(
#'         what = "tagList",
#'         args = lapply(
#'           connectors,
#'           function(connector) {
#'             div(
#'               connector$get_ui(
#'                 id = ns(connector$get_dataname())
#'               ),
#'               br()
#'             )
#'           }
#'         )
#'       )
#'     )
#'   }
#' )
#'
#' x$set_server(
#'   function(id, connection, connectors) {
#'     moduleServer(
#'       id = id,
#'       module = function(input, output, session) {
#'         # opens connection
#'         connection$get_open_server()(id = "open_connection", connection = connection)
#'         if (connection$is_opened()) {
#'           for (connector in connectors) {
#'             set_args(connector, args = list(n = input$n))
#'             # pull each dataset
#'             connector$get_server()(id = connector$get_dataname())
#'             if (connector$is_failed()) {
#'               break
#'             }
#'           }
#'         }
#'       }
#'     )
#'   }
#' )
#' \dontrun{
#' x$launch()
#' x$get_datasets()
#' }
#'
#' @return `TealDataConnector` object
#' @export
relational_data_connector <- function(connection, connectors) {
  stopifnot(inherits(connection, "TealDataConnection"))
  checkmate::assert_list(connectors, types = "TealDatasetConnector", min.len = 1)
  TealDataConnector$new(connection, connectors)
}

## CallableFunction ====
#'
#' @title A \code{CallableFunction} class of objects
#'
#' @description Object that stores a function name together with its arguments.
#' Methods are then available to get the function call and evaluate it.
#'
#' @keywords internal
#'
CallableFunction <- R6::R6Class( # nolint
  "CallableFunction",
  inherit = Callable,

  ## __Public Methods ====
  public = list(
    #' @description
    #' Create a new \code{CallableFunction} object
    #'
    #' @param fun (\code{function})\cr
    #'  function to be evaluated in class.
    #'  This is either a `function` object or its name as a string.
    #' @param env (\code{environment})\cr
    #'  environment where function will be evaluated
    #'
    #' @return new \code{CallableFunction} object
    initialize = function(fun, env = new.env(parent = parent.env(globalenv()))) {
      super$initialize(env = env)
      if (missing(fun)) {
        stop("A valid function name must be provided.")
      }
      if (!(checkmate::test_string(fun) || is.function(fun) || is.call(fun) || is.symbol(fun))) {
        stop("CallableFunction can be specified as character, symbol, call or function")
      }

      fun_name <- private$get_callable_function(fun)
      private$fun_name <- deparse1(fun_name, collapse = "\n")

      private$refresh()

      logger::log_trace("CallableFunction initialized with function: { deparse1(private$fun_name) }.")

      return(invisible(self))
    },
    #' @description
    #' get the arguments a function gets called with
    #'
    #' @return arguments the function gets called with
    get_args = function() {
      return(private$args)
    },
    #' @description
    #' Get function call with substituted arguments in \code{args}.
    #' These arguments will not be stored in the object.
    #'
    #' @param deparse (\code{logical} value)\cr
    #'  whether to return a deparsed version of call
    #' @param args (\code{NULL} or named \code{list})\cr
    #'  dynamic arguments to function
    #'
    #' @return \code{call} or \code{character} depending on \code{deparse} argument
    get_call = function(deparse = TRUE, args = NULL) {
      checkmate::assert_flag(deparse)
      checkmate::assert_list(args, names = "strict", min.len = 0, null.ok = TRUE)

      old_args <- private$args
      if (length(args) > 0) self$set_args(args)

      res <- if (deparse) {
        deparse1(private$call, collapse = "\n")
      } else {
        private$call
      }

      # set args back to default
      if (length(args) > 0) {
        lapply(names(args), self$set_arg_value, NULL)
        self$set_args(old_args)
      }

      return(res)
    },
    #' @description
    #' Set up function arguments
    #'
    #' @param args (\code{NULL} or named \code{list})\cr
    #'  function arguments to be stored persistently in the object. Setting \code{args} doesn't
    #'  remove other \code{args}, only create new of modify previous of the same name.
    #'  To clean arguments specify \code{args = NULL}.
    #'
    #' @return (`self`) invisibly for chaining.
    set_args = function(args) {
      # remove args if empty
      if (length(args) == 0) {
        private$args <- NULL
        private$refresh()
        return(invisible(self))
      }
      checkmate::assert_list(args, min.len = 0, names = "unique")

      for (idx in seq_along(args)) {
        self$set_arg_value(
          name = names(args)[[idx]],
          value = args[[idx]]
        )
      }
      logger::log_trace(
        "CallableFunction$set_args args set for function: { deparse1(private$fun_name) }."
      )

      return(invisible(self))
    },
    #' @description
    #' Set up single function argument with value
    #'
    #' @param name (\code{character}) argument name
    #' @param value argument value
    #'
    #' @return (`self`) invisibly for chaining.
    set_arg_value = function(name, value) {
      checkmate::assert_string(name)
      arg_names <- names(formals(eval(str2lang(private$fun_name))))
      stopifnot(name %in% arg_names || "..." %in% arg_names || is.null(arg_names))

      if (length(private$args) == 0) {
        private$args <- list()
      }
      private$args[[name]] <- value

      private$refresh()
      logger::log_trace("CallableFunction$set_arg_value args values set for arg: { deparse1(name) }.")

      return(invisible(self))
    }
  ),

  ## __Private Fields ====
  private = list(
    fun_name = character(0),
    args = NULL, # named list with argument names and values
    ## __Private Methods ====
    # @description
    # Refresh call with function name and saved arguments
    #
    # @return nothing
    refresh = function() {
      if (!is.null(private$fun_name) || !identical(private$fun_name, character(0))) {

        # replaced str2lang found at:
        # https://rlang.r-lib.org/reference/call2.html
        private$call <- as.call(
          c(rlang::parse_expr(private$fun_name), private$args)
        )

        # exception for source(...)$value
        if (private$fun_name == "source") {
          private$call <- rlang::parse_expr(
            sprintf("%s$value", deparse1(private$call, collapse = "\n"))
          )
        } else if (private$fun_name %in% c("py_run_file", "py_run_string")) {
          private$call <- rlang::parse_expr(
            sprintf("%s[[%s]]", deparse1(private$call, collapse = "\n"), deparse1(private$object, collapse = "\n"))
          )
        }
      }
    },
    # @description
    # Returns a call to a function
    #
    # Returns the call to the function as defined in the enclosing environment.
    #
    # @param callable \code{function, character, call, symbol} the function to return
    #
    # @return `call` the call to the function
    #
    get_callable_function = function(callable) {
      if (is.character(callable) && private$is_prefixed_function(callable)) {
        private$get_call_from_prefixed_function(callable)
      } else {
        private$get_call_from_symbol(callable)
      }
    },
    # @param function_name (`character`) the function name prefixed with \code{::}
    # and the package name
    # @return `call` the call to the function passed to this method
    get_call_from_prefixed_function = function(function_name) {
      package_function_names <- strsplit(function_name, "::")[[1]]
      fun <- get(package_function_names[2], envir = getNamespace(package_function_names[1]))
      if (!is.function(fun)) {
        stop(sprintf("object '%s' of mode 'function' was not found", function_name))
      }
      str2lang(function_name)
    },
    # @param symbol (`function`, `symbol` or `character`) the item matching a function
    # @return `call` the call to the function passed to this method
    get_call_from_symbol = function(symbol) {
      fun <- match.fun(symbol)
      fun_environment <- environment(fun)
      if (isNamespace(fun_environment)) {
        fun_name <- get_binding_name(fun, fun_environment)
        namespace_name <- strsplit(rlang::env_name(fun_environment), ":")[[1]][2]
        if (namespace_name != "base") {
          fun_name <- paste(namespace_name, fun_name, sep = "::")
        }
        fun <- str2lang(fun_name)
      }
      fun
    },
    # Checks whether a character vector is of this format
    # <package_name>::<function_name>
    #
    # @param function_name (`character`) the character vector
    # @return `logical` `TRUE` if \code{function_name} is of the specified
    # format; `FALSE` otherwise
    #
    is_prefixed_function = function(function_name) {
      grepl("^[[:ascii:]]+::[[:ascii:]]+$", function_name, perl = TRUE)
    }
  )
)

## Constructors ====

#' Create \code{CallableFunction} object
#'
#' @description `r lifecycle::badge("stable")`
#' Create \code{\link{CallableFunction}} object to execute specific function and get reproducible
#' call.
#'
#' @param fun (\code{function})\cr
#'   any R function, directly by name or \code{character} string.
#'
#' @return \code{CallableFunction} object
#'
#' @export
#'
#' @examples
#' cf <- callable_function(fun = stats::median)
#' cf$set_args(list(x = 1:10, na.rm = FALSE))
#' cf$run()
#' cf$get_call()
callable_function <- function(fun) {
  CallableFunction$new(fun)
}

#' Gets the name of the binding
#'
#' Gets the name of the object by finding its origin.
#' Depending on type of object function uses different methods
#' to obtain original location. If no `env` is specified then
#' object is tracked by `substitute` along the `sys.frames`.
#' If `env` is specified then search is limited to specified
#' environment.\cr
#'
#' @note
#' Raises an error if the object is not found in the environment.
#'
#' @param object (R object)\cr
#'   any R object
#' @param envir (`environment`)\cr
#'  if origin of the object is known then should be provided for
#'  more precise search
#' @return character
#' @keywords internal
#'
get_binding_name <- function(object, envir) {
  bindings_names <- ls(envir)
  identical_binding_mask <- vapply(
    bindings_names,
    function(binding_name) identical(get(binding_name, envir), object),
    FUN.VALUE = logical(1),
    USE.NAMES = FALSE
  )
  if (length(bindings_names[identical_binding_mask]) == 0) {
    stop("Object not found in the environment")
  }
  bindings_names[identical_binding_mask]
}

#' Topological graph sort
#'
#' Graph is a list which for each node contains a vector of child nodes
#' in the returned list, parents appear before their children.
#'
#' Implementation of `Kahn` algorithm with a modification to maintain the order of input elements.
#'
#' @param graph (named `list`) list with node vector elements
#' @keywords internal
#'
#' @examples
#' teal.data:::topological_sort(list(A = c(), B = c("A"), C = c("B"), D = c("A")))
#' teal.data:::topological_sort(list(D = c("A"), A = c(), B = c("A"), C = c("B")))
#' teal.data:::topological_sort(list(D = c("A"), B = c("A"), C = c("B"), A = c()))
topological_sort <- function(graph) {
  # compute in-degrees
  in_degrees <- list()
  for (node in names(graph)) {
    in_degrees[[node]] <- 0
    for (to_edge in graph[[node]]) {
      in_degrees[[to_edge]] <- 0
    }
  }

  for (node in graph) {
    for (to_edge in node) {
      in_degrees[[to_edge]] <- in_degrees[[to_edge]] + 1
    }
  }

  # sort
  visited <- 0
  sorted <- list()
  zero_in <- list()
  for (node in names(in_degrees)) {
    if (in_degrees[[node]] == 0) zero_in <- append(zero_in, node)
  }
  zero_in <- rev(zero_in)

  while (length(zero_in) != 0) {
    visited <- visited + 1
    sorted <- c(zero_in[[1]], sorted)
    for (edge_to in graph[[zero_in[[1]]]]) {
      in_degrees[[edge_to]] <- in_degrees[[edge_to]] - 1
      if (in_degrees[[edge_to]] == 0) {
        zero_in <- append(zero_in, edge_to, 1)
      }
    }
    zero_in[[1]] <- NULL
  }

  if (visited != length(in_degrees)) {
    stop(
      "Graph is not a directed acyclic graph. Cycles involving nodes: ",
      paste0(setdiff(names(in_degrees), sorted), collapse = " ")
    )
  } else {
    return(sorted)
  }
}

#' Checks whether a graph is a `Directed Acyclic Graph (DAG)`
#'
#' @inheritParams topological_sort
#' @return `logical(1)` `TRUE` if the graph is a `DAG`; `FALSE` otherwise
#' @keywords internal
is_dag <- function(graph) {
  inherits(try(topological_sort(graph), silent = TRUE), "try-error")
}

## TealDataConnection ====
#' @title A `TealDataConnection` class of objects
#' @description `r lifecycle::badge("stable")`
#'
#' Objects of this class store the connection to a data source.
#' It can be a database or server connection.
#'
#' @examples
#' open_fun <- callable_function(data.frame) # define opening function
#' open_fun$set_args(list(x = 1:5)) # define fixed arguments to opening function
#'
#' close_fun <- callable_function(sum) # define closing function
#' close_fun$set_args(list(x = 1:5)) # define fixed arguments to closing function
#'
#' ping_fun <- callable_function(function() TRUE)
#'
#' x <- data_connection( # define connection
#'   ping_fun = ping_fun, # define ping function
#'   open_fun = open_fun, # define opening function
#'   close_fun = close_fun # define closing function
#' )
#'
#' x$set_open_args(args = list(y = letters[1:5])) # define additional arguments if necessary
#'
#' x$open() # call opening function
#' x$get_open_call() # check reproducible R code
#'
#' # get data from connection via TealDataConnector$get_dataset()
#' \dontrun{
#' x$open(args = list(x = 1:5, y = letters[1:5])) # able to call opening function with arguments
#' x$close() # call closing function
#' }
#'
TealDataConnection <- R6::R6Class( # nolint
  ## __Public Methods ====
  "TealDataConnection",
  public = list(
    #' @description
    #' Create a new `TealDataConnection` object
    #'
    #' @param open_fun (`CallableFunction`) function to open connection
    #' @param close_fun (`CallableFunction`) function to close connection
    #' @param ping_fun (`CallableFunction`) function to ping connection
    #' @param if_conn_obj optional, (`logical`) whether to store `conn` object returned from opening
    #'   connection
    #' @return new `TealDataConnection` object
    initialize = function(open_fun = NULL, close_fun = NULL, ping_fun = NULL, if_conn_obj = FALSE) {
      checkmate::assert_flag(if_conn_obj)
      if (!is.null(open_fun)) {
        stopifnot(inherits(open_fun, "Callable"))
        private$set_open_fun(open_fun)
      }
      if (!is.null(close_fun)) {
        stopifnot(inherits(close_fun, "Callable"))
        private$set_close_fun(close_fun)
      }
      if (!is.null(ping_fun)) {
        stopifnot(inherits(ping_fun, "Callable"))
        private$set_ping_fun(ping_fun)
      }
      private$if_conn_obj <- if_conn_obj

      private$open_ui <- function(id) {
        NULL
      }
      private$ping_ui <- function(id) {
        NULL
      }
      private$close_ui <- function(id) {
        NULL
      }

      logger::log_trace(
        sprintf(
          "TealDataConnection initialized with:%s%s%s%s.",
          if (!is.null(open_fun)) " open_fun" else "",
          if (!is.null(close_fun)) " close_fun" else "",
          if (!is.null(ping_fun)) " ping_fun" else "",
          if (if_conn_obj) " conn" else ""
        )
      )
      invisible(self)
    },
    #' @description
    #' Finalize method closing the connection.
    #'
    #' @return NULL
    finalize = function() {
      self$close(silent = TRUE, try = TRUE)
      NULL
    },
    #' @description
    #' If connection is opened
    #'
    #' If open connection has been successfully evaluated
    #'
    #' @return (`logical`) if connection is open
    is_opened = function() {
      return(private$opened)
    },
    #' @description
    #' Check if connection has not failed.
    #'
    #' @return (`logical`) `TRUE` if connection failed, else `FALSE`
    is_failed = function() {
      self$is_open_failed() || self$is_close_failed()
    },
    #' @description
    #' Run simple application that uses its `ui` and `server` fields to open the
    #' connection.
    #'
    #' Useful for debugging
    #'
    #' @return An object that represents the app
    launch = function() {
      shinyApp(
        ui = fluidPage(
          include_js_files(),
          theme = get_teal_bs_theme(),
          fluidRow(
            column(
              width = 8,
              offset = 2,
              tags$div(
                id = "connection_inputs",
                self$get_open_ui(id = "data_connection"),
                actionButton("submit", "Submit"),
                `data-proxy-click` = "submit" # handled by jscode in custom.js - hit enter to submit
              ),
              shinyjs::hidden(
                tags$div(
                  id = "connection_set",
                  div(
                    h3("Connection successfully set."),
                    p("You can close this window and get back to R console.")
                  )
                )
              )
            )
          )
        ),
        server = function(input, output, session) {
          session$onSessionEnded(stopApp)
          preopen_server <- self$get_preopen_server()
          if (!is.null(preopen_server)) {
            preopen_server(id = "data_connection", connection = self)
          }
          observeEvent(input$submit, {
            rv <- reactiveVal(NULL)
            open_server <- self$get_open_server()
            if (!is.null(open_server)) {
              rv(open_server(id = "data_connection", connection = self))
            }
            observeEvent(rv(), {
              if (self$is_opened()) {
                removeUI(sprintf("#%s", session$ns("connection_inputs")))
                shinyjs::show("connection_set")
                stopApp()
              }
            })
          })
        }
      )
    },
    # ___ open connection -----
    #' @description
    #' Open the connection.
    #'
    #' Note that if the connection is already opened then it does nothing.
    #'
    #' @param args (`NULL` or named `list`) additional arguments not set up previously
    #' @param silent (`logical`) whether convert all "missing function" errors to messages
    #' @param try (`logical`) whether perform function evaluation inside `try` clause
    #'
    #' @return returns `self` if successful or if connection has been already
    #' opened. If `open_fun` fails, app returns an error in form of
    #' `shinyjs::alert` (if `try = TRUE`) or breaks the app (if `try = FALSE`)
    #'
    open = function(args = NULL, silent = FALSE, try = FALSE) {
      logger::log_trace("TealDataConnection$open opening the connection...")
      checkmate::assert_list(args, min.len = 0, names = "unique", null.ok = TRUE)
      if (isFALSE(private$check_open_fun(silent = silent))) {
        return()
      }
      if (isTRUE(private$opened) && isTRUE(private$ping())) {
        private$opened <- TRUE
        logger::log_trace("TealDataConnection$open connection already opened - skipped.")
        return(invisible(self))
      } else {
        open_res <- private$open_fun$run(args = args, try = try)
        if (!self$is_open_failed()) {
          private$opened <- TRUE
          if (private$if_conn_obj && !is.null(open_res)) {
            private$conn <- open_res

            if (!is.null(private$close_fun)) {
              private$close_fun$assign_to_env("conn", private$conn)
            }
            if (!is.null(private$ping_fun)) {
              private$ping_fun$assign_to_env("conn", private$conn)
            }
          }
          logger::log_trace("TealDataConnection$open connection opened.")
        } else {
          private$opened <- FALSE
          private$conn <- NULL
          logger::log_error("TealDataConnection$open connection failed to open.")
        }

        return(invisible(self))
      }
    },

    #' @description
    #' Get internal connection object
    #'
    #' @return `connection` object
    get_conn = function() {
      return(private$conn)
    },
    #' @description
    #' Get executed open connection call
    #'
    #' @param deparse (`logical`) whether return deparsed form of a call
    #' @param args (`NULL` or named `list`) additional arguments not set up previously
    #' @param silent (`logical`) whether convert all "missing function" errors to messages
    #'
    #' @return optionally deparsed `call` object
    get_open_call = function(deparse = TRUE, args = NULL, silent = FALSE) {
      checkmate::assert_flag(deparse)
      checkmate::assert_list(args, min.len = 0, names = "unique", null.ok = TRUE)
      if (isFALSE(private$check_open_fun(silent = silent))) {
        return()
      }
      open_call <- private$open_fun$get_call(deparse = FALSE, args = args)

      if (private$if_conn_obj) {
        open_call <- call("<-", as.name("conn"), open_call)
      }

      if (isTRUE(deparse)) {
        deparse1(open_call, collapse = "\n")
      } else {
        open_call
      }
    },
    #' @description
    #' Get error message from last connection
    #'
    #' @return (`character`)\cr
    #'  text of the error message or `character(0)` if last
    #'  connection was successful.
    get_open_error_message = function() {
      return(private$open_fun$get_error_message())
    },
    #' @description
    #' Get shiny server module prior opening connection.
    #'
    #' @return (`function`) shiny server prior opening connection.
    get_preopen_server = function() {
      return(private$preopen_server)
    },
    #' @description
    #' Get shiny server module to open connection.
    #'
    #' @return (`function`) shiny server to open connection.
    get_open_server = function() {
      return(private$open_server)
    },
    #' @description
    #' Get Shiny module with inputs to open connection
    #'
    #' @param id `character` shiny element id
    #'
    #' @return (`function`) shiny UI to set arguments to open connection function.
    get_open_ui = function(id) {
      return(private$open_ui(id))
    },
    #' @description
    #' Check if open connection has not failed.
    #'
    #' @return (`logical`) `TRUE` if open connection failed, else `FALSE`
    is_open_failed = function() {
      if (!is.null(private$open_fun)) {
        private$open_fun$is_failed()
      } else {
        FALSE
      }
    },
    #' @description
    #' Set open connection function argument
    #'
    #' @param args (`NULL` or named `list`) with values where list names are argument names
    #' @param silent (`logical`) whether convert all "missing function" errors to messages
    #'
    #' @return (`self`) invisibly for chaining.
    set_open_args = function(args, silent = FALSE) {
      checkmate::assert_list(args, min.len = 0, names = "unique", null.ok = TRUE)
      if (isFALSE(private$check_open_fun(silent = silent))) {
        return()
      }
      private$open_fun$set_args(args)
      logger::log_trace("TealDataConnection$set_open_args open args set.")

      return(invisible(self))
    },
    #' @description
    #' Set pre-open connection server function
    #'
    #' This function will be called before submit button will be hit.
    #'
    #' @param preopen_module (`function`)\cr
    #'  A shiny module server function
    #'
    #' @return (`self`) invisibly for chaining.
    set_preopen_server = function(preopen_module) {
      stopifnot(inherits(preopen_module, "function"))
      module_name <- "open_conn"
      if (all(names(formals(preopen_module)) %in% c("input", "output", "session", "connection"))) {
        private$preopen_server <- function(input, output, session, connection) {
          callModule(preopen_module, id = module_name, connection = connection)
        }
      } else if (all(names(formals(preopen_module)) %in% c("id", "connection"))) {
        private$preopen_server <- function(id, connection) {
          moduleServer(
            id = id,
            module = function(input, output, session) {
              preopen_module(id = module_name, connection = connection)
            }
          )
        }
      } else {
        stop(paste(
          "set_preopen_server accepts only a valid shiny module",
          "definition with a single additional parameter 'connection'."
        ))
      }
      logger::log_trace("TealDataConnection$set_preopen_server preopen_server set.")

      invisible(self)
    },
    #' @description
    #' Set open connection server function
    #'
    #' This function will be called after submit button will be hit. There is no possibility to
    #' specify some dynamic `ui` as `server` function is executed after hitting submit
    #' button.
    #'
    #' @param open_module (`function`)\cr
    #'  A shiny module server function that should load data from all connectors
    #'
    #' @return (`self`) invisibly for chaining.
    set_open_server = function(open_module) {
      stopifnot(inherits(open_module, "function"))
      module_name <- "open_conn"
      if (all(names(formals(open_module)) %in% c("input", "output", "session", "connection"))) {
        private$open_server <- function(input, output, session, connection) {
          withProgress(message = "Opening connection", value = 1, {
            callModule(open_module, id = module_name, connection = connection)
          })
        }
      } else if (all(names(formals(open_module)) %in% c("id", "connection"))) {
        private$open_server <- function(id, connection) {
          moduleServer(
            id = id,
            module = function(input, output, session) {
              withProgress(message = "Opening connection", value = 1, {
                open_module(id = module_name, connection = connection)
              })
            }
          )
        }
      } else {
        stop(paste(
          "set_open_server accepts only a valid shiny module",
          "definition with a single additional parameter 'connection'."
        ))
      }
      logger::log_trace("TealDataConnection$set_open_server open_server set.")

      invisible(self)
    },
    #' @description
    #' Set open connection UI function
    #'
    #' @param open_module (`function`)\cr
    #'  shiny module as function. Inputs specified in this `ui` are passed to server module
    #'  defined by `set_open_server` method.
    #'
    #' @return (`self`) invisibly for chaining.
    set_open_ui = function(open_module) {
      stopifnot(inherits(open_module, "function"))
      stopifnot(identical(names(formals(open_module)), "id"))

      private$open_ui <- function(id) {
        ns <- NS(id)
        tags$div(
          tags$div(
            id = ns("open_conn"),
            open_module(id = ns("open_conn"))
          )
        )
      }
      logger::log_trace("TealDataConnection$set_open_ui open_ui set.")

      invisible(self)
    },
    # ___ close connection -------
    #' @description
    #' Close the connection.
    #'
    #' @param silent (`logical`) whether convert all "missing function" errors to messages
    #' @param try (`logical`) whether perform function evaluation inside `try` clause
    #'
    #' @return returns (`self`) if successful. For unsuccessful evaluation it
    #' depends on `try` argument: if `try = TRUE` then returns
    #' `error`, for `try = FALSE` otherwise
    close = function(silent = FALSE, try = FALSE) {
      logger::log_trace("TealDataConnection$close closing the connection...")
      if (isFALSE(private$check_close_fun(silent = silent))) {
        return()
      }
      close_res <- private$close_fun$run(try = try)
      if (inherits(close_res, "error")) {
        logger::log_error("TealDataConnection$close failed to close the connection.")
        return(close_res)
      } else {
        private$opened <- FALSE
        private$conn <- NULL
        logger::log_trace("TealDataConnection$close connection closed.")
        return(invisible(NULL))
      }
    },
    #' @description
    #' Get executed close connection call
    #'
    #' @param deparse (`logical`) whether return deparsed form of a call
    #' @param silent (`logical`) whether convert all "missing function" errors to messages
    #'
    #' @return optionally deparsed `call` object
    get_close_call = function(deparse = TRUE, silent = FALSE) {
      checkmate::assert_flag(deparse)
      if (isFALSE(private$check_close_fun(silent = silent))) {
        return()
      }
      private$close_fun$get_call(deparse = deparse)
    },
    #' @description
    #' Get error message from last connection
    #'
    #' @return (`character`)\cr
    #'  text of the error message or `character(0)` if last
    #'  connection was successful.
    get_close_error_message = function() {
      return(private$close_fun$get_error_message())
    },
    #' @description
    #' Get shiny server module to close connection.
    #'
    #' @return the `server function` to close connection.
    get_close_server = function() {
      return(private$close_server)
    },
    #' @description
    #' Check if close connection has not failed.
    #'
    #' @return (`logical`) `TRUE` if close connection failed, else `FALSE`
    is_close_failed = function() {
      if (!is.null(private$close_fun)) {
        private$close_fun$is_failed()
      } else {
        FALSE
      }
    },

    #' @description
    #' Set close connection function argument
    #'
    #' @param args (named `list`) with values where list names are argument names
    #' @param silent (`logical`) whether convert all "missing function" errors to messages
    #'
    #' @return (`self`) invisibly for chaining.
    set_close_args = function(args, silent = FALSE) {
      checkmate::assert_list(args, min.len = 0, names = "unique", null.ok = TRUE)
      if (isFalse(private$check_close_fun(silent = silent))) {
        return()
      }
      private$close_fun$set_args(args)
      logger::log_trace("TealDataConnection$set_close_args close_args set")

      return(invisible(self))
    },

    #' @description
    #' Set close connection UI function
    #'
    #' @param close_module (`function`)\cr
    #'  shiny module as function. Inputs specified in this `ui` are passed to server module
    #'  defined by `set_close_server` method.
    #'
    #' @return (`self`) invisibly for chaining.
    set_close_ui = function(close_module) {
      stopifnot(inherits(close_module, "function"))
      stopifnot(identical(names(formals(close_module)), "id"))

      private$close_ui <- function(id) {
        ns <- NS(id)
        tags$div(
          tags$div(
            id = ns("close_conn"),
            close_module(id = ns("close_conn"))
          )
        )
      }
      logger::log_trace("TealDataConnection$close_ui close_ui set.")

      return(invisible(self))
    },

    #' @description
    #' Set close-connection server function
    #'
    #' This function will be called after submit button will be hit. There is no possibility to
    #' specify some dynamic `ui` as `server` function is executed after hitting submit
    #' button.
    #'
    #' @param close_module (`function`)\cr
    #'  A shiny module server function that should load data from all connectors
    #'
    #' @return (`self`) invisibly for chaining.
    set_close_server = function(close_module) {
      stopifnot(inherits(close_module, "function"))
      if (all(names(formals(close_module)) %in% c("input", "output", "session", "connection"))) {
        function(input, output, session, connection) {
          connection$close(try = TRUE)

          if (connection$is_close_failed()) {
            shinyjs::alert(
              paste(
                "Error closing connection\nError message: ",
                connection$get_close_error_message()
              )
            )
          }
          invisible(connection)
        }
      } else if (all(names(formals(close_module)) %in% c("id", "connection"))) {
        function(id, connection) {
          moduleServer(
            id,
            function(input, output, session) {
              connection$close(try = TRUE)

              if (connection$is_close_failed()) {
                shinyjs::alert(
                  paste(
                    "Error closing connection\nError message: ",
                    connection$get_close_error_message()
                  )
                )
              }
              invisible(connection)
            }
          )
        }
      } else {
        stop(paste(
          "set_close_server accepts only a valid shiny module",
          "definition with a single additional parameter 'connection'."
        ))
      }
      logger::log_trace("TealDataConnection$set_close_server close_server set.")

      invisible(self)
    }
  ),
  ## __Private Fields ====
  private = list(
    # callableFunctions
    open_fun = NULL,
    close_fun = NULL,
    ping_fun = NULL,

    # connection object
    if_conn_obj = FALSE,
    conn = NULL,

    # shiny elements
    open_ui = NULL,
    close_ui = NULL,
    ping_ui = NULL,
    preopen_server = NULL,
    open_server = NULL,
    close_server = NULL,
    ping_server = NULL,
    opened = FALSE,

    ## __Private Methods ====
    # need to have a custom deep_clone because one of the key fields are reference-type object
    # in particular: open_fun is a R6 object that wouldn't be cloned using default clone(deep = T)
    deep_clone = function(name, value) {
      deep_clone_r6(name, value)
    },
    check_open_fun = function(silent = FALSE) {
      checkmate::assert_flag(silent)

      if (is.null(private$open_fun)) {
        msg <- "Open connection function not set"
        if (silent) {
          return(FALSE)
        } else {
          stop(msg)
        }
      } else {
        return(TRUE)
      }
    },
    check_close_fun = function(silent = FALSE) {
      checkmate::assert_flag(silent)

      if (is.null(private$close_fun)) {
        msg <- "Close connection function not set"
        if (silent) {
          return(FALSE)
        } else {
          stop(msg)
        }
      } else {
        return(TRUE)
      }
    },
    # @description
    # Set close connection function
    #
    # @param fun (`Callable`) function to close connection
    #
    # @return (`self`) invisibly for chaining.
    set_close_fun = function(fun) {
      stopifnot(inherits(fun, "Callable"))
      private$close_fun <- fun
      return(invisible(self))
    },
    # @description
    # Set open connection function
    #
    # @param fun (`Callable`) function to open connection
    #
    # @return (`self`) invisibly for chaining.
    set_open_fun = function(fun) {
      stopifnot(inherits(fun, "Callable"))
      private$open_fun <- fun
      return(invisible(self))
    },
    # @description
    # Set a ping function
    #
    # @param fun (`Callable`) function to ping connection
    #
    # @return (`self`) invisibly for chaining.
    set_ping_fun = function(fun) {
      stopifnot(inherits(fun, "Callable"))
      private$ping_fun <- fun
      return(invisible(self))
    },
    # @description
    # Ping the connection.
    #
    # @return (`logical`)
    ping = function() {
      logger::log_trace("TealDataConnection$ping pinging the connection...")
      if (!is.null(private$ping_fun)) {
        ping_res <- isTRUE(private$ping_fun$run())
        logger::log_trace("TealDataConnection$ping ping result: { ping_res }.")
        return(ping_res)
      } else {
        return(invisible(NULL))
      }
    }
  )
)

#' The constructor for `TealDataConnection` class.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param open_fun (`CallableFunction`) function to open connection
#' @param close_fun (`CallableFunction`) function to close connection
#' @param ping_fun (`CallableFunction`) function to ping connection
#' @param if_conn_obj optional, (`logical`) whether to store `conn` object returned from opening
#'
#' @examples
#' open_fun <- callable_function(data.frame) # define opening function
#' open_fun$set_args(list(x = 1:5)) # define fixed arguments to opening function
#'
#' close_fun <- callable_function(sum) # define closing function
#' close_fun$set_args(list(x = 1:5)) # define fixed arguments to closing function
#'
#' ping_fun <- callable_function(function() TRUE)
#'
#' x <- data_connection( # define connection
#'   ping_fun = ping_fun, # define ping function
#'   open_fun = open_fun, # define opening function
#'   close_fun = close_fun # define closing function
#' )
#'
#' x$set_open_args(args = list(y = letters[1:5])) # define additional arguments if necessary
#'
#' x$open() # call opening function
#' x$get_open_call() # check reproducible R code
#'
#' # get data from connection via TealDataConnector$get_dataset()
#' \dontrun{
#' x$open(args = list(x = 1:5, y = letters[1:5])) # able to call opening function with arguments
#' x$close() # call closing function
#' }
#'
#' @return `TealDataConnection` object
#' @export
data_connection <- function(open_fun = NULL, close_fun = NULL, ping_fun = NULL, if_conn_obj = FALSE) {
  TealDataConnection$new(
    open_fun = open_fun, close_fun = close_fun, ping_fun = ping_fun, if_conn_obj = if_conn_obj
  )
}

## TealDatasetConnector ====
#'
#'
#' @title A `TealDatasetConnector` class of objects
#'
#' @description `r lifecycle::badge("stable")`
#' Objects of this class store the connection function to fetch a single dataset.
#' Note that for some specific connection types,
#' an object of class `TealDataConnection` must be provided.
#' Data can be pulled via the `pull` method and accessed directly
#' through the `dataset` active binding.
#' Pulled data inherits from the class [`TealDataset`]
#'
#' @param dataname (`character`)\cr
#'  A given name for the dataset it may not contain spaces
#'
#' @param pull_callable (`CallableFunction`)\cr
#'   function with necessary arguments set to fetch data from connection.
#'
#' @param keys optional, (`character`)\cr
#'  vector of dataset primary keys column names
#'
#' @param label (`character`)\cr
#'  Label to describe the dataset.
#'
#' @param code (`character`)\cr
#'  A character string defining code to modify `raw_data` from this dataset. To modify
#'  current dataset code should contain at least one assignment to object defined in `dataname`
#'  argument. For example if `dataname = ADSL` example code should contain
#'  `ADSL <- <some R code>`. Can't be used simultaneously with `script`
#'
#' @param script (`character`)\cr
#'   Alternatively to `code` - location of the file containing modification code.
#'   Can't be used simultaneously with `script`.
#'
#' @param vars (named `list`)) \cr
#'   In case when this object code depends on other `TealDataset` object(s) or
#'   other constant value, this/these object(s) should be included as named
#'   element(s) of the list. For example if this object code needs `ADSL`
#'   object we should specify `vars = list(ADSL = <adsl object>)`.
#'   It's recommended to include `TealDataset` or `TealDatasetConnector` objects to
#'   the `vars` list to preserve reproducibility. Please note that `vars`
#'   are included to this object as local `vars` and they cannot be modified
#'   within another dataset.
#'
#' @param metadata (named `list`, `NULL` or `CallableFunction`) \cr
#'   Field containing either the metadata about the dataset (each element of the list
#'   should be atomic and length one) or a `CallableFuntion` to pull the metadata
#'   from a connection. This should return a `list` or an object which can be
#'   converted to a list with `as.list`.
TealDatasetConnector <- R6::R6Class( # nolint

  ## __Public Methods ====
  classname = "TealDatasetConnector",
  public = list(
    #' @description
    #' Create a new `TealDatasetConnector` object. Set the pulling function
    #' `CallableFunction` which returns a `data.frame` or `MultiAssayExperiment`,
    #' e.g. by reading from a function or creating it on the fly.
    initialize = function(dataname,
                          pull_callable,
                          keys = character(0),
                          label = character(0),
                          code = character(0),
                          vars = list(),
                          metadata = NULL) {
      private$set_pull_callable(pull_callable)
      private$set_var_r6(vars)
      private$set_pull_vars(vars)

      private$set_dataname(dataname)
      private$set_metadata(metadata)

      self$set_dataset_label(label)
      self$set_keys(keys)

      if (length(code) > 0) {
        # just needs a dummy TealDataset object to store mutate code, hence col = 1
        private$dataset <- TealDataset$new(dataname = self$get_dataname(), x = data.frame(col = 1))
        private$dataset$mutate(code = code, vars = vars, force_delay = TRUE)
      }

      logger::log_trace("TealDatasetConnector initialized for dataset: { deparse1(self$get_dataname()) }.")

      return(invisible(self))
    },
    #' @description
    #' Prints this `TealDatasetConnector`.
    #'
    #' @param ... additional arguments to the printing method
    #' @return invisibly self
    print = function(...) {
      check_ellipsis(...)

      cat(sprintf(
        "A %s object, named %s, containing a TealDataset object that has %sbeen loaded/pulled%s\n",
        class(self)[1],
        self$get_dataname(),
        ifelse(self$is_pulled(), "", "not "),
        ifelse(self$is_pulled(), ":", "")
      ))
      if (self$is_pulled()) {
        print(self$get_dataset())
      }

      invisible(self)
    },

    # ___ getters ====
    #' @description
    #' Get `dataname` of dataset
    #'
    #' @return `dataname` of the dataset
    get_dataname = function() {
      return(private$dataname)
    },
    #' @description
    #' Get `dataname` of dataset
    #'
    #' @return `character` `dataname` of the dataset
    get_datanames = function() {
      return(private$dataname)
    },
    #' @description
    #' Get label of dataset
    #'
    #' @return `character` dataset label
    get_dataset_label = function() {
      return(private$dataset_label)
    },
    #' @description
    #' Get primary keys of dataset
    #' @return `character` vector with dataset primary keys
    get_keys = function() {
      return(private$keys)
    },
    #' @description
    #' Get code to get data
    #'
    #' @param deparse (`logical`)\cr
    #'  whether return deparsed form of a call
    #'
    #' @return optionally deparsed `call` object
    get_code = function(deparse = TRUE) {
      checkmate::assert_flag(deparse)
      return(self$get_code_class()$get_code(deparse = deparse))
    },
    #' @description
    #' Get internal `CodeClass` object
    #'
    #' @return `CodeClass`
    get_code_class = function() {
      code_class <- CodeClass$new()
      pull_code_class <- private$get_pull_code_class()
      code_class$append(pull_code_class)

      if (!is.null(private$dataset)) {
        executed_code_in_dataset <- private$dataset$get_code_class()
        code_class$append(executed_code_in_dataset)
      }

      return(code_class)
    },
    #' @description
    #'
    #' Derive the arguments this connector will pull with
    #' @return `list` of pull function fixed arguments
    get_pull_args = function() {
      private$pull_callable$get_args()
    },
    #' @description
    #' Get dataset
    #'
    #' @return dataset (`TealDataset`)
    get_dataset = function() {
      if (!self$is_pulled()) {
        stop(
          sprintf("'%s' has not been pulled yet\n - please use `load_dataset()` first.", self$get_dataname()),
          call. = FALSE
        )
      }
      private$dataset$get_dataset()
      return(private$dataset)
    },
    #' @description
    #' Get error message from last pull
    #'
    #' @return `character` object with error message or `character(0)` if last
    #'  pull was successful.
    get_error_message = function() {
      return(private$pull_callable$get_error_message())
    },
    #' @description
    #' Get pull function
    #'
    #' @return `CallableFunction`
    get_pull_callable = function() {
      return(private$pull_callable)
    },
    #' @description
    #' Get raw data from dataset
    #'
    #' @return `data.frame` or `MultiAssayExperiment` data
    get_raw_data = function() {
      dataset <- self$get_dataset()
      return(dataset$get_raw_data())
    },
    #' @description
    #' Get the list of dependencies that are `TealDataset` or `TealDatasetConnector` objects
    #'
    #' @return `list`
    get_var_r6 = function() {
      return(private$var_r6)
    },

    # ___ setters ====
    #' @description
    #' Reassign `vars` in this object to keep references up to date after deep clone.
    #' Update is done based on the objects passed in `datasets` argument. Reassignment
    #' refers only to the provided `datasets`, other `vars` remains the same.
    #' @param datasets (`named list` of `TealDataset(s)` or `TealDatasetConnector(s)`)\cr
    #'   objects with valid pointers.
    #' @return NULL invisible
    reassign_datasets_vars = function(datasets) {
      logger::log_trace(
        "TealDatasetConnector$reassign_datasets_vars reassigning vars in dataset: { self$get_dataname() }."
      )
      checkmate::assert_list(datasets, min.len = 0, names = "unique")

      common_var_r6 <- intersect(names(datasets), names(private$var_r6))
      private$var_r6[common_var_r6] <- datasets[common_var_r6]

      common_vars <- intersect(names(datasets), names(private$pull_vars))
      private$pull_vars[common_vars] <- datasets[common_vars]

      if (!is.null(private$dataset)) {
        private$dataset$reassign_datasets_vars(datasets)
      }
      logger::log_trace(
        "TealDatasetConnector$reassign_datasets_vars reassigned vars in dataset: { self$get_dataname() }."
      )

      invisible(NULL)
    },
    #' @description
    #' Set label of the `dataset` object
    #'
    #' @return (`self`) invisibly for chaining
    set_dataset_label = function(label) {
      if (is.null(label)) {
        label <- character(0)
      }
      checkmate::assert_character(label, max.len = 1, any.missing = FALSE)
      private$dataset_label <- label
      if (self$is_pulled()) {
        private$dataset$set_dataset_label(label)
      }
      logger::log_trace(
        "TealDatasetConnector$set_dataset_label label set for dataset: { deparse1(self$get_dataname()) }."
      )

      return(invisible(self))
    },
    #' @description
    #' Set new keys
    #' @return (`self`) invisibly for chaining.
    set_keys = function(keys) {
      checkmate::assert_character(keys, any.missing = FALSE)
      if (isTRUE(self$is_pulled())) {
        set_keys(private$dataset, keys)
      }
      private$keys <- keys
      logger::log_trace("TealDatasetConnector$set_keys keys set for dataset: { deparse1(self$get_dataname()) }.")

      return(invisible(self))
    },

    # ___ pull ====
    #' @description
    #' Pull the data (and metadata if it is a `Callable`)
    #'
    #' Read or create data using `pull_callable` specified in the constructor.
    #'
    #' @param args (`NULL` or named `list`)\cr
    #'  additional dynamic arguments for pull function. `args` can be omitted if `pull_callable`
    #'  from constructor already contains all necessary arguments to pull data. One can try
    #'  to execute `pull_callable` directly by `x$pull_callable$run()` or to get code using
    #'  `x$pull_callable$get_code()`. `args` specified in pull are used temporary to get data but
    #'  not saved in code.
    #' @param try (`logical` value)\cr
    #'  whether perform function evaluation inside `try` clause
    #'
    #' @return (`self`) if successful.
    pull = function(args = NULL, try = FALSE) {
      logger::log_trace("TealDatasetConnector$pull pulling dataset: {self$get_dataname() }.")
      data <- private$pull_internal(args = args, try = try)
      if (!self$is_failed()) {
        # The first time object is pulled, private$dataset may be NULL if mutate method was never called
        has_dataset <- !is.null(private$dataset)
        if (has_dataset) {
          code_in_dataset <- private$dataset$get_code_class(nodeps = TRUE)
          vars_in_dataset <- private$dataset$get_vars()
        }

        pulled_metadata <- private$pull_metadata_internal()
        private$dataset <- dataset(
          dataname = self$get_dataname(),
          x = data,
          keys = character(0), # keys need to be set after mutate
          label = self$get_dataset_label(),
          code = private$get_pull_code_class(),
          metadata = pulled_metadata
        )

        if (has_dataset) {
          private$dataset$mutate(
            code = code_in_dataset,
            vars = vars_in_dataset
          )
        }
        set_keys(private$dataset, self$get_keys())
        private$is_pulled_flag <- TRUE
        logger::log_trace("TealDatasetConnector$pull pulled dataset: {self$get_dataname() }.")
      } else {
        logger::log_error("TealDatasetConnector$pull failed to pull dataset: {self$get_dataname() }.")
      }

      return(invisible(self))
    },
    #' @description
    #' Set arguments to the pulling function
    #'
    #' @param args (`NULL` or named `list`) dynamic arguments to function
    #'
    #' @return (`self`) invisibly for chaining
    set_args = function(args) {
      set_args(private$pull_callable, args)
      logger::log_trace("TealDatasetConnector$set_args pull args set for dataset: {self$get_dataname() }.")
      return(invisible(self))
    },

    # ___ mutate ====
    #' @description
    #' Dispatcher for either eager or delayed mutate methods
    #'
    #' Either code or script must be provided, but not both.
    #'
    #' @return (`self`) invisibly for chaining.
    mutate = function(code, vars = list()) {
      checkmate::assert_list(vars, min.len = 0, names = "unique")

      if (is.null(private$dataset)) {
        # just needs a dummy TealDataset object to store mutate code, hence col = 1
        private$dataset <- TealDataset$new(dataname = self$get_dataname(), x = data.frame(col = 1))
      }
      private$dataset$mutate(code = code, vars = vars, force_delay = !self$is_pulled())
      # should be called at the end so that failure in TealDataset object will prevent it.
      private$set_var_r6(vars)
      logger::log_trace(
        sprintf(
          "TealDatasetConnector$mutate mutated dataset '%s' using the code (%s lines) and vars (%s).",
          self$get_dataname(),
          length(parse(text = if (inherits(code, "CodeClass")) code$get_code() else code)),
          paste(names(vars), collapse = ", ")
        )
      )


      return(invisible(self))
    },

    # ___ status ====
    #' @description
    #' Check if pull has not failed.
    #'
    #' @return `TRUE` if pull failed, else `FALSE`
    is_failed = function() {
      return(private$pull_callable$is_failed())
    },
    #' @description
    #' Check if dataset has already been pulled.
    #'
    #' @return `TRUE` if connector has been already pulled, else `FALSE`
    is_pulled = function() {
      private$is_pulled_flag
    },
    #' @description
    #' Check if dataset has mutations that are delayed
    #'
    #' @return `logical`
    is_mutate_delayed = function() {
      if (is.null(private$dataset)) {
        FALSE
      } else {
        private$dataset$is_mutate_delayed()
      }
    },

    # ___ check ====
    #' @description
    #' Check to determine if the raw data is reproducible from the
    #' `get_code()` code.
    #' @return
    #' `TRUE` always for all connectors to avoid evaluating the same code multiple times.
    check = function() {
      return(TRUE)
    },
    # ___ shiny ====
    #' @description
    #' Sets the shiny UI according to the given inputs.
    #' Inputs must provide only scalar (length of 1) variables.
    #' @param inputs (`function`) A shiny module UI function with single argument `ns`.
    #' This function needs to return a list of shiny inputs with their `inputId` wrapped
    #' in function `ns`. The `inputId` must match exactly the argument name to be set.
    #' See example.
    #' Nested lists are not allowed.
    #' @return (`self`) invisibly for chaining.
    #' @examples
    #' ds <- dataset_connector("xyz", pull_callable = callable_function(data.frame))
    #' ds$set_ui_input(
    #'   function(ns) {
    #'     list(sliderInput(ns("colA"), "Select value for colA", min = 0, max = 10, value = 3),
    #'          sliderInput(ns("colB"), "Select value for colB", min = 0, max = 10, value = 7))
    #'   }
    #' )
    #' \dontrun{
    #' ds$launch()
    #' }
    set_ui_input = function(inputs = NULL) {
      stopifnot(is.null(inputs) || is.function(inputs))
      if (is.function(inputs)) {
        if (!identical(names(formals(inputs)), "ns")) {
          stop("'inputs' must be a function of a single argument called 'ns'")
        }
      }
      private$ui_input <- inputs
      logger::log_trace(
        "TealDatasetConnector$set_ui_input ui_input set for dataset: { deparse1(self$get_dataname()) }."
      )
      return(invisible(self))
    },
    #' @description
    #' Get shiny `ui` function
    #' @param id (`character`) namespace id
    #' @return shiny UI in given namespace id
    get_ui = function(id) {
      checkmate::assert_string(id)
      if (!is.null(private$ui)) {
        private$ui(id)
      }
    },
    #' @description
    #' Get shiny server function
    #' @return shiny server function
    get_server = function() {
      return(private$server)
    },
    #' @description
    #' Launches a shiny app.
    #' @return Shiny app
    #' @examples
    #' ds <- dataset_connector("xyz", pull_callable = callable_function(data.frame))
    #' ds$set_ui_input(
    #'   function(ns) {
    #'     list(sliderInput(ns("colA"), "Select value for colA", min = 0, max = 10, value = 3),
    #'          sliderInput(ns("colB"), "Select value for colB", min = 0, max = 10, value = 7))
    #'   }
    #' )
    #' \dontrun{
    #' ds$launch()
    #' }
    launch = function() {
      if (is.null(private$server)) {
        stop("No arguments set yet. Please use set_ui_input method first.")
      }
      shinyApp(
        ui = fluidPage(
          theme = get_teal_bs_theme(),
          self$get_ui(id = "main_app"),
          shinyjs::useShinyjs(),
          br(),
          actionButton("pull", "Get data"),
          br(),
          tableOutput("result")
        ),
        server = function(input, output, session) {
          session$onSessionEnded(stopApp)
          observeEvent(input$pull, {
            self$get_server()(id = "main_app")
            if (self$is_pulled()) {
              output$result <- renderTable(head(self$get_raw_data()))
            }
          })
        }
      )
    }
  ),
  ## __Private Fields ====
  private = list(
    dataset = NULL, # TealDataset
    pull_callable = NULL, # Callable
    pull_vars = list(), # named list
    dataname = character(0),
    dataset_label = character(0),
    metadata = NULL, # Callable or list
    keys = NULL,
    var_r6 = list(),
    ui_input = NULL, # NULL or list
    is_pulled_flag = FALSE,

    ## __Private Methods ====
    ui = function(id) {
      ns <- NS(id)
      # add namespace to input ids
      ui <- if (!is.null(private$ui_input)) {
        do.call(private$ui_input, list(ns = ns))
      } else {
        NULL
      }
      # check ui inputs
      if (!is.null(ui)) {
        checkmate::assert_list(ui, types = "shiny.tag")
        attr_class <- vapply(lapply(ui, "[[", i = "attribs"), "[[", character(1), i = "class")
        if (!all(grepl("shiny-input-container", attr_class))) {
          stop("All elements must be shiny inputs")
        }
      }
      # create ui
      if (!is.null(ui)) {
        tags$div(
          tags$div(
            id = ns("inputs"),
            h4("TealDataset Connector for ", code(self$get_dataname())),
            ui
          )
        )
      }
    },
    server = function(id, data_args = NULL) {
      moduleServer(
        id = id,
        function(input, output, session) {
          withProgress(value = 1, message = paste("Pulling", self$get_dataname()), {
            # set args to save them - args set will be returned in the call
            dataset_args <- if (!is.null(private$ui_input)) {
              reactiveValuesToList(input)
            } else {
              NULL
            }
            if (length(dataset_args) > 0) {
              self$set_args(args = dataset_args)
            }

            self$pull(args = data_args, try = TRUE)

            # print error if any
            # error doesn't break an app
            if (self$is_failed()) {
              shinyjs::alert(
                sprintf(
                  "Error pulling %s:\nError message: %s",
                  self$get_dataname(),
                  self$get_error_message()
                )
              )
            }
          })
        }
      )
      return(invisible(self))
    },

    # need to have a custom deep_clone because one of the key fields are reference-type object
    # in particular: dataset is a R6 object that wouldn't be cloned using default clone(deep = T)
    deep_clone = function(name, value) {
      deep_clone_r6(name, value)
    },
    get_pull_code_class = function(args = NULL) {
      res <- CodeClass$new()
      res$append(list_to_code_class(private$pull_vars))
      code <- if (inherits(private$pull_callable, "CallableCode")) {
        tmp <- private$pull_callable$get_call(deparse = FALSE)
        tmp[[length(tmp)]] <- substitute(a <- b, list(a = as.name(private$dataname), b = tmp[[length(tmp)]]))
        paste0(vapply(tmp, deparse1, character(1), collapse = "\n"), collapse = "\n")
      } else {
        deparse1(substitute(
          a <- b,
          list(
            a = as.name(private$dataname),
            b = private$pull_callable$get_call(deparse = FALSE, args = args)
          )
        ), collapse = "\n")
      }

      res$set_code(code = code, dataname = private$dataname, deps = names(private$pull_vars))
      return(res)
    },
    set_pull_callable = function(pull_callable) {
      stopifnot(inherits(pull_callable, "Callable"))
      private$pull_callable <- pull_callable
      return(invisible(self))
    },
    set_metadata = function(metadata) {
      if (inherits(metadata, "Callable")) {
        private$metadata <- metadata
      } else {
        validate_metadata(metadata)
        private$metadata <- metadata
      }
      return(invisible(self))
    },
    set_pull_vars = function(pull_vars) {
      checkmate::assert_list(pull_vars, min.len = 0, names = "unique")
      private$pull_vars <- pull_vars
      return(invisible(self))
    },
    pull_metadata_internal = function() {
      if (!checkmate::test_class(private$metadata, "Callable")) {
        return(private$metadata)
      }

      logger::log_trace("TealDatasetConnector$pull pulling metadata for dataset: {self$get_dataname() }.")
      pulled_metadata <- private$metadata$run(try = TRUE)

      if (checkmate::test_class(pulled_metadata, c("simpleError", "error"))) {
        logger::log_warn("TealDatasetConnector$pull pulling metadata failed for dataset: {self$get_dataname() }.")
        return(NULL)
      }

      # metadata pulled, now lets make sure it is valid
      tryCatch(
        {
          pulled_metadata <- as.list(pulled_metadata)
          validate_metadata(pulled_metadata)
          logger::log_trace("TealDatasetConnector$pull pulled metadata for dataset: {self$get_dataname() }.")
          return(pulled_metadata)
        },
        error = function(e) {
          logger::log_warn("TealDatasetConnector$pull invalid metadata for dataset: {self$get_dataname() }.")
          return(NULL)
        }
      )
    },
    pull_internal = function(args = NULL, try = FALSE) {
      # include objects CallableFunction environment
      if (length(private$pull_vars) > 0) {
        for (var_idx in seq_along(private$pull_vars)) {
          var_name <- names(private$pull_vars)[[var_idx]]
          var_value <- private$pull_vars[[var_idx]]

          # assignment is done in pull_callable only once
          # because x is locked within local environment
          # this means that re-assignment is not possible and will be silently skipped
          # During the app loading, assign is called only once.
          private$pull_callable$assign_to_env(
            x = var_name,
            value = if (inherits(var_value, "TealDatasetConnector") || inherits(var_value, "TealDataset")) {
              get_raw_data(var_value)
            } else {
              var_value
            }
          )
        }
      }
      # eval CallableFunction with dynamic args
      tryCatch(
        expr = private$pull_callable$run(args = args, try = try),
        error = function(e) {
          if (grepl("object 'conn' not found", e$message)) {
            output_message <- "This dataset connector requires connection object (conn) to be provided."
          } else {
            output_message <- paste("Could not pull dataset, the following error message was returned:", e$message)
          }
          stop(output_message, call. = FALSE)
        }
      )
    },
    set_failure = function(res) {
      if (inherits(res, "error")) {
        private$failed <- TRUE
        private$failure_msg <- conditionMessage(res)
      } else {
        private$failed <- FALSE
        private$failure_msg <- NULL
      }
      return(NULL)
    },
    set_var_r6 = function(vars) {
      checkmate::assert_list(vars, min.len = 0, names = "unique")
      for (varname in names(vars)) {
        var <- vars[[varname]]

        if (inherits(var, "TealDatasetConnector") || inherits(var, "TealDataset")) {
          var_deps <- var$get_var_r6()
          var_deps[[varname]] <- var
          for (var_dep_name in names(var_deps)) {
            var_dep <- var_deps[[var_dep_name]]
            if (identical(self, var_dep)) {
              stop("Circular dependencies detected")
            }
            private$var_r6[[var_dep_name]] <- var_dep
          }
        }
      }
      return(invisible(self))
    },
    set_dataname = function(dataname) {
      checkmate::assert_string(dataname)
      stopifnot(!grepl("\\s", dataname))
      private$dataname <- dataname
      return(invisible(self))
    },
    set_ui = function(ui_args = NULL) {
      private$ui <- function(id) {
        ns <- NS(id)
        # add namespace to input ids
        ui <- if (!is.null(ui_args)) {
          do.call(ui_args, list(ns = ns))
        } else {
          NULL
        }
        # check ui inputs
        if (!is.null(ui)) {
          checkmate::assert_list(ui, types = "shiny.tag")
          attr_class <- vapply(lapply(ui, "[[", i = "attribs"), "[[", character(1), i = "class")
          if (!all(grepl("shiny-input-container", attr_class))) {
            stop("All elements must be shiny inputs")
          }
        }
        # create ui
        if (!is.null(ui)) {
          tags$div(
            tags$div(
              id = ns("inputs"),
              h4("TealDataset Connector for ", code(self$get_dataname())),
              ui
            )
          )
        }
      }
      return(invisible(self))
    }
  )
)

#' Create a new `TealDatasetConnector` object
#'
#' `r lifecycle::badge("stable")`
#'
#' Create `TealDatasetConnector` from [callable_function].
#'
#' @param dataname (`character`)\cr
#'  A given name for the dataset it may not contain spaces
#'
#' @param pull_callable (`CallableFunction`)\cr
#'   function with necessary arguments set to fetch data from connection.
#'
#' @param keys optional, (`character`)\cr
#'  vector of dataset primary keys column names
#'
#' @param label (`character`)\cr
#'  Label to describe the dataset.
#'
#' @param code (`character`)\cr
#'  A character string defining code to modify `raw_data` from this dataset. To modify
#'  current dataset code should contain at least one assignment to object defined in `dataname`
#'  argument. For example if `dataname = ADSL` example code should contain
#'  `ADSL <- <some R code>`. Can't be used simultaneously with `script`
#'
#' @param script (`character`)\cr
#'   Alternatively to `code` - location of the file containing modification code.
#'   Can't be used simultaneously with `script`.
#'
#' @param vars (named `list`)) \cr
#'   In case when this object code depends on other `TealDataset` object(s) or
#'   other constant value, this/these object(s) should be included as named
#'   element(s) of the list. For example if this object code needs `ADSL`
#'   object we should specify `vars = list(ADSL = <adsl object>)`.
#'   It's recommended to include `TealDataset` or `TealDatasetConnector` objects to
#'   the `vars` list to preserve reproducibility. Please note that `vars`
#'   are included to this object as local `vars` and they cannot be modified
#'   within another dataset.
#'
#' @param metadata (named `list`, `NULL` or `CallableFunction`) \cr
#'   Field containing either the metadata about the dataset (each element of the list
#'   should be atomic and length one) or a `CallableFuntion` to pull the metadata
#'   from a connection. This should return a `list` or an object which can be
#'   converted to a list with `as.list`.
#' @return new `TealDatasetConnector` object
#'
#' @examples
#' library(MultiAssayExperiment)
#' # data.frame example
#' pull_fun2 <- callable_function(data.frame)
#' pull_fun2$set_args(args = list(a = c(1, 2, 3)))
#' dataset_connector("test", pull_fun2)
#'
#' # MultiAssayExperiment example
#' pull_fun <- callable_function(
#'   function() {
#'     library("MultiAssayExperiment")
#'     data("miniACC")
#'     return(miniACC)
#'   }
#' )
#' dataset_connector(
#'   "miniacc",
#'   pull_fun,
#'   code = 'library("MultiAssayExperiment"); data("miniACC"); return(miniACC)'
#' )
#' @export
dataset_connector <- function(dataname,
                              pull_callable,
                              keys = character(0),
                              label = character(0),
                              code = character(0),
                              script = character(0),
                              vars = list(),
                              metadata = NULL) {
  checkmate::assert_string(dataname)
  stopifnot(inherits(pull_callable, "Callable"))
  checkmate::assert_character(keys, any.missing = FALSE)
  checkmate::assert_character(code, any.missing = FALSE)
  checkmate::assert_character(label, any.missing = FALSE)

  if (!checkmate::test_class(metadata, "Callable", null.ok = TRUE)) {
    validate_metadata(metadata)
  }

  x <- TealDatasetConnector$new(
    dataname = dataname,
    pull_callable = pull_callable,
    keys = keys,
    code = code_from_script(code, script),
    label = label,
    vars = vars,
    metadata = metadata
  )

  return(x)
}

#' Create a new `CDISCTealDatasetConnector` object
#'
#' `r lifecycle::badge("stable")`
#'
#' Create `CDISCTealDatasetConnector` from [callable_function].
#'
#' @inheritParams dataset_connector
#' @inheritParams cdisc_dataset
#'
#' @return new `CDISCTealDatasetConnector` object
#'
#' @export
cdisc_dataset_connector <- function(dataname,
                                    pull_callable,
                                    keys,
                                    parent = `if`(identical(dataname, "ADSL"), character(0), "ADSL"),
                                    label = character(0),
                                    code = character(0),
                                    script = character(0),
                                    vars = list(),
                                    metadata = NULL) {
  checkmate::assert_string(dataname)
  stopifnot(inherits(pull_callable, "Callable"))
  checkmate::assert_character(keys, any.missing = FALSE)
  checkmate::assert_character(parent, max.len = 1, any.missing = FALSE)
  checkmate::assert_character(code, max.len = 1, any.missing = FALSE)
  checkmate::assert_character(label, max.len = 1, any.missing = FALSE)

  if (!checkmate::test_class(metadata, "Callable", null.ok = TRUE)) {
    validate_metadata(metadata)
  }

  x <- CDISCTealDatasetConnector$new(
    dataname = dataname,
    pull_callable = pull_callable,
    keys = keys,
    parent = parent,
    code = code_from_script(code, script),
    label = label,
    vars = vars,
    metadata = metadata
  )

  return(x)
}


#' Load `TealDatasetConnector` object from a file
#'
#' `r lifecycle::badge("stable")`
#'
#' Please note that the script has to end with a call creating desired object. The error will
#' be raised otherwise.
#'
#' @inheritParams dataset_file
#'
#' @return `TealDatasetConnector` object
#'
#' @rdname dataset_connector_file
#'
#' @export
#'
#' @examples
#' # simple example
#' library(magrittr)
#' file_example <- tempfile(fileext = ".R")
#' writeLines(
#'   text = c(
#'     "library(teal.data)
#'
#'      pull_callable <- callable_function(teal.data::example_cdisc_data) %>%
#'        set_args(list(dataname = \"ADSL\"))
#'      dataset_connector(\"ADSL\", pull_callable, get_cdisc_keys(\"ADSL\"))"
#'   ),
#'   con = file_example
#' )
#' x <- dataset_connector_file(file_example)
#' get_code(x)
dataset_connector_file <- function(path) { # nolint
  object <- object_file(path, "TealDatasetConnector")
  return(object)
}

#' Load `CDISCTealDatasetConnector` object from a file
#'
#' `r lifecycle::badge("stable")`
#'
#' Please note that the script has to end with a call creating desired object. The error will
#' be raised otherwise.
#'
#' @inheritParams dataset_connector_file
#'
#' @return `CDISCTealDatasetConnector` object
#'
#' @rdname dataset_connector_file
#'
#' @export
#'
#' @examples
#' # simple example
#' library(magrittr)
#' file_example <- tempfile(fileext = ".R")
#' writeLines(
#'   text = c(
#'     "library(teal.data)
#'
#'      pull_callable <- callable_function(teal.data::example_cdisc_data) %>%
#'        set_args(list(dataname = \"ADSL\"))
#'      cdisc_dataset_connector(\"ADSL\", pull_callable, get_cdisc_keys(\"ADSL\"))"
#'   ),
#'   con = file_example
#' )
#' x <- cdisc_dataset_connector_file(file_example)
#' get_code(x)
cdisc_dataset_connector_file <- function(path) { # nolint
  object <- object_file(path, "CDISCTealDatasetConnector")
  return(object)
}

# RDS ====
#' `RDS` `TealDatasetConnector`
#'
#' `r lifecycle::badge("stable")`
#'
#' Create a `TealDatasetConnector` from `RDS` file.
#'
#' @inheritParams dataset_connector
#' @inheritParams fun_dataset_connector
#' @param file (`character`)\cr
#'   path to (`.rds` or `.R`) that contains `data.frame` object or
#'   code to `source`
#'
#' @param ... (`optional`)\cr
#'   additional arguments applied to [base::readRDS()] function
#'
#' @export
#'
#' @rdname rds_dataset_connector
#'
#' @examples
#' \dontrun{
#' x <- rds_dataset_connector(
#'   dataname = "ADSL",
#'   file = "path/to/file.RDS"
#' )
#' x$get_code()
#' }
rds_dataset_connector <- function(dataname,
                                  file,
                                  keys = character(0),
                                  label = character(0),
                                  code = character(0),
                                  script = character(0),
                                  metadata = list(type = "rds", file = file),
                                  ...) {
  dot_args <- list(...)
  checkmate::assert_list(dot_args, min.len = 0, names = "unique")
  checkmate::assert_string(file)
  if (!file.exists(file)) {
    stop("File ", file, " does not exist.", call. = FALSE)
  }

  x_fun <- callable_function(readRDS) # nolint
  args <- c(list(file = file), dot_args)
  x_fun$set_args(args)

  x <- dataset_connector(
    dataname = dataname,
    pull_callable = x_fun,
    keys = keys,
    label = label,
    code = code_from_script(code, script),
    metadata = metadata
  )

  return(x)
}

#' `RDS` `CDSICTealDatasetConnector`
#'
#' `r lifecycle::badge("stable")`
#'
#' Create a `CDSICTealDatasetConnector` from `RDS` file with keys automatically
#' assigned by `dataname`
#'
#' @inheritParams rds_dataset_connector
#' @inheritParams cdisc_dataset_connector
#'
#' @rdname rds_dataset_connector
#'
#' @export
rds_cdisc_dataset_connector <- function(dataname,
                                        file,
                                        keys = get_cdisc_keys(dataname),
                                        parent = `if`(identical(dataname, "ADSL"), character(0L), "ADSL"),
                                        label = character(0),
                                        code = character(0),
                                        script = character(0),
                                        metadata = list(type = "rds", file = file),
                                        ...) {
  x <- rds_dataset_connector(
    dataname = dataname,
    file = file,
    keys = keys,
    code = code_from_script(code, script),
    label = label,
    metadata = metadata,
    ...
  )

  res <- as_cdisc(
    x,
    parent = parent
  )

  return(res)
}


# SCRIPT ====
#' Script `TealDatasetConnector`
#'
#' `r lifecycle::badge("stable")`
#'
#' Create a `TealDatasetConnector` from `.R` file.
#'
#' @inheritParams dataset_connector
#' @inheritParams fun_dataset_connector
#' @param file (`character`)\cr
#'   file location containing code to be evaluated in connector. Object obtained in the last
#'   call from file will be returned to the connector - same as `source(file = file)$value`
#'
#' @export
#'
#' @rdname script_dataset_connector
#'
#' @examples
#' \dontrun{
#' x <- script_dataset_connector(
#'   dataname = "ADSL",
#'   file = "path/to/script.R",
#'   keys = get_cdisc_keys("ADSL")
#' )
#' x$get_code()
#' }
script_dataset_connector <- function(dataname,
                                     file,
                                     keys = character(0),
                                     label = character(0),
                                     code = character(0),
                                     script = character(0),
                                     metadata = NULL,
                                     ...) {
  vars <- list(...)
  checkmate::assert_list(vars, min.len = 0, names = "unique")
  checkmate::assert_string(file)
  if (!file.exists(file)) {
    stop("File ", file, " does not exist.", call. = FALSE)
  }

  x_fun <- callable_function(source) # nolint
  x_fun$set_args(list(file = file, local = TRUE))

  x <- dataset_connector(
    dataname = dataname,
    pull_callable = x_fun,
    keys = keys,
    label = label,
    code = code_from_script(code, script),
    vars = vars,
    metadata = metadata
  )

  return(x)
}

#' Script `CDISCTealDatasetConnector`
#'
#' `r lifecycle::badge("stable")`
#'
#' Create a `CDISCTealDatasetConnector` from `script` file with keys assigned
#' automatically by `dataname`.
#'
#' @inheritParams script_dataset_connector
#' @inheritParams cdisc_dataset_connector
#'
#' @rdname script_dataset_connector
#'
#' @export
script_cdisc_dataset_connector <- function(dataname,
                                           file,
                                           keys = get_cdisc_keys(dataname),
                                           parent = `if`(identical(dataname, "ADSL"), character(0L), "ADSL"),
                                           label = character(0),
                                           code = character(0),
                                           script = character(0),
                                           metadata = NULL,
                                           ...) {
  x <- script_dataset_connector(
    dataname = dataname,
    file = file,
    keys = keys,
    code = code_from_script(code, script),
    script = script,
    label = label,
    metadata = metadata,
    ...
  )

  res <- as_cdisc(
    x,
    parent = parent
  )

  return(res)
}


# CODE ====
#' Code `TealDatasetConnector`
#'
#' `r lifecycle::badge("stable")`
#'
#' Create a `TealDatasetConnector` from a string of code.
#'
#' @inheritParams dataset_connector
#' @inheritParams fun_dataset_connector
#'
#' @param code (`character`)\cr
#'   String containing the code to produce the object.
#'   The code must end in a call to the object.
#' @param mutate_code (`character`)\cr
#'   String containing the code used to mutate the object
#'   after it is produced.
#' @param mutate_script (`character`)\cr
#'   Alternatively to `mutate_code` - location of the file containing modification code.
#'   Can't be used simultaneously with `mutate_script`.
#'
#' @export
#'
#' @rdname code_dataset_connector
#'
#' @examples
#' x <- code_dataset_connector(
#'   dataname = "ADSL",
#'   keys = get_cdisc_keys("ADSL"),
#'   code = "ADSL <- teal.data::example_cdisc_data(\"ADSL\"); ADSL"
#' )
#'
#' x$get_code()
#'
#' mutate_dataset(x, code = "ADSL$new_variable <- 1")
#' x$get_code()
#'
#' file_example <- tempfile(fileext = ".R")
#' writeLines(
#'   text = c(
#'     "seed <- 1; ADSL <- radsl(cached = TRUE, seed = seed)\nADSL"
#'   ),
#'   con = file_example
#' )
#'
#' y <- code_dataset_connector(
#'   dataname = "ADSL",
#'   keys = get_cdisc_keys("ADSL"),
#'   code = paste0(readLines(file_example), collapse = "\n")
#' )
code_dataset_connector <- function(dataname,
                                   code,
                                   keys = character(0),
                                   label = character(0),
                                   mutate_code = character(0),
                                   mutate_script = character(0),
                                   metadata = NULL,
                                   ...) {
  vars <- list(...)
  checkmate::assert_list(vars, min.len = 0, names = "unique")
  checkmate::assert_string(code)
  checkmate::assert_character(label, max.len = 1, any.missing = FALSE)

  call <- callable_code(code = code)

  x <- dataset_connector(
    dataname = dataname,
    pull_callable = call,
    keys = keys,
    label = label,
    code = code_from_script(mutate_code, mutate_script),
    vars = vars,
    metadata = metadata
  )

  return(x)
}

#' Code `CDISCTealDatasetConnector`
#'
#' `r lifecycle::badge("stable")`
#'
#' Create a `CDISCTealDatasetConnector` from a string of code with keys
#' assigned automatically by `dataname`.
#'
#' @inheritParams code_dataset_connector
#' @inheritParams cdisc_dataset_connector
#'
#' @rdname code_dataset_connector
#'
#' @export
code_cdisc_dataset_connector <- function(dataname,
                                         code,
                                         keys = get_cdisc_keys(dataname),
                                         parent = `if`(identical(dataname, "ADSL"), character(0L), "ADSL"),
                                         label = character(0),
                                         mutate_code = character(0),
                                         metadata = NULL,
                                         ...) {
  x <- code_dataset_connector(
    dataname = dataname,
    code = code,
    keys = keys,
    mutate_code = mutate_code,
    label = label,
    metadata = metadata,
    ...
  )

  res <- as_cdisc(
    x,
    parent = parent
  )

  return(res)
}

# CSV ====
#' `csv` `TealDatasetConnector`
#'
#' `r lifecycle::badge("stable")`
#'
#' Create a `TealDatasetConnector` from `csv` (or general delimited file).
#'
#'
#' @inheritParams dataset_connector
#' @inheritParams fun_dataset_connector
#'
#' @param file (`character`)\cr
#'   path to (`.csv)` (or general delimited) file that contains `data.frame` object
#'
#' @param ... (`optional`)\cr
#'   additional arguments applied to pull function (`readr::read_delim`) by default
#'   `delim = ","`.
#'
#' @export
#'
#' @rdname csv_dataset_connector
#'
#' @examples
#' \dontrun{
#' x <- csv_dataset_connector(
#'   dataname = "ADSL",
#'   file = "path/to/file.csv",
#'   delim = ",",
#'   col_types = quote(readr::cols(AGE = "i"))
#' )
#' x$get_code()
#' }
csv_dataset_connector <- function(dataname,
                                  file,
                                  keys = character(0),
                                  label = character(0),
                                  code = character(0),
                                  script = character(0),
                                  metadata = list(type = "csv", file = file),
                                  ...) {
  dot_args <- list(...)
  checkmate::assert_list(dot_args, min.len = 0, names = "unique")

  check_pkg_quietly(
    "readr",
    "library readr is required to use csv connectors please install it."
  )

  # add default delim as ","
  if (!"delim" %in% names(dot_args)) {
    dot_args$delim <- ","
  }

  checkmate::assert_string(file)
  if (!file.exists(file)) {
    stop("File ", file, " does not exist.", call. = FALSE)
  }

  x_fun <- callable_function("readr::read_delim") # using read_delim as preserves dates (read.csv does not)
  args <- c(list(file = file), dot_args)
  x_fun$set_args(args)

  x <- dataset_connector(
    dataname = dataname,
    pull_callable = x_fun,
    keys = keys,
    label = label,
    code = code_from_script(code, script),
    metadata = metadata
  )

  return(x)
}

#' `csv` `CDISCTealDatasetConnector`
#'
#' `r lifecycle::badge("stable")`
#'
#' Create a `CDISCTealDatasetConnector` from `csv` (or general delimited) file
#' with keys and parent name assigned automatically by `dataname`.
#'
#' @inheritParams csv_dataset_connector
#' @inheritParams cdisc_dataset_connector
#'
#' @rdname csv_dataset_connector
#'
#' @export
csv_cdisc_dataset_connector <- function(dataname,
                                        file,
                                        keys = get_cdisc_keys(dataname),
                                        parent = `if`(identical(dataname, "ADSL"), character(0L), "ADSL"),
                                        label = character(0),
                                        code = character(0),
                                        script = character(0),
                                        metadata = list(type = "csv", file = file),
                                        ...) {
  x <- csv_dataset_connector(
    dataname = dataname,
    file = file,
    keys = keys,
    code = code_from_script(code, script),
    label = label,
    metadata = metadata,
    ...
  )

  res <- as_cdisc(
    x,
    parent = parent
  )

  return(res)
}

# FUN ====
#' Function Dataset Connector
#'
#' `r lifecycle::badge("stable")`
#'
#' Create a `TealDatasetConnector` from `function` and its arguments.
#'
#' @inheritParams dataset_connector
#'
#' @param fun (`function`)\cr
#'   a custom function to obtain dataset.
#' @param fun_args (`list`)\cr
#'   additional arguments for (`func`).
#' @param func_name (`name`)\cr
#'   for internal purposes, please keep it default
#' @param ... Additional arguments applied to pull function.
#'   In case when this object code depends on the `raw_data` from the other
#'   `TealDataset`, `TealDatasetConnector` object(s) or other constant value,
#'   this/these object(s) should be included. Please note that `vars`
#'   are included to this object as local `vars` and they cannot be modified
#'   within another dataset.
#' @export
#'
#' @rdname fun_dataset_connector
#'
#' @examples
#' my_data <- function(...) {
#'   data.frame(
#'     ID = paste0("ABC_", seq_len(10)),
#'     var1 = rnorm(n = 10),
#'     var2 = rnorm(n = 10),
#'     var3 = rnorm(n = 10)
#'   )
#' }
#' y <- fun_dataset_connector(
#'   dataname = "XYZ",
#'   fun = my_data
#' )
#'
#' y$get_code()
#'
#' y$pull()
#'
#' get_raw_data(y)
fun_dataset_connector <- function(dataname,
                                  fun,
                                  fun_args = NULL,
                                  keys = character(0),
                                  label = character(0),
                                  code = character(0),
                                  script = character(0),
                                  func_name = substitute(fun),
                                  metadata = NULL,
                                  ...) {
  vars <- list(...)
  checkmate::assert_list(vars, min.len = 0, names = "unique")

  stopifnot(is.function(fun))

  stopifnot(is.list(fun_args) || is.null(fun_args))

  cal <- if (!is.symbol(func_name)) as.call(func_name) else NULL

  is_pak <- FALSE
  is_locked <- TRUE
  if ((!is.null(cal)) && identical(cal[[1]], as.symbol("::"))) {
    pak <- cal[[2]]
    pak_char <- as.character(pak) # nolint
    library(pak_char, character.only = TRUE)
    func_name <- cal[[3]]
    is_pak <- TRUE
    is_locked <- TRUE
  } else {
    is_locked <- environmentIsLocked(environment(fun))
  }

  func_char <- as.character(func_name)

  ee <- new.env(parent = parent.env(globalenv()))

  ee$library <- function(...) {
    mc <- match.call()
    mc[[1]] <- quote(base::library)
    eval(mc, envir = globalenv())
    this_env <- parent.frame()
    if (!identical(this_env, globalenv())) {
      parent.env(this_env) <- parent.env(globalenv())
    }
  }


  if (!is_pak && !is_locked) {
    eval(bquote(.(func_name) <- get(.(func_char), .(environment(fun)))), envir = ee)
    eval(bquote(.(func_name) <- rlang::set_env(.(func_name), .(ee))), envir = ee)
  }

  x_fun <- CallableFunction$new(fun, env = ee)
  x_fun$set_args(fun_args)

  vars[[func_char]] <- ee[[func_char]]

  x <- dataset_connector(
    dataname = dataname,
    pull_callable = x_fun,
    keys = keys,
    code = code_from_script(code, script),
    label = label,
    vars = vars,
    metadata = metadata
  )

  return(x)
}

#' Function `CDISCTealDatasetConnector`
#'
#' `r lifecycle::badge("stable")`
#'
#' Create a `CDISCTealDatasetConnector` from `function` and its arguments
#' with keys and parent name assigned automatically by `dataname`.
#'
#' @inheritParams fun_dataset_connector
#' @inheritParams cdisc_dataset_connector
#'
#' @rdname fun_dataset_connector
#'
#' @export
fun_cdisc_dataset_connector <- function(dataname,
                                        fun,
                                        fun_args = NULL,
                                        keys = get_cdisc_keys(dataname),
                                        parent = `if`(identical(dataname, "ADSL"), character(0L), "ADSL"),
                                        label = character(0),
                                        code = character(0),
                                        script = character(0),
                                        func_name = substitute(fun),
                                        metadata = NULL,
                                        ...) {
  x <- fun_dataset_connector(
    dataname = dataname,
    fun = fun,
    fun_args = fun_args,
    func_name = func_name,
    keys = keys,
    label = label,
    code = code,
    script = script,
    metadata = metadata,
    ...
  )

  res <- as_cdisc(
    x,
    parent = parent
  )

  return(res)
}


# PYTHON ====
#' `Python` `TealDatasetConnector`
#'
#' `r lifecycle::badge("experimental")`
#' Create a `TealDatasetConnector` from `.py` file or through python code supplied directly.
#'
#' @details
#'   Note that in addition to the `reticulate` package, support for python requires an
#'   existing python installation. By default, `reticulate` will attempt to use the
#'   location `Sys.which("python")`, however the path to the python installation can be
#'   supplied directly via `reticulate::use_python`.
#'
#'   The `teal` API for delayed data requires the python code or script to return a
#'   data.frame object. For this, the `pandas` package is required. This can be installed
#'   using `reticulate::py_install("pandas")`.
#'
#'   Please see the package documentation for more details.
#'
#' @inheritParams dataset_connector
#' @inheritParams code_dataset_connector
#' @param file (`character`)\cr
#'   Path to the file location containing the python script used to generate the object.
#' @param code (`character`)\cr
#'   string containing the python code to be run using `reticulate`. Carefully consider
#'   indentation to follow proper python syntax.
#' @param object (`character`)\cr
#'   name of the object from the python script that is assigned to the dataset to be used.
#'
#' @note
#'   Raises an error when passed `code` and `file` are passed at the same time.
#'
#'   When using `code`, keep in mind that when using `reticulate` with delayed data, python
#'   functions do not have access to other objects in the `code` and must be self contained.
#'   In the following example, the function `makedata()` doesn't have access to variable `x`:
#'
#' \preformatted{import pandas as pd
#'
#' x = 1
#' def makedata():
#'   return pd.DataFrame({'x': [x, 2], 'y': [3, 4]})
#'
#' data = makedata()}
#'
#'   When using custom functions, the function environment must be entirely self contained:
#'
#' \preformatted{def makedata():
#'   import pandas as pd
#'   x = 1
#'   return pd.DataFrame({'x': [x, 2], 'y': [3, 4]})
#'
#' data = makedata()
#'   }
#'
#'   **Additional `reticulate` considerations:**
#'   1. Note that when using pull `vars`, `R` objects  referenced in the python
#'   code or script have to be prefixed with `r.`.
#'   2. `reticulate` isn't able to convert `POSIXct` objects. Please take extra
#'   care when working with `datetime` variables.
#'
#'   Please read the official documentation for the `reticulate` package for additional
#'   features and current limitations.
#'
#' @export
#'
#' @rdname python_dataset_connector
#'
#' @examples
#' \dontrun{
#' library(reticulate)
#'
#' # supply python code directly in R
#'
#' x <- python_dataset_connector(
#'   "ADSL",
#'   code = "import pandas as pd
#' data = pd.DataFrame({'STUDYID':  [1, 2], 'USUBJID': [3, 4]})",
#'   object = "data"
#' )
#'
#' x$pull()
#' x$get_raw_data()
#'
#' # supply an external python script
#'
#' python_file <- tempfile(fileext = ".py")
#' writeLines(
#'   text = "import pandas as pd
#' data = pd.DataFrame({'STUDYID':  [1, 2], 'USUBJID': [3, 4]})",
#'   con = python_file
#' )
#'
#' x <- python_dataset_connector(
#'   "ADSL",
#'   file = python_file,
#'   object = "data",
#' )
#'
#' x$pull()
#' x$get_raw_data()
#'
#' # supply pull `vars` from R
#'
#' y <- 8
#' x <- python_dataset_connector(
#'   "ADSL",
#'   code = "import pandas as pd
#' data = pd.DataFrame({'STUDYID':  [r.y], 'USUBJID': [r.y]})",
#'   object = "data",
#'   vars = list(y = y)
#' )
#'
#' x$pull()
#' x$get_raw_data()
#' }
python_dataset_connector <- function(dataname,
                                     file,
                                     code,
                                     object = dataname,
                                     keys = character(0),
                                     label = character(0),
                                     mutate_code = character(0),
                                     mutate_script = character(0),
                                     vars = list(),
                                     metadata = NULL) {
  if (!requireNamespace("reticulate", quietly = TRUE)) {
    stop("Cannot load package 'reticulate' - please install the package.", call. = FALSE)
  }
  if (utils::packageVersion("reticulate") < 1.22) {
    stop("Please upgrade package 'reticulate', teal.data requires version >= 1.22")
  }

  checkmate::assert_string(object)
  if (!xor(missing(code), missing(file))) stop("Exactly one of 'code' and 'script' is required")

  if (!missing(file)) {
    checkmate::assert_string(file)
    checkmate::assert_file_exists(file, extension = "py")
    x_fun <- CallablePythonCode$new("py_run_file") # nolint
    x_fun$set_args(list(file = file, local = TRUE))
  } else {
    checkmate::assert_string(code)
    x_fun <- CallablePythonCode$new("py_run_string") # nolint
    x_fun$set_args(list(code = code, local = TRUE))
  }

  x_fun$set_object(object)

  x <- dataset_connector(
    dataname = dataname,
    pull_callable = x_fun,
    keys = keys,
    label = label,
    code = code_from_script(mutate_code, mutate_script),
    vars = vars,
    metadata = metadata
  )

  return(x)
}

#' `Python` `CDISCTealDatasetConnector`
#'
#' `r lifecycle::badge("experimental")`
#' Create a `CDISCTealDatasetConnector` from `.py` file or through python code supplied directly.
#'
#' @inheritParams python_dataset_connector
#' @inheritParams cdisc_dataset_connector
#'
#' @export
#'
#' @rdname python_dataset_connector
python_cdisc_dataset_connector <- function(dataname,
                                           file,
                                           code,
                                           object = dataname,
                                           keys = get_cdisc_keys(dataname),
                                           parent = `if`(identical(dataname, "ADSL"), character(0L), "ADSL"),
                                           mutate_code = character(0),
                                           mutate_script = character(0),
                                           label = character(0),
                                           vars = list(),
                                           metadata = NULL) {
  x <- python_dataset_connector(
    dataname = dataname,
    file = file,
    code = code,
    object = object,
    keys = keys,
    mutate_code = mutate_code,
    mutate_script = mutate_script,
    label = label,
    vars = vars,
    metadata = metadata
  )

  res <- as_cdisc(
    x,
    parent = parent
  )

  return(res)
}

#' Get dataset from `TealDatasetConnector`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Get dataset from `TealDatasetConnector`
#' @param x (`TealDatasetConnector` or `TealDatasetConnector` or `TealDataAbstract`)
#' @param dataname (`character`) a name of dataset to be retrieved
#' @details See `help(TealDataConnector)` and `help(TealData)` for more complex examples.
#' @return (`TealDataset`)
#' @export
get_dataset <- function(x, dataname) {
  UseMethod("get_dataset")
}

#' @rdname get_dataset
#' @export
#' @examples
#'
#' # TealDatasetConnector --------
#' library(magrittr)
#'
#' pull_fun_adae <- callable_function(teal.data::example_cdisc_data) %>%
#'   set_args(list(dataname = "ADAE"))
#'
#' ADSL <- teal.data::example_cdisc_data("ADSL")
#'
#' dc <- dataset_connector(
#'   dataname = "ADAE", pull_callable = pull_fun_adae,
#'   keys = get_cdisc_keys("ADSL")
#' )
#'
#' \dontrun{
#' load_dataset(dc)
#' get_dataset(dc)
#' }
#'
get_dataset.TealDatasetConnector <- function(x, dataname = NULL) { # nolint
  if (!is.null(dataname)) {
    warning("'dataname' argument ignored - TealDatasetConnector can contain only one dataset.")
  }
  return(x$get_dataset())
}

#' @rdname get_dataset
#' @export
#' @examples
#'
#' # TealDataset --------
#' ADSL <- example_cdisc_data("ADSL")
#' x <- dataset("ADSL", ADSL)
#'
#' get_dataset(x)
get_dataset.TealDataset <- function(x, dataname = NULL) { # nolint
  if (!is.null(dataname)) {
    warning("'dataname' argument ignored - TealDataset can contain only one dataset.")
  }
  return(x$get_dataset())
}

#' @rdname get_dataset
#' @export
#' @examples
#'
#' # TealData  (not containing connectors) --------
#' adsl <- cdisc_dataset(
#'   dataname = "ADSL",
#'   x = example_cdisc_data("ADSL"),
#'   code = "library(teal.data)\nADSL <- example_cdisc_data(\"ADSL\")"
#' )
#'
#' adae <- cdisc_dataset(
#'   dataname = "ADAE",
#'   x = example_cdisc_data("ADAE"),
#'   code = "library(teal.data)\nADAE <- example_cdisc_data(\"ADAE\")"
#' )
#'
#' rd <- teal.data:::TealData$new(adsl, adae)
#' get_dataset(rd, "ADSL")
get_dataset.TealDataAbstract <- function(x, dataname = NULL) {
  if (is.null(dataname)) {
    stop(paste(
      "To get single dataset from data class one must specify the name of the dataset.",
      "To get all datasets please use get_datasets()"
    ))
  }
  return(x$get_dataset(dataname = dataname))
}

#' S3 generic for creating an information summary about the duplicate key values in a dataset
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @details The information summary provides row numbers and number of duplicates
#' for each duplicated key value.
#'
#' @param dataset `TealDataset` or `data.frame` a dataset, which will be tested
#' @param keys `character` vector of variable names in `dataset` consisting the key
#' or `keys` object, which does have a `primary` element with a vector of variable
#' names in `dataset` consisting the key. Optional, default: NULL
#'
#' @return a `tibble` with variables consisting the key and `row_no` and `duplicates_count` columns
#'
#' @note Raises an exception when this function cannot determine the primary key columns of the tested object.
#'
#' @examples
#'
#' adsl <- teal.data::example_cdisc_data("ADSL")
#' # create a TealDataset with default keys
#' rel_adsl <- cdisc_dataset("ADSL", adsl)
#' get_key_duplicates(rel_adsl)
#'
#' df <- as.data.frame(
#'   list(a = c("a", "a", "b", "b", "c"), b = c(1, 2, 3, 3, 4), c = c(1, 2, 3, 4, 5))
#' )
#' res <- get_key_duplicates(df, keys = c("a", "b")) # duplicated keys are in rows 3 and 4
#' print(res) # prints a tibble
#' \dontrun{
#' get_key_duplicates(df) # raises an exception, because keys are missing with no default
#' }
#'
#' @export
get_key_duplicates <- function(dataset, keys = NULL) {
  UseMethod("get_key_duplicates", dataset)
}

#' @rdname get_key_duplicates
#' @export
get_key_duplicates.TealDataset <- function(dataset, keys = NULL) { # nolint
  df <- get_raw_data(dataset)
  if (is.null(keys)) {
    keys_ds <- get_keys(dataset)
    keys <- if (is.null(keys_ds)) character(0) else keys_ds
  }

  get_key_duplicates_util(df, keys)
}

#' @rdname get_key_duplicates
#' @export
get_key_duplicates.data.frame <- function(dataset, keys = NULL) { # nolint
  if (is.null(keys)) {
    attr_key <- attr(dataset, "primary_key")
    keys <- if (is.null(attr_key)) character(0) else attr
  }
  get_key_duplicates_util(dataset, keys)
}

#' Creates a duplicate keys information summary.
#'
#' @details
#' Accepts a list of variable names - `keys`, which are treated as the
#' key to the `data.frame` argument. An instance of duplicated key is
#' defined as two rows, which have the same values in columns defined by `keys`.
#' Per each key value with duplicates returns a row in a `tibble`. The return table
#' has columns corresponding to the variable names passed in `keys` and
#' two additional columns: `rows` and `n`, which provide
#' information about row numbers of the original dataframe, which contain duplicated keys
#' and total duplicates counts.
#'
#' @param dataframe dataframe
#' @param keys `character` vector of variable names consisting the key to the `data.frame`
#'
#' @return `data.frame` with a duplicate keys information summary
#'
#' @keywords internal
#'
#' @examples
#' df <- data.frame(
#'   a = c("a", "a", "b", "b", "c"),
#'   b = c(1, 2, 3, 3, 4),
#'   c = c(1, 2, 3, 4, 5)
#' )
#' res <- teal.data:::get_key_duplicates_util(df, keys = c("a", "b"))
#' print(res) # duplicated keys are in rows 3 and 4
#' @seealso [get_key_duplicates]
get_key_duplicates_util <- function(dataframe, keys) {
  checkmate::assert_data_frame(dataframe)
  checkmate::assert_character(keys)
  stopifnot(
    all(
      vapply(keys, FUN.VALUE = logical(1), FUN = function(key) key %in% colnames(dataframe))
    )
  )

  # The goal is to print values of duplicated primary keys with number of duplicates and row numbers
  duplicates <- dataframe[, keys, drop = FALSE]
  duplicates$dups <- duplicated(duplicates, fromLast = FALSE) | duplicated(duplicates, fromLast = TRUE)
  duplicates$row_number <- seq_len(nrow(duplicates))
  duplicates <- duplicates[duplicates$dups, ]
  duplicates$dups <- NULL

  if (nrow(duplicates) == 0) {
    duplicates$rows <- character(0)
    duplicates$row_number <- NULL
    duplicates$n <- integer(0)
    return(duplicates)
  }

  groups <- split(duplicates, duplicates[, keys, drop = FALSE], drop = TRUE)
  summary_list <- lapply(groups, function(group) {
    ans <- group[1, keys, drop = FALSE]
    ans$rows <- paste(group[, "row_number"], collapse = ",")
    ans$n <- nrow(group)
    ans
  })
  summary <- do.call(rbind, summary_list)
  rownames(summary) <- NULL
  summary
}

#' Get code
#'
#' @description `r lifecycle::badge("stable")`
#' Reads code from specified files or an R6 object.
#'
#' \itemize{
#'   \item{if reading from R6: }{get the R code stored inside the object.}
#'   \item{if reading from files: }{
#'     Includes code from source if reading from files. Method reads code without
#'   }
#' }
#' `library()` or `require()` calls. Function created for teal app, but can be used with any file.
#' Get code from certain files and for specific datasets
#'
#' Reads code from specified files and specific code chunks.
#'
#' Code chunks are described with:
#'
#' \itemize{
#'   \item{to open chunk }{`#code>` or `#code ADSL>` or `#code ADSL ADTTE>`}
#'   \item{to close chunk }{`#<code` or `#<ADSL code` or `#<ADSL ADTTE code`}
#' }
#'
#' @param x ([`TealDatasetConnector`] or [`TealDataset`]). If of class `character` will be treated as file to read.
#' @param exclude_comments (`logical`) whether exclude commented-out lines of code. Lines to be excluded
#' should be ended with `# nocode`. For multiple line exclusions one should enclose ignored block of code with
#' `# nocode>` and `# <nocode`
#' @param read_sources (`logical`) whether to replace `source("path")` with code lines from sourced file.
#' If `read_sources = TRUE` changing working directory inside preprocessing is not allowed.
#' @param deparse (`logical`) whether return deparsed form of a call
#' @param files_path (`character`) (optional) vector of files path to be read for preprocessing. Code from
#' multiple files is joined together.
#' @param dataname (`character`) Name of dataset to return code for.
#' @param ... not used, only for support of S3
#' @export
#' @return (`character`) code of import and preparation of data for teal application.
get_code <- function(x, ...) {
  UseMethod("get_code")
}


# Getting code from R6 ====

#' @export
#' @rdname get_code
get_code.TealDatasetConnector <- function(x, deparse = TRUE, ...) {
  check_ellipsis(...)
  x$get_code(deparse = deparse)
}

#' @export
#' @rdname get_code
get_code.TealDataset <- function(x, deparse = TRUE, ...) {
  check_ellipsis(...)
  x$get_code(deparse = deparse)
}


#' @rdname get_code
#' @export
#' @examples
#' x1 <- dataset(
#'   x = data.frame(x = c(1, 2), y = c("a", "b"), stringsAsFactors = FALSE),
#'   keys = "y",
#'   dataname = "XY",
#'   code = "XY <- data.frame(x = c(1, 2), y = c('aa', 'bb'), stringsAsFactors = FALSE)",
#'   label = character(0)
#' )
#'
#' x2 <- dataset(
#'   x = data.frame(x = c(1, 2), y = c("a", "b"), stringsAsFactors = FALSE),
#'   keys = "y",
#'   dataname = "XYZ",
#'   code = "XYZ <- data.frame(x = c(1, 2), y = c('aa', 'bb'), stringsAsFactors = FALSE)",
#'   label = character(0)
#' )
#'
#' rd <- teal_data(x1, x2)
#'
#' get_code(rd)
#' get_code(rd, "XY")
#' get_code(rd, "XYZ")
get_code.TealDataAbstract <- function(x, dataname = character(0), deparse = TRUE, ...) { # nolint
  check_ellipsis(...)
  if (length(dataname) > 0) {
    if (any(!(dataname %in% x$get_datanames()))) {
      stop("The dataname provided does not exist")
    }
    x$get_code(dataname = dataname, deparse = deparse)
  } else {
    x$get_code(deparse = deparse)
  }
}

# Getting code from files ====

#' @rdname get_code
#' @export
get_code.default <- function(x,
                             exclude_comments = TRUE,
                             read_sources = TRUE,
                             deparse = FALSE,
                             files_path = NULL,
                             dataname = NULL,
                             ...) {
  if (!is.null(files_path)) {
    x <- files_path
  }

  check_ellipsis(...)
  checkmate::assert_character(x, min.len = 1, any.missing = FALSE)
  checkmate::assert_flag(exclude_comments)
  checkmate::assert_flag(read_sources)

  if (!methods::hasArg(dataname)) {
    l_lines <- lapply(x, function(file_path) {
      code_exclude(
        enclosed_with(
          get_code_single(file_path, read_sources = read_sources)
        ),
        lines,
        exclude_comments = exclude_comments
      )
    })
  } else {
    l_lines <- lapply(x, function(file_path) {
      code_exclude(
        enclosed_with_dataname(
          get_code_single(file_path, read_sources = read_sources),
          dataname = dataname
        ),
        lines,
        exclude_comments = exclude_comments
      )
    })
  }

  lines <- unlist(l_lines)
  if (deparse) {
    return(paste(
      vapply(lines, FUN = deparse1, collapse = "\n", FUN.VALUE = character(1)),
      collapse = "\n"
    ))
  } else {
    return(paste(lines, collapse = "\n"))
  }
}



# * Sub functions for getting code from files ====

#' Get code
#'
#' Get code from specified file.
#' @param file_path (`character`) path or URL address of the file to be parsed
#' @param if_url (`logical`) (optional) TRUE when URL address is provided
#' @inheritParams get_code
#'
#' @return lines (`character`) of preprocessing code
#' @keywords internal
get_code_single <- function(file_path, read_sources, if_url = grepl("^http[s]", file_path)) {
  checkmate::assert_string(file_path)
  if (!if_url) {
    if (!file.exists(file_path)) {
      stop(
        "Reading preprocessing code from ", file_path, " file failed. ",
        "Please double check if you saved your script."
      )
    }
  }
  checkmate::assert_flag(read_sources)
  checkmate::assert_flag(if_url)

  lines <- readLines(file_path)
  if (read_sources) {
    lines <- include_source_code(lines = lines, dir = `if`(if_url, NULL, dirname(file_path)))
  }

  lines
}

#' Get code enclosed within
#'
#' Extracts lines from code which are enclosed within regexp starts_at and stops_at
#' @param lines (`character`) of preprocessing code.
#' @return (`character`) subset of lines which start and end with preprocessing
#'   start and stop tags.
#' @keywords internal
enclosed_with <- function(lines) {
  checkmate::assert_character(lines, min.len = 1, any.missing = FALSE)

  # set beginning of preprocessing
  idx_start <- grep("#\\s*code>", lines)
  line_starts <- if (length(idx_start) > 1) {
    warning("More than one preproc start found - using the first one.")
    idx_start[1] + 1
  } else if (length(idx_start) == 1) {
    idx_start + 1
  } else {
    1L
  }

  # set stop of preprocessing
  idx_stop <- grep("#\\s*<code", lines)
  line_stops <- if (length(idx_stop) > 1) {
    warning("More than one preproc stops found - using the last one.")
    utils::tail(idx_stop, 1) - 1
  } else if (length(idx_stop) == 1) {
    idx_stop - 1
  } else {
    length(lines)
  }

  line_numbers <- seq(line_starts, line_stops)

  lines[line_numbers]
}

#' Get code enclosed within
#'
#' Extracts lines from code which are enclosed within regexp starts_at and stops_at
#' @inheritParams enclosed_with
#' @param dataname (`character`) metadata for returned lines
#' @return  (`list`) list of lines and their numbers from certain chunks of code at the specific file.
#' @keywords internal
enclosed_with_dataname <- function(lines, dataname = NULL) {
  checkmate::assert_character(lines, min.len = 1, any.missing = FALSE)
  if (!checkmate::test_character(dataname, min.len = 1, any.missing = FALSE)) {
    dataname <- ""
  }
  dataname <- trimws(dataname)
  any_chunk <- any(grepl("#\\s*<?\\s*code", lines))

  if (any_chunk) {
    any_start <- any(grepl(sprintf("#\\s*code[\\sa-zA-Z_]*%s[\\sa-zA-Z_]*>", dataname), lines, perl = TRUE))
    any_stop <- any(grepl(sprintf("#\\s*<[\\sa-zA-Z_]*%s[\\sa-zA-Z_]*(?<![a-zA-Z])code", dataname), lines, perl = TRUE))

    if (!(any_start && any_stop)) {
      stop(sprintf("File doesn't contain code marked for this %1$s.\n
                   Please use # code %1$s> to indicate which lines should be extracted.", dataname))
    }
  }

  # set beginning of preprocessing
  idx_start <- grep(sprintf("#\\s*code(?:[\\sa-zA-Z_]*%s[\\sa-zA-Z_]*|[\\s]*)>", dataname), lines, perl = TRUE)
  line_starts <- if (length(idx_start) >= 1) {
    idx_start + 1
  } else {
    1L
  }

  # set stop of preprocessing
  idx_stop <- grep(
    sprintf("#\\s*<(?:[\\sa-zA-Z_]*%s[\\sa-zA-Z_]*|[\\s]*)(?<![a-zA-Z])code", dataname),
    lines,
    perl = TRUE
  )
  line_stops <- if (length(idx_stop) >= 1) {
    idx_stop - 1
  } else {
    length(lines)
  }

  if (length(line_starts) != length(line_stops) || any(line_starts > line_stops)) {
    stop("Number of #code> has to be the same as #<code")
  }


  ll <- data.frame(line_starts, line_stops)

  line_numbers <- apply(ll, 1, function(x) seq(x[1], x[2]))

  lines_taken <- as.integer(unlist(line_numbers))

  res_lines <- lines[lines_taken]

  return(res_lines)
}

#' Exclude from code
#'
#' Excludes lines from code. It is possible to exclude one line ended by `# nocode`
#' @inheritParams enclosed_with
#' @inheritParams get_code
#' @inheritParams get_code_single
#' @keywords internal
code_exclude <- function(lines, exclude_comments, file_path) {
  checkmate::assert_character(lines, min.len = 1, any.missing = FALSE)
  checkmate::assert_flag(exclude_comments)

  nocode_single <- grep("^.+#[[:space:]]*nocode", lines)
  nocode_start <- grep("[[:space:]]*#[[:space:]]*nocode[[:space:]]*>+", lines)
  nocode_stop <- grep("[[:space:]]*#[[:space:]]*<+[[:space:]]*nocode[[:space:]]*", lines)

  if (length(nocode_start) != length(nocode_stop)) {
    stop(paste("Unequal number of no-code starts and stops in ", file_path)) # nolint
  }

  nocode_multi <- NULL
  if (length(nocode_start) > 0) {
    nocode_multi <- unlist(Map(seq, from = nocode_start, to = nocode_stop))
  }

  nocode <- c(nocode_single, nocode_multi)

  if (length(nocode) > 0) {
    lines <- lines[-nocode]
  }

  if (exclude_comments) {
    lines <- grep("^\\s*#.+$", x = lines, invert = TRUE, value = TRUE)
    lines <- gsub("(^\\s*#.+$)|(#[^\'\"]*$)", "", x = lines, perl = TRUE)
  }

  lines
}

#' Finds lines of code with source call
#'
#' Finds lines in preprocessing code where `source()` call is located
#' @inheritParams enclosed_with
#' @keywords internal
find_source_code <- function(lines) {
  checkmate::assert_character(lines, min.len = 1, any.missing = FALSE)
  idx <- grep("^[^#]*source\\([\'\"]([A-Za-z0-9_/.]).*\\.R[\'\"].*\\).*$", lines)

  if (length(idx) == 0) {
    return(idx)
  }

  if (any(grepl("source\\([^)]*chdir\\s*=\\s*T(RUE)*", x = lines[idx]))) {
    stop("Preprocessing doesn't handle source(chdir = TRUE)")
  }

  if (any(grepl("source\\(.+;\\s*source\\(", x = lines[idx]))) {
    stop("Preprocessing doesn't handle multiple sources in one line\n")
  }

  idx
}

#' Includes source in preprocessing code lines
#'
#' @inheritParams enclosed_with
#' @param dir of the file where source is called from.
#' @return lines of code with source text included
#' @keywords internal
include_source_code <- function(lines, dir = NULL) {
  checkmate::assert_character(lines, min.len = 1, any.missing = FALSE)
  stopifnot(is.null(dir) || dir.exists(dir))


  idx <- find_source_code(lines)

  if (length(idx) == 0) {
    return(lines)
  }

  sources_path <- unname(vapply(
    lines[idx],
    function(x) {
      res <- gsub("source\\(.*[\"\']([A-Za-z0-9_/.])", "\\1", strsplit(x, ",")[[1]][1])
      res <- gsub("[\'\"]", "", res)
      res <- gsub(")", "", res)
      res
    },
    character(1)
  ))

  if (length(sources_path) != length(idx)) {
    stop("Couldn't detect R file name from source() call.")
  }

  sources_code <- lapply(sources_path, function(s) {
    if (grepl("^http[s]", s)) {
      # url detected - do nothing
    } else {
      s <- ifelse(grepl("^(/)|^([\\])|^([A-Za-z]:)", s), s, file.path(dir, s))
      if (!all(file.exists(s))) {
        msg <- paste0(
          "File(s) provided in the source() calls don't exist: \n",
          paste(s[!file.exists(s)], collapse = "\n")
        )
        stop(msg)
      }

      s <- normalizePath(s)
    }

    get_code_single(file_path = s, read_sources = TRUE)
  })

  lines[idx] <- sources_code
  lines <- unlist(lines)

  lines
}

#' Get code from script
#'
#' Get code from script. Switches between `code` and `script` arguments
#' to return non-empty one to pass it further to constructors.
#'
#' @param code (`character`)\cr
#'   an R code to be evaluated or a `PythonCodeClass` created using [python_code].
#' @inheritParams dataset_connector
#' @return code (`character`)
#' @keywords internal
code_from_script <- function(code, script, dataname = NULL) {
  checkmate::assert(
    checkmate::check_character(code, max.len = 1, any.missing = FALSE),
    checkmate::check_class(code, "PythonCodeClass")
  )
  checkmate::assert_character(script, max.len = 1, any.missing = FALSE)
  if (length(code) == 0 && length(script) == 0) {
    return(character(0))
  }

  if (checkmate::test_string(code) && checkmate::test_string(script)) {
    stop("Function doesn't accept 'code' and 'script' at the same time.
         Please specify either 'code' or 'script'", call. = FALSE)
  }

  if (checkmate::test_string(script)) {
    code <- read_script(file = script, dataname = dataname)
  }

  code
}

#' Read .R file into character
#'
#' @description `r lifecycle::badge("stable")`
#' Comments will be excluded
#'
#' @param file (`character`) File to be parsed into code
#' @param dataname (`character`) dataset name to subset code from chunks
#' @return (`character`) vector with the code
#'
#' @export
#' @examples
#' file_example <- tempfile()
#' writeLines(c("x <- 2", "#second line comment", "x <- x + 2"), file_example)
#'
#' read_script(file_example)
read_script <- function(file, dataname = NULL) {
  checkmate::assert_string(file)
  checkmate::assert_file_exists(file)
  paste(
    code_exclude(
      enclosed_with_dataname(
        get_code_single(file, read_sources = TRUE),
        dataname = dataname
      ),
      exclude_comments = TRUE
    ),
    collapse = "\n"
  )
}

#' Function to get a file out of a package
#'
#' @param pkg (`character`)\cr
#'  The name of the package the file should be received from.
#' @param file_name (`character`)\cr
#'  The name of the file to be received or path to it starting from
#'  the base package path.
#' @return The path to the file
#' @keywords internal
#' @examples
#' teal.data:::get_package_file("teal.data", "WORDLIST")
#' teal.data:::get_package_file("teal.data", "cdisc_datasets/cdisc_datasets.yaml")
get_package_file <- function(pkg = NULL, file_name = NULL) {
  checkmate::assert_string(pkg)
  checkmate::assert_string(file_name)
  base_file <- system.file(file_name, package = pkg)

  if (file.exists(base_file)) {
    return(base_file)
  } else {
    stop(paste("There is no such file:", file_name, "or package:", pkg))
  }
}

# Function to be used while trying to load the object of specific class from the script.
object_file <- function(path, class) {
  checkmate::assert_string(path)
  checkmate::assert_file_exists(path)
  checkmate::assert_string(class)

  lines <- paste0(readLines(path), collapse = "\n")
  object <- eval(parse(text = lines, keep.source = FALSE))

  if (!inherits(object, class)) {
    stop("The object returned from the file is not of ", class, " class.")
  }
  return(object)
}

#' Check if package can be loaded
#'
#' @param pckg `character` package name.
#' @param msg `character` error message to display if package is not available.
#'
#' @return Error or invisible NULL.
#' @keywords internal
check_pkg_quietly <- function(pckg, msg) {
  checkmate::assert_string(pckg)
  checkmate::assert_string(msg)
  if (!pckg %in% rownames(utils::installed.packages())) {
    stop(msg)
  }

  invisible(NULL)
}


#' validate metadata as a list of length one atomic entries (or NULL)
#' @param metadata `object` to be checked
#' @return `NULL` or throw error
#' @examples
#'
#' validate_metadata(NULL)
#' validate_metadata(list(A = TRUE, B = 10, C = "test"))
#' \dontrun{
#' validate_metadata(list(a = 1:10))
#' }
#'
#' @export
validate_metadata <- function(metadata) {
  checkmate::assert_list(metadata, any.missing = FALSE, names = "named", null.ok = TRUE)
  lapply(names(metadata), function(name) {
    checkmate::assert_atomic(metadata[[name]], len = 1, .var.name = name)
  })
  return(NULL)
}

#' Resolve the expected bootstrap theme
#' @keywords internal
get_teal_bs_theme <- function() {
  bs_theme <- getOption("teal.bs_theme")
  if (is.null(bs_theme)) {
    NULL
  } else if (!inherits(bs_theme, "bs_theme")) {
    warning("teal.bs_theme has to be of a bslib::bs_theme class, the default shiny bootstrap is used.")
    NULL
  } else {
    bs_theme
  }
}

## TealDataAbstract ====
#' @title `TealDataAbstract` class
#'
#' @description
#' Abstract class containing code for handling set of datasets.
#' @keywords internal
TealDataAbstract <- R6::R6Class( # nolint
  classname = "TealDataAbstract",
  ## __Public Methods ====
  public = list(
    #' @description
    #' Cannot create a `TealDataAbstract` object
    #'
    #' @return throws error
    initialize = function() {
      stop("Pure virtual method")
    },
    #' @description
    #' Check if the object raw data is reproducible from the `get_code()` code.
    #' @return
    #'   `NULL` if check step has been disabled
    #'   `TRUE` if all the datasets generated from evaluating the
    #'   `get_code()` code are identical to the raw data, else `FALSE`.
    check = function() {
      # code can be put only to the mutate with empty code in datasets
      res <- if (isFALSE(private$.check)) {
        NULL
      } else {
        if (length(private$pull_code$code) > 0) {
          private$check_combined_code()
        } else {
          all(vapply(
            private$datasets,
            function(x) {
              check_res <- x$check()
              # NULL is still ok
              is.null(check_res) || isTRUE(check_res)
            },
            logical(1)
          ))
        }
      }
      private$check_result <- res
      logger::log_trace("TealDataAbstract$check executed the code to reproduce the data - result: { res }.")
      res
    },
    #' @description
    #' Execute `check()` and raise an error if it's not reproducible.
    #' @return error if code is not reproducible else invisibly nothing
    check_reproducibility = function() {
      self$check()
      if (isFALSE(self$get_check_result())) {
        stop("Reproducibility check failed.")
      }
      logger::log_trace("TealDataAbstract$check_reproducibility reproducibility check passed.")
      return(invisible(NULL))
    },
    #' @description
    #' Execute mutate code. Using `mutate_data(set).TealDataAbstract`
    #' does not cause instant execution, the `mutate_code` is
    #' delayed and can be evaluated using this method.
    execute_mutate = function() {
      logger::log_trace("TealDataAbstract$execute_mutate evaluating mutate code...")
      # this will be pulled already! - not needed?
      if (length(private$mutate_code$code) == 0) {
        res <- unlist(lapply(
          private$datasets,
          function(x) {
            if (is_pulled(x)) {
              get_datasets(x)
            } else {
              NULL
            }
          }
        ))
        # exit early if mutate isn't required
        logger::log_trace("TealDataAbstract$execute_mutate no code to evaluate.")
        if (!is.null(res)) {
          res <- stats::setNames(res, vapply(res, get_dataname, character(1)))
        }
        return(res)
      }

      if (inherits(private$mutate_code, "PythonCodeClass")) {
        items <- lapply(self$get_items(), get_raw_data)
        datasets <- stats::setNames(items, vapply(self$get_items(), get_dataname, character(1)))

        new_env <- private$mutate_code$eval(vars = c(datasets, private$mutate_vars))
      } else {
        # have to evaluate post-processing code (i.e. private$mutate_code) before returning dataset
        new_env <- new.env(parent = parent.env(globalenv()))
        for (dataset in self$get_items()) {
          assign(get_dataname(dataset), get_raw_data(dataset), envir = new_env)
        }

        for (var_idx in seq_along(private$mutate_vars)) {
          mutate_var <- private$mutate_vars[[var_idx]]
          assign(
            x = names(private$mutate_vars)[[var_idx]],
            value = `if`(
              inherits(mutate_var, "TealDataset") || inherits(mutate_var, "TealDatasetConnector"),
              get_raw_data(mutate_var),
              mutate_var
            ),
            envir = new_env
          )
        }

        private$mutate_code$eval(envir = new_env)
      }

      lapply(
        self$get_datasets(),
        function(x) {
          x$recreate(
            x = get(get_dataname(x), new_env)
          )
        }
      )
      logger::log_trace("TealDataAbstract$execute_mutate evaluated mutate code.")
      return(invisible(NULL))
    },
    #' @description
    #' Get result of reproducibility check
    #' @return `NULL` if check has not been called yet, `TRUE` / `FALSE` otherwise
    get_check_result = function() {
      private$check_result
    },
    #' @description
    #' Get code for all datasets.
    #' @param dataname (`character`) `dataname` or `NULL` for all datasets
    #' @param deparse (`logical`) whether to return the deparsed form of a call
    #' @return (`character`) vector of code to generate datasets.
    get_code = function(dataname = NULL, deparse = TRUE) {
      checkmate::assert_character(dataname, min.len = 1, null.ok = TRUE, any.missing = FALSE)
      checkmate::assert_flag(deparse)

      return(self$get_code_class()$get_code(dataname = dataname, deparse = deparse))
    },
    #' @description
    #' Get internal `CodeClass` object
    #' @param only_pull (`logical` value)\cr
    #'   if `TRUE` only code to pull datasets will be returned without the mutate code.
    #'
    #' @return `CodeClass`
    get_code_class = function(only_pull = FALSE) {
      all_code_class <- CodeClass$new()

      pull_code_class <- private$get_pull_code_class()
      all_code_class$append(pull_code_class)

      datasets_code_class <- private$get_datasets_code_class()
      all_code_class$append(datasets_code_class)

      if (isFALSE(only_pull)) {
        mutate_code_class <- private$get_mutate_code_class()
        all_code_class$append(mutate_code_class)
      }

      return(all_code_class)
    },
    #' @description
    #' Get names of the datasets.
    #'
    #' @return `character` vector with names of all datasets.
    get_datanames = function() {
      datasets_names <- unname(unlist(lapply(private$datasets, get_dataname)))

      return(datasets_names)
    },
    #' @description
    #' Get `TealDataset` object.
    #'
    #' @param dataname (`character` value)\cr
    #'   name of dataset to be returned. If `NULL`, all datasets are returned.
    #'
    #' @return `TealDataset`.
    get_dataset = function(dataname = NULL) {
      checkmate::assert_string(dataname, null.ok = TRUE)

      if (length(dataname) == 1) {
        if (!(dataname %in% self$get_datanames())) {
          stop(paste("dataset", dataname, "not found"))
        }

        res <- self$get_datasets()[[dataname]]
        return(res)
      } else {
        return(self$get_datasets())
      }
    },
    #' @description
    #' Get `list` of `TealDataset` objects.
    #'
    #' @return `list` of `TealDataset`.
    get_datasets = function() {
      if (!self$is_pulled()) {
        stop(
          "Not all datasets have been pulled yet.\n",
          "- Please use `load_datasets()` to retrieve complete results."
        )
      }
      unlist(lapply(self$get_items(), get_dataset))
    },
    #' @description
    #' Get all datasets and all dataset connectors
    #'
    #' @param dataname (`character` value)\cr
    #'   name of dataset connector to be returned. If `NULL`, all connectors are returned.
    #' @return `list` with all datasets and all connectors
    get_items = function(dataname = NULL) {
      checkmate::assert_string(dataname, null.ok = TRUE)

      if (length(dataname) == 1) {
        if (!(dataname %in% self$get_datanames())) {
          stop(paste("dataset", dataname, "not found"))
        }
        return(private$datasets[[dataname]])
      } else {
        return(private$datasets)
      }
    },
    #' @description
    #' Has this data been or will this data be subjected to a reproducibility check
    #' @return `logical`
    get_check = function() {
      private$.check
    },
    #' @field id String used to create unique GUI elements
    id = NULL,
    #' @description
    #' Check if dataset has already been pulled.
    #'
    #' @return `TRUE` if dataset has been already pulled, else `FALSE`
    is_pulled = function() {
      all(vapply(private$datasets, is_pulled, logical(1)))
    },
    #' @description
    #' Mutate data by code. Code used in this mutation is not linked to particular
    #' but refers to all datasets.
    #' Consequence of this is that when using `get_code(<dataset>)` this
    #' part of the code will be returned for each specified dataset. This method
    #' should be used only if particular call involve changing multiple datasets.
    #' Otherwise please use `mutate_dataset`.
    #' Execution of `mutate_code` is delayed after datasets are pulled
    #' (`isTRUE(is_pulled)`).
    #'
    #' @param code (`character`) Code to mutate the dataset. Must contain the
    #'  `dataset$dataname`
    #' @param vars (named `list`)) \cr
    #'   In case when this object code depends on other `TealDataset` object(s) or
    #'   other constant value, this/these object(s) should be included as named
    #'   element(s) of the list. For example if this object code needs `ADSL`
    #'   object we should specify `vars = list(ADSL = <adsl object>)`.
    #'   It's recommended to include `TealDataset` or `TealDatasetConnector` objects to
    #'   the `vars` list to preserve reproducibility. Please note that `vars`
    #'   are included to this object as local `vars` and they cannot be modified
    #'   within another dataset.
    #'
    #' @return self invisibly for chaining
    mutate = function(code, vars = list()) {
      private$set_mutate_vars(vars)
      private$set_mutate_code(
        code = code,
        deps = names(vars)
      )
      private$check_result <- NULL
      logger::log_trace(
        sprintf(
          "TealDataAbstract$mutate code (%s lines) and vars (%s) set.",
          length(parse(text = code, keep.source = FALSE)),
          paste(names(vars), collapse = ", ")
        )
      )
      return(invisible(self))
    },
    #' @description
    #' Mutate dataset by code.
    #' Execution of `mutate_code` is delayed after datasets are pulled
    #' (`isTRUE(is_pulled)`).
    #'
    #' @param dataname (`character`) `Dataname` to be mutated
    #' @param code (`character`) Code to mutate the dataset. Must contain the
    #'  `dataset$dataname`
    #' @param vars (named `list`)) \cr
    #'   In case when this object code depends on other `TealDataset` object(s) or
    #'   other constant value, this/these object(s) should be included as named
    #'   element(s) of the list. For example if this object code needs `ADSL`
    #'   object we should specify `vars = list(ADSL = <adsl object>)`.
    #'   It's recommended to include `TealDataset` or `TealDatasetConnector` objects to
    #'   the `vars` list to preserve reproducibility. Please note that `vars`
    #'   are included to this object as local `vars` and they cannot be modified
    #'   within another dataset.
    #'
    #' @return self invisibly for chaining
    mutate_dataset = function(dataname, code, vars = list()) {
      checkmate::assert_character(dataname, min.len = 1, any.missing = FALSE)
      stopifnot(all(dataname %in% self$get_datanames()))

      private$set_mutate_vars(vars = vars)
      private$set_mutate_code(
        code = code,
        dataname = dataname,
        deps = names(vars)
      )

      private$check_result <- NULL
      logger::log_trace(
        sprintf(
          "TealDataAbstract$mutate code (%s lines) and vars (%s) set for dataset: %s.",
          length(parse(text = code, keep.source = FALSE)),
          paste(names(vars), collapse = ", "),
          dataname
        )
      )

      return(invisible(self))
    },
    #' @description
    #' Set reproducibility check
    #'
    #' @param check (`logical`) whether to perform reproducibility check.
    #'
    #' @return (`self`) invisibly for chaining.
    set_check = function(check = FALSE) {
      checkmate::assert_flag(check)
      private$.check <- check
      logger::log_trace("TealDataAbstract$set_check check set to: { check }.")
      return(invisible(self))
    },
    #' @description
    #' Set pull code
    #'
    #' @param code (`character` value)\cr
    #'   code to reproduce `data` in `TealDataset` objects. Can't be set if any dataset
    #'   has `code` set already.
    #'
    #' @return (`self`) invisibly for chaining.
    set_pull_code = function(code) {
      checkmate::assert_string(code)
      is_code_set <- vapply(
        self$get_items(),
        function(item) {
          get_code(item, deparse = TRUE) != ""
        },
        logical(1)
      )

      is_dataset <- vapply(
        self$get_items(),
        function(item) {
          inherits(item, "TealDataset")
        },
        logical(1)
      )

      if (any(is_code_set & is_dataset)) {
        stop(
          "'code' argument should be specified only in the 'cdisc_data' or in 'cdisc_dataset' but not in both",
          call. = FALSE
        )
      }

      if (all(!is_dataset)) {
        stop(
          "Connectors are reproducible by default and setting 'code' argument might break it",
          call. = FALSE
        )
      }

      private$pull_code <- private$pull_code$set_code(
        code = code,
        dataname = self$get_datanames()
      )
      logger::log_trace("TealDataAbstract$set_pull_code pull code set.")

      return(invisible(self))
    },

    #' @description
    #' Reassign `vars` in `TealDataset` and `TealDatasetConnector` objects
    #' to keep the valid reference after deep cloning
    #' For example if `TealDatasetConnector` has a dependency on some `TealDataset`, this
    #' `TealDataset` is reassigned inside of `TealDatasetConnector`.
    reassign_datasets_vars = function() {
      for (dataset in self$get_items()) {
        dataset$reassign_datasets_vars(
          datasets = self$get_items()
        )
      }
      logger::log_trace("TealDataAbstract$reassign_datasets_vars reassigned vars.")
      invisible(NULL)
    }
  ),

  ## __Private Fields ====
  private = list(
    datasets = NULL,
    .check = FALSE,
    check_result = NULL, # TRUE / FALSE after calling check()
    mutate_code = NULL, # CodeClass after initialization
    mutate_vars = list(), # named list with vars used to mutate object
    pull_code = NULL, # CodeClass - code to reproduce loading of TealDataset(s) only

    ## __Private Methods ====
    # need to have a custom deep_clone because one of the key fields are reference-type object
    # in particular: datasets is a list of R6 objects that wouldn't be cloned using default clone(deep = T)
    deep_clone = function(name, value) {
      deep_clone_r6(name, value)
    },
    check_combined_code = function() {
      execution_environment <- new.env(parent = parent.env(globalenv()))
      self$get_code_class(only_pull = TRUE)$eval(envir = execution_environment)
      res <- all(vapply(
        Filter(is_pulled, self$get_items()),
        function(dataset) {
          data <- get_raw_data(dataset)
          data_from_code <- get(get_dataname(dataset), execution_environment)
          identical(data, data_from_code)
        },
        logical(1)
      ))
      logger::log_trace("TealDataAbstract$check_combined_code reproducibility result of the combined code: { res }.")
      res
    },
    get_datasets_code_class = function() {
      res <- CodeClass$new()
      if (is.null(private$datasets)) {
        return(res)
      }
      for (dataset in private$datasets) {
        res$append(dataset$get_code_class())
      }
      return(res)
    },
    get_mutate_code_class = function() {
      res <- CodeClass$new()
      res$append(list_to_code_class(private$mutate_vars))
      res$append(private$mutate_code)
      return(res)
    },
    get_pull_code_class = function() {
      res <- CodeClass$new()
      res$append(private$pull_code)
      return(res)
    },
    set_mutate_code = function(code, dataname = self$get_datanames(), deps = names(private$mutate_vars)) {
      checkmate::assert(
        checkmate::check_character(code, max.len = 1, any.missing = FALSE),
        checkmate::check_class(code, "PythonCodeClass")
      )

      if (inherits(code, "PythonCodeClass")) {
        r <- PythonCodeClass$new()
        r$append(private$mutate_code)
        private$mutate_code <- r

        code <- code$get_code()
      }

      if (length(code) > 0 && code != "") {
        private$mutate_code$set_code(code = code, dataname = dataname, deps = deps)
      }

      return(invisible(self))
    },
    set_mutate_vars = function(vars) {
      checkmate::assert_list(vars, min.len = 0, names = "unique")
      if (length(vars) > 0) {
        private$mutate_vars <- c(
          private$mutate_vars,
          vars[!names(vars) %in% names(private$mutate_vars)]
        )
      }

      return(invisible(self))
    },
    check_names = function(x) {
      if (any(vapply(x, identical, logical(1), y = ""))) {
        stop("Cannot extract some dataset names")
      }
      if (any(duplicated(x))) {
        stop("TealDatasets names should be unique")
      }
      if (any(x %in% self$get_datanames())) {
        stop("Some datanames already exists")
      }
      return(TRUE)
    }
  )
)

#' Helper function to deep copy `R6` object
#'
#' When cloning an R6 object the private function
#' `deep_clone` is automatically used. To ensure a complete
#' clone the private function should call this function
#'
#' @param name (`character`) argument passed by `deep_clone` function.
#' @param value (any `R` object) argument passed by `deep_clone` function.
#' @keywords internal
deep_clone_r6 <- function(name, value) {
  if (checkmate::test_list(value, types = "R6")) {
    lapply(value, function(x) x$clone(deep = TRUE))
  } else if (R6::is.R6(value)) {
    value$clone(deep = TRUE)
  } else if (is.environment(value)) {
    new_env <- as.environment(as.list(value, all.names = TRUE))
    parent.env(new_env) <- parent.env(value)
    new_env
  } else {
    value
  }
}

# CDISCTealDataConnector ------
#'
#' @title Manage multiple and `TealDatasetConnector` of the same type.
#'
#' @description `r lifecycle::badge("stable")`
#' Class manages `TealDatasetConnector` to specify additional dynamic arguments and to
#' open/close connection.
#'
#' @param connection (`TealDataConnection`)\cr
#'   connection to data source
#' @param connectors (`list` of `TealDatasetConnector` elements)\cr
#'   list with dataset connectors
#'
CDISCTealDataConnector <- R6::R6Class( # nolint
  classname = "CDISCTealDataConnector",
  inherit = TealDataConnector,

  ## __Public Methods ====
  public = list(
    #' @description
    #' Create a new `CDISCTealDataConnector` object
    initialize = function(connection, connectors) {
      super$initialize(connection = connection, connectors = connectors)

      new_parent <- list()
      for (x in connectors) {
        x_dataname <- x$get_dataname()
        new_parent[[x_dataname]] <- if (inherits(x, "CDISCTealDatasetConnector")) {
          x$get_parent()
        } else {
          character(0L)
        }
      }

      if (is_dag(new_parent)) {
        stop("Cycle detected in a parent and child dataset graph.")
      }

      private$parent <- new_parent
      logger::log_trace(
        "CDISCTealDataConnector initialized with data: { paste(self$get_datanames(), collapse = ' ') }"
      )
      return(invisible(self))
    },
    #' @description
    #' Get all datasets parent names
    #' @return (named `list`) with dataset name and its corresponding parent dataset name
    get_parent = function() {
      private$parent
    }
  ),

  ## __Private Fields ====
  private = list(
    parent = list() # list with dataset names and its parent dataset names
  )
)

#' The constructor of `CDISCTealDataConnector` objects.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param connection (`TealDataConnection`)\cr
#'   connection to data source
#' @param connectors (`list` of `TealDatasetConnector` elements)\cr
#'   list with dataset connectors
#'
#' @examples
#' adsl_cf <- callable_function(
#'   function() as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADSL"))))
#' )
#' adae_cf <- callable_function(
#'   function() as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADAE"))))
#' )
#' adsl <- cdisc_dataset_connector(
#'   "ADSL", adsl_cf,
#'   keys = get_cdisc_keys("ADSL"), parent = character(0)
#' )
#' adae <- cdisc_dataset_connector(
#'   "ADAE", adae_cf,
#'   keys = get_cdisc_keys("ADAE"), parent = "ADSL"
#' )
#' data <- cdisc_data_connector(
#'   connection = data_connection(open_fun = callable_function(function() "open function")),
#'   connectors = list(adsl, adae)
#' )
#' @return `CDISCTealDataConnector` object
#' @export
cdisc_data_connector <- function(connection, connectors) {
  stopifnot(inherits(connection, "TealDataConnection"))
  checkmate::assert_list(connectors, types = "TealDatasetConnector", min.len = 1)
  CDISCTealDataConnector$new(connection, connectors)
}

#' Load data from connection
#'
#' @description `r lifecycle::badge("stable")`
#' Load data from connection. Function used on [`TealDatasetConnector`] and
#' [`TealDataset`] to obtain data from connection.
#'
#' @param x (`TealDatasetConnector` or `TealDataset`)
#' @param args (`NULL` or named `list`)\cr
#'   additional dynamic arguments passed to function which loads the data.
#' @param try (`logical`) whether perform function evaluation inside `try` clause
#' @param conn Optional (`TealDataConnection`) object required to pull the data.
#' @param ... not used, only for support of S3
#'
#' @return `x` with loaded `dataset` object
#' @export
load_dataset <- function(x, ...) {
  UseMethod("load_dataset")
}

#' @rdname load_dataset
#' @examples
#'
#' # TealDataset --------
#' ADSL <- teal.data::example_cdisc_data("ADSL")
#' ADSL_dataset <- dataset("ADSL", x = ADSL)
#'
#' load_dataset(ADSL_dataset)
#' @export
load_dataset.TealDataset <- function(x, ...) { # nolint
  check_ellipsis(...)
  return(invisible(x$get_dataset()))
}

#' @rdname load_dataset
#' @examples
#'
#' # TealDatasetConnector --------
#'
#' random_data_connector <- function(dataname) {
#'   fun_dataset_connector(
#'     dataname = dataname,
#'     fun = teal.data::example_cdisc_data,
#'     fun_args = list(dataname = dataname),
#'   )
#' }
#'
#' adsl <- random_data_connector(dataname = "ADSL")
#' load_dataset(adsl)
#' get_dataset(adsl)
#'
#' adae <- random_data_connector(dataname = "ADAE")
#' load_dataset(adae)
#' get_dataset(adae)
#' @export
load_dataset.TealDatasetConnector <- function(x, args = NULL, try = FALSE, conn = NULL, ...) { # nolint
  check_ellipsis(...)
  if (!is.null(conn)) {
    stopifnot(inherits(conn, "TealDataConnection"))

    conn$open()
    conn_obj <- conn$get_conn()

    x$get_pull_callable()$assign_to_env("conn", conn_obj)
  }

  x$pull(args = args, try = try)

  return(invisible(x))
}

#' Load datasets
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param x ([`TealData`], [`TealDataset`] or [`TealDatasetConnector`])
#' @param args (`NULL` or named `list`)\cr
#'   additional dynamic arguments passed to function which loads the data. Applicable only on [`TealDatasetConnector`])
#' @param try (`logical`)\cr
#'   whether perform function evaluation inside `try` clause. Applicable only on [`TealDatasetConnector`])
#' @param ... (not used)\cr
#'  only for support of S3
#'
#' @export
#' @return If executed in the interactive session shiny app is opened to load the data. If executed in
#'  shiny application - it returns shiny server module.
load_datasets <- function(x, ...) {
  UseMethod("load_datasets")
}

#' @rdname load_datasets
#' @examples
#'
#' # TealDataset ------
#' ADSL <- teal.data::example_cdisc_data("ADSL")
#' x <- dataset("ADSL", x = ADSL)
#'
#' load_datasets(x)
#' @export
load_datasets.TealDataset <- function(x, ...) { # nolint
  check_ellipsis(...)
  return(invisible(x$get_dataset()))
}

#' @rdname load_datasets
#' @examples
#'
#' # TealDatasetConnector ------
#' random_data_connector <- function(dataname) {
#'   fun_dataset_connector(
#'     dataname = dataname,
#'     fun = teal.data::example_cdisc_data,
#'     fun_args = list(dataname = dataname),
#'   )
#' }
#'
#' adsl <- random_data_connector(dataname = "ADSL")
#' load_datasets(adsl)
#' get_dataset(adsl)
#'
#' adae <- random_data_connector(dataname = "ADAE")
#' load_datasets(adae)
#' get_dataset(adae)
#' @export
load_datasets.TealDatasetConnector <- function(x, args = NULL, try = FALSE, ...) { # nolint
  check_ellipsis(...)
  x$pull(args = args, try = try)
  return(invisible(x))
}


#' @rdname load_datasets
#' @export
#' @examples
#'
#' # TealDataConnector --------
#' random_data_connector <- function(dataname) {
#'   fun_dataset_connector(
#'     dataname = dataname,
#'     fun = teal.data::example_cdisc_data,
#'     fun_args = list(dataname = dataname),
#'   )
#' }
#'
#' adsl <- random_data_connector(dataname = "ADSL")
#' adrs <- random_data_connector(dataname = "ADRS")
#'
#' rdc <- cdisc_data(adsl, adrs)
#' \dontrun{
#' load_datasets(rdc)
#' }
load_datasets.TealDataConnector <- function(x, ...) { # nolint
  check_ellipsis(...)
  if (interactive()) {
    x$launch()
  } else {
    return(invisible(x))
  }
}

#' @rdname load_datasets
#' @export
#' @examples
#'
#' # TealData --------
#' random_data_connector <- function(dataname) {
#'   fun_dataset_connector(
#'     dataname = dataname,
#'     fun = teal.data::example_cdisc_data,
#'     fun_args = list(dataname = dataname),
#'   )
#' }
#'
#' adsl <- random_data_connector(dataname = "ADSL")
#' adlb <- random_data_connector(dataname = "ADLB")
#' adrs <- random_data_connector(dataname = "ADRS")
#'
#' tc <- cdisc_data(adsl, adlb, adrs)
#' \dontrun{
#' load_datasets(tc)
#' }
load_datasets.TealData <- function(x, ...) { # nolint
  check_ellipsis(...)
  if (interactive()) {
    x$launch()
  } else {
    return(invisible(x))
  }
}

## TealData ====
#' @title Manage multiple `TealDataConnector`, `TealDatasetConnector` and `TealDataset` objects.
#'
#' @description `r lifecycle::badge("experimental")`
#' Class manages `TealDataConnector`, `TealDatasetConnector` and
#' `TealDataset` objects and aggregate them in one collection.
#' Class also decides whether to launch app before initialize teal application.
#'
#' @param ... (`TealDataConnector`, `TealDataset`, `TealDatasetConnector`)\cr
#'   objects
#' @param join_keys (`JoinKeys`) or a single (`JoinKeySet`)\cr
#'   (optional) object with dataset column relationships used for joining.
#'   If empty then an empty `JoinKeys` object is passed by default.
#' @param check (`logical`) reproducibility check - whether evaluated preprocessing code gives the same objects
#'   as provided in arguments. Check is run only if flag is true and preprocessing code is not empty.
#'
#' @examples
#' adsl_cf <- callable_function(teal.data::example_cdisc_data)$set_args(list(dataname = "ADSL"))
#' adlb_cf <- callable_function(teal.data::example_cdisc_data)$set_args(list(dataname = "ADLB"))
#' adrs_cf <- callable_function(teal.data::example_cdisc_data)$set_args(list(dataname = "ADRS"))
#' adtte_cf <- callable_function(teal.data::example_cdisc_data)$set_args(list(dataname = "ADTTE"))
#' x1 <- cdisc_dataset_connector("ADSL", adsl_cf, keys = get_cdisc_keys("ADSL"))
#' x2 <- cdisc_dataset_connector("ADRS", adrs_cf, keys = get_cdisc_keys("ADRS"))
#' x3 <- cdisc_dataset(
#'   dataname = "ADAE",
#'   x = teal.data::example_cdisc_data("ADAE"),
#'   code = "library(teal.data)\nADAE <- teal.data::example_cdisc_data(\"ADAE\")"
#' )
#' x4 <- cdisc_dataset_connector("ADTTE", adtte_cf, keys = get_cdisc_keys("ADTTE"))
#' tc <- teal.data:::TealData$new(x1, x2, x3, x4)
#' tc$get_datanames()
#' \dontrun{
#' tc$launch()
#' get_datasets(tc) # equivalent to tc$get_datasets()
#' tc$get_dataset("ADAE")
#' tc$check()
#' }
#'
#' x <- cdisc_dataset(
#'   dataname = "ADSL",
#'   x = teal.data::example_cdisc_data("ADSL"),
#'   code = "library(teal.data)\nADSL <- teal.data::example_cdisc_data(\"ADSL\")"
#' )
#'
#' x2 <- cdisc_dataset_connector("ADTTE", adtte_cf, keys = get_cdisc_keys("ADTTE"))
#' tc <- teal.data:::TealData$new(x, x2)
#' \dontrun{
#' # This errors as we have not pulled the data
#' # tc$get_datasets()
#' # pull the data and then we can get the datasets
#' tc$launch()
#' tc$get_datasets()
#' get_raw_data(tc)
#' }
#'
TealData <- R6::R6Class( # nolint
  classname = "TealData",
  inherit = TealDataAbstract,
  ## __Public Methods ====
  public = list(
    #' @description
    #' Create a new object of `TealData` class
    initialize = function(..., check = FALSE, join_keys = teal.data::join_keys()) {
      checkmate::assert_class(join_keys, "JoinKeys")

      dot_args <- list(...)
      is_teal_data <- checkmate::test_list(
        dot_args,
        types = c("TealDataConnector", "TealDataset", "TealDatasetConnector")
      )
      if (!all(is_teal_data)) {
        stop("All elements should be of TealDataset(Connector) or TealDataConnector class")
      }

      datanames <- unlist(lapply(dot_args, get_dataname))
      private$check_names(datanames)

      private$datasets <- dot_args

      self$set_check(check)

      private$pull_code <- CodeClass$new()
      private$mutate_code <- CodeClass$new()

      private$join_keys <- join_keys

      self$id <- sample.int(1e11, 1, useHash = TRUE)

      logger::log_trace(
        "TealData initialized with data: { paste(self$get_datanames(), collapse = ' ') }."
      )
      return(invisible(self))
    },
    #' @description
    #' Creates a copy of the object with keeping valid references
    #' between `TealDataset` and `TealDatasetConnector` objects
    #' @param deep (`logical(1)`)\cr
    #'  argument passed to `clone` method. If `TRUE` deep copy is made
    #' @return self invisible
    copy = function(deep = FALSE) {
      new_self <- self$clone(deep = deep)
      new_self$reassign_datasets_vars()
      logger::log_trace("TealData$copy{if (deep) ' deep-' else ' '}copied self.")
      invisible(new_self)
    },
    #' @description
    #' Prints this `TealData`.
    #'
    #' @param ... additional arguments to the printing method
    #' @return invisibly self
    print = function(...) {
      check_ellipsis(...)

      cat(sprintf(
        "A %s object containing %d TealDataset/TealDatasetConnector object(s) as element(s):\n",
        class(self)[1],
        length(private$datasets)
      ))

      for (i in seq_along(private$datasets)) {
        cat(sprintf("--> Element %d:\n", i))
        print(private$datasets[[i]])
      }

      invisible(self)
    },
    # ___ getters ====
    #' @description
    #' Get data connectors.
    #'
    #' @return (`list`) with all `TealDatasetConnector` or `TealDataConnector` objects.
    get_connectors = function() {
      return(Filter(
        function(x) {
          inherits(x, "TealDatasetConnector") || inherits(x, "TealDataConnector")
        },
        private$datasets
      ))
    },
    #' @description
    #' Get all datasets and all dataset connectors
    #'
    #' @param dataname (`character` value)\cr
    #'   name of dataset connector to be returned. If `NULL`, all connectors are returned.
    #'
    #' @return `list` with all datasets and all connectors
    get_items = function(dataname = NULL) {
      checkmate::assert_string(dataname, null.ok = TRUE)

      get_sets <- function(x) {
        if (inherits(x, "TealDataConnector")) {
          x$get_items()
        } else {
          x
        }
      }

      sets <- unlist(lapply(private$datasets, get_sets))
      names(sets) <- vapply(sets, get_dataname, character(1))

      if (checkmate::test_string(dataname)) {
        if (!(dataname %in% self$get_datanames())) {
          stop(paste("dataset", dataname, "not found"))
        }
        return(sets[[dataname]])
      } else {
        return(sets)
      }
    },

    #' @description
    #' Get join keys between two datasets.
    #'
    #' @param dataset_1 (`character`) name of first dataset.
    #' @param dataset_2 (`character`) name of second dataset.
    #' @return (`character`) named character vector x with names(x) the
    #' columns of `dataset_1` and the values of `(x)` the corresponding join
    #' keys in `dataset_2` or `character(0)` if no relationship
    get_join_keys = function(dataset_1, dataset_2) {
      if (missing(dataset_1) && missing(dataset_2)) {
        private$join_keys
      } else {
        private$join_keys$get(dataset_1, dataset_2)
      }
    },

    #' @description
    #' returns the parents list of the datasets.
    #'
    #' @return named (`list`) of the parents of all datasets.
    get_parents = function() {
      private$join_keys$get_parents()
    },

    # ___ shiny ====

    #' @description
    #'
    #' Get a shiny-module UI to render the necessary app to
    #' derive `TealDataConnector` object's data
    #'
    #' @param id (`character`) item ID for the shiny module
    #' @return the `shiny` `ui` function
    get_ui = function(id) {
      if (is.null(private$ui)) {
        div(id = id, "Data Loaded")
      } else {
        private$ui(id)
      }
    },
    #' @description
    #'
    #' Get a shiny-module server to render the necessary app to
    #' derive `TealDataConnector` object's data
    #'
    #' @return `shiny` server module.
    get_server = function() {
      if (is.null(private$server)) {
        return(
          function(id) {
            moduleServer(
              id = id,
              module = function(input, output, session) {
                reactive(self)
              }
            )
          }
        )
      } else {
        function(id) {
          moduleServer(
            id = id,
            module = private$server
          )
        }
      }
    },
    #' @description
    #'
    #' Launch an app that allows to run the user-interfaces of all
    #' `TealDataConnector` and `TealDatasetConnector` modules
    #'
    #' This piece is mainly used for debugging.
    launch = function() {
      # if no data connectors can append any dataset connectors
      # and not load an app
      if (self$is_pulled()) {
        stop("All the datasets have already been pulled.")
      }

      # otherwise load TealDataConnector and
      # TealDatasetConnector with shiny app
      shinyApp(
        ui = fluidPage(
          theme = get_teal_bs_theme(),
          fluidRow(
            column(
              width = 8,
              offset = 2,
              self$get_ui(id = "main_app"),
              shinyjs::hidden(
                tags$div(
                  id = "data_loaded",
                  div(
                    h3("Data successfully loaded."),
                    p("You can close this window and get back to R console.")
                  )
                )
              ),
              include_js_files(),
              br()
            )
          )
        ),
        server = function(input, output, session) {
          session$onSessionEnded(stopApp)
          dat <- self$get_server()(id = "main_app")

          observeEvent(dat(), {
            if (self$is_pulled()) {
              shinyjs::show("data_loaded")
              stopApp()
            }
          })
          NULL
        }
      )
    },

    # ___ mutate ====
    #' @description
    #' Change join_keys for a given pair of dataset names
    #' @param dataset_1,dataset_2 (`character`) datasets for which join_keys are to be returned
    #' @param val (named `character`) column names used to join
    #' @return (`self`) invisibly for chaining
    mutate_join_keys = function(dataset_1, dataset_2, val) {
      private$join_keys$mutate(dataset_1, dataset_2, val)
    },

    # ___ check ====
    #' @description
    #' Check there is consistency between the datasets and join_keys
    #' @return raise and error or invisible `TRUE`
    check_metadata = function() {
      if (isFALSE(self$is_pulled())) {
        # all the checks below required data to be already pulled
        return(invisible(TRUE))
      }

      for (dataset in self$get_datasets()) {
        dataname <- get_dataname(dataset)
        dataset_colnames <- dataset$get_colnames()

        # expected columns in this dataset from JoinKeys specification
        join_key_cols <- unique(unlist(lapply(self$get_join_keys(dataname), names)))
        if (!is.null(join_key_cols) && !all(join_key_cols %in% dataset_colnames)) {
          stop(
            paste(
              "The join key specification requires dataset",
              dataname,
              "to contain the following columns:",
              paste(join_key_cols, collapse = ", ")
            )
          )
        }

        # check if primary keys in dataset
        primary_key_cols <- self$get_join_keys(dataname, dataname)
        if (!is.null(primary_key_cols) && !all(primary_key_cols %in% dataset_colnames)) {
          stop(
            paste(
              "The primary keys specification requires dataset",
              dataname,
              "to contain the following columns:",
              paste(primary_key_cols, collapse = ", ")
            )
          )
        }
        dataset$check_keys()
      }

      logger::log_trace("TealData$check_metadata metadata check passed.")

      return(invisible(TRUE))
    }
  ),

  ## __Private Fields ====
  private = list(
    join_keys = NULL,
    ui = function(id) {
      ns <- NS(id)

      # connectors ui(s) + submit button
      fluidPage(
        include_js_files(),
        theme = get_teal_bs_theme(),
        shinyjs::hidden(
          column(
            id = ns("delayed_data"),
            width = 8,
            offset = 2,
            div(
              tagList(
                lapply(
                  private$datasets,
                  function(x) {
                    div(
                      if (inherits(x, "TealDataConnector")) {
                        ui <- x$get_ui(id = ns(x$id))
                        if (is.null(ui)) {
                          ui <- div(
                            h4("TealDataset Connector for: ", lapply(x$get_datanames(), code)),
                            p(icon("check"), "Ready to Load")
                          )
                        }
                        ui
                      } else if (inherits(x, "TealDatasetConnector")) {
                        ui <- x$get_ui(id = ns(paste0(x$get_datanames(), collapse = "_")))
                        if (is.null(ui)) {
                          ui <- div(
                            h4("TealDataset Connector for: ", code(x$get_dataname())),
                            p(icon("check"), "Ready to Load")
                          )
                        }
                        ui
                      } else {
                        div(h4("Data(set) for: ", lapply(x$get_datanames(), code)), p(icon("check"), "Loaded"))
                      },
                      br()
                    )
                  }
                ),
                actionButton(inputId = ns("submit"), label = "Submit all")
              ),
              `data-proxy-click` = ns("submit") # handled by jscode in custom.js - hit enter to submit
            )
          )
        )
      )
    },
    server = function(input, output, session) {
      logger::log_trace("TealData$server initializing...")

      shinyjs::show("delayed_data")
      for (dc in self$get_connectors()) {
        if (inherits(dc, "TealDataConnector")) {
          dc$get_preopen_server()(id = dc$id)
        }
      }
      rv <- reactiveVal(NULL)
      observeEvent(input$submit, {
        logger::log_trace("TealData$server@1 submit button clicked.")
        # load data from all connectors
        for (dc in self$get_connectors()) {
          if (inherits(dc, "TealDataConnector")) {
            dc$get_server()(
              id = dc$id,
              connection = dc$get_connection(),
              connectors = dc$get_items()
            )
          } else if (inherits(dc, "TealDatasetConnector")) {
            dc$get_server()(id = dc$get_dataname())
          }
          if (dc$is_failed()) {
            break
          }
        }

        if (self$is_pulled()) {
          logger::log_trace("TealData$server@1 data is pulled.")
          withProgress(value = 1, message = "Checking data reproducibility", {
            # We check first and then mutate.
            #  mutate_code is reproducible by default we assume that we don't
            #  have to check the result of the re-evaluation of the code
            self$check_reproducibility()
          })

          withProgress(value = 1, message = "Executing processing code", {
            self$execute_mutate()
            self$check_metadata()
          })
          logger::log_info("Data ready to pass to the application.")
          shinyjs::hide("delayed_data")
          rv(self)
        }
      })
      return(rv)
    }
  )
)

#' Get dataset label attribute
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param data \code{data.frame} from which attribute is extracted
#'
#' @return (\code{character}) label or \code{NULL} if it is missing
#'
#' @export
#'
#' @examples
#' data_label(example_cdisc_data("ADSL"))
data_label <- function(data) {
  attr(data, "label")
}

#' Set dataset label attribute
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param x \code{data.frame} for which attribute is set
#' @param value (\code{character}) label
#'
#' @return modified \code{x} object
#'
#' @export
#'
#' @examples
#' x <- teal.data::example_cdisc_data("ADSL")
#' data_label(x) <- "My custom label"
#' data_label(x)
`data_label<-` <- function(x, value) { # nolint
  stopifnot(is.data.frame(x))
  checkmate::assert_string(value)

  attr(x, "label") <- value
  x
}

#' Function that returns the default keys for a `CDISC` dataset by name
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param dataname name of the `CDISC` dataset
#'
#' @return \code{keys} object
#'
#' @export
#'
#' @examples
#' get_cdisc_keys("ADSL")
get_cdisc_keys <- function(dataname) {
  checkmate::assert_string(dataname)

  if (!(dataname %in% names(default_cdisc_keys))) {
    stop(paste(sprintf("get_cdisc_keys does not support datasets called %s", dataname),
      "  Please specify the keys directly, for example:",
      sprintf(
        "  cdisc_dataset(dataname = \"%s\", keys = c(\"STUDYID\", \"USUBJID\", ...), parent = \"ADSL\", ...)",
        dataname
      ),
      sep = "\n"
    ))
  } else {
    cdisc_keys <- default_cdisc_keys[[dataname]]$primary

    return(cdisc_keys)
  }
}

#' Extracts dataset and variable labels from a dataset.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param data (`data.frame`) table to extract the labels from
#' @param fill (`logical(1)`) if `TRUE`, the function will return variable names for columns with non-existent labels;
#'   otherwise will return `NA` for them
#'
#' @return `list` with two keys: `dataset_labels` and `column_labels`
#'
#' @export
#'
#' @examples
#' iris_with_labels <- iris
#' attr(iris_with_labels, "label") <- "Custom iris dataset with labels"
#' attr(iris_with_labels["Sepal.Length"], "label") <- c(`Sepal.Length` = "Sepal Length")
#' get_labels(iris_with_labels, fill = TRUE)
#' get_labels(iris_with_labels, fill = FALSE)
get_labels <- function(data, fill = TRUE) {
  stopifnot(is.data.frame(data))
  checkmate::assert_flag(fill)

  column_labels <- Map(function(col, colname) {
    label <- attr(col, "label")
    if (is.null(label)) {
      if (fill) {
        colname
      } else {
        NA_character_
      }
    } else {
      if (!checkmate::test_string(label, na.ok = TRUE)) {
        stop("label for variable ", colname, " is not a character string")
      }
      as.vector(label) # because label might be a named vector
    }
  }, data, colnames(data))
  column_labels <- unlist(column_labels, recursive = FALSE, use.names = TRUE)

  list("dataset_label" = data_label(data), "column_labels" = column_labels)
}

## TealDataset ====
#'
#'
#' @title  R6 Class representing a dataset with its attributes
#'
#' @description `r lifecycle::badge("stable")`
#' Any `data.frame` object can be stored inside this object.
#' Some attributes like colnames, dimension or column names for a specific type will
#' be automatically derived.
#'
#' @param dataname (`character`)\cr
#'        A given name for the dataset it may not contain spaces
#' @param x (`data.frame`)\cr
#' @param keys optional, (`character`)\cr
#'        Vector with primary keys
#' @param code (`character`)\cr
#'        A character string defining the code needed to produce the data set in `x`.
#'        `initialize()` and `recreate()` accept code as `CodeClass`
#'        which is also needed to preserve the code uniqueness and correct order.
#' @param label (`character`)\cr
#'        Label to describe the dataset
#' @param vars (named `list`)) \cr
#'        In case when this object code depends on other `TealDataset` object(s) or
#'        other constant value, this/these object(s) should be included as named
#'        element(s) of the list. For example if this object code needs `ADSL`
#'        object we should specify `vars = list(ADSL = <adsl object>)`.
#'        It is recommended to include `TealDataset` or `TealDatasetConnector` objects to
#'        the `vars` list to preserve reproducibility. Please note that `vars`
#'        are included to this object as local `vars` and they cannot be modified
#'        within another dataset.
#' @param metadata (named `list` or `NULL`) \cr
#'        Field containing metadata about the dataset. Each element of the list
#'        should be atomic and of length one.
#'
#' @seealso [`MAETealDataset`]
#'
TealDataset <- R6::R6Class( # nolint
  "TealDataset",

  ## __Public Methods ====
  public = list(
    #' @description
    #' Create a new object of `TealDataset` class
    initialize = function(dataname,
                          x,
                          keys = character(0),
                          code = character(0),
                          label = character(0),
                          vars = list(),
                          metadata = NULL) {
      checkmate::assert_string(dataname)
      checkmate::assert_data_frame(x)
      checkmate::assert_character(keys, any.missing = FALSE)
      checkmate::assert(
        checkmate::check_character(code, max.len = 1, any.missing = FALSE),
        checkmate::check_class(code, "CodeClass")
      )
      # label might be NULL also because of taking label attribute from data.frame - missing attr is NULL
      checkmate::assert_character(label, max.len = 1, null.ok = TRUE, any.missing = FALSE)
      checkmate::assert_list(vars, names = "named")

      validate_metadata(metadata)

      private$.raw_data <- x
      private$metadata <- metadata

      private$set_dataname(dataname)
      self$set_vars(vars)
      self$set_dataset_label(label)
      self$set_keys(keys)

      # needed if recreating dataset - we need to preserve code order and uniqueness
      private$code <- CodeClass$new()
      if (is.character(code)) {
        self$set_code(code)
      } else {
        private$code$append(code)
      }

      logger::log_trace("TealDataset initialized for dataset: { deparse1(self$get_dataname()) }.")
      return(invisible(self))
    },

    #' @description
    #' Recreate this `TealDataset` with its current attributes.
    #'
    #' @return a new object of the `TealDataset` class
    recreate = function(dataname = self$get_dataname(),
                        x = self$get_raw_data(),
                        keys = self$get_keys(),
                        code = private$code,
                        label = self$get_dataset_label(),
                        vars = list(),
                        metadata = self$get_metadata()) {
      res <- self$initialize(
        dataname = dataname,
        x = x,
        keys = keys,
        code = code,
        label = label,
        vars = vars,
        metadata = metadata
      )
      logger::log_trace("TealDataset$recreate recreated dataset: { deparse1(self$get_dataname()) }.")
      return(res)
    },
    #' @description
    #' Prints this `TealDataset`.
    #'
    #' @param ... additional arguments to the printing method
    #' @return invisibly self
    print = function(...) {
      check_ellipsis(...)
      cat(sprintf(
        "A %s object containing the following data.frame (%s rows and %s columns):\n",
        class(self)[1],
        self$get_nrow(),
        self$get_ncol()
      ))
      print(head(as.data.frame(self$get_raw_data())))
      if (self$get_nrow() > 6) {
        cat("...\n")
      }
      invisible(self)
    },
    # ___ getters ====
    #' @description
    #' Performs any delayed mutate calls before returning self.
    #'
    #' @return dataset (`TealDataset`)
    get_dataset = function() {
      if (self$is_mutate_delayed() && !private$is_any_dependency_delayed()) {
        private$mutate_eager()
      }
      return(self)
    },
    #' @description
    #' Get all dataset attributes
    #' @return (named `list`) with dataset attributes
    get_attrs = function() {
      x <- append(
        attributes(self$get_raw_data()),
        list(
          column_labels = self$get_column_labels(),
          row_labels = self$get_row_labels(),
          dataname = self$get_dataname(),
          dataset_label = self$get_dataset_label(),
          keys = self$get_keys()
        )
      )
      return(x)
    },
    #' @description
    #' Derive the raw data frame inside this object
    #' @return `data.frame`
    get_raw_data = function() {
      private$.raw_data
    },
    #' @description
    #' Derive the names of all `numeric` columns
    #' @return `character` vector.
    get_numeric_colnames = function() {
      private$get_class_colnames("numeric")
    },
    #' @description
    #' Derive the names of all `character` columns
    #' @return `character` vector.
    get_character_colnames = function() {
      private$get_class_colnames("character")
    },
    #' @description
    #' Derive the names of all `factor` columns
    #' @return `character` vector.
    get_factor_colnames = function() {
      private$get_class_colnames("factor")
    },
    #' @description
    #' Derive the column names
    #' @return `character` vector.
    get_colnames = function() {
      colnames(private$.raw_data)
    },
    #' @description
    #' Derive the column labels
    #' @return `character` vector.
    get_column_labels = function() {
      col_labels(private$.raw_data, fill = FALSE)
    },
    #' @description
    #' Get the number of columns of the data
    #' @return `numeric` vector
    get_ncol = function() {
      ncol(private$.raw_data)
    },
    #' @description
    #' Get the number of rows of the data
    #' @return `numeric` vector
    get_nrow = function() {
      nrow(private$.raw_data)
    },
    #' @description
    #' Derive the row names
    #' @return `character` vector.
    get_rownames = function() {
      rownames(private$.raw_data)
    },
    #' @description
    #' Derive the row labels
    #' @return `character` vector.
    get_row_labels = function() {
      c()
    },
    #' @description
    #' Derive the `name` which was formerly called `dataname`
    #' @return `character` name of the dataset
    get_dataname = function() {
      private$dataname
    },
    #' @description
    #' Derive the `dataname`
    #' @return `character` name of the dataset
    get_datanames = function() {
      private$dataname
    },
    #' @description
    #' Derive the `label` which was former called `datalabel`
    #' @return `character` label of the dataset
    get_dataset_label = function() {
      private$dataset_label
    },
    #' @description
    #' Get primary keys of dataset
    #' @return (`character` vector) with dataset primary keys
    get_keys = function() {
      private$.keys
    },
    #' @description
    #' Get metadata of dataset
    #' @return (named `list`)
    get_metadata = function() {
      private$metadata
    },
    #' @description
    #' Get the list of dependencies that are `TealDataset` or `TealDatasetConnector` objects
    #'
    #' @return `list`
    get_var_r6 = function() {
      return(private$var_r6)
    },
    # ___ setters ====
    #' @description
    #' Overwrites `TealDataset` or `TealDatasetConnector` dependencies of this `TealDataset` with
    #' those found in `datasets`. Reassignment
    #' refers only to the provided `datasets`, other `vars` remains the same.
    #' @details
    #' Reassign `vars` in this object to keep references up to date after deep clone.
    #' Update is done based on the objects passed in `datasets` argument.
    #' Overwrites dependencies with names matching the names of the objects passed
    #' in `datasets`.
    #' @param datasets (`named list` of `TealDataset(s)` or `TealDatasetConnector(s)`)\cr
    #'   objects with valid pointers.
    #' @return NULL invisible
    #' @examples
    #' test_dataset <- teal.data:::TealDataset$new(
    #'   dataname = "iris",
    #'   x = iris,
    #'   vars = list(dep = teal.data:::TealDataset$new("iris2", iris))
    #' )
    #' test_dataset$reassign_datasets_vars(
    #'   list(iris2 = teal.data:::TealDataset$new("iris2", head(iris)))
    #' )
    #'
    reassign_datasets_vars = function(datasets) {
      checkmate::assert_list(datasets, min.len = 0, names = "unique")

      common_var_r6 <- intersect(names(datasets), names(private$var_r6))
      private$var_r6[common_var_r6] <- datasets[common_var_r6]

      common_vars <- intersect(names(datasets), names(private$vars))
      private$vars[common_vars] <- datasets[common_vars]

      common_mutate_vars <- intersect(names(datasets), names(private$mutate_vars))
      private$mutate_vars[common_mutate_vars] <- datasets[common_mutate_vars]

      logger::log_trace(
        "TealDataset$reassign_datasets_vars reassigned vars for dataset: { deparse1(self$get_dataname()) }."
      )
      invisible(NULL)
    },
    #' @description
    #' Set the label for the dataset
    #' @return (`self`) invisibly for chaining
    set_dataset_label = function(label) {
      if (is.null(label)) {
        label <- character(0)
      }
      checkmate::assert_character(label, max.len = 1, any.missing = FALSE)
      private$dataset_label <- label

      logger::log_trace(
        "TealDataset$set_dataset_label dataset_label set for dataset: { deparse1(self$get_dataname()) }."
      )
      return(invisible(self))
    },
    #' @description
    #' Set new keys
    #' @return (`self`) invisibly for chaining.
    set_keys = function(keys) {
      checkmate::assert_character(keys, any.missing = FALSE)
      private$.keys <- keys
      logger::log_trace(sprintf(
        "TealDataset$set_keys set the keys %s for dataset: %s",
        paste(keys, collapse = ", "),
        self$get_dataname()
      ))
      return(invisible(self))
    },

    #' @description
    #' Adds variables which code depends on
    #'
    #' @param vars (`named list`) contains any R object which code depends on
    #' @return (`self`) invisibly for chaining
    set_vars = function(vars) {
      private$set_vars_internal(vars, is_mutate_vars = FALSE)
      logger::log_trace("TealDataset$set_vars vars set for dataset: { deparse1(self$get_dataname()) }.")

      return(invisible(NULL))
    },
    #' @description
    #' Sets reproducible code
    #'
    #' @return (`self`) invisibly for chaining
    set_code = function(code) {
      checkmate::assert_character(code, max.len = 1, any.missing = FALSE)
      if (length(code) > 0 && code != "") {
        private$code$set_code(
          code = code,
          dataname = self$get_datanames(),
          deps = names(private$vars)
        )
      }
      logger::log_trace("TealDataset$set_code code set for dataset: { deparse1(self$get_dataname()) }.")
      return(invisible(NULL))
    },

    # ___ get_code ====
    #' @description
    #' Get code to get data
    #'
    #' @param deparse (`logical`) whether return deparsed form of a call
    #'
    #' @return optionally deparsed `call` object
    get_code = function(deparse = TRUE) {
      checkmate::assert_flag(deparse)
      res <- self$get_code_class()$get_code(deparse = deparse)
      return(res)
    },
    #' @description
    #' Get internal `CodeClass` object
    #' @param nodeps (`logical(1)`) whether `CodeClass` should not contain the code
    #' of the dependent `vars`
    #' the `mutate`
    #' @return `CodeClass`
    get_code_class = function(nodeps = FALSE) {
      res <- CodeClass$new()
      # precise order matters
      if (!nodeps) {
        res$append(list_to_code_class(private$vars))
        res$append(list_to_code_class(private$mutate_vars))
      }
      res$append(private$code)
      res$append(private$mutate_list_to_code_class())

      return(res)
    },
    #' @description
    #' Get internal `CodeClass` object
    #'
    #' @return `CodeClass`
    get_mutate_code_class = function() {
      res <- CodeClass$new()
      res$append(list_to_code_class(private$mutate_vars))
      res$append(private$mutate_list_to_code_class())

      return(res)
    },
    #' @description
    #' Get internal `vars` object
    #'
    #' @return `list`
    get_vars = function() {
      return(c(
        private$vars,
        private$mutate_vars[!names(private$mutate_vars) %in% names(private$vars)]
      ))
    },
    #' @description
    #' Get internal `mutate_vars` object
    #'
    #' @return `list`
    get_mutate_vars = function() {
      return(private$mutate_vars)
    },

    #' @description
    #' Whether mutate code has delayed evaluation.
    #' @return `logical`
    is_mutate_delayed = function() {
      return(length(private$mutate_code) > 0)
    },

    # ___ mutate ====
    #' @description
    #' Mutate dataset by code
    #'
    #' @param code (`CodeClass`) or (`character`) R expressions to be executed
    #' @param vars a named list of R objects that `code` depends on to execute
    #' @param force_delay (`logical`) used by the containing `TealDatasetConnector` object
    #'
    #' Either code or script must be provided, but not both.
    #'
    #' @return (`self`) invisibly for chaining
    mutate = function(code, vars = list(), force_delay = FALSE) {
      logger::log_trace(
        sprintf(
          "TealDatasetConnector$mutate mutating dataset '%s' using the code (%s lines) and vars (%s).",
          self$get_dataname(),
          length(parse(text = if (inherits(code, "CodeClass")) code$get_code() else code, keep.source = FALSE)),
          paste(names(vars), collapse = ", ")
        )
      )

      checkmate::assert_flag(force_delay)
      checkmate::assert_list(vars, min.len = 0, names = "unique")
      checkmate::assert(
        checkmate::check_string(code),
        checkmate::check_class(code, "CodeClass")
      )

      if (inherits(code, "PythonCodeClass")) {
        self$set_vars(vars)
        self$set_code(code$get_code())
        new_df <- code$eval(dataname = self$get_dataname())

        # dataset is recreated by replacing data by mutated object
        # mutation code is added to the code which replicates the data
        self$recreate(
          x = new_df,
          vars = list()
        )
      } else {
        private$mutate_delayed(code, vars)
        if (!(private$is_any_dependency_delayed(vars) || force_delay)) {
          private$mutate_eager()
        }
      }
      logger::log_trace(
        sprintf(
          "TealDataset$mutate mutated dataset '%s' using the code (%s lines) and vars (%s).",
          self$get_dataname(),
          length(parse(text = if (inherits(code, "CodeClass")) code$get_code() else code, keep.source = FALSE)),
          paste(names(vars), collapse = ", ")
        )
      )

      return(invisible(self))
    },

    # ___ check ====
    #' @description
    #' Check to determine if the raw data is reproducible from the `get_code()` code.
    #' @return
    #' `TRUE` if the dataset generated from evaluating the
    #' `get_code()` code is identical to the raw data, else `FALSE`.
    check = function() {
      logger::log_trace(
        "TealDataset$check executing the code to reproduce dataset: { deparse1(self$get_dataname()) }..."
      )
      if (!checkmate::test_character(self$get_code(), len = 1, pattern = "\\w+")) {
        stop(
          sprintf(
            "Cannot check preprocessing code of '%s' - code is empty.",
            self$get_dataname()
          )
        )
      }

      new_set <- private$execute_code(
        code = self$get_code_class(),
        vars = c(
          list(), # list() in the beginning to ensure c.list
          private$vars,
          setNames(list(self), self$get_dataname())
        )
      )

      res_check <- tryCatch(
        {
          identical(self$get_raw_data(), new_set)
        },
        error = function(e) {
          FALSE
        }
      )
      logger::log_trace("TealDataset$check { deparse1(self$get_dataname()) } reproducibility result: { res_check }.")

      return(res_check)
    },
    #' @description
    #' Check if keys has been specified correctly for dataset. Set of `keys`
    #' should distinguish unique rows or be `character(0)`.
    #'
    #' @return `TRUE` if dataset has been already pulled, else `FALSE`
    check_keys = function(keys = private$.keys) {
      if (length(keys) > 0) {
        if (!all(keys %in% self$get_colnames())) {
          stop("Primary keys specifed for ", self$get_dataname(), " do not exist in the data.")
        }

        duplicates <- get_key_duplicates(self$get_raw_data(), keys)
        if (nrow(duplicates) > 0) {
          stop(
            "Duplicate primary key values found in the dataset '", self$get_dataname(), "' :\n",
            paste0(utils::capture.output(print(duplicates))[-c(1, 3)], collapse = "\n"),
            call. = FALSE
          )
        }
      }
      logger::log_trace("TealDataset$check_keys keys checking passed for dataset: { deparse1(self$get_dataname()) }.")
    },
    #' @description
    #' Check if dataset has already been pulled.
    #'
    #' @return `TRUE` if dataset has been already pulled, else `FALSE`
    is_pulled = function() {
      return(TRUE)
    }
  ),
  ## __Private Fields ====
  private = list(
    .raw_data = data.frame(),
    metadata = NULL,
    dataname = character(0),
    code = NULL, # CodeClass after initialization
    vars = list(),
    var_r6 = list(),
    dataset_label = character(0),
    .keys = character(0),
    mutate_code = list(),
    mutate_vars = list(),

    ## __Private Methods ====
    mutate_delayed = function(code, vars) {
      private$set_vars_internal(vars, is_mutate_vars = TRUE)
      private$mutate_code[[length(private$mutate_code) + 1]] <- list(code = code, deps = names(vars))
      logger::log_trace(
        sprintf(
          "TealDatasetConnector$mutate_delayed set the code (%s lines) and vars (%s) for dataset: %s.",
          length(parse(text = if (inherits(code, "CodeClass")) code$get_code() else code, keep.source = FALSE)),
          paste(names(vars), collapse = ", "),
          self$get_dataname()
        )
      )
      return(invisible(self))
    },
    mutate_eager = function() {
      logger::log_trace(
        "TealDatasetConnector$mutate_eager executing mutate code for dataset: { deparse1(self$get_dataname()) }..."
      )
      new_df <- private$execute_code(
        code = private$mutate_list_to_code_class(),
        vars = c(
          list(), # list() in the beginning to ensure c.list
          private$vars,
          # if they have the same name, then they are guaranteed to be identical objects.
          private$mutate_vars[!names(private$mutate_vars) %in% names(private$vars)],
          setNames(list(self), self$get_dataname())
        )
      )

      # code set after successful evaluation
      # otherwise code != dataset
      # private$code$append(private$mutate_code) # nolint
      private$append_mutate_code()
      self$set_vars(private$mutate_vars)
      private$mutate_code <- list()
      private$mutate_vars <- list()

      # dataset is recreated by replacing data by mutated object
      # mutation code is added to the code which replicates the data
      # because new_code contains also code of the
      new_self <- self$recreate(
        x = new_df,
        vars = list()
      )

      logger::log_trace(
        "TealDatasetConnector$mutate_eager executed mutate code for dataset: { deparse1(self$get_dataname()) }."
      )

      new_self
    },

    # need to have a custom deep_clone because one of the key fields are reference-type object
    # in particular: code is a R6 object that wouldn't be cloned using default clone(deep = T)
    deep_clone = function(name, value) {
      deep_clone_r6(name, value)
    },
    get_class_colnames = function(class_type = "character") {
      checkmate::assert_string(class_type)
      return_cols <- self$get_colnames()[which(vapply(
        lapply(self$get_raw_data(), class),
        function(x, target_class_name) any(x %in% target_class_name),
        logical(1),
        target_class_name = class_type
      ))]

      return(return_cols)
    },
    mutate_list_to_code_class = function() {
      res <- CodeClass$new()
      for (mutate_code in private$mutate_code) {
        if (inherits(mutate_code$code, "CodeClass")) {
          res$append(mutate_code$code)
        } else {
          res$set_code(
            code = mutate_code$code,
            dataname = private$dataname,
            deps = mutate_code$deps
          )
        }
      }
      return(res)
    },
    append_mutate_code = function() {
      for (mutate_code in private$mutate_code) {
        if (inherits(mutate_code$code, "CodeClass")) {
          private$code$append(mutate_code$code)
        } else {
          private$code$set_code(
            code = mutate_code$code,
            dataname = private$dataname,
            deps = mutate_code$deps
          )
        }
      }
    },
    is_any_dependency_delayed = function(vars = list()) {
      any(vapply(
        c(list(), private$var_r6, vars),
        FUN.VALUE = logical(1),
        FUN = function(var) {
          if (inherits(var, "TealDatasetConnector")) {
            !var$is_pulled() || var$is_mutate_delayed()
          } else if (inherits(var, "TealDataset")) {
            var$is_mutate_delayed()
          } else {
            FALSE
          }
        }
      ))
    },

    # Set variables which code depends on
    # @param vars (`named list`) contains any R object which code depends on
    # @param is_mutate_vars (`logical(1)`) whether this var is used in mutate code
    set_vars_internal = function(vars, is_mutate_vars = FALSE) {
      checkmate::assert_flag(is_mutate_vars)
      checkmate::assert_list(vars, min.len = 0, names = "unique")

      total_vars <- c(list(), private$vars, private$mutate_vars)

      if (length(vars) > 0) {
        # not allowing overriding variable names
        over_rides <- names(vars)[vapply(
          names(vars),
          FUN.VALUE = logical(1),
          FUN = function(var_name) {
            var_name %in% names(total_vars) &&
              !identical(total_vars[[var_name]], vars[[var_name]])
          }
        )]
        if (length(over_rides) > 0) {
          stop(paste("Variable name(s) already used:", paste(over_rides, collapse = ", ")))
        }
        if (is_mutate_vars) {
          private$mutate_vars <- c(
            private$mutate_vars[!names(private$mutate_vars) %in% names(vars)],
            vars
          )
        } else {
          private$vars <- c(
            private$vars[!names(private$vars) %in% names(vars)],
            vars
          )
        }
      }
      # only adding dependencies if checks passed
      private$set_var_r6(vars)
      return(invisible(NULL))
    },

    # Evaluate script code to modify data or to reproduce data
    #
    # Evaluate script code to modify data or to reproduce data
    # @param vars (named `list`) additional pre-requisite vars to execute code
    # @return (`environment`) which stores modified `x`
    execute_code = function(code, vars = list()) {
      stopifnot(inherits(code, "CodeClass"))
      checkmate::assert_list(vars, min.len = 0, names = "unique")

      execution_environment <- new.env(parent = parent.env(globalenv()))

      # set up environment for execution
      for (vars_idx in seq_along(vars)) {
        var_name <- names(vars)[[vars_idx]]
        var_value <- vars[[vars_idx]]
        if (inherits(var_value, "TealDatasetConnector") || inherits(var_value, "TealDataset")) {
          var_value <- get_raw_data(var_value)
        }
        assign(envir = execution_environment, x = var_name, value = var_value)
      }

      # execute
      code$eval(envir = execution_environment)

      if (!is.data.frame(execution_environment[[self$get_dataname()]])) {
        out_msg <- sprintf(
          "\n%s\n\n - Code from %s need to return a data.frame assigned to an object of dataset name.",
          self$get_code(),
          self$get_dataname()
        )

        rlang::with_options(
          .expr = stop(out_msg, call. = FALSE),
          warning.length = max(min(8170, nchar(out_msg) + 30), 100)
        )
      }

      new_set <- execution_environment[[self$get_dataname()]]

      return(new_set)
    },

    # Set the name for the dataset
    # @param `dataname` (`character`) the new name
    # @return self invisibly for chaining
    set_dataname = function(dataname) {
      check_simple_name(dataname)
      private$dataname <- dataname
      return(invisible(self))
    },
    set_var_r6 = function(vars) {
      checkmate::assert_list(vars, min.len = 0, names = "unique")
      for (varname in names(vars)) {
        var <- vars[[varname]]

        if (inherits(var, "TealDatasetConnector") || inherits(var, "TealDataset")) {
          var_deps <- var$get_var_r6()
          var_deps[[varname]] <- var
          for (var_dep_name in names(var_deps)) {
            var_dep <- var_deps[[var_dep_name]]
            if (identical(self, var_dep)) {
              stop("Circular dependencies detected")
            }
            private$var_r6[[var_dep_name]] <- var_dep
          }
        }
      }
      return(invisible(self))
    }
  ),
  ## __Active Fields ====
  active = list(
    #' @field raw_data The data.frame behind this R6 class
    raw_data = function() {
      private$.raw_data
    },
    #' @field data The data.frame behind this R6 class
    data = function() {
      private$.raw_data
    },
    #' @field var_names The column names of the data
    var_names = function() {
      colnames(private$.raw_data)
    }
  )
)

## Constructors ====

#' Constructor for [`TealDataset`] class
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param dataname (`character`) a given name for the dataset, it cannot contain spaces
#'
#' @param x (`data.frame` or `MultiAssayExperiment`) object from which the dataset will be created
#'
#' @param keys optional, (`character`) vector with primary keys
#'
#' @param code (`character`) a character string defining the code needed to
#'   produce the data set in `x`
#'
#' @param label (`character`) label to describe the dataset
#'
#' @param vars (named `list`) in case when this object code depends on other `TealDataset`
#'   object(s) or other constant value, this/these object(s) should be included as named
#'   element(s) of the list. For example if this object code needs `ADSL`
#'   object we should specify `vars = list(ADSL = <adsl object>)`.
#'   It's recommended to include `TealDataset` or `TealDatasetConnector` objects to
#'   the `vars` list to preserve reproducibility. Please note that `vars`
#'   are included to this object as local `vars` and they cannot be modified
#'   within another dataset.
#'
#' @param metadata (named `list` or `NULL`) field containing metadata about the dataset.
#'   Each element of the list should be atomic and length one.
#'
#' @return [`TealDataset`] object
#'
#' @rdname dataset
#'
#' @export
#'
#' @examples
#' # Simple example
#' dataset("iris", iris)
#'
#' # Example with more arguments
#' \dontrun{
#' ADSL <- teal.data::example_cdisc_data("ADSL")
#' ADSL_dataset <- dataset(dataname = "ADSL", x = ADSL)
#'
#' ADSL_dataset$get_dataname()
#'
#' ADSL_dataset <- dataset(
#'   dataname = "ADSL",
#'   x = ADSL,
#'   label = "AdAM subject-level dataset",
#'   code = "ADSL <- teal.data::example_cdisc_data(\"ADSL\")"
#' )
#' ADSL_dataset$get_metadata()
#' ADSL_dataset$get_dataset_label()
#' ADSL_dataset$get_code()
#' }
dataset <- function(dataname,
                    x,
                    keys = character(0),
                    label = data_label(x),
                    code = character(0),
                    vars = list(),
                    metadata = NULL) {
  UseMethod("dataset", x)
}

#' @rdname dataset
#' @export
dataset.data.frame <- function(dataname,
                               x,
                               keys = character(0),
                               label = data_label(x),
                               code = character(0),
                               vars = list(),
                               metadata = NULL) {
  checkmate::assert_string(dataname)
  checkmate::assert_data_frame(x)
  checkmate::assert(
    checkmate::check_character(code, max.len = 1, any.missing = FALSE),
    checkmate::check_class(code, "CodeClass")
  )
  checkmate::assert_list(vars, min.len = 0, names = "unique")

  TealDataset$new(
    dataname = dataname,
    x = x,
    keys = keys,
    code = code,
    label = label,
    vars = vars,
    metadata = metadata
  )
}

#' Load `TealDataset` object from a file
#'
#' @description `r lifecycle::badge("experimental")`
#' Please note that the script has to end with a call creating desired object. The error will be raised otherwise.
#'
#' @param path (`character`) string giving the pathname of the file to read from.
#' @param code (`character`) reproducible code to re-create object
#'
#' @return `TealDataset` object
#'
#' @export
#'
#' @examples
#' # simple example
#' file_example <- tempfile(fileext = ".R")
#' writeLines(
#'   text = c(
#'     "library(teal.data)
#'      dataset(dataname = \"iris\",
#'              x = iris,
#'              code = \"iris\")"
#'   ),
#'   con = file_example
#' )
#' x <- dataset_file(file_example, code = character(0))
#' get_code(x)
#'
#' # custom code
#' file_example <- tempfile(fileext = ".R")
#' writeLines(
#'   text = c(
#'     "library(teal.data)
#'
#'      # code>
#'      x <- iris
#'      x$a1 <- 1
#'      x$a2 <- 2
#'
#'      # <code
#'      dataset(dataname = \"iris_mod\", x = x)"
#'   ),
#'   con = file_example
#' )
#' x <- dataset_file(file_example)
#' get_code(x)
dataset_file <- function(path, code = get_code(path)) {
  object <- object_file(path, "TealDataset")
  object$set_code(code)
  return(object)
}

#' S3 generic for `to_relational_data` function.
#'
#' This function takes an object and converts into a `TealData` object, the primary data
#' object for use in teal applications.
#'
#' @param data `TealDataset`, `TealDatasetConnector`, `data.frame`, `MultiAssayExperiment`,  `list`
#' or `function` returning a named list.
#'
#' @details Passing a `TealData` into this function leaves the object unchanged.
#'
#' @return `TealData` object
#'
#' @examples
#'
#' to_relational_data(head(iris))
#' to_relational_data(dataset("IRIS", head(iris)))
#' to_relational_data(list(iris = head(iris), mtcars = head(mtcars)))
#'
#' d_connector <- dataset_connector("iris", callable_function(function() head(iris)))
#' d_connector$pull()
#' to_relational_data(d_connector)
#'
#' @keywords internal
#' @export
to_relational_data <- function(data) {
  UseMethod("to_relational_data")
}

#' @keywords internal
#' @export
to_relational_data.data.frame <- function(data) { # nolint
  dataname <- deparse(substitute(data, parent.frame()), width.cutoff = 500L)

  if (grepl("\\)$", dataname) && inherits(data, "data.frame")) {
    stop("Single data.frame shouldn't be provided as a result of a function call. Please name
         the object first or use a named list.")
  }

  if (dataname %in% names(default_cdisc_keys)) {
    cdisc_data(cdisc_dataset(dataname, data))
  } else {
    teal_data(dataset(dataname, data))
  }
}

#' @keywords internal
#' @export
to_relational_data.TealDataset <- function(data) {
  dataname <- get_dataname(data)

  if (dataname %in% names(default_cdisc_keys)) {
    cdisc_data(data)
  } else {
    teal_data(data)
  }
}

#' @keywords internal
#' @export
to_relational_data.TealDatasetConnector <- function(data) { # nolint
  to_relational_data.TealDataset(data)
}

#' @keywords internal
#' @export
to_relational_data.list <- function(data) {
  checkmate::assert_list(
    data,
    types = c("dataset", "data.frame", "MultiAssayExperiment", "TealDataset", "TealDatasetConnector")
  )

  call <- substitute(data, parent.frame())
  list_names <- names(data)
  parsed_names <- as.character(call)[-1]

  if (
    (
      length(list_names) == 0 &&
        length(parsed_names) == 0 &&
        any(sapply(data, inherits, c("dataset", "data.frame", "MultiAssayExperiment")))
    ) ||
      (any(list_names == "") && length(parsed_names) == 0) ||
      (any(is.na(list_names)))
  ) {
    stop("Unnamed lists shouldn't be provided as input for data. Please use a named list.")
  }

  datasets_list <- lapply(
    seq_along(data),
    function(idx) {
      if (is.data.frame(data[[idx]]) || inherits(data[[idx]], "MultiAssayExperiment")) {
        dataname <- if (length(list_names) == 0 || list_names[[idx]] == "") {
          parsed_names[[idx]]
        } else {
          list_names[[idx]]
        }

        if (dataname %in% names(default_cdisc_keys)) {
          cdisc_dataset(dataname, data[[idx]])
        } else {
          dataset(dataname, data[[idx]])
        }
      } else if (inherits(data[[idx]], "TealDataset") || inherits(data[[idx]], "TealDatasetConnector")) {
        data[[idx]]
      } else {
        stop("Unknown class to create TealDataset from.")
      }
    }
  )

  if (any(sapply(datasets_list, function(x) inherits(x, "CDISCTealDataset")))) {
    do.call("cdisc_data", args = datasets_list)
  } else {
    do.call("teal_data", args = datasets_list)
  }
}

#' @keywords internal
#' @export
to_relational_data.MultiAssayExperiment <- function(data) { # nolint
  teal_data(dataset("MAE", data))
}

#' @keywords internal
#' @export
to_relational_data.TealData <- function(data) { # nolint
  data
}

#' Get dataset primary keys
#'
#' @description `r lifecycle::badge("stable")`
#' Get dataset primary keys
#'
#' @param x an object of `TealDataset` or `TealDatasetConnector` class
#' @param dataname (`character`) name of dataset to return keys for
#' @param ... not used, only for support of S3
#'
#' @return (`character`) vector of column names
#'
#' @export
get_keys <- function(x, ...) {
  UseMethod("get_keys")
}

#' @rdname get_keys
#' @export
#' @examples
#' # TealDataset --------
#'
#' get_keys(
#'   dataset(
#'     "ADSL",
#'     teal.data::example_cdisc_data("ADSL"),
#'     keys = get_cdisc_keys("ADSL"),
#'     code = "ADSL <- teal.data::example_cdisc_data(\"ADSL\")"
#'   )
#' )
get_keys.TealDataset <- function(x, ...) {
  check_ellipsis(...)
  x$get_keys()
}

#' @rdname get_keys
#' @export
#' @examples
#' # TealDatasetConnector --------
#' library(magrittr)
#' pull_fun_adsl <- callable_function(teal.data::example_cdisc_data) %>%
#'   set_args(list(dataname = "ADAE"))
#' get_keys(
#'   dataset_connector(
#'     "ADSL",
#'     pull_fun_adsl,
#'     keys = get_cdisc_keys("ADSL"),
#'   )
#' )
get_keys.TealDatasetConnector <- function(x, ...) {
  check_ellipsis(...)
  x$get_keys()
}

#' @rdname get_keys
#' @export
#' @examples
#' # TealData --------
#'
#' get_keys(
#'   teal_data(
#'     dataset("x", data.frame(x1 = 1:10, y1 = 11:20), keys = "x1"),
#'     dataset("y", data.frame(x2 = 1:10, y2 = 11:20), keys = "x2")
#'   ),
#'   "x"
#' )
get_keys.TealDataAbstract <- function(x, dataname, ...) {
  check_ellipsis(...)
  get_keys(x$get_items(dataname))
}



#' Set dataset primary keys
#'
#' @description `r lifecycle::badge("stable")`
#' Set dataset primary keys
#'
#' @param x an object of `TealDataset` or `TealDatasetConnector` class
#' @param keys optional, (`character`) vector with primary keys
#' @param dataname (`character`) name of dataset for which set the keys
#' @param ... not used, only for support of S3
#'
#' @return (`character`) vector of column names
#'
#' @export
set_keys <- function(x, ...) {
  UseMethod("set_keys")
}

#' @rdname set_keys
#' @export
#' @examples
#' # TealDataset --------
#'
#' set_keys(
#'   dataset(
#'     "DF",
#'     data.frame(ID = 1:10, x = runif(10))
#'   ),
#'   keys = c("ID")
#' )
set_keys.TealDataset <- function(x, keys, ...) {
  check_ellipsis(...)
  x$set_keys(keys)
}

#' @rdname set_keys
#' @export
#' @examples
#' # TealDatasetConnector --------
#'
#' pull_fun <- callable_function(
#'   function() {
#'     data.frame(ID = 1:10, x = runif(10))
#'   }
#' )
#' set_keys(
#'   dataset_connector(
#'     "DF",
#'     pull_fun
#'   ),
#'   keys = c("ID")
#' )
set_keys.TealDatasetConnector <- function(x, keys, ...) {
  check_ellipsis(...)
  x$set_keys(keys)
}

#' @rdname set_keys
#' @export
#' @examples
#' # TealData --------
#'
#' set_keys(
#'   teal_data(
#'     dataset("x", data.frame(x1 = 1:10, y1 = 11:20), keys = "x1"),
#'     dataset("y", data.frame(x2 = 1:10, y2 = 11:20), keys = "x2")
#'   ),
#'   "x",
#'   c("x1", "y1")
#' )
set_keys.TealDataAbstract <- function(x, dataname, keys, ...) {
  check_ellipsis(...)
  set_keys(x$get_items(dataname), keys = keys)
  return(invisible(x))
}

#' Ensure the ellipsis, ..., in method arguments are empty
#'
#' Ellipsis, ..., are needed as part of method arguments to allow for its arguments to be different from its generic's
#' arguments and for this to pass check(). Hence, ..., should always be empty. This function will check for this
#' condition.
#'
#' @param ... it should literally just be ...
#' @param stop TRUE to raise an error; FALSE will output warning message
#' @param allowed_args character vector naming arguments that are allowed in the \code{...}.
#'   to allow for unnamed arguments, let "" be one of the elements in this character vector.
#'
#' @return \code{NULL} if ... is empty
#'
#' @keywords internal
#'
#' @examples
#' method.class <- function(a, b, c, ...) {
#'   check_ellipsis(...)
#' }
#' method.class <- function(a, b, c, ...) {
#'   check_ellipsis(..., allowed_args = c("y", "z"))
#' }
check_ellipsis <- function(..., stop = FALSE, allowed_args = character(0)) {
  if (!missing(...)) {
    checkmate::assert_flag(stop)
    checkmate::assert_character(allowed_args, min.len = 0, null.ok = TRUE, any.missing = FALSE)
    args <- list(...)
    arg_names <- names(args)
    if (is.null(arg_names)) {
      arg_names <- rep("", length(args))
    }
    extra_args <- arg_names[!is.element(arg_names, allowed_args)]
    if (length(extra_args) == 0) {
      return(invisible(NULL))
    }
    message <- paste(length(extra_args), "total unused argument(s).")

    named_extra_args <- extra_args[!vapply(extra_args, identical, logical(1), "")]
    if (length(named_extra_args) > 0) {
      message <- paste0(
        message,
        " ",
        length(named_extra_args),
        " with name(s): ",
        paste(named_extra_args, collapse = ", "),
        "."
      )
    }
    if (stop) {
      stop(message)
    } else {
      warning(message)
    }
  }
}

#' Whether the variable name is good to use within Show R Code
#'
#' Spaces are problematic because the variables must be escaped
#' with backticks.
#' Also, they should not start with a number as R may silently make
#' it valid by changing it.
#' Therefore, we only allow alphanumeric characters with underscores.
#' The first character of the `name` must be an alphabetic character
#' and can be followed by alphanumeric characters.
#'
#' @md
#'
#' @param name `character, single or vector` name to check
#' @keywords internal
#'
#' @examples
#' teal.data:::check_simple_name("aas2df")
#' teal.data:::check_simple_name("ADSL")
#' teal.data:::check_simple_name("ADSLmodified")
#' teal.data:::check_simple_name("ADSL_2")
#' teal.data:::check_simple_name("a1")
#' # the following fail
#' \dontrun{
#' teal.data:::check_simple_name("1a")
#' teal.data:::check_simple_name("ADSL.modified")
#' teal.data:::check_simple_name("ADSL_modified")
#' teal.data:::check_simple_name("a1...")
#' }
check_simple_name <- function(name) {
  checkmate::assert_character(name, min.len = 1, any.missing = FALSE)
  if (!grepl("^[[:alpha:]][a-zA-Z0-9_]*$", name, perl = TRUE)) {
    stop(
      "name '",
      name,
      "' must only contain alphanumeric characters (with underscores)",
      " and the first character must be an alphabetic character"
    )
  }
}

#' Get a [`TealDataset`] objects.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param x ([`TealData`])\cr
#'  object containing datasets.
#' @export
#' @return `list` or `TealDataset` objects
get_datasets <- function(x) {
  UseMethod("get_datasets")
}

#' @rdname get_datasets
#' @export
#' @examples
#'
#' library(magrittr)
#'
#' # TealData --------
#' adsl <- cdisc_dataset(
#'   dataname = "ADSL",
#'   x = teal.data::example_cdisc_data("ADSL"), ,
#'   code = "library(teal.data)\nADSL <- teal.data::example_cdisc_data(\"ADSL\")"
#' )
#'
#' adae <- cdisc_dataset(
#'   dataname = "ADAE",
#'   x = teal.data::example_cdisc_data("ADAE"),
#'   code = "library(teal.data)\nADAE <- teal.data::example_cdisc_data(\"ADAE\")"
#' )
#'
#' rd <- cdisc_data(adsl, adae)
#' get_datasets(rd)
#'
#' # TealDataConnector --------
#' random_data_connector <- function(dataname) {
#'   fun_dataset_connector(
#'     dataname = dataname,
#'     fun = teal.data::example_cdisc_data,
#'     fun_args = list(dataname = dataname),
#'   )
#' }
#'
#' adsl_cf <- callable_function(teal.data::example_cdisc_data) %>%
#'   set_args(list(dataname = "ADSL"))
#' adsl <- cdisc_dataset_connector(
#'   dataname = "ADSL",
#'   pull_callable = adsl_cf,
#'   keys = get_cdisc_keys("ADSL")
#' )
#' adlb_cf <- callable_function(teal.data::example_cdisc_data) %>%
#'   set_args(list(dataname = "ADLB"))
#' adlb <- cdisc_dataset_connector(
#'   dataname = "ADLB",
#'   pull_callable = adlb_cf,
#'   keys = get_cdisc_keys("ADLB")
#' )
#'
#' rdc <- relational_data_connector(
#'   connection = data_connection(),
#'   connectors = list(adsl, adlb)
#' )
#'
#' rdc$set_ui(function(id, connection, connectors) p("Example UI"))
#' rdc$set_server(
#'   function(id, connection, connectors) {
#'     moduleServer(
#'       id = id,
#'       module = function(input, output, session) {
#'         # Note this is simplified as we are not opening a real connection here
#'         for (connector in connectors) {
#'           set_args(connector, args = list(name = input$name))
#'           # pull each dataset
#'           connector$get_server()(id = connector$get_dataname())
#'           if (connector$is_failed()) {
#'             break
#'           }
#'         }
#'       }
#'     )
#'   }
#' )
#' \dontrun{
#' load_datasets(rdc)
#' get_datasets(rdc)
#' }
#'
#' # TealData --------
#' \dontrun{
#' drc <- cdisc_data(rdc, adae)
#' get_datasets(drc)
#' }
get_datasets.TealDataAbstract <- function(x) { # nolint
  res <- x$get_datasets()
  if (length(res) == 0) {
    return(invisible(NULL))
  }
  res
}

#' @rdname get_datasets
#' @export
#' @examples
#'
#' # TealDatasetConnector --------
#' adsl_cf <- callable_function(teal.data::example_cdisc_data) %>%
#'   set_args(list(dataname = "ADSL"))
#' rdc <- cdisc_dataset_connector("ADSL", adsl_cf, keys = get_cdisc_keys("ADSL"))
#' \dontrun{
#' load_datasets(rdc)
#' get_datasets(rdc)
#' }
get_datasets.TealDatasetConnector <- function(x) { # nolint
  res <- x$get_dataset()
  if (length(res) == 0) {
    return(invisible(NULL))
  }
  res
}

#' @rdname get_datasets
#' @export
#' @examples
#'
#' # TealDataset --------
#' adsl <- cdisc_dataset(
#'   dataname = "ADSL",
#'   x = teal.data::example_cdisc_data("ADSL"),
#'   code = "library(teal.data)\nADSL <- example_cdisc_data(\"ADSL\")"
#' )
#'
#' get_datasets(adsl)
get_datasets.TealDataset <- function(x) {
  x
}

#' Mutate dataset by code
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' @param x (`TealDataset`)\cr
#'    object.
#' @param dataname (`character`)\cr
#'   `Dataname` to be mutated.
#' @param code (`character`)\cr
#'   Code to mutate the dataset. Must contain the `dataset$dataname`. Or can also be an object
#'   of class `PythonCodeClass` returned by [`python_code`].
#' @param script (`character`)\cr
#'   file that contains R Code that can be read using [`read_script`].
#'   Preferred before `code` argument.
#' @param vars (named `list`)) \cr
#'   In case when this object code depends on other `TealDataset` object(s) or
#'   other constant value, this/these object(s) should be included as named
#'   element(s) of the list. For example if this object code needs `ADSL`
#'   object we should specify `vars = list(ADSL = <adsl object>)`.
#'   It's recommended to include `TealDataset` or `TealDatasetConnector` objects to
#'   the `vars` list to preserve reproducibility. Please note that `vars`
#'   are included to this object as local `vars` and they cannot be modified
#'   within another dataset.
#' @param ... not used, only for support of S3
#'
#' @return modified `x` object
#'
#' @export
mutate_dataset <- function(x, ...) {
  UseMethod("mutate_dataset")
}

#' @rdname mutate_dataset
#' @examples
#' library(magrittr)
#'
#' ADSL <- teal.data::example_cdisc_data("ADSL")
#'
#' ADSL_dataset <- dataset(
#'   dataname = "ADSL",
#'   x = ADSL,
#'   label = "AdAM subject-level dataset",
#'   code = "ADSL <- teal.data::example_cdisc_data(\"ADSL\")"
#' )
#' ADSL_mutated <- ADSL_dataset %>%
#'   mutate_dataset(code = "ADSL$new_variable <- 1")
#'
#' ADSL_mutated$get_raw_data()$new_variable[1]
#'
#' # Use an R script to mutate the data
#' file_example <- tempfile(fileext = ".R")
#' writeLines(
#'   text = c(
#'     "ADSL <- ADSL %>%
#'       dplyr::mutate(new_variable = new_variable * 2)"
#'   ),
#'   con = file_example
#' )
#'
#' ADSL_mutated <- ADSL_mutated %>%
#'   mutate_dataset(script = file_example)
#'
#' ADSL_mutated$get_raw_data()$new_variable[1]
#'
#' ADSL_mutated <- ADSL_mutated %>%
#'   mutate_dataset(code = read_script(file_example))
#'
#' ADSL_mutated$get_raw_data()$new_variable[1]
#' @export
mutate_dataset.TealDataset <- function(x,
                                       code = character(0),
                                       script = character(0),
                                       vars = list(),
                                       ...) {
  check_ellipsis(...)
  checkmate::assert_list(vars, min.len = 0, names = "unique")

  code <- code_from_script(code, script)
  x$mutate(code = code, vars = vars, ...)
}


#' @rdname mutate_dataset
#' @export
mutate_dataset.TealDatasetConnector <- function(x, # nolint
                                                code = character(0),
                                                script = character(0),
                                                vars = list(),
                                                ...) {
  check_ellipsis(...)
  checkmate::assert_list(vars, min.len = 0, names = "unique")
  code <- code_from_script(code, script)
  x$mutate(code = code, vars = vars, ...)
}


#' @rdname mutate_dataset
#' @export
mutate_dataset.TealDataAbstract <- function(x,
                                            dataname,
                                            code = character(0),
                                            script = character(0),
                                            vars = list(),
                                            ...) {
  check_ellipsis(...)
  checkmate::assert_list(vars, min.len = 0, names = "unique")

  code <- code_from_script(code, script)
  x$mutate_dataset(dataname = dataname, code = code, vars = vars)
}



#' Mutate data by code
#'
#' @description `r lifecycle::badge("experimental")`
#' Code used in this mutation is not linked to particular
#' but refers to all datasets.
#' Consequence of this is that when using `get_code(<dataset>)` this
#' part of the code will be returned for each dataset specified. This method
#' should be used only if particular call involve changing multiple datasets.
#' Otherwise please use `mutate_dataset`.
#' Execution of the code is delayed after datasets are pulled
#' (`isTRUE(is_pulled)`).
#'
#' @param x (`TealDataAbstract`)\cr
#'   object.
#' @inheritParams mutate_dataset
#'
#' @return modified `x` object
#'
#' @export
mutate_data <- function(x,
                        code = character(0),
                        script = character(0),
                        vars = list()) {
  UseMethod("mutate_data")
}

#' @rdname mutate_data
#' @export
mutate_data.TealDataAbstract <- function(x,
                                         code = character(0),
                                         script = character(0),
                                         vars = list()) {
  checkmate::assert_list(vars, min.len = 0, names = "unique")

  code <- code_from_script(code, script)
  x$mutate(code = code, vars = vars)
  return(invisible(x))
}

## CallableCode ====
#'
#' @title A \code{CallableCode} class of objects
#'
#' @description `r lifecycle::badge("stable")`
#' Object that stores code to reproduce an object. It includes methods to
#' get or run the code and return the object.
#'
CallableCode <- R6::R6Class( # nolint
  "CallableCode",
  inherit = Callable,

  ## __Public Methods ====
  public = list(
    #' @description
    #'  Create a new \code{CallableCode} object
    #'
    #' @param code (\code{character})\cr
    #'  a string containing R code to reproduce the desired object.
    #' @param env (\code{environment})\cr
    #'  environment where function will be evaluated
    #'
    #' @return new \code{CallableCode} object
    initialize = function(code, env = new.env(parent = parent.env(globalenv()))) {
      if (!checkmate::test_string(code)) {
        stop("A string of length one containing the code needed to produce the object must be provided.")
      }

      # reposition all library calls in the code so that they are
      # visible in the new env
      env$library <- function(...) {
        mc <- match.call()
        mc[[1]] <- quote(base::library)
        eval(mc, envir = globalenv())
        this_env <- parent.frame()

        if (!identical(this_env, globalenv())) {
          parent.env(this_env) <- parent.env(globalenv())
        }
      }

      super$initialize(env = env)

      private$code <- code
      private$call <- private$get_callable_code(code)
      logger::log_trace("CallableCode initialized.")

      return(invisible(self))
    },
    #' @description
    #'  Get sequence of calls from the code supplied to produce the object.
    #'
    #' @param deparse (\code{logical} value)\cr
    #'  whether to return a deparsed version of call
    #' @param args (\code{NULL})\cr
    #'  available to be consistent with \code{CallableFunction} but are not used to
    #'  retrieve the call.
    #'
    #' @return \code{list} of \code{calls} or \code{character} depending on \code{deparse} argument
    get_call = function(deparse = TRUE, args = NULL) {
      checkmate::assert_flag(deparse)
      if (!is.null(args)) {
        stop("'args' are not used to retrieve the call.")
      }

      res <- if (deparse) {
        paste0(vapply(private$call, deparse1, character(1)), collapse = "\n")
      } else {
        private$call
      }

      return(res)
    }
  ),

  ## __Private Fields ====
  private = list(
    code = NULL,
    ## __Private Methods ====
    # @description
    #  Determines whether code is valid and callable. If not then stores error message.
    #
    # @param code \code{character} string to check
    #
    # @return \code{expression} parsed from the supplied code
    #
    get_callable_code = function(code) {
      expr <- tryCatch(
        str2expression(code),
        error = function(e) {
          private$error_msg <- e$message
          private$failed <- TRUE
        }
      )
      if (length(expr) >= 1 && !private$failed) {
        return(expr)
      } else {
        stop(paste("Code supplied is not valid:", private$error_msg))
      }
    }
  )
)

## Constructors ====

#' Create \code{\link{CallableCode}} object
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Create \link{CallableCode} object to execute specific code and get reproducible call.
#'
#' @param code (\code{character})\cr
#'   a string containing R code to reproduce the desired object. Please be aware
#'   that objects assigned to temporary environment are locked which means
#'   that they can't be modified.
#'
#' @return \code{CallableCode} object
#'
#' @export
#'
#' @examples
#' cf <- callable_code(code = "mtcars")
#' cf$run()
#' cf$get_call()
callable_code <- function(code) {
  CallableCode$new(code)
}

#' S3 method for getting a `dataname(s)` of
#' (`TealDataAbstract`, (`TealDatasetConnector` or
#' `TealDataset`) R6 object
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param x (`TealDataAbstract`, `TealDatasetConnector` or
#' `TealDataset`) object
#'
#' @return `dataname` (`character`) A given name for the dataset(s)
#'   it may not contain spaces
#' @export
get_dataname <- function(x) {
  UseMethod("get_dataname")
}

#' @rdname get_dataname
#' @export
get_dataname.TealDataAbstract <- function(x) { # nolint
  return(x$get_datanames())
}

#' @rdname get_dataname
#' @export
get_dataname.TealDatasetConnector <- function(x) { # nolint
  return(x$get_dataname())
}


#' @rdname get_dataname
#' @export
get_dataname.TealDataset <- function(x) { # nolint
  return(x$get_dataname())
}

#' Is pulled
#'
#' @description `r lifecycle::badge("stable")`
#'   S3 method to determine if dataset is pulled (loaded).
#'
#' @param x ([`TealDatasetConnector`], [`TealDataset`] or [`TealDataAbstract`])
#'
#' @return (`logical`) `TRUE` if connector has been already pulled, else `FALSE`.
#' @export
is_pulled <- function(x) {
  UseMethod("is_pulled")
}

#' @rdname is_pulled
#' @export
#'
#' @examples
#' # TealDatasetConnector --------
#' library(magrittr)
#' pull_fun_adsl <- callable_function(teal.data::example_cdisc_data) %>%
#'   set_args(list(dataname = "ADSL"))
#' x <- dataset_connector("ADSL", pull_fun_adsl)
#'
#' is_pulled(x)
#'
#' load_dataset(x)
#' is_pulled(x)
is_pulled.TealDatasetConnector <- function(x) {
  return(x$is_pulled())
}

#' @rdname is_pulled
#' @export
#'
#' @examples
#' # TealDataset --------
#' x <- dataset(
#'   dataname = "XY",
#'   x = data.frame(x = c(1, 2), y = c("a", "b"), stringsAsFactors = FALSE),
#'   keys = "y",
#'   code = "XY <- data.frame(x = c(1, 2), y = c('aa', 'bb'),
#'                            stringsAsFactors = FALSE)"
#' )
#'
#' is_pulled(x)
is_pulled.TealDataset <- function(x) {
  return(x$is_pulled())
}

#' @rdname is_pulled
#' @export
#'
#' @examples
#'
#' library(magrittr)
#'
#' # TealData --------
#' x1 <- dataset(
#'   x = teal.data::example_cdisc_data("ADSL"),
#'   dataname = "ADSL",
#'   keys = get_cdisc_keys("ADSL"),
#'   code = "ADSL <- teal.data::example_cdisc_data(\"ADSL\")",
#'   label = "ADTTE dataset"
#' )
#'
#' x2 <- dataset(
#'   x = teal.data::example_cdisc_data("ADTTE"),
#'   dataname = "ADTTE",
#'   keys = get_cdisc_keys("ADTTE"),
#'   code = "ADTTE <- teal.data::example_cdisc_data(\"ADTTE\")",
#'   label = "ADTTE dataset"
#' )
#'
#' rd <- teal_data(x1, x2)
#' is_pulled(rd)
#'
#' # TealDataConnector --------
#' adsl_cf <- callable_function(teal.data::example_cdisc_data) %>%
#'   set_args(list(dataname = "ADSL"))
#' adsl <- cdisc_dataset_connector(
#'   dataname = "ADSL",
#'   pull_callable = adsl_cf,
#'   keys = get_cdisc_keys("ADSL")
#' )
#'
#' new_cf <- callable_function(function(x) {
#'   x$NEW <- 1:nrow(x)
#'   x
#' })
#' new_cf$set_args(list(x = as.name("x")))
#' new <- cdisc_dataset_connector(
#'   dataname = "NEW",
#'   pull_callable = new_cf,
#'   keys = get_cdisc_keys("ADSL"),
#'   vars = list(x = adsl)
#' )
#'
#' rdc <- cdisc_data(adsl, new)
#'
#' is_pulled(rdc)
#' \dontrun{
#' load_datasets(rdc)
#' is_pulled(rdc)
#' }
is_pulled.TealDataAbstract <- function(x) { # nolint
  return(x$is_pulled())
}

#' Set arguments of a `CallableFunction`
#'
#' @description `r lifecycle::badge("stable")`
#' Set arguments of a `CallableFunction`
#'
#' @param x `CallableFunction` or `TealDatasetConnector`)
#' @param args (`NULL` or named `list`) dynamic arguments to function
#'
#' @return nothing
#' @rdname set_args
#' @export
set_args <- function(x, args) {
  UseMethod("set_args")
}

#' @rdname set_args
#' @export
#' @examples
#' ## Using CallableFunction
#' fun <- callable_function(example_cdisc_data)
#' set_args(fun, list(dataname = "ADSL"))
set_args.CallableFunction <- function(x, args) {
  x$set_args(args)
  return(invisible(x))
}

#' @rdname set_args
#' @export
#' @examples
#' ## Using CallableCode
#' code <- callable_code("example_cdisc_data()")
#' set_args(code, list(df = "adsl"))
set_args.CallableCode <- function(x, args) {
  warning(
    "'CallableCode' is unchangable. Ignoring arguments set by 'set_args'",
    call. = FALSE
  )
  return(invisible(x))
}

#' @rdname set_args
#' @export
#' @examples
#' ## Using TealDatasetConnector
#' ds <- dataset_connector("x", pull_callable = callable_function(data.frame))
#' set_args(ds, list(x = 1:5, y = letters[1:5]))
set_args.TealDatasetConnector <- function(x, args) {
  x$set_args(args)
  return(invisible(x))
}

#' S3 method for getting a label of
#' (`TealDatasetConnector` or `TealDataset`) R6 object
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param x (`TealDatasetConnector` or `TealDataset`) R6 object
#'
#' @return label (`character`) Label to describe the dataset
#' @export
get_dataset_label <- function(x) {
  UseMethod("get_dataset_label")
}

#' @rdname get_dataset_label
#' @export
#' @examples
#' fun <- callable_function(data.frame)
#' fun$set_args(list(c1 = seq_len(10)))
#'
#' x <- dataset_connector(
#'   pull_callable = fun,
#'   dataname = "ADSL",
#'   label = "My custom label"
#' )
#' get_dataset_label(x)
get_dataset_label.TealDatasetConnector <- function(x) { # nolint
  return(x$get_dataset_label())
}

#' @rdname get_dataset_label
#' @export
#' @examples
#' ADSL <- example_cdisc_data("ADSL")
#' ADSL_dataset <- dataset(dataname = "ADSL", x = ADSL, label = "My custom label")
#' get_dataset_label(ADSL_dataset)
get_dataset_label.TealDataset <- function(x) {
  return(x$get_dataset_label())
}

#' This function returns a dummy dataset for testing examples and should only be used within `teal.data`.
#'
#' It is not meant to retrieve the SCDA dataset, and the dataset itself is not maintained here.
#'
#' This function creates a copy of the SCDA data for testing purposes.
#'
#' CDISC data includes `ADSL`, `ADAE`, `ADLB`, `ADCM`, `ADEX`, `ADRS`, `ADTR` and `ADTTE`.
#'
#' @param dataname name of the `CDISC` dataset
#'
#' @return `cdisc_data`
#'
#' @export
example_cdisc_data <- function(dataname) {
  # Define the available datasets
  datasets <- c("ADSL", "ADAE", "ADLB", "ADCM", "ADEX", "ADRS", "ADTR", "ADTTE", "ADVS")

  # Check if the provided dataname is valid
  if (dataname %in% datasets) {
    dataset <- get(paste0("r", dataname))
    return(dataset)
  } else {
    stop("Invalid dataname. Please provide one of the following: ", paste(datasets, collapse = ", "))
  }
}

#' Data input for teal app
#'
#' @description `r lifecycle::badge("stable")`
#' Function takes datasets and creates `TealData` object which can be used in `teal` applications.
#'
#' @note This function does not automatically assign keys to `TealDataset`
#' and `TealDatasetConnector` objects passed to it. If the keys are needed
#' they should be assigned before calling `cdisc_data`. See example:
#' ```
#' test_dataset <- dataset("ADAE", teal.data::example_cdisc_data("ADAE")) # does not have keys
#' test_adsl <- cdisc_dataset("ADSL", teal.data::example_cdisc_data("ADSL"))
#' test_data <- cdisc_data(test_dataset, test_adsl)
#' get_keys(test_data, "ADAE") # returns character(0)
#'
#' test_dataset <- cdisc_dataset("ADAE", teal.data::example_cdisc_data("ADAE"))
#' test_data <- cdisc_data(test_dataset, test_adsl)
#' get_keys(test_data, "ADAE") # returns [1] "STUDYID" "USUBJID" "ASTDTM"  "AETERM"  "AESEQ"
#' ```
#' @inheritParams teal_data
#' @param ... (`TealDataConnector`, `TealDataset` or
#'   `TealDatasetConnector`) elements to include.
#' @param join_keys (`JoinKeys`) or a single (`JoinKeySet`)\cr
#'   (optional) object with datasets column names used for joining.
#'   If empty then it would be automatically derived basing on intersection of datasets primary keys
#'
#' @return a `TealData` object
#'
#' @details This function checks if there were keys added to all data sets
#'
#' @export
#'
#' @examples
#'
#' ADSL <- teal.data::example_cdisc_data("ADSL")
#' ADTTE <- teal.data::example_cdisc_data("ADTTE")
#'
#' # basic example
#' cdisc_data(
#'   cdisc_dataset("ADSL", ADSL),
#'   cdisc_dataset("ADTTE", ADTTE),
#'   code = "ADSL <- teal.data::example_cdisc_data(\"ADSL\")
#'           ADTTE <- teal.data::example_cdisc_data(\"ADTTE\")",
#'   check = TRUE
#' )
#'
#' # Example with keys
#' cdisc_data(
#'   cdisc_dataset("ADSL", ADSL,
#'     keys = c("STUDYID", "USUBJID")
#'   ),
#'   cdisc_dataset("ADTTE", ADTTE,
#'     keys = c("STUDYID", "USUBJID", "PARAMCD"),
#'     parent = "ADSL"
#'   ),
#'   join_keys = join_keys(
#'     join_key(
#'       "ADSL",
#'       "ADTTE",
#'       c("STUDYID" = "STUDYID", "USUBJID" = "USUBJID")
#'     )
#'   ),
#'   code = "ADSL <- teal.data::example_cdisc_data(\"ADSL\")
#'           ADTTE <- teal.data::example_cdisc_data(\"ADTTE\")",
#'   check = TRUE
#' )
cdisc_data <- function(...,
                       join_keys = teal.data::join_keys(),
                       code = "",
                       check = FALSE) {
  data_objects <- list(...)
  checkmate::assert_list(
    data_objects,
    types = c("TealDataset", "TealDatasetConnector", "TealDataConnector")
  )
  if (inherits(join_keys, "JoinKeySet")) {
    join_keys <- teal.data::join_keys(join_keys)
  }

  update_join_keys_to_primary(data_objects, join_keys)

  retrieve_parents <- function(x) {
    tryCatch(
      x$get_parent(),
      error = function(cond) rep(character(0), length(x$get_datanames()))
    )
  }

  new_parents_fun <- function(data_objects) {
    lapply(data_objects, function(x) {
      if (inherits(x, "TealDataConnector")) {
        unlist(new_parents_fun(x$get_items()), recursive = FALSE)
      } else {
        list(retrieve_parents(x))
      }
    })
  }

  new_parents <- unlist(new_parents_fun(data_objects), recursive = FALSE)

  names(new_parents) <- unlist(lapply(data_objects, function(x) {
    if (inherits(x, "TealDataConnector")) {
      lapply(x$get_items(), function(z) z$get_dataname())
    } else {
      x$get_datanames()
    }
  }))

  if (is_dag(new_parents)) {
    stop("Cycle detected in a parent and child dataset graph.")
  }
  join_keys$set_parents(new_parents)
  join_keys$update_keys_given_parents()

  x <- TealData$new(..., check = check, join_keys = join_keys)

  if (length(code) > 0 && !identical(code, "")) {
    x$set_pull_code(code = code)
  }

  x$check_reproducibility()
  x$check_metadata()
  return(x)
}

#' Load `TealData` object from a file
#'
#' @description `r lifecycle::badge("deprecated")`
#'
#' @inheritParams teal_data_file
#'
#' @return `TealData` object
#'
#' @export
#'
#' @examples
#' file_example <- tempfile(fileext = ".R")
#' writeLines(
#'   text = c(
#'     "# code>
#'      ADSL <- teal.data::example_cdisc_data('ADSL')
#'      ADTTE <- teal.data::example_cdisc_data('ADTTE')
#'
#'      cdisc_data(
#'           cdisc_dataset(\"ADSL\", ADSL), cdisc_dataset(\"ADTTE\", ADTTE),
#'           code = \"ADSL <- teal.data::example_cdisc_data('ADSL')
#'                   ADTTE <- teal.data::example_cdisc_data('ADTTE')\",
#'           check = FALSE
#'      )
#'      # <code"
#'   ),
#'   con = file_example
#' )
#'
#' cdisc_data_file(file_example)
cdisc_data_file <- function(path, code = get_code(path)) {
  lifecycle::deprecate_warn(when = "0.1.3", what = "cdisc_data_file()", with = "teal_data_file()")
  object <- object_file(path, "TealData")
  object$mutate(code)
  return(object)
}

#' Teal data
#'
#' @description `r lifecycle::badge("stable")`
#' Universal function to pass data to teal application
#'
#' @param ... (`TealDataConnector`, `TealDataset`, `TealDatasetConnector`)\cr
#'   objects
#' @param join_keys (`JoinKeys`) or a single (`JoinKeySet`)\cr
#'   (optional) object with dataset column relationships used for joining.
#'   If empty then no joins between pairs of objects
#' @param code (`character`) code to reproduce the datasets.
#' @param check (`logical`) reproducibility check - whether to perform a check that the pre-processing
#'  code included in the object definitions actually produces those objects.
#'  If `check` is true and preprocessing code is empty an error will be thrown.
#'
#' @return (`TealData`)
#'
#' @export
#'
#' @examples
#' x1 <- dataset(
#'   "x1",
#'   iris,
#'   code = "x1 <- iris"
#' )
#'
#' x2 <- dataset(
#'   "x2",
#'   mtcars,
#'   code = "x2 <- mtcars"
#' )
#'
#' teal_data(x1, x2)
teal_data <- function(...,
                      join_keys = teal.data::join_keys(),
                      code = "",
                      check = FALSE) {
  data_objects <- list(...)
  checkmate::assert_list(
    data_objects,
    types = c("TealDataset", "TealDatasetConnector", "TealDataConnector")
  )
  if (inherits(join_keys, "JoinKeySet")) {
    join_keys <- teal.data::join_keys(join_keys)
  }

  update_join_keys_to_primary(data_objects, join_keys)

  x <- TealData$new(..., check = check, join_keys = join_keys)

  if (length(code) > 0 && !identical(code, "")) {
    x$set_pull_code(code = code)
  }

  x$check_reproducibility()
  x$check_metadata()

  return(x)
}


#' Load `TealData` object from a file
#'
#' @description `r lifecycle::badge("experimental")`
#' Please note that the script has to end with a call creating desired object. The error will be raised otherwise.
#'
#' @param path A (`connection`) or a (`character`)\cr
#'   string giving the pathname of the file or URL to read from. "" indicates the connection `stdin`.
#' @param code (`character`)\cr
#'   reproducible code to re-create object
#'
#' @return `TealData` object
#'
#'
#' @export
#'
#' @examples
#' # simple example
#' file_example <- tempfile(fileext = ".R")
#' writeLines(
#'   text = c(
#'     "library(teal.data)
#'
#'      x1 <- dataset(dataname = \"IRIS\",
#'                    x = iris,
#'                    code = \"IRIS <- iris\")
#'
#'      x2 <- dataset(dataname = \"MTCARS\",
#'                    x = mtcars,
#'                    code = \"MTCARS <- mtcars\")
#'
#'      teal_data(x1, x2)"
#'   ),
#'   con = file_example
#' )
#' teal_data_file(file_example, code = character(0))
teal_data_file <- function(path, code = get_code(path)) {
  object <- object_file(path, "TealData")
  object$mutate(code)
  return(object)
}

#' Add primary keys as join_keys to a dataset self
#'
#' @param data_objects (`list`) of `TealDataset`, `TealDatasetConnector` or `TealDataConnector` objects
#' @param join_keys (`JoinKeys`) object
#'
#' @keywords internal
update_join_keys_to_primary <- function(data_objects, join_keys) {
  lapply(data_objects, function(obj) {
    if (inherits(obj, "TealDataConnector")) {
      update_join_keys_to_primary(obj$get_items(), join_keys)
    } else {
      dataname <- obj$get_dataname()
      if (length(join_keys$get(dataname, dataname)) == 0) {
        join_keys$mutate(
          dataname,
          dataname,
          obj$get_keys()
        )
      }
    }
  })
}

## CDISCTealDataset ====
#'
#' @title R6 Class representing a dataset with parent attribute
#'
#' @description `r lifecycle::badge("stable")`
#' Any `data.frame` object can be stored inside this object.
#'
#' The difference compared to `TealDataset` class is a parent field that
#' indicates name of the parent dataset. Note that the parent field might
#' be empty (i.e. `character(0)`).
#'
#' @param dataname (`character`)\cr
#'  A given name for the dataset it may not contain spaces
#'
#' @param x (`data.frame`)\cr
#'
#' @param keys (`character`)\cr
#'   vector with primary keys
#'
#' @param parent optional, (`character`) \cr
#'   parent dataset name
#'
#' @param code (`character`)\cr
#'   A character string defining the code needed to produce the data set in `x`
#'
#' @param label (`character`)\cr
#'   Label to describe the dataset
#'
#' @param vars (named `list`)) \cr
#'   In case when this object code depends on other `TealDataset` object(s) or
#'   other constant value, this/these object(s) should be included as named
#'   element(s) of the list. For example if this object code needs `ADSL`
#'   object we should specify `vars = list(ADSL = <adsl object>)`.
#'   It is recommended to include `TealDataset` or `TealDatasetConnector` objects to
#'   the `vars` list to preserve reproducibility. Please note that `vars`
#'   are included to this object as local `vars` and they cannot be modified
#'   within another dataset.
#'
#' @param metadata (named `list` or `NULL`) \cr
#'   Field containing metadata about the dataset. Each element of the list
#'   should be atomic and length one.
#'
#' @examples
#' x <- cdisc_dataset(
#'   dataname = "XYZ",
#'   x = data.frame(x = c(1, 2), y = c("a", "b"), stringsAsFactors = FALSE),
#'   keys = "y",
#'   parent = "ABC",
#'   code = "XYZ <- data.frame(x = c(1, 2), y = c('aa', 'bb'),
#'                             stringsAsFactors = FALSE)",
#'   metadata = list(type = "example")
#' )
#'
#' x$ncol
#' x$get_code()
#' x$get_dataname()
#' x$get_keys()
#' x$get_parent()
CDISCTealDataset <- R6::R6Class( # nolint
  "CDISCTealDataset",
  inherit = TealDataset,
  ## __Public Methods ====
  public = list(
    #' @description
    #' Create a new object of `CDISCTealDataset` class
    initialize = function(dataname, x, keys, parent, code = character(0),
                          label = character(0), vars = list(), metadata = NULL) {
      checkmate::assert_character(parent, max.len = 1, any.missing = FALSE)
      super$initialize(
        dataname = dataname, x = x, keys = keys, code = code,
        label = label, vars = vars, metadata = metadata
      )

      self$set_parent(parent)
      logger::log_trace("CDISCTealDataset initialized for dataset: { deparse1(self$get_dataname()) }.")
      return(invisible(self))
    },
    #' @description
    #' Recreate a dataset with its current attributes
    #' This is useful way to have access to class initialize method basing on class object
    #'
    #' @return a new object of `CDISCTealDataset` class
    recreate = function(dataname = self$get_dataname(),
                        x = self$get_raw_data(),
                        keys = self$get_keys(),
                        parent = self$get_parent(),
                        code = private$code,
                        label = self$get_dataset_label(),
                        vars = list(),
                        metadata = self$get_metadata()) {
      res <- self$initialize(
        dataname = dataname,
        x = x,
        keys = keys,
        parent = parent,
        code = code,
        label = label,
        vars = vars,
        metadata = metadata
      )
      logger::log_trace("CDISCTealDataset$recreate recreated dataset: { deparse1(self$get_dataname()) }.")
      return(res)
    },
    #' @description
    #' Get all dataset attributes
    #' @return (named `list`) with dataset attributes
    get_attrs = function() {
      x <- super$get_attrs()
      x <- append(
        x,
        list(
          parent = self$get_parent()
        )
      )
      return(x)
    },
    #' @description
    #' Get parent dataset name
    #' @return (`character`) indicating parent `dataname`
    get_parent = function() {
      return(private$parent)
    },
    #' @description
    #' Set parent dataset name
    #' @param parent (`character`) indicating parent `dataname`
    #' @return (`self`) invisibly for chaining
    set_parent = function(parent) {
      checkmate::assert_character(parent, max.len = 1, any.missing = FALSE)
      private$parent <- parent

      logger::log_trace("CDISCTealDataset$set_parent parent set for dataset: { deparse1(self$get_dataname()) }.")
      return(invisible(self))
    }
  ),
  ## __Private Fields ====
  private = list(
    parent = character(0)
  )
)

# constructors ====
#' Create a new object of `CDISCTealDataset` class
#'
#' @description `r lifecycle::badge("stable")`
#' Function that creates `CDISCTealDataset` object
#'
#' @inheritParams dataset
#' @param parent (`character`, optional) parent dataset name
#'
#' @return (`CDISCTealDataset`) a dataset with connected metadata
#'
#' @export
#'
#' @examples
#' ADSL <- example_cdisc_data("ADSL")
#'
#' cdisc_dataset("ADSL", ADSL, metadata = list(type = "teal.data"))
cdisc_dataset <- function(dataname,
                          x,
                          keys = get_cdisc_keys(dataname),
                          parent = `if`(identical(dataname, "ADSL"), character(0), "ADSL"),
                          label = data_label(x),
                          code = character(0),
                          vars = list(),
                          metadata = NULL) {
  CDISCTealDataset$new(
    dataname = dataname,
    x = x,
    keys = keys,
    parent = parent,
    label = label,
    code = code,
    vars = vars,
    metadata = metadata
  )
}

#' Load `CDISCTealDataset` object from a file
#'
#' @description `r lifecycle::badge("experimental")`
#' Please note that the script has to end with a call creating desired object. The error will be raised otherwise.
#'
#' @inheritParams dataset_file
#'
#' @return (`CDISCTealDataset`) object
#'
#' @export
#'
#' @examples
#' # simple example
#' file_example <- tempfile(fileext = ".R")
#' writeLines(
#'   text = c(
#'     "library(teal.data)
#'      cdisc_dataset(dataname = \"ADSL\",
#'                    x = teal.data::example_cdisc_data(\"ADSL\"),
#'                    code = \"ADSL <- teal.data::example_cdisc_data('ADSL')\")"
#'   ),
#'   con = file_example
#' )
#' x <- cdisc_dataset_file(file_example, code = character(0))
#' get_code(x)
cdisc_dataset_file <- function(path, code = get_code(path)) {
  object <- object_file(path, "CDISCTealDataset")
  object$set_code(code)
  return(object)
}

## CDISCTealDatasetConnector ====
#'
#' @title A `CDISCTealDatasetConnector` class of objects
#'
#' @description `r lifecycle::badge("stable")`
#' Objects of this class store the connection function to fetch a single dataset.
#'
#' The difference compared to `TealDatasetConnector` is a parent field that
#' indicates name of the parent dataset. Note that the parent field might
#' be empty (i.e. `character(0)`).
#'
#' @param dataname (`character`)\cr
#'  A given name for the dataset it may not contain spaces
#'
#' @param pull_callable (`CallableFunction`)\cr
#'   function with necessary arguments set to fetch data from connection.
#'
#' @param keys (`character`)\cr
#'  vector of dataset primary keys column names
#'
#' @param parent optional, (`character`) \cr
#'   parent dataset name
#'
#' @param label (`character`)\cr
#'   Label to describe the dataset.
#'
#' @param code (`character`)\cr
#'  A character string defining code to modify `raw_data` from this dataset. To modify
#'  current dataset code should contain at least one assignment to object defined in `dataname`
#'  argument. For example if `dataname = ADSL` example code should contain
#'  `ADSL <- <some R code>`. Can't be used simultaneously with `script`
#'
#' @param script (`character`)\cr
#'   Alternatively to `code` - location of the file containing modification code.
#'   Can't be used simultaneously with `script`.
#'
#' @param vars (named `list`)) \cr
#'   In case when this object code depends on other `TealDataset` object(s) or
#'   other constant value, this/these object(s) should be included as named
#'   element(s) of the list. For example if this object code needs `ADSL`
#'   object we should specify `vars = list(ADSL = <adsl object>)`.
#'   It's recommended to include `TealDataset` or `TealDatasetConnector` objects to
#'   the `vars` list to preserve reproducibility. Please note that `vars`
#'   are included to this object as local `vars` and they cannot be modified
#'   within another dataset.
#'
#' @param metadata (named `list`, `NULL` or `CallableFunction`) \cr
#'   Field containing either the metadata about the dataset (each element of the list
#'   should be atomic and length one) or a `CallableFuntion` to pull the metadata
#'   from a connection. This should return a `list` or an object which can be
#'   converted to a list with `as.list`.
CDISCTealDatasetConnector <- R6::R6Class( # nolint
  classname = "CDISCTealDatasetConnector",
  inherit = TealDatasetConnector,

  ## __Public Methods ====
  public = list(
    #' @description
    #' Create a new `TealDatasetConnector` object. Set the pulling function
    #' `CallableFunction` which returns a `data.frame`, e.g. by reading
    #' from a function or creating it on the fly.
    initialize = function(dataname,
                          pull_callable,
                          keys, parent,
                          code = character(0),
                          label = character(0),
                          vars = list(),
                          metadata = NULL) {
      super$initialize(
        dataname = dataname,
        pull_callable = pull_callable,
        keys = keys,
        code = code,
        label = label,
        vars = vars,
        metadata = metadata
      )
      private$set_parent(parent)
      logger::log_trace("CDISCTealDatasetConnector initialized for dataset: { deparse1(self$get_dataname()) }")

      return(invisible(self))
    },
    #' @description
    #' Get parent dataset name
    #' @return (`character`) indicating parent `dataname`
    get_parent = function() {
      private$parent
    },

    #' @description
    #' Pull the data
    #'
    #' Read or create the data using `pull_callable` specified in the constructor.
    #'
    #' @param args (`NULL` or named `list`)\cr
    #'  additional dynamic arguments for pull function. `args` can be omitted if `pull_callable`
    #'  from constructor already contains all necessary arguments to pull data. One can try
    #'  to execute `pull_callable` directly by `x$pull_callable$run()` or to get code using
    #'  `x$pull_callable$get_code()`. `args` specified in pull are used temporary to get data but
    #'  not saved in code.
    #' @param try (`logical` value)\cr
    #'  whether perform function evaluation inside `try` clause
    #'
    #' @return `self` invisibly for chaining.
    pull = function(args = NULL, try = FALSE) {
      logger::log_trace("CDISCTealDatasetConnector$pull pulling dataset: { deparse1(self$get_dataname()) }.")
      super$pull(args = args, try = try)

      if (!self$is_failed()) {
        private$dataset <- as_cdisc(
          private$dataset,
          parent = self$get_parent()
        )
        logger::log_trace("CDISCTealDatasetConnector$pull pulled dataset: { deparse1(self$get_dataname()) }.")
      } else {
        logger::log_error("CDISCTealDatasetConnector$pull failed to pull dataset: { deparse1(self$get_dataname()) }.")
      }
      return(invisible(self))
    }
  ),

  ## __Private Fields ====
  private = list(
    parent = character(0),

    ## __Private Methods ====
    set_parent = function(parent) {
      checkmate::assert_character(parent, max.len = 1, any.missing = FALSE)
      private$parent <- parent
      return(invisible(self))
    }
  )
)

#' Convert a `TealDataset(Connector)` object to a `CDISCTealDataset(Connector)` object
#'
#' Convert a `TealDataset(Connector)` object to a `CDISCTealDataset(Connector)` object
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @note If passed a `CDISC`-flavored object it returns the unmodified object.
#'
#' @param x an object of `TealDataset` or `TealDatasetConnector` class
#' @inheritParams cdisc_dataset
#'
#' @return (`CDISCTealDataset` or `CDISCTealDatasetConnector`) object
#'
#' @export
as_cdisc <- function(x, parent = `if`(identical(get_dataname(x), "ADSL"), character(0), "ADSL")) {
  if (any(class(x) %in% c("CDISCTealDataset", "CDISCTealDatasetConnector"))) {
    x
  } else {
    UseMethod("as_cdisc")
  }
}

#' @rdname as_cdisc
#' @export
#' @examples
#' # TealDataset --------
#'
#' as_cdisc(
#'   dataset(
#'     "ADSL",
#'     teal.data::example_cdisc_data("ADSL"),
#'     keys = get_cdisc_keys("ADSL"),
#'     code = "ADSL <- teal.data::example_cdisc_data(\"ADSL\")"
#'   )
#' )
#' as_cdisc(
#'   dataset(
#'     "ADAE",
#'     teal.data::example_cdisc_data("ADAE"),
#'     keys = get_cdisc_keys("ADAE"),
#'     code = "ADAE <- teal.data::example_cdisc_data(\"ADAE\")"
#'   ),
#'   parent = "ADSL"
#' )
as_cdisc.TealDataset <- function(x, parent = `if`(identical(get_dataname(x), "ADSL"), character(0), "ADSL")) {
  if (length(get_keys(x)) > 0 || !(get_dataname(x) %in% names(default_cdisc_keys))) {
    cdisc_dataset(
      dataname = get_dataname(x),
      x = get_raw_data(x),
      keys = get_keys(x),
      parent = parent,
      label = get_dataset_label(x),
      code = x$get_code_class(),
      metadata = x$get_metadata()
    )
  } else {
    cdisc_dataset(
      dataname = get_dataname(x),
      x = get_raw_data(x),
      parent = parent,
      label = get_dataset_label(x),
      code = x$get_code_class(),
      metadata = x$get_metadata()
    )
  }
}

#' @rdname as_cdisc
#' @export
#' @examples
#' # TealDatasetConnector --------
#' library(magrittr)
#' pull_fun_adsl <- callable_function(teal.data::example_cdisc_data) %>%
#'   set_args(list(dataname = "ADSL"))
#' as_cdisc(
#'   dataset_connector(
#'     "ADSL",
#'     pull_fun_adsl,
#'     keys = get_cdisc_keys("ADSL")
#'   )
#' )
#'
#' pull_fun_adae <- callable_function(teal.data::example_cdisc_data) %>%
#'   set_args(list(dataname = "ADAE"))
#' as_cdisc(
#'   dataset_connector(
#'     "ADAE",
#'     pull_fun_adae,
#'     keys = get_cdisc_keys("ADAE")
#'   ),
#'   parent = "ADSL"
#' )
as_cdisc.TealDatasetConnector <- function(x, parent = `if`(identical(get_dataname(x), "ADSL"), character(0), "ADSL")) {
  ds <- tryCatch(
    expr = get_dataset(x),
    error = function(e) NULL
  )
  if (!is.null(ds)) {
    warning(
      "Pulled 'dataset' from 'x' will not be passed to CDISCTealDatasetConnector.
      Avoid pulling before conversion."
    )
  }

  cdisc_dataset_connector(
    dataname = get_dataname(x),
    pull_callable = x$get_pull_callable(),
    keys = get_keys(x),
    parent = parent,
    label = get_dataset_label(x),
    vars = x$.__enclos_env__$private$pull_vars,
    metadata = x$.__enclos_env__$private$metadata
  )
}

#' Include `JS` files from `/inst/js/` package directory to application header
#'
#' `system.file` should not be used to access files in other packages, it does
#' not work with `devtools`. Therefore, we redefine this method in each package
#' as needed. Thus, we do not export this method
#'
#' @param pattern (`character`) pattern of files to be included, passed to `system.file`
#' @param except (`character`) vector of basename filenames to be excluded
#'
#' @return HTML code that includes `JS` files
#' @keywords internal
include_js_files <- function(pattern = NULL, except = NULL) {
  checkmate::assert_character(except, min.len = 1, any.missing = FALSE, null.ok = TRUE)
  js_files <- list.files(
    system.file("js", package = "teal.data", mustWork = TRUE),
    pattern = pattern, full.names = TRUE
  )
  js_files <- js_files[!(basename(js_files) %in% except)] # no-op if except is NULL
  if (length(js_files) == 0) {
    return(NULL)
  }
  return(singleton(lapply(js_files, includeScript)))
}

.onLoad <- function(libname, pkgname) { # nolint
  # expose default CDISC dataset names
  # copy from excel file
  default_cdisc_keys <- yaml::yaml.load_file(
    get_package_file("teal.data", "cdisc_datasets/cdisc_datasets.yaml")
  ) # nolint
  assign("default_cdisc_keys", default_cdisc_keys, envir = parent.env(environment()))

  # Set up the teal logger instance
  teal.logger::register_logger("teal.data")

  invisible()
}

#' Get dataset attributes
#'
#' @description `r lifecycle::badge("stable")`
#' Get dataset attributes in form of named list.
#'
#' @param x an object of (`TealDataset`) class
#'
#' @return named `list` of object attributes
#'
#' @export
get_attrs <- function(x) {
  UseMethod("get_attrs")
}


#' @rdname get_attrs
#' @export
#' @examples
#' # TealDataset --------
#'
#' ADSL <- teal.data::example_cdisc_data("ADSL")
#'
#' x1 <- dataset("ADSL", x = ADSL, label = "custom label")
#' get_attrs(x1)
#'
#' x2 <- dataset(
#'   "ADSL",
#'   x = ADSL,
#'   keys = get_cdisc_keys("ADSL"),
#'   label = "custom label"
#' )
#' get_attrs(x2)
#'
#' # CDISCTealDataset --------
#'
#' ADSL <- teal.data::example_cdisc_data("ADSL")
#' x3 <- cdisc_dataset(
#'   "ADSL",
#'   x = ADSL,
#'   keys = get_cdisc_keys("ADSL"),
#'   label = "custom label"
#' )
#' get_attrs(x3)
get_attrs.TealDataset <- function(x) {
  return(x$get_attrs())
}

1		## Callable ====
2		#'
3		#' @title A \code{Callable} class of objects
4		#'
5		#' @description Object that stores function name with its arguments. Methods to get call and run it.
6		#' @keywords internal
7		#'
8		Callable <- R6::R6Class( # nolint
9		"Callable",
10
11		## __Public Methods ====
12		public = list(
13		#' @description
14		#' Create a new \code{CallableCode} object
15		#'
16		#' @param env (\code{environment})\cr
17		#' environment where the call will be evaluated
18		#'
19		#' @return new \code{CallableCode} object
20		initialize = function(env) {
21	229x	stopifnot(is.environment(env))
22	229x	private$env <- env
23	229x	logger::log_trace("Callable initialized.")
24	229x	invisible(self)
25		},
26		#' @description
27		#' Assigns \code{x <- value} object to \code{env}. Assigned object can't
28		#' be modified within local environment as it will be locked by using
29		#' \code{lockBinding}. This also means that this object can't be reassigned
30		#' which will throw an error.
31		#' @param x (\code{character} value)\cr
32		#' name of the variable in class environment
33		#' @param value (\code{data.frame})\cr
34		#' object to be assigned to \code{x}
35		#'
36		#' @return (\code{self}) invisibly for chaining.
37		assign_to_env = function(x, value) {
38		# assign variable once
39	63x	if (!exists(x, envir = private$env)) {
40	54x	assign(x, value, envir = private$env)
41
42		# variable can't be modified
43	54x	lockBinding(sym = x, env = private$env)
44	54x	logger::log_trace("Callable$assign_to_env assigned '{ x }' to the environment.")
45		}
46
47	63x	return(invisible(self))
48		},
49		#' @description
50		#' Execute \code{Callable} function or code.
51		#'
52		#' @param return (\code{logical} value)\cr
53		#' whether to return an object
54		#' @param args (\code{NULL} or named \code{list})\cr
55		#' supplied for callable functions only, these are dynamic arguments passed to function.
56		#' Dynamic arguments are executed in this call and are not saved which means that
57		#' \code{self$get_call()} won't include them later.
58		#' @param try (\code{logical} value)\cr
59		#' whether perform function evaluation inside \code{try} clause
60		#'
61		#' @return nothing or output from function depending on \code{return}
62		#' argument. If \code{run} fails it will return object of class \code{simple-error error}
63		#' when \code{try = TRUE} or will stop if \code{try = FALSE}.
64		run = function(return = TRUE, args = NULL, try = FALSE) {
65	150x	checkmate::assert_flag(return)
66	150x	checkmate::assert_list(args, names = "unique", min.len = 0, null.ok = TRUE)
67	150x	checkmate::assert_flag(try)
68
69		# args are "dynamic" are used only to evaluate this call
70		# - args not saved to private$call persistently
71	150x	expr <- self$get_call(deparse = FALSE, args = args)
72
73	150x	res <- tryCatch(
74	150x	eval(expr, envir = private$env),
75	150x	error = function(e) e
76		)
77	150x	private$check_run_output(res, try = try)
78
79	145x	logger::log_trace("Callable$run callable has been run.")
80	145x	if (return) {
81	144x	return(res)
82		} else {
83	1x	return(invisible(NULL))
84		}
85		},
86		#' @description
87		#' Check if evaluation of the function has not failed.
88		#'
89		#' @return (\code{logical}) \code{TRUE} if evaluation of the function failed or \code{FALSE}
90		#' if evaluation failed or function hasn't yet been called.
91		is_failed = function() {
92	151x	return(private$failed)
93		},
94		#' @description
95		#' Get error message from last function execution
96		#'
97		#' @return (\code{character}) object with error message or \code{character(0)} if last
98		#' function evaluation was successful.
99		get_error_message = function() {
100	3x	return(private$error_msg)
101		}
102		),
103
104		## __Private Fields ====
105		private = list(
106		call = NULL, # a call object
107		env = NULL, # environment where function is called
108		failed = FALSE,
109		error_msg = character(0),
110		## __Private Methods ====
111
112		# The deep clone function deep clones the environment of the Callable so
113		# that it is distinct for the copy
114		deep_clone = function(name, value) {
115	155x	deep_clone_r6(name, value)
116		},
117		# Checks output and handles error messages
118		check_run_output = function(res, try) {
119	150x	if (inherits(res, "error")) {
120	8x	msg <- conditionMessage(res)
121	8x	is_locked <- grepl(pattern = "cannot change value of locked", x = msg)
122
123	8x	error_msg <- if (is_locked) {
124	2x	locked_var <- gsub("^.+\\'(.+)\\'$", "\\1", x = msg)
125	2x	sprintf(
126	2x	"Modification of the local variable '%1$s' is not allowed. %2$s '%1$s'",
127	2x	locked_var,
128	2x	"Please add proxy variable to CallableCode to obtain results depending on altered"
129		)
130		} else {
131	6x	msg
132		}
133
134	8x	if (try) {
135	3x	private$failed <- TRUE
136	3x	private$error_msg <- error_msg
137	3x	logger::log_error("Callable$check_run_output { deparse1(error_msg) }.")
138		} else {
139	5x	stop(error_msg, call. = FALSE)
140		}
141		} else {
142	142x	private$failed <- FALSE
143	142x	private$error_msg <- character(0)
144		}
145		}
146		)
147		)

1		#' Get Label Attributes of Variables in a \code{data.frame}
2		#'
3		#' Variable labels can be stored as a \code{label} attribute for each variable.
4		#' This functions returns a named character vector with the variable labels
5		#' (empty sting if not specified)
6		#'
7		#' @param x a \code{data.frame} object
8		#' @param fill boolean in case the \code{label} attribute does not exist if
9		#' \code{TRUE} the variable names is returned, otherwise \code{NA}
10		#'
11		#' @source This function was taken 1-1 from
12		#' \href{https://cran.r-project.org/web/packages/formatters/index.html}{formatters} package, to reduce the complexity of
13		#' the dependency tree.
14		#'
15		#' @seealso [col_relabel()] [`col_labels<-`]
16		#'
17		#' @return a named character vector with the variable labels, the names
18		#' correspond to the variable names
19		#'
20		#' @export
21		#'
22		#' @examples
23		#' x <- iris
24		#' col_labels(x)
25		#' col_labels(x) <- paste("label for", names(iris))
26		#' col_labels(x)
27		col_labels <- function(x, fill = FALSE) {
28	1x	stopifnot(is.data.frame(x))
29	1x	if (NCOL(x) == 0) {
30	!	return(character())
31		}
32
33	1x	y <- Map(function(col, colname) {
34	4x	label <- attr(col, "label")
35
36	4x	if (is.null(label)) {
37	4x	if (fill) {
38	!	colname
39		} else {
40	1x	NA_character_
41		}
42		} else {
43	!	if (!is.character(label) && !(length(label) == 1)) {
44	!	stop("label for variable ", colname, "is not a character string")
45		}
46	!	as.vector(label)
47		}
48	1x	}, x, colnames(x))
49
50	1x	labels <- unlist(y, recursive = FALSE, use.names = TRUE)
51
52	1x	if (!is.character(labels)) {
53	!	stop("label extraction failed")
54		}
55
56	1x	labels
57		}
58
59		#' Set Label Attributes of All Variables in a \code{data.frame}
60		#'
61		#' Variable labels can be stored as a \code{label} attribute for each variable.
62		#' This functions sets all non-missing (non-NA) variable labels in a \code{data.frame}
63		#'
64		#' @inheritParams col_labels
65		#' @param value new variable labels, \code{NA} removes the variable label
66		#'
67		#' @source This function was taken 1-1 from
68		#' \href{https://cran.r-project.org/web/packages/formatters/index.html}{formatters} package, to reduce the complexity of
69		#' the dependency tree.
70		#'
71		#' @seealso [col_labels()] [col_relabel()]
72		#'
73		#' @return modifies the variable labels of \code{x}
74		#'
75		#' @export
76		#'
77		#' @examples
78		#' x <- iris
79		#' col_labels(x)
80		#' col_labels(x) <- paste("label for", names(iris))
81		#' col_labels(x)
82		#'
83		#' if (interactive()) {
84		#' View(x) # in RStudio data viewer labels are displayed
85		#' }
86		`col_labels<-` <- function(x, value) {
87	6x	stopifnot(
88	6x	is.data.frame(x),
89	6x	is.character(value),
90	6x	ncol(x) == length(value)
91		)
92
93	6x	theseq <- if (!is.null(names(value))) names(value) else seq_along(x)
94		# across columns of x
95	6x	for (j in theseq) {
96	26x	attr(x[[j]], "label") <- if (!is.na(value[j])) {
97	26x	value[j]
98		} else {
99	!	NULL
100		}
101		}
102
103	6x	x
104		}
105
106		#' Copy and Change Variable Labels of a \code{data.frame}
107		#'
108		#' Relabel a subset of the variables
109		#'
110		#' @inheritParams col_labels<-
111		#' @param ... name-value pairs, where name corresponds to a variable name in
112		#' \code{x} and the value to the new variable label
113		#'
114		#' @return a copy of \code{x} with changed labels according to \code{...}
115		#'
116		#' @source This function was taken 1-1 from
117		#' \href{https://cran.r-project.org/web/packages/formatters/index.html}{formatters} package, to reduce the complexity of
118		#' the dependency tree.
119		#'
120		#' @seealso [col_labels()] [`col_labels<-`]
121		#'
122		#' @export
123		#'
124		#' @examples
125		#' x <- col_relabel(iris, Sepal.Length = "Sepal Length of iris flower")
126		#' col_labels(x)
127		#'
128		col_relabel <- function(x, ...) {
129	!	stopifnot(is.data.frame(x))
130	!	if (missing(...)) {
131	!	return(x)
132		}
133	!	dots <- list(...)
134	!	varnames <- names(dots)
135	!	stopifnot(!is.null(varnames))
136
137	!	map_varnames <- match(varnames, colnames(x))
138
139	!	if (any(is.na(map_varnames))) {
140	!	stop("variables: ", paste(varnames[is.na(map_varnames)], collapse = ", "), " not found")
141		}
142
143	!	if (any(vapply(dots, Negate(is.character), logical(1)))) {
144	!	stop("all variable labels must be of type character")
145		}
146
147	!	for (i in seq_along(map_varnames)) {
148	!	attr(x[[map_varnames[[i]]]], "label") <- dots[[i]]
149		}
150
151	!	x
152		}

1		#' Topological graph sort
2		#'
3		#' Graph is a list which for each node contains a vector of child nodes
4		#' in the returned list, parents appear before their children.
5		#'
6		#' Implementation of `Kahn` algorithm with a modification to maintain the order of input elements.
7		#'
8		#' @param graph (named `list`) list with node vector elements
9		#' @keywords internal
10		#'
11		#' @examples
12		#' teal.data:::topological_sort(list(A = c(), B = c("A"), C = c("B"), D = c("A")))
13		#' teal.data:::topological_sort(list(D = c("A"), A = c(), B = c("A"), C = c("B")))
14		#' teal.data:::topological_sort(list(D = c("A"), B = c("A"), C = c("B"), A = c()))
15		topological_sort <- function(graph) {
16		# compute in-degrees
17	29x	in_degrees <- list()
18	29x	for (node in names(graph)) {
19	55x	in_degrees[[node]] <- 0
20	55x	for (to_edge in graph[[node]]) {
21	27x	in_degrees[[to_edge]] <- 0
22		}
23		}
24
25	29x	for (node in graph) {
26	55x	for (to_edge in node) {
27	27x	in_degrees[[to_edge]] <- in_degrees[[to_edge]] + 1
28		}
29		}
30
31		# sort
32	29x	visited <- 0
33	29x	sorted <- list()
34	29x	zero_in <- list()
35	29x	for (node in names(in_degrees)) {
36	39x	if (in_degrees[[node]] == 0) zero_in <- append(zero_in, node)
37		}
38	29x	zero_in <- rev(zero_in)
39
40	29x	while (length(zero_in) != 0) {
41	57x	visited <- visited + 1
42	57x	sorted <- c(zero_in[[1]], sorted)
43	57x	for (edge_to in graph[[zero_in[[1]]]]) {
44	26x	in_degrees[[edge_to]] <- in_degrees[[edge_to]] - 1
45	26x	if (in_degrees[[edge_to]] == 0) {
46	18x	zero_in <- append(zero_in, edge_to, 1)
47		}
48		}
49	57x	zero_in[[1]] <- NULL
50		}
51
52	29x	if (visited != length(in_degrees)) {
53	1x	stop(
54	1x	"Graph is not a directed acyclic graph. Cycles involving nodes: ",
55	1x	paste0(setdiff(names(in_degrees), sorted), collapse = " ")
56		)
57		} else {
58	28x	return(sorted)
59		}
60		}
61
62		#' Checks whether a graph is a `Directed Acyclic Graph (DAG)`
63		#'
64		#' @inheritParams topological_sort
65		#' @return `logical(1)` `TRUE` if the graph is a `DAG`; `FALSE` otherwise
66		#' @keywords internal
67		is_dag <- function(graph) {
68	29x	inherits(try(topological_sort(graph), silent = TRUE), "try-error")
69		}

1		#' S3 generic for creating an information summary about the duplicate key values in a dataset
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' @details The information summary provides row numbers and number of duplicates
6		#' for each duplicated key value.
7		#'
8		#' @param dataset `TealDataset` or `data.frame` a dataset, which will be tested
9		#' @param keys `character` vector of variable names in `dataset` consisting the key
10		#' or `keys` object, which does have a `primary` element with a vector of variable
11		#' names in `dataset` consisting the key. Optional, default: NULL
12		#'
13		#' @return a `tibble` with variables consisting the key and `row_no` and `duplicates_count` columns
14		#'
15		#' @note Raises an exception when this function cannot determine the primary key columns of the tested object.
16		#'
17		#' @examples
18		#'
19		#' adsl <- teal.data::example_cdisc_data("ADSL")
20		#' # create a TealDataset with default keys
21		#' rel_adsl <- cdisc_dataset("ADSL", adsl)
22		#' get_key_duplicates(rel_adsl)
23		#'
24		#' df <- as.data.frame(
25		#' list(a = c("a", "a", "b", "b", "c"), b = c(1, 2, 3, 3, 4), c = c(1, 2, 3, 4, 5))
26		#' )
27		#' res <- get_key_duplicates(df, keys = c("a", "b")) # duplicated keys are in rows 3 and 4
28		#' print(res) # prints a tibble
29		#' \dontrun{
30		#' get_key_duplicates(df) # raises an exception, because keys are missing with no default
31		#' }
32		#'
33		#' @export
34		get_key_duplicates <- function(dataset, keys = NULL) {
35	46x	UseMethod("get_key_duplicates", dataset)
36		}
37
38		#' @rdname get_key_duplicates
39		#' @export
40		get_key_duplicates.TealDataset <- function(dataset, keys = NULL) { # nolint
41	!	df <- get_raw_data(dataset)
42	!	if (is.null(keys)) {
43	!	keys_ds <- get_keys(dataset)
44	!	keys <- if (is.null(keys_ds)) character(0) else keys_ds
45		}
46
47	!	get_key_duplicates_util(df, keys)
48		}
49
50		#' @rdname get_key_duplicates
51		#' @export
52		get_key_duplicates.data.frame <- function(dataset, keys = NULL) { # nolint
53	46x	if (is.null(keys)) {
54	!	attr_key <- attr(dataset, "primary_key")
55	!	keys <- if (is.null(attr_key)) character(0) else attr
56		}
57	46x	get_key_duplicates_util(dataset, keys)
58		}
59
60		#' Creates a duplicate keys information summary.
61		#'
62		#' @details
63		#' Accepts a list of variable names - `keys`, which are treated as the
64		#' key to the `data.frame` argument. An instance of duplicated key is
65		#' defined as two rows, which have the same values in columns defined by `keys`.
66		#' Per each key value with duplicates returns a row in a `tibble`. The return table
67		#' has columns corresponding to the variable names passed in `keys` and
68		#' two additional columns: `rows` and `n`, which provide
69		#' information about row numbers of the original dataframe, which contain duplicated keys
70		#' and total duplicates counts.
71		#'
72		#' @param dataframe dataframe
73		#' @param keys `character` vector of variable names consisting the key to the `data.frame`
74		#'
75		#' @return `data.frame` with a duplicate keys information summary
76		#'
77		#' @keywords internal
78		#'
79		#' @examples
80		#' df <- data.frame(
81		#' a = c("a", "a", "b", "b", "c"),
82		#' b = c(1, 2, 3, 3, 4),
83		#' c = c(1, 2, 3, 4, 5)
84		#' )
85		#' res <- teal.data:::get_key_duplicates_util(df, keys = c("a", "b"))
86		#' print(res) # duplicated keys are in rows 3 and 4
87		#' @seealso [get_key_duplicates]
88		get_key_duplicates_util <- function(dataframe, keys) {
89	53x	checkmate::assert_data_frame(dataframe)
90	52x	checkmate::assert_character(keys)
91	50x	stopifnot(
92	50x	all(
93	50x	vapply(keys, FUN.VALUE = logical(1), FUN = function(key) key %in% colnames(dataframe))
94		)
95		)
96
97		# The goal is to print values of duplicated primary keys with number of duplicates and row numbers
98	49x	duplicates <- dataframe[, keys, drop = FALSE]
99	49x	duplicates$dups <- duplicated(duplicates, fromLast = FALSE) \| duplicated(duplicates, fromLast = TRUE)
100	49x	duplicates$row_number <- seq_len(nrow(duplicates))
101	49x	duplicates <- duplicates[duplicates$dups, ]
102	49x	duplicates$dups <- NULL
103
104	49x	if (nrow(duplicates) == 0) {
105	45x	duplicates$rows <- character(0)
106	45x	duplicates$row_number <- NULL
107	45x	duplicates$n <- integer(0)
108	45x	return(duplicates)
109		}
110
111	4x	groups <- split(duplicates, duplicates[, keys, drop = FALSE], drop = TRUE)
112	4x	summary_list <- lapply(groups, function(group) {
113	6x	ans <- group[1, keys, drop = FALSE]
114	6x	ans$rows <- paste(group[, "row_number"], collapse = ",")
115	6x	ans$n <- nrow(group)
116	6x	ans
117		})
118	4x	summary <- do.call(rbind, summary_list)
119	4x	rownames(summary) <- NULL
120	4x	summary
121		}

1		#' Get code from script
2		#'
3		#' Get code from script. Switches between `code` and `script` arguments
4		#' to return non-empty one to pass it further to constructors.
5		#'
6		#' @param code (`character`)\cr
7		#' an R code to be evaluated or a `PythonCodeClass` created using [python_code].
8		#' @inheritParams dataset_connector
9		#' @return code (`character`)
10		#' @keywords internal
11		code_from_script <- function(code, script, dataname = NULL) {
12	248x	checkmate::assert(
13	248x	checkmate::check_character(code, max.len = 1, any.missing = FALSE),
14	248x	checkmate::check_class(code, "PythonCodeClass")
15		)
16	246x	checkmate::assert_character(script, max.len = 1, any.missing = FALSE)
17	246x	if (length(code) == 0 && length(script) == 0) {
18	181x	return(character(0))
19		}
20
21	65x	if (checkmate::test_string(code) && checkmate::test_string(script)) {
22	!	stop("Function doesn't accept 'code' and 'script' at the same time.
23	!	Please specify either 'code' or 'script'", call. = FALSE)
24		}
25
26	65x	if (checkmate::test_string(script)) {
27	!	code <- read_script(file = script, dataname = dataname)
28		}
29
30	65x	code
31		}
32
33		#' Read .R file into character
34		#'
35		#' @description `r lifecycle::badge("stable")`
36		#' Comments will be excluded
37		#'
38		#' @param file (`character`) File to be parsed into code
39		#' @param dataname (`character`) dataset name to subset code from chunks
40		#' @return (`character`) vector with the code
41		#'
42		#' @export
43		#' @examples
44		#' file_example <- tempfile()
45		#' writeLines(c("x <- 2", "#second line comment", "x <- x + 2"), file_example)
46		#'
47		#' read_script(file_example)
48		read_script <- function(file, dataname = NULL) {
49	2x	checkmate::assert_string(file)
50	2x	checkmate::assert_file_exists(file)
51	2x	paste(
52	2x	code_exclude(
53	2x	enclosed_with_dataname(
54	2x	get_code_single(file, read_sources = TRUE),
55	2x	dataname = dataname
56		),
57	2x	exclude_comments = TRUE
58		),
59	2x	collapse = "\n"
60		)
61		}
62
63		#' Function to get a file out of a package
64		#'
65		#' @param pkg (`character`)\cr
66		#' The name of the package the file should be received from.
67		#' @param file_name (`character`)\cr
68		#' The name of the file to be received or path to it starting from
69		#' the base package path.
70		#' @return The path to the file
71		#' @keywords internal
72		#' @examples
73		#' teal.data:::get_package_file("teal.data", "WORDLIST")
74		#' teal.data:::get_package_file("teal.data", "cdisc_datasets/cdisc_datasets.yaml")
75		get_package_file <- function(pkg = NULL, file_name = NULL) {
76	!	checkmate::assert_string(pkg)
77	!	checkmate::assert_string(file_name)
78	!	base_file <- system.file(file_name, package = pkg)
79
80	!	if (file.exists(base_file)) {
81	!	return(base_file)
82		} else {
83	!	stop(paste("There is no such file:", file_name, "or package:", pkg))
84		}
85		}
86
87		# Function to be used while trying to load the object of specific class from the script.
88		object_file <- function(path, class) {
89	6x	checkmate::assert_string(path)
90	6x	checkmate::assert_file_exists(path)
91	6x	checkmate::assert_string(class)
92
93	6x	lines <- paste0(readLines(path), collapse = "\n")
94	6x	object <- eval(parse(text = lines, keep.source = FALSE))
95
96	6x	if (!inherits(object, class)) {
97	1x	stop("The object returned from the file is not of ", class, " class.")
98		}
99	5x	return(object)
100		}
101
102		#' Check if package can be loaded
103		#'
104		#' @param pckg `character` package name.
105		#' @param msg `character` error message to display if package is not available.
106		#'
107		#' @return Error or invisible NULL.
108		#' @keywords internal
109		check_pkg_quietly <- function(pckg, msg) {
110	14x	checkmate::assert_string(pckg)
111	14x	checkmate::assert_string(msg)
112	14x	if (!pckg %in% rownames(utils::installed.packages())) {
113	1x	stop(msg)
114		}
115
116	13x	invisible(NULL)
117		}
118
119
120		#' validate metadata as a list of length one atomic entries (or NULL)
121		#' @param metadata `object` to be checked
122		#' @return `NULL` or throw error
123		#' @examples
124		#'
125		#' validate_metadata(NULL)
126		#' validate_metadata(list(A = TRUE, B = 10, C = "test"))
127		#' \dontrun{
128		#' validate_metadata(list(a = 1:10))
129		#' }
130		#'
131		#' @export
132		validate_metadata <- function(metadata) {
133	719x	checkmate::assert_list(metadata, any.missing = FALSE, names = "named", null.ok = TRUE)
134	713x	lapply(names(metadata), function(name) {
135	156x	checkmate::assert_atomic(metadata[[name]], len = 1, .var.name = name)
136		})
137	709x	return(NULL)
138		}
139
140		#' Resolve the expected bootstrap theme
141		#' @keywords internal
142		get_teal_bs_theme <- function() {
143	8x	bs_theme <- getOption("teal.bs_theme")
144	8x	if (is.null(bs_theme)) {
145	5x	NULL
146	3x	} else if (!inherits(bs_theme, "bs_theme")) {
147	2x	warning("teal.bs_theme has to be of a bslib::bs_theme class, the default shiny bootstrap is used.")
148	2x	NULL
149		} else {
150	1x	bs_theme
151		}
152		}

1		## MAETealDataset ====
2		#'
3		#' @title R6 Class representing a `MultiAssayExperiment` object with its attributes
4		#'
5		#' @description `r lifecycle::badge("experimental")`
6		#' Any `MultiAssayExperiment` object can be stored inside this `MAETealDataset`.
7		#' Some attributes like colnames, dimension or column names for a specific type will
8		#' be automatically derived.
9		#'
10		#'
11		#' @param dataname (`character`)\cr
12		#' A given name for the dataset it may not contain spaces
13		#' @param x (`MultiAssayExperiment`)\cr
14		#' @param keys optional, (`character`)\cr
15		#' A vector of primary keys
16		#' @param code (`character` or `CodeClass`)\cr
17		#' A character string defining the code needed to produce the data set in `x`.
18		#' `initialize()` and `recreate()` accept code as `CodeClass`
19		#' which is also needed to preserve the code uniqueness and correct order.
20		#' @param label (`character`)\cr
21		#' Label to describe the dataset
22		#' @param vars (named `list`)) \cr
23		#' In case when this object code depends on other `TealDataset` object(s) or
24		#' other constant value, this/these object(s) should be included as named
25		#' element(s) of the list. For example if this object code needs `ADSL`
26		#' object we should specify `vars = list(ADSL = <adsl object>)`.
27		#' It is recommended to include `TealDataset` or `TealDatasetConnector` objects to
28		#' the `vars` list to preserve reproducibility. Please note that `vars`
29		#' are included to this object as local `vars` and they cannot be modified
30		#' within another dataset.
31		#' @param metadata (named `list` or `NULL`) \cr
32		#' Field containing metadata about the dataset. Each element of the list
33		#' should be atomic and of length one.
34		#'
35		#' @seealso [`TealDataset`]
36		#'
37		MAETealDataset <- R6::R6Class( # nolint
38		"MAETealDataset",
39		inherit = TealDataset,
40		## __Public Methods ====
41		public = list(
42		#' @description
43		#' Create a new object of `MAETealDataset` class
44		#'
45		initialize = function(dataname,
46		x,
47		keys = character(0),
48		code = character(0),
49		label = character(0),
50		vars = list(),
51		metadata = NULL) {
52	18x	if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
53	!	stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
54		}
55	18x	checkmate::assert_string(dataname)
56	18x	stopifnot(inherits(x, "MultiAssayExperiment"))
57	18x	checkmate::assert_character(keys, any.missing = FALSE)
58	18x	checkmate::assert(
59	18x	checkmate::check_character(code, max.len = 1, any.missing = FALSE),
60	18x	checkmate::check_class(code, "CodeClass")
61		)
62	18x	checkmate::assert_character(label, max.len = 1, null.ok = TRUE, any.missing = FALSE)
63	18x	checkmate::assert_list(vars, min.len = 0, names = "unique")
64
65		# validate metadata as a list of length one atomic
66	18x	validate_metadata(metadata)
67
68	18x	private$.raw_data <- x
69	18x	private$metadata <- metadata
70	18x	private$set_dataname(dataname)
71	18x	self$set_vars(vars)
72	18x	self$set_dataset_label(label)
73	18x	self$set_keys(keys)
74
75		# needed if recreating dataset - we need to preserve code order and uniqueness
76	18x	private$code <- CodeClass$new()
77	18x	if (is.character(code)) {
78	17x	self$set_code(code)
79		} else {
80	1x	private$code$append(code)
81		}
82
83	18x	logger::log_trace("MAETealDataset$initialize initialized dataset: { deparse1(self$get_dataname()) }.")
84
85	18x	return(invisible(self))
86		},
87		# ___ check ====
88		#' @description
89		#' Check to determine if the raw data is reproducible from the `get_code()` code.
90		#' @return
91		#' `TRUE` if the dataset generated from evaluating the
92		#' `get_code()` code is identical to the raw data, else `FALSE`.
93		check = function() {
94	3x	logger::log_trace(
95	3x	"TealDataset$check executing the code to reproduce dataset: { deparse1(self$get_dataname()) }..."
96		)
97	3x	if (!checkmate::test_character(self$get_code(), len = 1, pattern = "\\w+")) {
98	1x	stop(
99	1x	sprintf(
100	1x	"Cannot check preprocessing code of '%s' - code is empty.",
101	1x	self$get_dataname()
102		)
103		)
104		}
105
106	2x	new_set <- private$execute_code(
107	2x	code = self$get_code_class(),
108	2x	vars = private$vars
109		)
110	2x	res_check <- tryCatch(
111		{
112	2x	identical(self$get_raw_data(), new_set)
113		},
114	2x	error = function(e) {
115	!	FALSE
116		}
117		)
118	2x	logger::log_trace("TealDataset$check { deparse1(self$get_dataname()) } reproducibility result: { res_check }.")
119
120	2x	return(res_check)
121		},
122		#' @description
123		#' Check if keys has been specified correctly for dataset. Set of `keys`
124		#' should distinguish unique rows or be `character(0)`.
125		#'
126		#' @return `TRUE` if dataset has been already pulled, else `FALSE`
127		check_keys = function(keys = private$.keys) {
128	8x	if (length(keys) > 0) {
129	3x	if (!all(keys %in% self$get_colnames())) {
130	1x	stop("Primary keys specifed for ", self$get_dataname(), " do not exist in the data.")
131		}
132
133	2x	duplicates <- get_key_duplicates(as.data.frame(SummarizedExperiment::colData(self$get_raw_data())), keys)
134	2x	if (nrow(duplicates) > 0) {
135	1x	stop(
136	1x	"Duplicate primary key values found in the dataset '", self$get_dataname(), "' :\n",
137	1x	paste0(utils::capture.output(print(duplicates))[-c(1, 3)], collapse = "\n"),
138	1x	call. = FALSE
139		)
140		}
141		}
142		},
143		#' @description
144		#' Derive the column names
145		#' @return `character` vector.
146		get_colnames = function() {
147	8x	colnames(SummarizedExperiment::colData(private$.raw_data))
148		},
149		#' @description
150		#' Derive the column labels
151		#' @return `character` vector.
152		get_column_labels = function() {
153	!	vapply(
154	!	X = SummarizedExperiment::colData(private$.raw_data),
155	!	FUN.VALUE = character(1),
156	!	FUN = function(x) {
157	!	label <- attr(x, "label")
158	!	if (length(label) != 1) {
159	!	NA_character_
160		} else {
161	!	label
162		}
163		}
164		)
165		},
166		#' @description
167		#' Get the number of columns of the data
168		#' @return `numeric` vector
169		get_ncol = function() {
170	!	ncol(SummarizedExperiment::colData(private$.raw_data))
171		},
172		#' @description
173		#' Get the number of rows of the data
174		#' @return `numeric` vector
175		get_nrow = function() {
176	!	nrow(SummarizedExperiment::colData(private$.raw_data))
177		},
178		#' @description
179		#' Derive the row names
180		#' @return `character` vector.
181		get_rownames = function() {
182	!	rownames(SummarizedExperiment::colData(private$.raw_data))
183		},
184		#' @description
185		#' Prints this `MAETealDataset`.
186		#' @param ... additional arguments to the printing method
187		#'
188		#' @return invisibly self
189		print = function(...) {
190	!	cat(sprintf("A MAETealDataset object containing data of %d subjects.\n", self$get_nrow()))
191	!	print(MultiAssayExperiment::experiments(self$get_raw_data()))
192	!	invisible(self)
193		}
194		),
195		## __Private Fields ====
196		private = list(
197		.raw_data = NULL,
198		get_class_colnames = function(class_type = "character") {
199	!	checkmate::assert_string(class_type)
200
201	!	return_cols <- private$.colnames[which(vapply(
202	!	lapply(SummarizedExperiment::colData(private$.raw_data), class),
203	!	function(x, target_class_name) any(x %in% target_class_name),
204	!	logical(1),
205	!	target_class_name = class_type
206		))]
207
208	!	return(return_cols)
209		},
210
211		# Evaluate script code to modify data or to reproduce data
212		#
213		# @param code (`CodeClass`) the object storing the code to execute
214		# @param vars (named `list`) additional pre-requisite vars to execute code
215		# @return (`environment`) which stores modified `x`
216		execute_code = function(code, vars = list()) {
217	2x	stopifnot(inherits(code, "CodeClass"))
218	2x	checkmate::assert_list(vars, min.len = 0, names = "unique")
219
220	2x	execution_environment <- new.env(parent = parent.env(globalenv()))
221
222		# set up environment for execution
223	2x	for (vars_idx in seq_along(vars)) {
224	!	var_name <- names(vars)[[vars_idx]]
225	!	var_value <- vars[[vars_idx]]
226	!	if (inherits(var_value, "TealDatasetConnector") \|\| inherits(var_value, "TealDataset")) {
227	!	var_value <- get_raw_data(var_value)
228		}
229	!	assign(envir = execution_environment, x = var_name, value = var_value)
230		}
231
232		# execute
233	2x	code$eval(envir = execution_environment)
234
235	2x	if (!inherits(execution_environment[[self$get_dataname()]], "MultiAssayExperiment")) {
236	!	out_msg <- sprintf(
237	!	"\n%s\n\n - Code from %s needs to return a MultiAssayExperiment assigned to an object of dataset name.",
238	!	self$get_code(),
239	!	self$get_dataname()
240		)
241
242	!	rlang::with_options(
243	!	.expr = stop(out_msg, call. = FALSE),
244	!	warning.length = max(min(8170, nchar(out_msg) + 30), 100)
245		)
246		}
247
248	2x	new_set <- execution_environment[[self$get_dataname()]]
249
250	2x	return(new_set)
251		}
252		)
253		)
254
255		#' S3 method to construct an `MAETealDataset` object from `MultiAssayExperiment`
256		#'
257		#' @rdname dataset
258		#'
259		#' @examples
260		#' # Simple example
261		#' utils::data(miniACC, package = "MultiAssayExperiment")
262		#' mae_d <- dataset(
263		#' "MAE",
264		#' miniACC,
265		#' keys = c("STUDYID", "USUBJID"),
266		#' metadata = list(type = "example")
267		#' )
268		#' mae_d$get_dataname()
269		#' mae_d$get_dataset_label()
270		#' mae_d$get_metadata()
271		#' mae_d$get_code()
272		#' mae_d$get_raw_data()
273		#' @export
274		dataset.MultiAssayExperiment <- function(dataname, # nolint
275		x,
276		keys = character(0),
277		label = data_label(x),
278		code = character(0),
279		vars = list(),
280		metadata = NULL) {
281	4x	if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
282	!	stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
283		}
284	4x	checkmate::assert_string(dataname)
285	4x	checkmate::assert(
286	4x	checkmate::check_character(code, max.len = 1, any.missing = FALSE),
287	4x	checkmate::check_class(code, "CodeClass")
288		)
289	4x	checkmate::assert_list(vars, min.len = 0, names = "unique")
290
291	4x	MAETealDataset$new(
292	4x	dataname = dataname,
293	4x	x = x,
294	4x	keys = keys,
295	4x	code = code,
296	4x	label = label,
297	4x	vars = vars,
298	4x	metadata = metadata
299		)
300		}
301
302		#' The constructor of `MAETealDataset`
303		#'
304		#' @description `r lifecycle::badge("deprecated")`
305		#'
306		#' @inheritParams dataset
307		#' @param x (`MultiAssayExperiment`)
308		#'
309		#' @examples
310		#' # Simple example
311		#' utils::data(miniACC, package = "MultiAssayExperiment")
312		#' mae_d <- dataset("MAE", miniACC)
313		#' mae_d$get_dataname()
314		#' mae_d$get_dataset_label()
315		#' mae_d$get_code()
316		#' mae_d$get_raw_data()
317		#' @export
318		mae_dataset <- function(dataname,
319		x,
320		label = data_label(x),
321		code = character(0),
322		vars = list()) {
323	!	lifecycle::deprecate_soft(
324	!	when = "0.10.1",
325	!	what = "teal.data::mae_dataset()",
326	!	with = "teal.data::dataset()"
327		)
328
329	!	if (!inherits(x, "MultiAssayExperiment")) {
330	!	stop("Argument x must be a MultiAssayExperiment object")
331		}
332
333	!	dataset(
334	!	dataname = dataname,
335	!	x = x,
336	!	code = code,
337	!	label = label,
338	!	vars = vars
339		)
340		}

1		## JoinKeys ====
2		#'
3		#'
4		#' @title R6 Class to store relationships for joining datasets
5		#'
6		#' @description `r lifecycle::badge("stable")`
7		#' This class stores symmetric links between pairs of key-values
8		#' (e.g. column A of dataset X can be joined with column B of dataset Y). This relationship
9		#' is more general than the SQL foreign key relationship which also imposes constraints on the values
10		#' of these columns.
11		#' @param dataset_1 (`character`) one dataset name
12		#' @param dataset_2 (`character`) other dataset name
13		#'
14		#' @examples
15		#' x <- teal.data:::JoinKeys$new()
16		#' x$set(
17		#' list(
18		#' join_key("dataset_A", "dataset_B", c("col_1" = "col_a")),
19		#' join_key("dataset_A", "dataset_C", c("col_2" = "col_x", "col_3" = "col_y"))
20		#' )
21		#' )
22		#' x$get()
23		#' x$mutate("dataset_A", "dataset_B", c("col1" = "col10"))
24		#' x$get("dataset_A", "dataset_B")
25		JoinKeys <- R6::R6Class( # nolint
26		classname = "JoinKeys",
27		## __Public Methods ====
28		public = list(
29		#' @description
30		#' Create a new object of `JoinKeys`
31		#' @return empty (`JoinKeys`)
32		initialize = function() {
33	247x	logger::log_trace("JoinKeys initialized.")
34	247x	return(invisible(self))
35		},
36		#' @description
37		#' Split the current `JoinKeys` object into a named list of join keys objects with an element for each dataset
38		#' @return (`list`) a list of `JoinKeys` object
39		split = function() {
40	6x	list_of_list_of_join_key_set <- lapply(
41	6x	names(self$get()),
42	6x	function(dataset_1) {
43	27x	lapply(
44	27x	names(self$get()[[dataset_1]]),
45	27x	function(dataset_2) join_key(dataset_1, dataset_2, self$get()[[dataset_1]][[dataset_2]])
46		)
47		}
48		)
49	6x	res <- lapply(
50	6x	list_of_list_of_join_key_set,
51	6x	function(x) {
52	27x	y <- JoinKeys$new()
53	27x	y$set(x)
54		}
55		)
56	6x	names(res) <- names(self$get())
57
58	6x	logger::log_trace("JoinKeys$split keys split.")
59	6x	return(res)
60		},
61		#' @description
62		#' Merging a list (or one) of `JoinKeys` objects into the current `JoinKeys` object
63		#' @param x `list` of `JoinKeys` objects or single `JoinKeys` object
64		#' @return (`self`) invisibly for chaining
65		merge = function(x) {
66	5x	if (inherits(x, "JoinKeys")) x <- list(x)
67	18x	checkmate::assert_list(x, types = "JoinKeys", min.len = 1)
68	13x	for (jk in x) {
69	25x	for (dataset_1 in names(jk$get())) {
70	87x	for (dataset_2 in names(jk$get()[[dataset_1]])) {
71	102x	self$mutate(dataset_1, dataset_2, jk$get()[[dataset_1]][[dataset_2]])
72		}
73		}
74		}
75	13x	logger::log_trace("JoinKeys$merge keys merged.")
76	13x	return(invisible(self))
77		},
78		#' @description
79		#' Get join keys between two datasets.
80		#' @return (`character`) named character vector x with names(x) the
81		#' columns of `dataset_1` and the values of `(x)` the corresponding join
82		#' keys in `dataset_2` or `character(0)` if no relationship
83		#' @details if one or both of `dataset_1` and `dataset_2` are missing then
84		#' underlying keys structure is returned for further processing
85		get = function(dataset_1, dataset_2) {
86	857x	if (missing(dataset_1) && missing(dataset_2)) {
87	368x	return(private$.keys)
88		}
89	489x	if (missing(dataset_2)) {
90	86x	return(private$.keys[[dataset_1]])
91		}
92	403x	if (missing(dataset_1)) {
93	1x	return(private$.keys[[dataset_2]])
94		}
95	402x	if (is.null(private$.keys[[dataset_1]][[dataset_2]])) {
96	152x	return(character(0))
97		}
98	250x	return(private$.keys[[dataset_1]][[dataset_2]])
99		},
100		#' @description
101		#' Change join_keys for a given pair of dataset names (or
102		#' add join_keys for given pair if it does not exist)
103		#' @param val (named `character`) column names used to join
104		#' @return (`self`) invisibly for chaining
105		mutate = function(dataset_1, dataset_2, val) {
106	232x	checkmate::assert_string(dataset_1)
107	232x	checkmate::assert_string(dataset_2)
108	232x	checkmate::assert_character(val, any.missing = FALSE)
109
110	232x	private$join_pair(join_key(dataset_1, dataset_2, val))
111
112	232x	logger::log_trace(
113	232x	sprintf(
114	232x	"JoinKeys$mutate updated the keys between %s and %s to %s",
115	232x	dataset_1,
116	232x	dataset_2,
117	232x	paste(val, collapse = ", ")
118		)
119		)
120	232x	return(invisible(self))
121		},
122		#' @description
123		#' Set up join keys basing on list of `JoinKeySet` objects.
124		#' @param x `list` of `JoinKeySet` objects (which are created using the `join_key` function)
125		#' or single `JoinKeySet` objects
126		#' @details Note that join keys are symmetric although the relationship only needs
127		#' to be specified once
128		#' @return (`self`) invisibly for chaining
129		set = function(x) {
130	119x	if (length(private$.keys) > 0) {
131	1x	stop("Keys already set, please use JoinKeys$mutate() to change them")
132		}
133	118x	if (inherits(x, "JoinKeySet")) {
134	!	x <- list(x)
135		}
136
137		# check if any JoinKeySets share the same datasets but different values
138	118x	for (idx_1 in seq_along(x)) {
139	213x	for (idx_2 in seq_len(idx_1)) {
140	363x	private$check_compatible_keys(x[[idx_1]], x[[idx_2]])
141		}
142		}
143
144	110x	checkmate::assert_list(x, types = "JoinKeySet", min.len = 1)
145	110x	lapply(x, private$join_pair)
146
147	110x	logger::log_trace("JoinKeys$set keys are set.")
148	110x	return(invisible(self))
149		},
150		#' @description
151		#' Prints this `JoinKeys`.
152		#'
153		#' @param ... additional arguments to the printing method
154		#' @return invisibly self
155		print = function(...) {
156	2x	check_ellipsis(...)
157	2x	keys_list <- self$get()
158	2x	if (length(keys_list) > 0) {
159	1x	cat(sprintf(
160	1x	"A JoinKeys object containing foreign keys between %s datasets:\n",
161	1x	length(keys_list)
162		))
163	1x	print(keys_list)
164		} else {
165	1x	cat("An empty JoinKeys object.")
166		}
167	2x	invisible(self)
168		},
169		#' @description
170		#' Sets the parents of the datasets.
171		#'
172		#' @param named_list Named (`list`) of the parents datasets.
173		#'
174		#' @return (`self`) invisibly for chaining
175		set_parents = function(named_list) {
176	34x	for (dataset in names(named_list)) {
177	74x	checkmate::assert(
178	74x	checkmate::check_null(self$get_parent(dataset)),
179	74x	checkmate::check_true(
180	74x	length(self$get_parent(dataset)) == 0 &&
181	74x	length(named_list[[dataset]]) == 0
182		),
183	74x	checkmate::check_true(self$get_parent(dataset) == named_list[[dataset]]),
184	74x	"Please check the difference between provided datasets parents and provided join_keys parents."
185		)
186	73x	if (is.null(self$get_parent(dataset))) {
187	70x	private$parents[[dataset]] <- named_list[[dataset]]
188		}
189		}
190	33x	invisible(self)
191		},
192		#' @description
193		#' Gets the parent of the desired dataset.
194		#'
195		#' @param dataname (`character`) name of the dataset.
196		#' @return (`character`) the parent of the desired dataset
197		get_parent = function(dataname) {
198	241x	if (missing(dataname)) {
199	1x	return(NULL)
200		}
201	240x	private$parents[[dataname]]
202		},
203		#' @description
204		#' Gets the parents of the datasets.
205		#'
206		#' @return (`list`) A named list of the parents of all datasets
207		get_parents = function() {
208	53x	private$parents
209		},
210		#' @description
211		#' Updates the keys of the datasets based on the parents.
212		#'
213		#' @return (`self`) invisibly for chaining
214		update_keys_given_parents = function() {
215	22x	datanames <- names(self$get())
216	22x	duplicate_pairs <- list()
217	22x	for (d1 in datanames) {
218	46x	d1_pk <- self$get(d1, d1)
219	46x	d1_parent <- self$get_parent(d1)
220	46x	for (d2 in datanames) {
221	112x	if (paste(d2, d1) %in% duplicate_pairs) {
222	26x	next
223		}
224	86x	if (length(self$get(d1, d2)) == 0) {
225	38x	d2_parent <- self$get_parent(d2)
226	38x	d2_pk <- self$get(d2, d2)
227
228	38x	fk <- if (identical(d1, d2_parent)) {
229		# first is parent of second -> parent keys -> first keys
230	18x	d1_pk
231	38x	} else if (identical(d1_parent, d2)) {
232		# second is parent of first -> parent keys -> second keys
233	!	d2_pk
234	38x	} else if (identical(d1_parent, d2_parent) && length(d1_parent) > 0) {
235		# both has the same parent -> parent keys
236	10x	self$get(d1_parent, d1_parent)
237		} else {
238		# cant find connection - leave empty
239	10x	next
240		}
241	28x	self$mutate(d1, d2, fk)
242	28x	duplicate_pairs <- append(duplicate_pairs, paste(d1, d2))
243		}
244		}
245		}
246		# check parent child relation
247	22x	private$check_parent_child()
248
249	22x	invisible(self)
250		}
251		),
252		## __Private Fields ====
253		private = list(
254		.keys = list(),
255		parents = list(),
256		join_pair = function(join_key) {
257	430x	dataset_1 <- join_key$dataset_1
258	430x	dataset_2 <- join_key$dataset_2
259	430x	keys <- join_key$keys
260
261	430x	if (is.null(private$.keys[[dataset_1]])) {
262	228x	private$.keys[[dataset_1]] <- list()
263		}
264	430x	private$.keys[[dataset_1]][[dataset_2]] <- keys
265
266	430x	if (dataset_2 != dataset_1) {
267	307x	if (is.null(private$.keys[[dataset_2]])) {
268	161x	private$.keys[[dataset_2]] <- list()
269		}
270
271	307x	if (length(keys) > 0) {
272	302x	keys <- setNames(names(keys), keys)
273		}
274	307x	private$.keys[[dataset_2]][[dataset_1]] <- keys
275		}
276		},
277		# helper function to deterimine if two key sets contain incompatible keys
278		# return TRUE if compatible, throw error otherwise
279		check_compatible_keys = function(join_key_1, join_key_2) {
280	363x	error_message <- function(dataset_1, dataset_2) {
281	7x	stop(
282	7x	paste("cannot specify multiple different join keys between datasets:", dataset_1, "and", dataset_2)
283		)
284		}
285
286
287		# if first datasets and the second datasets match and keys
288		# must contain the same named elements
289	363x	if (join_key_1$dataset_1 == join_key_2$dataset_1 && join_key_1$dataset_2 == join_key_2$dataset_2) {
290	212x	if (!identical(sort(join_key_1$keys), sort(join_key_2$keys))) {
291	3x	error_message(join_key_1$dataset_1, join_key_1$dataset_2)
292		}
293		}
294
295		# if first dataset of join_key_1 matches second dataset of join_key_2
296		# and the first dataset of join_key_2 must match second dataset of join_key_1
297		# and keys must contain the same elements but with names and values swapped
298	359x	if (join_key_1$dataset_1 == join_key_2$dataset_2 && join_key_1$dataset_2 == join_key_2$dataset_1) {
299		# have to handle empty case differently as names(character(0)) is NULL
300	39x	if (length(join_key_1$keys) == 0 && length(join_key_2$keys) == 0) {
301	2x	return(TRUE)
302		}
303
304	37x	if (xor(length(join_key_1$keys) == 0, length(join_key_2$keys) == 0) \|\|
305	37x	!identical(sort(join_key_1$keys), sort(setNames(names(join_key_2$keys), join_key_2$keys)))) {
306	4x	error_message(join_key_1$dataset_1, join_key_1$dataset_2)
307		}
308		}
309
310		# otherwise they are compatible
311	353x	return(TRUE)
312		},
313		# checks the parent child relations are valid
314		check_parent_child = function() {
315	24x	if (!is.null(self$get_parents())) {
316	24x	parents <- self$get_parents()
317	24x	for (idx1 in seq_along(parents)) {
318	46x	name_from <- names(parents)[[idx1]]
319	46x	for (idx2 in seq_along(parents[[idx1]])) {
320	21x	name_to <- parents[[idx1]][[idx2]]
321	21x	keys_from <- self$get(name_from, name_to)
322	21x	keys_to <- self$get(name_to, name_from)
323	21x	if (length(keys_from) == 0 && length(keys_to) == 0) {
324	1x	stop(sprintf("No join keys from %s to its parent (%s) and vice versa", name_from, name_to))
325		}
326	20x	if (length(keys_from) == 0) {
327	!	stop(sprintf("No join keys from %s to its parent (%s)", name_from, name_to))
328		}
329	20x	if (length(keys_to) == 0) {
330	!	stop(sprintf("No join keys from %s parent name (%s) to %s", name_from, name_to, name_from))
331		}
332		}
333		}
334		}
335		}
336		)
337		)
338
339		# constructors ====
340
341		#' Create a `JoinKeys` out of a list of `JoinKeySet` objects
342		#'
343		#' @description `r lifecycle::badge("stable")`
344		#'
345		#' @param ... optional, a `JoinKeySet` objects created using the `join_key` function.
346		#' @details Note that join keys are symmetric although the relationship only needs
347		#' to be specified once.
348		#'
349		#' @return `JoinKeys`
350		#'
351		#' @export
352		#'
353		#' @examples
354		#' join_keys()
355		#' join_keys(
356		#' join_key("dataset_A", "dataset_B", c("col_1" = "col_a")),
357		#' join_key("dataset_A", "dataset_C", c("col_2" = "col_x", "col_3" = "col_y"))
358		#' )
359		#' join_keys(
360		#' join_key("dataset_A", "dataset_B", c("col_1" = "col_a"))
361		#' )
362		join_keys <- function(...) {
363	181x	x <- list(...)
364
365	181x	res <- JoinKeys$new()
366	181x	if (length(x) > 0) {
367	59x	res$set(x)
368		}
369
370	173x	res
371		}
372
373		# wrappers ====
374		#' Mutate `JoinKeys` with a new values
375		#'
376		#' @description `r lifecycle::badge("experimental")`
377		#' Mutate `JoinKeys` with a new values
378		#'
379		#' @param x (`JoinKeys`) object to be modified
380		#' @param dataset_1 (`character`) one dataset name
381		#' @param dataset_2 (`character`) other dataset name
382		#' @param val (named `character`) column names used to join
383		#'
384		#' @return modified `JoinKeys` object
385		#'
386		#' @export
387		mutate_join_keys <- function(x, dataset_1, dataset_2, val) {
388	!	UseMethod("mutate_join_keys")
389		}
390
391		#' @rdname mutate_join_keys
392		#' @export
393		#' @examples
394		#' # JoinKeys ----
395		#'
396		#' x <- join_keys(
397		#' join_key("dataset_A", "dataset_B", c("col_1" = "col_a")),
398		#' join_key("dataset_A", "dataset_C", c("col_2" = "col_x", "col_3" = "col_y"))
399		#' )
400		#' x$get("dataset_A", "dataset_B")
401		#'
402		#' mutate_join_keys(x, "dataset_A", "dataset_B", c("col_1" = "col_10"))
403		#' x$get("dataset_A", "dataset_B")
404		mutate_join_keys.JoinKeys <- function(x, dataset_1, dataset_2, val) {
405	!	x$mutate(dataset_1, dataset_2, val)
406		}
407
408		#' @rdname mutate_join_keys
409		#' @export
410		#' @examples
411		#' # TealData ----
412		#'
413		#' ADSL <- teal.data::example_cdisc_data("ADSL")
414		#' ADRS <- teal.data::example_cdisc_data("ADRS")
415		#'
416		#' x <- cdisc_data(
417		#' cdisc_dataset("ADSL", ADSL),
418		#' cdisc_dataset("ADRS", ADRS)
419		#' )
420		#' x$get_join_keys()$get("ADSL", "ADRS")
421		#'
422		#' mutate_join_keys(x, "ADSL", "ADRS", c("COLUMN1" = "COLUMN2"))
423		#' x$get_join_keys()$get("ADSL", "ADRS")
424		mutate_join_keys.TealData <- function(x, dataset_1, dataset_2, val) { # nolint
425	!	x$mutate_join_keys(dataset_1, dataset_2, val)
426		}
427
428
429		#' Create a relationship between a pair of datasets
430		#'
431		#' @description `r lifecycle::badge("stable")`
432		#'
433		#' @inheritParams mutate_join_keys
434		#' @param keys (optionally named `character`) where `names(keys)` are columns in `dataset_1`
435		#' with relationship to columns of `dataset_2` given by the elements in `keys`.
436		#' If `names(keys)` is `NULL` then the same column names are used for both `dataset_1`
437		#' and `dataset_2`.
438		#'
439		#' @return object of class `JoinKeySet` to be passed into `join_keys` function.
440		#'
441		#' @seealso [join_keys()]
442		#'
443		#' @export
444		join_key <- function(dataset_1, dataset_2, keys) {
445	458x	checkmate::assert_string(dataset_1)
446	458x	checkmate::assert_string(dataset_2)
447	455x	checkmate::assert_character(keys, any.missing = FALSE)
448
449	453x	if (length(keys) > 0) {
450	409x	if (is.null(names(keys))) {
451	122x	names(keys) <- keys
452		}
453
454	409x	if (any(names(keys) == "")) {
455	4x	names(keys)[names(keys) == "" & keys != ""] <- keys[names(keys) == "" & keys != ""]
456		}
457
458	409x	stopifnot(!is.null(names(keys)))
459	409x	stopifnot(!anyDuplicated(keys))
460	408x	stopifnot(!anyDuplicated(names(keys)))
461		}
462
463	451x	if (dataset_1 == dataset_2 && any(names(keys) != keys)) {
464	1x	stop("Keys within a dataset must match exactly: keys = c('A' = 'B') are not allowed")
465		}
466
467	450x	structure(
468	450x	list(
469	450x	dataset_1 = dataset_1,
470	450x	dataset_2 = dataset_2,
471	450x	keys = keys
472		),
473	450x	class = "JoinKeySet"
474		)
475		}

1		#' Retrieve raw data
2		#'
3		#' @param x (`TealDataset`, `TealDatasetConnector`, `TealDataAbstract`)\cr
4		#' object
5		#' @param dataname (`character`)\cr
6		#' Name of dataset to return raw data for.
7		#'
8		#' @description `r lifecycle::badge("stable")`
9		#'
10		#' @return `data.frame` with the raw data inserted into the R6 objects. In case of
11		#' `TealDataAbstract`, `list` of `data.frame` can be returned
12		#' if user doesn't specify `dataname` - (`get_raw_data` from all datasets).
13		#'
14		#' @export
15		get_raw_data <- function(x, dataname = NULL) {
16	214x	checkmate::assert_string(dataname, null.ok = TRUE)
17	213x	UseMethod("get_raw_data")
18		}
19
20		#' @export
21		#' @rdname get_raw_data
22		#' @examples
23		#'
24		#' # TealDataset ---------
25		#' ADSL <- teal.data::example_cdisc_data("ADSL")
26		#'
27		#' x <- dataset(dataname = "ADSL", x = ADSL)
28		#' get_raw_data(x)
29		get_raw_data.TealDataset <- function(x, dataname = NULL) {
30	192x	if (!is.null(dataname)) {
31	2x	warning("'dataname' argument ignored - TealDataset can contain only one dataset.")
32		}
33	192x	x$get_raw_data()
34		}
35
36		#' @export
37		#' @rdname get_raw_data
38		#' @examples
39		#'
40		#' # TealDatasetConnector ---------
41		#' library(magrittr)
42		#' pull_fun_adsl <- callable_function(teal.data::example_cdisc_data) %>%
43		#' set_args(list(dataname = "ADSL"))
44		#' dc <- dataset_connector("ADSL", pull_fun_adsl)
45		#' load_dataset(dc)
46		#' get_raw_data(dc)
47		get_raw_data.TealDatasetConnector <- function(x, dataname = NULL) { # nolint
48	17x	if (!is.null(dataname)) {
49	1x	warning("'dataname' argument ignored - TealDatasetConnector can contain only one dataset.")
50		}
51	17x	x$get_raw_data()
52		}
53
54		#' @rdname get_raw_data
55		#' @export
56		#' @examples
57		#'
58		#' # TealData ----------------
59		#' adsl <- cdisc_dataset(
60		#' dataname = "ADSL",
61		#' x = teal.data::example_cdisc_data("ADSL"),
62		#' code = "library(teal.data)\nADSL <- teal.data::example_cdisc_data(\"ADSL\")"
63		#' )
64		#'
65		#' adtte <- cdisc_dataset(
66		#' dataname = "ADTTE",
67		#' x = teal.data::example_cdisc_data("ADTTE"),
68		#' code = "library(teal.data)\nADTTE <- teal.data::example_cdisc_data(\"ADTTE\")"
69		#' )
70		#'
71		#' rd <- teal.data:::TealData$new(adsl, adtte)
72		#' get_raw_data(rd)
73		#'
74		#' # TealDataConnector --------
75		#' library(magrittr)
76		#'
77		#' slice_cdisc_data <- function(dataname, n) {
78		#' head(example_cdisc_data(dataname), n)
79		#' }
80		#'
81		#' random_data_connector <- function(dataname) {
82		#' fun_dataset_connector(
83		#' dataname = dataname,
84		#' fun = slice_cdisc_data,
85		#' fun_args = list(dataname = dataname),
86		#' )
87		#' }
88		#'
89		#' open_fun <- callable_function(library)
90		#' open_fun$set_args(list(package = "teal.data"))
91		#'
92		#' con <- data_connection(open_fun = open_fun)
93		#' con$set_open_server(
94		#' function(id, connection) {
95		#' moduleServer(
96		#' id = id,
97		#' module = function(input, output, session) {
98		#' connection$open(try = TRUE)
99		#' return(invisible(connection))
100		#' }
101		#' )
102		#' }
103		#' )
104		#'
105		#' rdc <- relational_data_connector(
106		#' connection = con,
107		#' connectors = list(random_data_connector("ADSL"), random_data_connector("ADLB"))
108		#' )
109		#'
110		#' rdc$set_ui(
111		#' function(id, connection, connectors) {
112		#' ns <- NS(id)
113		#' tagList(
114		#' connection$get_open_ui(ns("open_connection")),
115		#' numericInput(inputId = ns("n"), label = "Choose number of records", min = 0, value = 1),
116		#' do.call(
117		#' what = "tagList",
118		#' args = lapply(
119		#' connectors,
120		#' function(connector) {
121		#' div(
122		#' connector$get_ui(
123		#' id = ns(connector$get_dataname())
124		#' ),
125		#' br()
126		#' )
127		#' }
128		#' )
129		#' )
130		#' )
131		#' }
132		#' )
133		#'
134		#' rdc$set_server(
135		#' function(id, connection, connectors) {
136		#' moduleServer(
137		#' id = id,
138		#' module = function(input, output, session) {
139		#' # opens connection
140		#' connection$get_open_server()(id = "open_connection", connection = connection)
141		#' if (connection$is_opened()) {
142		#' for (connector in connectors) {
143		#' set_args(connector, args = list(n = input$n))
144		#' # pull each dataset
145		#' connector$get_server()(id = connector$get_dataname())
146		#' if (connector$is_failed()) {
147		#' break
148		#' }
149		#' }
150		#' }
151		#' }
152		#' )
153		#' }
154		#' )
155		#'
156		#' \dontrun{
157		#' load_datasets(rdc)
158		#' get_raw_data(rdc)
159		#' }
160		#'
161		#' # TealData (with connectors) --------
162		#' drc <- cdisc_data(rdc)
163		#' \dontrun{
164		#' get_raw_data(drc)
165		#' }
166		get_raw_data.TealDataAbstract <- function(x, dataname = NULL) { # nolint
167	4x	if (!is.null(dataname)) {
168	!	datasets_names <- x$get_datanames()
169	!	if (dataname %in% datasets_names) {
170	!	if (is_pulled(x$get_items(dataname))) {
171	!	get_raw_data(
172	!	get_dataset(x, dataname = dataname)
173		)
174		} else {
175	!	stop(
176	!	sprintf("'%s' has not been pulled yet\n - please use `load_dataset()` first.", dataname),
177	!	call. = FALSE
178		)
179		}
180		} else {
181	!	stop("The dataname supplied does not exist.")
182		}
183		} else {
184	4x	lapply(
185	4x	get_datasets(x),
186	4x	get_raw_data
187		)
188		}
189		}

1		## `CodeClass` ====
2		#'
3		#' @title Code Class
4		#' @keywords internal
5		#'
6		#' @examples
7		#' cc <- teal.data:::CodeClass$new()
8		#' cc$set_code(c("foo <- function() {1}", "foo2 <- function() {2}"))
9		#' cc$get_code()
10		#' cc$get_code(deparse = FALSE)
11		#'
12		#' cc$set_code(c("DF <- data.frame(x = 1:10)", "DF$y <- 1"), "DF")
13		#' cc$set_code("DF$a <- foo()", "DF")
14		#'
15		#' # dependent dataset
16		#' cc$set_code(c("DF2 <- data.frame(x2 = 1:10)", "DF2$y2 <- DF$y"), "DF2", deps = "DF")
17		#'
18		#' cc$set_code("baz <- function() {2}")
19		#' cc$set_code("DF2$a <- baz()", "DF2")
20		#'
21		#' cc$get_code()
22		#' cc$get_code("DF")
23		#' cc$get_code("DF2")
24		#'
25		#'
26		#' x1 <- teal.data:::CodeClass$new()
27		#' x1$set_code("DF <- data.frame(x = 1:10)", "DF")
28		#' x1$get_code()
29		#'
30		#' x2 <- teal.data:::CodeClass$new()
31		#' x2$set_code(c("DF2 <- data.frame(x2 = 1:10)", "DF2$x2 <- DF$x"), "DF2", deps = "DF")
32		#' x2$get_code()
33		#'
34		#' x <- teal.data:::CodeClass$new()
35		#' x$append(x1)
36		#' x$append(x2)
37		#'
38		#' x$get_code()
39		#' x$get_code("DF")
40		#' x$get_code("DF2")
41		#' x$get_code(c("DF", "DF2"))
42		#'
43		#' x3 <- teal.data:::CodeClass$new()
44		#' x3$set_code("DF3 <- data.frame(x3 = 1:10) ", "DF3")
45		#' x3$get_code()
46		#'
47		#' x$append(x3)
48		#' x$get_code("DF3")
49		#'
50		#' # mutation simulation
51		#' x$set_code("DF3$x <- foo(DF$x)", "DF3", deps = "DF")
52		#' x$get_code("DF3")
53		CodeClass <- R6::R6Class( # nolint
54		"CodeClass",
55		## __Public Methods ====
56		public = list(
57		#' @description
58		#' `CodeClass` constructor
59		#' @param code (`character`) vector of code text to be set
60		#' @param dataname optional, (`character`) vector of `datanames` to assign code to. If empty then the code
61		#' is considered to be "global"
62		#' @param deps optional, (`character`) vector of `datanames` that given code depends on
63		#' @return object of class `CodeClass`
64		initialize = function(code = character(0), dataname = character(0), deps = character(0)) {
65	3518x	if (length(code) > 0) {
66	13x	self$set_code(code, dataname, deps)
67		}
68	3518x	logger::log_trace("CodeClass initialized.")
69	3518x	return(invisible(self))
70		},
71		#' @description
72		#' Append `CodeClass` object to a given `CodeClass` object
73		#' @param x (`CodeClass`) object to be appended
74		#' @return changed `CodeClass` object
75		append = function(x) {
76	3022x	stopifnot(inherits(x, "CodeClass"))
77	3022x	if (length(x$code) > 0) {
78	1458x	for (code_i in x$code) {
79	2782x	private$set_code_single(code_i)
80		}
81	1458x	logger::log_trace("CodeClass$append CodeClass appended.")
82		}
83
84	3022x	return(invisible(self))
85		},
86		#' @description
87		#' Set code in form of character
88		#' @param code (`character`) vector of code text to be set
89		#' @param dataname optional, (`character`) vector of `datanames` to assign code to. If empty then the code
90		#' is considered to be "global"
91		#' @param deps optional, (`character`) vector of `datanames` that given code depends on
92		#'
93		#' @return changed `CodeClass` object
94		set_code = function(code, dataname = character(0), deps = character(0)) {
95	793x	checkmate::assert_character(code, min.len = 1, any.missing = FALSE)
96	793x	checkmate::assert_character(dataname, any.missing = FALSE)
97	793x	stopifnot(!(dataname %in% deps))
98
99	793x	code <- pretty_code_string(code)
100
101	793x	for (code_single in code) {
102	822x	private$set_code_single(code_single, dataname, deps)
103		}
104	793x	logger::log_trace("CodeClass$set_code code set.")
105	793x	return(invisible(self))
106		},
107		#' @description
108		#' Get the code for a given data names
109		#' @param dataname optional, (`character`) vector of `datanames` for which the code is extracted.
110		#' If `NULL` then get the code for all data names
111		#' @param deparse optional, (`logical`) whether to return the deparsed form of a call
112		#' @return `character` or `list` of calls
113		get_code = function(dataname = NULL, deparse = TRUE) {
114	273x	checkmate::assert_character(dataname, min.len = 1, null.ok = TRUE, any.missing = FALSE)
115	273x	checkmate::assert_flag(deparse)
116	273x	if (is.null(dataname)) {
117	234x	private$get_code_all(deparse = deparse)
118		} else {
119	39x	private$get_code_dataname(dataname = dataname, deparse = deparse)
120		}
121		},
122		#' @description
123		#' Evaluates internal code within given environment
124		#' @param envir (`environment`) environment in which code will be evaluated
125		#' @return invisibly `NULL`
126		eval = function(envir = new.env(parent = parent.env(.GlobalEnv))) {
127	88x	for (x in self$get_code(deparse = FALSE)) {
128	121x	out <- tryCatch(
129	121x	base::eval(x, envir = envir),
130	121x	error = function(e) e
131		)
132
133	121x	if (inherits(out, "error")) {
134	4x	error_msg <- sprintf(
135	4x	"%s\n\nEvaluation of the code failed:\n %s", deparse1(x, collapse = "\n"), conditionMessage(out)
136		)
137
138	4x	rlang::with_options(
139	4x	stop(error_msg, call. = FALSE),
140	4x	warning.length = max(min(8170, nchar(error_msg) + 30), 100)
141		)
142		}
143		}
144	84x	logger::log_trace("CodeClass$eval successfuly evaluated the code.")
145	84x	return(invisible(NULL))
146		}
147		),
148		private = list(
149		## __Private Fields ====
150		.code = list(),
151		deps = list(),
152		## __Private Methods ====
153		set_code_single = function(code,
154		dataname = attr(code, "dataname"),
155		deps = attr(code, "deps"),
156		id = attr(code, "id")) {
157	!	if (is.null(dataname)) dataname <- character(0)
158	418x	if (is.null(deps)) deps <- character(0)
159	822x	if (is.null(id)) id <- digest::digest(c(private$.code, code))
160		# Line shouldn't be added when it contains the same code and the same `dataname`
161		# as a line already present in an object of `CodeClass`
162		if (
163	3604x	!id %in% unlist(lapply(private$.code, "attr", "id")) \|\|
164	3604x	all(
165	3604x	vapply(dataname, FUN.VALUE = logical(1), FUN = function(x) {
166	206x	!x %in% unlist(lapply(private$.code, "attr", "dataname"))
167		})
168		)
169		) {
170	3399x	attr(code, "dataname") <- dataname
171	3399x	attr(code, "deps") <- deps
172	3399x	attr(code, "id") <- id
173
174	3399x	private$.code <- base::append(private$.code, list(code))
175		}
176	3604x	return(invisible(NULL))
177		},
178		get_code_all = function(deparse) {
179	234x	private$get_code_idx(idx = seq_along(private$.code), deparse = deparse)
180		},
181		get_code_dataname = function(dataname, deparse) {
182		# the lines of code we need for the dataname
183	39x	res <- integer(0)
184		# the set of datanames we want code for code for initially just dataname
185	39x	datanames <- dataname
186
187		# loop backwards along code
188	39x	for (idx in rev(seq_along(private$.code))) {
189	170x	code_entry <- private$.code[[idx]]
190
191		# line of code is one we want if it is not empty and
192		# has any dataname attribute in the vector datanames or dataname starts with * or is global code and
193		# already have some lines of code selected
194		if (
195		(
196	170x	any(datanames %in% attr(code_entry, "dataname")) \|\|
197	170x	any(grepl("^[*]", attr(code_entry, "dataname"))) \|\|
198	170x	(length(res) > 0 && length(attr(code_entry, "dataname")) == 0)
199		) &&
200	170x	length(code_entry) > 0
201		) {
202		# append to index of code we want
203	92x	res <- c(idx, res)
204
205		# and update datasets we want for preceding code with additional datanames and deps
206	92x	datanames <- unique(c(datanames, attr(code_entry, "dataname"), attr(code_entry, "deps")))
207		}
208		}
209	39x	private$get_code_idx(idx = res, deparse = deparse)
210		},
211		get_code_idx = function(idx, deparse) {
212	273x	if (isFALSE(deparse)) {
213	107x	return(Filter(
214	107x	Negate(is.null),
215	107x	unname(unlist(lapply(
216	107x	private$.code[idx],
217	107x	function(x) sapply(x, function(i) text_to_call(i), simplify = FALSE)
218		)))
219		))
220		} else {
221	166x	return(paste0(unlist(private$.code[idx]), collapse = "\n"))
222		}
223		}
224		),
225
226		## __Active Fields ====
227		active = list(
228		#' @field code (`list`) Derive the code of the dataset.
229		code = function() {
230	4541x	private$.code
231		}
232		)
233		)
234
235
236		## Functions ====
237
238		# Convert named list to `CodeClass` utilizing both `TealDatasetConnector` and `TealDataset`
239		list_to_code_class <- function(x) {
240	1112x	checkmate::assert_list(x, min.len = 0, names = "unique")
241
242	1112x	res <- CodeClass$new()
243
244	1112x	if (length(x) > 0) {
245	163x	for (var_idx in seq_along(x)) {
246	179x	var_value <- x[[var_idx]]
247	179x	var_name <- names(x)[[var_idx]]
248	179x	if (inherits(var_value, "TealDatasetConnector") \|\| inherits(var_value, "TealDataset")) {
249	172x	res$append(var_value$get_code_class())
250	172x	if (var_name != var_value$get_dataname()) {
251	136x	res$set_code(
252	136x	deparse1(call("<-", as.name(var_name), as.name(var_value$get_dataname())), collapse = "\n"),
253	136x	dataname = var_value$get_dataname()
254		)
255		}
256		} else {
257	7x	var_code <- deparse1(call("<-", as.name(var_name), var_value), collapse = "\n")
258	7x	res$set_code(var_code, var_name)
259		}
260		}
261		}
262	1112x	return(res)
263		}
264
265		#' Create call from string
266		#'
267		#' @param x (`character`) string containing the code.
268		#'
269		#' @return (`call`) object.
270		#' @keywords internal
271		text_to_call <- function(x) {
272	169x	parsed <- parse(text = x, keep.source = FALSE)
273	169x	if (length(parsed) == 0) {
274	4x	return(NULL)
275		} else {
276	165x	return(as.list(as.call(parsed))[[1]])
277		}
278		}
279
280		#' Format a vector of code into a string
281		#'
282		#' @param code_vector (`character`) vector containing lines of
283		#' code to format into a string.
284		#'
285		#' @return (`character`) string containing the formatted code.
286		#' @keywords internal
287		pretty_code_string <- function(code_vector) {
288		# in order to remove bad formatting: text -> code -> text
289	812x	unlist(lapply(
290	812x	code_vector,
291	812x	function(code_single) {
292	814x	if (length(parse(text = code_single, keep.source = FALSE)) == 0) {
293		# if string code cannot be passed into expression (e.g. code comment) then pass on the string
294	11x	code_single
295		} else {
296	803x	vapply(
297	803x	as.list(as.call(parse(text = code_single, keep.source = FALSE))),
298	803x	deparse1,
299	803x	character(1),
300	803x	collapse = "\n"
301		)
302		}
303		}
304		))
305		}

1		## CallablePythonCode ====
2		#'
3		#' @title A `CallablePythonCode` class of objects
4		#' @keywords internal
5		#'
6		CallablePythonCode <- R6::R6Class( # nolint
7
8		## __Public Methods ====
9		classname = "CallablePythonCode",
10		inherit = CallableFunction,
11		public = list(
12		#' @description
13		#' Create a new `CallablePythonCode` object
14		#'
15		#' @param fun (`function`)\cr
16		#' function to be evaluated in class. Function should be named
17		#' @param env (\code{environment})\cr
18		#' environment where the result of python code evaluation are stored
19		#' @return new `CallablePythonCode` object
20		initialize = function(fun, env = new.env(parent = parent.env(globalenv()))) {
21	!	if (!requireNamespace("reticulate", quietly = TRUE)) {
22	!	stop("Cannot load package 'reticulate' - please install the package.", call. = FALSE)
23		}
24	!	if (utils::packageVersion("reticulate") < 1.22) {
25	!	stop("Please upgrade package 'reticulate', teal.data requires version >= 1.22")
26		}
27
28	!	super$initialize(fun = fun, env = env)
29	!	logger::log_trace("CallablePythonCode initialized.")
30	!	return(invisible(self))
31		},
32		#' @description
33		#' For scripts and code that contain multiple objects, save the name
34		#' of the object that corresponds to the final dataset of interest.
35		#' This is required for running python scripts with `reticulate`.
36		#'
37		#' @param x (`character`) the name of the object produced by the code
38		#' or script.
39		#'
40		#' @return (`self`) invisibly for chaining.
41		set_object = function(x) {
42	!	private$object <- x
43	!	private$refresh()
44	!	logger::log_trace("CallablePythonCode$set_object object set.")
45	!	return(invisible(self))
46		},
47		#' @description
48		#' Execute `Callable` python code.
49		#'
50		#' @param args (`NULL` or named `list`)\cr
51		#' supplied for callable functions only, these are dynamic arguments passed to
52		#' `reticulate::py_run_string` or `reticulate::py_run_file`. Dynamic arguments
53		#' are executed in this call and are not saved which means that `self$get_call()`
54		#' won't include them later.
55		#' @param try (`logical` value)\cr
56		#' whether perform function evaluation inside `try` clause
57		#'
58		#' @return nothing or output from function depending on `return`
59		#' argument. If `run` fails it will return object of class `simple-error` error
60		#' when `try = TRUE` or will stop if `try = FALSE`.
61		run = function(args = NULL, try = FALSE) {
62	!	rlang::with_options(
63	!	res <- super$run(args = args, try = try),
64	!	reticulate.engine.environment = private$env
65		)
66	!	if (is.null(res)) {
67	!	stop("The specified python object returned NULL or does not exist in the python code")
68		}
69	!	res
70		}
71		),
72
73		## __Private Fields ====
74		private = list(
75		object = NULL,
76
77		## __Private Methods ====
78		# @description
79		# Refresh call with function name and saved arguments
80		#
81		# @return nothing
82		refresh = function() {
83		# replaced str2lang found at:
84		# https://rlang.r-lib.org/reference/call2.html
85	!	private$call <- as.call(
86	!	c(rlang::parse_expr(private$fun_name), private$args)
87		)
88
89	!	private$call <- rlang::parse_expr(
90	!	sprintf("%s[[%s]]", deparse1(private$call, collapse = "\n"), deparse1(private$object, collapse = "\n"))
91		)
92		}
93		)
94		)
95		## PythonCodeClass ====
96		#'
97		#' @title A `CallablePythonCode` class of objects
98		#' @description `r lifecycle::badge("experimental")`
99		#'
100		PythonCodeClass <- R6::R6Class( # nolint
101		classname = "PythonCodeClass",
102		inherit = CodeClass,
103
104		## __Public Methods ====
105		public = list(
106		#' @description
107		#' Evaluates internal code within environment
108		#'
109		#' @param vars (named `list`) additional pre-requisite vars to execute code
110		#' @param dataname (`character`) name of the data frame object to be returned
111		#' @param envir (`environment`) environment in which code will be evaluated
112		#'
113		#' @return `data.frame` containing the mutated dataset
114		eval = function(vars = list(), dataname = NULL, envir = new.env(parent = parent.env(.GlobalEnv))) {
115	!	checkmate::assert_list(vars, min.len = 0, names = "unique")
116	!	execution_environment <- envir
117
118	!	for (vars_idx in seq_along(vars)) {
119	!	var_name <- names(vars)[[vars_idx]]
120	!	var_value <- vars[[vars_idx]]
121	!	if (inherits(var_value, "TealDatasetConnector") \|\| inherits(var_value, "TealDataset")) {
122	!	var_value <- get_raw_data(var_value)
123		}
124	!	assign(envir = execution_environment, x = var_name, value = var_value)
125		}
126
127		# execute
128	!	rlang::with_options(
129	!	super$eval(envir = execution_environment),
130	!	reticulate.engine.environment = execution_environment
131		)
132
133		# return early if only executing and not grabbing the dataset
134	!	if (is.null(dataname)) {
135	!	return(as.environment(as.list(execution_environment)))
136		}
137
138	!	if (!is.data.frame(execution_environment[[dataname]])) {
139	!	out_msg <- sprintf(
140	!	"\n%s\n\n - Code from %s needs to return a data.frame assigned to an object of dataset name.",
141	!	self$get_code(),
142	!	self$get_dataname()
143		)
144
145	!	rlang::with_options(
146	!	.expr = stop(out_msg, call. = FALSE),
147	!	warning.length = max(min(8170, nchar(out_msg) + 30), 100)
148		)
149		}
150
151	!	new_set <- execution_environment[[dataname]]
152	!	logger::log_trace("PythonCodeClass$eval successfuly evaluated the code.")
153
154	!	return(new_set)
155		}
156		)
157		)
158
159		#' Python Code
160		#'
161		#' `r lifecycle::badge("experimental")`
162		#' Create a python code object directly from python code or a
163		#' script containing python code.
164		#'
165		#' @details
166		#' Used to mutate dataset connector objects with python code. See
167		#' [`mutate_dataset`] or [`mutate_data`] for details.
168		#'
169		#' @param code (`character`)\cr
170		#' Code to mutate the dataset. Must contain the `dataset$dataname`.
171		#' @param script (`character`)\cr
172		#' file that contains python Code that can be read using `reticulate::py_run_script`.
173		#'
174		#' @return (`PythonCodeClass`) object containing python code
175		#' @export
176		#'
177		#' @examples
178		#' \dontrun{
179		#' library(reticulate)
180		#' library(magrittr)
181		#'
182		#' # mutate dataset object
183		#'
184		#' random_data_connector <- function(dataname) {
185		#' fun_dataset_connector(
186		#' dataname = dataname,
187		#' fun = teal.data::example_cdisc_data,
188		#' fun_args = list(dataname = dataname),
189		#' )
190		#' }
191		#' x <- random_data_connector(dataname = "ADSL")
192		#'
193		#' x %>% mutate_dataset(python_code("import pandas as pd
194		#' r.ADSL = pd.DataFrame({'x': [1]})"))
195		#'
196		#' x$get_code()
197		#' x$pull()
198		#' x$get_raw_data()
199		#'
200		#' # mutate data object
201		#'
202		#' y <- 8
203		#' tc <- cdisc_data(
204		#' random_data_connector(dataname = "ADSL"),
205		#' random_data_connector(dataname = "ADLB")
206		#' )
207		#'
208		#' tc %>% mutate_data(python_code("import pandas as pd
209		#' r.ADSL = pd.DataFrame({'STUDYID': [r.y], 'USUBJID': [r.y]})"), vars = list(y = y))
210		#'
211		#'
212		#' load_datasets(tc) # submit all
213		#' ds <- tc$get_dataset("ADSL")
214		#' ds$get_raw_data()
215		#' }
216		python_code <- function(code = character(0), script = character(0)) {
217	!	if (!xor(missing(code), missing(script))) stop("Exactly one of 'code' and 'script' is required")
218
219	!	if (length(script) > 0) {
220	!	code <- deparse(call("py_run_file", script))
221		} else {
222	!	code <- deparse(call("py_run_string", code))
223		}
224	!	py <- PythonCodeClass$new()
225	!	py$set_code(code)
226
227	!	return(py)
228		}

1		# TealDataConnector ------
2		#'
3		#'
4		#' @title Manage multiple and `TealDatasetConnector` of the same type.
5		#'
6		#' @description `r lifecycle::badge("stable")`
7		#' Class manages `TealDatasetConnector` to specify additional dynamic arguments and to
8		#' open/close connection.
9		#'
10		#' @param connection (`TealDataConnection`)\cr
11		#' connection to data source
12		#' @param connectors (`list` of `TealDatasetConnector` elements)\cr
13		#' list with dataset connectors
14		#'
15		#' @examples
16		#' library(magrittr)
17		#'
18		#' random_data_connector <- function(dataname) {
19		#' fun_dataset_connector(
20		#' dataname = dataname,
21		#' fun = teal.data::example_cdisc_data,
22		#' fun_args = list(dataname = dataname),
23		#' )
24		#' }
25		#'
26		#' open_fun <- callable_function(library)
27		#' open_fun$set_args(list(package = "teal.data"))
28		#'
29		#' con <- data_connection(open_fun = open_fun)
30		#' con$set_open_server(
31		#' function(id, connection) {
32		#' moduleServer(
33		#' id = id,
34		#' module = function(input, output, session) {
35		#' connection$open(try = TRUE)
36		#' return(invisible(connection))
37		#' }
38		#' )
39		#' }
40		#' )
41		#'
42		#' x <- teal.data:::TealDataConnector$new(
43		#' connection = con,
44		#' connectors = list(
45		#' random_data_connector(dataname = "ADSL"),
46		#' random_data_connector(dataname = "ADLB")
47		#' )
48		#' )
49		#'
50		#' x$set_ui(
51		#' function(id, connection, connectors) {
52		#' ns <- NS(id)
53		#' tagList(
54		#' connection$get_open_ui(ns("open_connection")),
55		#' numericInput(inputId = ns("n"), label = "Choose number of records", min = 0, value = 1),
56		#' do.call(
57		#' what = "tagList",
58		#' args = lapply(
59		#' connectors,
60		#' function(connector) {
61		#' div(
62		#' connector$get_ui(
63		#' id = ns(connector$get_dataname())
64		#' ),
65		#' br()
66		#' )
67		#' }
68		#' )
69		#' )
70		#' )
71		#' }
72		#' )
73		#'
74		#' x$set_server(
75		#' function(id, connection, connectors) {
76		#' moduleServer(
77		#' id = id,
78		#' module = function(input, output, session) {
79		#' # opens connection
80		#' connection$get_open_server()(id = "open_connection", connection = connection)
81		#' if (connection$is_opened()) {
82		#' for (connector in connectors) {
83		#' set_args(connector, args = list(n = input$n))
84		#' # pull each dataset
85		#' connector$get_server()(id = connector$get_dataname())
86		#' if (connector$is_failed()) {
87		#' break
88		#' }
89		#' }
90		#' }
91		#' }
92		#' )
93		#' }
94		#' )
95		#' \dontrun{
96		#' x$launch()
97		#' x$get_datasets()
98		#' }
99		TealDataConnector <- R6::R6Class( # nolint
100		classname = "TealDataConnector",
101		inherit = TealDataAbstract,
102
103		## __Public Methods ====
104		public = list(
105		#' @description
106		#' Create a new `TealDataConnector` object
107		initialize = function(connection, connectors) {
108	18x	checkmate::assert_list(connectors, types = "TealDatasetConnector", min.len = 1)
109
110	18x	connectors_names <- vapply(connectors, get_dataname, character(1))
111	18x	connectors <- setNames(connectors, connectors_names)
112
113	18x	private$check_names(connectors_names)
114
115	18x	if (!missing(connection)) {
116	18x	stopifnot(inherits(connection, "TealDataConnection"))
117	18x	private$connection <- connection
118		}
119
120	18x	private$datasets <- connectors
121
122	18x	private$pull_code <- CodeClass$new()
123	18x	private$mutate_code <- CodeClass$new()
124
125	18x	self$id <- sample.int(1e11, 1, useHash = TRUE)
126
127
128	18x	logger::log_trace(
129	18x	"TealDataConnector initialized with data: { paste(self$get_datanames(), collapse = ' ') }."
130		)
131	18x	return(invisible(self))
132		},
133		#' @description
134		#' Prints this `TealDataConnector`.
135		#'
136		#' @param ... additional arguments to the printing method
137		#' @return invisibly self
138		print = function(...) {
139	1x	check_ellipsis(...)
140
141	1x	cat(sprintf(
142	1x	"A currently %s %s object containing %d TealDataset/TealDatasetConnector object(s) as element(s).\n",
143	1x	ifelse(self$get_connection()$is_opened(), "opened", "not yet opened"),
144	1x	class(self)[1],
145	1x	length(private$datasets)
146		))
147	1x	cat(sprintf(
148	1x	"%d of which is/are loaded/pulled:\n",
149	1x	sum(vapply(private$datasets, function(x) x$is_pulled(), FUN.VALUE = logical(1)))
150		))
151
152	1x	for (i in seq_along(private$datasets)) {
153	2x	cat(sprintf("--> Element %d:\n", i))
154	2x	print(private$datasets[[i]])
155		}
156
157	1x	invisible(self)
158		},
159
160		# ___ getters ====
161		#' @description
162		#' Get connection to data source
163		#'
164		#' @return connector's connection
165		get_connection = function() {
166	1x	return(private$connection)
167		},
168		#' @description
169		#' Get internal `CodeClass` object
170		#'
171		#' @return `CodeClass`
172		get_code_class = function() {
173	30x	all_code <- CodeClass$new()
174
175	30x	open_connection_code <- if (!is.null(private$connection)) {
176	30x	private$connection$get_open_call(deparse = TRUE)
177		} else {
178	!	NULL
179		}
180
181	30x	if (!is.null(open_connection_code)) {
182	30x	all_code$set_code(open_connection_code, dataname = "*open")
183		}
184	30x	datasets_code_class <- private$get_datasets_code_class()
185	30x	all_code$append(datasets_code_class)
186
187	30x	close_connection_code <- if (!is.null(private$connection)) {
188	30x	private$connection$get_close_call(deparse = TRUE, silent = TRUE)
189		} else {
190	!	NULL
191		}
192
193	30x	if (!is.null(close_connection_code)) {
194	!	all_code$set_code(close_connection_code, dataname = "*close")
195		}
196
197	30x	mutate_code_class <- private$get_mutate_code_class()
198	30x	all_code$append(mutate_code_class)
199
200	30x	return(all_code)
201		},
202		#' @description get the server function
203		#'
204		#' @return the `server` function
205		get_server = function() {
206	2x	if (is.null(private$server)) {
207	!	stop("No server function set yet. Please use set_server method first.")
208		}
209	2x	function(id, connection = private$connection, connectors = private$datasets) {
210	!	rv <- reactiveVal(NULL)
211	!	moduleServer(
212	!	id = id,
213	!	module = function(input, output, session) {
214	!	private$server(id = "data_input", connection = connection, connectors = connectors)
215		}
216		)
217
218	!	if (self$is_pulled()) {
219	!	return(rv(TRUE))
220		} else {
221	!	return(rv(FALSE))
222		}
223		}
224		},
225		#' @description get the `preopen` server function
226		#'
227		#' @return the `server` function
228		get_preopen_server = function() {
229	!	function(id, connection = private$connection) {
230	!	if (!is.null(private$preopen_server)) {
231	!	moduleServer(
232	!	id = id,
233	!	module = function(input, output, session) {
234	!	private$preopen_server(id = "data_input", connection = connection)
235		}
236		)
237		}
238		}
239		},
240		#' @description
241		#' Get Shiny module with inputs for all `TealDatasetConnector` objects
242		#'
243		#' @param id `character` shiny element id
244		#'
245		#' @return the `ui` function
246		get_ui = function(id) {
247	3x	if (is.null(private$ui)) {
248	1x	stop("No UI set yet. Please use set_ui method first.")
249		}
250	2x	x <- function(id, connection = private$connection, connectors = private$datasets) {
251	2x	ns <- NS(id)
252	2x	tags$div(
253	2x	h3("Data Connector for:", lapply(self$get_datanames(), code)),
254	2x	tags$div(
255	2x	id = ns("data_input"),
256	2x	private$ui(id = ns("data_input"), connection = connection, connectors = connectors)
257		)
258		)
259		}
260	2x	x(id)
261		},
262
263		# ___ setters ====
264		#' @description
265		#' Set argument to the `pull_fun`
266		#'
267		#' @param args (named `list`)\cr
268		#' arguments values as separate list elements named by argument name. These arguments
269		#' are passed to each dataset.
270		#'
271		#' @return nothing
272		set_pull_args = function(args) {
273	1x	lapply(private$datasets, function(x) set_args(x, args))
274	1x	logger::log_trace("TealDataConnector$set_pull_args pull args set.")
275	1x	return(invisible(NULL))
276		},
277		#' @description
278		#' Set connector UI function
279		#'
280		#' @param f (`function`)\cr
281		#' shiny module as function. Inputs specified in this `ui` are passed to server module
282		#' defined by `set_server` method.
283		#'
284		#' @return nothing
285		set_ui = function(f) {
286	4x	stopifnot(inherits(f, "function"))
287	4x	stopifnot("id" %in% names(formals(f)))
288	4x	stopifnot(all(c("connection", "connectors") %in% names(formals(f))) \|\| "..." %in% names(formals(f)))
289	4x	private$ui <- f
290	4x	logger::log_trace("TealDataConnector$set_ui ui set.")
291	4x	return(invisible(NULL))
292		},
293		#' @description
294		#' Set connector server function
295		#'
296		#' This function will be called after submit button will be hit. There is no possibility to
297		#' specify some dynamic `ui` as `server` function is executed after hitting submit
298		#' button.
299		#'
300		#' @param f (`function`)\cr
301		#' A shiny module server function that should load data from all connectors
302		#'
303		#' @return nothing
304		set_server = function(f) {
305	2x	stopifnot(inherits(f, "function"))
306	2x	stopifnot(all(c("id", "connection", "connectors") %in% names(formals(f))))
307	2x	private$server <- f
308	2x	logger::log_trace("TealDataConnector$set_server server set.")
309	2x	return(invisible(NULL))
310		},
311		#' @description
312		#' Set connector pre-open server function
313		#'
314		#' This function will be called before submit button will be hit.
315		#'
316		#' @param f (`function`)\cr
317		#' A shiny module server function
318		#'
319		#' @return nothing
320		set_preopen_server = function(f) {
321	!	stopifnot(inherits(f, "function"))
322	!	stopifnot(all(c("id", "connection") %in% names(formals(f))))
323	!	private$preopen_server <- f
324	!	logger::log_trace("TealDataConnector$set_preopen_server preopen_server set.")
325	!	return(invisible(NULL))
326		},
327
328		# ___ pull ====
329		#' @description
330		#' Load data from each `TealDatasetConnector`
331		#'
332		#' @param con_args (`NULL` or named `list`)\cr
333		#' additional dynamic arguments for connection function. `args` will be passed to each
334		#' `TealDatasetConnector` object to evaluate `CallableFunction` assigned to
335		#' this dataset. If `args` is null than default set of arguments will be used, otherwise
336		#' call will be executed on these arguments only (arguments set before will be ignored).
337		#' `pull` function doesn't update reproducible call, it's just evaluate function.
338		#'
339		#' @param args (`NULL` or named `list`)\cr
340		#' additional dynamic arguments to pull dataset. `args` will be passed to each
341		#' `TealDatasetConnector` object to evaluate `CallableFunction` assigned to
342		#' this dataset. If `args` is null than default set of arguments will be used, otherwise
343		#' call will be executed on these arguments only (arguments set before will be ignored).
344		#' `pull` function doesn't update reproducible call, it's just evaluate function.
345		#'
346		#' @param try (`logical` value)\cr
347		#' whether perform function evaluation inside `try` clause
348		#'
349		#' @return (`self`) invisibly for chaining. In order to get the data please use `get_datasets` method.
350		pull = function(con_args = NULL, args = NULL, try = TRUE) {
351	3x	logger::log_trace("TealDataConnector$pull pulling data...")
352		# open connection
353	3x	if (!is.null(private$connection)) {
354	3x	private$connection$open(args = con_args, try = try)
355
356	3x	conn <- private$connection$get_conn()
357	3x	for (connector in private$datasets) {
358	4x	connector$get_pull_callable()$assign_to_env("conn", conn)
359		}
360		}
361
362		# load datasets
363	3x	for (dataset in private$datasets) {
364	4x	load_dataset(dataset, args = args)
365		}
366
367		# close connection
368	3x	if (!is.null(private$connection)) private$connection$close(silent = TRUE)
369
370	3x	logger::log_trace("TealDataConnector$pull data pulled.")
371
372	3x	return(invisible(self))
373		},
374		#' @description
375		#' Run simple application that uses its `ui` and `server` fields to pull data from
376		#' connection.
377		#'
378		#' Useful for debugging
379		#'
380		#' @return An object that represents the app
381		launch = function() {
382		# load TealDatasetConnector objects
383	!	if (self$is_pulled()) {
384	!	stop("All the datasets have already been pulled.")
385		}
386
387	!	shinyApp(
388	!	ui = fluidPage(
389	!	include_js_files(),
390	!	theme = get_teal_bs_theme(),
391	!	fluidRow(
392	!	column(
393	!	width = 8,
394	!	offset = 2,
395	!	tags$div(
396	!	id = "data_inputs",
397	!	self$get_ui(id = "data_connector"),
398	!	actionButton("submit", "Submit"),
399	!	`data-proxy-click` = "submit" # handled by jscode in custom.js - hit enter to submit
400		),
401	!	shinyjs::hidden(
402	!	tags$div(
403	!	id = "data_loaded",
404	!	div(
405	!	h3("Data successfully loaded."),
406	!	p("You can close this window and get back to R console.")
407		)
408		)
409		)
410		)
411		)
412		),
413	!	server = function(input, output, session) {
414	!	session$onSessionEnded(stopApp)
415	!	self$get_preopen_server()(
416	!	id = "data_connector",
417	!	connection = private$connection
418		)
419	!	observeEvent(input$submit, {
420	!	rv <- reactiveVal(NULL)
421	!	rv(
422	!	self$get_server()(
423	!	id = "data_connector",
424	!	connection = private$connection,
425	!	connectors = private$datasets
426		)
427		)
428
429	!	observeEvent(rv(), {
430	!	if (self$is_pulled()) {
431	!	removeUI(sprintf("#%s", session$ns("data_inputs")))
432	!	shinyjs::show("data_loaded")
433	!	stopApp()
434		}
435		})
436		})
437		}
438		)
439		},
440
441		# ___ mutate ====
442		#' @description
443		#' Mutate data by code.
444		#'
445		#' @param ... parameters inherited from `TealDataAbstract`.
446		#'
447		#' @return Informational message to not use mutate_data() with `TealDataConnectors`.
448		mutate = function(...) {
449	!	stop("TealDataConnectors do not support mutate_data().
450	!	Please use mutate_data() with teal_data() or cdisc_data()")
451		},
452
453		# ___ status ====
454		#' @description
455		#' Check if pull or connection has not failed.
456		#'
457		#' @return `TRUE` if pull or connection failed, else `FALSE`
458		is_failed = function() {
459	!	private$connection$is_failed() \|\|
460	!	any(vapply(private$datasets, function(x) x$is_failed(), logical(1)))
461		}
462		),
463		## __Private Fields ====
464		private = list(
465		server = NULL, # shiny server function
466		preopen_server = NULL, # shiny server function
467		ui = NULL, # shiny ui function
468		connection = NULL, # TealDataConnection
469
470		## __Private Methods ====
471		# adds open/close connection code at beginning/end of the dataset code
472		append_connection_code = function() {
473	!	lapply(
474	!	private$datasets,
475	!	function(connector) {
476	!	dataset <- get_dataset(connector)
477	!	try(
478	!	dataset$set_code(code = paste(
479	!	c(
480	!	if (!is.null(private$connection)) private$connection$get_open_call(deparse = TRUE),
481	!	get_code(dataset, deparse = TRUE, FUN.VALUE = character(1)),
482	!	if (!is.null(private$connection)) private$connection$get_close_call(deparse = TRUE, silent = TRUE)
483		),
484	!	collapse = "\n"
485		))
486		)
487		}
488		)
489		}
490		)
491		)
492
493		#' The constructor for `TealDataConnector` class.
494		#'
495		#' @description `r lifecycle::badge("stable")`
496		#' @param connection (`TealDataConnection`)\cr
497		#' connection to data source
498		#' @param connectors (`list` of `TealDatasetConnector` elements)\cr
499		#' list with dataset connectors
500		#'
501		#' @examples
502		#' library(magrittr)
503		#' random_data_connector <- function(dataname) {
504		#' fun_dataset_connector(
505		#' dataname = dataname,
506		#' fun = teal.data::example_cdisc_data,
507		#' fun_args = list(dataname = dataname),
508		#' )
509		#' }
510		#'
511		#' open_fun <- callable_function(library)
512		#' open_fun$set_args(list(package = "teal.data"))
513		#'
514		#' con <- data_connection(open_fun = open_fun)
515		#' con$set_open_server(
516		#' function(id, connection) {
517		#' moduleServer(
518		#' id = id,
519		#' module = function(input, output, session) {
520		#' connection$open(try = TRUE)
521		#' return(invisible(connection))
522		#' }
523		#' )
524		#' }
525		#' )
526		#'
527		#' x <- relational_data_connector(
528		#' connection = con,
529		#' connectors = list(
530		#' random_data_connector(dataname = "ADSL"),
531		#' random_data_connector(dataname = "ADLB")
532		#' )
533		#' )
534		#'
535		#' x$set_ui(
536		#' function(id, connection, connectors) {
537		#' ns <- NS(id)
538		#' tagList(
539		#' connection$get_open_ui(ns("open_connection")),
540		#' numericInput(inputId = ns("n"), label = "Choose number of records", min = 0, value = 1),
541		#' do.call(
542		#' what = "tagList",
543		#' args = lapply(
544		#' connectors,
545		#' function(connector) {
546		#' div(
547		#' connector$get_ui(
548		#' id = ns(connector$get_dataname())
549		#' ),
550		#' br()
551		#' )
552		#' }
553		#' )
554		#' )
555		#' )
556		#' }
557		#' )
558		#'
559		#' x$set_server(
560		#' function(id, connection, connectors) {
561		#' moduleServer(
562		#' id = id,
563		#' module = function(input, output, session) {
564		#' # opens connection
565		#' connection$get_open_server()(id = "open_connection", connection = connection)
566		#' if (connection$is_opened()) {
567		#' for (connector in connectors) {
568		#' set_args(connector, args = list(n = input$n))
569		#' # pull each dataset
570		#' connector$get_server()(id = connector$get_dataname())
571		#' if (connector$is_failed()) {
572		#' break
573		#' }
574		#' }
575		#' }
576		#' }
577		#' )
578		#' }
579		#' )
580		#' \dontrun{
581		#' x$launch()
582		#' x$get_datasets()
583		#' }
584		#'
585		#' @return `TealDataConnector` object
586		#' @export
587		relational_data_connector <- function(connection, connectors) {
588	2x	stopifnot(inherits(connection, "TealDataConnection"))
589	2x	checkmate::assert_list(connectors, types = "TealDatasetConnector", min.len = 1)
590	2x	TealDataConnector$new(connection, connectors)
591		}

1		## CallableFunction ====
2		#'
3		#' @title A \code{CallableFunction} class of objects
4		#'
5		#' @description Object that stores a function name together with its arguments.
6		#' Methods are then available to get the function call and evaluate it.
7		#'
8		#' @keywords internal
9		#'
10		CallableFunction <- R6::R6Class( # nolint
11		"CallableFunction",
12		inherit = Callable,
13
14		## __Public Methods ====
15		public = list(
16		#' @description
17		#' Create a new \code{CallableFunction} object
18		#'
19		#' @param fun (\code{function})\cr
20		#' function to be evaluated in class.
21		#' This is either a `function` object or its name as a string.
22		#' @param env (\code{environment})\cr
23		#' environment where function will be evaluated
24		#'
25		#' @return new \code{CallableFunction} object
26		initialize = function(fun, env = new.env(parent = parent.env(globalenv()))) {
27	210x	super$initialize(env = env)
28	210x	if (missing(fun)) {
29	1x	stop("A valid function name must be provided.")
30		}
31	209x	if (!(checkmate::test_string(fun) \|\| is.function(fun) \|\| is.call(fun) \|\| is.symbol(fun))) {
32	1x	stop("CallableFunction can be specified as character, symbol, call or function")
33		}
34
35	207x	fun_name <- private$get_callable_function(fun)
36	202x	private$fun_name <- deparse1(fun_name, collapse = "\n")
37
38	202x	private$refresh()
39
40	202x	logger::log_trace("CallableFunction initialized with function: { deparse1(private$fun_name) }.")
41
42	202x	return(invisible(self))
43		},
44		#' @description
45		#' get the arguments a function gets called with
46		#'
47		#' @return arguments the function gets called with
48		get_args = function() {
49	3x	return(private$args)
50		},
51		#' @description
52		#' Get function call with substituted arguments in \code{args}.
53		#' These arguments will not be stored in the object.
54		#'
55		#' @param deparse (\code{logical} value)\cr
56		#' whether to return a deparsed version of call
57		#' @param args (\code{NULL} or named \code{list})\cr
58		#' dynamic arguments to function
59		#'
60		#' @return \code{call} or \code{character} depending on \code{deparse} argument
61		get_call = function(deparse = TRUE, args = NULL) {
62	479x	checkmate::assert_flag(deparse)
63	479x	checkmate::assert_list(args, names = "strict", min.len = 0, null.ok = TRUE)
64
65	479x	old_args <- private$args
66	6x	if (length(args) > 0) self$set_args(args)
67
68	479x	res <- if (deparse) {
69	28x	deparse1(private$call, collapse = "\n")
70		} else {
71	451x	private$call
72		}
73
74		# set args back to default
75	479x	if (length(args) > 0) {
76	6x	lapply(names(args), self$set_arg_value, NULL)
77	6x	self$set_args(old_args)
78		}
79
80	479x	return(res)
81		},
82		#' @description
83		#' Set up function arguments
84		#'
85		#' @param args (\code{NULL} or named \code{list})\cr
86		#' function arguments to be stored persistently in the object. Setting \code{args} doesn't
87		#' remove other \code{args}, only create new of modify previous of the same name.
88		#' To clean arguments specify \code{args = NULL}.
89		#'
90		#' @return (`self`) invisibly for chaining.
91		set_args = function(args) {
92		# remove args if empty
93	94x	if (length(args) == 0) {
94	6x	private$args <- NULL
95	6x	private$refresh()
96	6x	return(invisible(self))
97		}
98	88x	checkmate::assert_list(args, min.len = 0, names = "unique")
99
100	88x	for (idx in seq_along(args)) {
101	121x	self$set_arg_value(
102	121x	name = names(args)[[idx]],
103	121x	value = args[[idx]]
104		)
105		}
106	88x	logger::log_trace(
107	88x	"CallableFunction$set_args args set for function: { deparse1(private$fun_name) }."
108		)
109
110	88x	return(invisible(self))
111		},
112		#' @description
113		#' Set up single function argument with value
114		#'
115		#' @param name (\code{character}) argument name
116		#' @param value argument value
117		#'
118		#' @return (`self`) invisibly for chaining.
119		set_arg_value = function(name, value) {
120	130x	checkmate::assert_string(name)
121	130x	arg_names <- names(formals(eval(str2lang(private$fun_name))))
122	130x	stopifnot(name %in% arg_names \|\| "..." %in% arg_names \|\| is.null(arg_names))
123
124	130x	if (length(private$args) == 0) {
125	80x	private$args <- list()
126		}
127	130x	private$args[[name]] <- value
128
129	130x	private$refresh()
130	130x	logger::log_trace("CallableFunction$set_arg_value args values set for arg: { deparse1(name) }.")
131
132	130x	return(invisible(self))
133		}
134		),
135
136		## __Private Fields ====
137		private = list(
138		fun_name = character(0),
139		args = NULL, # named list with argument names and values
140		## __Private Methods ====
141		# @description
142		# Refresh call with function name and saved arguments
143		#
144		# @return nothing
145		refresh = function() {
146	338x	if (!is.null(private$fun_name) \|\| !identical(private$fun_name, character(0))) {
147
148		# replaced str2lang found at:
149		# https://rlang.r-lib.org/reference/call2.html
150	338x	private$call <- as.call(
151	338x	c(rlang::parse_expr(private$fun_name), private$args)
152		)
153
154		# exception for source(...)$value
155	338x	if (private$fun_name == "source") {
156	9x	private$call <- rlang::parse_expr(
157	9x	sprintf("%s$value", deparse1(private$call, collapse = "\n"))
158		)
159	329x	} else if (private$fun_name %in% c("py_run_file", "py_run_string")) {
160	!	private$call <- rlang::parse_expr(
161	!	sprintf("%s[[%s]]", deparse1(private$call, collapse = "\n"), deparse1(private$object, collapse = "\n"))
162		)
163		}
164		}
165		},
166		# @description
167		# Returns a call to a function
168		#
169		# Returns the call to the function as defined in the enclosing environment.
170		#
171		# @param callable \code{function, character, call, symbol} the function to return
172		#
173		# @return `call` the call to the function
174		#
175		get_callable_function = function(callable) {
176	207x	if (is.character(callable) && private$is_prefixed_function(callable)) {
177	11x	private$get_call_from_prefixed_function(callable)
178		} else {
179	196x	private$get_call_from_symbol(callable)
180		}
181		},
182		# @param function_name (`character`) the function name prefixed with \code{::}
183		# and the package name
184		# @return `call` the call to the function passed to this method
185		get_call_from_prefixed_function = function(function_name) {
186	11x	package_function_names <- strsplit(function_name, "::")[[1]]
187	11x	fun <- get(package_function_names[2], envir = getNamespace(package_function_names[1]))
188	11x	if (!is.function(fun)) {
189	1x	stop(sprintf("object '%s' of mode 'function' was not found", function_name))
190		}
191	10x	str2lang(function_name)
192		},
193		# @param symbol (`function`, `symbol` or `character`) the item matching a function
194		# @return `call` the call to the function passed to this method
195		get_call_from_symbol = function(symbol) {
196	196x	fun <- match.fun(symbol)
197	192x	fun_environment <- environment(fun)
198	192x	if (isNamespace(fun_environment)) {
199	69x	fun_name <- get_binding_name(fun, fun_environment)
200	69x	namespace_name <- strsplit(rlang::env_name(fun_environment), ":")[[1]][2]
201	69x	if (namespace_name != "base") {
202	8x	fun_name <- paste(namespace_name, fun_name, sep = "::")
203		}
204	69x	fun <- str2lang(fun_name)
205		}
206	192x	fun
207		},
208		# Checks whether a character vector is of this format
209		# <package_name>::<function_name>
210		#
211		# @param function_name (`character`) the character vector
212		# @return `logical` `TRUE` if \code{function_name} is of the specified
213		# format; `FALSE` otherwise
214		#
215		is_prefixed_function = function(function_name) {
216	18x	grepl("^[[:ascii:]]+::[[:ascii:]]+$", function_name, perl = TRUE)
217		}
218		)
219		)
220
221		## Constructors ====
222
223		#' Create \code{CallableFunction} object
224		#'
225		#' @description `r lifecycle::badge("stable")`
226		#' Create \code{\link{CallableFunction}} object to execute specific function and get reproducible
227		#' call.
228		#'
229		#' @param fun (\code{function})\cr
230		#' any R function, directly by name or \code{character} string.
231		#'
232		#' @return \code{CallableFunction} object
233		#'
234		#' @export
235		#'
236		#' @examples
237		#' cf <- callable_function(fun = stats::median)
238		#' cf$set_args(list(x = 1:10, na.rm = FALSE))
239		#' cf$run()
240		#' cf$get_call()
241		callable_function <- function(fun) {
242	160x	CallableFunction$new(fun)
243		}
244
245		#' Gets the name of the binding
246		#'
247		#' Gets the name of the object by finding its origin.
248		#' Depending on type of object function uses different methods
249		#' to obtain original location. If no `env` is specified then
250		#' object is tracked by `substitute` along the `sys.frames`.
251		#' If `env` is specified then search is limited to specified
252		#' environment.\cr
253		#'
254		#' @note
255		#' Raises an error if the object is not found in the environment.
256		#'
257		#' @param object (R object)\cr
258		#' any R object
259		#' @param envir (`environment`)\cr
260		#' if origin of the object is known then should be provided for
261		#' more precise search
262		#' @return character
263		#' @keywords internal
264		#'
265		get_binding_name <- function(object, envir) {
266	70x	bindings_names <- ls(envir)
267	70x	identical_binding_mask <- vapply(
268	70x	bindings_names,
269	70x	function(binding_name) identical(get(binding_name, envir), object),
270	70x	FUN.VALUE = logical(1),
271	70x	USE.NAMES = FALSE
272		)
273	70x	if (length(bindings_names[identical_binding_mask]) == 0) {
274	1x	stop("Object not found in the environment")
275		}
276	69x	bindings_names[identical_binding_mask]
277		}

1		#' Get dataset from `TealDatasetConnector`
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' Get dataset from `TealDatasetConnector`
6		#' @param x (`TealDatasetConnector` or `TealDatasetConnector` or `TealDataAbstract`)
7		#' @param dataname (`character`) a name of dataset to be retrieved
8		#' @details See `help(TealDataConnector)` and `help(TealData)` for more complex examples.
9		#' @return (`TealDataset`)
10		#' @export
11		get_dataset <- function(x, dataname) {
12	131x	UseMethod("get_dataset")
13		}
14
15		#' @rdname get_dataset
16		#' @export
17		#' @examples
18		#'
19		#' # TealDatasetConnector --------
20		#' library(magrittr)
21		#'
22		#' pull_fun_adae <- callable_function(teal.data::example_cdisc_data) %>%
23		#' set_args(list(dataname = "ADAE"))
24		#'
25		#' ADSL <- teal.data::example_cdisc_data("ADSL")
26		#'
27		#' dc <- dataset_connector(
28		#' dataname = "ADAE", pull_callable = pull_fun_adae,
29		#' keys = get_cdisc_keys("ADSL")
30		#' )
31		#'
32		#' \dontrun{
33		#' load_dataset(dc)
34		#' get_dataset(dc)
35		#' }
36		#'
37		get_dataset.TealDatasetConnector <- function(x, dataname = NULL) { # nolint
38	47x	if (!is.null(dataname)) {
39	!	warning("'dataname' argument ignored - TealDatasetConnector can contain only one dataset.")
40		}
41	47x	return(x$get_dataset())
42		}
43
44		#' @rdname get_dataset
45		#' @export
46		#' @examples
47		#'
48		#' # TealDataset --------
49		#' ADSL <- example_cdisc_data("ADSL")
50		#' x <- dataset("ADSL", ADSL)
51		#'
52		#' get_dataset(x)
53		get_dataset.TealDataset <- function(x, dataname = NULL) { # nolint
54	84x	if (!is.null(dataname)) {
55	!	warning("'dataname' argument ignored - TealDataset can contain only one dataset.")
56		}
57	84x	return(x$get_dataset())
58		}
59
60		#' @rdname get_dataset
61		#' @export
62		#' @examples
63		#'
64		#' # TealData (not containing connectors) --------
65		#' adsl <- cdisc_dataset(
66		#' dataname = "ADSL",
67		#' x = example_cdisc_data("ADSL"),
68		#' code = "library(teal.data)\nADSL <- example_cdisc_data(\"ADSL\")"
69		#' )
70		#'
71		#' adae <- cdisc_dataset(
72		#' dataname = "ADAE",
73		#' x = example_cdisc_data("ADAE"),
74		#' code = "library(teal.data)\nADAE <- example_cdisc_data(\"ADAE\")"
75		#' )
76		#'
77		#' rd <- teal.data:::TealData$new(adsl, adae)
78		#' get_dataset(rd, "ADSL")
79		get_dataset.TealDataAbstract <- function(x, dataname = NULL) {
80	!	if (is.null(dataname)) {
81	!	stop(paste(
82	!	"To get single dataset from data class one must specify the name of the dataset.",
83	!	"To get all datasets please use get_datasets()"
84		))
85		}
86	!	return(x$get_dataset(dataname = dataname))
87		}

1		#' Get code
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#' Reads code from specified files or an R6 object.
5		#'
6		#' \itemize{
7		#' \item{if reading from R6: }{get the R code stored inside the object.}
8		#' \item{if reading from files: }{
9		#' Includes code from source if reading from files. Method reads code without
10		#' }
11		#' }
12		#' `library()` or `require()` calls. Function created for teal app, but can be used with any file.
13		#' Get code from certain files and for specific datasets
14		#'
15		#' Reads code from specified files and specific code chunks.
16		#'
17		#' Code chunks are described with:
18		#'
19		#' \itemize{
20		#' \item{to open chunk }{`#code>` or `#code ADSL>` or `#code ADSL ADTTE>`}
21		#' \item{to close chunk }{`#<code` or `#<ADSL code` or `#<ADSL ADTTE code`}
22		#' }
23		#'
24		#' @param x ([`TealDatasetConnector`] or [`TealDataset`]). If of class `character` will be treated as file to read.
25		#' @param exclude_comments (`logical`) whether exclude commented-out lines of code. Lines to be excluded
26		#' should be ended with `# nocode`. For multiple line exclusions one should enclose ignored block of code with
27		#' `# nocode>` and `# <nocode`
28		#' @param read_sources (`logical`) whether to replace `source("path")` with code lines from sourced file.
29		#' If `read_sources = TRUE` changing working directory inside preprocessing is not allowed.
30		#' @param deparse (`logical`) whether return deparsed form of a call
31		#' @param files_path (`character`) (optional) vector of files path to be read for preprocessing. Code from
32		#' multiple files is joined together.
33		#' @param dataname (`character`) Name of dataset to return code for.
34		#' @param ... not used, only for support of S3
35		#' @export
36		#' @return (`character`) code of import and preparation of data for teal application.
37		get_code <- function(x, ...) {
38	59x	UseMethod("get_code")
39		}
40
41
42		# Getting code from R6 ====
43
44		#' @export
45		#' @rdname get_code
46		get_code.TealDatasetConnector <- function(x, deparse = TRUE, ...) {
47	5x	check_ellipsis(...)
48	5x	x$get_code(deparse = deparse)
49		}
50
51		#' @export
52		#' @rdname get_code
53		get_code.TealDataset <- function(x, deparse = TRUE, ...) {
54	12x	check_ellipsis(...)
55	12x	x$get_code(deparse = deparse)
56		}
57
58
59		#' @rdname get_code
60		#' @export
61		#' @examples
62		#' x1 <- dataset(
63		#' x = data.frame(x = c(1, 2), y = c("a", "b"), stringsAsFactors = FALSE),
64		#' keys = "y",
65		#' dataname = "XY",
66		#' code = "XY <- data.frame(x = c(1, 2), y = c('aa', 'bb'), stringsAsFactors = FALSE)",
67		#' label = character(0)
68		#' )
69		#'
70		#' x2 <- dataset(
71		#' x = data.frame(x = c(1, 2), y = c("a", "b"), stringsAsFactors = FALSE),
72		#' keys = "y",
73		#' dataname = "XYZ",
74		#' code = "XYZ <- data.frame(x = c(1, 2), y = c('aa', 'bb'), stringsAsFactors = FALSE)",
75		#' label = character(0)
76		#' )
77		#'
78		#' rd <- teal_data(x1, x2)
79		#'
80		#' get_code(rd)
81		#' get_code(rd, "XY")
82		#' get_code(rd, "XYZ")
83		get_code.TealDataAbstract <- function(x, dataname = character(0), deparse = TRUE, ...) { # nolint
84	7x	check_ellipsis(...)
85	7x	if (length(dataname) > 0) {
86	4x	if (any(!(dataname %in% x$get_datanames()))) {
87	!	stop("The dataname provided does not exist")
88		}
89	4x	x$get_code(dataname = dataname, deparse = deparse)
90		} else {
91	3x	x$get_code(deparse = deparse)
92		}
93		}
94
95		# Getting code from files ====
96
97		#' @rdname get_code
98		#' @export
99		get_code.default <- function(x,
100		exclude_comments = TRUE,
101		read_sources = TRUE,
102		deparse = FALSE,
103		files_path = NULL,
104		dataname = NULL,
105		...) {
106	35x	if (!is.null(files_path)) {
107	31x	x <- files_path
108		}
109
110	35x	check_ellipsis(...)
111	35x	checkmate::assert_character(x, min.len = 1, any.missing = FALSE)
112	35x	checkmate::assert_flag(exclude_comments)
113	32x	checkmate::assert_flag(read_sources)
114
115	30x	if (!methods::hasArg(dataname)) {
116	11x	l_lines <- lapply(x, function(file_path) {
117	11x	code_exclude(
118	11x	enclosed_with(
119	11x	get_code_single(file_path, read_sources = read_sources)
120		),
121	11x	lines,
122	11x	exclude_comments = exclude_comments
123		)
124		})
125		} else {
126	19x	l_lines <- lapply(x, function(file_path) {
127	19x	code_exclude(
128	19x	enclosed_with_dataname(
129	19x	get_code_single(file_path, read_sources = read_sources),
130	19x	dataname = dataname
131		),
132	19x	lines,
133	19x	exclude_comments = exclude_comments
134		)
135		})
136		}
137
138	27x	lines <- unlist(l_lines)
139	27x	if (deparse) {
140	!	return(paste(
141	!	vapply(lines, FUN = deparse1, collapse = "\n", FUN.VALUE = character(1)),
142	!	collapse = "\n"
143		))
144		} else {
145	27x	return(paste(lines, collapse = "\n"))
146		}
147		}
148
149
150
151		# * Sub functions for getting code from files ====
152
153		#' Get code
154		#'
155		#' Get code from specified file.
156		#' @param file_path (`character`) path or URL address of the file to be parsed
157		#' @param if_url (`logical`) (optional) TRUE when URL address is provided
158		#' @inheritParams get_code
159		#'
160		#' @return lines (`character`) of preprocessing code
161		#' @keywords internal
162		get_code_single <- function(file_path, read_sources, if_url = grepl("^http[s]", file_path)) {
163	84x	checkmate::assert_string(file_path)
164	84x	if (!if_url) {
165	84x	if (!file.exists(file_path)) {
166	2x	stop(
167	2x	"Reading preprocessing code from ", file_path, " file failed. ",
168	2x	"Please double check if you saved your script."
169		)
170		}
171		}
172	82x	checkmate::assert_flag(read_sources)
173	82x	checkmate::assert_flag(if_url)
174
175	82x	lines <- readLines(file_path)
176	82x	if (read_sources) {
177	80x	lines <- include_source_code(lines = lines, dir = `if`(if_url, NULL, dirname(file_path)))
178		}
179
180	82x	lines
181		}
182
183		#' Get code enclosed within
184		#'
185		#' Extracts lines from code which are enclosed within regexp starts_at and stops_at
186		#' @param lines (`character`) of preprocessing code.
187		#' @return (`character`) subset of lines which start and end with preprocessing
188		#' start and stop tags.
189		#' @keywords internal
190		enclosed_with <- function(lines) {
191	11x	checkmate::assert_character(lines, min.len = 1, any.missing = FALSE)
192
193		# set beginning of preprocessing
194	9x	idx_start <- grep("#\\s*code>", lines)
195	9x	line_starts <- if (length(idx_start) > 1) {
196	!	warning("More than one preproc start found - using the first one.")
197	!	idx_start[1] + 1
198	9x	} else if (length(idx_start) == 1) {
199	7x	idx_start + 1
200		} else {
201	2x	1L
202		}
203
204		# set stop of preprocessing
205	9x	idx_stop <- grep("#\\s*<code", lines)
206	9x	line_stops <- if (length(idx_stop) > 1) {
207	!	warning("More than one preproc stops found - using the last one.")
208	!	utils::tail(idx_stop, 1) - 1
209	9x	} else if (length(idx_stop) == 1) {
210	7x	idx_stop - 1
211		} else {
212	2x	length(lines)
213		}
214
215	9x	line_numbers <- seq(line_starts, line_stops)
216
217	9x	lines[line_numbers]
218		}
219
220		#' Get code enclosed within
221		#'
222		#' Extracts lines from code which are enclosed within regexp starts_at and stops_at
223		#' @inheritParams enclosed_with
224		#' @param dataname (`character`) metadata for returned lines
225		#' @return (`list`) list of lines and their numbers from certain chunks of code at the specific file.
226		#' @keywords internal
227		enclosed_with_dataname <- function(lines, dataname = NULL) {
228	21x	checkmate::assert_character(lines, min.len = 1, any.missing = FALSE)
229	21x	if (!checkmate::test_character(dataname, min.len = 1, any.missing = FALSE)) {
230	4x	dataname <- ""
231		}
232	21x	dataname <- trimws(dataname)
233	21x	any_chunk <- any(grepl("#\\s<?\\scode", lines))
234
235	21x	if (any_chunk) {
236	17x	any_start <- any(grepl(sprintf("#\\scode[\\sa-zA-Z_]%s[\\sa-zA-Z_]*>", dataname), lines, perl = TRUE))
237	17x	any_stop <- any(grepl(sprintf("#\\s<[\\sa-zA-Z_]%s[\\sa-zA-Z_]*(?<![a-zA-Z])code", dataname), lines, perl = TRUE))
238
239	17x	if (!(any_start && any_stop)) {
240	1x	stop(sprintf("File doesn't contain code marked for this %1$s.\n
241	1x	Please use # code %1$s> to indicate which lines should be extracted.", dataname))
242		}
243		}
244
245		# set beginning of preprocessing
246	20x	idx_start <- grep(sprintf("#\\scode(?:[\\sa-zA-Z_]%s[\\sa-zA-Z_]\|[\\s])>", dataname), lines, perl = TRUE)
247	20x	line_starts <- if (length(idx_start) >= 1) {
248	16x	idx_start + 1
249		} else {
250	4x	1L
251		}
252
253		# set stop of preprocessing
254	20x	idx_stop <- grep(
255	20x	sprintf("#\\s<(?:[\\sa-zA-Z_]%s[\\sa-zA-Z_]\|[\\s])(?<![a-zA-Z])code", dataname),
256	20x	lines,
257	20x	perl = TRUE
258		)
259	20x	line_stops <- if (length(idx_stop) >= 1) {
260	16x	idx_stop - 1
261		} else {
262	4x	length(lines)
263		}
264
265	20x	if (length(line_starts) != length(line_stops) \|\| any(line_starts > line_stops)) {
266	!	stop("Number of #code> has to be the same as #<code")
267		}
268
269
270	20x	ll <- data.frame(line_starts, line_stops)
271
272	20x	line_numbers <- apply(ll, 1, function(x) seq(x[1], x[2]))
273
274	20x	lines_taken <- as.integer(unlist(line_numbers))
275
276	20x	res_lines <- lines[lines_taken]
277
278	20x	return(res_lines)
279		}
280
281		#' Exclude from code
282		#'
283		#' Excludes lines from code. It is possible to exclude one line ended by `# nocode`
284		#' @inheritParams enclosed_with
285		#' @inheritParams get_code
286		#' @inheritParams get_code_single
287		#' @keywords internal
288		code_exclude <- function(lines, exclude_comments, file_path) {
289	32x	checkmate::assert_character(lines, min.len = 1, any.missing = FALSE)
290	29x	checkmate::assert_flag(exclude_comments)
291
292	29x	nocode_single <- grep("^.+#[[:space:]]*nocode", lines)
293	29x	nocode_start <- grep("[[:space:]]#[[:space:]]nocode[[:space:]]*>+", lines)
294	29x	nocode_stop <- grep("[[:space:]]#[[:space:]]<+[[:space:]]nocode[[:space:]]", lines)
295
296	29x	if (length(nocode_start) != length(nocode_stop)) {
297	!	stop(paste("Unequal number of no-code starts and stops in ", file_path)) # nolint
298		}
299
300	29x	nocode_multi <- NULL
301	29x	if (length(nocode_start) > 0) {
302	10x	nocode_multi <- unlist(Map(seq, from = nocode_start, to = nocode_stop))
303		}
304
305	29x	nocode <- c(nocode_single, nocode_multi)
306
307	29x	if (length(nocode) > 0) {
308	19x	lines <- lines[-nocode]
309		}
310
311	29x	if (exclude_comments) {
312	10x	lines <- grep("^\\s*#.+$", x = lines, invert = TRUE, value = TRUE)
313	10x	lines <- gsub("(^\\s#.+$)\|(#[^\'\"]$)", "", x = lines, perl = TRUE)
314		}
315
316	29x	lines
317		}
318
319		#' Finds lines of code with source call
320		#'
321		#' Finds lines in preprocessing code where `source()` call is located
322		#' @inheritParams enclosed_with
323		#' @keywords internal
324		find_source_code <- function(lines) {
325	80x	checkmate::assert_character(lines, min.len = 1, any.missing = FALSE)
326	80x	idx <- grep("^[^#]source\\([\'\"]([A-Za-z0-9_/.]).\\.R[\'\"].\\).$", lines)
327
328	80x	if (length(idx) == 0) {
329	45x	return(idx)
330		}
331
332	35x	if (any(grepl("source\\([^)]chdir\\s=\\sT(RUE)", x = lines[idx]))) {
333	!	stop("Preprocessing doesn't handle source(chdir = TRUE)")
334		}
335
336	35x	if (any(grepl("source\\(.+;\\s*source\\(", x = lines[idx]))) {
337	!	stop("Preprocessing doesn't handle multiple sources in one line\n")
338		}
339
340	35x	idx
341		}
342
343		#' Includes source in preprocessing code lines
344		#'
345		#' @inheritParams enclosed_with
346		#' @param dir of the file where source is called from.
347		#' @return lines of code with source text included
348		#' @keywords internal
349		include_source_code <- function(lines, dir = NULL) {
350	80x	checkmate::assert_character(lines, min.len = 1, any.missing = FALSE)
351	80x	stopifnot(is.null(dir) \|\| dir.exists(dir))
352
353
354	80x	idx <- find_source_code(lines)
355
356	80x	if (length(idx) == 0) {
357	45x	return(lines)
358		}
359
360	35x	sources_path <- unname(vapply(
361	35x	lines[idx],
362	35x	function(x) {
363	52x	res <- gsub("source\\(.*[\"\']([A-Za-z0-9_/.])", "\\1", strsplit(x, ",")[[1]][1])
364	52x	res <- gsub("[\'\"]", "", res)
365	52x	res <- gsub(")", "", res)
366	52x	res
367		},
368	35x	character(1)
369		))
370
371	35x	if (length(sources_path) != length(idx)) {
372	!	stop("Couldn't detect R file name from source() call.")
373		}
374
375	35x	sources_code <- lapply(sources_path, function(s) {
376	52x	if (grepl("^http[s]", s)) {
377		# url detected - do nothing
378		} else {
379	52x	s <- ifelse(grepl("^(/)\|^([\\])\|^([A-Za-z]:)", s), s, file.path(dir, s))
380	52x	if (!all(file.exists(s))) {
381	!	msg <- paste0(
382	!	"File(s) provided in the source() calls don't exist: \n",
383	!	paste(s[!file.exists(s)], collapse = "\n")
384		)
385	!	stop(msg)
386		}
387
388	52x	s <- normalizePath(s)
389		}
390
391	52x	get_code_single(file_path = s, read_sources = TRUE)
392		})
393
394	35x	lines[idx] <- sources_code
395	35x	lines <- unlist(lines)
396
397	35x	lines
398		}

1		## TealDataAbstract ====
2		#' @title `TealDataAbstract` class
3		#'
4		#' @description
5		#' Abstract class containing code for handling set of datasets.
6		#' @keywords internal
7		TealDataAbstract <- R6::R6Class( # nolint
8		classname = "TealDataAbstract",
9		## __Public Methods ====
10		public = list(
11		#' @description
12		#' Cannot create a `TealDataAbstract` object
13		#'
14		#' @return throws error
15		initialize = function() {
16	1x	stop("Pure virtual method")
17		},
18		#' @description
19		#' Check if the object raw data is reproducible from the `get_code()` code.
20		#' @return
21		#' `NULL` if check step has been disabled
22		#' `TRUE` if all the datasets generated from evaluating the
23		#' `get_code()` code are identical to the raw data, else `FALSE`.
24		check = function() {
25		# code can be put only to the mutate with empty code in datasets
26	57x	res <- if (isFALSE(private$.check)) {
27	44x	NULL
28		} else {
29	13x	if (length(private$pull_code$code) > 0) {
30	1x	private$check_combined_code()
31		} else {
32	12x	all(vapply(
33	12x	private$datasets,
34	12x	function(x) {
35	27x	check_res <- x$check()
36		# NULL is still ok
37	26x	is.null(check_res) \|\| isTRUE(check_res)
38		},
39	12x	logical(1)
40		))
41		}
42		}
43	56x	private$check_result <- res
44	56x	logger::log_trace("TealDataAbstract$check executed the code to reproduce the data - result: { res }.")
45	56x	res
46		},
47		#' @description
48		#' Execute `check()` and raise an error if it's not reproducible.
49		#' @return error if code is not reproducible else invisibly nothing
50		check_reproducibility = function() {
51	47x	self$check()
52	47x	if (isFALSE(self$get_check_result())) {
53	2x	stop("Reproducibility check failed.")
54		}
55	45x	logger::log_trace("TealDataAbstract$check_reproducibility reproducibility check passed.")
56	45x	return(invisible(NULL))
57		},
58		#' @description
59		#' Execute mutate code. Using `mutate_data(set).TealDataAbstract`
60		#' does not cause instant execution, the `mutate_code` is
61		#' delayed and can be evaluated using this method.
62		execute_mutate = function() {
63	2x	logger::log_trace("TealDataAbstract$execute_mutate evaluating mutate code...")
64		# this will be pulled already! - not needed?
65	2x	if (length(private$mutate_code$code) == 0) {
66	1x	res <- unlist(lapply(
67	1x	private$datasets,
68	1x	function(x) {
69	2x	if (is_pulled(x)) {
70	2x	get_datasets(x)
71		} else {
72	!	NULL
73		}
74		}
75		))
76		# exit early if mutate isn't required
77	1x	logger::log_trace("TealDataAbstract$execute_mutate no code to evaluate.")
78	1x	if (!is.null(res)) {
79	1x	res <- stats::setNames(res, vapply(res, get_dataname, character(1)))
80		}
81	1x	return(res)
82		}
83
84	1x	if (inherits(private$mutate_code, "PythonCodeClass")) {
85	!	items <- lapply(self$get_items(), get_raw_data)
86	!	datasets <- stats::setNames(items, vapply(self$get_items(), get_dataname, character(1)))
87
88	!	new_env <- private$mutate_code$eval(vars = c(datasets, private$mutate_vars))
89		} else {
90		# have to evaluate post-processing code (i.e. private$mutate_code) before returning dataset
91	1x	new_env <- new.env(parent = parent.env(globalenv()))
92	1x	for (dataset in self$get_items()) {
93	2x	assign(get_dataname(dataset), get_raw_data(dataset), envir = new_env)
94		}
95
96	1x	for (var_idx in seq_along(private$mutate_vars)) {
97	!	mutate_var <- private$mutate_vars[[var_idx]]
98	!	assign(
99	!	x = names(private$mutate_vars)[[var_idx]],
100	!	value = `if`(
101	!	inherits(mutate_var, "TealDataset") \|\| inherits(mutate_var, "TealDatasetConnector"),
102	!	get_raw_data(mutate_var),
103	!	mutate_var
104		),
105	!	envir = new_env
106		)
107		}
108
109	1x	private$mutate_code$eval(envir = new_env)
110		}
111
112	1x	lapply(
113	1x	self$get_datasets(),
114	1x	function(x) {
115	2x	x$recreate(
116	2x	x = get(get_dataname(x), new_env)
117		)
118		}
119		)
120	1x	logger::log_trace("TealDataAbstract$execute_mutate evaluated mutate code.")
121	1x	return(invisible(NULL))
122		},
123		#' @description
124		#' Get result of reproducibility check
125		#' @return `NULL` if check has not been called yet, `TRUE` / `FALSE` otherwise
126		get_check_result = function() {
127	49x	private$check_result
128		},
129		#' @description
130		#' Get code for all datasets.
131		#' @param dataname (`character`) `dataname` or `NULL` for all datasets
132		#' @param deparse (`logical`) whether to return the deparsed form of a call
133		#' @return (`character`) vector of code to generate datasets.
134		get_code = function(dataname = NULL, deparse = TRUE) {
135	47x	checkmate::assert_character(dataname, min.len = 1, null.ok = TRUE, any.missing = FALSE)
136	46x	checkmate::assert_flag(deparse)
137
138	45x	return(self$get_code_class()$get_code(dataname = dataname, deparse = deparse))
139		},
140		#' @description
141		#' Get internal `CodeClass` object
142		#' @param only_pull (`logical` value)\cr
143		#' if `TRUE` only code to pull datasets will be returned without the mutate code.
144		#'
145		#' @return `CodeClass`
146		get_code_class = function(only_pull = FALSE) {
147	46x	all_code_class <- CodeClass$new()
148
149	46x	pull_code_class <- private$get_pull_code_class()
150	46x	all_code_class$append(pull_code_class)
151
152	46x	datasets_code_class <- private$get_datasets_code_class()
153	46x	all_code_class$append(datasets_code_class)
154
155	46x	if (isFALSE(only_pull)) {
156	41x	mutate_code_class <- private$get_mutate_code_class()
157	41x	all_code_class$append(mutate_code_class)
158		}
159
160	46x	return(all_code_class)
161		},
162		#' @description
163		#' Get names of the datasets.
164		#'
165		#' @return `character` vector with names of all datasets.
166		get_datanames = function() {
167	209x	datasets_names <- unname(unlist(lapply(private$datasets, get_dataname)))
168
169	209x	return(datasets_names)
170		},
171		#' @description
172		#' Get `TealDataset` object.
173		#'
174		#' @param dataname (`character` value)\cr
175		#' name of dataset to be returned. If `NULL`, all datasets are returned.
176		#'
177		#' @return `TealDataset`.
178		get_dataset = function(dataname = NULL) {
179	5x	checkmate::assert_string(dataname, null.ok = TRUE)
180
181	4x	if (length(dataname) == 1) {
182	3x	if (!(dataname %in% self$get_datanames())) {
183	1x	stop(paste("dataset", dataname, "not found"))
184		}
185
186	2x	res <- self$get_datasets()[[dataname]]
187	2x	return(res)
188		} else {
189	1x	return(self$get_datasets())
190		}
191		},
192		#' @description
193		#' Get `list` of `TealDataset` objects.
194		#'
195		#' @return `list` of `TealDataset`.
196		get_datasets = function() {
197	62x	if (!self$is_pulled()) {
198	2x	stop(
199	2x	"Not all datasets have been pulled yet.\n",
200	2x	"- Please use `load_datasets()` to retrieve complete results."
201		)
202		}
203	60x	unlist(lapply(self$get_items(), get_dataset))
204		},
205		#' @description
206		#' Get all datasets and all dataset connectors
207		#'
208		#' @param dataname (`character` value)\cr
209		#' name of dataset connector to be returned. If `NULL`, all connectors are returned.
210		#' @return `list` with all datasets and all connectors
211		get_items = function(dataname = NULL) {
212	30x	checkmate::assert_string(dataname, null.ok = TRUE)
213
214	30x	if (length(dataname) == 1) {
215	!	if (!(dataname %in% self$get_datanames())) {
216	!	stop(paste("dataset", dataname, "not found"))
217		}
218	!	return(private$datasets[[dataname]])
219		} else {
220	30x	return(private$datasets)
221		}
222		},
223		#' @description
224		#' Has this data been or will this data be subjected to a reproducibility check
225		#' @return `logical`
226		get_check = function() {
227	3x	private$.check
228		},
229		#' @field id String used to create unique GUI elements
230		id = NULL,
231		#' @description
232		#' Check if dataset has already been pulled.
233		#'
234		#' @return `TRUE` if dataset has been already pulled, else `FALSE`
235		is_pulled = function() {
236	128x	all(vapply(private$datasets, is_pulled, logical(1)))
237		},
238		#' @description
239		#' Mutate data by code. Code used in this mutation is not linked to particular
240		#' but refers to all datasets.
241		#' Consequence of this is that when using `get_code(<dataset>)` this
242		#' part of the code will be returned for each specified dataset. This method
243		#' should be used only if particular call involve changing multiple datasets.
244		#' Otherwise please use `mutate_dataset`.
245		#' Execution of `mutate_code` is delayed after datasets are pulled
246		#' (`isTRUE(is_pulled)`).
247		#'
248		#' @param code (`character`) Code to mutate the dataset. Must contain the
249		#' `dataset$dataname`
250		#' @param vars (named `list`)) \cr
251		#' In case when this object code depends on other `TealDataset` object(s) or
252		#' other constant value, this/these object(s) should be included as named
253		#' element(s) of the list. For example if this object code needs `ADSL`
254		#' object we should specify `vars = list(ADSL = <adsl object>)`.
255		#' It's recommended to include `TealDataset` or `TealDatasetConnector` objects to
256		#' the `vars` list to preserve reproducibility. Please note that `vars`
257		#' are included to this object as local `vars` and they cannot be modified
258		#' within another dataset.
259		#'
260		#' @return self invisibly for chaining
261		mutate = function(code, vars = list()) {
262	8x	private$set_mutate_vars(vars)
263	8x	private$set_mutate_code(
264	8x	code = code,
265	8x	deps = names(vars)
266		)
267	8x	private$check_result <- NULL
268	8x	logger::log_trace(
269	8x	sprintf(
270	8x	"TealDataAbstract$mutate code (%s lines) and vars (%s) set.",
271	8x	length(parse(text = code, keep.source = FALSE)),
272	8x	paste(names(vars), collapse = ", ")
273		)
274		)
275	8x	return(invisible(self))
276		},
277		#' @description
278		#' Mutate dataset by code.
279		#' Execution of `mutate_code` is delayed after datasets are pulled
280		#' (`isTRUE(is_pulled)`).
281		#'
282		#' @param dataname (`character`) `Dataname` to be mutated
283		#' @param code (`character`) Code to mutate the dataset. Must contain the
284		#' `dataset$dataname`
285		#' @param vars (named `list`)) \cr
286		#' In case when this object code depends on other `TealDataset` object(s) or
287		#' other constant value, this/these object(s) should be included as named
288		#' element(s) of the list. For example if this object code needs `ADSL`
289		#' object we should specify `vars = list(ADSL = <adsl object>)`.
290		#' It's recommended to include `TealDataset` or `TealDatasetConnector` objects to
291		#' the `vars` list to preserve reproducibility. Please note that `vars`
292		#' are included to this object as local `vars` and they cannot be modified
293		#' within another dataset.
294		#'
295		#' @return self invisibly for chaining
296		mutate_dataset = function(dataname, code, vars = list()) {
297	7x	checkmate::assert_character(dataname, min.len = 1, any.missing = FALSE)
298	6x	stopifnot(all(dataname %in% self$get_datanames()))
299
300	5x	private$set_mutate_vars(vars = vars)
301	5x	private$set_mutate_code(
302	5x	code = code,
303	5x	dataname = dataname,
304	5x	deps = names(vars)
305		)
306
307	5x	private$check_result <- NULL
308	5x	logger::log_trace(
309	5x	sprintf(
310	5x	"TealDataAbstract$mutate code (%s lines) and vars (%s) set for dataset: %s.",
311	5x	length(parse(text = code, keep.source = FALSE)),
312	5x	paste(names(vars), collapse = ", "),
313	5x	dataname
314		)
315		)
316
317	5x	return(invisible(self))
318		},
319		#' @description
320		#' Set reproducibility check
321		#'
322		#' @param check (`logical`) whether to perform reproducibility check.
323		#'
324		#' @return (`self`) invisibly for chaining.
325		set_check = function(check = FALSE) {
326	132x	checkmate::assert_flag(check)
327	131x	private$.check <- check
328	131x	logger::log_trace("TealDataAbstract$set_check check set to: { check }.")
329	131x	return(invisible(self))
330		},
331		#' @description
332		#' Set pull code
333		#'
334		#' @param code (`character` value)\cr
335		#' code to reproduce `data` in `TealDataset` objects. Can't be set if any dataset
336		#' has `code` set already.
337		#'
338		#' @return (`self`) invisibly for chaining.
339		set_pull_code = function(code) {
340	7x	checkmate::assert_string(code)
341	6x	is_code_set <- vapply(
342	6x	self$get_items(),
343	6x	function(item) {
344	11x	get_code(item, deparse = TRUE) != ""
345		},
346	6x	logical(1)
347		)
348
349	6x	is_dataset <- vapply(
350	6x	self$get_items(),
351	6x	function(item) {
352	11x	inherits(item, "TealDataset")
353		},
354	6x	logical(1)
355		)
356
357	6x	if (any(is_code_set & is_dataset)) {
358	2x	stop(
359	2x	"'code' argument should be specified only in the 'cdisc_data' or in 'cdisc_dataset' but not in both",
360	2x	call. = FALSE
361		)
362		}
363
364	4x	if (all(!is_dataset)) {
365	1x	stop(
366	1x	"Connectors are reproducible by default and setting 'code' argument might break it",
367	1x	call. = FALSE
368		)
369		}
370
371	3x	private$pull_code <- private$pull_code$set_code(
372	3x	code = code,
373	3x	dataname = self$get_datanames()
374		)
375	3x	logger::log_trace("TealDataAbstract$set_pull_code pull code set.")
376
377	3x	return(invisible(self))
378		},
379
380		#' @description
381		#' Reassign `vars` in `TealDataset` and `TealDatasetConnector` objects
382		#' to keep the valid reference after deep cloning
383		#' For example if `TealDatasetConnector` has a dependency on some `TealDataset`, this
384		#' `TealDataset` is reassigned inside of `TealDatasetConnector`.
385		reassign_datasets_vars = function() {
386	3x	for (dataset in self$get_items()) {
387	6x	dataset$reassign_datasets_vars(
388	6x	datasets = self$get_items()
389		)
390		}
391	3x	logger::log_trace("TealDataAbstract$reassign_datasets_vars reassigned vars.")
392	3x	invisible(NULL)
393		}
394		),
395
396		## __Private Fields ====
397		private = list(
398		datasets = NULL,
399		.check = FALSE,
400		check_result = NULL, # TRUE / FALSE after calling check()
401		mutate_code = NULL, # CodeClass after initialization
402		mutate_vars = list(), # named list with vars used to mutate object
403		pull_code = NULL, # CodeClass - code to reproduce loading of TealDataset(s) only
404
405		## __Private Methods ====
406		# need to have a custom deep_clone because one of the key fields are reference-type object
407		# in particular: datasets is a list of R6 objects that wouldn't be cloned using default clone(deep = T)
408		deep_clone = function(name, value) {
409	222x	deep_clone_r6(name, value)
410		},
411		check_combined_code = function() {
412	4x	execution_environment <- new.env(parent = parent.env(globalenv()))
413	4x	self$get_code_class(only_pull = TRUE)$eval(envir = execution_environment)
414	4x	res <- all(vapply(
415	4x	Filter(is_pulled, self$get_items()),
416	4x	function(dataset) {
417	8x	data <- get_raw_data(dataset)
418	8x	data_from_code <- get(get_dataname(dataset), execution_environment)
419	7x	identical(data, data_from_code)
420		},
421	4x	logical(1)
422		))
423	3x	logger::log_trace("TealDataAbstract$check_combined_code reproducibility result of the combined code: { res }.")
424	3x	res
425		},
426		get_datasets_code_class = function() {
427	78x	res <- CodeClass$new()
428	78x	if (is.null(private$datasets)) {
429	!	return(res)
430		}
431	78x	for (dataset in private$datasets) {
432	164x	res$append(dataset$get_code_class())
433		}
434	78x	return(res)
435		},
436		get_mutate_code_class = function() {
437	71x	res <- CodeClass$new()
438	71x	res$append(list_to_code_class(private$mutate_vars))
439	71x	res$append(private$mutate_code)
440	71x	return(res)
441		},
442		get_pull_code_class = function() {
443	48x	res <- CodeClass$new()
444	48x	res$append(private$pull_code)
445	48x	return(res)
446		},
447		set_mutate_code = function(code, dataname = self$get_datanames(), deps = names(private$mutate_vars)) {
448	16x	checkmate::assert(
449	16x	checkmate::check_character(code, max.len = 1, any.missing = FALSE),
450	16x	checkmate::check_class(code, "PythonCodeClass")
451		)
452
453	14x	if (inherits(code, "PythonCodeClass")) {
454	!	r <- PythonCodeClass$new()
455	!	r$append(private$mutate_code)
456	!	private$mutate_code <- r
457
458	!	code <- code$get_code()
459		}
460
461	14x	if (length(code) > 0 && code != "") {
462	14x	private$mutate_code$set_code(code = code, dataname = dataname, deps = deps)
463		}
464
465	14x	return(invisible(self))
466		},
467		set_mutate_vars = function(vars) {
468	17x	checkmate::assert_list(vars, min.len = 0, names = "unique")
469	15x	if (length(vars) > 0) {
470	2x	private$mutate_vars <- c(
471	2x	private$mutate_vars,
472	2x	vars[!names(vars) %in% names(private$mutate_vars)]
473		)
474		}
475
476	15x	return(invisible(self))
477		},
478		check_names = function(x) {
479	149x	if (any(vapply(x, identical, logical(1), y = ""))) {
480	!	stop("Cannot extract some dataset names")
481		}
482	149x	if (any(duplicated(x))) {
483	1x	stop("TealDatasets names should be unique")
484		}
485	148x	if (any(x %in% self$get_datanames())) {
486	!	stop("Some datanames already exists")
487		}
488	148x	return(TRUE)
489		}
490		)
491		)

1		#' Helper function to deep copy `R6` object
2		#'
3		#' When cloning an R6 object the private function
4		#' `deep_clone` is automatically used. To ensure a complete
5		#' clone the private function should call this function
6		#'
7		#' @param name (`character`) argument passed by `deep_clone` function.
8		#' @param value (any `R` object) argument passed by `deep_clone` function.
9		#' @keywords internal
10		deep_clone_r6 <- function(name, value) {
11	1629x	if (checkmate::test_list(value, types = "R6")) {
12	86x	lapply(value, function(x) x$clone(deep = TRUE))
13	1543x	} else if (R6::is.R6(value)) {
14	31x	value$clone(deep = TRUE)
15	1512x	} else if (is.environment(value)) {
16	5x	new_env <- as.environment(as.list(value, all.names = TRUE))
17	5x	parent.env(new_env) <- parent.env(value)
18	5x	new_env
19		} else {
20	1507x	value
21		}
22		}

1		# CDISCTealDataConnector ------
2		#'
3		#' @title Manage multiple and `TealDatasetConnector` of the same type.
4		#'
5		#' @description `r lifecycle::badge("stable")`
6		#' Class manages `TealDatasetConnector` to specify additional dynamic arguments and to
7		#' open/close connection.
8		#'
9		#' @param connection (`TealDataConnection`)\cr
10		#' connection to data source
11		#' @param connectors (`list` of `TealDatasetConnector` elements)\cr
12		#' list with dataset connectors
13		#'
14		CDISCTealDataConnector <- R6::R6Class( # nolint
15		classname = "CDISCTealDataConnector",
16		inherit = TealDataConnector,
17
18		## __Public Methods ====
19		public = list(
20		#' @description
21		#' Create a new `CDISCTealDataConnector` object
22		initialize = function(connection, connectors) {
23	8x	super$initialize(connection = connection, connectors = connectors)
24
25	8x	new_parent <- list()
26	8x	for (x in connectors) {
27	12x	x_dataname <- x$get_dataname()
28	12x	new_parent[[x_dataname]] <- if (inherits(x, "CDISCTealDatasetConnector")) {
29	12x	x$get_parent()
30		} else {
31	!	character(0L)
32		}
33		}
34
35	8x	if (is_dag(new_parent)) {
36	!	stop("Cycle detected in a parent and child dataset graph.")
37		}
38
39	8x	private$parent <- new_parent
40	8x	logger::log_trace(
41	8x	"CDISCTealDataConnector initialized with data: { paste(self$get_datanames(), collapse = ' ') }"
42		)
43	8x	return(invisible(self))
44		},
45		#' @description
46		#' Get all datasets parent names
47		#' @return (named `list`) with dataset name and its corresponding parent dataset name
48		get_parent = function() {
49	!	private$parent
50		}
51		),
52
53		## __Private Fields ====
54		private = list(
55		parent = list() # list with dataset names and its parent dataset names
56		)
57		)
58
59		#' The constructor of `CDISCTealDataConnector` objects.
60		#'
61		#' @description `r lifecycle::badge("stable")`
62		#'
63		#' @param connection (`TealDataConnection`)\cr
64		#' connection to data source
65		#' @param connectors (`list` of `TealDatasetConnector` elements)\cr
66		#' list with dataset connectors
67		#'
68		#' @examples
69		#' adsl_cf <- callable_function(
70		#' function() as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADSL"))))
71		#' )
72		#' adae_cf <- callable_function(
73		#' function() as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADAE"))))
74		#' )
75		#' adsl <- cdisc_dataset_connector(
76		#' "ADSL", adsl_cf,
77		#' keys = get_cdisc_keys("ADSL"), parent = character(0)
78		#' )
79		#' adae <- cdisc_dataset_connector(
80		#' "ADAE", adae_cf,
81		#' keys = get_cdisc_keys("ADAE"), parent = "ADSL"
82		#' )
83		#' data <- cdisc_data_connector(
84		#' connection = data_connection(open_fun = callable_function(function() "open function")),
85		#' connectors = list(adsl, adae)
86		#' )
87		#' @return `CDISCTealDataConnector` object
88		#' @export
89		cdisc_data_connector <- function(connection, connectors) {
90	9x	stopifnot(inherits(connection, "TealDataConnection"))
91	7x	checkmate::assert_list(connectors, types = "TealDatasetConnector", min.len = 1)
92	5x	CDISCTealDataConnector$new(connection, connectors)
93		}

1		#' Load data from connection
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#' Load data from connection. Function used on [`TealDatasetConnector`] and
5		#' [`TealDataset`] to obtain data from connection.
6		#'
7		#' @param x (`TealDatasetConnector` or `TealDataset`)
8		#' @param args (`NULL` or named `list`)\cr
9		#' additional dynamic arguments passed to function which loads the data.
10		#' @param try (`logical`) whether perform function evaluation inside `try` clause
11		#' @param conn Optional (`TealDataConnection`) object required to pull the data.
12		#' @param ... not used, only for support of S3
13		#'
14		#' @return `x` with loaded `dataset` object
15		#' @export
16		load_dataset <- function(x, ...) {
17	121x	UseMethod("load_dataset")
18		}
19
20		#' @rdname load_dataset
21		#' @examples
22		#'
23		#' # TealDataset --------
24		#' ADSL <- teal.data::example_cdisc_data("ADSL")
25		#' ADSL_dataset <- dataset("ADSL", x = ADSL)
26		#'
27		#' load_dataset(ADSL_dataset)
28		#' @export
29		load_dataset.TealDataset <- function(x, ...) { # nolint
30	45x	check_ellipsis(...)
31	45x	return(invisible(x$get_dataset()))
32		}
33
34		#' @rdname load_dataset
35		#' @examples
36		#'
37		#' # TealDatasetConnector --------
38		#'
39		#' random_data_connector <- function(dataname) {
40		#' fun_dataset_connector(
41		#' dataname = dataname,
42		#' fun = teal.data::example_cdisc_data,
43		#' fun_args = list(dataname = dataname),
44		#' )
45		#' }
46		#'
47		#' adsl <- random_data_connector(dataname = "ADSL")
48		#' load_dataset(adsl)
49		#' get_dataset(adsl)
50		#'
51		#' adae <- random_data_connector(dataname = "ADAE")
52		#' load_dataset(adae)
53		#' get_dataset(adae)
54		#' @export
55		load_dataset.TealDatasetConnector <- function(x, args = NULL, try = FALSE, conn = NULL, ...) { # nolint
56	76x	check_ellipsis(...)
57	76x	if (!is.null(conn)) {
58	!	stopifnot(inherits(conn, "TealDataConnection"))
59
60	!	conn$open()
61	!	conn_obj <- conn$get_conn()
62
63	!	x$get_pull_callable()$assign_to_env("conn", conn_obj)
64		}
65
66	76x	x$pull(args = args, try = try)
67
68	76x	return(invisible(x))
69		}
70
71		#' Load datasets
72		#'
73		#' @description `r lifecycle::badge("stable")`
74		#'
75		#' @param x ([`TealData`], [`TealDataset`] or [`TealDatasetConnector`])
76		#' @param args (`NULL` or named `list`)\cr
77		#' additional dynamic arguments passed to function which loads the data. Applicable only on [`TealDatasetConnector`])
78		#' @param try (`logical`)\cr
79		#' whether perform function evaluation inside `try` clause. Applicable only on [`TealDatasetConnector`])
80		#' @param ... (not used)\cr
81		#' only for support of S3
82		#'
83		#' @export
84		#' @return If executed in the interactive session shiny app is opened to load the data. If executed in
85		#' shiny application - it returns shiny server module.
86		load_datasets <- function(x, ...) {
87	!	UseMethod("load_datasets")
88		}
89
90		#' @rdname load_datasets
91		#' @examples
92		#'
93		#' # TealDataset ------
94		#' ADSL <- teal.data::example_cdisc_data("ADSL")
95		#' x <- dataset("ADSL", x = ADSL)
96		#'
97		#' load_datasets(x)
98		#' @export
99		load_datasets.TealDataset <- function(x, ...) { # nolint
100	!	check_ellipsis(...)
101	!	return(invisible(x$get_dataset()))
102		}
103
104		#' @rdname load_datasets
105		#' @examples
106		#'
107		#' # TealDatasetConnector ------
108		#' random_data_connector <- function(dataname) {
109		#' fun_dataset_connector(
110		#' dataname = dataname,
111		#' fun = teal.data::example_cdisc_data,
112		#' fun_args = list(dataname = dataname),
113		#' )
114		#' }
115		#'
116		#' adsl <- random_data_connector(dataname = "ADSL")
117		#' load_datasets(adsl)
118		#' get_dataset(adsl)
119		#'
120		#' adae <- random_data_connector(dataname = "ADAE")
121		#' load_datasets(adae)
122		#' get_dataset(adae)
123		#' @export
124		load_datasets.TealDatasetConnector <- function(x, args = NULL, try = FALSE, ...) { # nolint
125	!	check_ellipsis(...)
126	!	x$pull(args = args, try = try)
127	!	return(invisible(x))
128		}
129
130
131		#' @rdname load_datasets
132		#' @export
133		#' @examples
134		#'
135		#' # TealDataConnector --------
136		#' random_data_connector <- function(dataname) {
137		#' fun_dataset_connector(
138		#' dataname = dataname,
139		#' fun = teal.data::example_cdisc_data,
140		#' fun_args = list(dataname = dataname),
141		#' )
142		#' }
143		#'
144		#' adsl <- random_data_connector(dataname = "ADSL")
145		#' adrs <- random_data_connector(dataname = "ADRS")
146		#'
147		#' rdc <- cdisc_data(adsl, adrs)
148		#' \dontrun{
149		#' load_datasets(rdc)
150		#' }
151		load_datasets.TealDataConnector <- function(x, ...) { # nolint
152	!	check_ellipsis(...)
153	!	if (interactive()) {
154	!	x$launch()
155		} else {
156	!	return(invisible(x))
157		}
158		}
159
160		#' @rdname load_datasets
161		#' @export
162		#' @examples
163		#'
164		#' # TealData --------
165		#' random_data_connector <- function(dataname) {
166		#' fun_dataset_connector(
167		#' dataname = dataname,
168		#' fun = teal.data::example_cdisc_data,
169		#' fun_args = list(dataname = dataname),
170		#' )
171		#' }
172		#'
173		#' adsl <- random_data_connector(dataname = "ADSL")
174		#' adlb <- random_data_connector(dataname = "ADLB")
175		#' adrs <- random_data_connector(dataname = "ADRS")
176		#'
177		#' tc <- cdisc_data(adsl, adlb, adrs)
178		#' \dontrun{
179		#' load_datasets(tc)
180		#' }
181		load_datasets.TealData <- function(x, ...) { # nolint
182	!	check_ellipsis(...)
183	!	if (interactive()) {
184	!	x$launch()
185		} else {
186	!	return(invisible(x))
187		}
188		}

1		## TealData ====
2		#' @title Manage multiple `TealDataConnector`, `TealDatasetConnector` and `TealDataset` objects.
3		#'
4		#' @description `r lifecycle::badge("experimental")`
5		#' Class manages `TealDataConnector`, `TealDatasetConnector` and
6		#' `TealDataset` objects and aggregate them in one collection.
7		#' Class also decides whether to launch app before initialize teal application.
8		#'
9		#' @param ... (`TealDataConnector`, `TealDataset`, `TealDatasetConnector`)\cr
10		#' objects
11		#' @param join_keys (`JoinKeys`) or a single (`JoinKeySet`)\cr
12		#' (optional) object with dataset column relationships used for joining.
13		#' If empty then an empty `JoinKeys` object is passed by default.
14		#' @param check (`logical`) reproducibility check - whether evaluated preprocessing code gives the same objects
15		#' as provided in arguments. Check is run only if flag is true and preprocessing code is not empty.
16		#'
17		#' @examples
18		#' adsl_cf <- callable_function(teal.data::example_cdisc_data)$set_args(list(dataname = "ADSL"))
19		#' adlb_cf <- callable_function(teal.data::example_cdisc_data)$set_args(list(dataname = "ADLB"))
20		#' adrs_cf <- callable_function(teal.data::example_cdisc_data)$set_args(list(dataname = "ADRS"))
21		#' adtte_cf <- callable_function(teal.data::example_cdisc_data)$set_args(list(dataname = "ADTTE"))
22		#' x1 <- cdisc_dataset_connector("ADSL", adsl_cf, keys = get_cdisc_keys("ADSL"))
23		#' x2 <- cdisc_dataset_connector("ADRS", adrs_cf, keys = get_cdisc_keys("ADRS"))
24		#' x3 <- cdisc_dataset(
25		#' dataname = "ADAE",
26		#' x = teal.data::example_cdisc_data("ADAE"),
27		#' code = "library(teal.data)\nADAE <- teal.data::example_cdisc_data(\"ADAE\")"
28		#' )
29		#' x4 <- cdisc_dataset_connector("ADTTE", adtte_cf, keys = get_cdisc_keys("ADTTE"))
30		#' tc <- teal.data:::TealData$new(x1, x2, x3, x4)
31		#' tc$get_datanames()
32		#' \dontrun{
33		#' tc$launch()
34		#' get_datasets(tc) # equivalent to tc$get_datasets()
35		#' tc$get_dataset("ADAE")
36		#' tc$check()
37		#' }
38		#'
39		#' x <- cdisc_dataset(
40		#' dataname = "ADSL",
41		#' x = teal.data::example_cdisc_data("ADSL"),
42		#' code = "library(teal.data)\nADSL <- teal.data::example_cdisc_data(\"ADSL\")"
43		#' )
44		#'
45		#' x2 <- cdisc_dataset_connector("ADTTE", adtte_cf, keys = get_cdisc_keys("ADTTE"))
46		#' tc <- teal.data:::TealData$new(x, x2)
47		#' \dontrun{
48		#' # This errors as we have not pulled the data
49		#' # tc$get_datasets()
50		#' # pull the data and then we can get the datasets
51		#' tc$launch()
52		#' tc$get_datasets()
53		#' get_raw_data(tc)
54		#' }
55		#'
56		TealData <- R6::R6Class( # nolint
57		classname = "TealData",
58		inherit = TealDataAbstract,
59		## __Public Methods ====
60		public = list(
61		#' @description
62		#' Create a new object of `TealData` class
63		initialize = function(..., check = FALSE, join_keys = teal.data::join_keys()) {
64	133x	checkmate::assert_class(join_keys, "JoinKeys")
65
66	133x	dot_args <- list(...)
67	133x	is_teal_data <- checkmate::test_list(
68	133x	dot_args,
69	133x	types = c("TealDataConnector", "TealDataset", "TealDatasetConnector")
70		)
71	133x	if (!all(is_teal_data)) {
72	2x	stop("All elements should be of TealDataset(Connector) or TealDataConnector class")
73		}
74
75	131x	datanames <- unlist(lapply(dot_args, get_dataname))
76	131x	private$check_names(datanames)
77
78	130x	private$datasets <- dot_args
79
80	130x	self$set_check(check)
81
82	130x	private$pull_code <- CodeClass$new()
83	130x	private$mutate_code <- CodeClass$new()
84
85	130x	private$join_keys <- join_keys
86
87	130x	self$id <- sample.int(1e11, 1, useHash = TRUE)
88
89	130x	logger::log_trace(
90	130x	"TealData initialized with data: { paste(self$get_datanames(), collapse = ' ') }."
91		)
92	130x	return(invisible(self))
93		},
94		#' @description
95		#' Creates a copy of the object with keeping valid references
96		#' between `TealDataset` and `TealDatasetConnector` objects
97		#' @param deep (`logical(1)`)\cr
98		#' argument passed to `clone` method. If `TRUE` deep copy is made
99		#' @return self invisible
100		copy = function(deep = FALSE) {
101	2x	new_self <- self$clone(deep = deep)
102	2x	new_self$reassign_datasets_vars()
103	2x	logger::log_trace("TealData$copy{if (deep) ' deep-' else ' '}copied self.")
104	2x	invisible(new_self)
105		},
106		#' @description
107		#' Prints this `TealData`.
108		#'
109		#' @param ... additional arguments to the printing method
110		#' @return invisibly self
111		print = function(...) {
112	1x	check_ellipsis(...)
113
114	1x	cat(sprintf(
115	1x	"A %s object containing %d TealDataset/TealDatasetConnector object(s) as element(s):\n",
116	1x	class(self)[1],
117	1x	length(private$datasets)
118		))
119
120	1x	for (i in seq_along(private$datasets)) {
121	2x	cat(sprintf("--> Element %d:\n", i))
122	2x	print(private$datasets[[i]])
123		}
124
125	1x	invisible(self)
126		},
127		# ___ getters ====
128		#' @description
129		#' Get data connectors.
130		#'
131		#' @return (`list`) with all `TealDatasetConnector` or `TealDataConnector` objects.
132		get_connectors = function() {
133	5x	return(Filter(
134	5x	function(x) {
135	9x	inherits(x, "TealDatasetConnector") \|\| inherits(x, "TealDataConnector")
136		},
137	5x	private$datasets
138		))
139		},
140		#' @description
141		#' Get all datasets and all dataset connectors
142		#'
143		#' @param dataname (`character` value)\cr
144		#' name of dataset connector to be returned. If `NULL`, all connectors are returned.
145		#'
146		#' @return `list` with all datasets and all connectors
147		get_items = function(dataname = NULL) {
148	105x	checkmate::assert_string(dataname, null.ok = TRUE)
149
150	105x	get_sets <- function(x) {
151	195x	if (inherits(x, "TealDataConnector")) {
152	12x	x$get_items()
153		} else {
154	183x	x
155		}
156		}
157
158	105x	sets <- unlist(lapply(private$datasets, get_sets))
159	105x	names(sets) <- vapply(sets, get_dataname, character(1))
160
161	104x	if (checkmate::test_string(dataname)) {
162	5x	if (!(dataname %in% self$get_datanames())) {
163	2x	stop(paste("dataset", dataname, "not found"))
164		}
165	3x	return(sets[[dataname]])
166		} else {
167	99x	return(sets)
168		}
169		},
170
171		#' @description
172		#' Get join keys between two datasets.
173		#'
174		#' @param dataset_1 (`character`) name of first dataset.
175		#' @param dataset_2 (`character`) name of second dataset.
176		#' @return (`character`) named character vector x with names(x) the
177		#' columns of `dataset_1` and the values of `(x)` the corresponding join
178		#' keys in `dataset_2` or `character(0)` if no relationship
179		get_join_keys = function(dataset_1, dataset_2) {
180	179x	if (missing(dataset_1) && missing(dataset_2)) {
181	16x	private$join_keys
182		} else {
183	163x	private$join_keys$get(dataset_1, dataset_2)
184		}
185		},
186
187		#' @description
188		#' returns the parents list of the datasets.
189		#'
190		#' @return named (`list`) of the parents of all datasets.
191		get_parents = function() {
192	1x	private$join_keys$get_parents()
193		},
194
195		# ___ shiny ====
196
197		#' @description
198		#'
199		#' Get a shiny-module UI to render the necessary app to
200		#' derive `TealDataConnector` object's data
201		#'
202		#' @param id (`character`) item ID for the shiny module
203		#' @return the `shiny` `ui` function
204		get_ui = function(id) {
205	4x	if (is.null(private$ui)) {
206	!	div(id = id, "Data Loaded")
207		} else {
208	4x	private$ui(id)
209		}
210		},
211		#' @description
212		#'
213		#' Get a shiny-module server to render the necessary app to
214		#' derive `TealDataConnector` object's data
215		#'
216		#' @return `shiny` server module.
217		get_server = function() {
218	!	if (is.null(private$server)) {
219	!	return(
220	!	function(id) {
221	!	moduleServer(
222	!	id = id,
223	!	module = function(input, output, session) {
224	!	reactive(self)
225		}
226		)
227		}
228		)
229		} else {
230	!	function(id) {
231	!	moduleServer(
232	!	id = id,
233	!	module = private$server
234		)
235		}
236		}
237		},
238		#' @description
239		#'
240		#' Launch an app that allows to run the user-interfaces of all
241		#' `TealDataConnector` and `TealDatasetConnector` modules
242		#'
243		#' This piece is mainly used for debugging.
244		launch = function() {
245		# if no data connectors can append any dataset connectors
246		# and not load an app
247	!	if (self$is_pulled()) {
248	!	stop("All the datasets have already been pulled.")
249		}
250
251		# otherwise load TealDataConnector and
252		# TealDatasetConnector with shiny app
253	!	shinyApp(
254	!	ui = fluidPage(
255	!	theme = get_teal_bs_theme(),
256	!	fluidRow(
257	!	column(
258	!	width = 8,
259	!	offset = 2,
260	!	self$get_ui(id = "main_app"),
261	!	shinyjs::hidden(
262	!	tags$div(
263	!	id = "data_loaded",
264	!	div(
265	!	h3("Data successfully loaded."),
266	!	p("You can close this window and get back to R console.")
267		)
268		)
269		),
270	!	include_js_files(),
271	!	br()
272		)
273		)
274		),
275	!	server = function(input, output, session) {
276	!	session$onSessionEnded(stopApp)
277	!	dat <- self$get_server()(id = "main_app")
278
279	!	observeEvent(dat(), {
280	!	if (self$is_pulled()) {
281	!	shinyjs::show("data_loaded")
282	!	stopApp()
283		}
284		})
285	!	NULL
286		}
287		)
288		},
289
290		# ___ mutate ====
291		#' @description
292		#' Change join_keys for a given pair of dataset names
293		#' @param dataset_1,dataset_2 (`character`) datasets for which join_keys are to be returned
294		#' @param val (named `character`) column names used to join
295		#' @return (`self`) invisibly for chaining
296		mutate_join_keys = function(dataset_1, dataset_2, val) {
297	3x	private$join_keys$mutate(dataset_1, dataset_2, val)
298		},
299
300		# ___ check ====
301		#' @description
302		#' Check there is consistency between the datasets and join_keys
303		#' @return raise and error or invisible `TRUE`
304		check_metadata = function() {
305	52x	if (isFALSE(self$is_pulled())) {
306		# all the checks below required data to be already pulled
307	4x	return(invisible(TRUE))
308		}
309
310	48x	for (dataset in self$get_datasets()) {
311	82x	dataname <- get_dataname(dataset)
312	82x	dataset_colnames <- dataset$get_colnames()
313
314		# expected columns in this dataset from JoinKeys specification
315	82x	join_key_cols <- unique(unlist(lapply(self$get_join_keys(dataname), names)))
316	82x	if (!is.null(join_key_cols) && !all(join_key_cols %in% dataset_colnames)) {
317	3x	stop(
318	3x	paste(
319	3x	"The join key specification requires dataset",
320	3x	dataname,
321	3x	"to contain the following columns:",
322	3x	paste(join_key_cols, collapse = ", ")
323		)
324		)
325		}
326
327		# check if primary keys in dataset
328	79x	primary_key_cols <- self$get_join_keys(dataname, dataname)
329	79x	if (!is.null(primary_key_cols) && !all(primary_key_cols %in% dataset_colnames)) {
330	!	stop(
331	!	paste(
332	!	"The primary keys specification requires dataset",
333	!	dataname,
334	!	"to contain the following columns:",
335	!	paste(primary_key_cols, collapse = ", ")
336		)
337		)
338		}
339	79x	dataset$check_keys()
340		}
341
342	43x	logger::log_trace("TealData$check_metadata metadata check passed.")
343
344	43x	return(invisible(TRUE))
345		}
346		),
347
348		## __Private Fields ====
349		private = list(
350		join_keys = NULL,
351		ui = function(id) {
352	4x	ns <- NS(id)
353
354		# connectors ui(s) + submit button
355	4x	fluidPage(
356	4x	include_js_files(),
357	4x	theme = get_teal_bs_theme(),
358	4x	shinyjs::hidden(
359	4x	column(
360	4x	id = ns("delayed_data"),
361	4x	width = 8,
362	4x	offset = 2,
363	4x	div(
364	4x	tagList(
365	4x	lapply(
366	4x	private$datasets,
367	4x	function(x) {
368	6x	div(
369	6x	if (inherits(x, "TealDataConnector")) {
370	!	ui <- x$get_ui(id = ns(x$id))
371	!	if (is.null(ui)) {
372	!	ui <- div(
373	!	h4("TealDataset Connector for: ", lapply(x$get_datanames(), code)),
374	!	p(icon("check"), "Ready to Load")
375		)
376		}
377	!	ui
378	6x	} else if (inherits(x, "TealDatasetConnector")) {
379	!	ui <- x$get_ui(id = ns(paste0(x$get_datanames(), collapse = "_")))
380	!	if (is.null(ui)) {
381	!	ui <- div(
382	!	h4("TealDataset Connector for: ", code(x$get_dataname())),
383	!	p(icon("check"), "Ready to Load")
384		)
385		}
386	!	ui
387		} else {
388	6x	div(h4("Data(set) for: ", lapply(x$get_datanames(), code)), p(icon("check"), "Loaded"))
389		},
390	6x	br()
391		)
392		}
393		),
394	4x	actionButton(inputId = ns("submit"), label = "Submit all")
395		),
396	4x	`data-proxy-click` = ns("submit") # handled by jscode in custom.js - hit enter to submit
397		)
398		)
399		)
400		)
401		},
402		server = function(input, output, session) {
403	!	logger::log_trace("TealData$server initializing...")
404
405	!	shinyjs::show("delayed_data")
406	!	for (dc in self$get_connectors()) {
407	!	if (inherits(dc, "TealDataConnector")) {
408	!	dc$get_preopen_server()(id = dc$id)
409		}
410		}
411	!	rv <- reactiveVal(NULL)
412	!	observeEvent(input$submit, {
413	!	logger::log_trace("TealData$server@1 submit button clicked.")
414		# load data from all connectors
415	!	for (dc in self$get_connectors()) {
416	!	if (inherits(dc, "TealDataConnector")) {
417	!	dc$get_server()(
418	!	id = dc$id,
419	!	connection = dc$get_connection(),
420	!	connectors = dc$get_items()
421		)
422	!	} else if (inherits(dc, "TealDatasetConnector")) {
423	!	dc$get_server()(id = dc$get_dataname())
424		}
425	!	if (dc$is_failed()) {
426	!	break
427		}
428		}
429
430	!	if (self$is_pulled()) {
431	!	logger::log_trace("TealData$server@1 data is pulled.")
432	!	withProgress(value = 1, message = "Checking data reproducibility", {
433		# We check first and then mutate.
434		# mutate_code is reproducible by default we assume that we don't
435		# have to check the result of the re-evaluation of the code
436	!	self$check_reproducibility()
437		})
438
439	!	withProgress(value = 1, message = "Executing processing code", {
440	!	self$execute_mutate()
441	!	self$check_metadata()
442		})
443	!	logger::log_info("Data ready to pass to the application.")
444	!	shinyjs::hide("delayed_data")
445	!	rv(self)
446		}
447		})
448	!	return(rv)
449		}
450		)
451		)

1		#' Get dataset label attribute
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' @param data \code{data.frame} from which attribute is extracted
6		#'
7		#' @return (\code{character}) label or \code{NULL} if it is missing
8		#'
9		#' @export
10		#'
11		#' @examples
12		#' data_label(example_cdisc_data("ADSL"))
13		data_label <- function(data) {
14	179x	attr(data, "label")
15		}
16
17		#' Set dataset label attribute
18		#'
19		#' @description `r lifecycle::badge("stable")`
20		#'
21		#' @param x \code{data.frame} for which attribute is set
22		#' @param value (\code{character}) label
23		#'
24		#' @return modified \code{x} object
25		#'
26		#' @export
27		#'
28		#' @examples
29		#' x <- teal.data::example_cdisc_data("ADSL")
30		#' data_label(x) <- "My custom label"
31		#' data_label(x)
32		`data_label<-` <- function(x, value) { # nolint
33	!	stopifnot(is.data.frame(x))
34	!	checkmate::assert_string(value)
35
36	!	attr(x, "label") <- value
37	!	x
38		}
39
40		#' Function that returns the default keys for a `CDISC` dataset by name
41		#'
42		#' @description `r lifecycle::badge("stable")`
43		#'
44		#' @param dataname name of the `CDISC` dataset
45		#'
46		#' @return \code{keys} object
47		#'
48		#' @export
49		#'
50		#' @examples
51		#' get_cdisc_keys("ADSL")
52		get_cdisc_keys <- function(dataname) {
53	306x	checkmate::assert_string(dataname)
54
55	306x	if (!(dataname %in% names(default_cdisc_keys))) {
56	!	stop(paste(sprintf("get_cdisc_keys does not support datasets called %s", dataname),
57	!	" Please specify the keys directly, for example:",
58	!	sprintf(
59	!	" cdisc_dataset(dataname = \"%s\", keys = c(\"STUDYID\", \"USUBJID\", ...), parent = \"ADSL\", ...)",
60	!	dataname
61		),
62	!	sep = "\n"
63		))
64		} else {
65	306x	cdisc_keys <- default_cdisc_keys[[dataname]]$primary
66
67	306x	return(cdisc_keys)
68		}
69		}
70
71		#' Extracts dataset and variable labels from a dataset.
72		#'
73		#' @description `r lifecycle::badge("stable")`
74		#'
75		#' @param data (`data.frame`) table to extract the labels from
76		#' @param fill (`logical(1)`) if `TRUE`, the function will return variable names for columns with non-existent labels;
77		#' otherwise will return `NA` for them
78		#'
79		#' @return `list` with two keys: `dataset_labels` and `column_labels`
80		#'
81		#' @export
82		#'
83		#' @examples
84		#' iris_with_labels <- iris
85		#' attr(iris_with_labels, "label") <- "Custom iris dataset with labels"
86		#' attr(iris_with_labels["Sepal.Length"], "label") <- c(`Sepal.Length` = "Sepal Length")
87		#' get_labels(iris_with_labels, fill = TRUE)
88		#' get_labels(iris_with_labels, fill = FALSE)
89		get_labels <- function(data, fill = TRUE) {
90	8x	stopifnot(is.data.frame(data))
91	8x	checkmate::assert_flag(fill)
92
93	8x	column_labels <- Map(function(col, colname) {
94	27x	label <- attr(col, "label")
95	27x	if (is.null(label)) {
96	25x	if (fill) {
97	20x	colname
98		} else {
99	8x	NA_character_
100		}
101		} else {
102	2x	if (!checkmate::test_string(label, na.ok = TRUE)) {
103	!	stop("label for variable ", colname, " is not a character string")
104		}
105	2x	as.vector(label) # because label might be a named vector
106		}
107	8x	}, data, colnames(data))
108	8x	column_labels <- unlist(column_labels, recursive = FALSE, use.names = TRUE)
109
110	8x	list("dataset_label" = data_label(data), "column_labels" = column_labels)
111		}

1		#' S3 generic for `to_relational_data` function.
2		#'
3		#' This function takes an object and converts into a `TealData` object, the primary data
4		#' object for use in teal applications.
5		#'
6		#' @param data `TealDataset`, `TealDatasetConnector`, `data.frame`, `MultiAssayExperiment`, `list`
7		#' or `function` returning a named list.
8		#'
9		#' @details Passing a `TealData` into this function leaves the object unchanged.
10		#'
11		#' @return `TealData` object
12		#'
13		#' @examples
14		#'
15		#' to_relational_data(head(iris))
16		#' to_relational_data(dataset("IRIS", head(iris)))
17		#' to_relational_data(list(iris = head(iris), mtcars = head(mtcars)))
18		#'
19		#' d_connector <- dataset_connector("iris", callable_function(function() head(iris)))
20		#' d_connector$pull()
21		#' to_relational_data(d_connector)
22		#'
23		#' @keywords internal
24		#' @export
25		to_relational_data <- function(data) {
26	18x	UseMethod("to_relational_data")
27		}
28
29		#' @keywords internal
30		#' @export
31		to_relational_data.data.frame <- function(data) { # nolint
32	2x	dataname <- deparse(substitute(data, parent.frame()), width.cutoff = 500L)
33
34	2x	if (grepl("\\)$", dataname) && inherits(data, "data.frame")) {
35	!	stop("Single data.frame shouldn't be provided as a result of a function call. Please name
36	!	the object first or use a named list.")
37		}
38
39	2x	if (dataname %in% names(default_cdisc_keys)) {
40	!	cdisc_data(cdisc_dataset(dataname, data))
41		} else {
42	2x	teal_data(dataset(dataname, data))
43		}
44		}
45
46		#' @keywords internal
47		#' @export
48		to_relational_data.TealDataset <- function(data) {
49	4x	dataname <- get_dataname(data)
50
51	4x	if (dataname %in% names(default_cdisc_keys)) {
52	2x	cdisc_data(data)
53		} else {
54	2x	teal_data(data)
55		}
56		}
57
58		#' @keywords internal
59		#' @export
60		to_relational_data.TealDatasetConnector <- function(data) { # nolint
61	1x	to_relational_data.TealDataset(data)
62		}
63
64		#' @keywords internal
65		#' @export
66		to_relational_data.list <- function(data) {
67	11x	checkmate::assert_list(
68	11x	data,
69	11x	types = c("dataset", "data.frame", "MultiAssayExperiment", "TealDataset", "TealDatasetConnector")
70		)
71
72	11x	call <- substitute(data, parent.frame())
73	11x	list_names <- names(data)
74	11x	parsed_names <- as.character(call)[-1]
75
76		if (
77		(
78	11x	length(list_names) == 0 &&
79	11x	length(parsed_names) == 0 &&
80	11x	any(sapply(data, inherits, c("dataset", "data.frame", "MultiAssayExperiment")))
81		) \|\|
82	11x	(any(list_names == "") && length(parsed_names) == 0) \|\|
83	11x	(any(is.na(list_names)))
84		) {
85	3x	stop("Unnamed lists shouldn't be provided as input for data. Please use a named list.")
86		}
87
88	8x	datasets_list <- lapply(
89	8x	seq_along(data),
90	8x	function(idx) {
91	15x	if (is.data.frame(data[[idx]]) \|\| inherits(data[[idx]], "MultiAssayExperiment")) {
92	12x	dataname <- if (length(list_names) == 0 \|\| list_names[[idx]] == "") {
93	3x	parsed_names[[idx]]
94		} else {
95	9x	list_names[[idx]]
96		}
97
98	12x	if (dataname %in% names(default_cdisc_keys)) {
99	!	cdisc_dataset(dataname, data[[idx]])
100		} else {
101	12x	dataset(dataname, data[[idx]])
102		}
103	3x	} else if (inherits(data[[idx]], "TealDataset") \|\| inherits(data[[idx]], "TealDatasetConnector")) {
104	3x	data[[idx]]
105		} else {
106	!	stop("Unknown class to create TealDataset from.")
107		}
108		}
109		)
110
111	8x	if (any(sapply(datasets_list, function(x) inherits(x, "CDISCTealDataset")))) {
112	!	do.call("cdisc_data", args = datasets_list)
113		} else {
114	8x	do.call("teal_data", args = datasets_list)
115		}
116		}
117
118		#' @keywords internal
119		#' @export
120		to_relational_data.MultiAssayExperiment <- function(data) { # nolint
121	1x	teal_data(dataset("MAE", data))
122		}
123
124		#' @keywords internal
125		#' @export
126		to_relational_data.TealData <- function(data) { # nolint
127	!	data
128		}

1		#' Get dataset primary keys
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#' Get dataset primary keys
5		#'
6		#' @param x an object of `TealDataset` or `TealDatasetConnector` class
7		#' @param dataname (`character`) name of dataset to return keys for
8		#' @param ... not used, only for support of S3
9		#'
10		#' @return (`character`) vector of column names
11		#'
12		#' @export
13		get_keys <- function(x, ...) {
14	92x	UseMethod("get_keys")
15		}
16
17		#' @rdname get_keys
18		#' @export
19		#' @examples
20		#' # TealDataset --------
21		#'
22		#' get_keys(
23		#' dataset(
24		#' "ADSL",
25		#' teal.data::example_cdisc_data("ADSL"),
26		#' keys = get_cdisc_keys("ADSL"),
27		#' code = "ADSL <- teal.data::example_cdisc_data(\"ADSL\")"
28		#' )
29		#' )
30		get_keys.TealDataset <- function(x, ...) {
31	72x	check_ellipsis(...)
32	72x	x$get_keys()
33		}
34
35		#' @rdname get_keys
36		#' @export
37		#' @examples
38		#' # TealDatasetConnector --------
39		#' library(magrittr)
40		#' pull_fun_adsl <- callable_function(teal.data::example_cdisc_data) %>%
41		#' set_args(list(dataname = "ADAE"))
42		#' get_keys(
43		#' dataset_connector(
44		#' "ADSL",
45		#' pull_fun_adsl,
46		#' keys = get_cdisc_keys("ADSL"),
47		#' )
48		#' )
49		get_keys.TealDatasetConnector <- function(x, ...) {
50	20x	check_ellipsis(...)
51	20x	x$get_keys()
52		}
53
54		#' @rdname get_keys
55		#' @export
56		#' @examples
57		#' # TealData --------
58		#'
59		#' get_keys(
60		#' teal_data(
61		#' dataset("x", data.frame(x1 = 1:10, y1 = 11:20), keys = "x1"),
62		#' dataset("y", data.frame(x2 = 1:10, y2 = 11:20), keys = "x2")
63		#' ),
64		#' "x"
65		#' )
66		get_keys.TealDataAbstract <- function(x, dataname, ...) {
67	!	check_ellipsis(...)
68	!	get_keys(x$get_items(dataname))
69		}
70
71
72
73		#' Set dataset primary keys
74		#'
75		#' @description `r lifecycle::badge("stable")`
76		#' Set dataset primary keys
77		#'
78		#' @param x an object of `TealDataset` or `TealDatasetConnector` class
79		#' @param keys optional, (`character`) vector with primary keys
80		#' @param dataname (`character`) name of dataset for which set the keys
81		#' @param ... not used, only for support of S3
82		#'
83		#' @return (`character`) vector of column names
84		#'
85		#' @export
86		set_keys <- function(x, ...) {
87	119x	UseMethod("set_keys")
88		}
89
90		#' @rdname set_keys
91		#' @export
92		#' @examples
93		#' # TealDataset --------
94		#'
95		#' set_keys(
96		#' dataset(
97		#' "DF",
98		#' data.frame(ID = 1:10, x = runif(10))
99		#' ),
100		#' keys = c("ID")
101		#' )
102		set_keys.TealDataset <- function(x, keys, ...) {
103	119x	check_ellipsis(...)
104	119x	x$set_keys(keys)
105		}
106
107		#' @rdname set_keys
108		#' @export
109		#' @examples
110		#' # TealDatasetConnector --------
111		#'
112		#' pull_fun <- callable_function(
113		#' function() {
114		#' data.frame(ID = 1:10, x = runif(10))
115		#' }
116		#' )
117		#' set_keys(
118		#' dataset_connector(
119		#' "DF",
120		#' pull_fun
121		#' ),
122		#' keys = c("ID")
123		#' )
124		set_keys.TealDatasetConnector <- function(x, keys, ...) {
125	!	check_ellipsis(...)
126	!	x$set_keys(keys)
127		}
128
129		#' @rdname set_keys
130		#' @export
131		#' @examples
132		#' # TealData --------
133		#'
134		#' set_keys(
135		#' teal_data(
136		#' dataset("x", data.frame(x1 = 1:10, y1 = 11:20), keys = "x1"),
137		#' dataset("y", data.frame(x2 = 1:10, y2 = 11:20), keys = "x2")
138		#' ),
139		#' "x",
140		#' c("x1", "y1")
141		#' )
142		set_keys.TealDataAbstract <- function(x, dataname, keys, ...) {
143	!	check_ellipsis(...)
144	!	set_keys(x$get_items(dataname), keys = keys)
145	!	return(invisible(x))
146		}

1		#' Ensure the ellipsis, ..., in method arguments are empty
2		#'
3		#' Ellipsis, ..., are needed as part of method arguments to allow for its arguments to be different from its generic's
4		#' arguments and for this to pass check(). Hence, ..., should always be empty. This function will check for this
5		#' condition.
6		#'
7		#' @param ... it should literally just be ...
8		#' @param stop TRUE to raise an error; FALSE will output warning message
9		#' @param allowed_args character vector naming arguments that are allowed in the \code{...}.
10		#' to allow for unnamed arguments, let "" be one of the elements in this character vector.
11		#'
12		#' @return \code{NULL} if ... is empty
13		#'
14		#' @keywords internal
15		#'
16		#' @examples
17		#' method.class <- function(a, b, c, ...) {
18		#' check_ellipsis(...)
19		#' }
20		#' method.class <- function(a, b, c, ...) {
21		#' check_ellipsis(..., allowed_args = c("y", "z"))
22		#' }
23		check_ellipsis <- function(..., stop = FALSE, allowed_args = character(0)) {
24	491x	if (!missing(...)) {
25	20x	checkmate::assert_flag(stop)
26	20x	checkmate::assert_character(allowed_args, min.len = 0, null.ok = TRUE, any.missing = FALSE)
27	20x	args <- list(...)
28	20x	arg_names <- names(args)
29	20x	if (is.null(arg_names)) {
30	5x	arg_names <- rep("", length(args))
31		}
32	20x	extra_args <- arg_names[!is.element(arg_names, allowed_args)]
33	20x	if (length(extra_args) == 0) {
34	4x	return(invisible(NULL))
35		}
36	16x	message <- paste(length(extra_args), "total unused argument(s).")
37
38	16x	named_extra_args <- extra_args[!vapply(extra_args, identical, logical(1), "")]
39	16x	if (length(named_extra_args) > 0) {
40	12x	message <- paste0(
41	12x	message,
42		" ",
43	12x	length(named_extra_args),
44	12x	" with name(s): ",
45	12x	paste(named_extra_args, collapse = ", "),
46		"."
47		)
48		}
49	16x	if (stop) {
50	8x	stop(message)
51		} else {
52	8x	warning(message)
53		}
54		}
55		}
56
57		#' Whether the variable name is good to use within Show R Code
58		#'
59		#' Spaces are problematic because the variables must be escaped
60		#' with backticks.
61		#' Also, they should not start with a number as R may silently make
62		#' it valid by changing it.
63		#' Therefore, we only allow alphanumeric characters with underscores.
64		#' The first character of the `name` must be an alphabetic character
65		#' and can be followed by alphanumeric characters.
66		#'
67		#' @md
68		#'
69		#' @param name `character, single or vector` name to check
70		#' @keywords internal
71		#'
72		#' @examples
73		#' teal.data:::check_simple_name("aas2df")
74		#' teal.data:::check_simple_name("ADSL")
75		#' teal.data:::check_simple_name("ADSLmodified")
76		#' teal.data:::check_simple_name("ADSL_2")
77		#' teal.data:::check_simple_name("a1")
78		#' # the following fail
79		#' \dontrun{
80		#' teal.data:::check_simple_name("1a")
81		#' teal.data:::check_simple_name("ADSL.modified")
82		#' teal.data:::check_simple_name("ADSL_modified")
83		#' teal.data:::check_simple_name("a1...")
84		#' }
85		check_simple_name <- function(name) {
86	521x	checkmate::assert_character(name, min.len = 1, any.missing = FALSE)
87	521x	if (!grepl("^[[:alpha:]][a-zA-Z0-9_]*$", name, perl = TRUE)) {
88	5x	stop(
89	5x	"name '",
90	5x	name,
91	5x	"' must only contain alphanumeric characters (with underscores)",
92	5x	" and the first character must be an alphabetic character"
93		)
94		}
95		}

1		#' Get a [`TealDataset`] objects.
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' @param x ([`TealData`])\cr
6		#' object containing datasets.
7		#' @export
8		#' @return `list` or `TealDataset` objects
9		get_datasets <- function(x) {
10	9x	UseMethod("get_datasets")
11		}
12
13		#' @rdname get_datasets
14		#' @export
15		#' @examples
16		#'
17		#' library(magrittr)
18		#'
19		#' # TealData --------
20		#' adsl <- cdisc_dataset(
21		#' dataname = "ADSL",
22		#' x = teal.data::example_cdisc_data("ADSL"), ,
23		#' code = "library(teal.data)\nADSL <- teal.data::example_cdisc_data(\"ADSL\")"
24		#' )
25		#'
26		#' adae <- cdisc_dataset(
27		#' dataname = "ADAE",
28		#' x = teal.data::example_cdisc_data("ADAE"),
29		#' code = "library(teal.data)\nADAE <- teal.data::example_cdisc_data(\"ADAE\")"
30		#' )
31		#'
32		#' rd <- cdisc_data(adsl, adae)
33		#' get_datasets(rd)
34		#'
35		#' # TealDataConnector --------
36		#' random_data_connector <- function(dataname) {
37		#' fun_dataset_connector(
38		#' dataname = dataname,
39		#' fun = teal.data::example_cdisc_data,
40		#' fun_args = list(dataname = dataname),
41		#' )
42		#' }
43		#'
44		#' adsl_cf <- callable_function(teal.data::example_cdisc_data) %>%
45		#' set_args(list(dataname = "ADSL"))
46		#' adsl <- cdisc_dataset_connector(
47		#' dataname = "ADSL",
48		#' pull_callable = adsl_cf,
49		#' keys = get_cdisc_keys("ADSL")
50		#' )
51		#' adlb_cf <- callable_function(teal.data::example_cdisc_data) %>%
52		#' set_args(list(dataname = "ADLB"))
53		#' adlb <- cdisc_dataset_connector(
54		#' dataname = "ADLB",
55		#' pull_callable = adlb_cf,
56		#' keys = get_cdisc_keys("ADLB")
57		#' )
58		#'
59		#' rdc <- relational_data_connector(
60		#' connection = data_connection(),
61		#' connectors = list(adsl, adlb)
62		#' )
63		#'
64		#' rdc$set_ui(function(id, connection, connectors) p("Example UI"))
65		#' rdc$set_server(
66		#' function(id, connection, connectors) {
67		#' moduleServer(
68		#' id = id,
69		#' module = function(input, output, session) {
70		#' # Note this is simplified as we are not opening a real connection here
71		#' for (connector in connectors) {
72		#' set_args(connector, args = list(name = input$name))
73		#' # pull each dataset
74		#' connector$get_server()(id = connector$get_dataname())
75		#' if (connector$is_failed()) {
76		#' break
77		#' }
78		#' }
79		#' }
80		#' )
81		#' }
82		#' )
83		#' \dontrun{
84		#' load_datasets(rdc)
85		#' get_datasets(rdc)
86		#' }
87		#'
88		#' # TealData --------
89		#' \dontrun{
90		#' drc <- cdisc_data(rdc, adae)
91		#' get_datasets(drc)
92		#' }
93		get_datasets.TealDataAbstract <- function(x) { # nolint
94	7x	res <- x$get_datasets()
95	6x	if (length(res) == 0) {
96	!	return(invisible(NULL))
97		}
98	6x	res
99		}
100
101		#' @rdname get_datasets
102		#' @export
103		#' @examples
104		#'
105		#' # TealDatasetConnector --------
106		#' adsl_cf <- callable_function(teal.data::example_cdisc_data) %>%
107		#' set_args(list(dataname = "ADSL"))
108		#' rdc <- cdisc_dataset_connector("ADSL", adsl_cf, keys = get_cdisc_keys("ADSL"))
109		#' \dontrun{
110		#' load_datasets(rdc)
111		#' get_datasets(rdc)
112		#' }
113		get_datasets.TealDatasetConnector <- function(x) { # nolint
114	1x	res <- x$get_dataset()
115	1x	if (length(res) == 0) {
116	!	return(invisible(NULL))
117		}
118	1x	res
119		}
120
121		#' @rdname get_datasets
122		#' @export
123		#' @examples
124		#'
125		#' # TealDataset --------
126		#' adsl <- cdisc_dataset(
127		#' dataname = "ADSL",
128		#' x = teal.data::example_cdisc_data("ADSL"),
129		#' code = "library(teal.data)\nADSL <- example_cdisc_data(\"ADSL\")"
130		#' )
131		#'
132		#' get_datasets(adsl)
133		get_datasets.TealDataset <- function(x) {
134	1x	x
135		}

1		#' Mutate dataset by code
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' @param x (`TealDataset`)\cr
6		#' object.
7		#' @param dataname (`character`)\cr
8		#' `Dataname` to be mutated.
9		#' @param code (`character`)\cr
10		#' Code to mutate the dataset. Must contain the `dataset$dataname`. Or can also be an object
11		#' of class `PythonCodeClass` returned by [`python_code`].
12		#' @param script (`character`)\cr
13		#' file that contains R Code that can be read using [`read_script`].
14		#' Preferred before `code` argument.
15		#' @param vars (named `list`)) \cr
16		#' In case when this object code depends on other `TealDataset` object(s) or
17		#' other constant value, this/these object(s) should be included as named
18		#' element(s) of the list. For example if this object code needs `ADSL`
19		#' object we should specify `vars = list(ADSL = <adsl object>)`.
20		#' It's recommended to include `TealDataset` or `TealDatasetConnector` objects to
21		#' the `vars` list to preserve reproducibility. Please note that `vars`
22		#' are included to this object as local `vars` and they cannot be modified
23		#' within another dataset.
24		#' @param ... not used, only for support of S3
25		#'
26		#' @return modified `x` object
27		#'
28		#' @export
29		mutate_dataset <- function(x, ...) {
30	64x	UseMethod("mutate_dataset")
31		}
32
33		#' @rdname mutate_dataset
34		#' @examples
35		#' library(magrittr)
36		#'
37		#' ADSL <- teal.data::example_cdisc_data("ADSL")
38		#'
39		#' ADSL_dataset <- dataset(
40		#' dataname = "ADSL",
41		#' x = ADSL,
42		#' label = "AdAM subject-level dataset",
43		#' code = "ADSL <- teal.data::example_cdisc_data(\"ADSL\")"
44		#' )
45		#' ADSL_mutated <- ADSL_dataset %>%
46		#' mutate_dataset(code = "ADSL$new_variable <- 1")
47		#'
48		#' ADSL_mutated$get_raw_data()$new_variable[1]
49		#'
50		#' # Use an R script to mutate the data
51		#' file_example <- tempfile(fileext = ".R")
52		#' writeLines(
53		#' text = c(
54		#' "ADSL <- ADSL %>%
55		#' dplyr::mutate(new_variable = new_variable * 2)"
56		#' ),
57		#' con = file_example
58		#' )
59		#'
60		#' ADSL_mutated <- ADSL_mutated %>%
61		#' mutate_dataset(script = file_example)
62		#'
63		#' ADSL_mutated$get_raw_data()$new_variable[1]
64		#'
65		#' ADSL_mutated <- ADSL_mutated %>%
66		#' mutate_dataset(code = read_script(file_example))
67		#'
68		#' ADSL_mutated$get_raw_data()$new_variable[1]
69		#' @export
70		mutate_dataset.TealDataset <- function(x,
71		code = character(0),
72		script = character(0),
73		vars = list(),
74		...) {
75	31x	check_ellipsis(...)
76	31x	checkmate::assert_list(vars, min.len = 0, names = "unique")
77
78	31x	code <- code_from_script(code, script)
79	29x	x$mutate(code = code, vars = vars, ...)
80		}
81
82
83		#' @rdname mutate_dataset
84		#' @export
85		mutate_dataset.TealDatasetConnector <- function(x, # nolint
86		code = character(0),
87		script = character(0),
88		vars = list(),
89		...) {
90	29x	check_ellipsis(...)
91	29x	checkmate::assert_list(vars, min.len = 0, names = "unique")
92	29x	code <- code_from_script(code, script)
93	29x	x$mutate(code = code, vars = vars, ...)
94		}
95
96
97		#' @rdname mutate_dataset
98		#' @export
99		mutate_dataset.TealDataAbstract <- function(x,
100		dataname,
101		code = character(0),
102		script = character(0),
103		vars = list(),
104		...) {
105	4x	check_ellipsis(...)
106	4x	checkmate::assert_list(vars, min.len = 0, names = "unique")
107
108	4x	code <- code_from_script(code, script)
109	4x	x$mutate_dataset(dataname = dataname, code = code, vars = vars)
110		}
111
112
113
114		#' Mutate data by code
115		#'
116		#' @description `r lifecycle::badge("experimental")`
117		#' Code used in this mutation is not linked to particular
118		#' but refers to all datasets.
119		#' Consequence of this is that when using `get_code(<dataset>)` this
120		#' part of the code will be returned for each dataset specified. This method
121		#' should be used only if particular call involve changing multiple datasets.
122		#' Otherwise please use `mutate_dataset`.
123		#' Execution of the code is delayed after datasets are pulled
124		#' (`isTRUE(is_pulled)`).
125		#'
126		#' @param x (`TealDataAbstract`)\cr
127		#' object.
128		#' @inheritParams mutate_dataset
129		#'
130		#' @return modified `x` object
131		#'
132		#' @export
133		mutate_data <- function(x,
134		code = character(0),
135		script = character(0),
136		vars = list()) {
137	3x	UseMethod("mutate_data")
138		}
139
140		#' @rdname mutate_data
141		#' @export
142		mutate_data.TealDataAbstract <- function(x,
143		code = character(0),
144		script = character(0),
145		vars = list()) {
146	3x	checkmate::assert_list(vars, min.len = 0, names = "unique")
147
148	3x	code <- code_from_script(code, script)
149	3x	x$mutate(code = code, vars = vars)
150	3x	return(invisible(x))
151		}

1		## CallableCode ====
2		#'
3		#' @title A \code{CallableCode} class of objects
4		#'
5		#' @description `r lifecycle::badge("stable")`
6		#' Object that stores code to reproduce an object. It includes methods to
7		#' get or run the code and return the object.
8		#'
9		CallableCode <- R6::R6Class( # nolint
10		"CallableCode",
11		inherit = Callable,
12
13		## __Public Methods ====
14		public = list(
15		#' @description
16		#' Create a new \code{CallableCode} object
17		#'
18		#' @param code (\code{character})\cr
19		#' a string containing R code to reproduce the desired object.
20		#' @param env (\code{environment})\cr
21		#' environment where function will be evaluated
22		#'
23		#' @return new \code{CallableCode} object
24		initialize = function(code, env = new.env(parent = parent.env(globalenv()))) {
25	19x	if (!checkmate::test_string(code)) {
26	!	stop("A string of length one containing the code needed to produce the object must be provided.")
27		}
28
29		# reposition all library calls in the code so that they are
30		# visible in the new env
31	19x	env$library <- function(...) {
32	4x	mc <- match.call()
33	4x	mc[[1]] <- quote(base::library)
34	4x	eval(mc, envir = globalenv())
35	4x	this_env <- parent.frame()
36
37	4x	if (!identical(this_env, globalenv())) {
38	4x	parent.env(this_env) <- parent.env(globalenv())
39		}
40		}
41
42	19x	super$initialize(env = env)
43
44	19x	private$code <- code
45	19x	private$call <- private$get_callable_code(code)
46	15x	logger::log_trace("CallableCode initialized.")
47
48	15x	return(invisible(self))
49		},
50		#' @description
51		#' Get sequence of calls from the code supplied to produce the object.
52		#'
53		#' @param deparse (\code{logical} value)\cr
54		#' whether to return a deparsed version of call
55		#' @param args (\code{NULL})\cr
56		#' available to be consistent with \code{CallableFunction} but are not used to
57		#' retrieve the call.
58		#'
59		#' @return \code{list} of \code{calls} or \code{character} depending on \code{deparse} argument
60		get_call = function(deparse = TRUE, args = NULL) {
61	38x	checkmate::assert_flag(deparse)
62	38x	if (!is.null(args)) {
63	!	stop("'args' are not used to retrieve the call.")
64		}
65
66	38x	res <- if (deparse) {
67	4x	paste0(vapply(private$call, deparse1, character(1)), collapse = "\n")
68		} else {
69	34x	private$call
70		}
71
72	38x	return(res)
73		}
74		),
75
76		## __Private Fields ====
77		private = list(
78		code = NULL,
79		## __Private Methods ====
80		# @description
81		# Determines whether code is valid and callable. If not then stores error message.
82		#
83		# @param code \code{character} string to check
84		#
85		# @return \code{expression} parsed from the supplied code
86		#
87		get_callable_code = function(code) {
88	19x	expr <- tryCatch(
89	19x	str2expression(code),
90	19x	error = function(e) {
91	3x	private$error_msg <- e$message
92	3x	private$failed <- TRUE
93		}
94		)
95	19x	if (length(expr) >= 1 && !private$failed) {
96	15x	return(expr)
97		} else {
98	4x	stop(paste("Code supplied is not valid:", private$error_msg))
99		}
100		}
101		)
102		)
103
104		## Constructors ====
105
106		#' Create \code{\link{CallableCode}} object
107		#'
108		#' @description `r lifecycle::badge("stable")`
109		#'
110		#' Create \link{CallableCode} object to execute specific code and get reproducible call.
111		#'
112		#' @param code (\code{character})\cr
113		#' a string containing R code to reproduce the desired object. Please be aware
114		#' that objects assigned to temporary environment are locked which means
115		#' that they can't be modified.
116		#'
117		#' @return \code{CallableCode} object
118		#'
119		#' @export
120		#'
121		#' @examples
122		#' cf <- callable_code(code = "mtcars")
123		#' cf$run()
124		#' cf$get_call()
125		callable_code <- function(code) {
126	19x	CallableCode$new(code)
127		}

1		#' S3 method for getting a `dataname(s)` of
2		#' (`TealDataAbstract`, (`TealDatasetConnector` or
3		#' `TealDataset`) R6 object
4		#'
5		#' @description `r lifecycle::badge("stable")`
6		#'
7		#' @param x (`TealDataAbstract`, `TealDatasetConnector` or
8		#' `TealDataset`) object
9		#'
10		#' @return `dataname` (`character`) A given name for the dataset(s)
11		#' it may not contain spaces
12		#' @export
13		get_dataname <- function(x) {
14	731x	UseMethod("get_dataname")
15		}
16
17		#' @rdname get_dataname
18		#' @export
19		get_dataname.TealDataAbstract <- function(x) { # nolint
20	15x	return(x$get_datanames())
21		}
22
23		#' @rdname get_dataname
24		#' @export
25		get_dataname.TealDatasetConnector <- function(x) { # nolint
26	213x	return(x$get_dataname())
27		}
28
29
30		#' @rdname get_dataname
31		#' @export
32		get_dataname.TealDataset <- function(x) { # nolint
33	503x	return(x$get_dataname())
34		}

1		#' Is pulled
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#' S3 method to determine if dataset is pulled (loaded).
5		#'
6		#' @param x ([`TealDatasetConnector`], [`TealDataset`] or [`TealDataAbstract`])
7		#'
8		#' @return (`logical`) `TRUE` if connector has been already pulled, else `FALSE`.
9		#' @export
10		is_pulled <- function(x) {
11	245x	UseMethod("is_pulled")
12		}
13
14		#' @rdname is_pulled
15		#' @export
16		#'
17		#' @examples
18		#' # TealDatasetConnector --------
19		#' library(magrittr)
20		#' pull_fun_adsl <- callable_function(teal.data::example_cdisc_data) %>%
21		#' set_args(list(dataname = "ADSL"))
22		#' x <- dataset_connector("ADSL", pull_fun_adsl)
23		#'
24		#' is_pulled(x)
25		#'
26		#' load_dataset(x)
27		#' is_pulled(x)
28		is_pulled.TealDatasetConnector <- function(x) {
29	59x	return(x$is_pulled())
30		}
31
32		#' @rdname is_pulled
33		#' @export
34		#'
35		#' @examples
36		#' # TealDataset --------
37		#' x <- dataset(
38		#' dataname = "XY",
39		#' x = data.frame(x = c(1, 2), y = c("a", "b"), stringsAsFactors = FALSE),
40		#' keys = "y",
41		#' code = "XY <- data.frame(x = c(1, 2), y = c('aa', 'bb'),
42		#' stringsAsFactors = FALSE)"
43		#' )
44		#'
45		#' is_pulled(x)
46		is_pulled.TealDataset <- function(x) {
47	173x	return(x$is_pulled())
48		}
49
50		#' @rdname is_pulled
51		#' @export
52		#'
53		#' @examples
54		#'
55		#' library(magrittr)
56		#'
57		#' # TealData --------
58		#' x1 <- dataset(
59		#' x = teal.data::example_cdisc_data("ADSL"),
60		#' dataname = "ADSL",
61		#' keys = get_cdisc_keys("ADSL"),
62		#' code = "ADSL <- teal.data::example_cdisc_data(\"ADSL\")",
63		#' label = "ADTTE dataset"
64		#' )
65		#'
66		#' x2 <- dataset(
67		#' x = teal.data::example_cdisc_data("ADTTE"),
68		#' dataname = "ADTTE",
69		#' keys = get_cdisc_keys("ADTTE"),
70		#' code = "ADTTE <- teal.data::example_cdisc_data(\"ADTTE\")",
71		#' label = "ADTTE dataset"
72		#' )
73		#'
74		#' rd <- teal_data(x1, x2)
75		#' is_pulled(rd)
76		#'
77		#' # TealDataConnector --------
78		#' adsl_cf <- callable_function(teal.data::example_cdisc_data) %>%
79		#' set_args(list(dataname = "ADSL"))
80		#' adsl <- cdisc_dataset_connector(
81		#' dataname = "ADSL",
82		#' pull_callable = adsl_cf,
83		#' keys = get_cdisc_keys("ADSL")
84		#' )
85		#'
86		#' new_cf <- callable_function(function(x) {
87		#' x$NEW <- 1:nrow(x)
88		#' x
89		#' })
90		#' new_cf$set_args(list(x = as.name("x")))
91		#' new <- cdisc_dataset_connector(
92		#' dataname = "NEW",
93		#' pull_callable = new_cf,
94		#' keys = get_cdisc_keys("ADSL"),
95		#' vars = list(x = adsl)
96		#' )
97		#'
98		#' rdc <- cdisc_data(adsl, new)
99		#'
100		#' is_pulled(rdc)
101		#' \dontrun{
102		#' load_datasets(rdc)
103		#' is_pulled(rdc)
104		#' }
105		is_pulled.TealDataAbstract <- function(x) { # nolint
106	13x	return(x$is_pulled())
107		}

1		#' Set arguments of a `CallableFunction`
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#' Set arguments of a `CallableFunction`
5		#'
6		#' @param x `CallableFunction` or `TealDatasetConnector`)
7		#' @param args (`NULL` or named `list`) dynamic arguments to function
8		#'
9		#' @return nothing
10		#' @rdname set_args
11		#' @export
12		set_args <- function(x, args) {
13	14x	UseMethod("set_args")
14		}
15
16		#' @rdname set_args
17		#' @export
18		#' @examples
19		#' ## Using CallableFunction
20		#' fun <- callable_function(example_cdisc_data)
21		#' set_args(fun, list(dataname = "ADSL"))
22		set_args.CallableFunction <- function(x, args) {
23	13x	x$set_args(args)
24	13x	return(invisible(x))
25		}
26
27		#' @rdname set_args
28		#' @export
29		#' @examples
30		#' ## Using CallableCode
31		#' code <- callable_code("example_cdisc_data()")
32		#' set_args(code, list(df = "adsl"))
33		set_args.CallableCode <- function(x, args) {
34	!	warning(
35	!	"'CallableCode' is unchangable. Ignoring arguments set by 'set_args'",
36	!	call. = FALSE
37		)
38	!	return(invisible(x))
39		}
40
41		#' @rdname set_args
42		#' @export
43		#' @examples
44		#' ## Using TealDatasetConnector
45		#' ds <- dataset_connector("x", pull_callable = callable_function(data.frame))
46		#' set_args(ds, list(x = 1:5, y = letters[1:5]))
47		set_args.TealDatasetConnector <- function(x, args) {
48	1x	x$set_args(args)
49	1x	return(invisible(x))
50		}

1		#' S3 method for getting a label of
2		#' (`TealDatasetConnector` or `TealDataset`) R6 object
3		#'
4		#' @description `r lifecycle::badge("stable")`
5		#'
6		#' @param x (`TealDatasetConnector` or `TealDataset`) R6 object
7		#'
8		#' @return label (`character`) Label to describe the dataset
9		#' @export
10		get_dataset_label <- function(x) {
11	48x	UseMethod("get_dataset_label")
12		}
13
14		#' @rdname get_dataset_label
15		#' @export
16		#' @examples
17		#' fun <- callable_function(data.frame)
18		#' fun$set_args(list(c1 = seq_len(10)))
19		#'
20		#' x <- dataset_connector(
21		#' pull_callable = fun,
22		#' dataname = "ADSL",
23		#' label = "My custom label"
24		#' )
25		#' get_dataset_label(x)
26		get_dataset_label.TealDatasetConnector <- function(x) { # nolint
27	17x	return(x$get_dataset_label())
28		}
29
30		#' @rdname get_dataset_label
31		#' @export
32		#' @examples
33		#' ADSL <- example_cdisc_data("ADSL")
34		#' ADSL_dataset <- dataset(dataname = "ADSL", x = ADSL, label = "My custom label")
35		#' get_dataset_label(ADSL_dataset)
36		get_dataset_label.TealDataset <- function(x) {
37	31x	return(x$get_dataset_label())
38		}

1		#' This function returns a dummy dataset for testing examples and should only be used within `teal.data`.
2		#'
3		#' It is not meant to retrieve the SCDA dataset, and the dataset itself is not maintained here.
4		#'
5		#' This function creates a copy of the SCDA data for testing purposes.
6		#'
7		#' CDISC data includes `ADSL`, `ADAE`, `ADLB`, `ADCM`, `ADEX`, `ADRS`, `ADTR` and `ADTTE`.
8		#'
9		#' @param dataname name of the `CDISC` dataset
10		#'
11		#' @return `cdisc_data`
12		#'
13		#' @export
14		example_cdisc_data <- function(dataname) {
15		# Define the available datasets
16	33x	datasets <- c("ADSL", "ADAE", "ADLB", "ADCM", "ADEX", "ADRS", "ADTR", "ADTTE", "ADVS")
17
18		# Check if the provided dataname is valid
19	33x	if (dataname %in% datasets) {
20	33x	dataset <- get(paste0("r", dataname))
21	33x	return(dataset)
22		} else {
23	!	stop("Invalid dataname. Please provide one of the following: ", paste(datasets, collapse = ", "))
24		}
25		}

1		#' Data input for teal app
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#' Function takes datasets and creates `TealData` object which can be used in `teal` applications.
5		#'
6		#' @note This function does not automatically assign keys to `TealDataset`
7		#' and `TealDatasetConnector` objects passed to it. If the keys are needed
8		#' they should be assigned before calling `cdisc_data`. See example:
9		#' ```
10		#' test_dataset <- dataset("ADAE", teal.data::example_cdisc_data("ADAE")) # does not have keys
11		#' test_adsl <- cdisc_dataset("ADSL", teal.data::example_cdisc_data("ADSL"))
12		#' test_data <- cdisc_data(test_dataset, test_adsl)
13		#' get_keys(test_data, "ADAE") # returns character(0)
14		#'
15		#' test_dataset <- cdisc_dataset("ADAE", teal.data::example_cdisc_data("ADAE"))
16		#' test_data <- cdisc_data(test_dataset, test_adsl)
17		#' get_keys(test_data, "ADAE") # returns [1] "STUDYID" "USUBJID" "ASTDTM" "AETERM" "AESEQ"
18		#' ```
19		#' @inheritParams teal_data
20		#' @param ... (`TealDataConnector`, `TealDataset` or
21		#' `TealDatasetConnector`) elements to include.
22		#' @param join_keys (`JoinKeys`) or a single (`JoinKeySet`)\cr
23		#' (optional) object with datasets column names used for joining.
24		#' If empty then it would be automatically derived basing on intersection of datasets primary keys
25		#'
26		#' @return a `TealData` object
27		#'
28		#' @details This function checks if there were keys added to all data sets
29		#'
30		#' @export
31		#'
32		#' @examples
33		#'
34		#' ADSL <- teal.data::example_cdisc_data("ADSL")
35		#' ADTTE <- teal.data::example_cdisc_data("ADTTE")
36		#'
37		#' # basic example
38		#' cdisc_data(
39		#' cdisc_dataset("ADSL", ADSL),
40		#' cdisc_dataset("ADTTE", ADTTE),
41		#' code = "ADSL <- teal.data::example_cdisc_data(\"ADSL\")
42		#' ADTTE <- teal.data::example_cdisc_data(\"ADTTE\")",
43		#' check = TRUE
44		#' )
45		#'
46		#' # Example with keys
47		#' cdisc_data(
48		#' cdisc_dataset("ADSL", ADSL,
49		#' keys = c("STUDYID", "USUBJID")
50		#' ),
51		#' cdisc_dataset("ADTTE", ADTTE,
52		#' keys = c("STUDYID", "USUBJID", "PARAMCD"),
53		#' parent = "ADSL"
54		#' ),
55		#' join_keys = join_keys(
56		#' join_key(
57		#' "ADSL",
58		#' "ADTTE",
59		#' c("STUDYID" = "STUDYID", "USUBJID" = "USUBJID")
60		#' )
61		#' ),
62		#' code = "ADSL <- teal.data::example_cdisc_data(\"ADSL\")
63		#' ADTTE <- teal.data::example_cdisc_data(\"ADTTE\")",
64		#' check = TRUE
65		#' )
66		cdisc_data <- function(...,
67		join_keys = teal.data::join_keys(),
68		code = "",
69		check = FALSE) {
70	21x	data_objects <- list(...)
71	21x	checkmate::assert_list(
72	21x	data_objects,
73	21x	types = c("TealDataset", "TealDatasetConnector", "TealDataConnector")
74		)
75	21x	if (inherits(join_keys, "JoinKeySet")) {
76	!	join_keys <- teal.data::join_keys(join_keys)
77		}
78
79	21x	update_join_keys_to_primary(data_objects, join_keys)
80
81	21x	retrieve_parents <- function(x) {
82	43x	tryCatch(
83	43x	x$get_parent(),
84	43x	error = function(cond) rep(character(0), length(x$get_datanames()))
85		)
86		}
87
88	21x	new_parents_fun <- function(data_objects) {
89	25x	lapply(data_objects, function(x) {
90	47x	if (inherits(x, "TealDataConnector")) {
91	4x	unlist(new_parents_fun(x$get_items()), recursive = FALSE)
92		} else {
93	43x	list(retrieve_parents(x))
94		}
95		})
96		}
97
98	21x	new_parents <- unlist(new_parents_fun(data_objects), recursive = FALSE)
99
100	21x	names(new_parents) <- unlist(lapply(data_objects, function(x) {
101	42x	if (inherits(x, "TealDataConnector")) {
102	4x	lapply(x$get_items(), function(z) z$get_dataname())
103		} else {
104	38x	x$get_datanames()
105		}
106		}))
107
108	21x	if (is_dag(new_parents)) {
109	1x	stop("Cycle detected in a parent and child dataset graph.")
110		}
111	20x	join_keys$set_parents(new_parents)
112	20x	join_keys$update_keys_given_parents()
113
114	20x	x <- TealData$new(..., check = check, join_keys = join_keys)
115
116	20x	if (length(code) > 0 && !identical(code, "")) {
117	2x	x$set_pull_code(code = code)
118		}
119
120	19x	x$check_reproducibility()
121	18x	x$check_metadata()
122	18x	return(x)
123		}
124
125		#' Load `TealData` object from a file
126		#'
127		#' @description `r lifecycle::badge("deprecated")`
128		#'
129		#' @inheritParams teal_data_file
130		#'
131		#' @return `TealData` object
132		#'
133		#' @export
134		#'
135		#' @examples
136		#' file_example <- tempfile(fileext = ".R")
137		#' writeLines(
138		#' text = c(
139		#' "# code>
140		#' ADSL <- teal.data::example_cdisc_data('ADSL')
141		#' ADTTE <- teal.data::example_cdisc_data('ADTTE')
142		#'
143		#' cdisc_data(
144		#' cdisc_dataset(\"ADSL\", ADSL), cdisc_dataset(\"ADTTE\", ADTTE),
145		#' code = \"ADSL <- teal.data::example_cdisc_data('ADSL')
146		#' ADTTE <- teal.data::example_cdisc_data('ADTTE')\",
147		#' check = FALSE
148		#' )
149		#' # <code"
150		#' ),
151		#' con = file_example
152		#' )
153		#'
154		#' cdisc_data_file(file_example)
155		cdisc_data_file <- function(path, code = get_code(path)) {
156	2x	lifecycle::deprecate_warn(when = "0.1.3", what = "cdisc_data_file()", with = "teal_data_file()")
157	2x	object <- object_file(path, "TealData")
158	2x	object$mutate(code)
159	2x	return(object)
160		}

1		#' Teal data
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#' Universal function to pass data to teal application
5		#'
6		#' @param ... (`TealDataConnector`, `TealDataset`, `TealDatasetConnector`)\cr
7		#' objects
8		#' @param join_keys (`JoinKeys`) or a single (`JoinKeySet`)\cr
9		#' (optional) object with dataset column relationships used for joining.
10		#' If empty then no joins between pairs of objects
11		#' @param code (`character`) code to reproduce the datasets.
12		#' @param check (`logical`) reproducibility check - whether to perform a check that the pre-processing
13		#' code included in the object definitions actually produces those objects.
14		#' If `check` is true and preprocessing code is empty an error will be thrown.
15		#'
16		#' @return (`TealData`)
17		#'
18		#' @export
19		#'
20		#' @examples
21		#' x1 <- dataset(
22		#' "x1",
23		#' iris,
24		#' code = "x1 <- iris"
25		#' )
26		#'
27		#' x2 <- dataset(
28		#' "x2",
29		#' mtcars,
30		#' code = "x2 <- mtcars"
31		#' )
32		#'
33		#' teal_data(x1, x2)
34		teal_data <- function(...,
35		join_keys = teal.data::join_keys(),
36		code = "",
37		check = FALSE) {
38	28x	data_objects <- list(...)
39	28x	checkmate::assert_list(
40	28x	data_objects,
41	28x	types = c("TealDataset", "TealDatasetConnector", "TealDataConnector")
42		)
43	26x	if (inherits(join_keys, "JoinKeySet")) {
44	!	join_keys <- teal.data::join_keys(join_keys)
45		}
46
47	26x	update_join_keys_to_primary(data_objects, join_keys)
48
49	26x	x <- TealData$new(..., check = check, join_keys = join_keys)
50
51	26x	if (length(code) > 0 && !identical(code, "")) {
52	!	x$set_pull_code(code = code)
53		}
54
55	26x	x$check_reproducibility()
56	26x	x$check_metadata()
57
58	25x	return(x)
59		}
60
61
62		#' Load `TealData` object from a file
63		#'
64		#' @description `r lifecycle::badge("experimental")`
65		#' Please note that the script has to end with a call creating desired object. The error will be raised otherwise.
66		#'
67		#' @param path A (`connection`) or a (`character`)\cr
68		#' string giving the pathname of the file or URL to read from. "" indicates the connection `stdin`.
69		#' @param code (`character`)\cr
70		#' reproducible code to re-create object
71		#'
72		#' @return `TealData` object
73		#'
74		#'
75		#' @export
76		#'
77		#' @examples
78		#' # simple example
79		#' file_example <- tempfile(fileext = ".R")
80		#' writeLines(
81		#' text = c(
82		#' "library(teal.data)
83		#'
84		#' x1 <- dataset(dataname = \"IRIS\",
85		#' x = iris,
86		#' code = \"IRIS <- iris\")
87		#'
88		#' x2 <- dataset(dataname = \"MTCARS\",
89		#' x = mtcars,
90		#' code = \"MTCARS <- mtcars\")
91		#'
92		#' teal_data(x1, x2)"
93		#' ),
94		#' con = file_example
95		#' )
96		#' teal_data_file(file_example, code = character(0))
97		teal_data_file <- function(path, code = get_code(path)) {
98	2x	object <- object_file(path, "TealData")
99	2x	object$mutate(code)
100	2x	return(object)
101		}
102
103		#' Add primary keys as join_keys to a dataset self
104		#'
105		#' @param data_objects (`list`) of `TealDataset`, `TealDatasetConnector` or `TealDataConnector` objects
106		#' @param join_keys (`JoinKeys`) object
107		#'
108		#' @keywords internal
109		update_join_keys_to_primary <- function(data_objects, join_keys) {
110	55x	lapply(data_objects, function(obj) {
111	97x	if (inherits(obj, "TealDataConnector")) {
112	5x	update_join_keys_to_primary(obj$get_items(), join_keys)
113		} else {
114	92x	dataname <- obj$get_dataname()
115	92x	if (length(join_keys$get(dataname, dataname)) == 0) {
116	91x	join_keys$mutate(
117	91x	dataname,
118	91x	dataname,
119	91x	obj$get_keys()
120		)
121		}
122		}
123		})
124		}

1		## CDISCTealDataset ====
2		#'
3		#' @title R6 Class representing a dataset with parent attribute
4		#'
5		#' @description `r lifecycle::badge("stable")`
6		#' Any `data.frame` object can be stored inside this object.
7		#'
8		#' The difference compared to `TealDataset` class is a parent field that
9		#' indicates name of the parent dataset. Note that the parent field might
10		#' be empty (i.e. `character(0)`).
11		#'
12		#' @param dataname (`character`)\cr
13		#' A given name for the dataset it may not contain spaces
14		#'
15		#' @param x (`data.frame`)\cr
16		#'
17		#' @param keys (`character`)\cr
18		#' vector with primary keys
19		#'
20		#' @param parent optional, (`character`) \cr
21		#' parent dataset name
22		#'
23		#' @param code (`character`)\cr
24		#' A character string defining the code needed to produce the data set in `x`
25		#'
26		#' @param label (`character`)\cr
27		#' Label to describe the dataset
28		#'
29		#' @param vars (named `list`)) \cr
30		#' In case when this object code depends on other `TealDataset` object(s) or
31		#' other constant value, this/these object(s) should be included as named
32		#' element(s) of the list. For example if this object code needs `ADSL`
33		#' object we should specify `vars = list(ADSL = <adsl object>)`.
34		#' It is recommended to include `TealDataset` or `TealDatasetConnector` objects to
35		#' the `vars` list to preserve reproducibility. Please note that `vars`
36		#' are included to this object as local `vars` and they cannot be modified
37		#' within another dataset.
38		#'
39		#' @param metadata (named `list` or `NULL`) \cr
40		#' Field containing metadata about the dataset. Each element of the list
41		#' should be atomic and length one.
42		#'
43		#' @examples
44		#' x <- cdisc_dataset(
45		#' dataname = "XYZ",
46		#' x = data.frame(x = c(1, 2), y = c("a", "b"), stringsAsFactors = FALSE),
47		#' keys = "y",
48		#' parent = "ABC",
49		#' code = "XYZ <- data.frame(x = c(1, 2), y = c('aa', 'bb'),
50		#' stringsAsFactors = FALSE)",
51		#' metadata = list(type = "example")
52		#' )
53		#'
54		#' x$ncol
55		#' x$get_code()
56		#' x$get_dataname()
57		#' x$get_keys()
58		#' x$get_parent()
59		CDISCTealDataset <- R6::R6Class( # nolint
60		"CDISCTealDataset",
61		inherit = TealDataset,
62		## __Public Methods ====
63		public = list(
64		#' @description
65		#' Create a new object of `CDISCTealDataset` class
66		initialize = function(dataname, x, keys, parent, code = character(0),
67		label = character(0), vars = list(), metadata = NULL) {
68	81x	checkmate::assert_character(parent, max.len = 1, any.missing = FALSE)
69	80x	super$initialize(
70	80x	dataname = dataname, x = x, keys = keys, code = code,
71	80x	label = label, vars = vars, metadata = metadata
72		)
73
74	80x	self$set_parent(parent)
75	80x	logger::log_trace("CDISCTealDataset initialized for dataset: { deparse1(self$get_dataname()) }.")
76	80x	return(invisible(self))
77		},
78		#' @description
79		#' Recreate a dataset with its current attributes
80		#' This is useful way to have access to class initialize method basing on class object
81		#'
82		#' @return a new object of `CDISCTealDataset` class
83		recreate = function(dataname = self$get_dataname(),
84		x = self$get_raw_data(),
85		keys = self$get_keys(),
86		parent = self$get_parent(),
87		code = private$code,
88		label = self$get_dataset_label(),
89		vars = list(),
90		metadata = self$get_metadata()) {
91	8x	res <- self$initialize(
92	8x	dataname = dataname,
93	8x	x = x,
94	8x	keys = keys,
95	8x	parent = parent,
96	8x	code = code,
97	8x	label = label,
98	8x	vars = vars,
99	8x	metadata = metadata
100		)
101	8x	logger::log_trace("CDISCTealDataset$recreate recreated dataset: { deparse1(self$get_dataname()) }.")
102	8x	return(res)
103		},
104		#' @description
105		#' Get all dataset attributes
106		#' @return (named `list`) with dataset attributes
107		get_attrs = function() {
108	!	x <- super$get_attrs()
109	!	x <- append(
110	!	x,
111	!	list(
112	!	parent = self$get_parent()
113		)
114		)
115	!	return(x)
116		},
117		#' @description
118		#' Get parent dataset name
119		#' @return (`character`) indicating parent `dataname`
120		get_parent = function() {
121	38x	return(private$parent)
122		},
123		#' @description
124		#' Set parent dataset name
125		#' @param parent (`character`) indicating parent `dataname`
126		#' @return (`self`) invisibly for chaining
127		set_parent = function(parent) {
128	81x	checkmate::assert_character(parent, max.len = 1, any.missing = FALSE)
129	81x	private$parent <- parent
130
131	81x	logger::log_trace("CDISCTealDataset$set_parent parent set for dataset: { deparse1(self$get_dataname()) }.")
132	81x	return(invisible(self))
133		}
134		),
135		## __Private Fields ====
136		private = list(
137		parent = character(0)
138		)
139		)
140
141		# constructors ====
142		#' Create a new object of `CDISCTealDataset` class
143		#'
144		#' @description `r lifecycle::badge("stable")`
145		#' Function that creates `CDISCTealDataset` object
146		#'
147		#' @inheritParams dataset
148		#' @param parent (`character`, optional) parent dataset name
149		#'
150		#' @return (`CDISCTealDataset`) a dataset with connected metadata
151		#'
152		#' @export
153		#'
154		#' @examples
155		#' ADSL <- example_cdisc_data("ADSL")
156		#'
157		#' cdisc_dataset("ADSL", ADSL, metadata = list(type = "teal.data"))
158		cdisc_dataset <- function(dataname,
159		x,
160		keys = get_cdisc_keys(dataname),
161		parent = `if`(identical(dataname, "ADSL"), character(0), "ADSL"),
162		label = data_label(x),
163		code = character(0),
164		vars = list(),
165		metadata = NULL) {
166	66x	CDISCTealDataset$new(
167	66x	dataname = dataname,
168	66x	x = x,
169	66x	keys = keys,
170	66x	parent = parent,
171	66x	label = label,
172	66x	code = code,
173	66x	vars = vars,
174	66x	metadata = metadata
175		)
176		}
177
178		#' Load `CDISCTealDataset` object from a file
179		#'
180		#' @description `r lifecycle::badge("experimental")`
181		#' Please note that the script has to end with a call creating desired object. The error will be raised otherwise.
182		#'
183		#' @inheritParams dataset_file
184		#'
185		#' @return (`CDISCTealDataset`) object
186		#'
187		#' @export
188		#'
189		#' @examples
190		#' # simple example
191		#' file_example <- tempfile(fileext = ".R")
192		#' writeLines(
193		#' text = c(
194		#' "library(teal.data)
195		#' cdisc_dataset(dataname = \"ADSL\",
196		#' x = teal.data::example_cdisc_data(\"ADSL\"),
197		#' code = \"ADSL <- teal.data::example_cdisc_data('ADSL')\")"
198		#' ),
199		#' con = file_example
200		#' )
201		#' x <- cdisc_dataset_file(file_example, code = character(0))
202		#' get_code(x)
203		cdisc_dataset_file <- function(path, code = get_code(path)) {
204	!	object <- object_file(path, "CDISCTealDataset")
205	!	object$set_code(code)
206	!	return(object)
207		}

1		## CDISCTealDatasetConnector ====
2		#'
3		#' @title A `CDISCTealDatasetConnector` class of objects
4		#'
5		#' @description `r lifecycle::badge("stable")`
6		#' Objects of this class store the connection function to fetch a single dataset.
7		#'
8		#' The difference compared to `TealDatasetConnector` is a parent field that
9		#' indicates name of the parent dataset. Note that the parent field might
10		#' be empty (i.e. `character(0)`).
11		#'
12		#' @param dataname (`character`)\cr
13		#' A given name for the dataset it may not contain spaces
14		#'
15		#' @param pull_callable (`CallableFunction`)\cr
16		#' function with necessary arguments set to fetch data from connection.
17		#'
18		#' @param keys (`character`)\cr
19		#' vector of dataset primary keys column names
20		#'
21		#' @param parent optional, (`character`) \cr
22		#' parent dataset name
23		#'
24		#' @param label (`character`)\cr
25		#' Label to describe the dataset.
26		#'
27		#' @param code (`character`)\cr
28		#' A character string defining code to modify `raw_data` from this dataset. To modify
29		#' current dataset code should contain at least one assignment to object defined in `dataname`
30		#' argument. For example if `dataname = ADSL` example code should contain
31		#' `ADSL <- <some R code>`. Can't be used simultaneously with `script`
32		#'
33		#' @param script (`character`)\cr
34		#' Alternatively to `code` - location of the file containing modification code.
35		#' Can't be used simultaneously with `script`.
36		#'
37		#' @param vars (named `list`)) \cr
38		#' In case when this object code depends on other `TealDataset` object(s) or
39		#' other constant value, this/these object(s) should be included as named
40		#' element(s) of the list. For example if this object code needs `ADSL`
41		#' object we should specify `vars = list(ADSL = <adsl object>)`.
42		#' It's recommended to include `TealDataset` or `TealDatasetConnector` objects to
43		#' the `vars` list to preserve reproducibility. Please note that `vars`
44		#' are included to this object as local `vars` and they cannot be modified
45		#' within another dataset.
46		#'
47		#' @param metadata (named `list`, `NULL` or `CallableFunction`) \cr
48		#' Field containing either the metadata about the dataset (each element of the list
49		#' should be atomic and length one) or a `CallableFuntion` to pull the metadata
50		#' from a connection. This should return a `list` or an object which can be
51		#' converted to a list with `as.list`.
52		CDISCTealDatasetConnector <- R6::R6Class( # nolint
53		classname = "CDISCTealDatasetConnector",
54		inherit = TealDatasetConnector,
55
56		## __Public Methods ====
57		public = list(
58		#' @description
59		#' Create a new `TealDatasetConnector` object. Set the pulling function
60		#' `CallableFunction` which returns a `data.frame`, e.g. by reading
61		#' from a function or creating it on the fly.
62		initialize = function(dataname,
63		pull_callable,
64		keys, parent,
65		code = character(0),
66		label = character(0),
67		vars = list(),
68		metadata = NULL) {
69	37x	super$initialize(
70	37x	dataname = dataname,
71	37x	pull_callable = pull_callable,
72	37x	keys = keys,
73	37x	code = code,
74	37x	label = label,
75	37x	vars = vars,
76	37x	metadata = metadata
77		)
78	37x	private$set_parent(parent)
79	37x	logger::log_trace("CDISCTealDatasetConnector initialized for dataset: { deparse1(self$get_dataname()) }")
80
81	37x	return(invisible(self))
82		},
83		#' @description
84		#' Get parent dataset name
85		#' @return (`character`) indicating parent `dataname`
86		get_parent = function() {
87	49x	private$parent
88		},
89
90		#' @description
91		#' Pull the data
92		#'
93		#' Read or create the data using `pull_callable` specified in the constructor.
94		#'
95		#' @param args (`NULL` or named `list`)\cr
96		#' additional dynamic arguments for pull function. `args` can be omitted if `pull_callable`
97		#' from constructor already contains all necessary arguments to pull data. One can try
98		#' to execute `pull_callable` directly by `x$pull_callable$run()` or to get code using
99		#' `x$pull_callable$get_code()`. `args` specified in pull are used temporary to get data but
100		#' not saved in code.
101		#' @param try (`logical` value)\cr
102		#' whether perform function evaluation inside `try` clause
103		#'
104		#' @return `self` invisibly for chaining.
105		pull = function(args = NULL, try = FALSE) {
106	28x	logger::log_trace("CDISCTealDatasetConnector$pull pulling dataset: { deparse1(self$get_dataname()) }.")
107	28x	super$pull(args = args, try = try)
108
109	27x	if (!self$is_failed()) {
110	27x	private$dataset <- as_cdisc(
111	27x	private$dataset,
112	27x	parent = self$get_parent()
113		)
114	27x	logger::log_trace("CDISCTealDatasetConnector$pull pulled dataset: { deparse1(self$get_dataname()) }.")
115		} else {
116	!	logger::log_error("CDISCTealDatasetConnector$pull failed to pull dataset: { deparse1(self$get_dataname()) }.")
117		}
118	27x	return(invisible(self))
119		}
120		),
121
122		## __Private Fields ====
123		private = list(
124		parent = character(0),
125
126		## __Private Methods ====
127		set_parent = function(parent) {
128	37x	checkmate::assert_character(parent, max.len = 1, any.missing = FALSE)
129	37x	private$parent <- parent
130	37x	return(invisible(self))
131		}
132		)
133		)