Clean test folder

NAMESPACE

@@ -1,11 +1,13 @@
 # Generated by roxygen2: do not edit by hand
 
 export("%>%")
+export(End)
 export(add_deceased_flag)
 export(add_homelessness_date_flags)
 export(add_homelessness_flag)
 export(add_hri_variables)
 export(add_nsu_cohort)
+export(as)
 export(check_year_format)
 export(clean_temp_data)
 export(clean_up_free_text)
@@ -22,10 +24,13 @@ export(create_episode_file)
 export(create_homelessness_lookup)
 export(create_individual_file)
 export(create_service_use_cohorts)
+export(date)
+export(dmy)
 export(end_fy)
 export(end_fy_quarter)
 export(end_next_fy_quarter)
 export(find_latest_file)
+export(fy)
 export(fy_interval)
 export(get_boxi_extract_path)
 export(get_ch_costs_path)
@@ -156,6 +161,7 @@ export(produce_episode_file_tests)
 export(produce_sc_sandpit_tests)
 export(produce_source_extract_tests)
 export(produce_test_comparison)
+export(qtr)
 export(read_dev_slf_file)
 export(read_extract_acute)
 export(read_extract_ae)

R/00-update_refs.R

@@ -1,3 +1,109 @@
+################################################################################
+# # Name of file -  00-update_refs.R
+# Original Authors - Jennifer Thom, Zihao Li
+# Original Date - August 2021
+# Update - Oct 2024
+#
+# Written/run on - RStudio Server
+# Version of R - 4.1.2
+#
+# Description - Use this script to update references needed for the SLF update.
+#
+# Manual changes needed to the following Essential Functions:
+#       # End_date
+#       # Check_year_valid
+#       # Delayed_discharges_period
+#       # Latest_update
+#
+################################################################################
+
+#' End date
+#'
+#' @return Get the end date of the latest update period
+#' @export End date as dmy
+#'
+end_date <- function() {
+  ## UPDATE ##
+  # Last date in reporting period
+  # Q1 June = 30062024
+  # Q2 September = 30092024
+  # Q3 December = 31122024
+  # Q4 March = 31032024
+  lubridate::dmy(30062024)
+}
+
+
+#' Check data exists for a year
+#'
+#' @description  Check there is data available for a given year
+#' as some extracts are year dependent. E.g Homelessness
+#' is only available from 2016/17 onwards.
+#'
+#' @param year Financial year
+#' @param type name of extract
+#'
+#' @return A logical TRUE/FALSE
+check_year_valid <- function(
+    year,
+    type = c(
+      "acute",
+      "ae",
+      "at",
+      "ch",
+      "client",
+      "cmh",
+      "cost_dna",
+      "dd",
+      "deaths",
+      "dn",
+      "gpooh",
+      "hc",
+      "homelessness",
+      "hhg",
+      "maternity",
+      "mh",
+      "nsu",
+      "outpatients",
+      "pis",
+      "sds",
+      "sparra"
+    )) {
+  if (year <= "1415" && type %in% c("dn", "sparra")) {
+    return(FALSE)
+  } else if (year <= "1516" && type %in% c("cmh", "homelessness", "dd")) {
+    return(FALSE)
+  } else if (year <= "1617" && type %in% c("ch", "hc", "sds", "at", "client", "cost_dna")) {
+    return(FALSE)
+  } else if (year <= "1718" && type %in% "hhg") {
+    return(FALSE)
+  } else if (year >= "2122" && type %in% c("cmh", "dn")) {
+    return(FALSE)
+  } else if (year >= "2324" && type %in% c("nsu", "hhg")) {
+    return(FALSE)
+  } else if (year >= "2425" && type %in% "nsu") {
+    return(FALSE)
+  } else if (year >= "2526" && type %in% c("ch", "hc", "sds", "at", "sparra")) {
+    return(FALSE)
+  }
+
+  return(TRUE)
+}
+
+
+#' Delayed Discharge period
+#'
+#' @description Get the period for Delayed Discharge
+#'
+#' @return The period for the Delayed Discharge file
+#' as MMMYY_MMMYY
+#' @export
+#'
+#' @family initialisation
+get_dd_period <- function() {
+  "Jul16_Jun24"
+}
+
+
 #' Latest update
 #'
 #' @description Get the date of the latest update, e.g 'Jun_2022'
@@ -10,6 +116,7 @@ latest_update <- function() {
   "Sep_2024"
 }
 
+
 #' Previous update
 #'
 #' @param months_ago Number of months since the previous update
@@ -51,19 +158,34 @@ previous_update <- function(months_ago = 3L, override = NULL) {
   return(previous_update)
 }
 
-#' Delayed Discharge period
+
+#' Extract latest FY from end_date
 #'
-#' @description Get the period for Delayed Discharge
+#' @return fy in format "2024"
+#' @export
 #'
-#' @return The period for the Delayed Discharge file
-#' as MMMYY_MMMYY
+fy <- function() {
+  # Latest FY
+  fy <- phsmethods::extract_fin_year(end_date()) %>% substr(1, 4)
+}
+
+
+#' Extract latest quarter from end_date
+#'
+#' @return qtr in format "Q1"
 #' @export
 #'
-#' @family initialisation
-get_dd_period <- function() {
-  "Jul16_Jun24"
+#' @examples
+qtr <- function() {
+  # Latest Quarter
+  qtr <- lubridate::quarter(end_date(), fiscal_start = 4)
+
+  qtr <- stringr::str_glue("Q{qtr}")
+
+  return(qtr)
 }
 
+
 #' The year list for slf to update
 #'
 #' @description Get the vector of years to update slf

R/process_costs_rmd.R

@@ -23,7 +23,8 @@ process_costs_rmd <- function(file_name) {
 
   output_dir <- fs::path(
     get_slf_dir(),
-    "Tests"
+    "Tests",
+    "cost_tests"
   )
 
   input_file <- get_file_path(
@@ -44,13 +45,19 @@ process_costs_rmd <- function(file_name) {
     check_mode = "write"
   )
 
-  rmarkdown::render(
-    input = input_file,
-    output_file = output_file,
-    output_format = "html_document",
-    envir = new.env(),
-    quiet = TRUE
-  )
+  if (fs::file_exists(output_file)) {
+    # Do not write file if it already exists
+    output <- NULL
+  } else {
+    # If file does not exist, create it
+    rmarkdown::render(
+      input = input_file,
+      output_file = output_file,
+      output_format = "html_document",
+      envir = new.env(),
+      quiet = TRUE
+    )
+  }
 
   if (fs::file_info(output_file)$user == Sys.getenv("USER")) {
     # Set the correct permissions

R/write_tests_xlsx.R

@@ -25,16 +25,12 @@ write_tests_xlsx <- function(comparison_data,
                              )) {
   # Set up the workbook ----
   if (workbook_name == "ep_file") {
-    if (is.null(year)) {
-      tests_workbook_name <-
-        stringr::str_glue(latest_update(), "_ep_file_tests")
-    }
+    tests_workbook_name <-
+      stringr::str_glue(latest_update(), "_{year}_ep_file_tests")
   }
   if (workbook_name == "indiv_file") {
-    if (is.null(year)) {
-      tests_workbook_name <-
-        stringr::str_glue(latest_update(), "_indiv_file_tests")
-    }
+    tests_workbook_name <-
+      stringr::str_glue(latest_update(), "_{year}_indiv_file_tests")
   }
   if (workbook_name == "lookup") {
     if (is.null(year)) {
@@ -53,17 +49,16 @@ write_tests_xlsx <- function(comparison_data,
     }
   }
   if (workbook_name == "extract") {
-    if (is.null(year)) {
-    } else {
-      tests_workbook_name <-
-        stringr::str_glue(latest_update(), "_{year}_extract_tests")
-    }
+    tests_workbook_name <-
+      stringr::str_glue(latest_update(), "_{year}_extract_tests")
   }
 
 
   tests_workbook_path <- fs::path(
     get_slf_dir(),
     "Tests",
+    fy(),
+    qtr(),
     tests_workbook_name,
     ext = "xlsx"
   )