Add experimental functionality

Author: mitchelloharawild

DESCRIPTION

@@ -29,5 +29,6 @@ RoxygenNote: 7.2.3
 Imports: 
     lifecycle,
     rlang,
+    timechange,
     tsibble
 VignetteBuilder: knitr

NAMESPACE

@@ -5,6 +5,7 @@ S3method(autoplot,tbl_ts)
 export(CoordCalendar)
 export(autolayer)
 export(autoplot)
+export(cal_gregorian)
 export(coord_calendar)
 import(rlang)
 import(tsibble)

R/cal_wrap.R

@@ -0,0 +1,10 @@
+calendar_wrap <- function(x, wrap_points = cal_gregorian("week")) {
+  time <- convert_time(x)
+
+  if(is.function(wrap_points)) {
+    wrap_points <- wrap_points(range(time, na.rm = TRUE))
+  }
+  i <- as.integer(cut(time, wrap_points))
+  x <- x - as.numeric(wrap_points)[i]
+  x
+}

R/coord-calendar.R

@@ -0,0 +1,103 @@
+#' Calendar coordinates
+#'
+#' @export
+coord_calendar <- function(period = "week", xlim = NULL, ylim = NULL, expand = TRUE,
+                           default = FALSE, clip = "on") {
+  ggplot2::ggproto(NULL, CoordCalendar,
+    period = period,
+    limits = list(x = xlim, y = ylim),
+    expand = expand,
+    default = default,
+    clip = clip
+  )
+}
+
+#' @rdname ggplot2-ggproto
+#' @format NULL
+#' @usage NULL
+#' @export
+CoordCalendar <- ggplot2::ggproto("CoordCalendar", ggplot2::CoordCartesian,
+  aspect = function(details) 1,
+
+  range = function(self, panel_params) {
+    list(
+      x = panel_params$x.range,
+      y = panel_params$y.range
+    )
+  },
+
+  # Currently only works for x, should work for c("x", "xmin", "xmax", "xend", "xintercept")
+  # transform_position is the appropriate helper for this, but this is incompatible with the group hack (as is xmin, xmax, xend)
+  transform = function(self, data, panel_params) {
+    # Not sure what to do with training panel guides yet
+    if(any(is.infinite(data$x))) return(data)
+
+    # Convert x from numeric for handling time
+    time <- if (data$x[[1]] > 1e7) {
+      structure(data$x, class = c("POSIXct", "POSIXt"))
+    } else if (max(data$x) < 1e5) {
+      structure(data$x, class = "Date")
+    } else {
+      # Already done?
+      # Need to figure this out so inputs to $transform are consistent
+      return(data)
+    }
+
+    wrap_points <- cal_gregorian(self$period)(range(time, na.rm = TRUE))
+    # data$group <-
+    grp <- as.integer(cut(time, wrap_points))
+    data$x <- data$x - as.numeric(wrap_points)[grp] #[data$group]
+
+    data
+  },
+
+  setup_panel_params = function(self, scale_x, scale_y, params = list()) {
+    # environment(ggplot2::CoordCartesian$setup_panel_params)$setup_panel_params(self, scale_x, scale_y, params)
+
+    # Find reasonable limits for x
+    lim_x <- c(0, max(diff(as.numeric(cal_gregorian(self$period)(self$limits$x %||% scale_x$range$range)))))
+
+    # calculate break information
+    out_x <- scale_x$break_info(lim_x)
+
+    # range in coord space has already been calculated
+    # needs to be in increasing order for transform_value() to work
+    # out_x$range <- range(continuous_ranges$continuous_range_coord)
+    out_x <- list(
+      # Note that a ViewScale requires a limit and a range that are before the
+      # Coord's transformation, so we pass `continuous_range`, not `continuous_range_coord`.
+      ggplot2:::view_scale_primary(scale_x, lim_x, lim_x),
+      sec = ggplot2:::view_scale_secondary(scale_x, lim_x, lim_x),
+      range = out_x$range,
+      labels = out_x$labels,
+      major = out_x$major_source,
+      minor = out_x$minor_source,
+      sec.labels = out_x$sec.labels,
+      sec.major = out_x$sec.major_source,
+      sec.minor = out_x$sec.minor_source
+    )
+    names(out_x) <- c("x", paste("x", names(out_x)[-1], sep = "."))
+
+    out_x <- ggplot2:::view_scales_from_scale(scale_x, self$limits$x, self$expand)
+    out_x$x.range <- lim_x
+    c(
+      out_x,
+      ggplot2:::view_scales_from_scale(scale_y, self$limits$y, self$expand)
+    )
+  },
+
+  modify_scales = function(self, scales_x, scales_y) {
+    # body(scales_x[[1L]]$trans$transform)[[2]] <- rlang::expr(browser())
+    # body(scales_x[[1L]]$trans$transform)[[4]] <- rlang::expr(as.numeric(x) %% !!lubridate::period_to_seconds(lubridate::as.period(self$period)))
+
+    invisible()
+  }
+
+  # setup_data = function(data, params = list()) {
+  #   data
+  # },
+  #
+  # setup_layout = function(layout, params) {
+  #   layout
+  # },
+)

R/seq-gen.R

@@ -0,0 +1,21 @@
+#' @export
+cal_gregorian <- function(period = "week", week_start = 1) {
+  function(x) {
+    if(any(!is.finite(x))) return(x)
+
+    # Convert to date, should not needed later?
+    out <- convert_time(x)
+
+    # out <- as.Date(x, origin = "1970-01-01")
+    # Only designed to work for period = "week" for now.
+    # wday <- 1 + (as.numeric(out) + (6 - week_start))%%7
+
+    out <- seq(
+      from = timechange::time_floor(out[1], period, week_start),
+      to = timechange::time_ceiling(out[2], period, week_start),
+      by = period
+    )
+    out
+    # vctrs::vec_cast(out, x)
+  }
+}

R/utils.R

@@ -0,0 +1,7 @@
+convert_time <- function(x) {
+  if (max(x) > 1e5) {
+    structure(x, class = c("POSIXct", "POSIXt"))
+  } else {
+    structure(x, class = "Date")
+  }
+}

README.Rmd

@@ -36,7 +36,24 @@ remotes::install_github("tidyverts/ggtime")
 ```{r example}
 library(ggtime)
 library(tsibble)
+library(ggplot2)
 tsibbledata::aus_production %>% 
   autoplot(Bricks)
+
+cal_trans_x <- function() {
+  scales::trans_new(
+    name = "calendar",
+    transform = ggtime:::calendar_wrap,
+    inverse = identity,
+    breaks = scales::breaks_pretty(),
+    domain = c(0, 60*60*24*7)
+  )
+}
+
+pedestrian[with(pedestrian, Sensor == "Southern Cross Station" & Date < "2015-03-01"),] |> 
+  autoplot(Count) +
+  # coord_calendar(xlim = c(Sys.time(), Sys.Date() + lubridate::days(1)))
+  ggplot2::coord_trans(x = cal_trans_x(), xlim = as.POSIXct(c("2024-03-25 00:00:00", "2024-03-31 23:59:59"))) +
+  scale_x_datetime(date_breaks = "day", date_labels = "%a")
 ```
 

README.md

@@ -29,15 +29,46 @@ remotes::install_github("tidyverts/ggtime")
 
 ``` r
 library(ggtime)
+#> Registered S3 method overwritten by 'tsibble':
+#>   method               from 
+#>   as_tibble.grouped_df dplyr
 library(tsibble)
 #> 
 #> Attaching package: 'tsibble'
 #> The following objects are masked from 'package:base':
 #> 
 #>     intersect, setdiff, union
+library(ggplot2)
 tsibbledata::aus_production %>% 
   autoplot(Bricks)
-#> Warning: Removed 20 rows containing missing values (`geom_line()`).
+#> Warning: Removed 20 rows containing missing values or values outside the scale range
+#> (`geom_line()`).
 ```
 
 <img src="man/figures/README-example-1.png" width="100%" />
+
+``` r
+
+cal_trans_x <- function() {
+  scales::trans_new(
+    name = "calendar",
+    transform = ggtime:::calendar_wrap,
+    inverse = identity,
+    breaks = scales::breaks_pretty(),
+    domain = c(0, 60*60*24*7)
+  )
+}
+
+pedestrian[with(pedestrian, Sensor == "Southern Cross Station" & Date < "2015-03-01"),] |> 
+  autoplot(Count) +
+  # coord_calendar(xlim = c(Sys.time(), Sys.Date() + lubridate::days(1)))
+  ggplot2::coord_trans(x = cal_trans_x(), xlim = as.POSIXct(c("2024-03-25 00:00:00", "2024-03-31 23:59:59"))) +
+  scale_x_datetime(date_breaks = "day", date_labels = "%a")
+#> Warning in max(x): no non-missing arguments to max; returning -Inf
+#> Warning in min.default(structure(numeric(0), class = "Date"), na.rm = FALSE):
+#> no non-missing arguments to min; returning Inf
+#> Warning in max.default(structure(numeric(0), class = "Date"), na.rm = FALSE):
+#> no non-missing arguments to max; returning -Inf
+```
+
+<img src="man/figures/README-example-2.png" width="100%" />