Add more user facing message

R/AllGenerics.R

@@ -204,13 +204,18 @@ NULL
 #'  will be coerced to a `numeric` `matrix` via [data.matrix()].
 #' @param dates A [`numeric`] vector of dates. If named, the names must match
 #'  the row names of `object`.
+#' @param calendar An [`aion::TimeScale-class`] object specifying the calendar
+#'  of `dates` (see [calendar()]). Defaults to Gregorian Common Era.
 #' @param rank An [`integer`] specifying the number of CA factorial components
 #'  to be use for linear model fitting (see details). If `NULL` (the default),
 #'  axes corresponding to at least 60% of the inertia will be used.
 #' @param sup_row A [`numeric`] or [`logical`] vector specifying the indices of
 #'  the supplementary rows.
-#' @param calendar An [`aion::TimeScale-class`] object specifying the calendar
-#'  of `dates` (see [calendar()]). Defaults to Gregorian Common Era.
+#' @param total A length-one [`numeric`] vector specifying the minimum total of
+#'  a row/column. Rows/columns whose total is less than this value will be
+#'  omitted from the analysis.
+#' @param verbose A [`logical`] scalar: should \R report extra information
+#'  on progress?
 #' @param ... Further arguments to be passed to internal methods.
 #' @details
 #'  This is an implementation of the chronological modeling method proposed by
@@ -375,6 +380,8 @@ setGeneric(
 #' @param calendar An [`aion::TimeScale-class`] object specifying the target
 #'  calendar (see [aion::calendar()]). If `NULL`, *rata die* are returned.
 #' @param progress A [`logical`] scalar: should a progress bar be displayed?
+#' @param verbose A [`logical`] scalar: should \R report extra information
+#'  on progress?
 #' @param ... Further arguments to be passed to internal methods.
 #' @details
 #'  If `jackknife()` is used, one type/fabric is removed at a

R/event_date.R

@@ -22,8 +22,9 @@ setMethod(
 setMethod(
   f = "event",
   signature = c(object = "matrix", dates = "numeric"),
-  definition = function(object, dates, rank = NULL, sup_row = NULL,
-                        calendar = CE(), ...) {
+  definition = function(object, dates, calendar = CE(),
+                        rank = NULL, sup_row = NULL, total = 5,
+                        verbose = getOption("kairos.verbose"), ...) {
     ## Sample
     n <- nrow(object)
 
@@ -35,9 +36,6 @@ setMethod(
       dates[i] <- old_dates
     }
     arkhe::assert_length(dates, nrow(object))
-    if (all(is.na(dates))) {
-      stop("", call. = FALSE)
-    }
 
     ## Supplementary rows
     sup <- logical(n)
@@ -48,58 +46,37 @@ setMethod(
     dates_ref <- dates[!sup]
     dates_sup <- dates[sup]
 
-    ## Validation
-    clean <- TRUE
-    while (clean) {
-      rm_col <- colSums(data_ref) < 5
-      if (any(rm_col)) {
-        data_ref <- data_ref[, !rm_col, drop = FALSE]
-        data_sup <- data_sup[, !rm_col, drop = FALSE]
-      }
-
-      rm_row_ref <- rowSums(data_ref) < 5
-      if (any(rm_row_ref)) {
-        data_ref <- data_ref[!rm_row_ref, , drop = FALSE]
-        dates_ref <- dates_ref[!rm_row_ref]
-      }
-
-      rm_row_sup <- rowSums(data_sup) < 5
-      if (any(data_sup)) {
-        data_sup <- data_sup[!rm_row_sup, , drop = FALSE]
-        dates_sup <- dates_sup[!rm_row_sup]
-      }
-
-      if (!any(rm_col) & !any(rm_row_ref) & !any(rm_row_sup)) clean <- FALSE
-    }
+    ## Cleansing
+    data_clean <- clean_total(data_ref, data_sup, dates_ref, dates_sup,
+                              total = total, verbose = verbose)
 
-    data <- rbind(data_ref, data_sup)
-    dates <- c(dates_ref, dates_sup)
-    sup <- seq_along(dates_sup) + length(dates_ref)
+    data <- rbind(data_clean$data_ref, data_clean$data_sup)
+    dates <- c(data_clean$dates_ref, data_clean$dates_sup)
+    sup <- seq_along(data_clean$dates_sup) + length(data_clean$dates_ref)
 
     ## Correspondance analysis
     if (is.null(rank)) {
       tmp <- dimensio::ca(data, rank = NULL, sup_row = sup, ...)
       eig <- dimensio::get_eigenvalues(tmp)
       rank <- which.max(eig$cumulative >= 60)
     }
-    rank <- min(rank, dim(data_ref) - 1)
+    rank <- min(rank, dim(data) - 1)
     results_CA <- dimensio::ca(data, rank = rank, sup_row = sup, ...)
 
     ## Get row coordinates
     row_coord <- dimensio::get_coordinates(results_CA, margin = 1)
 
     ## Rata die
-    ok <- !row_coord$.sup & !is.na(dates)
     if (is.null(calendar)) {
-      rd <- aion::as_fixed(dates[ok])
+      rd <- aion::as_fixed(data_clean$dates_ref)
     } else {
-      rd <- aion::fixed(dates[ok], calendar = calendar)
+      rd <- aion::fixed(data_clean$dates_ref, calendar = calendar)
     }
 
     ## Gaussian multiple linear regression model
     contexts <- data.frame(
       date = rd,
-      row_coord[ok, -ncol(row_coord), drop = FALSE]
+      row_coord[!row_coord$.sup, -ncol(row_coord), drop = FALSE]
     )
     fit <- stats::lm(date ~ ., data = contexts)
 
@@ -122,6 +99,76 @@ setMethod(
   }
 )
 
+clean_total <- function(data_ref, data_sup, dates_ref, dates_sup,
+                        total = 5, verbose = TRUE) {
+
+  clean <- TRUE
+  n_rm_col <- n_rm_ref <- n_rm_sup <- 0
+
+  while (clean) {
+    rm_col <- colSums(data_ref) < total
+    n_rm_col <- n_rm_col + sum(rm_col)
+    if (any(rm_col)) {
+      data_ref <- data_ref[, !rm_col, drop = FALSE]
+      data_sup <- data_sup[, !rm_col, drop = FALSE]
+    }
+
+    rm_row_ref <- rowSums(data_ref) < total
+    n_rm_ref <- n_rm_ref + sum(rm_row_ref)
+    if (any(rm_row_ref)) {
+      data_ref <- data_ref[!rm_row_ref, , drop = FALSE]
+      dates_ref <- dates_ref[!rm_row_ref]
+    }
+
+    rm_row_sup <- rowSums(data_sup) < total
+    n_rm_sup <- n_rm_sup + sum(rm_row_sup)
+    if (any(data_sup)) {
+      data_sup <- data_sup[!rm_row_sup, , drop = FALSE]
+      dates_sup <- dates_sup[!rm_row_sup]
+    }
+
+    if (!any(rm_col) & !any(rm_row_ref) & !any(rm_row_sup)) clean <- FALSE
+  }
+
+  if (isTRUE(verbose)) {
+    if (n_rm_col > 0) {
+      msg <- ngettext(n_rm_col,
+                      "%d column has a grand total of less than %d.",
+                      "%d columns have a grand total of less than %d.")
+      message(sprintf(msg, n_rm_col, total))
+    }
+    if (n_rm_ref > 0) {
+      msg <- ngettext(n_rm_ref,
+                      "%d row has a grand total of less than %d.",
+                      "%d rows have a grand total of less than %d.")
+      message(sprintf(msg, n_rm_ref, total))
+    }
+    if (n_rm_sup > 0) {
+      msg <- ngettext(n_rm_sup,
+                      "%d supplementary row has a grand total of less than %d.",
+                      "%d supplementary rows have a grand total of less than %d.")
+      message(sprintf(msg, n_rm_sup, total))
+    }
+    n_rm <- n_rm_col + n_rm_ref + n_rm_sup
+    if (n_rm > 0) {
+      msg <- ngettext(n_rm, "It was omitted from the analysis.",
+                      "They were omitted from the analysis.")
+      message(msg)
+    }
+  }
+
+  if (all(is.na(dates_ref))) {
+    stop(tr_("All dates are missing!"), call. = FALSE)
+  }
+
+  list(
+    data_ref = data_ref,
+    data_sup = data_sup,
+    dates_ref = dates_ref,
+    dates_sup = dates_sup
+  )
+}
+
 # Event ========================================================================
 #' @export
 #' @rdname predict_event

R/event_model.R

@@ -20,7 +20,7 @@ setMethod("summary", c(object = "EventDate"), summary.EventDate)
 coef.EventDate <- function(object, calendar = NULL, ...) {
   z <- stats::coef(object@model, ...)
   if (is.null(calendar)) return(z)
-  z / calendar@year # Approximate
+  unclass(z) / calendar@year # Approximate
 }
 
 #' @export
@@ -46,7 +46,7 @@ setMethod("fitted", "EventDate", fitted.EventDate)
 residuals.EventDate <- function(object, calendar = NULL, ...) {
   z <- stats::residuals(object@model, ...)
   if (is.null(calendar)) return(z)
-  z / calendar@year # Approximate
+  unclass(z) / calendar@year # Approximate
 }
 
 #' @export
@@ -59,7 +59,7 @@ setMethod("residuals", "EventDate", residuals.EventDate)
 sigma.EventDate <- function(object, calendar = NULL, ...) {
   z <- stats::sigma(object@model, ...)
   if (is.null(calendar)) return(z)
-  z / calendar@year # Approximate
+  unclass(z) / calendar@year # Approximate
 }
 
 #' @export

R/event_resample.R

@@ -10,7 +10,8 @@ setMethod(
   signature = c(object = "EventDate"),
   definition = function(object, level = 0.95,
                         calendar = getOption("kairos.calendar"),
-                        progress = getOption("kairos.progress"), ...) {
+                        progress = getOption("kairos.progress"),
+                        verbose = getOption("kairos.verbose"), ...) {
     ## Get data
     fit_model <- object@model
     fit_dates <- time(object)
@@ -25,7 +26,8 @@ setMethod(
       x = fit_data,
       dates = fit_dates,
       rank = length(fit_dim),
-      progress = progress
+      progress = progress,
+      verbose = verbose
     )
     jack_coef <- colMeans(jack_values)
 
@@ -62,7 +64,7 @@ setMethod(
 #' @keywords internal
 #' @noRd
 compute_date_jack <- function(x, dates, rank = 10,
-                              progress = getOption("kairos.progress"), ...) {
+                              progress = FALSE, verbose = FALSE, ...) {
   m <- ncol(x)
   k <- seq_len(m)
   jack <- vector(mode = "list", length = m)
@@ -71,12 +73,8 @@ compute_date_jack <- function(x, dates, rank = 10,
   if (progress_bar) pbar <- utils::txtProgressBar(max = m, style = 3)
 
   for (j in k) {
-    ## Removing a column may lead to rows filled only with zeros
-    ## TODO: warning
     counts <- x[, -j, drop = FALSE]
-    if (any(rowSums(counts) == 0)) next
-
-    model <- event(counts, dates = dates, rank = rank, calendar = NULL)
+    model <- event(counts, dates = dates, calendar = NULL, rank = rank, verbose = verbose)
     jack[[j]] <- coef(model, calendar = NULL) # Get model coefficients
     if (progress_bar) utils::setTxtProgressBar(pbar, j)
   }

R/kairos-package.R

@@ -7,11 +7,13 @@
 #' }
 #'
 #' @section Package options:
-#'  `kairos` uses the following [options()] to configure behavior:
-#'  * `kairos.progress`: a [`logical`] scalar. Should progress bars be
-#'    displayed?
+#'  \pkg{kairos} uses the following [options()] to configure behavior:
 #'  * `kairos.calendar`: a [`aion::TimeScale-class`] object (default calendar
-#'    for printing).
+#'    for printing; see [aion::calendar()]).
+#'  * `kairos.progress`: a [`logical`] scalar. Should progress bars be
+#'    displayed? Defaults to [interactive()].
+#'  * `kairos.verbose`: a [`logical`] scalar. Should \R report extra information
+#'    on progress? Defaults to [interactive()].
 #'
 #' @author
 #' **Full list of authors and contributors** (alphabetic order)

R/zzz.R

@@ -1,7 +1,8 @@
 .onLoad <- function(libname, pkgname){
   op <- options()
   op.kairos <- list(
-    kairos.progress = TRUE,
+    kairos.verbose = interactive(),
+    kairos.progress = interactive(),
     kairos.calendar = aion::CE()
   )
   toset <- !(names(op.kairos) %in% names(op))