version 0.3.4

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: fabletools
 Title: Core Tools for Packages in the 'fable' Framework
-Version: 0.3.3
+Version: 0.3.4
 Authors@R: 
     c(person(given = "Mitchell",
              family = "O'Hara-Wild",
@@ -46,7 +46,7 @@ Encoding: UTF-8
 Language: en-GB
 RoxygenNote: 7.2.3
 NeedsCompilation: no
-Packaged: 2023-04-04 13:19:04 UTC; mitchell
+Packaged: 2023-10-11 22:19:46 UTC; mitchell
 Author: Mitchell O'Hara-Wild [aut, cre]
     (<https://orcid.org/0000-0001-6729-7695>),
   Rob Hyndman [aut],
@@ -56,4 +56,4 @@ Author: Mitchell O'Hara-Wild [aut, cre]
   David Holt [ctb]
 Maintainer: Mitchell O'Hara-Wild <mail@mitchelloharawild.com>
 Repository: CRAN
-Date/Publication: 2023-04-04 14:10:02 UTC
+Date/Publication: 2023-10-11 22:40:02 UTC

MD5

@@ -1,8 +1,8 @@
-bf8c55dce91e2adc0b0fb36841a4f3a1 *DESCRIPTION
-cbeabfe086ff23f01b9d59a188fe3efc *NAMESPACE
-2ef8eb1171e0b6849ccbc8075915cfe1 *NEWS.md
+b92ac3c7fe85d07e97db07e4dbfad422 *DESCRIPTION
+d81b95cc2dfb9d0bbeafbe5bd53f741f *NAMESPACE
+cc8cb1d9c9c2702901df88c7a7c1d69e *NEWS.md
 6818752e746ee789976f6a5fc64f4aac *R/accessors.R
-df68eb2bebf25663288916f5d91dab30 *R/accuracy.R
+f625d4399c57190cf6884d66ef627220 *R/accuracy.R
 37b47c2ba9cd1581c87da98367e52dd1 *R/aggregate.R
 43196b3a91f03002efa4e99f6a94ce8c *R/box_cox.R
 905500e19ecb80cb92ca9e328f195949 *R/broom.R
@@ -31,13 +31,13 @@ ec7eb945353800bd0a071b15a124538f *R/lst_mdl.R
 6cae1fdb6734995e8625daba498c6297 *R/mdl_ts.R
 ea1d9ad7b329da5b73adaba42b384fc3 *R/model.R
 cfa096eebc6da8b157da7bdd1f951ff5 *R/model_combination.R
-24ef7c0858e1dbf67b37d603fff4fcdc *R/model_decomposition.R
+0908b1be00a0a52dccb62199b9077da0 *R/model_decomposition.R
 df6f7d3d9bcc6fc1a989f7d821aef85c *R/model_null.R
 200ccace4ef4ea1dd983923c1d85cf1a *R/outliers.R
-5a0fa670b04e435fc694c7e05bfe121f *R/parse.R
-36cb1535dd6a82ce70f13b71dbff8ddb *R/plot.R
-d45bc948e3b58eb04b0557c128eff344 *R/reconciliation.R
-07cb8d8d11f2b248bbc25bace1c587a6 *R/reexports.R
+b8900f6ace1f6821330f9ea0d7895d96 *R/parse.R
+b57d7eda03aa3bf174ea9c39c60b42ea *R/plot.R
+eaa9d2eb11683a1ad9302fad722d08a6 *R/reconciliation.R
+78a218157cb64bbfb7d306cbdcf181da *R/reexports.R
 6bdb5113dd636553aac1aa541cbafb7b *R/refit.R
 2ca682e8231f7f02cae0fa4128a134bc *R/report.R
 769ed22fb489b0d681c816b58705f808 *R/residuals.R
@@ -55,14 +55,14 @@ aa2d52dbd3b07f0063bcecf1b0557eb9 *R/utils.R
 30c5b8e6b71fb0ca86f7d23370e24c7a *R/xregs.R
 9eed4b755fab99446a41a2bb44576600 *R/zzz.R
 2aa1613e174051158427cbdb49f32e76 *README.md
-553a1bf40ee979361a0d288565abc837 *build/fabletools.pdf
+278432c795b7edcf701f3f31bfe08654 *build/fabletools.pdf
 d177c79522b967ca3fa9606cbe566aed *build/vignette.rds
 184cc9e74fa8f1bd6683d0ff42ed2ded *inst/WORDLIST
-7bab195f754cc0017bd80d6b93536606 *inst/doc/extension_models.R
+21cda36b936f1f388eda39e59d6e611a *inst/doc/extension_models.R
 5a159266a4d4a7fc70c5e5702e4ccd9c *inst/doc/extension_models.Rmd
-87b0bd22764a2397de1d4fa5cf39448a *inst/doc/extension_models.html
+21d6d3e6eb4e0f4f8b2ff67858d2439f *inst/doc/extension_models.html
 cff23ee87902f0ba1c751ada29f20fc2 *man/MAAPE.Rd
-43aa0440d1cdc453de0081523bcce21a *man/accuracy.Rd
+91c4f419991ef376e144cc6bd8f0637d *man/accuracy.Rd
 d2fa9e9eb9773e7276e81d28dcdbb3e8 *man/agg_vec.Rd
 2641dbfbc7716d80b7629e133672ee0b *man/aggregate_index.Rd
 1bf4afbee45329236944d971db31fd6e *man/aggregate_key.Rd
@@ -141,7 +141,7 @@ fd11d262287dcffaedb4719e387c59ab *man/outliers.Rd
 6447d28ea570f4205ac3f04163adac9f *man/parse_model_rhs.Rd
 474792508988b76d6d1ae9ee579932cd *man/point_accuracy_measures.Rd
 cb19f90ef22302afe188ec08c93fad05 *man/reconcile.Rd
-f2665c9370d8cb70efc4a2afdf5d607f *man/reexports.Rd
+5ed9e39096f8255deb1c49aabd17f8c3 *man/reexports.Rd
 d626054ca8d93616014cad7ea95ed1b2 *man/refit.Rd
 7f923d344b049883e5ada968e6330f52 *man/register_feature.Rd
 fe74782d2d7a04c98808abda763e18ff *man/report.Rd
@@ -158,7 +158,7 @@ a51f43537bddd5e20fc9206074bf59e0 *man/scenarios.Rd
 7b39011fba1ee026be22079891a239c6 *man/unpack_hilo.Rd
 bd30a92d003b45262251d14c254332a4 *man/validate_formula.Rd
 8176e3fbb47046d5f7220e147a102483 *tests/testthat.R
-f65b4e5809a19d56d61b0ef1e137cc60 *tests/testthat/Rplots.pdf
+6a84e097debdb9c90fec5955d9b46e27 *tests/testthat/Rplots.pdf
 d086dba90b013cec5dda344fb7938612 *tests/testthat/setup-data.R
 b93b054b076aba90b60d8f5a0fd9198d *tests/testthat/setup-models.R
 6b683cb35b10e316ea6f1d5bcbf69b40 *tests/testthat/test-accuracy.R

NAMESPACE

@@ -346,6 +346,7 @@ importFrom(dplyr,summarise)
 importFrom(dplyr,transmute)
 importFrom(dplyr,ungroup)
 importFrom(dplyr,vars)
+importFrom(generics,accuracy)
 importFrom(generics,augment)
 importFrom(generics,components)
 importFrom(generics,equation)

NEWS.md

@@ -1,3 +1,23 @@
+# fabletools 0.3.4
+
+## New features
+
+* The formula parser now identifies and stores length 1 values in the 
+  transformation environment. This simplifies common tasks like automatic
+  box-cox parameters for each series, which can now be done with
+  `fable::ARIMA(box_cox(y, feasts::guerrero(y)))`.
+
+## Improvements
+
+* Added support for visualising different point forecasts (say means and medians)
+  when only one forecast is to be plotted for each series.
+
+## Bug fixes
+* Resolved issue with `autoplot(<fbl_ts>)` not identifying multiple point 
+  forecasts by `linetype`.
+* Fix for indexing of bottom series in `top_down()` and `middle_out()`
+  reconciliation methods (#362, #364 @FedericoGarza)
+
 # fabletools 0.3.3
 
 ## Improvements

R/accuracy.R

@@ -413,20 +413,12 @@ skill_score <- function(measure) {
 #' used to train the model.
 #' 
 #' @param object A model or forecast object
+#' @param measures A list of accuracy measure functions to compute (such as [`point_accuracy_measures`], [`interval_accuracy_measures`], or [`distribution_accuracy_measures`])
 #' @param ... Additional arguments to be passed to measures that use it.
 #' 
 #' @seealso 
 #' [Evaluating forecast accuracy](https://otexts.com/fpp3/accuracy.html)
 #' 
-#' @export
-accuracy <- function(object, ...){
-  UseMethod("accuracy")
-}
-
-#' @rdname accuracy
-#' 
-#' @param measures A list of accuracy measure functions to compute (such as [`point_accuracy_measures`], [`interval_accuracy_measures`], or [`distribution_accuracy_measures`])
-#' 
 #' @examplesIf requireNamespace("fable", quietly = TRUE) && requireNamespace("tsibbledata", quietly = TRUE)
 #' library(fable)
 #' library(tsibble)
@@ -456,6 +448,7 @@ accuracy <- function(object, ...){
 #'     measures = list(interval_accuracy_measures, distribution_accuracy_measures)
 #'   )
 #' 
+#' @rdname accuracy
 #' @export
 accuracy.mdl_df <- function(object, measures = point_accuracy_measures, ...){
   if(is_tsibble(measures)){
@@ -468,6 +461,7 @@ Hint: A tsibble of future values is only required when computing accuracy of a f
     unnest_tbl("fit")
 }
 
+#' @rdname accuracy
 #' @export
 accuracy.mdl_ts <- function(object, measures = point_accuracy_measures, ...){
   dots <- dots_list(...)

R/model_decomposition.R

@@ -107,7 +107,7 @@ Please check that you have specified the decomposition models appropriately.")
 #'   components() %>% 
 #'   autoplot()
 #'   
-#' # Use an ARIMA model to seasonally adjusted data, and SNAIVE to season_year
+#' # Use an ETS model to seasonally adjusted data, and SNAIVE to season_year
 #' # Any model can be used, and seasonal components will default to use SNAIVE.
 #' my_dcmp_spec <- decomposition_model(
 #'   STL(log(Turnover) ~ season(window = Inf)),

R/parse.R

@@ -131,101 +131,146 @@ parse_model_lhs <- function(model){
 
   # Traverse call removing all resp() usage
   # This is used to evaluate the response from the input data
-  response_exprs <- lapply(model_lhs, traverse,
-                           .f = function(x, y) {
-                             if(is_resp(y)) x[[1]] else call2(call_name(y), !!!x)
-                           },
-                           .g = function(x) x[-1],
-                           # .h = function(x) if(is_resp(x)) x[[length(x)]] else x,
-                           base = function(x) is_syntactic_literal(x) || is_symbol(x)
+  response_exprs <- lapply(
+    model_lhs, traverse,
+    .f = function(x, y) {
+      if(is_resp(y)) x[[1]] else call2(y[[1]], !!!x)
+    },
+    .g = function(x) x[-1],
+    # .h = function(x) if(is_resp(x)) x[[length(x)]] else x,
+    base = function(x) is_syntactic_literal(x) || is_symbol(x)
   )
 
-  # Traverse call to parse out AST for transformations
-  traversed_lhs <- lapply(model_lhs, traverse,
-     .f = function(x, y) {
-       if(any(resp_pos <- map_lgl(x, function(x) any(names(x) %in% "response")))){
-         if(sum(resp_pos) != 1) abort("The `resp()` function can only be used once per response variable. For multivariate modelling, use `vars()`.")
-         names(x)[resp_pos] <- "response"
-       }
-       `attr<-`(x, "call", y[[1]])
-     },
-     .g = function(x) x[-1],
-     .h = function(x) {
-       if(is_resp(x)){
-         if(length(x) > 2) abort("The response variable accepts only one input. For multivariate modelling, use `vars()`.")
-         list(response = x)
-       } else list(x)
-     },
-     base = function(x) is_syntactic_literal(x) || is_symbol(x) || is_resp(x)
+  has_resp <- function(x) traverse(
+    x,
+    .f = function(x,y) x[[1]]||y, .g = function(x) x[-1], .h = is_resp,
+    base = function(x) is_syntactic_literal(x) || is_symbol(x)
   )
 
-  # Reduce traversal down to the response
+  # Traverse call AST to parse out order of transformations
+  #
   # If the response is set via resp(), remove all usage of resp() from the traversal
   # If the response is not set via resp(), identify the response by the maximum length object until encountering ties
-  traversed_lhs <- lapply(traversed_lhs, traverse,
-    .f = function(x, y){
-      # Capture parent expression of base case
-      cl <- NULL
-      if(length(x) == 0){
-        # Multiple length `n` variables found and cannot disambiguate response
-        # Start with most disaggregated result of computation as response.
-        x <- if(is.null(attr(y, "call"))) list(y[[1]]) else syms(as_label(attr(y, "call")))
-      }
-      else{
-        if(is.null(attr(y, "call"))){
-          if(is_resp(x[[1]])){
-            x[[1]] <- x[[1]][[2]]
+  # 
+  # Returns a list of increasing depth of transformations
+  traversed_lhs <- lapply(model_lhs, 
+    function(x) {
+      len1vals <- list()
+      path <- traverse(
+        x,
+        .f = function(x, y) {
+          # Special handling for if the response was found by a length tie
+          if((length(x[[1]]$response == 1L) && (as_label(x[[1]]$response) == as_label(y[[1]])))) {
+            return(x[[1]])
           }
-        }
-        else{
-          # Remove resp() from call
-          cl <- attr(y,"call")
-          if(any(names(y) == "response")){
-            cl[[which(names(y) == "response")+1]] <- x[[1]][[length(x[[1]])]]
+
+          # Rebuild the expression
+          args <- lapply(x, function(y) {
+            y[[length(y)]]
+          })
+          y <- as.call(c(y[[1]][[1]], args))
+
+          # Search for response
+          path <- compact(lapply(x, `[[`, "response"))
+          if(length(path) > 0) return(list(response = c(path[[1]], y)))
+
+          # Otherwise keep the path that isn't length 1
+          path <- x[[which(map_lgl(x, function(x) is.name(x[[1]]) && !(as_label(x[[1]]) %in% names(len1vals))))]]
+          c(path, y)
+        },
+        .g = function(x) {
+          # traverse only call arguments
+          args <- x[-1]
+
+          # search for resp() to avoid unneeded evaluation
+          resp_loc <- which(map_lgl(args, has_resp))
+          if(length(resp_loc) > 1) {
+            abort("The `resp()` function can only be used once per response variable. For multivariate modelling, use `vars()`.")
           }
+          non_resp <- if(length(resp_loc) == 0) seq_along(args) else -resp_loc
+
+          res <- map(args[non_resp], function(y) eval(y, envir = model$data, enclos = model$specials))
+          len <- map_dbl(res, length)
+
+          if(length(unique(len[len!=1])) > 1){
+            abort(
+              sprintf(
+                "Response variable transformation has incompatible lengths, all arguments must be the length of the data %i or 1.",
+                max(len)
+              )
+            )
+          }
+
+          # store length 1 arguments for transformation environment
+          len1check <- function(len, arg) {
+            (len == 1) && (is.name(arg) || (is.call(arg) && !(as_label(arg[[1]]) %in% "length")))
+          }
+
+          if(any(is_singular <- map2_lgl(len, args[non_resp], len1check))) {
+            nm <- map_chr(args[non_resp][is_singular], as_label)
+            args[non_resp][is_singular] <- syms(nm)
+            len1vals[nm] <<- res[is_singular]
+          }
+
+          # handle unspecified response with equal length args
+          if((length(resp_loc) == 0) && (sum(len == max(len)) > 1)) {
+            return(list(call("resp", x)))
+          }
+
+          args
+        },
+        .h = function(x) {
+          if(is_resp(x)){
+            if(length(x[-1]) > 2) abort("The response variable accepts only one input. For multivariate modelling, use `vars()`.")
+            list(response = sym(as_label(x[[2]])))
+          } else list(x)
+        },
+        base = function(x) {
+          is_syntactic_literal(x) || is_symbol(x) || is_resp(x)
         }
-      }
-      c(x[[1]], cl)
-    },
-    .g = function(x){
-      if(all(names(x) != "response") && !is.null(attr(x, "call"))){
-        # parent_len <- length(eval(attr(x, "call") %||% x[[1]], envir = model$data))
-        len <- map_dbl(x, function(y) length(eval(attr(y, "call") %||% y[[1]], envir = model$data, enclos = model$specials)))
-        if(sum(len == max(len)) == 1){
-          names(x)[which.max(len)] <- "response"
-        }
-      }
-      if("response" %in% names(x)) x["response"] else list()
-    },
-    base = function(x) !is.list(x)
+      )
+      if("response" %in% names(path)) path <- path$response
+      if(!is.list(path)) path <- list(path)
+      list(path = path, len1vals = len1vals)
+    }
   )
 
   # Obtain parsed out response variable
-  responses <- map(traversed_lhs, function(x) x[[1]])
+  responses <- map(traversed_lhs, function(x) x$path[[1]])
   responses <- map_chr(responses, as_label)
 
   # Obtain transformation expression applied to response variable
-  transform_exprs <- lapply(traversed_lhs, function(x) x[[length(x)]])
+  transform_exprs <- lapply(traversed_lhs, function(x) x$path[[length(x$path)]])
 
   # Invert transformation applied to response variable
   inverse_exprs <- lapply(traversed_lhs, function(x){
-    x <- rev(x)
+    x <- rev(x$path)
     result <- x[[length(x)]]
     for (i in seq_len(length(x) - 1)){
       result <- undo_transformation(x[[i]], x[[i + 1]], result)
     }
     result
   })
 
+  # Create evaluation environment for transformation functions
+  # Includes cached values of single length arguments
+  transform_args <- lapply(traversed_lhs, `[[`, "len1vals")
+  envs <- lapply(transform_args, new_environment,  parent = model$env)
+
   # Produce transformation class functions for bt() usage
-  make_transforms <- function(exprs, responses){
-    map2(exprs, responses, function(x, response){
-      new_function(args = set_names(list(missing_arg()), response), x, env = model$env)
-    })
+  make_transforms <- function(exprs, responses, envs){
+    .mapply(
+      function(x, response, env){
+        new_function(args = set_names(list(missing_arg()), response), x, env = env)
+      },
+      dots = list(x = exprs, response = responses, env = envs),
+      MoreArgs = list()
+    )
   }
+
   transformations <- map2(
-    make_transforms(transform_exprs, responses),
-    make_transforms(inverse_exprs, responses),
+    make_transforms(transform_exprs, responses, envs),
+    make_transforms(inverse_exprs, responses, envs),
     new_transformation
   )