Update branch with existing FB changes (#6)

* README edits (#4)

* Fix couple of typos

* Tweaks to example code in README

* Tweaks to example code in README

* Merge doc_title branch in (#5)

* Add document_title parameter to report rendering

* Add document_title argument to spcr_make_report() - this gives the HTML document a customisable title for its <title> tag

* Add TOC to report output

* Add internal data for easier testing

* Big changes to Rmd

* Big changes to Rmd

.Rbuildignore

@@ -3,4 +3,5 @@
 ^LICENSE\.md$
 ^README\.Rmd$
 
-^local_development_files/
+^local_development_files/
+^data-raw$

DESCRIPTION

@@ -1,20 +1,20 @@
 Package: SPCreporter
 Title: Creates Metric Reports using Statistical Process Control in the NHS style
-Version: 0.1.5.1
+Version: 0.1.5.3
 Authors@R: 
     person("Tom", "Smith", , "[email protected]", role = c("aut", "cre"))
-Description: Takes a dataset file and a configuration file to produce an html
-    report with each metric presented as an SPC chart.  The initial rendering of
+Description: Takes a dataset file and a configuration file to produce an HTML
+    report with each metric presented as an SPC chart. The initial rendering of
     the report contains the charts folded to enable quick scanning of
-    "variation" and "assurance" status.  Each metric can be unfolded to reveal
+    "variation" and "assurance" status. Each metric can be unfolded to reveal
     the SPC chart to support clinical and management planning. 
-    The NHSRplothtedots package is used for SPC calcuations, and the "variation"
+    The NHSRplotthedots package is used for SPC calculations, and the "variation"
     and "assurance" is in line with the popular standard within the UK's
     National Health Service (NHS).
 License: MIT + file LICENSE
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.1
+RoxygenNote: 7.2.2
 URL: https://github.com/ThomUK/SPCreporter
 BugReports: https://github.com/ThomUK/SPCreporter/issues
 Imports: 

R/spcr_lengthen_measure_data.R

@@ -1,39 +1,60 @@
 #' Transform the data from wide to long format
 #'
-#' @param .data dataframe.  Data in wide format.
-#' @param frequency dtring.  Typically "weekly" or "monthly"
+#' @param .data data frame. Data in wide format.
+#' @param frequency string. Typically "weekly" or "monthly"
 #'
-#' @return Dataframe in long format
+#' @returns Data frame in long format
 #' @noRd
 #'
 spcr_lengthen_measure_data <- function(.data, frequency) {
   assertthat::assert_that(
     inherits(.data, "data.frame"),
-    msg = "spcr_lengthen_measure_data: The data must be a dataframe."
+    msg = "spcr_lengthen_measure_data: The data must be a data frame."
   )
 
-  # pivot incoming measure_data from wide to long
-  long_data <- .data |>
+  assertthat::assert_that(is.character(frequency),
+                          msg = usethis::ui_oops(
+                            "spcr_lengthen_measure_data: frequency variable (taken from measure_data
+        list name) is not a string."
+                          ))
+
+  ymd_regex <- "^[0-9]{2,}-[:alnum:]+-[0-9]+$"
+
+
+  assertthat::assert_that(
+    all(purrr::map_lgl(names(.data),
+                       function(x) {
+                         x %in% c("ref", "measure_name", "comment") |
+                           stringr::str_detect(x, "^[0-9]{5}$") |
+                           stringr::str_detect(x, ymd_regex)
+                       })
+    ),
+    msg = "spcr_lengthen_measure_data: The data contains invalid column names.")
+
+
+  convert_date <- function(x) {
+    if (grepl("^[0-9]{5}$", x)) {
+      x |>
+        as.numeric() |>
+        lubridate::as_date(origin = "1899-12-30")
+    } else lubridate::ymd(x)
+  }
+
+
+  # pivot incoming measure_data from wide to long,
+  # and convert date column to date format
+  .data |>
     tidyr::pivot_longer(
-      -c("ref", "measure_name", "comment"),
-      names_to = "date", values_to = "value"
+      cols = !any_of(c("ref", "measure_name", "comment")),
+      names_to = "date"
     ) |>
+    dplyr::select(!comment) |>
+    dplyr::filter(!is.na(value)) |>
     dplyr::mutate(frequency = frequency) |>
-    dplyr::select(-comment) |>
-    dplyr::filter(!is.na(value))
-
-  # handle varying date column heading formats
-  suppressWarnings(
-    long_data <- long_data |>
-      dplyr::mutate(
-        date = dplyr::case_when(
-
-          # when the date character string contains a "-"
-          grepl("-", date) == TRUE ~ as.Date(date, format = "%Y-%m-%d"),
-
-          # otherwise, its an excel character string that needs an origin
-          TRUE ~ as.Date(as.numeric(date), origin = "1899-12-30")
-        )
-      )
-  )
+    # need to do one row at a time otherwise grepl() throws an error
+    # case_when() would be better, but throws warnings:
+    # https://community.rstudio.com/t/why-am-i-getting-warnings-in-my-case-when-process/154418
+    dplyr::rowwise() |>
+    dplyr::mutate(across(date, convert_date)) |>
+    dplyr::ungroup()
 }

R/spcr_make_data_bundle.R

@@ -7,7 +7,9 @@
 #' @return dataframe. A nested dataframe containing calculated charts and parsed text
 #' @export
 #'
-spcr_make_data_bundle <- function(measure_data, report_config, measure_config) {
+spcr_make_data_bundle <- function(measure_data = test_measure_data,
+                                  report_config = test_report_config,
+                                  measure_config = test_measure_config) {
   # check report_config
   report_config <- spcr_check_report_config(report_config)
 
@@ -33,7 +35,11 @@ spcr_make_data_bundle <- function(measure_data, report_config, measure_config) {
   # check reference numbers and measure names agree across both data frames
   # this is to guard against typos and errors in reported figures
   # by ensuring a typo in one place (ref or title) will create an error
-  purrr::walk(refs, spcr_check_measure_names, measure_data = measure_data, measure_config = measure_config)
+  purrr::walk(refs,
+              .f = spcr_check_measure_names,
+              measure_data = measure_data,
+              measure_config = measure_config
+  )
 
   # map over each measure to do the calculations
   result <- purrr::map2_df(
@@ -43,11 +49,20 @@ spcr_make_data_bundle <- function(measure_data, report_config, measure_config) {
     measure_data = measure_data,
     measure_config = measure_config,
     report_config = report_config
-  ) |>
-    # add a column to control whether Domain titles are printed
-    dplyr::mutate(
-      Needs_Domain_Heading = dplyr::if_else(Domain != dplyr::lag(Domain, default = "TRUE"), TRUE, FALSE)
-    )
+  )
 
-  return(result)
+  add_domain_heading <- function(dtf, sort_col = "sort_order") {
+    dtf |>
+      dplyr::arrange({{ sort_col }}) |>
+      dplyr::mutate(Needs_Domain_Heading = c(TRUE, rep(FALSE, nrow(dtf) - 1)))
+  }
+
+  result |>
+    dplyr::mutate(sort_order = dplyr::row_number()) |>
+    dplyr::group_by(Domain) |>
+    dplyr::group_modify(add_domain_heading) |>
+    dplyr::ungroup() |>
+    dplyr::arrange(sort_order) |>
+    # restore original column order (and remove sort_order col)
+    dplyr::select(all_of(c(names(result), "Needs_Domain_Heading")))
 }

R/spcr_make_report.R

@@ -1,8 +1,9 @@
 #' Make the SPC Report
 #'
-#' @param data_bundle list. The pre-processed bundle of information (made with spcr_make_data_bundle())
+#' @param data_bundle data frame. The pre-processed bundle of information (made with `spcr_make_data_bundle()`)
 #' @param title string. The report title, printed at the top of the report
 #' @param subtitle string. The report subtitle, printed at the top of the report
+#' @param document_title string. A title for the document, as used in the HTML `<title>` tag or as the PDF document title. If left as NULL (the default), this function will use the `title` parameter and the current date to construct a title
 #' @param report_ref string. A unique reference for the report, to make finding it later easier (perhaps the repo name?)
 #' @param data_cutoff_dttm POSIXct. The data cutoff date-time (the last date-time for data in the report eg. month-end)
 #' @param logo_path string. Filepath of the logo to be used on the report
@@ -11,33 +12,43 @@
 #' @param intro string. Intro text printed at the head of the report
 #' @param author_name string. The author's name
 #' @param author_email string. The author's contact email address
+#' @param paper_colour string. Customise the background colour using a valid HTML hex colour code, or CSS colour name
+#' @param accordion_colour string. Customise the accordion colour using a valid HTML hex colour code, or CSS colour name
 #' @param output_directory string. The name of the directory to save the resulting report to
-#' @param paper_colour string. Customise the background colour using a valid HTML Hex Colour Code
-#' @param accordion_colour string. Customise the accordion colour using a valid HTML Hex Colour Code
-#' @param include_dq_icon logical. Is the data quality icon required on the final report
+#' @param export_xlsx logical. Whether to export an .xlsx file of the data used in the report, as well as the report itself
+#' @param include_dq_icon logical. Is the data quality icon required on the final report?
 #'
 #' @export
 #'
 spcr_make_report <- function(data_bundle,
-                             title,
+                             title = "SPC Report",
                              subtitle = NULL,
-                             report_ref,
+                             document_title = NULL,
+                             report_ref = "",
                              data_cutoff_dttm,
-                             logo_path = NULL,
+                             logo_path = "nhs",
                              department = NULL,
                              department_text_colour = "black",
                              intro = NULL,
-                             author_name,
-                             author_email,
-                             paper_colour = "#FFFFFF", # white
+                             author_name = "Anne Author",
+                             author_email = "[email protected]",
+                             paper_colour = "white",
                              accordion_colour = "#CCF2FF", # pale blue
-                             output_directory = "/",
+                             output_directory = ".",
+                             export_xlsx = TRUE,
                              include_dq_icon = TRUE) {
-  # check that the required arguments are not missing
-  # this is necessary because most are used in the Rmd, and do not throw an error here
-  purrr::map(
-    c(report_ref, data_cutoff_dttm, author_name, author_email),
-    exists
+
+  if (rlang::is_missing(data_cutoff_dttm)) {
+    usethis::ui_warn(
+      paste("spcr_make_report: Please provide a data cutoff date-time.",
+      "This is the last time for which data is included in the report.",
+      "Using 'yesterday' as a replacement value.", sep = "\n"))
+    data_cutoff_dttm <- Sys.Date() - lubridate::as.period("1s")
+  }
+
+  assertthat::assert_that(
+    inherits(data_cutoff_dttm, "POSIXct"),
+    msg = "spcr_make_report: The data cutoff date must be a POSIXct object"
   )
 
   # identify stale data and add a flag to the data bundle
@@ -60,18 +71,29 @@ spcr_make_report <- function(data_bundle,
     ".html"
   )
 
+  # create a document title (HTML <title>) unless already supplied
+  if (is.null(document_title)) {
+    document_title <- paste0(
+      title,
+      " ",
+      format(Sys.Date(), "%d %b %Y")
+    )
+  }
+
   # render the html output
   message("Making HTML output...")
   rmarkdown::render(
     system.file("Rmd", "Report.Rmd", package = "SPCreporter"),
     output_dir = file.path(getwd(), output_directory),
     output_file = output_file_name
   )
-  message("HTML output complete.")
+  usethis::ui_done("HTML output complete.")
 
   # print the full path to the console
-  path <- file.path("file://", getwd(), output_directory, output_file_name)
-  message("Full path: ", path)
+  wd <- getwd() |>
+    stringr::str_remove("^\\\\{1}") # if network location, remove an initial '\'
+  path <- file.path("file://", wd, output_directory, output_file_name)
+  usethis::ui_info(paste0("Full path: ", path))
 
   # open the result in the browser
   browseURL(path)
@@ -80,5 +102,5 @@ spcr_make_report <- function(data_bundle,
   beepr::beep(1)
 
   # return the data bundle, which now contains details on stale data
-  return(data_bundle)
+  # return(data_bundle)
 }