Merge pull request #52 from clemasso/develop

I have added user-defined thresholds based on #49
rjdverse · Aug 13, 2024 · 4088a6b · 4088a6b
2 parents 96ac0e0 + 0d05475
commit 4088a6b
Show file tree

Hide file tree

Showing 14 changed files with 387 additions and 99 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -45,6 +45,7 @@ Collate:
     'revision_analysis.R'
     'simulate.R'
     'tests.R'
+    'thresholds.R'
     'vintages.R'
     'zzz.R'
 Config/testthat/edition: 3

diff --git a/NAMESPACE b/NAMESPACE
@@ -40,6 +40,8 @@ export(orthogonallyModel1)
 export(orthogonallyModel2)
 export(render_report)
 export(revision_analysis)
+export(set_all_thresholds_to_default)
+export(set_thresholds_to_default)
 export(signalnoise)
 export(slope_and_drift)
 export(theil)

diff --git a/NEWS.md b/NEWS.md
@@ -8,6 +8,8 @@ to [Semantic Versioning](https://semver.org/spec/v2.0.0.html).
 
 ## [Unreleased]
 
+* user-defined thresholds for tests assessment
+* possibility to add plot of revisions in report
 
 ## [1.3.2] - 2024-07-10
 

diff --git a/R/report.R b/R/report.R
@@ -5,6 +5,8 @@
 #' @param output_file path or name of the output file containing the report
 #' @param output_dir path of the dir containing the output file (Optional)
 #' @param output_format either an HTML document (default) or a PDF document
+#' @param plot_revisions Boolean. Default is FALSE meaning that a plot with the
+#'   revisions will not be added to the report.
 #' @param open_report Boolean. Default is TRUE meaning that the report will
 #'                    open automatically after being generated.
 #' @param ... Arguments to be passed to `rmarkdown::render()`, for example:
@@ -44,14 +46,16 @@
 #'     rslt,
 #'     output_file = "my_report",
 #'     output_dir = "C:/Users/xxx",
-#'     output_format = "pdf_document"
+#'     output_format = "pdf_document",
+#'     plot_revisions = TRUE
 #' )
 #' }
 #'
 render_report <- function(rslt,
                           output_file,
                           output_dir,
                           output_format = c("html_document", "pdf_document"),
+                          plot_revisions = FALSE,
                           open_report = TRUE,
                           ...) {
 
@@ -92,7 +96,9 @@ render_report <- function(rslt,
 
     e <- list2env(list(
         descriptive_statistics = rslt$descriptive.statistics,
-        main_results = rslt$summary
+        main_results = rslt$summary,
+        add_plot = plot_revisions,
+        revisions = rslt$revisions
     ))
 
     rmarkdown::render(

diff --git a/R/revision_analysis.R b/R/revision_analysis.R
diff --git a/R/tests.R b/R/tests.R
@@ -522,7 +522,7 @@ orthogonallyModel1 <- function(revisions.view, nrevs = 1, na.zero = FALSE) {
         return(NULL)
     }
     colnames(om) <- OlsAllNames(nrevs)
-    rownames(om) <- colnames(r[-c(1:nrevs)])
+    rownames(om) <- colnames(r)[-c(1:nrevs)]
     return(om)
 }
 

diff --git a/R/thresholds.R b/R/thresholds.R
@@ -0,0 +1,68 @@
+#' Set all test thresholds to their default values
+#'
+#' @param diagnostic_tests Boolean. Whether or not to reset thresholds for
+#'   diagnostics tests on residuals as well in addition to parametric tests.
+#' @export
+#' @examples
+#'
+#' set_all_thresholds_to_default()
+#'
+set_all_thresholds_to_default <- function(diagnostic_tests = TRUE){
+
+    threshold_option_names <- c("theil_u1_threshold", "theil_u2_threshold",
+                                "t_threshold", "augmented_t_threshold",
+                                "slope_and_drift_threshold", "eff1_threshold",
+                                "eff2_threshold", "orth1_threshold",
+                                "orth2_threshold", "autocorr_threshold",
+                                "seas_threshold", "signal_noise1_threshold",
+                                "signal_noise2_threshold")
+
+    if(diagnostic_tests){
+        threshold_option_names <- c(threshold_option_names, "jb_res_threshold",
+                                    "bp_res_threshold", "white_res_threshold",
+                                    "arch_res_threshold")
+    }
+
+    for(threshold_option_name in threshold_option_names){
+        set_thresholds_to_default(threshold_option_name)
+    }
+
+    return(invisible(NULL))
+}
+
+
+#' Set thresholds of a given test to their default values
+#'
+#' @param threshold_option_name Boolean. Whether or not to reset thresholds for
+#'   diagnostics tests on residuals as well in addition to parametric tests.
+#' @export
+#' @examples
+#'
+#' set_thresholds_to_default("t_threshold")
+#'
+set_thresholds_to_default <- function(threshold_option_name){
+
+    switch(threshold_option_name,
+           theil_u1_threshold = {options(theil_u1_threshold = c(uncertain = .8, bad = .9, severe = .99))},
+           theil_u2_threshold = {options(theil_u2_threshold = c(uncertain = .8, bad = .9, severe = 1))},
+           t_threshold = {options(t_threshold = c(severe = 0.001, bad = 0.01, uncertain = 0.05))},
+           augmented_t_threshold = {options(augmented_t_threshold = c(severe = 0.001, bad = 0.01, uncertain = 0.05))},
+           slope_and_drift_threshold = {options(slope_and_drift_threshold = c(severe = 0.001, bad = 0.01, uncertain = 0.05))},
+           eff1_threshold = {options(eff1_threshold = c(severe = 0.001, bad = 0.01, uncertain = 0.05))},
+           eff2_threshold = {options(eff2_threshold = c(severe = 0.001, bad = 0.01, uncertain = 0.05))},
+           orth1_threshold = {options(orth1_threshold = c(severe = 0.001, bad = 0.01, uncertain = 0.05))},
+           orth2_threshold = {options(orth2_threshold = c(severe = 0.001, bad = 0.01, uncertain = 0.05))},
+           autocorr_threshold = {options(autocorr_threshold = c(severe = 0.001, bad = 0.01, uncertain = 0.05))},
+           seas_threshold= {options(seas_threshold = c(severe = 0.001, bad = 0.01, uncertain = 0.05))},
+           signal_noise1_threshold = {options(signal_noise1_threshold = c(severe = 0.001, bad = 0.01, uncertain = 0.05))},
+           signal_noise2_threshold = {options(signal_noise2_threshold = c(uncertain = 0.05))},
+           jb_res_threshold = {options(jb_res_threshold = c(bad = 0.01, uncertain = 0.1))},
+           bp_res_threshold = {options(bp_res_threshold = c(bad = 0.01, uncertain = 0.1))},
+           white_res_threshold = {options(white_res_threshold = c(bad = 0.01, uncertain = 0.1))},
+           arch_res_threshold = {options(arch_res_threshold = c(bad = 0.01, uncertain = 0.1))},
+           stop("Test not found")
+           )
+}
+
+
+
diff --git a/R/zzz.R b/R/zzz.R
@@ -9,4 +9,58 @@ NULL
 
     # reload extractors
     .jcall("jdplus/toolkit/base/api/information/InformationExtractors", "V", "reloadExtractors")
+
+    # options initialization
+    if (is.null(getOption("theil_u1_threshold"))) {
+        set_thresholds_to_default("theil_u1_threshold")
+    }
+    if (is.null(getOption("theil_u2_threshold"))) {
+        set_thresholds_to_default("theil_u2_threshold")
+    }
+    if (is.null(getOption("t_threshold"))) {
+        set_thresholds_to_default("t_threshold")
+    }
+    if (is.null(getOption("augmented_t_threshold"))) {
+        set_thresholds_to_default("augmented_t_threshold")
+    }
+    if (is.null(getOption("slope_and_drift_threshold"))) {
+        set_thresholds_to_default("slope_and_drift_threshold")
+    }
+    if (is.null(getOption("eff1_threshold"))) {
+        set_thresholds_to_default("eff1_threshold")
+    }
+    if (is.null(getOption("eff2_threshold"))) {
+        set_thresholds_to_default("eff2_threshold")
+    }
+    if (is.null(getOption("orth1_threshold"))) {
+        set_thresholds_to_default("orth1_threshold")
+    }
+    if (is.null(getOption("orth2_threshold"))) {
+        set_thresholds_to_default("orth2_threshold")
+    }
+    if (is.null(getOption("autocorr_threshold"))) {
+        set_thresholds_to_default("autocorr_threshold")
+    }
+    if (is.null(getOption("seas_threshold"))) {
+        set_thresholds_to_default("seas_threshold")
+    }
+    if (is.null(getOption("signal_noise1_threshold"))) {
+        set_thresholds_to_default("signal_noise1_threshold")
+    }
+    if (is.null(getOption("signal_noise2_threshold"))) {
+        set_thresholds_to_default("signal_noise2_threshold")
+    }
+
+    if (is.null(getOption("jb_res_threshold"))) {
+        set_thresholds_to_default("jb_res_threshold")
+    }
+    if (is.null(getOption("bp_res_threshold"))) {
+        set_thresholds_to_default("bp_res_threshold")
+    }
+    if (is.null(getOption("white_res_threshold"))) {
+        set_thresholds_to_default("white_res_threshold")
+    }
+    if (is.null(getOption("arch_res_threshold"))) {
+        set_thresholds_to_default("arch_res_threshold")
+    }
 }
diff --git a/inst/templates/report.Rmd b/inst/templates/report.Rmd
@@ -40,6 +40,12 @@ if (!requireNamespace("kableExtra", quietly = TRUE)) {
 } else {
     kableExtra::kable_minimal(knitr::kable(descriptive_statistics[selection, , drop = FALSE]))
 }
+
+if (add_plot) {
+    stats::ts.plot(revisions, gpars = list(xlab = "", ylab = "", col = c(1:ncol(revisions)), type = "h", lwd = 2))
+    graphics::legend("topleft", bty = "n", lty = 1, lwd = 2, col = c(1:ncol(revisions)), legend = colnames(revisions))
+    graphics::title(main = "Revisions size")
+}
 ```
 
 
@@ -71,7 +77,6 @@ if (!requireNamespace("kableExtra", quietly = TRUE)) {
 }
 ```
 
-
 # Tests description
 
 ## I. Relevancy

diff --git a/man/render_report.Rd b/man/render_report.Rd
diff --git a/man/revision_analysis.Rd b/man/revision_analysis.Rd
diff --git a/man/set_all_thresholds_to_default.Rd b/man/set_all_thresholds_to_default.Rd
diff --git a/man/set_thresholds_to_default.Rd b/man/set_thresholds_to_default.Rd