diff --git a/dashboard/R/fit_model.R b/dashboard/R/fit_model.R index c84362f..8c95657 100644 --- a/dashboard/R/fit_model.R +++ b/dashboard/R/fit_model.R @@ -42,7 +42,7 @@ generate_recipe_spec <- function(data, method) { rcp_spec <- recipe(value ~ ., data = data) - } else if (method_type == "ml" | method_type == "dl") { + } else if (any(method_type %in% c("ml", "dl"))) { rcp_spec <- recipe(value ~ ., data = data) |> step_timeseries_signature(date) |> @@ -51,13 +51,13 @@ generate_recipe_spec <- function(data, method) { step_rm(matches("(iso)|(xts)|(index.num)")) |> step_dummy(all_nominal(), one_hot = TRUE) - } else if (method_type == "mix") { + } else if (any(method_type %in% c("mix", "aml"))) { rcp_spec <- recipe(value ~ ., data = data) |> step_timeseries_signature(date) |> - step_normalize(date_index.num) |> + step_mutate(trend = as.numeric(date)) |> step_zv(all_predictors()) |> - step_rm(matches("(iso)|(xts)")) |> + step_rm(matches("(iso)|(xts)|(index.num)")) |> step_dummy(all_nominal(), one_hot = TRUE) } else { @@ -346,6 +346,23 @@ generate_model_spec <- function(method, params) { ) |> set_engine("prophet_xgboost") + } else if (method == "H2O AutoML") { + + model_spec <- automl_reg(mode = "regression") |> + set_engine( + engine = "h2o", + project_name = "h2o_tsf_dashboard", + max_models = 50, + max_runtime_secs = !!params$h2o_max_time, + max_runtime_secs_per_model = !!params$h2o_max_time_model, + nfolds = !!params$h2o_nfolds, + sort_metric = !!params$h2o_metric, + seed = 1992 + # include_algos = c("DRF"), + # exclude_algos = c("DeepLearning"), + # verbosity = NULL + ) + } else { stop(paste("Unknown method", method)) } @@ -354,6 +371,29 @@ generate_model_spec <- function(method, params) { } +# function to set the metric set +set_metric_set <- function(metric) { + + metric <- tolower(metric) + if (metric == "mae") { + mtr_set <- yardstick::metric_set(mae) + } else if (metric == "mape") { + mtr_set <- yardstick::metric_set(mape) + } else if (metric == "mase") { + mtr_set <- yardstick::metric_set(mase) + } else if (metric == "smape") { + mtr_set <- yardstick::metric_set(smape) + } else if (metric == "mse") { + mtr_set <- yardstick::metric_set(mse) + } else if (metric == "rmse") { + mtr_set <- yardstick::metric_set(rmse) + } else { + stop(paste("Unknown metric", metric)) + } + return(mtr_set) + +} + # function to generate the model specification for tuning set_tune_parameters <- function(method, params) { @@ -366,7 +406,6 @@ set_tune_parameters <- function(method, params) { } } - mtd_params <- getOption("tsf.dashboard.methods_params")[[method]] # get the parameters for the method if (method == "Elastic Net") { prm_ui_name <- params$tune_elanet } else if (method == "MARS") { @@ -396,6 +435,8 @@ set_tune_parameters <- function(method, params) { } else { stop(paste("Unknown method", method)) } + + mtd_params <- getOption("tsf.dashboard.methods_params")[[method]] # get the parameters for the method tune_params <- mtd_params[names(mtd_params) %in% prm_ui_name] # get the parameters to tune is_to_tune <- mtd_params %in% tune_params new_params <- purrr::map2(mtd_params, is_to_tune, set_tune) |> purrr::set_names(mtd_params) @@ -456,6 +497,7 @@ fit_model <- function(data, method, params, n_assess, assess_type, seed = 1992) wkfl_spec <- workflow() |> add_recipe(rcp_spec) |> add_model(model_spec) # fitting + if (method == "H2O AutoML") { h2o.init() } wkfl_fit <- wkfl_spec |> fit(data = train_tbl) return(wkfl_fit) @@ -526,11 +568,13 @@ fit_model_tuning <- function( data, method, params, n_assess, assess_type, validation_type = "Time Series CV", n_folds = 5, validation_metric = "rmse", grid_size = 10, - seed = 1992 + bayesian_optimization = TRUE, seed = 1992 ) { params_new <- set_tune_parameters(method, params) check_parameters(method, params_new) + validation_metric <- tolower(validation_metric) + valid_metric_set <- set_metric_set(validation_metric) set.seed(seed) # initial split @@ -557,17 +601,31 @@ fit_model_tuning <- function( # tuning doFuture::registerDoFuture() future::plan(strategy = "multisession", workers = parallelly::availableCores() - 1) - tune_fit <- wkfl_spec |> - tune::tune_grid( - resamples = cv_splits, - grid = params$tune_grid_size, # grid_spec - metrics = modeltime::default_forecast_accuracy_metric_set(), - control = tune::control_grid(save_pred = FALSE, allow_par = TRUE) - ) + if (bayesian_optimization) { + tune_fit <- wkfl_spec |> + tune::tune_bayes( + resamples = cv_splits, + metrics = valid_metric_set, + initial = as.integer(params$tune_grid_size), + objective = tune::conf_bound(kappa = 0.1), + iter = 20L, # as.integer(length(params_new) * 20) good practice + control = tune::control_bayes( + save_pred = FALSE, allow_par = TRUE, verbose = TRUE, no_improve = 5L + ) + ) + } else { + tune_fit <- wkfl_spec |> + tune::tune_grid( + resamples = cv_splits, + metrics = valid_metric_set, + grid = as.integer(params$tune_grid_size), # grid_spec + control = tune::control_grid(save_pred = FALSE, allow_par = TRUE, verbose = TRUE) + ) + } future::plan(strategy = "sequential") # picking best model - best_fit <- tune::show_best(tune_fit, metric = tolower(validation_metric), n = 1) + best_fit <- tune::show_best(tune_fit, metric = validation_metric, n = 1) # fitting (fit to training with optimal values) wkfl_fit <- wkfl_spec |> tune::finalize_workflow(best_fit) |> fit(train_tbl) diff --git a/dashboard/R/generate_forecast.R b/dashboard/R/generate_forecast.R index 7af535c..cbcd406 100644 --- a/dashboard/R/generate_forecast.R +++ b/dashboard/R/generate_forecast.R @@ -75,6 +75,7 @@ generate_forecast <- function( conf_interval = 0.95, conf_method = "conformal_split" ) + if (method == "H2O AutoML") { h2o.shutdown(prompt = FALSE) } res <- list( "splits" = splits, "fit" = fitted_model_list, diff --git a/dashboard/R/utils.R b/dashboard/R/utils.R index 135431b..2e39281 100644 --- a/dashboard/R/utils.R +++ b/dashboard/R/utils.R @@ -8,6 +8,7 @@ set_options <- function() { "ml" = c("Linear Regression", "Elastic Net", "MARS", "KNN", "SVM", "Random Forest", "Boosted Trees", "Cubist"), "dl" = c("Feed-Forward", "COMING SOON!"), "mix" = c("Feed-Forward AR", "ARIMA-Boost", "Prophet-Boost"), + "aml" = c("H2O AutoML", "COMING SOON!"), "ens" = c("Average", "Weighted Average", "Median"), "stk" = c("Linear Regression", "Elastic Net"), "tune" = c( @@ -85,7 +86,9 @@ set_options <- function() { ) |> purrr::set_names(c( "Random Predictors", "Trees", "Min Node Size", "Tree Depth", "Learning Rate", "Min Loss Reduction", "Sample" - )) + )), + "H2O AutoML" = c("h2o_max_time", "h2o_max_time_model", "h2o_nfolds", "h2o_metric") |> + purrr::set_names(c("Max Time (secs)", "Max Time per Model (secs)", "Folds", "Metric")) ), tsf.dashboard.transfs = c("log", "boxcox", "norm", "stand", "diff", "sdiff"), tsf.dashboard.test_transfs = c("test_log", "test_diff", "test_sdiff"), @@ -140,8 +143,14 @@ parse_method <- function(method) { res <- "dl" } else if (method %in% mtd$mix) { res <- "mix" + } else if (method %in% mtd$aml) { + res <- "aml" } else if (method %in% mtd$ens) { res <- "ens" + } else if (method %in% mtd$stk) { + res <- "stk" + } else if (method %in% mtd$tune) { + res <- "tune" } else { stop(paste("Unknown method", method)) } @@ -198,7 +207,8 @@ get_default <- function(parameter, return_value = TRUE) { "arima_boost_mtry" = 5, "arima_boost_trees" = 100, "arima_boost_min_n" = 1, "arima_boost_tree_depth" = 6, # ARIMA-Boost "arima_boost_learn_rate" = 0.3, "arima_boost_loss_reduction" = 0, "arima_boost_sample_size" = 1, "prophet_boost_mtry" = 5, "prophet_boost_trees" = 100, "prophet_boost_min_n" = 1, "prophet_boost_tree_depth" = 6, # Prophet-Boost - "prophet_boost_learn_rate" = 0.3, "prophet_boost_loss_reduction" = 0, "prophet_boost_sample_size" = 1 + "prophet_boost_learn_rate" = 0.3, "prophet_boost_loss_reduction" = 0, "prophet_boost_sample_size" = 1, + "h2o_max_time" = 30, "h2o_max_time_model" = 15, "h2o_nfolds" = 5, "h2o_metric" = "RMSE" ) if (return_value) { diff --git a/dashboard/test.R b/dashboard/test.R index 9ddf55b..ab50549 100644 --- a/dashboard/test.R +++ b/dashboard/test.R @@ -198,7 +198,7 @@ input <- list( n_folds = 5, metric = "RMSE", grid_size = 10, - tune_xx_elanet = c("Penalty", "Mixture") + tune_elanet = c("Penalty", "Mixture") ) input <- list( n_future = 12, @@ -221,6 +221,7 @@ validation_type = input$valid_type n_folds = input$n_folds validation_metric = input$metric grid_size = input$grid_size +seed = 1992 fitted_model_list <- map( input$method, @@ -262,3 +263,40 @@ res <- map( assess_type = input$assess_type ) res$accuracy |> format_accuracy(single_method = TRUE) + + +### GRID + +model_spec <- rand_forest( + mode = "regression", + mtry = tune(), + trees = tune(), + min_n = tune() +) |> + set_engine("ranger") + +model_spec <- boost_tree( + mode = "regression", + mtry = tune(), + trees = tune(), + min_n = tune(), + tree_depth = tune(), + learn_rate = tune(), + loss_reduction = tune(), + sample_size = tune() +) |> + set_engine("xgboost") + +model_spec <- prophet_boost( + mode = "regression", + mtry = tune(), + trees = tune(), + min_n = tune(), + tree_depth = tune(), + learn_rate = tune(), + loss_reduction = tune(), + sample_size = tune() +) |> + set_engine("prophet_xgboost") + + diff --git a/dashboard/todo.txt b/dashboard/todo.txt index 1c93e37..4c1bb7f 100644 --- a/dashboard/todo.txt +++ b/dashboard/todo.txt @@ -11,15 +11,17 @@ Next steps: - deployment su github actions - move to another github repo - documentazione in alto a destra +- aggiungere package::function per ogni funzione To Do: -- tune_bayes - -- aggiungere metodi di automl (h2o) +- ancora problema con mtry con tune_bayes, risolvere creando la griglia +- check h2o in compare e combine - pensare e aggiungere la sezione di stacking (LM + Elastic Net) -- pensare e aggiungere la sezione di scenario forecasting + uncertainty + judgmental (gauges?) +- pensare e aggiungere la sezione di scenario forecasting + uncertainty + judgmental (gauges?) + rolling variances - pensare e aggiungere il save del modello ottimizzato + use optimize in altre sezioni - aggiungere metodi di dl (NeuralProphet + NBEATS + DeepAR) - pensare e aggiungere la sezione di feature engineering (con in mente il save) - modificare output modello con parsing - cambiare assegnazione nomi ai parametri in UI +- XAI +- aggiornamento cluster h2o diff --git a/dashboard/tsf_dashboard.Rmd b/dashboard/tsf_dashboard.Rmd index 07d7bf6..40de32f 100644 --- a/dashboard/tsf_dashboard.Rmd +++ b/dashboard/tsf_dashboard.Rmd @@ -30,7 +30,8 @@ pkgs <- c( "forecast", "prophet", "glmnet", "earth", "kernlab", "kknn", "randomForest", "ranger", "xgboost", "treesnip", "lightgbm", "Cubist", "rules", - "tidymodels", "modeltime", + "tidymodels", + "modeltime", "modeltime.ensemble", "modeltime.resample", "modeltime.h2o", "plotly", "DT", "timetk", "rmarkdown", "flexdashboard", "shiny", "shinyWidgets", "shinyjs", "shinymanager" @@ -43,12 +44,14 @@ datasets <- c( ) set_options() +Sys.setenv(JAVA_HOME = "/usr/lib/jvm/jdk-17/") methods <- getOption("tsf.dashboard.methods") ts_methods <- methods$ts ml_methods <- methods$ml dl_methods <- methods$dl mix_methods <- methods$mix +aml_methods <- methods$aml ens_methods <- methods$ens stk_methods <- methods$stk tune_methods <- methods$tune @@ -116,15 +119,7 @@ data_selected <- reactive({ ts_freq <- reactive({ data_selected()$frequency |> unique() |> parse_frequency() }) -``` - - -Row 1 {data-height=100} ---------------------------------------------------------------------------- - -### -```{r} output$data_table <- renderDT({ data_selected() |> datatable( @@ -136,7 +131,15 @@ output$data_table <- renderDT({ }) output$data_str <- renderPrint({ str(data_selected()) }) output$data_summ <- renderPrint({ skim(data_selected()) }) +``` + + +Row 1 {data-height=100} +--------------------------------------------------------------------------- + +### +```{r} conditionalPanel( condition = "input.table_type == 'Preview'", DTOutput(outputId = "data_table") @@ -237,15 +240,7 @@ data_transformed <- reactive({ transform_data(section = "viz_transf", params = input, freq = ts_freq()) |> filter(between(date, input$date_range[1], input$date_range[2])) }) -``` - - -Row 1 {data-height=400} ---------------------------------------------------------------------------- -### {.no-padding} - -```{r} output$ts_plot_smooth <- renderPlotly({ data_transformed() |> timetk::plot_time_series( @@ -254,12 +249,7 @@ output$ts_plot_smooth <- renderPlotly({ .interactive = TRUE ) }) -plotlyOutput(outputId = "ts_plot_smooth") -``` - -### {.no-padding} -```{r} output$autocorr_plot <- renderPlotly({ data_transformed() |> timetk::plot_acf_diagnostics( @@ -269,16 +259,7 @@ output$autocorr_plot <- renderPlotly({ .title = "Autocorrelation", .y_lab = NULL, ) }) -plotlyOutput(outputId = "autocorr_plot") -``` - - -Row 2 {data-height=600} ---------------------------------------------------------------------------- -### {.no-padding} - -```{r} output$decomp_plot <- renderPlotly({ data_transformed() |> timetk::plot_stl_diagnostics( @@ -287,12 +268,7 @@ output$decomp_plot <- renderPlotly({ .title = "Decomposition" ) }) -plotlyOutput(outputId = "decomp_plot") -``` - -### {.no-padding} -```{r} output$season_plot <- renderPlotly({ data_transformed() |> timetk::plot_seasonal_diagnostics( @@ -300,6 +276,37 @@ output$season_plot <- renderPlotly({ .interactive = TRUE, .title = "Seasonality" ) }) +``` + + +Row 1 {data-height=400} +--------------------------------------------------------------------------- + +### {.no-padding} + +```{r} +plotlyOutput(outputId = "ts_plot_smooth") +``` + +### {.no-padding} + +```{r} +plotlyOutput(outputId = "autocorr_plot") +``` + + +Row 2 {data-height=600} +--------------------------------------------------------------------------- + +### {.no-padding} + +```{r} +plotlyOutput(outputId = "decomp_plot") +``` + +### {.no-padding} + +```{r} plotlyOutput(outputId = "season_plot") ``` @@ -338,15 +345,7 @@ observeEvent( data_cleaned <- reactive({ data_transformed() |> clean_data(params = input) }) -``` - -Row 1 {data-height=650} ---------------------------------------------------------------------------- - -### {.no-padding} - -```{r} output$anomaly_plot <- renderPlotly({ data_transformed() |> timetk::plot_anomaly_diagnostics( @@ -355,6 +354,24 @@ output$anomaly_plot <- renderPlotly({ .interactive = TRUE, .title = "Anomaly Plot", .legend_show = FALSE ) }) + +output$clean_plot <- renderPlotly({ + data_cleaned() |> + timetk::plot_time_series( + .date_var = date, .value = value, + .smooth = FALSE, .interactive = TRUE, + .title = "Cleaned Time Series" + ) +}) +``` + + +Row 1 {data-height=650} +--------------------------------------------------------------------------- + +### {.no-padding} + +```{r} plotlyOutput(outputId = "anomaly_plot") ``` @@ -365,14 +382,6 @@ Row 2 {data-height=350} ### {.no-padding} ```{r} -output$clean_plot <- renderPlotly({ - data_cleaned() |> - timetk::plot_time_series( - .date_var = date, .value = value, - .smooth = FALSE, .interactive = TRUE, - .title = "Cleaned Time Series" - ) -}) plotlyOutput(outputId = "clean_plot") ``` @@ -415,15 +424,7 @@ data_test <- reactive({ test_results <- reactive({ data_test() |> compute_hptests() }) -``` - -Row {data-height=500} ---------------------------------------------------------------------------- - -### - -```{r} output$test_table <- renderDT({ test_results() |> datatable( @@ -438,16 +439,7 @@ output$test_table <- renderDT({ rownames = FALSE ) }) -DTOutput(outputId = "test_table") -``` - - -Row {data-height=500} ---------------------------------------------------------------------------- - -### {.no-padding} -```{r} output$test_ts_plot <- renderPlotly({ data_test() |> timetk::plot_time_series( @@ -455,12 +447,7 @@ output$test_ts_plot <- renderPlotly({ .smooth = FALSE, .interactive = TRUE, .title = NULL ) }) -plotlyOutput(outputId = "test_ts_plot") -``` -### {.no-padding} - -```{r} output$test_autocorr_plot <- renderPlotly({ data_test() |> timetk::plot_acf_diagnostics( @@ -469,6 +456,31 @@ output$test_autocorr_plot <- renderPlotly({ .interactive = TRUE, .title = NULL, .y_lab = NULL ) }) +``` + + +Row {data-height=500} +--------------------------------------------------------------------------- + +### + +```{r} +DTOutput(outputId = "test_table") +``` + + +Row {data-height=500} +--------------------------------------------------------------------------- + +### {.no-padding} + +```{r} +plotlyOutput(outputId = "test_ts_plot") +``` + +### {.no-padding} + +```{r} plotlyOutput(outputId = "test_autocorr_plot") ``` @@ -525,7 +537,8 @@ pickerInput( `Time Series` = ts_methods, `Machine Learning` = ml_methods, `Deep Learning` = dl_methods, - `Mixed Algorithms` = mix_methods + `Mixed Algorithms` = mix_methods, + `Auto ML` = aml_methods ), selected = "Naive" ) @@ -774,6 +787,16 @@ conditionalPanel( numericInput(inputId = "prophet_boost_sample_size", label = "Sample Size", value = get_default("prophet_boost_sample_size"), min = 0, max = 1) ) +# H2O AutoML +conditionalPanel( + condition = "input.method == 'H2O AutoML'", + h5("Algorithm hyperparameters: "), + numericInput(inputId = "h2o_max_time", label = "Max Time (secs)", value = get_default("h2o_max_time"), min = 5, max = Inf, step = 1), + numericInput(inputId = "h2o_max_time_model", label = "Max Time per Model (secs)", value = get_default("h2o_max_time_model"), min = 5, max = Inf, step = 1), + sliderInput(inputId = "h2o_nfolds", label = "Folds", min = 2, max = 50, value = get_default("h2o_nfolds"), step = 1), + selectInput(inputId = "h2o_metric", label = "Metric", choices = metrics, selected = get_default("h2o_metric")) +) + # Coming Soon! conditionalPanel( condition = "input.method == 'COMING SOON!'", @@ -798,6 +821,58 @@ forecast_results <- eventReactive( ) } ) + +output$plot_test_forecast <- renderPlotly({ + forecast_results()$test_forecast |> + plot_modeltime_forecast(.legend_show = FALSE, .title = FALSE, .conf_interval_fill = "lightblue") +}) + +# output$plot_splits <- renderPlotly({ +# forecast_results()$splits |> +# tk_time_series_cv_plan() |> +# plot_time_series_cv_plan(date, value, .title = NULL, .legend_show = FALSE) +# }) + +output$plot_oos_forecast <- renderPlotly({ + forecast_results()$oos_forecast |> + plot_modeltime_forecast(.legend_show = FALSE, .title = FALSE, .conf_interval_fill = "lightblue") +}) + +output$accuracy_table <- renderDT({ + forecast_results()$accuracy |> + format_accuracy(single_method = TRUE) |> + datatable( + options = list( + ordering = FALSE, pageLength = 20, lengthChange = FALSE, searching = FALSE, + info = FALSE, paging = FALSE + ), + rownames = FALSE + ) +}) + +output$model_summary <- renderPrint({ + forecast_results()$fit +}) + +output$plot_resid_ts <- renderPlotly({ + forecast_results()$residuals |> + select(.index, .residuals) |> + set_names(c("date", "value")) |> + timetk::plot_time_series( + .date_var = date, .value = value, + .smooth = FALSE, .interactive = TRUE, .title = NULL + ) +}) + +output$plot_resid_acf <- renderPlotly({ + forecast_results()$residuals |> + select(.index, .residuals) |> + set_names(c("date", "value")) |> + timetk::plot_acf_diagnostics( + .date_var = date, .value = value, .lags = 60, + .interactive = TRUE, .title = NULL, .y_lab = NULL, + ) +}) ``` @@ -807,31 +882,18 @@ Row {data-height=500} ### Test Forecasts {.no-padding} ```{r} -output$plot_test_forecast <- renderPlotly({ - forecast_results()$test_forecast |> - plot_modeltime_forecast(.legend_show = FALSE, .title = FALSE, .conf_interval_fill = "lightblue") -}) plotlyOutput(outputId = "plot_test_forecast") ``` - - - - - ### Out-of-Sample Forecasts {.no-padding} ```{r} -output$plot_oos_forecast <- renderPlotly({ - forecast_results()$oos_forecast |> - plot_modeltime_forecast(.legend_show = FALSE, .title = FALSE, .conf_interval_fill = "lightblue") -}) plotlyOutput(outputId = "plot_oos_forecast") ``` @@ -842,56 +904,24 @@ Row {data-height=500} ### Evaluation Metrics {.no-padding} ```{r} -output$accuracy_table <- renderDT({ - forecast_results()$accuracy |> - format_accuracy(single_method = TRUE) |> - datatable( - options = list( - ordering = FALSE, pageLength = 20, lengthChange = FALSE, searching = FALSE, - info = FALSE, paging = FALSE - ), - rownames = FALSE - ) -}) DTOutput(outputId = "accuracy_table") ``` ### Algorithm Summary {.no-padding} ```{r} -output$model_summary <- renderPrint({ - forecast_results()$fit -}) verbatimTextOutput(outputId = "model_summary") ``` ### Residuals Time Plot {.no-padding} ```{r} -output$plot_resid_ts <- renderPlotly({ - forecast_results()$residuals |> - select(.index, .residuals) |> - set_names(c("date", "value")) |> - timetk::plot_time_series( - .date_var = date, .value = value, - .smooth = FALSE, .interactive = TRUE, .title = NULL - ) -}) plotlyOutput(outputId = "plot_resid_ts") ``` ### Residuals ACF {.no-padding} ```{r} -output$plot_resid_acf <- renderPlotly({ - forecast_results()$residuals |> - select(.index, .residuals) |> - set_names(c("date", "value")) |> - timetk::plot_acf_diagnostics( - .date_var = date, .value = value, .lags = 60, - .interactive = TRUE, .title = NULL, .y_lab = NULL, - ) -}) plotlyOutput(outputId = "plot_resid_acf") ``` @@ -930,7 +960,8 @@ pickerInput( `Time Series` = ts_methods, `Machine Learning` = ml_methods, `Deep Learning` = dl_methods, - `Mixed Algorithms` = mix_methods + `Mixed Algorithms` = mix_methods, + `Auto ML` = aml_methods ), selected = c("ETS", "SARIMA"), options = list("actions-box" = TRUE) ) @@ -971,6 +1002,33 @@ compare_results <- eventReactive( ) } ) + +output$plot_comp_test_forecast <- renderPlotly({ + compare_results()$test_forecast |> + plot_modeltime_forecast(.legend_show = TRUE, .title = FALSE, .conf_interval_fill = "lightblue") +}) + +output$plot_comp_oos_forecast <- renderPlotly({ + compare_results()$oos_forecast |> + plot_modeltime_forecast(.legend_show = TRUE, .title = FALSE, .conf_interval_fill = "lightblue") +}) + +output$comp_accuracy_table <- renderDT({ + compare_results()$accuracy |> + format_accuracy(single_method = FALSE) |> + filter(Type == "Test") |> + datatable( + options = list( + ordering = TRUE, pageLength = 6, lengthChange = FALSE, searching = FALSE, + info = FALSE, paging = FALSE, scrollCollapse = TRUE, scrollY = 300 + ), + rownames = FALSE + ) +}) + +output$comp_model_summary <- renderPrint({ + compare_results()$fit +}) ``` @@ -980,20 +1038,12 @@ Row {data-height=500} ### Test Forecasts {.no-padding} ```{r} -output$plot_comp_test_forecast <- renderPlotly({ - compare_results()$test_forecast |> - plot_modeltime_forecast(.legend_show = TRUE, .title = FALSE, .conf_interval_fill = "lightblue") -}) plotlyOutput(outputId = "plot_comp_test_forecast") ``` ### Out-of-Sample Forecasts {.no-padding} ```{r} -output$plot_comp_oos_forecast <- renderPlotly({ - compare_results()$oos_forecast |> - plot_modeltime_forecast(.legend_show = TRUE, .title = FALSE, .conf_interval_fill = "lightblue") -}) plotlyOutput(outputId = "plot_comp_oos_forecast") ``` @@ -1004,27 +1054,12 @@ Row {data-height=500} ### Evaluation Metrics {data-width=600 .no-padding} ```{r} -output$comp_accuracy_table <- renderDT({ - compare_results()$accuracy |> - format_accuracy(single_method = FALSE) |> - filter(Type == "Test") |> - datatable( - options = list( - ordering = TRUE, pageLength = 6, lengthChange = FALSE, searching = FALSE, - info = FALSE, paging = FALSE, scrollCollapse = TRUE, scrollY = 300 - ), - rownames = FALSE - ) -}) DTOutput(outputId = "comp_accuracy_table") ``` ### Algorithm Summary {data-width=400 .no-padding} ```{r} -output$comp_model_summary <- renderPrint({ - compare_results()$fit -}) verbatimTextOutput(outputId = "comp_model_summary") ``` @@ -1066,6 +1101,7 @@ dropdownButton( inputId = "tune_valid_metric", label = "Validation Metric", choices = metrics, selected = "RMSE" ), + awesomeCheckbox(inputId = "tune_bayes", label = "Use Bayes-Optim?", value = TRUE), sliderInput( inputId = "tune_grid_size", label = "Grid Size", value = 10, min = 1, max = 200, step = 10 @@ -1095,6 +1131,7 @@ observeEvent( updatePrettyRadioButtons(session = session, inputId = "tune_valid_type", selected = "Time Series CV") updateSliderInput(session = session, inputId = "tune_n_folds", value = 5) updateSelectInput(session = session, inputId = "tune_valid_metric", selected = "RMSE") + updateAwesomeCheckbox(session = session, inputId = "tune_bayes", value = TRUE) updateSliderInput(session = session, inputId = "tune_grid_size", value = 10) updateSelectInput(session = session, inputId = "tune_method", selected = "Elastic Net") updatePickerInput(session = session, inputId = "tune_elanet", selected = mtd_prm_names[["Elastic Net"]]) @@ -1273,7 +1310,8 @@ tune_results <- eventReactive( data = data_cleaned(), method = ., params = input, n_assess = input$tune_n_assess, assess_type = input$tune_assess_type, validation_type = input$tune_valid_type, n_folds = input$tune_n_folds, - validation_metric = input$tune_valid_metric, grid_size = input$tune_grid_size, + validation_metric = input$tune_valid_metric, + bayesian_optimization = input$tune_bayes, grid_size = input$tune_grid_size, seed = 1992 ) ) |> @@ -1283,6 +1321,58 @@ tune_results <- eventReactive( ) } ) + +output$plot_tune_test_forecast <- renderPlotly({ + tune_results()$test_forecast |> + plot_modeltime_forecast(.legend_show = FALSE, .title = FALSE, .conf_interval_fill = "lightblue") +}) + +# output$plot_tune_splits <- renderPlotly({ +# tune_results()$splits |> +# tk_time_series_cv_plan() |> +# plot_time_series_cv_plan(date, value, .title = NULL, .legend_show = FALSE) +# }) + +output$plot_tune_oos_forecast <- renderPlotly({ + tune_results()$oos_forecast |> + plot_modeltime_forecast(.legend_show = FALSE, .title = FALSE, .conf_interval_fill = "lightblue") +}) + +output$tune_accuracy_table <- renderDT({ + tune_results()$accuracy |> + format_accuracy(single_method = TRUE) |> + datatable( + options = list( + ordering = FALSE, pageLength = 20, lengthChange = FALSE, searching = FALSE, + info = FALSE, paging = FALSE + ), + rownames = FALSE + ) +}) + +output$tune_model_summary <- renderPrint({ + tune_results()$fit +}) + +output$plot_tune_resid_ts <- renderPlotly({ + tune_results()$residuals |> + select(.index, .residuals) |> + set_names(c("date", "value")) |> + timetk::plot_time_series( + .date_var = date, .value = value, + .smooth = FALSE, .interactive = TRUE, .title = NULL + ) +}) + +output$plot_tune_resid_acf <- renderPlotly({ + tune_results()$residuals |> + select(.index, .residuals) |> + set_names(c("date", "value")) |> + timetk::plot_acf_diagnostics( + .date_var = date, .value = value, .lags = 60, + .interactive = TRUE, .title = NULL, .y_lab = NULL, + ) +}) ``` @@ -1292,31 +1382,18 @@ Row {data-height=500} ### Test Forecasts {.no-padding} ```{r} -output$plot_tune_test_forecast <- renderPlotly({ - tune_results()$test_forecast |> - plot_modeltime_forecast(.legend_show = FALSE, .title = FALSE, .conf_interval_fill = "lightblue") -}) plotlyOutput(outputId = "plot_tune_test_forecast") ``` - - - - - - + ### Out-of-Sample Forecasts {.no-padding} ```{r} -output$plot_tune_oos_forecast <- renderPlotly({ - tune_results()$oos_forecast |> - plot_modeltime_forecast(.legend_show = FALSE, .title = FALSE, .conf_interval_fill = "lightblue") -}) plotlyOutput(outputId = "plot_tune_oos_forecast") ``` @@ -1327,56 +1404,24 @@ Row {data-height=500} ### Evaluation Metrics {.no-padding} ```{r} -output$tune_accuracy_table <- renderDT({ - tune_results()$accuracy |> - format_accuracy(single_method = TRUE) |> - datatable( - options = list( - ordering = FALSE, pageLength = 20, lengthChange = FALSE, searching = FALSE, - info = FALSE, paging = FALSE - ), - rownames = FALSE - ) -}) DTOutput(outputId = "tune_accuracy_table") ``` ### Algorithm Summary {.no-padding} ```{r} -output$tune_model_summary <- renderPrint({ - tune_results()$fit -}) verbatimTextOutput(outputId = "tune_model_summary") ``` ### Residuals Time Plot {.no-padding} ```{r} -output$plot_tune_resid_ts <- renderPlotly({ - tune_results()$residuals |> - select(.index, .residuals) |> - set_names(c("date", "value")) |> - timetk::plot_time_series( - .date_var = date, .value = value, - .smooth = FALSE, .interactive = TRUE, .title = NULL - ) -}) plotlyOutput(outputId = "plot_tune_resid_ts") ``` ### Residuals ACF {.no-padding} ```{r} -output$plot_tune_resid_acf <- renderPlotly({ - tune_results()$residuals |> - select(.index, .residuals) |> - set_names(c("date", "value")) |> - timetk::plot_acf_diagnostics( - .date_var = date, .value = value, .lags = 60, - .interactive = TRUE, .title = NULL, .y_lab = NULL, - ) -}) plotlyOutput(outputId = "plot_tune_resid_acf") ``` @@ -1415,7 +1460,8 @@ pickerInput( `Time Series` = ts_methods, `Machine Learning` = ml_methods, `Deep Learning` = dl_methods, - `Mixed Algorithms` = mix_methods + `Mixed Algorithms` = mix_methods, + `Auto ML` = aml_methods ), selected = c("ETS", "SARIMA"), multiple = TRUE, options = list( @@ -1476,6 +1522,33 @@ ensemble_results <- eventReactive( ) } ) + +output$plot_ens_test_forecast <- renderPlotly({ + ensemble_results()$test_forecast |> + plot_modeltime_forecast(.legend_show = TRUE, .title = FALSE, .conf_interval_fill = "lightblue") +}) + +output$plot_ens_oos_forecast <- renderPlotly({ + ensemble_results()$oos_forecast |> + plot_modeltime_forecast(.legend_show = TRUE, .title = FALSE, .conf_interval_fill = "lightblue") +}) + +output$ens_accuracy_table <- renderDT({ + ensemble_results()$accuracy |> + format_accuracy(single_method = FALSE) |> + filter(Type == "Test") |> + datatable( + options = list( + ordering = TRUE, pageLength = 6, lengthChange = FALSE, searching = FALSE, + info = FALSE, paging = FALSE, scrollCollapse = TRUE, scrollY = 300 + ), + rownames = FALSE + ) +}) + +output$ens_model_summary <- renderPrint({ + ensemble_results()$fit +}) ``` @@ -1485,20 +1558,12 @@ Row {data-height=500} ### Test Forecasts {.no-padding} ```{r} -output$plot_ens_test_forecast <- renderPlotly({ - ensemble_results()$test_forecast |> - plot_modeltime_forecast(.legend_show = TRUE, .title = FALSE, .conf_interval_fill = "lightblue") -}) plotlyOutput(outputId = "plot_ens_test_forecast") ``` ### Out-of-Sample Forecasts {.no-padding} ```{r} -output$plot_ens_oos_forecast <- renderPlotly({ - ensemble_results()$oos_forecast |> - plot_modeltime_forecast(.legend_show = TRUE, .title = FALSE, .conf_interval_fill = "lightblue") -}) plotlyOutput(outputId = "plot_ens_oos_forecast") ``` @@ -1509,27 +1574,12 @@ Row {data-height=500} ### Evaluation Metrics {data-width=600 .no-padding} ```{r} -output$ens_accuracy_table <- renderDT({ - ensemble_results()$accuracy |> - format_accuracy(single_method = FALSE) |> - filter(Type == "Test") |> - datatable( - options = list( - ordering = TRUE, pageLength = 6, lengthChange = FALSE, searching = FALSE, - info = FALSE, paging = FALSE, scrollCollapse = TRUE, scrollY = 300 - ), - rownames = FALSE - ) -}) DTOutput(outputId = "ens_accuracy_table") ``` ### Algorithm Summary {data-width=400 .no-padding} ```{r} -output$ens_model_summary <- renderPrint({ - ensemble_results()$fit -}) verbatimTextOutput(outputId = "ens_model_summary") ``` @@ -1568,7 +1618,8 @@ pickerInput( `Time Series` = ts_methods, `Machine Learning` = ml_methods, `Deep Learning` = dl_methods, - `Mixed Algorithms` = mix_methods + `Mixed Algorithms` = mix_methods, + `Auto ML` = aml_methods ), selected = "ETS" )