Merge pull request #182 from ssi-dk/feature/use-documentation-templates

Author: RasmusSkytte

R/0_documentation.R

@@ -8,8 +8,7 @@ rd_activity_units <- function(type = "param") {
 
 rd_stratification <- function(type = "param") {
   checkmate::assert_choice(type, c("param", "field"))
-  paste("(`list`(`quosures`))\\cr",
-        "Default NULL.",
+  paste("(`list`(`quosures`) or `NULL`)\\cr",
         "Use `rlang::quos(...)` to specify stratification.",
         "If given, expressions in stratification evaluated to give the stratification level.",
         ifelse(type == "field", "Read only.", ""))
@@ -62,7 +61,6 @@ rd_prediction_length <- function(type = "param") {
 rd_quantiles <- function(type = "param") {
   checkmate::assert_choice(type, c("param", "field"))
   paste("(`list`(`numeric`))\\cr",
-        "Default NULL.",
         "If given, results are returned at the quantiles given.",
         ifelse(type == "field", "Read only.", ""))
 }
@@ -106,7 +104,7 @@ rd_target_conn <- function(type = "param") {
 rd_schema <- function(type = "param") {
   checkmate::assert_choice(type, c("param", "field"))
   paste("(`character`)\\cr",
-        "A database schema",
+        "A database schema.",
         ifelse(type == "field", "Read only.", ""),
         "If the database backend does not support schema, the tables will be prefixed with <schema>.")
 }
@@ -178,15 +176,15 @@ rd_get_results_return <- paste(
 rd_get_results_seealso <- "[diseasy::DiseasyObservables]"
 
 
-rd_side_effects <- "NULL (called for side effects)"
+rd_side_effects <- "`NULL` (called for side effects)"
 
 
 rd_age_cuts_lower <- paste(
   "(`numeric`)\\cr",
-  "vector of ages defining the lower bound for each age group. If NULL (default), age groups of contact_basis is used."
+  "vector of ages defining the lower bound for each age group. If `NULL`, age groups of contact_basis is used."
 )
 
 rd_activity_weights <- paste(
   "(`numeric(4)`)\\cr",
-  "vector of weights for the four types of contacts. If NULL (default), no weighting is done."
+  "vector of weights for the four types of contacts. If `NULL`, no weighting is done."
 )

R/0_linters.R

@@ -12,7 +12,8 @@ diseasy_code_linters <- function() {
     "nolint_position_linter" = nolint_position_linter(120),
     "nolint_line_length_linter" = nolint_line_length_linter(120),
     "non_ascii_linter" = non_ascii_linter(),
-    "param_and_field_linter" = param_and_field_linter()
+    "param_and_field_linter" = param_and_field_linter(),
+    "documentation_template_linter" = documentation_template_linter()
   )
 
   return(linters)
@@ -211,7 +212,7 @@ non_ascii_linter <- function() {
 #'
 #' # okay
 #' lintr::lint(
-#'   text = "#' @param (`numeric()`)\cr",
+#'   text = "#' @param test (`numeric()`)\cr",
 #'   linters = param_and_field_linter()
 #' )
 #' @importFrom rlang .data
@@ -290,3 +291,85 @@ param_and_field_linter <- function() {
     }
   )
 }
+
+
+#' @rdname diseasy_linters
+#' @description
+#' documentation_template_linter: Ensure documentation templates are used if available.
+#'
+#' @examples
+#' ## documentation_template_linter
+#' rd_parameter <- "(`character`)\cr Description of parameter" # Create a template for the "parameter" parameter
+#'
+#' # will produce lints
+#' lintr::lint(
+#'   text = "#' @param parameter (`character`)\cr Description of parameter",                                            # nolint: documentation_template_linter
+#'   linters = documentation_template_linter()
+#' )
+#'
+#' # okay
+#' lintr::lint(
+#'   text = "#' @param parameter `r rd_parameter`",
+#'   linters = documentation_template_linter()
+#' )
+#'
+#' @importFrom rlang .data
+#' @noRd
+documentation_template_linter <- function() {
+  general_msg <- paste("Documentation templates should used if available!")
+
+  lintr::Linter(
+    function(source_expression) {
+
+      # Only go over complete file
+      if (!lintr::is_lint_level(source_expression, "file")) {
+        return(list())
+      }
+
+      # Find all @param and @field lines. All other lines become NA
+      detection_info <- source_expression$file_lines |>
+        stringr::str_extract(r"{#' ?@(param|field).*}")
+
+      # Convert to data.frame and determine line number
+      detection_info <- data.frame(
+        rd_line = detection_info,
+        line_number = seq_along(detection_info)
+      )
+
+      # Remove non param/field lines
+      detection_info <- detection_info |>
+        dplyr::filter(!is.na(.data$rd_line))
+
+      # Remove triple-dot-ellipsis params
+      detection_info <- detection_info |>
+        dplyr::filter(!stringr::str_detect(.data$rd_line, "@param +\\.{3}"))
+
+      # Remove auto-generated documentation
+      detection_info <- detection_info |>
+        dplyr::filter(!stringr::str_detect(.data$rd_line, r"{@(param|field) +[\.\w]+ +`r }"))
+
+      # Extract the parameter
+      detection_info <- detection_info |>
+        dplyr::mutate("param" = stringr::str_extract(.data$rd_line, r"{(@(param|field) +)([\.\w]+)}", group = 3))
+
+      # Detect if template exists
+      detection_info <- detection_info |>
+        dplyr::mutate("rd_template" = paste0("rd_", .data$param)) |>
+        dplyr::filter(.data$rd_template %in% names(as.list(base::getNamespace(devtools::as.package(".")$package)))) |>
+        dplyr::select(!"param")
+
+      purrr::pmap(
+        detection_info,
+        \(rd_line, line_number, rd_template) {
+          lintr::Lint(
+            filename = source_expression$filename,
+            line_number = line_number,
+            type = "style",
+            message = paste(general_msg, "Template", rd_template, "available."),
+            line = source_expression$file_lines[line_number]
+          )
+        }
+      )
+    }
+  )
+}

R/DiseasystoreBase.R

@@ -273,15 +273,10 @@ DiseasystoreBase <- R6::R6Class(
     },
 
     #' @description
-    #'   Joins various features from feature store assuming a primary feature (observable)
-    #'   that contains keys to witch the secondary features (defined by `stratification`) can be joined.
-    #' @param observable (`character`)\cr
-    #'   The name of a feature defined in the feature store
-    #' @param stratification (`list`(`quosures`) or `NULL`)\cr
-    #'   Expressions in `stratification` are evaluated to find appropriate features.
-    #'   These are then joined to the observable feature before `stratification` is performed.
-    #'
-    #'   If `NULL` (default) no stratification is performed.
+    #'   Joins various features from the feature store assuming a primary feature (observable)
+    #'   that contains keys to witch the secondary features (defined by `stratification`) are joined.
+    #' @param observable `r rd_observable()`
+    #' @param stratification `r rd_stratification()`
     #' @param start_date `r rd_start_date()`
     #' @param end_date `r rd_end_date()`
     #' @return

R/drop_diseasystore.R

@@ -2,8 +2,8 @@
 #' @importFrom rlang .data
 #' @param pattern (`character(1)`)\cr
 #'   Pattern to match the tables by
-#' @param schema (`character(1)`)\cr
-#'   Schema the diseasystore uses to store data in
+#' @param schema `r rd_schema()`
+#'   The location where the `diseasystore` stores data.
 #' @param conn `r rd_conn()`
 #' @return `r rd_side_effects`
 #' @examplesIf requireNamespace("RSQLite", quietly = TRUE)

R/source_conn_helpers.R

@@ -5,7 +5,7 @@
 #'  * source_conn_path: static url / directory.
 #'    This helper determines whether source_conn is a file path or URL and creates the full path to the
 #'    the file as needed based on the type of source_conn.
-#' @param source_conn (`character(1)`)\cr
+#' @param source_conn (`character(1)`)\cr                                                                               # nolint: documentation_template_linter
 #'   File location (path or URL).
 #' @param file (`character(1)`)\cr
 #'   Name (including path) of the file at the location.

R/test_diseasystore.R

@@ -15,8 +15,7 @@
 #'   Should take a `skip_backend` that does not open connections for the given backends.
 #' @param data_files (`character()`)\cr
 #'   List of files that should be available when testing.
-#' @param target_schema (`character(1)`)\cr
-#'   The data base schema where the tests should be run.
+#' @param target_schema `r rd_target_schema()`
 #' @param test_start_date (`Date`)\cr
 #'   The earliest date to retrieve data from during tests.
 #' @param skip_backends (`character()`)\cr

man/DiseasystoreBase.Rd

@@ -56,3 +56,21 @@ test_that("param_and_field_linter works", {
   lintr::expect_lint("#' @param test (`type`)\\cr", NULL, param_and_field_linter())
   lintr::expect_lint("#' @field test (`type`)\\cr", NULL, param_and_field_linter())
 })
+
+
+test_that("documentation_template_linter works", {
+  skip_if_not_installed("lintr")
+  skip_if_not_installed("devtools")
+
+  lintr::expect_lint(
+    "#' @param observable (`character(1)`)\\cr", # rd_observable defined in R/0_documentation.R                         # nolint: documentation_template_linter
+    list("line_number" = 1, "type" = "style"),
+    documentation_template_linter()
+  )
+
+  lintr::expect_lint(
+    "#' @param observable `r rd_test`",
+    NULL,
+    documentation_template_linter()
+  )
+})