Improve speed of date math

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: actxps
 Title: Create Actuarial Experience Studies: Prepare Data, Summarize Results, and Create Reports
-Version: 1.4.0
+Version: 1.4.0.9000
 Authors@R: 
     person("Matt", "Heaphy", email = "[email protected]", role = c("aut", "cre"))
 Maintainer: Matt Heaphy <[email protected]>
@@ -20,7 +20,7 @@ URL: https://github.com/mattheaphy/actxps/,
 BugReports: https://github.com/mattheaphy/actxps/issues
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.0
 Suggests: 
     knitr,
     RColorBrewer,
@@ -33,7 +33,6 @@ Config/testthat/edition: 3
 Depends: 
     R (>= 4.1)
 Imports: 
-    lubridate,
     dplyr (>= 1.1.1),
     ggplot2,
     tibble,
@@ -47,6 +46,7 @@ Imports:
     generics,
     readr,
     tidyr,
-    vctrs
+    vctrs,
+    clock
 LazyData: true
 VignetteBuilder: knitr

NAMESPACE

@@ -99,7 +99,6 @@ export(mutate)
 export(plot_actual_to_expected)
 export(plot_termination_rates)
 export(plot_utilization_rates)
-export(pol_interval)
 export(pol_mth)
 export(pol_qtr)
 export(pol_wk)
@@ -134,8 +133,6 @@ importFrom(dplyr,slice)
 importFrom(dplyr,ungroup)
 importFrom(generics,tidy)
 importFrom(ggplot2,autoplot)
-importFrom(lubridate,"%m+%")
-importFrom(lubridate,"%m-%")
 importFrom(recipes,bake)
 importFrom(recipes,prep)
 importFrom(rlang,":=")

NEWS.md

@@ -1,3 +1,10 @@
+# actxps 1.4.0.9000
+
+- To improve the speed of date calculations, lubridate was replaced with the clock package. Lubridate is no longer included in Imports.
+- **Breaking change** - The `pol_interval()` function is no longer exported. As part of the removal of lubridate, this function's `dur_length` argument only accepts, "year", "quarter", "month", or "week".
+- Shiny app layout updates
+- Small vignette and documentation clean-ups
+
 # actxps 1.4.0
 
 - actxps now supports split exposures that divide calendar periods crossing 

R/exp_shiny.R

@@ -68,7 +68,7 @@
 #'
 #' ## Output
 #'
-#' ### Plot Tab
+#' ### Plot
 #'
 #' This tab includes a plot and various options for customization:
 #'
@@ -252,11 +252,12 @@ exp_shiny <- function(dat,
   if (has_trx) {
     yVar_trx <- c("trx_util", "trx_freq", "trx_n", "trx_flag",
                   "trx_amt", "avg_trx", "avg_all", "exposure")
-    available_studies <- c("Termination study" = "exp",
-                           "Transaction study" = "trx")
   } else {
     yVar_trx <- NULL
-    available_studies <- c("Termination study" = "exp")
+  }
+
+  is.Date <- function(x) {
+    inherits(x, "Date")
   }
 
   # function to make input widgets
@@ -283,7 +284,7 @@ exp_shiny <- function(dat,
         step = if (is.integer(dat[[x]]) && info$n_unique < 100) 1L else NULL
       )
 
-    } else if (lubridate::is.Date(dat[[x]])) {
+    } else if (is.Date(dat[[x]])) {
 
       shiny::dateRangeInput(
         inputId, shiny::strong(x),
@@ -325,7 +326,7 @@ exp_shiny <- function(dat,
 
     inputId <- paste("i", x, sep = "_")
 
-    res <- if (is.numeric(dat[[x]]) || lubridate::is.Date(dat[[x]])) {
+    res <- if (is.numeric(dat[[x]]) || is.Date(dat[[x]])) {
       # numeric or date
       glue::glue("between({x}, input${inputId}[[1]], input${inputId}[[2]])")
     } else {
@@ -435,7 +436,7 @@ exp_shiny <- function(dat,
     sidebar = bslib::sidebar(
 
       title = "Filters",
-      width = "300px",
+      width = 370,
 
       bslib::input_switch("play",
                           list("Reactivity ",
@@ -446,9 +447,10 @@ exp_shiny <- function(dat,
       # filter descriptions
       bslib::value_box(
         title = "% data remaining",
+        theme = "primary",
         value = shiny::textOutput("rem_pct"),
         showcase = shiny::plotOutput("filter_pie",
-                                     height = "60px", width = "60px")
+                                     width = "75px", height = "75px")
       ) |>
         bslib::tooltip(paste0("Original row count: ",
                               scales::label_comma()(total_rows)),
@@ -520,6 +522,7 @@ exp_shiny <- function(dat,
 
     bslib::navset_bar(
       title = "Output",
+      inverse = TRUE,
       bslib::nav_panel(
         "Plot",
         bslib::card(
@@ -823,7 +826,8 @@ exp_shiny <- function(dat,
           trx_stats(percent_of = input$pct_checks,
                     trx_types = input$trx_types_checks,
                     combine_trx = input$trx_combine,
-                    conf_int = TRUE)
+                    conf_int = TRUE,
+                    conf_level = conf_level)
       }
 
     })
@@ -927,13 +931,14 @@ exp_shiny <- function(dat,
 
     })
 
-    # table output
+
     output$xpPlot <- shiny::renderPlot(
       {rplot()},
       res = 92,
       height = function() if (input$plotResize) input$plotHeight else "auto",
       width = function() if (input$plotResize) input$plotWidth else "auto")
 
+    # table output
     rtable <- shiny::reactive({
       # for an unknown reason, the table doesn't react to changes in decimals
       # alone as if it were wrapped in isolate(). force() resolves the issue
@@ -985,7 +990,7 @@ exp_shiny <- function(dat,
       choices <- info$scope[[1]]
 
       # numeric or date
-      if (is.numeric(dat[[x]]) || lubridate::is.Date(dat[[x]])) {
+      if (is.numeric(dat[[x]]) || is.Date(dat[[x]])) {
 
         if (selected[[1]] == selected[[2]]) {
           # exactly equal

R/expose.R

@@ -81,8 +81,6 @@
 #' @references Atkinson and McGarry (2016). Experience Study Calculations.
 #' <https://www.soa.org/49378a/globalassets/assets/files/research/experience-study-calculations.pdf>
 #'
-#' @importFrom lubridate %m+% %m-%
-#'
 #' @export
 expose <- function(.data,
                    end_date,
@@ -105,11 +103,11 @@ expose <- function(.data,
     paste0(prefix, "_", res, suffix)
   }
 
-
   # set up exposure period lengths
   expo_length <- rlang::arg_match(expo_length)
-  expo_step <- expo_step(expo_length)
   cal_frac <- cal_frac(expo_length)
+  cal_floor <- cal_floor(expo_length)
+  add_period <- add_period(expo_length)
 
   # column renames and name conflicts
   .data <- .data |>
@@ -137,25 +135,22 @@ expose <- function(.data,
            is.na(term_date) | term_date > start_date) |>
     mutate(
       term_date = dplyr::if_else(term_date > end_date,
-                                 lubridate::NA_Date_, term_date),
+                                 as.Date(NA), term_date),
       status = dplyr::if_else(is.na(term_date), default_status, status),
       last_date = pmin(term_date, end_date, na.rm = TRUE))
 
   if (cal_expo) {
     res <- res |>
       mutate(
         first_date = pmax(issue_date, start_date),
-        cal_b = lubridate::floor_date(first_date, expo_length),
-        tot_per = lubridate::interval(
-          cal_b,
-          lubridate::floor_date(last_date, expo_length)
-        ) / expo_step,
-        rep_n = ceiling(tot_per) + 1)
+        cal_b = cal_floor(first_date),
+        rep_n = clock::date_count_between(cal_b, last_date,
+                                          expo_length) + 1L)
   } else {
     res <- res |>
       mutate(
-        tot_per = lubridate::interval(issue_date - 1, last_date) / expo_step,
-        rep_n = ceiling(tot_per))
+        rep_n = clock::date_count_between(issue_date, last_date,
+                                          expo_length) + 1L)
   }
 
   # apply exposures
@@ -167,13 +162,13 @@ expose <- function(.data,
     mutate(
       last_per = .time == rep_n,
       status = dplyr::if_else(last_per, status, default_status),
-      term_date = dplyr::if_else(last_per, term_date, lubridate::NA_Date_))
+      term_date = dplyr::if_else(last_per, term_date, as.Date(NA)))
 
   if (cal_expo) {
     res <- res |>
       mutate(first_per = .time == 1,
-             cal_e = cal_b %m+% (expo_step * .time) - 1,
-             cal_b = cal_b %m+% (expo_step * (.time - 1)),
+             cal_e = add_period(cal_b, .time) - 1L,
+             cal_b = add_period(cal_b, .time - 1L),
              exposure = dplyr::case_when(
                status %in% target_status ~ 1,
                first_per & last_per ~ cal_frac(last_date) -
@@ -183,22 +178,25 @@ expose <- function(.data,
                TRUE ~ 1)
       ) |>
       select(-rep_n, -first_date, -last_date, -first_per, -last_per,
-             -.time, -tot_per) |>
+             -.time) |>
       relocate(cal_e, .after = cal_b) |>
       dplyr::rename_with(.fn = rename_col, .cols = cal_b, prefix = "cal") |>
       dplyr::rename_with(.fn = rename_col, .cols = cal_e, prefix = "cal",
                          suffix = "_end")
   } else {
     res <- res |>
       mutate(
-        cal_b = issue_date %m+% (expo_step * (.time - 1)),
-        cal_e = issue_date %m+% (expo_step * .time) - 1,
-        exposure = dplyr::if_else(last_per & !status %in% target_status,
-                                  tot_per %% 1, 1),
+        cal_b = add_period(issue_date, .time - 1L),
+        cal_e = add_period(issue_date, .time) - 1L,
+        exposure = dplyr::if_else(
+          last_per & !status %in% target_status,
+          as.integer((last_date - cal_b + 1))  /
+            as.integer(cal_e - cal_b + 1),
+          1),
         # exposure = 0 is possible if exactly 1 period has elapsed. replace these with 1's
         exposure = dplyr::if_else(exposure == 0, 1, exposure)
       ) |>
-      select(-last_per, -last_date, -tot_per, -rep_n) |>
+      select(-last_per, -last_date, -rep_n) |>
       filter(between(cal_b, start_date, end_date)) |>
       dplyr::rename_with(.fn = rename_col, .cols = .time, prefix = "pol") |>
       dplyr::rename_with(.fn = rename_col, .cols = cal_b, prefix = "pol_date") |>
@@ -266,31 +264,76 @@ expose_cw <- function(...) {
 
 # helper functions for calendar year fractions - do not export
 year_frac <- function(x, .offset = 0) {
-  (lubridate::yday(x) - .offset) / (365 + lubridate::leap_year(x))
+  xday <- clock::as_year_day(x) |> clock::get_day()
+  (xday - .offset) / (365 + clock::date_leap_year(x))
 }
 
 quarter_frac <- function(x, .offset = 0) {
-  (lubridate::qday(x) - .offset) /
-    lubridate::qday((lubridate::ceiling_date(x, "quarter") - 1))
+  xday <- clock::as_year_quarter_day(x) |> clock::get_day()
+  qdays <- (clock::date_group(x, "month", n = 3) |>
+              clock::add_quarters(1, invalid = "previous") - 1L) |>
+    clock::as_year_quarter_day() |>
+    clock::get_day()
+  (xday - .offset) / qdays
 }
 
 month_frac <- function(x, .offset = 0) {
-  (lubridate::mday(x) - .offset) /
-    lubridate::mday((lubridate::ceiling_date(x, "month") - 1))
+  xday <- clock::get_day(x)
+  mdays <- (clock::date_group(x, "month") |>
+              clock::add_months(1, invalid = "previous") - 1L) |>
+    clock::get_day()
+  (xday - .offset) / mdays
 }
 
 week_frac <- function(x, .offset = 0) {
-  (lubridate::wday(x) - .offset) / 7
+  (clock::as_year_week_day(x) |> clock::get_day() - .offset) / 7
 }
 
-cal_frac <- function(x) {
-  switch(x,
+cal_frac <- function(expo_length) {
+  switch(expo_length,
          "year" = year_frac,
          "quarter" = quarter_frac,
          "month" = month_frac,
          'week' = week_frac)
 }
 
+# helper functions for calendar year flooring
+year_floor <- function(x) {
+  clock::date_group(x, "year")
+}
+
+quarter_floor <- function(x) {
+  clock::date_group(x, "month", n = 3)
+}
+
+month_floor <- function(x) {
+  clock::date_group(x, "month")
+}
+
+week_floor <- function(x) {
+  sunday <- clock::weekday(clock::clock_weekdays$sunday)
+  clock::date_shift(x, target = sunday, which = "previous")
+}
+
+cal_floor <- function(expo_length) {
+  switch(expo_length,
+         "year" = year_floor,
+         "quarter" = quarter_floor,
+         "month" = month_floor,
+         'week' = week_floor)
+}
+
+# helper function for adding period
+add_period <- function(expo_length) {
+  fun <- switch(expo_length,
+                "year" = clock::add_years,
+                "quarter" = clock::add_quarters,
+                "month" = clock::add_months,
+                'week' = clock::add_weeks)
+  if (expo_length == "week") return(fun)
+  \(x, n) fun(x, n, invalid = "previous")
+}
+
 # helper function to handle name conflicts
 .expo_name_conflict <- function(.data, cal_expo, expo_length) {
 
@@ -326,12 +369,3 @@ most_common <- function(x) {
   y <- table(x) |> sort(decreasing = TRUE) |> names()
   factor(y[[1]], levels(x))
 }
-
-# helper function for determining exposure step lengths
-expo_step <- function(x) {
-  switch(x,
-         "year" = lubridate::years(1),
-         "quarter" = months(3),
-         "month" = months(1),
-         "week" = lubridate::days(7))
-}