billdenney / pknca

An R package is designed to perform all noncompartmental analysis (NCA) calculations for pharmacokinetic (PK) data.
http://billdenney.github.io/pknca/
GNU Affero General Public License v3.0
66 stars 23 forks source link

Add `nest()` verbs #272

Open billdenney opened 6 months ago

billdenney commented 6 months ago

Here is some code that works for at least one example:

nest.PKNCAconc <- function(object, ..., .by = NULL, .key = "PKNCAconc", .names_sep = NULL) {
  ret_prep <- object
  ret_prep$formula <-
    formulops::modify_formula(
      ret_prep$formula,
      lapply(X = .by, FUN = as.name),
      replace = rep(list(NULL), length(.by))
    )
  # Not requiring .by to be part of the groups because the PKNCAdose object may
  # not have it as part of the groups
  # checkmate::assert_subset(.by, choices = unlist(ret_prep$columns$groups))
  ret_prep$columns$groups$group_vars <- setdiff(ret_prep$columns$groups$group_vars, .by)
  ret_prep$columns$groups$group_analyte <- setdiff(ret_prep$columns$groups$group_analyte, .by)

  # tidyr::any_of is used instead of tidyr::all_of so that it can work for
  # PKNCAdose even when the group does not apply to the dose.
  data_nested <- tidyr::nest(as.data.frame(object), .by = tidyr::any_of(.by), .key = "data")
  data_nested[[.key]] <- rep(list(ret_prep), nrow(data_nested))
  for (idx in seq_len(nrow(data_nested))) {
    data_nested[[.key]][[idx]]$data <- data_nested$data[[idx]]
  }
  data_nested$data <- NULL
  data_nested
}

nest.PKNCAdose <- function(object, ..., .by = NULL, .key = "PKNCAdose", .names_sep = NULL) {
  nest.PKNCAconc(object = object, .by = .by, .key = .key, .names_sep = .names_sep)
}

nest.PKNCAdata <- function(object, ..., .by = NULL, .key = "PKNCAdata", .names_sep = NULL) {
  intervals_nested <- tidyr::nest(object$intervals, .by = tidyr::any_of(.by), .key = "intervals")
  conc_nested <- tidyr::nest(object$conc, .by = .by)
  dose_nested <- tidyr::nest(object$dose, .by = .by)
  ret_concdose <- dplyr::left_join(conc_nested, dose_nested)
  ret <- dplyr::left_join(ret_concdose, intervals_nested)
  ret[[.key]] <- rep(list(object), nrow(ret))
  for (idx in seq_len(nrow(ret))) {
    ret[[.key]][[idx]]$conc <- ret$PKNCAconc[[idx]]
    ret[[.key]][[idx]]$dose <- ret$PKNCAdose[[idx]]
    ret[[.key]][[idx]]$intervals <- ret$intervals[[idx]]
  }
  ret[, c(.by, .key), drop = FALSE]
}

nest.PKNCAresults <- function(object, ..., .by = NULL, .key = "PKNCAresults", .names_sep = NULL) {
  checkmate::assert_character(.by, any.missing = FALSE)
  result_nested <- tidyr::nest(as.data.frame(object), .by = .by, .key = "data_result", .names_sep = .names_sep)
  data_nested <- tidyr::nest(object$data, .by = .by)
  ret <- dplyr::left_join(result_nested, data_nested, by = .by)
  ret[[.key]] <- rep(list(object), nrow(ret))
  for (idx in seq_len(nrow(ret))) {
    ret[[.key]][[idx]]$result <- ret$data_result[[idx]]
    ret[[.key]][[idx]]$data <- ret$PKNCAdata[[idx]]
  }
  ret
  ret[, c(.by, .key), drop = FALSE]
}