product 2 monthly functions

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,24 +13,31 @@ 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 ---------------------------------------------------
 
 summarise_appointments_att() # key output "/appointments_att/apps_att_mth_hb.parquet"
 summarise_patients_seen() # key outputs "/patients_seen/pat_seen_unadj_wait_grp_mth.parquet' and "/patients_seen/pat_seen_adj_wait_grp_mth.parquet'
 
+summarise_open_cases()
+summarise_referrals()
+summarise_non_acceptance()
+
 # Step 4 - Excel summaries ------------------------------------------------# being used?
 
 compile_pat_seen_adj_summary()
 compile_pat_seen_unadj_summary()
+compile_appointments_summary()
 
+compile_open_cases_summary()
+compile_referrals_summary()
+compile_non_acceptance_summary()
 
 # Step 5 - Create plots ---------------------------------------------------
 # 

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()
-
-
-
-
 
 

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,