R/utils.R

In asshah4/forks: Formula Spells

# Conversion -------------------------------------------------------------------

#' Convert between lists, list-formulas, and tables
#'
#' @param x
#'
#' * For `list_to_table()`: A named `list` object
#'
#' * For `table_to_list()`: A `data.frame` object
#'
#' @param id Name of column that contains the term (or rune)
#'
#' @param val Name of column that contains specific values
#'
#' @param ... Further arguments passed to or from other methods
#'
#' @details
#'
#' `table_to_list()`:
#'
#' Takes a `data.frame` and uses the columns to generate a named list. This
#' removes the original column names, as it assumes that the data is contained
#' within the frame itself. It defaults to using the first column as the names
#' of the list.
#'
#' `formula_to_named_list()`:
#'
#' Handling of list-formula arguments. Stylistic choice to make arguments
#' entered in the form of a list, with each entry being a formula. The LHS will
#' always be the terms, and the RHS will always be the non-terms item (e.g.
#' group, label, role, etc).
#'
#' `named_list_to_formula()`:
#'
#' Converts a named list set to a formula pattern. The LHS is the term, and the
#' RHS is the value, such as a label, role, or tier.
#'
#' @name list-helpers
#' @export
list_to_table <- function(x, id, val, ...) {
  tbl <- as.data.frame(cbind(names(x), unlist(unname(x))))
  colnames(tbl) <- c(id, val)
  tbl
}

#' @rdname list-helpers
#' @export
table_to_list <- function(x, id, ...) {
  validate_class(x, "data.frame")

  if (ncol(x) == 2) {
    tbl <- x
    nms <- tbl[[id]]
    val <- tbl[[which(!colnames(tbl) %in% id)]]
    names(val) <- nms
    return(as.list(val))
  } else if (ncol(x) == 1) {
    tbl <- x
    return(as.list(tbl))
  } else {
    stop("table_to_list() requires there to be a data.frame of either 1 or 2 columns.",
      call. = FALSE
    )
  }
}

#' @rdname list-helpers
#' @export
formula_to_named_list <- function(x, ...) {
  validate_class(x, "list")


  pl <- list()

  for (i in seq_along(x)) {

    f <- x[[i]]
    validate_class(f, "formula")

    # Left hand side (terms usually)
    if (inherits(f[[2]], "character") | inherits(f[[2]], "name") | inherits(f[[2]], "numeric")) {
      t <- as.character(f[[2]])
    } else if (inherits(f[[2]], "call")) {
      t <- as.character(f[[2]])
      # First position will likely be primitive function
      if (t[1] %in% c("+", "~", "-", "c")) {
        t <- t[-1]
      }
    }

    # Information or values (right)
    if (inherits(f[[3]], "character") | inherits(f[[3]], "name")) {
      d <- as.character(f[[3]])
      n <- length(d)
    } else if (inherits(f[[3]], "numeric")) {
      d <- f[[3]]
      n <- length(d)
    } else if (inherits(f[[3]], "call")) {
      # Get call primitive
      fn <- as.character(f[[3]])[1]
      d <- as.character(f[[3]])[-1]
      n <- length(d)
      if (fn == "c") {
        #d <- f[[3]]
        d <- eval(f[[3]])

      }
    }

    # Assuming that the RHS is shorter than LHS
    if (n < length(t)) {
      y <- rep(d, length(t))
      names(y) <- t
      pl <- append(pl, y)
    } else if (n >= length(t)) {
      y <- list()
      y[[t]] <- d
      pl <- append(pl, y)
    }
  }

  # Return paired/named list
  pl
}

#' @rdname list-helpers
#' @export
named_list_to_formula <- function(x, ...) {
  validate_class(x, "list")

  fl <- list()
  for (i in seq_along(x)) {
    f <-
      paste0(names(x)[i], " ~ ", '"', unname(x)[i], '"') |>
      stats::formula()
    fl <- append(fl, f)
  }

  # Returned list of formula arguments
  fl
}

# Formula Tools ----------------------------------------------------------------

#' Tools for working with formula-like objects
#' @name sides
#' @export
lhs <- function(x, ...) {
  UseMethod("lhs", object = x)
}

#' @rdname sides
#' @export
rhs <- function(x, ...) {
  UseMethod("rhs", object = x)
}

#' @rdname sides
#' @export
rhs.rune <- function(x, ...) {
  tms <- vec_data(x)
  tms$runes[tms$side == "right"]
}

#' @rdname sides
#' @export
lhs.rune <- function(x, ...) {
  tms <- vec_data(x)
  tms$runes[tms$side == "left"]
}

#' @rdname sides
#' @export
rhs.fmls <- function(x, ...) {
  field(x, "right")[[1]]
}

#' @rdname sides
#' @export
lhs.fmls <- function(x, ...) {
  field(x, "left")[[1]]
}

#' @rdname sides
#' @param tidy Logical value to decide if operations should be removed from the
#'   terms. If `FALSE`, then the operations will remain included.
#' @export
rhs.formula <- function(x, tidy = FALSE, ...) {
  if (length(x) == 2) {
    pos <- 2
  }
  if (length(x) == 3) {
    pos <- 3
  }


  if (tidy) {
    # Get strings and trim them
    y <-
      x[[pos]] |>
      deparse1() |>
      strsplit("\\+|-") |>
      unlist() |>
      trimws()

    # Special terms that should allow for cutting operations
    ops <-
      c(template_shortcuts, template_operations) |>
      paste0("\\(") |>
      paste0(collapse = "|")

    # Return tidier variables
    ifelse(grepl(ops, y), sub("\\)", "", sub(ops, "", y)), y)

  } else {
    labels(stats::terms(x))
  }
}

#' @rdname sides
#' @export
lhs.formula <- function(x, tidy = FALSE, ...) {
  if (length(x) == 2) {
    return(character())
  }

  # Shift over to simplify evaluation
  y <-
    x[[2]] |>
    deparse1() |>
    {
      \(.x) paste("~", .x)
    }() |>
    stats::as.formula()

  if (tidy) {
    left <- all.vars(y, functions = FALSE, unique = FALSE)
  } else {
    left <- labels(stats::terms(y))
  }

  # Return
  left
}

#' @rdname sides
#' @export
rhs.spell <- function(x, ...) {
  x |>
    distill_rune() |>
    rhs()
}

#' @rdname sides
#' @export
lhs.spell <- function(x, ...) {
  x |>
    distill_rune() |>
    lhs()
}

# Getters ----

#' Retrieval functions for archetypical classes
#' @name getters
#' @export
roles <- function(x, ...) {
  UseMethod("roles", object = x)
}

#' @rdname getters
#' @export
roles.rune <- function(x, ...) {
  vec_data(x) |>
    {
      \(.x) .x[, c("runes", "role")]
    }() |>
    table_to_list(id = "runes")
}

#' @rdname getters
#' @export
roles.spell <- function(x, ...) {
  attr(x, "rune") |>
    vec_data() |>
    {
      \(.x) .x[, c("runes", "role")]
    }() |>
    table_to_list(id = "runes")
}

#' @rdname getters
#' @export
get_runes <- function(x, field = NA, value = NA) {
  if (class(x)[1] == "rune") {
    if (!is.na(field) & !is.na(field)) {
      t <- x[field(x, field) == value]
    } else {
      t <- x
    }
  }

  if (class(x)[1] == "fmls") {
    # Convert to basic terms
    tl <- distill_rune()

    for (i in seq_along(x)) {
      t <- c(
        field(x[i], "outcome")[[1]],
        field(x[i], "predictor")[[1]],
        field(x[i], "exposure")[[1]],
        field(x[i], "confounder")[[1]],
        field(x[i], "mediator")[[1]],
        field(x[i], "interaction")[[1]],
        field(x[i], "unknown")[[1]],
        field(x[i], "strata")[[1]]
      )

      tl <- append(tl, t)
    }

    t <- unique(tl)
  }


  t
}


#' @rdname getters
#' @export
labels.rune <- function(object, ...) {
  vec_data(object) |>
    {
      \(.x) .x[, c("runes", "label")]
    }() |>
    table_to_list(id = "runes") |>
    {
      \(.x) .x[!is.na(.x)]
    }()
}

#' @rdname getters
#' @export
labels.rune_list <- function(object, ...) {

  labs <-
    vec_data(object) |>
    sapply(labels)

  if (anyDuplicated(names(labs))) {
    message("Please check if the labels in the <rnls> object have duplicate terms.")
  }

  # Return
  labs
}

#' @rdname getters
#' @export
labels.spell <- function(object, ...) {
  object |>
    distill_rune() |>
    labels.rune()
}

#' @rdname getters
#' @export
labels.list_of_formulas <- function(object, ...) {
  attr(object, "runes") |>
    labels.rune()
}


#' @rdname getters
#' @export
tiers <- function(x, ...) {
  UseMethod("tiers", object = x)
}

#' @rdname getters
#' @export
tiers.rune <- function(x, ...) {
  vec_data(x) |>
    {
      \(.x) .x[, c("runes", "tier")]
    }() |>
    table_to_list(id = "runes") |>
    {
      \(.x) .x[!is.na(.x)]
    }()
}

#' @rdname getters
#' @export
tiers.spell <- function(x, ...) {
  attr(x, "runes") |>
    vec_data() |>
    {
      \(.x) .x[, c("runes", "tier")]
    }() |>
    table_to_list(id = "runes") |>
    {
      \(.x) .x[!is.na(.x)]
    }()
}

#' @rdname getters
#' @export
tiers.list_of_formulas <- function(x, ...) {
  attr(x, "runes") |>
    tiers.rune()
}


# Term Tools -------------------------------------------------------------------

#' Set components of distill_rune
#' @return A modified
#' @name setters
#' @export
set_roles <- function(x, roles, ...) {
  validate_class(roles, "list")

  # Update and append roles
  rls <- append(roles(x), roles)

  # If roles are not appropriate, should stop or error now
  if (!all(rls %in% template_roles)) {
    stop(
      "An invalid role was entered. It should be one of: `c(",
      paste(template_roles, collapse = ", "),
      ")`"
    )
  }

  # Save the most "recent" updated label and erase prior if duplicate
  t <- vec_data(x)
  for (i in seq_along(rls)) {
    t$role[t$runes == names(rls[i])] <- rls[[i]]
  }

  vec_restore(t, to = distill_rune())
}

#' @rdname setters
#' @export
set_tiers <- function(x, tiers, ...) {
  validate_class(x, "rune")
  validate_class(tiers, "list")

  # Append tiers
  grps <-
    tiers.rune(x) |>
    append(tiers)

  t <- vec_data(x)

  for (i in seq_along(grps)) {
    t$tier[t$runes == names(grps[i])] <- grps[[i]]
  }

  vec_restore(t, to = distill_rune())
}

#' @rdname setters
#' @export
set_labels <- function(x, labels, ...) {
  validate_class(x, "rune")
  validate_class(labels, "list")

  # Update and append labels
  labs <-
    labels.rune(x) |>
    append(labels)

  # Save the most "recent" updated label and erase prior if duplicate
  t <- vec_data(x)
  for (i in seq_along(labs)) {
    t$label[t$runes == names(labs[i])] <- labs[[i]]
  }

  vec_restore(t, to = distill_rune())
}

#' @rdname setters
#' @export
add_strata <- function(x, strata, ...) {
  validate_class(x, "rune")
  validate_class(strata, "character")

  strata_term <- distill_rune(
    x = strata,
    side = "meta",
    role = "strata",
    ...
  )

  # Return in combination
  c(x, strata_term)
}

#' Match the terms with the a formula, returning a subset of terms
#' @noRd
match_runes <- function(t, f) {
  validate_class(t, "rune")

  if ("formula" %in% class(f)) {
    vars <- c(lhs(f), rhs(f))
  } else if ("character" %in% class(f)) {
    vars <- f
  }

  # Terms
  vt <- vec_data(t)

  # New term creation and matching
  mt <-
    vt[vt$runes %in% vars, ] |>
    vec_restore(to = distill_rune())

  # Return
  mt
}

# Updating Functions -----------------------------------------------------------

#' Updating Spells
#'
#' These are a variety of functions to help update and modify objects from the
#' `{arcane}` package.
#' @return An object of the original class
#' @name updates
#' @export
update.rune <- function(object, parameters, ...) {
  object
}

#' @rdname updates
#' @export
update.spell <- function(object, parameters, ...) {
  t <- distill_rune(object)

  if (class(parameters) == "formula") {

    ### LHS
    all_left <- lhs(parameters, tidy = TRUE)
    plus_left <- lhs(parameters, tidy = FALSE)

    # Add
    if (length(plus_left) > 0) {
      for (i in seq_along(plus_left)) {
        .t <- distill_rune(x = plus_left[i], role = "outcome", side = "left")
        t <- c(t, .t)
      }
    }

    # Subtract
    minus_left <- setdiff(all_left, plus_left)

    tm <- vec_data(t)
    left <-
      tm[tm$side == "left" & !(tm$runes %in% minus_left), ] |>
      vec_restore(distill_rune())

    ### RHS
    all_right <- rhs(parameters, tidy = TRUE)
    plus_right <- rhs(parameters, tidy = FALSE)

    # Add
    if (length(plus_right) > 0) {
      .t <-
        paste(plus_right, collapse = " + ") |>
        {
          \(.x) paste("~", .x)
        }() |>
        stats::as.formula() |>
        distill_rune()

      t <- c(t, .t)
    }

    # Subtract
    minus_right <- setdiff(all_right, plus_right)

    tm <- vec_data(t)
    right <-
      tm[tm$side == "right" & !(tm$runes %in% minus_right), ] |>
      vec_restore(distill_rune())

    # Combine both sides
    t <- c(left, right)
  }

  # Return
  cast_spell(t)
}

#' @rdname updates
#' @export
add <- function(object, ...) {
  UseMethod("add", object = object)
}

#' @rdname updates
#' @export
add.spell <- function(object, parameters, ...) {
  obj <- distill_rune(object)

  switch(class(parameters)[1],
    rune = {
      f <-
        obj |>
        {
          \(.x) c(.x, parameters)
        }() |>
        cast_spell()
    },
    formula = {
      f <-
        distill_rune(parameters) |>
        {
          \(.x) c(obj, .x)
        }() |>
        cast_spell()
    }
  )

  # Return
  f
}

#' @rdname updates
#' @export
add.rune <- function(object, parameters, ...) {
  validate_class(parameters, "rune")

  # Find the "older" distill_rune that is a duplicate
  c(object, parameters) |>
    vec_data() |>
    {
      \(.x) {
        .x[!duplicated(.x$runes, fromLast = TRUE), ]
      }
    }() |>
    vec_restore(to = distill_rune())
}