├── .github ├── .gitignore └── workflows │ ├── pkgdown.yaml │ ├── test-coverage.yaml │ ├── R-CMD-check.yaml │ └── pr-commands.yaml ├── src ├── .gitignore ├── Makevars ├── is_ordered.cpp ├── sorted_range_search.cpp └── RcppExports.cpp ├── revdep ├── failures.md ├── problems.md ├── .gitignore ├── email.yml ├── cran.md └── README.md ├── cran-comments.md ├── LICENSE ├── .gitignore ├── data ├── FB.rda └── FANG.rda ├── tests ├── testthat.R └── testthat │ ├── test_compat-dplyr.R │ ├── test-coercion.R │ ├── test_helpers.R │ ├── test_new.R │ ├── test_reconstruct.R │ ├── test_print.R │ ├── test_getters.R │ ├── test_floor_index.R │ ├── test_ceiling_index.R │ ├── test_parse_period.R │ ├── test_coercion.R │ ├── test_parse_time_formula.R │ ├── test_create_series.R │ ├── test_rollify.R │ ├── test_as_period.R │ ├── test_compat-tidyr.R │ ├── test_filter_time.R │ └── test_collapse_index.R ├── man ├── figures │ └── tibbletime-logo.png ├── reexports.Rd ├── reconstruct.Rd ├── getters.Rd ├── new_tbl_time.Rd ├── posixct_numeric_to_datetime.Rd ├── FB.Rd ├── tibbletime.Rd ├── FANG.Rd ├── parse_period.Rd ├── tbl_time.Rd ├── floor_index.Rd ├── ceiling_index.Rd ├── partition_index.Rd ├── collapse_by.Rd ├── create_series.Rd ├── collapse_index.Rd ├── filter_time.Rd ├── as_period.Rd └── rollify.Rd ├── inst └── include │ └── is_ordered.h ├── .Rbuildignore ├── codecov.yml ├── R ├── RcppExports.R ├── tibbletime-package.r ├── validators.R ├── print.R ├── seq.R ├── helpers.R ├── util.R ├── time_join.R ├── new.R ├── reconstruct.R ├── aaa.R ├── data.R ├── getters.R ├── parse_time_formula.R ├── round-index.R ├── coercion.R ├── to_posixct_numeric.R ├── parse_period.R ├── create_series.R ├── as_period.R ├── compat-tidyr.R ├── compat-dplyr.R ├── partition_index.R ├── filter_time.R ├── rollify.R ├── collapse_index.R └── index-based-generics.R ├── tibbletime.Rproj ├── _pkgdown.yml ├── README.md ├── README.Rmd ├── DESCRIPTION ├── vignettes ├── TT-02-changing-time-periods.Rmd ├── TT-04-use-with-dplyr.Rmd ├── TT-01-time-based-filtering.Rmd └── TT-03-rollify-for-rolling-analysis.Rmd └── NAMESPACE /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /src/.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.so 3 | *.dll 4 | -------------------------------------------------------------------------------- /revdep/failures.md: -------------------------------------------------------------------------------- 1 | *Wow, no problems at all. :)* -------------------------------------------------------------------------------- /revdep/problems.md: -------------------------------------------------------------------------------- 1 | *Wow, no problems at all. :)* -------------------------------------------------------------------------------- /cran-comments.md: -------------------------------------------------------------------------------- 1 | There are no known problems. 2 | -------------------------------------------------------------------------------- /src/Makevars: -------------------------------------------------------------------------------- 1 | PKG_CXXFLAGS = -I../inst/include 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2017 2 | COPYRIGHT HOLDER: Davis Vaughan 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | .DS_Store 6 | -------------------------------------------------------------------------------- /data/FB.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/business-science/tibbletime/HEAD/data/FB.rda -------------------------------------------------------------------------------- /data/FANG.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/business-science/tibbletime/HEAD/data/FANG.rda -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(tibbletime) 3 | 4 | test_check("tibbletime") 5 | -------------------------------------------------------------------------------- /man/figures/tibbletime-logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/business-science/tibbletime/HEAD/man/figures/tibbletime-logo.png -------------------------------------------------------------------------------- /revdep/.gitignore: -------------------------------------------------------------------------------- 1 | checks 2 | library 3 | checks.noindex 4 | library.noindex 5 | data.sqlite 6 | *.html 7 | cloud.noindex 8 | -------------------------------------------------------------------------------- /revdep/email.yml: -------------------------------------------------------------------------------- 1 | release_date: ??? 2 | rel_release_date: ??? 3 | my_news_url: ??? 4 | release_version: ??? 5 | release_details: ??? 6 | -------------------------------------------------------------------------------- /inst/include/is_ordered.h: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #ifndef IS_ORDERED_H 4 | #define IS_ORDERED_H 5 | 6 | bool is_ordered_numeric(Rcpp::NumericVector x); 7 | 8 | #endif 9 | -------------------------------------------------------------------------------- /revdep/cran.md: -------------------------------------------------------------------------------- 1 | ## revdepcheck results 2 | 3 | We checked 6 reverse dependencies, comparing R CMD check results across CRAN and dev versions of this package. 4 | 5 | * We saw 0 new problems 6 | * We failed to check 0 packages 7 | 8 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^CRAN-RELEASE$ 2 | ^.*\.Rproj$ 3 | ^\.Rproj\.user$ 4 | ^README\.Rmd$ 5 | ^\.travis\.yml$ 6 | ^cran-comments\.md$ 7 | ^docs$ 8 | ^_pkgdown\.yml$ 9 | ^codecov\.yml$ 10 | ^revdep$ 11 | ^\.github$ 12 | ^CRAN-SUBMISSION$ 13 | -------------------------------------------------------------------------------- /codecov.yml: -------------------------------------------------------------------------------- 1 | comment: false 2 | 3 | coverage: 4 | status: 5 | project: 6 | default: 7 | target: auto 8 | threshold: 1% 9 | informational: true 10 | patch: 11 | default: 12 | target: auto 13 | threshold: 1% 14 | informational: true 15 | -------------------------------------------------------------------------------- /R/RcppExports.R: -------------------------------------------------------------------------------- 1 | # Generated by using Rcpp::compileAttributes() -> do not edit by hand 2 | # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | is_ordered_numeric <- function(x) { 5 | .Call(`_tibbletime_is_ordered_numeric`, x) 6 | } 7 | 8 | sorted_range_search <- function(x, lower, upper) { 9 | .Call(`_tibbletime_sorted_range_search`, x, lower, upper) 10 | } 11 | 12 | -------------------------------------------------------------------------------- /tests/testthat/test_compat-dplyr.R: -------------------------------------------------------------------------------- 1 | test_that("ungroup() works", { 2 | df <- tibble::tibble( 3 | group = c("g1", "g1", "g2"), 4 | date = as.Date(c("2017-12-01", "2017-12-02", "2017-12-03")) 5 | ) 6 | 7 | df <- as_tbl_time(df, date) 8 | df <- dplyr::group_by(df, group) 9 | 10 | expect_s3_class( 11 | dplyr::ungroup(df), 12 | c("tbl_time", "tbl_df", "tbl", "data.frame"), 13 | exact = TRUE 14 | ) 15 | }) 16 | 17 | 18 | 19 | -------------------------------------------------------------------------------- /tibbletime.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | PackageRoxygenize: rd,collate,namespace 22 | -------------------------------------------------------------------------------- /man/reexports.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/compat-dplyr.R, R/util.R 3 | \docType{import} 4 | \name{reexports} 5 | \alias{reexports} 6 | \alias{filter} 7 | \alias{\%>\%} 8 | \title{Objects exported from other packages} 9 | \keyword{internal} 10 | \description{ 11 | These objects are imported from other packages. Follow the links 12 | below to see their documentation. 13 | 14 | \describe{ 15 | \item{dplyr}{\code{\link[dplyr:reexports]{\%>\%}}, \code{\link[dplyr]{filter}}} 16 | }} 17 | 18 | -------------------------------------------------------------------------------- /R/tibbletime-package.r: -------------------------------------------------------------------------------- 1 | #' tibbletime: time-aware tibbles 2 | #' 3 | #' Built on top of the 'tibble' package, 'tibbletime' is an extension 4 | #' that allows for the creation of time aware tibbles. Some immediate 5 | #' advantages of this include: the ability to perform time based subsetting 6 | #' on tibbles, quickly summarising and aggregating results by time periods, 7 | #' and calling functions similar in spirit to the map family from 'purrr' 8 | #' on time based tibbles. 9 | #' 10 | #' @name tibbletime 11 | #' @docType package 12 | "_PACKAGE" 13 | -------------------------------------------------------------------------------- /tests/testthat/test-coercion.R: -------------------------------------------------------------------------------- 1 | test_that("coercing tbl_time to tibble works", { 2 | df <- as_tbl_time(FANG, date) 3 | x <- as_tibble(df) 4 | 5 | expect_s3_class(x, c("tbl_df", "tbl", "data.frame"), exact = TRUE) 6 | 7 | # Ensure attributes are dropped 8 | expect_null(attr(x, "index_quo")) 9 | expect_null(attr(x, "index_time_zone")) 10 | }) 11 | 12 | test_that("coercing grouped_tbl_time to tibble drops groupedness", { 13 | df <- as_tbl_time(FANG, date) 14 | gdf <- group_by(df, symbol) 15 | x <- as_tibble(gdf) 16 | 17 | expect_s3_class(x, c("tbl_df", "tbl", "data.frame"), exact = TRUE) 18 | }) 19 | -------------------------------------------------------------------------------- /man/reconstruct.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/reconstruct.R 3 | \name{reconstruct} 4 | \alias{reconstruct} 5 | \title{Reconstruct an S3 class from a template} 6 | \usage{ 7 | reconstruct(new, old) 8 | } 9 | \arguments{ 10 | \item{new}{Freshly created object} 11 | 12 | \item{old}{Existing object to use as template} 13 | } 14 | \description{ 15 | This is an implementation of \code{sloop::reconstruct()} that users can 16 | ignore. Once \code{sloop} is on CRAN, this function will be removed and that 17 | version will be used. It currently must be exported for use in \code{tidyquant}. 18 | } 19 | -------------------------------------------------------------------------------- /man/getters.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/getters.R 3 | \name{getters} 4 | \alias{getters} 5 | \alias{get_index_quo} 6 | \alias{get_index_char} 7 | \alias{get_index_col} 8 | \alias{get_index_time_zone} 9 | \alias{get_index_class} 10 | \title{Getters} 11 | \usage{ 12 | get_index_quo(.tbl_time) 13 | 14 | get_index_char(.tbl_time) 15 | 16 | get_index_col(.tbl_time) 17 | 18 | get_index_time_zone(.tbl_time) 19 | 20 | get_index_class(.tbl_time) 21 | } 22 | \arguments{ 23 | \item{.tbl_time}{A \code{tbl_time} object.} 24 | } 25 | \description{ 26 | Accessors to attributes of \code{tbl_time} objects. 27 | } 28 | -------------------------------------------------------------------------------- /src/is_ordered.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include "is_ordered.h" 3 | using namespace Rcpp; 4 | 5 | // [[Rcpp::export]] 6 | bool is_ordered_numeric(NumericVector x) { 7 | 8 | // Setup 9 | int length_x = x.size(); 10 | int i; 11 | bool ordered = true; 12 | 13 | // Loop over each element 14 | // (Nicely won't execute for vectors of length 1) 15 | for(i = 0; i < length_x - 1; i++) { 16 | 17 | // Check if diff < 0 18 | // (< allows duplicates (<= would not)) 19 | if(x[i+1] - x[i] < 0.0) { 20 | 21 | ordered = false; 22 | 23 | // Terminate early 24 | break; 25 | 26 | } 27 | 28 | } 29 | 30 | return ordered; 31 | } 32 | -------------------------------------------------------------------------------- /R/validators.R: -------------------------------------------------------------------------------- 1 | # Main validator 2 | validate_tbl_time <- function(x) { 3 | assert_index_exists_in_colnames(x) 4 | assert_index_class_is_allowed(x) 5 | x 6 | } 7 | 8 | assert_index_exists_in_colnames <- function(x) { 9 | index_char <- get_index_char(x) 10 | assertthat::assert_that( 11 | index_char %in% colnames(x), 12 | msg = "Specified `index` is not a column of x" 13 | ) 14 | } 15 | 16 | assert_index_class_is_allowed <- function(x) { 17 | index_char <- get_index_char(x) 18 | index_col <- x[[index_char]] 19 | assertthat::assert_that( 20 | inherits_allowed_datetime(index_col), 21 | msg = "Specified `index` is not time based" 22 | ) 23 | } 24 | -------------------------------------------------------------------------------- /man/new_tbl_time.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/new.R 3 | \name{new_tbl_time} 4 | \alias{new_tbl_time} 5 | \title{Create a new tbl_time object} 6 | \usage{ 7 | new_tbl_time(x, index_quo, index_time_zone, ..., subclass = NULL) 8 | } 9 | \arguments{ 10 | \item{x}{A tibble or data.frame} 11 | 12 | \item{index_quo}{The quo that references the index column} 13 | 14 | \item{index_time_zone}{The index time zone} 15 | 16 | \item{...}{Other attributes passed through to new_tibble()} 17 | 18 | \item{subclass}{A subclass to have as a child} 19 | } 20 | \description{ 21 | Often used internally by developers extending tibbletime 22 | } 23 | -------------------------------------------------------------------------------- /tests/testthat/test_helpers.R: -------------------------------------------------------------------------------- 1 | context("helpers testing") 2 | 3 | # Test objects 4 | 5 | test_time <- tibble::tibble( 6 | date = c(as.Date("2017-12-01"), as.Date("2017-12-02"), as.Date("2017-12-03")), 7 | value = c(1, 2, 3), 8 | group1 = c("a", "a", "b"), 9 | group2 = c("d", "e", "e") 10 | ) 11 | 12 | test_tbl_time <- as_tbl_time(test_time, date) 13 | 14 | test_time_g <- test_time %>% 15 | dplyr::group_by(group1) 16 | 17 | test_tbl_time_g <- as_tbl_time(test_time_g, date) 18 | 19 | # Tests 20 | 21 | test_that("Helpers convert to tbl_time", { 22 | expect_equal(tbl_time(test_time, date), test_tbl_time) 23 | expect_equal(tbl_time(test_time_g, date), test_tbl_time_g) 24 | }) 25 | -------------------------------------------------------------------------------- /tests/testthat/test_new.R: -------------------------------------------------------------------------------- 1 | context("new testing") 2 | 3 | # Test objects 4 | 5 | data(FB) 6 | data(FANG) 7 | 8 | # Tests 9 | 10 | test_that("new_tbl_time() creates valid tbl_time objects", { 11 | 12 | FB_time <- new_tbl_time(FB, rlang::quo(date), "UTC") 13 | 14 | expect_is(FB_time, "tbl_time") 15 | expect_equal(get_index_time_zone(FB_time), "UTC") 16 | expect_equal(get_index_char(FB_time), "date") 17 | expect_equal(get_index_quo(FB_time), rlang::quo(date)) 18 | }) 19 | 20 | test_that("subclasses of tbl_time can be created", { 21 | 22 | FB_time <- new_tbl_time(FB, rlang::quo(date), "UTC", subclass = "sub_tbl_time") 23 | 24 | expect_is(FB_time, "sub_tbl_time") 25 | expect_is(FB_time, "tbl_time") 26 | }) 27 | -------------------------------------------------------------------------------- /man/posixct_numeric_to_datetime.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/to_posixct_numeric.R 3 | \name{posixct_numeric_to_datetime} 4 | \alias{posixct_numeric_to_datetime} 5 | \title{Converting a posixct numeric time back to a classed datetime} 6 | \usage{ 7 | posixct_numeric_to_datetime(x, class = "POSIXct", ..., tz = NULL) 8 | } 9 | \arguments{ 10 | \item{x}{A posixct numeric vector} 11 | 12 | \item{class}{The class to convert to} 13 | 14 | \item{...}{Extra arguments passed on the the specific coercion function} 15 | 16 | \item{tz}{The time zone to convert to. The default UTC is used if none is 17 | supplied} 18 | } 19 | \description{ 20 | Converting a posixct numeric time back to a classed datetime 21 | } 22 | -------------------------------------------------------------------------------- /R/print.R: -------------------------------------------------------------------------------- 1 | #' @export 2 | #' @importFrom pillar tbl_sum 3 | tbl_sum.tbl_time <- function(x) { 4 | out <- c( 5 | "A time tibble" = pillar::dim_desc(x), 6 | "Index" = get_index_char(x) 7 | ) 8 | 9 | if (dplyr::is_grouped_df(x)) { 10 | out <- c(out, "Groups" = group_sum(x)) 11 | } 12 | 13 | out 14 | } 15 | 16 | # `dplyr:::group_sum()` 17 | group_sum <- function(x) { 18 | grps <- dplyr::n_groups(x) 19 | 20 | vars <- dplyr::group_vars(x) 21 | vars <- paste0(vars, collapse = ", ") 22 | 23 | paste0(vars, " [", big_mark(grps), "]") 24 | } 25 | 26 | # `dplyr:::big_mark()` 27 | big_mark <- function(x, ...) { 28 | mark <- if (identical(getOption("OutDec"), ",")) { 29 | "." 30 | } else { 31 | "," 32 | } 33 | formatC(x, big.mark = mark, ...) 34 | } 35 | -------------------------------------------------------------------------------- /tests/testthat/test_reconstruct.R: -------------------------------------------------------------------------------- 1 | context("reconstruct testing") 2 | 3 | # Test objects 4 | 5 | test_time <- tibble::tibble( 6 | date = c(as.Date("2017-12-01"), as.Date("2017-12-02"), as.Date("2017-12-03")), 7 | value = c(1, 2, 3), 8 | group1 = c("a", "a", "b"), 9 | group2 = c("d", "e", "e") 10 | ) 11 | 12 | test_tbl_time <- as_tbl_time(test_time, date) 13 | 14 | # Tests 15 | 16 | test_that("Remove index then reconstruct results in tibble", { 17 | 18 | no_index <- select(test_tbl_time, -date) 19 | no_index <- reconstruct(no_index, test_tbl_time) 20 | 21 | expect_equal(length(class(no_index)), 3) 22 | }) 23 | 24 | test_that("Not removing index then reconstruct results in tbl_time", { 25 | 26 | with_index <- select(test_tbl_time, date) 27 | with_index <- reconstruct(with_index, test_tbl_time) 28 | 29 | expect_is(with_index, "tbl_time") 30 | }) 31 | -------------------------------------------------------------------------------- /tests/testthat/test_print.R: -------------------------------------------------------------------------------- 1 | context("print testing") 2 | 3 | # Test objects 4 | 5 | test_time <- tibble::tibble( 6 | date = c(as.Date("2017-12-01"), as.Date("2017-12-02"), as.Date("2017-12-03")), 7 | value = c(1, 2, 3), 8 | group1 = c("a", "a", "b"), 9 | group2 = c("d", "e", "e") 10 | ) 11 | 12 | test_tbl_time <- as_tbl_time(test_time, date) 13 | test_tbl_time_g <- as_tbl_time(test_time, date) %>% 14 | dplyr::group_by(group1) 15 | 16 | # Tests 17 | 18 | test_that("Index is part of the tibble output", { 19 | expect_identical( 20 | pillar::tbl_sum(test_tbl_time), 21 | c("A time tibble" = pillar::dim_desc(test_tbl_time), "Index" = "date") 22 | ) 23 | }) 24 | 25 | test_that("Groups are still printed", { 26 | expect_identical( 27 | pillar::tbl_sum(test_tbl_time_g), 28 | c("A time tibble" = pillar::dim_desc(test_tbl_time_g), "Index" = "date", "Groups" = "group1 [2]") 29 | ) 30 | }) 31 | 32 | -------------------------------------------------------------------------------- /R/seq.R: -------------------------------------------------------------------------------- 1 | # These are simple, and validation is done outside the function so that only 2 | # unique Dates -> yearmon are created. E.g., from/to will only end up being 1st of 3 | # the month and `by` will be year + month / year + quarter 4 | 5 | #' @export 6 | seq.yearmon <- function(from, to, by, ...) { 7 | .seq <- seq.Date( 8 | zoo::as.Date(from, tz = get_default_time_zone()), 9 | zoo::as.Date(to, tz = get_default_time_zone()), 10 | by 11 | ) 12 | zoo::as.yearmon(.seq) 13 | } 14 | 15 | #' @export 16 | seq.yearqtr <- function(from, to, by, ...) { 17 | .seq <- seq.Date( 18 | zoo::as.Date(from, tz = get_default_time_zone()), 19 | zoo::as.Date(to, tz = get_default_time_zone()), 20 | by 21 | ) 22 | zoo::as.yearqtr(.seq) 23 | } 24 | 25 | #' @export 26 | seq.hms <- function(from, to, by, ...) { 27 | .seq <- seq.POSIXt( 28 | as.POSIXct(from), 29 | as.POSIXct(to), 30 | by 31 | ) 32 | hms::as_hms(.seq) 33 | } 34 | -------------------------------------------------------------------------------- /_pkgdown.yml: -------------------------------------------------------------------------------- 1 | template: 2 | params: 3 | bootswatch: flatly 4 | ganalytics: UA-76139189-2 5 | 6 | development: 7 | mode: release 8 | 9 | navbar: 10 | title: "tibbletime" 11 | left: 12 | - text: "Home" 13 | href: index.html 14 | - text: "Function Reference" 15 | href: reference/index.html 16 | - text: "Vignettes" 17 | href: articles/index.html 18 | menu: 19 | - text: "Time-based filtering" 20 | href: articles/TT-01-time-based-filtering.html 21 | - text: "Changing periodicity" 22 | href: articles/TT-02-changing-time-periods.html 23 | - text: "Rolling calculations in tibbletime" 24 | href: articles/TT-03-rollify-for-rolling-analysis.html 25 | - text: "Using tibbletime with dplyr" 26 | href: articles/TT-04-use-with-dplyr.html 27 | - text: "News" 28 | href: news/index.html 29 | 30 | right: 31 | - icon: fa-github 32 | href: https://github.com/business-science/tibbletime 33 | -------------------------------------------------------------------------------- /man/FB.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/data.R 3 | \docType{data} 4 | \name{FB} 5 | \alias{FB} 6 | \title{Stock prices for Facebook from 2013-2016} 7 | \format{ 8 | A tibble with 1,008 rows and 8 variables: 9 | \describe{ 10 | \item{symbol}{stock ticker symbol} 11 | \item{date}{trade date} 12 | \item{open}{stock price at the open of trading, in USD} 13 | \item{high}{stock price at the highest point during trading, in USD} 14 | \item{low}{stock price at the lowest point during trading, in USD} 15 | \item{close}{stock price at the close of trading, in USD} 16 | \item{volume}{number of shares traded} 17 | \item{adjusted}{stock price at the close of trading adjusted for stock splits, in USD} 18 | } 19 | } 20 | \source{ 21 | \url{https://www.investopedia.com/terms/f/fang-stocks-fb-amzn.asp} 22 | } 23 | \usage{ 24 | FB 25 | } 26 | \description{ 27 | A dataset containing the date, open, high, low, close, volume, and adjusted 28 | stock prices for Facebook from 2013-2016. 29 | } 30 | \keyword{datasets} 31 | -------------------------------------------------------------------------------- /man/tibbletime.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/tibbletime-package.r 3 | \docType{package} 4 | \name{tibbletime} 5 | \alias{tibbletime-package} 6 | \alias{tibbletime} 7 | \title{tibbletime: time-aware tibbles} 8 | \description{ 9 | Built on top of the 'tibble' package, 'tibbletime' is an extension 10 | that allows for the creation of time aware tibbles. Some immediate 11 | advantages of this include: the ability to perform time based subsetting 12 | on tibbles, quickly summarising and aggregating results by time periods, 13 | and calling functions similar in spirit to the map family from 'purrr' 14 | on time based tibbles. 15 | } 16 | \seealso{ 17 | Useful links: 18 | \itemize{ 19 | \item \url{https://github.com/business-science/tibbletime} 20 | \item Report bugs at \url{https://github.com/business-science/tibbletime/issues} 21 | } 22 | 23 | } 24 | \author{ 25 | \strong{Maintainer}: Davis Vaughan \email{davis@posit.co} 26 | 27 | Authors: 28 | \itemize{ 29 | \item Matt Dancho \email{mdancho@business-science.io} 30 | } 31 | 32 | } 33 | -------------------------------------------------------------------------------- /R/helpers.R: -------------------------------------------------------------------------------- 1 | #' @export 2 | #' @rdname tbl_time 3 | tbl_time <- function(x, index = NULL) { 4 | 5 | # Capture index 6 | index_quo <- rlang::enquo(index) 7 | 8 | # Enforce index use 9 | assert_index_use(index_quo) 10 | 11 | # Index as character 12 | index_char <- rlang::quo_name(index_quo) 13 | 14 | # Get index column 15 | index_col <- x[[index_char]] 16 | 17 | # Get time zone 18 | index_time_zone <- get_index_col_time_zone(index_col) 19 | 20 | # Check grouped 21 | subclass <- NULL 22 | if(inherits(x, "grouped_df")) { 23 | subclass <- "grouped_tbl_time" 24 | } 25 | 26 | # Create and validate 27 | validate_tbl_time( 28 | new_tbl_time( 29 | x, 30 | index_quo = index_quo, 31 | index_time_zone = index_time_zone, 32 | subclass = subclass 33 | ) 34 | ) 35 | } 36 | 37 | # Util ------------------------------------------------------------------------- 38 | 39 | assert_index_use <- function(x) { 40 | assertthat::assert_that( 41 | !rlang::quo_is_null(x), 42 | msg = "Please include a bare column name for the `index`" 43 | ) 44 | } 45 | -------------------------------------------------------------------------------- /man/FANG.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/data.R 3 | \docType{data} 4 | \name{FANG} 5 | \alias{FANG} 6 | \title{Stock prices for Facebook, Amazon, Netflix and Google from 2013-2016} 7 | \format{ 8 | A tibble with 4,032 rows and 8 variables: 9 | \describe{ 10 | \item{symbol}{stock ticker symbol} 11 | \item{date}{trade date} 12 | \item{open}{stock price at the open of trading, in USD} 13 | \item{high}{stock price at the highest point during trading, in USD} 14 | \item{low}{stock price at the lowest point during trading, in USD} 15 | \item{close}{stock price at the close of trading, in USD} 16 | \item{volume}{number of shares traded} 17 | \item{adjusted}{stock price at the close of trading adjusted for stock splits, in USD} 18 | } 19 | } 20 | \source{ 21 | \url{https://www.investopedia.com/terms/f/fang-stocks-fb-amzn.asp} 22 | } 23 | \usage{ 24 | FANG 25 | } 26 | \description{ 27 | A dataset containing the date, open, high, low, close, volume, and adjusted 28 | stock prices for Facebook, Amazon, Netflix and Google from 2013-2016. 29 | } 30 | \keyword{datasets} 31 | -------------------------------------------------------------------------------- /man/parse_period.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/parse_period.R 3 | \name{parse_period} 4 | \alias{parse_period} 5 | \title{Parse a character period specification} 6 | \usage{ 7 | parse_period(period) 8 | } 9 | \arguments{ 10 | \item{period}{A character specification used for time-based grouping. The 11 | general format to use is \code{"frequency period"} where frequency is a number 12 | like 1 or 2, and period is an interval like weekly or yearly. There must be 13 | a space between the two. 14 | 15 | Note that you can pass the specification in a flexible way: 16 | \itemize{ 17 | \item 1 Year: \code{'1 year'} / \code{'1 Y'} 18 | } 19 | 20 | This shorthand is available for year, quarter, month, day, hour, minute, 21 | second, millisecond and microsecond periodicities. 22 | 23 | Additionally, you have the option of passing in a vector of dates to 24 | use as custom and more flexible boundaries.} 25 | } 26 | \description{ 27 | The period is parsed into frequency and period and returned as a named list. 28 | } 29 | \examples{ 30 | 31 | parse_period('2 day') 32 | 33 | } 34 | -------------------------------------------------------------------------------- /R/util.R: -------------------------------------------------------------------------------- 1 | # Reexports -------------------------------------------------------------------- 2 | 3 | #' @importFrom dplyr %>% 4 | #' @export 5 | #' 6 | dplyr::`%>%` 7 | 8 | #' @importFrom rlang := 9 | #' 10 | NULL 11 | 12 | #' @importFrom rlang .data 13 | #' 14 | NULL 15 | 16 | #' @importFrom rlang %||% 17 | #' 18 | NULL 19 | 20 | #' @useDynLib tibbletime, .registration = TRUE 21 | #' @importFrom Rcpp sourceCpp 22 | NULL 23 | 24 | # Global util ------------------------------------------------------------------ 25 | 26 | # A glue version of stop() 27 | glue_stop <- function(..., .sep = "") { 28 | stop(glue::glue(..., .sep, .envir = parent.frame()), call. = FALSE) 29 | } 30 | 31 | # Cheaply get the length of a string 32 | string_length <- function(x) { 33 | split <- unlist(strsplit(x, "")) 34 | length(split) 35 | } 36 | 37 | index_attributes <- function() { 38 | c("index_quo", "index_time_zone") 39 | } 40 | 41 | make_dummy_dispatch_obj <- function(x) { 42 | structure(list(), class = x) 43 | } 44 | 45 | remove_time_group <- function(x) { 46 | if(".time_group" %in% colnames(x)) { 47 | x[[".time_group"]] <- NULL 48 | } 49 | x 50 | } 51 | -------------------------------------------------------------------------------- /R/time_join.R: -------------------------------------------------------------------------------- 1 | # # both must be tbl_time 2 | # 3 | # time_left_join <- function(x, y, by = NULL, period = "year", copy = FALSE, suffix = c(".x", ".y"), ...) { 4 | # 5 | # if(get_index_char(x) %in% by || get_index_char(y) %in% by) { 6 | # stop("Do not specify the time index in `by`. Use `period` instead.") 7 | # } 8 | # 9 | # x <- mutate(x, .time_group = partition_index(!! get_index_quo(x), period = period)) 10 | # y <- mutate(y, .time_group = partition_index(!! get_index_quo(y), period = period)) 11 | # 12 | # y <- y %>% select(- !! get_index_quo(y)) 13 | # 14 | # left_join(x, y, by = c(by, ".time_group"), copy = copy, suffix = suffix, ...) %>% 15 | # select(-.time_group) 16 | # } 17 | # 18 | # time_right_join <- function(x, y, by = NULL, period = "year", copy = FALSE, suffix = c(".x", ".y"), ...) { 19 | # 20 | # x <- mutate(x, .time_group = partition_index(!! get_index_quo(x), period = period)) 21 | # y <- mutate(y, .time_group = partition_index(!! get_index_quo(y), period = period)) 22 | # 23 | # x <- x %>% select(- !! get_index_quo(x)) 24 | # 25 | # right_join(x, y, by = c(by, ".time_group")) %>% 26 | # select(-.time_group) 27 | # } 28 | -------------------------------------------------------------------------------- /tests/testthat/test_getters.R: -------------------------------------------------------------------------------- 1 | context("getters testing") 2 | 3 | # Test objects 4 | 5 | test_time <- tibble::tibble( 6 | date = c(as.Date("2017-12-01"), as.Date("2017-12-02"), as.Date("2017-12-03")), 7 | value = c(1, 2, 3), 8 | group1 = c("a", "a", "b"), 9 | group2 = c("d", "e", "e") 10 | ) 11 | 12 | test_tbl_time <- as_tbl_time(test_time, date) 13 | 14 | # Tests 15 | 16 | test_that("Index getters are working", { 17 | expect_equal(get_index_quo(test_tbl_time), rlang::quo(date)) 18 | expect_equal(get_index_char(test_tbl_time), "date") 19 | expect_equal(get_index_col(test_tbl_time), test_tbl_time$date) 20 | expect_equal(get_.index_col(test_tbl_time), to_posixct_numeric(test_tbl_time$date)) 21 | expect_equal(get_index_time_zone(test_tbl_time), "UTC") 22 | expect_equal(get_index_class(test_tbl_time), "Date") 23 | expect_equal(get_index_dispatcher(test_tbl_time), structure(list(), class = "Date")) 24 | }) 25 | 26 | test_that("Creation getters are working", { 27 | expect_equal(get_default_time_zone(), "UTC") 28 | expect_equal(get_index_col_time_zone(test_tbl_time), "UTC") 29 | expect_equal(get_index_col_class(test_tbl_time$date), "Date") 30 | }) 31 | -------------------------------------------------------------------------------- /tests/testthat/test_floor_index.R: -------------------------------------------------------------------------------- 1 | context("floor_index testing") 2 | 3 | # Test objects 4 | 5 | data(FB) 6 | test_time <- FB 7 | test_tbl_time <- as_tbl_time(test_time, date) 8 | 9 | test_tbl_time <- test_tbl_time %>% 10 | dplyr::mutate( 11 | date_posix = to_posixct_numeric(date) %>% posixct_numeric_to_datetime(class = "POSIXct", tz = "UTC"), 12 | date_yearmon = to_posixct_numeric(date) %>% posixct_numeric_to_datetime(class = "yearmon", tz = "UTC"), 13 | date_yearqtr = to_posixct_numeric(date) %>% posixct_numeric_to_datetime(class = "yearqtr", tz = "UTC") 14 | ) %>% 15 | dplyr::select(dplyr::contains("date")) 16 | 17 | # Tests 18 | 19 | test_that("Floor all Date/Datetime to yearly results in the same answer", { 20 | test <- purrr::map_dfc(test_tbl_time, ~floor_index(.x, "year") %>% to_posixct_numeric) 21 | expect_equal(test$date, test$date_posix) 22 | expect_equal(test$date, test$date_yearmon) 23 | expect_equal(test$date, test$date_yearqtr) 24 | }) 25 | 26 | test_that("Floor works with hms", { 27 | hms_test <- create_series('01'~'12', period = "hour", class = "hms") 28 | expect_equal( 29 | floor_index(hms_test$date, "12 hour"), 30 | c(rep(0, 11), 43200) %>% hms::as_hms() 31 | ) 32 | }) 33 | -------------------------------------------------------------------------------- /tests/testthat/test_ceiling_index.R: -------------------------------------------------------------------------------- 1 | context("ceiling_index testing") 2 | 3 | # Test objects 4 | 5 | data(FB) 6 | test_time <- FB 7 | test_tbl_time <- as_tbl_time(test_time, date) 8 | 9 | test_tbl_time <- test_tbl_time %>% 10 | dplyr::mutate( 11 | date_posix = to_posixct_numeric(date) %>% posixct_numeric_to_datetime(class = "POSIXct", tz = "UTC"), 12 | date_yearmon = to_posixct_numeric(date) %>% posixct_numeric_to_datetime(class = "yearmon", tz = "UTC"), 13 | date_yearqtr = to_posixct_numeric(date) %>% posixct_numeric_to_datetime(class = "yearqtr", tz = "UTC") 14 | ) %>% 15 | dplyr::select(dplyr::contains("date")) 16 | 17 | # Tests 18 | 19 | test_that("Ceiling all Date/Datetime to yearly results in the same answer", { 20 | test <- purrr::map_dfc(test_tbl_time, ~ceiling_index(.x, "year") %>% to_posixct_numeric) 21 | expect_equal(test$date, test$date_posix) 22 | expect_equal(test$date, test$date_yearmon) 23 | expect_equal(test$date, test$date_yearqtr) 24 | }) 25 | 26 | test_that("Ceiling works with hms", { 27 | hms_test <- create_series('01'~'12', period = "hour", class = "hms") 28 | expect_equal( 29 | ceiling_index(hms_test$date, "12 hour"), 30 | rep(43200, 12) %>% hms::as_hms() 31 | ) 32 | }) 33 | -------------------------------------------------------------------------------- /R/new.R: -------------------------------------------------------------------------------- 1 | # New tbl_time creation -------------------------------------------------------- 2 | # Currently for internal use, may later be exported when we have more 3 | # packages 4 | 5 | 6 | #' Create a new tbl_time object 7 | #' 8 | #' Often used internally by developers extending tibbletime 9 | #' 10 | #' @param x A tibble or data.frame 11 | #' @param index_quo The quo that references the index column 12 | #' @param index_time_zone The index time zone 13 | #' @param ... Other attributes passed through to new_tibble() 14 | #' @param subclass A subclass to have as a child 15 | #' 16 | #' @export 17 | #' 18 | new_tbl_time <- function(x, index_quo, index_time_zone, ..., subclass = NULL) { 19 | 20 | stopifnot(is.data.frame(x)) 21 | stopifnot(rlang::is_quosure(index_quo)) 22 | stopifnot(is.character(index_time_zone)) 23 | 24 | # Subclass checks, takes care of grouped_tbl_time creation 25 | subclass <- c(subclass, "tbl_time") 26 | if("grouped_tbl_time" %in% subclass) { 27 | subclass <- c(subclass, "grouped_df") 28 | } 29 | 30 | tibble::new_tibble( 31 | x, 32 | index_quo = index_quo, 33 | index_time_zone = index_time_zone, 34 | ..., 35 | nrow = nrow(x), 36 | class = subclass 37 | ) 38 | 39 | } 40 | 41 | -------------------------------------------------------------------------------- /R/reconstruct.R: -------------------------------------------------------------------------------- 1 | # Implement generic reconstruct() until sloop is on CRAN 2 | 3 | #' Reconstruct an S3 class from a template 4 | #' 5 | #' This is an implementation of `sloop::reconstruct()` that users can 6 | #' ignore. Once `sloop` is on CRAN, this function will be removed and that 7 | #' version will be used. It currently must be exported for use in `tidyquant`. 8 | #' 9 | #' @param new Freshly created object 10 | #' @param old Existing object to use as template 11 | #' 12 | #' @export 13 | reconstruct <- function (new, old) { 14 | UseMethod("reconstruct", old) 15 | } 16 | 17 | #' @export 18 | reconstruct.tbl_time <- function(new, old) { 19 | 20 | # Check subclass, if it was/is a grouped_df, 21 | # it should also be grouped_tbl_time 22 | class <- NULL 23 | if(inherits(new, "grouped_df")) { 24 | class <- "grouped_tbl_time" 25 | } 26 | 27 | # If we have an index 28 | if(index_still_exists(new, old)) { 29 | new_tbl_time( 30 | new, 31 | index_quo = get_index_quo(old), 32 | index_time_zone = get_index_time_zone(old), 33 | subclass = class 34 | ) 35 | } 36 | 37 | else { 38 | tibble::new_tibble(new, nrow = nrow(new), class = class) 39 | } 40 | 41 | } 42 | 43 | index_still_exists <- function(new, old) { 44 | get_index_char(old) %in% colnames(new) 45 | } 46 | -------------------------------------------------------------------------------- /tests/testthat/test_parse_period.R: -------------------------------------------------------------------------------- 1 | context("parse_period testing") 2 | 3 | # Tests 4 | 5 | test_that("Basic parsing", { 6 | expect_equal(parse_period('d'), list(freq = 1, period = "day")) 7 | expect_equal(parse_period('2 day'), list(freq = 2, period = "day")) 8 | expect_equal(parse_period('3 m'), list(freq = 3, period = "month")) 9 | }) 10 | 11 | test_that("Minute vs Month parsing works", { 12 | expect_equal(parse_period("M"), list(freq = 1, period = "min")) 13 | expect_equal(parse_period("m"), list(freq = 1, period = "month")) 14 | }) 15 | 16 | test_that("Errors are thrown with incorrect specification", { 17 | expect_error(parse_period("t"), "Period 't' specified incorrectly.") 18 | expect_error(parse_period('hi q'), "Frequency must be coercible to numeric.") 19 | expect_error(parse_period('2 test'), "Period 'test' specified incorrectly.") 20 | }) 21 | 22 | test_that("Specialized subsecond parsing", { 23 | expect_lte(abs(parse_period('.1 sec')$freq - .1), 1e-9) 24 | expect_equal(parse_period('.1 sec')$period, "sec") 25 | 26 | expect_lte(abs(parse_period('1 millisec')$freq - .001), 1e-9) 27 | expect_equal(parse_period('1 millisec')$period, "sec") 28 | 29 | expect_lte(abs(parse_period('1 microsec')$freq - .000001), 1e-9) 30 | expect_equal(parse_period('1 microsec')$period, "sec") 31 | }) 32 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | # tibbletime 5 | 6 | 7 | 8 | [![Lifecycle 9 | Status](https://img.shields.io/badge/lifecycle-retired-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html) 10 | [![CRAN_Status_Badge](http://www.r-pkg.org/badges/version/tibbletime)](https://cran.r-project.org/package=tibbletime) 11 | [![Codecov test 12 | coverage](https://codecov.io/gh/business-science/tibbletime/branch/master/graph/badge.svg)](https://app.codecov.io/gh/business-science/tibbletime?branch=master) 13 | [![R-CMD-check](https://github.com/business-science/tibbletime/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/business-science/tibbletime/actions/workflows/R-CMD-check.yaml) 14 | 15 | 16 | ## Package status 17 | 18 | `tibbletime` has been officially retired. We will continue to maintain 19 | but not be adding new functionality. Options to get new functionality: 20 | 21 | - [**timetk**](https://business-science.github.io/timetk/index.html) - 22 | Provides time series visualization, wrangling, and preprocessing using 23 | `tibble` structure 24 | - [**tsibble**](https://github.com/tidyverts/tsibble) - Provides 25 | wrangling using `tsibble` structure 26 | -------------------------------------------------------------------------------- /tests/testthat/test_coercion.R: -------------------------------------------------------------------------------- 1 | context("coercion testing") 2 | 3 | # Test objects 4 | 5 | test_df <- data.frame( 6 | date = c(as.Date("2017-12-01"), as.Date("2017-12-02"), as.Date("2017-12-03")), 7 | value = c(1, 2, 3), 8 | group1 = c("a", "a", "b"), 9 | group2 = c("d", "e", "e") 10 | ) 11 | 12 | test_time <- tibble::as_tibble(test_df) 13 | 14 | # Tests 15 | 16 | test_that("Can coerce tbl_df to tbl_time", { 17 | # Manually make tbl_time 18 | test_time2 <- test_time 19 | attr(test_time2, "index_quo") <- rlang::quo(date) 20 | attr(test_time2, "index_time_zone") <- "UTC" 21 | class(test_time2) <- c("tbl_time", class(test_time2)) 22 | 23 | expect_equal(as_tbl_time(test_time, date), test_time2) 24 | }) 25 | 26 | test_that("Can coerce data.frame to tbl_time using default method", { 27 | expect_equal(as_tbl_time(test_df, date), as_tbl_time(test_time, date)) 28 | }) 29 | 30 | test_that("Can coerce grouped_df to tbl_time", { 31 | # tbl_time first then group 32 | test_time_g <- as_tbl_time(test_time, date) %>% 33 | group_by(group1) 34 | 35 | # group then tbl_time 36 | expect_equal(test_time %>% group_by(group1) %>% as_tbl_time(date), test_time_g) 37 | }) 38 | 39 | test_that("Can coerce tbl_time back to tbl_df", { 40 | test_time2 <- as_tbl_time(test_time, date) 41 | expect_equal(tibble::as_tibble(test_time2), test_time) 42 | }) 43 | -------------------------------------------------------------------------------- /.github/workflows/pkgdown.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | release: 9 | types: [published] 10 | workflow_dispatch: 11 | 12 | name: pkgdown 13 | 14 | jobs: 15 | pkgdown: 16 | runs-on: ubuntu-latest 17 | # Only restrict concurrency for non-PR jobs 18 | concurrency: 19 | group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} 20 | env: 21 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 22 | steps: 23 | - uses: actions/checkout@v3 24 | 25 | - uses: r-lib/actions/setup-pandoc@v2 26 | 27 | - uses: r-lib/actions/setup-r@v2 28 | with: 29 | use-public-rspm: true 30 | 31 | - uses: r-lib/actions/setup-r-dependencies@v2 32 | with: 33 | extra-packages: any::pkgdown, local::. 34 | needs: website 35 | 36 | - name: Build site 37 | run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE) 38 | shell: Rscript {0} 39 | 40 | - name: Deploy to GitHub pages 🚀 41 | if: github.event_name != 'pull_request' 42 | uses: JamesIves/github-pages-deploy-action@v4.4.1 43 | with: 44 | clean: false 45 | branch: gh-pages 46 | folder: docs 47 | -------------------------------------------------------------------------------- /README.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | output: github_document 3 | --- 4 | 5 | 6 | 7 | ```{r, echo = FALSE, message = FALSE} 8 | knitr::opts_chunk$set( 9 | collapse = TRUE, 10 | comment = "#>" 11 | ) 12 | devtools::load_all() 13 | ``` 14 | 15 | # tibbletime 16 | 17 | 18 | [![Lifecycle Status](https://img.shields.io/badge/lifecycle-retired-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html) 19 | [![CRAN_Status_Badge](http://www.r-pkg.org/badges/version/tibbletime)](https://cran.r-project.org/package=tibbletime) 20 | [![Codecov test coverage](https://codecov.io/gh/business-science/tibbletime/branch/master/graph/badge.svg)](https://app.codecov.io/gh/business-science/tibbletime?branch=master) 21 | [![R-CMD-check](https://github.com/business-science/tibbletime/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/business-science/tibbletime/actions/workflows/R-CMD-check.yaml) 22 | 23 | 24 | ## Package status 25 | 26 | `tibbletime` has been officially retired. We will continue to maintain but not be adding new functionality. Options to get new functionality: 27 | 28 | - [__timetk__](https://business-science.github.io/timetk/index.html) - Provides time series visualization, wrangling, and preprocessing using `tibble` structure 29 | - [__tsibble__](https://github.com/tidyverts/tsibble) - Provides wrangling using `tsibble` structure 30 | -------------------------------------------------------------------------------- /src/sorted_range_search.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include "is_ordered.h" 3 | using namespace Rcpp; 4 | 5 | // [[Rcpp::export]] 6 | LogicalVector sorted_range_search(NumericVector x, double lower, double upper) { 7 | 8 | if ( lower > upper ) { 9 | throw std::range_error( "upper value must be greater than lower value" ) ; 10 | } 11 | 12 | if(!is_ordered_numeric(x)) { 13 | Rf_warning("Note: Index not ordered. tibbletime assumes index is in ascending order. Results may not be as desired."); 14 | } 15 | 16 | NumericVector::iterator iter_lower; 17 | NumericVector::iterator iter_upper; 18 | IntegerVector loc = IntegerVector::create(0, 0); 19 | 20 | NumericVector::iterator x_begin = x.begin(); 21 | NumericVector::iterator x_end = x.end(); 22 | 23 | iter_lower = std::lower_bound(x_begin, x_end, lower); 24 | loc[0] = std::distance(x_begin, iter_lower); 25 | 26 | iter_upper = std::upper_bound(x_begin, x_end, upper); 27 | loc[1] = std::distance(x_begin, iter_upper); // + 1 - 1, +1 for C++ to R, -1 for upper_bound going too far 28 | 29 | LogicalVector filter_criteria(int(x.size()), false); 30 | 31 | // Two cases to return NULL 32 | // 1) When the upper pos is below the minimum of the series and lower is below that 33 | // 2) When the lower pos is above the max of the series and upper is above that 34 | if( (loc[1] == 0) || (loc[0] > x.size() - 1) ) { 35 | return filter_criteria; 36 | } 37 | 38 | for(int i = loc[0]; i < loc[1]; i++) { 39 | filter_criteria[i] = true; 40 | } 41 | 42 | return filter_criteria; 43 | } 44 | -------------------------------------------------------------------------------- /.github/workflows/test-coverage.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | 9 | name: test-coverage 10 | 11 | jobs: 12 | test-coverage: 13 | runs-on: ubuntu-latest 14 | env: 15 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 16 | 17 | steps: 18 | - uses: actions/checkout@v3 19 | 20 | - uses: r-lib/actions/setup-r@v2 21 | with: 22 | use-public-rspm: true 23 | 24 | - uses: r-lib/actions/setup-r-dependencies@v2 25 | with: 26 | extra-packages: any::covr 27 | needs: coverage 28 | 29 | - name: Test coverage 30 | run: | 31 | covr::codecov( 32 | quiet = FALSE, 33 | clean = FALSE, 34 | install_path = file.path(Sys.getenv("RUNNER_TEMP"), "package") 35 | ) 36 | shell: Rscript {0} 37 | 38 | - name: Show testthat output 39 | if: always() 40 | run: | 41 | ## -------------------------------------------------------------------- 42 | find ${{ runner.temp }}/package -name 'testthat.Rout*' -exec cat '{}' \; || true 43 | shell: bash 44 | 45 | - name: Upload test results 46 | if: failure() 47 | uses: actions/upload-artifact@v3 48 | with: 49 | name: coverage-test-failures 50 | path: ${{ runner.temp }}/package 51 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: tibbletime 2 | Type: Package 3 | Title: Time Aware Tibbles 4 | Version: 0.1.9.9000 5 | Authors@R: c( 6 | person("Davis", "Vaughan", email = "davis@posit.co", role = c("aut", "cre")), 7 | person("Matt", "Dancho", email = "mdancho@business-science.io", role = c("aut")) 8 | ) 9 | Maintainer: Davis Vaughan 10 | Description: Built on top of the 'tibble' package, 'tibbletime' is an extension 11 | that allows for the creation of time aware tibbles. Some immediate 12 | advantages of this include: the ability to perform time-based subsetting 13 | on tibbles, quickly summarising and aggregating results by time periods, 14 | and creating columns that can be used as 'dplyr' time-based groups. 15 | URL: https://github.com/business-science/tibbletime 16 | BugReports: https://github.com/business-science/tibbletime/issues 17 | License: MIT + file LICENSE 18 | Encoding: UTF-8 19 | RoxygenNote: 7.3.2 20 | Roxygen: list(markdown = TRUE) 21 | Depends: 22 | R (>= 3.4.0) 23 | Imports: 24 | assertthat (>= 0.2.1), 25 | dplyr (>= 1.0.10), 26 | glue (>= 1.6.2), 27 | hms (>= 1.1.2), 28 | lubridate (>= 1.9.1), 29 | pillar (>= 1.8.1), 30 | purrr (>= 0.3.5), 31 | Rcpp (>= 1.0.9), 32 | rlang (>= 1.0.6), 33 | tibble (>= 3.1.8), 34 | vctrs (>= 0.5.0), 35 | zoo (>= 1.8-11), 36 | lifecycle (>= 1.0.3) 37 | Suggests: 38 | broom, 39 | covr, 40 | gapminder, 41 | knitr, 42 | rmarkdown, 43 | testthat, 44 | tidyr (>= 1.0.0) 45 | VignetteBuilder: knitr 46 | LinkingTo: Rcpp (>= 1.0.10) 47 | LazyData: true 48 | -------------------------------------------------------------------------------- /R/aaa.R: -------------------------------------------------------------------------------- 1 | # ------------------------------------------------------------------------------ 2 | # Registration function 3 | # Copied from googledrive r package, dplyr-compat.R 4 | 5 | ## function is called in .onLoad() 6 | 7 | # nocov start 8 | 9 | register_s3_method <- function(pkg, generic, class, fun = NULL) { 10 | stopifnot(is.character(pkg)) 11 | envir <- asNamespace(pkg) 12 | 13 | stopifnot(is.character(generic)) 14 | stopifnot(is.character(class)) 15 | if (is.null(fun)) { 16 | fun <- get(paste0(generic, ".", class), envir = parent.frame()) 17 | } 18 | stopifnot(is.function(fun)) 19 | 20 | if (pkg %in% loadedNamespaces()) { 21 | registerS3method(generic, class, fun, envir = envir) 22 | } 23 | 24 | # Always register hook in case package is later unloaded & reloaded 25 | setHook( 26 | packageEvent(pkg, "onLoad"), 27 | function(...) { 28 | registerS3method(generic, class, fun, envir = envir) 29 | } 30 | ) 31 | } 32 | 33 | tidyr_at_least_1.0.0 <- NULL 34 | 35 | .onLoad <- function(libname, pkgname) { 36 | 37 | # If tidyr is available, library() it and register these methods implemented 38 | # in tibbletime. 39 | # This is done because tidyr is not imported because it is not used 40 | # anywhere else in the package. 41 | if (requireNamespace("tidyr", quietly = TRUE)) { 42 | register_s3_method("tidyr", "gather", "tbl_time") 43 | register_s3_method("tidyr", "spread", "tbl_time") 44 | register_s3_method("tidyr", "nest", "tbl_time") 45 | register_s3_method("tidyr", "unnest", "tbl_time") 46 | register_s3_method("tidyr", "unnest", "tbl_df") 47 | tidyr_at_least_1.0.0 <<- utils::packageVersion("tidyr") >= "1.0.0" 48 | } 49 | 50 | invisible() 51 | } 52 | 53 | # nocov end 54 | -------------------------------------------------------------------------------- /R/data.R: -------------------------------------------------------------------------------- 1 | #' Stock prices for Facebook, Amazon, Netflix and Google from 2013-2016 2 | #' 3 | #' A dataset containing the date, open, high, low, close, volume, and adjusted 4 | #' stock prices for Facebook, Amazon, Netflix and Google from 2013-2016. 5 | #' 6 | #' @format A tibble with 4,032 rows and 8 variables: 7 | #' \describe{ 8 | #' \item{symbol}{stock ticker symbol} 9 | #' \item{date}{trade date} 10 | #' \item{open}{stock price at the open of trading, in USD} 11 | #' \item{high}{stock price at the highest point during trading, in USD} 12 | #' \item{low}{stock price at the lowest point during trading, in USD} 13 | #' \item{close}{stock price at the close of trading, in USD} 14 | #' \item{volume}{number of shares traded} 15 | #' \item{adjusted}{stock price at the close of trading adjusted for stock splits, in USD} 16 | #' } 17 | #' @source \url{https://www.investopedia.com/terms/f/fang-stocks-fb-amzn.asp} 18 | "FANG" 19 | 20 | #' Stock prices for Facebook from 2013-2016 21 | #' 22 | #' A dataset containing the date, open, high, low, close, volume, and adjusted 23 | #' stock prices for Facebook from 2013-2016. 24 | #' 25 | #' @format A tibble with 1,008 rows and 8 variables: 26 | #' \describe{ 27 | #' \item{symbol}{stock ticker symbol} 28 | #' \item{date}{trade date} 29 | #' \item{open}{stock price at the open of trading, in USD} 30 | #' \item{high}{stock price at the highest point during trading, in USD} 31 | #' \item{low}{stock price at the lowest point during trading, in USD} 32 | #' \item{close}{stock price at the close of trading, in USD} 33 | #' \item{volume}{number of shares traded} 34 | #' \item{adjusted}{stock price at the close of trading adjusted for stock splits, in USD} 35 | #' } 36 | #' @source \url{https://www.investopedia.com/terms/f/fang-stocks-fb-amzn.asp} 37 | "FB" 38 | -------------------------------------------------------------------------------- /src/RcppExports.cpp: -------------------------------------------------------------------------------- 1 | // Generated by using Rcpp::compileAttributes() -> do not edit by hand 2 | // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | #include 5 | 6 | using namespace Rcpp; 7 | 8 | #ifdef RCPP_USE_GLOBAL_ROSTREAM 9 | Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); 10 | Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); 11 | #endif 12 | 13 | // is_ordered_numeric 14 | bool is_ordered_numeric(NumericVector x); 15 | RcppExport SEXP _tibbletime_is_ordered_numeric(SEXP xSEXP) { 16 | BEGIN_RCPP 17 | Rcpp::RObject rcpp_result_gen; 18 | Rcpp::RNGScope rcpp_rngScope_gen; 19 | Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP); 20 | rcpp_result_gen = Rcpp::wrap(is_ordered_numeric(x)); 21 | return rcpp_result_gen; 22 | END_RCPP 23 | } 24 | // sorted_range_search 25 | LogicalVector sorted_range_search(NumericVector x, double lower, double upper); 26 | RcppExport SEXP _tibbletime_sorted_range_search(SEXP xSEXP, SEXP lowerSEXP, SEXP upperSEXP) { 27 | BEGIN_RCPP 28 | Rcpp::RObject rcpp_result_gen; 29 | Rcpp::RNGScope rcpp_rngScope_gen; 30 | Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP); 31 | Rcpp::traits::input_parameter< double >::type lower(lowerSEXP); 32 | Rcpp::traits::input_parameter< double >::type upper(upperSEXP); 33 | rcpp_result_gen = Rcpp::wrap(sorted_range_search(x, lower, upper)); 34 | return rcpp_result_gen; 35 | END_RCPP 36 | } 37 | 38 | static const R_CallMethodDef CallEntries[] = { 39 | {"_tibbletime_is_ordered_numeric", (DL_FUNC) &_tibbletime_is_ordered_numeric, 1}, 40 | {"_tibbletime_sorted_range_search", (DL_FUNC) &_tibbletime_sorted_range_search, 3}, 41 | {NULL, NULL, 0} 42 | }; 43 | 44 | RcppExport void R_init_tibbletime(DllInfo *dll) { 45 | R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); 46 | R_useDynamicSymbols(dll, FALSE); 47 | } 48 | -------------------------------------------------------------------------------- /tests/testthat/test_parse_time_formula.R: -------------------------------------------------------------------------------- 1 | context("parse_time_formula testing") 2 | 3 | obj_Date <- make_dummy_dispatch_obj("Date") 4 | obj_POSIXct <- make_dummy_dispatch_obj("POSIXct") 5 | obj_yearmon <- make_dummy_dispatch_obj("yearmon") 6 | obj_yearqtr <- make_dummy_dispatch_obj("yearqtr") 7 | obj_hms <- make_dummy_dispatch_obj("hms") 8 | 9 | # Tests 10 | 11 | test_that("Basic parsing", { 12 | expect_equal(parse_time_formula(obj_Date, ~'2013'), 13 | list(list(y = 2013, m = 1, d = 1), 14 | list(y = 2013, m = 12, d = c(Dec = 31)))) 15 | 16 | expect_equal(parse_time_formula(obj_POSIXct, ~'2013'), 17 | list(list(y = 2013, m = 1, d = 1, h = 0, M = 0, s = 0), 18 | list(y = 2013, m = 12, d = c(Dec = 31), h = 23, M = 59, s = 59))) 19 | 20 | expect_equal(parse_time_formula(obj_yearmon, ~'2013'), 21 | list(list(y = 2013, m = 1), 22 | list(y = 2013, m = 12))) 23 | 24 | expect_equal(parse_time_formula(obj_yearqtr, ~'2013'), 25 | list(list(y = 2013, q = 1), 26 | list(y = 2013, q = 4))) 27 | 28 | expect_equal(parse_time_formula(obj_hms, ~'1'), 29 | list(list(h = 1, M = 0, s = 0), 30 | list(h = 1, M = 59, s = 59))) 31 | }) 32 | 33 | 34 | test_that("Errors are thrown with incorrect specification", { 35 | expect_error(parse_time_formula(obj_Date, ~'2013-01-01 - 1'), 36 | "For a Date index, time_formula can only include y, m, d specifications.") 37 | 38 | expect_error(parse_time_formula(obj_yearmon, ~'2013-01-01'), 39 | "For a yearmon index, time_formula can only include y, m specifications.") 40 | 41 | expect_error(parse_time_formula(obj_yearqtr, ~'2013-01-01'), 42 | "For a yearqtr index, time_formula can only include y, q specifications.") 43 | 44 | expect_error(parse_time_formula(obj_hms, ~'2013-01-01 / 1'), 45 | "For a hms index, time_formula can only include h, M, s specifications.") 46 | }) 47 | -------------------------------------------------------------------------------- /man/tbl_time.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/coercion.R, R/helpers.R 3 | \name{as_tbl_time} 4 | \alias{as_tbl_time} 5 | \alias{tbl_time} 6 | \title{Create \code{tbl_time} objects} 7 | \usage{ 8 | as_tbl_time(x, index = NULL, ...) 9 | 10 | tbl_time(x, index = NULL) 11 | } 12 | \arguments{ 13 | \item{x}{An object to be converted to \code{tbl_time}. This is generally 14 | a \code{\link[tibble:tibble]{tibble::tibble()}}, or an object that can first be coerced to a \code{tibble}.} 15 | 16 | \item{index}{The bare column name of the column to be used as the index.} 17 | 18 | \item{...}{Arguments passed to \code{\link[tibble:as_tibble]{tibble::as_tibble()}} if coercion is 19 | necessary first.} 20 | } 21 | \description{ 22 | \code{tbl_time} objects have a time index that contains information about 23 | which column should be used for time-based subsetting and other time-based 24 | manipulation. Otherwise, they function as normal tibbles. 25 | } 26 | \details{ 27 | The information stored about \code{tbl_time} objects are the \code{index_quo} and the 28 | \code{index_time_zone}. These are stored as attributes, with the \code{index_quo} as a 29 | \code{\link[rlang:quosure-tools]{rlang::quosure()}} and the \code{time_zone} as a string. 30 | 31 | Currently, \code{Date} and \code{POSIXct} classes are fully supported. \code{yearmon}, 32 | \code{yearqtr}, and \code{hms} have experimental support. Due to dplyr's 33 | handling of S3 classes like these 3, the classes are lost when you 34 | manipulate the index columns directly. 35 | } 36 | \examples{ 37 | 38 | # Converting a data.frame to a `tbl_time` 39 | # Using Date index 40 | ex1 <- data.frame(date = Sys.Date(), value = 1) 41 | ex1_tbl_time <- as_tbl_time(ex1, date) 42 | class(ex1_tbl_time) 43 | attributes(ex1_tbl_time) 44 | 45 | # Converting a tibble to a `tbl_time` 46 | # Using POSIXct index 47 | ex2 <- tibble::tibble( 48 | time = as.POSIXct(c("2017-01-01 10:12:01", "2017-01-02 12:12:01")), 49 | value = c(1, 2) 50 | ) 51 | as_tbl_time(ex2, time) 52 | 53 | } 54 | -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | # 4 | # NOTE: This workflow is overkill for most R packages and 5 | # check-standard.yaml is likely a better choice. 6 | # usethis::use_github_action("check-standard") will install it. 7 | on: 8 | push: 9 | branches: [main, master] 10 | pull_request: 11 | branches: [main, master] 12 | 13 | name: R-CMD-check 14 | 15 | jobs: 16 | R-CMD-check: 17 | runs-on: ${{ matrix.config.os }} 18 | 19 | name: ${{ matrix.config.os }} (${{ matrix.config.r }}) 20 | 21 | strategy: 22 | fail-fast: false 23 | matrix: 24 | config: 25 | - {os: macos-latest, r: 'release'} 26 | 27 | - {os: windows-latest, r: 'release'} 28 | # Use 3.6 to trigger usage of RTools35 29 | - {os: windows-latest, r: '3.6'} 30 | # use 4.1 to check with rtools40's older compiler 31 | - {os: windows-latest, r: '4.1'} 32 | 33 | - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} 34 | - {os: ubuntu-latest, r: 'release'} 35 | - {os: ubuntu-latest, r: 'oldrel-1'} 36 | - {os: ubuntu-latest, r: 'oldrel-2'} 37 | - {os: ubuntu-latest, r: 'oldrel-3'} 38 | - {os: ubuntu-latest, r: 'oldrel-4'} 39 | 40 | env: 41 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 42 | R_KEEP_PKG_SOURCE: yes 43 | 44 | steps: 45 | - uses: actions/checkout@v3 46 | 47 | - uses: r-lib/actions/setup-pandoc@v2 48 | 49 | - uses: r-lib/actions/setup-r@v2 50 | with: 51 | r-version: ${{ matrix.config.r }} 52 | http-user-agent: ${{ matrix.config.http-user-agent }} 53 | use-public-rspm: true 54 | 55 | - uses: r-lib/actions/setup-r-dependencies@v2 56 | with: 57 | extra-packages: any::rcmdcheck 58 | needs: check 59 | 60 | - uses: r-lib/actions/check-r-package@v2 61 | with: 62 | upload-snapshots: true 63 | -------------------------------------------------------------------------------- /man/floor_index.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/round-index.R 3 | \name{floor_index} 4 | \alias{floor_index} 5 | \title{A simple wrapper of \code{\link[lubridate:round_date]{lubridate::floor_date()}}} 6 | \usage{ 7 | floor_index(x, unit = "seconds") 8 | } 9 | \arguments{ 10 | \item{x}{a vector of date-time objects} 11 | 12 | \item{unit}{a string, \code{Period} object or a date-time object. When a singleton string, 13 | it specifies a time unit or a multiple of a unit to be rounded to. Valid base units 14 | are \code{second}, \code{minute}, \code{hour}, \code{day}, \code{week}, \code{month}, \code{bimonth}, \code{quarter}, 15 | \code{season}, \code{halfyear} and \code{year}. Arbitrary unique English abbreviations as in the 16 | \code{\link[lubridate:period]{period()}} constructor are allowed. Rounding to multiples of units (except weeks) 17 | is supported. 18 | 19 | When \code{unit} is a \code{Period} object, it is first converted to a string representation 20 | which might not be in the same units as the constructor. For example \code{weeks(1)} is 21 | converted to "7d 0H 0M 0S". Thus, always check the string representation of the 22 | period before passing to this function. 23 | 24 | When \code{unit} is a date-time object rounding is done to the nearest of the 25 | elements in \code{unit}. If range of \code{unit} vector does not cover the range of 26 | \code{x} \code{ceiling_date()} and \code{floor_date()} round to the \code{max(x)} and \code{min(x)} 27 | for elements that fall outside of \code{range(unit)}.} 28 | } 29 | \description{ 30 | This is a thin wrapper around a \code{\link[lubridate:round_date]{lubridate::floor_date()}} that works 31 | for \code{hms}, \code{yearmon}, and \code{yearqtr} classes as well. 32 | } 33 | \examples{ 34 | 35 | data(FB) 36 | dplyr::mutate(FB, date2 = floor_index(date, "year")) 37 | 38 | time_test <- create_series('00:00:00'~'12:00:00', 39 | '1 minute', class = "hms") 40 | 41 | dplyr::mutate(time_test, date2 = floor_index(date, "hour")) 42 | 43 | } 44 | \seealso{ 45 | \code{\link[lubridate:round_date]{lubridate::floor_date()}} 46 | } 47 | -------------------------------------------------------------------------------- /man/ceiling_index.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/round-index.R 3 | \name{ceiling_index} 4 | \alias{ceiling_index} 5 | \title{A simple wrapper of \code{\link[lubridate:round_date]{lubridate::ceiling_date()}}} 6 | \usage{ 7 | ceiling_index(x, unit = "seconds") 8 | } 9 | \arguments{ 10 | \item{x}{a vector of date-time objects} 11 | 12 | \item{unit}{a string, \code{Period} object or a date-time object. When a singleton string, 13 | it specifies a time unit or a multiple of a unit to be rounded to. Valid base units 14 | are \code{second}, \code{minute}, \code{hour}, \code{day}, \code{week}, \code{month}, \code{bimonth}, \code{quarter}, 15 | \code{season}, \code{halfyear} and \code{year}. Arbitrary unique English abbreviations as in the 16 | \code{\link[lubridate:period]{period()}} constructor are allowed. Rounding to multiples of units (except weeks) 17 | is supported. 18 | 19 | When \code{unit} is a \code{Period} object, it is first converted to a string representation 20 | which might not be in the same units as the constructor. For example \code{weeks(1)} is 21 | converted to "7d 0H 0M 0S". Thus, always check the string representation of the 22 | period before passing to this function. 23 | 24 | When \code{unit} is a date-time object rounding is done to the nearest of the 25 | elements in \code{unit}. If range of \code{unit} vector does not cover the range of 26 | \code{x} \code{ceiling_date()} and \code{floor_date()} round to the \code{max(x)} and \code{min(x)} 27 | for elements that fall outside of \code{range(unit)}.} 28 | } 29 | \description{ 30 | This is a thin wrapper around a \code{\link[lubridate:round_date]{lubridate::ceiling_date()}} that works 31 | for \code{hms}, \code{yearmon}, and \code{yearqtr} classes as well. 32 | } 33 | \examples{ 34 | 35 | data(FB) 36 | dplyr::mutate(FB, date2 = ceiling_index(date, "year")) 37 | 38 | time_test <- create_series('00:00:00'~'12:00:00', 39 | '1 minute', class = "hms") 40 | 41 | dplyr::mutate(time_test, date2 = ceiling_index(date, "hour")) 42 | 43 | } 44 | \seealso{ 45 | \code{\link[lubridate:round_date]{lubridate::ceiling_date()}} 46 | } 47 | -------------------------------------------------------------------------------- /man/partition_index.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/partition_index.R 3 | \name{partition_index} 4 | \alias{partition_index} 5 | \title{Partition an index vector into an integer vector representing groups} 6 | \usage{ 7 | partition_index(index, period = "year", start_date = NULL, ...) 8 | } 9 | \arguments{ 10 | \item{index}{A vector of date indices to create groups for.} 11 | 12 | \item{period}{A character specification used for time-based grouping. The 13 | general format to use is \code{"frequency period"} where frequency is a number 14 | like 1 or 2, and period is an interval like weekly or yearly. There must be 15 | a space between the two. 16 | 17 | Note that you can pass the specification in a flexible way: 18 | \itemize{ 19 | \item 1 Year: \code{'1 year'} / \code{'1 Y'} 20 | } 21 | 22 | This shorthand is available for year, quarter, month, day, hour, minute, 23 | second, millisecond and microsecond periodicities. 24 | 25 | Additionally, you have the option of passing in a vector of dates to 26 | use as custom and more flexible boundaries.} 27 | 28 | \item{start_date}{Optional argument used to 29 | specify the start date for the 30 | first group. The default is to start at the closest period boundary 31 | below the minimum date in the supplied index.} 32 | 33 | \item{...}{Not currently used.} 34 | } 35 | \description{ 36 | \code{\link[=partition_index]{partition_index()}} takes an index vector and returns an integer vector that 37 | can be used for grouping by periods. This is the workhorse for many other 38 | \code{tibbletime} functions. 39 | } 40 | \details{ 41 | This function is used internally, but may provide the user extra flexibility 42 | in some cases. 43 | 44 | Grouping can only be done on the minimum periodicity of the index and above. 45 | This means that a daily series cannot be grouped by minute. An hourly series 46 | cannot be grouped by 5 seconds, and so on. If the user attempts this, 47 | an error will be thrown. 48 | } 49 | \examples{ 50 | 51 | data(FB) 52 | 53 | partition_index(FB$date, '2 year') 54 | 55 | dplyr::mutate(FB, partition_index = partition_index(date, '2 day')) 56 | 57 | } 58 | \seealso{ 59 | \code{\link[=as_period]{as_period()}}, \code{\link[=collapse_index]{collapse_index()}} 60 | } 61 | -------------------------------------------------------------------------------- /tests/testthat/test_create_series.R: -------------------------------------------------------------------------------- 1 | context("create_series testing") 2 | 3 | # Test objects 4 | 5 | 6 | # Tests 7 | 8 | test_that("Can create basic series", { 9 | 10 | series <- create_series(~'2013-01-01', '1 day') 11 | check <- as_tbl_time(tibble::tibble(date = as.POSIXct("2013-01-01", tz = "UTC")), date) 12 | 13 | expect_equal(series, check) 14 | expect_is(series, "tbl_time") 15 | }) 16 | 17 | test_that("Can create series of different classes", { 18 | expect_equal(create_series(~'2013-01-01', '1 day', "Date"), 19 | as_tbl_time(tibble::tibble(date = as.Date("2013-01-01")), date)) 20 | 21 | expect_equal(create_series(~'2013-01', '1 m', "yearmon"), 22 | as_tbl_time(tibble::tibble(date = zoo::as.yearmon("2013-01")), date)) 23 | 24 | expect_equal(create_series(~'2013-01', '1 q', "yearqtr"), 25 | as_tbl_time(tibble::tibble(date = zoo::as.yearqtr("2013-01")), date)) 26 | 27 | expect_equal(create_series(~'1', '1 h', "hms"), 28 | as_tbl_time(tibble::tibble(date = hms::hms(hours = 1)), date)) 29 | }) 30 | 31 | test_that("Error thrown when creating finer periodicity than allowed", { 32 | expect_error(create_series(~'2013-01-01', '1 h', "Date"), 33 | "Only year, quarter, month, week, and day periods are allowed for an index of class Date") 34 | 35 | expect_error(create_series(~'2013-01', '1 day', "yearmon"), 36 | "Only year, quarter, and month periods are allowed for an index of class yearmon") 37 | 38 | expect_error(create_series(~'2013-01', '1 day', "yearqtr"), 39 | "Only year and quarter periods are allowed for an index of class yearqtr") 40 | 41 | expect_error(create_series(~'1', '1 day', "hms"), 42 | "Only hour, minute and second periods are allowed for an index of class hms") 43 | }) 44 | 45 | test_that("Can create vector series", { 46 | series <- create_series(~'2013-01-01', '1 day', as_vector = TRUE) 47 | check <- as.POSIXct("2013-01-01", tz = "UTC") 48 | 49 | expect_equal(series, check) 50 | }) 51 | 52 | test_that("Can alter time zone", { 53 | series <- create_series(~'2013-01-01', '1 day', as_vector = TRUE, tz = "America/New_York") 54 | check <- as.POSIXct("2013-01-01", tz = "America/New_York") 55 | 56 | expect_equal(series, check) 57 | }) 58 | -------------------------------------------------------------------------------- /tests/testthat/test_rollify.R: -------------------------------------------------------------------------------- 1 | context("rollify testing") 2 | 3 | # Test objects 4 | 5 | test_time <- tibble::tibble( 6 | group = c("g1", "g1", "g2"), 7 | date = c(as.Date("2017-12-01"), as.Date("2017-12-02"), as.Date("2017-12-03")), 8 | value = c(1, 2, 3), 9 | value2 = c(2, 5, 6), 10 | value3 = c(1, 3, 7) 11 | ) 12 | 13 | test_tbl_time <- as_tbl_time(test_time, date) 14 | 15 | # Tests 16 | 17 | test_that("Basic roller() call works", { 18 | expect_equal(roller(x = c(1,2,3), .f = mean, window = 2), 19 | c(NA, 1.5, 2.5)) 20 | }) 21 | 22 | test_that("rollify() creates a function", { 23 | expect_is(rollify(mean), "function") 24 | }) 25 | 26 | test_that("rollify() with function call works", { 27 | test_roll <- rollify(mean, window = 2) 28 | expect_equal(dplyr::mutate(test_tbl_time, test = test_roll(value)), 29 | dplyr::mutate(test_tbl_time, test = c(NA, 1.5, 2.5))) 30 | }) 31 | 32 | test_that("rollify() with ~ specification works", { 33 | test_roll <- rollify(~mean(.x), window = 2) 34 | expect_equal(dplyr::mutate(test_tbl_time, test = test_roll(value)), 35 | dplyr::mutate(test_tbl_time, test = c(NA, 1.5, 2.5))) 36 | }) 37 | 38 | test_that("rollify() with two args works", { 39 | test_roll <- rollify(~cor(.x, .y), window = 3) 40 | expect_equal(dplyr::mutate(test_tbl_time, test = test_roll(value, value2)), 41 | dplyr::mutate(test_tbl_time, test = c(NA, NA, cor(value, value2)))) 42 | }) 43 | 44 | test_that("rollify() with explicit function works for >2 args", { 45 | test_roll <- rollify(function(x, y, z) {sum(x + y + z)}, window = 3) 46 | expect_equal(dplyr::mutate(test_tbl_time, test = test_roll(value, value2, value3)), 47 | dplyr::mutate(test_tbl_time, test = c(NA, NA, sum(value + value2 + value3)))) 48 | }) 49 | 50 | test_that("rollify() result works alone", { 51 | test_roll <- rollify(~mean(.x), window = 2) 52 | expect_equal(test_roll(c(1,3,4)), c(NA, 2.0, 3.5)) 53 | }) 54 | 55 | test_that("rollify() with unlist = FALSE works", { 56 | test_roll <- rollify(~c(mean(.x), sd(.x)), window = 2, unlist = FALSE) 57 | test_rolled <- dplyr::mutate(test_tbl_time, test = test_roll(value)) 58 | expect_is(test_rolled$test[[1]], "logical") 59 | expect_is(test_rolled$test[[2]], "numeric") 60 | expect_is(test_rolled$test[[3]], "numeric") 61 | expect_equal(length(test_rolled$test[[2]]), 2L) 62 | }) 63 | 64 | -------------------------------------------------------------------------------- /tests/testthat/test_as_period.R: -------------------------------------------------------------------------------- 1 | context("as_period testing") 2 | 3 | # Test objects 4 | 5 | data(FB) 6 | test_time <- FB 7 | test_tbl_time <- as_tbl_time(test_time, date) 8 | 9 | data(FANG) 10 | test_tbl_time_g <- as_tbl_time(FANG, date) %>% 11 | group_by(symbol) 12 | 13 | # Tests 14 | 15 | test_that("Converting to more granular throws error", { 16 | expect_error(as_period(test_tbl_time, "hour")) 17 | }) 18 | 19 | test_that("Can convert to monthly", { 20 | test_period <- as_period(test_tbl_time, "month") 21 | expect_equal(nrow(test_period), 48L) 22 | expect_equal(ncol(test_period), 8L) 23 | expect_equal(test_period$date[2], as.Date("2013-02-01")) 24 | }) 25 | 26 | test_that("Can convert to monthly - end", { 27 | test_period <- as_period(test_tbl_time, "month", side = "end") 28 | expect_equal(nrow(test_period), 48L) 29 | expect_equal(ncol(test_period), 8L) 30 | expect_equal(test_period$date[2], as.Date("2013-02-28")) 31 | }) 32 | 33 | test_that("Can convert to yearly", { 34 | test_period <- as_period(test_tbl_time, "year") 35 | expect_equal(nrow(test_period), 4L) 36 | expect_equal(ncol(test_period), 8L) 37 | expect_equal(test_period$date[2], as.Date("2014-01-02")) 38 | }) 39 | 40 | test_that("Can convert to yearly - end", { 41 | test_period <- as_period(test_tbl_time, "year", side = "end") 42 | expect_equal(nrow(test_period), 4L) 43 | expect_equal(ncol(test_period), 8L) 44 | expect_equal(test_period$date[2], as.Date("2014-12-31")) 45 | }) 46 | 47 | test_that("Include endpoints with side = 'start' includes last point", { 48 | start <- as_period(test_tbl_time, "year", include_endpoints = TRUE) 49 | 50 | expect_equal( 51 | object = start$date[length(start$date)], 52 | expected = as.Date("2016-12-30")) 53 | }) 54 | 55 | test_that("Include endpoints with side = 'start' includes last point", { 56 | end <- as_period(test_tbl_time, "year", 57 | side = "end", include_endpoints = TRUE) 58 | 59 | expect_equal( 60 | object = end$date[1], 61 | expected = as.Date("2013-01-02")) 62 | }) 63 | 64 | test_that("Error with non tbl_time object", { 65 | expect_error(as_period(test_time, "year"), 66 | "Object is not of class `tbl_time`.") 67 | }) 68 | 69 | test_that("Groups are respected", { 70 | test_period <- as_period(test_tbl_time_g, "year") 71 | expect_equal(nrow(test_period), 16L) 72 | expect_equal(ncol(test_period), 8L) 73 | }) 74 | -------------------------------------------------------------------------------- /R/getters.R: -------------------------------------------------------------------------------- 1 | # Getters for tbl_time objects ------------------------------------------------- 2 | 3 | #' Getters 4 | #' 5 | #' Accessors to attributes of `tbl_time` objects. 6 | #' 7 | #' @param .tbl_time A `tbl_time` object. 8 | #' 9 | #' @name getters 10 | #' @export 11 | get_index_quo <- function(.tbl_time) { 12 | if(!inherits(.tbl_time, "tbl_time")) glue_stop("Object is not of class `tbl_time`.") 13 | 14 | index_quo <- attr(.tbl_time, "index_quo") 15 | 16 | if(is.null(index_quo)) { 17 | glue_stop("Attribute, `index_quo`, has been lost, ", 18 | "but class is still `tbl_time`. This should not happen unless ", 19 | "something has gone horribly wrong.") 20 | } 21 | 22 | index_quo 23 | } 24 | 25 | #' @rdname getters 26 | #' @export 27 | get_index_char <- function(.tbl_time) { 28 | rlang::quo_name(get_index_quo(.tbl_time)) 29 | } 30 | 31 | #' @rdname getters 32 | #' @export 33 | get_index_col <- function(.tbl_time) { 34 | .tbl_time[[get_index_char(.tbl_time)]] 35 | } 36 | 37 | #' @rdname getters 38 | #' @export 39 | get_index_time_zone <- function(.tbl_time) { 40 | if(!inherits(.tbl_time, "tbl_time")) glue_stop("Object is not of class `tbl_time`.") 41 | 42 | index_time_zone <- attr(.tbl_time, "index_time_zone") 43 | 44 | if(is.null(index_time_zone)) { 45 | glue_stop("Attribute, `index_time_zone`, has been lost, ", 46 | "but class is still `tbl_time`. This should not happen unless ", 47 | "something has gone horribly wrong.") 48 | } 49 | 50 | index_time_zone 51 | } 52 | 53 | #' @rdname getters 54 | #' @export 55 | get_index_class <- function(.tbl_time) { 56 | class(get_index_col(.tbl_time))[[1]] 57 | } 58 | 59 | get_.index_col <- function(.tbl_time) { 60 | to_posixct_numeric(get_index_col(.tbl_time)) 61 | } 62 | 63 | get_index_dispatcher <- function(.tbl_time) { 64 | make_dummy_dispatch_obj(get_index_class(.tbl_time)) 65 | } 66 | 67 | # Getters in tbl_time object creation ------------------------------------------ 68 | 69 | # Get the default time zone. Use a non daylight savings default 70 | # to avoid issues like issue #31 71 | get_default_time_zone <- function() { 72 | "UTC" 73 | } 74 | 75 | get_index_col_time_zone <- function(index) { 76 | if(inherits(index, "POSIXct")) { 77 | (attr(index, "tzone") %||% Sys.timezone()) %||% get_default_time_zone() 78 | } else { 79 | get_default_time_zone() 80 | } 81 | } 82 | 83 | get_index_col_class <- function(index) { 84 | class(index)[[1]] 85 | } 86 | -------------------------------------------------------------------------------- /revdep/README.md: -------------------------------------------------------------------------------- 1 | # Platform 2 | 3 | |field |value | 4 | |:--------|:-------------------------------------------------------------------------------------------| 5 | |version |R version 4.2.2 (2022-10-31) | 6 | |os |macOS Monterey 12.6.2 | 7 | |system |x86_64, darwin17.0 | 8 | |ui |RStudio | 9 | |language |(EN) | 10 | |collate |en_US.UTF-8 | 11 | |ctype |en_US.UTF-8 | 12 | |tz |America/New_York | 13 | |date |2023-01-24 | 14 | |rstudio |2022.12.0+353 Elsbeth Geranium (desktop) | 15 | |pandoc |2.19.2 @ /Applications/RStudio.app/Contents/Resources/app/quarto/bin/tools/ (via rmarkdown) | 16 | 17 | # Dependencies 18 | 19 | |package |old |new |Δ | 20 | |:----------|:------|:------|:--| 21 | |tibbletime |0.1.7 |0.1.8 |* | 22 | |assertthat |0.2.1 |0.2.1 | | 23 | |cli |3.6.0 |3.6.0 | | 24 | |cpp11 |0.4.3 |0.4.3 | | 25 | |dplyr |1.0.10 |1.0.10 | | 26 | |ellipsis |0.3.2 |0.3.2 | | 27 | |fansi |1.0.4 |1.0.4 | | 28 | |generics |0.1.3 |0.1.3 | | 29 | |glue |1.6.2 |1.6.2 | | 30 | |hms |1.1.2 |1.1.2 | | 31 | |lifecycle |1.0.3 |1.0.3 | | 32 | |lubridate |1.9.1 |1.9.1 | | 33 | |magrittr |2.0.3 |2.0.3 | | 34 | |pillar |1.8.1 |1.8.1 | | 35 | |pkgconfig |2.0.3 |2.0.3 | | 36 | |purrr |1.0.1 |1.0.1 | | 37 | |R6 |2.5.1 |2.5.1 | | 38 | |Rcpp |1.0.10 |1.0.10 | | 39 | |rlang |1.0.6 |1.0.6 | | 40 | |tibble |3.1.8 |3.1.8 | | 41 | |tidyselect |1.2.0 |1.2.0 | | 42 | |timechange |0.2.0 |0.2.0 | | 43 | |utf8 |1.2.2 |1.2.2 | | 44 | |vctrs |0.5.2 |0.5.2 | | 45 | |withr |2.5.0 |2.5.0 | | 46 | |zoo |1.8-11 |1.8-11 | | 47 | 48 | # Revdeps 49 | 50 | -------------------------------------------------------------------------------- /R/parse_time_formula.R: -------------------------------------------------------------------------------- 1 | parse_time_formula <- function(index, time_formula) { 2 | 3 | # lhs/rhs list 4 | tf <- list( 5 | lhs = rlang::f_lhs(time_formula), 6 | rhs = rlang::f_rhs(time_formula) 7 | ) 8 | 9 | # Environment to evaluate the sides in 10 | tf_env <- rlang::f_env(time_formula) 11 | 12 | # Tidy evaluation 13 | tf <- lapply(tf, function(x) { 14 | eval(x, envir = tf_env) 15 | }) 16 | 17 | # Double up if 1 sided 18 | # length = 2 means that it has ~ and 1 side 19 | if(length(time_formula) == 2) { 20 | tf$lhs <- tf$rhs 21 | } 22 | 23 | tf <- lapply(tf, FUN = function(x) keyword_parse(index, x)) 24 | 25 | # Split the input 26 | tf <- lapply(tf, split_to_list) 27 | 28 | # Add default times 29 | # map2 is a bit slow here 30 | tf_final <- list(NA, NA) 31 | tf_final[[1]] <- add_time_defaults(index, tf[[1]], "lhs") 32 | tf_final[[2]] <- add_time_defaults(index, tf[[2]], "rhs") 33 | 34 | tf_final 35 | } 36 | 37 | ### Utils ---- 38 | 39 | 40 | ## Functions for adding defaults ------------------------------------------ 41 | 42 | # Adds default times to fill out the sides of the time formula 43 | add_time_defaults <- function(index, tf_side, side = "lhs") { 44 | 45 | # Lookup specific index class defaults 46 | defaults <- lookup_defaults(index, side) 47 | 48 | # Check length 49 | if(length(tf_side) > length(defaults)) { 50 | index_class <- class(index)[[1]] 51 | default_names <- paste(names(defaults), collapse = ", ") 52 | stop(paste0("For a ", index_class, " index, time_formula can only include ", 53 | default_names, " specifications."), call. = FALSE) 54 | } 55 | 56 | # Overwrite defaults where necessary 57 | for(i in seq_along(tf_side)) { 58 | defaults[[i]] <- tf_side[[i]] 59 | } 60 | 61 | # Handle end of month 62 | if(!is.null(defaults$d)) { # If this passes it was Date/POSIX 63 | if(defaults$d == 0) { 64 | # Fake a date to find the number of days in that month 65 | fake_date <- lubridate::make_date(defaults$y, defaults$m, 1) 66 | defaults$d <- lubridate::days_in_month(fake_date) 67 | } 68 | } 69 | 70 | defaults 71 | } 72 | 73 | ## Functions for keyword parsing ------------------------------------------ 74 | 75 | keyword_parse <- function(index, side) { 76 | 77 | # Dummy index 78 | if(length(index) == 0) { 79 | return(side) 80 | } 81 | 82 | if(as.character(side) == "start") { 83 | dplyr::first(index) 84 | } else if (as.character(side) == "end") { 85 | dplyr::last(index) 86 | } else { 87 | side 88 | } 89 | 90 | } 91 | -------------------------------------------------------------------------------- /tests/testthat/test_compat-tidyr.R: -------------------------------------------------------------------------------- 1 | context("tidyr compatability") 2 | 3 | # Test objects 4 | 5 | data(FANG) 6 | 7 | FANG_g <- FANG %>% 8 | dplyr::group_by(symbol) %>% 9 | dplyr::slice(1:10) 10 | 11 | FANG_g_time <- FANG_g %>% 12 | as_tbl_time(date) 13 | 14 | FANG_time <- FANG %>% 15 | as_tbl_time(date) %>% 16 | dplyr::slice(1:10) 17 | 18 | # Tests 19 | 20 | test_that("nest() with index creates tbl_df", { 21 | 22 | FANG_nested <- FANG_g_time %>% tidyr::nest(data = everything()) 23 | 24 | expect_is(FANG_nested, "tbl_df") 25 | expect_is(FANG_nested$data[[1]], "tbl_time") 26 | }) 27 | 28 | test_that("nest() without index stays tbl_time", { 29 | 30 | # Can't use grouped_df with -date, tidyr::nest only chooses groups 31 | FANG_nested <- FANG_time %>% tidyr::nest(data = -date) 32 | 33 | expect_is(FANG_nested, "tbl_time") 34 | }) 35 | 36 | test_that("nest() with .key is deprecated but works", { 37 | expect_warning( 38 | FANG_nested <- FANG_time %>% tidyr::nest(-date, .key = "stuff") 39 | ) 40 | 41 | expect_is(FANG_nested, "tbl_time") 42 | expect_is(FANG_nested$stuff[[1]], "tbl_df") 43 | }) 44 | 45 | test_that("unnest() with index returns tbl_df", { 46 | # This "works" because we added a special `unnest.tbl_df()` method that 47 | # intercepted the unnesting. But that was a horrible idea because we don't 48 | # own the tbl_df class. But we can't remove it because anomalize relies on it. 49 | 50 | FANG_unnested <- FANG_g_time %>% 51 | tidyr::nest(data = everything()) %>% 52 | tidyr::unnest(cols = data) 53 | 54 | expect_is(FANG_unnested, "tbl_time") 55 | expect_equal(get_index_col(FANG_g_time), get_index_col(FANG_unnested)) 56 | }) 57 | 58 | test_that("unnest() without index stays tbl_time", { 59 | 60 | FANG_unnested <- FANG_time %>% tidyr::nest(data = c(-symbol, -date)) %>% tidyr::unnest(cols = data) 61 | 62 | expect_is(FANG_unnested, "tbl_time") 63 | expect_equal(get_index_col(FANG_time), get_index_col(FANG_unnested)) 64 | }) 65 | 66 | test_that("unnest() with `...` is deprecated but works", { 67 | FANG_nested <- FANG_g_time %>% tidyr::nest(data1 = open, data2 = high) 68 | 69 | expect_warning( 70 | FANG_unnested <- tidyr::unnest(FANG_nested, data1, data2) 71 | ) 72 | 73 | expect_is(FANG_unnested, "tbl_time") 74 | }) 75 | 76 | test_that("can still do a normal unnest()", { 77 | mtcars_unnested <- mtcars %>% 78 | tidyr::nest(data = c(mpg, cyl)) %>% 79 | tidyr::unnest(cols = data) 80 | 81 | expect_is(mtcars_unnested, "tbl_df") 82 | expect_equal(sort(colnames(mtcars_unnested)), sort(colnames(mtcars))) 83 | }) 84 | -------------------------------------------------------------------------------- /R/round-index.R: -------------------------------------------------------------------------------- 1 | #' A simple wrapper of [lubridate::ceiling_date()] 2 | #' 3 | #' This is a thin wrapper around a [lubridate::ceiling_date()] that works 4 | #' for `hms`, `yearmon`, and `yearqtr` classes as well. 5 | #' 6 | #' @inheritParams lubridate::ceiling_date 7 | #' 8 | #' @examples 9 | #' 10 | #' data(FB) 11 | #' dplyr::mutate(FB, date2 = ceiling_index(date, "year")) 12 | #' 13 | #' time_test <- create_series('00:00:00'~'12:00:00', 14 | #' '1 minute', class = "hms") 15 | #' 16 | #' dplyr::mutate(time_test, date2 = ceiling_index(date, "hour")) 17 | #' 18 | #' @seealso [lubridate::ceiling_date()] 19 | #' 20 | #' @export 21 | ceiling_index <- function(x, unit = "seconds") { 22 | UseMethod("ceiling_index") 23 | } 24 | 25 | #' @export 26 | ceiling_index.default <- function(x, unit = "seconds") { 27 | lubridate::ceiling_date(x, unit) 28 | } 29 | 30 | #' @export 31 | ceiling_index.hms <- function(x, unit = "seconds") { 32 | ceilinged <- ceiling_index(as.POSIXct(x), unit) 33 | hms::as_hms(ceilinged) 34 | } 35 | 36 | #' @export 37 | ceiling_index.yearmon <- function(x, unit = "seconds") { 38 | zoo::as.yearmon(ceiling_index(zoo::as.Date(x), unit)) 39 | } 40 | 41 | #' @export 42 | ceiling_index.yearqtr <- function(x, unit = "seconds") { 43 | zoo::as.yearqtr(ceiling_index(zoo::as.Date(x), unit)) 44 | } 45 | 46 | 47 | 48 | #' A simple wrapper of [lubridate::floor_date()] 49 | #' 50 | #' This is a thin wrapper around a [lubridate::floor_date()] that works 51 | #' for `hms`, `yearmon`, and `yearqtr` classes as well. 52 | #' 53 | #' @inheritParams lubridate::floor_date 54 | #' 55 | #' @examples 56 | #' 57 | #' data(FB) 58 | #' dplyr::mutate(FB, date2 = floor_index(date, "year")) 59 | #' 60 | #' time_test <- create_series('00:00:00'~'12:00:00', 61 | #' '1 minute', class = "hms") 62 | #' 63 | #' dplyr::mutate(time_test, date2 = floor_index(date, "hour")) 64 | #' 65 | #' @seealso [lubridate::floor_date()] 66 | #' 67 | #' @export 68 | floor_index <- function(x, unit = "seconds") { 69 | UseMethod("floor_index") 70 | } 71 | 72 | #' @export 73 | floor_index.default <- function(x, unit = "seconds") { 74 | lubridate::floor_date(x, unit) 75 | } 76 | 77 | #' @export 78 | floor_index.hms <- function(x, unit = "seconds") { 79 | floored <- floor_index(as.POSIXct(x), unit) 80 | hms::as_hms(floored) 81 | } 82 | 83 | #' @export 84 | floor_index.yearmon <- function(x, unit = "seconds") { 85 | zoo::as.yearmon(floor_index(zoo::as.Date(x), unit)) 86 | } 87 | 88 | #' @export 89 | floor_index.yearqtr <- function(x, unit = "seconds") { 90 | zoo::as.yearqtr(floor_index(zoo::as.Date(x), unit)) 91 | } 92 | 93 | -------------------------------------------------------------------------------- /.github/workflows/pr-commands.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | issue_comment: 5 | types: [created] 6 | 7 | name: Commands 8 | 9 | jobs: 10 | document: 11 | if: ${{ github.event.issue.pull_request && (github.event.comment.author_association == 'MEMBER' || github.event.comment.author_association == 'OWNER') && startsWith(github.event.comment.body, '/document') }} 12 | name: document 13 | runs-on: ubuntu-latest 14 | env: 15 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 16 | steps: 17 | - uses: actions/checkout@v3 18 | 19 | - uses: r-lib/actions/pr-fetch@v2 20 | with: 21 | repo-token: ${{ secrets.GITHUB_TOKEN }} 22 | 23 | - uses: r-lib/actions/setup-r@v2 24 | with: 25 | use-public-rspm: true 26 | 27 | - uses: r-lib/actions/setup-r-dependencies@v2 28 | with: 29 | extra-packages: any::roxygen2 30 | needs: pr-document 31 | 32 | - name: Document 33 | run: roxygen2::roxygenise() 34 | shell: Rscript {0} 35 | 36 | - name: commit 37 | run: | 38 | git config --local user.name "$GITHUB_ACTOR" 39 | git config --local user.email "$GITHUB_ACTOR@users.noreply.github.com" 40 | git add man/\* NAMESPACE 41 | git commit -m 'Document' 42 | 43 | - uses: r-lib/actions/pr-push@v2 44 | with: 45 | repo-token: ${{ secrets.GITHUB_TOKEN }} 46 | 47 | style: 48 | if: ${{ github.event.issue.pull_request && (github.event.comment.author_association == 'MEMBER' || github.event.comment.author_association == 'OWNER') && startsWith(github.event.comment.body, '/style') }} 49 | name: style 50 | runs-on: ubuntu-latest 51 | env: 52 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 53 | steps: 54 | - uses: actions/checkout@v3 55 | 56 | - uses: r-lib/actions/pr-fetch@v2 57 | with: 58 | repo-token: ${{ secrets.GITHUB_TOKEN }} 59 | 60 | - uses: r-lib/actions/setup-r@v2 61 | 62 | - name: Install dependencies 63 | run: install.packages("styler") 64 | shell: Rscript {0} 65 | 66 | - name: Style 67 | run: styler::style_pkg() 68 | shell: Rscript {0} 69 | 70 | - name: commit 71 | run: | 72 | git config --local user.name "$GITHUB_ACTOR" 73 | git config --local user.email "$GITHUB_ACTOR@users.noreply.github.com" 74 | git add \*.R 75 | git commit -m 'Style' 76 | 77 | - uses: r-lib/actions/pr-push@v2 78 | with: 79 | repo-token: ${{ secrets.GITHUB_TOKEN }} 80 | -------------------------------------------------------------------------------- /R/coercion.R: -------------------------------------------------------------------------------- 1 | #' Create `tbl_time` objects 2 | #' 3 | #' `tbl_time` objects have a time index that contains information about 4 | #' which column should be used for time-based subsetting and other time-based 5 | #' manipulation. Otherwise, they function as normal tibbles. 6 | #' 7 | #' @details 8 | #' 9 | #' The information stored about `tbl_time` objects are the `index_quo` and the 10 | #' `index_time_zone`. These are stored as attributes, with the `index_quo` as a 11 | #' [rlang::quosure()] and the `time_zone` as a string. 12 | #' 13 | #' Currently, `Date` and `POSIXct` classes are fully supported. `yearmon`, 14 | #' `yearqtr`, and `hms` have experimental support. Due to dplyr's 15 | #' handling of S3 classes like these 3, the classes are lost when you 16 | #' manipulate the index columns directly. 17 | #' 18 | #' @param x An object to be converted to `tbl_time`. This is generally 19 | #' a [tibble::tibble()], or an object that can first be coerced to a `tibble`. 20 | #' @param index The bare column name of the column to be used as the index. 21 | #' @param ... Arguments passed to [tibble::as_tibble()] if coercion is 22 | #' necessary first. 23 | #' 24 | #' @export 25 | #' 26 | #' @examples 27 | #' 28 | #' # Converting a data.frame to a `tbl_time` 29 | #' # Using Date index 30 | #' ex1 <- data.frame(date = Sys.Date(), value = 1) 31 | #' ex1_tbl_time <- as_tbl_time(ex1, date) 32 | #' class(ex1_tbl_time) 33 | #' attributes(ex1_tbl_time) 34 | #' 35 | #' # Converting a tibble to a `tbl_time` 36 | #' # Using POSIXct index 37 | #' ex2 <- tibble::tibble( 38 | #' time = as.POSIXct(c("2017-01-01 10:12:01", "2017-01-02 12:12:01")), 39 | #' value = c(1, 2) 40 | #' ) 41 | #' as_tbl_time(ex2, time) 42 | #' 43 | #' @export 44 | #' @rdname tbl_time 45 | as_tbl_time <- function(x, index = NULL, ...) { 46 | UseMethod("as_tbl_time") 47 | } 48 | 49 | #' @export 50 | as_tbl_time.default <- function(x, index = NULL, ...) { 51 | index_quo <- rlang::enquo(index) 52 | 53 | # Default to as_tibble for any error handling 54 | # If it can be converted to tibble, then try and convert to tbl_time 55 | as_tbl_time(tibble::as_tibble(x, ...), !! index_quo) 56 | } 57 | 58 | #' @export 59 | as_tbl_time.tbl_df <- function(x, index = NULL, ...) { 60 | index_quo <- rlang::enquo(index) 61 | 62 | # Pass off to helper 63 | tbl_time(x, !! index_quo) 64 | } 65 | 66 | # Parent coercion -------------------------------------------------------------- 67 | 68 | #' @export 69 | #' @importFrom tibble as_tibble 70 | as_tibble.tbl_time <- function(x, ...) { 71 | new_bare_tibble(x) 72 | } 73 | 74 | # new_tibble() currently doesn't strip attributes 75 | # https://github.com/tidyverse/tibble/pull/769 76 | new_bare_tibble <- function(x, ..., class = character()) { 77 | x <- vctrs::new_data_frame(x) 78 | tibble::new_tibble(x, nrow = nrow(x), ..., class = class) 79 | } 80 | 81 | -------------------------------------------------------------------------------- /tests/testthat/test_filter_time.R: -------------------------------------------------------------------------------- 1 | context("filter_time testing") 2 | 3 | # Test objects 4 | 5 | data(FB) 6 | test_time <- FB 7 | test_tbl_time <- as_tbl_time(test_time, date) 8 | 9 | data(FANG) 10 | test_tbl_time_g <- as_tbl_time(FANG, date) %>% 11 | dplyr::group_by(symbol) 12 | 13 | # Tests 14 | 15 | test_that("tbl_time class is retained", { 16 | test <- filter_time(test_tbl_time, ~'2013') 17 | expect_is(test, "tbl_time") 18 | }) 19 | 20 | test_that("Filtering is expanded correctly", { 21 | test <- filter_time(test_tbl_time, ~'2013') 22 | test_filter <- dplyr::filter(test_tbl_time, 23 | date >= "2013-01-01", 24 | date <= "2013-12-31") 25 | expect_equal(test, test_filter) 26 | }) 27 | 28 | test_that("Filtering is expanded correctly - double sided", { 29 | test <- filter_time(test_tbl_time, '2013-01' ~ '2014-02') 30 | test_filter <- dplyr::filter(test_tbl_time, 31 | date >= "2013-01-01", 32 | date <= "2014-02-28") 33 | expect_equal(test, test_filter) 34 | }) 35 | 36 | test_that("Time filter works with POSIXct objects", { 37 | test_tbl_time_posix <- dplyr::mutate(test_tbl_time, date = as.POSIXct(date)) 38 | test <- filter_time(test_tbl_time_posix, 39 | '2013-01-02 12:00:00' ~ '2014-02-01 14:01:01') 40 | test_filter <- dplyr::filter(test_tbl_time, 41 | date >= "2013-01-03", 42 | date <= "2014-01-31") %>% 43 | dplyr::mutate(date = as.POSIXct(date)) 44 | expect_equal(test, test_filter) 45 | }) 46 | 47 | test_that("Error with non tbl_time object", { 48 | expect_error(filter_time(test_time, ~'2013'), 49 | "Object is not of class `tbl_time`.") 50 | }) 51 | 52 | test_that("Groups are respected", { 53 | test <- filter_time(test_tbl_time_g, ~'2013') 54 | expect_equal(nrow(test), 1008L) 55 | }) 56 | 57 | test_that("Time filter subsetting [~i] works", { 58 | expect_equal(ncol(test_tbl_time[~'2013']), 8L) 59 | expect_equal(nrow(test_tbl_time[~'2013']), 252L) 60 | }) 61 | 62 | test_that("Column subsetting [i] works", { 63 | expect_equal(ncol(test_tbl_time[2]), 1L) 64 | expect_equal(nrow(test_tbl_time[2]), 1008L) 65 | }) 66 | 67 | test_that("Column subsetting [i, drop] works", { 68 | expect_equal(ncol(test_tbl_time[2, drop = FALSE]), 1L) 69 | expect_equal(nrow(test_tbl_time[2, drop = FALSE]), 1008L) 70 | }) 71 | 72 | test_that("Row subsetting [i,] works", { 73 | expect_equal(ncol(test_tbl_time[2,]), 8L) 74 | expect_equal(nrow(test_tbl_time[2,]), 1L) 75 | }) 76 | 77 | test_that("Row subsetting [i, , drop = FALSE] works", { 78 | expect_equal(ncol(test_tbl_time[2, , drop = FALSE]), 8L) 79 | expect_equal(nrow(test_tbl_time[2, , drop = FALSE]), 1L) 80 | }) 81 | 82 | test_that("Row subsetting [i, j] works", { 83 | expect_equal(ncol(test_tbl_time[1, 2]), 1L) 84 | expect_equal(nrow(test_tbl_time[2, 2]), 1L) 85 | }) 86 | -------------------------------------------------------------------------------- /man/collapse_by.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/collapse_index.R 3 | \name{collapse_by} 4 | \alias{collapse_by} 5 | \title{Collapse a tbl_time object by its index} 6 | \usage{ 7 | collapse_by( 8 | .tbl_time, 9 | period = "year", 10 | start_date = NULL, 11 | side = "end", 12 | clean = FALSE, 13 | ... 14 | ) 15 | } 16 | \arguments{ 17 | \item{.tbl_time}{A \code{tbl_time} object.} 18 | 19 | \item{period}{A character specification used for time-based grouping. The 20 | general format to use is \code{"frequency period"} where frequency is a number 21 | like 1 or 2, and period is an interval like weekly or yearly. There must be 22 | a space between the two. 23 | 24 | Note that you can pass the specification in a flexible way: 25 | \itemize{ 26 | \item 1 Year: \code{'1 year'} / \code{'1 Y'} 27 | } 28 | 29 | This shorthand is available for year, quarter, month, day, hour, minute, 30 | second, millisecond and microsecond periodicities. 31 | 32 | Additionally, you have the option of passing in a vector of dates to 33 | use as custom and more flexible boundaries.} 34 | 35 | \item{start_date}{Optional argument used to 36 | specify the start date for the 37 | first group. The default is to start at the closest period boundary 38 | below the minimum date in the supplied index.} 39 | 40 | \item{side}{Whether to return the date at the beginning or the end of 41 | the new period. By default, the "end" of the period. 42 | Use "start" to change to the start of the period.} 43 | 44 | \item{clean}{Whether or not to round the collapsed index up / down to the next 45 | period boundary. The decision to round up / down is controlled by the side 46 | argument.} 47 | 48 | \item{...}{Not currently used.} 49 | } 50 | \description{ 51 | Collapse the index of a \code{tbl_time} object by time period. The index column 52 | is altered so that all dates that fall in a specified interval share a 53 | common date. 54 | } 55 | \details{ 56 | \code{collapse_by()} is a simplification of a call to \code{\link[dplyr:mutate]{dplyr::mutate()}} to collapse an 57 | index column using \code{\link[=collapse_index]{collapse_index()}}. 58 | } 59 | \examples{ 60 | 61 | # Basic functionality ------------------------------------------------------- 62 | 63 | # Facebook stock prices 64 | data(FB) 65 | FB <- as_tbl_time(FB, date) 66 | 67 | # Collapse to weekly dates 68 | collapse_by(FB, "weekly") 69 | 70 | # A common workflow is to group on the collapsed date column 71 | # to perform a time based summary 72 | FB \%>\% 73 | collapse_by("year") \%>\% 74 | dplyr::group_by(date) \%>\% 75 | dplyr::summarise_if(is.numeric, mean) 76 | 77 | # Grouped functionality ----------------------------------------------------- 78 | 79 | data(FANG) 80 | FANG <- FANG \%>\% 81 | as_tbl_time(date) \%>\% 82 | dplyr::group_by(symbol) 83 | 84 | # Collapse each group to monthly, 85 | # calculate monthly standard deviation for each column 86 | FANG \%>\% 87 | collapse_by("month") \%>\% 88 | dplyr::group_by(symbol, date) \%>\% 89 | dplyr::summarise_all(sd) 90 | 91 | } 92 | -------------------------------------------------------------------------------- /man/create_series.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/create_series.R 3 | \name{create_series} 4 | \alias{create_series} 5 | \title{Create a \code{tbl_time} object with a sequence of regularly spaced dates} 6 | \usage{ 7 | create_series( 8 | time_formula, 9 | period = "day", 10 | class = "POSIXct", 11 | include_end = FALSE, 12 | tz = "UTC", 13 | as_vector = FALSE 14 | ) 15 | } 16 | \arguments{ 17 | \item{time_formula}{A period to create the series over. 18 | This is specified as a formula. 19 | See the \code{Details} section of \code{\link[=filter_time]{filter_time()}} for more information.} 20 | 21 | \item{period}{A character specification used for time-based grouping. The 22 | general format to use is \code{"frequency period"} where frequency is a number 23 | like 1 or 2, and period is an interval like weekly or yearly. There must be 24 | a space between the two. 25 | 26 | Note that you can pass the specification in a flexible way: 27 | \itemize{ 28 | \item 1 Year: \code{'1 year'} / \code{'1 Y'} 29 | } 30 | 31 | This shorthand is available for year, quarter, month, day, hour, minute, 32 | second, millisecond and microsecond periodicities. 33 | 34 | Additionally, you have the option of passing in a vector of dates to 35 | use as custom and more flexible boundaries.} 36 | 37 | \item{class}{One of \code{"Date"}, \code{"POSIXct"}, \code{"hms"}, \code{"yearmon"}, \code{"yearqtr"}. 38 | The default is \code{"POSIXct"}.} 39 | 40 | \item{include_end}{Whether to always include the RHS of the \code{time_formula} 41 | even if it does not match the regularly spaced index.} 42 | 43 | \item{tz}{Time zone of the new series.} 44 | 45 | \item{as_vector}{Should the series be returned as a vector instead of 46 | a tibble?} 47 | } 48 | \description{ 49 | \code{\link[=create_series]{create_series()}} allows the user to quickly create a \code{tbl_time} object with 50 | a \code{date} column populated with a sequence of dates. 51 | } 52 | \examples{ 53 | 54 | # Every day in 2013 55 | create_series(~'2013', 'day') 56 | 57 | # Every other day in 2013 58 | create_series(~'2013', '2 d') 59 | 60 | # Every quarter in 2013 61 | create_series(~'2013', '1 q') 62 | 63 | # Daily series for 2013-2015 64 | create_series('2013' ~ '2015', '1 d') 65 | 66 | # Minute series for 2 months 67 | create_series('2012-01' ~ '2012-02', 'M') 68 | 69 | # Second series for 2 minutes 70 | create_series('2011-01-01 12:10:00' ~ '2011-01-01 12:12:00', 's') 71 | 72 | # Date class 73 | create_series(~'2013', 'day', class = "Date") 74 | 75 | # yearmon class 76 | create_series(~'2013', 'month', class = "yearmon") 77 | 78 | # hms class. time_formula specified as HH:MM:SS here 79 | create_series('00:00:00' ~ '12:00:00', 'second' , class = "hms") 80 | 81 | # Subsecond series 82 | create_series('2013' ~ '2013-01-01 00:00:01', period = "10 millisec") 83 | milli <- create_series('2013' ~ '2013-01-01 00:00:01', period = ".1 sec") 84 | # Check that 'milli' is correct by running: 85 | # options("digits.secs" = 4) 86 | # options("digits" = 18) 87 | # milli$date 88 | # as.numeric(milli$date) 89 | 90 | 91 | } 92 | -------------------------------------------------------------------------------- /tests/testthat/test_collapse_index.R: -------------------------------------------------------------------------------- 1 | context("collapse_index testing") 2 | 3 | # Test objects 4 | 5 | test_time <- tibble::tibble( 6 | date = c(as.Date("2017-12-01"), as.Date("2017-12-02"), as.Date("2017-12-03")), 7 | value = c(1, 2, 3), 8 | group1 = c("a", "a", "b"), 9 | group2 = c("d", "e", "e") 10 | ) 11 | 12 | # Tests 13 | 14 | test_that("Yearly collapse returns correct dates", { 15 | test <- collapse_index(test_time$date, "year") 16 | expect_equal(unique(test), 17 | as.Date("2017-12-03")) 18 | }) 19 | 20 | test_that("side = 'start' returns start of period", { 21 | test <- collapse_index(test_time$date, "year", side = "start") 22 | expect_equal(unique(test), 23 | as.Date("2017-12-01")) 24 | }) 25 | 26 | test_that("Index vectors can be passed to the period argument", { 27 | custom_period <- create_series("2017-11-30" ~ "2017-12-03", "2 day", "Date", as_vector = TRUE) 28 | test <- collapse_index(test_time$date, custom_period) 29 | expect_equal(test, 30 | as.Date(c("2017-12-01", "2017-12-03", "2017-12-03"))) 31 | }) 32 | 33 | test_that("Collapsing works on yearmon", { 34 | ex <- create_series(~'2017', "month", "yearmon") 35 | 36 | expect_equal(collapse_index(ex$date, "year"), 37 | zoo::as.yearmon(rep(2017.917, 12))) 38 | }) 39 | 40 | test_that("Collapsing works on yearqtr", { 41 | ex <- create_series(~'2017', "quarter", "yearqtr") 42 | 43 | expect_equal(collapse_index(ex$date, "year"), 44 | zoo::as.yearqtr(rep(2017.75, 4))) 45 | }) 46 | 47 | test_that("Collapsing works on hms", { 48 | ex <- create_series(~'12:00', "second", "hms") 49 | 50 | expect_equal(collapse_index(ex$date, "minute", side = "start"), 51 | hms::hms(rep(43200, 60))) 52 | }) 53 | 54 | test_that("day becomes DSTday for POSIXct to prevent DST boundary problems", { 55 | seq_fun <- lookup_seq_fun(x = make_dummy_dispatch_obj("POSIXct")) 56 | 57 | ret <- seq_fun(as.POSIXct("2016-03-12", tz = "America/New_York"), 58 | as.POSIXct("2016-03-14", tz = "America/New_York"), 59 | "1 day") 60 | 61 | test <- as.POSIXct(c("2016-03-12", "2016-03-13", "2016-03-14"), 62 | tz = "America/New_York") 63 | 64 | expect_equal(ret, test) 65 | }) 66 | 67 | test_that("can use `collapse_by()` when a column is named `start_date` (#81)", { 68 | x <- data.frame( 69 | start_date = as.Date("2017-12-01") + 0:2, 70 | value = c(1, 2, 3) 71 | ) 72 | 73 | x <- as_tbl_time(x, start_date) 74 | 75 | expect_equal( 76 | collapse_by(x), 77 | dplyr::mutate(x, start_date = collapse_index(start_date)) 78 | ) 79 | 80 | expect_equal( 81 | collapse_by(x, start_date = as.Date("2017-01-01"), side = "start", period = "2 days"), 82 | dplyr::mutate(x, start_date = collapse_index(start_date, "2 days", start_date = as.Date("2017-01-01"), side = "start")) 83 | ) 84 | 85 | expect_equal( 86 | collapse_by(x, start_date = as.Date("2016-12-31"), side = "start", period = "2 days"), 87 | dplyr::mutate(x, start_date = collapse_index(start_date, "2 days", start_date = as.Date("2016-12-31"), side = "start")) 88 | ) 89 | }) 90 | 91 | 92 | -------------------------------------------------------------------------------- /R/to_posixct_numeric.R: -------------------------------------------------------------------------------- 1 | #### TO POSIXct NUMERIC 2 | 3 | to_posixct_numeric <- function(index) { 4 | UseMethod("to_posixct_numeric") 5 | } 6 | 7 | #' @export 8 | to_posixct_numeric.default <- function(index) { 9 | as.numeric(index) 10 | } 11 | 12 | #' @export 13 | to_posixct_numeric.Date <- function(index) { 14 | secs_in_day <- 86400 15 | as.numeric(.POSIXct(unclass(index) * secs_in_day, tz = get_default_time_zone())) 16 | } 17 | 18 | #' @export 19 | to_posixct_numeric.POSIXct <- function(index) { 20 | as.numeric(index) 21 | } 22 | 23 | #' @export 24 | to_posixct_numeric.yearmon <- function(index) { 25 | to_posixct_numeric( 26 | yearmon_to_POSIXct(index) 27 | ) 28 | } 29 | 30 | # Same as yearmon, represented as a numeric internally, same as yearmon 31 | #' @export 32 | to_posixct_numeric.yearqtr <- to_posixct_numeric.yearmon 33 | 34 | #' @export 35 | to_posixct_numeric.hms <- function(index) { 36 | # No need to convert to POSIXct then numeric, this is just number of 37 | # seconds since epoch 38 | as.numeric(index) 39 | } 40 | 41 | 42 | # This is much faster than using as.POSIXct.yearmon which calls 43 | # as.POSIXct.Date, it converts a character to a Date, very slow! 44 | yearmon_to_POSIXct <- function(x) { 45 | x <- unclass(x) 46 | if (all(is.na(x))) { 47 | return(as.Date(x)) 48 | } 49 | year <- floor(x + 0.001) 50 | month <- floor(12 * (x - year) + 1 + 0.5 + 0.001) 51 | 52 | lubridate::make_datetime(year, month, 1, tz = get_default_time_zone()) 53 | } 54 | 55 | 56 | #### FROM POSIXct NUMERIC 57 | 58 | #' Converting a posixct numeric time back to a classed datetime 59 | #' 60 | #' @param x A posixct numeric vector 61 | #' @param class The class to convert to 62 | #' @param ... Extra arguments passed on the the specific coercion function 63 | #' @param tz The time zone to convert to. The default UTC is used if none is 64 | #' supplied 65 | posixct_numeric_to_datetime <- function(x, class = "POSIXct", ..., tz = NULL) { 66 | dispatch_obj <- make_dummy_dispatch_obj(class) 67 | dispatch_to_datetime(dispatch_obj, x, ..., tz = tz) 68 | } 69 | 70 | # This picks the datetime class to convert back to 71 | dispatch_to_datetime <- function(dummy, x, ...) { 72 | UseMethod("dispatch_to_datetime") 73 | } 74 | 75 | #' @export 76 | dispatch_to_datetime.default <- function(dummy, x, ..., tz = NULL) { 77 | tz <- tz %||% get_default_time_zone() 78 | as.POSIXct(x, tz = tz, origin = "1970-01-01", ...) 79 | } 80 | 81 | #' @export 82 | dispatch_to_datetime.Date <- function(dummy, x, ..., tz = NULL) { 83 | tz <- tz %||% get_default_time_zone() 84 | as.Date(dispatch_to_datetime.default(dummy, x, tz = tz), tz = tz) 85 | } 86 | 87 | #' @export 88 | dispatch_to_datetime.yearmon <- function(dummy, x, ..., tz = NULL) { 89 | zoo::as.yearmon(dispatch_to_datetime.default(dummy, x, tz = tz)) 90 | } 91 | 92 | #' @export 93 | dispatch_to_datetime.yearqtr <- function(dummy, x, ..., tz = NULL) { 94 | zoo::as.yearqtr(dispatch_to_datetime.default(dummy, x, tz = tz)) 95 | } 96 | 97 | #' @export 98 | dispatch_to_datetime.hms <- function(dummy, x, ..., tz = NULL) { 99 | datetime <- dispatch_to_datetime.default(dummy, x, tz = tz) 100 | hms::as_hms(datetime) 101 | } 102 | -------------------------------------------------------------------------------- /vignettes/TT-02-changing-time-periods.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Changing periodicity" 3 | author: "Davis Vaughan" 4 | date: "`r Sys.Date()`" 5 | output: 6 | rmarkdown::html_vignette: 7 | toc: true 8 | toc_depth: 2 9 | vignette: > 10 | %\VignetteIndexEntry{Changing periodicity} 11 | %\VignetteEngine{knitr::rmarkdown} 12 | %\VignetteEncoding{UTF-8} 13 | --- 14 | 15 | # Introducing as_period() 16 | 17 | Often with time series you want to aggregate your dataset to a less 18 | granular period. An example of this might be moving from a daily series to 19 | a monthly series to look at broader trends in your data. `as_period()` allows 20 | you to do exactly this. 21 | 22 | The `period` argument in `as_period()` for specifying the transformation you 23 | want is a character with a general format of `"frequency period"` where frequency 24 | is a number like 1 or 2, and period is an interval like `weekly` or `yearly`. 25 | There must be a space between the two. 26 | 27 | ## Datasets required 28 | 29 | ```{r, message=FALSE, warning=FALSE} 30 | library(tibbletime) 31 | library(dplyr) 32 | 33 | # Facebook stock prices. 34 | data(FB) 35 | 36 | # Convert FB to tbl_time 37 | FB <- as_tbl_time(FB, index = date) 38 | 39 | # FANG stock prices 40 | data(FANG) 41 | 42 | # Convert FANG to tbl_time and group 43 | FANG <- as_tbl_time(FANG, index = date) %>% 44 | group_by(symbol) 45 | 46 | ``` 47 | 48 | ## Daily to monthly 49 | 50 | To see this in action, transform the daily `FB` data set to monthly data. 51 | 52 | ```{r} 53 | as_period(FB, '1 month') 54 | 55 | # Additionally, the following are equivalent 56 | # as_period(FB, 'month') 57 | # as_period(FB, 'm') 58 | # as_period(FB, '1 m') 59 | ``` 60 | 61 | ## Generic periods 62 | 63 | You aren't restricted to only 1 month periods. Maybe you wanted every 2 months? 64 | 65 | ```{r} 66 | as_period(FB, '2 m') 67 | ``` 68 | 69 | Or maybe every 25 days? Note that the dates do not line up exactly with a 70 | difference of 25 days. This is due to the data set not being completely regular 71 | (there are gaps due to weekends and holidays). 72 | `as_period()` chooses the first date it can find in the period specified. 73 | 74 | ```{r} 75 | as_period(FB, '25 d') 76 | ``` 77 | 78 | 79 | ## Details and the `start_date` argument 80 | 81 | By default, the date that starts the first group is calculated as: 82 | 83 | 1) Find the minimum date in your dataset. 84 | 85 | 2) Floor that date to the period that you specified. 86 | 87 | In the 1 month example above, `2013-01-02` is the first date in the series, 88 | and because "month" was chosen, the first group is defined as 89 | (2013-01-01 to 2013-01-31). 90 | 91 | Occasionally this is not what you want. Consider what would happen if you 92 | changed the period to "every 2 days". The first date is `2013-01-02`, but 93 | because "day" is chosen, this isn't floored to `2013-01-01` so the groups are 94 | (2013-01-02, 2013-01-03), (2013-01-04, 2013-01-05) and so on. 95 | If you wanted the first group to be (2013-01-01, 2013-01-02), you can use 96 | the `start_date` argument. 97 | 98 | ```{r} 99 | # Without start_date 100 | as_period(FB, '2 d') 101 | ``` 102 | 103 | ```{r} 104 | # With start_date 105 | as_period(FB, '2 d', start_date = "2013-01-01") 106 | ``` 107 | 108 | 109 | ## The `side` argument 110 | 111 | By default, the first date per period is returned. If you want the end of each 112 | period instead, specify the `side = "end"` argument. 113 | 114 | ```{r} 115 | as_period(FB, 'y', side = "end") 116 | ``` 117 | 118 | ## Grouped datasets 119 | 120 | One of the neat things about working in the `tidyverse` is that these functions 121 | can also work with grouped datasets. Here we transform the daily series of the 122 | 4 FANG stocks to a periodicity of every 2 years. 123 | 124 | ```{r} 125 | FANG %>% 126 | as_period('2 y') 127 | ``` 128 | -------------------------------------------------------------------------------- /R/parse_period.R: -------------------------------------------------------------------------------- 1 | #' Parse a character period specification 2 | #' 3 | #' The period is parsed into frequency and period and returned as a named list. 4 | #' 5 | #' @inheritParams partition_index 6 | #' 7 | #' @export 8 | #' 9 | #' @examples 10 | #' 11 | #' parse_period('2 day') 12 | #' 13 | parse_period <- function(period) { 14 | UseMethod("parse_period") 15 | } 16 | 17 | #' @export 18 | parse_period.default <- function(period) { 19 | glue_stop("Unsupported period specification. Only characters are allowed.") 20 | } 21 | 22 | #' @export 23 | parse_period.character <- function(period) { 24 | 25 | # Cannot supply vector of periods. 1 character only 26 | if(length(period) != 1) { 27 | glue_stop("Only 1 period can be specified.") 28 | } 29 | 30 | # Split on " " 31 | period_split <- unlist(strsplit(period, " ")) 32 | 33 | # Assign period_freq / period_char 34 | if(length(period_split) == 1) { 35 | 36 | period_freq <- 1 37 | period_char <- period_split 38 | 39 | } else if(length(period_split) == 2) { 40 | 41 | assert_freq_coerce_to_numeric(period_split[1]) 42 | period_freq <- as.numeric(period_split[1]) 43 | period_char <- period_split[2] 44 | 45 | } else { 46 | glue_stop("A maximum of 1 space character is allowed in the period.") 47 | } 48 | 49 | period_char <- parse_period_char(period_char) 50 | 51 | period_list <- list(freq = period_freq, period = period_char) 52 | 53 | period_list <- check_subsecond_period(period_list) 54 | 55 | period_list 56 | } 57 | 58 | 59 | #### Utils --------------------------------------------------------------------- 60 | 61 | # Check that the RHS of period is correct 62 | parse_period_char <- function(period) { 63 | 64 | if(string_length(period) == 1) { 65 | p <- parse_letter_period(period) 66 | } else { 67 | p <- parse_word_period(period) 68 | } 69 | 70 | p 71 | } 72 | 73 | # >1 letter character parsing 74 | parse_word_period <- function(period) { 75 | 76 | key <- c("year", "quarter", "month", "week", 77 | "da", "hour", "min", "sec", 78 | "ms", "mil", "us", "mic") 79 | 80 | value <- c("year", "quarter", "month", "week", 81 | "day", "hour", "min", "sec", 82 | "millisec", "millisec", "microsec", "microsec") 83 | 84 | loc_vec <- pmatch(key, period) 85 | parsed_period <- value[!is.na(loc_vec)] 86 | 87 | if(length(parsed_period) == 0) { 88 | glue_stop("Period '{period}' specified incorrectly.") 89 | } 90 | 91 | parsed_period 92 | } 93 | 94 | # 1 letter parsing, case sensitive 95 | parse_letter_period <- function(period) { 96 | switch (period, 97 | "y" = "year", "Y" = "year", 98 | "q" = "quarter", "Q" = "quarter", 99 | "m" = "month", # Case sensitive 100 | "w" = "week", "W" = "week", 101 | "d" = "day", "D" = "day", 102 | "h" = "hour", "H" = "hour", 103 | "M" = "min", # Case sensitive 104 | "s" = "sec", "S" = "sec", 105 | "l" = "millisec", "L" = "millisec", 106 | "u" = "microsec", "U" = "microsec", 107 | glue_stop("Period '{period}' specified incorrectly.") 108 | ) 109 | } 110 | 111 | # Check that the freq can be coerced to numeric 112 | assert_freq_coerce_to_numeric <- function(freq) { 113 | assertthat::assert_that( 114 | # Coercing to numeric should give a number, not NA 115 | suppressWarnings(!is.na(as.numeric(freq))), 116 | msg = "Frequency must be coercible to numeric." 117 | ) 118 | } 119 | 120 | # If subsecond resolution, change to correct second representation 121 | check_subsecond_period <- function(period_list) { 122 | 123 | multiplier <- switch(period_list$period, 124 | "millisec" = 1000, 125 | "microsec" = 1000000, 126 | 0 # Default for >subsecond periods so it returns 127 | ) 128 | 129 | if(!multiplier) return(period_list) 130 | 131 | period_list$freq <- period_list$freq / multiplier 132 | period_list$period <- "sec" 133 | 134 | period_list 135 | } 136 | -------------------------------------------------------------------------------- /man/collapse_index.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/collapse_index.R 3 | \name{collapse_index} 4 | \alias{collapse_index} 5 | \title{Collapse an index vector so that all observations in an interval share the 6 | same date} 7 | \usage{ 8 | collapse_index( 9 | index, 10 | period = "year", 11 | start_date = NULL, 12 | side = "end", 13 | clean = FALSE, 14 | ... 15 | ) 16 | } 17 | \arguments{ 18 | \item{index}{An index vector.} 19 | 20 | \item{period}{A character specification used for time-based grouping. The 21 | general format to use is \code{"frequency period"} where frequency is a number 22 | like 1 or 2, and period is an interval like weekly or yearly. There must be 23 | a space between the two. 24 | 25 | Note that you can pass the specification in a flexible way: 26 | \itemize{ 27 | \item 1 Year: \code{'1 year'} / \code{'1 Y'} 28 | } 29 | 30 | This shorthand is available for year, quarter, month, day, hour, minute, 31 | second, millisecond and microsecond periodicities. 32 | 33 | Additionally, you have the option of passing in a vector of dates to 34 | use as custom and more flexible boundaries.} 35 | 36 | \item{start_date}{Optional argument used to 37 | specify the start date for the 38 | first group. The default is to start at the closest period boundary 39 | below the minimum date in the supplied index.} 40 | 41 | \item{side}{Whether to return the date at the beginning or the end of 42 | the new period. By default, the "end" of the period. 43 | Use "start" to change to the start of the period.} 44 | 45 | \item{clean}{Whether or not to round the collapsed index up / down to the next 46 | period boundary. The decision to round up / down is controlled by the side 47 | argument.} 48 | 49 | \item{...}{Not currently used.} 50 | } 51 | \description{ 52 | When \code{collapse_index()} is used, the index vector is altered 53 | so that all dates that fall in a specified interval share a common date. 54 | The most common use case for this is to then group on the collapsed index. 55 | } 56 | \details{ 57 | The \code{\link[=collapse_by]{collapse_by()}} function provides a shortcut for the most common use 58 | of \code{collapse_index()}, calling the function inside a call to \code{mutate()} to 59 | modify the index directly. For more flexibility, like the nesting example 60 | below, use \code{collapse_index()}. 61 | 62 | Because this is often used for end of period summaries, the default is to 63 | use \code{side = "end"}. Note that this is the opposite of \code{\link[=as_period]{as_period()}} where 64 | the default is \code{side = "start"}. 65 | 66 | The \code{clean} argument is especially useful if you have an irregular series 67 | and want cleaner dates to report for summary values. 68 | } 69 | \examples{ 70 | 71 | # Basic functionality ------------------------------------------------------- 72 | 73 | # Facebook stock prices 74 | data(FB) 75 | FB <- as_tbl_time(FB, date) 76 | 77 | # Collapse to weekly dates 78 | dplyr::mutate(FB, date = collapse_index(date, "weekly")) 79 | 80 | # A common workflow is to group on the new date column 81 | # to perform a time based summary 82 | FB \%>\% 83 | dplyr::mutate(date = collapse_index(date, "year")) \%>\% 84 | dplyr::group_by(date) \%>\% 85 | dplyr::summarise_if(is.numeric, mean) 86 | 87 | # You can also assign the result to a separate column and use that 88 | # to nest on, allowing for 'period nests' that keep the 89 | # original dates in the nested tibbles. 90 | FB \%>\% 91 | dplyr::mutate(nest_date = collapse_index(date, "2 year")) \%>\% 92 | dplyr::group_by(nest_date) \%>\% 93 | tidyr::nest() 94 | 95 | # Grouped functionality ----------------------------------------------------- 96 | 97 | data(FANG) 98 | FANG <- FANG \%>\% 99 | as_tbl_time(date) \%>\% 100 | dplyr::group_by(symbol) 101 | 102 | # Collapse each group to monthly, 103 | # calculate monthly standard deviation for each column 104 | FANG \%>\% 105 | dplyr::mutate(date = collapse_index(date, "month")) \%>\% 106 | dplyr::group_by(symbol, date) \%>\% 107 | dplyr::summarise_all(sd) 108 | 109 | 110 | } 111 | -------------------------------------------------------------------------------- /vignettes/TT-04-use-with-dplyr.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Use with dplyr" 3 | author: "Davis Vaughan" 4 | date: "`r Sys.Date()`" 5 | output: 6 | rmarkdown::html_vignette: 7 | toc: true 8 | toc_depth: 3 9 | vignette: > 10 | %\VignetteIndexEntry{Use with dplyr} 11 | %\VignetteEngine{knitr::rmarkdown} 12 | %\VignetteEncoding{UTF-8} 13 | --- 14 | 15 | ## Package motivation 16 | 17 | `tibbletime` on its own has useful functions for manipulating time-based 18 | tibbles, but one of its most useful features is how nicely it plays with 19 | `dplyr`. Traditionally, performing grouped analysis over a time period with 20 | `dplyr` (like quarterly / monthly summaries) is doable, but it could be easier 21 | and typically requires use of the `lubridate` package along with the 22 | creation of multiple columns to group on. Below is an example of 23 | a monthly summary from a daily dataset. 24 | 25 | ```{r, warning=FALSE, message=FALSE} 26 | library(tibbletime) 27 | library(dplyr) 28 | library(lubridate) 29 | 30 | series <- create_series('2013' ~ '2017', 'day', class = "Date") %>% 31 | mutate(var = rnorm(n())) 32 | 33 | series 34 | 35 | series %>% 36 | mutate(year = year(date), month = month(date)) %>% 37 | group_by(year, month) %>% 38 | summarise(mean_var = mean(var)) 39 | ``` 40 | 41 | This gets more difficult the more granular you go. Getting 5-minute summaries 42 | from minute or second data requires grouping on year, month, day, hour and minute 43 | columns. 44 | 45 | ## Index manipulation 46 | 47 | With `tibbletime`, rather than creating new columns to group on, you 48 | manipulate your original date column into something that corresponds to 49 | the period you are summarising at. The `tibbletime` way to do this is with 50 | `collapse_by()`. 51 | 52 | ```{r} 53 | series %>% 54 | collapse_by("month") %>% 55 | group_by(date) %>% 56 | summarise(mean_var = mean(var)) 57 | ``` 58 | 59 | While `collapse_by()` directly manipulates the index column, the lower level `collapse_index()` 60 | function can be used inside of a call to `mutate()` to modify the index column 61 | and then save it as a new column. This can be useful if you don't want to lose 62 | the original index column. 63 | 64 | This works for more granular series too. Below we aggregate 5 second level data 65 | up to hourly. This is working with a faily sizable ~19 million row data set. 66 | 67 | ```{r} 68 | second_series <- create_series('2013' ~ '2015', '5 second') 69 | 70 | second_series %>% 71 | mutate(var = rnorm(n())) %>% 72 | collapse_by("hour") %>% 73 | group_by(date) %>% 74 | summarise(mean_var = mean(var)) 75 | ``` 76 | 77 | ## Multiple series 78 | 79 | One really powerful benefit of working in the `tidyverse` is being able to 80 | manipulate multiple series at once. Essentially we can create multiple layers 81 | of groupings, one for the stocks we are working with (like Facebook and Apple), 82 | and one for the period you want to summarise your data at (daily, yearly, etc). 83 | 84 | Below we use `create_series()` to create two dummy hourly price series, combine them, 85 | and calculate the OHLC (Open, High, Low, Close) prices per day by first collapsing 86 | to daily with `collapse_by()` to have something to group on. 87 | 88 | ```{r} 89 | set.seed(123) 90 | 91 | # Create price series of hourly movements for apple and facebook stock. 92 | apple <- create_series('2014' ~ '2016', period = '1 hour') %>% 93 | mutate(price = 100 + cumsum(rnorm(n(), mean = 0, sd = .5))) 94 | 95 | facebook <- create_series('2014' ~ '2016', period = '1 hour') %>% 96 | mutate(price = 150 + cumsum(rnorm(n(), mean = 0, sd = .5))) 97 | 98 | # Bind them together and create a symbol column to group on 99 | price_series <- bind_rows(list(apple = apple, facebook = facebook), .id = "symbol") %>% 100 | as_tbl_time(date) %>% 101 | group_by(symbol) 102 | 103 | # Collapse to daily and transform to OHLC (Open, High, Low, Close), a 104 | # common financial transformation 105 | price_series %>% 106 | collapse_by("day") %>% 107 | group_by(symbol, date) %>% 108 | summarise( 109 | open = first(price), 110 | high = max(price), 111 | low = min(price), 112 | close = last(price) 113 | ) %>% 114 | slice(1:5) 115 | ``` 116 | 117 | 118 | -------------------------------------------------------------------------------- /R/create_series.R: -------------------------------------------------------------------------------- 1 | #' Create a `tbl_time` object with a sequence of regularly spaced dates 2 | #' 3 | #' [create_series()] allows the user to quickly create a `tbl_time` object with 4 | #' a `date` column populated with a sequence of dates. 5 | #' 6 | #' @inheritParams partition_index 7 | #' @param time_formula A period to create the series over. 8 | #' This is specified as a formula. 9 | #' See the `Details` section of [filter_time()] for more information. 10 | #' @param include_end Whether to always include the RHS of the `time_formula` 11 | #' even if it does not match the regularly spaced index. 12 | #' @param tz Time zone of the new series. 13 | #' @param class One of `"Date"`, `"POSIXct"`, `"hms"`, `"yearmon"`, `"yearqtr"`. 14 | #' The default is `"POSIXct"`. 15 | #' @param as_vector Should the series be returned as a vector instead of 16 | #' a tibble? 17 | #' 18 | #' @examples 19 | #' 20 | #' # Every day in 2013 21 | #' create_series(~'2013', 'day') 22 | #' 23 | #' # Every other day in 2013 24 | #' create_series(~'2013', '2 d') 25 | #' 26 | #' # Every quarter in 2013 27 | #' create_series(~'2013', '1 q') 28 | #' 29 | #' # Daily series for 2013-2015 30 | #' create_series('2013' ~ '2015', '1 d') 31 | #' 32 | #' # Minute series for 2 months 33 | #' create_series('2012-01' ~ '2012-02', 'M') 34 | #' 35 | #' # Second series for 2 minutes 36 | #' create_series('2011-01-01 12:10:00' ~ '2011-01-01 12:12:00', 's') 37 | #' 38 | #' # Date class 39 | #' create_series(~'2013', 'day', class = "Date") 40 | #' 41 | #' # yearmon class 42 | #' create_series(~'2013', 'month', class = "yearmon") 43 | #' 44 | #' # hms class. time_formula specified as HH:MM:SS here 45 | #' create_series('00:00:00' ~ '12:00:00', 'second' , class = "hms") 46 | #' 47 | #' # Subsecond series 48 | #' create_series('2013' ~ '2013-01-01 00:00:01', period = "10 millisec") 49 | #' milli <- create_series('2013' ~ '2013-01-01 00:00:01', period = ".1 sec") 50 | #' # Check that 'milli' is correct by running: 51 | #' # options("digits.secs" = 4) 52 | #' # options("digits" = 18) 53 | #' # milli$date 54 | #' # as.numeric(milli$date) 55 | #' 56 | #' 57 | #' @export 58 | create_series <- function(time_formula, period = "day", 59 | class = "POSIXct", include_end = FALSE, 60 | tz = "UTC", as_vector = FALSE) { 61 | 62 | period_list <- parse_period(period) 63 | 64 | # Generic validation based on the class 65 | dummy_index <- make_dummy_dispatch_obj(class) 66 | assert_allowed_datetime(dummy_index) 67 | assert_period_matches_index_class(dummy_index, period_list$period) 68 | 69 | # Get seq_* functions 70 | seq_fun <- lookup_seq_fun(dummy_index) 71 | 72 | # Parse the time_formula, don't convert to dates yet 73 | tf_list <- parse_time_formula(dummy_index, time_formula) 74 | 75 | #### Could allow for multifilter idea here, but instead applied to series 76 | 77 | # Then convert to datetime 78 | from_to <- purrr::map(tf_list, ~list_to_datetime(dummy_index, .x, tz = tz)) 79 | 80 | # Get sequence creation pieces ready 81 | from <- from_to[[1]] 82 | to <- from_to[[2]] 83 | by <- create_by(period_list) 84 | 85 | # Final assertion of order 86 | assert_from_before_to(from, to) 87 | 88 | # Create the sequence 89 | date_seq <- seq_fun(from, to, by = by) 90 | 91 | # Add the end date if required 92 | if(include_end) { 93 | if(max(date_seq) < to) { 94 | date_seq <- push_datetime(date_seq, to) 95 | } 96 | } 97 | 98 | # Convert to tbl_time 99 | if(as_vector) { 100 | date_seq 101 | } else { 102 | as_tbl_time(tibble::tibble(date = date_seq), date) 103 | } 104 | 105 | } 106 | 107 | #### Utils --------------------------------------------------------------------- 108 | 109 | assert_allowed_datetime <- function(x) { 110 | assertthat::assert_that( 111 | inherits_allowed_datetime(x), 112 | msg = glue::glue("Specified class, '{class(x)}', ", 113 | "is not one of the allowed time-based classes") 114 | ) 115 | } 116 | 117 | assert_from_before_to <- function(from, to) { 118 | from_num <- to_posixct_numeric(from) 119 | to_num <- to_posixct_numeric(to) 120 | 121 | assertthat::assert_that( 122 | from_num <= to_num, 123 | msg = glue::glue("Incorrect expanded time_formula. ", 124 | "`from`, {from}, must be before `to`, {to}") 125 | ) 126 | } 127 | 128 | create_by <- function(period_list) { 129 | by <- paste(period_list$freq, period_list$period) 130 | by <- check_fractional_seconds(by, period_list) 131 | by 132 | } 133 | 134 | check_fractional_seconds <- function(by, period_list) { 135 | # For fractional seconds, the `by` argument must be numeric, not character 136 | if(period_list$freq < 1 && period_list$period == "sec") { 137 | by <- period_list$freq 138 | } 139 | by 140 | } 141 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method("[",tbl_time) 4 | S3method(anti_join,tbl_time) 5 | S3method(arrange,tbl_time) 6 | S3method(arrange_,tbl_time) 7 | S3method(as_period,default) 8 | S3method(as_period,tbl_time) 9 | S3method(as_tbl_time,default) 10 | S3method(as_tbl_time,tbl_df) 11 | S3method(as_tibble,tbl_time) 12 | S3method(assert_period_matches_index_class,Date) 13 | S3method(assert_period_matches_index_class,POSIXct) 14 | S3method(assert_period_matches_index_class,default) 15 | S3method(assert_period_matches_index_class,hms) 16 | S3method(assert_period_matches_index_class,yearmon) 17 | S3method(assert_period_matches_index_class,yearqtr) 18 | S3method(ceiling_index,default) 19 | S3method(ceiling_index,hms) 20 | S3method(ceiling_index,yearmon) 21 | S3method(ceiling_index,yearqtr) 22 | S3method(coerce_start_date,Date) 23 | S3method(coerce_start_date,POSIXct) 24 | S3method(coerce_start_date,hms) 25 | S3method(coerce_start_date,yearmon) 26 | S3method(coerce_start_date,yearqtr) 27 | S3method(dispatch_to_datetime,Date) 28 | S3method(dispatch_to_datetime,default) 29 | S3method(dispatch_to_datetime,hms) 30 | S3method(dispatch_to_datetime,yearmon) 31 | S3method(dispatch_to_datetime,yearqtr) 32 | S3method(distinct,tbl_time) 33 | S3method(filter,tbl_time) 34 | S3method(filter_time,default) 35 | S3method(filter_time,tbl_time) 36 | S3method(floor_index,default) 37 | S3method(floor_index,hms) 38 | S3method(floor_index,yearmon) 39 | S3method(floor_index,yearqtr) 40 | S3method(full_join,tbl_time) 41 | S3method(group_by,tbl_time) 42 | S3method(inner_join,tbl_time) 43 | S3method(left_join,tbl_time) 44 | S3method(list_to_datetime,Date) 45 | S3method(list_to_datetime,POSIXct) 46 | S3method(list_to_datetime,hms) 47 | S3method(list_to_datetime,yearmon) 48 | S3method(list_to_datetime,yearqtr) 49 | S3method(lookup_defaults,Date) 50 | S3method(lookup_defaults,POSIXct) 51 | S3method(lookup_defaults,hms) 52 | S3method(lookup_defaults,yearmon) 53 | S3method(lookup_defaults,yearqtr) 54 | S3method(lookup_seq_fun,Date) 55 | S3method(lookup_seq_fun,POSIXct) 56 | S3method(lookup_seq_fun,hms) 57 | S3method(lookup_seq_fun,yearmon) 58 | S3method(lookup_seq_fun,yearqtr) 59 | S3method(mutate,tbl_time) 60 | S3method(mutate_,tbl_time) 61 | S3method(parse_period,character) 62 | S3method(parse_period,default) 63 | S3method(push_datetime,default) 64 | S3method(push_datetime,hms) 65 | S3method(reconstruct,tbl_time) 66 | S3method(right_join,tbl_time) 67 | S3method(select,tbl_time) 68 | S3method(semi_join,tbl_time) 69 | S3method(seq,hms) 70 | S3method(seq,yearmon) 71 | S3method(seq,yearqtr) 72 | S3method(slice,tbl_time) 73 | S3method(slice_,tbl_time) 74 | S3method(split_to_list,Date) 75 | S3method(split_to_list,POSIXct) 76 | S3method(split_to_list,character) 77 | S3method(split_to_list,default) 78 | S3method(split_to_list,hms) 79 | S3method(split_to_list,yearmon) 80 | S3method(split_to_list,yearqtr) 81 | S3method(summarise,tbl_time) 82 | S3method(summarise_,tbl_time) 83 | S3method(summarize_,tbl_time) 84 | S3method(tbl_sum,tbl_time) 85 | S3method(to_posixct_numeric,Date) 86 | S3method(to_posixct_numeric,POSIXct) 87 | S3method(to_posixct_numeric,default) 88 | S3method(to_posixct_numeric,hms) 89 | S3method(to_posixct_numeric,yearmon) 90 | S3method(to_posixct_numeric,yearqtr) 91 | S3method(transmute,tbl_time) 92 | S3method(ungroup,tbl_time) 93 | export("%>%") 94 | export(as_period) 95 | export(as_tbl_time) 96 | export(ceiling_index) 97 | export(collapse_by) 98 | export(collapse_index) 99 | export(create_series) 100 | export(filter) 101 | export(filter_time) 102 | export(floor_index) 103 | export(get_index_char) 104 | export(get_index_class) 105 | export(get_index_col) 106 | export(get_index_quo) 107 | export(get_index_time_zone) 108 | export(new_tbl_time) 109 | export(parse_period) 110 | export(partition_index) 111 | export(reconstruct) 112 | export(rollify) 113 | export(tbl_time) 114 | importFrom(Rcpp,sourceCpp) 115 | importFrom(dplyr,"%>%") 116 | importFrom(dplyr,anti_join) 117 | importFrom(dplyr,arrange) 118 | importFrom(dplyr,arrange_) 119 | importFrom(dplyr,distinct) 120 | importFrom(dplyr,filter) 121 | importFrom(dplyr,full_join) 122 | importFrom(dplyr,group_by) 123 | importFrom(dplyr,inner_join) 124 | importFrom(dplyr,left_join) 125 | importFrom(dplyr,mutate) 126 | importFrom(dplyr,mutate_) 127 | importFrom(dplyr,right_join) 128 | importFrom(dplyr,select) 129 | importFrom(dplyr,semi_join) 130 | importFrom(dplyr,slice) 131 | importFrom(dplyr,slice_) 132 | importFrom(dplyr,summarise) 133 | importFrom(dplyr,summarise_) 134 | importFrom(dplyr,summarize_) 135 | importFrom(dplyr,transmute) 136 | importFrom(dplyr,ungroup) 137 | importFrom(lifecycle,deprecated) 138 | importFrom(pillar,tbl_sum) 139 | importFrom(rlang,"%||%") 140 | importFrom(rlang,":=") 141 | importFrom(rlang,.data) 142 | importFrom(tibble,as_tibble) 143 | useDynLib(tibbletime, .registration = TRUE) 144 | -------------------------------------------------------------------------------- /man/filter_time.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/filter_time.R 3 | \name{filter_time} 4 | \alias{filter_time} 5 | \alias{[.tbl_time} 6 | \title{Succinctly filter a \code{tbl_time} object by its index} 7 | \usage{ 8 | filter_time(.tbl_time, time_formula) 9 | 10 | \method{[}{tbl_time}(x, i, j, drop = FALSE) 11 | } 12 | \arguments{ 13 | \item{.tbl_time}{A \code{tbl_time} object.} 14 | 15 | \item{time_formula}{A period to filter over. 16 | This is specified as a \code{formula}. See \code{Details}.} 17 | 18 | \item{x}{Same as \code{.tbl_time} but consistent naming with base R.} 19 | 20 | \item{i}{A period to filter over. This is specified the same as 21 | \code{time_formula} or can use the traditional row extraction method.} 22 | 23 | \item{j}{Optional argument to also specify column index to subset. Works 24 | exactly like the normal extraction operator.} 25 | 26 | \item{drop}{Will always be coerced to \code{FALSE} by \code{tibble}.} 27 | } 28 | \description{ 29 | Use a concise filtering method to filter a \code{tbl_time} object by its \code{index}. 30 | } 31 | \details{ 32 | The \code{time_formula} is specified using the format \code{from ~ to}. 33 | Each side of the \code{time_formula} is specified as the character 34 | \code{'YYYY-MM-DD HH:MM:SS'}, but powerful shorthand is available. 35 | Some examples are: 36 | \itemize{ 37 | \item \strong{Year:} \code{'2013' ~ '2015'} 38 | \item \strong{Month:} \code{'2013-01' ~ '2016-06'} 39 | \item \strong{Day:} \code{'2013-01-05' ~ '2016-06-04'} 40 | \item \strong{Second:} \code{'2013-01-05 10:22:15' ~ '2018-06-03 12:14:22'} 41 | \item \strong{Variations:} \code{'2013' ~ '2016-06'} 42 | } 43 | 44 | The \code{time_formula} can also use a one sided formula. 45 | \itemize{ 46 | \item \strong{Only dates in 2015:} \code{~'2015'} 47 | \item \strong{Only dates March 2015:} \code{~'2015-03'} 48 | } 49 | 50 | The \code{time_formula} can also use \code{'start'} and \code{'end'} as keywords for 51 | your filter. 52 | \itemize{ 53 | \item \strong{Start of the series to end of 2015:} \code{'start' ~ '2015'} 54 | \item \strong{Start of 2014 to end of series:} \code{'2014' ~ 'end'} 55 | } 56 | 57 | All shorthand dates are expanded: 58 | \itemize{ 59 | \item The \code{from} side is expanded to be the first date in that period 60 | \item The \code{to} side is expanded to be the last date in that period 61 | } 62 | 63 | This means that the following examples are equivalent (assuming your 64 | index is a POSIXct): 65 | \itemize{ 66 | \item \code{'2015' ~ '2016' == '2015-01-01 + 00:00:00' ~ '2016-12-31 + 23:59:59'} 67 | \item \code{~'2015' == '2015-01-01 + 00:00:00' ~ '2015-12-31 + 23:59:59'} 68 | \item \code{'2015-01-04 + 10:12' ~ '2015-01-05' == '2015-01-04 + 10:12:00' ~ '2015-01-05 + 23:59:59'} 69 | } 70 | 71 | Special parsing is done for indices of class \code{hms}. The \code{from ~ to} time 72 | formula is specified as only \code{HH:MM:SS}. 73 | \itemize{ 74 | \item \strong{Start to 5th second of the 12th hour:} \code{'start' ~ '12:00:05'} 75 | \item \strong{Every second in the 12th hour:} \code{~'12'} 76 | } 77 | 78 | Subsecond resolution is also supported, however, R has a unique way of 79 | handling and printing subsecond dates and the user should be comfortable with 80 | this already. Specify subsecond resolution like so: 81 | \code{'2013-01-01 00:00:00.1' ~ '2013-01-01 00:00:00.2'}. Note that one sided 82 | expansion does not work with subsecond resolution due to seconds and subseconds 83 | being grouped together into 1 number (i.e. 1.2 seconds). This means \code{~'2013-01-01 00:00:00'} does 84 | not expand to something like \code{'2013-01-01 00:00:00.00' ~ '2013-01-01 00:00:00.99'}, 85 | but only expands to include whole seconds. 86 | 87 | This function respects \code{\link[dplyr:group_by]{dplyr::group_by()}} groups. 88 | } 89 | \examples{ 90 | 91 | # FANG contains Facebook, Amazon, Netflix and Google stock prices 92 | data(FANG) 93 | FANG <- as_tbl_time(FANG, date) \%>\% 94 | dplyr::group_by(symbol) 95 | 96 | # 2013-01-01 to 2014-12-31 97 | filter_time(FANG, '2013' ~ '2014') 98 | 99 | # 2013-05-25 to 2014-06-04 100 | filter_time(FANG, '2013-05-25' ~ '2014-06-04') 101 | 102 | # Using the `[` subset operator 103 | FANG['2014'~'2015'] 104 | 105 | # Using `[` and one sided formula for only dates in 2014 106 | FANG[~'2014'] 107 | 108 | # Using `[` and column selection 109 | FANG['2013'~'2016', c("date", "adjusted")] 110 | 111 | # Variables are unquoted using rlang 112 | lhs_date <- "2013" 113 | rhs_date <- as.Date("2014-01-01") 114 | filter_time(FANG, lhs_date ~ rhs_date) 115 | 116 | # Use the keywords 'start' and 'end' to conveniently access ends 117 | filter_time(FANG, 'start' ~ '2014') 118 | 119 | # hms (hour, minute, second) classes have special parsing 120 | hms_example <- create_series(~'12:01', 'second', class = 'hms') 121 | filter_time(hms_example, 'start' ~ '12:01:30') 122 | 123 | 124 | } 125 | -------------------------------------------------------------------------------- /vignettes/TT-01-time-based-filtering.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Time-based filtering" 3 | author: "Davis Vaughan" 4 | date: "`r Sys.Date()`" 5 | output: 6 | rmarkdown::html_vignette: 7 | toc: true 8 | toc_depth: 3 9 | vignette: > 10 | %\VignetteIndexEntry{Time-based filtering} 11 | %\VignetteEngine{knitr::rmarkdown} 12 | %\VignetteEncoding{UTF-8} 13 | --- 14 | 15 | # Introducing filter_time() 16 | 17 | `filter_time()` attempts to make filtering data frames by date much easier 18 | than `dplyr::filter()`. It includes a flexible shorthand notation that allows 19 | you to specify entire date ranges with very little typing. The general form 20 | of the `time_formula` that you will use to filter rows is `from ~ to`, where 21 | the left hand side (LHS) is the character start date, and the right hand side (RHS) is 22 | the character end date. Both endpoints are included in the result. 23 | Each side of the `time_formula` can be maximally specified as 24 | the character `'YYYY-MM-DD HH:MM:SS'`. 25 | 26 | ## Datasets required 27 | 28 | ```{r, message=FALSE, warning=FALSE} 29 | library(tibbletime) 30 | library(dplyr) 31 | 32 | # Facebook stock prices. 33 | data(FB) 34 | 35 | # Convert FB to tbl_time 36 | FB <- as_tbl_time(FB, index = date) 37 | 38 | # FANG stock prices 39 | data(FANG) 40 | 41 | # Convert FANG to tbl_time and group 42 | FANG <- as_tbl_time(FANG, index = date) %>% 43 | group_by(symbol) 44 | 45 | ``` 46 | 47 | ## Year filtering example 48 | 49 | In `dplyr`, if you wanted to get the dates for `2013` in the `FB` dataset, you 50 | might do something like this: 51 | 52 | ```{r} 53 | filter(FB, date >= as.Date("2013-01-01"), date <= as.Date("2013-12-31")) 54 | ``` 55 | 56 | That's a lot of typing for one filter step. With `tibbletime`, because 57 | the `index` was specified at creation, we can do this: 58 | 59 | ```{r} 60 | filter_time(FB, time_formula = '2013-01-01' ~ '2013-12-31') 61 | ``` 62 | 63 | At first glance, this might not look like less code, but this is before any 64 | shorthand is applied. Note how the filtering condition is specified as a 65 | `formula` separated by a `~`. 66 | 67 | Using `filter_time` shorthand, this can be written: 68 | 69 | ```{r} 70 | filter_time(FB, '2013' ~ '2013') 71 | ``` 72 | 73 | Or even more succinctly as: 74 | 75 | ```{r} 76 | filter_time(FB, ~'2013') 77 | ``` 78 | 79 | The shorthand notation works as follows. In the first example, `'2013' ~ '2013'` is 80 | expanded to `'2013-01-01 + 00:00:00' ~ '2013-12-31 + 23:59:59'`. It works by 81 | identifying the periodicity of the provided input (yearly), and expanding it 82 | to the beginning and end of that period. The one sided formula `~'2013'` works 83 | similarly, and is useful when you want to select every date inside a period. 84 | 85 | ## Month filtering example 86 | 87 | As another example of this shorthand, if you wanted to select every date in 88 | March, 2015: 89 | 90 | ```{r} 91 | filter_time(FB, ~'2015-03') 92 | 93 | # In dplyr it looks like this 94 | # (and you have to think, does March have 30 or 31 days?) 95 | # filter(FB, date >= as.Date("2015-03-01"), date <= as.Date("2015-03-31")) 96 | ``` 97 | 98 | ## Keywords 99 | 100 | Two keywords are available to assist with filtering: 101 | 102 | * `'start'` - The start of the series 103 | * `'end'` - The end of the series 104 | 105 | This filters from the start of the series to the end of 2015. 106 | 107 | ```{r} 108 | filter_time(FB, 'start' ~ '2015') 109 | ``` 110 | 111 | 112 | ## Grouped example 113 | 114 | Working with grouped `tbl_time` objects is just as you might expect. 115 | 116 | ```{r} 117 | FANG %>% 118 | filter_time('2013-01-01' ~ '2013-01-04') 119 | ``` 120 | 121 | ## Finer periods 122 | 123 | Filtering can also be done by hour / minute / second. Note that the form of this 124 | is slightly different than the standard, `'YYYY-MM-DD HH:MM:SS'`. 125 | 126 | ```{r} 127 | # Dummy example. Every second in a day 128 | example <- create_series(~'2013-01-01', period = 's') 129 | 130 | # The first 2 minutes of the day 131 | example %>% 132 | filter_time('2013-01-01' ~ '2013-01-01 00:02') 133 | 134 | # 3 specific hours of the day 135 | # Equivalent to: 136 | # '2013-01-01 + 03:00:00' ~ '2013-01-01 + 06:59:59' 137 | example %>% 138 | filter_time('2013-01-01 3' ~ '2013-01-01 6') 139 | ``` 140 | 141 | ## `[` syntax 142 | 143 | For interactive use, to get an even quicker look at a dataset you can use 144 | the traditional extraction operator `[` with the formula syntax. 145 | 146 | ```{r} 147 | FB[~'2013'] 148 | ``` 149 | 150 | ```{r} 151 | FB['2013'~'2014-02', c(1,2,3)] 152 | ``` 153 | 154 | ## Using variables in the filter 155 | 156 | Each side of the time formula is unquoted and evaluated in the environment 157 | that is was created using `rlang`. This means that you can use variables inside 158 | the call the `filter_time()`. 159 | 160 | ```{r} 161 | date_var <- as.Date("2014-01-01") 162 | filter_time(FB, 'start' ~ date_var) 163 | 164 | date_char <- "2014-02" 165 | filter_time(FB, ~ date_char) 166 | ``` 167 | 168 | -------------------------------------------------------------------------------- /man/as_period.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/as_period.R 3 | \name{as_period} 4 | \alias{as_period} 5 | \title{Change \code{tbl_time} periodicity} 6 | \usage{ 7 | as_period( 8 | .tbl_time, 9 | period = "year", 10 | start_date = NULL, 11 | side = "start", 12 | include_endpoints = FALSE, 13 | ... 14 | ) 15 | } 16 | \arguments{ 17 | \item{.tbl_time}{A \code{tbl_time} object.} 18 | 19 | \item{period}{A character specification used for time-based grouping. The 20 | general format to use is \code{"frequency period"} where frequency is a number 21 | like 1 or 2, and period is an interval like weekly or yearly. There must be 22 | a space between the two. 23 | 24 | Note that you can pass the specification in a flexible way: 25 | \itemize{ 26 | \item 1 Year: \code{'1 year'} / \code{'1 Y'} 27 | } 28 | 29 | This shorthand is available for year, quarter, month, day, hour, minute, 30 | second, millisecond and microsecond periodicities. 31 | 32 | Additionally, you have the option of passing in a vector of dates to 33 | use as custom and more flexible boundaries.} 34 | 35 | \item{start_date}{Optional argument used to 36 | specify the start date for the 37 | first group. The default is to start at the closest period boundary 38 | below the minimum date in the supplied index.} 39 | 40 | \item{side}{Whether to return the date at the beginning or the end of the 41 | new period. By default, the \code{"start"} of the period. Use \code{"end"} to change 42 | to the end of the period.} 43 | 44 | \item{include_endpoints}{Whether to include the first or last data point in 45 | addition to the transformed data.} 46 | 47 | \item{...}{Not currently used.} 48 | } 49 | \description{ 50 | Convert a \code{tbl_time} object from daily to monthly, 51 | from minute data to hourly, and more. This allows the user to easily 52 | aggregate data to a less granular level by taking the value from either 53 | the beginning or end of the period. 54 | } 55 | \details{ 56 | This function respects \code{\link[dplyr:group_by]{dplyr::group_by()}} groups. 57 | 58 | The \code{side} argument is useful when you want to return data at, say, the 59 | end of a quarter, or the end of a month. 60 | 61 | \code{include_endpoints} can be useful when calculating a change over time. 62 | In addition to changing to monthly dates, you often need the first data point 63 | as a baseline for the first calculation. 64 | } 65 | \examples{ 66 | 67 | # Basic usage --------------------------------------------------------------- 68 | 69 | # FB stock prices 70 | data(FB) 71 | FB <- as_tbl_time(FB, date) 72 | 73 | # Aggregate FB to yearly data 74 | as_period(FB, "year") 75 | 76 | # Aggregate FB to every 2 years 77 | as_period(FB, "2 years") 78 | 79 | # Aggregate FB to yearly data, but use the last data point available 80 | # in that period 81 | as_period(FB, "year", side = "end") 82 | 83 | # Aggregate FB to yearly data, end of period, and include the first 84 | # endpoint 85 | as_period(FB, "year", side = "end", include_endpoints = TRUE) 86 | 87 | # Aggregate to weekly. Notice that it only uses the earliest day available 88 | # in the data set at that periodicity. It will not set the date of the first 89 | # row to 2013-01-01 because that date did not exist in the original data set. 90 | as_period(FB, "weekly") 91 | 92 | # FB is daily data, aggregate to minute? 93 | # Not allowed for Date class indices, an error is thrown 94 | # as_period(FB, "minute") 95 | 96 | # Grouped usage ------------------------------------------------------------- 97 | 98 | # FANG contains Facebook, Amazon, Netflix and Google stock prices 99 | data(FANG) 100 | FANG <- as_tbl_time(FANG, date) 101 | 102 | FANG <- dplyr::group_by(FANG, symbol) 103 | 104 | # Respects groups 105 | as_period(FANG, "year") 106 | 107 | # Every 6 months, respecting groups 108 | as_period(FANG, "6 months") 109 | 110 | # Using start_date ---------------------------------------------------------- 111 | 112 | 113 | #### One method using start_date 114 | 115 | # FB stock prices 116 | data(FB) 117 | FB <- as_tbl_time(FB, date) 118 | 119 | # The Facebook series starts at 2013-01-02 so the 'every 2 day' counter 120 | # starts at that date as well. Groups become (2013-01-02, 2013-01-03), 121 | # (2013-01-04, 2013-01-05) and so on. 122 | as_period(FB, "2 day") 123 | 124 | # Specifying the `start_date = "2013-01-01"` might be preferable. 125 | # Groups become (2013-01-01, 2013-01-02), (2013-01-03, 2013-01-04) and so on. 126 | as_period(FB, "2 day", start_date = "2013-01-01") 127 | 128 | #### Equivalent method using an index vector 129 | 130 | # FB stock prices 131 | data(FB) 132 | FB <- as_tbl_time(FB, date) 133 | 134 | custom_period <- create_series( 135 | time_formula = dplyr::first(FB$date) - 1 ~ dplyr::last(FB$date), 136 | period = "2 day", 137 | class = "Date", 138 | as_vector = TRUE) 139 | 140 | FB \%>\% 141 | as_tbl_time(date) \%>\% 142 | as_period(period = custom_period) 143 | 144 | # Manually calculating returns at different periods ------------------------- 145 | 146 | data(FB) 147 | 148 | # Annual Returns 149 | # Convert to end of year periodicity, but include the endpoints to use as 150 | # a reference for the first return calculation. Then calculate returns. 151 | FB \%>\% 152 | as_tbl_time(date) \%>\% 153 | as_period("1 y", side = "end", include_endpoints = TRUE) \%>\% 154 | dplyr::mutate(yearly_return = adjusted / dplyr::lag(adjusted) - 1) 155 | 156 | } 157 | -------------------------------------------------------------------------------- /man/rollify.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/rollify.R 3 | \name{rollify} 4 | \alias{rollify} 5 | \title{Create a rolling version of any function} 6 | \usage{ 7 | rollify(.f, window = 1, unlist = TRUE, na_value = NULL) 8 | } 9 | \arguments{ 10 | \item{.f}{A function to modify, specified in one of the following ways: 11 | \itemize{ 12 | \item A named function, e.g. \code{mean}. 13 | \item An anonymous function, e.g. \verb{\\(x) x + 1} or \code{function(x) x + 1}. 14 | \item A formula, e.g. \code{~ .x + 1}. Only recommended if you require backward 15 | compatibility with older versions of R. 16 | }} 17 | 18 | \item{window}{The window size to roll over} 19 | 20 | \item{unlist}{If the function returns a single value each time it is called, 21 | use \code{unlist = TRUE}. If the function returns more than one value, or a more 22 | complicated object (like a linear model), use \code{unlist = FALSE} to create 23 | a list-column of the rolling results.} 24 | 25 | \item{na_value}{A default value for the \code{NA} values at the beginning of the 26 | roll.} 27 | } 28 | \description{ 29 | \code{rollify} returns a rolling version of the input function, with a 30 | rolling \code{window} specified by the user. 31 | } 32 | \details{ 33 | The intended use of \code{rollify} is to turn a function into a rolling version 34 | of itself for use inside of a call to \code{\link[dplyr:mutate]{dplyr::mutate()}}, however it works 35 | equally as well when called from \code{\link[purrr:map]{purrr::map()}}. 36 | 37 | Because of it's intended use with \code{\link[dplyr:mutate]{dplyr::mutate()}}, \code{rollify} 38 | creates a function that always returns output with the same length of the 39 | input, aligned right, and filled with \code{NA} unless otherwise specified 40 | by \code{na_value}. 41 | 42 | The form of the \code{.f} argument is the same as the form that can be passed 43 | to \code{\link[purrr:map]{purrr::map()}}. Use \code{.x} or \code{.} to refer to the first object to roll over, 44 | and \code{.y} to refer to the second object if required. The examples explain this 45 | further. 46 | 47 | If optional arguments to the function are required, specify them in the 48 | call to \code{rollify}, and not in the call to the rolling version of the 49 | function. See the examples for more details. 50 | } 51 | \examples{ 52 | 53 | # Rolling mean -------------------------------------------------------------- 54 | 55 | data(FB) 56 | 57 | # Turn the normal mean function into a rolling mean with a 5 row window 58 | mean_roll_5 <- rollify(mean, window = 5) 59 | 60 | dplyr::mutate(FB, 61 | normal_mean = mean(adjusted), 62 | rolling_mean = mean_roll_5(adjusted)) 63 | 64 | # There's nothing stopping you from combining multiple rolling functions with 65 | # different window sizes in the same mutate call 66 | mean_roll_10 <- rollify(mean, window = 10) 67 | 68 | dplyr::mutate(FB, 69 | rolling_mean_5 = mean_roll_5(adjusted), 70 | rolling_mean_10 = mean_roll_10(adjusted)) 71 | 72 | # Functions with multiple args and optional args ---------------------------- 73 | 74 | # With 2 args, use the purrr syntax of ~ and .x, .y 75 | # Rolling correlation example 76 | cor_roll <- rollify(~cor(.x, .y), window = 5) 77 | 78 | dplyr::mutate(FB, running_cor = cor_roll(adjusted, open)) 79 | 80 | # With >2 args, create an anonymous function with >2 args or use 81 | # the purrr convention of ..1, ..2, ..3 to refer to the arguments 82 | avg_of_avgs <- rollify(function(x, y, z) { 83 | (mean(x) + mean(y) + mean(z)) / 3 84 | }, 85 | window = 10) 86 | 87 | # Or 88 | avg_of_avgs <- rollify(~(mean(..1) + mean(..2) + mean(..3)) / 3, 89 | window = 10) 90 | 91 | dplyr::mutate(FB, avg_of_avgs = avg_of_avgs(open, high, low)) 92 | 93 | # Optional arguments MUST be passed at the creation of the rolling function 94 | # Only data arguments that are "rolled over" are allowed when calling the 95 | # rolling version of the function 96 | FB$adjusted[1] <- NA 97 | 98 | roll_mean_na_rm <- rollify(~mean(.x, na.rm = TRUE), window = 5) 99 | 100 | dplyr::mutate(FB, roll_mean = roll_mean_na_rm(adjusted)) 101 | 102 | # Returning multiple values ------------------------------------------------- 103 | 104 | data(FB) 105 | 106 | summary2 <- function(x) { 107 | unclass(summary(x)) 108 | } 109 | 110 | # If the function returns >1 value, set the `unlist = FALSE` argument 111 | # Running 5 number summary 112 | summary_roll <- rollify(summary2, window = 5, unlist = FALSE) 113 | 114 | FB_summarised <- dplyr::mutate(FB, summary_roll = summary_roll(adjusted)) 115 | FB_summarised$summary_roll[[5]] 116 | 117 | # dplyr::bind_rows() is often helpful in these cases to get 118 | # meaningful output 119 | 120 | summary_roll <- rollify(~dplyr::bind_rows(summary2(.)), window = 5, unlist = FALSE) 121 | FB_summarised <- dplyr::mutate(FB, summary_roll = summary_roll(adjusted)) 122 | FB_summarised \%>\% 123 | dplyr::filter(!is.na(summary_roll)) \%>\% 124 | tidyr::unnest(summary_roll) 125 | 126 | # Rolling regressions ------------------------------------------------------- 127 | 128 | # Extending an example from R 4 Data Science on "Many Models". 129 | # For each country in the gapminder data, calculate a linear regression 130 | # every 5 periods of lifeExp ~ year 131 | library(gapminder) 132 | 133 | # Rolling regressions are easy to implement 134 | lm_roll <- rollify(~lm(.x ~ .y), window = 5, unlist = FALSE) 135 | 136 | gapminder \%>\% 137 | dplyr::group_by(country) \%>\% 138 | dplyr::mutate(rolling_lm = lm_roll(lifeExp, year)) 139 | 140 | # Rolling with groups ------------------------------------------------------- 141 | 142 | # One of the most powerful things about this is that it works with 143 | # groups since `mutate` is being used 144 | data(FANG) 145 | FANG <- FANG \%>\% 146 | dplyr::group_by(symbol) 147 | 148 | mean_roll_3 <- rollify(mean, window = 3) 149 | 150 | FANG \%>\% 151 | dplyr::mutate(mean_roll = mean_roll_3(adjusted)) \%>\% 152 | dplyr::slice(1:5) 153 | 154 | } 155 | \seealso{ 156 | \link[purrr:safely]{purrr::safely}, \link[purrr:possibly]{purrr::possibly} 157 | } 158 | -------------------------------------------------------------------------------- /R/as_period.R: -------------------------------------------------------------------------------- 1 | #' Change `tbl_time` periodicity 2 | #' 3 | #' Convert a `tbl_time` object from daily to monthly, 4 | #' from minute data to hourly, and more. This allows the user to easily 5 | #' aggregate data to a less granular level by taking the value from either 6 | #' the beginning or end of the period. 7 | #' 8 | #' @inheritParams partition_index 9 | #' @param .tbl_time A `tbl_time` object. 10 | #' @param side Whether to return the date at the beginning or the end of the 11 | #' new period. By default, the `"start"` of the period. Use `"end"` to change 12 | #' to the end of the period. 13 | #' @param include_endpoints Whether to include the first or last data point in 14 | #' addition to the transformed data. 15 | #' 16 | #' @details 17 | #' 18 | #' This function respects [dplyr::group_by()] groups. 19 | #' 20 | #' The `side` argument is useful when you want to return data at, say, the 21 | #' end of a quarter, or the end of a month. 22 | #' 23 | #' `include_endpoints` can be useful when calculating a change over time. 24 | #' In addition to changing to monthly dates, you often need the first data point 25 | #' as a baseline for the first calculation. 26 | #' 27 | #' 28 | #' @examples 29 | #' 30 | #' # Basic usage --------------------------------------------------------------- 31 | #' 32 | #' # FB stock prices 33 | #' data(FB) 34 | #' FB <- as_tbl_time(FB, date) 35 | #' 36 | #' # Aggregate FB to yearly data 37 | #' as_period(FB, "year") 38 | #' 39 | #' # Aggregate FB to every 2 years 40 | #' as_period(FB, "2 years") 41 | #' 42 | #' # Aggregate FB to yearly data, but use the last data point available 43 | #' # in that period 44 | #' as_period(FB, "year", side = "end") 45 | #' 46 | #' # Aggregate FB to yearly data, end of period, and include the first 47 | #' # endpoint 48 | #' as_period(FB, "year", side = "end", include_endpoints = TRUE) 49 | #' 50 | #' # Aggregate to weekly. Notice that it only uses the earliest day available 51 | #' # in the data set at that periodicity. It will not set the date of the first 52 | #' # row to 2013-01-01 because that date did not exist in the original data set. 53 | #' as_period(FB, "weekly") 54 | #' 55 | #' # FB is daily data, aggregate to minute? 56 | #' # Not allowed for Date class indices, an error is thrown 57 | #' # as_period(FB, "minute") 58 | #' 59 | #' # Grouped usage ------------------------------------------------------------- 60 | #' 61 | #' # FANG contains Facebook, Amazon, Netflix and Google stock prices 62 | #' data(FANG) 63 | #' FANG <- as_tbl_time(FANG, date) 64 | #' 65 | #' FANG <- dplyr::group_by(FANG, symbol) 66 | #' 67 | #' # Respects groups 68 | #' as_period(FANG, "year") 69 | #' 70 | #' # Every 6 months, respecting groups 71 | #' as_period(FANG, "6 months") 72 | #' 73 | #' # Using start_date ---------------------------------------------------------- 74 | #' 75 | #' 76 | #' #### One method using start_date 77 | #' 78 | #' # FB stock prices 79 | #' data(FB) 80 | #' FB <- as_tbl_time(FB, date) 81 | #' 82 | #' # The Facebook series starts at 2013-01-02 so the 'every 2 day' counter 83 | #' # starts at that date as well. Groups become (2013-01-02, 2013-01-03), 84 | #' # (2013-01-04, 2013-01-05) and so on. 85 | #' as_period(FB, "2 day") 86 | #' 87 | #' # Specifying the `start_date = "2013-01-01"` might be preferable. 88 | #' # Groups become (2013-01-01, 2013-01-02), (2013-01-03, 2013-01-04) and so on. 89 | #' as_period(FB, "2 day", start_date = "2013-01-01") 90 | #' 91 | #' #### Equivalent method using an index vector 92 | #' 93 | #' # FB stock prices 94 | #' data(FB) 95 | #' FB <- as_tbl_time(FB, date) 96 | #' 97 | #' custom_period <- create_series( 98 | #' time_formula = dplyr::first(FB$date) - 1 ~ dplyr::last(FB$date), 99 | #' period = "2 day", 100 | #' class = "Date", 101 | #' as_vector = TRUE) 102 | #' 103 | #' FB %>% 104 | #' as_tbl_time(date) %>% 105 | #' as_period(period = custom_period) 106 | #' 107 | #' # Manually calculating returns at different periods ------------------------- 108 | #' 109 | #' data(FB) 110 | #' 111 | #' # Annual Returns 112 | #' # Convert to end of year periodicity, but include the endpoints to use as 113 | #' # a reference for the first return calculation. Then calculate returns. 114 | #' FB %>% 115 | #' as_tbl_time(date) %>% 116 | #' as_period("1 y", side = "end", include_endpoints = TRUE) %>% 117 | #' dplyr::mutate(yearly_return = adjusted / dplyr::lag(adjusted) - 1) 118 | #' 119 | #' @export 120 | #' 121 | as_period <- function(.tbl_time, period = "year", 122 | start_date = NULL, side = "start", 123 | include_endpoints = FALSE, ...) { 124 | UseMethod("as_period") 125 | } 126 | 127 | #' @export 128 | as_period.default <- function(.tbl_time, period = "year", 129 | start_date = NULL, side = "start", 130 | include_endpoints = FALSE, ...) { 131 | stop("Object is not of class `tbl_time`.", call. = FALSE) 132 | } 133 | 134 | #' @export 135 | as_period.tbl_time <- function(.tbl_time, period = "year", 136 | start_date = NULL, side = "start", 137 | include_endpoints = FALSE, ...) { 138 | 139 | # Add time groups 140 | .tbl_time_tg <- dplyr::mutate( 141 | .tbl_time, 142 | .time_group = partition_index(!! get_index_quo(.tbl_time), period, start_date) 143 | ) 144 | 145 | # Filter 146 | if(side == "start") 147 | .tbl_time_tg <- dplyr::filter( 148 | .tbl_time_tg, 149 | { 150 | .tg <- .data$.time_group 151 | criteria <- vector(length = length(.tg)) 152 | criteria[match(unique(.tg), .tg)] <- TRUE 153 | 154 | # Include last end point 155 | if(include_endpoints) { 156 | criteria[length(criteria)] <- TRUE 157 | } 158 | 159 | criteria 160 | } 161 | ) 162 | else if(side == "end") { 163 | .tbl_time_tg <- dplyr::filter( 164 | .tbl_time_tg, 165 | { 166 | .tg <- .data$.time_group 167 | criteria <- vector(length = length(.tg)) 168 | criteria[length(.tg) - match(unique(.tg), rev(.tg)) + 1] <- TRUE 169 | 170 | # Include first end point 171 | if(include_endpoints) { 172 | criteria[1] <- TRUE 173 | } 174 | 175 | criteria 176 | } 177 | ) 178 | } 179 | 180 | # Remove time group column 181 | .tbl_time_tg <- remove_time_group(.tbl_time_tg) 182 | 183 | reconstruct(.tbl_time_tg, .tbl_time) 184 | } 185 | 186 | 187 | -------------------------------------------------------------------------------- /R/compat-tidyr.R: -------------------------------------------------------------------------------- 1 | #' @importFrom lifecycle deprecated 2 | 3 | nest.tbl_time <- function(.data, ..., .key = deprecated()) { 4 | check_tidyr_version() 5 | 6 | if (rlang::is_missing(.key)) { 7 | .key_char <- deprecated() 8 | } else { 9 | .key <- rlang::enexpr(.key) 10 | .key_char <- rlang::expr_name(.key) 11 | } 12 | 13 | index_quo <- get_index_quo(.data) 14 | index_char <- get_index_char(.data) 15 | 16 | # Need this to avoid data VS .key = "data" collision in the mutate/map 17 | ..original_data <- .data 18 | 19 | # Perform the nest on a tibble 20 | .data_nested <- tidyr::nest(as_tibble(.data), ..., .key = .key_char) 21 | 22 | # Figure out the names of the new nested columns 23 | if (rlang::is_missing(.key)) { 24 | nested_columns <- names(rlang::enquos(...)) 25 | 26 | if (rlang::is_empty(nested_columns)) { 27 | nested_columns <- "data" 28 | } 29 | } else { 30 | nested_columns <- .key_char 31 | } 32 | 33 | contains_index <- function(col) { 34 | index_char %in% colnames(.data_nested[[col]][[1]]) 35 | } 36 | 37 | index_is_nested <- vapply(nested_columns, contains_index, logical(1)) 38 | 39 | for (i in seq_along(nested_columns)) { 40 | # Each nested element should be a list_of with attributes 41 | if (index_is_nested[i]) { 42 | nested_column_sym <- rlang::sym(nested_columns[i]) 43 | 44 | .data_nested <- dplyr::mutate( 45 | .data_nested, 46 | !!nested_column_sym := purrr::map(!!nested_column_sym, ~reconstruct(.x, ..original_data)), 47 | !!nested_column_sym := vctrs::as_list_of(!!nested_column_sym, .ptype = (!!nested_column_sym)[[1]]) 48 | ) 49 | } else { 50 | # The index is in the outer df 51 | .data_nested <- reconstruct(.data_nested, ..original_data) 52 | } 53 | } 54 | 55 | .data_nested 56 | } 57 | 58 | unnest.tbl_time <- function(data, 59 | cols, 60 | ..., 61 | keep_empty = FALSE, 62 | ptype = NULL, 63 | names_sep = NULL, 64 | names_repair = "check_unique", 65 | .drop = "DEPRECATED", 66 | .id = "DEPRECATED", 67 | .sep = "DEPRECATED", 68 | .preserve = "DEPRECATED") { 69 | check_tidyr_version() 70 | 71 | # This is called after nesting but excluding the index in the nest. 72 | # Have to recall `unnest()` because otherwise the `cols` tidyselection gets 73 | # evaluated too early. 74 | 75 | bare_data <- as.data.frame(data) 76 | 77 | out <- tidyr::unnest( 78 | data = bare_data, 79 | cols = {{ cols }}, 80 | ..., 81 | keep_empty = keep_empty, 82 | ptype = ptype, 83 | names_sep = names_sep, 84 | names_repair = names_repair 85 | ) 86 | 87 | copy_.data <- new_tbl_time(data, get_index_quo(data), get_index_time_zone(data)) 88 | reconstruct(out, copy_.data) 89 | } 90 | 91 | unnest.tbl_df <- function(data, 92 | cols, 93 | ..., 94 | keep_empty = FALSE, 95 | ptype = NULL, 96 | names_sep = NULL, 97 | names_repair = "check_unique", 98 | .drop = deprecated(), 99 | .id = deprecated(), 100 | .sep = deprecated(), 101 | .preserve = deprecated()) { 102 | check_tidyr_version() 103 | 104 | # Called after nesting a tbl_time, index is in the nest, then unnesting. 105 | # Have to recall `unnest()` because otherwise the `cols` tidyselection gets 106 | # evaluated too early. 107 | 108 | bare_data <- as.data.frame(data) 109 | 110 | out <- tidyr::unnest( 111 | data = bare_data, 112 | cols = {{ cols }}, 113 | ..., 114 | keep_empty = keep_empty, 115 | ptype = ptype, 116 | names_sep = names_sep, 117 | names_repair = names_repair 118 | ) 119 | 120 | list_cols <- names(data)[purrr::map_lgl(data, rlang::is_list)] 121 | 122 | # If any contain a tbl_time, special handling 123 | list_col_is_tbl_time <- purrr::map_lgl( 124 | .x = list_cols, 125 | .f = ~inherits(data[[.x]][[1]], "tbl_time") 126 | ) 127 | 128 | contains_inner_tbl_time <- any(list_col_is_tbl_time) 129 | contains_outer_tbl_time <- inherits(data, "tbl_time") 130 | 131 | # Inner is tbl_time, but the outer tbl is not one. Want to maintain 132 | # tbl_time class 133 | if(contains_inner_tbl_time & !contains_outer_tbl_time) { 134 | # Grab nested columns 135 | nested <- dplyr::transmute(dplyr::ungroup(data), !!! rlang::syms(list_cols)) 136 | 137 | # Which list columns contain tbl_time objects? Extract the first one 138 | # to reconstruct with 139 | which_tbl_time <- which(list_col_is_tbl_time) 140 | 141 | which_tbl_time <- which_tbl_time[1] 142 | nested_time <- nested[[which_tbl_time]][[1]] 143 | 144 | out <- reconstruct(out, nested_time) 145 | } 146 | 147 | out 148 | } 149 | 150 | # ------------------------------------------------------------------------------ 151 | # gather() and spread() seem to be needed as well 152 | 153 | gather.tbl_time <- function(data, key = "key", value = "value", ..., na.rm = FALSE, 154 | convert = FALSE, factor_key = FALSE) { 155 | key <- rlang::enquo(key) 156 | value <- rlang::enquo(value) 157 | quos <- rlang::quos(...) 158 | 159 | gathered_data <- tidyr::gather(as_tibble(data), key = !! key, value = !! value, !!! quos, 160 | na.rm = na.rm, convert = convert, factor_key = factor_key) 161 | 162 | reconstruct(gathered_data, data) 163 | } 164 | 165 | spread.tbl_time <- function(data, key, value, fill = NA, convert = FALSE, drop = TRUE, 166 | sep = NULL) { 167 | key <- rlang::enquo(key) 168 | value <- rlang::enquo(value) 169 | 170 | spread_data <- tidyr::spread(as_tibble(data), key = !! key, value = !! value, 171 | fill = fill, convert = convert, drop = drop, 172 | sep = sep) 173 | 174 | reconstruct(spread_data, data) 175 | } 176 | 177 | # ------------------------------------------------------------------------------ 178 | 179 | check_tidyr_version <- function() { 180 | if (tidyr_at_least_1.0.0) { 181 | return() 182 | } 183 | 184 | rlang::abort("`tidyr` must be at least version '1.0.0' to use this feature.") 185 | } 186 | 187 | 188 | -------------------------------------------------------------------------------- /R/compat-dplyr.R: -------------------------------------------------------------------------------- 1 | #' @export 2 | #' @importFrom dplyr mutate 3 | mutate.tbl_time <- function(.data, ...) { 4 | #reconstruct(NextMethod(), .data) 5 | copy_.data <- new_tbl_time(.data, get_index_quo(.data), get_index_time_zone(.data)) 6 | reconstruct(NextMethod(), copy_.data) 7 | } 8 | 9 | #' @export 10 | #' @importFrom dplyr transmute 11 | transmute.tbl_time <- function(.data, ...) { 12 | #reconstruct(NextMethod(), .data) 13 | copy_.data <- new_tbl_time(.data, get_index_quo(.data), get_index_time_zone(.data)) 14 | reconstruct(NextMethod(), copy_.data) 15 | } 16 | 17 | #' @export 18 | #' @importFrom dplyr summarise 19 | summarise.tbl_time <- function(.data, ...) { 20 | #reconstruct(NextMethod(), .data) 21 | copy_.data <- new_tbl_time(.data, get_index_quo(.data), get_index_time_zone(.data)) 22 | reconstruct(NextMethod(), copy_.data) 23 | } 24 | 25 | #' @export 26 | #' @importFrom dplyr filter 27 | filter.tbl_time <- function(.data, ...) { 28 | #reconstruct(NextMethod(), .data) 29 | copy_.data <- new_tbl_time(.data, get_index_quo(.data), get_index_time_zone(.data)) 30 | reconstruct(NextMethod(), copy_.data) 31 | } 32 | 33 | # Required to export filter, otherwise: 34 | # Warning: declared S3 method 'filter.tbl_time' not found 35 | # because of stats::filter 36 | 37 | #' @export 38 | #' 39 | dplyr::filter 40 | 41 | #' @export 42 | #' @importFrom dplyr arrange 43 | arrange.tbl_time <- function(.data, ...) { 44 | #reconstruct(NextMethod(), .data) 45 | copy_.data <- new_tbl_time(.data, get_index_quo(.data), get_index_time_zone(.data)) 46 | reconstruct(NextMethod(), copy_.data) 47 | } 48 | 49 | #' @export 50 | #' @importFrom dplyr distinct 51 | distinct.tbl_time <- function(.data, ..., .keep_all = FALSE) { 52 | #reconstruct(NextMethod(), .data) 53 | copy_.data <- new_tbl_time(.data, get_index_quo(.data), get_index_time_zone(.data)) 54 | reconstruct(NextMethod(), copy_.data) 55 | } 56 | 57 | #' @export 58 | #' @importFrom dplyr full_join 59 | #' 60 | full_join.tbl_time <- function(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ...) { 61 | #reconstruct(NextMethod(), x) 62 | copy_.data <- new_tbl_time(x, get_index_quo(x), get_index_time_zone(x)) 63 | reconstruct(NextMethod(), copy_.data) 64 | } 65 | 66 | #' @export 67 | #' @importFrom dplyr inner_join 68 | #' 69 | inner_join.tbl_time <- function(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ...) { 70 | #reconstruct(NextMethod(), x) 71 | copy_.data <- new_tbl_time(x, get_index_quo(x), get_index_time_zone(x)) 72 | reconstruct(NextMethod(), copy_.data) 73 | } 74 | 75 | #' @export 76 | #' @importFrom dplyr left_join 77 | #' 78 | left_join.tbl_time <- function(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ...) { 79 | #reconstruct(NextMethod(), x) 80 | copy_.data <- new_tbl_time(x, get_index_quo(x), get_index_time_zone(x)) 81 | reconstruct(NextMethod(), copy_.data) 82 | } 83 | 84 | #' @export 85 | #' @importFrom dplyr right_join 86 | #' 87 | right_join.tbl_time <- function(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ...) { 88 | #reconstruct(NextMethod(), x) 89 | copy_.data <- new_tbl_time(x, get_index_quo(x), get_index_time_zone(x)) 90 | reconstruct(NextMethod(), copy_.data) 91 | } 92 | 93 | #' @export 94 | #' @importFrom dplyr anti_join 95 | #' 96 | anti_join.tbl_time <- function(x, y, by = NULL, copy = FALSE, ...) { 97 | #reconstruct(NextMethod(), x) 98 | copy_.data <- new_tbl_time(x, get_index_quo(x), get_index_time_zone(x)) 99 | reconstruct(NextMethod(), copy_.data) 100 | } 101 | 102 | #' @export 103 | #' @importFrom dplyr semi_join 104 | #' 105 | semi_join.tbl_time <- function(x, y, by = NULL, copy = FALSE, ...) { 106 | #reconstruct(NextMethod(), x) 107 | copy_.data <- new_tbl_time(x, get_index_quo(x), get_index_time_zone(x)) 108 | reconstruct(NextMethod(), copy_.data) 109 | } 110 | 111 | #' @export 112 | #' @importFrom dplyr select 113 | #' 114 | select.tbl_time <- function(.data, ...) { 115 | #reconstruct(NextMethod(), .data) 116 | copy_.data <- new_tbl_time(.data, get_index_quo(.data), get_index_time_zone(.data)) 117 | reconstruct(NextMethod(), copy_.data) 118 | } 119 | 120 | #' @export 121 | #' @importFrom dplyr slice 122 | #' 123 | slice.tbl_time <- function(.data, ...) { 124 | #reconstruct(NextMethod(), .data) 125 | copy_.data <- new_tbl_time(.data, get_index_quo(.data), get_index_time_zone(.data)) 126 | reconstruct(NextMethod(), copy_.data) 127 | } 128 | 129 | #' @export 130 | #' @importFrom dplyr group_by 131 | group_by.tbl_time <- function(.data, ...) { 132 | #reconstruct(NextMethod(), .data) 133 | copy_.data <- new_tbl_time(.data, get_index_quo(.data), get_index_time_zone(.data)) 134 | reconstruct(NextMethod(), copy_.data) 135 | } 136 | 137 | #' @export 138 | #' @importFrom dplyr ungroup 139 | ungroup.tbl_time <- function(x, ...) { 140 | #reconstruct(NextMethod(), x) 141 | copy_.data <- new_tbl_time(x, get_index_quo(x), get_index_time_zone(x)) 142 | reconstruct(NextMethod(), copy_.data) 143 | } 144 | 145 | 146 | ### Backwards compat support for deprecated standard eval dplyr 147 | 148 | # Only a few of them need it. arrange_.tbl_df() directly calls arrange_impl() 149 | # causing a problem. 150 | 151 | #' @export 152 | #' @importFrom dplyr arrange_ 153 | #' 154 | arrange_.tbl_time <- function(.data, ..., .dots = list()) { 155 | #reconstruct(NextMethod(), .data) 156 | copy_.data <- new_tbl_time(.data, get_index_quo(.data), get_index_time_zone(.data)) 157 | reconstruct(NextMethod(), copy_.data) 158 | } 159 | 160 | #' @export 161 | #' @importFrom dplyr mutate_ 162 | #' 163 | mutate_.tbl_time <- function(.data, ..., .dots = list()) { 164 | #reconstruct(NextMethod(), .data) 165 | copy_.data <- new_tbl_time(.data, get_index_quo(.data), get_index_time_zone(.data)) 166 | reconstruct(NextMethod(), copy_.data) 167 | } 168 | 169 | #' @export 170 | #' @importFrom dplyr summarise_ 171 | #' 172 | summarise_.tbl_time <- function(.data, ..., .dots = list()) { 173 | #reconstruct(NextMethod(), .data) 174 | copy_.data <- new_tbl_time(.data, get_index_quo(.data), get_index_time_zone(.data)) 175 | reconstruct(NextMethod(), copy_.data) 176 | } 177 | 178 | #' @export 179 | #' @importFrom dplyr summarize_ 180 | #' 181 | summarize_.tbl_time <- function(.data, ..., .dots = list()) { 182 | #reconstruct(NextMethod(), .data) 183 | copy_.data <- new_tbl_time(.data, get_index_quo(.data), get_index_time_zone(.data)) 184 | reconstruct(NextMethod(), copy_.data) 185 | } 186 | 187 | #' @export 188 | #' @importFrom dplyr slice_ 189 | #' 190 | slice_.tbl_time <- function(.data, ..., .dots = list()) { 191 | #reconstruct(NextMethod(), .data) 192 | copy_.data <- new_tbl_time(.data, get_index_quo(.data), get_index_time_zone(.data)) 193 | reconstruct(NextMethod(), copy_.data) 194 | } 195 | -------------------------------------------------------------------------------- /R/partition_index.R: -------------------------------------------------------------------------------- 1 | #' Partition an index vector into an integer vector representing groups 2 | #' 3 | #' [partition_index()] takes an index vector and returns an integer vector that 4 | #' can be used for grouping by periods. This is the workhorse for many other 5 | #' `tibbletime` functions. 6 | #' 7 | #' @param index A vector of date indices to create groups for. 8 | #' @param period A character specification used for time-based grouping. The 9 | #' general format to use is `"frequency period"` where frequency is a number 10 | #' like 1 or 2, and period is an interval like weekly or yearly. There must be 11 | #' a space between the two. 12 | #' 13 | #' Note that you can pass the specification in a flexible way: 14 | #' 15 | #' * 1 Year: `'1 year'` / `'1 Y'` 16 | #' 17 | #' This shorthand is available for year, quarter, month, day, hour, minute, 18 | #' second, millisecond and microsecond periodicities. 19 | #' 20 | #' Additionally, you have the option of passing in a vector of dates to 21 | #' use as custom and more flexible boundaries. 22 | #' 23 | #' @param start_date Optional argument used to 24 | #' specify the start date for the 25 | #' first group. The default is to start at the closest period boundary 26 | #' below the minimum date in the supplied index. 27 | #' @param ... Not currently used. 28 | #' 29 | #' @details 30 | #' 31 | #' This function is used internally, but may provide the user extra flexibility 32 | #' in some cases. 33 | #' 34 | #' Grouping can only be done on the minimum periodicity of the index and above. 35 | #' This means that a daily series cannot be grouped by minute. An hourly series 36 | #' cannot be grouped by 5 seconds, and so on. If the user attempts this, 37 | #' an error will be thrown. 38 | #' 39 | #' @seealso [as_period()], [collapse_index()] 40 | #' 41 | #' @examples 42 | #' 43 | #' data(FB) 44 | #' 45 | #' partition_index(FB$date, '2 year') 46 | #' 47 | #' dplyr::mutate(FB, partition_index = partition_index(date, '2 day')) 48 | #' 49 | #' @export 50 | #' @rdname partition_index 51 | #' 52 | partition_index <- function(index, period = "year", start_date = NULL, ...) { 53 | 54 | .index <- to_posixct_numeric(index) 55 | 56 | # Check ordering of numeric index 57 | check_index_order(.index) 58 | 59 | # Find the correct boundaries for the partitioned index 60 | endpoints <- make_endpoints(index, period, start_date) 61 | 62 | # Use the boundaries to break up the index 63 | make_partitioned_index(.index, endpoints) 64 | } 65 | 66 | #### Utils --------------------------------------------------------------------- 67 | 68 | # Create the break points from the user's index and their specified period 69 | # to break on 70 | make_endpoints <- function(index, period, start_date) { 71 | 72 | # Allow the user to pass in an index vector to be used as the period 73 | if(inherits_allowed_datetime(period)) { 74 | 75 | assert_custom_period_class_matches_index_class(index, period) 76 | endpoints <- period 77 | 78 | # Otherwise, parse the period and make an endpoint vector 79 | } else { 80 | 81 | index_class <- get_index_col_class(index) 82 | index_time_zone <- get_index_col_time_zone(index) 83 | 84 | # Parse the period 85 | period_list <- parse_period(period) 86 | 87 | # Generic validation of user defined period 88 | assert_period_matches_index_class(index, period_list$period) 89 | 90 | # Make endpoint time_formula 91 | period_clean <- paste(period_list[["freq"]], period_list[["period"]]) 92 | 93 | endpoint_time_formula <- make_endpoint_formula( 94 | index = index, 95 | period = period_clean, 96 | start_date = start_date 97 | ) 98 | 99 | # Create series 100 | endpoints <- create_series( 101 | time_formula = endpoint_time_formula, 102 | period = period, 103 | class = index_class, 104 | tz = index_time_zone, 105 | include_end = TRUE, 106 | as_vector = TRUE 107 | ) 108 | 109 | } 110 | 111 | endpoints <- to_posixct_numeric(endpoints) 112 | 113 | endpoints 114 | } 115 | 116 | make_endpoint_formula <- function(index, period, start_date = NULL) { 117 | # Get start_date 118 | if(is.null(start_date)) { 119 | start_date <- dplyr::first(index) 120 | 121 | # Auto start_date get's floored (only by the period) 122 | start_date <- floor_index(start_date, period) 123 | 124 | } else { 125 | # Coerce the user specified start_date 126 | start_date <- coerce_start_date(index, start_date) 127 | assert_start_date_before_index_min(index, start_date) 128 | } 129 | 130 | # Get end_date (ceilinged by the full period to have the correct last grouping) 131 | end_date <- ceiling_index(dplyr::last(index), period) 132 | 133 | # As formula 134 | start_date ~ end_date 135 | } 136 | 137 | 138 | assert_start_date_before_index_min <- function(index, start_date) { 139 | assertthat::assert_that( 140 | to_posixct_numeric(dplyr::first(index)) >= to_posixct_numeric(start_date), 141 | msg = "start_date must be less than or equal to the minimum of the index column" 142 | ) 143 | } 144 | 145 | make_partitioned_index <- function(index, endpoints) { 146 | # Combine the two and obtain the correct order 147 | combined_dates <- c(endpoints, index) 148 | sorted_order <- order(combined_dates) 149 | 150 | # Create the unfilled time group vector and put it in the correct order 151 | endpoint_groups <- rlang::seq2_along(1, endpoints) 152 | endpoint_fillers <- rep(NA, times = length(index)) 153 | full_partition_index <- c(endpoint_groups, endpoint_fillers)[sorted_order] 154 | 155 | # Remember location of endpoint_dates for removal later 156 | endpoint_locations <- match(endpoint_groups, full_partition_index) 157 | 158 | # 'fill' the NA values forward with the correct group 159 | not_na <- !is.na(full_partition_index) 160 | full_partition_index <- cumsum(not_na) 161 | 162 | # Pull the endpoint_dates back out so we don't have duplicates 163 | .partition_index <- full_partition_index[-endpoint_locations] 164 | 165 | # Subtract off min-1 (takes care of starting the groups too early) 166 | .partition_index <- .partition_index - (.partition_index[1] - 1L) 167 | 168 | .partition_index 169 | } 170 | 171 | # Check if index in in ascending order, warn user if not. 172 | check_index_order <- function(index) { 173 | 174 | if(!is.numeric(index)) { 175 | index <- as.numeric(index) 176 | } 177 | 178 | if(!is_ordered_numeric(index)) { 179 | message("Note: Index not ordered. tibbletime assumes index is in ascending order. Results may not be as desired.") 180 | } 181 | } 182 | 183 | assert_custom_period_class_matches_index_class <- function(index, period) { 184 | assertthat::assert_that( 185 | get_index_col_class(index) == get_index_col_class(period), 186 | msg = "The custom period vector class much match the class of the index" 187 | ) 188 | } 189 | -------------------------------------------------------------------------------- /R/filter_time.R: -------------------------------------------------------------------------------- 1 | #' Succinctly filter a `tbl_time` object by its index 2 | #' 3 | #' Use a concise filtering method to filter a `tbl_time` object by its `index`. 4 | #' 5 | #' @param .tbl_time A `tbl_time` object. 6 | #' @param time_formula A period to filter over. 7 | #' This is specified as a `formula`. See `Details`. 8 | #' 9 | #' @details 10 | #' 11 | #' The `time_formula` is specified using the format `from ~ to`. 12 | #' Each side of the `time_formula` is specified as the character 13 | #' `'YYYY-MM-DD HH:MM:SS'`, but powerful shorthand is available. 14 | #' Some examples are: 15 | #' * __Year:__ `'2013' ~ '2015'` 16 | #' * __Month:__ `'2013-01' ~ '2016-06'` 17 | #' * __Day:__ `'2013-01-05' ~ '2016-06-04'` 18 | #' * __Second:__ `'2013-01-05 10:22:15' ~ '2018-06-03 12:14:22'` 19 | #' * __Variations:__ `'2013' ~ '2016-06'` 20 | #' 21 | #' The `time_formula` can also use a one sided formula. 22 | #' * __Only dates in 2015:__ `~'2015'` 23 | #' * __Only dates March 2015:__ `~'2015-03'` 24 | #' 25 | #' The `time_formula` can also use `'start'` and `'end'` as keywords for 26 | #' your filter. 27 | #' * __Start of the series to end of 2015:__ `'start' ~ '2015'` 28 | #' * __Start of 2014 to end of series:__ `'2014' ~ 'end'` 29 | #' 30 | #' All shorthand dates are expanded: 31 | #' * The `from` side is expanded to be the first date in that period 32 | #' * The `to` side is expanded to be the last date in that period 33 | #' 34 | #' This means that the following examples are equivalent (assuming your 35 | #' index is a POSIXct): 36 | #' * `'2015' ~ '2016' == '2015-01-01 + 00:00:00' ~ '2016-12-31 + 23:59:59'` 37 | #' * `~'2015' == '2015-01-01 + 00:00:00' ~ '2015-12-31 + 23:59:59'` 38 | #' * `'2015-01-04 + 10:12' ~ '2015-01-05' == '2015-01-04 + 10:12:00' ~ '2015-01-05 + 23:59:59'` 39 | #' 40 | #' Special parsing is done for indices of class `hms`. The `from ~ to` time 41 | #' formula is specified as only `HH:MM:SS`. 42 | #' * __Start to 5th second of the 12th hour:__ `'start' ~ '12:00:05'` 43 | #' * __Every second in the 12th hour:__ `~'12'` 44 | #' 45 | #' Subsecond resolution is also supported, however, R has a unique way of 46 | #' handling and printing subsecond dates and the user should be comfortable with 47 | #' this already. Specify subsecond resolution like so: 48 | #' `'2013-01-01 00:00:00.1' ~ '2013-01-01 00:00:00.2'`. Note that one sided 49 | #' expansion does not work with subsecond resolution due to seconds and subseconds 50 | #' being grouped together into 1 number (i.e. 1.2 seconds). This means `~'2013-01-01 00:00:00'` does 51 | #' not expand to something like `'2013-01-01 00:00:00.00' ~ '2013-01-01 00:00:00.99'`, 52 | #' but only expands to include whole seconds. 53 | #' 54 | #' This function respects [dplyr::group_by()] groups. 55 | #' 56 | #' @rdname filter_time 57 | #' 58 | #' @export 59 | #' 60 | #' @examples 61 | #' 62 | #' # FANG contains Facebook, Amazon, Netflix and Google stock prices 63 | #' data(FANG) 64 | #' FANG <- as_tbl_time(FANG, date) %>% 65 | #' dplyr::group_by(symbol) 66 | #' 67 | #' # 2013-01-01 to 2014-12-31 68 | #' filter_time(FANG, '2013' ~ '2014') 69 | #' 70 | #' # 2013-05-25 to 2014-06-04 71 | #' filter_time(FANG, '2013-05-25' ~ '2014-06-04') 72 | #' 73 | #' # Using the `[` subset operator 74 | #' FANG['2014'~'2015'] 75 | #' 76 | #' # Using `[` and one sided formula for only dates in 2014 77 | #' FANG[~'2014'] 78 | #' 79 | #' # Using `[` and column selection 80 | #' FANG['2013'~'2016', c("date", "adjusted")] 81 | #' 82 | #' # Variables are unquoted using rlang 83 | #' lhs_date <- "2013" 84 | #' rhs_date <- as.Date("2014-01-01") 85 | #' filter_time(FANG, lhs_date ~ rhs_date) 86 | #' 87 | #' # Use the keywords 'start' and 'end' to conveniently access ends 88 | #' filter_time(FANG, 'start' ~ '2014') 89 | #' 90 | #' # hms (hour, minute, second) classes have special parsing 91 | #' hms_example <- create_series(~'12:01', 'second', class = 'hms') 92 | #' filter_time(hms_example, 'start' ~ '12:01:30') 93 | #' 94 | #' 95 | filter_time <- function(.tbl_time, time_formula) { 96 | UseMethod("filter_time") 97 | } 98 | 99 | #' @export 100 | filter_time.default <- function(.tbl_time, time_formula) { 101 | stop("Object is not of class `tbl_time`.", call. = FALSE) 102 | } 103 | 104 | #' @export 105 | filter_time.tbl_time <- function(.tbl_time, time_formula) { 106 | 107 | index_quo <- get_index_quo(.tbl_time) 108 | tz <- get_index_time_zone(.tbl_time) 109 | 110 | # from/to setup is done inside the call to filter so it is unique to 111 | # each group 112 | .tbl_filtered <- dplyr::filter(.tbl_time, { 113 | 114 | # Parse the time_formula, don't convert to dates yet 115 | tf_list <- parse_time_formula(!! index_quo, time_formula) 116 | 117 | # Could allow for multifilter idea here 118 | 119 | # Then convert to datetime 120 | from_to <- purrr::map( 121 | .x = tf_list, 122 | .f = ~list_to_datetime(!! index_quo, .x, tz = tz) 123 | ) 124 | 125 | # Get sequence creation pieces ready 126 | from <- from_to[[1]] 127 | to <- from_to[[2]] 128 | 129 | # Final assertion of order 130 | assert_from_before_to(from, to) 131 | 132 | sorted_range_search(!! index_quo, from, to) 133 | }) 134 | 135 | reconstruct(.tbl_filtered, .tbl_time) 136 | } 137 | 138 | # Subset operator -------------------------------------------------------------- 139 | 140 | #' @export 141 | #' 142 | #' @param x Same as `.tbl_time` but consistent naming with base R. 143 | #' @param i A period to filter over. This is specified the same as 144 | #' `time_formula` or can use the traditional row extraction method. 145 | #' @param j Optional argument to also specify column index to subset. Works 146 | #' exactly like the normal extraction operator. 147 | #' @param drop Will always be coerced to `FALSE` by `tibble`. 148 | #' 149 | #' @rdname filter_time 150 | #' 151 | `[.tbl_time` <- function(x, i, j, drop = FALSE) { 152 | 153 | # This helps decide whether i is used for column subset or row subset 154 | .nargs <- nargs() - !missing(drop) 155 | 156 | # filter_time if required 157 | if(!missing(i)) { 158 | if(rlang::is_formula(i)) { 159 | x <- filter_time(x, i) 160 | } 161 | } 162 | 163 | # Remove time class/attribs to let tibble::`[` do the rest 164 | x_tbl <- as_tibble(x) 165 | 166 | # i filter 167 | if(!missing(i)) { 168 | if(!rlang::is_formula(i)) { 169 | if(.nargs <= 2) { 170 | # Column subset 171 | # Preferred if tibble issue is addressed 172 | # x <- x[i, drop = drop] 173 | x_tbl <- x_tbl[i] 174 | } else { 175 | # Row subset 176 | x_tbl <- x_tbl[i, , drop = drop] 177 | } 178 | 179 | } 180 | } 181 | 182 | # j filter 183 | if(!missing(j)) { 184 | x_tbl <- x_tbl[, j, drop = drop] 185 | } 186 | 187 | # If the index still exists, convert to tbl_time again 188 | if(get_index_char(x) %in% colnames(x_tbl)) { 189 | x_tbl <- as_tbl_time(x_tbl, !! get_index_quo(x)) 190 | } 191 | 192 | x_tbl 193 | } 194 | -------------------------------------------------------------------------------- /R/rollify.R: -------------------------------------------------------------------------------- 1 | #' Create a rolling version of any function 2 | #' 3 | #' `rollify` returns a rolling version of the input function, with a 4 | #' rolling `window` specified by the user. 5 | #' 6 | #' @inheritParams purrr::quietly 7 | #' @param window The window size to roll over 8 | #' @param unlist If the function returns a single value each time it is called, 9 | #' use `unlist = TRUE`. If the function returns more than one value, or a more 10 | #' complicated object (like a linear model), use `unlist = FALSE` to create 11 | #' a list-column of the rolling results. 12 | #' @param na_value A default value for the `NA` values at the beginning of the 13 | #' roll. 14 | #' 15 | #' @details 16 | #' 17 | #' The intended use of `rollify` is to turn a function into a rolling version 18 | #' of itself for use inside of a call to [dplyr::mutate()], however it works 19 | #' equally as well when called from [purrr::map()]. 20 | #' 21 | #' Because of it's intended use with [dplyr::mutate()], `rollify` 22 | #' creates a function that always returns output with the same length of the 23 | #' input, aligned right, and filled with `NA` unless otherwise specified 24 | #' by `na_value`. 25 | #' 26 | #' The form of the `.f` argument is the same as the form that can be passed 27 | #' to [purrr::map()]. Use `.x` or `.` to refer to the first object to roll over, 28 | #' and `.y` to refer to the second object if required. The examples explain this 29 | #' further. 30 | #' 31 | #' If optional arguments to the function are required, specify them in the 32 | #' call to `rollify`, and not in the call to the rolling version of the 33 | #' function. See the examples for more details. 34 | #' 35 | #' 36 | #' @examples 37 | #' 38 | #' # Rolling mean -------------------------------------------------------------- 39 | #' 40 | #' data(FB) 41 | #' 42 | #' # Turn the normal mean function into a rolling mean with a 5 row window 43 | #' mean_roll_5 <- rollify(mean, window = 5) 44 | #' 45 | #' dplyr::mutate(FB, 46 | #' normal_mean = mean(adjusted), 47 | #' rolling_mean = mean_roll_5(adjusted)) 48 | #' 49 | #' # There's nothing stopping you from combining multiple rolling functions with 50 | #' # different window sizes in the same mutate call 51 | #' mean_roll_10 <- rollify(mean, window = 10) 52 | #' 53 | #' dplyr::mutate(FB, 54 | #' rolling_mean_5 = mean_roll_5(adjusted), 55 | #' rolling_mean_10 = mean_roll_10(adjusted)) 56 | #' 57 | #' # Functions with multiple args and optional args ---------------------------- 58 | #' 59 | #' # With 2 args, use the purrr syntax of ~ and .x, .y 60 | #' # Rolling correlation example 61 | #' cor_roll <- rollify(~cor(.x, .y), window = 5) 62 | #' 63 | #' dplyr::mutate(FB, running_cor = cor_roll(adjusted, open)) 64 | #' 65 | #' # With >2 args, create an anonymous function with >2 args or use 66 | #' # the purrr convention of ..1, ..2, ..3 to refer to the arguments 67 | #' avg_of_avgs <- rollify(function(x, y, z) { 68 | #' (mean(x) + mean(y) + mean(z)) / 3 69 | #' }, 70 | #' window = 10) 71 | #' 72 | #' # Or 73 | #' avg_of_avgs <- rollify(~(mean(..1) + mean(..2) + mean(..3)) / 3, 74 | #' window = 10) 75 | #' 76 | #' dplyr::mutate(FB, avg_of_avgs = avg_of_avgs(open, high, low)) 77 | #' 78 | #' # Optional arguments MUST be passed at the creation of the rolling function 79 | #' # Only data arguments that are "rolled over" are allowed when calling the 80 | #' # rolling version of the function 81 | #' FB$adjusted[1] <- NA 82 | #' 83 | #' roll_mean_na_rm <- rollify(~mean(.x, na.rm = TRUE), window = 5) 84 | #' 85 | #' dplyr::mutate(FB, roll_mean = roll_mean_na_rm(adjusted)) 86 | #' 87 | #' # Returning multiple values ------------------------------------------------- 88 | #' 89 | #' data(FB) 90 | #' 91 | #' summary2 <- function(x) { 92 | #' unclass(summary(x)) 93 | #' } 94 | #' 95 | #' # If the function returns >1 value, set the `unlist = FALSE` argument 96 | #' # Running 5 number summary 97 | #' summary_roll <- rollify(summary2, window = 5, unlist = FALSE) 98 | #' 99 | #' FB_summarised <- dplyr::mutate(FB, summary_roll = summary_roll(adjusted)) 100 | #' FB_summarised$summary_roll[[5]] 101 | #' 102 | #' # dplyr::bind_rows() is often helpful in these cases to get 103 | #' # meaningful output 104 | #' 105 | #' summary_roll <- rollify(~dplyr::bind_rows(summary2(.)), window = 5, unlist = FALSE) 106 | #' FB_summarised <- dplyr::mutate(FB, summary_roll = summary_roll(adjusted)) 107 | #' FB_summarised %>% 108 | #' dplyr::filter(!is.na(summary_roll)) %>% 109 | #' tidyr::unnest(summary_roll) 110 | #' 111 | #' # Rolling regressions ------------------------------------------------------- 112 | #' 113 | #' # Extending an example from R 4 Data Science on "Many Models". 114 | #' # For each country in the gapminder data, calculate a linear regression 115 | #' # every 5 periods of lifeExp ~ year 116 | #' library(gapminder) 117 | #' 118 | #' # Rolling regressions are easy to implement 119 | #' lm_roll <- rollify(~lm(.x ~ .y), window = 5, unlist = FALSE) 120 | #' 121 | #' gapminder %>% 122 | #' dplyr::group_by(country) %>% 123 | #' dplyr::mutate(rolling_lm = lm_roll(lifeExp, year)) 124 | #' 125 | #' # Rolling with groups ------------------------------------------------------- 126 | #' 127 | #' # One of the most powerful things about this is that it works with 128 | #' # groups since `mutate` is being used 129 | #' data(FANG) 130 | #' FANG <- FANG %>% 131 | #' dplyr::group_by(symbol) 132 | #' 133 | #' mean_roll_3 <- rollify(mean, window = 3) 134 | #' 135 | #' FANG %>% 136 | #' dplyr::mutate(mean_roll = mean_roll_3(adjusted)) %>% 137 | #' dplyr::slice(1:5) 138 | #' 139 | #' @seealso [purrr::safely], [purrr::possibly] 140 | #' 141 | #' @export 142 | #' 143 | rollify <- function(.f, window = 1, unlist = TRUE, na_value = NULL) { 144 | 145 | # Mappify the function 146 | .f <- purrr::as_mapper(.f) 147 | 148 | # Return function that calls roller 149 | function(...) { 150 | roller(..., .f = .f, window = window, unlist = unlist, na_value = na_value) 151 | } 152 | } 153 | 154 | 155 | # Utils ------------------------------------------------------------------------ 156 | 157 | roller <- function(..., .f, window, unlist = TRUE, na_value = NULL) { 158 | 159 | # na_value as NA if not specified 160 | if(is.null(na_value)) { 161 | na_value = NA 162 | } 163 | 164 | # Capture dots as list. These should be the arguments that are rolled 165 | .dots <- rlang::dots_list(...) 166 | 167 | # Error check the dots 168 | check_dots(.dots, window) 169 | 170 | # Each data element of .dots should be of the same length so use the first 171 | # as the length of the dataset 172 | roll_length <- length(.dots[[1]]) 173 | 174 | # Initialize `filled` vector 175 | filled <- rlang::rep_along(1:roll_length, list(na_value)) 176 | 177 | # Roll and fill 178 | for(i in window:roll_length) { 179 | .f_dots <- lapply(.dots, function(x) {x[(i-window+1):i]}) 180 | filled[[i]] <- do.call(.f, .f_dots) 181 | } 182 | 183 | # Don't unlist if requested (when >1 value returned) 184 | if(unlist) { 185 | unlist(filled) 186 | } else { 187 | filled 188 | } 189 | 190 | } 191 | 192 | # Check that dots follow the necessary convention for rolling 193 | check_dots <- function(x, window) { 194 | 195 | # The user must have passed something to be passed on to .f 196 | assertthat::assert_that(length(x) > 0, 197 | msg = "At least 1 data argument must be supplied to be 198 | passed on to the rolling function") 199 | 200 | 201 | # The window must be smaller than the length of the data 202 | assertthat::assert_that(window <= length(x[[1]]), 203 | msg = "Cannot roll apply with a window larger than the 204 | length of the data") 205 | 206 | 207 | # Length of every element of .dots should be the same 208 | # Only data used in the rolling should be in .dots 209 | # Optional args should be specified in the rollify call 210 | for(i in 1:length(x)) { 211 | assertthat::assert_that(length(x[[i]]) == length(x[[1]]), 212 | msg = "Arguments supplied to the rolling version 213 | of the function should be data of the same length. 214 | Optional arguments should be specified when creating 215 | the rolling version with `rollify()`") 216 | } 217 | } 218 | -------------------------------------------------------------------------------- /R/collapse_index.R: -------------------------------------------------------------------------------- 1 | #' Collapse an index vector so that all observations in an interval share the 2 | #' same date 3 | #' 4 | #' When `collapse_index()` is used, the index vector is altered 5 | #' so that all dates that fall in a specified interval share a common date. 6 | #' The most common use case for this is to then group on the collapsed index. 7 | #' 8 | #' @inheritParams partition_index 9 | #' @param index An index vector. 10 | #' @param side Whether to return the date at the beginning or the end of 11 | #' the new period. By default, the "end" of the period. 12 | #' Use "start" to change to the start of the period. 13 | #' @param clean Whether or not to round the collapsed index up / down to the next 14 | #' period boundary. The decision to round up / down is controlled by the side 15 | #' argument. 16 | #' @param ... Not currently used. 17 | #' 18 | #' @details 19 | #' 20 | #' The [collapse_by()] function provides a shortcut for the most common use 21 | #' of `collapse_index()`, calling the function inside a call to `mutate()` to 22 | #' modify the index directly. For more flexibility, like the nesting example 23 | #' below, use `collapse_index()`. 24 | #' 25 | #' Because this is often used for end of period summaries, the default is to 26 | #' use `side = "end"`. Note that this is the opposite of [as_period()] where 27 | #' the default is `side = "start"`. 28 | #' 29 | #' The `clean` argument is especially useful if you have an irregular series 30 | #' and want cleaner dates to report for summary values. 31 | #' 32 | #' @examples 33 | #' 34 | #' # Basic functionality ------------------------------------------------------- 35 | #' 36 | #' # Facebook stock prices 37 | #' data(FB) 38 | #' FB <- as_tbl_time(FB, date) 39 | #' 40 | #' # Collapse to weekly dates 41 | #' dplyr::mutate(FB, date = collapse_index(date, "weekly")) 42 | #' 43 | #' # A common workflow is to group on the new date column 44 | #' # to perform a time based summary 45 | #' FB %>% 46 | #' dplyr::mutate(date = collapse_index(date, "year")) %>% 47 | #' dplyr::group_by(date) %>% 48 | #' dplyr::summarise_if(is.numeric, mean) 49 | #' 50 | #' # You can also assign the result to a separate column and use that 51 | #' # to nest on, allowing for 'period nests' that keep the 52 | #' # original dates in the nested tibbles. 53 | #' FB %>% 54 | #' dplyr::mutate(nest_date = collapse_index(date, "2 year")) %>% 55 | #' dplyr::group_by(nest_date) %>% 56 | #' tidyr::nest() 57 | #' 58 | #' # Grouped functionality ----------------------------------------------------- 59 | #' 60 | #' data(FANG) 61 | #' FANG <- FANG %>% 62 | #' as_tbl_time(date) %>% 63 | #' dplyr::group_by(symbol) 64 | #' 65 | #' # Collapse each group to monthly, 66 | #' # calculate monthly standard deviation for each column 67 | #' FANG %>% 68 | #' dplyr::mutate(date = collapse_index(date, "month")) %>% 69 | #' dplyr::group_by(symbol, date) %>% 70 | #' dplyr::summarise_all(sd) 71 | #' 72 | #' 73 | #' @export 74 | #' 75 | collapse_index <- function(index, period = "year", 76 | start_date = NULL, side = "end", clean = FALSE, ...) { 77 | 78 | # Side either start or end 79 | assert_valid_side(side) 80 | 81 | # Index as numeric (unlist would remove attrs) 82 | index_num <- to_posixct_numeric(index) 83 | 84 | # Very different approach with clean. Only returning the endpoints 85 | # filled to the correct location, not using the user's indices. 86 | if(clean) { 87 | 88 | # Create datetime endpoints 89 | endpoints <- make_endpoints(index, period, start_date) 90 | 91 | # Create a numeric index containing the endpoints positioned in a way 92 | # to replace the old index 93 | new_numeric_index <- make_partitioned_endpoints(index_num, endpoints, side) 94 | 95 | # Convert to datetime 96 | new_index <- posixct_numeric_to_datetime( 97 | x = new_numeric_index, 98 | class = get_index_col_class(index), 99 | tz = get_index_col_time_zone(index) 100 | ) 101 | 102 | # Else do a standard partition using the user's indices as the endpoints 103 | } else { 104 | 105 | # Partition index 106 | index_part <- partition_index(index, period, start_date) 107 | 108 | if(side == "start") { 109 | # For each partition, find the first date position 110 | pos <- match(unique(index_part), index_part) 111 | index_at_pos <- index_num[pos] 112 | 113 | # Each date must be repeated this many times to rebuild the column 114 | reps <- diff(c(pos, length(index_part) + 1)) 115 | 116 | } else if(side == "end") { 117 | # For each partition, find the last date position 118 | pos <- length(index_part) - match(unique(index_part), rev(index_part)) + 1 119 | index_at_pos <- index_num[pos] 120 | 121 | # Each date must be repeated this many times to rebuild the column 122 | reps <- diff(c(0, pos)) 123 | 124 | } 125 | 126 | new_index <- posixct_numeric_to_datetime( 127 | x = rep(index_at_pos, reps), 128 | class = get_index_col_class(index), 129 | tz = get_index_col_time_zone(index) 130 | ) 131 | 132 | } 133 | 134 | new_index 135 | } 136 | 137 | 138 | #' Collapse a tbl_time object by its index 139 | #' 140 | #' Collapse the index of a `tbl_time` object by time period. The index column 141 | #' is altered so that all dates that fall in a specified interval share a 142 | #' common date. 143 | #' 144 | #' @inheritParams collapse_index 145 | #' @inheritParams as_period 146 | #' 147 | #' @details 148 | #' 149 | #' `collapse_by()` is a simplification of a call to [dplyr::mutate()] to collapse an 150 | #' index column using [collapse_index()]. 151 | #' 152 | #' @examples 153 | #' 154 | #' # Basic functionality ------------------------------------------------------- 155 | #' 156 | #' # Facebook stock prices 157 | #' data(FB) 158 | #' FB <- as_tbl_time(FB, date) 159 | #' 160 | #' # Collapse to weekly dates 161 | #' collapse_by(FB, "weekly") 162 | #' 163 | #' # A common workflow is to group on the collapsed date column 164 | #' # to perform a time based summary 165 | #' FB %>% 166 | #' collapse_by("year") %>% 167 | #' dplyr::group_by(date) %>% 168 | #' dplyr::summarise_if(is.numeric, mean) 169 | #' 170 | #' # Grouped functionality ----------------------------------------------------- 171 | #' 172 | #' data(FANG) 173 | #' FANG <- FANG %>% 174 | #' as_tbl_time(date) %>% 175 | #' dplyr::group_by(symbol) 176 | #' 177 | #' # Collapse each group to monthly, 178 | #' # calculate monthly standard deviation for each column 179 | #' FANG %>% 180 | #' collapse_by("month") %>% 181 | #' dplyr::group_by(symbol, date) %>% 182 | #' dplyr::summarise_all(sd) 183 | #' 184 | #' @export 185 | collapse_by <- function(.tbl_time, period = "year", start_date = NULL, side = "end", clean = FALSE, ...) { 186 | 187 | index_quo <- get_index_quo(.tbl_time) 188 | index_char <- get_index_char(.tbl_time) 189 | 190 | start_date <- rlang::enquo(start_date) 191 | 192 | .tbl_time_collapsed <- dplyr::mutate( 193 | .data = .tbl_time, 194 | !! index_char := collapse_index( 195 | index = !! index_quo, 196 | period = period, 197 | start_date = !! start_date, 198 | side = side, 199 | clean = clean, 200 | ... 201 | ) 202 | ) 203 | 204 | .tbl_time_collapsed 205 | } 206 | 207 | 208 | assert_valid_side <- function(side) { 209 | assertthat::assert_that( 210 | side %in% c("start", "end"), 211 | msg = "`side` must be either 'start' or 'end'" 212 | ) 213 | } 214 | 215 | # This is similar to make_partitioned_index but rather than returning 216 | # a vector of integers corresponding to groups it returns a vector 217 | # of endpoints corresponding to the groups. These endpoints are 'clean' 218 | # dates 219 | make_partitioned_endpoints <- function(index, endpoints, side = "end") { 220 | # Combine the two and obtain the correct order 221 | combined_dates <- c(endpoints, index) 222 | sorted_order <- order(combined_dates) 223 | 224 | # Create the unfilled time group vector and put it in the correct order 225 | endpoint_fillers <- rep(NA, times = length(index)) 226 | full_partition_index <- c(endpoints, endpoint_fillers)[sorted_order] 227 | 228 | # Remember location of endpoint dates for removal later 229 | endpoint_locations <- match(endpoints, full_partition_index) 230 | 231 | # 'fill' the NA values forward/backward with the correct endpoint 232 | from_last <- ifelse(side == "end", yes = TRUE, no = FALSE) 233 | full_partition_index <- zoo::na.locf0(full_partition_index, fromLast = from_last) 234 | 235 | # Pull the endpoints back out so we don't have duplicates 236 | .partition_index <- full_partition_index[-endpoint_locations] 237 | 238 | .partition_index 239 | } 240 | -------------------------------------------------------------------------------- /vignettes/TT-03-rollify-for-rolling-analysis.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Rolling calculations in tibbletime" 3 | author: "Davis Vaughan" 4 | date: "`r Sys.Date()`" 5 | output: 6 | rmarkdown::html_vignette: 7 | toc: true 8 | toc_depth: 3 9 | vignette: > 10 | %\VignetteIndexEntry{Rolling calculations in tibbletime} 11 | %\VignetteEngine{knitr::rmarkdown} 12 | %\VignetteEncoding{UTF-8} 13 | --- 14 | 15 | # Introducing rollify() 16 | 17 | A common task in financial analyses is to perform a rolling calculation. This 18 | might be a single value like a rolling mean or standard deviation, or it 19 | might be more complicated like a rolling linear regression. To account for this 20 | flexibility, `tibbletime` has the `rollify()` function. This function allows 21 | you to turn _any_ function into a rolling version of itself. 22 | 23 | In the `tidyverse`, this type of function is known as an _adverb_ 24 | because it _modifies_ an existing function, which are 25 | typically given _verb_ names. 26 | 27 | ## Datasets required 28 | 29 | ```{r, message=FALSE, warning=FALSE} 30 | library(tibbletime) 31 | library(dplyr) 32 | library(tidyr) 33 | 34 | # Facebook stock prices. 35 | data(FB) 36 | 37 | # Only a few columns 38 | FB <- select(FB, symbol, date, open, close, adjusted) 39 | 40 | ``` 41 | 42 | 43 | ## A rolling average 44 | 45 | To calculate a rolling average, picture a column in a data frame where you take 46 | the average of the values in rows 1-5, then in rows 2-6, then in 3-7, and so on 47 | until you reach the end of the dataset. This type of 5-period moving window is 48 | a rolling calculation, and is often used to smooth out noise in a dataset. 49 | 50 | Let's see how to do this with `rollify()`. 51 | 52 | ```{r} 53 | 54 | # The function to use at each step is `mean`. 55 | # The window size is 5 56 | rolling_mean <- rollify(mean, window = 5) 57 | 58 | rolling_mean 59 | ``` 60 | 61 | We now have a rolling version of the function, `mean()`. You use it in a 62 | similar way to how you might use `mean()`. 63 | 64 | ```{r} 65 | mutate(FB, mean_5 = rolling_mean(adjusted)) 66 | ``` 67 | 68 | You can create multiple versions of the rolling function if you need to 69 | calculate the mean at multiple window lengths. 70 | 71 | ```{r} 72 | rolling_mean_2 <- rollify(mean, window = 2) 73 | rolling_mean_3 <- rollify(mean, window = 3) 74 | rolling_mean_4 <- rollify(mean, window = 4) 75 | 76 | FB %>% mutate( 77 | rm10 = rolling_mean_2(adjusted), 78 | rm20 = rolling_mean_3(adjusted), 79 | rm30 = rolling_mean_4(adjusted) 80 | ) 81 | ``` 82 | 83 | ## Purrr functional syntax 84 | 85 | `rollify()` is built using pieces from the `purrr` package. One of those is 86 | the ability to accept an anonymous function using the `~` function syntax. 87 | 88 | The documentation, `?rollify`, gives a thorough walkthrough of the different 89 | forms you can pass to `rollify()`, but let's see a few more examples. 90 | 91 | ```{r} 92 | # Rolling mean, but with function syntax 93 | rolling_mean <- rollify(.f = ~mean(.x), window = 5) 94 | 95 | mutate(FB, mean_5 = rolling_mean(adjusted)) 96 | ``` 97 | 98 | You can create anonymous functions (functions without a name) on the fly. 99 | 100 | ```{r} 101 | # 5 period average of 2 columns (open and close) 102 | rolling_avg_sum <- rollify(~ mean(.x + .y), window = 5) 103 | 104 | mutate(FB, avg_sum = rolling_avg_sum(open, close)) 105 | ``` 106 | 107 | ## Optional arguments 108 | 109 | To pass optional arguments (not `.x` or `.y`) to your rolling function, 110 | they must be specified in the non-rolling form in the call to `rollify()`. 111 | 112 | For instance, say our dataset had `NA` values, but we still wanted to calculate 113 | an average. We need to specify `na.rm = TRUE` as an argument to `mean()`. 114 | 115 | ```{r} 116 | FB$adjusted[1] <- NA 117 | 118 | # Do this 119 | rolling_mean_na <- rollify(~mean(.x, na.rm = TRUE), window = 5) 120 | 121 | FB %>% mutate(mean_na = rolling_mean_na(adjusted)) 122 | 123 | # Don't try this! 124 | # rolling_mean_na <- rollify(~mean(.x), window = 5) 125 | # FB %>% mutate(mean_na = rolling_mean_na(adjusted, na.rm = TRUE)) 126 | 127 | # Reset FB 128 | data(FB) 129 | FB <- select(FB, symbol, date, adjusted) 130 | ``` 131 | 132 | ## Returning more than 1 value per call 133 | 134 | Say our rolling function returned a call to a custom `summary_df()` function. 135 | This function calculates a 5 number number summary and returns it as a tidy 136 | data frame. 137 | 138 | We won't be able to use the rolling version of this out of the box. 139 | `dplyr::mutate()` will complain that an incorrect number of values were returned 140 | since `rollify()` attempts to unlist at each call. Essentially, each call would 141 | be returning 5 values instead of 1. What we need is to be able to 142 | create a list-column. To do this, specify `unlist = FALSE` in the call 143 | to `rollify()`. 144 | 145 | ```{r} 146 | # Our data frame summary 147 | summary_df <- function(x) { 148 | data.frame( 149 | rolled_summary_type = c("mean", "sd", "min", "max", "median"), 150 | rolled_summary_val = c(mean(x), sd(x), min(x), max(x), median(x)) 151 | ) 152 | } 153 | 154 | # A rolling version, with unlist = FALSE 155 | rolling_summary <- rollify(~summary_df(.x), window = 5, 156 | unlist = FALSE) 157 | 158 | FB_summarised <- mutate(FB, summary_list_col = rolling_summary(adjusted)) 159 | FB_summarised 160 | ``` 161 | 162 | The neat thing is that after removing the `NA` values at the beginning, the 163 | list-column can be unnested using `tidyr::unnest()` giving us a nice tidy 164 | 5-period rolling summary. 165 | 166 | ```{r} 167 | FB_summarised %>% 168 | filter(!is.na(summary_list_col)) %>% 169 | unnest(cols = summary_list_col) 170 | ``` 171 | 172 | ## Custom missing values 173 | 174 | The last example was a little clunky because to unnest we had to remove the first 175 | few missing rows manually. If those missing values were empty data frames then 176 | `unnest()` would have known how to handle them. Luckily, the `na_value` argument 177 | will allow us to specify a value to fill the `NA` spots at the beginning of the 178 | roll. 179 | 180 | ```{r} 181 | rolling_summary <- rollify(~summary_df(.x), window = 5, 182 | unlist = FALSE, na_value = data.frame()) 183 | 184 | FB_summarised <- mutate(FB, summary_list_col = rolling_summary(adjusted)) 185 | FB_summarised 186 | ``` 187 | 188 | Now unnesting directly: 189 | 190 | ```{r} 191 | FB_summarised %>% 192 | unnest(cols = summary_list_col) 193 | ``` 194 | 195 | Finally, if you want to actually keep those first few NA rows in the unnest, you 196 | can pass a data frame that is initialized with the same 197 | column names as the rest of the values. 198 | 199 | ```{r} 200 | rolling_summary <- rollify(~summary_df(.x), window = 5, 201 | unlist = FALSE, 202 | na_value = data.frame(rolled_summary_type = NA, 203 | rolled_summary_val = NA)) 204 | 205 | FB_summarised <- mutate(FB, summary_list_col = rolling_summary(adjusted)) 206 | FB_summarised %>% unnest(cols = summary_list_col) 207 | ``` 208 | 209 | ## Rolling regressions 210 | 211 | A final use of this flexible function is to calculate rolling regressions. 212 | 213 | A very ficticious example is to perform a rolling regression on the `FB` dataset 214 | of the form `close ~ high + low + volume`. Notice that we have 4 columns to pass 215 | here. This is more complicated than a `.x` and `.y` example, but have no fear. 216 | The arguments can be specified in order as `..1`, `..2`, ... for as far as 217 | is required, or you can pass a freshly created anonymous function. 218 | The latter is what we will do so we can preserve the names of the 219 | variables in the regression. 220 | 221 | Again, since this returns a linear model object, 222 | we will specify `unlist = FALSE`. Unfortunately there is no easy default NA 223 | value to pass here. 224 | 225 | ```{r} 226 | # Reset FB 227 | data(FB) 228 | 229 | rolling_lm <- rollify(.f = function(close, high, low, volume) { 230 | lm(close ~ high + low + volume) 231 | }, 232 | window = 5, 233 | unlist = FALSE) 234 | 235 | FB_reg <- mutate(FB, roll_lm = rolling_lm(close, high, low, volume)) 236 | FB_reg 237 | ``` 238 | 239 | To get some useful information about the regressions, we will use `broom::tidy()` 240 | and apply it to each regression using a `mutate() + map()` combination. 241 | 242 | ```{r} 243 | FB_reg %>% 244 | filter(!is.na(roll_lm)) %>% 245 | mutate(tidied = purrr::map(roll_lm, broom::tidy)) %>% 246 | unnest(tidied) %>% 247 | select(symbol, date, term, estimate, std.error, statistic, p.value) 248 | ``` 249 | 250 | -------------------------------------------------------------------------------- /R/index-based-generics.R: -------------------------------------------------------------------------------- 1 | # Generic functions that define the differences between date/time classes 2 | 3 | # Checks if the input is a supported date/time class 4 | inherits_allowed_datetime <- function(x) { 5 | inherits(x, c("Date", "POSIXct", "POSIXt", "yearmon", "yearqtr", "hms")) 6 | } 7 | 8 | #### General ------------------------------------------------------------------- 9 | 10 | 11 | #### create_series ------------------------------------------------------------- 12 | 13 | ## ------------------------------------------------------------------------- 14 | ## lookup_seq_fun() 15 | 16 | # For sequence creation in create_series() 17 | lookup_seq_fun <- function(x) { 18 | UseMethod("lookup_seq_fun") 19 | } 20 | 21 | #' @export 22 | lookup_seq_fun.POSIXct <- function(x) { 23 | 24 | # For POSIXct object, DST can cause problems with 25 | # rollover between DST boundaries. See #31. Using DSTday as the "by" 26 | # uses the actual "clock time" which is what is commonly desired. 27 | function(from, to, by) { 28 | if(grepl(pattern = "day", by)) { 29 | by <- gsub("day", "DSTday", by) 30 | } 31 | seq.POSIXt(from, to, by) 32 | } 33 | } 34 | 35 | #' @export 36 | lookup_seq_fun.Date <- function(x) { 37 | seq.Date 38 | } 39 | 40 | #' @export 41 | lookup_seq_fun.yearmon <- function(x) { 42 | seq.yearmon 43 | } 44 | 45 | #' @export 46 | lookup_seq_fun.yearqtr <- function(x) { 47 | seq.yearqtr 48 | } 49 | 50 | #' @export 51 | lookup_seq_fun.hms <- function(x) { 52 | seq.hms 53 | } 54 | 55 | ## ------------------------------------------------------------------------- 56 | ## push_datetime() 57 | 58 | # Really only necessary because c(hms, hms) loses the hms class 59 | push_datetime <- function(x, push) { 60 | UseMethod("push_datetime") 61 | } 62 | 63 | #' @export 64 | push_datetime.default <- function(x, push) { 65 | 66 | x_num <- to_posixct_numeric(x) 67 | push_num <- to_posixct_numeric(push) 68 | 69 | pushed <- unique(c(x_num, push_num)) 70 | 71 | posixct_numeric_to_datetime( 72 | pushed, 73 | class = get_index_col_class(x), 74 | tz = get_index_col_time_zone(x) 75 | ) 76 | } 77 | 78 | #' @export 79 | push_datetime.hms <- function(x, push) { 80 | hms::as_hms(push_datetime.default(x, push)) 81 | } 82 | 83 | 84 | #### parse_period -------------------------------------------------------------- 85 | 86 | ## ------------------------------------------------------------------------- 87 | ## assert_period_matches_index_class() 88 | 89 | # Check that the supplied period formula is allowed for that class 90 | assert_period_matches_index_class <- function(x, period) { 91 | UseMethod("assert_period_matches_index_class") 92 | } 93 | 94 | #' @export 95 | assert_period_matches_index_class.default <- function(x, period) { 96 | glue_stop("Class '{class(x)}' is not a known index class.") 97 | } 98 | 99 | #' @export 100 | assert_period_matches_index_class.POSIXct <- function(x, period) { 101 | return() 102 | } 103 | 104 | #' @export 105 | assert_period_matches_index_class.Date <- function(x, period) { 106 | assertthat::assert_that( 107 | period %in% c("year", "quarter", "month", "week", "day"), 108 | msg = "Only year, quarter, month, week, and day periods are allowed for an index of class Date" 109 | ) 110 | } 111 | 112 | #' @export 113 | assert_period_matches_index_class.yearmon <- function(x, period) { 114 | assertthat::assert_that( 115 | period %in% c("year", "quarter", "month"), 116 | msg = "Only year, quarter, and month periods are allowed for an index of class yearmon" 117 | ) 118 | } 119 | 120 | #' @export 121 | assert_period_matches_index_class.yearqtr <- function(x, period) { 122 | assertthat::assert_that( 123 | period %in% c("year", "quarter"), 124 | msg = "Only year and quarter periods are allowed for an index of class yearqtr" 125 | ) 126 | } 127 | 128 | #' @export 129 | assert_period_matches_index_class.hms <- function(x, period) { 130 | assertthat::assert_that( 131 | period %in% c("hour", "min", "sec"), 132 | msg = "Only hour, minute and second periods are allowed for an index of class hms" 133 | ) 134 | } 135 | 136 | 137 | #### parse_time_formula -------------------------------------------------------- 138 | 139 | ## ------------------------------------------------------------------------- 140 | ## split_to_list() 141 | 142 | split_to_list <- function(x) { 143 | UseMethod("split_to_list") 144 | } 145 | 146 | #' @export 147 | split_to_list.default <- function(x) { 148 | stop("Unrecognized time formula input") 149 | } 150 | 151 | #' @export 152 | split_to_list.Date <- function(x) { 153 | x_lt <- as.POSIXlt(x, tz = get_default_time_zone()) 154 | list(x_lt$year + 1900, x_lt$mon + 1, x_lt$mday) 155 | } 156 | 157 | #' @export 158 | split_to_list.POSIXct <- function(x) { 159 | x_lt <- as.POSIXlt(x, tz = get_index_col_time_zone(x)) 160 | list(x_lt$year + 1900, x_lt$mon + 1, x_lt$mday, 161 | x_lt$hour, x_lt$min, x_lt$sec) 162 | } 163 | 164 | #' @export 165 | split_to_list.yearmon <- function(x) { 166 | x_lt <- as.POSIXlt(x, tz = get_default_time_zone()) 167 | list(x_lt$year + 1900, x_lt$mon + 1) 168 | } 169 | #' @export 170 | split_to_list.yearqtr <- function(x) { 171 | x_lt <- as.POSIXlt(x, tz = get_default_time_zone()) 172 | list(x_lt$year + 1900, x_lt$mon + 1) 173 | } 174 | 175 | #' @export 176 | split_to_list.hms <- function(x) { 177 | x_lt <- as.POSIXlt(x, tz = get_default_time_zone()) 178 | list(x_lt$hour, x_lt$min, x_lt$sec) 179 | } 180 | 181 | #' @export 182 | split_to_list.character <- function(x) { 183 | # Split on - / , : * + space (notably not .) 184 | split_str <- unlist(strsplit(x, "-|/|:|[*]|[+]|[,]|[[:space:]]")) 185 | 186 | # Remove the "" that get left 187 | split_str <- split_str[split_str != ""] 188 | 189 | split_list <- as.list(split_str) 190 | 191 | maybe_to_numeric <- function(x) { 192 | if(x != ".") { 193 | x <- suppressWarnings(as.numeric(x)) 194 | if(is.na(x)) { 195 | stop("Cannot parse time formula specification", call. = FALSE) 196 | } 197 | } 198 | x 199 | } 200 | 201 | # Attempt to coerce to numeric unless '.' 202 | split_list <- lapply( 203 | split_list, 204 | maybe_to_numeric 205 | ) 206 | 207 | split_list 208 | } 209 | 210 | ## ------------------------------------------------------------------------- 211 | ## lookup_defaults() 212 | 213 | # Find the default time_formula list values. These get overwritten 214 | # with the user supplied values 215 | lookup_defaults <- function(index, side = "lhs") { 216 | UseMethod("lookup_defaults") 217 | } 218 | 219 | #' @export 220 | lookup_defaults.POSIXct <- function(index, side = "lhs") { 221 | switch(side, 222 | "lhs" = list(y = 1970, m = 01, d = 01, h = 00, M = 00, s = 00), 223 | "rhs" = list(y = 1970, m = 12, d = 00, h = 23, M = 59, s = 59)) 224 | } 225 | 226 | #' @export 227 | lookup_defaults.Date <- function(index, side = "lhs") { 228 | switch(side, 229 | "lhs" = list(y = 1970, m = 01, d = 01), 230 | "rhs" = list(y = 1970, m = 12, d = 00)) 231 | } 232 | 233 | #' @export 234 | lookup_defaults.yearmon <- function(index, side = "lhs") { 235 | switch(side, 236 | "lhs" = list(y = 1970, m = 01), 237 | "rhs" = list(y = 1970, m = 12)) 238 | } 239 | 240 | #' @export 241 | lookup_defaults.yearqtr <- function(index, side = "lhs") { 242 | switch(side, 243 | "lhs" = list(y = 1970, q = 01), 244 | "rhs" = list(y = 1970, q = 04)) 245 | } 246 | 247 | #' @export 248 | lookup_defaults.hms <- function(index, side = "lhs") { 249 | switch(side, 250 | "lhs" = list(h = 00, M = 00, s = 00), 251 | "rhs" = list(h = 23, M = 59, s = 59)) 252 | } 253 | 254 | ## ------------------------------------------------------------------------- 255 | ## list_to_datetime() 256 | 257 | # Collapse the list of period values into a real datetime class 258 | list_to_datetime <- function(index, tf_side, ...) { 259 | UseMethod("list_to_datetime") 260 | } 261 | 262 | #' @export 263 | list_to_datetime.POSIXct <- function(index, tf_side, tz, ...) { 264 | lubridate::make_datetime(tf_side$y, tf_side$m, tf_side$d, 265 | tf_side$h, tf_side$M, tf_side$s, tz = tz) 266 | } 267 | 268 | #' @export 269 | list_to_datetime.Date <- function(index, tf_side, ...) { 270 | lubridate::make_date(tf_side$y, tf_side$m, tf_side$d) 271 | } 272 | 273 | #' @export 274 | list_to_datetime.yearmon <- function(index, tf_side, ...) { 275 | tf_side$d <- 1 276 | zoo::as.yearmon(list_to_datetime.Date(index, tf_side)) 277 | } 278 | 279 | #' @export 280 | list_to_datetime.yearqtr <- function(index, tf_side, ...) { 281 | yearqtr_string <- paste0(tf_side$y, "-", tf_side$q) 282 | zoo::as.yearqtr(yearqtr_string) 283 | } 284 | 285 | #' @export 286 | list_to_datetime.hms <- function(index, tf_side, ...) { 287 | hms::hms(seconds = tf_side$s, minutes = tf_side$M, hours = tf_side$h) 288 | } 289 | 290 | #### partition_index ----------------------------------------------------------- 291 | 292 | ## ------------------------------------------------------------------------- 293 | ## coerce_start_date() 294 | 295 | # Coerce a character start_date to a real datetime 296 | coerce_start_date <- function(x, start_date) { 297 | UseMethod("coerce_start_date") 298 | } 299 | 300 | #' @export 301 | coerce_start_date.POSIXct <- function(x, start_date) { 302 | tz <- get_index_col_time_zone(x) 303 | as.POSIXct(start_date, tz = tz) 304 | } 305 | 306 | #' @export 307 | coerce_start_date.Date <- function(x, start_date) { 308 | as.Date(start_date) 309 | } 310 | 311 | #' @export 312 | coerce_start_date.yearmon <- function(x, start_date) { 313 | zoo::as.yearmon(start_date) 314 | } 315 | 316 | #' @export 317 | coerce_start_date.yearqtr <- function(x, start_date) { 318 | zoo::as.yearqtr(start_date) 319 | } 320 | 321 | #' @export 322 | coerce_start_date.hms <- function(x, start_date) { 323 | hms::as_hms(start_date) 324 | } 325 | --------------------------------------------------------------------------------