Merge pull request #431 from Public-Health-Scotland/bex

Bex

01_control/control_mmi.R

@@ -2,7 +2,7 @@
 ### Generate CAPTND MMI ###
 ###########################.
 
-# Author: Charlie Smith
+# Author: Charlie Smith & Bex Madden
 # Date: 2024-09-18
 
 
@@ -13,12 +13,11 @@ month_end <- "2024-08-01"
 
 
 # Step 2 - Run these scripts in sequence ----------------------------------
-# packages?
-
-# functions? (separate script)
+# packages
+source("./07_publication/script/chapters/1_load_packages.R")
+# functions
 source("./07_publication/script/chapters/2_load_functions.R")
-
-# constants?  (separate script)
+# constants
 source("./07_publication/script/chapters/3_set_constants.R")
 
 # Step 3 - Analyse Data ---------------------------------------------------
@@ -39,13 +38,14 @@ compile_appointments_summary()
 
 compile_pat_seen_adj_summary()
 compile_pat_seen_unadj_summary()
+compile_appointments_summary()
 
 compile_open_cases_summary()
 
 # Step 5 - Create plots ---------------------------------------------------
-# 
-# create_plots_patients_seen("PT")
-# create_plots_patients_seen("CAMHS")
+#
+#create_plots_patients_seen("PT")
+#create_plots_patients_seen("CAMHS")
 
 
 # Step 6 - Create MMI excel doc -------------------------------------------

01_control/control_outputs.R

@@ -26,13 +26,15 @@ source('06_calculations/calculate_first_treatment.R')
 source('06_calculations/compare_first_contact_aggregate_captnd.R')
 source('06_calculations/compare_dna_new_return_app.R')
 source('06_calculations/compare_dna_aggregate_captnd_csrework.R')
-source('05_data_quality/product3.R')
+#source('05_data_quality/product3.R')
 source('02_setup/save_df_as_parquet.R')
 source('06_calculations/compare_patients_waiting_monthly.R')
 source('06_calculations/create_comparison_reports.R')
 source('06_calculations/create_comparison_report_patient_data.R')
 source('06_calculations/calculate_patient_turnover.R')
 source('06_calculations/get_latest_month_end.R')
+source("./05_data_quality/create_product_pack.R")
+source("./05_data_quality/create_product_pack_mth.R")
 
 # 2 - open most recent RTT eval file--------------------------------------
 
@@ -66,7 +68,8 @@ make_product_2(df, most_recent_month_in_data)
 #make_product_3(df, most_recent_month_in_data, TRUE)
 #make_product_3(df, most_recent_month_in_data, FALSE)
 
-source("./05_data_quality/create_product_pack.R")
+create_product_pack()
+create_product_pack_mth() # with product 2 as a monthly not quarterly heatmap
 
 
 # 2.3 Comparisons ---------------------------------------------------------

01_control/control_swift.R

@@ -126,7 +126,7 @@ df_glob_swift_completed_rtt <- df_glob_swift_data_types_set %>%
   add_sub_source_eval() %>%
   add_ref_appt_discharge_month() %>%
   add_rtt_eval(., evalAllData=FALSE) %>% 
-  add_new_return_apps() # issue with first_treat_app
+  add_new_return_apps() 
 
 
 # For complete data including globalscape and swift entries, please run the 
@@ -146,9 +146,5 @@ cat(green('CAPTND data read and cleaned! \nThis process took', format(duration,u
 # takes about 1hr 20 minutes and 14.5 GiB
 
 read_clean_captnd_data()
-
-
-
-
 
 

04_check_modify/add_rtt_eval.R

@@ -48,7 +48,7 @@ add_rtt_eval <- function(df, evalAllData=FALSE) {
         ref_acc_last_reported == 1 &
         any(
             !is.na(!!sym(treat_start_date_o))
-        ) ~ 'seen - active',
+        ) ~ 'seen - active', # not how treat_start_date is really meant to be used..?
 
       #other case is patients seen whose treatment is ongoing
       has_ref_rec_date_opti == TRUE &
@@ -68,7 +68,7 @@ add_rtt_eval <- function(df, evalAllData=FALSE) {
         ref_acc_last_reported == 1 &
         any(
             !is.na(!!sym(treat_start_date_o))
-        ) ~ 'seen - closed',
+        ) ~ 'seen - closed', # not how treat_start_date is really meant to be used..?
 
       #next case is patients seen whose treatment is finished
       has_ref_rec_date_opti == TRUE &
@@ -135,15 +135,15 @@ add_rtt_eval <- function(df, evalAllData=FALSE) {
         any(
           !is.na(!!sym(app_date_o)) &
             !!sym(att_status_o) == 1 
-        ) ~ 'rtt not possible - attended app but no purpose',
+        ) ~ 'rtt not possible - attended app but no purpose', # this isn't dependent on only FIRST treatment app
 
       #rtt not possible - no app attendance information
       has_any_app_date == TRUE &
         has_ref_rec_date_opti == TRUE &
         #is_case_closed == FALSE &
         ref_acc_last_reported == 1 &
         (!!sym(att_status_o) == 99 | is.na(!!sym(att_status_o))) 
-      ~ 'rtt not possible - app date but no attendance status',
+      ~ 'rtt not possible - app date but no attendance status', # this isn't dependent on only FIRST treatment app
 
 
       #case closed due to no attendance
@@ -154,7 +154,7 @@ add_rtt_eval <- function(df, evalAllData=FALSE) {
         any(
           !is.na(!!sym(app_date_o)) &
             !!sym(att_status_o) %in% c(2,3,5,8) 
-        ) ~ 'case closed due to non attendance',
+        ) ~ 'case closed due to non attendance', # would this flag any closed case where ANY (rather than ALL) nonattendance had occurred?
 
       #patients waiting no attendance
       has_any_app_date == TRUE &
@@ -164,7 +164,7 @@ add_rtt_eval <- function(df, evalAllData=FALSE) {
         any(
           !is.na(!!sym(app_date_o)) &
             !!sym(att_status_o) %in% c(2,3,5,8) 
-        ) ~ 'waiting - not attended',
+        ) ~ 'waiting - not attended', # again ANY or ALL apps non-attended being flagged here?
 
       #case closed prior to app
       has_any_app_date == FALSE &

05_data_quality/create_product_pack.R

@@ -6,6 +6,7 @@
 # Author: Bex Madden
 # Date: 2024-03-07
 
+create_product_pack <- function(){
 library(openxlsx)
 
 
@@ -49,7 +50,7 @@ insertImage(wb, "2. RTT Summary", paste0(product2_dir, "/qt_product2_heatmap_",
 prod1_narrative <- paste0("The following heatmap shows retained data by Health Board in the 12 months up to and including ", latest_date, ".")
 prod2_narrative <- paste0("The following heatmap shows the percentage of the valid patient pathways where it is possible to calculate Unadjusted RTT,",
                           " by Health Board in the 4 quarters up to and including ", latest_date, ". See below for detail on the reasons RTT cannot be calculated.")
-prod2_narrative2 <- paste0("The following table contains detail on the reasons why RTT cannot be calculated.",
+prod2_narrative2 <- paste0("The following table contains detail on the reasons why RTT cannot be calculated (since August 2021).",
                            " Please use the drop-down column headers to find the data relating to your own Health Board.")
 #prod3_narrative <- paste0("The data shown relates to completed patient pathways in CAPTND up until ", latest_date)
 
@@ -89,7 +90,7 @@ writeDataTable(wb, "2. RTT Summary", p2_reasons,
 
 saveWorkbook(wb, paste0(external_reports_dir, "/CAPTND_opti_summary_", latest_date, ".xlsx"), overwrite = TRUE)
 
-
+}
 
 
 

05_data_quality/create_product_pack_mth.R

@@ -0,0 +1,83 @@
+
+###########################.
+### Create Product Pack ###
+###########################.
+
+# Author: Bex Madden
+# Date: 2024-03-07
+
+
+create_product_pack_mth <- function(){
+library(openxlsx)
+
+
+# 1. Derive dates ---------------------------------------------------------
+
+#get most recent and earliest dates for which products have been created 
+
+  files <- list.files(product2_dir) # list files in directory
+  files <- files[grep("mth_product2_heatmap", files)] # gets only the heatmap file names
+  files <- gsub("mth_product2_heatmap_","", gsub(".png","", files)) # remove the non-date elements of the file names
+
+  count_files <- length(files) # finds number of files
+
+  latest_date <- files[count_files] # creates object with latest product date only
+  earliest_date <- files[1] # creates object with earliest product date only
+
+
+
+# 2. Populate workbook ---------------------------------------------------------
+
+
+# pull template excel workbook containing products 1, 2, 3 - narrative and readme in template
+
+wb <- loadWorkbook(paste0("../../../output/product_pack_working/template_products.xlsx"))
+modifyBaseFont(wb, fontName = "Arial")
+
+# load in the created .pngs of each product
+
+insertImage(wb, "1. Data Retention", paste0(product1_dir, "/product1.png"),
+            startRow = 11, startCol = 2, width = 29, height = 13.5, units = "cm")
+
+insertImage(wb, "2. RTT Summary", paste0(product2_dir, "/mth_product2_heatmap_", latest_date, ".png"), 
+            startRow = 10, startCol = 2, width = 27, height = 13.5, units = "cm")
+# insertImage(wb, "2. RTT Summary", paste0(product2_dir, "/product2_heatmap_", earliest_date, ".png"), 
+#             startRow = 31, startCol = 2, width = 24, height = 13.5, units = "cm")
+# 
+# insertImage(wb, "3. Data Completeness", paste0(product3_dir, "/product3_closed_cases_until_", latest_date, ".png"), 
+#             startRow = 8, startCol = 2, width = 30, height = 15, units = "cm")
+
+# If wanting to add a dated comment above main narrative
+prod1_narrative <- paste0("The following heatmap shows retained data by Health Board in the 12 months up to and including ", latest_date, ".")
+prod2_narrative <- paste0("The following heatmap shows the percentage of the valid patient pathways where it is possible to calculate Unadjusted RTT,",
+                          " by Health Board in the 12 months up to and including ", latest_date, ". See below for detail on the reasons RTT cannot be calculated in the latest month.")
+prod2_narrative2 <- paste0("The following table contains detail on the reasons why RTT could not be calculated in the latest month.",
+                           " Please use the drop-down column headers to find the data relating to your own Health Board.")
+#prod3_narrative <- paste0("The data shown relates to completed patient pathways in CAPTND up until ", latest_date)
+
+# insert narrative text to each sheet
+writeData(wb, "1. Data Retention", x = prod1_narrative, startCol = 2, startRow = 6) #, headerStyle = my_fontsize
+writeData(wb, "2. RTT Summary", x = prod2_narrative, startCol = 2, startRow = 6) #, headerStyle = my_fontsize
+writeData(wb, "2. RTT Summary", x = prod2_narrative2, startCol = 2, startRow = 26) #, headerStyle = my_fontsize
+#writeData(wb, "3. Data Completeness", x = prod3_narrative, startCol = 2, startRow = 6) #, headerStyle = my_fontsize
+
+
+# read in data relating to ability to calculate RTT 
+
+source("./05_data_quality/get_prod2_reasons_table.R")
+p2_reasons <- get_prod2_reasons_table(latest_date = latest_date)
+
+writeDataTable(wb, "2. RTT Summary", p2_reasons, 
+               startRow = 28, startCol = 2,
+               tableStyle = "TableStyleLight9",
+               colNames = TRUE, withFilter = TRUE,
+               keepNA = TRUE, na.string = "NA")
+
+saveWorkbook(wb, paste0(external_reports_dir, "/CAPTND_opti_summary_mth_", latest_date, ".xlsx"), overwrite = TRUE)
+
+}
+
+
+
+
+

05_data_quality/get_prod2_reasons_table.R

@@ -6,11 +6,11 @@
 #date: 16/09/24
 
 
-get_prod2_reasons_table <- function(){
+get_prod2_reasons_table <- function(latest_date){
 
 # read in data relating to ability to calculate RTT FOR THE PAST MONTH ONLY
 
-p2_data <- read_parquet(paste0(product2_dir, "/product2_data_monthly.parquet")) |>
+p2_data <- read_parquet(paste0(product2_dir, "/product2_data_monthly_", latest_date, ".parquet")) |>
   filter(rtt_general == 'not possible',
          sub_month == max(sub_month)) |> # latest month only MONTHLY data
   group_by(!!!syms(c(hb_name_o, dataset_type_o)), sub_month) %>% 

05_data_quality/product2.R

@@ -15,6 +15,7 @@ source('05_data_quality/product2_plot_details.R')
 source('05_data_quality/product2_plot_general.R')
 source('05_data_quality/product2_plot_heatmap.R')
 source('05_data_quality/product2_plot_heatmap_quarterly.R')
+source('05_data_quality/product2_plot_heatmap_monthly.R')
 source('05_data_quality/product2_plot_issues.R')
 source('04_check_modify/add_rtt_eval.R')
 
@@ -42,8 +43,7 @@ make_product_2 <- function(df_rtt, most_recent_month_in_data) {
       mutate(
         perc = round(n / total * 100, 1),
         !!hb_name_o := factor(!!sym(hb_name_o), level = level_order),
-        !!rtt_eval_o := factor(
-          !!sym(rtt_eval_o),
+        !!rtt_eval_o := factor(!!sym(rtt_eval_o),
           level = c(
             'seen - active',
             #1
@@ -117,6 +117,8 @@ make_product_2 <- function(df_rtt, most_recent_month_in_data) {
     product2_plot_issues(df_rtt_plot_prep, date_max) # uses df plot prep from above - so is all time
     product2_plot_heatmap(df_rtt_again, date_max) #this will be showing for the past year based on the date filters for df_rtt_again
     product2_plot_heatmap_quarterly(df_rtt_again, date_max) # ditto, past year split into quarters, need months
+    product2_plot_heatmap_monthly(df_rtt_again, date_max) # ditto, past year split into quarters, need months
+
   }
 
 

05_data_quality/product2_plot_heatmap_monthly.R

@@ -30,7 +30,7 @@ product2_plot_heatmap_monthly <- function(df_rtt, date_max){
     #   )) %>%
     mutate(rtt_general = case_when(str_detect(!!sym(rtt_eval_o), 'unknown | not possible') ~ 'not possible',
                         TRUE ~ 'possible')) %>%
-    save_as_parquet(path = paste0(product2_dir, "/product2_data_monthly")) |> # save out monthly data that corresponds to heatmap
+    save_as_parquet(path = paste0(product2_dir, "/product2_data_monthly_", date_max)) |> # save out monthly data that corresponds to heatmap
     group_by(!!!syms(c(hb_name_o, dataset_type_o)), rtt_general, sub_month) %>% 
     summarise(n = sum(n),
               .groups ='drop') %>% 
@@ -63,11 +63,11 @@ product2_plot_heatmap_monthly <- function(df_rtt, date_max){
     unique() |>
     pull()
 
-  product2_plot_heatmap <- df_rtt_plot_prepping %>% 
+  product2_mth_heatmap <- df_rtt_plot_prepping %>% 
     filter(sub_month >=  ymd(date_max) - months(12)) |> 
     ggplot(aes(y = factor(!!sym(hb_name_o), levels = rev(level_order)), x = sub_month, fill = traffic_light)) + 
-    geom_tile(width = 25, height = 0.85, linewidth = .25, color = "black")+ 
-    geom_text(aes(label = percentage), size = 3)+
+    geom_tile(width = 25, height = 1, linewidth = .25, color = "black")+ 
+    geom_text(aes(label = percentage), size = 2.3)+
     scale_fill_manual(values = traffic_light_colours, 
                       name = '% of pathways where\nRTT is possible', 
                       drop = FALSE,
@@ -84,7 +84,8 @@ product2_plot_heatmap_monthly <- function(df_rtt, date_max){
     #theme(plot.title = element_text(hjust = 0.5))+
     theme(strip.background = element_rect(fill = "white", linewidth = 1, linetype = "solid"),
           plot.caption = element_text(hjust = 1, size = 6),
-          axis.text.x = element_text(hjust = 0.5, vjust = 0.5))
+          axis.text.x = element_text( hjust = 1, vjust = 1, angle = 45),
+          legend.title = element_text(size = 9))
 
 
   ggsave(paste0(product2_dir,'/mth_product2_heatmap_', date_max,

06_calculations/calculate_adjusted_rtt_waits.R

@@ -36,7 +36,7 @@ calculate_adjusted_rtt_waits <- function(df){
   df_reset <- df_rtt |>
     mutate(dna_date = if_else(#app_purpose %in% c(2, 3) & removing - should reset for treatment and assessment app d/cna/w
                                 att_status %in% c(3, 5, 8) &
-                                app_date < first_treat_app,
+                                app_date < first_treat_app, # should this <= instead?
                               app_date, NA_Date_)) |> # makes a column with dates for any D/CNA/W # will need to add cancellation date here
 
     filter(!is.na(dna_date)) |> # removes gaps between dnas so lag doesn't get interrupted

07_publication/script/chapters/2_load_functions.R

@@ -69,3 +69,5 @@ source('./07_publication/script/functions/get_forpub_refs_agesex.R')
 #### Functions for MMI only ----------------------------------------------------
 
 source('./07_publication/script/functions/summarise_patients_seen.R')
+source('./07_publication/script/functions/compile_pat_seen_adj_excel_summary.R')
+source('./07_publication/script/functions/compile_pat_seen_unadj_excel_summary.R')

07_publication/script/chapters/3_set_constants.R

@@ -35,6 +35,7 @@ apps_att_dir <- paste0(shorewise_pub_data_dir, "/appointments_att/")
 basic_opti_dir <- paste0(shorewise_pub_data_dir, "/basic_v_opti/")
 markdown_dir <- paste0(root_dir, "/markdown/")
 open_dir <- paste0(shorewise_pub_data_dir, "/open_cases/")
+pat_seen_dir <- paste0(shorewise_pub_data_dir, "/patients_seen/")
 
 # 4 - Reference -----------------------------------------------------------
 
@@ -65,8 +66,8 @@ df_ds_hb_name <- cross_join(as.data.frame(vec_dataset_type),
   rename(dataset_type = vec_dataset_type,
          hb_name = hb_vector) |> 
   mutate(hb_name = factor(hb_name, levels = hb_vector))
-  filter(!(#dataset_type == "CAMHS" & 
-             hb_name == "NHS 24")) # remove invalid combo
+  # filter(!(#dataset_type == "CAMHS" & 
+  #            hb_name == "NHS 24")) # remove invalid combo
 
 # with time columns
 df_time <- data.frame(month = date_range) |> 

07_publication/script/functions/compile_pat_seen_adj_excel_summary.R

@@ -13,20 +13,20 @@ compile_pat_seen_adj_summary <- function(){
   #filnames <- list.files(ref_dir)
 
   #  load parquet files 
-  p1 <- read_parquet(paste0(pat_seen_dir, "adj_wait_grp_all.parquet"))
-  p2 <- read_parquet(paste0(pat_seen_dir, "adj_wait_grp_all_sex.parquet"))
-  p3 <- read_parquet(paste0(pat_seen_dir, "adj_wait_grp_all_age.parquet"))
-  p4 <- read_parquet(paste0(pat_seen_dir, "adj_wait_grp_all_simd.parquet"))
+  p1 <- read_parquet(paste0(pat_seen_dir, "pat_seen_adj_wait_grp_all.parquet"))
+  p2 <- read_parquet(paste0(pat_seen_dir, "pat_seen_adj_wait_grp_all_sex.parquet"))
+  p3 <- read_parquet(paste0(pat_seen_dir, "pat_seen_adj_wait_grp_all_age.parquet"))
+  p4 <- read_parquet(paste0(pat_seen_dir, "pat_seen_adj_wait_grp_all_simd.parquet"))
 
-  p5 <- read_parquet(paste0(pat_seen_dir, "adj_wait_grp_mth.parquet"))
-  p6 <- read_parquet(paste0(pat_seen_dir, "adj_wait_grp_mth_sex.parquet"))
-  p7 <- read_parquet(paste0(pat_seen_dir, "adj_wait_grp_mth_age.parquet"))
-  p8 <- read_parquet(paste0(pat_seen_dir, "adj_wait_grp_mth_simd.parquet"))
+  p5 <- read_parquet(paste0(pat_seen_dir, "pat_seen_adj_wait_grp_mth.parquet"))
+  p6 <- read_parquet(paste0(pat_seen_dir, "pat_seen_adj_wait_grp_mth_sex.parquet"))
+  p7 <- read_parquet(paste0(pat_seen_dir, "pat_seen_adj_wait_grp_mth_age.parquet"))
+  p8 <- read_parquet(paste0(pat_seen_dir, "pat_seen_adj_wait_grp_mth_simd.parquet"))
 
-  p9 <- read_parquet(paste0(pat_seen_dir, "adj_wait_grp_qt.parquet"))
-  p10 <- read_parquet(paste0(pat_seen_dir, "adj_wait_grp_qt_sex.parquet"))
-  p11 <- read_parquet(paste0(pat_seen_dir, "adj_wait_grp_qt_age.parquet"))
-  p12 <- read_parquet(paste0(pat_seen_dir, "adj_wait_grp_qt_simd.parquet"))
+  p9 <- read_parquet(paste0(pat_seen_dir, "pat_seen_adj_wait_grp_qt.parquet"))
+  p10 <- read_parquet(paste0(pat_seen_dir, "pat_seen_adj_wait_grp_qt_sex.parquet"))
+  p11 <- read_parquet(paste0(pat_seen_dir, "pat_seen_adj_wait_grp_qt_age.parquet"))
+  p12 <- read_parquet(paste0(pat_seen_dir, "pat_seen_adj_wait_grp_qt_simd.parquet"))
 
   # name tabs
   list_tabs <- list(