Merge pull request #6 from pythonhealthdatascience/dev

Dev

Author: amyheather

DESCRIPTION

@@ -21,9 +21,14 @@ Imports:
     dplyr,
     future,
     future.apply,
+    rlang,
     simmer
 Suggests:
     devtools,
     ggplot2,
-    scales
+    lintr,
+    mockery,
+    patrick,
+    scales,
+    testthat (>= 3.0.0)
 Config/testthat/edition: 3

NAMESPACE

@@ -1,6 +1,14 @@
 # Generated by roxygen2: do not edit by hand
 
 export(add_patient_generator)
+export(check_all_param_names)
+export(check_all_positive)
+export(check_nonneg_integer)
+export(check_param_names)
+export(check_param_values)
+export(check_positive_integer)
+export(check_prob_vector)
+export(check_run_number)
 export(create_asu_arrivals)
 export(create_asu_los)
 export(create_asu_routing)
@@ -10,20 +18,24 @@ export(create_rehab_arrivals)
 export(create_rehab_los)
 export(create_rehab_routing)
 export(create_rehab_trajectory)
+export(filter_warmup)
 export(get_occupancy_stats)
 export(model)
 export(runner)
 export(sample_routing)
 export(transform_to_lnorm)
+export(valid_inputs)
 importFrom(dplyr,bind_rows)
 importFrom(dplyr,filter)
+importFrom(dplyr,group_by)
 importFrom(dplyr,mutate)
 importFrom(dplyr,rowwise)
 importFrom(dplyr,ungroup)
 importFrom(future,multisession)
 importFrom(future,plan)
 importFrom(future,sequential)
 importFrom(future.apply,future_lapply)
+importFrom(rlang,.data)
 importFrom(simmer,add_generator)
 importFrom(simmer,add_resource)
 importFrom(simmer,branch)

R/create_asu_trajectory.R

@@ -26,7 +26,7 @@ create_asu_trajectory <- function(env, patient_type, param) {
   # Set up simmer trajectory object...
   trajectory(paste0("ASU_", patient_type, "_path")) |>
 
-    log_("🚶 Arrived at ASU", level = 1L) |>
+    log_("\U0001F6B6 Arrived at ASU", level = 1L) |>
 
     seize("asu_bed", 1L) |>
 
@@ -41,7 +41,7 @@ create_asu_trajectory <- function(env, patient_type, param) {
       dest_names <- names(param[["asu_routing"]][[patient_type]])
       dest <- dest_names[dest_index]
       # Create log message
-      paste0("🎯 Planned ASU -> ", dest_index, " (", dest, ")")
+      paste0("\U0001F3AF Planned ASU -> ", dest_index, " (", dest, ")")
     }, level = 1L) |>
 
     set_attribute("asu_los", function() {
@@ -73,13 +73,13 @@ create_asu_trajectory <- function(env, patient_type, param) {
     }) |>
 
     log_(function() {
-      paste0("⏳ ASU length of stay: ",
+      paste0("\U000023F3 ASU length of stay: ",
              round(get_attribute(env, "asu_los"), 3L))
     }, level = 1L) |>
 
     timeout(function() get_attribute(env, "asu_los")) |>
 
-    log_("🏁 ASU stay completed", level = 1L) |>
+    log_("\U0001F3C1 ASU stay completed", level = 1L) |>
 
     release("asu_bed", 1L) |>
 

R/create_rehab_trajectory.R

@@ -26,7 +26,7 @@ create_rehab_trajectory <- function(env, patient_type, param) {
   # Set up simmer trajectory object...
   trajectory(paste0("rehab_", patient_type, "_path")) |>
 
-    log_("🚶 Arrived at rehab", level = 1L) |>
+    log_("\U0001F6B6 Arrived at rehab", level = 1L) |>
 
     seize("rehab_bed", 1L) |>
 
@@ -41,7 +41,7 @@ create_rehab_trajectory <- function(env, patient_type, param) {
       dest_names <- names(param[["rehab_routing"]][[patient_type]])
       dest <- dest_names[dest_index]
       # Create log message
-      paste0("🎯 Planned rehab -> ", dest_index, " (", dest, ")")
+      paste0("\U0001F3AF Planned rehab -> ", dest_index, " (", dest, ")")
     }, level = 1L) |>
 
     set_attribute("rehab_los", function() {
@@ -72,13 +72,13 @@ create_rehab_trajectory <- function(env, patient_type, param) {
     }) |>
 
     log_(function() {
-      paste0("⏳ Rehab length of stay: ",
+      paste0("\U000023F3 Rehab length of stay: ",
              round(get_attribute(env, "rehab_los"), 3L))
     }, level = 1L) |>
 
     timeout(function() get_attribute(env, "rehab_los")) |>
 
-    log_("🏁 Rehab stay completed", level = 1L) |>
+    log_("\U0001F3C1 Rehab stay completed", level = 1L) |>
 
     release("rehab_bed", 1L)
 }

R/filter_warmup.R

@@ -0,0 +1,22 @@
+#' Filters arrivals and occupancy to remove warm-up patients.
+#'
+#' @param result Named list with two tables: arrivals & occupancy.
+#' @param warm_up_period Length of warm-up period.
+#'
+#' @importFrom dplyr filter group_by ungroup
+#'
+#' @return The name list `result`, but with the tables (`arrivals` and
+#' `occupancy`) filtered to remove warm-up patients.
+#' @export
+
+filter_warmup <- function(result, warm_up_period) {
+  if (warm_up_period > 0L) {
+    result[["arrivals"]] <- result[["arrivals"]] |>
+      group_by(.data[["name"]]) |>
+      filter(all(.data[["start_time"]] >= warm_up_period)) |>
+      ungroup()
+    result[["occupancy"]] <- filter(result[["occupancy"]],
+                                    time >= warm_up_period)
+  }
+  result
+}

R/get_occupancy_stats.R

@@ -12,9 +12,12 @@
 #'   \item The "1 in every n" patients delayed (inverse of probability of delay)
 #' }
 #'
+#'
 #' @param occupancy DataFrame with three columns: \code{resource}, \code{time},
 #' and \code{occupancy}.
 #'
+#' @importFrom rlang .data
+#'
 #' @return A list of data frames, one per resource, each containing occupancy
 #' statistics.
 #' @export

R/model.R

@@ -1,3 +1,6 @@
+# To avoid package build warning (name in expand.grid())
+utils::globalVariables("time")
+
 #' Run simulation.
 #'
 #' @param run_number Integer representing index of current simulation run.
@@ -6,16 +9,20 @@
 #' may not wish to do if being set elsewhere - such as done in \code{runner()}).
 #' Default is TRUE.
 #'
-#' @importFrom dplyr filter mutate rowwise ungroup
+#' @importFrom dplyr filter group_by mutate rowwise ungroup
+#' @importFrom rlang .data
 #' @importFrom simmer add_resource get_mon_arrivals get_mon_resources simmer
 #' @importFrom simmer wrap
 #' @importFrom utils capture.output
 #'
-#' @return TBC
+#' @return Named list with two tables: arrivals and occupancy.
 #' @export
 
 model <- function(run_number, param, set_seed = TRUE) {
 
+  # Check all inputs are valid
+  valid_inputs(run_number, param)
+
   # Set random seed based on run number
   if (set_seed) {
     set.seed(run_number)
@@ -120,5 +127,12 @@ model <- function(run_number, param, set_seed = TRUE) {
   arrivals <- mutate(arrivals, replication = run_number)
   occupancy <- mutate(occupancy, replication = run_number)
 
-  return(list(arrivals = arrivals, occupancy = occupancy))
+  result <- list(arrivals = arrivals, occupancy = occupancy)
+
+  # Filter the output results if a warm-up period was specified...
+  result <- filter_warmup(
+    result = result, warm_up_period = param[["warm_up_period"]]
+  )
+
+  return(result)
 }