discretise with two-day window in dist_skel

epiforecasts · Nov 17, 2023 · cf257e0 · cf257e0
1 parent 4536626
commit cf257e0
Showing 1 changed file with 34 additions and 35 deletions.
diff --git a/R/dist.R b/R/dist.R
@@ -84,50 +84,30 @@
 #' )
 dist_skel <- function(n, dist = FALSE, cum = TRUE, model,
                       discrete = FALSE, params, max_value = 120) {
+  ## define unnormalised support function
   if (model == "exp") {
     # define support functions for exponential dist
-    rdist <- function(n) {
-      rexp(n, params$rate)
-    }
-    pdist <- function(n) {
-      pexp(n, params$rate) / pexp(max_value, params$rate)
-    }
-    ddist <- function(n) {
-      (pexp(n + 1, params$rate) -
-        pexp(n, params$rate)) /
-        pexp(max_value + 1, params$rate)
+    updist <- function(n) {
+      pexp(n, params$rate)
     }
   } else if (model == "gamma") {
-    rdist <- function(n) {
-      rgamma(n, params$shape, params$scale)
-    }
-    pdist <- function(n) {
-      pgamma(n, params$shape, params$scale) /
-        pgamma(max_value + 1, params$shape, params$scale)
-    }
-    ddist <- function(n) {
-      (pgamma(n + 1, params$shape, params$scale) -
-        pgamma(n, params$shape, params$scale)) /
-        pgamma(max_value + 1, params$shape, params$scale)
+    # define support functions for gamma dist
+    updist <- function(n) {
+      pgamma(n, params$shape, params$scale)
     }
   } else if (model == "lognormal") {
-    rdist <- function(n) {
-      rlnorm(n, params$mean, params$sd)
-    }
-    pdist <- function(n) {
-      plnorm(n, params$mean, params$sd) /
-        plnorm(max_value + 1, params$mean, params$sd)
-    }
-    ddist <- function(n) {
-      (plnorm(n + 1, params$mean, params$sd) -
-        plnorm(n, params$mean, params$sd)) /
-        plnorm(max_value + 1, params$mean, params$sd)
+    updist <- function(n) {
+      plnorm(n, params$mean, params$sd)
     }
   }
 
+  ## define normalised support functions
   if (discrete) {
-    cmf <- c(0, pdist(seq_len(max_value + 2)))
-    pmf <- (cmf[-1] - c(0, cmf[seq(1, length(cmf) - 2)])) / sum(tail(cmf, 2))
+    cmf <- c(0, updist(1),
+      updist(seq_len(max_value)) + updist(seq_len(max_value) + 1)
+    ) /
+      (updist(max_value) + updist(max_value + 1))
+    pmf <- diff(cmf)
     rdist <- function(n) {
       sample(x = seq_len(max_value + 1) - 1, size = n, prob = pmf)
     }
@@ -137,6 +117,26 @@ dist_skel <- function(n, dist = FALSE, cum = TRUE, model,
     ddist <- function(n) {
       pmf[n + 1]
     }
+  } else {
+    pdist <- function(n) {
+      updist(n) / updist(max_value + 1)
+    }
+    ddist <- function(n) {
+      pdist(n + 1) - pdist(n)
+    }
+    if (model == "exp") {
+      rdist <- function(n) {
+        rexp(n, params$rate)
+      }
+    } else if (model == "gamma") {
+      rdist <- function(n) {
+        rgamma(n, params$shape, params$scale)
+      }
+    } else if (model == "lognormal") {
+      rdist <- function(n) {
+        rlnorm(n, params$mean, params$sd)
+      }
+    }
   }
 
   # define internal sampling function
@@ -161,7 +161,6 @@ dist_skel <- function(n, dist = FALSE, cum = TRUE, model,
       while (any(!is.na(n) & n >= max_value)) {
         n <- ifelse(n >= max_value, inner_skel(n), n)
       }
-
       n <- as.integer(n)
     }
     return(n)