working 554 calendar

Author: usrbinr

554.R

@@ -16,90 +16,47 @@ min_year <- year(x@datum@min_date)
 
 start_year <- closest_sunday_feb1(min_year)
 
-
 new_cal <- fpaR:::seq_date_sql(start_date = start_year,end_date=x@datum@max_date,time_unit = "day",con =con ) |>
   augment_calendar(.date = date)
 
+#  this should generate a type of calendar
+# need to validate year logic -- I am getting 53 weeks all the time
 
 
-## next step add in new year indicator
-new_cal |>
-  dplyr::mutate(
-    new_week_indicator=if_else(day_of_week==1,1,0)
-    ,cumulative_week_count=cumsum(new_week_indicator)
-    ,quarter_554=case_when(
-      cumulative_week_count<=14~1
-      ,cumulative_week_count<=28~2
-      ,cumulative_week_count<=42~3
-      ,.default=4
-    )
-    ,month_554=case_when(
-      cumulative_week_count<=5~1
-      ,cumulative_week_count<=10~2
-      ,cumulative_week_count<=14~3
-      ,.default=0
-    )
-    ,.before=1
-  )
-
-
-
-
-# Example usage:
-map(2021:2024,\(x) closest_sunday_feb1(x))
-
-
-generate_5_5_4_daily <- function(start_date, num_years = 1) {
-  start_date <- as.Date(start_date)
 
-  # 5-5-4 pattern: weeks per month
-  weeks_per_quarter <- c(5, 5, 4)
-  weeks_per_year <- rep(weeks_per_quarter, 4)  # 12 months
+pattern <- "544"
 
-  # Total weeks to generate
-  total_weeks <- length(weeks_per_year) * num_years
 
-  # Generate week numbers
-  week_number <- 1:total_weeks
+days_in_week=7
+weeks_in_quarter=13
+quarters_in_year=4
 
-  # Generate fiscal years
-  fiscal_year <- rep(1:num_years, each = length(weeks_per_year))
-
-  # Generate month assignment
-  month_pattern <- 1:12
-  month <- rep(month_pattern, times = weeks_per_year)  # expand by weeks per month
-  month <- rep(month, times = num_years)              # expand for multiple years
-  month <- month[1:total_weeks]                        # truncate if needed
-
-  # Generate start dates for each week
-  week_starts <- start_date + 7 * (week_number - 1)
-
-  # Generate daily dates
-  daily_dates <- unlist(lapply(week_starts, function(d) d + 0:6))
-
-  # Repeat week, month, fiscal year info for each day
-  week_number_daily <- rep(week_number, each = 7)
-  month_daily <- rep(month, each = 7)
-  fiscal_year_daily <- rep(fiscal_year, each = 7)
-
-  # Return daily calendar
-  data.frame(
-    date = daily_dates,
-    fiscal_year = fiscal_year_daily,
-    month = month_daily,
-    week_number = week_number_daily
+# out <-
+  new_cal |>
+  dbplyr::window_order(date) |>
+  select(date,day_of_week) |>
+  dplyr::mutate(
+      year_index=dplyr::if_else(dplyr::row_number()%%(days_in_week*weeks_in_quarter*quarters_in_year)==1,1,0)
+      ,year_ns=cumsum(year_index)
+  ) |>
+  dplyr::mutate(
+    week_index=dplyr::if_else(dplyr::row_number()%%7==1,1,0)
+    ,week_ns=cumsum(week_index)
+    ,.by=year_ns
   ) |>
-    mutate(
-      date=as.Date(date)
+  create_ns_month(pattern=pattern) |>
+  dplyr::mutate(
+    quarter_ns=dplyr::case_when(
+      month_ns<=3~1
+      ,month_ns<=6~2
+      ,month_ns<=9~3
+      ,.default=4
     )
-}
+  ) |> collect() |> arrange(date)
 
-# Example usage: daily calendar starting Feb 2, 2020, for 1 year
-generate_5_5_4_daily("2020-02-02", num_years = 1)
 
 
-## next step add in new year indicator
+out |> collect() |> arrange(date)
 
 
 
-## add in period indicator for that

R/utils-misc.R

@@ -219,7 +219,7 @@ print_actions_steps <- function(x){
 #'   date-based attributes.
 #' @keywords internal
 
-augment_calendar_tbl <- function(.data,.date){
+augment_standard_calendar_tbl <- function(.data,.date){
 
 lubridate::days
   # create attibutes
@@ -311,7 +311,7 @@ lubridate::days
 #' @return A dbi containing the original data along with all generated
 #'   date-based attributes.
 #' @keywords internal
-augment_calendar_dbi <- function(.data,.date){
+augment_standard_calendar_dbi <- function(.data,.date){
 
 
   date_vec <- rlang::as_label(.date)
@@ -357,11 +357,8 @@ augment_calendar_dbi <- function(.data,.date){
 
 
 
-
-
-
 #' @title Add Comprehensive Date-Based Attributes to a DBI  lazy frame or tibble object
-#' @name augment_calendar
+#' @name augment_standard_calendar
 #' @description
 #' This function takes a data frame and a date column and generates a wide set of
 #' derived date attributes. These include start/end dates for year, quarter,
@@ -407,7 +404,7 @@ augment_calendar_dbi <- function(.data,.date){
 #' @return A dbi or  tibble containing the original data along with all generated
 #'   date-based attributes.
 #'
-augment_calendar <- function(.data,.date){
+augment_standard_calendar <- function(.data,.date){
 
   data_class <- class(.data)
 
@@ -420,7 +417,7 @@ augment_calendar <- function(.data,.date){
 
   if(any(data_class %in% "tbl_lazy")){
 
-    out <- augment_calendar_dbi(.data = .data,.date = .date_var)
+    out <- augment_standard_calendar_dbi(.data = .data,.date = .date_var)
 
     return(out)
 
@@ -429,7 +426,7 @@ augment_calendar <- function(.data,.date){
 
   if(any(data_class %in% "tbl")){
 
-    out <- augment_calendar_tbl(.data = .data,.date = !!.date_var)
+    out <- augment_standard_calendar_tbl(.data = .data,.date = !!.date_var)
 
     return(out)
   }
@@ -460,6 +457,121 @@ closest_sunday_feb1 <- function(year) {
 }
 
 
+#' Create Non-Standard Month
+#'
+#' @param .data non-standard calendar table
+#' @param pattern '554','545' or '445'
+#'
+#' @returns DBI object
+#'
+#' @keywords internal
+create_ns_month <- function(.data,pattern){
+
+
+  valid_colnames <- c("week_ns","year_ns")
+  valid_pattern <- c("544","545","445")
+
+
+  assertthat::assert_that(
+    pattern %in% valid_pattern
+    ,msg = cli::cli_abort("Please select {.or {.val {valid_pattern}}}")
+  )
+
+
+  assertthat::assert_that(
+    pattern %in% valid_pattern
+    ,msg = cli::cli_abort("Please ensure [.val week_ns] and [.val year_ns] are in the dataset")
+  )
+
+
+  if(pattern=="544"){
+
+    valid_cumulative_months <- cumsum(rep(c(5,4,4),4))
+
+    out <-
+      .data |>
+      dplyr::mutate(
+        .by=year_ns
+        ,month_ns=dplyr::case_when(
+          # either framing it in advance or somehow passing a arg to it
+          week_ns<=!!valid_cumulative_months[[1]]~1
+          ,week_ns<=!!valid_cumulative_months[[2]]~2
+          ,week_ns<=!!valid_cumulative_months[[3]]~3
+          ,week_ns<=!!valid_cumulative_months[[4]]~4
+          ,week_ns<=!!valid_cumulative_months[[5]]~5
+          ,week_ns<=!!valid_cumulative_months[[6]]~6
+          ,week_ns<=!!valid_cumulative_months[[7]]~7
+          ,week_ns<=!!valid_cumulative_months[[8]]~8
+          ,week_ns<=!!valid_cumulative_months[[9]]~9
+          ,week_ns<=!!valid_cumulative_months[[10]]~10
+          ,week_ns<=!!valid_cumulative_months[[11]]~11
+          ,week_ns<=!!valid_cumulative_months[[12]]~12
+          ,.default=13
+        )
+      )
+  }
+
+  if(pattern=="445"){
+
+    valid_cumulative_months <- cumsum(rep(c(4,4,5),4))
+
+    out <- .data |>
+      dplyr::mutate(
+        .by=year_ns
+        ,month_ns=dplyr::case_when(
+          # either framing it in advance or somehow passing a arg to it
+          week_ns<=!!valid_cumulative_months[[1]]~1
+          ,week_ns<=!!valid_cumulative_months[[2]]~2
+          ,week_ns<=!!valid_cumulative_months[[3]]~3
+          ,week_ns<=!!valid_cumulative_months[[4]]~4
+          ,week_ns<=!!valid_cumulative_months[[5]]~5
+          ,week_ns<=!!valid_cumulative_months[[6]]~6
+          ,week_ns<=!!valid_cumulative_months[[7]]~7
+          ,week_ns<=!!valid_cumulative_months[[8]]~8
+          ,week_ns<=!!valid_cumulative_months[[9]]~9
+          ,week_ns<=!!valid_cumulative_months[[10]]~10
+          ,week_ns<=!!valid_cumulative_months[[11]]~11
+          ,week_ns<=!!valid_cumulative_months[[12]]~12
+          ,.default=13
+        )
+      )
+  }
+
+
+  if(pattern=="454"){
+
+    valid_cumulative_months <- cumsum(rep(c(4,5,4),4))
+
+    out <- .data |>
+      dplyr::mutate(
+        .by=year_ns
+        ,month_ns=dplyr::case_when(
+          # either framing it in advance or somehow passing a arg to it
+          week_ns<=!!valid_cumulative_months[[1]]~1
+          ,week_ns<=!!valid_cumulative_months[[2]]~2
+          ,week_ns<=!!valid_cumulative_months[[3]]~3
+          ,week_ns<=!!valid_cumulative_months[[4]]~4
+          ,week_ns<=!!valid_cumulative_months[[5]]~5
+          ,week_ns<=!!valid_cumulative_months[[6]]~6
+          ,week_ns<=!!valid_cumulative_months[[7]]~7
+          ,week_ns<=!!valid_cumulative_months[[8]]~8
+          ,week_ns<=!!valid_cumulative_months[[9]]~9
+          ,week_ns<=!!valid_cumulative_months[[10]]~10
+          ,week_ns<=!!valid_cumulative_months[[11]]~11
+          ,week_ns<=!!valid_cumulative_months[[12]]~12
+          ,.default=13
+        )
+      )
+  }
+
+  return(out)
+
+
+}
+
+
+
+
 utils::globalVariables(
   c(
     "desc",