Added conditional seasonality for R (#894)

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.

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)
     )

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)

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(

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()