I'm trying to mimick tsibble::yearquarter in creating a yearsemester vctrs class, but the RStudio View() function behaves differently and just displays the unclass-ed version of the custom S3 class.
I narrowed down the behavior to strangeness in .rs.formatDataColumn, which calls format differently if you source this after trace(format).
I apologize for all the extra methods in here, but I'm not sure how to figure out which are causing the different call behavior of .rs.formatDataColumn. What method(s) do I need to ensure that View() works correctly with val_yearsemester?
# Packages --------------------------------------------
library(dplyr)
#>
#> Attaching package: 'dplyr'
#> The following objects are masked from 'package:stats':
#>
#> filter, lag
#> The following objects are masked from 'package:base':
#>
#> intersect, setdiff, setequal, union
library(glue)
#>
#> Attaching package: 'glue'
#> The following object is masked from 'package:dplyr':
#>
#> collapse
library(lubridate)
#>
#> Attaching package: 'lubridate'
#> The following objects are masked from 'package:base':
#>
#> date, intersect, setdiff, union
library(stringr)
library(tsibble)
#>
#> Attaching package: 'tsibble'
#> The following object is masked from 'package:lubridate':
#>
#> interval
library(unglue)
library(vctrs)
#>
#> Attaching package: 'vctrs'
#> The following object is masked from 'package:dplyr':
#>
#> data_frame
# Custom S3 class yearsemester ------------------------
# Modeled off of https://github.com/tidyverts/tsibble/blob/master/R/yearquarter.R
# Pull in a few private functions:
dont_know <- tsibble:::dont_know
bad_by <- tsibble:::bad_by
seq_date <- tsibble:::seq_date
semester_name_to_number <- function(x) {
x <- stringr::str_to_lower(x)
dplyr::case_when(
x == "spring" ~ 1L,
x == "fall" ~ 2L,
TRUE ~ NA_integer_
)
}
semester_number_to_name <- function(x) {
dplyr::case_when(
x == 1L ~ "spring",
x == 2L ~ "fall",
TRUE ~ NA_character_
)
}
# What follows is modeled off of tsibble::yearquarter
yearsemester <- function(x) {
UseMethod("yearsemester")
}
yearsemester.default <- function(x) {
dont_know(x, "yearsemester")
}
yearsemester.NULL <- function(x) {
new_yearsemester()
}
yearsemester.POSIXct <- function(x) {
new_yearsemester(lubridate::floor_date(lubridate::as_date(x), unit = "6 months"))
}
yearsemester.POSIXlt <- yearsemester.POSIXct
yearsemester.Date <- yearsemester.POSIXct
yearsemester.character <- function(x) {
# Used below to ensure that all columns exist
new_columns <- list(
year = NA_character_,
semester_number = NA_character_,
semester_name = NA_character_
)
unglue::unglue_data(
x,
patterns = c(
"{year=\\d+}{=\\s*[Ss]?}{semester_number=1|2}",
"{year=\\d+}{=\\s*}{semester_name=Spring|spring|Fall|fall}"
)
) %>%
# Ensure all columns exist
tibble::add_column(
!!!new_columns[!names(new_columns) %in% names(.)]
) %>%
dplyr::mutate_at(dplyr::vars(year, semester_number), base::as.integer) %>%
dplyr::mutate(
semester_number = dplyr::coalesce(semester_number, semester_name_to_number(semester_name)),
date = lubridate::make_date(
year = year,
month = 1L + 6L * (semester_number - 1L),
day = 1L
)
) %>%
dplyr::pull(date) %>%
new_yearsemester()
}
yearsemester.numeric <- function(x) {
new_yearsemester(0) + x
}
new_yearsemester <- function(x = double()) {
# Adding "Date" fixes View() display but breaks operations
# vctrs::new_vctr(x, class = c("yearsemester", "Date"))
vctrs::new_vctr(x, class = "yearsemester")
}
is_yearsemester <- function(x) {
base::inherits(x, "yearsemester")
}
is.numeric.yearsemester <- function(x) {
FALSE
}
tz.yearsemester <- function(x) {
"UTC"
}
vec_cast.yearsemester <- function(x, to, ...) {
UseMethod("vec_cast.yearsemester")
}
as.Date.yearsemester <- function(x, ...) {
vctrs::new_date(x)
}
vec_cast.Date.yearsemester <- function(x, to, ...) {
vctrs::new_date(x)
}
vec_cast.POSIXct.yearsemester <- function(x, to, ...) {
base::as.POSIXct(vctrs::new_date(x), ...)
}
vec_cast.double.yearsemester <- function(x, to, ...) {
base::as.double(
(lubridate::year(x) - 1970) * 2
+ (lubridate::month(x) - 1) / 6
)
}
vec_cast.integer.yearsemester <- function(x, to, ...) {
vctrs::vec_cast(
vctrs::vec_cast(x, to = double()),
to = to
)
}
vec_cast.yearsemester.double <- function(x, to, ...) {
yearsemester(x)
}
vec_cast.yearsemester.Date <- function(x, to, ...) {
vctrs::new_vctr(vctrs::vec_data(x), class = "yearsemester")
}
as.POSIXlt.yearsemester <- function(x, tz = "", ...) {
base::as.POSIXlt(vctrs::new_date(x), tz = tz, ...)
}
vec_cast.POSIXlt.yearsemester <- function(x, to, ...) {
base::as.POSIXlt(vctrs::new_date(x), ...)
}
vec_cast.yearsemester.yearsemester <- function(x, to, ...) {
new_yearsemester(x)
}
vec_cast.character.yearsemester <- function(x, to, ...) {
base::format(x)
}
vec_ptype2.yearsemester <- function(x, y, ...) {
UseMethod("vec_ptype2.yearsemester", y)
}
# I tried adding this to fix vctrs::vec_c(vctrs::new_datetime(0), new_yearsemester(0))
vec_ptype2.POSIXct <- function(x, y, ...) {
UseMethod("vec_ptype2.POSIXct", y)
}
vec_ptype2.yearsemester.POSIXct <- function(x, y, ...) {
vctrs::new_datetime()
}
vec_ptype2.POSIXct.yearsemester <- function(x, y, ...) {
vctrs::new_datetime()
}
vec_ptype2.yearsemester.Date <- function(x, y, ...) {
vctrs::new_date()
}
vec_ptype2.Date.yearsemester <- function(x, y, ...) {
vctrs::new_date()
}
vec_ptype2.yearsemester.yearsemester <- function(x, y, ...) {
new_yearsemester()
}
format.yearsemester <- function(x, format = "%Y %T", ...) {
# Also supports format = "%Y %T" for spring, fall
# Also supports format = "%YS%t" for 1/2
x <- lubridate::as_date(x)
year <- lubridate::year(x)
semester_number <- (lubridate::month(x) - 1L) / 6L + 1L
semester_name <- semester_number_to_name(semester_number)
glue_format <- format %>%
stringr::str_replace_all("%Y", "{ base::as.character(year) }") %>%
stringr::str_replace_all("%t", "{ base::as.character(semester_number) }") %>%
stringr::str_replace_all("%T", "{ semester_name }")
base::as.character(glue::glue(glue_format, .na = NULL))
}
# The default is fine: `getS3method("obj_print_data", "default")`
# obj_print_data.yearsemester <- function(x, ...) {
# if (length(x) == 0) return()
# print(format(x))
# }
vec_ptype_abbr.yearsemester <- function(x, ...) {
"ys"
}
Comparison of yearmonth to yearsemester
val_yearsemester <- yearsemester("2004 fall")
val_yearmonth <- tsibble::yearmonth("2004-07")
# Looks like .rs.formatDataColumn?
formatDataColumnish <- function(x, start = 1L, len = 1L, ...)
{
col <- x[start:min(NROW(x), start + len)]
if (is.numeric(col)) {
storage.mode(col) <- "double"
naVals <- is.na(col)
vals <- format(col, trim = TRUE, justify = "none",
...)
if (any(naVals)) {
vals[naVals] <- col[naVals]
}
vals
}
else {
as.character(col)
}
}
# works
print(format(val_yearmonth))
#> [1] "2004 Jul"
# works
print(format(val_yearsemester))
#> [1] "2004 fall"
# works
print(formatDataColumnish(val_yearmonth))
#> [1] "2004 Jul"
# works
print(formatDataColumnish(val_yearsemester))
#> [1] "2004 fall"
# works
print(.rs.formatDataColumn(val_yearmonth, 1L, 1L))
#> [1] "2004 Jul"
# doesn't work
print(.rs.formatDataColumn(val_yearsemester, 1L, 1L))
#> [1] "12600"
# works
# View(val_yearmonth)
# doesn't work
# View(val_yearsemester)
Session Info
print(sessionInfo())
#> R version 4.0.2 (2020-06-22)
#> Platform: x86_64-w64-mingw32/x64 (64-bit)
#> Running under: Windows 10 x64 (build 18363)
#>
#> Matrix products: default
#>
#> locale:
#> [1] LC_COLLATE=English_United States.1252
#> [2] LC_CTYPE=English_United States.1252
#> [3] LC_MONETARY=English_United States.1252
#> [4] LC_NUMERIC=C
#> [5] LC_TIME=English_United States.1252
#>
#> attached base packages:
#> [1] stats graphics grDevices datasets utils methods base
#>
#> other attached packages:
#> [1] vctrs_0.3.4.9000 unglue_0.1.0 tsibble_0.9.2 stringr_1.4.0
#> [5] lubridate_1.7.9 glue_1.4.2 dplyr_1.0.2
#>
#> loaded via a namespace (and not attached):
#> [1] Rcpp_1.0.5 knitr_1.30 magrittr_1.5
#> [4] tidyselect_1.1.0 anytime_0.3.9 lattice_0.20-41
#> [7] R6_2.4.1 rlang_0.4.8.9000 highr_0.8
#> [10] tools_4.0.2 grid_4.0.2 xfun_0.18
#> [13] ellipsis_0.3.1 htmltools_0.5.0.9001 yaml_2.2.1
#> [16] digest_0.6.25 tibble_3.0.3 lifecycle_0.2.0
#> [19] crayon_1.3.4 Matrix_1.2-18 purrr_0.3.4
#> [22] fs_1.5.0 evaluate_0.14 rmarkdown_2.5.0
#> [25] stringi_1.5.3 pillar_1.4.6 compiler_4.0.2
#> [28] generics_0.0.2 reticulate_1.16 jsonlite_1.7.1
#> [31] renv_0.12.0 pkgconfig_2.0.3
Created on 2020-10-23 by the reprex package (v0.3.0)