133 R/interval.R
View file
@@ -0,0 +1,133 @@
# Number of time units
gen_interval <- function(date) {
UseMethod("gen_interval")
}

gen_interval.default <- function(date) {
output <- min_interval(date) # num of years
return(output)
}

gen_interval.POSIXt <- function(date) {
dttm <- as.numeric(date)
output <- min_interval(dttm) # num of seconds
return(output)
}

gen_interval.Date <- function(date) {
date <- as.numeric(date)
output <- min_interval(date) # num of days
return(output)
}

gen_interval.yearmon <- function(date) {
# num of months
mon <- as.numeric(date)
output <- ceiling(min_interval(mon) * 12)
return(output)
}

gen_interval.yearqtr <- function(date) {
# num of quarters
qtr <- as.numeric(date)
output <- ceiling(min_interval(qtr) * 4)
return(output)
}

# Assume date is regularly spaced
# R6Class to manage tsibble interval, although the printing info is character.
pull_interval <- function(date) {
UseMethod("pull_interval")
}

pull_interval.POSIXt <- function(date) {
nhms <- gen_interval.POSIXt(date)
period <- period2list(nhms)
output <- structure(
list(hour = period$hour, minute = period$minute, second = period$second),
class = c("hms", "frequency")
)
return(output)
}

pull_interval.Date <- function(date) {
ndays <- gen_interval.Date(date)
output <- structure(list(day = ndays), class = c("day", "frequency"))
return(output)
}

pull_interval.yearmon <- function(date) {
nmonths <- gen_interval.yearmon(date)
output <- structure(list(month = nmonths), class = c("month", "frequency"))
return(output)
}

pull_interval.yearqtr <- function(date) {
nqtrs <- gen_interval.yearqtr(date)
output <- structure(list(quarter = nqtrs), class = c("quarter", "frequency"))
return(output)
}

pull_interval.default <- function(date) {
nyrs <- gen_interval.default(date)
output <- structure(list(year = nyrs), class = c("year", "frequency"))
return(output)
}

display_int <- function(x) {
not_zero <- !map_lgl(x, function(x) x == 0)
output <- x[not_zero]
return(paste0(rlang::flatten_dbl(output), toupper(names(output))))
}

## helper function
period2list <- function(x) {
output <- seconds_to_period(x)
return(list(
year = output$year, month = output$month, day = output$day,
hour = output$hour, minute = output$minute, second = output$second
))
}

min_interval <- function(date) {
return(min(abs(diff(as.numeric(date), na.rm = TRUE))))
}

support_cls <- function() {
return(c(
"Date", "POSIXt", "yearmon", "yearqtr", "integer", "numeric"
))
}

# from ts time to dates
time2date <- function(x, ...) {
UseMethod("time2date")
}

time2date.ts <- function(x, tz = "UTC", ...) {
freq <- frequency(x)
time_x <- time(x)
if (freq == 12) { # monthly
output <- as.yearmon(time_x)
} else if (freq == 4) { # quarterly
output <- as.yearqtr(time_x)
} else if (freq == 1) { # yearly
output <- as.numeric(time_x)
} else {
output <- date_decimal(as.numeric(time_x), tz = tz)
}
return(output)
}

#' @export
# rep S3 methods for yearmon & yearqtr
rep.yearmon <- function(x, ...) {
x <- NextMethod()
return(structure(x, class = "yearmon"))
}

#' @export
rep.yearqtr <- function(x, ...) {
x <- NextMethod()
return(structure(x, class = "yearqtr"))
}
54 R/parse.R
View file
@@ -0,0 +1,54 @@
# ToDo: parse_key(key = key_vars((x * y) | z))
# [[1]] z
# [[1]][[1]] x
# [[1]][[2]] y
# ToDo: print method for "key_ts" and etc
parse_key <- function(data, key = key_vars()) {
key_exprs <- exprs(!!!get_expr(key))
cn <- colnames(data)
if (is_empty(key) || length(key) > 2) { # univariate || three or more vars
# parse_key(key = key_vars())
# parse_key(key = key_vars(x, y, z))
key2 <- syms(select_vars(cn, !!!key_exprs))
return(structure(key2, class = "key_ts"))
} else {
len_key <- length(key_exprs)
syms_all <- c("|", "*")
if (len_key == 2) {
exprs_2 <- key_exprs[[2]]
if (is_symbol(exprs_2)) {
# parse_key(key = key_vars(x, y))
key2 <- syms(select_vars(cn, !!!key_exprs))
return(structure(key2, class = "key_ts"))
} else if (exprs_2 == syms_all[2]) {
# parse_key(key = key_vars(x:z, "*"))
key2 <- syms(select_vars(cn, !!!key_exprs[1]))
return(structure(key2, class = "key_gts"))
} else {
# parse_key(key = key_vars(-x, "|"))
# parse_key(key = key_vars(y:z, "|"))
# parse_key(key = key_vars(x:z, "|"))
key2 <- syms(select_vars(cn, !!!key_exprs[1]))
return(structure(key2, class = "key_hts"))
}
} else { # len_key == 1
all_exprs <- all.vars(key_exprs[[1]], functions = TRUE)
syms_has <- all_exprs[1]
if (is_false(syms_has %in% syms_all)) {
# parse_key(key = key_vars(x))
# parse_key(key = key_vars(x:z))
key2 <- syms(select_vars(cn, !!!key_exprs))
return(structure(key2, class = "key_ts"))
} else if (syms_has == syms_all[2]) {
# parse_key(key = key_vars(x * y * z))
key2 <- syms(select_vars(cn, all_exprs[-1]))
return(structure(key2, class = "key_gts"))
} else {
# parse_key(key = key_vars(x | y | z))
key2 <- syms(select_vars(cn, all_exprs[-1]))
return(structure(key2, class = "key_hts"))
}
}
}
}

32 R/reexports.R
View file
@@ -0,0 +1,32 @@
#' @export
dplyr::summarise

#' @export
dplyr::summarize

#' @export
dplyr::filter

#' @export
dplyr::mutate

#' @export
dplyr::select

#' @export
dplyr::group_by

#' @export
magrittr::`%>%`

#' @export
zoo::as.yearmon

#' @export
zoo::as.yearqtr

#' @export
lubridate::year

#' @export
lubridate::as_date
279 R/tsibble.R
View file
@@ -0,0 +1,279 @@
globalVariables(c("key", "value"))

#' Create a tsibble object
#'
#' @param ... A set of name-value pairs.
#' @param key Unquoted variable(s) indicating the key variables for tsibble,
#' used in combination with `key_vars()`.
#' @param index An unquoted variable indicating the time index variable.
#'
#' @return A tsibble object.
#' @author Earo Wang
#' @rdname tsibble
#' @seealso [tibble::tibble]
#'
#' @examples
#' ts_df <- tsibble(
#' Date = rep(seq(as.Date("2017-01-01"), by = 1, length = 10), 2),
#' Group = rep(c("A", "B"), each = 10),
#' Value = rnorm(20),
#' key = key_vars(Group), index = Date
#' )
#' print(ts_df)
#'
#' @export
tsibble <- function(..., key = key_vars(), index) {
index <- enquo(index)
tsibble_(lst(...), key = key, index = index)
}

#' Coerce to a tsibble object
#'
#' @param x Other objects to be coerced to tsibble.
#' @param ... Other arguments to be passed.
#'
#' @return A tsibble object.
#' @author Earo Wang
#' @seealso [tibble::as_tibble]
#' @rdname as-tsibble
#'
#' @examples
#' # coerce data.frame to tsibble
#' # as_tsibble(tidypkgs, key = key_vars(package), index = date)
#'
#' # coerce ts to tsibble
#' as_tsibble(AirPassengers)
#' as_tsibble(sunspot.year)
#' as_tsibble(sunspot.month)
#' as_tsibble(austres)
#'
#' @export
as_tsibble <- function(x, ...) {
UseMethod("as_tsibble")
}

#' @rdname as-tsibble
#' @param key Unquoted variable(s) indicating the key variables for tsibble,
#' used in combination with `key_vars()`.
#' @param index An unquoted variable indicating the time index variable
#' @export
as_tsibble.default <- function(x, key = key_vars(), index, ...) {
index <- enquo(index)
output <- tsibble_(x, key = key, index = index)
return(output)
}

#' @rdname as-tsibble
#' @param tz Time zone.
#' @export
as_tsibble.ts <- function(x, tz = "UTC", ...) {
idx <- time2date(x, tz = tz)
value <- unclass(x) # rm its ts class

output <- tsibble(
time = idx, value = value,
key = key_vars(), index = time,
)
colnames(output)[2] <- deparse(substitute(x))
return(output)
}

#' @rdname as-tsibble
#' @export
as_tsibble.mts <- function(x, tz = "UTC", ...) {
long_tbl <- mts2tbl(x, tz = tz)
colnames(long_tbl)[3] <- deparse(substitute(x))
output <- as_tsibble.default(long_tbl, key = key_vars(key), index = time)
return(output)
}

#' @rdname as-tsibble
#' @export
as_tsibble.hts <- function(x, tz = "UTC", ...) {
bts <- x$bts
nodes <- x$nodes[-1]
labels <- x$labels[-1]
labels <- labels[-length(labels)]
nr <- nrow(bts)
chr_labs <- map(seq_along(labels), ~ rep_nodes(labels[[.]], nodes, level = .))
full_labs <- map(rev.default(chr_labs), ~ rep(., each = nr))
names(full_labs) <- names(labels)

tbl <- mts2tbl(bts, tz = tz) %>%
dplyr::select(time, value, key)
colnames(tbl)[3] <- deparse(substitute(x))
out_hts <- bind_cols(tbl, full_labs)
# this would work around the special character issue in headers for parse()
sym_key <- syms(colnames(out_hts)[c(3, ncol(out_hts))])
chr_key <- paste(sym_key, collapse = ":")
output <- as_tsibble.default(
out_hts, key = key_vars(!!parse_expr(chr_key), "|"), index = time
)
return(output)
}

#' @rdname as-tsibble
#' @export
as_tsibble.gts <- function(x, tz = "UTC", ...) {
bts <- x$bts
group <- x$group[-1, , drop = FALSE]
group <- group[-nrow(group), , drop = FALSE]
labels <- x$labels
if (is_empty(labels)) {
abort("I don't know how to handle a grouped time series with no group.")
}
seq_labs <- seq_along(labels)
grp_label <- map(seq_labs, ~ labels[[.]][group[., ]])
chr_labs <- vector(mode = "list", length = length(labels))
for (i in seq_labs) {
chr_labs[[i]] <- map_chr(
strsplit(grp_label[[i]], split = "/", fixed = TRUE), ~ .[2]
)
}
nr <- nrow(bts)
full_labs <- map(chr_labs, ~ rep(., each = nr))
names(full_labs) <- names(labels)

tbl <- mts2tbl(bts, tz = tz) %>%
dplyr::select(time, value)
colnames(tbl)[2] <- deparse(substitute(x))
out_hts <- bind_cols(tbl, full_labs)
# this would work around the special character issue in headers for parse()
sym_key <- syms(colnames(out_hts)[c(3, ncol(out_hts))])
chr_key <- paste(sym_key, collapse = ":")
output <- as_tsibble.default(
out_hts, key = key_vars(!!parse_expr(chr_key), "*"), index = time
)
return(output)
}

## tsibble is a special class of tibble that handles temporal data. It
## requires a sequence of time index to be unique across every identifier.
## The way to distinguish univariate or multivariate series is based on "key".
## Although the "index" arg is possible to automate the detection of time
## objects, it would fail when tsibble contain multiple time objects. Better
## to let user specify.
tsibble_ <- function(..., key = key_vars(), index) {
tbl <- as_tibble(...)
cls_tbl <- class(tbl)

# check time index type
eval_idx <- eval_tidy(index, data = tbl)
cls_idx <- class(eval_idx)
if (is_false(any(cls_idx %in% support_cls()))) {
abort(paste(cls_idx, "class is not supported."))
}

pkey <- parse_key(tbl, key = key)
if (class(pkey) == "key_ts" && is_empty(pkey)) { # univariate
if (anyDuplicated(eval_idx) != 0) {
abort("'index' must contain unique time index.")
}
tbl_interval <- pull_interval(eval_idx)
cls_tbl <- c("tbl_ts", cls_tbl)
} else {
if (class(pkey) == "key_ts") { # multivariate
tbl_nest <- tbl %>%
group_by(!!!pkey) %>%
nest()
cls_tbl <- c("tbl_ts", cls_tbl)
} else if (class(pkey) == "key_hts") {
tbl_nest <- tbl %>%
group_by(!!!pkey[1]) %>% # the bottom level group
nest()
cls_tbl <- c("tbl_hts", "tbl_gts", "tbl_ts", cls_tbl)
} else { # key_gts
tbl_nest <- tbl %>%
group_by(!!!pkey) %>% # the comb of all the groups
nest()
cls_tbl <- c("tbl_gts", "tbl_ts", cls_tbl)
}
eval_lst_idx <- tbl_nest$data %>%
map(function(data) eval_tidy(index, data = data))
lst_interval <- vapply(eval_lst_idx,
function(x) gen_interval(x), numeric(1))
check_idx <- map_int(eval_lst_idx, anyDuplicated)
if (!is_constant(lst_interval)) {
abort("Each key variable must have the same time interval in 'tsibble'.")
} else if (any(check_idx != 0)) {
abort("'index' must contain unique time index for each key variable.")
} else {
tbl_interval <- pull_interval(eval_lst_idx[[1]])
}
}

attr(tbl, "key") <- pkey
attr(tbl, "index") <- index
attr(tbl, "interval") <- tbl_interval
output <- structure(tbl, class = cls_tbl)
return(output)
}

get_key <- function(tbl_ts) {
attr(tbl_ts, "key")
}

get_interval <- function(tbl_ts) {
attr(tbl_ts, "interval")
}

get_index <- function(tbl_ts) {
attr(tbl_ts, "index")
}

#' @export
print.tbl_ts <- function(x, ...) {
int_x <- get_interval(x)
grp_var <- get_key(x)
if (is_empty(grp_var)) {
cat("# A tsibble of", display_int(int_x), "time interval", "\n")
} else {
cat(
"# A tsibble of", display_int(int_x), "time interval", "for",
cat_chr(x, grp_var), "\n"
)
}
NextMethod()
}

#' @param ... Unquoted variable(s).
#' @rdname tsibble
#' @keywords internal
#' @export
key_vars <- function(...) {
return(quos(...))
}

cat_chr <- function(.data, ...) {
UseMethod("cat_chr")
}

cat_chr.tbl_ts <- function(.data, ...) { # ... is quos
paste(dots2str(...), collapse = ", ")
}

cat_chr.tbl_hts <- function(.data, ...) { # ... is quos
paste(dots2str(...), collapse = " | ")
}

cat_chr.tbl_gts <- function(.data, ...) { # ... is quos
paste(dots2str(...), collapse = " * ")
}

mts2tbl <- function(x, tz = "UTC") {
tbl <- bind_cols(time = time2date(x, tz = tz), as_tibble(x))
long_tbl <- tbl %>%
gather(key = key, value = value, -time)
return(long_tbl)
}

# recursive function to repeat nodes for hts
rep_nodes <- function(labels, nodes, level) {
labels <- rep(labels, nodes[[level]])
if (level == length(nodes)) {
return(labels)
} else {
return(rep_nodes(labels, nodes, level + 1))
}
}

9 R/type-sum.R
View file
@@ -0,0 +1,9 @@
#' @export
type_sum.yearmon <- function(x, ...) {
"yrmon"
}

#' @export
type_sum.yearqtr <- function(x, ...) {
"yrqtr"
}
14 R/utilities-rlang.R
View file
@@ -0,0 +1,14 @@
possibly_quosure <- function(x) {
check <- try(is_quosure(x), silent = TRUE)
ifelse(class(check) != "try-error", TRUE, FALSE)
}

possibly_identity <- function(x) { # x can be a list or a vector
any(vapply(x, function(x) x == 1, logical(1)))
}

dots2str <- function(...) { # list
peel <- map(..., get_expr) # quosure to expr
strs <- map_chr(peel, deparse) # expr to string
return(strs) # return a vector of characters
}
28 R/utilities.R
View file
@@ -0,0 +1,28 @@
## helper functions ------------------
min_na <- function(x) {
min(x, na.rm = TRUE)
}

max_na <- function(x) {
max(x, na.rm = TRUE)
}

expand.grid2 <- function(...) {
expand.grid(..., KEEP.OUT.ATTRS = FALSE, stringsAsFactors = FALSE)
}

is_constant <- function(x) {
return(diff(range(x, na.rm = TRUE)) < .Machine$double.eps ^ 0.5)
}

# Normalise the numerics to range from 0 to 1
normalise <- function(x, xmin = NULL, xmax = NULL) {
if (is_constant(x)) return(x)
if (is.null(xmin)) xmin <- min_na(x)
if (is.null(xmax)) xmax <- max_na(x)
return((x - xmin) / (xmax - xmin))
}

min_diff <- function(x) {
return(min(abs(diff(x, na.rm = TRUE))))
}
27 README.Rmd
View file
@@ -0,0 +1,27 @@
---
output:
github_document:
html_preview: false
---

<!-- README.md is generated from README.Rmd. Please edit that file -->

```{r, echo = FALSE}
knitr::opts_chunk$set(
collapse = TRUE, comment = "#>", fig.path = "man/figure/"
)
```

# sugrrants

[![Travis-CI Build Status](https://travis-ci.org/earowang/tsibble.svg?branch=master)](https://travis-ci.org/earowang/tsibble)
[![CRAN_Status_Badge](http://www.r-pkg.org/badges/version/tsibble)](https://cran.r-project.org/package=tsibble)

## Installation

You could install the development version from Github using

```r
# install.packages("devtools")
devtools::install_github("earowang/tsibble", build_vignettes = TRUE)
```
16 README.md
View file
@@ -0,0 +1,16 @@

<!-- README.md is generated from README.Rmd. Please edit that file -->
sugrrants
=========

[![Travis-CI Build Status](https://travis-ci.org/earowang/tsibble.svg?branch=master)](https://travis-ci.org/earowang/tsibble) [![CRAN\_Status\_Badge](http://www.r-pkg.org/badges/version/tsibble)](https://cran.r-project.org/package=tsibble)

Installation
------------

You could install the development version from Github using

``` r
# install.packages("devtools")
devtools::install_github("earowang/tsibble", build_vignettes = TRUE)
```
50 data-raw/read.R
View file
@@ -0,0 +1,50 @@
# Loading libraries -----------------------------------------------------------
library(tidyverse)
library(lubridate)

# Exchange rates
# ----------------------------written by @cpsievert---------------------------
# (1) Get a free plan from https://openexchangerates.org/signup/free
# (2) Tell this function your API key -- Sys.setenv("OER_KEY", "your-key-here")
# Sys.setenv("OER_KEY" = "")
getDay <- function(day) {
u <- sprintf(
"https://openexchangerates.org/api/historical/%s.json?app_id=%s",
day, Sys.getenv("OER_KEY")
)
res <- jsonlite::fromJSON(u)
res$rates$date <- as.POSIXct(res$timestamp, origin = "1970-01-01")
data.frame(res$rates)
}

getRates <- function(start = end - 3, end = Sys.Date()) {
days <- seq(start, end, by = "1 day")
Reduce("rbind", lapply(days, getDay))
}

xrates <- getRates(start = Sys.Date() - 60)
# --------------------------END------------------------------------------------

# BoM data
# devtools::install_github("toowoombatrio/bomrang")
library(bomrang)
sydney <- get_current_weather("Sydney Airport Amo")
melbourne <- get_current_weather("Melbourne Airport")
brisbane <- get_current_weather("Brisbane Aero")
perth <- get_current_weather("Perth Airport")
adelaide <- get_current_weather("Adalaide Airport")
hobart <- get_current_weather("Hobart Airport")
canberra <- get_current_weather("Canberra Airport")
darwin <- get_current_weather("Darwin Airport")
au_weather <- bind_rows(
sydney, melbourne, brisbane, perth, adelaide, hobart, canberra, darwin
)

# tidyverse core pkgs daily downloads
# devtools::install_github("metacran/cranlogs")
library(cranlogs)
start <- "2015-01-01"
end <- "2016-12-31"
pkgs <- c("ggplot2", "tibble", "tidyr", "readr", "purrr", "dplyr")
tidypkgs <- map_df(pkgs, ~ cran_downloads(.x, from = start, to = end))
devtools::use_data(tidypkgs, overwrite = TRUE)
58 man/as-tsibble.Rd
View file
42 man/reexports.Rd
View file
46 man/summarise.Rd
View file
44 man/tsibble.Rd
View file
21 tsibble.Rproj
View file
@@ -0,0 +1,21 @@
Version: 1.0

RestoreWorkspace: Default
SaveWorkspace: Default
AlwaysSaveHistory: Default
QuitChildProcessesOnExit: Default

EnableCodeIndexing: Yes
UseSpacesForTab: Yes
NumSpacesForTab: 2
Encoding: UTF-8

RnwWeave: knitr
LaTeX: pdfLaTeX

AutoAppendNewline: Yes
StripTrailingWhitespace: Yes

BuildType: Package
PackageUseDevtools: Yes
PackageInstallArgs: --no-multiarch --with-keep.source