From 0092638abe60a97c1aea85c5fe047450b7920490 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Olof=20H=C3=B6jvall?= Date: Fri, 22 Mar 2019 18:43:52 +0100 Subject: [PATCH] Added conditional seasonality for R (#894) --- R/R/diagnostics.R | 6 ++++ R/R/plot.R | 47 +++++++++++++++++++++-------- R/R/prophet.R | 40 ++++++++++++++++++++---- R/tests/testthat/test_diagnostics.R | 4 +++ R/tests/testthat/test_prophet.R | 40 ++++++++++++++++++++++++ 5 files changed, 118 insertions(+), 19 deletions(-) diff --git a/R/R/diagnostics.R b/R/R/diagnostics.R index 60a3728..13f6b2e 100644 --- a/R/R/diagnostics.R +++ b/R/R/diagnostics.R @@ -108,6 +108,12 @@ cross_validation <- function( } } columns <- c(columns, names(m$extra_regressors)) + for (name in names(m$seasonalities)) { + condition.name = m$seasonalities[[name]]$condition.name + if (!is.null(condition.name)) { + columns <- c(columns, condition.name) + } + } future <- df.predict[columns] yhat <- stats::predict(m, future) # Merge yhat, y, and cutoff. diff --git a/R/R/plot.R b/R/R/plot.R index b2a5e48..aad4e9e 100644 --- a/R/R/plot.R +++ b/R/R/plot.R @@ -116,7 +116,15 @@ prophet_plot_components <- function( for (name in sort(names(m$seasonalities))) { if (!(name %in% c('weekly', 'yearly')) && (name %in% colnames(fcst))) { - panels[[length(panels) + 1]] <- plot_seasonality(m, name, uncertainty) + if (m$seasonalities[[name]]$period == 7) { + panels[[length(panels) + 1]] <- plot_weekly(m, uncertainty, + weekly_start, name) + } else if (m$seasonalities[[name]]$period == 365.25) { + panels[[length(panels) + 1]] <- plot_yearly(m, uncertainty, + yearly_start, name) + } else { + panels[[length(panels) + 1]] <- plot_seasonality(m, name, uncertainty) + } } } # Plot extra regressors @@ -201,6 +209,13 @@ seasonality_plot_df <- function(m, ds) { for (name in names(m$extra_regressors)) { df_list[[name]] <- 0 } + # Activate all conditional seasonality columns + for (name in names(m$seasonalities)) { + condition.name = m$seasonalities[[name]]$condition.name + if (!is.null(condition.name)) { + df_list[[condition.name]] <- TRUE + } + } df <- as.data.frame(df_list) df <- setup_dataframe(m, df)$df return(df) @@ -213,11 +228,14 @@ seasonality_plot_df <- function(m, ds) { #' @param weekly_start Integer specifying the start day of the weekly #' seasonality plot. 0 (default) starts the week on Sunday. 1 shifts by 1 day #' to Monday, and so on. +#' @param name Name of seasonality component if previously changed +#' from default 'weekly'. #' #' @return A ggplot2 plot. #' #' @keywords internal -plot_weekly <- function(m, uncertainty = TRUE, weekly_start = 0) { +plot_weekly <- function(m, uncertainty = TRUE, weekly_start = 0, + name = 'weekly') { # Compute weekly seasonality for a Sun-Sat sequence of dates. days <- seq(set_date('2017-01-01'), by='d', length.out=7) + as.difftime( weekly_start, units = "days") @@ -225,19 +243,19 @@ plot_weekly <- function(m, uncertainty = TRUE, weekly_start = 0) { seas <- predict_seasonal_components(m, df.w) seas$dow <- factor(weekdays(df.w$ds), levels=weekdays(df.w$ds)) - gg.weekly <- ggplot2::ggplot(seas, ggplot2::aes(x = dow, y = weekly, - group = 1)) + + gg.weekly <- ggplot2::ggplot( + seas, ggplot2::aes_string(x = 'dow', y = name, group = 1)) + ggplot2::geom_line(color = "#0072B2", na.rm = TRUE) + ggplot2::labs(x = "Day of week") if (uncertainty) { gg.weekly <- gg.weekly + - ggplot2::geom_ribbon(ggplot2::aes(ymin = weekly_lower, - ymax = weekly_upper), + ggplot2::geom_ribbon(ggplot2::aes_string(ymin = paste0(name, '_lower'), + ymax = paste0(name, '_upper')), alpha = 0.2, fill = "#0072B2", na.rm = TRUE) } - if (m$seasonalities$weekly$mode == 'multiplicative') { + if (m$seasonalities[[name]]$mode == 'multiplicative') { gg.weekly <- ( gg.weekly + ggplot2::scale_y_continuous(labels = scales::percent) ) @@ -252,11 +270,14 @@ plot_weekly <- function(m, uncertainty = TRUE, weekly_start = 0) { #' @param yearly_start Integer specifying the start day of the yearly #' seasonality plot. 0 (default) starts the year on Jan 1. 1 shifts by 1 day #' to Jan 2, and so on. +#' @param name Name of seasonality component if previously changed +#' from default 'yearly'. #' #' @return A ggplot2 plot. #' #' @keywords internal -plot_yearly <- function(m, uncertainty = TRUE, yearly_start = 0) { +plot_yearly <- function(m, uncertainty = TRUE, yearly_start = 0, + name = 'yearly') { # Compute yearly seasonality for a Jan 1 - Dec 31 sequence of dates. days <- seq(set_date('2017-01-01'), by='d', length.out=365) + as.difftime( yearly_start, units = "days") @@ -264,20 +285,20 @@ plot_yearly <- function(m, uncertainty = TRUE, yearly_start = 0) { seas <- predict_seasonal_components(m, df.y) seas$ds <- df.y$ds - gg.yearly <- ggplot2::ggplot(seas, ggplot2::aes(x = ds, y = yearly, - group = 1)) + + gg.yearly <- ggplot2::ggplot( + seas, ggplot2::aes_string(x = 'ds', y = name, group = 1)) + ggplot2::geom_line(color = "#0072B2", na.rm = TRUE) + ggplot2::labs(x = "Day of year") + ggplot2::scale_x_datetime(labels = scales::date_format('%B %d')) if (uncertainty) { gg.yearly <- gg.yearly + - ggplot2::geom_ribbon(ggplot2::aes(ymin = yearly_lower, - ymax = yearly_upper), + ggplot2::geom_ribbon(ggplot2::aes_string(ymin = paste0(name, '_lower'), + ymax = paste0(name, '_upper')), alpha = 0.2, fill = "#0072B2", na.rm = TRUE) } - if (m$seasonalities$yearly$mode == 'multiplicative') { + if (m$seasonalities[[name]]$mode == 'multiplicative') { gg.yearly <- ( gg.yearly + ggplot2::scale_y_continuous(labels = scales::percent) ) diff --git a/R/R/prophet.R b/R/R/prophet.R index 17e44f2..591fd16 100644 --- a/R/R/prophet.R +++ b/R/R/prophet.R @@ -363,7 +363,19 @@ setup_dataframe <- function(m, df, initialize_scales = FALSE) { stop('Found NaN in column ', name) } } - + for (name in names(m$seasonalities)) { + condition.name = m$seasonalities[[name]]$condition.name + if (!is.null(condition.name)) { + if (!(condition.name %in% colnames(df))) { + stop('Condition "', name, '" missing from dataframe') + } + if(!all(df[[condition.name]] %in% c(FALSE,TRUE))) { + stop('Found non-boolean in column ', name) + } + df[[condition.name]] <- as.logical(df[[condition.name]]) + } + } + df <- df %>% dplyr::arrange(ds) @@ -714,6 +726,10 @@ add_regressor <- function( #' specified, m$seasonality.mode will be used (defaults to 'additive'). #' Additive means the seasonality will be added to the trend, multiplicative #' means it will multiply the trend. +#' +#' If condition.name is provided, the dataframe passed to `fit` and `predict` +#' should have a column with the specified condition.name containing booleans +#' which decides when to apply seasonality. #' #' @param m Prophet object. #' @param name String name of the seasonality component. @@ -721,12 +737,14 @@ add_regressor <- function( #' @param fourier.order Int number of Fourier components to use. #' @param prior.scale Optional float prior scale for this component. #' @param mode Optional 'additive' or 'multiplicative'. +#' @param condition.name String name of the seasonality condition. #' #' @return The prophet model with the seasonality added. #' #' @export add_seasonality <- function( - m, name, period, fourier.order, prior.scale = NULL, mode = NULL + m, name, period, fourier.order, prior.scale = NULL, mode = NULL, + condition.name = NULL ) { if (!is.null(m$history)) { stop("Seasonality must be added prior to model fitting.") @@ -749,11 +767,15 @@ add_seasonality <- function( if (!(mode %in% c('additive', 'multiplicative'))) { stop("mode must be 'additive' or 'multiplicative'") } + if (!is.null(condition.name)) { + validate_column_name(m, condition.name) + } m$seasonalities[[name]] <- list( period = period, fourier.order = fourier.order, prior.scale = ps, - mode = mode + mode = mode, + condition.name = condition.name ) return(m) } @@ -825,6 +847,9 @@ make_all_seasonality_features <- function(m, df) { props <- m$seasonalities[[name]] features <- make_seasonality_features( df$ds, props$period, props$fourier.order, name) + if (!is.null(props$condition.name)) { + features[!df[[props$condition.name]],] <- 0 + } seasonal.features <- cbind(seasonal.features, features) prior.scales <- c(prior.scales, props$prior.scale * rep(1, ncol(features))) @@ -1026,7 +1051,8 @@ set_auto_seasonalities <- function(m) { period = 365.25, fourier.order = fourier.order, prior.scale = m$seasonality.prior.scale, - mode = m$seasonality.mode + mode = m$seasonality.mode, + condition.name = NULL ) } @@ -1038,7 +1064,8 @@ set_auto_seasonalities <- function(m) { period = 7, fourier.order = fourier.order, prior.scale = m$seasonality.prior.scale, - mode = m$seasonality.mode + mode = m$seasonality.mode, + condition.name = NULL ) } @@ -1050,7 +1077,8 @@ set_auto_seasonalities <- function(m) { period = 1, fourier.order = fourier.order, prior.scale = m$seasonality.prior.scale, - mode = m$seasonality.mode + mode = m$seasonality.mode, + condition.name = NULL ) } return(m) diff --git a/R/tests/testthat/test_diagnostics.R b/R/tests/testthat/test_diagnostics.R index 36c93fa..f0e26e3 100644 --- a/R/tests/testthat/test_diagnostics.R +++ b/R/tests/testthat/test_diagnostics.R @@ -55,8 +55,12 @@ test_that("cross_validation_extra_regressors", { skip_if_not(Sys.getenv('R_ARCH') != '/i386') df <- DATA df$extra <- seq(0, nrow(df) - 1) + df$is_conditional_week <- seq(0, nrow(df) - 1) %/% 7 %% 2 m <- prophet() m <- add_seasonality(m, name = 'monthly', period = 30.5, fourier.order = 5) + m <- add_seasonality(m, name = 'conditional_weekly', period = 7, + fourier.order = 3, prior.scale = 2., + condition.name = 'is_conditional_week') m <- add_regressor(m, 'extra') m <- fit.prophet(m, df) df.cv <- cross_validation( diff --git a/R/tests/testthat/test_prophet.R b/R/tests/testthat/test_prophet.R index 0972125..2dd4af0 100644 --- a/R/tests/testthat/test_prophet.R +++ b/R/tests/testthat/test_prophet.R @@ -548,6 +548,46 @@ test_that("custom_seasonality", { expect_true(all(prior.scales == c(rep(2, 10), rep(10, 6), 4))) }) +test_that("conditional_custom_seasonality", { + skip_if_not(Sys.getenv('R_ARCH') != '/i386') + m <- prophet(weekly_seasonality=FALSE, yearly_seasonality=FALSE) + m <- add_seasonality(m, name='conditional_weekly', period=7, fourier.order=3, + prior.scale=2., condition.name='is_conditional_week') + m <- add_seasonality(m, name='normal_monthly', period=30.5, fourier.order=5, + prior.scale=2.) + df <- DATA + # Require all conditions names in df + expect_error( + fit.prophet(m, df) + ) + df$is_conditional_week <- c(rep(0, 255), rep(2, 255)) + # Require boolean compatible values + expect_error( + fit.prophet(m, df) + ) + df$is_conditional_week <- c(rep(0, 255), rep(1, 255)) + fit.prophet(m, df) + true <- list( + period = 7, fourier.order = 3, prior.scale = 2., mode = 'additive', + condition.name = 'is_conditional_week') + for (name in names(true)) { + expect_equal(m$seasonalities[['conditional_weekly']][[name]], true[[name]]) + } + expect_equal( + m$seasonalities[['normal_monthly']]$condition.name, NULL + ) + out <- prophet:::make_all_seasonality_features(m, df) + #Confirm that only values without is_conditional_week has non zero entries + nonzero.weekly = out$seasonal.features %>% + dplyr::select(dplyr::starts_with('conditional_weekly')) %>% + dplyr::mutate_all(~ . != 0) %>% + dplyr::mutate(nonzero = rowSums(. != 0) > 0) %>% + dplyr::pull(nonzero) + expect_equal( + nonzero.weekly, as.logical(df$is_conditional_week) + ) +}) + test_that("added_regressors", { skip_if_not(Sys.getenv('R_ARCH') != '/i386') m <- prophet()