1## ---- include = FALSE--------------------------------------------------------- 2knitr::opts_chunk$set( 3 collapse = TRUE, 4 comment = "#>" 5) 6set.seed(1014) 7 8## ----setup-------------------------------------------------------------------- 9library(vctrs) 10library(zeallot) 11 12## ----------------------------------------------------------------------------- 13new_percent <- function(x = double()) { 14 vec_assert(x, double()) 15 new_vctr(x, class = "vctrs_percent") 16} 17 18x <- new_percent(c(seq(0, 1, length.out = 4), NA)) 19x 20 21str(x) 22 23## ----------------------------------------------------------------------------- 24percent <- function(x = double()) { 25 x <- vec_cast(x, double()) 26 new_percent(x) 27} 28 29## ----------------------------------------------------------------------------- 30new_percent() 31percent() 32 33## ----------------------------------------------------------------------------- 34is_percent <- function(x) { 35 inherits(x, "vctrs_percent") 36} 37 38## ----------------------------------------------------------------------------- 39format.vctrs_percent <- function(x, ...) { 40 out <- formatC(signif(vec_data(x) * 100, 3)) 41 out[is.na(x)] <- NA 42 out[!is.na(x)] <- paste0(out[!is.na(x)], "%") 43 out 44} 45 46## ---- include = FALSE--------------------------------------------------------- 47# As of R 3.5, print.vctr can not find format.percent since it's not in 48# it's lexical environment. We fix that problem by manually registering. 49s3_register("base::format", "vctrs_percent") 50 51## ----------------------------------------------------------------------------- 52x 53 54## ----------------------------------------------------------------------------- 55data.frame(x) 56 57## ----------------------------------------------------------------------------- 58vec_ptype_abbr.vctrs_percent <- function(x, ...) { 59 "prcnt" 60} 61 62tibble::tibble(x) 63 64str(x) 65 66## ---- error = TRUE------------------------------------------------------------ 67vec_ptype2("bogus", percent()) 68vec_ptype2(percent(), NA) 69vec_ptype2(NA, percent()) 70 71## ----------------------------------------------------------------------------- 72vec_ptype2(percent(), percent()) 73 74## ----------------------------------------------------------------------------- 75vec_ptype2.vctrs_percent.vctrs_percent <- function(x, y, ...) new_percent() 76 77## ----------------------------------------------------------------------------- 78vec_ptype2.vctrs_percent.double <- function(x, y, ...) double() 79vec_ptype2.double.vctrs_percent <- function(x, y, ...) double() 80 81## ----------------------------------------------------------------------------- 82vec_ptype_show(percent(), double(), percent()) 83 84## ----------------------------------------------------------------------------- 85vec_cast.vctrs_percent.vctrs_percent <- function(x, to, ...) x 86 87## ----------------------------------------------------------------------------- 88vec_cast.vctrs_percent.double <- function(x, to, ...) percent(x) 89vec_cast.double.vctrs_percent <- function(x, to, ...) vec_data(x) 90 91## ----------------------------------------------------------------------------- 92vec_cast(0.5, percent()) 93vec_cast(percent(0.5), double()) 94 95## ---- error = TRUE------------------------------------------------------------ 96vec_c(percent(0.5), 1) 97vec_c(NA, percent(0.5)) 98# but 99vec_c(TRUE, percent(0.5)) 100 101x <- percent(c(0.5, 1, 2)) 102x[1:2] <- 2:1 103x[[3]] <- 0.5 104x 105 106## ---- error = TRUE------------------------------------------------------------ 107# Correct 108c(percent(0.5), 1) 109c(percent(0.5), factor(1)) 110 111# Incorrect 112c(factor(1), percent(0.5)) 113 114## ----------------------------------------------------------------------------- 115as_percent <- function(x) { 116 vec_cast(x, new_percent()) 117} 118 119## ----------------------------------------------------------------------------- 120as_percent <- function(x, ...) { 121 UseMethod("as_percent") 122} 123 124as_percent.default <- function(x, ...) { 125 vec_cast(x, new_percent()) 126} 127 128as_percent.character <- function(x) { 129 value <- as.numeric(gsub(" *% *$", "", x)) / 100 130 new_percent(value) 131} 132 133## ----------------------------------------------------------------------------- 134new_decimal <- function(x = double(), digits = 2L) { 135 vec_assert(x, ptype = double()) 136 vec_assert(digits, ptype = integer(), size = 1) 137 138 new_vctr(x, digits = digits, class = "vctrs_decimal") 139} 140 141decimal <- function(x = double(), digits = 2L) { 142 x <- vec_cast(x, double()) 143 digits <- vec_recycle(vec_cast(digits, integer()), 1L) 144 145 new_decimal(x, digits = digits) 146} 147 148digits <- function(x) attr(x, "digits") 149 150format.vctrs_decimal <- function(x, ...) { 151 sprintf(paste0("%-0.", digits(x), "f"), x) 152} 153 154vec_ptype_abbr.vctrs_decimal <- function(x, ...) { 155 "dec" 156} 157 158x <- decimal(runif(10), 1L) 159x 160 161## ----------------------------------------------------------------------------- 162x[1:2] 163x[[1]] 164 165## ----------------------------------------------------------------------------- 166vec_ptype_full.vctrs_decimal <- function(x, ...) { 167 paste0("decimal<", digits(x), ">") 168} 169 170x 171 172## ----------------------------------------------------------------------------- 173vec_ptype2.vctrs_decimal.vctrs_decimal <- function(x, y, ...) { 174 new_decimal(digits = max(digits(x), digits(y))) 175} 176vec_cast.vctrs_decimal.vctrs_decimal <- function(x, to, ...) { 177 new_decimal(vec_data(x), digits = digits(to)) 178} 179 180vec_c(decimal(1/100, digits = 3), decimal(2/100, digits = 2)) 181 182## ----------------------------------------------------------------------------- 183vec_ptype2.vctrs_decimal.double <- function(x, y, ...) x 184vec_ptype2.double.vctrs_decimal <- function(x, y, ...) y 185 186vec_cast.vctrs_decimal.double <- function(x, to, ...) new_decimal(x, digits = digits(to)) 187vec_cast.double.vctrs_decimal <- function(x, to, ...) vec_data(x) 188 189vec_c(decimal(1, digits = 1), pi) 190vec_c(pi, decimal(1, digits = 1)) 191 192## ---- error = TRUE------------------------------------------------------------ 193vec_cast(c(1, 2, 10), to = integer()) 194 195vec_cast(c(1.5, 2, 10.5), to = integer()) 196 197## ----------------------------------------------------------------------------- 198new_cached_sum <- function(x = double(), sum = 0L) { 199 vec_assert(x, ptype = double()) 200 vec_assert(sum, ptype = double(), size = 1L) 201 202 new_vctr(x, sum = sum, class = "vctrs_cached_sum") 203} 204 205cached_sum <- function(x) { 206 x <- vec_cast(x, double()) 207 new_cached_sum(x, sum(x)) 208} 209 210## ----------------------------------------------------------------------------- 211obj_print_footer.vctrs_cached_sum <- function(x, ...) { 212 cat("# Sum: ", format(attr(x, "sum"), digits = 3), "\n", sep = "") 213} 214 215x <- cached_sum(runif(10)) 216x 217 218## ----------------------------------------------------------------------------- 219vec_math.vctrs_cached_sum <- function(.fn, .x, ...) { 220 cat("Using cache\n") 221 switch(.fn, 222 sum = attr(.x, "sum"), 223 mean = attr(.x, "sum") / length(.x), 224 vec_math_base(.fn, .x, ...) 225 ) 226} 227 228sum(x) 229 230## ----------------------------------------------------------------------------- 231x[1:2] 232 233## ----------------------------------------------------------------------------- 234vec_restore.vctrs_cached_sum <- function(x, to, ..., i = NULL) { 235 new_cached_sum(x, sum(x)) 236} 237 238x[1] 239 240## ----------------------------------------------------------------------------- 241x <- as.POSIXlt(ISOdatetime(2020, 1, 1, 0, 0, 1:3)) 242x 243 244length(x) 245length(unclass(x)) 246 247x[[1]] # the first date time 248unclass(x)[[1]] # the first component, the number of seconds 249 250## ----------------------------------------------------------------------------- 251new_rational <- function(n = integer(), d = integer()) { 252 vec_assert(n, ptype = integer()) 253 vec_assert(d, ptype = integer()) 254 255 new_rcrd(list(n = n, d = d), class = "vctrs_rational") 256} 257 258## ----------------------------------------------------------------------------- 259rational <- function(n = integer(), d = integer()) { 260 c(n, d) %<-% vec_cast_common(n, d, .to = integer()) 261 c(n, d) %<-% vec_recycle_common(n, d) 262 263 new_rational(n, d) 264} 265 266x <- rational(1, 1:10) 267 268## ----------------------------------------------------------------------------- 269names(x) 270length(x) 271 272## ----------------------------------------------------------------------------- 273fields(x) 274field(x, "n") 275 276## ---- error = TRUE------------------------------------------------------------ 277x 278 279str(x) 280 281## ----------------------------------------------------------------------------- 282vec_data(x) 283 284str(vec_data(x)) 285 286## ----------------------------------------------------------------------------- 287format.vctrs_rational <- function(x, ...) { 288 n <- field(x, "n") 289 d <- field(x, "d") 290 291 out <- paste0(n, "/", d) 292 out[is.na(n) | is.na(d)] <- NA 293 294 out 295} 296 297vec_ptype_abbr.vctrs_rational <- function(x, ...) "rtnl" 298vec_ptype_full.vctrs_rational <- function(x, ...) "rational" 299 300x 301 302## ----------------------------------------------------------------------------- 303str(x) 304 305## ----------------------------------------------------------------------------- 306vec_ptype2.vctrs_rational.vctrs_rational <- function(x, y, ...) new_rational() 307vec_ptype2.vctrs_rational.integer <- function(x, y, ...) new_rational() 308vec_ptype2.integer.vctrs_rational <- function(x, y, ...) new_rational() 309 310vec_cast.vctrs_rational.vctrs_rational <- function(x, to, ...) x 311vec_cast.double.vctrs_rational <- function(x, to, ...) field(x, "n") / field(x, "d") 312vec_cast.vctrs_rational.integer <- function(x, to, ...) rational(x, 1) 313 314vec_c(rational(1, 2), 1L, NA) 315 316## ----------------------------------------------------------------------------- 317new_decimal2 <- function(l, r, scale = 2L) { 318 vec_assert(l, ptype = integer()) 319 vec_assert(r, ptype = integer()) 320 vec_assert(scale, ptype = integer(), size = 1L) 321 322 new_rcrd(list(l = l, r = r), scale = scale, class = "vctrs_decimal2") 323} 324 325decimal2 <- function(l, r, scale = 2L) { 326 l <- vec_cast(l, integer()) 327 r <- vec_cast(r, integer()) 328 c(l, r) %<-% vec_recycle_common(l, r) 329 scale <- vec_cast(scale, integer()) 330 331 # should check that r < 10^scale 332 new_decimal2(l = l, r = r, scale = scale) 333} 334 335format.vctrs_decimal2 <- function(x, ...) { 336 val <- field(x, "l") + field(x, "r") / 10^attr(x, "scale") 337 sprintf(paste0("%.0", attr(x, "scale"), "f"), val) 338} 339 340decimal2(10, c(0, 5, 99)) 341 342## ----------------------------------------------------------------------------- 343x <- rational(c(1, 2, 1, 2), c(1, 1, 2, 2)) 344x 345 346vec_proxy(x) 347 348x == rational(1, 1) 349 350## ----------------------------------------------------------------------------- 351# Thanks to Matthew Lundberg: https://stackoverflow.com/a/21504113/16632 352gcd <- function(x, y) { 353 r <- x %% y 354 ifelse(r, gcd(y, r), y) 355} 356 357vec_proxy_equal.vctrs_rational <- function(x, ...) { 358 n <- field(x, "n") 359 d <- field(x, "d") 360 gcd <- gcd(n, d) 361 362 data.frame(n = n / gcd, d = d / gcd) 363} 364vec_proxy_equal(x) 365 366x == rational(1, 1) 367 368## ----------------------------------------------------------------------------- 369unique(x) 370 371## ----------------------------------------------------------------------------- 372sort(x) 373 374## ----------------------------------------------------------------------------- 375vec_proxy_compare.vctrs_rational <- function(x, ...) { 376 field(x, "n") / field(x, "d") 377} 378 379sort(x) 380 381## ----------------------------------------------------------------------------- 382new_poly <- function(x) { 383 new_list_of(x, ptype = integer(), class = "vctrs_poly") 384} 385 386poly <- function(...) { 387 x <- list(...) 388 x <- lapply(x, vec_cast, integer()) 389 new_poly(x) 390} 391 392vec_ptype_full.vctrs_poly <- function(x, ...) "polynomial" 393vec_ptype_abbr.vctrs_poly <- function(x, ...) "poly" 394 395format.vctrs_poly <- function(x, ...) { 396 format_one <- function(x) { 397 if (length(x) == 0) { 398 return("") 399 } else if (length(x) == 1) { 400 format(x) 401 } else { 402 suffix <- c(paste0("\u22C5x^", seq(length(x) - 1, 1)), "") 403 out <- paste0(x, suffix) 404 out <- out[x != 0L] 405 paste0(out, collapse = " + ") 406 } 407 } 408 vapply(x, format_one, character(1)) 409} 410 411obj_print_data.vctrs_poly <- function(x, ...) { 412 if (length(x) == 0) 413 return() 414 print(format(x), quote = FALSE) 415} 416 417p <- poly(1, c(1, 0, 1), c(1, 0, 0, 0, 2)) 418p 419 420## ----------------------------------------------------------------------------- 421class(p) 422p[2] 423p[[2]] 424 425## ----------------------------------------------------------------------------- 426p == poly(c(1, 0, 1)) 427 428## ---- error = TRUE------------------------------------------------------------ 429sort(p) 430 431## ----------------------------------------------------------------------------- 432vec_proxy_compare.vctrs_poly <- function(x, ...) { 433 x_raw <- vec_data(x) 434 # First figure out the maximum length 435 n <- max(vapply(x_raw, length, integer(1))) 436 437 # Then expand all vectors to this length by filling in with zeros 438 full <- lapply(x_raw, function(x) c(rep(0L, n - length(x)), x)) 439 440 # Then turn into a data frame 441 as.data.frame(do.call(rbind, full)) 442} 443 444sort(poly(3, 2, 1)) 445sort(poly(1, c(1, 0, 0), c(1, 0))) 446 447## ----------------------------------------------------------------------------- 448vec_arith.MYCLASS <- function(op, x, y, ...) { 449 UseMethod("vec_arith.MYCLASS", y) 450} 451vec_arith.MYCLASS.default <- function(op, x, y, ...) { 452 stop_incompatible_op(op, x, y) 453} 454 455## ----------------------------------------------------------------------------- 456vec_math.vctrs_cached_sum <- function(.fn, .x, ...) { 457 switch(.fn, 458 sum = attr(.x, "sum"), 459 mean = attr(.x, "sum") / length(.x), 460 vec_math_base(.fn, .x, ...) 461 ) 462} 463 464## ----------------------------------------------------------------------------- 465new_meter <- function(x) { 466 stopifnot(is.double(x)) 467 new_vctr(x, class = "vctrs_meter") 468} 469 470format.vctrs_meter <- function(x, ...) { 471 paste0(format(vec_data(x)), " m") 472} 473 474meter <- function(x) { 475 x <- vec_cast(x, double()) 476 new_meter(x) 477} 478 479x <- meter(1:10) 480x 481 482## ----------------------------------------------------------------------------- 483sum(x) 484mean(x) 485 486## ---- error = TRUE------------------------------------------------------------ 487x + 1 488meter(10) + meter(1) 489meter(10) * 3 490 491## ----------------------------------------------------------------------------- 492vec_arith.vctrs_meter <- function(op, x, y, ...) { 493 UseMethod("vec_arith.vctrs_meter", y) 494} 495vec_arith.vctrs_meter.default <- function(op, x, y, ...) { 496 stop_incompatible_op(op, x, y) 497} 498 499## ---- error = TRUE------------------------------------------------------------ 500vec_arith.vctrs_meter.vctrs_meter <- function(op, x, y, ...) { 501 switch( 502 op, 503 "+" = , 504 "-" = new_meter(vec_arith_base(op, x, y)), 505 "/" = vec_arith_base(op, x, y), 506 stop_incompatible_op(op, x, y) 507 ) 508} 509 510meter(10) + meter(1) 511meter(10) - meter(1) 512meter(10) / meter(1) 513meter(10) * meter(1) 514 515## ---- error = TRUE------------------------------------------------------------ 516vec_arith.vctrs_meter.numeric <- function(op, x, y, ...) { 517 switch( 518 op, 519 "/" = , 520 "*" = new_meter(vec_arith_base(op, x, y)), 521 stop_incompatible_op(op, x, y) 522 ) 523} 524vec_arith.numeric.vctrs_meter <- function(op, x, y, ...) { 525 switch( 526 op, 527 "*" = new_meter(vec_arith_base(op, x, y)), 528 stop_incompatible_op(op, x, y) 529 ) 530} 531 532meter(2) * 10 533meter(2) * as.integer(10) 53410 * meter(2) 535meter(20) / 10 53610 / meter(20) 537meter(20) + 10 538 539## ----------------------------------------------------------------------------- 540vec_arith.vctrs_meter.MISSING <- function(op, x, y, ...) { 541 switch(op, 542 `-` = x * -1, 543 `+` = x, 544 stop_incompatible_op(op, x, y) 545 ) 546} 547-meter(1) 548+meter(1) 549 550## ----eval = FALSE------------------------------------------------------------- 551# #' Internal vctrs methods 552# #' 553# #' @import vctrs 554# #' @keywords internal 555# #' @name pizza-vctrs 556# NULL 557 558## ----------------------------------------------------------------------------- 559new_percent <- function(x = double()) { 560 vec_assert(x, double()) 561 new_vctr(x, class = "pizza_percent") 562} 563 564## ----------------------------------------------------------------------------- 565# for compatibility with the S4 system 566methods::setOldClass(c("pizza_percent", "vctrs_vctr")) 567 568## ----------------------------------------------------------------------------- 569#' `percent` vector 570#' 571#' This creates a double vector that represents percentages so when it is 572#' printed, it is multiplied by 100 and suffixed with `%`. 573#' 574#' @param x A numeric vector 575#' @return An S3 vector of class `pizza_percent`. 576#' @export 577#' @examples 578#' percent(c(0.25, 0.5, 0.75)) 579percent <- function(x = double()) { 580 x <- vec_cast(x, double()) 581 new_percent(x) 582} 583 584## ----------------------------------------------------------------------------- 585#' @export 586#' @rdname percent 587is_percent <- function(x) { 588 inherits(x, "pizza_percent") 589} 590 591## ----------------------------------------------------------------------------- 592#' @param x 593#' * For `percent()`: A numeric vector 594#' * For `is_percent()`: An object to test. 595 596## ----eval = FALSE------------------------------------------------------------- 597# #' @export 598# format.pizza_percent <- function(x, ...) { 599# out <- formatC(signif(vec_data(x) * 100, 3)) 600# out[is.na(x)] <- NA 601# out[!is.na(x)] <- paste0(out[!is.na(x)], "%") 602# out 603# } 604# 605# #' @export 606# vec_ptype_abbr.pizza_percent <- function(x, ...) { 607# "prcnt" 608# } 609 610## ---- eval = FALSE------------------------------------------------------------ 611# #' @export 612# vec_ptype2.vctrs_percent.vctrs_percent <- function(x, y, ...) new_percent() 613# #' @export 614# vec_ptype2.double.vctrs_percent <- function(x, y, ...) double() 615# 616# #' @export 617# vec_cast.pizza_percent.pizza_percent <- function(x, to, ...) x 618# #' @export 619# vec_cast.pizza_percent.double <- function(x, to, ...) percent(x) 620# #' @export 621# vec_cast.double.pizza_percent <- function(x, to, ...) vec_data(x) 622 623## ---- eval = FALSE------------------------------------------------------------ 624# expect_error(vec_c(1, "a"), class = "vctrs_error_incompatible_type") 625 626