Merge March 24 update into Master

DESCRIPTION

@@ -73,4 +73,5 @@ Encoding: UTF-8
 Language: en-GB
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.1
+

NAMESPACE

@@ -54,6 +54,7 @@ export(get_nsu_path)
 export(get_pop_path)
 export(get_practice_details_path)
 export(get_readcode_lookup_path)
+export(get_sandpit_extract_path)
 export(get_sc_at_episodes_path)
 export(get_sc_ch_episodes_path)
 export(get_sc_client_lookup_path)

R/00-update_refs.R

@@ -7,7 +7,7 @@
 #'
 #' @family initialisation
 latest_update <- function() {
-  "Dec_2023"
+  "Mar_2024"
 }
 
 #' Previous update
@@ -34,11 +34,11 @@
 
   latest_update_date <- lubridate::my(latest_update())
 
   previous_update_year <- lubridate::year(
     latest_update_date - lubridate::period(months_ago, "months")
   )
 
   previous_update_month <- lubridate::month(
     latest_update_date - lubridate::period(months_ago, "months"),
     label = TRUE,
     abbr = TRUE
@@ -61,7 +61,7 @@
 #'
 #' @family initialisation
 get_dd_period <- function() {
-  "Jul16_Sep23"
+  "Jul16_Dec23"
 }
 
 #' The latest financial year for Cost uplift setting

R/add_hri_variables.R

@@ -4,9 +4,9 @@
 #' \itemize{
 #' \item{keep_flag = 0 when resident is Scottish}
 #' \item{keep_flag = 1 when resident is not Scottish}
 #' \item{keep_flag = 2 when the postcode is missing or a dummy, and the gpprac is missing}
 #' \item{keep_flag = 3 when the gpprac is not English and the postcode is missing}
 #' \item{keep_flag = 4 when the gpprac is not English and the postcode is a dummy}
 #' }
 #' The intention is to only keep the records where keep_flag = 0
 #'
@@ -22,20 +22,20 @@
   # of the postcode
   pc_areas <- slf_pc_lookup %>%
     dplyr::mutate(
       pc_area = stringr::str_match(postcode, "^[A-Z]{1,3}"),
       scot_flag = TRUE
     ) %>%
     dplyr::distinct(pc_area, scot_flag)
 
   # Create a flag, 'keep_flag', to determine whether individuals are Scottish
   # residents or not
   return_data <- data %>%
     dplyr::mutate(pc_area = stringr::str_match(postcode, "^[A-Z]{1,3}")) %>%
     dplyr::left_join(pc_areas, by = "pc_area") %>%
     dplyr::mutate(
       dummy_postcode = .data$postcode %in% c("BF010AA", "NF1 1AB", "NK010AA") |
         stringr::str_sub(.data$postcode, 1, 4) %in% c("ZZ01", "ZZ61"),
       eng_prac = .data$gpprac %in% c(99942, 99957, 99961, 99976, 99981, 99995, 99999),
       scottish_resident = dplyr::case_when(
         .data$scot_flag ~ 0L,
         (is_missing(.data$postcode) | .data$dummy_postcode) & is.na(.data$gpprac) ~ 2L,
@@ -82,7 +82,7 @@
       "mh_episodes",
       "gls_episodes",
       "op_newcons_attendances",
-      # op_newcons_dnas,
+      "op_newcons_dnas",
       "ae_attendances",
       "pis_paid_items",
       "ooh_cases"

R/add_keep_population_flag.R

@@ -15,7 +15,7 @@
   } else {
     ## Obtain the population estimates for Locality AgeGroup and Gender.
     pop_estimates <-
-      readr::read_rds(get_datazone_pop_path("DataZone2011_pop_est_2011_2021.rds")) %>%
+      readr::read_rds(get_pop_path(type = "datazone")) %>%
       dplyr::select(year, datazone2011, sex, age0:age90plus)
 
     # Step 1: Obtain the population estimates for Locality, AgeGroup, and Gender
@@ -105,7 +105,7 @@
       ) %>%
       dplyr::filter(keep_nsu == 1L) %>%
       dplyr::ungroup() %>%
       dplyr::select(-flag_to_remove)
 
     # step 3: match the flag back onto the slf
     individual_file <- individual_file %>%

R/aggregate_by_chi.R

@@ -7,7 +7,7 @@
 #' @importFrom data.table .SD
 #'
 #' @inheritParams create_individual_file
-aggregate_by_chi <- function(episode_file, exclude_sc_var = FALSE) {
+aggregate_by_chi <- function(episode_file, year, exclude_sc_var = FALSE) {
   cli::cli_alert_info("Aggregate by CHI function started at {Sys.time()}")
 
   # Convert to data.table
@@ -89,6 +89,7 @@ aggregate_by_chi <- function(episode_file, exclude_sc_var = FALSE) {
         "episodes",
         "beddays",
         "cost",
+        "_dnas",
         "attendances",
         "attend",
         "contacts",
@@ -109,8 +110,7 @@ aggregate_by_chi <- function(episode_file, exclude_sc_var = FALSE) {
     vars_start_with(
       episode_file,
       "sds_option"
-    ),
-    "health_net_cost_inc_dnas"
+    )
   )
   cols4 <- cols4[!(cols4 %in% "ch_cis_episodes")]
   if (exclude_sc_var) {
@@ -187,6 +187,7 @@ aggregate_by_chi <- function(episode_file, exclude_sc_var = FALSE) {
     individual_file_cols5[, chi := NULL],
     individual_file_cols6[, chi := NULL]
   )
+  individual_file <- individual_file[, year := year]
 
   # convert back to tibble
   return(dplyr::as_tibble(individual_file))

R/calculate_stay.R

@@ -37,9 +37,6 @@ calculate_stay <- function(year, start_date, end_date, sc_qtr = NULL) {
     if (anyNA(sc_qtr)) {
       cli::cli_abort("Some of the submitted quarters are missing")
     }
-    # else {
-    #   sc_qtr <- check_quarter_format(sc_qtr)
-    # }
 
     # Set Quarters
     qtr_end <- lubridate::add_with_rollback(
@@ -51,6 +48,7 @@ calculate_stay <- function(year, start_date, end_date, sc_qtr = NULL) {
       lubridate::period(1L, "days")
     )
 
+    # check logic here for care home methodology
     dummy_end_date <- dplyr::case_when(
       # If end_date is not missing use the end date
       !is.na(end_date) ~ end_date,

R/check_year_valid.R

@@ -46,7 +46,7 @@ check_year_valid <- function(
     return(FALSE)
   } else if (year >= "2425" && type %in% "sparra") {
     return(FALSE)
-  } else if (year >= "2324" && type %in% c("ch", "hc", "sds", "at")) {
+  } else if (year >= "2425" && type %in% c("ch", "hc", "sds", "at")) {
     return(FALSE)
   }
 

R/create_demog_test_flags.R

@@ -3,19 +3,19 @@
 #' @description Create the demographic flags for testing
 #'
 #' @param data a dataframe containing demographic variables e.g. chi
+#' @param chi Specify chi or anon_chi.
 #'
 #' @return a dataframe with flag (1 or 0) for each demographic variable.
 #' Missing value flag from [is_missing()]
 #'
 #' @family flag functions
-create_demog_test_flags <- function(data) {
+create_demog_test_flags <- function(data, chi = c(chi, anon_chi)) {
   data %>%
-    dplyr::arrange(.data$chi) %>%
+    dplyr::arrange({{ chi }}) %>%
     # create test flags
     dplyr::mutate(
-      valid_chi = phsmethods::chi_check(.data$chi) == "Valid CHI",
-      unique_chi = dplyr::lag(.data$chi) != .data$chi,
-      n_missing_chi = is_missing(.data$chi),
+      unique_chi = dplyr::lag({{ chi }}) != {{ chi }},
+      n_missing_chi = is_missing({{ chi }}),
       n_males = .data$gender == 1L,
       n_females = .data$gender == 2L,
       n_postcode = !is.na(.data$postcode) | !.data$postcode == "",

R/create_demographic_lookup.R

@@ -344,18 +344,21 @@ assign_d_cohort_high_cc <- function(dementia,
                                     liver,
                                     cancer,
                                     spec) {
-  high_cc <-
+  high_cc <- dplyr::case_when(
+    spec == "G5" ~ TRUE,
     # FOR FUTURE: PhysicalandSensoryDisabilityClientGroup or LearningDisabilityClientGroup = "Y",
     # then high_cc_cohort = TRUE
     # FOR FUTURE: Care home removed, here's the code: .data$recid = "CH" & age < 65
-    rowSums(dplyr::pick(c(
+    (rowSums(dplyr::pick(c(
       "dementia",
       "hefailure",
       "refailure",
       "liver",
       "cancer"
-    )), na.rm = TRUE) >= 1L |
-      spec == "G5"
+    )), na.rm = TRUE) >= 1L) ~ TRUE,
+    .default = FALSE
+  )
+
   return(high_cc)
 }
 

R/create_episode_file.R

@@ -103,6 +103,8 @@ create_episode_file <- function(
         "mar_beddays"
       )
     ) %>%
+    # match on sc client variables
+    join_sc_client(year, sc_client = sc_client, file_type = "episode") %>%
     # Check chi is valid using phsmethods function
     # If the CHI is invalid for whatever reason, set the CHI to NA
     dplyr::mutate(
@@ -135,15 +137,15 @@ create_episode_file <- function(
       year,
       slf_deaths_lookup
     ) %>%
-    join_sc_client(year, sc_client = sc_client, file_type = "episode") %>%
     load_ep_file_vars(year)
 
   if (!check_year_valid(year, type = c("ch", "hc", "at", "sds"))) {
     episode_file <- episode_file %>%
       dplyr::mutate(
         ch_chi_cis = NA,
-        sc_id_cis = NA,
+        ch_sc_id_cis = NA,
         ch_name = NA,
+        ch_postcode = NA,
         ch_adm_reason = NA,
         ch_provider = NA,
         ch_nursing = NA,
@@ -158,7 +160,9 @@ create_episode_file <- function(
         hc_cost_q4 = NA,
         hc_provider = NA,
         hc_reablement = NA,
-        sds_option_4 = NA,
+        person_id = NA,
+        sc_latest_submission = NA,
+        sc_send_lca = NA,
         sc_living_alone = NA,
         sc_support_from_unpaid_carer = NA,
         sc_social_worker = NA,

R/create_individual_file.R

@@ -73,7 +73,7 @@ create_individual_file <- function(
     ))) %>%
     remove_blank_chi() %>%
     add_cij_columns() %>%
-    add_all_columns()
+    add_all_columns(year = year)
 
   if (!check_year_valid(year, type = c("ch", "hc", "at", "sds"))) {
     individual_file <- individual_file %>%
@@ -82,7 +82,7 @@ create_individual_file <- function(
     individual_file <- individual_file %>%
       aggregate_ch_episodes() %>%
       clean_up_ch(year) %>%
-      aggregate_by_chi(exclude_sc_var = FALSE)
+      aggregate_by_chi(year = year, exclude_sc_var = FALSE)
   }
 
   individual_file <- individual_file %>%
@@ -202,7 +202,7 @@ add_cij_columns <- function(episode_file) {
 #' of prefixed column names created based on some condition.
 #' @family individual_file
 #' @inheritParams create_individual_file
-add_all_columns <- function(episode_file) {
+add_all_columns <- function(episode_file, year) {
   cli::cli_alert_info("Add all columns function started at {Sys.time()}")
 
   episode_file <- episode_file %>%
@@ -483,8 +483,10 @@ add_ch_columns <- function(episode_file, prefix, condition) {
       ch_ep_end = dplyr::if_else(
         eval(condition),
         .data$record_keydate2,
-        lubridate::NA_Date_  ),
-      # If end date is missing use the first day of next FY quarter
+        lubridate::NA_Date_
+      ),
+      # check logic here for care home methodology
+      # If end date is missing use the end of the FY quarter
       ch_ep_end = dplyr::if_else(
         eval(condition) & is.na(.data$ch_ep_end),
         start_next_fy_quarter(.data$sc_latest_submission),

R/create_service_use_lookup.R

@@ -908,7 +908,13 @@ assign_cohort_names <- function(data) {
         # Situation where no cost is greater than another,
         # so the maximum is the same  as the mean
         .data$cost_max == rowSums(
-          dplyr::pick("psychiatry_cost":"residential_care_cost")
+          dplyr::pick(c(
+            "psychiatry_cost", "maternity_cost", "geriatric_cost",
+            "elective_inpatient_cost", "limited_daycases_cost",
+            "routine_daycase_cost", "single_emergency_cost",
+            "multiple_emergency_cost", "prescribing_cost",
+            "outpatient_cost", "ae2_cost", "residential_care_cost"
+          ))
         ) / 12.0 ~ "Unassigned",
         .data$cost_max == .data$psychiatry_cost ~ "Psychiatry",
         .data$cost_max == .data$maternity_cost ~ "Maternity",

R/fix_sc_dates.R

@@ -9,7 +9,7 @@
 #' @return A date vector with replaced end dates
 fix_sc_start_dates <- function(start_date, period_start) {
   # Fix sds_start_date is missing by setting start_date to be the start of
-  # financial year
+  # financial period
   start_date <- dplyr::if_else(
     is.na(start_date),
     period_start,
@@ -30,12 +30,12 @@ fix_sc_start_dates <- function(start_date, period_start) {
 #' @param period Social care latest submission period.
 #'
 #' @return A date vector with replaced end dates
-fix_sc_end_dates <- function(start_date, end_date, period) {
+fix_sc_end_dates <- function(start_date, end_date, period_end_date) {
   # Fix sds_end_date is earlier than sds_start_date by setting end_date to be
   # the end of financial year
   end_date <- dplyr::if_else(
     start_date > end_date,
-    end_fy(year = stringr::str_sub(period, 1L, 4L), "alternate"),
+    period_end_date,
     end_date
   )
 
@@ -57,7 +57,7 @@ fix_sc_end_dates <- function(start_date, end_date, period) {
 #' @return A date vector with replaced end dates
 fix_sc_missing_end_dates <- function(end_date, period_end) {
   # Fix sds_end_date is earlier than sds_start_date by setting end_date to be
-  # the end of financial year
+  # the end of financial period
   end_date <- dplyr::if_else(
     is.na(end_date),
     period_end,

R/get_fy_quarter_dates.R

@@ -15,8 +15,6 @@
 start_fy_quarter <- function(quarter) {
   quarter_unique <- unique(quarter)
 
-  #check_quarter_format(quarter)
-
   cal_quarter_date_unique <- lubridate::yq(quarter_unique)
 
   fy_quarter_date_unique <- lubridate::add_with_rollback(
@@ -47,8 +45,6 @@ start_fy_quarter <- function(quarter) {
 end_fy_quarter <- function(quarter) {
   quarter_unique <- unique(quarter)
 
-  #check_quarter_format(quarter)
-
   cal_quarter_date_unique <- lubridate::yq(quarter_unique)
 
   fy_quarter_date_unique <- lubridate::add_with_rollback(
@@ -80,8 +76,6 @@ end_fy_quarter <- function(quarter) {
 start_next_fy_quarter <- function(quarter) {
   quarter_unique <- unique(quarter)
 
-  #check_quarter_format(quarter)
-
   cal_quarter_date_unique <- lubridate::yq(quarter_unique)
 
   fy_quarter_date_unique <- lubridate::add_with_rollback(
@@ -112,8 +106,6 @@ start_next_fy_quarter <- function(quarter) {
 end_next_fy_quarter <- function(quarter) {
   quarter_unique <- unique(quarter)
 
-  #check_quarter_format(quarter)
-
   cal_quarter_date_unique <- lubridate::yq(quarter_unique)
 
   fy_quarter_date_unique <- lubridate::add_with_rollback(
@@ -128,28 +120,3 @@ end_next_fy_quarter <- function(quarter) {
 
   return(end_next_fy_quarter)
 }
-
-#' Check quarter format
-#'
-#' @inheritParams start_fy_quarter
-#'
-#' @return `quarter` invisibly if no issues were found
-#'
-#' @family date functions
-# check_quarter_format <- function(quarter) {
-#   stopifnot(typeof(quarter) == "character")
-#
-#   if (any(
-#     stringr::str_detect(quarter, "^\\d{4}Q[1-4]$", negate = TRUE),
-#     na.rm = TRUE
-#   )) {
-#     cli::cli_abort(
-#       c("{.var quarter} must be in the format {.val YYYYQx}
-#                    where {.val x} is the quarter number.",
-#         "v" = "For example {.val 2019Q1}."
-#       )
-#     )
-#   }
-#
-#   return(invisible(quarter))
-# }

R/get_lookup_paths.R

@@ -126,7 +126,7 @@ get_pop_path <- function(file_name = NULL,
     "intzone" ~ stringr::str_glue("IntZone_pop_est_2011_\\d+?\\.{ext}")
   )
 
-  datazone_pop_path <- get_file_path(
+  pop_path <- get_file_path(
     directory = pop_dir,
     file_name = file_name,
     ext = ext,