Merge pull request #20 from jdblischak/simplify

Use a tibble/df as the primary object

Author: dom-muston

.Rbuildignore

@@ -1,4 +1,4 @@
-^dynacem\.Rproj$
+^dynamicpv\.Rproj$
 ^\.Rproj\.user$
 ^README\.Rmd$
 ^data-raw$
@@ -7,3 +7,8 @@
 ^doc$
 ^Meta$
 ^docs$
+^LICENSES-THIRD-PARTY\.md$
+^codecov\.yml$
+^pkg\.lock$
+^pkgdown$
+^sticker\.png$

NAMESPACE

@@ -2,12 +2,30 @@
 
 S3method("+",dynpv)
 S3method("-",dynpv)
-S3method(print,dynpv)
+S3method(mean,dynpv)
+S3method(print,dynpv_summary)
+S3method(summary,dynpv)
 export(addprod)
-export(class_dynpv)
 export(dynpv)
 export(futurepv)
 export(get_dynfields)
 export(get_param_value)
+export(ncoh)
+export(ntimes)
+export(sum_by_coh)
+export(total)
 export(trim_vec)
-importFrom(rlang,.data)
+export(uptake)
+importFrom(dplyr,across)
+importFrom(dplyr,all_of)
+importFrom(dplyr,as_tibble)
+importFrom(dplyr,bind_rows)
+importFrom(dplyr,filter)
+importFrom(dplyr,join_by)
+importFrom(dplyr,left_join)
+importFrom(dplyr,mutate)
+importFrom(dplyr,rename)
+importFrom(dplyr,select)
+importFrom(dplyr,summarize)
+importFrom(tidyr,expand_grid)
+importFrom(tidyr,pivot_wider)

R/dynamic.R

@@ -15,26 +15,6 @@
 #
 #  You should have received a copy of the GNU General Public License
 #  along with this program.  If not, see <http://www.gnu.org/licenses/>.
-#
-#  =====================================================================
-
-## Collection of functions to calculate cost-effectiveness model results
-## with dynamic pricing and uptake
-## =====================================================================
-
-#' Trim the tailing zeroes from a long vector
-#'
-#' @param vec Vector. Final elements may be zero.
-#' @returns A vector whose length is shorter than the original, if there were trailing zero elements
-#' @export
-#' @examples
-#' trim_vec(c(1:10, rep(0,3)))
-trim_vec <- function(vec){
-  # Identify the last element before vector elements are zero
-  trimto <- which(rev(cumsum(rev(vec)))==vec)[1]
-  # Return trimmed vector
-  return(vec[1:trimto])
-}
 
 #' Calculate present value for a payoff with dynamic pricing and dynamic uptake
 #'
@@ -45,21 +25,20 @@ trim_vec <- function(vec){
 #' @param payoffs Vector of payoffs of interest (numeric vector)
 #' @param prices Vector of price indices through the time horizon of interest
 #' @param discrate Discount rate per timestep, corresponding to price index
-#' @param dpv_name Name to be given to Dynamic Present Value object created by this function call
-#' @returns A list containing `inputs` and `results`.
-#' The `inputs` list contains a list of the following parameters called with the function: `uptakes, payoffs, horizon, tzero, prices`, and `discrate`.
-#' The `results` output is a "dynpv" object (created by [class_dynpv()]) that contains the following elements:
-#' - `name`: Name given to the object
-#' - `df`: Tibble of calculation results
-#' - `ncoh`: Number of cohorts of uptaking patients
-#' - `ntimes`: Number of times (unique values of tzero) at which calculations are performed
-#' - `uptake`: Total number of uptaking patients
-#' - `total`: Total present value
-#' - `mean`: Average present value per uptaking patient (=total/uptake)
-#' - `sum_by_coh`: Tibble of summarized calculation results for each uptake cohort
+#' @returns A tibble of class "dynpv" with the following columns:
+#' - `j`: todo
+#' - `k`: todo
+#' - `l`: todo
+#' - `t`: todo
+#' - `uj`: todo
+#' - `pk`: todo
+#' - `R`: todo
+#' - `v`: todo
+#' - `pv`: todo
 #' @export
-#' @importFrom rlang .data
 #' @examples
+#' library(dplyr)
+#'
 #' # Obtain dataset
 #' democe <- get_dynfields(
 #'    heemodel = oncpsm,
@@ -69,57 +48,58 @@ trim_vec <- function(vec){
 #'
 #' # Obtain short payoff vector of interest
 #' payoffs <- democe |>
-#'    dplyr::filter(int=="new", model_time<11) |>
-#'    dplyr::mutate(cost_oth = cost_total - cost_daq_new)
+#'    filter(int=="new", model_time<11) |>
+#'    mutate(cost_oth = cost_total - cost_daq_new)
 #' Nt <- nrow(payoffs)
 #'
 #' # Example calculation
-#' dynpv(
+#' pv <- dynpv(
 #'    uptakes = rep(1, Nt),
 #'    payoffs = payoffs$cost_oth,
 #'    prices = 1 + (0:(Nt-1))*0.05,
 #'    discrate = 0.08
 #' )
+#' pv
+#' summary(pv)
 dynpv <- function(
     uptakes = 1,
     payoffs,
     horizon = length(payoffs),
     tzero = 0,
     prices = rep(1, length(payoffs)+tzero),
-    discrate = 0,
-    dpv_name = NA_character_
+    discrate = 0
     ){
   # Avoid no visible binding note
-  j <- k <- l <- uj <- pk <- R <- v <- pv <- spv <- total <- suptakes <- NULL
+  j <- k <- l <- uj <- pk <- R <- v <- NULL
   # Trim
   uptakes <- trim_vec(uptakes)
   payoffs <- trim_vec(payoffs)
   # Create a dataset for each combination of time
-  df <- tidyr::expand_grid(j=1:length(uptakes), k=1:length(payoffs), l=tzero) |>
-    dplyr::mutate(t= j + k - 1) |>
+  df <- expand_grid(j=1:length(uptakes), k=1:length(payoffs), l=tzero) |>
+    mutate(t= j + k - 1) |>
     # Remove time entries that are outside the time horizon
-    dplyr::filter(t <= horizon) |>
-    dplyr::mutate(
+    filter(t <= horizon) |>
+    mutate(
       uj = uptakes[j],
       pk = payoffs[k],
       R = prices[l + t],
       v = (1+discrate)^(1 - t),
       pv = uj * pk * R * v
     )
-
-  # Put dataset into a dynpv_class object
-  cds <- class_dynpv(name = dpv_name, df = df)
-
-  return(list(
-    inputs = list(
-      uptakes = uptakes,
-      payoffs = payoffs,
-      horizon = horizon,
-      tzero = tzero,
-      prices = prices,
-      discrate = discrate
-    ),
-    results = cds
-  ))
+  class(df) <- c("dynpv", class(df))
+  return(df)
 }
 
+#' Trim the tailing zeroes from a long vector
+#'
+#' @param vec Vector. Final elements may be zero.
+#' @returns A vector whose length is shorter than the original, if there were trailing zero elements
+#' @export
+#' @examples
+#' trim_vec(c(1:10, rep(0,3)))
+trim_vec <- function(vec){
+  # Identify the last element before vector elements are zero
+  trimto <- which(rev(cumsum(rev(vec)))==vec)[1]
+  # Return trimmed vector
+  return(vec[1:trimto])
+}

R/dynamicpv-package.R

@@ -1,6 +1,8 @@
+#' @importFrom dplyr across all_of as_tibble bind_rows filter join_by left_join mutate rename select summarize
+#' @importFrom tidyr expand_grid pivot_wider
 #' @keywords internal
 "_PACKAGE"
 
 ## usethis namespace: start
 ## usethis namespace: end
-NULL
+NULL

R/extract.R

@@ -15,8 +15,6 @@
 #
 #  You should have received a copy of the GNU General Public License
 #  along with this program.  If not, see <http://www.gnu.org/licenses/>.
-#
-#  =====================================================================
 
 ## Collection of functions to extract payoffs from other systems, e.g. heemod
 ## ==========================================================================
@@ -27,11 +25,10 @@
 #' @param discount Name of parameter providing discount rate per cycle (string)
 #' @param fname Export data to a .CSV file of this name, if given (character)
 #' @returns Tibble of payoffs taken from the heemod model, by intervention and model timestep (`model_time`).
-#' 
+#'
 #' The field `vt` is calculated as `(1+i)^(1-model_time)`, where `i` is the discount rate per model timestep set in the *heemod* model through the parameter `disc_cycle`. This can be useful in 'rolling-up' payoff values to the timestep in which they were incurred.
-#' 
+#'
 #' An additional set of payoffs (identified with a "_rup" suffix) provides calculations of the payoffs as at the start of the timestep in which they were incurred, i.e. original payoff / `vt`.
-#' @importFrom rlang .data
 #' @seealso [heemod::heemod-package]
 #' @export
 #' @examples
@@ -53,21 +50,21 @@ get_dynfields <- function(heemodel, payoffs, discount, fname=NA){
   # Pull in tibble into list for each intervention
   for (i in seq(int)){
     ds[[i]] <- heemodel$eval_strategy_list[[int[i]]]$values |>
-      dplyr::as_tibble() |>
-      dplyr::select(c("model_time", dplyr::all_of(payoffs))) |>
-      dplyr::mutate(int = int[i])
+      as_tibble() |>
+      select(c("model_time", all_of(payoffs))) |>
+      mutate(int = int[i])
   }
   # Unnest
-  ds <- dplyr::bind_rows(ds) |>
+  ds <- bind_rows(ds) |>
     # Add discounting variable
-    dplyr::mutate(vt = (1 + discrate)^(1 - model_time))
+    mutate(vt = (1 + discrate)^(1 - model_time))
   # Create rolled-up variables, with "r" prefix to their name
   rs <- ds |>
-    dplyr::mutate(dplyr::across(dplyr::all_of(payoffs), ~.x/vt))
+    mutate(across(all_of(payoffs), ~.x/vt))
   # Join the rolled-up data to the original data
   ds <- ds |>
-    dplyr::left_join(rs, by=c("model_time", "int"), suffix=c("", "_rup")) |>
-    dplyr::select(-vt_rup)
+    left_join(rs, by=c("model_time", "int"), suffix=c("", "_rup")) |>
+    select(-vt_rup)
   # Export as CSV
   if (!is.na(fname)) {readr::write_csv(ds, file=paste0(fname, ".csv"))}
   # Return
@@ -87,4 +84,4 @@ get_dynfields <- function(heemodel, payoffs, discount, fname=NA){
 #'    )
 get_param_value <- function(heemodel, param){
   rlang::eval_tidy(heemodel$parameters[[param]])
-}
+}

R/future.R

@@ -15,71 +15,52 @@
 #
 #  You should have received a copy of the GNU General Public License
 #  along with this program.  If not, see <http://www.gnu.org/licenses/>.
-#
-#  =====================================================================
 
 ## Convenience function to calculate 'future' cost-effectiveness results
 ## ========================================================================
 
 #' Calculate present value for a payoff in a single cohort with dynamic pricing across multiple timepoints
-#' 
+#'
 #' Present value of a series of payoffs for a single given cohort, entering at given future time, allowing for dynamic pricing. This function is a wrapper for [dynpv()] restricted to evaluation of a single cohort.
-#' @inheritParams dynpv
 #' @seealso [dynpv()]
-#' @returns A list `inputs`, `results` and `pv`.
-#' The `inputs` list contains a list of the following parameters called with the function: `uptakes, payoffs, horizon, tzero, prices`, and `discrate`. 
-#' The `results` output is a "dynpv" object (created by [class_dynpv()]) that contains the following elements:
-#' - `name`: Name given to the object
-#' - `df`: Tibble of calculation results
-#' - `ncoh`: Number of cohorts of uptaking patients (always 1)
-#' - `ntimes`: Number of times (unique values of tzero) at which calculations are performed 
-#' - `uptake`: Total number of uptaking patients (always 1)
-#' - `total`: Total present value
-#' - `mean`: Average present value per uptaking patient (=total/uptake)
-#' - `sum_by_coh`: Tibble of summarized calculation results for each uptake cohort
-#' - `inputs`: list contains a list of the following parameters called with the function: `uptakes, payoffs, horizon, tzero, prices`, and `discrate`. 
-#' The `pv` output is numeric, a convenience value equal to `$results$mean`.
+#' @inherit dynpv params return
 #' @export
 #' @examples
+#' library(dplyr)
+#'
 #' # Obtain dataset
 #' democe <- get_dynfields(
 #'    heemodel = oncpsm,
 #'    payoffs = c("cost_daq_new", "cost_total", "qaly"),
 #'    discount = "disc"
 #'    )
-#' 
+#'
 #' # Obtain discount rate
 #' discrate <- get_param_value(oncpsm, "disc")
-#' 
+#'
 #' # Obtain payoff vector of interest
 #' payoffs <- democe |>
-#'    dplyr::filter(int=="new") |>
-#'    dplyr::mutate(cost_oth_rup = cost_total_rup - cost_daq_new_rup)
+#'    filter(int=="new") |>
+#'    mutate(cost_oth_rup = cost_total_rup - cost_daq_new_rup)
 #' Nt <- nrow(payoffs)
-#' 
+#'
 #' # Run calculation for times 0-9
 #' fpv <- futurepv(
 #'   tzero = (0:9)*52,
 #'   payoffs = payoffs$cost_oth_rup,
 #'   prices = 1.001^(1:(2*Nt)-1), # Approx 5.3% every 52 steps
 #'   discrate = 0.001 + discrate
 #' )
-#' fpv$results
-#' fpv$pv
+#' fpv
+#' summary(fpv)
 futurepv <- function(tzero=0, payoffs, prices, discrate){
   # Wrapper for dynpv with uptakes=1 and horizon=length(payoffs)
-  dpv <- dynpv(
+  dynpv(
     uptakes = 1,
     payoffs = payoffs,
     horizon = length(payoffs),
     tzero = tzero,
     prices = prices,
     discrate = discrate
   )
-  # Only return useful outputs
-  list(
-    inputs = dpv$inputs,
-    results = dpv$results,
-    pv = dpv$results$mean
-  )
 }