Merge pull request #90 from nhs-r-community/new_main

New main for meeting

.gitignore

@@ -1,3 +1,12 @@
+# Your todo list
+TODO.txt
+calc_Lambert.R
+calc_tail_prob.R
+
+
+# mac stuff
+.DS_Store
+
 # History files
 .Rhistory
 .Rapp.history

DESCRIPTION

@@ -17,7 +17,7 @@ Description: R-package to implement the waiting list management approach describ
 License: MIT + file LICENSE
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 VignetteBuilder: knitr
 URL: https://nhs-r-community.github.io/NHSRwaitinglist/
 Config/testthat/edition: 3
@@ -27,7 +27,8 @@ Imports:
     rlang,
     purrr,
     utils,
-    stats
+    stats,
+    randomNames
 Suggests: 
     ggplot2,
     knitr,

NAMESPACE

@@ -1,13 +1,15 @@
 # Generated by roxygen2: do not edit by hand
 
+export(calc_priority_to_target)
 export(calc_queue_load)
 export(calc_relief_capacity)
 export(calc_target_capacity)
 export(calc_target_mean_wait)
 export(calc_target_queue_size)
 export(calc_waiting_list_pressure)
-export(create_bulk_synthetic_data)
 export(create_waiting_list)
+export(sim_patients)
+export(sim_schedule)
 export(wl_insert)
 export(wl_join)
 export(wl_queue_size)
@@ -16,3 +18,5 @@ export(wl_removal_stats)
 export(wl_schedule)
 export(wl_simulator)
 export(wl_stats)
+import(dplyr)
+import(randomNames)

NHSRwaitinglist.Rproj

@@ -15,7 +15,6 @@ LaTeX: pdfLaTeX
 StripTrailingWhitespace: Yes
 
 BuildType: Package
-PackageUseDevtools: Yes
+PackageCleanBeforeInstall: No
 PackageInstallArgs: --no-multiarch --with-keep.source
-PackageCheckArgs: --as-cran
 PackageRoxygenize: rd,collate,namespace,vignette

R/calc_index.R

@@ -0,0 +1,54 @@
+#' @title Calculate Column Indices
+#'
+#' @description Internal Helper function to get column indicies for referrals,
+#'  removals, and withdrawals
+#'
+#' @param waiting_list a dataframe containing the waitinglist
+#' @param colname string giving the column name
+#' @param type if colname, write referral, withdrawal, removal to guess the index
+#'
+#' @return index
+#'
+
+calc_index <- function(waiting_list,
+                       colname = NULL,
+                       type = NULL){
+
+  # get column index if name given
+  if( !is.null(colname) ){
+    index <-  which(colnames(waiting_list)==colname)
+    return(index)
+  } else {
+
+    # if name not give guess the name or index based on type
+    if (is.null(type)) {
+      index <- 1
+      return(index)
+    } else if ( type == "referral") {
+      guesses <- c("referral","Referral",1)
+    } else if ( type == "removal" ) {
+      guesses <- c("removal","Removal",2)
+    } else if ( type == "withdrawal") {
+      guesses <- c("withdrawal","Withdrawal",3)
+    } else if ( type == "target") {
+      guesses <- c("target","Target_wait",NULL)
+    } else {
+      warning("Waiting list index not found")
+      index <- 1
+      return(index)
+    }
+
+    # implement guess and return index given
+    for ( guess in guesses ) {
+      if ( is.character(guess) ){
+        index <-  which(colnames(waiting_list)==guess)
+      } else {
+        index <- guess
+      }
+      if (!identical(index,integer(0)) ){
+        break
+      }
+    }
+    return(index)
+  }
+}

R/calc_priority_to_target.R

@@ -0,0 +1,22 @@
+#' @title Calculates target days from priority code
+#'
+#' @description Internal Helper function number of days from prioirty code
+#'
+#' @param priority number 1,2,3 or 4
+#'
+#' @return number of days
+#'
+#' @export
+#'
+
+calc_priority_to_target <- function(priority){
+  if (priority == 1){
+    return(7)
+  } else if (priority == 2) {
+    return(28)
+  } else if (priority == 3) {
+    return(84)
+  } else {
+    return(365)
+  }
+}

R/calc_queue_load.R

@@ -19,6 +19,8 @@
 #' # If 30 patients are added to the waiting list each week (demand) and 27
 #' # removed (capacity) this results in a queue load of 1.11 (30/27).
 #' calc_queue_load(30, 27)
+#'
+
 calc_queue_load <- function(demand, capacity) {
   check_class(demand, capacity)
   load <- demand / capacity

R/calc_relief_capacity.R

@@ -32,12 +32,23 @@
 #'
 #' calc_relief_capacity(30, 1200, 390, 26)
 #'
+#'
+
 calc_relief_capacity <- function(
     demand,
     queue_size,
     target_queue_size,
-    time_to_target = 26) {
+    time_to_target = 26,
+    num_referrals = 0,
+    cv_demand = 0) {
   check_class(demand, queue_size, target_queue_size, time_to_target)
+  # Add two standard deviations to demand if it is estimated
+  if(num_referrals > 0 ){
+    if (2*demand*cv_demand / sqrt(num_referrals) < 1){
+      demand <- demand  / (1- 2*demand*cv_demand / sqrt(num_referrals) )
+    }
+  }
+  # Calculate the relief capacity
   rel_cap <- demand + (queue_size - target_queue_size) / time_to_target
   return(rel_cap)
-}
+}

R/calc_target_capacity.R

@@ -31,7 +31,7 @@
 #' # number of operations per week to have mean wait of 52/4
 #' calc_target_capacity(demand, target_wait)
 #'
-#' # TODO: Include a couple of standard deviations for errors in the mean demand
+
 calc_target_capacity <- function(
     demand,
     target_wait,

R/calc_target_mean_wait.R

@@ -23,6 +23,7 @@
 #' # If the target wait is 52 weeks then the target mean wait with a factor of 4
 #' # would be 13 weeks and with a factor of 6 it would be 8.67 weeks.
 #' calc_target_mean_wait(52, 4)
+
 calc_target_mean_wait <- function(target_wait, factor = 4) {
   check_class(target_wait, factor)
   target_mean_wait <- target_wait / factor

R/data_OPCS.R

@@ -0,0 +1,17 @@
+#' OPCS4 data
+#'
+#' @docType data
+#'
+#' @usage data(OPCS4)
+#'
+#' @format
+#'
+#' @keywords datasets
+#'
+#' @references
+#'
+#' @source https://biobank.ndph.ox.ac.uk/ukb/coding.cgi?id=240
+#'
+#' @examples
+#' \dontrun{data(OPCS4)}
+"OPCS4"

R/data_demographic.R

@@ -0,0 +1,16 @@
+#' demographic data
+#'
+#' @docType data
+#'
+#' @usage data(demographic_data)
+#'
+#' @format
+#'
+#' @keywords datasets
+#'
+#' @references
+#'
+#'
+#' @examples
+#' \dontrun{data(demographic_data)}
+"demographic_data"

R/sim_patients.R

@@ -0,0 +1,76 @@
+#' @title Generator of NHS patients
+#'
+#' @description Generates simulated NHS patients
+#'
+#' @param n_rows Number of rows/patients to generate
+#' @param start_date Start date (needed to generate patient ages)
+#'
+#' @return dataframe. Empty waiting list.
+#' @export sim_patients
+#' @import randomNames
+#' @examples
+#'
+
+
+
+
+sim_patients <- function(
+    n_rows = 10,
+    start_date = NULL
+) {
+
+  if ( is.null(start_date) ){
+    start_date = Sys.Date()
+  }
+  if (!exists("OPCS4")){
+    load(file='./data/OPCS4.rda')
+  }
+
+  # get proceedures
+  OPS <- OPCS4[(OPCS4$selectable=="Y") & (!is.na(OPCS4$name_4digit)),]
+  ran <- OPS[sample(nrow(OPS),n_rows,replace=TRUE),]
+  proceedures <- ran[c("code_1digit","name_1digit","code_4digit","name_4digit")]
+
+  # get names consultants and NHS numbers (length actually too short)
+  names <- randomNames::randomNames(n_rows)
+  consultant <- randomNames::randomNames(n_rows)
+  NHS_number <- sample.int(1e+8,n_rows, replace=TRUE)
+
+  # get semi-realistic ages (from gov.uk)
+  ages_rounded <-c(0,5,10,15,20,25,30,35,40,45,50,55,60,65,70,75,80,85)
+  probs <- c(
+    5.4,5.9,6.0,3.4,8.3,6.5,7.0,6.7,6.3,6.4,6.9,6.8,5.8,4.9,5.0,3.6,2.5,2.4
+  )
+  years <- 365*(sample(ages_rounded,size=n_rows,replace=TRUE,prob=probs) +
+                  sample.int(4,n_rows, replace = TRUE) -1)
+  days <- sample.int(365,n_rows, replace = TRUE) -1
+  dobs <- as.Date(as.numeric(start_date)-years-days)
+  priority <- sample(c(1,2,3,4),size=n_rows,replace=TRUE,prob=c(0.05,0.2,0.25,0.5))
+  target_wait <- sapply(priority, calc_priority_to_target)
+
+  # referral, removal, withdrawal columns
+  referral <- c(rep(NA,n_rows))
+  removal <- as.Date(c(rep(NA,n_rows)))
+  withdrawal <- c(rep(NA,n_rows))
+
+  waiting_list <- data.frame(
+    Referral = referral,
+    Removal = removal,
+    Withdrawal = withdrawal,
+    Priority = priority,
+    Target_wait = target_wait,
+    Name = names,
+    Birth_Date = dobs,
+    NHS_number = NHS_number,
+    Specialty_code = proceedures$code_1digit,
+    Specialty = proceedures$name_1digit,
+    OPCS = proceedures$code_4digit,
+    Proceedure = proceedures$name_4digit,
+    Consultant = consultant
+  )
+
+  return(waiting_list)
+
+
+}
+

R/sim_schedule.R

@@ -0,0 +1,32 @@
+#' @title Generator a list of dates to schedule
+#'
+#' @description Generates a list if dates in a given range
+#'
+#' @param n_rows Number of rows/patients to generate
+#' @param start_date Start date (needed to generate patient ages)
+#' @param daily_capacity Number of paitents per day
+#'
+#' @return dataframe. Empty waiting list.
+#' @export sim_schedule
+#'
+
+sim_schedule <- function(
+    n_rows = 10,
+    start_date = NULL,
+    daily_capacity = 1) {
+
+  if (is.null(start_date)){
+    start_date = Sys.Date()
+  }
+
+  schedule <-
+    as.Date(
+      as.numeric(start_date) +
+        ceiling(seq(0, n_rows - 1, 1 / daily_capacity)),
+      origin = "1970-01-01")
+
+  return(schedule)
+
+}
+
+