adapted assert_gtfs() to use gtfsio_error()

r-transit · Nov 5, 2021 · 6a24b42 · 6a24b42
1 parent b83a00e
commit 6a24b42
Show file tree

Hide file tree

Showing 9 changed files with 188 additions and 111 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Type: Package
 Package: gtfsio
 Title: Read and Write General Transit Feed Specification (GTFS) Files
-Version: 0.2.0.9012
+Version: 0.2.0.9013
 Authors@R: 
     c(person(given = "Daniel",
              family = "Herszenhut",
@@ -51,3 +51,15 @@ VignetteBuilder:
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.1.1
+Collate: 
+    'gtfsio_error.R'
+    'assert_gtfs.R'
+    'assert_inputs.R'
+    'checks.R'
+    'export_gtfs.R'
+    'get_gtfs_standards.R'
+    'gtfs_methods.R'
+    'gtfs_subset.R'
+    'gtfsio.R'
+    'import_gtfs.R'
+    'new_gtfs.R'
diff --git a/R/assert_gtfs.R b/R/assert_gtfs.R
@@ -1,13 +1,14 @@
 #' GTFS object validator
 #'
+#' @description
 #' Asserts that a GTFS object is valid. Valid objects are those in which:
-#' \itemize{
-#'   \item Every element is named.
-#'   \item Every element inherits from \code{data.frame}s.
-#' }
+#'
+#' - Every element is named.
+#' - Every element inherits from `data.frame`s.
+#'
 #' The exception to the second rule are objects that contain an element named
-#' \code{"."}. In such case, this element is actually composed by a named list
-#' of elements who inherit from \code{data.frame}s.
+#' `"."`. In such case, this element is actually composed by a named list of
+#' elements who inherit from `data.frame`s.
 #'
 #' @param x A GTFS object.
 #'
@@ -26,54 +27,90 @@ assert_gtfs <- function(x) {
 
   # check if all elements are named
 
-  if (is.null(names(x))) stop("Every element in a GTFS object must be named.")
+  if (is.null(names(x))) error_gtfs_not_fully_named()
 
   x_names <- names(x)[! names(x) %chin% ""]
-  if (length(x_names) != length(x))
-    stop("Every element in a GTFS object must be named.")
+  if (length(x_names) != length(x)) error_gtfs_not_fully_named()
 
   # check if all elements (other than '.') inherit from 'data.frame'
 
   no_dot_names <- setdiff(names(x), ".")
   inherit_df <- vapply(x[no_dot_names], inherits, logical(1), "data.frame")
 
-  if (!all(inherit_df))
-    stop(
-      "Every element in a GTFS object must inherit from 'data.frame'. ",
-      "The following elements do not: ",
-      paste0("'", no_dot_names[!inherit_df], "'", collapse = ", ")
-    )
+  if (!all(inherit_df)) error_table_not_df(no_dot_names, inherit_df)
 
   # if '.' element exists
 
   if ("." %chin% names(x)) {
 
     # check if it is a list
 
-    if (!is.list(x[["."]]))
-      stop("The '.' element of a GTFS object must be a list.")
+    if (!is.list(x[["."]])) error_dot_not_list()
 
     # check if all elements are named
 
-    if (is.null(names(x[["."]])))
-      stop("Every element inside '.' must be named.")
+    if (is.null(names(x[["."]]))) error_dot_not_fully_named()
 
     dot_names <- names(x[["."]])[! names(x[["."]]) %chin% ""]
-    if (length(dot_names) != length(x[["."]]))
-      stop("Every element inside '.' must be named.")
+    if (length(dot_names) != length(x[["."]])) error_dot_not_fully_named()
 
     # check if all elements inherit from 'data.frame'
 
     dot_inherit_df <- vapply(x[["."]], inherits, logical(1), "data.frame")
-    if (!all(dot_inherit_df))
-      stop(
-        "Every element inside '.' must inherit from 'data.frame'. ",
-        "The following elements do not: ",
-        paste0("'", names(x[["."]])[!dot_inherit_df], "'", collapse = ", ")
-      )
+    if (!all(dot_inherit_df)) error_dot_table_not_df(x, dot_inherit_df)
 
   }
 
   return(x)
 
 }
+
+
+# errors ------------------------------------------------------------------
+
+
+#' @include gtfsio_error.R
+error_gtfs_not_fully_named <- parent_function_error(
+  "Every element in a GTFS object must be named.",
+  subclass = "gtfs_not_fully_named"
+)
+
+error_table_not_df <- function(no_dot_names, inherit_df) {
+  parent_call <- sys.call(-1)
+  message <- paste0(
+    "Every element in a GTFS object must inherit from 'data.frame'. ",
+    "The following elements do not: ",
+    paste0("'", no_dot_names[!inherit_df], "'", collapse = ", ")
+  )
+
+  gtfsio_error(
+    message = message,
+    subclass = "gtfs_table_not_df",
+    call = parent_call
+  )
+}
+
+error_dot_not_list <- parent_function_error(
+  "The '.' element of a GTFS object must be a list.",
+  subclass = "gtfs_dot_not_list"
+)
+
+error_dot_not_fully_named <- parent_function_error(
+  "Every element inside '.' must be named.",
+  subclass = "gtfs_dot_not_fully_named"
+)
+
+error_dot_table_not_df <- function(x, dot_inherit_df) {
+  parent_call <- sys.call(-1)
+  message <- paste0(
+    "Every element inside '.' must inherit from 'data.frame'. ",
+    "The following elements do not: ",
+    paste0("'", names(x[["."]])[!dot_inherit_df], "'", collapse = ", ")
+  )
+
+  gtfsio_error(
+    message = message,
+    subclass = "gtfs_dot_table_not_df",
+    call = parent_call
+  )
+}
diff --git a/R/assert_inputs.R b/R/assert_inputs.R
@@ -171,68 +171,41 @@ assert_class <- function(x, class, n_call = -1) {
 # errors ------------------------------------------------------------------
 
 
-error_bad_class_argument <- function() {
-  parent_call <- sys.call(-1)
-  gtfsio_error(
-    "'class' must be a string.",
-    subclass = "bad_class_argument",
-    call = parent_call
-  )
-}
-
-error_bad_len_argument <- function() {
-  parent_call <- sys.call(-1)
-  gtfsio_error(
-    "'length' must be an integer vector with length 1.",
-    subclass = "bad_len_argument",
-    call = parent_call
-  )
-}
-
-error_bad_null_ok_argument <- function() {
-  parent_call <- sys.call(-1)
-  gtfsio_error(
-    "'null_ok' must be a logical vector with length 1.",
-    subclass = "bad_null_ok_argument",
-    call = parent_call
-  )
-}
-
-error_bad_var_name_argument <- function() {
-  parent_call <- sys.call(-1)
-  gtfsio_error(
-    "'var_name' must be a string.",
-    subclass = "bad_var_name_argument",
-    call = parent_call
-  )
-}
-
-error_bad_subset_of_argument <- function() {
-  parent_call <- sys.call(-1)
-  gtfsio_error(
-    "'subset_of' must be a character vector.",
-    subclass = "bad_subset_of_argument",
-    call = parent_call
-  )
-}
-
-error_bad_named_argument <- function() {
-  parent_call <- sys.call(-1)
-  gtfsio_error(
-    "'named' must be a logical vector with length 1.",
-    subclass = "bad_named_argument",
-    call = parent_call
-  )
-}
-
-error_bad_n_call_argument <- function() {
-  parent_call <- sys.call(-1)
-  gtfsio_error(
-    "'n_call' must be a negative integer.",
-    subclass = "bad_n_call_argument",
-    call = parent_call
-  )
-}
+#' @include gtfsio_error.R
+error_bad_class_argument <- parent_function_error(
+  "'class' must be a string.",
+  subclass = "bad_class_argument"
+)
+
+error_bad_len_argument <- parent_function_error(
+  "'length' must be an integer vector with length 1.",
+  subclass = "bad_len_argument"
+)
+
+error_bad_null_ok_argument <- parent_function_error(
+  "'null_ok' must be a logical vector with length 1.",
+  subclass = "bad_null_ok_argument"
+)
+
+error_bad_var_name_argument <- parent_function_error(
+  "'var_name' must be a string.",
+  subclass = "bad_var_name_argument"
+)
+
+error_bad_subset_of_argument <- parent_function_error(
+  "'subset_of' must be a character vector.",
+  subclass = "bad_subset_of_argument"
+)
+
+error_bad_named_argument <- parent_function_error(
+  "'named' must be a logical vector with length 1.",
+  subclass = "bad_named_argument"
+)
+
+error_bad_n_call_argument <- parent_function_error(
+  "'n_call' must be a negative integer.",
+  subclass = "bad_n_call_argument"
+)
 
 error_x_wrong_class <- function(input_name,
                                 vector_name,

diff --git a/R/gtfsio_error.R b/R/gtfsio_error.R
@@ -4,6 +4,8 @@
 #' @param subclass The subclass of the error.
 #' @param call A call to associate the error with.
 #'
+#' @family error constructors
+#'
 #' @keywords internal
 gtfsio_error <- function(message,
                          subclass = character(0),
@@ -27,3 +29,23 @@ gtfsio_error <- function(message,
   stop(error)
 
 }
+
+
+#' Parent error function constructor
+#'
+#' Creates a function that raises an error that is assigned to the function in
+#' which the error was originally seen. Useful to prevent big repetitive
+#' `gtfsio_error()` calls in the "main" functions.
+#'
+#' @param message The message to inform about the error.
+#' @param subclass The subclass of the error.
+#'
+#' @family error constructors
+#'
+#' @keywords internal
+parent_function_error <- function(message, subclass = character(0)) {
+  function() {
+    parent_call <- sys.call(-1)
+    gtfsio_error(message, subclass, parent_call)
+  }
+}
diff --git a/codemeta.json b/codemeta.json
@@ -10,7 +10,7 @@
   "codeRepository": "https://github.com/r-transit/gtfsio",
   "issueTracker": "https://github.com/r-transit/gtfsio/issues",
   "license": "https://spdx.org/licenses/MIT",
-  "version": "0.2.0.9012",
+  "version": "0.2.0.9013",
   "programmingLanguage": {
     "@type": "ComputerLanguage",
     "name": "R",
@@ -129,7 +129,7 @@
       "sameAs": "https://CRAN.R-project.org/package=zip"
     }
   ],
-  "fileSize": "268619.523KB",
+  "fileSize": "268621.761KB",
   "keywords": [
     "r",
     "gtfs"