fixed non-stnadard issue. but needs testing. renv out of sync, build_site fails

Author: usrbinr

R/methods.R

@@ -8,7 +8,6 @@ create_calendar <- S7::new_generic("create_calendar","x")
 calculate <- S7::new_generic("calculate","x")
 
 
-complete_calendar <- S7::new_generic("complete_calendar","x")
 
 
 #' Create Calendar Table
@@ -39,7 +38,7 @@ S7::method(create_calendar,ti) <- function(x){
 
     start_date <- closest_sunday_feb1(min_year)
 
-    if(min_year<start_date){
+    if(min_year<lubridate::year(start_date)){
 
       start_date <- closest_sunday_feb1(min_year-1)
 
@@ -99,6 +98,9 @@ S7::method(create_calendar,ti) <- function(x){
       ,!!x@value@value_vec:= dplyr::coalesce(!!x@value@value_quo, 0)
     )
 
+
+
+
   return(full_dbi)
 }
 
@@ -167,55 +169,6 @@ S7::method(calculate,segment_abc) <- function(x){
 }
 
 
-#' @title complete_calendar
-#' @name complete_calendar
-#' @param x ti object
-#' @returns dbi object
-#' @keywords internal
-S7::method(complete_calendar,ti) <- function(x){
-
-
-  calendar_dbi<- x@datum@data |>
-    dplyr::count(!!x@datum@date_quo) |>
-    dplyr::select(-n)
-
-
-  date_vec <- x@datum@date_vec
-
-  out <- calendar_dbi |>
-    dplyr::mutate(
-      year_start_date=lubridate::floor_date(!!x@datum@date_quo,unit = "year")
-      ,year_end_date=dplyr::sql(glue::glue("date_trunc('year', {date_vec}) + INTERVAL '1' YEAR"))
-      ,quarter_start_date=lubridate::floor_date(!!x@datum@date_quo,unit = "quarter")
-      ,quarter_end_date=dplyr::sql(glue::glue("date_trunc('quarter', {date_vec}) + INTERVAL '1' quarter"))
-      ,month_start_date=lubridate::floor_date(!!x@datum@date_quo,unit = "month")
-      ,month_end_date=dplyr::sql(glue::glue("date_trunc('month', {date_vec}) + INTERVAL '1' month"))
-      ,week_start_date=lubridate::floor_date(!!x@datum@date_quo,unit = "week")
-      ,week_end_date=dplyr::sql(glue::glue("date_trunc('month', {date_vec}) + INTERVAL '1' month"))
-      ,day_of_week=lubridate::wday(!!x@datum@date_quo,label = FALSE)
-      ,day_of_week_label=lubridate::wday(!!x@datum@date_quo,label = TRUE)
-      ,days_in_year=year_end_date-year_start_date
-      ,days_in_quarter=quarter_end_date-quarter_start_date
-      ,days_in_month=dplyr::sql(glue::glue("last_day({date_vec})"))
-      ,days_complete_in_week=!!x@datum@date_quo-week_start_date
-      ,days_remaining_in_week=week_end_date-!!x@datum@date_quo
-      ,days_remaining_in_quarter=quarter_end_date-!!x@datum@date_quo
-      ,days_remaining_in_month=month_end_date-!!x@datum@date_quo
-      ,days_remaining_in_year=year_end_date-!!x@datum@date_quo
-      ,days_complete_in_year=!!x@datum@date_quo-year_start_date
-      ,days_complete_in_quarter=!!x@datum@date_quo-quarter_start_date
-      ,days_complete_in_month=!!x@datum@date_quo-month_start_date
-      ,days_complete_in_year=!!x@datum@date_quo-year_start_date
-      ,weekend_indicator=dplyr::if_else(day_of_week_label %in% c("Saturday","Sunday"),1,0)
-    ) |>
-    dplyr::mutate(
-      dplyr::across(dplyr::contains("date"),\(x) as.Date(x))
-    )
-
-  return(out)
-
-}
-
 
 
 #' @title Print ti objects
@@ -418,3 +371,55 @@ S7::method(print,segment_cohort) <- function(x,...){
   print_next_steps()
 
 }
+
+
+
+# complete_calendar <- S7::new_generic("complete_calendar","x")
+
+
+
+# S7::method(complete_calendar,ti) <- function(x){
+#
+#
+#   calendar_dbi<- x@datum@data |>
+#     dplyr::count(!!x@datum@date_quo) |>
+#     dplyr::select(-n)
+#
+#
+#   date_vec <- x@datum@date_vec
+#
+#   out <- calendar_dbi |>
+#     dplyr::mutate(
+#       year_start_date=lubridate::floor_date(!!x@datum@date_quo,unit = "year")
+#       ,year_end_date=dplyr::sql(glue::glue("date_trunc('year', {date_vec}) + INTERVAL '1' YEAR"))
+#       ,quarter_start_date=lubridate::floor_date(!!x@datum@date_quo,unit = "quarter")
+#       ,quarter_end_date=dplyr::sql(glue::glue("date_trunc('quarter', {date_vec}) + INTERVAL '1' quarter"))
+#       ,month_start_date=lubridate::floor_date(!!x@datum@date_quo,unit = "month")
+#       ,month_end_date=dplyr::sql(glue::glue("date_trunc('month', {date_vec}) + INTERVAL '1' month"))
+#       ,week_start_date=lubridate::floor_date(!!x@datum@date_quo,unit = "week")
+#       ,week_end_date=dplyr::sql(glue::glue("date_trunc('month', {date_vec}) + INTERVAL '1' month"))
+#       ,day_of_week=lubridate::wday(!!x@datum@date_quo,label = FALSE)
+#       ,day_of_week_label=lubridate::wday(!!x@datum@date_quo,label = TRUE)
+#       ,days_in_year=year_end_date-year_start_date
+#       ,days_in_quarter=quarter_end_date-quarter_start_date
+#       ,days_in_month=dplyr::sql(glue::glue("last_day({date_vec})"))
+#       ,days_complete_in_week=!!x@datum@date_quo-week_start_date
+#       ,days_remaining_in_week=week_end_date-!!x@datum@date_quo
+#       ,days_remaining_in_quarter=quarter_end_date-!!x@datum@date_quo
+#       ,days_remaining_in_month=month_end_date-!!x@datum@date_quo
+#       ,days_remaining_in_year=year_end_date-!!x@datum@date_quo
+#       ,days_complete_in_year=!!x@datum@date_quo-year_start_date
+#       ,days_complete_in_quarter=!!x@datum@date_quo-quarter_start_date
+#       ,days_complete_in_month=!!x@datum@date_quo-month_start_date
+#       ,days_complete_in_year=!!x@datum@date_quo-year_start_date
+#       ,weekend_indicator=dplyr::if_else(day_of_week_label %in% c("Saturday","Sunday"),1,0)
+#     ) |>
+#     dplyr::mutate(
+#       dplyr::across(dplyr::contains("date"),\(x) as.Date(x))
+#     )
+#
+#   return(out)
+#
+# }
+
+

R/utils-misc.R

@@ -581,10 +581,11 @@ create_non_standard_month <- function(.data,pattern){
 #' @param .data data
 #' @param pattern 554,445 or 545
 #' @param x is ti object
-#'
+#' @keywords internal
 #' @returns DBI object
 #'
-augment_non_standard_calendar <- function(.data,x,pattern){
+complete_non_standard_calendar <- function(.data,x){
+
 
   #test inputs
   # pattern <- "544"
@@ -593,6 +594,11 @@ augment_non_standard_calendar <- function(.data,x,pattern){
   days_in_week=7
   weeks_in_quarter=13
   quarters_in_year=4
+  old_cols <- colnames(.data)
+  date_cols <- x@fn@new_date_column_name[x@fn@new_date_column_name!="date"]
+  new_cols <- lubridate::union(old_cols,new_cols)
+  pattern <- x@datum@calendar_type
+
   # start_year <- closest_sunday_feb1(min_year)
   min_date <- x@datum@min_date
 
@@ -632,11 +638,93 @@ augment_non_standard_calendar <- function(.data,x,pattern){
       date>min_date
     )
 
+
+  out <- out |>
+    dplyr::select(dplyr::any_of(new_cols))
+
   return(out)
 
 }
 
 
+#' Title
+#'
+#' @param .data DBI object
+#' @param x ti object
+#' @keywords internal
+#' @returns DBI object
+#'
+complete_standard_calendar <- function(.data,x){
+
+
+  if(any(x@fn@new_date_column_name %in% "year")){
+
+    .data <- .data |>
+      dplyr::mutate(
+        year=lubridate::year(date)
+      )
+
+  }
+  if(any(x@fn@new_date_column_name %in% "quarter")){
+
+    .data <- .data |>
+      dplyr::mutate(
+        year=lubridate::quarter(date)
+      )
+
+  }
+
+  if(any(x@fn@new_date_column_name %in% "month")){
+
+    .data <- .data |>
+      dplyr::mutate(
+        year=lubridate::month(date)
+      )
+
+  }
+
+  if(any(x@fn@new_date_column_name %in% "day")){
+
+    .data <- .data |>
+      dplyr::mutate(
+        year=lubridate::day(date)
+      )
+
+  }
+
+  return(.data)
+
+}
+
+
+#' Title
+#'
+#' @param x ti object
+#' @keywords internal
+#'
+#' @returns DBI object
+#'
+create_full_dbi <- function(x){
+
+
+  if(x@datum@calendar_type=="standard"){
+
+    full_dbi <-  create_calendar(x) |>
+      complete_standard_calendar(x=x)
+
+  }
+
+  if(x@datum@calendar_type!="standard"){
+
+    full_dbi <-  create_calendar(x) |>
+      complete_non_standard_calendar(x=x)
+  }
+
+  return(full_dbi)
+
+}
+
+
 utils::globalVariables(
   c(
     "desc",

_pkgdown.yml

@@ -16,7 +16,6 @@
       desc: "General helper and execution utilities."
       contents:
         - augment_standard_calendar
-        - augment_non_standard_calendar
         - calculate
 
     - title: "Cohort & Classification"