From 73f05e68c8b6a9ce6fcf1f8160a9bcac0c74e436 Mon Sep 17 00:00:00 2001
From: Mitchell <mail@mitchelloharawild.com>
Date: Fri, 10 Jul 2020 22:18:30 +1000
Subject: [PATCH] Added as_fable.forecast

Resolves #239
---
 NAMESPACE       |  1 +
 NEWS.md         |  2 ++
 R/fable.R       | 41 +++++++++++++++++++++++++++++++++++++++++
 man/as-fable.Rd |  8 ++++++++
 4 files changed, 52 insertions(+)

diff --git a/NAMESPACE b/NAMESPACE
index af10eb75..bdb33327 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -18,6 +18,7 @@ S3method(aggregate_key,tbl_ts)
 S3method(as_dable,tbl_df)
 S3method(as_dable,tbl_ts)
 S3method(as_fable,fbl_ts)
+S3method(as_fable,forecast)
 S3method(as_fable,grouped_df)
 S3method(as_fable,grouped_ts)
 S3method(as_fable,tbl_df)
diff --git a/NEWS.md b/NEWS.md
index bbf7a8a4..31ba7ad8 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -9,6 +9,8 @@
   always match regardless of the value used.
 * Using `summarise()` with a fable will now retain the fable class if the 
   distribution still exists under the same variable name.
+* Added `as_fable.forecast()` to convert forecast objects from the forecast
+  package to work with fable.
 * Documentation improvements
 * Performance improvements
 
diff --git a/R/fable.R b/R/fable.R
index 3cabe86c..2dc28f9e 100644
--- a/R/fable.R
+++ b/R/fable.R
@@ -79,6 +79,47 @@ as_fable.fbl_ts <- function(x, response, distribution, ...){
 #' @export
 as_fable.grouped_df <- as_fable.tbl_df
 
+#' @inheritParams forecast.mdl_df
+#' @rdname as-fable
+#' @export
+as_fable.forecast <- function(x, ..., point_forecast = list(.mean = mean)){
+  if(is.null(x$upper)){
+    # Without intervals, the best guess is the point forecast
+    dist <- distributional::dist_degenerate(x$mean)
+  } else {
+    if(!is.null(x$lambda)){
+      x$upper <- box_cox(x$upper, x$lambda)
+      x$lower <- box_cox(x$lower, x$lambda)
+    }
+    warn("Assuming intervals are computed from a normal distribution.")
+    level <- colnames(x$upper)[1]
+    level <- as.numeric(gsub("^[^0-9]+|%", "", level))/100
+    mid <- (x$upper[,1] - x$lower[,1])/2
+    mu <- x$lower[,1] + mid
+    sigma <- mid/(qnorm((1+level)/2))
+    dist <- distributional::dist_normal(mu = as.numeric(mu), sigma = as.numeric(sigma))
+    if(!is.null(x$lambda)){
+      dist <- distributional::dist_transformed(
+        dist, 
+        transform = purrr::partial(inv_box_cox, lambda = x$lambda), 
+        inverse = purrr::partial(box_cox, lambda = x$lambda)
+      )
+    }
+  }
+  out <- as_tsibble(x$mean)
+  dimnames(dist) <- "value"
+  out[["value"]] <- dist
+  
+  point_fc <- compute_point_forecasts(dist, point_forecast)
+  out[names(point_fc)] <- point_fc
+  
+  build_fable(
+    out,
+    response = "value",
+    distribution = "value"
+  )
+}
+
 build_fable <- function (x, response, distribution) {
   # If the response (from user input) needs converting
   response <- eval_tidy(enquo(response))
diff --git a/man/as-fable.Rd b/man/as-fable.Rd
index 457e534a..232f16b7 100644
--- a/man/as-fable.Rd
+++ b/man/as-fable.Rd
@@ -7,6 +7,7 @@
 \alias{as_fable.tbl_df}
 \alias{as_fable.fbl_ts}
 \alias{as_fable.grouped_df}
+\alias{as_fable.forecast}
 \title{Coerce to a fable object}
 \usage{
 as_fable(x, ...)
@@ -20,6 +21,8 @@ as_fable(x, ...)
 \method{as_fable}{fbl_ts}(x, response, distribution, ...)
 
 \method{as_fable}{grouped_df}(x, response, distribution, ...)
+
+\method{as_fable}{forecast}(x, ..., point_forecast = list(.mean = mean))
 }
 \arguments{
 \item{x}{Object to be coerced to a fable (\code{fbl_ts})}
@@ -30,6 +33,11 @@ as_fable(x, ...)
 
 \item{distribution}{The name of the distribution column (can be provided
 using a bare expression).}
+
+\item{point_forecast}{The point forecast measure(s) which should be returned
+in the resulting fable. Specified as a named list of functions which accept
+a distribution and return a vector. To compute forecast medians, you can use
+\code{list(.median = median)}.}
 }
 \description{
 Coerce to a fable object