imports from syn sport

ready4-dev · Nov 25, 2024 · 7f69915 · 7f69915
1 parent 947736a
commit 7f69915
Show file tree

Hide file tree

Showing 33 changed files with 1,594 additions and 966 deletions.
diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml
@@ -4,7 +4,6 @@ on:
   push:
     branches: [main, master]
   pull_request:
-    branches: [main, master]
   release:
     types: [published]
   workflow_dispatch:

diff --git a/DESCRIPTION b/DESCRIPTION
@@ -13,7 +13,7 @@ Description: Tools for undertaking time series analysis of mental health
     the serious package has been made available as part of the process of
     testing and documenting the package.  If you have any questions,
     please contact the authors (matthew.hamilton1@monash.edu).
-License: GPL-3 + file LICENSE
+License: GPL-3
 URL: https://ready4-dev.github.io/serious/,
     https://github.com/ready4-dev/serious,
     https://ready4-dev.github.io/ready4/
@@ -23,6 +23,7 @@ RoxygenNote: 7.3.2
 Suggests: 
     knitr,
     knitrBootstrap,
+    pkgload,
     rmarkdown,
     testthat
 VignetteBuilder: knitr
@@ -54,8 +55,10 @@ Imports:
     tidyselect,
     tsibble,
     xts,
+    youthu (>= 0.0.0.9122),
     youthvars (>= 0.0.0.9129)
-Remotes: 
+Remotes:  
     ready4-dev/ready4show,
     ready4-dev/ready4use,
-    ready4-dev/youthvars
+    ready4-dev/youthvars,
+    ready4-dev/youthu
diff --git a/NAMESPACE b/NAMESPACE
@@ -24,6 +24,7 @@ export(deprecated)
 export(get_ds_from_web_zip)
 export(get_index_type)
 export(get_medicare_data)
+export(get_model_predrs)
 export(get_new_index)
 export(get_performance)
 export(get_raw_erp_data)
@@ -48,13 +49,16 @@ export(make_service_summary)
 export(make_summary_ds)
 export(make_temporal_fns)
 export(make_temporal_vars)
+export(make_tfmn_args_ls)
 export(make_training_ds)
 export(make_ts_models)
+export(make_ts_models_ls)
 export(plot_autocorrelations)
 export(plot_decomposition)
 export(plot_forecast)
 export(plot_lags)
 export(plot_multiple)
+export(plot_residuals)
 export(plot_scatter)
 export(plot_series)
 export(plot_sngl_series)
@@ -63,6 +67,7 @@ export(plot_weekdays)
 export(transform_age_groups)
 export(transform_data_fmt)
 export(transform_output)
+export(transform_to_mdl_input)
 export(transform_to_shorthand)
 export(transform_to_temporal)
 export(transform_to_tsibble)
@@ -114,12 +119,15 @@ importFrom(fabletools,accuracy)
 importFrom(fabletools,components)
 importFrom(fabletools,forecast)
 importFrom(fabletools,model)
+importFrom(fabletools,report)
+importFrom(fabletools,vars)
 importFrom(feasts,ACF)
 importFrom(feasts,STL)
 importFrom(feasts,autolayer)
 importFrom(feasts,autoplot)
 importFrom(feasts,gg_lag)
 importFrom(feasts,gg_season)
+importFrom(feasts,gg_tsresiduals)
 importFrom(ggplot2,aes)
 importFrom(ggplot2,autoplot)
 importFrom(ggplot2,facet_grid)
@@ -162,6 +170,7 @@ importFrom(purrr,map2_dfr)
 importFrom(purrr,map2_lgl)
 importFrom(purrr,map_chr)
 importFrom(purrr,map_dbl)
+importFrom(purrr,map_dfc)
 importFrom(purrr,map_dfr)
 importFrom(purrr,map_int)
 importFrom(purrr,map_lgl)
@@ -201,7 +210,6 @@ importFrom(stringr,str_wrap)
 importFrom(tibble,add_case)
 importFrom(tibble,as_tibble)
 importFrom(tibble,tibble)
-importFrom(tidyr,all_of)
 importFrom(tidyr,drop_na)
 importFrom(tidyr,expand)
 importFrom(tidyr,fill)
@@ -210,6 +218,7 @@ importFrom(tidyr,pivot_longer)
 importFrom(tidyr,pivot_wider)
 importFrom(tidyselect,all_of)
 importFrom(tidyselect,any_of)
+importFrom(tsibble,append_row)
 importFrom(tsibble,as_tibble)
 importFrom(tsibble,as_tsibble)
 importFrom(tsibble,fill_gaps)

diff --git a/R/fn_add.R b/R/fn_add.R
@@ -348,37 +348,47 @@ add_episodes <- function (data_xx, separation_after_dbl, index_1L_int = integer(
 #' @param ts_models_ls Time series models (a list)
 #' @param data_xx Data (an output object of multiple potential types), Default: NULL
 #' @param periods_1L_int Periods (an integer vector of length one), Default: integer(0)
+#' @param type_1L_chr Type (a character vector of length one), Default: c("empirical", "scenario")
 #' @return Time series models (a list)
 #' @rdname add_fabels
 #' @export 
+#' @importFrom dplyr pull filter
+#' @importFrom rlang sym
 #' @importFrom purrr map2
 #' @importFrom fabletools forecast
 #' @importFrom stats setNames
 #' @keywords internal
-add_fabels <- function (ts_models_ls, data_xx = NULL, periods_1L_int = integer(0)) 
+add_fabels <- function (ts_models_ls, data_xx = NULL, periods_1L_int = integer(0), 
+    type_1L_chr = c("empirical", "scenario")) 
 {
+    type_1L_chr <- match.arg(type_1L_chr)
     if (identical(periods_1L_int, integer(0))) {
         periods_1L_int <- ts_models_ls$test_1L_int
     }
     if (identical(periods_1L_int, integer(0))) {
         stop("Supply a positive integer value to periods_1L_int")
     }
     if (!is.null(data_xx)) {
-        new_data_tsb <- get_tsibble(data_xx, frequency_1L_chr = ts_models_ls$args_ls$frequency_1L_chr, 
-            key_totals_ls = ts_models_ls$args_ls$key_totals_ls, 
-            key_vars_chr = ts_models_ls$args_ls$key_vars_chr, 
-            type_1L_chr = ts_models_ls$args_ls$type_1L_chr, what_1L_chr = ts_models_ls$args_ls$what_1L_chr)
-        if (!identical(ts_models_ls$test_1L_int, integer(0))) {
-            new_data_tsb <- new_data_tsb %>% tail(ts_models_ls$test_1L_int)
+        if (type_1L_chr == "empirical") {
+            new_data_tsb <- transform_to_mdl_input(data_xx, ts_models_ls = ts_models_ls)
+            if (!identical(ts_models_ls$test_1L_int, integer(0))) {
+                index_1L_chr <- get_new_index(ts_models_ls$args_ls$frequency_1L_chr)
+                test_dtm <- new_data_tsb %>% dplyr::pull(!!rlang::sym(index_1L_chr)) %>% 
+                  unique() %>% sort() %>% tail(ts_models_ls$test_1L_int)
+                new_data_tsb <- new_data_tsb %>% dplyr::filter(!!rlang::sym(index_1L_chr) %in% 
+                  test_dtm)
+            }
+        }
+        else {
+            new_data_tsb <- data_xx
         }
     }
     else {
         new_data_tsb <- NULL
     }
-    fabels_ls <- ts_models_ls$mabels_ls %>% purrr::map2(names(ts_models_ls$mabels_ls), 
+    ts_models_ls$fabels_ls <- ts_models_ls$mabels_ls %>% purrr::map2(names(ts_models_ls$mabels_ls), 
         ~.x %>% fabletools::forecast(h = periods_1L_int, new_data = new_data_tsb)) %>% 
         stats::setNames(names(ts_models_ls$mabels_ls))
-    ts_models_ls <- append(ts_models_ls, list(fabels_ls = fabels_ls))
     return(ts_models_ls)
 }
 #' Add new unique identifier

diff --git a/R/fn_calculate.R b/R/fn_calculate.R
@@ -20,9 +20,10 @@ calculate_autocorrelations <- function (data_xx, frequency_1L_chr = c("daily", "
     max_1L_int = NULL, metrics_chr = make_metric_vars()) 
 {
     frequency_1L_chr <- match.arg(frequency_1L_chr)
-    autocorrelations_ls <- metrics_chr %>% purrr::map(~get_tsibble(data_xx, 
-        frequency_1L_chr = frequency_1L_chr, key_totals_ls = key_totals_ls, 
-        key_vars_chr = key_vars_chr, metrics_chr = metrics_chr) %>% 
+    data_tsb <- get_tsibble(data_xx, frequency_1L_chr = frequency_1L_chr, 
+        key_totals_ls = key_totals_ls, key_vars_chr = key_vars_chr, 
+        metrics_chr = metrics_chr)
+    autocorrelations_ls <- metrics_chr %>% purrr::map(~data_tsb %>% 
         tsibble::fill_gaps() %>% feasts::ACF(!!rlang::sym(.x), 
         lag_max = max_1L_int)) %>% stats::setNames(metrics_chr)
     return(autocorrelations_ls)

diff --git a/R/fn_get.R b/R/fn_get.R
@@ -88,6 +88,40 @@ get_medicare_data <- function (path_1L_chr = character(0), clean_1L_lgl = FALSE,
     medicare_tb <- medicare_df %>% tibble::as_tibble()
     return(medicare_tb)
 }
+#' Get model predictors
+#' @description get_model_predrs() is a Get function that extracts data from an object. Specifically, this function implements an algorithm to get model predictors. The function returns Model predictors (a list).
+#' @param ts_models_ls Time series models (a list), Default: make_ts_models_ls()
+#' @return Model predictors (a list)
+#' @rdname get_model_predrs
+#' @export 
+#' @keywords internal
+get_model_predrs <- function (ts_models_ls = make_ts_models_ls()) 
+{
+    predictors_chr <- cumulatives_chr <- contributors_chr <- joins_chr <- character(0)
+    if (!identical(ts_models_ls$predictor_args_ls, make_tfmn_args_ls())) {
+        predictors_chr <- ts_models_ls$predictor_args_ls$metrics_chr
+    }
+    if (!identical(ts_models_ls$cumulatives_args_ls, make_tfmn_args_ls())) {
+        contributors_chr <- ts_models_ls$cumulatives_args_ls$metrics_chr
+        cumulatives_chr <- paste0(ts_models_ls$cumulatives_args_ls$prefix_1L_chr, 
+            ts_models_ls$cumulatives_args_ls$metrics_chr)
+    }
+    if (!identical(ts_models_ls$join_args_ls, make_tfmn_args_ls())) {
+        if (ts_models_ls$join_args_ls$type_1L_chr == "cumulative") {
+            join_contributors_chr <- ts_models_ls$join_args_ls$metrics_chr
+            joins_chr <- paste0(ts_models_ls$join_args_ls$prefix_1L_chr, 
+                ts_models_ls$join_args_ls$metrics_chr)
+        }
+        else {
+            join_contributors_chr <- character(0)
+            joins_chr <- ts_models_ls$join_args_ls$metrics_chr
+        }
+    }
+    model_predrs_ls <- list(predictors_chr = predictors_chr, 
+        contributors_chr = contributors_chr, cumulatives_chr = cumulatives_chr, 
+        join_contributors_chr = join_contributors_chr, joins_chr = joins_chr)
+    return(model_predrs_ls)
+}
 #' Get new index
 #' @description get_new_index() is a Get function that extracts data from an object. Specifically, this function implements an algorithm to get new index. The function returns New index (a character vector of length one).
 #' @param frequency_1L_chr Frequency (a character vector of length one), Default: c("daily", "weekly", "monthly", "quarterly", "yearly", "fiscal", 
@@ -111,30 +145,42 @@ get_new_index <- function (frequency_1L_chr = c("daily", "weekly", "monthly",
 #' @description get_performance() is a Get function that extracts data from an object. Specifically, this function implements an algorithm to get performance. The function returns Performance (a tibble).
 #' @param ts_mdls_ls Time series models (a list)
 #' @param data_xx Data (an output object of multiple potential types)
-#' @param metric_1L_chr Metric (a character vector of length one), Default: make_metric_vars()
+#' @param metric_1L_chr Metric (a character vector of length one)
 #' @param rank_by_int Rank by (an integer vector), Default: integer(0)
 #' @param statistics_chr Statistics (a character vector), Default: c("RMSE", "MAE", "MPE", "MAPE")
+#' @param type_1L_chr Type (a character vector of length one), Default: c("accuracy", "report")
 #' @return Performance (a tibble)
 #' @rdname get_performance
 #' @export 
 #' @importFrom purrr pluck
-#' @importFrom fabletools accuracy
+#' @importFrom fabletools accuracy report
 #' @importFrom dplyr select arrange
 #' @importFrom rlang sym
 #' @keywords internal
-get_performance <- function (ts_mdls_ls, data_xx, metric_1L_chr = make_metric_vars(), 
-    rank_by_int = integer(0), statistics_chr = c("RMSE", "MAE", 
-        "MPE", "MAPE")) 
+get_performance <- function (ts_mdls_ls, data_xx, metric_1L_chr, rank_by_int = integer(0), 
+    statistics_chr = c("RMSE", "MAE", "MPE", "MAPE"), type_1L_chr = c("accuracy", 
+        "report")) 
 {
-    metric_1L_chr <- match.arg(metric_1L_chr)
+    type_1L_chr <- match.arg(type_1L_chr)
     data_tsb <- get_tsibble(data_xx, frequency_1L_chr = ts_mdls_ls$args_ls$frequency_1L_chr, 
         key_totals_ls = ts_mdls_ls$args_ls$key_totals_ls, key_vars_chr = ts_mdls_ls$args_ls$key_vars_chr, 
-        type_1L_chr = ts_mdls_ls$args_ls$type_1L_chr, what_1L_chr = ts_mdls_ls$args_ls$what_1L_chr)
-    performance_tb <- ts_mdls_ls$fabels_ls %>% purrr::pluck(metric_1L_chr) %>% 
-        fabletools::accuracy(data_tsb)
+        metrics_chr = metric_1L_chr, type_1L_chr = ts_mdls_ls$args_ls$type_1L_chr, 
+        what_1L_chr = ts_mdls_ls$args_ls$what_1L_chr)
+    if (type_1L_chr == "accuracy") {
+        performance_tb <- ts_mdls_ls$fabels_ls %>% purrr::pluck(metric_1L_chr) %>% 
+            fabletools::accuracy(data_tsb)
+    }
+    else {
+        performance_tb <- ts_mdls_ls$mabels_ls %>% purrr::pluck(metric_1L_chr) %>% 
+            fabletools::report()
+        statistics_chr <- setdiff(names(performance_tb), c(".model", 
+            intersect(c(ts_mdls_ls$args_ls$what_1L_chr, ts_mdls_ls$args_ls$key_vars_chr), 
+                names(performance_tb))))
+    }
     if (!identical(statistics_chr, character(0))) {
         performance_tb <- performance_tb %>% dplyr::select(.model, 
-            statistics_chr)
+            intersect(c(ts_mdls_ls$args_ls$what_1L_chr, ts_mdls_ls$args_ls$key_vars_chr), 
+                names(performance_tb)), statistics_chr)
     }
     if (!identical(rank_by_int, integer(0))) {
         performance_tb <- performance_tb %>% dplyr::arrange(!!rlang::sym(statistics_chr[rank_by_int]))
@@ -236,7 +282,7 @@ get_temporal_fn <- function (period_1L_chr = make_temporal_vars(index_1L_chr = "
 #' @param frequency_1L_chr Frequency (a character vector of length one), Default: c("daily", "weekly", "monthly", "quarterly", "yearly", "fiscal")
 #' @param key_totals_ls Key totals (a list), Default: NULL
 #' @param key_vars_chr Key variables (a character vector), Default: character(0)
-#' @param metrics_chr Metrics (a character vector), Default: make_metric_vars()
+#' @param metrics_chr Metrics (a character vector), Default: character(0)
 #' @param prefix_1L_chr Prefix (a character vector of length one), Default: 'Cumulative'
 #' @param type_1L_chr Type (a character vector of length one), Default: c("totals", "key", "wide", "main", "cumulative")
 #' @param what_1L_chr What (a character vector of length one), Default: character(0)
@@ -251,12 +297,15 @@ get_temporal_fn <- function (period_1L_chr = make_temporal_vars(index_1L_chr = "
 #' @importFrom tidyselect all_of
 get_tsibble <- function (data_xx, fill_gaps_1L_lgl = FALSE, frequency_1L_chr = c("daily", 
     "weekly", "monthly", "quarterly", "yearly", "fiscal"), key_totals_ls = NULL, 
-    key_vars_chr = character(0), metrics_chr = make_metric_vars(), 
+    key_vars_chr = character(0), metrics_chr = character(0), 
     prefix_1L_chr = "Cumulative", type_1L_chr = c("totals", "key", 
         "wide", "main", "cumulative"), what_1L_chr = character(0)) 
 {
     frequency_1L_chr <- match.arg(frequency_1L_chr)
     type_1L_chr <- match.arg(type_1L_chr)
+    if (identical(metrics_chr, character(0))) {
+        metrics_chr <- make_metric_vars()
+    }
     if (!tsibble::is_tsibble(data_xx) & !inherits(data_xx, "Ready4useDyad")) {
         assertthat::assert_that(is.list(data_xx))
         data_xx <- purrr::pluck(data_xx, paste0(type_1L_chr, 
@@ -326,8 +375,8 @@ get_tsibble <- function (data_xx, fill_gaps_1L_lgl = FALSE, frequency_1L_chr = c
                     tidyselect::all_of(c(key_vars_chr, metrics_chr)))
             }
             data_tsb <- filtered_tb %>% transform_to_tsibble(index_1L_chr = new_index_1L_chr, 
-                metrics_chr = metrics_chr, temporal_vars_chr = character(0), 
-                key_vars_chr = key_vars_chr)
+                key_vars_chr = key_vars_chr, metrics_chr = metrics_chr, 
+                temporal_vars_chr = character(0))
             if (type_1L_chr == "cumulative") {
                 base_index_1L_chr <- tsibble::index(data_xx) %>% 
                   as.character()