Merge pull request #59 from TanguyBarthelemy/develop

Add `simulate_revisions` in README and some linting
rjdverse · Oct 23, 2024 · 38b9dcb · 38b9dcb
2 parents e7192ce + 429032c
commit 38b9dcb
Show file tree

Hide file tree

Showing 13 changed files with 177 additions and 123 deletions.
diff --git a/.lintr b/.lintr
@@ -1,10 +1,41 @@
-linters: linters_with_defaults(
+linters: lintr::all_linters(
         indentation_linter = lintr::indentation_linter(indent = 4L),
         object_usage_linter = NULL,
         object_name_linter = NULL,
         line_length_linter = NULL,
         commented_code_linter = NULL,
         cyclocomp_linter = NULL,
-        brace_linter = NULL
+        brace_linter = NULL,
+                extraction_operator_linter = NULL,
+        undesirable_function_linter = NULL,
+        nonportable_path_linter = NULL,
+        implicit_integer_linter = NULL,
+        numeric_leading_zero_linter = NULL,
+        fixed_regex_linter = NULL,
+        unused_import_linter = NULL,
+        absolute_path_linter = NULL,
+        library_call_linter = NULL,
+        keyword_quote_linter = NULL,
+        missing_package_linter = NULL,
+        unnecessary_concatenation_linter = NULL,
+        strings_as_factors_linter = NULL,
+        class_equals_linter = NULL,
+        namespace_linter = NULL,
+        inner_combine_linter = NULL,
+        paste_linter = NULL,
+        unnecessary_lambda_linter = NULL,
+        function_argument_linter = NULL,
+        line_length_linter = NULL,
+        if_not_else_linter = NULL,
+        unnecessary_lambda_linter = NULL,
+        boolean_arithmetic_linter = NULL,
+        condition_message_linter = NULL,
+        undesirable_operator_linter = NULL,
+        nested_ifelse_linter = NULL,
+        unnecessary_nested_if_linter = NULL,
+        todo_comment_linter = NULL,
+        redundant_ifelse_linter = NULL,
+        duplicate_argument_linter = NULL,
+        literal_coercion_linter = NULL
     )
 encoding: "UTF-8"
diff --git a/R/check.R b/R/check.R
@@ -1,4 +1,3 @@
-
 #' Check vector with date
 #' @description
 #' Useful functions to check if a vector represent dates object
@@ -120,7 +119,7 @@ check_date_month <- function(x) {
 #' @export
 check_format_date <- function(x, date_format = "%Y-%m-%d") {
     for (format_n in date_format) {
-        if (!(any(is.na(as.Date(x, format = format_n))))) {
+        if (!(anyNA(as.Date(x, format = format_n)))) {
             return(TRUE)
         }
     }
@@ -154,7 +153,7 @@ assert_time_period <- function(x, date_format = "%Y-%m-%d") {
     if (check_format_date(x = x, date_format = date_format)) {
         # Date au format ISO ou type date
         for (format_n in date_format) {
-            if (!(any(is.na(as.Date(x, format = format_n))))) {
+            if (!(anyNA(as.Date(x, format = format_n)))) {
                 return(as.Date(x, format = format_n))
             }
         }
@@ -191,7 +190,7 @@ assert_rev_date <- function(x, date_format = "%Y-%m-%d") {
     if (check_format_date(x = x, date_format = date_format)) {
         # Date au format ISO ou type date
         for (format_n in date_format) {
-            if (!(any(is.na(as.Date(x, format = format_n))))) {
+            if (!(anyNA(as.Date(x, format = format_n)))) {
                 return(as.Date(x, format = format_n))
             }
         }

diff --git a/R/revision_analysis.R b/R/revision_analysis.R
@@ -385,7 +385,7 @@ seasonality_test <- function(x) {
         lb_pval <- try(seasonality_qs(x_diff, stats::frequency(x))$pvalue, silent = TRUE) # Ljung-Box
         fd_pval <- try(seasonality_friedman(x_diff, stats::frequency(x))$pvalue, silent = TRUE) # Friedman non-parametric test
 
-        test_succeeded <- c(!"try-error" %in% class(lb_pval), !"try-error" %in% class(fd_pval))
+        test_succeeded <- c(!inherits(lb_pval, "try-error"), !inherits(fd_pval, "try-error"))
         if (all(test_succeeded)) {
             pvals <- c(lb_pval, fd_pval)
             seasonality <- ifelse(length(pvals[which(pvals < .05)]) == 2, TRUE, FALSE)
@@ -538,7 +538,7 @@ ac_test_evaluator <- function(ac, is_log, cnames, n_test, thr) {
     ac_trf <- ifelse(is_log, "Log", "None")
     ac_trf_str <- ifelse(ac_trf == "Log", get_info_transformation(TRUE, FALSE), get_info_transformation(FALSE, FALSE))
 
-    if (!"try-error" %in% class(ac)) {
+    if (!inherits(ac, "try-error")) {
         pm_test_mat <- matrix(unlist(ac), ncol = 2, byrow = TRUE)[, , drop = FALSE]
         dimnames(pm_test_mat) <- list(cnames, c("value", "p.value"))
         ac_rslt <- list(info_transformation = ac_trf_str, estimates_ljungbox = pm_test_mat)
@@ -555,19 +555,19 @@ seas_tests_evaluator <- function(lb_test, fd_test, is_log, cnames, freq, n_test,
     seas_trf <- ifelse(is_log, "Delta-Log 1", "Delta 1")
     seas_trf_str <- ifelse(seas_trf == "Delta-Log 1", get_info_transformation(TRUE, TRUE), get_info_transformation(FALSE, TRUE))
 
-    if (!"try-error" %in% class(lb_test) && !"try-error" %in% class(fd_test) && freq > 1) {
+    if (!inherits(lb_test, "try-error") && !inherits(fd_test, "try-error") && freq > 1) {
         seas_rslt <- list(info_transformation = seas_trf_str,
                           estimates_ljungbox = matrix(unlist(lb_test), ncol = 2, byrow = TRUE, dimnames = list(cnames, c("value", "p.value"))),
                           estimates_friedman = matrix(unlist(fd_test), ncol = 2, byrow = TRUE, dimnames = list(cnames, c("value", "p.value"))))
         seas_lb_q <- eval_test(seas_rslt$estimates_ljungbox[, "p.value"], threshold = thr)
         seas_fd_q <- eval_test(seas_rslt$estimates_friedman[, "p.value"], threshold = thr)
-    } else if (!"try-error" %in% class(lb_test) && freq > 1) {
+    } else if (!inherits(lb_test, "try-error") && freq > 1) {
         seas_rslt <- list(info_transformation = seas_trf_str,
                           estimates_ljungbox = matrix(unlist(lb_test), ncol = 2, byrow = TRUE, dimnames = list(cnames, c("value", "p.value"))),
                           estimates_friedman = NULL)
         seas_lb_q <- eval_test(seas_rslt$estimates_ljungbox[, "p.value"], threshold = thr)
         seas_fd_q <- rep(NA, n_test)
-    } else if (!"try-error" %in% class(fd_test) && freq > 1) {
+    } else if (!inherits(fd_test, "try-error") && freq > 1) {
         seas_rslt <- list(info_transformation = seas_trf_str,
                           estimates_ljungbox = NULL,
                           estimates_friedman = matrix(unlist(fd_test), ncol = 2, byrow = TRUE, dimnames = list(cnames, c("value", "p.value"))))
@@ -844,15 +844,16 @@ View.rjd3rev_rslts <- function(
     if (!requireNamespace("flextable", quietly = TRUE)) {
         warning("Please install 'flextable': install.packages('flextable') to get more visual output")
 
-        utils::View(table_output, title = paste(title, switch(
-            type,
-            "summary" = "Tests summary",
-            "stat-desc" = "Descriptive statistics",
-            "revisions" = "Revisions",
-            "tests" = "All tests"
-        )))
+        return(
+            utils::View(table_output, title = paste(title, switch(
+                type,
+                "summary" = "Tests summary",
+                "stat-desc" = "Descriptive statistics",
+                "revisions" = "Revisions",
+                "tests" = "All tests"
+            )))
+        )
     } else {
-        print(table_output)
+        return(table_output)
     }
-    return(invisible(NULL))
 }
diff --git a/R/tests.R b/R/tests.R
@@ -157,7 +157,7 @@ theil <- function(vintages.view, gap = 1, na.zero = FALSE) {
     if (na.zero) q[is.na(q)] <- 0
     jq <- matrix_r2jd(q)
     theil <- try(.jcall("jdplus/revisions/base/r/Utility", "[D", "theil", jq, as.integer(gap)), silent = TRUE)
-    if ("try-error" %in% class(theil)) {
+    if (inherits(theil, "try-error")) {
         warning("theil could not be performed", call. = FALSE)
         return(NULL)
     }
@@ -196,7 +196,7 @@ theil2 <- function(vintages.view, gap = 1, na.zero = FALSE) {
     if (na.zero) q[is.na(q)] <- 0
     jq <- matrix_r2jd(q)
     theil2 <- try(.jcall("jdplus/revisions/base/r/Utility", "[D", "theil2", jq, as.integer(gap)), silent = TRUE)
-    if ("try-error" %in% class(theil2)) {
+    if (inherits(theil2, "try-error")) {
         warning("theil2 could not be performed", call. = FALSE)
         return(NULL)
     }
@@ -234,7 +234,7 @@ bias <- function(revisions.view, na.zero = FALSE) {
     if (na.zero) r[is.na(r)] <- 0
     jrevs <- matrix_r2jd(r)
     jbias <- try(.jcall("jdplus/revisions/base/r/Utility", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", "bias", jrevs), silent = TRUE)
-    if ("try-error" %in% class(bias)) {
+    if (inherits(bias, "try-error")) {
         warning("bias could not be performed", call. = FALSE)
         return(NULL)
     }
@@ -285,7 +285,7 @@ slope_and_drift <- function(vintages.view, gap = 1, na.zero = FALSE) {
     if (na.zero) q[is.na(q)] <- 0
     jq <- matrix_r2jd(q)
     jsd <- try(.jcall("jdplus/revisions/base/r/Utility", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", "slopeAndDrift", jq, as.integer(gap)), silent = TRUE)
-    if ("try-error" %in% class(jsd)) {
+    if (inherits(jsd, "try-error")) {
         warning("Slope and drift could not be performed", call. = FALSE)
         return(NULL)
     }
@@ -336,7 +336,7 @@ efficiencyModel1 <- function(vintages.view, gap = 1, na.zero = FALSE) {
     if (na.zero) q[is.na(q)] <- 0
     jq <- matrix_r2jd(q)
     jef1 <- try(.jcall("jdplus/revisions/base/r/Utility", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", "efficiencyModel1", jq, as.integer(gap)), silent = TRUE)
-    if ("try-error" %in% class(jef1)) {
+    if (inherits(jef1, "try-error")) {
         warning("efficiencyModel1 could not be performed", call. = FALSE)
         return(NULL)
     }
@@ -388,7 +388,7 @@ efficiencyModel2 <- function(vintages.view, gap = 1, na.zero = FALSE) {
     if (na.zero) q[is.na(q)] <- 0
     jq <- matrix_r2jd(q)
     jef2 <- try(.jcall("jdplus/revisions/base/r/Utility", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", "efficiencyModel2", jq, as.integer(gap)), silent = TRUE)
-    if ("try-error" %in% class(jef2)) {
+    if (inherits(jef2, "try-error")) {
         warning("efficiencyModel2 could not be performed", call. = FALSE)
         return(NULL)
     }
@@ -443,7 +443,7 @@ orthogonallyModel1 <- function(revisions.view, nrevs = 1, na.zero = FALSE) {
     if (na.zero) r[is.na(r)] <- 0
     jr <- matrix_r2jd(as.matrix(r))
     jom <- try(.jcall("jdplus/revisions/base/r/Utility", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", "orthogonallyModel1", jr, as.integer(nrevs)), silent = TRUE)
-    if ("try-error" %in% class(jom)) {
+    if (inherits(jom, "try-error")) {
         warning("orthogonallyModel1 could not be performed", call. = FALSE)
         return(NULL)
     }
@@ -495,7 +495,7 @@ orthogonallyModel2 <- function(revisions.view, reference = 1, na.zero = FALSE) {
     if (na.zero) r[is.na(r)] <- 0
     jr <- matrix_r2jd(as.matrix(r))
     jom <- try(.jcall("jdplus/revisions/base/r/Utility", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", "orthogonallyModel2", jr, as.integer(reference)), silent = TRUE)
-    if ("try-error" %in% class(jom)) {
+    if (inherits(jom, "try-error")) {
         warning("orthogonallyModel2 could not be performed", call. = FALSE)
         return(NULL)
     }
@@ -549,7 +549,7 @@ signalnoise <- function(vintages.view, gap = 1, na.zero = FALSE) {
     if (na.zero) q[is.na(q)] <- 0
     jq <- matrix_r2jd(q)
     jsd <- try(.jcall("jdplus/revisions/base/r/Utility", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", "signalNoise", jq, as.integer(gap)), silent = TRUE)
-    if ("try-error" %in% class(jsd)) {
+    if (inherits(jsd, "try-error")) {
         warning("signalnoise could not be performed", call. = FALSE)
         return(NULL)
     }
@@ -596,7 +596,7 @@ unitroot <- function(vintages.view, adfk = 1, na.zero = FALSE) {
     if (na.zero) q[is.na(q)] <- 0
     jq <- matrix_r2jd(q)
     jsd <- try(.jcall("jdplus/revisions/base/r/Utility", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", "unitroot", jq, as.integer(adfk)), silent = TRUE)
-    if ("try-error" %in% class(jsd)) {
+    if (inherits(jsd, "try-error")) {
         warning("unit root test could not be performed", call. = FALSE)
         return(NULL)
     }
@@ -636,7 +636,7 @@ cointegration <- function(vintages.view, adfk = 1, na.zero = FALSE) {
     if (na.zero) q[is.na(q)] <- 0
     jq <- matrix_r2jd(q)
     jsd <- try(.jcall("jdplus/revisions/base/r/Utility", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", "cointegration", jq, as.integer(adfk)), silent = TRUE)
-    if ("try-error" %in% class(jsd)) {
+    if (inherits(jsd, "try-error")) {
         warning("cointegration test could not be performed", call. = FALSE)
         return(NULL)
     }
@@ -688,7 +688,7 @@ vecm <- function(vintages.view, lag = 2, model = c("none", "cnt", "trend"), na.z
     if (na.zero) q[is.na(q)] <- 0
     jq <- matrix_r2jd(q)
     jsd <- try(.jcall("jdplus/revisions/base/r/Utility", "Ljdplus/toolkit/base/api/math/matrices/Matrix;", "vecm", jq, as.integer(lag), model), silent = TRUE)
-    if ("try-error" %in% class(jsd)) {
+    if (inherits(jsd, "try-error")) {
         warning("vecm could not be performed", call. = FALSE)
         return(NULL)
     }

diff --git a/README.Rmd b/README.Rmd
@@ -63,6 +63,10 @@ remotes::install_github("rjdverse/rjd3revisions")
 
 ## Usage
 
+```{r, echo = TRUE, eval = TRUE}
+library("rjd3revisions")
+```
+
 First you need to get your input data set as a data.frame in R in a specific format as below. Note that missing values can either be mentioned as NA (as in the example below) or not be included in the input at the best convenience of the user.
 
 ### Format 1: long view
@@ -98,52 +102,48 @@ First you need to get your input data set as a data.frame in R in a specific for
 Depending on the location of your input data, you can use `create_vintages_from_xlsx()` or `create_vintages_from_csv()`, or the more generic function `create_vintages()` to create the vintages.
 
 ```{r, echo = TRUE, eval = TRUE}
-# Examples
+set.seed(7)
 
-# Long format
-long_view <- data.frame(
-    rev_date = rep(x = c("2022-07-31", "2022-08-31", "2022-09-30", "2022-10-31",
-                         "2022-11-30", "2022-12-31", "2023-01-31", "2023-02-28"),
-                   each = 4L),
-    time_period = rep(x = c("2022Q1", "2022Q2", "2022Q3", "2022Q4"), times = 8L),
-    obs_values = c(
-        .8, .2, NA, NA, .8, .1, NA, NA,
-        .7, .1, NA, NA, .7, .2, .5, NA,
-        .7, .2, .5, NA, .7, .3, .7, NA,
-        .7, .2, .7, .4, .7, .3, .7, .3
-    )
+# Examples
+long_view <- simulate_long(
+    periodicity = 4,
+    n_period = 4 * 10,
+    n_revision = 7,
+    start_period = as.Date("2000-01-01")
 )
-
-# Horizontal format
-horizontal_view <- matrix(data = c(.8, .8, .7, .7, .7, .7, .7, .7, .2, .1,
-                            .1, .2, .2, .3, .2, .3, NA, NA, NA, .5, .5, .7, .7,
-                            .7, NA, NA, NA, NA, NA, NA, .4, .3),
-                          ncol = 4)
-colnames(horizontal_view) <- c("2022Q1", "2022Q2", "2022Q3", "2022Q4")
-rownames(horizontal_view) <- c("2022-07-31", "2022-08-31", "2022-09-30", "2022-10-31",
-                               "2022-11-30", "2022-12-31", "2023-01-31", "2023-02-28")
-
-# Vertical format
-vertical_view <- matrix(data = c(.8, .2, NA, NA, .8, .1, NA, NA, .7, .1, NA,
-                                 NA, .7, .2, .5, NA, .7, .2, .5, NA, .7, .3, .7, NA,
-                                 .7, .2, .7, .4, .7, .3, .7, .3),
-                          nrow = 4)
-rownames(vertical_view) <- c("2022Q1", "2022Q2", "2022Q3", "2022Q4")
-colnames(vertical_view) <- c("2022-07-31", "2022-08-31", "2022-09-30", "2022-10-31",
-                               "2022-11-30", "2022-12-31", "2023-01-31", "2023-02-28")
 ```
 
-Then you can create your vintages, inspect revisions (optional) and make the analysis 
+Then you can create your vintages and plot the vintages and inspect the revisions (optional) 
 
 ```{r, echo = TRUE, eval = TRUE}
-library("rjd3revisions")
-
 vintages <- create_vintages(long_view, periodicity = 4)
-# revisions <- get_revisions(vintages, gap = 2)
-# plot(revisions)
+plot(vintages, lwd = 2)
+
+revisions <- get_revisions(vintages, gap = 2)
+plot(revisions)
+```
+
+and make the analysis 
+
+```{r, echo = FALSE, eval = TRUE}
+library("flextable")
+
+set_flextable_defaults(
+    font.family = "Arial",
+    font.size = 7,
+    big.mark = ""
+)
+```
+
+```{r, echo = TRUE, eval = TRUE}
 rslt <- revision_analysis(vintages, gap = 1, view = "diagonal", n.releases = 3)
+
+print(rslt)
+# summary(rslt)
+View(rslt)
 ```
 
+
 Finally to create a report and get a summary of the results, you can use
 
 ```{r, echo = TRUE, eval = FALSE}
@@ -153,10 +153,6 @@ render_report(
     output_dir = tempdir(),
     output_format = "pdf_document"
 )
-
-summary(rslt)
-print(rslt)
-View(rslt)
 ```
 
 ## Additional information