simplify print

rjdverse · Jul 24, 2024 · bba15fd · bba15fd
1 parent 1b9cdb7
commit bba15fd
Show file tree

Hide file tree

Showing 4 changed files with 179 additions and 153 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -23,6 +23,7 @@ S3method(print,JD3_TRAMOSEATS_RSLTS)
 S3method(print,JD3_TRAMOSEATS_SPEC)
 S3method(print,JD3_TRAMO_OUTPUT)
 S3method(print,JD3_TRAMO_SPEC)
+S3method(print,summary.JD3_TRAMOSEATS_RSLTS)
 S3method(remove_outlier,JD3_TRAMOSEATS_SPEC)
 S3method(remove_ramp,JD3_TRAMOSEATS_SPEC)
 S3method(residuals,JD3_TRAMOSEATS_OUTPUT)
@@ -40,6 +41,8 @@ S3method(set_seats,JD3_SEATS_SPEC)
 S3method(set_seats,JD3_TRAMOSEATS_SPEC)
 S3method(set_tradingdays,JD3_TRAMOSEATS_SPEC)
 S3method(set_transform,JD3_TRAMOSEATS_SPEC)
+S3method(summary,JD3_TRAMOSEATS_OUTPUT)
+S3method(summary,JD3_TRAMOSEATS_RSLTS)
 S3method(summary,JD3_TRAMO_OUTPUT)
 S3method(vcov,JD3_TRAMOSEATS_OUTPUT)
 S3method(vcov,JD3_TRAMO_OUTPUT)

diff --git a/R/print.R b/R/print.R
@@ -2,9 +2,8 @@
 #'@importFrom utils capture.output
 print_diagnostics <- function(x, digits = max(3L, getOption("digits") - 3L),
                               ...){
-  diagnostics <- rjd3toolkit::diagnostics(x)
-  variance_decomposition <- diagnostics$variance_decomposition
-  residual_tests <- diagnostics$residual_tests
+  variance_decomposition <- x$variance_decomposition
+  residual_tests <- x$residual_tests
 
   cat("Relative contribution of the components to the stationary",
       "portion of the variance in the original series,",
@@ -32,10 +31,6 @@ print_diagnostics <- function(x, digits = max(3L, getOption("digits") - 3L),
 
   invisible(x)
 }
-print_final <- function(x, ...){
-  print(rjd3toolkit::sa_decomposition(x), ...)
-  invisible(x)
-}
 
 #' @export
 print.JD3_SEATS <- function(x, ...) {
@@ -59,159 +54,45 @@ print.JD3_SEATS <- function(x, ...) {
 }
 
 #' @export
-print.JD3_TRAMO_SPEC <- function(x, ...) {
-
-  cat("Specification", "\n", sep = "")
-
-
-  cat("\n", "Series", "\n", sep = "")
-
-  cat("Serie span: ", x$basic$span$type, "\n", sep = "")
-  cat("Preliminary Check: ", ifelse(x$basic$preliminaryCheck, "Yes", "No"), "\n", sep = "")
-
-
-  cat("\n", "Estimate", "\n", sep = "")
-
-  cat("Model span: ", x$estimate$span$type, "\n", sep = "")
-  cat("Tolerance: ", x$estimate$tol, "\n", sep = "")
-  cat("Exact ML: ", ifelse(x$estimate$ml, "Yes", "No"), "\n", sep = "")
-  cat("Unit root limit: ", x$estimate$ubp, "\n", sep = "")
-
-
-  cat("\n", "Transformation", "\n", sep = "")
-
-  cat("Function: ", x$transform$fn, "\n", sep = "")
-  cat("AIC difference: ", x$transform$aicdiff, "\n", sep = "")
-  cat("Adjust: ", x$transform$adjust, "\n", sep = "")
-
-
-  cat("\n", "Regression", "\n", sep = "")
-
-  if (!is.null(x$regression$td$users) && length(x$regression$td$users) > 0) {
-    cat("Calendar regressor: user-defined calendar", "\n", sep = "")
-    cat("Test: ", x$regression$td$test, "\n", sep = "")
-  } else if (x$regression$td$td == "TD_NONE") {
-    cat("No calendar regressor", "\n", sep = "")
-  } else {
-    cat("Calendar regressor: ", x$regression$td$td, "\n", sep = "")
-    cat("with Leap Year: ", ifelse(x$regression$td$lp == "LEAPYEAR", "Yes", "No"), "\n", sep = "")
-    cat("AutoAdjust: ", x$regression$td$autoadjust, "\n", sep = "")
-    cat("Test: ", x$regression$td$test, "\n", sep = "")
-  }
-  cat("\n")
-
-  cat("Easter: ", x$regression$easter$type, "\n", sep = "")
-  cat("\n")
-
-  cat("Pre-specified outliers: ", length(x$regression$outliers), "\n", sep = "")
-  if (!is.null(x$regression$outliers) && length(x$regression$outliers) > 0) {
-    for (out in x$regression$outliers) {
-      cat("\t-", out$name, "\n")
-    }
-  }
-  cat("Ramps: ", ifelse(!is.null(x$regression$ramps) && length(x$regression$ramps) > 0, "Yes", "No"), "\n", sep = "")
-  cat("User-defined variables: ", ifelse(!is.null(x$regression$users) && length(x$regression$users) > 0, "Yes", "No"), "\n", sep = "")
-
-
-  cat("\n", "Outliers", "\n", sep = "")
-
-  if (is.null(x$outlier$outliers) || length(x$outlier$outliers) == 0) {
-    cat("Is enabled: No\n")
-  } else {
-    cat("Detection span: ", x$outlier$span$type, sep = "")
-    if (toupper(x$outlier$span$type) %in% c("FROM", "BETWEEN")) {
-      cat(" from", x$outlier$span$d0)
-    }
-    if (toupper(x$outlier$span$type) %in% c("TO", "BETWEEN")) {
-      cat(" to", x$outlier$span$d1)
-    }
-    if (x$outlier$span == "All") {
-      cat("Detection span: All\n")
-    }
-    cat("\n")
-
-    list_outliers <- c("ao", "ls", "tc", "so")
-    detected_outliers <- c("ao", "ls", "tc", "so")[do.call(
-      args = x$outlier[c("ao", "ls", "tc", "so")],
-      what = c)]
-
-    if (length(detected_outliers) > 0) {
-      cat("Outliers type: ", paste(detected_outliers, collapse = ", "), "\n", sep = "")
-    }
-
-    cat("Critical value: ", ifelse(x$outlier$va == 0, "0 (Auto)", x$outlier$va), "\n", sep = "")
-    cat("TC rate: ", ifelse(x$outlier$tcrate == 0.7, "0,7 (Auto)", x$outlier$tcrate), "\n", sep = "")
-    cat("EML estimation: ", ifelse(x$outlier$ml, "Yes", "No"), "\n", sep = "")
-  }
-
-
-  cat("\n", "ARIMA", "\n", sep = "")
-
-  print(x$arima)
-
-  cat("\n")
-  return(invisible(x))
+print.JD3_TRAMOSEATS_RSLTS <- function(x, digits = max(3L, getOption("digits") - 3L), summary_info = getOption("summary_info"),
+                                       ...){
+    cat("Model: TRAMO-SEATS","\n",sep="")
+    print(x$preprocessing, digits = digits, summary_info = FALSE, ...)
+    if (summary_info)
+        cat("\nFor a more detailed output, use the 'summary()' function.\n")
+    return(invisible(x))
 }
-
-
 #' @export
-print.JD3_SEATS_SPEC <- function(x, ...) {
-
-  cat("Specification SEATS", "\n", sep = "")
-
-
-  cat("Approximation mode: ", x$approximation, "\n", sep = "")
-  cat("MA unit root boundary: ", x$xl, "\n", sep = "")
-  cat("Trend boundary: ", x$rmod, "\n", sep = "")
-  cat("Seasonal tolerance: ", x$epsphi, "\n", sep = "")
-  cat("Seasonal boundary: ", x$sbound, "\n", sep = "")
-  cat("Method: ", x$algorithm, "\n", sep = "")
-
-  return(invisible(x))
+summary.JD3_TRAMOSEATS_RSLTS <- function(object, ...){
+    x <- list(preprocessing = summary(object$preprocessing),
+              decomposition = object$decomposition$canonicaldecomposition,
+              diagnostics = rjd3toolkit::diagnostics(object),
+              final = rjd3toolkit::sa_decomposition(object)
+    )
+    class(x) <- "summary.JD3_TRAMOSEATS_RSLTS"
+    return(x)
 }
 
 #' @export
-print.JD3_TRAMOSEATS_SPEC <- function(x, ...) {
-
-  print(x$tramo, ...)
-  print(x$seats, ...)
-
-  cat("\n", "Benchmarking", "\n", sep = "")
-
-  if (!x$benchmarking$enabled) {
-    cat("Is enabled: No\n")
-  } else {
-    cat("Enabled: Yes", sep = "")
-    cat("Target: ", x$benchmarking$target, "\n", sep = "")
-    cat("Lambda: ", x$benchmarking$lambda, "\n", sep = "")
-    cat("Rho: ", x$benchmarking$rho, "\n", sep = "")
-    cat("Use forecast: ", ifelse(x$benchmarking$forecast, "Yes", "No"), "\n", sep = "")
-  }
-
-  cat("\n")
-  return(invisible(x))
+summary.JD3_TRAMOSEATS_OUTPUT <- function(object, ...){
+    summary(object$result, ...)
 }
-
 #' @export
-print.JD3_TRAMOSEATS_RSLTS <- function(x, digits = max(3L, getOption("digits") - 3L),
-                                ...){
-
-  cat("TRAMO","\n",sep="")
-  print(x$preprocessing, digits = digits, ...)
-  cat("\n", "Decomposition","\n",sep="")
-  print(x$decomposition$canonicaldecomposition, ...)
-  cat("\n", "Diagnostics","\n",sep="")
-  print_diagnostics(x, digits = digits, ...)
-  cat("\n", "Final","\n",sep="")
-  print_final(x, digits = digits, ...)
-
-  return(invisible(x))
+print.summary.JD3_TRAMOSEATS_RSLTS <- function(x, digits = max(3L, getOption("digits") - 3L), signif.stars = getOption("show.signif.stars"), ...){
+    cat("Model: TRAMO-SEATS\n")
+    print(x$preprocessing, digits = digits, signif.stars = signif.stars, ...)
+    cat("\n", "Decomposition","\n",sep="")
+    print(x$decomposition, ...)
+    cat("\n", "Diagnostics","\n",sep="")
+    print_diagnostics(x$diagnostics, digits = digits, ...)
+    cat("\n", "Final","\n",sep="")
+    print(x$final, digits = digits, ...)
+    return(invisible(x))
 }
-
 #' @export
-print.JD3_TRAMOSEATS_OUTPUT<- function(x, digits = max(3L, getOption("digits") - 3L),
+print.JD3_TRAMOSEATS_OUTPUT<- function(x, digits = max(3L, getOption("digits") - 3L), summary_info = getOption("summary_info"),
                                 ...){
-  print(x$result, digits = digits, ...)
+  print(x$result, digits = digits, summary_info = summary_info, ...)
 
   return(invisible(x))
 }
@@ -272,3 +153,139 @@ diagnostics.JD3_TRAMOSEATS_RSLTS<-function(x, ...){
 diagnostics.JD3_TRAMOSEATS_OUTPUT<-function(x, ...){
   return(rjd3toolkit::diagnostics(x$result, ...))
 }
+
+
+#' @export
+print.JD3_TRAMO_SPEC <- function(x, ...) {
+
+    cat("Specification", "\n", sep = "")
+
+
+    cat("\n", "Series", "\n", sep = "")
+
+    cat("Serie span: ", x$basic$span$type, "\n", sep = "")
+    cat("Preliminary Check: ", ifelse(x$basic$preliminaryCheck, "Yes", "No"), "\n", sep = "")
+
+
+    cat("\n", "Estimate", "\n", sep = "")
+
+    cat("Model span: ", x$estimate$span$type, "\n", sep = "")
+    cat("Tolerance: ", x$estimate$tol, "\n", sep = "")
+    cat("Exact ML: ", ifelse(x$estimate$ml, "Yes", "No"), "\n", sep = "")
+    cat("Unit root limit: ", x$estimate$ubp, "\n", sep = "")
+
+
+    cat("\n", "Transformation", "\n", sep = "")
+
+    cat("Function: ", x$transform$fn, "\n", sep = "")
+    cat("AIC difference: ", x$transform$aicdiff, "\n", sep = "")
+    cat("Adjust: ", x$transform$adjust, "\n", sep = "")
+
+
+    cat("\n", "Regression", "\n", sep = "")
+
+    if (!is.null(x$regression$td$users) && length(x$regression$td$users) > 0) {
+        cat("Calendar regressor: user-defined calendar", "\n", sep = "")
+        cat("Test: ", x$regression$td$test, "\n", sep = "")
+    } else if (x$regression$td$td == "TD_NONE") {
+        cat("No calendar regressor", "\n", sep = "")
+    } else {
+        cat("Calendar regressor: ", x$regression$td$td, "\n", sep = "")
+        cat("with Leap Year: ", ifelse(x$regression$td$lp == "LEAPYEAR", "Yes", "No"), "\n", sep = "")
+        cat("AutoAdjust: ", x$regression$td$autoadjust, "\n", sep = "")
+        cat("Test: ", x$regression$td$test, "\n", sep = "")
+    }
+    cat("\n")
+
+    cat("Easter: ", x$regression$easter$type, "\n", sep = "")
+    cat("\n")
+
+    cat("Pre-specified outliers: ", length(x$regression$outliers), "\n", sep = "")
+    if (!is.null(x$regression$outliers) && length(x$regression$outliers) > 0) {
+        for (out in x$regression$outliers) {
+            cat("\t-", out$name, "\n")
+        }
+    }
+    cat("Ramps: ", ifelse(!is.null(x$regression$ramps) && length(x$regression$ramps) > 0, "Yes", "No"), "\n", sep = "")
+    cat("User-defined variables: ", ifelse(!is.null(x$regression$users) && length(x$regression$users) > 0, "Yes", "No"), "\n", sep = "")
+
+
+    cat("\n", "Outliers", "\n", sep = "")
+
+    if (is.null(x$outlier$outliers) || length(x$outlier$outliers) == 0) {
+        cat("Is enabled: No\n")
+    } else {
+        cat("Detection span: ", x$outlier$span$type, sep = "")
+        if (toupper(x$outlier$span$type) %in% c("FROM", "BETWEEN")) {
+            cat(" from", x$outlier$span$d0)
+        }
+        if (toupper(x$outlier$span$type) %in% c("TO", "BETWEEN")) {
+            cat(" to", x$outlier$span$d1)
+        }
+        if (x$outlier$span == "All") {
+            cat("Detection span: All\n")
+        }
+        cat("\n")
+
+        list_outliers <- c("ao", "ls", "tc", "so")
+        detected_outliers <- c("ao", "ls", "tc", "so")[do.call(
+            args = x$outlier[c("ao", "ls", "tc", "so")],
+            what = c)]
+
+        if (length(detected_outliers) > 0) {
+            cat("Outliers type: ", paste(detected_outliers, collapse = ", "), "\n", sep = "")
+        }
+
+        cat("Critical value: ", ifelse(x$outlier$va == 0, "0 (Auto)", x$outlier$va), "\n", sep = "")
+        cat("TC rate: ", ifelse(x$outlier$tcrate == 0.7, "0,7 (Auto)", x$outlier$tcrate), "\n", sep = "")
+        cat("EML estimation: ", ifelse(x$outlier$ml, "Yes", "No"), "\n", sep = "")
+    }
+
+
+    cat("\n", "ARIMA", "\n", sep = "")
+
+    print(x$arima)
+
+    cat("\n")
+    return(invisible(x))
+}
+
+
+#' @export
+print.JD3_SEATS_SPEC <- function(x, ...) {
+
+    cat("Specification SEATS", "\n", sep = "")
+
+
+    cat("Approximation mode: ", x$approximation, "\n", sep = "")
+    cat("MA unit root boundary: ", x$xl, "\n", sep = "")
+    cat("Trend boundary: ", x$rmod, "\n", sep = "")
+    cat("Seasonal tolerance: ", x$epsphi, "\n", sep = "")
+    cat("Seasonal boundary: ", x$sbound, "\n", sep = "")
+    cat("Method: ", x$algorithm, "\n", sep = "")
+
+    return(invisible(x))
+}
+
+#' @export
+print.JD3_TRAMOSEATS_SPEC <- function(x, ...) {
+
+    print(x$tramo, ...)
+    print(x$seats, ...)
+
+    cat("\n", "Benchmarking", "\n", sep = "")
+
+    if (!x$benchmarking$enabled) {
+        cat("Is enabled: No\n")
+    } else {
+        cat("Enabled: Yes", sep = "")
+        cat("Target: ", x$benchmarking$target, "\n", sep = "")
+        cat("Lambda: ", x$benchmarking$lambda, "\n", sep = "")
+        cat("Rho: ", x$benchmarking$rho, "\n", sep = "")
+        cat("Use forecast: ", ifelse(x$benchmarking$forecast, "Yes", "No"), "\n", sep = "")
+    }
+
+    cat("\n")
+    return(invisible(x))
+}
+
diff --git a/R/tramo_generic.R b/R/tramo_generic.R
@@ -25,11 +25,14 @@ residuals.JD3_TRAMO_OUTPUT <- function(object, ...){
 }
 #' @export
 summary.JD3_TRAMO_OUTPUT <- function(object, ...){
-  summary(object$result, ...)
+  x <- summary(object$result, ...)
+  x$method <- "TRAMO"
+  x
 }
 #' @export
-print.JD3_TRAMO_OUTPUT <- function(x, ...){
-  print(x$result, ...)
+print.JD3_TRAMO_OUTPUT <- function(x, summary_info = getOption("summary_info"), ...){
+  cat("Method: TRAMO\n")
+  print(x$result, summary_info = summary_info, ...)
 }
 #' @export
 diagnostics.JD3_TRAMO_OUTPUT <- function(x, ...){

diff --git a/R/zzz.R b/R/zzz.R
@@ -12,4 +12,7 @@ NULL
 
   # reload extractors
   rjd3toolkit::reload_dictionaries()
+
+  if(is.null(getOption("summary_info")))
+      options(summary_info = TRUE)
 }