tests/testthat/test-algo-prophet_boost.R

# ---- PROPHET BOOST ----
context("TEST prophet_boost: prophet_xgboost")


# SETUP ----

# Data
m750 <- m4_monthly %>% filter(id == "M750")

# Split Data 80/20
splits <- initial_time_split(m750, prop = 0.8)

# Model Spec
model_spec <- prophet_boost(
    growth                   = 'linear',
    changepoint_num          = 10,
    changepoint_range        = 0.75,
    seasonality_yearly       = TRUE,
    seasonality_weekly       = FALSE,
    seasonality_daily        = FALSE,
    season                   = 'multiplicative',
    prior_scale_changepoints = 20,
    prior_scale_seasonality  = 20,
    prior_scale_holidays     = 20,

    #xgboost
    mtry  = 25,
    trees = 250,
    min_n = 4,
    learn_rate = 0.1,
    tree_depth = 7,
    loss_reduction = 0.4,
    sample_size = 0.9
) %>%
    set_engine("prophet_xgboost")


# PARSNIP ----

# * NO XREGS ----

test_that("prophet_boost: No Xregs", {


    # ** MODEL FIT ----

    # Model Fit
    model_fit <- model_spec %>%
        fit(log(value) ~ date, data = training(splits))

    # Structure

    testthat::expect_s3_class(model_fit$fit, "prophet_xgboost_fit_impl")

    testthat::expect_s3_class(model_fit$fit$data, "tbl_df")

    testthat::expect_equal(names(model_fit$fit$data)[1], "date")

    testthat::expect_true(is.null(model_fit$fit$extras$xreg_recipe))

    # $fit PROPHET

    testthat::expect_s3_class(model_fit$fit$models$model_1, "prophet")

    testthat::expect_identical(model_fit$fit$models$model_1$growth, "linear")
    testthat::expect_identical(model_fit$fit$models$model_1$n.changepoints, 10)

    testthat::expect_identical(model_fit$fit$models$model_1$changepoint.range, 0.75)
    testthat::expect_identical(model_fit$fit$models$model_1$yearly.seasonality, TRUE)
    testthat::expect_identical(model_fit$fit$models$model_1$weekly.seasonality, FALSE)
    testthat::expect_identical(model_fit$fit$models$model_1$daily.seasonality, FALSE)

    testthat::expect_identical(model_fit$fit$models$model_1$seasonality.mode, 'multiplicative')
    testthat::expect_identical(model_fit$fit$models$model_1$seasonality.prior.scale, 20)
    testthat::expect_identical(model_fit$fit$models$model_1$changepoint.prior.scale, 20)
    testthat::expect_identical(model_fit$fit$models$model_1$holidays.prior.scale, 20)


    testthat::expect_identical(model_fit$fit$models$model_1$uncertainty.samples, 0)

    # $preproc

    testthat::expect_equal(model_fit$preproc$y_var, "value")


    # ** PREDICTIONS ----

    # Predictions
    predictions_tbl <- model_fit %>%
        modeltime_calibrate(testing(splits)) %>%
        modeltime_forecast(new_data = testing(splits))

    # Structure
    testthat::expect_identical(nrow(testing(splits)), nrow(predictions_tbl))
    testthat::expect_identical(testing(splits)$date, predictions_tbl$.index)

    # Out-of-Sample Accuracy Tests

    resid <- testing(splits)$value - exp(predictions_tbl$.value)

    # - Max Error less than 1500
    testthat::expect_lte(max(abs(resid)), 1500)

    # - MAE less than 700
    testthat::expect_lte(mean(abs(resid)), 700)

})

# * XREGS ----

test_that("prophet_boost: prophet, XREGS", {


    # ** MODEL FIT ----

    # Model Fit
    model_fit <- model_spec %>%
        fit(log(value) ~ date + as.numeric(date) + factor(month(date, label = TRUE), ordered = F),
            data = training(splits))

    # Structure

    testthat::expect_s3_class(model_fit$fit, "prophet_xgboost_fit_impl")

    testthat::expect_s3_class(model_fit$fit$data, "tbl_df")

    testthat::expect_equal(names(model_fit$fit$data)[1], "date")

    testthat::expect_true(!is.null(model_fit$fit$extras$xreg_recipe))

    # $fit PROPHET

    testthat::expect_s3_class(model_fit$fit$models$model_1, "prophet")

    testthat::expect_identical(model_fit$fit$models$model_1$growth, "linear")
    testthat::expect_identical(model_fit$fit$models$model_1$n.changepoints, 10)

    testthat::expect_identical(model_fit$fit$models$model_1$changepoint.range, 0.75)
    testthat::expect_identical(model_fit$fit$models$model_1$yearly.seasonality, TRUE)
    testthat::expect_identical(model_fit$fit$models$model_1$weekly.seasonality, FALSE)
    testthat::expect_identical(model_fit$fit$models$model_1$daily.seasonality, FALSE)

    testthat::expect_identical(model_fit$fit$models$model_1$seasonality.mode, 'multiplicative')
    testthat::expect_identical(model_fit$fit$models$model_1$seasonality.prior.scale, 20)
    testthat::expect_identical(model_fit$fit$models$model_1$changepoint.prior.scale, 20)
    testthat::expect_identical(model_fit$fit$models$model_1$holidays.prior.scale, 20)


    testthat::expect_identical(model_fit$fit$models$model_1$uncertainty.samples, 0)

    # $fit xgboost

    testthat::expect_s3_class(model_fit$fit$models$model_2, "xgb.Booster")

    testthat::expect_identical(model_fit$fit$models$model_2$params$eta, 0.1)

    testthat::expect_identical(model_fit$fit$models$model_2$params$max_depth, 7)

    testthat::expect_identical(model_fit$fit$models$model_2$params$gamma, 0.4)

    testthat::expect_identical(model_fit$fit$models$model_2$params$colsample_bytree, 1)

    testthat::expect_identical(model_fit$fit$models$model_2$params$min_child_weight, 4)

    testthat::expect_identical(model_fit$fit$models$model_2$params$subsample, 0.9)

    testthat::expect_identical(model_fit$fit$models$model_2$params$objective, "reg:squarederror")


    # $preproc

    testthat::expect_equal(model_fit$preproc$y_var, "value")


    # ** PREDICTIONS ----

    # Predictions
    predictions_tbl <- model_fit %>%
        modeltime_calibrate(testing(splits)) %>%
        modeltime_forecast(new_data = testing(splits))

    # Structure
    testthat::expect_identical(nrow(testing(splits)), nrow(predictions_tbl))
    testthat::expect_identical(testing(splits)$date, predictions_tbl$.index)

    # Out-of-Sample Accuracy Tests

    resid <- testing(splits)$value - exp(predictions_tbl$.value)

    # - Max Error less than 1500
    testthat::expect_lte(max(abs(resid)), 1500)

    # - MAE less than 700
    testthat::expect_lte(mean(abs(resid)), 700)

})


# ---- WORKFLOWS ----

# Recipe spec
recipe_spec <- recipe(value ~ date, data = training(splits)) %>%
    step_log(value, skip = FALSE) %>%
    step_date(date, features = "month") %>%
    step_mutate(date_num = as.numeric(date))

# Workflow
wflw <- workflow() %>%
    add_recipe(recipe_spec) %>%
    add_model(model_spec)





# TESTS
test_that("prophet_boost: prophet_xgboost (workflow)", {

    # Fitted Workflow
    wflw_fit <- wflw %>%
        fit(training(splits))


    # Structure

    testthat::expect_s3_class(wflw_fit$fit$fit$fit, "prophet_xgboost_fit_impl")

    testthat::expect_s3_class(wflw_fit$fit$fit$fit$data, "tbl_df")

    testthat::expect_equal(names(wflw_fit$fit$fit$fit$data)[1], "date")

    testthat::expect_true(!is.null(wflw_fit$fit$fit$fit$extras$xreg_recipe))

    # $fit prophet

    testthat::expect_s3_class(wflw_fit$fit$fit$fit$models$model_1, "prophet")

    testthat::expect_identical(wflw_fit$fit$fit$fit$models$model_1$growth, "linear")
    testthat::expect_identical(wflw_fit$fit$fit$fit$models$model_1$n.changepoints, 10)

    testthat::expect_identical(wflw_fit$fit$fit$fit$models$model_1$changepoint.range, 0.75)
    testthat::expect_identical(wflw_fit$fit$fit$fit$models$model_1$yearly.seasonality, TRUE)
    testthat::expect_identical(wflw_fit$fit$fit$fit$models$model_1$weekly.seasonality, FALSE)
    testthat::expect_identical(wflw_fit$fit$fit$fit$models$model_1$daily.seasonality, FALSE)

    testthat::expect_identical(wflw_fit$fit$fit$fit$models$model_1$seasonality.mode, 'multiplicative')
    testthat::expect_identical(wflw_fit$fit$fit$fit$models$model_1$seasonality.prior.scale, 20)
    testthat::expect_identical(wflw_fit$fit$fit$fit$models$model_1$changepoint.prior.scale, 20)
    testthat::expect_identical(wflw_fit$fit$fit$fit$models$model_1$holidays.prior.scale, 20)


    testthat::expect_identical(wflw_fit$fit$fit$fit$models$model_1$uncertainty.samples, 0)

    # $fit xgboost

    testthat::expect_s3_class(wflw_fit$fit$fit$fit$models$model_2, "xgb.Booster")

    testthat::expect_identical(wflw_fit$fit$fit$fit$models$model_2$params$eta, 0.1)

    testthat::expect_identical(wflw_fit$fit$fit$fit$models$model_2$params$max_depth, 7)

    testthat::expect_identical(wflw_fit$fit$fit$fit$models$model_2$params$gamma, 0.4)

    testthat::expect_identical(wflw_fit$fit$fit$fit$models$model_2$params$colsample_bytree, 1)

    testthat::expect_identical(wflw_fit$fit$fit$fit$models$model_2$params$min_child_weight, 4)

    testthat::expect_identical(wflw_fit$fit$fit$fit$models$model_2$params$subsample, 0.9)

    testthat::expect_identical(wflw_fit$fit$fit$fit$models$model_2$params$objective, "reg:squarederror")


    # $preproc
    mld <- wflw_fit %>% workflows::pull_workflow_mold()
    testthat::expect_equal(names(mld$outcomes), "value")


    # ** PREDICTIONS ----

    # Forecast
    predictions_tbl <- wflw_fit %>%
        modeltime_calibrate(testing(splits)) %>%
        modeltime_forecast(new_data = testing(splits), actual_data = training(splits)) %>%
        mutate_at(vars(.value), exp)

    full_data <- bind_rows(training(splits), testing(splits))

    # Structure
    testthat::expect_identical(nrow(full_data), nrow(predictions_tbl))
    testthat::expect_identical(full_data$date, predictions_tbl$.index)

    # Out-of-Sample Accuracy Tests
    predictions_tbl <- predictions_tbl %>% filter(.key == "prediction")
    resid <- testing(splits)$value - predictions_tbl$.value

    # - Max Error less than 1500
    testthat::expect_lte(max(abs(resid)), 1500)

    # - MAE less than 700
    testthat::expect_lte(mean(abs(resid)), 700)

})

# LOGISTIC GROWTH ----

# * MODELS ----

test_that("prophet_reg: prophet, Logistic Growth", {


    # ** MODEL FIT ----

    # Model Fit
    model_fit <- prophet_boost(
        growth = "logistic",
        logistic_cap = 11000,
        seasonality_yearly = FALSE,
        seasonality_weekly = FALSE,
        seasonality_daily  = FALSE
    ) %>%
        set_engine(engine = "prophet_xgboost") %>%
        fit(value ~ date
            + as.numeric(date)
            + month(date, label = TRUE)
            + fourier_vec(date, period = 12),
            data = m750)

    # Structure

    testthat::expect_s3_class(model_fit$fit, "prophet_xgboost_fit_impl")

    testthat::expect_s3_class(model_fit$fit$data, "tbl_df")

    testthat::expect_equal(names(model_fit$fit$data)[1], "date")

    testthat::expect_false(is.null(model_fit$fit$extras$logistic_params$logistic_cap))

    # $fit PROPHET

    testthat::expect_s3_class(model_fit$fit$models$model_1, "prophet")

    testthat::expect_identical(model_fit$fit$models$model_1$growth, "logistic")

    testthat::expect_identical(model_fit$fit$extras$logistic_params$growth, "logistic")
    testthat::expect_identical(model_fit$fit$extras$logistic_params$logistic_cap, 11000)
    testthat::expect_true(is.null(model_fit$fit$extras$logistic_params$logistic_floor))

    # $preproc

    testthat::expect_equal(model_fit$preproc$y_var, "value")


    # ** PREDICTIONS ----
    forecast_prophet_logisitic <- modeltime_table(
        model_fit
    ) %>%
        modeltime_forecast(
            h = 12 * 10,
            actual_data = m750
        ) %>%
        filter(.model_desc != "ACTUAL")

    expect_lte(
        forecast_prophet_logisitic$.value %>% max(),
        11500
    )

    # ERROR IF CAP/FLOOR NOT SPECIFIED

    expect_error({
        prophet_boost(
            growth = "logistic"
        ) %>%
            set_engine(engine = "prophet_xgboost") %>%
            fit(value ~ date, m750)
    })

})

Try the modeltime package in your browser

Any scripts or data that you put into this service are public.

modeltime documentation built on Sept. 15, 2021, 1:06 a.m.