- Output 'model_estimation' of mcs_delay_() now is named with 'dela…

…y_distribution' (to be in accordance with `mcs_mileage_()`. (#95) - Inserted `call. = FALSE` in MCS functions and `reliability_data`. (#197)
Tim-TU · Feb 9, 2021 · 7f758b9 · 7f758b9
1 parent 63418b4
commit 7f758b9
Show file tree

Hide file tree

Showing 6 changed files with 86 additions and 39 deletions.
diff --git a/R/delay_distributions.R b/R/delay_distributions.R
@@ -216,12 +216,18 @@ dist_delay.default <- function(...,
 
   ## Compare length of date_1 and distribution:
   if (!(length(distribution) == length(date_1) || length(distribution) == 1L)) {
-    stop("'distribution' must be either length one or 'length(date_1)'")
+    stop(
+      "'distribution' must be either length one or 'length(date_1)'",
+      call. = FALSE
+    )
   }
 
   ## Check for different length in date_1 and date_2:
   if (length(unique(lengths(c(date_1, date_2)))) != 1L) {
-    stop("All elements of 'date_1' and 'date_2' must have the same length!")
+    stop(
+      "All elements of 'date_1' and 'date_2' must have the same length!",
+      call. = FALSE
+    )
   }
 
   # Do dist_delay_() with respect to the number of delays:
@@ -431,16 +437,25 @@ dist_delay_register <- function(date_prod,
   # test for delays: all NA and smaller or equal to 0.
   # all NA:
   if (all(is.na(t_regist))) {
-    stop("All differences are NA. No parameters can be estimated!")
+    stop(
+      "All differences are NA. No parameters can be estimated!",
+      call. = FALSE
+    )
   }
   # all smaller or equal to zero:
   if (all(t_regist <= 0, na.rm = TRUE)) {
-    stop("All differences are smaller or equal to 0. No parameters can be estimated!")
+    stop(
+      "All differences are smaller or equal to 0. No parameters can be estimated!",
+      call. = FALSE
+    )
   }
   # any smaller or equal to zero:
   if (!all(t_regist <= 0, na.rm = TRUE) && any(t_regist <= 0, na.rm = TRUE)) {
-    warning("At least one of the time differences is smaller or equal to 0 and is",
-            " ignored for the estimation step!")
+    warning(
+      "At least one of the time differences is smaller or equal to 0 and is",
+      " ignored for the estimation step!",
+      call. = FALSE
+    )
 
     t_regist <- t_regist[t_regist > 0]
   }
@@ -525,16 +540,25 @@ dist_delay_report <- function(date_repair,
   # test for delays: all NA and smaller or equal to 0.
   # all NA:
   if (all(is.na(t_report))) {
-    stop("All differences are NA. No parameters can be estimated!")
+    stop(
+      "All differences are NA. No parameters can be estimated!",
+      call. = FALSE
+    )
   }
   # all smaller or equal to zero:
   if (all(t_report <= 0, na.rm = TRUE)) {
-    stop("All differences are smaller or equal to 0. No parameters can be estimated!")
+    stop(
+      "All differences are smaller or equal to 0. No parameters can be estimated!",
+      call. = FALSE
+    )
   }
   # any smaller or equal to zero:
   if (!all(t_report <= 0, na.rm = TRUE) && any(t_report <= 0, na.rm = TRUE)) {
-    warning("At least one of the time differences is smaller or equal to 0 and is",
-            " ignored for the estimation step!")
+    warning(
+      "At least one of the time differences is smaller or equal to 0 and is",
+      " ignored for the estimation step!",
+      call. = FALSE
+    )
 
     t_report <- t_report[t_report > 0]
   }

diff --git a/R/mcs_data.R b/R/mcs_data.R
@@ -135,7 +135,7 @@ mcs_delay_data <- function(data = NULL,
   if (purrr::is_null(data)) {
     # Vector based approach ----------------------------------------------------
     if (!is_characteristic(time)) {
-      stop("'time' must be numeric!")
+      stop("'time' must be numeric!", call. = FALSE)
     }
 
     if (purrr::is_null(id)) {
@@ -153,15 +153,24 @@ mcs_delay_data <- function(data = NULL,
       function(e1, e2) {
         ### Check for different length in date_1 and date_2:
         if (length(e1) != length(e2)) {
-          stop("Elements of 'date_1' and 'date_2' differ in length!")
+          stop(
+            "Elements of 'date_1' and 'date_2' differ in length!",
+            call. = FALSE
+          )
         }
         ### Check for class of date_1:
         if (!(class(e1) %in% c("Date", "character"))) {
-          stop("'date_1' must be of class 'Date' or 'character'!")
+          stop(
+            "'date_1' must be of class 'Date' or 'character'!",
+            call. = FALSE
+          )
         }
         ### Check for class date_2:
         if (!(class(e2) %in% c("Date", "character"))) {
-          stop("'date_2' must be of class 'Date' or 'character'!")
+          stop(
+            "'date_2' must be of class 'Date' or 'character'!",
+            call. = FALSE
+          )
         }
       }
     )
@@ -171,7 +180,10 @@ mcs_delay_data <- function(data = NULL,
     names_dates_list <- names(dates_list)
 
     if (any(trimws(names_dates_list) == "")) {
-      stop("Either all or no elements of 'date_1' and 'date_2' must have names!")
+      stop(
+        "Either all or no elements of 'date_1' and 'date_2' must have names!",
+        call. = FALSE
+      )
     }
 
     if (purrr::is_null(names_dates_list)) {
@@ -188,7 +200,7 @@ mcs_delay_data <- function(data = NULL,
 
     if (!purrr::is_null(status)) {
       if (!is_status(status)) {
-        stop("'status' must be numeric with elements 0 or 1!")
+        stop("'status' must be numeric with elements 0 or 1!", call. = FALSE)
       }
       tbl_list <- c(dates_list, list(time, status, id))
       names(tbl_list) <- c(names_dates_list, "time", "status", "id")
@@ -208,15 +220,16 @@ mcs_delay_data <- function(data = NULL,
     # Data based approach ------------------------------------------------------
     ## Checks:
     if (!is_characteristic(dplyr::select(data, {{time}})[[1]])) {
-      stop("'time' must be numeric!")
+      stop("'time' must be numeric!", call. = FALSE)
     }
 
     purrr::walk(
       dplyr::select(data, {{date_1}}, {{date_2}}),
       ~ if (!(class(.) %in% c("Date", "character"))) {
         stop(
           "Columns specified in 'date_1' and 'date_2' must be of class",
-          " 'Date' or 'character'!"
+          " 'Date' or 'character'!",
+          call. = FALSE
         )
       }
     )
@@ -227,7 +240,10 @@ mcs_delay_data <- function(data = NULL,
 
     ## Check for same length in 'date_1' and 'date_2':
     if (length(characteristic_1) != length(characteristic_2)) {
-      stop("The same number of columns must be specified in 'date_1' and 'date_2'!")
+      stop(
+        "The same number of columns must be specified in 'date_1' and 'date_2'!",
+        call. = FALSE
+      )
     }
 
     data <- tibble::as_tibble(data)
@@ -257,7 +273,7 @@ mcs_delay_data <- function(data = NULL,
 
     if ("status" %in% names(tbl)) {
       if (!is_status(tbl$status)) {
-        stop("'status' must be numeric with elements 0 or 1!")
+        stop("'status' must be numeric with elements 0 or 1!", call. = FALSE)
       }
     }
 
@@ -367,11 +383,11 @@ mcs_mileage_data <- function(data = NULL,
   if (purrr::is_null(data)) {
     # Vector based approach ----------------------------------------------------
     if (!is_characteristic(mileage)) {
-      stop("'mileage' must be numeric!")
+      stop("'mileage' must be numeric!", call. = FALSE)
     }
 
     if (!is_characteristic(time)) {
-      stop("'time' must be numeric!")
+      stop("'time' must be numeric!", call. = FALSE)
     }
 
     if (purrr::is_null(id)) {
@@ -380,7 +396,7 @@ mcs_mileage_data <- function(data = NULL,
 
     if (!purrr::is_null(status)) {
       if (!is_status(status)) {
-        stop("'status' must be numeric with elements 0 or 1!")
+        stop("'status' must be numeric with elements 0 or 1!", call. = FALSE)
       }
       tbl <- tibble::tibble(
         mileage = mileage,
@@ -399,11 +415,11 @@ mcs_mileage_data <- function(data = NULL,
   } else {
     # Data based approach ------------------------------------------------------
     if (!is_characteristic(dplyr::select(data, {{mileage}})[[1]])) {
-      stop("'mileage' must be numeric!")
+      stop("'mileage' must be numeric!", call. = FALSE)
     }
 
     if (!is_characteristic(dplyr::select(data, {{time}})[[1]])) {
-      stop("'time' must be numeric!")
+      stop("'time' must be numeric!", call. = FALSE)
     }
 
     data <- tibble::as_tibble(data)
@@ -432,7 +448,7 @@ mcs_mileage_data <- function(data = NULL,
 
     if ("status" %in% names(tbl)) {
       if (!is_status(tbl$status)) {
-        stop("'status' must be numeric with elements 0 or 1!")
+        stop("'status' must be numeric with elements 0 or 1!", call. = FALSE)
       }
 
       tbl <- dplyr::relocate(tbl, "mileage", "time", "status", "id")

diff --git a/R/mcs_delay.R b/R/mcs_delay.R
@@ -340,7 +340,9 @@ mcs_delay_ <- function(data = NULL,
   mcs_output <- list(
     data = data_tbl,
     sim_data = tibble::as_tibble(sim_list),
-    model_estimation = par_list
+    model_estimation = list(
+      delay_distribution = par_list
+    )
   )
 
   class(mcs_output) <- c("wt_mcs_delay", class(mcs_output))
@@ -489,7 +491,7 @@ mcs_delay_register <- function(date_prod,
 
     x_sim <- stats::rlnorm(n = n_rand, meanlog = params[[1]], sdlog = params[[2]])
   } else {
-    stop("No valid distribution!")
+    stop("No valid distribution!", call. = FALSE)
   }
 
   time[is.na(date_register)] <- time[is.na(date_register)] - x_sim
@@ -605,7 +607,7 @@ mcs_delay_report <- function(date_repair,
 
     x_sim <- stats::rlnorm(n = n_rand, meanlog = params[[1]], sdlog = params[[2]])
   } else {
-    stop("No valid distribution!")
+    stop("No valid distribution!", call. = FALSE)
   }
 
   time[status == 0] <- time[status == 0] - x_sim
@@ -761,7 +763,7 @@ mcs_delays <- function(date_prod,
     x_sim_report <- stats::rlnorm(n = n_rand_report, meanlog = params_report[[1]],
                                   sdlog = params_report[[2]])
   } else {
-    stop("No valid distribution!")
+    stop("No valid distribution!", call. = FALSE)
   }
 
   time[is.na(date_register)] <- time[is.na(date_register)] - x_sim_regist

diff --git a/R/mcs_mileage.R b/R/mcs_mileage.R
@@ -158,7 +158,7 @@ mcs_mileage.default <- function(x,
 
   ## Check for different length in time and x:
   if (length(x) != length(time)) {
-    stop("Elements of 'x' and 'time' differ in length!")
+    stop("Elements of 'x' and 'time' differ in length!", call. = FALSE)
   }
 
   mcs_mileage_(

diff --git a/R/mileage_distribution.R b/R/mileage_distribution.R
@@ -134,7 +134,8 @@ dist_mileage.default <- function(x,
   ## Check for negative mileage, stop if TRUE:
   if (any(x < 0, na.rm = TRUE)) {
     stop(
-      "Elements with negative distances are not meaningful and must be removed!"
+      "Elements with negative distances are not meaningful and must be removed!",
+      call. = FALSE
     )
   }
 
@@ -164,6 +165,7 @@ dist_mileage_ <- function(x,
     warning(
       "At least one computed annual distance is infinite and is ignored ",
       "for the estimation step!",
+      call. = FALSE
     )
 
     miles_annual <- miles_annual[!is.infinite(miles_annual)]
@@ -172,7 +174,8 @@ dist_mileage_ <- function(x,
   ## all NA:
   if (all(is.na(miles_annual))) {
     stop(
-      "All computed annual distances are 'NA'. No parameters can be estimated!"
+      "All computed annual distances are 'NA'. No parameters can be estimated!",
+      call. = FALSE
     )
   }
 
@@ -183,13 +186,15 @@ dist_mileage_ <- function(x,
       ### all:
       stop(
         "All computed annual distances are smaller or equal to 0. ",
-        "No parameters can be estimated!"
+        "No parameters can be estimated!",
+        call. = FALSE
       )
     } else {
       ### any:
       warning(
         "At least one computed annual distance is smaller or equal to 0 ",
-        "and is ignored for the estimation step!"
+        "and is ignored for the estimation step!",
+        call. = FALSE
       )
 
       miles_annual <- miles_annual[miles_annual > 0]

diff --git a/R/reliability_data.R b/R/reliability_data.R
@@ -76,11 +76,11 @@ reliability_data <- function(data = NULL,
   if (purrr::is_null(data)) {
     # Vector based approach ----------------------------------------------------
     if (!is_characteristic(x)) {
-      stop("'x' must be numeric!")
+      stop("'x' must be numeric!", call. = FALSE)
     }
 
     if (!is_status(status)) {
-      stop("'status' must be numeric with elements 0 or 1!")
+      stop("'status' must be numeric with elements 0 or 1!", call. = FALSE)
     }
 
     if (purrr::is_null(id)) {
@@ -93,11 +93,11 @@ reliability_data <- function(data = NULL,
   } else {
     # Data based approach -----------------------------------------------------
     if (!is_characteristic(dplyr::select(data, x = {{x}})[[1]])) {
-      stop("'x' must be numeric!")
+      stop("'x' must be numeric!", call. = FALSE)
     }
 
     if (!is_status(dplyr::select(data, status = {{status}})[[1]])) {
-      stop("'status' must be numeric with elements 0 or 1!")
+      stop("'status' must be numeric with elements 0 or 1!", call. = FALSE)
     }
 
     x_def <- dplyr::enexpr(x)