chore: synced file(s) with ssi-dk/diseasy

.github/sync.yaml

@@ -0,0 +1,38 @@
+ssi-dk/diseasystore:
+  - .github/workflows/synchronise-files.yaml
+  - .github/sync.yaml
+
+  - .lintr
+  - _pkgdown.yml
+  - inst/WORDLIST
+
+  - R/0_linters.R
+  - tests/testthat/test-0_linters.R
+
+  - R/0_R6_utils.R
+  - tests/testthat/test-0_R6_utils.R
+
+  - R/0_documentation.R
+  - tests/testthat/test-0_documentation.R
+
+  - tests/testthat/test-0_rd_files.R
+
+
+ssi-dk/diseasy:
+  - .github/workflows/synchronise-files.yaml
+  - .github/sync.yaml
+
+  - .lintr
+  - _pkgdown.yml
+  - inst/WORDLIST
+
+  - R/0_linters.R
+  - tests/testthat/test-0_linters.R
+
+  - R/0_R6_utils.R
+  - tests/testthat/test-0_R6_utils.R
+
+  - R/0_documentation.R
+  - tests/testthat/test-0_documentation.R
+
+  - tests/testthat/test-0_rd_files.R

.github/workflows/all-workflows.yaml

@@ -1,17 +1,11 @@
-# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples
-# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
-on:
-  push:
-  pull_request:
-    types: [opened, reopened]
-  release:
-  workflow_dispatch:
+on: [push, pull_request, release, workflow_dispatch]
 
 name: CI tests
 jobs:
 
   # We call the reusable workflow that triggers all AEF-DDF workflows
   run-all-AEF-DFF-workflows:
+    if: github.event_name == 'pull_request' && github.event.pull_request.head.repo.full_name == github.event.pull_request.base.repo.full_name
     name: ⚙️ Run all AEF-DDF workflows
     uses: ssi-dk/AEF-DDF/.github/workflows/workflow-dispatcher.yaml@workflows
     with:

.github/workflows/synchronise-files.yaml

@@ -0,0 +1,22 @@
+on:
+  push:
+    branches:
+      - main
+  workflow_dispatch:
+
+jobs:
+  sync:
+    name: 🔄 Sync diseasyverse files
+    runs-on: ubuntu-latest
+    permissions: write-all
+    steps:
+      - name: Checkout Repository
+        uses: actions/checkout@master
+      - name: Run GitHub File Sync
+        uses: BetaHuhn/repo-file-sync-action@v1
+        with:
+          GH_PAT: ${{ secrets.GH_PAT }}
+          CONFIG_PATH: .github/sync.yaml
+          COMMIT_PREFIX: "chore: "
+          PR_BODY: Automatically synchronise files between diseasyverse repositories
+          COMMIT_EACH_FILE: false

.lintr

@@ -1,6 +1,5 @@
 linters: c(
-    nolint_line_length_linter(120),
-    nolint_position_linter(120),
+    diseasy_code_linters(),
     all_linters(
       line_length_linter = NULL,          # We use 120, nolint-aware line length linter instead
       cyclocomp_linter = NULL,            # Not required in diseasy style guide

DESCRIPTION

@@ -43,6 +43,7 @@ Imports:
 Suggests:
     curl,
     knitr,
+    pkgload,
     R.utils,
     rmarkdown,
     RSQLite,

NAMESPACE

@@ -14,8 +14,6 @@ export(key_join_count)
 export(key_join_max)
 export(key_join_min)
 export(key_join_sum)
-export(nolint_line_length_linter)
-export(nolint_position_linter)
 export(to_diseasystore_case)
 importFrom(R6,R6Class)
 importFrom(dbplyr,window_order)

R/0_R6_utils.R

@@ -21,13 +21,53 @@
 
 
 #' cat printing with default new line
-#' @param ...  The normal input to cat
-#' @param file Path of an output file to append the output to
-#' @param sep The separator given to cat
+#' @param ...
+#'   The normal input to cat
+#' @param file
+#'   Path of an output file to append the output to
+#' @param sep (`character`)\cr
+#'   The separator given to cat
+#' @param max_width (`numeric`)\cr
+#'   The maximum number of characters to print before inserting a newline.
+#'   NULL (default) does not break up lines.
 #' @noRd
-printr <- function(..., file = nullfile(), sep = "") {
-  withr::local_output_sink(new = file, split = TRUE, append = TRUE)
-  cat(..., "\n", sep = sep)
+printr <- function(..., file = nullfile(), sep = "", max_width = NULL) {
+  sink(file = file, split = TRUE, append = TRUE, type = "output")
+
+  print_string <- paste(..., sep = sep)
+
+  # If a width limit is set, we iteratively determine the words that exceed the limit and
+  # insert a newline
+  if (!is.null(max_width)) {
+
+    # Get the current state of the string
+    split_string <- stringr::str_split_1(print_string, "\n")
+    segment_lengths <- purrr::map_dbl(split_string, ~ length(stringr::str_split_1(., " ")))
+
+    # While segments contain more than one word and is longer than max_width, split these segments
+    while (any(nchar(split_string) > max_width & segment_lengths > 1)) {
+      split_string <- split_string |>
+        purrr::map_if(
+          ~ nchar(.) > max_width,
+          ~ {
+            break_locations <- stringr::str_locate_all(., " |$")[[1]][, 1]
+            split_width <- break_locations[max(which((break_locations - 1) < max_width))]
+
+            stringr::str_replace(., paste0("(?<=^.{", split_width - 1, "})(\\w*) "), "\\1\n")
+          }
+        ) |>
+        stringr::str_split(stringr::fixed("\n")) |>
+        purrr::reduce(c)
+
+      segment_lengths <- purrr::map_dbl(split_string, ~ length(stringr::str_split_1(., " ")))
+    }
+
+    # Collapse segments with the newline
+    print_string <- paste(split_string, collapse = "\n")
+  }
+
+  cat(print_string, "\n", sep = sep)
+  sink()
 }
 
 
@@ -78,7 +118,7 @@
   checkmate::assert(
     checkmate::check_function(conn, null.ok = TRUE),
     checkmate::check_class(conn, "DBIConnection", null.ok = TRUE),
-    checkmate::check_character(conn, null.ok = TRUE),
+    checkmate::check_character(conn, len = 1, null.ok = TRUE),
     add = coll
   )
   checkmate::assert_choice(type, c("source_conn", "target_conn"), add = coll)

R/0_documentation.R

@@ -1,8 +1,16 @@
-rd_aggregation <- function(type = "param") {
+rd_activity_units <- function(type = "param") {
+  checkmate::assert_choice(type, c("param", "field"))
+  paste("(`list(list())`)\\cr",
+        "A nested list of all possible 'units' of activity that can be opened or closed.",
+        ifelse(type == "field", " Read only.", ""))
+}
+
+
+rd_stratification <- function(type = "param") {
   checkmate::assert_choice(type, c("param", "field"))
   paste("(`list`(`quosures`))\\cr",
         "Default NULL.",
-        "If given, expressions in aggregation evaluated to give the aggregation level.",
+        "If given, expressions in stratification evaluated to give the stratification level.",
         ifelse(type == "field", " Read only.", ""))
 }
 
@@ -15,6 +23,22 @@ rd_diseasystore_label <- function(type = "param") {
 }
 
 
+rd_contact_basis <- function(type = "param") {
+  checkmate::assert_choice(type, c("param", "field"))
+  paste("(`list(list())`)\\cr",
+        "A nested list with all the needed information for the contact_basis\\cr",
+        "* `counts` contains the age stratified contact counts across the arenas of the basis",
+        "  (e.g. 'work', 'home', 'school', 'other')\\cr",
+        "* `proportion` contains a list of the proportion of population in each age-group\\cr",
+        "* `demography` contains a `data.frame` with the columns\\cr",
+        "  * `age` (`integer()`) 1-year age group\\cr",
+        "  * `population` (`numeric()`) size of population in age group\\cr",
+        "  * `proportion` (`numeric()`) proportion of total population in age group\\cr",
+        "* `description` contains information about the source of the contact basis.",
+        ifelse(type == "field", " Read only.", ""))
+}
+
+
 rd_observable <- function(type = "param") {
   checkmate::assert_choice(type, c("param", "field"))
   paste("(`character`)\\cr",
@@ -96,7 +120,7 @@ rd_start_date <- function(type = "param") {
 rd_slice_ts <- function(type = "param") {
   checkmate::assert_choice(type, c("param", "field"))
   paste("(`Date` or `character`)\\cr",
-        "Date to slice the database on (used if source_conn is a database).",
+        "Date or timestamp (parsable by `as.POSIXct`) to slice the database on (used if source_conn is a database).",
         ifelse(type == "field", " Read only.", ""))
 }
 
@@ -120,12 +144,12 @@ rd_.data <- function(type = "param") {
 rd_describe <- "Prints a human readable report of the internal state of the module."
 
 rd_get_results_description <- paste(
-  "The primary method used to request model results of a given observable at a given aggregation."
+  "The primary method used to request model results of a given observable at a given stratification"
 )
 
 rd_get_results_return <- paste(
-  "A `tibble` [tibble::tibble] with predictions at the level specified by aggregation level.",
-  "In addition to aggregation columns, the output has the columns:\\cr",
+  "A `tibble` [tibble::tibble] with predictions at the level specified by stratification level.",
+  "In addition to stratification columns, the output has the columns:\\cr",
   "  date (`Date`) specifying the date of the prediction\\cr",
   "  realization_id (`character`) giving a unique id for each realization in the ensemble\\cr",
   "  model (`character`) the name (classname) of the model used to provide the prediction."
@@ -154,3 +178,18 @@ rd_training_length <- paste(
   "(`numeric`)\\cr",
   "The number of days that should be included in the training of the model."
 )
+
+
+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."
+)
+
+rd_activity_weights <- paste(
+  "(`numeric(4)`)\\cr",
+  "vector of weights for the four types of contacts. If NULL (default), no weighting is done."
+)

R/0_linters.R

@@ -1,7 +1,26 @@
-#' The custom linters of `diseasy`
+#' @title
+#'   The custom linters of `diseasy`
+#' @description
+#'   A curated list of linters to ensure adherence to the `diseasy` documentation and code standards
 #' @name diseasy_linters
+#' @examples
+#'   diseasy_code_linters()
+#' @return A list of linters
+#' @noRd
+diseasy_code_linters <- function() {
+  linters <- list(
+    nolint_position_linter(120),
+    nolint_line_length_linter(120),
+    non_ascii_linter()
+  )
+
+  return(linters)
+}
+
+
+#' @rdname diseasy_linters
 #' @description
-#' nolint_position_linter: Check that the `nolint:` statements occur after the character limit
+#' nolint_position_linter: Ensure `nolint:` statements occur after the character limit
 #'
 #' @param length maximum line length allowed. Default is 80L (Hollerith limit).
 #' @returns A list of `lintr::Lint`
@@ -22,8 +41,8 @@
 #' @seealso
 #' - [lintr::linters] for a complete list of linters available in lintr.
 #' - <https://style.tidyverse.org/syntax.html#long-lines>
-#' @export
 #' @importFrom rlang .data
+#' @noRd
 nolint_position_linter <- function(length = 80L) {
   general_msg <- paste("`nolint:` statements start at", length + 1, "characters.")
 
@@ -66,9 +85,9 @@
 }
 
 
-#' @name diseasy_linters
+#' @rdname diseasy_linters
 #' @description
-#' nolint_line_length_linter: Check that lines adhere to a given character limit, ignoring `nolint` statements
+#' nolint_line_length_linter: Ensure lines adhere to a given character limit, ignoring `nolint` statements
 #'
 #' @param length maximum line length allowed. Default is 80L (Hollerith limit).
 #' @examples
@@ -85,8 +104,8 @@
 #'   linters = c(nolint_line_length_linter(length = 20L), lintr::object_name_linter())
 #' )
 #'
-#' @export
 #' @importFrom rlang .data
+#' @noRd
 nolint_line_length_linter <- function(length = 80L) {
   general_msg <- paste("Lines should not be more than", length, "characters.")
 
@@ -118,3 +137,66 @@
     }
   )
 }
+
+
+#' @rdname diseasy_linters
+#' @description
+#' non_ascii_linter: Ensure the code base only contains ASCII symbols
+#'
+#' @examples
+#' ## non_ascii_linter
+#' # will produce lints
+#' lintr::lint(
+#'   text = "a-å",                                                                                                      # nolint: non_ascii_linter
+#'   linters = non_ascii_linter()
+#' )
+#'
+#' # okay
+#' lintr::lint(
+#'   text = "a-z",                                                                                                      # nolint: non_ascii_linter
+#'   linters = non_ascii_linter()
+#' )
+#'
+#' @importFrom rlang .data
+#' @noRd
+non_ascii_linter <- function() {
+  general_msg <- paste("Code should not contain non-ASCII characters")
+
+  lintr::Linter(
+    function(source_expression) {
+
+      # Only go over complete file
+      if (!lintr::is_lint_level(source_expression, "file")) {
+        return(list())
+      }
+
+      detection_info <- source_expression$file_lines |>
+        stringr::str_locate_all(stringr::regex(r"{[^\x00-\x7f]}", ignore_case = TRUE))
+
+      detection_info <- purrr::map2(
+        detection_info,
+        seq_along(detection_info),
+        ~ dplyr::mutate(as.data.frame(.x), line_number = .y)
+      )
+
+      detection_info <- detection_info |>
+        purrr::reduce(rbind) |>
+        dplyr::filter(!is.na(.data$start))
+
+      purrr::pmap(
+        detection_info,
+        \(start, end, line_number) {
+          lintr::Lint(
+            filename = source_expression$filename,
+            line_number = line_number,
+            column_number = start,
+            type = "style",
+            message = paste(general_msg, "non-ASCII character found"),
+            line = source_expression$file_lines[line_number],
+            ranges = list(c(start, end))
+          )
+        }
+      )
+    }
+  )
+}

inst/WORDLIST

@@ -53,6 +53,7 @@ nrow
 OO
 ORCID
 
+parsable
 PascalCase
 POSIXct
 pid