Functionality for continuous inputs

Author: dom-muston

R/dynamic.R

@@ -98,11 +98,34 @@
 dynpv <- function(
     uptakes = 1,
     payoffs,
-    horizon = length(payoffs),
+    horizon = NA,
     tzero = 0,
-    prices = rep(1, length(payoffs)+tzero),
+    prices = NA,
     discrate = 0
     ){
+  # If payoffs are discrete
+  if (class(payoffs)=="numeric") {
+    # Horizon defaults to length of payoffs
+    if (class(horizon)=="logical") {horizon <- length(payoffs)}
+    # Price index defaults to (1, ..., 1)
+    if (class(prices)=="logical") {prices <- rep(1, length(payoffs)+tzero)}
+    # Call calculation
+    dpv <- dynpv_discrete(uptakes, payoffs, horizon, tzero, prices, discrate)
+  }
+  # If payoffs are not discrete and uptake is discrete
+  if ((class(uptakes)=="numeric") & (class(payoffs)=="function")) {
+    dpv <- dynpv_semicts(uptakes, payoffs, horizon, tzero, prices, discrate)
+  }
+  # If payoffs and uptake are not discrete
+  if ((class(uptakes)=="function") & (class(payoffs)=="function")) {
+    dpv <- dynpv_fullycts(uptakes, payoffs, horizon, tzero, prices, discrate)
+  }
+  # Return
+  return(dpv)
+}
+
+# Discrete function
+dynpv_discrete <- function(uptakes, payoffs, horizon, tzero, prices, discrate){
   # Avoid no visible binding note
   j <- k <- l <- uj <- pk <- R <- v <- NULL
   # Trim
@@ -137,3 +160,42 @@ trim_vec <- function(vec){
   # Return trimmed vector
   return(vec[1:trimto])
 }
+
+# Function if payoffs, prices and discounting are functions; but uptakes is a vector
+dynpv_semicts <- function(uptakes, payoffs, horizon, tzero, prices, discrate){
+  # Avoid no visible binding note
+  j <- uj <- pRv <- pv <- NULL
+  # Trim
+  uptakes <- trim_vec(uptakes)
+  # Integrand function  
+  integrand <- function(k, j) {
+    payoffs(k) * prices(j+k+tzero) * discrate(j+k)
+  }
+  # Create a dataset for each combination of time
+  df <- expand_grid(j=1:length(uptakes)) |>
+    dplyr::mutate(
+      uj = uptakes[j],
+      pRv = stats::integrate(integrand, lower=0, upper=horizon-j, j=j)$value,
+      pv = uj * pRv
+    )
+  class(df) <- c("dynpv", class(df))
+  return(df)
+}
+
+# Function if uptakes, payoffs, prices and discounting are functions
+dynpv_fullycts <- function(uptakes, payoffs, horizon, tzero, prices, discrate){
+  # First integrand function - pRv, to be integrated between k=0 and k=T-j
+  integrand1 <- function(k, j) {
+    payoffs(k) * prices(j+k+tzero) * discrate(j+k)
+  }
+  # Second integrand function, uj I, to be integrated between j=0 and j=T
+  integrand2 <- function(j) {
+    pRv <- stats::integrate(integrand1, lower=0, upper=horizon-j, j=j)$value
+    uptakes(j) * pRv
+  }
+  # Needs to be vectorized before integrating
+  integrand2 <- Vectorize(integrand2, "j")
+  # Calculate double integral
+  df <- stats::integrate(integrand2, lower=0, upper=horizon)
+  return(df$value)
+}

tests/testthat/test-fullycts.R

@@ -0,0 +1,15 @@
+# Test new fullycts calculations
+
+# Example
+payoffs <- function(t) {100+50*t}
+prices <- function(t) {1.03 ^ (floor(t))}
+discrate <- function(t) {0.97 ^ t}
+uptakes <- function(t) {exp(-t/2)}
+
+# 1. Full function calls intermediate function ok
+test_that("Full function calls intermediate function ok", {
+    int <- dynpv_fullycts(uptakes=uptakes, payoffs=payoffs, horizon=5, tzero=0, prices=prices, discrate=discrate)
+    full <- dynpv(uptakes=uptakes, payoffs=payoffs, horizon=5, prices=prices, discrate=discrate)
+    expect_equal(int, full)
+  }
+)

tests/testthat/test-semicts.R

@@ -0,0 +1,19 @@
+# Test new semicts calculations
+
+# Example
+payoffs <- function(t) {100+50*t}
+prices <- function(t) {1.03 ^ (floor(t))}
+discrate <- function(t) {0.97 ^ t}
+
+# 1. Full function calls intermediate function ok
+test_that("Full function calls intermediate function ok", {
+    int <- dynpv_semicts(uptakes=1, payoffs=payoffs, horizon=5, tzero=0, prices=prices, discrate=discrate)
+    full <- dynpv(payoffs=payoffs, horizon=5, prices=prices, discrate=discrate)
+    expect_equal(int, full)
+  }
+)
+
+
+
+
+