vctrs/0000755000176200001440000000000013623552332011417 5ustar liggesusersvctrs/NAMESPACE0000644000176200001440000004254713623211547012652 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method("!",vctrs_vctr) S3method("!=",vctrs_vctr) S3method("$",vctrs_list_of) S3method("$",vctrs_rcrd) S3method("$",vctrs_sclr) S3method("$",vctrs_vctr) S3method("$<-",vctrs_list_of) S3method("$<-",vctrs_rcrd) S3method("$<-",vctrs_sclr) S3method("$<-",vctrs_vctr) S3method("%%",vctrs_vctr) S3method("%/%",vctrs_vctr) S3method("&",vctrs_vctr) S3method("*",vctrs_vctr) S3method("+",vctrs_vctr) S3method("-",vctrs_vctr) S3method("/",vctrs_vctr) S3method("<",vctrs_vctr) S3method("<=",vctrs_vctr) S3method("==",vctrs_vctr) S3method(">",vctrs_vctr) S3method(">=",vctrs_vctr) S3method("[",vctrs_rcrd) S3method("[",vctrs_sclr) S3method("[",vctrs_unspecified) S3method("[",vctrs_vctr) S3method("[<-",vctrs_list_of) S3method("[<-",vctrs_rcrd) S3method("[<-",vctrs_sclr) S3method("[<-",vctrs_vctr) S3method("[[",vctrs_list_of) S3method("[[",vctrs_rcrd) S3method("[[",vctrs_sclr) S3method("[[",vctrs_vctr) S3method("[[<-",vctrs_list_of) S3method("[[<-",vctrs_rcrd) S3method("[[<-",vctrs_sclr) S3method("[[<-",vctrs_vctr) S3method("^",vctrs_vctr) S3method("dim<-",vctrs_sclr) S3method("dim<-",vctrs_vctr) S3method("dimnames<-",vctrs_sclr) S3method("dimnames<-",vctrs_vctr) S3method("is.na<-",vctrs_sclr) S3method("is.na<-",vctrs_vctr) S3method("length<-",vctrs_rcrd) S3method("length<-",vctrs_vctr) S3method("levels<-",vctrs_sclr) S3method("levels<-",vctrs_vctr) S3method("names<-",vctrs_sclr) S3method("names<-",vctrs_vctr) S3method("|",vctrs_vctr) S3method(Complex,vctrs_sclr) S3method(Math,vctrs_sclr) S3method(Math,vctrs_vctr) S3method(Ops,vctrs_sclr) S3method(Summary,vctrs_sclr) S3method(Summary,vctrs_vctr) S3method(anyDuplicated,vctrs_sclr) S3method(anyDuplicated,vctrs_vctr) S3method(anyNA,vctrs_vctr) S3method(as.Date,vctrs_sclr) S3method(as.Date,vctrs_vctr) S3method(as.POSIXct,vctrs_sclr) S3method(as.POSIXct,vctrs_vctr) S3method(as.POSIXlt,vctrs_vctr) S3method(as.character,vctrs_list_of) S3method(as.character,vctrs_sclr) S3method(as.character,vctrs_vctr) S3method(as.data.frame,vctrs_sclr) S3method(as.data.frame,vctrs_vctr) S3method(as.double,vctrs_sclr) S3method(as.double,vctrs_vctr) S3method(as.integer,vctrs_sclr) S3method(as.integer,vctrs_vctr) S3method(as.list,vctrs_list_of) S3method(as.list,vctrs_rcrd) S3method(as.list,vctrs_sclr) S3method(as.list,vctrs_vctr) S3method(as.logical,vctrs_sclr) S3method(as.logical,vctrs_vctr) S3method(as_list_of,list) S3method(as_list_of,vctrs_list_of) S3method(c,vctrs_sclr) S3method(c,vctrs_vctr) S3method(cnd_body,vctrs_error_cast_lossy) S3method(cnd_body,vctrs_error_recycle_incompatible_size) S3method(cnd_body,vctrs_error_subscript_oob) S3method(cnd_body,vctrs_error_subscript_type) S3method(cnd_header,vctrs_error_cast_lossy) S3method(cnd_header,vctrs_error_recycle_incompatible_size) S3method(cnd_header,vctrs_error_subscript_oob) S3method(cnd_header,vctrs_error_subscript_size) S3method(cnd_header,vctrs_error_subscript_type) S3method(conditionMessage,vctrs_error_cast_lossy) S3method(diff,vctrs_vctr) S3method(duplicated,vctrs_sclr) S3method(duplicated,vctrs_vctr) S3method(format,vctrs_group_rle) S3method(format,vctrs_list_of) S3method(format,vctrs_rcrd) S3method(format,vctrs_vctr) S3method(is.finite,vctrs_vctr) S3method(is.infinite,vctrs_vctr) S3method(is.na,vctrs_vctr) S3method(is.nan,vctrs_vctr) S3method(length,vctrs_rcrd) S3method(levels,vctrs_sclr) S3method(levels,vctrs_vctr) S3method(max,vctrs_vctr) S3method(mean,vctrs_vctr) S3method(median,vctrs_vctr) S3method(min,vctrs_vctr) S3method(names,vctrs_rcrd) S3method(obj_print_data,default) S3method(obj_print_data,vctrs_list_of) S3method(obj_print_data,vctrs_partial) S3method(obj_print_footer,default) S3method(obj_print_header,default) S3method(obj_print_header,vctrs_group_rle) S3method(obj_print_header,vctrs_partial) S3method(obj_str_data,default) S3method(obj_str_data,vctrs_rcrd) S3method(obj_str_footer,default) S3method(obj_str_header,default) S3method(print,vctrs_sclr) S3method(print,vctrs_unspecified) S3method(print,vctrs_vctr) S3method(quantile,vctrs_vctr) S3method(range,vctrs_vctr) S3method(rep,vctrs_rcrd) S3method(rep,vctrs_vctr) S3method(str,vctrs_vctr) S3method(summary,vctrs_sclr) S3method(summary,vctrs_vctr) S3method(t,vctrs_sclr) S3method(t,vctrs_vctr) S3method(unique,vctrs_sclr) S3method(unique,vctrs_vctr) S3method(vec_arith,Date) S3method(vec_arith,POSIXct) S3method(vec_arith,default) S3method(vec_arith,difftime) S3method(vec_arith,factor) S3method(vec_arith,logical) S3method(vec_arith,numeric) S3method(vec_arith.Date,Date) S3method(vec_arith.Date,POSIXct) S3method(vec_arith.Date,default) S3method(vec_arith.Date,difftime) S3method(vec_arith.Date,numeric) S3method(vec_arith.POSIXct,Date) S3method(vec_arith.POSIXct,POSIXct) S3method(vec_arith.POSIXct,default) S3method(vec_arith.POSIXct,difftime) S3method(vec_arith.POSIXct,numeric) S3method(vec_arith.difftime,Date) S3method(vec_arith.difftime,MISSING) S3method(vec_arith.difftime,POSIXct) S3method(vec_arith.difftime,default) S3method(vec_arith.difftime,difftime) S3method(vec_arith.difftime,numeric) S3method(vec_arith.logical,default) S3method(vec_arith.logical,logical) S3method(vec_arith.logical,numeric) S3method(vec_arith.numeric,Date) S3method(vec_arith.numeric,POSIXct) S3method(vec_arith.numeric,default) S3method(vec_arith.numeric,difftime) S3method(vec_arith.numeric,logical) S3method(vec_arith.numeric,numeric) S3method(vec_cast,Date) S3method(vec_cast,POSIXct) S3method(vec_cast,POSIXlt) S3method(vec_cast,character) S3method(vec_cast,complex) S3method(vec_cast,data.frame) S3method(vec_cast,default) S3method(vec_cast,difftime) S3method(vec_cast,double) S3method(vec_cast,factor) S3method(vec_cast,integer) S3method(vec_cast,integer64) S3method(vec_cast,list) S3method(vec_cast,logical) S3method(vec_cast,raw) S3method(vec_cast,vctrs_list_of) S3method(vec_cast,vctrs_rcrd) S3method(vec_cast,vctrs_vctr) S3method(vec_cast.Date,Date) S3method(vec_cast.Date,POSIXt) S3method(vec_cast.Date,character) S3method(vec_cast.Date,default) S3method(vec_cast.Date,double) S3method(vec_cast.Date,list) S3method(vec_cast.POSIXct,Date) S3method(vec_cast.POSIXct,POSIXct) S3method(vec_cast.POSIXct,POSIXlt) S3method(vec_cast.POSIXct,character) S3method(vec_cast.POSIXct,default) S3method(vec_cast.POSIXct,double) S3method(vec_cast.POSIXct,list) S3method(vec_cast.POSIXlt,Date) S3method(vec_cast.POSIXlt,POSIXct) S3method(vec_cast.POSIXlt,POSIXlt) S3method(vec_cast.POSIXlt,character) S3method(vec_cast.POSIXlt,default) S3method(vec_cast.POSIXlt,double) S3method(vec_cast.POSIXlt,list) S3method(vec_cast.character,character) S3method(vec_cast.character,default) S3method(vec_cast.character,difftime) S3method(vec_cast.character,double) S3method(vec_cast.character,factor) S3method(vec_cast.character,integer) S3method(vec_cast.character,integer64) S3method(vec_cast.character,list) S3method(vec_cast.character,logical) S3method(vec_cast.complex,complex) S3method(vec_cast.complex,default) S3method(vec_cast.complex,double) S3method(vec_cast.complex,integer) S3method(vec_cast.complex,list) S3method(vec_cast.complex,logical) S3method(vec_cast.data.frame,data.frame) S3method(vec_cast.data.frame,default) S3method(vec_cast.data.frame,list) S3method(vec_cast.difftime,default) S3method(vec_cast.difftime,difftime) S3method(vec_cast.difftime,double) S3method(vec_cast.difftime,list) S3method(vec_cast.double,character) S3method(vec_cast.double,default) S3method(vec_cast.double,double) S3method(vec_cast.double,integer) S3method(vec_cast.double,integer64) S3method(vec_cast.double,list) S3method(vec_cast.double,logical) S3method(vec_cast.factor,character) S3method(vec_cast.factor,default) S3method(vec_cast.factor,factor) S3method(vec_cast.factor,list) S3method(vec_cast.integer,character) S3method(vec_cast.integer,default) S3method(vec_cast.integer,double) S3method(vec_cast.integer,integer) S3method(vec_cast.integer,integer64) S3method(vec_cast.integer,list) S3method(vec_cast.integer,logical) S3method(vec_cast.integer64,character) S3method(vec_cast.integer64,default) S3method(vec_cast.integer64,double) S3method(vec_cast.integer64,integer) S3method(vec_cast.integer64,integer64) S3method(vec_cast.integer64,logical) S3method(vec_cast.list,data.frame) S3method(vec_cast.list,default) S3method(vec_cast.list,list) S3method(vec_cast.list,vctrs_list_of) S3method(vec_cast.list,vctrs_rcrd) S3method(vec_cast.list,vctrs_vctr) S3method(vec_cast.logical,character) S3method(vec_cast.logical,default) S3method(vec_cast.logical,double) S3method(vec_cast.logical,integer) S3method(vec_cast.logical,integer64) S3method(vec_cast.logical,list) S3method(vec_cast.logical,logical) S3method(vec_cast.raw,default) S3method(vec_cast.raw,list) S3method(vec_cast.raw,raw) S3method(vec_cast.vctrs_list_of,default) S3method(vec_cast.vctrs_list_of,list) S3method(vec_cast.vctrs_list_of,vctrs_list_of) S3method(vec_cast.vctrs_rcrd,default) S3method(vec_cast.vctrs_rcrd,vctrs_rcrd) S3method(vec_cast.vctrs_vctr,default) S3method(vec_math,Date) S3method(vec_math,POSIXct) S3method(vec_math,default) S3method(vec_math,factor) S3method(vec_math,vctrs_rcrd) S3method(vec_proxy,AsIs) S3method(vec_proxy,Date) S3method(vec_proxy,POSIXct) S3method(vec_proxy,POSIXlt) S3method(vec_proxy,default) S3method(vec_proxy,vctrs_list_of) S3method(vec_proxy,vctrs_rcrd) S3method(vec_proxy,vctrs_vctr) S3method(vec_proxy_compare,POSIXlt) S3method(vec_proxy_compare,data.frame) S3method(vec_proxy_compare,default) S3method(vec_proxy_compare,integer64) S3method(vec_proxy_compare,raw) S3method(vec_proxy_compare,vctrs_rcrd) S3method(vec_proxy_equal,default) S3method(vec_ptype2,Date) S3method(vec_ptype2,POSIXt) S3method(vec_ptype2,character) S3method(vec_ptype2,complex) S3method(vec_ptype2,data.frame) S3method(vec_ptype2,default) S3method(vec_ptype2,difftime) S3method(vec_ptype2,double) S3method(vec_ptype2,factor) S3method(vec_ptype2,integer) S3method(vec_ptype2,integer64) S3method(vec_ptype2,list) S3method(vec_ptype2,logical) S3method(vec_ptype2,ordered) S3method(vec_ptype2,raw) S3method(vec_ptype2,vctrs_list_of) S3method(vec_ptype2,vctrs_partial_factor) S3method(vec_ptype2,vctrs_partial_frame) S3method(vec_ptype2,vctrs_unspecified) S3method(vec_ptype2,vctrs_vctr) S3method(vec_ptype2.Date,Date) S3method(vec_ptype2.Date,POSIXt) S3method(vec_ptype2.Date,default) S3method(vec_ptype2.Date,vctrs_unspecified) S3method(vec_ptype2.POSIXt,Date) S3method(vec_ptype2.POSIXt,POSIXt) S3method(vec_ptype2.POSIXt,default) S3method(vec_ptype2.POSIXt,vctrs_unspecified) S3method(vec_ptype2.character,character) S3method(vec_ptype2.character,default) S3method(vec_ptype2.character,factor) S3method(vec_ptype2.character,ordered) S3method(vec_ptype2.character,vctrs_unspecified) S3method(vec_ptype2.complex,complex) S3method(vec_ptype2.complex,default) S3method(vec_ptype2.complex,double) S3method(vec_ptype2.complex,integer) S3method(vec_ptype2.data.frame,data.frame) S3method(vec_ptype2.data.frame,default) S3method(vec_ptype2.data.frame,vctrs_partial_frame) S3method(vec_ptype2.difftime,default) S3method(vec_ptype2.difftime,difftime) S3method(vec_ptype2.difftime,vctrs_unspecified) S3method(vec_ptype2.double,complex) S3method(vec_ptype2.double,default) S3method(vec_ptype2.double,double) S3method(vec_ptype2.double,integer) S3method(vec_ptype2.double,logical) S3method(vec_ptype2.double,vctrs_unspecified) S3method(vec_ptype2.factor,character) S3method(vec_ptype2.factor,default) S3method(vec_ptype2.factor,factor) S3method(vec_ptype2.factor,ordered) S3method(vec_ptype2.factor,vctrs_partial_factor) S3method(vec_ptype2.factor,vctrs_unspecified) S3method(vec_ptype2.integer,complex) S3method(vec_ptype2.integer,default) S3method(vec_ptype2.integer,double) S3method(vec_ptype2.integer,integer) S3method(vec_ptype2.integer,integer64) S3method(vec_ptype2.integer,logical) S3method(vec_ptype2.integer,vctrs_unspecified) S3method(vec_ptype2.integer64,default) S3method(vec_ptype2.integer64,integer) S3method(vec_ptype2.integer64,integer64) S3method(vec_ptype2.integer64,logical) S3method(vec_ptype2.integer64,vctrs_unspecified) S3method(vec_ptype2.list,default) S3method(vec_ptype2.list,list) S3method(vec_ptype2.list,vctrs_list_of) S3method(vec_ptype2.list,vctrs_unspecified) S3method(vec_ptype2.logical,default) S3method(vec_ptype2.logical,double) S3method(vec_ptype2.logical,integer) S3method(vec_ptype2.logical,integer64) S3method(vec_ptype2.logical,logical) S3method(vec_ptype2.logical,vctrs_unspecified) S3method(vec_ptype2.ordered,character) S3method(vec_ptype2.ordered,default) S3method(vec_ptype2.ordered,factor) S3method(vec_ptype2.ordered,ordered) S3method(vec_ptype2.ordered,vctrs_unspecified) S3method(vec_ptype2.raw,default) S3method(vec_ptype2.raw,raw) S3method(vec_ptype2.vctrs_list_of,default) S3method(vec_ptype2.vctrs_list_of,list) S3method(vec_ptype2.vctrs_list_of,vctrs_list_of) S3method(vec_ptype2.vctrs_list_of,vctrs_unspecified) S3method(vec_ptype2.vctrs_partial_factor,factor) S3method(vec_ptype2.vctrs_partial_factor,vctrs_partial_factor) S3method(vec_ptype2.vctrs_partial_frame,data.frame) S3method(vec_ptype2.vctrs_partial_frame,vctrs_partial_frame) S3method(vec_ptype_abbr,AsIs) S3method(vec_ptype_abbr,Date) S3method(vec_ptype_abbr,POSIXt) S3method(vec_ptype_abbr,data.frame) S3method(vec_ptype_abbr,default) S3method(vec_ptype_abbr,difftime) S3method(vec_ptype_abbr,factor) S3method(vec_ptype_abbr,integer64) S3method(vec_ptype_abbr,ordered) S3method(vec_ptype_abbr,vctrs_list_of) S3method(vec_ptype_abbr,vctrs_partial_factor) S3method(vec_ptype_abbr,vctrs_partial_frame) S3method(vec_ptype_abbr,vctrs_unspecified) S3method(vec_ptype_finalise,default) S3method(vec_ptype_finalise,vctrs_partial) S3method(vec_ptype_finalise,vctrs_partial_factor) S3method(vec_ptype_finalise,vctrs_partial_frame) S3method(vec_ptype_full,AsIs) S3method(vec_ptype_full,Date) S3method(vec_ptype_full,POSIXct) S3method(vec_ptype_full,POSIXlt) S3method(vec_ptype_full,data.frame) S3method(vec_ptype_full,default) S3method(vec_ptype_full,difftime) S3method(vec_ptype_full,factor) S3method(vec_ptype_full,integer64) S3method(vec_ptype_full,ordered) S3method(vec_ptype_full,vctrs_list_of) S3method(vec_ptype_full,vctrs_partial_factor) S3method(vec_ptype_full,vctrs_partial_frame) S3method(vec_restore,AsIs) S3method(vec_restore,data.frame) S3method(vec_restore,default) S3method(vec_restore,vctrs_rcrd) S3method(vec_restore,vctrs_vctr) S3method(xtfrm,vctrs_sclr) S3method(xtfrm,vctrs_vctr) export("%0%") export("field<-") export("vec_slice<-") export(MISSING) export(allow_lossy_cast) export(as_list_of) export(field) export(fields) export(is_list_of) export(is_partial) export(list_of) export(maybe_lossy_cast) export(n_fields) export(new_data_frame) export(new_date) export(new_datetime) export(new_duration) export(new_factor) export(new_list_of) export(new_ordered) export(new_partial) export(new_rcrd) export(new_vctr) export(num_as_location) export(num_as_location2) export(obj_print) export(obj_print_data) export(obj_print_footer) export(obj_print_header) export(obj_str) export(obj_str_data) export(obj_str_footer) export(obj_str_header) export(partial_factor) export(partial_frame) export(s3_register) export(stop_incompatible_cast) export(stop_incompatible_op) export(stop_incompatible_size) export(stop_incompatible_type) export(unspecified) export(validate_list_of) export(vec_arith) export(vec_arith.Date) export(vec_arith.POSIXct) export(vec_arith.difftime) export(vec_arith.logical) export(vec_arith.numeric) export(vec_arith_base) export(vec_as_index) export(vec_as_location) export(vec_as_location2) export(vec_as_names) export(vec_as_names_legacy) export(vec_as_subscript) export(vec_as_subscript2) export(vec_assert) export(vec_assign) export(vec_c) export(vec_cast) export(vec_cast.Date) export(vec_cast.POSIXct) export(vec_cast.POSIXlt) export(vec_cast.character) export(vec_cast.complex) export(vec_cast.data.frame) export(vec_cast.difftime) export(vec_cast.double) export(vec_cast.factor) export(vec_cast.integer) export(vec_cast.integer64) export(vec_cast.list) export(vec_cast.logical) export(vec_cast.raw) export(vec_cast.vctrs_list_of) export(vec_cast_common) export(vec_cbind) export(vec_chop) export(vec_compare) export(vec_count) export(vec_data) export(vec_default_cast) export(vec_default_ptype2) export(vec_duplicate_any) export(vec_duplicate_detect) export(vec_duplicate_id) export(vec_empty) export(vec_equal) export(vec_equal_na) export(vec_group_id) export(vec_group_loc) export(vec_group_rle) export(vec_in) export(vec_init) export(vec_init_along) export(vec_is) export(vec_is_empty) export(vec_is_list) export(vec_list_cast) export(vec_match) export(vec_math) export(vec_math_base) export(vec_order) export(vec_proxy) export(vec_proxy_compare) export(vec_proxy_equal) export(vec_ptype) export(vec_ptype2) export(vec_ptype2.Date) export(vec_ptype2.POSIXt) export(vec_ptype2.character) export(vec_ptype2.complex) export(vec_ptype2.data.frame) export(vec_ptype2.difftime) export(vec_ptype2.double) export(vec_ptype2.factor) export(vec_ptype2.integer) export(vec_ptype2.integer64) export(vec_ptype2.list) export(vec_ptype2.logical) export(vec_ptype2.ordered) export(vec_ptype2.raw) export(vec_ptype2.vctrs_list_of) export(vec_ptype2.vctrs_unspecified) export(vec_ptype_abbr) export(vec_ptype_common) export(vec_ptype_finalise) export(vec_ptype_full) export(vec_ptype_show) export(vec_rbind) export(vec_recycle) export(vec_recycle_common) export(vec_repeat) export(vec_restore) export(vec_seq_along) export(vec_size) export(vec_size_common) export(vec_slice) export(vec_sort) export(vec_split) export(vec_type) export(vec_type2) export(vec_type_common) export(vec_unique) export(vec_unique_count) export(vec_unique_loc) import(rlang) importFrom(stats,median) importFrom(stats,quantile) useDynLib(vctrs, .registration = TRUE) vctrs/README.md0000644000176200001440000000737713622451540012712 0ustar liggesusers # vctrs [![Coverage status](https://codecov.io/gh/r-lib/vctrs/branch/master/graph/badge.svg)](https://codecov.io/github/r-lib/vctrs?branch=master) [![Lifecycle: maturing](https://img.shields.io/badge/lifecycle-maturing-blue.svg)](https://www.tidyverse.org/lifecycle/#maturing) ![R build status](https://github.com/r-lib/vctrs/workflows/R-CMD-check/badge.svg) There are three main goals to the vctrs package, each described in a vignette: - To propose `vec_size()` and `vec_ptype()` as alternatives to `length()` and `class()`; `vignette("type-size")`. These definitions are paired with a framework for size-recycling and type-coercion. `ptype` should evoke the notion of a prototype, i.e. the original or typical form of something. - To define size- and type-stability as desirable function properties, use them to analyse existing base functions, and to propose better alternatives; `vignette("stability")`. This work has been particularly motivated by thinking about the ideal properties of `c()`, `ifelse()`, and `rbind()`. - To provide a new `vctr` base class that makes it easy to create new S3 vectors; `vignette("s3-vector")`. vctrs provides methods for many base generics in terms of a few new vctrs generics, making implementation considerably simpler and more robust. vctrs is a developer-focussed package. Understanding and extending vctrs requires some effort from developers, but should be invisible to most users. It’s our hope that having an underlying theory will mean that users can build up an accurate mental model without explicitly learning the theory. vctrs will typically be used by other packages, making it easy for them to provide new classes of S3 vectors that are supported throughout the tidyverse (and beyond). For that reason, vctrs has few dependencies. ## Installation Install vctrs from CRAN with: ``` r install.packages("vctrs") ``` Alternatively, if you need the development version, install it with: ``` r # install.packages("devtools") devtools::install_github("r-lib/vctrs") ``` ## Usage ``` r library(vctrs) # Sizes str(vec_size_common(1, 1:10)) #> int 10 str(vec_recycle_common(1, 1:10)) #> List of 2 #> $ : num [1:10] 1 1 1 1 1 1 1 1 1 1 #> $ : int [1:10] 1 2 3 4 5 6 7 8 9 10 # Prototypes str(vec_ptype_common(FALSE, 1L, 2.5)) #> num(0) str(vec_cast_common(FALSE, 1L, 2.5)) #> List of 3 #> $ : num 0 #> $ : num 1 #> $ : num 2.5 ``` ## Motivation The original motivation for vctrs comes from two separate but related problems. The first problem is that `base::c()` has rather undesirable behaviour when you mix different S3 vectors: ``` r # combining factors makes integers c(factor("a"), factor("b")) #> [1] 1 1 # combining dates and date-times gives incorrect values; also, order matters dt <- as.Date("2020-01-01") dttm <- as.POSIXct(dt) c(dt, dttm) #> [1] "2020-01-01" "4321940-06-07" c(dttm, dt) #> [1] "2019-12-31 16:00:00 PST" "1969-12-31 21:04:22 PST" ``` This behaviour arises because `c()` has dual purposes: as well as its primary duty of combining vectors, it has a secondary duty of stripping attributes. For example, `?POSIXct` suggests that you should use `c()` if you want to reset the timezone. The second problem is that `dplyr::bind_rows()` is not extensible by others. Currently, it handles arbitrary S3 classes using heuristics, but these often fail, and it feels like we really need to think through the problem in order to build a principled solution. This intersects with the need to cleanly support more types of data frame columns, including lists of data frames, data frames, and matrices. vctrs/man/0000755000176200001440000000000013623045240012165 5ustar liggesusersvctrs/man/vec_duplicate.Rd0000644000176200001440000000377113622451540015276 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dictionary.R \name{vec_duplicate} \alias{vec_duplicate} \alias{vec_duplicate_any} \alias{vec_duplicate_detect} \alias{vec_duplicate_id} \title{Find duplicated values} \usage{ vec_duplicate_any(x) vec_duplicate_detect(x) vec_duplicate_id(x) } \arguments{ \item{x}{A vector (including a data frame).} } \value{ \itemize{ \item \code{vec_duplicate_any()}: a logical vector of length 1. \item \code{vec_duplicate_detect()}: a logical vector the same length as \code{x}. \item \code{vec_duplicate_id()}: an integer vector the same length as \code{x}. } } \description{ \itemize{ \item \code{vec_duplicate_any()}: detects the presence of duplicated values, similar to \code{\link[=anyDuplicated]{anyDuplicated()}}. \item \code{vec_duplicate_detect()}: returns a logical vector describing if each element of the vector is duplicated elsewhere. Unlike \code{\link[=duplicated]{duplicated()}}, it reports all duplicated values, not just the second and subsequent repetitions. \item \code{vec_duplicate_id()}: returns an integer vector giving the location of the first occurrence of the value. } } \section{Missing values}{ In most cases, missing values are not considered to be equal, i.e. \code{NA == NA} is not \code{TRUE}. This behaviour would be unappealing here, so these functions consider all \code{NAs} to be equal. (Similarly, all \code{NaN} are also considered to be equal.) } \examples{ vec_duplicate_any(1:10) vec_duplicate_any(c(1, 1:10)) x <- c(10, 10, 20, 30, 30, 40) vec_duplicate_detect(x) # Note that `duplicated()` doesn't consider the first instance to # be a duplicate duplicated(x) # Identify elements of a vector by the location of the first element that # they're equal to: vec_duplicate_id(x) # Location of the unique values: vec_unique_loc(x) # Equivalent to `duplicated()`: vec_duplicate_id(x) == seq_along(x) } \seealso{ \code{\link[=vec_unique]{vec_unique()}} for functions that work with the dual of duplicated values: unique values. } vctrs/man/vec_seq_along.Rd0000644000176200001440000000135513622451540015270 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/size.R \name{vec_seq_along} \alias{vec_seq_along} \alias{vec_init_along} \title{Useful sequences} \usage{ vec_seq_along(x) vec_init_along(x, y = x) } \arguments{ \item{x, y}{Vectors} } \value{ \itemize{ \item \code{vec_seq_along()} an integer vector with the same size as \code{x}. \item \code{vec_init_along()} a vector with the same type as \code{x} and the same size as \code{y}. } } \description{ \code{vec_seq_along()} is equivalent to \code{\link[=seq_along]{seq_along()}} but uses size, not length. \code{vec_init_along()} creates a vector of missing values with size matching an existing object. } \examples{ vec_seq_along(mtcars) vec_init_along(head(mtcars)) } vctrs/man/vec_list_cast.Rd0000644000176200001440000000142113622451540015277 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cast-list.R \name{vec_list_cast} \alias{vec_list_cast} \title{Cast a list to vector of specific type} \usage{ vec_list_cast(x, to, ..., x_arg = "", to_arg = "") } \arguments{ \item{x}{A list} \item{to}{Type to coerce to} \item{...}{These dots are for future extensions and must be empty.} } \description{ This is a function for developers to use when extending vctrs. It casts a list to a more specific vectoring type, keeping the length constant. It does this by discarding (with a warning), any elements after the 1. It is called from \code{vec_cast.XYZ.list()} methods to preserve symmetry with \code{vec_cast.list.XYZ()}. } \details{ See \code{vignette("s3-vector")} for details. } \keyword{internal} vctrs/man/vec_ptype2.Rd0000644000176200001440000000532013622451540014537 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/type-bare.R, R/type2.R \name{vec_ptype2.logical} \alias{vec_ptype2.logical} \alias{vec_ptype2.integer} \alias{vec_ptype2.double} \alias{vec_ptype2.complex} \alias{vec_ptype2.character} \alias{vec_ptype2.raw} \alias{vec_ptype2.list} \alias{vec_ptype2} \alias{vec_default_ptype2} \title{Find the common type for a pair of vector types} \usage{ \method{vec_ptype2}{logical}(x, y, ..., x_arg = "x", y_arg = "y") \method{vec_ptype2}{integer}(x, y, ..., x_arg = "x", y_arg = "y") \method{vec_ptype2}{double}(x, y, ..., x_arg = "x", y_arg = "y") \method{vec_ptype2}{complex}(x, y, ..., x_arg = "x", y_arg = "y") \method{vec_ptype2}{character}(x, y, ..., x_arg = "x", y_arg = "y") \method{vec_ptype2}{raw}(x, y, ..., x_arg = "x", y_arg = "y") \method{vec_ptype2}{list}(x, y, ..., x_arg = "x", y_arg = "y") vec_ptype2(x, y, ..., x_arg = "x", y_arg = "y") vec_default_ptype2(x, y, ..., x_arg = "x", y_arg = "y") } \arguments{ \item{x, y}{Vector types.} \item{...}{These dots are for future extensions and must be empty.} \item{x_arg, y_arg}{Argument names for \code{x} and \code{y}. These are used in error messages to inform the user about the locations of incompatible types (see \code{\link[=stop_incompatible_type]{stop_incompatible_type()}}).} } \description{ \code{vec_ptype2()} finds the common type for a pair of vectors, or dies trying. It forms the foundation of the vctrs type system, along with \code{\link[=vec_cast]{vec_cast()}}. This powers type coercion but should not usually be called directly; instead call \code{\link[=vec_ptype_common]{vec_ptype_common()}}. } \section{Coercion rules}{ vctrs thinks of the vector types as forming a partially ordered set, or poset. Then finding the common type from a set of types is a matter of finding the least-upper-bound; if the least-upper-bound does not exist, there is no common type. This is the case for many pairs of 1d vectors. The poset of the most important base vectors is shown below: (where datetime stands for \code{POSIXt}, and date for \code{Date}) \figure{coerce.png} } \section{S3 dispatch}{ \code{vec_ptype2()} dispatches on both arguments. This is implemented by having methods of \code{vec_ptype2()}, e.g. \code{vec_ptype2.integer()} also be S3 generics, which call e.g. \code{vec_ptype2.integer.double()}. \code{vec_ptype2.x.y()} must return the same value as \code{vec_ptype2.y.x()}; this is currently not enforced, but should be tested. Whenever you implement a \code{vec_ptype2.new_class()} generic/method, make sure to always provide \code{vec_ptype2.new_class.default()}. It should normally call \code{vec_default_ptype2()}. See \code{vignette("s3-vector")} for full details. } \keyword{internal} vctrs/man/new_rcrd.Rd0000644000176200001440000000167413622451540014272 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/type-rcrd.R \name{new_rcrd} \alias{new_rcrd} \alias{ses} \alias{rcrd} \title{rcrd (record) S3 class} \usage{ new_rcrd(fields, ..., class = character()) } \arguments{ \item{fields}{A list. It must possess the following properties: \itemize{ \item no attributes (apart from names) \item syntactic names \item length 1 or greater \item elements are vectors \item elements have equal length }} \item{...}{Additional attributes} \item{class}{Name of subclass.} } \description{ The rcrd class extends \link{vctr}. A rcrd is composed of 1 or more \link{field}s, which must be vectors of the same length. Is designed specifically for classes that can naturally be decomposed into multiple vectors of the same length, like \link{POSIXlt}, but where the organisation should be considered an implementation detail invisible to the user (unlike a \link{data.frame}). } \keyword{internal} vctrs/man/new_partial.Rd0000644000176200001440000000172313622451540014767 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/partial.R \name{new_partial} \alias{new_partial} \alias{is_partial} \alias{vec_ptype_finalise} \title{Partial type} \usage{ new_partial(..., class = character()) is_partial(x) vec_ptype_finalise(x, ...) } \arguments{ \item{...}{Attributes of the partial type} \item{class}{Name of subclass.} } \description{ Use \code{new_partial()} when constructing a new partial type subclass; and use \code{is_partial()} to test if an type is partial. All subclasses need to provide a \code{vec_ptype_finalise()} method. } \details{ As the name suggests, a partial type \emph{partially} specifies a type, and it must be combined with data to yield a full type. A useful example of a partial type is \code{\link[=partial_frame]{partial_frame()}}, which makes it possible to specify the type of just a few columns in a data frame. Use this constructor if you're making your own partial type. } \keyword{internal} vctrs/man/faq/0000755000176200001440000000000013622451540012737 5ustar liggesusersvctrs/man/faq/internal/0000755000176200001440000000000013622451540014553 5ustar liggesusersvctrs/man/faq/internal/ptype2-identity.Rmd0000644000176200001440000000612013622451540020270 0ustar liggesusers ```{r, child = "setup.Rmd", include = FALSE} ``` ## Promotion monoid Promotions (i.e. automatic coercions) should always transform inputs to their richer type to avoid losing values of precision. `vec_ptype2()` returns the _richer_ type of two vectors, or throws an incompatible type error if none of the two vector types include the other. For example, the richer type of integer and double is the latter because double covers a larger range of values than integer. `vec_ptype2()` is a [monoid](https://en.wikipedia.org/wiki/Monoid) over vectors, which in practical terms means that it is a well behaved operation for [reduction](https://purrr.tidyverse.org/reference/reduce.html). Reduction is an important operation for promotions because that is how the richer type of multiple elements is computed. As a monoid, `vec_ptype2()` needs an identity element, i.e. a value that doesn't change the result of the reduction. vctrs has two identity values, `NULL` and __unspecified__ vectors. ## The `NULL` identity As an identity element that shouldn't influence the determination of the common type of a set of vectors, `NULL` is promoted to any type: ```{r} vec_ptype2(NULL, "") vec_ptype2(1L, NULL) ``` The common type of `NULL` and `NULL` is the identity `NULL`: ```{r} vec_ptype2(NULL, NULL) ``` This way the result of `vec_ptype2(NULL, NULL)` does not influence subsequent promotions: ```{r} vec_ptype2( vec_ptype2(NULL, NULL), "" ) ``` ## Unspecified vectors In the vctrs coercion system, logical vectors of missing values are also automatically promoted to the type of any other vector, just like `NULL`. We call these vectors unspecified. The special coercion semantics of unspecified vectors serve two purposes: 1. It makes it possible to assign vectors of `NA` inside any type of vectors, even when they are not coercible with logical: ```{r} x <- letters[1:5] vec_assign(x, 1:2, c(NA, NA)) ``` 2. We can't put `NULL` in a data frame, so we need an identity element that behaves more like a vector. Logical vectors of `NA` seem a natural fit for this. Unspecified vectors are thus promoted to any other type, just like `NULL`: ```{r} vec_ptype2(NA, "") vec_ptype2(1L, c(NA, NA)) ``` ## Finalising common types vctrs has an internal vector type of class `vctrs_unspecified`. Users normally don't see such vectors in the wild, but they do come up when taking the common type of an unspecified vector with another identity value: ```{r} vec_ptype2(NA, NA) vec_ptype2(NA, NULL) vec_ptype2(NULL, NA) ``` We can't return `NA` here because `vec_ptype2()` normally returns empty vectors. We also can't return `NULL` because unspecified vectors need to be recognised as logical vectors if they haven't been promoted at the end of the reduction. ```{r} vec_ptype_finalise(vec_ptype2(NULL, NA)) ``` See the output of `vec_ptype_common()` which performs the reduction and finalises the type, ready to be used by the caller: ```{r} vec_ptype_common(NULL, NULL) vec_ptype_common(NA, NULL) ``` Note that __partial__ types in vctrs make use of the same mechanism. They are finalised with `vec_ptype_finalise()`. vctrs/man/faq/internal/setup.Rmd0000644000176200001440000000013213622451540016353 0ustar liggesusers ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` vctrs/man/vec_is_list.Rd0000644000176200001440000000154513623045211014762 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/assert.R \name{vec_is_list} \alias{vec_is_list} \title{Is the object a list?} \usage{ vec_is_list(x) } \arguments{ \item{x}{An object.} } \description{ \code{vec_is_list()} tests if \code{x} is considered a list in the vctrs sense. It returns \code{TRUE} if: \itemize{ \item \code{x} is a bare list with no class. \item \code{x} is a list explicitly inheriting from \code{"list"} or \code{"vctrs_list_of"}. \item \code{x} is an S3 list that \code{\link[=vec_is]{vec_is()}} returns \code{TRUE} for. For this to return \code{TRUE}, the class must implement a \code{\link[=vec_proxy]{vec_proxy()}} method. } } \details{ Notably, data frames and S3 record style classes like POSIXlt are not considered lists. } \examples{ vec_is_list(list()) vec_is_list(list_of(1)) vec_is_list(data.frame()) } vctrs/man/vctrs-conditions.Rd0000644000176200001440000000665513622451540016003 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/conditions.R \name{vctrs-conditions} \alias{vctrs-conditions} \alias{stop_incompatible_type} \alias{stop_incompatible_cast} \alias{stop_incompatible_op} \alias{stop_incompatible_size} \alias{maybe_lossy_cast} \alias{allow_lossy_cast} \title{Custom conditions for vctrs package} \usage{ stop_incompatible_type( x, y, x_arg = "", y_arg = "", details = NULL, ..., message = NULL, class = NULL ) stop_incompatible_cast( x, y, details = NULL, ..., x_arg = "", to_arg = "", message = NULL, class = NULL ) stop_incompatible_op( op, x, y, details = NULL, ..., message = NULL, class = NULL ) stop_incompatible_size( x, y, x_size, y_size, x_arg = "", y_arg = "", details = NULL, ..., message = NULL, class = NULL ) maybe_lossy_cast( result, x, to, lossy = NULL, locations = NULL, details = NULL, ..., x_arg = "", to_arg = "", message = NULL, class = NULL, .deprecation = FALSE ) allow_lossy_cast(expr, x_ptype = NULL, to_ptype = NULL) } \arguments{ \item{x, y}{Vectors} \item{details}{Any additional human readable details} \item{..., message, class}{Only use these fields when creating a subclass.} \item{result}{The result of a potentially lossy cast.} \item{to}{Type to cast to.} \item{lossy}{A logical vector indicating which elements of \code{result} were lossy. Can also be a single \code{TRUE}, but note that \code{locations} picks up locations from this vector by default. In this case, supply your own location vector, possibly empty.} \item{locations}{An optional integer vector giving the locations where \code{x} lost information.} \item{.deprecation}{If \code{TRUE}, the error is downgraded to a deprecation warning. This is useful for transitioning your class to a stricter conversion scheme. The warning advises your users to wrap their code with \code{allow_lossy_cast()}.} \item{x_ptype, to_ptype}{Suppress only the casting errors where \code{x} or \code{to} match these \link[=vec_ptype]{prototypes}.} \item{subclass}{Use if you want to further customise the class} } \value{ \verb{stop_incompatible_*()} unconditionally raise an error of class \code{"vctrs_error_incompatible_*"} and \code{"vctrs_error_incompatible"}. } \description{ These functions are called for their side effect of raising errors and warnings. These conditions have custom classes and structures to make testing easier. } \section{Lossy cast errors}{ By default, lossy casts are an error. Use \code{allow_lossy_cast()} to silence these errors and continue with the partial results. In this case the lost values are typically set to \code{NA} or to a lower value resolution, depending on the type of cast. Lossy cast errors are thrown by \code{maybe_lossy_cast()}. Unlike functions prefixed with \code{stop_}, \code{maybe_lossy_cast()} usually returns a result. If a lossy cast is detected, it throws an error, unless it's been wrapped in \code{allow_lossy_cast()}. In that case, it returns the result silently. } \examples{ # Most of the time, `maybe_lossy_cast()` returns its input normally: maybe_lossy_cast(c("foo", "bar"), NULL, "", lossy = c(FALSE, FALSE)) # If `lossy` has any `TRUE`, an error is thrown: try(maybe_lossy_cast(c("foo", "bar"), NULL, "", lossy = c(FALSE, TRUE))) # Unless lossy casts are allowed: allow_lossy_cast( maybe_lossy_cast(c("foo", "bar"), NULL, "", lossy = c(FALSE, TRUE)) ) } \keyword{internal} vctrs/man/vec_c.Rd0000644000176200001440000000563113622451540013543 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/c.R \name{vec_c} \alias{vec_c} \title{Combine many vectors into one vector} \usage{ vec_c( ..., .ptype = NULL, .name_spec = NULL, .name_repair = c("minimal", "unique", "check_unique", "universal") ) } \arguments{ \item{...}{Vectors to coerce.} \item{.ptype}{If \code{NULL}, the default, the output type is determined by computing the common type across all elements of \code{...}. Alternatively, you can supply \code{.ptype} to give the output known type. If \code{getOption("vctrs.no_guessing")} is \code{TRUE} you must supply this value: this is a convenient way to make production code demand fixed types.} \item{.name_spec}{A name specification for combining inner and outer names. This is relevant for inputs passed with a name, when these inputs are themselves named, like \code{outer = c(inner = 1)}, or when they have length greater than 1: \code{outer = 1:2}. By default, these cases trigger an error. You can resolve the error by providing a specification that describes how to combine the names or the indices of the inner vector with the name of the input. This specification can be: \itemize{ \item A function of two arguments. The outer name is passed as a string to the first argument, and the inner names or positions are passed as second argument. \item An anonymous function as a purrr-style formula. \item A glue specification of the form \code{"{outer}_{inner}"}. } See the \link[=name_spec]{name specification topic}.} \item{.name_repair}{How to repair names, see \code{repair} options in \code{\link[=vec_as_names]{vec_as_names()}}.} } \value{ A vector with class given by \code{.ptype}, and length equal to the sum of the \code{vec_size()} of the contents of \code{...}. The vector will have names if the individual components have names (inner names) or if the arguments are named (outer names). If both inner and outer names are present, an error is thrown unless a \code{.name_spec} is provided. } \description{ Combine all arguments into a new vector of common type. } \section{Invariants}{ \itemize{ \item \code{vec_size(vec_c(x, y)) == vec_size(x) + vec_size(y)} \item \code{vec_ptype(vec_c(x, y)) == vec_ptype_common(x, y)}. } } \examples{ vec_c(FALSE, 1L, 1.5) vec_c(FALSE, 1L, "x", .ptype = character()) # Date/times -------------------------- c(Sys.Date(), Sys.time()) c(Sys.time(), Sys.Date()) vec_c(Sys.Date(), Sys.time()) vec_c(Sys.time(), Sys.Date()) # Factors ----------------------------- c(factor("a"), factor("b")) vec_c(factor("a"), factor("b")) # By default, named inputs must be length 1: vec_c(name = 1) try(vec_c(name = 1:3)) # Pass a name specification to work around this: vec_c(name = 1:3, .name_spec = "{outer}_{inner}") # See `?name_spec` for more examples of name specifications. } \seealso{ \code{\link[=vec_cbind]{vec_cbind()}}/\code{\link[=vec_rbind]{vec_rbind()}} for combining data frames by rows or columns. } vctrs/man/vec_empty.Rd0000644000176200001440000000061513622451540014454 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/vctrs-deprecated.R \name{vec_empty} \alias{vec_empty} \title{Is a vector empty} \usage{ vec_empty(x) } \arguments{ \item{x}{An object.} } \description{ \Sexpr[results=rd, stage=render]{vctrs:::lifecycle("defunct")} This function is defunct, please use \code{\link[=vec_is_empty]{vec_is_empty()}}. } \keyword{internal} vctrs/man/internal-faq-ptype2-identity.Rd0000644000176200001440000001021313623013722020102 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/faq-internal.R \name{internal-faq-ptype2-identity} \alias{internal-faq-ptype2-identity} \title{Internal FAQ - \code{vec_ptype2()}, \code{NULL}, and unspecified vectors} \description{ \subsection{Promotion monoid}{ Promotions (i.e. automatic coercions) should always transform inputs to their richer type to avoid losing values of precision. \code{vec_ptype2()} returns the \emph{richer} type of two vectors, or throws an incompatible type error if none of the two vector types include the other. For example, the richer type of integer and double is the latter because double covers a larger range of values than integer. \code{vec_ptype2()} is a \href{https://en.wikipedia.org/wiki/Monoid}{monoid} over vectors, which in practical terms means that it is a well behaved operation for \href{https://purrr.tidyverse.org/reference/reduce.html}{reduction}. Reduction is an important operation for promotions because that is how the richer type of multiple elements is computed. As a monoid, \code{vec_ptype2()} needs an identity element, i.e. a value that doesn’t change the result of the reduction. vctrs has two identity values, \code{NULL} and \strong{unspecified} vectors. } \subsection{The \code{NULL} identity}{ As an identity element that shouldn’t influence the determination of the common type of a set of vectors, \code{NULL} is promoted to any type:\if{html}{\out{
}}\preformatted{vec_ptype2(NULL, "") #> character(0) vec_ptype2(1L, NULL) #> integer(0) }\if{html}{\out{
}} The common type of \code{NULL} and \code{NULL} is the identity \code{NULL}:\if{html}{\out{
}}\preformatted{vec_ptype2(NULL, NULL) #> NULL }\if{html}{\out{
}} This way the result of \code{vec_ptype2(NULL, NULL)} does not influence subsequent promotions:\if{html}{\out{
}}\preformatted{vec_ptype2( vec_ptype2(NULL, NULL), "" ) #> character(0) }\if{html}{\out{
}} } \subsection{Unspecified vectors}{ In the vctrs coercion system, logical vectors of missing values are also automatically promoted to the type of any other vector, just like \code{NULL}. We call these vectors unspecified. The special coercion semantics of unspecified vectors serve two purposes: \enumerate{ \item It makes it possible to assign vectors of \code{NA} inside any type of vectors, even when they are not coercible with logical:\if{html}{\out{
}}\preformatted{x <- letters[1:5] vec_assign(x, 1:2, c(NA, NA)) #> [1] NA NA "c" "d" "e" }\if{html}{\out{
}} \item We can’t put \code{NULL} in a data frame, so we need an identity element that behaves more like a vector. Logical vectors of \code{NA} seem a natural fit for this. } Unspecified vectors are thus promoted to any other type, just like \code{NULL}:\if{html}{\out{
}}\preformatted{vec_ptype2(NA, "") #> character(0) vec_ptype2(1L, c(NA, NA)) #> integer(0) }\if{html}{\out{
}} } \subsection{Finalising common types}{ vctrs has an internal vector type of class \code{vctrs_unspecified}. Users normally don’t see such vectors in the wild, but they do come up when taking the common type of an unspecified vector with another identity value:\if{html}{\out{
}}\preformatted{vec_ptype2(NA, NA) #> [0] vec_ptype2(NA, NULL) #> [0] vec_ptype2(NULL, NA) #> [0] }\if{html}{\out{
}} We can’t return \code{NA} here because \code{vec_ptype2()} normally returns empty vectors. We also can’t return \code{NULL} because unspecified vectors need to be recognised as logical vectors if they haven’t been promoted at the end of the reduction.\if{html}{\out{
}}\preformatted{vec_ptype_finalise(vec_ptype2(NULL, NA)) #> logical(0) }\if{html}{\out{
}} See the output of \code{vec_ptype_common()} which performs the reduction and finalises the type, ready to be used by the caller:\if{html}{\out{
}}\preformatted{vec_ptype_common(NULL, NULL) #> NULL vec_ptype_common(NA, NULL) #> logical(0) }\if{html}{\out{
}} Note that \strong{partial} types in vctrs make use of the same mechanism. They are finalised with \code{vec_ptype_finalise()}. } } vctrs/man/unspecified.Rd0000644000176200001440000000133613622451540014760 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/type-unspecified.R \name{unspecified} \alias{unspecified} \alias{vec_ptype2.vctrs_unspecified} \title{A 1d vector of unspecified type} \usage{ unspecified(n = 0) \method{vec_ptype2}{vctrs_unspecified}(x, y, ...) } \arguments{ \item{n}{Length of vector} } \description{ This is a \link[=new_partial]{partial type} used to represent logical vectors that only contain \code{NA}. These require special handling because we want to allow \code{NA} to specify missingness without requiring a type. } \examples{ vec_ptype_show() vec_ptype_show(NA) vec_c(NA, factor("x")) vec_c(NA, Sys.Date()) vec_c(NA, Sys.time()) vec_c(NA, list(1:3, 4:5)) } \keyword{internal} vctrs/man/vec_init.Rd0000644000176200001440000000057513622451540014266 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/slice.R \name{vec_init} \alias{vec_init} \title{Initialize a vector} \usage{ vec_init(x, n = 1L) } \arguments{ \item{x}{Template of vector to initialize.} \item{n}{Desired size of result.} } \description{ Initialize a vector } \examples{ vec_init(1:10, 3) vec_init(Sys.Date(), 5) vec_init(mtcars, 2) } vctrs/man/vec_proxy_compare.Rd0000644000176200001440000000244313622451540016206 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/compare.R \name{vec_proxy_compare} \alias{vec_proxy_compare} \title{Comparison proxy} \usage{ vec_proxy_compare(x, ..., relax = FALSE) } \arguments{ \item{x}{A vector x.} \item{...}{These dots are for future extensions and must be empty.} \item{relax}{If \code{TRUE}, and \code{x} is otherwise non-comparable, will return \code{vec_seq_along(x)}. This allows a data frame to be orderable, even if one of its components is not. This is experimental and may change in the future.} } \value{ A 1d atomic vector or a data frame. } \description{ Returns a proxy object (i.e. an atomic vector or data frame of atomic vectors). For \link{vctr}s, this determines the behaviour of \code{\link[=order]{order()}} and \code{\link[=sort]{sort()}} (via \code{\link[=xtfrm]{xtfrm()}}); \code{<}, \code{>}, \code{>=} and \code{<=} (via \code{\link[=vec_compare]{vec_compare()}}); and \code{\link[=min]{min()}}, \code{\link[=max]{max()}}, \code{\link[=median]{median()}}, and \code{\link[=quantile]{quantile()}}. } \details{ The default method assumes that all classes built on top of atomic vectors or records are orderable. If your class is not, you will need to provide a \code{vec_proxy_compare()} method that throws an error. } \keyword{internal} vctrs/man/new_date.Rd0000644000176200001440000000416513622451540014253 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/type-date-time.R \name{new_date} \alias{new_date} \alias{new_datetime} \alias{new_duration} \alias{vec_ptype2.Date} \alias{vec_ptype2.POSIXt} \alias{vec_ptype2.difftime} \alias{vec_cast.Date} \alias{vec_cast.POSIXct} \alias{vec_cast.POSIXlt} \alias{vec_cast.difftime} \alias{vec_arith.Date} \alias{vec_arith.POSIXct} \alias{vec_arith.difftime} \title{Date, date-time, and duration S3 classes} \usage{ new_date(x = double()) new_datetime(x = double(), tzone = "") new_duration(x = double(), units = c("secs", "mins", "hours", "days", "weeks")) \method{vec_ptype2}{Date}(x, y, ...) \method{vec_ptype2}{POSIXt}(x, y, ...) \method{vec_ptype2}{difftime}(x, y, ...) \method{vec_cast}{Date}(x, to, ...) \method{vec_cast}{POSIXct}(x, to, ...) \method{vec_cast}{POSIXlt}(x, to, ...) \method{vec_cast}{difftime}(x, to, ...) \method{vec_arith}{Date}(op, x, y, ...) \method{vec_arith}{POSIXct}(op, x, y, ...) \method{vec_arith}{difftime}(op, x, y, ...) } \arguments{ \item{x}{A double vector representing the number of days since UNIX epoch for \code{new_date()}, number of seconds since UNIX epoch for \code{new_datetime()}, and number of \code{units} for \code{new_duration()}.} \item{tzone}{Time zone. A character vector of length 1. Either \code{""} for the local time zone, or a value from \code{\link[=OlsonNames]{OlsonNames()}}} \item{units}{Units of duration.} } \description{ \itemize{ \item A \code{date} (\link{Date}) is a double vector. Its value represent the number of days since the Unix "epoch", 1970-01-01. It has no attributes. \item A \code{datetime} (\link{POSIXct} is a double vector. Its value represents the number of seconds since the Unix "Epoch", 1970-01-01. It has a single attribute: the timezone (\code{tzone})) \item A \code{duration} (\link{difftime}) } } \details{ These function help the base \code{Date}, \code{POSIXct}, and \code{difftime} classes fit into the vctrs type system by providing constructors, coercion functions, and casting functions. } \examples{ new_date(0) new_datetime(0, tzone = "UTC") new_duration(1, "hour") } \keyword{internal} vctrs/man/fields.Rd0000644000176200001440000000154213564465066013744 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fields.R \name{fields} \alias{fields} \alias{n_fields} \alias{field} \alias{field<-} \title{Tools for accessing the fields of a record.} \usage{ fields(x) n_fields(x) field(x, i) field(x, i) <- value } \arguments{ \item{x}{A \link{rcrd}, i.e. a list of equal length vectors with unique names.} } \description{ A \link{rcrd} behaves like a vector, so \code{length()}, \code{names()}, and \code{$} can not provide access to the fields of the underlying list. These helpers do: \code{fields()} is equivalent to \code{names()}; \code{n_fields()} is equivalent to \code{length()}; \code{field()} is equivalent to \code{$}. } \examples{ x <- new_rcrd(list(x = 1:3, y = 3:1, z = letters[1:3])) n_fields(x) fields(x) field(x, "y") field(x, "y") <- runif(3) field(x, "y") } \keyword{internal} vctrs/man/vctrs-package.Rd0000644000176200001440000000176013622451540015215 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/vctrs-package.R \docType{package} \name{vctrs-package} \alias{vctrs} \alias{vctrs-package} \title{vctrs: Vector Helpers} \description{ \if{html}{\figure{logo.png}{options: align='right'}} \Sexpr[results=rd, stage=render]{vctrs:::lifecycle("maturing")} Defines new notions of prototype and size that are used to provide tools for consistent and well-founded type-coercion and size-recycling, and are in turn connected to ideas of type- and size-stability useful for analysing function interfaces. } \seealso{ Useful links: \itemize{ \item \url{https://github.com/r-lib/vctrs} \item Report bugs at \url{https://github.com/r-lib/vctrs/issues} } } \author{ \strong{Maintainer}: Hadley Wickham \email{hadley@rstudio.com} Authors: \itemize{ \item Lionel Henry \email{lionel@rstudio.com} \item Davis Vaughan \email{davis@rstudio.com} } Other contributors: \itemize{ \item RStudio [copyright holder] } } \keyword{internal} vctrs/man/vec_equal.Rd0000644000176200001440000000245113622451540014425 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/equal.R \name{vec_equal} \alias{vec_equal} \alias{vec_equal_na} \title{Test if two vectors are equal} \usage{ vec_equal(x, y, na_equal = FALSE, .ptype = NULL) vec_equal_na(x) } \arguments{ \item{x}{Vectors with compatible types and lengths.} \item{y}{Vectors with compatible types and lengths.} \item{na_equal}{Should \code{NA} values be considered equal?} \item{.ptype}{Override to optionally specify common type} } \value{ A logical vector the same size as. Will only contain \code{NA}s if \code{na_equal} is \code{FALSE}. } \description{ \code{vec_equal_na()} tests a special case: equality with \code{NA}. It is similar to \link{is.na} but: \itemize{ \item Considers the missing element of a list to be \code{NULL}. \item Considered data frames and records to be missing if every component is missing. This preserves the invariant that \code{vec_equal_na(x)} is equal to \code{vec_equal(x, vec_init(x), na_equal = TRUE)}. } } \examples{ vec_equal(c(TRUE, FALSE, NA), FALSE) vec_equal(c(TRUE, FALSE, NA), FALSE, na_equal = TRUE) vec_equal_na(c(TRUE, FALSE, NA)) vec_equal(5, 1:10) vec_equal("d", letters[1:10]) df <- data.frame(x = c(1, 1, 2, 1, NA), y = c(1, 2, 1, NA, NA)) vec_equal(df, data.frame(x = 1, y = 2)) vec_equal_na(df) } vctrs/man/vec_group.Rd0000644000176200001440000000436713622451540014462 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/group.R \name{vec_group} \alias{vec_group} \alias{vec_group_id} \alias{vec_group_loc} \alias{vec_group_rle} \title{Identify groups} \usage{ vec_group_id(x) vec_group_loc(x) vec_group_rle(x) } \arguments{ \item{x}{A vector} } \value{ \itemize{ \item \code{vec_group_id()}: An integer vector with the same size as \code{x}. \item \code{vec_group_loc()}: A two column data frame with size equal to \code{vec_size(vec_unique(x))}. \itemize{ \item A \code{key} column of type \code{vec_ptype(x)} \item A \code{loc} column of type list, with elements of type integer. } \item \code{vec_group_rle()}: A \code{vctrs_group_rle} rcrd object with two integer vector fields: \code{group} and \code{length}. } Note that when using \code{vec_group_loc()} for complex types, the default \code{data.frame} print method will be suboptimal, and you will want to coerce into a tibble to better understand the output. } \description{ \Sexpr[results=rd, stage=render]{vctrs:::lifecycle("experimental")} \itemize{ \item \code{vec_group_id()} returns an identifier for the group that each element of \code{x} falls in, constructed in the order that they appear. The number of groups is also returned as an attribute, \code{n}. \item \code{vec_group_loc()} returns a data frame containing a \code{key} column with the unique groups, and a \code{loc} column with the locations of each group in \code{x}. \item \code{vec_group_rle()} locates groups in \code{x} and returns them run length encoded in the order that they appear. The return value is a rcrd object with fields for the \code{group} identifiers and the run \code{length} of the corresponding group. The number of groups is also returned as an attribute, \code{n}. } } \examples{ purrr <- c("p", "u", "r", "r", "r") vec_group_id(purrr) vec_group_rle(purrr) groups <- mtcars[c("vs", "am")] vec_group_id(groups) group_rle <- vec_group_rle(groups) group_rle # Access fields with `field()` field(group_rle, "group") field(group_rle, "length") # `vec_group_id()` is equivalent to vec_match(groups, vec_unique(groups)) vec_group_loc(mtcars$vs) vec_group_loc(mtcars[c("vs", "am")]) if (require("tibble")) { as_tibble(vec_group_loc(mtcars[c("vs", "am")])) } } \keyword{internal} vctrs/man/vec_arith.Rd0000644000176200001440000000373513622451540014433 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/arith.R \name{vec_arith} \alias{vec_arith} \alias{vec_arith.default} \alias{vec_arith.logical} \alias{vec_arith.numeric} \alias{vec_arith_base} \alias{MISSING} \title{Arithmetic operations} \usage{ vec_arith(op, x, y, ...) \method{vec_arith}{default}(op, x, y, ...) \method{vec_arith}{logical}(op, x, y, ...) \method{vec_arith}{numeric}(op, x, y, ...) vec_arith_base(op, x, y) MISSING() } \arguments{ \item{op}{An arithmetic operator as a string} \item{x, y}{A pair of vectors. For \code{!}, unary \code{+} and unary \code{-}, \code{y} will be a sentinel object of class \code{MISSING}, as created by \code{MISSING()}.} \item{...}{These dots are for future extensions and must be empty.} } \description{ This generic provides a common double dispatch mechanism for all infix operators (\code{+}, \code{-}, \code{/}, \code{*}, \code{^}, \code{\%\%}, \code{\%/\%}, \code{!}, \code{&}, \code{|}). It is used to power the default arithmetic and boolean operators for \link{vctr}s objects, overcoming the limitations of the base \link{Ops} generic. } \details{ \code{vec_arith_base()} is provided as a convenience for writing methods. It recycles \code{x} and \code{y} to common length then calls the base operator with the underlying \code{\link[=vec_data]{vec_data()}}. \code{vec_arith()} is also used in \code{diff.vctrs_vctr()} method via \code{-}. } \examples{ d <- as.Date("2018-01-01") dt <- as.POSIXct("2018-01-02 12:00") t <- as.difftime(12, unit = "hours") vec_arith("-", dt, 1) vec_arith("-", dt, t) vec_arith("-", dt, d) vec_arith("+", dt, 86400) vec_arith("+", dt, t) vec_arith("+", t, t) vec_arith("/", t, t) vec_arith("/", t, 2) vec_arith("*", t, 2) } \seealso{ \code{\link[=stop_incompatible_op]{stop_incompatible_op()}} for signalling that an arithmetic operation is not permitted/supported. See \code{\link[=vec_math]{vec_math()}} for the equivalent for the unary mathematical functions. } \keyword{internal} vctrs/man/vec_chop.Rd0000644000176200001440000000165213622451540014251 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/slice.R \name{vec_chop} \alias{vec_chop} \title{Repeatedly slice a vector} \usage{ vec_chop(x, indices = NULL) } \arguments{ \item{x}{A vector} \item{indices}{A list of index values to slice \code{x} with, or \code{NULL}. Each element of the list must be an integer, character or logical vector that would be valid as an index in \code{\link[=vec_slice]{vec_slice()}}. If \code{NULL}, \code{x} is split into its individual elements, equivalent to using an \code{indices} of \code{as.list(vec_seq_along(x))}.} } \value{ A list of size \code{vec_size(indices)} or, if \code{indices == NULL}, \code{vec_size(x)}. } \description{ \code{vec_chop()} provides an efficient method to repeatedly slice a vector. It captures the pattern of \code{map(indices, vec_slice, x = x)}. } \examples{ vec_chop(1:5) vec_chop(1:5, list(1, 1:2)) vec_chop(mtcars, list(1:3, 4:6)) } vctrs/man/op-empty-default.Rd0000644000176200001440000000101113622451540015644 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/size.R \name{\%0\%} \alias{\%0\%} \title{Default value for empty vectors} \usage{ x \%0\% y } \arguments{ \item{x}{A vector} \item{y}{Value to use if \code{x} is empty. To preserve type-stability, should be the same type as \code{x}.} } \description{ Use this inline operator when you need to provide a default value for empty (as defined by \code{\link[=vec_is_empty]{vec_is_empty()}}) vectors. } \examples{ 1:10 \%0\% 5 integer() \%0\% 5 } vctrs/man/name_spec.Rd0000644000176200001440000000501613622451540014413 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/names.R \name{name_spec} \alias{name_spec} \title{Name specifications} \arguments{ \item{name_spec, .name_spec}{A name specification for combining inner and outer names. This is relevant for inputs passed with a name, when these inputs are themselves named, like \code{outer = c(inner = 1)}, or when they have length greater than 1: \code{outer = 1:2}. By default, these cases trigger an error. You can resolve the error by providing a specification that describes how to combine the names or the indices of the inner vector with the name of the input. This specification can be: \itemize{ \item A function of two arguments. The outer name is passed as a string to the first argument, and the inner names or positions are passed as second argument. \item An anonymous function as a purrr-style formula. \item A glue specification of the form \code{"{outer}_{inner}"}. } See the \link[=name_spec]{name specification topic}.} } \description{ A name specification describes how to combine an inner and outer names. This sort of name combination arises when concatenating vectors or flattening lists. There are two possible cases: \itemize{ \item Named vector:\preformatted{vec_c(outer = c(inner1 = 1, inner2 = 2)) } \item Unnamed vector:\preformatted{vec_c(outer = 1:2) } } In r-lib and tidyverse packages, these cases are errors by default, because there's no behaviour that works well for every case. Instead, you can provide a name specification that describes how to combine the inner and outer names of inputs. Name specifications can refer to: \itemize{ \item \code{outer}: The external name recycled to the size of the input vector. \item \code{inner}: Either the names of the input vector, or a sequence of integer from 1 to the size of the vector if it is unnamed. } } \examples{ # By default, named inputs must be length 1: vec_c(name = 1) # ok try(vec_c(name = 1:3)) # bad # They also can't have internal names, even if scalar: try(vec_c(name = c(internal = 1))) # bad # Pass a name specification to work around this. A specification # can be a glue string referring to `outer` and `inner`: vec_c(name = 1:3, other = 4:5, .name_spec = "{outer}") vec_c(name = 1:3, other = 4:5, .name_spec = "{outer}_{inner}") # They can also be functions: my_spec <- function(outer, inner) paste(outer, inner, sep = "_") vec_c(name = 1:3, other = 4:5, .name_spec = my_spec) # Or purrr-style formulas for anonymous functions: vec_c(name = 1:3, other = 4:5, .name_spec = ~ paste0(.x, .y)) } vctrs/man/new_data_frame.Rd0000644000176200001440000000212613623032515015412 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/type-data-frame.R \name{new_data_frame} \alias{new_data_frame} \alias{vec_ptype2.data.frame} \alias{vec_cast.data.frame} \title{Data frame class} \usage{ new_data_frame(x = list(), n = NULL, ..., class = NULL) \method{vec_ptype2}{data.frame}(x, y, ...) \method{vec_cast}{data.frame}(x, to, ...) } \arguments{ \item{x}{A named list of equal-length vectors. The lengths are not checked; it is responsibility of the caller to make sure they are equal.} \item{n}{Number of rows. If \code{NULL}, will be computed from the length of the first element of \code{x}.} \item{..., class}{Additional arguments for creating subclasses.} } \description{ A \code{data.frame} \code{\link[=data.frame]{data.frame()}} is a list with "row.names" attribute. Each element of the list must be named, and of the same length. These functions help the base data.frame classes fit in to the vctrs type system by providing constructors, coercion functions, and casting functions. } \examples{ new_data_frame(list(x = 1:10, y = 10:1)) } \keyword{internal} vctrs/man/vec_order.Rd0000644000176200001440000000167713622451540014442 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/compare.R \name{vec_order} \alias{vec_order} \alias{vec_sort} \title{Order and sort vectors} \usage{ vec_order(x, direction = c("asc", "desc"), na_value = c("largest", "smallest")) vec_sort(x, direction = c("asc", "desc"), na_value = c("largest", "smallest")) } \arguments{ \item{x}{A vector} \item{direction}{Direction to sort in. Defaults to \code{asc}ending.} \item{na_value}{Should \code{NA}s be treated as the largest or smallest values?} } \value{ \itemize{ \item \code{vec_order()} an integer vector the same size as \code{x}. \item \code{vec_sort()} a vector with the same size and type as \code{x}. } } \description{ Order and sort vectors } \examples{ x <- round(c(runif(9), NA), 3) vec_order(x) vec_sort(x) vec_sort(x, "desc") # Can also handle data frames df <- data.frame(g = sample(2, 10, replace = TRUE), x = x) vec_order(df) vec_sort(df) vec_sort(df, "desc") } vctrs/man/vec_repeat.Rd0000644000176200001440000000166513622451540014604 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/size.R \name{vec_repeat} \alias{vec_repeat} \title{Expand the length of a vector} \usage{ vec_repeat(x, each = 1L, times = 1L) } \arguments{ \item{x}{A vector.} \item{each}{Number of times to repeat each element of \code{x}.} \item{times}{Number of times to repeat the whole vector of \code{x}.} } \value{ A vector the same type as \code{x} with size \code{vec_size(x) * times * each}. } \description{ This is a special case of \code{\link[=rep]{rep()}} for the special case of integer \code{times} and \code{each} values, and works along size, rather than length. } \examples{ # each repeats within vec_repeat(1:3, each = 2) # times repeats whole thing vec_repeat(1:3, times = 2) df <- data.frame(x = 1:2, y = 1:2) # rep() repeats columns of data frame, and returns list: rep(df, each = 2) # vec_repeat() repeats rows, and returns same data.frame vec_repeat(df, 2) } vctrs/man/vec_proxy_equal.Rd0000644000176200001440000000232613622451540015667 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/equal.R \name{vec_proxy_equal} \alias{vec_proxy_equal} \title{Equality proxy} \usage{ vec_proxy_equal(x, ...) } \arguments{ \item{x}{A vector x.} \item{...}{These dots are for future extensions and must be empty.} } \value{ A 1d atomic vector or a data frame. } \description{ Returns a proxy object (i.e. an atomic vector or data frame of atomic vectors). For \link{vctr}s, this determines the behaviour of \code{==} and \code{!=} (via \code{\link[=vec_equal]{vec_equal()}}); \code{\link[=unique]{unique()}}, \code{\link[=duplicated]{duplicated()}} (via \code{\link[=vec_unique]{vec_unique()}} and \code{\link[=vec_duplicate_detect]{vec_duplicate_detect()}}); \code{\link[=is.na]{is.na()}} and \code{\link[=anyNA]{anyNA()}} (via \code{\link[=vec_equal_na]{vec_equal_na()}}). } \details{ The default method calls \code{\link[=vec_proxy]{vec_proxy()}}, as the default underlying vector data should be equal-able in most cases. If your class is not equal-able, provide a \code{vec_proxy_equal()} method that throws an error. If the proxy for \code{x} is a data frame, \code{vec_proxy_equal()} is recursively applied on all columns as well. } \keyword{internal} vctrs/man/obj_print.Rd0000644000176200001440000000166513622451540014455 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/print-str.R \name{obj_print} \alias{obj_print} \alias{obj_print_header} \alias{obj_print_data} \alias{obj_print_footer} \alias{obj_str} \alias{obj_str_header} \alias{obj_str_data} \alias{obj_str_footer} \title{\code{print()} and \code{str()} generics.} \usage{ obj_print(x, ...) obj_print_header(x, ...) obj_print_data(x, ...) obj_print_footer(x, ...) obj_str(x, ...) obj_str_header(x, ...) obj_str_data(x, ...) obj_str_footer(x, ...) } \arguments{ \item{x}{A vector} \item{...}{Additional arguments passed on to methods. See \code{\link[=print]{print()}} and \code{\link[=str]{str()}} for commonly used options} } \description{ These are constructed to be more easily extensible since you can override the \verb{_header()}, \verb{_data()} or \verb{_footer()} components individually. The default methods are built on top of \code{format()}. } \keyword{internal} vctrs/man/vec_ptype.Rd0000644000176200001440000000632413622451540014462 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/type.R \name{vec_ptype} \alias{vec_ptype} \alias{vec_ptype_common} \alias{vec_ptype_show} \title{Find the prototype of a set of vectors} \usage{ vec_ptype(x) vec_ptype_common(..., .ptype = NULL) vec_ptype_show(...) } \arguments{ \item{..., x}{Vectors inputs} \item{.ptype}{If \code{NULL}, the default, the output type is determined by computing the common type across all elements of \code{...}. Alternatively, you can supply \code{.ptype} to give the output known type. If \code{getOption("vctrs.no_guessing")} is \code{TRUE} you must supply this value: this is a convenient way to make production code demand fixed types.} } \value{ \code{vec_ptype()} and \code{vec_ptype_common()} return a prototype (a size-0 vector) } \description{ \code{vec_ptype()} returns the unfinalised prototype of a single vector. \code{vec_ptype_common()} finds the common type of multiple vectors. \code{vec_ptype_show()} nicely prints the common type of any number of inputs, and is designed for interactive exploration. } \section{\code{vec_ptype()}}{ \code{vec_ptype()} returns \link[=vec_size]{size} 0 vectors potentially containing attributes but no data. Generally, this is just \code{vec_slice(x, 0L)}, but some inputs require special handling. \itemize{ \item While you can't slice \code{NULL}, the prototype of \code{NULL} is itself. This is because we treat \code{NULL} as an identity value in the \code{vec_ptype2()} monoid. \item The prototype of logical vectors that only contain missing values is the special \link{unspecified} type, which can be coerced to any other 1d type. This allows bare \code{NA}s to represent missing values for any 1d vector type. } See \link{internal-faq-ptype2-identity} for more information about identity values. Because it may contain unspecified vectors, the prototype returned by \code{vec_ptype()} is said to be \strong{unfinalised}. Call \code{\link[=vec_ptype_finalise]{vec_ptype_finalise()}} to finalise it. Commonly you will need the finalised prototype as returned by \code{vec_slice(x, 0L)}. } \section{\code{vec_ptype_common()}}{ \code{vec_ptype_common()} first finds the prototype of each input, then successively calls \code{\link[=vec_ptype2]{vec_ptype2()}} to find a common type. It returns a \link[=vec_ptype_finalise]{finalised} prototype. } \examples{ # Unknown types ------------------------------------------ vec_ptype_show() vec_ptype_show(NA) vec_ptype_show(NULL) # Vectors ------------------------------------------------ vec_ptype_show(1:10) vec_ptype_show(letters) vec_ptype_show(TRUE) vec_ptype_show(Sys.Date()) vec_ptype_show(Sys.time()) vec_ptype_show(factor("a")) vec_ptype_show(ordered("a")) # Matrices ----------------------------------------------- # The prototype of a matrix includes the number of columns vec_ptype_show(array(1, dim = c(1, 2))) vec_ptype_show(array("x", dim = c(1, 2))) # Data frames -------------------------------------------- # The prototype of a data frame includes the prototype of # every column vec_ptype_show(iris) # The prototype of multiple data frames includes the prototype # of every column that in any data frame vec_ptype_show( data.frame(x = TRUE), data.frame(y = 2), data.frame(z = "a") ) } vctrs/man/vec_as_names_legacy.Rd0000644000176200001440000000211413622451540016424 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/names.R \name{vec_as_names_legacy} \alias{vec_as_names_legacy} \title{Repair names with legacy method} \usage{ vec_as_names_legacy(names, prefix = "V", sep = "") } \arguments{ \item{names}{A character vector.} \item{prefix, sep}{Prefix and separator for repaired names.} } \description{ This standardises names with the legacy approach that was used in tidyverse packages (such as tibble, tidyr, and readxl) before \code{\link[=vec_as_names]{vec_as_names()}} was implemented. This tool is meant to help transitioning to the new name repairing standard and will be deprecated and removed from the package some time in the future. } \examples{ if (rlang::is_installed("tibble")) { library(tibble) # Names repair is turned off by default in tibble: try(tibble(a = 1, a = 2)) # You can turn it on by supplying a repair method: tibble(a = 1, a = 2, .name_repair = "universal") # If you prefer the legacy method, use `vec_as_names_legacy()`: tibble(a = 1, a = 2, .name_repair = vec_as_names_legacy) } } \keyword{internal} vctrs/man/vec_data.Rd0000644000176200001440000000507413622451540014233 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/proxy.R \name{vec_data} \alias{vec_data} \alias{vec_proxy} \title{Extract underlying data} \usage{ vec_data(x) vec_proxy(x, ...) } \arguments{ \item{x}{A vector or object implementing \code{vec_proxy()}.} \item{...}{These dots are for future extensions and must be empty.} } \value{ The data underlying \code{x}, free from any attributes except the names. } \description{ Extract the data underlying an S3 vector object, i.e. the underlying (named) atomic vector or list. \itemize{ \item \code{vec_data()} returns unstructured data. The only attributes preserved are names, dims, and dimnames. Currently, due to the underlying memory architecture of R, this creates a full copy of the data. \item \code{vec_proxy()} may return structured data. This generic is the main customisation point in vctrs, along with \code{\link[=vec_restore]{vec_restore()}}. See the section below to learn when you should implement \code{vec_proxy()}. Methods must return a vector type. Records and data frames will be processed rowwise. } } \section{When should you proxy your type}{ You should only implement \code{vec_proxy()} when your type is designed around a non-vector class. I.e. anything that is not either: \itemize{ \item An atomic vector \item A bare list \item A data frame } In this case, implement \code{vec_proxy()} to return such a vector class. The vctrs operations such as \code{\link[=vec_slice]{vec_slice()}} are applied on the proxy and \code{vec_restore()} is called to restore the original representation of your type. The most common case where you need to implement \code{vec_proxy()} is for S3 lists. In vctrs, S3 lists are treated as scalars by default. This way we don't treat objects like model fits as vectors. To prevent vctrs from treating your S3 list as a scalar, unclass it in the \code{vec_proxy()} method. For instance, here is the definition for \code{list_of}:\preformatted{vec_proxy.vctrs_list_of <- function(x) \{ unclass(x) \} } Another case where you need to implement a proxy is \link[=new_rcrd]{record types}. Record types should return a data frame, as in the \code{POSIXlt} method:\preformatted{vec_proxy.POSIXlt <- function(x) \{ new_data_frame(unclass(x)) \} } Note that you don't need to implement \code{vec_proxy()} when your class inherits from \code{vctrs_vctr} or \code{vctrs_rcrd}. } \seealso{ See \code{\link[=vec_restore]{vec_restore()}} for the inverse operation: it restores attributes given a bare vector and a prototype; \code{vec_restore(vec_data(x), x)} will always yield \code{x}. } vctrs/man/vec_math.Rd0000644000176200001440000000353313622451540014251 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/numeric.R \name{vec_math} \alias{vec_math} \alias{vec_math_base} \title{Mathematical operations} \usage{ vec_math(.fn, .x, ...) vec_math_base(.fn, .x, ...) } \arguments{ \item{.fn}{A mathematical function from the base package, as a string.} \item{.x}{A vector.} \item{...}{Additional arguments passed to \code{.fn}.} } \description{ This generic provides a common dispatch mechanism for all regular unary mathematical functions. It is used as a common wrapper around many of the Summary group generics, the Math group generics, and a handful of other mathematical functions like \code{mean()}. } \details{ \code{vec_math_base()} is provided as a convenience for writing methods. It calls the base \code{.fn} on the underlying \code{\link[=vec_data]{vec_data()}}. } \section{Included functions}{ \itemize{ \item From the \link{Summary} group generic: \code{prod()}, \code{sum()}, \code{any()}, \code{all()}. \item From the \link{Math} group generic: \code{abs()}, \code{sign()}, \code{sqrt()}, \code{ceiling()}, \code{floor()}, \code{trunc()}, \code{cummax()}, \code{cummin()}, \code{cumprod()}, \code{cumsum()}, \code{log()}, \code{log10()}, \code{log2()}, \code{log1p()}, \code{acos()}, \code{acosh()}, \code{asin()}, \code{asinh()}, \code{atan()}, \code{atanh()}, \code{exp()}, \code{expm1()}, \code{cos()}, \code{cosh()}, \code{cospi()}, \code{sin()}, \code{sinh()}, \code{sinpi()}, \code{tan()}, \code{tanh()}, \code{tanpi()}, \code{gamma()}, \code{lgamma()}, \code{digamma()}, \code{trigamma()}. \item Additional generics: \code{mean()}, \code{is.nan()}, \code{is.finite()}, \code{is.infinite()}. } } \examples{ x <- new_vctr(c(1, 2.5, 10)) x abs(x) sum(x) cumsum(x) } \seealso{ \code{\link[=vec_arith]{vec_arith()}} for the equivalent for the arithmetic infix operators. } \keyword{internal} vctrs/man/list_of.Rd0000644000176200001440000000370313622451540014121 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/type-list-of.R \name{list_of} \alias{list_of} \alias{as_list_of} \alias{validate_list_of} \alias{is_list_of} \alias{vec_ptype2.vctrs_list_of} \alias{vec_cast.vctrs_list_of} \title{\code{list_of} S3 class for homogenous lists} \usage{ list_of(..., .ptype = NULL) as_list_of(x, ...) validate_list_of(x) is_list_of(x) \method{vec_ptype2}{vctrs_list_of}(x, y, ..., x_arg = "x", y_arg = "y") \method{vec_cast}{vctrs_list_of}(x, to, ...) } \arguments{ \item{...}{Vectors to coerce.} \item{.ptype}{If \code{NULL}, the default, the output type is determined by computing the common type across all elements of \code{...}. Alternatively, you can supply \code{.ptype} to give the output known type. If \code{getOption("vctrs.no_guessing")} is \code{TRUE} you must supply this value: this is a convenient way to make production code demand fixed types.} \item{x}{For \code{as_list_of()}, a vector to be coerced to list_of.} \item{y, to}{Arguments to \code{vec_ptype2()} and \code{vec_cast()}.} \item{x_arg}{Argument names for \code{x} and \code{y}. These are used in error messages to inform the user about the locations of incompatible types (see \code{\link[=stop_incompatible_type]{stop_incompatible_type()}}).} \item{y_arg}{Argument names for \code{x} and \code{y}. These are used in error messages to inform the user about the locations of incompatible types (see \code{\link[=stop_incompatible_type]{stop_incompatible_type()}}).} } \description{ A \code{list_of} object is a list where each element has the same type. Modifying the list with \code{$}, \code{[}, and \code{[[} preserves the constraint by coercing all input items. } \details{ Unlike regular lists, setting a list element to \code{NULL} using \code{[[} does not remove it. } \examples{ x <- list_of(1:3, 5:6, 10:15) if (requireNamespace("tibble", quietly = TRUE)) { tibble::tibble(x = x) } vec_c(list_of(1, 2), list_of(FALSE, TRUE)) } vctrs/man/vec_default_cast.Rd0000644000176200001440000000232213622451540015751 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cast.R \name{vec_default_cast} \alias{vec_default_cast} \title{Default cast method} \usage{ vec_default_cast(x, to, x_arg = "x", to_arg = "to") } \arguments{ \item{x}{Vectors to cast.} \item{to}{Type to cast to. If \code{NULL}, \code{x} will be returned as is.} \item{x_arg}{Argument names for \code{x} and \code{to}. These are used in error messages to inform the user about the locations of incompatible types (see \code{\link[=stop_incompatible_type]{stop_incompatible_type()}}).} \item{to_arg}{Argument names for \code{x} and \code{to}. These are used in error messages to inform the user about the locations of incompatible types (see \code{\link[=stop_incompatible_type]{stop_incompatible_type()}}).} } \description{ This function should typically be called from the default \code{\link[=vec_cast]{vec_cast()}} method for your class, e.g. \code{vec_cast.myclass.default()}. It does two things: \itemize{ \item If \code{x} is an \link{unspecified} vector, it automatically casts it to \code{to} using \code{\link[=vec_init]{vec_init()}}. \item Otherwise, an error is thrown with \code{\link[=stop_incompatible_cast]{stop_incompatible_cast()}}. } } vctrs/man/vec_ptype_full.Rd0000644000176200001440000000206013622451540015475 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ptype-abbr-full.R \name{vec_ptype_full} \alias{vec_ptype_full} \alias{vec_ptype_abbr} \title{Vector type as a string} \usage{ vec_ptype_full(x, ...) vec_ptype_abbr(x, ...) } \arguments{ \item{x}{A vector.} \item{...}{These dots are for future extensions and must be empty.} } \value{ A string. } \description{ \code{vec_ptype_full()} displays the full type of the vector. \code{vec_ptype_abbr()} provides an abbreviated summary suitable for use in a column heading. } \section{S3 dispatch}{ The default method for \code{vec_ptype_full()} uses the first element of the class vector. Override this method if your class has parameters that should be prominently displayed. The default method for \code{vec_ptype_abbr()} \code{\link[=abbreviate]{abbreviate()}}s \code{vec_ptype_full()} to 8 characters. You should almost always override, aiming for 4-6 characters where possible. } \examples{ cat(vec_ptype_full(1:10)) cat(vec_ptype_full(iris)) cat(vec_ptype_abbr(1:10)) } \keyword{internal} vctrs/man/vec_type.Rd0000644000176200001440000000133313622451540014275 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/vctrs-deprecated.R \name{vec_type} \alias{vec_type} \alias{vec_type_common} \alias{vec_type2} \title{Deprecated type functions} \usage{ vec_type(x) vec_type_common(..., .ptype = NULL) vec_type2(x, y, ...) } \arguments{ \item{x, y, ..., .ptype}{Arguments for deprecated functions.} } \description{ \Sexpr[results=rd, stage=render]{vctrs:::lifecycle("deprecated")} These functions have been renamed: \itemize{ \item \code{vec_type()} => \code{\link[=vec_ptype]{vec_ptype()}} \item \code{vec_type2()} => \code{\link[=vec_ptype2]{vec_ptype2()}} \item \code{vec_type_common()} => \code{\link[=vec_ptype_common]{vec_ptype_common()}} } } \keyword{internal} vctrs/man/new_list_of.Rd0000644000176200001440000000075713622451540015000 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/type-list-of.R \name{new_list_of} \alias{new_list_of} \title{Create list_of subclass} \usage{ new_list_of(x = list(), ptype = logical(), ..., class = character()) } \arguments{ \item{x}{A list} \item{ptype}{The prototype which every element of \code{x} belongs to} \item{...}{Additional attributes used by subclass} \item{class}{Optional subclass name} } \description{ Create list_of subclass } \keyword{internal} vctrs/man/vec_cast.Rd0000644000176200001440000001476613622451540014264 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cast.R, R/proxy.R, R/type-bare.R \name{vec_cast} \alias{vec_cast} \alias{vec_cast_common} \alias{vec_restore} \alias{vec_cast.logical} \alias{vec_cast.integer} \alias{vec_cast.double} \alias{vec_cast.complex} \alias{vec_cast.raw} \alias{vec_cast.character} \alias{vec_cast.list} \title{Cast a vector to specified type} \usage{ vec_cast(x, to, ..., x_arg = "x", to_arg = "to") vec_cast_common(..., .to = NULL) vec_restore(x, to, ..., n = NULL) \method{vec_cast}{logical}(x, to, ...) \method{vec_cast}{integer}(x, to, ...) \method{vec_cast}{double}(x, to, ...) \method{vec_cast}{complex}(x, to, ...) \method{vec_cast}{raw}(x, to, ...) \method{vec_cast}{character}(x, to, ...) \method{vec_cast}{list}(x, to, ...) } \arguments{ \item{x}{Vectors to cast.} \item{to, .to}{Type to cast to. If \code{NULL}, \code{x} will be returned as is.} \item{...}{For \code{vec_cast_common()}, vectors to cast. For \code{vec_cast()} and \code{vec_restore()}, these dots are only for future extensions and should be empty.} \item{x_arg, to_arg}{Argument names for \code{x} and \code{to}. These are used in error messages to inform the user about the locations of incompatible types (see \code{\link[=stop_incompatible_type]{stop_incompatible_type()}}).} \item{n}{\Sexpr[results=rd, stage=render]{vctrs:::lifecycle("experimental")} The total size to restore to. This is currently passed by \code{vec_slice()} to solve edge cases arising in data frame restoration. In most cases you don't need this information and can safely ignore that argument. This parameter should be considered internal and experimental, it might change in the future.} } \value{ A vector the same length as \code{x} with the same type as \code{to}, or an error if the cast is not possible. An error is generated if information is lost when casting between compatible types (i.e. when there is no 1-to-1 mapping for a specific value). } \description{ \code{vec_cast()} provides general coercions from one type of vector to another, and along with \code{\link[=vec_ptype2]{vec_ptype2()}} forms the foundation of the vctrs type system. It should generally not be called by R users, but is important for R developers. \code{vec_restore()} is designed specifically for casting a bare vector to the original type; it's useful when relying \code{NextMethod()} for the actual implementation. \code{vec_cast_common(...)} casts a collection to vectors to the same type. } \section{Casting rules}{ Casting is more flexible than coercion, and allows for the possibility of information loss. This diagram summarises possible coercions. \code{vec_cast()} from any type connected to another type, provided that the arrows are followed in only one direction. For example you can cast from logical to character, and list to time, but you can not cast from logical to datetime. \figure{cast.png} Most casts are not symmetric: you can cast all integers to doubles, but you can only cast a subset of doubles back to integers. If a cast is potentially lossy, an error will be shown whenever an actual loss occurs. The rules for coercing from a list are fairly strict: each component of the list must be of length 1, and must be coercible to type \code{to}. This ensures that a round-trip to and form list is possible, without opening the door to very flexible list flattening (which should be the job of a more specialised function). } \section{S3 dispatch}{ \code{vec_cast()} dispatches on both arguments because casting depends on both the type of \code{x} and of \code{to}. This is implemented by having methods of \code{vec_cast()}, e.g. \code{vec_cast.integer()} also be S3 generics, which call e.g. \code{vec_cast.integer.double()}. Note that \code{vec_cast()} dispatches on its second argument, so that the name of the final method uses the same convention as \code{as.xyz()} methods, i.e. \code{vec_cast.integer.double()} casts double to integers, in the same way that \code{as.integer.double()} would. Whenever you implement a \code{vec_cast.new_class()} generic/method, make sure to always provide \code{vec_cast.new_class.default()} and call \code{\link[=vec_default_cast]{vec_default_cast()}} from that method. See \code{vignette("s3-vector")} for full details. } \section{Restoring attributes}{ A restore is a specialised type of cast, primarily used in conjunction with \code{NextMethod()} or a C-level function that works on the underlying data structure. A \code{vec_restore()} method can make the following assumptions about \code{x}: \itemize{ \item It has the correct type. \item It has the correct names. \item It has the correct \code{dim} and \code{dimnames} attributes. \item It is unclassed. This way you can call vctrs generics with \code{x} without triggering an infinite loop of restoration. } The length may be different (for example after \code{\link[=vec_slice]{vec_slice()}} has been called), and all other attributes may have been lost. The method should restore all attributes so that after restoration, \code{vec_restore(vec_data(x), x)} yields \code{x}. To understand the difference between \code{vec_cast()} and \code{vec_restore()} think about factors: it doesn't make sense to cast an integer to a factor, but if \code{NextMethod()} or another low-level function has stripped attributes, you still need to be able to restore them. The default method copies across all attributes so you only need to provide your own method if your attributes require special care (i.e. they are dependent on the data in some way). When implementing your own method, bear in mind that many R users add attributes to track additional metadata that is important to them, so you should preserve any attributes that don't require special handling for your class. } \examples{ # x is a double, but no information is lost vec_cast(1, integer()) # When information is lost the cast fails try(vec_cast(c(1, 1.5), integer())) try(vec_cast(c(1, 2), logical())) # You can suppress this error and get the partial results allow_lossy_cast(vec_cast(c(1, 1.5), integer())) allow_lossy_cast(vec_cast(c(1, 2), logical())) # By default this suppress all lossy cast errors without # distinction, but you can be specific about what cast is allowed # by supplying prototypes allow_lossy_cast(vec_cast(c(1, 1.5), integer()), to_ptype = integer()) try(allow_lossy_cast(vec_cast(c(1, 2), logical()), to_ptype = integer())) # No sensible coercion is possible so an error is generated try(vec_cast(1.5, factor("a"))) # Cast to common type vec_cast_common(factor("a"), factor(c("a", "b"))) } \keyword{internal} vctrs/man/figures/0000755000176200001440000000000013622451540013634 5ustar liggesusersvctrs/man/figures/sizes.graffle0000644000176200001440000000653013622451540016325 0ustar liggesusers]ks ]kFoN8& )" c3B'.[B:=}Q0{c?%h?'_ޞީ ZPa]Neu-X.u{(TFܸ: pߕ岤`TIu藻B/X]N@I #Tͺ:foNTݿYN:xOޜ+9s=g:)rIA/2䴼):TmtB1;m qYpELPYiժ,'EMu.2|#05_8Բ\ur7VNqŷk)sawJ+s6 }" vwN;^s^WMQy{L[ܮ+'[㙺i "7A۞9[hʑRL"E,G AÁT,cXpxWV,i"| *W ?U#sjo<-UZgnٍ%?0_nGW5i>XZkpy|ȿ^YZOJ}JZ3&[;ip 4DWNDYdQ S;@uPǔ1OT#оzʅM>h!luw-eWhe^:S|(:/QHLy/ˆJQT8VDAlX ]gLвX΢S1^gкZ~ )ۮL+8%EpY `p7-µJ]3vJ.m .;7A'g;1LIE A) /W?Q gВ$ "ا4Ṅ {5HTOiS>l[Y3Ӳ {,HKj E\@]QWjfr(1& 5 R((R+ 3<<1"2/& ߣO#6k<> lA/Ix=> ;pˆ5c)F,DܗT_KPgqL`&3QBd~/=OoMf5ѓmj(JŸbOF?'6>Z !*-]M^_>H4>la+!BO$! \ӳ`)䋊/xW3E ~6lDєXه B9%X8SoJzkwK0B^=}xU \^4Pom|*ΐnvt=ӹ*o ^{`]us=ٸ؈ "H$Qڽesl82r$VF9/A5UYnX@ý׆,{9qq:7] K5!D7mTW4=XQEPEW}6kj#m5Tu5?m v!jq˞j@^m]uK}n2 jOF.˗|WTn+-C>D)nŝІ"zhUHaFؗ4oaO/zޒyRɌJ-f<XA=PU[Yc!L|!>B|vK"sL /-*EW«dlQ-*EE_e-Ȓk^2 v6]Jx,a|ͤ#F>GH"=Loߦakm#2xz8k&>%GoR_$Qh !+^1#Gq,b1@+~h+=GxlڋtJ(i7 Ǒ5mABi8_{F L-٤(KZd(EԪ$/lR}vEl?/Yb8KKLI'dJ؊e;pB0!tN6Dٸ8"d44a)ÃFVJ%@хR2Hzc.>C:`ɶ9Od]!\5=չ4z*dž>DCa:F.9+Ta]8"~S71T|eC2eIh<úW7ѺXH2y|w?":3^HӸr<F|vctrs/man/figures/cast.png0000644000176200001440000003567513473164157015325 0ustar liggesusersPNG  IHDRTTSsRGB pHYs+ iTXtXML:com.adobe.xmp 2 5 1 2 Ү$9KIDATxyM.%".[I"RT(6$Z e -(囥URٲ!!m,Bз|{?9{q95y{f޳! ?WdX" W;E@ъW_m@D1D+^b~!Qx[@DGUl! WE@ъW_m@D1D+^b~!Qx[@DGUl! W~z…7gΜ &r?*=zۤ=q~%τޡykAط Wdm֮]q׮];o޼a  fΝ;wyK,9֭[Z5ΝrJL>c\ ,[Hw IÆ ر#㏦M6i0`@z!t2nܸ-[nz̘1i$)# O*>_:u*e|>}o~!%Jl޼w$eWm ,YǏڵg5GYr 4~ҥVzwرc}~< ЩSM6͚5M6oFڵQ% On! w I nΝׯ}͟?׮]ӦM$-I1)r!Fboo_fM2)T֭[gΜɂy*! WS&rСCY+^x…CGpBG}tƍMÛ޺73%c_nML2_НㄊsE"xB x|!)bLScꪫg1{X*馛q7bd S4(_5kH\rWv+Y/HE[o붮};vmNJ}O4|G`ӦM%K$~x ѭ%ߟ?8$EmB-=z:aOs0֪$R@@b )Z*Uq>J~{!$GUR!b=ЋbԵJ*@@̿zA@VIC/B :S*1p%-!Cܹ3X $cɒ%:ur-?0娃=ae…ո@E*2s3,[_K.}r!G}?A*U:,viXgҥ7onذ!qCtbݶmۂ lN>SO-R!SҴiS%\ҡCvj*Iȸ2(V=>d5kb PBק?&/C~ b~۷k׮X"Ae WKc=6֭[GW__hıݻW_}4`~|^a~wOIB&ʗNg2B+V0 3p}AL^6 9?FO233_wu29G7ָ[֭l28Hq' $ߘLuA1X}.D^yD? 3AwF O:?7WqhyAƍQ `bge?ߘI a8brqe?qM' f̘a=?CFxdxϢ{c g}QG[x& z'x" "CW5uT8r _m v:q{^K.]t$1aE!ugA(F7JIEݾtC۷ogbč7os;&yG!/q{s6Cʕ+e~l 5j`+fM>l@Oc.QL/qY>O;w.zn裏"f*Ȇ]^#'fҼm@(Z|C/w}Bˆ@DМ?b 1ڀ(bV-jB #Z* " h{QիW3Ƌ9hРD/b|!R[qO?tڽ ?3PJvl9;ѐ;%{Üf|8BÁiӦ@ 0"~ #zpK/弐11#RG>`Ǿ`<!1(<,q~f4waGNmP:={b>|8lرcU_/G b@իW?~5Chb3h^~RЕW^i)# B{ M rao f9τ@@1c:&|,| Ӓ3jϙ &3jt~@B~9d0ztAtFXg \BPqCGAFx0s5 ]{cZ)ゐw}jٲ%6,D"Xv#Uݙ4hyӧon=Ps e{L3sL. U)7k N1Ӝ?ĕBьMx9#ưJ QbUEyG4h5k9s d9)pyJ:^}Xf'8ƷQFr̉,t]WNTDI n5o/3cߣG.v^fiK܁[Gy$m[:|݇q ¹LJ삜 ׎ߴߟM;>Pr>ϝ/* q6JK1|&M*!gΝbA0^y@b`"{0?ٱr=B៵ &py ?v}N]6Rl[JO6,s. s`H VU s/XZ]%Qb:di\M8c=5#E$9WvmU^@7QkY& }6Ӝ?g5xmUq¡`7|!q)֭6XbqBD @l8%h0hz_~2a! LYg1Ig26iҤjժ1[V[b@+ENl;>q~[L1VnV}M-8ioF9T|9s7's2$/ܹ37_{ v4~Ls]C : _q8J>RY8BU^xVZl#|b3X#B>gW/?qԩlFoɃpt$gX9́r [.Bޓ|[ntڻw7xÓ h PbS:sG?|$RTo&wCRiӦ8xWȟ?F]k*YP_tޝN( 1G,qg&*}8_|p1YƍIwOSc9 Q4{5^{-]Oe05ȟMR 7j]_Z^:FLG/";[T?E JڶmyguV58GE'x"fP7xcab)dM ;Egg3fmh.ڪ96ZJ+ǏpTQTtj87ie/З_~AVVL?^zI8?hɿ+ G#/^b!v%KШRfX`gÅp¨ ?ZO>=*0s JK" ZǎID_~1Q#=իWF)Rvꫯ|a.;^_b;;8l߾I>c|ߩP ҝ\MEs` eX.ƃ:IY&eTaYQn5`1wd*" _*c{̵i.bCE0 kB}Du7 TlE~=L3 %oxNٲeZwq!H1 j'xwއ[l@P&"‹~ٯ[vq2%?;""h ?DL`'C}` R(J L/?<&bW1\X)GX֭e˖ 3תU`뮳7s<OI > }{xvȐ!#z{v>rGV1g7fAwsμ#?&^C ΐ<2(w¸ݵkW4tZSN[lXI!FgJUF>Y;WLaVBeGGoίN8]ilH&,~!" 0n?~4tץKE/ .>c7nv\P=&^fΜ8b!W2q 0C ,]@Iep=EZ&MB+>oذ᭷ڵk W|^IjC%KZSLRm0&iT? LZO9SO۰Ƿp{(i'F?b4 @xy=>%1N@DvLH]vYiX1s1%f‡_|nqOccO/"{o 80]ʰGq^t琁cSp(|80'xۣrEa9x8uL̐yؓntu1;An X:xJ^̂6visA<DǤ[戲 mgqC@CSNEVbۑk49kmn͌Ƈu], ڙ &pDs%)NbR'*d_=jNN%cQL]|'(0pa~R2H׷o_:ܪr#s[ċ"2s=}9FȨ*_۞DX! ǜ9s69T712[xfUB ]B>g s4zmڴ)coVn+096׳fN*?餓VK/GU -#cs7d訣P 0R9@8…+WMcr9W=fO?0Q0 $Qq%J>/IsE裏.ж<|G=DDs=G _VRG TK}m#ur=?;?\/ 0?'9K;zk7Q.]Xhٲ%?iҤP%2@HkÃ܀#y7o^A̱+;<0swx9s&JriX"W\2NJ#ؚUm槉Ϣ^*y(3 D{X(Q w1v$ԧ"EH2ebgʮ¦@2~Z|y8>7U ` z˫f@N2?&.ex̕XX%o߾=PD cƌa1,t"r K2 }yUȱ|5`Gb5sVL!(XDȥ o TC\UEG+ v[.{ɋӛ]L;\bꫯ+Iq*^'LJ.&j*BK/r?Spo-]Gcn]6Wٱ]]ImӦMk|ڸq+)`.`wsQjA9??eU1jp5hs'{l/4:Xbl6 HjdI9..+y٣@tڻ 2uqL2izz"xZ֜8ulcz?C5]C! /0bGB}#ל lM'ra% x0Y 䏅:\RAis AԴKx cuhY|' E2RɚU2kgd+vOWaA:AVjjKgT?cTS+gi?'xg۷TQHGs'K1QGy+ GsFsښHŊYi{>4`(G @bV@:D1X+'!(#C@I 1CrB ϙ3+T b9*RuЦuk|'so38?qTp1??hРoذaÆJ,ט)7)=7ons,W9\G XLvBo׮]L 7&~m֬YXˠP1qSD5=N;\H^d4@߹s' +K,iܸ1EjTaqOΙ0c.Ŧ7FRqBt> H36fL8>L/Ias֦d>#CI磏>ӯZJ r֝?9B0 ۠AAseP͋ŋ&;)Y$ͩggB;w\,)\ZT\l׮]oD*TeZ85M"b9.M֩SN.ꔦtR[c^y3Qkܺu+ի#1OΝ'蠸O>ĨօRUW]EFQ|T]joJMk,|]R7n ݻwǐ.7ܱcG,K+4d U \$$R!jzyR(Cs2MaiE@G?;ZKLf֪U$qDƏ?F?B Xm|!Ʊl '`?F3biMMvGi^_y̔>G.Xh`3s߆aD sC0iS$5x`fٸ}s1nu|B7?p,_y5З*U0j^bƠz嗓 @M41 ЙVvy (O)MP/Ttz.bsGn&>EA4P|~~̛ho 4$1SM$Q(;%w 5UR%3d~pԨQÄ10x'db;shH"痻@< H!>  m62&n ^ڤ@v/3 yj]^eg Α%R0Z 1DB 7ߴE^njv|؋M~5IkLyI<{=gRpO^3'ƃ}ex7s?c˗/X؀^~#Q׳>*2əv:ANݺu.[bǵtL'bŭj_:J(a qXy'Iv͚5oo`d1pFcPot7lK<50H֘LYl"IO;[;bW\T̟JN1pc"C1f:?yM|Et*4¦c_hт7B *tZp5tHtfNd 2s'.E͒ѣf4غC0VgIgxhm٩$19S8I Bm޸k8 3nwf9^ \,J!C k0IAZ$|fttdǃ,LYL13w2KXL>TM+&Iyp Y?Byl{NiEqYoI< L@lje_#sG”~@;]y9L~<ӻwo> f ̢_E5'esoFϞ=Am۲b"#+ RF~Ybdke$<32K|yb|M5RI00h̙Dz!Zn >,"Ebbzeۮ +`*7mv`pMSgD̓U˖-NDZ[uĨ|Ex 6f9xm'y03&8vX4&{Aج%e$,y\q5LV5QFFCK̆3G4(v猛Udm1|ɦ]"22_f Q2wK}PkDѳS̃P$Zɀ`Fa2yX3HRQ]veNF$b$jW_}J0y~.ʙX r+, SO\WMv&f2q6#SK"#>4Ob}.O{ C+J̉7&:`&t9nk4RgD̓ˀHm2--1C͞&"! \G mL[V2|׌!Bx>^*P3(8JA"JEBu2_s%(D[y ! Pe!'b~FZrJHxW϶9sc}YJ_2EߘŒIA ̑9#TH# s4MDFBT<{y9 JeDiڴ) Myq\p|[r,"]t9蠃L7x0;ލ)@ &e~Wsk5~1T%PbŊmڴ a*2<K/ 7SFX}FC2& kqlق ~3<3r^J*X|_!Xb~ \VŋsemDF;R3 le0!DM>&[ouҤI|| 70w+22ѢE Eڴ"J<}>PY̚5 z"&cCB j/QB #P*?*@@JV@<PbT(! 揇@Hs̙0aBA@x.\q qI"~7C I ҧ\A O8_~)I=8՗q qI"~g:utW0|l޼y0*{){ʔ)f%kΛ7/+Y+S!"i0?@ްaC͚5O;4۷z3_[.0kk.K ,1|[֨Q~;o_~A Vj?IsbI&1ĥ+W΂ӧs1+W&P_|q's1IU@^֧sεk6cǎ?+VVd ?ZyF >FXE{\`,ѷo_cdɒݺu;}ƽ={/&'OFM6(9fYu@ իW0(E-ZDg$.J{wM|lRrHiϸkCD YjBpdzj$gHhHx%KR1gCfсC6"'Eʗ-[F:uЯh *T`SCnnL1 iR0f>? ?k&;Dtk:u*3o#$B(|NucɟFm65d C@Jb''01sڴi/lց82>p>| srm@ZHC+&&휆ؒN919rsy(>]L_Š!TĸEuDaÆaߪZlɌ_\ti޽Y7Y\tE<̜i0l$~ 0+6ì+PjP 0%a}f?9@ ƌe*V4X#AP*|F %m?41Gemz!Z)@÷1c#|ur/+V@Dꩧ̔A-'LYq6ԗ5k 4ӗ]FwGcט]E9 '۱c5W:> 30K[fnT̢a׭[ǀo֢qml9 ve.(D1Ud?/0?r>܎ ?0eϔ)SAOI^{m2u`Y ٞc-w\p )Jȋ OHA_\99R>B@w?% B@@JiB@b&)G@>JQb&)G[3:QàIENDB`vctrs/man/figures/lifecycle-defunct.svg0000644000176200001440000000170413622451540017744 0ustar liggesuserslifecyclelifecycledefunctdefunct vctrs/man/figures/lifecycle-maturing.svg0000644000176200001440000000170613622451540020144 0ustar liggesuserslifecyclelifecyclematuringmaturing vctrs/man/figures/logo.png0000644000176200001440000024327413473164157015327 0ustar liggesusersPNG  IHDRޫhsRGB pHYs  iTXtXML:com.adobe.xmp Adobe ImageReady 1 ).=@IDATx^Gu/vz9X%↱ HM$@*7D 禓r)$@c H\{;M3|jH-o6kfϞgfM]/ؙ nlg og?2/G=r cǎܮ]̍\_iʇ*TD ?3?yȇle]/Ƚ^K1ÇclI>+lSF2Ll;7 =Аþk׋5j5͙Ztvms&qRXFWr0L\rL˃wfwؕu4;^ɮճ{2{5߳"WT* u咒h7[ gsy,*/Gݻ>ծ+?j|#hmjN?SꖕK ]n.dQClNJ)NKn/{ F0䏳/H]WnW)3}w˩S|\f\L 5ꜵ<7( oYmR)`ĝLfKWw-jpOfyVvHNl'\q9+.mڭ\`oѦpqVQzC !&PF`94lzrn 'Jىt@̀7cg{d^qW_|0Vʴ efЊ" dHe3?ozϨ{ɽ[ gf>psfD swؙ?1`VW%%sac{${ v`__6]*P@̀/;GݙlWP+ގ Rs2dΡvKMP 'Bf29z_ k8vj˔5LEtGߖ̮];uպo"/Zbfؠo:Si9'XA{lƏ"pܓ5q7L3_~^ >hXho_qET._U*~*`vX|Kjca,%aؐFᇥ84Ð*r vp9P3.}Ldfu?nLy86cr|SEexh"fd [!sOboxapeP%\_ِj/D eGʛ{5oQT~Y2q6[9c RR=ne ŢBy߈ ^eL3ox1~,{Pjjò<BٲWP-Jpaul3`x'xcT[sx('GY.eqQC !SŠtHXƱ;` vT1 jJ~uMP]Q`@J1Dx?Sck `ȥY`WڲE>^[̀L?Բ .%r׵aiX<ɨ2큋y74ha* s`^GQ;v- ;x.5~.stXBfq~l%K(o2|ˢ//2PsYa.<[g b+G.[ ;%\B5~r3t;VY,-x?V 53iƛMlLa{ vB^řL%J9{}ͲݔH]Y ;˷0T4qՎw7ԏ|C\a%hgb +7;-^сzR&! ca֣PO,ZH7;lN@rqO5bP6-3ɲ wo As9 2 )yǛ*ʇ}I0^4j4^3{כφ 9)qq@ H 4@zL՘K3712 B!>m<$-vEfT(vs6\) f+ Z$i. empy-WF6~2R5Y}{ Pd6Wׂ1QM8Z%m VTbI*DKs2N y HB{1D^!ЫȖ 2yl"@/8)~С/ڶ>fI ln:迠s9㟞e썗>.ٜ3߄$MCDŽ!wЫRD4UT]55C_st!8AV%j\%SBtcՍEuux*?ң|e~{Ip>h fD 7>*w IPx)4 =ql"F2VhZB.bG}W3ght 8#ߙ̢|۷_ ,Xi(,?!1^ΈLe-oϑP1/Rr" _:b1y 2rG?qm[Efre' w'ywte> 48,- P54&_#"6yӛaw,+RM6fdoU@O:n 4:bJŰS&a'WOņ?z3CF|(w~vpR\7BKIWߔ[:@}j9Zy%/~~oQq(T j4$ d$(2pra~5ՕSCk/U?YAfLK&l^u쿊aPefɰP\Mo8-PoeTJ(8M"U*_a/}ՆeBxyp;d*_}浥6Kw9lJ'V4x>OrdX20NNZ" -DžLh9`e GN"י(巎 Ú{[g0Tس^XwJC\Ȝr 6v˘.eޘ"C$\_\dg @SP@ Y͉ sW\g[l*`Ty~~ w5 0]-h.GsQ.mpߔ23`BI ͶgwXU.anu;.ޅ wwv>cYT/$^>5Nl',}ﺉb&),meAI54eՔ NIDr:qa/aޙ 'b[SElnNY`Xra+a 'op-O/BeG TcTw"@VQ|]+!tMcv>S.6KҀy,^o|{,*SL.x|yVs+Eq2fǥAS&GcƱ(6b,0dbsbzX]i簭ǏK#c70 G| _Zz{g+_{m5yj\j[HeB|2^]U5@+IXPĊH;D!ifS8棇=Mmvzp͖߽VpJD._Vv6zʁe"~(GM]X+ǛwL hP *m~EUO"H߃QzUV8O,F 1)pFF#- 4#x)mc~E]B<_؆;އ7qOLq 8[\ex B5 Y)\C߸ MۑٵvvxGNOY^>l sJۋ$Wwz0wСE s*wՉ} )b?TeP3⁐hÇ<0v}޳1S|N.i|0}5y>Ghuo(c|xFq%4GC NK@w Ģl̗y)YT]:,1x..7 +Rk^+iXoŁ`z2 Pe$\]IHČr|@OZc@K]0wl8a'{D80e];Pd|_/ N eoG~[h8x:JoNMӗKyUoU=ct6!6 7[^(ADIAXևĪJx袶Ip:> &2tE0^\wߎQ*2Y~Ql@:WTl%,V b4ɽPa FJᧈM 볘g{e&2qZ˚1P9"ݲE6m}Pw^[*gY^ Օt Nssix8+h&PRl$=j2~irM &pC2BPyD+& = DPz-Nx_;鵵1k+Y}0r4mwyn4OczΦL/=Xe_R05U5nP/4ϩy pq9 y+ŀ3,=2p9oy=K*^b,4ͰJYeZIk\Bb@>=$R*N{wKQg0yJ2MY!ա(jd3L"@N$GĮtuO0hVmځ^9I\vN{0,tC)e~9_ef[Mh3V !5^>lai\4M|/~qxtRH/-p*1}p&Pa; Ugz qL{wa(y귰/ܺP  T&ß(mJ0,R(ҪI(R琈!N|4 T&?ic|$3wu{9 8gs㔃xYm?ق¡?Dw+7C0lǴwC.ql 3m G-LA4a8ş HApֱ#c);sA=bGxܹ7Vm}Kw?1/hF_Ȉ;՛w-lSncrVnW O4[26^/ϷF/#${`|HyZooiG_;qGvw`ȀwfwlSl+l; xRv6XxM^6- :ћa0{E. p%Mg+}X:ʪ2RTx"ՉťƱ=3wir<' X,Ɯ#VDb/aPvViZ-kؿtT_FE3C{=˟r+~v:,d ;!2^Ksߐrx#r!\0+s]F}5 O<Ջ&|C p F=4%qUcb,P<\%T\m6i]1\߹~?|kxw~˾|dމ\ۙt۱񋘷x f` LS˂-Y9FА l2 !;8\2d\t.~\^4R{11)+HL,cҔy@/Q$Bu-.uT/ݔoh딷fžۗMcw| vЇ~3zwLf?=xWol.\)Gţ8/M7^Wբ")1PĊH5M-bؒ+/Yh=?f}}5cNQUҐyz7`RT~2\>0?Yּ678H(hqʰ”q/4-Sg'̧y| F=f_ЫRyb)ח.V.sy\}3l~¦26)ds7v7k_>];}]yk&]z. ؜rpウ^v|(W[X,Ɍfh> =Z"#p%3)h6^#u4)ѭLQwl4$QIz1DBWeRD^8Й|A MؼYMٺ|P*={rpOd-Rwf!ϮYЦ %owxwsuja8=;=y<+2^\s26?\bHTʭ-R0+ BR S<AP u Y)<? Jس=x0^L`؄-?ꤩGegfKyrqfbya1<=#? {,W]&3FssݢʖW+7| [Bf:ʤqV&>HEPو'L.!% h B^9v\Ɣsݳ=Y/kKUvaKA:;[toU4W`C-ٶo>g>gvac0'aDX5W*Ժ{_.9Z3l?&Bƫeoq VբI/⡼u>$'籣Ӑ)GFvi41FTIJ^b͙lIfQ{;-Qgjf~+f32SUmET{ m_ﭺo-Ѧl|DޙݱCv, !i9Als8d1]$B]ucAAex5^K3^+QkE"! )4u( :Fhф@.DtlD=,kY%=-RWWI4TĕȖ%͙K/=5,d?'7iS㽿_{}$Ø>8ſ^` 7j+?}Mٯ`I*)xu2Fk U k$-@D\joPV!X̡Ҟa+W`HfܹPlq+:*:eާgJj2fɭ{`yӹٹrKۋsťJz/|5081kI^-Up_wnzwAJ 14^sw*p\dA eT.F"$T[C4 >faZNI`pa0uYF5߬L"@^&.E_0jWlz@2h…m25=#ppHLQe^eU'W6UX,a,75^1\u Glqsm^ŀ+X-c{5m˅`_}sinZ'Qs;.N_~PP¾:"4"ݰR4EZ`@xn.V5$P&3HSqrZIl*N rIhؼ(^:X oXeCCg]Y/mM8szT 0R,0\Ǧm Iv?|LeU W5Nre3J[VKl!s4]+׾O 6>άNE/'lB)0[D2&mE%EUzܔ]'c߲EY)-F (Fva ?D)NRQ qg0nKnB)QX:MtD(DCeRULT6JQpu280aa38?&uC,6.B\={ M鲦|.YYͯafM\&}}y-+a" ɞQUcT"@.#$!6/g`e 2^]_uy޸Y,Y ǏSݔY.: lo^m8X_+AM?FN0dӄm[M;>pupTy;aHMs9zV]}k5D_ c Y|vL ±6U +6q);1*N*g5 'b6!Gwq%QzN%BXƒ`x思o2vlFӎqYALHPm۴):as(j ̅Z-,sB}տON['ޚىo uKff~o'+F;r*<$xbgy0,R'e6V7Έ8Q(`wgCR4H ؚL{&7\ Ҝql>jNƔGjH0.3QXN'p Lj^J1‰yA^+!ioı.(#Σz9cGx 庶RPk~{_k?|O>MW7r_F5EnUXbw Egeb贺+J essiN*A!H)10/é( NSb̅{ĊH9f.s$T,Ĭ\q!&wg4ՙokNx9N'W .ַ/( TJ7m,mzqSҹ*w@GB}:88sBC s= b 4J1؛ yh@SRS D#@C \Ц Ƶ9\'6Ʈ^4m7ώKǯ5wtCCYÄuq"io/0!^̆wzjD!DdxГϯ⟋ A!n4)էˉq{11AJ牥ֈ!T >GԌFQ&1iomАÓm  ioȩwfj`K:zQ RhzoC1VKgWcGiXfx`Mq@L/_,Ղi9? =Fuۧ!]x[.]t(4:Sd(^ԆwBz;UY)<?5A/V. Xh>7ó,`jiwvBZ[4^L{=OљYX&Z` /1tbY/\kYYڐDY/_lP*`:T/ v 2V0UoQQJVM.ߪg<;U]%@@"@`V姈RD<i~p9XNe u ҂YW;^ e(3XȐ/Ɔ81V3xwh6$b a|SiyԷuI?FqzrY}O9._?,]&ki7FZ/~4 NRa1$eL;,kV}pK$8@} | 4q :1$/ЀC&PVxy+f.|Lŧw1xD@Q8H-Pȅ큈]C.2l7C#kjB7/ 0!C0`7aPM:.|؀?3.Xlذg`%b~WI m R=Y5З})Fy砢0 U0ޯA/RI i]赚Gr:ݡ.Ei1+3l)|^xiP,P( !^\jlwX{zq.>bBkX#s[E;#.;1e3yuˆcFK<.],8F<;3t] ^@{6-P+SDs3[\q&jd@@ >' AENU'b x=bGH$VC.1PKr;6 M͂ eQY0::%gqĈH< `ߤ4e236MkL:Ua,sY4,;ʵr- rwLp|X2&3OΉH # /7 B^  ^8(3t\NQ$6/=>e6P1SD %ttՐKCv/]$MM 208.51!K֭iQg'? j;d;C[h,Z˄IH+l(u:-L(W]N6` : hP xq\qlEք% | F= OI󈐉b,"$!.[O֒Fiim 6Um.4+"~4?_a ݍ !jr$A!MfGPNctщE\0}%Fk6D*'a 9UQ$ 5]v#CLPg6^* s1!Lx/艆Bc E$E鋄jslr YL`,`83eb/j^,QN6.m !SP2C<ܠ+ TE^{YG<B{fsf(Ɍ  7*b5^*XEzJU, CbTgUbV&ZD4$g{ ՠ7ιz3c10w4ȸ,_ҁGy8yZQqd'q" 6c6l#-ecR/W6M7$9{QKN#+P&ur:?[SG"?BĀ|/DŲnzs4*ۻC=k:gⶄ("ňQw5ID˄ءh ~s,Y2 q,_ޭΫ' 4˜Y`8Yƛij>kEN"}h!yԤ6AOg`0o+ƀ'ZX h4,~:"uLwg \3$/|Lr*Wɝ@Em[=&q7rz(XB 4IՁf[ׁog7v-u>[X;i'}q#6w(cGCȗ xU-$46 HMJ5t\q("uq[,͗O( UԈE/&pT`8 X\Uynq)sľ~ [a8Ngaр Xc;L7(=9.閻~Pkc:9̂n m!8ͱ`N -*Ǘ ÎC-aV1O%TJW1^ H 4PU3#DGU k h )v GIdj}1cۼr e;p,ΐuU O9yr;Nb'Ak$LΨֲk,j_,iG;"p:֭eaCCN?1N@kXQ;޾Xb0^ϦsQL&ͥ*ɐmK3^0⢈(VҪ\^Ts FH(U__@r 4cf88r09؏i7ơ0I,d(Fefڕmyߏ-rZ &3fR !'ܕ'qn3?D6<1 ں*cABû) „<聄0MW$Mq+=pƱDSW:"ИcaXA0)9CM¦ă@^fsvV \^h (&ye[YZvlߐ,  KAݝW WlJp& >]Vܧ)H xLUY)"Иc0G. TC`/`ho'0,jzba* CH˝ckS*>YkW1vK \>YQZX Zp!~v/t iƫ.E4|]}SǒĥhDSRPCĊP9`X܁}XAښus3Ҋ~i4&4sә(9 F86=#mXM>qr\ڰ0 3E ZguohEolHr)@1D'zb*YDC;]^ ]}Qy n> tT{*+E'⧴&%!<,{=5˷@IDAT:x! 0Yݬ,ؤ!K]0wl89tlЫYb qwY1rN5 $놏{)[MeNY.jʚ+>l7Y4cp\6ŭ77KO(}ADW[lBӀ)# Rֶ5.ƭ_XzVˆ99 A0W2||uaݝ9S.";7^׫M=? b1Tس=0O$M`,_W-KۚDM65.Xa><-_L)-RCւ@9K ,Lj~x2N,Ф|:ݾJ|{ᤅ XOf8"L4ђơ$n@B:Z[:5eԽX 8 '`n j(Uƞ>\$`c)%Bl(o;@BSTY5r:ʈRƫHV#V&M (yb90Fk6QV\,kV,L3rXΩKS}_dr* Ra6mËhNa׌1%Ԙ9wCZ@ ~|>Jd9P3Fh1k4+XsB!@ՉE"z↞ҶhLZ{ڄ Bk[(%n9֏/ bD-QzKWbN 5r!~a)H"9M2h)H _p=jףe =wꅸLG[f ]*<5`H)'[Ve D"p!<\YXouMg*| <Ɂ|Рn$x=lζtlEyZe|J$Nf7b; \P Y"2lS:2X@P+`'Q qHa§r"$6f)Z7w6yUqg̢IZã܇+RqHps35xi@P AsV> 4Fmi;YȘh Ydz50%ӂmJ;:y |3 %wb*k\".-L3ߩx [bBjkҝQ|F' 4'u2:4"SQeW3=19zr[J>H?tVپit/i?}!\/Qsm kke֢Mv:`&&ǰa-q[U* B/z}u/w;1KZK$>gѨFYhog3rvٲy>/5&q<ʰ s`74dtFŃ-,oTwXZZak[-?~q,=wLwX+~bHYYޥn8 \LD`Z\?Z1 Cn>hQɌ2_:1Ǹa2?I9tr'k3w5ί2IBX'Jop#&SZ*پy;Su.3h~l߲Ny0O}A9tvD : μܽ :u(?9Gǧ(r>.oiy5^?<=lZ!xMrU=^ )c׃ f0˨]~Mív]q'.+cصh'&J5ڗ~Ԧ[LCxijQ)9;:!:*d$b5c"=UCfR1&\z^g F>u0ުcQ魛d^Йo<$hH6*aM9R\9"oFl)|MXdቜQ*EJL:,rh6;;,=uP 9Xl߸\A40I8KP e~+lʝWʥ=6H [FV06I w.YC;e^p6G %ҳ]1Y&?λt/ kJhCH/}pč:8^ŀG-pqjxZrRY)&С8Eh}/G|&k|  o]SAqVo׼>"_jq}Q&N#2G%{j"waN㬏q[b;MG/-К E A*DBg]K;>"-̫f8p jdz0P\LsxZ{J$g|w9ܣfbmB#GqfwoUۤ^>YԈ0%sQ? {^ErAy>Y%iSڮ]OObR?@m0S| F=CQ`4M(2Бҹmf<֬X,5}KPMRᩍMx2݊ٴn!__*ԾJAp`ͷ=s 3OxcDŜE ڕk7QB>7]]ڌ>pQ_&;nަQMԴCJSXv ?.Xxtfy14ȏa̩E:LWtm7lV9ٿfKٳF~!toq9rb@ZjGStPyhW\F?M8wbȗF9?@d||}-5/os`6\0,=WGe5pw';`Ky4ɮ/}, ceͯ4Qqjw|TfqMi 0LDCEg 0bc-mohF?f[7hB5vJjFxsh~j_K[dYDmy9AΞ7Z/_{wɾg0e7fCKexBW|ᛲ;1s) x»Ic_yxaik <ãhp^9rX#ܴ]z{;4mvS0p`HuAZ?o#~07, x :1܅!.{v}Nȯ?!Ԛ%/ WcD]t6kKpN~9瓇KΠ%1!37#ON j,] 땸];k_gIׂlj~NmW|.Ůl`+oY>/?xP_b>ܵo| jj~=eo? XQgPr?J|,Oa23فicS%MI[]\Ʊ’512v)!J$#NCf3iAP W lu5{OՀH`f}jԜZO jYݎZcSgNyUXJk˶MkU{g?܇>,+;yNt06}jhZpE&*s04vFZ.Y^y9l9#L Mh]3f??-j8Ub118 9s'İr^QQRA64 gצGbc0"wCe Jb pb _`#{MnlٲXAW0'35xХ( +y] sW7foHMf^&4'0a+ϫ/RYf~Vu |Lf%֭+鑊,YTV`l|LŒaE2+sy0g^19;fc7wڕDY*'b+2E7nEJN/}tbt Scُ~TK50֐AL5kt%`cr+A̲zRkCxPb'5^V+[>y!y(@fE2N1JczJSOta#UzļTrJDٴdgq[<;lАM33mڈs\>Ϝ_ϳ"㱃ҊSHZфIf:3 _{f-Ï@^[T1H4QN=}5r)?6a(pV?Fx6-;mwˏz`NY\Z&] 1cNLT' K Ӛ9҂y: y.˓>zOrd\':|a|u/hxy4(G90D|F9cw//߂yhlϡ4ޛ:9,o{dGJ9՜!YZvtuȧO~8nl։lߺD,k2FjbqQ2S1a>C›QxH)4ҫz0lj;̷` '/T^%m"݉MP买=LeJsMYzdBj4%{We9~O+/ϡv{ZS8s'e|6{E 'kXe^Ok(f?h>{[L~ԛ6T}.]酭ˇ+5 &0.\ĤiUp^OʿT4ao:(GPK6?ֈn'3'3l[3_7Z$cm6[.Klbmj܈\3G G|t 3*">P;&я>8:>q_ܥE&0=_B"5bG\34WyCTÓz hA CF4,=ڇjL`3!1%U€Y]ar9pMY4C1y_cz*i|<蠍b"~8-&quPo˯[GQsc N;~U[e*,=,H4_fJZdQ sq {O8jE MF`~ٰqZvf0y1z8dW?֦aQ~+6(ɦ%7^<*=3}i/, Zm+Εٵ=lPY4`"驂&O:1*47, 0n^N,8()L/4rۤBs:>+0t}RGJY ?]McA>)Oggw)]h:Л_#7\Z̷fSq+Ы6b1L]֞3vo?0m@I8qzӸ0Fh%՚a;J,bmTT/|o|d8UEdX*:ٍ3P|sbqJ޼XWΠ)]tB1j<hKcVмϼ!Q#Ljz°IN)"P_Q ytU1 z#&lZ,w>~g=<3[թ:9`H%J*XN뙳 ;>{wgƞq-4EQ"ŜAȱ@#4:]kN$OVM}m0iCd?ڢ:X0z2GEQF{-Rdz _xlS) ]=1{xz %ǚ}EGY QAmY1E -=vBK;q򺝺K!T3 6A.  dXqWv`t֧BQ s\sݼp —F[+pũ1guRࣝ;V8Ėjb rN榓Dፎ 1.wsgPGQ!(#YV՘QQ9w]ǢBD0('-*YV DD|dqabJ|}kfGnrk/ge#Pßj/_.uJOEKKsKR818Ije>Cl%HMIK(hNjifRvWX)Lʕ{?&~?"AD{UJw,< WR>kkD |k#F?@x!fKY>Uz'Ѐ $x;+my&cX^BG+Eޜμg W͹ȌƌNP2YQF@AA)MY0BG*Oƥk -LSX/T 9Lt _`|OKpD@'!b#b8Kml;{~Ukr.\8fCn>y[A]D +]HB{6$건x{!^J=`As?X'?J斳o{oVaћ\+ #uɮ\oq;FXER(zh2 _fb>6 ~ܰ{jK)WKE.Ӟ>rJ_ ƙGKf^ c4Fx23,7?|S-tuYZ4 8i;i}v+-"ͤeaG}_@ Bq@+wMʇW[YsL9-qV<ڢ(3Ld7p>avALEEsH`dtk(Kuu`߁BJ_#(h1?>jb_x}kq賭L"m!r6A@[fbJ{շXZ=Z'i"% M$潞}y쫛-z YR$!E_lv , 6~O]) "L5c텚X+9?aiYVbil'DUk,ﳮDrUKl^xqoh*?TVdB 7 xW,q|3ǭuI@[8FtР` '_Wp I[3?ؓ.g'RBrQ$i`K+sq&ܕ \h`s>;Nm=*ыvفk2Yis@IU 1 Db{A>6n,#-<% ncjKlצ $Y#)Ysvreflmex`ΕD4xV\"v{u%2=zR+B2!R7hi—3EoEU1pbxA+;zf(?Ӫ_!"1] )r1vu;x&v6 a-K Tg۸/Zm)]Za9VV*hLBU4Ag rm"҄Xz,;kln$[ȟaVT^bKJ[&b\\pBMDm%MEJ'|{q^! WKJ1NtF]%J #;̿4*qc'2=1: rC݂+$J忎R',wA|V Gģ[GضmK1Ӈ퇯c>aj 7ZXm -T7 p$s1y&)Ct`rwF껳_EoE{^ T;: +\*IBM&X.g yU7k$PJOr*idU/+giЙݪ2gsSLV , SG*5:mnIDX_oLMk}@+ũ)φТbr2mVQlK 0'CVVNW.$p:B!u&4adgdɢ3T͛?󙏥=2!#G 9%D% Q^S(Ĕvs&B͏\?͇P«顛.YE%`'O]4j둜 =fհH&! DȎ"ȯSMyǐ ],dݕ4P+sq@qM "`1kV >lJyQT='c/֕N.@Kfb wәF*<>TgUS0JvpE{Ռ^CqJ#d.V :%E'u+Hp.?z=oղZ@赦ܼdVHRr% *4IbeȁVF,ڽK)^؟#:dd^M߹?O}/JB:KjeID'(x0H :1af( R-ओ`w7[Ѹn_ɳ?\D:jMC - {S߁Y"ACPmL.BkG5 /Ԩ[21RjW/_x%M[e ܄]#lb}KG`<)MO%.x5Jj}yUWIא 5ZL "3|OaN iań>Y c$go9bF>3IAeƒЦu.1?fGo^-b+:&x5eNL""aNO 79c;^aM1֬sT [ hD"Ý q [3ߙܳ9|HE w%5&Pi34r~GUIU ~m_{TmEc+tV Ac˷UmE>To%]/`df}ݽDchfr{pFS}")'ڏ`G! M.k >Z@o%4uMCALio˶oXJd~3PL E糘ow.]k44o!|ClJ!I<i]+mP(EtڎQ+Nh%@ `UQmXLJAWF``H+G.3qxg"` [gk!뀈bT ZRg])&'Pݶi2[Vctq膵̤"C*簖79 ̽eˋ׎ -Pӆȋ={Ih59܃ڇ9"mz@F?p,zsܻshdzOc>k? nAhnaGS얧*Pe~_K0A,^߀ızOl-mPȺf(Ik"e|ҔbVvND>iϞ1sG/ǹ7H2riy1BFRfn$ڟ&tֵ̝GPfZ+}vOy]pr+TFיr}u-GO;M=H=~ўyZnHDt@$ڧ9Lj[m|HGگQe؝h#Tf\?F[AC+ {H5/,‰^[~ζXnW~x~[m׎JgNI+'-әΚaf@xD`7 NN~1󝹯=>cFXp?7~+UT`_ڟČblv&n`Tc} Ԁw8R.cT\%Ʉ)}>j[<&7 ~ףuѦ0~FȑϓNYF78s,Y%lI͸bIMQa"r)юٽVPG:%`ď04UڈR?âAbN[--f.;F ((`g{$1>pf = gG]i#6 b JdU@qB GpYgedkz{}F/]?tzg萕3vnWJ$K!9uߓhq[W#K,}*= PC=F&mBIN_?sĮЉjy}kΥ;XuKwB%xpy4Uqt髱 }Ӥ'dB]3֥.k'-_y\]AfE20s,t5=mU } 0vA`C_8YN)(=+lj:舖Dz Ar\GD~JKPJ!܈[,HhB@v+Ht"@WMQ(vy`my )D?~cc=Tm_QJ`+mMvWn={;G~Gۑ#7; #@91];MNfr; _-r >Zbn/HtyEeDrpڢ W8M^uK_4ImNX(.Q̳8 uVi:<7ELG '^NiX 9f7E 9VKQ\xX6L LEޜ?LfEKn+KM'rf?8l?x{UZݰT ;џh/jb^hT#IٗO,M<̢3{\˼텯f' >Zbn>"YœhseetS裋g,sj9Y:0 Z)'kF7-SW=Gn=a-D?SHNĨ!M0ҊRlJMw+7>x"dW,~LJLv;k"K/R %:>oﮰ_̢5- m )1}Oitƚ\gQ=eN 9z{BwJ{Hsםs3,3j1yNSk4D| rĜlo#-ÅL-xk_|:G@ZoL>Xqrj;A!&]>;з1=àrUOyu8D~fRP7;;h_opJ84T:ҜRj/44ou-q.WE&<&sGO5|_ ۱c z |ct\v&(@ ى^ۂ\^e9MvsāޅJ c_m]m>h[eUE֗q6vIk]}@% $ ơ-Hw'N|}>nncκ/3miN)R4ٔ>^|9(r 1.ہL9qVC8m+J0txV1"|eH~6+g5|?($` {3` ]$$ym}i=tO ]a/h3 v&Mu[Bͣv|#Hkr\n.ă>C; =d$ظr94OL S/+a|ȷ,~H߼ɜV&DVY}_ѧn27MQcU-b `{4`bB9^aq=*+3qnWN 5%WNhAL|jf~ꖃAǖiM3=Ba̝4p}} ){Lrx?}u- Fsd`p%UTerx- %9VBYֈ0s4B m?E?7ϼo *]v'۞~55fL/U qw)&`"pn2;CzODR*ڇAQR$dRNg5aA933 h)ƇIh U}%v{.x+ z 6G.F)BG}/H *+ceΫ mmik߸w= _=c|}c67\zxZi}r c®D"ʤXl{NeB@3 FM]~x܎P=LӦ|νqW#ơi?'i1`۶TH@Hޏq>##H-+0*WjPڥ$p"ns&|Y&X Mzˀ=6l(Wo=' i*O+zɪcHĒ8tO9\ADY +Xc 2JTo|^?` 4]z~$,pZt nj#a9z0&88S1iu4PVKB,\oq967DrcakϿ|:{{=>[?&q6@04!F &C'smfIu/gz#BȎZ_U 2+rLZ_ {h](W{q^x#oWZmm$)~pi!9Ms[Fe>G#xUC,2I8j/6W-Nz3D(?܊S%rLIUM?NJ '(!M L^q$ReGPꓘ:0X\X ;:5wY w_Š%eUmak<1Kʃ "H#&\qY j4Yuu땴qD?(!$<)!*ɜp1YQq6N:#1_E{̾{WK|Nl0..-PVg{$=QktPYp}4#HbN^9 Av2h{M0v,Ku(~Z-+Nfjy zLCd@`U<"A{+,r|,De; d!CednysBs͕(w8c`e{(&Cn %$OvZjliUmXiohƿ1ۂcNܨ_0CRϚCqv壏l}BYBo,QB({h#il$Q(=E2&!a}W7m<Fxs_@G_ƞƢ X\DiiIo/uK(U^~op S,WNhIc}ciwO^jnD\ص;=>X$~JU3%Kpެ%4by>Fjy%SXk.Z;'UPCpb/FzIJ =+XG@\"8{ݳVW@+hKe3xc4`/tXgf/K)?:S }޾#t6R=/>(-+y-J<P+# \%b&"jѾdmH.z#$Q@s4m]_XMMާWO +B3!":i; M R ) J#ͷdd2XGJ1O%QnuO'Z wqΎ^x- )"d?cɰ旾jV于cԢ>˚B ,V\Cnr[J,w4u41#B~H>Y)E>֑۝ۺ\;KsM_jMCƁ1S& {Kpff"zYBvC]Kfe+3_ԫmܓ세F8lC.ۿ# -qA m8L4o^k]s 2iP b}~g z|CY%Qub I E/Uyܢ)ELh$*wR1$j=<{GcS,k@(Ec̦  DVP}s`L;*;_YghmZpӡ.VOA(FV'3څg`\ L6K'pư2 z"퓖C[%x^}[RR*dۗ充IiLUq[O33%O (gmD7,WwE]A2`_}\_`F>,6 dWQT?=7Hx'4*sT4r|}/i2Q0QQR^&ۤ'־u}n6>SEX#ʿvS3N O:r9#T|MT\} NXO"ƅizڏ߸Hw"10Y]IUZuN|T ,ץ$XX"Vஉ8+!ؽm ~{ ve>c:A0LyeW?=j  .zr9>V+XAr)HB~>F@g%Y]=gn٪-`̂1C|aI60M=YЛ&vKhh#JBc%R$h33s9Lvv8)jj"߭iә ,%M=-dit*ԣJߐIQo)M*O󯝳kĦzA{%Q3?ʫ}8~iRUqDG>۲2K5Nofae ȍ >`bIFz1c[#)Hs>9pY6 H$h,M}NwN( _>a }zOL_7=N[^sqЎ#.N2u%t˱j-}ѱ&9vHOj|]z=d|9η}HXIUK$CTBIZmYI}_ D1mWG濭x"=Uj2^~/j|{hs^]QiJuqM]8_ ֞@(HT @JA.punuW#jJ&1>Lv f]˜Api?X7ZL ~B}+rk:{z7/ RI(xD?m tI*%MV#M96LIIoX8p/1n\#0 iy9htLw/͑It$1@ƨ%b4Y.]"@U1S~ˡC\̔~ZakUҾdkIj~ 0VU4_Aq Fcx)S>sT<8 k\hx@"\ EibL3ڝAZY *])S[L%ne:+V;qg%LïVTaie-33β7[6a$LOD<[JFK t@еwҗ9[:a#9>j)뗬wݵr)̍>R5ӊ=FC aEP0׸S`AvB :cw3G0H५npS%cNR@dEAzD.o4t)/%" I&fE`JHt#aWGKLxhLXk[MA5pgVŘrtA.`Mg`sJUA nq[j&EWл&1ˆ,m6_7lZyEuK HNosBW?|JN|%0p#aRsrPd#.ٲWm݆r\=9syDQ^,2Х'n؛'Z,ޗq03-,,r6!{\pq!FnxajѯOA"O22Zڲtq;q+'lDr]ugaqp,&%T_AI:8f9{fq'`Ͽ[9.LJAw,E !%Pd]H֠E'8260.! 931,N–#%!H,_<2bϭbUD{TۉwULjI g؆uevj5[ 1A9At R'vClkһu] Zr9{6.|sin,n?0>wpIeƈ$gaE[5kDfhb8FVL|]eP ]WyZ{f:0qUas,3^(,?69FR8m<0k;Km%μ~ꈱ r嗥LWpWr&ebB,*sT'c?ݹ>0` θu]JxI)I6&2t2(J5YщNwtYwg/ x_[BBks(]q0 &"rk7.~wޟI:,C/aJX ;"^^YT7G>2Yh6I-~ic9^n[ 4F`6pE0ڛ~kg Y-LV"S혶Hr HނBl~`}f04:b:y&t +Qꡒ)h_Nmu^%EtJeNT3@{ QC-f6 3xLqr;Ob+3IvӐZu. $Sߋ?i%BAgT1g/0 B\皀Wf.8+rV2(O(=**+vۗ,q,@UE)RwP#35 B^fvE;#sPXR8 2 ۊ[xgrg盇FLSOoLG,)gJ7,a+גEM?D*3Soˣ©,x]JGڋ}`Vնu퉷 `ZԌh~n#1js ,e4\`ח9ЬC׹1/o/Q s= zbThk28 CG @Cf]DP=$r:r`ֺ5%s7O01(oB7fTEDA c(0&ߏ&.a=Ma;A<=L*栝O3 ,zZoF<_yB}"Mq>^4yj b q[CRt|ǵH}*$O>_j]U%Fioa`.>< -eB$CQl4Z(P!͜IBeŅrI&iKI z۴iQ+߂7Ԋ:WqmM.tIv=DuҴ㓶&1tOJ֠=yF9>|Ԓx۸ĠE!g}OEkDvk/Hp]nŠ,/ǒ8?zBӸC7;ӼXwa/oeZ&0ʋ2>|_W 1v\ V.u}!;?sw L. ~ t+| yȅ GWф_:S RasiԎ{!ye 3jY6Ms(!œbY,! S @_?B,-V\]lzk2?<غXLĠv 7:CV Vzow ,:o^HrK,6B}_mߥnLxrW=~ܔkvVY9gh:0Vԯy"Ki)@Gʙw#UDu8_N+@shLJP[)Z48+~C O-ɍH!bq_zS<ވ8 p)IUPY +jw%džk/wxIJRD79[&6_xݛTgA%N7Z[)=,AzS4 Ubdb%ǁ`ۉ}v|Q 9]97 ~0AjN3 ~ӘX cZW-m!^Z1g$6A;Zؙ,hxꅳJZW /W ~;5ku#PHF>T~]&{`+Vyꉶ!=uVݴ1Z(PEDf"{s)ǎV!:KGB!_YA[-*OUO޿brSz!x62Dí/M X3>,p\0U pLRM17R(ShQ4}H5_۾";kIEF8429y!Eg2/8WTM:M7QEˠRC/U@`ctLQA EJdݘ'h/.ΡY $౗$[d65ԍ=0Pf("PF,밶z ϔW:\w:zl!3)%3 Gi p-/>HEE}#ӖWjk/~6rCq@^ \hm-ۮ]33\ߣWa{(6Ę1:M"%PK7j{`HpoS Q INg@k',?ɾJl_--`O#'p=FFj߽8a8/Τ>+ =Z-A_ꟁ6Gx `Ol%&e;IC&Tc+,wtOQf~rfIveEN@OMRPp`''+8+T PCMN 4`,/φ3Ӷ۵j+s'_nju? { 5v{mpfwT۶m, vS? $0iĸnO# j/\kqfJo_a՘ ä5%lfgnׯR]tIVQ?sh̆hp+=H:;k6-@̡a-rŞzrƁJ\VlQ0`,v"s"i$ukHw0~jSffj#K!1b'G-ڞplzwdUnߎE'ңJ0V"ٵt&D"E8_ͥ|R 56tY# ,˳Zؙ+X#rwM0QH|s@FJ oQuubK+03Hs8u~JB{@I7PG꺬9ߺ (F5YK7ɤ-jRN7;rb=y2l H0oCky~N ۱}.zsFWYhT?JSJ*#%sBn4 qp|j >m #~RX0l['p,EM+ȷ>Hw %.۲pOJ=5< v"&)5c&wr!#rRsa=U+_Y+HJxp4? ZG뛐&nW7)'_I ΉbԢMĪth+-JDA?'X7?lMS BC+y6,2KЉ:DM\eJL~|~Aƙ44?==o&(lwo{¾{3grY-r9ljyUeI b-=1JvMDpd67V"m`,KNKpkƔCpj֧~i;xTӟڰz"IUU(+@]mgyDbM"{K#gϮY(a)&X #<"ZX*_}hwۦ= ̗1ejVA?Q&6 ':.ME3V $Qo~fR9€CEND3y)VtG.$P\-zK,U!r Ji[{k[)g]4g pCwJE h""I XG߄=s25۪T]nYu_zxٕܜn:pӾf5Qã=s .." 0tym/@3 57^kae,v=XFkܽR2s]/-o [kv,cwϊ s gO6a:RF`Pq\ Awo6Ƚdc=˦QVbӇ:ӧ'\ra}wEJEv/qމd4xy9apDj{$3`촩dI|dmPgP#KFBӌyr'>+1%%zzrtw`4A]w3R"ʫ (-?9]E/Gi@\yӥpP; b豔DfXZ&Pa9q;XVgZ@L-O rMeiA:d˗䚟ʹ&j lT{@;<,ϐ+,2+kVOw;/^ci\%i{gufdO=VUivfAh!;L.2`P{tI#gF 9`u;xT|+K)9 +H|jڪx4büTs0[F;0w=iu> ߞiAtS,sU,*"-7}ͳ{b]M^Lƺk]e˄Z $4pzVSE1,ffs#iKc>`IpU}p~0e3@*x/`n"6  aNH g'g(6zQHX/P(78^& O\;ڷYj(#z0ԫ Wd.;Hy?[m}˩rJW] $A:|Y *E١A3wLw:\ݸ'ߏVFXT#KV|~pUR5r\VXT zq_"|VJx# ؉B*4WES*^XX"_k# 3 &@IDAT}֯޻]jCo8cܰ>`ZZ9:M'pWL R\I BPlWl&,"g1p])0ɈRL'896D}b |?|:bc_|2D] *h9 瘸FEf4(t23@,6kKQ0L4ٟ4 1RDq)^ցHQAc8^>cߦxeuZZUaR M:w/AUIBHGY?&ẵLJ{4%A4o\SWCo ?d7'y콃v@e%\ NaoLfϞhKj}5[[zlsvBl<~ZV)1O$R|J[<RDw$ؓ@"J%'o^+-sAoi1X8[JDyb6DH,jwuO-ĂkcX"pU Stڴ[%uCq'JUXdm1[0.P a_0i: bD]4[yqebZKw=jebaf0E@MԴQ4 }˒pINIvnFC 8(\5;PD vM9FKB*H-- enuReLK{JUK  Ci WHEh^.ݎy; l^1>Nص+`vƯݾȩ:Wwm5|^W]:U.Ҽ4-54KޯuYf*~cqA#S!aeQ(LDp;73^V:`z^1c6 7+$ 5Rp3sOXAݵu]1k\)J|y5C QY7uSy[ 8-Hk RLY=C,Z5.}no 3c} G;[mrinxGE\R5)T" TXain*"j4|:AF} h2B%S5mG" G|[HD=2a8Nx`70u2(#J> “% o2% koQՊk]ţAM Ovu"܃=`zZ nf/.0C@# U[,Lunx}*6U]m\K Ͽn9m;{񅷬kv0wmܐ¢{:; ÿ:Ld묓͛*b9ZtQ3 \R qAn( oV,J%A-[kf$>]];W;U&_bbLfQH߉K"Z +c)4iY,hcr (bwT`/2 北ó{tV]5HXWwuOL_>I5:~zA>2%/ar:$3Ҫz!GT*&£*%Y# Iexh$SS9  $p,܄jHQ׊<Lُ1{goGJ2Nlrƹ?~pT JYnlb寰*#f&u[v0s ,p_`IK'g$ٶ&b98Ϫ|9{Z[)P!dt\m۶VZ==fW[%)_o<@,=!~jTpB ӐLzut%EHóaBój,@ Ʊ{lLEy Q n\k̭x i*  a#O>z'K[ 5P8w0؝P"_YKs7ѣWoq$SMc""X =>h}˪] L'3Q֌3{$YBPC N}Tרzlj'Phq! *\_ut B2sCR >-n@ Ď!yIeu qxOt$?7?î4hpMrq3:/=K3^\',OIotGtdƈEO tg"?8eA ͜ˢŦ~RR{ ~+]4ݿ̬ Y̖B:q! P‰2 /t G?]sBԳϔmt˱ĭ)P9I&2}.֟Dv|Ůu!cى>HH$a;;Gܩa+&&1;Io9I<!(o5Ɋ|ã5.l CSURFmYJW`)Եzyb$5Xw֯[³KłmkZwZZL8燨Y{?:`ʢ;H$!t:tPl )#Itu4ݡw*52qXiq9?׍IC$J6ש Ggn[LR-Yز/Rt/`JUv;b;7چZ哧CQ ҸasuƸ _k1ݳ锽V >rx84k}P9Sq&6 7j<} X )sǰcRi):$\̮RްHcԩQb;\)na&'ANR)9p}q4m58;B54ꥻdF[qq&VCnu*pakAIpBЂ_ƲOkJ<ۧb\/\ \NX3TulYk{˕X Z$D/$uAS .q.譀K`[pǏ5۪B:ط &y~y`8y:Cx@ *_N![gز3LI<,2ɐ 'Q}8̂:ZKn'V[>V$[nYhˡ.4\QA)&!ɗ1N)&y.!4aSRlk͸  %sAÓuT!zcPz7/%&'(gaG;$λ!4{:S$m*/% ً'Zl7Vyaa<hn3`{mnJJHcP &$Y5)%QRB i|Kry\WgWp}Ğ{~ Ĥ"|:T8Õ*9@DRh,$<! )BJ>2Ys6EoN*{:}6n\ĺCD1pPz ;;_t$g FXDL0Qr3,QAȴ)r]c@a%V7Jprsq-glPzF >hv_2֊ S ];֨# ]mO dN@L5-%lYgsVQR' #99YpƱ4]'$It-"aq 0xvEZD631@Qp?k$cQ}V$,=Cb* ̤hKpQEn'-O%4~!m1wNݍS[6T?&70MK @*Pm, 7w9K@=yr96at>1h?}fab\ƃ@DؿPiS^5u]TQlV] =P-Id*6Y/M0`P5lyYd5+{lwEY]M.]D; ?ɳT-5E(rS8SӒxg90H15)%Hť3d VOV!H;lx)xw[;{Q;T`Q\5> w\޷q|AEknW,LY(,MIˍ]IQ6]^T^lb/+G8aC* 7Z`a ¦JBkAxx&$>"1+EjGkk[mu'=\Ep~\\OQz%ÏF“q?S`?p'2HbBWHv4#9&{n[$ers0Mk1v1q5l*CK  fN:j=O"In+;5su%3&19~43qcHLʈCXM7U]V?*fvЦ.5{[QOymK&;&2ʞ0OXJ+{Ms!Kosږ/4V._h'm–ܴFP \X$e4~zo).겯Va4D9@ϣz@WYc @H\Y;x4 7zNb=ŐEQ &dJSs5_qNaYخ_ 1,,9cW"u´̤ 4"(>װ; <GZIXQQPc/߸/FBKNJˇF$EڛJKgT @Pjˣ##6%K>W]1ŵK'Ϫ{kQ!~Ջv<d%Ӱq$Ry`\#PhN !J"N⃿}U+YK8nl_Lqe*Y4,eS'NX;dwиTNn9Ǿ %i\\Ї-M %:h(=3v U7ͣ#Ν'=NV*ٷ Z j*b(c"Q<[Fo DYFl*Jce>i:ph} T//]۱c,u0{B:pR%Fq a}yyu ᅄE\9#=ʦ0&K`M eyqv7@B3VxΪ;BK0 nkm&nռ?:!IbZ֬=G=X..qX\GR xTہrfy=a\p8(f? kʇF9 8 WM9(&w7mN?pK]|e9HYD4'-fXv)"HZƔK ZWX[nZ,&gGOf VJ3]@]'Sso`'462Dn.x FoePAhr8+[. Kɔ踊Ԣ>LR~R\1P~顑Y}s?. ٘1QTĭ,u*6i8`wn,%t{a{^D 93"eJPc.RTׯ*OfE ۠S رӮvGhNe"$oG3빘fR. U(\I;I*=!!U]&ET 4"O'`WBc3t1\IHl')&} 0ZՐr^|"Kx[5L>4L9nngZwO^ >A%6&E@G&u:JAfS #F&X=qЃmz 董v$[@5ksijNjp')VG\L6m疓Hs4kfG{\ ǻ+ȋ H&.ZL[5tHck!p*`̺}|.C,|k/ٴ:+`!چ3lygO 64WBdz1) @"UVă FMWkσsi 6a!419؁|F2 &n T@Ğ*GgrbfUVNOpɽ*BHFC$e$< @u4 FFJ` 9+6s(w58;7Wzt%'k^?UA'j SXZo3IB5PPU,¨gL s ֬,$j] +߳T9k+JXo eq$`pN*<9wByI*5‹ *ã@MM[_s G S $YmMmXi΍ e +!pWpy?[! ½H$-7Mi)z{h? w>SnńK.-y݇PG(A3HhPlEY#DgO324J<9E 'h'%'&U$S>J&?ܼ|^J^mw0-eeL&!L>Z6?G%L/EJs2Z(N쮱Cu6~&Y:6iu5 b+}$tŤPHH/GMl%bm>CO鳐y*HLO~z}bH] n[`)9f9!]-SH6QλU,R(1ݏPeb D %eLјEakĐ} TM^d }$FiO&0`5!=L>W/8!uֺa=;GbxX0ro4a2yچ0}m"s FY\ ($Q֤A5X{uØqB)JNnDvD2c3}T[}/]/T6)zU( p,.YI/_SW!CP_Y![ptl5dZS&ﻩg8_80> B&V]8++iגfْt4avuŐqӍcXXf=k)gyZZyF v_3RXWd&AHEx Qw4) Dَ1&K4`p^>v.iq,_E\\<4⍖02;&,C |n88)}BFrc[J@&*!u`v YL{rM`h8nqg? c ojLERߎœ&OZç%PB]5vʝv<#h'OVTgFQizɵl< Rl4(JpOKv# 4P v3GW-.2(hf)+A϶v&;LHb=Aaޕf^iJ>}{%E"x z8Z@"'F;wX5a(ʮg͒麊RAi"6-BiS4r V[#mFhȶ램CK5etJ [PbPxg鞛J עz##Ft:MEKK8&Ni),vxN@gLz8?RJ2]^.Owxma$+4Zq9μv~R;;<9ml%nVVؽcUUJO, uUT y}u}_p< O+N |1(Z)wFsXX5 dR/@2KII=AB,:|s'<{PM$}к"P*޹;m14X\MIYL(b!l_ w׉KHX㪥j(+)7-x,<GX,Bj_A0Nƿ Y_WFq.G pZуV;XzB5]>l/r~>fs֜ ]S!Xqߥk-`$}#<ʅ;&fdqV_#1m Io햽ĥ}?Gb捎Oִ#HG{|WHiH%!NqFc=cS O-:ɜpw|b;m*W+)(%*(pÐ&QZFբ@|ghnƄz`!u!E"G@1EiAZ[pT{ QP * fG%XD hT{YT8Oԩz۱;Gk'~B'I5$]^;{uEbdJ00|Db dE+Ȉ52EYhO7^QQټƒxٖuec~xio|CM ~Ȉa[FAsQ]Եr.]VXr~r/kM_/񍋷Njݿ}cr(M^1n!+gSѧ.Q=CM\{ájT'H`/!;WͶc?݃@ƒTR2w˺聺Ds,saeQ&gW/=GUC.b|b+k 48NM#)dTvSjpVX3lD$JL2YdJZkPօw],;C/Gea-iC9Q~$ZPCC(\DGNfoAי:ƒFXȽ`IFuͳJn@bGk(ܯj4hQp ep?zK1Un tV*rwr^Yb_)c+Pj`bێbUQ((?m ?F :Ĉ]^=\ͼ.bYS %`$z@8hu2 0.Ne5Rw_{!8u\F顟k_2bOۮO'e:ЊoK}r/]b>G٩H <+.>=+%2ىSuV<5DL.ç uS@\'[Åʍƒ:+pk/֌wY{pMEL3%vFmR/~%̈mʺ8qBP=J ֣Vg~jnТ1)lċb>bP5Sf+Zlժypϲh~0 thSHXE~@ہM! d*+g0Kf8n&ڗ;7'A.K[#x9xTnEPwN.KLAF%$TL ʩ0O)*q!st$H~]efVApY5gX| _&Y Rm%8OhKv-]sjͻ]߶͂M fP/y$:DSi žRk Ğk\h uNGZ$Ʋ!T,+RJaeQAx%9tpkHU7ep/1XeV:F)oMRhzk$ɢBuxx-TѤ TWM L!,dLz {|,w>&<A_rWu_׮Ș;K&7l/Ul:͏GTo5ܙ>`@l_k'd*x,gqHfP$FSr(}o=,b1$›[+WU˗C ƌEAHjp1HNa \bNN߼7|Ͼ*nk af6BPMB0@LbrJJ BڝcIJMrwNj ꀫ%q*^*AP0LasX/ܣ p1j^!/dPz:m!VvT_j>uԚ;(!u3 n/\$rDV,o!YX`,T\uUI3揤#AX8Bx,pKaUOTQ@l,/v{?=e)pzUҒy-3f/ 1w { tjȂJ ȳP3s~p"^ƲEdGm+<Ɵ=菱z0eg? PcEl,P\\|D~~.FǞ؞/ou/?g[7gd{c[=r/ߵ~n}@祺={?P4u}/h~iY/ZB`5UP0/[fιl5HF wA6-jxa=q#`d1$J7}L_i@ިy2Ir.Ky|k{kvZŐ[̂?}~ANw5 ic׭ktSPf[tr'PfwnƸ+9=B,>.`q"8SPdPoVP?[:OG^EQL| rJ5U2I!ݺ;^gQ C0l} 06}#Zqp%ɰ!+FµFZ%hqylJNLϐw2`Q W`3ɼSoi:7-Υ v+ O{ J_9YPNu)S-A@IDATIq{,ʯzJ0yLOjF^|^(?G ǡ#hM}~OzO<׷uhQAMc$ָޱO F/(kjiAx fZ| kWG5Ѳs/xCyu]sq΢cUԊmb8+Wj,[z8y/_tuI 6:UVQ" O)t5d}=%7R 1կ%\sݑqr#+r@cq#&Hdu7 < 1$]O(2Q $R1d-֋lHңqE5s~ݾe{[KCnkg9KF{Yje 4бIL$G;;(7Zfݺa&8:*R%;  ;7)Sď[?*oaܧJ)?vh FǶyGg(VE'lg!\#JƆȊ$1Fm@Cmp͚1DŢYd0%\u\+UJ%>NuC0pS)kGX"(agH+Fuf=])B/f: -l&JL8H80揍};?/?{[%+ =CYagٯjU yڵkeeuu[ӶIwŝPA3&gYVGG%%~b)L?WoWδ%t< 2zQpQ+'O=[k~ۿR[+] q]bxѣ:WD`׆'{B} 1(Aǻʳl|J 6Ls_EeqrZ9j*q6GoU`2iⲜRZѴPqzw鲚+lӆ9X _LKwChTl<(|,*MĶM-ݴipl W:`SUsͪYh-tPe){ 騙agB$KXGѩ>-S\Q7dv(U E'U}ٱNUѺ*)iyn3#Td"xjz)^b!AJ8t^=*z! +?E~0'&Y\ՙ/lu,{7ۯK9]pN̵^¯ \(Gء?x(YTUc?o>W`!Ra~3ٹ`2j.Ќ(K3m &NZ&=2#*tsM ZpUK $14~^ `N|}M̓^5FvkL;iE}kд>$NhK AyC~4I  jol=aVB3cX!d??#_bILdYUI7|H^%_v<ҾuɾYd^F3y:F0Ys(6^Q+#cSPbw_.TF[-ԍH:$LE7ʽojقbu~_aBͥ&L wc\V[(beA-4*)ɇsYaBC0ZxplXp7$#'H{MIM 8S/lx|xR̷WW[ڶ;P#*s ͚ǷJc]ləg^۟+G,5L 4\$ks *f*W//sd[RTX G>x?=D!퍵$f@r,^VŠeû˒L 3WS t%&? P7).No%dK8zM~/Aqsc>%B,7aQ@f rҧeD 8x~,iqbJc@h\XedΐRT\(a *Mjc;( NnR= (j#%ԟĕ bvB[dSaG_g۩ S..Zp+憔 4H%КǤ%"K-]XDxBU\jSV+N Njƿ^~s6BV#-~$~:uL?g}gI41.#3͗:e(hm_} 8~zIfЕ{ J9,! ܹzJYG RUR5L{hu[/uG}Q[{18,`!aFJ);X qf&˝SiCBKYnMʈz V*+D g@?lGU `btprhB(p f_nr-XL1 & YylB\~9DܳԄ,,xAilji5+wV 䵰v(-> 1?ۺ҆<N{L_ǒj:J!iI #1RnKunp:Dwd%G##ԍGcc"K| :͸%6ԢMmnvqרmBgn >L ZQ7.Z ":k붓vp]L#xR0%$z.YB ,~>OPhveޕxZ.~挕n6,,,Ⲏ^qQ}%;Xp˒ t %d<|40YnHݜp9 y %k V%WT1%Ԏ8Ddz3qe=/\,…SX7մ+Vqmmx +WvK2rT; ^y=1#M;d[a\oZͦ2Tv*V@;Dj()۫oL(Tb #GW,)bcuXeǞ:n.8B!,c OGTV4K"-p#c}Xޕ%%iQ6r%N`ĤvS}y3WNu&xC^{,1 L~4?YhD\r(!=3Z9I̤]Fg}ӖJ!J)1'^nE{w_X ް“7F5Ka8JćWo[l_%`9!B'%[\IBVswY !tc`;Q*1! UIeP%PrQ%XPt,f8yqPY=0 9;bB`U^J7pX@֛ BEք 2\M7vaܮr;XمRCyʢ2A,RXg;@2iZ1Ne-N4s[@uR#dI 2f s|B8yHG!a 82tـBɺ;IrDu̡;/3bV v@|W>`\8WkWo;_Mdsl оsGG' Ep'D<_/.ʰyId7ꃾ8e\|; 67B :n {IJIq2<ԏ=d̨gB,#ŃI_8'Ȳ~B \M  "_4dtKPe*Ag"wq!#6dKVD0?/1uX {'>,!Ea;g]g*d/lQp"PS[쩝qX";iDJrQt3s"'xg!E$dÅ4ХAF\)5d|P@7iPta? YWV%v60Ẍ́sFNǒjH5f"Wxϸ'I<\(g ',ꃞ+Ji}=A,WbIy’ @e)7b!kRV+* џ+ ȷN'0Zf@,thuaz)pm5'KR‹88qYB\ˈSp-N|Ђ?ŖԃfK}5ޗf5C?3 @iSM9IGdS(F|G^P+ov5@-x<^YMR\+)C6QRr+<,tg7G55%.L<_x: KbKnu6XжƮց(Cl7d?|ZOr,=S{c~mrʶ87E'w߼rb4!.L[&[PŚXB KŁT΋U,N %)FTftnf+ɱnb2 ( + G8LyaY@,"?u ;K.$ ~A[Ɔ[b>㧻(n@I9qܮhN&w< "I9EPV{Cvwiv\7h붣.|P,xbD*LD\K %rYȱWW}l4K,a hsE,Kj+EOX)ɝUK8H@򙩶 FLnn%(̆tQ3~jjO 'U.HүlZy$ y9Iy$5Y'y5T\Ɗ7BCDhd|Diy3řϱ[o[2b-Nx},B/Uup w aQB? ID8*^'N UpP֒Gzy=-Qr! '/[!t1Gӄ0{%a*H $\5+u&SHĦE٣Of#^( pK!kJhgj;c`DKx7b}-Xxk& <חz Y7Et-Qquit; k4F5'`{ڮ*DQKhfT,Psx(ηQ(t9VǖLeqFc!k9s UI3JB(-weBP;?_HFZ #J{*H c]kki@`$uQª2gt8+(xmt0kg⛜+FٖcV=)))Y@Ɩ5k0TmDž~E3>s>I=g:F 0ab @H.餦沊3=93_8LEL,%?E(Q h($8" PE)5hXbQ"{+w}X^*m1Dm')¶74?@lZF=+ׄaGaQ!6)5(dw:,)ܘ"q}X*:P"knK=G'S 3a!f߭oWՌ9}ʀDMoEI9W1wb4I%Gkb60M+/e'EI r"T\cpaj!!g kxGFő(T VP?102 G|-te{Sp'4Kcc̿nwCwԏ, ˯NKP\/,Iq%Tϧl:YG'Hs N C9v%YvKi8B&t3&`Z@ݽ)>Uőе&I~4?s>XgّXa 4Z\k~l!‹lfFov>8h%}Kܰvm' mKmYTPFx箓[ӴC}0mҀbC[lbŀn;fɷmϝ;FO H`ZKrb8|_`8JYh3x&eCI"DcqK-V][OGUY;ⵄUB$;3H,0Cd:ݩ_='ֆO]w-. ދf\Vs|X_W.HGV 1x7|&4lfQ`udQC .,˞9|25IPV;C뉯LĹr O`Yvs~uJA"c$ExU1A2s+:nZ಻}nȊdte绯?[׭f}Hl\ CHe=cAf8E6IVBvw1b7-F]'8!箉~FNcȦ)=-BPVCדR5Y;#lS5#rrl=]kv?|2Bh8N V @sJ{T67lev[c㾣?N7sy|G[4(|&՞[sFQƦ8*% UM'ׇL/ EcRfX7LiAjQ7lCL\eկJwPmƊZ. 3nlʱնvoV5=7OI'R%X qi KIM?~Ğ=<(K9 $r!M:xcca2@R|M#_ ھU?zCߧPSeB#'_vm7X>t^OwF]4G´E( Qi᥄KZ{w.سrNROd;O45Y)os3d &Z xww3!OIT?rmL)y+,JQ#W<9R-viijw\?1w|Mܿ7$^OɧPjs˖C,c!8k\~:jAw种ΜXjڿ64v5GQfY_?n{Kػw[yd;ܵ -';N>lΌ{阇EӅǹ<$1yVG咒Ʉ$6- m>X%^$<\bQ*b!gv|5!KT=U2"H@«q!!4>,;v}㙳gFf L ;ӝIС{Id)Ipa{L1~x0AK.b n\3$~k T aEX@Rնkles֑JQ^2%,,ji/jx8K-C"A2L1O [FZ %~wm!1J:jV0?0v_~߿}>Ÿ L>ҭP\jh~BY%+Kv?Mcg]tqz0-KQQRL%-jȧ_dƏ1f{<~U7,>c1DerLk6SLQv> $ B>BoMTrȢKԅf -xcDۣ{k֍ kJZ0@Lᨸ-g3fd:bj5Rhөazm=ɰ!%E%Kjf@BP&!b &PPJhrP06.?2B1JfTm=NG3EN*9~0-~hT[y|z{~ROMjUٻf9Z{8.2T7`dD1w$T;>lAY; +7 jkEQq*&U qj6}E/ F$#!ƹB N4a=o2hCń~M`i.""G҂e%9>M.PٿmdoVKw_{aԏl >;y?R8}V| ?A#1IJmYVHe)QqX̄ ?uj͟ßmt,(xd]MWB ;ekA ԏQq>'m94(N794 RAǰ\恰}|A62`{\ כMz[M5U '>mmD.zqXE72D9g @$ ~ cOySP~jlDw Jx#cS׮]5^ %L=@&l\SXhSBւKUO`>=!"q kE ćz>,vN>Ji^5t\e 0%[El8"vmq]=i\ts!D (U}PNfYjW3 7Ͳ.֬(m +שP Czcd!]4e u|˸ $A2)*usB p֩DX+=`Ģ2>eïp-[$8eep#7aXMM Z699Y]haя:;ŭWYi2:]ryH >cY\iG+7]^wR$< WECjBGl0{O^g%CdW┍ ӁϜ:6,ʴ%L*8ZͨqbN[oEԾH5KcWFB٨oN䘥NgX=""Ip"L職#˫ BAztE" $2p)j PW`}؞JO{잰x˯>O>Ycն"jF.HOX؏9Fu~V-XVRV˴&#]Tem|]OfXn$\C7jFeE18ѤB^I'5ZVtFfҎH-TX]l/N iwnDpew,ɷu70Cp@E5a=>eCPQ2Ow] QE7.w^qPʥS4SnA Qm^% ͕\֞{rt )L 1F J:rw4f70h/K;_!ؾm56~M7?FY,Kpw$O}n7&K,i` Z_{ۤ'JDSΧk'|Ն߅1>XCH` X^$4(ǸҌ5jSm;sV1,T2Ȼ:o^z3-\S7bn\Z$9$b W|xW*1,: .U5J{Ӗ&:f_ki@2P=Y^2Ӧf$.Pg0YB<1G ы'=Y (|I_9eKj w5`[C9܏;:*xϳ9v3O&9DL~KOWNG ˲>)+xM jjVJ'u0gچ<96(5ތ%u f6 ,# i!] ..R:3VS,NFVUWx@IOϻ縘k\bF1k+YݺkڦC $;%Sl3) ]%H$FdAp79^sia2#'R7b0`1Y=5@ th㚄;|` nD=,lIMDD ߞ{OWvO%{ɯ!: wu՜ON.vwzN?M #HJLr+Xks͝)TQ5fhD\Ds)/+\YmjG,R1al:%8hcN0sxjn4XLDh$'Ł*"DCN:"3/nIL0bm{)f(J]4b"AM49零dꮻ9["ls@@.2;N97wwn>)"4Ԛdc.K4ÌL,#B˄:=PS(_QV''v9%'R0ChDt\[pK02pZg޵򲖪z jPTUECjup-FxzwJah;E| ձ씚J'&%J/( 0fw/"nŃxĈ&,=ƈ½٦mh< "F8&A4!5⒖rl~\緖IXL*Ȇ}M2ίw5 'Tد;* LQjEE=Re1rdl=Ԡl0m(yʅ3CvHF!cGCĮ$H5sDY'.eE'feg=zOjOҰ?e}BS?d&5I**Uo"{D!j $BrajuhʧFi06Pc;fLycO i h h0݈a<ELa_LqJ7(MAi"z 6ZgtyUՇ$n5pCu#iLxo9?{`9lez{Y,*HfRGw'e''(Aj^x/ TGҰ6t ij`*::A^ 5rMh|OϠO/nomSC8q8_k)?ZP֙q9xN{qfH+pZ?.gx?5}w( CiwL&r2 qQr] ˯" O6:%ݨhX*&xMRj;@Щtǜ XUHOrR=ѝM5m~ݶㄔ M vl7̎+kO`ހZ!d8Yĸhgݹn`- "GVbȾ[f;Wܝ ;c- N̨Z :Q;œ4ڔIinÖX4Th|͏?}Pk~;94v kN##_p{]tog#cٔm.1q&X*iԮ{5NP)uƥH#^hnH)0jzIcx v4U逩RL#l\Ԥ痎HYacy\\:}0QrD61ok1۽V$͓Qoҝ!OFڎz:}]Zmg0nhf7FuLHhFIVt~yQ\F5G|۩c"3n΋c˲n !V۽ w/+MKŃ4Q9(؂ɏi5Zj{!''Ԅe</*'J9N}I))!N^vlVwO`*Gjε`:*N1Bͻ ׾ĤhًUi ,Q-4`ti@AԬzhD ek֦*caVwZ[|}| kt#*`zCG'+_y㮂/-;y2RayjiB\X!…GRA'H}T{l.d4,zzQ؅LE k;MbjT&p$RЙ!?I^;inHJW1^dЛSqC"fϾrٸ6ڐFڐB!Դ{ sfd+^>z_|K巯9 jgI$LE/kDi*IEIN]JIE!fdv_mBǀ]+EِlWrf\8#g3 ^{tKwP״V.)CE[sǖ3g䥎:8 6 (aMQr'gĉixbJ'Ɓv'j2XU mV-.^~LD5H&>T݅26x2' ;NsK] ;Uވԑ:RxMLt]}zձkwj›CG M{"O V* o] ;-O"2hK:#Z2}Co^3w+WMPxt. g4+ʊmMf;7e}\@@Ncb]C||vgv V.Y0"gH6m9^,\U` }rh~\L|іx?]a7 yfwyӿ[?{W Nz4G}«q~rTeQ*t>؇k. ;E^?S֮\QT}`'Xۻo{弬o}ZTC퀼FI5̌q;gOs'M¹ B_o8\lAY0o$'>TUXqQN pck-{%jP9z'A06>x:=Oy:@ZyZtku6`C?|)ۊ2h}bL7VZõ燛\Qr'Yge&B^Xs|3f]P_gon7PTNIw9n<@zLp&tOvH=O-ۖO^pֻ K*{I tn >R?2{L}\ҭ9gRՌ]Q;4 n7Yt_(oc^OJ zvw,@-|ڹг %I bf+VYB clEoieONIDATV'-Ɉx{e~Wx(7N{Ͽ<0Z)LnR -%]_%鄖hUT8ԭ&㷷W;JpGf/_ PH7t  ?1SphxCeG:jʥ\Vtm4eEjm,Hs1Eːj@K nZљn(.~z"( _!*u {o;%^O簊 u~\\b7@yTXJ=u,<-Ǫ}NF"N.mV\*sHTo@]", T+4D ^_Ѫesٟ1-*2ށ/â)ļ@5>RͿ7[irߝ󝃁C}(0.JӼ}|g2i%iTFKNm}jh~- ܑ˶~b=3w\Q9{d0!)y P\KgmjZ?v`x./!'p'gYL> 9hGqEWҴ+Kh.)'~-6ޕ@`W=kDq6%gTݣ ;#]Tuywq宀Wg3;sP:׭QAw7^[P}~;?K#rŒy8 I͆QNzм禓&|mN{D+;٧{%9>e㉿IENDB`vctrs/man/figures/lifecycle-archived.svg0000644000176200001440000000170713622451540020104 0ustar liggesusers lifecyclelifecyclearchivedarchived vctrs/man/figures/lifecycle-soft-deprecated.svg0000644000176200001440000000172613622451540021371 0ustar liggesuserslifecyclelifecyclesoft-deprecatedsoft-deprecated vctrs/man/figures/lifecycle-questioning.svg0000644000176200001440000000171413622451540020662 0ustar liggesuserslifecyclelifecyclequestioningquestioning vctrs/man/figures/types.graffle0000644000176200001440000003254013473164157016345 0ustar liggesusers}isG_}ૃGG{>tG^|YvG>|aT4G?̦g,Nv@Dl]fqЧt}?|:\.ŰǏx6xEIz2EWqb?R-{# C?tkˋN9Mf^^oI]en*[ѣ {k}ge }/N\7͒gI:z*6b,}OC/>>fxFwp9SqVtO(y壕;/r:K5ctu" pO^}t뫗'/?y翏'?_i~{'?O^i>?9z71dM/ikF39s:xjJPN>Sw6;p Ázؖt]m27;wӳ8G M?mȐ.Ra?%WQqyvy'ϳxn‘Vy:JwǬ2[^1.oZNMo@dw>r_ovO+s=e0ى(4?B#Ϗ{߇1ORw>&ʑ`KΓ|x:9%#xx2KIh|п?&blGm|d%<8LҭIS˩ֆ<+~[-oao^&.͚ lԻ8I?Oi;X=ͽT{?uS[OZ{ۙSoɁ0r[p utfv^G>trPgN{;s긪⾪*}lfYG#kA>9)(悫B7y)4c [F^˷ {!e(#%V+p[8 (A РE\O`l`p aڰ- `Q681>`l`l-lXOnFv/sӶW%Bf$]gEwޯx0PpKF+pCCCGnlJja@ 8c{R6Ko$(\\#.28ܴ~5s08p2{L908p]bA^OZ28pBEL[nn^p{AЖ;ڤW7NrIܮ/ e1(ܷ}+5Щ&vq]Gmu]no ])v (Uن 5{,or݅65GrƅlrD}meƚ7fD`DMymre^Smc}vLҏO|g19`rХiyօkk=##BoGmzm=V.}إA@]xzޤ7Myzޤ{J[٢^tczqz kpP[mQNFz5P ߇|$7@_P>  BhʂC mӶTA5Ua`"yUJÎC^Rұ
:7>k;Ce9.|vrTxTP?R&Jl%{7X,Pլ1LLA@ic9pZsc#'He"SD5@H#K9=uZ"MTW*큘2iE6Jsb"ҒǂB sY...2eLsvU忙V5BNaz l!JGd͂qo~LEKEpNqpRƬC=a|*Be-u[<-sl؜t6XpxB/ƠAg-r(В~L}kz4W AIBein(Ra1$ p W^vR4P,)/3g 'ijϦ_|Mu8G,1u'99'{p;ovL6_g)7 L™}G`f]D9,y!jJ}spח{V)A(AVڒ'/; ge~P:%5D2(RF{Jh2,_+P Jh@u7Z-HusmepBt7ZY^# LQ ޥ퀣G=v¢18SE't߽ Zˈl)b<x5(2zGkºŽ-6C芞Q̍-ɸ@Փj o>j;5HvݕF W:Q(+(K K,i( p p.&P;Eҧj ҃}F"\lv\lv=xQ_aD RZ1e040VWi4S/УxZ!̥0E="exYMs,0m6z!<k(EqA)",z^Q( 0% b6¨^R*'r*g*,=DFKYV9#xJ9d"'mh'(w^edi Ę3g P*.)_}#;1gt>n}M1_}x=PK_=Ĵ젾eJո{߲V(h:SS~;Ut* y7s*OGs>`Yf\`#% 81(P.5b_.92G"Cӕ^''S֛d>~Y oi21 ZS4x[nFySW [ &4yk62"R^a[KJYxS VZkuqnU`DBX DFOI aKuJMҔi6>h}XiZDKB5kZdV zTCxO `jZv{I @ +@pnuPQK"!ԀX Arb "EQDHi@)e<@H` `^6$:b (w^[J-@h)X` XdK 4Ew( R>w W+QЗ@lP g\=+[qIr.i")iJͽW '@ ^VK[Iv#Ei ,'r PQ (sECa[ևNW{X^RV ,d}$`O?5\lT~~Kl#gMi^ڈPQK R".L\l:ɎBH,xm/#EQ`` \$HrcQVAɯ! 冏,@% z!@X,bB[n ,@ɮ NE ڄ%>>AF9A冏nXϨ _V$D*H,v +@"AI-ڔˀ*cD0V Y`V Xdi<OR]O irД oAabJ}HBK:r@x]P,X~ @0.Ҕ+۠@kqXN`9:EDȴ|ε"'p=٫~ uVKފ3o.~F (=W{+2g\>ss}#%†2}{GsF HCXd_2gd^^n|N%z&PgOd>}&L3ZF *(V"-o{6MTFDBZ @BqE ?Mɮ}'n\=|ΆZSJJ:T0.%)5ürッ][㚶_a?8ᄶDN\w`G"hpD_@*a:-zF-E)O!tdh҇V#\wEkW>- Z:Z"q 1@y㱻bUl Bs +ٺ-hbQas]-(>ha|- DZ"Dqrh1RQkDe ӳ`)DIᳰSqE(/DI+-pP= ̂qBYT@3T @ ދ Я`BxAg9XYg"cv"X`Ϫg{,v)Xp,1] =+~ϒE@iCIQCtx1 QAoFSzh!-'؝h-G =;-t{j˥ˍrF/Uw/hѣajkl]V[in E?VZH[gj%[;+X#b4XBw7XV[-N ^'̎VBJMo"KP{)'I{~O%^(:h ZP ^J{Q@=xO2ޓ$c$s$<r_zp1x]7%=[)+{@Dd z}fa]O֏F`waai_Y@O_H<0Ac<,tceqg=ԝlT5ىB|tW8g|035[X";IwǬ_^m͓ /I/i0MY2"r{x2KIh|п?&(-燣8glu}ϒq<̦3x 1 H3p?kY{?6N\O$D=PMYS(o$~ZxSiBu{FT-8 ogt[hl4$Mejc٘|nz6&[Iڔhf+nМ`?۳ApYÎg ٧Dv5m0pҜ4?ڋA 44O1֗ϫTd2"JH3K/"εqOI\,Ʊu8 HDBk= D̖ؒ-[^DV{Prz^Zc=Mю|m󉴞;9 ;9;y'\-qoݓqz2)[Wmcγ) ;yֈr.LSu{P]OY`J2oXLuL ))Z|܅lCG$لQFcccT FMi0] RF|ASH R8K4Lb*T\Jߓaaaj LuaSD*tؔH齛ړ:C u= (;2PPPm9h SoKB((ƨx)KL(Dg JE; R R RmUq@Jc9sBqʰRso랣>۝ATX6t*$@"Z<:dG*G@ v~}؄]£%lZuhV_o=("N;aɱq`8RF"e#rHJ͢THc#!#ql$:, '5*G/(HH,IHbWFbHJ]IHh$ 62FR0еRb"-* ]&Y2q?[J7+ݽR;ՆKRL.wi4>]r)u`k,RUL6HUU2F/og#adDHUU2HjF"UU,sl$d$VCau}FBF"HiP`Emi2pPd*.k}y[rݝig);C_;KƝ^NwZTД<-^!{٣{^ON rH)Kȣ^􎑇wӉ:5ξAAWӕ搦 w׼aaWә~!ב20 vQzL-'e Gww3]C҄ (;J}$ ^/žzwG۸\6b9b^vqXmWn\+{EFximXu /9}e#굍po"֚{3#lFXGؤ#IG`aa6:&muM5+2, (؈}6Ik꽍pF}6H#{ca{aa{aa{aaFXGب#FXG8wюu{ca{aa{aa{aa Bb͊雍IG`aaS=BmDzMZؤX#YbZkM&֚6iMl#5mԚPFXkڨ5FXkڨ5F$kMkMlGzo#H#G}s7)bMFsL7ľÍ&phM2;bH+uiMm&~{a~Dn⇽7懛"{o"!-x6g˯,-p{6tF}K>-?Zһ6G\)R/F!>I ϮHwӷø dU\7 FnxO2k Óqz2hx (0IKd]~'L-Xv(z0KHr~5% }rMy^4ڳ};lqyW-\p!aD JR c;U?&2]lε[srVZ: [=hǾvt˷,Q6xu]UΙl:N⛋#vOB3BjNqq" 8:X~] 㙿.ڼDSH%3:K+Qy Ep hCyFC`_t$,E#[EODP8/W5nG֐fR#l-7Ѷ,2ebtE~g@h<hz,8B0Ļ2HO}HGܠ۩ڃZqڰV[cWp.[>kp -A{X-ghnEԿo-#m׫Z X2"WMAY'T/'Z:4:BRзVx+ -`kW̧ɿ ')~V]K9PP!JBYAS#WgA@+8EWg 'ijϦ_|Mu8G,'99'{p;ovL6_g).787Nnrfd&W_ղջ #L$|J}Rg Rin0/1_b12ﵹ֤5>~7ԑ5 xdAWaAXP DHt XPhL˂ ,(&.(h(E+ A߱IQW,#0Rzg3F^Q((VXQ`E"0<:%\ŦV㺛e^ 4>}-pg BށdaS{,U}r' ,TІP0ty t<44;$<`2d0.9OC9%#⋇'$/ a,r<}~8JJxpxF_> g,l:+98`giR/_ׯDP%OYAAH| r75"ޫ_ۛM^1 tG0pX]^Y!I膝*Z㚾WN{{rMJ:34 cG<^gT$-R;ƫu*)mck)ÁjT MlTn[i+wϻ (-QE"2GAZ[\^ս/& s^QFFJ }}ksI6dsI6dsrS+MƁ7bQ$@ʀ#>e-/ ]X}K:MTm\,4O4Y2K;'/)`yP]ƲSSvMy.NƭE$S(+m>+׆~y7s7 ݘt-缷usI;L1Jb& yM -ۖUwyțdneT7vvDL@Yڏg؎zR/PC4<ǟݯa"CJ!:c@u \u \@I ZΩzR\ǀu \u \u zHj Luch6({{S*2v:0N>3R;AO9NyXd[&){{Fa)R NaB' eSeDȀ"duNz4,Zhɢ%]--[n/!\S C;)*A|N {Vb;Ktl\_4A9ߙ3g{ǚ舢a±_`: bIeDEXm(%y3ge[8+%nk X 3;-CHe[;"KG.#RswꝲJmoNg-Xn[YE40h^1[S|*aⓤ`+H)]>IrnvQq<'V^ǟY&$9W>4i_r >Ț/8&o4#<[oO&i% zc!%ot,X&zՈqBq~/&'FӬ&IM_IiB2څs\fӳtc~,M&`lexO`kCמ eqo%IK^1~:*I1X1;i;Y='d$0Lp't1>B̩ܫBx8K+0&]acgՔ1[&|qڜӽy[ iN=g;joi 2 5 1 2 Ү$IDATx pT M0X"B[S*L”2m(С 86mymZ[*@I0E*K20aBi)`,"CbxIxK]͒=g#gcfwIjjjRn(***//wݸ{ [=/@7c/@7c/@7c/@7c/@7c/@7c/@7c/@7c/@7c/@7c/@7c/@7c/@7c/@7c/@7c/@7c/@7c/@7c/@7c/@7c/@7c/@7c/@7c/@7c/@7c/@7c/@7c/@7c/@7c/.aT[lihh;vlvvC zdM,}>dʕ.]~׬Y"Cd!h_etXgqkG6F nȚjիWW^d}_g Y_ްa#<5))ɻ+w3fHMMxu:ujܹu ]yMbN#G 2G2!@P[sСaK\m6zӦMׯߺunzɜe˖eee566]vGL4I敞.k;wtfZPP!JΝ7nܜ9sNbD@aa=n]Jp)7sL#SL6l=߿ᄏ`z^HuOs*۫wխNHiV:_'563I 5[ Bf&uz 8D5"$.@Xo'FD$-!@ֈh3DYc"mfX k@@Y#Ldp kDI"`]Nd63I 5[ Bf&uz 8D5"$.@Xo'FD$-!@ֈh3DYc"mfX k@@Y#Ldp kDI"`]NI"&go=l   D$5!x& L )#$EEEkeee 8IY~m֛jH kvy#`V1M5 5R;ϼ0+@֘Rg kzS d3o 5fTFj7fTC@Y#dYo! Uy捀YƬ7*@H+))YrK|~5kD>82 D .+VxgwB 2< ON\zuK,gɌD}YNlذG\H~bf̘꟮SN͝;7;9;d: fN2G2dHv.nLܶPN:th#Ӿ۶m9ӦMׯߺunzɜe˖eee566]vGL4IPd;wtUPP;JΝ7nܜ9sNbqֲ)6nꫯ~뭷˗/gϞ=zT&… =.\8qC\ַ#F۷or.a S."7x @/^?~4 T?q8p@;4bp &7cǎ͚5K?5)Zϟ~x] d$tYe -G'I%$vΎk(Nݻs۷,Ns\C9XR_ޙeYȏD_"EEE΂²1ƳL'&GRQ:0麀k^-xL何5Ñ+>P)PFh6C@Y#Ldap! Txa08*@m4zO~z/%kb TngRum Ro.pYm}&  ߩw~|R-m{TS$'5:YӶ/G =Rb:{:0"]3՝̎TC ds|Z+wبԴuVbwlYm۶-ɓK,3fm6}C!ظf͚}kzwQXXX[[kCtMdˆ]Pe_{֍w_qbE̙3L2eذa߿ᄏ`zz5Ȅq' w7^1567+[X˚O ܪ[i{eۅ5)@'J8vνq]#Ɔ:5򚣭/ܣTpҟWz#kSh \V, lAJ~e^Q\1NNAb!UT{oc־݅kԺgݱ?D jZ|;" _էނOD /OyHx#~7~Nt^=mk5䩋@>H{ީ!*Kؑ(wƟ[#w3hYSLTC =dzFoPݳLgM޽ `K߾}Woܼ/233L.!ה~~\i_RR`lj5o~Gh3 STTT^^WVVfVd%nKœUȄ>8apl2} ekEd]# Ei所]Ʈ?"@H4DYcןH kty"`WOu5R:<+@:R)f kS)dN3O 5vFJ'vTG@Y#d]# Ei所]Ʈ?"@H4DYcןH kty"`WOu5R:<+@:R)f kS)dN3O 5vFJ'vTG@Y#d]# Ei所]Ʈ?"@H4DYcןH kty"`WOu5R:<+@:R)f kS)dN3O 5vFJ'vTG@Y#d]# Ei所]Ʈ?"@H4DYcןH kty"`WOu5R:<+@:R)f kS)dN3O 5vFJ'vTG@Y#얧:[jvw˼jW;fSߝf0.@'`zR/ޮzzJ~k[ޝGtA:vjXqd&0G-B'ݠѫ۰ԒYc ~_ztwz)U_ԛ >-uV=oB1L(~?='Ҷ\sZ&GyRӖ}z 8N =R[XΞ_ٻ˽;ysT` kEgnT=nxZ+wبԴuVbw$`P߹sPPPJΝ7nܜ9sNOV1?dnNPm^>y^TsUgՑӿF|I-æ}񚚚,o71bٳg]sB49Ŀ1p^*or+VӕM s~9p&| U]]=a„CZ|| ;6k,R!ag/}Pp>}uw"6&77ѣ10f̘kرcѢEΣݯO|eժU}{?;xq<\CŧNUy`lJʹc16(aÆoʤI篥};ciG&\VrھU7,z'n6Fٳ?*͛,v~ x͟n_2yac9k<"uuލK27m_/ M&XY3|o~j IwSc*Yx]燍IOOٳSv!W XL&WnU^v5 L7 (xkťYm/9L=jNuwn k-TGW.+jaWOB$`Ym:*u]m=yU5jݳ?Inp..Ԫ?~:AwD'~?˒|L#ּYcޜ]xD~M»YaJB/WeO{kĉY'4n&GjݍzB/+ϫcGnvD krSwm5 jO݅ v; kS՟?qwIc?|BenVY_}ܯ_WUrtة)TŹIo7Wԣ8qGaZ"qř;;)++ Z,$@j6SEYc k5"`QOi 5T(@Xħ4AfX k,SAdf3U, 5) FP*F@Y#LdE|J# HlE">$@j6SEYc k5"`QOi 5T(@Xħ4AfX k,SAdf3U, 5) FP*F@Y#LdE|J# HlE">$`3V5FIENDB`vctrs/man/figures/coerce.png0000644000176200001440000002226213473164157015617 0ustar liggesusersPNG  IHDRm3sRGB pHYs+ iTXtXML:com.adobe.xmp 2 5 1 2 Ү$"@IDATxyUǕMҠ9BI" 2D3=J%JHIA(*Q%Ji4@za$s[ny-Z0b~&Md̘RJŋg(DoFd٫Wp 8w\IM ^x$e˖_|1Nz'% h ϟFTAd/C̙suwȑCf}Ν{ΐ T!C (SOs:0JH*\0U,}'H@%\B6ܹC=$bjժUuAu"ɓtM._<=n 9(0ł\s5v̙Č[z &$ |.]-eCLPjXb^gy:1Ǡ~@y1n:ն1d9Q vIٳ0wBjcGQ@I#Hl!p0Ukn߾aWBd<&`+ke7o22ۆ =z[]Ug%/ch"z/q+iX՛oYf͚I_~ɖ-۰aøQLt9YPr١^+#F]tEC_E (/ŪW_-o~Ie"̨mۚR p#l&LB0E`ѢEH6|F FAH5jILTv']vfB"҅8Xƨ~AO?[F$ӧO6Tu3/RDás{m都|gba~tY߾} Dr١^k8n'N7: yf~b_|IbpI !0ӚsӦM4(*X'Nʔ)c6T"F1&&Z.kuv0'78Åd̢SKr[re/M*[7x+5Ʉ XK1IX3 \.f-aX$[]"sz(-~m6B WX1A2X@Goɴ/ͨ2B"t.r!ra0oƖEAZ l`UV?&L{N]H5kpk𹕝 R#.n#YkF\l!Ot#0B<vڕ&L41p=pvc";DoH. ;AH@*QVQǜS>S[2ͭOMwj&=/RKf ÛA^<ް Wqgȑ# UL:l F^yf>i8'Iu9[Y}*$^Qps@|bN I ?nɁXxa;n}6IY3 ȇ1eﺳ69 Ɂ=;A\^xygGqPo%JA͛7K0&BGyL`GEt:|G*&s~8d9xW}լY ~ʝ;7͆Wei*~gML&#a_~x6Abɇnkw?>h4|H$ Qipl('1ŕQ9L3 I9T9kW2=^A8/%ܔ2ʫNW9"'GoT!?fW̒+@_|ӧts=tP!?P2ʟZql>UF#҂|Cqm a8ߺ)eT\{?} ǦyPqSSF*ک}ڵ|6NTt[oRpC/ ›x7gFwEn+" ijbȧǃ'ϓr->tSʨtx::jԨ͛:?,v馔Qlz{#Fy e˖mԨIIQF%4R5ITPC%q"EU2*2) 4Ta4h+7 &q>|le<͊MDۑ[N2^ۆZ+yæXnQB>-Իo߾/Onc;h )eTrCj߽bmFr$W ]^HIN:Ż<'qSTr;5uT u|#5 :GlٲÞإK^H"OqW!]({cƌ ;ٳdɒgիWwIl{֭v-_qp(HEs )J~/[s5ok9sT\ܹs0'^c/^nj6{%Jp'܉hB"+V Q L2@hr:u9(׃ EL` xhǎ  H?3s+`|sɼhѢ;Ңj֭͛ǁ^3fFš5k6oތͥd0>ӦM9r$ >+hDܹwE+߬YLH*v7}t Ġ':r̝;R4loׯX̙3S:˗<X  U@9Qq7K) d IEyozj:uDT0I3f(= ;,I}I[UhQ\Ӻui! 6B 5kLXl8Dnk֬CIءۿP2W\XeT:vX/_" ^^eիc&pMM81G ƬgΜ1p*9c>s:c#z''p(sfT޽M>}Zj*32L0{ŋKC,FիbŊF8Nnժ XMYSƸ0S/($ls2ʡF荒/ ڹKİ2t♏;FNom# Fr >q6v)(B]&bAqY>bQƇ ^(YȲΌ.\00İ:$PTO 8S 0OLFyNV("!<[!Z V(fZ%{2ʁ >[(3+k~V~'baAGA]`j$ؑ3V퀊(,$9xgF2;m[۠a3ƍC1k6%3>T-eI 'm'EY5J+%g2z:7301جڵk? ,L 56aO&.'XMT°!GF-J  0[)o4dfq2rpGlQbM2q~a ȔbOt/]r$6DL6 ,"{U_rUp42b,_|a#Gf!lv1XV̠Ef۰KjɹcċcZ6'Ico RJIq@ w8ni<]ulْ "vqA6ڃס\ӦM?[ZLcXֳJ1Md|Ν̞C 1( u`4Yu$|6'I~a>L{ؒA'6]yloЏƔrJLyOCۇL3:`?@1aPN19X V} ό].v'OL%Qx26uoj3H9c䷮إ{dWo^ [ٖr~k"_f l%p봐mwc{pr!]~r*XwX$8gN#eW#܆jff]Gcќ0# cЙ^`eǜ~d$1FъdwnzL1\ YqhYG1MW8+^ b 7=6GdHÒ O;d he}1rD[iA)RLXs 3„K#!̤U|eצΔ+}dcnL+tR7ul\҉% 3[ oELX0acc9C;&;Gd&>QY2Tc_5,.A @ N5v!>l2TPNʲ-ɒ/@O`8' 'oЛ |̗V D3J̘8ͱ85O* F 9Jp#:E ax{0"E(;[!J>S2Ͻʨ3$Qg T7E{Ώ )xآ'zE$G0q?QPHxȈBxQ@g}9YC@/ͭ8#rGSw(᥹gQh"e;4"2MU!rVPF9㣩;Q܊3(g|4Up2^[pF@匏*PFKs+(TE(wxinEe3>C@/ͭ8#rGSw(᥹gQh"e;4"2MU!rVPF9㣩;Q܊3(g|4Up2^[pF@匏*.{ׯmQ- a*A*1 Ӣ@ʨH4BeT iQE eT$Ā2*"2*Pb@@xZT@ RF?~]D"aÇ?~4" "eO?=gΜX4EŽ;vzXв@HSHdڴiEM@ E Dɨ,Y_~TR͚53fݻww߾}jբN:si*sUVeΜnݺJ2LfϞ}С 6n8o޼&I@ wdW"E  y'N#G… WZJԫWIҘ1c2et饗VP!_|mڴ! IFɓ'[l!CC /pРAgʔ)Ydɟ?:us%$AQd'"[.P3Çm۶"V58n޼PB[&i&xb7k,|W ^~eٳg{A]vqf͚f˖mذaQD"x!ǫoHrz=yG7Xb0DD5jԨAbGy}TwرΝ;}ѣ*EO`(Ac"zu֊+f͚4z꘎۷㾮*뚊y*<URDʕ]vr[vm6HZ]&?#Qٳgb *kk;f% ߸YN#G4`ݺueʔL95׳zݺuș^b]TlY/_1$3gl`̛7įXqƹsٳ͉͛3L6 ()kFu}ׯ<,X%IM6eڶl2: D':u! ޽{&M؅ϙ3'!![liժI/@5>^똼Ѱܹs׏YaK]tgV$ ^c{CpQê 4Q$ϤItO0ԿG s&$lĕ(Q T'N(P\-χ~hXw~XM 򤅮iưEaMv`曏?;4ElŋDbJ,i(v ۊ"CQ(z7٣c ~zǎyf\)ƤUd`ă|k׮eO:}46mW(gT4^HDJh("'QNh"e[4"2 MS"rWPF9i[Qn('t4Mp2-b_pB࿶iR IENDB`vctrs/man/figures/lifecycle-stable.svg0000644000176200001440000000167413622451540017574 0ustar liggesuserslifecyclelifecyclestablestable vctrs/man/figures/lifecycle-experimental.svg0000644000176200001440000000171613622451540021014 0ustar liggesuserslifecyclelifecycleexperimentalexperimental vctrs/man/figures/combined.png0000644000176200001440000013327413473164157016145 0ustar liggesusersPNG  IHDRN^ sRGB pHYs+ iTXtXML:com.adobe.xmp 2 5 1 2 Ү$@IDATx ~՜8_a #!)d _ Z6[ڣˤm$UeS٩f̘ cf,3>>w>z:Ϲgs>糟.w}7@`Eݿ/Oxi\ Xtou]a=G_M|`~lX\?|Bvo@ÿ,~v@ 4 ;qr=A}WZii2 袋2>pF>Ͻ59gaR2+J ,,3- 67r-?Oq=9yWzچ:%;d<9]߷?^xa!{A +$~Ї.&я'?mOCzAK_Q<p@T n@ӰBg|y!A'gv^BcpF/rmiaM6.+_fmo?g=YD@/zыN:$/}K)gk =p!\r%CЇ={I~w11Ur(^Շb.OxŔLj%Gy+ Wyٯ_%N̍7xQG/xwBÏ3J$/3^39Oh` !4Jq@|tCb @Ayy=)O!~#Ŋ~vX(zPn׿5O(=oڭK _(CvyjG\Ұ%$J;?o9JZv{页o~Be:B Ud.e;12Mo|~-^}տv:l& Ho2=\yH7D|e]bwşCbLC-)pX{J{Ygu`CS׽6Iovg0씜DiS<0i[}Fob-fka6!ƌNa.ͤv7A{ ZH 1gAm?ZCvp /.pDv'\oNźERwd [s=ӟMb%~;8AqP> /ӴV^QE{-k%W/&*KvmQ_qkEE\>|o2>SOŧ1lLm5iv7ߜPIF8Zk:sĬ)(jqcJF@5v^WOx4~ 07t~=IObZh1tʳR~hdѭݺV[3շm.=VOݝ_2Y^וc4[m_#skL*aChq@6\?S%O,dNqKh Ә')iqvװ Ao^2En?tʭZ;ޛL]srnQG ɤOq/n:ec|4vO~buKc̲G}- wxџY-6lc+Nx XzR0Ӟ4Nb/X~T7S>|k_ФzG /d8yBַ̻ %[x}bZR83ԧ~#=q84I[z/I4ib]T7)|'?I]! w7`3=ѰY3o!!훈FL^WN}U>oKlan֝CHlMGs[K `}g|饗TROu42.?A c7#F{y{`ҬL~ń]ON%:k}Xv%3ECK0c=hm0PBQ_o}&b7Y//Eߟ9@?+68<  m%r7{YOI|KA3b=1˾|TADv lܽaPkNC-.9UHM>"j\mj[4Yn4 W?C0V)3h!@i 0eMr$kY]P@I##j2>7EUxU?J<5Oz)\vŷv$ =~$qp++ܿ'M;BRq&`#Jb/Mj}sPHsT+' b"%=@GKxÀ=yD?xyh}"`7onO#8¹n=>__Q `Y;Ӱ1>}% 1fV{7 YDX~u]׮10(V% ъ"ZGbozj!`Mg䐓BSoo\\[o5k*h%chF`Xq}1My˱~dD1F83\X,-y+Ex: Ue:}%" "hXބfYV@,^z>#9CL~f1b"dЇ>+ Oxc쉰B82Vy|~!aN(hyRъ}c^uodDψg+L[ &)9rsk]**%Պӯ5 MM$SLs]ggg]҃G67hQHYV`TFD?묠?d+%&:O~rNЋ]?S`ҟ4Ԝ?OY59m_EXFKA3-9KL?:]> ǪsbTnKldkcWs}'X,<h$'`H9hL^Fo}x0BF(q5X^xE?XXVµ(|rAo:ޫdN 3)GaG\ƮȾad[(ʺNCy`~beІmx =ӏκɘcO9v}b LӖ8榛nb_͔;O!5ꚅgf:렧Nmlu ؔp[]T? \? u) _FGf |3"oAvVQd%03KQkZ C)a2#$Zi</B]tIx3ԙ*ҭtkeIzEÖwfvoVD@x%f[nȑ b˄}C11y( ʮy [FgJӃ#Dr\ph_#W;}oxh6%Bc~=Z8v^Vow"T?=fl̼3t8A[ijtQ3X°wgZvT)}1=ϵY#/E┻N2=tN[,|$i/%-^xLůd= dY@zm[kzqyNׁV4ǣjmFiR+F,ov%b\p1b*Zv9do2Ϙ~4"[EaqNlN3;{^1BcA!ybN!AVKm2ܺQX-V/Ń[ 8&|d~5icz[ J.쏠pT`Pz*I4nsd0JxduE+)E&L#NzTz vV"ğM=B/ ptW^f{yM0Z_>w H|a!rXS(E:$׸`kRoTi}3N;C9-ж(b b/K)xxߢP5X?/6N&RIڢ~U ҫ׿ Jsj% ?^cϳrwOx&Ní!b6XodҡmVxjx5LW@'"谹q&mظ-H!G% b Oʡ0R:`Nԧ>5zM%Q}Զ&Տgvǥ-𒣿~ "HXȽ]thA;ǎ^DdG.[)h(i~t?qxa-miy#m`~, KBiEZ VP+91)yq鷮,`E/"xC bD?<$atiդu}^pZlM%08;=CG=–h ڦ@iS+VH6It( vdnGi@ؤL~za .z(`UW]Ey,(BkM [N{s MEfF#3QDMӤ\C]L$-VhR`_ve@&&l#Ϧ"܋#hQH ~맗>}f<[]wyD@;k ,l rh}/!g'Bկ~u~i\B@)jNl8ۖthֵ.Gؑ :cHdd=`ooQBʏ 7u1~m?{HނȈ'(CJQt8+9?>ܵn`{{' rf|?%]n bmMLh▛I/$ 2 򝎮t#Z:ؐw+lf.] o~4Rz&j_L?Kn{{%Djlb?;k}Aj1 ͩTv$ cb-HDw$}AOz:uf(wyˇ?☮qoD~USydUeUʐ ڌoFB,LqOCN׭RCBn.J\8~YA-zhYtڋ\x߶PӖlZ8D+ )##j%ZHc>32[ nT\a^v[[S@>Uօx!qug.;9I^dfM5~2H PWWD%/ނ1J6K@}D|@sM: fۤJ+c@sG+T׏n V& 6z~n5 5aP]D_^K?@ҫX {mx%-0ݏ H/YG<ҁ4)F+@_&fƧmLFjNBGj;D(i,S/tnrQC/ٜwicy'~/m̯ Y0} BL,g0^.$ax6NcIB<Ǚ]!@Vg.ҏ\%SW\An?wGt}H3'J.NUSFvD-x!{`̥^:0]avm -rĜWM[jIS 7Kr KnI\ ZAiu"9x,TTy#Dbf3%]^W4cIɏl2-fL1,"orƲO\TS S0fCbq9[MozΆ㤉|>m 5kN[襷bx Jac`Ϥ2'JgKc{`]%NS^ͺćmLd=ct)L5s$Hǁn#c49o<-_\9K;{`aQK;9?Ci{a.,^`Cgb 3[e8X'heUz  0sg 7q!0@ 0Xgx)z3eWwEXgx+C>+Jβ|@ i(۸ΜƛnǏ~ܒv=~Ox/뺣B <Xt_(컝Bo勽tv_ҧ{{X9-;"?R.wq%ns}w)|M0QIHš(Ȯ{3}&D9l^֤^b ȿ ]8*?#6ZocDqu WhO|Fo} 7%,4\ފufi/ c HXhg1G%.kAnH|!iwaT7^yLي:4[g~]CxH,%"{&eq@蝿o{F;&~lO3>mo{- n֋?Frq^Gz2^Լ}i{L,ʃ< 11^zyjPQ u^*pPZ*gxh~E[oԧ>[{*P[oPpwk&DL$^ x~뮻|G No2R$4?!yHpz]in _ƙ^pN6s`[p?W U;iQy뭷[4mf5(_ѯb~v8{F^~*^]x!g@.Ds[CmBq3x^`>%2?k -S-f{ H {}[2dޭۢ} ꫻ DP55n-kx3/'Cin r!Zn#}?߳l9v @PҎ;XiMƒ{ Mʫn-੡<OSbfyc{5d66ɡcEK;$%\ !1_waJV[ bg=Wf&=9^Dzp_2]?/B GL3xU3`h:il<Bro|#fHΘ?$d ϥ{ţ|*ICytwI{PBn/K,#ScfP ?կ~5%9Z+S01ĄRK8r6X`H My%9͌()>9/.cñ%G 0p 䴌n&ܞ*fz)}ةbXaNGdkKb7$h*c>91V.s!pN13&p܄L^b"@E \IUi#믿]ZD>\e97ewWtI#AHp A$~x &NQ7mCu&Tz *=!KZ&fCy_ m2p,0$!)дLK&s,J^Z} +0tAOg`+@yDr^(!%gW|U&Z Mz7ZY]k @kONv/ZȥMuRhR,:Dњ3% ,㳘"aHhy8e283PPO&lC; 20B Vz%g<A^ysBXW@ B/dV8[(BXjz[ڼL#8-+OcAx{m#h]'l׽Y tK^(1<xo۩87l|0хUq2kg[ԟ@Z$-9 +fZDN[hם`Af!-A9jF[k.L]Py$t e AF|)bJDH%򶷽M_+NbEj(n.N?LNW2CXc\6w9Sq^LѽoR{ ܲ%;ƈ]֊~)gJiQia); O`G`rc_,0;  .,X*mD@ kQzQt!!`'S*O' >Z@Mk2Z$pDdaXdO:뮻 rb1z@|{,^;N@<Rχ #leǤ&,k:0Ze4'c(3Z`Yd(4 IG>'p*d ~, B YR~S ɍC_N:Ci-8]|_yH~p=B1g9s4~[*49e]A"!Qг۵Gf3P kby_ew2gwhojupkFoYqꩧ> ,86uG!Ӕ$qh(9pwu i}CzD-8U1(П Q1b/Ozғp:TJ,1(PEbN+*SD @{{kT#_΋_%bWt_'GB>k_ZX;85Sn.BD|p: >9N9ig1ĞEB1~D_h&l*hRMi>t  vX͘Ik$]DaVQB Jʃ*wƿvbO1aL0eq&^J0ƒ3`jqPLuY FVC +M=gk69@ ;;>&/IŐ^WIUD[յ+t$Jf I2[2*Ճ'ќV*][4%&ڽɒQ~ ѕ"`c;Cb @@?P/;r!@.XldR{5;X hiK#ݢ@TڌvɒԞ0^ DHPk\^Idotn!GEg\b ?siXƄԘ~c+?@qdGiI"*W^0I6!Ԁ|p1:{p_EW*Vi/:ݓR~PF *}чxk 3 ¶7sEL"eE.AnɢLW1(j^\r<^}h"4];#1GȳBRb侇>߭j br=t[D,iGzP],?:!g@ k֑y ^R i4BiE^*-PcDb>6Ӿ2vEm.AҢLC琼:뤈- Gd_;>r}i=A,"iHdH^c_}(cӈ2$@@̐ P &fH*/4Bd{)j6/fE,/V$"l*ff %W22._'w Z >?}}֦5blLo'Cb((g2u\{̧џ;;i/TNh Jm+fUNAP46Jۛ]?; *ة]̉ S1AC6Cb(}r-S1a2:]v*};H{Ï$#' e* }(dr1;و?GNJQ3L:;2,2}dA,R1p^L:\*LO[$|?u_hi4s*/fNI2 ]݃rvLo@%⧀Bgvoc\wode,J/,8Zç=?hbGf *hV4+j' Lv< [n99;2QHHD^)B|] u/rDHڱ#'$ T|+ t՞2حaI*-;Z[]8s9#Wg&a0a( vygĒ7/d Bz}z;ށGZy2(Ga<5:Ւv ;ny"Eh@@=]ʌA)d2 LC8%#.{071,{gy):10 ˄YAmȠ*0O)"Yiv}w/vaa;Suܢ°!"~04?>43$L%.qhIOzy+dVØUʗ-/9 },02b#AYa -_gcrQµ vQ ҄u诞RahលlAhLjX[;Y;&䠪x[Nz_}'cƇ b%_B>;γÌ5LmM~?UG!ϔ oqe HtL؟pyYeUx}ӋSCzKhI;F˴0WRvջcQ"t QmeTLli _y;,o솉 _Q 4:v"7[\! 'k8ng$ªR^X?w0,E{rLJf&`@F;#)^5R9"fkdM i:8``@赨M2w7Ͻ^jUϯA1'ʰ wͪPW}vCb!..]r/LI|&rT.=#gGv/B ""uu09a̰Q:5 Oh8 L!))5I-)jyȟK =M<ϔ.j.#"Jhl_S$y36B&hXcl6Wq%C] yr 6Z=Ղ*3d/J>]2L@ EAJnM 4*8舛fٙ.ZK/%Ցz/U9k8/e;&P[^6A w'/DŽS 7pԘ^®XbA龍6膛~oV}`_QHf5ePc |j72J2a>{Yus  VXW[u?vlJĤ'*?O8Gþ}N;>ݳ*p-^RO%In:J@:|ZZ,4[Zзۻ1iG XZ oif4Ӄ2&X8!ٹzS^#BR{`SXѺm@ _- ?zx';\A2ྲ j LQP'!D'98`4/ދy.9Q$f`1C C& iUW]5N9W2uϩ f_q\~Gs}Ap.|=]BV< ?\ں+p]^l0` ~?:4W!> ;PVzh[׭ev~I.|'Ӌ6ԉ/`Z=R?>6a|PO&d40 秉z P->"~ RM`)6њւbWp7ch=t]n|ukN/Tַ 6mi^/ųT@2etZPi1bv?tmeog.1DM u@v-f/]ώv?V bql\/84ƀڟ3*Ŏsq3#jyX+Mx>*oh._-,Tں*_pX4S3 ve@V׋0pqc-21~_pD|w3ŷ_tQ|W^yZa g4^ MKRKq*s嬷N ]E[bŠTD:M!6 ~%-PVd2GɊZ-29n nfG <{Pt659嬳=/ iu=MVJ_2zByTE-Cwy:Gq@IDATJ`~y`,}G # #%:vS(IbC@|L]lvs]}v[k~ПN w@u֏U1A >( e%S, Q (U57 *s±7Fnw{z{u3T8h 䈘{".3KN;`,ɝYwn֫ ?INm}OnLh";fʇ)ui9s f"^ ?ȋ8uT;)@Wм:s=c wז*HO~q#-(يsmaF3  <'b]<:WUwacKf [uW?{;!DJ,-'6kA яV"#찴p+ ) XSGzMUOPzI(X$RM5r-EzjhJKhRo]0v#S42V:ŗ6*:Y]>9DigqF1AL¶>C[y <&dt!)U|U ׎Rװ2UiOJEnhB.՛͔1knĵgV ˲z.,p?T4%- -FLJʔ2Tźصh.nd^L1@UZ[ 1&% {,O?Xl4A;f%Q[ou$"^D@bx4M"" 1sh\y#QJ(?SQy>ZuWKQDDxtluj>h{@1{5KWt_) YBk]M\7v"V` HKBG0şUS.m8J%et))k3q-s뢎 i;g1u)Y}lusEg8>d?CPd, ,xĐ餡!jXizȾ1;: ;C(8IN &IU(bjH1;'ƅ+ql>v*1DnnSſ7 D;tsX[YWQK9aoNy0y_c‼8hAOn)$5$N-[) l蒰$v$}{n~'u:c Pf Y >=(} sWK{ի^JTp[ll]1c[N hĭisyqit\&jj fk.=~;邏Nb@i͖ za fNr:R_KVcᢀF Mᅺav)hOVE4Đb;B9TwLWNPKZ,7 e[qD]6fÃag&\*&;gui"SֈL{;ށ^lc+^C9eArf;.%<+bGe/ f "RLɞ UsH0ʿ2@{6)ӯx S3fnnF O6\N[~RrvK ϒdeCL{$aA]؈$e~ -g \d(sG|gZ @xNl|I/E??\cQ}%/\$ G`gsZ\Ҡ,B1s)e0]+K l K|]V]@ M3~inZ'wZq3e*8'8 b=b-F1jw(|1!^bŘ9 O\`}ԍe{ꩧUc@6JG$!%Σ]{-QŹMTQ#cŲ-6@bǺບLG %<͍VB'w!D旌+ˆ^'O^*rчp* ADkULC ];se[,ai!wi~*0SLM?c(1P(7~B\AOl?$ LÉ]Qǚg~8|}Iꐇ;a`|g+cvioxum .B ^{A}6ۤ{OozӛHɰKTIAC0f?G?\3mꖶcU&ZbiuBE.dm9:\%4lm49(>~JԱpn&84 \p@$BgF3C= _`9U_I3ĦFI_x "/ڏ'Xq4@8# ҜL$ccHYЩ8ɑ\6䞙bW/+$QVr`%|bɱbJ)D,fG;"9v#Zmpsm3։h1(jkyzV -؊ty+MoV,9O ]~?N<%`DVx@0[@5D(=r V8,.zZS*!2g1A '.DffҌ]vK {KAGlJĈ*B aR 4Y]eHH?Kc.ڻ +ΥHfLXILtIW:S`xb6H%Lfq_̥wŠY2=H3(zF\BNH1!/ \6h9=&Lf Gꇧ EeZ+Fk(Exdr`vկ )YOY}`2vuq^"L@Iĉօ( ɨ Շ,h&RW +䃿 1>rADq~.kV_ed܁4VЋI5ПtjۈL(-b`캗 /Gs!M5̿S/I}^Wx]ɮjΆ>^11]>p(z';xC>0@ *PAqA E,(7K|EVZe(WB;,*Rd7xq݇ԧ6X4;mlI ^ҝ }ĸLdð`6UXf@Ɩ,/8k|Wb Bmz[zS=a5ax8)GԚ/P9sR rzY2ϣD{d0UNfH}%]bV/˒ᾱ -T̖bw8)>{^,=CkXMjk)X4Ґ~ gܙӉK#:>GWo$=BIZ뛻B/"VT1+5h@mQl͒0Ԋ?0}#qQ"Mo4ۧuBX$qwZ[c{1K3 EbP@/%ЋFO/h5ޙp0;ϴ|f]RTq?%M ^ Hc7ia">2i#GI8 RC2!!WRq2i1 nnz\r GCMco,JE IX!i3{+kr6x@7e yVĕ=* 嗴@ᭇB^ kq< ?#5ǟOKt c -r4:Q<.KwB[K"F5Ejԝ*. xMZ b9ibq_:&i2T/ܤ:Y-= >1+B?V5QDH?6b\;M(IX- +2"A窸*/"O* [/Eྊ@_b"ŐعFA,[vDb7WwM~k %(6~;?>>]*fϰۭdIq ȼOKڋI_4cY:EdQӉ(=ǣR|9b*OUsSGerϫri w}?z\ReZRLXRm4+va2)$N%àgl` GBmfqݡ_Z"8vFWQ0t&bS[G1nVJp̓F(8^^ge=-miRWB *X ,FT+ l Py[UP 11| 8 #DqqqU\ ;RNS4Uwk"] TFXڸ@ hQ Ze!74Q~sԷ*t!Ue80ؠj2:}z`sXz ߆nh vqG}R[VkZ5?_u|{=pKh]OAeu@C!_F6Pb@]Tn[oŊs !Rii^nJl54n}^a. ڄݝCleN ϺxQG,4Ǟu6Ey%/i\X3lښ7i9Ϻt>K{4tMa3,.>HfVB /{?YF{!Ok} ~blV MS}d,NYvr?{̖msb5 &pnL=[=]Xی >G/#ė{@]w]^Bq8mzFN)A8uUԙeq/}.a*\; &#Y |'rp͓zׄFQtCcbP],(lb+Y.Bvtzg$u=$L(>b М 6eLv=lg(mݶ#G/΄.i~yZ/@_Ҷ<RO;,d0m+;kiD? DiC\E%!! 7MjOnhJ%UWP`HZqv2񴻹 O[0fvsQ9i~p_ 9I#U\z;Ӥj\[ni, QrwarG8`Ebۯ)ZoI_(-]00ZW8m\6.w\8 /,IE UMPepԟ믿~~#$P'2~"15c"$\zQe \(ͬte 6+EL nvyKJXB[ s!CkOpGL|S?Glυ1@|$үzMWDfY̰baQT>w] 6W@`ߟvia1q"&"$`:as[8Ƒ D^.h<`$ cJ ֚Lܮmd:(4֥Od>V3Eo4B;եۜb gi>뭷bԟ1_.*HsKWa뼦Qo45qXYIue)ql>Ca7.\pA76;F&'|2܋.dA|D"ȡj#T ?c# pa@Ymի[Пc3 /K!X}pe \5@>Z-`ՋNgp^*8 GC'tTmKѾAve;G(j`G-"9uL:T#;]1?'maʻbOSEX&blQ/KPyx?< erd!Tv'r{.T*z%~{lg_7) /LWrÔ.j̽SN&^Nk45U@dJjXg1h$~\2^:.=]ܪL_yx(eԐ 4˝bsOg~tgDjM7t؀r79BA"u'_uUiv3@'pBiA_:vQlӚDiu45AirjAZ=iQ}14D3!NDLvܗtnL%yEg&di0X!{Q˱x :)Y: {K֘'pdm1"˟Ͻޛ/})Sqf JoCr'D]51h55)ĔwDЏ5b>lH(*R2}+pK|Σ!UY2'<Ƞ-F*a(j?  =.J/)F*x4 ٽ8'.܌~kV'< jvz]kʼtk>0na*,71&?!S!F2ffPZ2RfIqd 5`h>ф/t4W\qx (}UQRЈ!U4b82Yy^_T@Rc^nc׌m]T>׾Vc5gCW~ N1 \Ux w*ы:t>-% A>R)c{͟#-*?v~R&y{^C8^$[.4agfϸɭ;ә6 T$ZdWS/" 㾢 M @H,??svjoؓBTa0-+J얭HaDQPņң"뮻N}'@x}OI\|]\4K|-Ӗժp!D13JI\q۷w/*OmFGF-\%LT: O?֥tWcobkwk1 bLFŀr} s!ˀr..1b"{`6 ne_ʰY* `ݪ5\uc]yKUʔC_H>}bj=6ྉ`>HJa{a|nS+N,qlza2='F7D'4Mt *"^̋'W+ BVbaEȬqdkǬ~oJB/b>nH> X/ {'.Gզˠ$]1Zgu8]ZQ=ep%BJqu`BcI- S1 %;o3аhE!l"2w3A)ԕ!C,&%ЈpU^4G;ܐWqүc" }}8ڑ@ _#Pg9sU؀¿,U(G"r 1O^QQR1JO?6;:Fa2'9$BP Z2/3C-7}|Ӧ?s`RJ_lm<7fM0H2nN(ėimV[6\3_s7>rSiYJBIV?TT6 K3J~=ִӋЊ{l}%0OT>LAESPpD*"Д'9 ^B>_r&dW!Qe&crd2؟, &VBh c!(ĄG~( =#s=2WT r'}vTD瞓BVf^'`*Aغwt&Xݴ/r4s4 [~ dg[`ȌIS1Ჴh"U\$$[2S @l~.צnZc2Qx~pl]m;?m?^4s4 / -̢JcQL>ϑ_2φ%֚z#')LA (r^{̻H3p._6aҮռrõUyjh$\%W3jyMy駏fK='#%\|yyJR\{ C5 h ͷ^xaS'2=>vҺL1tW mj ``E$La\OFXH%kg5-!m.+iާ+oNNIGVcNHїK+S IYEJtZr4LX&d*j.w6B}5vf4f =A(] -Y}7})% 4:,`c#XZmP|UDp"h. dk CQMDlh/槷oUeY)pJbUR*bP҈OvQ8W@ +zd=8e`~sNr'hSkh~!wQB~Q/w}o}[_p$^9v(˯]vldCLDlHf,8- sMw;b;1f2_pq '@H4˜O<5{GjbwN9lJӴ`F|mދ5J+'#av3Թ }(0K+oqKV=y򕯼UPqX5q"""pqrڨAbs ; tv;S ߱k8∴h)$qxTyR8rXTzw5&Kad[7L.*_S/,酲*zX+AeoXvʖ~[;q f3!} CF 6 6:s=&T>mY 92F UT*:ɘ8~_9paa|]?b58%8DGHVBAd}bډ&ӀR[*д|Q:E_W+;y^AXzRBaA(/ȑ(:%Q ʘ^p$ φZHr[_bڨD`r..]IױXbVGS ?asf7r^d qg/K]Q i"xޫ,h=v'eIҚ'H&~r AҺ;O!؍$4'BGȐ ڨtmw9}`9Gg.~Do|c h&9%5iv6}AT4LK-(H/)C)G(;Zt9ty4֊r L>_}c|m喣 zO D;@Gmo ufaXPJ=-Ƀq% Yc8-1HnlΤݍmp ؔ`*To:$}ZNyu S]6 5[tR([z[p_ha*)* ߪ5cK ܉V_}u:\l!N>0,73|yV[Sx 4%_VunZa΀}#.b9!8zj1SEI814L44#q& P#+~sb p2AHU>w2YQU^94|^y۱ +J<^ %SW iV#qBG_W^yDۤbj%gtAR]p_B!-<+îvђ]+c*@ޛ1jmp+K̬j`JaeC1';tIJ#\pF8b h{@y]§(mYQ4ؤPu%OPྴ!=D4ڪv435Z1rPEK-V11N ȗ󡎙^35 i&) Rb@٪We]6>:V 5ƝZ^ ZWWۋ UZ@ؐ hl)lD**Һ)3fmb5# 8|o|_a^~Ҿ&J/8r ,(`R+s@Jdw001W\qjD=暴؝6.% f0D.ϴr8\hH7SH|Жi'U.tyH2kh MTETpʦyY*`Tޟ#1fg#.KW'-U$Lj8\l<-=zF0) OK1i ,u Zh]خ+d|, xaOzgbң K~2ի4 NxI"3IpvXrџwՇܦVߝ^eTh%؀[2 b;i-Dp;o׫a?Qt]p&D*4W.+fW3_ Hog2Hst> &m>VbN^k3Ҋ+9d:1;ʖW2WÙ jȘazuUW-|%'^JzZָ,^k%zcz9ꨣ`y֖lOa_vͷG/࿒4*ްacC/7RXnn 㥷J_{?i&{_Jw3 `?xu/+Oh'.Bunz9kOß@odY@~zYv-VZ{yba-J}u6uq]_sȝww1>p=`:lq}CluGV!;|_?uu 7)9&7yݓ~#Glޚsr'p7}p_{Z #g~ccn<9:fɺS~ZLٖ诡|:Z.[0Vly.U΀R@`i|$Eμ_`=n8&(tSu #n6BC|i SgQys@x!Q'Zlj>[o2+/&UܗC!TF <"҉qC'Z1-wha=s bLD>] `!wohUXLg񄩅uD?DB /t?6G B ?/n;[ Ҏ& b >PI0  -~\1b!>-@R"@xBy6-#9'zLD"!1i h^"plPMC ^{5W\DK/pacL"nTZ㉰t磰YQ煍fBa`ԥtTE: xҿU|QAf AWHzE";16bQɐibƟ!&%iHep%ʻ`ؖ<\3to-r~ՑE' NwR9ؙ9`vX8.21IS&M5?'v/pXуK]Ġ?»cXo3{(W+}JIHwtiPxPO[!t)2htjq CS@#s>\2BtQH[&A48D$L$a >8mƶAٺfMA b 1jM.(I+ՈјFAv[*j!Iֶ#Ü9|_o~!Ι33s< #S X..$}Ɖ:eK[{B .`Z sq42IDATT tR`'ƝVrCqEӟT,]j(X@ؠ]`HGi7acz햫ƾ jMvba{/C(b~fŌ%0kf7cΡgLm\hDǗ s b[{`mdo<'GlRJ_Xw93K=q!,;[TcgB(ܭJޜӧρƠDr ǫM8Հ^'* EbK8xM>fc >ȱ$ـ;'nJk0x?|I8?'*!_~_j`b%"l Y̤gMjs&bP)Y((7,M':@t Θ!X7 hnY:G˼.)gЅ@0 dƦA{}ݢ m3KW]u-,^ dq]2ZQ꿕ˣ'?9G}?C Hւkǩ;+%OUtFyt9\:g:?,lX6G&Ʊ[ՕW^C!bZtGKe E>OjSiğ8Xj\ '{X?쓝Gc_HCJO)Y~ 9w@-n$wډ~v%/mT;t:kR`P`q4s5#:;9٠5&1Psڔq+ S78*kTl 1u&}lII5z5z:;qza&HQ3ؿxW-T r|"=dL%cS~_ge@C5ȕL^xER'2I\o(޽3S7hr)(t/a hN>O\wu=nd}7 7'|nJFs~jM&da&k.(ek0XgW})|5[ n-2Lq)pGwǢ5 6Yj gPv\ fb&GsW\}M7N`t]^}{_5WV 3ɧKh@S@['vh5LKf٠^J0#jJ^Ζ}z1!~'85$+G咜6a$hF:/7!$7;y_-\WVZL<㮐]jOؙ6XEWNmZv#֫2 %þECh%'Y}a@##Ox#X.xb|'B& p )|d|E-)S^]d,~i4NQUr\2}7_p)"q˯k)n}}=JJR`Ig UxdĆq nqUwqGRbk r R6 ^o1pT+!fmS)8S`1Gf d&XBʁ/t(IʰI4qf^7:6IETgFa;cʹ]V/U T FR%I"AN|8 _ѿOSQabʨ24WPu eSQQ4gsO3n+ԨJcx%0G~ ">b, Q HbqF<`'xi;$/Mg=^<ςdS]YMZS)"Ttce<]p1f3R93W t!xXK}5IV l@?q.AYl5y/C*>0;Qʉ(vߓv<'޿g/yS5ql|nY(W =);v1o9×\G.5"=)0o"~%ap谞hz6[cj}Ϟ=twg9RNŭDko97thr Lh)m0T /~'^rk^p6gë&Y}TR`-( ZLhLb&yQu8#+yQk+VNvau;κrH Ag,\% ܹԈ֗dbQD6 3Ĩ5: [++N6 VZ =)Dh\ʉWLP3Jf,=\JAD?+SV ,8>L%ѹ4/ o_$L!} S+A}I#>.3ڔ1+7wb_8R)ȓ:%kX2H\KGԍ ȟVfʼe<3HKQP3xq)IQ K]5v$RweßsHRg!`ڞ3iڱ%g%P.Ufgyf;"cH!mW:*ERBr)@c|s;mpШؖXpK!ɋ쭝O'%~5pZ9ǗvUocѺ,/jR`R@vF9Ǩ2V>}K?YIe2%g8=F0?X.@K5yhrϳy¹61uzhVV ?|'PܡRV},<˳8"ggm2jat8Tʧ/~% #/qm\.9SU~l]R4%-kJur98}$߬qu$||%ܨҠcTӟ4ERyY0~GHV/}<ofsY2H'g/gidrꒈ*^ИoBGVjͤRw3(t\) 0RشQ=+] q-OhK0?f8DE+_qnD&|GE#vzA]}~p QSNC3xE1icw޴;jқf*HPT{lè~ZS)b ŜT'c㠋?`Fo:8h%Dw BQ4[Ql>v6fzSĦ"s<1.Ww #e]Fz}q׃bhymsυꅼW <. x2M'Qe6ظ`!E7X}5822y.k¾;ubУqu^Eo OApٿ?\ hU2_0(wg<ZsiK\ɵoPD?ß 9\tP_YK6ή.&F /n)JYaD;GawBPyc ͱ Z6^Jʧ(ohoZ+ 8ho߾FMygr(Hǒy.N~nq㨟ڹ[s:e~;<0|_PsBpEڸR`e傠3gPG^ +C=+ς%kS)-}(:h믿wF,&|)3l!=_ v HlVcd lJǑ0kY1[LO)bso`n8>杣H  ״~_ .m{.B#KUjN-6SO=Ԭ1יN;Mh/־U -B|UtO$߆1eZ']d{E{!ϛB:FY> |GOLFþ̿gu6ГbȚCwUW1Z%Q@mE5yüo:D՚JuG3 d,>> z}.ǩv,B6:Cyo˘7HD\Ԑ}!:ڼ9'uŹ8*h^Sxo1@\s'#5aKڕBT)S̙p13Jp|xJڽ@䬃b}6 6V_r`0ξrhų76j艧Y T ,l lQߗ% ATm5SjT >mgPt%4p NiR+tmV));˂*jIy2PpK_z1 6`TWqTn[&;gB%r>Hj߈w^䜰v Pcb%wtž6jMr)?Վtzrdue'u_ fȭz㗥yd; Aw \osfRv8V;plf $oBF;;@dneBK͑iƣŁ 5W}*3AXp$\TCmנpY)" 9ZN/uhuQ>&fIv%YY0_OO@d2ȔQ5 8!Q ꅱ+MyJEQO?¬IF d]o!sGkPX_}*"9_iK>yž-ZCU ,gRpS.`UujUC?'x饗ҧ,u{(DRI;|Qc[Jrtl O̒M\7(. `[ϕlB%QI(v_{p{w̴֒ (h'q";v#1Z}ٳ'&^WG)Vص:x/,ؖ6,{ bQއ9裏޳Ly.ھR`;RsmGž3W L@4}l ۾2oɻTwH(E|5ycJ{Qf~GMks > UQ33Ku<}WWCt\VG!(ԅP6Ԍ%Ÿt~np>ی9m쫩M֢gv0HpO$3Mo'L> OCMC@2d0W?>:AuHj('u[|P˂$1B;d~[HhE+5+ YxX8[MRnVLމ|ܛMńEK2]l)WCt".ٌ'LNx[!.;_kiaA@)Jm uBBfX],M:*ey ]JۅpW:>NW2ZذU5盃KK^')JS I:I;LIж^mIlh*\6;?m kh:qXQIhANc39(Vw Qګqnuc%?-frГ7.+ CAY?p6%1jt`A=- Cp-0˯|+O8h>b_BZʠB7\ؿDbrO Ֆ_rnh716wz_uXxax1oP|RqiF@-,)]2w\6b>ϥ'm&W؋~絯}*FK"CL}'$VCXmA餓NFKlkgYC@I$- `+QPf )α3dL7Rn8s0\- (Dh)|>~_ZKbQw>5?FhL3e}x(3%q'8~}j*,I*ttҫҋq/6z[:EGiD5D4\Yy}n)/.&F:2QzjZIEvaA]%_=q6 K,6f'9b(Hr-SQQAgbNF]•}Ӟָuu>uC1s`!o3-s:Lٽ/0ӆ!űNeJ/9 W  '/W3U[E፱XP•M޼2u] ϠCO% ':J2<3+=NEh6ܷo_g}tg 7l'!lNqjj,fɄ-ư(Xce(}V(z=t`!"g>±8jy[}5]-:JkB10e V/}ט؟qZ}Eq4}3ϴ-NE|GQg7R3zPAAx`?PoQ:At qJϢQg>@H9V`XvR$j׫1H٠25)3+51PnLh?/SoRTqgi%Ӛrܟ=sмMcfѪ*CE_oQp &^jK.uvN:eꪫ\|IS>v%a#_GYO’PQ} :GiLka1wB|:`ov :d#TgqFw Ѥ^|7tSpܻw/5*?ѱ8s=8A\_˾q/8º>믿 : Gt|d|Xq%_Sɽi33H"3el9=}ZGis(fVdkC=iOrl:oF!-d9tZo Ѵ e^4݀}m[z`;bUE,;+ y26ڎ48PDiáJ}-Ʈhg_;j:Vz`\?5uSAz[D+<}a%y([LIOL1e&k!ѷi̇?Z=Xd6`n 63U:]bw'ܹ[+{k7N¥R+h1i&+UR3ߢBܸA|2mCҠޚP qoLrO+0wyW_L |^a}GA~1Q쓳y晇z(PtNkk7M?n4p>CtxWa3ߛ2b`w!^GipM(F0ycdS?3>FsI@(wn~nW-oyKv NmgJCk Y=yF[T 2ڽ{9眃#,3}ī Q:˴,v9 XT'X ˨3ȳ>CPN,m{Y%Ba}(fqbg'm.*%n~jOט5Lnt8: 3d#QviLߏ` ="0l]"qDB(YfZf 11̀݌ VyC<"s8L'TՃx5HBB v(13kQ"ևb&ףzz*u}NF}Hl>fZ;N᳥"c(smΧ)C# 8SXk SdO?\{ |ːӜXk"< l\G0t.Fs6˷W.鐪Xv a詘MiH!=RKt*vŃH1:=u@umfMRY˔I3ohN ]1O)sz}攴ey9(J0!%dɽ5~K&nGjgc-E yƻ]8v'FDZ}$EEi"s]TXqCjԦ37m+c?uc9F4{!Eʟ"^eeMP:h١;rHlXO<1Ze60L|@yIt><y/b[->K8΃$[J@(OM3 ݙlFŇQ֓b2|5Rb, Nm@D7(X{ㄬX`tE'0J qIGl'ʒ[Or O?;F[G_mU5LpsX9:c:bc!}`'a棼3t26WJd$iY 4+,IKFw"O2W&coؘg+,<&2!K=/.,_)X|V cH!B7L[35jr q9*;=oZΨM T Ѱuze9 ~bV^FVt,*C,1keF4 .j>;zy ,upy( ^i ǃI,=$dئx*NW}T륏U d;%&l]t&9=av2+(yb֒WEhA( ѭ=m숓7\*Pc_E4@VQHe3a> q1߅|/HAƲx = F'B:SN`_o=#Ӎv.7(4bs>fadl ~, D/ *4 Zr$OLCv1H(21|/*(MYo]@vbeX?ޞ~6Yd^z)R-Eur"o)O>Y3ЉXe\ L~?~ov_uo>g]J=`[hF34^ֲQ^Q׊(ߣO_ƶnkFo5?῍wB}Ϟ=H6yz=w]eb߾eO|O/~i&t=,-e5.o}[}/Ң*Aߋ.=_ß5Fyow ۣx1QePY)P)0o)}TXVv(AB(8؜h|/O{B z[Ww}ɞ&6%ƃ+]r/t"p=^E,۞եy K[bmeA:{yՄE!W%0 $Ʌ b_Y${l;$PլE/ LTJc!Z"⮻$2(i~Q:ɒJte5muV-Z \l[-\8A ]$EK~֣-|/_: LN h~^|/y/%7L-N*f٤# a,:;PdإZc/1w:G@IPF : Αsft(LmdQR⬌bV^Gw*cJCx/zig~/pV~9Zc_|x.H|_cM@w@Y[®Ŭ1uX5 MkҲ/P 2/WQ49uhepˏU~r';ﵿj0'&0-os`Z3q 9r˾}΂u3$& XevK- AO_ZXobBzk:J  jFJ3[8# R䅹D&vkowT3IuY(%%C8 Qu>M}=zuFYGiSoP hS`T wh\pȨ>;翗[b|XA38?S8qa,K~WyRھL^H'6߸ol;P3.d k-y_h YT= ̹>{كFtNYm 9cM46o!/ҼENMԦLnF$vB.|@W⹞+4|:(AVuI[bpd![8Md5^"? &=o>z<.UW|_ʴ @iǻ0.nYG# 2#D ȕ ū,Udʴsc?6]v1}-:Ӆ8)!9}JCQ%~2mv6ue3--:|GdGnCʓ{+DTRWsdnwI80w;fXo@Q"Ba[QڐYA?A ^|}s  <|yu~#zqN>d0>d %h6K¶=oFN|FC/_E*?^H^[:@]3t\fل\2v;/;E':J$vGh_1amfx_6}5\_k}T~8!8Pw;[B>AtpK+_D;2TV1:XxC?Uen2u(E|״UfžǞY-a{R\2:W$+1nۯzի #umK1 D?LU2mX<ʥ%AR/I[*XIǂg4 rގrZK@Hr݃o>L>LeR2Nzk!G7!-<4"d1X}/BmU"VeԐ[1ԧ1TI o`ɩiE+M+^AhÔ9 }g\TE.((P)ѕWULo,?I-CLBh{ J@%mwo|/,0T kB|h]OD'WQXx@D ]ˏh"XnV)?0TC<>̝8\%e(lV<Ψb$In)=}/4{a[Ë^ؗ#7/AV'uV=E::Jw]26_I|!,0v\7geعs[vDo2lifecyclelifecycledeprecateddeprecated vctrs/man/partial_frame.Rd0000644000176200001440000000111613473164157015275 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/partial-frame.R \name{partial_frame} \alias{partial_frame} \title{Partially specify columns of a data frame} \usage{ partial_frame(...) } \arguments{ \item{...}{Attributes of subclass} } \description{ This special class can be passed to \code{.ptype} in order to specify the types of only some of the columns in a data frame. } \examples{ pf <- partial_frame(x = double()) pf vec_rbind( data.frame(x = 1L, y = "a"), data.frame(x = FALSE, z = 10), .ptype = partial_frame(x = double(), a = character()) ) } vctrs/man/vec_as_names.Rd0000644000176200001440000001337613622451540015114 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/names.R \name{vec_as_names} \alias{vec_as_names} \title{Retrieve and repair names} \usage{ vec_as_names( names, ..., repair = c("minimal", "unique", "universal", "check_unique"), quiet = FALSE ) } \arguments{ \item{names}{A character vector.} \item{...}{These dots are for future extensions and must be empty.} \item{repair}{Either a string or a function. If a string, it must be one of \code{"check_unique"}, \code{"minimal"}, \code{"unique"}, or \code{"universal"}. If a function, it is invoked with a vector of minimal names and must return minimal names, otherwise an error is thrown. \itemize{ \item Minimal names are never \code{NULL} or \code{NA}. When an element doesn't have a name, its minimal name is an empty string. \item Unique names are unique. A suffix is appended to duplicate names to make them unique. \item Universal names are unique and syntactic, meaning that you can safely use the names as variables without causing a syntax error. } The \code{"check_unique"} option doesn't perform any name repair. Instead, an error is raised if the names don't suit the \code{"unique"} criteria.} \item{quiet}{By default, the user is informed of any renaming caused by repairing the names. This only concerns unique and universal repairing. Set \code{quiet} to \code{TRUE} to silence the messages.} } \description{ \code{vec_as_names()} takes a character vector of names and repairs it according to the \code{repair} argument. It is the r-lib and tidyverse equivalent of \code{\link[base:make.names]{base::make.names()}}. vctrs deals with a few levels of name repair: \itemize{ \item \code{minimal} names exist. The \code{names} attribute is not \code{NULL}. The name of an unnamed element is \code{""} and never \code{NA}. For instance, \code{vec_as_names()} always returns minimal names and data frames created by the tibble package have names that are, at least, \code{minimal}. \item \code{unique} names are \code{minimal}, have no duplicates, and can be used where a variable name is expected. Empty names, \code{...}, and \code{..} followed by a sequence of digits are banned. \itemize{ \item All columns can be accessed by name via \code{df[["name"]]} and \code{df$`name` } and \code{with(df, `name`)}. } \item \code{universal} names are \code{unique} and syntactic (see Details for more). \itemize{ \item Names work everywhere, without quoting: \code{df$name} and \code{with(df, name)} and \code{lm(name1 ~ name2, data = df)} and \code{dplyr::select(df, name)} all work. } } \code{universal} implies \code{unique}, \code{unique} implies \code{minimal}. These levels are nested. } \section{\code{minimal} names}{ \code{minimal} names exist. The \code{names} attribute is not \code{NULL}. The name of an unnamed element is \code{""} and never \code{NA}. Examples:\preformatted{Original names of a vector with length 3: NULL minimal names: "" "" "" Original names: "x" NA minimal names: "x" "" } } \section{\code{unique} names}{ \code{unique} names are \code{minimal}, have no duplicates, and can be used (possibly with backticks) in contexts where a variable is expected. Empty names, \code{...}, and \code{..} followed by a sequence of digits are banned. If a data frame has \code{unique} names, you can index it by name, and also access the columns by name. In particular, \code{df[["name"]]} and \code{df$`name`} and also \code{with(df, `name`)} always work. There are many ways to make names \code{unique}. We append a suffix of the form \code{...j} to any name that is \code{""} or a duplicate, where \code{j} is the position. We also change \code{..#} and \code{...} to \code{...#}. Example:\preformatted{Original names: "" "x" "" "y" "x" "..2" "..." unique names: "...1" "x...2" "...3" "y" "x...5" "...6" "...7" } Pre-existing suffixes of the form \code{...j} are always stripped, prior to making names \code{unique}, i.e. reconstructing the suffixes. If this interacts poorly with your names, you should take control of name repair. } \section{\code{universal} names}{ \code{universal} names are \code{unique} and syntactic, meaning they: \itemize{ \item Are never empty (inherited from \code{unique}). \item Have no duplicates (inherited from \code{unique}). \item Are not \code{...}. Do not have the form \code{..i}, where \code{i} is a number (inherited from \code{unique}). \item Consist of letters, numbers, and the dot \code{.} or underscore \verb{_} characters. \item Start with a letter or start with the dot \code{.} not followed by a number. \item Are not a \link{reserved} word, e.g., \code{if} or \code{function} or \code{TRUE}. } If a vector has \code{universal} names, variable names can be used "as is" in code. They work well with nonstandard evaluation, e.g., \code{df$name} works. vctrs has a different method of making names syntactic than \code{\link[base:make.names]{base::make.names()}}. In general, vctrs prepends one or more dots \code{.} until the name is syntactic. Examples:\preformatted{ Original names: "" "x" NA "x" universal names: "...1" "x...2" "...3" "x...4" Original names: "(y)" "_z" ".2fa" "FALSE" universal names: ".y." "._z" "..2fa" ".FALSE" } } \examples{ # By default, `vec_as_names()` returns minimal names: vec_as_names(c(NA, NA, "foo")) # You can make them unique: vec_as_names(c(NA, NA, "foo"), repair = "unique") # Universal repairing fixes any non-syntactic name: vec_as_names(c("_foo", "+"), repair = "universal") } \seealso{ \code{\link[rlang:names2]{rlang::names2()}} returns the names of an object, after making them \code{minimal}. The \href{https://principles.tidyverse.org/names-attribute.html}{Names attribute} section in the "tidyverse package development principles". } vctrs/man/vec_count.Rd0000644000176200001440000000275413475700023014453 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dictionary.R \name{vec_count} \alias{vec_count} \title{Count unique values in a vector} \usage{ vec_count(x, sort = c("count", "key", "location", "none")) } \arguments{ \item{x}{A vector (including a data frame).} \item{sort}{One of "count", "key", "location", or "none". \itemize{ \item "count", the default, puts most frequent values at top \item "key", orders by the output key column (i.e. unique values of \code{x}) \item "location", orders by location where key first seen. This is useful if you want to match the counts up to other unique/duplicated functions. \item "none", leaves unordered. }} } \value{ A data frame with columns \code{key} (same type as \code{x}) and \code{count} (an integer vector). } \description{ Count the number of unique values in a vector. \code{vec_count()} has two important differences to \code{table()}: it returns a data frame, and when given multiple inputs (as a data frame), it only counts combinations that appear in the input. } \examples{ vec_count(mtcars$vs) vec_count(iris$Species) # If you count a data frame you'll get a data frame # column in the output str(vec_count(mtcars[c("vs", "am")])) # Sorting --------------------------------------- x <- letters[rpois(100, 6)] # default is to sort by frequency vec_count(x) # by can sort by key vec_count(x, sort = "key") # or location of first value vec_count(x, sort = "location") head(x) # or not at all vec_count(x, sort = "none") } vctrs/man/vec_bind.Rd0000644000176200001440000001253513622451540014236 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bind.R \name{vec_bind} \alias{vec_bind} \alias{vec_rbind} \alias{vec_cbind} \title{Combine many data frames into one data frame} \usage{ vec_rbind( ..., .ptype = NULL, .names_to = NULL, .name_repair = c("unique", "universal", "check_unique") ) vec_cbind( ..., .ptype = NULL, .size = NULL, .name_repair = c("unique", "universal", "check_unique", "minimal") ) } \arguments{ \item{...}{Data frames or vectors. When the inputs are named: \itemize{ \item \code{vec_rbind()} assigns names to row names unless \code{.names_to} is supplied. In that case the names are assigned in the column defined by \code{.names_to}. \item \code{vec_cbind()} creates packed data frame columns with named inputs. } \code{NULL} inputs are silently ignored. Empty (e.g. zero row) inputs will not appear in the output, but will affect the derived \code{.ptype}.} \item{.ptype}{If \code{NULL}, the default, the output type is determined by computing the common type across all elements of \code{...}. Alternatively, you can supply \code{.ptype} to give the output known type. If \code{getOption("vctrs.no_guessing")} is \code{TRUE} you must supply this value: this is a convenient way to make production code demand fixed types.} \item{.names_to}{Optionally, the name of a column where the names of \code{...} arguments are copied. These names are useful to identify which row comes from which input. If supplied and \code{...} is not named, an integer column is used to identify the rows.} \item{.name_repair}{One of \code{"unique"}, \code{"universal"}, or \code{"check_unique"}. See \code{\link[=vec_as_names]{vec_as_names()}} for the meaning of these options. With \code{vec_rbind()}, the repair function is applied to all inputs separately. This is because \code{vec_rbind()} needs to align their columns before binding the rows, and thus needs all inputs to have unique names. On the other hand, \code{vec_cbind()} applies the repair function after all inputs have been concatenated together in a final data frame. Hence \code{vec_cbind()} allows the more permissive minimal names repair.} \item{.size}{If, \code{NULL}, the default, will determine the number of rows in \code{vec_cbind()} output by using the standard recycling rules. Alternatively, specify the desired number of rows, and any inputs of length 1 will be recycled appropriately.} } \value{ A data frame, or subclass of data frame. If \code{...} is a mix of different data frame subclasses, \code{vec_ptype2()} will be used to determine the output type. For \code{vec_rbind()}, this will determine the type of the container and the type of each column; for \code{vec_cbind()} it only determines the type of the output container. If there are no non-\code{NULL} inputs, the result will be \code{data.frame()}. } \description{ This pair of functions binds together data frames (and vectors), either row-wise or column-wise. Row-binding creates a data frame with common type across all arguments. Column-binding creates a data frame with common length across all arguments. } \section{Invariants}{ All inputs are first converted to a data frame. The conversion for 1d vectors depends on the direction of binding: \itemize{ \item For \code{vec_rbind()}, each element of the vector becomes a column in a single row. \item For \code{vec_cbind()}, each element of the vector becomes a row in a single column. } Once the inputs have all become data frames, the following invariants are observed for row-binding: \itemize{ \item \code{vec_size(vec_rbind(x, y)) == vec_size(x) + vec_size(y)} \item \code{vec_ptype(vec_rbind(x, y)) = vec_ptype_common(x, y)} } Note that if an input is an empty vector, it is first converted to a 1-row data frame with 0 columns. Despite being empty, its effective size for the total number of rows is 1. For column-binding, the following invariants apply: \itemize{ \item \code{vec_size(vec_cbind(x, y)) == vec_size_common(x, y)} \item \code{vec_ptype(vec_cbind(x, y)) == vec_cbind(vec_ptype(x), vec_ptype(x))} } } \examples{ # row binding ----------------------------------------- # common columns are coerced to common class vec_rbind( data.frame(x = 1), data.frame(x = FALSE) ) # unique columns are filled with NAs vec_rbind( data.frame(x = 1), data.frame(y = "x") ) # null inputs are ignored vec_rbind( data.frame(x = 1), NULL, data.frame(x = 2) ) # bare vectors are treated as rows vec_rbind( c(x = 1, y = 2), c(x = 3) ) # default names will be supplied if arguments are not named vec_rbind( 1:2, 1:3, 1:4 ) # column binding -------------------------------------- # each input is recycled to have common length vec_cbind( data.frame(x = 1), data.frame(y = 1:3) ) # bare vectors are treated as columns vec_cbind( data.frame(x = 1), y = letters[1:3] ) # if you supply a named data frame, it is packed in a single column data <- vec_cbind( x = data.frame(a = 1, b = 2), y = 1 ) data # Packed data frames are nested in a single column. This makes it # possible to access it through a single name: data$x # since the base print method is suboptimal with packed data # frames, it is recommended to use tibble to work with these: if (rlang::is_installed("tibble")) { vec_cbind(x = tibble::tibble(a = 1, b = 2), y = 1) } # duplicate names are flagged vec_cbind(x = 1, x = 2) } \seealso{ \code{\link[=vec_c]{vec_c()}} for combining 1d vectors. } vctrs/man/vec_size.Rd0000644000176200001440000000610113622451540014264 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/size.R \name{vec_size} \alias{vec_size} \alias{vec_size_common} \alias{vec_is_empty} \title{Number of observations} \usage{ vec_size(x) vec_size_common(..., .size = NULL, .absent = 0L) vec_is_empty(x) } \arguments{ \item{x, ...}{Vector inputs or \code{NULL}.} \item{.size}{If \code{NULL}, the default, the output size is determined by recycling the lengths of all elements of \code{...}. Alternatively, you can supply \code{.size} to force a known size; in this case, \code{x} and \code{...} are ignored.} \item{.absent}{The size used when no input is provided, or when all input is \code{NULL}. If left as \code{NULL} when no input is supplied, an error is thrown.} } \value{ An integer (or double for long vectors). \code{vec_size_common()} returns \code{.absent} if all inputs are \code{NULL} or absent, \code{0L} by default. } \description{ \code{vec_size(x)} returns the size of a vector. \code{vec_is_empty()} returns \code{TRUE} if the size is zero, \code{FALSE} otherwise. The size is distinct from the \code{\link[=length]{length()}} of a vector because it generalises to the "number of observations" for 2d structures, i.e. it's the number of rows in matrix or a data frame. This definition has the important property that every column of a data frame (even data frame and matrix columns) have the same size. \code{vec_size_common(...)} returns the common size of multiple vectors. } \details{ There is no vctrs helper that retrieves the number of columns: as this is a property of the \link[=vec_ptype_show]{type}. \code{vec_size()} is equivalent to \code{NROW()} but has a name that is easier to pronounce, and throws an error when passed non-vector inputs. } \section{Invariants}{ \itemize{ \item \code{vec_size(dataframe)} == \code{vec_size(dataframe[[i]])} \item \code{vec_size(matrix)} == \code{vec_size(matrix[, i, drop = FALSE])} \item \code{vec_size(vec_c(x, y))} == \code{vec_size(x)} + \code{vec_size(y)} } } \section{The size of NULL}{ The size of \code{NULL} is hard-coded to \code{0L} in \code{vec_size()}. \code{vec_size_common()} returns \code{.absent} when all inputs are \code{NULL} (if only some inputs are \code{NULL}, they are simply ignored). A default size of 0 makes sense because sizes are most often queried in order to compute a total size while assembling a collection of vectors. Since we treat \code{NULL} as an absent input by principle, we return the identity of sizes under addition to reflect that an absent input doesn't take up any size. Note that other defaults might make sense under different circumstances. For instance, a default size of 1 makes sense for finding the common size because 1 is the identity of the recycling rules. } \examples{ vec_size(1:100) vec_size(mtcars) vec_size(array(dim = c(3, 5, 10))) vec_size_common(1:10, 1:10) vec_size_common(1:10, 1) vec_size_common(integer(), 1) } \seealso{ \code{\link[=vec_slice]{vec_slice()}} for a variation of \code{[} compatible with \code{vec_size()}, and \code{\link[=vec_recycle]{vec_recycle()}} to recycle vectors to common length. } vctrs/man/vec_assert.Rd0000644000176200001440000000271713622451540014624 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/assert.R \name{vec_assert} \alias{vec_assert} \alias{vec_is} \title{Assert an argument has known prototype and/or size} \usage{ vec_assert(x, ptype = NULL, size = NULL, arg = as_label(substitute(x))) vec_is(x, ptype = NULL, size = NULL) } \arguments{ \item{x}{A vector argument to check.} \item{ptype}{Prototype to compare against. If the prototype has a class, its \code{\link[=vec_ptype]{vec_ptype()}} is compared to that of \code{x} with \code{identical()}. Otherwise, its \code{\link[=typeof]{typeof()}} is compared to that of \code{x} with \code{==}.} \item{size}{Size to compare against} \item{arg}{Name of argument being checked. This is used in error messages. The label of the expression passed as \code{x} is taken as default.} } \value{ \code{vec_is()} returns \code{TRUE} or \code{FALSE}. \code{vec_assert()} either throws a typed error (see section on error types) or returns \code{x}, invisibly. } \description{ \itemize{ \item \code{vec_is()} is a predicate that checks if its input conforms to a prototype and/or a size. \item \code{vec_assert()} throws an error when the input doesn't conform. } } \section{Error types}{ \itemize{ \item If the prototype doesn't match, an error of class \code{"vctrs_error_assert_ptype"} is raised. \item If the size doesn't match, an error of class \code{"vctrs_error_assert_size"} is raised. } Both errors inherit from \code{"vctrs_error_assert"}. } vctrs/man/vec_as_index.Rd0000644000176200001440000000212713622451540015110 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/vctrs-deprecated.R \name{vec_as_index} \alias{vec_as_index} \title{Convert to an index vector} \usage{ vec_as_index(i, n, names = NULL) } \arguments{ \item{i}{An integer, character or logical vector specifying the locations or names of the observations to get/set. Specify \code{TRUE} to index all elements (as in \code{x[]}), or \code{NULL}, \code{FALSE} or \code{integer()} to index none (as in \code{x[NULL]}).} \item{n}{A single integer representing the total size of the object that \code{i} is meant to index into.} \item{names}{If \code{i} is a character vector, \code{names} should be a character vector that \code{i} will be matched against to construct the index. Otherwise, not used. The default value of \code{NULL} will result in an error if \code{i} is a character vector.} } \description{ \Sexpr[results=rd, stage=render]{vctrs:::lifecycle("soft-deprecated")} \code{vec_as_index()} has been renamed to \code{\link[=vec_as_location]{vec_as_location()}} and is soft-deprecated as of vctrs 0.2.2. } \keyword{internal} vctrs/man/vec_match.Rd0000644000176200001440000000310713622451540014411 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dictionary.R \name{vec_match} \alias{vec_match} \alias{vec_in} \title{Find matching observations across vectors} \usage{ vec_match(needles, haystack) vec_in(needles, haystack) } \arguments{ \item{needles, haystack}{Vector of \code{needles} to search for in vector haystack. \code{haystack} should usually be unique; if not \code{vec_match()} will only return the location of the first match. \code{needles} and \code{haystack} are coerced to the same type prior to comparison.} } \value{ A vector the same length as \code{needles}. \code{vec_in()} returns a logical vector; \code{vec_match()} returns an integer vector. } \description{ \code{vec_in()} returns a logical vector based on whether \code{needle} is found in haystack. \code{vec_match()} returns an integer vector giving location of \code{needle} in \code{haystack}, or \code{NA} if it's not found. } \details{ \code{vec_in()} is equivalent to \link{\%in\%}; \code{vec_match()} is equivalent to \code{match()}. } \section{Missing values}{ In most cases, missing values are not considered to be equal, i.e. \code{NA == NA} is not \code{TRUE}. This behaviour would be unappealing here, so these functions consider all \code{NAs} to be equal. (Similarly, all \code{NaN} are also considered to be equal.) } \examples{ hadley <- strsplit("hadley", "")[[1]] vec_match(hadley, letters) vowels <- c("a", "e", "i", "o", "u") vec_match(hadley, vowels) vec_in(hadley, vowels) # Only the first index of duplicates is returned vec_match(c("a", "b"), c("a", "b", "a", "b")) } vctrs/man/vec_slice.Rd0000644000176200001440000000540113622451540014413 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/slice.R \name{vec_slice} \alias{vec_slice} \alias{vec_slice<-} \alias{vec_assign} \title{Get or set observations in a vector} \usage{ vec_slice(x, i) vec_slice(x, i) <- value vec_assign(x, i, value) } \arguments{ \item{x}{A vector} \item{i}{An integer, character or logical vector specifying the locations or names of the observations to get/set. Specify \code{TRUE} to index all elements (as in \code{x[]}), or \code{NULL}, \code{FALSE} or \code{integer()} to index none (as in \code{x[NULL]}).} \item{value}{Replacement values. \code{value} is cast to the type of \code{x}, but only if they have a common type. See below for examples of this rule.} } \value{ A vector of the same type as \code{x}. } \description{ This provides a common interface to extracting and modifying observations for all vector types, regardless of dimensionality. It is an analog to \code{[} that matches \code{\link[=vec_size]{vec_size()}} instead of \code{length()}. } \section{Genericity}{ Support for S3 objects depends on whether the object implements a \code{\link[=vec_proxy]{vec_proxy()}} method. \itemize{ \item When a \code{vec_proxy()} method exists, the proxy is sliced and \code{vec_restore()} is called on the result. \item Otherwise \code{vec_slice()} falls back to the base generic \code{[}. } Note that S3 lists are treated as scalars by default, and will cause an error if they don't implement a \code{\link[=vec_proxy]{vec_proxy()}} method. } \section{Differences with base R subsetting}{ \itemize{ \item \code{vec_slice()} only slices along one dimension. For two-dimensional types, the first dimension is subsetted. \item \code{vec_slice()} preserves attributes by default. \item \verb{vec_slice<-()} is type-stable and always returns the same type as the LHS. } } \examples{ x <- sample(10) x vec_slice(x, 1:3) # You can assign with the infix variant: vec_slice(x, 2) <- 100 x # Or with the regular variant that doesn't modify the original input: y <- vec_assign(x, 3, 500) y x # Slicing objects of higher dimension: vec_slice(mtcars, 1:3) # Type stability -------------------------------------------------- # The assign variant is type stable. It always returns the same # type as the input. x <- 1:5 vec_slice(x, 2) <- 20.0 # `x` is still an integer vector because the RHS was cast to the # type of the LHS: vec_ptype(x) # Compare to `[<-`: x[2] <- 20.0 vec_ptype(x) # Note that the types must be coercible for the cast to happen. # For instance, you can cast a character vector to an integer: vec_cast("1", integer()) # But these types are not coercible: try(vec_ptype2("1", integer())) # Hence you cannot assign character values to an integer or double # vector: try(vec_slice(x, 2) <- "20") } \keyword{internal} vctrs/man/s3_register.Rd0000644000176200001440000000436413622451540014717 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/register-s3.R \name{s3_register} \alias{s3_register} \title{Register a method for a suggested dependency} \usage{ s3_register(generic, class, method = NULL) } \arguments{ \item{generic}{Name of the generic in the form \code{pkg::generic}.} \item{class}{Name of the class} \item{method}{Optionally, the implementation of the method. By default, this will be found by looking for a function called \code{generic.class} in the package environment. Note that providing \code{method} can be dangerous if you use devtools. When the namespace of the method is reloaded by \code{devtools::load_all()}, the function will keep inheriting from the old namespace. This might cause crashes because of dangling \code{.Call()} pointers.} } \description{ Generally, the recommend way to register an S3 method is to use the \code{S3Method()} namespace directive (often generated automatically by the \verb{@export} roxygen2 tag). However, this technique requires that the generic be in an imported package, and sometimes you want to suggest a package, and only provide a method when that package is loaded. \code{s3_register()} can be called from your package's \code{.onLoad()} to dynamically register a method only if the generic's package is loaded. (To avoid taking a dependency on vctrs for this one function, please feel free to copy and paste the function source into your own package.) } \details{ For R 3.5.0 and later, \code{s3_register()} is also useful when demonstrating class creation in a vignette, since method lookup no longer always involves the lexical scope. For R 3.6.0 and later, you can achieve a similar effect by using "delayed method registration", i.e. placing the following in your \code{NAMESPACE} file:\preformatted{if (getRversion() >= "3.6.0") \{ S3method(package::generic, class) \} } } \examples{ # A typical use case is to dynamically register tibble/pillar methods # for your class. That way you avoid creating a hard dependency on packages # that are not essential, while still providing finer control over # printing when they are used. .onLoad <- function(...) { s3_register("pillar::pillar_shaft", "vctrs_vctr") s3_register("tibble::type_sum", "vctrs_vctr") } } \keyword{internal} vctrs/man/partial_factor.Rd0000644000176200001440000000167713622451540015464 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/partial-factor.R \name{partial_factor} \alias{partial_factor} \title{Partially specify a factor} \usage{ partial_factor(levels = character()) } \arguments{ \item{levels}{Character vector of labels.} } \description{ This special class can be passed as a \code{ptype} in order to specify that the result should be a factor that contains at least the specified levels. } \examples{ # Assert that `x` is a factor vec_assert(factor("x"), partial_factor()) # Testing with `factor()` is too strict, # because it tries to match the levels exactly # rather than learning them from the data. try(vec_assert(factor("x"), factor())) # You can also enforce a minimum set of levels try(vec_assert(factor("x"), partial_factor("y"))) vec_assert(factor(c("x", "y")), partial_factor("y")) pf <- partial_factor(levels = c("x", "y")) pf vec_ptype_common(factor("v"), factor("w"), .ptype = pf) } vctrs/man/new_vctr.Rd0000644000176200001440000000606113622451540014311 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/type-vctr.R \name{new_vctr} \alias{new_vctr} \alias{vctr} \title{vctr (vector) S3 class} \usage{ new_vctr(.data, ..., class = character(), inherit_base_type = FALSE) } \arguments{ \item{.data}{Foundation of class. Must be a vector} \item{...}{Name-value pairs defining attributes} \item{class}{Name of subclass.} \item{inherit_base_type}{\Sexpr[results=rd, stage=render]{vctrs:::lifecycle("experimental")} Does this class extend the base type of \code{.data}? i.e. does the resulting object extend the behaviour the underlying type?} } \description{ This abstract class provides a set of useful default methods that makes it considerably easier to get started with a new S3 vector class. See \code{vignette("s3-vector")} to learn how to use it to create your own S3 vector classes. } \section{Base methods}{ The vctr class provides methods for many base generics using a smaller set of generics defined by this package. Generally, you should think carefully before overriding any of the methods that vctrs implements for you as they've been carefully planned to be internally consistent. \itemize{ \item \code{[[} and \code{[} use \code{NextMethod()} dispatch to the underlying base function, then restore attributes with \code{vec_restore()}. \code{rep()} and \verb{length<-} work similarly. \item \verb{[[<-} and \verb{[<-} cast \code{value} to same type as \code{x}, then call \code{NextMethod()}. \item \code{as.logical()}, \code{as.integer()}, \code{as.numeric()}, \code{as.character()}, \code{as.Date()} and \code{as.POSIXct()} methods call \code{vec_cast()}. The \code{as.list()} method calls \code{[[} repeatedly, and the \code{as.data.frame()} method uses a standard technique to wrap a vector in a data frame. \item \code{as.factor()}, \code{as.ordered()} and \code{as.difftime()} are not generic functions in base R, but have been reimplemented as generics in the \code{generics} package. \code{vctrs} extends these and calls \code{vec_cast()}. To inherit this behaviour in a package, import and re-export the generic of interest from \code{generics}. \item \code{==}, \code{!=}, \code{unique()}, \code{anyDuplicated()}, and \code{is.na()} use \code{\link[=vec_proxy]{vec_proxy()}}. \item \code{<}, \code{<=}, \code{>=}, \code{>}, \code{min()}, \code{max()}, \code{range()}, \code{median()}, \code{quantile()}, and \code{xtfrm()} methods use \code{\link[=vec_proxy_compare]{vec_proxy_compare()}}. \item \code{+}, \code{-}, \code{/}, \code{*}, \code{^}, \code{\%\%}, \code{\%/\%}, \code{!}, \code{&}, and \code{|} operators use \code{\link[=vec_arith]{vec_arith()}}. \item Mathematical operations including the Summary group generics (\code{prod()}, \code{sum()}, \code{any()}, \code{all()}), the Math group generics (\code{abs()}, \code{sign()}, etc), \code{mean()}, \code{is.nan()}, \code{is.finite()}, and \code{is.infinite()} use \code{\link[=vec_math]{vec_math()}}. \item \code{dims()}, \verb{dims<-}, \code{dimnames()}, \verb{dimnames<-}, \code{levels()}, and \verb{levels<-} methods throw errors. } } \keyword{internal} vctrs/man/vec_as_location.Rd0000644000176200001440000000712713622451540015616 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/subscript-loc.R \name{vec_as_location} \alias{vec_as_location} \alias{num_as_location} \alias{vec_as_location2} \alias{num_as_location2} \title{Create a vector of locations} \usage{ vec_as_location( i, n, names = NULL, ..., missing = c("propagate", "error"), arg = NULL ) num_as_location( i, n, ..., missing = c("propagate", "error"), negative = c("invert", "error", "ignore"), oob = c("error", "extend"), arg = NULL ) vec_as_location2( i, n, names = NULL, ..., missing = c("error", "propagate"), arg = NULL ) num_as_location2( i, n, ..., negative = c("error", "ignore"), missing = c("error", "propagate"), arg = NULL ) } \arguments{ \item{i}{An integer, character or logical vector specifying the locations or names of the observations to get/set. Specify \code{TRUE} to index all elements (as in \code{x[]}), or \code{NULL}, \code{FALSE} or \code{integer()} to index none (as in \code{x[NULL]}).} \item{n}{A single integer representing the total size of the object that \code{i} is meant to index into.} \item{names}{If \code{i} is a character vector, \code{names} should be a character vector that \code{i} will be matched against to construct the index. Otherwise, not used. The default value of \code{NULL} will result in an error if \code{i} is a character vector.} \item{missing}{Whether to throw an \code{"error"} when \code{i} is a missing value, or \code{"propagate"} it (return it as is). By default, vector subscripts can contain missing values and scalar subscripts can't.} \item{arg}{The argument name to be displayed in error messages when \code{vec_as_location()} and \code{vec_as_location2()} are used to check the type of a function input.} \item{negative}{Whether to throw an \code{"error"} when \code{i} is a negative location value, or \code{"ignore"} it.} \item{oob}{If \code{"error"}, throws an informative \code{"error"} if some elements are out-of-bounds. If \code{"extend"}, out-of-bounds locations are allowed if they are consecutive after the end. This can be used to implement extendable vectors like \code{letters[1:30]}.} } \value{ \code{vec_as_location()} returns an integer vector that can be used as an index in a subsetting operation. \code{vec_as_location2()} returns an integer of size 1 that can be used a scalar index for extracting an element. } \description{ These helpers provide a means of standardizing common indexing methods such as integer, character or logical indexing. \itemize{ \item \code{vec_as_location()} accepts integer, character, or logical vectors of any size. The output is always an integer vector that is suitable for subsetting with \code{[} or \code{\link[=vec_slice]{vec_slice()}}. It might be a different size than the input because negative selections are transformed to positive ones and logical vectors are transformed to a vector of indices for the \code{TRUE} locations. \item \code{vec_as_location2()} accepts a single number or string. It returns a single location as a integer vector of size 1. This is suitable for extracting with \code{[[}. } } \examples{ x <- array(1:6, c(2, 3)) dimnames(x) <- list(c("r1", "r2"), c("c1", "c2", "c3")) # The most common use case validates row indices vec_as_location(1, vec_size(x)) # Negative indices can be used to index from the back vec_as_location(-1, vec_size(x)) # Character vectors can be used if `names` are provided vec_as_location("r2", vec_size(x), rownames(x)) # You can also construct an index for dimensions other than the first vec_as_location(c("c2", "c1"), ncol(x), colnames(x)) } \keyword{internal} vctrs/man/vec_recycle.Rd0000644000176200001440000000403013622451540014737 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/recycle.R \name{vec_recycle} \alias{vec_recycle} \alias{vec_recycle_common} \title{Vector recycling} \usage{ vec_recycle(x, size, ..., x_arg = "x") vec_recycle_common(..., .size = NULL) } \arguments{ \item{x}{A vector to recycle.} \item{size}{Desired output size.} \item{...}{\itemize{ \item For \code{vec_recycle_common()}, vectors to recycle. \itemize{ \item For \code{vec_recycle()}, these dots should be empty. } }} \item{x_arg}{Argument name for \code{x}. These are used in error messages to inform the user about which argument has an incompatible size.} \item{.size}{Desired output size. If omitted, will use the common size from \code{\link[=vec_size_common]{vec_size_common()}}.} } \description{ \code{vec_recycle(x, size)} recycles a single vector to given size. \code{vec_recycle_common(...)} recycles multiple vectors to their common size. All functions obey the vctrs recycling rules, described below, and will throw an error if recycling is not possible. See \code{\link[=vec_size]{vec_size()}} for the precise definition of size. } \section{Recycling rules}{ The common size of two vectors defines the recycling rules, and can be summarise with the following table: \figure{sizes-recycling.png} (Note \code{NULL}s are handled specially; they are treated like empty arguments and hence don't affect the size) This is a stricter set of rules than base R, which will usually return output of length \code{max(nx, ny)}, warning if the length of the longer vector is not an integer multiple of the length of the shorter. We say that two vectors have \strong{compatible size} if they can be recycled to be the same length. } \examples{ # Inputs with 1 observation are recycled vec_recycle_common(1:5, 5) vec_recycle_common(integer(), 5) \dontrun{ vec_recycle_common(1:5, 1:2) } # Data frames and matrices are recycled along their rows vec_recycle_common(data.frame(x = 1), 1:5) vec_recycle_common(array(1:2, c(1, 2)), 1:5) vec_recycle_common(array(1:3, c(1, 3, 1)), 1:5) } vctrs/man/new_factor.Rd0000644000176200001440000000247213622451540014613 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/type-factor.R \name{new_factor} \alias{new_factor} \alias{new_ordered} \alias{vec_ptype2.factor} \alias{vec_ptype2.ordered} \alias{vec_cast.factor} \title{Factor/ordered factor S3 class} \usage{ new_factor(x = integer(), levels = character(), ..., class = character()) new_ordered(x = integer(), levels = character()) \method{vec_ptype2}{factor}(x, y, ...) \method{vec_ptype2}{ordered}(x, y, ...) \method{vec_cast}{factor}(x, to, ...) } \arguments{ \item{x}{Integer values which index in to \code{levels}.} \item{levels}{Character vector of labels.} \item{..., class}{Used to for subclasses.} } \description{ A \link{factor} is an integer with attribute \code{levels}, a character vector. There should be one level for each integer between 1 and \code{max(x)}. An \link{ordered} factor has the same properties as a factor, but possesses an extra class that marks levels as having a total ordering. } \details{ These functions help the base factor and ordered factor classes fit in to the vctrs type system by providing constructors, coercion functions, and casting functions. \code{new_factor()} and \code{new_ordered()} are low-level constructors - they only check that types, but not values, are valid, so are for expert use only. } \keyword{internal} vctrs/man/vec_split.Rd0000644000176200001440000000220013622451540014441 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/split.R \name{vec_split} \alias{vec_split} \title{Split a vector into groups} \usage{ vec_split(x, by) } \arguments{ \item{x}{Vector to divide into groups.} \item{by}{Vector whose unique values defines the groups.} } \value{ A data frame with two columns and size equal to \code{vec_size(vec_unique(by))}. The \code{key} column has the same type as \code{by}, and the \code{val} column is a list containing elements of type \code{vec_ptype(x)}. Note for complex types, the default \code{data.frame} print method will be suboptimal, and you will want to coerce into a tibble to better understand the output. } \description{ This is a generalisation of \code{\link[=split]{split()}} that can split by any type of vector, not just factors. Instead of returning the keys in the character names, the are returned in a separate parallel vector. } \examples{ vec_split(mtcars$cyl, mtcars$vs) vec_split(mtcars$cyl, mtcars[c("vs", "am")]) if (require("tibble")) { as_tibble(vec_split(mtcars$cyl, mtcars[c("vs", "am")])) as_tibble(vec_split(mtcars, mtcars[c("vs", "am")])) } } vctrs/man/int64.Rd0000644000176200001440000000134413622451540013425 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/type-integer64.R \name{vec_ptype_full.integer64} \alias{vec_ptype_full.integer64} \alias{vec_ptype_abbr.integer64} \alias{vec_ptype2.integer64} \alias{vec_cast.integer64} \title{64 bit integers} \usage{ \method{vec_ptype_full}{integer64}(x, ...) \method{vec_ptype_abbr}{integer64}(x, ...) \method{vec_ptype2}{integer64}(x, y, ...) \method{vec_cast}{integer64}(x, to, ...) } \description{ A \code{integer64} is a 64 bits integer vector, implemented in the \code{bit64} package. } \details{ These functions help the \code{integer64} class from \code{bit64} in to the vctrs type system by providing coercion functions and casting functions. } \keyword{internal} vctrs/man/vec_as_subscript.Rd0000644000176200001440000000361313622451540016020 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/subscript.R \name{vec_as_subscript} \alias{vec_as_subscript} \alias{vec_as_subscript2} \title{Convert to a base subscript type} \usage{ vec_as_subscript( i, ..., logical = c("cast", "error"), numeric = c("cast", "error"), character = c("cast", "error"), arg = NULL ) vec_as_subscript2( i, ..., logical = c("cast", "error"), numeric = c("cast", "error"), character = c("cast", "error"), arg = NULL ) } \arguments{ \item{i}{An integer, character or logical vector specifying the locations or names of the observations to get/set. Specify \code{TRUE} to index all elements (as in \code{x[]}), or \code{NULL}, \code{FALSE} or \code{integer()} to index none (as in \code{x[NULL]}).} \item{logical, location, character}{How to handle logical, numeric, and character subscripts. If \code{"cast"} and the subscript is not one of the three base types (logical, integer or character), the subscript is \link[=vec_cast]{cast} to the relevant base type, e.g. factors are coerced to character. \code{NULL} is treated as an empty integer vector, and is thus coercible depending on the setting of \code{numeric}. Symbols are treated as character vectors and thus coercible depending on the setting of \code{character}. If \code{"error"}, the subscript type is disallowed and triggers an informative error.} \item{arg}{The argument name to be displayed in error messages when \code{vec_as_location()} and \code{vec_as_location2()} are used to check the type of a function input.} } \description{ \Sexpr[results=rd, stage=render]{vctrs:::lifecycle("experimental")} Convert \code{i} to the base type expected by \code{\link[=vec_as_location]{vec_as_location()}} or \code{\link[=vec_as_location2]{vec_as_location2()}}. The values of the subscript type are not checked in any way (length, missingness, negative elements). } \keyword{internal} vctrs/man/vec_unique.Rd0000644000176200001440000000327413622451540014630 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dictionary.R \name{vec_unique} \alias{vec_unique} \alias{vec_unique_loc} \alias{vec_unique_count} \title{Find and count unique values} \usage{ vec_unique(x) vec_unique_loc(x) vec_unique_count(x) } \arguments{ \item{x}{A vector (including a data frame).} } \value{ \itemize{ \item \code{vec_unique()}: a vector the same type as \code{x} containing only unique values. \item \code{vec_unique_loc()}: an integer vector, giving locations of unique values. \item \code{vec_unique_count()}: an integer vector of length 1, giving the number of unique values. } } \description{ \itemize{ \item \code{vec_unique()}: the unique values. Equivalent to \code{\link[=unique]{unique()}}. \item \code{vec_unique_loc()}: the locations of the unique values. \item \code{vec_unique_count()}: the number of unique values. } } \section{Missing values}{ In most cases, missing values are not considered to be equal, i.e. \code{NA == NA} is not \code{TRUE}. This behaviour would be unappealing here, so these functions consider all \code{NAs} to be equal. (Similarly, all \code{NaN} are also considered to be equal.) } \examples{ x <- rpois(100, 8) vec_unique(x) vec_unique_loc(x) vec_unique_count(x) # `vec_unique()` returns values in the order that encounters them # use sort = "location" to match to the result of `vec_count()` head(vec_unique(x)) head(vec_count(x, sort = "location")) # Normally missing values are not considered to be equal NA == NA # But they are for the purposes of considering uniqueness vec_unique(c(NA, NA, NA, NA, 1, 2, 1)) } \seealso{ \link{vec_duplicate} for functions that work with the dual of unique values: duplicated values. } vctrs/man/vec_compare.Rd0000644000176200001440000000211313475700023014736 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/compare.R \name{vec_compare} \alias{vec_compare} \title{Compare two vectors} \usage{ vec_compare(x, y, na_equal = FALSE, .ptype = NULL) } \arguments{ \item{x, y}{Vectors with compatible types and lengths.} \item{na_equal}{Should \code{NA} values be considered equal?} \item{.ptype}{Override to optionally specify common type} } \value{ An integer vector with values -1 for \code{x < y}, 0 if \code{x == y}, and 1 if \code{x > y}. If \code{na_equal} is \code{FALSE}, the result will be \code{NA} if either \code{x} or \code{y} is \code{NA}. } \description{ Compare two vectors } \section{S3 dispatch}{ \code{vec_compare()} is not generic for performance; instead it uses \code{\link[=vec_proxy_compare]{vec_proxy_compare()}} to } \examples{ vec_compare(c(TRUE, FALSE, NA), FALSE) vec_compare(c(TRUE, FALSE, NA), FALSE, na_equal = TRUE) vec_compare(1:10, 5) vec_compare(runif(10), 0.5) vec_compare(letters[1:10], "d") df <- data.frame(x = c(1, 1, 1, 2), y = c(0, 1, 2, 1)) vec_compare(df, data.frame(x = 1, y = 1)) } vctrs/DESCRIPTION0000644000176200001440000000271013623552332013125 0ustar liggesusersPackage: vctrs Title: Vector Helpers Version: 0.2.3 Authors@R: c(person(given = "Hadley", family = "Wickham", role = c("aut", "cre"), email = "hadley@rstudio.com"), person(given = "Lionel", family = "Henry", role = "aut", email = "lionel@rstudio.com"), person(given = "Davis", family = "Vaughan", role = "aut", email = "davis@rstudio.com"), person(given = "RStudio", role = "cph")) Description: Defines new notions of prototype and size that are used to provide tools for consistent and well-founded type-coercion and size-recycling, and are in turn connected to ideas of type- and size-stability useful for analysing function interfaces. License: GPL-3 URL: https://github.com/r-lib/vctrs BugReports: https://github.com/r-lib/vctrs/issues Depends: R (>= 3.2) Imports: ellipsis (>= 0.2.0), digest, glue, rlang (>= 0.4.2) Suggests: bit64, covr, crayon, generics, knitr, pillar (>= 1.4.1), pkgdown, rmarkdown, testthat (>= 2.3.0), tibble, xml2, zeallot VignetteBuilder: knitr Encoding: UTF-8 Language: en-GB LazyData: true RoxygenNote: 7.0.2 NeedsCompilation: yes Packaged: 2020-02-19 11:07:58 UTC; lionel Author: Hadley Wickham [aut, cre], Lionel Henry [aut], Davis Vaughan [aut], RStudio [cph] Maintainer: Hadley Wickham Repository: CRAN Date/Publication: 2020-02-20 18:50:02 UTC vctrs/build/0000755000176200001440000000000013623213405012511 5ustar liggesusersvctrs/build/vignette.rds0000644000176200001440000000040613623213405015050 0ustar liggesusers hLj`\\:HDS'_\mB6r< ,c\&E}b>d<ڤhBeބ2wRt!<E=Ys&Y))L2M 5暴vWѶҠѥAu5:4>Bgߵ!XJ).iBtJ8R--m y{+}Q[/(緣cvcBvctrs/build/vctrs.pdf0000644000176200001440000050634313623213370014361 0ustar liggesusers%PDF-1.5 % 125 0 obj << /Length 938 /Filter /FlateDecode >> stream xڕV[o8}ϯmA W}]EU5e2!Vvk!L9Crs{]ln1A ;1A!c^tV(GB "l@! !67d/\1.C ;QO/&&|#&^=hPR4>1!Hpwz/B%0'&Y%>J@# @Z`˞7\zGBZB8}s?9p~/ò;`Jcm,l?\M\&δ>톹m5UbP~$!VDE N别U !NO$L`W3Ε~Ao%q]*so,vEF{ʨuh, 9ٱB}FE i`2;Zސ3 ӱ`o?g ;nOXo&6t _r!a|ڨ1(?7v ::7ЙR* ȳQj-TUFޠqC%'5~Mx٬+D Bhk+u~E9 u楒]Jk%tSv".@!+iEu:kd&S7|^jmթxCTV Dba\_(τIfqSXSr:$HdNc_?VbS.WO()ߝ~nG{O /n<1ޜ/^D)rRV8 }W)I]B(_tNNOGq,W,ė.W*O t(ْus|V8_e$ wNkԔ {}~ ܉VGVoYtw!C_rw?ք endstream endobj 164 0 obj << /Length 1738 /Filter /FlateDecode >> stream x[Ko6WT D "%u (=%h/$>ڵoǐPuWg?\8g"P&.1bg4(!]}x<&{ & &U[2ZʛE#]p $6Q#+E4E',}[E㰨a {q]0DS9G"O AkWg09Ek/"E8\Kj8Ke`8qQɭZwʍ$ ß? FڹUR@C/A߂ dAI'BӊPkua0}B3 BYOgvl&?*'M`"Bȉ)((]Ng_%|C|t/fqP^P,yi܉x(u.޼X P:+ *Թab1'!yu3rA~YJI%==d|(0&ߌ*bˉYmZpJdrfEEr:;1,;hUnH&NR>F˻qnֲk8'tA)l?p͙hJsPc|C';2ݿLgmqlNш%(iQ4u\1&(IdUvx"dv(F |{# | X6 ܗogoRK01 ff~vae)Jq:"ℹr+\fOY~c %I36ondMS`n&ళe&)"1àGi Uu]UrDa(C_aiXok+.k[W>4m\RbƾɸihH!DB9V:wyܴڢnS劄{5(og;/oe]U3cU|Z_lSCЊg,Ϭή KLzLcҕ6p.,Q4cBSXC2[mDŽX .v6;Y<%;i-I[kW7x disݤո "¨+RKsn\52MrEU]f/1vٙiv*/B]0{+62.k?J3-kvPsen((e߻Yxr9tbꕁnmŻRZݍ Vr{2/׍-+?9[tj=CSpQ?0̄kBuf?nǥd0[(av k#HWQv@yU*ixPݔm[Uzj}ܹ/@?F;҄>DC0L;IZ26uKIbf lyyR:hؓq~h0CT8\c7 710+E|鋥`fN@y>\fT1V~IQBWkx&,= Q/7^m3Ӫ0sgQ> stream xڽY]o}ׯ!ُ(ȽZpR*BQir=CQJToJ^rvٙpHYeUP֐ʒÑze3RN,Q91&"â31+eE`FQWlpF-bYR9*79b8@YEB4zCVL*&F0X2V!pGlxqN3ƨF*YL?F(JÅ FgT Q< #rq0e#2@$A"c: xCq D 2q :y)ElAs^,9DߑCDO, 2,|eHE(}ܒV'5@!dă09! AlNH8*JB R S$\(t' p Eze0g/2A܏|1 C,5{Y/'A6faE..TJZ^UݖM=_|{MySZu[}vz+<:jJ$baX_ݔHͼi+En~FAЈ{bb:n˦=`ax f9Vr8h1@,,Yo΀r[Awu{8l9o΀n|;l?)fU-pӷqxad+ê>u2O&afY6Xgugl㰦\|^z)ǁ^w<溻[ΰTl(vua7x?P_nxhs88`7Fš(ٯ{)'wּFKU+Yxq1+^#ʪy߯<-:ܮw͢vBg\V֟#-cfA%:PHO_`|#]TwuiNdEAnV|ekGm/q'Y؅cGьãXjV2(_\tE[UK{rӶ7EjovoͳUhShBy Q't348:d7nwTړt^Rnzh5fZq/@Jvn磞z>㞏{>㞏{>/|a.TuYzl*iZh1bs5XU`M*! O4Ҏ@ !95#hOQB/0K ^B@kPpj`X:<tG (Fa iJ V)6Deml~X5k0Q J~D\<LG L#<;Q䯫KNэhk@utKuCiD&(4'@ypcU5،tt#pF} :IF}i$N2QC`u5>plڑ'skYG>h7}&޿j@}M/!q/Մ`<ǹ$:IG4vIBq0'mY Q@mcmFdu>|6:qN88?}4cqc<'HwI"?{z\ ] X_QFUu󮐳u^\Wل%]5MjclNiS^MY/J-wRߴWPPko?-A5F endstream endobj 198 0 obj << /Length 1674 /Filter /FlateDecode >> stream xڭXKo6W,Cw/CR"%AhAOkjCZkDə<.twBHH"\lRrIJDfKW.շ}kζliu݇@THrb9fubpVή!b#CDF9MMb/O2cIk}9:,\YHXၫfK׶38iwʍ]) :]ָ`"+UUNHu9=iU~јM9p;17bbӶc41R0kZܙg_ ( A2{H*6<NnSC®n^%a.)ǥ G&C 35P|iv!4䥮â+W>Ѕ$,&$`.ny<B͍@.3GMvk %ҦaXDIȇ"t55NV6P+GAf(PKA|ׁ ,@UhYÑKœ'üDu pܰKq{@]r7J-r^yܼ2 oح߾ZC?O>"ޑ]q8q΄=# !~B[*$ת&NGLm~厏Zv -;lq-;NEeC 6xaA.{%}~泍ЏGe y.A]tr=}U.&k˘@L\ܳ_z<^=c3qJol1{֧O͙' 7Bgy.Zn2ŮbQ0#S̎4}$$CSmD~qU>-cȦ kNײ bK6¶1L!PKw2\ $bp-|k 0NCQ_ Ux \u{w9{ XfcWf{H ,@c&ʆjQբkPO.s)ߏ> stream xXo6BHLjQaͰݗt0Z'IfاmO#y݉::?̾[^] ߉HsY:R"< |Jr\O<Ox-KzUܢZ+{g2;qViZJr9zۗ}w 5l`DRe/5Rb&Fvtq\=R|jBšj4 =k$E9n}bf6Mf*o2 [!"7?|m>QʍŪсs8M`2"CI(ҨМEz#Vn뫓xfꃰ鲋ʐՆYnh_ kHP<KY^UI5LZxY}9$1Q0Q%Ʊ/hAC%G;㓻* uUNňT;Jlc`pL:h7D)$sNoi1b|?ve𫉫y$ hx9CBh~8a"%E.F9y=qIERUCDP苼8fUPebl"udL@BP;\R.0gXu8Q^Fah qbhP27 1"V=-BNҭZ V=iu^fS|fkCkA€Ar3Ƞ'BeT9{$9uocgOK=r3pE#_i43ZWudu89i{%Ե倀X=3l9X=os()zpƪF)iE_|o'Pǀ$=‚VhW L(f@XZYc|DOC 4|v 4E qwЈERk eO*¤Ǻwl ufpH5 u.u:5dwRW*cq1aN}5m]y~,@oӥ!j`8vٍYjp '#k_t{yjsPU8ˆCWĆ!Fh unm`(nv݊5 ;x;joH}e u 4z k;}Y4X^LϯHw ==/*p7 ^ 4. s3!ZN7`0m* @#I#AN_Dw> stream xڽXo6_!崀WI}.))Z8ZZV#P+ie_/99񝟯~M K#9{Gȉ# tnwΝ[eG=|?QhCG^IgXCdY>#޵e^_ˊl +'ҔJ^e軍^=e,ڮq44ҥ>']MJ9VG/o߾]8)@DoQ,x~ZAʲjݒmUYg5Ǣ&.Cqĸ`DAF|5xm6EQ߬RxEs4>VCzjnn>_ ;b0HN~wvx*Mzt!8*wW?{>F !@ ELvB%b/+} &?M7 ؼ^~h4;dيz%C&+mQ7UTiGfնj ,Y#lZAT|} 5Ŕ{Լ* _nfpUjTԍx= X49m[@ұ L $/>H9-1Ν3< "B8 !Mj$'KrzlzUVl5|nAdz9`EmVwe g ۴?emjtݽAMCQ*ˎluVAaUiVgh痢˛uKCQ| =貤S]{"/UlDOuo9**N!A .\3N1\p`޶A&g+0 z 1uow!_{ʶ.{+#kٻИ^ǖk3xʳW&]W-Ӄ)ݩU)c&=2n*_C.v*ex5̯āCy? ^R2&Ϗ4Xz PR֛rSrФ;8ݭTL( 0POE$Łb1B~b"!F-N(׸*YVtYЎ% ˇ58?!gbzD\C25D`=b)4B8,uu0'Fgt'"fxqX8{#񩗈aG<9K*5/**7,ʭܦ8Pݠ?M'\+?pX_{Z"nrx*Ő004\BEuKyR\HHƅBjj1Id',`) kE+au=7we/rS˥gh-]4ol^,Kܙ"﫜fhs 4X &c4qZ >F6܁(ik! cERwtx L -P`48GT\|CWO0XljxiK; Fk@9= C;a7 mdhǾfq({B^0\: ?4jbǯ抾Z99*Ncria&G]}*فz?_fz endstream endobj 229 0 obj << /Length 1283 /Filter /FlateDecode >> stream xڽWKs6WpC &H!O{pڤ34Nqa 8C@ۚLۻ )Kn|m{ [=($>[xi-0JN"Pӊ(9-n3Oi&kL|s 6yZǛGZ &ǞWoKasLZSoDz5G?}[Ӧ%[e^)lԫ;6rZgϱBsϲJW<6ԟTHW t*]ZwGWVa02=-DWL,xqP~%x "ih H[z,= Yed)2ZP'%!~!W!A8P}0Xʼ6HC?]n*Qr 7c*F2U'1HWlx F= ,1 ]~*u DpJVc@CG9a yUC[L$FQ]סZn?rHUu.8yѦ˚q;gDy}9nLm~`ƷswҶ JzQ!٨Y s5=?s>r_Xj^6ݛ}Y7g b+nwT7 V! ^VN>|áդC+ZzCo' GxKA|܏k@ L Em?d{~l^~ zL`Ta5F!#mLd<0s\~xN Mm A>V-J42fu%i^ l,6+>~Ђ ͂hz?є0ҵUbG*膝O_vU0Bpk 9_9@I|>zQTKP~S藋ؠ*;> stream xڵWK6Wb.ߒEE M) ZȒ+&×$e29|3 u?&Nn8RJ*UD0F( Fea6ϊUm&8(TXL;(Yɵ%X+[ݮSwjʏXUhZ= |6O<2 ;VzݘvE8"!EN>|_E&n#N9"z7shOP$+8ON@9`7EiBAbD;i{!-tߪmr8QIa%TTRm[3|ߪGmbr%pCǞ:]@v+]=!e/̼F#́~RvJ,!IϺ}^.v#͊í:Љkǽ_gKΩ~-<T8FO̝"MVCQ!DMI& m> n|ydT>IӪl UUbʿ7Lrs cp~s%A`ΐV>R*4q=yfD |WeZcZ|vcnrU[`P e}BPS@#l< d]m7u5bzh|Tu >lTARG0,+ՔH2 qog"Cs֛=9`)k^Z9t[hg(O[Þ@DqmOh6_WChCF5b* ;aX ݕ205g=гd=/\?WNz$vfCwx%Q?GRDȰpú=姈%ĀLdОyo> stream xڵYYo~ϯ7-tN3 Ud:bKIN>~-E1ó|gQaW'߽Q4bQp h. B"9 ,w6r)`c d93dMmUo8C^]w,ECyffF$ (Eg(CO k F2[vW7Cuۮ>~baw-.%$PvIDܱۨ=pшXv̩]za8ku5gr,Mg]~~PK꺲F)ި-~30ZIh $tŤE$N">%4nÙWs<#864$q pI ˺ӤcL5i0N ?#B~^3 ꪭD3]V)EnZ|moii(Q!,,1oFt󀧟zL9#a]XeEd|oPe;|*d@fQxsFd\)7+/ڃq$DD.EYlO瀞]pG!]@6.PN#+ɛnY qk9UK޿UӻZxaOw%ި=Ô'P q>_p4ĈX,f |k;p %0ëwHP Li2Wg>i Et8kpD=qwBXfmfF B/&kBcv㒴,d1}=e-Ҭi}c\Gp)OǑOX 3Nɩ3s-}E]GS!eeæAgݪt8ezK/ƺ΁ "h'Q 2z~r |݊@I#ĤyQғ󦮀݉j1m0i J*qXwEtlrOk, RH=r _li Y}mT2>!UQV^}6OL=OAh: V) u($}p<].}#WOtF=}eYHKմ6N]Զ( O Z_wkQ2@t d/u[ V|gf(g85FԭkmhW踮,7^Ĕ1,&#A_5q|H/'F rd8H9#"M4_lՋ5cVMQͤ5uu"tWze._uO a{t+W p(9=ռT$Es;ܥ Y*`KӔ*"BRJb~kqc͇V=~ C̍sBK5萤uU0q*j]T:44墱OʴJuiml@hYܓ Y2`r?:LbkTKų )}+'/ ^W O xBIÞN$PFԃBFVT5p2h -@/蠯ިZ4/Q}ox endstream endobj 269 0 obj << /Length 2390 /Filter /FlateDecode >> stream xڵY[۶~и)5BI9&I;z`{DHsp"h/i;@s?;X]_}{X,R/ 9^$Ce)\.uq(.֣skj 9ny-]b.b%SΣu\#1Ν:[­qN˕K{Z::Te)74749պϩn)xT") B$!!]y lM$Z#I)2ZobJT[ɩ' Mvu_j}E ]CsuQLWl{LTsF/yV-}]sǺ8u8D=˶meDF@7c:f*͉$r)K\}&k*Wmo}ՠbmY,2:i < Omy,*7,6h8 {7IgrAM[YEqoHf`xas@EJ05e( IL:u+ #le=SUSS3hgзsrVQe; hhֆ`'g J#xrF|j1EMmbF^mm!6ab@lôoGGf:"g2^;S*Vj X8^?F2'k ]/AJrbf,O TVswXEfs.`*!^8eq;^|:0s*0<_=&S* -z4 )( 2Q"vomNu67!7H`ȅ? k2p L$R(rCY.H $Ry&BB P0hmG[OOohh)&21#ԛxDDgVUыz Q-\ n8~C_gƅ^U>)9{ >]t,Yvwä΅=<3q`Tk(4iZsS"Zu :w13>dGbX2 e_"RcLbvv+A 7Op#OX#/26 EPVGAS>Q ZD_w0,3Fq4c6 &CGv^Dp%c4~7@2TV.[̳dguᤓh۶,z0+w)MR Ӓu9S>o)48e>mKy"NJ1ÛzJOlh'fsX9lΦ!aw`"Ncxu?:RLY2[jJ&@LSǢ=vxtV[J,K?\t_CidőCLK*dTcc>lcD_8 `2OXHO r'%_M{33"yY)1O w;Tcu3;Ba3l.fF,<zO Mu-3Op !0 e(My.Ƹ1h&E࣠ѝ,ØNjH.vJwem,yN'ӌǾOhqݱ/0Vط vE}ALA %Bms%C.3CƜ<}cI0Sz''a&81#H}R0\|/p]1e#Уqňor>$COLQh:6L<I혥ۗ\>ϡHr>1AmahXihdB<! -͊Sesfp(yZ[5&"5J!?! nluoE@,`"!#Dݮ97H ٷ͞0S_]XŸÿЗ.I9ْ{^$7Sr5iv Xhq7 6veK1_:6MJv˂/DP4UtAf>Vzmw_\ɻ'Ig4 endstream endobj 279 0 obj << /Length 1477 /Filter /FlateDecode >> stream xWo6_!x{p0I}ҭ:ֺCVxDZJrߑ:й c\SPE>/ڔjC,Áyi WQb4Lux L7J{kga4LYO>ONZͼT\ !bDk4u \[ihH3F5;ճQ2V+¾04H7hǫjcrlH53KI;Nw|1bܠaL,03&*P&@z]P2W[1 endstream endobj 291 0 obj << /Length 2552 /Filter /FlateDecode >> stream xYY~ׯ iYAD~p$"g9vETuuϵ Q]]W5j W{w?*Xxu[0dRū$Y$v=QMYm}e<9BΒ͜wFky-#?4< IW];;}Q)@g,Lcly$fY*ͻz-05I4O54Ԛ+#I;vvM:%7vf\y@6g!볇LŃA s{txA,D޶$%3AWTS_(xa]}umKW1#G̜rNTvr۟RoI *8,248hT^U7Ȝ^N-#E}Ovr?n. %JիުX* #<2ܐެe͋tws:4'01䩡3I2Y?GBv'ˬ"aЖG LAY( >݅04ۛ4C5ykFNf]f:oAw3|dIuk;" PGc!;%[ݔDfs|t2xY$4MVTY .r~y!TgbP9MJ+)23(R2$i̚Xbv9Ƌq~sߢ>]~z-ʪħ\t_ԭ0N)WÔTZa'Q4| 0*&&~G(ERא 1FV408OxOZ<6Hu?afLq/`dx8 Rܕu}u_tnC2]^=SL&jᵾ,%A9FBԷR: ֈ{|x~whİ"# P9Q`Ox[[s׹}"] c1wv4Wq(jcYPeׅ R)`Bp_hd~s5fQ<;D1a|%fܽE}"M)I4C"ջHħ.+wp( l@rw fd90a'|e[?2c"/ N3`&]Cy 3ڮQ+LKɒ0]yټ+![xbfnU_/LRcJнn)djWhSaUqŗ3 XPK;XjPh4ETMkBا$P=bwH$yݪ+jz0#'ɛ.!]kj0+ fŘ=g|4w9 h5)Bq(حEaE^=|#[iP}n^N زѠQM xi6ipZg!((^@Copa@PdCa!TXA'vQT[pkwf0 ]ټgSRɉMJ o84χ|/ 3+ؤi@5^X*;8e(9Fa0ycC)3M^xN*`Vk-t'I N\(985Dy &U6`E+_d傋׍WP,ʒ\B9Rɢ%[hh=Uژ̭R Y2E\B-f \tR 3oNujRM\%$hϺ0ƺe|lj Pd; iHt㪕a6ਫ=6epp=l;C qnI!z" 2΄)o}ڥ,dt3o8m;3&n-R,9QF^W oKӁ2!0e;{6pޢ[`rD, /"UE{!f?F6Bɇ Yķ&hWi|DJDoH3*-N0ֱ,W42q VÉ$z΋(2ڃ;"V cXpJ)L+!Rp6RfĠ7`rZ)Ղt4r7jQӅ˜C>U<7uon!,RCfGcƹ.dZj˰Ɓlqk2CK@uz=Y u? {|N@s"'-`d'߳,a}u0{st"ld aY'>r~_Gsq1V7EӨ͋ìeD\~s:-,=mj8oH Iu(@4FB4[4cyِm,,͸55W cCcPM> stream xYo7 ~_a:IE) -؀"miMlþ4=$(")RgD6^)',:Cs&:ћĢk6y\0k2Y8R`"`!b1cxRTX&E)H1+P8Tg^UQ| gLH5V^E/J(^y"0B5fQB0!4$#q`F%`u ՉYgCC$5 Ā ''G#&5X J0f|Eu: EYm8̰1VsjMP (AmFRqL* ?8nlAaԱ lD#U@q#ç aº`(0p q (B@w.Wj(K^ ͒WŸYe"AҜyęS? gI,8[`gq6K1:ώp] pBC ۅ x C 0^ϧӺ1gzTo/Y? ?ԃd'2Nz>mjiIs[paǜn9X@rgRZKYvlc L9[dm6^2 .ZRs,YM&Sp<3U$:HyӮO> E=owrߪWՋ3.T")6C aʂHQlQkSS:}35h3{r}iǓj6luKp;{BKoǙ,!<k &lƅonƥ`3R^]J ,Z^y"<˞y>2? ъ?&znuo'+1ZF n`Z=8dQP4RYAe[Wha.z0l\G1$[8w3lrvŅvOy?Y'n͉(Djʣ5u1ð)jE6-Xfd2\7H-G ڞuK{,\|pJZSGCǎի=[m';xseA ي+hw]?Kie-0F8Z9s':FN梏?}`/֐=.ꃃ᧺-o}}OoM`nXR倱mM`oIHeW=]=q%,wMBd$>s}i0MT3mG\>n74;'ru=䶦SN 8 -DN{1R3E} ?j~9|88h ?hi@lPlFrϞ FJժU::Ƴza|QCՊ˰i릶˧q(;ġlj Y)܎Q<Ryӵ?&.!'cN?^gɹ6Jv'2#?mᆋvh#e*;a]ް6)P8C(As & endstream endobj 299 0 obj << /Length 858 /Filter /FlateDecode >> stream xڽVo0~篈 Aj'qH}2iuLpR~ia*]o/ 3F!k/߳WSFF2L幏͢9js+=2RdžH}.X_z|[Py yx .Xm\: } M?"vFyBN$.<,K. qAS +p"pDyRY(>$C1!++׼FM=g<[ XRNT^ƕRj+kCG&`fU:gz=aԨ\xr1> stream xڕWYF~@N<Һ`%d7Jhm#s-4s(Oٙ.UU_ϳ6.qBw6;`;+#Qg8+-x|_m~ ZMq&YfHJ% d^ҕ7ʥmZ$X9KQ腚)Dvust0^|W䝒C_ƅusKNq/'*JPH}֑\hڪ;> 2Ѥ4[SwF0g*V"-g\qy1|CGC-}%3.G`# Qm@+x#^-LFڄƠltkҼǼi1lY_ۧ@-5`m˜sq(a 6DG~L<9a@AB<.UfQj"ݞAXDZE]3Nu:mӢQqU s\f>%YiX/Zz7֌n"mb_'mq$z)4.]h/h }:wAٗ!pzNnﰓ&ba<*q 9T &Ho<> ,HtƎ( bgԏe0ԓ^̹s$9tkiiL+i iW}S-5H(KyZn;76oK˻>`S{F8|wT~\\A?!:LلK^/=%Y!Q|4:͡*5!: g *YhHN? xVTl:䭜ZR9YCQXWl*4D;v*.fTLQ 2w[]I=Hǣ Z~a #t<(R^Ҽ5_U]&ml$ʘqN8LDӟ1O4j4ٺ`<dV endstream endobj 318 0 obj << /Length 1777 /Filter /FlateDecode >> stream xڥXo7 _ad/g,VN}hfðvlzW)JaK(")̝;/%, E8_͸2gQ|1 CYy!EWoǛ;![^ޅFX!ީ%ZATNT6YY wVeEi}̊XgVʬbIm, lc߹ddJj.8  f-8gIy@Ӯmp/k$Slh&iu^4 *h٨Zz/T[*Խguq kpHӋu^Ӑ~r8j@@$o86<_$퉸F΅k28sUg`u])I1f#~;q,J<8VLX',.Cꘈ}  sjm\#%1TၹU^k#QUx$@s}9YeK)y`u[ 6i{"9dKZTFv,si=jaaSbr?x%sPMf/4 ײbhk\*MiHg&tqeA'{#L~ZF$D0\WÑ;H 'LV b1F 33;0vR MҾMcc##0f;]4]YgxJ4ŚhkVU}g$/DĄUDmٚ<裤 UҰkBTZ>7pmsy`{%$cL0:+'uU̷:D߮ga_9 O A : xVh>N)wYzqw`j<4*YuyK`ژ*$w=&D'@18ҋ캛8tƋ|ܨ:*Y?h+۪{a"/8QD 8'‘۸EĻ8]&x2ja%hΨgBւMx{Pl5ǃ~C \ͶFʜT[bnDʔ?4wٿj@C馔 px=S9 |؄fo;(UG@<|?e9+:p͢?Ltӥ^9[az]Y3=gq_i#+N/#(^D. KJ,RwhuERgJD6ѕNH]-tT\=A p^eDj6VAU]OG9MunjۣTI"&k1urqh:oZLAr]U &o'QF endstream endobj 327 0 obj << /Length 1409 /Filter /FlateDecode >> stream xXnF}W Hk\7FN^DlARKA]Rsf\[z^␄QzQ Nw>S}ޤj=z䂆` P1W"^qrA'@6dJvNUsV%Ar:A6 >3C귛f-Ӂզ7߳|N00wd䯤4w"!;4f YTcHێһNப]EU[r\6橺33.K6ig_OM0( <܇0/-&~  A9>h pxsqq A>ȵLZs]lt&'H/P>B;jlE6ivt@:C#^p vXוJlbO9ҬnJ%Hɲ5/ ٮٷYkǙ:S2dP}44Y]٣뤅 ;Jp 99)<+`C3S̶&Ͳ=L!>Oqc6y%3ep$K9A̠04PX۬O)妀(6Gm_DY|#l?؈gqixLIѦI6ij<)$ Il AUZ`~OLiɺ}540L"" DYXt{۟vcُQ8>nܫFgW'}\#ߧ)Ƹ>/iۼ`BIUZve?f_2>}W+=n8md^ĝ_[. |s&eónX_pMJgX?}x H>4ā\mx endstream endobj 342 0 obj << /Length 1557 /Filter /FlateDecode >> stream xڭXYo7~ׯXI"r4)NѢH]q=bwxV"pxp\6~t={%Q&:"#'Q`fN_Ɉ@-ͷs{ivB@[KM{ENept"a;{KT(6SW5we_(7Z^;Ԩ G8KW~_`aJ; $G޼9-(ɑ +X}'E,;㹺Œ)$EY6P*E~E52f/1)^,#3ҜFKBPι%jdW*;x8yw9eb>pfrʏC)c)S }R%i=\%$ qe 3f)?0kl[mOrOL E#?aLKRDljwdSBeP+)UIQ;ܷuʢFcD5}S8.dp㮞7Kp^73ڔIï?^ATqmK-AsL|#fX(W;VLMʵ9G y]'FN_kKziBt3ō =㑎~Z~TkYR $l$:q[=UX,YbKLAjBAǓyj;:y6mvҔPTs5@ 20VΌ[N@^- b }E3}{Zpi]< ^m U+y1ksh; ?P zKF!֪jUE6Ar{'!H\ N`9COz',LCo`Sm=zH; ,7>aL}zJ N#<}v<ԽɑP,L 5\s: oZVC<(GˢW%h'eݫG~MgljyU%ła)ceYLn)wɃuێxKL#;> stream xڥW[o6~ER`{v؀=,"ѱ6]\JÛ,9v PRytw>~8 0ej#A8:a$#Q*9/.s/WHb`lƉ2 '`/](kȇ]lk.'ύ>FQNPR+Yt}>,lT I(cىݕ-/*>9aǵ7% k;N;`2~olyy[&aRDS7Ե/RĔ HO~㽮ʍj|z)ԤPz~$X^L턪G|ݿS9Y /Xs8&]ǝwqTΥv(W!Qv=o"o}_\N_}!pvE99+!ͧ5| jÏpeݿkjyTA/)KpP40(%| , &K\? e#QciJ#yA#RuN -yF,mE7N?NHBDM,0 !Bc?sYjkHv)h!!$#_C,'WJĎ)=OB-,iAoKC 5UqƼJ*4   eg.OQĎR^ v zтA\ }++`ѳ4tzkݟ+%E(.ۭ r n';R .yY5~-X%P)?aFX| ܊\"̈MH<hxӉTV;=\{3 Y!xn6uKymԊs9`'_L.1C&ߘvKO DL&'gǁ8:x0W#Lf)Gg XN߷Q&&^hxu/ڀڿ\lsQKFb!R ::'&@<%[Z׽S|s NV­>&JxfL9Όo&kAQtW:J۝> 5C}w3- =uEe:b-p endstream endobj 374 0 obj << /Length 1923 /Filter /FlateDecode >> stream xڥX[o~ϯ020"2mhHNYMjeѕuP(gC\s!qwTYdq]ΙEp\m_"-wb1Tf/~"t5˝ftb%rSMs)@pfCEcuGCmUp Mm * J-3 Xq5=]Y?{ GʀچSi>\YSze9>G5G+8H0olI<!*' |NDmboxΓ]%E7T&oDMg gƸcdh40FXi֮iLSAnCmc٢AFHК*c Ulrm*kE+95) A ހc.T3\L5W̞,IzGXEUu+p,56RDe]Tۡ1+c5T ^ mHwTGa=4Tho@"2SpƧ؂kaR78c,CpgE 1Q *v5kd;hB 1#4[`фg <'?Oa덭5 N"> /ho7"+粗7|/A^*vN^f @B AZRcz.q~=Qn`; 8u>e",/hly!Fgb*ñeNڙ9de\1%I`on+T'ԗ*v1T֭+5&bQ|b7脺ܖv& 輓u\lZILKc91NU7+n(9כO%xM8Xa<BnA$( EɒrYЧOQ/WӘm!)!^~xɾ[Q%aa 2i9v29,?*7 $Jg/;A6{4½WMKg8*OB*ZB^KWtH&qiR Vրҵ4 # ;]2Id6doQ.ڬ̮q2ѷ2,pf ̒$'&ʏUk 7{~&h^:I|g!4EeMpr4mW\S>,%2h7'C ?ގ|s:d(: T}׳-E'Fk^@: OeUVaΥZk(`*x31ns#<D-p7_~ LB.f ɳ1X'1盿>#sLn%XH7{Bl{ZFk=Eޢ!Nvݔ8 .@W"9Oxy}̻0=hW%r5Aq{m $x%[l_%$gWZt(z3}חۀ5]{vMt$Ixv"L_ 6eq*Gw_ߊ^̀X.6@p.*ء8:W;rv.)rdL2Dף3t>e k@9S~T"fZf=R}l64il34)J{C5]P#R@Z|2[[> stream xX[8~c*Q_+ ¢QM,iRd.~}4I;EVB>>; ?&'/b+ʣA@P^"9K;OfgN_o_pջ(J46G&{ٙ;"qZ6?M) Y]Vz:c2Ek2"4xu(ͨ"RoϧQ?w_t7+{|Hjr.޽;@%f=!a]܍cJ*%bOCG#FXvNI>>c.3x5"٦:"l$vZHv6#Dh&3;kO &(*E.mYVVpn N(Pah[뇀"$pRKqDcM85W$/и,W8fŢ`&wkPw@:MD^e4Dt@]6 QO9Bi1hZo2_4{=|PR {[[`Ǒwgn=@<>N?lD #@8ӽޞ B n~@ Qp$oR2$x g;b UU3D?PDH띦"AmuRS #}@֐8j)܇AQHHAC5?3;/5!d_"ǷFMaeoK 9"јZ)؂s_}˿}!l U7Lf~q!&}~ҦaBAu]>GZJ3\/IcT583|\ )saIXQ;ɗߦB7EۥI S;ğj5t ױe 525q,XcDŬT1@Tۂa=i 2<΃]8ƽr~vVsd|,ri|cꮾ4Rć5GSdPMS+;ڠ״ALѐnaR˦m:h;vo@ގ endstream endobj 303 0 obj << /Type /ObjStm /N 100 /First 876 /Length 1807 /Filter /FlateDecode >> stream xZMo7W^(9 @ Nm {Su$WmZ;%UFz}Kg %g|Cޛ+ 'ދ lbq#H*I^a$)&3>>"7D(``C EtT IqI<0 $xD`x:{/x0+0#a`4+ %Bh7>4`[Tծ_gsX8L6Fc.U/F"ڬ#`B|+JlkgPXr{x(CF2s#57~3x`@Yg٧kL픾rb 8gI TLH260Vl6,A3.ʟ7Á~%[xT`'H`[,gΚؽr*gbc-mι Q#4F =ytNH0OD N$ 'J_Su/a"XH>Bֱ nڊf =Fb =Yb>^-z r$=,zJl9P7 shYuP7 ԰=_,bc'R]Z+nzVS=s|t*lQ?E0ç^Yn43NԌ#q0".:%Ni.׽8[N>\u[-3u7Gm#Dm;۰X*Pl, $eT6G.IGOO9e)zNEF2Hq@OnPˇ:˭| \~TbA$G-|9dgpAof!XsO/s3"#-j5(kw{68T-E]雃ce6p?6Gph#W[L endstream endobj 411 0 obj << /Length 1377 /Filter /FlateDecode >> stream xXn6+tQ3"E=4(6LiAXC@I^>D@7E$>}󽏣f bþyq0 ,ğ|zvMqdc3&8#٤<>vMۋS˗6]s^;7gׄx \9񦘡0)`FYb61-v_؇K d}Bv\0?now%VS~{ݐvx=t;-l5icv` 3/}"kC&ʇd&dYC؞i6zY"Uq!ڜEݤżťTM1DBɜMbAEh&WbGX kT.MizKP)½9&ŁD11A<(G2]ddq7x٘4P飏)z^6,ЂF q910p޲TKzcet5s-m@CX3_^AůʣPܻ~+nQn# pJFb6adeYBk70_$\? "@%fp [JUd, ENEꦗ1A&O^,i'PW<ȏmn/˝ՏOm-XbV4%^#\DEf>!6`b$w,FPS Gi~ Bq6-tڧE3[\%{b!dɕOHhj_պ,Pde4dzgaԬ+>U-A4C lhʥ敖 g13qQL(ԸTV"vHrPg/*Pm cAEw]J( > f \|}:`i@P3'_l ,V͘|_K~~B[^jٙzH/ח7wWZ75w>˺p&/(a~]o/,7zB;;n?zI҆ xtUxL`yM }Z֣*X65it̛N?li=<(G1G9IVV+;%m6~<It t,RY!]; >*چF'&FN3D7@2-mv)b?eQuhRQ YR_BٻÇ2fD7{)W;D00`TsC@n endstream endobj 424 0 obj << /Length 1095 /Filter /FlateDecode >> stream xڵW[o6~dëD ŀ5SEl9ٯߡ(*- @HIG{K{.gxx##/ 0zĻ1Q,n- %)1"#\YђkaUś*;CROr+`H 8x 0柿\_L}dv<'E"e>].hTWŔqr}aOz;!xu|NumzYo5G{n:ڏOi. XeSmPZF:n-Wrñu1r7O%6_st7zEdž3L48i3SySY7ۿs6&"* ijqS\ɴ*u,T•]j[m^fj橕Y7{uE\YGO?yكadnB=()E ]'oG 1F4+HԹj?+?3&:.K.ѽ)gpa-2~r\(:_n cctQȉӵk gq9Uo>!G!iIa ^)pNE870ljvz;?$bCǾ=CԆ'F@7R[Fl23]bq _Vyc=8z_[ڀp>uQ}ytIl8ՁW\B@ґPÏN ^`(&7 9bWsbwۭpd endstream endobj 436 0 obj << /Length 1482 /Filter /FlateDecode >> stream xڭX[o6~K1Y&J(aMK-EȴU\QNC9lCHws(QzrAҘr(BŁ#) cH V8Ar8]s;Gfn8 7*=~|~IX$Xqf~,zlQNr < U kTՔ$Ev~9jMq?yu-wJ۱,WvpMVYU9Bjm*ƃoU4͖ɪR+UUY7cWn_!*bֻ#wPK"uOψc8B)OOnRo# ѷ͸?7{}aObDDf?G D$kW1`Wϓin_0/A__"16I0cv妃VlrEV=v jg/όCM!>ﶪ٪ʚ&| 넕J iD)"ܩ;Q[y}Ea)0iCO5fjr~KA2؀##M>'Lz`}nE&lI-3%] ̓1B8?( Ðܙa1K&3"<Ŧ {p6=R+Yiu'0Gr#@ gDoCAm/7- >L 1u(ox=^<MB6\ ݎ(\nmwcǎOO("nZy\#BJ{EM K?.*t *Ug]ՂflMh_vju߱q藞дjL%fT2dau( M ߽5DS8u`OHhL=H e(hDmmpyJ@z5 P_S ` غivVjMGСΩx*&AT537ʼng'ǩ_|ir:.AoS6ϵ۩[SB =*=ac_2hdM-;Y pc]{K^fcҘ|0doB'YB D 65K]P1f(a+_Cm[nYtfb2 V 'mz +:UJ6n ʴ2 ue 3̺+\mςz~—~*Nɤ_镌mČwy!᷊ ,s_6`EYDWnTOԠfW?G endstream endobj 451 0 obj << /Length 1021 /Filter /FlateDecode >> stream xVMo8W"D}[&Y`-vcѶYJtߡHѢ8a4f83o{k{L>.&!RF4+`0#Poyw9a3Qՙ?/ogbNliT&]OcMvW1|yyKqY$A1NYg~u+r3< k:+'̜io\n4Rԍ )A) 'Q4n?r+UVOg J{=g#DbmN+}. -ZLX3K.!7Z}]NzhJ]^ #,Poc/ {jU^Har}"/fj rX09F: K҄t-L/3-4U-ʪv&Y u}CmRNhȐZ4:ɼ*{d`=Bϲ.5f8EF4Ї}mZ$/Ge+v0BQy:6KK ?yfעִPm2<ƦB{ W-/(JAϩ9]\R[3hvz},r.S&%q-V /N$Sj8|IRFGY^l)`NE6uQLmDVRiA5<9'LRʧ0Hр(J]~t WFY@P\~+@ޖ!먾#0K#ntbm' Zz 1sf8ҋm#Jot(Tc%p=ͺڗI2_)!OWܽiٕ4JBHܬ5^46PlKnn5Թq|AfNM_t]\ykXAh nRot endstream endobj 468 0 obj << /Length 2004 /Filter /FlateDecode >> stream xڵXێ}߯ id<ȉd9!p9396_pH.w6k#X,nvTթ!7n}+tLs"F)RGD чͯ}+dH(`'u{lM? n77 4b :KtWa`n=E1H*y˧U &T%/p}IۍTqY7[hg;ݣ3|nv`޿jIx(΃jŃZ*^hs_6LL-jaTQg3䨄h%Zm݁i H) 5`ˋa}GBsϽCm]ӆzE_n&r _U[oַTI'.?U /24!`EiL\㿸Ǐ߽{n8ij0 ϨG] eD/Ƙfo[}-?_w+a#@ ~h,33%% =h9,"}P>8E0",#)Y]K^M獛W8 \)4%,2w 8y`NDu 4V!h&ͰsHXR]Y: |7z g7F:<}OU@,xE=aDO:":"9Y|/tgSu[e[QL!4g#XZ ` O(m'Drj8 i4Me.k r4u-_R8N){>0"1r,t z^4r=S{;]qGY_ c )K0-|GbۀϪ9VH:w9. =Js>˩8|.S!:%8v+*}NS5$> stream xڝWIo8W I- AN6N/"%%FKɵ_GRrXHQo'V;G |(!4 ])Pɣ퓌O~sG( W0_H h!:3,8_gOwOYt04L}BޯAN)0pJ b=V?'OQ~ӧ.58xRbzl Oe3̿>ܞ2~_q[ף8ks+8_ZʔKq-Eоx6r?٬eY y,f͒+;EmJ (6K;)M^T|Kub]Tf}Z wAx7~@5nZ8K_j%Vss3,dk_5ӆj lduqtwfԵ4(aXQT;+xg͸@'iDm}9~(&s1\?J%hn&͑Gn2t?r p0,v&vLg2?M('SGNܙňb}!*b]p^B 4! 4ޑt]U≷z1E$֙ڠqU/QKPu͈gui֕0y[lO6bfov?&e1>ES (fn&&{+*s`Ul 7LY;7YfΖ"QAj$ q'ϴ)[HUb ۅQIu<5<+KwkWH] ʆI r)UX`ԑ IQ`]VXdr{p ۯGiXCbIÌ؝>CV. ƥ DV].,d4A7$!|qA=檀4[Hf{umpm)V`~%3FN(qVYg߽YP7Zui\?D x endstream endobj 495 0 obj << /Length 1245 /Filter /FlateDecode >> stream xڥVn6}W؇!{b""@[M[Buq%j;á$Q- #^fg̐;;.~Y/.oIXY9ЉBO:ٕo78>#z̞KjШ-JBF-+0fԬd>2 Y-W2ncIF5LԺU!\:+O|#&|ዔyp uCMlK~4G!lۺ, 8N]@MK$"`x), %Q<\,|+F]yg.-_Qp~KVi]a㿱 u@)p s^K[ g[.^xPՂ02;Nep(-s`·z;zݫ^j>Ӝ&',-@Z0.}Ǐ3F(~[xB6O'N *jލJ5" Y`*[ch>ց]]Ǎڞc@$ZFLb½&EJd}RNYV=~Lihuo5B4 Dj1ΐ(mRdJ4 =R(5|_l :_F󽤏X>!N]vsAy`2SLƦM5B. -zkXi"dBU eWw?yOO˘Ȉ{tj}K܋*K)b|͵gN1)6kcտnNtk1"Bov!QiۅG\?1Ac-#boq4 xޒL%ACW [ N},rlY\t6ToD66-%ծ7ŕ> stream x_lg $\ڌẍe %y#DDI؅Jɬ 1 ,u(p! ,qH+A,ݰk۝rC{ m9{?s~О `_|1RH RH R 5R 5R 5H 5H 5RH 5RH 5RH RHҥK۷o;~Qwƍ &$KVXfݺukƍ'OI!5 5vڴi9H HhٱcGj^ƌ#5 5ڵkƍϯܵk˗/_.5 57GHM?tَ 6̜90;w,--1cFAAUn޼ᴴl3\sݻN:5|o߾HЖ,Yŋg͚vĉO:U]]=]8 g۶mɯ-L9sٳ^NjҚ4iRI~~~ǐB{[j› j… \jf8 {rر;y^GmL{{)S+K.[jƎx2Ç[.///aӦM.pСC\~=^YYX,++[jBaXR7j.pLܹs.\H5Y&^SSX,))aj;xOx QL’Ij/^|⸥fѢE'5.5R3tjV^65'NpW:p@= =gΜqK 괩iiiqWjmmMȑ#='OtKHHR֖vѣGFjFjFjFjFj=5/K1}SכFjFj֭[sQjFjFjFѲe_듋Ob9|r6VO|W\۷ow CG3@bDFR#5R 5R 5H 5H 5H 5H 5H 5RH 5RH 5RH 5RH 5]V c%S>7Ƿޫ7  5H 5H 5H 5H 5RH 5RH 5RH 5RH 5RH RK.m߾Ruƍ &$.+VHMNѭ[6n8yRɓS[[;mڴAb d;v^Dcƌ dk׮7.??r׮]/_^|dd 봷&(5Y1vR9x={cÆ %%%3gά8}t!Ν;KKKg̘QPPjժ7od8--- Wܹ{p8SN ۷GgFjdɒ/^ٙ$'kkkcכ{]Ð1IM&O&[$Fmdz[@j@jFj@j@j@j@j@j@j@j@j@j@j@j@j@j˟/?Zjۿu&5`œ3]8<׿_36٨6h7?H u<=3 k oAI Ɋ86w7˳h^35iM4)$??„ ={'5<&}A/D*beܾL=38vXggyRONyyy)S$V.]ddL$_tpqN͡CbYYYRql_8cHs&/\<3k֬I$KJJⓚLc|Og\OSSUU\xg&'d;_ gfỉ'b~Wɓqlᮦ鞻GrsjӞdd,߫HpF TxuWጎޠ|ny(gFj\M@קt龟.4*5Rj2~?磰o1'J?%5Rj2yeKTKmHp޻7֝V|ONϏIpF?n]~V5UFW<EKظ4Y s>ȒWጲG7-[~~ϖhgq5΃9F%ѐ7mz37>YlY_}{ggg^^^b&+&dlCܻ}sbCݟdd@j@j@j@j@j@j@j@j@@j@j@j@j@j@j˟/?ZjۿuƆ`œ3]8<׿_36٨6h7? 5u<=3 k oA!5UņW=cm۶1gΜAfϞ}X&'~(,}#< ʱ TG2pl3c&̟?֭KnشiSH33>ݴlI=[j=+uAI83پDC޴I3_pA'+WHMM7P;nT%s@j@j@j@j@j@j@j@jl?Fš endstream endobj 504 0 obj << /Length 1016 /Filter /FlateDecode >> stream xڵWM6W\~h)( urI@i[d{;EKw{H&g <`)$AAEXcBD#hXfOe;/ 1AQ .v-l?QİWjLmH7GMR6NKci[YƨenJj6fymTFDsQNKUeYm/Ѹ,^;k?pri] }p/@ x8 ! +'` ?$Ē88e`A.&t8_5=Abx(Hgzt C(EIL;Mu1v2kjV@I[HSqA{dukjwk1:"9DSjf'<-̻,m oP~\ij (B#,;&|`&m+άemƇD0;ma(D>ńW!u{dm1O6e/hB#I*Ì?e :@ګ;c)TvLM}"Ob4!&qIr:C*pT MU]O~?9rV[Kmo>^b$@+~g[|Ts>EoTu0' ??:ͱfeY`Nۦ**Pwz;}hgKy֤Z˷æ*$ ʞxٟ3f Ս*I/Oy¾zY+m _¨!w_7/#YɟwQwn\}x9@-EȉxL]!kiz5'PObefI&^杆Kכ P`=Bl˕ܬW'n|>?H/oUžڇjuFZڝ)}+\+|*>Ӹ~yog&'#\OO endstream endobj 407 0 obj << /Type /ObjStm /N 100 /First 874 /Length 1667 /Filter /FlateDecode >> stream xYn[7+l79/  ТEZ# ǖ[Zv{Zqe[HH.9:;sAZ $HU0O2e<`T|*AkS!d V|^Bg lXf̉Ccbd>!SUCfnɕC,jO_uîB,TC6W c/*X |a&/H;5n@9%%'lŰ 6ADR ųbaɁ%!. 3aZ*%ءKCi00kbᆭr-fGpj2X3QixKT %x%;|">hvlH$78_̝ _˝!Rqa 9S $k)p,U #%uU)\$qbP]bA3> V KTEG;.ۅKʠSOKvu%WN%]ZGذg+`{v`%ɮA R0s6 XW}c3 d {a)2Hdž]=y2wƻGƯk 8D8A ȇP&Xol~zrՋ0~3xzt~ϱdv@k{p"y<9< 6ȱw KΗ+Uh0i:k4~6?; ;w/0qݘ%b!<5+t0afgq0K5O~WimK)FrىE$*WXL}092,}`; Y>zz(~d\Bf(m t-xZ6x!0] 4Vb3]2ؕJj(-i΋|.gn)qb u` #SUV vNiHYLʱ{TiXd!X6[ DQV_cKGvg4ƽC(ϣ!{Cr`V,%ʺʹ^ #`SA1l}`t fH}`6:WRW>0NduްozוuW^PCu`%E,-N0 gX#[H4&oXH -[N'-|mI5u à  QkTm'kJq83Po2G~  lq:9O'G[Y_Pѯe4jPR>%gwt#L-Nu8\b5/~#XuG )ԟ.Xt8$:O+f(ZtC>Ndo<&VuUU!1V=[$6NpZ'X%fi >{m؏ʥûϵ*ZTjj-i7h$FÏrrD<ĸ{*G*mqu.0l`$ڑ-V7ސmy")6` RAJÇ&|+ɛ/t;/?h˄ x~14ݺDR͖:]pr, ~> k+ ry 綒4= endstream endobj 516 0 obj << /Length 1308 /Filter /FlateDecode >> stream xڵXMo8W ,%& Am^"Pd’\n,يͶR?޼y3MO\3($|2$F`>4~{sIo$"$u1ߧD:ڎ`|mb 1%4|||'<3oNJ6$`D bMY.>M;nkm3*pwHu5L* sN#NO]U5YY 3#r/X`%έD1gtbٔ 2I60>R)=AqP `jW3fJHS;j];,Vy3NhX+ ]5rvɊ<ό0.AJxvJ'2I\#”{.ͳ@~PC讝 $7!1麛v}VKyljf@cdԪ:YQ_Y[` \ރ5f o)j닦y氽HKLDGG⥤ c"=<9p~*n!sJ/n/ʫ}o7~~JaAɻx#MTu?@VB=ŵNy2zd3aLBk:r~듃u=Q?""bE, NӃjLfW?t&DBE6$N[s+!X ̀8j?^/eGM˼?tU-bHn7FCE)}X~CVk1,,8,fqO˪]vUH@qǀמSr UyJ/uN(^BW&k wFWEu w[4Qg+Y֌@q*1Rʺ&2_A%JyXl.l+Tģk?a37MhN-Vvkf{ cH?#q"1;יm)$TՍz:l1YNo$J`UՕ9اF%v^f mku[p[ug$tZ* ։u[;J" Fޥez$ YDY-tzwwdp&m@)_z%8#s~9z77j\t2,K/A;E endstream endobj 534 0 obj << /Length 2013 /Filter /FlateDecode >> stream xڥX[o6~ϯl,aER}ȰPt@uiQեw/Yv A@";7:YōK! }/n7 8B8[&2Z՗?_ppu(TY[.s{+&pMVYn\M=:=_06ѐ8Մ.WWs)CO€Y?( ^SVtZZCaM < Ԟw3ZBMS~FA'rsĪ<1nf8 E ᲹZܠq6kʶEEū=*O ^N8Kު)·L?ʍer K.(425Wȡ\8u4И%!u}oyEԤ++l/[}m8-l920031 p OtjJM~SVHߊyij!OktEDYͽ5NrO|aQWtdNXD@w*t[LdSo5|Eq⬭fe@jTALkiWi"< j=)8 O*+sC4w'Aq"ƈK;#jyB.HBt֜UE:|el1C$,&J0$+;|c)~Mee/2URzP)2k~ 1.nc"xHPT=bq7w a3W~\3QX+V{k!CduT3Yԡ_3X9֐ݨ-x\dRթ2fIݢlX"*yB9n0h j04+S&Myi2g+oc^H`k $e f7v1+mYDO׸8a@*V\xޅ>O LH8(0#qv4Osӥ..;HzݽA}5P Xf(b=^4Gq JqF$jM.y!ؾ7֫Ws'&~w~bo8&8iH8,#>[

>CR%<<>"3u@h*)1MB)ǂ u9ɑ@*H26aFeimxFY5- G(u}x=6ʷ_\e ПϳXNG΁^堭 c`g |{'(ErA`Ѝ14[⻹,HMT6s  >;\Gt\x%{.1 \i5dZy#BAXy]|^?DFjTY@ @=(N01oH7ߣΨbT/όԱ56T! Vfȵ=:quVV4S x}{޸ endstream endobj 547 0 obj << /Length 1371 /Filter /FlateDecode >> stream xڵX[o6~=@͒HI{밤X,3VYrD* ;H6m E#w`۫8]@0FQ̃c"\//a7^d3 hr ÔP]]wBOry= q@ (C,b=rl~`+KGúbBPG@Wo_^8XqΝ`Tb$EYJz>e8HQMkV4fam>18yo ht9U|^ \auBRyefܩM)珦dxp)MkUxܐr "9ec9ǿzA^|}Jvв\ 8W/ll/2L ķ-@yc!uvZ>9үvVaWyPP4{P3o"P{;B߁庄627!v@7 L WCs&Ni3BÃ"&{jL  5)4c:ޘ8O! G;3'|8;~-h[?O$`C̞r2>~ endstream endobj 564 0 obj << /Length 1433 /Filter /FlateDecode >> stream xڭWێ6}W )QyؠI]ӗ$rm#J;PȻp8s8<3 x^/g/FH[n<$b/C-GEby˷aEu(2ܥ54\kpRHtbK]c6 }Ȧi#ۮ;Xzr^LӒLQv-'9*uʚTucϳxf-EڹS_T]a@6ct߅D#2 nI?yj9bN/9%գtS(M {< jj-t|&wVT0oX/k>b8I}\z5=C+a.UE/cgo/3jޖ ^!ު}xk!!\ݯF"|IȘ= , a<`GDE EnV->ܷr& z `݉ )-1 /4zWժ:وf:t{םP: oj]x8!l\PGqwjQPOA~ wp2" ^ɘruk%bxA/fWڦNvz<=V>7=@'F!;tv endstream endobj 576 0 obj << /Length 380 /Filter /FlateDecode >> stream xڍRn +Dl-J=[= Y$;TӴ-3%@4BM0Zjn0$ T(I&/4-}"@13i.|sv=̈́~WR^Љ9^[_ka9ֹ`\* mY_Q'6|rTD^g4;LÄeǴkvb#.7^U{bZQx,Z}C)Cٕ]uphF\k%0JJc+bLcsrǬrwd&81:x8G|PrW|h֯-EaL/^( endstream endobj 666 0 obj << /Length 1577 /Filter /FlateDecode >> stream x[Ko6W@K$s,]"t"ԑINYc4.A`#o3߼0xMx͇!!CDYDV߲'?|$$PHE$ n Ջal fH1Kk~j$޵ǧbבvHqٞf֣+|q􇏰pq%P'ZsXhmP^+XR)m功} u_bk&.S4K-LS` :vam~lXse` SD18+eNl wp'v7:36ɰWP;(IV䍋(&ENq;zq*q'AdBzIՃT(_q,¿X(==a4pKJГU_wYم~D^.@^ǻMu$[g !{u!80ojʨè:FĒHR88Rc %;J4e*jD<\tB7o*mKLuAR@R}JϻxRI8R/FSO4C3l:ƘBegz PC}u*M+qQq>3g45oC=I[fEi [ 'uoR"IM'x R?m7~_uY_(BޘKۆE}Gaט,L (̋.OG-o{o zbT eOoha#<^i{!wM >xq#+i݂vW/Z( F0 mN|k@'b endstream endobj 512 0 obj << /Type /ObjStm /N 100 /First 879 /Length 2141 /Filter /FlateDecode >> stream xZ]o\ }_E#R"%Z`a[#3ughw}iױ=ur>$ҽ{DQ!%YJO%I K'*?rϒxt~5xX0LQU.ſnw@/]L*ŷ3d^ ^-.ǿ\܉cAi @)}&26Vչ4Pδy*de3#H9U35.15ޭ9I5zn4j ]ֈ.nNt^B0G yyq*Ha3^ D;8y\㳩 em"'$w}JrOXe3X`pC,6OF:xYu,W7W!}%!~ ;.Op~~r_g΅k3;Tm_I#rahf-ZVюhcggggggggggx~:yRmE+j=mQQQ!RE(^'iMW^ x-Z\&xQ:h x-$$$$$$$$$$"Yk$k%m~i!A> stream xڭVn0+xLz4C%0Xlh>T%ES-`X.w 6NIdH*QDJb _1!\qD2A cq|rKp \Q/ kl]YZnTܹj(!L?Mπ8> stream x]W2ѨJfa?pH"{&bͿS==]ҧoQόv}UJI2G3* 2JET~xL$2I1GZ=IH2]ZdTmrQ$Mɵb'=vJn1ҙtV{T͘֍jEZk9LJɴƜ\dJMugOYc51瘥&NWw3ZFj>۶pG"m:7 Ż޸cq<$=4Zm^sC u?XGX;*׻;:}XGLZfx`4 ;Gv؅#vNLS:Yæ0bH1?%MÅ9yc R޲g`wxu Wg'j-~ Y5]0xˆYK%wt,zl2?BVb{X }JWW ҡ] TgD*f k!Kdp+-%OBTECK"b$=DՂj!PqQHs+4d' ~6͍ IFmFmY 6B@Դ<|tGu"QT=DPw %v6֨aڳF Q)´~oU}; 3ɵ#i*̲\cgqb` Zck,1&?]։yj% gT:&T1VkBEeujb #"Xc+l "Y4oɶ=ڨȜ " b=-*ZhCgAFOVkuI[96Lbf;[g캦u- BJXt q&efzmRvݿQ'[֥QD({jڜ:o6xn9M)bXTF>A"ffu6›2HlgbWsrW-dۃ2*yʈca@DiK~&Z:- ;e K7 9.0vں%AQk7aB5#$q!KJ+YJ뤚 KG7-' Ҭ![}m̀Ȏ.حھIhƷ׿=Ѡa*yrƞ㏯?5WJY&{ `L~~a|5/=Pj.x7{_ݻ!?sa/_uKZDڠ4%#yDl^/Jq&! őxy_F2:c[G_Ǿ>oqyzbx쌓 8*Ճ,ڊE+ƳbFx=wF;8^0eA;\ +LsR= a/R<1ܛ۪,ή=s,zޚa5HHoA⚹Y;'j',%XNQy6ّf6[٧|yk;fiX{7 kq OMPM5r8 1%F9sd> stream xڜvt]njf'm۶4ƶmƍIw9;25񬉵)2PƉ iclkhkedaB4s2tYIIU,<ֆo}aH"b2sN.f.F#ۿm@+T܉ '˜dF f(ڙd.@PZ88:Z 06322QAԬ@Og`deoV֎p6v48SCMh48ۘʒ2SP]VAq J;W@t22(̝ٙZs4:SR,jc"lkm qrgdX;f6\82LaYC' 76#_TXV%@%$!"ItBBnO-#;; SC"Po&vހ_WQJ C02~6=ll?:Z{Gh/_&t:8!qNA/le.sWg_Z[Xo6 TEsgJ:X ژY-pp(X8L Um`h+[[1 &6f&V6;<hXY '7  dsveBlz߈@/qE~#N߈@/1%#OS7@>F ^7EPX*hG(okF#N߈t:[*ee[Ktpm rk)1 h ƌ-Nd[ #VPlc[+P7M02k7dm)[.AEGP_ΠAmJo]S ?|Zu3HGкٯOw;ehHf1Jol,XTZˆw(V/H(ѯJ& i##hvA1 6(6qfQ:N?T%]PPb#Hb{㿐3_߾Y~ mA ?QFЖe.z9Dt7{GdO@ qrwbp4u3ҺAYwc@N@PE<~sy:G$NzcS al> M2dYTKS=K1GZРɔW)rM~ă ec"vā.T5Qð`:0wZie~k;mҮ7ι:>Hs˖ TBVL&sw)4  Z{*YZΞ|/X'dskh'#%eElQMWh,,\#yN"C,r2+ޮ1րEj8`&WWELr&M)BVu%R%G|svXx,!XkKx3Z]}]N΄*?Z.|v!%kMCr:e9Ϥ vU.Ř^(V&ƪ]&6Ϝê_|a$r9ٻ3YkAwHrmdw>uBlAQ9.PFƪ|S]el.MUzL,ϢHɔToCfm v C//($$gPQm`fz )>P=˛OV9{Sg]4d4gKmDbSoNH'7wQbKQ>rgʿʼnIx/ 4&=4ҥM+Pb'I%/dh<צ`Ja-`|]wZ @fVj]mor 9!hٝ>bmoiD I^ũmf8dXʁ6A&]z\\ʑA}_k /ۼ0,[]VddTv©aWǗ ܜvV HU85e^Րw G.ݜ+*f3%~1d}`.%XlO} 4b803emؚn=X0EϿ aP>a ASˎlnb6]nZε-wa7Q`I~hSp*w ^\6c{0 |xçi5ocq mI*.e]{B…wS`L&Hv8t۹Ç2l[ ?1 +)ֆ]H7oPz0FLY#ɟy1§L]v6Dڵ\{`FAQ;4E84дU:DAityO\7?+x^G8 }{^v<=:޷m^^V`X OQ(RF. =mD%X:5,M#.nkӥ.QIF?&j{Nox[gFFl'ClRܻx|+>;cҠr}z(wSa6<nz郰P>T # v[v1i* /&_LP(q?MfUAu_4L:mb~ŪȘf=,E 3$pe'˜X5o,j K疜f\|NA@!j}SR9?NDNH$fuQ_ҡLy5B݇G$vǁH +*lL\twYli%Wa$o;⏃M~Vj:)ίi7r26MJ:ᬜ}n5T6r6^Ni:>~+bHGrSk~W*vLOGA;d!Ui5 QJ=;"i˭0pǑQPTeYcZ݁V9 XyĆ>aJoV?.U-ERD֪Kʝd2^bsJsPc0]>KFoj5cKyD8ʺ&%7Xf_=:մXQ\£|Jvv^>`ֺWn+/[ |fi3>TH JNaivݝ_y~>!"ILuAOKZC>\xvb\ў=4OvLƷdT?j4l^_n]a=dLdKJ̹ >iukQl[v'@U^o϶1؍0O7t1愄?߮ap}{қN*Ct,BfW!3#'Byޚ ->ӱiO6􈪋ThC?B/Z8vN:wxM$q-mk_0 12a$J\ϭ)hQ4۱J%fîcUyJڏpMkY$F f AeOB&$ҺjoaC=lyfք`/|^-`j[A #~_I*&{&h'(嵨 JK=!za_uVU ıY%-O ;݂cO}G 7:iYK_ UDX A꽞^&a؞Y&4>:<|8ցi%gԋmbn[ ˲C!v_ړzsllUQ*4t]| =#UZVigD_/]=M$k'K֑ˏ*AU?0by0p&"gŗdS[UH9XbY{ϥ-Y?cq&0#wI'2h4Ē7>488T";o>el46jg\2S6%(9}26ϞŇON5= O{/XEUirT'0т1~YʸƬ@ҵd ׆,bƇ ,O/`9UڄGa/{z(U6 5$X=#I:X)xu,eu%M=f^T,VQ)j9Da+ '^,9]EfEd.#h=}0ikPg6> ٹ X!Y݋'"c%큰apkc$^@[Rj>ev+ZpWwAQV?\&X;ߥ`ֻ:SVN3^#սTţlt>O `A孑}+51Js.AFB=,j TqÄ25% xyuaszcd  iHt4 dU+C#%N60՝ݍbǶ8 q^Ъè܌ewCfre/ =?Wb#M$|%gp pًj=rۍLg$S0sF[+R^TSJpѦ]ZqDLF>{0rhrd@g EmLǔ> ORH .e%;碪Ichw1ˁd4 3v,v{xHɾ_̰#dbB0h-$iX R1 tzq>10ZqjmѵuP*_O=Rd7#*xbx^N':sOuD->(LD9, ,afwg\0(2Ļ}oif;5W=oJFE*] }Ł?SNR4( Hc$D.Wzk* vvQ=GcX1[5BQsz0V'cF| ꆧ<K٠e6ut0uX4S՗)3 F ] + L^%H,JŷQqS%( Nu(kT`4I g"?5J}KuHk /Au0UQ {mB >n6a ,RzXϷ2 ДAGo %NZS6Y ʼ0sˉQř VS=Q(45Vٵ΂d8I*\w8%t aŒJ*B>>8a_/k(-HgR؂]pq^>5+KD.#ֱFna KrAJ m}x~F^uSIVt}D7 4(zžr˵FR *R||u&N)>V ,GЀly\/&vNdtzD 7Ic4= 9GT69tS0Dݖl'㷇Ųc!sýe>.c\3F>CL}3QAn*e<2G:&b}6 3BcuW1s2rr>p}6G`/dWcV9M +%;V.](zmRD=,ߣ৻n`uCۃ\Mϭ  !c}Cճea\aaFnrƩOWփBCN0=)Q| vh/<#c'q94T6]wCUz/TKÝ/jpP /bvݝ K̉UtiR`CBLa}ѝucb.W.ᧆ"9A z |&N}ÆGp΃>mۄR~uh$DնQWD;CS)Kn,'gOgPfsIiM4y:Mm ٍ&&?٥zrʆ<`QVJǔU7,1XK}Z]<˙xT*{k9e}ui$;Z deH1D ;_2VAVrHpO$P7ue3!c|H|~g_kɿ'DKS!&B\ujۙd{KԶOZ56!X]п 51\}NqjNT2װxʶ8L[z0 PF(4yח`ls7QbJ^-R8`z'!ф秨dߗO)z1įHv u%@(= D3%7>8%2k#r5N +& L=L՝rlCfZ\sD~Qۥ lmcZk@J<k/7ύNC\sy==GqxϺ ?)_y[|ySFo3K՘';&3{b܀N}{H!a ˝/=x [5[t1گd%x.&@ *\q8G-ٓnjySxF[T7 ͙JY 7\ȆQQTB˴)h&7|=Ayj:: q -ޗi*Y*TD>BPs-[\b'J9d-a.>tl)?%u`Sdp<M1_sC4nL ̫C)#.5%64IS2\g_da wβT]T,Ö^..P ;O5M̚B,nICD*&H {ZJPٗg"%U;%,I"{,\ I+0ɱ]Asgt|xnϏ&vwZ'-5j"|RTë Xa;[ f.Lxv:n*CJHfk;C89RYE# J>T;c&rJ2VXI0zsE3Ph(4DVQ|+e(.4-q>nS#c gg28wGtLHxn&9HR3Q]iJR)Gm] 0vo8aLCXv+$0“3=#{aOo?KP.w%aGةMڬ.v"\Ш9~w<$L^tNVlJuH(5y>cu~G8KX=ԉu/"S2*A)eRvx'dBbG͐ء:CXq>Z3"48i EVȺMRndDȚ|'o:!rT!:}-!"΢%05C ^zI4yYQ[c'Q@!>f‚yp*1-<(|pyN--8St+&ٷttl+9' osJ +% 6|.(ra6 -vi;8Kͦ| XYl((tPS&3Ioɘ:v*PGhmWISlIO_!-yX߈cAܰDtjsH5 YYrPi0L#f3;/QzX ,T+ޠ{`^Oy2xγ'dȢ3\s%]/sw~,h͒FהHj嘚nRi:cz&!f"㣒=c`G 웞1\f6g9ʩi.$ ?mQ'xkkN?Ivmr:U5 e1Ȅ:EU|wWc웓߸-peU˼2Wdig&N'P#̧1kH{u~@#ENv܌Go~wv< hPU8L4Y&JyTz;<ͱS]z wC~XH j-\5@NL\ÉJf Z8Jŧ}@ (%o^.t}b ;+>2]*P&PMev~ق3ܑDOIAI^D_/A(rQcrÎ;sGˇfۡ9JGzSOoh(|ߨ_xvMn~%.B]w7Af`A%Kh}wy=p/XW\ƊN(cCgCejO.31 \W77O)(Gp]pVTkc1XVB%,?wܵ.j7~oUyj$ &TTfצI7nj;Z[S8 1nRV=9J*[*.& 鍌iB',&J)䟒>%{nw tDbgF$ۄE+D8]7:x$s;)$v}F^QV]6yjyP:0V[*@gt`z_>ܬ 01˳;EHcT}+KUC߯y&_:e*IIU#w @ }/e7021 SMJ84{N`ɡ{{wst–]GFKPF2i yɧ$ Z4<|'-=#{Li UySPRiZ( kb . ;1=CեVyW֒hƉD?V1s 9[T; S l넑+c5Q;xɰCOfDz-!,l~&`,(u_; 3]>mwlGc˴-L{PV}]v{hdnxЙx~VVZSPti.k7fMU2%"Vݭ90<NK PjyY(1DEa{][X=ӱ.V.UȝAϥ@zpTw7E|$3;w0b xiG8wq2?xl}ij*,\ѫd;Vymg4. &ӳcC&ֳ٬WidBvop5Uj"BLWeʳagyNdD~K@'|Qj΅P=WcGmV4:C14TXַ), L;X5\k6Li"*w'sHȯYq}N CW6Ǜj'<N6'bРMDf䊜uWGrJϔLlXLt$Ad_-Ă{e5ݦvrGHl"zA-W턿(J<Fvc8$xrl2](~[h;$-w9XlƁ1u[kKKDy]:mN$' U r}S7B+ð<L~N)ÌM2 } ejO'P|5)wsU8X7jВ&91uy*\]=b=E8ܛX%9NxGlt믣9$SN?n{Q=Ct L?lk}!߼]Fo m …Kid+e!3=?>'H1S3cZgX /hoQT]cEb.4{*6iHr6z>ܬ!$6B8x# #4,DqbdǾxFGL%5t㣩ԣ􀩭[18nA 𖔃jD1Q} c)C^UFm|mgҭ%ʙq]p1݇2xlb1 śeD/Ȭ)2K>CXIR 6~\DW8 s|Y twl5XH71/&`N5~#.1_~K@/Rs/]/~;,Q:MJ0` 9G OxCї3Bԗ<] E0j-43᷌n}Lv]s~Y1`w>8"&'&ĻvM|}4']/'usU^ƾj9s{&))`g\4`%~R_de ^gƊg#gC]NBÄNObMDN1u66ߑtNTNOߍ=R~g\i::[d 9,~o}Іz !r@f* +zy bY%&WTiAam\&~:0B9ad!PU'ʕDk܋jN`tfϗ纬j4N-Wε]Jerz[ڳ3 i> EfɕNQV.MN kb&oP#2#QOlO! iߞ^!^3# d?e\Z͛ח+ʞ0RNE>HG_{UcrIOvЗO1*>4w>֍%wiX6!E]}|*(9}:VTڥaZ,U.9ynLC |^LyiB{ ,|=Li ,BumީU03¥VFsψ@72vAQ9kEG.F[Sܩ?|4i'n1.ub$|,$*#8;n&϶n+`IdžMwQ]`g4NQmNBKg)hYXܜ\m>&Y͌Y r0Ϝ;u}0LxpyU͝d0̓pVVWwAAtm@{-{tnx95*[59>oAHd%[Q1p bbs !!:{'I14.cp,@PT]n15")qX Wm,UeTca'g_~ Nϼ"OMgt7|WD3GB5'-Qd&Ȓ\Y2ٕ^BtF£ eSߥ?y|(EØ($o%zeIh~-8B R-[V&9>ܧrF+e8 ==Wz̀gx*rv`iX?,D2#5M57i8C1Ɂ͂DJ=J쌖x21XzpH: EŬ*g?7E VC0u(*frE&ia嘻E6/4F=imkl|p]MSآrdu4"!NPQdk#b#E T!UJRB+Řz+, ?e*͓]i]DZ\1 H.X9c~,BU~X9@Y`{U{eV2x||; I3Fp\SAp)E92Bʓ~iō {Fɺ0y\ܔLח#W+%q^ ,0#iԶEZ3?GƺeL*_0<|gYؗ/~$ z6^FW+O,snҞv3]Ŗخ%O 8Clc:I&-C1>M2IuEcr"x!^?ni4kDIF( L8\ CJ$wk{Y%3&hJڡBAbk_ukl֢$x۰&!IM-Sd?𨭈˱S9HL]{d9%B"'lNU?Ux'w 俪,*Y젹m $Do.`}V@#b3h<- QM6fN1O#Z 8X$7pD94>s]ͼU6*2ԉ<x2B̈́,=!YJ߽ P ~*[CDyw,@f~l2/e^Y+(tA[tx+W3bq&H32}6u񑱐o1SEl"@#x Hp*x;,7H::W;#ܚW_4лz-bR;1J;n8k1z?KddWzY]Y܇SIбjOh{Boq d~'l}b/ZOjs{@2bm7|d*r6;5LnzvAB "=b@ۖmũCwMt/d˔RBM-a]|iUX(×pHȴS*q̬f)S{z! dvZvI.ʈu?uz ߦ\,˙E˽j yqLNsUX\Ցku'(8b"i` Do{O kniilV{l4HQoWd -%"BD[ڏ% +NB5V'j\_| FpYضߢG !.} &]|eps͞dS%#exg7Z:#{hWYȚBrmi( T'&:F>FSnvJJ>h'F (w* 5½&L'}l[~41KOEcQխ=+J6(:-y͝ H#Iq}{>pa/R>ԊՍ5&~cibj Sz\†/Mv+.Xg>mDR$&,2P$?ش[wAg ºNezUw?N3ʊ[ZE7On_)xH߅GnP7ef6} z&,2.ofΰƑ(J-E)`KMN@sM,񈘀έaqh)fx55 nؼ ?!ɰRx&a*k37*>!? 67;si)*n)c^EGFt#>߻fQƫGy7pZkO$/FஈܪEb@hUqYoF3LK&Y|"dX/;;m{ f5l}bHpW4݂#)7n7]rQPZH1kIC t|^{."lIo P'芪.Xj ?bIk;ug/7#сޅ2&kˆ3.=|HB0zW~ 13W{yh"  #OBSRZ$i365咭UR45>nvn>$h͹v+!M>cnG.G &!ׇ54~INUݽeLfܓf X65-=WFb>jqHMg'Ir"6,$ 9ӌU-UڿqL̽U9ثƮ*4H'D{{S;$Q xHJXB:bº4"E1ުՙ7Ψ[B9$;̾_P% h-I;rЃ@LbK[" ]!1wc4rkRwFPK.!6J%} ;l `~[)n5`QK?X-Yl ρw샹Ϸ}?#=ۇRTBsXgV*Dκ7;w }3Uqg%\\q 021npCXWVbC,ߢ:'2AhN'AΝH;xu{CWլ#`:wZ= CHN?ȳ %PI$`'r;D*]/Td|@ ($0K'/w^KZ*,!OO] -I v-GG@W|dFrՌ3ٖE.~Z)&AR9~SahG4 6zwF㽸: NεX,2Xm au /9[{#:\?s`3>e]{bGNSg҇91[>xH5!YmI[#`iKƥ#n1ݥy_ŏƺJN D L ilZ:-(N\tJcun!<"^? 4iǫQu64ɫtʡ9݂Ch,7K~(r\)b#ze3Cѣ5(W 2{Dz Fn' M?Ќ-(@B*IhYZHnB>?a>7ʛ,b=;p_ꉯ[ٲmڛB90G}2HgV7hA+w]4BmS[A[}ۨ?Ǒg f7 |^T:;z*ԕp_ k1vs֔z˗q7Ȑidl6$bCCh*?Q/jCaWǫxR}k' fKbPڽR7v\||kṂǎiMiŨuw zuO]ed&ER/AJ~ҸR%SN`ēESv vv=Z貣4!F6(pKr7uBx-uX v% HNaDjYzԋ1ИWĂ#}bcnyE'z8RQh;ȪOvBq @q5oa}MPb!y;v`úKyb/k iU3~cp R@1'RSӣxS+~KP%Qc虇n]qYC%>ʮ؝K"d'Pm.iAY c %}IPwe@ [0qb*hPdR+e{+%9e[5#XA{.m .'Ggr= Nb @YY+۵~]]&8ucO/Y-7H _܋''&jIw9VקXveng߻7x!<+m p%JslيoΡF\%$-Qf&h'jaR"__la=F~*s0}T!e}vA>p'{kAqQgxTyv|67^|d^#8x?(~t="Zv2W7-AԦ"k) J ^D<_QߤY(~s؋ãT*7 7.DE\]#~H(9.+ &o0C!a,I U`99]U(ek/!oe\R݋ ƙ)w J-L$VZ芸.q1ː-ӞTqEAoacu1hne^!ú͇.7ĞQNR$Ivo3H 'F˷8's `!LDWJc)~q燎'8/ 0d=ܰ'&y/X\9)m>:sX)[IZ&!g҂y6 !ؗɐba>SKA΃l4\ԕ"V V$-m0_6O>xgF4w>F-ioq fX*ʶvY ۣo9/Kc>Aسg֤++-m@@J5»R6Đ!4N@՗ gNpR=]G8/)rT nbï1! W^ב)ǾTMOqOU8LAD(cx[?:Ꭼueq6.Hu.䓀T2VMաa?tOEh فU5BCj͘+XηqUSz04KD?DҙF׵'/-6 PEBMJԯVunڸ#gfAFwI@)?nߒ-UdIzw[t_ tt@c°+7Qs\nՆRҡ00=ޢYLМ`bvG`}{q=.^2}*5XFcǟ膞 5Nug c J@d[.{e yPpf^vd:;2X7W;BT1xӠX n=qMf5P>%V!=Ev8y_=(0nST=x2PeMcM`q HO h 0ZÃɜ׬I*3J6f z\޺Asd@ kֻxQK!%JN{u_}h/3@g'm3 :߶ 9_Y 4)&kň~TB7 P)8A@.>/CP1{K\ gp N4L"N7(qa_eĿ/[,Khha:K5L‰ίiAA_fQOaByYNS1=IGG$!v1[㶍%*+e)b05wWvN6p!,U<IQ'# jXqx-P6 IJ3 dy #bAO^BvKl)vV=#v[8N.Y# }Nw^h9W\OM1fRBs{N lC)#i =;x.wyckGkTT5 hotg3Jx%}/)IQ+OIͨezATI֫)Ĉ֩2ËoA+,UhBZ{n+VŹpO:ϣx5 V[ &G=ʽzAil42*gh=4`PlHt}F7Vy4XC^ҳ[ЌXڸ(\#S C{9OQZo #E_|U'\jOM9' ]2K;#MgXi3[A!̠2@U  r\cyy8 cx\ɹn0w`R;l-Nyj0+ŀUd7ҹ`a|-ĢxR}|ud &:9 bt4t Ǩzg"~Pء:MRe{ MW pL[hbORw*|2[CNߐ׹0Q40{%V{V81l azdGuڢM{erfN{-eöe^Db-eeE.-ؙ#" M[US uj~1hQ lVv sO8eےF; [>X^c&jv/`"ks=巢@d}x^ϹLesuϭZ#o?=Mt'ƭ[N"!K9T0;K Yehv16;1`ΛZg/591g#Dj-$(u)톋&$psTAhʂoewJˡz[;@̟|Z;ёoj^т8oZ#F`W@ ' IU^ش]^,+Œ*@ C)ѓ}4lq:S#?' dB<  2#nYpBH5%7eǕ6 KrY˺JԱu h2>z-Jw*Ұ+G2\?Jr)nSevw *A|7.פSh}pE`uwłopͧx =P$?^{/וrGG +Oy7ek9p9NdlvylQO^J4ĒQYk7gO4ڸ|ȹ{.RF#S"܆Q"|F;gIoHi#R^[wyZЖA CWyܾ6`!7~R$2}%i<,P,ζuw l$ cnuzZ,]#,:W2li|Ljf~՗y;+]2Ӻ7]&;9`b\77`qwG>aGr1ZOIv7<%^o IdԾDvjb 't,bEĶXR?ɀ t'̿U WL;R_DseIbG p?#4E-^Ә#*u7{1Th[PЀU endstream endobj 702 0 obj << /Length1 1144 /Length2 1528 /Length3 0 /Length 2250 /Filter /FlateDecode >> stream xuSyQa"AXHx\dDg"B+1+|&WY#]AĆ#t rt&TA>Z4s:¢gBvP#X4L,SB ]3i̜!>@͝[q?,fδ6Ptw'alPXp+c62@gH4Lx`Ѹp;џb B;E`B !@5|SGa5 V ku^(o>H0fn_T06x)"o1WB;Blľ  îWALd3Ep?5wO-47˝dq\xӽsiiWsYw! 10uL 2)5,fμ87 `px.1"`P @7C0sN0aB0 Q̯4xf.=eςAp+P/AIg'ϐc0nYXm,Zn+t^fD6r)m`9o9L{c" j湥i0=gCT~Ф5EkcϝWFWO;T&#񺓛Qz|%1͏(u#%[҅S.x^Ѡ[ꨂJvU}E*&6޼d(۴dzt̬]ӣ뫻5S^ّX}Dkm60dx0t~zli^Kɚv󶞆{k'֩#%ILf=?x$6wjVurhu(237k<]iu4Mтָ'" ^&?S^PZo#fn=q-ޞ'IS 6Ɖg'v5+:+E-%F#/7삯O$1w_H\W8PAݓҨ@BT9>2hZJ?U7[qf*L&\꺪#oXl-Aih\Fѹw)}ʭDءx5{b 2+: M%w:~uxe[ؤ=j*/ާ z:V]q[e"Y)sa@&YDtd[~Lwp[:eMY1uX|ƹڪ~9qluL,a$+o[{$mr>[4|x~p7>Qi\XZT< 0\8e@<2}llDUޭ\Q=D-)p#1ve9k|U\3)J)}AؾގWuЉ<گ4kli3[}!FW7=81&A[%E R9etI犓%?Hd)g֍{}:drވ>~s@ҞhReQ? {#nq69WxKKԇn7r겜p=*VmI.xu$ #c|?M>ՙe:Y`{Yt2C eͺiۍ{6i8U捞5 K֭^]%+ ڍ#VE\~E"Pk~%lLs+ęyoj UVHF`iͶ8QO 6kKZ$M sSC] ąhv~B1Ja:`:>LcKRa-4&w([nR(UK}5*a㧬'R4>o R:`4V̷(2語rnxjo \s͓T҅ اPPhy`#qRãvEjA fR[SiNuC%eNy՝թsG9޷h{cdE>!Gm,)hi|-M7Q21dՈDZêhEm 쩒\h endstream endobj 704 0 obj << /Length1 1626 /Length2 12284 /Length3 0 /Length 13122 /Filter /FlateDecode >> stream xڭteT.wo!684Ҹ'݂;! 3ܹZ[T=UEM,f6I!,le37Wu2_Y daxs#SSK$, s vru)`7OW+Gۏ;r_;j@5`icH)d2 G ffocP19`?s_sN s779/ `qX!o=6nx[~pxӽSB\]l Bj-,-n-̛qt@@r6N@o\ljhOL-_gV=ooV dAfxiyme׬9Zl[9w7@ d̪ XfoB?r핁ox;2@G۝(:4n :[N|k-l,lڸJx,Tm K[k9Z\mAoR3;ۿ4m"*ſojzb*qPm ^No%= #.09v ?@|+!.6?%9⯱р-&\\{ߪ3y̑WYܡ Ivz*pw@zSuKäK¡| KPʿMw1b6 ^J0!~T7rL膢i#Wj-2"NFUg{hEi P9'kG)!2087+Y~/zۆ`8-IZ6'Hӯ3F^5mn-$ cXʵLL gRnz?#@⿸["9vO;~ܼ2zяJh͎޴A *g,:f1yauJs,VkX?` k?rW›cz0z|ßmHYӛrz$ 0ԸܮRtk8t_K{p@i n!A׳?ɖp><,&=}6,K`6hf ,|AX<:+5[!VݫmljVjbe굮o8Eq [tb>ba%pPXBd&,.w'NLQX ']dQ%G-`| _V9o=ڸb<s 9T^;bHV^Cl)8';p:FLqģ/WUhaFĜ̀h=f}z{%ՉfWn5Q;Z:I-VR :hB*9m]i%y-r?^m^H'.a)"Q̖Jcٟ@+KQ2ߜi-[:<ռLaIr_ ѫeUjNE]8yѡ0~iqMda_ GzRkEq|ѕ.1zi5wupd(|./Մ]ߓ&x͎`۹Agmr?ydZU](Iwmi/*1FU\J*k/$oa Q_"V#u5ܮ&d`Hڹ$e«Xy*\ڲ4*۔w֢5,/z.9zO(=94~|<=lQ2e{(Q:xIi^ ޕj<ګ5)dJxUBfb=-ƒ~Z&ؼff2+Z@F]aaQ.@56F~m^TݛhaE?\P5Nߏ̝= ?;Hbpkg#skmb]BٵQ]3lʉĔg6,!/v2tʄ-.nY1uK| %Jɹf42% ~(m vڎRul D)Y__Y30IBi5'G; Bq`io\QzUf Mns?ƁB!}%"`(B$J30gzvʉ); |8Yx /w MpBR.2{j"}Dm3+wẌn%CV9c~KMd\%Ӊ#̿CxS]di}j2TݶLSf}%rX>Hj 1@C9^9tcJ3Oyͳҭ9j #/pKeh lasݯ2u"|&3;X⇀5=Ш6n1?`9ڥoQX͸6,NZYV2%|N&/ ?7"zQB/"f觺 in.(7PpyG]*OZ23ijG XFDSB; K)>ix w5wk(u ɋ&-2mG"F|^6--Z f&kiwi6o_}uR1(YzILWs“Qa\g0jǟ,4P0p}'(/֋VGjn{5.Wiٮ=]N;K$B)Vb!cSV}?u;ɣNU WwCKRaP7m+o!jzqANSE'rphVN\㶎5zcYƸK#Uf[Vq_.冨X޲oΊky!棃. gD͒W7u~%b)4`1ϴs~yLA-%sde)k܅$\Ȋm'du֭T#@Z?´ug(:V`̔4P%[?ᝑ4FxyF[}?h؝xHrPȩK՜c5ʇxRizDwnhu':yWF+Jgw/zsӛޥRQ*Þw<b/9(C97JuTH[<2Q_Tpf܁Dn.05W2Bc9v2,N\ͤ2n/3%m!x`sE vbt[.ҿ9KcbnFc;nrzr, ٯPǞib2C+P#ND}pf׿\3DsO"luծ9b#l R>hae>LCC3C7RV Ư'/a28*hJڹ[{(uvl <m]V.llfDˇGjt?emi2ǣ:CՋ3b^t\TRpM"08FJ|i-]ŧ&R;e콛||[Z@]k}Otp hx>3یd ZmSc_lzCt~yƧG'>¢"mƟFX*Mc{H_B.|60} FBT]e{>B \Ğ"-NTϜO:LF4䧂էOj1!;oKK8T+ICysS;s*'݈)uGןװQ;2 <`tu糬mIqE1^Vskur$N {&TV/k٦ M_9}@$M^r~x ގCl܌'C6N8sk.ܤ W+?1a[eUo܄Nu[skʑ8^Z'syeѪZ-5n31lOD]V!jnlUaܓG6\ʑjĈq=~ѴAd¶ۉ 8+-Ž+^ y!@kpg١ ҈/n]t8e~k49(n °͑L{*_or:q>=z Fsj,V;^^N!WzH `fi$ ɒ.7ECOnuDMo"r^MXm{- dҁGc !{4Mw/&NDNJ< '~c_CgvuOs Dl4^?~Rɑ&{pPt~7o,3}J@]Q2.׺&׌!^IoT߫NL.Obw:׈?={&Ǎ;D3*܉DӸJwج``^6d[ǯ^cGbz-`۱X|tgg-/Y1ƻ^Pi8JDaڣؘ'J;҄ 7Z~r]avXOdzAtY` iioL&7cdɎ!ߚDjZ-T%ߕ ;m𖓖P/?cO 1mCVzz]b.ڦKx?hljyapfwl>.|2o$m#yVFKTb^|fa:L9d,ؠvJzH$R)׊`$uN,OqcY8y}fgY.:Mxir) sgwA=M{.gwFni 38:ط4!j:T& _2^Ñ%7Tl0źj=PKЏlݖ^Y`\VT#A|h=>N.NtT D}.:߉gjz]OI~$nEA<=+2,$j? *R󎩔TS˩YXT.p۷C-j}cũyzъ9Ԁy۵krbe8\;`I/FvRZV, OKܩqG/_">-4C8((7arlH#=$%ʙ΄_"!OӸP.գ9rd'$,E늴U(ׂ|;'N.Lv;;G["&3`֦wS:s2'NY# m MZ@ J~o0= {^@kI3-LgF -2)@wr&zag ?IB>oKɁU0)'ݣ(^3^W[aqf^Iy53xt$KmOG4oϲ%R"3c s*ge z mSj/*|x/QįL5 ':=y%2AI~$/UQ: r<×L 阾wj_Y#.HXnH#$o:k(-L5íy\Cf?9Q[ۈ#7ĸP1~L4޳8^}xvZ-m$ˢNܹi9KDCzNR0[w˅;4B [8 ǝqŨ2O &%PڇOOs}r8]]wt) [\E"‹DaSXMzeEU"<+ߩUs)79W;X==w;55͍;AOH;a!Q!s6^oĺEt}/5(sT6r7 Bk [4>kus͏֋ ~tyx^>;Q„h6O ުފ~Fdn|Q5(aB걂<*ϱ=!wuplq!ff>kVzN Y4^ uҢCKzkwRۙ(6﮻Yğ > C6t'9< af .h?v2yZP)|X] ĩ+XcŲ ?8WfI~5 f;`FA̗T39}}H HͽsMYnˍXdg4ZaCԫ|rd ݴϫyWWBo-"ˠ' P Eڳձ*1f9=]HQ X.5@=:e!HzOZ6LEu{ka++߭!mE">) YƌǶ/֗&p]B؁ؖ `j+ |paHXHofDDD a?ϑMF棲ۗoiM2Sd~8V_L;f,K};| u~ E IW -,Aqg4h,js}29"UcRkCt )ZvU2EOݜ$eӰ{EؗFV96טpYXŐhCIg?d@hPRfpÉ YA +gz s;l0vc/FjSDL )~qzmrϱ̒DA % T)t\43)Or' Lx#}LcD}>hfTxre"I.ЖU9 Y͵CM,~uemvM} Db=-xĴv*uS"RV{`EK3٫`X[+I?iG؟]r-0E3u-ݤ&)-?hvзKqEk?a%} kXxQlqT -.  `S{C!Aw`W {wPR.E<@x*gTճ3 #Wt)9:ѭ=nֻwpȖ mՄ=45:l=JYP48y,rQS ):S# 8(V3L#B;"夬c#(Fg1hC9?-2FpL}O$pJd#Mnܳ;dN.{q1%l:}n@+!93F…GGB@e\g+ri 3 7+F?Q<^CB#-ݑd[ko﬚gI#|aBf(H \?:z_uk!xY`Wٳbm-VZKꝯuJ)(ޛ#ɱRaYk|>D{doXs[^CqiϽimcgq~#RjEQ6 }]|OJ}F,Fos~P\B-:|-G OeGwN}a )Л4xBswRs>|ne$;ŷ$胴i~-b=O1tP ],1h0YH]FiLHTǺ>sa1mwSA /%s%$29RQ:=^DZ;Ea4BD>0/(9Q_ۙuoA#o֢4PYuX5c=F2MM%5p61OeLUϞʼ'7)pcVM;{2oU &baj/ -% enw_WI^ M2*ݫN72OpRgMk1E0ֆO| -O퇰eQ&̳nD<}?M1s x/䶉av\H~ 虦P'!T~9Uз&&{]}hZ|ŗ8rjqS}&nnmdSߑwbaELj.p9 4/x?=e:ptŸ%Ue`ms 1ůK$}X/+u>6֌Vhkaz6DQj{0n'ʛ&7*%[?EuM^Hpgݜrs`h%yƋǔO̼s <4f~34URo|xɨ$ /Sfs5׭\nϸhGUtwm%4mp{U!#";/~P ^e`mV8bl'rC}#)nRLy t?H7ElqP W)ǚ2KrxCb`3V𣏕}׽ڧ65o_.!"TxV{/tsHWSfNE;.$؍荭 `'u 3XiS(8D)V'ϪP!IZSⴸ$qnfk3UL&|][VtRtXgYe0'NѥB8W<׫<[ LI!8>6,A|9}6&R'<"x$KlC2J%K7g3~h]oa@Ҷˉ^̐"ʥ3C}!_hu8\v/j³KJ>ٻhi*Nܣc&gT|~.sbs[X ¹y[3t~fLIQ-Rd#w7+l,cGnΖʟwO%k32\Gkw6> stream xڬct]%vضmVlmIvRmWT8_ saƦ QVe1s01twe`ad(L\TxT-pbƮ@{qcWs^@ `ၣ98z9-\*4tt)`?5=]ʿ?v!UV 9@LIY[FQ @-27w6(M@Ss{s3\b.n枦v@ o\@{S[7+pWB-);:]*K;OW+cb-L)_0@{?Lf@G[c9: ?38[;ٚOwNR׿e9]]m-XX4uhϬ[8X-7ss:ws5IoHˌ}$7PB oWKz+]2{ g;|퀶^'jit`2"bofF .@Os3eo%W73wڛ_m003827_3+k+Ko G5 fqFT ``f{&_@,yV0vuzt'#ao`診ۛ6usvKߪ_sonin `bZ?2%;>X֤VRPSe^<|q$K{<ևeK՛f;M6O. &2 %]Nfo*P3?ٜai܋0ȟL1PA/(OGG{o!a)RIR\L?!_ݹ\s4kQ=V܈Y2؈,D@WL<~DZ$ Oͪ4t\qn\6 fd5GHep|jP K-e%Ik0sd~ֈboDLk;@HZ`C2È!Gԃ?uEJ{?Xv3hu:$PFK\7jC WpTmfb|{T^ E!ٓf}m+r9X8?T%fzS*NѴ(΃>l5;zabg bp=8!%ll#N4E( ;x}-h70 *hJ CX_w儂LnTPlzM[P9i V%&6cijӂZd+<=lvsM:ShHUi K7C +7 lp@yr v`y,RfQ6LͭY`sxklst~\YbN|7o 9Χ/lo`>=E'? sQTs1-GO~(Oy|-Z>} (O" zLj!C3%܂fۤ|_')/n7 G#vF3cK$U "š ŬTnų f"!Q_D`CVՊe)> M!V±âE:ByQqu%U no”B*{},y߆>fpL@ӶeOH?QnbNH&0io:Yz\%`W9i}efvn͜M^_y Q5Ecܿa2,S?2ar:t~NsH B,HѮ-"/vxk7J^Mˆ6ơ[&Еtcלছ<4(S'I݄qܫIBiF% A쭒?Rt+a*9(!ÃI euF>PC[\;}%6S:n`s+a0C㑡0O3u튑?2>5Nǰ( zNo6'6~-0I^ lUH2 UL +jt\e&i! ZRĕ:y%{N&.jA ͥ|B\Όm#}.P(;MDXsR"`꫺rA2T0ʠ +tn{H.{$r۴P&N. m51f<tκf\)ZK Ea>CNGu!un 3KpWZx\N)w ҂3 `.|oΞ@]N!HKS;t|B4wqʴ܀z FS{Ocf; yc'ҟE&`Q|t{It;Amc=}xė[!'`ȕ;u,|&Jvf7`gՉOD(n3mzf Kv;NzU2P, /mb_l)x\5+K#cRM=m=go}Jդ{چzAb.䬟5"_X|nD5?) G!"/f{<\A~1 Ku?&@bt܍ v(ai/`(,Dw:==ooy l?;XXv( у|K@CJQXPh1 kJ 'eE3N& CW}Ny~էSD P "G>gqaR oooh*{M~%Ŕ4)x_҉?/.S>T ӡȉlӱ_JIrww*T`sҏ7~rМ YߒM>; ,7%6j'@ π)DESҎoi' : y.uyAg8ōoݖn_>-'ǔYi4fѿiU$u:qkD1v Hr1&\#[;=W}۷1>ӪD)C 4 $H,&P<#YY9L EF˨M#\OGdU.]*zTz)jvcz3O!biR6aVŭB?ߤ);y{Тb+#x؍txf80M*ܭ:l7yTF 5Wob/ o_A'jVs b+QT!0soqpb:<.K4|v-RgYM,ܗy_D)TEɳ;љZUQsTjSoKs%ݶWyfΟW1~HQ߈'ִf߆D{eR7oxzھ|SN|DU+Nj9ӃŘmbe= ։SGjޔ!$&3!`oTH\(+u[w~7k3I^ m_Uz_i;􅛚ߨpwOY=X՛Ɩ4u6ӝA׸T4pǢ*y]@ix^XS=6[ c&Գvl[Xqǯg|0W` жp͛ X1ddsYڴN:h; S솸;W'޳^~|L~syhS:>جFLi7  7Q-v$|ʿOH7=# C"3έөOv4z۬-0 G@r`8KK9 JGH嗿6^,0_R4S7.>뉗h9"^أ5\-@BjL+~#VP跉&7N5& ƩU2dJt s4,[S6Py$Vq |bj?Kf&wPq吝F;f~Vr&Ef$n=巣fEhː 2Ľ9qiܱDRŽ~0åTKwnDX+#I9*)75~F&U7mY߿cg=h@RRXK^~^\D-E#?+W\>d@(hENh}8k,*. j煰ȿ0>"v522ʡKS ,~\KjIaaw8P%:ke=YO%t>$^b@]2fݎq| *! :NfHu綤9\B"ƿnc_J芺4nVAqfDϠ=4<W.gCnח)E8nvh %vok+AԎ_1>JɫiJDYL"͠7YB/hkf:^OÔ>Ѳys"qWxgˏ0傻zF) ! oxtQtWc,$qRW *jNhrl%6d8KxQ?Jw3tf QkcՋ`𝙗U )ĭV_.ҏ4,+΅{ZMzdD44n~d^Ob&|Ij'+7|z ;7tԳ?x9lobЀL2!q裷,IQNExxKR3X4( hԁOCM "Bˉΰ~\ we2KWƒBѭwb<5܄dzcy63[`{]1F ,ILM'$rb$.bօ |=%x)dE-fj(˓(X41_LлѳMMK2gAY"_gR>ܱ0 -/W*QM_4颥d'ߓy+tV?FlNf&(*PX܇1U| 9|(r8y8hPj?3ҦNH E93[ (?NKoNV/㱓Νe Ģ6 M ZH1yټ٘y.dR5h(mZG)E4U(.Qu?hC2bQK s* aS*hsPrT_#&PH)v!B=2/>c *dn>e0tG<ɪNGi#2I׀]簤bTʜNw)C䡲q v%Keթlϼri.YCo} }BQ%*"10lSXHsJ)H⥧Dw#$v7_h^_ J ܼDpV fw/1>/*PDzj~* U& 0CeiW[4G:}<& [Ru/zxIљpU fH$ RR96',<r-rh ]#`MSlD[i,^VȸT.v3ɜ}}ZΨ%5gRV?Pœdхw(SVe SΨ?K]r爱D6V0"*,cQhdi%2'&[PlHU v;ܬ]Xžd"'_{i ThEk|@=bj$ (&/) <5dDFAg*0+߾02cH $:1kٲ!H`QR3EW&&N>Ռs8RơW_!=ڈ3}G\4vD>:W^Ư*iI^G6ѶTf˩&ܔ5s܍s՜"f<ĶAO/{.^];2T3/1Hӯ`{/av'dꆩKgN*t~^Z6,tfy$aC F~/-,;p$n-1PcTI,ƕ!}` 7dй0NJ3bq&eUnJB n[1 a8/{F񡦝룊U!1$eX/s"LDH_V/.wY~E<&,u Ftƴ}BmeX/}aLXdJBS`φwZɯ)}sDDI`? i>zhb~~*-TVɃX]9#HG)ʼ6(}62R=&5'~$:Ѿe&(Ҡ`ˊ6'~Az/'B[ (cVbYرiߑ"BVS=ٍDP4JA%b,4siI$Z2X& 8un\)%Tu5H Zc)]/@I7ZT?! ٍ2e?mWpTFy |"SXިįLLZ')uycciѻ{řNhx~qΖ0{(z±_?X)}yݫA^[DŊ)Cv*:{,KrB(MIGѢL"b_퐄MK¿̨wѾ~;^A8F m%`1s>; D-R229\c!$}%ՊuXCTgIJT坋r eAM`ƺ~mC^AхP^^:I§C7W-k(plLhh! !$&7 r%W4~Ғvq)Yݞ+t"¬[H֢fyvg&泞8{L)^7^ͷ a KgTu fU}L;QYõUO-Q%sP&12<{fBhɊTj0+h)G b 6\=6[*MixOoLq"  |ˮYd>sp^=VmAR ?kRڽCe/vDdhN4ßom xf/]\ǎ"s]@sgi%S\C1+nW93 |@4cLmO"].r  weK1yBh[Nt(oB{%_nMx<> Q=w(f6T]kI[! BFL=f 1'݁~d@]9Iv39zev߼Pv Z:b>]J%%ygU: 9ZHZ$W\htt۾]`c׍A CGYM%~>F[cn; CmaohXU-9qkQ̺:i[k)U1gsUKH@p 2rd".|kX\ɮvP6Ié2U/ģ_':䳊&D~ZU4^tY蘒7ёE%MrcK=Y.Y[jw[!ݺI:z7 ?~ۦx&`"$DmZ/¨G`4> fd^;ս-sxQ>ɧ oЯ6`R7iMXYvhKc]%F͌d?E5Aԫx&@#E 30Li|d6엠tc1RՆ*_nkPy(U0d2Cj+fJ!J{akq,ñO.C a3ifw`%s<5N* i0d\~ 9 H! A3/hֻ1>. k*L,*nfJRKkeNRmy!vCFPY:7z?VÇ}$SC.1mv-CXRiN1KTg SY0dh.H-XM>wۮ!] OXRdsC7`N681:I1(ު_BNԢbZ'y?EbCByxA8Q,L]s?$ @<);xsy9*0I+#N%GgGJ㜡Mb%&: vhfq:[0j[] g4ZfCf%IF|%w6y 9P|*`ޥc͕$B[7[Abt1aV+ԡ|h6li`M#t@+#LIqWvX¼-CRFWș'b1Cy)z"q4u@ OkL9{eϊl{OMP9j&m}Oҫsth#۴~(DD:4+k1 o+Um#<* {o*.yh'/ӑ%0 ]Q28GN=I>8E^\R%TERyAIM0xi3([brj #?+DЯ#)⎝N9p0B&bNł.&=JY{'tt6JG9.2.70r0ZBK33%?ǔ?m-NžQ ~iBe2u%J'o6K~d/H  LwZ5F },bո)}s;L*oMG$LE{0#T)~}4ң{F9 dO*;[ct3X`gg^ѿ'Tgl/;I6M^^P.^cHw>=Ut~HyV-ڵflN,juj! pRPsf-L wKfqLpDC0$kt)fp}p|M͢Sxf6aϢkI(SPe~$ 9]ЪMlDe8/ :A\^3X5K+|%p~]:xp!f<)D[ FegQ$CU#-|#_ŎxPM ΢mvj,bHΩ̂l A ‘2_(Z͟m56j8S覐V$ٽO6i=:;jA1 3;4$s_1x6wLW:qje'f4Y6TQlZꮩG*~fK;ti)<Ljh'6S"kn»{ ^}K5U yp0W -]㎜).w$ ŦZQ÷?Gi]C_%Jc)jv:TUH[ӚaυRek>A1~Lsئ֗ Evyh)E^YΞTUM dAOx*)ӭ4]ۼz0K2#V=+1}>#\Ay4p҂jeN>5 $a"Kˡ4u$F!N C\JlMۨT߷rr? I: Jngg?pJ!S}:e  CG7ϣgg3=k h3btY񲱕 4S*cْвg=Vhi3Ϳ t6w$Oۿ<=THB4d4 VѬrZaU7+7iy5>zѰt r4ip)]R~7<ʇ[|c&5. 4 l.uA(asu#?֙p$tCpK/3 UuZV+ HԓX;iG7 #Fb]$x %]Q_8aD!8T'>v!B)0 W!F'\b9Ϧ] M&ވ4`QYlFxWŷʛBVV $9Z4T9֙>Vg\ti}']рJ6޴o1&@ܟzڇ)*?qiVΣu YmNf 7xm9L]}1FN0pS90lt=D? ]lj,@$#U}kXS\bB-[%ISÛZ3f77~PgSv =t~$>zS "Q̘ ;4/{cD~s] ;|j>(mpš%Ie(EES=9$㊆k\*+d 7yd=_b#8m&㛷dQzvYcq7NG&; abuH2m͌Z1gKoY ~%bD 3YMf9iN(Lv8D|E,֌;.3]j+PVߋF-bU:o‡nʨ=n[UO.mNuL_bsYmA,~nW4To+G SMERsq?WD^eBh+X_7%JJyxK$u7AI[g`2N0"=]T0|Ži96"WB,kЗ <soihۨ.u~لgKجA~*mw*Br;!Tꕈ7@ПWK =$Ƈ:A/P$qQa (̺H@bEAs\fmj~4CDW %|:%;zrjFbWx[ab/*]j̫=_ ?ltꄢ͹cBѽ<^T퇅t.WYM \5Pjozxf3Pa)idNՃ[% Z?ysQڦ.r?c kj*P& -|+3!=NLp%V)ɔEH ERdTLj^g"%+cdؠ9<&'*9PwKĞ.LuqWa30<8i,\!$<.ZePP|Q#ː[dl+@%am ZDlQΡ [D(-rBQLuST Qr+wneDL= :#+j3 +J*LsvW$pq7?gMTB1]΄_Z˥YID3FO3'sT}WBLS"rk s{ hSR?kH LkV;do'iVO-zN/PhCCR>'߶J&ݷ8SHm{a.Y?l.Qyސ&E\7Xmc!T,R/&xXTX\ң84\LQ[qšF+t! 2;Z`E !Yf\Ihd)0V"}Rt Y7$g/-SOvbe{}S3^Jwjz#C9iyn$X!뗘 C?Uvxhu#A\Ywx~i4é]-?Y =ckhY%hHL6S%%3h;*"hzJe};ʭ_%ʎC-+ɎfXO+]LhS;pTƹKBD9ĤBeXr1$nqܫ^h }l Xޗ8c8̷((jR QpɨEDju! 6e:wS,]օQM|z3ٝIHs}1`J]K`45~3pY"| 5*1i ʟ#X"1"I" Gk !{Ur+p3# TTǃbA­(޿وG]FJ]u OoaŵZZ_q4^H"I2~)+Wpt^*)`P@G6cLn{7f&+-\p~;+HԻ`: Y"@>D}L">?3 '0ƼkSrQqҵ+>uks5hnmlf_}$I%q%T4E\D@ puZ^ԛoǽX> nV<9_$Xvlmk;n5;Tchw*rU+z̓eC8`Ã1k|SE~ ڊHsPiJtٖ,g)P~D EAz'=9ˬD= b^z:m^7z3W""'9Mw_zU#]t^$D V; cO߉1JAM"7I5Pk+`ug As6{U.Qp^,uY,L4,W-x8Q%/_άĄ*{3mK(?L&e;W zYTJ ȃk(Aה;~_{fY d 6}]߫B\G}fK *4KʽrU?OrROmYjvkpOne$a9/T)]0dCEpqgD'h .?HPu9Bkz%#HR endstream endobj 708 0 obj << /Length1 1644 /Length2 11435 /Length3 0 /Length 12285 /Filter /FlateDecode >> stream xڭweTݶ%A!8v܂&k Kp&^߯d.kEM$b6J휘ؘY [gGWIh xs"QS9@`;qc' @hlH1 @I_&м{:,4/.@-Q8Y  @LQI[FA @'mJ&6 S<h6:Lvf92c8@SлhW:؂ G{w[ؾN {'{T%qdi7#] [M]d s8ݜ2@6@ @ c3;;Wzc{{Xg 'G93{LS ;$"cgKnl:? ;3Ilf@s${H}$7PB ;G%-lc`l>1%clx3yEccۂlo^n W0'YS_ $ hr2ۼd|XYMf 2KT@;❲j`Q֐PRdߗ,qqE},큀O ?EEnO&6.;m|O!?@lubr2}Hؙ{qn@S9)Ujw_=]ljy~UN԰ r`qןG/;wlh;ޔy4 ,Ũߏ5p;Vf4kVa&z=9QDo`}? xf3s= Af/d$&kP6'sN/:}79'JYA',7g&ʃ]Y[#oOBh5~e… ZI>w@Tf+1 |A3}cs**,m8QSЖ!Tjh٘U",Pjct;f65PLU2(l+$NT i!= rE'%r 9>t_fLu#6ʉ2ZD;#Igh\sGPC"Ѧkd!o Y,Xme:uP1& c+bOPP+9?#i\\gcs+q)Ig_= ' ۯvXN,02"LVlWn%*uvqS^P5:+(˵} 3+9m1lCJ j50n]qn8D MZW"'ذ H3à-ea8(%'L9;8 @x6D/c-(cmtJ VA+g] *^љQI/6֕j ÌWd >4cZ]C^8<[ \ᨑ+8;ߟ1ê`}#/&PL5֋0.qa֪ƒ+\{.B+bݠA/)pPH1N_a^ +OdWg;_iy~yt:No$'re[^9O"f@1Qih Ͱ]k6Pυ|MfX%CBiFƳ%o|##pON-]x6BL܏ uppM;|)Ջ:r_-2sv68E_9p\Y3q"yQjpwzIr;VRkB 8#4q aʉ.])x&k Ƭ!qѬDcOn;#L^ gMl(b r4cҌFG.hCG\*'s<7[1+CHy59͌PHDb4gN:Q-raXhp"_oZ 1\ {) ʹWż&4s7YP!,&ܣoKB69ВXԠVGuhKxr:[+ʐ) |x\)tTM *`zqt6Zq0 Nl$VDs|SU,q692$BU03ԁcXjg:p+a .:cƥ{m C6͹^< &N$Q$cgEdR1Gk#~4JG fE/: e)'w{j8z]Xxd(rʤ6Bdt>},9"!u4zF7Y ~yr!,ľzѺ2xe%-9i6|eWm3ٰS7W1 5:&s9U.Mvpǔ SQXgR b>Մ  kDhMȝ"iߺʼn3a&)~3ނw(./knGE29fԅ̗<>;t6_T#~%EP'ȹRlw$*9> BpπZ9kC ߙ] E>k (0Z@Mu"ގOM}]yt>b&Kcvi^(E~ijJu`ljo~DRė-Ljj}fްr#QMѫɑA͚$ LچɈ3Wҟ(&AYgkup}xh|=^`]b@7ʷxHRY۶?W;vDP=K;D<9?KҀf?A._3n~`:fg}!⏿9ŸF֤iZI>I4֡6Qi+5 y;\zBWǯiٿ~eknć[+=uKuiՎOp+=dt5z^"]:6w8/b"/ g rcl$VO٥(lZ!ɼoFlV`  +j1!=lbKj'fe+$j1%UU5OoSabFҡKԵBgDSj96L{fGdr"RleR I]E7:[ͩOz\d91]PŐ+愚 r}[4 ȅėE6\o-𨜁  X"[*0|KB䐊orh\,AB Vl@T+R揖9?E n׎BwcUn^2ύhצP* ֭cݷkxTGM8x8(W޾Xia_@^{c:_<- z%sVk.Qpбk]ÿ."A)"@6xOFGc|mR7;}zݜS5&B7X!ݺueKlxؘ^_ѾJHl.~EKLʕIAzEw{ ; v (#m1n|&nr(.)^-p-%ɋ9JdS/)ƌLΜs l[?c^(i_1[[+~LYjKi+ǎRÛ IC{g>*̫bt#kYoLU.t%@L$ +#dbJ F^:T!QckDsʹ,V֫W9kA*p|iM27ҎozoyWA^Hsz;/Bʺv}u_G PF܍<ʟ P]z ]L^.m`Vnp k(ˣ"/7iղ3İ'7maL]*&, n)in[v3XXAZ&{ /1::-eቑ_:[aFOS 0hJ7d!(2p]TBz&|#]bMVG"~+ph3[JT> onR)Ks.O}u5^N{w=OG-P>zP80al|!Z_.Ѱ;}%L4N:bY;T캢s.g$NWM]"*pS2s@f[9z{ ڰ.`r85)frК ${,Tf/j |Bo|Dumۻ߄z=3{)Ǖ|hf5m4poPs}Y?\V7%YTlT怒Rlt )/@ĢQDގh{$QL(dGK ?4fo]QxkYS8T;|[s%69jyI~: USJF{ cm$YȀ2"{Aəj*}FۏTU 00ml?GoaM,3ere)^aG5/ʅSmL' vxTIzK*)^VKw];8'BC4 @u4Wr+6AP E_#R}?zXpe~h%lSg; I;{a!b~}7J_/, *(ZUK;eb,pB)i_K)9!0H\rZnQU9d]RQ4ea-mυt,[ ;6s,A( 5.44=6ksYsWF`dj>-I8fwNȲtmM$Y߿".c0M{cJEe $e#Йp].pO[qdSO`U@Tw[a#%io=hFj~6e&G.h,\/޿|þw(3D[vqPi7Y+2"= Yqeu.)/h#<@Mb@k1hD2; 8_()0a-`m[,r-,+P$dGeh0#Ry`neUۼ%|\8>HZD5Z*\"ʝJ)0hūh?ANl$9JV0ilGE=k<zU_º-7[` HI e0 TbN\Mf!t.xJC>afX{qHo#~ ۞,vFS>I 0֒Un9>A"Ngk]BnVxg$=V0QGֿغ[|whU'l$`Ghtݟ>2:#[Jq#);hܼ-@V':8B^Amcf) `%W47`|C#TrtYgytmud{S}lqfrsޫTQc\ ~`i[5өOկ xrAM?Eu64M}kLbWڟ̥ƾ9% @˥e__݊nQ#5^IhM{uISdEګG*3 s ޳XR"m\sEGÌTķB}ПCI!h^|3t pM_9Sckh7!1۳ɲT`SKy&,ٽ[@cEӢH-X0n C8 5bڎJT) s+Il]6naI Fɋz.?IJ?h se+CXf{ذz% 5AgeI\9|J" L(gwWCñWe:ueA$j0Հ,6ž_jU%ڵO]3&kyޒSi!v(b7`F)Pb,5w9H|B) 6mE SGbɅy*x{*UL&l #j698n 5&vk3 MNpدTP 5oC2%*?ptu$H־6!r7x5z+S$XEƷ$=ל p *X2XHXst Ux ޴ UM;#d(^{^:jtBp 브Ň'+y:juilneR˱RP&@GFua#^zxGZUJ*X zq4^eS󮱎(L:InGs-qÜ 'qMQåI(`W~\\M5ԑZz,ӕJ&9MlWP 0׍8!]jݒf X'pC'zݪG("8O>"SDgi a2k=j3A抆 vB6^h7Sve8AgDw<(}\>OWcpz~" 9(Sfhm@C1 DObn,7"[qxO0 #(v)D>u NTU|>TVܩ( Xe5C5'U/%`.Lw!xpleﵝac5-qrƏ1$ulD"`CRxX~s bZzk<5w9v|Ѥ Va,>B:/uo>*M~lW?:X ~QImA.Tj~)vNr5{4Vܥj s>Wѱ%PΟɢ:'Oe (\@ eԢJgyQg|fêi~"RH#6=1J[ v,(8oYK6Ii6XHfR(Rss2C=~ "e[|<t}y\& &)ZC&:!(]N?#=K <~Q3+BR螙0IaZLkw;ܗ9ɕz?º'dO$a omb;Sxt~)hحsDDU+{[+%Í%}4(-|]!м`nMx &!vF! :b]< XҪ<$jIʐ ߽LD;32+o^_Lr+s'pY>8ơe2/5N\vqT3OP \j桿 SK:v$f7)VCWe e#$6|As4=jl bCg7!5<3]h HF>&eGݺ}ufo_Ym3U$|'ЁRenO7بWUG= Ƙo!+pOd 99{;6l$2"V}ha  _!A#d-3=}K(nU1500yD+؀36tieZ!G I؛rLueYy6Ne70[k ~DH|X ^،TDs"+L? j#dݞY9IY I3AK7IЂ)e@jUЎK9. L΁ZP JHpJIHط%V gǾ-"(T^_%sʿ34r9mMnơs5~|Ry|qRXr+s;pj?=KB~c@+ NJh()y7眒~0 ۻ.䡻b9M"C kx[>8ì̄5 TByC՗U,lP2$^Q? |3%K+fc|x`V?\tP Þh/Gt2'lWkv販BC4߀vmn_zn^`vg:ҒcK$Iս&A.b?0=Mu{Jrpos᎕kSdݴ:zNE*}o}Ł. (CK %g ŒA$GrdhcLh'ӏlA9SË2r2{Ѻr4{'~*I'Ln;(s&U D7“P zoPᜦ#"O /-a$x\q϶DG7 O9&*  .e1}xkc8vȠ:葙8K`O$Jc>kLJT5msХ,%^+Z__u 9IP.2gݺ21?JT^餃|8O6c~mŝWQRQBn I9{yr*4Ф[_؆_yr;hyR$㳾/be5"а'bXz:=5jwx*3dIr{bkO`(B+7ch/eAퟜq6vנ\TiN=YL.eboQ 8<=\IAb&xG[T:ݥ S#2H|J}W Cڸ>.N,nNoT8#G0Hts ĬrQoٲү JW-`Zi'J 5i@Wmrʄo޸J5W)?#>,5G"SHmj#h|o=GGT[?-Vy}, ܭrpR*hA1jeݜw:$T+d #]%9b<%`J9s'ApGg=o"Em͢W=M9)&ϒ A l EԪ:ɨȊ>Y{T0=ijNf&TbAI9*q.Np endstream endobj 710 0 obj << /Length1 1647 /Length2 14454 /Length3 0 /Length 15306 /Filter /FlateDecode >> stream xڭcte].ZqŶVl۶m+N*m6*V%bV\q*6n;{ϹZmt>lmR(19K:\Xy&n.< n2@;'GA!ltv]yZfqsS++ lmi Pբ/?*@>-]-A ws;G{s맋kC5ss9 #(RH̝?Pv36[\i/ 3Jsa%\M?̿;͝]\>.Kg s\ S;7[8+!GgO Oә+3t8X|j9SҿO7+p5O,s33Ggb @g3;sO7ٝUttÿ3kWs; F8Ϙ-ApL o` z3 `fnǤ@2?B?r;G!{kI7;;Eg{> 5y? gXLv'e;!F]$)[Z,v/dIӈaV֦7d25| dDEd5_ʟ]h_s+QQooN+a<<a @Wgo=fFffkeHL#5W Slg!07fn `bڀ?2)71Xެ^RPSmZ2sm_g?U_E!/@&eAa9bV-H]Nf̓IUòWh.6h܋0Lӛ1QZ5R&=S 軂ǧˋbz;6C=s{ zgH3XoE]WZZ  B_|%Lî/Q Rjdk5!H2Qe|h٭$רU ETڎ0 s]'G gbKATG/IEc[XGe> S_PB(мIϜEU,O׋˪mVc^U1z | ej|FYMn~TqΆr_$ Cj^֕,%fo2^O:MgþW*&XE 섗N:oW#K} N{)~IMIF4_Ko c'Q>*""}IwF*'ӰKKıܗ?tG=T`Qu_}o% j(;^4QD9'lpݯh|ul Ju. H5ChlP.8>IovP$_M]%bY:u6 YaWr^j=sY2:pR[2 @SvO"i/V#Eak#m_{qp~m?o&j 7'x%"=Umz1o]Ҷ3XE ^W\ dbFV)ޚMd@QZUݻN˵WZXu{="DP5e Jxr#2R3tKy2BPJH0Tɹ"E{ڄv'ɈT`6@'гVEc1G7),ٿ& b!%@X([uaE!kؼ*I'FIS. (؏gMx/Gw# gZԚ%A 6>aR⷗ϣ_ip&hn]3k$w Ȳ4jG B̗}LBv4nbp;0J75aIi 8ekZoYa;Ul!At/f$R mW;6.q"ūՠvgB1k|r R\ml_1Oap2TuΟqoyA:[ִˏPR8ߛ pޞh; =](V,/8!uS,8mGe=C4U ]&溝BY6Yf)r>}A Բ6덲a!L ܏^ZÔ{M.%e&Fk#sbPC!L 3|Y;il%SSm*L{Bó [1$)̈"3h ƶLu+bQRe\:L12ZJUn|sBlcYu4i6Ջכ :uxNB3K6o&E7;T6$1_dVg(8:1M%t`|ӝd(Ɠxts"dZLy\1l%844k LWǠ鸸:3\^lBSK?4`Y-fY"|[$aoR_|َP"r h*4zSP3BOMZ7@CNFl0]{7A,x7qPI&(>Z]ύ-Pz=֗os%N !n[cazX&Ev;X ykp( aiv;g YS_*P1oLDgL~`gL~LTn]v jaqzh2(U+׀G˳ 9!Q<3:'=7x^1&YV*.2Q[d" I0ד>-4p}Mq9ekigŚ2>ZAD*^u5yZ2׈:b1q˄hdgΝdr nw6Qiz)zZUr;b8xWG f^E#(k&+ O艌HI@`ƭOqNʹ}xŒ`2PئW8{zqp F9pa^v9=! /d~SPG%RExMb$ \8Huܬ'K8*#ZϟfZ辈46F`*or22RTfmӡO ǣ}-rhA^F:WY=-1E+ |-URvt1 b2[jd8p >:K& G6l,'.F<Ϟ&#$K&͏ @I qpn&W~^N0 @cEod<5Pc|8t= h)`cԩ,3LJjRr"-` >$-|;>{$sJ3bɍFsae DЯ4:>ΝgKj;U7;tE*ZUg_7\ů"uN!O.B|dWVd6_+M_-gPŸ+hŎوL븚KNE8Tsl&ͫGz $8= W+j(Y\]|F~g7d."6HhṰsZ0^`\BE7r OU޶hѲ* 1gS`^؟ gZptp,&:KH]ҭ(˩*V5rطS4'7+DlٔdJSF |V)aQ74g}N]XnJNBxuY x ËA0 ѫ} ro&w6K*HDM٩Dj&t0-7MwD*Ɗ)ZkY+1,(n/9"ePC" *Y;Ny5Q(opͷoMO<ά(QtςE=ZP6hqItҩ(_Y^tXcIh(F*I u] 9?q/̧pF% MD,RQI@R9 @pC.=㢓VČY=F/ ͞ߏ !cH*_#.F*看Qa_ϩ)0YkL~xʽE1YaFaM\\2+?pos@֣YtTDN*YF$DR]þ^"6DJzL1hwKW YMSBҍc%ߵc—05UiΕT 9.Rm8S]-Shg۪d^"yIށ[neo`a,a ) SGA|D'Y9p u:Db [ *^NJL`5n՚ %^%!Bv RYTB-aEU~/ E(+j`3'-LssStf P;7!H 6>-7)nyn \(UHeARS1Ek(ۉLcs,Cyal!݄+)#l4#Qn+FRT)-!EOȁk§УZH4ȁf6<9黦1? B zh<2m H=uA M|< $[1}3 \F}#=Tt??rK܌'9O$kbAsrzWzȖd}@曳=rW{K|kU QݲӀIo^c2%]pw3|-%d_REcvd+&F9g5Dףrܛ[/u_0ܝMh}? ݫ%UHaSUN&P_B &υӄ*ߊ1rb=c(^{昅Y:6On$,޾Ru^'ohwSN8e?g oJÑu92]=TxcRz^*3i 3}oq&2$^o VHxꗇP)g?oC}R,W`9 '\iunCMU a#4 dž7W'np#sv\9X\2e kO'uz$j6lV*V_҆hͩ3^*Sz {=pJcf#ʪ< t)ԼC&ՂƯKs16#`vW%FIjيTi8^jr΄ r_Q پSA x[ڶ ~%DJY%DRc+zS:2y u̿TV"}^Ȳ{;/&.8lE;,33!:}a+~J$VE۔R֠LEG3qC{=;-HBE? U5}R{Iyp 6Rm0sqC0~@0/̻\rAQŎWWC_- l/7 -%;o3pZfճkMM+Ki7%߉_ ~';{6^8S]r 8  {Q ~yĞAXoD~)V'@<\L`"b feRygo]5Xw&u*"'\k=65z"Cr@tƗ^P~'jj}u^@9`3u U5ޔۍMB7o6EKB__8UH$5˃1M{{F03'(lD?|FCVSM8){c8v G%p?>w_'BP9;{9?Yדs-Si(*zƧ;q˃ B3p0$R1ZRwt 2 Bߺe. wo3ivc^ CdnU0K(8I:~M۲h||`LQ#gs2,W4^`ȧ`:1 '$2PIK]ŗ% .H yI߁Eީ?>L *⪬iAS’ QA4j}ʆC+?Mq*w3:lQY8Oxrog(~YL]OxzΤVʢB|ˉG0%фHoQnZ3w)\吧JTA!`%3+CCy4?%l%F{Ay; zGĢ04Juw(U+P^J01Rw=A+Bhb'7_lx$9|S†*<6DY-Up+,!kH=nRbS݇#}=1;guQm@yU//d1GEUC& 2h7NcI'T jd3WD&#rzz`lV 5O‚Σ/3VDϓ=>\0 `<Ⱦ$\Vua!,_u 'K$xB6R9ȻcUP?+S-U3{!2~mPEh[E8 3JNGz`p0& @M.ơZ?]J칝xP|__F^IkT{%rﳒff,S8^k,{E&Gzi 6jӎ4f$,'g[ZS\>;բM3ͭp{CoJP'M=xzZo!"5=?a&FKa4o]Ŀ:Tmmy}ͯwWfj{*.aD_Y9/oT4ӵ:Щ վ!By5ٱG4vѤ6ǙU~-MnPܠ"y#t@nD 5y#tI)*UpqK48yxk\\ ,V44 í{A0zWm[^aacFיv yq'Ti ؁E R)W߄,#VƩ/:aMg@P$tˌY/&o.!4U&>cWSFQ.c(d?Fl܃K0ԇs*.l \>[-b+I%1VtBK /6^'?am!'BM)/oqjY-爸oi,xP7wL9n|(dX?[EEj,fM#nK`mխe#Tf4[EB0"˾.z1U9." S ؄2Eh4x~T(es(wm\aM%DA_ۆ:<y^*e X?w-Y$QGR͔VQȫ`3;3떲b!g}: oN<ԕS2xuM±{ cNL"MF]/s6G@*Xr\Y|UhbΩ)[ǼG>Lj,rarw!*\B-1 :E|8~Ժ̖5i/@k.Hq!_/:KDett\yU/rb~jBZ:TցR^KsB8%z0*_!ۼ qm7a<9P*(m ^{sr$NO/+`yUEȺ'F=Џ1hVhI9P1sY,9 v}:xh0sSGUbLpENхe |99B!gm Z3UHVG5@@)+P< *糱,+f>Yz٤|tu"GY:}<>ꩉOd=;ZәDr`jEʞ7ᇂ_#'eۧBOhlN(Wa%+b*L6v|&L_w̉Dy^둖?=tr>M|, Wxts<s$}d9׻{o} %ū于Gk%VGOzj'Un@GԄQѯQ!FwzA5bgz,?RᭋU\1_R$,P"Q3|m~8QV]7)^MuȜH"pz+68WO@Y|s!>|R '04#8U,Uj)9T>LIl}ZR|[rgĻTD9#ZWfr̜ੲd4%S̊7o=3%C'8?ze8x\P@ oz#cɁC|;2H 5=eyYJ]G~zQQeMF|#@?iuXbd} cdĒ)]uht#v& c@_y1#Kz-#Y z" I)^lpW{EIkJBJz GtNx ֭9jf!C8%~L˄9lqacё0,"4zlOFyddgH:?2n#.a+p<,U ބl ,5y@3&ӿ.H(Pc&d珐%_`Ҝ0(`S1g};c"IVcY Јk-L-6uvRa LWA?#4x| 0OԱ%!/H׾uq嫢]iN⢺|ܦ >EӼ)RR\)d:]wBGHZg,_@X8&׸42(ߓt((K6Rx4#;:~)ij8P+A@)gX}x]1{}IKWG>sxrÓf1O~+ gSf\Y0cUՙiX[x\)OS+;P;!a?d)1*7F}afEUIICoX EŹaֶG#xr&_6f' $.LAʚnH'7~$u@?I;TS>'ubK4o2}:\0!\*]F쾚B]5 PkLJrE\Kvsviw\/Nn w o{RudG yzAsG7dp+o=q09t&K1z\:ݴ[/ʉ[NͳK~%>3ski{a PzǦxgUU؊6R:K؛1ݾYO{l dWx7EZZR8 M4qUPșWp.+E>/ Rq2u>xc$rm|.Nz OM(":D>pq(|zt׵99Y Mmν"ib">ـ7(̽kxMj7[%`Q~8A53b!:ࡷMEZ~Ƞ|Y^ k\_FaYF!F}eP?8u g8>v) ;c_ g|KgCI}#nUa@e4li]%'BGa@"C3i3G0eR+T\H O(Ez$ls뱱v%"S|)W}L|=ӭM摫Uۉ?O6z(-> 4VvFE1Pp06K4uD odHӅohn<2 ^l<ړdjl%bÚpȅyz~S[P"7RADbr"D tKq}*~Pl{ \4Brwc y --,?܌7v遪"'" Eš#7qK[TAb*\[ILWM֧ VD!E^h#zSEe*^A< .0M@,E?^T!-WM%='&]{)CHM^C{IjMN@!\tY5n܂:wDh*kC\[T8 x֕ mXߏqrLD5x顚+!ۛ<=mw ϥ79s -r3i *4?(;LjاH QY3Ry X7K:E@z]:Ϝx xyݹ״2;y*:4 ARwfmI ^^Dzj6hYoc_tƝSI mlt&Aqi֤43LZF%zNǚ'j2?C {ݐd-4'0@-YP7 :ZSMUS5 14UadT&GUu_ZRej)gX5M![pƸR3Q07=c`ᆱo1U㫘8058?ZEkb謰M[ I͢NY?5 Κ0 H5;?IphΜ/S*pX\xF鎙Y\/FajgDM V .dwpD4 IzTܶ n@,L|8ak E;/_Q_%Ro",68ZةIc#hS׆0"g2c2D N! cr +Y.e Շ_i!T律p\ђpdqݰˇ=i%PjQM 7*ܵ ]c+C0p2,9ȅ9,}MoIU ,\=C ?C?_85O`Xb2cEh Υ6bxs *%0n6ڙp^SiлJE~G+濋ʕݝYC) viqT|h}U{= [ ̎/ y6uB1$V.8څnJx:jPr)+g֋-ѣlJvVm=8nl¸~ !F?"OW^e7P X_O4SSF{ ]u}_|9 /c`fPioyBJ[tZ3IV >Ž@V&mybt 쯢l/f7 FojA$r6U|!rGD^x!]ʷ]D)();SMy&oa45b+hZB׾'wң }.,88;)9_.*D ۢĘJof6P~>Š3Q endstream endobj 689 0 obj << /Type /ObjStm /N 100 /First 891 /Length 4335 /Filter /FlateDecode >> stream x[msܶ_V;w ׍ZqMz:%9ݝ<ί.@)~hNg_$ftQLʂ)QppGuBYZh ^UJ> ZR{)(c j/tIAWYB^=(h+Ơa A,4BA ɨe!@3[H#,VР*U(ΠA ,S BjâfАCCMGZP 7RR%hZiQB E Éz*m.)L)laDP(XӪ0L0i9|,z0#AN_`Ai$A [J]0SX!0Fr6bx`) 4BÁDk@ o Q<;\IuE2 F4C~-@'>)"*@F3D!1 3>.DŴ<`BVcLpOT  Z@氆PΑ3D!#ڇB֒jwr}/7 p qچm ;9:#^cI J<#>e=? < "b?Ĝ΁ߐ>b:a1$ 2YkO q}ˆ>DMyO>?~Ucv' 8~MUpv>kLF \QqP9ץ#<!2R_/G7.ŐAw.AƱx?!qJ8t.Nk?ۦo0 s(}Gq2r?'&u܁@%w;!~p۬u5n;q[^~{ۋbn7~ne}_U(BϞm>?G ](Oȗq7^Uft}MW߾>NwfT7uWOgsۜzh9څyO/~}oT.pQ1#3|!r!6w;D|&<<t95˧ܾؗg͌],| Ѫ`pJ;c<*qfLbDK Ccr!ȅkPBg"eʧ%|>/ 'Lt'q"d9WhH@aٯVu\1RWա`̔B|ppc[6g ۋQެuO8> Ag^n:dCܥy3gO д9,@SvގQ{TZϨwgP&jaoM,CfF>!A߿eb&?h [*0\]հn*z8Y]3֓ݧǍܛxr9󜡞KҐ}ѷ>Cx,\UP9u=q}&ɿJs~7z S8e:NB ͏(/ 9&ԩK L9ޱGP8jes Y89GNhvm x>pr̢=F,L9`p~ 0 @@h6G#|-uu]p6ssb5|EWo||κ0c`ܯWeUWۯa'S޽eq _LpUG! :|.녤~ {[C̭!{_Ku*_ͽ:1iwjO/T yo@/"}C{H[zwdv}z>/}sw?̊~6?.sGx45T%zVJHŲPT-+j&k#6t_EeBȺ͑nBmr32nroیl&$6#:Ǵ6 HCMg=su>Aj0T÷p$y|8{U ?\t9=u_;:v˓˫ߙCxnURЬ*estG禽;6 YT]~:r:_5m+C_V?k'8=u4:,'aYwn]/Uom77ݧScNFN1a :Ik.ʀuwTZ3H0g)I&">fnV }  0|U- qppA3NM1Y1 I®ނBwu[0`_|rIbZڬ'$ALf&4~".@;þF[l؉7WMbFULd B\H"T(ψyINRnS)|tSy/0hzf0\&c.Uij`z♇2rlElf¹HGQHaW05nMLD$Bt 4dvjne}UW][q$ %c<{xf)9O[]@5M̳7` /tڍ \J>ݳ)٬%V5u㳔L;yHF8Q'cvۨ[An [cw)|D6"b:TcFg# ~,wDLc&b KXƃLli*3o x{,b? V?Ici~~{z$S(xJG4 sڗJ5obg tkQ`<+e$dX1a endstream endobj 778 0 obj << /Author()/Title()/Subject()/Creator(LaTeX with hyperref package)/Producer(pdfTeX-1.40.17)/Keywords() /CreationDate (D:20200219120731+01'00') /ModDate (D:20200219120731+01'00') /Trapped /False /PTEX.Fullbanner (This is pdfTeX, Version 3.14159265-2.6-1.40.17 (TeX Live 2016) kpathsea version 6.2.2) >> endobj 750 0 obj << /Type /ObjStm /N 28 /First 244 /Length 1007 /Filter /FlateDecode >> stream xڝOo7 )ttw$Jɭᶧ"3MFvS߾|;4CZcgZ| %90.113MpFyRg 1, 1(1U-Zچ뀽$Ɛ$5W RE%Ԑ+4(cH & l@(]. #9Pb,&^bX̛o7)i;o W*C%6v хҀ˶63yeeq TfժEf+'Pjkn+Ɓ93gAh;Zy@h}2; ZxjrꪩP]9 on+ƁE%k/?f+-Yh.D{YF}%۟h ٙlRqYDl['(j*^ ž J(0@[]ZQ*кk-[h%f7ŝ+ZhhfȠ7yB:B6G6-`v聙quE8&(`sr3T/ EqM &'#ȺqYwbj(ъŨok-Y hn@CucZw=6P-F}[ h} h%.U~8|Hֱړ]ݏwv=KۿtyQK3uʳ?Id/6y/i}ج:yn➁o2D{u3iUuov|;fe0y4z<8MgOŁ >>* endstream endobj 779 0 obj << /Type /XRef /Index [0 780] /Size 780 /W [1 3 1] /Root 777 0 R /Info 778 0 R /ID [<6AD48C7AFD8DB6205AD0ACE2BD763CAB> <6AD48C7AFD8DB6205AD0ACE2BD763CAB>] /Length 1817 /Filter /FlateDecode >> stream x%9]Inv{w>/}}H 0BL ] 0Ae  A7@D$~g:n[}Թ)AJӼ-?At2 2cb4b[Ŧ gl}b' \#b |sb BGbG '`5s3\ K֊1\ 66\;dV;h8 n0\ kĞ7\ 2Kl:X/Ll(Jlh 6mcm b_vnbwvv/0&Y>6 _kwEۺhg<J{s^(|P9x*bSf97 oToPxF9%&  3)>(,P(X߈{y %N8A!@B?Gf(aږ (eTTט >(|PAQ5[[=&Ս>^)S__,~1~πIJ3!N9c(']fx9'Lr9b:4N0M"`HHNN<XQ̼4mIX4 6~2))ڏ-9`;H!:!DOs9)ZQ8GrWcRD:pNz)x+p!?{\up$d@.*ņٺDM쓞S _Kͣ xD*+k(=%UP\5Rҕҕҕ5LwQt5眺_ _ _)])])]QJJ UK\i^kl*FƓjkvF9ѮWsƔkQUtttzh^i^i^i^i^]sA [0] vctrs/tests/testthat/test-vctrs.R0000644000176200001440000000145713622451540016667 0ustar liggesuserscontext("vctrs") test_that("generics are extensible", { expect_error(vec_cast(NA, NA, NA), class = "rlib_error_dots_nonempty") expect_error(vec_restore(NA, NA, NA), class = "rlib_error_dots_nonempty") expect_error(vec_proxy(NA, NA), class = "rlib_error_dots_nonempty") expect_error(vec_proxy_equal(NA, NA), class = "rlib_error_dots_nonempty") expect_error(vec_proxy_compare(NA, NA), class = "rlib_error_dots_nonempty") expect_error(vec_ptype2(NA, NA, NA), class = "rlib_error_dots_nonempty") expect_error(vec_ptype_abbr(NA, NA), class = "rlib_error_dots_nonempty") expect_error(vec_ptype_full(NA, NA), class = "rlib_error_dots_nonempty") expect_error(vec_arith(NA, NA, NA, NA), class = "rlib_error_dots_nonempty") expect_error(vec_ptype_finalise(NA, NA), class = "rlib_error_dots_nonempty") }) vctrs/tests/testthat/test-type-rational.R0000644000176200001440000000132213622451540020305 0ustar liggesuserscontext("type-rational.R") # These tests check the rational type from the S3 vignette test_that("equality proxy is taken (#375)", { local_rational_class() x <- rational(c(1, 2, 1, 2, 6), c(1, 1, 2, 2, 2)) expect_identical(x == rational(3, 1), c(FALSE, FALSE, FALSE, FALSE, TRUE)) expect_identical(unique(x), rational(c(1, 2, 1, 6), c(1, 1, 2, 2))) }) test_that("compare proxy is taken", { local_rational_class() x <- rational(c(1, 2, 1, 2, 6), c(1, 1, 2, 2, 2)) expect_identical(sort(x), rational(c(1, 1, 2, 2, 6), c(2, 1, 2, 1, 2))) }) test_that("can find common type and cast to rational", { local_rational_class() x <- rational(1:2, 2:1) expect_identical(vec_cast_common(x, x), list(x, x)) }) vctrs/tests/testthat/test-cast-list.R0000644000176200001440000000111513622451540017420 0ustar liggesuserscontext("test-cast-list") test_that("silently extracts elements of length 1", { expect_equal(vec_list_cast(list(1, 2), double()), c(1, 2)) }) test_that("elements of length 0 become NA without error", { x <- list(1, double()) out <- vec_list_cast(x, double()) expect_equal(out, c(1, NA)) }) test_that("elements of length >1 are truncated with error", { x <- list(1, c(2, 1), c(3, 2, 1)) expect_lossy(vec_list_cast(x, dbl()), dbl(1, 2, 3), x = list(), to = dbl()) x <- list(c(2, 1), c(3, 2, 1)) expect_lossy(vec_list_cast(x, dbl()), dbl(2, 3), x = list(), to = dbl()) }) vctrs/tests/testthat/test-partial-frame-print.txt0000644000176200001440000000006413623022034022004 0ustar liggesuserspartial_frame< x: integer {partial} y: double > vctrs/tests/testthat/test-ptype-abbr-full.R0000644000176200001440000000341313622451540020525 0ustar liggesuserscontext("test-type-string") test_that("input must be a vector", { expect_error(vec_ptype_abbr(sum), "Not a vector") expect_error(vec_ptype_full(sum), "Not a vector") }) test_that("NULL has method", { expect_equal(vec_ptype_abbr(NULL), "NULL") expect_equal(vec_ptype_full(NULL), "NULL") }) test_that("non objects default to type + shape", { expect_equal(vec_ptype_abbr(ones(10)), "dbl") expect_equal(vec_ptype_abbr(ones(0, 10)), "dbl[,10]") expect_equal(vec_ptype_abbr(ones(10, 0)), "dbl[,0]") expect_equal(vec_ptype_full(ones(10)), "double") expect_equal(vec_ptype_full(ones(0, 10)), "double[,10]") expect_equal(vec_ptype_full(ones(10, 0)), "double[,0]") }) test_that("objects default to first class", { x <- structure(1, class = "foofy") expect_equal(vec_ptype_full(x), "foofy") expect_equal(vec_ptype_abbr(x), "foofy") }) test_that("atomic vectors and arrays as expected", { expect_equal(vec_ptype_full(1:5), "integer") dbl_mat <- array(double(), c(0, 3)) expect_equal(vec_ptype_full(dbl_mat), "double[,3]") }) test_that("complex and factor as expected (#323)", { expect_equal(vec_ptype_abbr(0i), "cpl") expect_equal(vec_ptype_abbr(factor()), "fct") }) test_that("I() wraps contents", { f <- factor() expect_equal(vec_ptype_abbr(I(f)), "I") expect_equal(vec_ptype_full(I(f)), "I>") }) test_that("AsIs class stripped from I()", { df <- data.frame(x = 1, y = 1:2) class(df) <- c("myclass", "data.frame") expect_equal(vec_ptype_full(I(df)), "I>") expect_equal(vec_ptype_full(I(df[1])), "I>") expect_equal(vec_ptype_full(I(df[0])), "I>") }) test_that("named lists are tagged (#322)", { expect_identical(vec_ptype_abbr(list(x = 1, y = 2)), "named list") }) vctrs/tests/testthat/test-type-data-frame.R0000644000176200001440000001525013623210233020473 0ustar liggesuserscontext("test-type-data-frame") # printing ---------------------------------------------------------------- test_that("data frames print nicely", { expect_equal(vec_ptype_abbr(mtcars), "df[,11]") verify_output(test_path("test-type-data-frame.txt"), { vec_ptype_show(mtcars) vec_ptype_show(iris) }) }) test_that("embedded data frames print nicely", { df <- data.frame(x = 1:3) df$a <- data.frame(a = 1:3, b = letters[1:3]) df$b <- list_of(1, 2, 3) df$c <- as_list_of(split(data.frame(x = 1:3, y = letters[1:3]), 1:3)) verify_output(test_path("test-type-data-frame-embedded.txt"), { vec_ptype_show(df) }) }) # coercing ---------------------------------------------------------------- test_that("data frame only combines with other data frames or NULL", { dt <- data.frame(x = 1) expect_equal(vec_ptype_common(dt, NULL), vec_ptype(dt)) expect_error(vec_ptype_common(dt, 1:10), class = "vctrs_error_incompatible_type") }) test_that("data frame takes max of individual variables", { dt1 <- data.frame(x = FALSE, y = 1L) dt2 <- data.frame(x = 1.5, y = 1.5) expect_equal(vec_ptype_common(dt1, dt2), vec_ptype_common(dt2)) }) test_that("data frame combines variables", { dt1 <- data.frame(x = 1) dt2 <- data.frame(y = 1) dt3 <- max(dt1, dt2) expect_equal( vec_ptype_common(dt1, dt2), vec_ptype_common(data.frame(x = double(), y = double())) ) }) test_that("empty data frame still has names", { df <- data.frame() out <- vec_ptype_common(df, df) expect_equal(names(out), character()) }) # casting ----------------------------------------------------------------- test_that("safe casts work as expected", { df <- data.frame(x = 1, y = 0) expect_equal(vec_cast(NULL, df), NULL) expect_equal(vec_cast(df, df), df) expect_equal(vec_cast(data.frame(x = TRUE, y = FALSE), df), df) }) test_that("warn about lossy coercions", { df1 <- data.frame(x = 1, y = 1) df2 <- data.frame(x = c("a", 1), stringsAsFactors = FALSE) expect_lossy(vec_cast(df1, df1[1]), df1[1], x = df1, to = df1[1]) expect_lossy(vec_cast(df2, df1), data.frame(x = dbl(NA, 1), y = dbl(NA, NA)), x = chr(), to = dbl()) out <- allow_lossy_cast( allow_lossy_cast( vec_cast(df2, df1), chr(), dbl() ), df2, df1 ) expect_identical(out, data.frame(x = dbl(NA, 1), y = dbl(NA, NA))) }) test_that("invalid cast generates error", { expect_error(vec_cast(1L, data.frame()), class = "vctrs_error_incompatible_cast") }) test_that("column order matches type", { df1 <- data.frame(x = 1, y = "a") df2 <- data.frame(x = TRUE, z = 3) df3 <- vec_cast(df2, vec_ptype_common(df1, df2)) expect_named(df3, c("x", "y", "z")) }) test_that("casts preserve outer class", { df <- data.frame(x = 1) dt <- tibble::tibble(x = 1) expect_s3_class(vec_cast(df, dt), "tbl_df") expect_s3_class(vec_cast(dt, df), "data.frame") }) test_that("restore generates correct row/col names", { df1 <- data.frame(x = NA, y = 1:4, z = 1:4) df1$x <- data.frame(a = 1:4, b = 1:4) df2 <- vec_restore(lapply(df1[1:3], vec_slice, 1:2), df1) expect_named(df2, c("x", "y", "z")) expect_equal(.row_names_info(df2), -2) }) test_that("restore keeps automatic row/col names", { df1 <- data.frame(x = NA, y = 1:4, z = 1:4) df1$x <- data.frame(a = 1:4, b = 1:4) df2 <- vec_restore(df1, df1) expect_named(df2, c("x", "y", "z")) expect_equal(.row_names_info(df2), -4) }) test_that("cast to empty data frame preserves number of rows", { out <- vec_cast(new_data_frame(n = 10L), new_data_frame()) expect_equal(nrow(out), 10L) }) test_that("can cast unspecified to data frame", { df <- data.frame(x = 1, y = 2L) expect_identical(vec_cast(unspecified(3), df), vec_init(df, 3)) }) test_that("can cast list of data frames to data frame", { df <- data.frame(x = 1, y = 2L) expect_equal(vec_cast(list(df, df), df), vec_slice(df, c(1, 1))) }) test_that("can only cast list of data frames to data frame if they are all size 1", { df <- data.frame(x = 1:2) expect_error(vec_cast(list(df), df), class = "vctrs_error_cast_lossy") }) test_that("can restore lists with empty names", { expect_identical(vec_restore(list(), data.frame()), data.frame()) }) test_that("can restore subclasses of data frames", { expect_identical(vec_restore(list(), subclass(data.frame())), subclass(data.frame())) local_methods( vec_restore.vctrs_foobar = function(x, to, ..., i) "dispatched" ) expect_identical(vec_restore(list(), subclass(data.frame())), "dispatched") }) test_that("df_as_dataframe() checks for names", { x <- data_frame(1) y <- data_frame(2) expect_error(vec_cast_common(x, y), "must have names") }) test_that("can slice AsIs class", { df <- data.frame(x = I(1:3), y = I(list(4, 5, 6))) expect_identical(vec_slice(df, 2:3), unrownames(df[2:3, ])) }) # new_data_frame ---------------------------------------------------------- test_that("can construct an empty data frame", { expect_identical(new_data_frame(), data.frame()) }) test_that("can validly set the number of rows when there are no columns", { expect <- structure( list(), class = "data.frame", row.names = .set_row_names(2L), names = character() ) expect_identical(new_data_frame(n = 2L), expect) }) test_that("can add additional classes", { expect_s3_class(new_data_frame(class = "foobar"), "foobar") expect_s3_class(new_data_frame(class = c("foo", "bar")), c("foo", "bar")) }) test_that("can add additional attributes", { expect <- data.frame() attr(expect, "foo") <- "bar" attr(expect, "a") <- "b" expect_identical(new_data_frame(foo = "bar", a = "b"), expect) }) test_that("size is pulled from first column if not supplied", { x <- new_data_frame(list(x = 1:5, y = 1:6)) expect_identical(.row_names_info(x, type = 1), -5L) }) test_that("can construct a data frame without column names", { expect_named(new_data_frame(list(1, 2)), NULL) }) test_that("the names on an empty data frame are an empty character vector", { expect_identical(names(new_data_frame()), character()) }) test_that("attributes with special names are ignored", { expect_identical( names(new_data_frame(list(), 0L, names = "name")), character() ) expect_identical( attr(new_data_frame(list(), 0L, row.names = "rowname"), "row.names"), integer() ) }) test_that("`x` must be a list", { expect_error(new_data_frame(1), "`x` must be a list") }) test_that("if supplied, `n` must be an integer of size 1", { expect_error(new_data_frame(n = c(1L, 2L)), "must be an integer of size 1") expect_error(new_data_frame(n = "x"), "must be an integer of size 1") }) test_that("`class` must be a character vector", { expect_error(new_data_frame(class = 1), "must be NULL or a character vector") }) vctrs/tests/testthat/test-recycle.R0000644000176200001440000001103013622451540017140 0ustar liggesuserscontext("test-recycle") # vec_recycle ------------------------------------------------------------- test_that("vec_recycle recycles size 1 to any other size", { x <- 1 x0 <- numeric() x2 <- c(x, x) expect_equal(vec_recycle(x, 1), x) expect_equal(vec_recycle(x, 0), x0) expect_equal(vec_recycle(x, 2), x2) }) test_that("incompatible lengths get error messages", { x2 <- c(1, 2) expect_error(vec_recycle(x2, 1), class = "vctrs_error_recycle_incompatible_size") expect_error(vec_recycle(x2, 0), class = "vctrs_error_recycle_incompatible_size") expect_error(vec_recycle(x2, 3), class = "vctrs_error_recycle_incompatible_size") }) test_that("can recycle arrays", { x <- matrix(1:2, 1) x2 <- matrix(1:2, 2, 2, byrow = TRUE) x0 <- matrix(integer(), 0, 2) expect_equal(vec_recycle(x, 1), x) expect_equal(vec_recycle(x, 0), x0) expect_equal(vec_recycle(x, 2), x2) # List arrays data <- c(list(1), list(2)) x <- matrix(data, 1) x2 <- matrix(data, 2, 2, byrow = TRUE) x0 <- matrix(list(), 0, 2) expect_equal(vec_recycle(x, 1), x) expect_equal(vec_recycle(x, 0), x0) expect_equal(vec_recycle(x, 2), x2) }) # Empty ------------------------------------------------------------------- test_that("empty input returns empty list", { expect_equal(vec_recycle_common(), list()) }) # Vectors ----------------------------------------------------------------- test_that("NULL is idempotent", { expect_equal(vec_recycle_common(NULL, NULL), list(NULL, NULL)) expect_equal(vec_recycle_common(1:5, NULL), list(1:5, NULL)) expect_equal(vec_recycle_common(NULL, 1:5), list(NULL, 1:5)) }) test_that("equal lengths returned as is", { x <- 1:3 expect_equal(vec_recycle_common(x, x), list(x, x)) expect_equal(vec_recycle_common(x[1], x[1]), list(x[1], x[1])) expect_equal(vec_recycle_common(x[0], x[0]), list(x[0], x[0])) }) test_that("vec_recycle_common recycles size 1 to any other size", { x1 <- 1 x3 <- rep(1, 3) x0 <- numeric() expect_equal(vec_recycle_common(x1, x3), list(x3, x3)) expect_equal(vec_recycle_common(x3, x1), list(x3, x3)) expect_equal(vec_recycle_common(x1, x0), list(x0, x0)) }) test_that("incompatible lengths get error messages", { expect_error(vec_recycle_common(1:2, 1:3), class = "vctrs_error_incompatible_size") expect_error(vec_recycle_common(1:3, 1:2), class = "vctrs_error_incompatible_size") expect_error(vec_recycle_common(numeric(), 1:2), class = "vctrs_error_incompatible_size") }) # Matrices ---------------------------------------------------------------- test_that("can vec_recycle_common matrices", { x <- matrix(nrow = 4, ncol = 4) x1 <- x[1, , drop = FALSE] expect_equal(vec_recycle_common(x, x), list(x, x)) expect_equal(vec_recycle_common(x1, x), list(x, x)) }) test_that("recycling matrices respects incompatible sizes", { x <- matrix(nrow = 4, ncol = 4) x2 <- x[1:2, , drop = FALSE] x0 <- x[0, , drop = FALSE] expect_error(vec_recycle_common(x2, x), class = "vctrs_error_incompatible_size") expect_error(vec_recycle_common(x0, x), class = "vctrs_error_incompatible_size") }) test_that("can vec_recycle_common data frames", { x <- data.frame(a = rep(1, 3), b = rep(2, 3)) x1 <- vec_slice(x, 1L) expect_equal(vec_recycle_common(x, x), list(x, x)) expect_equal(vec_recycle_common(x1, x), list(x, x)) }) test_that("recycling data frames respects incompatible sizes", { x <- data.frame(a = rep(1, 3), b = rep(2, 3)) x2 <- vec_slice(x, 1:2) x0 <- vec_slice(x, integer()) expect_error(vec_recycle_common(x2, x), class = "vctrs_error_incompatible_size") expect_error(vec_recycle_common(x0, x), class = "vctrs_error_incompatible_size") }) test_that("can vec_recycle_common matrix and data frame", { mt <- matrix(nrow = 2, ncol = 2) df <- data.frame(x = c(1, 1), y = c(2, 2)) expect_equal( vec_recycle_common(vec_slice(mt, 1L), df), list(mt, df) ) expect_equal( vec_recycle_common(mt, vec_slice(df, 1L)), list(mt, df) ) }) test_that("recycling data frames with matrices respects incompatible sizes", { mt <- matrix(nrow = 2, ncol = 2) df <- data.frame(x = c(1, 1), y = c(2, 2)) expect_error( vec_recycle_common(vec_slice(mt, integer()), df), class = "vctrs_error_incompatible_size" ) expect_error( vec_recycle_common(mt, vec_slice(df, 0L)), class = "vctrs_error_incompatible_size" ) }) test_that("recycling has informative errors", { verify_output(test_path("error", "test-recycle.txt"), { "# incompatible recycling size has informative error" vec_recycle(1:2, 4) vec_recycle(1:2, 4, x_arg = "foo") }) }) vctrs/tests/testthat/test-type-data-frame-embedded.txt0000644000176200001440000000036413623210233022640 0ustar liggesusers> vec_ptype_show(df) Prototype: data.frame< x: integer a: data.frame< a: integer b: factor<38ce1> > b: list_of c: list_of< data.frame< x: integer y: factor<38ce1> > > > vctrs/tests/testthat/test-type-list-of.R0000644000176200001440000001142713622451540020060 0ustar liggesuserscontext("test-type-list-of") test_that("list_of inherits from list", { skip("Disabled") x1 <- list_of(1, 1) expect_s3_class(x1, "list") }) test_that("list_of works like list", { x1 <- list_of(1, 1) expect_type(x1, "list") expect_s3_class(x1, "vctrs_list_of") expect_equal(attr(x1, "ptype"), double()) x2 <- list_of(1, 1, .ptype = integer()) expect_equal(attr(x1, "ptype"), integer()) x3 <- as_list_of(list(1, 1)) expect_equal(x3, x1) x4 <- list_of(a = 1, b = 2) expect_equal(x4$b, 2) expect_error(x4$c, "Invalid index", fixed = TRUE) }) test_that("list_of errors if it can't find common type", { expect_error(list_of(1, "a"), class = "vctrs_error_incompatible_type") expect_error(list_of(), "find common type") }) test_that("can use as_list_of to change type", { x1 <- list_of(1) expect_equal(as_list_of(x1), x1) x2 <- as_list_of(x1, .ptype = integer()) expect_identical(x2[[1]], 1L) }) test_that("is_list_of as expected", { expect_false(is_list_of(list(1))) expect_true(is_list_of(list_of(1))) }) test_that("print method gives human friendly output", { skip_on_cran() # Depends on tibble x <- list_of(1, 2:3) expect_known_output({ print(x) cat("\n") print(tibble::tibble(x)) }, file = test_path("test-list_of-print.txt") ) }) test_that("str method is reasonably correct", { x <- list_of(1, 2:3) expect_known_output({ str(x) cat("\n") str(list(list(x, y = 2:1))) }, file = test_path("test-list_of-str.txt") ) expect_known_output({ str(x[0]) cat("\n") str(list(list(x, y = 2:1))) }, file = test_path("test-list_of-str-empty.txt") ) }) # Subsetting -------------------------------------------------------------- test_that("[ preserves type", { x <- list_of(1) expect_equal(x[1], x) }) test_that("[<-, [[<- and $<- coerce their input", { x <- list_of(x = 1, y = 1, z = 1, w = 1) x[1] <- list(FALSE) expect_identical(x, list_of(x = 0, y = 1, z = 1, w = 1)) x[[2]] <- FALSE expect_identical(x, list_of(x = 0, y = 0, z = 1, w = 1)) x$z <- FALSE expect_identical(x, list_of(x = 0, y = 0, z = 0, w = 1)) x[3:4] <- c(TRUE, FALSE) expect_identical(x, list_of(x = 0, y = 0, z = 1, w = 0)) x[[2]] <- NULL expect_equal(x, list_of(x = 0, y = NULL, z = 1, w = 0)) expect_error(x[[2]] <- list(20), class = "vctrs_error_incompatible_type") expect_error(x$y <- list(20), class = "vctrs_error_incompatible_type") x[3:4] <- list(NULL) expect_equal(x, list_of(x = 0, y = NULL, z = NULL, w = NULL)) expect_equal(is.na(x), c(FALSE, TRUE, TRUE, TRUE)) }) test_that("assingment can increase size of vector", { x <- list_of(x = 1) x[[2]] <- 2 x$z <- 3 x[4:5] <- c(4,5) expect_length(x, 5) }) # Type system ------------------------------------------------------------- test_that("list_of() are vectors", { expect_true(vec_is_vector(list_of(1))) expect_true(vec_is(list_of(1))) }) test_that("list coercions are symmetric and unchanging", { types <- list( list(), list_of(.ptype = integer()), list_of(.ptype = double()), list_of(.ptype = character()) ) mat <- maxtype_mat(types) expect_true(isSymmetric(mat)) expect_known_output( mat, test_path("test-list_of-type.txt"), print = TRUE, width = 200 ) }) test_that("max, list_of> is list_of>", { r_int <- list_of(.ptype = integer()) r_dbl <- list_of(.ptype = double()) expect_equal(vec_ptype_common(r_int, r_int), r_int) expect_equal(vec_ptype_common(r_int, r_dbl), r_int) }) test_that("safe casts work as expected", { x <- list_of(1) expect_equal(vec_cast(NULL, x), NULL) expect_equal(vec_cast(1L, x), x) expect_equal(vec_cast(1, x), x) expect_equal(vec_cast(list(1), x), x) expect_equal(vec_cast(list(TRUE), x), x) expect_equal(vec_cast(NA, x), list_of(NULL, .ptype = double())) expect_identical(vec_cast(x, list()), list(1)) }) test_that("lossy casts generate warning", { expect_lossy( vec_cast(list(c(1.5, 1), 1L), to = list_of(1L)), list_of(int(1L, 1L), 1L), x = dbl(), to = int() ) }) test_that("invalid casts generate error", { expect_error(vec_cast(factor("a"), list_of(1)), class = "vctrs_error_incompatible_cast") }) test_that("validation", { expect_error(validate_list_of(list_of(1, 2, 3)), NA) expect_error( validate_list_of(new_list_of(list(1, "a", 3), dbl())), class = "vctrs_error_cast_lossy" ) }) test_that("list_of() has as.character() method (tidyverse/tidyr#654)", { exp <- rep(paste0("<", vec_ptype_abbr(mtcars), ">"), 2) expect_identical(as.character(list_of(mtcars, mtcars)), exp) }) test_that("vec_ptype2(>, NA) is symmetric (#687)", { lof <- list_of(1, 2, 3) expect_identical(vec_ptype2(lof, NA), vec_ptype(lof)) expect_identical(vec_ptype2(NA, lof), vec_ptype(lof)) }) vctrs/tests/testthat/test-print-str-attr.txt0000644000176200001440000000032113623022034021034 0ustar liggesusers int [1:100] 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16... @ x: chr "a string" @ y: int [1:20] 1 2 3 4 5 6 7 8 9 10 ... @ z:'data.frame': 3 obs. of 1 variable: ..$ x: int [1:3] 1 2 3 vctrs/tests/testthat/test-type-integer64.R0000644000176200001440000001020213622451540020300 0ustar liggesuserscontext("test-type-integer64") test_that("casting of integer64 works", { x <- bit64::as.integer64(1:10) expect_equal(vec_cast(x, bit64::integer64()), x) expect_equal(vec_cast(x, integer()), 1:10) expect_equal(vec_cast(1:10, bit64::integer64()), x) expect_equal(vec_cast(x, double()), as.double(x)) expect_equal(vec_cast(as.numeric(1:10), bit64::integer64()), x) expect_equal(vec_cast(x, character()), as.character(x)) expect_equal(vec_cast(as.character(1:10), bit64::integer64()), x) expect_equal(vec_cast(x, logical()), rep(TRUE, 10L)) expect_equal(vec_cast(c(TRUE, FALSE), bit64::integer64()), bit64::as.integer64(c(1, 0))) expect_equal(vec_cast(NA, bit64::integer64()), bit64::as.integer64(NA)) expect_equal(vec_cast(unspecified(2), bit64::integer64()), bit64::as.integer64(c(NA, NA))) expect_error(vec_cast(x, factor()), class = "vctrs_error_incompatible_cast") expect_error(vec_cast(factor(), x), class = "vctrs_error_incompatible_cast") }) test_that("vec_ptype2 for integer64 works", { x <- bit64::as.integer64(1:10) expect_equal(vec_ptype2(x, x), bit64::integer64()) expect_equal(vec_ptype2(x, 1L), bit64::integer64()) expect_equal(vec_ptype2(1L, x), bit64::integer64()) expect_equal(vec_ptype2(x, TRUE), bit64::integer64()) expect_equal(vec_ptype2(TRUE, x), bit64::integer64()) expect_equal(vec_ptype2(x, NA), bit64::integer64()) expect_equal(vec_ptype2(NA, x), bit64::integer64()) expect_equal(vec_ptype2(unspecified(), x), bit64::integer64()) expect_equal(vec_ptype2(x, unspecified()), bit64::integer64()) expect_error(vec_ptype2(x, 1)) expect_error(vec_ptype2(1, x)) expect_error(vec_ptype2(x, "")) expect_error(vec_ptype2("", x)) expect_error(vec_ptype2(data.frame(), x)) expect_error(vec_ptype2(x, data.frame())) }) test_that("vec_ptype_abbr.integer64", { expect_equal(vec_ptype_abbr(bit64::as.integer64(1:10)), "int64") expect_equal(vec_ptype_full(bit64::as.integer64(1:10)), "integer64") }) test_that("can sort integer64", { x <- bit64::as.integer64(c(-1, -3, -2, 1)) expect_identical(vec_order(x), int(2, 3, 1, 4)) expect_identical(x[vec_order(x)], bit64::as.integer64(c(-3, -2, -1, 1))) }) test_that("can slice integer64 objects of all dimensions", { x <- bit64::as.integer64(1:8) expect <- bit64::as.integer64(c(1, 3)) expect_identical(vec_slice(x, c(1, 3)), expect) dim(x) <- c(4, 2) expect <- bit64::as.integer64(c(1, 3, 5, 7)) dim(expect) <- c(2, 2) expect_identical(vec_slice(x, c(1, 3)), expect) dim(x) <- c(2, 2, 2) expect <- bit64::as.integer64(c(2, 4, 6, 8)) dim(expect) <- c(1, 2, 2) expect_identical(vec_slice(x, 2), expect) }) test_that("can slice integer64 objects with `NA_integer_`", { idx <- c(NA_integer_, 1) x <- bit64::as.integer64(1:8) expect <- bit64::as.integer64(c(NA, 1)) expect_identical(vec_slice(x, idx), expect) dim(x) <- c(4, 2) expect <- bit64::as.integer64(c(NA, 1, NA, 5)) dim(expect) <- c(2, 2) expect_identical(vec_slice(x, idx), expect) dim(x) <- c(2, 2, 2) expect <- bit64::as.integer64(c(NA, 1, NA, 3, NA, 5, NA, 7)) dim(expect) <- c(2, 2, 2) expect_identical(vec_slice(x, idx), expect) }) test_that("can init integer64 objects", { idx <- c(NA_integer_, NA_integer_) x <- bit64::as.integer64(1:8) expect_identical(vec_init(x, 2), vec_slice(x, idx)) dim(x) <- c(4, 2) expect_identical(vec_init(x, 2), vec_slice(x, idx)) dim(x) <- c(2, 2, 2) expect_identical(vec_init(x, 2), vec_slice(x, idx)) }) test_that("can chop integer64 objects with `NA_integer_` indices", { idx <- list(NA_integer_, 1) x <- bit64::as.integer64(1:8) expect <- list( bit64::as.integer64(NA), bit64::as.integer64(1) ) expect_identical(vec_chop(x, idx), expect) dim(x) <- c(4, 2) expect <- list( bit64::as.integer64(c(NA, NA)), bit64::as.integer64(c(1, 5)) ) dim(expect[[1]]) <- c(1, 2) dim(expect[[2]]) <- c(1, 2) expect_identical(vec_chop(x, idx), expect) dim(x) <- c(2, 2, 2) expect <- list( bit64::as.integer64(c(NA, NA, NA, NA)), bit64::as.integer64(c(1, 3, 5, 7)) ) dim(expect[[1]]) <- c(1, 2, 2) dim(expect[[2]]) <- c(1, 2, 2) expect_identical(vec_chop(x, idx), expect) }) vctrs/tests/testthat/test-type-factor.txt0000644000176200001440000000027013623022051020361 0ustar liggesusers ordered<> factor<> character ordered<> "ordered<>" NA "character" factor<> NA "factor<>" "character" character "character" "character" "character" vctrs/tests/testthat/test-group.R0000644000176200001440000001351513622451540016660 0ustar liggesuserscontext("test-group") # group id ---------------------------------------------------------------- test_that("vec_group_id detects groups in order of appearance", { x <- c(2, 4, 2, 1, 4) expect <- structure(c(1L, 2L, 1L, 3L, 2L), n = 3L) expect_equal(vec_group_id(x), expect) }) test_that("vec_group_id works for size 0 input", { expect <- structure(integer(), n = 0L) expect_equal(vec_group_id(NULL), expect) expect_equal(vec_group_id(numeric()), expect) }) test_that("vec_group_id works on base S3 objects", { x <- factor(c("x", "y", "x")) expect <- structure(c(1L, 2L, 1L), n = 2L) expect_equal(vec_group_id(x), expect) x <- new_date(c(0, 1, 0)) expect <- structure(c(1L, 2L, 1L), n = 2L) expect_equal(vec_group_id(x), expect) }) test_that("vec_group_id works row wise on data frames", { df <- data.frame(x = c(1, 2, 1, 1), y = c(2, 3, 2, 3)) expect <- structure(c(1L, 2L, 1L, 3L), n = 3L) expect_equal(vec_group_id(df), expect) }) test_that("vec_group_id works row wise on arrays", { x <- array(c(1, 1, 1, 2, 4, 2), c(3, 2)) expect <- structure(c(1L, 2L, 1L), n = 2L) expect_equal(vec_group_id(x), expect) }) test_that("vec_group_id works with different encodings", { expect <- structure(c(1L, 1L, 1L), n = 1L) expect_equal(vec_group_id(encodings()), expect) }) test_that("vec_group_id takes the equality proxy", { local_comparable_tuple() x <- tuple(c(1, 2, 1, 1), c(1, 1, 1, 2)) # Compares on only the first field expect <- structure(c(1L, 2L, 1L, 1L), n = 2L) expect_equal(vec_group_id(x), expect) }) test_that("vec_group_id takes the equality proxy recursively", { local_comparable_tuple() x <- tuple(c(1, 2, 1, 1), 1:4) df <- data_frame(x = x) expect <- structure(c(1L, 2L, 1L, 1L), n = 2L) expect_equal(vec_group_id(df), expect) }) # group rle --------------------------------------------------------------- test_that("vec_group_rle returns a `vctrs_group_rle` object", { expect_is(vec_group_rle(1), "vctrs_group_rle") }) test_that("vec_group_rle works with size 0 input", { expect <- new_group_rle(integer(), integer(), 0L) expect_equal(vec_group_rle(integer()), expect) expect_equal(vec_group_rle(NULL), expect) }) test_that("vec_group_rle detects groups in order of appearance", { x <- c(2, 2, 3, 1, 1) expect <- new_group_rle(1:3, c(2L, 1L, 2L), 3L) expect_equal(vec_group_rle(x), expect) }) test_that("vec_group_rle can refer to groups it has already seen", { x <- c(2, 3, 2) expect <- new_group_rle(c(1L, 2L, 1L), rep(1L, 3), 2L) expect_equal(vec_group_rle(x), expect) }) test_that("vec_group_rle works on base S3 objects", { expect <- new_group_rle(c(1L, 2L, 1L, 3L), c(1L, 2L, 1L, 1L), 3L) x <- factor(c("x", "y", "y", "x", "z")) expect_equal(vec_group_rle(x), expect) x <- new_date(c(0, 1, 1, 0, 2)) expect_equal(vec_group_rle(x), expect) }) test_that("vec_group_rle takes the equality proxy", { local_comparable_tuple() x <- tuple(c(1, 2, 1, 1), c(1, 1, 1, 2)) # Compares on only the first field expect <- new_group_rle(c(1L, 2L, 1L), c(1L, 1L, 2L), 2L) expect_equal(vec_group_rle(x), expect) }) test_that("vec_group_rle works row wise on data frames", { df <- data.frame(x = c(1, 1, 2, 1), y = c(2, 2, 3, 2)) expect <- new_group_rle(c(1L, 2L, 1L), c(2L, 1L, 1L), 2L) expect_equal(vec_group_rle(df), expect) }) test_that("vec_group_rle takes the equality proxy recursively", { local_comparable_tuple() x <- tuple(c(1, 2, 1, 1), 1:4) df <- data_frame(x = x) expect <- new_group_rle(c(1L, 2L, 1L), c(1L, 1L, 2L), 2L) expect_equal(vec_group_rle(df), expect) }) test_that("can access fields", { x <- vec_group_rle(c(1, 1, 2)) expect_equal(fields(x), c("group", "length")) expect_identical(field(x, "group"), c(1L, 2L)) expect_identical(field(x, "length"), c(2L, 1L)) }) test_that("can access number of groups", { x <- vec_group_rle(c(1, 1, 2)) expect_identical(attr(x, "n"), 2L) }) test_that("print method is useful", { x <- new_group_rle(c(1L, 2L, 1L), c(3L, 2L, 1L), 2L) expect_known_output(print(x), file = test_path("test-type-group-rle.txt")) }) # group loc -------------------------------------------------------------- test_that("can locate unique groups of an empty vector", { out <- vec_group_loc(integer()) expect_s3_class(out, "data.frame") expect_equal(out$key, integer()) expect_equal(out$loc, list()) }) test_that("can locate unique groups of a data frame", { df <- data_frame(x = c(1, 1, 1, 2, 2), y = c("a", "a", "b", "a", "b")) out <- vec_group_loc(df) expect_equal(nrow(out), 4L) expect_equal(out$key, vec_unique(df)) }) test_that("can locate unique groups of a data frame with a list column", { df <- data_frame(x = list(1:2, 1:2, "a", 5.5, "a")) out <- vec_group_loc(df) expect_equal(nrow(out), 3L) expect_equal(out$key, vec_unique(df)) }) test_that("`x` must be a vector", { expect_error(vec_group_loc(environment()), class = "vctrs_error_scalar_type") }) test_that("`key` column retains full type information", { x <- factor(letters[c(1, 2, 1)], levels = letters[1:3]) out <- vec_group_loc(x) expect_equal(levels(out$key), levels(x)) }) test_that("vec_group_loc takes the equality proxy", { local_comparable_tuple() x <- tuple(c(1, 2, 1), 1:3) expect_equal(vec_group_loc(x)$key, x[1:2]) expect_equal(vec_group_loc(x)$loc, list(c(1L, 3L), 2L)) x <- as.POSIXlt(new_datetime(c(1, 2, 1))) expect_equal(vec_group_loc(x)$key, x[1:2]) expect_equal(vec_group_loc(x)$loc, list(c(1L, 3L), 2L)) }) test_that("vec_group_loc takes the equality proxy recursively", { local_comparable_tuple() x <- tuple(c(1, 2, 1, 1), 1:4) df <- data_frame(x = x) expect <- data_frame(key = vec_slice(df, c(1, 2)), loc = list(c(1L, 3L, 4L), 2L)) expect_equal(vec_group_loc(df), expect) }) test_that("vec_group_loc works with different encodings", { encs <- encodings() expect_identical(nrow(vec_group_loc(encs)), 1L) }) vctrs/tests/testthat/test-c.R0000644000176200001440000001412113622451540015740 0ustar liggesuserscontext("test-c") test_that("zero length input returns NULL", { expect_equal(vec_c(), NULL) expect_equal(vec_c(NULL), NULL) expect_equal(vec_c(NULL,), NULL) expect_equal(vec_c(NULL, NULL), NULL) }) test_that("NULL is idempotent", { expect_equal(vec_c(NULL, 1L), 1L) expect_equal(vec_c(1L, NULL), 1L) }) test_that("NA is idempotent", { expect_equal(vec_c(NA, 1L), c(NA, 1L)) expect_equal(vec_c(NA, "x"), c(NA, "x")) expect_equal(vec_c(NA, factor("x")), factor(c(NA, "x"))) expect_equal(vec_c(NA, new_date(0)), new_date(c(NA, 0))) expect_equal(vec_c(NA, new_datetime(0)), new_datetime(c(NA, 0))) expect_equal(vec_c(NA, new_duration(0)), new_duration(c(NA, 0))) }) test_that("NA is logical if no other types intervene", { expect_equal(vec_c(logical()), logical()) expect_equal(vec_c(NA), NA) expect_equal(vec_c(NA, NA), c(NA, NA)) }) test_that("different types are coerced to common", { expect_equal(vec_c(TRUE, 1L, 1), c(1, 1, 1)) expect_equal(vec_c(TRUE, 2:4), 1:4) }) test_that("specified .ptypes allows more casts", { expect_equal(vec_c(TRUE, .ptype = character()), "TRUE") }) test_that("combines outer an inner names", { expect_equal(vec_c(x = 1), c(x = 1)) expect_equal(vec_c(c(x = 1)), c(x = 1)) expect_equal(vec_c(c(x = 1:2)), c(x1 = 1, x2 = 2)) expect_error(vec_c(y = c(x = 1)), "Please supply") }) test_that("can bind data.frame columns", { df <- data.frame(x = NA, y = 1:2) df$x <- data.frame(a = 1:2) expected <- data.frame(x = NA, y = c(1:2, 1:2)) expected$x <- data.frame(a = c(1:2, 1:2)) expect_equal(vec_c(df, df), expected) }) test_that("vec_c() handles matrices", { m <- matrix(1:4, nrow = 2) dimnames(m) <- list(c("foo", "bar"), c("baz", "quux")) # FIXME: `vec_ptype_common(m, m)` doesn't return dimension names exp <- matrix(c(1:2, 1:2, 3:4, 3:4), nrow = 4) rownames(exp) <- c("foo", "bar", "foo", "bar") expect_identical(vec_c(m, m), exp) expect_error(vec_c(outer = m), "Please supply") }) test_that("vec_c() includes index in argument tag", { df1 <- tibble(x = tibble(y = tibble(z = 1))) df2 <- tibble(x = tibble(y = tibble(z = "a"))) expect_known_output(file = test_path("test-type-vec-c-error.txt"), { try2(vec_c(df1, df2)) try2(vec_c(df1, df1, df2)) try2(vec_c(foo = df1, bar = df2)) }) }) test_that("vec_c() handles record classes", { local_rational_class() out <- vec_c(rational(1, 2), 1L, NA) expect_true(vec_is(out, rational(1, 2))) expect_size(out, 3) expect_identical(vec_proxy(out), data.frame(n = c(1L, 1L, NA), d = c(2L, 1L, NA))) }) test_that("can mix named and unnamed vectors (#271)", { expect_identical(vec_c(c(a = 1), 2), c(a = 1, 2)) expect_identical(vec_c(0, c(a = 1), 2, b = 3), c(0, a = 1, 2, b =3)) }) test_that("vec_c() repairs names", { # Default minimal repair expect_named(vec_c(a = 1, a = 2, `_` = 3), c("a", "a", "_")) out <- vec_c(!!!set_names(1, NA)) expect_named(out, "") expect_named(vec_c(a = 1, a = 2, `_` = 3, .name_repair = "unique"), c("a...1", "a...2", "_")) expect_error(vec_c(a = 1, a = 2, `_` = 3, .name_repair = "check_unique"), class = "vctrs_error_names_must_be_unique") expect_named(vec_c(a = 1, a = 2, `_` = 3, .name_repair = "universal"), c("a...1", "a...2", "._")) expect_named(vec_c(a = 1, a = 2, .name_repair = ~ toupper(.)), c("A", "A")) }) test_that("vec_c() doesn't use outer names for data frames (#524)", { x <- data.frame(inner = 1) expect_equal(vec_c(outer = x), x) a <- data.frame(x = 1L) b <- data.frame(x = 2L) expect_equal(vec_c(foo = a, bar = b), data.frame(x = 1:2)) }) test_that("vec_c() drops data frame row names", { x <- data.frame(a = 1, row.names = "r1") y <- data.frame(a = 2, row.names = "r2") expect_equal(rownames(vec_c(x, y)), c("1", "2")) }) test_that("vec_c() outer names work with proxied objects", { x <- as.POSIXlt(new_datetime(0)) exp <- set_names(x, "outer") expect_equal(vec_c(outer = x), exp) named_x <- set_names(x, "inner") exp <- set_names(named_x, "outer_inner") expect_error(vec_c(outer = named_x), "Please supply") expect_equal(vec_c(outer = named_x, .name_spec = "{outer}_{inner}"), exp) xs <- as.POSIXlt(new_datetime(c(0, 1))) exp <- set_names(xs, c("outer_1", "outer_2")) expect_error(vec_c(outer = xs), "Please supply") expect_equal(vec_c(outer = xs, .name_spec = "{outer}_{inner}"), exp) }) test_that("vec_c() falls back to c() for foreign classes", { verify_errors({ expect_error( vec_c(foobar(1), foobar(2)), "concatenation" ) }) expect_error( vec_c(NULL, foobar(1), foobar(2)), "concatenation" ) # Check off-by-one error expect_error( vec_c(foobar(1), "", foobar(2)), class = "vctrs_error_incompatible_type" ) # Fallback when the class implements `c()` method <- function(...) rep_along(list(...), "dispatched") local_methods( c.vctrs_foobar = method ) expect_identical( vec_c(foobar(1), foobar(2)), c("dispatched", "dispatched") ) expect_identical( vec_c(NULL, foobar(1), NULL, foobar(2)), c("dispatched", "dispatched") ) # Registered fallback s3_register("base::c", "vctrs_c_fallback", method) expect_identical( vec_c( structure(1, class = "vctrs_c_fallback"), structure(2, class = "vctrs_c_fallback") ), c("dispatched", "dispatched") ) # Don't fallback for S3 lists which are treated as scalars by default expect_error( vec_c(foobar(list(1)), foobar(list(2))), class = "vctrs_error_scalar_type" ) }) test_that("vec_c() fallback doesn't support `name_spec` or `ptype`", { verify_errors({ expect_error( vec_c(foobar(1), foobar(2), .name_spec = "{outer}_{inner}"), "name specification" ) expect_error( vec_c(foobar(1), foobar(2), .ptype = ""), "prototype" ) }) }) test_that("vec_c() has informative error messages", { verify_output(test_path("error", "test-c.txt"), { "# vec_c() falls back to c() for foreign classes" vec_c(foobar(1), foobar(2)) "# vec_c() fallback doesn't support `name_spec` or `ptype`" vec_c(foobar(1), foobar(2), .name_spec = "{outer}_{inner}") vec_c(foobar(1), foobar(2), .ptype = "") }) }) vctrs/tests/testthat/test-type-date-time.txt0000644000176200001440000000200513623022051020752 0ustar liggesusers date datetime datetime POSIXlt duration duration date "date" "datetime" "datetime" "datetime" NA NA datetime "datetime" "datetime" "datetime" "datetime" NA NA datetime "datetime" "datetime" "datetime" "datetime" NA NA POSIXlt "datetime" "datetime" "datetime" "datetime" NA NA duration NA NA NA NA "duration" "duration" duration NA NA NA NA "duration" "duration" vctrs/tests/testthat/test-partial-factor-print-empty.txt0000644000176200001440000000002313623022034023317 0ustar liggesuserspartial_factor< > vctrs/tests/testthat/test-bind.R0000644000176200001440000003552713623014440016442 0ustar liggesuserscontext("test-bind") # rows -------------------------------------------------------------------- test_that("empty inputs return an empty data frame", { expect_equal(vec_rbind(), data_frame()) expect_equal(vec_rbind(NULL, NULL), data_frame()) }) test_that("NULL is idempotent", { df <- data_frame(x = 1) expect_equal(vec_rbind(df, NULL), df) }) test_that("output is tibble if any input is tibble", { df <- data_frame(x = 1) dt <- tibble::tibble(x = 1) expect_s3_class(vec_rbind(dt), "tbl_df") expect_s3_class(vec_rbind(dt, df), "tbl_df") expect_s3_class(vec_rbind(df, dt), "tbl_df") }) test_that("type of column is common type of individual columns", { x_int <- data_frame(x = 1L) x_dbl <- data_frame(x = 2.5) x_chr <- data_frame(x = "a") expect_equal(vec_rbind(x_int, x_int), data_frame(x = c(1L, 1L))) expect_equal(vec_rbind(x_int, x_dbl), data_frame(x = c(1, 2.5))) expect_error(vec_rbind(x_int, x_chr), class = "vctrs_error_incompatible_type") }) test_that("result contains union of columns", { expect_named( vec_rbind( data_frame(x = 1), data_frame(y = 1) ), c("x" , "y") ) expect_named( vec_rbind( data_frame(y = 1, x = 1), data_frame(y = 1, z = 2) ), c("y", "x", "z") ) }) test_that("all inputs coerced to data frames", { expect_equal( vec_rbind(data_frame(x = 1L), c(x = 1.5)), data_frame(x = c(1, 1.5)) ) }) test_that("names are supplied if needed", { expect_message(out <- vec_rbind(data_frame(...1 = 1), 1), "->") expect_equal(out, data_frame(...1 = c(1, 1))) }) test_that("matrix becomes data frame and has names properly repaired", { x <- matrix(1:4, nrow = 2) expect_equal(vec_rbind(x), data.frame(...1 = 1:2, ...2 = 3:4)) }) test_that("can bind data.frame columns", { df <- data.frame(x = NA, y = 1:2) df$x <- data.frame(a = 1:2) expected <- data.frame(x = NA, y = c(1:2, 1:2)) expected$x <- data.frame(a = c(1:2, 1:2)) expect_equal(vec_rbind(df, df), expected) }) test_that("can rbind unspecified vectors", { df <- data.frame(x = 1) expect_identical(vec_rbind(NA, df), data.frame(x = c(NA, 1))) expect_identical(vec_rbind(df, NA), data.frame(x = c(1, NA))) expect_identical(vec_rbind(NA, df, NA), data.frame(x = c(NA, 1, NA))) expect_identical(vec_rbind(c(x = NA), data.frame(x = 1)), data.frame(x = c(NA, 1))) expect_identical(vec_rbind(c(y = NA), df), data.frame(y = c(NA, NA), x = c(NA, 1))) out <- suppressMessages(vec_rbind(c(x = NA, x = NA), df)) exp <- data.frame(x...1 = c(NA, NA), x...2 = c(NA, NA), x = c(NA, 1)) expect_identical(out, exp) }) test_that("as_df_row() tidies the names of unspecified vectors", { expect_identical(as_df_row(c(NA, NA)), c(NA, NA)) expect_identical(as_df_row(unspecified(2)), unspecified(2)) expect_identical(as_df_row(c(a = NA, a = NA), quiet = TRUE), data.frame(a...1 = NA, a...2 = NA)) expect_identical(as_df_row(c(a = TRUE, a = TRUE), quiet = TRUE), data.frame(a...1 = TRUE, a...2 = TRUE)) }) test_that("can rbind spliced lists", { data <- list(c(a = 1, b = 2), c(a = TRUE, b = FALSE)) expect_identical(vec_rbind(!!!data), data_frame(a = c(1, 1), b = c(2, 0))) }) test_that("can rbind list columns", { out <- vec_rbind(data_frame(x = list(1, 2)), data_frame(x = list(3))) expect_identical(out, data_frame(x = list(1, 2, 3))) }) test_that("can rbind lists", { out <- vec_rbind(list(x = 1:2)) expect_identical(out, data_frame(x = list(c(1L, 2L)))) out <- vec_rbind(list(x = 1:2, y = 3L)) expect_identical(out, data_frame(x = list(c(1L, 2L)), y = list(3L))) out <- vec_rbind(list(x = 1, y = 2), list(y = "string")) expect_identical(out, data_frame(x = list(1, NULL), y = list(2, "string"))) }) test_that("can rbind factors", { fctr <- factor(c("a", "b")) expect_equal(vec_rbind(fctr), data_frame(...1 = fctr[1], ...2 = fctr[2])) fctr_named <- set_names(fctr) expect_equal(vec_rbind(fctr_named), data_frame(a = fctr[1], b = fctr[2])) }) test_that("can rbind dates", { date <- new_date(c(0, 1)) expect_equal(vec_rbind(date), data_frame(...1 = date[1], ...2 = date[2])) date_named <- set_names(date, c("a", "b")) expect_equal(vec_rbind(date_named), data_frame(a = date[1], b = date[2])) }) test_that("can rbind POSIXlt objects into POSIXct objects", { datetime <- as.POSIXlt(new_datetime(0)) expect_is(vec_rbind(datetime, datetime)[[1]], "POSIXct") datetime_named <- set_names(datetime, "col") expect_named(vec_rbind(datetime_named, datetime_named), "col") }) test_that("can rbind missing vectors", { expect_identical(vec_rbind(na_int), data_frame(...1 = na_int)) expect_identical(vec_rbind(na_int, na_int), data_frame(...1 = int(na_int, na_int))) }) test_that("can rbind unspecified vectors", { expect_identical(vec_rbind(NA), data_frame(...1 = NA)) expect_identical(vec_rbind(NA, NA), data_frame(...1 = lgl(NA, NA))) }) test_that("vec_rbind() respects size invariants (#286)", { expect_identical(vec_rbind(), new_data_frame(n = 0L)) expect_identical(vec_rbind(int(), int()), new_data_frame(n = 2L)) expect_identical(vec_rbind(int(), TRUE), new_data_frame(list(...1 = lgl(NA, TRUE)))) expect_identical(vec_rbind(int(), new_data_frame(n = 2L), int()), new_data_frame(n = 4L)) }) test_that("can repair names in `vec_rbind()` (#229)", { expect_error(vec_rbind(.name_repair = "none"), "can't be `\"none\"`") expect_error(vec_rbind(.name_repair = "minimal"), "can't be `\"minimal\"`") expect_named(vec_rbind(list(a = 1, a = 2), .name_repair = "unique"), c("a...1", "a...2")) expect_error(vec_rbind(list(a = 1, a = 2), .name_repair = "check_unique"), class = "vctrs_error_names_must_be_unique") expect_named(vec_rbind(list(`_` = 1)), "_") expect_named(vec_rbind(list(`_` = 1), .name_repair = "universal"), c("._")) expect_named(vec_rbind(list(a = 1, a = 2), .name_repair = ~ toupper(.)), c("A", "A")) }) test_that("can construct an id column", { df <- data.frame(x = 1) expect_named(vec_rbind(df, df, .names_to = "id"), c("x", "id")) expect_equal(vec_rbind(df, df, .names_to = "id")$id, c(1L, 2L)) expect_equal(vec_rbind(a = df, b = df, .names_to = "id")$id, c("a", "b")) expect_equal(vec_rbind(a = df, df, .names_to = "id")$id, c("a", "")) }) test_that("vec_rbind() fails with arrays of dimensionality > 3", { expect_error(vec_rbind(array(NA, c(1, 1, 1))), "Can't bind arrays") }) test_that("row names are preserved by vec_rbind()", { df1 <- mtcars[1:3, ] df2 <- mtcars[4:5, ] expect_identical(vec_rbind(df1, df2), mtcars[1:5, ]) row.names(df2) <- NULL out <- mtcars[1:5, ] row.names(out) <- c(row.names(df1), "...4", "...5") expect_identical(vec_rbind(df1, df2), out) }) test_that("can assign row names in vec_rbind()", { df1 <- mtcars[1:3, ] df2 <- mtcars[4:5, ] # Combination out <- vec_rbind(foo = df1, df2) exp <- mtcars[1:5, ] row.names(exp) <- c(paste0("foo...", row.names(df1)), row.names(df2)) expect_identical(out, exp) out <- vec_rbind(foo = df1, df2, .names_to = "id") exp <- mtcars[1:5, ] exp$id <- c(rep("foo", 3), rep("", 2)) expect_identical(out, exp) # Sequence out <- vec_rbind(foo = unrownames(df1), df2, bar = unrownames(mtcars[6, ])) exp <- mtcars[1:6, ] row.names(exp) <- c(paste0("foo", 1:3), row.names(df2), "bar") expect_identical(out, exp) out <- vec_rbind(foo = unrownames(df1), df2, bar = unrownames(mtcars[6, ]), .names_to = "id") exp <- mtcars[1:6, ] exp$id <- c(rep("foo", 3), rep("", 2), "bar") row.names(exp) <- c(paste0("...", 1:3), row.names(df2), "...6") expect_identical(out, exp) }) # cols -------------------------------------------------------------------- test_that("empty inputs give data frame", { expect_equal(vec_cbind(), data_frame()) expect_equal(vec_cbind(NULL), data_frame()) expect_equal(vec_cbind(data.frame(a = 1), NULL), data_frame(a = 1)) }) test_that("NULL is idempotent", { df <- data_frame(x = 1) expect_equal(vec_cbind(df, NULL), df) }) test_that("outer names are respected", { expect_named(vec_cbind(x = 1, y = 4), c("x", "y")) expect_named(vec_cbind(a = data.frame(x = 1)), "a") }) test_that("inner names are respected", { expect_named(vec_cbind(data_frame(x = 1), data_frame(y = 1)), c("x", "y")) }) test_that("nameless vectors get tidy defaults", { expect_named(vec_cbind(1:2, 1), c("...1", "...2")) }) test_that("matrix becomes data frame", { x <- matrix(1:4, nrow = 2) expect_equal(vec_cbind(x), data.frame(...1 = 1:2, ...2 = 3:4)) # Packed if named expect_equal(vec_cbind(x = x), data_frame(x = x)) }) test_that("duplicate names are de-deduplicated", { expect_message( expect_named(vec_cbind(x = 1, x = 1), c("x...1", "x...2")), "x -> x...1", fixed = TRUE ) expect_named(vec_cbind(data.frame(x = 1), data.frame(x = 1)), c("x...1", "x...2")) }) test_that("rows recycled to longest", { df <- data.frame(x = 1:3) expect_dim(vec_cbind(df), c(3, 1)) expect_dim(vec_cbind(df, NULL), c(3, 1)) expect_dim(vec_cbind(df, y = 1), c(3, 2)) expect_dim(vec_cbind(data.frame(x = 1), y = 1:3), c(3, 2)) expect_dim( vec_cbind( data.frame(a = 1, b = 2), y = 1:3 ), c(3, 3) ) }) test_that("output is tibble if any input is tibble", { df <- data.frame(x = 1) dt <- tibble::tibble(y = 2) expect_s3_class(vec_cbind(dt), "tbl_df") expect_s3_class(vec_cbind(df, dt), "tbl_df") expect_s3_class(vec_cbind(dt, df), "tbl_df") }) test_that("can override default .nrow", { expect_dim(vec_cbind(1, .size = 3), c(3, 1)) }) test_that("can repair names in `vec_cbind()` (#227)", { expect_error(vec_cbind(a = 1, a = 2, .name_repair = "none"), "can't be `\"none\"`") expect_named(vec_cbind(a = 1, a = 2, .name_repair = "unique"), c("a...1", "a...2")) expect_error(vec_cbind(a = 1, a = 2, .name_repair = "check_unique"), class = "vctrs_error_names_must_be_unique") expect_named(vec_cbind(`_` = 1, .name_repair = "universal"), "._") expect_named(vec_cbind(a = 1, a = 2, .name_repair = "minimal"), c("a", "a")) expect_named(vec_cbind(a = 1, a = 2, .name_repair = toupper), c("A", "A")) }) test_that("can supply `.names_to` to `vec_rbind()` (#229)", { expect_error(vec_rbind(.names_to = letters), "must be") expect_error(vec_rbind(.names_to = 10), "must be") x <- data_frame(foo = 1:2, bar = 3:4) y <- data_frame(foo = 5L, bar = 6L) expect_identical( vec_rbind(a = x, b = y, .names_to = "quux"), data_frame(foo = c(1L, 2L, 5L), bar = c(3L, 4L, 6L), quux = c("a", "a", "b")) ) expect_identical( vec_rbind(a = x, b = y, .names_to = "foo"), data_frame(foo = c("a", "a", "b"), bar = c(3L, 4L, 6L)) ) # No names expect_identical( vec_rbind(x, y, .names_to = "quux"), data_frame(foo = c(1L, 2L, 5L), bar = c(3L, 4L, 6L), quux = c(1L, 1L, 2L)) ) expect_identical( vec_rbind(x, y, .names_to = "foo"), data_frame(foo = c(1L, 1L, 2L), bar = c(3L, 4L, 6L)) ) # Partial names expect_identical(vec_rbind(x, b = y, .names_to = "quux")$quux, c("", "", "b")) }) test_that("vec_cbind() returns visibly (#452)", { # Shouldn't be needed once `check_unique` is implemented in C expect_visible(vctrs::vec_cbind(x = 1, .name_repair = "check_unique")) }) test_that("vec_cbind() packs named data frames (#446)", { expect_identical(vec_cbind(data_frame(y = 1:3)), data_frame(y = 1:3)) expect_identical(vec_cbind(x = data_frame(y = 1:3)), data_frame(x = data_frame(y = 1:3))) }) test_that("vec_cbind() packs 1d arrays", { a <- array(1:2) expect_identical(vec_cbind(a), data_frame(...1 = 1:2)) expect_identical(vec_cbind(x = a), data_frame(x = a)) }) test_that("vec_cbind() packs named matrices", { m <- matrix(1:4, 2) expect_identical(vec_cbind(m), data_frame(...1 = 1:2, ...2 = 3:4)) expect_identical(vec_cbind(x = m), data_frame(x = m)) }) test_that("vec_cbind() never packs named vectors", { expect_identical(vec_cbind(1:2), data_frame(...1 = 1:2)) expect_identical(vec_cbind(x = 1:2), data_frame(x = 1:2)) }) test_that("names are repaired late if unpacked", { out1 <- vec_cbind(a = 1, data_frame(b = 2, b = 3)) out2 <- vec_cbind(a = 1, as.matrix(data_frame(b = 2, b = 3))) out3 <- vec_cbind(a = 1, matrix(1:2, nrow = 1)) expect_named(out1, c("a", "b...2", "b...3")) expect_named(out2, c("a", "b...2", "b...3")) expect_named(out3, c("a", "...2", "...3")) }) test_that("names are not repaired if packed", { out1 <- vec_cbind(a = 1, packed = data_frame(b = 2, b = 3)) out2 <- vec_cbind(a = 1, packed = as.matrix(data_frame(b = 2, b = 3))) out3 <- vec_cbind(a = 1, packed = matrix(1:2, nrow = 1)) expect_named(out1, c("a", "packed")) expect_named(out2, c("a", "packed")) expect_named(out3, c("a", "packed")) expect_named(out1$packed, c("b", "b")) expect_identical(colnames(out2$packed), c("b", "b")) expect_identical(colnames(out3$packed), NULL) }) test_that("vec_cbind() fails with arrays of dimensionality > 3", { a <- array(NA, c(1, 1, 1)) expect_error(vec_cbind(a), "Can't bind arrays") expect_error(vec_cbind(x = a), "Can't bind arrays") }) test_that("vec_rbind() consistently handles unnamed outputs", { # Name repair of columns is a little weird but unclear we can do better expect_identical( vec_rbind(1, 2), data.frame(...1 = c(1, 2)) ) expect_identical( vec_rbind(1, 2, ...10 = 3), data.frame(...1 = c(1, 2, 3), row.names = c("...1", "...2", "...3")) ) expect_identical( vec_rbind(a = 1, b = 2), data.frame(...1 = c(1, 2), row.names = c("a", "b")) ) expect_identical( vec_rbind(c(a = 1), c(b = 2)), data.frame(a = c(1, NA), b = c(NA, 2)) ) }) test_that("vec_cbind() consistently handles unnamed outputs", { expect_identical( vec_cbind(1, 2), data.frame(...1 = 1, ...2 = 2) ) expect_identical( vec_cbind(1, 2, ...10 = 3), data.frame(...1 = 1, ...2 = 2, ...3 = 3) ) expect_identical( vec_cbind(a = 1, b = 2), data.frame(a = 1, b = 2) ) expect_identical( vec_cbind(c(a = 1), c(b = 2)), new_data_frame(list(...1 = c(a = 1), ...2 = c(b = 2))) ) }) test_that("rbind() and cbind() have informative outputs when repairing names", { verify_output(test_path("output", "bind-name-repair.txt"), { "# vec_rbind()" "Suboptimal" vec_rbind(1, 2) "Suboptimal" vec_rbind(1, 2, ...10 = 3) vec_rbind(a = 1, b = 2) vec_rbind(c(a = 1), c(b = 2)) "# vec_cbind()" vec_cbind(1, 2) vec_cbind(1, 2, ...10 = 3) vec_cbind(a = 1, b = 2) vec_cbind(c(a = 1), c(b = 2)) }) }) test_that("cbind() deals with row names", { expect_identical( vec_cbind(mtcars[1:3], foo = 1), cbind(mtcars[1:3], foo = 1) ) expect_identical( vec_cbind(mtcars[1:3], mtcars[4]), cbind(mtcars[1:3], mtcars[4]) ) out <- vec_cbind( mtcars[1, 1, drop = FALSE], unrownames(mtcars[1:3, 2, drop = FALSE]) ) exp <- mtcars[1:3, c(1, 2)] exp[[1]] <- exp[[1, 1]] row.names(exp) <- paste0(c("Mazda RX4..."), 1:3) expect_identical(out, exp) # Should work once we have frame prototyping expect_error( vec_cbind(mtcars[1:3], vec_slice(mtcars[4], nrow(mtcars):1)), "different row names" ) }) vctrs/tests/testthat/test-print-str-mtcars.txt0000644000176200001440000000121413623022034021355 0ustar liggesusersdf[,11] [1:32] $ mpg : num [1:32] 21 21 22.8 21.4 18.7 18.1 14.3 24.4 22.8 19.2 ... $ cyl : num [1:32] 6 6 4 6 8 6 8 4 4 6 ... $ disp: num [1:32] 160 160 108 258 360 ... $ hp : num [1:32] 110 110 93 110 175 105 245 62 95 123 ... $ drat: num [1:32] 3.9 3.9 3.85 3.08 3.15 2.76 3.21 3.69 3.92 3.92 ... $ wt : num [1:32] 2.62 2.88 2.32 3.21 3.44 ... $ qsec: num [1:32] 16.5 17 18.6 19.4 17 ... $ vs : num [1:32] 0 0 1 1 0 1 0 1 1 1 ... $ am : num [1:32] 1 1 1 0 0 0 0 0 0 0 ... $ gear: num [1:32] 4 4 4 3 3 3 3 4 4 4 ... $ carb: num [1:32] 4 4 1 1 2 1 4 2 2 4 ... @ row.names: chr [1:32] "Mazda RX4" "Mazda RX4 Wag" "Datsun 710" "Hornet 4 Drive" ... vctrs/tests/testthat/test-partial-factor-print-learned.txt0000644000176200001440000000003213623022034023573 0ustar liggesuserspartial_factor< df698 > vctrs/tests/testthat/helper-conditions.R0000644000176200001440000000147413622451540020176 0ustar liggesusers with_subscript_data <- function(expr, subscript_arg, subscript_elt = NULL, subscript_action = NULL) { local_options(rlang_force_unhandled_error = TRUE) tryCatch( expr, vctrs_error_subscript = function(cnd) { cnd$subscript_arg <- subscript_arg cnd$subscript_elt <- subscript_elt cnd$subscript_action <- subscript_action cnd_signal(cnd) } ) } with_tibble_cols <- function(expr) { with_subscript_data( expr, subscript_arg = quote(foo(bar)), subscript_elt = "column", subscript_action = "rename" ) } with_tibble_rows <- function(expr) { with_subscript_data( expr, subscript_arg = quote(foo(bar)), subscript_elt = "row", subscript_action = "remove" ) } vctrs/tests/testthat/test-type2.txt0000644000176200001440000000070013623022057017173 0ustar liggesusers logical integer double character raw list logical "logical" "integer" "double" NA NA NA integer "integer" "integer" "double" NA NA NA double "double" "double" "double" NA NA NA character NA NA NA "character" NA NA raw NA NA NA NA "raw" NA list NA NA NA NA NA "list" vctrs/tests/testthat/test-partial-factor-print-partial.txt0000644000176200001440000000004413623022034023620 0ustar liggesuserspartial_factor< 5a425 {partial} > vctrs/tests/testthat/helper-types.R0000644000176200001440000000465313623175311017173 0ustar liggesusers# Don't call tibble::tibble() to avoid catch-22, because tibble now uses vctrs bare_tibble <- structure(data.frame(), class = c("tbl_df", "tbl", "data.frame")) base_empty_types <- list( null = NULL, logical = lgl(), integer = int(), double = dbl(), complex = cpl(), character = chr(), raw = bytes(), list = list(), dataframe = data.frame() ) base_s3_empty_types <- list( bare_factor = new_factor(), bare_ordered = new_ordered(), bare_date = new_date(), bare_posixct = new_datetime(tzone = "UTC"), bare_posixlt = as.POSIXlt(new_datetime(tzone = "UTC")), bare_tibble = bare_tibble ) proxied_empty_types <- list( double = new_hidden(), dataframe = bare_tibble, dataframe = structure(data.frame(), class = c("vctrs_foobar", "data.frame")) ) empty_types <- c( base_empty_types, proxied_empty_types, # Non proxied type scalar = foobar(list()), scalar = function() NULL ) atomics <- list(TRUE, 1L, 1.0, 1i, "foo", bytes(1)) vectors <- c(atomics, list(list())) records <- list( df = data.frame(x = 1), rcrd = new_rcrd(list(x = 1)), posixlt = as.POSIXlt("2020-01-01") ) tuple <- function(x = integer(), y = integer()) { fields <- vec_recycle_common( x = vec_cast(x, integer()), y = vec_cast(y, integer()) ) new_rcrd(fields, class = "tuple") } tuple_methods <- list( format.tuple = function(x, ...) { paste0("(", field(x, "x"), ",", field(x, "y"), ")") }, vec_ptype2.tuple = function(x, y, ...) UseMethod("vec_ptype2.tuple", y), vec_ptype2.tuple.vctrs_unspecified = function(x, y, ...) tuple(), vec_ptype2.tuple.tuple = function(x, y, ...) tuple(), vec_ptype2.tuple.default = function(x, y, ..., x_arg = "x", y_arg = "y") { stop_incompatible_type(x, y, x_arg = x_arg, y_arg = y_arg) }, vec_cast.tuple = function(x, to, ...) UseMethod("vec_cast.tuple"), vec_cast.tuple.list = function(x, to, ...) vec_list_cast (x, to), vec_cast.tuple.tuple = function(x, to, ...) x ) local_tuple_methods <- function(frame = caller_env()) { local_methods(.frame = frame, !!!tuple_methods) } set_tuple_methods <- function(env = global_env()) { env_bind(env, !!!tuple_methods) } local_comparable_tuple <- function(frame = caller_env()) { local_tuple_methods(frame = frame) # Compare only on first field local_methods(.frame = frame, vec_proxy_equal.tuple = function(x, ...) field(x, "x") ) } c_na <- function(...) { x <- c(...) names(x)[names(x) == ""] <- NA_character_ x } vctrs/tests/testthat/test-arith.R0000644000176200001440000000151413622451540016627 0ustar liggesuserscontext("test-arith") test_that("logical/integer/numeric works", { expect_equal(vec_arith("+", TRUE, TRUE), 2L) expect_equal(vec_arith("+", TRUE, 1L), 2L) expect_equal(vec_arith("+", TRUE, 1), 2) expect_equal(vec_arith("+", 1L, TRUE), 2L) expect_equal(vec_arith("+", 1L, 1L), 2L) expect_equal(vec_arith("+", 1L, 1), 2) expect_equal(vec_arith("+", 1, TRUE), 2L) expect_equal(vec_arith("+", 1, 1L), 2L) expect_equal(vec_arith("+", 1, 1), 2) }) test_that("default is error", { f <- new_vctr(1:10, class = "foo") expect_error(vec_arith("+", f, 1), class = "vctrs_error_incompatible_op") expect_error(vec_arith("+", TRUE, f), class = "vctrs_error_incompatible_op") expect_error(vec_arith("+", 1L, f), class = "vctrs_error_incompatible_op") expect_error(vec_arith("+", 1, f), class = "vctrs_error_incompatible_op") }) vctrs/tests/testthat/out/0000755000176200001440000000000013622451540015226 5ustar liggesusersvctrs/tests/testthat/out/vec-ptype-0.txt0000644000176200001440000000002013623022056020025 0ustar liggesusersPrototype: NULL vctrs/tests/testthat/out/vec-ptype-1.txt0000644000176200001440000000002313623022056020031 0ustar liggesusersPrototype: integer vctrs/tests/testthat/out/vec-ptype-3.txt0000644000176200001440000000021713623022056020040 0ustar liggesusersPrototype: 0. ( , ) = 1. ( , ) = 2. ( , ) = vctrs/tests/testthat/out/vec-ptype-2.txt0000644000176200001440000000014613623022056020040 0ustar liggesusersPrototype: 0. ( , ) = 1. ( , ) = vctrs/tests/testthat/test-list_of-type.txt0000644000176200001440000000064413623022053020551 0ustar liggesusers list list_of list_of list_of list "list" NA NA NA list_of NA "list_of" "list_of" NA list_of NA "list_of" "list_of" NA list_of NA NA NA "list_of" vctrs/tests/testthat/test-cast.R0000644000176200001440000001010513623013722016443 0ustar liggesuserscontext("test-cast") # vec_cast --------------------------------------------------------------- test_that("new classes are uncoercible by default", { x <- structure(1:10, class = "vctrs_nonexistant") expect_error(vec_cast(1, x), class = "vctrs_error_incompatible_cast") expect_error(vec_cast(x, 1), class = "vctrs_error_incompatible_cast") }) test_that("casting requires vectors", { expect_error(vec_cast(NULL, quote(name)), class = "vctrs_error_scalar_type") expect_error(vec_cast(NA, quote(name)), class = "vctrs_error_scalar_type") expect_error(vec_cast(list(), quote(name)), class = "vctrs_error_scalar_type") expect_error(vec_cast(quote(name), NULL), class = "vctrs_error_scalar_type") expect_error(vec_cast(quote(name), NA), class = "vctrs_error_scalar_type") expect_error(vec_cast(quote(name), list()), class = "vctrs_error_scalar_type") expect_error(vec_cast(quote(name), quote(name)), class = "vctrs_error_scalar_type") }) test_that("casting between `NULL` and partial types is allowed", { expect_identical(vec_cast(NULL, partial_factor()), NULL) expect_identical(vec_cast(partial_factor(), NULL), partial_factor()) }) test_that("dimensionality matches output" ,{ x1 <- matrix(TRUE, nrow = 1, ncol = 1) x2 <- matrix(1, nrow = 0, ncol = 2) expect_dim(vec_cast(x1, x2), c(1, 2)) expect_dim(vec_cast(TRUE, x2), c(1, 2)) x <- matrix(1, nrow = 2, ncol = 2) expect_error(vec_cast(x, logical()), class = "vctrs_error_incompatible_cast") }) test_that("empty input to vec_cast_common() returns list()", { expect_equal(vec_cast_common(), list()) expect_equal(vec_cast_common(NULL, NULL), list(NULL, NULL)) }) test_that("identical structures can be cast to each other", { expect_identical(vec_cast(foobar("foo"), foobar("bar")), foobar("foo")) expect_identical(vec_coercible_cast(foobar("foo"), foobar("bar")), foobar("foo")) }) test_that("inputs to vec_coercible_cast() are checked", { expect_error(vec_coercible_cast("", "", x_arg = 1), "must be a string") expect_error(vec_coercible_cast("", "", to_arg = chr()), "must be a string") }) test_that("cast common preserves names", { expect_identical(vec_cast_common(foo = 1, bar = 2L), list(foo = 1, bar = 2)) }) test_that("cast errors create helpful messages (#57, #225)", { expect_known_output(file = test_path("test-cast-error-nested.txt"), { # Lossy cast try2(vec_cast("foo", 10)) # Incompatible cast try2(vec_cast(factor("foo"), 10)) ## Nested data frames # Lossy cast x <- tibble(a = tibble(b = "foo")) y <- tibble(a = tibble(b = 10)) try2(vec_cast(x, y)) # Incompatible cast x <- tibble(a = tibble(b = factor("foo"))) try2(vec_cast(x, y)) # Common cast error try2(vec_cast_common(x, y)) }) }) # Conditions -------------------------------------------------------------- test_that("can suppress cast errors selectively", { f <- function() vec_cast(factor("a"), to = factor("b")) expect_error(regexp = NA, allow_lossy_cast(f())) expect_error(regexp = NA, allow_lossy_cast(f(), x_ptype = factor("a"))) expect_error(regexp = NA, allow_lossy_cast(f(), to_ptype = factor("b"))) expect_error(regexp = NA, allow_lossy_cast(f(), x_ptype = factor("a"), to_ptype = factor("b"))) expect_error(allow_lossy_cast(f(), x_ptype = factor("c")), class = "vctrs_error_cast_lossy") expect_error(allow_lossy_cast(f(), x_ptype = factor("b"), to_ptype = factor("a")), class = "vctrs_error_cast_lossy") expect_error(allow_lossy_cast(f(), x_ptype = factor("a"), to_ptype = factor("c")), class = "vctrs_error_cast_lossy") }) test_that("can signal deprecation warnings for lossy casts", { local_lifecycle_warnings() lossy_cast <- function() { maybe_lossy_cast(TRUE, factor("foo"), factor("bar"), lossy = TRUE, .deprecation = TRUE) } expect_true(expect_warning(lossy_cast(), "detected a lossy transformation")) expect_true(expect_warning(regexp = NA, allow_lossy_cast(lossy_cast()))) expect_true(expect_warning(regexp = NA, allow_lossy_cast(lossy_cast(), factor("foo"), factor("bar")))) expect_true(expect_warning(allow_lossy_cast(lossy_cast(), factor("bar"), double()))) }) vctrs/tests/testthat/output/0000755000176200001440000000000013622451540015757 5ustar liggesusersvctrs/tests/testthat/output/bind-name-repair.txt0000644000176200001440000000167613623022030021631 0ustar liggesusers vec_rbind() =========== > # Suboptimal > vec_rbind(1, 2) Message: New names: * `` -> ...1 Message: New names: * `` -> ...1 ...1 1 1 2 2 > # Suboptimal > vec_rbind(1, 2, ...10 = 3) Message: New names: * `` -> ...1 Message: New names: * `` -> ...1 Message: New names: * `` -> ...1 Message: New names: * `` -> ...1 * `` -> ...2 * ...10 -> ...3 ...1 ...1 1 ...2 2 ...3 3 > vec_rbind(a = 1, b = 2) Message: New names: * `` -> ...1 Message: New names: * `` -> ...1 ...1 a 1 b 2 > vec_rbind(c(a = 1), c(b = 2)) a b 1 1 NA 2 NA 2 vec_cbind() =========== > vec_cbind(1, 2) Message: New names: * `` -> ...1 * `` -> ...2 ...1 ...2 1 1 2 > vec_cbind(1, 2, ...10 = 3) Message: New names: * `` -> ...1 * `` -> ...2 * ...10 -> ...3 ...1 ...2 ...3 1 1 2 3 > vec_cbind(a = 1, b = 2) a b 1 1 2 > vec_cbind(c(a = 1), c(b = 2)) Message: New names: * `` -> ...1 * `` -> ...2 ...1 ...2 1 1 2 vctrs/tests/testthat/test-split.R0000644000176200001440000000227613622451540016661 0ustar liggesuserscontext("test-split") test_that("can split empty vector", { out <- vec_split(integer(), character()) expect_s3_class(out, "data.frame") expect_equal(out$key, character()) expect_equal(out$val, list()) }) test_that("split data frame with data frame", { df <- data.frame(x = c(1, 1, 2), y = c(1, 1, 1)) out <- vec_split(df, df) expect_s3_class(out, "data.frame") expect_equal(out$key, data.frame(x = c(1, 2), y = c(1, 1))) expect_equal(out$val, list( data.frame(x = c(1, 1), y = c(1, 1)), data.frame(x = 2, y = 1) )) }) test_that("x and by must be same size", { expect_error( vec_split(1:3, 1:2), "same size" ) }) test_that("split takes the equality proxy (#375)", { local_comparable_tuple() x <- tuple(c(1, 2, 1), 1:3) expect_identical(nrow(vec_split(1:3, x)), 2L) }) test_that("split works with different encodings", { encs <- encodings() expect_identical(nrow(vec_split(1:3, encs)), 1L) }) test_that("`key` and `value` retain names", { x <- c(a = 1, b = 2, c = 1, a = 1) split <- vec_split(x, x) expect_identical(split$key, c(a = 1, b = 2)) expect_identical(split$val[[1]], c(a = 1, c = 1, a = 1)) expect_identical(split$val[[2]], c(b = 2)) }) vctrs/tests/testthat/test-cast-error-nested.txt0000644000176200001440000000066613623022031021474 0ustar liggesusers vec_cast("foo", 10): Lossy cast from `x` to `to` . * Locations: 1 vec_cast(factor("foo"), 10): Can't cast `x` > to `to` . vec_cast(x, y): Lossy cast from `x$a$b` to `to$a$b` . * Locations: 1 vec_cast(x, y): Can't cast `x$a$b` > to `to$a$b` . vec_cast_common(x, y): No common type for `..1$a$b` > and `..2$a$b` . vctrs/tests/testthat/test-hash.R0000644000176200001440000001121013622451540016435 0ustar liggesuserscontext("test-hash") # Vectorised -------------------------------------------------------------- test_that("vec_hash() produces same hash for same values", { x <- vec_hash(1:3) y <- do.call(c, map(1:3, vec_hash)) expect_identical(x, y) }) test_that("F, T, and NA hash to different values", { x <- map(c(TRUE, FALSE, NA), vec_hash) expect_length(unique(x), 3) }) test_that("vec_hash of double produces different values", { x <- vec_hash(c(1, 1, 2)) expect_true(identical(x[1:4], x[5:8])) expect_false(identical(x[5:8], x[9:12])) }) test_that("NA and NaN hash to different values", { x <- vec_hash(c(NA, NaN)) expect_false(identical(x[1:4], x[5:8])) }) test_that("same string hashes to same value", { x <- vec_hash(c("1", "1", "2")) expect_true(identical(x[1:4], x[5:8])) expect_false(identical(x[5:8], x[9:12])) }) test_that("list hashes to values of individual values", { x <- vec_hash(list(1:3, letters)) expect_identical(x[1:4], obj_hash(1:3)) expect_identical(x[5:8], obj_hash(letters)) x <- map(list(list(1:3), list(letters)), vec_hash) expect_identical(x[[1]], obj_hash(1:3)) expect_identical(x[[2]], obj_hash(letters)) }) test_that("hash of data frame works down rows", { df <- data.frame(x = 1:3, y = 1:3) x <- vec_hash(df) expect_length(x, 4 * vec_size(df)) expect_identical(x[1:4], vec_hash(df[1, ])) }) test_that("hashes are consistent from run to run", { # no string, since we're currently hashing the address in string pool df <- list( lgl = c(TRUE, FALSE, NA), int = 1:100, dbl1 = as.double(1:100), dbl2 = seq(0, 1, length = 100) ) hash <- lapply(df, vec_hash) # Big-endian results are byte-swapped, but otherwise equivalent. # Swap results so that there's no need to save results twice. if (.Platform$endian == "big") { hash <- lapply( hash, function(x) { writeBin(readBin(x, "int", 100, endian = "big"), x, endian = "little") } ) } local_options(max.print = 99999) expect_known_output(print(hash), file = test_path("test-hash-hash.txt")) }) test_that("can hash list of non-vectors", { x <- list(quote(x), mean) expect_equal( vec_hash(x), c(obj_hash(x[[1]]), obj_hash(x[[2]])) ) }) test_that("can hash matrices", { x <- matrix(c(1, 1, 1, 2, 2, 1), c(3, 2)) expect_identical( vec_hash(x), vec_hash(x) ) x <- matrix(c(1, 2, 3, 4), c(2, 2)) expect_identical( vec_hash(x), vec_hash(x) ) expect_false(identical( vec_hash(x), vec_hash(c(1, 2)) )) y <- matrix(c(1, 2, 3, 5), c(2, 2)) expect_false(identical( vec_hash(x), vec_hash(y) )) }) test_that("can hash NA", { expect_identical( vec_hash(NA), vec_hash(NA), ) }) test_that("can hash 1D arrays", { # 1D arrays are dispatched to `as.data.frame.vector()` which # currently does not strip dimensions. This caused an infinite # recursion. expect_length(vec_hash(array(1:2)), 8) expect_identical(vec_hash(array(1:2)), vec_hash(1:2)) }) test_that("can hash raw vectors", { expect_identical(vec_hash(0:255), vec_hash(as.raw(0:255))) }) test_that("can hash complex vectors", { expect_identical( vec_hash(c(1, 2) + 0i), c(obj_hash(c(1, 0)), obj_hash(c(2, 0))) ) }) test_that("hash treats positive and negative 0 as equivalent (#637)", { expect_equal(vec_hash(-0), vec_hash(0)) }) test_that("can hash lists of expressions", { expect_equal( vec_hash(list(expression(x), expression(y))), c(obj_hash(expression(x)), obj_hash(expression(y))) ) }) test_that("vec_hash() uses recursive equality proxy", { x <- new_data_frame(list(x = foobar(1:3))) default <- vec_hash(x) local_methods(vec_proxy_equal.vctrs_foobar = function(...) c(0, 0, 0)) overridden <- vec_hash(x) expect_false(identical(default, overridden)) }) # Object ------------------------------------------------------------------ test_that("equal objects hash to same value", { # just test function since they'll recurse through every other object type f1 <- function(x, y = NULL) x + y f2 <- function(x, y = NULL) x + y expect_false(identical(obj_hash(f1), obj_hash(f2))) expect_false(identical(vec_hash(data_frame(x = list(f1))), vec_hash(data_frame(x = list(f2))))) attr(f1, "srcref") <- NULL attr(f2, "srcref") <- NULL expect_equal(obj_hash(f1), obj_hash(f2)) expect_equal(vec_hash(data_frame(x = list(f1))), vec_hash(data_frame(x = list(f2)))) }) test_that("expression vectors hash to the same value as lists of calls/names", { expect_equal( obj_hash(expression(x, y)), obj_hash(list(as.name("x"), as.name("y"))) ) expect_equal( obj_hash(expression(mean(), sd())), obj_hash(list(call("mean"), call("sd"))) ) }) vctrs/tests/testthat/test-translate.R0000644000176200001440000001532613622451540017523 0ustar liggesuserscontext("test-translate") # ------------------------------------------------------------------------------ # obj_maybe_translate_encoding() test_that("can translate a character vector of various encodings (#553)", { x <- unlist(encodings(), use.names = FALSE) results <- obj_maybe_translate_encoding(x) expect_equal_encoding(results, encodings()$utf8) }) test_that("does not perform translation when encodings are all the same", { encs <- encodings(bytes = TRUE) for (enc in encs) { x <- c(enc, enc) expect_equal_encoding(obj_maybe_translate_encoding(x), x) } }) test_that("can translate a list containing character vectors with different encodings", { results <- obj_maybe_translate_encoding(encodings()) results <- unlist(results) expect_equal_encoding(results, encodings()$utf8) }) test_that("translation fails purposefully when mixing with bytes with other encodings", { for (enc in encodings()) { x <- c(encoding_bytes(), enc) expect_error(obj_maybe_translate_encoding(x), "translating strings with \"bytes\" encoding") } }) test_that("attributes are kept on translation (#599)", { encs <- encodings() x <- c(encs$utf8, encs$latin1) x <- structure(x, names = c("a", "b"), extra = 1) expect_equal(attributes(obj_maybe_translate_encoding(x)), attributes(x)) }) test_that("translation is robust against scalar types contained in lists (#633)", { x <- list(a = z ~ y, b = z ~ z) expect_equal(obj_maybe_translate_encoding(x), x) }) test_that("translation can still occur even if a scalar type is in a list", { encs <- encodings() x <- list(a = z ~ y, b = encs$latin1) result <- obj_maybe_translate_encoding(x) expect_equal_encoding(result$b, encs$utf8) }) test_that("translation occurs inside scalars contained in a list", { encs <- encodings() scalar <- structure(list(x = encs$latin1), class = "scalar_list") lst <- list(scalar) result <- obj_maybe_translate_encoding(lst) expect_equal_encoding(result[[1]]$x, encs$utf8) }) # ------------------------------------------------------------------------------ # obj_maybe_translate_encoding2() test_that("can find a common encoding between various encoding combinations", { encs <- encodings() for (x_enc in encs) { for (y_enc in encs) { together <- obj_maybe_translate_encoding(c(x_enc, y_enc)) separate <- obj_maybe_translate_encoding2(x_enc, y_enc) separate <- unlist(separate) expect_equal_encoding(separate, together) } } }) test_that("can ignore strings containing only bytes", { bytes <- encoding_bytes() result <- obj_maybe_translate_encoding2(bytes, bytes) result <- unlist(result) expect_equal_encoding(result, bytes) }) test_that("cannot find a common encoding when mixing bytes with other encodings", { encs <- encodings() bytes <- encoding_bytes() for (enc in encs) { expect_error(obj_maybe_translate_encoding2(enc, bytes), "translating strings with \"bytes\" encoding") } }) test_that("can find a common encoding when one string has multiple encodings", { encs <- encodings() utf8_unknown <- c(encs$utf8, encs$unknown) together <- obj_maybe_translate_encoding(c(utf8_unknown, encs$latin1)) separate <- obj_maybe_translate_encoding2(utf8_unknown, encs$latin1) separate <- unlist(separate) expect_equal_encoding(separate, together) }) test_that("can find a common encoding between lists of characters with different encodings", { encs <- encodings() lst_utf8 <- list(encs$utf8) lst_ascii_latin1 <- list("ascii", encs$latin1) together <- obj_maybe_translate_encoding(c(lst_utf8, lst_ascii_latin1)) together <- unlist(together) separate <- obj_maybe_translate_encoding2(lst_utf8, lst_ascii_latin1) separate <- unlist(separate) expect_equal_encoding(separate, together) lst_of_lst_utf8 <- list(lst_utf8) lst_of_lst_ascii_latin1 <- list(list("ascii"), list(encs$latin1)) together <- obj_maybe_translate_encoding(c(lst_of_lst_utf8, lst_of_lst_ascii_latin1)) together <- unlist(together) separate <- obj_maybe_translate_encoding2(lst_of_lst_utf8, lst_of_lst_ascii_latin1) separate <- unlist(separate) expect_equal_encoding(separate, together) }) test_that("can find a common encoding with data frames with character columns", { encs <- encodings() df_utf8 <- data_frame(x = encs$utf8) df_unknown <- data_frame(x = encs$unknown) results <- obj_maybe_translate_encoding2(df_utf8, df_unknown) expect_equal_encoding(results[[1L]]$x, df_utf8$x) expect_equal_encoding(results[[2L]]$x, df_utf8$x) }) test_that("can find a common encoding with data frame subclasses with character columns", { encs <- encodings() df_utf8 <- new_data_frame(list(x = encs$utf8), class = "subclass") df_unknown <- new_data_frame(list(x = encs$unknown), class = "subclass") results <- obj_maybe_translate_encoding2(df_utf8, df_unknown) expect_equal_encoding(results[[1L]]$x, df_utf8$x) expect_equal_encoding(results[[2L]]$x, df_utf8$x) }) test_that("only columns requiring translation are affected", { encs <- encodings() df_utf8_latin1 <- data_frame(x = encs$utf8, y = encs$latin1) df_unknown_latin1 <- data_frame(x = encs$unknown, y = encs$latin1) results <- obj_maybe_translate_encoding2(df_utf8_latin1, df_unknown_latin1) expect_equal_encoding(results[[1L]]$y, df_utf8_latin1$y) expect_equal_encoding(results[[2L]]$y, df_unknown_latin1$y) }) test_that("can find a common encoding with lists of data frames with string columns", { encs <- encodings() df_utf8 <- data_frame(x = encs$utf8) df_unknown_1 <- data_frame(x = encs$unknown) df_unknown_2 <- data_frame(x = encs$unknown) lst_of_df_utf8 <- list(df_utf8) lst_of_df_unknown <- list(df_unknown_1, df_unknown_2) results <- obj_maybe_translate_encoding2(lst_of_df_utf8, lst_of_df_unknown) result1 <- results[[1L]] result2 <- results[[2L]] expect_equal_encoding(result1[[1]]$x, df_utf8$x) expect_equal_encoding(result2[[1]]$x, df_utf8$x) expect_equal_encoding(result2[[2]]$x, df_utf8$x) }) test_that("all elements are affected when any translation is required in a list", { encs <- encodings() lst_of_utf8 <- list(encs$utf8) # Both elements of the list are recursively translated df_latin1 <- data_frame(x = encs$latin1) lst_of_unknown_df_latin1 <- list(encs$unknown, df_latin1) results <- obj_maybe_translate_encoding2(lst_of_utf8, lst_of_unknown_df_latin1) result1 <- results[[1L]] result2 <- results[[2L]] expect_equal_encoding(result1[[1]], encs$utf8) expect_equal_encoding(result2[[1]], encs$utf8) expect_equal_encoding(result2[[2]]$x, encs$utf8) }) test_that("translation is robust against scalar types contained in lists (#633)", { x <- list(a = z ~ y, b = z ~ z) y <- list(a = c ~ d, b = e ~ f) expect_equal(obj_maybe_translate_encoding2(x, y), list(x, y)) }) vctrs/tests/testthat/test-partial-frame.R0000644000176200001440000000525313622451540020250 0ustar liggesuserscontext("test-partial-frame") test_that("has ok print method", { pf <- vec_ptype2(partial_frame(x = 1L), data.frame(y = 2)) expect_known_output( print(pf), test_path("test-partial-frame-print.txt") ) expect_equal(vec_ptype_abbr(pf), "prtl") }) test_that("order of variables comes from data", { pf <- partial_frame(y = 1, x = 2) df <- data.frame(x = 1, y = 2) expect_named(vec_ptype_common(pf, df), c("x", "y")) expect_named(vec_ptype_common(df, pf), c("x", "y")) }) test_that("partial variables added to end if not in data", { pf <- partial_frame(y = 1) df <- data.frame(x = 1) expect_named(vec_ptype_common(pf, df), c("x", "y")) expect_named(vec_ptype_common(df, pf), c("x", "y")) }) test_that("can assert partial frames based on column presence", { pf <- partial_frame(y = 1) expect_true(vec_is(data.frame(y = 2), pf)) expect_false(vec_is(data.frame(x = 1), pf)) expect_true(vec_is(data.frame(x = 1, y = 2), pf)) expect_true(vec_is(data.frame(x = 1, y = 2, z = 3), pf)) pf <- partial_frame(y = 1, z = 3) expect_false(vec_is(data.frame(y = 2), pf)) expect_false(vec_is(data.frame(x = 1), pf)) expect_false(vec_is(data.frame(x = 1, y = 2), pf)) expect_true(vec_is(data.frame(x = 1, y = 2, z = 3), pf)) }) test_that("can assert partial frames based on column type", { pf <- partial_frame(y = 1) expect_false(vec_is(data.frame(y = "2"), pf)) }) test_that("incompatible data frames are an error", { df <- data.frame(y = 1) expect_error(vec_ptype2(df, partial_frame(y = chr())), class = "vctrs_error_incompatible_type") expect_error(new_partial_frame(df, data.frame(y = chr())), class = "vctrs_error_incompatible_type") }) test_that("dispatch is symmetric with tibbles", { left <- vec_ptype2(partial_frame(x = 1), tibble::tibble(x = 1)) right <- vec_ptype2(tibble::tibble(x = 1), partial_frame(x = 1)) expect_identical(left, right) }) test_that("can take the common type with partial frames", { exp <- tibble::tibble(x = dbl(), y = chr(), a = chr()) out <- vec_ptype_common( partial_frame(x = double(), a = character()), tibble::tibble(x = 1L, y = "a") ) expect_identical(out, exp) out <- vec_ptype_common( tibble::tibble(x = 1L, y = "a"), partial_frame(x = double(), a = character()) ) expect_identical(out, tibble::tibble(x = dbl(), y = chr(), a = chr())) }) test_that("can rbind with a partial frame prototype", { out <- vec_rbind( tibble::tibble(x = 1L, y = "a"), tibble::tibble(x = FALSE, z = 10), .ptype = partial_frame(x = double(), a = character()) ) exp <- tibble::tibble( x = dbl(1, 0), y = chr("a", NA), z = dbl(NA, 10), a = chr(NA, NA) ) expect_identical(out, exp) }) vctrs/tests/testthat/test-type2.R0000644000176200001440000001617013623013722016564 0ustar liggesuserscontext("test-type-coerce") test_that("base coercions are symmetric and unchanging", { types <- list( logical(), integer(), double(), character(), raw(), list() ) mat <- maxtype_mat(types) expect_true(isSymmetric(mat)) expect_known_output(mat, test_path("test-type2.txt"), print = TRUE) }) test_that("new classes are uncoercible by default", { x <- structure(1:10, class = "vctrs_nonexistant") expect_error(vec_ptype2(1, x), class = "vctrs_error_incompatible_type") expect_error(vec_ptype2(x, 1), class = "vctrs_error_incompatible_type") }) test_that("vec_typeof2() returns common type", { nms <- names(base_empty_types) for (i in seq_along(base_empty_types)) { this <- nms[[i]] for (j in seq_along(base_empty_types)) { that <- nms[[j]] if (i <= j) { exp <- paste0("vctrs_type2_", this, "_", that) } else { exp <- paste0("vctrs_type2_", that, "_", this) } out <- vec_typeof2(base_empty_types[[this]], base_empty_types[[that]]) expect_identical(out, exp) } } }) test_that("vec_typeof2_s3() returns common type", { all_base_empty_types <- c(base_empty_types, base_s3_empty_types) nms_s3 <- names(base_s3_empty_types) nms <- names(all_base_empty_types) for (i in seq_along(all_base_empty_types)) { this <- nms[[i]] for (j in seq_along(all_base_empty_types)) { that <- nms[[j]] # Skip when we have two non s3 objects if (!(this %in% nms_s3) & !(that %in% nms_s3)) { next } if (i <= j) { exp <- paste0("vctrs_type2_s3_", this, "_", that) } else { exp <- paste0("vctrs_type2_s3_", that, "_", this) } out <- vec_typeof2_s3(all_base_empty_types[[this]], all_base_empty_types[[that]]) expect_identical(out, exp) } } }) test_that("vec_ptype2() dispatches when inputs have shape", { expect_identical(dim(vec_ptype2(int(), matrix(nrow = 3, ncol = 4))), c(0L, 4L)) expect_identical(dim(vec_ptype2(matrix("", nrow = 3), c("", "", ""))), c(0L, 1L)) }) test_that("vec_ptype2() requires vectors", { expect_error(vec_ptype2(NULL, quote(name)), class = "vctrs_error_scalar_type") expect_error(vec_ptype2(NA, quote(name)), class = "vctrs_error_scalar_type") expect_error(vec_ptype2(list(), quote(name)), class = "vctrs_error_scalar_type") expect_error(vec_ptype2(quote(name), NULL), class = "vctrs_error_scalar_type") expect_error(vec_ptype2(quote(name), NA), class = "vctrs_error_scalar_type") expect_error(vec_ptype2(quote(name), list()), class = "vctrs_error_scalar_type") expect_error(vec_ptype2(quote(name), quote(name)), class = "vctrs_error_scalar_type") }) test_that("vec_ptype2() with unspecified requires vectors", { expect_error(vec_ptype2(unspecified(), quote(name)), class = "vctrs_error_scalar_type") expect_error(vec_ptype2(quote(name), unspecified()), class = "vctrs_error_scalar_type") }) test_that("vec_ptype2() forwards argument tag", { expect_error(vec_ptype2(quote(name), list(), x_arg = "foo"), "`foo`", class = "vctrs_error_scalar_type") expect_error(vec_ptype2(list(), quote(name), y_arg = "foo"), "`foo`", class = "vctrs_error_scalar_type") }) test_that("stop_incompatible_type() checks for scalars", { expect_error(stop_incompatible_type(NA, foobar()), class = "vctrs_error_scalar_type") expect_error(vec_ptype_common(NA, foobar()), class = "vctrs_error_scalar_type") expect_error(vec_ptype_common(foobar(), list()), class = "vctrs_error_scalar_type") }) test_that("vec_ptype2() methods forward args to stop_incompatible_type()", { expect_args(new_hidden(), lgl(), x_arg = "foo", y_arg = "bar") expect_args(lgl(), new_hidden(), x_arg = "foo", y_arg = "bar") expect_args(int(), new_hidden(), x_arg = "foo", y_arg = "bar") expect_args(dbl(), new_hidden(), x_arg = "foo", y_arg = "bar") expect_args(chr(), new_hidden(), x_arg = "foo", y_arg = "bar") expect_args(list(), new_hidden(), x_arg = "foo", y_arg = "bar") expect_args(new_rcrd(list(x = NA)), new_hidden(), x_arg = "foo", y_arg = "bar") expect_args(data.frame(), new_hidden(), x_arg = "foo", y_arg = "bar") expect_args(Sys.Date(), new_hidden(), x_arg = "foo", y_arg = "bar") expect_args(as.difftime(1, units = "hours"), new_hidden(), x_arg = "foo", y_arg = "bar") expect_args(factor(), new_hidden(), x_arg = "foo", y_arg = "bar") expect_args(ordered(""), new_hidden(), x_arg = "foo", y_arg = "bar") expect_args(ordered(""), factor(), x_arg = "foo", y_arg = "bar") expect_args(bit64::as.integer64(1), new_hidden(), x_arg = "foo", y_arg = "bar") }) test_that("vec_ptype2() data frame methods builds argument tags", { expect_known_output(file = test_path("test-type2-error-messages.txt"), { cat_line("Bare objects:") try2(vec_ptype2("foo", 10)) cat_line("Nested dataframes:") df1 <- tibble(x = tibble(y = tibble(z = 1))) df2 <- tibble(x = tibble(y = tibble(z = "a"))) try2(vec_ptype2(df1, df2)) }) }) test_that("stop_incompatible_type() can be called without argument tags", { expect_error(stop_incompatible_type(1, 2, x_arg = "", y_arg = ""), " and ", class = "vctrs_error_incompatible_type") }) test_that("vec_ptype2() returns empty prototype when other input is NULL", { expect_identical(vec_ptype2(1:5, NULL), int()) expect_identical(vec_ptype2(NULL, 1:5), int()) }) test_that("Subclasses of data.frame dispatch to `vec_ptype2()` methods", { local_methods( vec_ptype2.quuxframe = function(x, y, ...) UseMethod("vec_ptype2.quuxframe"), vec_ptype2.quuxframe.data.frame = function(x, y, ...) "dispatched!", vec_ptype2.data.frame.quuxframe = function(x, y, ...) "dispatched!" ) quux <- structure(data.frame(), class = c("quuxframe", "data.frame")) expect_identical(vec_ptype2(quux, mtcars), "dispatched!") expect_identical(vec_ptype2(mtcars, quux), "dispatched!") quux <- structure(data.frame(), class = c("quuxframe", "tbl_df", "data.frame")) expect_identical(vec_ptype2(quux, mtcars), "dispatched!") expect_identical(vec_ptype2(mtcars, quux), "dispatched!") }) test_that("Subclasses of `tbl_df` have `tbl_df` common type (#481)", { quux <- tibble() quux <- structure(quux, class = c("quux", class(quux))) expect_identical(vec_ptype2(quux, tibble()), tibble()) expect_identical(vec_ptype2(tibble(), quux), tibble()) }) test_that("Column name encodings are handled correctly in the common type (#553)", { encs <- encodings() data <- list(chr()) df_utf8 <- tibble::as_tibble(set_names(data, encs$utf8)) df_unknown <- tibble::as_tibble(set_names(data, encs$unknown)) expect_identical(vec_ptype2(df_utf8, df_unknown), df_utf8) }) test_that("vec_is_subtype() determines subtyping relationship", { expect_true(vec_is_subtype(lgl(), int())) expect_false(vec_is_subtype(int(), lgl())) expect_false(vec_is_subtype(lgl(), chr())) expect_false(vec_is_subtype(chr(), lgl())) local_methods( vec_ptype2.vctrs_foobar = function(x, y, ...) UseMethod("vec_ptype2.vctrs_foobar", y), vec_ptype2.vctrs_foobar.logical = function(x, y, ...) logical(), vec_ptype2.logical.vctrs_foobar = function(x, y, ...) logical() ) expect_true(vec_is_subtype(foobar(TRUE), lgl())) expect_false(vec_is_subtype(lgl(), foobar(TRUE))) }) vctrs/tests/testthat/helper-cast.R0000644000176200001440000000034113622451540016747 0ustar liggesusers expect_lossy_cast <- function(expr) { cnd <- NULL out <- with_handlers( warning = calling(function(x) { cnd <<- x cnd_muffle(x) }), expr ) expect_is(cnd, "vctrs_warning_cast_lossy") out } vctrs/tests/testthat/test-type-vctr.R0000644000176200001440000003436213622451540017464 0ustar liggesuserscontext("test-type-vctr") test_that("constructor sets attributes", { x <- new_vctr(1:4, class = "x", x = 1) expect_equal(x, structure(1:4, class = c("x", "vctrs_vctr"), x = 1)) x <- new_vctr(1:4, class = "x", x = 1, inherit_base_type = TRUE) expect_equal(x, structure(1:4, class = c("x", "vctrs_vctr", "integer"), x = 1)) }) test_that(".data must be a vector", { expect_error(new_vctr(mean), "vector type") }) test_that("attributes other than names are ignored", { out <- new_vctr(structure(1, a = 1)) expect_null(attributes(out)$a) }) test_that("default format method is internal", { x <- new_vctr(1, class = "x") expect_equal(format(x), format(x)) }) test_that("vctr class is proxied", { expect_identical(vec_proxy(new_vctr(1:3)), new_vctr(1:3)) expect_identical(vec_proxy(new_vctr(as.list(1:3))), unclass(new_vctr(as.list(1:3)))) expect_true(vec_is(new_vctr(as.list(1:3)))) }) test_that("Can opt out of base type", { x <- new_vctr(1, class = "x", inherit_base_type = FALSE) expect_s3_class(x, c("x", "vctrs_vctr"), exact = TRUE) }) test_that("attributes must be named", { expect_error(vec_set_attributes(1, list(1)), "must be named") expect_error(vec_set_attributes(1, list(y = 1, 2)), "2 does not") }) test_that("can strip all attributes without adding new ones", { expect_equal(vec_set_attributes(structure(1, a = 1), NULL), 1) }) test_that("`c.vctrs_vctr()` checks for default method arguments (#791)", { expect_error(c(new_vctr(1), recursive = TRUE), "`recursive` must be") expect_error(c(new_vctr(1), use.names = FALSE), "`use.names` must be") }) # Cast/restore ------------------------------------------------------------ test_that("cast to NULL returns x", { x <- new_vctr(1, class = "x") expect_equal(vec_cast(NULL, x), NULL) }) test_that("cast succeeds if attributes equal", { x1 <- new_vctr(1, class = "x", a = 1, b = 2) x2 <- new_vctr(2, class = "x", a = 1, b = 2) expect_equal(vec_cast(x1, x2), x1) expect_equal(vec_cast(x2, x1), x2) }) test_that("and fails if attributes are different", { x1 <- new_vctr(1, class = "x", a = 1, b = 2) x2 <- new_vctr(2, class = "x", a = 2, b = 2) expect_error(vec_cast(x1, x2), class = "vctrs_error_incompatible_cast") }) test_that("restoring to atomic vector of same type preserves attributes", { x1 <- new_vctr(1, class = "x") x2 <- new_vctr(2, class = "x") expect_equal(vec_restore(2, x1), x2) }) test_that("restoring to atomic vector of different type throws error", { x1 <- new_vctr(1, class = "x") expect_error(vec_restore("x", x1), class = "vctrs_error_incompatible_cast") }) test_that("base coercion methods mapped to vec_cast", { x <- new_vctr(1, inherit_base_type = FALSE) expect_error(as.logical(x), class = "vctrs_error_incompatible_cast") expect_error(as.integer(x), class = "vctrs_error_incompatible_cast") expect_error(as.logical(x), class = "vctrs_error_incompatible_cast") expect_error(as.double(x), class = "vctrs_error_incompatible_cast") expect_error(as.character(x), class = "vctrs_error_incompatible_cast") expect_error(as.Date(x), class = "vctrs_error_incompatible_cast") expect_error(as.POSIXct(x), class = "vctrs_error_incompatible_cast") expect_error(as.POSIXlt(x), class = "vctrs_error_incompatible_cast") expect_equal(as.list(x), list(x)) }) test_that("as.data.frame creates data frame", { x <- new_vctr(1:3) df <- as.data.frame(x) expect_s3_class(df, "data.frame") expect_equal(nrow(df), 3) expect_named(df, "x") }) # equality + comparison + arith + math --------------------------------------- test_that("equality functions remapped", { x <- new_vctr(c(1, 1, NA), inherit_base_type = FALSE) expect_error(x == 1, class = "vctrs_error_incompatible_type") expect_error(x != 1, class = "vctrs_error_incompatible_type") expect_equal(is.na(x), c(FALSE, FALSE, TRUE)) expect_true(anyNA(x)) expect_equal(unique(x), new_vctr(c(1, NA), inherit_base_type = FALSE)) expect_equal(duplicated(x), c(FALSE, TRUE, FALSE)) expect_true(anyDuplicated(x)) }) test_that("is.na<-() supported", { x <- new_vctr(1:4) is.na(x) <- c(FALSE, FALSE, TRUE, NA) expect_identical(x, new_vctr(c(1:2, NA, 4L))) is.na(x) <- TRUE expect_identical(x, new_vctr(rep(NA_integer_, 4))) }) test_that("comparison functions remapped", { local_methods( vec_proxy_compare.bizzaro = function(x) -vec_data(x) ) x1 <- new_vctr(c(1, 2), class = "bizzaro") x2 <- new_vctr(2, class = "bizzaro") expect_equal(order(x1), c(2L, 1L)) expect_equal(x1 < x2, c(FALSE, FALSE)) expect_equal(x1 <= x2, c(FALSE, TRUE)) expect_equal(x1 > x2, c(TRUE, FALSE)) expect_equal(x1 >= x2, c(TRUE, TRUE)) }) test_that("operators remapped", { local_methods( vec_arith.bizzaro = function(op, x, y) 1L ) x <- new_vctr(c(1, 2), class = "bizzaro") expect_equal(x + 1, 1L) expect_equal(x - 1, 1L) expect_equal(x * 1, 1L) expect_equal(x / 1, 1L) expect_equal(x ^ 1, 1L) expect_equal(x %% 1, 1L) expect_equal(x %/% 1, 1L) expect_equal(x & 1, 1L) expect_equal(x | 1, 1L) expect_equal(!x, 1L) expect_equal(+x, 1L) expect_equal(-x, 1L) }) test_that("math functions overridden", { local_methods( vec_math.bizzaro = function(fn, x, ...) vec_math_base(fn, 2L) ) x <- new_vctr(c(1, NA), class = "bizzaro") expect_equal(mean(x), 2L) expect_equal(sum(x), 2L) expect_equal(is.finite(x), TRUE) expect_equal(is.infinite(x), FALSE) expect_equal(is.nan(x), FALSE) }) test_that("diff matches base R", { local_methods( vec_arith.vctrs_minus = function(op, x, y) vec_arith_base(op, x, y) ) x1 <- cumsum(cumsum(1:10)) x2 <- new_vctr(x1, class = "vctrs_minus") expect_equal(diff(x2), diff(x1)) expect_equal(diff(x2, lag = 2L), diff(x1, lag = 2L)) expect_equal(diff(x2, differences = 2L), diff(x1, differences = 2L)) expect_equal(diff(x2, lag = 11), x2[0L]) expect_equal(diff(x2, differences = 11), x2[0L]) }) # names ------------------------------------------------------------------- test_that("all elements must be named if any are named", { expect_error(new_vctr(setNames(1:2, c("a", NA))), "named") expect_error(new_vctr(setNames(1:2, c("a", ""))), "named") }) test_that("can not provide invalid names", { x <- new_vctr(c(a = 1, b = 2)) expect_error(names(x) <- "x", "length") expect_error(names(x) <- c("x", NA), "named") expect_error(names(x) <- c("x", ""), "named") expect_error(names(x) <- c("x", "y", "z"), "length") expect_error(names(x) <- NULL, NA) }) test_that("can use [ and [[ with names", { local_methods( vec_ptype2.vctrs_vctr = function(...) dbl(), vec_ptype2.double.vctrs_vctr = function(...) dbl() ) x <- new_vctr(c(a = 1, b = 2)) expect_equal(x["b"], new_vctr(c(b = 2))) expect_equal(x[["b"]], new_vctr(2)) # [[ drops names x[["c"]] <- 3 expect_equal(x[["c"]], new_vctr(3)) x["d"] <- 4 expect_equal(x[["d"]], new_vctr(4)) }) test_that("can use [ and [[ with names - list vctr", { local_methods( vec_ptype2.vctrs_vctr = function(...) list(), vec_ptype2.list.vctrs_vctr = function(...) list() ) y <- new_vctr(list(a = 1, b = 2)) y[["c"]] <- 3 expect_equal(y[["c"]], 3) y["d"] <- list(4) expect_equal(y[["d"]], 4) }) test_that("can use [[<- to replace n-dimensional elements", { local_methods( vec_restore.vctrs_mtrx = function(x, to, ...) x, vec_ptype2.double.vctrs_mtrx = function(...) dbl(), vec_ptype2.vctrs_mtrx = function(...) dbl() ) x <- new_vctr(rep(1, times = 4), dim = c(2, 2), class = "vctrs_mtrx") x[[2, 2]] <- 4 expect_equal(x[[2, 2]], 4) }) test_that("subsetting preserves attributes", { x <- new_vctr(c(a = 1, b = 2)) attr(x, "extra") <- TRUE y <- x[1] expect_equal(attr(x, "extra"), TRUE) }) test_that("$ inherits from underlying vector", { x1 <- new_vctr(c(a = 1, b = 2)) expect_error(x1$a, "atomic vectors") expect_error(x1$a <- 2, "atomic vectors") x2 <- new_vctr(list(a = 1, b = 2)) expect_equal(x2$a, 1) x2$a <- 10 expect_equal(x2$a, 10) }) # unsupported/unimplemented operations -------------------------------------- test_that("can't touch protected attributes", { x <- new_vctr(1:4) expect_error(dim(x) <- c(2, 2), class = "vctrs_error_unsupported") expect_error(dimnames(x) <- list("x"), class = "vctrs_error_unsupported") expect_error(levels(x), class = "vctrs_error_unsupported") expect_error(levels(x) <- "x", class = "vctrs_error_unsupported") # but it's ok to set names to NULL; this happens at least in vec_c # and maybe elsewhere. We may need to back off on this level of # strictness in the future expect_error(names(x) <- NULL, NA) }) test_that("summary is unimplemented", { x <- new_vctr(1:4) expect_error(summary(x), class = "vctrs_error_unimplemented") }) # hidden class ------------------------------------------------------------ # We can't construct classes in test because the methods are not found # when vctr generics call other generics. Instead we rely on a very simple # class implemented in vctr.R test_that("class preserved when subsetting", { h <- new_hidden(1:4) expect_s3_class(h, "hidden") expect_s3_class(h[1], "hidden") expect_s3_class(h[[1]], "hidden") expect_s3_class(rep(h[1], 2), "hidden") expect_s3_class(as.list(h)[[1]], "hidden") length(h) <- 3 expect_s3_class(h, "hidden") }) test_that("RHS cast when using subset assign", { local_hidden() h <- new_hidden(1) expect_error(h[[1]] <- "x", class = "vctrs_error_incompatible_type") expect_error(h[1] <- "x", class = "vctrs_error_incompatible_type") h[2] <- 1 expect_equal(h, new_hidden(c(1, 1))) h[[2]] <- 2 expect_equal(h, new_hidden(c(1, 2))) }) test_that("c passes on to vec_c", { local_hidden() h <- new_hidden(1) expect_equal(c(h), h) expect_equal(c(h, NULL), h) expect_equal(c(h, 1), rep(h, 2)) expect_equal(c(h, h), rep(h, 2)) }) test_that("summaries preserve class", { h <- new_hidden(c(1, 2)) expect_equal(sum(h), new_hidden(3)) expect_equal(mean(h), new_hidden(1.5)) }) test_that("methods using vec_proxy_compare agree with base", { h <- new_hidden(c(1:10)) h_na <- new_hidden(c(NA, 1:10)) expect_agree <- function(f, x, na.rm = FALSE) { f <- enexpr(f) expect_equal(vec_data((!!f)(x, na.rm = na.rm)), (!!f)(vec_data(x), na.rm = na.rm)) } expect_agree(min, h) expect_agree(max, h) expect_agree(range, h) expect_agree(min, h_na) expect_agree(max, h_na) expect_agree(range, h_na) expect_agree(min, h_na, na.rm = TRUE) expect_agree(max, h_na, na.rm = TRUE) expect_agree(range, h_na, na.rm = TRUE) }) test_that("can put in data frame", { h <- new_hidden(1:4) expect_named(as.data.frame(h), "h") expect_named(data.frame(x = h), "x") }) test_that("base coercions default to vec_cast", { local_hidden() h <- new_hidden(1) expect_error(as.character(h), class = "vctrs_error_incompatible_cast") expect_error(as.integer(h), class = "vctrs_error_incompatible_cast") expect_error(generics::as.factor(h), class = "vctrs_error_incompatible_cast") expect_error(generics::as.ordered(h), class = "vctrs_error_incompatible_cast") expect_error(generics::as.difftime(h), class = "vctrs_error_incompatible_cast") expect_equal(as.logical(h), TRUE) expect_equal(as.double(h), 1) }) test_that("default print and str methods are useful", { h <- new_hidden(1:4) expect_known_output( { print(h) cat("\n") print(h[0]) cat("\n") str(h) }, file = "test-vctr-print.txt", ) }) test_that("default print method shows names", { h <- new_hidden(c(A = 1, B = 2, C = 3)) expect_known_output( { print(h) }, file = "test-vctr-print-names.txt", ) }) test_that("can't transpose", { h <- new_hidden(1:4) expect_error(t(h), class = "vctrs_error_unsupported") }) test_that("shaped vctrs can be cast to data frames", { x <- new_vctr(1:4, dim = 4) expect_identical(as.data.frame(x), data.frame(V1 = 1:4)) x <- new_vctr(1:4, dim = c(2, 2)) expect_identical(as.data.frame(x), data.frame(V1 = 1:2, V2 = 3:4)) }) # slicing ----------------------------------------------------------------- test_that("additional subscripts are handled (#269)", { new_2d <- function(.data, dim) { vctrs::new_vctr(.data, dim = dim, class = "vctrs_2d") } x <- new_2d(c(1, 2), dim = c(2L, 1L)) expect_identical(x[1], new_2d(1, dim = c(1, 1))) expect_identical(x[1, 1], new_2d(1, dim = c(1, 1))) expect_identical(x[, 1], new_2d(c(1, 2), dim = c(2, 1))) }) # summary generics -------------------------------------------------------- test_that("na.rm is forwarded to summary generics", { x <- new_vctr(dbl(1, 2, NA)) expect_identical(mean(x, na.rm = FALSE), new_vctr(dbl(NA))) expect_identical(mean(x, na.rm = TRUE), new_vctr(1.5)) expect_identical(min(x, na.rm = FALSE), new_vctr(dbl(NA))) expect_identical(min(x, na.rm = TRUE), new_vctr(1)) expect_identical(max(x, na.rm = FALSE), new_vctr(dbl(NA))) expect_identical(max(x, na.rm = TRUE), new_vctr(2)) x <- new_vctr(lgl(TRUE, NA)) expect_identical(all(x, na.rm = FALSE), lgl(NA)) expect_identical(all(x, na.rm = TRUE), TRUE) }) test_that("Summary generics behave identically to base for empty vctrs (#88)", { expect_warning( expect_identical( new_vctr(max(numeric())), max(new_vctr(numeric())) ) ) expect_warning( expect_identical( new_vctr(min(numeric())), min(new_vctr(numeric())) ) ) expect_warning( expect_identical( new_vctr(range(numeric())), range(new_vctr(numeric())) ) ) expect_identical( new_vctr(prod(numeric())), prod(new_vctr(numeric())) ) expect_identical( new_vctr(sum(numeric())), sum(new_vctr(numeric())) ) expect_identical( new_vctr(cummax(numeric())), cummax(new_vctr(numeric())) ) expect_identical( new_vctr(cummin(numeric())), cummin(new_vctr(numeric())) ) expect_identical( new_vctr(cumprod(numeric())), cumprod(new_vctr(numeric())) ) expect_identical( new_vctr(cumsum(numeric())), cumsum(new_vctr(numeric())) ) expect_identical( new_vctr(mean(numeric())), mean(new_vctr(numeric())) ) }) test_that("generic predicates return logical vectors (#251)", { x <- new_vctr(c(1, 2)) expect_identical(is.finite(x), c(TRUE, TRUE)) expect_identical(is.infinite(x), c(FALSE, FALSE)) expect_identical(is.nan(x), c(FALSE, FALSE)) x <- new_vctr(TRUE) expect_identical(any(x), TRUE) expect_identical(all(x), TRUE) }) vctrs/tests/testthat/test-hash-hash.txt0000644000176200001440000000756313623022033020004 0ustar liggesusers$lgl [1] 70 a2 85 ef b9 79 37 9e 59 df 73 0b $int [1] 70 a2 85 ef bf 3c 2c cf e0 2d 28 24 3e 2c d4 c2 86 cd 44 6a c1 c6 22 fb 7d [26] 28 01 b7 c4 de 70 e7 cc a2 b3 60 49 7e 5c 87 bd 77 d8 31 2c 27 c0 1a 4b f7 [51] f2 33 aa 4d 23 5e fe 51 52 6a 75 cd 5c f3 a1 18 08 77 d0 cc 3b 74 cd ce 28 [76] 80 da 82 82 70 1e db 49 88 ef 6a 83 16 45 b6 ef 6f a8 63 fc 59 f3 50 ab 1d [101] 56 e3 06 58 61 10 57 e3 99 3e c1 e0 53 77 22 cd 86 b9 75 87 14 33 2e e9 31 [126] 21 82 48 cb 87 24 99 c7 b1 e2 a0 e3 2a 76 8c 99 50 f3 0c 08 81 8d 36 aa b5 [151] 72 f0 41 78 9f 1a fc 7b 81 05 51 8d 37 0d 15 47 b7 a6 7b c3 7b 7b ce e5 26 [176] 1d 43 60 95 97 d2 f2 a8 41 23 3c 26 82 d1 13 cb 66 41 e5 1d 8b 2e 28 1f 9d [201] f1 6f 67 ae 0c 1b 2f a0 3a 45 d9 12 0a 93 29 eb 4d a4 f9 d8 72 99 a2 b1 2e [226] 0e 12 21 ee 74 0d fc 0f f3 a9 bf 4c f9 bf c1 ee b1 42 35 70 ec 24 34 41 bf [251] 2e 12 41 72 24 81 68 83 4e 10 76 9a c5 56 d1 1d 56 95 9d 60 e6 31 5f d2 48 [276] 68 0d dc b3 7a 3a b1 0c 83 22 aa b9 cc 3b 72 d4 6c 58 88 e4 ce 6d 3f 7b f9 [301] 13 5b 06 d1 b5 d1 03 4e 4b 89 b8 59 fe ca aa 94 e7 03 74 de fe d4 11 15 e9 [326] a0 37 7c e0 61 8b 3c da f6 91 e3 3d 55 02 7f 33 24 73 1b bb 11 65 50 e3 51 [351] 16 9c a2 dc 9b 79 e0 27 fc e1 fe c4 5a 7e 4c e4 cd a7 43 f9 d4 82 f5 8e 6b [376] f4 1a a5 4f 41 4b 7a 10 f2 d2 98 6e 7e 7f 11 0f c9 93 eb 84 3a a3 d6 05 9c $dbl1 [1] 00 c1 04 29 59 03 e1 f3 6a 26 91 1e a7 0a 94 81 d0 c2 58 ef 6a b0 2f 59 c2 [26] f7 fe 63 c3 ce 8a 90 1d 1d ce 14 05 c8 d4 e8 2f cf 98 46 e2 99 af e3 b9 cf [51] 1b 4b 39 8b 47 f3 e3 49 63 d1 0a af 42 9d 48 fe c7 7b ab b4 ab 5b a8 d7 94 [76] 6e 0c 82 24 08 fc 20 d8 cb 7a bb c7 ba 9e 3b 0d d5 d6 8c 9e 2b 48 97 9e c8 [101] f0 c9 4b ad da 6b 9e 41 8b 82 e8 82 ba 6a f2 99 a1 81 82 d5 c0 ca 3d fb ce [126] 54 60 0e 7d 93 bd 32 8e 02 d8 db e0 cb f9 e7 f5 ae e1 b9 73 17 5d ed ff a7 [151] 43 68 23 ee 2d 63 73 d9 a0 43 f6 72 2d 68 19 ff fc 46 0b 49 69 3e 1f bc 03 [176] 1d 1a ab de c9 b0 4a ed 85 af 2f e3 fc 80 99 b7 c4 7f 65 ac c1 96 17 5b 86 [201] 78 2e c8 67 65 45 5d 95 77 3d 3a 9b d8 c7 01 fd e7 1d 5b 2d f6 19 7b 18 20 [226] 67 7c af 43 01 54 b6 2c 99 10 85 28 c4 68 e1 99 67 d9 ae f4 5a e2 04 87 14 [251] 63 8a 89 96 5e f6 fc 9c a3 6a f1 23 29 09 82 c9 2a cc 51 b7 8f 27 53 47 a0 [276] a6 fa 73 2d 07 86 f5 cc 07 98 1a f2 6c d4 e0 f2 43 31 90 98 2c 94 28 25 40 [301] 23 1f 2f 2f 41 50 c3 d2 65 6f 01 32 a1 7f 7a 40 a8 5c 11 db 88 7d 7e a4 1d [326] 7d 43 c3 17 cd 2e ca dc 56 aa c3 74 8d 37 1a 16 07 d4 c5 0a f9 03 8f a7 6d [351] 23 c5 b8 05 ad 7c e1 33 d1 0e 0e 8c 19 72 0d 80 3e c7 80 5c 77 58 b1 ef 89 [376] 39 a5 a2 72 0a c4 c4 c5 16 47 90 da 47 49 a1 b1 81 70 ce cf cf b3 5c ca 3a $dbl2 [1] b9 79 37 9e 87 e6 d0 04 ff 57 34 47 e9 da db 08 35 18 46 24 36 7b 48 f3 75 [26] 78 db 2d 6c 77 76 c5 67 0a 4b b9 64 57 19 b8 f4 69 d5 5d c2 04 8f 91 55 6a [51] d5 2f 33 2d 76 e9 9d f6 f8 5e cf c6 06 5d 6a 73 96 c6 21 e5 ca ad 3f d6 4c [76] 1d 3c 72 9b b3 3a 66 7a e4 91 0d 96 82 63 22 50 12 56 6b 1a 7f 0f 3e 5b e8 [101] bc 28 55 9c 90 22 9c f7 9a f9 60 5f 64 8c d0 c8 c4 cd fa 2d 20 1a db 65 c0 [126] 7e 70 5f 2d 59 57 6f cc 52 4f 75 87 f9 6a 7a e8 1e 2c 5c e7 1b 72 ea 69 8a [151] 6b fb a5 7d 41 05 1a e3 ed e6 ea 50 2b 06 3f 39 e8 a1 e0 69 29 56 5e 0e 72 [176] 29 b2 4c 65 ae 76 d2 cd 18 6c 74 3d f4 62 1f 67 51 37 e4 1f eb 54 0f 00 71 [201] 5b da 32 37 d5 fc 9d f3 c3 0e a6 81 09 19 25 1e 06 61 2f 2c 62 7a 33 fc 41 [226] 13 fc f9 44 55 57 9d d6 4b a7 ba 87 fe 1e 00 d7 1c 0c 34 ba 25 ce 21 7f 97 [251] d5 11 f5 cf 2f a4 34 2f 60 a7 b2 a5 2c 8f 90 29 c5 55 06 c6 6a 19 e4 bc 46 [276] 24 c0 43 8c bf ac d9 db 43 ea 2f 29 da 48 64 fa 51 55 85 81 40 cd ac bc 6e [301] 9b d2 07 e2 94 df 2a 7d c2 bd 63 87 5e 5e 47 8d 2d 21 ac 92 0a b8 52 e4 e5 [326] fb ec d6 5b 17 34 01 02 21 78 b2 83 28 f9 f0 f5 ae 90 27 30 aa 4b 5c 6a d2 [351] da 71 2e 3c c6 68 a7 9f a9 36 16 81 cb cb d8 6d 07 96 6e f4 f9 29 8d 61 f7 [376] 86 51 af f2 7e cc 3d 4f 24 8e e0 9f 70 be b1 af c9 73 f2 4b c9 00 c1 04 29 vctrs/tests/testthat/test-compare.R0000644000176200001440000002127713623013722017153 0ustar liggesuserscontext("test-compare") test_that("inputs must be vectors", { expect_error(vec_compare(NULL, 1), class = "vctrs_error_scalar_type") expect_error(vec_compare(1, NULL), class = "vctrs_error_scalar_type") }) test_that("matches R ordering", { expect_same <- function(x, y) { expect_equal(vec_compare(!!x, !!y), cmp(!!x, !!y)) } expect_same(c(NA, FALSE, TRUE), FALSE) expect_same(c(NA, -100L, 0L, 100L), 0L) expect_same(c(NA, -Inf, -100, 100, Inf), 0L) expect_same(c(NA, NaN, 0), NA) expect_same(c(NA, "a", "b", "c"), "b") expect_same(as.raw(2:5), as.raw(4)) }) test_that("NAs equal when requested", { expect_value <- function(x, y, val, .ptype = NULL) { expect_equal(vec_compare(!!x, !!y, .ptype = .ptype, na_equal = TRUE), !!val) } expect_value(NA, NA, 0L) expect_value(NA, FALSE, -1L) expect_value(FALSE, NA, 1L) expect_value(NA_integer_, NA_integer_, 0L) expect_value(NA_integer_, 0L, -1L) expect_value(0L, NA_integer_, 1L) expect_value(NA_character_, NA_character_, 0L) expect_value(NA_character_, "", -1L) expect_value("", NA_character_, 1L) expect_value(0, NA_real_, 1L) expect_value(0, NaN, 1L) expect_value(0, 0, 0L) expect_value(NA_real_, NA_real_, 0L) expect_value(NA_real_, NaN, 1L) expect_value(NA_real_, 0, -1L) expect_value(NaN, NA_real_, -1L) expect_value(NaN, NaN, 0L) expect_value(NaN, 0, -1L) }) test_that("data frames are compared column by column", { df1 <- data.frame(x = c(1, 1, 1), y = c(-1, 0, 1)) expect_equal(vec_compare(df1, df1[2, ]), c(-1, 0, 1)) expect_equal(vec_compare(df1[1], df1[2, 1, drop = FALSE]), c(0, 0, 0)) expect_equal(vec_compare(df1[2], df1[2, 2, drop = FALSE]), c(-1, 0, 1)) expect_equal(vec_compare(df1[2:1], df1[2, 2:1]), c(-1, 0, 1)) }) test_that("can compare data frames with various types of columns", { x1 <- data_frame(x = 1, y = 2) y1 <- data_frame(x = 2, y = 1) x2 <- data_frame(x = "a") y2 <- data_frame(x = "b") x3 <- data_frame(x = FALSE) y3 <- data_frame(x = TRUE) x4 <- data_frame(x = 1L) y4 <- data_frame(x = 2L) expect_equal(vec_compare(x1, y1), -1) expect_equal(vec_compare(x2, y2), -1) expect_equal(vec_compare(x3, y3), -1) expect_equal(vec_compare(x4, y4), -1) }) test_that("can compare data frames with data frame columns", { df1 <- data_frame(x = data_frame(a = 1)) df2 <- data_frame(x = data_frame(a = 2)) expect_equal(vec_compare(df1, df1), 0) expect_equal(vec_compare(df1, df2), -1) }) test_that("can compare data frames with list columns because of `vec_proxy_compare(relax = TRUE)`", { # lists are replaced with `vec_seq_along()`, # so `list(a = 1)` and `list(a = 0)` look equivalent df1 <- data_frame(x = list(a = 1), y = 2) df2 <- data_frame(x = list(a = 0), y = 3) expect_equal(vec_compare(df1, df2), -1) }) test_that("C code doesn't crash with bad inputs", { df <- data.frame(x = c(1, 1, 1), y = c(-1, 0, 1)) expect_error(.Call(vctrs_compare, df, df[1], TRUE), "not comparable") # Names are not checked, as `vec_cast_common()` should take care of the type. # So if `vec_cast_common()` is not called, or is improperly specified, then # this could result in false equality. expect_equal(.Call(vctrs_compare, df, setNames(df, c("x", "z")), TRUE), c(0, 0, 0)) df1 <- new_data_frame(list(x = 1:3, y = c(1, 1, 1))) df2 <- new_data_frame(list(y = 1:2, x = 1:2)) expect_error(.Call(vctrs_compare, df1, df2, TRUE), "must have the same types and lengths") }) test_that("xtfrm.vctrs_vctr works for variety of base classes", { df <- data.frame(x = c(NA, 1, 1), y = c(1, 2, 1)) expect_equal(xtfrm.vctrs_vctr(df), c(3, 2, 1)) x <- c(2, 3, 1) expect_equal(xtfrm.vctrs_vctr(x), x) expect_equal(xtfrm.vctrs_vctr(letters[x]), x) }) test_that("vec_proxy_compare() refuses to deal with lists", { expect_error(vec_proxy_compare(list()), class = "vctrs_error_unsupported") }) test_that("vec_compare() calls vec_proxy_compare()", { local_methods( vec_proxy_compare.vctrs_foobar = function(x) rev(x), vec_ptype2.integer.vctrs_foobar = function(...) foobar(int()), vec_ptype2.vctrs_foobar = function(...) foobar(int()), vec_cast.vctrs_foobar = function(x, ...) x ) expect_identical(vec_compare(1:3, 1:3), int(0, 0, 0)) expect_identical(vec_compare(1:3, foobar(1:3)), int(-1, 0, 1)) }) test_that("vec_proxy_compare() preserves data frames and vectors", { df <- data_frame(x = 1:2, y = c("a", "b")) expect_identical(vec_proxy_compare(df), df) x <- c(NA, "a", "b", "c") expect_identical(vec_proxy_compare(x), x) }) test_that("vec_proxy_compare() handles data frame with a POSIXlt column", { df <- data.frame(times = 1:5, x = 1:5) df$times <- as.POSIXlt(seq.Date(as.Date("2019-12-30"), as.Date("2020-01-03"), by = "day")) df2 <- df df2$times <- vec_proxy_compare(df$times) expect_identical( vec_proxy_compare(df), vec_proxy_compare(df2) ) }) test_that("vec_proxy_compare.POSIXlt() correctly orders (#720)", { dates <- as.POSIXlt(seq.Date(as.Date("2019-12-30"), as.Date("2020-01-03"), by = "day")) expect_equal(vec_order(dates), 1:5) }) test_that("error is thrown with data frames with 0 columns", { x <- new_data_frame(n = 1L) expect_error(vec_compare(x, x), "data frame with zero columns") }) test_that("error is thrown when comparing lists", { expect_error(vec_compare(list(), list()), class = "vctrs_error_unsupported") expect_error(.Call(vctrs_compare, list(), list(), FALSE), "Can't compare lists") }) test_that("error is thrown when comparing scalars", { x <- new_sclr(x = 1) expect_error(vec_compare(x, x), class = "vctrs_error_scalar_type") expect_error(.Call(vctrs_compare, x, x, FALSE), class = "vctrs_error_scalar_type") }) test_that("`na_equal` is validated", { expect_error(vec_compare(1, 1, na_equal = 1), class = "vctrs_error_assert_ptype") expect_error(vec_compare(1, 1, na_equal = c(TRUE, FALSE)), class = "vctrs_error_assert_size") }) test_that("can compare equal strings with different encodings", { for (x_encoding in encodings()) { for (y_encoding in encodings()) { expect_equal(vec_compare(x_encoding, y_encoding), 0L) } } }) test_that("can compare non-equal strings with different encodings", { x <- "x" y <- encodings()$latin1 expect_equal(vec_compare(x, y), -1L) }) test_that("equality can always be determined when strings have identical encodings", { encs <- encodings(bytes = TRUE) for (enc in encs) { expect_equal(vec_compare(enc, enc), 0L) } }) test_that("equality is known to fail when comparing bytes to other encodings", { error <- "translating strings with \"bytes\" encoding" for (enc in encodings()) { expect_error(vec_compare(encoding_bytes(), enc), error) expect_error(vec_compare(enc, encoding_bytes()), error) } }) test_that("can compare unspecified", { expect_equal(vec_compare(NA, NA), NA_integer_) expect_equal(vec_compare(NA, NA, na_equal = TRUE), 0) expect_equal(vec_compare(c(NA, NA), unspecified(2)), c(NA_integer_, NA_integer_)) }) # order/sort -------------------------------------------------------------- test_that("can request NAs sorted first", { expect_equal(vec_order(c(1, NA), "asc", "large"), 1:2) expect_equal(vec_order(c(1, NA), "desc", "large"), 2:1) expect_equal(vec_order(c(1, NA), "asc", "small"), 2:1) expect_equal(vec_order(c(1, NA), "desc", "small"), 1:2) }) test_that("can sort data frames", { df <- data.frame(x = c(1, 2, 1), y = c(1, 2, 2)) out1 <- vec_sort(df) expect_equal(out1, data.frame(x = c(1, 1, 2), y = c(1, 2, 2))) out2 <- vec_sort(df, "desc") expect_equal(out2, data.frame(x = c(2, 1, 1), y = c(2, 2, 1))) }) test_that("can sort empty data frames (#356)", { df1 <- data.frame() expect_equal(vec_sort(df1), df1) df2 <- data.frame(x = numeric(), y = integer()) expect_equal(vec_sort(df2), df2) }) test_that("can order tibbles that contain non-comparable objects", { expect_equal(vec_order(data_frame(list(10, 2, 1))), 1:3) }) test_that("can order matrices and arrays (#306)", { x <- matrix(c(1, 1, 1, 1, 2, 1), ncol = 2) expect_identical(vec_order(x), c(1L, 3L, 2L)) x <- array(1:8, c(2, 2, 2)) x[2] <- 1 x[3] <- 5 expect_identical(vec_order(x), 2:1) }) test_that("can order empty data frames (#356)", { df1 <- data.frame() expect_equal(vec_order(df1), integer()) df2 <- data.frame(x = numeric(), y = integer()) expect_equal(vec_order(df2), integer()) }) test_that("can order data frames with data frame columns (#527)", { expect_equal( vec_order(iris), vec_order(data_frame(iris = iris)) ) }) test_that("can order data frames (and subclasses) with matrix columns", { df <- new_data_frame(n = 2L) df$x <- new_data_frame(list(y = matrix(1:2, 2))) expect_identical(vec_order(df), 1:2) df$x <- tibble::tibble(y = matrix(1:2, 2)) expect_identical(vec_order(df), 1:2) }) vctrs/tests/testthat/helper-c.R0000644000176200001440000000007413622451540016242 0ustar liggesusers class_type <- function(x) { .Call(vctrs_class_type, x) } vctrs/tests/testthat/test-type-tibble.R0000644000176200001440000000417213623013722017740 0ustar liggesuserscontext("test-type-tibble") test_that("tibble beats data frame", { df <- new_data_frame() dt <- tibble::tibble() expect_s3_class(vec_ptype_common(dt, df), "tbl_df") expect_s3_class(vec_ptype_common(df, dt), "tbl_df") }) test_that("can cast tibble to df and vice versa", { df <- new_data_frame() dt <- tibble::tibble() expect_equal(vec_cast(df, dt), dt) expect_equal(vec_cast(dt, df), df) }) test_that("can't cast vector to tibble", { dt <- tibble::tibble() v <- logical() expect_error(vec_ptype2(v, dt), class = "vctrs_error_incompatible_type") expect_error(vec_ptype2(dt, v), class = "vctrs_error_incompatible_type") expect_error(vec_cast(v, dt), class = "vctrs_error_incompatible_cast") }) test_that("no common type between list and tibble", { dt <- tibble::tibble() l <- list() expect_error(vec_ptype2(l, dt), class = "vctrs_error_incompatible_type") expect_error(vec_ptype2(dt, l), class = "vctrs_error_incompatible_type") }) test_that("can cast a list of 1 or 0 row tibbles to a tibble", { dt1 <- tibble::tibble(x = numeric()) dt2 <- tibble::tibble(x = 1) lst <- list(dt1, dt2) expect <- tibble::tibble(x = c(NA, 1)) expect_equal(vec_cast(lst, dt1), expect) }) test_that("vec_restore restores tibbles", { df1 <- tibble::tibble(x = 1:4) df2 <- vec_restore(vec_data(df1), df1) expect_s3_class(df2, "tbl_df") }) test_that("the type of a tibble with an unspecified column retains unspecifiedness", { df1 <- tibble::tibble(x = 1, y = NA) df2 <- tibble::tibble(x = 1, y = unspecified(1)) expect <- tibble::tibble(x = numeric(), y = unspecified()) expect_identical(vec_ptype(df1), expect) expect_identical(vec_ptype(df2), expect) }) test_that("vec_ptype_finalise() works recursively over tibbles", { df <- tibble(x = numeric(), y = unspecified()) expect <- tibble(x = numeric(), y = logical()) expect_identical(vec_ptype_finalise(df), expect) }) test_that("vec_ptype_finalise() can handle tibble df columns", { df <- tibble(x = numeric(), y = tibble(z = unspecified())) expect <- tibble(x = numeric(), y = tibble(z = logical())) expect_identical(vec_ptype_finalise(df), expect) }) vctrs/tests/testthat/test-assert-explanations.txt0000644000176200001440000000472313623022030022134 0ustar liggesusers> vec_assert(lgl(), chr()): Error: `lgl()` must be a vector with type . Instead, it has type . > vec_assert(lgl(), factor()): Error: `lgl()` must be a vector with type >. Instead, it has type . > vec_assert(lgl(), factor(levels = "foo")): Error: `lgl()` must be a vector with type >. Instead, it has type . > vec_assert(factor(levels = "bar"), factor(levels = "foo")): Error: `factor(levels = "bar")` must be a vector with type >. Instead, it has type >. > vec_assert(factor(), chr()): Error: `factor()` must be a vector with type . Instead, it has type >. > vec_assert(lgl(), data.frame()): Error: `lgl()` must be a vector with type >. Instead, it has type . > vec_assert(lgl(), data.frame(x = 1)): Error: `lgl()` must be a vector with type >. Instead, it has type . > vec_assert(lgl(), data.frame(x = 1, y = 2)): Error: `lgl()` must be a vector with type: > Instead, it has type . > vec_assert(data.frame(), chr()): Error: `data.frame()` must be a vector with type . Instead, it has type >. > vec_assert(data.frame(x = 1), chr()): Error: `data.frame(x = 1)` must be a vector with type . Instead, it has type >. > vec_assert(data.frame(x = 1), data.frame(x = "foo")): Error: `data.frame(x = 1)` must be a vector with type >. Instead, it has type >. > vec_assert(data.frame(x = 1), data.frame(x = "foo", y = 2)): Error: `data.frame(x = 1)` must be a vector with type: > Instead, it has type >. > vec_assert(data.frame(x = 1, y = 2), chr()): Error: `data.frame(x = 1, y = 2)` must be a vector with type . Instead, it has type: > > vec_assert(data.frame(x = 1, y = 2), data.frame(x = "foo")): Error: `data.frame(x = 1, y = 2)` must be a vector with type >. Instead, it has type: > > vec_assert(data.frame(x = 1, y = 2), data.frame(x = "foo", y = 2)): Error: `data.frame(x = 1, y = 2)` must be a vector with type: > Instead, it has type: > vctrs/tests/testthat/test-slice.R0000644000176200001440000007065413623013722016627 0ustar liggesusers test_that("vec_slice throws error with non-vector inputs", { expect_error(vec_slice(environment(), 1L), class = "vctrs_error_scalar_type") }) test_that("vec_slice throws error with non-vector subscripts", { expect_error(vec_slice(1:3, Sys.Date()), class = "vctrs_error_incompatible_cast") expect_error(vec_slice(1:3, matrix(TRUE, nrow = 1)), "must have one dimension") }) test_that("can subset base vectors", { i <- 2:3 expect_identical(vec_slice(lgl(1, 0, 1), i), lgl(0, 1)) expect_identical(vec_slice(int(1, 2, 3), i), int(2, 3)) expect_identical(vec_slice(dbl(1, 2, 3), i), dbl(2, 3)) expect_identical(vec_slice(cpl(1, 2, 3), i), cpl(2, 3)) expect_identical(vec_slice(chr("1", "2", "3"), i), chr("2", "3")) expect_identical(vec_slice(bytes(1, 2, 3), i), bytes(2, 3)) expect_identical(vec_slice(list(1, 2, 3), i), list(2, 3)) }) test_that("can subset shaped base vectors", { i <- 2:3 mat <- as.matrix expect_identical(vec_slice(mat(lgl(1, 0, 1)), i), mat(lgl(0, 1))) expect_identical(vec_slice(mat(int(1, 2, 3)), i), mat(int(2, 3))) expect_identical(vec_slice(mat(dbl(1, 2, 3)), i), mat(dbl(2, 3))) expect_identical(vec_slice(mat(cpl(1, 2, 3)), i), mat(cpl(2, 3))) expect_identical(vec_slice(mat(chr("1", "2", "3")), i), mat(chr("2", "3"))) expect_identical(vec_slice(mat(bytes(1, 2, 3)), i), mat(bytes(2, 3))) expect_identical(vec_slice(mat(list(1, 2, 3)), i), mat(list(2, 3))) }) test_that("can subset with missing indices", { for (i in list(int(2L, NA), lgl(FALSE, TRUE, NA))) { expect_identical(vec_slice(lgl(1, 0, 1), i), lgl(0, NA)) expect_identical(vec_slice(int(1, 2, 3), i), int(2, NA)) expect_identical(vec_slice(dbl(1, 2, 3), i), dbl(2, NA)) expect_identical(vec_slice(cpl(1, 2, 3), i), cpl(2, NA)) expect_identical(vec_slice(chr("1", "2", "3"), i), c("2", NA)) expect_identical(vec_slice(bytes(1, 2, 3), i), bytes(2, 0)) expect_identical(vec_slice(list(1, 2, 3), i), list(2, NULL)) } }) test_that("can subset with a recycled NA", { expect_identical(vec_slice(1:3, NA), int(NA, NA, NA)) expect_identical(vec_slice(new_vctr(1:3), NA), new_vctr(int(NA, NA, NA))) rownames <- rep_len("", nrow(mtcars)) rownames <- vec_as_names(rownames, repair = "unique") expect_identical(vec_slice(mtcars, NA), structure(mtcars[NA, ], row.names = rownames)) }) test_that("can subset with a recycled TRUE", { expect_identical(vec_slice(1:3, TRUE), 1:3) expect_identical(vec_slice(mtcars, TRUE), mtcars) expect_identical(vec_slice(new_vctr(1:3), TRUE), new_vctr(1:3)) expect_identical(vec_as_location(TRUE, 2), 1:2) }) test_that("can subset with a recycled FALSE", { expect_identical(vec_slice(1:3, FALSE), int()) expect_identical(vec_slice(mtcars, FALSE), mtcars[NULL, ]) expect_identical(vec_slice(new_vctr(1:3), FALSE), new_vctr(integer())) }) test_that("can't index beyond the end of a vector", { verify_errors({ expect_error(vec_slice(1:2, 3L), class = "vctrs_error_subscript_oob") expect_error(vec_slice(1:2, -3L), class = "vctrs_error_subscript_oob") }) }) test_that("slicing non existing elements fails", { expect_error(vec_as_location("foo", 1L, "f"), class = "vctrs_error_subscript_oob") expect_error(vec_slice(c(f = 1), "foo"), class = "vctrs_error_subscript_oob") }) test_that("can subset object of any dimensionality", { x0 <- c(1, 1) x1 <- ones(2) x2 <- ones(2, 3) x3 <- ones(2, 3, 4) x4 <- ones(2, 3, 4, 5) expect_equal(vec_slice(x0, 1L), 1) expect_identical(vec_slice(x1, 1L), ones(1)) expect_identical(vec_slice(x2, 1L), ones(1, 3)) expect_identical(vec_slice(x3, 1L), ones(1, 3, 4)) expect_identical(vec_slice(x4, 1L), ones(1, 3, 4, 5)) }) test_that("can subset using logical subscript", { x0 <- c(1, 1) expect_identical(vec_slice(x0, TRUE), x0) expect_identical(vec_slice(x0, c(TRUE, FALSE)), 1) expect_error( vec_slice(x0, c(TRUE, FALSE, TRUE)), class = "vctrs_error_subscript_size" ) expect_error( vec_slice(x0, lgl()), class = "vctrs_error_subscript_size" ) expect_error( vec_slice(mtcars, c(TRUE, FALSE)), class = "vctrs_error_subscript_size" ) }) test_that("can subset data frame columns", { df <- data.frame(x = 1:2) df$y <- data.frame(a = 2:1) expect_equal(vec_slice(df, 1L)$y, vec_slice(df$y, 1L)) }) test_that("can subset empty data frames", { df <- new_data_frame(n = 3L) expect_equal(vec_size(vec_slice(df, integer())), 0) expect_equal(vec_size(vec_slice(df, 1L)), 1) expect_equal(vec_size(vec_slice(df, 1:3)), 3) df$df <- df expect_equal(vec_size(vec_slice(df, integer())), 0) expect_equal(vec_size(vec_slice(df, 1L)), 1) expect_equal(vec_size(vec_slice(df, 1:3)), 3) }) test_that("ignores NA in logical subsetting", { x <- c(NA, 1, 2) expect_equal(vec_slice(x, x > 0), c(NA, 1, 2)) }) test_that("ignores NA in integer subsetting", { expect_equal(vec_slice(0:2, c(NA, 2:3)), c(NA, 1, 2)) }) test_that("can't slice with missing argument", { expect_error(vec_slice(1:3)) expect_error(vec_slice(mtcars)) expect_error(vec_slice(new_vctr(1:3))) }) test_that("can slice with NULL argument", { expect_identical(vec_slice(1:3, NULL), integer()) expect_identical(vec_slice(iris, NULL), iris[0, ]) expect_identical(vec_slice(new_vctr(1:3), NULL), new_vctr(integer())) }) test_that("slicing unclassed structures preserves attributes", { x <- structure(1:3, foo = "bar") expect_identical(vec_slice(x, 1L), structure(1L, foo = "bar")) }) test_that("can slice with negative indices", { expect_identical(vec_slice(1:3, -c(1L, 3L)), 2L) expect_identical(vec_slice(mtcars, -(1:30)), vec_slice(mtcars, 31:32)) expect_error(vec_slice(1:3, -c(1L, NA)), class = "vctrs_error_subscript_type") expect_error(vec_slice(1:3, c(-1L, 1L)), class = "vctrs_error_subscript_type") }) test_that("0 is ignored in negative indices", { expect_identical(vec_slice(1:3, c(-2L, 0L)), int(1L, 3L)) expect_identical(vec_slice(1:3, c(0L, -2L)), int(1L, 3L)) }) test_that("0 is ignored in positive indices", { expect_identical(vec_slice(1:3, 0L), int()) expect_identical(vec_slice(1:3, c(0L, 0L)), int()) expect_identical(vec_slice(1:3, c(0L, 2L, 0L)), 2L) }) test_that("can slice with double indices", { expect_identical(vec_slice(1:3, dbl(2, 3)), 2:3) err <- expect_error(vec_as_location(2^31, 3L), class = "vctrs_error_subscript_type") expect_is(err$parent, "vctrs_error_cast_lossy") }) test_that("can slice with symbols", { expect_identical(vec_as_location(quote(b), 26, letters), 2L) }) test_that("vec_as_location() checks type", { expect_error(vec_as_location("foo", "bar"), class = "vctrs_error_incompatible_type") expect_error(vec_as_location("foo", 1L, names = 1L), "must be a character vector") expect_error(vec_as_location(Sys.Date(), 3L), class = "vctrs_error_subscript_type") expect_error(vec_as_location(matrix(TRUE, nrow = 1), 3L), "must have one dimension") }) test_that("can `vec_slice()` S3 objects without dispatch infloop", { expect_identical(new_vctr(1:3)[1], new_vctr(1L)) expect_identical(new_vctr(as.list(1:3))[1], new_vctr(list(1L))) }) test_that("can `vec_slice()` records", { out <- vec_slice(new_rcrd(list(a = 1L, b = 2L)), rep(1, 3)) expect_size(out, 3) out <- vec_init(new_rcrd(list(a = 1L, b = 2L)), 2) expect_size(out, 2) }) test_that("vec_restore() is called after proxied slicing", { local_methods( vec_proxy.vctrs_foobar = identity, vec_restore.vctrs_foobar = function(x, to, ...) "dispatch" ) expect_identical(vec_slice(foobar(1:3), 2), "dispatch") }) test_that("vec_slice() is proxied", { local_proxy() x <- vec_slice(new_proxy(1:3), 2:3) expect_identical(proxy_deref(x), 2:3) }) test_that("dimensions are preserved by vec_slice()", { attrib <- NULL local_methods( vec_restore.vctrs_foobar = function(x, ...) attrib <<- attributes(x) ) x <- foobar(1:4) dim(x) <- c(2, 2) dimnames(x) <- list(a = c("foo", "bar"), b = c("quux", "hunoz")) vec_slice(x, 1) exp <- list(dim = 1:2, dimnames = list(a = "foo", b = c("quux", "hunoz"))) expect_identical(attrib, exp) }) test_that("can slice shaped objects by name", { x <- matrix(1:2) expect_error(vec_slice(x, "foo"), "unnamed") dimnames(x) <- list(c("foo", "bar")) expect_equal(vec_slice(x, "foo"), vec_slice(x, 1L)) expect_error(vec_slice(x, "baz"), class = "vctrs_error_subscript_oob") }) test_that("vec_slice() unclasses input before calling `vec_restore()`", { oo <- NULL local_methods( vec_proxy.vctrs_foobar = identity, vec_restore.vctrs_foobar = function(x, ...) oo <<- is.object(x) ) x <- foobar(1:4) dim(x) <- c(2, 2) vec_slice(x, 1) expect_false(oo) }) test_that("can call `vec_slice()` from `[` methods with shaped objects without infloop", { local_methods( `[.vctrs_foobar` = function(x, i, ...) vec_slice(x, i) ) x <- foobar(1:4) dim(x) <- c(2, 2) exp <- foobar(c(1L, 3L)) dim(exp) <- c(1, 2) expect_identical(x[1], exp) }) test_that("vec_slice() falls back to `[` with S3 objects", { local_methods( `[.vctrs_foobar` = function(x, i, ...) "dispatched" ) expect_identical(vec_slice(foobar(NA), 1), foobar("dispatched")) expect_error(vec_slice(foobar(list(NA)), 1), class = "vctrs_error_scalar_type") local_methods( vec_proxy.vctrs_foobar = identity ) expect_identical(vec_slice(foobar(list(NA)), 1), foobar(list(NA))) }) test_that("vec_slice() doesn't restore when attributes have already been restored", { local_methods( `[.vctrs_foobar` = function(x, i, ...) structure("dispatched", foo = "bar"), vec_restore.vctrs_foobar = function(...) stop("not called") ) expect_error(vec_slice(foobar(NA), 1), NA) }) test_that("can vec_slice() without inflooping when restore calls math generics", { local_methods( new_foobar = function(x) { new_vctr(as.double(x), class = "vctrs_foobar") }, vec_restore.vctrs_foobar = function(x, ...) { abs(x) sum(x) mean(x) is.finite(x) is.infinite(x) is.nan(x) new_foobar(x) } ) expect_identical(new_foobar(1:10)[1:2], new_foobar(1:2)) }) test_that("vec_restore() is called after slicing data frames", { local_methods( vec_restore.vctrs_tabble = function(...) "dispatched" ) df <- structure(mtcars, class = c("vctrs_tabble", "data.frame")) expect_identical(vec_slice(df, 1), "dispatched") }) test_that("additional subscripts are forwarded to `[`", { local_methods( `[.vctrs_foobar` = function(x, i, ...) vec_index(x, i, ...) ) x <- foobar(c("foo", "bar", "quux", "hunoz")) dim(x) <- c(2, 2) exp <- foobar("quux") dim(exp) <- c(1, 1) expect_identical(x[1, 2], exp) }) test_that("can use names to vec_slice() a named object", { x0 <- c(a = 1, b = 2) x1 <- c(a = 1, a = 2) expect_identical(vec_slice(x0, letters[1]), c(a = 1)) expect_identical(vec_slice(x0, letters[2:1]), c(b = 2, a = 1)) expect_identical(vec_slice(x1, letters[1]), c(a = 1)) expect_error(vec_slice(x0, letters[3:1]), class = "vctrs_error_subscript_oob") expect_error(vec_slice(x1, letters[2]), class = "vctrs_error_subscript_oob") }) test_that("can't use names to vec_slice() an unnamed object", { expect_error( vec_slice(1:3, letters[1]), "Can't use character names to index an unnamed vector.", fixed = TRUE ) expect_error( vec_slice(1:3, letters[25:27]), "Can't use character names to index an unnamed vector.", fixed = TRUE ) }) test_that("can slice with missing character indices (#244)", { expect_identical(vec_as_location(na_chr, 2L, c("x", "")), na_int) expect_identical(vec_slice(c(x = 1), na_chr), set_names(na_dbl, "")) expect_identical(vec_slice(c(x = "foo"), na_chr), set_names(na_chr, "")) }) test_that("can slice with numerics (#577)", { expect_identical(vec_as_location(1:2, 3), 1:2) expect_error(vec_as_location(1:2, 3.5), class = "vctrs_error_cast_lossy") }) test_that("missing indices don't create NA names", { x <- set_names(letters) expect_identical(vec_slice(x, na_int), set_names(na_chr, "")) expect_identical(vec_slice(x, int(1, NA, 3, NA)), chr(a = "a", NA, c = "c", NA)) # Preserves existing NA names x <- set_names(1:2, c(NA, "foo")) expect_identical(vec_slice(x, 1:2), x) }) test_that("vec_slice throws error with non-vector inputs", { expect_error(vec_slice(environment(), 1L), class = "vctrs_error_scalar_type") }) test_that("vec_slice() asserts vectorness (#301)", { expect_error(vec_slice(NULL, 1), class = "vctrs_error_scalar_type") }) test_that("slicing an unspecified logical vector returns a logical vector", { expect_identical(vec_slice(NA, integer()), logical()) expect_identical(vec_slice(NA, c(1, 1)), c(NA, NA)) }) test_that("slicing an unspecified() object returns an unspecified()", { expect_identical(vec_slice(unspecified(1), integer()), unspecified()) expect_identical(vec_slice(unspecified(1), c(1, 1)), unspecified(2)) }) # vec_init ---------------------------------------------------------------- test_that("na of atomic vectors is as expected", { expect_equal(vec_init(TRUE), NA) expect_equal(vec_init(1L), NA_integer_) expect_equal(vec_init(1), NA_real_) expect_equal(vec_init("x"), NA_character_) expect_equal(vec_init(1i), NA_complex_) }) test_that("na of factor preserves levels", { f1 <- factor("a", levels = c("a", "b")) f2 <- vec_init(f1) expect_equal(levels(f1), levels(f2)) }) test_that("na of POSIXct preserves tz", { dt1 <- as.POSIXct("2010-01-01", tz = "America/New_York") dt2 <- vec_init(dt1) expect_equal(attr(dt2, "tzone"), "America/New_York") }) test_that("na of list is list(NULL)", { expect_equal(vec_init(list()), list(NULL)) }) test_that("na of array is 1d slice", { x1 <- array(1:12, c(2, 3, 4)) x2 <- vec_init(x1) expect_equal(x2, array(NA_integer_, c(1, 3, 4))) }) test_that("na of list-array is 1d slice", { x1 <- array(as.list(1:12), c(2, 3, 4)) x2 <- vec_init(x1) expect_equal(x2, array(list(), c(1, 3, 4))) }) test_that("vec_init() asserts vectorness (#301)", { expect_error(vec_init(NULL, 1L), class = "vctrs_error_scalar_type") }) test_that("vec_init() works with Altrep classes", { skip_if(getRversion() < "3.5") x <- .Call(vctrs_rle, c(foo = 1L, bar = 2L)) expect_equal(vec_init(x, 2), rep(NA_character_, 2)) }) # vec_chop ---------------------------------------------------------------- test_that("vec_chop() throws error with non-vector inputs", { expect_error(vec_chop(NULL), class = "vctrs_error_scalar_type") expect_error(vec_chop(environment()), class = "vctrs_error_scalar_type") }) test_that("atomics are split into a list", { x <- 1:5 expect_equal(vec_chop(x), as.list(x)) x <- letters[1:5] expect_equal(vec_chop(x), as.list(x)) }) test_that("atomic names are kept", { x <- set_names(1:5) result <- lapply(vec_chop(x), names) expect_equal(result, as.list(names(x))) }) test_that("base R classed objects are split into a list", { fctr <- factor(c("a", "b")) expect <- lapply(vec_seq_along(fctr), vec_slice, x = fctr) expect_equal(vec_chop(fctr), expect) date <- new_date(c(0, 1)) expect <- lapply(vec_seq_along(date), vec_slice, x = date) expect_equal(vec_chop(date), expect) }) test_that("base R classed object names are kept", { fctr <- set_names(factor(c("a", "b"))) result <- lapply(vec_chop(fctr), names) expect_equal(result, as.list(names(fctr))) }) test_that("list elements are split", { x <- list(1, 2) result <- list(vec_slice(x, 1), vec_slice(x, 2)) expect_equal(vec_chop(x), result) }) test_that("data frames are split rowwise", { x <- data_frame(x = 1:2, y = c("a", "b")) result <- list(vec_slice(x, 1), vec_slice(x, 2)) expect_equal(vec_chop(x), result) }) test_that("data frame row names are kept", { x <- data_frame(x = 1:2, y = c("a", "b")) rownames(x) <- c("r1", "r2") result <- lapply(vec_chop(x), rownames) expect_equal(result, list("r1", "r2")) }) test_that("matrices / arrays are split rowwise", { x <- array(1:12, c(2, 2, 2)) result <- list(vec_slice(x, 1), vec_slice(x, 2)) expect_equal(vec_chop(x), result) }) test_that("matrix / array row names are kept", { x <- array(1:12, c(2, 2, 2), dimnames = list(c("r1", "r2"), c("c1", "c2"))) result <- lapply(vec_chop(x), rownames) expect_equal(result, list("r1", "r2")) }) test_that("matrices / arrays without row names have other dimension names kept", { x <- array(1:12, c(2, 2, 2), dimnames = list(NULL, c("c1", "c2"))) result <- lapply(vec_chop(x), colnames) expect_equal(result, list(c("c1", "c2"), c("c1", "c2"))) }) test_that("vec_chop() doesn't restore when attributes have already been restored", { local_methods( `[.vctrs_foobar` = function(x, i, ...) structure("dispatched", foo = "bar"), vec_restore.vctrs_foobar = function(...) structure("dispatched-and-restored", foo = "bar") ) result <- vec_chop(foobar(NA))[[1]] expect_equal(result, structure("dispatched", foo = "bar")) }) test_that("vec_chop() restores when attributes have not been restored by `[`", { local_methods( `[.vctrs_foobar` = function(x, i, ...) "dispatched", vec_restore.vctrs_foobar = function(...) "dispatched-and-restored" ) result <- vec_chop(foobar(NA))[[1]] expect_equal(result, "dispatched-and-restored") }) test_that("vec_chop() falls back to `[` for shaped objects with no proxy", { x <- foobar(1) dim(x) <- c(1, 1) result <- vec_chop(x)[[1]] expect_equal(result, x) }) test_that("`indices` are validated", { expect_error(vec_chop(1, 1), "`indices` must be a list of index values, or `NULL`") expect_error(vec_chop(1, list(1.5)), class = "vctrs_error_cast_lossy") expect_error(vec_chop(1, list(2)), class = "vctrs_error_subscript_oob") }) test_that("size 0 `indices` list is allowed", { expect_equal(vec_chop(1, list()), list()) }) test_that("individual index values of size 0 are allowed", { expect_equal(vec_chop(1, list(integer())), list(numeric())) df <- data.frame(a = 1, b = "1") expect_equal(vec_chop(df, list(integer())), list(vec_ptype(df))) }) test_that("data frame row names are kept when `indices` are used", { x <- data_frame(x = 1:2, y = c("a", "b")) rownames(x) <- c("r1", "r2") result <- lapply(vec_chop(x, list(1, 1:2)), rownames) expect_equal(result, list("r1", c("r1", "r2"))) }) test_that("vec_chop(, indices =) can be equivalent to the default", { x <- 1:5 indices <- as.list(vec_seq_along(x)) expect_equal(vec_chop(x, indices), vec_chop(x)) }) test_that("vec_chop(, indices =) can be equivalent to the default", { x <- data.frame(x = 1:5) indices <- as.list(vec_seq_along(x)) expect_equal(vec_chop(x, indices), vec_chop(x)) }) test_that("vec_chop(, indices =) can be equivalent to the default", { x <- array(1:8, c(2, 2, 2)) indices <- as.list(vec_seq_along(x)) expect_equal(vec_chop(x, indices), vec_chop(x)) }) test_that("`indices` can use names", { x <- set_names(1:3, c("a", "b", "c")) expect_equal( vec_chop(x, list(1, 2:3)), vec_chop(x, list("a", c("b", "c"))) ) }) test_that("`indices` can use array row names", { x <- array(1:4, c(2, 2), dimnames = list(c("r1", "r2"))) expect_equal( vec_chop(x, list("r1")), vec_chop(x, list(1)) ) }) test_that("`indices` cannot use data frame row names", { df <- data.frame(x = 1, row.names = "r1") expect_error(vec_chop(df, list("r1")), "Can't use character") }) test_that("fallback method with `indices` works", { fctr <- factor(c("a", "b")) indices <- list(1, c(1, 2)) expect_equal( vec_chop(fctr, indices), map(indices, vec_slice, x = fctr) ) }) test_that("vec_chop() falls back to `[` for shaped objects with no proxy when indices are provided", { x <- foobar(1) dim(x) <- c(1, 1) result <- vec_chop(x, list(1))[[1]] expect_equal(result, x) }) # vec_slice + compact_rep ------------------------------------------------- # `i` is 1-based test_that("names are repaired correctly with compact reps and `NA_integer_`", { x <- list(a = 1L, b = 2L) expect <- set_names(list(NULL, NULL), c("", "")) expect_equal(vec_slice_rep(x, NA_integer_, 2L), expect) }) test_that("vec_slice() with compact_reps work with Altrep classes", { skip_if(getRversion() < "3.5") x <- .Call(vctrs_rle, c(foo = 10L, bar = 5L)) expect_equal(vec_slice_rep(x, 10L, 3L), rep("foo", 3)) }) # vec_slice + compact_seq ------------------------------------------------- # `start` is 0-based test_that("can subset base vectors with compact seqs", { start <- 1L size <- 2L increasing <- TRUE expect_identical(vec_slice_seq(lgl(1, 0, 1), start, size, increasing), lgl(0, 1)) expect_identical(vec_slice_seq(int(1, 2, 3), start, size, increasing), int(2, 3)) expect_identical(vec_slice_seq(dbl(1, 2, 3), start, size, increasing), dbl(2, 3)) expect_identical(vec_slice_seq(cpl(1, 2, 3), start, size, increasing), cpl(2, 3)) expect_identical(vec_slice_seq(chr("1", "2", "3"), start, size, increasing), chr("2", "3")) expect_identical(vec_slice_seq(bytes(1, 2, 3), start, size, increasing), bytes(2, 3)) expect_identical(vec_slice_seq(list(1, 2, 3), start, size, increasing), list(2, 3)) }) test_that("can subset base vectors with decreasing compact seqs", { start <- 2L size <- 2L increasing <- FALSE expect_identical(vec_slice_seq(lgl(1, 0, 1), start, size, increasing), lgl(1, 0)) expect_identical(vec_slice_seq(int(1, 2, 3), start, size, increasing), int(3, 2)) expect_identical(vec_slice_seq(dbl(1, 2, 3), start, size, increasing), dbl(3, 2)) expect_identical(vec_slice_seq(cpl(1, 2, 3), start, size, increasing), cpl(3, 2)) expect_identical(vec_slice_seq(chr("1", "2", "3"), start, size, increasing), chr("3", "2")) expect_identical(vec_slice_seq(bytes(1, 2, 3), start, size, increasing), bytes(3, 2)) expect_identical(vec_slice_seq(list(1, 2, 3), start, size, increasing), list(3, 2)) }) test_that("can subset base vectors with size 0 compact seqs", { start <- 1L size <- 0L increasing <- TRUE expect_identical(vec_slice_seq(lgl(1, 0, 1), start, size, increasing), lgl()) expect_identical(vec_slice_seq(int(1, 2, 3), start, size, increasing), int()) expect_identical(vec_slice_seq(dbl(1, 2, 3), start, size, increasing), dbl()) expect_identical(vec_slice_seq(cpl(1, 2, 3), start, size, increasing), cpl()) expect_identical(vec_slice_seq(chr("1", "2", "3"), start, size, increasing), chr()) expect_identical(vec_slice_seq(bytes(1, 2, 3), start, size, increasing), bytes()) expect_identical(vec_slice_seq(list(1, 2, 3), start, size, increasing), list()) }) test_that("can subset shaped base vectors with compact seqs", { start <- 1L size <- 2L increasing <- TRUE mat <- as.matrix expect_identical(vec_slice_seq(mat(lgl(1, 0, 1)), start, size, increasing), mat(lgl(0, 1))) expect_identical(vec_slice_seq(mat(int(1, 2, 3)), start, size, increasing), mat(int(2, 3))) expect_identical(vec_slice_seq(mat(dbl(1, 2, 3)), start, size, increasing), mat(dbl(2, 3))) expect_identical(vec_slice_seq(mat(cpl(1, 2, 3)), start, size, increasing), mat(cpl(2, 3))) expect_identical(vec_slice_seq(mat(chr("1", "2", "3")), start, size, increasing), mat(chr("2", "3"))) expect_identical(vec_slice_seq(mat(bytes(1, 2, 3)), start, size, increasing), mat(bytes(2, 3))) expect_identical(vec_slice_seq(mat(list(1, 2, 3)), start, size, increasing), mat(list(2, 3))) }) test_that("can subset shaped base vectors with decreasing compact seqs", { start <- 2L size <- 2L increasing <- FALSE mat <- as.matrix expect_identical(vec_slice_seq(mat(lgl(1, 0, 1)), start, size, increasing), mat(lgl(1, 0))) expect_identical(vec_slice_seq(mat(int(1, 2, 3)), start, size, increasing), mat(int(3, 2))) expect_identical(vec_slice_seq(mat(dbl(1, 2, 3)), start, size, increasing), mat(dbl(3, 2))) expect_identical(vec_slice_seq(mat(cpl(1, 2, 3)), start, size, increasing), mat(cpl(3, 2))) expect_identical(vec_slice_seq(mat(chr("1", "2", "3")), start, size, increasing), mat(chr("3", "2"))) expect_identical(vec_slice_seq(mat(bytes(1, 2, 3)), start, size, increasing), mat(bytes(3, 2))) expect_identical(vec_slice_seq(mat(list(1, 2, 3)), start, size, increasing), mat(list(3, 2))) }) test_that("can subset shaped base vectors with size 0 compact seqs", { start <- 1L size <- 0L increasing <- TRUE mat <- as.matrix expect_identical(vec_slice_seq(mat(lgl(1, 0, 1)), start, size, increasing), mat(lgl())) expect_identical(vec_slice_seq(mat(int(1, 2, 3)), start, size, increasing), mat(int())) expect_identical(vec_slice_seq(mat(dbl(1, 2, 3)), start, size, increasing), mat(dbl())) expect_identical(vec_slice_seq(mat(cpl(1, 2, 3)), start, size, increasing), mat(cpl())) expect_identical(vec_slice_seq(mat(chr("1", "2", "3")), start, size, increasing), mat(chr())) expect_identical(vec_slice_seq(mat(bytes(1, 2, 3)), start, size, increasing), mat(bytes())) expect_identical(vec_slice_seq(mat(list(1, 2, 3)), start, size, increasing), mat(list())) }) test_that("can subset object of any dimensionality with compact seqs", { x0 <- c(1, 1) x1 <- ones(2) x2 <- ones(2, 3) x3 <- ones(2, 3, 4) x4 <- ones(2, 3, 4, 5) expect_equal(vec_slice_seq(x0, 0L, 1L), 1) expect_identical(vec_slice_seq(x1, 0L, 1L), ones(1)) expect_identical(vec_slice_seq(x2, 0L, 1L), ones(1, 3)) expect_identical(vec_slice_seq(x3, 0L, 1L), ones(1, 3, 4)) expect_identical(vec_slice_seq(x4, 0L, 1L), ones(1, 3, 4, 5)) }) test_that("can subset data frames with compact seqs", { df <- data_frame(x = 1:5, y = letters[1:5]) expect_equal(vec_slice_seq(df, 0L, 0L), vec_slice(df, integer())) expect_equal(vec_slice_seq(df, 0L, 1L), vec_slice(df, 1L)) expect_equal(vec_slice_seq(df, 0L, 3L), vec_slice(df, 1:3)) expect_equal(vec_slice_seq(df, 2L, 3L, FALSE), vec_slice(df, 3:1)) df$df <- df expect_equal(vec_slice_seq(df, 0L, 0L), vec_slice(df, integer())) expect_equal(vec_slice_seq(df, 0L, 1L), vec_slice(df, 1L)) expect_equal(vec_slice_seq(df, 0L, 3L), vec_slice(df, 1:3)) expect_equal(vec_slice_seq(df, 2L, 3L, FALSE), vec_slice(df, 3:1)) }) test_that("can subset S3 objects using the fallback method with compact seqs", { x <- factor(c("a", "b", "c", "d")) expect_equal(vec_slice_seq(x, 0L, 0L), vec_slice(x, integer())) expect_equal(vec_slice_seq(x, 0L, 1L), vec_slice(x, 1L)) expect_equal(vec_slice_seq(x, 2L, 2L), vec_slice(x, 3:4)) expect_equal(vec_slice_seq(x, 3L, 2L, FALSE), vec_slice(x, 4:3)) }) test_that("vec_slice() with compact_seqs work with Altrep classes", { skip_if(getRversion() < "3.5") x <- .Call(vctrs_rle, c(foo = 2L, bar = 3L)) expect_equal(vec_slice_seq(x, 1L, 3L), c("foo", "bar", "bar")) }) # vec_chop + compact_seq -------------------------------------------------- # `start` is 0-based test_that("can chop base vectors with compact seqs", { start <- 1L size <- 2L expect_identical(vec_chop_seq(lgl(1, 0, 1), start, size), list(lgl(0, 1))) expect_identical(vec_chop_seq(int(1, 2, 3), start, size), list(int(2, 3))) expect_identical(vec_chop_seq(dbl(1, 2, 3), start, size), list(dbl(2, 3))) expect_identical(vec_chop_seq(cpl(1, 2, 3), start, size), list(cpl(2, 3))) expect_identical(vec_chop_seq(chr("1", "2", "3"), start, size), list(chr("2", "3"))) expect_identical(vec_chop_seq(bytes(1, 2, 3), start, size), list(bytes(2, 3))) expect_identical(vec_chop_seq(list(1, 2, 3), start, size), list(list(2, 3))) }) test_that("can chop with a decreasing compact seq", { expect_equal(vec_chop_seq(int(1, 2, 3), 1L, 2L, FALSE), list(int(2, 1))) }) test_that("can chop with multiple compact seqs", { start <- c(1L, 0L) size <- c(1L, 3L) expect_equal( vec_chop_seq(int(1, 2, 3), start, size), list(int(2), int(1, 2, 3)) ) }) test_that("can chop S3 objects using the fallback method with compact seqs", { x <- factor(c("a", "b", "c", "d")) expect_equal(vec_chop_seq(x, 0L, 0L), list(vec_slice(x, integer()))) expect_equal(vec_chop_seq(x, 0L, 1L), list(vec_slice(x, 1L))) expect_equal(vec_chop_seq(x, 2L, 2L), list(vec_slice(x, 3:4))) }) test_that("vec_slice() works with Altrep classes with custom extract methods", { skip_if(getRversion() < "3.5") x <- .Call(vctrs_rle, c(foo = 10L, bar = 5L)) idx <- c(9, 10, 11) expect_equal(vec_slice(x, idx), c("foo", "foo", "bar")) }) test_that("slice has informative error messages", { verify_output(test_path("error", "test-slice.txt"), { "# Unnamed vector with character subscript" vec_slice(1:3, letters[1]) "# Negative subscripts are checked" vec_slice(1:3, -c(1L, NA)) vec_slice(1:3, c(-1L, 1L)) "# oob error messages are properly constructed" vec_slice(c(bar = 1), "foo") "Multiple OOB indices" vec_slice(letters, c(100, 1000)) vec_slice(letters, c(1, 100:103, 2, 104:110)) vec_slice(set_names(letters), c("foo", "bar")) vec_slice(set_names(letters), toupper(letters)) "# Can't index beyond the end of a vector" vec_slice(1:2, 3L) vec_slice(1:2, -3L) }) }) vctrs/tests/testthat/helper-encoding.R0000644000176200001440000000137413622451540017612 0ustar liggesusersencodings <- function(bytes = FALSE) { string <- "\u00B0C" utf8 <- iconv(string, from = Encoding(string), to = "UTF-8") unknown <- iconv(string, from = Encoding(string), to = "", mark = FALSE) latin1 <- iconv(string, from = Encoding(string), to = "latin1") out <- list(utf8 = utf8, unknown = unknown, latin1 = latin1) if (bytes) { out <- list2(!!! out, bytes = encoding_bytes()) } out } encoding_bytes <- function() { string <- "\u00B0C" unknown <- iconv(string, from = Encoding(string), to = "", mark = FALSE) bytes <- unknown Encoding(bytes) <- "bytes" bytes } expect_equal_encoding <- function(object, expected) { args <- vec_recycle_common(object, expected) expect_equal(Encoding(args[[1L]]), Encoding(args[[2L]])) } vctrs/tests/testthat/test-type-vec-type-common-error.txt0000644000176200001440000000363513623022056023271 0ustar liggesusers vec_ptype_common(df1, df2): No common type for `..1$x$y$z` and `..2$x$y$z` . vec_ptype_common(df1, df1, df2): No common type for `..1$x$y$z` and `..3$x$y$z` . vec_ptype_common(large_df1, large_df2): No common type for `..1$foobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobar$y$z` and `..2$foobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobar$y$z` . vec_ptype_common(foo = TRUE, bar = "foo"): No common type for `foo` and `bar` . vec_ptype_common(foo = TRUE, baz = FALSE, bar = "foo"): No common type for `foo` and `bar` . vec_ptype_common(foo = df1, bar = df2): No common type for `foo$x$y$z` and `bar$x$y$z` . vec_ptype_common(df1, df1, bar = df2): No common type for `..1$x$y$z` and `bar$x$y$z` . vec_ptype_common(TRUE, !!!list(1, "foo")): No common type for `..2` and `..3` . vec_ptype_common(TRUE, !!!list(1, 2), "foo"): No common type for `..2` and `..5` . vec_ptype_common(1, !!!list(TRUE, FALSE), "foo"): No common type for `..1` and `..5` . vec_ptype_common(foo = TRUE, !!!list(FALSE, FALSE), bar = "foo"): No common type for `foo` and `bar` . vec_ptype_common(foo = TRUE, !!!list(bar = 1, "foo")): No common type for `bar` and `..3` . vec_ptype_common(foo = TRUE, !!!list(bar = "foo")): No common type for `foo` and `bar` . vec_ptype_common(foo = TRUE, !!!list(bar = FALSE), baz = "chr"): No common type for `foo` and `baz` . vec_ptype_common(foo = TRUE, !!!list(bar = FALSE), !!!list(baz = "chr")): No common type for `foo` and `baz` . vctrs/tests/testthat/test-shape-print.txt0000644000176200001440000000002613473164157020376 0ustar liggesusersshape: [1] shape: [1] vctrs/tests/testthat/test-partial-factor.R0000644000176200001440000000340013622451540020424 0ustar liggesuserscontext("test-partial-factor") test_that("has ok print method", { partial <- partial_factor("x") expect_known_output( print(partial), test_path("test-partial-factor-print-partial.txt") ) both <- vec_ptype2(partial, factor("y")) expect_known_output( print(both), test_path("test-partial-factor-print-both.txt") ) empty <- partial_factor() expect_known_output( print(empty), test_path("test-partial-factor-print-empty.txt") ) learned <- vec_ptype2(empty, factor("y")) expect_known_output( print(learned), test_path("test-partial-factor-print-learned.txt") ) expect_equal(vec_ptype_abbr(partial), "prtl_fctr") }) test_that("order of levels comes from data", { pfctr <- partial_factor(c("y", "x")) fctr <- factor(levels = c("x", "y")) expect_equal(levels(vec_ptype_common(pfctr, fctr)), c("x", "y")) expect_equal(levels(vec_ptype_common(fctr, pfctr)), c("x", "y")) }) test_that("partial levels added to end if not in data", { pfctr <- partial_factor("y") fctr <- factor(levels = "x") expect_equal(levels(vec_ptype_common(pfctr, fctr)), c("x", "y")) expect_equal(levels(vec_ptype_common(fctr, pfctr)), c("x", "y")) }) test_that("can assert partial factors based on level presence", { pfctr <- partial_factor("y") expect_true(vec_is(factor("y"), pfctr)) expect_false(vec_is(factor("x"), pfctr)) expect_true(vec_is(factor(c("x", "y")), pfctr)) pfctr <- partial_factor(c("y", "z")) expect_false(vec_is(factor("y"), pfctr)) expect_true(vec_is(factor(c("y", "z")), pfctr)) expect_true(vec_is(factor(c("x", "y", "z")), pfctr)) }) # TODO - why is this not working? # test_that("can assert partial factor based on factor type", { # pfctr <- partial_factor() # expect_false(vec_is(1, pfctr)) # }) vctrs/tests/testthat/test-list_of-str-empty.txt0000644000176200001440000000026613623022052021533 0ustar liggesuserslist [1:0] list() @ ptype: num(0) List of 1 $ :List of 2 ..$ : list [1:2] .. ..$ : num 1 .. ..$ : num [1:2] 2 3 .. ..@ ptype: num(0) ..$ y: int [1:2] 2 1 vctrs/tests/testthat/test-type-factor.R0000644000176200001440000001141113622451540017752 0ustar liggesuserscontext("test-type-factor") test_that("ptype methods are descriptive", { f <- factor() o <- ordered(character()) expect_equal(vec_ptype_abbr(f), "fct") expect_equal(vec_ptype_abbr(o), "ord") expect_equal(vec_ptype_full(f), "factor<>") expect_equal(vec_ptype_full(o), "ordered<>") }) # Coercion ---------------------------------------------------------------- test_that("factor/character coercions are symmetric and unchanging", { types <- list( ordered(character()), factor(), character() ) mat <- maxtype_mat(types) expect_true(isSymmetric(mat)) expect_known_output( mat, print = TRUE, test_path("test-type-factor.txt"), width = 200 ) }) test_that("factors level are unioned", { # This is technically incorrect, but because of R's existing behaviour # anything else will cause substantial friction. fa <- factor(levels = "a") fb <- factor(levels = "b") expect_equal(vec_ptype_common(fa, fb), factor(levels = c("a", "b"))) expect_equal(vec_ptype_common(fb, fa), factor(levels = c("b", "a"))) }) test_that("coercion errors with factors", { f <- factor(levels = "a") expect_error(vec_ptype_common(f, logical()), class = "vctrs_error_incompatible_type") expect_error(vec_ptype_common(logical(), f), class = "vctrs_error_incompatible_type") }) test_that("vec_ptype2(, NA) is symmetric (#687)", { fct <- new_factor() expect_identical( vec_ptype2(fct, NA), vec_ptype2(NA, fct) ) fct <- new_ordered() expect_identical( vec_ptype2(fct, NA), vec_ptype2(NA, fct) ) }) test_that("vec_ptype2(, NA) is symmetric (#687)", { i64 <- bit64::integer64() expect_identical( vec_ptype2(i64, NA), vec_ptype2(NA, i64) ) }) test_that("vec_ptype2() errors with malformed factors", { x <- structure(1, class = "factor") y <- factor("x") expect_error(vec_ptype2(x, y, x_arg = "z"), "`z` is a corrupt factor") expect_error(vec_ptype2(y, x, y_arg = "z"), "`z` is a corrupt factor") }) test_that("vec_ptype2() errors with malformed ordered factors", { x <- structure(1, class = c("ordered", "factor")) y <- as.ordered(factor("x")) expect_error(vec_ptype2(x, y, x_arg = "z"), "`z` is a corrupt ordered factor") expect_error(vec_ptype2(y, x, y_arg = "z"), "`z` is a corrupt ordered factor") }) # Casting ----------------------------------------------------------------- test_that("safe casts work as expected", { fa <- factor("a") fab <- factor(c("a", "b")) expect_equal(vec_cast(NULL, fa), NULL) expect_equal(vec_cast(fa, fa), fa) expect_equal(vec_cast(fa, fab), fab[1]) expect_equal(vec_cast("a", fab), fab[1]) expect_equal(vec_cast("a", factor()), fa) expect_equal(vec_cast(fa, factor()), fa) expect_equal(vec_cast(list("a", "b"), fab), fab) }) test_that("can cast to character", { expect_equal(vec_cast(factor("X"), character()), "X") expect_equal(vec_cast(ordered("X"), character()), "X") }) test_that("can cast NA and unspecified to factor", { expect_identical(vec_cast(NA, new_factor()), factor(NA)) expect_identical(vec_cast(NA, new_ordered()), ordered(NA)) expect_identical(vec_cast(unspecified(2), new_factor()), factor(c(NA, NA))) expect_identical(vec_cast(unspecified(2), new_ordered()), ordered(c(NA, NA))) }) test_that("lossy factor casts fail", { fa <- factor("a") fb <- factor("b") expect_lossy(vec_cast(fa, fb), factor(NA, levels = "b"), x = fa, to = fb) expect_lossy(vec_cast("a", fb), factor(NA, levels = "b"), x = chr(), to = fb) }) test_that("invalid casts generate error", { expect_error(vec_cast(double(), factor("a")), class = "vctrs_error_incompatible_cast") expect_error(vec_cast(factor("a"), logical()), class = "vctrs_error_incompatible_cast") expect_error(vec_cast(ordered("a"), logical()), class = "vctrs_error_incompatible_cast") expect_error(vec_cast(logical(), factor("a")), class = "vctrs_error_incompatible_cast") expect_error(vec_cast(logical(), ordered("a")), class = "vctrs_error_incompatible_cast") }) test_that("orderedness of factor is preserved", { fct <- factor("a") ord <- ordered("a") expect_equal(vec_cast(fct, ord), ord) expect_equal(vec_cast("a", ord), ord) }) test_that("NA are not considered lossy in factor cast (#109)", { f <- factor(c("itsy", "bitsy", NA, "spider", "spider")) expect_warning(vec_cast(f, f[1]), NA) }) test_that("Casting to a factor with explicit NA levels retains them", { f <- factor(c("x", NA), exclude = NULL) expect_identical(vec_cast(f, f), f) expect_identical(vec_cast(f, factor()), f) }) # Arithmetic and factor --------------------------------------------------- test_that("factors don't support math or arthimetic", { f <- factor("x") expect_error(vec_math("sum", f), class = "vctrs_error_unsupported") expect_error(vec_arith("+", f, f), class = "vctrs_error_unsupported") }) vctrs/tests/testthat/test-subscript-loc.R0000644000176200001440000004700113622451540020312 0ustar liggesusers test_that("vec_as_location2() returns a position", { expect_identical(vec_as_location2(2, 2L), 2L) expect_identical(vec_as_location2("foo", 2L, c("bar", "foo")), 2L) }) test_that("vec_as_location2() requires integer or character inputs", { verify_errors({ expect_error(vec_as_location2(TRUE, 10L), class = "vctrs_error_subscript_type") expect_error(vec_as_location2(mtcars, 10L), class = "vctrs_error_subscript_type") expect_error(vec_as_location2(env(), 10L), class = "vctrs_error_subscript_type") expect_error(vec_as_location2(foobar(), 10L), class = "vctrs_error_subscript_type") expect_error(vec_as_location2(2.5, 10L), class = "vctrs_error_subscript_type") "Idem with custom `arg`" expect_error(vec_as_location2(foobar(), 10L, arg = "foo"), class = "vctrs_error_subscript_type") expect_error(vec_as_location2(2.5, 3L, arg = "foo"), class = "vctrs_error_subscript_type") }) }) test_that("vec_as_location() requires integer, character, or logical inputs", { verify_errors({ expect_error(vec_as_location(mtcars, 10L), class = "vctrs_error_subscript_type") expect_error(vec_as_location(env(), 10L), class = "vctrs_error_subscript_type") expect_error(vec_as_location(foobar(), 10L), class = "vctrs_error_subscript_type") expect_error(vec_as_location(2.5, 10L), class = "vctrs_error_subscript_type") expect_error(vec_as_location(list(), 10L), class = "vctrs_error_subscript_type") expect_error(vec_as_location(function() NULL, 10L), class = "vctrs_error_subscript_type") "Idem with custom `arg`" expect_error(vec_as_location(env(), 10L, arg = "foo"), class = "vctrs_error_subscript_type") expect_error(vec_as_location(foobar(), 10L, arg = "foo"), class = "vctrs_error_subscript_type") expect_error(vec_as_location(2.5, 3L, arg = "foo"), class = "vctrs_error_subscript_type") }) }) test_that("vec_as_location2() and vec_as_location() require integer- or character-like OO inputs", { expect_identical(vec_as_location2(factor("foo"), 2L, c("bar", "foo")), 2L) expect_identical(vec_as_location(factor("foo"), 2L, c("bar", "foo")), 2L) expect_error(vec_as_location2(foobar(1L), 10L), class = "vctrs_error_subscript_type") expect_error(vec_as_location(foobar(1L), 10L), class = "vctrs_error_subscript_type") # Define subtype of logical and integer local_methods( vec_ptype2.vctrs_foobar = function(x, y, ...) UseMethod("vec_ptype2.vctrs_foobar", y), vec_ptype2.vctrs_foobar.default = function(x, y, ...) vec_default_ptype2(x, y, ...), vec_ptype2.vctrs_foobar.logical = function(x, y, ...) logical(), vec_ptype2.vctrs_foobar.integer = function(x, y, ...) integer(), vec_ptype2.logical.vctrs_foobar = function(x, y, ...) logical(), vec_ptype2.integer.vctrs_foobar = function(x, y, ...) integer(), vec_cast.vctrs_foobar = function(x, to, ...) UseMethod("vec_cast.vctrs_foobar"), vec_cast.vctrs_foobar.integer = function(x, to, ...) foobar(x), vec_cast.integer.vctrs_foobar = function(x, to, ...) vec_cast(unclass(x), int()), vec_cast.logical.vctrs_foobar = function(x, to, ...) vec_cast(unclass(x), lgl()) ) expect_error(vec_as_location2(foobar(TRUE), 10L), class = "vctrs_error_subscript_type") expect_identical(vec_as_location(foobar(TRUE), 10L), 1:10) expect_identical(vec_as_location(foobar(FALSE), 10L), int()) }) test_that("vec_as_location() and variants check for OOB elements", { verify_errors({ "Numeric indexing" expect_error(vec_as_location(10L, 2L), class = "vctrs_error_subscript_oob") expect_error(vec_as_location(-10L, 2L), class = "vctrs_error_subscript_oob") expect_error(vec_as_location2(10L, 2L), class = "vctrs_error_subscript_oob") "Character indexing" expect_error(vec_as_location("foo", 1L, names = "bar"), class = "vctrs_error_subscript_oob") expect_error(vec_as_location2("foo", 1L, names = "bar"), class = "vctrs_error_subscript_oob") }) expect_error(num_as_location(10L, 2L), class = "vctrs_error_subscript_oob") expect_error(num_as_location2(10L, 2L), class = "vctrs_error_subscript_oob") }) test_that("vec_as_location() doesn't require `n` for character indexing", { expect_identical(vec_as_location("b", NULL, names = letters), 2L) }) test_that("vec_as_location2() requires length 1 inputs", { verify_errors({ expect_error(vec_as_location2(1:2, 2L), class = "vctrs_error_subscript_type") expect_error(vec_as_location2(c("foo", "bar"), 2L, c("foo", "bar")), class = "vctrs_error_subscript_type") "Idem with custom `arg`" expect_error(vec_as_location2(1:2, 2L, arg = "foo"), class = "vctrs_error_subscript_type") expect_error(vec_as_location2(mtcars, 10L, arg = "foo"), class = "vctrs_error_subscript_type") expect_error(vec_as_location2(1:2, 2L, arg = "foo"), class = "vctrs_error_subscript_type") }) }) test_that("vec_as_location2() requires positive integers", { verify_errors({ expect_error(vec_as_location2(0, 2L), class = "vctrs_error_subscript_type") expect_error(vec_as_location2(-1, 2L), class = "vctrs_error_subscript_type") "Idem with custom `arg`" expect_error(vec_as_location2(0, 2L, arg = "foo"), class = "vctrs_error_subscript_type") }) }) test_that("vec_as_location2() fails with NA", { verify_errors({ expect_error(vec_as_location2(na_int, 2L), class = "vctrs_error_subscript_type") expect_error(vec_as_location2(na_chr, 1L, names = "foo"), class = "vctrs_error_subscript_type") "Idem with custom `arg`" expect_error(vec_as_location2(na_int, 2L, arg = "foo"), class = "vctrs_error_subscript_type") }) }) test_that("vec_as_location2() doesn't allow lossy casts", { expect_error(vec_as_location2(2^31, 3L), class = "vctrs_error_subscript_type") # Lossy casts generate missing values, which are disallowed expect_error(allow_lossy_cast(vec_as_location2(2^31, 3L)), class = "vctrs_error_subscript_type") }) test_that("all subscript errors inherit from `vctrs_error_subscript`", { expect_error(vec_as_location(100, 2L), class = "vctrs_error_subscript") expect_error(vec_as_location("foo", 2L, names = c("bar", "baz")), class = "vctrs_error_subscript") expect_error(vec_as_location(foobar(1L), 2L), class = "vctrs_error_subscript") expect_error(vec_as_location(1.5, 2L), class = "vctrs_error_subscript") expect_error(vec_as_location2(TRUE, 2L), class = "vctrs_error_subscript") expect_error(vec_as_location2(1.5, 2L), class = "vctrs_error_subscript") }) test_that("all OOB errors inherit from `vctrs_error_subscript_oob`", { expect_error(vec_as_location(100, 2L), class = "vctrs_error_subscript_oob") expect_error(vec_as_location("foo", 2L, names = c("bar", "baz")), class = "vctrs_error_subscript_oob") }) test_that("vec_as_location() preserves names if possible", { expect_identical(vec_as_location(c(a = 1L, b = 3L), 3L), c(a = 1L, b = 3L)) expect_identical(vec_as_location(c(a = 1, b = 3), 3L), c(a = 1L, b = 3L)) expect_identical(vec_as_location(c(a = "z", b = "y"), 26L, letters), c(a = 26L, b = 25L)) expect_identical(vec_as_location(c(foo = TRUE, bar = FALSE, baz = TRUE), 3L), c(foo = 1L, baz = 3L)) expect_identical(vec_as_location(c(foo = TRUE), 3L), c(foo = 1L, foo = 2L, foo = 3L)) expect_identical(vec_as_location(c(foo = NA), 3L), c(foo = na_int, foo = na_int, foo = na_int)) # Names of negative selections are dropped expect_identical(vec_as_location(c(a = -1L, b = -3L), 3L), 2L) }) test_that("vec_as_location2() optionally allows missing values", { expect_identical(vec_as_location2(NA, 2L, missing = "propagate"), na_int) expect_error(vec_as_location2(NA, 2L, missing = "error"), class = "vctrs_error_subscript_type") }) test_that("num_as_location2() optionally allows missing and negative locations", { expect_identical(num_as_location2(na_dbl, 2L, missing = "propagate"), na_int) expect_identical(num_as_location2(-1, 2L, negative = "ignore"), -1L) expect_error(num_as_location2(-3, 2L, negative = "ignore"), class = "vctrs_error_subscript_oob") expect_error(num_as_location2(0, 2L, negative = "ignore"), class = "vctrs_error_subscript_type") }) test_that("num_as_location() optionally allows negative indices", { expect_identical(num_as_location(dbl(1, -1), 2L, negative = "ignore"), int(1L, -1L)) expect_error(num_as_location(c(1, -10), 2L, negative = "ignore"), class = "vctrs_error_subscript_oob") }) test_that("num_as_location() optionally forbids negative indices", { verify_errors({ expect_error(num_as_location(dbl(1, -1), 2L, negative = "error"), class = "vctrs_error_subscript_type") }) expect_error(num_as_location(c(1, -10), 2L, negative = "error"), class = "vctrs_error_subscript_type") }) test_that("vec_as_location() handles NULL", { expect_identical( vec_as_location(NULL, 10), vec_as_location(int(), 10), ) }) test_that("vec_as_location() checks for mix of negative and missing locations", { verify_errors({ expect_error( vec_as_location(-c(1L, NA), 30), class = "vctrs_error_subscript_type" ) expect_error( vec_as_location(-c(1L, rep(NA, 10)), 30), class = "vctrs_error_subscript_type" ) }) }) test_that("vec_as_location() checks for mix of negative and positive locations", { verify_errors({ expect_error( vec_as_location(c(-1L, 1L), 30), class = "vctrs_error_subscript_type" ) expect_error( vec_as_location(c(-1L, rep(1L, 10)), 30), class = "vctrs_error_subscript_type" ) }) }) test_that("logical subscripts must match size of indexed vector", { verify_errors({ expect_error( vec_as_location(c(TRUE, FALSE), 3), class = "vctrs_error_subscript_size" ) }) }) test_that("character subscripts require named vectors", { verify_errors({ expect_error(vec_as_location(letters[1], 3), "unnamed vector") }) }) test_that("can optionally extend beyond the end", { expect_error(num_as_location(1:5, 3), class = "vctrs_error_subscript_oob") expect_identical(num_as_location(1:5, 3, oob = "extend"), 1:5) expect_identical(num_as_location(c(1:5, 7, 6), 3, oob = "extend"), c(1:5, 7L, 6L)) expect_identical(num_as_location(c(1, NA, 3), 2, oob = "extend"), c(1L, NA, 3L)) verify_errors({ expect_error( num_as_location(c(1, 3), 1, oob = "extend"), class = "vctrs_error_subscript_oob" ) expect_error( num_as_location(c(1:5, 7), 3, oob = "extend"), class = "vctrs_error_subscript_oob" ) expect_error( class = "vctrs_error_subscript_oob", num_as_location(c(1:5, 7, 1), 3, oob = "extend") ) expect_error( class = "vctrs_error_subscript_oob", num_as_location(c(1:5, 7, 1, 10), 3, oob = "extend") ) }) }) test_that("missing values are supported in error formatters", { verify_errors({ expect_error( num_as_location(c(1, NA, 2, 3), 1), class = "vctrs_error_subscript_oob" ) expect_error( num_as_location(c(1, NA, 3), 1, oob = "extend"), class = "vctrs_error_subscript_oob" ) }) }) test_that("can disallow missing values", { verify_errors({ expect_error( vec_as_location(c(1, NA), 2, missing = "error"), class = "vctrs_error_subscript_type" ) expect_error( vec_as_location(c(1, NA, 2, NA), 2, missing = "error", arg = "foo"), class = "vctrs_error_subscript_type" ) expect_error( with_tibble_cols(vec_as_location(c(1, NA, 2, NA), 2, missing = "error")), class = "vctrs_error_subscript_type" ) }) }) test_that("can customise subscript type errors", { verify_errors({ "With custom `arg`" expect_error( num_as_location(-1, 2, negative = "error", arg = "foo"), class = "vctrs_error_subscript_type" ) expect_error( num_as_location2(-1, 2, negative = "error", arg = "foo"), class = "vctrs_error_subscript_type" ) expect_error( vec_as_location2(0, 2, arg = "foo"), class = "vctrs_error_subscript_type" ) expect_error( vec_as_location2(na_dbl, 2, arg = "foo"), class = "vctrs_error_subscript_type" ) expect_error( vec_as_location2(c(1, 2), 2, arg = "foo"), class = "vctrs_error_subscript_type" ) expect_error( vec_as_location(c(TRUE, FALSE), 3, arg = "foo"), class = "vctrs_error_subscript_size" ) expect_error( vec_as_location(c(-1, NA), 3, arg = "foo"), class = "vctrs_error_subscript_type" ) expect_error( vec_as_location(c(-1, 1), 3, arg = "foo"), class = "vctrs_error_subscript_type" ) expect_error( num_as_location(c(1, 4), 2, oob = "extend", arg = "foo"), class = "vctrs_error_subscript_oob" ) "With tibble columns" expect_error( with_tibble_cols(num_as_location(-1, 2, negative = "error")), class = "vctrs_error_subscript_type" ) expect_error( with_tibble_cols(num_as_location2(-1, 2, negative = "error")), class = "vctrs_error_subscript_type" ) expect_error( with_tibble_cols(vec_as_location2(0, 2)), class = "vctrs_error_subscript_type" ) expect_error( with_tibble_cols(vec_as_location2(na_dbl, 2)), class = "vctrs_error_subscript_type" ) expect_error( with_tibble_cols(vec_as_location2(c(1, 2), 2)), class = "vctrs_error_subscript_type" ) expect_error( with_tibble_cols(vec_as_location(c(TRUE, FALSE), 3)), class = "vctrs_error_subscript_size" ) expect_error( with_tibble_cols(vec_as_location(c(-1, NA), 3)), class = "vctrs_error_subscript_type" ) expect_error( with_tibble_cols(vec_as_location(c(-1, 1), 3)), class = "vctrs_error_subscript_type" ) expect_error( with_tibble_cols(num_as_location(c(1, 4), 2, oob = "extend")), class = "vctrs_error_subscript_oob" ) }) }) test_that("can customise OOB errors", { verify_errors({ expect_error( vec_slice(set_names(letters), "foo"), class = "vctrs_error_subscript_oob" ) "With custom `arg`" expect_error( vec_as_location(30, length(letters), arg = "foo"), class = "vctrs_error_subscript_oob" ) expect_error( vec_as_location("foo", NULL, letters, arg = "foo"), class = "vctrs_error_subscript_oob" ) "With tibble columns" expect_error( with_tibble_cols(vec_slice(set_names(letters), "foo")), class = "vctrs_error_subscript_oob" ) expect_error( with_tibble_cols(vec_slice(set_names(letters), 30)), class = "vctrs_error_subscript_oob" ) expect_error( with_tibble_cols(vec_slice(set_names(letters), -30)), class = "vctrs_error_subscript_oob" ) "With tibble rows" expect_error( with_tibble_rows(vec_slice(set_names(letters), c("foo", "bar"))), class = "vctrs_error_subscript_oob" ) expect_error( with_tibble_rows(vec_slice(set_names(letters), 1:30)), class = "vctrs_error_subscript_oob" ) expect_error( with_tibble_rows(vec_slice(set_names(letters), -(1:30))), class = "vctrs_error_subscript_oob" ) }) }) test_that("conversion to locations has informative error messages", { verify_output(test_path("error", "test-subscript-loc.txt"), { "# vec_as_location() checks for mix of negative and missing locations" vec_as_location(-c(1L, NA), 30) vec_as_location(-c(1L, rep(NA, 10)), 30) "# vec_as_location() checks for mix of negative and positive locations" vec_as_location(c(-1L, 1L), 30) vec_as_location(c(-1L, rep(1L, 10)), 30) "# num_as_location() optionally forbids negative indices" num_as_location(dbl(1, -1), 2L, negative = "error") "# logical subscripts must match size of indexed vector" vec_as_location(c(TRUE, FALSE), 3) "# character subscripts require named vectors" vec_as_location(letters[1], 3) "# vec_as_location() requires integer, character, or logical inputs" vec_as_location(mtcars, 10L) vec_as_location(env(), 10L) vec_as_location(foobar(), 10L) vec_as_location(2.5, 3L) vec_as_location(list(), 10L) vec_as_location(function() NULL, 10L) "Idem with custom `arg`" vec_as_location(env(), 10L, arg = "foo") vec_as_location(foobar(), 10L, arg = "foo") vec_as_location(2.5, 3L, arg = "foo") "# vec_as_location2() requires integer or character inputs" vec_as_location2(TRUE, 10L) vec_as_location2(mtcars, 10L) vec_as_location2(env(), 10L) vec_as_location2(foobar(), 10L) vec_as_location2(2.5, 3L) "Idem with custom `arg`" vec_as_location2(foobar(), 10L, arg = "foo") vec_as_location2(2.5, 3L, arg = "foo") "# vec_as_location2() requires length 1 inputs" vec_as_location2(1:2, 2L) vec_as_location2(mtcars, 10L) "Idem with custom `arg`" vec_as_location2(1:2, 2L, arg = "foo") vec_as_location2(mtcars, 10L, arg = "foo") vec_as_location2(1:2, 2L, arg = "foo") "# vec_as_location2() requires positive integers" vec_as_location2(0, 2L) vec_as_location2(-1, 2L) "Idem with custom `arg`" vec_as_location2(0, 2L, arg = "foo") "vec_as_location2() fails with NA" vec_as_location2(na_int, 2L) vec_as_location2(na_chr, 1L, names = "foo") "Idem with custom `arg`" vec_as_location2(na_int, 2L, arg = "foo") "# vec_as_location() and variants check for OOB elements" "Numeric subscripts" vec_as_location(10L, 2L) vec_as_location(-10L, 2L) vec_as_location2(10L, 2L) "Character subscripts" vec_as_location("foo", 1L, names = "bar") vec_as_location2("foo", 1L, names = "bar") "# can optionally extend beyond the end" num_as_location(c(1, 3), 1, oob = "extend") num_as_location(c(1:5, 7), 3, oob = "extend") num_as_location(c(1:5, 7, 1), 3, oob = "extend") num_as_location(c(1:5, 7, 1, 10), 3, oob = "extend") "# missing values are supported in error formatters" num_as_location(c(1, NA, 2, 3), 1) num_as_location(c(1, NA, 3), 1, oob = "extend") "# can customise subscript type errors" "With custom `arg`" num_as_location(-1, 2, negative = "error", arg = "foo") num_as_location2(-1, 2, negative = "error", arg = "foo") vec_as_location2(0, 2, arg = "foo") vec_as_location2(na_dbl, 2, arg = "foo") vec_as_location2(c(1, 2), 2, arg = "foo") vec_as_location(c(TRUE, FALSE), 3, arg = "foo") vec_as_location(c(-1, NA), 3, arg = "foo") vec_as_location(c(-1, 1), 3, arg = "foo") num_as_location(c(1, 4), 2, oob = "extend", arg = "foo") "With tibble columns" with_tibble_cols(num_as_location(-1, 2, negative = "error")) with_tibble_cols(num_as_location2(-1, 2, negative = "error")) with_tibble_cols(vec_as_location2(0, 2)) with_tibble_cols(vec_as_location2(na_dbl, 2)) with_tibble_cols(vec_as_location2(c(1, 2), 2)) with_tibble_cols(vec_as_location(c(TRUE, FALSE), 3)) with_tibble_cols(vec_as_location(c(-1, NA), 3)) with_tibble_cols(vec_as_location(c(-1, 1), 3)) with_tibble_cols(num_as_location(c(1, 4), 2, oob = "extend")) "# can customise OOB errors" vec_slice(set_names(letters), "foo") "With custom `arg`" vec_as_location(30, length(letters), arg = "foo") vec_as_location("foo", NULL, letters, arg = "foo") "With tibble columns" with_tibble_cols(vec_slice(set_names(letters), "foo")) with_tibble_cols(vec_slice(set_names(letters), 30)) with_tibble_cols(vec_slice(set_names(letters), -30)) "With tibble rows" with_tibble_rows(vec_slice(set_names(letters), c("foo", "bar"))) with_tibble_rows(vec_slice(set_names(letters), 1:30)) with_tibble_rows(vec_slice(set_names(letters), -(1:30))) "# can disallow missing values" vec_as_location(c(1, NA), 2, missing = "error") vec_as_location(c(1, NA, 2, NA), 2, missing = "error", arg = "foo") with_tibble_cols(vec_as_location(c(1, NA, 2, NA), 2, missing = "error")) }) }) vctrs/tests/testthat/test-rcrd-format.txt0000644000176200001440000000215613623022053020353 0ustar liggesusers [1] (1,1) (1,2) (1,3) (1,4) (1,5) (1,6) (1,7) (1,8) (1,9) [10] (1,10) (1,11) (1,12) (1,13) (1,14) (1,15) (1,16) (1,17) (1,18) [19] (1,19) (1,20) (1,21) (1,22) (1,23) (1,24) (1,25) (1,26) (1,27) [28] (1,28) (1,29) (1,30) (1,31) (1,32) (1,33) (1,34) (1,35) (1,36) [37] (1,37) (1,38) (1,39) (1,40) (1,41) (1,42) (1,43) (1,44) (1,45) [46] (1,46) (1,47) (1,48) (1,49) (1,50) (1,51) (1,52) (1,53) (1,54) [55] (1,55) (1,56) (1,57) (1,58) (1,59) (1,60) (1,61) (1,62) (1,63) [64] (1,64) (1,65) (1,66) (1,67) (1,68) (1,69) (1,70) (1,71) (1,72) [73] (1,73) (1,74) (1,75) (1,76) (1,77) (1,78) (1,79) (1,80) (1,81) [82] (1,82) (1,83) (1,84) (1,85) (1,86) (1,87) (1,88) (1,89) (1,90) [91] (1,91) (1,92) (1,93) (1,94) (1,95) (1,96) (1,97) (1,98) (1,99) [100] (1,100) tuple [1:10] (1,1), (1,2), (1,3), (1,4), (1,5), (1,6), (1,7), (1,8), (1,9)... List of 1 $ :List of 1 ..$ :List of 2 .. ..$ : tuple [1:100] (1,1), (1,2), (1,3), (1,4), (1,5), (1,6), (1,7), (... .. ..$ : int [1:100] 1 2 3 4 5 6 7 8 9 10 ... vctrs/tests/testthat/test-type-bare.R0000644000176200001440000003032113623013722017403 0ustar liggesuserscontext("test-type-bare") test_that("ptype2 base methods are not inherited", { ptypes <- vec_remove(base_empty_types, "null") for (ptype in ptypes) { x <- new_vctr(ptype, class = "foobar", inherit_base_type = TRUE) expect_is(vec_ptype2(x, x), "foobar") expect_error(vec_ptype2(x, ptype), class = "vctrs_error_incompatible_type") expect_error(vec_ptype2(ptype, x), class = "vctrs_error_incompatible_type") } }) test_that("cast base methods are not inherited", { # FIXME: Should also disallow data frame and list methods ptypes <- vec_remove(base_empty_types, c("null", "dataframe", "list")) for (ptype in ptypes) { x <- new_vctr(ptype, class = "foobar", inherit_base_type = TRUE) expect_is(vec_cast(ptype, x), "foobar") expect_error(vec_cast(x, !!ptype), class = "vctrs_error_incompatible_cast") } }) # shape_match ------------------------------------------------------------- test_that("array dimensions are preserved", { mat1 <- matrix(lgl(), nrow = 1, ncol = 1) mat2 <- matrix(lgl(), nrow = 2, ncol = 2) mat3 <- matrix(lgl(), nrow = 2, ncol = 3) expect_equal(vec_ptype2(mat1, mat1), matrix(lgl(), nrow = 0, ncol = 1)) expect_equal(vec_ptype2(mat1, mat2), matrix(lgl(), nrow = 0, ncol = 2)) expect_error(vec_ptype2(mat2, mat3), "Incompatible") }) test_that("shape_match()", { int <- function(...) array(NA_integer_, c(...)) expect_identical(shape_match(integer(), int(5), int(10)), new_shape(integer())) expect_identical(shape_match(integer(), int(5, 1), int(10, 1)), new_shape(integer(), 1)) expect_identical(shape_match(integer(), int(5, 1, 2), int(10, 1, 2)), new_shape(integer(), 1:2)) }) # vec_cast() -------------------------------------------------------------- # NULL test_that("NULL is idempotent", { expect_equal(vec_cast(NULL, NULL), NULL) expect_equal(vec_cast(list(1:3), NULL), list(1:3)) }) # Logical test_that("safe casts work as expected", { exp <- lgl(TRUE, FALSE) expect_equal(vec_cast(NULL, logical()), NULL) expect_equal(vec_cast(lgl(TRUE, FALSE), logical()), exp) expect_equal(vec_cast(int(1L, 0L), logical()), exp) expect_equal(vec_cast(dbl(1, 0), logical()), exp) expect_equal(vec_cast(chr("T", "F"), logical()), exp) expect_equal(vec_cast(chr("TRUE", "FALSE"), logical()), exp) expect_equal(vec_cast(chr("true", "false"), logical()), exp) expect_equal(vec_cast(list(1, 0), logical()), exp) }) test_that("NA casts work as expected", { exp <- lgl(NA) to <- lgl() expect_equal(vec_cast(lgl(NA), to), exp) expect_equal(vec_cast(int(NA), to), exp) expect_equal(vec_cast(dbl(NA), to), exp) expect_equal(vec_cast(chr(NA), to), exp) expect_equal(vec_cast(list(NA), to), exp) }) test_that("Shaped NA casts work as expected", { mat <- matrix exp_mat <- mat(lgl(NA)) to_mat <- matrix(lgl()) expect_equal(vec_cast(mat(lgl(NA)), to_mat), exp_mat) expect_equal(vec_cast(mat(int(NA)), to_mat), exp_mat) expect_equal(vec_cast(mat(dbl(NA)), to_mat), exp_mat) expect_equal(vec_cast(mat(chr(NA)), to_mat), exp_mat) expect_equal(vec_cast(mat(list(NA)), to_mat), exp_mat) }) test_that("lossy casts generate warning", { expect_lossy(vec_cast(int(2L, 1L), lgl()), lgl(TRUE, TRUE), x = int(), to = lgl()) expect_lossy(vec_cast(dbl(2, 1), lgl()), lgl(TRUE, TRUE), x = dbl(), to = lgl()) expect_lossy(vec_cast(chr("x", "TRUE"), lgl()), lgl(NA, TRUE), x = chr(), to = lgl()) expect_lossy(vec_cast(chr("t", "T"), lgl()), lgl(NA, TRUE), x = chr(), to = lgl()) expect_lossy(vec_cast(chr("f", "F"), lgl()), lgl(NA, FALSE), x = chr(), to = lgl()) expect_lossy(vec_cast(list(c(TRUE, FALSE), TRUE), lgl()), lgl(TRUE, TRUE), x = list(), to = lgl()) }) test_that("invalid casts generate error", { expect_error(vec_cast(factor("a"), logical()), class = "vctrs_error_incompatible_cast") }) test_that("dimensionality matches output" ,{ x1 <- matrix(TRUE, nrow = 1, ncol = 1) x2 <- matrix(1, nrow = 0, ncol = 2) expect_dim(vec_cast(x1, x2), c(1, 2)) expect_dim(vec_cast(TRUE, x2), c(1, 2)) x <- matrix(1, nrow = 2, ncol = 2) expect_error(vec_cast(x, logical()), class = "vctrs_error_incompatible_cast") }) test_that("the common type of two `NA` vectors is unspecified", { expect_equal(vec_ptype2(NA, NA), unspecified()) # Ensure the R level dispatch is consistent expect_equal(vec_default_ptype2(NA, NA), unspecified()) }) # Integer test_that("safe casts work as expected", { expect_equal(vec_cast(NULL, integer()), NULL) expect_equal(vec_cast(lgl(TRUE, FALSE), integer()), int(1L, 0L)) expect_equal(vec_cast(int(1L, 2L), integer()), int(1L, 2L)) expect_equal(vec_cast(dbl(1, 2), integer()), int(1L, 2L)) expect_equal(vec_cast(chr("1", "2"), integer()), int(1L, 2L)) expect_equal(vec_cast(list(1L, 2L), integer()), int(1L, 2L)) }) test_that("NA casts work as expected", { exp <- int(NA) to <- int() expect_equal(vec_cast(lgl(NA), to), exp) expect_equal(vec_cast(int(NA), to), exp) expect_equal(vec_cast(dbl(NA), to), exp) expect_equal(vec_cast(chr(NA), to), exp) expect_equal(vec_cast(list(NA), to), exp) }) test_that("Shaped NA casts work as expected", { mat <- matrix exp_mat <- mat(int(NA)) to_mat <- matrix(int()) expect_equal(vec_cast(mat(lgl(NA)), to_mat), exp_mat) expect_equal(vec_cast(mat(int(NA)), to_mat), exp_mat) expect_equal(vec_cast(mat(dbl(NA)), to_mat), exp_mat) expect_equal(vec_cast(mat(chr(NA)), to_mat), exp_mat) expect_equal(vec_cast(mat(list(NA)), to_mat), exp_mat) }) test_that("lossy casts generate error", { expect_lossy(vec_cast(c(2.5, 2), int()), int(2, 2), x = dbl(), to = int()) expect_lossy(vec_cast(c("2.5", "2"), int()), int(2, 2), x = chr(), to = int()) expect_lossy(vec_cast(c(.Machine$integer.max + 1, 1), int()), int(NA, 1L), x = dbl(), to = int()) expect_lossy(vec_cast(c(-.Machine$integer.max - 1, 1), int()), int(NA, 1L), x = dbl(), to = int()) }) test_that("invalid casts generate error", { expect_error(vec_cast(factor("a"), integer()), class = "vctrs_error_incompatible_cast") }) # Double test_that("safe casts work as expected", { expect_equal(vec_cast(NULL, double()), NULL) expect_equal(vec_cast(lgl(TRUE, FALSE), double()), dbl(1, 0)) expect_equal(vec_cast(int(1, 0), double()), dbl(1, 0)) expect_equal(vec_cast(dbl(1, 1.5), double()), dbl(1, 1.5)) expect_equal(vec_cast(chr("1", "1.5"), double()), dbl(1, 1.5)) expect_equal(vec_cast(list(1, 1.5), double()), dbl(1, 1.5)) }) test_that("NA casts work as expected", { exp <- dbl(NA) to <- dbl() expect_equal(vec_cast(lgl(NA), to), exp) expect_equal(vec_cast(int(NA), to), exp) expect_equal(vec_cast(dbl(NA), to), exp) expect_equal(vec_cast(chr(NA), to), exp) expect_equal(vec_cast(list(NA), to), exp) }) test_that("Shaped NA casts work as expected", { mat <- matrix exp_mat <- mat(dbl(NA)) to_mat <- matrix(dbl()) expect_equal(vec_cast(mat(lgl(NA)), to_mat), exp_mat) expect_equal(vec_cast(mat(int(NA)), to_mat), exp_mat) expect_equal(vec_cast(mat(dbl(NA)), to_mat), exp_mat) expect_equal(vec_cast(mat(chr(NA)), to_mat), exp_mat) expect_equal(vec_cast(mat(list(NA)), to_mat), exp_mat) }) test_that("lossy casts generate warning", { expect_lossy(vec_cast(c("2.5", "x"), dbl()), dbl(2.5, NA), x = chr(), to = dbl()) }) test_that("invalid casts generate error", { expect_error(vec_cast(factor("a"), double()), class = "vctrs_error_incompatible_cast") }) # Complex test_that("safe casts to complex works", { expect_identical(vec_cast(NULL, cpl()), NULL) expect_identical(vec_cast(lgl(TRUE, FALSE), cpl()), cpl(1, 0)) expect_identical(vec_cast(int(1, 0), cpl()), cpl(1, 0)) expect_identical(vec_cast(dbl(1, 1.5), cpl()), cpl(1, 1.5)) expect_identical(vec_cast(list(1, 1.5), cpl()), cpl(1, 1.5)) }) test_that("NA casts work as expected", { exp <- cpl(NA) to <- cpl() expect_equal(vec_cast(lgl(NA), to), exp) expect_equal(vec_cast(int(NA), to), exp) expect_equal(vec_cast(dbl(NA), to), exp) expect_equal(vec_cast(list(NA), to), exp) }) test_that("Shaped NA casts work as expected", { mat <- matrix exp_mat <- mat(cpl(NA)) to_mat <- matrix(cpl()) expect_equal(vec_cast(mat(lgl(NA)), to_mat), exp_mat) expect_equal(vec_cast(mat(int(NA)), to_mat), exp_mat) expect_equal(vec_cast(mat(dbl(NA)), to_mat), exp_mat) expect_equal(vec_cast(mat(list(NA)), to_mat), exp_mat) }) test_that("complex is coercible to numeric types", { expect_identical(vec_ptype2(cpl(), NULL), cpl()) expect_identical(vec_ptype2(NULL, cpl()), cpl()) expect_identical(vec_ptype2(cpl(), int()), cpl()) expect_identical(vec_ptype2(int(), cpl()), cpl()) expect_identical(vec_ptype2(cpl(), dbl()), cpl()) expect_identical(vec_ptype2(dbl(), cpl()), cpl()) expect_identical(vec_ptype2(cpl(), cpl()), cpl()) expect_identical(vec_c(0, 1i), cpl(0i, 1i)) }) test_that("complex is not coercible to logical", { expect_error(vec_ptype2(cpl(), lgl()), class = "vctrs_error_incompatible_type") expect_error(vec_ptype2(lgl(), cpl()), class = "vctrs_error_incompatible_type") }) # Character test_that("safe casts work as expected", { expect_equal(vec_cast(NULL, character()), NULL) expect_equal(vec_cast(NA, character()), NA_character_) expect_equal(vec_cast(lgl(TRUE, FALSE), character()), chr("TRUE", "FALSE")) expect_equal(vec_cast(list("x", "y"), character()), chr("x", "y")) }) test_that("NA casts work as expected", { exp <- chr(NA) to <- chr() expect_equal(vec_cast(lgl(NA), to), exp) expect_equal(vec_cast(int(NA), to), exp) expect_equal(vec_cast(dbl(NA), to), exp) expect_equal(vec_cast(chr(NA), to), exp) expect_equal(vec_cast(list(NA), to), exp) }) test_that("Shaped NA casts work as expected", { mat <- matrix exp_mat <- mat(chr(NA)) to_mat <- matrix(chr()) expect_equal(vec_cast(mat(lgl(NA)), to_mat), exp_mat) expect_equal(vec_cast(mat(int(NA)), to_mat), exp_mat) expect_equal(vec_cast(mat(dbl(NA)), to_mat), exp_mat) expect_equal(vec_cast(mat(chr(NA)), to_mat), exp_mat) expect_equal(vec_cast(mat(list(NA)), to_mat), exp_mat) }) test_that("difftime gets special treatment", { dt1 <- as.difftime(600, units = "secs") expect_equal(vec_cast(dt1, character()), "600 secs") }) # Raw test_that("safe casts work as expected", { expect_equal(vec_cast(NULL, raw()), NULL) expect_equal(vec_cast(list(raw(1)), raw()), raw(1)) }) test_that("invalid casts generate error", { expect_error(vec_cast(raw(1), double()), class = "vctrs_error_incompatible_cast") expect_error(vec_cast(double(1), raw()), class = "vctrs_error_incompatible_cast") }) test_that("can sort raw", { x <- as.raw(c(3, 1, 2, 4)) expect_identical(vec_order(x), int(2, 3, 1, 4)) expect_identical(x[vec_order(x)], as.raw(1:4)) }) test_that("raw has informative type summaries", { expect_equal(vec_ptype_abbr(raw()), "raw") expect_equal(vec_ptype_full(raw()), "raw") }) # Lists test_that("safe casts work as expected", { expect_equal(vec_cast(NULL, list()), NULL) expect_equal(vec_cast(NA, list()), list(NULL)) expect_equal(vec_cast(1:2, list()), list(1L, 2L)) expect_equal(vec_cast(list(1L, 2L), list()), list(1L, 2L)) }) test_that("dimensionality matches to" ,{ x1 <- matrix(TRUE, nrow = 1, ncol = 1) x2 <- matrix(list(), nrow = 0, ncol = 2) expect_dim(vec_cast(x1, x2), c(1, 2)) expect_dim(vec_cast(TRUE, x2), c(1, 2)) }) test_that("data frames are cast to list row wise (#639)", { x <- data.frame(x = 1:2, row.names = c("a", "b")) expect <- list(data.frame(x = 1L), data.frame(x = 2L)) expect_equal(vec_cast(x, list()), expect) }) test_that("data frames can be cast to shaped lists", { to <- array(list(), dim = c(0, 2, 1)) x <- data.frame(x = 1:2, y = 3:4) expect <- list(vec_slice(x, 1), vec_slice(x, 2)) expect <- array(expect, dim = c(2, 2, 1)) expect_equal(vec_cast(x, to), expect) }) test_that("Casting atomic `NA` values to list results in a `NULL`", { x <- c(NA, 1) expect <- list(NULL, 1) expect_equal(vec_cast(x, list()), expect) }) test_that("Casting data frame `NA` rows to list results in a `NULL`", { x <- data.frame(x = c(NA, NA, 1), y = c(NA, 1, 2)) expect <- list(NULL, vec_slice(x, 2), vec_slice(x, 3)) expect_equal(vec_cast(x, list()), expect) }) # Unspecified test_that("unspecified can be cast to bare methods", { for (x in vectors[-4]) { expect_identical(vec_cast(unspecified(3), x), vec_init(x, 3)) } }) vctrs/tests/testthat/test-print-str.R0000644000176200001440000000047013473164157017473 0ustar liggesuserscontext("test-print-str") test_that("show attributes", { x <- structure(1:100, x = "a string", y = 1:20, z = data.frame(x = 1:3)) expect_known_output( obj_str(x), test_path("test-print-str-attr.txt") ) expect_known_output( obj_str(mtcars), test_path("test-print-str-mtcars.txt") ) }) vctrs/tests/testthat/test-lifecycle-deprecated.R0000644000176200001440000000042613622451540021556 0ustar liggesusers test_that("vec_as_index() still works", { local_lifecycle_silence() expect_identical(vec_as_index(-2, 10), vec_as_location(-2, 10)) expect_identical( vec_as_index("cyl", length(mtcars), names(mtcars)), vec_as_location("cyl", length(mtcars), names(mtcars)) ) }) vctrs/tests/testthat/helper-output.R0000644000176200001440000000042413622451540017357 0ustar liggesusers try_cat <- function(expr) { cat(paste0("> ", as_label(substitute(expr)), ":\n\n")) out <- tryCatch(expr, error = function(err) { cat(paste0("Error: ", err$message, "\n")) }) cat("\n\n\n") out } # Dummy until implemented in testthat verify_errors <- identity vctrs/tests/testthat/helper-expectations.R0000644000176200001440000000505313622451540020530 0ustar liggesusersexpect_dim <- function(x, shape) { dim <- dim2(x) expect_equal(dim, !!shape) } expect_lossy <- function(expr, result, x = NULL, to = NULL) { expr <- enquo(expr) expect_error(eval_tidy(expr), class = "vctrs_error_cast_lossy") out <- allow_lossy_cast(eval_tidy(expr), x_ptype = x, to_ptype = to) expect_identical(!!out, !!result) } expect_args <- function(x, y, x_arg, y_arg) { err <- catch_cnd(vec_ptype2(x, y, x_arg = x_arg, y_arg = y_arg), classes = "vctrs_error_incompatible_type") expect_true(!is_null(err)) expect_true(grepl(paste0("for `", x_arg, "`"), err$message, fixed = TRUE)) expect_true(grepl(paste0("and `", y_arg, "`"), err$message, fixed = TRUE)) expect_identical(list(err$x_arg, err$y_arg), list(x_arg, y_arg)) } # Work around deparsing of !! on old versions of R as_label2 <- function(expr) { expr <- duplicate(expr, shallow = FALSE) label <- as_label(fix_bang(expr)) label <- gsub("+++", "!!!", label, fixed = TRUE) label <- gsub("++", "!!", label, fixed = TRUE) label } fix_bang <- function(expr) { curr <- expr while (!is_null(curr)) { car <- node_car(curr) if (is_triple_bang(car)) { replace_triple_bang(car) } else if (is_double_bang(car)) { replace_double_bang(car) } else if (is_call(car)) { node_poke_car(curr, fix_bang(car)) } curr <- node_cdr(curr) } expr } is_double_bang <- function(expr) { is_call(expr, "!") && is_call(node_cadr(expr), "!") } is_triple_bang <- function(expr) { is_double_bang(expr) && is_call(node_cadr(node_cadr(expr)), "!") } replace_double_bang <- function(expr) { node_poke_car(expr, sym("+")) node_poke_car(node_cadr(expr), sym("+")) } replace_triple_bang <- function(expr) { replace_double_bang(expr) node_poke_car(node_cadr(node_cadr(expr)), sym("+")) } try2 <- function(expr) { cat(paste0("\n", as_label2(substitute(expr)), ":\n\n")) cat(conditionMessage(catch_cnd(expr, classes = "error")), "\n\n") } expect_known_output_nobang <- function(object, file, ...) { expect_known_output(object, file, ...) } expect_syntactic <- function(name, exp_syn_name) { expect_identical( syn_name <- make_syntactic(name), exp_syn_name ) expect_identical(syn_name, make.names(syn_name)) } expect_error_cnd <- function(object, class, message = NULL, ..., .fixed = TRUE) { cnd <- expect_error(object, regexp = message, class = class, fixed = .fixed) expect_true(inherits_all(cnd, class)) exp_fields <- list2(...) expect_true(is_empty(setdiff(!!names(exp_fields), names(cnd)))) expect_equal(cnd[names(exp_fields)], exp_fields) } vctrs/tests/testthat/helper-size.R0000644000176200001440000000014113622451540016765 0ustar liggesusers expect_size <- function(object, n) { expect_identical(vec_size(object), vec_cast(n, int())) } vctrs/tests/testthat/test-type-vec-size-common-error.txt0000644000176200001440000000027213623022035023251 0ustar liggesusers vec_size_common(1:2, 1, 1:4): No common size for `..1`, size 2, and `..3`, size 4. vec_size_common(foo = 1:2, 1, bar = 1:4): No common size for `foo`, size 2, and `bar`, size 4. vctrs/tests/testthat/test-assert.R0000644000176200001440000002074113623045211017017 0ustar liggesuserscontext("test-assert") test_that("basic assert is idempotent", { x <- new_vctr(1:4) expect_true(vec_is(x)) expect_identical(vec_assert(x), x) expect_identical(vec_assert(x), new_vctr(1:4)) expect_false(withVisible(vec_assert(x))$visible) expect_true(vec_is(1:4)) expect_identical(vec_assert(1:4), 1:4) }) test_that("asserting ptype", { x <- new_vctr(1:4) good <- new_vctr(integer()) expect_true(vec_is(x, good)) expect_error(vec_assert(x, good), NA) # Is this the correct error message? bad <- new_vctr(double()) expect_false(vec_is(x, bad)) expect_error(vec_assert(x, bad), class = "vctrs_error_assert_ptype") }) test_that("asserting size", { x <- new_vctr(1:4) expect_true(vec_is(x, size = 4)) expect_error(vec_assert(x, size = 4), NA) expect_false(vec_is(x, size = 5)) expect_error(vec_assert(x, size = 5), class = "vctrs_error_assert_size") }) test_that("vec_assert() labels input", { expect_error( vec_assert(new_vctr(1:4), size = 5), regexp = "`new_vctr\\(1:4\\)` must have", class = "vctrs_error_assert_size" ) expect_error( vec_assert(new_vctr(1:4), size = 5, arg = "foobar"), regexp = "`foobar` must have", class = "vctrs_error_assert_size" ) }) test_that("bare atomic vectors are vectors but not recursive", { expect_true(vec_is_vector(TRUE)) expect_true(vec_is_vector(1L)) expect_true(vec_is_vector(1)) expect_true(vec_is_vector(1i)) expect_true(vec_is_vector("foo")) expect_true(vec_is_vector(as.raw(1))) }) test_that("S3 atomic vectors are vectors", { expect_true(vec_is_vector(foobar(TRUE))) expect_true(vec_is_vector(foobar(1L))) expect_true(vec_is_vector(foobar(1))) expect_true(vec_is_vector(foobar(1i))) expect_true(vec_is_vector(foobar("foo"))) expect_true(vec_is_vector(foobar(as.raw(1)))) }) test_that("bare lists are vectors", { expect_true(vec_is_vector(list())) }) test_that("S3 lists are not vectors by default", { expect_false(vec_is_vector(foobar())) local_foobar_proxy() expect_true(vec_is_vector(foobar())) }) test_that("data frames and records are vectors", { expect_true(vec_is_vector(mtcars)) expect_true(vec_is_vector(new_rcrd(list(x = 1, y = 2)))) }) test_that("non-vector base types are scalars", { expect_identical(vec_typeof(quote(foo)), "scalar") expect_identical(vec_typeof(pairlist("")), "scalar") expect_identical(vec_typeof(function() NULL), "scalar") expect_identical(vec_typeof(env()), "scalar") expect_identical(vec_typeof(quote(foo)), "scalar") expect_identical(vec_typeof(~foo), "scalar") expect_identical(vec_typeof(base::`{`), "scalar") expect_identical(vec_typeof(base::c), "scalar") expect_identical(vec_typeof(expression()), "scalar") expect_false(vec_is_vector(quote(foo))) expect_false(vec_is_vector(pairlist(""))) expect_false(vec_is_vector(function() NULL)) expect_false(vec_is_vector(env())) expect_false(vec_is_vector(~foo)) expect_false(vec_is_vector(base::`{`)) expect_false(vec_is_vector(base::c)) expect_false(vec_is_vector(expression())) expect_false(vec_is(quote(foo))) expect_false(vec_is(pairlist(""))) expect_false(vec_is(function() NULL)) expect_false(vec_is(env())) expect_false(vec_is(~foo)) expect_false(vec_is(base::`{`)) expect_false(vec_is(base::c)) expect_false(vec_is(expression())) expect_error(vec_assert(quote(foo)), class = "vctrs_error_scalar_type") expect_error(vec_assert(pairlist("")), class = "vctrs_error_scalar_type") expect_error(vec_assert(function() NULL), class = "vctrs_error_scalar_type") expect_error(vec_assert(env()), class = "vctrs_error_scalar_type") expect_error(vec_assert(~foo), class = "vctrs_error_scalar_type") expect_error(vec_assert(base::`{`), class = "vctrs_error_scalar_type") expect_error(vec_assert(base::c), class = "vctrs_error_scalar_type") expect_error(vec_assert(expression()), class = "vctrs_error_scalar_type") }) test_that("non-vector types can be proxied", { x <- new_proxy(1:3) expect_identical(vec_typeof(x), "scalar") expect_false(vec_is_vector(x)) expect_false(vec_is(x)) expect_error(vec_assert(x), class = "vctrs_error_scalar_type") local_env_proxy() expect_identical(vec_typeof(x), "integer") expect_true(vec_is_vector(x)) expect_true(vec_is(x)) expect_error(regexp = NA, vec_assert(x)) }) test_that("vec_assert() uses friendly type in error messages", { # Friendly type will be generated in rlang in the future. Upstream # changes should not cause CRAN failures. skip_on_cran() expect_error(vec_assert(function() NULL), class = "vctrs_error_scalar_type") }) test_that("vec_typeof() handles all types", { for (i in seq_along(empty_types)) { expect_identical(vec_typeof(!!empty_types[[i]]), !!names(empty_types)[[i]]) } }) test_that("bare prototypes don't act as partial types", { expect_false(vec_is(foobar(1), dbl())) expect_error(vec_assert(foobar(1), dbl()), class = "vctrs_error_assert_ptype") }) test_that("data frames are always classified as such even when dispatch is off", { expect_identical(vec_typeof_bare(mtcars), "dataframe") }) test_that("assertion is not applied on proxy", { local_methods( vec_proxy.vctrs_foobar = unclass, vec_restore.vctrs_foobar = function(x, ...) foobar(x), `[.vctrs_foobar` = function(x, i) vec_slice(x, i) ) x <- foobar(list()) expect_true(vec_is(x, x)) expect_false(vec_is(x, list())) expect_error(vec_assert(x, list()), class = "vctrs_error_assert_ptype") expect_error(vec_assert(x, x), regexp = NA) }) test_that("attributes of unclassed vectors are asserted", { x <- structure(FALSE, foo = "bar") y <- structure(TRUE, foo = "bar") expect_false(vec_is(x, FALSE)) expect_false(vec_is(FALSE, x)) expect_true(vec_is(y, x)) expect_true(vec_is(x, y)) }) test_that("unspecified is finalised before assertion", { expect_true(vec_is(NA, TRUE)) expect_true(vec_is(data.frame(x = NA), data.frame(x = lgl()))) expect_error(regexp = NA, vec_assert(NA, TRUE)) expect_error(regexp = NA, vec_assert(data.frame(x = NA), data.frame(x = lgl()))) }) test_that("assertion failures are explained", { expect_known_output(file = test_path("test-assert-explanations.txt"), { local_no_stringsAsFactors() local_options(rlang_backtrace_on_error = "none") try_cat(vec_assert(lgl(), chr())) try_cat(vec_assert(lgl(), factor())) try_cat(vec_assert(lgl(), factor(levels = "foo"))) try_cat(vec_assert(factor(levels = "bar"), factor(levels = "foo"))) try_cat(vec_assert(factor(), chr())) try_cat(vec_assert(lgl(), data.frame())) try_cat(vec_assert(lgl(), data.frame(x = 1))) try_cat(vec_assert(lgl(), data.frame(x = 1, y = 2))) try_cat(vec_assert(data.frame(), chr())) try_cat(vec_assert(data.frame(x = 1), chr())) try_cat(vec_assert(data.frame(x = 1), data.frame(x = "foo"))) try_cat(vec_assert(data.frame(x = 1), data.frame(x = "foo", y = 2))) try_cat(vec_assert(data.frame(x = 1, y = 2), chr())) try_cat(vec_assert(data.frame(x = 1, y = 2), data.frame(x = "foo"))) try_cat(vec_assert(data.frame(x = 1, y = 2), data.frame(x = "foo", y = 2))) }) }) test_that("NULL is not a vector", { expect_false(vec_is_vector(NULL)) expect_false(vec_is(NULL)) }) test_that("names and row names do not influence type identity (#707)", { expect_true(vec_is(c(a = TRUE), logical())) expect_true(vec_is(TRUE, c(a = TRUE))) expect_true(vec_is(structure(mtcars, row.names = 1:32), mtcars)) expect_true(vec_is(mtcars, structure(mtcars, row.names = 1:32))) }) # vec_is_list ----------------------------------------------------------- test_that("bare lists are lists", { expect_true(vec_is_list(list())) }) test_that("Vectors with a non-VECSXP type are not lists", { expect_false(vec_is_list(1)) expect_false(vec_is_list("a")) expect_false(vec_is_list(quote(name))) }) test_that("explicitly classed lists are lists", { x <- structure(list(), class = "list") expect_true(vec_is_list(x)) expect_true(vec_is_list(subclass(x))) }) test_that("POSIXlt are not considered a list", { expect_false(vec_is_list(as.POSIXlt(new_datetime()))) }) test_that("rcrd types are not lists", { expect_false(vec_is_list(new_rcrd(list(x = 1)))) }) test_that("scalars are not lists", { expect_false(vec_is_list(foobar())) }) test_that("non-explicitly classed lists that implement a proxy are lists", { local_foobar_proxy() expect_true(vec_is_list(foobar())) }) test_that("data frames of all types are not lists", { expect_false(vec_is_list(data.frame())) expect_false(vec_is_list(subclass(data.frame()))) expect_false(vec_is_list(tibble::tibble())) }) vctrs/tests/testthat/test-slice-assign.R0000644000176200001440000002602513623013722020102 0ustar liggesuserscontext("test-slice-assign") test_that("slice-assign throws error with non-vector inputs", { x <- environment() expect_error(vec_slice(x, 1L) <- 1L, class = "vctrs_error_scalar_type") }) test_that("slice-assign throws error with non-vector `value`", { x <- 1L expect_error(vec_slice(x, 1L) <- NULL, class = "vctrs_error_scalar_type") expect_error(vec_slice(x, 1L) <- environment(), class = "vctrs_error_scalar_type") }) test_that("can slice-assign NULL", { x <- NULL vec_slice(x, 1L) <- 1 expect_identical(x, NULL) }) test_that("can slice-assign base vectors", { x <- rep(FALSE, 3) vec_slice(x, 2) <- TRUE expect_identical(x, lgl(FALSE, TRUE, FALSE)) x <- rep(0L, 3) vec_slice(x, 2) <- 1L expect_identical(x, int(0L, 1L, 0L)) x <- rep(0., 3) vec_slice(x, 2) <- 1 expect_identical(x, dbl(0, 1, 0)) x <- rep(0i, 3) vec_slice(x, 2) <- 1i expect_identical(x, cpl(0i, 1i, 0i)) x <- rep("", 3) vec_slice(x, 2) <- "foo" expect_identical(x, chr("", "foo", "")) x <- as.raw(rep(0, 3)) vec_slice(x, 2) <- as.raw(1) expect_identical(x, as.raw(c(0, 1, 0))) }) test_that("can assign base vectors", { x <- rep(FALSE, 3) expect_identical(vec_assign(x, 2, TRUE), lgl(FALSE, TRUE, FALSE)) expect_identical(x, rep(FALSE, 3)) x <- rep(0L, 3) expect_identical(vec_assign(x, 2, 1L), int(0L, 1L, 0L)) expect_identical(x, rep(0L, 3)) x <- rep(0., 3) expect_identical(vec_assign(x, 2, 1), dbl(0, 1, 0)) expect_identical(x, rep(0., 3)) x <- rep(0i, 3) expect_identical(vec_assign(x, 2, 1i), cpl(0i, 1i, 0i)) expect_identical(x, rep(0i, 3)) x <- rep("", 3) expect_identical(vec_assign(x, 2, "foo"), chr("", "foo", "")) expect_identical(x, rep("", 3)) x <- as.raw(rep(0, 3)) expect_identical(vec_assign(x, 2, as.raw(1)), as.raw(c(0, 1, 0))) expect_identical(x, as.raw(rep(0, 3))) }) test_that("can slice-assign lists", { x <- rep(list(NULL), 3) vec_slice(x, 2) <- list(NA) expect_identical(x, list(NULL, NA, NULL)) }) test_that("can assign lists", { x <- rep(list(NULL), 3) expect_identical(vec_assign(x, 2, list(NA)), list(NULL, NA, NULL)) expect_identical(x, rep(list(NULL), 3)) }) test_that("atomics can't be assigned in lists", { x <- list(NULL) expect_error(vec_slice(x, 1) <- 1, class = "vctrs_error_incompatible_type") expect_error(vec_assign(x, 1, 2), class = "vctrs_error_incompatible_type") expect_error(vec_slice(x, 1) <- "foo", class = "vctrs_error_incompatible_type") expect_error(vec_assign(x, 1, "foo"), class = "vctrs_error_incompatible_type") }) test_that("Unspecified `NA` vector can be assigned into lists", { x <- list(1, 2) vec_slice(x, 1) <- NA expect_identical(x, list(NULL, 2)) }) test_that("monitoring test - unspecified() can be assigned in lists", { x <- list(1, 2) expect_error(vec_slice(x, 1) <- unspecified(1), NA) expect_equal(x, list(NULL, 2)) }) test_that("can assign and slice-assign data frames", { df <- data.frame(x = 1:2) df$y <- data.frame(a = 2:1) orig <- duplicate(df, shallow = FALSE) other <- data.frame(x = 3) other$y <- data.frame(a = 3) exp <- data.frame(x = int(3, 2)) exp$y <- data.frame(a = int(3, 1)) expect_identical(vec_assign(df, 1, other), exp) expect_identical(df, orig) vec_slice(df, 1) <- other expect_identical(df, exp) }) test_that("can slice-assign arrays", { x <- array(c(2, 1, 2, 1), c(2, 2)) vec_slice(x, 1L) <- 1 expect_equal(x, array(1, c(2, 2))) x <- array(c(2, 1, 2, 1, 2, 1, 2, 1), c(2, 2, 2)) vec_slice(x, 1L) <- 1 expect_equal(x, array(1, c(2, 2, 2))) }) test_that("can assign arrays", { x <- array(c(2, 1, 2, 1), c(2, 2)) expect_identical(vec_assign(x, 1L, 1), array(1, c(2, 2))) expect_identical(x, array(c(2, 1, 2, 1), c(2, 2))) x <- array(c(2, 1, 2, 1, 2, 1, 2, 1), c(2, 2, 2)) expect_identical(vec_assign(x, 1L, 1), array(1, c(2, 2, 2))) expect_identical(x, array(c(2, 1, 2, 1, 2, 1, 2, 1), c(2, 2, 2))) }) test_that("can slice-assign using logical index", { x <- c(2, 1) vec_slice(x, TRUE) <- 3 expect_equal(x, c(3, 3)) vec_slice(x, c(TRUE, FALSE)) <- 4 expect_equal(x, c(4, 3)) expect_error( vec_assign(x, c(TRUE, FALSE, TRUE), 5), class = "vctrs_error_subscript_size" ) expect_error( vec_assign(mtcars, c(TRUE, FALSE), mtcars[1, ]), class = "vctrs_error_subscript_size" ) }) test_that("slice-assign ignores NA in logical subsetting", { x <- c(NA, 1, 2) expect_equal(`vec_slice<-`(x, x > 0, 1), c(NA, 1, 1)) expect_equal(`vec_slice<-`(x, x > 0, c(NA, 2:1)), c(NA, 2, 1)) }) test_that("slice-assign ignores NA in integer subsetting", { x <- 0:2 expect_equal(`vec_slice<-`(x, c(NA, 2:3), 1), c(0, 1, 1)) expect_equal(`vec_slice<-`(x, c(NA, 2:3), c(NA, 2:1)), c(0, 2, 1)) }) test_that("can't modify subset with missing argument", { x <- 1:3 expect_error(vec_slice(x, ) <- 2L) }) test_that("can modify subset with recycled NA argument", { x <- 1:3 vec_slice(x, NA) <- 2L expect_identical(x, 1:3) }) test_that("can modify subset with recycled TRUE argument", { x <- 1:3 vec_slice(x, TRUE) <- 2L expect_identical(x, rep(2L, 3)) }) test_that("can modify subset with recycled FALSE argument", { x <- 1:3 vec_slice(x, FALSE) <- 2L expect_identical(x, 1:3) }) test_that("can modify subset with NULL argument", { x <- 1:3 vec_slice(x, NULL) <- 2L expect_identical(x, 1:3) }) test_that("can slice-assign with missing indices", { x <- 1:3 y <- 4:6 test <- c(NA, TRUE, FALSE) vec_slice(x, test) <- vec_slice(y, test) expect_identical(x, int(1, 5, 3)) }) test_that("slice-assign checks vectorness", { x <- foobar(list(1)) expect_error(vec_slice(x, 1) <- 10, class = "vctrs_error_scalar_type") }) test_that("a coercible RHS is cast to LHS before assignment (#140)", { x <- 1:2 expect_error(vec_slice(x, 1) <- "1", class = "vctrs_error_incompatible_type") x <- c("foo", "bar") expect_error(vec_slice(x, 1) <- 1, class = "vctrs_error_incompatible_type") x <- 1:2 expect_error(vec_slice(x, 1) <- 3.5, class = "vctrs_error_cast_lossy") allow_lossy_cast(vec_slice(x, 1) <- 3.5) expect_identical(x, int(3, 2)) x <- matrix(1:4, 2) vec_slice(x, 1) <- matrix(c(FALSE, FALSE), 1) expect_identical(x, matrix(int(0, 2, 0, 4), 2)) expect_error(vec_assign(x, 1, matrix(c("", ""), 1)), class = "vctrs_error_incompatible_type") }) test_that("slice-assign takes the proxy", { local_proxy() x <- new_proxy(1:3) y <- new_proxy(20:21) vec_slice(x, 2:3) <- y expect_identical(proxy_deref(x), int(1, 20, 21)) }) test_that("can use names to vec_slice<-() a named object", { x0 <- c(a = 1, b = 2) x1 <- c(a = 1, a = 2) vec_slice(x0, "b") <- 3 expect_identical(x0, c(a = 1, b = 3)) vec_slice(x1, "a") <- 3 expect_identical(x1, c(a = 3, a = 2)) }) test_that("can use names to vec_slice<-() a named object", { x0 <- 1:3 expect_error( vec_slice(x0, letters[1]) <- 4L, "Can't use character names to index an unnamed vector.", fixed = TRUE ) expect_error( vec_slice(x0, letters[25:27]) <- 5L, "Can't use character names to index an unnamed vector.", fixed = TRUE ) }) test_that("slice-assign falls back to `[<-` when proxy is not implemented", { obj <- foobar(c("foo", "bar", "baz")) expect_error(vec_slice(obj, 1:2) <- TRUE, class = "vctrs_error_incompatible_type") vec_slice(obj, 1:2) <- foobar("quux") vec_ptype2(foobar(""), foobar("")) vec_cast(foobar(""), foobar("")) #> Error: Can't cast to local_methods( `[<-.vctrs_foobar` = function(x, i, value) { x <- unclass(x) x[i] <- "dispatched" x }, vec_ptype2.logical.vctrs_foobar = function(...) foobar(""), vec_ptype2.vctrs_foobar = function(...) foobar(""), vec_cast.vctrs_foobar = function(x, to, ...) x ) obj <- foobar(c("foo", "bar", "baz")) vec_slice(obj, 1:2) <- TRUE expect_identical(obj, c("dispatched", "dispatched", "baz")) }) test_that("vec_assign() can always assign unspecified values into foreign vector types", { obj <- foobar(c("foo", "bar", "baz")) expect <- foobar(c(NA, "bar", "baz")) expect_identical(vec_assign(obj, 1, NA), expect) expect_identical(vec_assign(obj, 1, unspecified(1)), expect) }) test_that("slice-assign restores value before falling back to `[<-` (#443)", { called <- FALSE local_methods( vec_proxy.vctrs_proxy = proxy_deref, vec_restore.vctrs_proxy = function(x, to, ...) new_proxy(x), vec_ptype2.vctrs_proxy = function(...) new_proxy(NA), vec_cast.vctrs_foobar = function(x, ...) proxy_deref(x), `[<-.vctrs_foobar` = function(x, i, value) { called <<- TRUE expect_is(value, "vctrs_proxy") } ) x <- foobar(1) y <- new_proxy(10) vec_slice(x, 1) <- y expect_true(called) }) test_that("index and value are sliced before falling back", { # Work around a bug in base R `[<-` lhs <- foobar(c(NA, 1:4)) rhs <- foobar(int(0L, 10L)) exp <- foobar(int(10L, 1:4)) expect_identical(vec_assign(lhs, c(NA, 1), rhs), exp) }) test_that("can assign to data frame", { x <- data_frame(x = 1:3) y <- data_frame(x = 20) expect_identical(vec_assign(x, 2, y), data_frame(x = int(1, 20, 3))) }) test_that("can slice-assign unspecified vectors with default type2 method", { local_rational_class() x <- rational(1:2, 2:3) x[[1]] <- NA expect_identical(x, rational(c(NA, 2L), c(NA, 3L))) }) test_that("`vec_assign()` requires recyclable value", { verify_errors({ expect_error( vec_assign(1:3, 1:3, 1:2), class = "vctrs_error_recycle_incompatible_size" ) }) }) test_that("logical subscripts must match size of indexed vector", { verify_errors({ expect_error( vec_assign(1:2, c(TRUE, FALSE, TRUE), 5), class = "vctrs_error_subscript_size" ) }) }) test_that("must assign existing elements", { verify_errors({ expect_error( vec_assign(1:3, 5, 10), class = "vctrs_error_subscript_oob" ) expect_error( vec_assign(1:3, "foo", 10), "unnamed vector" ) expect_error( vec_slice(letters, -100) <- "foo", class = "vctrs_error_subscript_oob" ) expect_error( vec_assign(set_names(letters), "foo", "bar"), class = "vctrs_error_subscript_oob" ) }) }) test_that("must assign with proper negative locations", { verify_errors({ expect_error( vec_assign(1:3, c(-1, 1), 1:2), class = "vctrs_error_subscript_type" ) expect_error( vec_assign(1:3, c(-1, NA), 1:2), class = "vctrs_error_subscript_type" ) }) }) test_that("slice and assign have informative errors", { verify_output(test_path("error", "test-slice-assign.txt"), { "# `vec_assign()` requires recyclable value" vec_assign(1:3, 1:3, 1:2) "# logical subscripts must match size of indexed vector" vec_assign(1:2, c(TRUE, FALSE, TRUE), 5) vec_assign(mtcars, c(TRUE, FALSE), mtcars[1, ]) "# must assign existing elements" vec_assign(1:3, 5, 10) vec_assign(1:3, "foo", 10) vec_slice(letters, -100) <- "foo" vec_assign(set_names(letters), "foo", "bar") "# must assign with proper negative locations" vec_assign(1:3, c(-1, 1), 1:2) vec_assign(1:3, c(-1, NA), 1:2) }) }) vctrs/tests/testthat/test-size.R0000644000176200001440000000652513623013722016476 0ustar liggesuserscontext("test-size") # vec_size ----------------------------------------------------------------- test_that("vec_size must be called with vector", { expect_error(vec_size(mean), class = "vctrs_error_scalar_type") }) test_that("length is number of rows", { expect_equal(vec_size(integer()), 0) expect_equal(vec_size(array(integer())), 0) expect_equal(vec_size(1:2), 2) expect_equal(vec_size(array(dim = 2)), 2) expect_equal(vec_size(matrix(nrow = 2, ncol = 3)), 2) expect_equal(vec_size(array(dim = c(2, 1, 5))), 2) }) test_that("length of record is number of rows, not fields", { r <- new_rcrd(list(x = 1:10)) expect_equal(vec_size(r), 10) }) test_that("handles three types of data frame rownames", { df1 <- df2 <- df3 <- data.frame(x = 1:3) rownames(df1) <- NULL rownames(df2) <- 3:1 rownames(df3) <- letters[1:3] expect_equal(vec_size(df1), 3) expect_equal(vec_size(df2), 3) expect_equal(vec_size(df3), 3) }) test_that("handles positive short row names (#220)", { data <- structure(mtcars, row.names = c(NA, 32)) expect_identical(vec_size(data), 32L) }) test_that("size is proxied", { local_env_proxy() expect_size(new_proxy(1:3), 3) expect_size(new_proxy(list(1, 2, 3)), 3) expect_size(new_proxy(foobar(list(1, 2, 3))), 3) }) test_that("`NULL` has size zero", { expect_identical(vec_size(NULL), 0L) }) test_that("can take the size of unspecified objects", { expect_size(NA, 1) expect_size(c(NA, NA), 2) expect_size(unspecified(2), 2) }) # vec_size_common --------------------------------------------------------- test_that("vec_size_common with no input is 0L unless `.absent` is provided", { expect_identical(vec_size_common(), 0L) expect_identical(vec_size_common(NULL), 0L) expect_equal(vec_size_common(.absent = na_int), na_int) }) test_that("`.absent` must be a length 1 integer if provided", { expect_error(vec_size_common(.absent = 1), "must be a single integer") expect_error(vec_size_common(.absent = c(1L, 2L)), "must be a single integer") }) test_that("`NULL` is treated as the absence of input", { expect_equal(vec_size_common(1:5, NULL), vec_size_common(1:5)) }) test_that("size 1 is overshadowed by any other size", { expect_equal(vec_size_common(1, integer()), 0) expect_equal(vec_size_common(1, 1:5), 5) }) test_that("if not size 1, sizes must be identical", { expect_equal(vec_size_common(integer(), integer()), 0) expect_error(vec_size_common(1:2, integer()), class = "vctrs_error_incompatible_size") expect_error(vec_size_common(1:2, 1:3), class = "vctrs_error_incompatible_size") }) test_that("argument tags are forwarded", { expect_known_output_nobang(file = test_path("test-type-vec-size-common-error.txt"), { try2(vec_size_common(1:2, 1, 1:4)) try2(vec_size_common(foo = 1:2, 1, bar = 1:4)) }) }) test_that("can pass size", { expect_identical(vec_size_common(1:2, 1:3, .size = 5L), 5L) }) test_that("provided size is cast to an integer", { expect_identical(vec_size_common(.size = 1), 1L) }) # sequences --------------------------------------------------------------- test_that("vec_seq_along returns size-0 output for size-0 input", { expect_equal(vec_seq_along(character()), integer()) expect_equal(vec_seq_along(data.frame()), integer()) }) test_that("vec_init_along can be called with single argument", { expect_equal(vec_init_along(1:3), rep(NA_integer_, 3)) }) vctrs/tests/testthat/test-vctr-print-names.txt0000644000176200001440000000004613623022055021342 0ustar liggesusers A B C xxx xxx xxx vctrs/tests/testthat/test-type-unspecified.R0000644000176200001440000000645313623013722021001 0ustar liggesuserscontext("test-type-unspecified") test_that("unknown type is idempotent", { types <- list( unspecified(), logical(), integer(), double(), character(), list(), new_list_of(ptype = integer()), new_factor(), new_ordered(), new_date(), new_datetime(), new_duration() ) lhs <- map(types, vec_ptype2, x = unspecified()) expect_equal(types, lhs) rhs <- map(types, vec_ptype2, y = unspecified()) expect_equal(types, rhs) }) test_that("common type of unspecified and NULL is unspecified", { expect_identical(vec_ptype2(unspecified(), NULL), unspecified()) expect_identical(vec_ptype2(NULL, unspecified()), unspecified()) expect_identical(vec_ptype2(NA, NULL), unspecified()) expect_identical(vec_ptype2(NULL, NA), unspecified()) }) test_that("cannot take the common type of unspecified and a scalar list", { expect_error(vec_ptype2(unspecified(), foobar()), class = "vctrs_error_scalar_type") expect_error(vec_ptype2(foobar(), unspecified()), class = "vctrs_error_scalar_type") }) test_that("subsetting works", { expect_identical(unspecified(4)[2:3], unspecified(2)) }) test_that("subsetting works", { expect_identical(unspecified(4)[2:3], unspecified(2)) }) test_that("has useful print method", { expect_known_output(unspecified(), print = TRUE, file = test_path("test-type-unspecified.txt")) }) test_that("can finalise data frame containing unspecified columns", { df <- data.frame(y = NA, x = c(1, 2, NA)) ptype <- vec_ptype(df) expect_identical(ptype$y, unspecified()) finalised <- vec_ptype_finalise(ptype) expect_identical(finalised$y, lgl()) common <- vec_ptype_common(df, df) expect_identical(common$y, lgl()) }) test_that("can cast to common type data frame containing unspecified columns", { df <- data.frame(y = NA, x = c(1, 2, NA)) expect_identical(vec_cast_common(df, df), list(df, df)) }) test_that("unspecified vectors are always unspecified (#222)", { expect_true(is_unspecified(unspecified())) expect_true(is_unspecified(unspecified(1))) }) test_that("S3 vectors and shaped vectors are never unspecified", { expect_false(is_unspecified(foobar(NA))) expect_false(is_unspecified(foobar(lgl(NA, NA)))) expect_false(is_unspecified(matrix(NA, 2))) }) test_that("can finalise lengthy unspecified vectors", { expect_identical(vec_ptype_finalise(unspecified(3)), rep(NA, 3)) expect_identical(ununspecify(unspecified(3)), rep(NA, 3)) }) test_that("unspecified() validates input", { expect_identical(unspecified(1), unspecified(1L)) expect_error(unspecified(1:3), "must be a single number") }) test_that("tibble::type_sum() knows about unspecified", { expect_identical(tibble::type_sum(unspecified(3)), "???") }) test_that("casting to a scalar type errors", { expect_error(vec_cast(NA, quote(x)), class = "vctrs_error_scalar_type") expect_error(vec_cast(unspecified(1), quote(x)), class = "vctrs_error_scalar_type") }) test_that("monitoring test - can cast to unspecified from unspecified", { expect_identical(vec_cast(NA, unspecified()), unspecified(1)) expect_identical(vec_cast(unspecified(1), unspecified()), unspecified(1)) }) test_that("monitoring test - casting unspecified input to NA unspecified results in NA vector", { expect_identical(vec_cast(unspecified(1), NA), NA) expect_identical(vec_cast(NA, NA), NA) }) vctrs/tests/testthat/test-empty.R0000644000176200001440000000017113473164157016665 0ustar liggesuserscontext("test-empty") test_that("uses y when x is empty", { expect_equal(1 %0% 2, 1) expect_equal(1[0] %0% 2, 2) }) vctrs/tests/testthat/test-shape.R0000644000176200001440000000456613622451540016632 0ustar liggesuserscontext("test-shape") int <- function(...) { array(NA_integer_, c(...)) } # common shape ------------------------------------------------------------ test_that("length is ignored", { expect_equal(shape_common(int(5), int(10)), integer()) expect_equal(shape_common(int(5, 1), int(10, 1)), 1L) expect_equal(shape_common(int(5, 1, 2), int(10, 1, 2)), c(1L, 2L)) expect_equal(shape_common(int(10, 1, 2), int(5, 1, 2)), c(1L, 2L)) expect_equal(shape_common(int(0, 1, 5), int(1, 5, 1)), c(5L, 5L)) }) test_that("recycling rules applied", { expect_equal(shape_common(int(1, 5, 5), int(1)), c(5L, 5L)) expect_equal(shape_common(int(1), int(1, 5, 5)), c(5L, 5L)) expect_equal(shape_common(int(1, 1), int(1, 5, 5)), c(5L, 5L)) expect_equal(shape_common(int(1, 1, 1), int(1, 5, 5)), c(5L, 5L)) expect_equal(shape_common(int(1, 1, 5), int(1, 5, 1)), c(5L, 5L)) expect_equal(shape_common(int(1, 5, 1), int(1, 1, 5)), c(5L, 5L)) expect_equal(shape_common(int(1, 1, 1), int(1, 5, 5)), c(5L, 5L)) expect_equal(shape_common(int(1, 0, 5), int(1, 1, 1)), c(0L, 5L)) expect_error(shape_common(int(1, 0, 5), int(1, 5, 1)), "0, 5") expect_error(shape_common(int(1, 5, 0), int(1, 1, 5)), "0, 5") }) # broadcasting ------------------------------------------------------------- test_that("can broadcast to higher dimension, but not lower", { expect_identical(shape_broadcast(1, NULL), 1) expect_null(shape_broadcast(NULL, 1)) expect_equal( shape_broadcast(1, int(0, 4)), array(1, c(1, 4)) ) expect_error( shape_broadcast(int(1, 1, 1), int(4, 4)), class = "vctrs_error_incompatible_cast" ) expect_error( shape_broadcast(int(3, 2), int(3, 3)), class = "vctrs_error_incompatible_cast" ) }) test_that("recycling rules applied", { expect_equal( shape_broadcast(array(1:4, c(1, 1, 4)), int(0, 4, 4))[1, , ], matrix(1:4, 4, 4, byrow = TRUE) ) expect_equal( shape_broadcast(array(1:4, c(1, 4, 1)), int(0, 4, 4))[1, , ], matrix(1:4, 4, 4) ) expect_equal( shape_broadcast(array(1L, c(1, 1)), int(1, 0)), matrix(integer(), nrow = 1) ) expect_error( shape_broadcast(array(1L, c(1, 2)), int(1, 0)), "Non-recyclable dimensions", class = "vctrs_error_incompatible_cast" ) expect_error( shape_broadcast(array(1L, c(1, 0)), int(1, 1)), "Non-recyclable dimensions", class = "vctrs_error_incompatible_cast" ) }) vctrs/tests/testthat/test-vctr-print.txt0000644000176200001440000000011713623022055020240 0ustar liggesusers [1] xxx xxx xxx xxx hidden [1:4] xxx, xxx, xxx, xxx vctrs/tests/testthat/test-subscript.R0000644000176200001440000000414213622451540017536 0ustar liggesusers test_that("vec_as_subscript() coerces unspecified vectors", { expect_identical( vec_as_subscript(NA), NA ) expect_identical( vec_as_subscript(NA, logical = "error"), na_int ) expect_identical( vec_as_subscript(NA, logical = "error", numeric = "error"), na_chr ) }) test_that("vec_as_subscript() coerces subtypes and supertypes", { expect_identical(vec_as_subscript(factor("foo")), "foo") with_lgl_subtype({ expect_identical(vec_as_subscript(new_lgl_subtype(TRUE)), TRUE) }) with_lgl_supertype({ expect_identical(vec_as_subscript(new_lgl_supertype(TRUE)), TRUE) }) }) test_that("vec_as_subscript() handles NULL", { expect_identical(vec_as_subscript(NULL), int()) expect_error( vec_as_subscript(NULL, numeric = "error"), class = "vctrs_error_subscript_type" ) }) test_that("vec_as_subscript() handles symbols", { expect_identical(vec_as_subscript(quote(foo)), "foo") expect_identical(vec_as_subscript(quote(``)), "\u5e78") expect_error( vec_as_subscript(quote(foo), character = "error"), class = "vctrs_error_subscript_type" ) }) test_that("can customise subscript errors", { verify_errors({ expect_error( with_tibble_cols(vec_as_subscript(env())), class = "vctrs_error_subscript_type" ) }) }) test_that("subscript functions have informative error messages", { verify_output(test_path("error", "test-subscript.txt"), { "# vec_as_subscript() forbids subscript types" vec_as_subscript(1L, logical = "error", numeric = "error") vec_as_subscript("foo", logical = "error", character = "error") vec_as_subscript(TRUE, logical = "error") vec_as_subscript("foo", character = "error") vec_as_subscript(NULL, numeric = "error") vec_as_subscript(quote(foo), character = "error") "# vec_as_subscript2() forbids subscript types" vec_as_subscript2(1L, numeric = "error", logical = "error") vec_as_subscript2("foo", character = "error", logical = "error") vec_as_subscript2(TRUE, logical = "error") "# can customise subscript errors" with_tibble_cols(vec_as_subscript(env())) }) }) vctrs/tests/testthat/test-utils.R0000644000176200001440000000202113622451540016652 0ustar liggesuserscontext("test-utils") # outer_names -------------------------------------------------------------- test_that("names preserved if outer name is missing", { x <- c("a", "z", "") expect_equal(outer_names(x, NULL, 3), x) expect_equal(outer_names(x, "", 3), x) expect_equal(outer_names(x, na_chr, 3), x) }) test_that("outer name vectorised if needed", { expect_equal(outer_names(NULL, "x", 1L), c("x")) expect_equal(outer_names(NULL, "x", 2L), c("x1", "x2")) }) test_that("outer and inner names are combined", { expect_equal(outer_names("x", "y", 1), c("y..x")) }) test_that("options are created", { expect_identical( unclass(new_opts(c("a", "c"), letters[1:4])), c(a = TRUE, b = FALSE, c = TRUE, d = FALSE) ) }) test_that("can't supply unknown option", { expect_error( new_opts(c("a", "foo"), letters[1:4]), "Argument must be one of \"a\", \"b\", \"c\" or \"d\"" ) expect_error( new_opts(c("a", "foo"), letters[1:4], arg = "foo"), "`foo` must be one of \"a\", \"b\", \"c\" or \"d\"" ) }) vctrs/tests/testthat/test-type-data-frame.txt0000644000176200001440000000060313623210233021105 0ustar liggesusers> vec_ptype_show(mtcars) Prototype: data.frame< mpg : double cyl : double disp: double hp : double drat: double wt : double qsec: double vs : double am : double gear: double carb: double > > vec_ptype_show(iris) Prototype: data.frame< Sepal.Length: double Sepal.Width : double Petal.Length: double Petal.Width : double Species : factor<12d60> > vctrs/tests/testthat/test-equal.R0000644000176200001440000002616413623013722016634 0ustar liggesuserscontext("test-equal") # vectorised -------------------------------------------------------------- test_that("throws error for unsuported type", { expect_error(.Call(vctrs_equal, expression(x), expression(x), TRUE), class = "vctrs_error_scalar_type") }) test_that("C wrapper throws error if length or type doesn't match", { expect_error(.Call(vctrs_equal, 1:2, 1L, TRUE), "same types and lengths") expect_error(.Call(vctrs_equal, 1, 1L, TRUE), "same types and lengths") }) test_that("correct behaviour for basic vectors", { expect_equal(vec_equal(c(TRUE, FALSE), TRUE), c(TRUE, FALSE)) expect_equal(vec_equal(c(1L, 2L), 1L), c(TRUE, FALSE)) expect_equal(vec_equal(c(1, 2), 1), c(TRUE, FALSE)) expect_equal(vec_equal(c("1", "2"), "1"), c(TRUE, FALSE)) expect_equal(vec_equal(as.raw(1:2), as.raw(1L)), c(TRUE, FALSE)) expect_equal(vec_equal(list(1:3, 1:2), list(1:3)), c(TRUE, FALSE)) expect_equal(vec_equal(list(1:3, 1.5), list(1:3)), c(TRUE, FALSE)) expect_equal(vec_equal(list(as.raw(1:3), as.raw(1.5)), list(as.raw(1:3))), c(TRUE, FALSE)) expect_equal(vec_equal(list(1+1i, 1+0i), list(1+1i)), c(TRUE, FALSE)) expect_equal(vec_equal(c(1, 2) + 1i, 1+1i), c(TRUE, FALSE)) }) test_that("NAs are equal", { expect_true(vec_equal(NA, NA, na_equal = TRUE)) expect_true(vec_equal(NA_integer_, NA_integer_, na_equal = TRUE)) expect_true(vec_equal(NA_real_, NA_real_, na_equal = TRUE)) expect_true(vec_equal(NA_character_, NA_character_, na_equal = TRUE)) expect_true(vec_equal(list(NULL), list(NULL), na_equal = TRUE)) }) test_that("double special values", { expect_equal(vec_equal(c(NaN, NA), NaN, na_equal = TRUE), c(TRUE, FALSE)) expect_equal(vec_equal(c(NA, NaN), NA, na_equal = TRUE), c(TRUE, FALSE)) expect_true(vec_equal(Inf, Inf)) expect_true(vec_equal(-Inf, -Inf)) }) test_that("`list(NULL)` is considered a missing value (#653)", { expect_equal(vec_equal(list(NULL), list(NULL)), NA) expect_equal(vec_equal(list(NULL), list(1)), NA) }) test_that("can compare data frames", { df <- data.frame(x = 1:2, y = letters[2:1], stringsAsFactors = FALSE) expect_equal(vec_equal(df, df[1, ]), c(TRUE, FALSE)) }) test_that("can compare data frames with various types of columns", { x1 <- data_frame(x = 1, y = 2) y1 <- data_frame(x = 2, y = 1) x2 <- data_frame(x = "a") y2 <- data_frame(x = "b") x3 <- data_frame(x = FALSE) y3 <- data_frame(x = TRUE) x4 <- data_frame(x = 1L) y4 <- data_frame(x = 2L) x5 <- data_frame(x = as.raw(0)) y5 <- data_frame(x = as.raw(1)) x6 <- data_frame(x = 1+0i) y6 <- data_frame(x = 1+1i) expect_false(vec_equal(x1, y1)) expect_false(vec_equal(x2, y2)) expect_false(vec_equal(x3, y3)) expect_false(vec_equal(x4, y4)) expect_false(vec_equal(x5, y5)) expect_false(vec_equal(x6, y6)) }) test_that("can compare data frames with data frame columns", { df1 <- data_frame(x = data_frame(a = 1)) df2 <- data_frame(x = data_frame(a = 2)) expect_true(vec_equal(df1, df1)) expect_false(vec_equal(df1, df2)) }) test_that("can compare data frames with list columns", { df1 <- data_frame(x = list(a = 1, b = 2), y = c(1, 1)) df2 <- data_frame(x = list(a = 0, b = 2), y = c(1, 1)) expect_equal(vec_equal(df1, df2), c(FALSE, TRUE)) }) test_that("data frames must have same size and columns", { expect_error(.Call(vctrs_equal, data.frame(x = 1), data.frame(x = 1, y = 2), TRUE ), "must have the same number of columns" ) # Names are not checked, as `vec_cast_common()` should take care of the type. # So if `vec_cast_common()` is not called, or is improperly specified, then # this could result in false equality. expect_true(.Call(vctrs_equal, data.frame(x = 1), data.frame(y = 1), TRUE )) expect_error(.Call(vctrs_equal, data.frame(x = 1:2, y = 3:4), data.frame(x = 1, y = 2), TRUE ), "must have same types and lengths" ) expect_false(.Call(vctrs_equal, data.frame(x = 1), data.frame(x = 2), TRUE )) expect_false(.Call(vctrs_equal, list(data.frame(x = 1)), list(10), TRUE )) }) test_that("can compare data frames with 0 columns", { x <- new_data_frame(n = 1L) expect_true(vec_equal(x, x)) }) test_that("can compare lists of scalars (#643)", { lst <- list(new_sclr(x = 1)) expect_true(vec_equal(lst, lst)) # NA does not propagate lst <- list(new_sclr(y = NA)) expect_true(vec_equal(lst, lst)) df <- data.frame(x = c(1, 4, 3), y = c(2, 8, 9)) model <- lm(y ~ x, df) lst <- list(model) expect_true(vec_equal(lst, lst)) }) test_that("can determine equality of strings with different encodings (#553)", { for (x_encoding in encodings()) { for (y_encoding in encodings()) { expect_equal(vec_equal(x_encoding, y_encoding), TRUE) expect_equal(vec_equal(x_encoding, y_encoding), x_encoding == y_encoding) } } }) test_that("equality can be determined when strings have identical encodings", { encs <- encodings(bytes = TRUE) for (enc in encs) { expect_true(vec_equal(enc, enc)) expect_equal(vec_equal(enc, enc), enc == enc) } }) test_that("equality is known to fail when comparing bytes to other encodings", { error <- "translating strings with \"bytes\" encoding" for (enc in encodings()) { expect_error(vec_equal(encoding_bytes(), enc), error) expect_error(vec_equal(enc, encoding_bytes()), error) } }) test_that("`na_equal` is validated", { expect_error(vec_equal(1, 1, na_equal = 1), class = "vctrs_error_assert_ptype") expect_error(vec_equal(1, 1, na_equal = c(TRUE, FALSE)), class = "vctrs_error_assert_size") }) test_that("can compare lists of expressions", { x <- list(expression(x), expression(y)) y <- list(expression(x)) expect_equal(vec_equal(x, y), c(TRUE, FALSE)) }) # object ------------------------------------------------------------------ test_that("can compare NULL",{ expect_true(obj_equal(NULL, NULL)) }) test_that("can compare objects with reference semantics", { expect_true(obj_equal(globalenv(), globalenv())) expect_false(obj_equal(globalenv(), environment())) expect_true(obj_equal(quote(x), quote(x))) expect_false(obj_equal(quote(x), quote(y))) }) test_that("can compare pairlists", { expect_true(obj_equal(quote(x + y), quote(x + y))) expect_true(obj_equal(pairlist(x = 1, y = 2), pairlist(x = 1, y = 2))) }) test_that("can compare functions", { f1 <- function(x, y) x + y f2 <- function(x, y) x + y expect_false(obj_equal(f2, f1)) attr(f1, "srcref") <- NULL attr(f2, "srcref") <- NULL expect_true(obj_equal(f2, f1)) f3 <- f1 formals(f3) <- alist(x = 1) expect_false(obj_equal(f3, f1)) f4 <- f1 body(f4) <- quote(x) expect_false(obj_equal(f4, f2)) }) test_that("not equal if different types or lengths", { expect_false(obj_equal(1, 2)) expect_false(obj_equal(1:2, 1)) }) test_that("not equal if attributes not equal", { x1 <- structure(1:10, x = 1, y = 2) x2 <- structure(1:10, x = 1, y = 3) expect_false(obj_equal(x1, x2)) }) test_that("can compare expressions", { expect_true(obj_equal(expression(x), expression(x))) expect_false(obj_equal(expression(x), expression(y))) }) # na ---------------------------------------------------------------------- test_that("can detect different types of NA", { expect_true(vec_equal_na(NA)) expect_true(vec_equal_na(NA_integer_)) expect_true(vec_equal_na(NA_real_)) expect_true(vec_equal_na(NA_complex_)) expect_true(vec_equal_na(complex(real = NA, imaginary = 1))) expect_true(vec_equal_na(NaN)) expect_true(vec_equal_na(NA_character_)) expect_true(vec_equal_na(list(NULL))) }) test_that("vectorised over rows of a data frame", { df <- data.frame(x = c(1, 1, NA, NA), y = c(1, NA, 1, NA)) expect_equal(vec_equal_na(df), c(FALSE, FALSE, FALSE, TRUE)) }) test_that("works recursively with data frame columns", { df <- data.frame(x = c(1, 1, NA, NA)) df$df <- data.frame(y = c(NA, 1, 1, NA), z = c(1, NA, 1, NA)) expect_equal(vec_equal_na(df), c(FALSE, FALSE, FALSE, TRUE)) }) test_that("NA propagate symmetrically (#204)", { exp <- c(NA, NA) expect_identical(vec_equal(c(TRUE, FALSE), NA), exp) expect_identical(vec_equal(1:2, NA), exp) expect_identical(vec_equal(c(1, 2), NA), exp) expect_identical(vec_equal(letters[1:2], NA), exp) expect_identical(vec_equal(NA, c(TRUE, FALSE)), exp) expect_identical(vec_equal(NA, 1:2), exp) expect_identical(vec_equal(NA, c(1, 2)), exp) expect_identical(vec_equal(NA, letters[1:2]), exp) }) test_that("NA propagate from data frames columns", { x <- data.frame(x = 1:3) y <- data.frame(x = c(1L, NA, 2L)) expect_identical(vec_equal(x, y), c(TRUE, NA, FALSE)) expect_identical(vec_equal(y, x), c(TRUE, NA, FALSE)) expect_identical(vec_equal(x, y, na_equal = TRUE), c(TRUE, FALSE, FALSE)) expect_identical(vec_equal(y, x, na_equal = TRUE), c(TRUE, FALSE, FALSE)) x <- data.frame(x = 1:3, y = 1:3) y <- data.frame(x = c(1L, NA, 2L), y = c(NA, 2L, 3L)) expect_identical(vec_equal(x, y), c(NA, NA, FALSE)) expect_identical(vec_equal(y, x), c(NA, NA, FALSE)) expect_identical(vec_equal(x, y, na_equal = TRUE), c(FALSE, FALSE, FALSE)) expect_identical(vec_equal(y, x, na_equal = TRUE), c(FALSE, FALSE, FALSE)) }) test_that("NA do not propagate from list components (#662)", { expect_true(obj_equal(NA, NA)) expect_true(vec_equal(list(NA), list(NA))) }) test_that("NA do not propagate from names when comparing objects", { x <- set_names(1:3, c("a", "b", NA)) y <- set_names(1:3, c("a", NA, NA)) expect_true(obj_equal(x, x)) expect_false(obj_equal(x, y)) expect_equal(vec_equal(list(x, x, y), list(x, y, y)), c(TRUE, FALSE, TRUE)) }) test_that("NA do not propagate from attributes", { x <- structure(1:3, foo = NA) y <- structure(1:3, foo = "") expect_true(obj_equal(x, x)) expect_false(obj_equal(x, y)) }) test_that("NA do not propagate from function bodies or formals", { fn <- other <- function() NA body(other) <- TRUE expect_true(vec_equal(list(fn), list(fn))) expect_false(vec_equal(list(fn), list(other))) expect_true(obj_equal(fn, fn)) expect_false(obj_equal(fn, other)) fn <- other <- function(x = NA) NULL formals(other) <- list(x = NULL) expect_true(vec_equal(list(fn), list(fn))) expect_false(vec_equal(list(fn), list(other))) }) test_that("can check equality of unspecified objects", { expect_equal(vec_equal(NA, NA), NA) expect_true(vec_equal(NA, NA, na_equal = TRUE)) expect_equal(vec_equal(unspecified(1), unspecified(1)), NA) expect_true(vec_equal(unspecified(1), unspecified(1), na_equal = TRUE)) expect_equal(vec_equal(NA, unspecified(1)), NA) expect_true(vec_equal(NA, unspecified(1), na_equal = TRUE)) }) # proxy ------------------------------------------------------------------- test_that("vec_equal() takes vec_proxy() by default", { local_env_proxy() x <- new_proxy(1:3) y <- new_proxy(3:1) expect_identical(vec_equal(x, y), lgl(FALSE, TRUE, FALSE)) }) test_that("vec_equal() takes vec_proxy_equal() if implemented", { local_comparable_tuple() x <- tuple(1:3, 1:3) y <- tuple(1:3, 4:6) expect_identical(x == y, rep(TRUE, 3)) expect_identical(vec_equal(x, y), rep(TRUE, 3)) # Recursive case foo <- data_frame(x = x) bar <- data_frame(x = y) expect_identical(vec_equal(foo, bar), rep(TRUE, 3)) }) vctrs/tests/testthat/helper-s3.R0000644000176200001440000000742513622451540016354 0ustar liggesusers foobar <- function(x = list()) structure(x, class = "vctrs_foobar") unrownames <- function(x) { row.names(x) <- NULL x } local_methods <- function(..., .frame = caller_env()) { local_bindings(..., .env = global_env(), .frame = .frame) } local_proxy <- function(frame = caller_env()) { local_methods(.frame = frame, vec_proxy.vctrs_proxy = function(x, ...) proxy_deref(x), vec_restore.vctrs_proxy = function(x, to, ...) new_proxy(x), vec_ptype2.vctrs_proxy = function(x, y, ...) UseMethod("vec_ptype2.vctrs_proxy", y), vec_ptype2.vctrs_proxy.vctrs_proxy = function(x, y, ...) new_proxy(vec_ptype(proxy_deref(x))), vec_cast.vctrs_proxy = function(x, to, ...) UseMethod("vec_cast.vctrs_proxy"), vec_cast.vctrs_proxy.default = function(x, to, ...) stop_incompatible_cast(x, to), vec_cast.vctrs_proxy.vctrs_proxy = function(x, to, ...) x ) } new_proxy <- function(x) { structure(list(env(x = x)), class = "vctrs_proxy") } proxy_deref <- function(x) { x[[1]]$x } local_env_proxy <- function(frame = caller_env()) { local_methods(.frame = frame, vec_proxy.vctrs_proxy = proxy_deref, vec_restore.vctrs_proxy = function(x, ...) new_proxy(x) ) } local_no_stringsAsFactors <- function(frame = caller_env()) { local_options(.frame = frame, stringsAsFactors = FALSE) } tibble <- function(...) { tibble::tibble(...) } local_foobar_proxy <- function(frame = caller_env()) { local_methods(.frame = frame, vec_proxy.vctrs_foobar = identity) } subclass <- function(x) { class(x) <- c("vctrs_foo", "vctrs_foobar", class(x)) x } # Subclass promoted to logical new_lgl_subtype <- function(x) { stopifnot(is_logical(x)) structure(x, class = "vctrs_lgl_subtype") } local_lgl_subtype <- function(frame = caller_env()) { local_methods(.frame = frame, vec_ptype2.vctrs_lgl_subtype = function(x, y, ...) UseMethod("vec_ptype2.vctrs_lgl_subtype", y), vec_ptype2.vctrs_lgl_subtype.default = function(x, y, ...) vec_default_ptype2(x, y), vec_ptype2.vctrs_lgl_subtype.vctrs_lgl_subtype = function(x, y, ...) x, vec_ptype2.vctrs_lgl_subtype.logical = function(x, y, ...) y, vec_ptype2.logical.vctrs_lgl_subtype = function(x, y, ...) x, vec_cast.vctrs_lgl_subtype = function(x, to, ...) UseMethod("vec_cast.vctrs_lgl_subtype"), vec_cast.vctrs_lgl_subtype.default = function(x, to, ...) stop_incompatible_cast(x, to), vec_cast.vctrs_lgl_subtype.vctrs_lgl_subtype = function(x, to, ...) x, vec_cast.vctrs_lgl_subtype.logical = function(x, to, ...) new_lgl_subtype(x), vec_cast.logical.vctrs_lgl_subtype = function(x, to, ...) unstructure(x) ) } with_lgl_subtype <- function(expr) { local_lgl_subtype() expr } # Logical promoted to subclass new_lgl_supertype <- function(x) { stopifnot(is_logical(x)) structure(x, class = "vctrs_lgl_supertype") } local_lgl_supertype <- function(frame = caller_env()) { local_methods(.frame = frame, vec_ptype2.vctrs_lgl_supertype = function(x, y, ...) UseMethod("vec_ptype2.vctrs_lgl_supertype", y), vec_ptype2.vctrs_lgl_supertype.default = function(x, y, ...) vec_default_ptype2(x, y), vec_ptype2.vctrs_lgl_supertype.vctrs_lgl_supertype = function(x, y, ...) x, vec_ptype2.vctrs_lgl_supertype.logical = function(x, y, ...) x, vec_ptype2.logical.vctrs_lgl_supertype = function(x, y, ...) y, vec_cast.vctrs_lgl_supertype = function(x, to, ...) UseMethod("vec_cast.vctrs_lgl_supertype"), vec_cast.vctrs_lgl_supertype.default = function(x, to, ...) stop_incompatible_cast(x, to), vec_cast.vctrs_lgl_supertype.vctrs_lgl_supertype = function(x, to, ...) x, vec_cast.vctrs_lgl_supertype.logical = function(x, to, ...) new_lgl_subtype(x), vec_cast.logical.vctrs_lgl_supertype = function(x, to, ...) unstructure(x) ) } with_lgl_supertype <- function(expr) { local_lgl_supertype() expr } vctrs/tests/testthat/helper-rational.R0000644000176200001440000000410013622451540017623 0ustar liggesusers # Rational record class from the S3 vector vignette new_rational <- function(n = integer(), d = integer()) { vec_assert(n, ptype = integer()) vec_assert(d, ptype = integer()) new_rcrd(list(n = n, d = d), class = "vctrs_rational") } rational <- function(n, d) { args <- vec_cast_common(n, d, .to = integer()) args <- vec_recycle_common(!!! args) new_rational(args[[1L]], args[[2L]]) } format.vctrs_rational <- function(x, ...) { n <- field(x, "n") d <- field(x, "d") out <- paste0(n, "/", d) out[is.na(n) | is.na(d)] <- NA out } vec_proxy_equal.vctrs_rational <- function(x) { n <- field(x, "n") d <- field(x, "d") gcd <- gcd(n, d) data.frame(n = n / gcd, d = d / gcd) } gcd <- function(x, y) { r <- x %% y ifelse(r, gcd(y, r), y) } vec_proxy_compare.vctrs_rational <- function(x) { field(x, "n") / field(x, "d") } rational_methods <- list( vec_ptype_abbr.vctrs_rational = function(x, ...) "rtnl", vec_ptype_full.vctrs_rational = function(x, ...) "rational", vec_ptype2.vctrs_rational = function(x, y, ...) UseMethod("vec_ptype2.vctrs_rational", y), vec_ptype2.vctrs_rational.default = function(x, y, ...) vec_default_ptype2(x, y, ...), vec_ptype2.vctrs_rational.vctrs_rational = function(x, y, ...) new_rational(), vec_ptype2.vctrs_rational.integer = function(x, y, ...) new_rational(), vec_ptype2.integer.vctrs_rational = function(x, y, ...) new_rational(), vec_cast.vctrs_rational = function(x, to, ...) UseMethod("vec_cast.vctrs_rational"), vec_cast.vctrs_rational.default = function(x, to, ...) vec_default_cast(x, to), vec_cast.vctrs_rational.vctrs_rational = function(x, to, ...) x, vec_cast.double.vctrs_rational = function(x, to, ...) field(x, "n") / field(x, "d"), vec_cast.vctrs_rational.integer = function(x, to, ...) rational(x, 1), vec_proxy_equal.vctrs_rational = vec_proxy_equal.vctrs_rational, vec_proxy_compare.vctrs_rational = vec_proxy_compare.vctrs_rational ) local_rational_class <- function(frame = caller_env()) { local_methods(.frame = frame, !!!rational_methods) } env_bind(global_env(), !!!rational_methods) vctrs/tests/testthat/test-proxy-restore.R0000644000176200001440000000560013623013722020357 0ustar liggesusers test_that("default vec_restore() restores attributes except names", { to <- structure(NA, foo = "foo", bar = "bar") expect_identical(vec_restore.default(NA, to), structure(NA, foo = "foo", bar = "bar")) to <- structure(NA, names = "a", foo = "foo", bar = "bar") expect_identical(vec_restore.default(NA, to), structure(NA, foo = "foo", bar = "bar")) to <- structure(NA, foo = "foo", names = "a", bar = "bar") expect_identical(vec_restore.default(NA, to), structure(NA, foo = "foo", bar = "bar")) to <- structure(NA, foo = "foo", bar = "bar", names = "a") expect_identical(vec_restore.default(NA, to), structure(NA, foo = "foo", bar = "bar")) }) test_that("default vec_restore() restores objectness", { to <- structure(NA, class = "foo") x <- vec_restore.default(NA, to) expect_true(is.object(x)) expect_is(x, "foo") }) test_that("data frame vec_restore() checks type", { expect_error(vec_restore(NA, mtcars), "Attempt to restore data frame from a logical") }) test_that("can use vctrs primitives from vec_restore() without inflooping", { local_methods( vec_restore.vctrs_foobar = function(x, to, ...) { vec_ptype(x) vec_init(x) vec_assert(x) vec_slice(x, 0) "woot" } ) foobar <- new_vctr(1:3, class = "vctrs_foobar") expect_identical(vec_slice(foobar, 2), "woot") }) test_that("vec_restore() passes `n` argument to methods", { local_methods( vec_restore.vctrs_foobar = function(x, to, ..., n) n ) expect_identical(vec_slice(foobar(1:3), 2), 1L) }) test_that("dimensions are preserved by default restore method", { x <- foobar(1:4) dim(x) <- c(2, 2) dimnames(x) <- list(a = c("foo", "bar"), b = c("quux", "hunoz")) exp <- foobar(c(1L, 3L)) dim(exp) <- c(1, 2) dimnames(exp) <- list(a = "foo", b = c("quux", "hunoz")) expect_identical(vec_slice(x, 1), exp) }) test_that("names attribute isn't set when restoring 1D arrays using 2D+ objects", { x <- foobar(1:2) dim(x) <- c(2) nms <- c("foo", "bar") dimnames(x) <- list(nms) res <- vec_restore(x, matrix(1)) expect_null(attributes(res)$names) expect_equal(attr(res, "names"), nms) expect_equal(names(res), nms) }) test_that("arguments are not inlined in the dispatch call (#300)", { local_methods( vec_restore.vctrs_foobar = function(x, to, ..., n) sys.call(), vec_proxy.vctrs_foobar = unclass ) call <- vec_restore(foobar(list(1)), foobar(list(1))) expect_equal(call, quote(vec_restore.vctrs_foobar(x = x, to = to, n = n))) }) test_that("restoring to non-bare data frames calls `vec_bare_df_restore()` before dispatching", { x <- list(x = numeric()) to <- new_data_frame(x, class = "tbl_foobar") local_methods( vec_restore.tbl_foobar = function(x, to, ..., n) { if (is.data.frame(x)) { abort(class = "error_df_restore_was_called") } } ) expect_error(vec_restore(x, to), class = "error_df_restore_was_called") }) vctrs/tests/testthat/test-list_of-str.txt0000644000176200001440000000031213623022052020367 0ustar liggesuserslist [1:2] $ : num 1 $ : num [1:2] 2 3 @ ptype: num(0) List of 1 $ :List of 2 ..$ : list [1:2] .. ..$ : num 1 .. ..$ : num [1:2] 2 3 .. ..@ ptype: num(0) ..$ y: int [1:2] 2 1 vctrs/tests/testthat/test-type-sclr.R0000644000176200001440000000541313622451540017444 0ustar liggesuserscontext("test-type-sclr") test_that("sclr is a named list", { x <- new_sclr(x = 1, y = 2) expect_type(x, "list") expect_s3_class(x, "vctrs_sclr") expect_named(x, c("x", "y")) }) test_that("scalar must have unique names", { expect_error(new_sclr(x = 1, x = 2), "not TRUE") }) test_that("can get and set existing fields", { x <- new_sclr(x = 1, y = 2) x$x <- 3 expect_equal(x$x, 3) x[["y"]] <- 4 expect_equal(x[["y"]], 4) expect_error(x$z, "Invalid index") expect_error(x$z <- 1, "Invalid index") }) test_that("as.list strips attributes apart from names", { x <- new_sclr(x = 1, y = 2) y <- as.list(x) expect_type(y, "list") expect_equal(attributes(y), list(names = names(x))) }) test_that("as.data.frame works", { # #167: Not sure if this is the correct behavior. x <- new_sclr(x = 1, y = 2) expect_equal( as.data.frame(x, nm = "a"), new_data_frame(list(a = list(x))) ) }) test_that("putting in a data frame makes a list-col", { x <- new_sclr(x = 1, y = 2) df <- data.frame(x) expect_s3_class(df, "data.frame") expect_equal(df$x, list(x)) }) test_that("vector operations are unsupported", { x <- new_sclr(x = 1, y = 2) expect_error(x["a"], class = "vctrs_error_unsupported") expect_error(x["a"] <- 1, class = "vctrs_error_unsupported") expect_error(names(x) <- "x", class = "vctrs_error_unsupported") expect_error(dim(x) <- 1, class = "vctrs_error_unsupported") expect_error(dimnames(x) <- 1, class = "vctrs_error_unsupported") expect_error(levels(x) <- 1, class = "vctrs_error_unsupported") expect_error(is.na(x) <- 1, class = "vctrs_error_unsupported") expect_error(c(x), class = "vctrs_error_unsupported") expect_error(abs(x), class = "vctrs_error_unsupported") expect_error(x + 1, class = "vctrs_error_unsupported") expect_error(Arg(x), class = "vctrs_error_unsupported") expect_error(sum(x), class = "vctrs_error_unsupported") expect_error(order(x), class = "vctrs_error_unsupported") expect_error(levels(x), class = "vctrs_error_unsupported") expect_error(t(x), class = "vctrs_error_unsupported") expect_error(unique(x), class = "vctrs_error_unsupported") expect_error(duplicated(x), class = "vctrs_error_unsupported") expect_error(anyDuplicated(x), class = "vctrs_error_unsupported") expect_error(as.logical(x), class = "vctrs_error_unsupported") expect_error(as.integer(x), class = "vctrs_error_unsupported") expect_error(as.double(x), class = "vctrs_error_unsupported") expect_error(as.character(x), class = "vctrs_error_unsupported") expect_error(as.Date(x), class = "vctrs_error_unsupported") expect_error(as.POSIXct(x), class = "vctrs_error_unsupported") }) test_that("summary is unimplemented", { x <- new_sclr(x = 1, y = 2) expect_error(summary(x), class = "vctrs_error_unimplemented") }) vctrs/tests/testthat/test-dim.R0000644000176200001440000000131313622451540016266 0ustar liggesuserscontext("test-dim") # vec_dim ----------------------------------------------------------------- test_that("dim is dimensions", { expect_equal(vec_dim(array(dim = c(1))), c(1)) expect_equal(vec_dim(array(dim = c(1, 1))), c(1, 1)) expect_equal(vec_dim(array(dim = c(1, 1, 1))), c(1, 1, 1)) }) test_that("dim_n is number of dimensions", { expect_equal(vec_dim_n(array(dim = c(1))), 1) expect_equal(vec_dim_n(array(dim = c(1, 1))), 2) expect_equal(vec_dim_n(array(dim = c(1, 1, 1))), 3) }) test_that("vector and 1-d array are equivalent", { x1 <- 1:5 x2 <- array(x1) expect_equal(vec_dim(x1), 5) expect_equal(vec_dim(x2), 5) expect_equal(vec_size(x1), 5) expect_equal(vec_size(x2), 5) }) vctrs/tests/testthat/test-conditions.R0000644000176200001440000000373213622451540017675 0ustar liggesuserscontext("conditions") test_that("conditions inherit from `vctrs_error`", { expect_error(stop_incompatible(NULL, NULL), class = "vctrs_error") expect_error(stop_incompatible_type(NULL, NULL), class = "vctrs_error") expect_error(stop_incompatible_cast(NULL, NULL), class = "vctrs_error") expect_error(stop_incompatible_op("", NULL, NULL), class = "vctrs_error") expect_error(stop_incompatible_size(NULL, NULL, 0, 0), class = "vctrs_error") expect_error(maybe_lossy_cast(NULL, NULL, NULL, TRUE), class = "vctrs_error") expect_error(stop_unsupported("", ""), class = "vctrs_error") expect_error(stop_unimplemented("", ""), class = "vctrs_error") expect_error(stop_scalar_type(NULL), class = "vctrs_error") expect_error(stop_names("", NULL, 1), class = "vctrs_error") expect_error(stop_names_cannot_be_empty(1), class = "vctrs_error") expect_error(stop_names_cannot_be_dot_dot(1), class = "vctrs_error") expect_error(stop_names_must_be_unique(1), class = "vctrs_error") }) test_that("can override arg in OOB conditions", { verify_errors({ expect_error( with_subscript_data( vec_slice(set_names(letters), "foo"), NULL ), class = "vctrs_error_subscript_oob" ) expect_error( with_subscript_data( vec_slice(set_names(letters), "foo"), quote(foo) ), class = "vctrs_error_subscript_oob" ) expect_error( with_subscript_data( vec_slice(set_names(letters), "foo"), quote(foo(bar)) ), class = "vctrs_error_subscript_oob" ) }) }) verify_output(test_path("error", "test-conditions.txt"), { "# can override arg in OOB conditions" with_subscript_data( vec_slice(set_names(letters), "foo"), NULL ) with_subscript_data( vec_slice(set_names(letters), "foo"), "input" ) with_subscript_data( vec_slice(set_names(letters), "foo"), quote(input) ) with_subscript_data( vec_slice(set_names(letters), "foo"), quote(input[i]) ) }) vctrs/tests/testthat/test-dictionary.R0000644000176200001440000001726213622451540017674 0ustar liggesuserscontext("test-dictionary") # counting ---------------------------------------------------------------- test_that("vec_count counts number observations", { x <- vec_count(rep(1:3, 1:3), sort = "key") expect_equal(x, data.frame(key = 1:3, count = 1:3)) }) test_that("vec_count works with matrices", { x <- matrix(c(1, 1, 1, 2, 2, 1), c(3, 2)) out <- vec_count(x) exp <- data_frame(key = c(NA, NA), count = int(2L, 1L)) exp$key <- vec_slice(x, c(1, 3)) expect_identical(out, exp) }) test_that("vec_count works with arrays", { x <- array(c(rep(1, 3), rep(2, 3)), dim = c(3, 2, 1)) expect <- data.frame(key = NA, count = 3) expect$key <- vec_slice(x, 1L) expect_equal(vec_count(x), expect) }) test_that("vec_count works for zero-length input", { x <- vec_count(integer(), sort = "none") expect_equal(x, data.frame(key = integer(), count = integer())) }) test_that("vec_count works with different encodings", { x <- vec_count(encodings()) expect_equal(x, new_data_frame(list(key = encodings()[1], count = 3L))) }) test_that("vec_count recursively takes the equality proxy", { local_comparable_tuple() x <- tuple(c(1, 1, 2), 1:3) df <- data_frame(x = x) expect <- data_frame(key = vec_slice(df, c(1, 3)), count = c(2L, 1L)) expect_equal(vec_count(df), expect) }) # duplicates and uniques -------------------------------------------------- test_that("vec_duplicated reports on duplicates regardless of position", { x <- c(1, 1, 2, 3, 4, 4) expect_equal(vec_duplicate_detect(x), c(TRUE, TRUE, FALSE, FALSE, TRUE, TRUE)) }) test_that("vec_duplicate_any returns single TRUE/FALSE", { expect_false(vec_duplicate_any(c(1:10))) expect_true(vec_duplicate_any(c(1:10, 1))) }) test_that("vec_duplicate_id gives position of first found", { x <- c(1, 2, 3, 1, 4) expect_equal(vec_duplicate_id(x), c(1, 2, 3, 1, 5)) }) test_that("vec_unique matches unique", { x <- sample(100, 1000, replace = TRUE) expect_equal(vec_unique(x), unique(x)) }) test_that("vec_unique matches unique for matrices", { x <- matrix(c(1, 1, 2, 2), ncol = 2) expect_equal(vec_unique(x), unique(x)) }) test_that("vec_unique_count matches length + unique", { x <- sample(100, 1000, replace = TRUE) expect_equal(vec_unique_count(x), length(unique(x))) }) test_that("also works for data frames", { df <- data.frame(x = 1:3, y = letters[3:1], stringsAsFactors = FALSE) idx <- c(1L, 1L, 1L, 2L, 2L, 3L) df2 <- df[idx, , drop = FALSE] rownames(df2) <- NULL expect_equal(vec_duplicate_detect(df2), vec_duplicate_detect(idx)) expect_equal(vec_unique(df2), vec_slice(df, vec_unique(idx))) count <- vec_count(df2, sort = "key") expect_equal(count$key, df) expect_equal(count$count, vec_count(idx)$count) exp <- tibble(x = c(1, 1, 2), y = c(1, 2, 3)) expect_identical(vec_unique(vec_slice(exp, c(1, 1, 2, 3))), exp) }) test_that("vec_unique() handles matrices (#327)", { x <- matrix(c(1, 2, 3, 4), c(2, 2)) y <- matrix(c(1, 2, 3, 5), c(2, 2)) expect_identical(vec_unique(list(x, x)), list(x)) expect_identical(vec_unique(list(x, y)), list(x, y)) x <- matrix(c(1, 2, 1, 1, 2, 1), nrow = 3) expect_identical(vec_unique(x), vec_slice(x, 1:2)) }) test_that("vec_unique() works with 1D arrays", { # 1D arrays are dispatched to `as.data.frame.vector()` which # currently does not strip dimensions. This caused an infinite # recursion. expect_identical(vec_unique(array(1:2)), array(1:2)) x <- new_vctr(c(1, 1, 1, 2, 1, 2), dim = c(3, 2)) expect_identical(vec_unique(x), new_vctr(c(1, 1, 2, 1), dim = c(2, 2))) }) test_that("unique functions take the equality proxy (#375)", { local_comparable_tuple() x <- tuple(c(1, 2, 1), 1:3) expect_true(vec_in(tuple(2, 100), x)) expect_identical(vec_match(tuple(2, 100), x), 2L) }) test_that("unique functions take the equality proxy recursively", { local_comparable_tuple() x <- tuple(c(1, 1, 2), 1:3) df <- data_frame(x = x) expect_equal(vec_unique(df), vec_slice(df, c(1, 3))) expect_equal(vec_unique_count(df), 2L) expect_equal(vec_unique_loc(df), c(1, 3)) }) test_that("duplicate functions take the equality proxy recursively", { local_comparable_tuple() x <- tuple(c(1, 1, 2), 1:3) df <- data_frame(x = x) expect_equal(vec_duplicate_any(df), TRUE) expect_equal(vec_duplicate_detect(df), c(TRUE, TRUE, FALSE)) expect_equal(vec_duplicate_id(df), c(1, 1, 3)) }) test_that("unique functions treat positive and negative 0 as equivalent (#637)", { expect_equal(vec_unique(c(0, -0)), 0) expect_equal(vec_unique_count(c(0, -0)), 1) expect_equal(vec_unique_loc(c(0, -0)), 1) }) test_that("unique functions work with different encodings", { encs <- encodings() expect_equal(vec_unique(encs), encs[1]) expect_equal(vec_unique_count(encs), 1L) expect_equal(vec_unique_loc(encs), 1L) }) test_that("unique functions can handle scalar types in lists", { x <- list(x = a ~ b, y = a ~ b, z = a ~ c) expect_equal(vec_unique(x), vec_slice(x, c(1, 3))) x <- list(x = call("x"), y = call("y"), z = call("x")) expect_equal(vec_unique(x), vec_slice(x, c(1, 2))) }) test_that("duplicate functions works with different encodings", { encs <- encodings() expect_equal(vec_duplicate_id(encs), rep(1, 3)) expect_equal(vec_duplicate_detect(encs), rep(TRUE, 3)) expect_equal(vec_duplicate_any(encs), TRUE) }) test_that("vec_unique() returns differently encoded strings in the order they appear", { encs <- encodings() x <- c(encs$unknown, encs$utf8) y <- c(encs$utf8, encs$unknown) expect_equal_encoding(vec_unique(x), encs$unknown) expect_equal_encoding(vec_unique(y), encs$utf8) }) test_that("vec_unique() works on lists containing expressions", { x <- list(expression(x), expression(y), expression(x)) expect_equal(vec_unique(x), x[1:2]) }) test_that("vec_unique() works with glm objects (#643)", { # class(model$family$initialize) == "expression" model <- glm(mpg ~ wt, data = mtcars) expect_equal(vec_unique(list(model, model)), list(model)) }) # matching ---------------------------------------------------------------- test_that("vec_match() matches match()", { n <- c(1:3, NA) h <- c(4, 2, 1, NA) expect_equal(vec_match(n, h), match(n, h)) }) test_that("vec_in() matches %in%", { n <- c(1:3, NA) h <- c(4, 2, 1, NA) expect_equal(vec_in(n, h), n %in% h) }) test_that("vec_match works with empty data frame", { out <- vec_match( new_data_frame(n = 3L), new_data_frame(n = 0L) ) expect_equal(out, vec_init(integer(), 3)) }) test_that("matching functions take the equality proxy (#375)", { local_comparable_tuple() x <- tuple(c(1, 2, 1), 1:3) expect_identical(vec_unique_loc(x), 1:2) expect_identical(unique(x), tuple(c(1, 2), 1:2)) expect_true(vec_duplicate_any(x)) expect_identical(vec_duplicate_id(x), c(1L, 2L, 1L)) expect_identical(vec_unique_count(x), 2L) expect_identical(vec_duplicate_detect(x), c(TRUE, FALSE, TRUE)) }) test_that("can take the unique loc of 1d arrays (#461)", { x <- array(c(1, 1, 2, 2, 3)) y <- array(c(1, 1, 2, 2, 3), dimnames = list(NULL)) expect_identical(vctrs::vec_unique_loc(x), int(1, 3, 5)) expect_identical(vctrs::vec_unique_loc(y), int(1, 3, 5)) z <- array(c(1, 1, 2, 2, 3, 4), c(3, 2)) expect_silent(expect_identical(vctrs::vec_unique_loc(y), int(1, 3, 5))) }) test_that("matching functions work with different encodings", { encs <- encodings() expect_equal(vec_match(encs, encs[1]), rep(1, 3)) expect_equal(vec_in(encs, encs[1]), rep(TRUE, 3)) }) test_that("matching functions take the equality proxy recursively", { local_comparable_tuple() x <- tuple(c(1, 2), 1:2) df <- data_frame(x = x) y <- tuple(c(2, 3), c(3, 3)) df2 <- data_frame(x = y) expect_equal(vec_match(df, df2), c(NA, 1)) expect_equal(vec_in(df, df2), c(FALSE, TRUE)) }) vctrs/tests/testthat/test-fields.R0000644000176200001440000000450313622451540016767 0ustar liggesuserscontext("test-fields") test_that("n_fields captures number of fields", { r <- new_rcrd(list(x = 1, y = 2)) expect_equal(n_fields(r), 2) }) # get --------------------------------------------------------------------- test_that("can extract valid field", { r <- new_rcrd(list(x = 1, y = 2)) expect_equal(field(r, "x"), 1) expect_equal(field(r, 1L), 1) }) test_that("can extract field even if encoding is different", { x1 <- "fa\u00e7ile" skip_if_not(Encoding(x1) == "UTF-8") x2 <- iconv(x1, from = "UTF-8", to = "latin1") skip_if_not(Encoding(x2) == "latin1") r <- new_rcrd(setNames(list(1), x1)) expect_equal(field(r, x1), 1) expect_equal(field(r, x2), 1) }) test_that("invalid indices throw error", { r <- new_rcrd(list(x = 1, y = 2)) expect_error(field(r, "z"), "Invalid index") expect_error(field(r, NA_character_), "Invalid index") expect_error(field(r, ""), "Invalid index") expect_error(field(r, letters), "Invalid index") expect_error(field(r, 0L), "Invalid index") expect_error(field(r, NA_integer_), "Invalid index") expect_error(field(r, 0), "Invalid index") expect_error(field(r, NA_real_), "Invalid index") expect_error(field(r, Inf), "Invalid index") expect_error(field(r, mean), "Invalid index") }) test_that("corrupt rcrd throws error", { r <- new_rcrd(list(x = 1, y = 2)) expect_error(field(1:10, 1L), "Corrupt rcrd") expect_error(field(list(), 1L), "Corrupt rcrd") expect_error(field(list(1), "x"), "Corrupt x") expect_error(field(setNames(list(1, 1), "y"), "x"), "Corrupt x") }) # set --------------------------------------------------------------------- test_that("field<- modifies a copy", { r1 <- new_rcrd(list(x = 1, y = 2)) r2 <- r1 field(r1, "x") <- 3 expect_equal(field(r1, "x"), 3) expect_equal(field(r2, "x"), 1) }) test_that("field<- checks inputs", { x <- list() expect_error(field(x, "x") <- 1, "Corrupt rcrd") r <- new_rcrd(list(x = 1)) expect_error(field(r, "x") <- 1:3, "Invalid value") expect_error(field(r, "x") <- environment(), "Invalid value") }) test_that("field<- respects size, not length (#450)", { r1 <- new_rcrd(list(df = new_data_frame(n = 2L))) new_df <- data.frame(x = 1:2) field(r1, 'df') <- new_df expect_equal(field(r1, "df"), new_df) expect_error(field(r1, 'df') <- new_data_frame(n = 3L), "Invalid value") }) vctrs/tests/testthat/test-type2-error-messages.txt0000644000176200001440000000031413623022060022122 0ustar liggesusersBare objects: vec_ptype2("foo", 10): No common type for `x` and `y` . Nested dataframes: vec_ptype2(df1, df2): No common type for `x$x$y$z` and `y$x$y$z` . vctrs/tests/testthat/test-type-rcrd.R0000644000176200001440000001277313622451540017442 0ustar liggesuserscontext("test-type-rcrd") # constructor and accessors ----------------------------------------------- test_that("can construct and access components", { r <- new_rcrd(list(x = 1, y = 2)) expect_equal(length(r), 1) expect_equal(n_fields(r), 2) expect_equal(names(r), NULL) expect_equal(fields(r), c("x", "y")) expect_error(r$x, class = "vctrs_error_unsupported") expect_equal(field(r, "x"), 1) }) test_that("requires format method", { x <- new_rcrd(list(x = 1)) expect_error(format(x), class = "vctrs_error_unimplemented") }) test_that("vec_proxy() transforms records to data frames", { expect_identical( vec_proxy(new_rcrd(list(a = "1"))), new_data_frame(list(a = "1")) ) }) # coercion ---------------------------------------------------------------- test_that("can cast list to rcrd", { l <- list( new_rcrd(list(a = "1", b = 3L)), new_rcrd(list(b = "4", a = 2)) ) expect_equal( vec_cast(l, new_rcrd(list(a = 1L, b = 2L))), new_rcrd(list(a = 1:2, b = 3:4)) ) }) test_that("can recast rcrd from list", { r <- new_rcrd(list(x = integer(), y = numeric())) expect_equal( vec_restore(list(x = 1L, y = 1), r), new_rcrd(list(x = 1L, y = 1)) ) }) test_that("can cast rcrd to list", { r <- new_rcrd(list(x = 1:2, y = 2:3)) expect_identical( vec_cast(r, list()), list( new_rcrd(list(x = 1L, y = 2L)), new_rcrd(list(x = 2L, y = 3L)) ) ) expect_identical( vec_cast(r, list()), as.list(r) ) }) test_that("default casts are implemented correctly", { r <- new_rcrd(list(x = 1, y = 1)) expect_error(vec_cast(1, r), error = "vctrs_error_incompatible_cast") expect_equal(vec_cast(NULL, r), NULL) }) test_that("can't cast incompatible rcrd", { expect_error( vec_cast( new_rcrd(list(a = "1", b = 3L)), new_rcrd(list(a = "1")) ), class = "vctrs_error_incompatible_cast" ) expect_error( vec_cast( new_rcrd(list(a = "1", b = 3L)), new_rcrd(list(a = "1", c = 3L)) ), class = "vctrs_error_incompatible_cast" ) expect_lossy( vec_cast( new_rcrd(list(a = "a", b = 3L)), new_rcrd(list(a = 1, b = 3L)) ), new_rcrd(list(a = na_dbl, b = 3L)), chr(), dbl() ) }) # invalid inputs ------------------------------------------------------------ test_that("must be list of equal length vectors", { expect_error(new_rcrd(list()), "list of length 1") expect_error(new_rcrd(list(x = environment())), "vector") expect_error(new_rcrd(list(x = 1, y = 1:2)), "same length") }) test_that("names must be unique", { expect_error(new_rcrd(list(1, 2)), "unique names") expect_error(new_rcrd(list(x = 1, 2)), "unique names") expect_error(new_rcrd(list(x = 1, x = 2)), "unique names") expect_error(new_rcrd(setNames(list(1, 2), "x")), "unique names") }) test_that("no attributes", { x <- structure(list(x = 1:3), y = 1) expect_error(new_rcrd(x), "no attributes") }) test_that("subset assignment throws error", { x <- new_rcrd(list(x = 1)) expect_error( x$y <- 2, class = "vctrs_error_unsupported" ) }) # tuple class ---------------------------------------------------------- # use simple class to test essential features of rcrds test_that("print and str use format", { local_tuple_methods() r <- tuple(1, 1:100) expect_known_output( file = test_path("test-rcrd-format.txt"), { print(r) cat("\n") str(r[1:10]) cat("\n") str(list(list(list(r, 1:100)))) } ) }) test_that("subsetting methods applied to each field", { local_tuple_methods() x <- tuple(1:2, 1) expect_equal(x[1], tuple(1, 1)) expect_equal(x[[1]], tuple(1, 1)) expect_equal(rep(tuple(1, 1), 2), tuple(c(1, 1), 1)) length(x) <- 1 expect_equal(x, tuple(1, 1)) }) test_that("subset assignment modifies each field", { local_tuple_methods() x <- tuple(c(1, 1), c(2, 2)) x[[1]] <- tuple(3, 3) expect_equal(x, tuple(c(3, 1), c(3, 2))) x[1] <- tuple(4, 4) expect_equal(x, tuple(c(4, 1), c(4, 2))) }) test_that("subset assignment recycles", { local_tuple_methods() x <- tuple(c(1, 1), c(2, 2)) x[1:2] <- tuple(1, 1) expect_equal(x, tuple(c(1, 1), c(1, 1))) x[] <- tuple(2, 2) expect_equal(x, tuple(c(2, 2), c(2, 2))) }) test_that("can sort rcrd", { local_tuple_methods() x <- tuple(c(1, 2, 1), c(3, 1, 2)) expect_equal(xtfrm(x), c(2, 3, 1)) expect_equal(order(x), c(3, 1, 2)) expect_equal(sort(x), tuple(c(1, 1, 2), c(2, 3, 1))) }) test_that("can use dictionary methods on a rcrd", { local_tuple_methods() x <- tuple(c(1, 2, 1), c(3, 1, 3)) expect_equal(unique(x), x[1:2]) expect_equal(duplicated(x), c(FALSE, FALSE, TRUE)) expect_equal(anyDuplicated(x), TRUE) }) test_that("can round trip through list", { local_tuple_methods() t <- tuple(1:2, 3:4) l <- expect_equal(vec_cast(t, list()), list(tuple(1, 3), tuple(2, 4))) expect_equal(vec_cast(l, t), t) }) test_that("dangerous methods marked as unimplemented", { local_tuple_methods() t <- tuple() expect_error(mean(t), class = "vctrs_error_unsupported") expect_error(abs(t), class = "vctrs_error_unsupported") expect_error(is.finite(t), class = "vctrs_error_unsupported") expect_error(is.nan(t), class = "vctrs_error_unsupported") }) # slicing ----------------------------------------------------------------- test_that("dots are forwarded", { expect_error(new_rcrd(list(foo = "foo"))[1, 2], "incorrect number of dimensions") }) test_that("records are restored after slicing the proxy", { expect_identical(new_rcrd(list(x = 1:2))[1], new_rcrd(list(x = 1L))) }) vctrs/tests/testthat/test-type-date-time.R0000644000176200001440000002666113622451540020362 0ustar liggesuserscontext("test-type-date-time") test_that("date-times have informative types", { expect_equal(vec_ptype_abbr(Sys.Date()), "date") expect_equal(vec_ptype_full(Sys.Date()), "date") expect_equal(vec_ptype_abbr(Sys.time()), "dttm") expect_equal(vec_ptype_full(Sys.time()), "datetime") expect_equal(vec_ptype_abbr(new_duration(10)), "drtn") expect_equal(vec_ptype_full(new_duration(10)), "duration") }) test_that("vec_ptype() returns a double date for integer dates", { x <- structure(0L, class = "Date") expect_true(is.double(vec_ptype(x))) }) test_that("dates and times are vectors", { expect_true(vec_is(Sys.Date())) expect_true(vec_is(as.POSIXct("2020-01-01"))) expect_true(vec_is(as.POSIXlt("2020-01-01"))) }) test_that("vec_c() converts POSIXct with int representation to double representation (#540)", { time1 <- seq(as.POSIXct("2015-12-01", tz = "UTC"), length.out = 2, by = "days") time2 <- vec_c(time1) expect_true(is.double(time2)) time3 <- vec_c(time1, time1) expect_true(is.double(time3)) }) test_that("vec_c() and vec_rbind() convert Dates with int representation to double representation (#396)", { x <- structure(0L, class = "Date") df <- data.frame(x = x) expect_true(is.double(vec_c(x))) expect_true(is.double(vec_c(x, x))) expect_true(is.double(vec_rbind(df)$x)) expect_true(is.double(vec_rbind(df, df)$x)) }) test_that("vec_proxy() returns a double for Dates with int representation", { x <- structure(0L, class = "Date") expect_true(is.double(vec_proxy(x))) }) # coerce ------------------------------------------------------------------ test_that("datetime coercions are symmetric and unchanging", { types <- list( new_date(), new_datetime(), new_datetime(tzone = "US/Central"), as.POSIXlt(character(), tz = "US/Central"), difftime(Sys.time() + 1000, Sys.time()), difftime(Sys.time() + 1, Sys.time()) ) mat <- maxtype_mat(types) expect_true(isSymmetric(mat)) expect_known_output( mat, test_path("test-type-date-time.txt"), print = TRUE, width = 200 ) }) test_that("tz comes from first non-empty", { # On the assumption that if you've set the time zone explicitly it # should win x <- as.POSIXct("2020-01-01") y <- as.POSIXct("2020-01-01", tz = "America/New_York") expect_equal(vec_ptype2(x, y), y[0]) expect_equal(vec_ptype2(y, x), y[0]) z <- as.POSIXct("2020-01-01", tz = "Pacific/Auckland") expect_equal(vec_ptype2(y, z), y[0]) expect_equal(vec_ptype2(z, y), z[0]) }) test_that("POSIXlt always steered towards POSIXct", { dtc <- as.POSIXct("2020-01-01") dtl <- as.POSIXlt("2020-01-01") expect_equal(vec_ptype2(dtc, dtl), dtc[0]) expect_equal(vec_ptype2(dtl, dtc), dtc[0]) expect_equal(vec_ptype2(dtl, dtl), dtc[0]) }) test_that("vec_ptype2() on a POSIXlt with multiple time zones returns the first", { x <- as.POSIXlt(new_datetime(), tz = "Pacific/Auckland") expect_identical(attr(x, "tzone"), c("Pacific/Auckland", "NZST", "NZDT")) expect_identical(attr(vec_ptype2(x, new_date()), "tzone"), "Pacific/Auckland") }) test_that("vec_ptype2(, NA) is symmetric (#687)", { date <- new_date() expect_identical( vec_ptype2(date, NA), vec_ptype2(NA, date) ) }) test_that("vec_ptype2(, NA) is symmetric (#687)", { time <- Sys.time() expect_identical( vec_ptype2(time, NA), vec_ptype2(NA, time) ) }) test_that("vec_ptype2(, NA) is symmetric (#687)", { dtime <- Sys.time() - Sys.time() expect_identical( vec_ptype2(dtime, NA), vec_ptype2(NA, dtime) ) }) # cast: dates --------------------------------------------------------------- test_that("safe casts work as expected", { date <- as.Date("2018-01-01") expect_equal(vec_cast(NULL, date), NULL) expect_equal(vec_cast(17532, date), date) expect_equal(vec_cast("2018-01-01", date), date) expect_equal(vec_cast(date, date), date) expect_equal(vec_cast(as.POSIXct(date), date), date) expect_equal(vec_cast(list(date), date), date) }) test_that("lossy casts generate error", { date <- as.Date("2018-01-01") datetime <- as.POSIXct(date) + c(0, 3600) expect_lossy(vec_cast(datetime, date), vec_c(date, date), x = datetime, to = date) }) test_that("invalid casts generate error", { date <- as.Date("2018-01-01") expect_error(vec_cast(integer(), date), class = "vctrs_error_incompatible_cast") }) test_that("can cast NA and unspecified to Date", { expect_identical(vec_cast(NA, new_date()), new_date(NA_real_)) expect_identical(vec_cast(unspecified(2), new_date()), new_date(dbl(NA, NA))) }) test_that("casting an integer date to another date returns a double date", { x <- structure(0L, class = "Date") expect_true(is.double(vec_cast(x, x))) }) # cast: datetimes ----------------------------------------------------------- test_that("safe casts work as expected", { datetime_c <- as.POSIXct("1970-02-01", tz = "UTC") datetime_l <- as.POSIXlt("1970-02-01", tz = "UTC") expect_equal(vec_cast(NULL, datetime_c), NULL) expect_equal(vec_cast(2678400, datetime_c), datetime_c) expect_equal(vec_cast("1970-02-01", datetime_c), datetime_c) expect_equal(vec_cast(datetime_c, datetime_c), datetime_c) expect_equal(vec_cast(datetime_l, datetime_c), datetime_c) expect_equal(vec_cast(as.Date(datetime_c), datetime_c), datetime_c) expect_equal(vec_cast(list(datetime_c), datetime_c), datetime_c) expect_equal(vec_cast(NULL, datetime_l), NULL) expect_equal(vec_cast(2678400, datetime_l), datetime_l) expect_equal(vec_cast("1970-02-01", datetime_l), datetime_l) expect_equal(vec_cast(datetime_c, datetime_l), datetime_l) expect_equal(vec_cast(datetime_l, datetime_l), datetime_l) expect_equal(vec_cast(as.Date(datetime_l), datetime_l), datetime_l) expect_equal(vec_cast(list(datetime_l), datetime_l), datetime_l) expect_error(vec_cast(raw(), datetime_l), class = "vctrs_error_incompatible_cast") }) test_that("invalid casts generate error", { datetime <- as.POSIXct("1970-02-01", tz = "UTC") expect_error(vec_cast(integer(), datetime), class = "vctrs_error_incompatible_cast") }) test_that("dates become midnight in date-time tzone", { date1 <- as.Date("2010-01-01") datetime_c <- as.POSIXct(character(), tz = "Pacific/Auckland") datetime_l <- as.POSIXlt(character(), tz = "Pacific/Auckland") date2_c <- vec_cast(date1, datetime_c) expect_equal(tzone(date2_c), "Pacific/Auckland") expect_equal(format(date2_c, "%H:%M"), "00:00") date2_l <- vec_cast(date1, datetime_l) expect_equal(tzone(date2_l), "Pacific/Auckland") expect_equal(format(date2_l, "%H:%M"), "00:00") }) test_that("can cast NA and unspecified to POSIXct and POSIXlt", { dtc <- as.POSIXct("2020-01-01") dtl <- as.POSIXlt("2020-01-01") expect_identical(vec_cast(NA, dtc), vec_init(dtc)) expect_identical(vec_cast(NA, dtl), vec_init(dtl)) expect_identical(vec_cast(unspecified(2), dtc), vec_init(dtc, 2)) expect_identical(vec_cast(unspecified(2), dtl), vec_init(dtl, 2)) }) # cast: durations ------------------------------------------------------------ test_that("safe casts work as expected", { dt1 <- as.difftime(600, units = "secs") dt2 <- as.difftime(10, units = "mins") expect_equal(vec_cast(NULL, dt1), NULL) expect_equal(vec_cast(600, dt1), dt1) expect_equal(vec_cast(dt1, dt1), dt1) expect_equal(vec_cast(dt1, dt2), dt2) expect_equal(vec_cast(list(dt1), dt1), dt1) }) test_that("invalid casts generate error", { dt <- as.difftime(600, units = "secs") expect_error(vec_cast(integer(), dt), class = "vctrs_error_incompatible_cast") }) test_that("can cast NA and unspecified to duration", { expect_identical(vec_cast(NA, new_duration()), new_duration(na_dbl)) expect_identical(vec_cast(unspecified(2), new_duration()), new_duration(dbl(NA, NA))) }) # arithmetic -------------------------------------------------------------- test_that("default is error", { d <- as.Date("2018-01-01") dt <- as.POSIXct("2018-01-02 12:00") t <- as.difftime(12, units = "hours") f <- factor("x") expect_error(vec_arith("+", d, f), class = "vctrs_error_incompatible_op") expect_error(vec_arith("+", dt, f), class = "vctrs_error_incompatible_op") expect_error(vec_arith("+", t, f), class = "vctrs_error_incompatible_op") expect_error(vec_arith("*", dt, t), class = "vctrs_error_incompatible_op") expect_error(vec_arith("*", d, t), class = "vctrs_error_incompatible_op") expect_error(vec_arith("!", t, MISSING()), class = "vctrs_error_incompatible_op") }) test_that("date-time vs date-time", { d <- as.Date("2018-01-01") dt <- as.POSIXct(d) expect_error(vec_arith("+", d, d), class = "vctrs_error_incompatible_op") expect_equal(vec_arith("-", d, d), d - d) expect_error(vec_arith("+", d, dt), class = "vctrs_error_incompatible_op") expect_equal(vec_arith("-", d, dt), difftime(d, dt)) expect_error(vec_arith("+", dt, d), class = "vctrs_error_incompatible_op") expect_equal(vec_arith("-", dt, d), difftime(dt, d)) expect_error(vec_arith("+", dt, dt), class = "vctrs_error_incompatible_op") expect_equal(vec_arith("-", dt, dt), dt - dt) }) test_that("date-time vs numeric", { d <- as.Date("2018-01-01") dt <- as.POSIXct(d) expect_equal(vec_arith("+", d, 1), d + 1) expect_equal(vec_arith("+", 1, d), d + 1) expect_equal(vec_arith("-", d, 1), d - 1) expect_error(vec_arith("-", 1, d), class = "vctrs_error_incompatible_op") expect_error(vec_arith("*", 1, d), class = "vctrs_error_incompatible_op") expect_error(vec_arith("*", d, 1), class = "vctrs_error_incompatible_op") }) test_that("date-time vs difftime", { d <- as.Date("2018-01-01") dt <- as.POSIXct(d) t <- as.difftime(1, units = "days") th <- as.difftime(c(1, 24), units = "hours") expect_equal(vec_arith("+", dt, t), dt + t) expect_equal(vec_arith("+", d, t), d + t) expect_equal(vec_arith("+", dt, th), dt + th) expect_lossy(vec_arith("+", d, th), d + th, x = t, to = d) expect_equal(vec_arith("-", dt, t), dt - t) expect_equal(vec_arith("-", d, t), d - t) expect_equal(vec_arith("-", dt, th), dt - th) expect_lossy(vec_arith("-", d, th), d - th, x = t, to = d) expect_equal(vec_arith("+", t, dt), dt + t) expect_equal(vec_arith("+", t, d), d + t) expect_equal(vec_arith("+", th, dt), dt + th) expect_lossy(vec_arith("+", th, d), d + th, x = t, to = d) expect_error(vec_arith("-", t, dt), class = "vctrs_error_incompatible_op") expect_error(vec_arith("-", t, d), class = "vctrs_error_incompatible_op") }) test_that("difftime vs difftime/numeric", { t <- as.difftime(12, units = "hours") expect_equal(vec_arith("-", t, MISSING()), -t) expect_equal(vec_arith("+", t, MISSING()), t) expect_equal(vec_arith("-", t, t), t - t) expect_equal(vec_arith("-", t, 1), t - 1) expect_equal(vec_arith("-", 1, t), 1 - t) expect_equal(vec_arith("+", t, t), 2 * t) expect_equal(vec_arith("+", t, 1), t + 1) expect_equal(vec_arith("+", 1, t), t + 1) expect_equal(vec_arith("*", 2, t), 2 * t) expect_equal(vec_arith("*", t, 2), 2 * t) expect_error(vec_arith("*", t, t), class = "vctrs_error_incompatible_op") expect_equal(vec_arith("/", t, 2), t / 2) expect_error(vec_arith("/", 2, t), class = "vctrs_error_incompatible_op") expect_equal(vec_arith("/", t, t), 1) expect_equal(vec_arith("%/%", t, t), 1) expect_equal(vec_arith("%%", t, t), 0) }) # Math -------------------------------------------------------------------- test_that("date and date times don't support math", { expect_error(vec_math("sum", new_date()), class = "vctrs_error_unsupported") expect_error(vec_math("sum", new_datetime()), class = "vctrs_error_unsupported") }) vctrs/tests/testthat/test-proxy.R0000644000176200001440000000507213622451540016704 0ustar liggesusers test_that("vec_data() preserves names (#245)", { x <- set_names(letters, LETTERS) expect_identical(vec_names(x), vec_names(vec_data(x))) x <- diag(2) rownames(x) <- letters[1:2] colnames(x) <- LETTERS[1:2] expect_identical(vec_names(x), vec_names(vec_data(x))) }) test_that("vec_data() preserves size (#245)", { x <- set_names(letters, LETTERS) expect_identical(vec_size(x), vec_size(vec_data(x))) x <- diag(2) expect_identical(vec_size(x), vec_size(vec_data(x))) }) test_that("vec_data() preserves dim and dimnames (#245)", { x <- set_names(letters, LETTERS) expect_identical(vec_dim(x), vec_dim(vec_data(x))) x <- diag(2) expect_identical(vec_dim(x), vec_dim(vec_data(x))) x <- diag(2) rownames(x) <- letters[1:2] colnames(x) <- LETTERS[1:2] expect_identical(dimnames(x), dimnames(vec_data(x))) }) test_that("strips vector attributes apart from names, dim and dimnames", { x <- new_vctr(1:10, a = 1, b = 2) expect_null(attributes(vec_data(x))) x <- new_vctr(c(x = 1, y = 2), a = 1, b = 2) expect_equal(names(attributes(vec_data(x))), "names") x <- new_vctr(1, a = 1, dim = c(1L, 1L)) expect_equal(names(attributes(vec_data(x))), "dim") x <- new_vctr(1, a = 1, dim = c(1L, 1L), dimnames = list("foo", "bar")) expect_equal(names(attributes(vec_data(x))), c("dim", "dimnames")) }) test_that("vec_proxy() is a no-op with data vectors", { for (x in vectors) { expect_identical(vec_proxy(!!x), !!x) } x <- structure(1:3, foo = "bar") expect_identical(vec_proxy(!!x), !!x) }) test_that("vec_proxy() transforms records to data frames", { for (x in records) { expect_identical(vec_proxy(x), new_data_frame(unclass(x))) } }) test_that("vec_proxy() is a no-op with non vectors", { x <- foobar(list()) expect_identical(vec_proxy(x), x) }) test_that("can take the proxy of non-vector objects", { local_env_proxy() expect_identical(vec_proxy(new_proxy(1:3)), 1:3) }) test_that("vec_data() asserts vectorness", { expect_error(vec_data(new_sclr()), class = "vctrs_error_scalar_type") expect_error(vec_data(~foo), class = "vctrs_error_scalar_type") }) test_that("vec_data() is proxied", { local_env_proxy() x <- new_proxy(mtcars) expect_identical(vec_data(x), vec_data(mtcars)) }) test_that("vec_proxy_equal() is recursive over data frames (#641)", { x <- new_data_frame(list(x = foobar(1:3))) default <- vec_proxy_equal(x) expect_is(default$x, "vctrs_foobar") local_methods(vec_proxy_equal.vctrs_foobar = function(...) c(0, 0, 0)) overridden <- vec_proxy_equal(x) expect_identical(overridden$x, c(0, 0, 0)) }) vctrs/tests/testthat/test-type-vec-c-error.txt0000644000176200001440000000043713623022031021232 0ustar liggesusers vec_c(df1, df2): No common type for `..1$x$y$z` and `..2$x$y$z` . vec_c(df1, df1, df2): No common type for `..1$x$y$z` and `..3$x$y$z` . vec_c(foo = df1, bar = df2): No common type for `foo$x$y$z` and `bar$x$y$z` . vctrs/tests/testthat/test-partial-factor-print-both.txt0000644000176200001440000000005413623022034023121 0ustar liggesuserspartial_factor< 5a425 {partial} df698 > vctrs/tests/testthat/test-type.R0000644000176200001440000001776113623045211016507 0ustar liggesuserscontext("test-type") test_that("vec_ptype() is a no-op for NULL", { expect_null(vec_ptype(NULL)) }) test_that("vec_ptype() is a no-op for partial types", { expect_identical(vec_ptype(partial_factor("x")), partial_factor("x")) expect_identical(vec_ptype(partial_frame(x = 1)), partial_frame(x = 1)) }) test_that("vec_ptype() errors on scalars", { expect_error(vec_ptype(quote(name)), class = "vctrs_error_scalar_type") expect_error(vec_ptype(quote(fn())), class = "vctrs_error_scalar_type") }) test_that(".ptype argument overrides others", { expect_equal(vec_ptype_common(.ptype = 1:10), numeric()) }) test_that(".ptype required in strict mode", { old <- options(vctrs.no_guessing = TRUE) on.exit(options(old)) expect_error(vec_ptype_common(), "strict mode") }) test_that("can feed ptype into itself", { expect_equal(vec_ptype_common(vec_ptype_common(1:10)), numeric()) }) test_that("finalised prototypes created from under specified inputs", { expect_equal(vec_ptype_common(), NULL) expect_equal(vec_ptype_common(NULL), NULL) expect_equal(vec_ptype_common(NA), logical()) expect_equal(vec_ptype_common(NA, NULL), logical()) expect_equal(vec_ptype_common(NULL, NA), logical()) }) test_that("finalised prototypes created from under specified data frame cols", { df <- data.frame(x = NA) expect_equal(vec_ptype_common(df)$x, logical()) }) test_that("non-missing logical get correct type", { expect_equal(vec_ptype_common(TRUE), logical()) }) test_that("output tests", { expect_known_output(vec_ptype_show(), "out/vec-ptype-0.txt") expect_known_output(vec_ptype_show(integer()), "out/vec-ptype-1.txt") expect_known_output(vec_ptype_show(integer(), double()), "out/vec-ptype-2.txt") expect_known_output(vec_ptype_show(logical(), integer(), double()), "out/vec-ptype-3.txt") }) test_that("vec_ptype_common() handles matrices", { m <- matrix(1:4, nrow = 2) expect_identical(vec_ptype_common(m, m), matrix(int(), ncol = 2)) }) test_that("vec_ptype_common() includes index in argument tag", { df1 <- tibble(x = tibble(y = tibble(z = 1))) df2 <- tibble(x = tibble(y = tibble(z = "a"))) # Create a column name too large for default buffer nm <- str_dup("foobarfoobar", 10) large_df1 <- set_names(df1, nm) large_df2 <- set_names(df2, nm) expect_known_output_nobang(file = test_path("test-type-vec-type-common-error.txt"), { try2(vec_ptype_common(df1, df2)) try2(vec_ptype_common(df1, df1, df2)) try2(vec_ptype_common(large_df1, large_df2)) # Names try2(vec_ptype_common(foo = TRUE, bar = "foo")) try2(vec_ptype_common(foo = TRUE, baz = FALSE, bar = "foo")) try2(vec_ptype_common(foo = df1, bar = df2)) try2(vec_ptype_common(df1, df1, bar = df2)) # One splice box try2(vec_ptype_common(TRUE, !!!list(1, "foo"))) try2(vec_ptype_common(TRUE, !!!list(1, 2), "foo")) try2(vec_ptype_common(1, !!!list(TRUE, FALSE), "foo")) # One named splice box try2(vec_ptype_common(foo = TRUE, !!!list(FALSE, FALSE), bar = "foo")) try2(vec_ptype_common(foo = TRUE, !!!list(bar = 1, "foo"))) try2(vec_ptype_common(foo = TRUE, !!!list(bar = "foo"))) try2(vec_ptype_common(foo = TRUE, !!!list(bar = FALSE), baz = "chr")) # Two splice boxes in next and current try2(vec_ptype_common(foo = TRUE, !!!list(bar = FALSE), !!!list(baz = "chr"))) }) }) test_that("proxied types are have s3 bare type", { for (x in proxied_empty_types) { expect_identical(vec_typeof_bare(x), "s3") } }) test_that("vec_ptype() preserves attributes of unproxied structures", { expect_identical(vec_ptype(foobar(dbl(1))), foobar(dbl())) }) test_that("vec_ptype() errors on scalar lists", { expect_error(vec_ptype(foobar(list())), class = "vctrs_error_scalar_type") }) test_that("can retrieve type info", { exp <- list(type = "integer", proxy_method = NULL) expect_identical(vec_type_info(1:3), exp) exp <- list(type = "s3", proxy_method = NULL) expect_identical(vec_type_info(~foo), exp) x <- as.POSIXlt(new_datetime(0)) exp <- list(type = "s3", proxy_method = vec_proxy.POSIXlt) expect_identical(vec_type_info(x), exp) }) test_that("can retrieve proxy info", { exp <- list(type = "integer", proxy_method = NULL, proxy = 1:3) expect_identical(vec_proxy_info(1:3), exp) exp <- list(type = "scalar", proxy_method = NULL, proxy = ~foo) expect_identical(vec_proxy_info(~foo), exp) x <- as.POSIXlt(new_datetime(0)) proxy <- new_data_frame(unclass(x)) exp <- list(type = "dataframe", proxy_method = vec_proxy.POSIXlt, proxy = proxy) expect_identical(vec_proxy_info(x), exp) }) test_that("class_type() detects classes", { expect_identical(class_type(list()), "none") expect_identical(class_type(foobar(list())), "unknown") expect_identical(class_type(structure(list(), class = "list")), "list") expect_identical(class_type(subclass(structure(list(), class = "list"))), "list") expect_identical(class_type(new_list_of()), "list_of") expect_identical(class_type(subclass(new_list_of())), "list_of") expect_identical(class_type(data.frame()), "bare_data_frame") expect_identical(class_type(tibble::tibble()), "bare_tibble") expect_identical(class_type(subclass(data.frame())), "data_frame") expect_identical(class_type(new_factor()), "bare_factor") expect_identical(class_type(new_ordered()), "bare_ordered") expect_identical(class_type(subclass(new_factor())), "unknown") expect_identical(class_type(subclass(new_ordered())), "unknown") expect_identical(class_type(new_date()), "bare_date") expect_identical(class_type(new_datetime()), "bare_posixct") expect_identical(class_type(as.POSIXlt(new_date())), "bare_posixlt") expect_identical(class_type(subclass(new_date())), "unknown") expect_identical(class_type(subclass(new_datetime())), "unknown") expect_identical(class_type(subclass(as.POSIXlt(new_date()))), "posixlt") expect_identical(class_type(new_rcrd(list(a = 1))), "rcrd") expect_identical(class_type(subclass(new_rcrd(list(a = 1)))), "rcrd") expect_identical(class_type(NA), "none") expect_identical(class_type(foobar()), "unknown") }) test_that("vec_ptype() handles class-less yet OBJECT gremlins", { gremlin <- stats::model.frame(freeny) expect_error(vec_ptype(gremlin), NA) expect_error(vec_c(gremlin), NA) }) test_that("explicit list subclasses are vectors", { list_subclass <- function(x) { structure(x, class = c("custom_subclass", "list")) } x <- list_subclass(list()) expect_true(vec_is(x)) df <- data.frame(x = 1:2) df$z <- list_subclass(list(1, 2)) expect_identical(vec_slice(df, 1)$z, list_subclass(list(1))) }) test_that("the type of a classed data frame with an unspecified column retains unspecifiedness", { df1 <- subclass(data_frame(x = 1, y = NA)) df2 <- subclass(data_frame(x = 1, y = unspecified(1))) expect <- subclass(data_frame(x = numeric(), y = unspecified())) expect_identical(vec_ptype(df1), expect) expect_identical(vec_ptype(df2), expect) }) test_that("vec_ptype_finalise() works with NULL", { expect_identical(vec_ptype_finalise(NULL), NULL) }) test_that("vec_ptype_finalise() works recursively over bare data frames", { df <- data_frame(x = numeric(), y = unspecified(), z = partial_factor()) expect <- data_frame(x = numeric(), y = logical(), z = factor()) expect_identical(vec_ptype_finalise(df), expect) }) test_that("vec_ptype_finalise() works recursively over classed data frames", { df <- subclass(data_frame(x = numeric(), y = unspecified(), z = partial_factor())) expect <- subclass(data_frame(x = numeric(), y = logical(), z = factor())) expect_identical(vec_ptype_finalise(df), expect) }) test_that("vec_ptype_finalise() can handle data frame columns", { df <- data_frame(x = numeric(), y = data_frame(z = unspecified())) expect <- data_frame(x = numeric(), y = data_frame(z = logical())) expect_identical(vec_ptype_finalise(df), expect) }) test_that("vec_ptype_finalise() requires vector types", { expect_error(vec_ptype_finalise(quote(name)), class = "vctrs_error_scalar_type") expect_error(vec_ptype_finalise(foobar()), class = "vctrs_error_scalar_type") }) vctrs/tests/testthat/test-list_of-print.txt0000644000176200001440000000017413623022052020721 0ustar liggesusers[2]> [[1]] [1] 1 [[2]] [1] 2 3 # A tibble: 2 x 1 x > 1 [1] 2 [2] vctrs/tests/testthat/test-type-group-rle.txt0000644000176200001440000000005413623022033021017 0ustar liggesusers [1] 1x3 2x2 1x1 vctrs/tests/testthat/test-names.R0000644000176200001440000005712413622451540016633 0ustar liggesuserscontext("test-names") # vec_names() --------------------------------------------------------- test_that("vec_names() retrieves names", { expect_null(vec_names(letters)) expect_identical(vec_names(set_names(letters)), letters) expect_null(vec_names(mtcars)) expect_identical(vec_names(Titanic), dimnames(Titanic)[[1]]) x <- matrix(1L, dimnames = list("row", "col")) expect_identical(vec_names(x), dimnames(x)[[1]]) }) test_that("vec_names() dispatches", { local_methods( names.vctrs_foobar = function(x) "dispatched!" ) expect_identical(vec_names(foobar()), "dispatched!") }) test_that("vec_names<- sets names", { x <- letters vec_names(x) <- letters expect_identical(vec_names(x), letters) vec_names(x) <- NULL expect_null(vec_names(x)) y <- iris vec_names(y) <- as.character(-seq_len(vec_size(y))) expect_identical(row.names(y), row.names(iris)) expect_null(vec_names(y)) z <- ones(3, 2, 1) vec_names(z) <- as.character(1:3) expect_identical(vec_names(z), as.character(1:3)) }) # vec_names2() ------------------------------------------------------------- test_that("vec_names2() repairs names", { expect_identical(vec_names2(1:2), c("", "")) expect_identical(vec_names2(1:2, repair = "unique"), c("...1", "...2")) expect_identical(vec_names2(set_names(1:2, c("_foo", "_bar")), repair = "universal"), c("._foo", "._bar")) }) test_that("vec_names2() treats data frames and arrays as vectors", { expect_identical(vec_names2(mtcars), rep_len("", nrow(mtcars))) expect_identical(vec_names2(as.matrix(mtcars)), row.names(mtcars)) }) test_that("vec_names2() accepts and checks repair function", { expect_identical(vec_names2(1:2, repair = function(nms) rep_along(nms, "foo")), c("foo", "foo")) expect_error(vec_names2(1:2, repair = function(nms) "foo"), "length 1 instead of length 2") }) test_that("vec_names2() repairs names before invoking repair function", { x <- set_names(1:2, c(NA, NA)) expect_identical(vec_names2(x, repair = identity), c("", "")) }) # vec_as_names() ----------------------------------------------------------- test_that("vec_as_names() requires character vector", { expect_error(vec_as_names(NULL), "`names` must be a character vector") }) test_that("vec_as_names() repairs names", { expect_identical(vec_as_names(chr(NA, NA)), c("", "")) expect_identical(vec_as_names(chr(NA, NA), repair = "unique"), c("...1", "...2")) expect_identical(vec_as_names(chr("_foo", "_bar"), repair = "universal"), c("._foo", "._bar")) expect_identical(vec_as_names(chr("a", "b"), repair = "check_unique"), c("a", "b")) }) test_that("vec_as_names() checks unique names", { expect_error(vec_as_names(chr(NA), repair = "check_unique")) expect_error(vec_as_names(chr(""), repair = "check_unique")) expect_error(vec_as_names(chr("a", "a"), repair = "check_unique")) expect_error(vec_as_names(chr("..1"), repair = "check_unique")) expect_error(vec_as_names(chr("..."), repair = "check_unique")) }) test_that("vec_as_names() keeps the names of a named vector", { x_unnamed <- c(NA, "", "..1", "...2") x_names <- letters[1:4] x <- set_names(x_unnamed, x_names) expect_identical( set_names(vec_as_names(x_unnamed, repair = "minimal"), x_names), vec_as_names(x, repair = "minimal") ) expect_identical( set_names(vec_as_names(x_unnamed, repair = "unique"), x_names), vec_as_names(x, repair = "unique") ) expect_identical( set_names(vec_as_names(x_unnamed, repair = "universal"), x_names), vec_as_names(x, repair = "universal") ) }) test_that("vec_as_names() accepts and checks repair function", { f <- local({ local_obj <- "foo" ~ rep_along(.x, local_obj) }) expect_identical(vec_as_names(c("", ""), repair = f), c("foo", "foo")) expect_error(vec_as_names(c("", ""), repair = function(nms) "foo"), "length 1 instead of length 2") }) test_that("vec_as_names() repairs names before invoking repair function", { expect_identical(vec_as_names(chr(NA, NA), repair = identity), c("", "")) }) test_that("validate_minimal_names() checks names", { expect_error(validate_minimal_names(1), "must return a character vector") expect_error(validate_minimal_names(NULL), "can't return `NULL`") expect_error(validate_minimal_names(chr(NA)), "can't return `NA` values") }) test_that("validate_unique() checks unique names", { expect_error(validate_unique(chr(NA)), "`NA`") expect_error(validate_unique(chr("")), class = "vctrs_error_names_cannot_be_empty") expect_error(validate_unique(chr("a", "a")), class = "vctrs_error_names_must_be_unique") expect_error(validate_unique(chr("..1")), class = "vctrs_error_names_cannot_be_dot_dot") expect_error(validate_unique(chr("...")), class = "vctrs_error_names_cannot_be_dot_dot") }) test_that("vec_as_names_validate() validates repair arguments", { expect_identical( validate_name_repair_arg(c("unique", "check_unique")), "unique" ) expect_identical( validate_name_repair_arg(~ toupper(.))(letters), LETTERS ) }) # vec_repair_names() ------------------------------------------------------- test_that("vec_repair_names() repairs names", { expect_identical(vec_repair_names(1:2), set_names(1:2, c("", ""))) expect_identical(vec_repair_names(1:2, "unique"), set_names(1:2, c("...1", "...2"))) expect_identical(vec_repair_names(set_names(1:2, c("_foo", "_bar")), "universal"), set_names(1:2, c("._foo", "._bar"))) }) test_that("vec_repair_names() handles data frames and arrays", { df <- data.frame(x = 1:2) expect_identical(vec_repair_names(df), df) expect_identical(row.names(vec_repair_names(as.matrix(df))), c("", "")) expect_identical(row.names(vec_repair_names(as.matrix(df), "unique")), c("...1", "...2")) }) # vec_set_names() ----------------------------------------------------------- test_that("vec_set_names() sets atomic names", { x <- 1:2 names <- c("x1", "x2") exp <- set_names(x, names) expect_equal(vec_set_names(x, names), exp) }) test_that("vec_set_names() sets matrix/array names", { x <- matrix(1:2) names <- c("x1", "x2") exp <- x rownames(exp) <- names expect_equal(vec_set_names(x, names), exp) y <- array(1:4, dim = c(2, 1, 2)) exp <- y rownames(exp) <- names expect_equal(vec_set_names(y, names), exp) }) test_that("vec_set_names() does not set row names on data frames", { x <- data.frame(a = 1, b = 2) expect_equal(vec_set_names(x, "r1"), x) }) test_that("vec_set_names() leaves existing data frame row names intact", { x <- data.frame(a = 1, b = 2, row.names = "original") expect_equal(rownames(vec_set_names(x, "new")), "original") }) test_that("vec_set_names() correctly sets names on POSIXlt objects", { x <- as.POSIXlt(new_datetime(0)) exp <- set_names(x, "a") expect_equal(vec_set_names(x, "a"), exp) }) test_that("vec_set_names() falls back to `names<-` with proxied objects", { x <- structure(1, class = "foobar") exp <- set_names(x, "a") expect_equal(vec_set_names(x, "a"), exp) local_methods(`names<-.foobar` = function(x, value) "fallback!") expect_equal(vec_set_names(x, "a"), "fallback!") }) test_that("vec_set_names() falls back to `rownames<-` with shaped proxied objects", { x <- structure(1:2, dim = c(2L, 1L), class = "foobar") names <- c("r1", "r2") exp <- x rownames(exp) <- names expect_equal(vec_set_names(x, names), exp) # `rownames<-` is not generic, but eventually calls `dimnames<-` which is local_methods(`dimnames<-.foobar` = function(x, value) "fallback!") expect_equal(vec_set_names(x, names), "fallback!") }) test_that("vec_set_names() can set NULL names", { x <- 1:2 expect_equal(vec_set_names(x, NULL), x) x_named <- set_names(x) expect_equal(vec_set_names(x_named, NULL), x) x_mat <- as.matrix(x) expect_equal(vec_set_names(x_mat, NULL), x_mat) x_mat_named <- x_mat rownames(x_mat_named) <- c("1", "2") exp <- matrix(x_mat, dimnames = list(NULL, NULL)) expect_equal(vec_set_names(x_mat_named, NULL), exp) }) test_that("vec_set_names() errors with bad `names`", { expect_error(vec_set_names(1, 1), "character vector, not a double") expect_error(vec_set_names(1, c("x", "y")), "The size of `names`, 2") }) # minimal names ------------------------------------------------------------- test_that("minimal names are made from `n` when `name = NULL`", { expect_identical(minimal_names(1:2), c("", "")) }) test_that("as_minimal_names() checks input", { expect_error(as_minimal_names(1:3), "must be a character vector") }) test_that("minimal names have '' instead of NAs", { expect_identical(as_minimal_names(c("", NA, "", NA)), c("", "", "", "")) }) test_that("repairing minimal names copes with NULL input names", { x <- 1:3 x_named <- vec_repair_names(x) expect_equal(names(x_named), rep("", 3)) }) test_that("as_minimal_names() is idempotent", { x <- c("", "", NA) expect_identical(as_minimal_names(x), as_minimal_names(as_minimal_names(x))) }) test_that("minimal_names() treats data frames and arrays as vectors", { expect_identical(minimal_names(mtcars), rep_len("", nrow(mtcars))) expect_identical(minimal_names(as.matrix(mtcars)), row.names(mtcars)) }) test_that("as_minimal_names() copies on write", { nms <- chr(NA, NA) as_minimal_names(nms) expect_identical(nms, chr(NA, NA)) nms <- c("a", "b") out <- as_minimal_names(nms) expect_true(is_reference(nms, out)) }) # unique names ------------------------------------------------------------- test_that("unique_names() handles unnamed vectors", { expect_identical(unique_names(1:3), c("...1", "...2", "...3")) }) test_that("as_unique_names() is a no-op when no repairs are needed", { x <- c("x", "y") out <- as_unique_names(x) expect_true(is_reference(out, x)) expect_identical(out, c("x", "y")) }) test_that("as_unique_names() eliminates emptiness and duplication", { x <- c("", "x", "y", "x") expect_identical(as_unique_names(x), c("...1", "x...2", "y", "x...4")) }) test_that("solo empty or NA gets suffix", { expect_identical(as_unique_names(""), "...1") expect_identical(as_unique_names(NA_character_), "...1") }) test_that("ellipsis treated like empty string", { expect_identical(as_unique_names("..."), as_unique_names("")) }) test_that("two_three_dots() does its job and no more", { x <- c(".", ".1", "...1", "..1a") expect_identical(two_to_three_dots(x), x) expect_identical(two_to_three_dots(c("..1", "..22")), c("...1", "...22")) }) test_that("two dots then number treated like three dots then number", { expect_identical(as_unique_names("..2"), as_unique_names("...5")) }) test_that("as_unique_names() strips positional suffixes, re-applies as needed", { x <- c("...20", "a...1", "b", "", "a...2...34") expect_identical(as_unique_names(x), c("...1", "a...2", "b", "...4", "a...5")) expect_identical(as_unique_names("a...1"), "a") expect_identical(as_unique_names(c("a...2", "a")), c("a...1", "a...2")) expect_identical(as_unique_names(c("a...3", "a", "a")), c("a...1", "a...2", "a...3")) expect_identical(as_unique_names(c("a...2", "a", "a")), c("a...1", "a...2", "a...3")) expect_identical(as_unique_names(c("a...2", "a...2", "a...2")), c("a...1", "a...2", "a...3")) }) test_that("as_unique_names() is idempotent", { x <- c("...20", "a...1", "b", "", "a...2") expect_identical(as_unique_names(!!x), as_unique_names(as_unique_names(!!x))) }) test_that("unique-ification has an 'algebraic'-y property", { ## inspired by, but different from, this guarantee about base::make.unique() ## make.unique(c(A, B)) == make.unique(c(make.unique(A), B)) ## If A is already unique, then make.unique(c(A, B)) preserves A. ## I haven't formulated what we guarantee very well yet, but it's probably ## implicit in this test (?) x <- c("...20", "a...1", "b", "", "a...2", "d") y <- c("", "a...3", "b", "...3", "e") ## fix names on each, catenate, fix the whole z1 <- as_unique_names( c( as_unique_names(x), as_unique_names(y) ) ) ## fix names on x, catenate, fix the whole z2 <- as_unique_names( c( as_unique_names(x), y ) ) ## fix names on y, catenate, fix the whole z3 <- as_unique_names( c( x, as_unique_names(y) ) ) ## catenate, fix the whole z4 <- as_unique_names( c( x, y ) ) expect_identical(z1, z2) expect_identical(z1, z3) expect_identical(z1, z4) }) test_that("unique_names() and as_unique_names() are verbose or silent", { expect_message(unique_names(1:2), "-> ...1", fixed = TRUE) expect_message(as_unique_names(c("", "")), "-> ...1", fixed = TRUE) expect_message(regexp = NA, unique_names(1:2, quiet = TRUE)) expect_message(regexp = NA, as_unique_names(c("", ""), quiet = TRUE)) }) test_that("names with only duplicates are repaired", { expect_identical(unique_names(list(x = NA, x = NA)), c("x...1", "x...2")) }) # Universal names ---------------------------------------------------------- test_that("zero-length input", { expect_equal(as_universal_names(character()), character()) }) test_that("universal names are not changed", { expect_equal(as_universal_names(letters), letters) }) test_that("as_universal_names() is idempotent", { x <- c(NA, "", "x", "x", "a1:", "_x_y}") expect_identical(as_universal_names(x), as_universal_names(as_universal_names(x))) }) test_that("dupes get a suffix", { expect_equal( as_universal_names(c("a", "b", "a", "c", "b")), c("a...1", "b...2", "a...3", "c", "b...5") ) }) test_that("solo empty or NA gets suffix", { expect_identical(as_universal_names(""), "...1") expect_identical(as_universal_names(NA_character_), "...1") }) test_that("ellipsis treated like empty string", { expect_identical(as_universal_names("..."), as_universal_names("")) }) test_that("solo dot is unchanged", { expect_equal(as_universal_names("."), ".") }) test_that("dot, dot gets suffix", { expect_equal(as_universal_names(c(".", ".")), c("....1", "....2")) }) test_that("dot-dot, dot-dot gets suffix", { expect_equal(as_universal_names(c("..", "..")), c(".....1", ".....2")) }) test_that("empty, dot becomes suffix, dot", { expect_equal(as_universal_names(c("", ".")), c("...1", ".")) }) test_that("empty, empty, dot becomes suffix, suffix, dot", { expect_equal(as_universal_names(c("", "", ".")), c("...1", "...2", ".")) }) test_that("dot, dot, empty becomes suffix, suffix, suffix", { expect_equal(as_universal_names(c(".", ".", "")), c("....1", "....2", "...3")) }) test_that("dot, empty, dot becomes suffix, suffix, suffix", { expect_equal(as_universal_names(c(".", "", ".")), c("....1", "...2", "....3")) }) test_that("empty, dot, empty becomes suffix, dot, suffix", { expect_equal(as_universal_names(c("", ".", "")), c("...1", ".", "...3")) }) test_that("'...j' gets stripped then names are modified", { expect_equal(as_universal_names(c("...6", "...1...2")), c("...1", "...2")) expect_equal(as_universal_names("if...2"), ".if") }) test_that("complicated inputs", { expect_equal( as_universal_names(c("", ".", NA, "if...4", "if", "if...8", "for", "if){]1")), c("...1", ".", "...3", ".if...4", ".if...5", ".if...6", ".for", "if...1") ) }) test_that("message", { expect_message( as_universal_names(c("a b", "b c")), "New names:\n* `a b` -> a.b\n* `b c` -> b.c\n", fixed = TRUE ) }) test_that("quiet", { expect_message( as_universal_names("", quiet = TRUE), NA ) }) test_that("unique then universal is universal, with shuffling", { x <- c("", ".2", "..3", "...4", "....5", ".....6", "......7", "...") expect_identical(as_universal_names(as_unique_names(x)), as_universal_names(x)) x2 <- x[c(7L, 4L, 3L, 6L, 5L, 1L, 2L, 8L)] expect_identical(as_universal_names(as_unique_names(x2)), as_universal_names(x2)) x3 <- x[c(3L, 2L, 4L, 6L, 8L, 1L, 5L, 7L)] expect_identical(as_universal_names(as_unique_names(x3)), as_universal_names(x3)) }) test_that("zero-length inputs given character names", { out <- vec_repair_names(character(), "universal") expect_equal(names(out), character()) }) test_that("unnamed input gives uniquely named output", { out <- vec_repair_names(1:3, "universal") expect_equal(names(out), c("...1", "...2", "...3")) }) test_that("messages by default", { expect_message( vec_repair_names(set_names(1, "a:b"), "universal"), "New names:\n* `a:b` -> a.b\n", fixed = TRUE ) expect_message( vec_repair_names(set_names(1, "a:b"), ~ make.names(.)), "New names:\n* `a:b` -> a.b\n", fixed = TRUE ) }) test_that("quiet = TRUE", { expect_message(vec_repair_names(set_names(1, ""), "universal", quiet = TRUE), NA) }) test_that("non-universal names", { out <- vec_repair_names(set_names(1, "a b"), "universal") expect_equal(names(out), "a.b") expect_equal(as_universal_names("a b"), "a.b") }) # make_syntactic() --------------------------------------------------------- test_that("make_syntactic(): empty or NA", { expect_syntactic( c("", NA_character_), c(".", ".") ) }) test_that("make_syntactic(): reserved words", { expect_syntactic( c("if", "TRUE", "Inf", "NA_real_", "normal"), c(".if", ".TRUE", ".Inf", ".NA_real_", "normal") ) }) test_that("make_syntactic(): underscore", { expect_syntactic( c( "_", "_1", "_a}"), c("._", "._1", "._a.") ) }) test_that("make_syntactic(): dots", { expect_syntactic( c(".", "..", "...", "...."), c(".", "..", "....", "....") ) }) test_that("make_syntactic(): number", { expect_syntactic( c( "0", "1", "22", "333"), c("...0", "...1", "...22", "...333") ) }) test_that("make_syntactic(): number then character", { expect_syntactic( c( "0a", "1b", "22c", "333d"), c("..0a", "..1b", "..22c", "..333d") ) }) test_that("make_syntactic(): number then non-character", { expect_syntactic( c( "0)", "1&", "22*", "333@"), c("..0.", "..1.", "..22.", "..333.") ) }) test_that("make_syntactic(): dot then number", { expect_syntactic( c( ".0", ".1", ".22", ".333"), c("...0", "...1", "...22", "...333") ) }) test_that("make_syntactic(): dot then number then character", { expect_syntactic( c( ".0a", ".1b", ".22c", ".333d"), c("..0a", "..1b", "..22c", "..333d") ) }) test_that("make_syntactic(): dot then number then non-character", { expect_syntactic( c( ".0)", ".1&", ".22*", ".333@"), c("..0.", "..1.", "..22.", "..333.") ) }) test_that("make_syntactic(): dot dot then number", { expect_syntactic( c( "..0", "..1", "..22", "..333"), c("...0", "...1", "...22", "...333") ) }) test_that("make_syntactic(): dot dot dot then number", { expect_syntactic( c("...0", "...1", "...22", "...333"), c("...0", "...1", "...22", "...333") ) }) test_that("make_syntactic(): dot dot dot dot then number", { expect_syntactic( c("....0", "....1", "....22", "....333"), c("....0", "....1", "....22", "....333") ) }) test_that("make_syntactic(): dot dot dot dot dot then number", { expect_syntactic( c(".....0", ".....1", ".....22", ".....333"), c(".....0", ".....1", ".....22", ".....333") ) }) test_that("make_syntactic(): dot dot then number then character", { expect_syntactic( c("..0a", "..1b", "..22c", "..333d"), c("..0a", "..1b", "..22c", "..333d") ) }) test_that("make_syntactic(): dot dot then number then non-character", { expect_syntactic( c("..0)", "..1&", "..22*", "..333@"), c("..0.", "..1.", "..22.", "..333.") ) }) # Duplication -------------------------------------------------------------- test_that("Minimal name repair duplicates if needed", { x1 <- NA_character_ x3 <- c(x1, x1) # Called to check absence of side effect vec_as_names(x3, repair = "minimal") expect_identical(x3, c(NA_character_, NA_character_)) }) test_that("Unique name repair duplicates if needed", { x1 <- "fa\u00e7ile" x3 <- c(x1, x1) # Called to check absence of side effect vec_as_names(x3, repair = "unique") expect_identical(x3, c("fa\u00e7ile", "fa\u00e7ile")) }) # Encoding ------------------------------------------------------------- test_that("Name repair works with non-UTF-8 names", { x1 <- "fa\u00e7ile" skip_if_not(Encoding(x1) == "UTF-8") x2 <- iconv(x1, from = "UTF-8", to = "latin1") skip_if_not(Encoding(x2) == "latin1") x3 <- c(x2, x2) expect_equal(vec_as_names(x3, repair = "unique"), paste0(x3, "...", 1:2)) }) # Conditions ----------------------------------------------------------- test_that("names cannot be empty", { expect_error_cnd( stop_names_cannot_be_empty(1:3), class = c("vctrs_error_names_cannot_be_empty", "vctrs_error_names", "vctrs_error"), message = "Names must not be empty.", locations = 1:3 ) }) test_that("names cannot be dot dot", { expect_error_cnd( stop_names_cannot_be_dot_dot(1:3), class = c("vctrs_error_names_cannot_be_dot_dot", "vctrs_error_names", "vctrs_error"), message = "Names must not be of the form `...` or `..j`.", locations = 1:3 ) }) test_that("names must be unique", { expect_error_cnd( stop_names_must_be_unique(1:3), class = c("vctrs_error_names_must_be_unique", "vctrs_error_names", "vctrs_error"), message = "Names must be unique.", locations = 1:3 ) }) # Legacy repair -------------------------------------------------------- test_that("vec_as_names_legacy() works", { expect_identical(vec_as_names_legacy(chr()), chr()) expect_identical(vec_as_names_legacy(c("a", "a", "", "")), c("a", "a1", "V1", "V2")) expect_identical(vec_as_names_legacy(c("a", "a", "", ""), sep = "_"), c("a", "a_1", "V_1", "V_2")) expect_identical(vec_as_names_legacy(c("a", "a", "", ""), prefix = "foo"), c("a", "a1", "foo1", "foo2")) expect_identical(vec_as_names_legacy(c("a", "a", "", ""), prefix = "foo", sep = "_"), c("a", "a_1", "foo_1", "foo_2")) # From tibble expect_identical(vec_as_names_legacy(c("x", "x")), c("x", "x1")) expect_identical(vec_as_names_legacy(c("", "")), c("V1", "V2")) expect_identical(vec_as_names_legacy(c("", "V1")), c("V2", "V1")) expect_identical(vec_as_names_legacy(c("", "V", "V")), c("V2", "V", "V1")) }) # Name specification --------------------------------------------------- test_that("NULL name specs works with scalars", { expect_identical(apply_name_spec(NULL, "foo", NULL, 1L), "foo") expect_named(vec_c(foo = 1), "foo") expect_error(apply_name_spec(NULL, "foo", c("a", "b")), "vector of length > 1") expect_error(vec_c(foo = c(a = 1, b = 2)), "vector of length > 1") expect_error(apply_name_spec(NULL, "foo", NULL, 2L), "vector of length > 1") expect_error(vec_c(foo = 1:2), "vector of length > 1") }) test_that("function name spec is applied", { spec <- function(outer, inner) { sep <- if (is_character(inner)) "_" else ":" paste0(outer, sep, inner) } expect_identical(apply_name_spec(spec, "foo", NULL, 1L), "foo") expect_named(vec_c(foo = 1, .name_spec = spec), "foo") expect_identical(apply_name_spec(spec, "foo", c("a", "b")), c("foo_a", "foo_b")) expect_named(vec_c(foo = c(a = 1, b = 2), .name_spec = spec), c("foo_a", "foo_b")) expect_identical(apply_name_spec(spec, "foo", NULL, 2L), c("foo:1", "foo:2")) expect_named(vec_c(foo = 1:2, .name_spec = spec), c("foo:1", "foo:2")) }) test_that("can pass lambda formula as name spec", { expect_named(vec_c(foo = c(a = 1, b = 2), .name_spec = ~ paste(.x, .y, sep = "_")), c("foo_a", "foo_b")) expect_error(vec_c(foo = c(a = 1, b = 2), .name_spec = env()), "Can't convert `.name_spec`", fixed = TRUE) }) test_that("can pass glue string as name spec", { expect_named(vec_c(foo = c(a = 1, b = 2), .name_spec = "{outer}_{inner}"), c("foo_a", "foo_b")) expect_named(vec_c(foo = 1:2, .name_spec = "{outer}_{inner}"), c("foo_1", "foo_2")) expect_error(vec_c(foo = c(a = 1, b = 2), .name_spec = c("a", "b")), "single string") }) test_that("`outer` is recycled before name spec is invoked", { expect_identical(vec_c(outer = 1:2, .name_spec = "{outer}"), c(outer = 1L, outer = 2L)) }) vctrs/tests/testthat/error/0000755000176200001440000000000013622451540015550 5ustar liggesusersvctrs/tests/testthat/error/test-slice.txt0000644000176200001440000000345413623022040020361 0ustar liggesusers Unnamed vector with character subscript ======================================= > vec_slice(1:3, letters[1]) Error: Can't use character names to index an unnamed vector. Negative subscripts are checked =============================== > vec_slice(1:3, -c(1L, NA)) Error: Must subset elements with a valid subscript vector. x Negative locations can't have missing values. i The subscript has a missing value at location 2. > vec_slice(1:3, c(-1L, 1L)) Error: Must subset elements with a valid subscript vector. x Negative locations can't be mixed with positive locations. i The subscript has a positive value at location 2. oob error messages are properly constructed =========================================== > vec_slice(c(bar = 1), "foo") Error: Can't subset elements that don't exist. x The element `foo` doesn't exist. > # Multiple OOB indices > vec_slice(letters, c(100, 1000)) Error: Can't subset elements that don't exist. x The locations 100 and 1000 don't exist. i There are only 26 elements. > vec_slice(letters, c(1, 100:103, 2, 104:110)) Error: Can't subset elements that don't exist. x The locations 100, 101, 102, 103, 104, etc. don't exist. i There are only 26 elements. > vec_slice(set_names(letters), c("foo", "bar")) Error: Can't subset elements that don't exist. x The elements `foo` and `bar` don't exist. > vec_slice(set_names(letters), toupper(letters)) Error: Can't subset elements that don't exist. x The elements `A`, `B`, `C`, `D`, `E`, etc. don't exist. Can't index beyond the end of a vector ====================================== > vec_slice(1:2, 3L) Error: Can't subset elements that don't exist. x The location 3 doesn't exist. i There are only 2 elements. > vec_slice(1:2, -3L) Error: Can't negate elements that don't exist. x The location 3 doesn't exist. i There are only 2 elements. vctrs/tests/testthat/error/test-recycle.txt0000644000176200001440000000046713623022035020715 0ustar liggesusers incompatible recycling size has informative error ================================================= > vec_recycle(1:2, 4) Error: `x` can't be recycled to size 4. x It must be size 4 or 1, not 2. > vec_recycle(1:2, 4, x_arg = "foo") Error: `foo` can't be recycled to size 4. x It must be size 4 or 1, not 2. vctrs/tests/testthat/error/test-slice-assign.txt0000644000176200001440000000342613623022036021647 0ustar liggesusers `vec_assign()` requires recyclable value ======================================== > vec_assign(1:3, 1:3, 1:2) Error: `value` can't be recycled to size 3. x It must be size 3 or 1, not 2. logical subscripts must match size of indexed vector ==================================================== > vec_assign(1:2, c(TRUE, FALSE, TRUE), 5) Error: Must assign to elements with a valid subscript vector. i Logical subscripts must match the size of the indexed input. x The input has size 2 but the subscript has size 3. > vec_assign(mtcars, c(TRUE, FALSE), mtcars[1, ]) Error: Must assign to elements with a valid subscript vector. i Logical subscripts must match the size of the indexed input. x The input has size 32 but the subscript has size 2. must assign existing elements ============================= > vec_assign(1:3, 5, 10) Error: Can't assign to elements that don't exist. x The location 5 doesn't exist. i There are only 3 elements. > vec_assign(1:3, "foo", 10) Error: Can't use character names to index an unnamed vector. > vec_slice(letters, -100) <- "foo" Error: Can't negate elements that don't exist. x The location 100 doesn't exist. i There are only 26 elements. > vec_assign(set_names(letters), "foo", "bar") Error: Can't assign to elements that don't exist. x The element `foo` doesn't exist. must assign with proper negative locations ========================================== > vec_assign(1:3, c(-1, 1), 1:2) Error: Must assign to elements with a valid subscript vector. x Negative locations can't be mixed with positive locations. i The subscript has a positive value at location 2. > vec_assign(1:3, c(-1, NA), 1:2) Error: Must assign to elements with a valid subscript vector. x Negative locations can't have missing values. i The subscript has a missing value at location 2. vctrs/tests/testthat/error/test-subscript.txt0000644000176200001440000000415613623022046021306 0ustar liggesusers vec_as_subscript() forbids subscript types ========================================== > vec_as_subscript(1L, logical = "error", numeric = "error") Error: Must subset elements with a valid subscript vector. x The subscript has the wrong type `integer`. i It must be character. > vec_as_subscript("foo", logical = "error", character = "error") Error: Must subset elements with a valid subscript vector. x The subscript has the wrong type `character`. i It must be numeric. > vec_as_subscript(TRUE, logical = "error") Error: Must subset elements with a valid subscript vector. x The subscript has the wrong type `logical`. i It must be numeric or character. > vec_as_subscript("foo", character = "error") Error: Must subset elements with a valid subscript vector. x The subscript has the wrong type `character`. i It must be logical or numeric. > vec_as_subscript(NULL, numeric = "error") Error: Must subset elements with a valid subscript vector. x The subscript has the wrong type `NULL`. i It must be logical or character. > vec_as_subscript(quote(foo), character = "error") Error: Must subset elements with a valid subscript vector. x The subscript has the wrong type `symbol`. i It must be logical or numeric. vec_as_subscript2() forbids subscript types =========================================== > vec_as_subscript2(1L, numeric = "error", logical = "error") Error: Must extract element with a single valid subscript. x The subscript has the wrong type `integer`. i It must be character. > vec_as_subscript2("foo", character = "error", logical = "error") Error: Must extract element with a single valid subscript. x The subscript has the wrong type `character`. i It must be numeric. > vec_as_subscript2(TRUE, logical = "error") Error: Must extract element with a single valid subscript. x The subscript has the wrong type `logical`. i It must be numeric or character. can customise subscript errors ============================== > with_tibble_cols(vec_as_subscript(env())) Error: Must rename columns with a valid subscript vector. x The subscript `foo(bar)` has the wrong type `environment`. i It must be logical, numeric, or character. vctrs/tests/testthat/error/test-subscript-loc.txt0000644000176200001440000003650313623022046022062 0ustar liggesusers vec_as_location() checks for mix of negative and missing locations ================================================================== > vec_as_location(-c(1L, NA), 30) Error: Must subset elements with a valid subscript vector. x Negative locations can't have missing values. i The subscript has a missing value at location 2. > vec_as_location(-c(1L, rep(NA, 10)), 30) Error: Must subset elements with a valid subscript vector. x Negative locations can't have missing values. i The subscript has 10 missing values at locations 2, 3, 4, 5, 6, etc. vec_as_location() checks for mix of negative and positive locations =================================================================== > vec_as_location(c(-1L, 1L), 30) Error: Must subset elements with a valid subscript vector. x Negative locations can't be mixed with positive locations. i The subscript has a positive value at location 2. > vec_as_location(c(-1L, rep(1L, 10)), 30) Error: Must subset elements with a valid subscript vector. x Negative locations can't be mixed with positive locations. i The subscript has 10 missing values at locations 2, 3, 4, 5, 6, etc. num_as_location() optionally forbids negative indices ===================================================== > num_as_location(dbl(1, -1), 2L, negative = "error") Error: Must subset elements with a valid subscript vector. x The subscript can't contain negative locations. logical subscripts must match size of indexed vector ==================================================== > vec_as_location(c(TRUE, FALSE), 3) Error: Must subset elements with a valid subscript vector. i Logical subscripts must match the size of the indexed input. x The input has size 3 but the subscript has size 2. character subscripts require named vectors ========================================== > vec_as_location(letters[1], 3) Error: Can't use character names to index an unnamed vector. vec_as_location() requires integer, character, or logical inputs ================================================================ > vec_as_location(mtcars, 10L) Error: Must subset elements with a valid subscript vector. x The subscript has the wrong type `data.frame< mpg : double cyl : double disp: double hp : double drat: double wt : double qsec: double vs : double am : double gear: double carb: double >`. i It must be logical, numeric, or character. > vec_as_location(env(), 10L) Error: Must subset elements with a valid subscript vector. x The subscript has the wrong type `environment`. i It must be logical, numeric, or character. > vec_as_location(foobar(), 10L) Error: Must subset elements with a valid subscript vector. x The subscript has the wrong type `vctrs_foobar`. i It must be logical, numeric, or character. > vec_as_location(2.5, 3L) Error: Must subset elements with a valid subscript vector. x Lossy cast from to . > vec_as_location(list(), 10L) Error: Must subset elements with a valid subscript vector. x The subscript has the wrong type `list`. i It must be logical, numeric, or character. > vec_as_location(function() NULL, 10L) Error: Must subset elements with a valid subscript vector. x The subscript has the wrong type `closure`. i It must be logical, numeric, or character. > # Idem with custom `arg` > vec_as_location(env(), 10L, arg = "foo") Error: Must subset elements with a valid subscript vector. x The subscript `foo` has the wrong type `environment`. i It must be logical, numeric, or character. > vec_as_location(foobar(), 10L, arg = "foo") Error: Must subset elements with a valid subscript vector. x The subscript `foo` has the wrong type `vctrs_foobar`. i It must be logical, numeric, or character. > vec_as_location(2.5, 3L, arg = "foo") Error: Must subset elements with a valid subscript vector. x Lossy cast from `foo` to . vec_as_location2() requires integer or character inputs ======================================================= > vec_as_location2(TRUE, 10L) Error: Must extract element with a single valid subscript. x The subscript has the wrong type `logical`. i It must be numeric or character. > vec_as_location2(mtcars, 10L) Error: Must extract element with a single valid subscript. x The subscript has the wrong type `data.frame< mpg : double cyl : double disp: double hp : double drat: double wt : double qsec: double vs : double am : double gear: double carb: double >`. i It must be numeric or character. > vec_as_location2(env(), 10L) Error: Must extract element with a single valid subscript. x The subscript has the wrong type `environment`. i It must be numeric or character. > vec_as_location2(foobar(), 10L) Error: Must extract element with a single valid subscript. x The subscript has the wrong type `vctrs_foobar`. i It must be numeric or character. > vec_as_location2(2.5, 3L) Error: Must extract element with a single valid subscript. x Lossy cast from to . > # Idem with custom `arg` > vec_as_location2(foobar(), 10L, arg = "foo") Error: Must extract element with a single valid subscript. x The subscript `foo` has the wrong type `vctrs_foobar`. i It must be numeric or character. > vec_as_location2(2.5, 3L, arg = "foo") Error: Must extract element with a single valid subscript. x Lossy cast from `foo` to . vec_as_location2() requires length 1 inputs =========================================== > vec_as_location2(1:2, 2L) Error: Must extract element with a single valid subscript. x The subscript has size 2 but must be size 1. > vec_as_location2(mtcars, 10L) Error: Must extract element with a single valid subscript. x The subscript has the wrong type `data.frame< mpg : double cyl : double disp: double hp : double drat: double wt : double qsec: double vs : double am : double gear: double carb: double >`. i It must be numeric or character. > # Idem with custom `arg` > vec_as_location2(1:2, 2L, arg = "foo") Error: Must extract element with a single valid subscript. x The subscript `foo` has size 2 but must be size 1. > vec_as_location2(mtcars, 10L, arg = "foo") Error: Must extract element with a single valid subscript. x The subscript `foo` has the wrong type `data.frame< mpg : double cyl : double disp: double hp : double drat: double wt : double qsec: double vs : double am : double gear: double carb: double >`. i It must be numeric or character. > vec_as_location2(1:2, 2L, arg = "foo") Error: Must extract element with a single valid subscript. x The subscript `foo` has size 2 but must be size 1. vec_as_location2() requires positive integers ============================================= > vec_as_location2(0, 2L) Error: Must extract element with a single valid subscript. x The subscript has value 0 but must be a positive location. > vec_as_location2(-1, 2L) Error: Must extract element with a single valid subscript. x The subscript has value -1 but must be a positive location. > # Idem with custom `arg` > vec_as_location2(0, 2L, arg = "foo") Error: Must extract element with a single valid subscript. x The subscript `foo` has value 0 but must be a positive location. > # vec_as_location2() fails with NA > vec_as_location2(na_int, 2L) Error: Must extract element with a single valid subscript. x The subscript can't be `NA`. > vec_as_location2(na_chr, 1L, names = "foo") Error: Must extract element with a single valid subscript. x The subscript can't be `NA`. > # Idem with custom `arg` > vec_as_location2(na_int, 2L, arg = "foo") Error: Must extract element with a single valid subscript. x The subscript `foo` can't be `NA`. vec_as_location() and variants check for OOB elements ===================================================== > # Numeric subscripts > vec_as_location(10L, 2L) Error: Can't subset elements that don't exist. x The location 10 doesn't exist. i There are only 2 elements. > vec_as_location(-10L, 2L) Error: Can't negate elements that don't exist. x The location 10 doesn't exist. i There are only 2 elements. > vec_as_location2(10L, 2L) Error: Can't subset elements that don't exist. x The location 10 doesn't exist. i There are only 2 elements. > # Character subscripts > vec_as_location("foo", 1L, names = "bar") Error: Can't subset elements that don't exist. x The element `foo` doesn't exist. > vec_as_location2("foo", 1L, names = "bar") Error: Can't subset elements that don't exist. x The element `foo` doesn't exist. can optionally extend beyond the end ==================================== > num_as_location(c(1, 3), 1, oob = "extend") Error: Can't subset elements beyond the end with non-consecutive locations. i The input has size 1. x The subscript contains non-consecutive location 3. > num_as_location(c(1:5, 7), 3, oob = "extend") Error: Can't subset elements beyond the end with non-consecutive locations. i The input has size 3. x The subscript contains non-consecutive locations 4 and 7. > num_as_location(c(1:5, 7, 1), 3, oob = "extend") Error: Can't subset elements beyond the end with non-consecutive locations. i The input has size 3. x The subscript contains non-consecutive locations 4 and 7. > num_as_location(c(1:5, 7, 1, 10), 3, oob = "extend") Error: Can't subset elements beyond the end with non-consecutive locations. i The input has size 3. x The subscript contains non-consecutive locations 4, 7, and 10. missing values are supported in error formatters ================================================ > num_as_location(c(1, NA, 2, 3), 1) Error: Can't subset elements that don't exist. x The locations 2 and 3 don't exist. i There are only 1 element. > num_as_location(c(1, NA, 3), 1, oob = "extend") Error: Can't subset elements beyond the end with non-consecutive locations. i The input has size 1. x The subscript contains non-consecutive location 3. can customise subscript type errors =================================== > # With custom `arg` > num_as_location(-1, 2, negative = "error", arg = "foo") Error: Must subset elements with a valid subscript vector. x The subscript `foo` can't contain negative locations. > num_as_location2(-1, 2, negative = "error", arg = "foo") Error: Must extract element with a single valid subscript. x The subscript `foo` has value -1 but must be a positive location. > vec_as_location2(0, 2, arg = "foo") Error: Must extract element with a single valid subscript. x The subscript `foo` has value 0 but must be a positive location. > vec_as_location2(na_dbl, 2, arg = "foo") Error: Must extract element with a single valid subscript. x The subscript `foo` can't be `NA`. > vec_as_location2(c(1, 2), 2, arg = "foo") Error: Must extract element with a single valid subscript. x The subscript `foo` has size 2 but must be size 1. > vec_as_location(c(TRUE, FALSE), 3, arg = "foo") Error: Must subset elements with a valid subscript vector. i Logical subscripts must match the size of the indexed input. x The input has size 3 but the subscript `foo` has size 2. > vec_as_location(c(-1, NA), 3, arg = "foo") Error: Must subset elements with a valid subscript vector. x Negative locations can't have missing values. i The subscript `foo` has a missing value at location 2. > vec_as_location(c(-1, 1), 3, arg = "foo") Error: Must subset elements with a valid subscript vector. x Negative locations can't be mixed with positive locations. i The subscript `foo` has a positive value at location 2. > num_as_location(c(1, 4), 2, oob = "extend", arg = "foo") Error: Can't subset elements beyond the end with non-consecutive locations. i The input has size 2. x The subscript `foo` contains non-consecutive location 4. > # With tibble columns > with_tibble_cols(num_as_location(-1, 2, negative = "error")) Error: Must rename columns with a valid subscript vector. x The subscript `foo(bar)` can't contain negative locations. > with_tibble_cols(num_as_location2(-1, 2, negative = "error")) Error: Must rename column with a single valid subscript. x The subscript `foo(bar)` has value -1 but must be a positive location. > with_tibble_cols(vec_as_location2(0, 2)) Error: Must rename column with a single valid subscript. x The subscript `foo(bar)` has value 0 but must be a positive location. > with_tibble_cols(vec_as_location2(na_dbl, 2)) Error: Must rename column with a single valid subscript. x The subscript `foo(bar)` can't be `NA`. > with_tibble_cols(vec_as_location2(c(1, 2), 2)) Error: Must rename column with a single valid subscript. x The subscript `foo(bar)` has size 2 but must be size 1. > with_tibble_cols(vec_as_location(c(TRUE, FALSE), 3)) Error: Must rename columns with a valid subscript vector. i Logical subscripts must match the size of the indexed input. x The input has size 3 but the subscript `foo(bar)` has size 2. > with_tibble_cols(vec_as_location(c(-1, NA), 3)) Error: Must rename columns with a valid subscript vector. x Negative locations can't have missing values. i The subscript `foo(bar)` has a missing value at location 2. > with_tibble_cols(vec_as_location(c(-1, 1), 3)) Error: Must rename columns with a valid subscript vector. x Negative locations can't be mixed with positive locations. i The subscript `foo(bar)` has a positive value at location 2. > with_tibble_cols(num_as_location(c(1, 4), 2, oob = "extend")) Error: Can't rename columns beyond the end with non-consecutive locations. i The input has size 2. x The subscript `foo(bar)` contains non-consecutive location 4. can customise OOB errors ======================== > vec_slice(set_names(letters), "foo") Error: Can't subset elements that don't exist. x The element `foo` doesn't exist. > # With custom `arg` > vec_as_location(30, length(letters), arg = "foo") Error: Can't subset elements that don't exist. x The location 30 doesn't exist. i There are only 26 elements. > vec_as_location("foo", NULL, letters, arg = "foo") Error: Can't subset elements that don't exist. x The element `foo` doesn't exist. > # With tibble columns > with_tibble_cols(vec_slice(set_names(letters), "foo")) Error: Can't rename columns that don't exist. x The column `foo` doesn't exist. > with_tibble_cols(vec_slice(set_names(letters), 30)) Error: Can't rename columns that don't exist. x The location 30 doesn't exist. i There are only 26 columns. > with_tibble_cols(vec_slice(set_names(letters), -30)) Error: Can't rename columns that don't exist. x The location 30 doesn't exist. i There are only 26 columns. > # With tibble rows > with_tibble_rows(vec_slice(set_names(letters), c("foo", "bar"))) Error: Can't remove rows that don't exist. x The rows `foo` and `bar` don't exist. > with_tibble_rows(vec_slice(set_names(letters), 1:30)) Error: Can't remove rows that don't exist. x The locations 27, 28, 29, and 30 don't exist. i There are only 26 rows. > with_tibble_rows(vec_slice(set_names(letters), -(1:30))) Error: Can't remove rows that don't exist. x The locations 27, 28, 29, and 30 don't exist. i There are only 26 rows. can disallow missing values =========================== > vec_as_location(c(1, NA), 2, missing = "error") Error: Must subset elements with a valid subscript vector. x The subscript can't contain missing values. x It has a missing value at location 2. > vec_as_location(c(1, NA, 2, NA), 2, missing = "error", arg = "foo") Error: Must subset elements with a valid subscript vector. x The subscript can't contain missing values. x It has missing values at locations 2 and 4. > with_tibble_cols(vec_as_location(c(1, NA, 2, NA), 2, missing = "error")) Error: Must rename columns with a valid subscript vector. x The subscript `foo(bar)` can't contain missing values. x It has missing values at locations 2 and 4. vctrs/tests/testthat/error/test-conditions.txt0000644000176200001440000000126213623022032021427 0ustar liggesusers can override arg in OOB conditions ================================== > with_subscript_data(vec_slice(set_names(letters), "foo"), NULL) Error: Can't subset elements that don't exist. x The element `foo` doesn't exist. > with_subscript_data(vec_slice(set_names(letters), "foo"), "input") Error: Can't subset elements that don't exist. x The element `foo` doesn't exist. > with_subscript_data(vec_slice(set_names(letters), "foo"), quote(input)) Error: Can't subset elements that don't exist. x The element `foo` doesn't exist. > with_subscript_data(vec_slice(set_names(letters), "foo"), quote(input[i])) Error: Can't subset elements that don't exist. x The element `foo` doesn't exist. vctrs/tests/testthat/error/test-c.txt0000644000176200001440000000154113623022031017477 0ustar liggesusers vec_c() falls back to c() for foreign classes ============================================= > vec_c(foobar(1), foobar(2)) Error: Can't find vctrs or base methods for concatenation. vctrs methods must be implemented for class `vctrs_foobar`. See . vec_c() fallback doesn't support `name_spec` or `ptype` ======================================================= > vec_c(foobar(1), foobar(2), .name_spec = "{outer}_{inner}") Error: Can't use a name specification with non-vctrs types. vctrs methods must be implemented for class `vctrs_foobar`. See . > vec_c(foobar(1), foobar(2), .ptype = "") Error: Can't specify a prototype with non-vctrs types. vctrs methods must be implemented for class `vctrs_foobar`. See . vctrs/tests/testthat.R0000644000176200001440000000035413622451540014544 0ustar liggesuserslibrary(testthat) library(vctrs) if (requireNamespace("xml2")) { test_check("vctrs", reporter = MultiReporter$new(reporters = list(JunitReporter$new(file = "test-results.xml"), CheckReporter$new()))) } else { test_check("vctrs") } vctrs/src/0000755000176200001440000000000013623213416012203 5ustar liggesusersvctrs/src/size-common.c0000644000176200001440000000503013622451540014606 0ustar liggesusers#include "vctrs.h" #include "utils.h" // [[ register(external = TRUE) ]] SEXP vctrs_size_common(SEXP call, SEXP op, SEXP args, SEXP env) { args = CDR(args); SEXP size = PROTECT(Rf_eval(CAR(args), env)); args = CDR(args); if (size != R_NilValue) { R_len_t out = size_validate(size, ".size"); UNPROTECT(1); return r_int(out); } SEXP absent = PROTECT(Rf_eval(CAR(args), env)); if (absent != R_NilValue && (TYPEOF(absent) != INTSXP || Rf_length(absent) != 1)) { Rf_errorcall(R_NilValue, "`.absent` must be a single integer."); } SEXP xs = PROTECT(rlang_env_dots_list(env)); R_len_t common = vec_size_common(xs, -1); SEXP out; if (common < 0) { if (absent == R_NilValue) { Rf_errorcall(R_NilValue, "`...` is empty, and no `.absent` value was supplied."); } out = absent; } else { out = r_int(common); } UNPROTECT(3); return out; } static SEXP vctrs_size2_common(SEXP x, SEXP y, struct counters* counters); // [[ include("vctrs.h") ]] R_len_t vec_size_common(SEXP xs, R_len_t absent) { SEXP common = PROTECT(reduce(R_NilValue, args_empty, xs, &vctrs_size2_common)); R_len_t out; if (common == R_NilValue) { out = absent; } else { out = vec_size(common); } UNPROTECT(1); return out; } static SEXP vctrs_size2_common(SEXP x, SEXP y, struct counters* counters) { if (x == R_NilValue) { counters_shift(counters); return y; } if (y == R_NilValue) { return x; } R_len_t nx = vec_size(x); R_len_t ny = vec_size(y); if (nx == ny) { return x; } if (nx == 1) { counters_shift(counters); return y; } if (ny == 1) { return x; } stop_incompatible_size(x, y, nx, ny, counters->curr_arg, counters->next_arg); } // [[ register(external = TRUE) ]] SEXP vctrs_recycle_common(SEXP call, SEXP op, SEXP args, SEXP env) { args = CDR(args); SEXP size = PROTECT(Rf_eval(CAR(args), env)); args = CDR(args); R_len_t common; SEXP xs = PROTECT(rlang_env_dots_list(env)); if (size != R_NilValue) { common = size_validate(size, ".size"); } else { common = vec_size_common(xs, -1); } SEXP out = PROTECT(vec_recycle_common(xs, common)); UNPROTECT(3); return out; } // [[ include("vctrs.h") ]] SEXP vec_recycle_common(SEXP xs, R_len_t size) { if (size < 0) { return xs; } xs = PROTECT(r_maybe_duplicate(xs)); R_len_t n = vec_size(xs); SEXP elt; for (R_len_t i = 0; i < n; ++i) { elt = VECTOR_ELT(xs, i); SET_VECTOR_ELT(xs, i, vec_recycle(elt, size, args_empty)); } UNPROTECT(1); return xs; } vctrs/src/arg-counter.c0000644000176200001440000001170613622451540014603 0ustar liggesusers#include "vctrs.h" #include "utils.h" #include "arg.h" #include "arg-counter.h" void init_counters(struct counters* counters, SEXP names, struct vctrs_arg* curr_arg, struct counters* prev_box_counters, struct counters* next_box_counters) { counters->curr = 0; counters->next = 0; counters->names = names; counters->names_curr = 0; counters->names_next = 0; counters->curr_counter_data = new_counter_arg_data(&counters->curr, &counters->names, &counters->names_curr); counters->next_counter_data = new_counter_arg_data(&counters->next, &counters->names, &counters->names_next); counters->curr_counter = new_counter_arg(NULL, (void*) &counters->curr_counter_data); counters->next_counter = new_counter_arg(NULL, (void*) &counters->next_counter_data); counters->curr_arg = curr_arg; counters->next_arg = (struct vctrs_arg*) &counters->next_counter; counters->prev_box_counters = prev_box_counters; counters->next_box_counters = next_box_counters; } void init_next_box_counters(struct counters* counters, SEXP names) { SWAP(struct counters*, counters->prev_box_counters, counters->next_box_counters); struct counters* next = counters->next_box_counters; REPROTECT(names, next->names_pi); init_counters(next, names, counters->curr_arg, NULL, NULL); next->next = counters->next; } // Stack-based protection, should be called after `init_counters()` #define PROTECT_COUNTERS(counters, nprot) do { \ PROTECT_WITH_INDEX((counters)->names, &(counters)->names_pi); \ PROTECT_WITH_INDEX(R_NilValue, &(counters)->prev_box_counters->names_pi); \ PROTECT_WITH_INDEX(R_NilValue, &(counters)->next_box_counters->names_pi); \ *nprot += 3; \ } while(0) void counters_inc(struct counters* counters) { ++(counters->next); ++(counters->names_next); } /** * Swap counters so that the `next` counter (the one being increased * on iteration and representing the new input in the reduction) * becomes the current counter (the one representing the result so * far of the reduction). * * [[ include("arg-counter.h") ]] */ void counters_shift(struct counters* counters) { // Swap the counters data SWAP(void*, counters->curr_counter.data, counters->next_counter.data); SWAP(R_len_t*, counters->curr_counter_data.i, counters->next_counter_data.i); SWAP(R_len_t*, counters->curr_counter_data.names_i, counters->next_counter_data.names_i); // Update the handles to `vctrs_arg` counters->curr_arg = (struct vctrs_arg*) &counters->curr_counter; counters->next_arg = (struct vctrs_arg*) &counters->next_counter; // Update the current index counters->curr = counters->next; } // Reduce `impl` with argument counters SEXP reduce_impl(SEXP current, SEXP rest, struct counters* counters, bool spliced, SEXP (*impl)(SEXP current, SEXP next, struct counters* counters)); SEXP reduce_splice_box(SEXP current, SEXP rest, struct counters* counters, SEXP (*impl)(SEXP current, SEXP next, struct counters* counters)); // [[ include("arg-counter.h") ]] SEXP reduce(SEXP current, struct vctrs_arg* current_arg, SEXP rest, SEXP (*impl)(SEXP current, SEXP next, struct counters* counters)) { // Store the box counters here as they might outlive their frame struct counters next_box_counters; struct counters prev_box_counters; struct counters counters; init_counters(&counters, r_names(rest), current_arg, &prev_box_counters, &next_box_counters); int nprot = 0; PROTECT_COUNTERS(&counters, &nprot); SEXP out = reduce_impl(current, rest, &counters, false, impl); UNPROTECT(nprot); return out; } SEXP reduce_impl(SEXP current, SEXP rest, struct counters* counters, bool spliced, SEXP (*impl)(SEXP current, SEXP next, struct counters* counters)) { R_len_t n = Rf_length(rest); for (R_len_t i = 0; i < n; ++i, counters_inc(counters)) { PROTECT(current); SEXP next = VECTOR_ELT(rest, i); // Don't call `rlang_is_splice_box()` if we're already looking at a // spliced list because it's expensive if (spliced || !rlang_is_splice_box(next)) { current = impl(current, next, counters); } else { next = PROTECT(rlang_unbox(next)); current = reduce_splice_box(current, next, counters, impl); UNPROTECT(1); } UNPROTECT(1); } return current; } SEXP reduce_splice_box(SEXP current, SEXP rest, struct counters* counters, SEXP (*impl)(SEXP current, SEXP rest, struct counters* counters)) { init_next_box_counters(counters, r_names(rest)); struct counters* box_counters = counters->next_box_counters; current = reduce_impl(current, rest, box_counters, true, impl); counters->curr_arg = box_counters->curr_arg; counters->next = box_counters->next; return current; } vctrs/src/dictionary.c0000644000176200001440000002446413622451540014527 0ustar liggesusers#include "vctrs.h" #include "dictionary.h" #include "utils.h" // Initialised at load time struct vctrs_arg args_needles; struct vctrs_arg args_haystack; // http://graphics.stanford.edu/~seander/bithacks.html#RoundUpPowerOf2 int32_t ceil2(int32_t x) { x--; x |= x >> 1; x |= x >> 2; x |= x >> 4; x |= x >> 8; x |= x >> 16; x++; return x; } // Dictonary object ------------------------------------------------------------ // Dictionary functions assume that `x` has been proxied recursively because: // - `dict_init_impl()` uses `hash_fill()` // - `dict_hash_with()` uses `equal_scalar()` static void dict_init_impl(dictionary* d, SEXP x, bool partial); // Dictionaries must be protected and unprotected in consistent stack // order with `PROTECT_DICT()` and `UNPROTECT_DICT()`. void dict_init(dictionary* d, SEXP x) { dict_init_impl(d, x, false); } void dict_init_partial(dictionary* d, SEXP x) { dict_init_impl(d, x, true); } static void dict_init_impl(dictionary* d, SEXP x, bool partial) { d->vec = x; d->used = 0; if (partial) { d->key = NULL; d->size = 0; } else { // assume worst case, that every value is distinct, aiming for a load factor // of at most 77%. We round up to power of 2 to ensure quadratic probing // strategy works. // Rprintf("size: %i\n", size); R_len_t size = ceil2(vec_size(x) / 0.77); size = (size < 16) ? 16 : size; d->key = (R_len_t*) R_alloc(size, sizeof(R_len_t)); memset(d->key, DICT_EMPTY, size * sizeof(R_len_t)); d->size = size; } R_len_t n = vec_size(x); d->hash = (uint32_t*) R_alloc(n, sizeof(uint32_t)); if (d->hash) { memset(d->hash, 0, n * sizeof(R_len_t)); hash_fill(d->hash, n, x); } } uint32_t dict_hash_with(dictionary* d, dictionary* x, R_len_t i) { uint32_t hash = x->hash[i]; // Quadratic probing: will try every slot if d->size is power of 2 // http://research.cs.vt.edu/AVresearch/hashing/quadratic.php for (uint32_t k = 0; k < d->size; ++k) { uint32_t probe = (hash + k * (k + 1) / 2) & (d->size - 1); // Rprintf("Probe: %i\n", probe); // If we circled back to start, dictionary is full if (k > 1 && probe == hash) { break; } // Check for unused slot R_len_t idx = d->key[probe]; if (idx == DICT_EMPTY) { return probe; } // Check for same value as there might be a collision. If there is // a collision, next iteration will find another spot using // quadratic probing. if (equal_scalar(d->vec, idx, x->vec, i, true)) { return probe; } } Rf_errorcall(R_NilValue, "Internal error: Dictionary is full!"); } uint32_t dict_hash_scalar(dictionary* d, R_len_t i) { return dict_hash_with(d, d, i); } void dict_put(dictionary* d, uint32_t hash, R_len_t i) { d->key[hash] = i; d->used++; } // R interface ----------------------------------------------------------------- // TODO: rename to match R function names // TODO: separate out into individual files SEXP vctrs_unique_loc(SEXP x) { int nprot = 0; R_len_t n = vec_size(x); x = PROTECT_N(vec_proxy_equal(x), &nprot); x = PROTECT_N(obj_maybe_translate_encoding(x, n), &nprot); dictionary d; dict_init(&d, x); PROTECT_DICT(&d, &nprot); struct growable g = new_growable(INTSXP, 256); PROTECT_GROWABLE(&g, &nprot); for (int i = 0; i < n; ++i) { uint32_t hash = dict_hash_scalar(&d, i); if (d.key[hash] == DICT_EMPTY) { dict_put(&d, hash, i); growable_push_int(&g, i + 1); } } SEXP out = growable_values(&g); UNPROTECT(nprot); return out; } // [[ include("vctrs.h") ]] SEXP vec_unique(SEXP x) { SEXP index = PROTECT(vctrs_unique_loc(x)); SEXP out = vec_slice(x, index); UNPROTECT(1); return out; } SEXP vctrs_duplicated_any(SEXP x) { bool out = duplicated_any(x); return Rf_ScalarLogical(out); } // [[ include("vctrs.h") ]] bool duplicated_any(SEXP x) { int nprot = 0; R_len_t n = vec_size(x); x = PROTECT_N(vec_proxy_equal(x), &nprot); x = PROTECT_N(obj_maybe_translate_encoding(x, n), &nprot); dictionary d; dict_init(&d, x); PROTECT_DICT(&d, &nprot); bool out = false; for (int i = 0; i < n; ++i) { uint32_t hash = dict_hash_scalar(&d, i); if (d.key[hash] == DICT_EMPTY) { dict_put(&d, hash, i); } else { out = true; break; } } UNPROTECT(nprot); return out; } SEXP vctrs_n_distinct(SEXP x) { int nprot = 0; R_len_t n = vec_size(x); x = PROTECT_N(vec_proxy_equal(x), &nprot); x = PROTECT_N(obj_maybe_translate_encoding(x, n), &nprot); dictionary d; dict_init(&d, x); PROTECT_DICT(&d, &nprot); for (int i = 0; i < n; ++i) { uint32_t hash = dict_hash_scalar(&d, i); if (d.key[hash] == DICT_EMPTY) dict_put(&d, hash, i); } UNPROTECT(nprot); return Rf_ScalarInteger(d.used); } SEXP vctrs_id(SEXP x) { int nprot = 0; R_len_t n = vec_size(x); x = PROTECT_N(vec_proxy_equal(x), &nprot); x = PROTECT_N(obj_maybe_translate_encoding(x, n), &nprot); dictionary d; dict_init(&d, x); PROTECT_DICT(&d, &nprot); SEXP out = PROTECT_N(Rf_allocVector(INTSXP, n), &nprot); int* p_out = INTEGER(out); for (int i = 0; i < n; ++i) { uint32_t hash = dict_hash_scalar(&d, i); if (d.key[hash] == DICT_EMPTY) { dict_put(&d, hash, i); } p_out[i] = d.key[hash] + 1; } UNPROTECT(nprot); return out; } // [[ register() ]] SEXP vec_match(SEXP needles, SEXP haystack) { int nprot = 0; int _; SEXP type = PROTECT_N(vec_type2(needles, haystack, &args_needles, &args_haystack, &_), &nprot); needles = PROTECT_N(vec_cast(needles, type, args_empty, args_empty), &nprot); haystack = PROTECT_N(vec_cast(haystack, type, args_empty, args_empty), &nprot); needles = PROTECT_N(vec_proxy_equal(needles), &nprot); haystack = PROTECT_N(vec_proxy_equal(haystack), &nprot); R_len_t n_haystack = vec_size(haystack); R_len_t n_needle = vec_size(needles); SEXP translated = PROTECT_N(obj_maybe_translate_encoding2(needles, n_needle, haystack, n_haystack), &nprot); needles = VECTOR_ELT(translated, 0); haystack = VECTOR_ELT(translated, 1); dictionary d; dict_init(&d, haystack); PROTECT_DICT(&d, &nprot); // Load dictionary with haystack for (int i = 0; i < n_haystack; ++i) { uint32_t hash = dict_hash_scalar(&d, i); if (d.key[hash] == DICT_EMPTY) { dict_put(&d, hash, i); } } dictionary d_needles; dict_init_partial(&d_needles, needles); // Locate needles SEXP out = PROTECT_N(Rf_allocVector(INTSXP, n_needle), &nprot); int* p_out = INTEGER(out); for (int i = 0; i < n_needle; ++i) { uint32_t hash = dict_hash_with(&d, &d_needles, i); if (d.key[hash] == DICT_EMPTY) { p_out[i] = NA_INTEGER; } else { p_out[i] = d.key[hash] + 1; } } UNPROTECT(nprot); return out; } // [[ register() ]] SEXP vctrs_in(SEXP needles, SEXP haystack) { int nprot = 0; int _; SEXP type = PROTECT_N(vec_type2(needles, haystack, &args_needles, &args_haystack, &_), &nprot); needles = PROTECT_N(vec_cast(needles, type, args_empty, args_empty), &nprot); haystack = PROTECT_N(vec_cast(haystack, type, args_empty, args_empty), &nprot); needles = PROTECT_N(vec_proxy_equal(needles), &nprot); haystack = PROTECT_N(vec_proxy_equal(haystack), &nprot); R_len_t n_haystack = vec_size(haystack); R_len_t n_needle = vec_size(needles); SEXP translated = PROTECT_N(obj_maybe_translate_encoding2(needles, n_needle, haystack, n_haystack), &nprot); needles = VECTOR_ELT(translated, 0); haystack = VECTOR_ELT(translated, 1); dictionary d; dict_init(&d, haystack); PROTECT_DICT(&d, &nprot); // Load dictionary with haystack for (int i = 0; i < n_haystack; ++i) { uint32_t hash = dict_hash_scalar(&d, i); if (d.key[hash] == DICT_EMPTY) { dict_put(&d, hash, i); } } dictionary d_needles; dict_init_partial(&d_needles, needles); PROTECT_DICT(&d_needles, &nprot); // Locate needles SEXP out = PROTECT_N(Rf_allocVector(LGLSXP, n_needle), &nprot); int* p_out = LOGICAL(out); for (int i = 0; i < n_needle; ++i) { uint32_t hash = dict_hash_with(&d, &d_needles, i); p_out[i] = (d.key[hash] != DICT_EMPTY); } UNPROTECT(nprot); return out; } SEXP vctrs_count(SEXP x) { int nprot = 0; R_len_t n = vec_size(x); x = PROTECT_N(vec_proxy_equal(x), &nprot); x = PROTECT_N(obj_maybe_translate_encoding(x, n), &nprot); dictionary d; dict_init(&d, x); PROTECT_DICT(&d, &nprot); SEXP val = PROTECT_N(Rf_allocVector(INTSXP, d.size), &nprot); int* p_val = INTEGER(val); for (int i = 0; i < n; ++i) { int32_t hash = dict_hash_scalar(&d, i); if (d.key[hash] == DICT_EMPTY) { dict_put(&d, hash, i); p_val[hash] = 0; } p_val[hash]++; } // Create output SEXP out_key = PROTECT_N(Rf_allocVector(INTSXP, d.used), &nprot); SEXP out_val = PROTECT_N(Rf_allocVector(INTSXP, d.used), &nprot); int* p_out_key = INTEGER(out_key); int* p_out_val = INTEGER(out_val); int i = 0; for (int hash = 0; hash < d.size; ++hash) { if (d.key[hash] == DICT_EMPTY) continue; p_out_key[i] = d.key[hash] + 1; p_out_val[i] = p_val[hash]; i++; } SEXP out = PROTECT_N(Rf_allocVector(VECSXP, 2), &nprot); SET_VECTOR_ELT(out, 0, out_key); SET_VECTOR_ELT(out, 1, out_val); SEXP names = PROTECT_N(Rf_allocVector(STRSXP, 2), &nprot); SET_STRING_ELT(names, 0, Rf_mkChar("key")); SET_STRING_ELT(names, 1, Rf_mkChar("val")); Rf_setAttrib(out, R_NamesSymbol, names); UNPROTECT(nprot); return out; } SEXP vctrs_duplicated(SEXP x) { int nprot = 0; R_len_t n = vec_size(x); x = PROTECT_N(vec_proxy_equal(x), &nprot); x = PROTECT_N(obj_maybe_translate_encoding(x, n), &nprot); dictionary d; dict_init(&d, x); PROTECT_DICT(&d, &nprot); SEXP val = PROTECT_N(Rf_allocVector(INTSXP, d.size), &nprot); int* p_val = INTEGER(val); for (int i = 0; i < n; ++i) { int32_t hash = dict_hash_scalar(&d, i); if (d.key[hash] == DICT_EMPTY) { dict_put(&d, hash, i); p_val[hash] = 0; } p_val[hash]++; } // Create output SEXP out = PROTECT_N(Rf_allocVector(LGLSXP, n), &nprot); int* p_out = LOGICAL(out); for (int i = 0; i < n; ++i) { int32_t hash = dict_hash_scalar(&d, i); p_out[i] = p_val[hash] != 1; } UNPROTECT(nprot); return out; } void vctrs_init_dictionary(SEXP ns) { args_needles = new_wrapper_arg(NULL, "needles"); args_haystack = new_wrapper_arg(NULL, "haystack"); } vctrs/src/slice.c0000644000176200001440000004263713622451540013463 0ustar liggesusers#include "vctrs.h" #include "altrep.h" #include "slice.h" #include "subscript-loc.h" #include "type-data-frame.h" #include "utils.h" // Initialised at load time SEXP syms_vec_slice_fallback = NULL; SEXP fns_vec_slice_fallback = NULL; SEXP syms_vec_slice_fallback_integer64 = NULL; SEXP fns_vec_slice_fallback_integer64 = NULL; SEXP syms_vec_slice_dispatch_integer64 = NULL; SEXP fns_vec_slice_dispatch_integer64 = NULL; /** * This `vec_slice()` variant falls back to `[` with S3 objects. * * @param to The type to restore to. * @param dispatch When `true`, dispatches to `[` for compatibility * with base R. When `false`, uses native implementations. */ SEXP vec_slice_impl(SEXP x, SEXP subscript); #define SLICE_SUBSCRIPT(RTYPE, CTYPE, DEREF, CONST_DEREF, NA_VALUE) \ const CTYPE* data = CONST_DEREF(x); \ R_len_t n = Rf_length(subscript); \ int* subscript_data = INTEGER(subscript); \ \ SEXP out = PROTECT(Rf_allocVector(RTYPE, n)); \ CTYPE* out_data = DEREF(out); \ \ for (R_len_t i = 0; i < n; ++i, ++subscript_data, ++out_data) { \ int j = *subscript_data; \ *out_data = (j == NA_INTEGER) ? NA_VALUE : data[j - 1]; \ } \ \ UNPROTECT(1); \ return out #define SLICE_COMPACT_REP(RTYPE, CTYPE, DEREF, CONST_DEREF, NA_VALUE) \ const CTYPE* data = CONST_DEREF(x); \ \ int* subscript_data = INTEGER(subscript); \ R_len_t j = subscript_data[0]; \ R_len_t n = subscript_data[1]; \ \ SEXP out = PROTECT(Rf_allocVector(RTYPE, n)); \ CTYPE* out_data = DEREF(out); \ \ CTYPE elt = (j == NA_INTEGER) ? NA_VALUE : data[j - 1]; \ \ for (R_len_t i = 0; i < n; ++i, ++out_data) { \ *out_data = elt; \ } \ \ UNPROTECT(1); \ return out #define SLICE_COMPACT_SEQ(RTYPE, CTYPE, DEREF, CONST_DEREF) \ int* subscript_data = INTEGER(subscript); \ R_len_t start = subscript_data[0]; \ R_len_t n = subscript_data[1]; \ R_len_t step = subscript_data[2]; \ \ const CTYPE* data = CONST_DEREF(x) + start; \ \ SEXP out = PROTECT(Rf_allocVector(RTYPE, n)); \ CTYPE* out_data = DEREF(out); \ \ for (int i = 0; i < n; ++i, ++out_data, data += step) { \ *out_data = *data; \ } \ \ UNPROTECT(1); \ return out #define SLICE(RTYPE, CTYPE, DEREF, CONST_DEREF, NA_VALUE) \ if (ALTREP(x)) { \ SEXP alt_subscript = PROTECT(compact_materialize(subscript)); \ SEXP out = ALTVEC_EXTRACT_SUBSET_PROXY(x, alt_subscript, R_NilValue); \ UNPROTECT(1); \ if (out != NULL) { \ return out; \ } \ } \ if (is_compact_rep(subscript)) { \ SLICE_COMPACT_REP(RTYPE, CTYPE, DEREF, CONST_DEREF, NA_VALUE); \ } else if (is_compact_seq(subscript)) { \ SLICE_COMPACT_SEQ(RTYPE, CTYPE, DEREF, CONST_DEREF); \ } else { \ SLICE_SUBSCRIPT(RTYPE, CTYPE, DEREF, CONST_DEREF, NA_VALUE); \ } static SEXP lgl_slice(SEXP x, SEXP subscript) { SLICE(LGLSXP, int, LOGICAL, LOGICAL_RO, NA_LOGICAL); } static SEXP int_slice(SEXP x, SEXP subscript) { SLICE(INTSXP, int, INTEGER, INTEGER_RO, NA_INTEGER); } static SEXP dbl_slice(SEXP x, SEXP subscript) { SLICE(REALSXP, double, REAL, REAL_RO, NA_REAL); } static SEXP cpl_slice(SEXP x, SEXP subscript) { SLICE(CPLXSXP, Rcomplex, COMPLEX, COMPLEX_RO, vctrs_shared_na_cpl); } static SEXP chr_slice(SEXP x, SEXP subscript) { SLICE(STRSXP, SEXP, STRING_PTR, STRING_PTR_RO, NA_STRING); } static SEXP raw_slice(SEXP x, SEXP subscript) { SLICE(RAWSXP, Rbyte, RAW, RAW_RO, 0); } #undef SLICE #undef SLICE_COMPACT_REP #undef SLICE_COMPACT_SEQ #undef SLICE_SUBSCRIPT #define SLICE_BARRIER_SUBSCRIPT(RTYPE, GET, SET, NA_VALUE) \ R_len_t n = Rf_length(subscript); \ int* subscript_data = INTEGER(subscript); \ \ SEXP out = PROTECT(Rf_allocVector(RTYPE, n)); \ \ for (R_len_t i = 0; i < n; ++i, ++subscript_data) { \ int j = *subscript_data; \ SEXP elt = (j == NA_INTEGER) ? NA_VALUE : GET(x, j - 1); \ SET(out, i, elt); \ } \ \ UNPROTECT(1); \ return out #define SLICE_BARRIER_COMPACT_REP(RTYPE, GET, SET, NA_VALUE) \ int* subscript_data = INTEGER(subscript); \ R_len_t j = subscript_data[0]; \ R_len_t n = subscript_data[1]; \ \ SEXP out = PROTECT(Rf_allocVector(RTYPE, n)); \ \ SEXP elt = (j == NA_INTEGER) ? NA_VALUE : GET(x, j - 1); \ \ for (R_len_t i = 0; i < n; ++i) { \ SET(out, i, elt); \ } \ \ UNPROTECT(1); \ return out #define SLICE_BARRIER_COMPACT_SEQ(RTYPE, GET, SET) \ int* subscript_data = INTEGER(subscript); \ R_len_t start = subscript_data[0]; \ R_len_t n = subscript_data[1]; \ R_len_t step = subscript_data[2]; \ \ SEXP out = PROTECT(Rf_allocVector(RTYPE, n)); \ \ for (R_len_t i = 0; i < n; ++i, start += step) { \ SET(out, i, GET(x, start)); \ } \ \ UNPROTECT(1); \ return out #define SLICE_BARRIER(RTYPE, GET, SET, NA_VALUE) \ if (is_compact_rep(subscript)) { \ SLICE_BARRIER_COMPACT_REP(RTYPE, GET, SET, NA_VALUE); \ } else if (is_compact_seq(subscript)) { \ SLICE_BARRIER_COMPACT_SEQ(RTYPE, GET, SET); \ } else { \ SLICE_BARRIER_SUBSCRIPT(RTYPE, GET, SET, NA_VALUE); \ } static SEXP list_slice(SEXP x, SEXP subscript) { SLICE_BARRIER(VECSXP, VECTOR_ELT, SET_VECTOR_ELT, R_NilValue); } #undef SLICE_BARRIER #undef SLICE_BARRIER_COMPACT_REP #undef SLICE_BARRIER_COMPACT_SEQ #undef SLICE_BARRIER_SUBSCRIPT static SEXP df_slice(SEXP x, SEXP subscript) { R_len_t n = Rf_length(x); SEXP out = PROTECT(Rf_allocVector(VECSXP, n)); // FIXME: Should that be restored? SEXP nms = PROTECT(Rf_getAttrib(x, R_NamesSymbol)); Rf_setAttrib(out, R_NamesSymbol, nms); UNPROTECT(1); for (R_len_t i = 0; i < n; ++i) { SEXP elt = VECTOR_ELT(x, i); SEXP sliced = vec_slice_impl(elt, subscript); SET_VECTOR_ELT(out, i, sliced); } SEXP row_nms = PROTECT(df_rownames(x)); if (TYPEOF(row_nms) == STRSXP) { row_nms = PROTECT(slice_rownames(row_nms, subscript)); Rf_setAttrib(out, R_RowNamesSymbol, row_nms); UNPROTECT(1); } UNPROTECT(1); UNPROTECT(1); return out; } SEXP vec_slice_fallback(SEXP x, SEXP subscript) { // TODO - Remove once bit64 is updated on CRAN. Special casing integer64 // objects to ensure correct slicing with `NA_integer_`. if (is_integer64(x)) { return vctrs_dispatch2(syms_vec_slice_fallback_integer64, fns_vec_slice_fallback_integer64, syms_x, x, syms_i, subscript); } return vctrs_dispatch2(syms_vec_slice_fallback, fns_vec_slice_fallback, syms_x, x, syms_i, subscript); } static SEXP vec_slice_dispatch(SEXP x, SEXP subscript) { // TODO - Remove once bit64 is updated on CRAN. Special casing integer64 // objects to ensure correct slicing with `NA_integer_`. if (is_integer64(x)) { return vctrs_dispatch2(syms_vec_slice_dispatch_integer64, fns_vec_slice_dispatch_integer64, syms_x, x, syms_i, subscript); } return vctrs_dispatch2(syms_bracket, fns_bracket, syms_x, x, syms_i, subscript); } bool vec_requires_fallback(SEXP x, struct vctrs_proxy_info info) { return OBJECT(x) && info.proxy_method == R_NilValue && info.type != vctrs_type_dataframe; } SEXP vec_slice_base(enum vctrs_type type, SEXP x, SEXP subscript) { switch (type) { case vctrs_type_logical: return lgl_slice(x, subscript); case vctrs_type_integer: return int_slice(x, subscript); case vctrs_type_double: return dbl_slice(x, subscript); case vctrs_type_complex: return cpl_slice(x, subscript); case vctrs_type_character: return chr_slice(x, subscript); case vctrs_type_raw: return raw_slice(x, subscript); case vctrs_type_list: return list_slice(x, subscript); default: Rf_error("Internal error: Non-vector base type `%s` in `vec_slice_base()`", vec_type_as_str(type)); } } // Replace any `NA` name caused by `NA` subscript with the empty // string. It's ok mutate the names vector since it is freshly // created, but we make an additional check for that anyways // (and the empty string is persistently protected anyway). static void repair_na_names(SEXP names, SEXP subscript) { if (!NO_REFERENCES(names)) { Rf_errorcall(R_NilValue, "Internal error: `names` must not be referenced."); } // No possible way to have `NA_integer_` in a compact seq if (is_compact_seq(subscript)) { return; } R_len_t n = Rf_length(names); if (n == 0) { return; } SEXP* p_names = STRING_PTR(names); // Special handling for a compact_rep object with repeated `NA` if (is_compact_rep(subscript)) { for (R_len_t i = 0; i < n; ++i) { p_names[i] = strings_empty; } return; } const int* p_i = INTEGER_RO(subscript); for (R_len_t i = 0; i < n; ++i) { if (p_i[i] == NA_INTEGER) { p_names[i] = strings_empty; } } } SEXP slice_names(SEXP names, SEXP subscript) { if (names == R_NilValue) { return names; } names = PROTECT(chr_slice(names, subscript)); repair_na_names(names, subscript); UNPROTECT(1); return names; } SEXP slice_rownames(SEXP names, SEXP subscript) { if (names == R_NilValue) { return names; } names = PROTECT(chr_slice(names, subscript)); // Rownames can't contain `NA` or duplicates names = vec_as_unique_names(names, true); UNPROTECT(1); return names; } SEXP vec_slice_impl(SEXP x, SEXP subscript) { int nprot = 0; SEXP restore_size = PROTECT_N(r_int(vec_subscript_size(subscript)), &nprot); struct vctrs_proxy_info info = vec_proxy_info(x); PROTECT_PROXY_INFO(&info, &nprot); SEXP data = info.proxy; // Fallback to `[` if the class doesn't implement a proxy. This is // to be maximally compatible with existing classes. if (vec_requires_fallback(x, info)) { if (info.type == vctrs_type_scalar) { Rf_errorcall(R_NilValue, "Can't slice a scalar"); } if (is_compact(subscript)) { subscript = PROTECT_N(compact_materialize(subscript), &nprot); } SEXP out; if (has_dim(x)) { out = PROTECT_N(vec_slice_fallback(x, subscript), &nprot); } else { out = PROTECT_N(vec_slice_dispatch(x, subscript), &nprot); } // Take over attribute restoration only if the `[` method did not // restore itself if (ATTRIB(out) == R_NilValue) { out = vec_restore(out, x, restore_size); } UNPROTECT(nprot); return out; } switch (info.type) { case vctrs_type_null: Rf_error("Internal error: Unexpected `NULL` in `vec_slice_impl()`."); case vctrs_type_logical: case vctrs_type_integer: case vctrs_type_double: case vctrs_type_complex: case vctrs_type_character: case vctrs_type_raw: case vctrs_type_list: { SEXP out; if (has_dim(x)) { out = PROTECT_N(vec_slice_shaped(info.type, data, subscript), &nprot); SEXP names = PROTECT_N(Rf_getAttrib(x, R_DimNamesSymbol), &nprot); if (names != R_NilValue) { names = PROTECT_N(Rf_shallow_duplicate(names), &nprot); SEXP row_names = VECTOR_ELT(names, 0); row_names = PROTECT_N(slice_names(row_names, subscript), &nprot); SET_VECTOR_ELT(names, 0, row_names); Rf_setAttrib(out, R_DimNamesSymbol, names); } } else { out = PROTECT_N(vec_slice_base(info.type, data, subscript), &nprot); SEXP names = PROTECT_N(Rf_getAttrib(x, R_NamesSymbol), &nprot); names = PROTECT_N(slice_names(names, subscript), &nprot); Rf_setAttrib(out, R_NamesSymbol, names); } out = vec_restore(out, x, restore_size); UNPROTECT(nprot); return out; } case vctrs_type_dataframe: { SEXP out = PROTECT_N(df_slice(data, subscript), &nprot); out = vec_restore(out, x, restore_size); UNPROTECT(nprot); return out; } default: Rf_error("Internal error: Unexpected type `%s` for vector proxy in `vec_slice()`", vec_type_as_str(info.type)); } } // [[export]] SEXP vctrs_slice(SEXP x, SEXP subscript) { vec_assert(x, args_empty); subscript = PROTECT(vec_as_location(subscript, vec_size(x), PROTECT(vec_names(x)))); SEXP out = vec_slice_impl(x, subscript); UNPROTECT(2); return out; } SEXP vec_slice(SEXP x, SEXP subscript) { return vctrs_slice(x, subscript); } // [[ include("vctrs.h") ]] SEXP vec_init(SEXP x, R_len_t n) { struct vctrs_arg x_arg = new_wrapper_arg(NULL, "x"); vec_assert(x, &x_arg); SEXP i = PROTECT(compact_rep(NA_INTEGER, n)); SEXP out = vec_slice_impl(x, i); UNPROTECT(1); return out; } // [[ register() ]] SEXP vctrs_init(SEXP x, SEXP n) { R_len_t n_ = r_int_get(n, 0); return vec_init(x, n_); } // Exported for testing // [[ register() ]] SEXP vec_slice_seq(SEXP x, SEXP start, SEXP size, SEXP increasing) { R_len_t start_ = r_int_get(start, 0); R_len_t size_ = r_int_get(size, 0); bool increasing_ = r_lgl_get(increasing, 0); SEXP subscript = PROTECT(compact_seq(start_, size_, increasing_)); SEXP out = vec_slice_impl(x, subscript); UNPROTECT(1); return out; } // Exported for testing // [[ register() ]] SEXP vec_slice_rep(SEXP x, SEXP i, SEXP n) { R_len_t i_ = r_int_get(i, 0); R_len_t n_ = r_int_get(n, 0); SEXP subscript = PROTECT(compact_rep(i_, n_)); SEXP out = vec_slice_impl(x, subscript); UNPROTECT(1); return out; } void vctrs_init_slice(SEXP ns) { syms_vec_slice_fallback = Rf_install("vec_slice_fallback"); syms_vec_slice_fallback_integer64 = Rf_install("vec_slice_fallback_integer64"); syms_vec_slice_dispatch_integer64 = Rf_install("vec_slice_dispatch_integer64"); fns_vec_slice_fallback = Rf_findVar(syms_vec_slice_fallback, ns); fns_vec_slice_fallback_integer64 = Rf_findVar(syms_vec_slice_fallback_integer64, ns); fns_vec_slice_dispatch_integer64 = Rf_findVar(syms_vec_slice_dispatch_integer64, ns); } vctrs/src/fields.c0000644000176200001440000000702013622451540013615 0ustar liggesusers#include "vctrs.h" // SEXP x and y must be CHARSXP // x_utf* is pointer to const char* which is lazily initialised: // This makes this function also suitable for use when repeated // comparing varying y to constant x bool equal_string(SEXP x, const char** x_utf8, SEXP y) { // Try fast pointer comparison if (x == y) return true; if (*x_utf8 == NULL) *x_utf8 = Rf_translateCharUTF8(x); // Try slower conversion to common encoding const char* y_utf = Rf_translateCharUTF8(y); return (strcmp(y_utf, *x_utf8) == 0); } int find_offset(SEXP x, SEXP index) { if (Rf_length(index) != 1) { Rf_errorcall(R_NilValue, "Invalid index: must have length 1"); } int n = Rf_length(x); if (TYPEOF(index) == INTSXP) { int val = INTEGER(index)[0]; if (val == NA_INTEGER) Rf_errorcall(R_NilValue, "Invalid index: NA_integer_"); val--; if (val < 0 || val >= n) Rf_errorcall(R_NilValue, "Invalid index: out of bounds"); return val; } else if (TYPEOF(index) == REALSXP) { double val = REAL(index)[0]; if (R_IsNA(val)) Rf_errorcall(R_NilValue, "Invalid index: NA_real_"); val--; if (val < 0 || val >= n) Rf_errorcall(R_NilValue, "Invalid index: out of bounds"); if (val > R_LEN_T_MAX) { Rf_errorcall(R_NilValue, "Invalid index: too large"); } return (int) val; } else if (TYPEOF(index) == STRSXP) { SEXP names = PROTECT(Rf_getAttrib(x, R_NamesSymbol)); if (names == R_NilValue) Rf_errorcall(R_NilValue, "Corrupt x: no names"); SEXP val_0 = STRING_ELT(index, 0); if (val_0 == NA_STRING) Rf_errorcall(R_NilValue, "Invalid index: NA_character_"); const char* val_0_chr = Rf_translateCharUTF8(val_0); if (val_0_chr[0] == '\0') Rf_errorcall(R_NilValue, "Invalid index: empty string"); for (int j = 0; j < Rf_length(names); ++j) { SEXP name_j = STRING_ELT(names, j); if (name_j == NA_STRING) Rf_errorcall(R_NilValue, "Corrupt x: element %i is unnamed", j + 1); if (equal_string(val_0, &val_0_chr, name_j)) { UNPROTECT(1); return j; } } Rf_errorcall(R_NilValue, "Invalid index: field name '%s' not found", val_0_chr); } else { Rf_errorcall(R_NilValue, "Invalid index: must be a character or numeric vector"); } } // Lists ------------------------------------------------------------------- SEXP vctrs_list_get(SEXP x, SEXP index) { int idx = find_offset(x, index); return VECTOR_ELT(x, idx); } SEXP vctrs_list_set(SEXP x, SEXP index, SEXP value) { int idx = find_offset(x, index); SEXP out = PROTECT(Rf_shallow_duplicate(x)); SET_VECTOR_ELT(out, idx, value); UNPROTECT(1); return out; } // Records ------------------------------------------------------------------ void check_rcrd(SEXP x) { if (!Rf_isVectorList(x)) Rf_errorcall(R_NilValue, "Corrupt rcrd: not a list"); if (Rf_length(x) == 0) Rf_errorcall(R_NilValue, "Corrupt rcrd: length 0"); } SEXP vctrs_fields(SEXP x) { check_rcrd(x); return Rf_getAttrib(x, R_NamesSymbol); } SEXP vctrs_n_fields(SEXP x) { check_rcrd(x); return Rf_ScalarInteger(Rf_length(x)); } SEXP vctrs_field_get(SEXP x, SEXP index) { check_rcrd(x); return vctrs_list_get(x, index); } SEXP vctrs_field_set(SEXP x, SEXP index, SEXP value) { check_rcrd(x); if (!vec_is_vector(value)) { Rf_errorcall(R_NilValue, "Invalid value: not a vector."); } if (vec_size(value) != vec_size(x)) { Rf_errorcall(R_NilValue, "Invalid value: incorrect length."); } return vctrs_list_set(x, index, value); } vctrs/src/type-list-of.c0000644000176200001440000000111513622451540014702 0ustar liggesusers#include "vctrs.h" #include "utils.h" // [[ include("utils.h") ]] SEXP new_list_of(SEXP x, SEXP ptype) { if (TYPEOF(x) != VECSXP) { Rf_errorcall(R_NilValue, "Internal error: `x` must be a list."); } if (vec_size(ptype) != 0) { Rf_errorcall(R_NilValue, "Internal error: `ptype` must be a prototype with size 0."); } x = PROTECT(r_maybe_duplicate(x)); init_list_of(x, ptype); UNPROTECT(1); return x; } // [[ include("utils.h") ]] void init_list_of(SEXP x, SEXP ptype) { Rf_setAttrib(x, R_ClassSymbol, classes_list_of); Rf_setAttrib(x, syms_ptype, ptype); } vctrs/src/growable.c0000644000176200001440000000053413622451540014154 0ustar liggesusers#include "vctrs.h" #include "utils.h" struct growable new_growable(SEXPTYPE type, int capacity) { struct growable g; g.x = Rf_allocVector(type, capacity); g.type = type; g.array = r_vec_unwrap(type, g.x); g.n = 0; g.capacity = capacity; return g; } SEXP growable_values(struct growable* g) { return Rf_lengthgets(g->x, g->n); } vctrs/src/ptype2-dispatch.c0000644000176200001440000000441413623013722015370 0ustar liggesusers#include "vctrs.h" #include "utils.h" // [[ include("vctrs.h") ]] SEXP vec_ptype2_dispatch(SEXP x, SEXP y, enum vctrs_type x_type, enum vctrs_type y_type, struct vctrs_arg* x_arg, struct vctrs_arg* y_arg, int* left) { enum vctrs_type2_s3 type2_s3 = vec_typeof2_s3_impl(x, y, x_type, y_type, left); switch (type2_s3) { case vctrs_type2_s3_character_bare_factor: case vctrs_type2_s3_character_bare_ordered: return vctrs_shared_empty_chr; case vctrs_type2_s3_bare_factor_bare_factor: return fct_ptype2(x, y, x_arg, y_arg); case vctrs_type2_s3_bare_ordered_bare_ordered: return ord_ptype2(x, y, x_arg, y_arg); case vctrs_type2_s3_bare_date_bare_date: return vctrs_shared_empty_date; case vctrs_type2_s3_bare_date_bare_posixct: case vctrs_type2_s3_bare_date_bare_posixlt: return date_datetime_ptype2(x, y); case vctrs_type2_s3_bare_posixct_bare_posixct: case vctrs_type2_s3_bare_posixct_bare_posixlt: case vctrs_type2_s3_bare_posixlt_bare_posixlt: return datetime_datetime_ptype2(x, y); case vctrs_type2_s3_dataframe_bare_tibble: case vctrs_type2_s3_bare_tibble_bare_tibble: return tibble_ptype2(x, y, x_arg, y_arg); default: return vec_ptype2_dispatch_s3(x, y, x_arg, y_arg); } } // Initialised at load time static SEXP fns_vec_ptype2_dispatch_s3 = NULL; static SEXP syms_vec_ptype2_dispatch_s3 = NULL; // [[ include("vctrs.h") ]] SEXP vec_ptype2_dispatch_s3(SEXP x, SEXP y, struct vctrs_arg* x_arg, struct vctrs_arg* y_arg) { SEXP x_arg_chr = PROTECT(vctrs_arg(x_arg)); SEXP y_arg_chr = PROTECT(vctrs_arg(y_arg)); SEXP syms[5] = { syms_x, syms_y, syms_x_arg, syms_y_arg, NULL }; SEXP args[5] = { x, y, x_arg_chr, y_arg_chr, NULL }; SEXP out = vctrs_dispatch_n(syms_vec_ptype2_dispatch_s3, fns_vec_ptype2_dispatch_s3, syms, args); UNPROTECT(2); return out; } void vctrs_init_ptype2_dispatch(SEXP ns) { syms_vec_ptype2_dispatch_s3 = Rf_install("vec_ptype2_dispatch_s3"); fns_vec_ptype2_dispatch_s3 = Rf_findVar(syms_vec_ptype2_dispatch_s3, ns); } vctrs/src/hash.c0000644000176200001440000002140613622451540013276 0ustar liggesusers#include "vctrs.h" #include "utils.h" // boost::hash_combine from https://stackoverflow.com/questions/35985960 static uint32_t hash_combine(uint32_t x, uint32_t y) { return x ^ (y + 0x9e3779b9 + (x << 6) + (x >> 2)); } // 32-bit mixer from murmurhash // https://github.com/aappleby/smhasher/blob/master/src/MurmurHash3.cpp#L68 static uint32_t hash_int32(uint32_t x) { x ^= x >> 16; x *= 0x85ebca6b; x ^= x >> 13; x *= 0xc2b2ae35; x ^= x >> 16; return x; } // 64-bit mixer from murmurhash // https://github.com/aappleby/smhasher/blob/master/src/MurmurHash3.cpp#L81 static uint32_t hash_int64(int64_t x) { x ^= x >> 33; x *= UINT64_C(0xff51afd7ed558ccd); x ^= x >> 33; x *= UINT64_C(0xc4ceb9fe1a85ec53); x ^= x >> 33; return x; } // Seems like something designed specificaly for doubles should work better // but I haven't been able to find anything static uint32_t hash_double(double x) { // Treat positive/negative 0 as equivalent if (x == 0.0) { x = 0.0; } union { double d; uint64_t i; } value; value.d = x; return hash_int64(value.i); } static uint32_t hash_char(SEXP x) { return hash_int64((intptr_t) x); } // Hashing scalars ----------------------------------------------------- static uint32_t lgl_hash_scalar(const int* x); static uint32_t int_hash_scalar(const int* x); static uint32_t dbl_hash_scalar(const double* x); static uint32_t cpl_hash_scalar(const Rcomplex* x); static uint32_t chr_hash_scalar(const SEXP* x); static uint32_t raw_hash_scalar(const Rbyte* x); static uint32_t list_hash_scalar(SEXP x, R_len_t i); static uint32_t lgl_hash_scalar(const int* x) { return hash_int32(*x); } static uint32_t int_hash_scalar(const int* x) { return hash_int32(*x); } static uint32_t dbl_hash_scalar(const double* x) { double val = *x; // Hash all NAs and NaNs to same value (i.e. ignoring significand) switch (dbl_classify(val)) { case vctrs_dbl_number: break; case vctrs_dbl_missing: val = NA_REAL; break; case vctrs_dbl_nan: val = R_NaN; break; } return hash_double(val); } static uint32_t cpl_hash_scalar(const Rcomplex* x) { uint32_t hash = 0; hash = hash_combine(hash, dbl_hash_scalar(&x->r)); hash = hash_combine(hash, dbl_hash_scalar(&x->i)); return hash; } static uint32_t chr_hash_scalar(const SEXP* x) { return hash_char(*x); } static uint32_t raw_hash_scalar(const Rbyte* x) { return hash_int32(*x); } static uint32_t list_hash_scalar(SEXP x, R_len_t i) { return hash_object(VECTOR_ELT(x, i)); } // Hashing objects ----------------------------------------------------- static uint32_t lgl_hash(SEXP x); static uint32_t int_hash(SEXP x); static uint32_t dbl_hash(SEXP x); static uint32_t chr_hash(SEXP x); static uint32_t list_hash(SEXP x); static uint32_t node_hash(SEXP x); static uint32_t fn_hash(SEXP x); static uint32_t sexp_hash(SEXP x); uint32_t hash_object(SEXP x) { uint32_t hash = sexp_hash(x); SEXP attrib = ATTRIB(x); if (attrib != R_NilValue) { hash = hash_combine(hash, hash_object(attrib)); } return hash; } // [[ register() ]] SEXP vctrs_hash_object(SEXP x) { SEXP out = PROTECT(Rf_allocVector(RAWSXP, sizeof(uint32_t))); uint32_t hash = 0; hash = hash_combine(hash, hash_object(x)); memcpy(RAW(out), &hash, sizeof(uint32_t)); UNPROTECT(1); return out; } static uint32_t sexp_hash(SEXP x) { switch(TYPEOF(x)) { case NILSXP: return 0; case LGLSXP: return lgl_hash(x); case INTSXP: return int_hash(x); case REALSXP: return dbl_hash(x); case STRSXP: return chr_hash(x); case EXPRSXP: case VECSXP: return list_hash(x); case DOTSXP: case LANGSXP: case LISTSXP: case BCODESXP: return node_hash(x); case CLOSXP: return fn_hash(x); case SYMSXP: case SPECIALSXP: case BUILTINSXP: case ENVSXP: case EXTPTRSXP: return hash_int64((intptr_t) x); default: Rf_errorcall(R_NilValue, "Unsupported type %s", Rf_type2char(TYPEOF(x))); } } #define HASH(CTYPE, CONST_DEREF, HASHER) \ uint32_t hash = 0; \ R_len_t n = Rf_length(x); \ const CTYPE* p = CONST_DEREF(x); \ \ for (R_len_t i = 0; i < n; ++i, ++p) { \ hash = hash_combine(hash, HASHER(p)); \ } \ \ return hash static uint32_t lgl_hash(SEXP x) { HASH(int, LOGICAL_RO, lgl_hash_scalar); } static uint32_t int_hash(SEXP x) { HASH(int, INTEGER_RO, int_hash_scalar); } static uint32_t dbl_hash(SEXP x) { HASH(double, REAL_RO, dbl_hash_scalar); } static uint32_t chr_hash(SEXP x) { HASH(SEXP, STRING_PTR_RO, chr_hash_scalar); } #undef HASH #define HASH_BARRIER(GET, HASHER) \ uint32_t hash = 0; \ R_len_t n = Rf_length(x); \ \ for (R_len_t i = 0; i < n; ++i) { \ hash = hash_combine(hash, HASHER(GET(x, i))); \ } \ \ return hash static uint32_t list_hash(SEXP x) { HASH_BARRIER(VECTOR_ELT, hash_object); } #undef HASH_BARRIER static uint32_t node_hash(SEXP x) { uint32_t hash = 0; hash = hash_combine(hash, hash_object(CAR(x))); hash = hash_combine(hash, hash_object(CDR(x))); return hash; } static uint32_t fn_hash(SEXP x) { uint32_t hash = 0; hash = hash_combine(hash, hash_object(BODY(x))); hash = hash_combine(hash, hash_object(CLOENV(x))); hash = hash_combine(hash, hash_object(FORMALS(x))); return hash; } // Fill hash array ----------------------------------------------------- static void lgl_hash_fill(uint32_t* p, R_len_t size, SEXP x); static void int_hash_fill(uint32_t* p, R_len_t size, SEXP x); static void dbl_hash_fill(uint32_t* p, R_len_t size, SEXP x); static void cpl_hash_fill(uint32_t* p, R_len_t size, SEXP x); static void chr_hash_fill(uint32_t* p, R_len_t size, SEXP x); static void raw_hash_fill(uint32_t* p, R_len_t size, SEXP x); static void list_hash_fill(uint32_t* p, R_len_t size, SEXP x); static void df_hash_fill(uint32_t* p, R_len_t size, SEXP x); // Not compatible with hash_scalar // [[ include("vctrs.h") ]] void hash_fill(uint32_t* p, R_len_t size, SEXP x) { if (has_dim(x)) { // The conversion to data frame is only a stopgap, in the long // term, we'll hash arrays natively x = PROTECT(r_as_data_frame(x)); hash_fill(p, size, x); UNPROTECT(1); return; } switch (TYPEOF(x)) { case LGLSXP: lgl_hash_fill(p, size, x); return; case INTSXP: int_hash_fill(p, size, x); return; case REALSXP: dbl_hash_fill(p, size, x); return; case CPLXSXP: cpl_hash_fill(p, size, x); return; case STRSXP: chr_hash_fill(p, size, x); return; case RAWSXP: raw_hash_fill(p, size, x); return; case VECSXP: if (is_data_frame(x)) { df_hash_fill(p, size, x); } else { list_hash_fill(p, size, x); } return; default: Rf_error("Internal error: Unsupported type %s in `hash_fill()`.", Rf_type2char(TYPEOF(x))); } } #define HASH_FILL(CTYPE, CONST_DEREF, HASHER) \ const CTYPE* xp = CONST_DEREF(x); \ \ for (R_len_t i = 0; i < size; ++i, ++xp) { \ p[i] = hash_combine(p[i], HASHER(xp)); \ } static void lgl_hash_fill(uint32_t* p, R_len_t size, SEXP x) { HASH_FILL(int, LOGICAL_RO, lgl_hash_scalar); } static void int_hash_fill(uint32_t* p, R_len_t size, SEXP x) { HASH_FILL(int, INTEGER_RO, int_hash_scalar); } static void dbl_hash_fill(uint32_t* p, R_len_t size, SEXP x) { HASH_FILL(double, REAL_RO, dbl_hash_scalar); } static void cpl_hash_fill(uint32_t* p, R_len_t size, SEXP x) { HASH_FILL(Rcomplex, COMPLEX_RO, cpl_hash_scalar); } static void chr_hash_fill(uint32_t* p, R_len_t size, SEXP x) { HASH_FILL(SEXP, STRING_PTR_RO, chr_hash_scalar); } static void raw_hash_fill(uint32_t* p, R_len_t size, SEXP x) { HASH_FILL(Rbyte, RAW_RO, raw_hash_scalar); } #undef HASH_FILL #define HASH_FILL_BARRIER(HASHER) \ for (R_len_t i = 0; i < size; ++i) { \ p[i] = hash_combine(p[i], HASHER(x, i)); \ } static void list_hash_fill(uint32_t* p, R_len_t size, SEXP x) { HASH_FILL_BARRIER(list_hash_scalar); } #undef HASH_FILL_BARRIER static void df_hash_fill(uint32_t* p, R_len_t size, SEXP x) { R_len_t ncol = Rf_length(x); for (R_len_t i = 0; i < ncol; ++i) { SEXP col = VECTOR_ELT(x, i); hash_fill(p, size, col); } } // [[ register() ]] SEXP vctrs_hash(SEXP x) { x = PROTECT(vec_proxy_equal(x)); R_len_t n = vec_size(x); SEXP out = PROTECT(Rf_allocVector(RAWSXP, n * sizeof(uint32_t))); uint32_t* p = (uint32_t*) RAW(out); memset(p, 0, n * sizeof(uint32_t)); hash_fill(p, n, x); UNPROTECT(2); return out; } vctrs/src/arg-counter.h0000644000176200001440000000332113622451540014602 0ustar liggesusers#ifndef VCTRS_ARG_COUNTER_H #define VCTRS_ARG_COUNTER_H struct counters { /* public: */ // Argument tags for the current value of the reduction (the result // so far) and the next value. These handles typically point to the // local counter args, but might also point to external arg objects // like the initial current arg, or a splice box counter arg. struct vctrs_arg* curr_arg; struct vctrs_arg* next_arg; /* private: */ // Global counters R_len_t curr; R_len_t next; SEXP names; R_len_t names_curr; R_len_t names_next; // `names` might be from a splice box whose reduction has already // finished. We protect those from up high. PROTECT_INDEX names_pi; // Local counters for splice boxes. Since the tags are generated // lazily, we need two counter states to handle the // `vec_c(!!!list(foo = 1), !!!list(bar = 2))` case. struct counters* next_box_counters; struct counters* prev_box_counters; // Actual counter args are stored here struct arg_data_counter curr_counter_data; struct arg_data_counter next_counter_data; struct vctrs_arg curr_counter; struct vctrs_arg next_counter; }; /** * Swap the argument tags of the reduction * * There are two counters used for generating argument tags when an * error occur during a reduction. The first represent the result so * far, and the second the next input. Call `counters_shift()` to set * the counter of the next input as current counter, and start * iterating with a new counter for the next input. */ void counters_shift(struct counters* counters); SEXP reduce(SEXP current, struct vctrs_arg* current_arg, SEXP rest, SEXP (*impl)(SEXP current, SEXP next, struct counters* counters)); #endif vctrs/src/type-date-time.c0000644000176200001440000000352513622451540015205 0ustar liggesusers#include "vctrs.h" #include "utils.h" static SEXP new_empty_datetime(SEXP tzone); static SEXP get_tzone(SEXP x); // [[ include("vctrs.h") ]] SEXP date_datetime_ptype2(SEXP x, SEXP y) { SEXP x_class = PROTECT(Rf_getAttrib(x, R_ClassSymbol)); SEXP x_first_class = STRING_ELT(x_class, 0); SEXP tzone = (x_first_class == strings_date) ? get_tzone(y) : get_tzone(x); PROTECT(tzone); SEXP out = new_empty_datetime(tzone); UNPROTECT(2); return out; } static SEXP tzone_union(SEXP x_tzone, SEXP y_tzone); // [[ include("vctrs.h") ]] SEXP datetime_datetime_ptype2(SEXP x, SEXP y) { SEXP x_tzone = PROTECT(get_tzone(x)); SEXP y_tzone = PROTECT(get_tzone(y)); // Never allocates SEXP tzone = tzone_union(x_tzone, y_tzone); SEXP out = new_empty_datetime(tzone); UNPROTECT(2); return out; } static SEXP new_empty_datetime(SEXP tzone) { SEXP out = PROTECT(Rf_allocVector(REALSXP, 0)); Rf_setAttrib(out, R_ClassSymbol, classes_posixct); Rf_setAttrib(out, syms_tzone, tzone); UNPROTECT(1); return out; } static SEXP get_tzone(SEXP x) { SEXP tzone = PROTECT(Rf_getAttrib(x, syms_tzone)); if (tzone == R_NilValue) { UNPROTECT(1); return chrs_empty; } R_len_t size = Rf_length(tzone); if (size == 1) { UNPROTECT(1); return tzone; } if (size == 0) { Rf_errorcall(R_NilValue, "Corrupt datetime with 0-length `tzone` attribute"); } // If there are multiple, only take the first SEXP out = PROTECT(Rf_allocVector(STRSXP, 1)); SET_STRING_ELT(out, 0, STRING_ELT(tzone, 0)); UNPROTECT(2); return out; } // `get_tzone()` is guaranteed to return 1 element static inline bool tzone_is_local(SEXP tzone) { return STRING_ELT(tzone, 0) == strings_empty; } static SEXP tzone_union(SEXP x_tzone, SEXP y_tzone) { if (tzone_is_local(x_tzone)) { return y_tzone; } else { return x_tzone; } } vctrs/src/typeof2-s3.c0000644000176200001440000007577013623013722014300 0ustar liggesusers#include "vctrs.h" #include "utils.h" static enum vctrs_type2_s3 vec_typeof2_s3_impl2(SEXP x, SEXP y, enum vctrs_type type_y, int* left); // [[ include("vctrs.h") ]] enum vctrs_type2_s3 vec_typeof2_s3_impl(SEXP x, SEXP y, enum vctrs_type type_x, enum vctrs_type type_y, int* left) { switch (type_x) { case vctrs_type_null: { switch (class_type(y)) { case vctrs_class_bare_factor: *left = 0; return vctrs_type2_s3_null_bare_factor; case vctrs_class_bare_ordered: *left = 0; return vctrs_type2_s3_null_bare_ordered; case vctrs_class_bare_date: *left = 0; return vctrs_type2_s3_null_bare_date; case vctrs_class_bare_posixct: *left = 0; return vctrs_type2_s3_null_bare_posixct; case vctrs_class_bare_posixlt: *left = 0; return vctrs_type2_s3_null_bare_posixlt; case vctrs_class_bare_tibble: *left = 0; return vctrs_type2_s3_null_bare_tibble; default: *left = 0; return vctrs_type2_s3_null_unknown; } } case vctrs_type_unspecified: { switch (class_type(y)) { case vctrs_class_bare_factor: *left = 0; return vctrs_type2_s3_unspecified_bare_factor; case vctrs_class_bare_ordered: *left = 0; return vctrs_type2_s3_unspecified_bare_ordered; case vctrs_class_bare_date: *left = 0; return vctrs_type2_s3_unspecified_bare_date; case vctrs_class_bare_posixct: *left = 0; return vctrs_type2_s3_unspecified_bare_posixct; case vctrs_class_bare_posixlt: *left = 0; return vctrs_type2_s3_unspecified_bare_posixlt; case vctrs_class_bare_tibble: *left = 0; return vctrs_type2_s3_unspecified_bare_tibble; default: *left = 0; return vctrs_type2_s3_unspecified_unknown; } } case vctrs_type_logical: { switch (class_type(y)) { case vctrs_class_bare_factor: *left = 0; return vctrs_type2_s3_logical_bare_factor; case vctrs_class_bare_ordered: *left = 0; return vctrs_type2_s3_logical_bare_ordered; case vctrs_class_bare_date: *left = 0; return vctrs_type2_s3_logical_bare_date; case vctrs_class_bare_posixct: *left = 0; return vctrs_type2_s3_logical_bare_posixct; case vctrs_class_bare_posixlt: *left = 0; return vctrs_type2_s3_logical_bare_posixlt; case vctrs_class_bare_tibble: *left = 0; return vctrs_type2_s3_logical_bare_tibble; default: *left = 0; return vctrs_type2_s3_logical_unknown; } } case vctrs_type_integer: { switch (class_type(y)) { case vctrs_class_bare_factor: *left = 0; return vctrs_type2_s3_integer_bare_factor; case vctrs_class_bare_ordered: *left = 0; return vctrs_type2_s3_integer_bare_ordered; case vctrs_class_bare_date: *left = 0; return vctrs_type2_s3_integer_bare_date; case vctrs_class_bare_posixct: *left = 0; return vctrs_type2_s3_integer_bare_posixct; case vctrs_class_bare_posixlt: *left = 0; return vctrs_type2_s3_integer_bare_posixlt; case vctrs_class_bare_tibble: *left = 0; return vctrs_type2_s3_integer_bare_tibble; default: *left = 0; return vctrs_type2_s3_integer_unknown; } } case vctrs_type_double: { switch (class_type(y)) { case vctrs_class_bare_factor: *left = 0; return vctrs_type2_s3_double_bare_factor; case vctrs_class_bare_ordered: *left = 0; return vctrs_type2_s3_double_bare_ordered; case vctrs_class_bare_date: *left = 0; return vctrs_type2_s3_double_bare_date; case vctrs_class_bare_posixct: *left = 0; return vctrs_type2_s3_double_bare_posixct; case vctrs_class_bare_posixlt: *left = 0; return vctrs_type2_s3_double_bare_posixlt; case vctrs_class_bare_tibble: *left = 0; return vctrs_type2_s3_double_bare_tibble; default: *left = 0; return vctrs_type2_s3_double_unknown; } } case vctrs_type_complex: { switch (class_type(y)) { case vctrs_class_bare_factor: *left = 0; return vctrs_type2_s3_complex_bare_factor; case vctrs_class_bare_ordered: *left = 0; return vctrs_type2_s3_complex_bare_ordered; case vctrs_class_bare_date: *left = 0; return vctrs_type2_s3_complex_bare_date; case vctrs_class_bare_posixct: *left = 0; return vctrs_type2_s3_complex_bare_posixct; case vctrs_class_bare_posixlt: *left = 0; return vctrs_type2_s3_complex_bare_posixlt; case vctrs_class_bare_tibble: *left = 0; return vctrs_type2_s3_complex_bare_tibble; default: *left = 0; return vctrs_type2_s3_complex_unknown; } } case vctrs_type_character: { switch (class_type(y)) { case vctrs_class_bare_factor: *left = 0; return vctrs_type2_s3_character_bare_factor; case vctrs_class_bare_ordered: *left = 0; return vctrs_type2_s3_character_bare_ordered; case vctrs_class_bare_date: *left = 0; return vctrs_type2_s3_character_bare_date; case vctrs_class_bare_posixct: *left = 0; return vctrs_type2_s3_character_bare_posixct; case vctrs_class_bare_posixlt: *left = 0; return vctrs_type2_s3_character_bare_posixlt; case vctrs_class_bare_tibble: *left = 0; return vctrs_type2_s3_character_bare_tibble; default: *left = 0; return vctrs_type2_s3_character_unknown; } } case vctrs_type_raw: { switch (class_type(y)) { case vctrs_class_bare_factor: *left = 0; return vctrs_type2_s3_raw_bare_factor; case vctrs_class_bare_ordered: *left = 0; return vctrs_type2_s3_raw_bare_ordered; case vctrs_class_bare_date: *left = 0; return vctrs_type2_s3_raw_bare_date; case vctrs_class_bare_posixct: *left = 0; return vctrs_type2_s3_raw_bare_posixct; case vctrs_class_bare_posixlt: *left = 0; return vctrs_type2_s3_raw_bare_posixlt; case vctrs_class_bare_tibble: *left = 0; return vctrs_type2_s3_raw_bare_tibble; default: *left = 0; return vctrs_type2_s3_raw_unknown; } } case vctrs_type_list: { switch (class_type(y)) { case vctrs_class_bare_factor: *left = 0; return vctrs_type2_s3_list_bare_factor; case vctrs_class_bare_ordered: *left = 0; return vctrs_type2_s3_list_bare_ordered; case vctrs_class_bare_date: *left = 0; return vctrs_type2_s3_list_bare_date; case vctrs_class_bare_posixct: *left = 0; return vctrs_type2_s3_list_bare_posixct; case vctrs_class_bare_posixlt: *left = 0; return vctrs_type2_s3_list_bare_posixlt; case vctrs_class_bare_tibble: *left = 0; return vctrs_type2_s3_list_bare_tibble; default: *left = 0; return vctrs_type2_s3_list_unknown; } } case vctrs_type_dataframe: { switch (class_type(y)) { case vctrs_class_bare_factor: *left = 0; return vctrs_type2_s3_dataframe_bare_factor; case vctrs_class_bare_ordered: *left = 0; return vctrs_type2_s3_dataframe_bare_ordered; case vctrs_class_bare_date: *left = 0; return vctrs_type2_s3_dataframe_bare_date; case vctrs_class_bare_posixct: *left = 0; return vctrs_type2_s3_dataframe_bare_posixct; case vctrs_class_bare_posixlt: *left = 0; return vctrs_type2_s3_dataframe_bare_posixlt; case vctrs_class_bare_tibble: *left = 0; return vctrs_type2_s3_dataframe_bare_tibble; default: *left = 0; return vctrs_type2_s3_dataframe_unknown; } } case vctrs_type_scalar: { switch (class_type(y)) { case vctrs_class_bare_factor: *left = 0; return vctrs_type2_s3_scalar_bare_factor; case vctrs_class_bare_ordered: *left = 0; return vctrs_type2_s3_scalar_bare_ordered; case vctrs_class_bare_date: *left = 0; return vctrs_type2_s3_scalar_bare_date; case vctrs_class_bare_posixct: *left = 0; return vctrs_type2_s3_scalar_bare_posixct; case vctrs_class_bare_posixlt: *left = 0; return vctrs_type2_s3_scalar_bare_posixlt; case vctrs_class_bare_tibble: *left = 0; return vctrs_type2_s3_scalar_bare_tibble; default: *left = 0; return vctrs_type2_s3_scalar_unknown; } } case vctrs_type_s3: { return vec_typeof2_s3_impl2(x, y, type_y, left); }} never_reached("vec_typeof2_s3_impl()"); } static enum vctrs_type2_s3 vec_typeof2_s3_impl2(SEXP x, SEXP y, enum vctrs_type type_y, int* left) { switch (class_type(x)) { case vctrs_class_bare_factor: { switch (type_y) { case vctrs_type_null: *left = 1; return vctrs_type2_s3_null_bare_factor; case vctrs_type_unspecified: *left = 1; return vctrs_type2_s3_unspecified_bare_factor; case vctrs_type_logical: *left = 1; return vctrs_type2_s3_logical_bare_factor; case vctrs_type_integer: *left = 1; return vctrs_type2_s3_integer_bare_factor; case vctrs_type_double: *left = 1; return vctrs_type2_s3_double_bare_factor; case vctrs_type_complex: *left = 1; return vctrs_type2_s3_complex_bare_factor; case vctrs_type_character: *left = 1; return vctrs_type2_s3_character_bare_factor; case vctrs_type_raw: *left = 1; return vctrs_type2_s3_raw_bare_factor; case vctrs_type_list: *left = 1; return vctrs_type2_s3_list_bare_factor; case vctrs_type_dataframe: *left = 1; return vctrs_type2_s3_dataframe_bare_factor; case vctrs_type_scalar: *left = 1; return vctrs_type2_s3_scalar_bare_factor; case vctrs_type_s3: { switch (class_type(y)) { case vctrs_class_bare_factor: *left = -1; return vctrs_type2_s3_bare_factor_bare_factor; case vctrs_class_bare_ordered: *left = 0; return vctrs_type2_s3_bare_factor_bare_ordered; case vctrs_class_bare_date: *left = 0; return vctrs_type2_s3_bare_factor_bare_date; case vctrs_class_bare_posixct: *left = 0; return vctrs_type2_s3_bare_factor_bare_posixct; case vctrs_class_bare_posixlt: *left = 0; return vctrs_type2_s3_bare_factor_bare_posixlt; case vctrs_class_bare_tibble: *left = 0; return vctrs_type2_s3_bare_factor_bare_tibble; default: *left = 0; return vctrs_type2_s3_bare_factor_unknown; } }} } case vctrs_class_bare_ordered: { switch (type_y) { case vctrs_type_null: *left = 1; return vctrs_type2_s3_null_bare_ordered; case vctrs_type_unspecified: *left = 1; return vctrs_type2_s3_unspecified_bare_ordered; case vctrs_type_logical: *left = 1; return vctrs_type2_s3_logical_bare_ordered; case vctrs_type_integer: *left = 1; return vctrs_type2_s3_integer_bare_ordered; case vctrs_type_double: *left = 1; return vctrs_type2_s3_double_bare_ordered; case vctrs_type_complex: *left = 1; return vctrs_type2_s3_complex_bare_ordered; case vctrs_type_character: *left = 1; return vctrs_type2_s3_character_bare_ordered; case vctrs_type_raw: *left = 1; return vctrs_type2_s3_raw_bare_ordered; case vctrs_type_list: *left = 1; return vctrs_type2_s3_list_bare_ordered; case vctrs_type_dataframe: *left = 1; return vctrs_type2_s3_dataframe_bare_ordered; case vctrs_type_scalar: *left = 1; return vctrs_type2_s3_scalar_bare_ordered; case vctrs_type_s3: { switch (class_type(y)) { case vctrs_class_bare_factor: *left = 1; return vctrs_type2_s3_bare_factor_bare_ordered; case vctrs_class_bare_ordered: *left = -1; return vctrs_type2_s3_bare_ordered_bare_ordered; case vctrs_class_bare_date: *left = 0; return vctrs_type2_s3_bare_ordered_bare_date; case vctrs_class_bare_posixct: *left = 0; return vctrs_type2_s3_bare_ordered_bare_posixct; case vctrs_class_bare_posixlt: *left = 0; return vctrs_type2_s3_bare_ordered_bare_posixlt; case vctrs_class_bare_tibble: *left = 0; return vctrs_type2_s3_bare_ordered_bare_tibble; default: *left = 0; return vctrs_type2_s3_bare_ordered_unknown; } }} } case vctrs_class_bare_date: { switch (type_y) { case vctrs_type_null: *left = 1; return vctrs_type2_s3_null_bare_date; case vctrs_type_unspecified: *left = 1; return vctrs_type2_s3_unspecified_bare_date; case vctrs_type_logical: *left = 1; return vctrs_type2_s3_logical_bare_date; case vctrs_type_integer: *left = 1; return vctrs_type2_s3_integer_bare_date; case vctrs_type_double: *left = 1; return vctrs_type2_s3_double_bare_date; case vctrs_type_complex: *left = 1; return vctrs_type2_s3_complex_bare_date; case vctrs_type_character: *left = 1; return vctrs_type2_s3_character_bare_date; case vctrs_type_raw: *left = 1; return vctrs_type2_s3_raw_bare_date; case vctrs_type_list: *left = 1; return vctrs_type2_s3_list_bare_date; case vctrs_type_dataframe: *left = 1; return vctrs_type2_s3_dataframe_bare_date; case vctrs_type_scalar: *left = 1; return vctrs_type2_s3_scalar_bare_date; case vctrs_type_s3: { switch (class_type(y)) { case vctrs_class_bare_factor: *left = 1; return vctrs_type2_s3_bare_factor_bare_date; case vctrs_class_bare_ordered: *left = 1; return vctrs_type2_s3_bare_ordered_bare_date; case vctrs_class_bare_date: *left = -1; return vctrs_type2_s3_bare_date_bare_date; case vctrs_class_bare_posixct: *left = 0; return vctrs_type2_s3_bare_date_bare_posixct; case vctrs_class_bare_posixlt: *left = 0; return vctrs_type2_s3_bare_date_bare_posixlt; case vctrs_class_bare_tibble: *left = 0; return vctrs_type2_s3_bare_date_bare_tibble; default: *left = 0; return vctrs_type2_s3_bare_date_unknown; } }} } case vctrs_class_bare_posixct: { switch (type_y) { case vctrs_type_null: *left = 1; return vctrs_type2_s3_null_bare_posixct; case vctrs_type_unspecified: *left = 1; return vctrs_type2_s3_unspecified_bare_posixct; case vctrs_type_logical: *left = 1; return vctrs_type2_s3_logical_bare_posixct; case vctrs_type_integer: *left = 1; return vctrs_type2_s3_integer_bare_posixct; case vctrs_type_double: *left = 1; return vctrs_type2_s3_double_bare_posixct; case vctrs_type_complex: *left = 1; return vctrs_type2_s3_complex_bare_posixct; case vctrs_type_character: *left = 1; return vctrs_type2_s3_character_bare_posixct; case vctrs_type_raw: *left = 1; return vctrs_type2_s3_raw_bare_posixct; case vctrs_type_list: *left = 1; return vctrs_type2_s3_list_bare_posixct; case vctrs_type_dataframe: *left = 1; return vctrs_type2_s3_dataframe_bare_posixct; case vctrs_type_scalar: *left = 1; return vctrs_type2_s3_scalar_bare_posixct; case vctrs_type_s3: { switch (class_type(y)) { case vctrs_class_bare_factor: *left = 1; return vctrs_type2_s3_bare_factor_bare_posixct; case vctrs_class_bare_ordered: *left = 1; return vctrs_type2_s3_bare_ordered_bare_posixct; case vctrs_class_bare_date: *left = 1; return vctrs_type2_s3_bare_date_bare_posixct; case vctrs_class_bare_posixct: *left = -1; return vctrs_type2_s3_bare_posixct_bare_posixct; case vctrs_class_bare_posixlt: *left = 0; return vctrs_type2_s3_bare_posixct_bare_posixlt; case vctrs_class_bare_tibble: *left = 0; return vctrs_type2_s3_bare_posixct_bare_tibble; default: *left = 0; return vctrs_type2_s3_bare_posixct_unknown; } }} } case vctrs_class_bare_posixlt: { switch (type_y) { case vctrs_type_null: *left = 1; return vctrs_type2_s3_null_bare_posixlt; case vctrs_type_unspecified: *left = 1; return vctrs_type2_s3_unspecified_bare_posixlt; case vctrs_type_logical: *left = 1; return vctrs_type2_s3_logical_bare_posixlt; case vctrs_type_integer: *left = 1; return vctrs_type2_s3_integer_bare_posixlt; case vctrs_type_double: *left = 1; return vctrs_type2_s3_double_bare_posixlt; case vctrs_type_complex: *left = 1; return vctrs_type2_s3_complex_bare_posixlt; case vctrs_type_character: *left = 1; return vctrs_type2_s3_character_bare_posixlt; case vctrs_type_raw: *left = 1; return vctrs_type2_s3_raw_bare_posixlt; case vctrs_type_list: *left = 1; return vctrs_type2_s3_list_bare_posixlt; case vctrs_type_dataframe: *left = 1; return vctrs_type2_s3_dataframe_bare_posixlt; case vctrs_type_scalar: *left = 1; return vctrs_type2_s3_scalar_bare_posixlt; case vctrs_type_s3: { switch (class_type(y)) { case vctrs_class_bare_factor: *left = 1; return vctrs_type2_s3_bare_factor_bare_posixlt; case vctrs_class_bare_ordered: *left = 1; return vctrs_type2_s3_bare_ordered_bare_posixlt; case vctrs_class_bare_date: *left = 1; return vctrs_type2_s3_bare_date_bare_posixlt; case vctrs_class_bare_posixct: *left = 1; return vctrs_type2_s3_bare_posixct_bare_posixlt; case vctrs_class_bare_posixlt: *left = -1; return vctrs_type2_s3_bare_posixlt_bare_posixlt; case vctrs_class_bare_tibble: *left = 0; return vctrs_type2_s3_bare_posixlt_bare_tibble; default: *left = 0; return vctrs_type2_s3_bare_posixlt_unknown; } }} } case vctrs_class_bare_tibble: { switch (type_y) { case vctrs_type_null: *left = 1; return vctrs_type2_s3_null_bare_tibble; case vctrs_type_unspecified: *left = 1; return vctrs_type2_s3_unspecified_bare_tibble; case vctrs_type_logical: *left = 1; return vctrs_type2_s3_logical_bare_tibble; case vctrs_type_integer: *left = 1; return vctrs_type2_s3_integer_bare_tibble; case vctrs_type_double: *left = 1; return vctrs_type2_s3_double_bare_tibble; case vctrs_type_complex: *left = 1; return vctrs_type2_s3_complex_bare_tibble; case vctrs_type_character: *left = 1; return vctrs_type2_s3_character_bare_tibble; case vctrs_type_raw: *left = 1; return vctrs_type2_s3_raw_bare_tibble; case vctrs_type_list: *left = 1; return vctrs_type2_s3_list_bare_tibble; case vctrs_type_dataframe: *left = 1; return vctrs_type2_s3_dataframe_bare_tibble; case vctrs_type_scalar: *left = 1; return vctrs_type2_s3_scalar_bare_tibble; case vctrs_type_s3: { switch (class_type(y)) { case vctrs_class_bare_factor: *left = 1; return vctrs_type2_s3_bare_factor_bare_tibble; case vctrs_class_bare_ordered: *left = 1; return vctrs_type2_s3_bare_ordered_bare_tibble; case vctrs_class_bare_date: *left = 1; return vctrs_type2_s3_bare_date_bare_tibble; case vctrs_class_bare_posixct: *left = 1; return vctrs_type2_s3_bare_posixct_bare_tibble; case vctrs_class_bare_posixlt: *left = 1; return vctrs_type2_s3_bare_posixlt_bare_tibble; case vctrs_class_bare_tibble: *left = -1; return vctrs_type2_s3_bare_tibble_bare_tibble; default: *left = 0; return vctrs_type2_s3_bare_tibble_unknown; } }} } default: { switch (type_y) { case vctrs_type_null: *left = 1; return vctrs_type2_s3_null_unknown; case vctrs_type_unspecified: *left = 1; return vctrs_type2_s3_unspecified_unknown; case vctrs_type_logical: *left = 1; return vctrs_type2_s3_logical_unknown; case vctrs_type_integer: *left = 1; return vctrs_type2_s3_integer_unknown; case vctrs_type_double: *left = 1; return vctrs_type2_s3_double_unknown; case vctrs_type_complex: *left = 1; return vctrs_type2_s3_complex_unknown; case vctrs_type_character: *left = 1; return vctrs_type2_s3_character_unknown; case vctrs_type_raw: *left = 1; return vctrs_type2_s3_raw_unknown; case vctrs_type_list: *left = 1; return vctrs_type2_s3_list_unknown; case vctrs_type_dataframe: *left = 1; return vctrs_type2_s3_dataframe_unknown; case vctrs_type_scalar: *left = 1; return vctrs_type2_s3_scalar_unknown; case vctrs_type_s3: { switch (class_type(y)) { case vctrs_class_bare_factor: *left = 1; return vctrs_type2_s3_bare_factor_unknown; case vctrs_class_bare_ordered: *left = 1; return vctrs_type2_s3_bare_ordered_unknown; case vctrs_class_bare_date: *left = 1; return vctrs_type2_s3_bare_date_unknown; case vctrs_class_bare_posixct: *left = 1; return vctrs_type2_s3_bare_posixct_unknown; case vctrs_class_bare_posixlt: *left = 1; return vctrs_type2_s3_bare_posixlt_unknown; case vctrs_class_bare_tibble: *left = 1; return vctrs_type2_s3_bare_tibble_unknown; default: *left = -1; return vctrs_type2_s3_unknown_unknown; } }} }} never_reached("vec_typeof2_s3_impl2()"); } enum vctrs_type2_s3 vec_typeof2_s3(SEXP x, SEXP y) { int _; return vec_typeof2_s3_impl(x, y, vec_typeof(x), vec_typeof(y), &_); } const char* vctrs_type2_s3_as_str(enum vctrs_type2_s3 type) { switch (type) { case vctrs_type2_s3_null_bare_factor: return "vctrs_type2_s3_null_bare_factor"; case vctrs_type2_s3_null_bare_ordered: return "vctrs_type2_s3_null_bare_ordered"; case vctrs_type2_s3_null_bare_date: return "vctrs_type2_s3_null_bare_date"; case vctrs_type2_s3_null_bare_posixct: return "vctrs_type2_s3_null_bare_posixct"; case vctrs_type2_s3_null_bare_posixlt: return "vctrs_type2_s3_null_bare_posixlt"; case vctrs_type2_s3_null_bare_tibble: return "vctrs_type2_s3_null_bare_tibble"; case vctrs_type2_s3_null_unknown: return "vctrs_type2_s3_null_unknown"; case vctrs_type2_s3_unspecified_bare_factor: return "vctrs_type2_s3_unspecified_bare_factor"; case vctrs_type2_s3_unspecified_bare_ordered: return "vctrs_type2_s3_unspecified_bare_ordered"; case vctrs_type2_s3_unspecified_bare_date: return "vctrs_type2_s3_unspecified_bare_date"; case vctrs_type2_s3_unspecified_bare_posixct: return "vctrs_type2_s3_unspecified_bare_posixct"; case vctrs_type2_s3_unspecified_bare_posixlt: return "vctrs_type2_s3_unspecified_bare_posixlt"; case vctrs_type2_s3_unspecified_bare_tibble: return "vctrs_type2_s3_unspecified_bare_tibble"; case vctrs_type2_s3_unspecified_unknown: return "vctrs_type2_s3_unspecified_unknown"; case vctrs_type2_s3_logical_bare_factor: return "vctrs_type2_s3_logical_bare_factor"; case vctrs_type2_s3_logical_bare_ordered: return "vctrs_type2_s3_logical_bare_ordered"; case vctrs_type2_s3_logical_bare_date: return "vctrs_type2_s3_logical_bare_date"; case vctrs_type2_s3_logical_bare_posixct: return "vctrs_type2_s3_logical_bare_posixct"; case vctrs_type2_s3_logical_bare_posixlt: return "vctrs_type2_s3_logical_bare_posixlt"; case vctrs_type2_s3_logical_bare_tibble: return "vctrs_type2_s3_logical_bare_tibble"; case vctrs_type2_s3_logical_unknown: return "vctrs_type2_s3_logical_unknown"; case vctrs_type2_s3_integer_bare_factor: return "vctrs_type2_s3_integer_bare_factor"; case vctrs_type2_s3_integer_bare_ordered: return "vctrs_type2_s3_integer_bare_ordered"; case vctrs_type2_s3_integer_bare_date: return "vctrs_type2_s3_integer_bare_date"; case vctrs_type2_s3_integer_bare_posixct: return "vctrs_type2_s3_integer_bare_posixct"; case vctrs_type2_s3_integer_bare_posixlt: return "vctrs_type2_s3_integer_bare_posixlt"; case vctrs_type2_s3_integer_bare_tibble: return "vctrs_type2_s3_integer_bare_tibble"; case vctrs_type2_s3_integer_unknown: return "vctrs_type2_s3_integer_unknown"; case vctrs_type2_s3_double_bare_factor: return "vctrs_type2_s3_double_bare_factor"; case vctrs_type2_s3_double_bare_ordered: return "vctrs_type2_s3_double_bare_ordered"; case vctrs_type2_s3_double_bare_date: return "vctrs_type2_s3_double_bare_date"; case vctrs_type2_s3_double_bare_posixct: return "vctrs_type2_s3_double_bare_posixct"; case vctrs_type2_s3_double_bare_posixlt: return "vctrs_type2_s3_double_bare_posixlt"; case vctrs_type2_s3_double_bare_tibble: return "vctrs_type2_s3_double_bare_tibble"; case vctrs_type2_s3_double_unknown: return "vctrs_type2_s3_double_unknown"; case vctrs_type2_s3_complex_bare_factor: return "vctrs_type2_s3_complex_bare_factor"; case vctrs_type2_s3_complex_bare_ordered: return "vctrs_type2_s3_complex_bare_ordered"; case vctrs_type2_s3_complex_bare_date: return "vctrs_type2_s3_complex_bare_date"; case vctrs_type2_s3_complex_bare_posixct: return "vctrs_type2_s3_complex_bare_posixct"; case vctrs_type2_s3_complex_bare_posixlt: return "vctrs_type2_s3_complex_bare_posixlt"; case vctrs_type2_s3_complex_bare_tibble: return "vctrs_type2_s3_complex_bare_tibble"; case vctrs_type2_s3_complex_unknown: return "vctrs_type2_s3_complex_unknown"; case vctrs_type2_s3_character_bare_factor: return "vctrs_type2_s3_character_bare_factor"; case vctrs_type2_s3_character_bare_ordered: return "vctrs_type2_s3_character_bare_ordered"; case vctrs_type2_s3_character_bare_date: return "vctrs_type2_s3_character_bare_date"; case vctrs_type2_s3_character_bare_posixct: return "vctrs_type2_s3_character_bare_posixct"; case vctrs_type2_s3_character_bare_posixlt: return "vctrs_type2_s3_character_bare_posixlt"; case vctrs_type2_s3_character_bare_tibble: return "vctrs_type2_s3_character_bare_tibble"; case vctrs_type2_s3_character_unknown: return "vctrs_type2_s3_character_unknown"; case vctrs_type2_s3_raw_bare_factor: return "vctrs_type2_s3_raw_bare_factor"; case vctrs_type2_s3_raw_bare_ordered: return "vctrs_type2_s3_raw_bare_ordered"; case vctrs_type2_s3_raw_bare_date: return "vctrs_type2_s3_raw_bare_date"; case vctrs_type2_s3_raw_bare_posixct: return "vctrs_type2_s3_raw_bare_posixct"; case vctrs_type2_s3_raw_bare_posixlt: return "vctrs_type2_s3_raw_bare_posixlt"; case vctrs_type2_s3_raw_bare_tibble: return "vctrs_type2_s3_raw_bare_tibble"; case vctrs_type2_s3_raw_unknown: return "vctrs_type2_s3_raw_unknown"; case vctrs_type2_s3_list_bare_factor: return "vctrs_type2_s3_list_bare_factor"; case vctrs_type2_s3_list_bare_ordered: return "vctrs_type2_s3_list_bare_ordered"; case vctrs_type2_s3_list_bare_date: return "vctrs_type2_s3_list_bare_date"; case vctrs_type2_s3_list_bare_posixct: return "vctrs_type2_s3_list_bare_posixct"; case vctrs_type2_s3_list_bare_posixlt: return "vctrs_type2_s3_list_bare_posixlt"; case vctrs_type2_s3_list_bare_tibble: return "vctrs_type2_s3_list_bare_tibble"; case vctrs_type2_s3_list_unknown: return "vctrs_type2_s3_list_unknown"; case vctrs_type2_s3_dataframe_bare_factor: return "vctrs_type2_s3_dataframe_bare_factor"; case vctrs_type2_s3_dataframe_bare_ordered: return "vctrs_type2_s3_dataframe_bare_ordered"; case vctrs_type2_s3_dataframe_bare_date: return "vctrs_type2_s3_dataframe_bare_date"; case vctrs_type2_s3_dataframe_bare_posixct: return "vctrs_type2_s3_dataframe_bare_posixct"; case vctrs_type2_s3_dataframe_bare_posixlt: return "vctrs_type2_s3_dataframe_bare_posixlt"; case vctrs_type2_s3_dataframe_bare_tibble: return "vctrs_type2_s3_dataframe_bare_tibble"; case vctrs_type2_s3_dataframe_unknown: return "vctrs_type2_s3_dataframe_unknown"; case vctrs_type2_s3_scalar_bare_factor: return "vctrs_type2_s3_scalar_bare_factor"; case vctrs_type2_s3_scalar_bare_ordered: return "vctrs_type2_s3_scalar_bare_ordered"; case vctrs_type2_s3_scalar_bare_date: return "vctrs_type2_s3_scalar_bare_date"; case vctrs_type2_s3_scalar_bare_posixct: return "vctrs_type2_s3_scalar_bare_posixct"; case vctrs_type2_s3_scalar_bare_posixlt: return "vctrs_type2_s3_scalar_bare_posixlt"; case vctrs_type2_s3_scalar_bare_tibble: return "vctrs_type2_s3_scalar_bare_tibble"; case vctrs_type2_s3_scalar_unknown: return "vctrs_type2_s3_scalar_unknown"; case vctrs_type2_s3_bare_factor_bare_factor: return "vctrs_type2_s3_bare_factor_bare_factor"; case vctrs_type2_s3_bare_factor_bare_ordered: return "vctrs_type2_s3_bare_factor_bare_ordered"; case vctrs_type2_s3_bare_factor_bare_date: return "vctrs_type2_s3_bare_factor_bare_date"; case vctrs_type2_s3_bare_factor_bare_posixct: return "vctrs_type2_s3_bare_factor_bare_posixct"; case vctrs_type2_s3_bare_factor_bare_posixlt: return "vctrs_type2_s3_bare_factor_bare_posixlt"; case vctrs_type2_s3_bare_factor_bare_tibble: return "vctrs_type2_s3_bare_factor_bare_tibble"; case vctrs_type2_s3_bare_factor_unknown: return "vctrs_type2_s3_bare_factor_unknown"; case vctrs_type2_s3_bare_ordered_bare_ordered: return "vctrs_type2_s3_bare_ordered_bare_ordered"; case vctrs_type2_s3_bare_ordered_bare_date: return "vctrs_type2_s3_bare_ordered_bare_date"; case vctrs_type2_s3_bare_ordered_bare_posixct: return "vctrs_type2_s3_bare_ordered_bare_posixct"; case vctrs_type2_s3_bare_ordered_bare_posixlt: return "vctrs_type2_s3_bare_ordered_bare_posixlt"; case vctrs_type2_s3_bare_ordered_bare_tibble: return "vctrs_type2_s3_bare_ordered_bare_tibble"; case vctrs_type2_s3_bare_ordered_unknown: return "vctrs_type2_s3_bare_ordered_unknown"; case vctrs_type2_s3_bare_date_bare_date: return "vctrs_type2_s3_bare_date_bare_date"; case vctrs_type2_s3_bare_date_bare_posixct: return "vctrs_type2_s3_bare_date_bare_posixct"; case vctrs_type2_s3_bare_date_bare_posixlt: return "vctrs_type2_s3_bare_date_bare_posixlt"; case vctrs_type2_s3_bare_date_bare_tibble: return "vctrs_type2_s3_bare_date_bare_tibble"; case vctrs_type2_s3_bare_date_unknown: return "vctrs_type2_s3_bare_date_unknown"; case vctrs_type2_s3_bare_posixct_bare_posixct: return "vctrs_type2_s3_bare_posixct_bare_posixct"; case vctrs_type2_s3_bare_posixct_bare_posixlt: return "vctrs_type2_s3_bare_posixct_bare_posixlt"; case vctrs_type2_s3_bare_posixct_bare_tibble: return "vctrs_type2_s3_bare_posixct_bare_tibble"; case vctrs_type2_s3_bare_posixct_unknown: return "vctrs_type2_s3_bare_posixct_unknown"; case vctrs_type2_s3_bare_posixlt_bare_posixlt: return "vctrs_type2_s3_bare_posixlt_bare_posixlt"; case vctrs_type2_s3_bare_posixlt_bare_tibble: return "vctrs_type2_s3_bare_posixlt_bare_tibble"; case vctrs_type2_s3_bare_posixlt_unknown: return "vctrs_type2_s3_bare_posixlt_unknown"; case vctrs_type2_s3_bare_tibble_bare_tibble: return "vctrs_type2_s3_bare_tibble_bare_tibble"; case vctrs_type2_s3_bare_tibble_unknown: return "vctrs_type2_s3_bare_tibble_unknown"; case vctrs_type2_s3_unknown_unknown: return "vctrs_type2_s3_unknown_unknown"; } never_reached("vctrs_type2_s3_as_str"); } // [[ register() ]] SEXP vctrs_typeof2_s3(SEXP x, SEXP y) { enum vctrs_type2_s3 type = vec_typeof2_s3(x, y); return Rf_mkString(vctrs_type2_s3_as_str(type)); } vctrs/src/cast-dispatch.c0000644000176200001440000000613213623013722015076 0ustar liggesusers#include "vctrs.h" #include "utils.h" static SEXP vec_cast_dispatch2(SEXP x, SEXP to, enum vctrs_type x_type, bool* lossy, struct vctrs_arg* x_arg, struct vctrs_arg* to_arg); // [[ include("vctrs.h") ]] SEXP vec_cast_dispatch(SEXP x, SEXP to, enum vctrs_type x_type, enum vctrs_type to_type, bool* lossy, struct vctrs_arg* x_arg, struct vctrs_arg* to_arg) { switch (to_type) { case vctrs_type_character: switch (class_type(x)) { case vctrs_class_bare_factor: return fct_as_character(x, x_arg); case vctrs_class_bare_ordered: return ord_as_character(x, x_arg); default: break; } break; case vctrs_type_dataframe: switch(class_type(x)) { case vctrs_class_bare_data_frame: Rf_errorcall(R_NilValue, "Internal error: `x` should have been classified as a `vctrs_type_dataframe`"); case vctrs_class_bare_tibble: return df_as_dataframe(x, to, x_arg, to_arg); default: break; } break; case vctrs_type_s3: return vec_cast_dispatch2(x, to, x_type, lossy, x_arg, to_arg); default: break; } return R_NilValue; } static SEXP vec_cast_dispatch2(SEXP x, SEXP to, enum vctrs_type x_type, bool* lossy, struct vctrs_arg* x_arg, struct vctrs_arg* to_arg) { switch (class_type(to)) { case vctrs_class_bare_factor: switch (x_type) { case vctrs_type_character: return chr_as_factor(x, to, lossy, to_arg); case vctrs_type_s3: switch (class_type(x)) { case vctrs_class_bare_factor: return fct_as_factor(x, to, lossy, x_arg, to_arg); default: break; } default: break; } break; case vctrs_class_bare_ordered: switch (x_type) { case vctrs_type_character: return chr_as_ordered(x, to, lossy, to_arg); case vctrs_type_s3: switch (class_type(x)) { case vctrs_class_bare_ordered: return ord_as_ordered(x, to, lossy, x_arg, to_arg); default: break; } default: break; } break; case vctrs_class_bare_tibble: switch (x_type) { case vctrs_type_dataframe: return df_as_dataframe(x, to, x_arg, to_arg); case vctrs_type_s3: switch (class_type(x)) { case vctrs_class_bare_data_frame: Rf_errorcall(R_NilValue, "Internal error: `x` should have been classified as a `vctrs_type_dataframe`"); case vctrs_class_bare_tibble: return df_as_dataframe(x, to, x_arg, to_arg); default: break; } default: break; } break; case vctrs_class_bare_data_frame: Rf_errorcall(R_NilValue, "Internal error: `to` should have been classified as a `vctrs_type_dataframe`"); default: break; } return R_NilValue; } vctrs/src/slice-array.c0000644000176200001440000006022013622451540014563 0ustar liggesusers#include "vctrs.h" #include "utils.h" /* * Array slicing works by treating the array as a 1D structure, and transforming * the `index` passed from R into a series of 1D indices that are used to * extract elements from `x` into the new result. * * Strides represent the offset between elements in the same dimension. For * a (2, 2, 2) array, the strides would be [1, 2, 4]. This means that if you * flattened this 3D array to 1D in a column major order, there is 1 space * between row elements, 2 spaces between column elements and 4 spaces between * elements in the third dimension. In practice, we only need the shape strides * since the first stride is always 1, so `vec_strides()` only returns the shape * strides. Strides are computed as a cumulative product of the `dim`, with an * initial value of `1`, this is what `vec_strides()` does. * * Using the strides, any array index can be converted to a 1D index. * This is what `vec_strided_loc()` does. In a (2, 2, 2) array, to find * the location at the index [1, 0, 1] (C-based index, 2nd row, 1st col, * 2nd elem in 3rd dim) you compute a sum product between the array index * and the strides. So it looks like: * loc = 1 * (1) + 0 * (2) + 1 * (4) = 5 * (loc is a C-based index into `x`) * Since the first stride is always one, we leave it off and just do: * loc = 1 + 0 * (2) + 1 * (4) = 5 * * Example: * x = (3, 3, 2) array * vec_slice(x, 2:3) * * strides = [3, 9] // (shape strides) * * Indices are C-based * * | array index | x index | how? * ------------------------------------------------------- * out[0] | [1, 0, 0] | 1 | 1 + 0 * (3) + 0 * (9) * out[1] | [2, 0, 0] | 2 | * out[2] | [1, 1, 0] | 4 | * ... | ... | ... | * out[9] | [2, 1, 1] | 14 | 2 + 1 * (3) + 1 * (9) * out[10] | [1, 2, 1] | 16 | * out[11] | [2, 2, 1] | 17 | * ^ ^ ^ * | \/ * | |- shape_index * |- size_index */ static SEXP vec_strides(const int* p_dim, const R_len_t shape_n) { SEXP strides = PROTECT(Rf_allocVector(INTSXP, shape_n)); int* p_strides = INTEGER(strides); int stride = 1; for (int i = 0; i < shape_n; ++i) { stride *= p_dim[i]; p_strides[i] = stride; } UNPROTECT(1); return strides; } static int vec_strided_loc(const int size_index, const int* p_shape_index, const int* p_strides, const R_len_t shape_n) { int loc = size_index; for (R_len_t i = 0; i < shape_n; ++i) { loc += p_strides[i] * p_shape_index[i]; } return loc; } // To keep the #define as compact as possible, we use a struct to pass around // important information. struct vec_slice_shaped_info { const int* p_dim; const int* p_strides; const int* p_index; int* p_shape_index; R_len_t dim_n; R_len_t shape_n; R_len_t index_n; R_len_t shape_elem_n; SEXP out_dim; }; #define SLICE_SHAPED_INDEX(RTYPE, CTYPE, DEREF, CONST_DEREF, NA_VALUE) \ SEXP out = PROTECT(Rf_allocArray(RTYPE, info.out_dim)); \ CTYPE* out_data = DEREF(out); \ const CTYPE* x_data = CONST_DEREF(x); \ \ for (int i = 0; i < info.shape_elem_n; ++i) { \ \ /* Find and add the next `x` element */ \ for (int j = 0; j < info.index_n; ++j, ++out_data) { \ int size_index = info.p_index[j]; \ \ if (size_index == NA_INTEGER) { \ *out_data = NA_VALUE; \ } else { \ int loc = vec_strided_loc( \ size_index - 1, \ info.p_shape_index, \ info.p_strides, \ info.shape_n \ ); \ *out_data = x_data[loc]; \ } \ } \ \ /* Update shape_index */ \ for (int j = 0; j < info.shape_n; ++j) { \ info.p_shape_index[j]++; \ if (info.p_shape_index[j] < info.p_dim[j + 1]) { \ break; \ } \ info.p_shape_index[j] = 0; \ } \ } \ \ UNPROTECT(1); \ return out #define SLICE_SHAPED_COMPACT_REP(RTYPE, CTYPE, DEREF, CONST_DEREF, NA_VALUE) \ SEXP out = PROTECT(Rf_allocArray(RTYPE, info.out_dim)); \ CTYPE* out_data = DEREF(out); \ \ int size_index = info.p_index[0]; \ if (size_index == NA_INTEGER) { \ R_len_t out_n = info.shape_elem_n * info.index_n; \ for (int i = 0; i < out_n; ++i, ++out_data) { \ *out_data = NA_VALUE; \ } \ UNPROTECT(1); \ return(out); \ } \ \ const CTYPE* x_data = CONST_DEREF(x); \ \ /* Convert to C index */ \ size_index = size_index - 1; \ \ for (int i = 0; i < info.shape_elem_n; ++i) { \ \ /* Find and add the next `x` element */ \ for (int j = 0; j < info.index_n; ++j, ++out_data) { \ int loc = vec_strided_loc( \ size_index, \ info.p_shape_index, \ info.p_strides, \ info.shape_n \ ); \ *out_data = x_data[loc]; \ } \ \ /* Update shape_index */ \ for (int j = 0; j < info.shape_n; ++j) { \ info.p_shape_index[j]++; \ if (info.p_shape_index[j] < info.p_dim[j + 1]) { \ break; \ } \ info.p_shape_index[j] = 0; \ } \ } \ \ UNPROTECT(1); \ return out #define SLICE_SHAPED_COMPACT_SEQ(RTYPE, CTYPE, DEREF, CONST_DEREF) \ SEXP out = PROTECT(Rf_allocArray(RTYPE, info.out_dim)); \ CTYPE* out_data = DEREF(out); \ \ R_len_t start = info.p_index[0]; \ R_len_t n = info.p_index[1]; \ R_len_t step = info.p_index[2]; \ \ const CTYPE* x_data = CONST_DEREF(x); \ \ for (int i = 0; i < info.shape_elem_n; ++i) { \ \ /* Find and add the next `x` element */ \ for (int j = 0, size_index = start; j < n; ++j, size_index += step, ++out_data) { \ int loc = vec_strided_loc( \ size_index, \ info.p_shape_index, \ info.p_strides, \ info.shape_n \ ); \ *out_data = x_data[loc]; \ } \ \ /* Update shape_index */ \ for (int j = 0; j < info.shape_n; ++j) { \ info.p_shape_index[j]++; \ if (info.p_shape_index[j] < info.p_dim[j + 1]) { \ break; \ } \ info.p_shape_index[j] = 0; \ } \ } \ \ UNPROTECT(1); \ return out #define SLICE_SHAPED(RTYPE, CTYPE, DEREF, CONST_DEREF, NA_VALUE) \ if (is_compact_rep(index)) { \ SLICE_SHAPED_COMPACT_REP(RTYPE, CTYPE, DEREF, CONST_DEREF, NA_VALUE); \ } else if (is_compact_seq(index)) { \ SLICE_SHAPED_COMPACT_SEQ(RTYPE, CTYPE, DEREF, CONST_DEREF); \ } else { \ SLICE_SHAPED_INDEX(RTYPE, CTYPE, DEREF, CONST_DEREF, NA_VALUE); \ } static SEXP lgl_slice_shaped(SEXP x, SEXP index, struct vec_slice_shaped_info info) { SLICE_SHAPED(LGLSXP, int, LOGICAL, LOGICAL_RO, NA_LOGICAL); } static SEXP int_slice_shaped(SEXP x, SEXP index, struct vec_slice_shaped_info info) { SLICE_SHAPED(INTSXP, int, INTEGER, INTEGER_RO, NA_INTEGER); } static SEXP dbl_slice_shaped(SEXP x, SEXP index, struct vec_slice_shaped_info info) { SLICE_SHAPED(REALSXP, double, REAL, REAL_RO, NA_REAL); } static SEXP cpl_slice_shaped(SEXP x, SEXP index, struct vec_slice_shaped_info info) { SLICE_SHAPED(CPLXSXP, Rcomplex, COMPLEX, COMPLEX_RO, vctrs_shared_na_cpl); } static SEXP chr_slice_shaped(SEXP x, SEXP index, struct vec_slice_shaped_info info) { SLICE_SHAPED(STRSXP, SEXP, STRING_PTR, STRING_PTR_RO, NA_STRING); } static SEXP raw_slice_shaped(SEXP x, SEXP index, struct vec_slice_shaped_info info) { SLICE_SHAPED(RAWSXP, Rbyte, RAW, RAW_RO, 0); } #undef SLICE_SHAPED #undef SLICE_SHAPED_COMPACT_REP #undef SLICE_SHAPED_COMPACT_SEQ #undef SLICE_SHAPED_INDEX #define SLICE_BARRIER_SHAPED_INDEX(RTYPE, GET, SET, NA_VALUE) \ SEXP out = PROTECT(Rf_allocArray(RTYPE, info.out_dim)); \ \ int out_loc = 0; \ \ for (int i = 0; i < info.shape_elem_n; ++i) { \ \ /* Find and add the next `x` element */ \ for (int j = 0; j < info.index_n; ++j, ++out_loc) { \ int size_index = info.p_index[j]; \ \ if (size_index == NA_INTEGER) { \ SET(out, out_loc, NA_VALUE); \ } else { \ int loc = vec_strided_loc( \ size_index - 1, \ info.p_shape_index, \ info.p_strides, \ info.shape_n \ ); \ SEXP elt = GET(x, loc); \ SET(out, out_loc, elt); \ } \ } \ \ /* Update shape_index */ \ for (int j = 0; j < info.shape_n; ++j) { \ info.p_shape_index[j]++; \ if (info.p_shape_index[j] < info.p_dim[j + 1]) { \ break; \ } \ info.p_shape_index[j] = 0; \ } \ } \ \ UNPROTECT(1); \ return out #define SLICE_BARRIER_SHAPED_COMPACT_REP(RTYPE, GET, SET, NA_VALUE) \ SEXP out = PROTECT(Rf_allocArray(RTYPE, info.out_dim)); \ \ int size_index = info.p_index[0]; \ if (size_index == NA_INTEGER) { \ R_len_t out_n = info.shape_elem_n * info.index_n; \ for (int i = 0; i < out_n; ++i) { \ SET(out, i, NA_VALUE); \ } \ UNPROTECT(1); \ return(out); \ } \ \ int out_loc = 0; \ \ /* Convert to C index */ \ size_index = size_index - 1; \ \ for (int i = 0; i < info.shape_elem_n; ++i) { \ \ /* Find and add the next `x` element */ \ for (int j = 0; j < info.index_n; ++j, ++out_loc) { \ int loc = vec_strided_loc( \ size_index, \ info.p_shape_index, \ info.p_strides, \ info.shape_n \ ); \ SEXP elt = GET(x, loc); \ SET(out, out_loc, elt); \ } \ \ /* Update shape_index */ \ for (int j = 0; j < info.shape_n; ++j) { \ info.p_shape_index[j]++; \ if (info.p_shape_index[j] < info.p_dim[j + 1]) { \ break; \ } \ info.p_shape_index[j] = 0; \ } \ } \ \ UNPROTECT(1); \ return out #define SLICE_BARRIER_SHAPED_COMPACT_SEQ(RTYPE, GET, SET) \ SEXP out = PROTECT(Rf_allocArray(RTYPE, info.out_dim)); \ \ R_len_t start = info.p_index[0]; \ R_len_t n = info.p_index[1]; \ R_len_t step = info.p_index[2]; \ \ int out_loc = 0; \ \ for (int i = 0; i < info.shape_elem_n; ++i) { \ \ /* Find and add the next `x` element */ \ for (int j = 0, size_index = start; j < n; ++j, size_index += step, ++out_loc) { \ int loc = vec_strided_loc( \ size_index, \ info.p_shape_index, \ info.p_strides, \ info.shape_n \ ); \ SEXP elt = GET(x, loc); \ SET(out, out_loc, elt); \ } \ \ /* Update shape_index */ \ for (int j = 0; j < info.shape_n; ++j) { \ info.p_shape_index[j]++; \ if (info.p_shape_index[j] < info.p_dim[j + 1]) { \ break; \ } \ info.p_shape_index[j] = 0; \ } \ } \ \ UNPROTECT(1); \ return out #define SLICE_BARRIER_SHAPED(RTYPE, GET, SET, NA_VALUE) \ if (is_compact_rep(index)) { \ SLICE_BARRIER_SHAPED_COMPACT_REP(RTYPE, GET, SET, NA_VALUE); \ } else if (is_compact_seq(index)) { \ SLICE_BARRIER_SHAPED_COMPACT_SEQ(RTYPE, GET, SET); \ } else { \ SLICE_BARRIER_SHAPED_INDEX(RTYPE, GET, SET, NA_VALUE); \ } static SEXP list_slice_shaped(SEXP x, SEXP index, struct vec_slice_shaped_info info) { SLICE_BARRIER_SHAPED(VECSXP, VECTOR_ELT, SET_VECTOR_ELT, R_NilValue); } #undef SLICE_BARRIER_SHAPED #undef SLICE_BARRIER_SHAPED_COMPACT_REP #undef SLICE_BARRIER_SHAPED_COMPACT_SEQ #undef SLICE_BARRIER_SHAPED_INDEX SEXP vec_slice_shaped_base(enum vctrs_type type, SEXP x, SEXP index, struct vec_slice_shaped_info info) { switch (type) { case vctrs_type_logical: return lgl_slice_shaped(x, index, info); case vctrs_type_integer: return int_slice_shaped(x, index, info); case vctrs_type_double: return dbl_slice_shaped(x, index, info); case vctrs_type_complex: return cpl_slice_shaped(x, index, info); case vctrs_type_character: return chr_slice_shaped(x, index, info); case vctrs_type_raw: return raw_slice_shaped(x, index, info); case vctrs_type_list: return list_slice_shaped(x, index, info); default: Rf_error("Internal error: Non-vector base type `%s` in `vec_slice_shaped_base()`", vec_type_as_str(type)); } } SEXP vec_slice_shaped(enum vctrs_type type, SEXP x, SEXP index) { SEXP dim = PROTECT(vec_dim(x)); struct vec_slice_shaped_info info; info.p_dim = INTEGER_RO(dim); info.p_index = INTEGER_RO(index); info.dim_n = Rf_length(dim); info.shape_n = info.dim_n - 1; info.index_n = vec_subscript_size(index); SEXP strides = PROTECT(vec_strides(info.p_dim, info.shape_n)); info.p_strides = INTEGER_RO(strides); // `out_dim` has the same shape as `x`, with an altered size // corresponding to the length of the `index` info.out_dim = PROTECT(Rf_shallow_duplicate(dim)); INTEGER(info.out_dim)[0] = info.index_n; // Initialize `shape_index` to 0 SEXP shape_index = PROTECT(Rf_allocVector(INTSXP, info.shape_n)); info.p_shape_index = INTEGER(shape_index); for (int i = 0; i < info.shape_n; ++i) { info.p_shape_index[i] = 0; } info.shape_elem_n = 1; for (int i = 1; i < info.dim_n; ++i) { info.shape_elem_n *= info.p_dim[i]; } SEXP out = vec_slice_shaped_base(type, x, index, info); UNPROTECT(4); return out; } vctrs/src/c.c0000644000176200001440000001321213622451540012571 0ustar liggesusers#include "vctrs.h" #include "utils.h" // From type.c SEXP vctrs_type_common_impl(SEXP dots, SEXP ptype); // From slice-assign.c SEXP vec_assign_impl(SEXP proxy, SEXP index, SEXP value, bool clone); static bool list_has_inner_names(SEXP xs); // [[ register(external = TRUE) ]] SEXP vctrs_c(SEXP call, SEXP op, SEXP args, SEXP env) { args = CDR(args); SEXP xs = PROTECT(rlang_env_dots_list(env)); SEXP ptype = PROTECT(Rf_eval(CAR(args), env)); args = CDR(args); SEXP name_spec = PROTECT(Rf_eval(CAR(args), env)); args = CDR(args); SEXP name_repair = PROTECT(Rf_eval(CAR(args), env)); struct name_repair_opts name_repair_opts = new_name_repair_opts(name_repair, false); PROTECT_NAME_REPAIR_OPTS(&name_repair_opts); SEXP out = vec_c(xs, ptype, name_spec, &name_repair_opts); UNPROTECT(5); return out; } static inline bool needs_vec_c_fallback(SEXP xs); static SEXP vec_c_fallback(SEXP xs); static inline int vec_c_fallback_validate_args(SEXP ptype, SEXP name_spec); static void stop_vec_c_fallback(SEXP xs, int err_type); static bool vec_implements_base_c(SEXP x); // [[ include("vctrs.h") ]] SEXP vec_c(SEXP xs, SEXP ptype, SEXP name_spec, const struct name_repair_opts* name_repair) { R_len_t n = Rf_length(xs); if (needs_vec_c_fallback(xs)) { int err_type = vec_c_fallback_validate_args(ptype, name_spec); if (err_type) { stop_vec_c_fallback(xs, err_type); } SEXP out = vec_c_fallback(xs); return out; } ptype = PROTECT(vctrs_type_common_impl(xs, ptype)); if (ptype == R_NilValue) { UNPROTECT(1); return R_NilValue; } // Find individual input sizes and total size of output R_len_t out_size = 0; SEXP ns_placeholder = PROTECT(Rf_allocVector(INTSXP, n)); int* ns = INTEGER(ns_placeholder); for (R_len_t i = 0; i < n; ++i) { SEXP elt = VECTOR_ELT(xs, i); R_len_t size = (elt == R_NilValue) ? 0 : vec_size(elt); out_size += size; ns[i] = size; } PROTECT_INDEX out_pi; SEXP out = vec_init(ptype, out_size); PROTECT_WITH_INDEX(out, &out_pi); out = vec_proxy(out); REPROTECT(out, out_pi); SEXP idx = PROTECT(compact_seq(0, 0, true)); int* idx_ptr = INTEGER(idx); SEXP xs_names = PROTECT(r_names(xs)); bool has_names = xs_names != R_NilValue || list_has_inner_names(xs); has_names = has_names && !is_data_frame(ptype); SEXP out_names = has_names ? Rf_allocVector(STRSXP, out_size) : R_NilValue; PROTECT(out_names); bool is_shaped = has_dim(ptype); // Compact sequences use 0-based counters R_len_t counter = 0; for (R_len_t i = 0; i < n; ++i) { R_len_t size = ns[i]; if (!size) { continue; } // TODO SEXP x = VECTOR_ELT(xs, i); SEXP elt = PROTECT(vec_cast(x, ptype, args_empty, args_empty)); init_compact_seq(idx_ptr, counter, size, true); if (is_shaped) { SEXP idx = PROTECT(r_seq(counter + 1, counter + size + 1)); out = vec_assign(out, idx, elt); REPROTECT(out, out_pi); UNPROTECT(1); } else { vec_assign_impl(out, idx, elt, false); } if (has_names) { SEXP outer = xs_names == R_NilValue ? R_NilValue : STRING_ELT(xs_names, i); SEXP inner = PROTECT(vec_names(x)); SEXP x_nms = PROTECT(apply_name_spec(name_spec, outer, inner, size)); if (x_nms != R_NilValue) { vec_assign_impl(out_names, idx, x_nms, false); } UNPROTECT(2); } counter += size; UNPROTECT(1); } out = PROTECT(vec_restore(out, ptype, R_NilValue)); if (has_names) { out_names = PROTECT(vec_as_names(out_names, name_repair)); out = vec_set_names(out, out_names); REPROTECT(out, out_pi); UNPROTECT(1); } UNPROTECT(7); return out; } static bool list_has_inner_names(SEXP xs) { R_len_t n = Rf_length(xs); for (R_len_t i = 0; i < n; ++i) { SEXP elt = VECTOR_ELT(xs, i); if (vec_names(elt) != R_NilValue) { return true; } } return false; } static bool vec_implements_base_c(SEXP x) { return OBJECT(x) && s3_find_method("c", x, base_method_table) != R_NilValue; } static inline bool needs_vec_c_fallback(SEXP xs) { if (!Rf_length(xs)) { return false; } SEXP x = list_first_non_null(xs, NULL); if (!vec_is_vector(x)) { return false; } return !vec_implements_ptype2(x) && list_is_s3_homogeneous(xs); } static SEXP vec_c_fallback(SEXP xs) { SEXP args = PROTECT(Rf_coerceVector(xs, LISTSXP)); args = PROTECT(node_compact_d(args)); if (!vec_implements_base_c(CAR(args))) { stop_vec_c_fallback(xs, 3); } SEXP call = PROTECT(Rf_lcons(Rf_install("c"), args)); // Dispatch in the base namespace which inherits from the global env SEXP out = Rf_eval(call, R_BaseNamespace); UNPROTECT(3); return out; } static inline int vec_c_fallback_validate_args(SEXP ptype, SEXP name_spec) { if (ptype != R_NilValue) { return 1; } if (name_spec != R_NilValue) { return 2; } return 0; } static void stop_vec_c_fallback(SEXP xs, int err_type) { SEXP common_class = PROTECT(r_class(list_first_non_null(xs, NULL))); const char* class_str = r_chr_get_c_string(common_class, 0); const char* msg = NULL; switch (err_type) { case 1: msg = "Can't specify a prototype with non-vctrs types."; break; case 2: msg = "Can't use a name specification with non-vctrs types."; break; case 3: msg = "Can't find vctrs or base methods for concatenation."; break; default: msg = "Internal error: Unexpected error type."; break; } Rf_errorcall(R_NilValue, "%s\n" "vctrs methods must be implemented for class `%s`.\n" "See .", msg, class_str); } vctrs/src/type-info.c0000644000176200001440000001321713623045211014261 0ustar liggesusers#include "vctrs.h" #include "utils.h" #include "arg-counter.h" // Initialised at load time static SEXP syms_vec_is_vector_dispatch = NULL; static SEXP fns_vec_is_vector_dispatch = NULL; // From proxy.c SEXP vec_proxy_method(SEXP x); SEXP vec_proxy_invoke(SEXP x, SEXP method); static enum vctrs_type vec_base_typeof(SEXP x, bool proxied); // [[ include("vctrs.h") ]] struct vctrs_type_info vec_type_info(SEXP x) { struct vctrs_type_info info; info.type = vec_typeof(x); switch (info.type) { case vctrs_type_s3: info.proxy_method = vec_proxy_method(x); break; default: info.proxy_method = R_NilValue; } return info; } // [[ include("vctrs.h") ]] struct vctrs_proxy_info vec_proxy_info(SEXP x) { struct vctrs_proxy_info info; info.proxy_method = OBJECT(x) ? vec_proxy_method(x) : R_NilValue; PROTECT(info.proxy_method); if (info.proxy_method == R_NilValue) { info.type = vec_base_typeof(x, false); info.proxy = x; } else { SEXP proxy = PROTECT(vec_proxy_invoke(x, info.proxy_method)); info.type = vec_base_typeof(proxy, true); info.proxy = proxy; UNPROTECT(1); } UNPROTECT(1); return info; } // [[ register() ]] SEXP vctrs_type_info(SEXP x) { struct vctrs_type_info info = vec_type_info(x); SEXP out = PROTECT(Rf_mkNamed(VECSXP, (const char*[]) { "type", "proxy_method", "" })); SET_VECTOR_ELT(out, 0, Rf_mkString(vec_type_as_str(info.type))); SET_VECTOR_ELT(out, 1, info.proxy_method); UNPROTECT(1); return out; } // [[ register() ]] SEXP vctrs_proxy_info(SEXP x) { struct vctrs_proxy_info info = vec_proxy_info(x); SEXP out = PROTECT(Rf_mkNamed(VECSXP, (const char*[]) { "type", "proxy_method", "proxy", "" })); SET_VECTOR_ELT(out, 0, Rf_mkString(vec_type_as_str(info.type))); SET_VECTOR_ELT(out, 1, info.proxy_method); SET_VECTOR_ELT(out, 2, info.proxy); UNPROTECT(1); return out; } static enum vctrs_type vec_base_typeof(SEXP x, bool proxied) { switch (TYPEOF(x)) { // Atomic types are always vectors case NILSXP: return vctrs_type_null; case LGLSXP: return vctrs_type_logical; case INTSXP: return vctrs_type_integer; case REALSXP: return vctrs_type_double; case CPLXSXP: return vctrs_type_complex; case STRSXP: return vctrs_type_character; case RAWSXP: return vctrs_type_raw; case VECSXP: // Bare lists and data frames are vectors if (!OBJECT(x)) return vctrs_type_list; if (is_data_frame(x)) return vctrs_type_dataframe; // S3 lists are only vectors if they are proxied if (proxied || Rf_inherits(x, "list")) return vctrs_type_list; // fallthrough default: return vctrs_type_scalar; } } // [[ include("vctrs.h") ]] enum vctrs_type vec_proxy_typeof(SEXP x) { return vec_base_typeof(x, true); } bool vec_is_list(SEXP x) { if (TYPEOF(x) != VECSXP) { return false; } switch(class_type(x)) { // Bare list case vctrs_class_none: return true; // Explicit lists case vctrs_class_list: case vctrs_class_list_of: return true; // Non-explicit S3 lists case vctrs_class_unknown: return vec_is_vector(x); // TODO: Can this ever be considered a list? case vctrs_class_rcrd: return false; // List-like classes known by `class_type()`. // All data frame classes, posixlt. default: return false; } } // [[ register() ]] SEXP vctrs_is_list(SEXP x) { return Rf_ScalarLogical(vec_is_list(x)); } // [[ include("vctrs.h") ]] bool vec_is_vector(SEXP x) { if (x == R_NilValue) { return false; } struct vctrs_proxy_info info = vec_proxy_info(x); return info.type != vctrs_type_scalar; } // [[ register() ]] SEXP vctrs_is_vector(SEXP x) { return Rf_ScalarLogical(vec_is_vector(x)); } static bool class_is_null(SEXP x) { return Rf_getAttrib(x, R_ClassSymbol) == R_NilValue; } // [[ include("vctrs.h") ]] enum vctrs_type vec_typeof(SEXP x) { // Check for unspecified vectors before `vec_base_typeof()` which // allows vectors of `NA` to pass through as `vctrs_type_logical` if (vec_is_unspecified(x)) { return vctrs_type_unspecified; } if (!OBJECT(x) || class_is_null(x)) { return vec_base_typeof(x, false); } // Bare data frames are treated as a base atomic type. Subclasses of // data frames are treated as S3 to give them a chance to be proxied // or implement their own methods for cast, type2, etc. if (is_bare_data_frame(x)) { return vctrs_type_dataframe; } return vctrs_type_s3; } // [[ register() ]] SEXP vctrs_typeof(SEXP x, SEXP dispatch) { enum vctrs_type type; if (LOGICAL(dispatch)[0]) { type = vec_proxy_info(x).type; } else { type = vec_typeof(x); } return Rf_mkString(vec_type_as_str(type)); } void vctrs_stop_unsupported_type(enum vctrs_type type, const char* fn) { Rf_errorcall(R_NilValue, "Unsupported vctrs type `%s` in `%s`", vec_type_as_str(type), fn); } const char* vec_type_as_str(enum vctrs_type type) { switch (type) { case vctrs_type_null: return "null"; case vctrs_type_unspecified: return "unspecified"; case vctrs_type_logical: return "logical"; case vctrs_type_integer: return "integer"; case vctrs_type_double: return "double"; case vctrs_type_complex: return "complex"; case vctrs_type_character: return "character"; case vctrs_type_raw: return "raw"; case vctrs_type_list: return "list"; case vctrs_type_dataframe: return "dataframe"; case vctrs_type_s3: return "s3"; case vctrs_type_scalar: return "scalar"; } never_reached("vec_type_as_str"); } void vctrs_init_type_info(SEXP ns) { syms_vec_is_vector_dispatch = Rf_install("vec_is_vector"); fns_vec_is_vector_dispatch = Rf_findVar(syms_vec_is_vector_dispatch, ns); } vctrs/src/type2.c0000644000176200001440000001172013623013722013411 0ustar liggesusers#include "vctrs.h" #include "type-data-frame.h" #include "utils.h" // [[ include("vctrs.h") ]] SEXP vec_type2(SEXP x, SEXP y, struct vctrs_arg* x_arg, struct vctrs_arg* y_arg, int* left) { if (x == R_NilValue) { if (!vec_is_partial(y)) { vec_assert(y, y_arg); } *left = y == R_NilValue; return vec_type(y); } if (y == R_NilValue) { if (!vec_is_partial(x)) { vec_assert(x, x_arg); } *left = x == R_NilValue; return vec_type(x); } if (has_dim(x) || has_dim(y)) { return vec_ptype2_dispatch_s3(x, y, x_arg, y_arg); } enum vctrs_type type_x = vec_typeof(x); enum vctrs_type type_y = vec_typeof(y); if (type_x == vctrs_type_scalar) { stop_scalar_type(x, x_arg); } if (type_y == vctrs_type_scalar) { stop_scalar_type(y, y_arg); } if (type_x == vctrs_type_unspecified) { return vec_type(y); } if (type_y == vctrs_type_unspecified) { return vec_type(x); } if (type_x == vctrs_type_s3 || type_y == vctrs_type_s3) { return vec_ptype2_dispatch(x, y, type_x, type_y, x_arg, y_arg, left); } enum vctrs_type2 type2 = vec_typeof2_impl(type_x, type_y, left); switch (type2) { case vctrs_type2_null_null: return R_NilValue; case vctrs_type2_logical_logical: return vctrs_shared_empty_lgl; case vctrs_type2_logical_integer: case vctrs_type2_integer_integer: return vctrs_shared_empty_int; case vctrs_type2_logical_double: case vctrs_type2_integer_double: case vctrs_type2_double_double: return vctrs_shared_empty_dbl; case vctrs_type2_character_character: return vctrs_shared_empty_chr; case vctrs_type2_raw_raw: return vctrs_shared_empty_raw; case vctrs_type2_list_list: return vctrs_shared_empty_list; case vctrs_type2_dataframe_dataframe: return df_ptype2(x, y, x_arg, y_arg); default: return vec_ptype2_dispatch_s3(x, y, x_arg, y_arg); } } // [[ include("vctrs.h") ]] SEXP df_ptype2(SEXP x, SEXP y, struct vctrs_arg* x_arg, struct vctrs_arg* y_arg) { SEXP x_names = PROTECT(r_names(x)); SEXP y_names = PROTECT(r_names(y)); SEXP x_dups_pos = PROTECT(vec_match(x_names, y_names)); SEXP y_dups_pos = PROTECT(vec_match(y_names, x_names)); int* x_dups_pos_data = INTEGER(x_dups_pos); int* y_dups_pos_data = INTEGER(y_dups_pos); R_len_t x_len = Rf_length(x_dups_pos); R_len_t y_len = Rf_length(y_dups_pos); // Count columns that are only in `y` R_len_t rest_len = 0; for (R_len_t i = 0; i < y_len; ++i) { if (y_dups_pos_data[i] == NA_INTEGER) { ++rest_len; } } R_len_t out_len = x_len + rest_len; SEXP out = PROTECT(Rf_allocVector(VECSXP, out_len)); SEXP nms = PROTECT(Rf_allocVector(STRSXP, out_len)); Rf_setAttrib(out, R_NamesSymbol, nms); R_len_t i = 0; // Fill in prototypes of all the columns that are in `x`, in order for (; i < x_len; ++i) { R_len_t dup = x_dups_pos_data[i]; SEXP type; if (dup == NA_INTEGER) { type = vec_type(VECTOR_ELT(x, i)); } else { --dup; // 1-based index struct arg_data_index x_arg_data = new_index_arg_data(r_chr_get_c_string(x_names, i), x_arg); struct arg_data_index y_arg_data = new_index_arg_data(r_chr_get_c_string(y_names, dup), y_arg); struct vctrs_arg named_x_arg = new_index_arg(x_arg, &x_arg_data); struct vctrs_arg named_y_arg = new_index_arg(y_arg, &y_arg_data); int _left; type = vec_type2(VECTOR_ELT(x, i), VECTOR_ELT(y, dup), &named_x_arg, &named_y_arg, &_left); } SET_VECTOR_ELT(out, i, type); SET_STRING_ELT(nms, i, STRING_ELT(x_names, i)); } // Fill in prototypes of the columns that are only in `y` for (R_len_t j = 0; i < out_len; ++j) { R_len_t dup = y_dups_pos_data[j]; if (dup == NA_INTEGER) { SET_VECTOR_ELT(out, i, vec_type(VECTOR_ELT(y, j))); SET_STRING_ELT(nms, i, STRING_ELT(y_names, j)); ++i; } } init_data_frame(out, 0); UNPROTECT(6); return out; } // [[ register() ]] SEXP vctrs_type2(SEXP x, SEXP y, SEXP x_arg, SEXP y_arg) { if (!r_is_string(x_arg)) { Rf_errorcall(R_NilValue, "`x_arg` must be a string"); } if (!r_is_string(y_arg)) { Rf_errorcall(R_NilValue, "`y_arg` must be a string"); } struct vctrs_arg x_arg_ = new_wrapper_arg(NULL, r_chr_get_c_string(x_arg, 0)); struct vctrs_arg y_arg_ = new_wrapper_arg(NULL, r_chr_get_c_string(y_arg, 0)); int _left; return vec_type2(x, y, &x_arg_, &y_arg_, &_left); } // [[ register() ]] SEXP vctrs_type2_df_df(SEXP x, SEXP y, SEXP x_arg, SEXP y_arg) { if (!r_is_string(x_arg)) { Rf_errorcall(R_NilValue, "`x_arg` must be a string"); } if (!r_is_string(y_arg)) { Rf_errorcall(R_NilValue, "`y_arg` must be a string"); } struct vctrs_arg x_arg_ = new_wrapper_arg(NULL, r_chr_get_c_string(x_arg, 0)); struct vctrs_arg y_arg_ = new_wrapper_arg(NULL, r_chr_get_c_string(y_arg, 0)); return df_ptype2(x, y, &x_arg_, &y_arg_); } vctrs/src/init.c0000644000176200001440000003211113623203263013307 0ustar liggesusers#include #include #include // for NULL #include // for bool #include #include "altrep-rle.h" #include "vctrs.h" /* FIXME: Check these declarations against the C/Fortran source code. */ /* .Call calls */ extern SEXP vctrs_list_get(SEXP, SEXP); extern SEXP vctrs_list_set(SEXP, SEXP, SEXP); extern SEXP vctrs_field_get(SEXP, SEXP); extern SEXP vctrs_field_set(SEXP, SEXP, SEXP); extern SEXP vctrs_fields(SEXP); extern SEXP vctrs_n_fields(SEXP); extern SEXP vctrs_hash(SEXP); extern SEXP vctrs_hash_object(SEXP); extern SEXP vctrs_equal_object(SEXP, SEXP); extern SEXP vctrs_in(SEXP, SEXP); extern SEXP vctrs_duplicated(SEXP); extern SEXP vctrs_unique_loc(SEXP); extern SEXP vctrs_count(SEXP); extern SEXP vctrs_id(SEXP); extern SEXP vctrs_n_distinct(SEXP); extern SEXP vec_split(SEXP, SEXP); extern SEXP vctrs_group_id(SEXP); extern SEXP vctrs_group_rle(SEXP); extern SEXP vec_group_loc(SEXP); extern SEXP vctrs_equal(SEXP, SEXP, SEXP); extern SEXP vctrs_equal_na(SEXP); extern SEXP vctrs_compare(SEXP, SEXP, SEXP); extern SEXP vec_match(SEXP, SEXP); extern SEXP vctrs_duplicated_any(SEXP); extern SEXP vctrs_size(SEXP); extern SEXP vec_dim(SEXP); extern SEXP vctrs_dim_n(SEXP); extern SEXP vctrs_is_unspecified(SEXP); extern SEXP vctrs_typeof(SEXP, SEXP); extern SEXP vctrs_is_vector(SEXP); extern SEXP vctrs_type2(SEXP, SEXP, SEXP, SEXP); extern SEXP vctrs_typeof2(SEXP, SEXP); extern SEXP vctrs_typeof2_s3(SEXP, SEXP); extern SEXP vctrs_cast(SEXP, SEXP, SEXP, SEXP); extern SEXP vctrs_as_location(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP vctrs_slice(SEXP, SEXP); extern SEXP vctrs_init(SEXP, SEXP); extern SEXP vctrs_chop(SEXP, SEXP); extern SEXP vctrs_chop_seq(SEXP, SEXP, SEXP, SEXP); extern SEXP vec_slice_seq(SEXP, SEXP, SEXP, SEXP); extern SEXP vec_slice_rep(SEXP, SEXP, SEXP); extern SEXP vec_restore(SEXP, SEXP, SEXP); extern SEXP vec_restore_default(SEXP, SEXP); extern SEXP vec_proxy(SEXP); extern SEXP vec_proxy_equal(SEXP); extern SEXP vctrs_unspecified(SEXP); extern SEXP vec_type(SEXP); extern SEXP vec_ptype_finalise(SEXP); extern SEXP vctrs_minimal_names(SEXP); extern SEXP vctrs_unique_names(SEXP, SEXP); extern SEXP vctrs_as_minimal_names(SEXP); extern SEXP vec_names(SEXP); extern SEXP vctrs_is_unique_names(SEXP); extern SEXP vctrs_as_unique_names(SEXP, SEXP); extern SEXP vec_set_names(SEXP, SEXP); extern SEXP vctrs_df_as_dataframe(SEXP, SEXP, SEXP, SEXP); extern SEXP vctrs_type2_df_df(SEXP, SEXP, SEXP, SEXP); extern SEXP vctrs_type_info(SEXP); extern SEXP vctrs_proxy_info(SEXP); extern SEXP vctrs_class_type(SEXP); extern SEXP vec_bare_df_restore(SEXP, SEXP, SEXP); extern SEXP vctrs_recycle(SEXP, SEXP, SEXP); extern SEXP vctrs_coercible_cast(SEXP, SEXP, SEXP, SEXP); extern SEXP vec_assign(SEXP, SEXP, SEXP); extern SEXP vctrs_set_attributes(SEXP, SEXP); extern SEXP vctrs_as_df_row(SEXP, SEXP); extern SEXP vctrs_outer_names(SEXP, SEXP, SEXP); extern SEXP vctrs_df_size(SEXP); extern SEXP vctrs_as_df_col(SEXP, SEXP); extern SEXP vctrs_apply_name_spec(SEXP, SEXP, SEXP, SEXP); extern SEXP vctrs_proxy_recursive(SEXP, SEXP); extern SEXP vctrs_maybe_translate_encoding(SEXP); extern SEXP vctrs_maybe_translate_encoding2(SEXP, SEXP); extern SEXP vctrs_validate_name_repair_arg(SEXP); extern SEXP vctrs_validate_minimal_names(SEXP, SEXP); extern SEXP vctrs_as_names(SEXP, SEXP, SEXP); extern SEXP vctrs_is_partial(SEXP); extern SEXP vctrs_is_list(SEXP); // Very experimental // Available in the API header extern R_len_t vec_size(SEXP); extern SEXP vec_init(SEXP, R_len_t); extern SEXP vec_assign_impl(SEXP, SEXP, SEXP, bool); extern SEXP vec_slice_impl(SEXP, SEXP); extern SEXP vec_names(SEXP); extern SEXP vec_recycle(SEXP, R_len_t, struct vctrs_arg*); extern SEXP vec_chop(SEXP, SEXP); // Extremely experimental // Exported but not directly available in the API header extern SEXP compact_seq(R_len_t, R_len_t, bool); extern SEXP init_compact_seq(int*, R_len_t, R_len_t, bool); // Extremely experimental (for dplyr) extern bool vec_is_vector(SEXP); // Defined below SEXP vctrs_init_library(SEXP); // Defined in altrep-rle.h extern SEXP altrep_rle_Make(SEXP); void vctrs_init_altrep_rle(DllInfo* dll); static const R_CallMethodDef CallEntries[] = { {"vctrs_list_get", (DL_FUNC) &vctrs_list_get, 2}, {"vctrs_list_set", (DL_FUNC) &vctrs_list_set, 3}, {"vctrs_field_get", (DL_FUNC) &vctrs_field_get, 2}, {"vctrs_field_set", (DL_FUNC) &vctrs_field_set, 3}, {"vctrs_fields", (DL_FUNC) &vctrs_fields, 1}, {"vctrs_n_fields", (DL_FUNC) &vctrs_n_fields, 1}, {"vctrs_hash", (DL_FUNC) &vctrs_hash, 1}, {"vctrs_hash_object", (DL_FUNC) &vctrs_hash_object, 1}, {"vctrs_equal_object", (DL_FUNC) &vctrs_equal_object, 2}, {"vctrs_in", (DL_FUNC) &vctrs_in, 2}, {"vctrs_unique_loc", (DL_FUNC) &vctrs_unique_loc, 1}, {"vctrs_duplicated", (DL_FUNC) &vctrs_duplicated, 1}, {"vctrs_duplicated_any", (DL_FUNC) &vctrs_duplicated_any, 1}, {"vctrs_count", (DL_FUNC) &vctrs_count, 1}, {"vctrs_id", (DL_FUNC) &vctrs_id, 1}, {"vctrs_n_distinct", (DL_FUNC) &vctrs_n_distinct, 1}, {"vctrs_split", (DL_FUNC) &vec_split, 2}, {"vctrs_group_id", (DL_FUNC) &vctrs_group_id, 1}, {"vctrs_group_rle", (DL_FUNC) &vctrs_group_rle, 1}, {"vctrs_group_loc", (DL_FUNC) &vec_group_loc, 1}, {"vctrs_size", (DL_FUNC) &vctrs_size, 1}, {"vctrs_dim", (DL_FUNC) &vec_dim, 1}, {"vctrs_dim_n", (DL_FUNC) &vctrs_dim_n, 1}, {"vctrs_is_unspecified", (DL_FUNC) &vctrs_is_unspecified, 1}, {"vctrs_equal", (DL_FUNC) &vctrs_equal, 3}, {"vctrs_equal_na", (DL_FUNC) &vctrs_equal_na, 1}, {"vctrs_compare", (DL_FUNC) &vctrs_compare, 3}, {"vctrs_match", (DL_FUNC) &vec_match, 2}, {"vctrs_typeof", (DL_FUNC) &vctrs_typeof, 2}, {"vctrs_init_library", (DL_FUNC) &vctrs_init_library, 1}, {"vctrs_is_vector", (DL_FUNC) &vctrs_is_vector, 1}, {"vctrs_type2", (DL_FUNC) &vctrs_type2, 4}, {"vctrs_typeof2", (DL_FUNC) &vctrs_typeof2, 2}, {"vctrs_typeof2_s3", (DL_FUNC) &vctrs_typeof2_s3, 2}, {"vctrs_cast", (DL_FUNC) &vctrs_cast, 4}, {"vctrs_as_location", (DL_FUNC) &vctrs_as_location, 7}, {"vctrs_slice", (DL_FUNC) &vctrs_slice, 2}, {"vctrs_init", (DL_FUNC) &vctrs_init, 2}, {"vctrs_chop", (DL_FUNC) &vctrs_chop, 2}, {"vctrs_chop_seq", (DL_FUNC) &vctrs_chop_seq, 4}, {"vctrs_slice_seq", (DL_FUNC) &vec_slice_seq, 4}, {"vctrs_slice_rep", (DL_FUNC) &vec_slice_rep, 3}, {"vctrs_restore", (DL_FUNC) &vec_restore, 3}, {"vctrs_restore_default", (DL_FUNC) &vec_restore_default, 2}, {"vctrs_proxy", (DL_FUNC) &vec_proxy, 1}, {"vctrs_proxy_equal", (DL_FUNC) &vec_proxy_equal, 1}, {"vctrs_unspecified", (DL_FUNC) &vctrs_unspecified, 1}, {"vctrs_type", (DL_FUNC) &vec_type, 1}, {"vctrs_ptype_finalise", (DL_FUNC) &vec_ptype_finalise, 1}, {"vctrs_minimal_names", (DL_FUNC) &vctrs_minimal_names, 1}, {"vctrs_unique_names", (DL_FUNC) &vctrs_unique_names, 2}, {"vctrs_as_minimal_names", (DL_FUNC) &vctrs_as_minimal_names, 1}, {"vctrs_names", (DL_FUNC) &vec_names, 1}, {"vctrs_is_unique_names", (DL_FUNC) &vctrs_is_unique_names, 1}, {"vctrs_as_unique_names", (DL_FUNC) &vctrs_as_unique_names, 2}, {"vctrs_set_names", (DL_FUNC) &vec_set_names, 2}, {"vctrs_df_as_dataframe", (DL_FUNC) &vctrs_df_as_dataframe, 4}, {"vctrs_type2_df_df", (DL_FUNC) &vctrs_type2_df_df, 4}, {"vctrs_type_info", (DL_FUNC) &vctrs_type_info, 1}, {"vctrs_proxy_info", (DL_FUNC) &vctrs_proxy_info, 1}, {"vctrs_class_type", (DL_FUNC) &vctrs_class_type, 1}, {"vctrs_bare_df_restore", (DL_FUNC) &vec_bare_df_restore, 3}, {"vctrs_recycle", (DL_FUNC) &vctrs_recycle, 3}, {"vctrs_coercible_cast", (DL_FUNC) &vctrs_coercible_cast, 4}, {"vctrs_assign", (DL_FUNC) &vec_assign, 3}, {"vctrs_set_attributes", (DL_FUNC) &vctrs_set_attributes, 2}, {"vctrs_as_df_row", (DL_FUNC) &vctrs_as_df_row, 2}, {"vctrs_outer_names", (DL_FUNC) &vctrs_outer_names, 3}, {"vctrs_df_size", (DL_FUNC) &vctrs_df_size, 1}, {"vctrs_as_df_col", (DL_FUNC) &vctrs_as_df_col, 2}, {"vctrs_apply_name_spec", (DL_FUNC) &vctrs_apply_name_spec, 4}, {"vctrs_proxy_recursive", (DL_FUNC) &vctrs_proxy_recursive, 2}, {"vctrs_maybe_translate_encoding", (DL_FUNC) &vctrs_maybe_translate_encoding, 1}, {"vctrs_maybe_translate_encoding2", (DL_FUNC) &vctrs_maybe_translate_encoding2, 2}, {"vctrs_rle", (DL_FUNC) &altrep_rle_Make, 1}, {"vctrs_validate_name_repair_arg", (DL_FUNC) &vctrs_validate_name_repair_arg, 1}, {"vctrs_validate_minimal_names", (DL_FUNC) &vctrs_validate_minimal_names, 2}, {"vctrs_as_names", (DL_FUNC) &vctrs_as_names, 3}, {"vctrs_is_partial", (DL_FUNC) &vctrs_is_partial, 1}, {"vctrs_is_list", (DL_FUNC) &vctrs_is_list, 1}, {NULL, NULL, 0} }; extern SEXP vctrs_type_common(SEXP, SEXP, SEXP, SEXP); extern SEXP vctrs_size_common(SEXP, SEXP, SEXP, SEXP); extern SEXP vctrs_recycle_common(SEXP, SEXP, SEXP, SEXP); extern SEXP vctrs_cast_common(SEXP, SEXP, SEXP, SEXP); extern SEXP vctrs_rbind(SEXP, SEXP, SEXP, SEXP); extern SEXP vctrs_cbind(SEXP, SEXP, SEXP, SEXP); extern SEXP vctrs_c(SEXP, SEXP, SEXP, SEXP); extern SEXP vctrs_new_data_frame(SEXP); static const R_ExternalMethodDef ExtEntries[] = { {"vctrs_type_common", (DL_FUNC) &vctrs_type_common, 1}, {"vctrs_size_common", (DL_FUNC) &vctrs_size_common, 2}, {"vctrs_recycle_common", (DL_FUNC) &vctrs_recycle_common, 1}, {"vctrs_cast_common", (DL_FUNC) &vctrs_cast_common, 1}, {"vctrs_rbind", (DL_FUNC) &vctrs_rbind, 3}, {"vctrs_cbind", (DL_FUNC) &vctrs_cbind, 3}, {"vctrs_c", (DL_FUNC) &vctrs_c, 3}, {"vctrs_new_data_frame", (DL_FUNC) &vctrs_new_data_frame, -1}, {NULL, NULL, 0} }; void R_init_vctrs(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, ExtEntries); R_useDynamicSymbols(dll, FALSE); // Very experimental R_RegisterCCallable("vctrs", "vec_proxy", (DL_FUNC) &vec_proxy); R_RegisterCCallable("vctrs", "vec_restore", (DL_FUNC) &vec_restore); R_RegisterCCallable("vctrs", "vec_assign_impl", (DL_FUNC) &vec_assign_impl); R_RegisterCCallable("vctrs", "vec_slice_impl", (DL_FUNC) &vec_slice_impl); R_RegisterCCallable("vctrs", "vec_names", (DL_FUNC) &vec_names); R_RegisterCCallable("vctrs", "vec_set_names", (DL_FUNC) &vec_set_names); R_RegisterCCallable("vctrs", "vec_chop", (DL_FUNC) &vec_chop); // Extremely experimental // Exported but not directly available in the API header R_RegisterCCallable("vctrs", "vctrs_cast", (DL_FUNC) &vctrs_cast); R_RegisterCCallable("vctrs", "compact_seq", (DL_FUNC) &compact_seq); R_RegisterCCallable("vctrs", "init_compact_seq", (DL_FUNC) &init_compact_seq); // Extremely experimental as eventually these might support R_xlen_t R_RegisterCCallable("vctrs", "short_vec_size", (DL_FUNC) &vec_size); R_RegisterCCallable("vctrs", "short_vec_recycle", (DL_FUNC) &vec_recycle); R_RegisterCCallable("vctrs", "short_vec_init", (DL_FUNC) &vec_init); // Extremely experimental (for dplyr) R_RegisterCCallable("vctrs", "vec_is_vector", (DL_FUNC) &vec_is_vector); // Altrep classes vctrs_init_altrep_rle(dll); } void vctrs_init_cast(SEXP ns); void vctrs_init_data(SEXP ns); void vctrs_init_dictionary(SEXP ns); void vctrs_init_names(SEXP ns); void vctrs_init_proxy_restore(SEXP ns); void vctrs_init_slice(SEXP ns); void vctrs_init_slice_assign(SEXP ns); void vctrs_init_subscript_loc(SEXP ns); void vctrs_init_ptype2_dispatch(SEXP ns); void vctrs_init_type(SEXP ns); void vctrs_init_type_info(SEXP ns); void vctrs_init_unspecified(SEXP ns); void vctrs_init_utils(SEXP ns); SEXP vctrs_init_library(SEXP ns) { vctrs_init_cast(ns); vctrs_init_data(ns); vctrs_init_dictionary(ns); vctrs_init_names(ns); vctrs_init_proxy_restore(ns); vctrs_init_slice(ns); vctrs_init_slice_assign(ns); vctrs_init_subscript_loc(ns); vctrs_init_ptype2_dispatch(ns); vctrs_init_type(ns); vctrs_init_type_info(ns); vctrs_init_unspecified(ns); vctrs_init_utils(ns); return R_NilValue; } vctrs/src/type.c0000644000176200001440000001144513623013722013333 0ustar liggesusers#include "vctrs.h" #include "utils.h" #include "arg-counter.h" // Initialised at load time static SEXP syms_vec_ptype_finalise_dispatch = NULL; static SEXP fns_vec_ptype_finalise_dispatch = NULL; static SEXP vec_type_slice(SEXP x, SEXP empty); static SEXP s3_type(SEXP x); // [[ include("vctrs.h"); register() ]] SEXP vec_type(SEXP x) { switch (vec_typeof(x)) { case vctrs_type_null: return R_NilValue; case vctrs_type_unspecified: return vctrs_shared_empty_uns; case vctrs_type_logical: return vec_type_slice(x, vctrs_shared_empty_lgl); case vctrs_type_integer: return vec_type_slice(x, vctrs_shared_empty_int); case vctrs_type_double: return vec_type_slice(x, vctrs_shared_empty_dbl); case vctrs_type_complex: return vec_type_slice(x, vctrs_shared_empty_cpl); case vctrs_type_character: return vec_type_slice(x, vctrs_shared_empty_chr); case vctrs_type_raw: return vec_type_slice(x, vctrs_shared_empty_raw); case vctrs_type_list: return vec_type_slice(x, vctrs_shared_empty_list); case vctrs_type_dataframe: return bare_df_map(x, &vec_type); case vctrs_type_s3: return s3_type(x); case vctrs_type_scalar: stop_scalar_type(x, args_empty); } never_reached("vec_type_impl"); } static SEXP vec_type_slice(SEXP x, SEXP empty) { if (ATTRIB(x) == R_NilValue) { return empty; } else { // Slicing preserves attributes return vec_slice(x, R_NilValue); } } static SEXP s3_type(SEXP x) { switch(class_type(x)) { case vctrs_class_bare_tibble: return bare_df_map(x, &vec_type); case vctrs_class_data_frame: return df_map(x, &vec_type); case vctrs_class_bare_data_frame: Rf_errorcall(R_NilValue, "Internal error: Bare data frames should be handled by `vec_type()`"); case vctrs_class_none: Rf_errorcall(R_NilValue, "Internal error: Non-S3 classes should be handled by `vec_type()`"); default: break; } if (vec_is_partial(x)) { return x; } vec_assert(x, args_empty); return vec_slice(x, R_NilValue); } static SEXP vec_ptype_finalise_unspecified(SEXP x); static SEXP vec_ptype_finalise_dispatch(SEXP x); // [[ include("vctrs.h"); register() ]] SEXP vec_ptype_finalise(SEXP x) { if (x == R_NilValue) { return x; } if (!OBJECT(x)) { vec_assert(x, args_empty); return x; } if (vec_is_unspecified(x)) { return vec_ptype_finalise_unspecified(x); } if (vec_is_partial(x)) { return vec_ptype_finalise_dispatch(x); } vec_assert(x, args_empty); switch(class_type(x)) { case vctrs_class_bare_tibble: case vctrs_class_bare_data_frame: return bare_df_map(x, &vec_ptype_finalise); case vctrs_class_data_frame: return df_map(x, &vec_ptype_finalise); case vctrs_class_none: Rf_errorcall(R_NilValue, "Internal error: Non-S3 classes should have returned by now"); default: return vec_ptype_finalise_dispatch(x); } } static SEXP vec_ptype_finalise_unspecified(SEXP x) { R_len_t size = Rf_length(x); if (size == 0) { return vctrs_shared_empty_lgl; } SEXP out = PROTECT(Rf_allocVector(LGLSXP, size)); r_lgl_fill(out, NA_LOGICAL, size); UNPROTECT(1); return out; } static SEXP vec_ptype_finalise_dispatch(SEXP x) { return vctrs_dispatch1( syms_vec_ptype_finalise_dispatch, fns_vec_ptype_finalise_dispatch, syms_x, x ); } SEXP vctrs_type_common_impl(SEXP dots, SEXP ptype); static SEXP vctrs_type2_common(SEXP current, SEXP next, struct counters* counters); // [[ register(external = TRUE) ]] SEXP vctrs_type_common(SEXP call, SEXP op, SEXP args, SEXP env) { args = CDR(args); SEXP types = PROTECT(rlang_env_dots_values(env)); SEXP ptype = PROTECT(Rf_eval(CAR(args), env)); SEXP out = vctrs_type_common_impl(types, ptype); UNPROTECT(2); return out; } SEXP vctrs_type_common_impl(SEXP dots, SEXP ptype) { if (!vec_is_partial(ptype)) { return vec_type(ptype); } if (r_is_true(r_peek_option("vctrs.no_guessing"))) { Rf_errorcall(R_NilValue, "strict mode is activated; you must supply complete `.ptype`."); } // Start reduction with the `.ptype` argument struct vctrs_arg ptype_arg = new_wrapper_arg(NULL, ".ptype"); SEXP type = PROTECT(reduce(ptype, &ptype_arg, dots, &vctrs_type2_common)); type = vec_ptype_finalise(type); UNPROTECT(1); return type; } static SEXP vctrs_type2_common(SEXP current, SEXP next, struct counters* counters) { int left = -1; current = vec_type2(current, next, counters->curr_arg, counters->next_arg, &left); // Update current if RHS is the common type. Otherwise the previous // counter stays in effect. if (!left) { counters_shift(counters); } return current; } void vctrs_init_type(SEXP ns) { syms_vec_ptype_finalise_dispatch = Rf_install("vec_ptype_finalise_dispatch"); fns_vec_ptype_finalise_dispatch = Rf_findVar(syms_vec_ptype_finalise_dispatch, ns); } vctrs/src/slice-chop.c0000644000176200001440000002613113622451540014401 0ustar liggesusers#include "vctrs.h" #include "slice.h" #include "subscript-loc.h" #include "type-data-frame.h" #include "utils.h" /* * @member proxy_info The result of `vec_proxy_info(x)`. * @member restore_size The restore size used in each call to `vec_restore()`. * Will always be 1 for `indices = NULL`. * @member p_restore_size A pointer to update the restore size. * @member index The current index value. If `indices` are provided, this is * the i-th element of indices. For the default of `indices = NULL`, this * starts at 0 and is incremented by 1 repeatedly through `p_index`. * @member p_index A pointer to increment the `index` value for the default * case. * @member has_indices Whether indices were provided. * @member out_size The size of `out`. Will be `vec_size(x)` in the default * case, otherwise will be `vec_size(indices)`. * @member out The list container for the result. */ struct vctrs_chop_info { struct vctrs_proxy_info proxy_info; SEXP restore_size; int* p_restore_size; SEXP index; int* p_index; bool has_indices; R_len_t out_size; SEXP out; }; #define PROTECT_CHOP_INFO(info, n) do { \ PROTECT_PROXY_INFO(&(info)->proxy_info, n); \ PROTECT((info)->restore_size); \ PROTECT((info)->index); \ PROTECT((info)->out); \ *n += 3; \ } while (0) \ static struct vctrs_chop_info init_chop_info(SEXP x, SEXP indices) { int nprot = 0; struct vctrs_chop_info info; info.proxy_info = vec_proxy_info(x); PROTECT_PROXY_INFO(&info.proxy_info, &nprot); info.restore_size = PROTECT_N(r_int(1), &nprot); info.p_restore_size = INTEGER(info.restore_size); info.index = PROTECT_N(r_int(0), &nprot); info.p_index = INTEGER(info.index); if (indices == R_NilValue) { info.out_size = vec_size(x); info.has_indices = false; } else { info.out_size = vec_size(indices); info.has_indices = true; } info.out = PROTECT_N(Rf_allocVector(VECSXP, info.out_size), &nprot); UNPROTECT(nprot); return info; } // ----------------------------------------------------------------------------- static SEXP chop(SEXP x, SEXP indices, struct vctrs_chop_info info); static SEXP chop_shaped(SEXP x, SEXP indices, struct vctrs_chop_info info); static SEXP chop_df(SEXP x, SEXP indices, struct vctrs_chop_info info); static SEXP chop_fallback(SEXP x, SEXP indices, struct vctrs_chop_info info); static SEXP chop_fallback_shaped(SEXP x, SEXP indices, struct vctrs_chop_info info); static SEXP vec_chop_base(SEXP x, SEXP indices, struct vctrs_chop_info info); static SEXP vec_as_indices(SEXP indices, R_len_t n, SEXP names); // [[ register() ]] SEXP vctrs_chop_seq(SEXP x, SEXP starts, SEXP sizes, SEXP increasings) { int* p_starts = INTEGER(starts); int* p_sizes = INTEGER(sizes); int* p_increasings = LOGICAL(increasings); int n = Rf_length(starts); SEXP indices = PROTECT(Rf_allocVector(VECSXP, n)); for (int i = 0; i < n; ++i) { SEXP index = compact_seq(p_starts[i], p_sizes[i], p_increasings[i]); SET_VECTOR_ELT(indices, i, index); } SEXP out = PROTECT(vec_chop(x, indices)); UNPROTECT(2); return out; } // [[ register() ]] SEXP vctrs_chop(SEXP x, SEXP indices) { R_len_t n = vec_size(x); SEXP names = PROTECT(vec_names(x)); indices = PROTECT(vec_as_indices(indices, n, names)); SEXP out = PROTECT(vec_chop(x, indices)); UNPROTECT(3); return out; } // [[ include("vctrs.h") ]] SEXP vec_chop(SEXP x, SEXP indices) { int nprot = 0; struct vctrs_chop_info info = init_chop_info(x, indices); PROTECT_CHOP_INFO(&info, &nprot); SEXP out = PROTECT_N(vec_chop_base(x, indices, info), &nprot); UNPROTECT(nprot); return out; } static SEXP vec_chop_base(SEXP x, SEXP indices, struct vctrs_chop_info info) { struct vctrs_proxy_info proxy_info = info.proxy_info; // Fallback to `[` if the class doesn't implement a proxy. This is // to be maximally compatible with existing classes. if (vec_requires_fallback(x, proxy_info)) { if (proxy_info.type == vctrs_type_scalar) { Rf_errorcall(R_NilValue, "Can't slice a scalar"); } if (info.has_indices) { for (int i = 0; i < info.out_size; ++i) { SEXP index = VECTOR_ELT(indices, i); if (is_compact(index)) { SET_VECTOR_ELT(indices, i, compact_materialize(index)); } } } if (has_dim(x)) { return chop_fallback_shaped(x, indices, info); } return chop_fallback(x, indices, info); } switch (proxy_info.type) { case vctrs_type_logical: case vctrs_type_integer: case vctrs_type_double: case vctrs_type_complex: case vctrs_type_character: case vctrs_type_raw: case vctrs_type_list: { if (has_dim(x)) { return chop_shaped(x, indices, info); } return chop(x, indices, info); } case vctrs_type_dataframe: { return chop_df(x, indices, info); } default: vec_assert(x, args_empty); Rf_error( "Internal error: Unexpected type `%s` for vector proxy in `vec_chop()`", vec_type_as_str(proxy_info.type) ); } } static SEXP chop(SEXP x, SEXP indices, struct vctrs_chop_info info) { SEXP elt; SEXP names = PROTECT(Rf_getAttrib(x, R_NamesSymbol)); for (R_len_t i = 0; i < info.out_size; ++i) { if (info.has_indices) { info.index = VECTOR_ELT(indices, i); *info.p_restore_size = vec_subscript_size(info.index); } else { ++(*info.p_index); } elt = PROTECT(vec_slice_base(info.proxy_info.type, info.proxy_info.proxy, info.index)); if (names != R_NilValue) { SEXP elt_names = PROTECT(slice_names(names, info.index)); r_poke_names(elt, elt_names); UNPROTECT(1); } elt = vec_restore(elt, x, info.restore_size); SET_VECTOR_ELT(info.out, i, elt); UNPROTECT(1); } UNPROTECT(1); return info.out; } static SEXP chop_df(SEXP x, SEXP indices, struct vctrs_chop_info info) { SEXP elt; int n_cols = Rf_length(x); SEXP col_names = PROTECT(Rf_getAttrib(x, R_NamesSymbol)); SEXP row_names = PROTECT(df_rownames(x)); bool has_row_names = TYPEOF(row_names) == STRSXP; // Pre-load the `out` container with lists that will become data frames for (R_len_t i = 0; i < info.out_size; ++i) { elt = PROTECT(Rf_allocVector(VECSXP, n_cols)); Rf_setAttrib(elt, R_NamesSymbol, col_names); if (has_row_names) { if (info.has_indices) { info.index = VECTOR_ELT(indices, i); } else { ++(*info.p_index); } Rf_setAttrib(elt, R_RowNamesSymbol, slice_rownames(row_names, info.index)); } SET_VECTOR_ELT(info.out, i, elt); UNPROTECT(1); } // Split each column according to the indices, and then assign the results // into the appropriate data frame column in the `out` list for (int i = 0; i < n_cols; ++i) { SEXP col = VECTOR_ELT(info.proxy_info.proxy, i); SEXP split = PROTECT(vec_chop(col, indices)); for (int j = 0; j < info.out_size; ++j) { elt = VECTOR_ELT(info.out, j); SET_VECTOR_ELT(elt, i, VECTOR_ELT(split, j)); } UNPROTECT(1); } // Restore each data frame for (int i = 0; i < info.out_size; ++i) { if (info.has_indices) { *info.p_restore_size = vec_subscript_size(VECTOR_ELT(indices, i)); } elt = VECTOR_ELT(info.out, i); elt = vec_restore(elt, x, info.restore_size); SET_VECTOR_ELT(info.out, i, elt); } UNPROTECT(2); return info.out; } static SEXP chop_shaped(SEXP x, SEXP indices, struct vctrs_chop_info info) { SEXP elt; SEXP dim_names = PROTECT(Rf_getAttrib(x, R_DimNamesSymbol)); SEXP row_names = R_NilValue; if (dim_names != R_NilValue) { row_names = VECTOR_ELT(dim_names, 0); } for (R_len_t i = 0; i < info.out_size; ++i) { if (info.has_indices) { info.index = VECTOR_ELT(indices, i); *info.p_restore_size = vec_subscript_size(info.index); } else { ++(*info.p_index); } elt = PROTECT(vec_slice_shaped(info.proxy_info.type, info.proxy_info.proxy, info.index)); if (dim_names != R_NilValue) { if (row_names != R_NilValue) { SEXP new_dim_names = PROTECT(Rf_shallow_duplicate(dim_names)); SEXP new_row_names = PROTECT(slice_names(row_names, info.index)); SET_VECTOR_ELT(new_dim_names, 0, new_row_names); Rf_setAttrib(elt, R_DimNamesSymbol, new_dim_names); UNPROTECT(2); } else { Rf_setAttrib(elt, R_DimNamesSymbol, dim_names); } } elt = vec_restore(elt, x, info.restore_size); SET_VECTOR_ELT(info.out, i, elt); UNPROTECT(1); } UNPROTECT(1); return info.out; } static SEXP chop_fallback(SEXP x, SEXP indices, struct vctrs_chop_info info) { SEXP elt; // Evaluate in a child of the global environment to allow dispatch // to custom functions. We define `[` to point to its base // definition to ensure consistent look-up. This is the same logic // as in `vctrs_dispatch_n()`, reimplemented here to allow repeated // evaluations in a loop. SEXP env = PROTECT(r_new_environment(R_GlobalEnv, 2)); Rf_defineVar(syms_x, x, env); Rf_defineVar(syms_i, info.index, env); // Construct call with symbols, not values, for performance. // TODO - Remove once bit64 is updated on CRAN. Special casing integer64 // objects to ensure correct slicing with `NA_integer_`. SEXP call; if (is_integer64(x)) { call = PROTECT(Rf_lang3(syms_vec_slice_dispatch_integer64, syms_x, syms_i)); Rf_defineVar(syms_vec_slice_dispatch_integer64, fns_vec_slice_dispatch_integer64, env); } else { call = PROTECT(Rf_lang3(syms_bracket, syms_x, syms_i)); Rf_defineVar(syms_bracket, fns_bracket, env); } for (R_len_t i = 0; i < info.out_size; ++i) { if (info.has_indices) { info.index = VECTOR_ELT(indices, i); *info.p_restore_size = vec_size(info.index); // Update `i` binding with the new index value Rf_defineVar(syms_i, info.index, env); } else { ++(*info.p_index); } elt = PROTECT(Rf_eval(call, env)); // Restore attributes only if `[` fallback doesn't if (ATTRIB(elt) == R_NilValue) { elt = vec_restore(elt, x, info.restore_size); } SET_VECTOR_ELT(info.out, i, elt); UNPROTECT(1); } UNPROTECT(2); return info.out; } static SEXP chop_fallback_shaped(SEXP x, SEXP indices, struct vctrs_chop_info info) { SEXP elt; for (R_len_t i = 0; i < info.out_size; ++i) { if (info.has_indices) { info.index = VECTOR_ELT(indices, i); } else { ++(*info.p_index); } // `vec_slice_fallback()` will also `vec_restore()` for us elt = PROTECT(vec_slice_fallback(x, info.index)); SET_VECTOR_ELT(info.out, i, elt); UNPROTECT(1); } return info.out; } static SEXP vec_as_indices(SEXP indices, R_len_t n, SEXP names) { if (indices == R_NilValue) { return indices; } if (TYPEOF(indices) != VECSXP) { Rf_errorcall(R_NilValue, "`indices` must be a list of index values, or `NULL`."); } SEXP index; indices = PROTECT(r_maybe_duplicate(indices)); R_len_t size = vec_size(indices); for (int i = 0; i < size; ++i) { index = VECTOR_ELT(indices, i); SET_VECTOR_ELT(indices, i, vec_as_location(index, n, names)); } UNPROTECT(1); return indices; } vctrs/src/slice-assign.c0000644000176200001440000002655413623203263014743 0ustar liggesusers#include "vctrs.h" #include "subscript-loc.h" #include "utils.h" // Initialised at load time SEXP syms_vec_assign_fallback = NULL; SEXP fns_vec_assign_fallback = NULL; // Defined in slice.c SEXP vec_as_location(SEXP i, R_len_t n, SEXP names); static SEXP vec_assign_fallback(SEXP x, SEXP index, SEXP value); SEXP vec_assign_impl(SEXP x, SEXP index, SEXP value, bool clone); static SEXP lgl_assign(SEXP x, SEXP index, SEXP value, bool clone); static SEXP int_assign(SEXP x, SEXP index, SEXP value, bool clone); static SEXP dbl_assign(SEXP x, SEXP index, SEXP value, bool clone); static SEXP cpl_assign(SEXP x, SEXP index, SEXP value, bool clone); SEXP chr_assign(SEXP x, SEXP index, SEXP value, bool clone); static SEXP raw_assign(SEXP x, SEXP index, SEXP value, bool clone); SEXP list_assign(SEXP x, SEXP index, SEXP value, bool clone); SEXP df_assign(SEXP x, SEXP index, SEXP value, bool clone); // [[ register(); include("vctrs.h") ]] SEXP vec_assign(SEXP x, SEXP index, SEXP value) { if (x == R_NilValue) { return R_NilValue; } struct vctrs_arg x_arg = new_wrapper_arg(NULL, "x"); struct vctrs_arg value_arg = new_wrapper_arg(NULL, "value"); vec_assert(x, &x_arg); vec_assert(value, &value_arg); // Take the proxy of the RHS before coercing and recycling SEXP value_orig = value; value = PROTECT(vec_coercible_cast(value, x, &value_arg, &x_arg)); SEXP value_proxy = PROTECT(vec_proxy(value)); // Recycle the proxy of `value` index = PROTECT(vec_as_location_opts(index, vec_size(x), PROTECT(vec_names(x)), vec_as_location_default_assign_opts)); value_proxy = PROTECT(vec_recycle(value_proxy, vec_size(index), &value_arg)); struct vctrs_proxy_info info = vec_proxy_info(x); SEXP out; if (vec_requires_fallback(x, info) || has_dim(x)) { // Restore the value before falling back to `[<-` value = PROTECT(vec_restore(value_proxy, value_orig, R_NilValue)); out = vec_assign_fallback(x, index, value); UNPROTECT(1); } else { out = PROTECT(vec_assign_impl(info.proxy, index, value_proxy, true)); out = vec_restore(out, x, R_NilValue); UNPROTECT(1); } UNPROTECT(5); return out; } /** * @param clone Whether to shallow duplicate before assignment. With * data frames, the cloning is recursive. If `false`, make sure you * own the relevant parts of the vector structure (data frame * columns in particular). */ SEXP vec_assign_impl(SEXP proxy, SEXP index, SEXP value, bool clone) { switch (vec_proxy_typeof(proxy)) { case vctrs_type_logical: return lgl_assign(proxy, index, value, clone); case vctrs_type_integer: return int_assign(proxy, index, value, clone); case vctrs_type_double: return dbl_assign(proxy, index, value, clone); case vctrs_type_complex: return cpl_assign(proxy, index, value, clone); case vctrs_type_character: return chr_assign(proxy, index, value, clone); case vctrs_type_raw: return raw_assign(proxy, index, value, clone); case vctrs_type_list: return list_assign(proxy, index, value, clone); case vctrs_type_dataframe: return df_assign(proxy, index, value, clone); case vctrs_type_null: case vctrs_type_unspecified: case vctrs_type_s3: Rf_error("Internal error in `vec_assign_impl()`: Unexpected type %s.", vec_type_as_str(vec_typeof(proxy))); case vctrs_type_scalar: stop_scalar_type(proxy, args_empty); } never_reached("vec_assign_impl"); } #define ASSIGN_INDEX(CTYPE, DEREF, CONST_DEREF) \ R_len_t n = Rf_length(index); \ int* index_data = INTEGER(index); \ \ if (n != Rf_length(value)) { \ Rf_error("Internal error in `vec_assign()`: " \ "`value` should have been recycled to fit `x`."); \ } \ \ const CTYPE* value_data = CONST_DEREF(value); \ SEXP out = PROTECT(clone ? Rf_shallow_duplicate(x) : x); \ CTYPE* out_data = DEREF(out); \ \ for (R_len_t i = 0; i < n; ++i) { \ int j = index_data[i]; \ if (j != NA_INTEGER) { \ out_data[j - 1] = value_data[i]; \ } \ } \ \ UNPROTECT(1); \ return out #define ASSIGN_COMPACT(CTYPE, DEREF, CONST_DEREF) \ int* index_data = INTEGER(index); \ R_len_t start = index_data[0]; \ R_len_t n = index_data[1]; \ R_len_t step = index_data[2]; \ \ if (n != Rf_length(value)) { \ Rf_error("Internal error in `vec_assign()`: " \ "`value` should have been recycled to fit `x`."); \ } \ \ const CTYPE* value_data = CONST_DEREF(value); \ SEXP out = PROTECT(clone ? Rf_shallow_duplicate(x) : x); \ CTYPE* out_data = DEREF(out) + start; \ \ for (int i = 0; i < n; ++i, out_data += step, ++value_data) { \ *out_data = *value_data; \ } \ \ UNPROTECT(1); \ return out #define ASSIGN(CTYPE, DEREF, CONST_DEREF) \ if (is_compact_seq(index)) { \ ASSIGN_COMPACT(CTYPE, DEREF, CONST_DEREF); \ } else { \ ASSIGN_INDEX(CTYPE, DEREF, CONST_DEREF); \ } static SEXP lgl_assign(SEXP x, SEXP index, SEXP value, bool clone) { ASSIGN(int, LOGICAL, LOGICAL_RO); } static SEXP int_assign(SEXP x, SEXP index, SEXP value, bool clone) { ASSIGN(int, INTEGER, INTEGER_RO); } static SEXP dbl_assign(SEXP x, SEXP index, SEXP value, bool clone) { ASSIGN(double, REAL, REAL_RO); } static SEXP cpl_assign(SEXP x, SEXP index, SEXP value, bool clone) { ASSIGN(Rcomplex, COMPLEX, COMPLEX_RO); } SEXP chr_assign(SEXP x, SEXP index, SEXP value, bool clone) { ASSIGN(SEXP, STRING_PTR, STRING_PTR_RO); } static SEXP raw_assign(SEXP x, SEXP index, SEXP value, bool clone) { ASSIGN(Rbyte, RAW, RAW_RO); } #undef ASSIGN #undef ASSIGN_INDEX #undef ASSIGN_COMPACT #define ASSIGN_BARRIER_INDEX(GET, SET) \ R_len_t n = Rf_length(index); \ int* index_data = INTEGER(index); \ \ if (n != Rf_length(value)) { \ Rf_error("Internal error in `vec_assign()`: " \ "`value` should have been recycled to fit `x`."); \ } \ \ SEXP out = PROTECT(clone ? Rf_shallow_duplicate(x) : x); \ \ for (R_len_t i = 0; i < n; ++i) { \ int j = index_data[i]; \ if (j != NA_INTEGER) { \ SET(out, j - 1, GET(value, i)); \ } \ } \ \ UNPROTECT(1); \ return out #define ASSIGN_BARRIER_COMPACT(GET, SET) \ int* index_data = INTEGER(index); \ R_len_t start = index_data[0]; \ R_len_t n = index_data[1]; \ R_len_t step = index_data[2]; \ \ if (n != Rf_length(value)) { \ Rf_error("Internal error in `vec_assign()`: " \ "`value` should have been recycled to fit `x`."); \ } \ \ SEXP out = PROTECT(clone ? Rf_shallow_duplicate(x) : x); \ \ for (R_len_t i = 0; i < n; ++i, start += step) { \ SET(out, start, GET(value, i)); \ } \ \ UNPROTECT(1); \ return out #define ASSIGN_BARRIER(GET, SET) \ if (is_compact_seq(index)) { \ ASSIGN_BARRIER_COMPACT(GET, SET); \ } else { \ ASSIGN_BARRIER_INDEX(GET, SET); \ } SEXP list_assign(SEXP x, SEXP index, SEXP value, bool clone) { ASSIGN_BARRIER(VECTOR_ELT, SET_VECTOR_ELT); } #undef ASSIGN_BARRIER #undef ASSIGN_BARRIER_INDEX #undef ASSIGN_BARRIER_COMPACT /** * - `out` and `value` must be rectangular lists. * - `value` must have the same size as `index`. * * [[ include("vctrs.h") ]] */ SEXP df_assign(SEXP x, SEXP index, SEXP value, bool clone) { SEXP out = PROTECT(clone ? Rf_shallow_duplicate(x) : x); R_len_t n = Rf_length(out); for (R_len_t i = 0; i < n; ++i) { SEXP out_elt = VECTOR_ELT(out, i); SEXP value_elt = VECTOR_ELT(value, i); // No need to cast or recycle because those operations are // recursive and have already been performed. However, proxy and // restore are not recursive so need to be done for each element // we recurse into. SEXP proxy_elt = PROTECT(vec_proxy(out_elt)); value_elt = PROTECT(vec_proxy(value_elt)); SEXP assigned = PROTECT(vec_assign_impl(proxy_elt, index, value_elt, clone)); assigned = vec_restore(assigned, out_elt, R_NilValue); SET_VECTOR_ELT(out, i, assigned); UNPROTECT(3); } UNPROTECT(1); return out; } static SEXP vec_assign_fallback(SEXP x, SEXP index, SEXP value) { return vctrs_dispatch3(syms_vec_assign_fallback, fns_vec_assign_fallback, syms_x, x, syms_i, index, syms_value, value); } void vctrs_init_slice_assign(SEXP ns) { syms_vec_assign_fallback = Rf_install("vec_assign_fallback"); fns_vec_assign_fallback = Rf_findVar(syms_vec_assign_fallback, ns); } vctrs/src/utils.c0000644000176200001440000011423613623203140013507 0ustar liggesusers#include "vctrs.h" #include "utils.h" #include // Initialised at load time bool (*rlang_is_splice_box)(SEXP) = NULL; SEXP (*rlang_unbox)(SEXP) = NULL; SEXP (*rlang_env_dots_values)(SEXP) = NULL; SEXP (*rlang_env_dots_list)(SEXP) = NULL; SEXP vctrs_method_table = NULL; SEXP base_method_table = NULL; SEXP strings_tbl = NULL; SEXP strings_tbl_df = NULL; SEXP strings_data_frame = NULL; SEXP strings_vctrs_rcrd = NULL; SEXP strings_date = NULL; SEXP strings_posixct = NULL; SEXP strings_posixlt = NULL; SEXP strings_posixt = NULL; SEXP strings_factor = NULL; SEXP strings_ordered = NULL; SEXP strings_vctrs_vctr = NULL; SEXP strings_vctrs_list_of = NULL; SEXP strings_list = NULL; SEXP classes_data_frame = NULL; SEXP classes_factor = NULL; SEXP classes_ordered = NULL; SEXP classes_date = NULL; SEXP classes_posixct = NULL; SEXP classes_tibble = NULL; SEXP classes_list_of = NULL; SEXP classes_vctrs_group_rle = NULL; static SEXP syms_as_data_frame2 = NULL; static SEXP fns_as_data_frame2 = NULL; static SEXP vctrs_eval_mask_n_impl(SEXP fn, SEXP* syms, SEXP* args, SEXP mask); /** * Evaluate with masked arguments * * This takes two arrays of argument (`args`) and argument names * `syms`). The names should correspond to formal arguments of `fn`. * Elements of `args` are assigned to their corresponding name in * `syms` in a child of `env`. A call to `fn` is constructed with the * CARs and TAGs assigned symmetrically to the elements of * `syms`. This way the arguments are masked by symbols corresponding * to the formal parameters. * * @param fn The function to call. * @param syms A null-terminated array of symbols. The arguments * `args` are assigned to these symbols. The assignment occurs in a * child of `env` and the dispatch call refers to these symbols. * @param args A null-terminated array of arguments passed to the method. * @param env The environment in which to evaluate. */ SEXP vctrs_eval_mask_n(SEXP fn, SEXP* syms, SEXP* args, SEXP env) { SEXP mask = PROTECT(r_new_environment(env, 4)); SEXP out = vctrs_eval_mask_n_impl(fn, syms, args, mask); UNPROTECT(1); return out; } SEXP vctrs_eval_mask1(SEXP fn, SEXP x_sym, SEXP x, SEXP env) { SEXP syms[2] = { x_sym, NULL }; SEXP args[2] = { x, NULL }; return vctrs_eval_mask_n(fn, syms, args, env); } SEXP vctrs_eval_mask2(SEXP fn, SEXP x_sym, SEXP x, SEXP y_sym, SEXP y, SEXP env) { SEXP syms[3] = { x_sym, y_sym, NULL }; SEXP args[3] = { x, y, NULL }; return vctrs_eval_mask_n(fn, syms, args, env); } SEXP vctrs_eval_mask3(SEXP fn, SEXP x_sym, SEXP x, SEXP y_sym, SEXP y, SEXP z_sym, SEXP z, SEXP env) { SEXP syms[4] = { x_sym, y_sym, z_sym, NULL }; SEXP args[4] = { x, y, z, NULL }; return vctrs_eval_mask_n(fn, syms, args, env); } SEXP vctrs_eval_mask4(SEXP fn, SEXP x1_sym, SEXP x1, SEXP x2_sym, SEXP x2, SEXP x3_sym, SEXP x3, SEXP x4_sym, SEXP x4, SEXP env) { SEXP syms[5] = { x1_sym, x2_sym, x3_sym, x4_sym, NULL }; SEXP args[5] = { x1, x2, x3, x4, NULL }; return vctrs_eval_mask_n(fn, syms, args, env); } SEXP vctrs_eval_mask5(SEXP fn, SEXP x1_sym, SEXP x1, SEXP x2_sym, SEXP x2, SEXP x3_sym, SEXP x3, SEXP x4_sym, SEXP x4, SEXP x5_sym, SEXP x5, SEXP env) { SEXP syms[6] = { x1_sym, x2_sym, x3_sym, x4_sym, x5_sym, NULL }; SEXP args[6] = { x1, x2, x3, x4, x5, NULL }; return vctrs_eval_mask_n(fn, syms, args, env); } /** * Dispatch in the global environment * * Like `vctrs_eval_mask_n()`, the arguments `args` are are assigned * to the symbols `syms`. In addition, the function `fn` is assigned * to `fn_sym`. The mask is a direct child of the global environment * so that method dispatch finds globally defined methods. * * @param fn_sym A symbol to which `fn` is assigned. * @inheritParams vctrs_eval_mask_n */ SEXP vctrs_dispatch_n(SEXP fn_sym, SEXP fn, SEXP* syms, SEXP* args) { // Mask `fn` with `fn_sym`. We dispatch in the global environment. SEXP mask = PROTECT(r_new_environment(R_GlobalEnv, 4)); Rf_defineVar(fn_sym, fn, mask); SEXP out = vctrs_eval_mask_n_impl(fn_sym, syms, args, mask); UNPROTECT(1); return out; } SEXP vctrs_dispatch1(SEXP fn_sym, SEXP fn, SEXP x_sym, SEXP x) { SEXP syms[2] = { x_sym, NULL }; SEXP args[2] = { x, NULL }; return vctrs_dispatch_n(fn_sym, fn, syms, args); } SEXP vctrs_dispatch2(SEXP fn_sym, SEXP fn, SEXP x_sym, SEXP x, SEXP y_sym, SEXP y) { SEXP syms[3] = { x_sym, y_sym, NULL }; SEXP args[3] = { x, y, NULL }; return vctrs_dispatch_n(fn_sym, fn, syms, args); } SEXP vctrs_dispatch3(SEXP fn_sym, SEXP fn, SEXP x_sym, SEXP x, SEXP y_sym, SEXP y, SEXP z_sym, SEXP z) { SEXP syms[4] = { x_sym, y_sym, z_sym, NULL }; SEXP args[4] = { x, y, z, NULL }; return vctrs_dispatch_n(fn_sym, fn, syms, args); } SEXP vctrs_dispatch4(SEXP fn_sym, SEXP fn, SEXP w_sym, SEXP w, SEXP x_sym, SEXP x, SEXP y_sym, SEXP y, SEXP z_sym, SEXP z) { SEXP syms[5] = { w_sym, x_sym, y_sym, z_sym, NULL }; SEXP args[5] = { w, x, y, z, NULL }; return vctrs_dispatch_n(fn_sym, fn, syms, args); } static SEXP vctrs_eval_mask_n_impl(SEXP fn, SEXP* syms, SEXP* args, SEXP mask) { SEXP call = PROTECT(r_call(fn, syms, syms)); while (*syms) { Rf_defineVar(*syms, *args, mask); ++syms; ++args; } SEXP out = Rf_eval(call, mask); UNPROTECT(1); return out; } // An alternative to `attributes(x) <- attrib`, which makes // two copies on R < 3.6.0 // [[ register() ]] SEXP vctrs_set_attributes(SEXP x, SEXP attrib) { R_len_t n_attrib = Rf_length(attrib); int n_protect = 0; if (MAYBE_REFERENCED(x)) { x = PROTECT(Rf_shallow_duplicate(x)); ++n_protect; } // Remove existing attributes, and unset the object bit SET_ATTRIB(x, R_NilValue); SET_OBJECT(x, 0); // Possible early exit after removing attributes if (n_attrib == 0) { UNPROTECT(n_protect); return x; } SEXP names = Rf_getAttrib(attrib, R_NamesSymbol); if (Rf_isNull(names)) { Rf_errorcall(R_NilValue, "Attributes must be named."); } // Check that each element of `names` is named. for (R_len_t i = 0; i < n_attrib; ++i) { SEXP name = STRING_ELT(names, i); if (name == NA_STRING || name == R_BlankString) { const char* msg = "All attributes must have names. Attribute %i does not."; Rf_errorcall(R_NilValue, msg, i + 1); } } // Always set `dim` first, if it exists. This way it is set before `dimnames`. int dim_pos = -1; for (R_len_t i = 0; i < n_attrib; ++i) { if (!strcmp(CHAR(STRING_ELT(names, i)), "dim")) { dim_pos = i; break; } } if (dim_pos != -1) { Rf_setAttrib(x, R_DimSymbol, VECTOR_ELT(attrib, dim_pos)); } for (R_len_t i = 0; i < n_attrib; ++i) { if (i == dim_pos) { continue; } Rf_setAttrib(x, Rf_installChar(STRING_ELT(names, i)), VECTOR_ELT(attrib, i)); } UNPROTECT(n_protect); return x; } // [[ include("utils.h") ]] SEXP map(SEXP x, SEXP (*fn)(SEXP)) { R_len_t n = Rf_length(x); SEXP out = PROTECT(Rf_allocVector(VECSXP, n)); for (R_len_t i = 0; i < n; ++i) { SET_VECTOR_ELT(out, i, fn(VECTOR_ELT(x, i))); } SEXP nms = PROTECT(Rf_getAttrib(x, R_NamesSymbol)); Rf_setAttrib(out, R_NamesSymbol, nms); UNPROTECT(2); return out; } // [[ include("utils.h") ]] SEXP map_with_data(SEXP x, SEXP (*fn)(SEXP, void*), void* data) { R_len_t n = Rf_length(x); SEXP out = PROTECT(Rf_allocVector(VECSXP, n)); for (R_len_t i = 0; i < n; ++i) { SET_VECTOR_ELT(out, i, fn(VECTOR_ELT(x, i), data)); } SEXP nms = PROTECT(Rf_getAttrib(x, R_NamesSymbol)); Rf_setAttrib(out, R_NamesSymbol, nms); UNPROTECT(2); return out; } // [[ include("utils.h") ]] SEXP bare_df_map(SEXP df, SEXP (*fn)(SEXP)) { SEXP out = PROTECT(map(df, fn)); out = vec_bare_df_restore(out, df, vctrs_shared_zero_int); UNPROTECT(1); return out; } // [[ include("utils.h") ]] SEXP df_map(SEXP df, SEXP (*fn)(SEXP)) { SEXP out = PROTECT(map(df, fn)); out = vec_df_restore(out, df, vctrs_shared_zero_int); UNPROTECT(1); return out; } inline void never_reached(const char* fn) { Rf_error("Internal error in `%s()`: Reached the unreachable.", fn); } static char s3_buf[200]; static SEXP s3_method_sym(const char* generic, const char* class) { int gen_len = strlen(generic); int class_len = strlen(class); int dot_len = 1; if (gen_len + class_len + dot_len >= 200) { Rf_error("Internal error: Generic or class name is too long."); } char* buf = s3_buf; memcpy(buf, generic, gen_len); buf += gen_len; *buf = '.'; ++buf; memcpy(buf, class, class_len); buf += class_len; *buf = '\0'; return Rf_install(s3_buf); } // First check in global env, then in method table static SEXP s3_get_method(const char* generic, const char* class, SEXP table) { SEXP sym = s3_method_sym(generic, class); SEXP method = r_env_get(R_GlobalEnv, sym); if (r_is_function(method)) { return method; } method = r_env_get(table, sym); if (r_is_function(method)) { return method; } return R_NilValue; } SEXP s3_find_method(const char* generic, SEXP x, SEXP table) { if (!OBJECT(x)) { return R_NilValue; } SEXP class = PROTECT(Rf_getAttrib(x, R_ClassSymbol)); SEXP* class_ptr = STRING_PTR(class); int n_class = Rf_length(class); for (int i = 0; i < n_class; ++i, ++class_ptr) { SEXP method = s3_get_method(generic, CHAR(*class_ptr), table); if (method != R_NilValue) { UNPROTECT(1); return method; } } UNPROTECT(1); return R_NilValue; } // [[ include("utils.h") ]] bool vec_implements_ptype2(SEXP x) { if (vec_typeof(x) == vctrs_type_s3) { SEXP met = s3_find_method("vec_ptype2", x, vctrs_method_table); return met != R_NilValue; } else { return true; } } // [[ include("utils.h") ]] SEXP list_first_non_null(SEXP xs, R_len_t* non_null_i) { SEXP x = R_NilValue; R_len_t n = Rf_length(xs); R_len_t i = 0; for (; i < n; ++i) { x = VECTOR_ELT(xs, i); if (x != R_NilValue) { break; } } if (non_null_i) { *non_null_i = i; } return x; } // [[ include("utils.h") ]] bool list_is_s3_homogeneous(SEXP xs) { R_len_t n = Rf_length(xs); if (n == 0 || n == 1) { return true; } R_len_t i = -1; SEXP first = list_first_non_null(xs, &i); SEXP first_class = PROTECT(r_class(first)); for (; i < n; ++i) { SEXP this = VECTOR_ELT(xs, i); if (this == R_NilValue) { continue; } SEXP this_class = PROTECT(r_class(this)); if (!equal_object(first_class, this_class)) { UNPROTECT(2); return false; } UNPROTECT(1); } UNPROTECT(1); return true; } // [[ include("utils.h") ]] SEXP node_compact_d(SEXP node) { SEXP handle = PROTECT(Rf_cons(R_NilValue, node)); SEXP prev = handle; while (node != R_NilValue) { if (CAR(node) == R_NilValue) { SETCDR(prev, CDR(node)); } else { prev = node; } node = CDR(node); } UNPROTECT(1); return CDR(handle); } // [[ include("utils.h") ]] SEXP new_empty_factor(SEXP levels) { if (TYPEOF(levels) != STRSXP) { Rf_errorcall(R_NilValue, "Internal error: `level` must be a character vector."); } SEXP out = PROTECT(Rf_allocVector(INTSXP, 0)); Rf_setAttrib(out, R_LevelsSymbol, levels); Rf_setAttrib(out, R_ClassSymbol, classes_factor); UNPROTECT(1); return out; } // [[ include("utils.h") ]] SEXP new_empty_ordered(SEXP levels) { SEXP out = PROTECT(Rf_allocVector(INTSXP, 0)); Rf_setAttrib(out, R_LevelsSymbol, levels); Rf_setAttrib(out, R_ClassSymbol, classes_ordered); UNPROTECT(1); return out; } // [[ include("vctrs.h") ]] enum vctrs_dbl_class dbl_classify(double x) { if (!isnan(x)) { return vctrs_dbl_number; } union vctrs_dbl_indicator indicator; indicator.value = x; if (indicator.key[vctrs_indicator_pos] == 1954) { return vctrs_dbl_missing; } else { return vctrs_dbl_nan; } } // Initialised at load time SEXP compact_seq_attrib = NULL; // p[0] = Start value // p[1] = Sequence size. Always >= 1. // p[2] = Step size to increment/decrement `start` with void init_compact_seq(int* p, R_len_t start, R_len_t size, bool increasing) { int step = increasing ? 1 : -1; p[0] = start; p[1] = size; p[2] = step; } // Returns a compact sequence that `vec_slice()` understands // The sequence is generally generated as `[start, start +/- size)` // If `size == 0` a 0-length sequence is generated // `start` is 0-based SEXP compact_seq(R_len_t start, R_len_t size, bool increasing) { if (start < 0) { Rf_error("Internal error: `start` must not be negative in `compact_seq()`."); } if (size < 0) { Rf_error("Internal error: `size` must not be negative in `compact_seq()`."); } if (!increasing && size > start + 1) { Rf_error("Internal error: If constructing a decreasing sequence, `size` must not be larger than `start` in `compact_seq()`."); } SEXP info = PROTECT(Rf_allocVector(INTSXP, 3)); int* p = INTEGER(info); init_compact_seq(p, start, size, increasing); SET_ATTRIB(info, compact_seq_attrib); UNPROTECT(1); return info; } bool is_compact_seq(SEXP x) { return ATTRIB(x) == compact_seq_attrib; } // Materialize a 1-based sequence SEXP compact_seq_materialize(SEXP x) { int* p = INTEGER(x); R_len_t start = p[0] + 1; R_len_t size = p[1]; R_len_t step = p[2]; SEXP out = PROTECT(Rf_allocVector(INTSXP, size)); int* out_data = INTEGER(out); for (R_len_t i = 0; i < size; ++i, ++out_data, start += step) { *out_data = start; } UNPROTECT(1); return out; } // Initialised at load time SEXP compact_rep_attrib = NULL; void init_compact_rep(int* p, R_len_t i, R_len_t n) { p[0] = i; p[1] = n; } // Returns a compact repetition that `vec_slice()` understands // `i` should be an R-based index SEXP compact_rep(R_len_t i, R_len_t n) { if (n < 0) { Rf_error("Internal error: Negative `n` in `compact_rep()`."); } SEXP rep = PROTECT(Rf_allocVector(INTSXP, 2)); int* p = INTEGER(rep); init_compact_rep(p, i, n); SET_ATTRIB(rep, compact_rep_attrib); UNPROTECT(1); return rep; } bool is_compact_rep(SEXP x) { return ATTRIB(x) == compact_rep_attrib; } SEXP compact_rep_materialize(SEXP x) { int i = r_int_get(x, 0); int n = r_int_get(x, 1); SEXP out = PROTECT(Rf_allocVector(INTSXP, n)); r_int_fill(out, i, n); UNPROTECT(1); return out; } bool is_compact(SEXP x) { return is_compact_rep(x) || is_compact_seq(x); } SEXP compact_materialize(SEXP x) { if (is_compact_rep(x)) { return compact_rep_materialize(x); } else if (is_compact_seq(x)) { return compact_seq_materialize(x); } else { return x; } } R_len_t vec_subscript_size(SEXP x) { if (is_compact_rep(x)) { return r_int_get(x, 1); } else if (is_compact_seq(x)) { return r_int_get(x, 1); } else { return vec_size(x); } } static SEXP syms_colnames = NULL; static SEXP fns_colnames = NULL; // [[ include("utils.h") ]] SEXP colnames(SEXP x) { return vctrs_dispatch1(syms_colnames, fns_colnames, syms_x, x); } // [[ include("utils.h") ]] SEXP arg_validate(SEXP arg, const char* arg_nm) { if (arg == R_NilValue) { return chrs_empty; } else if (r_is_string(arg)) { return arg; } else { Rf_errorcall(R_NilValue, "`%s` tag must be a string", arg_nm); } } // [[ include("utils.h") ]] bool is_integer64(SEXP x) { return TYPEOF(x) == REALSXP && Rf_inherits(x, "integer64"); } void* r_vec_deref(SEXP x) { switch (TYPEOF(x)) { case INTSXP: return INTEGER(x); case STRSXP: return STRING_PTR(x); default: Rf_error("Unimplemented type in `r_vec_deref()`."); } } const void* r_vec_const_deref(SEXP x) { switch (TYPEOF(x)) { case INTSXP: return INTEGER_RO(x); case STRSXP: return STRING_PTR_RO(x); default: Rf_error("Unimplemented type in `r_vec_deref()`."); } } void r_vec_ptr_inc(SEXPTYPE type, void** p, R_len_t i) { switch (type) { case STRSXP: *((SEXP**) p) += i; return; case INTSXP: *((int**) p) += i; return; default: Rf_error("Unimplemented type in `r_vec_ptr_inc()`."); } } #define FILL(CTYPE, PTR, VAL_PTR, VAL_I, N) \ do { \ CTYPE* data = (CTYPE*) PTR; \ CTYPE* end = data + N; \ CTYPE value = ((const CTYPE*) VAL_PTR)[VAL_I]; \ \ while (data != end) { \ *data++ = value; \ } \ } while (false) void r_vec_fill(SEXPTYPE type, void* p, const void* value_p, R_len_t value_i, R_len_t n) { switch (type) { case STRSXP: FILL(SEXP, p, value_p, value_i, n); return; case INTSXP: FILL(int, p, value_p, value_i, n); return; default: Rf_error("Internal error: Unimplemented type in `r_fill()`"); } } #undef FILL R_len_t r_lgl_sum(SEXP x, bool na_true) { if (TYPEOF(x) != LGLSXP) { Rf_errorcall(R_NilValue, "Internal error: Excepted logical vector in `r_lgl_sum()`"); } R_len_t n = Rf_length(x); R_len_t sum = 0; int* ptr = LOGICAL(x); for (R_len_t i = 0; i < n; ++i, ++ptr) { // This can't overflow since `sum` is necessarily smaller or equal // to the vector length expressed in `R_len_t`. if (na_true && *ptr) { sum += 1; } else if (*ptr == 1) { sum += 1; } } return sum; } SEXP r_lgl_which(SEXP x, bool na_propagate) { if (TYPEOF(x) != LGLSXP) { Rf_errorcall(R_NilValue, "Internal error: Expected logical vector in `r_lgl_which()`"); } R_len_t n = Rf_length(x); int* data = LOGICAL(x); R_len_t which_n = r_lgl_sum(x, na_propagate); SEXP which = PROTECT(Rf_allocVector(INTSXP, which_n)); int* which_data = INTEGER(which); for (R_len_t i = 0; i < n; ++i, ++data) { int elt = *data; if (elt) { if (na_propagate && elt == NA_LOGICAL) { *which_data++ = NA_INTEGER; } else if (elt != NA_LOGICAL) { *which_data++ = i + 1; } } } UNPROTECT(1); return which; } #define FILL(CTYPE, DEREF) \ CTYPE* data = DEREF(x); \ \ for (R_len_t i = 0; i < n; ++i, ++data) \ *data = value void r_lgl_fill(SEXP x, int value, R_len_t n) { FILL(int, LOGICAL); } void r_int_fill(SEXP x, int value, R_len_t n) { FILL(int, INTEGER); } void r_chr_fill(SEXP x, SEXP value, R_len_t n) { FILL(SEXP, STRING_PTR); } #undef FILL void r_int_fill_seq(SEXP x, int start, R_len_t n) { int* data = INTEGER(x); for (R_len_t i = 0; i < n; ++i, ++data, ++start) { *data = start; } } SEXP r_seq(R_len_t from, R_len_t to) { R_len_t n = to - from; if (n < 0) { Rf_error("Internal error: Negative length in `r_seq()`"); } SEXP seq = PROTECT(Rf_allocVector(INTSXP, n)); r_int_fill_seq(seq, from, n); UNPROTECT(1); return seq; } #define FIND(CTYPE, CONST_DEREF) \ R_len_t n = Rf_length(x); \ const CTYPE* data = CONST_DEREF(x); \ \ for (R_len_t i = 0; i < n; ++i) { \ if (data[i] == value) { \ return i; \ } \ } \ return -1 R_len_t r_chr_find(SEXP x, SEXP value) { FIND(SEXP, STRING_PTR_RO); } #undef FIND bool r_int_any_na(SEXP x) { int* data = INTEGER(x); R_len_t n = Rf_length(x); for (R_len_t i = 0; i < n; ++i, ++data) { if (*data == NA_INTEGER) { return true; } } return false; } int r_chr_max_len(SEXP x) { R_len_t n = Rf_length(x); SEXP* p = STRING_PTR(x); int max = 0; for (R_len_t i = 0; i < n; ++i, ++p) { int len = strlen(CHAR(*p)); max = len > max ? len : max; } return max; } /** * Create a character vector of sequential integers * * @param n The sequence is from 1 to `n`. * @param buf,len A memory buffer of size `len`. * @param prefix A null-terminated string that is prefixed to the * sequence. */ SEXP r_chr_iota(R_len_t n, char* buf, int len, const char* prefix) { int prefix_len = strlen(prefix); if (len - 1 < prefix_len) { Rf_errorcall(R_NilValue, "Internal error: Prefix is larger than iota buffer."); } memcpy(buf, prefix, prefix_len); len -= prefix_len; char* beg = buf + prefix_len; SEXP out = PROTECT(Rf_allocVector(STRSXP, n)); for (R_len_t i = 0; i < n; ++i) { int written = snprintf(beg, len, "%d", i + 1); if (written >= len) { UNPROTECT(1); return R_NilValue; } SET_STRING_ELT(out, i, Rf_mkChar(buf)); } UNPROTECT(1); return out; } #include static void abort_parse(SEXP code, const char* why) { if (Rf_GetOption1(Rf_install("rlang__verbose_errors")) != R_NilValue) { Rf_PrintValue(code); } Rf_error("Internal error: %s", why); } SEXP r_parse(const char* str) { SEXP str_ = PROTECT(Rf_mkString(str)); ParseStatus status; SEXP out = PROTECT(R_ParseVector(str_, -1, &status, R_NilValue)); if (status != PARSE_OK) { abort_parse(str_, "Parsing failed"); } if (Rf_length(out) != 1) { abort_parse(str_, "Expected a single expression"); } out = VECTOR_ELT(out, 0); UNPROTECT(2); return out; } SEXP r_parse_eval(const char* str, SEXP env) { SEXP out = Rf_eval(PROTECT(r_parse(str)), env); UNPROTECT(1); return out; } static SEXP new_env_call = NULL; static SEXP new_env__parent_node = NULL; static SEXP new_env__size_node = NULL; SEXP r_new_environment(SEXP parent, R_len_t size) { parent = parent ? parent : R_EmptyEnv; SETCAR(new_env__parent_node, parent); size = size ? size : 29; SETCAR(new_env__size_node, Rf_ScalarInteger(size)); SEXP env = Rf_eval(new_env_call, R_BaseEnv); // Free for gc SETCAR(new_env__parent_node, R_NilValue); return env; } static SEXP new_function_call = NULL; static SEXP new_function__formals_node = NULL; static SEXP new_function__body_node = NULL; SEXP r_new_function(SEXP formals, SEXP body, SEXP env) { SETCAR(new_function__formals_node, formals); SETCAR(new_function__body_node, body); SEXP fn = Rf_eval(new_function_call, env); // Free for gc SETCAR(new_function__formals_node, R_NilValue); SETCAR(new_function__body_node, R_NilValue); return fn; } // [[ include("utils.h") ]] SEXP r_protect(SEXP x) { return Rf_lang2(fns_quote, x); } // [[ include("utils.h") ]] bool r_is_bool(SEXP x) { return TYPEOF(x) == LGLSXP && Rf_length(x) == 1 && LOGICAL(x)[0] != NA_LOGICAL; } bool r_is_true(SEXP x) { return r_is_bool(x) && LOGICAL(x)[0] == 1; } bool r_is_string(SEXP x) { return TYPEOF(x) == STRSXP && Rf_length(x) == 1 && STRING_ELT(x, 0) != NA_STRING; } bool r_is_number(SEXP x) { return TYPEOF(x) == INTSXP && Rf_length(x) == 1 && INTEGER(x)[0] != NA_INTEGER; } SEXP r_peek_option(const char* option) { return Rf_GetOption1(Rf_install(option)); } /** * Create a call or pairlist * * @param tags Optional. If not `NULL`, a null-terminated array of symbols. * @param cars Mandatory. A null-terminated array of CAR values. * @param fn The first CAR value of the language list. * * [[ include("utils.h") ]] */ SEXP r_pairlist(SEXP* tags, SEXP* cars) { if (!cars) { Rf_error("Internal error: Null `cars` in `r_pairlist()`"); } SEXP list = PROTECT(Rf_cons(R_NilValue, R_NilValue)); SEXP node = list; while (*cars) { SEXP next_node = Rf_cons(*cars, R_NilValue); SETCDR(node, next_node); node = next_node; if (tags) { SET_TAG(next_node, *tags); ++tags; } ++cars; } UNPROTECT(1); return CDR(list); } SEXP r_call(SEXP fn, SEXP* tags, SEXP* cars) { return Rf_lcons(fn, r_pairlist(tags, cars)); } bool r_has_name_at(SEXP names, R_len_t i) { if (TYPEOF(names) != STRSXP) { return false; } R_len_t n = Rf_length(names); if (n <= i) { Rf_error("Internal error: Names shorter than expected: (%d/%d)", i + 1, n); } SEXP elt = STRING_ELT(names, i); return elt != NA_STRING && elt != strings_empty; } bool r_is_minimal_names(SEXP x) { if (TYPEOF(x) != STRSXP) { return false; } R_len_t n = Rf_length(x); const SEXP* p = STRING_PTR_RO(x); for (R_len_t i = 0; i < n; ++i, ++p) { SEXP elt = *p; if (elt == NA_STRING || elt == strings_empty) { return false; } } return true; } bool r_is_empty_names(SEXP x) { if (TYPEOF(x) != STRSXP) { if (x == R_NilValue) { return true; } else { return false; } } R_len_t n = Rf_length(x); const SEXP* p = STRING_PTR_RO(x); for (R_len_t i = 0; i < n; ++i, ++p) { SEXP elt = *p; if (elt != NA_STRING && elt != strings_empty) { return false; } } return true; } SEXP r_env_get(SEXP env, SEXP sym) { SEXP obj = PROTECT(Rf_findVarInFrame3(env, sym, FALSE)); // Force lazy loaded bindings if (TYPEOF(obj) == PROMSXP) { obj = Rf_eval(obj, R_BaseEnv); } UNPROTECT(1); return obj; } bool r_is_function(SEXP x) { switch (TYPEOF(x)) { case CLOSXP: case BUILTINSXP: case SPECIALSXP: return true; default: return false; } } SEXP r_maybe_duplicate(SEXP x) { if (MAYBE_REFERENCED(x)) { return Rf_shallow_duplicate(x); } else { return x; } } bool r_is_names(SEXP names) { if (names == R_NilValue) { return false; } R_len_t n = Rf_length(names); const SEXP* p = STRING_PTR_RO(names); for (R_len_t i = 0; i < n; ++i, ++p) { SEXP nm = *p; if (nm == strings_empty || nm == NA_STRING) { return false; } } return true; } bool r_chr_has_string(SEXP x, SEXP str) { R_len_t n = Rf_length(x); const SEXP* xp = STRING_PTR_RO(x); for (R_len_t i = 0; i < n; ++i, ++xp) { if (*xp == str) { return true; } } return false; } SEXP r_as_data_frame(SEXP x) { if (is_bare_data_frame(x)) { return x; } else { return vctrs_dispatch1(syms_as_data_frame2, fns_as_data_frame2, syms_x, x); } } SEXP rlang_formula_formals = NULL; SEXP r_as_function(SEXP x, const char* arg) { switch (TYPEOF(x)) { case CLOSXP: case BUILTINSXP: case SPECIALSXP: return x; case LANGSXP: if (CAR(x) == syms_tilde && CDDR(x) == R_NilValue) { SEXP env = PROTECT(Rf_getAttrib(x, syms_dot_environment)); if (env == R_NilValue) { Rf_errorcall(R_NilValue, "Can't transform formula to function because it doesn't have an environment."); } SEXP fn = r_new_function(rlang_formula_formals, CADR(x), env); UNPROTECT(1); return fn; } // else fallthrough; default: Rf_errorcall(R_NilValue, "Can't convert `%s` to a function", arg); } } SEXP vctrs_ns_env = NULL; SEXP vctrs_shared_empty_str = NULL; SEXP vctrs_shared_empty_lgl = NULL; SEXP vctrs_shared_empty_int = NULL; SEXP vctrs_shared_empty_dbl = NULL; SEXP vctrs_shared_empty_cpl = NULL; SEXP vctrs_shared_empty_chr = NULL; SEXP vctrs_shared_empty_raw = NULL; SEXP vctrs_shared_empty_list = NULL; SEXP vctrs_shared_empty_date = NULL; SEXP vctrs_shared_true = NULL; SEXP vctrs_shared_false = NULL; Rcomplex vctrs_shared_na_cpl; SEXP vctrs_shared_zero_int = NULL; SEXP vctrs_shared_na_lgl = NULL; SEXP strings = NULL; SEXP strings_empty = NULL; SEXP strings_dots = NULL; SEXP strings_none = NULL; SEXP strings_minimal = NULL; SEXP strings_unique = NULL; SEXP strings_universal = NULL; SEXP strings_check_unique = NULL; SEXP strings_key = NULL; SEXP strings_loc = NULL; SEXP strings_val = NULL; SEXP strings_group = NULL; SEXP strings_length = NULL; SEXP chrs_subset = NULL; SEXP chrs_extract = NULL; SEXP chrs_assign = NULL; SEXP chrs_rename = NULL; SEXP chrs_remove = NULL; SEXP chrs_negate = NULL; SEXP chrs_numeric = NULL; SEXP chrs_character = NULL; SEXP chrs_empty = NULL; SEXP syms_i = NULL; SEXP syms_n = NULL; SEXP syms_x = NULL; SEXP syms_y = NULL; SEXP syms_to = NULL; SEXP syms_dots = NULL; SEXP syms_bracket = NULL; SEXP syms_arg = NULL; SEXP syms_x_arg = NULL; SEXP syms_y_arg = NULL; SEXP syms_to_arg = NULL; SEXP syms_subscript_arg = NULL; SEXP syms_out = NULL; SEXP syms_value = NULL; SEXP syms_quiet = NULL; SEXP syms_dot_name_spec = NULL; SEXP syms_outer = NULL; SEXP syms_inner = NULL; SEXP syms_tilde = NULL; SEXP syms_dot_environment = NULL; SEXP syms_ptype = NULL; SEXP syms_missing = NULL; SEXP syms_size = NULL; SEXP syms_subscript_action = NULL; SEXP syms_subscript_type = NULL; SEXP syms_repair = NULL; SEXP syms_tzone = NULL; SEXP fns_bracket = NULL; SEXP fns_quote = NULL; SEXP fns_names = NULL; struct vctrs_arg args_empty_; struct vctrs_arg* args_empty = NULL; void vctrs_init_utils(SEXP ns) { vctrs_ns_env = ns; vctrs_method_table = r_env_get(ns, Rf_install(".__S3MethodsTable__.")); base_method_table = r_env_get(R_BaseNamespace, Rf_install(".__S3MethodsTable__.")); vctrs_shared_empty_str = Rf_mkString(""); R_PreserveObject(vctrs_shared_empty_str); // Holds the CHARSXP objects because unlike symbols they can be // garbage collected strings = Rf_allocVector(STRSXP, 21); R_PreserveObject(strings); strings_dots = Rf_mkChar("..."); SET_STRING_ELT(strings, 0, strings_dots); strings_empty = Rf_mkChar(""); SET_STRING_ELT(strings, 1, strings_empty); strings_vctrs_rcrd = Rf_mkChar("vctrs_rcrd"); SET_STRING_ELT(strings, 2, strings_vctrs_rcrd); strings_date = Rf_mkChar("Date"); SET_STRING_ELT(strings, 3, strings_date); strings_posixct = Rf_mkChar("POSIXct"); SET_STRING_ELT(strings, 4, strings_posixct); strings_posixlt = Rf_mkChar("POSIXlt"); SET_STRING_ELT(strings, 5, strings_posixlt); strings_posixt = Rf_mkChar("POSIXt"); SET_STRING_ELT(strings, 6, strings_posixlt); strings_vctrs_vctr = Rf_mkChar("vctrs_vctr"); SET_STRING_ELT(strings, 7, strings_vctrs_vctr); strings_none = Rf_mkChar("none"); SET_STRING_ELT(strings, 8, strings_none); strings_minimal = Rf_mkChar("minimal"); SET_STRING_ELT(strings, 9, strings_minimal); strings_unique = Rf_mkChar("unique"); SET_STRING_ELT(strings, 10, strings_unique); strings_universal = Rf_mkChar("universal"); SET_STRING_ELT(strings, 11, strings_universal); strings_check_unique = Rf_mkChar("check_unique"); SET_STRING_ELT(strings, 12, strings_check_unique); strings_key = Rf_mkChar("key"); SET_STRING_ELT(strings, 13, strings_key); strings_loc = Rf_mkChar("loc"); SET_STRING_ELT(strings, 14, strings_loc); strings_val = Rf_mkChar("val"); SET_STRING_ELT(strings, 15, strings_val); strings_group = Rf_mkChar("group"); SET_STRING_ELT(strings, 16, strings_group); strings_length = Rf_mkChar("length"); SET_STRING_ELT(strings, 17, strings_length); strings_factor = Rf_mkChar("factor"); SET_STRING_ELT(strings, 18, strings_factor); strings_ordered = Rf_mkChar("ordered"); SET_STRING_ELT(strings, 19, strings_ordered); strings_list = Rf_mkChar("list"); SET_STRING_ELT(strings, 20, strings_list); classes_data_frame = Rf_allocVector(STRSXP, 1); R_PreserveObject(classes_data_frame); strings_data_frame = Rf_mkChar("data.frame"); SET_STRING_ELT(classes_data_frame, 0, strings_data_frame); classes_factor = Rf_allocVector(STRSXP, 1); R_PreserveObject(classes_factor); SET_STRING_ELT(classes_factor, 0, strings_factor); classes_ordered = Rf_allocVector(STRSXP, 2); R_PreserveObject(classes_ordered); SET_STRING_ELT(classes_ordered, 0, strings_ordered); SET_STRING_ELT(classes_ordered, 1, strings_factor); classes_date = Rf_allocVector(STRSXP, 1); R_PreserveObject(classes_date); SET_STRING_ELT(classes_date, 0, strings_date); classes_posixct = Rf_allocVector(STRSXP, 2); R_PreserveObject(classes_posixct); SET_STRING_ELT(classes_posixct, 0, strings_posixct); SET_STRING_ELT(classes_posixct, 1, strings_posixt); chrs_subset = Rf_mkString("subset"); R_PreserveObject(chrs_subset); chrs_extract = Rf_mkString("extract"); R_PreserveObject(chrs_extract); chrs_assign = Rf_mkString("assign"); R_PreserveObject(chrs_assign); chrs_rename = Rf_mkString("rename"); R_PreserveObject(chrs_rename); chrs_remove = Rf_mkString("remove"); R_PreserveObject(chrs_remove); chrs_negate = Rf_mkString("negate"); R_PreserveObject(chrs_negate); chrs_numeric = Rf_mkString("numeric"); R_PreserveObject(chrs_numeric); chrs_character = Rf_mkString("character"); R_PreserveObject(chrs_character); chrs_empty = Rf_mkString(""); R_PreserveObject(chrs_empty); classes_tibble = Rf_allocVector(STRSXP, 3); R_PreserveObject(classes_tibble); strings_tbl_df = Rf_mkChar("tbl_df"); SET_STRING_ELT(classes_tibble, 0, strings_tbl_df); strings_tbl = Rf_mkChar("tbl"); SET_STRING_ELT(classes_tibble, 1, strings_tbl); SET_STRING_ELT(classes_tibble, 2, strings_data_frame); classes_list_of = Rf_allocVector(STRSXP, 3); R_PreserveObject(classes_list_of); strings_vctrs_list_of = Rf_mkChar("vctrs_list_of"); SET_STRING_ELT(classes_list_of, 0, strings_vctrs_list_of); SET_STRING_ELT(classes_list_of, 1, strings_vctrs_vctr); SET_STRING_ELT(classes_list_of, 2, Rf_mkChar("list")); classes_vctrs_group_rle = Rf_allocVector(STRSXP, 3); R_PreserveObject(classes_vctrs_group_rle); SET_STRING_ELT(classes_vctrs_group_rle, 0, Rf_mkChar("vctrs_group_rle")); SET_STRING_ELT(classes_vctrs_group_rle, 1, strings_vctrs_rcrd); SET_STRING_ELT(classes_vctrs_group_rle, 2, strings_vctrs_vctr); vctrs_shared_empty_lgl = Rf_allocVector(LGLSXP, 0); R_PreserveObject(vctrs_shared_empty_lgl); MARK_NOT_MUTABLE(vctrs_shared_empty_lgl); vctrs_shared_empty_int = Rf_allocVector(INTSXP, 0); R_PreserveObject(vctrs_shared_empty_int); MARK_NOT_MUTABLE(vctrs_shared_empty_int); vctrs_shared_empty_dbl = Rf_allocVector(REALSXP, 0); R_PreserveObject(vctrs_shared_empty_dbl); MARK_NOT_MUTABLE(vctrs_shared_empty_dbl); vctrs_shared_empty_cpl = Rf_allocVector(CPLXSXP, 0); R_PreserveObject(vctrs_shared_empty_cpl); MARK_NOT_MUTABLE(vctrs_shared_empty_cpl); vctrs_shared_empty_chr = Rf_allocVector(STRSXP, 0); R_PreserveObject(vctrs_shared_empty_chr); MARK_NOT_MUTABLE(vctrs_shared_empty_chr); vctrs_shared_empty_raw = Rf_allocVector(RAWSXP, 0); R_PreserveObject(vctrs_shared_empty_raw); MARK_NOT_MUTABLE(vctrs_shared_empty_raw); vctrs_shared_empty_list = Rf_allocVector(VECSXP, 0); R_PreserveObject(vctrs_shared_empty_list); MARK_NOT_MUTABLE(vctrs_shared_empty_list); vctrs_shared_empty_date = Rf_allocVector(REALSXP, 0); R_PreserveObject(vctrs_shared_empty_date); Rf_setAttrib(vctrs_shared_empty_date, R_ClassSymbol, classes_date); MARK_NOT_MUTABLE(vctrs_shared_empty_date); vctrs_shared_true = Rf_allocVector(LGLSXP, 1); R_PreserveObject(vctrs_shared_true); MARK_NOT_MUTABLE(vctrs_shared_true); LOGICAL(vctrs_shared_true)[0] = 1; vctrs_shared_false = Rf_allocVector(LGLSXP, 1); R_PreserveObject(vctrs_shared_false); MARK_NOT_MUTABLE(vctrs_shared_false); LOGICAL(vctrs_shared_false)[0] = 0; vctrs_shared_na_cpl.i = NA_REAL; vctrs_shared_na_cpl.r = NA_REAL; vctrs_shared_na_lgl = r_lgl(NA_LOGICAL); R_PreserveObject(vctrs_shared_na_lgl); MARK_NOT_MUTABLE(vctrs_shared_na_lgl); vctrs_shared_zero_int = Rf_allocVector(INTSXP, 1); INTEGER(vctrs_shared_zero_int)[0] = 0; R_PreserveObject(vctrs_shared_zero_int); MARK_NOT_MUTABLE(vctrs_shared_zero_int); syms_i = Rf_install("i"); syms_n = Rf_install("n"); syms_x = Rf_install("x"); syms_y = Rf_install("y"); syms_to = Rf_install("to"); syms_dots = Rf_install("..."); syms_bracket = Rf_install("["); syms_arg = Rf_install("arg"); syms_x_arg = Rf_install("x_arg"); syms_y_arg = Rf_install("y_arg"); syms_to_arg = Rf_install("to_arg"); syms_subscript_arg = Rf_install("subscript_arg"); syms_out = Rf_install("out"); syms_value = Rf_install("value"); syms_quiet = Rf_install("quiet"); syms_dot_name_spec = Rf_install(".name_spec"); syms_outer = Rf_install("outer"); syms_inner = Rf_install("inner"); syms_tilde = Rf_install("~"); syms_dot_environment = Rf_install(".Environment"); syms_ptype = Rf_install("ptype"); syms_missing = R_MissingArg; syms_size = Rf_install("size"); syms_subscript_action = Rf_install("subscript_action"); syms_subscript_type = Rf_install("subscript_type"); syms_repair = Rf_install("repair"); syms_tzone = Rf_install("tzone"); fns_bracket = Rf_findVar(syms_bracket, R_BaseEnv); fns_quote = Rf_findVar(Rf_install("quote"), R_BaseEnv); fns_names = Rf_findVar(Rf_install("names"), R_BaseEnv); new_env_call = r_parse_eval("as.call(list(new.env, TRUE, NULL, NULL))", R_BaseEnv); R_PreserveObject(new_env_call); new_env__parent_node = CDDR(new_env_call); new_env__size_node = CDR(new_env__parent_node); new_function_call = r_parse_eval("as.call(list(`function`, NULL, NULL))", R_BaseEnv); R_PreserveObject(new_function_call); new_function__formals_node = CDR(new_function_call); new_function__body_node = CDR(new_function__formals_node); const char* formals_code = "pairlist2(... = , .x = quote(..1), .y = quote(..2), . = quote(..1))"; rlang_formula_formals = r_parse_eval(formals_code, ns); R_PreserveObject(rlang_formula_formals); args_empty_ = new_wrapper_arg(NULL, ""); args_empty = &args_empty_; rlang_is_splice_box = (bool (*)(SEXP)) R_GetCCallable("rlang", "rlang_is_splice_box"); rlang_unbox = (SEXP (*)(SEXP)) R_GetCCallable("rlang", "rlang_unbox"); rlang_env_dots_values = (SEXP (*)(SEXP)) R_GetCCallable("rlang", "rlang_env_dots_values"); rlang_env_dots_list = (SEXP (*)(SEXP)) R_GetCCallable("rlang", "rlang_env_dots_list"); syms_as_data_frame2 = Rf_install("as.data.frame2"); syms_colnames = Rf_install("colnames"); fns_as_data_frame2 = r_env_get(ns, syms_as_data_frame2); fns_colnames = r_env_get(R_BaseEnv, syms_colnames); compact_seq_attrib = Rf_cons(R_NilValue, R_NilValue); R_PreserveObject(compact_seq_attrib); SET_TAG(compact_seq_attrib, Rf_install("vctrs_compact_seq")); compact_rep_attrib = Rf_cons(R_NilValue, R_NilValue); R_PreserveObject(compact_rep_attrib); SET_TAG(compact_rep_attrib, Rf_install("vctrs_compact_rep")); // We assume the following in `union vctrs_dbl_indicator` VCTRS_ASSERT(sizeof(double) == sizeof(int64_t)); VCTRS_ASSERT(sizeof(double) == 2 * sizeof(int)); } vctrs/src/bind.c0000644000176200001440000003235713623014634013276 0ustar liggesusers#include "vctrs.h" #include "type-data-frame.h" #include "utils.h" static SEXP vec_rbind(SEXP xs, SEXP ptype, SEXP id, struct name_repair_opts* name_repair); static SEXP as_df_row(SEXP x, struct name_repair_opts* name_repair); static SEXP as_df_row_impl(SEXP x, struct name_repair_opts* name_repair); struct name_repair_opts validate_bind_name_repair(SEXP name_repair, bool allow_minimal); // [[ register(external = TRUE) ]] SEXP vctrs_rbind(SEXP call, SEXP op, SEXP args, SEXP env) { args = CDR(args); SEXP xs = PROTECT(rlang_env_dots_list(env)); SEXP ptype = PROTECT(Rf_eval(CAR(args), env)); args = CDR(args); SEXP names_to = PROTECT(Rf_eval(CAR(args), env)); args = CDR(args); SEXP name_repair = PROTECT(Rf_eval(CAR(args), env)); if (names_to != R_NilValue) { if (!r_is_string(names_to)) { Rf_errorcall(R_NilValue, "`.names_to` must be `NULL` or a string."); } names_to = r_chr_get(names_to, 0); } struct name_repair_opts name_repair_opts = validate_bind_name_repair(name_repair, false); PROTECT_NAME_REPAIR_OPTS(&name_repair_opts); SEXP out = vec_rbind(xs, ptype, names_to, &name_repair_opts); UNPROTECT(5); return out; } // From type.c SEXP vctrs_type_common_impl(SEXP dots, SEXP ptype); static SEXP vec_rbind(SEXP xs, SEXP ptype, SEXP names_to, struct name_repair_opts* name_repair) { int nprot = 0; R_len_t n = Rf_length(xs); for (R_len_t i = 0; i < n; ++i) { SET_VECTOR_ELT(xs, i, as_df_row(VECTOR_ELT(xs, i), name_repair)); } // The common type holds information about common column names, // types, etc. Each element of `xs` needs to be cast to that type // before assignment. ptype = PROTECT_N(vctrs_type_common_impl(xs, ptype), &nprot); if (ptype == R_NilValue) { UNPROTECT(nprot); return new_data_frame(vctrs_shared_empty_list, 0); } if (TYPEOF(ptype) == LGLSXP && !Rf_length(ptype)) { ptype = as_df_row_impl(vctrs_shared_na_lgl, name_repair); PROTECT_N(ptype, &nprot); } if (!is_data_frame(ptype)) { Rf_errorcall(R_NilValue, "Can't bind objects that are not coercible to a data frame."); } // Find individual input sizes and total size of output R_len_t nrow = 0; bool has_rownames = false; if (names_to == R_NilValue && r_names(xs) != R_NilValue) { // Names of inputs become row names when `names_to` isn't supplied has_rownames = true; } SEXP ns_placeholder = PROTECT_N(Rf_allocVector(INTSXP, n), &nprot); int* ns = INTEGER(ns_placeholder); for (R_len_t i = 0; i < n; ++i) { SEXP elt = VECTOR_ELT(xs, i); R_len_t size = (elt == R_NilValue) ? 0 : vec_size(elt); nrow += size; ns[i] = size; if (!has_rownames && is_data_frame(elt)) { has_rownames = rownames_type(df_rownames(elt)) == ROWNAMES_IDENTIFIERS; } } SEXP out = PROTECT_N(vec_init(ptype, nrow), &nprot); SEXP idx = PROTECT_N(compact_seq(0, 0, true), &nprot); int* idx_ptr = INTEGER(idx); SEXP rownames = R_NilValue; if (has_rownames) { rownames = PROTECT_N(Rf_allocVector(STRSXP, nrow), &nprot); } SEXP nms = PROTECT_N(r_names(xs), &nprot); bool has_names = nms != R_NilValue; bool has_names_to = names_to != R_NilValue; const SEXP* nms_p = NULL; if (has_names) { nms_p = STRING_PTR_RO(nms); } SEXP names_to_col = R_NilValue; SEXPTYPE names_to_type = 99; void* names_to_p = NULL; const void* index_p = NULL; if (has_names_to) { SEXP index = R_NilValue; if (has_names) { index = nms; } else { index = PROTECT_N(Rf_allocVector(INTSXP, n), &nprot); r_int_fill_seq(index, 1, n); } index_p = r_vec_const_deref(index); names_to_type = TYPEOF(index); names_to_col = PROTECT_N(Rf_allocVector(names_to_type, nrow), &nprot); names_to_p = r_vec_deref(names_to_col); } // Compact sequences use 0-based counters R_len_t counter = 0; for (R_len_t i = 0; i < n; ++i) { R_len_t size = ns[i]; if (!size) { continue; } SEXP x = VECTOR_ELT(xs, i); SEXP tbl = PROTECT(vec_cast(x, ptype, args_empty, args_empty)); init_compact_seq(idx_ptr, counter, size, true); df_assign(out, idx, tbl, false); if (has_rownames) { SEXP rn = df_rownames(x); if (has_names && nms_p[i] != strings_empty && !has_names_to) { if (rownames_type(rn) == ROWNAMES_IDENTIFIERS) { rn = r_chr_paste_prefix(rn, CHAR(nms_p[i]), "..."); } else if (size > 1) { rn = r_seq_chr(CHAR(nms_p[i]), size); } else { rn = r_str_as_character(nms_p[i]); } } PROTECT(rn); if (rownames_type(rn) == ROWNAMES_IDENTIFIERS) { chr_assign(rownames, idx, rn, false); } UNPROTECT(1); } // Assign current name to group vector, if supplied if (has_names_to) { r_vec_fill(names_to_type, names_to_p, index_p, i, size); r_vec_ptr_inc(names_to_type, &names_to_p, size); } counter += size; UNPROTECT(1); } if (has_rownames) { rownames = PROTECT(vec_as_names(rownames, default_unique_repair_opts)); Rf_setAttrib(out, R_RowNamesSymbol, rownames); UNPROTECT(1); } if (has_names_to) { out = df_poke_at(out, names_to, names_to_col); } UNPROTECT(nprot); return out; } static SEXP as_df_row(SEXP x, struct name_repair_opts* name_repair) { if (vec_is_unspecified(x) && r_names(x) == R_NilValue) { return x; } else { return as_df_row_impl(x, name_repair); } } static SEXP as_df_row_impl(SEXP x, struct name_repair_opts* name_repair) { if (x == R_NilValue) { return x; } if (is_data_frame(x)) { return x; } int nprot = 0; R_len_t ndim = vec_dim_n(x); if (ndim > 2) { Rf_errorcall(R_NilValue, "Can't bind arrays."); } if (ndim == 2) { SEXP names = PROTECT_N(vec_unique_colnames(x, name_repair->quiet), &nprot); SEXP out = PROTECT_N(r_as_data_frame(x), &nprot); r_poke_names(out, names); UNPROTECT(nprot); return out; } SEXP nms = PROTECT_N(vec_names(x), &nprot); // Remove names as they are promoted to data frame column names if (nms != R_NilValue) { x = PROTECT_N(r_maybe_duplicate(x), &nprot); r_poke_names(x, R_NilValue); } if (nms == R_NilValue) { nms = PROTECT_N(vec_unique_names(x, name_repair->quiet), &nprot); } else { nms = PROTECT_N(vec_as_names(nms, name_repair), &nprot); } x = PROTECT_N(vec_chop(x, R_NilValue), &nprot); r_poke_names(x, nms); x = new_data_frame(x, 1); UNPROTECT(nprot); return x; } // [[ register() ]] SEXP vctrs_as_df_row(SEXP x, SEXP quiet) { struct name_repair_opts name_repair_opts = { .type = name_repair_unique, .fn = R_NilValue, .quiet = LOGICAL(quiet)[0] }; return as_df_row(x, &name_repair_opts); } static SEXP as_df_col(SEXP x, SEXP outer, bool* allow_pack); static SEXP vec_cbind(SEXP xs, SEXP ptype, SEXP size, struct name_repair_opts* name_repair); static SEXP cbind_container_type(SEXP x, void* data); // [[ register(external = TRUE) ]] SEXP vctrs_cbind(SEXP call, SEXP op, SEXP args, SEXP env) { args = CDR(args); SEXP xs = PROTECT(rlang_env_dots_list(env)); SEXP ptype = PROTECT(Rf_eval(CAR(args), env)); args = CDR(args); SEXP size = PROTECT(Rf_eval(CAR(args), env)); args = CDR(args); SEXP name_repair = PROTECT(Rf_eval(CAR(args), env)); struct name_repair_opts name_repair_opts = validate_bind_name_repair(name_repair, true); PROTECT_NAME_REPAIR_OPTS(&name_repair_opts); SEXP out = vec_cbind(xs, ptype, size, &name_repair_opts); UNPROTECT(5); return out; } static SEXP vec_cbind(SEXP xs, SEXP ptype, SEXP size, struct name_repair_opts* name_repair) { R_len_t n = Rf_length(xs); // Find the common container type of inputs SEXP rownames = R_NilValue; SEXP containers = PROTECT(map_with_data(xs, &cbind_container_type, &rownames)); ptype = PROTECT(cbind_container_type(ptype, &rownames)); SEXP type = PROTECT(vctrs_type_common_impl(containers, ptype)); if (type == R_NilValue) { type = new_data_frame(vctrs_shared_empty_list, 0); } else if (!is_data_frame(type)) { type = r_as_data_frame(type); } UNPROTECT(1); PROTECT(type); R_len_t nrow; if (size == R_NilValue) { nrow = vec_size_common(xs, 0); } else { nrow = size_validate(size, ".size"); } if (rownames != R_NilValue && Rf_length(rownames) != nrow) { rownames = PROTECT(vec_recycle(rownames, nrow, args_empty)); rownames = vec_as_unique_names(rownames, false); UNPROTECT(1); } PROTECT(rownames); // Convert inputs to data frames, validate, and collect total number of columns SEXP xs_names = PROTECT(r_names(xs)); bool has_names = xs_names != R_NilValue; SEXP* xs_names_p = has_names ? STRING_PTR(xs_names) : NULL; R_len_t ncol = 0; for (R_len_t i = 0; i < n; ++i) { SEXP x = VECTOR_ELT(xs, i); if (x == R_NilValue) { continue; } x = PROTECT(vec_recycle(x, nrow, args_empty)); SEXP outer_name = has_names ? xs_names_p[i] : strings_empty; bool allow_packing; x = PROTECT(as_df_col(x, outer_name, &allow_packing)); // Remove outer name of column vectors because they shouldn't be repacked if (has_names && !allow_packing) { SET_STRING_ELT(xs_names, i, strings_empty); } SET_VECTOR_ELT(xs, i, x); UNPROTECT(2); // Named inputs are packed in a single column R_len_t x_ncol = outer_name == strings_empty ? Rf_length(x) : 1; ncol += x_ncol; } // Fill in columns SEXP out = PROTECT(Rf_allocVector(VECSXP, ncol)); SEXP names = PROTECT(Rf_allocVector(STRSXP, ncol)); SEXP idx = PROTECT(compact_seq(0, 0, true)); int* idx_ptr = INTEGER(idx); R_len_t counter = 0; for (R_len_t i = 0; i < n; ++i) { SEXP x = VECTOR_ELT(xs, i); if (x == R_NilValue) { continue; } SEXP outer_name = has_names ? xs_names_p[i] : strings_empty; if (outer_name != strings_empty) { SET_VECTOR_ELT(out, counter, x); SET_STRING_ELT(names, counter, outer_name); ++counter; continue; } R_len_t xn = Rf_length(x); init_compact_seq(idx_ptr, counter, xn, true); list_assign(out, idx, x, false); SEXP xnms = PROTECT(r_names(x)); if (xnms != R_NilValue) { chr_assign(names, idx, xnms, false); } counter += xn; UNPROTECT(1); } names = PROTECT(vec_as_names(names, name_repair)); Rf_setAttrib(out, R_NamesSymbol, names); if (rownames != R_NilValue) { Rf_setAttrib(out, R_RowNamesSymbol, rownames); } out = vec_restore(out, type, R_NilValue); UNPROTECT(9); return out; } static SEXP cbind_container_type(SEXP x, void* data) { if (is_data_frame(x)) { SEXP rn = df_rownames(x); if (rownames_type(rn) == ROWNAMES_IDENTIFIERS) { SEXP* learned_rn_p = (SEXP*) data; SEXP learned_rn = *learned_rn_p; if (learned_rn == R_NilValue) { *learned_rn_p = rn; } else if (!equal_object(rn, learned_rn)) { Rf_errorcall(R_NilValue, "Can't column-bind data frames with different row names."); } } return df_container_type(x); } else { return R_NilValue; } } static SEXP shaped_as_df_col(SEXP x, SEXP outer); static SEXP vec_as_df_col(SEXP x, SEXP outer); // [[ register() ]] SEXP vctrs_as_df_col(SEXP x, SEXP outer) { bool allow_pack; return as_df_col(x, r_chr_get(outer, 0), &allow_pack); } static SEXP as_df_col(SEXP x, SEXP outer, bool* allow_pack) { if (is_data_frame(x)) { *allow_pack = true; return Rf_shallow_duplicate(x); } R_len_t ndim = vec_bare_dim_n(x); if (ndim > 2) { Rf_errorcall(R_NilValue, "Can't bind arrays."); } if (ndim > 0) { *allow_pack = true; return shaped_as_df_col(x, outer); } *allow_pack = false; return vec_as_df_col(x, outer); } static SEXP shaped_as_df_col(SEXP x, SEXP outer) { // If packed, store array as a column if (outer != strings_empty) { return x; } // If unpacked, transform to data frame first. We repair names // after unpacking and concatenation. SEXP out = PROTECT(r_as_data_frame(x)); // Remove names if they were repaired by `as.data.frame()` if (colnames(x) == R_NilValue) { r_poke_names(out, R_NilValue); } UNPROTECT(1); return out; } static SEXP vec_as_df_col(SEXP x, SEXP outer) { SEXP out = PROTECT(Rf_allocVector(VECSXP, 1)); SET_VECTOR_ELT(out, 0, x); if (outer != strings_empty) { SEXP names = PROTECT(r_str_as_character(outer)); Rf_setAttrib(out, R_NamesSymbol, names); UNPROTECT(1); } init_data_frame(out, Rf_length(x)); UNPROTECT(1); return out; } struct name_repair_opts validate_bind_name_repair(SEXP name_repair, bool allow_minimal) { struct name_repair_opts opts = new_name_repair_opts(name_repair, false); switch (opts.type) { case name_repair_custom: case name_repair_unique: case name_repair_universal: case name_repair_check_unique: break; case name_repair_minimal: if (allow_minimal) break; // else fallthrough default: if (allow_minimal) { Rf_errorcall(R_NilValue, "`.name_repair` can't be `\"%s\"`.\n" "It must be one of `\"unique\"`, `\"universal\"`, `\"check_unique\"`, or `\"minimal\"`.", name_repair_arg_as_c_string(opts.type)); } else { Rf_errorcall(R_NilValue, "`.name_repair` can't be `\"%s\"`.\n" "It must be one of `\"unique\"`, `\"universal\"`, or `\"check_unique\"`.", name_repair_arg_as_c_string(opts.type)); } } return opts; } vctrs/src/type-data-frame.h0000644000176200001440000000113313622451540015333 0ustar liggesusers#ifndef VCTRS_TYPE_DATA_FRAME_H #define VCTRS_TYPE_DATA_FRAME_H SEXP new_data_frame(SEXP x, R_len_t n); void init_data_frame(SEXP x, R_len_t n); void init_tibble(SEXP x, R_len_t n); void init_compact_rownames(SEXP x, R_len_t n); SEXP df_rownames(SEXP x); bool is_native_df(SEXP x); R_len_t compact_rownames_length(SEXP x); SEXP df_container_type(SEXP x); SEXP df_poke(SEXP x, R_len_t i, SEXP value); SEXP df_poke_at(SEXP x, SEXP name, SEXP value); enum rownames_type { ROWNAMES_AUTOMATIC, ROWNAMES_AUTOMATIC_COMPACT, ROWNAMES_IDENTIFIERS }; enum rownames_type rownames_type(SEXP rn); #endif vctrs/src/compare.c0000644000176200001440000003011213622451540013773 0ustar liggesusers#include "vctrs.h" #include "utils.h" #include static void stop_not_comparable(SEXP x, SEXP y, const char* message) { Rf_errorcall(R_NilValue, "`x` and `y` are not comparable: %s", message); } // https://stackoverflow.com/questions/10996418 static inline int icmp(int x, int y) { return (x > y) - (x < y); } int qsort_icmp(const void* x, const void* y) { return icmp(*((int*) x), *((int*) y)); } static int dcmp(double x, double y) { return (x > y) - (x < y); } // UTF-8 translation is successful in these cases: // - (utf8 + latin1), (unknown + utf8), (unknown + latin1) // UTF-8 translation fails purposefully in these cases: // - (bytes + utf8), (bytes + latin1), (bytes + unknown) // UTF-8 translation is not attempted in these cases: // - (utf8 + utf8), (latin1 + latin1), (unknown + unknown), (bytes + bytes) static int scmp(SEXP x, SEXP y) { if (x == y) { return 0; } // Same encoding if (Rf_getCharCE(x) == Rf_getCharCE(y)) { int cmp = strcmp(CHAR(x), CHAR(y)); return cmp / abs(cmp); } const void *vmax = vmaxget(); int cmp = strcmp(Rf_translateCharUTF8(x), Rf_translateCharUTF8(y)); vmaxset(vmax); if (cmp == 0) { return cmp; } else { return cmp / abs(cmp); } } // ----------------------------------------------------------------------------- static inline int lgl_compare_scalar(const int* x, const int* y, bool na_equal) { int xi = *x; int yj = *y; if (na_equal) { return icmp(xi, yj); } else { return (xi == NA_LOGICAL || yj == NA_LOGICAL) ? NA_INTEGER : icmp(xi, yj); } } static inline int int_compare_scalar(const int* x, const int* y, bool na_equal) { int xi = *x; int yj = *y; if (na_equal) { return icmp(xi, yj); } else { return (xi == NA_INTEGER || yj == NA_INTEGER) ? NA_INTEGER : icmp(xi, yj); } } static inline int dbl_compare_scalar(const double* x, const double* y, bool na_equal) { double xi = *x; double yj = *y; if (na_equal) { enum vctrs_dbl_class x_class = dbl_classify(xi); enum vctrs_dbl_class y_class = dbl_classify(yj); switch (x_class) { case vctrs_dbl_number: { switch (y_class) { case vctrs_dbl_number: return dcmp(xi, yj); case vctrs_dbl_missing: return 1; case vctrs_dbl_nan: return 1; } } case vctrs_dbl_missing: { switch (y_class) { case vctrs_dbl_number: return -1; case vctrs_dbl_missing: return 0; case vctrs_dbl_nan: return 1; } } case vctrs_dbl_nan: { switch (y_class) { case vctrs_dbl_number: return -1; case vctrs_dbl_missing: return -1; case vctrs_dbl_nan: return 0; } } } } else { return (isnan(xi) || isnan(yj)) ? NA_INTEGER : dcmp(xi, yj); } never_reached("dbl_compare_scalar"); } static inline int chr_compare_scalar(const SEXP* x, const SEXP* y, bool na_equal) { const SEXP xi = *x; const SEXP yj = *y; if (na_equal) { if (xi == NA_STRING) { return (yj == NA_STRING) ? 0 : -1; } else { return (yj == NA_STRING) ? 1 : scmp(xi, yj); } } else { return (xi == NA_STRING || yj == NA_STRING) ? NA_INTEGER : scmp(xi, yj); } } static inline int df_compare_scalar(SEXP x, R_len_t i, SEXP y, R_len_t j, bool na_equal, int n_col) { int cmp; for (int k = 0; k < n_col; ++k) { SEXP col_x = VECTOR_ELT(x, k); SEXP col_y = VECTOR_ELT(y, k); cmp = compare_scalar(col_x, i, col_y, j, na_equal); if (cmp != 0) { return cmp; } } return cmp; } // ----------------------------------------------------------------------------- // [[ include("vctrs.h") ]] int compare_scalar(SEXP x, R_len_t i, SEXP y, R_len_t j, bool na_equal) { switch (TYPEOF(x)) { case LGLSXP: return lgl_compare_scalar(LOGICAL(x) + i, LOGICAL(y) + j, na_equal); case INTSXP: return int_compare_scalar(INTEGER(x) + i, INTEGER(y) + j, na_equal); case REALSXP: return dbl_compare_scalar(REAL(x) + i, REAL(y) + j, na_equal); case STRSXP: return chr_compare_scalar(STRING_PTR(x) + i, STRING_PTR(y) + j, na_equal); default: break; } switch (vec_proxy_typeof(x)) { case vctrs_type_list: stop_not_comparable(x, y, "lists are not comparable"); case vctrs_type_dataframe: { int n_col = Rf_length(x); if (n_col != Rf_length(y)) { stop_not_comparable(x, y, "must have the same number of columns"); } if (n_col == 0) { stop_not_comparable(x, y, "data frame with zero columns"); } return df_compare_scalar(x, i, y, j, na_equal, n_col); } default: break; } Rf_errorcall(R_NilValue, "Unsupported type %s", Rf_type2char(TYPEOF(x))); } // ----------------------------------------------------------------------------- static SEXP df_compare(SEXP x, SEXP y, bool na_equal, R_len_t n_row); #define COMPARE(CTYPE, CONST_DEREF, SCALAR_COMPARE) \ do { \ SEXP out = PROTECT(Rf_allocVector(INTSXP, size)); \ int* p_out = INTEGER(out); \ \ const CTYPE* p_x = CONST_DEREF(x); \ const CTYPE* p_y = CONST_DEREF(y); \ \ for (R_len_t i = 0; i < size; ++i, ++p_x, ++p_y) { \ p_out[i] = SCALAR_COMPARE(p_x, p_y, na_equal); \ } \ \ UNPROTECT(1); \ return out; \ } \ while (0) // [[ register() ]] SEXP vctrs_compare(SEXP x, SEXP y, SEXP na_equal_) { bool na_equal = Rf_asLogical(na_equal_); R_len_t size = vec_size(x); enum vctrs_type type = vec_proxy_typeof(x); if (type != vec_proxy_typeof(y) || size != vec_size(y)) { stop_not_comparable(x, y, "must have the same types and lengths"); } switch (type) { case vctrs_type_logical: COMPARE(int, LOGICAL_RO, lgl_compare_scalar); case vctrs_type_integer: COMPARE(int, INTEGER_RO, int_compare_scalar); case vctrs_type_double: COMPARE(double, REAL_RO, dbl_compare_scalar); case vctrs_type_character: COMPARE(SEXP, STRING_PTR_RO, chr_compare_scalar); case vctrs_type_dataframe: return df_compare(x, y, na_equal, size); case vctrs_type_scalar: Rf_errorcall(R_NilValue, "Can't compare scalars with `vctrs_compare()`"); case vctrs_type_list: Rf_errorcall(R_NilValue, "Can't compare lists with `vctrs_compare()`"); default: Rf_error("Unimplemented type in `vctrs_compare()`"); } } #undef COMPARE // ----------------------------------------------------------------------------- static struct vctrs_df_rowwise_info vec_compare_col(SEXP x, SEXP y, bool na_equal, struct vctrs_df_rowwise_info info, R_len_t n_row); static struct vctrs_df_rowwise_info df_compare_impl(SEXP x, SEXP y, bool na_equal, struct vctrs_df_rowwise_info info, R_len_t n_row); static struct vctrs_df_rowwise_info init_rowwise_compare_info(R_len_t n_row) { struct vctrs_df_rowwise_info info; // Initialize to "equality" value // and only change if we learn that it differs info.out = PROTECT(Rf_allocVector(INTSXP, n_row)); int* p_out = INTEGER(info.out); memset(p_out, 0, n_row * sizeof(int)); // To begin with, no rows have a known comparison value info.row_known = PROTECT(Rf_allocVector(RAWSXP, n_row * sizeof(bool))); info.p_row_known = (bool*) RAW(info.row_known); memset(info.p_row_known, false, n_row * sizeof(bool)); info.remaining = n_row; UNPROTECT(2); return info; } static SEXP df_compare(SEXP x, SEXP y, bool na_equal, R_len_t n_row) { int nprot = 0; struct vctrs_df_rowwise_info info = init_rowwise_compare_info(n_row); PROTECT_DF_ROWWISE_INFO(&info, &nprot); info = df_compare_impl(x, y, na_equal, info, n_row); UNPROTECT(nprot); return info.out; } static struct vctrs_df_rowwise_info df_compare_impl(SEXP x, SEXP y, bool na_equal, struct vctrs_df_rowwise_info info, R_len_t n_row) { int n_col = Rf_length(x); if (n_col == 0) { stop_not_comparable(x, y, "data frame with zero columns"); } if (n_col != Rf_length(y)) { stop_not_comparable(x, y, "must have the same number of columns"); } for (R_len_t i = 0; i < n_col; ++i) { SEXP x_col = VECTOR_ELT(x, i); SEXP y_col = VECTOR_ELT(y, i); info = vec_compare_col(x_col, y_col, na_equal, info, n_row); // If we know all comparison values, break if (info.remaining == 0) { break; } } return info; } // ----------------------------------------------------------------------------- #define COMPARE_COL(CTYPE, CONST_DEREF, SCALAR_COMPARE) \ do { \ int* p_out = INTEGER(info.out); \ \ const CTYPE* p_x = CONST_DEREF(x); \ const CTYPE* p_y = CONST_DEREF(y); \ \ for (R_len_t i = 0; i < n_row; ++i, ++p_x, ++p_y) { \ if (info.p_row_known[i]) { \ continue; \ } \ \ int cmp = SCALAR_COMPARE(p_x, p_y, na_equal); \ \ if (cmp != 0) { \ p_out[i] = cmp; \ info.p_row_known[i] = true; \ --info.remaining; \ \ if (info.remaining == 0) { \ break; \ } \ } \ } \ \ return info; \ } \ while (0) static struct vctrs_df_rowwise_info vec_compare_col(SEXP x, SEXP y, bool na_equal, struct vctrs_df_rowwise_info info, R_len_t n_row) { switch (vec_proxy_typeof(x)) { case vctrs_type_logical: COMPARE_COL(int, LOGICAL_RO, lgl_compare_scalar); case vctrs_type_integer: COMPARE_COL(int, INTEGER_RO, int_compare_scalar); case vctrs_type_double: COMPARE_COL(double, REAL_RO, dbl_compare_scalar); case vctrs_type_character: COMPARE_COL(SEXP, STRING_PTR_RO, chr_compare_scalar); case vctrs_type_dataframe: return df_compare_impl(x, y, na_equal, info, n_row); case vctrs_type_scalar: Rf_errorcall(R_NilValue, "Can't compare scalars with `vctrs_compare()`"); case vctrs_type_list: Rf_errorcall(R_NilValue, "Can't compare lists with `vctrs_compare()`"); default: Rf_error("Unimplemented type in `vctrs_compare()`"); } } #undef COMPARE_COL vctrs/src/unspecified.c0000644000176200001440000000374113622451540014653 0ustar liggesusers#include "vctrs.h" #include "utils.h" // Initialised at load time static SEXP unspecified_attrib = NULL; SEXP vctrs_shared_empty_uns = NULL; // [[ include("vctrs.h") ]] SEXP vec_unspecified(R_len_t n) { SEXP out = PROTECT(Rf_allocVector(LGLSXP, n)); r_lgl_fill(out, NA_LOGICAL, n); SET_ATTRIB(out, unspecified_attrib); SET_OBJECT(out, 1); UNPROTECT(1); return out; } // [[ register ]] SEXP vctrs_unspecified(SEXP n) { if (Rf_length(n) != 1) { Rf_errorcall(R_NilValue, "`n` must be a single number"); } if (TYPEOF(n) != INTSXP) { n = vec_cast(n, vctrs_shared_empty_int, args_empty, args_empty); } int len = INTEGER(n)[0]; return vec_unspecified(len); } // [[ include("vctrs.h") ]] bool vec_is_unspecified(SEXP x) { if (TYPEOF(x) != LGLSXP) { return false; } SEXP attrib = ATTRIB(x); if (attrib == unspecified_attrib) { return true; } if (attrib != R_NilValue) { // The unspecified vector might have been created outside the // session (e.g. serialisation) if (Rf_inherits(x, "vctrs_unspecified")) { return true; } if (OBJECT(x)) { return false; } if (has_dim(x)) { return false; } } R_len_t n = Rf_length(x); if (n == 0) { return false; } R_len_t* p_x = LOGICAL(x); for (R_len_t i = 0; i < n; ++i) { if (p_x[i] != NA_LOGICAL) { return false; } } return true; } // [[ register ]] SEXP vctrs_is_unspecified(SEXP x) { return Rf_ScalarLogical(vec_is_unspecified(x)); } void vctrs_init_unspecified(SEXP ns) { { SEXP unspecified_class = PROTECT(Rf_allocVector(STRSXP, 1)); SET_STRING_ELT(unspecified_class, 0, Rf_mkChar("vctrs_unspecified")); unspecified_attrib = Rf_cons(unspecified_class, R_NilValue); R_PreserveObject(unspecified_attrib); SET_TAG(unspecified_attrib, R_ClassSymbol); UNPROTECT(1); } vctrs_shared_empty_uns = vec_unspecified(0); R_PreserveObject(vctrs_shared_empty_uns); MARK_NOT_MUTABLE(vctrs_shared_empty_uns); } vctrs/src/slice.h0000644000176200001440000000054713622451540013462 0ustar liggesusers#ifndef VCTRS_SLICE_H #define VCTRS_SLICE_H extern SEXP syms_vec_slice_dispatch_integer64; extern SEXP fns_vec_slice_dispatch_integer64; SEXP slice_names(SEXP names, SEXP subscript); SEXP slice_rownames(SEXP names, SEXP subscript); SEXP vec_slice_base(enum vctrs_type type, SEXP x, SEXP subscript); SEXP vec_slice_fallback(SEXP x, SEXP subscript); #endif vctrs/src/cast.c0000644000176200001440000002665113623013722013311 0ustar liggesusers#include "vctrs.h" #include "type-data-frame.h" #include "utils.h" // Initialised at load time static SEXP syms_vec_cast_dispatch = NULL; static SEXP syms_df_lossy_cast = NULL; static SEXP fns_vec_cast_dispatch = NULL; static SEXP fns_df_lossy_cast = NULL; static SEXP int_as_logical(SEXP x, bool* lossy) { int* data = INTEGER(x); R_len_t n = Rf_length(x); SEXP out = PROTECT(Rf_allocVector(LGLSXP, n)); int* out_data = LOGICAL(out); for (R_len_t i = 0; i < n; ++i, ++data, ++out_data) { int elt = *data; if (elt == NA_INTEGER) { *out_data = NA_LOGICAL; continue; } if (elt != 0 && elt != 1) { *lossy = true; UNPROTECT(1); return R_NilValue; } *out_data = elt; } UNPROTECT(1); return out; } static SEXP dbl_as_logical(SEXP x, bool* lossy) { double* data = REAL(x); R_len_t n = Rf_length(x); SEXP out = PROTECT(Rf_allocVector(LGLSXP, n)); int* out_data = LOGICAL(out); for (R_len_t i = 0; i < n; ++i, ++data, ++out_data) { double elt = *data; if (isnan(elt)) { *out_data = NA_LOGICAL; continue; } if (elt != 0 && elt != 1) { *lossy = true; UNPROTECT(1); return R_NilValue; } *out_data = (int) elt; } UNPROTECT(1); return out; } static SEXP chr_as_logical(SEXP x, bool* lossy) { SEXP* data = STRING_PTR(x); R_len_t n = Rf_length(x); SEXP out = PROTECT(Rf_allocVector(LGLSXP, n)); int* out_data = LOGICAL(out); for (R_len_t i = 0; i < n; ++i, ++data, ++out_data) { SEXP str = *data; if (str == NA_STRING) { *out_data = NA_LOGICAL; continue; } const char* elt = CHAR(str); switch (elt[0]) { case 'T': if (elt[1] == '\0' || strcmp(elt, "TRUE") == 0) { *out_data = 1; continue; } break; case 'F': if (elt[1] == '\0' || strcmp(elt, "FALSE") == 0) { *out_data = 0; continue; } break; case 't': if (strcmp(elt, "true") == 0) { *out_data = 1; continue; } break; case 'f': if (strcmp(elt, "false") == 0) { *out_data = 0; continue; } break; default: break; } *lossy = true; UNPROTECT(1); return R_NilValue; } UNPROTECT(1); return out; } static SEXP lgl_as_integer(SEXP x, bool* lossy) { return Rf_coerceVector(x, INTSXP); } static SEXP dbl_as_integer(SEXP x, bool* lossy) { double* data = REAL(x); R_len_t n = Rf_length(x); SEXP out = PROTECT(Rf_allocVector(INTSXP, n)); int* out_data = INTEGER(out); for (R_len_t i = 0; i < n; ++i, ++data, ++out_data) { double elt = *data; if (elt <= INT_MIN || elt >= INT_MAX + 1.0) { *lossy = true; UNPROTECT(1); return R_NilValue; } if (isnan(elt)) { *out_data = NA_INTEGER; continue; } int value = (int) elt; if (value != elt) { *lossy = true; UNPROTECT(1); return R_NilValue; } *out_data = value; } UNPROTECT(1); return out; } static SEXP lgl_as_double(SEXP x, bool* lossy) { int* data = LOGICAL(x); R_len_t n = Rf_length(x); SEXP out = PROTECT(Rf_allocVector(REALSXP, n)); double* out_data = REAL(out); for (R_len_t i = 0; i < n; ++i, ++data, ++out_data) { int elt = *data; *out_data = (elt == NA_LOGICAL) ? NA_REAL : elt; } UNPROTECT(1); return out; } static SEXP int_as_double(SEXP x, bool* lossy) { int* data = INTEGER(x); R_len_t n = Rf_length(x); SEXP out = PROTECT(Rf_allocVector(REALSXP, n)); double* out_data = REAL(out); for (R_len_t i = 0; i < n; ++i, ++data, ++out_data) { int elt = *data; *out_data = (elt == NA_INTEGER) ? NA_REAL : elt; } UNPROTECT(1); return out; } // [[ register() ]] SEXP vctrs_df_as_dataframe(SEXP x, SEXP to, SEXP x_arg_, SEXP to_arg_) { if (!r_is_string(x_arg_)) { Rf_errorcall(R_NilValue, "`x_arg` must be a string"); } if (!r_is_string(to_arg_)) { Rf_errorcall(R_NilValue, "`to_arg` must be a string"); } struct vctrs_arg x_arg = new_wrapper_arg(NULL, r_chr_get_c_string(x_arg_, 0)); struct vctrs_arg to_arg = new_wrapper_arg(NULL, r_chr_get_c_string(to_arg_, 0)); return df_as_dataframe(x, to, &x_arg, &to_arg); } // Take all columns of `to` and preserve the order. Common columns are // cast to their types in `to`. Extra `x` columns are dropped and // cause a lossy cast. Extra `to` columns are filled with missing // values. // [[ include("vctrs.h") ]] SEXP df_as_dataframe(SEXP x, SEXP to, struct vctrs_arg* x_arg, struct vctrs_arg* to_arg) { SEXP x_names = PROTECT(r_names(x)); SEXP to_names = PROTECT(r_names(to)); if (x_names == R_NilValue || to_names == R_NilValue) { Rf_error("Internal error in `df_as_dataframe()`: Data frame must have names."); } SEXP to_dups_pos = PROTECT(vec_match(to_names, x_names)); int* to_dups_pos_data = INTEGER(to_dups_pos); R_len_t to_len = Rf_length(to_dups_pos); SEXP out = PROTECT(Rf_allocVector(VECSXP, to_len)); Rf_setAttrib(out, R_NamesSymbol, to_names); R_len_t size = df_size(x); R_len_t common_len = 0; for (R_len_t i = 0; i < to_len; ++i) { R_len_t pos = to_dups_pos_data[i]; SEXP col; if (pos == NA_INTEGER) { col = vec_init(VECTOR_ELT(to, i), size); } else { --pos; // 1-based index struct arg_data_index x_arg_data = new_index_arg_data(r_chr_get_c_string(x_names, pos), x_arg); struct arg_data_index to_arg_data = new_index_arg_data(r_chr_get_c_string(to_names, i), to_arg); struct vctrs_arg named_x_arg = new_index_arg(x_arg, &x_arg_data); struct vctrs_arg named_to_arg = new_index_arg(to_arg, &to_arg_data); ++common_len; col = vec_cast(VECTOR_ELT(x, pos), VECTOR_ELT(to, i), &named_x_arg, &named_to_arg); } SET_VECTOR_ELT(out, i, col); } // Restore data frame size before calling `vec_restore()`. `x` and // `to` might not have any columns to compute the original size. init_data_frame(out, size); out = PROTECT(vec_restore(out, to, R_NilValue)); R_len_t extra_len = Rf_length(x) - common_len; if (extra_len) { out = vctrs_dispatch3(syms_df_lossy_cast, fns_df_lossy_cast, syms_out, out, syms_x, x, syms_to, to); } UNPROTECT(5); return out; } static SEXP vec_cast_switch(SEXP x, SEXP to, bool* lossy, struct vctrs_arg* x_arg, struct vctrs_arg* to_arg) { enum vctrs_type x_type = vec_typeof(x); enum vctrs_type to_type = vec_typeof(to); if (x_type == vctrs_type_scalar) { stop_scalar_type(x, x_arg); } if (to_type == vctrs_type_scalar) { stop_scalar_type(to, to_arg); } if (x_type == vctrs_type_unspecified) { return vec_init(to, vec_size(x)); } if (to_type == vctrs_type_s3 || x_type == vctrs_type_s3) { return vec_cast_dispatch(x, to, x_type, to_type, lossy, x_arg, to_arg); } switch (to_type) { case vctrs_type_logical: switch (x_type) { case vctrs_type_logical: return x; case vctrs_type_integer: return int_as_logical(x, lossy); case vctrs_type_double: return dbl_as_logical(x, lossy); case vctrs_type_character: return chr_as_logical(x, lossy); default: break; } break; case vctrs_type_integer: switch (x_type) { case vctrs_type_logical: return lgl_as_integer(x, lossy); case vctrs_type_integer: return x; case vctrs_type_double: return dbl_as_integer(x, lossy); case vctrs_type_character: // TODO: Implement with `R_strtod()` from R_ext/utils.h break; default: break; } break; case vctrs_type_double: switch (x_type) { case vctrs_type_logical: return lgl_as_double(x, lossy); case vctrs_type_integer: return int_as_double(x, lossy); case vctrs_type_double: return x; case vctrs_type_character: // TODO: Implement with `R_strtod()` from R_ext/utils.h break; default: break; } break; case vctrs_type_character: switch (x_type) { case vctrs_type_logical: case vctrs_type_integer: case vctrs_type_double: return Rf_coerceVector(x, STRSXP); case vctrs_type_character: return x; default: break; } break; case vctrs_type_dataframe: switch (x_type) { case vctrs_type_dataframe: return df_as_dataframe(x, to, x_arg, to_arg); default: break; } default: break; } return R_NilValue; } // [[ register() ]] SEXP vctrs_cast(SEXP x, SEXP to, SEXP x_arg_, SEXP to_arg_) { if (!r_is_string(x_arg_)) { Rf_errorcall(R_NilValue, "`x_arg` must be a string"); } if (!r_is_string(to_arg_)) { Rf_errorcall(R_NilValue, "`to_arg` must be a string"); } struct vctrs_arg x_arg = new_wrapper_arg(NULL, r_chr_get_c_string(x_arg_, 0)); struct vctrs_arg to_arg = new_wrapper_arg(NULL, r_chr_get_c_string(to_arg_, 0)); return vec_cast(x, to, &x_arg, &to_arg); } // [[ include("vctrs.h") ]] SEXP vec_cast(SEXP x, SEXP to, struct vctrs_arg* x_arg, struct vctrs_arg* to_arg) { if (x == R_NilValue) { if (!vec_is_partial(to)) { vec_assert(to, to_arg); } return x; } if (to == R_NilValue) { if (!vec_is_partial(x)) { vec_assert(x, x_arg); } return x; } bool lossy = false; SEXP out = R_NilValue; if (!has_dim(x) && !has_dim(to)) { out = vec_cast_switch(x, to, &lossy, x_arg, to_arg); } if (!lossy && out != R_NilValue) { return out; } out = vctrs_dispatch4(syms_vec_cast_dispatch, fns_vec_cast_dispatch, syms_x, x, syms_to, to, syms_x_arg, PROTECT(vctrs_arg(x_arg)), syms_to_arg, PROTECT(vctrs_arg(to_arg))); UNPROTECT(2); return out; } // [[ include("vctrs.h") ]] SEXP vec_coercible_cast(SEXP x, SEXP to, struct vctrs_arg* x_arg, struct vctrs_arg* to_arg) { // Called for the side effect of generating an error if there is no // common type int _left; vec_type2(x, to, x_arg, to_arg, &_left); return vec_cast(x, to, x_arg, to_arg); } // [[ register() ]] SEXP vctrs_coercible_cast(SEXP x, SEXP to, SEXP x_arg_, SEXP to_arg_) { x_arg_ = arg_validate(x_arg_, "x_arg"); to_arg_ = arg_validate(to_arg_, "to_arg"); struct vctrs_arg x_arg = new_wrapper_arg(NULL, r_chr_get_c_string(x_arg_, 0)); struct vctrs_arg to_arg = new_wrapper_arg(NULL, r_chr_get_c_string(to_arg_, 0)); return vec_coercible_cast(x, to, &x_arg, &to_arg); } SEXP vctrs_type_common_impl(SEXP dots, SEXP ptype); // [[ include("vctrs.h") ]] SEXP vec_cast_common(SEXP xs, SEXP to) { SEXP type = PROTECT(vctrs_type_common_impl(xs, to)); R_len_t n = Rf_length(xs); SEXP out = PROTECT(Rf_allocVector(VECSXP, n)); for (R_len_t i = 0; i < n; ++i) { SEXP elt = VECTOR_ELT(xs, i); // TODO SET_VECTOR_ELT(out, i, vec_cast(elt, type, args_empty, args_empty)); } SEXP names = PROTECT(Rf_getAttrib(xs, R_NamesSymbol)); Rf_setAttrib(out, R_NamesSymbol, names); UNPROTECT(3); return out; } // [[ register(external = TRUE) ]] SEXP vctrs_cast_common(SEXP call, SEXP op, SEXP args, SEXP env) { args = CDR(args); SEXP dots = PROTECT(rlang_env_dots_list(env)); SEXP to = PROTECT(Rf_eval(CAR(args), env)); SEXP out = vec_cast_common(dots, to); UNPROTECT(2); return out; } void vctrs_init_cast(SEXP ns) { syms_vec_cast_dispatch = Rf_install("vec_cast_dispatch"); syms_df_lossy_cast = Rf_install("df_lossy_cast"); fns_vec_cast_dispatch = Rf_findVar(syms_vec_cast_dispatch, ns); fns_df_lossy_cast = Rf_findVar(syms_df_lossy_cast, ns); } vctrs/src/utils.h0000644000176200001440000002324613623045211013517 0ustar liggesusers#ifndef VCTRS_UTILS_H #define VCTRS_UTILS_H #include "arg-counter.h" #define SWAP(T, x, y) do { \ T tmp = x; \ x = y; \ y = tmp; \ } while (0) #define PROTECT_N(x, n) (++*n, PROTECT(x)) enum vctrs_class_type { vctrs_class_list, vctrs_class_list_of, vctrs_class_data_frame, vctrs_class_bare_data_frame, vctrs_class_bare_tibble, vctrs_class_bare_factor, vctrs_class_bare_ordered, vctrs_class_rcrd, vctrs_class_bare_date, vctrs_class_bare_posixct, vctrs_class_bare_posixlt, vctrs_class_posixlt, vctrs_class_unknown, vctrs_class_none }; bool r_is_bool(SEXP x); SEXP vctrs_eval_mask_n(SEXP fn, SEXP* syms, SEXP* args, SEXP env); SEXP vctrs_eval_mask1(SEXP fn, SEXP x_sym, SEXP x, SEXP env); SEXP vctrs_eval_mask2(SEXP fn, SEXP x_sym, SEXP x, SEXP y_sym, SEXP y, SEXP env); SEXP vctrs_eval_mask3(SEXP fn, SEXP x_sym, SEXP x, SEXP y_sym, SEXP y, SEXP z_sym, SEXP z, SEXP env); SEXP vctrs_eval_mask4(SEXP fn, SEXP x1_sym, SEXP x1, SEXP x2_sym, SEXP x2, SEXP x3_sym, SEXP x3, SEXP x4_sym, SEXP x4, SEXP env); SEXP vctrs_eval_mask5(SEXP fn, SEXP x1_sym, SEXP x1, SEXP x2_sym, SEXP x2, SEXP x3_sym, SEXP x3, SEXP x4_sym, SEXP x4, SEXP x5_sym, SEXP x5, SEXP env); SEXP vctrs_dispatch_n(SEXP fn_sym, SEXP fn, SEXP* syms, SEXP* args); SEXP vctrs_dispatch1(SEXP fn_sym, SEXP fn, SEXP x_sym, SEXP x); SEXP vctrs_dispatch2(SEXP fn_sym, SEXP fn, SEXP x_sym, SEXP x, SEXP y_sym, SEXP y); SEXP vctrs_dispatch3(SEXP fn_sym, SEXP fn, SEXP x_sym, SEXP x, SEXP y_sym, SEXP y, SEXP z_sym, SEXP z); SEXP vctrs_dispatch4(SEXP fn_sym, SEXP fn, SEXP w_sym, SEXP w, SEXP x_sym, SEXP x, SEXP y_sym, SEXP y, SEXP z_sym, SEXP z); SEXP map(SEXP x, SEXP (*fn)(SEXP)); SEXP map_with_data(SEXP x, SEXP (*fn)(SEXP, void*), void* data); SEXP df_map(SEXP df, SEXP (*fn)(SEXP)); SEXP bare_df_map(SEXP df, SEXP (*fn)(SEXP)); enum vctrs_class_type class_type(SEXP x); bool is_data_frame(SEXP x); bool is_bare_data_frame(SEXP x); bool is_bare_tibble(SEXP x); bool is_record(SEXP x); SEXP vec_unique_names(SEXP x, bool quiet); SEXP vec_unique_colnames(SEXP x, bool quiet); // Returns S3 method for `generic` suitable for the class of `x`. The // inheritance hierarchy is explored except for the default method. SEXP s3_find_method(const char* generic, SEXP x, SEXP table); bool vec_implements_ptype2(SEXP x); SEXP list_first_non_null(SEXP xs, R_len_t* non_null_i); bool list_is_s3_homogeneous(SEXP xs); // Destructive compacting SEXP node_compact_d(SEXP xs); extern struct vctrs_arg* args_empty; SEXP arg_validate(SEXP arg, const char* arg_nm); void never_reached(const char* fn) __attribute__((noreturn)); enum vctrs_type2 vec_typeof2_impl(enum vctrs_type type_x, enum vctrs_type type_y, int* left); enum vctrs_type2_s3 vec_typeof2_s3_impl(SEXP x, SEXP y, enum vctrs_type type_x, enum vctrs_type type_y, int* left); enum vctrs_class_type class_type(SEXP x); SEXP new_list_of(SEXP x, SEXP ptype); void init_list_of(SEXP x, SEXP ptype); SEXP new_empty_factor(SEXP levels); SEXP new_empty_ordered(SEXP levels); void init_compact_seq(int* p, R_len_t start, R_len_t size, bool increasing); SEXP compact_seq(R_len_t start, R_len_t size, bool increasing); bool is_compact_seq(SEXP x); void init_compact_rep(int* p, R_len_t i, R_len_t n); SEXP compact_rep(R_len_t i, R_len_t n); bool is_compact_rep(SEXP x); bool is_compact(SEXP x); SEXP compact_materialize(SEXP x); R_len_t vec_subscript_size(SEXP x); bool is_integer64(SEXP x); SEXP apply_name_spec(SEXP name_spec, SEXP outer, SEXP inner, R_len_t n); SEXP outer_names(SEXP names, SEXP outer, R_len_t n); SEXP vec_set_names(SEXP x, SEXP names); SEXP colnames(SEXP x); R_len_t size_validate(SEXP size, const char* arg); extern bool (*rlang_is_splice_box)(SEXP); extern SEXP (*rlang_unbox)(SEXP); extern SEXP (*rlang_env_dots_values)(SEXP); extern SEXP (*rlang_env_dots_list)(SEXP); void* r_vec_deref(SEXP x); const void* r_vec_const_deref(SEXP x); void r_vec_ptr_inc(SEXPTYPE type, void** p, R_len_t i); void r_vec_fill(SEXPTYPE type, void* p, const void* value_p, R_len_t value_i, R_len_t n); R_len_t r_lgl_sum(SEXP lgl, bool na_true); SEXP r_lgl_which(SEXP x, bool na_true); void r_lgl_fill(SEXP x, int value, R_len_t n); void r_int_fill(SEXP x, int value, R_len_t n); void r_chr_fill(SEXP x, SEXP value, R_len_t n); void r_int_fill_seq(SEXP x, int start, R_len_t n); SEXP r_seq(R_len_t from, R_len_t to); bool r_int_any_na(SEXP x); R_len_t r_chr_find(SEXP x, SEXP value); #define r_resize Rf_xlengthgets int r_chr_max_len(SEXP x); SEXP r_chr_iota(R_len_t n, char* buf, int len, const char* prefix); SEXP r_new_environment(SEXP parent, R_len_t size); SEXP r_new_function(SEXP formals, SEXP body, SEXP env); SEXP r_as_function(SEXP x, const char* arg); SEXP r_protect(SEXP x); bool r_is_true(SEXP x); bool r_is_string(SEXP x); bool r_is_number(SEXP x); SEXP r_peek_option(const char* option); SEXP r_maybe_duplicate(SEXP x); SEXP r_pairlist(SEXP* tags, SEXP* cars); SEXP r_call(SEXP fn, SEXP* tags, SEXP* cars); static inline SEXP r_names(SEXP x) { return Rf_getAttrib(x, R_NamesSymbol); } static inline SEXP r_poke_names(SEXP x, SEXP names) { return Rf_setAttrib(x, R_NamesSymbol, names); } static inline SEXP r_class(SEXP x) { return Rf_getAttrib(x, R_ClassSymbol); } static inline SEXP r_poke_class(SEXP x, SEXP names) { return Rf_setAttrib(x, R_ClassSymbol, names); } bool r_has_name_at(SEXP names, R_len_t i); bool r_is_names(SEXP names); bool r_is_minimal_names(SEXP x); bool r_is_empty_names(SEXP x); SEXP r_env_get(SEXP env, SEXP sym); bool r_is_function(SEXP x); bool r_chr_has_string(SEXP x, SEXP str); static inline const char* r_chr_get_c_string(SEXP chr, R_len_t i) { return CHAR(STRING_ELT(chr, i)); } static inline void r__vec_get_check(SEXP x, R_len_t i, const char* fn) { if ((Rf_length(x) - 1) < i) { Rf_error("Internal error in `%s()`: Vector is too small", fn); } } static inline int r_lgl_get(SEXP x, R_len_t i) { r__vec_get_check(x, i, "r_lgl_get"); return LOGICAL(x)[i]; } static inline int r_int_get(SEXP x, R_len_t i) { r__vec_get_check(x, i, "r_int_get"); return INTEGER(x)[i]; } static inline double r_dbl_get(SEXP x, R_len_t i) { r__vec_get_check(x, i, "r_dbl_get"); return REAL(x)[i]; } #define r_chr_get STRING_ELT static inline void* r_vec_unwrap(SEXPTYPE type, SEXP x) { switch (type) { case INTSXP: return (void*) INTEGER(x); default: Rf_error("Internal error: Unimplemented type in `r_vec_unwrap()`."); } } #define r_lgl Rf_ScalarLogical #define r_int Rf_ScalarInteger #define r_str Rf_mkChar #define r_sym Rf_install static inline SEXP r_list(SEXP x) { SEXP out = Rf_allocVector(VECSXP, 1); SET_VECTOR_ELT(out, 0, x); return out; } #define r_str_as_character Rf_ScalarString SEXP r_as_data_frame(SEXP x); static inline void r_dbg_save(SEXP x, const char* name) { Rf_defineVar(Rf_install(name), x, R_GlobalEnv); } extern SEXP vctrs_ns_env; extern SEXP vctrs_shared_empty_str; extern SEXP vctrs_shared_na_lgl; extern SEXP vctrs_shared_zero_int; extern SEXP classes_data_frame; extern SEXP classes_factor; extern SEXP classes_ordered; extern SEXP classes_date; extern SEXP classes_posixct; extern SEXP classes_tibble; extern SEXP classes_list_of; extern SEXP classes_vctrs_group_rle; extern SEXP strings_dots; extern SEXP strings_empty; extern SEXP strings_tbl; extern SEXP strings_tbl_df; extern SEXP strings_data_frame; extern SEXP strings_vctrs_rcrd; extern SEXP strings_date; extern SEXP strings_posixct; extern SEXP strings_posixlt; extern SEXP strings_posixt; extern SEXP strings_factor; extern SEXP strings_ordered; extern SEXP strings_vctrs_vctr; extern SEXP strings_vctrs_list_of; extern SEXP strings_list; extern SEXP strings_none; extern SEXP strings_minimal; extern SEXP strings_unique; extern SEXP strings_universal; extern SEXP strings_check_unique; extern SEXP strings_key; extern SEXP strings_loc; extern SEXP strings_val; extern SEXP strings_group; extern SEXP strings_length; extern SEXP chrs_subset; extern SEXP chrs_extract; extern SEXP chrs_assign; extern SEXP chrs_rename; extern SEXP chrs_remove; extern SEXP chrs_negate; extern SEXP chrs_numeric; extern SEXP chrs_character; extern SEXP chrs_empty; extern SEXP syms_i; extern SEXP syms_n; extern SEXP syms_x; extern SEXP syms_y; extern SEXP syms_to; extern SEXP syms_dots; extern SEXP syms_bracket; extern SEXP syms_arg; extern SEXP syms_x_arg; extern SEXP syms_y_arg; extern SEXP syms_to_arg; extern SEXP syms_subscript_arg; extern SEXP syms_out; extern SEXP syms_value; extern SEXP syms_quiet; extern SEXP syms_dot_name_spec; extern SEXP syms_outer; extern SEXP syms_inner; extern SEXP syms_tilde; extern SEXP syms_dot_environment; extern SEXP syms_ptype; extern SEXP syms_missing; extern SEXP syms_size; extern SEXP syms_subscript_action; extern SEXP syms_subscript_type; extern SEXP syms_repair; extern SEXP syms_tzone; #define syms_names R_NamesSymbol extern SEXP fns_bracket; extern SEXP fns_quote; extern SEXP fns_names; extern SEXP vctrs_method_table; extern SEXP base_method_table; #endif vctrs/src/names.c0000644000176200001440000005131213623035652013460 0ustar liggesusers#include #include "vctrs.h" #include "utils.h" #include static void describe_repair(SEXP old_names, SEXP new_names); // 3 leading '.' + 1 trailing '\0' + 24 characters #define MAX_IOTA_SIZE 28 // Initialised at load time SEXP syms_as_universal_names = NULL; SEXP syms_validate_unique_names = NULL; SEXP fns_as_universal_names = NULL; SEXP fns_validate_unique_names = NULL; // Defined below SEXP vctrs_as_minimal_names(SEXP names); SEXP vec_as_universal_names(SEXP names, bool quiet); SEXP vec_validate_unique_names(SEXP names); SEXP vec_as_custom_names(SEXP names, const struct name_repair_opts* opts); static void vec_validate_minimal_names(SEXP names, R_len_t n); // [[ include("names.h") ]] SEXP vec_as_names(SEXP names, const struct name_repair_opts* opts) { if (!opts) { return names; } switch (opts->type) { case name_repair_none: return names; case name_repair_minimal: return vctrs_as_minimal_names(names); case name_repair_unique: return vec_as_unique_names(names, opts->quiet); case name_repair_universal: return vec_as_universal_names(names, opts->quiet); case name_repair_check_unique: return vec_validate_unique_names(names); case name_repair_custom: return vec_as_custom_names(names, opts); } never_reached("vec_as_names"); } // [[ register() ]] SEXP vctrs_as_names(SEXP names, SEXP repair, SEXP quiet) { if (!r_is_bool(quiet)) { Rf_errorcall(R_NilValue, "`quiet` must a boolean value."); } struct name_repair_opts repair_opts = new_name_repair_opts(repair, quiet); PROTECT_NAME_REPAIR_OPTS(&repair_opts); SEXP out = vec_as_names(names, &repair_opts); UNPROTECT(1); return out; } SEXP vec_as_universal_names(SEXP names, bool quiet) { SEXP quiet_obj = PROTECT(r_lgl(quiet)); SEXP out = vctrs_dispatch2(syms_as_universal_names, fns_as_universal_names, syms_names, names, syms_quiet, quiet_obj); UNPROTECT(1); return out; } SEXP vec_validate_unique_names(SEXP names) { SEXP out = PROTECT(vctrs_dispatch1(syms_validate_unique_names, fns_validate_unique_names, syms_names, names)); // Restore visibility Rf_eval(R_NilValue, R_EmptyEnv); UNPROTECT(1); return out; } SEXP vec_as_custom_names(SEXP names, const struct name_repair_opts* opts) { names = PROTECT(vctrs_as_minimal_names(names)); // Don't use vctrs dispatch utils because we match argument positionally SEXP call = PROTECT(Rf_lang2(syms_repair, syms_names)); SEXP mask = PROTECT(r_new_environment(R_GlobalEnv, 2)); Rf_defineVar(syms_repair, opts->fn, mask); Rf_defineVar(syms_names, names, mask); SEXP out = PROTECT(Rf_eval(call, mask)); vec_validate_minimal_names(out, Rf_length(names)); if (!opts->quiet) { describe_repair(names, out); } UNPROTECT(4); return out; } // [[ register(); include("vctrs.h") ]] SEXP vec_names(SEXP x) { if (OBJECT(x) && Rf_inherits(x, "data.frame")) { return R_NilValue; } if (vec_dim_n(x) == 1) { if (OBJECT(x)) { return vctrs_dispatch1(syms_names, fns_names, syms_x, x); } else { return r_names(x); } } SEXP dimnames = PROTECT(Rf_getAttrib(x, R_DimNamesSymbol)); if (dimnames == R_NilValue || Rf_length(dimnames) < 1) { UNPROTECT(1); return R_NilValue; } SEXP out = VECTOR_ELT(dimnames, 0); UNPROTECT(1); return out; } // [[ register() ]] SEXP vctrs_as_minimal_names(SEXP names) { if (TYPEOF(names) != STRSXP) { Rf_errorcall(R_NilValue, "`names` must be a character vector"); } R_len_t i = 0; R_len_t n = Rf_length(names); const SEXP* ptr = STRING_PTR_RO(names); for (; i < n; ++i, ++ptr) { SEXP elt = *ptr; if (elt == NA_STRING) { break; } } if (i == n) { return names; } names = PROTECT(Rf_shallow_duplicate(names)); for (; i < n; ++i, ++ptr) { SEXP elt = *ptr; if (elt == NA_STRING) { SET_STRING_ELT(names, i, strings_empty); } } UNPROTECT(1); return names; } // [[ register() ]] SEXP vctrs_minimal_names(SEXP x) { SEXP names = PROTECT(vec_names(x)); if (names == R_NilValue) { names = Rf_allocVector(STRSXP, vec_size(x)); } else { names = vctrs_as_minimal_names(names); } UNPROTECT(1); return names; } // From dictionary.c SEXP vctrs_duplicated(SEXP x); static bool any_has_suffix(SEXP names); static SEXP as_unique_names_impl(SEXP names, bool quiet); static void stop_large_name(); static bool is_dotdotint(const char* name); static ptrdiff_t suffix_pos(const char* name); static bool needs_suffix(SEXP str); // [[ include("vctrs.h") ]] SEXP vec_as_unique_names(SEXP names, bool quiet) { if (is_unique_names(names) && !any_has_suffix(names)) { return names; } else { return(as_unique_names_impl(names, quiet)); } } // [[ include("vctrs.h") ]] bool is_unique_names(SEXP names) { if (TYPEOF(names) != STRSXP) { Rf_errorcall(R_NilValue, "`names` must be a character vector"); } R_len_t n = Rf_length(names); const SEXP* names_ptr = STRING_PTR_RO(names); if (duplicated_any(names)) { return false; } for (R_len_t i = 0; i < n; ++i) { SEXP elt = names_ptr[i]; if (needs_suffix(elt)) { return false; } } return true; } bool any_has_suffix(SEXP names) { R_len_t n = Rf_length(names); const SEXP* names_ptr = STRING_PTR_RO(names); for (R_len_t i = 0; i < n; ++i) { SEXP elt = names_ptr[i]; if (suffix_pos(CHAR(elt)) >= 0) { return true; } } return false; } SEXP as_unique_names_impl(SEXP names, bool quiet) { R_len_t n = Rf_length(names); SEXP new_names = PROTECT(Rf_shallow_duplicate(names)); const SEXP* new_names_ptr = STRING_PTR_RO(new_names); for (R_len_t i = 0; i < n; ++i) { SEXP elt = new_names_ptr[i]; // Set `NA` and dots values to "" so they get replaced by `...n` // later on if (needs_suffix(elt)) { elt = strings_empty; SET_STRING_ELT(new_names, i, elt); continue; } // Strip `...n` suffixes const char* nm = CHAR(elt); int pos = suffix_pos(nm); if (pos >= 0) { elt = Rf_mkCharLenCE(nm, pos, Rf_getCharCE(elt)); SET_STRING_ELT(new_names, i, elt); continue; } } // Append all duplicates with a suffix SEXP dups = PROTECT(vctrs_duplicated(new_names)); const int* dups_ptr = LOGICAL_RO(dups); for (R_len_t i = 0; i < n; ++i) { SEXP elt = new_names_ptr[i]; if (elt != strings_empty && !dups_ptr[i]) { continue; } const char* name = CHAR(elt); int size = strlen(name); int buf_size = size + MAX_IOTA_SIZE; R_CheckStack2(buf_size); char buf[buf_size]; buf[0] = '\0'; memcpy(buf, name, size); int remaining = buf_size - size; int needed = snprintf(buf + size, remaining, "...%d", i + 1); if (needed >= remaining) { stop_large_name(); } SET_STRING_ELT(new_names, i, Rf_mkCharLenCE(buf, size + needed, Rf_getCharCE(elt))); } if (!quiet) { describe_repair(names, new_names); } UNPROTECT(2); return new_names; } SEXP vctrs_as_unique_names(SEXP names, SEXP quiet) { SEXP out = PROTECT(vec_as_unique_names(names, LOGICAL(quiet)[0])); UNPROTECT(1); return out; } SEXP vctrs_is_unique_names(SEXP names) { bool out = is_unique_names(names); return Rf_ScalarLogical(out); } static bool is_dotdotint(const char* name) { int n = strlen(name); if (n < 3) { return false; } if (name[0] != '.' || name[1] != '.') { return false; } if (name[2] == '.') { name += 3; } else { name += 2; } return (bool) strtol(name, NULL, 10); } static ptrdiff_t suffix_pos(const char* name) { int n = strlen(name); const char* suffix_end = NULL; int in_dots = 0; bool in_digits = false; for (const char* ptr = name + n - 1; ptr >= name; --ptr) { char c = *ptr; if (in_digits) { if (c == '.') { in_digits = false; in_dots = 1; continue; } if (isdigit(c)) { continue; } goto done; } switch (in_dots) { case 0: if (isdigit(c)) { in_digits = true; continue; } goto done; case 1: case 2: if (c == '.') { ++in_dots; continue; } goto done; case 3: suffix_end = ptr + 1; if (isdigit(c)) { in_dots = 0; in_digits = true; continue; } goto done; default: Rf_error("Internal error: Unexpected state in `suffix_pos()`"); }} done: if (suffix_end) { return suffix_end - name; } else { return -1; } } static void stop_large_name() { Rf_errorcall(R_NilValue, "Can't tidy up name because it is too large"); } static bool needs_suffix(SEXP str) { return str == NA_STRING || str == strings_dots || str == strings_empty || is_dotdotint(CHAR(str)); } static SEXP names_iota(R_len_t n); static SEXP vec_unique_names_impl(SEXP names, R_len_t n, bool quiet); // [[ register() ]] SEXP vctrs_unique_names(SEXP x, SEXP quiet) { return vec_unique_names(x, LOGICAL(quiet)[0]); } // [[ include("utils.h") ]] SEXP vec_unique_names(SEXP x, bool quiet) { SEXP names = PROTECT(vec_names(x)); SEXP out = vec_unique_names_impl(names, vec_size(x), quiet); UNPROTECT(1); return out; } // [[ include("utils.h") ]] SEXP vec_unique_colnames(SEXP x, bool quiet) { SEXP names = PROTECT(colnames(x)); SEXP out = vec_unique_names_impl(names, Rf_ncols(x), quiet); UNPROTECT(1); return out; } static SEXP vec_unique_names_impl(SEXP names, R_len_t n, bool quiet) { SEXP out; if (names == R_NilValue) { out = PROTECT(names_iota(n)); if (!quiet) { describe_repair(names, out); } } else { out = PROTECT(vec_as_unique_names(names, quiet)); } UNPROTECT(1); return(out); } static SEXP names_iota(R_len_t n) { char buf[MAX_IOTA_SIZE]; SEXP nms = r_chr_iota(n, buf, MAX_IOTA_SIZE, "..."); if (nms == R_NilValue) { Rf_errorcall(R_NilValue, "Too many names to repair."); } return nms; } static void describe_repair(SEXP old_names, SEXP new_names) { SEXP call = PROTECT(Rf_lang3(Rf_install("describe_repair"), old_names, new_names)); Rf_eval(call, vctrs_ns_env); // To reset visibility when called from a `.External2()` Rf_eval(R_NilValue, R_EmptyEnv); UNPROTECT(1); } // [[ register() ]] SEXP vctrs_outer_names(SEXP names, SEXP outer, SEXP n) { if (names != R_NilValue && TYPEOF(names) != STRSXP) { Rf_error("Internal error: `names` must be `NULL` or a string"); } if (!r_is_number(n)) { Rf_error("Internal error: `n` must be a single integer"); } if (outer != R_NilValue) { outer = r_chr_get(outer, 0); } return outer_names(names, outer, r_int_get(n, 0)); } // [[ include("utils.h") ]] SEXP outer_names(SEXP names, SEXP outer, R_len_t n) { if (outer == R_NilValue) { return names; } if (TYPEOF(outer) != CHARSXP) { Rf_error("Internal error: `outer` must be a scalar string."); } if (outer == strings_empty || outer == NA_STRING) { return names; } if (r_is_empty_names(names)) { if (n == 1) { return r_str_as_character(outer); } else { return r_seq_chr(CHAR(outer), n); } } else { return r_chr_paste_prefix(names, CHAR(outer), ".."); } } // [[ register() ]] SEXP vctrs_apply_name_spec(SEXP name_spec, SEXP outer, SEXP inner, SEXP n) { return apply_name_spec(name_spec, r_chr_get(outer, 0), inner, r_int_get(n, 0)); } static SEXP glue_as_name_spec(SEXP spec); // [[ include("utils.h") ]] SEXP apply_name_spec(SEXP name_spec, SEXP outer, SEXP inner, R_len_t n) { if (outer == R_NilValue) { return inner; } if (TYPEOF(outer) != CHARSXP) { Rf_error("Internal error: `outer` must be a scalar string."); } if (outer == strings_empty || outer == NA_STRING) { return inner; } if (r_is_empty_names(inner)) { if (n == 1) { return r_str_as_character(outer); } inner = PROTECT(r_seq(1, n + 1)); } else { inner = PROTECT(inner); } switch (TYPEOF(name_spec)) { case CLOSXP: break; case STRSXP: name_spec = glue_as_name_spec(name_spec); break; default: name_spec = r_as_function(name_spec, ".name_spec"); break; case NILSXP: Rf_errorcall(R_NilValue, "Can't merge the outer name `%s` with a vector of length > 1.\n" "Please supply a `.name_spec` specification.", CHAR(outer)); } PROTECT(name_spec); // Recycle `outer` so specs don't need to refer to both `outer` and `inner` SEXP outer_chr = PROTECT(Rf_allocVector(STRSXP, n)); r_chr_fill(outer_chr, outer, n); SEXP out = vctrs_dispatch2(syms_dot_name_spec, name_spec, syms_outer, outer_chr, syms_inner, inner); if (TYPEOF(out) != STRSXP) { Rf_errorcall(R_NilValue, "`.name_spec` must return a character vector."); } if (Rf_length(out) != n) { Rf_errorcall(R_NilValue, "`.name_spec` must return a character vector as long as `inner`."); } UNPROTECT(3); return out; } static SEXP syms_glue_as_name_spec = NULL; static SEXP fns_glue_as_name_spec = NULL; static SEXP syms_internal_spec = NULL; static SEXP glue_as_name_spec(SEXP spec) { if (!r_is_string(spec)) { Rf_errorcall(R_NilValue, "Glue specification in `.name_spec` must be a single string."); } return vctrs_dispatch1(syms_glue_as_name_spec, fns_glue_as_name_spec, syms_internal_spec, spec); } // [[ include("names.h") ]] SEXP r_chr_paste_prefix(SEXP names, const char* prefix, const char* sep) { names = PROTECT(Rf_shallow_duplicate(names)); R_len_t n = Rf_length(names); int outer_len = strlen(prefix); int names_len = r_chr_max_len(names); int sep_len = strlen(sep); int total_len = outer_len + names_len + sep_len + 1; R_CheckStack2(total_len); char buf[total_len]; buf[total_len - 1] = '\0'; char* bufp = buf; memcpy(bufp, prefix, outer_len); bufp += outer_len; for (int i = 0; i < sep_len; ++i) { *bufp++ = sep[i]; } SEXP* p = STRING_PTR(names); for (R_len_t i = 0; i < n; ++i, ++p) { const char* inner = CHAR(*p); int inner_n = strlen(inner); memcpy(bufp, inner, inner_n); bufp[inner_n] = '\0'; SET_STRING_ELT(names, i, r_str(buf)); } UNPROTECT(1); return names; } // [[ include("names.h") ]] SEXP r_seq_chr(const char* prefix, R_len_t n) { int total_len = 24 + strlen(prefix) + 1; R_CheckStack2(total_len); char buf[total_len]; return r_chr_iota(n, buf, total_len, prefix); } // Initialised at load time SEXP syms_set_rownames_fallback = NULL; SEXP fns_set_rownames_fallback = NULL; static SEXP set_rownames_fallback(SEXP x, SEXP names) { return vctrs_dispatch2(syms_set_rownames_fallback, fns_set_rownames_fallback, syms_x, x, syms_names, names); } // Initialised at load time SEXP syms_set_names_fallback = NULL; SEXP fns_set_names_fallback = NULL; static SEXP set_names_fallback(SEXP x, SEXP names) { return vctrs_dispatch2(syms_set_names_fallback, fns_set_names_fallback, syms_x, x, syms_names, names); } static void check_names(SEXP x, SEXP names) { if (names == R_NilValue) { return; } if (TYPEOF(names) != STRSXP) { Rf_errorcall( R_NilValue, "`names` must be a character vector, not a %s.", Rf_type2char(TYPEOF(names)) ); } R_len_t x_size = vec_size(x); R_len_t names_size = vec_size(names); if (x_size != names_size) { Rf_errorcall( R_NilValue, "The size of `names`, %i, must be the same as the size of `x`, %i.", names_size, x_size ); } } SEXP vec_set_rownames(SEXP x, SEXP names) { if (OBJECT(x)) { return set_rownames_fallback(x, names); } int nprot = 0; SEXP dim_names = Rf_getAttrib(x, R_DimNamesSymbol); // Early exit when no new row names and no existing row names if (names == R_NilValue) { if (dim_names == R_NilValue || VECTOR_ELT(dim_names, 0) == R_NilValue) { return x; } } x = PROTECT_N(r_maybe_duplicate(x), &nprot); if (dim_names == R_NilValue) { dim_names = PROTECT_N(Rf_allocVector(VECSXP, vec_dim_n(x)), &nprot); } SET_VECTOR_ELT(dim_names, 0, names); Rf_setAttrib(x, R_DimNamesSymbol, dim_names); UNPROTECT(nprot); return x; } // FIXME: Do we need to get the vec_proxy() and only fall back if it doesn't // exist? See #526 and #531 for discussion and the related issue. // [[ include("utils.h"); register() ]] SEXP vec_set_names(SEXP x, SEXP names) { // Never on a data frame if (is_data_frame(x)) { return x; } check_names(x, names); if (has_dim(x)) { return vec_set_rownames(x, names); } if (OBJECT(x)) { return set_names_fallback(x, names); } // Early exit if no new names and no existing names if (names == R_NilValue && Rf_getAttrib(x, R_NamesSymbol) == R_NilValue) { return x; } x = PROTECT(r_maybe_duplicate(x)); Rf_setAttrib(x, R_NamesSymbol, names); UNPROTECT(1); return x; } SEXP vctrs_validate_name_repair_arg(SEXP arg) { struct name_repair_opts opts = new_name_repair_opts(arg, true); if (opts.type == name_repair_custom) { return opts.fn; } else if (Rf_length(arg) != 1) { return r_str_as_character(r_str(name_repair_arg_as_c_string(opts.type))); } else { return arg; } } void stop_name_repair() { Rf_errorcall(R_NilValue, "`.name_repair` must be a string or a function. See `?vctrs::vec_as_names`."); } struct name_repair_opts new_name_repair_opts(SEXP name_repair, bool quiet) { struct name_repair_opts opts = { .type = 0, .fn = R_NilValue, .quiet = quiet }; switch (TYPEOF(name_repair)) { case STRSXP: { if (!Rf_length(name_repair)) { stop_name_repair(); } SEXP c = r_chr_get(name_repair, 0); if (c == strings_none) { opts.type = name_repair_none; } else if (c == strings_minimal) { opts.type = name_repair_minimal; } else if (c == strings_unique) { opts.type = name_repair_unique; } else if (c == strings_universal) { opts.type = name_repair_universal; } else if (c == strings_check_unique) { opts.type = name_repair_check_unique; } else { Rf_errorcall(R_NilValue, "`.name_repair` can't be \"%s\". See `?vctrs::vec_as_names`.", CHAR(name_repair)); } return opts; } case LANGSXP: opts.fn = r_as_function(name_repair, ".name_repair"); opts.type = name_repair_custom; return opts; case CLOSXP: opts.fn = name_repair; opts.type = name_repair_custom; return opts; default: stop_name_repair(); } never_reached("new_name_repair_opts"); } // [[ include("vctrs.h") ]] const char* name_repair_arg_as_c_string(enum name_repair_type type) { switch (type) { case name_repair_none: return "none"; case name_repair_minimal: return "minimal"; case name_repair_unique: return "unique"; case name_repair_universal: return "universal"; case name_repair_check_unique: return "check_unique"; case name_repair_custom: return "custom"; } never_reached("name_repair_arg_as_c_string"); } static void vec_validate_minimal_names(SEXP names, R_len_t n) { if (names == R_NilValue) { Rf_errorcall(R_NilValue, "Names repair functions can't return `NULL`."); } if (TYPEOF(names) != STRSXP) { Rf_errorcall(R_NilValue, "Names repair functions must return a character vector."); } if (n >= 0 && Rf_length(names) != n) { Rf_errorcall(R_NilValue, "Repaired names have length %d instead of length %d.", Rf_length(names), n); } if (r_chr_has_string(names, NA_STRING)) { Rf_errorcall(R_NilValue, "Names repair functions can't return `NA` values."); } } SEXP vctrs_validate_minimal_names(SEXP names, SEXP n_) { R_len_t n = -1; if (TYPEOF(n_) == INTSXP) { if (Rf_length(n_) != 1) { Rf_error("Internal error (minimal names validation): `n` must be a single number."); } n = INTEGER(n_)[0]; } vec_validate_minimal_names(names, n); return names; } struct name_repair_opts default_unique_repair_opts_obj; void vctrs_init_names(SEXP ns) { syms_set_rownames_fallback = Rf_install("set_rownames_fallback"); syms_set_names_fallback = Rf_install("set_names_fallback"); syms_as_universal_names = Rf_install("as_universal_names"); syms_validate_unique_names = Rf_install("validate_unique"); fns_set_rownames_fallback = r_env_get(ns, syms_set_rownames_fallback); fns_set_names_fallback = r_env_get(ns, syms_set_names_fallback); fns_as_universal_names = r_env_get(ns, syms_as_universal_names); fns_validate_unique_names = r_env_get(ns, syms_validate_unique_names); syms_glue_as_name_spec = Rf_install("glue_as_name_spec"); fns_glue_as_name_spec = r_env_get(ns, syms_glue_as_name_spec); syms_internal_spec = Rf_install("_spec"); default_unique_repair_opts_obj.type = name_repair_unique; default_unique_repair_opts_obj.fn = R_NilValue; default_unique_repair_opts_obj.quiet = false; } vctrs/src/group.c0000644000176200001440000001307613622451540013513 0ustar liggesusers#include "vctrs.h" #include "dictionary.h" #include "type-data-frame.h" #include "utils.h" // [[ register() ]] SEXP vctrs_group_id(SEXP x) { int nprot = 0; R_len_t n = vec_size(x); x = PROTECT_N(vec_proxy_equal(x), &nprot); x = PROTECT_N(obj_maybe_translate_encoding(x, n), &nprot); dictionary d; dict_init(&d, x); PROTECT_DICT(&d, &nprot); SEXP out = PROTECT_N(Rf_allocVector(INTSXP, n), &nprot); int* p_out = INTEGER(out); R_len_t g = 1; for (int i = 0; i < n; ++i) { int32_t hash = dict_hash_scalar(&d, i); R_len_t key = d.key[hash]; if (key == DICT_EMPTY) { dict_put(&d, hash, i); p_out[i] = g; ++g; } else { p_out[i] = p_out[key]; } } SEXP n_groups = PROTECT_N(Rf_ScalarInteger(d.used), &nprot); Rf_setAttrib(out, syms_n, n_groups); UNPROTECT(nprot); return out; } // ----------------------------------------------------------------------------- static SEXP new_group_rle(SEXP g, SEXP l, R_len_t n); // [[ register() ]] SEXP vctrs_group_rle(SEXP x) { int nprot = 0; R_len_t n = vec_size(x); x = PROTECT_N(vec_proxy_equal(x), &nprot); x = PROTECT_N(obj_maybe_translate_encoding(x, n), &nprot); dictionary d; dict_init(&d, x); PROTECT_DICT(&d, &nprot); SEXP g = PROTECT_N(Rf_allocVector(INTSXP, n), &nprot); int* p_g = INTEGER(g); SEXP l = PROTECT_N(Rf_allocVector(INTSXP, n), &nprot); int* p_l = INTEGER(l); if (n == 0) { SEXP out = PROTECT_N(new_group_rle(g, l, 0), &nprot); UNPROTECT(nprot); return out; } // Integer vector that maps `hash` values to locations in `g` SEXP map = PROTECT_N(Rf_allocVector(INTSXP, d.size), &nprot); int* p_map = INTEGER(map); // Initialize first value int32_t hash = dict_hash_scalar(&d, 0); dict_put(&d, hash, 0); p_map[hash] = 0; *p_g = 1; *p_l = 1; int loc = 1; for (int i = 1; i < n; ++i) { if (equal_scalar(x, i - 1, x, i, true)) { ++(*p_l); continue; } ++p_l; *p_l = 1; // Check if we have seen this value before int32_t hash = dict_hash_scalar(&d, i); if (d.key[hash] == DICT_EMPTY) { dict_put(&d, hash, i); p_map[hash] = loc; p_g[loc] = d.used; } else { p_g[loc] = p_g[p_map[hash]]; } ++loc; } g = PROTECT_N(Rf_lengthgets(g, loc), &nprot); l = PROTECT_N(Rf_lengthgets(l, loc), &nprot); SEXP out = new_group_rle(g, l, d.used); UNPROTECT(nprot); return out; } static SEXP new_group_rle(SEXP g, SEXP l, R_len_t n) { SEXP out = PROTECT(Rf_allocVector(VECSXP, 2)); SET_VECTOR_ELT(out, 0, g); SET_VECTOR_ELT(out, 1, l); SEXP names = PROTECT(Rf_allocVector(STRSXP, 2)); SET_STRING_ELT(names, 0, strings_group); SET_STRING_ELT(names, 1, strings_length); Rf_setAttrib(out, R_NamesSymbol, names); SEXP n_groups = PROTECT(Rf_ScalarInteger(n)); Rf_setAttrib(out, syms_n, n_groups); Rf_setAttrib(out, R_ClassSymbol, classes_vctrs_group_rle); UNPROTECT(3); return out; } // ----------------------------------------------------------------------------- // [[ include("vctrs.h"); register() ]] SEXP vec_group_loc(SEXP x) { int nprot = 0; R_len_t n = vec_size(x); SEXP proxy = PROTECT_N(vec_proxy_equal(x), &nprot); proxy = PROTECT_N(obj_maybe_translate_encoding(proxy, n), &nprot); dictionary d; dict_init(&d, proxy); PROTECT_DICT(&d, &nprot); SEXP groups = PROTECT_N(Rf_allocVector(INTSXP, n), &nprot); int* p_groups = INTEGER(groups); R_len_t g = 0; // Identify groups, this is essentially `vec_group_id()` for (int i = 0; i < n; ++i) { int32_t hash = dict_hash_scalar(&d, i); R_len_t key = d.key[hash]; if (key == DICT_EMPTY) { dict_put(&d, hash, i); p_groups[i] = g; ++g; } else { p_groups[i] = p_groups[key]; } } int n_groups = d.used; // Location of first occurence of each group in `x` SEXP key_loc = PROTECT_N(Rf_allocVector(INTSXP, n_groups), &nprot); int* p_key_loc = INTEGER(key_loc); int key_loc_current = 0; // Count of the number of elements in each group SEXP counts = PROTECT_N(Rf_allocVector(INTSXP, n_groups), &nprot); int* p_counts = INTEGER(counts); memset(p_counts, 0, n_groups * sizeof(int)); for (int i = 0; i < n; ++i) { int group = p_groups[i]; if (group == key_loc_current) { p_key_loc[key_loc_current] = i + 1; key_loc_current++; } p_counts[group]++; } SEXP out_loc = PROTECT_N(Rf_allocVector(VECSXP, n_groups), &nprot); // Initialize `out_loc` to a list of integers with sizes corresponding // to the number of elements in that group for (int i = 0; i < n_groups; ++i) { SET_VECTOR_ELT(out_loc, i, Rf_allocVector(INTSXP, p_counts[i])); } // The current location we are updating, each group has its own counter SEXP locations = PROTECT_N(Rf_allocVector(INTSXP, n_groups), &nprot); int* p_locations = INTEGER(locations); memset(p_locations, 0, n_groups * sizeof(int)); // Fill in the location values for each group for (int i = 0; i < n; ++i) { int group = p_groups[i]; int location = p_locations[group]; INTEGER(VECTOR_ELT(out_loc, group))[location] = i + 1; p_locations[group]++; } SEXP out_key = PROTECT_N(vec_slice(x, key_loc), &nprot); // Construct output data frame SEXP out = PROTECT_N(Rf_allocVector(VECSXP, 2), &nprot); SET_VECTOR_ELT(out, 0, out_key); SET_VECTOR_ELT(out, 1, out_loc); SEXP names = PROTECT_N(Rf_allocVector(STRSXP, 2), &nprot); SET_STRING_ELT(names, 0, strings_key); SET_STRING_ELT(names, 1, strings_loc); Rf_setAttrib(out, R_NamesSymbol, names); out = new_data_frame(out, n_groups); UNPROTECT(nprot); return out; } vctrs/src/conditions.c0000644000176200001440000000475613622451540014535 0ustar liggesusers#include "vctrs.h" #include "utils.h" void stop_scalar_type(SEXP x, struct vctrs_arg* arg) { SEXP call = PROTECT(Rf_lang3(Rf_install("stop_scalar_type"), PROTECT(r_protect(x)), PROTECT(vctrs_arg(arg)))); Rf_eval(call, vctrs_ns_env); Rf_error("Internal error: `stop_scalar_type()` should have jumped earlier"); } void vec_assert(SEXP x, struct vctrs_arg* arg) { if (!vec_is_vector(x)) { stop_scalar_type(x, arg); } } void stop_incompatible_size(SEXP x, SEXP y, R_len_t x_size, R_len_t y_size, struct vctrs_arg* x_arg, struct vctrs_arg* y_arg) { SEXP syms[7] = { syms_x, syms_y, r_sym("x_size"), r_sym("y_size"), syms_x_arg, syms_y_arg, NULL }; SEXP args[7] = { PROTECT(r_protect(x)), PROTECT(r_protect(y)), PROTECT(r_int(x_size)), PROTECT(r_int(y_size)), PROTECT(vctrs_arg(x_arg)), PROTECT(vctrs_arg(y_arg)), NULL }; SEXP call = PROTECT(r_call(r_sym("stop_incompatible_size"), syms, args)); Rf_eval(call, vctrs_ns_env); Rf_error("Internal error: `stop_incompatible_size()` should have jumped earlier"); } void stop_recycle_incompatible_size(R_len_t x_size, R_len_t size, struct vctrs_arg* x_arg) { SEXP syms[4] = { r_sym("x_size"), r_sym("size"), r_sym("x_arg"), NULL }; SEXP args[4] = { PROTECT(r_int(x_size)), PROTECT(r_int(size)), PROTECT(vctrs_arg(x_arg)), NULL }; SEXP call = PROTECT(r_call(r_sym("stop_recycle_incompatible_size"), syms, args)); Rf_eval(call, vctrs_ns_env); Rf_error("Internal error: `stop_recycle_incompatible_size()` should have jumped earlier"); } void stop_corrupt_factor_levels(SEXP x, struct vctrs_arg* arg) { SEXP call = PROTECT(Rf_lang3(Rf_install("stop_corrupt_factor_levels"), PROTECT(r_protect(x)), PROTECT(vctrs_arg(arg)))); Rf_eval(call, vctrs_ns_env); Rf_error("Internal error: `stop_corrupt_factor_levels()` should have jumped earlier"); } void stop_corrupt_ordered_levels(SEXP x, struct vctrs_arg* arg) { SEXP call = PROTECT(Rf_lang3(Rf_install("stop_corrupt_ordered_levels"), PROTECT(r_protect(x)), PROTECT(vctrs_arg(arg)))); Rf_eval(call, vctrs_ns_env); Rf_error("Internal error: `stop_corrupt_ordered_levels()` should have jumped earlier"); } vctrs/src/names.h0000644000176200001440000000170613623203263013462 0ustar liggesusers#ifndef VCTRS_NAMES_H #define VCTRS_NAMES_H enum name_repair_type { name_repair_none = 0, name_repair_minimal, name_repair_unique, name_repair_universal, name_repair_check_unique, name_repair_custom = 99 }; struct name_repair_opts { enum name_repair_type type; SEXP fn; bool quiet; }; extern struct name_repair_opts default_unique_repair_opts_obj; static const struct name_repair_opts* const default_unique_repair_opts = &default_unique_repair_opts_obj; #define PROTECT_NAME_REPAIR_OPTS(opts) PROTECT((opts)->fn) SEXP vec_as_names(SEXP names, const struct name_repair_opts* opts); struct name_repair_opts new_name_repair_opts(SEXP name_repair, bool quiet); const char* name_repair_arg_as_c_string(enum name_repair_type type); bool is_unique_names(SEXP names); SEXP vec_as_unique_names(SEXP names, bool quiet); SEXP r_seq_chr(const char* prefix, R_len_t n); SEXP r_chr_paste_prefix(SEXP names, const char* prefix, const char* sep); #endif vctrs/src/size.c0000644000176200001440000001052113623203263013317 0ustar liggesusers#include "vctrs.h" #include "type-data-frame.h" #include "utils.h" R_len_t rcrd_size(SEXP x); // From slice.c SEXP vec_slice_impl(SEXP x, SEXP index); // [[ register(); include("vctrs.h") ]] SEXP vec_dim(SEXP x) { SEXP dim = PROTECT(vec_bare_dim(x)); if (dim == R_NilValue) { dim = r_int(Rf_length(x)); } UNPROTECT(1); return dim; } // [[ include("vctrs.h") ]] R_len_t vec_dim_n(SEXP x) { return Rf_length(vec_dim(x)); } // [[ register() ]] SEXP vctrs_dim_n(SEXP x) { return r_int(vec_dim_n(x)); } // These versions return NULL and 0 for bare vectors. This is useful // to distinguish them from 1D arrays. // [[ include("vctrs.h") ]] SEXP vec_bare_dim(SEXP x) { return Rf_getAttrib(x, R_DimSymbol); } // [[ include("vctrs.h") ]] R_len_t vec_bare_dim_n(SEXP x) { return Rf_length(vec_bare_dim(x)); } // [[ include("vctrs.h") ]] R_len_t vec_size(SEXP x) { int nprot = 0; struct vctrs_proxy_info info = vec_proxy_info(x); PROTECT_PROXY_INFO(&info, &nprot); SEXP data = info.proxy; R_len_t size; switch (info.type) { case vctrs_type_null: size = 0; break; case vctrs_type_logical: case vctrs_type_integer: case vctrs_type_double: case vctrs_type_complex: case vctrs_type_character: case vctrs_type_raw: case vctrs_type_list: { SEXP dims = Rf_getAttrib(data, R_DimSymbol); if (dims == R_NilValue || Rf_length(dims) == 0) { size = Rf_length(data); break; } if (TYPEOF(dims) != INTSXP) { Rf_errorcall(R_NilValue, "Corrupt vector: dims is not integer vector"); } size = INTEGER(dims)[0]; break; } case vctrs_type_dataframe: size = df_size(data); break; default: { struct vctrs_arg arg = new_wrapper_arg(NULL, "x"); stop_scalar_type(x, &arg); }} UNPROTECT(nprot); return size; } // [[ register() ]] SEXP vctrs_size(SEXP x) { return Rf_ScalarInteger(vec_size(x)); } R_len_t df_rownames_size(SEXP x) { for (SEXP attr = ATTRIB(x); attr != R_NilValue; attr = CDR(attr)) { if (TAG(attr) != R_RowNamesSymbol) { continue; } SEXP rn = CAR(attr); R_len_t n = Rf_length(rn); switch (rownames_type(rn)) { case ROWNAMES_IDENTIFIERS: case ROWNAMES_AUTOMATIC: return n; case ROWNAMES_AUTOMATIC_COMPACT: return compact_rownames_length(rn); } } return -1; } // For performance, avoid Rf_getAttrib() because it automatically transforms // the rownames into an integer vector R_len_t df_size(SEXP x) { R_len_t n = df_rownames_size(x); if (n < 0) { Rf_errorcall(R_NilValue, "Corrupt data frame: row.names are missing"); } return n; } // Supports bare lists as well R_len_t df_raw_size(SEXP x) { R_len_t n = df_rownames_size(x); if (n >= 0) { return n; } return df_raw_size_from_list(x); } // [[ include("vctrs.h") ]] R_len_t df_raw_size_from_list(SEXP x) { if (Rf_length(x) >= 1) { return vec_size(VECTOR_ELT(x, 0)); } else { return 0; } } // [[ register() ]] SEXP vctrs_df_size(SEXP x) { return r_int(df_raw_size(x)); } R_len_t rcrd_size(SEXP x) { int n = Rf_length(x); if (n == 0) { return 0; } else { return Rf_length(VECTOR_ELT(x, 0)); } } bool has_dim(SEXP x) { return ATTRIB(x) != R_NilValue && Rf_getAttrib(x, R_DimSymbol) != R_NilValue; } // [[ include("vctrs.h") ]] SEXP vec_recycle(SEXP x, R_len_t size, struct vctrs_arg* x_arg) { if (x == R_NilValue) { return R_NilValue; } R_len_t n_x = vec_size(x); if (n_x == size) { return x; } if (n_x == 1L) { SEXP i = PROTECT(compact_rep(1, size)); SEXP out = vec_slice_impl(x, i); UNPROTECT(1); return out; } stop_recycle_incompatible_size(n_x, size, x_arg); } // [[ register() ]] SEXP vctrs_recycle(SEXP x, SEXP size_obj, SEXP x_arg) { if (x == R_NilValue || size_obj == R_NilValue) { return R_NilValue; } size_obj = PROTECT(vec_cast(size_obj, vctrs_shared_empty_int, args_empty, args_empty)); R_len_t size = r_int_get(size_obj, 0); UNPROTECT(1); struct vctrs_arg x_arg_ = new_wrapper_arg(NULL, r_chr_get_c_string(x_arg, 0)); return vec_recycle(x, size, &x_arg_); } // [[ include("utils.h") ]] R_len_t size_validate(SEXP size, const char* arg) { size = vec_cast(size, vctrs_shared_empty_int, args_empty, args_empty); if (Rf_length(size) != 1) { Rf_errorcall(R_NilValue, "`%s` must be a single integer.", arg); } return r_int_get(size, 0); } vctrs/src/utils-dispatch.c0000644000176200001440000000677513623045211015317 0ustar liggesusers#include "vctrs.h" #include "utils.h" // Defined below enum vctrs_class_type class_type(SEXP x); static enum vctrs_class_type class_type_impl(SEXP class); static const char* class_type_as_str(enum vctrs_class_type type); // [[ register() ]] SEXP vctrs_class_type(SEXP x) { return Rf_mkString(class_type_as_str(class_type(x))); } // [[ include("utils.h") ]] bool is_record(SEXP x) { enum vctrs_class_type type = class_type(x); return type == vctrs_class_rcrd || type == vctrs_class_posixlt || type == vctrs_class_bare_posixlt; } // [[ include("utils.h") ]] enum vctrs_class_type class_type(SEXP x) { if (!OBJECT(x)) { return vctrs_class_none; } SEXP class = PROTECT(Rf_getAttrib(x, R_ClassSymbol)); enum vctrs_class_type type = class_type_impl(class); UNPROTECT(1); return type; } static enum vctrs_class_type class_type_impl(SEXP class) { int n = Rf_length(class); SEXP const* p = STRING_PTR(class); // First check for bare types for which we know how many strings are // the classes composed of switch (n) { case 1: { SEXP p0 = p[0]; if (p0 == strings_data_frame) { return vctrs_class_bare_data_frame; } else if (p0 == strings_factor) { return vctrs_class_bare_factor; } else if (p0 == strings_date) { return vctrs_class_bare_date; } break; } case 2: { SEXP p0 = p[0]; SEXP p1 = p[1]; if (p0 == strings_ordered && p1 == strings_factor) { return vctrs_class_bare_ordered; } if (p1 == strings_posixt) { if (p0 == strings_posixct) { return vctrs_class_bare_posixct; } else if (p0 == strings_posixlt) { return vctrs_class_bare_posixlt; } } break; } case 3: { if (p[0] == strings_tbl_df && p[1] == strings_tbl && p[2] == strings_data_frame) { return vctrs_class_bare_tibble; } break; }} // Now check for inherited classes p = p + n - 2; SEXP butlast = *p++; SEXP last = *p++; if (butlast == strings_posixlt) { if (last == strings_posixt) return vctrs_class_posixlt; } else if (butlast == strings_vctrs_rcrd) { if (last == strings_vctrs_vctr) return vctrs_class_rcrd; } else if (butlast == strings_vctrs_list_of) { if (last == strings_vctrs_vctr) return vctrs_class_list_of; } else if (last == strings_data_frame) { return vctrs_class_data_frame; } else if (last == strings_list) { return vctrs_class_list; } return vctrs_class_unknown; } static const char* class_type_as_str(enum vctrs_class_type type) { switch (type) { case vctrs_class_list: return "list"; case vctrs_class_list_of: return "list_of"; case vctrs_class_data_frame: return "data_frame"; case vctrs_class_bare_data_frame: return "bare_data_frame"; case vctrs_class_bare_tibble: return "bare_tibble"; case vctrs_class_bare_factor: return "bare_factor"; case vctrs_class_bare_ordered: return "bare_ordered"; case vctrs_class_rcrd: return "rcrd"; case vctrs_class_bare_date: return "bare_date"; case vctrs_class_bare_posixct: return "bare_posixct"; case vctrs_class_bare_posixlt: return "bare_posixlt"; case vctrs_class_posixlt: return "posixlt"; case vctrs_class_unknown: return "unknown"; case vctrs_class_none: return "none"; } never_reached("class_type_as_str"); } // [[ include("vctrs.h") ]] bool vec_is_partial(SEXP x) { return x == R_NilValue || (TYPEOF(x) == VECSXP && Rf_inherits(x, "vctrs_partial")); } // [[ register() ]] SEXP vctrs_is_partial(SEXP x) { return Rf_ScalarLogical(vec_is_partial(x)); } vctrs/src/typeof2.c0000644000176200001440000004631613623013722013747 0ustar liggesusers#include "vctrs.h" #include "utils.h" /** * Type for symmetric binary dispatch. * * Permuting `x` and `y` does not change the typeof2. * * After adding entries in `vec_typeof2()`, adjust the list of types * in helper-types.R. This will ensure the consistency of the new * entries. */ /** * [[ include("utils.h") ]] * * @param left Output parameter. Set to 1 when the common type comes * from the left, 0 when it comes from the right, and -1 when it * comes from both sides. This means that "left" is the default * when coerced to a boolean value. */ enum vctrs_type2 vec_typeof2_impl(enum vctrs_type type_x, enum vctrs_type type_y, int* left) { switch (type_x) { case vctrs_type_null: { switch (type_y) { case vctrs_type_null: *left = -1; return vctrs_type2_null_null; case vctrs_type_unspecified: *left = 0; return vctrs_type2_null_unspecified; case vctrs_type_logical: *left = 0; return vctrs_type2_null_logical; case vctrs_type_integer: *left = 0; return vctrs_type2_null_integer; case vctrs_type_double: *left = 0; return vctrs_type2_null_double; case vctrs_type_complex: *left = 0; return vctrs_type2_null_complex; case vctrs_type_character: *left = 0; return vctrs_type2_null_character; case vctrs_type_raw: *left = 0; return vctrs_type2_null_raw; case vctrs_type_list: *left = 0; return vctrs_type2_null_list; case vctrs_type_dataframe: *left = 0; return vctrs_type2_null_dataframe; case vctrs_type_s3: *left = 0; return vctrs_type2_null_s3; case vctrs_type_scalar: *left = 0; return vctrs_type2_null_scalar; } } case vctrs_type_unspecified: { switch (type_y) { case vctrs_type_null: *left = 1; return vctrs_type2_null_unspecified; case vctrs_type_unspecified: *left = -1; return vctrs_type2_unspecified_unspecified; case vctrs_type_logical: *left = 0; return vctrs_type2_unspecified_logical; case vctrs_type_integer: *left = 0; return vctrs_type2_unspecified_integer; case vctrs_type_double: *left = 0; return vctrs_type2_unspecified_double; case vctrs_type_complex: *left = 0; return vctrs_type2_unspecified_complex; case vctrs_type_character: *left = 0; return vctrs_type2_unspecified_character; case vctrs_type_raw: *left = 0; return vctrs_type2_unspecified_raw; case vctrs_type_list: *left = 0; return vctrs_type2_unspecified_list; case vctrs_type_dataframe: *left = 0; return vctrs_type2_unspecified_dataframe; case vctrs_type_s3: *left = 0; return vctrs_type2_unspecified_s3; case vctrs_type_scalar: *left = 0; return vctrs_type2_unspecified_scalar; } } case vctrs_type_logical: { switch (type_y) { case vctrs_type_null: *left = 1; return vctrs_type2_null_logical; case vctrs_type_unspecified: *left = 1; return vctrs_type2_unspecified_logical; case vctrs_type_logical: *left = -1; return vctrs_type2_logical_logical; case vctrs_type_integer: *left = 0; return vctrs_type2_logical_integer; case vctrs_type_double: *left = 0; return vctrs_type2_logical_double; case vctrs_type_complex: *left = 0; return vctrs_type2_logical_complex; case vctrs_type_character: *left = 0; return vctrs_type2_logical_character; case vctrs_type_raw: *left = 0; return vctrs_type2_logical_raw; case vctrs_type_list: *left = 0; return vctrs_type2_logical_list; case vctrs_type_dataframe: *left = 0; return vctrs_type2_logical_dataframe; case vctrs_type_s3: *left = 0; return vctrs_type2_logical_s3; case vctrs_type_scalar: *left = 0; return vctrs_type2_logical_scalar; } } case vctrs_type_integer: { switch (type_y) { case vctrs_type_null: *left = 1; return vctrs_type2_null_integer; case vctrs_type_unspecified: *left = 1; return vctrs_type2_unspecified_integer; case vctrs_type_logical: *left = 1; return vctrs_type2_logical_integer; case vctrs_type_integer: *left = -1; return vctrs_type2_integer_integer; case vctrs_type_double: *left = 0; return vctrs_type2_integer_double; case vctrs_type_complex: *left = 0; return vctrs_type2_integer_complex; case vctrs_type_character: *left = 0; return vctrs_type2_integer_character; case vctrs_type_raw: *left = 0; return vctrs_type2_integer_raw; case vctrs_type_list: *left = 0; return vctrs_type2_integer_list; case vctrs_type_dataframe: *left = 0; return vctrs_type2_integer_dataframe; case vctrs_type_s3: *left = 0; return vctrs_type2_integer_s3; case vctrs_type_scalar: *left = 0; return vctrs_type2_integer_scalar; } } case vctrs_type_double: { switch (type_y) { case vctrs_type_null: *left = 1; return vctrs_type2_null_double; case vctrs_type_unspecified: *left = 1; return vctrs_type2_unspecified_double; case vctrs_type_logical: *left = 1; return vctrs_type2_logical_double; case vctrs_type_integer: *left = 1; return vctrs_type2_integer_double; case vctrs_type_double: *left = -1; return vctrs_type2_double_double; case vctrs_type_complex: *left = 0; return vctrs_type2_double_complex; case vctrs_type_character: *left = 0; return vctrs_type2_double_character; case vctrs_type_raw: *left = 0; return vctrs_type2_double_raw; case vctrs_type_list: *left = 0; return vctrs_type2_double_list; case vctrs_type_dataframe: *left = 0; return vctrs_type2_double_dataframe; case vctrs_type_s3: *left = 0; return vctrs_type2_double_s3; case vctrs_type_scalar: *left = 0; return vctrs_type2_double_scalar; } } case vctrs_type_complex: { switch (type_y) { case vctrs_type_null: *left = 1; return vctrs_type2_null_complex; case vctrs_type_unspecified: *left = 1; return vctrs_type2_unspecified_complex; case vctrs_type_logical: *left = 1; return vctrs_type2_logical_complex; case vctrs_type_integer: *left = 1; return vctrs_type2_integer_complex; case vctrs_type_double: *left = 1; return vctrs_type2_double_complex; case vctrs_type_complex: *left = -1; return vctrs_type2_complex_complex; case vctrs_type_character: *left = 0; return vctrs_type2_complex_character; case vctrs_type_raw: *left = 0; return vctrs_type2_complex_raw; case vctrs_type_list: *left = 0; return vctrs_type2_complex_list; case vctrs_type_dataframe: *left = 0; return vctrs_type2_complex_dataframe; case vctrs_type_s3: *left = 0; return vctrs_type2_complex_s3; case vctrs_type_scalar: *left = 0; return vctrs_type2_complex_scalar; } } case vctrs_type_character: { switch (type_y) { case vctrs_type_null: *left = 1; return vctrs_type2_null_character; case vctrs_type_unspecified: *left = 1; return vctrs_type2_unspecified_character; case vctrs_type_logical: *left = 1; return vctrs_type2_logical_character; case vctrs_type_integer: *left = 1; return vctrs_type2_integer_character; case vctrs_type_double: *left = 1; return vctrs_type2_double_character; case vctrs_type_complex: *left = 1; return vctrs_type2_complex_character; case vctrs_type_character: *left = -1; return vctrs_type2_character_character; case vctrs_type_raw: *left = 0; return vctrs_type2_character_raw; case vctrs_type_list: *left = 0; return vctrs_type2_character_list; case vctrs_type_dataframe: *left = 0; return vctrs_type2_character_dataframe; case vctrs_type_s3: *left = 0; return vctrs_type2_character_s3; case vctrs_type_scalar: *left = 0; return vctrs_type2_character_scalar; } } case vctrs_type_raw: { switch (type_y) { case vctrs_type_null: *left = 1; return vctrs_type2_null_raw; case vctrs_type_unspecified: *left = 1; return vctrs_type2_unspecified_raw; case vctrs_type_logical: *left = 1; return vctrs_type2_logical_raw; case vctrs_type_integer: *left = 1; return vctrs_type2_integer_raw; case vctrs_type_double: *left = 1; return vctrs_type2_double_raw; case vctrs_type_complex: *left = 1; return vctrs_type2_complex_raw; case vctrs_type_character: *left = 1; return vctrs_type2_character_raw; case vctrs_type_raw: *left = -1; return vctrs_type2_raw_raw; case vctrs_type_list: *left = 0; return vctrs_type2_raw_list; case vctrs_type_dataframe: *left = 0; return vctrs_type2_raw_dataframe; case vctrs_type_s3: *left = 0; return vctrs_type2_raw_s3; case vctrs_type_scalar: *left = 0; return vctrs_type2_raw_scalar; } } case vctrs_type_list: { switch (type_y) { case vctrs_type_null: *left = 1; return vctrs_type2_null_list; case vctrs_type_unspecified: *left = 1; return vctrs_type2_unspecified_list; case vctrs_type_logical: *left = 1; return vctrs_type2_logical_list; case vctrs_type_integer: *left = 1; return vctrs_type2_integer_list; case vctrs_type_double: *left = 1; return vctrs_type2_double_list; case vctrs_type_complex: *left = 1; return vctrs_type2_complex_list; case vctrs_type_character: *left = 1; return vctrs_type2_character_list; case vctrs_type_raw: *left = 1; return vctrs_type2_raw_list; case vctrs_type_list: *left = -1; return vctrs_type2_list_list; case vctrs_type_dataframe: *left = 0; return vctrs_type2_list_dataframe; case vctrs_type_s3: *left = 0; return vctrs_type2_list_s3; case vctrs_type_scalar: *left = 0; return vctrs_type2_list_scalar; } } case vctrs_type_dataframe: { switch (type_y) { case vctrs_type_null: *left = 1; return vctrs_type2_null_dataframe; case vctrs_type_unspecified: *left = 1; return vctrs_type2_unspecified_dataframe; case vctrs_type_logical: *left = 1; return vctrs_type2_logical_dataframe; case vctrs_type_integer: *left = 1; return vctrs_type2_integer_dataframe; case vctrs_type_double: *left = 1; return vctrs_type2_double_dataframe; case vctrs_type_complex: *left = 1; return vctrs_type2_complex_dataframe; case vctrs_type_character: *left = 1; return vctrs_type2_character_dataframe; case vctrs_type_raw: *left = 1; return vctrs_type2_raw_dataframe; case vctrs_type_list: *left = 1; return vctrs_type2_list_dataframe; case vctrs_type_dataframe: *left = -1; return vctrs_type2_dataframe_dataframe; case vctrs_type_s3: *left = 0; return vctrs_type2_dataframe_s3; case vctrs_type_scalar: *left = 0; return vctrs_type2_dataframe_scalar; } } case vctrs_type_s3: { switch (type_y) { case vctrs_type_null: *left = 1; return vctrs_type2_null_s3; case vctrs_type_unspecified: *left = 1; return vctrs_type2_unspecified_s3; case vctrs_type_logical: *left = 1; return vctrs_type2_logical_s3; case vctrs_type_integer: *left = 1; return vctrs_type2_integer_s3; case vctrs_type_double: *left = 1; return vctrs_type2_double_s3; case vctrs_type_complex: *left = 1; return vctrs_type2_complex_s3; case vctrs_type_character: *left = 1; return vctrs_type2_character_s3; case vctrs_type_raw: *left = 1; return vctrs_type2_raw_s3; case vctrs_type_list: *left = 1; return vctrs_type2_list_s3; case vctrs_type_dataframe: *left = 1; return vctrs_type2_dataframe_s3; case vctrs_type_s3: *left = -1; return vctrs_type2_s3_s3; case vctrs_type_scalar: *left = 0; return vctrs_type2_s3_scalar; } } case vctrs_type_scalar: { switch (type_y) { case vctrs_type_null: *left = 1; return vctrs_type2_null_scalar; case vctrs_type_unspecified: *left = 1; return vctrs_type2_unspecified_scalar; case vctrs_type_logical: *left = 1; return vctrs_type2_logical_scalar; case vctrs_type_integer: *left = 1; return vctrs_type2_integer_scalar; case vctrs_type_double: *left = 1; return vctrs_type2_double_scalar; case vctrs_type_complex: *left = 1; return vctrs_type2_complex_scalar; case vctrs_type_character: *left = 1; return vctrs_type2_character_scalar; case vctrs_type_raw: *left = 1; return vctrs_type2_raw_scalar; case vctrs_type_list: *left = 1; return vctrs_type2_list_scalar; case vctrs_type_dataframe: *left = 1; return vctrs_type2_dataframe_scalar; case vctrs_type_s3: *left = 1; return vctrs_type2_s3_scalar; case vctrs_type_scalar: *left = -1; return vctrs_type2_scalar_scalar; } }} never_reached("vec_typeof2_impl()"); } // [[ include("vctrs.h") ]] enum vctrs_type2 vec_typeof2(SEXP x, SEXP y) { int _; return vec_typeof2_impl(vec_typeof(x), vec_typeof(y), &_); } const char* vctrs_type2_as_str(enum vctrs_type2 type) { switch (type) { case vctrs_type2_null_null: return "vctrs_type2_null_null"; case vctrs_type2_null_logical: return "vctrs_type2_null_logical"; case vctrs_type2_null_integer: return "vctrs_type2_null_integer"; case vctrs_type2_null_double: return "vctrs_type2_null_double"; case vctrs_type2_null_complex: return "vctrs_type2_null_complex"; case vctrs_type2_null_character: return "vctrs_type2_null_character"; case vctrs_type2_null_raw: return "vctrs_type2_null_raw"; case vctrs_type2_null_list: return "vctrs_type2_null_list"; case vctrs_type2_null_dataframe: return "vctrs_type2_null_dataframe"; case vctrs_type2_null_s3: return "vctrs_type2_null_s3"; case vctrs_type2_null_unspecified: return "vctrs_type2_null_unspecified"; case vctrs_type2_null_scalar: return "vctrs_type2_null_scalar"; case vctrs_type2_unspecified_logical: return "vctrs_type2_unspecified_logical"; case vctrs_type2_unspecified_integer: return "vctrs_type2_unspecified_integer"; case vctrs_type2_unspecified_double: return "vctrs_type2_unspecified_double"; case vctrs_type2_unspecified_complex: return "vctrs_type2_unspecified_complex"; case vctrs_type2_unspecified_character: return "vctrs_type2_unspecified_character"; case vctrs_type2_unspecified_raw: return "vctrs_type2_unspecified_raw"; case vctrs_type2_unspecified_list: return "vctrs_type2_unspecified_list"; case vctrs_type2_unspecified_dataframe: return "vctrs_type2_unspecified_dataframe"; case vctrs_type2_unspecified_s3: return "vctrs_type2_unspecified_s3"; case vctrs_type2_unspecified_unspecified: return "vctrs_type2_unspecified_unspecified"; case vctrs_type2_unspecified_scalar: return "vctrs_type2_unspecified_scalar"; case vctrs_type2_logical_logical: return "vctrs_type2_logical_logical"; case vctrs_type2_logical_integer: return "vctrs_type2_logical_integer"; case vctrs_type2_logical_double: return "vctrs_type2_logical_double"; case vctrs_type2_logical_complex: return "vctrs_type2_logical_complex"; case vctrs_type2_logical_character: return "vctrs_type2_logical_character"; case vctrs_type2_logical_raw: return "vctrs_type2_logical_raw"; case vctrs_type2_logical_list: return "vctrs_type2_logical_list"; case vctrs_type2_logical_dataframe: return "vctrs_type2_logical_dataframe"; case vctrs_type2_logical_s3: return "vctrs_type2_logical_s3"; case vctrs_type2_logical_scalar: return "vctrs_type2_logical_scalar"; case vctrs_type2_integer_integer: return "vctrs_type2_integer_integer"; case vctrs_type2_integer_double: return "vctrs_type2_integer_double"; case vctrs_type2_integer_complex: return "vctrs_type2_integer_complex"; case vctrs_type2_integer_character: return "vctrs_type2_integer_character"; case vctrs_type2_integer_raw: return "vctrs_type2_integer_raw"; case vctrs_type2_integer_list: return "vctrs_type2_integer_list"; case vctrs_type2_integer_dataframe: return "vctrs_type2_integer_dataframe"; case vctrs_type2_integer_s3: return "vctrs_type2_integer_s3"; case vctrs_type2_integer_scalar: return "vctrs_type2_integer_scalar"; case vctrs_type2_double_double: return "vctrs_type2_double_double"; case vctrs_type2_double_complex: return "vctrs_type2_double_complex"; case vctrs_type2_double_character: return "vctrs_type2_double_character"; case vctrs_type2_double_raw: return "vctrs_type2_double_raw"; case vctrs_type2_double_list: return "vctrs_type2_double_list"; case vctrs_type2_double_dataframe: return "vctrs_type2_double_dataframe"; case vctrs_type2_double_s3: return "vctrs_type2_double_s3"; case vctrs_type2_double_scalar: return "vctrs_type2_double_scalar"; case vctrs_type2_complex_complex: return "vctrs_type2_complex_complex"; case vctrs_type2_complex_character: return "vctrs_type2_complex_character"; case vctrs_type2_complex_raw: return "vctrs_type2_complex_raw"; case vctrs_type2_complex_list: return "vctrs_type2_complex_list"; case vctrs_type2_complex_dataframe: return "vctrs_type2_complex_dataframe"; case vctrs_type2_complex_s3: return "vctrs_type2_complex_s3"; case vctrs_type2_complex_scalar: return "vctrs_type2_complex_scalar"; case vctrs_type2_character_character: return "vctrs_type2_character_character"; case vctrs_type2_character_raw: return "vctrs_type2_character_raw"; case vctrs_type2_character_list: return "vctrs_type2_character_list"; case vctrs_type2_character_dataframe: return "vctrs_type2_character_dataframe"; case vctrs_type2_character_s3: return "vctrs_type2_character_s3"; case vctrs_type2_character_scalar: return "vctrs_type2_character_scalar"; case vctrs_type2_raw_raw: return "vctrs_type2_raw_raw"; case vctrs_type2_raw_list: return "vctrs_type2_raw_list"; case vctrs_type2_raw_dataframe: return "vctrs_type2_raw_dataframe"; case vctrs_type2_raw_s3: return "vctrs_type2_raw_s3"; case vctrs_type2_raw_scalar: return "vctrs_type2_raw_scalar"; case vctrs_type2_list_list: return "vctrs_type2_list_list"; case vctrs_type2_list_dataframe: return "vctrs_type2_list_dataframe"; case vctrs_type2_list_s3: return "vctrs_type2_list_s3"; case vctrs_type2_list_scalar: return "vctrs_type2_list_scalar"; case vctrs_type2_dataframe_dataframe: return "vctrs_type2_dataframe_dataframe"; case vctrs_type2_dataframe_s3: return "vctrs_type2_dataframe_s3"; case vctrs_type2_dataframe_scalar: return "vctrs_type2_dataframe_scalar"; case vctrs_type2_s3_s3: return "vctrs_type2_s3_s3"; case vctrs_type2_s3_scalar: return "vctrs_type2_s3_scalar"; case vctrs_type2_scalar_scalar: return "vctrs_type2_scalar_scalar"; } never_reached("vctrs_type2_as_str"); } SEXP vctrs_typeof2(SEXP x, SEXP y) { enum vctrs_type2 type = vec_typeof2(x, y); return Rf_mkString(vctrs_type2_as_str(type)); } vctrs/src/type-data-frame.c0000644000176200001440000001244713623032515015336 0ustar liggesusers#include "vctrs.h" #include "type-data-frame.h" #include "utils.h" // [[ include("type-data-frame.h") ]] bool is_data_frame(SEXP x) { enum vctrs_class_type type = class_type(x); return type == vctrs_class_bare_data_frame || type == vctrs_class_bare_tibble || type == vctrs_class_data_frame; } // [[ include("type-data-frame.h") ]] bool is_native_df(SEXP x) { enum vctrs_class_type type = class_type(x); return type == vctrs_class_bare_data_frame || type == vctrs_class_bare_tibble; } // [[ include("type-data-frame.h") ]] bool is_bare_data_frame(SEXP x) { return class_type(x) == vctrs_class_bare_data_frame; } // [[ include("type-data-frame.h") ]] bool is_bare_tibble(SEXP x) { return class_type(x) == vctrs_class_bare_tibble; } // [[ include("type-data-frame.h") ]] SEXP new_data_frame(SEXP x, R_len_t n) { x = PROTECT(r_maybe_duplicate(x)); init_data_frame(x, n); UNPROTECT(1); return x; } static R_len_t df_size_from_list(SEXP x, SEXP n); static void poke_data_frame_class(SEXP x, SEXP cls); // [[ register() ]] SEXP vctrs_new_data_frame(SEXP args) { args = CDR(args); SEXP x = CAR(args); args = CDR(args); SEXP n = CAR(args); args = CDR(args); SEXP cls = CAR(args); args = CDR(args); SEXP attrib = args; if (TYPEOF(x) != VECSXP) { Rf_errorcall(R_NilValue, "`x` must be a list"); } R_len_t size = df_size_from_list(x, n); if (attrib != R_NilValue) { x = r_maybe_duplicate(x); SET_ATTRIB(x, attrib); } PROTECT(x); SEXP out = PROTECT(new_data_frame(x, size)); if (cls != R_NilValue) { poke_data_frame_class(out, cls); } UNPROTECT(2); return out; } static R_len_t df_size_from_list(SEXP x, SEXP n) { if (n == R_NilValue) { return df_raw_size_from_list(x); } if (TYPEOF(n) != INTSXP || Rf_length(n) != 1) { Rf_errorcall(R_NilValue, "`n` must be an integer of size 1"); } return r_int_get(n, 0); } static void poke_data_frame_class(SEXP x, SEXP cls) { if (cls == R_NilValue) { return; } if (TYPEOF(cls) != STRSXP) { Rf_errorcall(R_NilValue, "`class` must be NULL or a character vector"); } if (Rf_length(cls) == 0) { return; } SEXP args = PROTECT(Rf_allocVector(VECSXP, 2)); SET_VECTOR_ELT(args, 0, cls); SET_VECTOR_ELT(args, 1, classes_data_frame); cls = PROTECT(vec_c( args, vctrs_shared_empty_chr, R_NilValue, NULL )); Rf_setAttrib(x, R_ClassSymbol, cls); UNPROTECT(2); } // [[ include("type-data-frame.h") ]] enum rownames_type rownames_type(SEXP x) { switch (TYPEOF(x)) { case STRSXP: return ROWNAMES_IDENTIFIERS; case INTSXP: if (Rf_length(x) == 2 && INTEGER(x)[0] == NA_INTEGER) { return ROWNAMES_AUTOMATIC_COMPACT; } else { return ROWNAMES_AUTOMATIC; } default: Rf_error("Corrupt data in `rownames_type()`: Unexpected type `%s`.", Rf_type2char(TYPEOF(x))); } } // [[ include("type-data-frame.h") ]] R_len_t compact_rownames_length(SEXP x) { return abs(INTEGER(x)[1]); } static void init_bare_data_frame(SEXP x, R_len_t n); static SEXP new_compact_rownames(R_len_t n); // [[ include("type-data-frame.h") ]] void init_data_frame(SEXP x, R_len_t n) { Rf_setAttrib(x, R_ClassSymbol, classes_data_frame); init_bare_data_frame(x, n); } // [[ include("type-data-frame.h") ]] void init_tibble(SEXP x, R_len_t n) { Rf_setAttrib(x, R_ClassSymbol, classes_tibble); init_bare_data_frame(x, n); } static void init_bare_data_frame(SEXP x, R_len_t n) { if (Rf_length(x) == 0) { Rf_setAttrib(x, R_NamesSymbol, vctrs_shared_empty_chr); } init_compact_rownames(x, n); } // [[ include("type-data-frame.h") ]] void init_compact_rownames(SEXP x, R_len_t n) { SEXP rn = PROTECT(new_compact_rownames(n)); Rf_setAttrib(x, R_RowNamesSymbol, rn); UNPROTECT(1); } static SEXP new_compact_rownames(R_len_t n) { if (n <= 0) { return vctrs_shared_empty_int; } SEXP out = Rf_allocVector(INTSXP, 2); int* out_data = INTEGER(out); out_data[0] = NA_INTEGER; out_data[1] = -n; return out; } // [[ include("type-data-frame.h") ]] SEXP df_rownames(SEXP x) { // Required, because getAttrib() already does the transformation to a vector, // and getAttrib0() is hidden SEXP node = ATTRIB(x); while (node != R_NilValue) { SEXP tag = TAG(node); if (tag == R_RowNamesSymbol) { return CAR(node); } node = CDR(node); } return R_NilValue; } SEXP df_container_type(SEXP x) { SEXP type = PROTECT(Rf_allocVector(VECSXP, 0)); SET_ATTRIB(type, Rf_shallow_duplicate(ATTRIB(x))); SET_OBJECT(type, OBJECT(x)); Rf_setAttrib(type, R_NamesSymbol, vctrs_shared_empty_chr); init_compact_rownames(type, df_size(x)); UNPROTECT(1); return type; } // If negative index, value is appended SEXP df_poke(SEXP x, R_len_t i, SEXP value) { if (i >= 0) { SET_VECTOR_ELT(x, i, value); return x; } R_len_t ncol = Rf_length(x); SEXP tmp = PROTECT(r_resize(x, ncol + 1)); Rf_copyMostAttrib(x, tmp); x = tmp; SET_VECTOR_ELT(x, ncol, value); UNPROTECT(1); return x; } SEXP df_poke_at(SEXP x, SEXP name, SEXP value) { SEXP names = PROTECT(r_names(x)); R_len_t i = r_chr_find(names, name); UNPROTECT(1); x = PROTECT(df_poke(x, i, value)); if (i < 0) { SEXP names = PROTECT(r_names(x)); SET_STRING_ELT(names, Rf_length(x) - 1, name); UNPROTECT(1); } UNPROTECT(1); return x; } vctrs/src/vctrs.h0000644000176200001440000004564613623203263013533 0ustar liggesusers#define R_NO_REMAP #include #include #include #include #include typedef R_xlen_t r_ssize_t; #define VCTRS_ASSERT(condition) ((void)sizeof(char[1 - 2*!(condition)])) // Vector types ------------------------------------------------- enum vctrs_type { vctrs_type_null = 0, vctrs_type_unspecified, vctrs_type_logical, vctrs_type_integer, vctrs_type_double, vctrs_type_complex, vctrs_type_character, vctrs_type_raw, vctrs_type_list, vctrs_type_dataframe, vctrs_type_scalar, vctrs_type_s3 = 255 }; /** * @member type The vector type of the original data. * @member proxy_method The function of the `vec_proxy()` method, if * any. This method is looked up with [vec_proxy_method()]. */ struct vctrs_type_info { enum vctrs_type type; SEXP proxy_method; }; /** * @inheritMembers vctrs_type_info * @member type If `proxy_method` was found, the vector type of the * proxy data. Otherwise, the vector type of the original data. * This is never `vctrs_type_s3`. * @member proxy If `proxy_method` was found, the result of invoking * the method. Otherwise, the original data. */ struct vctrs_proxy_info { enum vctrs_type type; SEXP proxy_method; SEXP proxy; }; /** * Return the type information of a vector or its proxy * * `vec_type_info()` returns the vctrs type of `x`. `vec_proxy_info()` * returns the vctrs type of `x` or its proxy if it has one. The * former returns `vctrs_type_s3` with S3 objects (expect for native * types like bare data frames). The latter returns the bare type of * the proxy, if any. It never returns `vctrs_type_s3`. * * `vec_proxy_info()` returns both the proxy method and the proxy * data. `vec_type_info()` only returns the proxy method, which it * needs to determine whether S3 lists and non-vector base types are * scalars or proxied vectors. * * Use `PROTECT_PROXY_INFO()` and `PROTECT_TYPE_INFO()` to protect the * members of the return value. These helpers take a pointer to a * protection counter that can be passed to `UNPROTECT()`. */ struct vctrs_type_info vec_type_info(SEXP x); struct vctrs_proxy_info vec_proxy_info(SEXP x); #define PROTECT_PROXY_INFO(info, n) do { \ PROTECT((info)->proxy); \ PROTECT((info)->proxy_method); \ *n += 2; \ } while (0) #define PROTECT_TYPE_INFO(info, n) do { \ PROTECT((info)->proxy_method); \ *n += 1; \ } while (0) enum vctrs_type vec_typeof(SEXP x); enum vctrs_type vec_proxy_typeof(SEXP x); const char* vec_type_as_str(enum vctrs_type type); bool vec_is_vector(SEXP x); bool vec_is_partial(SEXP x); // After adding a new `vctrs_dispatch` type, add the missing entries // in `vec_typeof2()` enum vctrs_type2 { vctrs_type2_null_null, vctrs_type2_null_unspecified, vctrs_type2_null_logical, vctrs_type2_null_integer, vctrs_type2_null_double, vctrs_type2_null_complex, vctrs_type2_null_character, vctrs_type2_null_raw, vctrs_type2_null_list, vctrs_type2_null_dataframe, vctrs_type2_null_s3, vctrs_type2_null_scalar, vctrs_type2_unspecified_unspecified, vctrs_type2_unspecified_logical, vctrs_type2_unspecified_integer, vctrs_type2_unspecified_double, vctrs_type2_unspecified_complex, vctrs_type2_unspecified_character, vctrs_type2_unspecified_raw, vctrs_type2_unspecified_list, vctrs_type2_unspecified_dataframe, vctrs_type2_unspecified_s3, vctrs_type2_unspecified_scalar, vctrs_type2_logical_logical, vctrs_type2_logical_integer, vctrs_type2_logical_double, vctrs_type2_logical_complex, vctrs_type2_logical_character, vctrs_type2_logical_raw, vctrs_type2_logical_list, vctrs_type2_logical_dataframe, vctrs_type2_logical_s3, vctrs_type2_logical_scalar, vctrs_type2_integer_integer, vctrs_type2_integer_double, vctrs_type2_integer_complex, vctrs_type2_integer_character, vctrs_type2_integer_raw, vctrs_type2_integer_list, vctrs_type2_integer_dataframe, vctrs_type2_integer_s3, vctrs_type2_integer_scalar, vctrs_type2_double_double, vctrs_type2_double_complex, vctrs_type2_double_character, vctrs_type2_double_raw, vctrs_type2_double_list, vctrs_type2_double_dataframe, vctrs_type2_double_s3, vctrs_type2_double_scalar, vctrs_type2_complex_complex, vctrs_type2_complex_character, vctrs_type2_complex_raw, vctrs_type2_complex_list, vctrs_type2_complex_dataframe, vctrs_type2_complex_s3, vctrs_type2_complex_scalar, vctrs_type2_character_character, vctrs_type2_character_raw, vctrs_type2_character_list, vctrs_type2_character_dataframe, vctrs_type2_character_s3, vctrs_type2_character_scalar, vctrs_type2_raw_raw, vctrs_type2_raw_list, vctrs_type2_raw_dataframe, vctrs_type2_raw_s3, vctrs_type2_raw_scalar, vctrs_type2_list_list, vctrs_type2_list_dataframe, vctrs_type2_list_s3, vctrs_type2_list_scalar, vctrs_type2_dataframe_dataframe, vctrs_type2_dataframe_s3, vctrs_type2_dataframe_scalar, vctrs_type2_s3_s3, vctrs_type2_s3_scalar, vctrs_type2_scalar_scalar }; enum vctrs_type2_s3 { vctrs_type2_s3_null_bare_factor, vctrs_type2_s3_null_bare_ordered, vctrs_type2_s3_null_bare_date, vctrs_type2_s3_null_bare_posixct, vctrs_type2_s3_null_bare_posixlt, vctrs_type2_s3_null_bare_tibble, vctrs_type2_s3_null_unknown, vctrs_type2_s3_unspecified_bare_factor, vctrs_type2_s3_unspecified_bare_ordered, vctrs_type2_s3_unspecified_bare_date, vctrs_type2_s3_unspecified_bare_posixct, vctrs_type2_s3_unspecified_bare_posixlt, vctrs_type2_s3_unspecified_bare_tibble, vctrs_type2_s3_unspecified_unknown, vctrs_type2_s3_logical_bare_factor, vctrs_type2_s3_logical_bare_ordered, vctrs_type2_s3_logical_bare_date, vctrs_type2_s3_logical_bare_posixct, vctrs_type2_s3_logical_bare_posixlt, vctrs_type2_s3_logical_bare_tibble, vctrs_type2_s3_logical_unknown, vctrs_type2_s3_integer_bare_factor, vctrs_type2_s3_integer_bare_ordered, vctrs_type2_s3_integer_bare_date, vctrs_type2_s3_integer_bare_posixct, vctrs_type2_s3_integer_bare_posixlt, vctrs_type2_s3_integer_bare_tibble, vctrs_type2_s3_integer_unknown, vctrs_type2_s3_double_bare_factor, vctrs_type2_s3_double_bare_ordered, vctrs_type2_s3_double_bare_date, vctrs_type2_s3_double_bare_posixct, vctrs_type2_s3_double_bare_posixlt, vctrs_type2_s3_double_bare_tibble, vctrs_type2_s3_double_unknown, vctrs_type2_s3_complex_bare_factor, vctrs_type2_s3_complex_bare_ordered, vctrs_type2_s3_complex_bare_date, vctrs_type2_s3_complex_bare_posixct, vctrs_type2_s3_complex_bare_posixlt, vctrs_type2_s3_complex_bare_tibble, vctrs_type2_s3_complex_unknown, vctrs_type2_s3_character_bare_factor, vctrs_type2_s3_character_bare_ordered, vctrs_type2_s3_character_bare_date, vctrs_type2_s3_character_bare_posixct, vctrs_type2_s3_character_bare_posixlt, vctrs_type2_s3_character_bare_tibble, vctrs_type2_s3_character_unknown, vctrs_type2_s3_raw_bare_factor, vctrs_type2_s3_raw_bare_ordered, vctrs_type2_s3_raw_bare_date, vctrs_type2_s3_raw_bare_posixct, vctrs_type2_s3_raw_bare_posixlt, vctrs_type2_s3_raw_bare_tibble, vctrs_type2_s3_raw_unknown, vctrs_type2_s3_list_bare_factor, vctrs_type2_s3_list_bare_ordered, vctrs_type2_s3_list_bare_date, vctrs_type2_s3_list_bare_posixct, vctrs_type2_s3_list_bare_posixlt, vctrs_type2_s3_list_bare_tibble, vctrs_type2_s3_list_unknown, vctrs_type2_s3_dataframe_bare_factor, vctrs_type2_s3_dataframe_bare_ordered, vctrs_type2_s3_dataframe_bare_date, vctrs_type2_s3_dataframe_bare_posixct, vctrs_type2_s3_dataframe_bare_posixlt, vctrs_type2_s3_dataframe_bare_tibble, vctrs_type2_s3_dataframe_unknown, vctrs_type2_s3_scalar_bare_factor, vctrs_type2_s3_scalar_bare_ordered, vctrs_type2_s3_scalar_bare_date, vctrs_type2_s3_scalar_bare_posixct, vctrs_type2_s3_scalar_bare_posixlt, vctrs_type2_s3_scalar_bare_tibble, vctrs_type2_s3_scalar_unknown, vctrs_type2_s3_bare_factor_bare_factor, vctrs_type2_s3_bare_factor_bare_ordered, vctrs_type2_s3_bare_factor_bare_date, vctrs_type2_s3_bare_factor_bare_posixct, vctrs_type2_s3_bare_factor_bare_posixlt, vctrs_type2_s3_bare_factor_bare_tibble, vctrs_type2_s3_bare_factor_unknown, vctrs_type2_s3_bare_ordered_bare_ordered, vctrs_type2_s3_bare_ordered_bare_date, vctrs_type2_s3_bare_ordered_bare_posixct, vctrs_type2_s3_bare_ordered_bare_posixlt, vctrs_type2_s3_bare_ordered_bare_tibble, vctrs_type2_s3_bare_ordered_unknown, vctrs_type2_s3_bare_date_bare_date, vctrs_type2_s3_bare_date_bare_posixct, vctrs_type2_s3_bare_date_bare_posixlt, vctrs_type2_s3_bare_date_bare_tibble, vctrs_type2_s3_bare_date_unknown, vctrs_type2_s3_bare_posixct_bare_posixct, vctrs_type2_s3_bare_posixct_bare_posixlt, vctrs_type2_s3_bare_posixct_bare_tibble, vctrs_type2_s3_bare_posixct_unknown, vctrs_type2_s3_bare_posixlt_bare_posixlt, vctrs_type2_s3_bare_posixlt_bare_tibble, vctrs_type2_s3_bare_posixlt_unknown, vctrs_type2_s3_bare_tibble_bare_tibble, vctrs_type2_s3_bare_tibble_unknown, vctrs_type2_s3_unknown_unknown }; enum vctrs_type2 vec_typeof2(SEXP x, SEXP y); const char* vctrs_type2_as_str(enum vctrs_type2 type); extern SEXP vctrs_shared_empty_lgl; extern SEXP vctrs_shared_empty_int; extern SEXP vctrs_shared_empty_dbl; extern SEXP vctrs_shared_empty_cpl; extern SEXP vctrs_shared_empty_chr; extern SEXP vctrs_shared_empty_raw; extern SEXP vctrs_shared_empty_list; extern SEXP vctrs_shared_empty_date; extern SEXP vctrs_shared_empty_uns; extern SEXP vctrs_shared_true; extern SEXP vctrs_shared_false; extern Rcomplex vctrs_shared_na_cpl; SEXP vec_unspecified(R_len_t n); bool vec_is_unspecified(SEXP x); // Vector methods ------------------------------------------------ #include "arg.h" #include "names.h" enum vctrs_proxy_kind { vctrs_proxy_default, vctrs_proxy_equal, vctrs_proxy_compare }; SEXP vec_proxy(SEXP x); SEXP vec_proxy_equal(SEXP x); SEXP vec_proxy_recursive(SEXP x, enum vctrs_proxy_kind kind); SEXP vec_restore(SEXP x, SEXP to, SEXP i); R_len_t vec_size(SEXP x); R_len_t vec_size_common(SEXP xs, R_len_t absent); SEXP vec_dim(SEXP x); R_len_t vec_dim_n(SEXP x); SEXP vec_bare_dim(SEXP x); R_len_t vec_bare_dim_n(SEXP x); SEXP vec_cast(SEXP x, SEXP to, struct vctrs_arg* x_arg, struct vctrs_arg* to_arg); SEXP vec_cast_common(SEXP xs, SEXP to); SEXP vec_coercible_cast(SEXP x, SEXP to, struct vctrs_arg* x_arg, struct vctrs_arg* to_arg); SEXP vec_slice(SEXP x, SEXP index); SEXP vec_chop(SEXP x, SEXP indices); SEXP vec_slice_shaped(enum vctrs_type type, SEXP x, SEXP index); SEXP vec_assign(SEXP x, SEXP index, SEXP value); bool vec_requires_fallback(SEXP x, struct vctrs_proxy_info info); SEXP vec_init(SEXP x, R_len_t n); SEXP vec_type(SEXP x); SEXP vec_ptype_finalise(SEXP x); bool vec_is_unspecified(SEXP x); SEXP vec_recycle(SEXP x, R_len_t size, struct vctrs_arg* x_arg); SEXP vec_recycle_common(SEXP xs, R_len_t size); SEXP vec_names(SEXP x); SEXP vec_group_loc(SEXP x); SEXP vec_match(SEXP needles, SEXP haystack); SEXP vec_c(SEXP xs, SEXP ptype, SEXP name_spec, const struct name_repair_opts* name_repair); SEXP vec_type2(SEXP x, SEXP y, struct vctrs_arg* x_arg, struct vctrs_arg* y_arg, int* left); SEXP vec_ptype2_dispatch(SEXP x, SEXP y, enum vctrs_type x_type, enum vctrs_type y_type, struct vctrs_arg* x_arg, struct vctrs_arg* y_arg, int* left); SEXP vec_ptype2_dispatch_s3(SEXP x, SEXP y, struct vctrs_arg* x_arg, struct vctrs_arg* y_arg); SEXP vec_cast_dispatch(SEXP x, SEXP to, enum vctrs_type x_type, enum vctrs_type to_type, bool* lossy, struct vctrs_arg* x_arg, struct vctrs_arg* to_arg); SEXP df_ptype2(SEXP x, SEXP y, struct vctrs_arg* x_arg, struct vctrs_arg* y_arg); SEXP df_as_dataframe(SEXP x, SEXP to, struct vctrs_arg* x_arg, struct vctrs_arg* to_arg); bool is_data_frame(SEXP x); bool is_record(SEXP x); R_len_t df_size(SEXP x); R_len_t df_rownames_size(SEXP x); R_len_t df_raw_size(SEXP x); R_len_t df_raw_size_from_list(SEXP x); SEXP vec_bare_df_restore(SEXP x, SEXP to, SEXP n); SEXP vec_df_restore(SEXP x, SEXP to, SEXP n); SEXP chr_assign(SEXP out, SEXP index, SEXP value, bool clone); SEXP list_assign(SEXP out, SEXP index, SEXP value, bool clone); SEXP df_assign(SEXP out, SEXP index, SEXP value, bool clone); // equal_object() never propagates missingness, so // it can return a `bool` bool equal_object(SEXP x, SEXP y); bool equal_names(SEXP x, SEXP y); /** * These functions are meant to be used in loops so it is the callers * responsibility to ensure that: * * - `x` and `y` have identical SEXTYPEs * - `i` is a valid index into `x`, and `j` is a valid index into `y`. * * The behaviour is undefined if these conditions are not true. */ int equal_scalar(SEXP x, R_len_t i, SEXP y, R_len_t j, bool na_equal); int compare_scalar(SEXP x, R_len_t i, SEXP y, R_len_t j, bool na_equal); uint32_t hash_object(SEXP x); void hash_fill(uint32_t* p, R_len_t n, SEXP x); SEXP vec_unique(SEXP x); bool duplicated_any(SEXP names); // Rowwise operations ------------------------------------------- // Used in functions that treat data frames as vectors of rows, but // iterate over them column wise. Examples are `vec_equal()` and // `vec_compare()`. /** * @member out A vector of size `n_row` containing the output of the * row wise data frame operation. * @member row_known A boolean array of size `n_row`. Allocated on the R heap. * Initially, all values are initialized to `false`. As we iterate along the * columns, we flip the corresponding row's `row_known` value to `true` if we * can determine the `out` value for that row from the current columns. * Once a row's `row_known` value is `true`, we never check that row again * as we continue through the columns. * @member p_row_known A pointer to the boolean array stored in `row_known`. * Initialized with `(bool*) RAW(info.row_known)`. * @member remaining The number of `row_known` values that are still `false`. * If this hits `0` before we traverse the entire data frame, we can exit * immediately because all `out` values are already known. */ struct vctrs_df_rowwise_info { SEXP out; SEXP row_known; bool* p_row_known; R_len_t remaining; }; #define PROTECT_DF_ROWWISE_INFO(info, n) do { \ PROTECT((info)->out); \ PROTECT((info)->row_known); \ *n += 2; \ } while (0) // Missing values ----------------------------------------------- // Annex F of C99 specifies that `double` should conform to the IEEE 754 // type `binary64`, which is defined as: // * 1 bit : sign // * 11 bits: exponent // * 52 bits: significand // // R stores the value "1954" in the last 32 bits: this payload marks // the value as a NA, not a regular NaN. // // On big endian systems, this corresponds to the second element of an // integer array of size 2. On little endian systems, this is flipped // and the NA marker is in the first element. // // The type assumptions made here are asserted in `vctrs_init_utils()` #ifdef WORDS_BIGENDIAN static const int vctrs_indicator_pos = 1; #else static const int vctrs_indicator_pos = 0; #endif union vctrs_dbl_indicator { double value; // 8 bytes unsigned int key[2]; // 4 * 2 bytes }; enum vctrs_dbl_class { vctrs_dbl_number, vctrs_dbl_missing, vctrs_dbl_nan }; enum vctrs_dbl_class dbl_classify(double x); // Factor methods ----------------------------------------------- SEXP fct_ptype2(SEXP x, SEXP y, struct vctrs_arg* x_arg, struct vctrs_arg* y_arg); SEXP ord_ptype2(SEXP x, SEXP y, struct vctrs_arg* x_arg, struct vctrs_arg* y_arg); SEXP fct_as_character(SEXP x, struct vctrs_arg* x_arg); SEXP ord_as_character(SEXP x, struct vctrs_arg* x_arg); SEXP chr_as_factor(SEXP x, SEXP to, bool* lossy, struct vctrs_arg* to_arg); SEXP fct_as_factor(SEXP x, SEXP to, bool* lossy, struct vctrs_arg* x_arg, struct vctrs_arg* to_arg); SEXP chr_as_ordered(SEXP x, SEXP to, bool* lossy, struct vctrs_arg* to_arg); SEXP ord_as_ordered(SEXP x, SEXP to, bool* lossy, struct vctrs_arg* x_arg, struct vctrs_arg* to_arg); // Datetime methods --------------------------------------------- SEXP date_datetime_ptype2(SEXP x, SEXP y); SEXP datetime_datetime_ptype2(SEXP x, SEXP y); // Tibble methods ---------------------------------------------- SEXP tibble_ptype2(SEXP x, SEXP y, struct vctrs_arg* x_arg, struct vctrs_arg* y_arg); // Character translation ---------------------------------------- SEXP obj_maybe_translate_encoding(SEXP x, R_len_t size); SEXP obj_maybe_translate_encoding2(SEXP x, R_len_t x_size, SEXP y, R_len_t y_size); // Growable vector ---------------------------------------------- struct growable { SEXP x; SEXPTYPE type; void* array; PROTECT_INDEX idx; int n; int capacity; }; struct growable new_growable(SEXPTYPE type, int capacity); SEXP growable_values(struct growable* g); static inline void growable_push_int(struct growable* g, int i) { if (g->n == g->capacity) { g->capacity *= 2; g->x = Rf_lengthgets(g->x, g->capacity); REPROTECT(g->x, g->idx); g->array = INTEGER(g->x); } int* p = (int*) g->array; p[g->n] = i; ++(g->n); } #define PROTECT_GROWABLE(g, n) do { \ PROTECT_WITH_INDEX((g)->x, &((g)->idx)); \ *n += 1; \ } while(0) #define UNPROTECT_GROWABLE(g) do { UNPROTECT(1);} while(0) // Shape -------------------------------------------------------- bool has_dim(SEXP x); // Conditions --------------------------------------------------- void vctrs_stop_unsupported_type(enum vctrs_type, const char* fn) __attribute__((noreturn)); void stop_scalar_type(SEXP x, struct vctrs_arg* arg) __attribute__((noreturn)); void vec_assert(SEXP x, struct vctrs_arg* arg); void stop_incompatible_size(SEXP x, SEXP y, R_len_t x_size, R_len_t y_size, struct vctrs_arg* x_arg, struct vctrs_arg* y_arg) __attribute__((noreturn)); void stop_recycle_incompatible_size(R_len_t x_size, R_len_t size, struct vctrs_arg* x_arg) __attribute__((noreturn)); void stop_corrupt_factor_levels(SEXP x, struct vctrs_arg* arg) __attribute__((noreturn)); void stop_corrupt_ordered_levels(SEXP x, struct vctrs_arg* arg) __attribute__((noreturn)); // Compatibility ------------------------------------------------ #if (R_VERSION < R_Version(3, 5, 0)) # define LOGICAL_RO(x) ((const int*) LOGICAL(x)) # define INTEGER_RO(x) ((const int*) INTEGER(x)) # define REAL_RO(x) ((const double*) REAL(x)) # define COMPLEX_RO(x) ((const Rcomplex*) COMPLEX(x)) # define STRING_PTR_RO(x) ((const SEXP*) STRING_PTR(x)) # define RAW_RO(x) ((const Rbyte*) RAW(x)) #endif vctrs/src/equal.c0000644000176200001440000005647313622451540013476 0ustar liggesusers#include #include "vctrs.h" static int lgl_equal_scalar(const int* x, const int* y, bool na_equal); static int int_equal_scalar(const int* x, const int* y, bool na_equal); static int dbl_equal_scalar(const double* x, const double* y, bool na_equal); static int raw_equal_scalar(const Rbyte* x, const Rbyte* y, bool na_equal); static int cpl_equal_scalar(const Rcomplex* x, const Rcomplex* y, bool na_equal); static int chr_equal_scalar(const SEXP* x, const SEXP* y, bool na_equal); static int list_equal_scalar(SEXP x, R_len_t i, SEXP y, R_len_t j, bool na_equal); static int df_equal_scalar(SEXP x, R_len_t i, SEXP y, R_len_t j, bool na_equal, int n_col); // If `x` is a data frame, it must have been recursively proxied // beforehand // // [[ include("vctrs.h") ]] int equal_scalar(SEXP x, R_len_t i, SEXP y, R_len_t j, bool na_equal) { switch (TYPEOF(x)) { case LGLSXP: return lgl_equal_scalar(LOGICAL(x) + i, LOGICAL(y) + j, na_equal); case INTSXP: return int_equal_scalar(INTEGER(x) + i, INTEGER(y) + j, na_equal); case REALSXP: return dbl_equal_scalar(REAL(x) + i, REAL(y) + j, na_equal); case STRSXP: return chr_equal_scalar(STRING_PTR(x) + i, STRING_PTR(y) + j, na_equal); case RAWSXP: return raw_equal_scalar(RAW(x) + i, RAW(y) + j, na_equal); case CPLXSXP: return cpl_equal_scalar(COMPLEX(x) + i, COMPLEX(y) + j, na_equal); default: break; } switch (vec_proxy_typeof(x)) { case vctrs_type_list: return list_equal_scalar(x, i, y, j, na_equal); case vctrs_type_dataframe: { int n_col = Rf_length(x); if (n_col != Rf_length(y)) { Rf_errorcall(R_NilValue, "`x` and `y` must have the same number of columns"); } return df_equal_scalar(x, i, y, j, na_equal, n_col); } default: break; } vctrs_stop_unsupported_type(vec_typeof(x), "equal_scalar()"); } // ----------------------------------------------------------------------------- static SEXP df_equal(SEXP x, SEXP y, bool na_equal, R_len_t n_row); #define EQUAL(CTYPE, CONST_DEREF, SCALAR_EQUAL) \ do { \ SEXP out = PROTECT(Rf_allocVector(LGLSXP, size)); \ int* p_out = LOGICAL(out); \ \ const CTYPE* p_x = CONST_DEREF(x); \ const CTYPE* p_y = CONST_DEREF(y); \ \ for (R_len_t i = 0; i < size; ++i, ++p_x, ++p_y) { \ p_out[i] = SCALAR_EQUAL(p_x, p_y, na_equal); \ } \ \ UNPROTECT(3); \ return out; \ } \ while (0) #define EQUAL_BARRIER(SCALAR_EQUAL) \ do { \ SEXP out = PROTECT(Rf_allocVector(LGLSXP, size)); \ int* p_out = LOGICAL(out); \ \ for (R_len_t i = 0; i < size; ++i) { \ p_out[i] = SCALAR_EQUAL(x, i, y, i, na_equal); \ } \ \ UNPROTECT(3); \ return out; \ } \ while (0) // [[ register() ]] SEXP vctrs_equal(SEXP x, SEXP y, SEXP na_equal_) { x = PROTECT(vec_proxy_equal(x)); y = PROTECT(vec_proxy_equal(y)); R_len_t size = vec_size(x); enum vctrs_type type = vec_proxy_typeof(x); if (type != vec_proxy_typeof(y) || size != vec_size(y)) { Rf_errorcall(R_NilValue, "`x` and `y` must have same types and lengths"); } bool na_equal = Rf_asLogical(na_equal_); switch (type) { case vctrs_type_logical: EQUAL(int, LOGICAL_RO, lgl_equal_scalar); case vctrs_type_integer: EQUAL(int, INTEGER_RO, int_equal_scalar); case vctrs_type_double: EQUAL(double, REAL_RO, dbl_equal_scalar); case vctrs_type_raw: EQUAL(Rbyte, RAW_RO, raw_equal_scalar); case vctrs_type_complex: EQUAL(Rcomplex, COMPLEX_RO, cpl_equal_scalar); case vctrs_type_character: EQUAL(SEXP, STRING_PTR_RO, chr_equal_scalar); case vctrs_type_list: EQUAL_BARRIER(list_equal_scalar); case vctrs_type_dataframe: { SEXP out = PROTECT(df_equal(x, y, na_equal, size)); UNPROTECT(3); return out; } case vctrs_type_scalar: Rf_errorcall(R_NilValue, "Can't compare scalars with `vctrs_equal()`"); default: Rf_error("Unimplemented type in `vctrs_equal()`"); } } #undef EQUAL #undef EQUAL_BARRIER // ----------------------------------------------------------------------------- // Storing pointed values on the stack helps performance for the // `!na_equal` cases static int lgl_equal_scalar(const int* x, const int* y, bool na_equal) { const int xi = *x; const int yj = *y; if (na_equal) { return xi == yj; } else { return (xi == NA_LOGICAL || yj == NA_LOGICAL) ? NA_LOGICAL : xi == yj; } } static int int_equal_scalar(const int* x, const int* y, bool na_equal) { const int xi = *x; const int yj = *y; if (na_equal) { return xi == yj; } else { return (xi == NA_INTEGER || yj == NA_INTEGER) ? NA_LOGICAL : xi == yj; } } static int raw_equal_scalar(const Rbyte* x, const Rbyte* y, bool na_equal) { // Raw vectors have no notion of missing value return *x == *y; } static int dbl_equal_scalar(const double* x, const double* y, bool na_equal) { const double xi = *x; const double yj = *y; if (na_equal) { switch (dbl_classify(xi)) { case vctrs_dbl_number: break; case vctrs_dbl_missing: return dbl_classify(yj) == vctrs_dbl_missing; case vctrs_dbl_nan: return dbl_classify(yj) == vctrs_dbl_nan; } if (isnan(yj)) { return false; } } else { if (isnan(xi) || isnan(yj)) return NA_LOGICAL; } return xi == yj; } static int cpl_equal_scalar(const Rcomplex* x, const Rcomplex* y, bool na_equal) { int real_equal = dbl_equal_scalar(&x->r, &y->r, na_equal); int imag_equal = dbl_equal_scalar(&x->i, &y->i, na_equal); if (real_equal == NA_LOGICAL || imag_equal == NA_LOGICAL) { return NA_LOGICAL; } else { return real_equal && imag_equal; } } // UTF-8 translation is successful in these cases: // - (utf8 + latin1), (unknown + utf8), (unknown + latin1) // UTF-8 translation fails purposefully in these cases: // - (bytes + utf8), (bytes + latin1), (bytes + unknown) // UTF-8 translation is not attempted in these cases: // - (utf8 + utf8), (latin1 + latin1), (unknown + unknown), (bytes + bytes) static int chr_equal_scalar_impl(const SEXP x, const SEXP y) { if (x == y) { return 1; } if (Rf_getCharCE(x) != Rf_getCharCE(y)) { const void *vmax = vmaxget(); int out = !strcmp(Rf_translateCharUTF8(x), Rf_translateCharUTF8(y)); vmaxset(vmax); return out; } return 0; } static int chr_equal_scalar(const SEXP* x, const SEXP* y, bool na_equal) { const SEXP xi = *x; const SEXP yj = *y; if (na_equal) { return chr_equal_scalar_impl(xi, yj); } else { return (xi == NA_STRING || yj == NA_STRING) ? NA_LOGICAL : chr_equal_scalar_impl(xi, yj); } } static int list_equal_scalar(SEXP x, R_len_t i, SEXP y, R_len_t j, bool na_equal) { const SEXP xi = VECTOR_ELT(x, i); const SEXP yj = VECTOR_ELT(y, j); if (na_equal) { return equal_object(xi, yj); } else { return (xi == R_NilValue || yj == R_NilValue) ? NA_LOGICAL : equal_object(xi, yj); } } static int df_equal_scalar(SEXP x, R_len_t i, SEXP y, R_len_t j, bool na_equal, int n_col) { for (int k = 0; k < n_col; ++k) { int eq = equal_scalar(VECTOR_ELT(x, k), i, VECTOR_ELT(y, k), j, na_equal); if (eq <= 0) { return eq; } } return true; } // ----------------------------------------------------------------------------- // Missingness is never propagated through objects, // so `na_equal` is always `true` in these macros #define EQUAL_ALL(CTYPE, CONST_DEREF, SCALAR_EQUAL) \ do { \ const CTYPE* p_x = CONST_DEREF(x); \ const CTYPE* p_y = CONST_DEREF(y); \ \ for (R_len_t i = 0; i < n; ++i, ++p_x, ++p_y) { \ if (!SCALAR_EQUAL(p_x, p_y, true)) { \ return false; \ } \ } \ return true; \ } \ while (0) #define EQUAL_ALL_BARRIER(SCALAR_EQUAL) \ do { \ for (R_len_t i = 0; i < n; ++i) { \ if (!SCALAR_EQUAL(x, i, y, i, true)) { \ return false; \ } \ } \ return true; \ } \ while (0) static inline bool vec_equal_attrib(SEXP x, SEXP y); // [[ include("vctrs.h") ]] bool equal_object(SEXP x, SEXP y) { SEXPTYPE type = TYPEOF(x); if (type != TYPEOF(y)) { return false; } // Pointer comparison is all that is required for these types switch (type) { case NILSXP: case SYMSXP: case SPECIALSXP: case BUILTINSXP: case CHARSXP: case ENVSXP: case EXTPTRSXP: return x == y; } // For other types, try a pointer comparison first before // performing an in depth equality check if (x == y) { return true; } switch(type) { // Handled below case LGLSXP: case INTSXP: case REALSXP: case STRSXP: case RAWSXP: case CPLXSXP: case EXPRSXP: case VECSXP: break; case DOTSXP: case LANGSXP: case LISTSXP: case BCODESXP: { if (!equal_object(ATTRIB(x), ATTRIB(y))) { return false; } if (!equal_object(CAR(x), CAR(y))) { return false; } x = CDR(x); y = CDR(y); if (!equal_object(x, y)) { return false; } return true; } case CLOSXP: if (!equal_object(ATTRIB(x), ATTRIB(y))) { return false; } if (!equal_object(BODY(x), BODY(y))) { return false; } if (!equal_object(CLOENV(x), CLOENV(y))) { return false; } if (!equal_object(FORMALS(x), FORMALS(y))) { return false; } return true; case NILSXP: case SYMSXP: case SPECIALSXP: case BUILTINSXP: case CHARSXP: case ENVSXP: case EXTPTRSXP: // These are handled above with pointer comparison Rf_error("Internal error: Unexpected reference type in `vec_equal()`"); default: Rf_errorcall(R_NilValue, "Unsupported type %s", Rf_type2char(TYPEOF(x))); } R_len_t n = Rf_length(x); if (n != Rf_length(y)) { return false; } if (!vec_equal_attrib(x, y)) { return false; } switch (type) { case LGLSXP: EQUAL_ALL(int, LOGICAL_RO, lgl_equal_scalar); case INTSXP: EQUAL_ALL(int, INTEGER_RO, int_equal_scalar); case REALSXP: EQUAL_ALL(double, REAL_RO, dbl_equal_scalar); case STRSXP: EQUAL_ALL(SEXP, STRING_PTR_RO, chr_equal_scalar); case RAWSXP: EQUAL_ALL(Rbyte, RAW_RO, raw_equal_scalar); case CPLXSXP: EQUAL_ALL(Rcomplex, COMPLEX_RO, cpl_equal_scalar); case EXPRSXP: case VECSXP: EQUAL_ALL_BARRIER(list_equal_scalar); default: Rf_errorcall(R_NilValue, "Internal error: Unexpected type in `equal_object()`"); } } #undef EQUAL_ALL #undef EQUAL_ALL_BARRIER // [[ register() ]] SEXP vctrs_equal_object(SEXP x, SEXP y) { return Rf_ScalarLogical(equal_object(x, y)); } // TODO: Sort attributes by tag before comparison static inline bool vec_equal_attrib(SEXP x, SEXP y) { SEXP x_attrs = ATTRIB(x); SEXP y_attrs = ATTRIB(y); while (x_attrs != R_NilValue) { if (y_attrs == R_NilValue) { return false; } SEXP x_tag = TAG(x_attrs); SEXP y_tag = TAG(x_attrs); if (x_tag != y_tag) { return false; } if (!equal_object(CAR(x_attrs), CAR(y_attrs))) { return false; } x_attrs = CDR(x_attrs); y_attrs = CDR(y_attrs); } return true; } // [[ include("vctrs.h") ]] bool equal_names(SEXP x, SEXP y) { SEXP x_names = PROTECT(Rf_getAttrib(x, R_NamesSymbol)); SEXP y_names = PROTECT(Rf_getAttrib(y, R_NamesSymbol)); bool out = equal_object(x_names, y_names); UNPROTECT(2); return out; } // ----------------------------------------------------------------------------- static struct vctrs_df_rowwise_info vec_equal_col(SEXP x, SEXP y, bool na_equal, struct vctrs_df_rowwise_info info, R_len_t n_row); static struct vctrs_df_rowwise_info df_equal_impl(SEXP x, SEXP y, bool na_equal, struct vctrs_df_rowwise_info info, R_len_t n_row); static struct vctrs_df_rowwise_info init_rowwise_equal_info(R_len_t n_row) { struct vctrs_df_rowwise_info info; // Initialize to "equality" value // and only change if we learn that it differs info.out = PROTECT(Rf_allocVector(LGLSXP, n_row)); int* p_out = LOGICAL(info.out); for (R_len_t i = 0; i < n_row; ++i) { p_out[i] = 1; } // To begin with, no rows have a known comparison value info.row_known = PROTECT(Rf_allocVector(RAWSXP, n_row * sizeof(bool))); info.p_row_known = (bool*) RAW(info.row_known); memset(info.p_row_known, false, n_row * sizeof(bool)); info.remaining = n_row; UNPROTECT(2); return info; } static SEXP df_equal(SEXP x, SEXP y, bool na_equal, R_len_t n_row) { int nprot = 0; struct vctrs_df_rowwise_info info = init_rowwise_equal_info(n_row); PROTECT_DF_ROWWISE_INFO(&info, &nprot); info = df_equal_impl(x, y, na_equal, info, n_row); UNPROTECT(nprot); return info.out; } static struct vctrs_df_rowwise_info df_equal_impl(SEXP x, SEXP y, bool na_equal, struct vctrs_df_rowwise_info info, R_len_t n_row) { int n_col = Rf_length(x); if (n_col != Rf_length(y)) { Rf_errorcall(R_NilValue, "`x` and `y` must have the same number of columns"); } for (R_len_t i = 0; i < n_col; ++i) { SEXP x_col = VECTOR_ELT(x, i); SEXP y_col = VECTOR_ELT(y, i); info = vec_equal_col(x_col, y_col, na_equal, info, n_row); // If we know all comparison values, break if (info.remaining == 0) { break; } } return info; } // ----------------------------------------------------------------------------- #define EQUAL_COL(CTYPE, CONST_DEREF, SCALAR_EQUAL) \ do { \ int* p_out = LOGICAL(info.out); \ \ const CTYPE* p_x = CONST_DEREF(x); \ const CTYPE* p_y = CONST_DEREF(y); \ \ for (R_len_t i = 0; i < n_row; ++i, ++p_x, ++p_y) { \ if (info.p_row_known[i]) { \ continue; \ } \ \ int eq = SCALAR_EQUAL(p_x, p_y, na_equal); \ \ if (eq <= 0) { \ p_out[i] = eq; \ info.p_row_known[i] = true; \ --info.remaining; \ \ if (info.remaining == 0) { \ break; \ } \ } \ } \ \ return info; \ } \ while (0) #define EQUAL_COL_BARRIER(SCALAR_EQUAL) \ do { \ int* p_out = LOGICAL(info.out); \ \ for (R_len_t i = 0; i < n_row; ++i) { \ if (info.p_row_known[i]) { \ continue; \ } \ \ int eq = SCALAR_EQUAL(x, i, y, i, na_equal); \ \ if (eq <= 0) { \ p_out[i] = eq; \ info.p_row_known[i] = true; \ --info.remaining; \ \ if (info.remaining == 0) { \ break; \ } \ } \ } \ \ return info; \ } \ while (0) static struct vctrs_df_rowwise_info vec_equal_col(SEXP x, SEXP y, bool na_equal, struct vctrs_df_rowwise_info info, R_len_t n_row) { switch (vec_proxy_typeof(x)) { case vctrs_type_logical: EQUAL_COL(int, LOGICAL_RO, lgl_equal_scalar); case vctrs_type_integer: EQUAL_COL(int, INTEGER_RO, int_equal_scalar); case vctrs_type_double: EQUAL_COL(double, REAL_RO, dbl_equal_scalar); case vctrs_type_raw: EQUAL_COL(Rbyte, RAW_RO, raw_equal_scalar); case vctrs_type_complex: EQUAL_COL(Rcomplex, COMPLEX_RO, cpl_equal_scalar); case vctrs_type_character: EQUAL_COL(SEXP, STRING_PTR_RO, chr_equal_scalar); case vctrs_type_list: EQUAL_COL_BARRIER(list_equal_scalar); case vctrs_type_dataframe: return df_equal_impl(x, y, na_equal, info, n_row); case vctrs_type_scalar: Rf_errorcall(R_NilValue, "Can't compare scalars with `vctrs_equal()`"); default: Rf_error("Unimplemented type in `vctrs_equal()`"); } } #undef EQUAL_COL #undef EQUAL_COL_BARRIER // ----------------------------------------------------------------------------- static int lgl_equal_na_scalar(const int* x); static int int_equal_na_scalar(const int* x); static int dbl_equal_na_scalar(const double* x); static int cpl_equal_na_scalar(const Rcomplex* x); static int chr_equal_na_scalar(const SEXP* x); static int list_equal_na_scalar(SEXP x, R_len_t i); static int df_equal_na_scalar(SEXP x, R_len_t i); // If `x` is a data frame, it must have been recursively proxied // beforehand so we can safely use `TYPEOF(x)` int equal_na(SEXP x, R_len_t i) { switch (TYPEOF(x)) { case LGLSXP: return lgl_equal_na_scalar(LOGICAL(x) + i); case INTSXP: return int_equal_na_scalar(INTEGER(x) + i); case REALSXP: return dbl_equal_na_scalar(REAL(x) + i); case CPLXSXP: return cpl_equal_na_scalar(COMPLEX(x) + i); case STRSXP: return chr_equal_na_scalar(STRING_PTR(x) + i); default: break; } switch (vec_proxy_typeof(x)) { case vctrs_type_list: return list_equal_na_scalar(x, i); case vctrs_type_dataframe: return df_equal_na_scalar(x, i); default: break; } vctrs_stop_unsupported_type(vec_typeof(x), "equal_na()"); } #define EQUAL_NA(CTYPE, CONST_DEREF, SCALAR_EQUAL_NA) \ do { \ const CTYPE* xp = CONST_DEREF(x); \ \ for (R_len_t i = 0; i < n; ++i, ++xp) { \ p[i] = SCALAR_EQUAL_NA(xp); \ } \ } \ while (0) #define EQUAL_NA_BARRIER(SCALAR_EQUAL_NA) \ do { \ for (R_len_t i = 0; i < n; ++i) { \ p[i] = SCALAR_EQUAL_NA(x, i); \ } \ } \ while (0) // [[ register() ]] SEXP vctrs_equal_na(SEXP x) { R_len_t n = vec_size(x); SEXP out = PROTECT(Rf_allocVector(LGLSXP, n)); int32_t* p = LOGICAL(out); x = PROTECT(vec_proxy_equal(x)); enum vctrs_type type = vec_proxy_typeof(x); switch (type) { case vctrs_type_logical: EQUAL_NA(int, LOGICAL_RO, lgl_equal_na_scalar); break; case vctrs_type_integer: EQUAL_NA(int, INTEGER_RO, int_equal_na_scalar); break; case vctrs_type_double: EQUAL_NA(double, REAL_RO, dbl_equal_na_scalar); break; case vctrs_type_complex: EQUAL_NA(Rcomplex, COMPLEX_RO, cpl_equal_na_scalar); break; case vctrs_type_character: EQUAL_NA(SEXP, STRING_PTR_RO, chr_equal_na_scalar); break; case vctrs_type_list: EQUAL_NA_BARRIER(list_equal_na_scalar); break; case vctrs_type_dataframe: EQUAL_NA_BARRIER(df_equal_na_scalar); break; case vctrs_type_scalar: Rf_errorcall(R_NilValue, "Can't detect `NA` values in scalars with `vctrs_equal_na()`."); default: Rf_error("Unimplemented type in `vctrs_equal_na()`."); } UNPROTECT(2); return out; } #undef EQUAL_NA #undef EQUAL_NA_BARRIER static int lgl_equal_na_scalar(const int* x) { return *x == NA_LOGICAL; } static int int_equal_na_scalar(const int* x) { return *x == NA_INTEGER; } static int dbl_equal_na_scalar(const double* x) { // is.na(NaN) is TRUE // isnan() does not consistently return 1 and 0 on all platforms, // but R's ISNAN() does return ISNAN(*x); } static int cpl_equal_na_scalar(const Rcomplex* x) { return ISNAN(x->r) || ISNAN(x->i); } static int chr_equal_na_scalar(const SEXP* x) { return *x == NA_STRING; } static int list_equal_na_scalar(SEXP x, R_len_t i) { return Rf_isNull(VECTOR_ELT(x, i)); } static int df_equal_na_scalar(SEXP x, R_len_t i) { int n_col = Rf_length(x); for (int k = 0; k < n_col; ++k) { if (!equal_na(VECTOR_ELT(x, k), i)) { return false; } } return true; } vctrs/src/arg.h0000644000176200001440000000350513622451540013131 0ustar liggesusers#ifndef VCTRS_ARG_H #define VCTRS_ARG_H /** * Structure for argument tags * * Argument tags are used in error messages to provide information * about which elements of nested data structures (such as tibbles) * fail to match a given type. They are generated lazily by the `fill` * method in order to avoid any cost when there is no error. * * @member parent The previously active argument tag. * @member fill Takes a pointer to data, and a buffer to fill. If the * buffer is too small according to the `remaining` argument, * `fill()` must return a negative error value. */ struct vctrs_arg { struct vctrs_arg* parent; r_ssize_t (*fill)(void* data, char* buf, r_ssize_t remaining); void* data; }; // Simple wrapper around a string struct vctrs_arg new_wrapper_arg(struct vctrs_arg* parent, const char* arg); // Wrapper around a counter representing the current position of the // argument struct arg_data_counter { R_len_t* i; SEXP* names; R_len_t* names_i; }; struct vctrs_arg new_counter_arg(struct vctrs_arg* parent, struct arg_data_counter* data); struct arg_data_counter new_counter_arg_data(R_len_t* i, SEXP* names, R_len_t* names_i); // Wrapper around a string that should be prefixed with `$`, unless // that's the first argument of the chain struct arg_data_index { const char* arg; struct vctrs_arg* parent; }; struct vctrs_arg new_index_arg(struct vctrs_arg* parent, struct arg_data_index* data); struct arg_data_index new_index_arg_data(const char* arg, struct vctrs_arg* parent); // Materialise an argument tag as a CHARSXP. SEXP vctrs_arg(struct vctrs_arg* arg); #endif vctrs/src/dictionary.h0000644000176200001440000000266613622451540014534 0ustar liggesusers #define DICT_EMPTY -1 // The dictionary structure is a little peculiar since R has no notion of // a scalar, so the `key`s are indexes into vector `x`. This means we can // only store values from a single vector, but we can still lookup using // another vector, provided that they're of the same type (which is ensured // at the R-level). struct dictionary { SEXP vec; R_len_t* key; uint32_t* hash; uint32_t size; uint32_t used; }; typedef struct dictionary dictionary; /** * Initialise a dictionary * * - `dict_init()` creates a dictionary and precaches the hashes for * each element of `x`. * * - `dict_init_partial()` creates a dictionary with precached hashes * as well, but does not allocate an array of keys. This is useful * for finding a key in another dictionary with `dict_hash_with()`. */ void dict_init(dictionary* d, SEXP x); void dict_init_partial(dictionary* d, SEXP x); #define PROTECT_DICT(d, n) do { \ PROTECT((d)->vec); \ *(n) += 1; \ } while(0) /** * Find key hash for a vector element * * - `dict_hash_scalar()` returns the key hash for element `i`. * * - `dict_hash_with()` finds the hash for indexing into `d` with * element `i` of `x`. */ uint32_t dict_hash_scalar(dictionary* d, R_len_t i); uint32_t dict_hash_with(dictionary* d, dictionary* x, R_len_t i); void dict_put(dictionary* d, uint32_t k, R_len_t i); vctrs/src/altrep-rle.c0000644000176200001440000001043113622451540014416 0ustar liggesusers#include "vctrs.h" #include "altrep-rle.h" #include "altrep.h" #if (R_VERSION < R_Version(3, 5, 0)) #include void vctrs_init_altrep_rle(DllInfo* dll) { } SEXP altrep_rle_Make(SEXP input) { Rf_error("Need R 3.5+ for Altrep support."); return R_NilValue; } #else SEXP altrep_rle_Make(SEXP input) { SEXP res = R_new_altrep(altrep_rle_class, input, R_NilValue); MARK_NOT_MUTABLE(res); return res; } // ALTREP methods ------------------- // The length of the object inline R_xlen_t altrep_rle_Length(SEXP vec) { SEXP data2 = R_altrep_data2(vec); if (data2 != R_NilValue) { return Rf_xlength(data2); } R_xlen_t sz = 0; SEXP rle = R_altrep_data1(vec); int* rle_p = INTEGER(rle); for (R_xlen_t i = 0; i < Rf_xlength(rle); ++i) { sz += rle_p[i]; } return sz; } // What gets printed when .Internal(inspect()) is used Rboolean altrep_rle_Inspect( SEXP x, int pre, int deep, int pvec, void (*inspect_subtree)(SEXP, int, int, int)) { Rprintf( "vroom_rle (len=%d, materialized=%s)\n", altrep_rle_Length(x), R_altrep_data2(x) != R_NilValue ? "T" : "F"); return TRUE; } // ALTSTRING methods ----------------- // the element at the index `i` SEXP altrep_rle_string_Elt(SEXP vec, R_xlen_t i) { SEXP data2 = R_altrep_data2(vec); if (data2 != R_NilValue) { return STRING_ELT(data2, i); } SEXP rle = R_altrep_data1(vec); int* rle_p = INTEGER(rle); SEXP nms = Rf_getAttrib(rle, Rf_install("names")); R_xlen_t idx = 0; while (i >= 0 && idx < Rf_xlength(rle)) { i -= rle_p[idx++]; } return STRING_ELT(nms, idx - 1); } R_xlen_t find_rle_index(int* rle_data, R_xlen_t i, R_xlen_t size) { R_xlen_t idx = 0; while (i >= 0 && idx < size) { i -= rle_data[idx++]; } return idx - 1; } // This is a simple implementation, a more complex one would produce a // altrep_rle object as well SEXP altrep_rle_Extract_subset(SEXP x, SEXP indx, SEXP call) { SEXP data2 = R_altrep_data2(x); // If the vector is already materialized, just fall back to the default // implementation if (data2 != R_NilValue) { return NULL; } SEXP data1 = R_altrep_data1(x); int* index_data = INTEGER(indx); R_xlen_t index_n = Rf_length(indx); int* rle_data = INTEGER(data1); R_xlen_t rle_n = Rf_length(data1); SEXP nms = PROTECT(Rf_getAttrib(data1, Rf_install("names"))); SEXP out = PROTECT(Rf_allocVector(STRSXP, index_n)); for (R_len_t i = 0; i < index_n; ++i) { int index_elt = index_data[i]; if (index_elt == NA_INTEGER) { SET_STRING_ELT(out, i, NA_STRING); continue; } --index_elt; R_xlen_t rle_idx = find_rle_index(rle_data, index_elt, rle_n); SET_STRING_ELT(out, i, STRING_ELT(nms, rle_idx)); } UNPROTECT(2); return out; } // --- Altvec SEXP altrep_rle_string_Materialize(SEXP vec) { SEXP data2 = R_altrep_data2(vec); if (data2 != R_NilValue) { return data2; } R_xlen_t sz = altrep_rle_Length(vec); SEXP rle = R_altrep_data1(vec); int* rle_p = INTEGER(rle); SEXP out = PROTECT(Rf_allocVector(STRSXP, sz)); R_xlen_t idx = 0; SEXP nms = Rf_getAttrib(rle, Rf_install("names")); for (R_xlen_t i = 0; i < Rf_xlength(rle); ++i) { for (R_xlen_t j = 0; j < rle_p[i]; ++j) { SET_STRING_ELT(out, idx++, STRING_ELT(nms, i)); } } UNPROTECT(1); R_set_altrep_data2(vec, out); return out; } void* altrep_rle_Dataptr(SEXP vec, Rboolean writeable) { return STDVEC_DATAPTR(altrep_rle_string_Materialize(vec)); } const void* altrep_rle_Dataptr_or_null(SEXP vec) { SEXP data2 = R_altrep_data2(vec); if (data2 == R_NilValue) return NULL; return STDVEC_DATAPTR(data2); } // -------- initialize the altrep class with the methods above void vctrs_init_altrep_rle(DllInfo* dll) { altrep_rle_class = R_make_altstring_class("altrep_rle", "vctrs", dll); // altrep R_set_altrep_Length_method(altrep_rle_class, altrep_rle_Length); R_set_altrep_Inspect_method(altrep_rle_class, altrep_rle_Inspect); // altvec R_set_altvec_Dataptr_method(altrep_rle_class, altrep_rle_Dataptr); R_set_altvec_Dataptr_or_null_method(altrep_rle_class, altrep_rle_Dataptr_or_null); R_set_altvec_Extract_subset_method(altrep_rle_class, altrep_rle_Extract_subset); // altstring R_set_altstring_Elt_method(altrep_rle_class, altrep_rle_string_Elt); } #endif vctrs/src/type-factor.c0000644000176200001440000002222413623203263014605 0ustar liggesusers#include "vctrs.h" #include "utils.h" static SEXP levels_union(SEXP x, SEXP y); // [[ include("vctrs.h") ]] SEXP fct_ptype2(SEXP x, SEXP y, struct vctrs_arg* x_arg, struct vctrs_arg* y_arg) { SEXP x_levels = Rf_getAttrib(x, R_LevelsSymbol); SEXP y_levels = Rf_getAttrib(y, R_LevelsSymbol); if (TYPEOF(x_levels) != STRSXP) { stop_corrupt_factor_levels(x, x_arg); } if (TYPEOF(y_levels) != STRSXP) { stop_corrupt_factor_levels(y, y_arg); } // Quick early exit for identical levels pointing to the same SEXP if (x_levels == y_levels) { return new_empty_factor(x_levels); } SEXP levels = PROTECT(levels_union(x_levels, y_levels)); SEXP out = new_empty_factor(levels); UNPROTECT(1); return out; } // [[ include("vctrs.h") ]] SEXP ord_ptype2(SEXP x, SEXP y, struct vctrs_arg* x_arg, struct vctrs_arg* y_arg) { SEXP x_levels = Rf_getAttrib(x, R_LevelsSymbol); SEXP y_levels = Rf_getAttrib(y, R_LevelsSymbol); if (TYPEOF(x_levels) != STRSXP) { stop_corrupt_ordered_levels(x, x_arg); } if (TYPEOF(y_levels) != STRSXP) { stop_corrupt_ordered_levels(y, y_arg); } // Quick early exit for identical levels pointing to the same SEXP if (x_levels == y_levels) { return new_empty_ordered(x_levels); } SEXP levels = PROTECT(levels_union(x_levels, y_levels)); SEXP out = new_empty_ordered(levels); UNPROTECT(1); return out; } static SEXP levels_union(SEXP x, SEXP y) { SEXP args = PROTECT(Rf_allocVector(VECSXP, 2)); SET_VECTOR_ELT(args, 0, x); SET_VECTOR_ELT(args, 1, y); const struct name_repair_opts name_repair_opts = { .type = name_repair_none, .fn = R_NilValue }; // Combine with known ptype // No name repair because this is just combining factor levels SEXP xy = PROTECT(vec_c( args, vctrs_shared_empty_chr, R_NilValue, &name_repair_opts )); SEXP out = vec_unique(xy); UNPROTECT(2); return out; } // ----------------------------------------------------------------------------- static void init_factor(SEXP x, SEXP levels); static void init_ordered(SEXP x, SEXP levels); // [[ include("vctrs.h") ]] SEXP fct_as_character(SEXP x, struct vctrs_arg* x_arg) { SEXP levels = PROTECT(Rf_getAttrib(x, R_LevelsSymbol)); if (TYPEOF(levels) != STRSXP) { stop_corrupt_factor_levels(x, x_arg); } UNPROTECT(1); return Rf_asCharacterFactor(x); } // [[ include("vctrs.h") ]] SEXP ord_as_character(SEXP x, struct vctrs_arg* x_arg) { return fct_as_character(x, x_arg); } static SEXP chr_as_factor_from_self(SEXP x, bool ordered); static SEXP chr_as_factor_impl(SEXP x, SEXP levels, bool* lossy, bool ordered); // [[ include("vctrs.h") ]] SEXP chr_as_factor(SEXP x, SEXP to, bool* lossy, struct vctrs_arg* to_arg) { SEXP levels = PROTECT(Rf_getAttrib(to, R_LevelsSymbol)); if (TYPEOF(levels) != STRSXP) { stop_corrupt_factor_levels(to, to_arg); } SEXP out; // When `to` has no levels, it is treated as a template and the // levels come from `x` if (vec_size(levels) == 0) { out = chr_as_factor_from_self(x, false); } else { out = chr_as_factor_impl(x, levels, lossy, false); } UNPROTECT(1); return out; } // [[ include("vctrs.h") ]] SEXP chr_as_ordered(SEXP x, SEXP to, bool* lossy, struct vctrs_arg* to_arg) { SEXP levels = PROTECT(Rf_getAttrib(to, R_LevelsSymbol)); if (TYPEOF(levels) != STRSXP) { stop_corrupt_ordered_levels(to, to_arg); } SEXP out; // When `to` has no levels, it is treated as a template and the // levels come from `x` if (vec_size(levels) == 0) { out = chr_as_factor_from_self(x, true); } else { out = chr_as_factor_impl(x, levels, lossy, true); } UNPROTECT(1); return out; } static SEXP chr_as_factor_impl(SEXP x, SEXP levels, bool* lossy, bool ordered) { SEXP out = PROTECT(vec_match(x, levels)); const int* p_out = INTEGER(out); R_len_t size = vec_size(x); const SEXP* p_x = STRING_PTR_RO(x); // Detect lossy no-matches, but allow `NA` values from `x` for (R_len_t i = 0; i < size; ++i) { if (p_out[i] == NA_INTEGER && p_x[i] != NA_STRING) { *lossy = true; UNPROTECT(1); return R_NilValue; } } if (ordered) { init_ordered(out, levels); } else { init_factor(out, levels); } UNPROTECT(1); return out; } static SEXP remove_na_levels(SEXP levels); // Factor levels are added in order of appearance. // `NA` values in `x` are not considered factor levels. static SEXP chr_as_factor_from_self(SEXP x, bool ordered) { SEXP levels = PROTECT(vec_unique(x)); levels = PROTECT(remove_na_levels(levels)); // `NA` values in `x` correctly become `NA` values in the result SEXP out = PROTECT(vec_match(x, levels)); if (ordered) { init_ordered(out, levels); } else { init_factor(out, levels); } UNPROTECT(3); return out; } static SEXP remove_na_levels(SEXP levels) { R_len_t size = vec_size(levels); const SEXP* p_levels = STRING_PTR_RO(levels); // There might only ever be 1 `NA` level. // Remove it if it exists. for (R_len_t i = 0; i < size; ++i) { if (p_levels[i] == NA_STRING) { int na_loc = (i + 1) * -1; SEXP na_loc_obj = PROTECT(r_int(na_loc)); SEXP out = vec_slice(levels, na_loc_obj); UNPROTECT(1); return out; } } return levels; } static SEXP fct_as_factor_impl(SEXP x, SEXP x_levels, SEXP to_levels, bool* lossy, bool ordered); // [[ include("vctrs.h") ]] SEXP fct_as_factor(SEXP x, SEXP to, bool* lossy, struct vctrs_arg* x_arg, struct vctrs_arg* to_arg) { SEXP x_levels = PROTECT(Rf_getAttrib(x, R_LevelsSymbol)); SEXP to_levels = PROTECT(Rf_getAttrib(to, R_LevelsSymbol)); if (TYPEOF(x_levels) != STRSXP) { stop_corrupt_factor_levels(x, x_arg); } if (TYPEOF(to_levels) != STRSXP) { stop_corrupt_factor_levels(to, to_arg); } SEXP out = fct_as_factor_impl(x, x_levels, to_levels, lossy, false); UNPROTECT(2); return out; } // [[ include("vctrs.h") ]] SEXP ord_as_ordered(SEXP x, SEXP to, bool* lossy, struct vctrs_arg* x_arg, struct vctrs_arg* to_arg) { SEXP x_levels = PROTECT(Rf_getAttrib(x, R_LevelsSymbol)); SEXP to_levels = PROTECT(Rf_getAttrib(to, R_LevelsSymbol)); if (TYPEOF(x_levels) != STRSXP) { stop_corrupt_ordered_levels(x, x_arg); } if (TYPEOF(to_levels) != STRSXP) { stop_corrupt_ordered_levels(to, to_arg); } SEXP out = fct_as_factor_impl(x, x_levels, to_levels, lossy, true); UNPROTECT(2); return out; } static SEXP fct_as_factor_impl(SEXP x, SEXP x_levels, SEXP to_levels, bool* lossy, bool ordered) { // Early exit if levels are identical if (x_levels == to_levels) { return x; } R_len_t x_levels_size = vec_size(x_levels); R_len_t to_levels_size = vec_size(to_levels); // Early exit if `to` has no levels. In this case it is being used as // a template if (to_levels_size == 0) { return x; } // Always lossy if there are more levels in `x` than in `to` if (x_levels_size > to_levels_size) { *lossy = true; return R_NilValue; } R_len_t x_size = vec_size(x); const SEXP* p_x_levels = STRING_PTR_RO(x_levels); const SEXP* p_to_levels = STRING_PTR_RO(to_levels); bool is_contiguous_subset = true; for (R_len_t i = 0; i < x_levels_size; ++i) { if (p_x_levels[i] != p_to_levels[i]) { is_contiguous_subset = false; break; } } // No recoding required if contiguous subset. // Duplicate, strip non-factor attributes, and re-initialize with new levels. // Using `r_maybe_duplicate()` avoids an immediate copy using ALTREP wrappers. if (is_contiguous_subset) { SEXP out = PROTECT(r_maybe_duplicate(x)); SET_ATTRIB(out, R_NilValue); if (ordered) { init_ordered(out, to_levels); } else { init_factor(out, to_levels); } UNPROTECT(1); return out; } const int* p_x = INTEGER_RO(x); SEXP out = PROTECT(Rf_allocVector(INTSXP, x_size)); int* p_out = INTEGER(out); if (ordered) { init_ordered(out, to_levels); } else { init_factor(out, to_levels); } SEXP recode = PROTECT(vec_match(x_levels, to_levels)); const int* p_recode = INTEGER_RO(recode); // Detect if there are any levels in `x` that aren't in `to` for (R_len_t i = 0; i < x_levels_size; ++i) { if (p_recode[i] == NA_INTEGER) { *lossy = true; UNPROTECT(2); return R_NilValue; } } // Recode `x` int values into `to` level ordering for (R_len_t i = 0; i < x_size; ++i) { const int elt = p_x[i]; if (elt == NA_INTEGER) { p_out[i] = NA_INTEGER; continue; } p_out[i] = p_recode[elt - 1]; } UNPROTECT(2); return out; } static void init_factor(SEXP x, SEXP levels) { if (TYPEOF(x) != INTSXP) { Rf_errorcall(R_NilValue, "Internal error: Only integers can be made into factors"); } Rf_setAttrib(x, R_LevelsSymbol, levels); Rf_setAttrib(x, R_ClassSymbol, classes_factor); } static void init_ordered(SEXP x, SEXP levels) { if (TYPEOF(x) != INTSXP) { Rf_errorcall(R_NilValue, "Internal error: Only integers can be made into ordered factors"); } Rf_setAttrib(x, R_LevelsSymbol, levels); Rf_setAttrib(x, R_ClassSymbol, classes_ordered); } vctrs/src/type-tibble.c0000644000176200001440000000044513623013722014570 0ustar liggesusers#include "vctrs.h" #include "utils.h" // [[ include("vctrs.h") ]] SEXP tibble_ptype2(SEXP x, SEXP y, struct vctrs_arg* x_arg, struct vctrs_arg* y_arg) { SEXP out = PROTECT(df_ptype2(x, y, x_arg, y_arg)); Rf_setAttrib(out, R_ClassSymbol, classes_tibble); UNPROTECT(1); return out; } vctrs/src/altrep-rle.h0000644000176200001440000000123213623045157014426 0ustar liggesusers#ifndef ALTREP_RLE_H #define ALTREP_RLE_H #include "altrep.h" #if (R_VERSION >= R_Version(3, 5, 0)) SEXP altrep_rle_Make(SEXP input); R_xlen_t altrep_rle_Length(SEXP vec); Rboolean altrep_rle_Inspect( SEXP x, int pre, int deep, int pvec, void (*inspect_subtree)(SEXP, int, int, int)); SEXP altrep_rle_string_Elt(SEXP vec, R_xlen_t i); SEXP altrep_rle_Extract_subset(SEXP x, SEXP indx, SEXP call); SEXP altrep_rle_string_Materialize(SEXP vec); void* altrep_rle_Dataptr(SEXP vec, Rboolean writeable); const void* altrep_rle_Dataptr_or_null(SEXP vec); void vctrs_init_altrep_rle(DllInfo* dll); R_altrep_class_t altrep_rle_class; #endif #endif vctrs/src/subscript-loc.h0000644000176200001440000000350513622451540015151 0ustar liggesusers#ifndef VCTRS_SUBSCRIPT_LOC_H #define VCTRS_SUBSCRIPT_LOC_H #include "utils.h" enum subscript_action { SUBSCRIPT_ACTION_DEFAULT, SUBSCRIPT_ACTION_SUBSET, SUBSCRIPT_ACTION_EXTRACT, SUBSCRIPT_ACTION_ASSIGN, SUBSCRIPT_ACTION_RENAME, SUBSCRIPT_ACTION_REMOVE, SUBSCRIPT_ACTION_NEGATE }; enum subscript_missing { SUBSCRIPT_MISSING_PROPAGATE, SUBSCRIPT_MISSING_ERROR }; enum num_as_location_loc_negative { LOC_NEGATIVE_INVERT, LOC_NEGATIVE_ERROR, LOC_NEGATIVE_IGNORE }; enum num_as_location_loc_oob { LOC_OOB_EXTEND, LOC_OOB_ERROR }; struct vec_as_location_opts { enum subscript_action action; enum num_as_location_loc_negative loc_negative; enum num_as_location_loc_oob loc_oob; enum subscript_missing missing; SEXP subscript_arg; }; extern struct vec_as_location_opts vec_as_location_default_opts_obj; extern struct vec_as_location_opts vec_as_location_default_assign_opts_obj; static const struct vec_as_location_opts* const vec_as_location_default_opts = &vec_as_location_default_opts_obj; static const struct vec_as_location_opts* const vec_as_location_default_assign_opts = &vec_as_location_default_assign_opts_obj; SEXP vec_as_location(SEXP i, R_len_t n, SEXP names); SEXP vec_as_location_opts(SEXP i, R_len_t n, SEXP names, const struct vec_as_location_opts* opts); static inline SEXP get_opts_action(const struct vec_as_location_opts* opts) { switch (opts->action) { case SUBSCRIPT_ACTION_DEFAULT: return R_NilValue; case SUBSCRIPT_ACTION_SUBSET: return chrs_subset; case SUBSCRIPT_ACTION_EXTRACT: return chrs_extract; case SUBSCRIPT_ACTION_ASSIGN: return chrs_assign; case SUBSCRIPT_ACTION_RENAME: return chrs_rename; case SUBSCRIPT_ACTION_REMOVE: return chrs_remove; case SUBSCRIPT_ACTION_NEGATE: return chrs_negate; } never_reached("get_opts_action"); } #endif vctrs/src/arg.c0000644000176200001440000001164013622451540013123 0ustar liggesusers#include "vctrs.h" #include "utils.h" // Materialising argument tags ------------------------------------------ #define DEFAULT_ARG_BUF_SIZE 100 static int fill_arg_buffer(struct vctrs_arg* arg, char* buf, r_ssize_t cur_size, r_ssize_t tot_size); /** * This takes a `struct vctrs_arg{}` linked list and calls the * recursive function `fill_arg_buffer()`. It allocates a buffer in a * RAWSXP of size 100, which is grown by a factor of 1.5 each time the * `fill()` methods return a negative value. Returns a character * vector of size 1 containing the materialised argument tag. */ SEXP vctrs_arg(struct vctrs_arg* arg) { r_ssize_t next_size = DEFAULT_ARG_BUF_SIZE; r_ssize_t size; SEXP buf_holder = PROTECT(R_NilValue); char* buf; do { size = next_size; UNPROTECT(1); buf_holder = PROTECT(Rf_allocVector(RAWSXP, size)); buf = (char*) RAW(buf_holder); // Reallocate a larger buffer at the next iteration if the current // buffer turns out too small next_size *= 1.5; } while (fill_arg_buffer(arg, buf, 0, size) < 0); SEXP out = Rf_mkString(buf); UNPROTECT(1); return out; } /** * Takes a `struct vctrs_arg{}` linked list and a buffer and calls the * `fill()` method on each of those, recursively. Unless an error * occurred, it returns the current size written to the buffer so we * can track the remaining memory available in the buffer after * recursion. */ static int fill_arg_buffer(struct vctrs_arg* arg, char* buf, r_ssize_t cur_size, r_ssize_t tot_size) { if (arg->parent) { cur_size = fill_arg_buffer(arg->parent, buf, cur_size, tot_size); if (cur_size < 0) { return cur_size; } } r_ssize_t written = arg->fill(arg->data, buf + cur_size, tot_size - cur_size); if (written < 0) { return written; } else { return cur_size + written; } } // Objects ------------------------------------------------------------- // Simple wrapper around a `const char*` argument tag static r_ssize_t wrapper_arg_fill(void* data, char* buf, r_ssize_t remaining); struct vctrs_arg new_wrapper_arg(struct vctrs_arg* parent, const char* arg) { return (struct vctrs_arg) { .parent = parent, .fill = &wrapper_arg_fill, .data = (void*) arg }; } static r_ssize_t wrapper_arg_fill(void* data, char* buf, r_ssize_t remaining) { const char* src = (const char*) data; size_t len = strlen(src); if (len >= remaining) { return -1; } memcpy(buf, src, len); buf[len] = '\0'; return len; } // Wrapper around a counter representing the current position of the // argument static r_ssize_t counter_arg_fill(void* data, char* buf, r_ssize_t remaining); struct vctrs_arg new_counter_arg(struct vctrs_arg* parent, struct arg_data_counter* data) { return (struct vctrs_arg) { .parent = parent, .fill = &counter_arg_fill, .data = (void*) data }; } struct arg_data_counter new_counter_arg_data(R_len_t* i, SEXP* names, R_len_t* names_i) { return (struct arg_data_counter) { .i = i, .names = names, .names_i = names_i }; } static r_ssize_t counter_arg_fill(void* data_, char* buf, r_ssize_t remaining) { struct arg_data_counter* data = (struct arg_data_counter*) data_; R_len_t i = *data->i; SEXP names = *data->names; R_len_t names_i = *data->names_i; int len; if (r_has_name_at(names, names_i)) { // FIXME: Check for syntactic names len = snprintf(buf, remaining, "%s", r_chr_get_c_string(names, names_i)); } else { len = snprintf(buf, remaining, "..%d", i + 1); } if (len >= remaining) { return -1; } else { return len; } } // Indexing tag that materialises as `$rhs`. The `$` is only written when // the arg has a parent. static r_ssize_t index_arg_fill(void* data, char* buf, r_ssize_t remaining); static bool is_empty_arg(struct vctrs_arg* arg); struct vctrs_arg new_index_arg(struct vctrs_arg* parent, struct arg_data_index* data) { return (struct vctrs_arg) { .parent = parent, .fill = &index_arg_fill, .data = (void*) data }; } struct arg_data_index new_index_arg_data(const char* arg, struct vctrs_arg* parent) { return (struct arg_data_index) { .arg = arg, .parent = parent }; } static r_ssize_t index_arg_fill(void* data_, char* buf, r_ssize_t remaining) { struct arg_data_index* data = (struct arg_data_index*) data_; const char* src = data->arg; size_t len = strlen(src); bool child = is_empty_arg(data->parent); if (child) { ++len; } if (len >= remaining) { return -1; } if (child) { *buf++ = '$'; } memcpy(buf, src, len); buf[len] = '\0'; return len; } static bool is_empty_arg(struct vctrs_arg* arg) { char tmp[1]; return arg->fill(arg->data, tmp, 1) != 0;; } vctrs/src/subscript-loc.c0000644000176200001440000003672213622451540015153 0ustar liggesusers#include "vctrs.h" #include "utils.h" #include "subscript-loc.h" static SEXP int_invert_location(SEXP subscript, R_len_t n, const struct vec_as_location_opts* opts); static SEXP int_filter_zero(SEXP subscript, R_len_t n_zero); static void int_check_consecutive(SEXP subscript, R_len_t n, const struct vec_as_location_opts* opts); static void stop_subscript_missing(SEXP i); static void stop_subscript_oob_location(SEXP i, R_len_t size, const struct vec_as_location_opts* opts); static void stop_subscript_oob_name(SEXP i, SEXP names, const struct vec_as_location_opts* opts); static void stop_location_negative(SEXP i, const struct vec_as_location_opts* opts); static void stop_indicator_size(SEXP i, SEXP n, const struct vec_as_location_opts* opts); static void stop_location_negative_missing(SEXP i, const struct vec_as_location_opts* opts); static void stop_location_negative_positive(SEXP i, const struct vec_as_location_opts* opts); static void stop_location_oob_non_consecutive(SEXP i, R_len_t size, const struct vec_as_location_opts* opts); static SEXP int_as_location(SEXP subscript, R_len_t n, const struct vec_as_location_opts* opts) { const int* data = INTEGER_RO(subscript); R_len_t loc_n = Rf_length(subscript); // Zeros need to be filtered out from the subscript vector. // `int_invert_location()` filters them out for negative indices, but // positive indices need to go through and `int_filter_zero()`. R_len_t n_zero = 0; bool extended = false; for (R_len_t i = 0; i < loc_n; ++i, ++data) { int elt = *data; if (elt == NA_INTEGER) { if (opts->missing == SUBSCRIPT_MISSING_ERROR) { stop_subscript_missing(subscript); } } else { if (elt < 0) { switch (opts->loc_negative) { case LOC_NEGATIVE_INVERT: return int_invert_location(subscript, n, opts); case LOC_NEGATIVE_ERROR: stop_location_negative(subscript, opts); case LOC_NEGATIVE_IGNORE: break; } } if (elt == 0) { ++n_zero; } else if (abs(elt) > n) { if (opts->loc_oob == LOC_OOB_ERROR) { stop_subscript_oob_location(subscript, n, opts); } extended = true; } } } if (n_zero) { subscript = int_filter_zero(subscript, n_zero); } PROTECT(subscript); if (extended) { int_check_consecutive(subscript, n, opts); } UNPROTECT(1); return subscript; } static SEXP lgl_as_location(SEXP subscript, R_len_t n, const struct vec_as_location_opts* opts); static SEXP int_invert_location(SEXP subscript, R_len_t n, const struct vec_as_location_opts* opts) { const int* data = INTEGER_RO(subscript); R_len_t loc_n = Rf_length(subscript); SEXP sel = PROTECT(Rf_allocVector(LGLSXP, n)); r_lgl_fill(sel, 1, n); int* sel_data = LOGICAL(sel); for (R_len_t i = 0; i < loc_n; ++i, ++data) { int j = *data; if (j == NA_INTEGER) { stop_location_negative_missing(subscript, opts); } if (j >= 0) { if (j == 0) { continue; } else { stop_location_negative_positive(subscript, opts); } } j = -j; if (j > n) { struct vec_as_location_opts updated_opts = *opts; updated_opts.action = SUBSCRIPT_ACTION_NEGATE; stop_subscript_oob_location(subscript, n, &updated_opts); } sel_data[j - 1] = 0; } SEXP out = lgl_as_location(sel, n, opts); UNPROTECT(1); return out; } static SEXP int_filter_zero(SEXP subscript, R_len_t n_zero) { R_len_t loc_n = vec_size(subscript); const int* data = INTEGER_RO(subscript); SEXP out = PROTECT(Rf_allocVector(INTSXP, loc_n - n_zero)); int* out_data = INTEGER(out); for (R_len_t i = 0; i < loc_n; ++i, ++data) { int elt = *data; if (elt != 0) { *out_data = elt; ++out_data; } } UNPROTECT(1); return out; } // From compare.c int qsort_icmp(const void* x, const void* y); static void int_check_consecutive(SEXP subscript, R_len_t n, const struct vec_as_location_opts* opts) { SEXP sorted = PROTECT(Rf_duplicate(subscript)); int* p_sorted = INTEGER(sorted); R_len_t n_subscript = Rf_length(sorted); R_len_t n_missing = 0; qsort(p_sorted, n_subscript, sizeof(int), &qsort_icmp); for (R_len_t i = 0; i < n_subscript; ++i) { int elt = p_sorted[i]; // All missing values are sorted to the beginning if (elt == NA_INTEGER) { ++n_missing; continue; } --elt; if (elt < n) { continue; } if (elt != (i - n_missing) && elt != n) { stop_location_oob_non_consecutive(subscript, n, opts); } } UNPROTECT(1); } static SEXP dbl_as_location(SEXP subscript, R_len_t n, const struct vec_as_location_opts* opts) { subscript = PROTECT(vec_cast(subscript, vctrs_shared_empty_int, args_empty, args_empty)); subscript = int_as_location(subscript, n, opts); UNPROTECT(1); return subscript; } static SEXP lgl_as_location(SEXP subscript, R_len_t n, const struct vec_as_location_opts* opts) { R_len_t subscript_n = Rf_length(subscript); if (subscript_n == n) { SEXP out = PROTECT(r_lgl_which(subscript, true)); SEXP nms = PROTECT(r_names(subscript)); if (nms != R_NilValue) { nms = PROTECT(vec_slice(nms, out)); r_poke_names(out, nms); UNPROTECT(1); } UNPROTECT(2); return out; } /* A single `TRUE` or `FALSE` index is recycled_nms to the full vector * size. This means `TRUE` is synonym for missing index (subscript.e. no * subsetting) and `FALSE` is synonym for empty index. * * We could return the missing argument as sentinel to avoid * materialising the index vector for the `TRUE` case but this would * make `vec_as_location()` an option type just to optimise a rather * uncommon case. */ if (subscript_n == 1) { int elt = LOGICAL(subscript)[0]; SEXP out; if (elt == NA_LOGICAL) { out = PROTECT(Rf_allocVector(INTSXP, n)); r_int_fill(out, NA_INTEGER, n); } else if (elt) { out = PROTECT(Rf_allocVector(INTSXP, n)); r_int_fill_seq(out, 1, n); } else { return vctrs_shared_empty_int; } SEXP nms = PROTECT(r_names(subscript)); if (nms != R_NilValue) { SEXP recycled_nms = PROTECT(Rf_allocVector(STRSXP, n)); r_chr_fill(recycled_nms, r_chr_get(nms, 0), n); r_poke_names(out, recycled_nms); UNPROTECT(1); } UNPROTECT(2); return out; } SEXP n_obj = PROTECT(Rf_ScalarInteger(n)); stop_indicator_size(subscript, n_obj, opts); never_reached("lgl_as_location"); } static SEXP chr_as_location(SEXP subscript, SEXP names, const struct vec_as_location_opts* opts) { if (names == R_NilValue) { Rf_errorcall(R_NilValue, "Can't use character names to index an unnamed vector."); } if (TYPEOF(names) != STRSXP) { Rf_errorcall(R_NilValue, "`names` must be a character vector."); } SEXP matched = PROTECT(Rf_match(names, subscript, NA_INTEGER)); R_len_t n = Rf_length(matched); const int* p = INTEGER_RO(matched); const SEXP* ip = STRING_PTR_RO(subscript); for (R_len_t k = 0; k < n; ++k) { if (p[k] == NA_INTEGER && ip[k] != NA_STRING) { stop_subscript_oob_name(subscript, names, opts); } } r_poke_names(matched, PROTECT(r_names(subscript))); UNPROTECT(1); UNPROTECT(1); return matched; } SEXP vec_as_location(SEXP subscript, R_len_t n, SEXP names) { return vec_as_location_opts(subscript, n, names, vec_as_location_default_opts); } SEXP vec_as_location_opts(SEXP subscript, R_len_t n, SEXP names, const struct vec_as_location_opts* opts) { if (vec_dim_n(subscript) != 1) { Rf_errorcall(R_NilValue, "`i` must have one dimension, not %d.", vec_dim_n(subscript)); } switch (TYPEOF(subscript)) { case NILSXP: return vctrs_shared_empty_int; case INTSXP: return int_as_location(subscript, n, opts); case REALSXP: return dbl_as_location(subscript, n, opts); case LGLSXP: return lgl_as_location(subscript, n, opts); case STRSXP: return chr_as_location(subscript, names, opts); default: Rf_errorcall(R_NilValue, "`i` must be an integer, character, or logical vector, not a %s.", Rf_type2char(TYPEOF(subscript))); } } static void stop_subscript_arg_missing() { Rf_errorcall(R_NilValue, "`missing` must be one of \"propagate\" or \"error\"."); } static void stop_bad_negative() { Rf_errorcall(R_NilValue, "`negative` must be one of \"invert\", \"error\", or \"ignore\"."); } static void stop_bad_oob() { Rf_errorcall(R_NilValue, "`oob` must be one of \"error\" or \"extend\"."); } static enum subscript_missing parse_subscript_arg_missing(SEXP x) { if (TYPEOF(x) != STRSXP || Rf_length(x) == 0) { stop_subscript_arg_missing(); } const char* str = CHAR(STRING_ELT(x, 0)); if (!strcmp(str, "propagate")) return SUBSCRIPT_MISSING_PROPAGATE; if (!strcmp(str, "error")) return SUBSCRIPT_MISSING_ERROR; stop_subscript_arg_missing(); never_reached("stop_subscript_arg_missing"); } static enum num_as_location_loc_negative parse_loc_negative(SEXP x) { if (TYPEOF(x) != STRSXP || Rf_length(x) == 0) { stop_bad_negative(); } const char* str = CHAR(STRING_ELT(x, 0)); if (!strcmp(str, "invert")) return LOC_NEGATIVE_INVERT; if (!strcmp(str, "error")) return LOC_NEGATIVE_ERROR; if (!strcmp(str, "ignore")) return LOC_NEGATIVE_IGNORE; stop_bad_negative(); never_reached("stop_bad_negative"); } static enum num_as_location_loc_oob parse_loc_oob(SEXP x) { if (TYPEOF(x) != STRSXP || Rf_length(x) == 0) { stop_bad_oob(); } const char* str = CHAR(STRING_ELT(x, 0)); if (!strcmp(str, "error")) return LOC_OOB_ERROR; if (!strcmp(str, "extend")) return LOC_OOB_EXTEND; stop_bad_oob(); never_reached("stop_bad_oob"); } SEXP vctrs_as_location(SEXP subscript, SEXP n_, SEXP names, SEXP loc_negative, SEXP loc_oob, SEXP missing, SEXP arg) { R_len_t n = 0; if (n_ == R_NilValue && TYPEOF(subscript) == STRSXP) { n = Rf_length(subscript); } else { if (OBJECT(n_) || TYPEOF(n_) != INTSXP) { n_ = vec_coercible_cast(n_, vctrs_shared_empty_int, args_empty, args_empty); } PROTECT(n_); if (Rf_length(n_) != 1) { Rf_error("Internal error: `n` must be a scalar number"); } n = r_int_get(n_, 0); UNPROTECT(1); } struct vec_as_location_opts opts = { .action = SUBSCRIPT_ACTION_DEFAULT, .missing = parse_subscript_arg_missing(missing), .loc_negative = parse_loc_negative(loc_negative), .loc_oob = parse_loc_oob(loc_oob), .subscript_arg = arg }; return vec_as_location_opts(subscript, n, names, &opts); } static void stop_subscript_missing(SEXP i) { vctrs_eval_mask1(Rf_install("stop_subscript_missing"), syms_i, i, vctrs_ns_env); never_reached("stop_subscript_missing"); } static void stop_location_negative_missing(SEXP i, const struct vec_as_location_opts* opts) { vctrs_eval_mask3(Rf_install("stop_location_negative_missing"), syms_i, i, syms_subscript_arg, opts->subscript_arg, syms_subscript_action, get_opts_action(opts), vctrs_ns_env); never_reached("stop_location_negative_missing"); } static void stop_location_negative_positive(SEXP i, const struct vec_as_location_opts* opts) { vctrs_eval_mask3(Rf_install("stop_location_negative_positive"), syms_i, i, syms_subscript_arg, opts->subscript_arg, syms_subscript_action, get_opts_action(opts), vctrs_ns_env); never_reached("stop_location_negative_positive"); } static void stop_subscript_oob_location(SEXP i, R_len_t size, const struct vec_as_location_opts* opts) { SEXP size_obj = PROTECT(r_int(size)); vctrs_eval_mask5(Rf_install("stop_subscript_oob"), syms_i, i, syms_subscript_type, chrs_numeric, syms_size, size_obj, syms_subscript_action, get_opts_action(opts), syms_subscript_arg, opts->subscript_arg, vctrs_ns_env); UNPROTECT(1); never_reached("stop_subscript_oob_location"); } static void stop_subscript_oob_name(SEXP i, SEXP names, const struct vec_as_location_opts* opts) { vctrs_eval_mask5(Rf_install("stop_subscript_oob"), syms_i, i, syms_subscript_type, chrs_character, syms_names, names, syms_subscript_action, get_opts_action(opts), syms_subscript_arg, opts->subscript_arg, vctrs_ns_env); never_reached("stop_subscript_oob_name"); } static void stop_location_negative(SEXP i, const struct vec_as_location_opts* opts) { vctrs_eval_mask3(Rf_install("stop_location_negative"), syms_i, i, syms_subscript_action, get_opts_action(opts), syms_subscript_arg, opts->subscript_arg, vctrs_ns_env); never_reached("stop_location_negative"); } static void stop_indicator_size(SEXP i, SEXP n, const struct vec_as_location_opts* opts) { vctrs_eval_mask4(Rf_install("stop_indicator_size"), syms_i, i, syms_n, n, syms_subscript_action, get_opts_action(opts), syms_subscript_arg, opts->subscript_arg, vctrs_ns_env); never_reached("stop_indicator_size"); } static void stop_location_oob_non_consecutive(SEXP i, R_len_t size, const struct vec_as_location_opts* opts) { SEXP size_obj = PROTECT(r_int(size)); vctrs_eval_mask4(Rf_install("stop_location_oob_non_consecutive"), syms_i, i, syms_size, size_obj, syms_subscript_action, get_opts_action(opts), syms_subscript_arg, opts->subscript_arg, vctrs_ns_env); UNPROTECT(1); never_reached("stop_location_oob_non_consecutive"); } struct vec_as_location_opts vec_as_location_default_opts_obj; struct vec_as_location_opts vec_as_location_default_assign_opts_obj; void vctrs_init_subscript_loc(SEXP ns) { vec_as_location_default_opts_obj.action = SUBSCRIPT_ACTION_DEFAULT; vec_as_location_default_opts_obj.loc_negative = LOC_NEGATIVE_INVERT; vec_as_location_default_opts_obj.loc_oob = LOC_OOB_ERROR; vec_as_location_default_opts_obj.subscript_arg = R_NilValue; vec_as_location_default_opts_obj.missing = SUBSCRIPT_MISSING_PROPAGATE; vec_as_location_default_assign_opts_obj.action = SUBSCRIPT_ACTION_ASSIGN; vec_as_location_default_assign_opts_obj.loc_negative = LOC_NEGATIVE_INVERT; vec_as_location_default_assign_opts_obj.loc_oob = LOC_OOB_ERROR; vec_as_location_default_assign_opts_obj.subscript_arg = R_NilValue; vec_as_location_default_assign_opts_obj.missing = SUBSCRIPT_MISSING_PROPAGATE; } vctrs/src/altrep.h0000644000176200001440000000360513622451540013650 0ustar liggesusers#ifndef ALTREP_H #define ALTREP_H #include "Rversion.h" #if (R_VERSION < R_Version(3, 5, 0)) # define ALTREP(x) false # define ALTVEC_EXTRACT_SUBSET_PROXY(x, indx, call) NULL #else #include "R_ext/Altrep.h" #define ALTREP_METHODS \ R_altrep_UnserializeEX_method_t UnserializeEX; \ R_altrep_Unserialize_method_t Unserialize; \ R_altrep_Serialized_state_method_t Serialized_state; \ R_altrep_DuplicateEX_method_t DuplicateEX; \ R_altrep_Duplicate_method_t Duplicate; \ R_altrep_Coerce_method_t Coerce; \ R_altrep_Inspect_method_t Inspect; \ R_altrep_Length_method_t Length #define ALTVEC_METHODS \ ALTREP_METHODS; \ R_altvec_Dataptr_method_t Dataptr; \ R_altvec_Dataptr_or_null_method_t Dataptr_or_null; \ R_altvec_Extract_subset_method_t Extract_subset typedef struct { ALTREP_METHODS; } altrep_methods_t; typedef struct { ALTVEC_METHODS; } altvec_methods_t; #define CLASS_METHODS_TABLE(type_class) STDVEC_DATAPTR(type_class) #define GENERIC_METHODS_TABLE(x, type_class) \ ((type_class##_methods_t *) CLASS_METHODS_TABLE(ALTREP_CLASS(x))) #define ALTREP_METHODS_TABLE(x) GENERIC_METHODS_TABLE(x, altrep) #define ALTVEC_METHODS_TABLE(x) GENERIC_METHODS_TABLE(x, altvec) #define DISPATCH_TARGET_HELPER(x, ...) x #define DISPATCH_TARGET(...) DISPATCH_TARGET_HELPER(__VA_ARGS__, dummy) #define DO_DISPATCH(type, fun, ...) \ type##_METHODS_TABLE(DISPATCH_TARGET(__VA_ARGS__))->fun(__VA_ARGS__) #define ALTREP_DISPATCH(fun, ...) DO_DISPATCH(ALTREP, fun, __VA_ARGS__) #define ALTVEC_DISPATCH(fun, ...) DO_DISPATCH(ALTVEC, fun, __VA_ARGS__) static inline SEXP ALTVEC_EXTRACT_SUBSET_PROXY(SEXP x, SEXP indx, SEXP call) { return ALTVEC_DISPATCH(Extract_subset, x, indx, call); } #endif #endif vctrs/src/proxy.c0000644000176200001440000000524013622451540013532 0ustar liggesusers#include "vctrs.h" #include "utils.h" // Initialised at load time SEXP syms_vec_proxy = NULL; SEXP syms_vec_proxy_equal_dispatch = NULL; SEXP fns_vec_proxy_equal_dispatch = NULL; // Defined below SEXP vec_proxy_method(SEXP x); SEXP vec_proxy_invoke(SEXP x, SEXP method); // [[ register(); include("vctrs.h") ]] SEXP vec_proxy(SEXP x) { int nprot = 0; struct vctrs_type_info info = vec_type_info(x); PROTECT_TYPE_INFO(&info, &nprot); SEXP out; if (info.type == vctrs_type_s3) { out = vec_proxy_invoke(x, info.proxy_method); } else { out = x; } UNPROTECT(nprot); return out; } // [[ register(); include("vctrs.h") ]] SEXP vec_proxy_equal(SEXP x) { return vec_proxy_recursive(x, vctrs_proxy_equal); } SEXP vec_proxy_equal_dispatch(SEXP x) { if (vec_typeof(x) == vctrs_type_s3) { return vctrs_dispatch1(syms_vec_proxy_equal_dispatch, fns_vec_proxy_equal_dispatch, syms_x, x); } else { return x; } } // [[ include("vctrs.h") ]] SEXP vec_proxy_recursive(SEXP x, enum vctrs_proxy_kind kind) { switch (kind) { case vctrs_proxy_default: x = vec_proxy(x); break; case vctrs_proxy_equal: x = vec_proxy_equal_dispatch(x); break; case vctrs_proxy_compare: Rf_error("Internal error: Unimplemented proxy kind"); } PROTECT(x); if (is_data_frame(x)) { x = PROTECT(r_maybe_duplicate(x)); R_len_t n = Rf_length(x); for (R_len_t i = 0; i < n; ++i) { SEXP col = vec_proxy_recursive(VECTOR_ELT(x, i), kind); SET_VECTOR_ELT(x, i, col); } UNPROTECT(1); } UNPROTECT(1); return x; } // [[ register() ]] SEXP vctrs_proxy_recursive(SEXP x, SEXP kind_) { enum vctrs_proxy_kind kind; if (kind_ == Rf_install("default")) { kind = vctrs_proxy_default; } else if (kind_ == Rf_install("equal")) { kind = vctrs_proxy_equal; } else if (kind_ == Rf_install("compare")) { kind = vctrs_proxy_compare; } else { Rf_error("Internal error: Unexpected proxy kind `%s`.", CHAR(PRINTNAME(kind_))); } return vec_proxy_recursive(x, kind); } SEXP vec_proxy_method(SEXP x) { return s3_find_method("vec_proxy", x, vctrs_method_table); } // This should be faster than normal dispatch but also means that // proxy methods can't call `NextMethod()`. This could be changed if // it turns out a problem. SEXP vec_proxy_invoke(SEXP x, SEXP method) { if (method == R_NilValue) { return x; } else { return vctrs_dispatch1(syms_vec_proxy, method, syms_x, x); } } void vctrs_init_data(SEXP ns) { syms_vec_proxy = Rf_install("vec_proxy"); syms_vec_proxy_equal_dispatch = Rf_install("vec_proxy_equal_dispatch"); fns_vec_proxy_equal_dispatch = r_env_get(ns, syms_vec_proxy_equal_dispatch); } vctrs/src/translate.c0000644000176200001440000002701713622451540014354 0ustar liggesusers#include "vctrs.h" #include "utils.h" // ----------------------------------------------------------------------------- // Helpers for determining if UTF-8 translation is required for character // vectors // UTF-8 translation will be successful in these cases: // - (utf8 + latin1), (unknown + utf8), (unknown + latin1) // UTF-8 translation will fail purposefully in these cases: // - (bytes + utf8), (bytes + latin1), (bytes + unknown) // UTF-8 translation is not attempted in these cases: // - (utf8 + utf8), (latin1 + latin1), (unknown + unknown), (bytes + bytes) static bool chr_translation_required_impl(const SEXP* x, R_len_t size, cetype_t reference) { for (R_len_t i = 0; i < size; ++i) { if (Rf_getCharCE(x[i]) != reference) { return true; } } return false; } static bool chr_translation_required(SEXP x, R_len_t size) { if (size == 0) { return false; } const SEXP* p_x = STRING_PTR_RO(x); cetype_t reference = Rf_getCharCE(*p_x); return chr_translation_required_impl(p_x, size, reference); } // Check if `x` or `y` need to be translated to UTF-8, relative to each other static bool chr_translation_required2(SEXP x, R_len_t x_size, SEXP y, R_len_t y_size) { const SEXP* p_x; const SEXP* p_y; bool x_empty = x_size == 0; bool y_empty = y_size == 0; if (x_empty && y_empty) { return false; } if (x_empty) { p_y = STRING_PTR_RO(y); return chr_translation_required_impl(p_y, y_size, Rf_getCharCE(*p_y)); } if (y_empty) { p_x = STRING_PTR_RO(x); return chr_translation_required_impl(p_x, x_size, Rf_getCharCE(*p_x)); } p_x = STRING_PTR_RO(x); cetype_t reference = Rf_getCharCE(*p_x); if (chr_translation_required_impl(p_x, x_size, reference)) { return true; } p_y = STRING_PTR_RO(y); if (chr_translation_required_impl(p_y, y_size, reference)) { return true; } return false; } // ----------------------------------------------------------------------------- // Utilities to check if any character elements of a list have a // "known" encoding (UTF-8 or Latin1). This implies that we have to convert // all character elements of the list to UTF-8. Only `list_any_known_encoding()` // is ever called directly. static bool chr_any_known_encoding(SEXP x, R_len_t size); static bool list_any_known_encoding(SEXP x, R_len_t size); static bool df_any_known_encoding(SEXP x, R_len_t size); static bool obj_any_known_encoding(SEXP x, R_len_t size) { switch (TYPEOF(x)) { case STRSXP: { return chr_any_known_encoding(x, size); } case VECSXP: { if (is_data_frame(x)) { return df_any_known_encoding(x, size); } else { return list_any_known_encoding(x, size); } } default: { return false; } } } // For usage on list elements. They have unknown size, and might be scalars. static bool elt_any_known_encoding(SEXP x) { switch (TYPEOF(x)) { case STRSXP: { return chr_any_known_encoding(x, Rf_length(x)); } case VECSXP: { if (is_data_frame(x)) { return df_any_known_encoding(x, vec_size(x)); } else { return list_any_known_encoding(x, Rf_length(x)); } } default: { return false; } } } static bool chr_any_known_encoding(SEXP x, R_len_t size) { if (size == 0) { return false; } const SEXP* p_x = STRING_PTR_RO(x); for (int i = 0; i < size; ++i) { if (Rf_getCharCE(p_x[i]) != CE_NATIVE) { return true; } } return false; } static bool list_any_known_encoding(SEXP x, R_len_t size) { for (int i = 0; i < size; ++i) { if (elt_any_known_encoding(VECTOR_ELT(x, i))) { return true; } } return false; } // Data frames have a separate path from lists here purely for // performance reasons. We know the size of each column, and can // pass that information through. static bool df_any_known_encoding(SEXP x, R_len_t size) { int n_col = Rf_length(x); for (int i = 0; i < n_col; ++i) { if (obj_any_known_encoding(VECTOR_ELT(x, i), size)) { return true; } } return false; } // ----------------------------------------------------------------------------- // Utilities to translate all character vector elements of an object to UTF-8. // This does not check if a translation is required. static SEXP chr_translate_encoding(SEXP x, R_len_t size); static SEXP list_translate_encoding(SEXP x, R_len_t size); static SEXP df_translate_encoding(SEXP x, R_len_t size); static SEXP obj_translate_encoding(SEXP x, R_len_t size) { switch (TYPEOF(x)) { case STRSXP: { return chr_translate_encoding(x, size); } case VECSXP: { if (is_data_frame(x)) { return df_translate_encoding(x, size); } else { return list_translate_encoding(x, size); } } default: { return x; } } } // For usage on list elements. They have unknown size, and might be scalars. static SEXP elt_translate_encoding(SEXP x) { switch (TYPEOF(x)) { case STRSXP: { return chr_translate_encoding(x, Rf_length(x)); } case VECSXP: { if (is_data_frame(x)) { return df_translate_encoding(x, vec_size(x)); } else { return list_translate_encoding(x, Rf_length(x)); } } default: { return x; } } } static SEXP chr_translate_encoding(SEXP x, R_len_t size) { if (size == 0) { return x; } const SEXP* p_x = STRING_PTR_RO(x); SEXP out = PROTECT(r_maybe_duplicate(x)); SEXP* p_out = STRING_PTR(out); const void *vmax = vmaxget(); for (int i = 0; i < size; ++i) { SEXP chr = p_x[i]; if (Rf_getCharCE(chr) == CE_UTF8) { p_out[i] = chr; continue; } p_out[i] = Rf_mkCharCE(Rf_translateCharUTF8(chr), CE_UTF8); } vmaxset(vmax); UNPROTECT(1); return out; } static SEXP list_translate_encoding(SEXP x, R_len_t size) { x = PROTECT(r_maybe_duplicate(x)); for (int i = 0; i < size; ++i) { SEXP elt = VECTOR_ELT(x, i); SET_VECTOR_ELT(x, i, elt_translate_encoding(elt)); } UNPROTECT(1); return x; } static SEXP df_translate_encoding(SEXP x, R_len_t size) { int n_col = Rf_length(x); x = PROTECT(r_maybe_duplicate(x)); for (int i = 0; i < n_col; ++i) { SEXP col = VECTOR_ELT(x, i); SET_VECTOR_ELT(x, i, obj_translate_encoding(col, size)); } UNPROTECT(1); return x; } // ----------------------------------------------------------------------------- // Utilities for translating encodings within one vector, if required. // - If `x` is a character vector requiring translation, translate it. // - If `x` is a list where any element has a "known" encoding, force a // translation of every element in the list. // - If `x` is a data frame, translate the columns one by one, independently. // Notes: // - Assumes that `x` has been proxied recursively. static SEXP chr_maybe_translate_encoding(SEXP x, R_len_t size); static SEXP list_maybe_translate_encoding(SEXP x, R_len_t size); static SEXP df_maybe_translate_encoding(SEXP x, R_len_t size); // [[ include("vctrs.h") ]] SEXP obj_maybe_translate_encoding(SEXP x, R_len_t size) { switch (TYPEOF(x)) { case STRSXP: { return chr_maybe_translate_encoding(x, size); } case VECSXP: { if (is_data_frame(x)) { return df_maybe_translate_encoding(x, size); } else { return list_maybe_translate_encoding(x, size); } } default: { return x; } } } static SEXP chr_maybe_translate_encoding(SEXP x, R_len_t size) { return chr_translation_required(x, size) ? chr_translate_encoding(x, size) : x; } static SEXP list_maybe_translate_encoding(SEXP x, R_len_t size) { return list_any_known_encoding(x, size) ? list_translate_encoding(x, size) : x; } static SEXP df_maybe_translate_encoding(SEXP x, R_len_t size) { int n_col = Rf_length(x); x = PROTECT(r_maybe_duplicate(x)); for (int i = 0; i < n_col; ++i) { SEXP elt = VECTOR_ELT(x, i); SET_VECTOR_ELT(x, i, obj_maybe_translate_encoding(elt, size)); } UNPROTECT(1); return x; } // ----------------------------------------------------------------------------- // Utilities for translating encodings of `x` and `y` relative to each other, // if required. static SEXP translate_none(SEXP x, SEXP y); static SEXP chr_maybe_translate_encoding2(SEXP x, R_len_t x_size, SEXP y, R_len_t y_size); static SEXP list_maybe_translate_encoding2(SEXP x, R_len_t x_size, SEXP y, R_len_t y_size); static SEXP df_maybe_translate_encoding2(SEXP x, R_len_t x_size, SEXP y, R_len_t y_size); // Notes: // - Assumes that `x` and `y` are the same type from calling `vec_cast()`. // - Assumes that `x` and `y` have been recursively proxied. // - Does not assume that `x` and `y` are the same size. // - Returns a list holding `x` and `y` translated to their common encoding. // [[ include("vctrs.h") ]] SEXP obj_maybe_translate_encoding2(SEXP x, R_len_t x_size, SEXP y, R_len_t y_size) { switch (TYPEOF(x)) { case STRSXP: { return chr_maybe_translate_encoding2(x, x_size, y, y_size); } case VECSXP: { if (is_data_frame(x)) { return df_maybe_translate_encoding2(x, x_size, y, y_size); } else { return list_maybe_translate_encoding2(x, x_size, y, y_size); } } default: { return translate_none(x, y); } } } static SEXP translate_none(SEXP x, SEXP y) { SEXP out = PROTECT(Rf_allocVector(VECSXP, 2)); SET_VECTOR_ELT(out, 0, x); SET_VECTOR_ELT(out, 1, y); UNPROTECT(1); return out; } static SEXP chr_maybe_translate_encoding2(SEXP x, R_len_t x_size, SEXP y, R_len_t y_size) { SEXP out = PROTECT(Rf_allocVector(VECSXP, 2)); if (chr_translation_required2(x, x_size, y, y_size)) { SET_VECTOR_ELT(out, 0, chr_translate_encoding(x, x_size)); SET_VECTOR_ELT(out, 1, chr_translate_encoding(y, y_size)); } else { SET_VECTOR_ELT(out, 0, x); SET_VECTOR_ELT(out, 1, y); } UNPROTECT(1); return out; } static SEXP list_maybe_translate_encoding2(SEXP x, R_len_t x_size, SEXP y, R_len_t y_size) { SEXP out = PROTECT(Rf_allocVector(VECSXP, 2)); if (list_any_known_encoding(x, x_size) || list_any_known_encoding(y, y_size)) { SET_VECTOR_ELT(out, 0, list_translate_encoding(x, x_size)); SET_VECTOR_ELT(out, 1, list_translate_encoding(y, y_size)); } else { SET_VECTOR_ELT(out, 0, x); SET_VECTOR_ELT(out, 1, y); } UNPROTECT(1); return out; } static SEXP df_maybe_translate_encoding2(SEXP x, R_len_t x_size, SEXP y, R_len_t y_size) { int n_col = Rf_length(x); x = PROTECT(r_maybe_duplicate(x)); y = PROTECT(r_maybe_duplicate(y)); SEXP out = PROTECT(Rf_allocVector(VECSXP, 2)); for (int i = 0; i < n_col; ++i) { SEXP x_elt = VECTOR_ELT(x, i); SEXP y_elt = VECTOR_ELT(y, i); SEXP translated = PROTECT(obj_maybe_translate_encoding2(x_elt, x_size, y_elt, y_size)); SET_VECTOR_ELT(x, i, VECTOR_ELT(translated, 0)); SET_VECTOR_ELT(y, i, VECTOR_ELT(translated, 1)); UNPROTECT(1); } SET_VECTOR_ELT(out, 0, x); SET_VECTOR_ELT(out, 1, y); UNPROTECT(3); return out; } // ----------------------------------------------------------------------------- // [[ register() ]] SEXP vctrs_maybe_translate_encoding(SEXP x) { x = PROTECT(vec_proxy_equal(x)); SEXP out = PROTECT(obj_maybe_translate_encoding(x, vec_size(x))); UNPROTECT(2); return out; } // [[ register() ]] SEXP vctrs_maybe_translate_encoding2(SEXP x, SEXP y) { struct vctrs_arg args_x = new_wrapper_arg(NULL, "x"); struct vctrs_arg args_y = new_wrapper_arg(NULL, "y"); int _; SEXP type = PROTECT(vec_type2(x, y, &args_x, &args_y, &_)); x = PROTECT(vec_cast(x, type, args_empty, args_empty)); y = PROTECT(vec_cast(y, type, args_empty, args_empty)); x = PROTECT(vec_proxy_equal(x)); y = PROTECT(vec_proxy_equal(y)); SEXP out = obj_maybe_translate_encoding2(x, vec_size(x), y, vec_size(y)); UNPROTECT(5); return out; } vctrs/src/proxy-restore.c0000644000176200001440000001020613623013722015206 0ustar liggesusers#include "vctrs.h" #include "type-data-frame.h" #include "utils.h" // Initialised at load time static SEXP syms_vec_restore_dispatch = NULL; static SEXP fns_vec_restore_dispatch = NULL; // Copy attributes except names and dim. This duplicates `x` if needed. SEXP vec_restore_default(SEXP x, SEXP to) { SEXP attrib = ATTRIB(to); if (attrib == R_NilValue) { return x; } int n_protect = 0; attrib = PROTECT(Rf_shallow_duplicate(attrib)); ++n_protect; if (MAYBE_REFERENCED(x)) { x = PROTECT(Rf_shallow_duplicate(x)); ++n_protect; } // Remove vectorised attributes which might be incongruent after reshaping. // Shouldn't matter for GNU R but other R implementations might have checks. // Also record class to set it later with `Rf_setAttrib()`. This restores // the OBJECT bit and is likely more compatible with other implementations. SEXP class = R_NilValue; { SEXP node = attrib; SEXP prev = R_NilValue; while (node != R_NilValue) { SEXP tag = TAG(node); // Skip special attributes if (tag == R_NamesSymbol || tag == R_DimSymbol || tag == R_DimNamesSymbol || tag == R_ClassSymbol || tag == R_RowNamesSymbol) { if (tag == R_ClassSymbol) { class = CAR(node); } if (prev == R_NilValue) { attrib = CDR(attrib); node = CDR(node); continue; } SETCDR(prev, CDR(node)); } prev = node; node = CDR(node); } } // Copy attributes but keep names and dims. Don't restore names for // shaped objects since those are generated from dimnames. SEXP dim = PROTECT(Rf_getAttrib(x, R_DimSymbol)); ++n_protect; if (dim == R_NilValue) { SEXP nms = PROTECT(Rf_getAttrib(x, R_NamesSymbol)); SEXP rownms = PROTECT(df_rownames(x)); SET_ATTRIB(x, attrib); Rf_setAttrib(x, R_NamesSymbol, nms); Rf_setAttrib(x, R_RowNamesSymbol, rownms); UNPROTECT(2); } else { SEXP dimnames = PROTECT(Rf_getAttrib(x, R_DimNamesSymbol)); SET_ATTRIB(x, attrib); Rf_setAttrib(x, R_DimSymbol, dim); Rf_setAttrib(x, R_DimNamesSymbol, dimnames); UNPROTECT(1); } if (class != R_NilValue) { Rf_setAttrib(x, R_ClassSymbol, class); } UNPROTECT(n_protect); return x; } static SEXP vec_restore_dispatch(SEXP x, SEXP to, SEXP n) { return vctrs_dispatch3(syms_vec_restore_dispatch, fns_vec_restore_dispatch, syms_x, x, syms_to, to, syms_n, n); } static SEXP bare_df_restore_impl(SEXP x, SEXP to, R_len_t size) { x = PROTECT(r_maybe_duplicate(x)); x = PROTECT(vec_restore_default(x, to)); if (Rf_getAttrib(x, R_NamesSymbol) == R_NilValue) { Rf_setAttrib(x, R_NamesSymbol, vctrs_shared_empty_chr); } SEXP rownames = PROTECT(df_rownames(x)); if (rownames == R_NilValue) { init_compact_rownames(x, size); } UNPROTECT(3); return x; } // [[ include("vctrs.h"); register() ]] SEXP vec_bare_df_restore(SEXP x, SEXP to, SEXP n) { if (TYPEOF(x) != VECSXP) { Rf_errorcall(R_NilValue, "Internal error: Attempt to restore data frame from a %s.", Rf_type2char(TYPEOF(x))); } R_len_t size = (n == R_NilValue) ? df_raw_size(x) : r_int_get(n, 0); return bare_df_restore_impl(x, to, size); } // Restore methods are passed the original atomic type back, so we // first restore data frames as such before calling the restore // method, if any // [[ include("vctrs.h") ]] SEXP vec_df_restore(SEXP x, SEXP to, SEXP n) { SEXP out = PROTECT(vec_bare_df_restore(x, to, n)); out = vec_restore_dispatch(out, to, n); UNPROTECT(1); return out; } SEXP vec_restore(SEXP x, SEXP to, SEXP n) { switch (class_type(to)) { default: return vec_restore_dispatch(x, to, n); case vctrs_class_none: return vec_restore_default(x, to); case vctrs_class_bare_data_frame: case vctrs_class_bare_tibble: return vec_bare_df_restore(x, to, n); case vctrs_class_data_frame: return vec_df_restore(x, to, n); } } void vctrs_init_proxy_restore(SEXP ns) { syms_vec_restore_dispatch = Rf_install("vec_restore_dispatch"); fns_vec_restore_dispatch = Rf_findVar(syms_vec_restore_dispatch, ns); } vctrs/src/split.c0000644000176200001440000000102113622451540013475 0ustar liggesusers#include "vctrs.h" #include "utils.h" // [[ register() ]] SEXP vec_split(SEXP x, SEXP by) { if (vec_size(x) != vec_size(by)) { Rf_errorcall(R_NilValue, "`x` and `by` must have the same size."); } SEXP out = PROTECT(vec_group_loc(by)); SEXP indices = VECTOR_ELT(out, 1); SEXP val = vec_chop(x, indices); SET_VECTOR_ELT(out, 1, val); SEXP names = PROTECT(Rf_getAttrib(out, R_NamesSymbol)); SET_STRING_ELT(names, 1, strings_val); Rf_setAttrib(out, R_NamesSymbol, names); UNPROTECT(2); return out; } vctrs/vignettes/0000755000176200001440000000000013623213416013424 5ustar liggesusersvctrs/vignettes/type-size.Rmd0000644000176200001440000003174113622451540016030 0ustar liggesusers--- title: "Prototypes and sizes" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Prototypes and sizes} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r setup, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` Rather than using `class()` and `length()`, vctrs has notions of prototype (`vec_ptype_show()`) and size (`vec_size()`). This vignette discusses the motivation for why these alternatives are necessary and connects their definitions to type coercion and the recycling rules. Size and prototype are motivated by thinking about the optimal behaviour for `c()` and `rbind()`, particularly inspired by data frames with columns that are matrices or data frames. ```{r} library(vctrs) ``` ## Prototype The idea of a prototype is to capture the metadata associated with a vector without capturing any data. Unfortunately, the `class()` of an object is inadequate for this purpose: * The `class()` doesn't include attributes. Attributes are important because, for example, they store the levels of a factor and the timezone of a `POSIXct`. You cannot combine two factors or two `POSIXct`s without thinking about the attributes. * The `class()` of a matrix is "matrix" and doesn't include the type of the underlying vector or the dimensionality. Instead, vctrs takes advantage of R's vectorised nature and uses a __prototype__, a 0-observation slice of the vector (this is basically `x[0]` but with some subtleties we'll come back to later). This is a miniature version of the vector that contains all of the attributes but none of the data. Conveniently, you can create many prototypes using existing base functions (e.g, `double()` and `factor(levels = c("a", "b"))`). vctrs provides a few helpers (e.g. `new_date()`, `new_datetime()`, and `new_duration()`) where the equivalents in base R are missing. ### Base prototypes `vec_ptype()` creates a prototype from an existing object. However, many base vectors have uninformative printing methods for 0-length subsets, so vctrs also provides `vec_ptype_show()`, which prints the prototype in a friendly way (and returns nothing). Using `vec_ptype_show()` allows us to see the prototypes base R classes: * Atomic vectors have no attributes and just display the underlying `typeof()`: ```{r} vec_ptype_show(FALSE) vec_ptype_show(1L) vec_ptype_show(2.5) vec_ptype_show("three") vec_ptype_show(list(1, 2, 3)) ``` * The prototype of matrices and arrays include the base type and the dimensions after the first: ```{r} vec_ptype_show(array(logical(), c(2, 3))) vec_ptype_show(array(integer(), c(2, 3, 4))) vec_ptype_show(array(character(), c(2, 3, 4, 5))) ``` * The prototype of a factor includes its levels. Levels are a character vector, which can be arbitrarily long, so the prototype just shows a hash. If the hash of two factors is equal, it's highly likely that their levels are also equal. ```{r} vec_ptype_show(factor("a")) vec_ptype_show(ordered("b")) ``` While `vec_ptype_show()` prints only the hash, the prototype object itself does contain all levels: ```{r} vec_ptype(factor("a")) ``` * Base R has three key date time classes: dates, date-times (`POSIXct`), and durations (`difftime)`. Date-times have a timezone, and durations have a unit. ```{r} vec_ptype_show(Sys.Date()) vec_ptype_show(Sys.time()) vec_ptype_show(as.difftime(10, units = "mins")) ``` * Data frames have the most complex prototype: the prototype of a data frame is the name and prototype of each column: ```{r} vec_ptype_show(data.frame(a = FALSE, b = 1L, c = 2.5, d = "x")) ``` Data frames can have columns that are themselves data frames, making this a "recursive" type: ```{r} df <- data.frame(x = FALSE) df$y <- data.frame(a = 1L, b = 2.5) vec_ptype_show(df) ``` ### Coercing to common type It's often important to combine vectors with multiple types. vctrs provides a consistent set of rules for coercion, via `vec_ptype_common()`. `vec_ptype_common()` possesses the following invariants: * `class(vec_ptype_common(x, y))` equals `class(vec_ptype_common(y, x))`. * `class(vec_ptype_common(x, vec_ptype_common(y, z))` equals `class(vec_ptype_common(vec_ptype_common(x, y), z))`. * `vec_ptype_common(x, NULL) == vec_ptype(x)`. i.e., `vec_ptype_common()` is both commutative and associative (with respect to class) and has an identity element, `NULL`; i.e., it's a __commutative monoid__. This means the underlying implementation is quite simple: we can find the common type of any number of objects by progressively finding the common type of pairs of objects. Like with `vec_ptype()`, the easiest way to explore `vec_ptype_common()` is with `vec_ptype_show()`: when given multiple inputs, it will print their common prototype. (In other words: program with `vec_ptype_common()` but play with `vec_ptype_show()`.) * The common type of atomic vectors is computed very similar to the rules of base R, except that we do not coerce to character automatically: ```{r, error = TRUE} vec_ptype_show(logical(), integer(), double()) vec_ptype_show(logical(), character()) ``` * Matrices and arrays are automatically broadcast to higher dimensions: ```{r} vec_ptype_show( array(1, c(0, 1)), array(1, c(0, 2)) ) vec_ptype_show( array(1, c(0, 1)), array(1, c(0, 3)), array(1, c(0, 3, 4)), array(1, c(0, 3, 4, 5)) ) ``` Provided that the dimensions follow the vctrs recycling rules: ```{r, error = TRUE} vec_ptype_show( array(1, c(0, 2)), array(1, c(0, 3)) ) ``` * Factors combine levels in the order in which they appear. ```{r} fa <- factor("a") fb <- factor("b") levels(vec_ptype_common(fa, fb)) levels(vec_ptype_common(fb, fa)) ``` * Combining a date and date-time yields a date-time: ```{r} vec_ptype_show(new_date(), new_datetime()) ``` When combining two date times, the timezone is taken from the first input: ```{r} vec_ptype_show( new_datetime(tzone = "US/Central"), new_datetime(tzone = "Pacific/Auckland") ) ``` Unless it's the local timezone, in which case any explicit time zone will win: ```{r} vec_ptype_show( new_datetime(tzone = ""), new_datetime(tzone = ""), new_datetime(tzone = "Pacific/Auckland") ) ``` * The common type of two data frames is the common type of each column that occurs in both data frames: ```{r} vec_ptype_show( data.frame(x = FALSE), data.frame(x = 1L), data.frame(x = 2.5) ) ``` And the union of the columns that only occur in one: ```{r} vec_ptype_show(data.frame(x = 1, y = 1), data.frame(y = 1, z = 1)) ``` Note that new columns are added on the right-hand side. This is consistent with the way that factor levels and time zones are handled. ### Casting to specified type `vec_ptype_common()` finds the common type of a set of vector. Typically, however, what you want is a set of vectors coerced to that common type. That's the job of `vec_cast_common()`: ```{r} str(vec_cast_common( FALSE, 1:5, 2.5 )) str(vec_cast_common( factor("x"), factor("y") )) str(vec_cast_common( data.frame(x = 1), data.frame(y = 1:2) )) ``` Alternatively, you can cast to a specific prototype using `vec_cast()`: ```{r, error = TRUE} # Cast succeeds vec_cast(c(1, 2), integer()) # Cast fails vec_cast(c(1.5, 2.5), factor("a")) ``` If a cast is possible in general (i.e., double -> integer), but information is lost for a specific input (e.g. 1.5 -> 1), it will generate an error. ```{r, error = TRUE} vec_cast(c(1.5, 2), integer()) ``` You can suppress the lossy cast errors with `allow_lossy_cast()`: ```{r} allow_lossy_cast( vec_cast(c(1.5, 2), integer()) ) ``` This will suppress all lossy cast errors. Supply prototypes if you want to be specific about the type of lossy cast allowed: ```{r} allow_lossy_cast( vec_cast(c(1.5, 2), integer()), x_ptype = double(), to_ptype = integer() ) ``` The set of casts is more permissive than the set of coercions and is summarised in the diagram below. Coercions are shown by arrows; possible casts are shown with circles. ```{r, echo = FALSE, fig.cap="Summary of vctrs casting rules"} knitr::include_graphics("../man/figures/combined.png", dpi = 300) ``` ## Size `vec_size()` was motivated by the need to have an invariant that describes the number of "observations" in a data structure. This is particularly important for data frames, as it's useful to have some function such that `f(data.frame(x))` equals `f(x)`. No base function has this property: * `length(data.frame(x))` equals `1` because the length of a data frame is the number of columns. * `nrow(data.frame(x))` does not equal `nrow(x)` because `nrow()` of a vector is `NULL`. * `NROW(data.frame(x))` equals `NROW(x)` for vector `x`, so is almost what we want. But because `NROW()` is defined in terms of `length()`, it returns a value for every object, even types that can't go in a data frame, e.g. `data.frame(mean)` errors even though `NROW(mean)` is `1`. We define `vec_size()` as follows: * It is the length of 1d vectors. * It is the number of rows of data frames, matrices, and arrays. * It throws error for non vectors. Given `vec_size()`, we can give a precise definition of a data frame: a data frame is a list of vectors where every vector has the same size. This has the desirable property of trivially supporting matrix and data frame columns. ### Slicing `vec_slice()` is to `vec_size()` as `[` is to `length()`; i.e., it allows you to select observations regardless of the dimensionality of the underlying object. `vec_slice(x, i)` is equivalent to: * `x[i]` when `x` is a vector. * `x[i, , drop = FALSE]` when `x` is a data frame. * `x[i, , , drop = FALSE]` when `x` is a 3d array. ```{r} x <- sample(1:10) df <- data.frame(x = x) vec_slice(x, 5:6) vec_slice(df, 5:6) ``` `vec_slice(data.frame(x), i)` equals `data.frame(vec_slice(x, i))` (modulo variable and row names). Prototypes are generated with `vec_slice(x, 0L)`; given a prototype, you can initialize a vector of given size (filled with `NA`s) with `vec_init()`. ### Common sizes: recycling rules Closely related to the definition of size are the __recycling rules__. The recycling rules determine the size of the output when two vectors of different sizes are combined. In vctrs, the recycling rules are encoded in `vec_size_common()`, which gives the common size of a set of vectors: ```{r} vec_size_common(1:3, 1:3, 1:3) vec_size_common(1:10, 1) vec_size_common(integer(), 1) ``` vctrs obeys a stricter set of recycling rules than base R. Vectors of size 1 are recycled to any other size. All other size combinations will generate an error. This strictness prevents common mistakes like `dest == c("IAH", "HOU"))`, at the cost of occasionally requiring an explicit calls to `rep()`. ```{r, echo = FALSE, fig.cap="Summary of vctrs recycling rules. X indicates n error"} knitr::include_graphics("../man/figures/sizes-recycling.png", dpi = 300) ``` You can apply the recycling rules in two ways: * If you have a vector and desired size, use `vec_recycle()`: ```{r} vec_recycle(1:3, 3) vec_recycle(1, 10) ``` * If you have multiple vectors and you want to recycle them to the same size, use `vec_recycle_common()`: ```{r} vec_recycle_common(1:3, 1:3) vec_recycle_common(1:10, 1) ``` ## Appendix: recycling in base R The recycling rules in base R are described in [The R Language Definition](https://cran.r-project.org/doc/manuals/r-release/R-lang.html#Recycling-rules) but are not implemented in a single function and thus are not applied consistently. Here, I give a brief overview of their most common realisation, as well as showing some of the exceptions. Generally, in base R, when a pair of vectors is not the same length, the shorter vector is recycled to the same length as the longer: ```{r} rep(1, 6) + 1 rep(1, 6) + 1:2 rep(1, 6) + 1:3 ``` If the length of the longer vector is not an integer multiple of the length of the shorter, you usually get a warning: ```{r} invisible(pmax(1:2, 1:3)) invisible(1:2 + 1:3) invisible(cbind(1:2, 1:3)) ``` But some functions recycle silently: ```{r} length(atan2(1:3, 1:2)) length(paste(1:3, 1:2)) length(ifelse(1:3, 1:2, 1:2)) ``` And `data.frame()` throws an error: ```{r, error = TRUE} data.frame(1:2, 1:3) ``` The R language definition states that "any arithmetic operation involving a zero-length vector has a zero-length result". But outside of arithmetic, this rule is not consistently followed: ```{r, error = TRUE} # length-0 output 1:2 + integer() atan2(1:2, integer()) pmax(1:2, integer()) # dropped cbind(1:2, integer()) # recycled to length of first ifelse(rep(TRUE, 4), integer(), character()) # preserved-ish paste(1:2, integer()) # Errors data.frame(1:2, integer()) ``` vctrs/vignettes/s3-vector.Rmd0000644000176200001440000010177613622451540015732 0ustar liggesusers--- title: "S3 vectors" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{S3 vectors} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) set.seed(1014) ``` This vignette shows you how to create your own S3 vector classes. It focuses on the aspects of making a vector class that every class needs to worry about; you'll also need to provide methods that actually make the vector useful. I assume that you're already familiar with the basic machinery of S3, and the vocabulary I use in Advanced R: constructor, helper, and validator. If not, I recommend reading at least the first two sections of [the S3 chapter](https://adv-r.hadley.nz/s3.html) of _Advanced R_. ```{r setup} library(vctrs) library(zeallot) ``` This vignette works through five big topics: * The basics of creating a new vector class with vctrs. * The coercion and casting system. * The record and list-of types. * Equality and comparison proxies. * Arithmetic operators. They're collectively demonstrated with a number of simple S3 classes: * Percent: a double vector that prints as a percentage. This illustrates the basic mechanics of class creation, coercion, and casting. * Decimal: a double vector that always prints with a fixed number of decimal places. This class has an attribute which needs a little extra care in casts and coercions. * Cached sum: a double vector that caches the total sum in an attribute. The attribute depends on the data, so needs extra care. * Rational: a pair of integer vectors that defines a rational number like `2 / 3`. This introduces you to the record style, and to the equality and comparison operators. It also needs special handling for `+`, `-`, and friends. * Polynomial: a list of integer vectors that define polynomials like `1 + x - x^3`. Sorting such vectors correctly requires a custom equality method. * Meter: a numeric vector with meter units. This is the simplest possible class with interesting algebraic properties. * Period and frequency: a pair of classes represent a period, or it's inverse, frequency. This allows us to explore more arithmetic operators. ## Basics In this section you'll learn how to create a new vctrs class by calling `new_vctr()`. This creates an object with class `vctrs_vctr` which has a number of methods. These are designed to make your life as easy as possible. For example: * The `print()` and `str()` methods are defined in terms of `format()` so you get a pleasant, consistent display as soon as you've made your `format()` method. * You can immediately put your new vector class in a data frame because `as.data.frame.vctrs_vctr()` does the right thing. * Subsetting (`[`, `[[`, and `$`), `length<-`, and `rep()` methods automatically preserve attributes because they use `vec_restore()`. A default `vec_restore()` works for all classes where the attributes are data-independent, and can easily be customised when the attributes do depend on the data. * Default subset-assignment methods (`[<-`, `[[<-`, and `$<-`) follow the principle that the new values should be coerced to match the existing vector. This gives predictable behaviour and clear error messages. ### Percent class In this section, I'll show you how to make a `percent` class, i.e., a double vector that is printed as a percentage. We start by defining a low-level [constructor](https://adv-r.hadley.nz/s3.html#s3-constrcutor) that uses `vec_assert()` to checks types and/or sizes then calls `new_vctr()`. `percent` is built on a double vector of any length and doesn't have any attributes. ```{r} new_percent <- function(x = double()) { vec_assert(x, double()) new_vctr(x, class = "vctrs_percent") } x <- new_percent(c(seq(0, 1, length = 4), NA)) x str(x) ``` Note that we prefix the name of the class with the name of the package. This prevents conflicting definitions between packages. For packages that implement only one class (such as [blob](https://blob.tidyverse.org/)), it's fine to use the package name without prefix as the class name. We then follow up with a user friendly [helper](https://adv-r.hadley.nz/s3.html#helpers). Here we'll use `vec_cast()` to allow it to accept anything coercible to a double: ```{r} percent <- function(x = double()) { x <- vec_cast(x, double()) new_percent(x) } ``` Before you go on, check that user-friendly constructor returns a zero-length vector when called with no arguments. This makes it easy to use as a prototype. ```{r} new_percent() percent() ``` Add a call to `setOldClass()` for compatibility with the S4 system: ```{r} #' @importFrom methods setOldClass methods::setOldClass(c("vctrs_percent", "vctrs_vctr")) ``` For the convenience of your users, consider implementing an `is_percent()` function: ```{r} is_percent <- function(x) { inherits(x, "vctrs_percent") } ``` ### `format()` method The first method for every class should almost always be a `format()` method. This should return a character vector the same length as `x`. The easiest way to do this is to rely on one of R's low-level formatting functions like `formatC()`: ```{r} format.vctrs_percent <- function(x, ...) { out <- formatC(signif(vec_data(x) * 100, 3)) out[is.na(x)] <- NA out[!is.na(x)] <- paste0(out[!is.na(x)], "%") out } ``` ```{r, include = FALSE} # As of R 3.5, print.vctr can not find format.percent since it's not in # it's lexical environment. We fix that problem by manually registering. s3_register("base::format", "vctrs_percent") ``` ```{r} x ``` (Note the use of `vec_data()` so `format()` doesn't get stuck in an infinite loop, and that I take a little care to not convert `NA` to `"NA"`; this leads to better printing.) The format method is also used by data frames, tibbles, and `str()`: ```{r} data.frame(x) ``` For optimal display, I recommend also defining an abbreviated type name, which should be 4-5 letters for commonly used vectors. This is used in tibbles and in `str()`: ```{r} vec_ptype_abbr.vctrs_percent <- function(x, ...) { "prcnt" } tibble::tibble(x) str(x) ``` If you need more control over printing in tibbles, implement a method for `pillar::pillar_shaft()`. See for details. ## Casting and coercion The next set of methods you are likely to need are those related to coercion and casting. Coercion and casting are two sides of the same coin: changing the prototype of an existing object. When the change happens _implicitly_ (e.g in `c()`) we call it __coercion__; when the change happens _explicitly_ (e.g. with `as.integer(x)`), we call it __casting__. One of the main goals of vctrs is to put coercion and casting on a robust theoretical footing so it's possible to make accurate predictions about what (e.g.) `c(x, y)` should do when `x` and `y` have different prototypes. vctrs achieves this goal through two generics: * `vec_ptype2(x, y)` defines possible set of coercions. It returns a prototype if `x` and `y` can be safely coerced to the same prototype; otherwise it returns an error. The set of automatic coercions is usually quite small because too many tend to make code harder to reason about and silently propagate mistakes. * `vec_cast(x, to)` defines the possible sets of casts. It returns `x` translated to have prototype `to`, or throws an error if the conversion isn't possible. The set of possible casts is a superset of possible coercions because they're requested explicitly. ### Double dispatch Both generics use __[double dispatch](https://en.wikipedia.org/wiki/Double_dispatch)__ which means that the implementation is selected based on the class of two arguments, not just one. S3 does not natively support double dispatch, but we can implement with a trick: doing single dispatch twice. In practice, this means you end up with method names with two classes, like `vec_ptype2.foo.bar()`, and you need a little boilerplate to get started. The key idea that makes double dispatch work without any modifications to S3 is that a function (like `vec_ptype2.foo()`) can be both an S3 generic and an S3 method. ```{r} vec_ptype2.MYCLASS <- function(x, y, ...) UseMethod("vec_ptype2.MYCLASS", y) vec_ptype2.MYCLASS.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } vec_cast.MYCLASS <- function(x, to, ...) UseMethod("vec_cast.MYCLASS") vec_cast.MYCLASS.default <- function(x, to, ...) vec_default_cast(x, to) ``` We'll discuss what this boilerplate does in the upcoming sections; just remember you'll always need to copy and paste it when creating a new S3 class. ### Percent class {#percent} We'll make our percent class coercible back and forth with double vectors. I'll start with the boilerplate for `vec_ptype2()`: ```{r} vec_ptype2.vctrs_percent <- function(x, y, ...) UseMethod("vec_ptype2.vctrs_percent", y) vec_ptype2.vctrs_percent.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } ``` ```{r, include = FALSE} s3_register("vctrs::vec_ptype2", "vctrs_percent") ``` The default method provides a user friendly error message if the coercion doesn't exist and makes sure `NA` is handled in a standard way. `NA` is technically a logical vector, but we want to stand in for a missing value of any type. ```{r, error = TRUE} vec_ptype2("bogus", percent()) vec_ptype2(percent(), NA) vec_ptype2(NA, percent()) ``` Next, start by saying that a `vctrs_percent` combined with a `vctrs_percent` yields a `vctrs_percent`, which we indicate by returning a prototype generated by the constructor. ```{r} vec_ptype2.vctrs_percent.vctrs_percent <- function(x, y, ...) new_percent() ``` Next we define methods that say that combining a `percent` and double should yield a `double`. We avoid returning a `percent` here because errors in the scale (1 vs. 0.01) are more obvious with raw numbers. Because double dispatch is a bit of a hack, we need to provide two methods. It's your responsibility to ensure that each pair return the same result: if they don't you will get weird and unpredictable behaviour. ```{r} vec_ptype2.vctrs_percent.double <- function(x, y, ...) double() vec_ptype2.double.vctrs_percent <- function(x, y, ...) double() ``` We can check that we've implemented this correctly with `vec_ptype_show()`: ```{r} vec_ptype_show(percent(), double(), percent()) ``` Next we implement explicit casting, again starting with the boilerplate: ```{r} vec_cast.vctrs_percent <- function(x, to, ...) UseMethod("vec_cast.vctrs_percent") vec_cast.vctrs_percent.default <- function(x, to, ...) vec_default_cast(x, to) ``` ```{r, include = FALSE} s3_register("vctrs::vec_cast", "vctrs_percent") ``` Then providing a method to coerce a percent to a percent: ```{r} vec_cast.vctrs_percent.vctrs_percent <- function(x, to, ...) x ``` And then for converting back and forth between doubles. To convert a double to a percent we use the `percent()` helper (not the constructor; this is unvalidated user input). To convert a `percent` to a double, we strip the attributes. ```{r} vec_cast.vctrs_percent.double <- function(x, to, ...) percent(x) vec_cast.double.vctrs_percent <- function(x, to, ...) vec_data(x) ``` Then we can check this works with `vec_cast()`: ```{r} vec_cast(0.5, percent()) vec_cast(percent(0.5), double()) ``` Once you've implemented `vec_ptype2()` and `vec_cast()` you get `vec_c()`, `[<-`, and `[[<-` implementations for free. ```{r, error = TRUE} vec_c(percent(0.5), 1) vec_c(NA, percent(0.5)) # but vec_c(TRUE, percent(0.5)) x <- percent(c(0.5, 1, 2)) x[1:2] <- 2:1 x[[3]] <- 0.5 x ``` You'll also get mostly correct behaviour for `c()`. The exception is when you use `c()` with a base R class: ```{r, error = TRUE} # Correct c(percent(0.5), 1) c(percent(0.5), factor(1)) # Incorrect c(factor(1), percent(0.5)) ``` Unfortunately there's no way to fix this problem with the current design of `c()`. Again, as a convenience, consider providing an `as_percent()` function that makes use of the casts defined in your `vec_cast.vctrs_percent()` methods: ```{r} as_percent <- function(x) { vec_cast(x, new_percent()) } ``` ### Decimal class Now that you've seen the basics with a very simple S3 class, we'll gradually explore more complicated scenarios. This section creates a `decimal` class that prints with the specified number of decimal places. This is very similar to `percent` but now the class needs an attribute: the number of decimal places to display (an integer vector of length 1). We start of as before, defining a low-level constructor, a user-friendly constructor, a `format()` method, and a `vec_ptype_abbr()`. Note that additional object attributes are simply passed along to `new_vctr()`: ```{r} new_decimal <- function(x = double(), digits = 2L) { vec_assert(x, ptype = double()) vec_assert(digits, ptype = integer(), size = 1) new_vctr(x, digits = digits, class = "vctrs_decimal") } decimal <- function(x = double(), digits = 2L) { x <- vec_cast(x, double()) digits <- vec_recycle(vec_cast(digits, integer()), 1L) new_decimal(x, digits = digits) } digits <- function(x) attr(x, "digits") format.vctrs_decimal <- function(x, ...) { sprintf(paste0("%-0.", digits(x), "f"), x) } vec_ptype_abbr.vctrs_decimal <- function(x, ...) { paste0("dec") } x <- decimal(runif(10), 1L) x ``` Note that I provide a little helper to extract the `digits` attribute. This makes the code a little easier to read and should not be exported. By default, vctrs assumes that attributes are independent of the data and so are automatically preserved. You'll see what to do if the attributes are data dependent in the next section. ```{r} x[1:2] x[[1]] ``` For the sake of exposition, we'll assume that `digits` is an important attribute of the class and should be included in the full type: ```{r} vec_ptype_full.vctrs_decimal <- function(x, ...) { paste0("decimal<", digits(x), ">") } x ``` Now consider `vec_cast()` and `vec_ptype2()`. I start with the standard recipes: ```{r} vec_ptype2.vctrs_decimal <- function(x, y, ...) UseMethod("vec_ptype2.vctrs_decimal", y) vec_ptype2.vctrs_decimal.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } vec_cast.vctrs_decimal <- function(x, to, ...) UseMethod("vec_cast.vctrs_decimal") vec_cast.vctrs_decimal.default <- function(x, to, ...) vec_default_cast(x, to) ``` Casting and coercing from one decimal to another requires a little thought as the values of the `digits` attribute might be different, and we need some way to reconcile them. Here I've decided to chose the maximum of the two; other reasonable options are to take the value from the left-hand side or throw an error. ```{r} vec_ptype2.vctrs_decimal.vctrs_decimal <- function(x, y, ...) { new_decimal(digits = max(digits(x), digits(y))) } vec_cast.vctrs_decimal.vctrs_decimal <- function(x, to, ...) { new_decimal(vec_data(x), digits = digits(to)) } vec_c(decimal(1/100, digits = 3), decimal(2/100, digits = 2)) ``` Finally, I can implement coercion to and from other types, like doubles. When automatically coercing, I choose the richer type (i.e., the decimal). ```{r} vec_ptype2.vctrs_decimal.double <- function(x, y, ...) x vec_ptype2.double.vctrs_decimal <- function(x, y, ...) y vec_cast.vctrs_decimal.double <- function(x, to, ...) new_decimal(x, digits = digits(to)) vec_cast.double.vctrs_decimal <- function(x, to, ...) vec_data(x) vec_c(decimal(1, digits = 1), pi) vec_c(pi, decimal(1, digits = 1)) ``` If type `x` has greater resolution than `y`, there will be some inputs that lose precision. These should generate errors using `stop_lossy_cast()`. You can see that in action when casting from doubles to integers; only some doubles can become integers without losing resolution. ```{r, error = TRUE} vec_cast(c(1, 2, 10), to = integer()) vec_cast(c(1.5, 2, 10.5), to = integer()) ``` ### Cached sum class {#cached-sum} The next level up in complexity is an object that has data-dependent attributes. To explore this idea we'll create a vector that caches the sum of its values. As usual, we start with low-level and user-friendly constructors: ```{r} new_cached_sum <- function(x = double(), sum = 0L) { vec_assert(x, ptype = double()) vec_assert(sum, ptype = double(), size = 1L) new_vctr(x, sum = sum, class = "vctrs_cached_sum") } cached_sum <- function(x) { x <- vec_cast(x, double()) new_cached_sum(x, sum(x)) } ``` For this class, we can use the default `format()` method, and instead, we'll customise the `obj_print_footer()` method. This is a good place to display user facing attributes. ```{r} obj_print_footer.vctrs_cached_sum <- function(x, ...) { cat("# Sum: ", format(attr(x, "sum"), digits = 3), "\n", sep = "") } x <- cached_sum(runif(10)) x ``` We'll also override `sum()` and `mean()` to use the attribute. This is easiest to do with `vec_math()`, which you'll learn about later. ```{r} vec_math.vctrs_cached_sum <- function(.fn, .x, ...) { cat("Using cache\n") switch(.fn, sum = attr(.x, "sum"), mean = attr(.x, "sum") / length(.x), vec_math_base(.fn, .x, ...) ) } sum(x) ``` As mentioned above, vctrs assumes that attributes are independent of the data. This means that when we take advantage of the default methods, they'll work, but return the incorrect result: ```{r} x[1:2] ``` To fix this, you need to provide a `vec_restore()` method. Note that this method dispatches on the `to` argument. ```{r} vec_restore.vctrs_cached_sum <- function(x, to, ..., i = NULL) { new_cached_sum(x, sum(x)) } x[1] ``` This works because most of the vctrs methods dispatch to the underlying base function by first stripping off extra attributes with `vec_data()` and then reapplying them again with `vec_restore()`. The default `vec_restore()` method copies over all attributes, which is not appropriate when the attributes depend on the data. Note that `vec_restore.class` is subtly different from `vec_cast.class.class()`. `vec_restore()` is used when restoring attributes that have been lost; `vec_cast()` is used for coercions. This is easier to understand with a concrete example. Imagine factors were implemented with `new_vctr()`. `vec_restore.factor()` would restore attributes back to an integer vector, but you would not want to allow manually casting an integer to a factor with `vec_cast()`. ## Record-style objects Record-style objects use a list of equal-length vectors to represent individual components of the object. The best example of this is `POSIXlt`, which underneath the hood is a list of 11 fields like year, month, and day. Record-style classes override `length()` and subsetting methods to conceal this implementation detail. ```{r} x <- as.POSIXlt(ISOdatetime(2020, 1, 1, 0, 0, 1:3)) x length(x) length(unclass(x)) x[[1]] # the first date time unclass(x)[[1]] # the first component, the number of seconds ``` vctrs makes it easy to create new record-style classes using `new_rcrd()`, which has a wide selection of default methods. ### Rational class A fraction, or rational number, can be represented by a pair of integer vectors representing the numerator (the number on top) and the denominator (the number on bottom), where the length of each vector must be the same. To represent such a data structure we turn to a new base data type: the record (or rcrd for short). As usual we start with low-level and user-friendly constructors. The low-level constructor calls `new_rcrd()`, which needs a named list of equal-length vectors. ```{r} new_rational <- function(n = integer(), d = integer()) { vec_assert(n, ptype = integer()) vec_assert(d, ptype = integer()) new_rcrd(list(n = n, d = d), class = "vctrs_rational") } ``` Our user friendly constructor casts `n` and `d` to integers and recycles them to the same length. ```{r} rational <- function(n, d) { c(n, d) %<-% vec_cast_common(n, d, .to = integer()) c(n, d) %<-% vec_recycle_common(n, d) new_rational(n, d) } x <- rational(1, 1:10) ``` Behind the scenes, `x` is a named list with two elements. But those details are hidden so that it behaves like a vector: ```{r} names(x) length(x) ``` To access the underlying fields we need to use `field()` and `fields()`: ```{r} fields(x) field(x, "n") ``` This allows us to create a format method: ```{r} format.vctrs_rational <- function(x, ...) { n <- field(x, "n") d <- field(x, "d") out <- paste0(n, "/", d) out[is.na(n) | is.na(d)] <- NA out } vec_ptype_abbr.vctrs_rational <- function(x, ...) "rtnl" vec_ptype_full.vctrs_rational <- function(x, ...) "rational" x ``` vctrs uses the `format()` method in `str()`, hiding the underlying implementation details from the user: ```{r} str(x) ``` For `rational`, `vec_ptype2()` and `vec_cast()` follow the same pattern as `percent()`. I allow coercion from integer and to doubles. ```{r} vec_ptype2.vctrs_rational <- function(x, y, ...) UseMethod("vec_ptype2.vctrs_rational", y) vec_ptype2.vctrs_rational.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } vec_ptype2.vctrs_rational.vctrs_rational <- function(x, y, ...) new_rational() vec_ptype2.vctrs_rational.integer <- function(x, y, ...) new_rational() vec_ptype2.integer.vctrs_rational <- function(x, y, ...) new_rational() vec_cast.vctrs_rational <- function(x, to, ...) UseMethod("vec_cast.vctrs_rational") vec_cast.vctrs_rational.default <- function(x, to, ...) vec_default_cast(x, to) vec_cast.vctrs_rational.vctrs_rational <- function(x, to, ...) x vec_cast.double.vctrs_rational <- function(x, to, ...) field(x, "n") / field(x, "d") vec_cast.vctrs_rational.integer <- function(x, to, ...) rational(x, 1) vec_c(rational(1, 2), 1L, NA) ``` ### Decimal2 class The previous implementation of `decimal` was built on top of doubles. This is a bad idea because decimal vectors are typically used when you care about precise values (i.e., dollars and cents in a bank account), and double values suffer from floating point problems. A better implementation of a decimal class would be to use pair of integers, one for the value to the left of the decimal point, and the other for the value to the right (divided by a `scale`). The following code is a very quick sketch of how you might start creating such a class: ```{r} new_decimal2 <- function(l, r, scale = 2L) { vec_assert(l, ptype = integer()) vec_assert(r, ptype = integer()) vec_assert(scale, ptype = integer(), size = 1L) new_rcrd(list(l = l, r = r), scale = scale, class = "vctrs_decimal2") } decimal2 <- function(l, r, scale = 2L) { l <- vec_cast(l, integer()) r <- vec_cast(r, integer()) c(l, r) %<-% vec_recycle_common(l, r) scale <- vec_cast(scale, integer()) # should check that r < 10^scale new_decimal2(l = l, r = r, scale = scale) } format.vctrs_decimal2 <- function(x, ...) { val <- field(x, "l") + field(x, "r") / 10^attr(x, "scale") sprintf(paste0("%.0", attr(x, "scale"), "f"), val) } decimal2(10, c(0, 5, 99)) ``` ## Equality and comparison vctrs provides three "proxy" generics. Two of these let you control how your class determines equality and ordering: * `vec_proxy_equal()` returns a data vector suitable for comparison. It underpins `==`, `!=`, `unique()`, `anyDuplicated()`, and `is.na()`. * `vec_proxy_compare()` specifies how to compare the elements of your vector. This proxy is used in `<`, `<=`, `>=`, `>`, `min()`, `max()`, `median()`, `quantile()`, and `xtfrm()` (used in `order()` and `sort()`) methods. By default, `vec_proxy_equal()` and `vec_proxy_compare()` just call `vec_proxy()`. * `vec_proxy()` returns the actual data of a vector. This is useful when you store the data in a field of your class. Most of the time, you shouldn't need to implement `vec_proxy()`. You should only implement these proxies when some preprocessing on the data is needed to make elements comparable. In that case, defining these methods will get you a lot of behaviour for relatively little work. These proxy functions should always return a simple object (either a bare vector or a data frame) that possesses the same properties as your class. This permits efficient implementation of the vctrs internals because it allows dispatch to happen once in R, and then efficient computations can be written in C. ### Rational class Let's explore these ideas by with the rational class we started on above. By default, `vec_proxy()` converts a record to a data frame, and the default comparison works column by column: ```{r} x <- rational(c(1, 2, 1, 2), c(1, 1, 2, 2)) x vec_proxy(x) x == rational(1, 1) ``` This makes sense as a default but isn't correct here because `rational(1, 1)` represents the same number as `rational(2, 2)`, so they should be equal. We can fix that by implementing a `vec_proxy_equal()` method that divides `n` and `d` by their greatest common divisor: ```{r} # Thanks to Matthew Lundberg: https://stackoverflow.com/a/21504113/16632 gcd <- function(x, y) { r <- x %% y ifelse(r, gcd(y, r), y) } vec_proxy_equal.vctrs_rational <- function(x, ...) { n <- field(x, "n") d <- field(x, "d") gcd <- gcd(n, d) data.frame(n = n / gcd, d = d / gcd) } vec_proxy(x) x == rational(1, 1) ``` `vec_proxy_equal()` is also used by `unique()`: ```{r} unique(x) ``` We now need to fix `sort()` similarly, since it currently sorts by `n`, then by `d`: ```{r} sort(x) ``` The easiest fix is to convert the fraction to a decimal and then sort that: ```{r} vec_proxy_compare.vctrs_rational <- function(x, ...) { field(x, "n") / field(x, "d") } sort(x) ``` (We could have used the same approach in `vec_proxy_equal()`, but when working with floating point numbers it's not necessarily true that `x == y` implies that `d * x == d * y`.) ### Polynomial class A related problem occurs if we build our vector on top of a list. The following code defines a polynomial class that represents polynomials (like `1 + 3x - 2x^2`) using a list of integer vectors (like `c(1, 3, -2)`). Note the use of `new_list_of()` in the constructor. ```{r} new_poly <- function(x) { new_list_of(x, ptype = integer(), class = "vctrs_poly") } poly <- function(...) { x <- list(...) x <- lapply(x, vec_cast, integer()) new_poly(x) } vec_ptype_full.vctrs_poly <- function(x, ...) "polynomial" vec_ptype_abbr.vctrs_poly <- function(x, ...) "poly" format.vctrs_poly <- function(x, ...) { format_one <- function(x) { if (length(x) == 0) { return("") } else if (length(x) == 1) { format(x) } else { suffix <- c(paste0("\u22C5x^", seq(length(x) - 1, 1)), "") out <- paste0(x, suffix) out <- out[x != 0L] paste0(out, collapse = " + ") } } vapply(x, format_one, character(1)) } obj_print_data.vctrs_poly <- function(x, ...) { if (length(x) == 0) return() print(format(x), quote = FALSE) } p <- poly(1, c(1, 0, 1), c(1, 0, 0, 0, 2)) p ``` The resulting objects will inherit from the `vctrs_list_of` class, which provides tailored methods for `$`, `[[`, the corresponding assignment operators, and other methods. ```{r} class(p) p[2] p[[2]] ``` Equality works out of the box because we can tell if two integer vectors are equal: ```{r} p == poly(c(1, 0, 1)) ``` But we can't order them because lists are not comparable: ```{r, error = TRUE} sort(p) ``` So we need to define a `vec_proxy_compare()` method: ```{r} vec_proxy_compare.vctrs_poly <- function(x, ...) { x_raw <- vec_data(x) # First figure out the maximum length n <- max(vapply(x_raw, length, integer(1))) # Then expand all vectors to this length by filling in with zeros full <- lapply(x_raw, function(x) c(rep(0L, n - length(x)), x)) # Then turn into a data frame as.data.frame(do.call(rbind, full)) } sort(poly(3, 2, 1)) sort(poly(1, c(1, 0, 0), c(1, 0))) ``` ## Arithmetic vctrs also provides two mathematical generics that allow you to define a broad swath of mathematical behaviour at once: * `vec_math(fn, x, ...)` specifies the behaviour of mathematical functions like `abs()`, `sum()`, and `mean()`. (See `?vec_math()` for the complete list.) * `vec_arith(op, x, y)` specifies the behaviour of the arithmetic operations like `+`, `-`, and `%%`. (See `?vec_arith()` for the complete list.) Both generics define the behaviour for multiple functions because `sum.vctrs_vctr(x)` calls `vec_math.vctrs_vctr("sum", x)`, and `x + y` calls `vec_math.x_class.y_class("+", x, y)`. They're accompanied by `vec_math_base()` and `vec_arith_base()` which make it easy to call the underlying base R functions. `vec_arith()` uses double dispatch and needs the following standard boilerplate: ```{r} vec_arith.MYCLASS <- function(op, x, y, ...) { UseMethod("vec_arith.MYCLASS", y) } vec_arith.MYCLASS.default <- function(op, x, y, ...) { stop_incompatible_op(op, x, y) } ``` ### Cached sum class I showed an example of `vec_math()` to define `sum()` and `mean()` methods for `cached_sum`. Now let's talk about exactly how it works. Most `vec_math()` functions will have a similar form. You use a switch statement to handle the methods that you care about and fall back to `vec_math_base()` for those that you don't care about. ```{r} vec_math.vctrs_cached_sum <- function(.fn, .x, ...) { switch(.fn, sum = attr(.x, "sum"), mean = attr(.x, "sum") / length(.x), vec_math_base(.fn, .x, ...) ) } ``` ### Meter class To explore the infix arithmetic operators exposed by `vec_arith()` I'll create a new class that represents a measurement in `meter`s: ```{r} new_meter <- function(x) { stopifnot(is.double(x)) new_vctr(x, class = "vctrs_meter") } format.vctrs_meter <- function(x, ...) { paste0(format(vec_data(x)), " m") } meter <- function(x) { x <- vec_cast(x, double()) new_meter(x) } x <- meter(1:10) x ``` Because `meter` is built on top of a double vector, basic mathematic operations work: ```{r} sum(x) mean(x) ``` But we can't do arithmetic: ```{r, error = TRUE} x + 1 meter(10) + meter(1) meter(10) * 3 ``` To allow these infix functions to work, we'll need to provide `vec_arith()` generic. But before we do that, let's think about what combinations of inputs we should support: * It makes sense to add and subtract meters: that yields another meter. We can divide a meter by another meter (yielding a unitless number), but we can't multiply meters (because that would yield an area). * For a combination of meter and number multiplication and division by a number are acceptable. Addition and subtraction don't make much sense as we, strictly speaking, are dealing with objects of different nature. `vec_arith()` is another function that uses double dispatch, so as usual we start with a template. ```{r} vec_arith.vctrs_meter <- function(op, x, y, ...) { UseMethod("vec_arith.vctrs_meter", y) } vec_arith.vctrs_meter.default <- function(op, x, y, ...) { stop_incompatible_op(op, x, y) } ``` Then write the method for two meter objects. We use a switch statement to cover the cases we care about and `stop_incompatible_op()` to throw an informative error message for everything else. ```{r, error = TRUE} vec_arith.vctrs_meter.vctrs_meter <- function(op, x, y, ...) { switch( op, "+" = , "-" = new_meter(vec_arith_base(op, x, y)), "/" = vec_arith_base(op, x, y), stop_incompatible_op(op, x, y) ) } meter(10) + meter(1) meter(10) - meter(1) meter(10) / meter(1) meter(10) * meter(1) ``` Next we write the pair of methods for arithmetic with a meter and a number. These are almost identical, but while `meter(10) / 2` makes sense, `2 / meter(10)` does not (and neither do addition and subtraction). ```{r, error = TRUE} vec_arith.vctrs_meter.numeric <- function(op, x, y, ...) { switch( op, "/" = , "*" = new_meter(vec_arith_base(op, x, y)), stop_incompatible_op(op, x, y) ) } vec_arith.numeric.vctrs_meter <- function(op, x, y, ...) { switch( op, "*" = new_meter(vec_arith_base(op, x, y)), stop_incompatible_op(op, x, y) ) } meter(2) * 10 10 * meter(2) meter(20) / 10 10 / meter(20) meter(20) + 10 ``` For completeness, we also need `vec_arith.vctrs_meter.MISSING` for the unary `+` and `-` operators: ```{r} vec_arith.vctrs_meter.MISSING <- function(op, x, y, ...) { switch(op, `-` = x * -1, `+` = x, stop_incompatible_op(op, x, y) ) } -meter(1) +meter(1) ``` ## Appendix: `NAMESPACE` declarations Defining S3 methods interactively is fine for iteration and exploration, but if your vector lives in a package, you also need to register the S3 methods by listing them in the `NAMESPACE` file. The namespace declarations are a little tricky because (e.g.) `vec_cast.vctrs_percent()` is both a generic function (which must be exported with `export()`) and an S3 method (which must be registered with `S3method()`). This problem wasn't considered in the design of roxygen2, so you have to be quite explicit: ```{r} #' @method vec_cast vctrs_percent #' @export #' @export vec_cast.vctrs_percent vec_cast.vctrs_percent <- function(x, to, ...) { } ``` You also need to register the individual double-dispatch methods. Again, this is harder than it should be because roxygen's heuristics aren't quite right. That means you need to describe the `@method` explicitly: ```{r} #' @method vec_cast.binned double #' @export vec_cast.binned.double <- function(x, y, ...) { } ``` Hopefully future versions of roxygen will make these exports less painful. vctrs/vignettes/stability.Rmd0000644000176200001440000003107313622451540016101 0ustar liggesusers--- title: "Type and size stability" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Type and size stability} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` This vignette introduces the ideas of type-stability and size-stability. If a function possesses these properties, it is substantially easier to reason about because to predict the "shape" of the output you only need to know the "shape"s of the inputs. This work is partly motivated by a common pattern that I noticed when reviewing code: if I read the code (without running it!), and I can't predict the type of each variable, I feel very uneasy about the code. This sense is important because most unit tests explore typical inputs, rather than exhaustively testing the strange and unusual. Analysing the types (and size) of variables makes it possible to spot unpleasant edge cases. ```{r setup} library(vctrs) library(zeallot) ``` ## Definitions We say a function is __type-stable__ iff: 1. You can predict the output type knowing only the input types. 1. The order of arguments in ... does not affect the output type. Similarly, a function is __size-stable__ iff: 1. You can predict the output size knowing only the input sizes, or there is a single numeric input that specifies the output size. Very few base R functions are size-stable, so I'll also define a slightly weaker condition. I'll call a function __length-stable__ iff: 1. You can predict the output _length_ knowing only the input _lengths_, or there is a single numeric input that specifies the output _length_. (But note that length-stable is not a particularly robust definition because `length()` returns a value for things that are not vectors.) We'll call functions that don't obey these principles __type-unstable__ and __size-unstable__ respectively. On top of type- and size-stability it's also desirable to have a single set of rules that are applied consistently. We want one set of type-coercion and size-recycling rules that apply everywhere, not many sets of rules that apply to different functions. The goal of these principles is to minimise cognitive overhead. Rather than having to memorise many special cases, you should be able to learn one set of principles and apply them again and again. ### Examples To make these ideas concrete, let's apply them to a few base functions: 1. `mean()` is trivially type-stable and size-stable because it always returns a double vector of length 1 (or it throws an error). 1. Surprisingly, `median()` is type-unstable: ```{r} vec_ptype_show(median(c(1L, 1L))) vec_ptype_show(median(c(1L, 1L, 1L))) ``` It is, however, size-stable, since it always returns a vector of length 1. 1. `sapply()` is type-unstable because you can't predict the output type only knowing the input types: ```{r} vec_ptype_show(sapply(1L, function(x) c(x, x))) vec_ptype_show(sapply(integer(), function(x) c(x, x))) ``` It's not quite size-stable; `vec_size(sapply(x, f))` is `vec_size(x)` for vectors but not for matrices (the output is transposed) or data frames (it iterates over the columns). 1. `vapply()` is a type-stable version of `sapply()` because `vec_ptype_show(vapply(x, fn, template))` is always `vec_ptype_show(template)`. It is size-unstable for the same reasons as `sapply()`. 1. `c()` is type-unstable because `c(x, y)` doesn't always output the same type as `c(y, x)`. ```{r} vec_ptype_show(c(NA, Sys.Date())) vec_ptype_show(c(Sys.Date(), NA)) ``` `c()` is *almost always* length-stable because `length(c(x, y))` *almost always* equals `length(x) + length(y)`. One common source of instability here is dealing with non-vectors (see the later section "Non-vectors"): ```{r} env <- new.env(parent = emptyenv()) length(env) length(mean) length(c(env, mean)) ``` 1. `paste(x1, x2)` is length-stable because `length(paste(x1, x2))` equals `max(length(x1), length(x2))`. However, it doesn't follow the usual arithmetic recycling rules because `paste(1:2, 1:3)` doesn't generate a warning. 1. `ifelse()` is length-stable because `length(ifelse(cond, true, false))` is always `length(cond)`. `ifelse()` is type-unstable because the output type depends on the value of `cond`: ```{r} vec_ptype_show(ifelse(NA, 1L, 1L)) vec_ptype_show(ifelse(FALSE, 1L, 1L)) ``` 1. `read.csv(file)` is type-unstable and size-unstable because, while you know it will return a data frame, you don't know what columns it will return or how many rows it will have. Similarly, `df[[i]]` is not type-stable because the result depends on the _value_ of `i`. There are very many important functions that can not be made type-stable or size-stable! With this understanding of type- and size-stability in hand, we'll use them to analyse some base R functions in greater depth and then propose alternatives with better properties. ## `c()` and `vctrs::vec_c()` In this section we'll compare and contrast `c()` and `vec_c()`. `vec_c()` is both type- and size-stable because it possesses the following invariants: * `vec_ptype(vec_c(x, y))` equals `vec_ptype_common(x, y)`. * `vec_size(vec_c(x, y))` equals `vec_size(x) + vec_size(y)`. `c()` has another undesirable property in that it's not consistent with `unlist()`; i.e., `unlist(list(x, y))` does not always equal `c(x, y)`; i.e., base R has multiple sets of type-coercion rules. I won't consider this problem further here. I have two goals here: * To fully document the quirks of `c()`, hence motivating the development of an alternative. * To discuss non-obvious consequences of the type- and size-stability above. ### Atomic vectors If we only consider atomic vectors, `c()` is type-stable because it uses a hierarchy of types: character > complex > double > integer > logical. ```{r} c(FALSE, 1L, 2.5) ``` `vec_c()` obeys similar rules: ```{r} vec_c(FALSE, 1L, 2.5) ``` But it does not automatically coerce to character vectors or lists: ```{r, error = TRUE} c(FALSE, "x") vec_c(FALSE, "x") c(FALSE, list(1)) vec_c(FALSE, list(1)) ``` ### Non-vectors As far as I can tell, `c()` never throws an error. No matter how bizarre the inputs, it always returns something: ```{r} c(Sys.Date(), factor("x"), "x") ``` If the inputs aren't vectors, `c()` automatically puts them in a list: ```{r} c(mean, globalenv()) ``` `vec_c()` throws an error if the inputs are not vectors or not automatically coercible: ```{r, error = TRUE} vec_c(mean, globalenv()) vec_c(Sys.Date(), factor("x"), "x") ``` ### Factors Combining two factors returns an integer vector: ```{r} fa <- factor("a") fb <- factor("b") c(fa, fb) ``` (This is documented in `c()` but is still undesirable.) `vec_c()` returns a factor taking the union of the levels. This behaviour is motivated by pragmatics: there are many places in base R that automatically convert character vectors to factors, so enforcing stricter behaviour would be unnecessarily onerous. (This is backed up by experience with `dplyr::bind_rows()`, which is stricter and is a common source of user difficulty.) ```{r} vec_c(fa, fb) vec_c(fb, fa) ``` ### Date-times `c()` strips the time zone associated with date-times: ```{r} datetime_nz <- as.POSIXct("2020-01-01 09:00", tz = "Pacific/Auckland") c(datetime_nz) ``` This behaviour is documented in `?DateTimeClasses` but is the source of considerable user pain. `vec_c()` preserves time zones: ```{r} vec_c(datetime_nz) ``` What time zone should the output have if inputs have different time zones? One option would be to be strict and force the user to manually align all the time zones. However, this is onerous (particularly because there's no easy way to change the time zone in base R), so vctrs chooses to use the first non-local time zone: ```{r} datetime_local <- as.POSIXct("2020-01-01 09:00") datetime_houston <- as.POSIXct("2020-01-01 09:00", tz = "US/Central") vec_c(datetime_local, datetime_houston, datetime_nz) vec_c(datetime_houston, datetime_nz) vec_c(datetime_nz, datetime_houston) ``` ### Dates and date-times Combining dates and date-times with `c()` gives silently incorrect results: ```{r} date <- as.Date("2020-01-01") datetime <- as.POSIXct("2020-01-01 09:00") c(date, datetime) c(datetime, date) ``` This behaviour arises because neither `c.Date()` nor `c.POSIXct()` check that all inputs are of the same type. `vec_c()` uses a standard set of rules to avoid this problem. When you mix dates and date-times, vctrs returns a date-time and converts dates to date-times at midnight (in the timezone of the date-time). ```{r} vec_c(date, datetime) vec_c(date, datetime_nz) ``` ### Missing values If a missing value comes at the beginning of the inputs, `c()` falls back to the internal behaviour, which strips all attributes: ```{r} c(NA, fa) c(NA, date) c(NA, datetime) ``` `vec_c()` takes a different approach treating a logical vector consisting only of `NA` as the `unspecified()` class which can be converted to any other 1d type: ```{r} vec_c(NA, fa) vec_c(NA, date) vec_c(NA, datetime) ``` ### Data frames Because it is *almost always* length-stable, `c()` combines data frames column wise (into a list): ```{r} df1 <- data.frame(x = 1) df2 <- data.frame(x = 2) str(c(df1, df1)) ``` `vec_c()` is size-stable, which implies it will row-bind data frames: ```{r} vec_c(df1, df2) ``` ### Matrices and arrays The same reasoning applies to matrices: ```{r} m <- matrix(1:4, nrow = 2) c(m, m) vec_c(m, m) ``` One difference is that `vec_c()` will "broadcast" a vector to match the dimensions of a matrix: ```{r} c(m, 1) vec_c(m, 1) ``` ### Implementation The basic implementation of `vec_c()` is reasonably simple. We first figure out the properties of the output, i.e. the common type and total size, and then allocate it with `vec_init()`, and then insert each input into the correct place in the output. ```{r, eval = FALSE} vec_c <- function(...) { args <- compact(list2(...)) ptype <- vec_ptype_common(!!!args) if (is.null(ptype)) return(NULL) ns <- map_int(args, vec_size) out <- vec_init(ptype, sum(ns)) pos <- 1 for (i in seq_along(ns)) { n <- ns[[i]] x <- vec_cast(args[[i]], to = ptype) vec_slice(out, pos:(pos + n - 1)) <- x pos <- pos + n } out } ``` (The real `vec_c()` is a bit more complicated in order to handle inner and outer names). ## `ifelse()` One of the functions that motivate the development of vctrs is `ifelse`. It has the surprising property that the result value is "A vector of the same length and attributes (including dimensions and class) as `test`". To me, it seems more reasonable for the type of the output to be controlled by the type of the `yes` and `no` arguments. In `dplyr::if_else()` I swung too far towards strictness: it throws an error if `yes` and `no` are not the same type. This is annoying in practice because it requires typed missing values (`NA_character_` etc), and because the checks are only on the class (not the full prototype), it's easy to create invalid output. I found it much easier understand what `ifelse()` _should_ do once I internalised the ideas of type- and size-stability: * The first argument must be logical. * `vec_ptype(if_else(test, yes, no))` equals `vec_ptype_common(yes, no)`. Unlike `ifelse()` this implies that `if_else()` must always evaluate both `yes` and `no` in order to figure out the correct type. I think this is consistent with `&&` (scalar operation, short circuits) and `&` (vectorised, evaluates both sides). * `vec_size(if_else(test, yes, no))` equals `vec_size_common(test, yes, no)`. I think the output could have the same size as `test` (i.e., the same behaviour as `ifelse`), but I _think_ as a general rule that your inputs should either be mutually recycling or not. This leads to the following implementation: ```{r} if_else <- function(test, yes, no) { vec_assert(test, logical()) c(yes, no) %<-% vec_cast_common(yes, no) c(test, yes, no) %<-% vec_recycle_common(test, yes, no) out <- vec_init(yes, vec_size(yes)) vec_slice(out, test) <- vec_slice(yes, test) vec_slice(out, !test) <- vec_slice(no, !test) out } x <- c(NA, 1:4) if_else(x > 2, "small", "big") if_else(x > 2, factor("small"), factor("big")) if_else(x > 2, Sys.Date(), Sys.Date() + 7) ``` By using `vec_size()` and `vec_slice()`, this definition of `if_else()` automatically works with data.frames and matrices: ```{r} if_else(x > 2, data.frame(x = 1), data.frame(y = 2)) if_else(x > 2, matrix(1:10, ncol = 2), cbind(30, 30)) ``` vctrs/R/0000755000176200001440000000000013623203271011613 5ustar liggesusersvctrs/R/partial-factor.R0000644000176200001440000000540713622451540014657 0ustar liggesusers#' Partially specify a factor #' #' This special class can be passed as a `ptype` in order to specify that the #' result should be a factor that contains at least the specified levels. #' #' @inheritParams new_factor #' @export #' @examples #' # Assert that `x` is a factor #' vec_assert(factor("x"), partial_factor()) #' #' # Testing with `factor()` is too strict, #' # because it tries to match the levels exactly #' # rather than learning them from the data. #' try(vec_assert(factor("x"), factor())) #' #' # You can also enforce a minimum set of levels #' try(vec_assert(factor("x"), partial_factor("y"))) #' #' vec_assert(factor(c("x", "y")), partial_factor("y")) #' #' pf <- partial_factor(levels = c("x", "y")) #' pf #' #' vec_ptype_common(factor("v"), factor("w"), .ptype = pf) #' partial_factor <- function(levels = character()) { partial <- new_factor(levels = levels) new_partial_factor(partial) } new_partial_factor <- function(partial = factor(), learned = factor()) { stopifnot( is.factor(partial), is.factor(learned) ) # Fails if `learned` is not compatible with `partial` vec_ptype2(partial, learned) new_partial( partial = partial, learned = learned, class = "vctrs_partial_factor" ) } #' @export vec_ptype_full.vctrs_partial_factor <- function(x, ...) { empty <- "" levels <- map(x, levels) hashes <- map_chr(levels, hash_label) needs_indent <- hashes != empty hashes[needs_indent] <- map_chr(hashes[needs_indent], function(x) paste0(" ", x)) source <- rep_named(names(hashes), empty) if (hashes["partial"] != empty) { source["partial"] <- " {partial}" } details <- paste0(hashes, source) details <- details[details != empty] paste0( "partial_factor<\n", paste0(details, collapse = "\n"), "\n>" ) } #' @export vec_ptype_abbr.vctrs_partial_factor <- function(x, ...) { "prtl_fctr" } #' @method vec_ptype2 vctrs_partial_factor #' @export vec_ptype2.vctrs_partial_factor <- function(x, y, ...) { UseMethod("vec_ptype2.vctrs_partial_factor", y) } #' @method vec_ptype2.vctrs_partial_factor vctrs_partial_factor #' @export vec_ptype2.vctrs_partial_factor.vctrs_partial_factor <- function(x, y, ...) { partial <- vec_ptype2(x$partial, y$partial) learned <- vec_ptype2(x$learned, y$learned) new_partial_factor(partial, learned) } #' @method vec_ptype2.vctrs_partial_factor factor #' @export vec_ptype2.vctrs_partial_factor.factor <- function(x, y, ...) { new_partial_factor(x$partial, vec_ptype2(x$learned, y)) } #' @method vec_ptype2.factor vctrs_partial_factor #' @export vec_ptype2.factor.vctrs_partial_factor <- function(x, y, ...) { new_partial_factor(y$partial, vec_ptype2(y$learned, x)) } #' @export vec_ptype_finalise.vctrs_partial_factor <- function(x, ...) { vec_ptype2(x$learned, x$partial) } vctrs/R/names.R0000644000176200001440000004072213622451540013051 0ustar liggesusers#' Retrieve and repair names #' #' @description #' #' `vec_as_names()` takes a character vector of names and repairs it #' according to the `repair` argument. It is the r-lib and tidyverse #' equivalent of [base::make.names()]. #' #' vctrs deals with a few levels of name repair: #' #' * `minimal` names exist. The `names` attribute is not `NULL`. The #' name of an unnamed element is `""` and never `NA`. For instance, #' `vec_as_names()` always returns minimal names and data frames #' created by the tibble package have names that are, at least, #' `minimal`. #' #' * `unique` names are `minimal`, have no duplicates, and can be used #' where a variable name is expected. Empty names, `...`, and #' `..` followed by a sequence of digits are banned. #' #' - All columns can be accessed by name via `df[["name"]]` and #' ``df$`name` `` and ``with(df, `name`)``. #' #' * `universal` names are `unique` and syntactic (see Details for #' more). #' #' - Names work everywhere, without quoting: `df$name` and `with(df, #' name)` and `lm(name1 ~ name2, data = df)` and #' `dplyr::select(df, name)` all work. #' #' `universal` implies `unique`, `unique` implies `minimal`. These #' levels are nested. #' #' #' @param names A character vector. #' @param repair Either a string or a function. If a string, it must #' be one of `"check_unique"`, `"minimal"`, `"unique"`, or `"universal"`. #' If a function, it is invoked with a vector of minimal names and must #' return minimal names, otherwise an error is thrown. #' #' * Minimal names are never `NULL` or `NA`. When an element doesn't #' have a name, its minimal name is an empty string. #' #' * Unique names are unique. A suffix is appended to duplicate #' names to make them unique. #' #' * Universal names are unique and syntactic, meaning that you can #' safely use the names as variables without causing a syntax #' error. #' #' The `"check_unique"` option doesn't perform any name repair. #' Instead, an error is raised if the names don't suit the #' `"unique"` criteria. #' @param quiet By default, the user is informed of any renaming #' caused by repairing the names. This only concerns unique and #' universal repairing. Set `quiet` to `TRUE` to silence the #' messages. #' @inheritParams ellipsis::dots_empty #' #' @section `minimal` names: #' #' `minimal` names exist. The `names` attribute is not `NULL`. The #' name of an unnamed element is `""` and never `NA`. #' #' Examples: #' #' ``` #' Original names of a vector with length 3: NULL #' minimal names: "" "" "" #' #' Original names: "x" NA #' minimal names: "x" "" #' ``` #' #' #' @section `unique` names: #' #' `unique` names are `minimal`, have no duplicates, and can be used #' (possibly with backticks) in contexts where a variable is #' expected. Empty names, `...`, and `..` followed by a sequence of #' digits are banned. If a data frame has `unique` names, you can #' index it by name, and also access the columns by name. In #' particular, `df[["name"]]` and `` df$`name` `` and also ``with(df, #' `name`)`` always work. #' #' There are many ways to make names `unique`. We append a suffix of the form #' `...j` to any name that is `""` or a duplicate, where `j` is the position. #' We also change `..#` and `...` to `...#`. #' #' Example: #' #' ``` #' Original names: "" "x" "" "y" "x" "..2" "..." #' unique names: "...1" "x...2" "...3" "y" "x...5" "...6" "...7" #' ``` #' #' Pre-existing suffixes of the form `...j` are always stripped, prior #' to making names `unique`, i.e. reconstructing the suffixes. If this #' interacts poorly with your names, you should take control of name #' repair. #' #' #' @section `universal` names: #' #' `universal` names are `unique` and syntactic, meaning they: #' #' * Are never empty (inherited from `unique`). #' * Have no duplicates (inherited from `unique`). #' * Are not `...`. Do not have the form `..i`, where `i` is a #' number (inherited from `unique`). #' * Consist of letters, numbers, and the dot `.` or underscore `_` #' characters. #' * Start with a letter or start with the dot `.` not followed by a #' number. #' * Are not a [reserved] word, e.g., `if` or `function` or `TRUE`. #' #' If a vector has `universal` names, variable names can be used #' "as is" in code. They work well with nonstandard evaluation, e.g., #' `df$name` works. #' #' vctrs has a different method of making names syntactic than #' [base::make.names()]. In general, vctrs prepends one or more dots #' `.` until the name is syntactic. #' #' Examples: #' #' ``` #' Original names: "" "x" NA "x" #' universal names: "...1" "x...2" "...3" "x...4" #' #' Original names: "(y)" "_z" ".2fa" "FALSE" #' universal names: ".y." "._z" "..2fa" ".FALSE" #' ``` #' #' @seealso [rlang::names2()] returns the names of an object, after #' making them `minimal`. #' #' The [Names attribute](https://principles.tidyverse.org/names-attribute.html) #' section in the "tidyverse package development principles". #' #' @examples #' # By default, `vec_as_names()` returns minimal names: #' vec_as_names(c(NA, NA, "foo")) #' #' # You can make them unique: #' vec_as_names(c(NA, NA, "foo"), repair = "unique") #' #' # Universal repairing fixes any non-syntactic name: #' vec_as_names(c("_foo", "+"), repair = "universal") #' @export vec_as_names <- function(names, ..., repair = c("minimal", "unique", "universal", "check_unique"), quiet = FALSE) { if (!missing(...)) { ellipsis::check_dots_empty() } .Call(vctrs_as_names, names, repair, quiet) } validate_name_repair_arg <- function(repair) { .Call(vctrs_validate_name_repair_arg, repair) } validate_minimal_names <- function(names, n = NULL) { .Call(vctrs_validate_minimal_names, names, n) } validate_unique <- function(names, n = NULL) { validate_minimal_names(names, n) empty_names <- which(names == "") if (has_length(empty_names)) { stop_names_cannot_be_empty(empty_names) } dot_dot_name <- grep("^[.][.](?:[.]|[1-9][0-9]*)$", names) if (has_length(dot_dot_name)) { stop_names_cannot_be_dot_dot(dot_dot_name) } if (anyDuplicated(names)) { stop_names_must_be_unique(which(duplicated(names))) } invisible(names) } #' Extract repaired names from a vector #' #' Returns the repaired names from a vector, even if the vector is unnamed. #' #' @param x A vector with names #' @inheritParams vec_as_names #' #' @return The names of x, repaired #' @noRd vec_names2 <- function(x, ..., repair = c("minimal", "unique", "universal", "check_unique"), quiet = FALSE) { if (!missing(...)) { ellipsis::check_dots_empty() } repair <- validate_name_repair_arg(repair) if (is_function(repair)) { names <- minimal_names(x) new_names <- validate_minimal_names(repair(names), n = length(names)) if (!quiet) { describe_repair(names, new_names) } return(new_names) } switch(repair, minimal = minimal_names(x), unique = unique_names(x, quiet = quiet), universal = as_universal_names(minimal_names(x), quiet = quiet), check_unique = validate_unique(minimal_names(x)) ) } vec_repair_names <- function(x, repair = c("minimal", "unique", "universal", "check_unique"), ..., quiet = FALSE) { set_names2(x, vec_names2(x, ..., repair = repair, quiet = quiet)) } minimal_names <- function(x) { .Call(vctrs_minimal_names, x) } unique_names <- function(x, quiet = FALSE) { .Call(vctrs_unique_names, x, quiet) } vec_names <- function(x) { .Call(vctrs_names, x) } `vec_names<-` <- function(x, value) { if (is.data.frame(x)) { # Do not update row names } else if (vec_dim_n(x) == 1) { names(x) <- value } else { rownames(x) <- value } x } set_names2 <- `vec_names<-` as_minimal_names <- function(names) { .Call(vctrs_as_minimal_names, names) } as_unique_names <- function(names, quiet = FALSE) { .Call(vctrs_as_unique_names, names, quiet) } as_universal_names <- function(names, quiet = FALSE) { new_names <- names new_names[] <- "" naked_names <- strip_pos(two_to_three_dots(names)) empty <- naked_names %in% c("", "...") new_names[!empty] <- make_syntactic(naked_names[!empty]) needs_suffix <- empty | vec_duplicate_detect(new_names) new_names <- append_pos(new_names, needs_suffix = needs_suffix) if (!quiet) { describe_repair(names, new_names) } new_names } two_to_three_dots <- function(names) { sub("(^[.][.][1-9][0-9]*$)", ".\\1", names) } append_pos <- function(names, needs_suffix) { need_append_pos <- which(needs_suffix) names[need_append_pos] <- paste0(names[need_append_pos], "...", need_append_pos) names } strip_pos <- function(names) { rx <- "([.][.][.][1-9][0-9]*)+$" gsub(rx, "", names) %|% "" } # Makes each individual name syntactic but does not enforce unique-ness make_syntactic <- function(names) { names[is.na(names)] <- "" names[names == ""] <- "." names[names == "..."] <- "...." names <- sub("^_", "._", names) new_names <- make.names(names) X_prefix <- grepl("^X", new_names) & !grepl("^X", names) new_names[X_prefix] <- sub("^X", "", new_names[X_prefix]) dot_suffix <- which(new_names == paste0(names, ".")) new_names[dot_suffix] <- sub("^(.*)[.]$", ".\\1", new_names[dot_suffix]) # Illegal characters have been replaced with '.' via make.names() # however, we have: # * Declined its addition of 'X' prefixes. # * Turned its '.' suffixes to '.' prefixes. regex <- paste0( "^(?[.]{0,2})", "(?[0-9]*)", "(?[^0-9]?.*$)" ) re <- re_match(new_names, pattern = regex) needs_dots <- which(re$numbers != "") needs_third_dot <- (re$leftovers[needs_dots] == "") re$leading_dots[needs_dots] <- ifelse(needs_third_dot, "...", "..") new_names <- paste0(re$leading_dots, re$numbers, re$leftovers) new_names } # From rematch2, except we don't add tbl_df or tbl classes to the return value re_match <- function(text, pattern, perl = TRUE, ...) { stopifnot( is.character(pattern), length(pattern) == 1, !is.na(pattern) ) text <- as.character(text) match <- regexpr(pattern, text, perl = perl, ...) start <- as.vector(match) length <- attr(match, "match.length") end <- start + length - 1L matchstr <- substring(text, start, end) matchstr[ start == -1 ] <- NA_character_ res <- data.frame( stringsAsFactors = FALSE, .text = text, .match = matchstr ) if (!is.null(attr(match, "capture.start"))) { gstart <- attr(match, "capture.start") glength <- attr(match, "capture.length") gend <- gstart + glength - 1L groupstr <- substring(text, gstart, gend) groupstr[ gstart == -1 ] <- NA_character_ dim(groupstr) <- dim(gstart) res <- cbind(groupstr, res, stringsAsFactors = FALSE) } names(res) <- c(attr(match, "capture.names"), ".text", ".match") res } describe_repair <- function(orig_names, names) { if (is_null(orig_names)) { orig_names <- rep_along(names, "") } if (length(orig_names) != length(names)) { stop("Internal error: New names and old names don't have same length") } new_names <- names != as_minimal_names(orig_names) if (any(new_names)) { msg <- bullets( "New names:", paste0( tick_if_needed(orig_names[new_names]), " -> ", tick_if_needed(names[new_names]), .problem = "" ) ) message(msg) } } bullets <- function(header, ..., .problem) { problems <- c(...) MAX_BULLETS <- 6L if (length(problems) >= MAX_BULLETS) { n_more <- length(problems) - MAX_BULLETS + 1L problems[[MAX_BULLETS]] <- "..." length(problems) <- MAX_BULLETS } paste0( header, "\n", paste0("* ", problems, collapse = "\n") ) } tick <- function(x) { ifelse(is.na(x), "NA", encodeString(x, quote = "`")) } is_syntactic <- function(x) { ret <- (make_syntactic(x) == x) ret[is.na(x)] <- FALSE ret } tick_if_needed <- function(x) { needs_ticks <- !is_syntactic(x) x[needs_ticks] <- tick(x[needs_ticks]) x } # Used in names.c set_rownames_fallback <- function(x, names) { rownames(x) <- names x } # Used in names.c set_names_fallback <- function(x, names) { names(x) <- names x } vec_set_names <- function(x, names) { .Call(vctrs_set_names, x, names) } #' Repair names with legacy method #' #' This standardises names with the legacy approach that was used in #' tidyverse packages (such as tibble, tidyr, and readxl) before #' [vec_as_names()] was implemented. This tool is meant to help #' transitioning to the new name repairing standard and will be #' deprecated and removed from the package some time in the future. #' #' @inheritParams vec_as_names #' @param prefix,sep Prefix and separator for repaired names. #' #' @examples #' if (rlang::is_installed("tibble")) { #' #' library(tibble) #' #' # Names repair is turned off by default in tibble: #' try(tibble(a = 1, a = 2)) #' #' # You can turn it on by supplying a repair method: #' tibble(a = 1, a = 2, .name_repair = "universal") #' #' # If you prefer the legacy method, use `vec_as_names_legacy()`: #' tibble(a = 1, a = 2, .name_repair = vec_as_names_legacy) #' #' } #' @keywords internal #' @export vec_as_names_legacy <- function(names, prefix = "V", sep = "") { if (length(names) == 0) { return(character()) } blank <- names == "" names[!blank] <- make.unique(names[!blank], sep = sep) new_nms <- setdiff(paste(prefix, seq_along(names), sep = sep), names) names[blank] <- new_nms[seq_len(sum(blank))] names } #' Name specifications #' #' @description #' #' A name specification describes how to combine an inner and outer #' names. This sort of name combination arises when concatenating #' vectors or flattening lists. There are two possible cases: #' #' * Named vector: #' #' ``` #' vec_c(outer = c(inner1 = 1, inner2 = 2)) #' ``` #' #' * Unnamed vector: #' #' ``` #' vec_c(outer = 1:2) #' ``` #' #' In r-lib and tidyverse packages, these cases are errors by default, #' because there's no behaviour that works well for every case. #' Instead, you can provide a name specification that describes how to #' combine the inner and outer names of inputs. Name specifications #' can refer to: #' #' * `outer`: The external name recycled to the size of the input #' vector. #' #' * `inner`: Either the names of the input vector, or a sequence of #' integer from 1 to the size of the vector if it is unnamed. #' #' @param name_spec,.name_spec A name specification for combining #' inner and outer names. This is relevant for inputs passed with a #' name, when these inputs are themselves named, like `outer = #' c(inner = 1)`, or when they have length greater than 1: `outer = #' 1:2`. By default, these cases trigger an error. You can resolve #' the error by providing a specification that describes how to #' combine the names or the indices of the inner vector with the #' name of the input. This specification can be: #' #' * A function of two arguments. The outer name is passed as a #' string to the first argument, and the inner names or positions #' are passed as second argument. #' #' * An anonymous function as a purrr-style formula. #' #' * A glue specification of the form `"{outer}_{inner}"`. #' #' See the [name specification topic][name_spec]. #' #' @examples #' # By default, named inputs must be length 1: #' vec_c(name = 1) # ok #' try(vec_c(name = 1:3)) # bad #' #' # They also can't have internal names, even if scalar: #' try(vec_c(name = c(internal = 1))) # bad #' #' # Pass a name specification to work around this. A specification #' # can be a glue string referring to `outer` and `inner`: #' vec_c(name = 1:3, other = 4:5, .name_spec = "{outer}") #' vec_c(name = 1:3, other = 4:5, .name_spec = "{outer}_{inner}") #' #' # They can also be functions: #' my_spec <- function(outer, inner) paste(outer, inner, sep = "_") #' vec_c(name = 1:3, other = 4:5, .name_spec = my_spec) #' #' # Or purrr-style formulas for anonymous functions: #' vec_c(name = 1:3, other = 4:5, .name_spec = ~ paste0(.x, .y)) #' @name name_spec NULL apply_name_spec <- function(name_spec, outer, inner, n = length(inner)) { .Call(vctrs_apply_name_spec, name_spec, outer, inner, n) } glue_as_name_spec <- function(`_spec`) { function(inner, outer) { glue::glue(`_spec`) } } # Evaluate glue specs in a child of base for now environment(glue_as_name_spec) <- baseenv() vctrs/R/type-list-of.R0000644000176200001440000001436613622451540014307 0ustar liggesusers#' `list_of` S3 class for homogenous lists #' #' A `list_of` object is a list where each element has the same type. #' Modifying the list with `$`, `[`, and `[[` preserves the constraint #' by coercing all input items. #' #' Unlike regular lists, setting a list element to `NULL` using `[[` #' does not remove it. #' #' @inheritParams vec_c #' @param x For `as_list_of()`, a vector to be coerced to list_of. #' @param y,to Arguments to `vec_ptype2()` and `vec_cast()`. #' @export #' @examples #' x <- list_of(1:3, 5:6, 10:15) #' if (requireNamespace("tibble", quietly = TRUE)) { #' tibble::tibble(x = x) #' } #' #' vec_c(list_of(1, 2), list_of(FALSE, TRUE)) list_of <- function(..., .ptype = NULL) { args <- list2(...) ptype <- vec_ptype_common(!!!args, .ptype = .ptype) if (is.null(ptype)) { abort("Could not find common type for elements of `x`.") } x <- map(args, vec_cast, to = ptype) new_list_of(x, ptype) } #' @export #' @rdname list_of as_list_of <- function(x, ...) { UseMethod("as_list_of") } #' @export as_list_of.vctrs_list_of <- function(x, .ptype = NULL, ...) { if (!is.null(.ptype)) { list_of(!!!x, .ptype = .ptype) } else { x } } #' @export as_list_of.list <- function(x, ..., .ptype = NULL) { list_of(!!!x, .ptype = .ptype) } #' Create list_of subclass #' #' @param x A list #' @param ptype The prototype which every element of `x` belongs to #' @param ... Additional attributes used by subclass #' @param class Optional subclass name #' @keywords internal #' @export new_list_of <- function(x = list(), ptype = logical(), ..., class = character()) { stopifnot(is.list(x)) stopifnot(vec_size(ptype) == 0) new_vctr(x, ..., ptype = ptype, class = c(class, "vctrs_list_of")) } #' @export #' @rdname list_of validate_list_of <- function(x) { stopifnot(is.list(x)) ptype <- attr(x, "ptype") stopifnot(vec_size(ptype) == 0) walk(x, vec_cast, to = ptype) invisible(x) } #' @export #' @rdname list_of is_list_of <- function(x) { inherits(x, "vctrs_list_of") } #' @export vec_proxy.vctrs_list_of <- function(x, ...) { unclass(x) } # Formatting -------------------------------------------------------------- #' @export obj_print_data.vctrs_list_of <- function(x, ...) { if (length(x) == 0) return() print(vec_data(x)) } #' @export format.vctrs_list_of <- function(x, ...) { format.default(x) } #' @export vec_ptype_full.vctrs_list_of <- function(x, ...) { param <- vec_ptype_full(attr(x, "ptype")) if (grepl("\n", param)) { param <- paste0(indent(paste0("\n", param), 2), "\n") } paste0("list_of<", param, ">") } #' @export vec_ptype_abbr.vctrs_list_of <- function(x, ...) { paste0("list<", vec_ptype_abbr(attr(x, "ptype")), ">") } # vctr methods ------------------------------------------------------------ #' @export as.list.vctrs_list_of <- function(x, ...) { attr(x, "ptype") <- NULL attr(x, "class") <- NULL x } #' @export as.character.vctrs_list_of <- function(x, ...) { map_chr(x, function(elt) paste0("<", vec_ptype_abbr(elt), ">")) } #' @export `[[.vctrs_list_of` <- function(x, i, ...) { .Call(vctrs_list_get, x, i) } #' @export `$.vctrs_list_of` <- function(x, i, ...) { .Call(vctrs_list_get, x, i) } #' @export `[<-.vctrs_list_of` <- function(x, i, value) { wrapped_type <- attr(x, "ptype") value <- map(value, vec_coercible_cast, to = wrapped_type, x_arg = "to", to_arg = "value") value <- new_list_of(value, ptype = attr(x, "ptype")) NextMethod() } #' @export `[[<-.vctrs_list_of` <- function(x, i, value) { if (is.null(value)) { # Setting to NULL via [[ shortens the list! Example: # `[[<-`(list(1), 1, NULL) x[i] <- list(value) return(x) } value <- vec_coercible_cast(value, attr(x, "ptype"), x_arg = "value", to_arg = "x") NextMethod() } #' @export `$<-.vctrs_list_of` <- function(x, i, value) { value <- vec_coercible_cast(value, attr(x, "ptype"), x_arg = "value", to_arg = "x") NextMethod() } # Type system ------------------------------------------------------------- #' @rdname list_of #' @inheritParams vec_ptype2 #' @export vec_ptype2.vctrs_list_of #' @method vec_ptype2 vctrs_list_of #' @export vec_ptype2.vctrs_list_of <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (inherits_only(x, c("vctrs_list_of", "vctrs_vctr"))) { UseMethod("vec_ptype2.vctrs_list_of", y) } else { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } } #' @method vec_ptype2.vctrs_list_of vctrs_list_of #' @export vec_ptype2.vctrs_list_of.vctrs_list_of <- function(x, y, ...) { type <- vec_ptype2(attr(x, "ptype"), attr(y, "ptype")) new_list_of(list(), type) } #' @method vec_ptype2.vctrs_list_of list #' @export vec_ptype2.vctrs_list_of.list <- function(x, y, ..., x_arg = "x", y_arg = "y") { stop_incompatible_type(x, y, x_arg = x_arg, y_arg = y_arg) } #' @method vec_ptype2.list vctrs_list_of #' @export vec_ptype2.list.vctrs_list_of <- function(x, y, ..., x_arg = "x", y_arg = "y") { stop_incompatible_type(x, y, x_arg = x_arg, y_arg = y_arg) } #' @method vec_ptype2.vctrs_list_of default #' @export vec_ptype2.vctrs_list_of.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } #' @rdname list_of #' @export vec_cast.vctrs_list_of #' @method vec_cast vctrs_list_of #' @export vec_cast.vctrs_list_of <- function(x, to, ...) { UseMethod("vec_cast.vctrs_list_of") } #' @export #' @method vec_cast.vctrs_list_of list vec_cast.vctrs_list_of.list <- function(x, to, ...) { # Casting list to list_of will warn/err if the cast is lossy, # but the locations refer to the inner vectors, # and the cast fails if all (vector) elements in a single (list) element as_list_of(x, .ptype = attr(to, "ptype")) } #' @export #' @method vec_cast.list vctrs_list_of vec_cast.list.vctrs_list_of <- function(x, to, ...) { # Casting list_of to list is never lossy shape_broadcast(as.list(x), to) } #' @export #' @method vec_cast.vctrs_list_of vctrs_list_of vec_cast.vctrs_list_of.vctrs_list_of <- vec_cast.vctrs_list_of.list #' @export #' @method vec_cast.vctrs_list_of default vec_cast.vctrs_list_of.default <- function(x, to, ...) { x <- vec_cast(x, attr(to, "ptype")) out <- lapply(seq_along(x), function(i) x[[i]]) miss <- is.na(x) out[miss] <- rep(list(NULL), sum(miss)) new_list_of(out, ptype = attr(to, "ptype")) } vctrs/R/type-date-time.R0000644000176200001440000003435713622451540014605 0ustar liggesusers#' Date, date-time, and duration S3 classes #' #' * A `date` ([Date]) is a double vector. Its value represent the number #' of days since the Unix "epoch", 1970-01-01. It has no attributes. #' * A `datetime` ([POSIXct] is a double vector. Its value represents the #' number of seconds since the Unix "Epoch", 1970-01-01. It has a single #' attribute: the timezone (`tzone`)) #' * A `duration` ([difftime]) #' #' These function help the base `Date`, `POSIXct`, and `difftime` classes fit #' into the vctrs type system by providing constructors, coercion functions, #' and casting functions. #' #' @param x A double vector representing the number of days since UNIX #' epoch for `new_date()`, number of seconds since UNIX epoch for #' `new_datetime()`, and number of `units` for `new_duration()`. #' @param tzone Time zone. A character vector of length 1. Either `""` for #' the local time zone, or a value from [OlsonNames()] #' @param units Units of duration. #' @export #' @keywords internal #' @examples #' new_date(0) #' new_datetime(0, tzone = "UTC") #' new_duration(1, "hour") new_date <- function(x = double()) { stopifnot(is.double(x)) structure( x, class = "Date" ) } #' @export #' @rdname new_date new_datetime <- function(x = double(), tzone = "") { tzone <- tzone %||% "" if (is.integer(x)) { x <- as.double(x) } stopifnot(is.double(x)) stopifnot(is.character(tzone)) structure( x, tzone = tzone, class = c("POSIXct", "POSIXt") ) } #' @export #' @rdname new_date new_duration <- function(x = double(), units = c("secs", "mins", "hours", "days", "weeks")) { stopifnot(is.double(x)) units <- match.arg(units) structure( x, units = units, class = "difftime" ) } #' @export vec_proxy.Date <- function(x, ...) { as_double_date(x) } #' @export vec_proxy.POSIXct <- function(x, ...) { new_datetime(x, attr(x, "tzone")) } #' @export vec_proxy.POSIXlt <- function(x, ...) { new_data_frame(unclass(x)) } #' @export vec_proxy_compare.POSIXlt <- function(x, ..., relax = FALSE) { new_data_frame(vec_data(x)[c("year", "mon", "mday", "hour", "min", "sec")], n = length(x)) } # Print ------------------------------------------------------------------ #' @export vec_ptype_full.Date <- function(x, ...) { "date" } #' @export vec_ptype_abbr.Date <- function(x, ...) { "date" } #' @export vec_ptype_full.POSIXct <- function(x, ...) { tzone <- if (tzone_is_local(x)) "local" else tzone(x) paste0("datetime<", tzone, ">") } #' @export vec_ptype_full.POSIXlt <- function(x, ...) { tzone <- if (tzone_is_local(x)) "local" else tzone(x) paste0("POSIXlt<", tzone, ">") } #' @export vec_ptype_abbr.POSIXt <- function(x, ...) { "dttm" } #' @export vec_ptype_full.difftime <- function(x, ...) { paste0("duration<", attr(x, "units"), ">") } #' @export vec_ptype_abbr.difftime <- function(x, ...) { "drtn" } # Coerce ------------------------------------------------------------------ #' @rdname new_date #' @export vec_ptype2.Date #' @method vec_ptype2 Date #' @export vec_ptype2.Date <- function(x, y, ...) UseMethod("vec_ptype2.Date", y) #' @method vec_ptype2.Date default #' @export vec_ptype2.Date.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } #' @method vec_ptype2.Date Date #' @export vec_ptype2.Date.Date <- function(x, y, ...) new_date() #' @rdname new_date #' @export vec_ptype2.POSIXt #' @method vec_ptype2 POSIXt #' @export vec_ptype2.POSIXt <- function(x, y, ...) UseMethod("vec_ptype2.POSIXt", y) #' @method vec_ptype2.POSIXt default #' @export vec_ptype2.POSIXt.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } #' @method vec_ptype2.POSIXt Date #' @export vec_ptype2.POSIXt.Date <- function(x, y, ...) new_datetime(tzone = tzone(x)) #' @method vec_ptype2.Date POSIXt #' @export vec_ptype2.Date.POSIXt <- function(x, y, ...) new_datetime(tzone = tzone(y)) #' @method vec_ptype2.POSIXt POSIXt #' @export vec_ptype2.POSIXt.POSIXt <- function(x, y, ...) new_datetime(tzone = tzone_union(x, y)) #' @rdname new_date #' @export vec_ptype2.difftime #' @method vec_ptype2 difftime #' @export vec_ptype2.difftime <- function(x, y, ...) UseMethod("vec_ptype2.difftime", y) #' @method vec_ptype2.difftime default #' @export vec_ptype2.difftime.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } #' @method vec_ptype2.difftime difftime #' @export vec_ptype2.difftime.difftime <- function(x, y, ...) new_duration(units = units_union(x, y)) # Cast -------------------------------------------------------------------- #' @rdname new_date #' @export vec_cast.Date #' @method vec_cast Date #' @export vec_cast.Date <- function(x, to, ...) { UseMethod("vec_cast.Date") } #' @export #' @method vec_cast.Date double vec_cast.Date.double <- function(x, to, ...) { new_date(x) } #' @export #' @method vec_cast.Date character vec_cast.Date.character <- function(x, to, ...) { as.Date(x, format = "%Y-%m-%d") } #' @export #' @method vec_cast.Date Date vec_cast.Date.Date <- function(x, to, ...) { as_double_date(x) } #' @export #' @method vec_cast.Date POSIXt vec_cast.Date.POSIXt <- function(x, to, ..., x_arg = "x", to_arg = "to") { out <- as.Date(x) lossy <- abs(x - as.POSIXct(out)) > 1e-9 maybe_lossy_cast(out, x, to, lossy, x_arg = x_arg, to_arg = to_arg) } #' @export #' @method vec_cast.Date list vec_cast.Date.list <- function(x, to, ..., x_arg = "x", to_arg = "to") { vec_list_cast(x, to, x_arg = x_arg, to_arg = to_arg) } #' @export #' @method vec_cast.Date default vec_cast.Date.default <- function(x, to, ..., x_arg = "x", to_arg = "to") { vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg) } #' @rdname new_date #' @export vec_cast.POSIXct #' @method vec_cast POSIXct #' @export vec_cast.POSIXct <- function(x, to, ...) { UseMethod("vec_cast.POSIXct") } #' @export #' @method vec_cast.POSIXct double vec_cast.POSIXct.double <- function(x, to, ...) { new_datetime(x, tzone = tzone(to)) } #' @export #' @method vec_cast.POSIXct character vec_cast.POSIXct.character <- function(x, to, ...) { as.POSIXct(x, tz = tzone(to)) } #' @export #' @method vec_cast.POSIXct Date vec_cast.POSIXct.Date <- function(x, to, ...) { as.POSIXct(as.character(x), tz = tzone(to)) } #' @export #' @method vec_cast.POSIXct POSIXlt vec_cast.POSIXct.POSIXlt <- function(x, to, ...) { new_datetime(as.POSIXct(x), tzone = tzone(to)) } #' @export #' @method vec_cast.POSIXct POSIXct vec_cast.POSIXct.POSIXct <- function(x, to, ...) { new_datetime(vec_data(x), tzone = tzone(to)) } #' @export #' @method vec_cast.POSIXct list vec_cast.POSIXct.list <- function(x, to, ..., x_arg = "x", to_arg = "to") { vec_list_cast(x, to, x_arg = x_arg, to_arg = to_arg) } #' @export #' @method vec_cast.POSIXct default vec_cast.POSIXct.default <- function(x, to, ..., x_arg = "x", to_arg = "to") { vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg) } #' @rdname new_date #' @export vec_cast.POSIXlt #' @method vec_cast POSIXlt #' @export vec_cast.POSIXlt <- function(x, to, ...) { UseMethod("vec_cast.POSIXlt") } #' @export #' @method vec_cast.POSIXlt double vec_cast.POSIXlt.double <- function(x, to, ...) { as.POSIXlt(new_datetime(x, tzone = tzone(to))) } #' @export #' @method vec_cast.POSIXlt character vec_cast.POSIXlt.character <- function(x, to, ...) { as.POSIXlt(x, tz = tzone(to)) } #' @export #' @method vec_cast.POSIXlt Date vec_cast.POSIXlt.Date <- function(x, to, ...) { as.POSIXlt(as.character(x), tz = tzone(to)) } #' @export #' @method vec_cast.POSIXlt POSIXlt vec_cast.POSIXlt.POSIXlt <- function(x, to, ...) { as.POSIXlt(x, tz = tzone(to)) } #' @export #' @method vec_cast.POSIXlt POSIXct vec_cast.POSIXlt.POSIXct <- function(x, to, ...) { as.POSIXlt(x, tz = tzone(to)) } #' @export #' @method vec_cast.POSIXlt list vec_cast.POSIXlt.list <- function(x, to, ..., x_arg = "x", to_arg = "to") { vec_list_cast(x, to, x_arg = x_arg, to_arg = to_arg) } #' @export #' @method vec_cast.POSIXlt default vec_cast.POSIXlt.default <- function(x, to, ..., x_arg = "x", to_arg = "to") { vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg) } #' @rdname new_date #' @export vec_cast.difftime #' @method vec_cast difftime #' @export vec_cast.difftime <- function(x, to, ...) { UseMethod("vec_cast.difftime") } #' @export #' @method vec_cast.difftime double vec_cast.difftime.double <- function(x, to, ...) { new_duration(vec_data(x), units = units(to)) } #' @export #' @method vec_cast.difftime difftime vec_cast.difftime.difftime <- function(x, to, ...) { if (identical(units(x), units(to))) { x } else { # Hack: I can't see any obvious way of changing the units origin <- as.POSIXct(0, origin = "1970-01-01") difftime(origin, origin - x, units = units(to)) } } #' @export #' @method vec_cast.difftime list vec_cast.difftime.list <- function(x, to, ..., x_arg = "x", to_arg = "to") { vec_list_cast(x, to, x_arg = x_arg, to_arg = to_arg) } #' @export #' @method vec_cast.difftime default vec_cast.difftime.default <- function(x, to, ..., x_arg = "x", to_arg = "to") { vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg) } # Arithmetic -------------------------------------------------------------- #' @rdname new_date #' @export vec_arith.Date #' @method vec_arith Date #' @export vec_arith.Date <- function(op, x, y, ...) UseMethod("vec_arith.Date", y) #' @rdname new_date #' @export vec_arith.POSIXct #' @method vec_arith POSIXct #' @export vec_arith.POSIXct <- function(op, x, y, ...) UseMethod("vec_arith.POSIXct", y) #' @rdname new_date #' @export vec_arith.difftime #' @method vec_arith difftime #' @export vec_arith.difftime <- function(op, x, y, ...) UseMethod("vec_arith.difftime", y) #' @method vec_arith.Date default #' @export vec_arith.Date.default <- function(op, x, y, ...) stop_incompatible_op(op, x, y) #' @method vec_arith.POSIXct default #' @export vec_arith.POSIXct.default <- function(op, x, y, ...) stop_incompatible_op(op, x, y) #' @method vec_arith.difftime default #' @export vec_arith.difftime.default <- function(op, x, y, ...) stop_incompatible_op(op, x, y) #' @method vec_arith.Date Date #' @export vec_arith.Date.Date <- function(op, x, y, ...) { switch(op, `-` = difftime(x, y, units = "days"), stop_incompatible_op(op, x, y) ) } #' @method vec_arith.POSIXct POSIXct #' @export vec_arith.POSIXct.POSIXct <- function(op, x, y, ...) { switch(op, `-` = difftime(x, y, units = "secs"), stop_incompatible_op(op, x, y) ) } #' @method vec_arith.POSIXct Date #' @export vec_arith.POSIXct.Date <- vec_arith.POSIXct.POSIXct #' @method vec_arith.Date POSIXct #' @export vec_arith.Date.POSIXct <- vec_arith.POSIXct.POSIXct #' @method vec_arith.Date numeric #' @export vec_arith.Date.numeric <- function(op, x, y, ...) { switch(op, `+` = vec_restore(vec_arith_base(op, x, y), x), `-` = vec_restore(vec_arith_base(op, x, y), x), stop_incompatible_op(op, x, y) ) } #' @method vec_arith.numeric Date #' @export vec_arith.numeric.Date <- function(op, x, y, ...) { switch(op, `+` = vec_restore(vec_arith_base(op, x, y), y), stop_incompatible_op(op, x, y) ) } #' @method vec_arith.POSIXct numeric #' @export vec_arith.POSIXct.numeric <- vec_arith.Date.numeric #' @method vec_arith.numeric POSIXct #' @export vec_arith.numeric.POSIXct <- vec_arith.numeric.Date #' @method vec_arith.POSIXct difftime #' @export vec_arith.POSIXct.difftime <- function(op, x, y, ...) { y <- vec_cast(y, new_duration(units = "secs")) switch(op, `+` = vec_restore(vec_arith_base(op, x, y), x), `-` = vec_restore(vec_arith_base(op, x, y), x), stop_incompatible_op(op, x, y) ) } #' @method vec_arith.difftime POSIXct #' @export vec_arith.difftime.POSIXct <- function(op, x, y, ...) { x <- vec_cast(x, new_duration(units = "secs")) switch(op, `+` = vec_restore(vec_arith_base(op, x, y), y), stop_incompatible_op(op, x, y) ) } #' @method vec_arith.Date difftime #' @export vec_arith.Date.difftime <- function(op, x, y, ...) { y <- vec_cast(y, new_duration(units = "days")) switch(op, `+` = , `-` = vec_restore(vec_arith_base(op, x, lossy_floor(y, x)), x), stop_incompatible_op(op, x, y) ) } #' @method vec_arith.difftime Date #' @export vec_arith.difftime.Date <- function(op, x, y, ...) { x <- vec_cast(x, new_duration(units = "days")) switch(op, `+` = vec_restore(vec_arith_base(op, lossy_floor(x, y), y), y), stop_incompatible_op(op, x, y) ) } #' @method vec_arith.difftime difftime #' @export vec_arith.difftime.difftime <- function(op, x, y, ...) { # Ensure x and y have same units args <- vec_cast_common(x, y) x <- args[[1L]] y <- args[[2L]] switch(op, `+` = vec_restore(vec_arith_base(op, x, y), x), `-` = vec_restore(vec_arith_base(op, x, y), x), `/` = vec_arith_base(op, x, y), `%/%` = vec_arith_base(op, x, y), `%%` = vec_arith_base(op, x, y), stop_incompatible_op(op, x, y) ) } #' @method vec_arith.difftime MISSING #' @export vec_arith.difftime.MISSING <- function(op, x, y, ...) { switch(op, `-` = vec_restore(-vec_data(x), x), `+` = x, stop_incompatible_op(op, x, y) ) } #' @method vec_arith.difftime numeric #' @export vec_arith.difftime.numeric <- function(op, x, y, ...) { vec_restore(vec_arith_base(op, x, y), x) } #' @method vec_arith.numeric difftime #' @export vec_arith.numeric.difftime <- function(op, x, y, ...) { switch(op, `/` = stop_incompatible_op(op, x, y), vec_restore(vec_arith_base(op, x, y), y) ) } # Helpers ----------------------------------------------------------------- # The tz attribute for POSIXlt can have 3 components # (time zone name, abbreviated name, abbreviated DST name) tzone <- function(x) { attr(x, "tzone")[[1]] %||% "" } tzone_is_local <- function(x) { identical(tzone(x), "") } tzone_union <- function(x, y) { if (tzone_is_local(x)) { tzone(y) } else { tzone(x) } } units_union <- function(x, y) { if (identical(units(x), units(y))) { units(x) } else { "secs" } } as_double_date <- function(x) { if (is.integer(x)) { new_date(as.double(x)) } else { x } } # Math -------------------------------------------------------------------- #' @export vec_math.Date <- function(.fn, .x, ...) { stop_unsupported(.x, .fn) } #' @export vec_math.POSIXct <- function(.fn, .x, ...) { stop_unsupported(.x, .fn) } vctrs/R/cast-list.R0000644000176200001440000000206213622451540013644 0ustar liggesusers#' Cast a list to vector of specific type #' #' This is a function for developers to use when extending vctrs. It casts #' a list to a more specific vectoring type, keeping the length constant. #' It does this by discarding (with a warning), any elements after the 1. #' It is called from `vec_cast.XYZ.list()` methods to preserve symmetry with #' `vec_cast.list.XYZ()`. #' #' See `vignette("s3-vector")` for details. #' #' @param x A list #' @param to Type to coerce to #' @inheritParams ellipsis::dots_empty #' #' @export #' @keywords internal vec_list_cast <- function(x, to, ..., x_arg = "", to_arg = "") { if (!missing(...)) { ellipsis::check_dots_empty() } ns <- map_int(x, vec_size) n <- vec_size(x) out <- vec_init(to, n) for (i in seq_len(n)) { val <- x[[i]] if (vec_size(val) == 0) { next } val <- vec_slice(val, 1L) vec_slice(out, i) <- vec_cast(val, to, x_arg = x_arg, to_arg = to_arg) } if (!is.object(to)) { out <- shape_broadcast(out, to) } maybe_lossy_cast(out, x, to, lossy = !ns %in% c(0L, 1L)) } vctrs/R/register-s3.R0000644000176200001440000000700713622451540014114 0ustar liggesusers#' Register a method for a suggested dependency #' #' Generally, the recommend way to register an S3 method is to use the #' `S3Method()` namespace directive (often generated automatically by the #' `@export` roxygen2 tag). However, this technique requires that the generic #' be in an imported package, and sometimes you want to suggest a package, #' and only provide a method when that package is loaded. `s3_register()` #' can be called from your package's `.onLoad()` to dynamically register #' a method only if the generic's package is loaded. (To avoid taking a #' dependency on vctrs for this one function, please feel free to copy #' and paste the function source into your own package.) #' #' For R 3.5.0 and later, `s3_register()` is also useful when demonstrating #' class creation in a vignette, since method lookup no longer always involves #' the lexical scope. For R 3.6.0 and later, you can achieve a similar effect #' by using "delayed method registration", i.e. placing the following in your #' `NAMESPACE` file: #' #' ``` #' if (getRversion() >= "3.6.0") { #' S3method(package::generic, class) #' } #' ``` #' #' @param generic Name of the generic in the form `pkg::generic`. #' @param class Name of the class #' @param method Optionally, the implementation of the method. By default, #' this will be found by looking for a function called `generic.class` #' in the package environment. #' #' Note that providing `method` can be dangerous if you use #' devtools. When the namespace of the method is reloaded by #' `devtools::load_all()`, the function will keep inheriting from #' the old namespace. This might cause crashes because of dangling #' `.Call()` pointers. #' @export #' @examples #' # A typical use case is to dynamically register tibble/pillar methods #' # for your class. That way you avoid creating a hard dependency on packages #' # that are not essential, while still providing finer control over #' # printing when they are used. #' #' .onLoad <- function(...) { #' s3_register("pillar::pillar_shaft", "vctrs_vctr") #' s3_register("tibble::type_sum", "vctrs_vctr") #' } #' @keywords internal # nocov start s3_register <- function(generic, class, method = NULL) { stopifnot(is.character(generic), length(generic) == 1) stopifnot(is.character(class), length(class) == 1) pieces <- strsplit(generic, "::")[[1]] stopifnot(length(pieces) == 2) package <- pieces[[1]] generic <- pieces[[2]] caller <- parent.frame() get_method_env <- function() { top <- topenv(caller) if (isNamespace(top)) { asNamespace(environmentName(top)) } else { caller } } get_method <- function(method, env) { if (is.null(method)) { get(paste0(generic, ".", class), envir = get_method_env()) } else { method } } method_fn <- get_method(method) stopifnot(is.function(method_fn)) # Always register hook in case package is later unloaded & reloaded setHook( packageEvent(package, "onLoad"), function(...) { ns <- asNamespace(package) # Refresh the method, it might have been updated by `devtools::load_all()` method_fn <- get_method(method) registerS3method(generic, class, method_fn, envir = ns) } ) # Avoid registration failures during loading (pkgload or regular) if (!isNamespaceLoaded(package)) { return(invisible()) } envir <- asNamespace(package) # Only register if generic can be accessed if (exists(generic, envir)) { registerS3method(generic, class, method_fn, envir = envir) } invisible() } # nocov end vctrs/R/type-tibble.R0000644000176200001440000000131313622451540014157 0ustar liggesusers# Coercion ---------------------------------------------------------------- df_as_tibble <- function(df) { class(df) <- c("tbl_df", "tbl", "data.frame") df } # Conditionally registered in .onLoad() vec_ptype2.tbl_df <- function(x, y, ...) { UseMethod("vec_ptype2.tbl_df", y) } vec_ptype2.tbl_df.default <- function(x, y, ...) { # FIXME: Do we need some sort of `next_vec_type2()`? vec_ptype2.data.frame(x, y, ...) } vec_ptype2.tbl_df.data.frame <- function(x, y, ..., x_arg = "x", y_arg = "y") { df_as_tibble(.Call(vctrs_type2_df_df, x, y, x_arg, y_arg)) } vec_ptype2.data.frame.tbl_df <- function(x, y, ..., x_arg = "x", y_arg = "y") { df_as_tibble(.Call(vctrs_type2_df_df, x, y, x_arg, y_arg)) } vctrs/R/utils.R0000644000176200001440000000520713622451540013105 0ustar liggesusersstr_dup <- function(x, times) { paste0(rep(x, times = times), collapse = "") } indent <- function(x, n) { pad <- str_dup(" ", n) map_chr(x, gsub, pattern = "(\n+)", replacement = paste0("\\1", pad)) } ones <- function(...) { array(1, dim = c(...)) } vec_coerce_bare <- function(x, type) { # Unexported wrapper around Rf_coerceVector() coerce <- env_get(ns_env("rlang"), "vec_coerce") coerce(x, type) } # Matches the semantics of c() - based on experimenting with the output # of c(), not reading the source code. outer_names <- function(names, outer, n) { .Call(vctrs_outer_names, names, outer, vec_cast(n, int())) } has_inner_names <- function(x) { !all(map_lgl(map(x, vec_names), is.null)) } cat_line <- function(...) { cat(paste0(..., "\n", collapse = "")) } set_partition <- function(x, y) { list( both = intersect(x, y), only_x = setdiff(x, y), only_y = setdiff(y, x) ) } all_equal <- function(x) all(x == x[[1]]) inline_list <- function(title, x, width = getOption("width"), quote = "") { label_width <- width - nchar(title) x <- glue::glue_collapse( encodeString(x, quote = quote), sep = ", ", width = label_width ) paste0(title, x) } has_unique_names <- function(x) { nms <- names(x) if (length(nms) != length(x)) { return(FALSE) } if (any(is.na(nms) | nms == "")) { return(FALSE) } !anyDuplicated(nms) } compact <- function(x) { is_null <- map_lgl(x, is.null) x[!is_null] } paste_line <- function (...) { paste(chr(...), collapse = "\n") } has_dim <- function(x) { !is.null(attr(x, "dim")) } # Experimental result <- function(ok = NULL, err = NULL) { structure( list(ok = ok, err = err), class = "rlang_result" ) } result_get <- function(x) { if (!is_null(x$err)) { cnd_signal(x$err) } x$ok } obj_type <- function(x) { if (vec_is(x)) { vec_ptype_full(x) } else if (is.object(x)) { paste(class(x), collapse = "/") } else { typeof(x) } } new_opts <- function(x, opts, subclass = NULL, arg = NULL) { if (!all(x %in% opts)) { if (is_null(arg)) { arg <- "Argument" } else { arg <- glue::glue("`{arg}`") } opts <- encodeString(opts, quote = "\"") opts <- glue::glue_collapse(opts, sep = ", ", last = " or ") abort(glue::glue("{arg} must be one of {opts}.")) } structure( set_names(opts %in% x, opts), class = c(subclass, "vctrs_opts") ) } glue_data_bullets <- function(.data, ..., .env = caller_env()) { glue_data <- function(...) glue::glue_data(.data, ..., .envir = .env) format_error_bullets(map_chr(chr(...), glue_data)) } unstructure <- function(x) { attributes(x) <- NULL x } vctrs/R/zzz.R0000644000176200001440000000237413622451540012604 0ustar liggesusers# nocov start on_package_load <- function(pkg, expr) { if (isNamespaceLoaded(pkg)) { expr } else { thunk <- function(...) expr setHook(packageEvent(pkg, "onLoad"), thunk) } } .onLoad <- function(libname, pkgname) { s3_register("generics::as.factor", "vctrs_vctr") s3_register("generics::as.ordered", "vctrs_vctr") s3_register("generics::as.difftime", "vctrs_vctr") on_package_load("tibble", { # Remove once tibble has implemented the methods if (!env_has(ns_env("tibble"), "vec_ptype2.tbl_df")) { s3_register("vctrs::vec_ptype2", "tbl_df") s3_register("vctrs::vec_ptype2.tbl_df", "default") s3_register("vctrs::vec_ptype2.tbl_df", "data.frame") s3_register("vctrs::vec_ptype2.data.frame", "tbl_df") } }) utils::globalVariables("vec_set_attributes") # Prevent two copies from being made by `attributes(x) <- attrib` on R < 3.6.0 if (getRversion() >= '3.6.0') { vec_set_attributes <- function(x, attrib) { attributes(x) <- attrib x } } else { vec_set_attributes <- function(x, attrib) { .Call(vctrs_set_attributes, x, attrib) } } ns <- ns_env("vctrs") env_bind(ns, vec_set_attributes = vec_set_attributes) .Call(vctrs_init_library, ns_env()) } # nocov end vctrs/R/type-sclr.R0000644000176200001440000000737413622451540013676 0ustar liggesusersnew_sclr <- function(..., class = character()) { fields <- list(...) stopifnot(has_unique_names(fields)) structure( list(...), class = c(class, "vctrs_sclr") ) } # Subsetting -------------------------------------------------------------- #' @export `[[.vctrs_sclr` <- function(x, i, ...) { .Call(vctrs_list_get, x, i) } #' @export `$.vctrs_sclr` <- function(x, i, ...) { .Call(vctrs_list_get, x, i) } #' @export `[[<-.vctrs_sclr` <- function(x, i, value) { .Call(vctrs_list_set, x, i, value) } #' @export `$<-.vctrs_sclr` <- function(x, i, value) { .Call(vctrs_list_set, x, i, value) } # Shared niceties --------------------------------------------------------- #' @export print.vctrs_sclr <- function(x, ...) { obj_print(x, ...) invisible(x) } #' @export as.list.vctrs_sclr <- function(x, ...) { vec_set_attributes(x, list(names = names(x))) } #' @export as.data.frame.vctrs_sclr <- function(x, row.names = NULL, optional = FALSE, ..., nm = paste(deparse(substitute(x), width.cutoff = 500L), collapse = " ") ) { force(nm) cols <- list(list(x)) if (!optional) { names(cols) <- nm } new_data_frame(cols, n = 1L) } # Vector behaviours ------------------------------------------------------- #' @export `[.vctrs_sclr` <- function(x, ...) { stop_unsupported(x, "[") } #' @export `[<-.vctrs_sclr` <- function(x, ..., value) { stop_unsupported(x, "[<-") } #' @export c.vctrs_sclr <- function(...) { stop_unsupported(..1, "c") } #' @export Math.vctrs_sclr <- function(x, ...) { stop_unsupported(x, .Generic) } #' @export Ops.vctrs_sclr <- function(e1, e2) { stop_unsupported(e1, .Generic) } #' @export Complex.vctrs_sclr <- function(z) { stop_unsupported(z, .Generic) } #' @export Summary.vctrs_sclr <- function(..., na.rm = TRUE) { stop_unsupported(..1, .Generic) } #' @export `names<-.vctrs_sclr` <- function(x, value) { stop_unsupported(x, "names<-") } #' @export xtfrm.vctrs_sclr <- function(x) { stop_unsupported(x, "xtfrm") } #' @export `dim<-.vctrs_sclr` <- function(x, value) { stop_unsupported(x, "dim<-") } #' @export `dimnames<-.vctrs_sclr` <- function(x, value) { stop_unsupported(x, "dimnames<-") } #' @export levels.vctrs_sclr <- function(x) { stop_unsupported(x, "levels") } #' @export `levels<-.vctrs_sclr` <- function(x, value) { stop_unsupported(x, "levels<-") } #' @export `t.vctrs_sclr` <- function(x) { stop_unsupported(x, "t") } #' @export `is.na<-.vctrs_sclr` <- function(x, value) { stop_unsupported(x, "is.na<-") } #' @export unique.vctrs_sclr <- function(x, incomparables = FALSE, ...) { stop_unsupported(x, "unique") } #' @export duplicated.vctrs_sclr <- function(x, incomparables = FALSE, ...) { stop_unsupported(x, "unique") } #' @export anyDuplicated.vctrs_sclr <- function(x, incomparables = FALSE, ...) { stop_unsupported(x, "unique") } #' @export as.logical.vctrs_sclr <- function(x, ...) { stop_unsupported(x, "as.logical") } #' @export as.integer.vctrs_sclr <- function(x, ...) { stop_unsupported(x, "as.integer") } #' @export as.double.vctrs_sclr <- function(x, ...) { stop_unsupported(x, "as.double") } #' @export as.character.vctrs_sclr <- function(x, ...) { stop_unsupported(x, "as.character") } #' @export as.Date.vctrs_sclr <- function(x, ...) { stop_unsupported(x, "as.Date") } #' @export as.POSIXct.vctrs_sclr <- function(x, tz = "", ...) { stop_unsupported(x, "as.POSIXct") } # Unimplemented ----------------------------------------------------------- #' @export summary.vctrs_sclr <- function(object, ...) { # nocov start stop_unimplemented(object, "summary") # nocov end } vctrs/R/fields.R0000644000176200001440000000164313475700023013212 0ustar liggesusers#' Tools for accessing the fields of a record. #' #' A [rcrd] behaves like a vector, so `length()`, `names()`, and `$` can #' not provide access to the fields of the underlying list. These helpers do: #' `fields()` is equivalent to `names()`; `n_fields()` is equivalent to #' `length()`; `field()` is equivalent to `$`. #' #' @param x A [rcrd], i.e. a list of equal length vectors with unique names. #' @keywords internal #' @export #' @examples #' x <- new_rcrd(list(x = 1:3, y = 3:1, z = letters[1:3])) #' n_fields(x) #' fields(x) #' #' field(x, "y") #' field(x, "y") <- runif(3) #' field(x, "y") fields <- function(x) { .Call(vctrs_fields, x) } #' @export #' @rdname fields n_fields <- function(x) { .Call(vctrs_n_fields, x) } #' @export #' @rdname fields field <- function(x, i) { .Call(vctrs_field_get, x, i) } #' @export #' @rdname fields `field<-` <- function(x, i, value) { .Call(vctrs_field_set, x, i, value) } vctrs/R/type-integer64.R0000644000176200001440000000675413623013722014540 0ustar liggesusers #' @export vec_proxy_compare.integer64 <- function(x, ...) { bit64::rank.integer64(x) } # Print ------------------------------------------------------------------- #' 64 bit integers #' #' A `integer64` is a 64 bits integer vector, implemented in the `bit64` package. #' #' These functions help the `integer64` class from `bit64` in to #' the vctrs type system by providing coercion functions #' and casting functions. #' #' @keywords internal #' @rdname int64 #' @export vec_ptype_full.integer64 <- function(x, ...) { "integer64" } #' @rdname int64 #' @export vec_ptype_abbr.integer64 <- function(x, ...) { "int64" } # Coerce ------------------------------------------------------------------ #' @export #' @rdname int64 #' @export vec_ptype2.integer64 #' @method vec_ptype2 integer64 vec_ptype2.integer64 <- function(x, y, ...) { UseMethod("vec_ptype2.integer64", y) } #' @method vec_ptype2.integer64 default #' @export vec_ptype2.integer64.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } #' @method vec_ptype2.integer64 vctrs_unspecified #' @export vec_ptype2.integer64.vctrs_unspecified <- function(x, y, ...) bit64::integer64() #' @method vec_ptype2.integer64 integer64 #' @export vec_ptype2.integer64.integer64 <- function(x, y, ...) bit64::integer64() #' @method vec_ptype2.integer64 integer #' @export vec_ptype2.integer64.integer <- function(x, y, ...) bit64::integer64() #' @method vec_ptype2.integer integer64 #' @export vec_ptype2.integer.integer64 <- function(x, y, ...) bit64::integer64() #' @method vec_ptype2.integer64 logical #' @export vec_ptype2.integer64.logical <- function(x, y, ...) bit64::integer64() #' @method vec_ptype2.logical integer64 #' @export vec_ptype2.logical.integer64 <- function(x, y, ...) bit64::integer64() # Cast -------------------------------------------------------------------- #' @export #' @rdname int64 #' @export vec_cast.integer64 #' @method vec_cast integer64 vec_cast.integer64 <- function(x, to, ...) UseMethod("vec_cast.integer64") #' @export #' @method vec_cast.integer64 default vec_cast.integer64.default <- function(x, to, ..., x_arg = "x", to_arg = "to") { # Don't use `vec_default_cast()` because integer64 is not compatible # with `vec_init()` if (is_unspecified(x)) { bit64::as.integer64(unclass(x)) } else { stop_incompatible_cast(x, to, x_arg = x_arg, to_arg = to_arg) } } #' @export #' @method vec_cast.integer64 integer64 vec_cast.integer64.integer64 <- function(x, to, ...) x #' @export #' @method vec_cast.integer64 integer vec_cast.integer64.integer <- function(x, to, ...) { bit64::as.integer64(x) } #' @export #' @method vec_cast.integer integer64 vec_cast.integer.integer64 <- function(x, to, ...) { as.integer(x) } #' @export #' @method vec_cast.integer64 logical vec_cast.integer64.logical <- function(x, to, ...) { bit64::as.integer64(x) } #' @export #' @method vec_cast.logical integer64 vec_cast.logical.integer64 <- function(x, to, ...) { as.logical(x) } #' @export #' @method vec_cast.integer64 character vec_cast.integer64.character <- function(x, to, ...) { bit64::as.integer64(x) } #' @export #' @method vec_cast.character integer64 vec_cast.character.integer64 <- function(x, to, ...) { as.character(x) } #' @export #' @method vec_cast.integer64 double vec_cast.integer64.double <- function(x, to, ...) { bit64::as.integer64(x) } #' @export #' @method vec_cast.double integer64 vec_cast.double.integer64 <- function(x, to, ...) { as.double(x) } vctrs/R/subscript-loc.R0000644000176200001440000003444413622451540014543 0ustar liggesusers#' Create a vector of locations #' #' @description #' #' These helpers provide a means of standardizing common indexing #' methods such as integer, character or logical indexing. #' #' * `vec_as_location()` accepts integer, character, or logical vectors #' of any size. The output is always an integer vector that is #' suitable for subsetting with `[` or [vec_slice()]. It might be a #' different size than the input because negative selections are #' transformed to positive ones and logical vectors are transformed #' to a vector of indices for the `TRUE` locations. #' #' * `vec_as_location2()` accepts a single number or string. It returns #' a single location as a integer vector of size 1. This is suitable #' for extracting with `[[`. #' #' @inheritParams vec_slice #' @param n A single integer representing the total size of the #' object that `i` is meant to index into. #' @param names If `i` is a character vector, `names` should be a character #' vector that `i` will be matched against to construct the index. Otherwise, #' not used. The default value of `NULL` will result in an error #' if `i` is a character vector. #' @param missing Whether to throw an `"error"` when `i` is a missing #' value, or `"propagate"` it (return it as is). By default, vector #' subscripts can contain missing values and scalar subscripts can't. #' @param arg The argument name to be displayed in error messages when #' `vec_as_location()` and `vec_as_location2()` are used to check the #' type of a function input. #' #' @return `vec_as_location()` returns an integer vector that can be used #' as an index in a subsetting operation. `vec_as_location2()` #' returns an integer of size 1 that can be used a scalar index for #' extracting an element. #' #' @examples #' x <- array(1:6, c(2, 3)) #' dimnames(x) <- list(c("r1", "r2"), c("c1", "c2", "c3")) #' #' # The most common use case validates row indices #' vec_as_location(1, vec_size(x)) #' #' # Negative indices can be used to index from the back #' vec_as_location(-1, vec_size(x)) #' #' # Character vectors can be used if `names` are provided #' vec_as_location("r2", vec_size(x), rownames(x)) #' #' # You can also construct an index for dimensions other than the first #' vec_as_location(c("c2", "c1"), ncol(x), colnames(x)) #' #' @keywords internal #' @export vec_as_location <- function(i, n, names = NULL, ..., missing = c("propagate", "error"), arg = NULL) { if (!missing(...)) ellipsis::check_dots_empty() i <- vec_as_subscript(i, arg = arg) .Call( vctrs_as_location, i = i, n = n, names = names, loc_negative = "invert", loc_oob = "error", missing = missing, arg = arg ) } #' @rdname vec_as_location #' @param negative Whether to `"invert"` negative values to positive #' locations, throw an informative `"error"`, or `"ignore"` them. #' @param oob If `"error"`, throws an informative `"error"` if some #' elements are out-of-bounds. If `"extend"`, out-of-bounds #' locations are allowed if they are consecutive after the end. This #' can be used to implement extendable vectors like `letters[1:30]`. #' @export num_as_location <- function(i, n, ..., missing = c("propagate", "error"), negative = c("invert", "error", "ignore"), oob = c("error", "extend"), arg = NULL) { if (!missing(...)) ellipsis::check_dots_empty() if (!is_integer(i) && !is_double(i)) { abort("`i` must be a numeric vector.") } .Call( vctrs_as_location, i = i, n = n, names = NULL, loc_negative = negative, loc_oob = oob, missing = missing, arg = arg ) } #' @rdname vec_as_location #' @export vec_as_location2 <- function(i, n, names = NULL, ..., missing = c("error", "propagate"), arg = NULL) { if (!missing(...)) ellipsis::check_dots_empty() result_get(vec_as_location2_result( i, n = n, names = names, negative = "error", missing = missing, arg = arg )) } #' @rdname vec_as_location #' @param negative Whether to throw an `"error"` when `i` is a #' negative location value, or `"ignore"` it. #' @export num_as_location2 <- function(i, n, ..., negative = c("error", "ignore"), missing = c("error", "propagate"), arg = NULL) { if (!missing(...)) ellipsis::check_dots_empty() if (!is_integer(i) && !is_double(i)) { abort("`i` must be a numeric vector.") } result_get(vec_as_location2_result( i, n = n, names = NULL, negative = negative, missing = missing, arg = arg )) } vec_as_location2_result <- function(i, n, names, missing, negative, arg) { allow_missing <- arg_match(missing, c("error", "propagate")) == "propagate" allow_negative <- arg_match(negative, c("error", "ignore")) == "ignore" result <- vec_as_subscript2_result( i = i, arg = arg, logical = "error" ) if (!is_null(result$err)) { parent <- result$err return(result(err = new_error_location2_type( i = i, subscript_arg = arg, # FIXME: Should body fields in parents be automatically inherited? body = function(...) cnd_body(parent), parent = parent ))) } # Locations must be size 1, can't be NA, and must be positive i <- result$ok if (length(i) != 1L) { return(result(err = new_error_location2_type( i = i, subscript_arg = arg, body = cnd_bullets_location2_need_scalar ))) } neg <- typeof(i) == "integer" && !is.na(i) && i < 0L if (allow_negative && neg) { i <- -i } if (is.na(i)) { if (!allow_missing && is.na(i)) { result <- result(err = new_error_location2_type( i = i, subscript_arg = arg, body = cnd_bullets_location2_need_present )) } else { result <- result(i) } return(result) } if (i == 0L) { return(result(err = new_error_location2_type( i = i, subscript_arg = arg, body = cnd_bullets_location2_need_positive ))) } if (!allow_negative && neg) { return(result(err = new_error_location2_type( i = i, subscript_arg = arg, body = cnd_bullets_location2_need_positive ))) } # FIXME: Use result approach in internal implementation? err <- NULL i <- tryCatch( vec_as_location(i, n, names = names, arg = arg), vctrs_error_subscript_type = function(err) { err <<- err i } ) if (neg) { i <- -i } if (is_null(err)) { result(i) } else { result(err = new_error_location2_type( i = i, parent = err, subscript_arg = arg )) } } stop_location_negative_missing <- function(i, ...) { cnd_signal(new_error_subscript_type( i, ..., body = cnd_body_vctrs_error_subscript_type )) } cnd_body_vctrs_error_subscript_type <- function(cnd, ...) { missing_loc <- which(is.na(cnd$i)) arg <- append_arg("The subscript", cnd$subscript_arg) if (length(missing_loc) == 1) { loc <- glue::glue("{arg} has a missing value at location {missing_loc}.") } else { n_loc <- length(missing_loc) missing_loc <- ensure_full_stop(enumerate(missing_loc)) loc <- glue::glue( "{arg} has {n_loc} missing values at locations {missing_loc}" ) } format_error_bullets(c( x = "Negative locations can't have missing values.", i = loc )) } stop_location_negative_positive <- function(i, ...) { cnd_signal(new_error_subscript_type( i, ..., body = cnd_body_vctrs_error_location_negative_positive )) } cnd_body_vctrs_error_location_negative_positive <- function(cnd, ...) { positive_loc <- which(cnd$i > 0) arg <- append_arg("The subscript", cnd$subscript_arg) if (length(positive_loc) == 1) { loc <- glue::glue("{arg} has a positive value at location {positive_loc}.") } else { n_loc <- length(positive_loc) positive_loc <- ensure_full_stop(enumerate(positive_loc)) loc <- glue::glue( "{arg} has {n_loc} missing values at locations {positive_loc}" ) } format_error_bullets(c( x = "Negative locations can't be mixed with positive locations.", i = loc )) } new_error_location2_type <- function(i, ..., class = NULL) { new_error_subscript2_type( class = class, i = i, logical = "error", numeric = "cast", character = "cast", ... ) } cnd_bullets_location2_need_scalar <- function(cnd, ...) { cnd$subscript_arg <- append_arg("The subscript", cnd$subscript_arg) format_error_bullets(c( x = glue::glue_data(cnd, "{subscript_arg} has size {length(i)} but must be size 1.") )) } cnd_bullets_location2_need_present <- function(cnd, ...) { cnd$subscript_arg <- append_arg("The subscript", cnd$subscript_arg) format_error_bullets(c( x = glue::glue_data(cnd, "{subscript_arg} can't be `NA`.") )) } cnd_bullets_location2_need_positive <- function(cnd, ...) { cnd$subscript_arg <- append_arg("The subscript", cnd$subscript_arg) format_error_bullets(c( x = glue::glue_data(cnd, "{subscript_arg} has value {i} but must be a positive location.") )) } stop_location_negative <- function(i, ...) { cnd_signal(new_error_subscript_type( i, body = cnd_bullets_location_need_non_negative, ... )) } cnd_bullets_location_need_non_negative <- function(cnd, ...) { cnd$subscript_arg <- append_arg("The subscript", cnd$subscript_arg) format_error_bullets(c( x = glue::glue_data(cnd, "{subscript_arg} can't contain negative locations.") )) } stop_subscript_missing <- function(i, ...) { cnd_signal(new_error_subscript_type( i = i, body = cnd_bullets_subscript_missing, ... )) } cnd_bullets_subscript_missing <- function(cnd, ...) { cnd$subscript_arg <- append_arg("The subscript", cnd$subscript_arg) missing_loc <- which(is.na(cnd$i)) if (length(missing_loc) == 1) { missing_line <- glue::glue("It has a missing value at location {missing_loc}.") } else { missing_enum <- ensure_full_stop(enumerate(missing_loc)) missing_line <- glue::glue("It has missing values at locations {missing_enum}") } format_error_bullets(c( x = glue::glue_data(cnd, "{subscript_arg} can't contain missing values."), x = missing_line )) } stop_indicator_size <- function(i, n, ...) { cnd_signal(new_error_subscript_size( i, n = n, ..., body = cnd_body_vctrs_error_indicator_size )) } cnd_body_vctrs_error_indicator_size <- function(cnd, ...) { cnd$subscript_arg <- append_arg("the subscript", cnd$subscript_arg) glue_data_bullets( cnd, i = "Logical subscripts must match the size of the indexed input.", x = "The input has size {n} but {subscript_arg} has size {vec_size(i)}." ) } stop_subscript_oob <- function(i, subscript_type, ...) { stop_subscript( class = "vctrs_error_subscript_oob", i = i, subscript_type = subscript_type, ... ) } #' @export cnd_header.vctrs_error_subscript_oob <- function(cnd, ...) { if (cnd_subscript_oob_non_consecutive(cnd)) { return(cnd_header_vctrs_error_subscript_oob_non_consecutive(cnd, ...)) } elt <- cnd_subscript_element(cnd) action <- cnd_subscript_action(cnd) glue::glue("Can't {action} {elt[[2]]} that don't exist.") } #' @export cnd_body.vctrs_error_subscript_oob <- function(cnd, ...) { switch(cnd_subscript_type(cnd), numeric = if (cnd_subscript_oob_non_consecutive(cnd)) { cnd_body_vctrs_error_subscript_oob_non_consecutive(cnd, ...) } else { cnd_body_vctrs_error_subscript_oob_location(cnd, ...) }, character = cnd_body_vctrs_error_subscript_oob_name(cnd, ...), abort("Internal error: subscript type can't be `logical` for OOB errors.") ) } cnd_body_vctrs_error_subscript_oob_location <- function(cnd, ...) { i <- cnd$i elt <- cnd_subscript_element(cnd) # In case of negative indexing i <- abs(i) # In case of missing locations i <- i[!is.na(i)] oob <- i[i > cnd$size] oob_enum <- enumerate(oob) format_error_bullets(c( x = glue::glue(ngettext( length(oob), "The location {oob_enum} doesn't exist.", "The locations {oob_enum} don't exist." )), i = glue::glue(ngettext( cnd$size, "There are only {cnd$size} {elt[[1]]}.", "There are only {cnd$size} {elt[[2]]}.", )) )) } cnd_body_vctrs_error_subscript_oob_name <- function(cnd, ...) { elt <- cnd_subscript_element(cnd) oob <- cnd$i[!cnd$i %in% cnd$names] oob_enum <- enumerate(glue::backtick(oob)) format_error_bullets(c( x = glue::glue(ngettext( length(oob), "The {elt[[1]]} {oob_enum} doesn't exist.", "The {elt[[2]]} {oob_enum} don't exist." )) )) } stop_location_oob_non_consecutive <- function(i, size, ...) { stop_subscript_oob( i = i, size = size, subscript_type = "numeric", subscript_oob_non_consecutive = TRUE, ... ) } cnd_header_vctrs_error_subscript_oob_non_consecutive <- function(cnd, ...) { action <- cnd_subscript_action(cnd) elt <- cnd_subscript_element(cnd) glue::glue("Can't {action} {elt[[2]]} beyond the end with non-consecutive locations.") } cnd_body_vctrs_error_subscript_oob_non_consecutive <- function(cnd, ...) { i <- sort(cnd$i) i <- i[i > cnd$size] non_consecutive <- i[c(TRUE, diff(i) != 1L)] arg <- append_arg("The subscript", cnd$subscript_arg) if (length(non_consecutive) == 1) { x_line <- glue::glue("{arg} contains non-consecutive location {non_consecutive}.") } else { non_consecutive <- ensure_full_stop(enumerate(non_consecutive)) x_line <- glue::glue("{arg} contains non-consecutive locations {non_consecutive}") } glue_data_bullets( cnd, i = "The input has size {size}.", x = x_line ) } cnd_subscript_oob_non_consecutive <- function(cnd) { out <- cnd$subscript_oob_non_consecutive %||% FALSE stopifnot(is_bool(out)) out } vctrs/R/split.R0000644000176200001440000000205013622451540013071 0ustar liggesusers#' Split a vector into groups #' #' This is a generalisation of [split()] that can split by any type of vector, #' not just factors. Instead of returning the keys in the character names, #' the are returned in a separate parallel vector. #' #' @param x Vector to divide into groups. #' @param by Vector whose unique values defines the groups. #' @return A data frame with two columns and size equal to #' `vec_size(vec_unique(by))`. The `key` column has the same type as #' `by`, and the `val` column is a list containing elements of type #' `vec_ptype(x)`. #' #' Note for complex types, the default `data.frame` print method will be #' suboptimal, and you will want to coerce into a tibble to better #' understand the output. #' @export #' @examples #' vec_split(mtcars$cyl, mtcars$vs) #' vec_split(mtcars$cyl, mtcars[c("vs", "am")]) #' #' if (require("tibble")) { #' as_tibble(vec_split(mtcars$cyl, mtcars[c("vs", "am")])) #' as_tibble(vec_split(mtcars, mtcars[c("vs", "am")])) #' } vec_split <- function(x, by) { .Call(vctrs_split, x, by) } vctrs/R/assert.R0000644000176200001440000001120113623045211013230 0ustar liggesusers#' Assert an argument has known prototype and/or size #' #' @description #' #' * `vec_is()` is a predicate that checks if its input conforms to a #' prototype and/or a size. #' #' * `vec_assert()` throws an error when the input doesn't conform. #' #' @section Error types: #' #' * If the prototype doesn't match, an error of class #' `"vctrs_error_assert_ptype"` is raised. #' #' * If the size doesn't match, an error of class #' `"vctrs_error_assert_size"` is raised. #' #' Both errors inherit from `"vctrs_error_assert"`. #' #' @param x A vector argument to check. #' @param ptype Prototype to compare against. If the prototype has a #' class, its [vec_ptype()] is compared to that of `x` with #' `identical()`. Otherwise, its [typeof()] is compared to that of #' `x` with `==`. #' @param size Size to compare against #' @param arg Name of argument being checked. This is used in error #' messages. The label of the expression passed as `x` is taken as #' default. #' #' @return `vec_is()` returns `TRUE` or `FALSE`. `vec_assert()` either #' throws a typed error (see section on error types) or returns `x`, #' invisibly. #' @export vec_assert <- function(x, ptype = NULL, size = NULL, arg = as_label(substitute(x))) { if (!vec_is_vector(x)) { stop_scalar_type(x, arg) } if (!is_null(ptype)) { ptype <- vec_ptype(ptype) x_type <- vec_ptype_finalise(vec_ptype(x)) if (!is_same_type(x_type, ptype)) { msg <- vec_assert_type_explain(x_type, ptype, arg) abort( msg, class = c("vctrs_error_assert_ptype", "vctrs_error_assert"), required = ptype, actual = x_type ) } } if (!is_null(size)) { size <- vec_recycle(vec_cast(size, integer()), 1L) x_size <- vec_size(x) if (!identical(x_size, size)) { msg <- paste0("`", arg, "` must have size ", size, ", not size ", x_size, ".") abort( msg, class = c("vctrs_error_assert_size", "vctrs_error_assert"), required = size, actual = x_size ) } } invisible(x) } #' @rdname vec_assert #' @export vec_is <- function(x, ptype = NULL, size = NULL) { if (!vec_is_vector(x)) { return(FALSE) } if (!is_null(ptype)) { ptype <- vec_ptype(ptype) x_type <- vec_ptype_finalise(vec_ptype(x)) if (!is_same_type(x_type, ptype)) { return(FALSE) } } if (!is_null(size)) { size <- vec_recycle(vec_cast(size, integer()), 1L) x_size <- vec_size(x) if (!identical(x_size, size)) { return(FALSE) } } TRUE } #' Is object a vector? #' @noRd #' #' @description #' #' Returns `TRUE` if: #' #' * `x` is an atomic, whether it has a class or not. #' * `x` is a bare list without class. #' * `x` implements [vec_proxy()]. #' #' S3 lists are thus treated as scalars unless they implement a proxy. vec_is_vector <- function(x) { .Call(vctrs_is_vector, x) } #' Is the object a list? #' #' @description #' `vec_is_list()` tests if `x` is considered a list in the vctrs sense. It #' returns `TRUE` if: #' #' * `x` is a bare list with no class. #' * `x` is a list explicitly inheriting from `"list"` or `"vctrs_list_of"`. #' * `x` is an S3 list that [vec_is()] returns `TRUE` for. For this to return #' `TRUE`, the class must implement a [vec_proxy()] method. #' #' @param x An object. #' #' @details #' Notably, data frames and S3 record style classes like POSIXlt are not #' considered lists. #' #' @export #' @examples #' vec_is_list(list()) #' vec_is_list(list_of(1)) #' #' vec_is_list(data.frame()) vec_is_list <- function(x) { .Call(vctrs_is_list, x) } is_same_type <- function(x, ptype) { if (is_partial(ptype)) { env <- environment() ptype <- tryCatch( vctrs_error_incompatible_type = function(...) return_from(env, FALSE), vec_ptype_common(x, ptype) ) } x <- vec_slice(x, integer()) ptype <- vec_slice(ptype, integer()) # FIXME: Remove row names for matrices and arrays, and handle empty # but existing dimnames x <- vec_set_names(x, NULL) ptype <- vec_set_names(ptype, NULL) identical(x, ptype) } vec_assert_type_explain <- function(x, type, arg) { arg <- str_backtick(arg) x <- paste0("<", vec_ptype_full(x), ">") type <- paste0("<", vec_ptype_full(type), ">") intro <- paste0(arg, " must be a vector with type") intro <- layout_type(intro, type) outro <- paste0("Instead, it has type") outro <- layout_type(outro, x) paste_line( !!!intro, if (str_is_multiline(intro)) "", !!!outro ) } layout_type <- function(start, type) { if (str_is_multiline(type)) { paste_line( paste0(start, ":"), "", paste0(" ", indent(type, 2)) ) } else { paste0(start, " ", type, ".") } } vctrs/R/type-data-frame.R0000644000176200001440000001046413623032515014724 0ustar liggesusers#' Data frame class #' #' A `data.frame` [data.frame()] is a list with "row.names" attribute. Each #' element of the list must be named, and of the same length. These functions #' help the base data.frame classes fit in to the vctrs type system by #' providing constructors, coercion functions, and casting functions. #' #' @param x A named list of equal-length vectors. The lengths are not #' checked; it is responsibility of the caller to make sure they are #' equal. #' @param n Number of rows. If `NULL`, will be computed from the length of #' the first element of `x`. #' @param ...,class Additional arguments for creating subclasses. #' @export #' @keywords internal #' @examples #' new_data_frame(list(x = 1:10, y = 10:1)) new_data_frame <- function(x = list(), n = NULL, ..., class = NULL) { .External(vctrs_new_data_frame, x, n, class, ...) } new_data_frame <- fn_inline_formals(new_data_frame, "x") # Light weight constructor used for tests - avoids having to repeatedly do # stringsAsFactors = FALSE etc. Should not be used in internal code as is # not a real helper as it lacks value checks. data_frame <- function(...) { cols <- list(...) new_data_frame(cols) } #' @export vec_ptype_full.data.frame <- function(x, ...) { if (length(x) == 0) { return(paste0(class(x)[[1]], "<>")) } else if (length(x) == 1) { return(paste0(class(x)[[1]], "<", names(x), ":", vec_ptype_full(x[[1]]), ">")) } # Needs to handle recursion with indenting types <- map_chr(x, vec_ptype_full) needs_indent <- grepl("\n", types) types[needs_indent] <- map(types[needs_indent], function(x) indent(paste0("\n", x), 4)) names <- paste0(" ", format(names(x))) paste0( class(x)[[1]], "<\n", paste0(names, ": ", types, collapse = "\n"), "\n>" ) } #' @export vec_ptype_abbr.data.frame <- function(x, ...) { paste0("df", vec_ptype_shape(x)) } #' @export vec_proxy_compare.data.frame <- function(x, ..., relax = FALSE) { out <- lapply(as.list(x), vec_proxy_compare, relax = TRUE) new_data_frame(out, nrow(x)) } # Coercion ---------------------------------------------------------------- #' @rdname new_data_frame #' @export vec_ptype2.data.frame #' @method vec_ptype2 data.frame #' @export vec_ptype2.data.frame <- function(x, y, ...) UseMethod("vec_ptype2.data.frame", y) #' @method vec_ptype2.data.frame data.frame #' @export vec_ptype2.data.frame.data.frame <- function(x, y, ..., x_arg = "x", y_arg = "y") { .Call(vctrs_type2_df_df, x, y, x_arg, y_arg) } #' @method vec_ptype2.data.frame default #' @export vec_ptype2.data.frame.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } # Cast -------------------------------------------------------------------- #' @rdname new_data_frame #' @export vec_cast.data.frame #' @method vec_cast data.frame #' @export vec_cast.data.frame <- function(x, to, ...) { UseMethod("vec_cast.data.frame") } #' @export #' @method vec_cast.data.frame data.frame vec_cast.data.frame.data.frame <- function(x, to, ..., x_arg = "x", to_arg = "to") { .Call(vctrs_df_as_dataframe, x, to, x_arg, to_arg) } #' @export #' @method vec_cast.data.frame list vec_cast.data.frame.list <- function(x, to, ..., x_arg = "x", to_arg = "to") { vec_list_cast(x, to, x_arg = x_arg, to_arg = to_arg) } #' @export #' @method vec_cast.data.frame default vec_cast.data.frame.default <- function(x, to, ..., x_arg = "x", to_arg = "to") { vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg) } #' @export vec_restore.data.frame <- function(x, to, ..., n = NULL) { .Call(vctrs_bare_df_restore, x, to, n) } # AsIS -------------------------------------------------------------------- # Arises with base df ctor: `data.frame(x = I(list(1, 2:3)))` #' @export vec_proxy.AsIs <- function(x, ...) { class(x) <- setdiff(class(x), "AsIs") vec_proxy(x) } #' @export vec_restore.AsIs <- function(x, to, ...) { I(x) } # Helpers ----------------------------------------------------------------- df_size <- function(x) { .Call(vctrs_df_size, x) } df_lossy_cast <- function(out, x, to) { extra <- setdiff(names(x), names(to)) maybe_lossy_cast( result = out, x = x, to = to, lossy = length(extra) > 0, locations = int(), details = inline_list("Dropped variables: ", extra, quote = "`"), class = "vctrs_error_cast_lossy_dropped" ) } vctrs/R/type-unspecified.R0000644000176200001440000000516613622451540015226 0ustar liggesusers#' A 1d vector of unspecified type #' #' This is a [partial type][new_partial] used to represent logical vectors #' that only contain `NA`. These require special handling because we want to #' allow `NA` to specify missingness without requiring a type. #' #' @keywords internal #' @param n Length of vector #' @export #' @examples #' vec_ptype_show() #' vec_ptype_show(NA) #' #' vec_c(NA, factor("x")) #' vec_c(NA, Sys.Date()) #' vec_c(NA, Sys.time()) #' vec_c(NA, list(1:3, 4:5)) unspecified <- function(n = 0) { .Call(vctrs_unspecified, n) } #' @export `[.vctrs_unspecified` <- function(x, i, ...) { unspecified(length(NextMethod())) } #' @export print.vctrs_unspecified <- function(x, ...) { cat(" [", length(x), "]\n", sep = "") } #' @export vec_ptype_abbr.vctrs_unspecified <- function(x, ...) { "???" } is_unspecified <- function(x) { .Call(vctrs_is_unspecified, x) } ununspecify <- function(x) { if (is_unspecified(x)) { new_logical(length(x)) } else { x } } # Type system ------------------------------------------------------------- #' @rdname unspecified #' @export vec_ptype2.vctrs_unspecified #' @export vec_ptype2.vctrs_unspecified <- function(x, y, ...) vec_ptype(y) #' @method vec_ptype2.logical vctrs_unspecified #' @export vec_ptype2.logical.vctrs_unspecified <- function(x, y, ...) vec_ptype(x) #' @method vec_ptype2.integer vctrs_unspecified #' @export vec_ptype2.integer.vctrs_unspecified <- function(x, y, ...) vec_ptype(x) #' @method vec_ptype2.double vctrs_unspecified #' @export vec_ptype2.double.vctrs_unspecified <- function(x, y, ...) vec_ptype(x) #' @method vec_ptype2.character vctrs_unspecified #' @export vec_ptype2.character.vctrs_unspecified <- function(x, y, ...) vec_ptype(x) #' @method vec_ptype2.factor vctrs_unspecified #' @export vec_ptype2.factor.vctrs_unspecified <- function(x, y, ...) vec_ptype(x) #' @method vec_ptype2.ordered vctrs_unspecified #' @export vec_ptype2.ordered.vctrs_unspecified <- function(x, y, ...) vec_ptype(x) #' @method vec_ptype2.list vctrs_unspecified #' @export vec_ptype2.list.vctrs_unspecified <- function(x, y, ...) vec_ptype(x) #' @method vec_ptype2.vctrs_list_of vctrs_unspecified #' @export vec_ptype2.vctrs_list_of.vctrs_unspecified <- function(x, y, ...) vec_ptype(x) #' @method vec_ptype2.Date vctrs_unspecified #' @export vec_ptype2.Date.vctrs_unspecified <- function(x, y, ...) vec_ptype(x) #' @method vec_ptype2.POSIXt vctrs_unspecified #' @export vec_ptype2.POSIXt.vctrs_unspecified <- function(x, y, ...) vec_ptype(x) #' @method vec_ptype2.difftime vctrs_unspecified #' @export vec_ptype2.difftime.vctrs_unspecified <- function(x, y, ...) vec_ptype(x) vctrs/R/vctrs-deprecated.R0000644000176200001440000000376413622451540015212 0ustar liggesusers#' Is a vector empty #' #' @description #' #' \Sexpr[results=rd, stage=render]{vctrs:::lifecycle("defunct")} #' #' This function is defunct, please use [vec_is_empty()]. #' #' @param x An object. #' #' @keywords internal #' @export vec_empty <- function(x) { stop_defunct(paste_line( "`vec_empty()` is defunct as of vctrs 0.2.0.", "Please use `vec_is_empty()` instead." )) } #' Deprecated type functions #' #' @description #' #' \Sexpr[results=rd, stage=render]{vctrs:::lifecycle("deprecated")} #' #' These functions have been renamed: #' #' * `vec_type()` => [vec_ptype()] #' * `vec_type2()` => [vec_ptype2()] #' * `vec_type_common()` => [vec_ptype_common()] #' #' @param x,y,...,.ptype Arguments for deprecated functions. #' #' @keywords internal #' @export vec_type <- function(x) { warn_deprecated(c("`vec_type()` has been renamed to `vec_ptype()`.")) vec_ptype(x) } #' @rdname vec_type #' @export vec_type_common <- function(..., .ptype = NULL) { warn_deprecated(c("`vec_type_common()` has been renamed to `vec_ptype_common()`.")) vec_ptype_common(..., .ptype = .ptype) } #' @rdname vec_type #' @export vec_type2 <- function(x, y, ...) { warn_deprecated(c("`vec_type2()` has been renamed to `vec_ptype2()`.")) vec_ptype2(x, y, ...) } #' Convert to an index vector #' #' @description #' #' \Sexpr[results=rd, stage=render]{vctrs:::lifecycle("soft-deprecated")} #' #' `vec_as_index()` has been renamed to [vec_as_location()] and is #' soft-deprecated as of vctrs 0.2.2. #' #' @inheritParams vec_as_location #' #' @keywords internal #' @export vec_as_index <- function(i, n, names = NULL) { signal_soft_deprecated(paste_line( "`vec_as_index()` is deprecated as of vctrs 0.2.2.", "Please use `vec_as_location() instead.`" )) n <- vec_coercible_cast(n, integer()) vec_assert(n, integer(), 1L) i <- vec_as_subscript(i) .Call( vctrs_as_location, i = i, n = n, names = names, loc_negative = "invert", loc_oob = "error", missing = "propagate", arg = NULL ) } vctrs/R/shape.R0000644000176200001440000000371713622451540013051 0ustar liggesusers# The dimensionality of an matrix/array is partition into two parts: # * the first dimension = the number of observations # * all other dimensions = the shape parameter of the type # These helpers work with the shape parameter new_shape <- function(type, shape = NULL) { if (length(shape) == 0L) { type } else { structure(type, dim = c(0L, shape)) } } shape_common <- function(x, y) { shape <- n_dim2(shape(x), shape(y)) map2_int(shape$x, shape$y, axis2) } axis2 <- function(nx, ny) { if (nx == ny) { nx } else if (nx == 1L) { ny } else if (ny == 1L) { nx } else { abort(paste0("Incompatible lengths: ", nx, ", ", ny, ".")) } } shape_broadcast <- function(x, to) { if (is.null(x) || is.null(to)) { return(x) } dim_x <- vec_dim(x) dim_to <- vec_dim(to) # Don't set dimensions for vectors if (length(dim_x) == 1L && length(dim_to) == 1L) { return(x) } if (length(dim_x) > length(dim_to)) { stop_incompatible_cast(x, to, details = "Can not decrease dimensions") } dim_x <- n_dim2(dim_x, dim_to)$x dim_to[[1]] <- dim_x[[1]] # don't change number of observations ok <- dim_x == dim_to | dim_x == 1 if (any(!ok)) { stop_incompatible_cast(x, to, details = "Non-recyclable dimensions") } # Increase dimensionality if required if (vec_dim_n(x) != length(dim_x)) { dim(x) <- dim_x } recycle <- dim_x != dim_to # Avoid expensive subset if (all(!recycle)) { return(x) } indices <- rep(list(missing_arg()), length(dim_to)) indices[recycle] <- map(dim_to[recycle], rep_len, x = 1L) eval_bare(expr(x[!!!indices, drop = FALSE])) } # Helpers ----------------------------------------------------------------- shape <- function(x) { vec_dim(x)[-1] } n_dim2 <- function(x, y) { nx <- length(x) ny <- length(y) if (nx == ny) { list(x = x, y = y) } else if (nx < ny) { list(x = c(x, rep(1L, ny - nx)), y = y) } else { list(x = x, y = c(y, rep(1L, nx - ny))) } } vctrs/R/type-bare.R0000644000176200001440000004633413623013722013640 0ustar liggesusers# Type2 ------------------------------------------------------------------- # Left generics ----------------------------------------------------------- #' @rdname vec_ptype2 #' @export vec_ptype2.logical #' @method vec_ptype2 logical #' @export vec_ptype2.logical <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is.object(x)) { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } else { UseMethod("vec_ptype2.logical", y) } } #' @rdname vec_ptype2 #' @export vec_ptype2.integer #' @method vec_ptype2 integer #' @export vec_ptype2.integer <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is.object(x)) { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } else { UseMethod("vec_ptype2.integer", y) } } #' @rdname vec_ptype2 #' @export vec_ptype2.double #' @method vec_ptype2 double #' @export vec_ptype2.double <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is.object(x)) { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } else { UseMethod("vec_ptype2.double", y) } } #' @rdname vec_ptype2 #' @export vec_ptype2.complex #' @method vec_ptype2 complex #' @export vec_ptype2.complex <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is.object(x)) { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } else { UseMethod("vec_ptype2.complex", y) } } #' @rdname vec_ptype2 #' @export vec_ptype2.character #' @method vec_ptype2 character #' @export vec_ptype2.character <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is.object(x)) { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } else { UseMethod("vec_ptype2.character", y) } } #' @rdname vec_ptype2 #' @export vec_ptype2.raw #' @method vec_ptype2 raw #' @export vec_ptype2.raw <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is.object(x)) { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } else { UseMethod("vec_ptype2.raw", y) } } #' @rdname vec_ptype2 #' @export vec_ptype2.list #' @method vec_ptype2 list #' @export vec_ptype2.list <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is.object(x)) { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } else { UseMethod("vec_ptype2.list", y) } } # Numeric-ish #' @method vec_ptype2.logical logical #' @export vec_ptype2.logical.logical <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is.object(y)) { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } else if (is_unspecified(x) && is_unspecified(y)) { # Special case `vec_ptype2(NA, NA)` to ensure that # `unspecified()` is returned unspecified() } else { shape_match(logical(), x, y) } } #' @export #' @method vec_ptype2.integer integer vec_ptype2.integer.integer <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is.object(y)) { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } else { shape_match(integer(), x, y) } } #' @export #' @method vec_ptype2.logical integer vec_ptype2.logical.integer <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is.object(y)) { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } else { shape_match(integer(), x, y) } } #' @export #' @method vec_ptype2.integer logical vec_ptype2.integer.logical <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is.object(y)) { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } else { shape_match(integer(), x, y) } } #' @export #' @method vec_ptype2.double double vec_ptype2.double.double <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is.object(y)) { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } else { shape_match(double(), x, y) } } #' @export #' @method vec_ptype2.logical double vec_ptype2.logical.double <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is.object(y)) { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } else { shape_match(double(), x, y) } } #' @export #' @method vec_ptype2.double logical vec_ptype2.double.logical <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is.object(y)) { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } else { shape_match(double(), x, y) } } #' @export #' @method vec_ptype2.integer double vec_ptype2.integer.double <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is.object(y)) { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } else { shape_match(double(), x, y) } } #' @export #' @method vec_ptype2.double integer vec_ptype2.double.integer <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is.object(y)) { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } else { shape_match(double(), x, y) } } #' @export #' @method vec_ptype2.complex complex vec_ptype2.complex.complex <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is.object(y)) { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } else { shape_match(complex(), x, y) } } #' @export #' @method vec_ptype2.integer complex vec_ptype2.integer.complex <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is.object(y)) { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } else { shape_match(complex(), x, y) } } #' @export #' @method vec_ptype2.complex integer vec_ptype2.complex.integer <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is.object(y)) { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } else { shape_match(complex(), x, y) } } #' @export #' @method vec_ptype2.double complex vec_ptype2.double.complex <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is.object(y)) { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } else { shape_match(complex(), x, y) } } #' @export #' @method vec_ptype2.complex double vec_ptype2.complex.double <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is.object(y)) { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } else { shape_match(complex(), x, y) } } # Character #' @method vec_ptype2.character character #' @export vec_ptype2.character.character <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is.object(y)) { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } else { shape_match(character(), x, y) } } # Raw #' @export #' @method vec_ptype2.raw raw vec_ptype2.raw.raw <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is.object(y)) { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } else { shape_match(raw(), x, y) } } # Lists #' @method vec_ptype2.list list #' @export vec_ptype2.list.list <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is.object(y)) { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } else { shape_match(list(), x, y) } } # Default #' @method vec_ptype2.logical default #' @export vec_ptype2.logical.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is_unspecified(x)) { vec_ptype(y) } else { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } } #' @method vec_ptype2.integer default #' @export vec_ptype2.integer.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } #' @method vec_ptype2.double default #' @export vec_ptype2.double.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } #' @method vec_ptype2.complex default #' @export vec_ptype2.complex.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } #' @method vec_ptype2.character default #' @export vec_ptype2.character.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } #' @method vec_ptype2.raw default #' @export vec_ptype2.raw.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } #' @method vec_ptype2.list default #' @export vec_ptype2.list.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { stop_incompatible_type(x, y, x_arg = x_arg, y_arg = y_arg) } # Cast -------------------------------------------------------------------- # These methods for base types are handled at the C level unless # inputs have shape or have lossy casts #' @export #' @rdname vec_cast #' @export vec_cast.logical #' @method vec_cast logical vec_cast.logical <- function(x, to, ...) { UseMethod("vec_cast.logical") } #' @export #' @method vec_cast.logical logical vec_cast.logical.logical <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (is.object(x)) { return(vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg)) } shape_broadcast(x, to) } #' @export #' @method vec_cast.logical integer vec_cast.logical.integer <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (is.object(x)) { return(vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg)) } out <- vec_coerce_bare(x, "logical") out <- shape_broadcast(out, to) lossy <- !x %in% c(0L, 1L, NA_integer_) maybe_lossy_cast(out, x, to, lossy, x_arg = x_arg, to_arg = to_arg) } #' @export #' @method vec_cast.logical double vec_cast.logical.double <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (is.object(x)) { return(vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg)) } out <- vec_coerce_bare(x, "logical") out <- shape_broadcast(out, to) lossy <- !x %in% c(0, 1, NA_real_) maybe_lossy_cast(out, x, to, lossy, x_arg = x_arg, to_arg = to_arg) } #' @export #' @method vec_cast.logical character vec_cast.logical.character <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (is.object(x)) { return(vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg)) } out <- vec_coerce_bare(x, "logical") out <- shape_broadcast(out, to) lossy <- !x %in% c("T", "F", "TRUE", "FALSE", "true", "false", NA_character_) maybe_lossy_cast(out, x, to, lossy, x_arg = x_arg, to_arg = to_arg) } #' @export #' @method vec_cast.logical list vec_cast.logical.list <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (is.object(x)) { return(vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg)) } vec_list_cast(x, to, x_arg = x_arg, to_arg = to_arg) } #' @export #' @method vec_cast.logical default vec_cast.logical.default <- function(x, to, ..., x_arg = "x", to_arg = "to") { vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg) } #' @export #' @rdname vec_cast #' @export vec_cast.integer #' @method vec_cast integer vec_cast.integer <- function(x, to, ...) { UseMethod("vec_cast.integer") } #' @export #' @method vec_cast.integer logical vec_cast.integer.logical <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (is.object(x)) { return(vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg)) } x <- vec_coerce_bare(x, "integer") shape_broadcast(x, to) } #' @export #' @method vec_cast.integer integer vec_cast.integer.integer <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (is.object(x)) { return(vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg)) } shape_broadcast(x, to) } #' @export #' @method vec_cast.integer double vec_cast.integer.double <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (is.object(x)) { return(vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg)) } out <- suppressWarnings(vec_coerce_bare(x, "integer")) x_na <- is.na(x) lossy <- (out != x & !x_na) | xor(x_na, is.na(out)) out <- shape_broadcast(out, to) maybe_lossy_cast(out, x, to, lossy, x_arg = x_arg, to_arg = to_arg) } #' @export #' @method vec_cast.integer character vec_cast.integer.character <- vec_cast.integer.double #' @export #' @method vec_cast.integer list vec_cast.integer.list <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (is.object(x)) { return(vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg)) } vec_list_cast(x, to, x_arg = x_arg, to_arg = to_arg) } #' @export #' @method vec_cast.integer default vec_cast.integer.default <- function(x, to, ..., x_arg = "x", to_arg = "to") { vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg) } #' @export #' @rdname vec_cast #' @export vec_cast.double #' @method vec_cast double vec_cast.double <- function(x, to, ...) { UseMethod("vec_cast.double") } #' @export #' @method vec_cast.double logical vec_cast.double.logical <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (is.object(x)) { return(vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg)) } x <- vec_coerce_bare(x, "double") shape_broadcast(x, to) } #' @export #' @method vec_cast.double integer vec_cast.double.integer <- vec_cast.double.logical #' @export #' @method vec_cast.double character vec_cast.double.character <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (is.object(x)) { return(vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg)) } out <- suppressWarnings(vec_coerce_bare(x, "double")) x_na <- is.na(x) lossy <- (out != x & !x_na) | xor(x_na, is.na(out)) out <- shape_broadcast(out, to) maybe_lossy_cast(out, x, to, lossy, x_arg = x_arg, to_arg = to_arg) } #' @export #' @method vec_cast.double double vec_cast.double.double <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (is.object(x)) { return(vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg)) } shape_broadcast(x, to) } #' @export #' @method vec_cast.double list vec_cast.double.list <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (is.object(x)) { return(vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg)) } vec_list_cast(x, to, x_arg = x_arg, to_arg = to_arg) } #' @export #' @method vec_cast.double default vec_cast.double.default <- function(x, to, ..., x_arg = "x", to_arg = "to") { vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg) } #' @export #' @rdname vec_cast #' @export vec_cast.complex #' @method vec_cast complex vec_cast.complex <- function(x, to, ...) { UseMethod("vec_cast.complex") } #' @export #' @method vec_cast.complex logical vec_cast.complex.logical <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (is.object(x)) { return(vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg)) } x <- vec_coerce_bare(x, "complex") shape_broadcast(x, to) } #' @export #' @method vec_cast.complex integer vec_cast.complex.integer <- vec_cast.complex.logical #' @export #' @method vec_cast.complex double vec_cast.complex.double <- vec_cast.complex.logical #' @export #' @method vec_cast.complex complex vec_cast.complex.complex <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (is.object(x)) { return(vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg)) } shape_broadcast(x, to) } #' @export #' @method vec_cast.complex list vec_cast.complex.list <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (is.object(x)) { return(vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg)) } vec_list_cast(x, to, x_arg = x_arg, to_arg = to_arg) } #' @export #' @method vec_cast.complex default vec_cast.complex.default <- function(x, to, ..., x_arg = "x", to_arg = "to") { vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg) } #' @export #' @rdname vec_cast #' @export vec_cast.raw #' @method vec_cast raw vec_cast.raw <- function(x, to, ...) { UseMethod("vec_cast.raw") } #' @export #' @method vec_cast.raw raw vec_cast.raw.raw <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (is.object(x)) { return(vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg)) } shape_broadcast(x, to) } #' @export #' @method vec_cast.raw list vec_cast.raw.list <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (is.object(x)) { return(vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg)) } vec_list_cast(x, to, x_arg = x_arg, to_arg = to_arg) } #' @export #' @method vec_cast.raw default vec_cast.raw.default <- function(x, to, ..., x_arg = "x", to_arg = "to") { vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg) } #' @export #' @rdname vec_cast #' @export vec_cast.character #' @method vec_cast character vec_cast.character <- function(x, to, ...) { UseMethod("vec_cast.character") } #' @export #' @method vec_cast.character logical vec_cast.character.logical <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (is.object(x)) { return(vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg)) } x <- vec_coerce_bare(x, "character") shape_broadcast(x, to) } #' @export #' @method vec_cast.character integer vec_cast.character.integer <- vec_cast.character.logical #' @export #' @method vec_cast.character double vec_cast.character.double <- vec_cast.character.logical #' @export #' @method vec_cast.character character vec_cast.character.character <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (is.object(x)) { return(vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg)) } shape_broadcast(x, to) } #' @export #' @method vec_cast.character difftime vec_cast.character.difftime <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (!inherits_only(x, "difftime")) { return(vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg)) } x <- paste(x, units(x)) shape_broadcast(x, to) } #' @export #' @method vec_cast.character list vec_cast.character.list <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (is.object(x)) { return(vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg)) } vec_list_cast(x, to, x_arg = x_arg, to_arg = to_arg) } #' @export #' @method vec_cast.character default vec_cast.character.default <- function(x, to, ..., x_arg = "x", to_arg = "to") { vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg) } #' @rdname vec_cast #' @export vec_cast.list #' @method vec_cast list #' @export vec_cast.list <- function(x, to, ...) { UseMethod("vec_cast.list") } #' @export #' @method vec_cast.list list vec_cast.list.list <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (is.object(x)) { return(vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg)) } shape_broadcast(x, to) } #' @export #' @method vec_cast.list default vec_cast.list.default <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (is.object(x)) { return(vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg)) } vec_cast_list_default(x, to, x_arg = x_arg, to_arg = to_arg) } vec_cast_list_default <- function(x, to, ..., x_arg = x_arg, to_arg = to_arg) { out <- lapply(seq_along(x), function(i) x[[i]]) vec_slice(out, vec_equal_na(x)) <- list(NULL) if (!is.object(to)) { out <- shape_broadcast(out, to) } out } #' @export #' @method vec_cast.list data.frame vec_cast.list.data.frame <- function(x, to, ...) { # FIXME - Replace with the `vec_chop()` # equivalent for `vec_get()` row.names(x) <- NULL out <- vec_chop(x) vec_slice(out, vec_equal_na(x)) <- list(NULL) if (!is.object(to)) { out <- shape_broadcast(out, to) } out } # compare ------------------------------------------------------------ #' @export vec_proxy_compare.raw <- function(x, ...) { # because: # order(as.raw(1:3)) # #> Error in order(as.raw(1:3)): unimplemented type 'raw' in 'orderVector1' as.integer(x) } # Helpers ----------------------------------------------------------------- lossy_floor <- function(x, to, x_arg = "x", to_arg = "to") { x_floor <- floor(x) lossy <- x != x_floor maybe_lossy_cast(x_floor, x, to, lossy, x_arg = x_arg, to_arg = to_arg) } shape_match <- function(type, x, y) { if (!is.object(x) && !is.object(y)) { shape <- shape_common(x, y) new_shape(type, shape) } else { type } } vctrs/R/utils-cli.R0000644000176200001440000000214713622451540013652 0ustar liggesusers parens <- function(x, left = TRUE) { x_lines <- strsplit(x, "\n") x_lines <- map(x_lines, paren, left = left) map_chr(x_lines, paste0, collapse = "\n") } paren <- function(x, left = TRUE) { if (length(x) <= 1) { if (left) { paste0("( ", x) } else { paste0(x, " )") } } else { if (left) { paste0(c("\u250c ", rep("\u2502 ", length(x) - 2), "\u2514 "), x) } else { paste0(format(x), c(" \u2510", rep(" \u2502", length(x) - 2), " \u2518")) } } } pad_height <- function(x) { pad <- function(x, n) c(x, rep("", n - length(x))) lines <- strsplit(x, "\n") height <- max(map_int(lines, length)) lines <- map(lines, pad, height) map_chr(lines, paste0, "\n", collapse = "") } pad_width <- function(x) { lines <- strsplit(x, "\n", fixed = TRUE) # fix up strsplit bug n <- map_int(lines, length) lines[n == 0] <- "" width <- max(unlist(map(lines, nchar))) lines <- map(lines, format, width = width) map_chr(lines, paste, collapse = "\n") } str_backtick <- function(x) { paste0("`", x, "`") } str_is_multiline <- function(x) { grepl("\n", x) } vctrs/R/compat-friendly-type.R0000644000176200001440000000253113622451540016016 0ustar liggesusers# nocov start --- r-lib/rlang compat-friendly-type --- 2019-09-09 Mon 11:50 friendly_type_of <- function(x, length = FALSE) { if (is.object(x)) { return(sprintf("a `%s` object", paste(class(x), collapse = "/"))) } friendly <- as_friendly_type(typeof(x)) if (length && rlang::is_vector(x)) { friendly <- paste0(friendly, sprintf(" of length %s", length(x))) } friendly } as_friendly_type <- function(type) { switch(type, logical = "a logical vector", integer = "an integer vector", numeric = , double = "a double vector", complex = "a complex vector", character = "a character vector", raw = "a raw vector", string = "a string", list = "a list", NULL = "NULL", environment = "an environment", externalptr = "a pointer", weakref = "a weak reference", S4 = "an S4 object", name = , symbol = "a symbol", language = "a call", pairlist = "a pairlist node", expression = "an expression vector", quosure = "a quosure", formula = "a formula", char = "an internal string", promise = "an internal promise", ... = "an internal dots object", any = "an internal `any` object", bytecode = "an internal bytecode object", primitive = , builtin = , special = "a primitive function", closure = "a function", type ) } # nocov end vctrs/R/recycle.R0000644000176200001440000000405113622451540013367 0ustar liggesusers#' Vector recycling #' #' `vec_recycle(x, size)` recycles a single vector to given size. #' `vec_recycle_common(...)` recycles multiple vectors to their common size. #' All functions obey the vctrs recycling rules, described below, and will #' throw an error if recycling is not possible. See [vec_size()] for the #' precise definition of size. #' #' @section Recycling rules: #' The common size of two vectors defines the recycling rules, and can be #' summarise with the following table: #' #' \figure{sizes-recycling.png} #' #' (Note `NULL`s are handled specially; they are treated like empty #' arguments and hence don't affect the size) #' #' This is a stricter set of rules than base R, which will usually #' return output of length `max(nx, ny)`, warning if the length of the longer #' vector is not an integer multiple of the length of the shorter. #' #' We say that two vectors have __compatible size__ if they can be #' recycled to be the same length. #' #' @param x A vector to recycle. #' @param ... #' * For `vec_recycle_common()`, vectors to recycle. #' * For `vec_recycle()`, these dots should be empty. #' @param size Desired output size. #' @param .size Desired output size. If omitted, #' will use the common size from [vec_size_common()]. #' @param x_arg Argument name for `x`. These are used in error #' messages to inform the user about which argument has an #' incompatible size. #' @export #' @examples #' # Inputs with 1 observation are recycled #' vec_recycle_common(1:5, 5) #' vec_recycle_common(integer(), 5) #' \dontrun{ #' vec_recycle_common(1:5, 1:2) #' } #' #' # Data frames and matrices are recycled along their rows #' vec_recycle_common(data.frame(x = 1), 1:5) #' vec_recycle_common(array(1:2, c(1, 2)), 1:5) #' vec_recycle_common(array(1:3, c(1, 3, 1)), 1:5) vec_recycle <- function(x, size, ..., x_arg = "x") { if (!missing(...)) { ellipsis::check_dots_empty() } .Call(vctrs_recycle, x, size, x_arg) } #' @export #' @rdname vec_recycle vec_recycle_common <- function(..., .size = NULL) { .External2(vctrs_recycle_common, .size) } vctrs/R/arith.R0000644000176200001440000000622313622451540013053 0ustar liggesusers#' Arithmetic operations #' #' This generic provides a common double dispatch mechanism for all infix #' operators (`+`, `-`, `/`, `*`, `^`, `%%`, `%/%`, `!`, `&`, `|`). It is used #' to power the default arithmetic and boolean operators for [vctr]s objects, #' overcoming the limitations of the base [Ops] generic. #' #' `vec_arith_base()` is provided as a convenience for writing methods. It #' recycles `x` and `y` to common length then calls the base operator with the #' underlying [vec_data()]. #' #' `vec_arith()` is also used in `diff.vctrs_vctr()` method via `-`. #' #' @param op An arithmetic operator as a string #' @param x,y A pair of vectors. For `!`, unary `+` and unary `-`, `y` will be #' a sentinel object of class `MISSING`, as created by `MISSING()`. #' @inheritParams ellipsis::dots_empty #' #' @seealso [stop_incompatible_op()] for signalling that an arithmetic #' operation is not permitted/supported. #' @seealso See [vec_math()] for the equivalent for the unary mathematical #' functions. #' @export #' @keywords internal #' @examples #' d <- as.Date("2018-01-01") #' dt <- as.POSIXct("2018-01-02 12:00") #' t <- as.difftime(12, unit = "hours") #' #' vec_arith("-", dt, 1) #' vec_arith("-", dt, t) #' vec_arith("-", dt, d) #' #' vec_arith("+", dt, 86400) #' vec_arith("+", dt, t) #' vec_arith("+", t, t) #' #' vec_arith("/", t, t) #' vec_arith("/", t, 2) #' #' vec_arith("*", t, 2) vec_arith <- function(op, x, y, ...) { if (!missing(...)) { ellipsis::check_dots_empty() } UseMethod("vec_arith", x) } #' @export #' @rdname vec_arith vec_arith.default <- function(op, x, y, ...) { stop_incompatible_op(op, x, y) } # Atomic vectors ---------------------------------------------------------- #' @rdname vec_arith #' @export vec_arith.logical #' @method vec_arith logical #' @export vec_arith.logical <- function(op, x, y, ...) UseMethod("vec_arith.logical", y) #' @method vec_arith.logical default #' @export vec_arith.logical.default <- function(op, x, y, ...) stop_incompatible_op(op, x, y) #' @method vec_arith.logical logical #' @export vec_arith.logical.logical <- function(op, x, y, ...) vec_arith_base(op, x, y) #' @method vec_arith.logical numeric #' @export vec_arith.logical.numeric <- function(op, x, y, ...) vec_arith_base(op, x, y) #' @rdname vec_arith #' @export vec_arith.numeric #' @method vec_arith numeric #' @export vec_arith.numeric <- function(op, x, y, ...) UseMethod("vec_arith.numeric", y) #' @method vec_arith.numeric default #' @export vec_arith.numeric.default <- function(op, x, y, ...) stop_incompatible_op(op, x, y) #' @method vec_arith.numeric logical #' @export vec_arith.numeric.logical <- function(op, x, y, ...) vec_arith_base(op, x, y) #' @method vec_arith.numeric numeric #' @export vec_arith.numeric.numeric <- function(op, x, y, ...) vec_arith_base(op, x, y) # Helpers ----------------------------------------------------------------- #' @export #' @rdname vec_arith vec_arith_base <- function(op, x, y) { args <- vec_recycle_common(x, y) op_fn <- getExportedValue("base", op) op_fn(vec_data(args[[1L]]), vec_data(args[[2L]])) } #' @export #' @rdname vec_arith MISSING <- function() { structure(list(), class = "MISSING") } vctrs/R/ptype-abbr-full.R0000644000176200001440000000514713622451540014755 0ustar liggesusers#' Vector type as a string #' #' `vec_ptype_full()` displays the full type of the vector. `vec_ptype_abbr()` #' provides an abbreviated summary suitable for use in a column heading. #' #' @section S3 dispatch: #' The default method for `vec_ptype_full()` uses the first element of the #' class vector. Override this method if your class has parameters that should #' be prominently displayed. #' #' The default method for `vec_ptype_abbr()` [abbreviate()]s `vec_ptype_full()` #' to 8 characters. You should almost always override, aiming for 4-6 #' characters where possible. #' #' @param x A vector. #' @inheritParams ellipsis::dots_empty #' #' @keywords internal #' @return A string. #' @export #' @examples #' cat(vec_ptype_full(1:10)) #' cat(vec_ptype_full(iris)) #' #' cat(vec_ptype_abbr(1:10)) vec_ptype_full <- function(x, ...) { if (!missing(...)) { ellipsis::check_dots_empty() } UseMethod("vec_ptype_full") } #' @export #' @rdname vec_ptype_full vec_ptype_abbr <- function(x, ...) { if (!missing(...)) { ellipsis::check_dots_empty() } UseMethod("vec_ptype_abbr") } vec_ptype_full.NULL <- function(x, ...) "NULL" vec_ptype_abbr.NULL <- function(x, ...) "NULL" # Default: base types and fallback for S3/S4 ------------------------------ #' @export vec_ptype_full.default <- function(x, ...) { if (is.object(x)) { class(x)[[1]] } else if (is_vector(x)) { paste0(typeof(x), vec_ptype_shape(x)) } else { abort("Not a vector.") } } #' @export vec_ptype_abbr.default <- function(x, ...) { if (is.object(x)) { unname(abbreviate(vec_ptype_full(x), 8)) } else if (is_list(x)) { named <- is_character(names(x)) paste0(if (named) "named ", "list", vec_ptype_shape(x)) } else if (is_vector(x)) { abbr <- switch(typeof(x), logical = "lgl", integer = "int", double = "dbl", character = "chr", complex = "cpl", list = "list", expression = "expr", raw = "raw", abbreviate(typeof(x)) ) paste0(abbr, vec_ptype_shape(x)) } else { abort("Not a vector.") } } # AsIs -------------------------------------------------------------------- #' @export vec_ptype_full.AsIs <- function(x, ...) { class(x) <- setdiff(class(x), "AsIs") paste0("I<", vec_ptype_full(x), ">") } #' @export vec_ptype_abbr.AsIs <- function(x, ...) { class(x) <- setdiff(class(x), "AsIs") paste0("I<", vec_ptype_abbr(x), ">") } # Helpers ----------------------------------------------------------------- vec_ptype_shape <- function(x) { dim <- dim2(x) if (length(dim) == 1) { "" } else { paste0("[,", paste(dim[-1], collapse = ","), "]") } } vctrs/R/subscript.R0000644000176200001440000002412313622451540013761 0ustar liggesusers#' Convert to a base subscript type #' #' @description #' #' \Sexpr[results=rd, stage=render]{vctrs:::lifecycle("experimental")} #' #' Convert `i` to the base type expected by [vec_as_location()] or #' [vec_as_location2()]. The values of the subscript type are #' not checked in any way (length, missingness, negative elements). #' #' @inheritParams vec_as_location #' @param logical,location,character How to handle logical, numeric, #' and character subscripts. #' #' If `"cast"` and the subscript is not one of the three base types #' (logical, integer or character), the subscript is #' [cast][vec_cast] to the relevant base type, e.g. factors are #' coerced to character. `NULL` is treated as an empty integer #' vector, and is thus coercible depending on the setting of #' `numeric`. Symbols are treated as character vectors and thus #' coercible depending on the setting of `character`. #' #' If `"error"`, the subscript type is disallowed and triggers an #' informative error. #' @keywords internal #' @export vec_as_subscript <- function(i, ..., logical = c("cast", "error"), numeric = c("cast", "error"), character = c("cast", "error"), arg = NULL) { if (!missing(...)) ellipsis::check_dots_empty() result_get(vec_as_subscript_result( i, arg = arg, logical = logical, numeric = numeric, character = character )) } vec_as_subscript_result <- function(i, arg, logical, numeric, character) { logical <- arg_match(logical, c("cast", "error")) numeric <- arg_match(numeric, c("cast", "error")) character <- arg_match(character, c("cast", "error")) if (is_null(i) && numeric == "cast") { i <- integer() } if (is_symbol(i) && character == "cast") { i <- as_string(i) } if (!vec_is(i)) { return(result(err = new_error_subscript_type( i = i, subscript_arg = arg, logical = logical, numeric = numeric, character = character ))) } nms <- names(i) orig <- i # Coerce to base types if (is.object(i)) { if (vec_is_coercible(i, lgl())) { i <- vec_cast(i, lgl()) } else if (vec_is_coercible(i, int())) { i <- vec_cast(i, int()) } else if (vec_is_coercible(i, chr())) { i <- vec_cast(i, chr()) } else { return(result(err = new_error_subscript_type( i, subscript_arg = arg, logical = logical, numeric = numeric, character = character ))) } } else if (is_double(i)) { result <- tryCatch( { i <- vec_coercible_cast(i, int(), x_arg = arg, to_arg = "") names(i) <- nms result(i) }, vctrs_error_cast_lossy = function(err) { result(err = new_error_subscript_type( i = i, parent = err, body = cnd_bullets_subscript_lossy_cast, logical = logical, numeric = numeric, character = character )) }) return(result) } # Coerce unspecified vectors to integer only if logical indices # are not allowed if (logical == "error" && is_unspecified(i)) { if (numeric == "cast") { i <- vec_cast(i, int()) } else { i <- vec_cast(i, chr()) } } action <- switch(typeof(i), logical = logical, integer = numeric, character = character, "error" ) if (action == "error") { result(err = new_error_subscript_type( i = i, subscript_arg = arg, logical = logical, numeric = numeric, character = character )) } else { # FIXME: Work around lack of character restoration in `vec_cast()` names(i) <- nms result(i) } } #' @rdname vec_as_subscript #' @export vec_as_subscript2 <- function(i, ..., logical = c("cast", "error"), numeric = c("cast", "error"), character = c("cast", "error"), arg = NULL) { if (!missing(...)) ellipsis::check_dots_empty() result_get(vec_as_subscript2_result( i, arg, logical = logical, numeric = numeric, character = character )) } vec_as_subscript2_result <- function(i, arg, logical = "cast", numeric = "cast", character = "cast") { logical <- arg_match(logical, c("cast", "error")) numeric <- arg_match(numeric, c("cast", "error")) character <- arg_match(character, c("cast", "error")) result <- vec_as_subscript_result( i, arg = arg, logical = logical, numeric = numeric, character = character ) # Return a subclass of subscript error if (!is_null(result$err)) { parent <- result$err$parent if (inherits(parent, "vctrs_error_cast_lossy")) { bullets <- cnd_bullets_subscript_lossy_cast } else { bullets <- cnd_body.vctrs_error_subscript_type } result$err <- new_error_subscript2_type( i = result$err$i, logical = logical, numeric = numeric, character = character, subscript_arg = arg, body = bullets, parent = result$err$parent ) return(result) } i <- result$ok if (typeof(i) == "logical") { return(result(err = new_error_subscript2_type( i = i, logical = logical, numeric = numeric, character = character, subscript_arg = arg, body = cnd_body.vctrs_error_subscript_type ))) } result } subscript_type_opts <- c("logical", "numeric", "character") subscript_type_opts_indefinite_singular <- c("a logical flag", "a location", "a name") subscript_type_opts_indefinite_plural <- c("logical flags", "locations", "names") as_opts_subscript_type <- function(x, arg = NULL) { if (inherits(x, "vctrs_opts_subscript_type")) { return(x) } new_opts( x, subscript_type_opts, subclass = "vctrs_opts_subscript_type", arg = arg ) } as_opts_subscript2_type <- function(x, arg = NULL) { if ("logical" %in% x) { abort("Logical subscripts can't be converted to a single location.") } as_opts_subscript_type(x, arg = arg) } stop_subscript <- function(i, ..., class = NULL) { abort( class = c(class, "vctrs_error_subscript"), i = i, ... ) } new_error_subscript <- function(class = NULL, i, ...) { error_cnd( c(class, "vctrs_error_subscript"), i = i, ... ) } new_error_subscript_type <- function(i, logical = "cast", numeric = "cast", character = "cast", ..., class = NULL) { new_error_subscript( class = c(class, "vctrs_error_subscript_type"), i = i, logical = logical, numeric = numeric, character = character, ... ) } #' @export cnd_header.vctrs_error_subscript_type <- function(cnd) { action <- cnd_subscript_action(cnd) elt <- cnd_subscript_element(cnd) if (cnd_subscript_scalar(cnd)) { glue::glue("Must {action} {elt[[1]]} with a single valid subscript.") } else { glue::glue("Must {action} {elt[[2]]} with a valid subscript vector.") } } #' @export cnd_body.vctrs_error_subscript_type <- function(cnd) { arg <- append_arg("The subscript", cnd$subscript_arg) type <- obj_type(cnd$i) expected_types <- collapse_subscript_type(cnd) format_error_bullets(c( x = glue::glue("{arg} has the wrong type `{type}`."), i = glue::glue("It must be {expected_types}.") )) } cnd_bullets_subscript_lossy_cast <- function(cnd, ...) { format_error_bullets(c(x = cnd_header(cnd$parent))) } collapse_subscript_type <- function(cnd) { types <- c("logical", "numeric", "character") allowed <- cnd[types] != "error" types <- types[allowed] if (length(types) == 2) { last <- " or " } else { last <- ", or " } glue::glue_collapse(types, sep = ", ", last = last) } new_error_subscript_size <- function(i, ..., class = NULL) { new_error_subscript( class = c(class, "vctrs_error_subscript_size"), i = i, ... ) } #' @export cnd_header.vctrs_error_subscript_size <- function(cnd, ...) { cnd_header.vctrs_error_subscript_type(cnd, ...) } new_error_subscript2_type <- function(i, logical, numeric, character, ...) { new_error_subscript_type( i = i, logical = logical, numeric = numeric, character = character, subscript_scalar = TRUE, ... ) } cnd_subscript_element <- function(cnd) { elt <- cnd$subscript_elt %||% "element" if (!is_string(elt, c("element", "row", "column"))) { abort(paste0( "Internal error: `cnd$subscript_elt` must be one of ", "`element`, `row`, or `column`." )) } switch(elt, element = c("element", "elements"), row = c("row", "rows"), column = c("column", "columns") ) } subscript_actions <- c( "subset", "extract", "assign", "rename", "remove", "negate" ) cnd_subscript_action <- function(cnd, assign_to = TRUE) { action <- cnd$subscript_action if (is_null(action)) { if (cnd_subscript_scalar(cnd)) { action <- "extract" } else { action <- "subset" } } if (!is_string(action, subscript_actions)) { abort(paste0( "Internal error: `cnd$subscript_action` must be one of ", "`subset`, `extract`, `assign`, `rename`, `remove`, or `negate`." )) } if (assign_to && action == "assign") { "assign to" } else { action } } cnd_subscript_type <- function(cnd) { type <- cnd$subscript_type if (!is_string(type, c("logical", "numeric", "character"))) { abort("Internal error: `cnd$subscript_type` must be `logical`, `numeric`, or `character`.") } type } cnd_subscript_scalar <- function(cnd) { out <- cnd$subscript_scalar %||% FALSE if (!is_bool(out)) { abort("Internal error: `cnd$subscript_scalar` must be a boolean.") } out } vctrs/R/size.R0000644000176200001440000001210413622451540012711 0ustar liggesusers#' Number of observations #' #' @description #' #' `vec_size(x)` returns the size of a vector. `vec_is_empty()` #' returns `TRUE` if the size is zero, `FALSE` otherwise. #' #' The size is distinct from the [length()] of a vector because it #' generalises to the "number of observations" for 2d structures, #' i.e. it's the number of rows in matrix or a data frame. This #' definition has the important property that every column of a data #' frame (even data frame and matrix columns) have the same size. #' `vec_size_common(...)` returns the common size of multiple vectors. #' #' @seealso [vec_slice()] for a variation of `[` compatible with `vec_size()`, #' and [vec_recycle()] to recycle vectors to common length. #' @section Invariants: #' * `vec_size(dataframe)` == `vec_size(dataframe[[i]])` #' * `vec_size(matrix)` == `vec_size(matrix[, i, drop = FALSE])` #' * `vec_size(vec_c(x, y))` == `vec_size(x)` + `vec_size(y)` #' #' @param x,... Vector inputs or `NULL`. #' @param .size If `NULL`, the default, the output size is determined by #' recycling the lengths of all elements of `...`. Alternatively, you can #' supply `.size` to force a known size; in this case, `x` and `...` are #' ignored. #' @param .absent The size used when no input is provided, or when all input #' is `NULL`. If left as `NULL` when no input is supplied, an error is thrown. #' @return An integer (or double for long vectors). #' #' `vec_size_common()` returns `.absent` if all inputs are `NULL` or #' absent, `0L` by default. #' #' #' @details #' #' There is no vctrs helper that retrieves the number of columns: as this #' is a property of the [type][vec_ptype_show()]. #' #' `vec_size()` is equivalent to `NROW()` but has a name that is easier to #' pronounce, and throws an error when passed non-vector inputs. #' #' #' @section The size of NULL: #' #' The size of `NULL` is hard-coded to `0L` in `vec_size()`. #' `vec_size_common()` returns `.absent` when all inputs are `NULL` #' (if only some inputs are `NULL`, they are simply ignored). #' #' A default size of 0 makes sense because sizes are most often #' queried in order to compute a total size while assembling a #' collection of vectors. Since we treat `NULL` as an absent input by #' principle, we return the identity of sizes under addition to #' reflect that an absent input doesn't take up any size. #' #' Note that other defaults might make sense under different #' circumstances. For instance, a default size of 1 makes sense for #' finding the common size because 1 is the identity of the recycling #' rules. #' #' #' @export #' @examples #' vec_size(1:100) #' vec_size(mtcars) #' vec_size(array(dim = c(3, 5, 10))) #' #' vec_size_common(1:10, 1:10) #' vec_size_common(1:10, 1) #' vec_size_common(integer(), 1) vec_size <- function(x) { .Call(vctrs_size, x) } #' @export #' @rdname vec_size vec_size_common <- function(..., .size = NULL, .absent = 0L) { .External2(vctrs_size_common, .size, .absent) } #' @rdname vec_size #' @export vec_is_empty <- function(x) { vec_size(x) == 0L } #' Default value for empty vectors #' #' Use this inline operator when you need to provide a default value for #' empty (as defined by [vec_is_empty()]) vectors. #' #' @param x A vector #' @param y Value to use if `x` is empty. To preserve type-stability, should #' be the same type as `x`. #' @rdname op-empty-default #' @export #' @examples #' 1:10 %0% 5 #' integer() %0% 5 `%0%` <- function(x, y) { if (vec_is_empty(x)) y else x } # sequences ------------------------------------------------------------------- #' Useful sequences #' #' `vec_seq_along()` is equivalent to [seq_along()] but uses size, not length. #' `vec_init_along()` creates a vector of missing values with size matching #' an existing object. #' #' @param x,y Vectors #' @return #' * `vec_seq_along()` an integer vector with the same size as `x`. #' * `vec_init_along()` a vector with the same type as `x` and the same size #' as `y`. #' @export #' @examples #' vec_seq_along(mtcars) #' vec_init_along(head(mtcars)) vec_seq_along <- function(x) { seq_len(vec_size(x)) } #' @export #' @rdname vec_seq_along vec_init_along <- function(x, y = x) { vec_slice(x, rep_len(NA_integer_, vec_size(y))) } #' Expand the length of a vector #' #' This is a special case of [rep()] for the special case of integer `times` #' and `each` values, and works along size, rather than length. #' #' @param x A vector. #' @param each Number of times to repeat each element of `x`. #' @param times Number of times to repeat the whole vector of `x`. #' @return A vector the same type as `x` with size `vec_size(x) * times * each`. #' @export #' @examples #' # each repeats within #' vec_repeat(1:3, each = 2) #' # times repeats whole thing #' vec_repeat(1:3, times = 2) #' #' df <- data.frame(x = 1:2, y = 1:2) #' # rep() repeats columns of data frame, and returns list: #' rep(df, each = 2) #' # vec_repeat() repeats rows, and returns same data.frame #' vec_repeat(df, 2) vec_repeat <- function(x, each = 1L, times = 1L) { vec_assert(each, size = 1L) vec_assert(times, size = 1L) idx <- rep(vec_seq_along(x), times = times, each = each) vec_slice(x, idx) } vctrs/R/cast.R0000644000176200001440000001625113622451540012700 0ustar liggesusers#' Cast a vector to specified type #' #' `vec_cast()` provides general coercions from one type of vector to another, #' and along with [vec_ptype2()] forms the foundation of the vctrs type system. #' It should generally not be called by R users, but is important for R #' developers. `vec_restore()` is designed specifically for casting a bare #' vector to the original type; it's useful when relying `NextMethod()` for #' the actual implementation. `vec_cast_common(...)` casts a collection to #' vectors to the same type. #' #' @section Casting rules: #' Casting is more flexible than coercion, and allows for the possibility of #' information loss. This diagram summarises possible coercions. `vec_cast()` #' from any type connected to another type, provided that the arrows are #' followed in only one direction. For example you can cast from logical to #' character, and list to time, but you can not cast from logical to datetime. #' #' \figure{cast.png} #' #' Most casts are not symmetric: you can cast all integers to doubles, but you #' can only cast a subset of doubles back to integers. If a cast is potentially #' lossy, an error will be shown whenever an actual loss occurs. #' #' The rules for coercing from a list are fairly strict: each component of the #' list must be of length 1, and must be coercible to type `to`. This ensures #' that a round-trip to and form list is possible, without opening the door #' to very flexible list flattening (which should be the job of a more #' specialised function). #' #' @section S3 dispatch: #' `vec_cast()` dispatches on both arguments because casting depends on both #' the type of `x` and of `to`. This is implemented by having methods of #' `vec_cast()`, e.g. `vec_cast.integer()` also be S3 generics, which call #' e.g. `vec_cast.integer.double()`. #' #' Note that `vec_cast()` dispatches on its second argument, so that the name #' of the final method uses the same convention as `as.xyz()` methods, i.e. #' `vec_cast.integer.double()` casts double to integers, in the same way #' that `as.integer.double()` would. #' #' Whenever you implement a `vec_cast.new_class()` generic/method, #' make sure to always provide `vec_cast.new_class.default()` and #' call [vec_default_cast()] from that method. #' #' See `vignette("s3-vector")` for full details. #' #' #' @section Restoring attributes: #' #' A restore is a specialised type of cast, primarily used in #' conjunction with `NextMethod()` or a C-level function that works on #' the underlying data structure. A `vec_restore()` method can make #' the following assumptions about `x`: #' #' * It has the correct type. #' * It has the correct names. #' * It has the correct `dim` and `dimnames` attributes. #' * It is unclassed. This way you can call vctrs generics with `x` #' without triggering an infinite loop of restoration. #' #' The length may be different (for example after [vec_slice()] has #' been called), and all other attributes may have been lost. The #' method should restore all attributes so that after restoration, #' `vec_restore(vec_data(x), x)` yields `x`. #' #' To understand the difference between `vec_cast()` and `vec_restore()` #' think about factors: it doesn't make sense to cast an integer to a factor, #' but if `NextMethod()` or another low-level function has stripped attributes, #' you still need to be able to restore them. #' #' The default method copies across all attributes so you only need to #' provide your own method if your attributes require special care #' (i.e. they are dependent on the data in some way). When implementing #' your own method, bear in mind that many R users add attributes to track #' additional metadata that is important to them, so you should preserve any #' attributes that don't require special handling for your class. #' #' @param x Vectors to cast. #' @param ... For `vec_cast_common()`, vectors to cast. For #' `vec_cast()` and `vec_restore()`, these dots are only for future #' extensions and should be empty. #' @param to,.to Type to cast to. If `NULL`, `x` will be returned as is. #' @param n \Sexpr[results=rd, stage=render]{vctrs:::lifecycle("experimental")} #' The total size to restore to. This is currently passed by #' `vec_slice()` to solve edge cases arising in data frame #' restoration. In most cases you don't need this information and #' can safely ignore that argument. This parameter should be #' considered internal and experimental, it might change in the #' future. #' @param x_arg,to_arg Argument names for `x` and `to`. These are used #' in error messages to inform the user about the locations of #' incompatible types (see [stop_incompatible_type()]). #' @return A vector the same length as `x` with the same type as `to`, #' or an error if the cast is not possible. An error is generated if #' information is lost when casting between compatible types (i.e. when #' there is no 1-to-1 mapping for a specific value). #' @export #' @keywords internal #' @examples #' # x is a double, but no information is lost #' vec_cast(1, integer()) #' #' # When information is lost the cast fails #' try(vec_cast(c(1, 1.5), integer())) #' try(vec_cast(c(1, 2), logical())) #' #' # You can suppress this error and get the partial results #' allow_lossy_cast(vec_cast(c(1, 1.5), integer())) #' allow_lossy_cast(vec_cast(c(1, 2), logical())) #' #' # By default this suppress all lossy cast errors without #' # distinction, but you can be specific about what cast is allowed #' # by supplying prototypes #' allow_lossy_cast(vec_cast(c(1, 1.5), integer()), to_ptype = integer()) #' try(allow_lossy_cast(vec_cast(c(1, 2), logical()), to_ptype = integer())) #' #' # No sensible coercion is possible so an error is generated #' try(vec_cast(1.5, factor("a"))) #' #' # Cast to common type #' vec_cast_common(factor("a"), factor(c("a", "b"))) vec_cast <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (!missing(...)) { ellipsis::check_dots_empty() } return(.Call(vctrs_cast, x, to, x_arg, to_arg)) UseMethod("vec_cast", to) } vec_cast_dispatch <- function(x, to, ..., x_arg = "x", to_arg = "to") { UseMethod("vec_cast", to) } #' @export #' @rdname vec_cast vec_cast_common <- function(..., .to = NULL) { .External2(vctrs_cast_common, .to) } #' @export vec_cast.default <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (has_same_type(x, to)) { return(x) } stop_incompatible_cast(x, to, x_arg = x_arg, to_arg = to_arg) } # Cast `x` to `to` but only if they are coercible vec_coercible_cast <- function(x, to, ..., x_arg = "x", to_arg = "to") { if (!missing(...)) { ellipsis::check_dots_empty() } .Call(vctrs_coercible_cast, x, to, x_arg, to_arg) } #' Default cast method #' #' @description #' #' This function should typically be called from the default #' [vec_cast()] method for your class, e.g. `vec_cast.myclass.default()`. #' It does two things: #' #' * If `x` is an [unspecified] vector, it automatically casts it to #' `to` using [vec_init()]. #' #' * Otherwise, an error is thrown with [stop_incompatible_cast()]. #' #' @inheritParams vec_cast #' @export vec_default_cast <- function(x, to, x_arg = "x", to_arg = "to") { if (is_unspecified(x)) { vec_init(to, length(x)) } else { stop_incompatible_cast(x, to, x_arg = x_arg, to_arg = to_arg) } } vctrs/R/aaa.R0000644000176200001440000000053013622451540012461 0ustar liggesusers # nocov start # Useful for micro-optimising default arguments requiring evaluation, # such as `param = c("foo", "bar")`. Buys about 0.6us on my desktop. fn_inline_formals <- function(fn, names) { stopifnot(typeof(fn) == "closure") fmls <- formals(fn) fmls[names] <- lapply(fmls[names], eval) formals(fn) <- fmls fn } # nocov end vctrs/R/slice.R0000644000176200001440000001441013623201552013035 0ustar liggesusers#' Get or set observations in a vector #' #' This provides a common interface to extracting and modifying observations #' for all vector types, regardless of dimensionality. It is an analog to `[` #' that matches [vec_size()] instead of `length()`. #' #' @param x A vector #' @param i An integer, character or logical vector specifying the #' locations or names of the observations to get/set. Specify #' `TRUE` to index all elements (as in `x[]`), or `NULL`, `FALSE` or #' `integer()` to index none (as in `x[NULL]`). #' @param value Replacement values. `value` is cast to the type of #' `x`, but only if they have a common type. See below for examples #' of this rule. #' @return A vector of the same type as `x`. #' #' @section Genericity: #' #' Support for S3 objects depends on whether the object implements a #' [vec_proxy()] method. #' #' * When a `vec_proxy()` method exists, the proxy is sliced and #' `vec_restore()` is called on the result. #' #' * Otherwise `vec_slice()` falls back to the base generic `[`. #' #' Note that S3 lists are treated as scalars by default, and will #' cause an error if they don't implement a [vec_proxy()] method. #' #' @section Differences with base R subsetting: #' #' * `vec_slice()` only slices along one dimension. For #' two-dimensional types, the first dimension is subsetted. #' #' * `vec_slice()` preserves attributes by default. #' #' * `vec_slice<-()` is type-stable and always returns the same type #' as the LHS. #' #' @export #' @keywords internal #' @examples #' x <- sample(10) #' x #' vec_slice(x, 1:3) #' #' # You can assign with the infix variant: #' vec_slice(x, 2) <- 100 #' x #' #' # Or with the regular variant that doesn't modify the original input: #' y <- vec_assign(x, 3, 500) #' y #' x #' #' #' # Slicing objects of higher dimension: #' vec_slice(mtcars, 1:3) #' #' # Type stability -------------------------------------------------- #' #' # The assign variant is type stable. It always returns the same #' # type as the input. #' x <- 1:5 #' vec_slice(x, 2) <- 20.0 #' #' # `x` is still an integer vector because the RHS was cast to the #' # type of the LHS: #' vec_ptype(x) #' #' # Compare to `[<-`: #' x[2] <- 20.0 #' vec_ptype(x) #' #' #' # Note that the types must be coercible for the cast to happen. #' # For instance, you can cast a character vector to an integer: #' vec_cast("1", integer()) #' #' # But these types are not coercible: #' try(vec_ptype2("1", integer())) #' #' # Hence you cannot assign character values to an integer or double #' # vector: #' try(vec_slice(x, 2) <- "20") vec_slice <- function(x, i) { .Call(vctrs_slice, x, i) } # Called when `x` has dimensions vec_slice_fallback <- function(x, i) { out <- unclass(vec_proxy(x)) vec_assert(out) d <- vec_dim_n(out) if (d == 2) { out <- out[i, , drop = FALSE] } else { miss_args <- rep(list(missing_arg()), d - 1) out <- eval_bare(expr(out[i, !!!miss_args, drop = FALSE])) } vec_restore(out, x) } vec_slice_fallback_integer64 <- function(x, i) { d <- vec_dim_n(x) if (d == 2) { out <- x[i, , drop = FALSE] } else { miss_args <- rep(list(missing_arg()), d - 1) out <- eval_bare(expr(x[i, !!!miss_args, drop = FALSE])) } is_na <- is.na(i) if (!any(is_na)) { return(out) } if (d == 2) { out[is_na,] <- bit64::NA_integer64_ } else { eval_bare(expr(out[is_na, !!!miss_args] <- bit64::NA_integer64_)) } out } # bit64::integer64() objects do not have support for `NA_integer_` # slicing. This manually replaces the garbage values that are created # any time a slice with `NA_integer_` is made. vec_slice_dispatch_integer64 <- function(x, i) { out <- x[i] is_na <- is.na(i) if (!any(is_na)) { return(out) } out[is_na] <- bit64::NA_integer64_ out } #' @rdname vec_slice #' @export `vec_slice<-` <- function(x, i, value) { .Call(vctrs_assign, x, i, value) } #' @rdname vec_slice #' @export vec_assign <- function(x, i, value) { .Call(vctrs_assign, x, i, value) } vec_assign_fallback <- function(x, i, value) { # Work around bug in base `[<-` existing <- !is.na(i) i <- vec_slice(i, existing) value <- vec_slice(value, existing) d <- vec_dim_n(x) miss_args <- rep(list(missing_arg()), d - 1) eval_bare(expr(x[i, !!!miss_args] <- value)) x } vec_remove <- function(x, i) { vec_slice(x, -vec_as_location(i, length(x), names(x))) } vec_index <- function(x, i, ...) { i <- maybe_missing(i, TRUE) if (!dots_n(...)) { return(vec_slice(x, i)) } # Need to unclass to avoid infinite recursion through `[` proxy <- unclass(vec_proxy(x)) vec_assert(proxy) i <- vec_as_location(i, vec_size(x), vec_names(x)) out <- proxy[i, ..., drop = FALSE] vec_restore(out, x, n = length(i)) } #' Initialize a vector #' #' @param x Template of vector to initialize. #' @param n Desired size of result. #' @export #' @examples #' vec_init(1:10, 3) #' vec_init(Sys.Date(), 5) #' vec_init(mtcars, 2) vec_init <- function(x, n = 1L) { n <- vec_cast(n, integer()) vec_assert(n, size = 1L) .Call(vctrs_init, x, n) } #' Repeatedly slice a vector #' #' `vec_chop()` provides an efficient method to repeatedly slice a vector. It #' captures the pattern of `map(indices, vec_slice, x = x)`. #' #' @param x A vector #' @param indices A list of index values to slice `x` with, or `NULL`. Each #' element of the list must be an integer, character or logical vector that #' would be valid as an index in [vec_slice()]. If `NULL`, `x` is split into #' its individual elements, equivalent to using an `indices` of #' `as.list(vec_seq_along(x))`. #' @return A list of size `vec_size(indices)` or, if `indices == NULL`, #' `vec_size(x)`. #' @export #' @examples #' vec_chop(1:5) #' vec_chop(1:5, list(1, 1:2)) #' vec_chop(mtcars, list(1:3, 4:6)) vec_chop <- function(x, indices = NULL) { .Call(vctrs_chop, x, indices) } # Exposed for testing (`starts` is 0-based) vec_chop_seq <- function(x, starts, sizes, increasings = TRUE) { args <- vec_recycle_common(starts, sizes, increasings) .Call(vctrs_chop_seq, x, args[[1]], args[[2]], args[[3]]) } # Exposed for testing (`start` is 0-based) vec_slice_seq <- function(x, start, size, increasing = TRUE) { .Call(vctrs_slice_seq, x, start, size, increasing) } # Exposed for testing (`i` is 1-based) vec_slice_rep <- function(x, i, n) { .Call(vctrs_slice_rep, x, i, n) } vctrs/R/partial-frame.R0000644000176200001440000000471013622451540014467 0ustar liggesusers#' Partially specify columns of a data frame #' #' This special class can be passed to `.ptype` in order to specify the #' types of only some of the columns in a data frame. #' #' @param ... Attributes of subclass #' @export #' @examples #' pf <- partial_frame(x = double()) #' pf #' #' vec_rbind( #' data.frame(x = 1L, y = "a"), #' data.frame(x = FALSE, z = 10), #' .ptype = partial_frame(x = double(), a = character()) #' ) partial_frame <- function(...) { args <- list2(...) args <- lapply(args, vec_ptype) partial <- new_data_frame(args, n = 0L) new_partial_frame(partial) } new_partial_frame <- function(partial = data.frame(), learned = data.frame()) { stopifnot( is.data.frame(partial), is.data.frame(learned) ) # Fails if `learned` is not compatible with `partial` vec_ptype2(partial, learned) new_partial( partial = partial, learned = learned, class = "vctrs_partial_frame" ) } #' @export vec_ptype_full.vctrs_partial_frame <- function(x, ...) { both <- c(as.list(x$partial), as.list(x$learned)) types <- map_chr(both, vec_ptype_full) needs_indent <- grepl("\n", types) types[needs_indent] <- map(types[needs_indent], function(x) indent(paste0("\n", x), 4)) source <- c(rep(" {partial}", length(x$partial)), rep("", length(x$learned))) names <- paste0(" ", format(names(both))) paste0( "partial_frame<\n", paste0(names, ": ", types, source, collapse = "\n"), "\n>" ) } #' @export vec_ptype_abbr.vctrs_partial_frame <- function(x, ...) { "prtl" } #' @method vec_ptype2 vctrs_partial_frame #' @export vec_ptype2.vctrs_partial_frame <- function(x, y, ...) { UseMethod("vec_ptype2.vctrs_partial_frame", y) } #' @method vec_ptype2.vctrs_partial_frame vctrs_partial_frame #' @export vec_ptype2.vctrs_partial_frame.vctrs_partial_frame <- function(x, y, ...) { partial <- vec_ptype2(x$partial, y$partial) learned <- vec_ptype2(x$learned, y$learned) new_partial_frame(partial, learned) } #' @method vec_ptype2.vctrs_partial_frame data.frame #' @export vec_ptype2.vctrs_partial_frame.data.frame <- function(x, y, ...) { new_partial_frame(x$partial, vec_ptype2(x$learned, y)) } #' @method vec_ptype2.data.frame vctrs_partial_frame #' @export vec_ptype2.data.frame.vctrs_partial_frame <- function(x, y, ...) { new_partial_frame(y$partial, vec_ptype2(y$learned, x)) } #' @export vec_ptype_finalise.vctrs_partial_frame <- function(x, ...) { out <- x$learned out[names(x$partial)] <- x$partial out } vctrs/R/dictionary.R0000644000176200001440000001557513622451540014123 0ustar liggesusers#' Count unique values in a vector #' #' Count the number of unique values in a vector. `vec_count()` has two #' important differences to `table()`: it returns a data frame, and when #' given multiple inputs (as a data frame), it only counts combinations that #' appear in the input. #' #' @param x A vector (including a data frame). #' @param sort One of "count", "key", "location", or "none". #' * "count", the default, puts most frequent values at top #' * "key", orders by the output key column (i.e. unique values of `x`) #' * "location", orders by location where key first seen. This is useful #' if you want to match the counts up to other unique/duplicated functions. #' * "none", leaves unordered. #' @return A data frame with columns `key` (same type as `x`) and #' `count` (an integer vector). #' @export #' @examples #' vec_count(mtcars$vs) #' vec_count(iris$Species) #' #' # If you count a data frame you'll get a data frame #' # column in the output #' str(vec_count(mtcars[c("vs", "am")])) #' #' # Sorting --------------------------------------- #' #' x <- letters[rpois(100, 6)] #' # default is to sort by frequency #' vec_count(x) #' #' # by can sort by key #' vec_count(x, sort = "key") #' #' # or location of first value #' vec_count(x, sort = "location") #' head(x) #' #' # or not at all #' vec_count(x, sort = "none") vec_count <- function(x, sort = c("count", "key", "location", "none")) { sort <- match.arg(sort) # Returns key-value pair giving index of first occurrence value and count kv <- .Call(vctrs_count, vec_proxy(x)) # rep_along() to support zero-length vectors! df <- data_frame(key = rep_along(kv$val, NA), count = kv$val) df$key <- vec_slice(x, kv$key) # might be a dataframe if (sort == "none") { return(df) } idx <- switch(sort, location = order(kv$key), key = vec_order(df$key), count = order(-kv$val) ) df <- vec_slice(df, idx) reset_rownames(df) } reset_rownames <- function(x) { rownames(x) <- NULL is_df <- map_lgl(x, is.data.frame) x[is_df] <- lapply(x[is_df], reset_rownames) x } # Duplicates -------------------------------------------------------------- #' Find duplicated values #' #' * `vec_duplicate_any()`: detects the presence of duplicated values, #' similar to [anyDuplicated()]. #' * `vec_duplicate_detect()`: returns a logical vector describing if each #' element of the vector is duplicated elsewhere. Unlike [duplicated()], it #' reports all duplicated values, not just the second and subsequent #' repetitions. #' * `vec_duplicate_id()`: returns an integer vector giving the location of #' the first occurrence of the value. #' #' @section Missing values: #' In most cases, missing values are not considered to be equal, i.e. #' `NA == NA` is not `TRUE`. This behaviour would be unappealing here, #' so these functions consider all `NAs` to be equal. (Similarly, #' all `NaN` are also considered to be equal.) #' #' @param x A vector (including a data frame). #' @return #' * `vec_duplicate_any()`: a logical vector of length 1. #' * `vec_duplicate_detect()`: a logical vector the same length as `x`. #' * `vec_duplicate_id()`: an integer vector the same length as `x`. #' @seealso [vec_unique()] for functions that work with the dual of duplicated #' values: unique values. #' @name vec_duplicate #' @examples #' vec_duplicate_any(1:10) #' vec_duplicate_any(c(1, 1:10)) #' #' x <- c(10, 10, 20, 30, 30, 40) #' vec_duplicate_detect(x) #' # Note that `duplicated()` doesn't consider the first instance to #' # be a duplicate #' duplicated(x) #' #' # Identify elements of a vector by the location of the first element that #' # they're equal to: #' vec_duplicate_id(x) #' # Location of the unique values: #' vec_unique_loc(x) #' # Equivalent to `duplicated()`: #' vec_duplicate_id(x) == seq_along(x) NULL #' @rdname vec_duplicate #' @export vec_duplicate_any <- function(x) { .Call(vctrs_duplicated_any, x) } #' @rdname vec_duplicate #' @export vec_duplicate_detect <- function(x) { .Call(vctrs_duplicated, x) } #' @rdname vec_duplicate #' @export vec_duplicate_id <- function(x) { .Call(vctrs_id, x) } # Unique values ----------------------------------------------------------- #' Find and count unique values #' #' * `vec_unique()`: the unique values. Equivalent to [unique()]. #' * `vec_unique_loc()`: the locations of the unique values. #' * `vec_unique_count()`: the number of unique values. #' #' @inherit vec_duplicate sections #' @param x A vector (including a data frame). #' @return #' * `vec_unique()`: a vector the same type as `x` containing only unique #' values. #' * `vec_unique_loc()`: an integer vector, giving locations of unique values. #' * `vec_unique_count()`: an integer vector of length 1, giving the #' number of unique values. #' @seealso [vec_duplicate] for functions that work with the dual of #' unique values: duplicated values. #' @export #' @examples #' x <- rpois(100, 8) #' vec_unique(x) #' vec_unique_loc(x) #' vec_unique_count(x) #' #' # `vec_unique()` returns values in the order that encounters them #' # use sort = "location" to match to the result of `vec_count()` #' head(vec_unique(x)) #' head(vec_count(x, sort = "location")) #' #' # Normally missing values are not considered to be equal #' NA == NA #' #' # But they are for the purposes of considering uniqueness #' vec_unique(c(NA, NA, NA, NA, 1, 2, 1)) vec_unique <- function(x) { vec_slice(x, vec_unique_loc(x)) } #' @rdname vec_unique #' @export vec_unique_loc <- function(x) { .Call(vctrs_unique_loc, x) } #' @rdname vec_unique #' @export vec_unique_count <- function(x) { .Call(vctrs_n_distinct, x) } # Matching ---------------------------------------------------------------- #' Find matching observations across vectors #' #' `vec_in()` returns a logical vector based on whether `needle` is found in #' haystack. `vec_match()` returns an integer vector giving location of #' `needle` in `haystack`, or `NA` if it's not found. #' #' `vec_in()` is equivalent to [%in%]; `vec_match()` is equivalent to `match()`. #' #' @inherit vec_duplicate sections #' @param needles,haystack Vector of `needles` to search for in vector haystack. #' `haystack` should usually be unique; if not `vec_match()` will only #' return the location of the first match. #' #' `needles` and `haystack` are coerced to the same type prior to #' comparison. #' @return A vector the same length as `needles`. `vec_in()` returns a #' logical vector; `vec_match()` returns an integer vector. #' @export #' @examples #' hadley <- strsplit("hadley", "")[[1]] #' vec_match(hadley, letters) #' #' vowels <- c("a", "e", "i", "o", "u") #' vec_match(hadley, vowels) #' vec_in(hadley, vowels) #' #' # Only the first index of duplicates is returned #' vec_match(c("a", "b"), c("a", "b", "a", "b")) vec_match <- function(needles, haystack) { .Call(vctrs_match, needles, haystack) } #' @export #' @rdname vec_match vec_in <- function(needles, haystack) { .Call(vctrs_in, needles, haystack) } vctrs/R/equal.R0000644000176200001440000000456513622451540013062 0ustar liggesusers#' Equality proxy #' #' Returns a proxy object (i.e. an atomic vector or data frame of atomic #' vectors). For [vctr]s, this determines the behaviour of `==` and #' `!=` (via [vec_equal()]); [unique()], [duplicated()] (via #' [vec_unique()] and [vec_duplicate_detect()]); [is.na()] and [anyNA()] #' (via [vec_equal_na()]). #' #' The default method calls [vec_proxy()], as the default underlying #' vector data should be equal-able in most cases. If your class is #' not equal-able, provide a `vec_proxy_equal()` method that throws an #' error. #' #' If the proxy for `x` is a data frame, `vec_proxy_equal()` is #' recursively applied on all columns as well. #' #' @param x A vector x. #' @inheritParams ellipsis::dots_empty #' #' @return A 1d atomic vector or a data frame. #' @keywords internal #' #' @export vec_proxy_equal <- function(x, ...) { if (!missing(...)) { ellipsis::check_dots_empty() } return(.Call(vctrs_proxy_equal, x)) UseMethod("vec_proxy_equal") } vec_proxy_equal_dispatch <- function(x, ...) { UseMethod("vec_proxy_equal") } #' @export vec_proxy_equal.default <- function(x, ...) { vec_proxy(x) } #' Test if two vectors are equal #' #' `vec_equal_na()` tests a special case: equality with `NA`. It is similar to #' [is.na] but: #' * Considers the missing element of a list to be `NULL`. #' * Considered data frames and records to be missing if every component #' is missing. #' This preserves the invariant that `vec_equal_na(x)` is equal to #' `vec_equal(x, vec_init(x), na_equal = TRUE)`. #' #' @inheritParams vec_compare #' @return A logical vector the same size as. Will only contain `NA`s if `na_equal` is `FALSE`. #' @export #' @examples #' vec_equal(c(TRUE, FALSE, NA), FALSE) #' vec_equal(c(TRUE, FALSE, NA), FALSE, na_equal = TRUE) #' vec_equal_na(c(TRUE, FALSE, NA)) #' #' vec_equal(5, 1:10) #' vec_equal("d", letters[1:10]) #' #' df <- data.frame(x = c(1, 1, 2, 1, NA), y = c(1, 2, 1, NA, NA)) #' vec_equal(df, data.frame(x = 1, y = 2)) #' vec_equal_na(df) vec_equal <- function(x, y, na_equal = FALSE, .ptype = NULL) { vec_assert(na_equal, ptype = logical(), size = 1L) args <- vec_recycle_common(x, y) args <- vec_cast_common(!!!args, .to = .ptype) .Call(vctrs_equal, args[[1]], args[[2]], na_equal) } #' @export #' @rdname vec_equal vec_equal_na <- function(x) { .Call(vctrs_equal_na, x) } obj_equal <- function(x, y) { .Call(vctrs_equal_object, x, y) } vctrs/R/dim.R0000644000176200001440000000302613622451540012513 0ustar liggesusers#' Actual vector dimensions #' #' @description #' * `vec_dim_n()` gives the dimensionality (i.e. number of dimensions) #' * `vec_dim()` returns the size of each dimension #' #' These functions access the raw `"dim"` attribute of the object #' and do not dispatch over the [dim()] generic. #' #' @details #' Unlike base R, we treat vectors with `NULL` dimensions as 1d. This #' simplifies the type system by eliding a special case. Compared to the base R #' equivalent, `vec_dim()` returns [length()], not `NULL`, when `x` is 1d. #' #' @seealso #' [dim2()], a variant of [dim()] that returns [length()] if an object #' doesn't have dimensions. #' #' @param x A vector #' @noRd #' @examples #' # Compared to base R #' x <- 1:5 #' dim(x) #' vec_dim(x) NULL # FIXME: Should `vec_dim()` return the size instead of the length? vec_dim <- function(x) { .Call(vctrs_dim, x) } vec_dim_n <- function(x) { .Call(vctrs_dim_n, x) } #' Perceived vector dimensions #' #' @description #' `dim2()` is a variant of [dim()] that returns [vec_size()] if an object #' doesn't have dimensions. #' #' @details #' Unlike base R, we treat vectors with `NULL` dimensions as 1d. This #' simplifies the type system by eliding a special case. Compared to the base R #' equivalent, `dim2()` returns [length()], not `NULL`, when `x` is 1d. #' #' @seealso #' [vec_dim()], a variant that never dispatches over the [dim()] generic. #' #' @param x A vector #' @noRd #' @examples #' # Compared to base R #' x <- 1:5 #' dim(x) #' vec_dim(x) dim2 <- function(x) { dim(x) %||% length(x) } vctrs/R/vctrs-package.R0000644000176200001440000000075513622451540014502 0ustar liggesusers#' @description #' \if{html}{\figure{logo.png}{options: align='right'}} #' \Sexpr[results=rd, stage=render]{vctrs:::lifecycle("maturing")} #' #' Defines new notions of prototype and size that are #' used to provide tools for consistent and well-founded type-coercion #' and size-recycling, and are in turn connected to ideas of type- and #' size-stability useful for analysing function interfaces. #' #' @keywords internal #' @import rlang #' @useDynLib vctrs, .registration = TRUE "_PACKAGE" vctrs/R/type-explore.R0000644000176200001440000000130613622451540014376 0ustar liggesuserscoerces_to <- function(x, y, using = "strict") { type_max <- switch(using, strict = vec_ptype2, base_c = c, base_unlist = function(x, y) unlist(list(x, y)), base_modify = function(x, y) `[<-`(x, 2, value = y) ) tryCatch({ type <- suppressWarnings(type_max(x, y)) vec_ptype_full(type) }, error = function(e) { NA_character_ }) } maxtype_mat <- function(types, using = "strict") { names(types) <- map_chr(types, function(x) vec_ptype_full(vec_ptype(x))) grid <- expand.grid(x = types, y = types) grid$max <- map2_chr(grid$x, grid$y, coerces_to, using = using) matrix( grid$max, nrow = length(types), dimnames = list(names(types), names(types)) ) } vctrs/R/print-str.R0000644000176200001440000000654713622451540013717 0ustar liggesusers# print ------------------------------------------------------------------- #' `print()` and `str()` generics. #' #' These are constructed to be more easily extensible since you can override #' the `_header()`, `_data()` or `_footer()` components individually. The #' default methods are built on top of `format()`. #' #' @param x A vector #' @param ... Additional arguments passed on to methods. See [print()] and #' [str()] for commonly used options #' @keywords internal #' @export obj_print <- function(x, ...) { obj_print_header(x, ...) obj_print_data(x, ...) obj_print_footer(x, ...) invisible(x) } #' @export #' @rdname obj_print obj_print_header <- function(x, ...) { UseMethod("obj_print_header") } #' @export obj_print_header.default <- function(x, ...) { cat_line("<", vec_ptype_full(x), "[", vec_size(x), "]>") invisible(x) } #' @export #' @rdname obj_print obj_print_data <- function(x, ...) { UseMethod("obj_print_data") } #' @export obj_print_data.default <- function(x, ...) { if (length(x) == 0) return() out <- stats::setNames(format(x), names(x)) print(out, quote = FALSE) invisible(x) } #' @export #' @rdname obj_print obj_print_footer <- function(x, ...) { UseMethod("obj_print_footer") } #' @export obj_print_footer.default <- function(x, ...) { invisible(x) } # str --------------------------------------------------------------------- #' @export #' @rdname obj_print obj_str <- function(x, ...) { obj_str_header(x, ...) obj_str_data(x, ...) obj_str_footer(x, ...) } #' @export #' @rdname obj_print obj_str_header <- function(x, ...) { UseMethod("obj_str_header") } #' @export obj_str_header.default <- function(x, ...) { invisible(x) } #' @export #' @rdname obj_print obj_str_data <- function(x, ...) { UseMethod("obj_str_data") } #' @export obj_str_data.default <- function(x, ...) { if (is.list(x)) { obj_str_recursive(x, ...) } else { obj_str_leaf(x, ...) } } obj_str_recursive <- function(x, ..., indent.str = "", nest.lev = 0) { if (nest.lev != 0L) cat(" ") cat_line(glue::glue("{vec_ptype_abbr(x)} [1:{vec_size(x)}] ")) utils::str( vec_data(x), no.list = TRUE, ..., nest.lev = nest.lev + 1L, indent.str = indent.str ) } obj_str_leaf <- function(x, ..., indent.str = "", width = getOption("width")) { width <- width - nchar(indent.str) - 2 # Avoid spending too much time formatting elements that won't see length <- ceiling(width / 2) if (length(x) > length) { out <- x[seq2(1, length)] } else { out <- x } title <- glue::glue(" {vec_ptype_abbr(x)} [1:{length(x)}] ") cat_line(inline_list(title, format(out), width = width)) invisible(x) } #' @export #' @rdname obj_print obj_str_footer <- function(x, ...) { UseMethod("obj_str_footer") } #' @export obj_str_footer.default <- function(x, ..., indent.str = "", nest.lev = 0) { attr <- attributes(x) attr[["class"]] <- NULL attr[["names"]] <- NULL if (length(attr) == 0) return(invisible(x)) if (!is.list(x)) { indent.str <- paste0(" ", indent.str) } utils::str( attr, no.list = TRUE, ..., comp.str = "@ ", nest.lev = nest.lev + 1L, indent.str = indent.str ) invisible(x) } vctrs/R/type-factor.R0000644000176200001440000001274313622451540014205 0ustar liggesusers#' Factor/ordered factor S3 class #' #' A [factor] is an integer with attribute `levels`, a character vector. There #' should be one level for each integer between 1 and `max(x)`. #' An [ordered] factor has the same properties as a factor, but possesses #' an extra class that marks levels as having a total ordering. #' #' These functions help the base factor and ordered factor classes fit in to #' the vctrs type system by providing constructors, coercion functions, #' and casting functions. `new_factor()` and `new_ordered()` are low-level #' constructors - they only check that types, but not values, are valid, so #' are for expert use only. #' #' @param x Integer values which index in to `levels`. #' @param levels Character vector of labels. #' @param ...,class Used to for subclasses. #' @keywords internal #' @export new_factor <- function(x = integer(), levels = character(), ..., class = character()) { stopifnot(is.integer(x)) stopifnot(is.character(levels)) structure( x, levels = levels, ..., class = c(class, "factor") ) } #' @export #' @rdname new_factor new_ordered <- function(x = integer(), levels = character()) { new_factor(x = x, levels = levels, class = "ordered") } # Print ------------------------------------------------------------------- #' @export vec_ptype_full.factor <- function(x, ...) { paste0("factor<", hash_label(levels(x)), ">") } #' @export vec_ptype_abbr.factor <- function(x, ...) { "fct" } #' @export vec_ptype_full.ordered <- function(x, ...) { paste0("ordered<", hash_label(levels(x)), ">") } #' @export vec_ptype_abbr.ordered <- function(x, ...) { "ord" } # Coerce ------------------------------------------------------------------ #' @rdname new_factor #' @export vec_ptype2.factor #' @method vec_ptype2 factor #' @export vec_ptype2.factor <- function(x, y, ...) UseMethod("vec_ptype2.factor", y) #' @method vec_ptype2.factor default #' @export vec_ptype2.factor.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } #' @method vec_ptype2.character factor #' @export vec_ptype2.character.factor <- function(x, y, ...) character() #' @method vec_ptype2.factor character #' @export vec_ptype2.factor.character <- function(x, y, ...) character() #' @method vec_ptype2.factor factor #' @export vec_ptype2.factor.factor <- function(x, y, ...) new_factor(levels = levels_union(x, y)) #' @rdname new_factor #' @export vec_ptype2.ordered #' @method vec_ptype2 ordered #' @export vec_ptype2.ordered <- function(x, y, ...) UseMethod("vec_ptype2.ordered", y) #' @method vec_ptype2.ordered default #' @export vec_ptype2.ordered.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } #' @method vec_ptype2.ordered character #' @export vec_ptype2.ordered.character <- function(x, y, ...) character() #' @method vec_ptype2.character ordered #' @export vec_ptype2.character.ordered <- function(x, y, ...) character() #' @method vec_ptype2.ordered factor #' @export vec_ptype2.ordered.factor <- function(x, y, ..., x_arg = "x", y_arg = "y") { stop_incompatible_type(x, y, x_arg = x_arg, y_arg = y_arg) } #' @method vec_ptype2.factor ordered #' @export vec_ptype2.factor.ordered <- function(x, y, ..., x_arg = "x", y_arg = "y") { stop_incompatible_type(x, y, x_arg = x_arg, y_arg = y_arg) } #' @method vec_ptype2.ordered ordered #' @export vec_ptype2.ordered.ordered <- function(x, y, ...) new_ordered(levels = levels_union(x, y)) # Cast -------------------------------------------------------------------- #' @rdname new_factor #' @export vec_cast.factor #' @method vec_cast factor #' @export vec_cast.factor <- function(x, to, ...) { UseMethod("vec_cast.factor") } #' @export #' @method vec_cast.factor factor vec_cast.factor.factor <- function(x, to, ..., x_arg = "", to_arg = "") { if (length(levels(to)) == 0L) { levels <- levels(x) if (is.null(levels)) { exclude <- NA levels <- unique(x) } else { exclude <- NULL } factor(as.character(x), levels = levels, ordered = is.ordered(to), exclude = exclude) } else { lossy <- !(x %in% levels(to) | is.na(x)) out <- factor(x, levels = levels(to), ordered = is.ordered(to), exclude = NULL) maybe_lossy_cast(out, x, to, lossy, x_arg = x_arg, to_arg = to_arg) } } #' @export #' @method vec_cast.factor character vec_cast.factor.character <- vec_cast.factor.factor #' @export #' @method vec_cast.character factor vec_cast.character.factor <- function(x, to, ...) as.character(x) #' @export #' @method vec_cast.factor list vec_cast.factor.list <- function(x, to, ..., x_arg = "", to_arg = "") { vec_list_cast(x, to, x_arg = x_arg, to_arg = to_arg) } #' @export #' @method vec_cast.factor default vec_cast.factor.default <- function(x, to, ..., x_arg = "", to_arg = "") { vec_default_cast(x, to, x_arg = x_arg, to_arg = to_arg) } # Math and arithmetic ----------------------------------------------------- #' @export vec_math.factor <- function(.fn, .x, ...) { stop_unsupported(.x, .fn) } #' @export vec_arith.factor <- function(op, x, y, ...) { stop_unsupported(x, op) } # Helpers ----------------------------------------------------------------- hash_label <- function(x, length = 5) { if (length(x) == 0) { "" } else { # Can't use hash() currently because it hashes the string pointers # for performance, so the values in the test change each time substr(digest::digest(x), 1, length) } } levels_union <- function(x, y) { union(levels(x), levels(y)) } vctrs/R/faq-internal.R0000644000176200001440000000026313622451540014323 0ustar liggesusers#' Internal FAQ - `vec_ptype2()`, `NULL`, and unspecified vectors #' #' @includeRmd man/faq/internal/ptype2-identity.Rmd description #' #' @name internal-faq-ptype2-identity NULL vctrs/R/bind.R0000644000176200001440000001312213622451540012654 0ustar liggesusers#' Combine many data frames into one data frame #' #' This pair of functions binds together data frames (and vectors), either #' row-wise or column-wise. Row-binding creates a data frame with common type #' across all arguments. Column-binding creates a data frame with common length #' across all arguments. #' #' @section Invariants: #' #' All inputs are first converted to a data frame. The conversion for #' 1d vectors depends on the direction of binding: #' #' * For `vec_rbind()`, each element of the vector becomes a column in #' a single row. #' * For `vec_cbind()`, each element of the vector becomes a row in a #' single column. #' #' Once the inputs have all become data frames, the following #' invariants are observed for row-binding: #' #' * `vec_size(vec_rbind(x, y)) == vec_size(x) + vec_size(y)` #' * `vec_ptype(vec_rbind(x, y)) = vec_ptype_common(x, y)` #' #' Note that if an input is an empty vector, it is first converted to #' a 1-row data frame with 0 columns. Despite being empty, its #' effective size for the total number of rows is 1. #' #' For column-binding, the following invariants apply: #' #' * `vec_size(vec_cbind(x, y)) == vec_size_common(x, y)` #' * `vec_ptype(vec_cbind(x, y)) == vec_cbind(vec_ptype(x), vec_ptype(x))` #' @param ... Data frames or vectors. #' #' When the inputs are named: #' * `vec_rbind()` assigns names to row names unless `.names_to` is #' supplied. In that case the names are assigned in the column #' defined by `.names_to`. #' * `vec_cbind()` creates packed data frame columns with named #' inputs. #' #' `NULL` inputs are silently ignored. Empty (e.g. zero row) inputs #' will not appear in the output, but will affect the derived `.ptype`. #' @param .names_to Optionally, the name of a column where the names #' of `...` arguments are copied. These names are useful to identify #' which row comes from which input. If supplied and `...` is not named, #' an integer column is used to identify the rows. #' @param .name_repair One of `"unique"`, `"universal"`, or #' `"check_unique"`. See [vec_as_names()] for the meaning of these #' options. #' #' With `vec_rbind()`, the repair function is applied to all inputs #' separately. This is because `vec_rbind()` needs to align their #' columns before binding the rows, and thus needs all inputs to #' have unique names. On the other hand, `vec_cbind()` applies the #' repair function after all inputs have been concatenated together #' in a final data frame. Hence `vec_cbind()` allows the more #' permissive minimal names repair. #' @inheritParams vec_c #' @return A data frame, or subclass of data frame. #' #' If `...` is a mix of different data frame subclasses, `vec_ptype2()` #' will be used to determine the output type. For `vec_rbind()`, this #' will determine the type of the container and the type of each column; #' for `vec_cbind()` it only determines the type of the output container. #' If there are no non-`NULL` inputs, the result will be `data.frame()`. #' @seealso [vec_c()] for combining 1d vectors. #' @examples #' # row binding ----------------------------------------- #' #' # common columns are coerced to common class #' vec_rbind( #' data.frame(x = 1), #' data.frame(x = FALSE) #' ) #' #' # unique columns are filled with NAs #' vec_rbind( #' data.frame(x = 1), #' data.frame(y = "x") #' ) #' #' # null inputs are ignored #' vec_rbind( #' data.frame(x = 1), #' NULL, #' data.frame(x = 2) #' ) #' #' # bare vectors are treated as rows #' vec_rbind( #' c(x = 1, y = 2), #' c(x = 3) #' ) #' #' # default names will be supplied if arguments are not named #' vec_rbind( #' 1:2, #' 1:3, #' 1:4 #' ) #' #' # column binding -------------------------------------- #' #' # each input is recycled to have common length #' vec_cbind( #' data.frame(x = 1), #' data.frame(y = 1:3) #' ) #' #' # bare vectors are treated as columns #' vec_cbind( #' data.frame(x = 1), #' y = letters[1:3] #' ) #' #' # if you supply a named data frame, it is packed in a single column #' data <- vec_cbind( #' x = data.frame(a = 1, b = 2), #' y = 1 #' ) #' data #' #' # Packed data frames are nested in a single column. This makes it #' # possible to access it through a single name: #' data$x #' #' # since the base print method is suboptimal with packed data #' # frames, it is recommended to use tibble to work with these: #' if (rlang::is_installed("tibble")) { #' vec_cbind(x = tibble::tibble(a = 1, b = 2), y = 1) #' } #' #' # duplicate names are flagged #' vec_cbind(x = 1, x = 2) #' #' @name vec_bind NULL #' @export #' @rdname vec_bind vec_rbind <- function(..., .ptype = NULL, .names_to = NULL, .name_repair = c("unique", "universal", "check_unique")) { .External2(vctrs_rbind, .ptype, .names_to, .name_repair) } vec_rbind <- fn_inline_formals(vec_rbind, ".name_repair") #' @export #' @rdname vec_bind #' @param .size If, `NULL`, the default, will determine the number of #' rows in `vec_cbind()` output by using the standard recycling rules. #' #' Alternatively, specify the desired number of rows, and any inputs #' of length 1 will be recycled appropriately. vec_cbind <- function(..., .ptype = NULL, .size = NULL, .name_repair = c("unique", "universal", "check_unique", "minimal")) { .External2(vctrs_cbind, .ptype, .size, .name_repair) } vec_cbind <- fn_inline_formals(vec_cbind, ".name_repair") as_df_row <- function(x, quiet = FALSE) { .Call(vctrs_as_df_row, x, quiet) } as_df_col <- function(x, outer_name) { .Call(vctrs_as_df_col, x, outer_name) } vctrs/R/type.R0000644000176200001440000001152513622451540012726 0ustar liggesusers#' Find the prototype of a set of vectors #' #' `vec_ptype()` returns the unfinalised prototype of a single vector. #' `vec_ptype_common()` finds the common type of multiple vectors. #' `vec_ptype_show()` nicely prints the common type of any number of #' inputs, and is designed for interactive exploration. #' #' @param ...,x Vectors inputs #' @param .ptype If `NULL`, the default, the output type is determined by #' computing the common type across all elements of `...`. #' #' Alternatively, you can supply `.ptype` to give the output known type. #' If `getOption("vctrs.no_guessing")` is `TRUE` you must supply this value: #' this is a convenient way to make production code demand fixed types. #' @return `vec_ptype()` and `vec_ptype_common()` return a prototype #' (a size-0 vector) #' #' @section `vec_ptype()`: #' `vec_ptype()` returns [size][vec_size] 0 vectors potentially #' containing attributes but no data. Generally, this is just #' `vec_slice(x, 0L)`, but some inputs require special #' handling. #' #' * While you can't slice `NULL`, the prototype of `NULL` is #' itself. This is because we treat `NULL` as an identity value in #' the `vec_ptype2()` monoid. #' #' * The prototype of logical vectors that only contain missing values #' is the special [unspecified] type, which can be coerced to any #' other 1d type. This allows bare `NA`s to represent missing values #' for any 1d vector type. #' #' See [internal-faq-ptype2-identity] for more information about #' identity values. #' #' Because it may contain unspecified vectors, the prototype returned #' by `vec_ptype()` is said to be __unfinalised__. Call #' [vec_ptype_finalise()] to finalise it. Commonly you will need the #' finalised prototype as returned by `vec_slice(x, 0L)`. #' #' @section `vec_ptype_common()`: #' `vec_ptype_common()` first finds the prototype of each input, then #' successively calls [vec_ptype2()] to find a common type. It returns #' a [finalised][vec_ptype_finalise] prototype. #' #' @export #' @examples #' # Unknown types ------------------------------------------ #' vec_ptype_show() #' vec_ptype_show(NA) #' vec_ptype_show(NULL) #' #' # Vectors ------------------------------------------------ #' vec_ptype_show(1:10) #' vec_ptype_show(letters) #' vec_ptype_show(TRUE) #' #' vec_ptype_show(Sys.Date()) #' vec_ptype_show(Sys.time()) #' vec_ptype_show(factor("a")) #' vec_ptype_show(ordered("a")) #' #' # Matrices ----------------------------------------------- #' # The prototype of a matrix includes the number of columns #' vec_ptype_show(array(1, dim = c(1, 2))) #' vec_ptype_show(array("x", dim = c(1, 2))) #' #' # Data frames -------------------------------------------- #' # The prototype of a data frame includes the prototype of #' # every column #' vec_ptype_show(iris) #' #' # The prototype of multiple data frames includes the prototype #' # of every column that in any data frame #' vec_ptype_show( #' data.frame(x = TRUE), #' data.frame(y = 2), #' data.frame(z = "a") #' ) vec_ptype <- function(x) { .Call(vctrs_type, x) } #' @export #' @rdname vec_ptype vec_ptype_common <- function(..., .ptype = NULL) { .External2(vctrs_type_common, .ptype) } #' @export #' @rdname vec_ptype vec_ptype_show <- function(...) { args <- compact(list2(...)) n <- length(args) if (n == 0) { cat_line("Prototype: NULL") } else if (n == 1) { cat_line("Prototype: ", vec_ptype_full(args[[1]])) } else { in_types <- map(args, vec_ptype) out_types <- vector("list", length(in_types)) out_types[[1]] <- in_types[[1]] for (i in seq2(2, n)) { out_types[[i]] <- vec_ptype2(out_types[[i - 1]], in_types[[i]]) } in_full <- paste0("<", map_chr(in_types, vec_ptype_full), ">") out_full <- paste0("<", map_chr(out_types, vec_ptype_full), ">") out <- cbind( n = paste0(seq(0, n - 1), ". "), lhs = c("", out_full[-n]), comma = " , ", rhs = in_full, equals = " = ", res = c(in_full[[1]], out_full[-1]) ) out <- t(apply(out, 1, pad_height)) out <- apply(out, 2, pad_width) out[, "lhs"] <- parens(out[, "lhs"]) out[, "rhs"] <- parens(out[, "rhs"], FALSE) lines <- strsplit(out, "\n") dim(lines) <- dim(out) steps <- apply(lines, 1, function(x) do.call(cbind, x)) if (is.list(steps)) { step_lines <- unlist(lapply(steps, function(x) apply(x, 1, paste0, collapse = ""))) } else { step_lines <- apply(steps, 2, paste0, collapse = "") } cat_line("Prototype: ", out_full[[n]]) cat_line(step_lines) } invisible() } has_same_type <- function(x, y) { typeof(x) == typeof(y) && identical(attributes(x), attributes(y)) } vec_typeof <- function(x) { .Call(vctrs_typeof, x, TRUE) } vec_typeof_bare <- function(x) { .Call(vctrs_typeof, x, FALSE) } vec_type_info <- function(x) { .Call(vctrs_type_info, x) } vec_proxy_info <- function(x) { .Call(vctrs_proxy_info, x) } vctrs/R/conditions.R0000644000176200001440000003315213622451540014116 0ustar liggesusers#' Custom conditions for vctrs package #' #' These functions are called for their side effect of raising #' errors and warnings. #' These conditions have custom classes and structures to make #' testing easier. #' #' @param x,y Vectors #' @param details Any additional human readable details #' @param subclass Use if you want to further customise the class #' @param ...,message,class Only use these fields when creating a subclass. #' #' @section Lossy cast errors: #' #' By default, lossy casts are an error. Use `allow_lossy_cast()` to #' silence these errors and continue with the partial results. In this #' case the lost values are typically set to `NA` or to a lower value #' resolution, depending on the type of cast. #' #' Lossy cast errors are thrown by `maybe_lossy_cast()`. Unlike #' functions prefixed with `stop_`, `maybe_lossy_cast()` usually #' returns a result. If a lossy cast is detected, it throws an error, #' unless it's been wrapped in `allow_lossy_cast()`. In that case, it #' returns the result silently. #' #' @examples #' #' # Most of the time, `maybe_lossy_cast()` returns its input normally: #' maybe_lossy_cast(c("foo", "bar"), NULL, "", lossy = c(FALSE, FALSE)) #' #' # If `lossy` has any `TRUE`, an error is thrown: #' try(maybe_lossy_cast(c("foo", "bar"), NULL, "", lossy = c(FALSE, TRUE))) #' #' # Unless lossy casts are allowed: #' allow_lossy_cast( #' maybe_lossy_cast(c("foo", "bar"), NULL, "", lossy = c(FALSE, TRUE)) #' ) #' #' @keywords internal #' @name vctrs-conditions NULL stop_vctrs <- function(message = NULL, class = NULL, ...) { abort(message, class = c(class, "vctrs_error"), ...) } stop_incompatible <- function(x, y, details = NULL, ..., message = NULL, class = NULL) { stop_vctrs( message, class = c(class, "vctrs_error_incompatible"), x = x, y = y, details = details, ... ) } #' @return #' `stop_incompatible_*()` unconditionally raise an error of class #' `"vctrs_error_incompatible_*"` and `"vctrs_error_incompatible"`. #' #' @rdname vctrs-conditions #' @export stop_incompatible_type <- function(x, y, x_arg = "", y_arg = "", details = NULL, ..., message = NULL, class = NULL) { vec_assert(x) vec_assert(y) if (is_null(message)) { if (nzchar(x_arg)) { x_name <- paste0(" `", x_arg, "` ") } else { x_name <- " " } if (nzchar(y_arg)) { y_name <- paste0(" `", y_arg, "` ") } else { y_name <- " " } message <- glue_lines( "No common type for{x_name}<{vec_ptype_full(x)}> and{y_name}<{vec_ptype_full(y)}>.", details ) } stop_incompatible( x, y, x_arg = x_arg, y_arg = y_arg, details = details, ..., message = message, class = c(class, "vctrs_error_incompatible_type") ) } #' @rdname vctrs-conditions #' @export stop_incompatible_cast <- function(x, y, details = NULL, ..., x_arg = "", to_arg = "", message = NULL, class = NULL) { if (is_null(message)) { x_label <- format_arg_label(vec_ptype_full(x), x_arg) to_label <- format_arg_label(vec_ptype_full(y), to_arg) message <- glue_lines( "Can't cast {x_label} to {to_label}.", details ) } stop_incompatible( x, y, details = details, ..., x_arg = x_arg, y_arg = to_arg, message = message, class = c(class, "vctrs_error_incompatible_cast") ) } #' @rdname vctrs-conditions #' @export stop_incompatible_op <- function(op, x, y, details = NULL, ..., message = NULL, class = NULL) { message <- message %||% glue_lines( "<{vec_ptype_full(x)}> {op} <{vec_ptype_full(y)}> is not permitted", details ) stop_incompatible( x, y, op = op, details = details, ..., message = message, class = c(class, "vctrs_error_incompatible_op") ) } #' @rdname vctrs-conditions #' @export stop_incompatible_size <- function(x, y, x_size, y_size, x_arg = "", y_arg = "", details = NULL, ..., message = NULL, class = NULL) { vec_assert(x) vec_assert(y) vec_assert(x_size, int(), 1) vec_assert(y_size, int(), 1) if (is_null(message)) { if (nzchar(x_arg)) { x_name <- paste0("`", x_arg, "`, size") } else { x_name <- "vector, size" } if (nzchar(y_arg)) { y_name <- paste0("`", y_arg, "`, size") } else { y_name <- "vector, size" } message <- glue_lines( "No common size for {x_name} {x_size}, and {y_name} {y_size}.", details ) } stop_incompatible( x, y, x_size = x_size, y_size = y_size, x_arg = x_arg, y_arg = y_arg, details = details, ..., message = message, class = c(class, "vctrs_error_incompatible_size") ) } #' @rdname vctrs-conditions #' @param result The result of a potentially lossy cast. #' @param to Type to cast to. #' @param lossy A logical vector indicating which elements of `result` #' were lossy. #' #' Can also be a single `TRUE`, but note that `locations` picks up #' locations from this vector by default. In this case, supply your #' own location vector, possibly empty. #' @param locations An optional integer vector giving the #' locations where `x` lost information. #' @param .deprecation If `TRUE`, the error is downgraded to a #' deprecation warning. This is useful for transitioning your class #' to a stricter conversion scheme. The warning advises your users #' to wrap their code with `allow_lossy_cast()`. #' @export maybe_lossy_cast <- function(result, x, to, lossy = NULL, locations = NULL, details = NULL, ..., x_arg = "", to_arg = "", message = NULL, class = NULL, .deprecation = FALSE) { if (!any(lossy)) { return(result) } if (.deprecation) { maybe_warn_deprecated_lossy_cast(x, to, x_arg, to_arg) return(result) } locations <- locations %||% which(lossy) withRestarts( vctrs_restart_error_cast_lossy = function() result, stop_lossy_cast( x = x, to = to, result = result, locations = locations, details = details, ..., x_arg = x_arg, to_arg = to_arg, message = message, class = class ) ) } stop_lossy_cast <- function(x, to, result, locations = NULL, details = NULL, ..., x_arg = "", to_arg = "", message = NULL, class = NULL) { stop_vctrs( message, x = x, y = to, to = to, result = result, x_arg = x_arg, to_arg = to_arg, locations = locations, details = details, ..., class = c(class, "vctrs_error_cast_lossy") ) } #' @export conditionMessage.vctrs_error_cast_lossy <- function(c) { # FIXME: Remove `message` argument if (is_string(c$message) && nzchar(c$message)) { return(c$message) } # FIXME: Add `cnd_details()`? glue_lines( cnd_message(c), c$details ) } #' @export cnd_header.vctrs_error_cast_lossy <- function(cnd, ...) { x_label <- format_arg_label(vec_ptype_full(cnd$x), cnd$x_arg) to_label <- format_arg_label(vec_ptype_full(cnd$to), cnd$to_arg) glue::glue("Lossy cast from {x_label} to {to_label}.") } #' @export cnd_body.vctrs_error_cast_lossy <- function(cnd, ...) { if (length(cnd$locations)) { format_error_bullets(inline_list("Locations: ", cnd$locations)) } else { character() } } # Used in maybe_warn_deprecated_lossy_cast() new_error_cast_lossy <- function(x, to, x_arg = "", to_arg = "") { error_cnd( "vctrs_error_cast_lossy", x = x, to = to, x_arg = x_arg, to_arg = to_arg ) } #' @rdname vctrs-conditions #' @param x_ptype,to_ptype Suppress only the casting errors where `x` #' or `to` match these [prototypes][vec_ptype]. #' @export allow_lossy_cast <- function(expr, x_ptype = NULL, to_ptype = NULL) { withCallingHandlers( vctrs_error_cast_lossy = function(err) { if (!is_null(x_ptype) && !vec_is(err$x, x_ptype)) { return() } if (!is_null(to_ptype) && !vec_is(err$to, to_ptype)) { return() } invokeRestart("vctrs_restart_error_cast_lossy") }, expr ) } maybe_warn_deprecated_lossy_cast <- function(x, to, x_arg, to_arg) { # Returns `TRUE` if `allow_lossy_cast()` is on the stack and accepts # to handle the condition handled <- withRestarts( vctrs_restart_error_cast_lossy = function() TRUE, { # Signal fully formed condition but strip the error classes in # case someone is catching: This is not an abortive condition. cnd <- new_error_cast_lossy(x, to, x_arg = x_arg, to_arg = to_arg) class(cnd) <- setdiff(class(cnd), c("error", "rlang_error")) signalCondition(cnd) FALSE } ) if (handled) { return(invisible()) } from <- format_arg_label(vec_ptype_abbr(x), x_arg) to <- format_arg_label(vec_ptype_abbr(to), to_arg) warn_deprecated(paste_line( glue::glue("We detected a lossy transformation from `{ from }` to `{ to }`."), "The result will contain lower-resolution values or missing values.", "To suppress this warning, wrap your code with `allow_lossy_cast()`:", "", " # Allow all lossy transformations:", " vctrs::allow_lossy_cast(mycode())", "", " # Allow only a specific transformation:", " vctrs::allow_lossy_cast(mycode(), x_ptype = from, to_ptype = to)", "", "Consult `?vctrs::allow_lossy_cast` for more information." )) invisible() } stop_unsupported <- function(x, method) { msg <- glue::glue("`{method}.{class(x)[[1]]}()` not supported.") stop_vctrs( "vctrs_error_unsupported", message = msg, x = x, method = method ) } stop_unimplemented <- function(x, method) { msg <- glue::glue("`{method}.{class(x)[[1]]}()` not implemented.") stop_vctrs( "vctrs_error_unimplemented", message = msg, x = x, method = method ) } stop_scalar_type <- function(x, arg = NULL) { if (is_null(arg) || !nzchar(arg)) { msg <- glue::glue("Expected a vector, not { friendly_type_of(x) }") } else { msg <- glue::glue("`{ arg }` must be a vector, not { friendly_type_of(x) }") } stop_vctrs(msg, "vctrs_error_scalar_type", actual = x) } stop_corrupt_factor_levels <- function(x, arg = "x") { msg <- glue::glue("`{arg}` is a corrupt factor with non-character levels") abort(msg) } stop_corrupt_ordered_levels <- function(x, arg = "x") { msg <- glue::glue("`{arg}` is a corrupt ordered factor with non-character levels") abort(msg) } stop_recycle_incompatible_size <- function(x_size, size, x_arg = "x") { stop_vctrs( x_size = x_size, size = size, x_arg = x_arg, class = "vctrs_error_recycle_incompatible_size" ) } #' @export cnd_header.vctrs_error_recycle_incompatible_size <- function(cnd, ...) { glue::glue_data(cnd, "`{x_arg}` can't be recycled to size {size}.") } #' @export cnd_body.vctrs_error_recycle_incompatible_size <- function(cnd, ...) { glue_data_bullets( cnd, x = "It must be size {size} or 1, not {x_size}.", ) } # Names ------------------------------------------------------------------- stop_names <- function(message, class, locations, ...) { stop_vctrs( message, class = c(class, "vctrs_error_names"), locations = locations, ... ) } stop_names_cannot_be_empty <- function(locations) { stop_names( "Names must not be empty.", class = "vctrs_error_names_cannot_be_empty", locations = locations ) } stop_names_cannot_be_dot_dot <- function(locations) { stop_names( "Names must not be of the form `...` or `..j`.", class = "vctrs_error_names_cannot_be_dot_dot", locations = locations ) } stop_names_must_be_unique <- function(locations) { stop_names( "Names must be unique.", class = "vctrs_error_names_must_be_unique", locations = locations ) } enumerate <- function(x, max = 5L, allow_empty = FALSE) { n <- length(x) if (n == 0L && !allow_empty) { abort("Internal error: Enumeration can't be empty.") } if (n > max) { paste0(glue::glue_collapse(x[seq2(1, max)], ", "), ", etc.") } else { if (n == 2) { last <- " and " } else { last <- ", and " } glue::glue_collapse(x, ", ", last = last) } } ensure_full_stop <- function(x) { n <- nchar(x) if (substr(x, n, n) == ".") { x } else { paste0(x, ".") } } # Helpers ----------------------------------------------------------------- glue_lines <- function(..., env = parent.frame()) { out <- map_chr(chr(...), glue::glue, .envir = env) paste(out, collapse = "\n") } format_arg_label <- function(type, arg = "") { type <- paste0("<", type, ">") if (nzchar(arg)) { paste0("`", arg, "` ", type) } else { type } } arg_as_string <- function(arg) { if (is_string(arg)) { arg } else { as_label(arg) } } append_arg <- function(x, arg) { if (is_null(arg)) { x } else { arg <- arg_as_string(arg) glue::glue("{x} `{arg}`") } } vctrs/R/proxy.R0000644000176200001440000000654413622451540013133 0ustar liggesusers#' Extract underlying data #' #' @description #' #' Extract the data underlying an S3 vector object, i.e. the underlying #' (named) atomic vector or list. #' #' * `vec_data()` returns unstructured data. The only attributes #' preserved are names, dims, and dimnames. #' #' Currently, due to the underlying memory architecture of R, this #' creates a full copy of the data. #' #' * `vec_proxy()` may return structured data. This generic is the #' main customisation point in vctrs, along with [vec_restore()]. #' See the section below to learn when you should implement #' `vec_proxy()`. #' #' Methods must return a vector type. Records and data frames will #' be processed rowwise. #' #' @param x A vector or object implementing `vec_proxy()`. #' @return The data underlying `x`, free from any attributes except the names. #' #' @section When should you proxy your type: #' #' You should only implement `vec_proxy()` when your type is designed #' around a non-vector class. I.e. anything that is not either: #' #' * An atomic vector #' * A bare list #' * A data frame #' #' In this case, implement `vec_proxy()` to return such a vector #' class. The vctrs operations such as [vec_slice()] are applied on #' the proxy and `vec_restore()` is called to restore the original #' representation of your type. #' #' The most common case where you need to implement `vec_proxy()` is #' for S3 lists. In vctrs, S3 lists are treated as scalars by #' default. This way we don't treat objects like model fits as #' vectors. To prevent vctrs from treating your S3 list as a scalar, #' unclass it in the `vec_proxy()` method. For instance, here is the #' definition for `list_of`: #' #' ``` #' vec_proxy.vctrs_list_of <- function(x) { #' unclass(x) #' } #' ``` #' #' Another case where you need to implement a proxy is [record #' types][new_rcrd]. Record types should return a data frame, as in #' the `POSIXlt` method: #' #' ``` #' vec_proxy.POSIXlt <- function(x) { #' new_data_frame(unclass(x)) #' } #' ``` #' #' Note that you don't need to implement `vec_proxy()` when your class #' inherits from `vctrs_vctr` or `vctrs_rcrd`. #' #' @seealso See [vec_restore()] for the inverse operation: it restores #' attributes given a bare vector and a prototype; #' `vec_restore(vec_data(x), x)` will always yield `x`. #' @export vec_data <- function(x) { vec_assert(x) x <- vec_proxy(x) if (has_dim(x)) { x <- vec_set_attributes(x, list(dim = dim(x), dimnames = dimnames(x))) } else { x <- vec_set_attributes(x, list(names = names(x))) } x } #' @rdname vec_data #' @inheritParams ellipsis::dots_empty #' @export vec_proxy <- function(x, ...) { if (!missing(...)) { ellipsis::check_dots_empty() } return(.Call(vctrs_proxy, x)) UseMethod("vec_proxy") } vec_proxy_dispatch <- function(x, ...) { UseMethod("vec_proxy") } #' @export vec_proxy.default <- function(x, ...) { x } vec_proxy_recursive <- function(x, kind = "default") { .Call(vctrs_proxy_recursive, x, sym(kind)) } #' @export #' @rdname vec_cast vec_restore <- function(x, to, ..., n = NULL) { if (!missing(...)) { ellipsis::check_dots_empty() } return(.Call(vctrs_restore, x, to, n)) UseMethod("vec_restore", to) } vec_restore_dispatch <- function(x, to, ..., n = NULL) { UseMethod("vec_restore", to) } #' @export vec_restore.default <- function(x, to, ..., n = NULL) { .Call(vctrs_restore_default, x, to) } vctrs/R/group.R0000644000176200001440000000571613622451540013106 0ustar liggesusers#' Identify groups #' #' @description #' #' \Sexpr[results=rd, stage=render]{vctrs:::lifecycle("experimental")} #' #' * `vec_group_id()` returns an identifier for the group that each element of #' `x` falls in, constructed in the order that they appear. The number of #' groups is also returned as an attribute, `n`. #' #' * `vec_group_loc()` returns a data frame containing a `key` column with the #' unique groups, and a `loc` column with the locations of each group in `x`. #' #' * `vec_group_rle()` locates groups in `x` and returns them run length #' encoded in the order that they appear. The return value is a rcrd object #' with fields for the `group` identifiers and the run `length` of the #' corresponding group. The number of groups is also returned as an #' attribute, `n`. #' #' @param x A vector #' @return #' * `vec_group_id()`: An integer vector with the same size as `x`. #' * `vec_group_loc()`: A two column data frame with size equal to #' `vec_size(vec_unique(x))`. #' * A `key` column of type `vec_ptype(x)` #' * A `loc` column of type list, with elements of type integer. #' * `vec_group_rle()`: A `vctrs_group_rle` rcrd object with two integer #' vector fields: `group` and `length`. #' #' Note that when using `vec_group_loc()` for complex types, the default #' `data.frame` print method will be suboptimal, and you will want to coerce #' into a tibble to better understand the output. #' @name vec_group #' @keywords internal #' @examples #' purrr <- c("p", "u", "r", "r", "r") #' vec_group_id(purrr) #' vec_group_rle(purrr) #' #' groups <- mtcars[c("vs", "am")] #' vec_group_id(groups) #' #' group_rle <- vec_group_rle(groups) #' group_rle #' #' # Access fields with `field()` #' field(group_rle, "group") #' field(group_rle, "length") #' #' # `vec_group_id()` is equivalent to #' vec_match(groups, vec_unique(groups)) #' #' vec_group_loc(mtcars$vs) #' vec_group_loc(mtcars[c("vs", "am")]) #' #' if (require("tibble")) { #' as_tibble(vec_group_loc(mtcars[c("vs", "am")])) #' } NULL #' @rdname vec_group #' @export vec_group_id <- function(x) { .Call(vctrs_group_id, x) } #' @rdname vec_group #' @export vec_group_loc <- function(x) { .Call(vctrs_group_loc, x) } #' @rdname vec_group #' @export vec_group_rle <- function(x) { .Call(vctrs_group_rle, x) } #' @export format.vctrs_group_rle <- function(x, ...) { group <- field(x, "group") length <- field(x, "length") paste0(group, "x", length) } #' @export obj_print_header.vctrs_group_rle <- function(x, ...) { size <- vec_size(x) n <- attr(x, "n") cat_line("<", vec_ptype_full(x), "[", size, "][n = ", n, "]>") invisible(x) } # For testing new_group_rle <- function(group, length, n) { vec_assert(group, integer()) vec_assert(length, integer()) vec_assert(n, integer(), 1L) if (vec_size(group) != vec_size(length)) { abort("`group` and `length` must have the same size.") } new_rcrd(list(group = group, length = length), n = n, class = "vctrs_group_rle") } vctrs/R/type-vctr.R0000644000176200001440000004021513622451540013700 0ustar liggesusers#' vctr (vector) S3 class #' #' This abstract class provides a set of useful default methods that makes it #' considerably easier to get started with a new S3 vector class. See #' `vignette("s3-vector")` to learn how to use it to create your own S3 #' vector classes. #' #' @section Base methods: #' The vctr class provides methods for many base generics using a smaller #' set of generics defined by this package. Generally, you should think #' carefully before overriding any of the methods that vctrs implements for #' you as they've been carefully planned to be internally consistent. #' #' * `[[` and `[` use `NextMethod()` dispatch to the underlying base function, #' then restore attributes with `vec_restore()`. #' `rep()` and `length<-` work similarly. #' #' * `[[<-` and `[<-` cast `value` to same type as `x`, then call #' `NextMethod()`. #' #' * `as.logical()`, `as.integer()`, `as.numeric()`, `as.character()`, #' `as.Date()` and `as.POSIXct()` methods call `vec_cast()`. #' The `as.list()` method calls `[[` repeatedly, and the `as.data.frame()` #' method uses a standard technique to wrap a vector in a data frame. #' #' * `as.factor()`, `as.ordered()` and `as.difftime()` are not generic functions #' in base R, but have been reimplemented as generics in the `generics` #' package. `vctrs` extends these and calls `vec_cast()`. To inherit this #' behaviour in a package, import and re-export the generic of interest #' from `generics`. #' #' * `==`, `!=`, `unique()`, `anyDuplicated()`, and `is.na()` use #' [vec_proxy()]. #' #' * `<`, `<=`, `>=`, `>`, `min()`, `max()`, `range()`, `median()`, #' `quantile()`, and `xtfrm()` methods use [vec_proxy_compare()]. #' #' * `+`, `-`, `/`, `*`, `^`, `%%`, `%/%`, `!`, `&`, and `|` operators #' use [vec_arith()]. #' #' * Mathematical operations including the Summary group generics (`prod()`, #' `sum()`, `any()`, `all()`), the Math group generics (`abs()`, `sign()`, #' etc), `mean()`, `is.nan()`, `is.finite()`, and `is.infinite()` #' use [vec_math()]. #' #' * `dims()`, `dims<-`, `dimnames()`, `dimnames<-`, `levels()`, and #' `levels<-` methods throw errors. #' #' @param .data Foundation of class. Must be a vector #' @param ... Name-value pairs defining attributes #' @param class Name of subclass. #' @param inherit_base_type \Sexpr[results=rd, stage=render]{vctrs:::lifecycle("experimental")} #' Does this class extend the base type of `.data`? i.e. does the #' resulting object extend the behaviour the underlying type? #' @export #' @keywords internal #' @aliases vctr new_vctr <- function(.data, ..., class = character(), inherit_base_type = FALSE) { if (!is_vector(.data)) { abort("`.data` must be a vector type.") } nms <- validate_names(.data) class <- c(class, "vctrs_vctr", if (inherit_base_type) typeof(.data)) attrib <- list(names = nms, ..., class = class) vec_set_attributes(.data, attrib) } validate_names <- function(.data) { nms <- names(.data) if (!names_all_or_nothing(nms)) { stop("If any elements of `.data` are named, all must be named", call. = FALSE) } nms } names_all_or_nothing <- function(names) { if (is.null(names)) { TRUE } else { all(names != "" & !is.na(names)) } } #' @export vec_proxy.vctrs_vctr <- function(x, ...) { if (is_list(x)) { unclass(x) } else { x } } #' @export vec_restore.vctrs_vctr <- function(x, to, ..., i = NULL) { if (typeof(x) != typeof(to)) { stop_incompatible_cast(x, to) } NextMethod() } #' @method vec_ptype2 vctrs_vctr #' @export vec_ptype2.vctrs_vctr <- function(x, y, ..., x_arg = "x", y_arg = "y") { # This method is redundant with `vec_ptype2.default()` but it # instructs `vec_c()` that it isn't a foreign type. This avoids # infinite recursion through `c.vctrs_vctr()`. if (has_same_type(x, y)) { vec_ptype(x) } else { vec_default_ptype2(x, y, ..., x_arg = x_arg, y_arg = y_arg) } } #' @method vec_cast vctrs_vctr #' @export vec_cast.vctrs_vctr <- function(x, to, ...) UseMethod("vec_cast.vctrs_vctr") #' @method vec_cast.vctrs_vctr default #' @export vec_cast.vctrs_vctr.default <- function(x, to, ...) { # These are not strictly necessary, but make bootstrapping a new class # a bit simpler if (is.object(x)) { attr_x <- utils::modifyList(attributes(x), list(names = NULL)) attr_y <- utils::modifyList(attributes(to), list(names = NULL)) if (identical(attr_x, attr_y)) { return(x) } else { stop_incompatible_cast(x, to) } } vec_restore(x, to) } #' @export #' @method vec_cast.list vctrs_vctr vec_cast.list.vctrs_vctr <- function(x, to, ...) { # FIXME: Coercion to list should be disallowed. Current # implementation can be achieved with `vec_chop()`. vec_cast_list_default(x, to, ...) } #' @export c.vctrs_vctr <- function(..., recursive = FALSE, use.names = TRUE) { if (!is_false(recursive)) { abort("`recursive` must be `FALSE` when concatenating vctrs classes.") } if (!is_true(use.names)) { abort("`use.names` must be `TRUE` when concatenating vctrs classes.") } vec_c(...) } # Printing ---------------------------------------------------------------- #' @export print.vctrs_vctr <- function(x, ...) { obj_print(x, ...) invisible(x) } #' @export str.vctrs_vctr <- function(object, ...) { obj_str(object, ...) } #' @export format.vctrs_vctr <- function(x, ...) { format(vec_data(x), ...) } # Subsetting -------------------------------------------------------------- #' @export `[.vctrs_vctr` <- function(x, i, ...) { vec_index(x, i, ...) } #' @export `[[.vctrs_vctr` <- function(x, i, ...) { if (is.list(x)) { NextMethod() } else { vec_restore(NextMethod(), x) } } #' @export `$.vctrs_vctr` <- function(x, i) { if (is.list(x)) { NextMethod() } else { vec_restore(NextMethod(), x) } } #' @export rep.vctrs_vctr <- function(x, ...) { vec_restore(NextMethod(), x) } #' @export `length<-.vctrs_vctr` <- function(x, value) { vec_restore(NextMethod(), x) } #' @export diff.vctrs_vctr <- function(x, lag = 1L, differences = 1L, ...) { stopifnot(length(lag) == 1L, lag >= 1L) stopifnot(length(differences) == 1L, differences >= 1L) n <- vec_size(x) if (lag * differences >= n) return(vec_slice(x, 0L)) out <- x for (i in seq_len(differences)) { n <- vec_size(out) lhs <- (1L + lag):n rhs <- 1L:(n - lag) out <- vec_slice(out, lhs) - vec_slice(out, rhs) } out } # Modification ------------------------------------------------------------- #' @export `[[<-.vctrs_vctr` <- function(x, ..., value) { if (!is.list(x)) { value <- vec_coercible_cast(value, x, x_arg = "x", to_arg = "value") } NextMethod() } #' @export `$<-.vctrs_vctr` <- function(x, i, value) { if (is.list(x)) { NextMethod() } else { # Default behaviour is to cast LHS to a list abort("$ operator is invalid for atomic vectors.") } } #' @export `[<-.vctrs_vctr` <- function(x, i, value) { value <- vec_coercible_cast(value, x, x_arg = "x", to_arg = "value") NextMethod() } #' @export `names<-.vctrs_vctr` <- function(x, value) { if (length(value) != 0 && length(value) != length(x)) { abort("`names()` must be the same length as x.") } if (!names_all_or_nothing(value)) { abort("If any elements are named, all elements must be named.") } NextMethod() } # Coercion ---------------------------------------------------------------- #' @export as.logical.vctrs_vctr <- function(x, ...) { vec_cast(x, logical()) } #' @export as.integer.vctrs_vctr <- function(x, ...) { vec_cast(x, integer()) } #' @export as.double.vctrs_vctr <- function(x, ...) { vec_cast(x, double()) } #' @export as.character.vctrs_vctr <- function(x, ...) { vec_cast(x, character()) } #' @export as.list.vctrs_vctr <- function(x, ...) { vec_cast(x, list()) } #' @export as.Date.vctrs_vctr <- function(x, ...) { vec_cast(x, new_date()) } #' @export as.POSIXct.vctrs_vctr <- function(x, tz = "", ...) { vec_cast(x, new_datetime(tzone = tz)) } #' @export as.POSIXlt.vctrs_vctr <- function(x, tz = "", ...) { to <- as.POSIXlt(new_datetime(), tz = tz) vec_cast(x, to) } # Work around inconsistencies in as.data.frame() for 1D arrays as.data.frame2 <- function(x) { out <- as.data.frame(x) if (vec_dim_n(x) == 1) { # 1D arrays are not stripped from their dimensions out[[1]] <- as.vector(out[[1]]) # 1D arrays are auto-labelled with substitute() names(out) <- "V1" } out } #' @export as.data.frame.vctrs_vctr <- function(x, row.names = NULL, optional = FALSE, ..., nm = paste(deparse(substitute(x), width.cutoff = 500L), collapse = " ")) { force(nm) if (has_dim(x)) { return(as.data.frame2(vec_data(x))) } cols <- list(x) if (!optional) { names(cols) <- nm } new_data_frame(cols, n = vec_size(x)) } # Dynamically registered in .onLoad() as.factor.vctrs_vctr <- function(x, levels = character(), ...) { vec_cast(x, new_factor(levels = levels)) } # Dynamically registered in .onLoad() as.ordered.vctrs_vctr <- function(x, levels = character(), ...) { vec_cast(x, new_ordered(levels = levels)) } # Dynamically registered in .onLoad() as.difftime.vctrs_vctr <- function(x, units = "secs", ...) { vec_cast(x, new_duration(units = units)) } # Equality ---------------------------------------------------------------- #' @export `==.vctrs_vctr` <- function(e1, e2) { vec_equal(e1, e2) } #' @export `!=.vctrs_vctr` <- function(e1, e2) { !vec_equal(e1, e2) } #' @export is.na.vctrs_vctr <- function(x) { vec_equal_na(x) } #' @export anyNA.vctrs_vctr <- if (getRversion() >= "3.2") { function(x, recursive = FALSE) { any(is.na(x)) } } else { function(x) { any(is.na(x)) } } #' @export unique.vctrs_vctr <- function(x, incomparables = FALSE, ...) { vec_unique(x) } #' @export duplicated.vctrs_vctr <- function(x, incomparables = FALSE, ...) { vec_duplicate_id(x) != seq_along(x) } #' @export anyDuplicated.vctrs_vctr <- function(x, incomparables = FALSE, ...) { vec_duplicate_any(x) } # Comparison ---------------------------------------------------------------- #' @export `<=.vctrs_vctr` <- function(e1, e2) { vec_compare(e1, e2) <= 0 } #' @export `<.vctrs_vctr` <- function(e1, e2) { vec_compare(e1, e2) < 0 } #' @export `>=.vctrs_vctr` <- function(e1, e2) { vec_compare(e1, e2) >= 0 } #' @export `>.vctrs_vctr` <- function(e1, e2) { vec_compare(e1, e2) > 0 } #' @export xtfrm.vctrs_vctr <- function(x) { proxy <- vec_proxy_compare(x) # order(order(x)) ~= rank(x) if (is_integer(proxy) || is_double(proxy)) { proxy } else { order(order_proxy(proxy)) } } #' @importFrom stats median #' @export median.vctrs_vctr <- function(x, ..., na.rm = FALSE) { # nocov start stop_unimplemented(x, "median") # nocov end } #' @importFrom stats quantile #' @export quantile.vctrs_vctr <- function(x, ..., type = 1, na.rm = FALSE) { # nocov start stop_unimplemented(x, "quantile") # nocov end } #' @export min.vctrs_vctr <- function(x, ..., na.rm = FALSE) { if (vec_is_empty(x)) { return(vec_cast(Inf, x)) } # TODO: implement to do vec_arg_min() rank <- xtfrm(x) if (isTRUE(na.rm)) { idx <- which.min(rank) } else { idx <- which(vec_equal(rank, min(rank), na_equal = TRUE)) } x[[idx[[1]]]] } #' @export max.vctrs_vctr <- function(x, ..., na.rm = FALSE) { if (vec_is_empty(x)) { return(vec_cast(-Inf, x)) } # TODO: implement to do vec_arg_max() rank <- xtfrm(x) if (isTRUE(na.rm)) { idx <- which.max(rank) } else { idx <- which(vec_equal(rank, max(rank), na_equal = TRUE)) } x[[idx[[1]]]] } #' @export range.vctrs_vctr <- function(x, ..., na.rm = FALSE) { if (vec_is_empty(x)) { return(vec_cast(c(Inf, -Inf), x)) } # Inline `min()` / `max()` to only call `xtfrm()` once rank <- xtfrm(x) if (isTRUE(na.rm)) { idx_min <- which.min(rank) idx_max <- which.max(rank) } else { idx_min <- which(vec_equal(rank, min(rank), na_equal = TRUE)) idx_max <- which(vec_equal(rank, max(rank), na_equal = TRUE)) } c(x[[idx_min[[1]]]], x[[idx_max[[1]]]]) } # Numeric ----------------------------------------------------------------- #' @export Math.vctrs_vctr <- function(x, ...) { vec_math(.Generic, x, ...) } #' @export Summary.vctrs_vctr <- function(..., na.rm = FALSE) { vec_math(.Generic, vec_c(...), na.rm = na.rm) } #' @export mean.vctrs_vctr <- function(x, ..., na.rm = FALSE) { vec_math("mean", x, na.rm = na.rm) } #' @export is.finite.vctrs_vctr <- function(x) { vec_math("is.finite", x) } #' @export is.infinite.vctrs_vctr <- function(x) { vec_math("is.infinite", x) } #' @export is.nan.vctrs_vctr <- function(x) { vec_math("is.nan", x) } # Arithmetic -------------------------------------------------------------- #' @export `+.vctrs_vctr` <- function(e1, e2) { if (missing(e2)) { vec_arith("+", e1, MISSING()) } else { vec_arith("+", e1, e2) } } #' @export `-.vctrs_vctr` <- function(e1, e2) { if (missing(e2)) { vec_arith("-", e1, MISSING()) } else { vec_arith("-", e1, e2) } } #' @export `*.vctrs_vctr` <- function(e1, e2) { vec_arith("*", e1, e2) } #' @export `/.vctrs_vctr` <- function(e1, e2) { vec_arith("/", e1, e2) } #' @export `^.vctrs_vctr` <- function(e1, e2) { vec_arith("^", e1, e2) } #' @export `%%.vctrs_vctr` <- function(e1, e2) { vec_arith("%%", e1, e2) } #' @export `%/%.vctrs_vctr` <- function(e1, e2) { vec_arith("%/%", e1, e2) } #' @export `!.vctrs_vctr` <- function(x) { vec_arith("!", x, MISSING()) } #' @export `&.vctrs_vctr` <- function(e1, e2) { vec_arith("&", e1, e2) } #' @export `|.vctrs_vctr` <- function(e1, e2) { vec_arith("|", e1, e2) } # Unimplemented ------------------------------------------------------------ #' @export summary.vctrs_vctr <- function(object, ...) { # nocov start stop_unimplemented(object, "summary") # nocov end } # Unsupported -------------------------------------------------------------- #' @export `dim<-.vctrs_vctr` <- function(x, value) { stop_unsupported(x, "dim<-") } #' @export `dimnames<-.vctrs_vctr` <- function(x, value) { stop_unsupported(x, "dimnames<-") } #' @export levels.vctrs_vctr <- function(x) { stop_unsupported(x, "levels") } #' @export `levels<-.vctrs_vctr` <- function(x, value) { stop_unsupported(x, "levels<-") } #' @export `t.vctrs_vctr` <- function(x) { stop_unsupported(x, "t") } #' @export `is.na<-.vctrs_vctr` <- function(x, value) { # No support for other arguments than logical for now, # even if base R is more lenient here. vec_assert(value, logical()) vec_slice(x, value) <- vec_init(x) x } # Helpers ----------------------------------------------------------------- # This simple class is used for testing as defining methods inside # a test does not work (because the lexical scope is lost) # nocov start new_hidden <- function(x = double()) { stopifnot(is.numeric(x)) new_vctr(vec_cast(x, double()), class = "hidden", inherit_base_type = FALSE) } format.hidden <- function(x, ...) rep("xxx", length(x)) local_hidden <- function(frame = caller_env()) { local_bindings(.env = global_env(), .frame = frame, vec_ptype2.hidden = function(x, y, ...) UseMethod("vec_ptype2.hidden", y), vec_ptype2.hidden.default = function(x, y, ...) stop_incompatible_type(x, y, ...), vec_ptype2.hidden.hidden = function(x, y, ...) new_hidden(), vec_ptype2.hidden.double = function(x, y, ...) new_hidden(), vec_ptype2.double.hidden = function(x, y, ...) new_hidden(), vec_ptype2.hidden.logical = function(x, y, ...) new_hidden(), vec_ptype2.logical.hidden = function(x, y, ...) new_hidden(), vec_cast.hidden = function(x, to, ...) UseMethod("vec_cast.hidden"), vec_cast.hidden.default = function(x, to, ...) stop_incompatible_cast(x, to, ...), vec_cast.hidden.hidden = function(x, to, ...) x, vec_cast.hidden.double = function(x, to, ...) new_hidden(vec_data(x)), vec_cast.double.hidden = function(x, to, ...) vec_data(x), vec_cast.hidden.logical = function(x, to, ...) new_hidden(as.double(x)), vec_cast.logical.hidden = function(x, to, ...) as.logical(vec_data(x)) ) } # nocov end vctrs/R/type-rcrd.R0000644000176200001440000001145313622451540013656 0ustar liggesusers# Constructor and basic methods --------------------------------------------- #' rcrd (record) S3 class #' #' The rcrd class extends [vctr]. A rcrd is composed of 1 or more [field]s, #' which must be vectors of the same length. Is designed specifically for #' classes that can naturally be decomposed into multiple vectors of the same #' length, like [POSIXlt], but where the organisation should be considered #' an implementation detail invisible to the user (unlike a [data.frame]). #' #' @param fields A list. It must possess the following properties: #' * no attributes (apart from names) #' * syntactic names #' * length 1 or greater #' * elements are vectors #' * elements have equal length #' @param ... Additional attributes #' @param class Name of subclass. #' @export #' @aliases ses rcrd #' @keywords internal new_rcrd <- function(fields, ..., class = character()) { check_fields(fields) structure(fields, ..., class = c(class, "vctrs_rcrd", "vctrs_vctr")) } check_fields <- function(fields) { if (!is.list(fields) || length(fields) == 0) { abort("`fields` must be a list of length 1 or greater.") } if (!has_unique_names(fields)) { abort("`fields` must have unique names.") } if (!identical(names(attributes(fields)), "names")) { abort("`fields` must have no attributes (apart from names).") } is_vector <- map_lgl(fields, is_vector) if (!all(is_vector)) { abort("Every field must be a vector.") } lengths <- map_int(fields, length) if (!all_equal(lengths)) { abort("Every field must be the same length.") } invisible(fields) } #' @export vec_proxy.vctrs_rcrd <- function(x, ...) { new_data_frame(unclass(x)) } #' @export vec_restore.vctrs_rcrd <- function(x, to, ...) { x <- NextMethod() attr(x, "row.names") <- NULL x } #' @export length.vctrs_rcrd <- function(x) { .Call(vctrs_size, x) } #' @export names.vctrs_rcrd <- function(x) { NULL } #' @export format.vctrs_rcrd <- function(x, ...) { # nocov start stop_unimplemented(x, "format") # nocov end } #' @export obj_str_data.vctrs_rcrd <- function(x, ...) { obj_str_leaf(x, ...) } #' @method vec_cast vctrs_rcrd #' @export vec_cast.vctrs_rcrd <- function(x, to, ...) UseMethod("vec_cast.vctrs_rcrd") #' @method vec_cast.vctrs_rcrd vctrs_rcrd #' @export vec_cast.vctrs_rcrd.vctrs_rcrd <- function(x, to, ...) { # This assumes that we don't have duplicate field names, # which is verified even in the constructor. if (!setequal(fields(x), fields(to))) { stop_incompatible_cast(x, to) } new_data <- map2( vec_data(x)[fields(to)], vec_data(to), vec_cast ) new_rcrd(new_data) } #' @method vec_cast.vctrs_rcrd default #' @export vec_cast.vctrs_rcrd.default <- function(x, to, ..., x_arg = "", to_arg = "") { if (is_bare_list(x)) { vec_list_cast(x, to, x_arg = x_arg, to_arg = to_arg) } else { stop_incompatible_cast(x, to) } } #' @export #' @method vec_cast.list vctrs_rcrd vec_cast.list.vctrs_rcrd <- function(x, to, ...) { # FIXME: Coercion to list should be disallowed. Current # implementation can be achieved with `vec_chop()`. vec_cast_list_default(x, to, ...) } # Subsetting -------------------------------------------------------------- #' @export `[.vctrs_rcrd` <- function(x, i, ...) { vec_index(x, i, ...) } #' @export `[[.vctrs_rcrd` <- function(x, i, ...) { out <- lapply(vec_data(x), `[[`, i, ...) vec_restore(out, x) } #' @export `$.vctrs_rcrd` <- function(x, i, ...) { stop_unsupported(x, "subsetting with $") } #' @export rep.vctrs_rcrd <- function(x, ...) { out <- lapply(vec_data(x), rep, ...) vec_restore(out, x) } #' @export `length<-.vctrs_rcrd` <- function(x, value) { out <- lapply(vec_data(x), `length<-`, value) vec_restore(out, x) } #' @export as.list.vctrs_rcrd <- function(x, ...) { vec_cast(x, list()) } # Replacement ------------------------------------------------------------- #' @export `[[<-.vctrs_rcrd` <- function(x, i, value) { value <- vec_cast(value, x) out <- map2(vec_data(x), vec_data(value), function(x, value) { x[[i]] <- value x }) vec_restore(out, x) } #' @export `$<-.vctrs_rcrd` <- function(x, i, value) { stop_unsupported(x, "subset assignment with $") } #' @export `[<-.vctrs_rcrd` <- function(x, i, value) { value <- vec_cast(value, x) if (missing(i)) { replace <- function(x, value) { x[] <- value x } } else { replace <- function(x, value) { x[i] <- value x } } out <- map2(vec_data(x), vec_data(value), replace) vec_restore(out, x) } # Equality and ordering --------------------------------------------------- # FIXME #' @export vec_proxy_compare.vctrs_rcrd <- function(x, ..., relax = FALSE) { new_data_frame(vec_data(x), n = length(x)) } #' @export vec_math.vctrs_rcrd <- function(.fn, .x, ...) { stop_unsupported(.x, "vec_math") } vctrs/R/type2.R0000644000176200001440000000613413623013722013005 0ustar liggesusers#' Find the common type for a pair of vector types #' #' `vec_ptype2()` finds the common type for a pair of vectors, or dies trying. #' It forms the foundation of the vctrs type system, along with [vec_cast()]. #' This powers type coercion but should not usually be called directly; #' instead call [vec_ptype_common()]. #' #' @section Coercion rules: #' vctrs thinks of the vector types as forming a partially ordered set, or #' poset. Then finding the common type from a set of types is a matter of #' finding the least-upper-bound; if the least-upper-bound does not exist, #' there is no common type. This is the case for many pairs of 1d vectors. #' #' The poset of the most important base vectors is shown below: #' (where datetime stands for `POSIXt`, and date for `Date`) #' #' \figure{coerce.png} #' #' @section S3 dispatch: #' `vec_ptype2()` dispatches on both arguments. This is implemented by having #' methods of `vec_ptype2()`, e.g. `vec_ptype2.integer()` also be S3 generics, #' which call e.g. `vec_ptype2.integer.double()`. `vec_ptype2.x.y()` must #' return the same value as `vec_ptype2.y.x()`; this is currently not enforced, #' but should be tested. #' #' Whenever you implement a `vec_ptype2.new_class()` generic/method, #' make sure to always provide `vec_ptype2.new_class.default()`. It #' should normally call `vec_default_ptype2()`. #' #' See `vignette("s3-vector")` for full details. #' @keywords internal #' @inheritParams ellipsis::dots_empty #' @param x,y Vector types. #' @param x_arg,y_arg Argument names for `x` and `y`. These are used #' in error messages to inform the user about the locations of #' incompatible types (see [stop_incompatible_type()]). #' @export vec_ptype2 <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (!missing(...)) { ellipsis::check_dots_empty() } return(.Call(vctrs_type2, x, y, x_arg, y_arg)) UseMethod("vec_ptype2") } vec_ptype2_dispatch_s3 <- function(x, y, ..., x_arg = "x", y_arg = "y") { UseMethod("vec_ptype2") } #' @export vec_ptype2.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (has_same_type(x, y)) { return(x) } stop_incompatible_type(x, y, x_arg = x_arg, y_arg = y_arg) } #' @rdname vec_ptype2 #' @export vec_default_ptype2 <- function(x, y, ..., x_arg = "x", y_arg = "y") { if (is_unspecified(y)) { return(vec_ptype(x)) } if (is_same_type(x, y)) { return(vec_ptype(x)) } stop_incompatible_type(x, y, x_arg = x_arg, y_arg = y_arg) } vec_typeof2 <- function(x, y) { .Call(vctrs_typeof2, x, y) } vec_typeof2_s3 <- function(x, y) { .Call(vctrs_typeof2_s3, x, y) } # https://github.com/r-lib/vctrs/issues/571 vec_is_coercible <- function(x, to, ..., x_arg = "x", to_arg = "to") { tryCatch( vctrs_error_incompatible_type = function(...) FALSE, { vctrs::vec_ptype2(x, to, ..., x_arg = x_arg, y_arg = to_arg) TRUE } ) } vec_is_subtype <- function(x, super, ..., x_arg = "x", super_arg = "super") { tryCatch( vctrs_error_incompatible_type = function(...) FALSE, { common <- vctrs::vec_ptype2(x, super, ..., x_arg = x_arg, y_arg = super_arg) vec_is(common, super) } ) } vctrs/R/hash.R0000644000176200001440000000042513622451540012665 0ustar liggesusers # These return raw vectors of hashes. Vector elements are coded with # 32 bit hashes. Thus, the size of the raw vector of hashes is 4 times # the size of the input. vec_hash <- function(x) { .Call(vctrs_hash, x) } obj_hash <- function(x) { .Call(vctrs_hash_object, x) } vctrs/R/translate.R0000644000176200001440000000027713622451540013744 0ustar liggesusersobj_maybe_translate_encoding <- function(x) { .Call(vctrs_maybe_translate_encoding, x) } obj_maybe_translate_encoding2 <- function(x, y) { .Call(vctrs_maybe_translate_encoding2, x, y) } vctrs/R/compat-lifecycle.R0000644000176200001440000001634013622451540015165 0ustar liggesusers# nocov start --- compat-lifecycle --- 2019-11-15 Fri 15:55 # This file serves as a reference for currently unexported rlang # lifecycle functions. Please find the most recent version in rlang's # repository. These functions require rlang in your `Imports` # DESCRIPTION field but you don't need to import rlang in your # namespace. #' Signal deprecation #' #' @description #' #' These functions provide two levels of verbosity for deprecation #' warnings. #' #' * `signal_soft_deprecated()` warns only if called from the global #' environment (so the user can change their script) or from the #' package currently being tested (so the package developer can fix #' the package). #' #' * `warn_deprecated()` warns unconditionally. #' #' * `stop_defunct()` fails unconditionally. #' #' Both functions warn only once per session by default to avoid #' overwhelming the user with repeated warnings. #' #' @param msg The deprecation message. #' @param id The id of the deprecation. A warning is issued only once #' for each `id`. Defaults to `msg`, but you should give a unique ID #' when the message is built programmatically and depends on inputs. #' @param env The environment in which the soft-deprecated function #' was called. A warning is issued if called from the global #' environment. If testthat is running, a warning is also called if #' the retired function was called from the package being tested. #' #' @section Controlling verbosity: #' #' The verbosity of retirement warnings can be controlled with global #' options. You'll generally want to set these options locally with #' one of these helpers: #' #' * `with_lifecycle_silence()` disables all soft-deprecation and #' deprecation warnings. #' #' * `with_lifecycle_warnings()` enforces warnings for both #' soft-deprecated and deprecated functions. The warnings are #' repeated rather than signalled once per session. #' #' * `with_lifecycle_errors()` enforces errors for both #' soft-deprecated and deprecated functions. #' #' All the `with_` helpers have `scoped_` variants that are #' particularly useful in testthat blocks. #' #' @noRd #' @seealso [lifecycle()] NULL signal_soft_deprecated <- function(msg, id = msg, env = caller_env(2)) { msg <- lifecycle_validate_message(msg) stopifnot( rlang::is_string(id), rlang::is_environment(env) ) if (rlang::is_true(rlang::peek_option("lifecycle_disable_warnings"))) { return(invisible(NULL)) } env_inherits_global <- function(env) { # `topenv(emptyenv())` returns the global env. Return `FALSE` in # that case to allow passing the empty env when the # soft-deprecation should not be promoted to deprecation based on # the caller environment. if (rlang::is_reference(env, emptyenv())) { return(FALSE) } rlang::is_reference(topenv(env), rlang::global_env()) } if (rlang::is_true(rlang::peek_option("lifecycle_verbose_soft_deprecation")) || env_inherits_global(env)) { warn_deprecated(msg, id) return(invisible(NULL)) } # Test for environment names rather than reference/contents because # testthat clones the namespace tested_package <- Sys.getenv("TESTTHAT_PKG") if (nzchar(tested_package) && identical(Sys.getenv("NOT_CRAN"), "true") && rlang::env_name(topenv(env)) == rlang::env_name(ns_env(tested_package))) { warn_deprecated(msg, id) return(invisible(NULL)) } rlang::signal(msg, "lifecycle_soft_deprecated") } warn_deprecated <- function(msg, id = msg) { msg <- lifecycle_validate_message(msg) stopifnot(rlang::is_string(id)) if (rlang::is_true(rlang::peek_option("lifecycle_disable_warnings"))) { return(invisible(NULL)) } if (!rlang::is_true(rlang::peek_option("lifecycle_repeat_warnings")) && rlang::env_has(deprecation_env, id)) { return(invisible(NULL)) } rlang::env_poke(deprecation_env, id, TRUE); has_colour <- function() rlang::is_installed("crayon") && crayon::has_color() silver <- function(x) if (has_colour()) crayon::silver(x) else x if (rlang::is_true(rlang::peek_option("lifecycle_warnings_as_errors"))) { .Signal <- stop_defunct } else { .Signal <- .Deprecated } if (!rlang::is_true(rlang::peek_option("lifecycle_repeat_warnings"))) { msg <- paste0(msg, "\n", silver("This warning is displayed once per session.")) } .Signal(msg = msg) } deprecation_env <- new.env(parent = emptyenv()) stop_defunct <- function(msg) { msg <- lifecycle_validate_message(msg) err <- cnd( c("defunctError", "error", "condition"), old = NULL, new = NULL, package = NULL, message = msg ) stop(err) } local_lifecycle_silence <- function(frame = rlang::caller_env()) { rlang::local_options(.frame = frame, lifecycle_disable_warnings = TRUE ) } with_lifecycle_silence <- function(expr) { local_lifecycle_silence() expr } local_lifecycle_warnings <- function(frame = rlang::caller_env()) { rlang::local_options(.frame = frame, lifecycle_disable_warnings = FALSE, lifecycle_verbose_soft_deprecation = TRUE, lifecycle_repeat_warnings = TRUE ) } with_lifecycle_warnings <- function(expr) { local_lifecycle_warnings() expr } local_lifecycle_errors <- function(frame = rlang::caller_env()) { local_lifecycle_warnings(frame = frame) rlang::local_options(.frame = frame, lifecycle_warnings_as_errors = TRUE ) } with_lifecycle_errors <- function(expr) { local_lifecycle_errors() expr } #' Embed a lifecycle badge in documentation #' #' @description #' #' Use `lifecycle()` within a `Sexpr` macro to embed a #' [lifecycle](https://www.tidyverse.org/lifecycle/) badge in your #' documentation. The badge should appear first in the description: #' #' ``` #' \Sexpr[results=rd, stage=render]{mypkg:::lifecycle("questioning")} #' ``` #' #' The badge appears as an image in the HTML version of the #' documentation. To make them available in your package, visit #' and copy #' all the files starting with `lifecycle-` in your `man/figures/` #' folder. #' #' @param stage A lifecycle stage as a string, one of: #' `"experimental"`, `"maturing"`, `"stable"`, `"questioning"`, #' `"archived"`, `"soft-deprecated"`, `"deprecated"`, `"defunct"`. #' #' @keywords internal #' @noRd NULL lifecycle <- function(stage) { url <- paste0("https://www.tidyverse.org/lifecycle/#", stage) img <- lifecycle_img(stage, url) sprintf( "\\ifelse{html}{%s}{\\strong{%s}}", img, upcase1(stage) ) } lifecycle_img <- function(stage, url) { file <- sprintf("lifecycle-%s.svg", stage) stage_alt <- upcase1(stage) switch(stage, experimental = , maturing = , stable = , questioning = , retired = , archived = sprintf( "\\out{%s lifecycle}", url, file.path("figures", file), stage_alt ) , `soft-deprecated` = , deprecated = , defunct = sprintf( "\\figure{%s}{options: alt='%s lifecycle'}", file, stage_alt ), rlang::abort(sprintf("Unknown lifecycle stage `%s`", stage)) ) } upcase1 <- function(x) { substr(x, 1, 1) <- toupper(substr(x, 1, 1)) x } lifecycle_validate_message <- function(msg) { stopifnot(is_character(msg)) paste0(msg, collapse = "\n") } # nocov end vctrs/R/compat-purrr.R0000644000176200001440000001015413622451540014375 0ustar liggesusers# nocov start - compat-purrr (last updated: rlang 0.2.0) # This file serves as a reference for compatibility functions for # purrr. They are not drop-in replacements but allow a similar style # of programming. This is useful in cases where purrr is too heavy a # package to depend on. Please find the most recent version in rlang's # repository. map <- function(.x, .f, ...) { lapply(.x, .f, ...) } map_mold <- function(.x, .f, .mold, ...) { out <- vapply(.x, .f, .mold, ..., USE.NAMES = FALSE) names(out) <- names(.x) out } map_lgl <- function(.x, .f, ...) { map_mold(.x, .f, logical(1), ...) } map_int <- function(.x, .f, ...) { map_mold(.x, .f, integer(1), ...) } map_dbl <- function(.x, .f, ...) { map_mold(.x, .f, double(1), ...) } map_chr <- function(.x, .f, ...) { map_mold(.x, .f, character(1), ...) } map_cpl <- function(.x, .f, ...) { map_mold(.x, .f, complex(1), ...) } walk <- function(.x, .f, ...) { map(.x, .f, ...) invisible(.x) } pluck <- function(.x, .f) { map(.x, `[[`, .f) } pluck_lgl <- function(.x, .f) { map_lgl(.x, `[[`, .f) } pluck_int <- function(.x, .f) { map_int(.x, `[[`, .f) } pluck_dbl <- function(.x, .f) { map_dbl(.x, `[[`, .f) } pluck_chr <- function(.x, .f) { map_chr(.x, `[[`, .f) } pluck_cpl <- function(.x, .f) { map_cpl(.x, `[[`, .f) } map2 <- function(.x, .y, .f, ...) { Map(.f, .x, .y, ...) } map2_lgl <- function(.x, .y, .f, ...) { as.vector(map2(.x, .y, .f, ...), "logical") } map2_int <- function(.x, .y, .f, ...) { as.vector(map2(.x, .y, .f, ...), "integer") } map2_dbl <- function(.x, .y, .f, ...) { as.vector(map2(.x, .y, .f, ...), "double") } map2_chr <- function(.x, .y, .f, ...) { as.vector(map2(.x, .y, .f, ...), "character") } map2_cpl <- function(.x, .y, .f, ...) { as.vector(map2(.x, .y, .f, ...), "complex") } args_recycle <- function(args) { lengths <- map_int(args, length) n <- max(lengths) stopifnot(all(lengths == 1L | lengths == n)) to_recycle <- lengths == 1L args[to_recycle] <- map(args[to_recycle], function(x) rep.int(x, n)) args } pmap <- function(.l, .f, ...) { args <- args_recycle(.l) do.call("mapply", c( FUN = list(quote(.f)), args, MoreArgs = quote(list(...)), SIMPLIFY = FALSE, USE.NAMES = FALSE )) } probe <- function(.x, .p, ...) { if (is_logical(.p)) { stopifnot(length(.p) == length(.x)) .p } else { map_lgl(.x, .p, ...) } } keep <- function(.x, .f, ...) { .x[probe(.x, .f, ...)] } discard <- function(.x, .p, ...) { sel <- probe(.x, .p, ...) .x[is.na(sel) | !sel] } map_if <- function(.x, .p, .f, ...) { matches <- probe(.x, .p) .x[matches] <- map(.x[matches], .f, ...) .x } transpose <- function(.l) { inner_names <- names(.l[[1]]) if (is.null(inner_names)) { fields <- seq_along(.l[[1]]) } else { fields <- set_names(inner_names) } map(fields, function(i) { map(.l, .subset2, i) }) } every <- function(.x, .p, ...) { for (i in seq_along(.x)) { if (!rlang::is_true(.p(.x[[i]], ...))) return(FALSE) } TRUE } some <- function(.x, .p, ...) { for (i in seq_along(.x)) { if (rlang::is_true(.p(.x[[i]], ...))) return(TRUE) } FALSE } negate <- function(.p) { function(...) !.p(...) } reduce <- function(.x, .f, ..., .init) { f <- function(x, y) .f(x, y, ...) Reduce(f, .x, init = .init) } reduce_right <- function(.x, .f, ..., .init) { f <- function(x, y) .f(y, x, ...) Reduce(f, .x, init = .init, right = TRUE) } accumulate <- function(.x, .f, ..., .init) { f <- function(x, y) .f(x, y, ...) Reduce(f, .x, init = .init, accumulate = TRUE) } accumulate_right <- function(.x, .f, ..., .init) { f <- function(x, y) .f(y, x, ...) Reduce(f, .x, init = .init, right = TRUE, accumulate = TRUE) } detect <- function(.x, .f, ..., .right = FALSE, .p = is_true) { for (i in index(.x, .right)) { if (.p(.f(.x[[i]], ...))) { return(.x[[i]]) } } NULL } detect_index <- function(.x, .f, ..., .right = FALSE, .p = is_true) { for (i in index(.x, .right)) { if (.p(.f(.x[[i]], ...))) { return(i) } } 0L } index <- function(x, right = FALSE) { idx <- seq_along(x) if (right) { idx <- rev(idx) } idx } # nocov end vctrs/R/compare.R0000644000176200001440000001174413622451540013376 0ustar liggesusers#' Comparison proxy #' #' Returns a proxy object (i.e. an atomic vector or data frame of atomic #' vectors). For [vctr]s, this determines the behaviour of [order()] and #' [sort()] (via [xtfrm()]); `<`, `>`, `>=` and `<=` (via [vec_compare()]); #' and [min()], [max()], [median()], and [quantile()]. #' #' The default method assumes that all classes built on top of atomic #' vectors or records are orderable. If your class is not, you will need #' to provide a `vec_proxy_compare()` method that throws an error. #' #' @param x A vector x. #' @param relax If `TRUE`, and `x` is otherwise non-comparable, will return #' `vec_seq_along(x)`. This allows a data frame to be orderable, even if #' one of its components is not. This is experimental and may change in the #' future. #' @inheritParams ellipsis::dots_empty #' @return A 1d atomic vector or a data frame. #' @keywords internal #' @export vec_proxy_compare <- function(x, ..., relax = FALSE) { if (!missing(...)) { ellipsis::check_dots_empty() } UseMethod("vec_proxy_compare") } #' @export vec_proxy_compare.default <- function(x, ..., relax = FALSE) { if (vec_dim_n(x) > 1) { # The conversion to data frame is only a stopgap, in the long # term, we'll hash arrays natively. Note that hashing functions # similarly convert to data frames. as.data.frame(x) } else { vec_proxy_compare_default(x, relax) } } vec_proxy_compare_default <- function(x, relax = FALSE) { if (is_bare_list(x)) { if (relax) { vec_seq_along(x) } else { stop_unsupported(x, "vec_proxy_compare") } } else { vec_data(x) } } #' Compare two vectors #' #' @section S3 dispatch: #' `vec_compare()` is not generic for performance; instead it uses #' [vec_proxy_compare()] to #' #' @param x,y Vectors with compatible types and lengths. #' @param na_equal Should `NA` values be considered equal? #' @param .ptype Override to optionally specify common type #' @return An integer vector with values -1 for `x < y`, 0 if `x == y`, #' and 1 if `x > y`. If `na_equal` is `FALSE`, the result will be `NA` #' if either `x` or `y` is `NA`. #' @export #' @examples #' vec_compare(c(TRUE, FALSE, NA), FALSE) #' vec_compare(c(TRUE, FALSE, NA), FALSE, na_equal = TRUE) #' #' vec_compare(1:10, 5) #' vec_compare(runif(10), 0.5) #' vec_compare(letters[1:10], "d") #' #' df <- data.frame(x = c(1, 1, 1, 2), y = c(0, 1, 2, 1)) #' vec_compare(df, data.frame(x = 1, y = 1)) vec_compare <- function(x, y, na_equal = FALSE, .ptype = NULL) { vec_assert(x) vec_assert(y) vec_assert(na_equal, ptype = logical(), size = 1L) args <- vec_recycle_common(x, y) args <- vec_cast_common(!!!args, .to = .ptype) .Call(vctrs_compare, vec_proxy_compare(args[[1]]), vec_proxy_compare(args[[2]]), na_equal) } # order/sort -------------------------------------------------------------- #' Order and sort vectors #' #' @param x A vector #' @param direction Direction to sort in. Defaults to `asc`ending. #' @param na_value Should `NA`s be treated as the largest or smallest values? #' @return #' * `vec_order()` an integer vector the same size as `x`. #' * `vec_sort()` a vector with the same size and type as `x`. #' @export #' @examples #' x <- round(c(runif(9), NA), 3) #' vec_order(x) #' vec_sort(x) #' vec_sort(x, "desc") #' #' # Can also handle data frames #' df <- data.frame(g = sample(2, 10, replace = TRUE), x = x) #' vec_order(df) #' vec_sort(df) #' vec_sort(df, "desc") vec_order <- function(x, direction = c("asc", "desc"), na_value = c("largest", "smallest") ) { direction <- match.arg(direction) na_value <- match.arg(na_value) order_proxy(vec_proxy_compare(x), direction = direction, na_value = na_value) } #' @export #' @rdname vec_order vec_sort <- function(x, direction = c("asc", "desc"), na_value = c("largest", "smallest")) { direction <- match.arg(direction) na_value <- match.arg(na_value) idx <- vec_order(x, direction = direction, na_value = na_value) vec_slice(x, idx) } order_proxy <- function(proxy, direction = "asc", na_value = "largest") { decreasing <- !identical(direction, "asc") na.last <- identical(na_value, "largest") if (decreasing) { na.last <- !na.last } if (is.data.frame(proxy)) { # Work around type-instability in `base::order()` if (vec_size(proxy) == 0L) { return(integer(0L)) } args <- map(unname(proxy), function(.x) { if (is.data.frame(.x)) { .x <- order(vec_order(.x, direction = direction, na_value = na_value)) } .x }) exec("order", !!!args, decreasing = decreasing, na.last = na.last) } else if (is_character(proxy) || is_logical(proxy) || is_integer(proxy) || is_double(proxy)) { order(proxy, decreasing = decreasing, na.last = na.last) } else { abort("Invalid type returned by `vec_proxy_compare()`.") } } # Helpers ----------------------------------------------------------------- # Used for testing cmp <- function(x, y) (x > y) - (x < y) vctrs/R/partial.R0000644000176200001440000000312113623013722013367 0ustar liggesusers#' Partial type #' #' Use `new_partial()` when constructing a new partial type subclass; #' and use `is_partial()` to test if an type is partial. All subclasses #' need to provide a `vec_ptype_finalise()` method. #' #' As the name suggests, a partial type _partially_ specifies a type, and #' it must be combined with data to yield a full type. A useful example #' of a partial type is [partial_frame()], which makes it possible to #' specify the type of just a few columns in a data frame. Use this constructor #' if you're making your own partial type. #' #' @param ... Attributes of the partial type #' @param class Name of subclass. #' @export #' @keywords internal new_partial <- function(..., class = character()) { new_sclr(..., class = c(class, "vctrs_partial")) } #' @export obj_print_header.vctrs_partial <- function(x, ...) { NULL invisible(x) } #' @export obj_print_data.vctrs_partial <- function(x, ...) { cat_line(vec_ptype_full(x)) invisible(x) } #' @rdname new_partial #' @export is_partial <- function(x) { .Call(vctrs_is_partial, x) } #' @rdname new_partial #' @inheritParams ellipsis::dots_empty #' @export vec_ptype_finalise <- function(x, ...) { if (!missing(...)) { ellipsis::check_dots_empty() } return(.Call(vctrs_ptype_finalise, x)) UseMethod("vec_ptype_finalise") } vec_ptype_finalise_dispatch <- function(x, ...) { UseMethod("vec_ptype_finalise") } #' @export vec_ptype_finalise.vctrs_partial <- function(x, ...) { # nocov start stop_unimplemented(x, "vec_ptype_finalise") # nocov end } #' @export vec_ptype_finalise.default <- function(x, ...) { x } vctrs/R/numeric.R0000644000176200001440000000404313622451540013404 0ustar liggesusers#' Mathematical operations #' #' This generic provides a common dispatch mechanism for all regular unary #' mathematical functions. It is used as a common wrapper around many of the #' Summary group generics, the Math group generics, and a handful of other #' mathematical functions like `mean()`. #' #' `vec_math_base()` is provided as a convenience for writing methods. It #' calls the base `.fn` on the underlying [vec_data()]. #' #' @section Included functions: #' #' * From the [Summary] group generic: #' `prod()`, `sum()`, `any()`, `all()`. #' #' * From the [Math] group generic: #' `abs()`, `sign()`, `sqrt()`, `ceiling()`, `floor()`, `trunc()`, `cummax()`, #' `cummin()`, `cumprod()`, `cumsum()`, `log()`, `log10()`, `log2()`, #' `log1p()`, `acos()`, `acosh()`, `asin()`, `asinh()`, `atan()`, `atanh()`, #' `exp()`, `expm1()`, `cos()`, `cosh()`, `cospi()`, `sin()`, `sinh()`, #' `sinpi()`, `tan()`, `tanh()`, `tanpi()`, `gamma()`, `lgamma()`, #' `digamma()`, `trigamma()`. #' #' * Additional generics: `mean()`, `is.nan()`, `is.finite()`, `is.infinite()`. #' #' @seealso [vec_arith()] for the equivalent for the arithmetic infix operators. #' @param .fn A mathematical function from the base package, as a string. #' @param .x A vector. #' @param ... Additional arguments passed to `.fn`. #' @keywords internal #' @export #' @examples #' x <- new_vctr(c(1, 2.5, 10)) #' x #' #' abs(x) #' sum(x) #' cumsum(x) vec_math <- function(.fn, .x, ...) { UseMethod("vec_math", .x) } #' @export vec_math.default <- function(.fn, .x, ...) { if (!is_double(.x) && !is_logical_dispatch(.fn, .x)) { stop_unimplemented(.x, "vec_math") } out <- vec_math_base(.fn, .x, ...) # Don't restore output of logical predicates like `any()`, # `is.finite()`, or `is.nan()` if (is_double(out)) { out <- vec_restore(out, .x) } out } is_logical_dispatch <- function(fn, x) { is_logical(x) && fn %in% c("any", "all") } #' @export #' @rdname vec_math vec_math_base <- function(.fn, .x, ...) { .fn <- getExportedValue("base", .fn) .fn(vec_data(.x), ...) } vctrs/R/c.R0000644000176200001440000000345513622451540012172 0ustar liggesusers#' Combine many vectors into one vector #' #' Combine all arguments into a new vector of common type. #' #' @section Invariants: #' * `vec_size(vec_c(x, y)) == vec_size(x) + vec_size(y)` #' * `vec_ptype(vec_c(x, y)) == vec_ptype_common(x, y)`. #' #' @param ... Vectors to coerce. #' @param .name_repair How to repair names, see `repair` options in [vec_as_names()]. #' @return A vector with class given by `.ptype`, and length equal to the #' sum of the `vec_size()` of the contents of `...`. #' #' The vector will have names if the individual components have names #' (inner names) or if the arguments are named (outer names). If both #' inner and outer names are present, an error is thrown unless a #' `.name_spec` is provided. #' @inheritParams vec_ptype_show #' @inheritParams name_spec #' @seealso [vec_cbind()]/[vec_rbind()] for combining data frames by rows #' or columns. #' @export #' @examples #' vec_c(FALSE, 1L, 1.5) #' vec_c(FALSE, 1L, "x", .ptype = character()) #' #' # Date/times -------------------------- #' c(Sys.Date(), Sys.time()) #' c(Sys.time(), Sys.Date()) #' #' vec_c(Sys.Date(), Sys.time()) #' vec_c(Sys.time(), Sys.Date()) #' #' # Factors ----------------------------- #' c(factor("a"), factor("b")) #' vec_c(factor("a"), factor("b")) #' #' #' # By default, named inputs must be length 1: #' vec_c(name = 1) #' try(vec_c(name = 1:3)) #' #' # Pass a name specification to work around this: #' vec_c(name = 1:3, .name_spec = "{outer}_{inner}") #' #' # See `?name_spec` for more examples of name specifications. vec_c <- function(..., .ptype = NULL, .name_spec = NULL, .name_repair = c("minimal", "unique", "check_unique", "universal")) { .External2(vctrs_c, .ptype, .name_spec, .name_repair) } vec_c <- fn_inline_formals(vec_c, ".name_repair") vctrs/NEWS.md0000644000176200001440000003344513623213173012523 0ustar liggesusers # vctrs 0.2.3 * The main feature of this release is considerable performance improvements with factors and dates. * `vec_c()` now falls back to `base::c()` if the vector doesn't implement `vec_ptype2()` but implements `c()`. This should improve the compatibility of vctrs-based functions with foreign classes (#801). * `new_data_frame()` is now faster. * New `vec_is_list()` for detecting if a vector is a list in the vctrs sense. For instance, objects of class `lm` are not lists. In general, classes need to explicitly inherit from `"list"` to be considered as lists by vctrs. * Unspecified vectors of `NA` can now be assigned into a list (#819). ``` x <- list(1, 2) vec_slice(x, 1) <- NA x #> [[1]] #> NULL #> #> [[2]] #> 2 ``` * `vec_ptype()` now errors on scalar inputs (#807). * `vec_ptype_finalise()` is now recursive over all data frame types, ensuring that unspecified columns are correctly finalised to logical (#800). * `vec_ptype()` now correctly handles unspecified columns in data frames, and will always return an unspecified column type (#800). * `vec_slice()` and `vec_chop()` now work correctly with `bit64::integer64()` objects when an `NA` subscript is supplied. By extension, this means that `vec_init()` now works with these objects as well (#813). * `vec_rbind()` now binds row names. When named inputs are supplied and `names_to` is `NULL`, the names define row names. If `names_to` is supplied, they are assigned in the column name as before. * `vec_cbind()` now binds row names if they are congruent across inputs. If the row names are not identical that's an error. * The `c()` method for `vctrs_vctr` now throws an error when `recursive` or `use.names` is supplied (#791). # vctrs 0.2.2 * New `vec_as_subscript()` function to cast inputs to the base type of a subscript (logical, numeric, or character). `vec_as_index()` has been renamed to `vec_as_location()`. Use `num_as_location()` if you need more options to control how numeric subscripts are converted to a vector of locations. * New `vec_as_subscript2()`, `vec_as_location2()`, and `num_as_location2()` variants for validating scalar subscripts and locations (e.g. for indexing with `[[`). * `vec_as_location()` now preserves names of its inputs if possible. * `vec_ptype2()` methods for base classes now prevent inheritance. This makes sense because the subtyping graph created by `vec_ptype2()` methods is generally not the same as the inheritance relationships defined by S3 classes. For instance, subclasses are often a richer type than their superclasses, and should often be declared as supertypes (e.g. `vec_ptype2()` should return the subclass). We introduced this breaking change in a patch release because `new_vctr()` now adds the base type to the class vector by default, which caused `vec_ptype2()` to dispatch erroneously to the methods for base types. We'll finish switching to this approach in vctrs 0.3.0 for the rest of the base S3 classes (dates, data frames, ...). * `vec_equal_na()` now works with complex vectors. * `vctrs_vctr` class gains an `as.POSIXlt()` method (#717). * `vec_is()` now ignores names and row names (#707). * `vec_slice()` now support Altvec vectors (@jimhester, #696). * `vec_proxy_equal()` is now applied recursively across the columns of data frames (#641). * `vec_split()` no longer returns the `val` column as a `list_of`. It is now returned as a bare list (#660). * Complex numbers are now coercible with integer and double (#564). * zeallot has been moved from Imports to Suggests, meaning that `%<-%` is no longer re-exported from vctrs. * `vec_equal()` no longer propagates missing values when comparing list elements. This means that `vec_equal(list(NULL), list(NULL))` will continue to return `NA` because `NULL` is the missing element for a list, but now `vec_equal(list(NA), list(NA))` returns `TRUE` because the `NA` values are compared directly without checking for missingness. * Lists of expressions are now supported in `vec_equal()` and functions that compare elements, such as `vec_unique()` and `vec_match()`. This ensures that they work with the result of modeling functions like `glm()` and `mgcv::gam()` which store "family" objects containing expressions (#643). * `new_vctr()` gains an experimental `inherit_base_type` argument which determines whether or not the class of the underlying type will be included in the class. * `list_of()` now inherits explicitly from "list" (#593). * `vec_ptype()` has relaxed default behaviour for base types; now if two vectors both inherit from (e.g.) "character", the common type is also "character" (#497). * `vec_equal()` now correctly treats `NULL` as the missing value element for lists (#653). * `vec_cast()` now casts data frames to lists rowwise, i.e. to a list of data frames of size 1. This preserves the invariant of `vec_size(vec_cast(x, to)) == vec_size(x)` (#639). * Positive and negative 0 are now considered equivalent by all functions that check for equality or uniqueness (#637). * New experimental functions `vec_group_rle()` for returning run length encoded groups; `vec_group_id()` for constructing group identifiers from a vector; `vec_group_loc()` for computing the locations of unique groups in a vector (#514). * New `vec_chop()` for repeatedly slicing a vector. It efficiently captures the pattern of `map(indices, vec_slice, x = x)`. * Support for multiple character encodings has been added to functions that compare elements within a single vector, such as `vec_unique()`, and across multiple vectors, such as `vec_match()`. When multiple encodings are encountered, a translation to UTF-8 is performed before any comparisons are made (#600, #553). * Equality and ordering methods are now implemented for raw and complex vectors (@romainfrancois). # vctrs 0.2.1 Maintenance release for CRAN checks. # vctrs 0.2.0 With the 0.2.0 release, many vctrs functions have been rewritten with native C code to improve performance. Functions like `vec_c()` and `vec_rbind()` should now be fast enough to be used in packages. This is an ongoing effort, for instance the handling of factors and dates has not been rewritten yet. These classes still slow down vctrs primitives. The API in 0.2.0 has been updated, please see a list of breaking changes below. vctrs has now graduated from experimental to a maturing package (see the [lifecycle of tidyverse packages](https://www.tidyverse.org/lifecycle/)). Please note that API changes are still planned for future releases, for instance `vec_ptype2()` and `vec_cast()` might need to return a sentinel instead of failing with an error when there is no common type or possible cast. ## Breaking changes * Lossy casts now throw errors of type `vctrs_error_cast_lossy`. Previously these were warnings. You can suppress these errors selectively with `allow_lossy_cast()` to get the partial cast results. To implement your own lossy cast operation, call the new exported function `maybe_lossy_cast()`. * `vec_c()` now fails when an input is supplied with a name but has internal names or is length > 1: ``` vec_c(foo = c(a = 1)) #> Error: Can't merge the outer name `foo` with a named vector. #> Please supply a `.name_spec` specification. vec_c(foo = 1:3) #> Error: Can't merge the outer name `foo` with a vector of length > 1. #> Please supply a `.name_spec` specification. ``` You can supply a name specification that describes how to combine the external name of the input with its internal names or positions: ``` # Name spec as glue string: vec_c(foo = c(a = 1), .name_spec = "{outer}_{inner}") # Name spec as a function: vec_c(foo = c(a = 1), .name_spec = function(outer, inner) paste(outer, inner, sep = "_")) vec_c(foo = c(a = 1), .name_spec = ~ paste(.x, .y, sep = "_")) ``` * `vec_empty()` has been renamed to `vec_is_empty()`. * `vec_dim()` and `vec_dims()` are no longer exported. * `vec_na()` has been renamed to `vec_init()`, as the primary use case is to initialize an output container. * `vec_slice<-` is now type stable (#140). It always returns the same type as the LHS. If needed, the RHS is cast to the correct type, but only if both inputs are coercible. See examples in `?vec_slice`. * We have renamed the `type` particle to `ptype`: - `vec_type()` => `vec_ptype()` - `vec_type2()` => `vec_ptype2()` - `vec_type_common()` => `vec_ptype_common()` Consequently, `vec_ptype()` was renamed to `vec_ptype_show()`. ## New features * New `vec_proxy()` generic. This is the main customisation point in vctrs along with `vec_restore()`. You should only implement it when your type is designed around a non-vector class (atomic vectors, bare lists, data frames). In this case, `vec_proxy()` should return such a vector class. The vctrs operations will be applied on the proxy and `vec_restore()` is called to restore the original representation of your type. The most common case where you need to implement `vec_proxy()` is for S3 lists. In vctrs, S3 lists are treated as scalars by default. This way we don't treat objects like model fits as vectors. To prevent vctrs from treating your S3 list as a scalar, unclass it from the `vec_proxy()` method. For instance here is the definition for `list_of`: ``` #' @export vec_proxy.vctrs_list_of <- function(x) { unclass(x) } ``` If you inherit from `vctrs_vctr` or `vctrs_rcrd` you don't need to implement `vec_proxy()`. * `vec_c()`, `vec_rbind()`, and `vec_cbind()` gain a `.name_repair` argument (#227, #229). * `vec_c()`, `vec_rbind()`, `vec_cbind()`, and all functions relying on `vec_ptype_common()` now have more informative error messages when some of the inputs have nested data frames that are not convergent: ``` df1 <- tibble(foo = tibble(bar = tibble(x = 1:3, y = letters[1:3]))) df2 <- tibble(foo = tibble(bar = tibble(x = 1:3, y = 4:6))) vec_rbind(df1, df2) #> Error: No common type for `..1$foo$bar$y` and `..2$foo$bar$y` . ``` * `vec_cbind()` now turns named data frames to packed columns. ```r data <- tibble::tibble(x = 1:3, y = letters[1:3]) data <- vec_cbind(data, packed = data) data # A tibble: 3 x 3 x y packed$x $y 1 1 a 1 a 2 2 b 2 b 3 3 c 3 c ``` Packed data frames are nested in a single column. This makes it possible to access it through a single name: ```r data$packed # A tibble: 3 x 2 x y 1 1 a 2 2 b 3 3 c ``` We are planning to use this syntax more widely in the tidyverse. * New `vec_is()` function to check whether a vector conforms to a prototype and/or a size. Unlike `vec_assert()`, it doesn't throw errors but returns `TRUE` or `FALSE` (#79). Called without a specific type or size, `vec_assert()` tests whether an object is a data vector or a scalar. S3 lists are treated as scalars by default. Implement a `vec_is_vector()` for your class to override this property (or derive from `vctrs_vctr`). * New `vec_order()` and `vec_sort()` for ordering and sorting generalised vectors. * New `.names_to` parameter for `vec_rbind()`. If supplied, this should be the name of a column where the names of the inputs are copied. This is similar to the `.id` parameter of `dplyr::bind_rows()`. * New `vec_seq_along()` and `vec_init_along()` create useful sequences (#189). * `vec_slice()` now preserves character row names, if present. * New `vec_split(x, by)` is a generalisation of `split()` that can divide a vector into groups formed by the unique values of another vector. Returns a two-column data frame containing unique values of `by` aligned with matching `x` values (#196). ## Other features and bug fixes * Using classed errors of class `"vctrs_error_assert"` for failed assertions, and of class `"vctrs_error_incompatible"` (with subclasses `_type`, `_cast` and `_op`) for errors on incompatible types (#184). * Character indexing is now only supported for named objects, an error is raised for unnamed objects (#171). * Predicate generics now consistently return logical vectors when passed a `vctrs_vctr` class. They used to restore the output to their input type (#251). * `list_of()` now has an `as.character()` method. It uses `vec_ptype_abbr()` to collapse complex objects into their type representation (tidyverse/tidyr#654). * New `stop_incompatible_size()` to signal a failure due to mismatched sizes. * New `validate_list_of()` (#193). * `vec_arith()` is consistent with base R when combining `difftime` and `date`, with a warning if casts are lossy (#192). * `vec_c()` and `vec_rbind()` now handle data.frame columns properly (@yutannihilation, #182). * `vec_cast(x, data.frame())` preserves the number of rows in `x`. * `vec_equal()` now handles missing values symmetrically (#204). * `vec_equal_na()` now returns `TRUE` for data frames and records when every component is missing, not when _any_ component is missing (#201). * `vec_init()` checks input is a vector. * `vec_proxy_compare()` gains an experimental `relax` argument, which allows data frames to be orderable even if all their columns are not (#210). * `vec_size()` now works with positive short row names. This fixes issues with data frames created with jsonlite (#220). * `vec_slice<-` now has a `vec_assign()` alias. Use `vec_assign()` when you don't want to modify the original input. * `vec_slice()` now calls `vec_restore()` automatically. Unlike the default `[` method from base R, attributes are preserved by default. * `vec_slice()` can correct slice 0-row data frames (#179). * New `vec_repeat()` for repeating each element of a vector the same number of times. * `vec_type2(x, data.frame())` ensures that the returned object has names that are a length-0 character vector. vctrs/MD50000644000176200001440000004205113623552332011731 0ustar liggesusers99a0e367cc4f512f3fd2746a2d9f04e5 *DESCRIPTION 519091b5c6a1ffa4a0b2e1e487838333 *NAMESPACE d3e023f9e34c2f3a60f94b5ac5499e9e *NEWS.md 073d0fec29db69ce086f977d3f2deab0 *R/aaa.R f24fdf599a553075c2161da61e7b21f9 *R/arith.R 821bc974426c8aef3aade4acc0df885e *R/assert.R 395f5c4b536ffa6109e2d50cb2d1eb0e *R/bind.R 1228eea366bb9ee40ca41ef08a3381fa *R/c.R 355f145d25808bb4a834a43b53ce0113 *R/cast-list.R 786c626a0756d1cbea1de44d99ea0da6 *R/cast.R 924b151e67ded67702c421a6500cef16 *R/compare.R e5a9676fa2b27c9a20ed34b04731c271 *R/compat-friendly-type.R bf3266e842b5b0d6684b38f7ba65a8a4 *R/compat-lifecycle.R de569e3f582fc5f58bc85d8431862990 *R/compat-purrr.R 672f20db29558b621b946a7329f017f2 *R/conditions.R 4a9c897debe47a2b5ad301534e5de08d *R/dictionary.R 18c64d8fad2faed59dc6d7f0f4965214 *R/dim.R 1e74817cacd388889db65d54ad173145 *R/equal.R 23e1082e791534d5f3d88a606451fb86 *R/faq-internal.R 4086555f3ef197850db758371ae41269 *R/fields.R 7691b0d44ac74d49e49074e9eb64e20a *R/group.R a87a8c656a676bfb84d33e1a0f5e824e *R/hash.R 6eca05e9a6683db963e8ff46a1667361 *R/names.R f7499283d96888b9d16364b093ac1785 *R/numeric.R 1131bc73ca0a7c97fa0be8a3322b3001 *R/partial-factor.R 93111f18f86631672fb6a6e4815cb6b1 *R/partial-frame.R 5cc21adde5ab342255b064f6041e7480 *R/partial.R 175f75d2c101f0749857227826b25d00 *R/print-str.R bf2419c3fe256a0696b8153af08d1712 *R/proxy.R 1f299ec681489c02cf4d9df35fba476c *R/ptype-abbr-full.R 593f661ee7cd79a8b0a79940621478cd *R/recycle.R 257646c425728c1f386cd704e40af728 *R/register-s3.R 43bd917d58086dd6b3dcb30be4ea6723 *R/shape.R fe6df37676b26dbf2f9f0f5d73879f1b *R/size.R 27c73c99c970325a8e6a22d0634f770c *R/slice.R c72562ee46d73df4a048ad64d02a174a *R/split.R 821b0189a18ff8f5af2cac0ded571a3f *R/subscript-loc.R 6b5dcc64b9108526531adc4749cf1b33 *R/subscript.R 74a1e08ee616a3e7eeae0fe31504cb47 *R/translate.R a959588327cf8aae88ea648939f15410 *R/type-bare.R 576b8bb6e3e912cc7a2070a6d9124245 *R/type-data-frame.R 3fbaeb913f1fa999ab1f9d671d06ce6d *R/type-date-time.R 1bc366ed2f22e61411c9023903952a4f *R/type-explore.R 4d2299c7f4949f91dc7cf7f552fd878e *R/type-factor.R 99757f8c75166c3df5d3047df703e2b9 *R/type-integer64.R 891ea33cbd3e8bb7e99fece900016b86 *R/type-list-of.R 0de3fc29d16d70897569f73259647f13 *R/type-rcrd.R 5f3abd93050255499756203ed4b8a068 *R/type-sclr.R 15cfcd6bed6112e168c10cdb9e7972dc *R/type-tibble.R c780d99394542516a1f74b1a094d26a6 *R/type-unspecified.R 4ebabf8012dcd1ed860d076a688de9e6 *R/type-vctr.R 22dec9517888db68bcd6e47a9fd1fb12 *R/type.R 131983735cd16cf0cd0994cb193ea2d9 *R/type2.R 6137f151be3f347f7585f08fe722db83 *R/utils-cli.R 237965a873baf978c4d3dbc5b0a15ce4 *R/utils.R cbc416d71e48bb9101966d114bc14ae0 *R/vctrs-deprecated.R 81acb57324952b030368d6b415c5293a *R/vctrs-package.R a937b96122bbb3d37bb7e9dda96b27fd *R/zzz.R 3ffc7f959befa5c6038c1e0baa47815a *README.md 18ac4dfa35812f358e89309620d754bb *build/vctrs.pdf 24e97b966e474304b12b3ee5fc98dcde *build/vignette.rds 43cc81e569685f0ede8af83150d4f016 *inst/WORDLIST af6a32ba40398d740d1e5e94c403dad4 *inst/doc/s3-vector.R 2c0036bddd3316e60d77dffaa3e9b2bc *inst/doc/s3-vector.Rmd 1fb295a36f758338eebdc995dbcc542f *inst/doc/s3-vector.html dda5255498cca0e7c956ed3243c1ab03 *inst/doc/stability.R f427b4ce01d21dd6c69c47b829046fb0 *inst/doc/stability.Rmd 142d48d55517d8fb035b5316d4017678 *inst/doc/stability.html 7a558b9e6f5c7c028c23f6a1d05fff80 *inst/doc/type-size.R 0c4748f3ccb8c39265c488dd72a30b23 *inst/doc/type-size.Rmd ccb11d987876b26b4f7b90adf4410c1e *inst/doc/type-size.html 4ed0bccc44dc738456eb9998f6877d46 *inst/include/vctrs.c a3e900eda91fd972ec5d99fde07a2771 *inst/include/vctrs.h 72a2c002010ef7e88e3346d667b301f3 *man/faq/internal/ptype2-identity.Rmd a2b83aa8a8a13a57d4973128290dac28 *man/faq/internal/setup.Rmd 856c670ccf80ab0a433a5a1a172b313d *man/fields.Rd 69eb638d262c60d5bd5ed2aa4717190c *man/figures/cast.png f5627d4a9d3071aad2dec7dbd3d33eca *man/figures/coerce.png e01d20997a9c8d069ef28e3c6013bd8c *man/figures/combined.png cb1e46f469cfbbbde29c8b5113e1d789 *man/figures/lifecycle-archived.svg c0d2e5a54f1fa4ff02bf9533079dd1f7 *man/figures/lifecycle-defunct.svg a1b8c987c676c16af790f563f96cbb1f *man/figures/lifecycle-deprecated.svg c3978703d8f40f2679795335715e98f4 *man/figures/lifecycle-experimental.svg 952b59dc07b171b97d5d982924244f61 *man/figures/lifecycle-maturing.svg 27b879bf3677ea76e3991d56ab324081 *man/figures/lifecycle-questioning.svg 6902bbfaf963fbc4ed98b86bda80caa2 *man/figures/lifecycle-soft-deprecated.svg 53b3f893324260b737b3c46ed2a0e643 *man/figures/lifecycle-stable.svg e544367a961afd79dd37cfb81e5c1e96 *man/figures/logo.png 25e2f330cc7176f22ad3cc5a3ba4dc22 *man/figures/sizes-recycling.png ff7dec2d166e669c6b6abf085030f369 *man/figures/sizes.graffle 793b22af8f7b1648699748172cab8af7 *man/figures/types.graffle adb03fe5026bdbf0027002f12f8792d5 *man/int64.Rd 6120ad57460012aad2d26fb5685f8c8e *man/internal-faq-ptype2-identity.Rd 48d2b594f60de376d1cc50c98cd1fbdd *man/list_of.Rd e757844d97713018184a26a825899583 *man/name_spec.Rd 9c6b5f7936d7994b3e344d9157dca4de *man/new_data_frame.Rd 781828969a1267da4214db1284d464ac *man/new_date.Rd 285f3760e64b15ab85c32c57449a44ab *man/new_factor.Rd 4b83a08a6ed1055066d2860e552b8b46 *man/new_list_of.Rd c6a03e41c3903a18e9854af7ef2fa21d *man/new_partial.Rd 2e120b4d9514537061f20984e5f5056a *man/new_rcrd.Rd bffe5bb720b78ad18f114e4a5854f59d *man/new_vctr.Rd 0432b9bc77e37a36a76ba1f65697ea6e *man/obj_print.Rd 4bd8924e7585671c5f2995ca1fcb8578 *man/op-empty-default.Rd 68cfef37046b5db7409bbb39073eb09e *man/partial_factor.Rd a8d87e8e584fda4a44214f7820ce5050 *man/partial_frame.Rd 90a06b93139afa5a323009b5de3d0d66 *man/s3_register.Rd 4e63ab2855b8925c8c47c60d0e9e9f73 *man/unspecified.Rd db06074cba4ea07e595edeb0f726ead0 *man/vctrs-conditions.Rd 8e9482ee838d343a6377ec216e1af25c *man/vctrs-package.Rd 41aec7be7b1c7722937983d2fdf1b8e3 *man/vec_arith.Rd 9319f7299408ddeee7cc82bda4a8e1cf *man/vec_as_index.Rd dce9f0bc180f127212ca06ba5ab30b70 *man/vec_as_location.Rd e9bd6a85720fddb13672191fed9d73a3 *man/vec_as_names.Rd 4751d9e1734abce229836322b3cd18ec *man/vec_as_names_legacy.Rd 8427b25490f821f461df7335441a0f68 *man/vec_as_subscript.Rd b52ecc53674292d5ea4035b5e1b8f082 *man/vec_assert.Rd a408b5c5a5f637c72b4cfba7e217deb5 *man/vec_bind.Rd 5fe129f8b0e93d2f92fb5b356f1418df *man/vec_c.Rd 5a134a296e1450be914bcbb8b42d22a8 *man/vec_cast.Rd 46d36fba0d33e2e4ad096c020285485a *man/vec_chop.Rd c31febcfda12e7856573b815f4d29a63 *man/vec_compare.Rd bfea5e87095b79f0d765e7100f8e7bd2 *man/vec_count.Rd 0629203674e604e0f535b887406064f9 *man/vec_data.Rd 4b6e6797488918af2c230af71597e266 *man/vec_default_cast.Rd b574f4aee7dbeba02e70a7740ab01c06 *man/vec_duplicate.Rd be220e3c31e4ecee79039f5f3318d0cc *man/vec_empty.Rd 62aafa8f2f043126ed85448c9bde4884 *man/vec_equal.Rd 613ce755fcbe7787e4a67a52937b89aa *man/vec_group.Rd 045a81d5ab49765cee703bd31c0b7958 *man/vec_init.Rd 73177ab53b67f4ac9ee624b0b6282b69 *man/vec_is_list.Rd 63b8dd27a1038d248082a77cffcd25e8 *man/vec_list_cast.Rd 509e7a00e5c5415ffdb23b9a81a1d8fa *man/vec_match.Rd 6584719eab2934f2eb8ad6ba208cba46 *man/vec_math.Rd b0a30dd8da85965b862f7d0843eaa1b1 *man/vec_order.Rd 8df0817a95a4e3ce7496a6c5e6ba0340 *man/vec_proxy_compare.Rd 0dbef82ea8c7281353f620c047d88b75 *man/vec_proxy_equal.Rd 5952a2f7ddce9128cfd1111b054a4a1c *man/vec_ptype.Rd 103363406e85db4cdd333c4e3571068f *man/vec_ptype2.Rd a18e1e8a4de3bbc54a65d7dec9633418 *man/vec_ptype_full.Rd ad35eb3a6c2190ee8790c533d009cce1 *man/vec_recycle.Rd 0e604eb7132e3b3b79491cb0fc42d1dd *man/vec_repeat.Rd 998136cc73dfd5148c60699abd8424f0 *man/vec_seq_along.Rd 4b5277861dd586804c5ef445e3b40a0f *man/vec_size.Rd 9be38d3e14302601e7dc56b3691a1f17 *man/vec_slice.Rd 6eb9a14de2750b0a272e15d44ed0def9 *man/vec_split.Rd 08227be2da6402ff398d9efd5a6dcbdd *man/vec_type.Rd e182c12caa98af31d87452e51526f9c8 *man/vec_unique.Rd eee79a244bba0e6d6cd3b33620f7daa9 *src/altrep-rle.c 7778ea1eaa4e80b6e428d3471b74210c *src/altrep-rle.h 993790dcfe2e59077558851576f9323b *src/altrep.h cecc47bfb851e9c797b914052b1e6dfa *src/arg-counter.c 217330a15f240d476d5651f1079f8afd *src/arg-counter.h 596c0866edf2dada3676092eb34c742c *src/arg.c aab0f383185a93b08cc38f0e359a36c9 *src/arg.h 43976335816594fbdbfe552455d8c66e *src/bind.c 88868300a66ed9eebc910a314afacbe6 *src/c.c 07098a5fd4a2be5fb8f85d06979529b3 *src/cast-dispatch.c 194b6106aa59aa190f7f4a44ee1ae2dc *src/cast.c 9f69f805d5cfa7689734b318d707ec8f *src/compare.c f9a96a6db44e67c0a8b6a80d4375c0d8 *src/conditions.c 8492d045dd8183d6ca6eca58c7aea3d8 *src/dictionary.c c42bd27efd8ce29a3f7e66852014d550 *src/dictionary.h ad881844dc7fb641301a4b24c87ad578 *src/equal.c aa7b46e86d9f60232d6e811237e68dde *src/fields.c 2c3a1f7a10603fed3b51bf08a680d20b *src/group.c 12dd3a8d05caf37435ed791482eb9588 *src/growable.c 5fa261683011f582f1d896aa1d612c7c *src/hash.c ddcd479c64c3bb2278d2c3346b4ce21f *src/init.c bdfd77ea0ba3750616fe2b2233f005c8 *src/names.c 1d70e576d71e305498b73475b5619992 *src/names.h e3d8276f28923abe8db801e273a7e61f *src/proxy-restore.c 4fd30957de1a6f3943e8500c244ac52c *src/proxy.c 2fcdf5ee0d06af4960bc62c41d60910e *src/ptype2-dispatch.c 8943670133d4c810868b7b461253097a *src/size-common.c 2010932f49b20a063effcc603262eba8 *src/size.c 413ca135238595bcde9be9d6c4662b4d *src/slice-array.c 7a1d8e5d33812680f131c938e4c45e62 *src/slice-assign.c 3e5df32daf7a6c22cfb3c735abd95e7b *src/slice-chop.c 3c2df59f00767a476a6577aa79c3ad4b *src/slice.c e03ad098cc3b32cfbaa9ef29b43d57e2 *src/slice.h a9b375713d95fa32bb1819c45ab9966c *src/split.c b0c99797023426f7ff83f5bccbd9f375 *src/subscript-loc.c 6634161ac480cfbf6550f97119bc154d *src/subscript-loc.h fa31116f61cad211871f0a086297b98e *src/translate.c ddef35ff8af4787aa4a5158ae7f5d559 *src/type-data-frame.c 5b87ab0b2396b4cc216d05bc88d52712 *src/type-data-frame.h ca6b69391b6759477d885b8037c4f91d *src/type-date-time.c 48facb8682cc7bfe02fc4613a3bf6954 *src/type-factor.c 73340db1017af351bda1d0538f31628c *src/type-info.c 53723c8d9944d4f257d8ec8b4c141950 *src/type-list-of.c 64c07722b989d66b7a61432190c88bb7 *src/type-tibble.c 39646618b3fa3da667e2a7d8ae7c8242 *src/type.c 3080457769e7337bcaa93419ca2b48a9 *src/type2.c d0e95044d2452f7aee5488717618428f *src/typeof2-s3.c c8430c6b42c571e81bc588ae84762d4e *src/typeof2.c 4901d7959405016388fae3e813ccd361 *src/unspecified.c 0d5c24477f0a3beb519ecb0fef5b62cf *src/utils-dispatch.c 89970b9091c298f668ddd6509f0fe852 *src/utils.c 0483439b574cf4da7beff8cfc1731e34 *src/utils.h a7cb296e217b1230013ae28952ce615c *src/vctrs.h 36298abc8bb1476f930ae3c5cfe46ffe *tests/testthat.R 9025ca276fe3762d7974bf65cc5809be *tests/testthat/error/test-c.txt b2dc78f8f305955afaad1cc4ee91e3c5 *tests/testthat/error/test-conditions.txt ed1d822b8324b7299569583bd05e679f *tests/testthat/error/test-recycle.txt 291c4ec50029439c4bd0679d58bdcd95 *tests/testthat/error/test-slice-assign.txt ed7187f1b06b5c445e83752b7c6c90eb *tests/testthat/error/test-slice.txt 7d7068906eecb74bd99a41d5fd36e37a *tests/testthat/error/test-subscript-loc.txt 22ffcf5f77c277ba0fbeb1afdcc9bae3 *tests/testthat/error/test-subscript.txt dbaddd2cc47dd9d09dc1cd128d38ca15 *tests/testthat/helper-c.R 65b2760f1948df30498f331c2fd86a02 *tests/testthat/helper-cast.R babc74df9458b9fe8ed1a01d369d21ca *tests/testthat/helper-conditions.R 76c635db233174b0c228e30b12b09ce3 *tests/testthat/helper-encoding.R a027a67e16c0898b12c24665d8065356 *tests/testthat/helper-expectations.R b0c833310272df9b6b9cf757e9caa8b9 *tests/testthat/helper-output.R a67eb912c0aa334688b40283db6f5a11 *tests/testthat/helper-rational.R 97e06ed40ebf80a3af0adf03dd6033b4 *tests/testthat/helper-s3.R dc794d40870fcdfc375b93ad91a6854d *tests/testthat/helper-size.R cb67eb59238b39ad812b2689cecefd70 *tests/testthat/helper-types.R 929027f6e4855c4afe03934201f233c2 *tests/testthat/out/vec-ptype-0.txt 6041399246127cb2c6b37821a37e4c0a *tests/testthat/out/vec-ptype-1.txt 3cdee079cea92524e4767807d4637d1e *tests/testthat/out/vec-ptype-2.txt a001c92c68abacc2b3678bdb1392eb3f *tests/testthat/out/vec-ptype-3.txt 7782440f6f43b13796a3e497555d313f *tests/testthat/output/bind-name-repair.txt 9c96b28198f3cae7e97a58c96ec2eae1 *tests/testthat/test-arith.R ac61494d9059b3f4a1dff1ab389e2c9d *tests/testthat/test-assert-explanations.txt 065f31e4c968dace5eb82290d76b68fd *tests/testthat/test-assert.R 5e1377f54ce555cf67065734c12e05ff *tests/testthat/test-bind.R bf3ef738e168633df193d118467f7eba *tests/testthat/test-c.R aa628ed9c1aa15431763b9c546d224db *tests/testthat/test-cast-error-nested.txt db299801ced286c5b7f5394d38e01640 *tests/testthat/test-cast-list.R dbe035ffdcbfebfb12318014ba258f5c *tests/testthat/test-cast.R be253964ae53bb535bf5e0ee0a9412b2 *tests/testthat/test-compare.R 2746058cc49ecb6e8aa677a5b9932231 *tests/testthat/test-conditions.R 64227e6e443f2e96e3fad4f95206e892 *tests/testthat/test-dictionary.R ac2b7cbb67b3066ad11f23fcca5d09da *tests/testthat/test-dim.R 0c8725efab3eb32b8096a23fae3941ed *tests/testthat/test-empty.R 385402f9482b29ef50ce52b0920d4cee *tests/testthat/test-equal.R 1b2e54222838e9300ea2439ce5b5ccb4 *tests/testthat/test-fields.R 84d08df9436f1f531ec746e26d5b33c3 *tests/testthat/test-group.R 543408eef52312f76a20d50b95aa3c1e *tests/testthat/test-hash-hash.txt 95d955cecff964db955f8fa206c67f5d *tests/testthat/test-hash.R 1b694f12efdb5fcca52101e1d2721361 *tests/testthat/test-lifecycle-deprecated.R f9fe97611639e49dc50a46bee23d915e *tests/testthat/test-list_of-print.txt 4bcfd8ed7c141308a0764999e185cdd9 *tests/testthat/test-list_of-str-empty.txt 3e8821e1f513884c455ae501899c14cb *tests/testthat/test-list_of-str.txt 8d40169d77a512b45e61d1945f57f996 *tests/testthat/test-list_of-type.txt a0f22eb1f4e8a477ec6fcd82f1792c06 *tests/testthat/test-names.R 785215aa7995fa73407d47e5d1a0048b *tests/testthat/test-partial-factor-print-both.txt 7505e7573c3547f6a2ed243b1f6e4132 *tests/testthat/test-partial-factor-print-empty.txt cf5b3b8c13928ec842f3d5f422f7124f *tests/testthat/test-partial-factor-print-learned.txt d07918475ff7f310bb6ae3435c3a3fb0 *tests/testthat/test-partial-factor-print-partial.txt 5c567a496590cfa2be5c8d1ff8e02a31 *tests/testthat/test-partial-factor.R 5c33c00aa55262152308c627371c3500 *tests/testthat/test-partial-frame-print.txt d677850b41c4b452dfb7798ad31667f0 *tests/testthat/test-partial-frame.R f47c9cf5606d4451dd7420ef72e9b57b *tests/testthat/test-print-str-attr.txt fb04ada072f03e54b0135ce6622d14e3 *tests/testthat/test-print-str-mtcars.txt 10e262d1d03bf0e4d433c2b2591a0ce4 *tests/testthat/test-print-str.R a57eb77a262fb405014fd6cb17b378c2 *tests/testthat/test-proxy-restore.R 4433dab6e0ab50a424fd8a80377de0e0 *tests/testthat/test-proxy.R d919faee1836fa43135712e6984f18dc *tests/testthat/test-ptype-abbr-full.R 52c9290f522b6a450741f11d03d07c0f *tests/testthat/test-rcrd-format.txt bd0adb7178e9d69081dc973bf4bf8264 *tests/testthat/test-recycle.R c81119483f19f1298b51e5a2fa97102e *tests/testthat/test-shape-print.txt 4913569b0d37509961750105ebee0dd5 *tests/testthat/test-shape.R 4ba0f17c5735a5c1697c76596d996de3 *tests/testthat/test-size.R d031313328498252667bd60b955e0429 *tests/testthat/test-slice-assign.R a60e22cfbf93962f71e3eda625948777 *tests/testthat/test-slice.R e9dff536036ed8c761649b52413fe2d2 *tests/testthat/test-split.R 186f42acfa2f247f071d34e671a19ea1 *tests/testthat/test-subscript-loc.R 701f80525eb710a9aae966889b97c5b2 *tests/testthat/test-subscript.R 440d4e5573c89ee88062e869dc01416a *tests/testthat/test-translate.R 83ef203808ee293130778f30a10966b5 *tests/testthat/test-type-bare.R cfbfdc0627caf2d7b8a3b00a54316835 *tests/testthat/test-type-data-frame-embedded.txt 441aa7a3dcb68a071ac6e5e24dce6fc8 *tests/testthat/test-type-data-frame.R 5e47fbd58ccf6d80ad64562ac7504066 *tests/testthat/test-type-data-frame.txt 7ec43b7daaa46844475d89ea209a0517 *tests/testthat/test-type-date-time.R f795b221de83dbbc5c3add632db18264 *tests/testthat/test-type-date-time.txt 39e114661df046a67c398081ae9c1cf4 *tests/testthat/test-type-factor.R ece1b7198e31c938df834f1e20b76094 *tests/testthat/test-type-factor.txt 46842fad3e4dbba1fdc190c4602defd6 *tests/testthat/test-type-group-rle.txt dee8e80b79a1bbc1a754ccf21db8e71f *tests/testthat/test-type-integer64.R da564e32ae8407e526ba4b85b889a465 *tests/testthat/test-type-list-of.R 9fccc613b072ff668cd3b32a94563168 *tests/testthat/test-type-rational.R 4237639833d6504b22ed8ed81f2cb795 *tests/testthat/test-type-rcrd.R 26daa1a57b855a0aef55ad4844e00304 *tests/testthat/test-type-sclr.R 3b37cd6e91ac753c0c1cb7b643a9baa2 *tests/testthat/test-type-tibble.R 085be32f5fc074c795fb8c3d03d0b883 *tests/testthat/test-type-unspecified.R 6301d24246251a8d40cc03c41f393038 *tests/testthat/test-type-unspecified.txt 466fa6b0b8a22151eefd4dd280cb4ec7 *tests/testthat/test-type-vctr.R 7a77ad6cfe432b6848dd4523cff6f4bd *tests/testthat/test-type-vec-c-error.txt 636d51dc67b54f9e982e06d893deeed7 *tests/testthat/test-type-vec-size-common-error.txt 4ee7c967b2654a2c16af5de3571d265a *tests/testthat/test-type-vec-type-common-error.txt f6a59b2f120703201099df8c7752350e *tests/testthat/test-type.R 5f6287e95e56c05f8c6acb69f0c22da9 *tests/testthat/test-type2-error-messages.txt 5907713ef351796ffe92495b29641ecb *tests/testthat/test-type2.R 60e429f9a5fe38018fd3c7d03ef1d929 *tests/testthat/test-type2.txt f39f144d032e574adeba3dcf0f2b308a *tests/testthat/test-utils.R bcf4a0cda7d861e924cba4a7c3b75722 *tests/testthat/test-vctr-print-names.txt f04a12e223a1d31f957df65a40f660d5 *tests/testthat/test-vctr-print.txt 7b3e372bb0d34650ae853d483a4afa39 *tests/testthat/test-vctrs.R 2c0036bddd3316e60d77dffaa3e9b2bc *vignettes/s3-vector.Rmd f427b4ce01d21dd6c69c47b829046fb0 *vignettes/stability.Rmd 0c4748f3ccb8c39265c488dd72a30b23 *vignettes/type-size.Rmd vctrs/inst/0000755000176200001440000000000013623213405012367 5ustar liggesusersvctrs/inst/doc/0000755000176200001440000000000013623213405013134 5ustar liggesusersvctrs/inst/doc/s3-vector.html0000644000176200001440000033313713623213400015654 0ustar liggesusers S3 vectors

S3 vectors

This vignette shows you how to create your own S3 vector classes. It focuses on the aspects of making a vector class that every class needs to worry about; you’ll also need to provide methods that actually make the vector useful.

I assume that you’re already familiar with the basic machinery of S3, and the vocabulary I use in Advanced R: constructor, helper, and validator. If not, I recommend reading at least the first two sections of the S3 chapter of Advanced R.

library(vctrs)
library(zeallot)

This vignette works through five big topics:

  • The basics of creating a new vector class with vctrs.
  • The coercion and casting system.
  • The record and list-of types.
  • Equality and comparison proxies.
  • Arithmetic operators.

They’re collectively demonstrated with a number of simple S3 classes:

  • Percent: a double vector that prints as a percentage. This illustrates the basic mechanics of class creation, coercion, and casting.

  • Decimal: a double vector that always prints with a fixed number of decimal places. This class has an attribute which needs a little extra care in casts and coercions.

  • Cached sum: a double vector that caches the total sum in an attribute. The attribute depends on the data, so needs extra care.

  • Rational: a pair of integer vectors that defines a rational number like 2 / 3. This introduces you to the record style, and to the equality and comparison operators. It also needs special handling for +, -, and friends.

  • Polynomial: a list of integer vectors that define polynomials like 1 + x - x^3. Sorting such vectors correctly requires a custom equality method.

  • Meter: a numeric vector with meter units. This is the simplest possible class with interesting algebraic properties.

  • Period and frequency: a pair of classes represent a period, or it’s inverse, frequency. This allows us to explore more arithmetic operators.

Basics

In this section you’ll learn how to create a new vctrs class by calling new_vctr(). This creates an object with class vctrs_vctr which has a number of methods. These are designed to make your life as easy as possible. For example:

  • The print() and str() methods are defined in terms of format() so you get a pleasant, consistent display as soon as you’ve made your format() method.

  • You can immediately put your new vector class in a data frame because as.data.frame.vctrs_vctr() does the right thing.

  • Subsetting ([, [[, and $), length<-, and rep() methods automatically preserve attributes because they use vec_restore(). A default vec_restore() works for all classes where the attributes are data-independent, and can easily be customised when the attributes do depend on the data.

  • Default subset-assignment methods ([<-, [[<-, and $<-) follow the principle that the new values should be coerced to match the existing vector. This gives predictable behaviour and clear error messages.

Percent class

In this section, I’ll show you how to make a percent class, i.e., a double vector that is printed as a percentage. We start by defining a low-level constructor that uses vec_assert() to checks types and/or sizes then calls new_vctr().

percent is built on a double vector of any length and doesn’t have any attributes.

new_percent <- function(x = double()) {
  vec_assert(x, double())
  new_vctr(x, class = "vctrs_percent")
}

x <- new_percent(c(seq(0, 1, length = 4), NA))
x
#> <vctrs_percent[5]>
#> [1] 0.0000000 0.3333333 0.6666667 1.0000000        NA

str(x)
#>  vctrs_pr [1:5] 0.0000000, 0.3333333, 0.6666667, 1.0000000,        NA

Note that we prefix the name of the class with the name of the package. This prevents conflicting definitions between packages. For packages that implement only one class (such as blob), it’s fine to use the package name without prefix as the class name.

We then follow up with a user friendly helper. Here we’ll use vec_cast() to allow it to accept anything coercible to a double:

percent <- function(x = double()) {
  x <- vec_cast(x, double())
  new_percent(x)
}

Before you go on, check that user-friendly constructor returns a zero-length vector when called with no arguments. This makes it easy to use as a prototype.

new_percent()
#> <vctrs_percent[0]>
percent()
#> <vctrs_percent[0]>

Add a call to setOldClass() for compatibility with the S4 system:

#' @importFrom methods setOldClass
methods::setOldClass(c("vctrs_percent", "vctrs_vctr"))

For the convenience of your users, consider implementing an is_percent() function:

is_percent <- function(x) {
  inherits(x, "vctrs_percent")
}

format() method

The first method for every class should almost always be a format() method. This should return a character vector the same length as x. The easiest way to do this is to rely on one of R’s low-level formatting functions like formatC():

format.vctrs_percent <- function(x, ...) {
  out <- formatC(signif(vec_data(x) * 100, 3))
  out[is.na(x)] <- NA
  out[!is.na(x)] <- paste0(out[!is.na(x)], "%")
  out
}
x
#> <vctrs_percent[5]>
#> [1] 0%    33.3% 66.7% 100%  <NA>

(Note the use of vec_data() so format() doesn’t get stuck in an infinite loop, and that I take a little care to not convert NA to "NA"; this leads to better printing.)

The format method is also used by data frames, tibbles, and str():

data.frame(x)
#>       x
#> 1    0%
#> 2 33.3%
#> 3 66.7%
#> 4  100%
#> 5  <NA>

For optimal display, I recommend also defining an abbreviated type name, which should be 4-5 letters for commonly used vectors. This is used in tibbles and in str():

vec_ptype_abbr.vctrs_percent <- function(x, ...) {
  "prcnt"
}

tibble::tibble(x)
#> # A tibble: 5 x 1
#>         x
#>   <prcnt>
#> 1      0%
#> 2   33.3%
#> 3   66.7%
#> 4    100%
#> 5      NA

str(x)
#>  prcnt [1:5] 0%, 33.3%, 66.7%, 100%, <NA>

If you need more control over printing in tibbles, implement a method for pillar::pillar_shaft(). See https://tibble.tidyverse.org/articles/extending.html for details.

Casting and coercion

The next set of methods you are likely to need are those related to coercion and casting. Coercion and casting are two sides of the same coin: changing the prototype of an existing object. When the change happens implicitly (e.g in c()) we call it coercion; when the change happens explicitly (e.g. with as.integer(x)), we call it casting.

One of the main goals of vctrs is to put coercion and casting on a robust theoretical footing so it’s possible to make accurate predictions about what (e.g.) c(x, y) should do when x and y have different prototypes. vctrs achieves this goal through two generics:

  • vec_ptype2(x, y) defines possible set of coercions. It returns a prototype if x and y can be safely coerced to the same prototype; otherwise it returns an error. The set of automatic coercions is usually quite small because too many tend to make code harder to reason about and silently propagate mistakes.

  • vec_cast(x, to) defines the possible sets of casts. It returns x translated to have prototype to, or throws an error if the conversion isn’t possible. The set of possible casts is a superset of possible coercions because they’re requested explicitly.

Double dispatch

Both generics use double dispatch which means that the implementation is selected based on the class of two arguments, not just one. S3 does not natively support double dispatch, but we can implement with a trick: doing single dispatch twice. In practice, this means you end up with method names with two classes, like vec_ptype2.foo.bar(), and you need a little boilerplate to get started. The key idea that makes double dispatch work without any modifications to S3 is that a function (like vec_ptype2.foo()) can be both an S3 generic and an S3 method.

vec_ptype2.MYCLASS <- function(x, y, ...) UseMethod("vec_ptype2.MYCLASS", y)
vec_ptype2.MYCLASS.default <- function(x, y, ..., x_arg = "x", y_arg = "y") {
  vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg)
}

vec_cast.MYCLASS <- function(x, to, ...) UseMethod("vec_cast.MYCLASS")
vec_cast.MYCLASS.default <- function(x, to, ...) vec_default_cast(x, to)

We’ll discuss what this boilerplate does in the upcoming sections; just remember you’ll always need to copy and paste it when creating a new S3 class.

Percent class

We’ll make our percent class coercible back and forth with double vectors. I’ll start with the boilerplate for vec_ptype2():

vec_ptype2.vctrs_percent <- function(x, y, ...) UseMethod("vec_ptype2.vctrs_percent", y)
vec_ptype2.vctrs_percent.default <- function(x, y, ..., x_arg = "x", y_arg = "y") {
  vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg)
}

The default method provides a user friendly error message if the coercion doesn’t exist and makes sure NA is handled in a standard way. NA is technically a logical vector, but we want to stand in for a missing value of any type.

vec_ptype2("bogus", percent())
#> Error: No common type for `x` <character> and `y` <vctrs_percent>.
vec_ptype2(percent(), NA)
#> <vctrs_percent[0]>
vec_ptype2(NA, percent())
#> <vctrs_percent[0]>

Next, start by saying that a vctrs_percent combined with a vctrs_percent yields a vctrs_percent, which we indicate by returning a prototype generated by the constructor.

vec_ptype2.vctrs_percent.vctrs_percent <- function(x, y, ...) new_percent()

Next we define methods that say that combining a percent and double should yield a double. We avoid returning a percent here because errors in the scale (1 vs. 0.01) are more obvious with raw numbers.

Because double dispatch is a bit of a hack, we need to provide two methods. It’s your responsibility to ensure that each pair return the same result: if they don’t you will get weird and unpredictable behaviour.

vec_ptype2.vctrs_percent.double <- function(x, y, ...) double()
vec_ptype2.double.vctrs_percent <- function(x, y, ...) double()

We can check that we’ve implemented this correctly with vec_ptype_show():

vec_ptype_show(percent(), double(), percent())
#> Prototype: <double>
#> 0. (                 , <vctrs_percent> ) = <vctrs_percent>
#> 1. ( <vctrs_percent> , <double>        ) = <double>       
#> 2. ( <double>        , <vctrs_percent> ) = <double>

Next we implement explicit casting, again starting with the boilerplate:

vec_cast.vctrs_percent <- function(x, to, ...) UseMethod("vec_cast.vctrs_percent")
vec_cast.vctrs_percent.default <- function(x, to, ...) vec_default_cast(x, to)

Then providing a method to coerce a percent to a percent:

vec_cast.vctrs_percent.vctrs_percent <- function(x, to, ...) x

And then for converting back and forth between doubles. To convert a double to a percent we use the percent() helper (not the constructor; this is unvalidated user input). To convert a percent to a double, we strip the attributes.

vec_cast.vctrs_percent.double <- function(x, to, ...) percent(x)
vec_cast.double.vctrs_percent <- function(x, to, ...) vec_data(x)

Then we can check this works with vec_cast():

vec_cast(0.5, percent())
#> <vctrs_percent[1]>
#> [1] 50%
vec_cast(percent(0.5), double())
#> [1] 0.5

Once you’ve implemented vec_ptype2() and vec_cast() you get vec_c(), [<-, and [[<- implementations for free.

vec_c(percent(0.5), 1)
#> [1] 0.5 1.0
vec_c(NA, percent(0.5))
#> <vctrs_percent[2]>
#> [1] <NA> 50%
# but
vec_c(TRUE, percent(0.5))
#> Error: No common type for `..1` <logical> and `..2` <vctrs_percent>.

x <- percent(c(0.5, 1, 2))
x[1:2] <- 2:1
#> Error: No common type for `x` <integer> and `value` <vctrs_percent>.
x[[3]] <- 0.5
x
#> <vctrs_percent[3]>
#> [1] 50%  100% 50%

You’ll also get mostly correct behaviour for c(). The exception is when you use c() with a base R class:

# Correct
c(percent(0.5), 1)
#> [1] 0.5 1.0
c(percent(0.5), factor(1))
#> Error: No common type for `..1` <vctrs_percent> and `..2` <factor<5b58e>>.

# Incorrect
c(factor(1), percent(0.5))
#> [1] 1.0 0.5

Unfortunately there’s no way to fix this problem with the current design of c().

Again, as a convenience, consider providing an as_percent() function that makes use of the casts defined in your vec_cast.vctrs_percent() methods:

as_percent <- function(x) {
  vec_cast(x, new_percent())
}

Decimal class

Now that you’ve seen the basics with a very simple S3 class, we’ll gradually explore more complicated scenarios. This section creates a decimal class that prints with the specified number of decimal places. This is very similar to percent but now the class needs an attribute: the number of decimal places to display (an integer vector of length 1).

We start of as before, defining a low-level constructor, a user-friendly constructor, a format() method, and a vec_ptype_abbr(). Note that additional object attributes are simply passed along to new_vctr():

new_decimal <- function(x = double(), digits = 2L) {
  vec_assert(x, ptype = double())
  vec_assert(digits, ptype = integer(), size = 1)

  new_vctr(x, digits = digits, class = "vctrs_decimal")
}

decimal <- function(x = double(), digits = 2L) {
  x <- vec_cast(x, double())
  digits <- vec_recycle(vec_cast(digits, integer()), 1L)

  new_decimal(x, digits = digits)
}

digits <- function(x) attr(x, "digits")

format.vctrs_decimal <- function(x, ...) {
  sprintf(paste0("%-0.", digits(x), "f"), x)
}

vec_ptype_abbr.vctrs_decimal <- function(x, ...) {
  paste0("dec")
}

x <- decimal(runif(10), 1L)
x
#> <vctrs_decimal[10]>
#>  [1] 0.1 0.8 0.6 0.2 0.0 0.5 0.5 0.3 0.7 0.8

Note that I provide a little helper to extract the digits attribute. This makes the code a little easier to read and should not be exported.

By default, vctrs assumes that attributes are independent of the data and so are automatically preserved. You’ll see what to do if the attributes are data dependent in the next section.

x[1:2]
#> <vctrs_decimal[2]>
#> [1] 0.1 0.8
x[[1]]
#> <vctrs_decimal[1]>
#> [1] 0.1

For the sake of exposition, we’ll assume that digits is an important attribute of the class and should be included in the full type:

vec_ptype_full.vctrs_decimal <- function(x, ...) {
  paste0("decimal<", digits(x), ">")
}

x
#> <decimal<1>[10]>
#>  [1] 0.1 0.8 0.6 0.2 0.0 0.5 0.5 0.3 0.7 0.8

Now consider vec_cast() and vec_ptype2(). I start with the standard recipes:

vec_ptype2.vctrs_decimal <- function(x, y, ...) UseMethod("vec_ptype2.vctrs_decimal", y)
vec_ptype2.vctrs_decimal.default <- function(x, y, ..., x_arg = "x", y_arg = "y") {
  vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg)
}

vec_cast.vctrs_decimal <- function(x, to, ...) UseMethod("vec_cast.vctrs_decimal")
vec_cast.vctrs_decimal.default <- function(x, to, ...) vec_default_cast(x, to)

Casting and coercing from one decimal to another requires a little thought as the values of the digits attribute might be different, and we need some way to reconcile them. Here I’ve decided to chose the maximum of the two; other reasonable options are to take the value from the left-hand side or throw an error.

vec_ptype2.vctrs_decimal.vctrs_decimal <- function(x, y, ...) {
  new_decimal(digits = max(digits(x), digits(y)))
}
vec_cast.vctrs_decimal.vctrs_decimal <- function(x, to, ...) {
  new_decimal(vec_data(x), digits = digits(to))
}

vec_c(decimal(1/100, digits = 3), decimal(2/100, digits = 2))
#> <decimal<3>[2]>
#> [1] 0.010 0.020

Finally, I can implement coercion to and from other types, like doubles. When automatically coercing, I choose the richer type (i.e., the decimal).

vec_ptype2.vctrs_decimal.double <- function(x, y, ...) x
vec_ptype2.double.vctrs_decimal <- function(x, y, ...) y

vec_cast.vctrs_decimal.double  <- function(x, to, ...) new_decimal(x, digits = digits(to))
vec_cast.double.vctrs_decimal  <- function(x, to, ...) vec_data(x)

vec_c(decimal(1, digits = 1), pi)
#> <decimal<1>[2]>
#> [1] 1.0 3.1
vec_c(pi, decimal(1, digits = 1))
#> <decimal<1>[2]>
#> [1] 3.1 1.0

If type x has greater resolution than y, there will be some inputs that lose precision. These should generate errors using stop_lossy_cast(). You can see that in action when casting from doubles to integers; only some doubles can become integers without losing resolution.

vec_cast(c(1, 2, 10), to = integer())
#> [1]  1  2 10

vec_cast(c(1.5, 2, 10.5), to = integer())
#> Error: Lossy cast from `x` <double> to `to` <integer>.
#> * Locations: 1, 3

Cached sum class

The next level up in complexity is an object that has data-dependent attributes. To explore this idea we’ll create a vector that caches the sum of its values. As usual, we start with low-level and user-friendly constructors:

new_cached_sum <- function(x = double(), sum = 0L) {
  vec_assert(x, ptype = double())
  vec_assert(sum, ptype = double(), size = 1L)

  new_vctr(x, sum = sum, class = "vctrs_cached_sum")
}

cached_sum <- function(x) {
  x <- vec_cast(x, double())
  new_cached_sum(x, sum(x))
}

For this class, we can use the default format() method, and instead, we’ll customise the obj_print_footer() method. This is a good place to display user facing attributes.

obj_print_footer.vctrs_cached_sum <- function(x, ...) {
  cat("# Sum: ", format(attr(x, "sum"), digits = 3), "\n", sep = "")
}

x <- cached_sum(runif(10))
x
#> <vctrs_cached_sum[10]>
#>  [1] 0.87460066 0.17494063 0.03424133 0.32038573 0.40232824 0.19566983
#>  [7] 0.40353812 0.06366146 0.38870131 0.97554784
#> # Sum: 3.83

We’ll also override sum() and mean() to use the attribute. This is easiest to do with vec_math(), which you’ll learn about later.

vec_math.vctrs_cached_sum <- function(.fn, .x, ...) {
  cat("Using cache\n")
  switch(.fn,
    sum = attr(.x, "sum"),
    mean = attr(.x, "sum") / length(.x),
    vec_math_base(.fn, .x, ...)
  )
}

sum(x)
#> Using cache
#> [1] 3.833615

As mentioned above, vctrs assumes that attributes are independent of the data. This means that when we take advantage of the default methods, they’ll work, but return the incorrect result:

x[1:2]
#> <vctrs_cached_sum[2]>
#> [1] 0.8746007 0.1749406
#> # Sum: 3.83

To fix this, you need to provide a vec_restore() method. Note that this method dispatches on the to argument.

vec_restore.vctrs_cached_sum <- function(x, to, ..., i = NULL) {
  new_cached_sum(x, sum(x))
}

x[1]
#> <vctrs_cached_sum[1]>
#> [1] 0.8746007
#> # Sum: 0.875

This works because most of the vctrs methods dispatch to the underlying base function by first stripping off extra attributes with vec_data() and then reapplying them again with vec_restore(). The default vec_restore() method copies over all attributes, which is not appropriate when the attributes depend on the data.

Note that vec_restore.class is subtly different from vec_cast.class.class(). vec_restore() is used when restoring attributes that have been lost; vec_cast() is used for coercions. This is easier to understand with a concrete example. Imagine factors were implemented with new_vctr(). vec_restore.factor() would restore attributes back to an integer vector, but you would not want to allow manually casting an integer to a factor with vec_cast().

Record-style objects

Record-style objects use a list of equal-length vectors to represent individual components of the object. The best example of this is POSIXlt, which underneath the hood is a list of 11 fields like year, month, and day. Record-style classes override length() and subsetting methods to conceal this implementation detail.

x <- as.POSIXlt(ISOdatetime(2020, 1, 1, 0, 0, 1:3))
x
#> [1] "2020-01-01 00:00:01 CET" "2020-01-01 00:00:02 CET"
#> [3] "2020-01-01 00:00:03 CET"

length(x)
#> [1] 3
length(unclass(x))
#> [1] 11

x[[1]] # the first date time
#> [1] "2020-01-01 00:00:01 CET"
unclass(x)[[1]] # the first component, the number of seconds
#> [1] 1 2 3

vctrs makes it easy to create new record-style classes using new_rcrd(), which has a wide selection of default methods.

Rational class

A fraction, or rational number, can be represented by a pair of integer vectors representing the numerator (the number on top) and the denominator (the number on bottom), where the length of each vector must be the same. To represent such a data structure we turn to a new base data type: the record (or rcrd for short).

As usual we start with low-level and user-friendly constructors. The low-level constructor calls new_rcrd(), which needs a named list of equal-length vectors.

new_rational <- function(n = integer(), d = integer()) {
  vec_assert(n, ptype = integer())
  vec_assert(d, ptype = integer())
  
  new_rcrd(list(n = n, d = d), class = "vctrs_rational")
}

Our user friendly constructor casts n and d to integers and recycles them to the same length.

rational <- function(n, d) {
  c(n, d) %<-% vec_cast_common(n, d, .to = integer())
  c(n, d) %<-% vec_recycle_common(n, d)
  
  new_rational(n, d)
}

x <- rational(1, 1:10)

Behind the scenes, x is a named list with two elements. But those details are hidden so that it behaves like a vector:

names(x)
#> NULL
length(x)
#> [1] 10

To access the underlying fields we need to use field() and fields():

fields(x)
#> [1] "n" "d"
field(x, "n")
#>  [1] 1 1 1 1 1 1 1 1 1 1

This allows us to create a format method:

format.vctrs_rational <- function(x, ...) {
  n <- field(x, "n")
  d <- field(x, "d")
  
  out <- paste0(n, "/", d)
  out[is.na(n) | is.na(d)] <- NA
  
  out
}

vec_ptype_abbr.vctrs_rational <- function(x, ...) "rtnl"
vec_ptype_full.vctrs_rational <- function(x, ...) "rational"

x
#> <rational[10]>
#>  [1] 1/1  1/2  1/3  1/4  1/5  1/6  1/7  1/8  1/9  1/10

vctrs uses the format() method in str(), hiding the underlying implementation details from the user:

str(x)
#>  rtnl [1:10] 1/1, 1/2, 1/3, 1/4, 1/5, 1/6, 1/7, 1/8, 1/9, 1/10

For rational, vec_ptype2() and vec_cast() follow the same pattern as percent(). I allow coercion from integer and to doubles.

vec_ptype2.vctrs_rational <- function(x, y, ...) UseMethod("vec_ptype2.vctrs_rational", y)
vec_ptype2.vctrs_rational.default <- function(x, y, ..., x_arg = "x", y_arg = "y") {
  vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg)
}
vec_ptype2.vctrs_rational.vctrs_rational <- function(x, y, ...) new_rational()
vec_ptype2.vctrs_rational.integer <- function(x, y, ...) new_rational()
vec_ptype2.integer.vctrs_rational <- function(x, y, ...) new_rational()

vec_cast.vctrs_rational <- function(x, to, ...) UseMethod("vec_cast.vctrs_rational")
vec_cast.vctrs_rational.default <- function(x, to, ...) vec_default_cast(x, to)
vec_cast.vctrs_rational.vctrs_rational <- function(x, to, ...) x
vec_cast.double.vctrs_rational <- function(x, to, ...) field(x, "n") / field(x, "d")
vec_cast.vctrs_rational.integer <- function(x, to, ...) rational(x, 1)

vec_c(rational(1, 2), 1L, NA)
#> <rational[3]>
#> [1] 1/2  1/1  <NA>

Decimal2 class

The previous implementation of decimal was built on top of doubles. This is a bad idea because decimal vectors are typically used when you care about precise values (i.e., dollars and cents in a bank account), and double values suffer from floating point problems.

A better implementation of a decimal class would be to use pair of integers, one for the value to the left of the decimal point, and the other for the value to the right (divided by a scale). The following code is a very quick sketch of how you might start creating such a class:

new_decimal2 <- function(l, r, scale = 2L) {
  vec_assert(l, ptype = integer())
  vec_assert(r, ptype = integer())
  vec_assert(scale, ptype = integer(), size = 1L)
  
  new_rcrd(list(l = l, r = r), scale = scale, class = "vctrs_decimal2")
}

decimal2 <- function(l, r, scale = 2L) {
  l <- vec_cast(l, integer())
  r <- vec_cast(r, integer())
  c(l, r) %<-% vec_recycle_common(l, r)
  scale <- vec_cast(scale, integer())
  
  # should check that r < 10^scale
  new_decimal2(l = l, r = r, scale = scale)
}

format.vctrs_decimal2 <- function(x, ...) {
  val <- field(x, "l") + field(x, "r") / 10^attr(x, "scale")
  sprintf(paste0("%.0", attr(x, "scale"), "f"), val)
}

decimal2(10, c(0, 5, 99))
#> <vctrs_decimal2[3]>
#> [1] 10.00 10.05 10.99

Equality and comparison

vctrs provides three “proxy” generics. Two of these let you control how your class determines equality and ordering:

  • vec_proxy_equal() returns a data vector suitable for comparison. It underpins ==, !=, unique(), anyDuplicated(), and is.na().

  • vec_proxy_compare() specifies how to compare the elements of your vector. This proxy is used in <, <=, >=, >, min(), max(), median(), quantile(), and xtfrm() (used in order() and sort()) methods.

By default, vec_proxy_equal() and vec_proxy_compare() just call vec_proxy().

  • vec_proxy() returns the actual data of a vector. This is useful when you store the data in a field of your class. Most of the time, you shouldn’t need to implement vec_proxy().

You should only implement these proxies when some preprocessing on the data is needed to make elements comparable. In that case, defining these methods will get you a lot of behaviour for relatively little work.

These proxy functions should always return a simple object (either a bare vector or a data frame) that possesses the same properties as your class. This permits efficient implementation of the vctrs internals because it allows dispatch to happen once in R, and then efficient computations can be written in C.

Rational class

Let’s explore these ideas by with the rational class we started on above. By default, vec_proxy() converts a record to a data frame, and the default comparison works column by column:

x <- rational(c(1, 2, 1, 2), c(1, 1, 2, 2))
x
#> <rational[4]>
#> [1] 1/1 2/1 1/2 2/2

vec_proxy(x)
#>   n d
#> 1 1 1
#> 2 2 1
#> 3 1 2
#> 4 2 2

x == rational(1, 1)
#> [1]  TRUE FALSE FALSE FALSE

This makes sense as a default but isn’t correct here because rational(1, 1) represents the same number as rational(2, 2), so they should be equal. We can fix that by implementing a vec_proxy_equal() method that divides n and d by their greatest common divisor:

# Thanks to Matthew Lundberg: https://stackoverflow.com/a/21504113/16632 
gcd <- function(x, y) {
  r <- x %% y
  ifelse(r, gcd(y, r), y)
}

vec_proxy_equal.vctrs_rational <- function(x, ...) {
  n <- field(x, "n")
  d <- field(x, "d")
  gcd <- gcd(n, d)
  
  data.frame(n = n / gcd, d = d / gcd)
}
vec_proxy(x)
#>   n d
#> 1 1 1
#> 2 2 1
#> 3 1 2
#> 4 2 2

x == rational(1, 1)
#> [1]  TRUE FALSE FALSE  TRUE

vec_proxy_equal() is also used by unique():

unique(x)
#> <rational[3]>
#> [1] 1/1 2/1 1/2

We now need to fix sort() similarly, since it currently sorts by n, then by d:

sort(x)
#> <rational[4]>
#> [1] 1/1 1/2 2/1 2/2

The easiest fix is to convert the fraction to a decimal and then sort that:

vec_proxy_compare.vctrs_rational <- function(x, ...) {
  field(x, "n") / field(x, "d")
}

sort(x)
#> <rational[4]>
#> [1] 1/2 1/1 2/2 2/1

(We could have used the same approach in vec_proxy_equal(), but when working with floating point numbers it’s not necessarily true that x == y implies that d * x == d * y.)

Polynomial class

A related problem occurs if we build our vector on top of a list. The following code defines a polynomial class that represents polynomials (like 1 + 3x - 2x^2) using a list of integer vectors (like c(1, 3, -2)). Note the use of new_list_of() in the constructor.

new_poly <- function(x) {
  new_list_of(x, ptype = integer(), class = "vctrs_poly")
}

poly <- function(...) {
  x <- list(...)
  x <- lapply(x, vec_cast, integer())
  new_poly(x)
}

vec_ptype_full.vctrs_poly <- function(x, ...) "polynomial"
vec_ptype_abbr.vctrs_poly <- function(x, ...) "poly"

format.vctrs_poly <- function(x, ...) {
  format_one <- function(x) {
    if (length(x) == 0) {
      return("")
    } else if (length(x) == 1) {
      format(x)
    } else {
      suffix <- c(paste0("\u22C5x^", seq(length(x) - 1, 1)), "")
      out <- paste0(x, suffix)
      out <- out[x != 0L]
      paste0(out, collapse = " + ")
    }
  }
  vapply(x, format_one, character(1))
}

obj_print_data.vctrs_poly <- function(x, ...) {
  if (length(x) == 0)
    return()
  print(format(x), quote = FALSE)
}

p <- poly(1, c(1, 0, 1), c(1, 0, 0, 0, 2))
p
#> <polynomial[3]>
#> [1] 1         1⋅x^2 + 1 1⋅x^4 + 2

The resulting objects will inherit from the vctrs_list_of class, which provides tailored methods for $, [[, the corresponding assignment operators, and other methods.

class(p)
#> [1] "vctrs_poly"    "vctrs_list_of" "vctrs_vctr"
p[2]
#> <polynomial[1]>
#> [1] 1⋅x^2 + 1
p[[2]]
#> [1] 1 0 1

Equality works out of the box because we can tell if two integer vectors are equal:

p == poly(c(1, 0, 1))
#> [1] FALSE  TRUE FALSE

But we can’t order them because lists are not comparable:

sort(p)
#> Error: Invalid type returned by `vec_proxy_compare()`.

So we need to define a vec_proxy_compare() method:

vec_proxy_compare.vctrs_poly <- function(x, ...) {
  x_raw <- vec_data(x)
  # First figure out the maximum length
  n <- max(vapply(x_raw, length, integer(1)))
  
  # Then expand all vectors to this length by filling in with zeros
  full <- lapply(x_raw, function(x) c(rep(0L, n - length(x)), x))
  
  # Then turn into a data frame
  as.data.frame(do.call(rbind, full))
}

sort(poly(3, 2, 1))
#> <polynomial[3]>
#> [1] 1 2 3
sort(poly(1, c(1, 0, 0), c(1, 0)))
#> <polynomial[3]>
#> [1] 1     1⋅x^1 1⋅x^2

Arithmetic

vctrs also provides two mathematical generics that allow you to define a broad swath of mathematical behaviour at once:

  • vec_math(fn, x, ...) specifies the behaviour of mathematical functions like abs(), sum(), and mean(). (See ?vec_math() for the complete list.)

  • vec_arith(op, x, y) specifies the behaviour of the arithmetic operations like +, -, and %%. (See ?vec_arith() for the complete list.)

Both generics define the behaviour for multiple functions because sum.vctrs_vctr(x) calls vec_math.vctrs_vctr("sum", x), and x + y calls vec_math.x_class.y_class("+", x, y). They’re accompanied by vec_math_base() and vec_arith_base() which make it easy to call the underlying base R functions.

vec_arith() uses double dispatch and needs the following standard boilerplate:

vec_arith.MYCLASS <- function(op, x, y, ...) {
  UseMethod("vec_arith.MYCLASS", y)
}
vec_arith.MYCLASS.default <- function(op, x, y, ...) {
  stop_incompatible_op(op, x, y)
}

Cached sum class

I showed an example of vec_math() to define sum() and mean() methods for cached_sum. Now let’s talk about exactly how it works. Most vec_math() functions will have a similar form. You use a switch statement to handle the methods that you care about and fall back to vec_math_base() for those that you don’t care about.

vec_math.vctrs_cached_sum <- function(.fn, .x, ...) {
  switch(.fn,
    sum = attr(.x, "sum"),
    mean = attr(.x, "sum") / length(.x),
    vec_math_base(.fn, .x, ...)
  )
}

Meter class

To explore the infix arithmetic operators exposed by vec_arith() I’ll create a new class that represents a measurement in meters:

new_meter <- function(x) {
  stopifnot(is.double(x))
  new_vctr(x, class = "vctrs_meter")
}

format.vctrs_meter <- function(x, ...) {
  paste0(format(vec_data(x)), " m")
}

meter <- function(x) {
  x <- vec_cast(x, double())
  new_meter(x)
}

x <- meter(1:10)
x
#> <vctrs_meter[10]>
#>  [1]  1 m  2 m  3 m  4 m  5 m  6 m  7 m  8 m  9 m 10 m

Because meter is built on top of a double vector, basic mathematic operations work:

sum(x)
#> <vctrs_meter[1]>
#> [1] 55 m
mean(x)
#> <vctrs_meter[1]>
#> [1] 5.5 m

But we can’t do arithmetic:

x + 1
#> Error: <vctrs_meter> + <double> is not permitted
meter(10) + meter(1)
#> Error: <vctrs_meter> + <vctrs_meter> is not permitted
meter(10) * 3
#> Error: <vctrs_meter> * <double> is not permitted

To allow these infix functions to work, we’ll need to provide vec_arith() generic. But before we do that, let’s think about what combinations of inputs we should support:

  • It makes sense to add and subtract meters: that yields another meter. We can divide a meter by another meter (yielding a unitless number), but we can’t multiply meters (because that would yield an area).

  • For a combination of meter and number multiplication and division by a number are acceptable. Addition and subtraction don’t make much sense as we, strictly speaking, are dealing with objects of different nature.

vec_arith() is another function that uses double dispatch, so as usual we start with a template.

vec_arith.vctrs_meter <- function(op, x, y, ...) {
  UseMethod("vec_arith.vctrs_meter", y)
}
vec_arith.vctrs_meter.default <- function(op, x, y, ...) {
  stop_incompatible_op(op, x, y)
}

Then write the method for two meter objects. We use a switch statement to cover the cases we care about and stop_incompatible_op() to throw an informative error message for everything else.

vec_arith.vctrs_meter.vctrs_meter <- function(op, x, y, ...) {
  switch(
    op,
    "+" = ,
    "-" = new_meter(vec_arith_base(op, x, y)),
    "/" = vec_arith_base(op, x, y),
    stop_incompatible_op(op, x, y)
  )
}

meter(10) + meter(1)
#> <vctrs_meter[1]>
#> [1] 11 m
meter(10) - meter(1)
#> <vctrs_meter[1]>
#> [1] 9 m
meter(10) / meter(1)
#> [1] 10
meter(10) * meter(1)
#> Error: <vctrs_meter> * <vctrs_meter> is not permitted

Next we write the pair of methods for arithmetic with a meter and a number. These are almost identical, but while meter(10) / 2 makes sense, 2 / meter(10) does not (and neither do addition and subtraction).

vec_arith.vctrs_meter.numeric <- function(op, x, y, ...) {
  switch(
    op,
    "/" = ,
    "*" = new_meter(vec_arith_base(op, x, y)),
    stop_incompatible_op(op, x, y)
  )
}
vec_arith.numeric.vctrs_meter <- function(op, x, y, ...) {
  switch(
    op,
    "*" = new_meter(vec_arith_base(op, x, y)),
    stop_incompatible_op(op, x, y)
  )
}

meter(2) * 10
#> <vctrs_meter[1]>
#> [1] 20 m
10 * meter(2) 
#> <vctrs_meter[1]>
#> [1] 20 m
meter(20) / 10
#> <vctrs_meter[1]>
#> [1] 2 m
10 / meter(20)
#> Error: <double> / <vctrs_meter> is not permitted
meter(20) + 10
#> Error: <vctrs_meter> + <double> is not permitted

For completeness, we also need vec_arith.vctrs_meter.MISSING for the unary + and - operators:

vec_arith.vctrs_meter.MISSING <- function(op, x, y, ...) {
  switch(op, 
    `-` = x * -1,
    `+` = x,
    stop_incompatible_op(op, x, y)
  )
}
-meter(1) 
#> <vctrs_meter[1]>
#> [1] -1 m
+meter(1) 
#> <vctrs_meter[1]>
#> [1] 1 m

Appendix: NAMESPACE declarations

Defining S3 methods interactively is fine for iteration and exploration, but if your vector lives in a package, you also need to register the S3 methods by listing them in the NAMESPACE file. The namespace declarations are a little tricky because (e.g.) vec_cast.vctrs_percent() is both a generic function (which must be exported with export()) and an S3 method (which must be registered with S3method()).

This problem wasn’t considered in the design of roxygen2, so you have to be quite explicit:

#' @method vec_cast vctrs_percent
#' @export
#' @export vec_cast.vctrs_percent
vec_cast.vctrs_percent <- function(x, to, ...) {
} 

You also need to register the individual double-dispatch methods. Again, this is harder than it should be because roxygen’s heuristics aren’t quite right. That means you need to describe the @method explicitly:

#' @method vec_cast.binned double
#' @export
vec_cast.binned.double <- function(x, y, ...) {
}

Hopefully future versions of roxygen will make these exports less painful.

vctrs/inst/doc/s3-vector.R0000644000176200001440000004147113623213376015122 0ustar liggesusers## ---- include = FALSE--------------------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) set.seed(1014) ## ----setup-------------------------------------------------------------------- library(vctrs) library(zeallot) ## ----------------------------------------------------------------------------- new_percent <- function(x = double()) { vec_assert(x, double()) new_vctr(x, class = "vctrs_percent") } x <- new_percent(c(seq(0, 1, length = 4), NA)) x str(x) ## ----------------------------------------------------------------------------- percent <- function(x = double()) { x <- vec_cast(x, double()) new_percent(x) } ## ----------------------------------------------------------------------------- new_percent() percent() ## ----------------------------------------------------------------------------- #' @importFrom methods setOldClass methods::setOldClass(c("vctrs_percent", "vctrs_vctr")) ## ----------------------------------------------------------------------------- is_percent <- function(x) { inherits(x, "vctrs_percent") } ## ----------------------------------------------------------------------------- format.vctrs_percent <- function(x, ...) { out <- formatC(signif(vec_data(x) * 100, 3)) out[is.na(x)] <- NA out[!is.na(x)] <- paste0(out[!is.na(x)], "%") out } ## ---- include = FALSE--------------------------------------------------------- # As of R 3.5, print.vctr can not find format.percent since it's not in # it's lexical environment. We fix that problem by manually registering. s3_register("base::format", "vctrs_percent") ## ----------------------------------------------------------------------------- x ## ----------------------------------------------------------------------------- data.frame(x) ## ----------------------------------------------------------------------------- vec_ptype_abbr.vctrs_percent <- function(x, ...) { "prcnt" } tibble::tibble(x) str(x) ## ----------------------------------------------------------------------------- vec_ptype2.MYCLASS <- function(x, y, ...) UseMethod("vec_ptype2.MYCLASS", y) vec_ptype2.MYCLASS.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } vec_cast.MYCLASS <- function(x, to, ...) UseMethod("vec_cast.MYCLASS") vec_cast.MYCLASS.default <- function(x, to, ...) vec_default_cast(x, to) ## ----------------------------------------------------------------------------- vec_ptype2.vctrs_percent <- function(x, y, ...) UseMethod("vec_ptype2.vctrs_percent", y) vec_ptype2.vctrs_percent.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } ## ---- include = FALSE--------------------------------------------------------- s3_register("vctrs::vec_ptype2", "vctrs_percent") ## ---- error = TRUE------------------------------------------------------------ vec_ptype2("bogus", percent()) vec_ptype2(percent(), NA) vec_ptype2(NA, percent()) ## ----------------------------------------------------------------------------- vec_ptype2.vctrs_percent.vctrs_percent <- function(x, y, ...) new_percent() ## ----------------------------------------------------------------------------- vec_ptype2.vctrs_percent.double <- function(x, y, ...) double() vec_ptype2.double.vctrs_percent <- function(x, y, ...) double() ## ----------------------------------------------------------------------------- vec_ptype_show(percent(), double(), percent()) ## ----------------------------------------------------------------------------- vec_cast.vctrs_percent <- function(x, to, ...) UseMethod("vec_cast.vctrs_percent") vec_cast.vctrs_percent.default <- function(x, to, ...) vec_default_cast(x, to) ## ---- include = FALSE--------------------------------------------------------- s3_register("vctrs::vec_cast", "vctrs_percent") ## ----------------------------------------------------------------------------- vec_cast.vctrs_percent.vctrs_percent <- function(x, to, ...) x ## ----------------------------------------------------------------------------- vec_cast.vctrs_percent.double <- function(x, to, ...) percent(x) vec_cast.double.vctrs_percent <- function(x, to, ...) vec_data(x) ## ----------------------------------------------------------------------------- vec_cast(0.5, percent()) vec_cast(percent(0.5), double()) ## ---- error = TRUE------------------------------------------------------------ vec_c(percent(0.5), 1) vec_c(NA, percent(0.5)) # but vec_c(TRUE, percent(0.5)) x <- percent(c(0.5, 1, 2)) x[1:2] <- 2:1 x[[3]] <- 0.5 x ## ---- error = TRUE------------------------------------------------------------ # Correct c(percent(0.5), 1) c(percent(0.5), factor(1)) # Incorrect c(factor(1), percent(0.5)) ## ----------------------------------------------------------------------------- as_percent <- function(x) { vec_cast(x, new_percent()) } ## ----------------------------------------------------------------------------- new_decimal <- function(x = double(), digits = 2L) { vec_assert(x, ptype = double()) vec_assert(digits, ptype = integer(), size = 1) new_vctr(x, digits = digits, class = "vctrs_decimal") } decimal <- function(x = double(), digits = 2L) { x <- vec_cast(x, double()) digits <- vec_recycle(vec_cast(digits, integer()), 1L) new_decimal(x, digits = digits) } digits <- function(x) attr(x, "digits") format.vctrs_decimal <- function(x, ...) { sprintf(paste0("%-0.", digits(x), "f"), x) } vec_ptype_abbr.vctrs_decimal <- function(x, ...) { paste0("dec") } x <- decimal(runif(10), 1L) x ## ----------------------------------------------------------------------------- x[1:2] x[[1]] ## ----------------------------------------------------------------------------- vec_ptype_full.vctrs_decimal <- function(x, ...) { paste0("decimal<", digits(x), ">") } x ## ----------------------------------------------------------------------------- vec_ptype2.vctrs_decimal <- function(x, y, ...) UseMethod("vec_ptype2.vctrs_decimal", y) vec_ptype2.vctrs_decimal.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } vec_cast.vctrs_decimal <- function(x, to, ...) UseMethod("vec_cast.vctrs_decimal") vec_cast.vctrs_decimal.default <- function(x, to, ...) vec_default_cast(x, to) ## ----------------------------------------------------------------------------- vec_ptype2.vctrs_decimal.vctrs_decimal <- function(x, y, ...) { new_decimal(digits = max(digits(x), digits(y))) } vec_cast.vctrs_decimal.vctrs_decimal <- function(x, to, ...) { new_decimal(vec_data(x), digits = digits(to)) } vec_c(decimal(1/100, digits = 3), decimal(2/100, digits = 2)) ## ----------------------------------------------------------------------------- vec_ptype2.vctrs_decimal.double <- function(x, y, ...) x vec_ptype2.double.vctrs_decimal <- function(x, y, ...) y vec_cast.vctrs_decimal.double <- function(x, to, ...) new_decimal(x, digits = digits(to)) vec_cast.double.vctrs_decimal <- function(x, to, ...) vec_data(x) vec_c(decimal(1, digits = 1), pi) vec_c(pi, decimal(1, digits = 1)) ## ---- error = TRUE------------------------------------------------------------ vec_cast(c(1, 2, 10), to = integer()) vec_cast(c(1.5, 2, 10.5), to = integer()) ## ----------------------------------------------------------------------------- new_cached_sum <- function(x = double(), sum = 0L) { vec_assert(x, ptype = double()) vec_assert(sum, ptype = double(), size = 1L) new_vctr(x, sum = sum, class = "vctrs_cached_sum") } cached_sum <- function(x) { x <- vec_cast(x, double()) new_cached_sum(x, sum(x)) } ## ----------------------------------------------------------------------------- obj_print_footer.vctrs_cached_sum <- function(x, ...) { cat("# Sum: ", format(attr(x, "sum"), digits = 3), "\n", sep = "") } x <- cached_sum(runif(10)) x ## ----------------------------------------------------------------------------- vec_math.vctrs_cached_sum <- function(.fn, .x, ...) { cat("Using cache\n") switch(.fn, sum = attr(.x, "sum"), mean = attr(.x, "sum") / length(.x), vec_math_base(.fn, .x, ...) ) } sum(x) ## ----------------------------------------------------------------------------- x[1:2] ## ----------------------------------------------------------------------------- vec_restore.vctrs_cached_sum <- function(x, to, ..., i = NULL) { new_cached_sum(x, sum(x)) } x[1] ## ----------------------------------------------------------------------------- x <- as.POSIXlt(ISOdatetime(2020, 1, 1, 0, 0, 1:3)) x length(x) length(unclass(x)) x[[1]] # the first date time unclass(x)[[1]] # the first component, the number of seconds ## ----------------------------------------------------------------------------- new_rational <- function(n = integer(), d = integer()) { vec_assert(n, ptype = integer()) vec_assert(d, ptype = integer()) new_rcrd(list(n = n, d = d), class = "vctrs_rational") } ## ----------------------------------------------------------------------------- rational <- function(n, d) { c(n, d) %<-% vec_cast_common(n, d, .to = integer()) c(n, d) %<-% vec_recycle_common(n, d) new_rational(n, d) } x <- rational(1, 1:10) ## ----------------------------------------------------------------------------- names(x) length(x) ## ----------------------------------------------------------------------------- fields(x) field(x, "n") ## ----------------------------------------------------------------------------- format.vctrs_rational <- function(x, ...) { n <- field(x, "n") d <- field(x, "d") out <- paste0(n, "/", d) out[is.na(n) | is.na(d)] <- NA out } vec_ptype_abbr.vctrs_rational <- function(x, ...) "rtnl" vec_ptype_full.vctrs_rational <- function(x, ...) "rational" x ## ----------------------------------------------------------------------------- str(x) ## ----------------------------------------------------------------------------- vec_ptype2.vctrs_rational <- function(x, y, ...) UseMethod("vec_ptype2.vctrs_rational", y) vec_ptype2.vctrs_rational.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } vec_ptype2.vctrs_rational.vctrs_rational <- function(x, y, ...) new_rational() vec_ptype2.vctrs_rational.integer <- function(x, y, ...) new_rational() vec_ptype2.integer.vctrs_rational <- function(x, y, ...) new_rational() vec_cast.vctrs_rational <- function(x, to, ...) UseMethod("vec_cast.vctrs_rational") vec_cast.vctrs_rational.default <- function(x, to, ...) vec_default_cast(x, to) vec_cast.vctrs_rational.vctrs_rational <- function(x, to, ...) x vec_cast.double.vctrs_rational <- function(x, to, ...) field(x, "n") / field(x, "d") vec_cast.vctrs_rational.integer <- function(x, to, ...) rational(x, 1) vec_c(rational(1, 2), 1L, NA) ## ----------------------------------------------------------------------------- new_decimal2 <- function(l, r, scale = 2L) { vec_assert(l, ptype = integer()) vec_assert(r, ptype = integer()) vec_assert(scale, ptype = integer(), size = 1L) new_rcrd(list(l = l, r = r), scale = scale, class = "vctrs_decimal2") } decimal2 <- function(l, r, scale = 2L) { l <- vec_cast(l, integer()) r <- vec_cast(r, integer()) c(l, r) %<-% vec_recycle_common(l, r) scale <- vec_cast(scale, integer()) # should check that r < 10^scale new_decimal2(l = l, r = r, scale = scale) } format.vctrs_decimal2 <- function(x, ...) { val <- field(x, "l") + field(x, "r") / 10^attr(x, "scale") sprintf(paste0("%.0", attr(x, "scale"), "f"), val) } decimal2(10, c(0, 5, 99)) ## ----------------------------------------------------------------------------- x <- rational(c(1, 2, 1, 2), c(1, 1, 2, 2)) x vec_proxy(x) x == rational(1, 1) ## ----------------------------------------------------------------------------- # Thanks to Matthew Lundberg: https://stackoverflow.com/a/21504113/16632 gcd <- function(x, y) { r <- x %% y ifelse(r, gcd(y, r), y) } vec_proxy_equal.vctrs_rational <- function(x, ...) { n <- field(x, "n") d <- field(x, "d") gcd <- gcd(n, d) data.frame(n = n / gcd, d = d / gcd) } vec_proxy(x) x == rational(1, 1) ## ----------------------------------------------------------------------------- unique(x) ## ----------------------------------------------------------------------------- sort(x) ## ----------------------------------------------------------------------------- vec_proxy_compare.vctrs_rational <- function(x, ...) { field(x, "n") / field(x, "d") } sort(x) ## ----------------------------------------------------------------------------- new_poly <- function(x) { new_list_of(x, ptype = integer(), class = "vctrs_poly") } poly <- function(...) { x <- list(...) x <- lapply(x, vec_cast, integer()) new_poly(x) } vec_ptype_full.vctrs_poly <- function(x, ...) "polynomial" vec_ptype_abbr.vctrs_poly <- function(x, ...) "poly" format.vctrs_poly <- function(x, ...) { format_one <- function(x) { if (length(x) == 0) { return("") } else if (length(x) == 1) { format(x) } else { suffix <- c(paste0("\u22C5x^", seq(length(x) - 1, 1)), "") out <- paste0(x, suffix) out <- out[x != 0L] paste0(out, collapse = " + ") } } vapply(x, format_one, character(1)) } obj_print_data.vctrs_poly <- function(x, ...) { if (length(x) == 0) return() print(format(x), quote = FALSE) } p <- poly(1, c(1, 0, 1), c(1, 0, 0, 0, 2)) p ## ----------------------------------------------------------------------------- class(p) p[2] p[[2]] ## ----------------------------------------------------------------------------- p == poly(c(1, 0, 1)) ## ---- error = TRUE------------------------------------------------------------ sort(p) ## ----------------------------------------------------------------------------- vec_proxy_compare.vctrs_poly <- function(x, ...) { x_raw <- vec_data(x) # First figure out the maximum length n <- max(vapply(x_raw, length, integer(1))) # Then expand all vectors to this length by filling in with zeros full <- lapply(x_raw, function(x) c(rep(0L, n - length(x)), x)) # Then turn into a data frame as.data.frame(do.call(rbind, full)) } sort(poly(3, 2, 1)) sort(poly(1, c(1, 0, 0), c(1, 0))) ## ----------------------------------------------------------------------------- vec_arith.MYCLASS <- function(op, x, y, ...) { UseMethod("vec_arith.MYCLASS", y) } vec_arith.MYCLASS.default <- function(op, x, y, ...) { stop_incompatible_op(op, x, y) } ## ----------------------------------------------------------------------------- vec_math.vctrs_cached_sum <- function(.fn, .x, ...) { switch(.fn, sum = attr(.x, "sum"), mean = attr(.x, "sum") / length(.x), vec_math_base(.fn, .x, ...) ) } ## ----------------------------------------------------------------------------- new_meter <- function(x) { stopifnot(is.double(x)) new_vctr(x, class = "vctrs_meter") } format.vctrs_meter <- function(x, ...) { paste0(format(vec_data(x)), " m") } meter <- function(x) { x <- vec_cast(x, double()) new_meter(x) } x <- meter(1:10) x ## ----------------------------------------------------------------------------- sum(x) mean(x) ## ---- error = TRUE------------------------------------------------------------ x + 1 meter(10) + meter(1) meter(10) * 3 ## ----------------------------------------------------------------------------- vec_arith.vctrs_meter <- function(op, x, y, ...) { UseMethod("vec_arith.vctrs_meter", y) } vec_arith.vctrs_meter.default <- function(op, x, y, ...) { stop_incompatible_op(op, x, y) } ## ---- error = TRUE------------------------------------------------------------ vec_arith.vctrs_meter.vctrs_meter <- function(op, x, y, ...) { switch( op, "+" = , "-" = new_meter(vec_arith_base(op, x, y)), "/" = vec_arith_base(op, x, y), stop_incompatible_op(op, x, y) ) } meter(10) + meter(1) meter(10) - meter(1) meter(10) / meter(1) meter(10) * meter(1) ## ---- error = TRUE------------------------------------------------------------ vec_arith.vctrs_meter.numeric <- function(op, x, y, ...) { switch( op, "/" = , "*" = new_meter(vec_arith_base(op, x, y)), stop_incompatible_op(op, x, y) ) } vec_arith.numeric.vctrs_meter <- function(op, x, y, ...) { switch( op, "*" = new_meter(vec_arith_base(op, x, y)), stop_incompatible_op(op, x, y) ) } meter(2) * 10 10 * meter(2) meter(20) / 10 10 / meter(20) meter(20) + 10 ## ----------------------------------------------------------------------------- vec_arith.vctrs_meter.MISSING <- function(op, x, y, ...) { switch(op, `-` = x * -1, `+` = x, stop_incompatible_op(op, x, y) ) } -meter(1) +meter(1) ## ----------------------------------------------------------------------------- #' @method vec_cast vctrs_percent #' @export #' @export vec_cast.vctrs_percent vec_cast.vctrs_percent <- function(x, to, ...) { } ## ----------------------------------------------------------------------------- #' @method vec_cast.binned double #' @export vec_cast.binned.double <- function(x, y, ...) { } vctrs/inst/doc/type-size.Rmd0000644000176200001440000003174113622451540015542 0ustar liggesusers--- title: "Prototypes and sizes" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Prototypes and sizes} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r setup, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` Rather than using `class()` and `length()`, vctrs has notions of prototype (`vec_ptype_show()`) and size (`vec_size()`). This vignette discusses the motivation for why these alternatives are necessary and connects their definitions to type coercion and the recycling rules. Size and prototype are motivated by thinking about the optimal behaviour for `c()` and `rbind()`, particularly inspired by data frames with columns that are matrices or data frames. ```{r} library(vctrs) ``` ## Prototype The idea of a prototype is to capture the metadata associated with a vector without capturing any data. Unfortunately, the `class()` of an object is inadequate for this purpose: * The `class()` doesn't include attributes. Attributes are important because, for example, they store the levels of a factor and the timezone of a `POSIXct`. You cannot combine two factors or two `POSIXct`s without thinking about the attributes. * The `class()` of a matrix is "matrix" and doesn't include the type of the underlying vector or the dimensionality. Instead, vctrs takes advantage of R's vectorised nature and uses a __prototype__, a 0-observation slice of the vector (this is basically `x[0]` but with some subtleties we'll come back to later). This is a miniature version of the vector that contains all of the attributes but none of the data. Conveniently, you can create many prototypes using existing base functions (e.g, `double()` and `factor(levels = c("a", "b"))`). vctrs provides a few helpers (e.g. `new_date()`, `new_datetime()`, and `new_duration()`) where the equivalents in base R are missing. ### Base prototypes `vec_ptype()` creates a prototype from an existing object. However, many base vectors have uninformative printing methods for 0-length subsets, so vctrs also provides `vec_ptype_show()`, which prints the prototype in a friendly way (and returns nothing). Using `vec_ptype_show()` allows us to see the prototypes base R classes: * Atomic vectors have no attributes and just display the underlying `typeof()`: ```{r} vec_ptype_show(FALSE) vec_ptype_show(1L) vec_ptype_show(2.5) vec_ptype_show("three") vec_ptype_show(list(1, 2, 3)) ``` * The prototype of matrices and arrays include the base type and the dimensions after the first: ```{r} vec_ptype_show(array(logical(), c(2, 3))) vec_ptype_show(array(integer(), c(2, 3, 4))) vec_ptype_show(array(character(), c(2, 3, 4, 5))) ``` * The prototype of a factor includes its levels. Levels are a character vector, which can be arbitrarily long, so the prototype just shows a hash. If the hash of two factors is equal, it's highly likely that their levels are also equal. ```{r} vec_ptype_show(factor("a")) vec_ptype_show(ordered("b")) ``` While `vec_ptype_show()` prints only the hash, the prototype object itself does contain all levels: ```{r} vec_ptype(factor("a")) ``` * Base R has three key date time classes: dates, date-times (`POSIXct`), and durations (`difftime)`. Date-times have a timezone, and durations have a unit. ```{r} vec_ptype_show(Sys.Date()) vec_ptype_show(Sys.time()) vec_ptype_show(as.difftime(10, units = "mins")) ``` * Data frames have the most complex prototype: the prototype of a data frame is the name and prototype of each column: ```{r} vec_ptype_show(data.frame(a = FALSE, b = 1L, c = 2.5, d = "x")) ``` Data frames can have columns that are themselves data frames, making this a "recursive" type: ```{r} df <- data.frame(x = FALSE) df$y <- data.frame(a = 1L, b = 2.5) vec_ptype_show(df) ``` ### Coercing to common type It's often important to combine vectors with multiple types. vctrs provides a consistent set of rules for coercion, via `vec_ptype_common()`. `vec_ptype_common()` possesses the following invariants: * `class(vec_ptype_common(x, y))` equals `class(vec_ptype_common(y, x))`. * `class(vec_ptype_common(x, vec_ptype_common(y, z))` equals `class(vec_ptype_common(vec_ptype_common(x, y), z))`. * `vec_ptype_common(x, NULL) == vec_ptype(x)`. i.e., `vec_ptype_common()` is both commutative and associative (with respect to class) and has an identity element, `NULL`; i.e., it's a __commutative monoid__. This means the underlying implementation is quite simple: we can find the common type of any number of objects by progressively finding the common type of pairs of objects. Like with `vec_ptype()`, the easiest way to explore `vec_ptype_common()` is with `vec_ptype_show()`: when given multiple inputs, it will print their common prototype. (In other words: program with `vec_ptype_common()` but play with `vec_ptype_show()`.) * The common type of atomic vectors is computed very similar to the rules of base R, except that we do not coerce to character automatically: ```{r, error = TRUE} vec_ptype_show(logical(), integer(), double()) vec_ptype_show(logical(), character()) ``` * Matrices and arrays are automatically broadcast to higher dimensions: ```{r} vec_ptype_show( array(1, c(0, 1)), array(1, c(0, 2)) ) vec_ptype_show( array(1, c(0, 1)), array(1, c(0, 3)), array(1, c(0, 3, 4)), array(1, c(0, 3, 4, 5)) ) ``` Provided that the dimensions follow the vctrs recycling rules: ```{r, error = TRUE} vec_ptype_show( array(1, c(0, 2)), array(1, c(0, 3)) ) ``` * Factors combine levels in the order in which they appear. ```{r} fa <- factor("a") fb <- factor("b") levels(vec_ptype_common(fa, fb)) levels(vec_ptype_common(fb, fa)) ``` * Combining a date and date-time yields a date-time: ```{r} vec_ptype_show(new_date(), new_datetime()) ``` When combining two date times, the timezone is taken from the first input: ```{r} vec_ptype_show( new_datetime(tzone = "US/Central"), new_datetime(tzone = "Pacific/Auckland") ) ``` Unless it's the local timezone, in which case any explicit time zone will win: ```{r} vec_ptype_show( new_datetime(tzone = ""), new_datetime(tzone = ""), new_datetime(tzone = "Pacific/Auckland") ) ``` * The common type of two data frames is the common type of each column that occurs in both data frames: ```{r} vec_ptype_show( data.frame(x = FALSE), data.frame(x = 1L), data.frame(x = 2.5) ) ``` And the union of the columns that only occur in one: ```{r} vec_ptype_show(data.frame(x = 1, y = 1), data.frame(y = 1, z = 1)) ``` Note that new columns are added on the right-hand side. This is consistent with the way that factor levels and time zones are handled. ### Casting to specified type `vec_ptype_common()` finds the common type of a set of vector. Typically, however, what you want is a set of vectors coerced to that common type. That's the job of `vec_cast_common()`: ```{r} str(vec_cast_common( FALSE, 1:5, 2.5 )) str(vec_cast_common( factor("x"), factor("y") )) str(vec_cast_common( data.frame(x = 1), data.frame(y = 1:2) )) ``` Alternatively, you can cast to a specific prototype using `vec_cast()`: ```{r, error = TRUE} # Cast succeeds vec_cast(c(1, 2), integer()) # Cast fails vec_cast(c(1.5, 2.5), factor("a")) ``` If a cast is possible in general (i.e., double -> integer), but information is lost for a specific input (e.g. 1.5 -> 1), it will generate an error. ```{r, error = TRUE} vec_cast(c(1.5, 2), integer()) ``` You can suppress the lossy cast errors with `allow_lossy_cast()`: ```{r} allow_lossy_cast( vec_cast(c(1.5, 2), integer()) ) ``` This will suppress all lossy cast errors. Supply prototypes if you want to be specific about the type of lossy cast allowed: ```{r} allow_lossy_cast( vec_cast(c(1.5, 2), integer()), x_ptype = double(), to_ptype = integer() ) ``` The set of casts is more permissive than the set of coercions and is summarised in the diagram below. Coercions are shown by arrows; possible casts are shown with circles. ```{r, echo = FALSE, fig.cap="Summary of vctrs casting rules"} knitr::include_graphics("../man/figures/combined.png", dpi = 300) ``` ## Size `vec_size()` was motivated by the need to have an invariant that describes the number of "observations" in a data structure. This is particularly important for data frames, as it's useful to have some function such that `f(data.frame(x))` equals `f(x)`. No base function has this property: * `length(data.frame(x))` equals `1` because the length of a data frame is the number of columns. * `nrow(data.frame(x))` does not equal `nrow(x)` because `nrow()` of a vector is `NULL`. * `NROW(data.frame(x))` equals `NROW(x)` for vector `x`, so is almost what we want. But because `NROW()` is defined in terms of `length()`, it returns a value for every object, even types that can't go in a data frame, e.g. `data.frame(mean)` errors even though `NROW(mean)` is `1`. We define `vec_size()` as follows: * It is the length of 1d vectors. * It is the number of rows of data frames, matrices, and arrays. * It throws error for non vectors. Given `vec_size()`, we can give a precise definition of a data frame: a data frame is a list of vectors where every vector has the same size. This has the desirable property of trivially supporting matrix and data frame columns. ### Slicing `vec_slice()` is to `vec_size()` as `[` is to `length()`; i.e., it allows you to select observations regardless of the dimensionality of the underlying object. `vec_slice(x, i)` is equivalent to: * `x[i]` when `x` is a vector. * `x[i, , drop = FALSE]` when `x` is a data frame. * `x[i, , , drop = FALSE]` when `x` is a 3d array. ```{r} x <- sample(1:10) df <- data.frame(x = x) vec_slice(x, 5:6) vec_slice(df, 5:6) ``` `vec_slice(data.frame(x), i)` equals `data.frame(vec_slice(x, i))` (modulo variable and row names). Prototypes are generated with `vec_slice(x, 0L)`; given a prototype, you can initialize a vector of given size (filled with `NA`s) with `vec_init()`. ### Common sizes: recycling rules Closely related to the definition of size are the __recycling rules__. The recycling rules determine the size of the output when two vectors of different sizes are combined. In vctrs, the recycling rules are encoded in `vec_size_common()`, which gives the common size of a set of vectors: ```{r} vec_size_common(1:3, 1:3, 1:3) vec_size_common(1:10, 1) vec_size_common(integer(), 1) ``` vctrs obeys a stricter set of recycling rules than base R. Vectors of size 1 are recycled to any other size. All other size combinations will generate an error. This strictness prevents common mistakes like `dest == c("IAH", "HOU"))`, at the cost of occasionally requiring an explicit calls to `rep()`. ```{r, echo = FALSE, fig.cap="Summary of vctrs recycling rules. X indicates n error"} knitr::include_graphics("../man/figures/sizes-recycling.png", dpi = 300) ``` You can apply the recycling rules in two ways: * If you have a vector and desired size, use `vec_recycle()`: ```{r} vec_recycle(1:3, 3) vec_recycle(1, 10) ``` * If you have multiple vectors and you want to recycle them to the same size, use `vec_recycle_common()`: ```{r} vec_recycle_common(1:3, 1:3) vec_recycle_common(1:10, 1) ``` ## Appendix: recycling in base R The recycling rules in base R are described in [The R Language Definition](https://cran.r-project.org/doc/manuals/r-release/R-lang.html#Recycling-rules) but are not implemented in a single function and thus are not applied consistently. Here, I give a brief overview of their most common realisation, as well as showing some of the exceptions. Generally, in base R, when a pair of vectors is not the same length, the shorter vector is recycled to the same length as the longer: ```{r} rep(1, 6) + 1 rep(1, 6) + 1:2 rep(1, 6) + 1:3 ``` If the length of the longer vector is not an integer multiple of the length of the shorter, you usually get a warning: ```{r} invisible(pmax(1:2, 1:3)) invisible(1:2 + 1:3) invisible(cbind(1:2, 1:3)) ``` But some functions recycle silently: ```{r} length(atan2(1:3, 1:2)) length(paste(1:3, 1:2)) length(ifelse(1:3, 1:2, 1:2)) ``` And `data.frame()` throws an error: ```{r, error = TRUE} data.frame(1:2, 1:3) ``` The R language definition states that "any arithmetic operation involving a zero-length vector has a zero-length result". But outside of arithmetic, this rule is not consistently followed: ```{r, error = TRUE} # length-0 output 1:2 + integer() atan2(1:2, integer()) pmax(1:2, integer()) # dropped cbind(1:2, integer()) # recycled to length of first ifelse(rep(TRUE, 4), integer(), character()) # preserved-ish paste(1:2, integer()) # Errors data.frame(1:2, integer()) ``` vctrs/inst/doc/stability.R0000644000176200001440000001146213623213401015263 0ustar liggesusers## ---- include = FALSE--------------------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ## ----setup-------------------------------------------------------------------- library(vctrs) library(zeallot) ## ----------------------------------------------------------------------------- vec_ptype_show(median(c(1L, 1L))) vec_ptype_show(median(c(1L, 1L, 1L))) ## ----------------------------------------------------------------------------- vec_ptype_show(sapply(1L, function(x) c(x, x))) vec_ptype_show(sapply(integer(), function(x) c(x, x))) ## ----------------------------------------------------------------------------- vec_ptype_show(c(NA, Sys.Date())) vec_ptype_show(c(Sys.Date(), NA)) ## ----------------------------------------------------------------------------- env <- new.env(parent = emptyenv()) length(env) length(mean) length(c(env, mean)) ## ----------------------------------------------------------------------------- vec_ptype_show(ifelse(NA, 1L, 1L)) vec_ptype_show(ifelse(FALSE, 1L, 1L)) ## ----------------------------------------------------------------------------- c(FALSE, 1L, 2.5) ## ----------------------------------------------------------------------------- vec_c(FALSE, 1L, 2.5) ## ---- error = TRUE------------------------------------------------------------ c(FALSE, "x") vec_c(FALSE, "x") c(FALSE, list(1)) vec_c(FALSE, list(1)) ## ----------------------------------------------------------------------------- c(Sys.Date(), factor("x"), "x") ## ----------------------------------------------------------------------------- c(mean, globalenv()) ## ---- error = TRUE------------------------------------------------------------ vec_c(mean, globalenv()) vec_c(Sys.Date(), factor("x"), "x") ## ----------------------------------------------------------------------------- fa <- factor("a") fb <- factor("b") c(fa, fb) ## ----------------------------------------------------------------------------- vec_c(fa, fb) vec_c(fb, fa) ## ----------------------------------------------------------------------------- datetime_nz <- as.POSIXct("2020-01-01 09:00", tz = "Pacific/Auckland") c(datetime_nz) ## ----------------------------------------------------------------------------- vec_c(datetime_nz) ## ----------------------------------------------------------------------------- datetime_local <- as.POSIXct("2020-01-01 09:00") datetime_houston <- as.POSIXct("2020-01-01 09:00", tz = "US/Central") vec_c(datetime_local, datetime_houston, datetime_nz) vec_c(datetime_houston, datetime_nz) vec_c(datetime_nz, datetime_houston) ## ----------------------------------------------------------------------------- date <- as.Date("2020-01-01") datetime <- as.POSIXct("2020-01-01 09:00") c(date, datetime) c(datetime, date) ## ----------------------------------------------------------------------------- vec_c(date, datetime) vec_c(date, datetime_nz) ## ----------------------------------------------------------------------------- c(NA, fa) c(NA, date) c(NA, datetime) ## ----------------------------------------------------------------------------- vec_c(NA, fa) vec_c(NA, date) vec_c(NA, datetime) ## ----------------------------------------------------------------------------- df1 <- data.frame(x = 1) df2 <- data.frame(x = 2) str(c(df1, df1)) ## ----------------------------------------------------------------------------- vec_c(df1, df2) ## ----------------------------------------------------------------------------- m <- matrix(1:4, nrow = 2) c(m, m) vec_c(m, m) ## ----------------------------------------------------------------------------- c(m, 1) vec_c(m, 1) ## ---- eval = FALSE------------------------------------------------------------ # vec_c <- function(...) { # args <- compact(list2(...)) # # ptype <- vec_ptype_common(!!!args) # if (is.null(ptype)) # return(NULL) # # ns <- map_int(args, vec_size) # out <- vec_init(ptype, sum(ns)) # # pos <- 1 # for (i in seq_along(ns)) { # n <- ns[[i]] # # x <- vec_cast(args[[i]], to = ptype) # vec_slice(out, pos:(pos + n - 1)) <- x # pos <- pos + n # } # # out # } ## ----------------------------------------------------------------------------- if_else <- function(test, yes, no) { vec_assert(test, logical()) c(yes, no) %<-% vec_cast_common(yes, no) c(test, yes, no) %<-% vec_recycle_common(test, yes, no) out <- vec_init(yes, vec_size(yes)) vec_slice(out, test) <- vec_slice(yes, test) vec_slice(out, !test) <- vec_slice(no, !test) out } x <- c(NA, 1:4) if_else(x > 2, "small", "big") if_else(x > 2, factor("small"), factor("big")) if_else(x > 2, Sys.Date(), Sys.Date() + 7) ## ----------------------------------------------------------------------------- if_else(x > 2, data.frame(x = 1), data.frame(y = 2)) if_else(x > 2, matrix(1:10, ncol = 2), cbind(30, 30)) vctrs/inst/doc/s3-vector.Rmd0000644000176200001440000010177613622451540015444 0ustar liggesusers--- title: "S3 vectors" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{S3 vectors} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) set.seed(1014) ``` This vignette shows you how to create your own S3 vector classes. It focuses on the aspects of making a vector class that every class needs to worry about; you'll also need to provide methods that actually make the vector useful. I assume that you're already familiar with the basic machinery of S3, and the vocabulary I use in Advanced R: constructor, helper, and validator. If not, I recommend reading at least the first two sections of [the S3 chapter](https://adv-r.hadley.nz/s3.html) of _Advanced R_. ```{r setup} library(vctrs) library(zeallot) ``` This vignette works through five big topics: * The basics of creating a new vector class with vctrs. * The coercion and casting system. * The record and list-of types. * Equality and comparison proxies. * Arithmetic operators. They're collectively demonstrated with a number of simple S3 classes: * Percent: a double vector that prints as a percentage. This illustrates the basic mechanics of class creation, coercion, and casting. * Decimal: a double vector that always prints with a fixed number of decimal places. This class has an attribute which needs a little extra care in casts and coercions. * Cached sum: a double vector that caches the total sum in an attribute. The attribute depends on the data, so needs extra care. * Rational: a pair of integer vectors that defines a rational number like `2 / 3`. This introduces you to the record style, and to the equality and comparison operators. It also needs special handling for `+`, `-`, and friends. * Polynomial: a list of integer vectors that define polynomials like `1 + x - x^3`. Sorting such vectors correctly requires a custom equality method. * Meter: a numeric vector with meter units. This is the simplest possible class with interesting algebraic properties. * Period and frequency: a pair of classes represent a period, or it's inverse, frequency. This allows us to explore more arithmetic operators. ## Basics In this section you'll learn how to create a new vctrs class by calling `new_vctr()`. This creates an object with class `vctrs_vctr` which has a number of methods. These are designed to make your life as easy as possible. For example: * The `print()` and `str()` methods are defined in terms of `format()` so you get a pleasant, consistent display as soon as you've made your `format()` method. * You can immediately put your new vector class in a data frame because `as.data.frame.vctrs_vctr()` does the right thing. * Subsetting (`[`, `[[`, and `$`), `length<-`, and `rep()` methods automatically preserve attributes because they use `vec_restore()`. A default `vec_restore()` works for all classes where the attributes are data-independent, and can easily be customised when the attributes do depend on the data. * Default subset-assignment methods (`[<-`, `[[<-`, and `$<-`) follow the principle that the new values should be coerced to match the existing vector. This gives predictable behaviour and clear error messages. ### Percent class In this section, I'll show you how to make a `percent` class, i.e., a double vector that is printed as a percentage. We start by defining a low-level [constructor](https://adv-r.hadley.nz/s3.html#s3-constrcutor) that uses `vec_assert()` to checks types and/or sizes then calls `new_vctr()`. `percent` is built on a double vector of any length and doesn't have any attributes. ```{r} new_percent <- function(x = double()) { vec_assert(x, double()) new_vctr(x, class = "vctrs_percent") } x <- new_percent(c(seq(0, 1, length = 4), NA)) x str(x) ``` Note that we prefix the name of the class with the name of the package. This prevents conflicting definitions between packages. For packages that implement only one class (such as [blob](https://blob.tidyverse.org/)), it's fine to use the package name without prefix as the class name. We then follow up with a user friendly [helper](https://adv-r.hadley.nz/s3.html#helpers). Here we'll use `vec_cast()` to allow it to accept anything coercible to a double: ```{r} percent <- function(x = double()) { x <- vec_cast(x, double()) new_percent(x) } ``` Before you go on, check that user-friendly constructor returns a zero-length vector when called with no arguments. This makes it easy to use as a prototype. ```{r} new_percent() percent() ``` Add a call to `setOldClass()` for compatibility with the S4 system: ```{r} #' @importFrom methods setOldClass methods::setOldClass(c("vctrs_percent", "vctrs_vctr")) ``` For the convenience of your users, consider implementing an `is_percent()` function: ```{r} is_percent <- function(x) { inherits(x, "vctrs_percent") } ``` ### `format()` method The first method for every class should almost always be a `format()` method. This should return a character vector the same length as `x`. The easiest way to do this is to rely on one of R's low-level formatting functions like `formatC()`: ```{r} format.vctrs_percent <- function(x, ...) { out <- formatC(signif(vec_data(x) * 100, 3)) out[is.na(x)] <- NA out[!is.na(x)] <- paste0(out[!is.na(x)], "%") out } ``` ```{r, include = FALSE} # As of R 3.5, print.vctr can not find format.percent since it's not in # it's lexical environment. We fix that problem by manually registering. s3_register("base::format", "vctrs_percent") ``` ```{r} x ``` (Note the use of `vec_data()` so `format()` doesn't get stuck in an infinite loop, and that I take a little care to not convert `NA` to `"NA"`; this leads to better printing.) The format method is also used by data frames, tibbles, and `str()`: ```{r} data.frame(x) ``` For optimal display, I recommend also defining an abbreviated type name, which should be 4-5 letters for commonly used vectors. This is used in tibbles and in `str()`: ```{r} vec_ptype_abbr.vctrs_percent <- function(x, ...) { "prcnt" } tibble::tibble(x) str(x) ``` If you need more control over printing in tibbles, implement a method for `pillar::pillar_shaft()`. See for details. ## Casting and coercion The next set of methods you are likely to need are those related to coercion and casting. Coercion and casting are two sides of the same coin: changing the prototype of an existing object. When the change happens _implicitly_ (e.g in `c()`) we call it __coercion__; when the change happens _explicitly_ (e.g. with `as.integer(x)`), we call it __casting__. One of the main goals of vctrs is to put coercion and casting on a robust theoretical footing so it's possible to make accurate predictions about what (e.g.) `c(x, y)` should do when `x` and `y` have different prototypes. vctrs achieves this goal through two generics: * `vec_ptype2(x, y)` defines possible set of coercions. It returns a prototype if `x` and `y` can be safely coerced to the same prototype; otherwise it returns an error. The set of automatic coercions is usually quite small because too many tend to make code harder to reason about and silently propagate mistakes. * `vec_cast(x, to)` defines the possible sets of casts. It returns `x` translated to have prototype `to`, or throws an error if the conversion isn't possible. The set of possible casts is a superset of possible coercions because they're requested explicitly. ### Double dispatch Both generics use __[double dispatch](https://en.wikipedia.org/wiki/Double_dispatch)__ which means that the implementation is selected based on the class of two arguments, not just one. S3 does not natively support double dispatch, but we can implement with a trick: doing single dispatch twice. In practice, this means you end up with method names with two classes, like `vec_ptype2.foo.bar()`, and you need a little boilerplate to get started. The key idea that makes double dispatch work without any modifications to S3 is that a function (like `vec_ptype2.foo()`) can be both an S3 generic and an S3 method. ```{r} vec_ptype2.MYCLASS <- function(x, y, ...) UseMethod("vec_ptype2.MYCLASS", y) vec_ptype2.MYCLASS.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } vec_cast.MYCLASS <- function(x, to, ...) UseMethod("vec_cast.MYCLASS") vec_cast.MYCLASS.default <- function(x, to, ...) vec_default_cast(x, to) ``` We'll discuss what this boilerplate does in the upcoming sections; just remember you'll always need to copy and paste it when creating a new S3 class. ### Percent class {#percent} We'll make our percent class coercible back and forth with double vectors. I'll start with the boilerplate for `vec_ptype2()`: ```{r} vec_ptype2.vctrs_percent <- function(x, y, ...) UseMethod("vec_ptype2.vctrs_percent", y) vec_ptype2.vctrs_percent.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } ``` ```{r, include = FALSE} s3_register("vctrs::vec_ptype2", "vctrs_percent") ``` The default method provides a user friendly error message if the coercion doesn't exist and makes sure `NA` is handled in a standard way. `NA` is technically a logical vector, but we want to stand in for a missing value of any type. ```{r, error = TRUE} vec_ptype2("bogus", percent()) vec_ptype2(percent(), NA) vec_ptype2(NA, percent()) ``` Next, start by saying that a `vctrs_percent` combined with a `vctrs_percent` yields a `vctrs_percent`, which we indicate by returning a prototype generated by the constructor. ```{r} vec_ptype2.vctrs_percent.vctrs_percent <- function(x, y, ...) new_percent() ``` Next we define methods that say that combining a `percent` and double should yield a `double`. We avoid returning a `percent` here because errors in the scale (1 vs. 0.01) are more obvious with raw numbers. Because double dispatch is a bit of a hack, we need to provide two methods. It's your responsibility to ensure that each pair return the same result: if they don't you will get weird and unpredictable behaviour. ```{r} vec_ptype2.vctrs_percent.double <- function(x, y, ...) double() vec_ptype2.double.vctrs_percent <- function(x, y, ...) double() ``` We can check that we've implemented this correctly with `vec_ptype_show()`: ```{r} vec_ptype_show(percent(), double(), percent()) ``` Next we implement explicit casting, again starting with the boilerplate: ```{r} vec_cast.vctrs_percent <- function(x, to, ...) UseMethod("vec_cast.vctrs_percent") vec_cast.vctrs_percent.default <- function(x, to, ...) vec_default_cast(x, to) ``` ```{r, include = FALSE} s3_register("vctrs::vec_cast", "vctrs_percent") ``` Then providing a method to coerce a percent to a percent: ```{r} vec_cast.vctrs_percent.vctrs_percent <- function(x, to, ...) x ``` And then for converting back and forth between doubles. To convert a double to a percent we use the `percent()` helper (not the constructor; this is unvalidated user input). To convert a `percent` to a double, we strip the attributes. ```{r} vec_cast.vctrs_percent.double <- function(x, to, ...) percent(x) vec_cast.double.vctrs_percent <- function(x, to, ...) vec_data(x) ``` Then we can check this works with `vec_cast()`: ```{r} vec_cast(0.5, percent()) vec_cast(percent(0.5), double()) ``` Once you've implemented `vec_ptype2()` and `vec_cast()` you get `vec_c()`, `[<-`, and `[[<-` implementations for free. ```{r, error = TRUE} vec_c(percent(0.5), 1) vec_c(NA, percent(0.5)) # but vec_c(TRUE, percent(0.5)) x <- percent(c(0.5, 1, 2)) x[1:2] <- 2:1 x[[3]] <- 0.5 x ``` You'll also get mostly correct behaviour for `c()`. The exception is when you use `c()` with a base R class: ```{r, error = TRUE} # Correct c(percent(0.5), 1) c(percent(0.5), factor(1)) # Incorrect c(factor(1), percent(0.5)) ``` Unfortunately there's no way to fix this problem with the current design of `c()`. Again, as a convenience, consider providing an `as_percent()` function that makes use of the casts defined in your `vec_cast.vctrs_percent()` methods: ```{r} as_percent <- function(x) { vec_cast(x, new_percent()) } ``` ### Decimal class Now that you've seen the basics with a very simple S3 class, we'll gradually explore more complicated scenarios. This section creates a `decimal` class that prints with the specified number of decimal places. This is very similar to `percent` but now the class needs an attribute: the number of decimal places to display (an integer vector of length 1). We start of as before, defining a low-level constructor, a user-friendly constructor, a `format()` method, and a `vec_ptype_abbr()`. Note that additional object attributes are simply passed along to `new_vctr()`: ```{r} new_decimal <- function(x = double(), digits = 2L) { vec_assert(x, ptype = double()) vec_assert(digits, ptype = integer(), size = 1) new_vctr(x, digits = digits, class = "vctrs_decimal") } decimal <- function(x = double(), digits = 2L) { x <- vec_cast(x, double()) digits <- vec_recycle(vec_cast(digits, integer()), 1L) new_decimal(x, digits = digits) } digits <- function(x) attr(x, "digits") format.vctrs_decimal <- function(x, ...) { sprintf(paste0("%-0.", digits(x), "f"), x) } vec_ptype_abbr.vctrs_decimal <- function(x, ...) { paste0("dec") } x <- decimal(runif(10), 1L) x ``` Note that I provide a little helper to extract the `digits` attribute. This makes the code a little easier to read and should not be exported. By default, vctrs assumes that attributes are independent of the data and so are automatically preserved. You'll see what to do if the attributes are data dependent in the next section. ```{r} x[1:2] x[[1]] ``` For the sake of exposition, we'll assume that `digits` is an important attribute of the class and should be included in the full type: ```{r} vec_ptype_full.vctrs_decimal <- function(x, ...) { paste0("decimal<", digits(x), ">") } x ``` Now consider `vec_cast()` and `vec_ptype2()`. I start with the standard recipes: ```{r} vec_ptype2.vctrs_decimal <- function(x, y, ...) UseMethod("vec_ptype2.vctrs_decimal", y) vec_ptype2.vctrs_decimal.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } vec_cast.vctrs_decimal <- function(x, to, ...) UseMethod("vec_cast.vctrs_decimal") vec_cast.vctrs_decimal.default <- function(x, to, ...) vec_default_cast(x, to) ``` Casting and coercing from one decimal to another requires a little thought as the values of the `digits` attribute might be different, and we need some way to reconcile them. Here I've decided to chose the maximum of the two; other reasonable options are to take the value from the left-hand side or throw an error. ```{r} vec_ptype2.vctrs_decimal.vctrs_decimal <- function(x, y, ...) { new_decimal(digits = max(digits(x), digits(y))) } vec_cast.vctrs_decimal.vctrs_decimal <- function(x, to, ...) { new_decimal(vec_data(x), digits = digits(to)) } vec_c(decimal(1/100, digits = 3), decimal(2/100, digits = 2)) ``` Finally, I can implement coercion to and from other types, like doubles. When automatically coercing, I choose the richer type (i.e., the decimal). ```{r} vec_ptype2.vctrs_decimal.double <- function(x, y, ...) x vec_ptype2.double.vctrs_decimal <- function(x, y, ...) y vec_cast.vctrs_decimal.double <- function(x, to, ...) new_decimal(x, digits = digits(to)) vec_cast.double.vctrs_decimal <- function(x, to, ...) vec_data(x) vec_c(decimal(1, digits = 1), pi) vec_c(pi, decimal(1, digits = 1)) ``` If type `x` has greater resolution than `y`, there will be some inputs that lose precision. These should generate errors using `stop_lossy_cast()`. You can see that in action when casting from doubles to integers; only some doubles can become integers without losing resolution. ```{r, error = TRUE} vec_cast(c(1, 2, 10), to = integer()) vec_cast(c(1.5, 2, 10.5), to = integer()) ``` ### Cached sum class {#cached-sum} The next level up in complexity is an object that has data-dependent attributes. To explore this idea we'll create a vector that caches the sum of its values. As usual, we start with low-level and user-friendly constructors: ```{r} new_cached_sum <- function(x = double(), sum = 0L) { vec_assert(x, ptype = double()) vec_assert(sum, ptype = double(), size = 1L) new_vctr(x, sum = sum, class = "vctrs_cached_sum") } cached_sum <- function(x) { x <- vec_cast(x, double()) new_cached_sum(x, sum(x)) } ``` For this class, we can use the default `format()` method, and instead, we'll customise the `obj_print_footer()` method. This is a good place to display user facing attributes. ```{r} obj_print_footer.vctrs_cached_sum <- function(x, ...) { cat("# Sum: ", format(attr(x, "sum"), digits = 3), "\n", sep = "") } x <- cached_sum(runif(10)) x ``` We'll also override `sum()` and `mean()` to use the attribute. This is easiest to do with `vec_math()`, which you'll learn about later. ```{r} vec_math.vctrs_cached_sum <- function(.fn, .x, ...) { cat("Using cache\n") switch(.fn, sum = attr(.x, "sum"), mean = attr(.x, "sum") / length(.x), vec_math_base(.fn, .x, ...) ) } sum(x) ``` As mentioned above, vctrs assumes that attributes are independent of the data. This means that when we take advantage of the default methods, they'll work, but return the incorrect result: ```{r} x[1:2] ``` To fix this, you need to provide a `vec_restore()` method. Note that this method dispatches on the `to` argument. ```{r} vec_restore.vctrs_cached_sum <- function(x, to, ..., i = NULL) { new_cached_sum(x, sum(x)) } x[1] ``` This works because most of the vctrs methods dispatch to the underlying base function by first stripping off extra attributes with `vec_data()` and then reapplying them again with `vec_restore()`. The default `vec_restore()` method copies over all attributes, which is not appropriate when the attributes depend on the data. Note that `vec_restore.class` is subtly different from `vec_cast.class.class()`. `vec_restore()` is used when restoring attributes that have been lost; `vec_cast()` is used for coercions. This is easier to understand with a concrete example. Imagine factors were implemented with `new_vctr()`. `vec_restore.factor()` would restore attributes back to an integer vector, but you would not want to allow manually casting an integer to a factor with `vec_cast()`. ## Record-style objects Record-style objects use a list of equal-length vectors to represent individual components of the object. The best example of this is `POSIXlt`, which underneath the hood is a list of 11 fields like year, month, and day. Record-style classes override `length()` and subsetting methods to conceal this implementation detail. ```{r} x <- as.POSIXlt(ISOdatetime(2020, 1, 1, 0, 0, 1:3)) x length(x) length(unclass(x)) x[[1]] # the first date time unclass(x)[[1]] # the first component, the number of seconds ``` vctrs makes it easy to create new record-style classes using `new_rcrd()`, which has a wide selection of default methods. ### Rational class A fraction, or rational number, can be represented by a pair of integer vectors representing the numerator (the number on top) and the denominator (the number on bottom), where the length of each vector must be the same. To represent such a data structure we turn to a new base data type: the record (or rcrd for short). As usual we start with low-level and user-friendly constructors. The low-level constructor calls `new_rcrd()`, which needs a named list of equal-length vectors. ```{r} new_rational <- function(n = integer(), d = integer()) { vec_assert(n, ptype = integer()) vec_assert(d, ptype = integer()) new_rcrd(list(n = n, d = d), class = "vctrs_rational") } ``` Our user friendly constructor casts `n` and `d` to integers and recycles them to the same length. ```{r} rational <- function(n, d) { c(n, d) %<-% vec_cast_common(n, d, .to = integer()) c(n, d) %<-% vec_recycle_common(n, d) new_rational(n, d) } x <- rational(1, 1:10) ``` Behind the scenes, `x` is a named list with two elements. But those details are hidden so that it behaves like a vector: ```{r} names(x) length(x) ``` To access the underlying fields we need to use `field()` and `fields()`: ```{r} fields(x) field(x, "n") ``` This allows us to create a format method: ```{r} format.vctrs_rational <- function(x, ...) { n <- field(x, "n") d <- field(x, "d") out <- paste0(n, "/", d) out[is.na(n) | is.na(d)] <- NA out } vec_ptype_abbr.vctrs_rational <- function(x, ...) "rtnl" vec_ptype_full.vctrs_rational <- function(x, ...) "rational" x ``` vctrs uses the `format()` method in `str()`, hiding the underlying implementation details from the user: ```{r} str(x) ``` For `rational`, `vec_ptype2()` and `vec_cast()` follow the same pattern as `percent()`. I allow coercion from integer and to doubles. ```{r} vec_ptype2.vctrs_rational <- function(x, y, ...) UseMethod("vec_ptype2.vctrs_rational", y) vec_ptype2.vctrs_rational.default <- function(x, y, ..., x_arg = "x", y_arg = "y") { vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg) } vec_ptype2.vctrs_rational.vctrs_rational <- function(x, y, ...) new_rational() vec_ptype2.vctrs_rational.integer <- function(x, y, ...) new_rational() vec_ptype2.integer.vctrs_rational <- function(x, y, ...) new_rational() vec_cast.vctrs_rational <- function(x, to, ...) UseMethod("vec_cast.vctrs_rational") vec_cast.vctrs_rational.default <- function(x, to, ...) vec_default_cast(x, to) vec_cast.vctrs_rational.vctrs_rational <- function(x, to, ...) x vec_cast.double.vctrs_rational <- function(x, to, ...) field(x, "n") / field(x, "d") vec_cast.vctrs_rational.integer <- function(x, to, ...) rational(x, 1) vec_c(rational(1, 2), 1L, NA) ``` ### Decimal2 class The previous implementation of `decimal` was built on top of doubles. This is a bad idea because decimal vectors are typically used when you care about precise values (i.e., dollars and cents in a bank account), and double values suffer from floating point problems. A better implementation of a decimal class would be to use pair of integers, one for the value to the left of the decimal point, and the other for the value to the right (divided by a `scale`). The following code is a very quick sketch of how you might start creating such a class: ```{r} new_decimal2 <- function(l, r, scale = 2L) { vec_assert(l, ptype = integer()) vec_assert(r, ptype = integer()) vec_assert(scale, ptype = integer(), size = 1L) new_rcrd(list(l = l, r = r), scale = scale, class = "vctrs_decimal2") } decimal2 <- function(l, r, scale = 2L) { l <- vec_cast(l, integer()) r <- vec_cast(r, integer()) c(l, r) %<-% vec_recycle_common(l, r) scale <- vec_cast(scale, integer()) # should check that r < 10^scale new_decimal2(l = l, r = r, scale = scale) } format.vctrs_decimal2 <- function(x, ...) { val <- field(x, "l") + field(x, "r") / 10^attr(x, "scale") sprintf(paste0("%.0", attr(x, "scale"), "f"), val) } decimal2(10, c(0, 5, 99)) ``` ## Equality and comparison vctrs provides three "proxy" generics. Two of these let you control how your class determines equality and ordering: * `vec_proxy_equal()` returns a data vector suitable for comparison. It underpins `==`, `!=`, `unique()`, `anyDuplicated()`, and `is.na()`. * `vec_proxy_compare()` specifies how to compare the elements of your vector. This proxy is used in `<`, `<=`, `>=`, `>`, `min()`, `max()`, `median()`, `quantile()`, and `xtfrm()` (used in `order()` and `sort()`) methods. By default, `vec_proxy_equal()` and `vec_proxy_compare()` just call `vec_proxy()`. * `vec_proxy()` returns the actual data of a vector. This is useful when you store the data in a field of your class. Most of the time, you shouldn't need to implement `vec_proxy()`. You should only implement these proxies when some preprocessing on the data is needed to make elements comparable. In that case, defining these methods will get you a lot of behaviour for relatively little work. These proxy functions should always return a simple object (either a bare vector or a data frame) that possesses the same properties as your class. This permits efficient implementation of the vctrs internals because it allows dispatch to happen once in R, and then efficient computations can be written in C. ### Rational class Let's explore these ideas by with the rational class we started on above. By default, `vec_proxy()` converts a record to a data frame, and the default comparison works column by column: ```{r} x <- rational(c(1, 2, 1, 2), c(1, 1, 2, 2)) x vec_proxy(x) x == rational(1, 1) ``` This makes sense as a default but isn't correct here because `rational(1, 1)` represents the same number as `rational(2, 2)`, so they should be equal. We can fix that by implementing a `vec_proxy_equal()` method that divides `n` and `d` by their greatest common divisor: ```{r} # Thanks to Matthew Lundberg: https://stackoverflow.com/a/21504113/16632 gcd <- function(x, y) { r <- x %% y ifelse(r, gcd(y, r), y) } vec_proxy_equal.vctrs_rational <- function(x, ...) { n <- field(x, "n") d <- field(x, "d") gcd <- gcd(n, d) data.frame(n = n / gcd, d = d / gcd) } vec_proxy(x) x == rational(1, 1) ``` `vec_proxy_equal()` is also used by `unique()`: ```{r} unique(x) ``` We now need to fix `sort()` similarly, since it currently sorts by `n`, then by `d`: ```{r} sort(x) ``` The easiest fix is to convert the fraction to a decimal and then sort that: ```{r} vec_proxy_compare.vctrs_rational <- function(x, ...) { field(x, "n") / field(x, "d") } sort(x) ``` (We could have used the same approach in `vec_proxy_equal()`, but when working with floating point numbers it's not necessarily true that `x == y` implies that `d * x == d * y`.) ### Polynomial class A related problem occurs if we build our vector on top of a list. The following code defines a polynomial class that represents polynomials (like `1 + 3x - 2x^2`) using a list of integer vectors (like `c(1, 3, -2)`). Note the use of `new_list_of()` in the constructor. ```{r} new_poly <- function(x) { new_list_of(x, ptype = integer(), class = "vctrs_poly") } poly <- function(...) { x <- list(...) x <- lapply(x, vec_cast, integer()) new_poly(x) } vec_ptype_full.vctrs_poly <- function(x, ...) "polynomial" vec_ptype_abbr.vctrs_poly <- function(x, ...) "poly" format.vctrs_poly <- function(x, ...) { format_one <- function(x) { if (length(x) == 0) { return("") } else if (length(x) == 1) { format(x) } else { suffix <- c(paste0("\u22C5x^", seq(length(x) - 1, 1)), "") out <- paste0(x, suffix) out <- out[x != 0L] paste0(out, collapse = " + ") } } vapply(x, format_one, character(1)) } obj_print_data.vctrs_poly <- function(x, ...) { if (length(x) == 0) return() print(format(x), quote = FALSE) } p <- poly(1, c(1, 0, 1), c(1, 0, 0, 0, 2)) p ``` The resulting objects will inherit from the `vctrs_list_of` class, which provides tailored methods for `$`, `[[`, the corresponding assignment operators, and other methods. ```{r} class(p) p[2] p[[2]] ``` Equality works out of the box because we can tell if two integer vectors are equal: ```{r} p == poly(c(1, 0, 1)) ``` But we can't order them because lists are not comparable: ```{r, error = TRUE} sort(p) ``` So we need to define a `vec_proxy_compare()` method: ```{r} vec_proxy_compare.vctrs_poly <- function(x, ...) { x_raw <- vec_data(x) # First figure out the maximum length n <- max(vapply(x_raw, length, integer(1))) # Then expand all vectors to this length by filling in with zeros full <- lapply(x_raw, function(x) c(rep(0L, n - length(x)), x)) # Then turn into a data frame as.data.frame(do.call(rbind, full)) } sort(poly(3, 2, 1)) sort(poly(1, c(1, 0, 0), c(1, 0))) ``` ## Arithmetic vctrs also provides two mathematical generics that allow you to define a broad swath of mathematical behaviour at once: * `vec_math(fn, x, ...)` specifies the behaviour of mathematical functions like `abs()`, `sum()`, and `mean()`. (See `?vec_math()` for the complete list.) * `vec_arith(op, x, y)` specifies the behaviour of the arithmetic operations like `+`, `-`, and `%%`. (See `?vec_arith()` for the complete list.) Both generics define the behaviour for multiple functions because `sum.vctrs_vctr(x)` calls `vec_math.vctrs_vctr("sum", x)`, and `x + y` calls `vec_math.x_class.y_class("+", x, y)`. They're accompanied by `vec_math_base()` and `vec_arith_base()` which make it easy to call the underlying base R functions. `vec_arith()` uses double dispatch and needs the following standard boilerplate: ```{r} vec_arith.MYCLASS <- function(op, x, y, ...) { UseMethod("vec_arith.MYCLASS", y) } vec_arith.MYCLASS.default <- function(op, x, y, ...) { stop_incompatible_op(op, x, y) } ``` ### Cached sum class I showed an example of `vec_math()` to define `sum()` and `mean()` methods for `cached_sum`. Now let's talk about exactly how it works. Most `vec_math()` functions will have a similar form. You use a switch statement to handle the methods that you care about and fall back to `vec_math_base()` for those that you don't care about. ```{r} vec_math.vctrs_cached_sum <- function(.fn, .x, ...) { switch(.fn, sum = attr(.x, "sum"), mean = attr(.x, "sum") / length(.x), vec_math_base(.fn, .x, ...) ) } ``` ### Meter class To explore the infix arithmetic operators exposed by `vec_arith()` I'll create a new class that represents a measurement in `meter`s: ```{r} new_meter <- function(x) { stopifnot(is.double(x)) new_vctr(x, class = "vctrs_meter") } format.vctrs_meter <- function(x, ...) { paste0(format(vec_data(x)), " m") } meter <- function(x) { x <- vec_cast(x, double()) new_meter(x) } x <- meter(1:10) x ``` Because `meter` is built on top of a double vector, basic mathematic operations work: ```{r} sum(x) mean(x) ``` But we can't do arithmetic: ```{r, error = TRUE} x + 1 meter(10) + meter(1) meter(10) * 3 ``` To allow these infix functions to work, we'll need to provide `vec_arith()` generic. But before we do that, let's think about what combinations of inputs we should support: * It makes sense to add and subtract meters: that yields another meter. We can divide a meter by another meter (yielding a unitless number), but we can't multiply meters (because that would yield an area). * For a combination of meter and number multiplication and division by a number are acceptable. Addition and subtraction don't make much sense as we, strictly speaking, are dealing with objects of different nature. `vec_arith()` is another function that uses double dispatch, so as usual we start with a template. ```{r} vec_arith.vctrs_meter <- function(op, x, y, ...) { UseMethod("vec_arith.vctrs_meter", y) } vec_arith.vctrs_meter.default <- function(op, x, y, ...) { stop_incompatible_op(op, x, y) } ``` Then write the method for two meter objects. We use a switch statement to cover the cases we care about and `stop_incompatible_op()` to throw an informative error message for everything else. ```{r, error = TRUE} vec_arith.vctrs_meter.vctrs_meter <- function(op, x, y, ...) { switch( op, "+" = , "-" = new_meter(vec_arith_base(op, x, y)), "/" = vec_arith_base(op, x, y), stop_incompatible_op(op, x, y) ) } meter(10) + meter(1) meter(10) - meter(1) meter(10) / meter(1) meter(10) * meter(1) ``` Next we write the pair of methods for arithmetic with a meter and a number. These are almost identical, but while `meter(10) / 2` makes sense, `2 / meter(10)` does not (and neither do addition and subtraction). ```{r, error = TRUE} vec_arith.vctrs_meter.numeric <- function(op, x, y, ...) { switch( op, "/" = , "*" = new_meter(vec_arith_base(op, x, y)), stop_incompatible_op(op, x, y) ) } vec_arith.numeric.vctrs_meter <- function(op, x, y, ...) { switch( op, "*" = new_meter(vec_arith_base(op, x, y)), stop_incompatible_op(op, x, y) ) } meter(2) * 10 10 * meter(2) meter(20) / 10 10 / meter(20) meter(20) + 10 ``` For completeness, we also need `vec_arith.vctrs_meter.MISSING` for the unary `+` and `-` operators: ```{r} vec_arith.vctrs_meter.MISSING <- function(op, x, y, ...) { switch(op, `-` = x * -1, `+` = x, stop_incompatible_op(op, x, y) ) } -meter(1) +meter(1) ``` ## Appendix: `NAMESPACE` declarations Defining S3 methods interactively is fine for iteration and exploration, but if your vector lives in a package, you also need to register the S3 methods by listing them in the `NAMESPACE` file. The namespace declarations are a little tricky because (e.g.) `vec_cast.vctrs_percent()` is both a generic function (which must be exported with `export()`) and an S3 method (which must be registered with `S3method()`). This problem wasn't considered in the design of roxygen2, so you have to be quite explicit: ```{r} #' @method vec_cast vctrs_percent #' @export #' @export vec_cast.vctrs_percent vec_cast.vctrs_percent <- function(x, to, ...) { } ``` You also need to register the individual double-dispatch methods. Again, this is harder than it should be because roxygen's heuristics aren't quite right. That means you need to describe the `@method` explicitly: ```{r} #' @method vec_cast.binned double #' @export vec_cast.binned.double <- function(x, y, ...) { } ``` Hopefully future versions of roxygen will make these exports less painful. vctrs/inst/doc/stability.Rmd0000644000176200001440000003107313622451540015613 0ustar liggesusers--- title: "Type and size stability" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Type and size stability} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` This vignette introduces the ideas of type-stability and size-stability. If a function possesses these properties, it is substantially easier to reason about because to predict the "shape" of the output you only need to know the "shape"s of the inputs. This work is partly motivated by a common pattern that I noticed when reviewing code: if I read the code (without running it!), and I can't predict the type of each variable, I feel very uneasy about the code. This sense is important because most unit tests explore typical inputs, rather than exhaustively testing the strange and unusual. Analysing the types (and size) of variables makes it possible to spot unpleasant edge cases. ```{r setup} library(vctrs) library(zeallot) ``` ## Definitions We say a function is __type-stable__ iff: 1. You can predict the output type knowing only the input types. 1. The order of arguments in ... does not affect the output type. Similarly, a function is __size-stable__ iff: 1. You can predict the output size knowing only the input sizes, or there is a single numeric input that specifies the output size. Very few base R functions are size-stable, so I'll also define a slightly weaker condition. I'll call a function __length-stable__ iff: 1. You can predict the output _length_ knowing only the input _lengths_, or there is a single numeric input that specifies the output _length_. (But note that length-stable is not a particularly robust definition because `length()` returns a value for things that are not vectors.) We'll call functions that don't obey these principles __type-unstable__ and __size-unstable__ respectively. On top of type- and size-stability it's also desirable to have a single set of rules that are applied consistently. We want one set of type-coercion and size-recycling rules that apply everywhere, not many sets of rules that apply to different functions. The goal of these principles is to minimise cognitive overhead. Rather than having to memorise many special cases, you should be able to learn one set of principles and apply them again and again. ### Examples To make these ideas concrete, let's apply them to a few base functions: 1. `mean()` is trivially type-stable and size-stable because it always returns a double vector of length 1 (or it throws an error). 1. Surprisingly, `median()` is type-unstable: ```{r} vec_ptype_show(median(c(1L, 1L))) vec_ptype_show(median(c(1L, 1L, 1L))) ``` It is, however, size-stable, since it always returns a vector of length 1. 1. `sapply()` is type-unstable because you can't predict the output type only knowing the input types: ```{r} vec_ptype_show(sapply(1L, function(x) c(x, x))) vec_ptype_show(sapply(integer(), function(x) c(x, x))) ``` It's not quite size-stable; `vec_size(sapply(x, f))` is `vec_size(x)` for vectors but not for matrices (the output is transposed) or data frames (it iterates over the columns). 1. `vapply()` is a type-stable version of `sapply()` because `vec_ptype_show(vapply(x, fn, template))` is always `vec_ptype_show(template)`. It is size-unstable for the same reasons as `sapply()`. 1. `c()` is type-unstable because `c(x, y)` doesn't always output the same type as `c(y, x)`. ```{r} vec_ptype_show(c(NA, Sys.Date())) vec_ptype_show(c(Sys.Date(), NA)) ``` `c()` is *almost always* length-stable because `length(c(x, y))` *almost always* equals `length(x) + length(y)`. One common source of instability here is dealing with non-vectors (see the later section "Non-vectors"): ```{r} env <- new.env(parent = emptyenv()) length(env) length(mean) length(c(env, mean)) ``` 1. `paste(x1, x2)` is length-stable because `length(paste(x1, x2))` equals `max(length(x1), length(x2))`. However, it doesn't follow the usual arithmetic recycling rules because `paste(1:2, 1:3)` doesn't generate a warning. 1. `ifelse()` is length-stable because `length(ifelse(cond, true, false))` is always `length(cond)`. `ifelse()` is type-unstable because the output type depends on the value of `cond`: ```{r} vec_ptype_show(ifelse(NA, 1L, 1L)) vec_ptype_show(ifelse(FALSE, 1L, 1L)) ``` 1. `read.csv(file)` is type-unstable and size-unstable because, while you know it will return a data frame, you don't know what columns it will return or how many rows it will have. Similarly, `df[[i]]` is not type-stable because the result depends on the _value_ of `i`. There are very many important functions that can not be made type-stable or size-stable! With this understanding of type- and size-stability in hand, we'll use them to analyse some base R functions in greater depth and then propose alternatives with better properties. ## `c()` and `vctrs::vec_c()` In this section we'll compare and contrast `c()` and `vec_c()`. `vec_c()` is both type- and size-stable because it possesses the following invariants: * `vec_ptype(vec_c(x, y))` equals `vec_ptype_common(x, y)`. * `vec_size(vec_c(x, y))` equals `vec_size(x) + vec_size(y)`. `c()` has another undesirable property in that it's not consistent with `unlist()`; i.e., `unlist(list(x, y))` does not always equal `c(x, y)`; i.e., base R has multiple sets of type-coercion rules. I won't consider this problem further here. I have two goals here: * To fully document the quirks of `c()`, hence motivating the development of an alternative. * To discuss non-obvious consequences of the type- and size-stability above. ### Atomic vectors If we only consider atomic vectors, `c()` is type-stable because it uses a hierarchy of types: character > complex > double > integer > logical. ```{r} c(FALSE, 1L, 2.5) ``` `vec_c()` obeys similar rules: ```{r} vec_c(FALSE, 1L, 2.5) ``` But it does not automatically coerce to character vectors or lists: ```{r, error = TRUE} c(FALSE, "x") vec_c(FALSE, "x") c(FALSE, list(1)) vec_c(FALSE, list(1)) ``` ### Non-vectors As far as I can tell, `c()` never throws an error. No matter how bizarre the inputs, it always returns something: ```{r} c(Sys.Date(), factor("x"), "x") ``` If the inputs aren't vectors, `c()` automatically puts them in a list: ```{r} c(mean, globalenv()) ``` `vec_c()` throws an error if the inputs are not vectors or not automatically coercible: ```{r, error = TRUE} vec_c(mean, globalenv()) vec_c(Sys.Date(), factor("x"), "x") ``` ### Factors Combining two factors returns an integer vector: ```{r} fa <- factor("a") fb <- factor("b") c(fa, fb) ``` (This is documented in `c()` but is still undesirable.) `vec_c()` returns a factor taking the union of the levels. This behaviour is motivated by pragmatics: there are many places in base R that automatically convert character vectors to factors, so enforcing stricter behaviour would be unnecessarily onerous. (This is backed up by experience with `dplyr::bind_rows()`, which is stricter and is a common source of user difficulty.) ```{r} vec_c(fa, fb) vec_c(fb, fa) ``` ### Date-times `c()` strips the time zone associated with date-times: ```{r} datetime_nz <- as.POSIXct("2020-01-01 09:00", tz = "Pacific/Auckland") c(datetime_nz) ``` This behaviour is documented in `?DateTimeClasses` but is the source of considerable user pain. `vec_c()` preserves time zones: ```{r} vec_c(datetime_nz) ``` What time zone should the output have if inputs have different time zones? One option would be to be strict and force the user to manually align all the time zones. However, this is onerous (particularly because there's no easy way to change the time zone in base R), so vctrs chooses to use the first non-local time zone: ```{r} datetime_local <- as.POSIXct("2020-01-01 09:00") datetime_houston <- as.POSIXct("2020-01-01 09:00", tz = "US/Central") vec_c(datetime_local, datetime_houston, datetime_nz) vec_c(datetime_houston, datetime_nz) vec_c(datetime_nz, datetime_houston) ``` ### Dates and date-times Combining dates and date-times with `c()` gives silently incorrect results: ```{r} date <- as.Date("2020-01-01") datetime <- as.POSIXct("2020-01-01 09:00") c(date, datetime) c(datetime, date) ``` This behaviour arises because neither `c.Date()` nor `c.POSIXct()` check that all inputs are of the same type. `vec_c()` uses a standard set of rules to avoid this problem. When you mix dates and date-times, vctrs returns a date-time and converts dates to date-times at midnight (in the timezone of the date-time). ```{r} vec_c(date, datetime) vec_c(date, datetime_nz) ``` ### Missing values If a missing value comes at the beginning of the inputs, `c()` falls back to the internal behaviour, which strips all attributes: ```{r} c(NA, fa) c(NA, date) c(NA, datetime) ``` `vec_c()` takes a different approach treating a logical vector consisting only of `NA` as the `unspecified()` class which can be converted to any other 1d type: ```{r} vec_c(NA, fa) vec_c(NA, date) vec_c(NA, datetime) ``` ### Data frames Because it is *almost always* length-stable, `c()` combines data frames column wise (into a list): ```{r} df1 <- data.frame(x = 1) df2 <- data.frame(x = 2) str(c(df1, df1)) ``` `vec_c()` is size-stable, which implies it will row-bind data frames: ```{r} vec_c(df1, df2) ``` ### Matrices and arrays The same reasoning applies to matrices: ```{r} m <- matrix(1:4, nrow = 2) c(m, m) vec_c(m, m) ``` One difference is that `vec_c()` will "broadcast" a vector to match the dimensions of a matrix: ```{r} c(m, 1) vec_c(m, 1) ``` ### Implementation The basic implementation of `vec_c()` is reasonably simple. We first figure out the properties of the output, i.e. the common type and total size, and then allocate it with `vec_init()`, and then insert each input into the correct place in the output. ```{r, eval = FALSE} vec_c <- function(...) { args <- compact(list2(...)) ptype <- vec_ptype_common(!!!args) if (is.null(ptype)) return(NULL) ns <- map_int(args, vec_size) out <- vec_init(ptype, sum(ns)) pos <- 1 for (i in seq_along(ns)) { n <- ns[[i]] x <- vec_cast(args[[i]], to = ptype) vec_slice(out, pos:(pos + n - 1)) <- x pos <- pos + n } out } ``` (The real `vec_c()` is a bit more complicated in order to handle inner and outer names). ## `ifelse()` One of the functions that motivate the development of vctrs is `ifelse`. It has the surprising property that the result value is "A vector of the same length and attributes (including dimensions and class) as `test`". To me, it seems more reasonable for the type of the output to be controlled by the type of the `yes` and `no` arguments. In `dplyr::if_else()` I swung too far towards strictness: it throws an error if `yes` and `no` are not the same type. This is annoying in practice because it requires typed missing values (`NA_character_` etc), and because the checks are only on the class (not the full prototype), it's easy to create invalid output. I found it much easier understand what `ifelse()` _should_ do once I internalised the ideas of type- and size-stability: * The first argument must be logical. * `vec_ptype(if_else(test, yes, no))` equals `vec_ptype_common(yes, no)`. Unlike `ifelse()` this implies that `if_else()` must always evaluate both `yes` and `no` in order to figure out the correct type. I think this is consistent with `&&` (scalar operation, short circuits) and `&` (vectorised, evaluates both sides). * `vec_size(if_else(test, yes, no))` equals `vec_size_common(test, yes, no)`. I think the output could have the same size as `test` (i.e., the same behaviour as `ifelse`), but I _think_ as a general rule that your inputs should either be mutually recycling or not. This leads to the following implementation: ```{r} if_else <- function(test, yes, no) { vec_assert(test, logical()) c(yes, no) %<-% vec_cast_common(yes, no) c(test, yes, no) %<-% vec_recycle_common(test, yes, no) out <- vec_init(yes, vec_size(yes)) vec_slice(out, test) <- vec_slice(yes, test) vec_slice(out, !test) <- vec_slice(no, !test) out } x <- c(NA, 1:4) if_else(x > 2, "small", "big") if_else(x > 2, factor("small"), factor("big")) if_else(x > 2, Sys.Date(), Sys.Date() + 7) ``` By using `vec_size()` and `vec_slice()`, this definition of `if_else()` automatically works with data.frames and matrices: ```{r} if_else(x > 2, data.frame(x = 1), data.frame(y = 2)) if_else(x > 2, matrix(1:10, ncol = 2), cbind(30, 30)) ``` vctrs/inst/doc/type-size.R0000644000176200001440000001276713623213403015223 0ustar liggesusers## ----setup, include = FALSE--------------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ## ----------------------------------------------------------------------------- library(vctrs) ## ----------------------------------------------------------------------------- vec_ptype_show(FALSE) vec_ptype_show(1L) vec_ptype_show(2.5) vec_ptype_show("three") vec_ptype_show(list(1, 2, 3)) ## ----------------------------------------------------------------------------- vec_ptype_show(array(logical(), c(2, 3))) vec_ptype_show(array(integer(), c(2, 3, 4))) vec_ptype_show(array(character(), c(2, 3, 4, 5))) ## ----------------------------------------------------------------------------- vec_ptype_show(factor("a")) vec_ptype_show(ordered("b")) ## ----------------------------------------------------------------------------- vec_ptype(factor("a")) ## ----------------------------------------------------------------------------- vec_ptype_show(Sys.Date()) vec_ptype_show(Sys.time()) vec_ptype_show(as.difftime(10, units = "mins")) ## ----------------------------------------------------------------------------- vec_ptype_show(data.frame(a = FALSE, b = 1L, c = 2.5, d = "x")) ## ----------------------------------------------------------------------------- df <- data.frame(x = FALSE) df$y <- data.frame(a = 1L, b = 2.5) vec_ptype_show(df) ## ---- error = TRUE------------------------------------------------------------ vec_ptype_show(logical(), integer(), double()) vec_ptype_show(logical(), character()) ## ----------------------------------------------------------------------------- vec_ptype_show( array(1, c(0, 1)), array(1, c(0, 2)) ) vec_ptype_show( array(1, c(0, 1)), array(1, c(0, 3)), array(1, c(0, 3, 4)), array(1, c(0, 3, 4, 5)) ) ## ---- error = TRUE------------------------------------------------------------ vec_ptype_show( array(1, c(0, 2)), array(1, c(0, 3)) ) ## ----------------------------------------------------------------------------- fa <- factor("a") fb <- factor("b") levels(vec_ptype_common(fa, fb)) levels(vec_ptype_common(fb, fa)) ## ----------------------------------------------------------------------------- vec_ptype_show(new_date(), new_datetime()) ## ----------------------------------------------------------------------------- vec_ptype_show( new_datetime(tzone = "US/Central"), new_datetime(tzone = "Pacific/Auckland") ) ## ----------------------------------------------------------------------------- vec_ptype_show( new_datetime(tzone = ""), new_datetime(tzone = ""), new_datetime(tzone = "Pacific/Auckland") ) ## ----------------------------------------------------------------------------- vec_ptype_show( data.frame(x = FALSE), data.frame(x = 1L), data.frame(x = 2.5) ) ## ----------------------------------------------------------------------------- vec_ptype_show(data.frame(x = 1, y = 1), data.frame(y = 1, z = 1)) ## ----------------------------------------------------------------------------- str(vec_cast_common( FALSE, 1:5, 2.5 )) str(vec_cast_common( factor("x"), factor("y") )) str(vec_cast_common( data.frame(x = 1), data.frame(y = 1:2) )) ## ---- error = TRUE------------------------------------------------------------ # Cast succeeds vec_cast(c(1, 2), integer()) # Cast fails vec_cast(c(1.5, 2.5), factor("a")) ## ---- error = TRUE------------------------------------------------------------ vec_cast(c(1.5, 2), integer()) ## ----------------------------------------------------------------------------- allow_lossy_cast( vec_cast(c(1.5, 2), integer()) ) ## ----------------------------------------------------------------------------- allow_lossy_cast( vec_cast(c(1.5, 2), integer()), x_ptype = double(), to_ptype = integer() ) ## ---- echo = FALSE, fig.cap="Summary of vctrs casting rules"------------------ knitr::include_graphics("../man/figures/combined.png", dpi = 300) ## ----------------------------------------------------------------------------- x <- sample(1:10) df <- data.frame(x = x) vec_slice(x, 5:6) vec_slice(df, 5:6) ## ----------------------------------------------------------------------------- vec_size_common(1:3, 1:3, 1:3) vec_size_common(1:10, 1) vec_size_common(integer(), 1) ## ---- echo = FALSE, fig.cap="Summary of vctrs recycling rules. X indicates n error"---- knitr::include_graphics("../man/figures/sizes-recycling.png", dpi = 300) ## ----------------------------------------------------------------------------- vec_recycle(1:3, 3) vec_recycle(1, 10) ## ----------------------------------------------------------------------------- vec_recycle_common(1:3, 1:3) vec_recycle_common(1:10, 1) ## ----------------------------------------------------------------------------- rep(1, 6) + 1 rep(1, 6) + 1:2 rep(1, 6) + 1:3 ## ----------------------------------------------------------------------------- invisible(pmax(1:2, 1:3)) invisible(1:2 + 1:3) invisible(cbind(1:2, 1:3)) ## ----------------------------------------------------------------------------- length(atan2(1:3, 1:2)) length(paste(1:3, 1:2)) length(ifelse(1:3, 1:2, 1:2)) ## ---- error = TRUE------------------------------------------------------------ data.frame(1:2, 1:3) ## ---- error = TRUE------------------------------------------------------------ # length-0 output 1:2 + integer() atan2(1:2, integer()) pmax(1:2, integer()) # dropped cbind(1:2, integer()) # recycled to length of first ifelse(rep(TRUE, 4), integer(), character()) # preserved-ish paste(1:2, integer()) # Errors data.frame(1:2, integer()) vctrs/inst/doc/type-size.html0000644000176200001440000037545313623213405015774 0ustar liggesusers Prototypes and sizes

Prototypes and sizes

Rather than using class() and length(), vctrs has notions of prototype (vec_ptype_show()) and size (vec_size()). This vignette discusses the motivation for why these alternatives are necessary and connects their definitions to type coercion and the recycling rules.

Size and prototype are motivated by thinking about the optimal behaviour for c() and rbind(), particularly inspired by data frames with columns that are matrices or data frames.

library(vctrs)

Prototype

The idea of a prototype is to capture the metadata associated with a vector without capturing any data. Unfortunately, the class() of an object is inadequate for this purpose:

  • The class() doesn’t include attributes. Attributes are important because, for example, they store the levels of a factor and the timezone of a POSIXct. You cannot combine two factors or two POSIXcts without thinking about the attributes.

  • The class() of a matrix is “matrix” and doesn’t include the type of the underlying vector or the dimensionality.

Instead, vctrs takes advantage of R’s vectorised nature and uses a prototype, a 0-observation slice of the vector (this is basically x[0] but with some subtleties we’ll come back to later). This is a miniature version of the vector that contains all of the attributes but none of the data.

Conveniently, you can create many prototypes using existing base functions (e.g, double() and factor(levels = c("a", "b"))). vctrs provides a few helpers (e.g. new_date(), new_datetime(), and new_duration()) where the equivalents in base R are missing.

Base prototypes

vec_ptype() creates a prototype from an existing object. However, many base vectors have uninformative printing methods for 0-length subsets, so vctrs also provides vec_ptype_show(), which prints the prototype in a friendly way (and returns nothing).

Using vec_ptype_show() allows us to see the prototypes base R classes:

  • Atomic vectors have no attributes and just display the underlying typeof():

    vec_ptype_show(FALSE)
    #> Prototype: logical
    vec_ptype_show(1L)
    #> Prototype: integer
    vec_ptype_show(2.5)
    #> Prototype: double
    vec_ptype_show("three")
    #> Prototype: character
    vec_ptype_show(list(1, 2, 3))
    #> Prototype: list
  • The prototype of matrices and arrays include the base type and the dimensions after the first:

    vec_ptype_show(array(logical(), c(2, 3)))
    #> Prototype: logical[,3]
    vec_ptype_show(array(integer(), c(2, 3, 4)))
    #> Prototype: integer[,3,4]
    vec_ptype_show(array(character(), c(2, 3, 4, 5)))
    #> Prototype: character[,3,4,5]
  • The prototype of a factor includes its levels. Levels are a character vector, which can be arbitrarily long, so the prototype just shows a hash. If the hash of two factors is equal, it’s highly likely that their levels are also equal.

    vec_ptype_show(factor("a"))
    #> Prototype: factor<127a2>
    vec_ptype_show(ordered("b"))
    #> Prototype: ordered<ddf10>

    While vec_ptype_show() prints only the hash, the prototype object itself does contain all levels:

    vec_ptype(factor("a"))
    #> factor(0)
    #> Levels: a
  • Base R has three key date time classes: dates, date-times (POSIXct), and durations (difftime). Date-times have a timezone, and durations have a unit.

    vec_ptype_show(Sys.Date())
    #> Prototype: date
    vec_ptype_show(Sys.time())
    #> Prototype: datetime<local>
    vec_ptype_show(as.difftime(10, units = "mins"))
    #> Prototype: duration<mins>
  • Data frames have the most complex prototype: the prototype of a data frame is the name and prototype of each column:

    vec_ptype_show(data.frame(a = FALSE, b = 1L, c = 2.5, d = "x"))
    #> Prototype: data.frame<
    #>   a: logical
    #>   b: integer
    #>   c: double
    #>   d: factor<5a425>
    #> >

    Data frames can have columns that are themselves data frames, making this a “recursive” type:

    df <- data.frame(x = FALSE)
    df$y <- data.frame(a = 1L, b = 2.5)
    vec_ptype_show(df)
    #> Prototype: data.frame<
    #>   x: logical
    #>   y: 
    #>     data.frame<
    #>       a: integer
    #>       b: double
    #>     >
    #> >

Coercing to common type

It’s often important to combine vectors with multiple types. vctrs provides a consistent set of rules for coercion, via vec_ptype_common(). vec_ptype_common() possesses the following invariants:

  • class(vec_ptype_common(x, y)) equals class(vec_ptype_common(y, x)).

  • class(vec_ptype_common(x, vec_ptype_common(y, z)) equals class(vec_ptype_common(vec_ptype_common(x, y), z)).

  • vec_ptype_common(x, NULL) == vec_ptype(x).

i.e., vec_ptype_common() is both commutative and associative (with respect to class) and has an identity element, NULL; i.e., it’s a commutative monoid. This means the underlying implementation is quite simple: we can find the common type of any number of objects by progressively finding the common type of pairs of objects.

Like with vec_ptype(), the easiest way to explore vec_ptype_common() is with vec_ptype_show(): when given multiple inputs, it will print their common prototype. (In other words: program with vec_ptype_common() but play with vec_ptype_show().)

  • The common type of atomic vectors is computed very similar to the rules of base R, except that we do not coerce to character automatically:

    vec_ptype_show(logical(), integer(), double())
    #> Prototype: <double>
    #> 0. (           , <logical> ) = <logical>
    #> 1. ( <logical> , <integer> ) = <integer>
    #> 2. ( <integer> , <double>  ) = <double>
    
    vec_ptype_show(logical(), character())
    #> Error: No common type for `x` <logical> and `y` <character>.
  • Matrices and arrays are automatically broadcast to higher dimensions:

    vec_ptype_show(
      array(1, c(0, 1)), 
      array(1, c(0, 2))
    )
    #> Prototype: <double[,2]>
    #> 0. (              , <double[,1]> ) = <double[,1]>
    #> 1. ( <double[,1]> , <double[,2]> ) = <double[,2]>
    
    vec_ptype_show(
      array(1, c(0, 1)), 
      array(1, c(0, 3)),
      array(1, c(0, 3, 4)),
      array(1, c(0, 3, 4, 5))
    )
    #> Prototype: <double[,3,4,5]>
    #> 0. (                , <double[,1]>     ) = <double[,1]>    
    #> 1. ( <double[,1]>   , <double[,3]>     ) = <double[,3]>    
    #> 2. ( <double[,3]>   , <double[,3,4]>   ) = <double[,3,4]>  
    #> 3. ( <double[,3,4]> , <double[,3,4,5]> ) = <double[,3,4,5]>

    Provided that the dimensions follow the vctrs recycling rules:

    vec_ptype_show(
      array(1, c(0, 2)), 
      array(1, c(0, 3))
    )
    #> Error: Incompatible lengths: 2, 3.
  • Factors combine levels in the order in which they appear.

    fa <- factor("a")
    fb <- factor("b")
    
    levels(vec_ptype_common(fa, fb))
    #> [1] "a" "b"
    levels(vec_ptype_common(fb, fa))
    #> [1] "b" "a"
  • Combining a date and date-time yields a date-time:

    vec_ptype_show(new_date(), new_datetime())
    #> Prototype: <datetime<local>>
    #> 0. (        , <date>            ) = <date>           
    #> 1. ( <date> , <datetime<local>> ) = <datetime<local>>

    When combining two date times, the timezone is taken from the first input:

    vec_ptype_show(
      new_datetime(tzone = "US/Central"), 
      new_datetime(tzone = "Pacific/Auckland")
    )
    #> Prototype: <datetime<US/Central>>
    #> 0. (                        , <datetime<US/Central>>       ) = <datetime<US/Central>>
    #> 1. ( <datetime<US/Central>> , <datetime<Pacific/Auckland>> ) = <datetime<US/Central>>

    Unless it’s the local timezone, in which case any explicit time zone will win:

    vec_ptype_show(
      new_datetime(tzone = ""), 
      new_datetime(tzone = ""), 
      new_datetime(tzone = "Pacific/Auckland")
    )
    #> Prototype: <datetime<Pacific/Auckland>>
    #> 0. (                   , <datetime<local>>            ) = <datetime<local>>           
    #> 1. ( <datetime<local>> , <datetime<local>>            ) = <datetime<local>>           
    #> 2. ( <datetime<local>> , <datetime<Pacific/Auckland>> ) = <datetime<Pacific/Auckland>>
  • The common type of two data frames is the common type of each column that occurs in both data frames:

    vec_ptype_show(
      data.frame(x = FALSE), 
      data.frame(x = 1L),
      data.frame(x = 2.5)
    )
    #> Prototype: <data.frame<x:double>>
    #> 0. (                         , <data.frame<x:logical>> ) = <data.frame<x:logical>>
    #> 1. ( <data.frame<x:logical>> , <data.frame<x:integer>> ) = <data.frame<x:integer>>
    #> 2. ( <data.frame<x:integer>> , <data.frame<x:double>>  ) = <data.frame<x:double>>

    And the union of the columns that only occur in one:

    vec_ptype_show(data.frame(x = 1, y = 1), data.frame(y = 1, z = 1))
    #> Prototype: <data.frame<
    #>   x: double
    #>   y: double
    #>   z: double
    #> >>
    #> 0. ┌              , <data.frame< ┐ = <data.frame<
    #>    │                  x: double  │     x: double 
    #>    │                  y: double  │     y: double 
    #>    └                >>           ┘   >>          
    #> 1. ┌ <data.frame< , <data.frame< ┐ = <data.frame<
    #>    │   x: double      y: double  │     x: double 
    #>    │   y: double      z: double  │     y: double 
    #>    │ >>             >>           │     z: double 
    #>    └                             ┘   >>

    Note that new columns are added on the right-hand side. This is consistent with the way that factor levels and time zones are handled.

Casting to specified type

vec_ptype_common() finds the common type of a set of vector. Typically, however, what you want is a set of vectors coerced to that common type. That’s the job of vec_cast_common():

str(vec_cast_common(
  FALSE, 
  1:5, 
  2.5
))
#> List of 3
#>  $ : num 0
#>  $ : num [1:5] 1 2 3 4 5
#>  $ : num 2.5

str(vec_cast_common(
  factor("x"), 
  factor("y")
))
#> List of 2
#>  $ : Factor w/ 2 levels "x","y": 1
#>  $ : Factor w/ 2 levels "x","y": 2

str(vec_cast_common(
  data.frame(x = 1),
  data.frame(y = 1:2)
))
#> List of 2
#>  $ :'data.frame':    1 obs. of  2 variables:
#>   ..$ x: num 1
#>   ..$ y: int NA
#>  $ :'data.frame':    2 obs. of  2 variables:
#>   ..$ x: num [1:2] NA NA
#>   ..$ y: int [1:2] 1 2

Alternatively, you can cast to a specific prototype using vec_cast():

# Cast succeeds
vec_cast(c(1, 2), integer())
#> [1] 1 2

# Cast fails
vec_cast(c(1.5, 2.5), factor("a"))
#> Error: Can't cast `x` <double> to `to` <factor<127a2>>.

If a cast is possible in general (i.e., double -> integer), but information is lost for a specific input (e.g. 1.5 -> 1), it will generate an error.

vec_cast(c(1.5, 2), integer())
#> Error: Lossy cast from `x` <double> to `to` <integer>.
#> * Locations: 1

You can suppress the lossy cast errors with allow_lossy_cast():

allow_lossy_cast(
  vec_cast(c(1.5, 2), integer())
)
#> [1] 1 2

This will suppress all lossy cast errors. Supply prototypes if you want to be specific about the type of lossy cast allowed:

allow_lossy_cast(
  vec_cast(c(1.5, 2), integer()),
  x_ptype = double(),
  to_ptype = integer()
)
#> [1] 1 2

The set of casts is more permissive than the set of coercions and is summarised in the diagram below. Coercions are shown by arrows; possible casts are shown with circles.

Summary of vctrs casting rules

Size

vec_size() was motivated by the need to have an invariant that describes the number of “observations” in a data structure. This is particularly important for data frames, as it’s useful to have some function such that f(data.frame(x)) equals f(x). No base function has this property:

  • length(data.frame(x)) equals 1 because the length of a data frame is the number of columns.

  • nrow(data.frame(x)) does not equal nrow(x) because nrow() of a vector is NULL.

  • NROW(data.frame(x)) equals NROW(x) for vector x, so is almost what we want. But because NROW() is defined in terms of length(), it returns a value for every object, even types that can’t go in a data frame, e.g. data.frame(mean) errors even though NROW(mean) is 1.

We define vec_size() as follows:

  • It is the length of 1d vectors.
  • It is the number of rows of data frames, matrices, and arrays.
  • It throws error for non vectors.

Given vec_size(), we can give a precise definition of a data frame: a data frame is a list of vectors where every vector has the same size. This has the desirable property of trivially supporting matrix and data frame columns.

Slicing

vec_slice() is to vec_size() as [ is to length(); i.e., it allows you to select observations regardless of the dimensionality of the underlying object. vec_slice(x, i) is equivalent to:

  • x[i] when x is a vector.
  • x[i, , drop = FALSE] when x is a data frame.
  • x[i, , , drop = FALSE] when x is a 3d array.
x <- sample(1:10)
df <- data.frame(x = x)

vec_slice(x, 5:6)
#> [1] 8 2
vec_slice(df, 5:6)
#>   x
#> 1 8
#> 2 2

vec_slice(data.frame(x), i) equals data.frame(vec_slice(x, i)) (modulo variable and row names).

Prototypes are generated with vec_slice(x, 0L); given a prototype, you can initialize a vector of given size (filled with NAs) with vec_init().

Common sizes: recycling rules

Closely related to the definition of size are the recycling rules. The recycling rules determine the size of the output when two vectors of different sizes are combined. In vctrs, the recycling rules are encoded in vec_size_common(), which gives the common size of a set of vectors:

vec_size_common(1:3, 1:3, 1:3)
#> [1] 3
vec_size_common(1:10, 1)
#> [1] 10
vec_size_common(integer(), 1)
#> [1] 0

vctrs obeys a stricter set of recycling rules than base R. Vectors of size 1 are recycled to any other size. All other size combinations will generate an error. This strictness prevents common mistakes like dest == c("IAH", "HOU")), at the cost of occasionally requiring an explicit calls to rep().

Summary of vctrs recycling rules. X indicates n error

You can apply the recycling rules in two ways:

  • If you have a vector and desired size, use vec_recycle():

    vec_recycle(1:3, 3)
    #> [1] 1 2 3
    vec_recycle(1, 10)
    #>  [1] 1 1 1 1 1 1 1 1 1 1
  • If you have multiple vectors and you want to recycle them to the same size, use vec_recycle_common():

    vec_recycle_common(1:3, 1:3)
    #> [[1]]
    #> [1] 1 2 3
    #> 
    #> [[2]]
    #> [1] 1 2 3
    vec_recycle_common(1:10, 1)
    #> [[1]]
    #>  [1]  1  2  3  4  5  6  7  8  9 10
    #> 
    #> [[2]]
    #>  [1] 1 1 1 1 1 1 1 1 1 1

Appendix: recycling in base R

The recycling rules in base R are described in The R Language Definition but are not implemented in a single function and thus are not applied consistently. Here, I give a brief overview of their most common realisation, as well as showing some of the exceptions.

Generally, in base R, when a pair of vectors is not the same length, the shorter vector is recycled to the same length as the longer:

rep(1, 6) + 1
#> [1] 2 2 2 2 2 2
rep(1, 6) + 1:2
#> [1] 2 3 2 3 2 3
rep(1, 6) + 1:3
#> [1] 2 3 4 2 3 4

If the length of the longer vector is not an integer multiple of the length of the shorter, you usually get a warning:

invisible(pmax(1:2, 1:3))
#> Warning in pmax(1:2, 1:3): an argument will be fractionally recycled
invisible(1:2 + 1:3)
#> Warning in 1:2 + 1:3: longer object length is not a multiple of shorter object
#> length
invisible(cbind(1:2, 1:3))
#> Warning in cbind(1:2, 1:3): number of rows of result is not a multiple of vector
#> length (arg 1)

But some functions recycle silently:

length(atan2(1:3, 1:2))
#> [1] 3
length(paste(1:3, 1:2))
#> [1] 3
length(ifelse(1:3, 1:2, 1:2))
#> [1] 3

And data.frame() throws an error:

data.frame(1:2, 1:3)
#> Error in data.frame(1:2, 1:3): arguments imply differing number of rows: 2, 3

The R language definition states that “any arithmetic operation involving a zero-length vector has a zero-length result”. But outside of arithmetic, this rule is not consistently followed:

# length-0 output
1:2 + integer()
#> integer(0)
atan2(1:2, integer())
#> numeric(0)
pmax(1:2, integer())
#> integer(0)

# dropped
cbind(1:2, integer())
#>      [,1]
#> [1,]    1
#> [2,]    2

# recycled to length of first
ifelse(rep(TRUE, 4), integer(), character())
#> [1] NA NA NA NA

# preserved-ish
paste(1:2, integer())
#> [1] "1 " "2 "

# Errors
data.frame(1:2, integer())
#> Error in data.frame(1:2, integer()): arguments imply differing number of rows: 2, 0
vctrs/inst/doc/stability.html0000644000176200001440000013232313623213402016027 0ustar liggesusers Type and size stability

Type and size stability

This vignette introduces the ideas of type-stability and size-stability. If a function possesses these properties, it is substantially easier to reason about because to predict the “shape” of the output you only need to know the “shape”s of the inputs.

This work is partly motivated by a common pattern that I noticed when reviewing code: if I read the code (without running it!), and I can’t predict the type of each variable, I feel very uneasy about the code. This sense is important because most unit tests explore typical inputs, rather than exhaustively testing the strange and unusual. Analysing the types (and size) of variables makes it possible to spot unpleasant edge cases.

library(vctrs)
library(zeallot)

Definitions

We say a function is type-stable iff:

  1. You can predict the output type knowing only the input types.
  2. The order of arguments in … does not affect the output type.

Similarly, a function is size-stable iff:

  1. You can predict the output size knowing only the input sizes, or there is a single numeric input that specifies the output size.

Very few base R functions are size-stable, so I’ll also define a slightly weaker condition. I’ll call a function length-stable iff:

  1. You can predict the output length knowing only the input lengths, or there is a single numeric input that specifies the output length.

(But note that length-stable is not a particularly robust definition because length() returns a value for things that are not vectors.)

We’ll call functions that don’t obey these principles type-unstable and size-unstable respectively.

On top of type- and size-stability it’s also desirable to have a single set of rules that are applied consistently. We want one set of type-coercion and size-recycling rules that apply everywhere, not many sets of rules that apply to different functions.

The goal of these principles is to minimise cognitive overhead. Rather than having to memorise many special cases, you should be able to learn one set of principles and apply them again and again.

Examples

To make these ideas concrete, let’s apply them to a few base functions:

  1. mean() is trivially type-stable and size-stable because it always returns a double vector of length 1 (or it throws an error).

  2. Surprisingly, median() is type-unstable:

    vec_ptype_show(median(c(1L, 1L)))
    #> Prototype: double
    vec_ptype_show(median(c(1L, 1L, 1L)))
    #> Prototype: integer

    It is, however, size-stable, since it always returns a vector of length 1.

  3. sapply() is type-unstable because you can’t predict the output type only knowing the input types:

    vec_ptype_show(sapply(1L, function(x) c(x, x)))
    #> Prototype: integer[,1]
    vec_ptype_show(sapply(integer(), function(x) c(x, x)))
    #> Prototype: list

    It’s not quite size-stable; vec_size(sapply(x, f)) is vec_size(x) for vectors but not for matrices (the output is transposed) or data frames (it iterates over the columns).

  4. vapply() is a type-stable version of sapply() because vec_ptype_show(vapply(x, fn, template)) is always vec_ptype_show(template).
    It is size-unstable for the same reasons as sapply().

  5. c() is type-unstable because c(x, y) doesn’t always output the same type as c(y, x).

    vec_ptype_show(c(NA, Sys.Date()))
    #> Prototype: double
    vec_ptype_show(c(Sys.Date(), NA))
    #> Prototype: date

    c() is almost always length-stable because length(c(x, y)) almost always equals length(x) + length(y). One common source of instability here is dealing with non-vectors (see the later section “Non-vectors”):

    env <- new.env(parent = emptyenv())
    length(env)
    #> [1] 0
    length(mean)
    #> [1] 1
    length(c(env, mean))
    #> [1] 2
  6. paste(x1, x2) is length-stable because length(paste(x1, x2)) equals max(length(x1), length(x2)). However, it doesn’t follow the usual arithmetic recycling rules because paste(1:2, 1:3) doesn’t generate a warning.

  7. ifelse() is length-stable because length(ifelse(cond, true, false)) is always length(cond). ifelse() is type-unstable because the output type depends on the value of cond:

    vec_ptype_show(ifelse(NA, 1L, 1L))
    #> Prototype: logical
    vec_ptype_show(ifelse(FALSE, 1L, 1L))
    #> Prototype: integer
  8. read.csv(file) is type-unstable and size-unstable because, while you know it will return a data frame, you don’t know what columns it will return or how many rows it will have. Similarly, df[[i]] is not type-stable because the result depends on the value of i. There are very many important functions that can not be made type-stable or size-stable!

With this understanding of type- and size-stability in hand, we’ll use them to analyse some base R functions in greater depth and then propose alternatives with better properties.

c() and vctrs::vec_c()

In this section we’ll compare and contrast c() and vec_c(). vec_c() is both type- and size-stable because it possesses the following invariants:

  • vec_ptype(vec_c(x, y)) equals vec_ptype_common(x, y).
  • vec_size(vec_c(x, y)) equals vec_size(x) + vec_size(y).

c() has another undesirable property in that it’s not consistent with unlist(); i.e., unlist(list(x, y)) does not always equal c(x, y); i.e., base R has multiple sets of type-coercion rules. I won’t consider this problem further here.

I have two goals here:

  • To fully document the quirks of c(), hence motivating the development of an alternative.

  • To discuss non-obvious consequences of the type- and size-stability above.

Atomic vectors

If we only consider atomic vectors, c() is type-stable because it uses a hierarchy of types: character > complex > double > integer > logical.

c(FALSE, 1L, 2.5)
#> [1] 0.0 1.0 2.5

vec_c() obeys similar rules:

vec_c(FALSE, 1L, 2.5)
#> [1] 0.0 1.0 2.5

But it does not automatically coerce to character vectors or lists:

c(FALSE, "x")
#> [1] "FALSE" "x"
vec_c(FALSE, "x")
#> Error: No common type for `..1` <logical> and `..2` <character>.

c(FALSE, list(1))
#> [[1]]
#> [1] FALSE
#> 
#> [[2]]
#> [1] 1
vec_c(FALSE, list(1))
#> Error: No common type for `..1` <logical> and `..2` <list>.

Non-vectors

As far as I can tell, c() never throws an error. No matter how bizarre the inputs, it always returns something:

c(Sys.Date(), factor("x"), "x")
#> Warning in as.POSIXlt.Date(x): NAs introduced by coercion
#> [1] "2020-02-19" "1970-01-02" NA

If the inputs aren’t vectors, c() automatically puts them in a list:

c(mean, globalenv())
#> [[1]]
#> function (x, ...) 
#> UseMethod("mean")
#> <bytecode: 0x7fd3f09f0758>
#> <environment: namespace:base>
#> 
#> [[2]]
#> <environment: R_GlobalEnv>

vec_c() throws an error if the inputs are not vectors or not automatically coercible:

vec_c(mean, globalenv())
#> Error: `..1` must be a vector, not a function

vec_c(Sys.Date(), factor("x"), "x")
#> Error: No common type for `..1` <date> and `..2` <factor<5a425>>.

Factors

Combining two factors returns an integer vector:

fa <- factor("a")
fb <- factor("b")

c(fa, fb)
#> [1] 1 1

(This is documented in c() but is still undesirable.)

vec_c() returns a factor taking the union of the levels. This behaviour is motivated by pragmatics: there are many places in base R that automatically convert character vectors to factors, so enforcing stricter behaviour would be unnecessarily onerous. (This is backed up by experience with dplyr::bind_rows(), which is stricter and is a common source of user difficulty.)

vec_c(fa, fb)
#> [1] a b
#> Levels: a b
vec_c(fb, fa)
#> [1] b a
#> Levels: b a

Date-times

c() strips the time zone associated with date-times:

datetime_nz <- as.POSIXct("2020-01-01 09:00", tz = "Pacific/Auckland")
c(datetime_nz)
#> [1] "2019-12-31 21:00:00 CET"

This behaviour is documented in ?DateTimeClasses but is the source of considerable user pain.

vec_c() preserves time zones:

vec_c(datetime_nz)
#> [1] "2020-01-01 09:00:00 NZDT"

What time zone should the output have if inputs have different time zones? One option would be to be strict and force the user to manually align all the time zones. However, this is onerous (particularly because there’s no easy way to change the time zone in base R), so vctrs chooses to use the first non-local time zone:

datetime_local <- as.POSIXct("2020-01-01 09:00")
datetime_houston <- as.POSIXct("2020-01-01 09:00", tz = "US/Central")

vec_c(datetime_local, datetime_houston, datetime_nz)
#> [1] "2020-01-01 02:00:00 CST" "2020-01-01 09:00:00 CST"
#> [3] "2019-12-31 14:00:00 CST"
vec_c(datetime_houston, datetime_nz)
#> [1] "2020-01-01 09:00:00 CST" "2019-12-31 14:00:00 CST"
vec_c(datetime_nz, datetime_houston)
#> [1] "2020-01-01 09:00:00 NZDT" "2020-01-02 04:00:00 NZDT"

Dates and date-times

Combining dates and date-times with c() gives silently incorrect results:

date <- as.Date("2020-01-01")
datetime <- as.POSIXct("2020-01-01 09:00")

c(date, datetime)
#> [1] "2020-01-01"    "4322019-04-14"
c(datetime, date)
#> [1] "2020-01-01 09:00:00 CET" "1970-01-01 06:04:22 CET"

This behaviour arises because neither c.Date() nor c.POSIXct() check that all inputs are of the same type.

vec_c() uses a standard set of rules to avoid this problem. When you mix dates and date-times, vctrs returns a date-time and converts dates to date-times at midnight (in the timezone of the date-time).

vec_c(date, datetime)
#> [1] "2020-01-01 00:00:00 CET" "2020-01-01 09:00:00 CET"
vec_c(date, datetime_nz)
#> [1] "2020-01-01 00:00:00 NZDT" "2020-01-01 09:00:00 NZDT"

Missing values

If a missing value comes at the beginning of the inputs, c() falls back to the internal behaviour, which strips all attributes:

c(NA, fa)
#> [1] NA  1
c(NA, date)
#> [1]    NA 18262
c(NA, datetime)
#> [1]         NA 1577865600

vec_c() takes a different approach treating a logical vector consisting only of NA as the unspecified() class which can be converted to any other 1d type:

vec_c(NA, fa)
#> [1] <NA> a   
#> Levels: a
vec_c(NA, date)
#> [1] NA           "2020-01-01"
vec_c(NA, datetime)
#> [1] NA                        "2020-01-01 09:00:00 CET"

Data frames

Because it is almost always length-stable, c() combines data frames column wise (into a list):

df1 <- data.frame(x = 1)
df2 <- data.frame(x = 2)
str(c(df1, df1))
#> List of 2
#>  $ x: num 1
#>  $ x: num 1

vec_c() is size-stable, which implies it will row-bind data frames:

vec_c(df1, df2)
#>   x
#> 1 1
#> 2 2

Matrices and arrays

The same reasoning applies to matrices:

m <- matrix(1:4, nrow = 2)
c(m, m)
#> [1] 1 2 3 4 1 2 3 4
vec_c(m, m)
#>      [,1] [,2]
#> [1,]    1    3
#> [2,]    2    4
#> [3,]    1    3
#> [4,]    2    4

One difference is that vec_c() will “broadcast” a vector to match the dimensions of a matrix:

c(m, 1)
#> [1] 1 2 3 4 1

vec_c(m, 1)
#>      [,1] [,2]
#> [1,]    1    3
#> [2,]    2    4
#> [3,]    1    1

Implementation

The basic implementation of vec_c() is reasonably simple. We first figure out the properties of the output, i.e. the common type and total size, and then allocate it with vec_init(), and then insert each input into the correct place in the output.

vec_c <- function(...) {
  args <- compact(list2(...))

  ptype <- vec_ptype_common(!!!args)
  if (is.null(ptype))
    return(NULL)

  ns <- map_int(args, vec_size)
  out <- vec_init(ptype, sum(ns))

  pos <- 1
  for (i in seq_along(ns)) {
    n <- ns[[i]]
    
    x <- vec_cast(args[[i]], to = ptype)
    vec_slice(out, pos:(pos + n - 1)) <- x
    pos <- pos + n
  }

  out
}

(The real vec_c() is a bit more complicated in order to handle inner and outer names).

ifelse()

One of the functions that motivate the development of vctrs is ifelse. It has the surprising property that the result value is “A vector of the same length and attributes (including dimensions and class) as test”. To me, it seems more reasonable for the type of the output to be controlled by the type of the yes and no arguments.

In dplyr::if_else() I swung too far towards strictness: it throws an error if yes and no are not the same type. This is annoying in practice because it requires typed missing values (NA_character_ etc), and because the checks are only on the class (not the full prototype), it’s easy to create invalid output.

I found it much easier understand what ifelse() should do once I internalised the ideas of type- and size-stability:

  • The first argument must be logical.

  • vec_ptype(if_else(test, yes, no)) equals vec_ptype_common(yes, no). Unlike ifelse() this implies that if_else() must always evaluate both yes and no in order to figure out the correct type. I think this is consistent with && (scalar operation, short circuits) and & (vectorised, evaluates both sides).

  • vec_size(if_else(test, yes, no)) equals vec_size_common(test, yes, no). I think the output could have the same size as test (i.e., the same behaviour as ifelse), but I think as a general rule that your inputs should either be mutually recycling or not.

This leads to the following implementation:

if_else <- function(test, yes, no) {
  vec_assert(test, logical())
  c(yes, no) %<-% vec_cast_common(yes, no)
  c(test, yes, no) %<-% vec_recycle_common(test, yes, no)

  out <- vec_init(yes, vec_size(yes))
  vec_slice(out, test) <- vec_slice(yes, test)
  vec_slice(out, !test) <- vec_slice(no, !test)

  out
}

x <- c(NA, 1:4)
if_else(x > 2, "small", "big")
#> [1] NA      "big"   "big"   "small" "small"
if_else(x > 2, factor("small"), factor("big"))
#> [1] <NA>  big   big   small small
#> Levels: small big
if_else(x > 2, Sys.Date(), Sys.Date() + 7)
#> [1] NA           "2020-02-26" "2020-02-26" "2020-02-19" "2020-02-19"

By using vec_size() and vec_slice(), this definition of if_else() automatically works with data.frames and matrices:

if_else(x > 2, data.frame(x = 1), data.frame(y = 2))
#>    x  y
#> 1 NA NA
#> 2 NA  2
#> 3 NA  2
#> 4  1 NA
#> 5  1 NA

if_else(x > 2, matrix(1:10, ncol = 2), cbind(30, 30))
#>      [,1] [,2]
#> [1,]   NA   NA
#> [2,]   30   30
#> [3,]   30   30
#> [4,]    4    9
#> [5,]    5   10
vctrs/inst/include/0000755000176200001440000000000013623213417014015 5ustar liggesusersvctrs/inst/include/vctrs.c0000644000176200001440000000160213622451540015321 0ustar liggesusers#include "vctrs.h" SEXP (*vec_proxy)(SEXP) = NULL; SEXP (*vec_restore)(SEXP, SEXP, SEXP) = NULL; SEXP (*vec_assign_impl)(SEXP, SEXP, SEXP, bool) = NULL; SEXP (*vec_slice_impl)(SEXP, SEXP) = NULL; SEXP (*vec_names)(SEXP) = NULL; SEXP (*vec_set_names)(SEXP, SEXP) = NULL; SEXP (*vec_chop)(SEXP, SEXP) = NULL; void vctrs_init_api() { vec_proxy = (SEXP (*)(SEXP)) R_GetCCallable("vctrs", "vec_proxy"); vec_restore = (SEXP (*)(SEXP, SEXP, SEXP)) R_GetCCallable("vctrs", "vec_restore"); vec_assign_impl = (SEXP (*)(SEXP, SEXP, SEXP, bool)) R_GetCCallable("vctrs", "vec_assign_impl"); vec_slice_impl = (SEXP (*)(SEXP, SEXP)) R_GetCCallable("vctrs", "vec_slice_impl"); vec_names = (SEXP (*)(SEXP)) R_GetCCallable("vctrs", "vec_names"); vec_set_names = (SEXP (*)(SEXP, SEXP)) R_GetCCallable("vctrs", "vec_set_names"); vec_chop = (SEXP (*)(SEXP, SEXP)) R_GetCCallable("vctrs", "vec_chop"); } vctrs/inst/include/vctrs.h0000644000176200001440000000065313623046060015331 0ustar liggesusers#ifndef VCTRS_H #define VCTRS_H #include #include #include extern SEXP (*vec_proxy)(SEXP); extern SEXP (*vec_restore)(SEXP, SEXP, SEXP); extern SEXP (*vec_assign_impl)(SEXP, SEXP, SEXP, bool); extern SEXP (*vec_slice_impl)(SEXP, SEXP); extern SEXP (*vec_names)(SEXP); extern SEXP (*vec_set_names)(SEXP, SEXP); extern SEXP (*vec_chop)(SEXP, SEXP); void vctrs_init_api(); #endif vctrs/inst/WORDLIST0000644000176200001440000000001313473164157013567 0ustar liggesusersvectorised