Merge branch 'issue_56_vignette' of https://github.com/nhs-r-communit…

…y/NHSRwaitinglist into issue_56_vignette

.Rbuildignore

@@ -1,13 +1,15 @@
-^LICENSE\.md$
-^.*\.Rproj$
-^\.Rproj\.user$
-^\.Rprofile$
-^CODE_OF_CONDUCT\.md$
-README.Rmd
-cran-comments.md
-^_pkgdown\.yml$
-^docs$
-^pkgdown$
-^\.github$
-^codecov\.yml$
-.lintr
+^LICENSE\.md$
+^.*\.Rproj$
+^\.Rproj\.user$
+^\.Rprofile$
+^CODE_OF_CONDUCT\.md$
+README.Rmd
+cran-comments.md
+^_pkgdown\.yml$
+^docs$
+^pkgdown$
+^\.github$
+^codecov\.yml$
+.lintr
+^data-raw$
+

.all-contributorsrc

@@ -0,0 +1,73 @@
+{
+  "files": [
+    "README.md"
+  ],
+  "imageSize": 100,
+  "commit": false,
+  "commitType": "docs",
+  "commitConvention": "angular",
+  "contributors": [
+    {
+      "login": "jacgrout",
+      "name": "Jacqueline Grout",
+      "avatar_url": "https://avatars.githubusercontent.com/u/103451105?v=4",
+      "profile": "https://github.com/jacgrout",
+      "contributions": [
+        "ideas"
+      ]
+    },
+    {
+      "login": "ThomUK",
+      "name": "Tom Smith",
+      "avatar_url": "https://avatars.githubusercontent.com/u/10871342?v=4",
+      "profile": "https://github.com/ThomUK",
+      "contributions": [
+        "code"
+      ]
+    },
+    {
+      "login": "matt-dray",
+      "name": "Matt Dray",
+      "avatar_url": "https://avatars.githubusercontent.com/u/18232097?v=4",
+      "profile": "http://matt-dray.com",
+      "contributions": [
+        "code"
+      ]
+    },
+    {
+      "login": "kaituna",
+      "name": "kaituna",
+      "avatar_url": "https://avatars.githubusercontent.com/u/151142766?v=4",
+      "profile": "https://github.com/kaituna",
+      "contributions": [
+        "doc"
+      ]
+    },
+    {
+      "login": "chrismainey",
+      "name": "Chris Mainey",
+      "avatar_url": "https://avatars.githubusercontent.com/u/39626211?v=4",
+      "profile": "https://github.com/chrismainey",
+      "contributions": [
+        "code",
+        "doc",
+        "test"
+      ]
+    },
+    {
+      "login": "PeterSNHS",
+      "name": "PeterSNHS",
+      "avatar_url": "https://avatars.githubusercontent.com/u/67410797?v=4",
+      "profile": "https://github.com/PeterSNHS",
+      "contributions": [
+        "doc"
+      ]
+    }
+  ],
+  "contributorsPerLine": 7,
+  "skipCi": true,
+  "repoType": "github",
+  "repoHost": "https://github.com",
+  "projectName": "NHSRwaitinglist",
+  "projectOwner": "nhs-r-community"
+}

DESCRIPTION

@@ -3,9 +3,10 @@ Title: R-package to implement a waiting list management approach
 Version: 0.0.0.9000
 Authors@R: c(
           person("Neil", "Walton", ,"[email protected]", c("cre", "aut"), comment = c(ORCID ="0000-0002-5241-9765")),
-          person("Yasser", "Mustaq", ,"[email protected]", "aut"),
           person("Jacqueline", "Grout", ,"[email protected]", "aut"),
           person("Zoë", "Turner", , "[email protected]", "aut", comment = c(ORCID = "0000-0003-1033-9158")),
+          person("Matt", "Dray", , "[email protected]", "aut"),
+          person("Paul", "Fenton", , "[email protected]", "aut"),
           person("Marcos", "Fabietti", ,"[email protected]", "aut"),
           person("Tom", "Smith", ,"[email protected]", "aut"),
           person("Chris", "Mainey", ,"[email protected]", "aut", comment = c(ORCID ="0000-0002-3018-6171")),
@@ -24,8 +25,15 @@ Imports:
     cli,
     dplyr,
     ggplot2,
-    rlang
+    rlang,
+    purrr,
+    utils,
+    stats
 Suggests: 
     knitr,
     rmarkdown,
     testthat (>= 3.0.0)
+Depends: 
+    R (>= 2.10)
+LazyData: true
+

NAMESPACE

@@ -1,6 +1,8 @@
 # Generated by roxygen2: do not edit by hand
 
 export(average_wait)
+export(create_bulk_synthetic_data)
+export(create_waiting_list)
 export(queue_load)
 export(relief_capacity)
 export(target_capacity)

R/create_bulk_synthetic_data.R

@@ -0,0 +1,24 @@
+
+#' @title Create Bulk Synthetic Data
+#'
+#' @description
+#' Creates a series of waiting lists, one for each row in the dataframe
+#' parameter and joins them together into one dataframe with relevant creation
+#' criteria
+#'
+#' @param bulk_data A dataframe object, each row being a waiting list with
+#'  parameters to generate the synthetic data. A sample data.frame is available
+#'  as demo-data
+#'
+#' @return Dataframe of waiting lists for each specified site and specialty,
+#' opcs etc
+#' @export
+#'
+#' @examples create_bulk_synthetic_data(demo_df)
+
+create_bulk_synthetic_data <- function(bulk_data) {
+  result <- bulk_data |>
+    purrr::pmap(create_waiting_list) |>
+    dplyr::bind_rows()
+  return(result)
+}

R/create_waiting_list.R

@@ -0,0 +1,71 @@
+#' @title Create Waiting List
+#'
+#' @description
+#' Creates a waiting list using the parameters specified
+#'
+#'
+#' @param n Numeric value of rate of demand in same units as target wait
+#'  - e.g. if target wait is weeks, then demand in units of patients/week.
+#' @param mean_arrival_rate Numeric value of mean daily arrival rate.
+#' @param mean_wait Numeric value of mean wait time for treatment/on waiting
+#' list.
+#' @param start_date Character value of date from which to start generated
+#' waiting list.
+#' @param limit_removals Defaults to TRUE
+#' @param sd Numeric value, standard deviation. Defaults to 0.
+#' @param rott Numeric value, proportion of referrals to be randomly flagged
+#' as ROTT. Defaults to 0.
+#' @param ... Container for the list
+#'
+#' @return A tibble of a random generated list of patients with addition_date,
+#'  removal_date, wait_length and rott status for each patient
+#' @export
+#'
+#' @examples create_waiting_list(366,50,21,"2024-01-01",10,0.1)
+#'
+
+
+create_waiting_list <- function(n, mean_arrival_rate, mean_wait,
+                                start_date = Sys.Date(), limit_removals = TRUE,
+                                sd = 0, rott = 0,  ...) {
+
+  dots <- list(...)
+
+  #Generate date range and number of referrals for each date (with or without
+  #random variation around mean_arrival_rate)
+  dates <- seq.Date(from = as.Date(start_date, format = "%Y-%m-%d"),
+                    length.out = n,
+                    by = "day")
+  counts <- pmax(0, stats::rnorm(n, mean = mean_arrival_rate, sd = sd))
+  referrals <- rep(dates, times = counts)
+
+  #set random waiting time in days for each referral received with exponential
+  #distribution rate 1/mean_waiting_time
+  values <- stats::rexp(length(referrals), 1 / mean_wait)
+
+  #Create dataframe of referrals and calculate removal date
+  test_df <- data.frame(addition_date = referrals, wait_length = values)
+  test_df$removal_date <- test_df$addition_date + round(test_df$wait_length, 0)
+
+  #Suppress removal dates that are greater than start date + 'n' days to
+  #simulate non-zero waitlist at end of simulated period.
+  if (limit_removals) {
+    test_df$removal_date[test_df$removal_date >
+                           (as.Date(start_date, format = "%Y-%m-%d") + n)] <- NA
+    test_df$wait_length[is.na(test_df$removal_date)] <- NA
+  }
+
+  #Randomly flag user defined proportion of referrals as ROTT
+  test_df$rott <- FALSE
+  sample_list <- sample(seq_len(nrow(test_df)), nrow(test_df) * rott,
+                        replace = FALSE)
+  test_df$rott[sample_list] <- TRUE
+
+  #Add a patient ID to each referral and prepare data for return
+  test_df$pat_id <- seq_len(nrow(test_df))
+  test_df <- test_df[order(test_df$addition_date),
+                     c("pat_id", "addition_date",
+                       "removal_date", "wait_length", "rott")]
+
+  return(dplyr::as_tibble(c(dots, test_df)))
+}

R/demo-data.R

@@ -0,0 +1,26 @@
+#' @title A Demo 'data.frame' Object
+#'
+#' @description A pre-created data.frame ready to be used to test the
+#' create_bulk_synthetic_data and create_waiting_list functions. Each row of
+#' the data.frame represents an individual waiting list for which the site,
+#' specialty, OPCS code(s) and respective mean wait, arrival rate, start_date,
+#' sd and rott can be specified. It allows the user to see an example of the
+#' structure of the data.frame required by the create_bulk_synthetic_data
+#' function to create your synthetic dataset.
+#'
+#' @format A dataframe with 5 rows and 9 columns:
+#' \describe{
+#'\item{hospital_site}{Character. Hospital site code of the waiting list.}
+#'\item{main_spec_code}{Numeric. Main specialty code of the waiting list.}
+#'\item{opcs4_code}{Character. OPCS4 code(s) of the procedure(s) on the waiting
+#' list.}
+#'\item{n}{Numeric. Number of days for which to create synthetic waiting
+#'   list data.}
+#'\item{mean_arrival_rate}{Numeric. Mean number of arrivals per day.}
+#'\item{mean_wait}{Numeric. Mean wait time for treatment/on waiting list.}
+#'\item{start_date}{Character. Date from which to start generated waiting
+#'   list in format yyyy-mm-dd.}
+#'\item{sd}{Numeric. Standard deviation.}
+#'\item{rott}{Numeric. Proportion of referrals to be randomly flagged as ROTT}
+#' }
+"demo_df"

R/wl_referral_stats.R

@@ -46,7 +46,7 @@ wl_referral_stats <- function(waiting_list,
 
   inter_arrival_times <- diff(arrival_dates, lags = -1)
   mean_arrival <- as.numeric(mean(inter_arrival_times))
-  sd_arrival <- sd(inter_arrival_times)
+  sd_arrival <- stats::sd(inter_arrival_times)
   cv_arrival <- sd_arrival / mean_arrival
   num_arrivals <- length(inter_arrival_times)
   demand <- 1 / mean_arrival

R/wl_removal_stats.R

@@ -61,7 +61,7 @@ wl_removal_stats <- function(waiting_list,
 
   differences <- removals_and_zeros[which(removals_and_zeros[, 2] == TRUE), 4]
   mean_removal <- as.numeric(mean(differences, na.rm = TRUE))
-  sd_removal <- sd(differences, na.rm = TRUE)
+  sd_removal <- stats::sd(differences, na.rm = TRUE)
   cv_removal <- sd_removal / mean_removal
   num_removals <- length(differences)
   capacity <- 1 / mean_removal

R/wl_simulator.R

@@ -38,7 +38,7 @@ wl_simulator <- function(
   daily_capacity <- capacity / 7
 
   # allowing for fluctuations in predicted demand give a arrival list
-  realized_demand <- rpois(1, total_demand)
+  realized_demand <- stats::rpois(1, total_demand)
   referral <-
     sample(
            seq(as.Date(start_date), as.Date(end_date), by = "day"),

R/wl_stats.R

@@ -104,7 +104,7 @@ wl_stats <- function(waiting_list,
   q_load_too_big <- (q_load >= 1.)
 
   # final queue_size
-  q_size <- tail(queue_sizes, n = 1)[, 2]
+  q_size <- utils::tail(queue_sizes, n = 1)[, 2]
 
   # target queue size
   q_target <- target_queue_size(referral_stats$demand.weekly, target_wait)

README.md

@@ -1,4 +1,7 @@
 <!-- badges: start -->
+<!-- ALL-CONTRIBUTORS-BADGE:START - Do not remove or modify this section -->
+[![All Contributors](https://img.shields.io/badge/all_contributors-6-orange.svg?style=flat-square)](#contributors-)
+<!-- ALL-CONTRIBUTORS-BADGE:END -->
 [![Lifecycle: experimental](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html#experimental)
 [![R-CMD-check](https://github.com/nhs-r-community/NHSRwaitinglist/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/nhs-r-community/NHSRwaitinglist/actions/workflows/R-CMD-check.yaml)
 [![Codecov test coverage](https://codecov.io/gh/nhs-r-community/NHSRwaitinglist/branch/main/graph/badge.svg)](https://app.codecov.io/gh/nhs-r-community/NHSRwaitinglist?branch=main)
@@ -12,18 +15,26 @@
 An R-package to implement the waiting list management approach described in the paper [Understanding Waiting Lists Pressures](https://www.medrxiv.org/content/10.1101/2022.08.23.22279117v1) by Fong et al.
 
 
-## To install the package, run:
-``` r
+# Installation 
+
+You can install the current version of {name of package} from GitHub with:
+
+```{r}
+
+# install.packages("remotes")
 remotes::install_github("nhs-r-community/NHSRwaitinglist", build_vignettes = TRUE)
+
 ```
 
+## Contributing
 
-## Contribution
+If you want to learn more about this project, please join the discussion at the [NHS-R Community Slack](https://nhsrway.nhsrcommunity.com/community-handbook.html#slack) group and the specific channel #managing-waiting-lists.
 
-This is an NHS-R Community project that is open for anyone to contribute to in any way that they are able. Please see the [NHS-R Way](https://nhsrway.nhsrcommunity.com/style-guides.html) to read more on the style guides and for [Code of Conduct](https://nhsrway.nhsrcommunity.com/code-of-conduct.html) related to any activity or contribution to the NHS-R Community as well as the Code of Conduct in this repository which is generated using `usethis::use_code_of_conduct(contact = "[email protected]")`.
-By contributing to this project, you agree to abide by these terms.
+Please see our 
+[guidance on how to contribute](https://tools.nhsrcommunity.com/contribution.html).
 
-If you want to learn more about this project, please join the discussion at the [NHS-R Community Slack](https://nhsrway.nhsrcommunity.com/community-handbook.html#slack) group and the specific channel #managing-waiting-lists.
+This project is released with a Contributor [Code of Conduct](./CODE_OF_CONDUCT.md). 
+By contributing to this project, you agree to abide by its terms.
 
 The simplest way to contribute is to raise an issue detailing the feature or functionality you would like to see added, or any unexpected behaviour or bugs you have experienced.
 
@@ -35,4 +46,32 @@ You are welcome to also submit Pull Requests and, as the `main` branch is protec
 * Commit to the new branch (add code or delete code or make changes)
 * Push the commits 
 * Create a pull-request in GitHub to signal that your work is ready to be merged
-* Tag one or more reviewers so that your contribution can be reviewed and merged into `main`
+* Tag one or more reviewers (@ThomUK and @ChrisMainey) so that your contribution can be reviewed and merged into main
+
+
+## Contributors ✨
+
+Thanks goes to these wonderful people ([emoji key](https://allcontributors.org/docs/en/emoji-key)):
+
+<!-- ALL-CONTRIBUTORS-LIST:START - Do not remove or modify this section -->
+<!-- prettier-ignore-start -->
+<!-- markdownlint-disable -->
+<table>
+  <tbody>
+    <tr>
+      <td align="center" valign="top" width="14.28%"><a href="https://github.com/jacgrout"><img src="https://avatars.githubusercontent.com/u/103451105?v=4?s=100" width="100px;" alt="Jacqueline Grout"/><br /><sub><b>Jacqueline Grout</b></sub></a><br /><a href="#ideas-jacgrout" title="Ideas, Planning, & Feedback">🤔</a></td>
+      <td align="center" valign="top" width="14.28%"><a href="https://github.com/ThomUK"><img src="https://avatars.githubusercontent.com/u/10871342?v=4?s=100" width="100px;" alt="Tom Smith"/><br /><sub><b>Tom Smith</b></sub></a><br /><a href="https://github.com/nhs-r-community/NHSRwaitinglist/commits?author=ThomUK" title="Code">💻</a></td>
+      <td align="center" valign="top" width="14.28%"><a href="http://matt-dray.com"><img src="https://avatars.githubusercontent.com/u/18232097?v=4?s=100" width="100px;" alt="Matt Dray"/><br /><sub><b>Matt Dray</b></sub></a><br /><a href="https://github.com/nhs-r-community/NHSRwaitinglist/commits?author=matt-dray" title="Code">💻</a></td>
+      <td align="center" valign="top" width="14.28%"><a href="https://github.com/kaituna"><img src="https://avatars.githubusercontent.com/u/151142766?v=4?s=100" width="100px;" alt="kaituna"/><br /><sub><b>kaituna</b></sub></a><br /><a href="https://github.com/nhs-r-community/NHSRwaitinglist/commits?author=kaituna" title="Documentation">📖</a></td>
+      <td align="center" valign="top" width="14.28%"><a href="https://github.com/chrismainey"><img src="https://avatars.githubusercontent.com/u/39626211?v=4?s=100" width="100px;" alt="Chris Mainey"/><br /><sub><b>Chris Mainey</b></sub></a><br /><a href="https://github.com/nhs-r-community/NHSRwaitinglist/commits?author=chrismainey" title="Code">💻</a> <a href="https://github.com/nhs-r-community/NHSRwaitinglist/commits?author=chrismainey" title="Documentation">📖</a> <a href="https://github.com/nhs-r-community/NHSRwaitinglist/commits?author=chrismainey" title="Tests">⚠️</a></td>
+      <td align="center" valign="top" width="14.28%"><a href="https://github.com/PeterSNHS"><img src="https://avatars.githubusercontent.com/u/67410797?v=4?s=100" width="100px;" alt="PeterSNHS"/><br /><sub><b>PeterSNHS</b></sub></a><br /><a href="https://github.com/nhs-r-community/NHSRwaitinglist/commits?author=PeterSNHS" title="Documentation">📖</a></td>
+    </tr>
+  </tbody>
+</table>
+
+<!-- markdownlint-restore -->
+<!-- prettier-ignore-end -->
+
+<!-- ALL-CONTRIBUTORS-LIST:END -->
+
+This project follows the [all-contributors](https://github.com/all-contributors/all-contributors) specification. Contributions of any kind welcome!

data-raw/demo-data.R

@@ -0,0 +1,13 @@
+## code to prepare `demo-data` dataset
+demo_df <- data.frame(hospital_site = c("ABC001", "DHR70", "JRW20", "RFW002",
+                                        "DHR70"),
+                      main_spec_code = c(100, 110, 120, 130, 100),
+                      opcs4_code = c("T202", "W401", "F344", "C866", "T272"),
+                      n = 366,
+                      mean_arrival_rate = c(50, 25, 20, 40, 50),
+                      mean_wait = c(21, 20, 10, 30, 21),
+                      start_date = c("2024-01-01", "2023-04-01", "2024-04-01",
+                                     "2023-01-01", "2024-01-01"),
+                      sd = 10,
+                      rott = c(0, 0.1, 0.05, 0.2, 0.1))
+usethis::use_data(demo_df, overwrite = TRUE)