dplyr/0000755000176200001440000000000013615060710011403 5ustar liggesusersdplyr/NAMESPACE0000644000176200001440000002703413614573561012644 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method("[",fun_list) S3method("[",grouped_df) S3method(all.equal,tbl_df) S3method(anti_join,data.frame) S3method(anti_join,tbl_df) S3method(arrange,data.frame) S3method(arrange,default) S3method(arrange,grouped_df) S3method(arrange,tbl_df) S3method(arrange_,data.frame) S3method(arrange_,tbl_df) S3method(as.data.frame,grouped_df) S3method(as.data.frame,rowwise_df) S3method(as.data.frame,tbl_cube) S3method(as.table,tbl_cube) S3method(as.tbl,data.frame) S3method(as.tbl,tbl) S3method(as.tbl_cube,array) S3method(as.tbl_cube,data.frame) S3method(as.tbl_cube,matrix) S3method(as.tbl_cube,table) S3method(as_tibble,grouped_df) S3method(as_tibble,tbl_cube) S3method(auto_copy,tbl_cube) S3method(auto_copy,tbl_df) S3method(cbind,grouped_df) S3method(collapse,data.frame) S3method(collect,data.frame) S3method(common_by,"NULL") S3method(common_by,character) S3method(common_by,default) S3method(common_by,list) S3method(compute,data.frame) S3method(copy_to,DBIConnection) S3method(copy_to,src_local) S3method(default_missing,data.frame) S3method(default_missing,default) S3method(dim,tbl_cube) S3method(distinct,data.frame) S3method(distinct,default) S3method(distinct,grouped_df) S3method(distinct,tbl_df) S3method(distinct_,data.frame) S3method(distinct_,grouped_df) S3method(distinct_,tbl_df) S3method(do,"NULL") S3method(do,data.frame) S3method(do,default) S3method(do,grouped_df) S3method(do,rowwise_df) S3method(do_,"NULL") S3method(do_,data.frame) S3method(do_,grouped_df) S3method(do_,rowwise_df) S3method(filter,data.frame) S3method(filter,default) S3method(filter,tbl_cube) S3method(filter,tbl_df) S3method(filter,ts) S3method(filter_,data.frame) S3method(filter_,tbl_cube) S3method(filter_,tbl_df) S3method(format,src_local) S3method(full_join,data.frame) S3method(full_join,tbl_df) S3method(group_by,data.frame) S3method(group_by,default) S3method(group_by,rowwise_df) S3method(group_by,tbl_cube) S3method(group_by_,data.frame) S3method(group_by_,rowwise_df) S3method(group_by_,tbl_cube) S3method(group_by_drop_default,default) S3method(group_by_drop_default,grouped_df) S3method(group_data,data.frame) S3method(group_data,grouped_df) S3method(group_data,rowwise_df) S3method(group_indices,data.frame) S3method(group_indices,default) S3method(group_indices,grouped_df) S3method(group_indices,rowwise_df) S3method(group_indices_,data.frame) S3method(group_indices_,grouped_df) S3method(group_indices_,rowwise_df) S3method(group_keys,data.frame) S3method(group_keys,grouped_df) S3method(group_keys,rowwise_df) S3method(group_modify,data.frame) S3method(group_modify,grouped_df) S3method(group_nest,data.frame) S3method(group_nest,grouped_df) S3method(group_size,data.frame) S3method(group_size,grouped_df) S3method(group_size,rowwise_df) S3method(group_split,data.frame) S3method(group_split,grouped_df) S3method(group_split,rowwise_df) S3method(group_trim,data.frame) S3method(group_trim,grouped_df) S3method(group_vars,default) S3method(group_vars,grouped_df) S3method(group_vars,tbl_cube) S3method(groups,default) S3method(groups,grouped_df) S3method(groups,tbl_cube) S3method(hybrid_call,data.frame) S3method(inner_join,data.frame) S3method(inner_join,tbl_df) S3method(intersect,data.frame) S3method(intersect,default) S3method(left_join,data.frame) S3method(left_join,tbl_df) S3method(mutate,data.frame) S3method(mutate,default) S3method(mutate,tbl_df) S3method(mutate_,data.frame) S3method(mutate_,tbl_df) S3method(n_groups,data.frame) S3method(n_groups,grouped_df) S3method(n_groups,rowwise_df) S3method(nest_join,data.frame) S3method(nest_join,tbl_df) S3method(print,BoolResult) S3method(print,all_vars) S3method(print,any_vars) S3method(print,dplyr_sel_vars) S3method(print,fun_list) S3method(print,hybrid_call) S3method(print,location) S3method(print,rowwise_df) S3method(print,src) S3method(print,tbl_cube) S3method(pull,data.frame) S3method(rbind,grouped_df) S3method(recode,character) S3method(recode,factor) S3method(recode,numeric) S3method(rename,data.frame) S3method(rename,default) S3method(rename,grouped_df) S3method(rename,tbl_cube) S3method(rename_,data.frame) S3method(rename_,grouped_df) S3method(rename_,tbl_cube) S3method(right_join,data.frame) S3method(right_join,tbl_df) S3method(same_src,data.frame) S3method(same_src,tbl_cube) S3method(sample_frac,data.frame) S3method(sample_frac,default) S3method(sample_n,data.frame) S3method(sample_n,default) S3method(select,data.frame) S3method(select,default) S3method(select,grouped_df) S3method(select,list) S3method(select,tbl_cube) S3method(select_,data.frame) S3method(select_,grouped_df) S3method(select_,tbl_cube) S3method(semi_join,data.frame) S3method(semi_join,tbl_df) S3method(setdiff,data.frame) S3method(setdiff,default) S3method(setequal,data.frame) S3method(setequal,default) S3method(slice,data.frame) S3method(slice,default) S3method(slice,tbl_df) S3method(slice_,data.frame) S3method(slice_,tbl_df) S3method(src_tbls,src_local) S3method(summarise,data.frame) S3method(summarise,default) S3method(summarise,tbl_cube) S3method(summarise,tbl_df) S3method(summarise_,data.frame) S3method(summarise_,tbl_cube) S3method(summarise_,tbl_df) S3method(tbl,DBIConnection) S3method(tbl,src_local) S3method(tbl_sum,grouped_df) S3method(tbl_vars,data.frame) S3method(tbl_vars,tbl_cube) S3method(transmute,default) S3method(transmute,grouped_df) S3method(transmute_,default) S3method(transmute_,grouped_df) S3method(ungroup,data.frame) S3method(ungroup,grouped_df) S3method(ungroup,rowwise_df) S3method(union,data.frame) S3method(union,default) S3method(union_all,data.frame) S3method(union_all,default) export("%>%") export(.data) export(add_count) export(add_count_) export(add_row) export(add_rownames) export(add_tally) export(add_tally_) export(all_equal) export(all_vars) export(anti_join) export(any_vars) export(arrange) export(arrange_) export(arrange_all) export(arrange_at) export(arrange_if) export(as.tbl) export(as.tbl_cube) export(as_data_frame) export(as_label) export(as_tibble) export(auto_copy) export(bench_tbls) export(between) export(bind_cols) export(bind_rows) export(case_when) export(changes) export(check_dbplyr) export(coalesce) export(collapse) export(collect) export(combine) export(common_by) export(compare_tbls) export(compare_tbls2) export(compute) export(contains) export(copy_to) export(count) export(count_) export(cumall) export(cumany) export(cume_dist) export(cummean) export(current_vars) export(data_frame) export(data_frame_) export(db_analyze) export(db_begin) export(db_commit) export(db_create_index) export(db_create_indexes) export(db_create_table) export(db_data_type) export(db_desc) export(db_drop_table) export(db_explain) export(db_has_table) export(db_insert_into) export(db_list_tables) export(db_query_fields) export(db_query_rows) export(db_rollback) export(db_save_query) export(db_write_table) export(dense_rank) export(desc) export(dim_desc) export(distinct) export(distinct_) export(distinct_all) export(distinct_at) export(distinct_if) export(distinct_prepare) export(do) export(do_) export(dr_dplyr) export(ends_with) export(enexpr) export(enexprs) export(enquo) export(enquos) export(ensym) export(ensyms) export(eval_tbls) export(eval_tbls2) export(everything) export(explain) export(expr) export(failwith) export(filter) export(filter_) export(filter_all) export(filter_at) export(filter_if) export(first) export(frame_data) export(full_join) export(funs) export(funs_) export(glimpse) export(group_by) export(group_by_) export(group_by_all) export(group_by_at) export(group_by_drop_default) export(group_by_if) export(group_by_prepare) export(group_cols) export(group_data) export(group_indices) export(group_indices_) export(group_keys) export(group_map) export(group_modify) export(group_nest) export(group_rows) export(group_size) export(group_split) export(group_trim) export(group_vars) export(group_walk) export(grouped_df) export(groups) export(hybrid_call) export(id) export(ident) export(if_else) export(inner_join) export(intersect) export(is.grouped_df) export(is.src) export(is.tbl) export(is_grouped_df) export(lag) export(last) export(last_col) export(lead) export(left_join) export(location) export(lst) export(lst_) export(make_tbl) export(matches) export(min_rank) export(mutate) export(mutate_) export(mutate_all) export(mutate_at) export(mutate_each) export(mutate_each_) export(mutate_if) export(n) export(n_distinct) export(n_groups) export(na_if) export(near) export(nest_join) export(new_grouped_df) export(nth) export(ntile) export(num_range) export(one_of) export(order_by) export(percent_rank) export(progress_estimated) export(pull) export(quo) export(quo_name) export(quos) export(rbind_all) export(rbind_list) export(recode) export(recode_factor) export(rename) export(rename_) export(rename_all) export(rename_at) export(rename_if) export(rename_vars) export(rename_vars_) export(right_join) export(row_number) export(rowwise) export(same_src) export(sample_frac) export(sample_n) export(select) export(select_) export(select_all) export(select_at) export(select_if) export(select_var) export(select_vars) export(select_vars_) export(semi_join) export(setdiff) export(setequal) export(show_query) export(slice) export(slice_) export(sql) export(sql_escape_ident) export(sql_escape_string) export(sql_join) export(sql_select) export(sql_semi_join) export(sql_set_op) export(sql_subquery) export(sql_translate_env) export(src) export(src_df) export(src_local) export(src_mysql) export(src_postgres) export(src_sqlite) export(src_tbls) export(starts_with) export(summarise) export(summarise_) export(summarise_all) export(summarise_at) export(summarise_each) export(summarise_each_) export(summarise_if) export(summarize) export(summarize_) export(summarize_all) export(summarize_at) export(summarize_each) export(summarize_each_) export(summarize_if) export(sym) export(syms) export(tally) export(tally_) export(tbl) export(tbl_cube) export(tbl_df) export(tbl_nongroup_vars) export(tbl_sum) export(tbl_vars) export(tibble) export(top_frac) export(top_n) export(transmute) export(transmute_) export(transmute_all) export(transmute_at) export(transmute_if) export(tribble) export(trunc_mat) export(type_sum) export(ungroup) export(union) export(union_all) export(validate_grouped_df) export(vars) export(with_order) export(wrap_dbplyr_obj) import(rlang) importFrom(R6,R6Class) importFrom(Rcpp,Rcpp.plugin.maker) importFrom(Rcpp,cppFunction) importFrom(assertthat,"on_failure<-") importFrom(assertthat,assert_that) importFrom(assertthat,is.flag) importFrom(glue,glue) importFrom(magrittr,"%>%") importFrom(methods,is) importFrom(pkgconfig,get_config) importFrom(rlang,":=") importFrom(rlang,.data) importFrom(rlang,as_label) importFrom(rlang,as_name) importFrom(rlang,dots_n) importFrom(rlang,enquo) importFrom(rlang,enquos) importFrom(rlang,expr) importFrom(rlang,sym) importFrom(rlang,syms) importFrom(stats,lag) importFrom(stats,setNames) importFrom(stats,update) importFrom(tibble,add_row) importFrom(tibble,as_data_frame) importFrom(tibble,as_tibble) importFrom(tibble,data_frame) importFrom(tibble,data_frame_) importFrom(tibble,frame_data) importFrom(tibble,glimpse) importFrom(tibble,is_tibble) importFrom(tibble,lst) importFrom(tibble,lst_) importFrom(tibble,new_tibble) importFrom(tibble,tbl_sum) importFrom(tibble,tibble) importFrom(tibble,tribble) importFrom(tibble,trunc_mat) importFrom(tibble,type_sum) importFrom(tibble,view) importFrom(tidyselect,contains) importFrom(tidyselect,ends_with) importFrom(tidyselect,everything) importFrom(tidyselect,last_col) importFrom(tidyselect,matches) importFrom(tidyselect,num_range) importFrom(tidyselect,one_of) importFrom(tidyselect,starts_with) importFrom(utils,head) importFrom(utils,tail) useDynLib(dplyr, .registration = TRUE) dplyr/LICENSE0000644000176200001440000000005213614573561012421 0ustar liggesusersYEAR: 2013-2015 COPYRIGHT HOLDER: RStudio dplyr/README.md0000644000176200001440000001335113614573562012702 0ustar liggesusers # dplyr [![CRAN status](https://www.r-pkg.org/badges/version/dplyr)](https://cran.r-project.org/package=dplyr) [![Travis build status](https://travis-ci.org/tidyverse/dplyr.svg?branch=master)](https://travis-ci.org/tidyverse/dplyr) [![AppVeyor build status](https://ci.appveyor.com/api/projects/status/github/tidyverse/dplyr?branch=master&svg=true)](https://ci.appveyor.com/project/tidyverse/dplyr) [![Codecov test coverage](https://codecov.io/gh/tidyverse/dplyr/branch/master/graph/badge.svg)](https://codecov.io/gh/tidyverse/dplyr?branch=master) ## Overview dplyr is a grammar of data manipulation, providing a consistent set of verbs that help you solve the most common data manipulation challenges: - `mutate()` adds new variables that are functions of existing variables - `select()` picks variables based on their names. - `filter()` picks cases based on their values. - `summarise()` reduces multiple values down to a single summary. - `arrange()` changes the ordering of the rows. These all combine naturally with `group_by()` which allows you to perform any operation “by group”. You can learn more about them in `vignette("dplyr")`. As well as these single-table verbs, dplyr also provides a variety of two-table verbs, which you can learn about in `vignette("two-table")`. dplyr is designed to abstract over how the data is stored. That means as well as working with local data frames, you can also work with remote database tables, using exactly the same R code. Install the dbplyr package then read `vignette("databases", package = "dbplyr")`. If you are new to dplyr, the best place to start is the [data import chapter](http://r4ds.had.co.nz/transform.html) in R for data science. ## Installation ``` r # The easiest way to get dplyr is to install the whole tidyverse: install.packages("tidyverse") # Alternatively, install just dplyr: install.packages("dplyr") ``` ### Development version To get a bug fix, or use a feature from the development version, you can install dplyr from GitHub. ``` r # install.packages("devtools") devtools::install_github("tidyverse/dplyr") ``` ## Cheatsheet ## Usage ``` r library(dplyr) starwars %>% filter(species == "Droid") #> # A tibble: 5 x 13 #> name height mass hair_color skin_color eye_color birth_year gender #> #> 1 C-3PO 167 75 gold yellow 112 #> 2 R2-D2 96 32 white, bl… red 33 #> 3 R5-D4 97 32 white, red red NA #> 4 IG-88 200 140 none metal red 15 none #> 5 BB8 NA NA none none black NA none #> # … with 5 more variables: homeworld , species , films , #> # vehicles , starships starwars %>% select(name, ends_with("color")) #> # A tibble: 87 x 4 #> name hair_color skin_color eye_color #> #> 1 Luke Skywalker blond fair blue #> 2 C-3PO gold yellow #> 3 R2-D2 white, blue red #> 4 Darth Vader none white yellow #> 5 Leia Organa brown light brown #> # … with 82 more rows starwars %>% mutate(name, bmi = mass / ((height / 100) ^ 2)) %>% select(name:mass, bmi) #> # A tibble: 87 x 4 #> name height mass bmi #> #> 1 Luke Skywalker 172 77 26.0 #> 2 C-3PO 167 75 26.9 #> 3 R2-D2 96 32 34.7 #> 4 Darth Vader 202 136 33.3 #> 5 Leia Organa 150 49 21.8 #> # … with 82 more rows starwars %>% arrange(desc(mass)) #> # A tibble: 87 x 13 #> name height mass hair_color skin_color eye_color birth_year gender #> #> 1 Jabb… 175 1358 green-tan… orange 600 herma… #> 2 Grie… 216 159 none brown, wh… green, y… NA male #> 3 IG-88 200 140 none metal red 15 none #> 4 Dart… 202 136 none white yellow 41.9 male #> 5 Tarf… 234 136 brown brown blue NA male #> # … with 82 more rows, and 5 more variables: homeworld , #> # species , films , vehicles , starships starwars %>% group_by(species) %>% summarise( n = n(), mass = mean(mass, na.rm = TRUE) ) %>% filter(n > 1, mass > 50) #> # A tibble: 8 x 3 #> species n mass #> #> 1 Droid 5 69.8 #> 2 Gungan 3 74 #> 3 Human 35 82.8 #> 4 Kaminoan 2 88 #> 5 Mirialan 2 53.1 #> # … with 3 more rows ``` ## Getting help If you encounter a clear bug, please file a minimal reproducible example on [github](https://github.com/tidyverse/dplyr/issues). For questions and other discussion, please use [community.rstudio.com](https://community.rstudio.com/), or the [manipulatr mailing list](https://groups.google.com/group/manipulatr). ----- Please note that this project is released with a [Contributor Code of Conduct](https://dplyr.tidyverse.org/CODE_OF_CONDUCT). By participating in this project you agree to abide by its terms. dplyr/data/0000755000176200001440000000000013614573562012331 5ustar liggesusersdplyr/data/starwars.rda0000644000176200001440000000646213614573562014677 0ustar liggesusersBZh91AY&SY_o@$2[W@FH=}zm.;ܻ ҝ)7"4OG=MMS@='@4OS=F4 ڞOSA4&CIfTd i{*=M@iD()& @hi44`1d224h 10&"ɐѠ(MFFѦh矹cW (xSwx˟pN\D L49$P$r5౫s'yST6)ۧɩ;\V'N-/5;Dw7͎0]xitCB;SF,[Q)0҅-7%'ZE*51lj :9FrguIQX0vA"@֝60"*@:W*EL $,JT4դ —aom[pLmj|"E[gy퇲F9(S/NkF_I"7'46igiʔcٳ.Bm`LzݒR&/ӵy$p4 2I$+!'}&I&Ck$Cd$,I=@TAT HDXK:[E~g&4)CN *c/5y%kدqCAkBpSUe;K\T8\a̢TSb0( J"' )D1T?b~=m[+KJ_%Rr4R-us@EK9Ti]az%ᑢ3+Ԧk,חC5FILID"zA*^I vm0zP-Q9.(^:7QulBUU_#qOhDJ,Ars72, iHXbd樟)̑TŚ|**FЀܾkf%eyd3E;(!m 8w1C-\a#(8pz=0*0Aĕ1 $UYJ 6P(D9Q`k, iR `(DHpb@b=BX+<^wF9u@AsͿHzdj}$giLBLit/.1/.a꛷hGNBA F .RKAm%qM0G*lGR~5!Ma%2#GK PGTǿ)aQ.=Zŷ}AnJCtĦ"F^̿ l6o v(lNHkOq v&N?,@[l DI u(.ʲĀԐ@FJ/.%BQ kZםa}8II p=WJfO3:VU^X=k;|Y ÊBIP1x6ђ,9AtQp0|rP {5$^4qA@+ˋDlHPOT v2vQ앛ffٛN[S_[!Ap7:`,j[onLAb\ywvxގ7О2Bm[yK$!jϴE-Zi$uP=om3s^D`L+O:ccgߋlH{ :ո@cSBhC @tiEi”.$*jԙF$G0;|z#L"fD[{!Obsن7QS9w6R,/ir$/u8ƛz<,ЅYH\ .** 4`!gcgl`rv (0:;$L,z2CSA4%^ṙ<᭧W"d|^3A$Pa4`NI$F5] /~D1,5> xщ.ʑ1N,u8"*.C#:$ɿc8ky"DAƆ6 ƧH GтjzD-]ym[87`k4P$l @C`41q[E GM5M);uk*oq; () HJ<3H&4x m-3Mse"@@dC <9LJqQDN7sҷ|I""w0yK|I蚹. E<$P1pܷ W^5>teYpI貅EV#=qB4F$݉IíF] iKu sv oA)JN{-ODAM"-N aQ r4i[\yCI| !)AHNB@ BMT6U?L A4 i?MSMڀ DBAORhM@i5?B(B$BbT4=!L Fi LHRzm@h!)"F=5Mz&M1CFifOCSG?  ti4!T#N:΢6 @Ҕ HiДl:Miӥ@M&mh@(vͻEhbZ+mrr(MAUnUE-p.skshԔt& :֤V+tխ\.TPVJ҆@ Vrض+]1 )4)Eb9֍U[vȱ tit\9hnTW&УB:P@@itHiҚ.JUJGM(V%P&1!JSRM(-4 4).chM͋W([8"tҮ4!DZT*c_\^6t!t5BЅlIH4 W@PhCl!FC[XwuTU]5AiЅ4 ЕJ~ H@& !)#bM& i(@4t] NR(iJFZ.@ FHWBk@J@!t:Ti4 hiUt!Кt 4!J VjTi.4! J]RCJPҩ4 HR b)J44<mQ\\*[-sjV-cTlM[(Zl &U(Z4&"R( "]PAJQD@ M ҅:4СCJ4FKкRPдBhBR!Jy U^mhU\cF6]"t@PSBkD-sn֋bnj)-)(Q-l!:Һ6”&ZV[aBthSFihКdT\665%b*jckƶZ-lG@4T]l V(F W-k\ֈBJM PFDiCJGNiF4 )B @EW"+rrT'$hīJBt:JWN\勛D\kN kH.$h Uh& HW5rmѫ\ wt;nŧgIЅ44:ӡ[.bV*SB:1)ARt"4iHv TҢi  G5wuwuDsrPVj劍mXnE`5F54 TBiSBihرrA܋QQ-.ZДJҘ+(] 4.]JJ]JPk@@R !4[bhh1Vk72X!  I@@U"@A )Hҥ!(4 m`tUTIIIrU\E4 β( 5Ҏѥi176hh-.MhPPl[rұrڋc.ik[kEFmEskFD6jB i6[Z7-ulѭʊXƷ"j"Kn t& t:4N H-.AlPQl &Ħ[ h ,5\sNtQ\JQҺ"ZM.#*r7MŌXrcX55̉vjQlrsgg\WZ4b-(hbZ@٢q9F5hvHuZF.4h4.lFΊw.sPSƋӻEEl=:x(nVc\rኋG1rSv墌c7- 1nX.-*mcl\1 NW"LutwEhkJ MiM5j˚\D͹&ň4\"@:4P6 幵sstukPLa44'I4mJ5uݮr+ 9(փKCE+lP9sr&:QWNƴhmZ"CFکuͱuSwN:tlnݱGJ@[ -b4 l&+a(5hւE-hsXƣjkKSti"3HjCk&.KhvdAK#4SF!Ѧ]6 )-NRj4\ΉcXwr'+,WM6qwuݝ;.r1 AFƨ4lִM'@NZ @r7*wr-nskusN\6&)iZ4.m]h c.lkFmuVζbvӺ˲%]ӛh6k[Yq D&'pkFfh軮ݎW(wP]ՠ4ƓQ%ֵCv#gw v*ڝgMѢ[Y)4kAE%iHk\ܹnrQPCq.nPwr1Fbֳkm)ӊ4ӌ`Qm)˗NpMk4h5Zًf *¹aJRqґKq9шt(Ƙ+mZ1E*6m;Af"Fwbg;i&`I*-wnf#jkkjflQlFh5TlŋBmQ.ȮrH1q+Uc mXm1jӠ#m[V+RV-bTX6 ]W+m͢tw\+src.;cV5ckbvFؓ4NcD(4lcku)lF*ĦZ5lsf*Ֆ1k:-#]H;tgwsNi:8p]˺ZNIcbjWNQQL`5rpfڭw 튂dbii@mqi6i7g0P9'FۄŽL 0Hِ\Q-CkRkFrB'#(kb|i4)Th#ڦlN Fbi14Abg9(Ίhh-mٜB2(QDB( '9AENջ֧ MlGQ` ؁HES|n71.@pnmMA6 <75vnq4[uRieE[R;mH#XHC^@* $N2(F!B7!cMꐹ2r"dB/,cǏj2 !1G"+r" M&.gW#G#qZ8FZr& +$`yi&fq֥HM' )S1L|fqēc(IclX.o3YvZ9SDT5 7>"H-i {8R8ŵo!I&eT(阵\9H6Qb8@bLvh*H$qdT\iF m+D%!6V-e ۯm֧9@'EH,bnbUrr`Dib+׎jhۭ8h5bc&&\ִM3wK+X5t( dM`B4>=OwS֮uE#92&W$ًqbN;2YE"״Zh޻f1ܑA6Dq6nnVf1^35*r"-Xw'68łx 3xj˛JqL+kadF<-P(>kq֭y.1Y 2M55A" jM ̭nqՕ yQG ِ LMx{sv,wR*a̒9S9Bׯ!V#s[ձa>mn[vkPS0 1҉ǁ7kUU,P&M=,SM<64t,fnrMMܛ031ȮMfnyXZVIX5ZnV,qcj(CbW^c5j9h <~a[\Q&?J(!CiB$ںP#[_7U?0EnG.J.*Q VЀm&{Qt)՜IPCglLm} />ߎcTlxma:kٷV3M[\t,:49\l!e?EY&IM*YZ/;r`=kޫ=O3],lm>'Fu^IDN8@̊)D~uEթ8 ) nԊ.lLP^9Fc}zN")´c؜93%N H(liwlHg$5DG\lsc&յ4;uD%86Ү-_L8î΍7O$~튨t?բWҏ򳍰|@ lzCmHmd[}8]XѢo3皚u (.u-sjՂE@QN3D[Wȧ~۽'-zd#k(!0cLF~ÊpH_50̅v}go"tGUKԭu_G:ha)ï"%d`0R!08>RbNt8q6wS&:T Ʉ<5lܵ60WEv8ܪ%oMp׎>%Sz,}(I@*N/>Eߺ> " ݂  AB/jj9wϵ0A"dlJݝ><&|' u2{XDoX)vD}1E Y5I?Lԭ}ik6󬕥?Hq$u!#fՙ/vX}t} yݙ&*fTW _;A؜'md!h=ϯErm6\$ӥg!eKTNνekNwJ\Ɔ`R<)r9zvT,*czu8a0*`*(6J@Th:Qϐ0ns8VUuիX [+@%Rp"{*Sp:W!*Z3K24/k$ªvQ!NW7/~ g򥞪hKsO"M # `E`'Ʋފ#Xݕ 5VLW.}o2h| 8;b.Vύ#tX"ːœo?_6*9N$kSYBGy~y~#ߌ"i&"Y:ǍؑڅlHE2g7lmŋц"JN?:~Dӭ{pUCTOljŭUk|#T[_ASCuMxѯS#EbPbk~g9 GP|$PO_>+1D﹙JJC;n"3]Soޡ*s& +]^ # g?[jzMP,Janr9qXχ `ȧ~, LdLgog g4};֒նE[p`XfE!Nv2^mD,~R[XWBy>yȆdWZ_ Tf1Og@ZC9~m[0'v(ފi4HFpAW/ġƹlQ=`['!A)ކBqo, "LOFv$ IۦTrZ) )j.VD۷zꞬAVeiY<g6ӫo"/Qx\5ztΧq]TsH~+};8dIcw^jW]g-i(u[  mU#Bxue뫺ƧK^_HF{Y Oe@PKb usua1﹝7ڙ^Ex[}_ŷzqLm*"~Ϭp T6ۍbX/JF}tli|ju6jʾzsb{qMDLV-lb:3ߝ  BO u,#;6h|Ԝ^Bݎ ЋVZ+(&-+čR.eYIo9nEm`[l&Z裸$*T -,Uʔ3 l,RHGRs*c(7 wJheWu-LǚjS|3^D_ Ql9ŋ yu.1qvԏ%õ6#վo٫o,#峧ے0ZDՍ*j)=DUN+Tk &mZ V%zCj#7vvz0ۛk7cJ֗jlK=x:{sHC2Cm#ot,&ˤA/D*v!(٫8$e*0dXD0z črF#(/7)Nuw@Y׊& B8MA/ ER"@EI[qB /ŴZu΢0/uSlXe'ڗHGcI Y;jz$V1uoTB?/`"=Ybz G;4 *E#ÅE5iiʭTe$309iR?U}?ykܳ2WU*'tw: S1l<RxQ X_N"aP/vjyeWL-zL #!~M7A~F\ 2d2"×hFyb@]S 9`UIfBcj0Eh*eY5siם\(mУb{3jxfEҪ5TbЦ;HJ!%ExXwfG˭>]y>ӭnO: 0!еYV1Djvԯ;V͂33Ob_k8<}J.WD_ʚ_tWtVbJX9vi;4ɐԲV²+2gjb :ǕED8"q{,PO)t)[_y GMHM2sLvBd{_ʀ.*:pqmLVAwWHT*`.H`]օghaףeFf{ZJ1TNtVC7vZ`x $T֎lH.+t{ڄjPl{*{vmj3*%aቦ2<o#",vL(@/ʽ,w 2SF"-8u] 0eyta4 ; >q =Tw$KNHas[&1zタ/-#VZUcs* Di/}Lchϡ/eޮO>TƉ]AĤRTҒK.5$uFbZ[U$123Um"yAjM9аW]4?0~z=?*zT'ށqCv I2< B&s -y"R3&mˁnhsln&P 6W(7pB2e{dͻ]Z~թLMթC.%$g%t+X< O+#V:ֶ kZ뛩hPDvBLSNBJ-ϑ95ɁV1I)-4 P|-F@4FQ tU)¸f"JG1_?r3tWb5vub I=Ehc*[%%Hz `{Pjbj!#܎_z*91K+qOw|J$Mn)+1^ 1 ŕ=[ Xjs9.0:BOT]׉Oѥ:Ve}AQe,8k"FY甐]֪ G|YS Sv V݅7ÿ_Tܓ'X+J[s=cjAs3eh( !K?޺,亱rtϏNㆌ}.s @>r^6dǬ5j)|xUʸ3P^YX9gpBކz6]$E:0_5Y2$WM7(Ab1WD!FNWir9{TG7zmmWĨ.hJ^ݵ4gՙ&$Ol U쇆#6:}dD6,Y7}na2^:6L Y}/ԬqWu`UZQPحH0eM]*vXFnNP;9撈JX7^-s|'=Ʋ.'qLw+jܨX_G9~vAc{wjϺC?{jnOǔ;ȩ( EQ6[Ǭ2ţGq-W֨qqft@M3@F Z'zUw=ۑj['7VY>ӚSS_0KA[f!=Sr"¨CtSw WK[ޛeU7Sy1G5XOѷ&n߄֯MԔ\u696>fG#+h`'%'nKXfMTpqO7d<JY׋H^E$NhE+iU.{Z1L-N狷L~6^jwƆ9$њ^> s-iƖ?OG.tVKh[v>.a1ed0{5X:4<{f^Ya{ r%%,jI,Tv=%pic RmS(츥&}g`)ޝ+mݻph@ͭ6^%wux[`ϞeZ6J0vWfD %'" p)}]1-µIh G" >k16 | OU2E s(ưoQ{o+}gJ. hV Cs"uZVOmV~xLQI# pj9FO-Ŕ#Bb2ܺю;o }Cٴy Sj5lM{/鸵iIY١[VkW=%[CJre/L̴du#Jd`ub-%*tӭE+Nf pj8&Zlܒv-c'"#neZ=@3060tl7Hꢯ@}͊kM*YNO]ƙ٨ީWySLi26~A%6CjOSjsw]o[+=-8ߨnz},6_euwy[}O?' a!]w\LisVfm/ǣ~$[y"4wB*7OGXt~½F#Ƀݲߜq,"]\˭Y=t 6drH9vtgGIza[䍺XOcNE)ZYlZēim)' CZey&ϣ?!V biGv:Hn)9D&]r&ΣW2ڙ%^zn{tO Y,Mg]5BY"͖,Td}WHd ZSpiWfo'owgK҅*6)?dRB.T[add2ۜokZ=p܁O,lP90 /,A]CG< '{kjʍ$91kMV4s6#{sSee>*zyբۅFԼۉ76EVY&R]=3G TC0C@=Bo+A ToMGhn.~Iuz6ç^/#k7xMRCD?|5UfKxsxTH\;D+=V]Džv 6+X/Vwb F*cb7TeުQDD~P$ sJ,V88:@&Nb^|qHҿDˋI{孟SC-&B0q%΅N ,8*%mPtvGf ֦aNz֛5Aj "d1UCvBAa1R*lqX@6t`z_h|m]k3N:лYr[6k`%>]5eT=PS{ᨌO @C} iTų*\'Eưٵ%V}ܨ!@$ e,wjm}o^H'÷ h|gZwڎ+ |kk)~\'Dr0C\?,Epekm7>sĆ|Ӟ~MkpG3=ކ-(usߔ" c/O?PW*\DfOcf9F')M!ĺc.C뗵s|ᯍszц# lH&BڋMXttg|](eh# s'.SP1np03);#-/ŴG]4ZN\6aFڛSd: Q1vR5aꝝ|D^w^L5۽y~%0KwR톪p3\5#숛xe㚫Y*CZ1otFC=.౰ir|ikkp9ɟ=;NXڬ0co^iFMop\v4\@WTRGi hx]u$h2 cxٹgI!ݸXaqBv+'V.u!d|?buY@!RAtۯUSA:<(C9yrнo9LFϳʉR6UVxXɰyk:g&5\S&!Ew؅8M=@ڛ'z*ZInZeb랊kL5ib׸ g4s_|W] Ki  O6mW{i&ri.q n)0H@ 2;[fibdUK'5N놺D!pxC*veG8Ww|&y<\q9f(-UHܭ 1!)$,mZJU-҈ͼ$RXd+vO<9SeHV'6qk_'E9+a ǓYzIUuz/>,Ê;Nzr3$3 vXݑRr1&U#Qjݒ j]2$(Om%5o5p3 mLݙh# 3Yd㇏K5yOF1YZBA,xF,$]..* gOJHԼ)e'wJϋJf QaQìZojľ}Wpj.pQG?4i>OGΕE]0tTGN嘥/ь@2*,h*9V0hqe􁦡A3@IЇ5MDsEtQ˾{ȇC\\ (Z/TbAu;TY!H%WQ@O d;jǓxZeFH0+$iZCyMBT *KȝyyDܞ8FR{ ZT;UwXi~%;˶FIz@؇1Ø~ɍ|m|ᯋyYY>uV{n|5ݠ%G;p}9B2qsѶk~"渔W2B%%H9Hza[ЈQ8 sۚuqR,S*H6ZB=>1qQvM+e ׵(lo4e̾858[v-z4p,nWp5VVJ,bxH晢{:Wf`m׏Q~b0c 5~wWv_o!QJv1m[ bOP`M@n;34<#zTK@/Cg/EPS TK!qkR,Y:tYLxi%19!;pU{Jj$pK!ӋB85@K(N|/qs==nbG ;O*?D痾 k}> 5hH߂hyW az@; zOPf)[c$ASL<]Xq19tog8Hˤ>3VnJy0G +1%ϓ5K!v<(1cUqbP-̃7yf(3-ev#1Y.45| 8C3&N} xʆ'|M=ʝ&vgኒD Gx4ӂdK3x*4`[IQ+rqov5W(X:4j&f:!\LoTePBiQN6^# ^M^emI)C>5Akh1]-'%REZ|ht\`G9jٱ쭪%+Xmo.: Q qWhtN)@j^:p=+}* (tq)vGiC Ysipu; o+IKEJ#Vay%c<誧ܰ$B,w?iJ *߹QM6X%M5ツjw3Sͱ90nGXx"eb22ɆfW:Y˚hfZV4 7׈zy-]oYmyk}nT?|w4lISE,*Z:)dȞ8m;JB"~]v``Յ>yW%1 Ajuǖq,1 Ѳ"j4al~i([fF"gK=LBᑩH}p.'PDZ>ۂݧ8/" =fʧ?1G~@yY I/7ZdlM"Qr۔R"61YKq/듛m3%n/0I3YNW{a6 !kÖ׹J]"բ1QCu09^.8QuyI)8_9=X@[J XiKT&1KL@Ƈ,rPtS\HĎՏx8y@|%BB"᫢nyYÁ'-ڍ&Ml#J5Y$ʐ-r,8s1JrD%Gjkb,V'Z*OO ݡ ?+L*X9s/4b-.L$$yb*y3ISXaT_lM 9GIHdڜD6_m2j/rǼK=?eeE!K'n5 "tÉ,T/C_pY`we/JN>z3b( h-ʎ5o-{R+S܈ۉ@r' ĉȹ1҆q0LC~z0P)%]1#[|?V~˸HK6dM'X! R3͓(͋TA/2 fJ3DXܶ?!{YK/zr=mߚ3aT[(3&qSl_&>>?'DۋXhGèrfkVJFq9r';) \Eӽg("8DA$IΰuZQ@)I*: ͬ?0JUY*4M ly6#7#uٲZŜ_뽹KQL݊ן5Џ(v9hRFJsn*Єڠr9 ׬A+NW vj\#-2?Y9)ʊ1tS)^aa]%U J,PXyK˫HRͦU^ĊqQA~M3,ra@5`RfIB/} hb'/{6Xj4Y~Qξcj,Wm@cC?:M[k]6QЃ$wKuwq~*t~۝g -ܤX'!×&,dMlP;[ҷ/ [ϝk鈻LN:.ŝp群rxUl8=7|6X"bX5Mu}Xoy\O"-%:yGQ\JUyʓ_/+\^6;gP5TuZ,[XJ:ya+Fi|U ?!53gKpP~ʦW4'"+)d[tD)pYD3 M1ߎ}%jĀyw;%:vjxKƤKKT#cik[w;s t^=l=myqCQ]x ~[&Չĺ=q6jWb7m[!ߋÚh%1,YfЫ)4іLGM^rik0<ߏ7Bdd:;W϶E!S#"*7w"eRmJVĶYG\OeɬCTjWJD5wSLf:v(ѬX[ GuK۵Z$VV#;r6#}`cQbsjRj)j7-{p}&?pT&'ωr()3uض(biKZE. UBY0+zRO?nCw %9o/{>i0i ~ƺKA }7J",[O 16p[ t܂It6Q7&-S43F5ޚ8wȺsr%4,h&&z؟%:S !dL! g9I(Ș+t2Т%)V0R6aR~ (S1c/E? DGue-1Auo,R"+ČGexmyEN,+/K6(s>W^Sb)(OZ9TLyVɇǫ'n0Y/ hC w|ԝњpz=>(w:QvIn;R{av. l&⢌Z% :0׌uof* ^l6^Zߪ-&~E{$uNVS2Z@۴GEi|Q #q&S](H#뾌B|@\)PٛysC2N  b?Yq|QH~ ^ ɲ.U?т լ@=r4>M: 7NԪ"䭙j]?$߲?yl݆V5|=sSfg@pt:crMξM7yaS΢L)M7GO*OUG<ҚI\t=?~> 賸yt멮Oݝ976Tu;3m3ߢS}9IڮȤsč(ǢtԭVZHG$Zm|.^\VAR4"W:W$'rz}AI@,T :$oÈB+ΐL-(Ao S;1p7#ҭ'N֍O&l iPmY9ū:cfy_k{:G6GQ1D`ѷ E*tW"f+7y,"sA1خ5*ʣ5TA ,yfUk8 ?Aڽ}"[@hgix'i4FL/npO/Fo}p(Ccg&"14pM:%[G]5J]"{JÒFc\-|fI`γ~uٴڿN=[EشЮҝZJoRRWܒ:ҵg^j XȬzqo9Hs]/ך6Қ`Xҷ[:1=Īyx$I!մ&unSlx:.8ͮ,XGp|ln)s!-T;}{F_BBQ9g0#| .L(:gIX3T= 3*ϛ4GL{;dH{|3 }g;tfķ {*ڵ_q;Q(UM{1×J&n+b;і'ȼEUqqK<ŝb mV"n1$"(TeSɑ_j&ܫnNǰ Uq&i<)B;o8d@ I$P4%H!L-Iޚnf߳J (L\P{)'}(-ȅ7X.=BqDi)i\2K9Md+2 SAV%$l\U!?T&2TRGT Ǧi ccu;֔nCrYM{5UU*=Z%9J+H7&Uɇ6Y" 6jX;e2`O<䳐xs ӭ>'=ly5uK%8gFm)+U [st#ke683Ar wݏ Bi/t[ ;N[)Xg6_}V,z e~"^.(촻}7o]Υ]oP%::/ T17Q T6"p)v^CKg]]ttCt|##M`Mm)0XXiFiu45UnW tnm(%$/L~o~g*ß*1PL'1"#xpqB[ M-\,zDX6E)Ia; G#T FͤdEhԓ.JRx=TwjeD$nmD i&Cm w7$# |D0."Wr~-=mߪn  Chƹؙ/oo8۟=7|1,_>lÜ&;g7ŜKFX͝}I_2;UHh5,}Ȧ]+je>grq mSU8ls$7C4ʬu~S`.2bn53jC=ɅN?2n+bs"R2,Qxf,@ \dysv2;L:ki8[]QJQ :PЋnG-N@C(YAgK&,:U!Ji{~z,YlϘF.k&4 jj(U"0pD ⧯j,Z,qzZ;n/pVw83ƈ#ɧ+>pJLhRJUC3lhs23(n쑽XKRzԲђmչvT7riTOTF1Qc:uNus;[O@F5U݇#^hO;7ZSHB<_[EOr~) _CA:ܾ’j ޙ:! Ūwfc6],I& (t- wNp^llS!֑ȕrB)&!͕IUUJ b*Zp{1lBp梼]YٽZF&!G\"I챉f!eJH]s4:"N#d5!$4Oyֻ0>Uh*'GEh - d.pks{xq&W\ɤDFsy* P=%Zd4̨Auyrr!Q^SQTk$,ؒ%R /_HacvLYa~\4[Ȏm7HJIDr߃[Жy u͋Ӵ@A-f1✵8j I\T'gh:YXr䖡}W6;-GBcgKg4(Q 1(f^צTnZn5٪(ABUz^qRI@B4|Kޥi ]C%:Nfy>yW-81v3Z 9 S6~~Û_fE秢߅8NSec0tPE44("ҋ֥/dT: ڼ./;&~{qd&VJ=roP<{I~O@gEbΤ2 ">-&*y@[hfέ% Qq]0`k7jj|H`]J3/2ύcqn"M6mIccg|{ f6O-*6Zb쳉FnSRd&ɶt#(2 Ef6d~36jEZE9Ъmg Vm |ƭ{T3엡2\B)tT0,AKԍ zvOwh`䡫v `0Ҋ b U!7Oߊs֫Bj*֍{.xr'^+poS9ԁz C:Jud*{]ݬPS oFĎޅs4q/LQqC FQat2yE|8 *'􄘓CФ:^ GH}@H2u&Pa|C%-dʎ2%>~`MEO6 I$qo)!㘜5X{K>gV8h'j9ec 0,e kQ$Q5 s*2aQK|ᕑ WK jqv((6A%*v|0`Z>Lj%6Ư#jCqHĂZXͅtJP)lt~^idyo^}p$pO|{/̛{E_ngИMSI~z71CŰb RtA\$V(y[jmJ`sSxm[:EtEeLq4#'!_{ßX:Z v>rE fgԔ 5F.[`sMP\n'۸O~SCv^kH)\+jiĞθ ܈,:P/iSZqau6աRlzhӒ9w]9dhwD69ٕ­ڌeS As$ݕfO2q(W;5j HO8X1v+tY0Ts>_(뺟PgcƈXP+bW^xZW$VڈԂ{cPϒ֞Yet)ָA̙j`OB :*Z$-{#e+s6z{E[ <@.v{_ +CؤoL|/(o8[1l4Q)L]٦cɭ?x۹Tag+ͮ&I+8>|!yH^}޳$ 'P0Oue\+DH2=[氚XŴwʿK_nB$}ӜT6k"雏W O~Pc6)+fP o4DW mK*b^h_.$!b&ԩCuMf.rc$ ;DLoA!y滝6π!5uz0,lR;,7G'Sx^mGڒ &Ѓ +~u-u켈mci~|t]SI_?D2ȧZGI ,lZMKG?ӟ[wJX!J6z% ,|\ͤNtK:Ujez̕Yy&/I=To#eԈ$2AWuH<7Nv)9Ch9]3D^I7lk#tW}4Qzynr!F9uOמ[^mЬȂCؓXjb%Sjo׈PN_lhΝuO6qy?4f}'OKaMϜ|:Ӣ}!iXμ\̏" u,Q2x(sޞ]ī*B //UlvHg}5P Y!.<~fXq>ngאAr/%R&g]!IH։ 76i;`ۈ++%ܢɾzYQF\&žo#FVv~Z-OhT\@17 +Ƶ| h:i?SbͳIv){.0+'t x;@M |߃tu^.~© Pz=(Z%'jq`W>hϭDžjW`6z7u(ip>RjwyAH[d}s3\z F7ܸtaau 2NPӎOSD<̣l0""9O-H=Τ5vfaD"e[=m9)VߘBIE) wI4 xND:vۂ`q;Qv='7;#tAW" s9wmUID:KUdHbkbG'&>1 \YVoI3[\]Ѕӏj `I^T)MK@{6o=ޟnu\ c+1%wcDiI 1iD,)<>ҕȣ?*93'&t "jBRb w=i0q0y*鈷y5^]0g_m >Oߖs6i.]=g'ڟI7:R7N ~t%NP7ثpF:ҌzP>< EۙpgC.}g7K7$*F œ/=B#ՊӌW uy?yxd8NLsi#:\<׍ԇZji >D_|@|=o@ԪiFɉr}2>"}|妞ɆOm /Dkx^%(?',[הX: q`czOKHu.}^$ n!zKv-Ak-$LgeE/cg\nӱsL S=^OPTo1Q(K+GkGa]C&0a;#ekRd Q ^F١Ozb$s,hR7&ig7`V㾕X" +7qCs@4ȁkl%!U:')@DRĽ <N"H\;GF)rICߙaGqxCa=J'pOh˔ʧ6QE &b{mZ4$3cETurțC/s,_='"!Z%-y]Vnh SVu>ET9j>w)i""b3<+D^iy#̌N#5TV m#9j5jV.q5aU`5L͖dO)4]Y'o*tY՘a Ffy֤ܮive%7gJJʰ%*R.,kZ4DQC=!Gʫ95Sey_~q_P# K2otf[gMԃJGb[-["O~ZHxmCܛLـGe)KUC!G^=Ɵ]=keKfX  4O(?m[h{N;ѵWrkmx&.#zbJLl@I1z"ɬ6&xI" )rY9׏8g 8v0FJDΜcn& 9܅7*#=Կ&rG /2X IxtZKch"0.nkvM7$=p3LQ%cvHݝ]+#7;pξ/\?ߜ}GY+0U䥴kf}/चy}tljz3I!7n|BtH}:OgGz5ѣ9qc9T<ȁKEsrfl] +CAX7>2U͏')[Ej={C)d(Y#(Ѵ8sNQGFeUO0q2gD|Jh,S1K̟ m n7nB9=Ժ(jY Tcn̲/f|>UAyqRU~TS4/'#'ծɜg5~ѝ5~׳Kw@GO^FK<8 -5;ϿPmsW-',&ME 0Ϭ LB3'2azZĢBh&K/GfSyDAnF@CHVt_?ڈ)}_9ȫ@o}٢>*?,MQ;G)nk9X#|u!sky{oq/ixOA1Nty0c'66zWU6{S07$.do'IFYT7[K&;5(2ʎg#i;bYB;y@< :@mCl]"ц;SޜgjYcK]6IBT:YC9[%*vFtw/&93Er BD<)SҽM5ܦq&й&h;IݖN{mXt)aE<4Shqǧm;4w dkZSur>e[ps.Adia3NMYooY-__ ?>>,(V,>B%_we8Zk#):U:]$9-u!w0Eag†\N6&6iRCCb`&H^b. FKjۧ V'~PBE3~|gaMvje$"˞.sc c*Ye%?JνT|&J5[ BܻgTK}!:K`X5WVwVzҤA.Xw''pFƵ+ر[I3Mb;P݂N=s龶HT~g\tQx4<3$G]0ϛpl3kd&'iX)0FKA$\c[}h<<9O_|ּ-@znti"A=w~tcJ垈:5ئRS*3 2^e]w0ț b{~YʚK ixUL!˴U駳//0h_p/,cXmUOJe6hO^di HXPCtW~,u!́UwZO;O2Ō@%'UndmQ5k{ mZNZ9$#abJ=`-k«9ɇΞ j*V =0AC`b?tٓ O ;2V0h>m60LӚ<ʷ_ė@=IckJ7L4^AY=RRh1#_Sq"M{aFV6i{U̴ Keb3mH l&B^Y Wq-,ۖ%fEkn7fs?`PQgǚ?L䐤<40픏n30/!A+b3r$Lm xqxczĄ f~IGyTlbǖ|_4τK * ~gխT{OV.i(sNf YI9)8|i@QgG_)_}2m' 8n6l*X)/#H$ b0o"3~kG5#5;ڮ_)XȷA$ ۑGXy>3[kd߰R_]pHM(ca:+;Oj DSsNH&jrf^*@2 |$lNa8䡅2Y81ͭ9힊߬Go ^GR91W/P&b|7WEVs3&CW{v!4Ӳا(K`-$,~|-j|X=Мj4Bt525o>!CT2g]:7O YN儵W׼L仒l6/<:5E#R|fob)VJBQ@|tה.֦Fy<|܎עOn`H(d!Jnw~EwK2nVe|p)v9Td%62Mvfܑ,O}p68%٣s*PghûAسE{/U~#LHyIψsΡv)D޶+7td>ܱnFi_v2z^ލS 뷉5=WboWlW(=1!fw-}ċ}@ӫLOWMV'l0~*~%I|{G??lW=OLT 3N9=s,$nCe_NX,(yVNQfnjrfבI`YuS.z,*:%zZ8˧;UN!3c|BD\QG'=B>2RQ'Eᓰ1ZLsF83dH,Ö>Ҋl/5LεaT9qdkzYШbvwY'כ$|,RDѴ\WD XS<{ܥU4sؤm1pKKp%wLU& L vZ̀A5W+/BIrɯU30knSdۛ%V.G_s S]USrR ؀h6-?8d~Ki{w*U)8}Dx*_dT\):0,}*//5e\ %uIny^1B,Ρ~I[Y;ZqCAv$mG6w69}Oj,tdS9 TZf:J'!$vg2 篏LOS a聉*f}C10Ҏ_Jz{ICpOXGͥ^O}VP3>T=MbV~[ Rj[s˘)R[2_-ʜ rlxE2Qzb\Qc$I%6Ÿdz+bbyМޞikx>s,uzV]@B)hzwVYr[Xм?ֺ~LERzW*WNUCBZIZj4'mO/ Ѵr~s \53Hhvd5u*_ 9]?|Uiy^'@T 4en' Qr7 .h=H NɑZQ<_y;}nwOβ"6Uuzuy7-"Cf{Nӻw{ۡk6KY}zez玁w/^hb]ěGGPفSdžN֯DQ0H.ԬQ_ct#ɡb#-2(,[a?ߖ[~I22hֽ׭^&6~;C܇?KoJCb }?H>aՈ7[fzCGV?d?oS+1;S,j|WKAP^" !r/[ c݇/"x::5 SV'a)w@HEFDbHP;Lo CW)u!T(!'fz zv'կNN" O {LlxC Vͦ.㗗L34$"~K{ .\-ޔ`Wlш |}XrobOjslVvn#H{؊޳Lh*?2~pw jTHty PPEp7V,sbϚd0'm:z^,vrTde`סsh1.WIt^!S?f/&WrEЖd禄NhKibTf~ڄ bHc:v;ciX-yA:(4\No%X!O>ne/ղ)o࣮^Af-^p?vYl+LM ?aKfw<:[q!j FO|%4*݌mt[QP̱C_jfbK8{ų8x{{󹶸Pngv /NHg-㹺wkTdJgLqYEN-WVZ'k3U˛>{m}m.ʻHeɾpeҖZ_Rzo"uzLw/xߓW=[fS  zT&m|ϡƀUU#_Cn 4c4sʇn}="5T#ڃ%Q^V>;l 3 ^Z׹D=nU{zJޯV*qYk̙f&9id}pᤙ $$y_>}!CR~·I/Mӯ"h1'M4Ф / *Nce>ozn'R.o?xбnIcMca=[{s{~϶}56##ПvA'EQwh蛾8rR{~8mOB9|TĞ_z7m۵ht!ɗH_ߐN)v#3/,v**)9oYd)NMZئko'=_;[DjS531EŎNPQ0)8C3Ն+` ^q[Dvs @ѽ\g~ ´ٜh16w/E̛Uhu3̞+I?E~읛lǜN't]n}+Ƚt(Y1$) wȱbuMJ)bA =d["T EDfN0r}\ʇ„)Z̰&C֢Ur:$SHW"hb0lL(-:p~,M#nli(L4_~4o꘹7SWXXDtʚ~KCb=Ol|ҝEtLӲ}i`2g_pG&eM SHtYqG&_N~FLNݦ]#\f 3?[p?MPy|!} Z}]$:|S#Xl_3ec{p'U_qM}6lЗb>] vEX68{]xh,P/B >+ڳQXŴ\[F?_r8S\Șb 8Aq~$oPt!YH>O#~IH.P8j-=qZ=[近m0y{_bEyjҨ{DDȄdrh|\<ߊdEKng"6tڳ93+$Hh^E#[ԝ1 ~(p;^zqɺǒgh; |1u h6::mt&B18QќXkYN!-,9٬QVIۉt+a}Ť'4M@rk+5R~fy6jD(Z*-p0OTdnzbOjMsoNEz3t7ÍX @Gƛ]Q(/*QeA%M*u[.k w4%(b8ЧRIs&՚NKY7N}/i+E/Iu5t( EgT30{+RDiS3# Ooa+԰a -@{ʹKF"Mpbs jtK%}rϔĽUmgFmjhYONt)<+6קy/VDY?rMydW5#QQ DphJPJTItؖ^O!Ǐyc˜s$J9 diFD|7)xL0 >y '{uo7"3/v(搮^ 3 -H@z*hE$* $,\XU/ 6;$ ܠ6/>3UUuڄrM1Y-uW[@6sލa6gΊ=g^ o?Oyya`g 'ި: />[2_>M_~'dey7H*wLOwYdG:cQHM_)gfq 7ñ.%Bjw b喦xVܳYWtRpښ 7D"zPk6 $./-3w\* V%EJ<i$#LFfD6t-v3kA]fvNQ $A\nMͧW~vX38FN#K23F\˒. CZ!>? g=y^MQ Qa /yH܃fgb#Tx@1K־8Zogm^{IytY%YΉa=wq= 5 ,~Dѱ:9N,_ez?j=~ԏYz%;oUqpM #4tKI9Lj'7Z% RCxPؘR`$xSE`VR9Dl}f?MP|&X;)]\@=~G=Lm~:wsr>q#W<`h&9o0_XQaTEV@Cp%a%ȼҹQS3éSب В1C'n}=;$L%R) |/qQ=LDʼnmN+ 3eDo-XraA<'EŖG xW2>'f>7*ƌ:%77qڂ]?lnX9$ /Ֆ#CE$'īIU|T~-#)]ҏ>U呇r,993Td:ޗ>{$R2d/ TT;|Y ϶iwRO݌7sv&^W_<'DO~ngVt^/-+kZ4}d{l_{^YNm\Ee mUs)ҦzsRg;;?6|h>ۭpɕ掭li·?x ԞUC._gǚM}: w0i0'FI"T܈VMrlк]t=OB O6僪J c.%NVɛũ)o%j/v4|DA޲hh(Gs9{g?b,+?=3qٷbߓ c{v:854H?z=¬`)UE~?<>6WXQ\bU!dI]"XDBcm G6Umԥ).jZ%-#|du~zzuWIY )ժ'FUc%k4DgRd K01MݳG @,)*_g+1U=EdSͰ|B3H,ӂ@cJi˪ts1g_21 FG;^GѺV(A%.*+9ґ)IЏ B( '~ GXUdaAɣ'4YV:f<&HIaq̄"o B ldק´dbLZoɹ܊lYx$2I9w9GICnt#/Ym6欥Fe_I|^q.;5/ֶ܄xOG,?*fd%u_J_]:C!8!ׯ40>P ݆'Dt^ R8(ua 3֧ԋC:W& U¼gHo8mȗq[?`Í}>ya@I7B75?ΤR敝n@* m8Me.k:/~NQ˓`NWi@<>e>>EsN,,%T!4Wq̟!CO0=Et=բC~SUӮ5(tÚ _i)72o]h, DU)M y ˞}Ce* tW5!NUB&NiNJ /!cKEKyw9_ * yɑN]hbLMՐLTsW85쮑aXH*򧹡͛4>!R0:N"p໿Z99:w=x?&vvvA ZQ%ޏy+??&YbN?h-_լr~zJ@shăY,άgsd]]ϴ雽=So'3tj@u5/o=2UEjw+觿?G>e@?β$j-Sa89zdt^:y Nu B+vF}"2٧ZO쇺'd 閿W|N!_WΆj#q3NuqkԔ!DC} aNѻuE1ٸPAwZOU.t^WTQF.{3 kKN;:D\NXUe9Bp-a(!5jşL"R4yfc=dZnȓ?LЕ}vq= Hs6ͯ t ٓ^s4z7=nMM5z#јg\I[>bY^Xܚıl-LR>YSetU\ݚU!=ճ4LҸW; 2[%TXҞV,e/pԴY8TYyz`_VItՙWWy>J=?(BJT#Ih 7g?37_U2l$EuR_Lr`Tv6'_pH$<ћSd9dRu#dBxxkBn6y˸uW:֯ IV7_gjYmލ5YM.(דXZ,垓OӟU+ hՏ9>/#Cv5l9GSDZ%t/\p㈟f6r/7ݭiLVt*UGER Pcп PZ?i׊W$gYIwE|=.F~iBUMSh|y͑?(r1`Kث`gn;˄bnI=3LF- 3ݛ]A׿{j%$rr[  1MIB\DQYvTSM *Gg&BLLs.NVگ 0GbI|uN=J|i1 oE*0)M^krtee6˒ p04;QkMd.Q{QP;=At )s1GToN] f)LP!n<ʞ9x[z^i:.-}SOm=ɛ<}Juѧ)!?"iPQ W.؂k%d`9]QI!5k<^ck/tMr10$&R(n)NA\Җwj|Q#YSA7DOW(F49 !A~eÖ!2,sűWAJ IT{ z\aY,b2EUAQMAY7>tzJvr  !v'8ek/ xB/QHljh['֧sКݑHڿN n{(Z[#Cu 39yYy: |] nZ%uWӜzPKFJLDuJ3<FP>ѡA%ON̴~2$DJ".15f%fߝ!a[ cҡt%M;Z~="[>I\3,idόc٭ 0^Sziҩ껧 [G|3K'3; @{s[O{vTC7&u` c S&UtZ~âtX,>dGCPYNdKµIYu(i?H1]^]t%ߡܖKa3*RJ;FRC زK,caqW$eOݟQvGTaD$/C+ "a7߉(XxdOrW,B#z~5'dd_zb%T< ҙ(c|tP>m%O)_tECZEOZ;Omo弔Hѕ^}TH%'E,4 ?ti(XlE[+2(j})I#VvӶM9G' ?jmneURDg%zm9|lZS 9[GɄ9Џ{]neSwy "*J`,5"ݲX .x/W7B̓5S#ے 5m:Xdp_z>^jIcKi׏1ț?= ~k7. dIy:69G.p=󃸦XۛNSrg|"\]~zxFi6܇31iRԅZ"G TV(Xk+>gIH)^LX~_/: {a,B:aȱ!X"҄S{Froᑰ,to%k濡̸lع I}}+¯)ySc\j%S WxH㸠u0΅iOȿ'!O&wڅ|*K')Qhվͦmd!)Z?N<v!U;wX; hQl|d܉+a?E2LlxspD4 O!{:~Jp~=~zS&lq-г7a?X[9ޗn$tα` fR) 19j|NtIL =VR"_QYcF/r1*kJש==#u֌w&ͤ7e87nʍ^fўln 3 W_ UD>&ت\:#k!_:IA'V^n17Lܽ0C Јg슔f;z5Z;(B+9ꡜgI 0ZBTtR"v-{[ZhwSD8]i ԑbѲw8s92XC-yڏ`jGv$'֊j#SbJF7)z} :#4mRZM<5N^~y2yotGx Q'xؠG Ξ왃V7_c_hߪKopT21@Ekj?._&)ǴguhMySC㪤k .LOʀ(W^N=o `zOaf$$4F'iMz Wl̼#8opLڢ.$  XLr9Jج]J0IZe]\֟Tq /կ|g[7h ĿH6%/_g&ZR^oZN@_fv*}emMT.vы'Ӧ{4% ncW4V7gklNt-~j_Be8d'0iFS -(RG;IvBC$P FeZH22ZNZvmr?tDIZ<źow:f1+YH)& J{ֿ-`|Ѩx^sIPIZ S 7TaF>llI{yVjG?lӂޟsH( tоTtdko\-YTj']' !# 7DTH^q 穽 =&ޮDϫK0oJ6I@n$EwRIgw?u..}MH|mLaz0 ?%;4IqtN5GӚa\J9.[m BU޴ Zj:Gj[U)jSkQti RB%,E<;*ISKSB;9,WYƌR3:30#ϬO~@=mӟh2lj xw,4#B{M]GJrQ=|onmQJ#UO-(:qTS77Lhp8gJH%3W7ˊoFWjYTebJE,D)TTɸXE}V/4$.D_1/`KP_(-bxWZ ,maY`1']7*۫^^=\xߑ`Y0LZ6lj #mvRu؁9TϷ'dfq?Z#tPgޞvPK8VbD*7H(՘(E)!|t_D{%L%E6 ̭&}I UE't1CX 8IIYVS2?"~+s*i |gS'D4*xD!:;h͈lQC>!½:ٿێb^~_a5U@ V7vCm_R>XƲEPŁӕ 'B)ro+%]ڴrDrZf}VH^"AԘ0ɍ1qۺќ1#RBcv4O۩?0`ZJZB@h V#J)Jj8m_Z{XQ<1.,wM;A@rv \֪)^TL8gdK,=BFVEW3[@zE&莠Q}3t2Ơza]_"S10Nxt2^8V&8Ge:.m0~2gEQej2ZG'L܈r*2MZֲ*[F~u_lܟ|Qy/PG>sI2W83$HR|Mk .q݉I{$C @t`t]fhS(yo_%dVۆ__l+˲uSe;B.fy9ZF[a=]8W6)Gs@m^P9!c᎞qyʻ 4\<thԙY9S@Ccqr?#E+5/vo8)ϼE#YYn#i͇3Br\e99fѧ*)#T?|} Mo?&y$ήl5=.hа/8э淞JΔ9//> Վ\C$R@u.yXP\6GPb2nʏ#si7=Ӝ@E0"(w^h~)m; 8 XR<3|vHiY:KXt_`H&?6JI˚sOVΥt[!f]JjH6߷E1v90cr}+wO銧og,'T&:@b^D8ZY#KZr'2< dApI7g .pILa_Ff2QY.}ny\.Esܻ`Jn2Uąob?e7d{*m zdL[zD̔/YuLM9[\%SK51G>U/zdC~+Fmd,#* k5 a]| ubUES|u#>s,I[6ؠD I}2VU Zs6L1 DՒ|OenZnF&f]/?6=ɩ%Rrmxjuٝ(e&cWaiKj 1  5>ȑqo=YH]ױ3B V u,%[*Wg"]o%$.e1b7 "18KsVRg\Ws9)o68sQ 㣇6>,xN=.Ďȝj# +>|'_b\ #煿K ͥ9֯OؼXDH2WRs0YZ[Qust:T:&KWc'Zl-6qgQ̻[0%9ALyfRǸq@4:&s5}}P2~.>$ݶm5J=YC?C̢uv:4ZJC?7dQ'Ⱥ\tI3ryAV2ȔtaPfOq$70 gfVni1bCr߭-U+yiB_ 4$dv7{}&GXgc%bـ/HX+-FIy?wz2`$&C_؆YŸ8̝^NVw6\`Ή_H;5"8Ρ]ډu hTlBK#01FKuY;; `8GS_o LODFUQl/+/cz)no*dr? KZ нML6m#޿pg" &bjh;Q+0C*Qr7R@ H&a(LW:%;w(Yps*?ҳdA!xJ^^+yLiw(Cw}˳ƀ,4^B%D>VB\p0ߑme^A![qZI䳹BIhyӕFhIN!AūTNu(+[ pZb .? ab2=4dBmv$1E+a$R?-}ov>]tqJYYf(½&jfU|MX14RLr.XŢ꜅f*؞I sߦ+IUH+Ne `NPL TNpf'"̓ITesΡ%.T&,qF#6a,+J7,.YgQq;og<`i*-DQÈ\#5Pm}ΪU \<dfz6+\Sc6۬DN(u A ;1`?Mn!Z|߂1)KI]ܦ^̔@øI#i\L׉NKi5.wq_>i>?Yg &>]ˁnFs$bm D˱㝠Y(9'B NJP̙,b_J H0EeI(ͫPs:fOIͯr@\xK糯Om"Cur'l-”-FM3Z[}T n1c㷜kA)R> JTtONk|dA{S\{?růcn>2 4뮛Rt$p6'M T;JfKxI-ڔ`'R/#b=,Ej3'[jH]I+U+sC] l]JJ(F]˘~p+?"ƈUK~W9}^_~D("A ],LZ65i&$AFšƢk_ȴZ Yb_冖 &X`iJ_:.d:=u]gr57fѡW?X^7{:Omst8oje LyexTwmA̟6?b=ɋFӼyv({u1 )G IKg\r4RU[M46ۑ( /nlhkFhb[g:Պb PhZV7Wphwxqc8M"7q_NݼӖDŽm4sT4|@ϪbCHj#ʞ| #K3lTo57_gq= ihPI&X،idE ƚzڊXxc&Z.Ϣ:Lh]˓T;dTIFwq ^éJ CADG_"֜T@ }@ !6|6=@ ^ww#Dk%@s C~b4*Fg弯[s>~EDT/t炈'G8KQ>>DT"IUDq/*!D>@UBAG~wPeDA!@UC ? 2'tHpTPe~U⊪OdUABUdeDk⒇)j+c7lյ:(˨ECEj~ Sc#KA })s# %@O 'Ud@EUPe@VA_*#B!(!JST?ns=bU^WUK%=6a&%sظ~xΎZsJ_ B:hZsNq Lә[[+ޞa.kIh@:u; CE@Rsa&Ciܚ9 􎣩4=m9;*#ȽȺv&K5WTh8+ZœI>>sp}uXBx\^x%;Q+ 拌/yTP!(?cUo]#ם^r Hss_KWkIE鳱.C.AaξwY9 xÉN_((9usO]+%ԹPH# AmiR G7͜4QF/J^ѝ2.Ԋz=Ƣ=ŇA0G> +^ }}{Ԝ^r tT`6(1uWxɎt[Ft)';>:{gFs}HM/qC%;SY>NW$<@kO闻;2G~+r `$}kسpׂMs⋁:9 8&szٍࠁs6bӋNSAŢ^sNtM~/:8H)0R4ulo/Wq׋ĽF!|G&5^+r{\oo{44ےpZ.;PuHRs9!xܶ樢ڣFnFMV4 ,F{أI-Aci:|) 2bPJ^KIBW%^@pT& T󫕃Eޗ+/oNEϝǞXƈѿQ*'[!^ѽ2kᢍ^+ۆC:9QJd9 4 h t4D)=HmHi-{M>BXOS*D:)(.*$ Q$TÉyӽ4mQkom ='4K4Rw Z{{xuՉAH1<0KËHcO?Mܵ ub8;/u'}1:|ƜCY{?8|C?9u/3>$L{W-+xۛGr,[cEk=N9P@RR4k2ɣF+A]̚mث5I\PEmmW74+O TN鷋Ѷ[DV5㘍bElFTjѹ+'Yh E%EhL;~{΢-=$:]lT-Q )\!.HSTQoʹQPc#~pjQUwZ.nVĜitيDMP[ j )h=`|+|+̙bSwY}A9 CJܷXh+*.rm1&ִ h1>7x`[Kbcg*Y&?rgMy+E}g,ʀ7!2U!4w&oVзŎZ%; !RqXٮRU5olgtC4%\&ez+OSlw.sc tQ jv4Ht+ᕾ?X *o~(j0 ~7Byok=T[!SE> A|NAODy>ϑ}{;8tO{{ȌcȣFj ne0g+ 5.ɑuj6˩YUAV"@2zbf r*lJ%!U*t>|GN hMw}wǹ'Xvrf罕]DکF:`]w#^ʥ>T&d]=!S~}DG)QsשrujmvVG5i{Nk]nQ!#Pi\z9^Vu\Y`UPVe ؈Yw]X]~Aa`r[jjXn-lEH^O ]i̴b}c]2bλX$g]P}E#o㬣Z_fPPyJM:Y|#"eoQ:zs" q8N6Vom^W;Q{iˌr/r@ +7'oOhG"66s{b&l5| 5^:ǽ;:T,ήJUvQ9o]#AK՞{VƏgp.G]fL0v-MgV{6\Ddx!o7tC%hGOF4)iK N.-aRݝó.fy=Ů͑0dco[>\5zކcu7fLorc{1R<#;ZWt:}<LuBBT0Ջ:V5 R:csZGm5 {]NL1=F%PL( PyPF[LFrgܴ]d:ܥ+{C YdhtYܰHrn%J o"ԀXe(5GU}3;eǥ #H gF ԮTr&CwjӴ1iJhȪC7o%YIZ&Jϖژ& RZHEd  s~JI5rhF]ұC'&HfbfР̪|,pY0[@zKJ)-:?:Sț^͐@T̢VjYl㓵cP&ꄤd*3 ZUTϧĢfr]Mז&2>2SpֳN] zF4/kEx^0=L!2Mz:YG/|2BtvL'zJ\}˽+û=MnR);g| u!;Z=t,$Hɖ%VK ,![f\qs]]=I2ԕsВ+^wT}F>СRs}\0دrC#u4H-Ubӄ2"/rE;EL6fazKWd]Gu&G%WmH+刴d*Q:_ _^ߜ&zgSӟRE^5516Z/97DjZGU[U4oɯ3]w OxӫxZkƧ(OEҰr9q}F'۔C/zE7Kp<"a[@흴RvegZ$Zd`)܄b70վuN6G(\l;rFrlVi.e+GƱPS5iPXVvŭRh,iK̤ݤ.=62ޭĤQԥx:<;D=v,\fc`}5,_ 33qɷey :3`$C\44B PKςrssgTX )`UJoo_z ;jzv]CEY5IN iYebfJ4b|$*dؽw_ B8DD!UUhڿ$[lY1c%4j7r̥ۖmIJ?7:kcր5͎nc'2 X(blQ6,Xn[F"V RTXѼ[QGm?bcjfj"l_hV"E?ŤT'ۑ4  $4*4: A4Q(@&DVJ@y* ! V*E[<M(KE)kݶ6 U#4 }rBMi)@ 0@hFS( GH ZJ@0-jʢbh*Khr*$oKF6ۗ(ƍc}yJJBu Ҁ|AԏPZCD:Jy*@hRJ-iEE[6+sDk:iBCEt)QДHӘ yƍh1#RDE2*ǦkQQccmQQ}56JJ JBB=z@@#Ҋ|JP9"iiH!E5汪TZF6m&Zڋrtb,H`yب Z%JQy@J@"R4-+TD & t ʎZ@4h_H9*P{TV5shr$(4 4)KNiX.j 6'[%Q%Tk6Q5ƭ>Uh hWҢH(RU4#J{?/8Gx)U)tl/Pi@ mJB Gs)*Q3\]I6{[&4k (.+ƷUx1{rUW-TRBWM !܂= T|ைQT|@rд]4MQMyM^rXQK+FF(UE_eslh֊+j}a(=œJDSGG9]" Z=ЁPҭ)BPM(!KH-u*!I"ȏ%Ԋh( lHiкhC$XR0cEh1W2h6lZ4mMMb4CQ-uWs8 =iSJJC A@(4R&4 G^H IJ JR)<_)hS RB) iRBSi}E+ 3&4ZLJQ5FcPh[ض4ڃE6bbώ@H+AI0 밴4#@%E!IԚw*rsm&T_ih_ ZZ%r|R*|RPyą @JM I@lgКЦ: 3h1I"( he(Wv*QbȨ!*;\"FFƱ4[Tm-Q l[`-W*1F1Ƃѭ%1WmZ6dVZƭR )TB=A|6(ѵQ(\ծm_MnZ+cF7tn`t:I(3&jLIfF5BbPE^*x эyx;hHݮit A󴆗*e6֢|;h֋Ѵ&lKiiJB J.Q5 Ѷ-m|*ەƯ6#_ˀiR )N(DtP)E Ppw)Z}d{åZo +EcXQhV6nhxo)B[&J()#kj(Amb@Y,Qh6656ohDX[Eh#hlcFƊZQXԅ W",EchMHAZC]j"hj-r juWoXrQbV64P50p EYj(bVܢ -cFhƶ*rQEErѓXEEdʮiB 2A  l(؍$Fȋ_MJ+5$0Rl(,j,X4^b>WQҮEFgش0͠KV @m/~uFѬѣ JR%#@k66җ1##䩦PEnhmu:Jh]yk"/mr5ōCV[,Xn[6ڌZcFѵEcE۾nɮ̦S&J(*0d{nDBeT`*7LAZHz\Q๨0I4cFI^Kb5$TbIT`QE$`i m`њ!iZO")J -F[cQh[nh6DV( Q&cm5Ec}-[uhE5(FMh5ojclQ4k5ETmFX" W5F[njH7c`4l(mU 1%,&DX#d4pfS\ٕDhbb0SמuAIE Y,F 6,G:jBΘ4llb 1Fƙ߷5zshmjLmFҼkQhZ5%A~5r1Q_ƢwjQkoxEi61QF6oѨk5LFCZ*$"5*62V5_rLWXE5j6ƊF5E7Om "F3(JFH}wMEwhf0)-^.bIS)Rcb1Gro؊"}7%FOx& !A41EQj7 lFph"$RlUhոh}6F:`DVKRm&XքKX)6hڊے&MFbThlV "1?nz]("JNZi) i)ޕW#lE*nhh-X5Y,Z4lj5Qlb߳kƦI"D2bEe$BD$lh 1$ AiBh Mab"4BG,lTQDj0ɈҷzF#`wE"Xh&fȘ6&c>W1lV(BWQPQXر1lhԛW2#&#Rc&hTk&=Br# D-`A`ѠHRQj 21RiЖX"DjI1FE( b-QE1"#QD%jcmvŋ1$i!BEDe HFhQD#)2(7ɘouQQ@ll$Z1y>:x6!AL‘(ƌ RII븨(ђV"-E&Qub$YlS ,E%ň(0QL6,Q@ b61zpOkl3hl2z4&mQXz#X`,kEQhwb؆DFS5Im%EfmTEAQhLb EF#R&Th֊K e$st MwXш&_K`bIQ!b2)?v߹\!bɴj&vj" F" "HQ:Q& +Qj(@UIQPl z ,k ەFJKA˹OˤSHj PM>#,_] hoM{^(ѣRQFɨilh"iu1F̣vh ęIFQhE bzk#CD}-\ۥ02cD&b4FXՍh׍]\H4Ĥ IRRhIC)0z(}u$j C$$i Y-O}t@ -ClhbLWr В,d35+OäJ F"JF7W3O4;I6av]F LE%G.R_EQ1F'(HTD͉nIhcccd㸲kɶ#b?]U%0DQ3L1B5ʍ#AFjb5cdV3*-VH"6@6$DJL0"$MR") D (") L-͊2X6LP&c0J4SF#^.|9C1lF<׃&cQxF!cbBM4dws"%F1]q?Ȅ CAۗ$BRh$NJM&(F5ݢ.12lhF0Lb"XJK$XdcZ2ci4XMR"6h&K!hi%5 F*Fm&QnBBRIh2h$D$)4Di,y *$nJ$QfJ~r |LQA""~I&Mb(ĄX($?pd`"ńh!PDj@ɔw6M$!!FƓIDM1Q2B5LQJa AI^vCMQ"ED[dM,Qp&)4&I1E`,Qdd`d2!(#%j 5&-IIl$$\¼$D4 d(XK "Eͽ:h2= $`$1f„Q4PE6}H=:F<_$*R6 3 TH$& AHdχh&HbM!(M bdcS,  QFۥ(`BE#C$ R d) L̡2"-ʼn32Xc&#D S6 JrIh1IS"5+h&-R(,&"S3h6wٯJ1 %$D(Ffnh3HflFa,a @fhѩ) d)"@뺈I|Qh Bb(d1$dIA&k`PGYJ2#0] JF 4sG߯64;r"*3"$Db,0e &# 1#i9d L(!$i1XE d(-dc` RTlF4 c2iY&أb RJ%(, 0$j,lE5#chLX-M0DD1LBd4n(os,%׾ݳ,$5$D400` ёQ@B `f^.!$ cE"b 0! !t21bLRY `4 DDm%OKv) ܒF$u3Dɓ"4DM4lh4Q3dIBbł 4l!"C$Y d $j4I34(BF 0$Q&E bȆKEPITZ4hɈ&4TfE2E&)CM#$i64$ x12$|9!1Y)'R._nE"1$H|wS {F*I%40 & "2n`Ql@y2f(ld5ɊD`6"0 *f61 & ;d`FDRHBE%"@R#Ed|J00dHhY# BQRbdjR(0h,# b$0@HQ-JLĈe5%h6+QQF#@hl(ɂS2gfL%OU S#3bL C#IdLfa&$}1 Ʈb1Ĵ11 2iI&h 2I>;&x2fHAY)@}u1%4D!5". JfdQ `2 1k0P!WNc%DdIh&@~  )$3LDQdH PZSE،QRAddhD"ŖF!JQcIB)1XQ&$ D&%F1BEY$"DĒ$ \=L1 ( $$Ba]1 fFӖ)L@vm/}B&ncQe$$41XMDH2fR$Kf2RL@HH Qf4$% )"$&FI& bD) C!#L!tM1 FBfF$3I$((0M02H,PPhМFdJ)#Ei( HDFfY(`KRE 2IQQ$a1M BFiLc3cIRJ%)sD٦*@@$c"dAdDi^@C2OJapЛ2(̨d 0$Yf"0(2a$d11 &IBD-#&L0FdP3F2!! R$əD-QF JS# mRI 2)tFJ̊ M>RlIY(БcbȈ`jW"6B(*#4a0,l&Ȗ"ش),P2R@0&`DX4FdlI3l@bi(%\~\J!"Q)416P1A" fY4DҊ ~d& $Z&+] b4FRIh!,hF&i!"$PFR` 3*K#DJK&be$,%%b`J0A4jH$&jC$E,a2PL2ƙh)1RlQQcWˌŊ6-BdJBI]r2Rf "M9F)#@IM)! D<\bQI2&e QR6J{2DHH4D$BD6fFFLTF!RK "5 @FLHf)DBDKq$HЈl@A$!)-( bb(0e,“4 (#(H bHH6"`F!4Q!F h4j  %LlњXHJ!"0@ġH$ɢ0&RbuMM b&L3A"Dҙ$a.~{vdD$eP&& dDDJ7ZCjM%!3DuІ&dfdP; @J4 02H#$H#+L `4ɂ, IfhB`RIfY(FDA&Q4I `٘"aL11dAV I"4Ԋdi2"j"JH4!"Xe` "jA1Hi1"@@/t2B2F !2BQbFHX dQPP#$dA)4R$P2L HIC(K0_J!HdBQX #IF3"H4lXHbB&3)iJ" @ dRfDDj1&L PJfBd3 6" "2RP͊$$hɢ!2`#0 v]BE)2,h/ ) &cʺ SR$ؑDoèLBDI Zi1'5ɑ# DRRdnͦ,^we"12BA$dP&HR)C 21&iBI&$",*)JBMѩ=ONb %l51H$DP&FLI2b2&D@H1e0FaH 34ы&"$łf4% Di),i mb@L XR"4lИYA&i DTI31!S( HOn1F Q@@&)CR1  ,@JF%'vɒ[c(0Q HD3M! & (I됅/}2" $hca c <&$ *B%&P#)d( ")d@I4fMLQRd3Bcb#)A !bI & )A( BB*Bi! iS `I(A"D,@TQSLI2DD"BT%DT& {3"!^ """&&K1Ғc4$0$HjDDBE2@RԚIQa`I$bH 3ё RIRDBHd0#BA3LRR$ԐcFLIlHɢb%ѲTFd(& Dl#!E  dҘ !ۊJ1eq (X)4$da04i#1,DPِ$RL@!JHHfR$LdD P$a LJHI!)$X0Ĕى%)b LDdɢ r`#$X驘!I1!"BHH"DL!1i2$`% $Dƃ05@S! 0)fę e2d$D%21Hb$ddF\&d1dS 4$`0Eyܐ`F039eYJEHX o!3 He cQ&$` #e"K H% č(k)R0dAbfd)`}̐FL( e(ƙ#F# )3`2@!)j 2!HkλD0FJX(HJY!aH fP 1#4!M l$$fQ")0b%0I $ @E! &10Ɩ܄%&R"H@c$ bJ I&Dd&) Y1PI,bbB"d &DPD&M23f-%M(مJl1*J0ȲQI3 DF3bR4dFFXRI#(X1,#3, GA,DЈ#&4d4d@LHfL_q !(D5"L)0DJdFD"C1f1 R )42 h DFѐ(R4&% `a (2d@DD f$A 0#&!Ĉh›4hJh $H d X$d$(0#Q4Qd(c)I)M1HԆZ"`i!D$FD&$1L6$Fb12f$leF2C2SFIDB"H%&DH4I"I4~:0c A2D`L)A! І$ђ4əID04 l(c"`QJ,3D$6c2`Ɋ,!!2f1 &Y4)($&DĊMA$"!};&HL(L ! 4dDAh1 &22D~;Ȅ`DC fD (d bJLL"lQ20ήd،J0bfafM0IbADYD%ņRLM6P02II AE`3AHȊS# HePfH$뤅M4 2#Ȧ@HODLBdI,1Ji4$4dRei14L0HP4(c)A 4F0%H̍?n 52dEn2c3Dh R&DYB"BTB@*I( %(J !4И216*&"X h$A!JP)0 &HdŒ&b"D)20S*`Y&`S(!҉IDb,!1FJ24d2hI)F F"4(ɩRJR0&I, Pi$${d2A"LHٌ2 3Y0c11H `̩,F4dJfQ R@@HcLA@QУD( 2 4%hA"QhDh0D&I I$cD@D`l "LHPRFY`w$ IE0D L20 "4PI1%"!R1bA2H!a0M)33HɌ&FAADHQd` A FLHICA$0iȱdҙ&Y 1`e `cHXLJMLȒ 4b (MFAL#lP$D$6 (R3$(!&D"I&LL7 #1E& F#(0 2$%A(DĠL$I12d0)114F2LBD 0I1F6L@c"+Fhi D4B&l,"e@K DLdd3i2ic 2`$łFA (XFb hJE4Ȁ,Db!\Hh"Jj Rh"Ff( H"P,2D PĀQdFLcC) IhH2 bY(4 I3#0M#2H $KI a" "E2K4)D$䌑FD@YQDH(1/N L@IDF$M34II121S e LbB  BT! B@D014 R2E"A"dIRjSbH̡$&يlɱ! 32L@4 # )LDHcb S3,Sa4#0(%D]j&FJ 3P(;Jm2DX]d2H12šF) C5APBRSFY{2S i1!yM I1J1,B͑31E!!4CAh&Z%ˆX( hMXS1(,S3 3&]I)(JfIFH4@(E6hcDb Jfhdf4hLLR# DAc R&f(Ц) ؤ2$f 7w0ňfD$bK$R$ Fd"e"6wF0&B" $4`, 4S2f6"&L4d4Qb,F*CC-AȲbI$Ȉ1bf2IP AF( #"آMƉ0jEB!d٥Y)*dcC!HaJAA2S@PD P(21$HdFJec4% 4h$Af4DH͙IIhF2Q4[%M@ @!2̈%I$2dM1 fFH30e2ƒT lXS LLQڃj2""$ MS0Ȥh2b, 1LX4$$d@d!fF%JRhM `Fb"A2@`6 hM x۔Bd0ɦbX0QљMI!RLLA" 1X 3Aj"@HP!I1$XI1Y$2ZB c$X$ "d`h4A $с#LR&I!&01fa(K310"ȑAY0`AL2cwuHL@26fdAMc 4(1CRAB1j(1E,I0A5 R EɲBFdDa&bJ34Id̢(Ěda4 &BhQhhBIL E"LX.s20P_wg_QnE@>w">PiE|`W`ZV?u{//_zgMp;/н73:(س?M%ΎbU#{\@jGj 7tqc·BX?ִH1D ۏ @>^^0b\"G^a>koҾ=YvZ_Lx*ChSC( v7LKԐ(a)b6$SBv*m E+m).#J,+aFk|r? #X:5SA\"r 2PMtd f]\ X;_ ci׽ǥZ#Mh'KwDnfPix Ff60}IHчWVAbAII,A9z13u4<,WAE_8"%m6~e<1@{0%bY21E$qUˢu2. ,[0@*!lIHcYC9ZO AДwǙgF_@h.R;dZp>$_{Q?=uت 3FJ5@E'_S!T e|>VKa\}2eOs5ױP9xiLQFPg\y)ȗpó+;wa)Q u:1 3KF! U ezɇ#?mګAzi*UUԙ* v( &pgo~4nUO6!^]~zGn~yV=?x8QE3Uϓz؍*aii#*-IEͨT<K7Ug6Hgir*h#`#Y!s ߔkFME`(s)M)IAA+M(4jf&]QGћ;sDZdd埲aYљ~G.ҊQ@ʫjP ?onE };<2X6vBuſ%r^x[scBsCkiu!eA%@X,@Re/. `68:) Jãi*[Bڲ+fqD-/]w9GG|׋%VWc.m="ak1w=g,^'}Ƥ l6 DJ%2 WmV?LkRÍl =!,*t/l/)RCΖq8t"(g*:-YGH))ǙIv`hңԗ`zPddqIǤxGr!)NGu(BsUN$E ajXGA0@f#i&Iz#7.18U ,vzj?^ׁU [lm vR,ba» ªVp*#cW];>NV-x(![Z@26)RI>;ҐFgNi,o_yꮼ nZR>8R^_?L)R|dh< GF: P0*oȎRJ,@ U]3(5ͮs)5 F16%`J72ǩcjO*@٢0cOqZPK̪~GG3TÒ ֢E*A)CVL_eZAB޸᨟G`ED/`RLwDB0xShǍGo 'ܯm9#BUkƞ$ ^t(PMp>x* fK|s+»ݪZ;05g5$`C!MLJetdbb82r4RRLrm`~綺M,~oYOz!eKһ8ፌL(a6O~iWT&%(b£!b=9P /UiH6QR`ދ swJpmndqx/cpo/Fu3tiL5"-QBV)\;?^&kHBdB}l}S}F , & ubS.U\;?~kaYfXLKSA;K)J.RIaSu}'ik>gmZFm8?3wN,kPњÅRpE5i (HJ -l%Z)>hQ J2 I Abmz@ l6ĝV*UQ"U%P 21U3gq8m`Ct X3L{c*߁0_J܆<`& )= \oWvCӒE]avG$vuϓtk%VD#iˮbJё~'ym84j֔Ԥ(z- u4ʩb41r6ci`W!l MN+S+z7`~O%\a» J]J{k; C"bq{HKe?yY)>u/P{SM4(go]lbHjšVu6nD|j&z{ LQļVa7?XZ-]a+ǘh%fLz_rm^;N@Lx{\xrh4opq"ڋ/shحg-͆yJ̼KbPME̺Кaң_Yr־QOD&zVKsqo+H Z!ejDd̓y4tJlkf5Nmޕ|cA)*ٗatkr;U lĄg$IMRU۳# f`}oɅh 6.r[)g!܈U[5,T0zڕ +!,/LHG}tS2e5>߄ ofteںAx; JM3 Fg-׈ľ;k6 !Z Ph'e"5gty51j2ggDguh֗m%Dž\̷Bu5j;&qmJxd AAr7:я/zlYi[4g leߓ+ֹgV7!%84&0v/"I!I,tC|RT}.'MRa(\ ``*˯z5Kc@yGL= *+//4JC_}aY}ڳ>{">j~zݥ0<1=&bgJ/\r|dbU]Rhj|Зnimh&Ӆ׏Ґ%q.4c-lt޷ݞ,+،5wІ^+Fj%:ۍӑM.ZӫPC[ |$\PFѮ5Z/oC"p"<_Y:eʁ=І bbZ/s۶ȸϲmř/[YOUj 3jVY:yޗO7Txu}Zm&V̻k@ZdCu= %.=:E1G=7{_q6Q~2ɭ[g HR.)7կ{^_wO$.LQBQcz :mR s=F뗨}oIۺa,Dk)x%:`G*(?]# +btFi~.{hy 1W}R"7y;+9V]Ɍ/ 08wVcmDfqT fde`:MWN]vE75JmڠprzM u>]:}p5mt@^֝tk@o26BjW4h]>ujFqCcHȯ\!Cb53DAm]WhޏzR@8\1%P?}3Y5<+t_B.k0UuG)Q푶ʽns. 2F#e썲>wZ^bcr=&kGngb- 2%x!=՞4FB ?9qtـԶV{$[`D+| wpFNk0Jry OH8s!-F3{]ۺsx4+';9FR\kŪ霜c|'}k _f#0W|qJ_^dĹvSMiFa @mI4Wl|IVng)K,Ԅq><K sj"Tu4hm9=vg aKK4TxF\sO @ڕLhtfj'"(GI!k:j2KD:C!,ަ ͒%tZvF:޳:M 3&u*0 8Os lեYG <lRÒRk(] ;,{jG[:vC]Uz銃뎦W%˾`'__y~irPoJu O{zM꩘mWu_U'hSn8;uƃht6O%*`׷Hbc‰^VN¾t6?#K)26ݞ36X-Fvl&*%2a7={>{atӿ'_'P7i 6bgU0?Nʊs`wd@荚6j =;Lh%h=qp4UTīgʰ @KXuh[GBۼ? dq(֟4=j huzHٯ^BhES]M\LRZNJrT]Z8-yzs3/P Y^+mk Ʌ$C b&5V4V֭GݲIUzZcR-!!^-Z +L*m=&B؋v`m@Ⅸ7bfu+#BHDLAS"lYrZ2e!_R# YdƴDA Ƨ&+L^H#ιkݛ՛J絺WIװ/$:p+f;XShUIQn0\QXKloU;J=.wdI*`B )4"g*;AYsM.:<=h~wΨ8j|m1RLJcUB*"i_U=7.Z-9]?m3 ֽm75f|, x5׶D P8Ĕsmtv1Li(Niw9(ȅr1Ee W81gYJbqvPaPPaXM&>G;UF5 Ln4ΨtNTwf v۶ lBǛ*kT A\j981 (rNjE{׶(&9%z먨t5f1ISlPMn]-`< e턜: hG%Z08hК+WA xc`DV(t[ vnJ ۞7#[Q485$ J쪚fT]l5Lwef e@(.U 4 *aTAK4_a7Vc^Z5M 45:=bmpleZ)83miSW 8s`߱s[bCuJ ]zoy(PAc'^*{W Wk_ڦh#b V&rJNs8tQ*$իy%ǡxU+TEO4,Qk#3n:r3hoi<櫈Ӆ[[7g"K:(LӕPU%igi!n( ԕT#9٪k>; FxMa*F+k<)eh-4Ͼrgm I:Ȩbū\31춥Bsz [,Kp~t׊ӹ-F/E>|dD1%4j6"zY1[&T%AAf1TXSY˄h[xޯk4d1Œ-l)* -IR %sITvzsI?ɌJfk:kfFZVq2EUqg i5bqM`7Л(Z5~y]MeS|J5ߞb|q^>2Nw_%Y>DQ-hZ$jepB,K)%SEUd|ˎ4 +1*63SIu0/w<߯ Ƣ:}91aWC[5&kD>s Lc &v=U+R 7~0Ԭ#u94;D'PCTv2z9l]gK G%N>6C a/no av@V,>8V$QI@ 0IJZp )BQJdLrIf]Wƫ!r)=0;pw:T;1m?jk4KbZj|t'Lo]YuHD9NzAb_ fZ~<(k%;fǡuz5N61Ph^&%*7N9'. `&#mre7f7~t|>4#lo{HȓLPfU.kftvծ{~#D x_-7>+m.cEf6u]nzy :DŽ˕@Ձʪ9MMf 1H'Jo2^eSƋJEO};`zޖfvs5ǦoZo\g(8`PXة;7Tf KIN̏nݚ)΢ s#7y15f˜4=|`ҙ^- Vk4KJ'Y+,HDq]*~(p gfآ_2ݖ" 0*o6;-!n^T; a0"tK߳xÆL+Dz}j0ITҎm=V=c7Rn̑i.76Ad(N)QjK3XT[Y5% E?k̟ՠ4msJ v"WiQmdFZ#{ӟ|u<{}vZG.6BNO±Ηt[?1]3s #R.:o[WӪ8u͛[yNzgiQcfM3d0p8sɪIbzidF4ܵZ]#aשg)9G8뫂H۹)L h=|ظ< g,1xrmy>ǯ1{q%o%yN+}2^)\d€$ %hwVAv89HN\p4@[h"C@2^H4:M<\ @߾Z37Kzs`L;P*B't6G/L|*I"ڴV4r #Z}UTE 2fsۮbjnl-m{bPQHZ|shoMX2H${jf'<᫥@ĻtvLesQ-(W7gKO'&.]GSK.BU哐RånMB%D㠑'SSD7,英,NJN:$ўbpZM|",LѐZ5v۪s,2)< wSja@Fj_qw_#ߏH(+YnVaObLySKg폡pQ [1g[f㯯G Ÿ˾g=gXK ԢíHM%P^} ʅllS0L,NНkc”҉4߈ja~3|%m<^)ȿ4?*6QmB:#ws zQťJ6fC \t ZB5o4ak/VEK2ޛL[-,,ddćNܰo]i`#C za15br-VH]ᛛLqR};f=о{_?*ig zr¬׳\ԱzFc>Li~dKLV8r1%i*]G[вr "2.PߞtC~R'(eb Tbן S>k@s3;WӪ\CN:YlMd]5BGnʼ\`&<|x|dkx*x 8c\i'}U׎~\l)Dׇ?9\VWHf4~5[C&cFQV*3=oMC/gpոFsH 'm˾3֒X|P+]-JpF QME/ LB#+މa:Am@5k5oDpN:z5kxzUf>mvsӒoLDlY=b`:PtU_;>N^/#kNT|ȜUI=K{o\8.sj C>WLd>:鄀U `>Az7`J'eÄ80$D9-%ḁBDH_E@N6ESG)N]o7&^.mW[xթe ow&e%Dٽk'>E=1ڈ>2j>^Gzzvj4l(ϲgMǤ6ڿcFemkw:0-4%]ّKփh6XpOb['t#>]ʍSXH K`N8;whBHKB1%ATU&݂fZAB֛AD/1M=N2 O !CIxqz{0cY.#뼶g:OuqOU:EXH.%$/mNsD* קI4uw=jv|k=ǭ9_Oc7-s.bV5 +n)X]BS:-Mer;w:X%5c1%^LQ/dG(]Zdyki"i#).&yAohL3%uRҎjX0Ix΃ޮ$6C\=ZI*޴2bڳi6L(>#E/|nf B.i65Yc6BڼL fͣLJUTMj<`/]jٲhŽ&T W0,xKёU,A5I(E5.嶷jtcz~=#pimyѾRwwE TMNr{ UW0ƋGEhQ XEjMV0";?"*5nM=TZVYQ ɉ}6u[x[̛"nNt*d5XDr)rϮkIy X+a/ c!Wsnޔ\oH+[W^ɧ.JG):5MlTR 1ǏBKg-7#J^zQsg-x7㕠uux.Y v9K=G5 aR;XYn'5ao:?<)*kYFΒEj{Կ涭'n"ݏR0 zfJ-J&06xi*<潬kh[&e,3b0hxΛ+\߼7zj;zP7.Ywgx/ *䊙huDG-aWS;ɬHl Ѭ&CtmL B­kzaSURP%R$بbBFlUM4RH %lebى jeKI$vpoV9IX("=1MN"i1F:G: @@H1ߛ+J uq4|Q耀!QD@>sPVIgXZ[]RSSQSxat r*RA@5B$RIUH%@ ) ETIUh U`4Ɔ` Zm"Id8q@ܢR z<}uowP!\ poDM_K ^J U>y}@fo՞U_;#@2Cl*kBJ(TSCR@%%%AA@(P R"(tue5;m@E }2ѦLBDO,r GV6^|R慉P(@@A)H@TPH*!P)*PCBMaхZ T*(T"@QR(@ RUJJ*% EE$ $̀!UFh8r $JP}h )4PT&iڻ|(t'(ꃰ"h&& L&j~TPhh @@$IJQ) Hd 4b @h 4TDLBh*~A=M' 4Cj%"(5OSOP P.?A2 ҄t KVUU"2)QT,-L#%*C4ҺreV ŨY,Qe XaWH(Ij\,F"I8\!ºFUУp A++9pN)1s"S)*$ ƒt$б."()U NY$VJZ`e V-U,PTXNC36YsU-ffF-Za-B(n.uȻ j]%HLhrʥXk %Df`K Q%Bdi %jD*-Ф(YPO+̪#VdeR -:ERR"T3@ӑh%;DED-RB$C Z饙Z’,K ”05Kf2b0HZ&QI*$SI"+Z(NfYFU 4ZVUYYZFSIP5( :ʰH4 ԭM, UaE\jSTDT$:JR]eKǻ:ufҺ ,YhE"'C-S`*EMAjlҺ%RU E痡] 5EJHt%YgN%iIBqsp؃8DYZ-N(FF$sWCT15!5VE:IImHiʌH Nr ! LA'DURrR)5I L$M*22՚EM0-@\E3TZ L.V)!ZDT$P&EEuLYņ Wi"Aph\#]^!aT2(UEG%8U)b'sn$Mيg,Yeb$%UDRt!KCS&iQ"U*,+l.$wE',rn%F8r$$5PLi$T*P4LN_qZ*,="$ZO0b$YG1MPwKdP\*jZ.v)m:RUT@OQC2]\#J TX B+)ֱjF"AT̴ULi! Bh h)I*22-jaJ, %J1a×z9ȀD]ۦ2gcowSaYi0ӰQFUʣbD5Kun(u<ޯ=\]w1UD3v^wuRV^=ePpsϷ#k^. y:UVIeg]\w/sq^89(srBz^wrxsW:`2D ˦Mp1jr4m 4HA`zǖt'QGr(z%y&BUxsy<ӌRս|5E/N:!&v;c"V1mRo5qwt1rȊx9^}hKe@hS:DVB9mIDj Vj< Q>o]ʃAxN_sH,Gp s5|?:Br7PQ6T*a xJծr-y*2ǴR2 V6ۖўOhrB*c՗,Zlbvb޲0R.l(p,]+懜-h^sw(4F+hf̯v\js\]yZq (!+t A(ZX|OV1HCH]9M8 ̈́t͵,9bm?KlDX]"WYả$ S8RVM]'* sd aI'crh&9 2(H<'L/8,EgPuoG=0HJy&yxyԒ< #mgBs(xu2%,h+htrN~ލ9 et4k(nj2lxkL9tNHHz9d(Tb#W"Y %u\+3] QG`ThOWm{躖zaA183&mռK643JA6ԓE_Jsh6NnVM"@ߗF˜[l}alһd\L]vׇαioSucLqDQAjf; AGB1A81Rs|'X֕8]^;.jߞnI-Rzxu-MCAj.U3gkA O5YHi"r'[1z-+掲7z9$NjفT:۷NLGEf4ĐhP\$MXĚ5֊<]֘}_]oHƁ=jۙiٳ#Lu8Zn*DD! ٮGTP "T"hyahyEDŽEi,@AH ocq vxϓ'!g3HS!",{FVx^O>]=O$2%sZsy co>6F1S 9phLPN#8ÓIWVД=3XO͵ļac$yib=tcòCթ-McgA9OiN9l*+cTJ MadLX`X&8'Ƙ\]^c_4JRse`ACN'N(Oޯ]~wo\PnAD2 FNDKGݕF$6VäΑ*ӻKG"/t{.OJdsEM?{(T|hqZ&y1pg Qog{$x;GTGCnDbĈ> H)]Y7 'Ma'4fL,`4u)+QSEǠ=eNLZoUs*"en#x˻M`}"pqƨ[XkN9xMJ`[!w>RтнUMq̙4܎;c$T'c=*XW*S64՗F4NWj=,fۛB6ܮM)(h:LmWi 愹pƢO%ͮ]Z&<{?! ߸\cnĆ@K9W`Y6& ZUPAsQiH.rSkaHu}o'(̺t*9S N?D4ȚgusĵzB6ImQhj*]x& >GЬL\)G8^Qx-ʷgbT쬠Zo&˜F1oDSWR*S*|_+G{Vnʌ$1hQLJ" R N?/&B셰 yI Jډnuz$K#n͖RJh}r˃&p˻lI.,AՅNlpW̶! Js\{T)tѴОtG(ңLRlUUfo;$ }eĘqmbeo9<FF̝Ɔ5NMy5T:#׉D4 {xkw=JL^IYC'ZbtSj]% 'vzʵڈn9{.v:Vbv壹 ۺeOV\3G [+qWLZvp&/D _g6NнgU=W,dN6a^Se2- IUd*{rrr a׷d=b9Ͷ L]j)ێtIedxJ9F?~Wz6#BoKdaΛeoY3,nl(VU;"bݝnJȩaSm5nɓכNǦ yL"Ӻ5Y_G9ޭ 1Tݢިi ) %o3P u.Izdi:>^vMw9M_&%ױ7n{yoRK,l˔JA5ZIJlec[np.RU\W uN%vaLɵ/d-%ͼx=p!&;.@:_ WEI422OE Rk~lQ8ݭ%4BPN!"~' 8\UynET]q;]\%qԏ=7]|n;/ LDs+|8ԑ ̢ܟ'E#"B0W2{_Hi56eGknNA&5c1kغEݤkAvoe9Ǡiȳj\Tc@E33ӧU9;)+5||9F"" wҽ uw=9E/W YTȒG""9/ $Z(&'8{a+w=-нMd!jht%mYLY&"\%̗;竻<=q/VX"t =wp_͎thqtG1w'QV*wqOD2w\HekiǢssժE*T@*ߨ 4tw=z8xI`N=ISqj;O p.p+=ŹSnp3ékkwR)*w7GE.Rȵ}ׅD+"H ]76U&Y6XUXrU܋p>Yseב{EVu SVhfҗ.Td12aBQ,"Az lX$22a\eԤjE Dh?si~ w6 N'*}{O2"F,syҸG{tYVo;) 4Fa+$0+R$PQ9r)S@0F=>? IRWnJ8^SzN{{/<[ݦzܒ{E׮{МC4=p &KI,_ Zx0dͪ.>|dtUdžfȃha{ P~!uWOMuR=V *"W^w/JqEGW.6v[.뉨lwT4uP1wd\qhu=#u4wq(1U.yC޸rs2Cs.@(pD*HssH*@E( B۲sDl+O H^B}8."*֕ᗸJ[lEPʍ-T[7\\wq ۸rD-$sqj堨ȣM0Ke+!.VRXQ!cR(h;B **+rŦmq)uy(ZU W=}HjAj^.5ڵVq9ZѴz=Gd}nb܎ԯ$R}ϼ+[ղ=\9EBM7$$!s6FӬ6,mFEA٘{CKp 2HLBEټ!mhYHֽh>)/E[2U.]=GXږBzlvvK:r(!y2jMt:~g~Jc6ahXEأZ;0rn;UUܳbJak QIJ[xN5:WbBdnICL`߸#()E4Ti<! K\Bg6svDnIřr=J+(NȊʢ?g 9NIXC!7&P9CfC.+vZӡ~< ?%/!"}< p?!IDB yv}.BH,ɂeaBb")P=@瞣UŖ\5ysa>dy\\;ELcM hRc&qծARot_Nܾ\Έts/z}RQ,d+%QrwC$3C7sy9p.\fn!|(.*/J]p_ߡAUZp[*,˛|])4/+_2/+JIwnD=r_}d@s @F3ٍpFd(]fn]ӢLB=}qĿH DwӽF1a/X3o J&kvJBd}D@|Za% s3 )(3ILPv~:K⪄ }g@W:#݅QɐAG!M2DADDL \Eyu"'_W~տWLM}Xp]%"I޺ɹTDN`RD'@=zR$ jw+r]*E1'ѧMzr c.lF^SO~ő{P)ݺqΐDr/1_/s_-۸ V;ZKcū#eJ62=ek.gYcݶr?1a[9#LwKW[Ȝo:>%YiדJ=(bTy@@RYldli̞aT;Z-t]PӚh:X͜^_Urv9'Wz'xNSLrevܦMsTl|I[:*dXq.ڵrN1q[|7V\}t{uT!mb^Svdo72B:U9su.=yvZp䫬z);EMNǺ4fdn(JXnR8:4ޓY V̈ Nֳ 1 A hu53 s>'\C )&2o>9eSUoק?{Ɯ@=;>;j~~=|o_񾓞ْ/rb>(и+u4Cy8s6{3 # \F<ƌ}y|ryK鑝nϰ{FMUW^P_GM~ǟį>{?~~;|Wzz|N~[7.V>7ңb}N9/|*|2VMǿQ!XCUe׾Q܎ߏ+]jwru>gnb{#ycJ ;N߈][~z&GZgc_.G 'mkQOlǟ1_?^]丿oi9;~ǯGqCرI9>:}=#Ƈ$Q{^v?}jwG㶁 !Uo-v>c<{tLi`P[^qƽob:'N_gozY=Nəxo~Nco>;r[ퟯK 롲Hp4zb{7q.wnkϋ)թhTէ5Q$i=#5nAǟ{={gO=z>c]>=LI??~U_1=!XS39jz~\ɁG^ݸ< 1֫קRN?Ŭ}9g{qU10ȢNVXROَuY=?+w9"wai9ݽ" (r#{8G QL~:t27 0NJL<*O/Y"5'Ӊ뉞59XB}TӥX9)hGA]ɟ]Ⱦ</V=@ S ! Ѳ +{1ky||){1}R#&a(eBhsTM)B-Ő)L.W"j; !zpI$p()NY*ĖwmڍpH"dN8~iǷ_>]wu{焊ˈ8=Y' k~?6:#X<ǿuNj#+`7ba&dhA͈7O 0ߴŞ^elB s)Fv8BZ\FbzU] pe^@iDk" *4I qg̮sIœ 8aϋri(judU1zKz㬹/n:_^Qɉ^ߏ6cyI0mH)`әaQ:" >{(,CԖ O9Q\Bބ3@qv`2 Zr8]9[;=%!\Jd(,_Gqwѓf5bGqdkypa$H;dOQ}XcIRil9@r)·-&ᝍvݓȧ֬V뽘ɂ:" P^Q{`ǨmNG+=y6aL''ϗF>mA"SXgy`]^ ?s~އ}bc8q?cXh6Rc3w1Ag$.?FBZ "2Еa:0d oXflf,i $+HbZ;Ȣ40w5\ $s`6$y5ٲ֕m:ƇDW[:0$Ԭ#88~B6oAIZd ,7HbHcyݠ8xN,R]`=u=#z&6E\>Psje"ؠF`Dұu5jN3c3`Ęe8z epFFc MpQ#tB;^c>:ڔ /`tLX1MI"T&!)-cw`/ktRauن6#PBID, $e-BtUC24MUɇ6e8ŬrJh}WoqzވߋvAw[du҈>1/ow:tJ>.KaI$! L&o5 w_o'21(צSUrY;Y%叠,d F 'QL7Dӆ{*F֍Đ !8"!`b8ܔ5t4kT vf<~8Kzq&e`jSm !Jk2\ 7hpEAF, G@Xk*Xa ,$ D!\S!p<11ӌȲHv"AXjpdZ>yMN#c4@\#YM#~|As׊sc*lLl)\K$ A3: DW=lBP̐md0Ik(po nHG Ԅd=^g4``E`#`2i !T ScD- JY,=\P6 0+ł4$D``G !I^skҞݻDGoCX@C 7PPf1T ͻ r?v2ـkO;KV,Mwd) EBlF'WnL܁d㊪5T12@$o(Ë<;(K=^_:rzN {B' ;+~RP$-vdtK`w-Ŋr{6"s`{΃;x `0 IPHZw(O%>cJVBalB?*Eޥ;94{htKE ćL&u߀(Z Zpys"bvP̙˄qnΜ]qËf9#BXMIJqEA4BX5^m /=n9AC{A2vhߡQy/ GD'bNJysYi>9e[#0 j^8(Q῟goU (@߸C|uth|+ TK6مJ9Us ?hSJ~)^@޲zCM*FQ:hh94V٤n&Z`}l@^O4BBmɟG!`9z;Q(B9TL*eUGTo9G9UlXMTA]rҪLN8΍ k j6un)StsiTiD6@!TC0(i=ƹ*b (VpN Q\WMliM"쁹SJRrG_0y x IˁE`o-ʣ]8RL8\6A(WțRP9Nj('%4Sb*"-'<(8:7yyxCMPi:It(#Q;4iTiAiZ)tRthA(J4P R;"ҭEsUn[G6h)< {̆@i;'d)>tǰ&9zMYnw`9qyIS>O6NL?}CN>wלfba/sRzYo9KP^I+~S{;Ƈy$\N!+YӔ2<kwT/yQy"A=] ׆z"9Nmx Ҟ rWi)h9|0i >8zܔ!t% /|']G'e)H$ҡF%.ePwA^JwDTJP3R] J&ՈhA)(hsJ7%s埈v=`p)$J SݲtJP߇5_UhiP PO'NIKT/G;c 8NcDRJy҂P q4f B.SB Eymsl)Tj+ʣX母nEAh+b4}-Q|&%)X)J&9` 4ȷ#QwPU͍Z)wxP jP;# DJvH5B0J% < B4!Cj(չF&Ɗ664LJi˒0:F GҕEPVNv kc5<.^n=UahJ"N (.wpt =]L؂LPmhce d(Ut`P)TO9G@J*RJd(A4!M-S@.}|U'`Q!d{,հre>ulrJ44bԨP˂e  V"#4~ZyFX8mHhP3^{g.kv%q+m / :9GGka+<ѣ^>%>={V:8@kLcfB'̏ P4i '|=Jw|ϛ!AC J nCޤ}9܉s( <#p;dp1rFH+>Q"\/uLf񑜤3M㴊qFMJ`ibsWt)C UZwWZ7*X~i涊=yc[3AT6=}z! ;01 )#q!こ`_i譹3 s,#``kNm0H$QY#l@eѸ(BP]/^a}{ϸOןIT ZT h 1i4ݻSA̸_xĞ^C Ԝ(wsDj$ xxcN'2cL9؈̺S.L|giSJc@|豁,o:ֻo8` pqI|fr$54@0G-F =ؘ}r~`ǝ4J@| :4FѢ lQ,.Pa\U]0H57*B`MкH&NyM]]q2HH28$+;A˜w5B0(%"/3R1t0N4 Lomt7fp@b(P5@A+l/&|t >+w=tl/}cFD&Q (k RC};*p:YNO]: HK-&m[yWRErZMc[rѫ(9[s7&@Cm,*ĒA;ㄣ Rqrp),b[Ν `4#< gͩOU<5׋q"Cly (2q{)OFםĻr?ˑŔ-̕{_dz_B]Ui&R';*"?;ÓF`I3-jpXdFLAC` RBUX1]QOyǘ`|O *0 D >)("m:z}A4=MU@&D!Q ES _ƃ[[*(RjtRѝiMSFՑeY3P(VE(Ҙ6hF0\IAa0c9V D"JBKA# js.nN]3RHIF5#[m1"k1c1XrhZ66h4TFȍVX-ͣn\*TZrDmrRR Kaj-$*U;4i') QA(@45k;dfh;YC)V* .]Ą:ӤLTHkJ-35ݤ#RP .1CJG SN.آ6 bmc;ktTٝ4$Bΐ)RhT*w\Vt(W-s()-kYXM5ʤ9ƹZcmF E-rE;tm8P eб-@h]RT256sJƍ`JV35n8HtTҔ*I*. ʠ9.L̂vT\UV ӗ2"kDˉQ(18˶] IW(GwXt("+m 5ZZ&YIsK]K6r"ӹuq h Q帲TdA9s]TR,nnj(H$ڎW:"݅QQE0m)q -ssFe L\ v"wvҘ*]SPaWH \F2ssDe08EΥs;9\5 "Ei3;@T(Th;8S,]+-s( SJHκ6K..EEmh\`ܣ`ŹQEɴ7Bb-h.kqݸ&ӎT$a$u LѴ\;!#DdeUQ"TU NJh\" 2.˙H"e6$S4eC5&J38P.k(5]( (tavY bv$], i1"$:q,Ü]ݗuqNUіBQ\L *"K%3b4uvBPLbvDD]PwqDC,ws Y ,\M`9%L%"Y#\%:䓦pF8Y4" b\$`:e06TtɅè 4&˅աUhIQ*.uv@&LEhQGBY 6h'T #a)BtT1dZTFf*CIB(ibLbpl(TZPYjW(*̬1r5˄Ё"m 9':*]˝naQsrf! F:sNvwt,&*ەn8戙Bq!"*PؒpeA&3tΙ(#b ccrvvNn\mq"&$"VeY]JHMܶdHW#5aQXܻ0(e&DTҴ,QDBE u]͖mT Ła32.Fj'dW#ӐW ˆDQJQTD!h"\S* H4 FR[ NN!t!wn݊;uاus 4C$.GI5wvNE4eGeiY1V[,k YuXR"&X%AHjI$I,9VB!C(̬Tي4: ȤSU8*ur%2Ʌ$QENи;+cBl Drqú;$5*(˜23:\a]G#cdUʺU$SPRɔ $rm(!DZ jABq t.9u38e%YFhe&hR̪#@֡Tي,$IDDDa:+#eHJr3A#L!"h!qT¢ge%8R(DQDYm8BLV&rZ4ҤS$8%f!TQ$dESDd®Ⱥ!Id\S0%p#&XjtlȡZAe2J# (܎`77R *PDIIdZQ&J*DQP!&2J$i;YmsEIK4Rʊt(B#B IsMXrR4tTjYJ[$Ch4(+F(PFBe e"g-+QdF%\FE$"PQ+I)*6Ridr$Z9r&2)9b̭+EQt؊J1NXPJ%&+RQUQ̴,B"!j҉&6ڥEaDJIi&RPgThDFpC"EI U!VUm,jQ(LU[2͑M I[j 0LJ$)U3.%Dr24Nd9 "Ab,J9LF7sDr૕Y)Yj'Z4Q%$DTDCAUt3V"Fm8'TR MSE#2Fr+g*CQbTlRIfV˔*D]ERVTJ&PbX%Yʉ # .$ppNF:&Er-;]p*19 ۰V30"fjH8乎uX 8XU,eTgfr*Ȉ3IDU,Lԑ++PSP#%S0BZj&%Kۑ3)!EE5$%DȩZ˄Rl2dZI hFAV $PQgshdd.MC3JHt3 p:Ȁ-)RE3\$ZDTAa&a,IUjsE(ŴP)h\ 摉вZ uJ 9$ZEE•'J*˥i`H™u NXRZKY,C#XK6Ӭ3+ ʃ-,RUTR$B"(5qhvrMȶDBUtQ4 "JHZ&C2Yq[B260Q RX[,3-W\$FIAr HrP,"(,BM3"""2Q*U"Ti%EUQ2jE*Tȴ!"9r˚iRUh!TF$!,T I)21 5lTՕP* ,ȋE5Y%L2Tk$3drtIu݄"3HjJ%()9!EUS(N,0SNSdm$KUI.a*!RP""aeMB+'Te$ $4X"VYITS4p2uȈ5ATVR&tZJ"2.UU-CZL,E4TRE!UЂ J%R!]Z& lEjjij""\($TNdww\Rb9t'6 !T.au"j[;hFkIfgJT9SdIӊWP'9J$F-E$Mv99:λrL&!9\G(덄ӹ MeV"*U\̔rHբuebq*I6WeQwdRt$$ws9 !VF,*S5YFt"Aj%eITJrR,:HD1Ӊw;0Lƻ 4L9\sR@"Ց ˄*ʂ&KPSBje)[XTuJ4Nh!Z!fVJm fi)h*Vr)RG(TΘhr)-h\FJ4#Z ]C*,R " Ε.1#W71HT(.QWL(U*RH+3EDLA ""rYĊ)UB+ 8UQaMLЌ2(54UKR$"JV-3-BT4iUВ1+[%;D6ALG *E"£bJ(S(VlYuԱiГ%)TW+mPTU&]Yef2SM*)efdXIdQI 6EV)+$MJIf!3 k"6IJ& l K&6S"E;ASU (* -5))P%8Q$[RI R$lShda*H5KIJi 1";*D4) :YTU@OnC*"*(!V]LP"!@ *Tr (4Q5l,Y9 jh`"4](c(hIOCFtpA@&@ބj`6O~$(H`ƶɢ؈ҋjۺA(BIIX4J% H.*!M ,&aUU6klU IM0)E=bSd"SM+A% HUT L Кh[M1i @ &AM FZBc4:R MR @)pQ&iH4m5Xeymm]wA$$ ;/18vJ BRnl- أZQ5")UaLr8ޡnnc|xD:@R44rIϑNy’waO;YWTRwN9m Mϝ#ې"hj#J:0 ]΍dK?5w)#OTRG&&ӑ%mV?, */KhO;tUd+`:xBKNȾyyGOO\-ZgT88 dH$1 ?BJY[V+zW\N#xwgzI:VUSBb4N5iDȷ=*uIE %e! 6.f\72JꢎHZ6pɢW L2oRD!= ܧqwsΪ{ ~bMβ2DO~HrORT$ *[C|:xW,rs8$BH E ↢ČƦ8RfͶY`c->/͟]#$~m|r;UջNp8xt_ws"ޮZrgC$ϞUw{w$N4ЇI\!BKr `E#_}h||C,'WHLmАSƤ#% "Y+e"#;s.6*3Iq*f3Hj4|y"mAQd2xF9'߫hm>_ԏ d^etJbR-8fj3lIxYa6_n:/Ma]8Z!}gUA"TdR G D3ߛ=N=*@ R+hXᨎ.:tl&c+d-$`+TȢlMiՉskX>泲UK$RRzR(FE*+djm~ 3*pKd*ˑH JR Z/zpuh pbL+]8 _BOv ~yCB ?O8:Q}˻ZQҢinЋN;$jҨwbRgˣф#7AtXl#D"Բ @,XL'/Q T"8w}"6MA5k! nȋxX6mM̗,D .bHU%5MJ[8Ѩ.m IC,,$4r]f@TB9)z+4Ng*^a0GI?H ڟg4ЁF niqOm|9]f#H7sh2ԙe.BLU1pmQB*%I2%-` IWӚ1{ tX1O5m\\!_m_ڨ}w.d?t~t rYR_}{Guߡć >()/uW+e=ViVWǰ뾾ۦ$+bdcl` nB* ~1|qyhjcQ$CeqG' Ys$rDKr!RymhxٽՈ6}Gآ'Gq15UAݒY+rĀj>슆L$DO~:D (a 4GB,K EAZOG:3io}w{t>c 2'Ӣ$gH1D,2EcJ I!`h(ɘE%)"v0g3ݹ|mszЩ $+M!Gh'K2#d Fd؊bcrd)SIJ guafL3&kHqQ+hBM|zϝ2ݤ1BbLg}_j <΋*|ww9Åtwv;=cy>(ǂ;@H@~>s=8"?1!$pj4!~Ϛ%P{詋}Hc'y&̚"ۻ{Q{gǷ!޾oƀ`9xK@:WyRz Y^0lg81)$5ZM4kA4mA,Yg.1"r\5t&4 :3 "P&E҈P$B%*)B( ҠA  A Jw(VBY$DZ(ReDbfQJ3`50FŒ$,ccF6Œ ZLEQb+TdƓY0iZQD(أi,MEcb(6LlTLѓBX Fѩ,Z-EDDd56-* *1cQX* %"cAXD̢R6cZ(4EQ&4%4LLXEd,hQԅX3H1TPP-QE%(QbjQ!PR)K%$FbЙ4F 4̍4ѴPآ I,`HZ#h$ʼn4S(Ŋ$#S-0e6M$hE"hȊcAE&M3 fLlf- lS "1$cKF1l$aQIDX AIQ(ل F jMP2EF1BbBA Hlh&T3Da$K!&A2D#X bhc4M6!4fBbMRh"FCA$e*3 (  b1 @QR4h2aED&5F $DH$4lc"FI) Qb$SH  XlAPb +QH1ELPjE҅Œ6,h1DQ!L%HI6 ,Y5I 2M!"i*5(ThchFhشlbɨƈ34V,Z IDXec%dRhE#"iƔ$QhԖEDRbƋ`afj(HQ4#e2LҖ"F*@†hcm P2d QD&3(؃(bd4ш֊eRMFhTi4$1hc! ,Rh2#bhɉFL$j%3YZ,cфIEfXLXb)b FdM@4D!Hhѱcb&dPk֋5m[e ld"4chEFFlk)#!*$!XؤclYJ6(ذQ22؊52I!X#c4h10&#b#lkdţlBIcb-DEf"RIbIZT4j1&hɃHIbF TZLD[PEAJ5IZ!ZLC 6MclljHJH*-$X ؠ*h!i*I*6Š%lXƱI&"6,EbآIEFƊbQh,cchb6h66#i"PQhƩ"Zh"1XlQ@A!&44D l6,E& ƱX֍Tmi(31QY4e,X,EiEFdj1d&6eB QDȨ(6IB%E؄c1!0B+CQEReF&A4X"&0i#BQAhZ(HXɨC"d"1TTi) Q0Hщ4I$H %"4f (E 1b4TF!5&J"J5fьX26Ě(-h`LƫcjEcTQ͢h+HUEEAU21@ؙ-FKFhYC$j5Pb B1H1ih-Z#lI"#"4ljJMcL4d0F"Ff&"&$DJI&B1IF5%2A"Ch2(ɢ1$D%E$&6aMlhCQLE EXZj-kUQlU$1h+XlV5FhT#%-h6 X mZA*6ŒIb(T%ɱlFe ĚИՋPcY143*Pj*JV cbiAHDIE&Hm)d&M& bX5X,E-FMZ,Qj6JRJiFZ@ TXZiZ F)U(D*تLZ cXըTI,j+FѱZBS+chɲDM"4Z-Q*6( U-ڱFQEUZ5hF+cTJ(B"ТP(VF*M& eb٘h"PQF$LhchX1E#QJM#d6kAcXF0Z4`5&565lmcj,chXm[cTllh [ckbZEX[bبƂ* i1 Dc $M)()F(+(KP&1%`DV LBT,h( 4E 5(EQmъآI"H#h#-&hEQhQQkIb,-6֪JZ#JJD%Q[F-`h؋&ɱXTZ*#F`"6 XBƒ1JEQA3AZ5Iű aFɰFэDKlcDf4)"-$H0TFTEIhAZMMQcQbѶѩ1HԁcEhѶMj6T@kZG؜-1(6-+hƠ+c%5Y2(6K% AJ[EDPX5K&ɒX MQcAj+& l*0RFLSRb*66 DZ#cb1-fH (Ѩ̢ŊԘ4K( `5j"5ѓP9y Rj6-lRjkFFƍDb %15HQ3lQbRQɨP RH$,E5 Xa0Q4 F2J6#b"-D` DF$1Uh4X%dH\̢uBg-%bڈѶŬV+Flhڍ+d,EE"JK1f0 BPQb"JA 뺺=ܺ]ܗ;XE5` ф&EPQQZ"jƢb[b2PJ% BЫ,lZ)(`, I65nl{$+$yy\k1$Qѩ(ƢbTbض &-QXڈX,mL cj6-i5h#F AWSxT&$WoK$gsy1u7qwn:cwY Ѻh&4DXņaZ*ŊHɊ5D64b F"EbAXHbEEE V%jMmeQ!S9燈gEdȰU,-r^H}@ j%<" A\ n^%f1{q^+J=yy2c#,梩Fct7]H(vN|6@PQ:OEw '=U@ЙAA|D@DPJQ([Wo٣6*hAb:N@w&HiJ4TT Y%6bF٘`[ l%V2XգZ-Qj@^cqȩ((%U!AJ (i$2-EMFشJiL%EbA#F*4AmFDi3,X1dYHY$li)Y5"43IJi&ŨF-Q[b(-b nEj*k[h4r)5&JF(i-"mh p6(4ъȕs\EQZZ(6̱Twt_zQEE,\}aC@hF4 (P+UZj"P4H dИbi&] T.J) b<J40`HhF*%'$JPt+&O80Xjmj 9>se%j\J-W.hؤT i ť=ۛI])4MFHAF4U5Ò[ou^& m^yR[˚5V5ԝ={/%@i\bn`-gvU @^',[9ض}trh|Wuat{y,\,M$׽xRswwtnzwG ޴h )5Br-jߵM)MHHP"R*)H>YEIv25TXH t%@AP;}iB)B6ƪ)B** گZ0j+GN&E6m)A9J&/nqȨ7)hnE$&'~ǡB3/fWehD+Ok<>4)*~z}y\zez^ݦ]q#¶8lMCY-Pr+/qDf*㇈=B3?pO M".O)(UOzj%O0Q*"! :&NIJ:%UH%̲4z C2B5Oz˜'HФU"C 1TiZ%%!#!$ %TY˥ibtDe# T!J!j'Dshk,5u;PtJSU4Kt>%Rd9(̩PK}}% Zk\Re,5L,\s9\9'2VijzH&D$SQS}. (2 єDvwZDC/ТLG0ZQX[܆|ύʑlD!a )J&DL\I3(#`cstf*eO]؞뼢CP[|u EL03$hi!D#7wHi##dihK>Q7\qJb_;Θbё`%#4fIl|n2$LHRs*&Fт]sYs^>r"뗩$?+udT\&ICbW-T9T"w%S>uAo '&&NJrC.s_\J2IAm0Kj V1GZ!rʐ'<]"9!6 EA sF-ٻS)!KwwQ ih|ig hg>oWWc=OGPB0w.֠=)dI(hAP(3v I6#F, 4&QF" Ej ҩ@#B-ЈP)B+†NJP*$@VM Vڴa AlͶ٢ADeQZf"QJtҷۅ,lQbsmcYc0ɈDQX H1IY˖ܬQR:s]6Wo/7HSr  Sb99 $$ۇnt&kWbnN=p|Ǻ$xov~D(ǜrTH]rn;r",JG'y ޕ}UV5p<%lC#8G><7[ klŴh cx(o# ]Eebd4A"I 52P5-Qj*֮Uj4 N$dD̔)z*(gx#b1-uڏPE' +p2 {\JS;T\p+0/3t-ַ9RFwSajΑK!I2:B&"c6#5R" ͕ Np eXz.:Ɓ:suԷ\g\w[K, $fI*v>meBZ6(^ 1QiJaK*1FF-hwNI3j:v(MKw%_j~,t*ѢBo6O5rTYE9WTlEp}>^q}hϛ^=hxBo{IuFSj5QqnRc&PU5.LKVAY(Yh(7a,-#zC6(E/;J*fB3Q.Hмݳv.gQsW9K{nN^h*"dZΫ+W2e0q3qȣEݥWg0TFm+)NvD+1NʈPl#YR@Q=ŃMvTm4!wC)$KHzzq %*,:Nnstإ5 Oz(@3 vΦf7SH#ED-cx N@dY@(n k uf"u/;3AUffmFڅ!eٓOKTN[b "edNw@Ђrr;0ve?s>31 %!~:F!E21E=g#~g#w~GozAo**ds$nP!9IZ=bpʠ #I&7.~˙/ӮuRQ%"Ds7Ct""\i,$7L$u1(}}P(>ץC"f _ ot d{Er_w~_~g}Y\dQ2"f/$WW'7}9\a>{-HS ]v&.\}]߯wOçͫ4剘0/WS/7&6evy$;iW[>ze޼8xI|S3|lAϝ7.R~ˑ |FE] o׼@K4҅ RGCx(VyCQB% 2vi@^@?G>˘cqܷgIא;b}h G#(PIHcñe:,y T=qt`IZ`uu:LPdAвtH܍O2+r8Q3u}Jy8wD_v\&AQ7=@z$|8C%iq2}da 3w!EU}*9W4ZccH|1ۦt٦}iY "]D5Q QU**)%QD6kE* x*9ĈH(Ј)@P5EV*,kkJF[kkX6L(S&ATUUB QhӤ6FUWu\QqM<ڊyn0[nXtu ʹSN8*j"$W(͒9͏9/,] gH쌼*$wvq盡>˟7&i9Hr'PGvxGy U(cb6OV+F̭ ,FJ*JPrRe& ab"!BB7b{wW 1 6d06L"7*bUTE2dՊlUbڱQZmj5WJZhE3ECQ"@P@O?%{!IAB:* |c? 2Ϧ0wk{v}ul?;GvA-*jٶ­UQfl()b@"@ Ѷxy 5hi `hDѶ%E*5 RPER)E($@*@)(TIQP%SZP@I T$%UP($-#A"UUH*X d!]|IRP @(zH$ $ RS@4TlAL5У P4hU*`D@i!D@ DJ@$(R( CV-4J!mVmVJJP *$ʆ(BǷPH(4kd  sl{}Mj6Z6Š%'@A"Ǽ티;7`H }iͺ` P>5mRr%)gNs393"绎(*뤔a{nnVu3)1j"k@4d*Ӕ&OZ.C=uwEHlѯ.E6 $㥓-"T\]Nܧ3v㻞̱W͔>z֖EfDŽlnZhZ˅zt IUtOsK3(>wpE#Jz^.) ™m aS]c$/D9Fd ׻-XGeI(YMGtz(U^Hz;N1<ٞ`8&6.usK`6 @]KZGfR Z aVRJu(:n랶 EDV[em[]\Rꧮ.Y!abBR`堶R؏= Lwn^$=3w1Ipu"nb橺V*ե)&#LmkWDWarCs8޳4<4؅77[oVC#̨b[)((ɷpiK2Pc=N' ԍtŋ"!G9Wjhϧwm{-)H9@*Х D%R5c*eK\%ވw43",G$M6BĐpm-%%nv"Z؊4 eIvȄ,swq'olTޝ)'$XM%P/v]=ޚȯJvfz4r kxV!9DV6# )b֡۾<^ `A"V2Ki'l`e4Bq bi j` ,- R]@ݸrHEmV[QM Nyun;)JJK4Mɳdu.;S0+bc[-(\ȐRcĕc[V[eKPqzNs[JNLZb-G`V ln^2wenmt;l݌T^1#YkM54&[ӭ׷MޥN2.ooAXKPF1%% '(6@&ݷMV,Qsc9ǥvmV9 ҶYRb"H8mQt$hBȊHY43L'wNy] 7KH7$:Nf$仡%%ǵ ,E@kp`&(3ݒ{vw;tN,Kل8`C3d#M#[ g22n(um݊EM7R$4ݛaR׎5{x]@5x{V];f |yM䣿[QOˋb})z!9ȥiȇG/Gbm$3`z^=r:<_8]ZDӲN"|Vۯ{v\yq@"МDt+:("͖Y|PQˆC<{w@0|4L)yIM`GT fieM$_T =MC O].B %@ 10mHB"數Qsq qw9ΑtSsHG((!Ndu(qR68ݝ)Ý's}otܓkD9tɤ2T" pB@ D75C9R̈́ ;Cyo SEtQWIGJA!DIN(Ũ'Ds,\Rϱw. |Y >:$AR9q)9(ւ"GK|YpCw%.'K ]|g'"H㼲"={ I+lm*;N#Ü"$ ZGu>s47Z:S8޽ϊΗY%pt;H菶 T\$R'A9qu>wt%׷HI]'qQ@8qQ ['qϥ֗o_$D۩ 4l(#;]=qN#nm}}^@I%s[Hxztְ:两EyyէGq^YV'y%=zbf{a T.=)Y=Y}8vN}&!zyZ5ݲ$;dHWnaVD\*&x9ⳇvK (!'CCa Xb(D<Z,'$@N;<3*`Lĥ#{2&_fxd,Ja kφa.l|j7SPP%<Q!W 1Y*g.D4frR-I%,#NQUiӑWaZ&t R&HL8I'fcv--DR̕9rIJaE٢d&DF52idsj)r[YۑY$Mr+J"$XݥM6i0&۔mۥJӭ7.̤乭r"N3ٵ'ePwl݁rtq6fvFŖ22 ZГ+JؐKNֱ)ҙĊI.\֐]:(Kͷ0vqAݦDuQbD8R bv%@\Z8YK8);m6+.*lJ\W[h0n⎻.Im\Vgg\WEuTEEDWUuEhQwT[k,ZZ ֔4 (;mtYENs2P. .ؙI9LPDNFh)ZFiS!TQ@KJ4 ANiҚ) JmhSZB%M4\UfetVڬ㠮!(] 5J hi (JD( \wmӫJ-*ַBĂB:RG\wNڳN:mYGId]R:@ Q *Vf$eaYb Ge*.H$YvY9JvgI"RI8G&udQWqmfbJ&6tAE+(B"H%A QڳܗGNQ-i;R*.*4Eh+Dӎ$IqmJ@N:êi4)( ] ZG\Gqvg%YlŶlet]iW6 .#4.֊rAqHR4JPКlδ uEvwVڻ,:"tmYfۻ$wNGtQ$UY۳˨HRDL&$4]+mrۈM3:32mwYiZuRsi:@B֕ HК q +Z4i4BlXѧAEJj'ae'p:Ӏ-8:J 㨲f컈u䩸bVmEaZ;Kҋ:mvv4eq۝gbquts99@]faX$\pIqrI+h"3vGMe&M Ĩ[]wT%gtQ%'!e[5w)9 PkHjHRB6JƝ"T1$*̨VضZivEvrt"mNa6ۺ(ݖDճ&Gmbݑ8j۱ i#;(i;7 ӛMLXcV&Pr9U3YÌ(ûI;[uH"qÅItNrH!u'D䢗 w)" 9K:N.K0$)Z-7QTHS$N(닄:˳(38LJ;.md؈4+m,mUPTtwԡ6([mۢƻNqB[eleIBmfsVk43W5 :EHIU8rMB",fřL9)4tsI3mmq%6n,)BM+4%.G9qE ks#uS0갪 'I8R$8Bq8胖d;ٝw'nqnѭp8ՓkVXDHwYDV]eq!e6,.NSpDhT.4MN I0щE3\&MkY#m;G8m Ȫ*hDm8ZEvmfE1[VtVETsrU˒$Ur AB;(.HIT햭ƒ!̌8:"PB&-*;E%J*Q"ͳ\i)(&%F&puNˑ\1kmȎDVG%9N&mMn܌mA !(E-l)I լSȗed NFM8īaqeH]Mdt‹8 h:d4*B͠Jk4Cf2- ֢FBA$C:g5a4BV9B֑( Ҵ6b)6ħl55$hfq,tݶq@6D䓳kvCQfsЊ̚7vYQ`L#R5HQU5,uS\maf謻C R$ӁH\9E!ԓeM6`$&Gg8գI:"mBtpm&@U 9TEAJaTHdk0Hidfֶ vK k.K6,ɠa°D洶wgQ\ۻ+,KLJlv hʎ.nf"I)CmݜSZ(rʶ%U3U' ad1fZЛZŹ[22mbnlfRu#[BE"Y(a9bDvHNe,q;6ӎVXJp۵:WDk4]AU;7kXlXmjD2@Hfm[cX ͢12:Fl[\: Qi:vĮ*HFv ؒv*$ӈv!,0LReuvt]%*%"& !KBLkmn Rgd$5lY&KUNGBZZZhL4:"Nfj!&hmVd-L***Tf !*Z6!ΜbX--+EHrMN+SVEڴti1#ePjȑe ,Sl̴ܰA9\kgI RA#l2Gd.\kfAb,ι]k8[GB6Ze#$s%i! HCPPZEeL fMlI,mf"M0"%ERd dST8;ik&؍i;-͉S.Th]iR]+.Y)20-CJUʕ:%+2IJ̴,钪 TRLEiR jii \6k)!9A&Y4-1e⡠jp$b rP#4p;;QQͥdFZ6!ɤG(e6k %ZPvS)Ս[ ErZ6%M9sh6DY]͝q."%ZH$ElC&*jEBt5l!Ӵ ZXVclmtCkmVqkm[6sTZLT襄Yӭag"['w3ݝ횊kZIldvF͝--VuDtw6+;m:N0m8qd:qFMj$[n9iv;plt4pF ; l%Łv \ΐjdA YeeܜvF۫++6t5͎ӈq8H:-#mcekn: & PZqCIc$lmrdՈIܑhi8fhRv((C,n$p莜%QScn"'tNG6nHe NHӓ⌮#K*kw%huZEKi ke!,v(+ ,m`Vaj, YHI-.q!ĖT(-97.RStE3Ϊa,4"uE9T*S鵠ڜN؋ )+ 8m\(ҊQSU-RDfZ3)hۻ,nE 21 i6[8e-XEMFM244sΒuiMVTQ(LDvRK%FtK *VP CNDt"q*̂Cq H-wfܐ rt8GI̕J\wqgNv;e:ͻq f8.N)$GHWueͬ]BhȢUBem3SiEUȚv25fff\V\]hVQZEdهv%vv-sl$-*3*IRQ!Юө:&IhN#.p3NJdԬUj%RhWn"RB#(! UZZDRDJ'KHZ2Q)+UH9[h9HPF%1 @JG*M$%&mfR ܔbMVΑfƬ-'pt@D$;%É$ҒpӌֱqqfSnq).&بf69[V-fG9I",&ևdmiƭf.N8 a# 9"8EÝٙQsq6@#"Ӭ;S0NG ĒUdu0AU XM$8NmVڎ;hԶ,bkbBv'($H$9 hܝKbM8,.83 GVcn3K4Y,69%P!:aL# cZ%M Zm&̓m Ym\˨'mI9 [:FQtQ[kpM+DQ lg R' YE-.+S*D칠]EPtsm fDXmcllݠ ș֜$$ѶmD9#M"p8㎑8!9YJ$vNP8%Q :Dfq'q$mm(!T 9(&ݻ("3*##8:m`p$ܡ8AI*;m#9՛9'6P4-%)'Zݢ''digg6-4QU)VVJNRWS CLM&15lieJhvuGDRM)ZuH(̴(:";(mfYMAvBʦ+\Bb+0MŶβFTVu\YfqHt [Mm4Kuhfpʣ,NRGqE]gdprviQYZtGq8"HI RvZjIhPjBUaEa[X[v]$pludU%KvDD.Y TfE#Xu.fQrJAu Z(".TtʋVT U3$CEi8"NIӚ(k1a&*:YXtCL]v6SƁT-X eVeMR[ J,άm"XBWe֜ +Pč(FIVge5vqŜpYafglpvZlݡ%[nL&-FYLHJ!9BM2*ȋv3MIMflYfgdc25)[,ݜlr 4+c ͝PjTjsP)H)DB:кu5svYN@JiXRFElIaVXZULJEGN[YfلsKL#iRE"6VI$9eٖq#MD0(DȦZ ST*SddZr r" gYW"&5eˡkVFh۲EcX&Ie*'"LfeդGjsi-hu,(Z )HČJD)Iҩ4(ԶCs % h% n5g8-)Y"ZִȦZ.ŭf E"T"ňPfI'*ÚES RD")Y-D!HNDӥUV3qmѝ(hQ),E&Q RRFWLIJ (]9E2%0۽+k'o2F.8JN#[NBHTKeL軣՝ТGr䤒 .BP-#M A@QB@-5c(r񞾀,'sCY\1q4a捧1BҀ"PI4EI*[\瓝"S`;. "C~CDV(@ޜG(4*whnTm': w̴znƥ5>kS_TV c9>zCϣ?@_c~s+#1T?.q{vdbnC۹[FAfKC_O  +$"{*J\8.] szzRW9|;#a+w_omW=|uEwߖ7a|666w/3Đ3rHQGʼ͛õ7ϜhNx.%O[S~8&[W^٭}+#W7OE狼r-n_o+]x<|e/\R3G JjyZC>1[#'˺89Oy_Hʜ,Q&D :=OwFHRNYAHkiX- }6U62*-$ӏ;|*akXmdpPi ڌ+^t5gNK5 4&ɾ1*`T$ !Ī0c1!M0PīIL"T85(CMFxMXD[7vn6+Vr:j!PDPkJ ȅE/X(rt,)?C㭑?ܮ%Wj-A!DgՌ*͛g)5%l>LL2I痃&?:g}UGnZ I[SuN$ Ut]c8ϛ֘NIXBh!= X@$[0{RgQVy+=,ly×$f>Y"0 CH73IIL$HD%!BEq&U M1[mg-5.ءQady&^l'[-MmvI9-qz@};b5upҖj̽2%]jZVp{V}Zkggb@7Yٔa(h`$a DtVʿnL ']'m9v0ǭADUX*5@&n|w8sa3sd=ˆnaZ?jH'`Wz)ǽV(*A6¨"=ܜ[YH0(r h{zo"(ߑH 5/9(hLAyygK-pá +(F{-Vb *0$%.+IM*)(P QaPX7pԻ#Dei$ b "an̡lu'\]9.pJg,fe9+) {&hQ 5ߋ4 BhHCa4XUYtE@(ZnlV"QpUb%J Vn]实ߝA5(_ LX#雉NA2 G$17@эr>kHb{=6gLr-tޣCwvxhWX'å C,+t YR˜q%@ijuX9bFeQcf^T qz4m̭A:Ȯ$B$u$܋'o,NΠEe :8f&|nVyxP+L{Nn:Mp-keiæ($;ߏVw{ 0 Jz'zsroK97e.EUXkkNZhUjڔYE+4ӎX0:kH9s;HB.9$N$y^#mԀBH de.߯7dBy)1z@ 3uqrw9mZ6!ApHI):J(6E .) 0}ݙ'oxFa'xeH%Ť 4J(6?ۭZD A'>Ⱥp$HrU I'9ZCRP;N'r'wӜtHHGsGiHPߏ|pfVg6z#$U6"t4N:(HI"h%?ONjpqE.Q8QSK~vp9H\G}k/9J.u :r'_(m'^w%߅n_Z$HA1**vQ$E-w壝hs%wD+G"jSw%Ys_ĝ8]ChD"/Y9?F'CCοԾ8|_Ouk4:rzaς p v^e=_ojI2ix&1R'N I+['Sq~u:Ol\%GsNI'׷z\E!'夿ff~t߅kS"#~5gG$J'Ap/W/w׭slG?M'Z}}8<r9{_c^^ 9+Bwn\Iqq#'>trJ{h5:wށh/{^oj He 'oI|hdI[WjH+ 6w#`yDtuv^kZ|V,zf CX=;i,!i`b0i<"M',Q{g[پZ ̵T,(RW( r&ɹ ߺ=ǫ嶺4 =z<2y rz3ILS Cre*7 +H 72,Pq83|.F=H8=Ӊ_&&3̞'z|5V )Fz^!^z3k jR [lO$~L&˨hl PP5*+=][5/_ԉJgYT\gn/(' 8.ˡvvYX 2=۰s Ε1eǝz@UirQ9W14A /:gSC+jȭ"ngzzclfPmITk= '' 9q,mvfhN$d[Xr^TNȢujtqúhye:jsi 9wݤ%r#r6,=XH$9,fն΃LA Ӈ:m)َ;RA(U\(Զ„kL:QS /qWFȎXViә:nEQr9SA5DԄgJQHu%WqȻ.S,jI0RN+U"jZ%kfEtM(]QzЋ@`tt:v9Nʳ 㣬(%+ TK]纬6edm4+@ȗk5D畁(9 : Ǖ^IZ=mrk%9-qlVq  -VڰS9wh!Pځ3g&K!0ISTpSœ;;LGmDwǎwE]m#9EDDmYzzpm/|&ŕ$KnR)-e[kCd%HV֖ۑ1 p5VZJ6&@swaYuy-W%aVGD\/3YDI,͘ 8E=ֽfpJjhRp,kcFDZPm,c nP w Y=:-)m^(<򰢢Qקr˳t"#mdw{d=rrrG*ֲS;GiU59<݈ ytA"%#p;PZ[ppG en#4IEtH\wfSri6rK,Cm9+4sΔ \st6Nmq!'CN+32͒HW33DD 9pNN[V.!qE99'$w)Dpp9"D$'^ؠۑ)$rQ8$ p'yh9Zr;lD8OPGSE SD##J#;%9J.#PN<ԹVTD9GsGQ\G9EHNAD&IȎ\ 9P:N |:[SlZwI6(#N)qEBHN@RQ+K'DDABw9“d:!˜E;GBCHtC%"@!9w) 8N=qˉ9pY휢v݀EX#(8\L>_\p-ksȢ$NkRrO:ԠJJ)2d2Ewvֈ(9s">mte)=o5㱵E|AiӢ ++; ^ir!|e'%8e6'NtNlQv@&6@dG6R:aQYMrW>y݄bU!DsR#\ki a$EݶMbQ5eceHwEr,/C("f2Ɏٷ{KUUPM%l34j{ylςUbjhX)@ު`,⺓H#.R ' 9ufiAVLTJL<7:JոޭuVu6 A!lHĪ3L-Fns,;eb%ݧgg✄X>ɾ<-QM*Zg7w8q96|M+%"I&khDbi' Iv4:ib%EtKU1H2oЌBt ̐ 1V{e氤RQ:IbbFbRdH(8h'PYȑ&,ZfA.iWYQE&`CK J9Kz5 ڱF$jԢ좂'$xHBdQ$3uYӘKU\L$p(,래-sA8ζVXr2#-B edo;8m,L%DdI8{Yc<ʲ ./M0UptqdvtoklYnŬNM֓7g3y$K>>t9V%n:Z%(DY.;.+2v"pE)UK4406ȐZVMb8͙5.[чuTBCsIM2Us$vXp"̒ QZEH`ujuD*Y#HGw*t$ma1{N7&ie!V0ŀDɘ,>[N9vEL1eZB 5hI$yv|RY2P'nfR||nBn"@k% L k4\64fnsgmnK $`nKq+eC"1ni iI YL6.ul! R9 DFz#{in +Q$fiG0ݗc/³ZAGI/'| t0Ce@6I޽ou8CrrS!Dn d$F&lnNDc).M 7mîNe}a'rD@(@'{v98qpIGr{|grܔ2B;t3I y0BRD#Jxc 鰛睲uLj1WUI߭ӜD8Wַ\"Ii)f9Z9:"N p;.ȑ䤇 $tùps@$+ݮkG!Ye!{ݝ=x{wϗ >m)Jp:ÁNäCr. ĸE}m8:T. B)89'_5!:Dpq!ӎ:#}2_[H"}4$^$p%PA=8_[FX°5ě;;BLORB $)!k-PQ2IG8qrDQs8w'INE}3H('Ht*ND,;$sKWI:"'G@8li!G k"x":'&odu/-*.+ǙE3}+ +2NNK9$[HI 9))܀ t'8'"JHDJS!˙;Yfe !tÔ/m|cwhUw-8坫%"}.G'$Pո)btCo{PtpqWHIG*Tq<1$IhLII[{v2P#v}IDG'%mś`B[;FxZq2^(d6`BJ$ݺUd5`X 605zBS!IHW,evь  9rX1Pu/%H9&F"s8;F.yeީ|pBbMoc$ɧv.iL^3E  SCpqBPih/F9ޔp7]yx3@̙\?+7h` B@k T0㔣< !"1fcTz٭>bvwD Dbptos6B|'7kս W\BȠ*kfuu]q/#%Xhz;ξмinUH)i7#y{w1PP fڹ2lHѥbٛ4 !]/ܠ#;ƙhmƷd-UFj y[[wUXw}st;=crlYa+aJf$'ZDa +jKf9 &5# T77{pmy*oȗc ٛaEHim ' :Gw2O'uoh\& ڤmdK|Q6$>;tȥk~*0gErGVhS, g,YA98.T-Pv(2 Ea:EfvsAil&\#9'8D Q֠4ar$S3,xM4W3S{NZeIVKML7{RrTv,n5ԋ${g7\7aU= (i `m_. qyN$ϿժnZW (ߧ )HPNn:քRz@H6MJ[nN .s#"˸8>|ƵtGI <ؼ  >gxD͞.pqqBQ?;ց8sܹ s4䜸tNNq~8-_{{œa=z3H^$p|l=l7z?[ʋvW%H8DI8C%\SNq rpw#'9ΜB\>k 8Rr.;-P =mgU#:Z'Dr'sĢHk-{%|h1H*H:<8qʇrw8q98Hf!9J ('_a{sp79CR\.(ƞIp bO[D$ny۔3?f>+>֎^X?;ʼ䃜-]sHE? ~6*$H:BCӋoH(۴Iq @c<2Oisnj̉b";̳*ҍ s燝/e˕L%HĘ)#;SnIo#$IMн׸H˴m^onȄk_5vi\q|Z\Ѯ"䣢}n $*;|WꬋvIeFQۧ#8G^lTڲ\\``C۵"f''ȤrRnGN kI2t9qpsCtI`N۵(^Y%۲YrQ'tQ|ے6IʒJN.#:ȀM-+3˥'>ފe Qz׶I3SrրmF,r>:qDDs8("hD)ܐpS/kSr@'(-! 8%p8pNpDfwn.߯W߭yG[i~aqOѡD;>7/:QEgg|]蜐K4;;~6Z8 LJ*]֕ᖧN:r8G{-&R>,#\ʬ!9!eUL4CËvˆn j%%6L"|.صam(F].HFԍv0ivktgTw hE*bT"C"ȩ4JE<""i>@ ~P[Hs %ctt'qѝ&*%wEUIw: $:(AOiOќ͙( i]EHuIԸG;*:sŪc#rR|4 fܦ"(HQCdplyr/data/band_instruments2.rda0000644000176200001440000000032213451046652016451 0ustar liggesusersBZh91AY&SYH,s2hP@ޠ@U?M=#b1iƚ 2h 414`R' 4 " WEU2؋%aX+}KIm~cu̥P A#8L}6yE*1˘(kK7!F)7UրIz!/) (RȲ }MV ث:ʻO=‘M2(4&, oH)&Z X5? Z"(H8[Ԁdplyr/data/storms.rda0000644000176200001440000011654113451046652014352 0ustar liggesusersBZh91AY&SY<\@a"U Yc;f_lQxQ@(A MiNU)JUSl*mw;^W3\th(sth"٪BF"j@(P(R(Aڱ14)J2  77( @hJ:E"(@ܘ×z:pT_{; )>(@r(IE  <97ЪR(g=٥HaP}>q;wwR@#و:݌^w (:FzGaVo@A4CE=zh HzAH44zhb =1%j4  O%HQ32z4zG6@h =@)H"e6bjmSґTzLcԏzeM F4Oj =@204`F2i`!jRDI'zQQ~hjiCM4=AF@z @RTDbd'5SM.}PM R)>ZE> O/¨ʥ*Rw;M{ts^$zbkr=+BW^zņ^yWfdy HF)OlR+EC""4T]UD5u$B/-EByrB COIB 2A3 5tȡB0*M#ȔEU0\/OC4)R\ EH]'BV(*iÇQ&hi]'s7SS˵WUծ):9tm֮ݨU}Ţ%m]7W^Zדlݗc-W2(UjMT׽5k]KنsI#] {dzf+ͷ-C&[ WWYy^5=zq@&|%vbZI_ 1͓Lx.y]ײJОG95Z6qiZWYϵ]#qǎl5=@hHBZ^z۔륑d\QXKj"CTDQv0DR֬\.wB=dASf+Zr\VkOBU.ݚ'(ҧjG$eH=D!&í9_dT>w6͹ {Y=::sӺ}4tN3iۓ66m-}EwҹIC1/bsε9G|;o&!\v}BDc2i|=z=>S{Q96UmO8@:h]1tl&ӜMtÜN浩̹W2jfE;td[Kj6%d2O&(؝4N6NeW5IƠsenr [A+2tԎ5E%Mx֌jj2 imQ i,6R6Ɣ666-QƤ[JlQlj[QQ-mR[$mىqm#`s.2BmSdMS-;UrcZ(L6ڮ-mSbEm15hChحdڪSb-̅hW~8ywN-bmX6&ҳmL:}ÜwN_=ߜou}7^ҭUlf߃gC#SaٛK[BC)ƏVׇv(!٨9qrSfNJ]**ʺ{xgm9Uy ^9b5Qm[L騻vΡ.$ {ǺC@|(zuQmczhיK8[3Y.dڮ== {@ڮU^ӭPUMu795.\cc'4UᓬW|s]c:sk79C BDYK0+#|xxg>=<~S{8Syɶ4{1g cvuMw?xs !Ϲgf;p]CpxGtpz6 늺$)t b:1Gqyt:sӱSNpKWL:gŇj]{8.vJt͎p;5.2;4;7IK]u:c`ګwnaֶ/ uG.:e!ƃv\uÍrq'ˀDpI(zHxbvŴٲvժW4Njm]utlr\`6֣iMl*%̖lW:\vaې몍+EۈSSۉݑ66';OKl^&l%pw\3ϷעF-FƼׄie? ׸RrOr#~q!<%AzWJ?~(Hn|mFBA%!){^Axټ^]y2?cʁ;=W fB7!GI[_]8?b:?H\۔^Ӵb[c!z~ydw Et~d?%;oi_MovM{P_ {lđ)Kx)JY~Z@lu$%:HK~K潯H߇6M׸sדSڭʺj:rtWGН1˜+kWqvVmN48əfPiVαs k:xj;ci9uл0[%Y.v\sT.p8b;9\:e:9t\kq6IqUQΓ9Ѵv/#TQEo+rF1V-h6-"h5I6F#D&&Pj DmcF$Ek2ŐƋF5$4UEɨEFTXXTTTjWKFߠW(T 2AnQ[ѶoIsrQcIl[6g5?vWxrI; Nyq~yzK *$g'"bQk6Tj4msnQErJŽkJj5ѮZxFRhsW9d%!F6cTQ0scslrX`JM.jMQj6[놯 mVcTEcE+DQQcY5*9xEk/s*M6-[-/)!p{ZTXƴ61AڽKWb_@x$8^C;W(*4Zf]Q.x ;pm<2wgABBL\ش*&bhʹE\[gubՋi+sW+ŷ*mm;x쁗GESQsn[Q smV5lj5b\\UkT[sVwXۘۆwQ!EmѱnZDwZF\܈Tj$lcE˕;ch F@ur +ą\I7U.n͋nFbƨ؋k(Ӹ\ܱlV+Q[1IQUnTPj6ƍhܹQPmչrۖK6W+FZs˚-Gwjͮ[r.\1gu\+c\lr*cZQVErTFnlZ&ḍcW( b6hDTQW6fmKLPeI(E-&RQM(M&Swk &bnW,mm]e&ATQh,lmk&Q\Ibkr~m{]5t`cjsڗ2^*yؖ~ҐPx/FmMoNnsg +vh7M,Vj^6 krh]o4&rQl\sIr(LW /е<.7et^yؼW9ۛwAu1ܱ.W^;͹QSp-sF;.mb5R;\TO#]'*ܧ t3uLkwvu(ڒ*2c!F e鷩z&_C_V卌7۳&Q$Qz-=*j6N#6ѻߠktwV"M*S6M 8ӻ):Q\,Z0R8|xy@',L\3((dxEk􂊠*j]2 ,݃kxQ6]ܖ;4آJ*95w;] ^Zȥ _ǯtdCA4m~U5Q$B0RQ\nZK]{oS{3]]i_Zz#I $UFRgPR&y {HAQREꅑxNZ$/傗;krx#ȏu*yt(.--EoEEz(řco6>&6_+O&xjm^(ѫ˔X2Zwt;B17:L;msZa8u"* 9 yڷӭ݁=.okmxRoqvX]NV޴qʨ-ղkj-eĦ }fnmMkf&ɧ\:wpӷMTaMB]u3h Qf&,^:^_M;Zl N=>]׎|\^WڦjujN>]Go{r8j.U\h!]ٚ>'9Odq)<N xe㧻#v:ڧvVn lT{^įFe я_x1NqӊڼuF_ʔP[m^>-5|؜\\tkW/S[Ѽf4-m.zwͨg]NGfWnu>lfHơ(7k/DVǗ>N^M'+Ceٷ!6 ۡ]W{_yܣX>mqm_o hrj_N}<Ƿq =zCuʹ+#Ŧ+4Eyhٱݐi9һ5>}ej{Sede*F5x^7vNs~\jv̷GaRkEZjmĻQ+nW?om@eFŮ_+m0xd> Nv4{}yytt vmwI$?"><)d屷­siI+`s.yvڇǏ6Nx'Cӕَ8eaiy+ӄ^Z"cFhEܫqdgS |8>M;4cF+,i-c}+O0tIʽo 4b`#mKS=|SWzpׯHk6f6(j[ɖ6fWêһG/ [Uca_i$PwynY K"1ܨ6KLX y5 U cPQTܗo).S}=?MxSޝȧӠF`IM4^L^ g :ُF'G^OE-|jK*/qy֟no}{=zx^^ *^> ׳㮎1|<6 Lʄne{ D ó"d 96Ťix^(!s&O1($l",&V5k۠?z"*|c?*D$U^m6[mxj>,|Y:⧧#hj^r6M'Xڼ[veGjΎqNJϝkԯ֫"H߮M1`}:j_.+{2}9N|kՏ[BacV6fj}ݓͼN oEwZU))K/W ܦAb r$(y%"[ѫ5 zWguHw^kq3#n@Vӳ`zra;Q{'ݡ&89Z }d$A`!#wӸM 4zD|~Rp])_ J\CMP@HQ&(@23/3! 6 X GHh`bLo=J Yf|B#x/YĘ#$c^uQF#ѥ~q OS #o&Q*&I3H"g^ys**'myy2sT4*T*t$yW'OLr]m$YRÒ[b@Q.EUWméb"W1>.нT]E+;g4I^wǎL陙lkLZI;zr2b3/Z<$^h bfS4oW4v(Tאi$Fx"!N>4je ǎ*ncާ5<ג\"xϏU $s7ihȣ@u6ft.I y޶A3"RKƤCЧ/* ;R*<>MGm=znd!U*TzD=SQEA^EeMUS<"^.uM[E5% d9d<"VEaT= ^_"U T(8ey{X`C`'h54j:ф$$60 1HymE92 #<22Ҍ?ݼ")E2:vd}<ݢEO<:!'@ydEQEWD)$3!W$eEyGℊzw>ݟNsr{b$o3Phc]"ӹJj9a+c\j*[+/H:g>"|Io*(:fyH4 z o+ i zo^j%&O.ziD$D(EM#GX͜<ϔ̡xWjG˂Jq#X.i+S9M(fu]T#AQ ']^^$f6untLl7_/LayEm`stxHfZy~6|qv|eI%OF{(6KkB##gkOoo)>d=,OA$6=UZf( A Uw23IkpD֕O8?1|4Th#^7bdأ~% VmkQgm#hBM\Pך~N~P@aS:yxxq;-i{ D`̀y<{dzjc+H4wuY LF7S2A$gkK,9 U SxrF.3MsNZ'[³#4 AZpjEm4A \aC%H|~;Ou~sys'o|P+>P>-ߠJ̄-13>';o{ƴK_<1zR~m*`;64q-5f]ybiCzs4kkE6Wj~V˫A1离cn.#c@Gko׬ۛ{믯IkԽį-6bjy1^0q^mnEhs`}V_W`{`"pS3"&|98i7M*8g;»Z=(޳70MkS Ͽ?/[YEC8IL`ٙ;6q}iV2Dj(glY]w}}~M"(B|J!X6jä&ɡ H3*MxiiqBWjFD v}jC}]kzƷ͋Vs$\ªzYMhB7E0f ڳ0mdE6b5v 1)Ldđ;Ї@PєU0w'Ʊb.xkT54wx(nU7W^z*:O4a/f0O et f@&5b9!2'd.vfn ziBs4bNNM4H<ځv&^e*5 #B%!c3XAa:_gq{]u;(ҌGT :Ui߱sʳK nwhK⒫хiݘ_{ZP["?Z.)UM@gݜ^YⰂ+@՞#WSsw/3U {+ϭw968C6]ܾ.StKv\DXR4V0ỉH"l$25"8w!E+աيsT'JڢL99Mг~ #S%i_.7ʅa^ŗ^%)!3:L> V 0Ej"i1E PC;)AdHʨXag0QMEIgh jxqzWؗp04Ne{k٪ڌ_`"v0@qg/`g¥zh]Tnt/8<ܡ" GLuȼֽsz+$Đ7. Yǣ/L=rU*:Ȗ7+ DU%kSNrH=蜍C '*d{6ęϢq'ςxOY ޞ-H$BH2(fE+jDA"+̊iZjHB*v.4Yf<0{ܼ%DKL/9U(a78=Q0d($@tdh_'dkSjyٶK#uCgdy䊑'7[#':)4(KZAY$ cRz `X27C47-Yv|pˆ/΍BH5g/Z0@ghQƆH4e n2 Oۅ@ǩlI^~3Z`j/1lyס }m 'Hhf6A^Ÿ@)/ ~q7?zIj/]w/! *2\C$^̘՝nR'Z+DV0WX/|Jx6IZ5{_G(hml׈ѭסfM,Zlv88C"QőIP`ܙSxNǷ{3b X+/I G&R<=aqd@_k<TAbwXw&q‹;>#*XI^V *xiE|^!dNY\X.!ΙηChQk8Y/ҽciܐU0%$ 'Nt<4%Ke{"U B2R&@)˸7vB>=p\)cubNm4y>gUOhg r)4↌OdB1ɋ[S>  O4FV~{+/aheGkumnA/rLg[ex (RR ` 2+"y7CGѮ/}V>|_׼7g G`W*ݙ/h3T\&o50 2LMj&pt xyDCg&q 2>D*/Z#Q 1ȳھ\*f/i.a@7+-JvDIvY 3YgE>j$a," YeȕǞ{$AL,q `I$ A\FN"M`RDjGk"i޸0&#TReC0Hhle{ ɐ#'D9FDG%h uMp32s- x"="^.+=12$ ȤIjc yA'ʴǙ'ܙ%n {G{IC2BsC@*$lP \T{#L@ cz3ۻN_f.XyA>ZjX\NK|)3RNPdH2 (I RhӟiuTIC|G?F7ھ6il"C<{)U潆pEK"Ibb >uԸk& d|3T޳/@}lC^O#=**WqtTBJT_>_ocWυ$C;Oٴ]݉p+jenۗm -1_lEEϑ6Mh6X*jmodžxq­ MwmJ؏r/:SbIG8C+ث7 r=M\8Dox{1}}+vlimE/w*4kD[cmSޯ1X xݵU:ϩ=]y5x?bbyuQFt;rm%Ǥ<;uSkGn N5'N:5l۩q:.==Uue6NL|O{=xay=w|<.}^ǔwxqϖ<DŽu'= 6V[Jޔ~`ނ.}'wx `lS OfUߎt#Ѵfe8Զ Ś$mUQi1i6-lImd[E-hڱblZ5hŴkhѣlQ[X֢-REk4ZƓ&XFQEmQXTZ1FV 55EEIQXj5Ѩƍ"[Lѩ*clmXѶZ-FT66XbMƣ+QRm6XMF@hFѨŴVڈjm2G25mUFͶ(ڮEb屫msj1PQAQb(F)4`5smrAEf%4kuPF"M̭ED" Y2h"3 a6 1bQ-Hl nXۛ FsRTS35F5w[EŋG9Ur5Ennj"\6VWwXƱr[sk5ww* FW-vTQ#\ۻ4jmKܹ[QQrZ4gtmAEF7*FQ+湪+űcrqݢ#cTX9F6l[6.[69x'^8k*X4clFTQsW"-wv*-rضnP1NsrXQhۛV r5ƹX-µnQE.mDIwUZlk5I9mʹmcsW+tU.Vw[bW(mL*ѱrrEnG1ͫZ6\ۦ ܧteEEEF5V FQEjXXkF4jXj4jTwulmV6,lEF4IV4QEhbFkpMEh$besksQs\LY5FMb%jwQhűd,FIJ$ۑhr(+ahPŹb0nUr,kFة1Qn6DUt劊ƴk%UݻDbɪ]\W9bƍTXY.렪5TcFEbMbьlb j,=F**F4%`fM#HEIEѣh QTiMbFƬ` B6ksE$-bElj޹!IK`[QUh`HChUF@I_Ԡd[SU?;ѹ)$"I$](OIQIsC UHŒBMȧ]UL@B(*ȑ+Q0U3D"\ԢP=$(*7D(,čQ$$J%*P#tr ,E/$(*]DT=Pq+tvEJQX".*Q)E+zVQi R 殕Z!H*zF9$BUUY)YR" v;&nEByEaazHnZ"FVyR*j$yFIy%h!V(RE&^ziK^ifz)Q&.a(WND%irf!!fE(nf`ZQHTbQDzdeJ:TxR蒞E"YF*) IRk#nhie^BY祄i"%EYFRBb!KhFI&)R(KU^d!S((@^$jDddIhXjQ fZQ*A %人(xGGiYaZI"jJUeix TIjAKZa襑%*hXHy醦V$$hVVG湜.`]u,)Ih*xnQ"&bDheR*$bQV"Hj%YzV"!n$k^GbwC$rv"]I-,JPԋ4D*+LOK1r%4TK$"̋IqB)\,4D,J53U4CL$ TD7THT4rP+sQLTR02]$p<Ҭ̐qK5tO(,KEH$K]PR R̢TL$B/,5TrD( DE%E, U @5 "R++AR=-,SSPCsBCHWL2Ԍ"܊/U T0W#"5uOW$KD+4K OWE+Aq *Jĥ/B 4 C@MIE$ʈܬM/2ʔCEqO52,B5D R TBH#2$"%u]+)$R04DAr 5%H2 L@# KԵ7R)"TKJT$A5TL̥RPL3]R+@!D3,(3PP1LuETEpܩ*ԥM3sLW"Is3 L+)+J$E+@U2W42J /I\ҭL0#%0BrW1U ((M+r3fO.g&!W{5$Sg+sz[fj5}:?6W/7F|j.ƅG$|* =޸GUƯ/@N^8\SD/~ه+ɖfߍ2IW5rfYl\؆e/Nѹt_:fJ* dEߏܒEv';u6Q\T60^DBB$T)2ut<)@_V[渚ߖb( ̇$| RD<9A\)7'#Hȝ7nȁdO;S`|/B+mĊ/uҿD$PoE}t&d讼qx+GgWG^9_OIqڔ1S?ygm:zj]c̝s]唤~P)o>Z$=7=w^ :m-[玭i{:nWmk2?'OGl]"/҇ݽw}z^15toz=dj8B[Um]^t˚cBE{BqT/~rHjd/gu4.u߫^dnƊ}Wf} TCmnA$0YytckDJW`$:dۙy #zݧׯ=zt[fЯwwߝDIr==[^?v7W& ookovz|nwΫ{/;U|sajيaWZڒ1ȶETjwr6bѶQZnkxsUx$:əYhdC әZkk kk;˵.iEDD/fPѻ/DIDT20 Ҙsֻimnsfz՛f+ƶ7O;vQ<6s-nK%[cYah@ᩙ8ٲ3V:.m2u]jg.;2Sy,-nMc]UDݙ62Iva5\Fvm -¨Uj0EiSEcN.vyr-,afӜmvMlN֞l b{Is.E5-ۅmd;-XmDXV&W0aؕ5Ium5ey,1JY6\D1֝libviٙJ1e9fݺ˲Hm$i4Q[-% T:bIc-9Kv2h2U&e]7ؕ[ۉVne{pFMcamûyzcpb2 s\%hW8tdK n{P[k% q6$K8mvd%S/ljc ʱ$k=3ٚbzC;Fֱ+8jY)5,$KUKc<2O"< [nE^ճj7 [FZI e6's8ւIy1Z.i39=3b4UD+i51iI"kn(R3eF{aW)VNޚy*^QdzM%M,j `̖46 Y[j{P:Tv]Uj˒p!LқShm{eC6Fږe[bJU۲"&Op+j[T'Ã(Q.eڕsJv:%viC#%'}P#tC'UMD )v9G2q%qGb"h Fr.J*_}}g;O xk-6^E{KޥHbۤk޵\ׄ2zFI_9^ּSMmo}ğv$;o9u$}G@AZW3(IN?1W$98NH\F9VCeeWQ.BS ې4;Qp&JLjW^'l{)دi}A9z'Hj> AvQrK8.zЭPDҥbé>'H_U{w]lWmm}퓬lww|wtwq(P$φإkhkQOPg7co|/QEUnW˝jSϓgҞzx|ȧ-Gd/b\ vS9JZOTª: ACʽ2 {##.C҇0V2 w£ UMcP*O O7 6ơ86Z\-W5QEDd2\$n뤑RD.FES(^TI!&nHi%K"*RYHbV&'U^BDJ{CI2NDn^xF fiJQ$zTA{(ۄanBۮ.,*TH#) HEA-utB,R#$ 2O ($()#$=IJ @.Gu% ;c]Ђt&NΌ=r1$FcBZ]^X슑2HcZM*J/u];. !+ G_oqx+_k^ND=^뇏ۂ:BpL=W:UcW穯:5x+wLEkD~WX״D\sg$e3?퍿Vt?F0}T{S$׈~H>2KueRfI&; ]-rTuR%H1F{Z5c޷(s}*7~Ꮾq~ ut orФ\Wh|a?Uw%W猿TFOQ3_n9}_ov-~׽>jO/W~~uSeNx")OIм-BҜDrSԥt@> LֵۜA.sG3E9ڌ@|e_9Nb?^U~ NZg.Th>㠗ߪ}᨟IGSGj)|DPޚOR]v ACxB=D2xJJV7*^T>o*`wOdE3DqUNИ"\IOSU;N-ۨ\!IGTy(_eSCCOm+)h;(v\jvO?ݫ!8QʯjKF_eQ˧X}4]ڤ!}$ԜC' =/bEڡ앹7 $}\HT|{E,E 0UDJ\T({tʗBsmK*., }R8I\D4sE ғQ 8.,#*> _ GցJL"\|j^;dU! rU.%:_IKCE\$ooJgIy%OZ-'Ql[]k IhK_jgg[WWKڋ?fP/oąuh^JyN{o?\J+farg~/VH3ϏNg:>W>8/%JߔШ ;!Uоn%4*Tj}i_V\U8eXW"x@~ if;RòX)vBY8#3E2a*BB?RAsLa{dIO%l:*2_(z^O=T.||4R~gBI %^zQWAN3.(%+U;:Nnw(??C7|>?y} խ6ղSHwKE]_{\ԷC3I[75J̚z-ռ욾&ɾrovi+o$3xƒZ>L(S뻷+F8K>+ƑF @DlnQRoqL딋E7[oe,l:tt] [=T:G qR}zba9Lt;8R˻30(_M>ze}PLH-|q_oW72Ȃ"~aYwss`kwjg}7>׏N۽nW7:^پW徢w~s:*擝thl:ݳysChͶuRiuThFYU`XyTKխ۵֤VS!("{ VJ̑9 OEE$%+ 7kr2)Z D_4G# B_EC ݉7<}.lv|mD%QlHDB1S&g:x|Tvqޫ=xr={2>O߱]G7BsGºO=wyxP(>Wr_%=pBSbW٦;bb lBw0p$AA/ _!962[k~6jm*/_hibuwti}+|WU2h>n| xIYK_?^uԤoy |뻓7(ewqr]S#sN̘'|nznlmkyKodH/>`zr(O^F~~?<~~9KGo=?1X-XUѪj"PL)*2ĢYb(iK4eeFlɲR FʚM$6e#M٦H D B%31L2Є$$f̅ffM4&eLP"1LI$f@# )R0dfiH(d%0ĄT2aD4%! H &Fb -RZ5I%!2&BHmF QBlf4IF6(D ( S a$h64b2QQ,TTd" B62EF661f"h0&ф 2ZlĦm ,XFmE0ʌFĦ$ڒFBc% !1KFфUQ54´mV4Q6Tj6ْk -Em(ŊJVح4EFب6*hRD)bUDp jCz ӶdsΧJjz*tyHN#Hoٸ-ӎ86:uOk3Myfl H$I$[RywFPHK[7_j۷d]DwDo__+O';5Wzu~<(繓ϭ5]y w.I~_GNWᙫiڍi1Lf)5of3hua1(uϸڼƏbQ*ɾꙙ7낽2nmfW_w@3_wK7|xde@!.]"o\˃ru64-&}σ6OtkK9$%M92fK]Ą '=|8xs.#|s} Hoy]/ѩ}ˡIN}/u4x}٫y;|"./2/ ])֝iҝqӯ^v'ff6bHƢiR{ 7|~=^/?OJ0R Ss&PăoNe7Hܽ ,Rp }OܣE<ʢ>1})xS_7kkJUM/wz~^^F|<='qLJ㻿 } Dќَ#̋1Il3fEvNƶcbNİ-3K2Xs-F-atnJuJÒdm.B5ЬY]a[Eh;hs[N4hv쉛vv6vDbVp7Q]N&^^ɦ&C2(18MFh;X1Kҥ&gZW]0mlSy{YjG#BpL9S-zWe&l'Wj 4f#@EV%"j@ [RR' ={EE_V|Anr:R+UQO_6+7QVv;)yԞo]W{iϿh{ GG}>{"{!د)~qL[wp.{0Gڻ<Ϝ 8D? ]n_p]t]ߗCC(< +^/ߜfb*HvF_V}^R;﷟kͿE\4ZFW1IsO=Db[wv-̑;]1>ܫjvK}旽#' $,$7/s|}__'/x-LWK~|W#yu/$i _Ϛnٳ¿:QhlXحbUDhFUcTZ 4%iPZ4BDLM6FL4 & RH(L3H)$HFJaJ e)$f 1JY&l)JL,D 3EPS!$i e&L e JfDLɅ"%M"BPd40"L13HH@ID &1 #1fT6"L$l$c0RlERm$I5ch",Q`Y3*HDdIdMH`0fSIhHaEI3cELF1"hecj "XQdc&ELX$lQ!m1QE4h61EM5I($єŌF5ɩhK&!3h% F DhԘ,X&Qڍ1XѣQh&"&1آ1hEcFٚ`(L,4m) hڢ4XDFi1ƈѭZ)4BlلlT]ިSOExu$9TRePb]Qߋwk񩊽oJcb>z5DъҍjKR'z_UJ<$łsnۻytז%Q]sPQEej^mim>{g՛m=kA ԩqi\Iz[k}*,dy^Wz{Na pHRH17y 7D/{7W}̆_es\c6v͍#j^y_$lE>A㞯q'{̞it:Nļ{¨ke5ː }~{n^VTվ"P= A@ (P((({t$I SG2zhF#&a24`!1!iODFL&`4ɦ&A jy!4$LDщ@CM@h42444M d4@&hhѦM B4?T<=# @44i T2h d@ @4 R"zh=MQG#@C@ iѣ@444Ѧjh F4ɲib2biDwf2F13vUz; 2D\V}a,dQM()3IF̊a`/E,D]{.\VypA Wŧԧ-T0 F46 Zڶ$;*1'1#W$FGwYy!S)⁅7Rb*\be=PX [VBY7{wqu=.p,Nz=\쥁ȹS@k[AL.<5jFy@V48] eiZ .2s-s2!Sc;t2n(Pkf,[iph#K[7+[8fԓ7G" ReQU2lD *A/5M @m2ῗ[y RlGU fQ lFZbsR`:brI s y<6C,^A|l{8;;VO2"*&P& *y-3~i|Ʉw-r]Kq 3 Z6nLI&g,?S<[F;A08s45"97R' s&d` Z k 1jmoc)e7ތ|$8"D%[TM!kɖW5Z-܆7IN8t}KIANfmBXmr>VЄU8$B2̇e'ua5Q;zAz&JtP8G dkSJøAs;n\Ȍ]dBmԣ?jg¢ǐ5tK'"F R$5!I$ tƭ~9WZ[-Ip0=OXMˡVM4V1Y,܆.RK"Ilpaqd"Q!# 8vu͓Hy $2$<M /MƠ]VSV5.8ƕ m5'9M@j!:w:Úx]WФG$fl ok_y>+y ."ʎ34u/#^$^d $K(80 E),/ȟ4xcml[-gsAȱא\Q4贒iK^)Hd|'30;av1y(t"I{ )<ս'C9P2kl_ckLu oh!u;c_[Ɏ@2'RzZ5ӎ XvF~J "3@Or4S4^SL?*w2YNf#574Ne(BR8`Ghʙfwq3vJLff3+0Fd̕fRdxVSq!X9lOx=ң%/S{uKE#6Atg9 fKDZi.eF5!7YIg֮~3,1A\KͤUSr1Ui{OnAu(ruƇL3VXLJcUTh(R P-UVIDDkƷ ȤGӾ?TrChpJq6=aڤڡk-M{>GHtO6@=?6rnܥQE!ڱiQJDhQJPRVY4fYaQjVN-.O7nz1"eQƍ9+<8%6N/w&YɁ&ܮur_4:[KNU"4H o6 dplyr/data/band_instruments.rda0000644000176200001440000000030213451046652016365 0ustar liggesusersBZh91AY&SY>s2HP@ޠ@ S="=P QM3SAdA)sdb-T}P߻"I~pnTQ 'K đ^l&enXe`feUG/|*HCGN!koQlF^Mp+=x/H =dplyr/man/0000755000176200001440000000000013614573562012173 5ustar liggesusersdplyr/man/tbl_vars.Rd0000644000176200001440000000116613574646634014310 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tbl.r \name{tbl_vars} \alias{tbl_vars} \alias{tbl_nongroup_vars} \title{List variables provided by a tbl.} \usage{ tbl_vars(x) tbl_nongroup_vars(x) } \arguments{ \item{x}{A tbl object} } \description{ \code{tbl_vars()} returns all variables while \code{tbl_nongroup_vars()} returns only non-grouping variables. The \code{groups} attribute of the object returned by \code{tbl_vars()} is a character vector of the grouping columns. } \seealso{ \code{\link[=group_vars]{group_vars()}} for a function that returns grouping variables. } \keyword{internal} dplyr/man/summarise_each.Rd0000644000176200001440000000266113614573562015454 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/colwise-mutate.R \name{summarise_each} \alias{summarise_each} \alias{summarise_each_} \alias{mutate_each} \alias{mutate_each_} \alias{summarize_each} \alias{summarize_each_} \title{Summarise and mutate multiple columns.} \usage{ summarise_each(tbl, funs, ...) summarise_each_(tbl, funs, vars) mutate_each(tbl, funs, ...) mutate_each_(tbl, funs, vars) summarize_each(tbl, funs, ...) summarize_each_(tbl, funs, vars) } \description{ \code{mutate_each()} and \code{summarise_each()} are deprecated in favour of a more featureful family of functions: \code{\link[=mutate_all]{mutate_all()}}, \code{\link[=mutate_at]{mutate_at()}}, \code{\link[=mutate_if]{mutate_if()}}, \code{\link[=summarise_all]{summarise_all()}}, \code{\link[=summarise_at]{summarise_at()}} and \code{\link[=summarise_if]{summarise_if()}}. The \code{_each()} functions have two replacements depending on what variables you want to apply \code{funs} to. To apply a function to all variables, use \code{\link[=mutate_all]{mutate_all()}} or \code{\link[=summarise_all]{summarise_all()}}. To apply a function to a selection of variables, use \code{\link[=mutate_at]{mutate_at()}} or \code{\link[=summarise_at]{summarise_at()}}. See the relevant section of \code{vignette("compatibility")} for more information. } \details{ \Sexpr[results=rd, stage=render]{dplyr:::lifecycle("deprecated")} } \keyword{internal} dplyr/man/as.table.tbl_cube.Rd0000644000176200001440000000146413614573562015736 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tbl-cube.r \name{as.table.tbl_cube} \alias{as.table.tbl_cube} \alias{as.data.frame.tbl_cube} \alias{as_tibble.tbl_cube} \title{Coerce a \code{tbl_cube} to other data structures} \usage{ \method{as.table}{tbl_cube}(x, ..., measure = 1L) \method{as.data.frame}{tbl_cube}(x, ...) \method{as_tibble}{tbl_cube}(x, ...) } \arguments{ \item{x}{a \code{tbl_cube}} \item{...}{Passed on to individual methods; otherwise ignored.} \item{measure}{A measure name or index, default: the first measure} } \description{ Supports conversion to tables, data frames, tibbles. For a cube, the data frame returned by \code{\link[tibble:as_tibble]{tibble::as_tibble()}} resulting data frame contains the dimensions as character values (and not as factors). } dplyr/man/do.Rd0000644000176200001440000000732013614573562013066 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/do.r \name{do} \alias{do} \title{Do anything} \usage{ do(.data, ...) } \arguments{ \item{.data}{a tbl} \item{...}{Expressions to apply to each group. If named, results will be stored in a new column. If unnamed, should return a data frame. You can use \code{.} to refer to the current group. You can not mix named and unnamed arguments.} } \value{ \code{do()} always returns a data frame. The first columns in the data frame will be the labels, the others will be computed from \code{...}. Named arguments become list-columns, with one element for each group; unnamed elements must be data frames and labels will be duplicated accordingly. Groups are preserved for a single unnamed input. This is different to \code{\link[=summarise]{summarise()}} because \code{do()} generally does not reduce the complexity of the data, it just expresses it in a special way. For multiple named inputs, the output is grouped by row with \code{\link[=rowwise]{rowwise()}}. This allows other verbs to work in an intuitive way. } \description{ This is a general purpose complement to the specialised manipulation functions \code{\link[=filter]{filter()}}, \code{\link[=select]{select()}}, \code{\link[=mutate]{mutate()}}, \code{\link[=summarise]{summarise()}} and \code{\link[=arrange]{arrange()}}. You can use \code{do()} to perform arbitrary computation, returning either a data frame or arbitrary objects which will be stored in a list. This is particularly useful when working with models: you can fit models per group with \code{do()} and then flexibly extract components with either another \code{do()} or \code{summarise()}. For an empty data frame, the expressions will be evaluated once, even in the presence of a grouping. This makes sure that the format of the resulting data frame is the same for both empty and non-empty input. } \details{ \Sexpr[results=rd, stage=render]{dplyr:::lifecycle("questioning")} } \section{Alternative}{ \code{do()} is marked as questioning as of dplyr 0.8.0, and may be advantageously replaced by \code{\link[=group_map]{group_map()}}. } \section{Connection to plyr}{ If you're familiar with plyr, \code{do()} with named arguments is basically equivalent to \code{\link[plyr:dlply]{plyr::dlply()}}, and \code{do()} with a single unnamed argument is basically equivalent to \code{\link[plyr:ldply]{plyr::ldply()}}. However, instead of storing labels in a separate attribute, the result is always a data frame. This means that \code{summarise()} applied to the result of \code{do()} can act like \code{ldply()}. } \examples{ by_cyl <- group_by(mtcars, cyl) do(by_cyl, head(., 2)) models <- by_cyl \%>\% do(mod = lm(mpg ~ disp, data = .)) models summarise(models, rsq = summary(mod)$r.squared) models \%>\% do(data.frame(coef = coef(.$mod))) models \%>\% do(data.frame( var = names(coef(.$mod)), coef(summary(.$mod))) ) models <- by_cyl \%>\% do( mod_linear = lm(mpg ~ disp, data = .), mod_quad = lm(mpg ~ poly(disp, 2), data = .) ) models compare <- models \%>\% do(aov = anova(.$mod_linear, .$mod_quad)) # compare \%>\% summarise(p.value = aov$`Pr(>F)`) if (require("nycflights13")) { # You can use it to do any arbitrary computation, like fitting a linear # model. Let's explore how carrier departure delays vary over the time carriers <- group_by(flights, carrier) group_size(carriers) mods <- do(carriers, mod = lm(arr_delay ~ dep_time, data = .)) mods \%>\% do(as.data.frame(coef(.$mod))) mods \%>\% summarise(rsq = summary(mod)$r.squared) \dontrun{ # This longer example shows the progress bar in action by_dest <- flights \%>\% group_by(dest) \%>\% filter(n() > 100) library(mgcv) by_dest \%>\% do(smooth = gam(arr_delay ~ s(dep_time) + month, data = .)) } } } dplyr/man/bind.Rd0000644000176200001440000000604713614573562013405 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bind.r, R/rbind.R \name{bind} \alias{bind} \alias{rbind_all} \alias{rbind_list} \alias{bind_rows} \alias{bind_cols} \title{Efficiently bind multiple data frames by row and column} \usage{ bind_rows(..., .id = NULL) bind_cols(...) } \arguments{ \item{...}{Data frames to combine. Each argument can either be a data frame, a list that could be a data frame, or a list of data frames. When row-binding, columns are matched by name, and any missing columns will be filled with NA. When column-binding, rows are matched by position, so all data frames must have the same number of rows. To match by value, not position, see \link{join}.} \item{.id}{Data frame identifier. When \code{.id} is supplied, a new column of identifiers is created to link each row to its original data frame. The labels are taken from the named arguments to \code{bind_rows()}. When a list of data frames is supplied, the labels are taken from the names of the list. If no names are found a numeric sequence is used instead.} } \value{ \code{bind_rows()} and \code{bind_cols()} return the same type as the first input, either a data frame, \code{tbl_df}, or \code{grouped_df}. } \description{ This is an efficient implementation of the common pattern of \code{do.call(rbind, dfs)} or \code{do.call(cbind, dfs)} for binding many data frames into one. } \details{ The output of \code{bind_rows()} will contain a column if that column appears in any of the inputs. } \section{Deprecated functions}{ \code{rbind_list()} and \code{rbind_all()} have been deprecated. Instead use \code{bind_rows()}. } \examples{ one <- mtcars[1:4, ] two <- mtcars[11:14, ] # You can supply data frames as arguments: bind_rows(one, two) # The contents of lists are spliced automatically: bind_rows(list(one, two)) bind_rows(split(mtcars, mtcars$cyl)) bind_rows(list(one, two), list(two, one)) # In addition to data frames, you can supply vectors. In the rows # direction, the vectors represent rows and should have inner # names: bind_rows( c(a = 1, b = 2), c(a = 3, b = 4) ) # You can mix vectors and data frames: bind_rows( c(a = 1, b = 2), tibble(a = 3:4, b = 5:6), c(a = 7, b = 8) ) # Note that for historical reasons, lists containing vectors are # always treated as data frames. Thus their vectors are treated as # columns rather than rows, and their inner names are ignored: ll <- list( a = c(A = 1, B = 2), b = c(A = 3, B = 4) ) bind_rows(ll) # You can circumvent that behaviour with explicit splicing: bind_rows(!!!ll) # When you supply a column name with the `.id` argument, a new # column is created to link each row to its original data frame bind_rows(list(one, two), .id = "id") bind_rows(list(a = one, b = two), .id = "id") bind_rows("group 1" = one, "group 2" = two, .id = "groups") # Columns don't need to match when row-binding bind_rows(data.frame(x = 1:3), data.frame(y = 1:4)) \dontrun{ # Rows do need to match when column-binding bind_cols(data.frame(x = 1), data.frame(y = 1:2)) } bind_cols(one, two) bind_cols(list(one, two)) } dplyr/man/top_n.Rd0000644000176200001440000000326513614573562013607 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/top-n.R \name{top_n} \alias{top_n} \alias{top_frac} \title{Select top (or bottom) n rows (by value)} \usage{ top_n(x, n, wt) top_frac(x, n, wt) } \arguments{ \item{x}{a \code{\link[=tbl]{tbl()}} to filter} \item{n}{number of rows to return for \code{top_n()}, fraction of rows to return for \code{top_frac()}. If \code{x} is grouped, this is the number (or fraction) of rows per group. Will include more rows if there are ties. If \code{n} is positive, selects the top rows. If negative, selects the bottom rows.} \item{wt}{(Optional). The variable to use for ordering. If not specified, defaults to the last variable in the tbl.} } \description{ This is a convenient wrapper that uses \code{\link[=filter]{filter()}} and \code{\link[=min_rank]{min_rank()}} to select the top or bottom entries in each group, ordered by \code{wt}. } \details{ Both \code{n} and \code{wt} are automatically \link[rlang:enquo]{quoted} and later \link[rlang:eval_tidy]{evaluated} in the context of the data frame. It supports \link[rlang:quasiquotation]{unquoting}. } \examples{ df <- data.frame(x = c(10, 4, 1, 6, 3, 1, 1)) df \%>\% top_n(2) # half the rows df \%>\% top_n(n() * .5) df \%>\% top_frac(.5) # Negative values select bottom from group. Note that we get more # than 2 values here because there's a tie: top_n() either takes # all rows with a value, or none. df \%>\% top_n(-2) if (require("Lahman")) { # Find 10 players with most games tbl_df(Batting) \%>\% group_by(playerID) \%>\% tally(G) \%>\% top_n(10) # Find year with most games for each player \dontrun{ tbl_df(Batting) \%>\% group_by(playerID) \%>\% top_n(1, G) } } } dplyr/man/arrange_all.Rd0000644000176200001440000000372113614573562014734 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/colwise-arrange.R \name{arrange_all} \alias{arrange_all} \alias{arrange_at} \alias{arrange_if} \title{Arrange rows by a selection of variables} \usage{ arrange_all(.tbl, .funs = list(), ..., .by_group = FALSE) arrange_at(.tbl, .vars, .funs = list(), ..., .by_group = FALSE) arrange_if(.tbl, .predicate, .funs = list(), ..., .by_group = FALSE) } \arguments{ \item{.tbl}{A \code{tbl} object.} \item{.funs}{A function \code{fun}, a quosure style lambda \code{~ fun(.)} or a list of either form.} \item{...}{Additional arguments for the function calls in \code{.funs}. These are evaluated only once, with \link[rlang:tidy-dots]{tidy dots} support.} \item{.by_group}{If \code{TRUE}, will sort first by grouping variable. Applies to grouped data frames only.} \item{.vars}{A list of columns generated by \code{\link[=vars]{vars()}}, a character vector of column names, a numeric vector of column positions, or \code{NULL}.} \item{.predicate}{A predicate function to be applied to the columns or a logical vector. The variables for which \code{.predicate} is or returns \code{TRUE} are selected. This argument is passed to \code{\link[rlang:as_function]{rlang::as_function()}} and thus supports quosure-style lambda functions and strings representing function names.} } \description{ These \link{scoped} variants of \code{\link[=arrange]{arrange()}} sort a data frame by a selection of variables. Like \code{\link[=arrange]{arrange()}}, you can modify the variables before ordering with the \code{.funs} argument. } \section{Grouping variables}{ The grouping variables that are part of the selection participate in the sorting of the data frame. } \examples{ df <- as_tibble(mtcars) df arrange_all(df) # You can supply a function that will be applied before taking the # ordering of the variables. The variables of the sorted tibble # keep their original values. arrange_all(df, desc) arrange_all(df, list(~desc(.))) } dplyr/man/id.Rd0000644000176200001440000000117013614573562013055 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/id.r \name{id} \alias{id} \title{Compute a unique numeric id for each unique row in a data frame.} \usage{ id(.variables, drop = FALSE) } \arguments{ \item{.variables}{list of variables} \item{drop}{drop unused factor levels?} } \value{ a numeric vector with attribute n, giving total number of possibilities } \description{ Properties: \itemize{ \item \code{order(id)} is equivalent to \code{do.call(order, df)} \item rows containing the same data have the same value \item if \code{drop = FALSE} then room for all possibilities } } \keyword{internal} dplyr/man/group_trim.Rd0000644000176200001440000000221413614573562014650 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/group_trim.R \name{group_trim} \alias{group_trim} \title{Trim grouping structure} \usage{ group_trim(.tbl, .drop = group_by_drop_default(.tbl)) } \arguments{ \item{.tbl}{A \link[=grouped_df]{grouped data frame}} \item{.drop}{See \code{\link[=group_by]{group_by()}}} } \value{ A \link[=grouped_df]{grouped data frame} } \description{ Drop unused levels of all factors that are used as grouping variables, then recalculates the grouping structure. \code{group_trim()} is particularly useful after a \code{\link[=filter]{filter()}} that is intended to select a subset of groups. } \details{ \Sexpr[results=rd, stage=render]{dplyr:::lifecycle("experimental")} } \examples{ iris \%>\% group_by(Species) \%>\% filter(Species == "setosa", .preserve = TRUE) \%>\% group_trim() } \seealso{ Other grouping functions: \code{\link{group_by_all}}, \code{\link{group_by}}, \code{\link{group_indices}}, \code{\link{group_keys}}, \code{\link{group_map}}, \code{\link{group_nest}}, \code{\link{group_rows}}, \code{\link{group_size}}, \code{\link{groups}} } \concept{grouping functions} dplyr/man/summarise.Rd0000644000176200001440000001000513614573562014463 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/manip.r \name{summarise} \alias{summarise} \alias{summarize} \title{Reduce multiple values down to a single value} \usage{ summarise(.data, ...) summarize(.data, ...) } \arguments{ \item{.data}{A tbl. All main verbs are S3 generics and provide methods for \code{\link[=tbl_df]{tbl_df()}}, \code{\link[dtplyr:tbl_dt]{dtplyr::tbl_dt()}} and \code{\link[dbplyr:tbl_dbi]{dbplyr::tbl_dbi()}}.} \item{...}{Name-value pairs of summary functions. The name will be the name of the variable in the result. The value should be an expression that returns a single value like \code{min(x)}, \code{n()}, or \code{sum(is.na(y))}. The arguments in \code{...} are automatically \link[rlang:quo]{quoted} and \link[rlang:eval_tidy]{evaluated} in the context of the data frame. They support \link[rlang:quasiquotation]{unquoting} and splicing. See \code{vignette("programming")} for an introduction to these concepts.} } \value{ An object of the same class as \code{.data}. One grouping level will be dropped. } \description{ Create one or more scalar variables summarizing the variables of an existing tbl. Tbls with groups created by \code{\link[=group_by]{group_by()}} will result in one row in the output for each group. Tbls with no groups will result in one row. } \details{ \code{summarise()} and \code{summarize()} are synonyms. } \section{Useful functions}{ \itemize{ \item Center: \code{\link[=mean]{mean()}}, \code{\link[=median]{median()}} \item Spread: \code{\link[=sd]{sd()}}, \code{\link[=IQR]{IQR()}}, \code{\link[=mad]{mad()}} \item Range: \code{\link[=min]{min()}}, \code{\link[=max]{max()}}, \code{\link[=quantile]{quantile()}} \item Position: \code{\link[=first]{first()}}, \code{\link[=last]{last()}}, \code{\link[=nth]{nth()}}, \item Count: \code{\link[=n]{n()}}, \code{\link[=n_distinct]{n_distinct()}} \item Logical: \code{\link[=any]{any()}}, \code{\link[=all]{all()}} } } \section{Backend variations}{ The data frame backend supports creating a variable and using it in the same summary. This means that previously created summary variables can be further transformed or combined within the summary, as in \code{\link[=mutate]{mutate()}}. However, it also means that summary variables with the same names as previous variables overwrite them, making those variables unavailable to later summary variables. This behaviour may not be supported in other backends. To avoid unexpected results, consider using new names for your summary variables, especially when creating multiple summaries. } \section{Tidy data}{ When applied to a data frame, row names are silently dropped. To preserve, convert to an explicit variable with \code{\link[tibble:rownames_to_column]{tibble::rownames_to_column()}}. } \examples{ # A summary applied to ungrouped tbl returns a single row mtcars \%>\% summarise(mean = mean(disp), n = n()) # Usually, you'll want to group first mtcars \%>\% group_by(cyl) \%>\% summarise(mean = mean(disp), n = n()) # Each summary call removes one grouping level (since that group # is now just a single row) mtcars \%>\% group_by(cyl, vs) \%>\% summarise(cyl_n = n()) \%>\% group_vars() # Reusing variable names when summarising may lead to unexpected results mtcars \%>\% group_by(cyl) \%>\% summarise(disp = mean(disp), sd = sd(disp), double_disp = disp * 2) # Refer to column names stored as strings with the `.data` pronoun: var <- "mass" summarise(starwars, avg = mean(.data[[var]], na.rm = TRUE)) # For more complex cases, knowledge of tidy evaluation and the # unquote operator `!!` is required. See https://tidyeval.tidyverse.org/ # # One useful and simple tidy eval technique is to use `!!` to # bypass the data frame and its columns. Here is how to divide the # column `mass` by an object of the same name: mass <- 100 summarise(starwars, avg = mean(mass / !!mass, na.rm = TRUE)) } \seealso{ Other single table verbs: \code{\link{arrange}}, \code{\link{filter}}, \code{\link{mutate}}, \code{\link{select}}, \code{\link{slice}} } \concept{single table verbs} dplyr/man/n.Rd0000644000176200001440000000106013614573562012714 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/manip.r \name{n} \alias{n} \title{The number of observations in the current group.} \usage{ n() } \description{ This function is implemented specifically for each data source and can only be used from within \code{\link[=summarise]{summarise()}}, \code{\link[=mutate]{mutate()}} and \code{\link[=filter]{filter()}}. } \examples{ if (require("nycflights13")) { carriers <- group_by(flights, carrier) summarise(carriers, n()) mutate(carriers, n = n()) filter(carriers, n() < 100) } } dplyr/man/group_nest.Rd0000644000176200001440000000422713614573562014654 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/group_nest.R \name{group_nest} \alias{group_nest} \title{Nest a tibble using a grouping specification} \usage{ group_nest(.tbl, ..., .key = "data", keep = FALSE) } \arguments{ \item{.tbl}{A tbl} \item{...}{Grouping specification, forwarded to \code{\link[=group_by]{group_by()}}} \item{.key}{the name of the list column} \item{keep}{Should the grouping columns be kept in the list column.} } \value{ A tbl with one row per unique combination of the grouping variables. The first columns are the grouping variables, followed by a list column of tibbles with matching rows of the remaining columns. } \description{ Nest a tibble using a grouping specification } \details{ \Sexpr[results=rd, stage=render]{dplyr:::lifecycle("experimental")} } \section{Grouped data frames}{ The primary use case for \code{\link[=group_nest]{group_nest()}} is with already grouped data frames, typically a result of \code{\link[=group_by]{group_by()}}. In this case \code{\link[=group_nest]{group_nest()}} only uses the first argument, the grouped tibble, and warns when \code{...} is used. } \section{Ungrouped data frames}{ When used on ungrouped data frames, \code{\link[=group_nest]{group_nest()}} forwards the \code{...} to \code{\link[=group_by]{group_by()}} before nesting, therefore the \code{...} are subject to the data mask. } \examples{ #----- use case 1: a grouped data frame iris \%>\% group_by(Species) \%>\% group_nest() # this can be useful if the grouped data has been altered before nesting iris \%>\% group_by(Species) \%>\% filter(Sepal.Length > mean(Sepal.Length)) \%>\% group_nest() #----- use case 2: using group_nest() on a ungrouped data frame with # a grouping specification that uses the data mask starwars \%>\% group_nest(species, homeworld) } \seealso{ Other grouping functions: \code{\link{group_by_all}}, \code{\link{group_by}}, \code{\link{group_indices}}, \code{\link{group_keys}}, \code{\link{group_map}}, \code{\link{group_rows}}, \code{\link{group_size}}, \code{\link{group_trim}}, \code{\link{groups}} } \concept{grouping functions} \keyword{internal} dplyr/man/starwars.Rd0000644000176200001440000000157113614573562014334 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-starwars.R \docType{data} \name{starwars} \alias{starwars} \title{Starwars characters} \format{A tibble with 87 rows and 13 variables: \describe{ \item{name}{Name of the character} \item{height}{Height (cm)} \item{mass}{Weight (kg)} \item{hair_color,skin_color,eye_color}{Hair, skin, and eye colors} \item{birth_year}{Year born (BBY = Before Battle of Yavin)} \item{gender}{male, female, hermaphrodite, or none.} \item{homeworld}{Name of homeworld} \item{species}{Name of species} \item{films}{List of films the character appeared in} \item{vehicles}{List of vehicles the character has piloted} \item{starships}{List of starships the character has piloted} }} \usage{ starwars } \description{ This data comes from SWAPI, the Star Wars API, \url{http://swapi.co/} } \examples{ starwars } \keyword{datasets} dplyr/man/select.Rd0000644000176200001440000001222013614573562013736 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/manip.r \name{select} \alias{select} \alias{rename} \title{Select/rename variables by name} \usage{ select(.data, ...) rename(.data, ...) } \arguments{ \item{.data}{A tbl. All main verbs are S3 generics and provide methods for \code{\link[=tbl_df]{tbl_df()}}, \code{\link[dtplyr:tbl_dt]{dtplyr::tbl_dt()}} and \code{\link[dbplyr:tbl_dbi]{dbplyr::tbl_dbi()}}.} \item{...}{One or more unquoted expressions separated by commas. You can treat variable names like they are positions, so you can use expressions like \code{x:y} to select ranges of variables. Positive values select variables; negative values drop variables. If the first expression is negative, \code{select()} will automatically start with all variables. Use named arguments, e.g. \code{new_name = old_name}, to rename selected variables. The arguments in \code{...} are automatically \link[rlang:quo]{quoted} and \link[rlang:eval_tidy]{evaluated} in a context where column names represent column positions. They also support \link[rlang:quasiquotation]{unquoting} and splicing. See \code{vignette("programming")} for an introduction to these concepts. See \link[tidyselect:select_helpers]{select helpers} for more details and examples about tidyselect helpers such as \code{starts_with()}, \code{everything()}, ...} } \value{ An object of the same class as \code{.data}. } \description{ Choose or rename variables from a tbl. \code{select()} keeps only the variables you mention; \code{rename()} keeps all variables. } \details{ These functions work by column index, not value; thus, an expression like \code{select(data.frame(x = 1:5, y = 10), z = x+1)} does not create a variable with values \code{2:6}. (In the current implementation, the expression \code{z = x+1} wouldn't do anything useful.) To calculate using column values, see \code{\link[=mutate]{mutate()}}/\code{\link[=transmute]{transmute()}}. } \section{Useful functions}{ As well as using existing functions like \code{:} and \code{c()}, there are a number of special functions that only work inside \code{select()}: \itemize{ \item \code{\link[=starts_with]{starts_with()}}, \code{\link[=ends_with]{ends_with()}}, \code{\link[=contains]{contains()}} \item \code{\link[=matches]{matches()}} \item \code{\link[=num_range]{num_range()}} \item \code{\link[=one_of]{one_of()}} \item \code{\link[=everything]{everything()}} \item \code{\link[=group_cols]{group_cols()}} } To drop variables, use \code{-}. Note that except for \code{:}, \code{-} and \code{c()}, all complex expressions are evaluated outside the data frame context. This is to prevent accidental matching of data frame variables when you refer to variables from the calling context. } \section{Scoped selection and renaming}{ The three \link{scoped} variants of \code{select()} (\code{\link[=select_all]{select_all()}}, \code{\link[=select_if]{select_if()}} and \code{\link[=select_at]{select_at()}}) and the three variants of \code{rename()} (\code{\link[=rename_all]{rename_all()}}, \code{\link[=rename_if]{rename_if()}}, \code{\link[=rename_at]{rename_at()}}) make it easy to apply a renaming function to a selection of variables. } \section{Tidy data}{ When applied to a data frame, row names are silently dropped. To preserve, convert to an explicit variable with \code{\link[tibble:rownames_to_column]{tibble::rownames_to_column()}}. } \examples{ iris <- as_tibble(iris) # so it prints a little nicer select(iris, starts_with("Petal")) select(iris, ends_with("Width")) # Move Species variable to the front select(iris, Species, everything()) # Move Sepal.Length variable to back # first select all variables except Sepal.Length, then re select Sepal.Length select(iris, -Sepal.Length, Sepal.Length) df <- as.data.frame(matrix(runif(100), nrow = 10)) df <- tbl_df(df[c(3, 4, 7, 1, 9, 8, 5, 2, 6, 10)]) select(df, V4:V6) select(df, num_range("V", 4:6)) # Drop variables with - select(iris, -starts_with("Petal")) # Select the grouping variables: starwars \%>\% group_by(gender) \%>\% select(group_cols()) # The .data pronoun is available: select(mtcars, .data$cyl) select(mtcars, .data$mpg : .data$disp) # However it isn't available within calls since those are evaluated # outside of the data context. This would fail if run: # select(mtcars, identical(.data$cyl)) # Renaming ----------------------------------------- # * select() keeps only the variables you specify select(iris, petal_length = Petal.Length) # * rename() keeps all variables rename(iris, petal_length = Petal.Length) # * select() can rename variables in a group select(iris, obs = starts_with('S')) # Unquoting ---------------------------------------- # Like all dplyr verbs, select() supports unquoting of symbols: vars <- list( var1 = sym("cyl"), var2 = sym("am") ) select(mtcars, !!!vars) # For convenience it also supports strings and character # vectors. This is unlike other verbs where strings would be # ambiguous. vars <- c(var1 = "cyl", var2 ="am") select(mtcars, !!vars) rename(mtcars, !!vars) } \seealso{ Other single table verbs: \code{\link{arrange}}, \code{\link{filter}}, \code{\link{mutate}}, \code{\link{slice}}, \code{\link{summarise}} } \concept{single table verbs} dplyr/man/tbl_df.Rd0000644000176200001440000000051313614573562013713 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tbl-df.r \name{tbl_df} \alias{tbl_df} \title{Create a data frame tbl.} \usage{ tbl_df(data) } \arguments{ \item{data}{a data frame} } \description{ Deprecated: please use \code{\link[tibble:as_tibble]{tibble::as_tibble()}} instead. } \keyword{internal} dplyr/man/bench_compare.Rd0000644000176200001440000000515713614573562015257 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bench-compare.r \name{bench_compare} \alias{bench_compare} \alias{bench_tbls} \alias{compare_tbls} \alias{compare_tbls2} \alias{eval_tbls} \alias{eval_tbls2} \title{Evaluate, compare, benchmark operations of a set of srcs.} \usage{ bench_tbls(tbls, op, ..., times = 10) compare_tbls(tbls, op, ref = NULL, compare = equal_data_frame, ...) compare_tbls2(tbls_x, tbls_y, op, ref = NULL, compare = equal_data_frame, ...) eval_tbls(tbls, op) eval_tbls2(tbls_x, tbls_y, op) } \arguments{ \item{tbls, tbls_x, tbls_y}{A list of \code{\link[=tbl]{tbl()}}s.} \item{op}{A function with a single argument, called often with each element of \code{tbls}.} \item{\dots}{For \code{compare_tbls()}: additional parameters passed on the \code{compare()} function For \code{bench_tbls()}: additional benchmarks to run.} \item{times}{For benchmarking, the number of times each operation is repeated.} \item{ref}{For checking, a data frame to test results against. If not supplied, defaults to the results from the first \code{src}.} \item{compare}{A function used to compare the results. Defaults to \code{equal_data_frame} which ignores the order of rows and columns.} } \value{ \code{eval_tbls()}: a list of data frames. \code{compare_tbls()}: an invisible \code{TRUE} on success, otherwise an error is thrown. \code{bench_tbls()}: an object of class \code{\link[microbenchmark:microbenchmark]{microbenchmark::microbenchmark()}} } \description{ These functions support the comparison of results and timings across multiple sources. } \examples{ \dontrun{ if (require("microbenchmark") && has_lahman()) { lahman_local <- lahman_srcs("df", "sqlite") teams <- lapply(lahman_local, function(x) x \%>\% tbl("Teams")) compare_tbls(teams, function(x) x \%>\% filter(yearID == 2010)) bench_tbls(teams, function(x) x \%>\% filter(yearID == 2010)) # You can also supply arbitrary additional arguments to bench_tbls # if there are other operations you'd like to compare. bench_tbls(teams, function(x) x \%>\% filter(yearID == 2010), base = subset(Lahman::Teams, yearID == 2010)) # A more complicated example using multiple tables setup <- function(src) { list( src \%>\% tbl("Batting") \%>\% filter(stint == 1) \%>\% select(playerID:H), src \%>\% tbl("Master") \%>\% select(playerID, birthYear) ) } two_tables <- lapply(lahman_local, setup) op <- function(tbls) { semi_join(tbls[[1]], tbls[[2]], by = "playerID") } # compare_tbls(two_tables, op) bench_tbls(two_tables, op, times = 2) } } } \seealso{ \code{\link[=src_local]{src_local()}} for working with local data } \keyword{internal} dplyr/man/nth.Rd0000644000176200001440000000307013567743067013261 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/nth-value.R \name{nth} \alias{nth} \alias{first} \alias{last} \title{Extract the first, last or nth value from a vector} \usage{ nth(x, n, order_by = NULL, default = default_missing(x)) first(x, order_by = NULL, default = default_missing(x)) last(x, order_by = NULL, default = default_missing(x)) } \arguments{ \item{x}{A vector} \item{n}{For \code{nth_value()}, a single integer specifying the position. Negative integers index from the end (i.e. \code{-1L} will return the last value in the vector). If a double is supplied, it will be silently truncated.} \item{order_by}{An optional vector used to determine the order} \item{default}{A default value to use if the position does not exist in the input. This is guessed by default for base vectors, where a missing value of the appropriate type is returned, and for lists, where a \code{NULL} is return. For more complicated objects, you'll need to supply this value. Make sure it is the same type as \code{x}.} } \value{ A single value. \code{[[} is used to do the subsetting. } \description{ These are straightforward wrappers around \code{\link{[[}}. The main advantage is that you can provide an optional secondary vector that defines the ordering, and provide a default value to use when the input is shorter than expected. } \examples{ x <- 1:10 y <- 10:1 first(x) last(y) nth(x, 1) nth(x, 5) nth(x, -2) nth(x, 11) last(x) # Second argument provides optional ordering last(x, y) # These functions always return a single value first(integer()) } dplyr/man/same_src.Rd0000644000176200001440000000062313451046652014251 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/src.r \name{same_src} \alias{same_src} \title{Figure out if two sources are the same (or two tbl have the same source)} \usage{ same_src(x, y) } \arguments{ \item{x, y}{src or tbls to test} } \value{ a logical flag } \description{ Figure out if two sources are the same (or two tbl have the same source) } \keyword{internal} dplyr/man/dr_dplyr.Rd0000644000176200001440000000064013614573562014301 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dr.R \name{dr_dplyr} \alias{dr_dplyr} \title{Dr Dplyr checks your installation for common problems.} \usage{ dr_dplyr() } \description{ Only run this if you are seeing problems, like random crashes. It's possible for \code{dr_dplyr} to return false positives, so there's no need to run if all is ok. } \examples{ \dontrun{ dr_dplyr() } } dplyr/man/tbl_cube.Rd0000644000176200001440000000675513614573562014256 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tbl-cube.r \name{tbl_cube} \alias{tbl_cube} \title{A data cube tbl} \usage{ tbl_cube(dimensions, measures) } \arguments{ \item{dimensions}{A named list of vectors. A dimension is a variable whose values are known before the experiment is conducted; they are fixed by design (in \pkg{reshape2} they are known as id variables). \code{tbl_cubes} are dense which means that almost every combination of the dimensions should have associated measurements: missing values require an explicit NA, so if the variables are nested, not crossed, the majority of the data structure will be empty. Dimensions are typically, but not always, categorical variables.} \item{measures}{A named list of arrays. A measure is something that is actually measured, and is not known in advance. The dimension of each array should be the same as the length of the dimensions. Measures are typically, but not always, continuous values.} } \description{ A cube tbl stores data in a compact array format where dimension names are not needlessly repeated. They are particularly appropriate for experimental data where all combinations of factors are tried (e.g. complete factorial designs), or for storing the result of aggregations. Compared to data frames, they will occupy much less memory when variables are crossed, not nested. } \details{ \code{tbl_cube} support is currently experimental and little performance optimisation has been done, but you may find them useful if your data already comes in this form, or you struggle with the memory overhead of the sparse/crossed of data frames. There is no support for hierarchical indices (although I think that would be a relatively straightforward extension to storing data frames for indices rather than vectors). } \section{Implementation}{ Manipulation functions: \itemize{ \item \code{select()} (M) \item \code{summarise()} (M), corresponds to roll-up, but rather more limited since there are no hierarchies. \item \code{filter()} (D), corresponds to slice/dice. \item \code{mutate()} (M) is not implemented, but should be relatively straightforward given the implementation of \code{summarise}. \item \code{arrange()} (D?) Not implemented: not obvious how much sense it would make } Joins: not implemented. See \code{vignettes/joins.graffle} for ideas. Probably straightforward if you get the indexes right, and that's probably some straightforward array/tensor operation. } \examples{ # The built in nasa dataset records meterological data (temperature, # cloud cover, ozone etc) for a 4d spatio-temporal dataset (lat, long, # month and year) nasa head(as.data.frame(nasa)) titanic <- as.tbl_cube(Titanic) head(as.data.frame(titanic)) admit <- as.tbl_cube(UCBAdmissions) head(as.data.frame(admit)) as.tbl_cube(esoph, dim_names = 1:3) # Some manipulation examples with the NASA dataset -------------------------- # select() operates only on measures: it doesn't affect dimensions in any way select(nasa, cloudhigh:cloudmid) select(nasa, matches("temp")) # filter() operates only on dimensions filter(nasa, lat > 0, year == 2000) # Each component can only refer to one dimensions, ensuring that you always # create a rectangular subset \dontrun{filter(nasa, lat > long)} # Arrange is meaningless for tbl_cubes by_loc <- group_by(nasa, lat, long) summarise(by_loc, pressure = max(pressure), temp = mean(temperature)) } \seealso{ \code{\link[=as.tbl_cube]{as.tbl_cube()}} for ways of coercing existing data structures into a \code{tbl_cube}. } dplyr/man/lead-lag.Rd0000644000176200001440000000221513567521174014127 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lead-lag.R \name{lead-lag} \alias{lead-lag} \alias{lead} \alias{lag} \title{Lead and lag.} \usage{ lead(x, n = 1L, default = NA, order_by = NULL, ...) lag(x, n = 1L, default = NA, order_by = NULL, ...) } \arguments{ \item{x}{a vector of values} \item{n}{a positive integer of length 1, giving the number of positions to lead or lag by} \item{default}{value used for non-existent rows. Defaults to \code{NA}.} \item{order_by}{override the default ordering to use another vector} \item{...}{Needed for compatibility with lag generic.} } \description{ Find the "next" or "previous" values in a vector. Useful for comparing values ahead of or behind the current values. } \examples{ lead(1:10, 1) lead(1:10, 2) lag(1:10, 1) lead(1:10, 1) x <- runif(5) cbind(ahead = lead(x), x, behind = lag(x)) # Use order_by if data not already ordered df <- data.frame(year = 2000:2005, value = (0:5) ^ 2) scrambled <- df[sample(nrow(df)), ] wrong <- mutate(scrambled, prev = lag(value)) arrange(wrong, year) right <- mutate(scrambled, prev = lag(value, order_by = year)) arrange(right, year) } dplyr/man/storms.Rd0000644000176200001440000000252513451046652014007 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-storms.R \docType{data} \name{storms} \alias{storms} \title{Storm tracks data} \format{A tibble with 10,010 observations and 13 variables: \describe{ \item{name}{Storm Name} \item{year,month,day}{Date of report} \item{hour}{Hour of report (in UTC)} \item{lat,long}{Location of storm center} \item{status}{Storm classification (Tropical Depression, Tropical Storm, or Hurricane)} \item{category}{Saffir-Simpson storm category (estimated from wind speed. -1 = Tropical Depression, 0 = Tropical Storm)} \item{wind}{storm's maximum sustained wind speed (in knots)} \item{pressure}{Air pressure at the storm's center (in millibars)} \item{ts_diameter}{Diameter of the area experiencing tropical storm strength winds (34 knots or above)} \item{hu_diameter}{Diameter of the area experiencing hurricane strength winds (64 knots or above)} }} \usage{ storms } \description{ This data is a subset of the NOAA Atlantic hurricane database best track data, \url{http://www.nhc.noaa.gov/data/#hurdat}. The data includes the positions and attributes of 198 tropical storms, measured every six hours during the lifetime of a storm. } \examples{ storms } \seealso{ The script to create the storms data set: \url{https://github.com/tidyverse/dplyr/blob/master/data-raw/storms.R} } \keyword{datasets} dplyr/man/auto_copy.Rd0000644000176200001440000000125313451046652014457 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/copy-to.r \name{auto_copy} \alias{auto_copy} \title{Copy tables to same source, if necessary} \usage{ auto_copy(x, y, copy = FALSE, ...) } \arguments{ \item{x, y}{\code{y} will be copied to \code{x}, if necessary.} \item{copy}{If \code{x} and \code{y} are not from the same data source, and \code{copy} is \code{TRUE}, then \code{y} will be copied into the same src as \code{x}. This allows you to join tables across srcs, but it is a potentially expensive operation so you must opt into it.} \item{...}{Other arguments passed on to methods.} } \description{ Copy tables to same source, if necessary } dplyr/man/scoped.Rd0000644000176200001440000001143113614573562013737 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/colwise.R \name{scoped} \alias{scoped} \title{Operate on a selection of variables} \arguments{ \item{.tbl}{A \code{tbl} object.} \item{.funs}{A function \code{fun}, a quosure style lambda \code{~ fun(.)} or a list of either form.} \item{.vars}{A list of columns generated by \code{\link[=vars]{vars()}}, a character vector of column names, a numeric vector of column positions, or \code{NULL}.} \item{.predicate}{A predicate function to be applied to the columns or a logical vector. The variables for which \code{.predicate} is or returns \code{TRUE} are selected. This argument is passed to \code{\link[rlang:as_function]{rlang::as_function()}} and thus supports quosure-style lambda functions and strings representing function names.} \item{...}{Additional arguments for the function calls in \code{.funs}. These are evaluated only once, with \link[rlang:tidy-dots]{tidy dots} support.} } \description{ The variants suffixed with \code{_if}, \code{_at} or \code{_all} apply an expression (sometimes several) to all variables within a specified subset. This subset can contain all variables (\code{_all} variants), a \code{\link[=vars]{vars()}} selection (\code{_at} variants), or variables selected with a predicate (\code{_if} variants). } \details{ The verbs with scoped variants are: \itemize{ \item \code{\link[=mutate]{mutate()}}, \code{\link[=transmute]{transmute()}} and \code{\link[=summarise]{summarise()}}. See \code{\link[=summarise_all]{summarise_all()}}. \item \code{\link[=filter]{filter()}}. See \code{\link[=filter_all]{filter_all()}}. \item \code{\link[=group_by]{group_by()}}. See \code{\link[=group_by_all]{group_by_all()}}. \item \code{\link[=rename]{rename()}} and \code{\link[=select]{select()}}. See \code{\link[=select_all]{select_all()}}. \item \code{\link[=arrange]{arrange()}}. See \code{\link[=arrange_all]{arrange_all()}} } There are three kinds of scoped variants. They differ in the scope of the variable selection on which operations are applied: \itemize{ \item Verbs suffixed with \code{_all()} apply an operation on all variables. \item Verbs suffixed with \code{_at()} apply an operation on a subset of variables specified with the quoting function \code{\link[=vars]{vars()}}. This quoting function accepts \code{\link[tidyselect:vars_select]{tidyselect::vars_select()}} helpers like \code{\link[=starts_with]{starts_with()}}. Instead of a \code{\link[=vars]{vars()}} selection, you can also supply an \link[rlang:is_integerish]{integerish} vector of column positions or a character vector of column names. \item Verbs suffixed with \code{_if()} apply an operation on the subset of variables for which a predicate function returns \code{TRUE}. Instead of a predicate function, you can also supply a logical vector. } } \section{Grouping variables}{ Most of these operations also apply on the grouping variables when they are part of the selection. This includes: \itemize{ \item \code{\link[=arrange_all]{arrange_all()}}, \code{\link[=arrange_at]{arrange_at()}}, and \code{\link[=arrange_if]{arrange_if()}} \item \code{\link[=distinct_all]{distinct_all()}}, \code{\link[=distinct_at]{distinct_at()}}, and \code{\link[=distinct_if]{distinct_if()}} \item \code{\link[=filter_all]{filter_all()}}, \code{\link[=filter_at]{filter_at()}}, and \code{\link[=filter_if]{filter_if()}} \item \code{\link[=group_by_all]{group_by_all()}}, \code{\link[=group_by_at]{group_by_at()}}, and \code{\link[=group_by_if]{group_by_if()}} \item \code{\link[=select_all]{select_all()}}, \code{\link[=select_at]{select_at()}}, and \code{\link[=select_if]{select_if()}} } This is not the case for summarising and mutating variants where operations are \emph{not} applied on grouping variables. The behaviour depends on whether the selection is \strong{implicit} (\code{all} and \code{if} selections) or \strong{explicit} (\code{at} selections). Grouping variables covered by explicit selections (with \code{\link[=summarise_at]{summarise_at()}}, \code{\link[=mutate_at]{mutate_at()}}, and \code{\link[=transmute_at]{transmute_at()}}) are always an error. For implicit selections, the grouping variables are always ignored. In this case, the level of verbosity depends on the kind of operation: \itemize{ \item Summarising operations (\code{\link[=summarise_all]{summarise_all()}} and \code{\link[=summarise_if]{summarise_if()}}) ignore grouping variables silently because it is obvious that operations are not applied on grouping variables. \item On the other hand it isn't as obvious in the case of mutating operations (\code{\link[=mutate_all]{mutate_all()}}, \code{\link[=mutate_if]{mutate_if()}}, \code{\link[=transmute_all]{transmute_all()}}, and \code{\link[=transmute_if]{transmute_if()}}). For this reason, they issue a message indicating which grouping variables are ignored. } } dplyr/man/src.Rd0000644000176200001440000000116213451046652013243 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/src.r \name{src} \alias{src} \alias{is.src} \title{Create a "src" object} \usage{ src(subclass, ...) is.src(x) } \arguments{ \item{subclass}{name of subclass. "src" is an abstract base class, so you must supply this value. \code{src_} is automatically prepended to the class name} \item{...}{fields used by object. These dots are evaluated with \link[rlang:dots_list]{explicit splicing}.} \item{x}{object to test for "src"-ness.} } \description{ \code{src()} is the standard constructor for srcs and \code{is.src()} tests. } \keyword{internal} dplyr/man/desc.Rd0000644000176200001440000000077713451046652013405 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/desc.r \name{desc} \alias{desc} \title{Descending order} \usage{ desc(x) } \arguments{ \item{x}{vector to transform} } \description{ Transform a vector into a format that will be sorted in descending order. This is useful within \code{\link[=arrange]{arrange()}}. } \examples{ desc(1:10) desc(factor(letters)) first_day <- seq(as.Date("1910/1/1"), as.Date("1920/1/1"), "years") desc(first_day) starwars \%>\% arrange(desc(mass)) } dplyr/man/select_vars.Rd0000644000176200001440000000236213614573562014777 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reexport-tidyselect.R \name{select_vars} \alias{select_vars} \alias{rename_vars} \alias{select_var} \alias{current_vars} \title{Select variables} \usage{ select_vars(vars = chr(), ..., include = chr(), exclude = chr()) rename_vars(vars = chr(), ..., strict = TRUE) select_var(vars, var = -1) current_vars(...) } \arguments{ \item{vars}{A character vector of existing column names.} \item{...}{Expressions to compute.} \item{include, exclude}{Character vector of column names to always include/exclude.} \item{strict}{If \code{TRUE}, will throw an error if you attempt to rename a variable that doesn't exist.} \item{var}{A variable specified as in the same argument of \code{\link[tidyselect:vars_pull]{tidyselect::vars_pull()}}.} } \description{ \strong{Retired}: These functions now live in the tidyselect package as \code{\link[tidyselect:vars_select]{tidyselect::vars_select()}}, \code{\link[tidyselect:vars_rename]{tidyselect::vars_rename()}} and \code{\link[tidyselect:vars_pull]{tidyselect::vars_pull()}}. These dplyr aliases are soft-deprecated and will be deprecated sometimes in the future. } \details{ \Sexpr[results=rd, stage=render]{dplyr:::lifecycle("deprecated")} } dplyr/man/dplyr-package.Rd0000644000176200001440000000377613614573562015222 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dplyr.r \docType{package} \name{dplyr-package} \alias{dplyr} \alias{dplyr-package} \title{dplyr: a grammar of data manipulation} \description{ dplyr provides a flexible grammar of data manipulation. It's the next iteration of plyr, focused on tools for working with data frames (hence the \emph{d} in the name). } \details{ It has three main goals: \itemize{ \item Identify the most important data manipulation verbs and make them easy to use from R. \item Provide blazing fast performance for in-memory data by writing key pieces in C++ (using Rcpp) \item Use the same interface to work with data no matter where it's stored, whether in a data frame, a data table or database. } To learn more about dplyr, start with the vignettes: \code{browseVignettes(package = "dplyr")} } \section{Package options}{ \describe{ \item{\code{dplyr.show_progress}}{Should lengthy operations such as \code{do()} show a progress bar? Default: \code{TRUE}} } } \section{Package configurations}{ These can be set on a package-by-package basis, or for the global environment. See \code{\link[pkgconfig:set_config]{pkgconfig::set_config()}} for usage. \describe{ \item{\code{dplyr::na_matches}}{Should \code{NA} values be matched in data frame joins by default? Default: \code{"na"} (for compatibility with dplyr v0.5.0 and earlier, subject to change), alternative value: \code{"never"} (the default for database backends, see \code{\link[=join.tbl_df]{join.tbl_df()}}).} } } \seealso{ Useful links: \itemize{ \item \url{http://dplyr.tidyverse.org} \item \url{https://github.com/tidyverse/dplyr} \item Report bugs at \url{https://github.com/tidyverse/dplyr/issues} } } \author{ \strong{Maintainer}: Hadley Wickham \email{hadley@rstudio.com} (0000-0003-4757-117X) Authors: \itemize{ \item Romain François (0000-0002-2444-4226) \item Lionel Henry \item Kirill Müller (0000-0002-1416-3412) } Other contributors: \itemize{ \item RStudio [copyright holder, funder] } } dplyr/man/join.Rd0000644000176200001440000001363313614573562013427 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/join.r \name{join} \alias{join} \alias{inner_join} \alias{left_join} \alias{right_join} \alias{full_join} \alias{semi_join} \alias{nest_join} \alias{anti_join} \title{Join two tbls together} \usage{ inner_join(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ...) left_join(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ...) right_join(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ...) full_join(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ...) semi_join(x, y, by = NULL, copy = FALSE, ...) nest_join(x, y, by = NULL, copy = FALSE, keep = FALSE, name = NULL, ...) anti_join(x, y, by = NULL, copy = FALSE, ...) } \arguments{ \item{x, y}{tbls to join} \item{by}{a character vector of variables to join by. If \code{NULL}, the default, \code{*_join()} will do a natural join, using all variables with common names across the two tables. A message lists the variables so that you can check they're right (to suppress the message, simply explicitly list the variables that you want to join). To join by different variables on x and y use a named vector. For example, \code{by = c("a" = "b")} will match \code{x.a} to \code{y.b}.} \item{copy}{If \code{x} and \code{y} are not from the same data source, and \code{copy} is \code{TRUE}, then \code{y} will be copied into the same src as \code{x}. This allows you to join tables across srcs, but it is a potentially expensive operation so you must opt into it.} \item{suffix}{If there are non-joined duplicate variables in \code{x} and \code{y}, these suffixes will be added to the output to disambiguate them. Should be a character vector of length 2.} \item{...}{other parameters passed onto methods, for instance, \code{na_matches} to control how \code{NA} values are matched. See \link{join.tbl_df} for more.} \item{keep}{If \code{TRUE} the by columns are kept in the nesting joins.} \item{name}{the name of the list column nesting joins create. If \code{NULL} the name of \code{y} is used.} } \description{ These are generic functions that dispatch to individual tbl methods - see the method documentation for details of individual data sources. \code{x} and \code{y} should usually be from the same data source, but if \code{copy} is \code{TRUE}, \code{y} will automatically be copied to the same source as \code{x}. } \section{Join types}{ Currently dplyr supports four types of mutating joins, two types of filtering joins, and a nesting join. \strong{Mutating joins} combine variables from the two data.frames: \describe{ \item{\code{inner_join()}}{return all rows from \code{x} where there are matching values in \code{y}, and all columns from \code{x} and \code{y}. If there are multiple matches between \code{x} and \code{y}, all combination of the matches are returned.} \item{\code{left_join()}}{return all rows from \code{x}, and all columns from \code{x} and \code{y}. Rows in \code{x} with no match in \code{y} will have \code{NA} values in the new columns. If there are multiple matches between \code{x} and \code{y}, all combinations of the matches are returned.} \item{\code{right_join()}}{return all rows from \code{y}, and all columns from \code{x} and y. Rows in \code{y} with no match in \code{x} will have \code{NA} values in the new columns. If there are multiple matches between \code{x} and \code{y}, all combinations of the matches are returned.} \item{\code{full_join()}}{return all rows and all columns from both \code{x} and \code{y}. Where there are not matching values, returns \code{NA} for the one missing.} } \strong{Filtering joins} keep cases from the left-hand data.frame: \describe{ \item{\code{semi_join()}}{return all rows from \code{x} where there are matching values in \code{y}, keeping just columns from \code{x}. A semi join differs from an inner join because an inner join will return one row of \code{x} for each matching row of \code{y}, where a semi join will never duplicate rows of \code{x}.} \item{\code{anti_join()}}{return all rows from \code{x} where there are not matching values in \code{y}, keeping just columns from \code{x}.} } \strong{Nesting joins} create a list column of data.frames: \describe{ \item{\code{nest_join()}}{return all rows and all columns from \code{x}. Adds a list column of tibbles. Each tibble contains all the rows from \code{y} that match that row of \code{x}. When there is no match, the list column is a 0-row tibble with the same column names and types as \code{y}. \code{nest_join()} is the most fundamental join since you can recreate the other joins from it. An \code{inner_join()} is a \code{nest_join()} plus an \code{\link[tidyr:unnest]{tidyr::unnest()}}, and \code{left_join()} is a \code{nest_join()} plus an \code{unnest(.drop = FALSE)}. A \code{semi_join()} is a \code{nest_join()} plus a \code{filter()} where you check that every element of data has at least one row, and an \code{anti_join()} is a \code{nest_join()} plus a \code{filter()} where you check every element has zero rows. } } } \section{Grouping}{ Groups are ignored for the purpose of joining, but the result preserves the grouping of \code{x}. } \examples{ # "Mutating" joins combine variables from the LHS and RHS band_members \%>\% inner_join(band_instruments) band_members \%>\% left_join(band_instruments) band_members \%>\% right_join(band_instruments) band_members \%>\% full_join(band_instruments) # "Filtering" joins keep cases from the LHS band_members \%>\% semi_join(band_instruments) band_members \%>\% anti_join(band_instruments) # "Nesting" joins keep cases from the LHS and nests the RHS band_members \%>\% nest_join(band_instruments) # To suppress the message, supply by band_members \%>\% inner_join(band_instruments, by = "name") # This is good practice in production code # Use a named `by` if the join variables have different names band_members \%>\% full_join(band_instruments2, by = c("name" = "artist")) # Note that only the key from the LHS is kept } dplyr/man/arrange.Rd0000644000176200001440000000364213614573562014106 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/manip.r \name{arrange} \alias{arrange} \alias{arrange.grouped_df} \title{Arrange rows by variables} \usage{ arrange(.data, ...) \method{arrange}{grouped_df}(.data, ..., .by_group = FALSE) } \arguments{ \item{.data}{A tbl. All main verbs are S3 generics and provide methods for \code{\link[=tbl_df]{tbl_df()}}, \code{\link[dtplyr:tbl_dt]{dtplyr::tbl_dt()}} and \code{\link[dbplyr:tbl_dbi]{dbplyr::tbl_dbi()}}.} \item{...}{Comma separated list of unquoted variable names, or expressions involving variable names. Use \code{\link[=desc]{desc()}} to sort a variable in descending order.} \item{.by_group}{If \code{TRUE}, will sort first by grouping variable. Applies to grouped data frames only.} } \value{ An object of the same class as \code{.data}. } \description{ Order tbl rows by an expression involving its variables. } \section{Locales}{ The sort order for character vectors will depend on the collating sequence of the locale in use: see \code{\link[=locales]{locales()}}. } \section{Missing values}{ Unlike base sorting with \code{sort()}, \code{NA} are: \itemize{ \item always sorted to the end for local data, even when wrapped with \code{desc()}. \item treated differently for remote data, depending on the backend. } } \section{Tidy data}{ When applied to a data frame, row names are silently dropped. To preserve, convert to an explicit variable with \code{\link[tibble:rownames_to_column]{tibble::rownames_to_column()}}. } \examples{ arrange(mtcars, cyl, disp) arrange(mtcars, desc(disp)) # grouped arrange ignores groups by_cyl <- mtcars \%>\% group_by(cyl) by_cyl \%>\% arrange(desc(wt)) # Unless you specifically ask: by_cyl \%>\% arrange(desc(wt), .by_group = TRUE) } \seealso{ Other single table verbs: \code{\link{filter}}, \code{\link{mutate}}, \code{\link{select}}, \code{\link{slice}}, \code{\link{summarise}} } \concept{single table verbs} dplyr/man/rowwise.Rd0000644000176200001440000000216013614573562014160 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rowwise.r \name{rowwise} \alias{rowwise} \title{Group input by rows} \usage{ rowwise(data) } \arguments{ \item{data}{Input data frame.} } \description{ \Sexpr[results=rd, stage=render]{dplyr:::lifecycle("questioning")} } \details{ See \href{https://github.com/jennybc/row-oriented-workflows}{this repository} for alternative ways to perform row-wise operations \code{rowwise()} is used for the results of \code{\link[=do]{do()}} when you create list-variables. It is also useful to support arbitrary complex operations that need to be applied to each row. Currently, rowwise grouping only works with data frames. Its main impact is to allow you to work with list-variables in \code{\link[=summarise]{summarise()}} and \code{\link[=mutate]{mutate()}} without having to use \code{[[1]]}. This makes \code{summarise()} on a rowwise tbl effectively equivalent to \code{\link[plyr:ldply]{plyr::ldply()}}. } \examples{ df <- expand.grid(x = 1:3, y = 3:1) df_done <- df \%>\% rowwise() \%>\% do(i = seq(.$x, .$y)) df_done df_done \%>\% summarise(n = length(i)) } dplyr/man/as.tbl_cube.Rd0000644000176200001440000000216513614573562014647 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tbl-cube.r \name{as.tbl_cube} \alias{as.tbl_cube} \alias{as.tbl_cube.array} \alias{as.tbl_cube.table} \alias{as.tbl_cube.matrix} \alias{as.tbl_cube.data.frame} \title{Coerce an existing data structure into a \code{tbl_cube}} \usage{ as.tbl_cube(x, ...) \method{as.tbl_cube}{array}(x, dim_names = names(dimnames(x)), met_name = deparse(substitute(x)), ...) \method{as.tbl_cube}{table}(x, dim_names = names(dimnames(x)), met_name = "Freq", ...) \method{as.tbl_cube}{matrix}(x, dim_names = names(dimnames(x)), met_name = deparse(substitute(x)), ...) \method{as.tbl_cube}{data.frame}(x, dim_names = NULL, met_name = guess_met(x), ...) } \arguments{ \item{x}{an object to convert. Built in methods will convert arrays, tables and data frames.} \item{...}{Passed on to individual methods; otherwise ignored.} \item{dim_names}{names of the dimensions. Defaults to the names of} \item{met_name}{a string to use as the name for the measure the \code{\link[=dimnames]{dimnames()}}.} } \description{ Coerce an existing data structure into a \code{tbl_cube} } dplyr/man/if_else.Rd0000644000176200001440000000260413451046652014064 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/if_else.R \name{if_else} \alias{if_else} \title{Vectorised if} \usage{ if_else(condition, true, false, missing = NULL) } \arguments{ \item{condition}{Logical vector} \item{true, false}{Values to use for \code{TRUE} and \code{FALSE} values of \code{condition}. They must be either the same length as \code{condition}, or length 1. They must also be the same type: \code{if_else()} checks that they have the same type and same class. All other attributes are taken from \code{true}.} \item{missing}{If not \code{NULL}, will be used to replace missing values.} } \value{ Where \code{condition} is \code{TRUE}, the matching value from \code{true}, where it's \code{FALSE}, the matching value from \code{false}, otherwise \code{NA}. } \description{ Compared to the base \code{\link[=ifelse]{ifelse()}}, this function is more strict. It checks that \code{true} and \code{false} are the same type. This strictness makes the output type more predictable, and makes it somewhat faster. } \examples{ x <- c(-5:5, NA) if_else(x < 0, NA_integer_, x) if_else(x < 0, "negative", "positive", "missing") # Unlike ifelse, if_else preserves types x <- factor(sample(letters[1:5], 10, replace = TRUE)) ifelse(x \%in\% c("a", "b", "c"), x, factor(NA)) if_else(x \%in\% c("a", "b", "c"), x, factor(NA)) # Attributes are taken from the `true` vector, } dplyr/man/tbl.Rd0000644000176200001440000000072413614573562013246 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tbl.r \name{tbl} \alias{tbl} \alias{is.tbl} \alias{as.tbl} \title{Create a table from a data source} \usage{ tbl(src, ...) is.tbl(x) as.tbl(x, ...) } \arguments{ \item{src}{A data source} \item{...}{Other arguments passed on to the individual methods} \item{x}{an object to coerce to a \code{tbl}} } \description{ This is a generic method that dispatches based on the first argument. } dplyr/man/failwith.Rd0000644000176200001440000000101313614573562014264 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/failwith.r \name{failwith} \alias{failwith} \title{Fail with specified value.} \usage{ failwith(default = NULL, f, quiet = FALSE) } \arguments{ \item{default}{default value} \item{f}{function} \item{quiet}{all error messages be suppressed?} } \value{ a function } \description{ Deprecated. Please use \code{\link[purrr:possibly]{purrr::possibly()}} instead. } \seealso{ \code{\link[plyr:try_default]{plyr::try_default()}} } \keyword{internal} dplyr/man/cumall.Rd0000644000176200001440000000265213614573562013744 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/RcppExports.R \name{cumall} \alias{cumall} \alias{cumany} \alias{cummean} \title{Cumulativate versions of any, all, and mean} \usage{ cumall(x) cumany(x) cummean(x) } \arguments{ \item{x}{For \code{cumall()} and \code{cumany()}, a logical vector; for \code{cummean()} an integer or numeric vector.} } \value{ A vector the same length as \code{x}. } \description{ dplyr provides \code{cumall()}, \code{cumany()}, and \code{cummean()} to complete R's set of cumulative functions. } \section{Cumulative logical functions}{ These are particularly useful in conjunction with \code{filter()}: \itemize{ \item \code{cumall(x)}: all cases until the first \code{FALSE}. \item \code{cumall(!x)}: all cases until the first \code{TRUE}. \item \code{cumany(x)}: all cases after the first \code{TRUE}. \item \code{cumany(!x)}: all cases after the first \code{FALSE}. } } \examples{ # `cummean()` returns a numeric/integer vector of the same length # as the input vector. x <- c(1, 3, 5, 2, 2) cummean(x) cumsum(x) / seq_along(x) # `cumall()` and `cumany()` return logicals cumall(x < 5) cumany(x == 3) # `cumall()` vs. `cumany()` df <- data.frame( date = as.Date("2020-01-01") + 0:6, balance = c(100, 50, 25, -25, -50, 30, 120) ) # all rows after first overdraft df \%>\% filter(cumany(balance < 0)) # all rows until first overdraft df \%>\% filter(cumall(!(balance < 0))) } dplyr/man/grouped_df.Rd0000644000176200001440000000126113614573562014600 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/grouped-df.r \name{grouped_df} \alias{grouped_df} \alias{is.grouped_df} \alias{is_grouped_df} \title{A grouped data frame.} \usage{ grouped_df(data, vars, drop = FALSE) is.grouped_df(x) is_grouped_df(x) } \arguments{ \item{data}{a tbl or data frame.} \item{vars}{a character vector or a list of \code{\link[=name]{name()}}} \item{drop}{When \code{.drop = TRUE}, empty groups are dropped.} } \description{ The easiest way to create a grouped data frame is to call the \code{group_by()} method on a data frame or tbl: this will take care of capturing the unevaluated expressions for you. } \keyword{internal} dplyr/man/add_rownames.Rd0000644000176200001440000000100213614573562015116 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dataframe.R \name{add_rownames} \alias{add_rownames} \title{Convert row names to an explicit variable.} \usage{ add_rownames(df, var = "rowname") } \arguments{ \item{df}{Input data frame with rownames.} \item{var}{Name of variable to use} } \description{ Deprecated, use \code{\link[tibble:rownames_to_column]{tibble::rownames_to_column()}} instead. } \examples{ mtcars \%>\% tbl_df() mtcars \%>\% add_rownames() } \keyword{internal} dplyr/man/tidyeval-compat.Rd0000644000176200001440000000074413614573562015571 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils-tidy-eval.R \name{tidyeval-compat} \alias{tidyeval-compat} \alias{quo} \alias{quos} \alias{quo_name} \alias{ensym} \alias{ensyms} \alias{enexpr} \alias{enexprs} \title{Other tidy eval tools} \description{ These tidy eval tools are no longer recommended for normal usage, but are still exported for compatibility. See \code{\link[=tidyeval]{?tidyeval}} for the recommended tools. } \keyword{internal} dplyr/man/vars.Rd0000644000176200001440000000224113614573562013434 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/colwise.R \name{vars} \alias{vars} \title{Select variables} \usage{ vars(...) } \arguments{ \item{...}{Variables to include/exclude in mutate/summarise. You can use same specifications as in \code{\link[=select]{select()}}. If missing, defaults to all non-grouping variables. These arguments are automatically \link[rlang:quo]{quoted} and later \link[rlang:eval_tidy]{evaluated} in the context of the data frame. They support \link[rlang:quasiquotation]{unquoting}. See \code{vignette("programming")} for an introduction to these concepts.} } \description{ This helper is intended to provide equivalent semantics to \code{\link[=select]{select()}}. It is used for instance in scoped summarising and mutating verbs (\code{\link[=mutate_at]{mutate_at()}} and \code{\link[=summarise_at]{summarise_at()}}). } \details{ Note that verbs accepting a \code{vars()} specification also accept a numeric vector of positions or a character vector of column names. } \seealso{ \code{\link[=all_vars]{all_vars()}} and \code{\link[=any_vars]{any_vars()}} for other quoting functions that you can use with scoped verbs. } dplyr/man/distinct_all.Rd0000644000176200001440000000415013614573562015133 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/colwise-distinct.R \name{distinct_all} \alias{distinct_all} \alias{distinct_at} \alias{distinct_if} \title{Select distinct rows by a selection of variables} \usage{ distinct_all(.tbl, .funs = list(), ..., .keep_all = FALSE) distinct_at(.tbl, .vars, .funs = list(), ..., .keep_all = FALSE) distinct_if(.tbl, .predicate, .funs = list(), ..., .keep_all = FALSE) } \arguments{ \item{.tbl}{A \code{tbl} object.} \item{.funs}{A function \code{fun}, a quosure style lambda \code{~ fun(.)} or a list of either form.} \item{...}{Additional arguments for the function calls in \code{.funs}. These are evaluated only once, with \link[rlang:tidy-dots]{tidy dots} support.} \item{.keep_all}{If \code{TRUE}, keep all variables in \code{.data}. If a combination of \code{...} is not distinct, this keeps the first row of values.} \item{.vars}{A list of columns generated by \code{\link[=vars]{vars()}}, a character vector of column names, a numeric vector of column positions, or \code{NULL}.} \item{.predicate}{A predicate function to be applied to the columns or a logical vector. The variables for which \code{.predicate} is or returns \code{TRUE} are selected. This argument is passed to \code{\link[rlang:as_function]{rlang::as_function()}} and thus supports quosure-style lambda functions and strings representing function names.} } \description{ These \link{scoped} variants of \code{\link[=distinct]{distinct()}} extract distinct rows by a selection of variables. Like \code{distinct()}, you can modify the variables before ordering with the \code{.funs} argument. } \section{Grouping variables}{ The grouping variables that are part of the selection are taken into account to determine distinct rows. } \examples{ df <- tibble(x = rep(2:5, each = 2) / 2, y = rep(2:3, each = 4) / 2) df distinct_all(df) distinct_at(df, vars(x,y)) distinct_if(df, is.numeric) # You can supply a function that will be applied before extracting the distinct values # The variables of the sorted tibble keep their original values. distinct_all(df, round) arrange_all(df, list(~round(.))) } dplyr/man/init_logging.Rd0000644000176200001440000000064713614573562015142 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/RcppExports.R \name{init_logging} \alias{init_logging} \title{Enable internal logging} \usage{ init_logging(log_level) } \arguments{ \item{log_level}{A character value, one of "WARN", "INFO", "DEBUG", "VERB", or "NONE".} } \description{ Log entries, depending on the log level, will be printed to the standard error stream. } \keyword{internal} dplyr/man/mutate_all.Rd0000644000176200001440000001350613614573562014616 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/colwise-mutate.R \name{mutate_all} \alias{mutate_all} \alias{mutate_if} \alias{mutate_at} \alias{transmute_all} \alias{transmute_if} \alias{transmute_at} \title{Mutate multiple columns} \usage{ mutate_all(.tbl, .funs, ...) mutate_if(.tbl, .predicate, .funs, ...) mutate_at(.tbl, .vars, .funs, ..., .cols = NULL) transmute_all(.tbl, .funs, ...) transmute_if(.tbl, .predicate, .funs, ...) transmute_at(.tbl, .vars, .funs, ..., .cols = NULL) } \arguments{ \item{.tbl}{A \code{tbl} object.} \item{.funs}{A function \code{fun}, a quosure style lambda \code{~ fun(.)} or a list of either form.} \item{...}{Additional arguments for the function calls in \code{.funs}. These are evaluated only once, with \link[rlang:tidy-dots]{tidy dots} support.} \item{.predicate}{A predicate function to be applied to the columns or a logical vector. The variables for which \code{.predicate} is or returns \code{TRUE} are selected. This argument is passed to \code{\link[rlang:as_function]{rlang::as_function()}} and thus supports quosure-style lambda functions and strings representing function names.} \item{.vars}{A list of columns generated by \code{\link[=vars]{vars()}}, a character vector of column names, a numeric vector of column positions, or \code{NULL}.} \item{.cols}{This argument has been renamed to \code{.vars} to fit dplyr's terminology and is deprecated.} } \value{ A data frame. By default, the newly created columns have the shortest names needed to uniquely identify the output. To force inclusion of a name, even when not needed, name the input (see examples for details). } \description{ The \link{scoped} variants of \code{\link[=mutate]{mutate()}} and \code{\link[=transmute]{transmute()}} make it easy to apply the same transformation to multiple variables. There are three variants: \itemize{ \item _all affects every variable \item _at affects variables selected with a character vector or vars() \item _if affects variables selected with a predicate function: } } \section{Grouping variables}{ If applied on a grouped tibble, these operations are \emph{not} applied to the grouping variables. The behaviour depends on whether the selection is \strong{implicit} (\code{all} and \code{if} selections) or \strong{explicit} (\code{at} selections). \itemize{ \item Grouping variables covered by explicit selections in \code{mutate_at()} and \code{transmute_at()} are always an error. Add \code{-group_cols()} to the \code{\link[=vars]{vars()}} selection to avoid this:\preformatted{data \%>\% mutate_at(vars(-group_cols(), ...), myoperation) } Or remove \code{group_vars()} from the character vector of column names:\preformatted{nms <- setdiff(nms, group_vars(data)) data \%>\% mutate_at(vars, myoperation) } \item Grouping variables covered by implicit selections are ignored by \code{mutate_all()}, \code{transmute_all()}, \code{mutate_if()}, and \code{transmute_if()}. } } \section{Naming}{ The names of the created columns is derived from the names of the input variables and the names of the functions. \itemize{ \item if there is only one unnamed function, the names of the input variables are used to name the created columns \item if there is only one unnamed variable, the names of the functions are used to name the created columns. \item otherwise in the most general case, the created names are created by concatenating the names of the input variables and the names of the functions. } The names of the functions here means the names of the list of functions that is supplied. When needed and not supplied, the name of a function is the prefix "fn" followed by the index of this function within the unnamed functions in the list. Ultimately, names are made unique. } \examples{ iris <- as_tibble(iris) # All variants can be passed functions and additional arguments, # purrr-style. The _at() variants directly support strings. Here # we'll scale the variables `height` and `mass`: scale2 <- function(x, na.rm = FALSE) (x - mean(x, na.rm = na.rm)) / sd(x, na.rm) starwars \%>\% mutate_at(c("height", "mass"), scale2) # You can pass additional arguments to the function: starwars \%>\% mutate_at(c("height", "mass"), scale2, na.rm = TRUE) # You can also pass formulas to create functions on the spot, purrr-style: starwars \%>\% mutate_at(c("height", "mass"), ~scale2(., na.rm = TRUE)) # You can also supply selection helpers to _at() functions but you have # to quote them with vars(): iris \%>\% mutate_at(vars(matches("Sepal")), log) # The _if() variants apply a predicate function (a function that # returns TRUE or FALSE) to determine the relevant subset of # columns. Here we divide all the numeric columns by 100: starwars \%>\% mutate_if(is.numeric, scale2, na.rm = TRUE) # mutate_if() is particularly useful for transforming variables from # one type to another iris \%>\% mutate_if(is.factor, as.character) iris \%>\% mutate_if(is.double, as.integer) # Multiple transformations ---------------------------------------- # If you want to apply multiple transformations, pass a list of # functions. When there are multiple functions, they create new # variables instead of modifying the variables in place: iris \%>\% mutate_if(is.numeric, list(scale2, log)) # The list can contain purrr-style formulas: iris \%>\% mutate_if(is.numeric, list(~scale2(.), ~log(.))) # Note how the new variables include the function name, in order to # keep things distinct. The default names are not always helpful # but you can also supply explicit names: iris \%>\% mutate_if(is.numeric, list(scale = scale2, log = log)) # When there's only one function in the list, it modifies existing # variables in place. Give it a name to instead create new variables: iris \%>\% mutate_if(is.numeric, list(scale2)) iris \%>\% mutate_if(is.numeric, list(scale = scale2)) } \seealso{ \link[=scoped]{The other scoped verbs}, \code{\link[=vars]{vars()}} } dplyr/man/group_map.Rd0000644000176200001440000001035113614573562014453 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/group_map.R \name{group_map} \alias{group_map} \alias{group_modify} \alias{group_walk} \title{Apply a function to each group} \usage{ group_map(.tbl, .f, ..., keep = FALSE) group_modify(.tbl, .f, ..., keep = FALSE) group_walk(.tbl, .f, ...) } \arguments{ \item{.tbl}{A grouped tibble} \item{.f}{A function or formula to apply to each group. It must return a data frame. If a \strong{function}, it is used as is. It should have at least 2 formal arguments. If a \strong{formula}, e.g. \code{~ head(.x)}, it is converted to a function. In the formula, you can use \itemize{ \item \code{.} or \code{.x} to refer to the subset of rows of \code{.tbl} for the given group \item \code{.y} to refer to the key, a one row tibble with one column per grouping variable that identifies the group }} \item{...}{Additional arguments passed on to \code{.f}} \item{keep}{are the grouping variables kept in \code{.x}} } \value{ \itemize{ \item \code{group_modify()} returns a grouped tibble. In that case \code{.f} must return a data frame. \item \code{group_map()} returns a list of results from calling \code{.f} on each group \item \code{group_walk()} calls \code{.f} for side effects and returns the input \code{.tbl}, invisibly } } \description{ \code{group_map()}, \code{group_modify()} and \code{group_walk()} are purrr-style functions that can be used to iterate on grouped tibbles. } \details{ \Sexpr[results=rd, stage=render]{dplyr:::lifecycle("experimental")} Use \code{group_modify()} when \code{summarize()} is too limited, in terms of what you need to do and return for each group. \code{group_modify()} is good for "data frame in, data frame out". If that is too limited, you need to use a \link[=group_nest]{nested} or \link[=group_split]{split} workflow. \code{group_modify()} is an evolution of \code{\link[=do]{do()}}, if you have used that before. Each conceptual group of the data frame is exposed to the function \code{.f} with two pieces of information: \itemize{ \item The subset of the data for the group, exposed as \code{.x}. \item The key, a tibble with exactly one row and columns for each grouping variable, exposed as \code{.y}. } For completeness, \code{group_modify()}, \code{group_map} and \code{group_walk()} also work on ungrouped data frames, in that case the function is applied to the entire data frame (exposed as \code{.x}), and \code{.y} is a one row tibble with no column, consistently with \code{\link[=group_keys]{group_keys()}}. } \examples{ # return a list mtcars \%>\% group_by(cyl) \%>\% group_map(~ head(.x, 2L)) # return a tibble grouped by `cyl` with 2 rows per group # the grouping data is recalculated mtcars \%>\% group_by(cyl) \%>\% group_modify(~ head(.x, 2L)) if (requireNamespace("broom", quietly = TRUE)) { # a list of tibbles iris \%>\% group_by(Species) \%>\% group_map(~ broom::tidy(lm(Petal.Length ~ Sepal.Length, data = .x))) # a restructured grouped tibble iris \%>\% group_by(Species) \%>\% group_modify(~ broom::tidy(lm(Petal.Length ~ Sepal.Length, data = .x))) } # a list of vectors iris \%>\% group_by(Species) \%>\% group_map(~ quantile(.x$Petal.Length, probs = c(0.25, 0.5, 0.75))) # to use group_modify() the lambda must return a data frame iris \%>\% group_by(Species) \%>\% group_modify(~ { quantile(.x$Petal.Length, probs = c(0.25, 0.5, 0.75)) \%>\% tibble::enframe(name = "prob", value = "quantile") }) iris \%>\% group_by(Species) \%>\% group_modify(~ { .x \%>\% purrr::map_dfc(fivenum) \%>\% mutate(nms = c("min", "Q1", "median", "Q3", "max")) }) # group_walk() is for side effects dir.create(temp <- tempfile()) iris \%>\% group_by(Species) \%>\% group_walk(~ write.csv(.x, file = file.path(temp, paste0(.y$Species, ".csv")))) list.files(temp, pattern = "csv$") unlink(temp, recursive = TRUE) # group_modify() and ungrouped data frames mtcars \%>\% group_modify(~ head(.x, 2L)) } \seealso{ Other grouping functions: \code{\link{group_by_all}}, \code{\link{group_by}}, \code{\link{group_indices}}, \code{\link{group_keys}}, \code{\link{group_nest}}, \code{\link{group_rows}}, \code{\link{group_size}}, \code{\link{group_trim}}, \code{\link{groups}} } \concept{grouping functions} dplyr/man/sql.Rd0000644000176200001440000000070613451046652013256 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/compat-dbplyr.R \name{sql} \alias{sql} \title{SQL escaping.} \usage{ sql(...) } \arguments{ \item{...}{Character vectors that will be combined into a single SQL expression.} } \description{ These functions are critical when writing functions that translate R functions to sql functions. Typically a conversion function should escape all its inputs and return an sql object. } dplyr/man/mutate.Rd0000644000176200001440000001342513614573562013766 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/manip.r \name{mutate} \alias{mutate} \alias{transmute} \title{Create or transform variables} \usage{ mutate(.data, ...) transmute(.data, ...) } \arguments{ \item{.data}{A tbl. All main verbs are S3 generics and provide methods for \code{\link[=tbl_df]{tbl_df()}}, \code{\link[dtplyr:tbl_dt]{dtplyr::tbl_dt()}} and \code{\link[dbplyr:tbl_dbi]{dbplyr::tbl_dbi()}}.} \item{...}{Name-value pairs of expressions, each with length 1 or the same length as the number of rows in the group (if using \code{\link[=group_by]{group_by()}}) or in the entire input (if not using groups). The name of each argument will be the name of a new variable, and the value will be its corresponding value. Use a \code{NULL} value in \code{mutate} to drop a variable. New variables overwrite existing variables of the same name. The arguments in \code{...} are automatically \link[rlang:quo]{quoted} and \link[rlang:eval_tidy]{evaluated} in the context of the data frame. They support \link[rlang:quasiquotation]{unquoting} and splicing. See \code{vignette("programming")} for an introduction to these concepts.} } \value{ An object of the same class as \code{.data}. } \description{ \code{mutate()} adds new variables and preserves existing ones; \code{transmute()} adds new variables and drops existing ones. Both functions preserve the number of rows of the input. New variables overwrite existing variables of the same name. } \section{Useful functions available in calculations of variables}{ \itemize{ \item \code{\link{+}}, \code{\link{-}}, \code{\link[=log]{log()}}, etc., for their usual mathematical meanings \item \code{\link[=lead]{lead()}}, \code{\link[=lag]{lag()}} \item \code{\link[=dense_rank]{dense_rank()}}, \code{\link[=min_rank]{min_rank()}}, \code{\link[=percent_rank]{percent_rank()}}, \code{\link[=row_number]{row_number()}}, \code{\link[=cume_dist]{cume_dist()}}, \code{\link[=ntile]{ntile()}} \item \code{\link[=cumsum]{cumsum()}}, \code{\link[=cummean]{cummean()}}, \code{\link[=cummin]{cummin()}}, \code{\link[=cummax]{cummax()}}, \code{\link[=cumany]{cumany()}}, \code{\link[=cumall]{cumall()}} \item \code{\link[=na_if]{na_if()}}, \code{\link[=coalesce]{coalesce()}} \item \code{\link[=if_else]{if_else()}}, \code{\link[=recode]{recode()}}, \code{\link[=case_when]{case_when()}} } } \section{Grouped tibbles}{ Because mutating expressions are computed within groups, they may yield different results on grouped tibbles. This will be the case as soon as an aggregating, lagging, or ranking function is involved. Compare this ungrouped mutate:\preformatted{starwars \%>\% mutate(mass / mean(mass, na.rm = TRUE)) \%>\% pull() } With the grouped equivalent:\preformatted{starwars \%>\% group_by(gender) \%>\% mutate(mass / mean(mass, na.rm = TRUE)) \%>\% pull() } The former normalises \code{mass} by the global average whereas the latter normalises by the averages within gender levels. Note that you can't overwrite a grouping variable within \code{mutate()}. \code{mutate()} does not evaluate the expressions when the group is empty. } \section{Scoped mutation and transmutation}{ The three \link{scoped} variants of \code{mutate()} (\code{\link[=mutate_all]{mutate_all()}}, \code{\link[=mutate_if]{mutate_if()}} and \code{\link[=mutate_at]{mutate_at()}}) and the three variants of \code{transmute()} (\code{\link[=transmute_all]{transmute_all()}}, \code{\link[=transmute_if]{transmute_if()}}, \code{\link[=transmute_at]{transmute_at()}}) make it easy to apply a transformation to a selection of variables. } \section{Tidy data}{ When applied to a data frame, row names are silently dropped. To preserve, convert to an explicit variable with \code{\link[tibble:rownames_to_column]{tibble::rownames_to_column()}}. } \examples{ # Newly created variables are available immediately mtcars \%>\% as_tibble() \%>\% mutate( cyl2 = cyl * 2, cyl4 = cyl2 * 2 ) # You can also use mutate() to remove variables and # modify existing variables mtcars \%>\% as_tibble() \%>\% mutate( mpg = NULL, disp = disp * 0.0163871 # convert to litres ) # window functions are useful for grouped mutates mtcars \%>\% group_by(cyl) \%>\% mutate(rank = min_rank(desc(mpg))) # see `vignette("window-functions")` for more details # You can drop variables by setting them to NULL mtcars \%>\% mutate(cyl = NULL) # mutate() vs transmute -------------------------- # mutate() keeps all existing variables mtcars \%>\% mutate(displ_l = disp / 61.0237) # transmute keeps only the variables you create mtcars \%>\% transmute(displ_l = disp / 61.0237) # The mutate operation may yield different results on grouped # tibbles because the expressions are computed within groups. # The following normalises `mass` by the global average: starwars \%>\% mutate(mass / mean(mass, na.rm = TRUE)) \%>\% pull() # Whereas this normalises `mass` by the averages within gender # levels: starwars \%>\% group_by(gender) \%>\% mutate(mass / mean(mass, na.rm = TRUE)) \%>\% pull() # Note that you can't overwrite grouping variables: gdf <- mtcars \%>\% group_by(cyl) try(mutate(gdf, cyl = cyl * 100)) # Refer to column names stored as strings with the `.data` pronoun: vars <- c("mass", "height") mutate(starwars, prod = .data[[vars[[1]]]] * .data[[vars[[2]]]]) # For more complex cases, knowledge of tidy evaluation and the # unquote operator `!!` is required. See https://tidyeval.tidyverse.org/ # # One useful and simple tidy eval technique is to use `!!` to # bypass the data frame and its columns. Here is how to divide the # column `mass` by an object of the same name: mass <- 100 mutate(starwars, mass = mass / !!mass) } \seealso{ Other single table verbs: \code{\link{arrange}}, \code{\link{filter}}, \code{\link{select}}, \code{\link{slice}}, \code{\link{summarise}} } \concept{single table verbs} dplyr/man/na_if.Rd0000644000176200001440000000233113614573562013535 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/na_if.R \name{na_if} \alias{na_if} \title{Convert values to NA} \usage{ na_if(x, y) } \arguments{ \item{x}{Vector to modify} \item{y}{Value to replace with NA} } \value{ A modified version of \code{x} that replaces any values that are equal to \code{y} with NA. } \description{ This is a translation of the SQL command \code{NULL_IF}. It is useful if you want to convert an annoying value to \code{NA}. } \examples{ na_if(1:5, 5:1) x <- c(1, -1, 0, 10) 100 / x 100 / na_if(x, 0) y <- c("abc", "def", "", "ghi") na_if(y, "") # na_if is particularly useful inside mutate, # and is meant for use with vectors rather than entire data frames starwars \%>\% select(name, eye_color) \%>\% mutate(eye_color = na_if(eye_color, "unknown")) # na_if can also be used with scoped variants of mutate # like mutate_if to mutate multiple columns starwars \%>\% mutate_if(is.character, list(~na_if(., "unknown"))) } \seealso{ \code{\link[=coalesce]{coalesce()}} to replace missing values with a specified value. \code{\link[tidyr:replace_na]{tidyr::replace_na()}} to replace \code{NA} with a value. \code{\link[=recode]{recode()}} to more generally replace values. } dplyr/man/check_dbplyr.Rd0000644000176200001440000000142513451046652015107 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/compat-dbplyr.R \name{check_dbplyr} \alias{check_dbplyr} \alias{wrap_dbplyr_obj} \title{dbplyr compatibility functions} \usage{ check_dbplyr() wrap_dbplyr_obj(obj_name) } \description{ In dplyr 0.7.0, a number of database and SQL functions moved from dplyr to dbplyr. The generic functions stayed in dplyr (since there is no easy way to conditionally import a generic from different packages), but many other SQL and database helper functions moved. If you have written a backend, these functions generate the code you need to work with both dplyr 0.5.0 dplyr 0.7.0. } \examples{ if (requireNamespace("dbplyr", quietly = TRUE)) { wrap_dbplyr_obj("build_sql") wrap_dbplyr_obj("base_agg") } } \keyword{internal} dplyr/man/dim_desc.Rd0000644000176200001440000000064513451046652014230 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils-format.r \name{dim_desc} \alias{dim_desc} \title{Describing dimensions} \usage{ dim_desc(x) } \arguments{ \item{x}{Object to show dimensions for.} } \description{ Prints the dimensions of an array-like object in a user-friendly manner, substituting \code{NA} with ?? (for SQL queries). } \examples{ dim_desc(mtcars) } \keyword{internal} dplyr/man/pull.Rd0000644000176200001440000000211413614573562013434 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pull.R \name{pull} \alias{pull} \title{Pull out a single variable} \usage{ pull(.data, var = -1) } \arguments{ \item{.data}{A table of data} \item{var}{A variable specified as: \itemize{ \item a literal variable name \item a positive integer, giving the position counting from the left \item a negative integer, giving the position counting from the right. } The default returns the last column (on the assumption that's the column you've created most recently). This argument is taken by expression and supports \link[rlang:quasiquotation]{quasiquotation} (you can unquote column names and column positions).} } \description{ This works like \code{[[} for local data frames, and automatically collects before indexing for remote data tables. } \examples{ mtcars \%>\% pull(-1) mtcars \%>\% pull(1) mtcars \%>\% pull(cyl) # Also works for remote sources if (requireNamespace("dbplyr", quietly = TRUE)) { df <- dbplyr::memdb_frame(x = 1:10, y = 10:1, .name = "pull-ex") df \%>\% mutate(z = x * y) \%>\% pull() } } dplyr/man/groups.Rd0000644000176200001440000000155213614573562014004 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/group-by.r \name{groups} \alias{groups} \alias{group_vars} \title{Return grouping variables} \usage{ groups(x) group_vars(x) } \arguments{ \item{x}{A \code{\link[=tbl]{tbl()}}} } \description{ \code{group_vars()} returns a character vector; \code{groups()} returns a list of symbols. } \examples{ df <- tibble(x = 1, y = 2) \%>\% group_by(x, y) group_vars(df) groups(df) } \seealso{ \code{\link[=group_cols]{group_cols()}} for matching grouping variables in \link[=select]{selection contexts}. Other grouping functions: \code{\link{group_by_all}}, \code{\link{group_by}}, \code{\link{group_indices}}, \code{\link{group_keys}}, \code{\link{group_map}}, \code{\link{group_nest}}, \code{\link{group_rows}}, \code{\link{group_size}}, \code{\link{group_trim}} } \concept{grouping functions} dplyr/man/group_by_all.Rd0000644000176200001440000000516513614573562015147 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/colwise-group-by.R \name{group_by_all} \alias{group_by_all} \alias{group_by_at} \alias{group_by_if} \title{Group by a selection of variables} \usage{ group_by_all(.tbl, .funs = list(), ..., .add = FALSE, .drop = group_by_drop_default(.tbl)) group_by_at(.tbl, .vars, .funs = list(), ..., .add = FALSE, .drop = group_by_drop_default(.tbl)) group_by_if(.tbl, .predicate, .funs = list(), ..., .add = FALSE, .drop = group_by_drop_default(.tbl)) } \arguments{ \item{.tbl}{A \code{tbl} object.} \item{.funs}{A function \code{fun}, a quosure style lambda \code{~ fun(.)} or a list of either form.} \item{...}{Additional arguments for the function calls in \code{.funs}. These are evaluated only once, with \link[rlang:tidy-dots]{tidy dots} support.} \item{.add}{See \code{\link[=group_by]{group_by()}}} \item{.drop}{When \code{.drop = TRUE}, empty groups are dropped. See \code{\link[=group_by_drop_default]{group_by_drop_default()}} for what the default value is for this argument.} \item{.vars}{A list of columns generated by \code{\link[=vars]{vars()}}, a character vector of column names, a numeric vector of column positions, or \code{NULL}.} \item{.predicate}{A predicate function to be applied to the columns or a logical vector. The variables for which \code{.predicate} is or returns \code{TRUE} are selected. This argument is passed to \code{\link[rlang:as_function]{rlang::as_function()}} and thus supports quosure-style lambda functions and strings representing function names.} } \description{ These \link{scoped} variants of \code{\link[=group_by]{group_by()}} group a data frame by a selection of variables. Like \code{\link[=group_by]{group_by()}}, they have optional \link{mutate} semantics. } \section{Grouping variables}{ Existing grouping variables are maintained, even if not included in the selection. } \examples{ # Group a data frame by all variables: group_by_all(mtcars) # Group by variables selected with a predicate: group_by_if(iris, is.factor) # Group by variables selected by name: group_by_at(mtcars, vars(vs, am)) # Like group_by(), the scoped variants have optional mutate # semantics. This provide a shortcut for group_by() + mutate(): d <- tibble(x=c(1,1,2,2), y=c(1,2,1,2)) group_by_all(d, as.factor) group_by_if(iris, is.factor, as.character) } \seealso{ Other grouping functions: \code{\link{group_by}}, \code{\link{group_indices}}, \code{\link{group_keys}}, \code{\link{group_map}}, \code{\link{group_nest}}, \code{\link{group_rows}}, \code{\link{group_size}}, \code{\link{group_trim}}, \code{\link{groups}} } \concept{grouping functions} dplyr/man/recode.Rd0000644000176200001440000001217513614573562013731 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/recode.R \name{recode} \alias{recode} \alias{recode_factor} \title{Recode values} \usage{ recode(.x, ..., .default = NULL, .missing = NULL) recode_factor(.x, ..., .default = NULL, .missing = NULL, .ordered = FALSE) } \arguments{ \item{.x}{A vector to modify} \item{...}{Replacements. For character and factor \code{.x}, these should be named and replacement is based only on their name. For numeric \code{.x}, these can be named or not. If not named, the replacement is done based on position i.e. \code{.x} represents positions to look for in replacements. See examples. When named, the argument names should be the current values to be replaced, and the argument values should be the new (replacement) values. All replacements must be the same type, and must have either length one or the same length as \code{.x}. These dots support \link[rlang:tidy-dots]{tidy dots} features.} \item{.default}{If supplied, all values not otherwise matched will be given this value. If not supplied and if the replacements are the same type as the original values in \code{.x}, unmatched values are not changed. If not supplied and if the replacements are not compatible, unmatched values are replaced with \code{NA}. \code{.default} must be either length 1 or the same length as \code{.x}.} \item{.missing}{If supplied, any missing values in \code{.x} will be replaced by this value. Must be either length 1 or the same length as \code{.x}.} \item{.ordered}{If \code{TRUE}, \code{recode_factor()} creates an ordered factor.} } \value{ A vector the same length as \code{.x}, and the same type as the first of \code{...}, \code{.default}, or \code{.missing}. \code{recode_factor()} returns a factor whose levels are in the same order as in \code{...}. The levels in \code{.default} and \code{.missing} come last. } \description{ This is a vectorised version of \code{\link[=switch]{switch()}}: you can replace numeric values based on their position or their name, and character or factor values only by their name. This is an S3 generic: dplyr provides methods for numeric, character, and factors. For logical vectors, use \code{\link[=if_else]{if_else()}}. For more complicated criteria, use \code{\link[=case_when]{case_when()}}. } \details{ You can use \code{recode()} directly with factors; it will preserve the existing order of levels while changing the values. Alternatively, you can use \code{recode_factor()}, which will change the order of levels to match the order of replacements. See the \href{http://forcats.tidyverse.org/}{forcats} package for more tools for working with factors and their levels. } \examples{ # For character values, recode values with named arguments only. Unmatched # values are unchanged. char_vec <- sample(c("a", "b", "c"), 10, replace = TRUE) recode(char_vec, a = "Apple") recode(char_vec, a = "Apple", b = "Banana") # Use .default as replacement for unmatched values recode(char_vec, a = "Apple", b = "Banana", .default = NA_character_) # Use a named character vector for unquote splicing with !!! level_key <- c(a = "apple", b = "banana", c = "carrot") recode(char_vec, !!!level_key) # For numeric values, named arguments can also be used num_vec <- c(1:4, NA) recode(num_vec, `2` = 20L, `4` = 40L) # Or if you don't name the arguments, recode() matches by position. # (Only works for numeric vector) recode(num_vec, "a", "b", "c", "d") # .x (position given) looks in (...), then grabs (... value at position) # so if nothing at position (here 5), it uses .default or NA. recode(c(1,5,3), "a", "b", "c", "d", .default = "nothing") # Note that if the replacements are not compatible with .x, # unmatched values are replaced by NA and a warning is issued. recode(num_vec, `2` = "b", `4` = "d") # use .default to change the replacement value recode(num_vec, "a", "b", "c", .default = "other") # use .missing to replace missing values in .x recode(num_vec, "a", "b", "c", .default = "other", .missing = "missing") # For factor values, use only named replacements # and supply default with levels() factor_vec <- factor(c("a", "b", "c")) recode(factor_vec, a = "Apple", .default = levels(factor_vec)) # Use recode_factor() to create factors with levels ordered as they # appear in the recode call. The levels in .default and .missing # come last. recode_factor(num_vec, `1` = "z", `2` = "y", `3` = "x") recode_factor(num_vec, `1` = "z", `2` = "y", `3` = "x", .default = "D") recode_factor(num_vec, `1` = "z", `2` = "y", `3` = "x", .default = "D", .missing = "M") # When the input vector is a compatible vector (character vector or # factor), it is reused as default. recode_factor(letters[1:3], b = "z", c = "y") recode_factor(factor(letters[1:3]), b = "z", c = "y") # Use a named character vector to recode factors with unquote splicing. level_key <- c(a = "apple", b = "banana", c = "carrot") recode_factor(char_vec, !!!level_key) } \seealso{ \code{\link[=na_if]{na_if()}} to replace specified values with a \code{NA}. \code{\link[=coalesce]{coalesce()}} to replace missing values with a specified value. \code{\link[tidyr:replace_na]{tidyr::replace_na()}} to replace \code{NA} with a value. } dplyr/man/src_tbls.Rd0000644000176200001440000000065713614573562014305 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/src.r \name{src_tbls} \alias{src_tbls} \title{List all tbls provided by a source.} \usage{ src_tbls(x) } \arguments{ \item{x}{a data src.} } \description{ This is a generic method which individual src's will provide methods for. Most methods will not be documented because it's usually pretty obvious what possible results will be. } \keyword{internal} dplyr/man/filter_all.Rd0000644000176200001440000000546713614573562014613 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/colwise-filter.R \name{filter_all} \alias{filter_all} \alias{filter_if} \alias{filter_at} \title{Filter within a selection of variables} \usage{ filter_all(.tbl, .vars_predicate, .preserve = FALSE) filter_if(.tbl, .predicate, .vars_predicate, .preserve = FALSE) filter_at(.tbl, .vars, .vars_predicate, .preserve = FALSE) } \arguments{ \item{.tbl}{A \code{tbl} object.} \item{.vars_predicate}{A quoted predicate expression as returned by \code{\link[=all_vars]{all_vars()}} or \code{\link[=any_vars]{any_vars()}}. Can also be a function or purrr-like formula. In this case, the intersection of the results is taken by default and there's currently no way to request the union.} \item{.preserve}{when \code{FALSE} (the default), the grouping structure is recalculated based on the resulting data, otherwise it is kept as is.} \item{.predicate}{A predicate function to be applied to the columns or a logical vector. The variables for which \code{.predicate} is or returns \code{TRUE} are selected. This argument is passed to \code{\link[rlang:as_function]{rlang::as_function()}} and thus supports quosure-style lambda functions and strings representing function names.} \item{.vars}{A list of columns generated by \code{\link[=vars]{vars()}}, a character vector of column names, a numeric vector of column positions, or \code{NULL}.} } \description{ These \link{scoped} filtering verbs apply a predicate expression to a selection of variables. The predicate expression should be quoted with \code{\link[=all_vars]{all_vars()}} or \code{\link[=any_vars]{any_vars()}} and should mention the pronoun \code{.} to refer to variables. } \section{Grouping variables}{ The grouping variables that are part of the selection are taken into account to determine filtered rows. } \examples{ # While filter() accepts expressions with specific variables, the # scoped filter verbs take an expression with the pronoun `.` and # replicate it over all variables. This expression should be quoted # with all_vars() or any_vars(): all_vars(is.na(.)) any_vars(is.na(.)) # You can take the intersection of the replicated expressions: filter_all(mtcars, all_vars(. > 150)) # Or the union: filter_all(mtcars, any_vars(. > 150)) # You can vary the selection of columns on which to apply the # predicate. filter_at() takes a vars() specification: filter_at(mtcars, vars(starts_with("d")), any_vars((. \%\% 2) == 0)) # And filter_if() selects variables with a predicate function: filter_if(mtcars, ~ all(floor(.) == .), all_vars(. != 0)) # We're working on a new syntax to allow functions instead, # including purrr-like lambda functions. This is already # operational, but there's currently no way to specify the union of # the predicate results: mtcars \%>\% filter_at(vars(hp, vs), ~ . \%\% 2 == 0) } dplyr/man/select_all.Rd0000644000176200001440000000505013614573562014571 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/colwise-select.R \name{select_all} \alias{select_all} \alias{rename_all} \alias{select_if} \alias{rename_if} \alias{select_at} \alias{rename_at} \title{Select and rename a selection of variables} \usage{ select_all(.tbl, .funs = list(), ...) rename_all(.tbl, .funs = list(), ...) select_if(.tbl, .predicate, .funs = list(), ...) rename_if(.tbl, .predicate, .funs = list(), ...) select_at(.tbl, .vars, .funs = list(), ...) rename_at(.tbl, .vars, .funs = list(), ...) } \arguments{ \item{.tbl}{A \code{tbl} object.} \item{.funs}{A function \code{fun}, a purrr style lambda \code{~ fun(.)} or a list of either form.} \item{...}{Additional arguments for the function calls in \code{.funs}. These are evaluated only once, with \link[rlang:tidy-dots]{tidy dots} support.} \item{.predicate}{A predicate function to be applied to the columns or a logical vector. The variables for which \code{.predicate} is or returns \code{TRUE} are selected. This argument is passed to \code{\link[rlang:as_function]{rlang::as_function()}} and thus supports quosure-style lambda functions and strings representing function names.} \item{.vars}{A list of columns generated by \code{\link[=vars]{vars()}}, a character vector of column names, a numeric vector of column positions, or \code{NULL}.} } \description{ These \link{scoped} variants of \code{\link[=select]{select()}} and \code{\link[=rename]{rename()}} operate on a selection of variables. The semantics of these verbs have subtle but important differences: \itemize{ \item Selection drops variables that are not in the selection while renaming retains them. \item The renaming function is optional for selection but not for renaming. } The \code{_if} and \code{_at} variants always retain grouping variables for grouped data frames. } \section{Grouping variables}{ Existing grouping variables are always kept in the data frame, even if not included in the selection. } \examples{ # Supply a renaming function: select_all(mtcars, toupper) select_all(mtcars, "toupper") select_all(mtcars, list(~toupper(.))) # Selection drops unselected variables: is_whole <- function(x) all(floor(x) == x) select_if(mtcars, is_whole, toupper) select_at(mtcars, vars(-contains("ar"), starts_with("c")), toupper) # But renaming retains them: rename_if(mtcars, is_whole, toupper) rename_at(mtcars, vars(-(1:3)), toupper) rename_all(mtcars, toupper) # The renaming function is optional for selection: select_if(mtcars, is_whole) select_at(mtcars, vars(-everything())) select_all(mtcars) } dplyr/man/funs.Rd0000644000176200001440000000330513614573562013436 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/funs.R \name{funs} \alias{funs} \title{Create a list of functions calls.} \usage{ funs(..., .args = list()) } \arguments{ \item{...}{A list of functions specified by: \itemize{ \item Their name, \code{"mean"} \item The function itself, \code{mean} \item A call to the function with \code{.} as a dummy argument, \code{mean(., na.rm = TRUE)} } These arguments are automatically \link[rlang:quo]{quoted}. They support \link[rlang:quasiquotation]{unquoting} and splicing. See \code{vignette("programming")} for an introduction to these concepts. The following notations are \strong{not} supported, see examples: \itemize{ \item An anonymous function, \code{function(x) mean(x, na.rm = TRUE)} \item An anonymous function in \pkg{purrr} notation, \code{~mean(., na.rm = TRUE)} }} \item{.args, args}{A named list of additional arguments to be added to all function calls. As \code{funs()} is being deprecated, use other methods to supply arguments: \code{...} argument in \link[=summarise_at]{scoped verbs} or make own functions with \code{\link[purrr:partial]{purrr::partial()}}.} } \description{ \code{funs()} provides a flexible way to generate a named list of functions for input to other functions like \code{\link[=summarise_at]{summarise_at()}}. } \details{ \Sexpr[results=rd, stage=render]{dplyr:::lifecycle("soft-deprecated")} } \examples{ funs(mean, "mean", mean(., na.rm = TRUE)) # Override default names funs(m1 = mean, m2 = "mean", m3 = mean(., na.rm = TRUE)) # If you have function names in a vector, use funs_ fs <- c("min", "max") funs_(fs) # Not supported \dontrun{ funs(function(x) mean(x, na.rm = TRUE)) funs(~mean(x, na.rm = TRUE))} } dplyr/man/sample.Rd0000644000176200001440000000371313614573562013747 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sample.R \name{sample} \alias{sample} \alias{sample_n} \alias{sample_frac} \title{Sample n rows from a table} \usage{ sample_n(tbl, size, replace = FALSE, weight = NULL, .env = NULL, ...) sample_frac(tbl, size = 1, replace = FALSE, weight = NULL, .env = NULL, ...) } \arguments{ \item{tbl}{tbl of data.} \item{size}{For \code{sample_n()}, the number of rows to select. For \code{sample_frac()}, the fraction of rows to select. If \code{tbl} is grouped, \code{size} applies to each group.} \item{replace}{Sample with or without replacement?} \item{weight}{Sampling weights. This must evaluate to a vector of non-negative numbers the same length as the input. Weights are automatically standardised to sum to 1. This argument is automatically \link[rlang:quo]{quoted} and later \link[rlang:eval_tidy]{evaluated} in the context of the data frame. It supports \link[rlang:quasiquotation]{unquoting}. See \code{vignette("programming")} for an introduction to these concepts.} \item{.env}{This variable is deprecated and no longer has any effect. To evaluate \code{weight} in a particular context, you can now unquote a \link[rlang:quosure]{quosure}.} \item{...}{ignored} } \description{ This is a wrapper around \code{\link[=sample.int]{sample.int()}} to make it easy to select random rows from a table. It currently only works for local tbls. } \examples{ by_cyl <- mtcars \%>\% group_by(cyl) # Sample fixed number per group sample_n(mtcars, 10) sample_n(mtcars, 50, replace = TRUE) sample_n(mtcars, 10, weight = mpg) sample_n(by_cyl, 3) sample_n(by_cyl, 10, replace = TRUE) sample_n(by_cyl, 3, weight = mpg / mean(mpg)) # Sample fixed fraction per group # Default is to sample all data = randomly resample rows sample_frac(mtcars) sample_frac(mtcars, 0.1) sample_frac(mtcars, 1.5, replace = TRUE) sample_frac(mtcars, 0.1, weight = 1 / mpg) sample_frac(by_cyl, 0.2) sample_frac(by_cyl, 1, replace = TRUE) } dplyr/man/group_size.Rd0000644000176200001440000000147413614573562014656 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/group-size.r \name{group_size} \alias{group_size} \alias{n_groups} \title{Calculate group sizes.} \usage{ group_size(x) n_groups(x) } \arguments{ \item{x}{a grouped tbl} } \description{ Calculate group sizes. } \examples{ if (require("nycflights13")) { by_day <- flights \%>\% group_by(year, month, day) n_groups(by_day) group_size(by_day) by_dest <- flights \%>\% group_by(dest) n_groups(by_dest) group_size(by_dest) } } \seealso{ Other grouping functions: \code{\link{group_by_all}}, \code{\link{group_by}}, \code{\link{group_indices}}, \code{\link{group_keys}}, \code{\link{group_map}}, \code{\link{group_nest}}, \code{\link{group_rows}}, \code{\link{group_trim}}, \code{\link{groups}} } \concept{grouping functions} \keyword{internal} dplyr/man/n_distinct.Rd0000644000176200001440000000100013451046652014601 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/distinct.R \name{n_distinct} \alias{n_distinct} \title{Efficiently count the number of unique values in a set of vector} \usage{ n_distinct(..., na.rm = FALSE) } \arguments{ \item{\dots}{vectors of values} \item{na.rm}{if \code{TRUE} missing values don't count} } \description{ This is a faster and more concise equivalent of \code{length(unique(x))} } \examples{ x <- sample(1:10, 1e5, rep = TRUE) length(unique(x)) n_distinct(x) } dplyr/man/explain.Rd0000644000176200001440000000262213451046652014116 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/explain.r \name{explain} \alias{explain} \alias{show_query} \title{Explain details of a tbl} \usage{ explain(x, ...) show_query(x, ...) } \arguments{ \item{x}{An object to explain} \item{...}{Other parameters possibly used by generic} } \value{ The first argument, invisibly. } \description{ This is a generic function which gives more details about an object than \code{\link[=print]{print()}}, and is more focused on human readable output than \code{\link[=str]{str()}}. } \section{Databases}{ Explaining a \code{tbl_sql} will run the SQL \code{EXPLAIN} command which will describe the query plan. This requires a little bit of knowledge about how \code{EXPLAIN} works for your database, but is very useful for diagnosing performance problems. } \examples{ \donttest{ if (require("dbplyr")) { lahman_s <- lahman_sqlite() batting <- tbl(lahman_s, "Batting") batting \%>\% show_query() batting \%>\% explain() # The batting database has indices on all ID variables: # SQLite automatically picks the most restrictive index batting \%>\% filter(lgID == "NL" & yearID == 2000L) \%>\% explain() # OR's will use multiple indexes batting \%>\% filter(lgID == "NL" | yearID == 2000) \%>\% explain() # Joins will use indexes in both tables teams <- tbl(lahman_s, "Teams") batting \%>\% left_join(teams, c("yearID", "teamID")) \%>\% explain() } } } dplyr/man/src_dbi.Rd0000644000176200001440000001061213614573562014067 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/src_dbi.R \name{src_dbi} \alias{src_dbi} \alias{src_mysql} \alias{src_postgres} \alias{src_sqlite} \title{Source for database backends} \usage{ src_mysql(dbname, host = NULL, port = 0L, username = "root", password = "", ...) src_postgres(dbname = NULL, host = NULL, port = NULL, user = NULL, password = NULL, ...) src_sqlite(path, create = FALSE) } \arguments{ \item{dbname}{Database name} \item{host, port}{Host name and port number of database} \item{...}{for the src, other arguments passed on to the underlying database connector, \code{\link[DBI:dbConnect]{DBI::dbConnect()}}. For the tbl, included for compatibility with the generic, but otherwise ignored.} \item{user, username, password}{User name and password. Generally, you should avoid saving username and password in your scripts as it is easy to accidentally expose valuable credentials. Instead, retrieve them from environment variables, or use database specific credential scores. For example, with MySQL you can set up \code{my.cnf} as described in \code{\link[RMySQL:MySQL]{RMySQL::MySQL()}}.} \item{path}{Path to SQLite database. You can use the special path ":memory:" to create a temporary in memory database.} \item{create}{if \code{FALSE}, \code{path} must already exist. If \code{TRUE}, will create a new SQLite3 database at \code{path} if \code{path} does not exist and connect to the existing database if \code{path} does exist.} } \value{ An S3 object with class \code{src_dbi}, \code{src_sql}, \code{src}. } \description{ For backward compatibility dplyr provides three srcs for popular open source databases: \itemize{ \item \code{src_mysql()} connects to a MySQL or MariaDB database using \code{\link[RMySQL:MySQL]{RMySQL::MySQL()}}. \item \code{src_postgres()} connects to PostgreSQL using \code{\link[RPostgreSQL:PostgreSQL]{RPostgreSQL::PostgreSQL()}} \item \code{src_sqlite()} to connect to a SQLite database using \code{\link[RSQLite:SQLite]{RSQLite::SQLite()}}. } However, modern best practice is to use \code{\link[=tbl]{tbl()}} directly on an \code{DBIConnection}. } \details{ All data manipulation on SQL tbls are lazy: they will not actually run the query or retrieve the data unless you ask for it: they all return a new \code{tbl_dbi} object. Use \code{\link[=compute]{compute()}} to run the query and save the results in a temporary in the database, or use \code{\link[=collect]{collect()}} to retrieve the results to R. You can see the query with \code{\link[=show_query]{show_query()}}. For best performance, the database should have an index on the variables that you are grouping by. Use \code{\link[=explain]{explain()}} to check that the database is using the indexes that you expect. There is one exception: \code{\link[=do]{do()}} is not lazy since it must pull the data into R. } \examples{ # Basic connection using DBI ------------------------------------------- if (require(dbplyr, quietly = TRUE)) { con <- DBI::dbConnect(RSQLite::SQLite(), ":memory:") copy_to(con, mtcars) DBI::dbListTables(con) # To retrieve a single table from a source, use `tbl()` con \%>\% tbl("mtcars") # You can also use pass raw SQL if you want a more sophisticated query con \%>\% tbl(sql("SELECT * FROM mtcars WHERE cyl == 8")) # To show off the full features of dplyr's database integration, # we'll use the Lahman database. lahman_sqlite() takes care of # creating the database. lahman_p <- lahman_sqlite() batting <- lahman_p \%>\% tbl("Batting") batting # Basic data manipulation verbs work in the same way as with a tibble batting \%>\% filter(yearID > 2005, G > 130) batting \%>\% select(playerID:lgID) batting \%>\% arrange(playerID, desc(yearID)) batting \%>\% summarise(G = mean(G), n = n()) # There are a few exceptions. For example, databases give integer results # when dividing one integer by another. Multiply by 1 to fix the problem batting \%>\% select(playerID:lgID, AB, R, G) \%>\% mutate( R_per_game1 = R / G, R_per_game2 = R * 1.0 / G ) # All operations are lazy: they don't do anything until you request the # data, either by `print()`ing it (which shows the first ten rows), # or by `collect()`ing the results locally. system.time(recent <- filter(batting, yearID > 2010)) system.time(collect(recent)) # You can see the query that dplyr creates with show_query() batting \%>\% filter(G > 0) \%>\% group_by(playerID) \%>\% summarise(n = n()) \%>\% show_query() } } dplyr/man/src_local.Rd0000644000176200001440000000144313614573562014425 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/src-local.r \name{src_local} \alias{src_local} \alias{src_df} \title{A local source.} \usage{ src_local(tbl, pkg = NULL, env = NULL) src_df(pkg = NULL, env = NULL) } \arguments{ \item{tbl}{name of the function used to generate \code{tbl} objects} \item{pkg, env}{Either the name of a package or an environment object in which to look for objects.} } \description{ This is mainly useful for testing, since makes it possible to refer to local and remote tables using exactly the same syntax. } \details{ Generally, \code{src_local()} should not be called directly, but instead one of the constructors should be used. } \examples{ if (require("Lahman")) { batting_df <- tbl(src_df("Lahman"), "Batting") } } \keyword{internal} dplyr/man/group_indices.Rd0000644000176200001440000000150213614573562015312 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/group-indices.R \name{group_indices} \alias{group_indices} \title{Group id.} \usage{ group_indices(.data, ...) } \arguments{ \item{.data}{a tbl} \item{...}{Variables to group by. All tbls accept variable names. Some tbls will accept functions of variables. Duplicated groups will be silently dropped.} } \description{ Generate a unique id for each group } \examples{ group_indices(mtcars, cyl) } \seealso{ \code{\link[=group_by]{group_by()}} Other grouping functions: \code{\link{group_by_all}}, \code{\link{group_by}}, \code{\link{group_keys}}, \code{\link{group_map}}, \code{\link{group_nest}}, \code{\link{group_rows}}, \code{\link{group_size}}, \code{\link{group_trim}}, \code{\link{groups}} } \concept{grouping functions} \keyword{internal} dplyr/man/setops.Rd0000644000176200001440000000251513566740705014003 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sets.r \name{setops} \alias{setops} \alias{intersect} \alias{union} \alias{union_all} \alias{setdiff} \alias{setequal} \title{Set operations} \usage{ intersect(x, y, ...) union(x, y, ...) union_all(x, y, ...) setdiff(x, y, ...) setequal(x, y, ...) } \arguments{ \item{x, y}{objects to perform set function on (ignoring order)} \item{...}{other arguments passed on to methods} } \description{ These functions override the set functions provided in base to make them generic so that efficient versions for data frames and other tables can be provided. The default methods call the base versions. Beware that \code{intersect()}, \code{union()} and \code{setdiff()} remove duplicates. } \examples{ mtcars$model <- rownames(mtcars) first <- mtcars[1:20, ] second <- mtcars[10:32, ] intersect(first, second) union(first, second) setdiff(first, second) setdiff(second, first) union_all(first, second) setequal(mtcars, mtcars[32:1, ]) # Handling of duplicates: a <- data.frame(column = c(1:10, 10)) b <- data.frame(column = c(1:5, 5)) # intersection is 1 to 5, duplicates removed (5) intersect(a, b) # union is 1 to 10, duplicates removed (5 and 10) union(a, b) # set difference, duplicates removed (10) setdiff(a, b) # union all does not remove duplicates union_all(a, b) } dplyr/man/with_order.Rd0000644000176200001440000000073513451046652014627 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/order-by.R \name{with_order} \alias{with_order} \title{Run a function with one order, translating result back to original order} \usage{ with_order(order_by, fun, x, ...) } \arguments{ \item{order_by}{vector to order by} \item{fun}{window function} \item{x, ...}{arguments to \code{f}} } \description{ This is used to power the ordering parameters of dplyr's window functions } \keyword{internal} dplyr/man/near.Rd0000644000176200001440000000101513451046652013376 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/near.R \name{near} \alias{near} \title{Compare two numeric vectors} \usage{ near(x, y, tol = .Machine$double.eps^0.5) } \arguments{ \item{x, y}{Numeric vectors to compare} \item{tol}{Tolerance of comparison.} } \description{ This is a safe way of comparing if two vectors of floating point numbers are (pairwise) equal. This is safer than using \code{==}, because it has a built in tolerance } \examples{ sqrt(2) ^ 2 == 2 near(sqrt(2) ^ 2, 2) } dplyr/man/group_by_prepare.Rd0000644000176200001440000000132213614573562016024 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/distinct.R, R/group-by.r \name{distinct_prepare} \alias{distinct_prepare} \alias{group_by_prepare} \title{Same basic philosophy as group_by_prepare(): lazy_dots comes in, list of data and vars (character vector) comes out.} \usage{ distinct_prepare(.data, vars, group_vars = character(), .keep_all = FALSE) group_by_prepare(.data, ..., .dots = list(), add = FALSE) } \value{ A list \item{data}{Modified tbl} \item{groups}{Modified groups} } \description{ \code{*_prepare()} performs standard manipulation that is needed prior to actual data processing. They are only be needed by packages that implement dplyr backends. } \keyword{internal} dplyr/man/nasa.Rd0000644000176200001440000000220513614573562013403 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-nasa.r \docType{data} \name{nasa} \alias{nasa} \title{NASA spatio-temporal data} \format{A \link{tbl_cube} with 41,472 observations.} \usage{ nasa } \description{ This data comes from the ASA 2007 data expo, \url{http://stat-computing.org/dataexpo/2006/}. The data are geographic and atmospheric measures on a very coarse 24 by 24 grid covering Central America. The variables are: temperature (surface and air), ozone, air pressure, and cloud cover (low, mid, and high). All variables are monthly averages, with observations for Jan 1995 to Dec 2000. These data were obtained from the NASA Langley Research Center Atmospheric Sciences Data Center (with permission; see important copyright terms below). } \section{Dimensions}{ \itemize{ \item \code{lat}, \code{long}: latitude and longitude \item \code{year}, \code{month}: month and year } } \section{Measures}{ \itemize{ \item \code{cloudlow}, \code{cloudmed}, \code{cloudhigh}: cloud cover at three heights \item \code{ozone} \item \code{surftemp} and \code{temperature} \item \code{pressure} } } \examples{ nasa } dplyr/man/figures/0000755000176200001440000000000013451046652013631 5ustar liggesusersdplyr/man/figures/lifecycle-defunct.svg0000644000176200001440000000170413451046652017741 0ustar liggesuserslifecyclelifecycledefunctdefunct dplyr/man/figures/lifecycle-maturing.svg0000644000176200001440000000170613451046652020141 0ustar liggesuserslifecyclelifecyclematuringmaturing dplyr/man/figures/logo.png0000644000176200001440000005260413451046652015306 0ustar liggesusersPNG  IHDRX?gAMA a cHRMz&u0`:pQ<bKGD pHYs!7!73XztIME 5kv{TsIDATxwx\y9N ʠW v7HImIeq\ıc;qI쟝dݬwM^GvVkN\eIDRl {L{;&h`|0m~#07<1_sO)Й#Ot$ 1` | #W"/hu_<#<|8xepK?z? M!ML1F7f:|xuL!5L!lߵMr`-~r L%LF+?>d%ig/BN}L0#[1-i`4WiċSS)062ߙ`8U1b  ܊!>"S S)ˆp UB?ċSSb"4p,H %㋾CM!.g!ub_n'`*dy(.7a^M"g!& cjRH "NwQAF%zԵ@TƀSȳ)dD Pd)1tҼ r3XTPBt{Ե >;Z<1BIL#|#cT+%8s)zԡ! hG0jk pF2HwESӏ)if]w`CN )jQL$/42){iz84qCI!%(qPAVEȱ @%ݾ {Ч?6m3)$3ߘ9m榓jQ Njo?IfM ` 8I\螺6lEvK҄;! 飹G(%->/BN4, /Min: !&.>|um}iSM4a x huW`,)$t;(K'ۓ . RGO)0/1FMb0< F#`@JIs'ivoGqӘ$a xnElI_K)nU))~d@ GKptcӶL6[0SI *MwRNێ`Ej$ Aoc')1.2vrIw*"e;? P79imqj[(Pf~dQ~: (LϢP$' :gZܱ?nl1jӶxLa1n8(fGaE:0u>|dzӶL36?9r3od݇/IFcɴ-ie[Ƕ7l]4vLNZi[M+ie(MoPᣭ7hM'7f( 7]{=]u>C:ɲ-~8xfM#i9xtbUt3`[ R?MfojnnK:qB°-Fb4vi)0<6 '9l~ZzSvJ <-yO4' ŀ?KJZ漴-Yb,Qas(q0l~rg!@$u~zIIL\L8W< ?AׁmQ;HKohlatXgol'.+ |2h[R?6̤'ucD] /f{d"D5I[_a-mv_L;N5FSO0XRG1Z㧹mq~FNX(:8,SLfh Ũ zX=mQ2 tj&h$!9E1D'ϐ JRQVe. E ID~IOMJۢNF?RkS$]ȫ(@(*b4xYBh# TvץSn:Ǽ/wIw`s\tA]\+6'(Wdh;^-%}΀LFZfiaTL!l@mV MZtT 2O#`/,7O ,PP wf %'9fL~FS[4K|:ؤEM8M4AGmp6jgLLR)QQ~*,TtZ>q![~i1%"a JѳZe`%fkg+乍+8#MP!q ,b;>fd"oV@C >/2>u d:nb*9 w0&s =ED[fh-1>s-40ZvR`&yt6J~$ujt@2&sP$I7E|Q$ t?<ݤF @`pY 3&.0/7RT0 XNJa IBND' 4iwjR“4tB4)Q [UUEUU1]GQTt]Ǫ 3UCEq?OpAt6ߎMj))^HE;Ez{{^,V+YYY>}^ 'G qBWɇLd0(C0xt"]T8dԍ] RU`XJjeMMf{]|oUWx$ v:rs{b1bH~|>ijlr ]ݼِH#[ܵIׂf -$SPH%NoP',EPX[lcSRZ?7&\x! 4ӭQVZɯ~K<멪b5ϙ3gp@X,~N8 5kB\."hvSM\tOVfXQd9U։ b:->p%F#J2s pgq1wAâM+)7 RBG,gjU}j߈tvv@0׳tR, WHOҥKDxǕ+W|PRRѣGFJIzz:eeeAb%%%deeCK[uWT[Cg9jԨqNZBb~=jQb=n-:C_?%^6mYd .fݍfT(FYhNSSO}`?H ~;9/]I qf-| ˗/ǓjbG?|3v).Wbs^%yc6&$?26<'1 ab1 8 <Ҋx{%=ÛoɡCBǎExT\Rj%Soe݆ɢEXz5k֬!''<*++X,(bV~q!9l+#X oWr^ qnP!w>G8^syOd!PTTDGH,͹qvzv|RRjj}HXG9CU@_| ]]헉\|WظugTATu^ Vob6>6oL~~"BF tvv_]׹Xr%cCݻټy hnG@/^<OGYYYp!/">_Edads\Q?xٱc\p`*gO*=5OGz$GW3LvɾmϣU+X{ߤrպ\<~?M8{,{7 {졵4233y|ӟjv;k֬aϞ=ntcZhii}>;f}Ĺ_:BMMbQ$#rP#P1]gV'/g~SCH]Ky$?  oNy|/>d߾}F:IEERBIq!@ӧO+/s1 ^M6QQQ??3~'yp:TTTo?N^^ިinnoo|`]/xKp_;Q"*8 UmFUU"PQt7dT(zdz_HA+$(j|i͠c,5NJқ";w䯿5VZE}}=?JSS/>N._< X,FYY-"77>(D)//JhvC\.t]' a'!`Q% Ky1Ne*$׭ .?7Fĺ!22 /'t;Q 9'f֭رR~?uuun]]]twwsIΜ9Ù3gؼyBaXPUW_}ݻwŽ;x~m6m4Op:f6>rV Z{.ЁMr JA \6<2n֕ZXS Ƞk+ŋqFJKK),,Hhhhnp8"`_qڞ@6VyCH}q?NNN.kj˺ X} 7B>r]0 )2t40,ɆBK{ϵGv*=---Z |rn7~.,KRݽ}w}0 \n4lLYV֯_?g߷ooGܹsLww7@H$-EiANEEz+f M༡shH&#nyI/,/9ӭ1~p:pUBǹr9xG|O=4? >F"hЩxzRl lj2rwqe^xjkkٳ g" <p8HKK###Kvv6iiitbٰX,Kpͧ5;-d8cySzt $Ak=KNblū)]+֠i:?Wk).*P`mmm464bZy׉Ƣm6,\v=0QUB__~233x<8N p:dff5PH>Y#j.OskF[HwG50b8fZ[[Br8}4?o=* P"63P:njސFORۧRc-Ēexb-o>V+v<W=r$.9vO;YWlyQ 2V0 !*p!̏"iNV+uuuo|իWp`qw?kq_b5]HZ|{WnEֲdm8\iŋ\z`0Hzz:8 Z:DMM gΝ${Yq?k2{qZ,4'Yȁ&Q#\P@gS{bc\֬^CZ۽{7*]]]x^^ * qE-9^@%LK1x9 S)Bb3UPQ8աPy|`0Onm!S{Yϑ,uI ֦wnJ]#~ongev/^Lgg'?O{ÇEUYmw݋,ZosJ#^k,gjpI m_}k87N;{׳b 9p\x5yrcx9i(BlCq._̹N<%??Vʊ n>b}%Jkg*YLB蘃V@O~sp@UU***رc <3{Y97o4^Kt z\+Dnq-,YREnn.ϟXurQPPpV!E\Hz[X"c*d0j(H[(R$~(Op8?~0rq-PVV /@{[n{/ה>yRWt\jTJ#b)PZD[S؍[@Z7%K hFaau Qg9MM{p "m¶w>|C}nLwŋzjvE[k x<{* %{{Gϱ0Mac^v>LSoKTT.&33<;wd׮]V䠹IY3T)p3)JLn}߽ 7#<2`Y/cg+ivvÏϥKӋ Z)PR~ S z9jcӖ[Qߗ^zj***&m!K,7xݯFՒ+8p:O"N\rFo/.Fz\krqX{VYSPL8 VRYiv޽TWWOP@nn.~;===<쳔S.v_4P)XICN`W}BLFAbRr_n=.w`MၫNq`;ȯ_?G;fq N' .v@EW^yΎvS+Q.]̢NܛjN#zKm%1^XP;Gb 8ő@Cio^e;HsNn喁#]445߳=^N#R/\͛7S[[˫v#p6LO~lV+vU6Ry˃pֹ&Px_|)` dTӚ(uõ.ƛ9gm6k׮e˖-477sAYX^ 5x+ywsҟzhŀ1l!X 3ҊXb̐oe˖Ν;9{,47hJ?fzCtcS4VZĜ-36 {[yu.\jTN,YBOO/_… 8vZ[/(`u{7yškA:ZVe ӍdrCa*Z|⯸;ZRr%v rss)++krX$HͱrUzY nj8L7 d\vkGeҪ oqq^{5N:EGGlٲEvvY^/B(~]ͩSꢤÁn'//Ju|m\5T{\,Mͧ S&SBPvƾ:8)`ݽx^sƃʕ+>|SNqIF沠H$PT>jܳP'ͦہ/S&IA h9ԕI`#nͷFX-i---9s7|˗/E(BQmڵrA?,o4S"6lTuL4ikU-Z%wzF,XX^ҥK[8pb˗/]Cvv;;t5J3_Kl dP2:M}:gTj#9K]UZ‚|s" q{9vIqq1r yBuqd%L 1k+qjz4Ȝ%-YϲXR?,jM8JN[nu"-lzVTj rZ'bB0{XY?Iae^M/6u`HGt}:$5}NڕlK)_kSUUE~^޸B_S|uC8 (Z0dN!E2[aqG{3~owk+$l%+7jz/"//:޺bUn:֦MfM*|x. {7^`.,^EM^ǢŋFbcr9l7wdh d a!iae!RFS.7bJWQr+RhN"+NLN,SY?|.zKU"_`C>YIJ2\АfWX"4=@W$}'P,̥>L F^J,` x:65Y'eO7~5ȡss t!u {-z Ɣef%q dW~nta x:5_Ūл@o81 zw=a_J<`L"9!^B&k!7,L(RSGd<BaJ)C{?3w읉k[C>KЇP{sc xij35%#]h]蝵pߤn,aՉq ТȈ|e6Ypd tu֢w]A|F$YX]`3LY 2liZOJiž6xݤ -QV!ihm5DksRGc[eE^ g!}hm |o_װ.?$صMУ %Jc% ass-g zhx>Z(azaS-?Ȇv7*CB_Q9GB!t{tR aOJDy[LZq;Kjn-g&[l RqWލ!lnԂVK߃/@ #_ KF"&;LA'1(ؐD }|ᴮTa]H8?zDd- \"F/%|B(]r7p"xd*{ %~[|׻?=ECF8)5G"[C&jc[5N24M`[~/`7qhA hEQEkƿ]-8>A4H.ԣ ƄZ,eqw(EƵ1EzHkv\w'DZp kZrxc Gkh!= 3z_ ;:ǿO=Uc*-<D/NॿGL1^[v>97!~ȹZN?,t_ +o.[uR,%4x[ls|}?ы~ DXVE7Bw2Ái D(rl+7VP,z Nؿ9VqP k߯"#~B>K{]x -&;kD.jLO%aa]<(l., o_ |S(<>}6o޺` Hr;JFɐA3-B'jQ‡G4~ :c k~#M(FAk9_6t#JfUZb|$v CH~Ё]`Gż*#:.6x w9 hW Ɠz 9,KABҞ߼J8Ò"rEPыƧ[6]yb$^d#>#F Dν`Wf(RGIˍSbg;/!Ak9;VodjB,1=V< ze>͍WŤ} z !#:FŎuᭃP5Bk|8^Ȱ1&"%JF15<ԚO#n Bt51kV}GɉSC zoŽX +SLd[pҌ9yϫ|&P!CZe h>3pd eZBEDNU@kF2(%j*ԬLP~9>@;/&GDBA#v` XJ7 lG1y;ɘP n.wuԢX WO>l:X VkXb)8̾5DKfR%ra'$[5o1l5f6մa x$Nk7B`_A#h,1I±S78/W6pxnpf)#sP4//Eb^bh/Q\^lG40Π|7dL+;EAk;0LC),Җmb[aR K-k?;VL/Xpl\~x5!u7qlĠBdЁ>}P)^=(\ށ]7̾4cV E%Vw[?ƹDx~X9Ch0JVY@(Fj*ՁmB(Zydć}uFDFa7JuVC֪8u֚ӌ)" џI#7^ ՆZXZzV2 {D/V[FN=V}u{.}xC00?VP #va}DCDϿlNNdSE !Bo|ͨQ4ԆO Vk𩧍?iQbU bs= b_F>T?&|x%W(EE"lMDB/c;4W(9(ZodtL!CX!6Dza9Fu 6ȉwfn;O,-kxIq$ޏ 'b~K:cH2@#zi/Ϣu\{5AQ G'rc Dk뤨q` xLSk>E,'%% 5w]5g:[?\(Xi^W2rw.(d؇ۈ}Dk:)>%7F w )Z4K:tfX/AY6XᝥNe, jx;wL l_9?faگ3E3)`>,؂\+ @>yK$fd `[~~>>y_ޔ6۰Q=B-g'dl}g, AL2JL)iyw(CVPo/:'DuCs +$9ݮKؚ$H߆uGw|;V6B)$ 0:m:]!9o\!%y.AI f8i>bGjRb,ذV`n"%tc/m2n|I}= CS+$)JS(VO:D.)rXq"&p))"M>f$S''? XJ~44]XqTN;‘aբP1O~&)`_DrSf2#cdr$jFR6 N%1@&t$F$OmLɯ~p3iĎ1 H1pX6;q? =:=$jW;/.e@D+]B_Ra͌"4$tBLe&GG S? NbXLxAVwHUUoD\꒴K]k?_chvp{O~;_2 !Pd;q]s]yUML=2:mj^70Yyk`"d+p%F6 D(4tZ%Q`7Q}qA1ZI!= i9d2O@D~IO'|I7-0N&}]Fy'UQØ?:0l27&3h˽!9pO&? w1! `=EA m<,r\=fdW†p;Sepc=q3Dv=ۀIJBaȣഘ"6ImAO_֦${~+#l#瀥S0nas Ӷhr$H>tʛ<3Dě8I1Bȋ?>Mf{ۘ)d$1O It?~\N8Q=)1D |?̯E-B#QI 7A1D.  $ Ia-8׳MCp.ܡǚ4F!^bH޴- _{hu`Kp#TF $OcN:# <w2ۓ"0m&'aIͯcpU@r;ا!B`L7}cjHznAq{Rɝ&&GO?eAc:[C1&!B`$|X7Ki12 vl2A֠_ Ʀ$ 0z3ˆ#%O1<&?Ni26x9a>_TH`fě8eWc-L#3mF-~؁i[4I2as5FƙX5mEisuLۢ rBER7S-ni[yau"\Y67^{xͯ!8[6"`1m7F{).lkRXQG~~O$oH ο>$^-3`m9^" CwЈƜV#6I=Չa'ثF;ǔHl\0V bNI&?NbY ˴-R7_F5¾Q;59E;'c)o)R^ F-~ Ӷ8/P V`)݈} Fͮ$S u‡]uR7Sִ̹-#۪ۊտh5/`)\E]# _*f9'`նq3LѶq[`1E`[n#l:JV׿e$r(EDμ`s2l~3ŜpӶ8G5c)YO!\^w%#?GI/DI!t.圴sZ ӶXneLҦb̻b1:-F" oŲ` zo/{6?9'm~3ż05H1m3]Gs@HǶ}(rD5 Ƕ?'z'(c!6?C0`´-N?RxPau Dk8c %2@z:.Z4L{ya)杀Y@Jˋ&tX֠u^Ʋ`+Z{ Sb ͅC 2l~3żp!Ba8uۢ >.3-s%k͟)ԼmDϽ"_RXM®x[LdHZ\H˼ cLAMD)Vc*r>AXנCqe!uPʈ]{Q]\ 28KƘ 7m7ma']i 1X6߱Vގ}'x KZG@hQ4:C"6ǁb6pӶ8U$Jf2@6w}'~G8ұVA H)m{)j)nJ'Ŷe`m:'( lCCxQ3l.!Zےw6>+AO|fy_-`xqm ^d$ۈmDș i釋]:Sgfpk%Ql>Mo[Pea[{67 O#O=V"6'0r/%^مLp#Kxr.˯wa[~;hNz@G?8u_cAL1䦶-J ;"rl JZ.?ZyZ9cq)y}Cs7S}1Ř[-T0 SKOH2\O)?:H5o ۋlEDϼ@Dqe:Za 8M1RIYmQ% a)\UNO67{3SϠR0ɲu<'-J@FDN>x h5BAf' G>hMC7S ƶ(ahֲMH);`)œOpZy/#51)މb x]ۢ'% kžzQ3KP2{ľAG~oGC#^& 6:ǁċp'))2lR"dď랿Ghmvı(Yev}kr5)$ҶE#NԂXoAk=^dTΈMő 4$-/1ulטUۢ4酠pl/b %-8WZ1% :c/܄6l-*@Dl>D/׌DFE64]Oj~7o0Z[N+DN?pf"T+zgLߜ 0[Ekv#Zyzo#/ B0 Mo.c xVg>,vV$XB:M8n,}5PV16O~Q03)ޙ 3],Vö(%Jz2CM<,1E)M<,3¶>}2YiKLYm0&1h@kES)bc rMɶS iKAL #lc'm[o` 8E8QD 70$۶xL!ٶ!69)9FmQ`Fk69)9Ȉ8 qn$}')޹)9! |(GL<<`E7O1<ŶKL3FՉ_kw~GmjG"%tEXtdate:create2018-06-06T08:50:26-05:00QE%tEXtdate:modify2017-11-21T00:25:53-06:00SIENDB`dplyr/man/figures/lifecycle-archived.svg0000644000176200001440000000170713451046652020101 0ustar liggesusers lifecyclelifecyclearchivedarchived dplyr/man/figures/lifecycle-soft-deprecated.svg0000644000176200001440000000172613451046652021366 0ustar liggesuserslifecyclelifecyclesoft-deprecatedsoft-deprecated dplyr/man/figures/lifecycle-questioning.svg0000644000176200001440000000171413451046652020657 0ustar liggesuserslifecyclelifecyclequestioningquestioning dplyr/man/figures/lifecycle-stable.svg0000644000176200001440000000167413451046652017571 0ustar liggesuserslifecyclelifecyclestablestable dplyr/man/figures/lifecycle-experimental.svg0000644000176200001440000000171613451046652021011 0ustar liggesuserslifecyclelifecycleexperimentalexperimental dplyr/man/figures/lifecycle-deprecated.svg0000644000176200001440000000171213451046652020410 0ustar liggesuserslifecyclelifecycledeprecateddeprecated dplyr/man/figures/lifecycle-retired.svg0000644000176200001440000000170513451046652017750 0ustar liggesusers lifecyclelifecycleretiredretired dplyr/man/reexports.Rd0000644000176200001440000000317613614573562014524 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reexport-tibble.r, R/reexport-tidyselect.R, % R/utils.r \docType{import} \name{reexports} \alias{reexports} \alias{data_frame} \alias{data_frame_} \alias{as_data_frame} \alias{lst} \alias{lst_} \alias{add_row} \alias{type_sum} \alias{glimpse} \alias{frame_data} \alias{tribble} \alias{tibble} \alias{as_tibble} \alias{view} \alias{trunc_mat} \alias{tbl_sum} \alias{contains} \alias{select_helpers} \alias{ends_with} \alias{everything} \alias{matches} \alias{num_range} \alias{one_of} \alias{starts_with} \alias{last_col} \alias{\%>\%} \title{Objects exported from other packages} \keyword{internal} \description{ These objects are imported from other packages. Follow the links below to see their documentation. \describe{ \item{magrittr}{\code{\link[magrittr]{\%>\%}}} \item{tibble}{\code{\link[tibble]{data_frame}}, \code{\link[tibble]{data_frame_}}, \code{\link[tibble]{as_data_frame}}, \code{\link[tibble]{lst}}, \code{\link[tibble]{lst_}}, \code{\link[tibble]{add_row}}, \code{\link[tibble]{type_sum}}, \code{\link[tibble]{glimpse}}, \code{\link[tibble]{frame_data}}, \code{\link[tibble]{tribble}}, \code{\link[tibble]{tibble}}, \code{\link[tibble]{as_tibble}}, \code{\link[tibble]{view}}, \code{\link[tibble]{trunc_mat}}, \code{\link[tibble]{tbl_sum}}} \item{tidyselect}{\code{\link[tidyselect]{contains}}, \code{\link[tidyselect]{ends_with}}, \code{\link[tidyselect]{everything}}, \code{\link[tidyselect]{matches}}, \code{\link[tidyselect]{num_range}}, \code{\link[tidyselect]{one_of}}, \code{\link[tidyselect]{starts_with}}, \code{\link[tidyselect]{last_col}}} }} dplyr/man/make_tbl.Rd0000644000176200001440000000123013614573562014234 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tbl.r \name{make_tbl} \alias{make_tbl} \title{Create a "tbl" object} \usage{ make_tbl(subclass, ...) } \arguments{ \item{subclass}{name of subclass. "tbl" is an abstract base class, so you must supply this value. \code{tbl_} is automatically prepended to the class name} \item{...}{For \code{tbl()}, other fields used by class. For \code{as.tbl()}, other arguments passed to methods.} \item{object}{to test/coerce.} } \description{ \code{tbl()} is the standard constructor for tbls. \code{as.tbl()} coerces, and \code{is.tbl()} tests. } \examples{ as.tbl(mtcars) } \keyword{internal} dplyr/man/group_by.Rd0000644000176200001440000000653513614573562014321 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/group-by.r \name{group_by} \alias{group_by} \alias{ungroup} \title{Group by one or more variables} \usage{ group_by(.data, ..., add = FALSE, .drop = group_by_drop_default(.data)) ungroup(x, ...) } \arguments{ \item{.data}{a tbl} \item{...}{Variables to group by. All tbls accept variable names. Some tbls will accept functions of variables. Duplicated groups will be silently dropped.} \item{add}{When \code{add = FALSE}, the default, \code{group_by()} will override existing groups. To add to the existing groups, use \code{add = TRUE}.} \item{.drop}{When \code{.drop = TRUE}, empty groups are dropped. See \code{\link[=group_by_drop_default]{group_by_drop_default()}} for what the default value is for this argument.} \item{x}{A \code{\link[=tbl]{tbl()}}} } \value{ A \link[=grouped_df]{grouped data frame}, unless the combination of \code{...} and \code{add} yields a non empty set of grouping columns, a regular (ungrouped) data frame otherwise. } \description{ Most data operations are done on groups defined by variables. \code{group_by()} takes an existing tbl and converts it into a grouped tbl where operations are performed "by group". \code{ungroup()} removes grouping. } \section{Tbl types}{ \code{group_by()} is an S3 generic with methods for the three built-in tbls. See the help for the corresponding classes and their manip methods for more details: \itemize{ \item data.frame: \link{grouped_df} \item data.table: \link[dtplyr:grouped_dt]{dtplyr::grouped_dt} \item SQLite: \code{\link[=src_sqlite]{src_sqlite()}} \item PostgreSQL: \code{\link[=src_postgres]{src_postgres()}} \item MySQL: \code{\link[=src_mysql]{src_mysql()}} } } \section{Scoped grouping}{ The three \link{scoped} variants (\code{\link[=group_by_all]{group_by_all()}}, \code{\link[=group_by_if]{group_by_if()}} and \code{\link[=group_by_at]{group_by_at()}}) make it easy to group a dataset by a selection of variables. } \examples{ by_cyl <- mtcars \%>\% group_by(cyl) # grouping doesn't change how the data looks (apart from listing # how it's grouped): by_cyl # It changes how it acts with the other dplyr verbs: by_cyl \%>\% summarise( disp = mean(disp), hp = mean(hp) ) by_cyl \%>\% filter(disp == max(disp)) # Each call to summarise() removes a layer of grouping by_vs_am <- mtcars \%>\% group_by(vs, am) by_vs <- by_vs_am \%>\% summarise(n = n()) by_vs by_vs \%>\% summarise(n = sum(n)) # To removing grouping, use ungroup by_vs \%>\% ungroup() \%>\% summarise(n = sum(n)) # You can group by expressions: this is just short-hand for # a mutate/rename followed by a simple group_by mtcars \%>\% group_by(vsam = vs + am) # By default, group_by overrides existing grouping by_cyl \%>\% group_by(vs, am) \%>\% group_vars() # Use add = TRUE to instead append by_cyl \%>\% group_by(vs, am, add = TRUE) \%>\% group_vars() # when factors are involved, groups can be empty tbl <- tibble( x = 1:10, y = factor(rep(c("a", "c"), each = 5), levels = c("a", "b", "c")) ) tbl \%>\% group_by(y) \%>\% group_rows() } \seealso{ Other grouping functions: \code{\link{group_by_all}}, \code{\link{group_indices}}, \code{\link{group_keys}}, \code{\link{group_map}}, \code{\link{group_nest}}, \code{\link{group_rows}}, \code{\link{group_size}}, \code{\link{group_trim}}, \code{\link{groups}} } \concept{grouping functions} dplyr/man/group_split.Rd0000644000176200001440000000664413614573562015043 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/group_keys.R, R/group_split.R \name{group_keys} \alias{group_keys} \alias{group_split} \title{Split data frame by groups} \usage{ group_keys(.tbl, ...) group_split(.tbl, ..., keep = TRUE) } \arguments{ \item{.tbl}{A tbl} \item{...}{Grouping specification, forwarded to \code{\link[=group_by]{group_by()}}} \item{keep}{Should the grouping columns be kept} } \value{ \itemize{ \item \code{\link[=group_split]{group_split()}} returns a list of tibbles. Each tibble contains the rows of \code{.tbl} for the associated group and all the columns, including the grouping variables. \item \code{\link[=group_keys]{group_keys()}} returns a tibble with one row per group, and one column per grouping variable } } \description{ Split data frame by groups } \details{ \Sexpr[results=rd, stage=render]{dplyr:::lifecycle("experimental")} \code{\link[=group_split]{group_split()}} works like \code{\link[base:split]{base::split()}} but \itemize{ \item it uses the grouping structure from \code{\link[=group_by]{group_by()}} and therefore is subject to the data mask \item it does not name the elements of the list based on the grouping as this typically loses information and is confusing. } \code{\link[=group_keys]{group_keys()}} explains the grouping structure, by returning a data frame that has one row per group and one column per grouping variable. } \section{Grouped data frames}{ The primary use case for \code{\link[=group_split]{group_split()}} is with already grouped data frames, typically a result of \code{\link[=group_by]{group_by()}}. In this case \code{\link[=group_split]{group_split()}} only uses the first argument, the grouped tibble, and warns when \code{...} is used. Because some of these groups may be empty, it is best paried with \code{\link[=group_keys]{group_keys()}} which identifies the representatives of each grouping variable for the group. } \section{Ungrouped data frames}{ When used on ungrouped data frames, \code{\link[=group_split]{group_split()}} and \code{\link[=group_keys]{group_keys()}} forwards the \code{...} to \code{\link[=group_by]{group_by()}} before the split, therefore the \code{...} are subject to the data mask. Using these functions on an ungrouped data frame only makes sense if you need only one or the other, because otherwise the grouping algorithm is performed each time. } \section{Rowwise data frames}{ \code{\link[=group_split]{group_split()}} returns a list of one-row tibbles is returned, and the \code{...} are ignored and warned against } \examples{ # ----- use case 1 : on an already grouped tibble ir <- iris \%>\% group_by(Species) group_split(ir) group_keys(ir) # this can be useful if the grouped data has been altered before the split ir <- iris \%>\% group_by(Species) \%>\% filter(Sepal.Length > mean(Sepal.Length)) group_split(ir) group_keys(ir) # ----- use case 2: using a group_by() grouping specification # both group_split() and group_keys() have to perform the grouping # so it only makes sense to do this if you only need one or the other iris \%>\% group_split(Species) iris \%>\% group_keys(Species) } \seealso{ Other grouping functions: \code{\link{group_by_all}}, \code{\link{group_by}}, \code{\link{group_indices}}, \code{\link{group_map}}, \code{\link{group_nest}}, \code{\link{group_rows}}, \code{\link{group_size}}, \code{\link{group_trim}}, \code{\link{groups}} } \concept{grouping functions} dplyr/man/ident.Rd0000644000176200001440000000114613451046652013561 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/compat-dbplyr.R \name{ident} \alias{ident} \title{Flag a character vector as SQL identifiers} \usage{ ident(...) } \arguments{ \item{...}{A character vector, or name-value pairs} } \description{ \code{ident()} takes unquoted strings and flags them as identifiers. \code{ident_q()} assumes its input has already been quoted, and ensures it does not get quoted again. This is currently used only for for \code{schema.table}. } \examples{ # Identifiers are escaped with " if (requireNamespace("dbplyr", quietly = TRUE)) { ident("x") } } dplyr/man/filter.Rd0000644000176200001440000001131213614573562013745 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/manip.r \name{filter} \alias{filter} \title{Return rows with matching conditions} \usage{ filter(.data, ..., .preserve = FALSE) } \arguments{ \item{.data}{A tbl. All main verbs are S3 generics and provide methods for \code{\link[=tbl_df]{tbl_df()}}, \code{\link[dtplyr:tbl_dt]{dtplyr::tbl_dt()}} and \code{\link[dbplyr:tbl_dbi]{dbplyr::tbl_dbi()}}.} \item{...}{Logical predicates defined in terms of the variables in \code{.data}. Multiple conditions are combined with \code{&}. Only rows where the condition evaluates to \code{TRUE} are kept. The arguments in \code{...} are automatically \link[rlang:quo]{quoted} and \link[rlang:eval_tidy]{evaluated} in the context of the data frame. They support \link[rlang:quasiquotation]{unquoting} and splicing. See \code{vignette("programming")} for an introduction to these concepts.} \item{.preserve}{when \code{FALSE} (the default), the grouping structure is recalculated based on the resulting data, otherwise it is kept as is.} } \value{ An object of the same class as \code{.data}. } \description{ Use \code{filter()} to choose rows/cases where conditions are true. Unlike base subsetting with \code{[}, rows where the condition evaluates to \code{NA} are dropped. } \details{ Note that dplyr is not yet smart enough to optimise filtering optimisation on grouped datasets that don't need grouped calculations. For this reason, filtering is often considerably faster on \code{\link[=ungroup]{ungroup()}}ed data. } \section{Useful filter functions}{ \itemize{ \item \code{\link{==}}, \code{\link{>}}, \code{\link{>=}} etc \item \code{\link{&}}, \code{\link{|}}, \code{\link{!}}, \code{\link[=xor]{xor()}} \item \code{\link[=is.na]{is.na()}} \item \code{\link[=between]{between()}}, \code{\link[=near]{near()}} } } \section{Grouped tibbles}{ Because filtering expressions are computed within groups, they may yield different results on grouped tibbles. This will be the case as soon as an aggregating, lagging, or ranking function is involved. Compare this ungrouped filtering:\preformatted{starwars \%>\% filter(mass > mean(mass, na.rm = TRUE)) } With the grouped equivalent:\preformatted{starwars \%>\% group_by(gender) \%>\% filter(mass > mean(mass, na.rm = TRUE)) } The former keeps rows with \code{mass} greater than the global average whereas the latter keeps rows with \code{mass} greater than the gender average. It is valid to use grouping variables in filter expressions. When applied on a grouped tibble, \code{filter()} automatically \link[=arrange]{rearranges} the tibble by groups for performance reasons. } \section{Tidy data}{ When applied to a data frame, row names are silently dropped. To preserve, convert to an explicit variable with \code{\link[tibble:rownames_to_column]{tibble::rownames_to_column()}}. } \section{Scoped filtering}{ The three \link{scoped} variants (\code{\link[=filter_all]{filter_all()}}, \code{\link[=filter_if]{filter_if()}} and \code{\link[=filter_at]{filter_at()}}) make it easy to apply a filtering condition to a selection of variables. } \examples{ filter(starwars, species == "Human") filter(starwars, mass > 1000) # Multiple criteria filter(starwars, hair_color == "none" & eye_color == "black") filter(starwars, hair_color == "none" | eye_color == "black") # Multiple arguments are equivalent to and filter(starwars, hair_color == "none", eye_color == "black") # The filtering operation may yield different results on grouped # tibbles because the expressions are computed within groups. # # The following filters rows where `mass` is greater than the # global average: starwars \%>\% filter(mass > mean(mass, na.rm = TRUE)) # Whereas this keeps rows with `mass` greater than the gender # average: starwars \%>\% group_by(gender) \%>\% filter(mass > mean(mass, na.rm = TRUE)) # Refer to column names stored as strings with the `.data` pronoun: vars <- c("mass", "height") cond <- c(80, 150) starwars \%>\% filter( .data[[vars[[1]]]] > cond[[1]], .data[[vars[[2]]]] > cond[[2]] ) # For more complex cases, knowledge of tidy evaluation and the # unquote operator `!!` is required. See https://tidyeval.tidyverse.org/ # # One useful and simple tidy eval technique is to use `!!` to bypass # the data frame and its columns. Here is how to filter the columns # `mass` and `height` relative to objects of the same names: mass <- 80 height <- 150 filter(starwars, mass > !!mass, height > !!height) } \seealso{ \code{\link[=filter_all]{filter_all()}}, \code{\link[=filter_if]{filter_if()}} and \code{\link[=filter_at]{filter_at()}}. Other single table verbs: \code{\link{arrange}}, \code{\link{mutate}}, \code{\link{select}}, \code{\link{slice}}, \code{\link{summarise}} } \concept{single table verbs} dplyr/man/hybrid_call.Rd0000644000176200001440000000067113614573562014742 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/hybrid.R \name{hybrid_call} \alias{hybrid_call} \title{Inspect how dplyr evaluates an expression} \usage{ hybrid_call(.data, expr) } \arguments{ \item{.data}{a tibble} \item{expr}{an expression} } \description{ Inspect how dplyr evaluates an expression } \examples{ # hybrid evaulation hybrid_call(iris, n()) # standard evaluation hybrid_call(iris, n() + 1L) } dplyr/man/between.Rd0000644000176200001440000000105313614573562014112 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/RcppExports.R \name{between} \alias{between} \title{Do values in a numeric vector fall in specified range?} \usage{ between(x, left, right) } \arguments{ \item{x}{A numeric vector of values} \item{left, right}{Boundary values} } \description{ This is a shortcut for \code{x >= left & x <= right}, implemented efficiently in C++ for local values, and translated to the appropriate SQL for remote tables. } \examples{ between(1:12, 7, 9) x <- rnorm(1e2) x[between(x, -1, 1)] } dplyr/man/group_cols.Rd0000644000176200001440000000166313451046652014636 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/grouped-df.r \name{group_cols} \alias{group_cols} \title{Select grouping variables} \usage{ group_cols(vars = peek_vars()) } \arguments{ \item{vars}{A character vector of variable names. When called from inside selecting functions like \code{\link[dplyr:select]{dplyr::select()}} these are automatically set to the names of the table.} } \description{ This selection helpers matches grouping variables. It can be used in \code{\link[=select]{select()}} or \link[=scoped]{vars()} selections. } \examples{ gdf <- iris \%>\% group_by(Species) # Select the grouping variables: gdf \%>\% select(group_cols()) # Remove the grouping variables from mutate selections: gdf \%>\% mutate_at(vars(-group_cols()), `/`, 100) } \seealso{ \code{\link[=groups]{groups()}} and \code{\link[=group_vars]{group_vars()}} for retrieving the grouping variables outside selection contexts. } dplyr/man/compute.Rd0000644000176200001440000000251113614573562014135 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/compute-collect.r \name{compute} \alias{compute} \alias{collect} \alias{collapse} \title{Force computation of a database query} \usage{ compute(x, name = random_table_name(), ...) collect(x, ...) collapse(x, ...) } \arguments{ \item{x}{A tbl} \item{name}{Name of temporary table on database.} \item{...}{Other arguments passed on to methods} } \description{ \code{compute()} stores results in a remote temporary table. \code{collect()} retrieves data into a local tibble. \code{collapse()} is slightly different: it doesn't force computation, but instead forces generation of the SQL query. This is sometimes needed to work around bugs in dplyr's SQL generation. } \details{ All functions preserve grouping and ordering. } \examples{ if (require(dbplyr)) { mtcars2 <- src_memdb() \%>\% copy_to(mtcars, name = "mtcars2-cc", overwrite = TRUE) remote <- mtcars2 \%>\% filter(cyl == 8) \%>\% select(mpg:drat) # Compute query and save in remote table compute(remote) # Compute query bring back to this session collect(remote) # Creates a fresh query based on the generated SQL collapse(remote) } } \seealso{ \code{\link[=copy_to]{copy_to()}}, the opposite of \code{collect()}: it takes a local data frame and uploads it to the remote source. } dplyr/man/case_when.Rd0000644000176200001440000001070713614573562014423 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/case_when.R \name{case_when} \alias{case_when} \title{A general vectorised if} \usage{ case_when(...) } \arguments{ \item{...}{A sequence of two-sided formulas. The left hand side (LHS) determines which values match this case. The right hand side (RHS) provides the replacement value. The LHS must evaluate to a logical vector. The RHS does not need to be logical, but all RHSs must evaluate to the same type of vector. Both LHS and RHS may have the same length of either 1 or \code{n}. The value of \code{n} must be consistent across all cases. The case of \code{n == 0} is treated as a variant of \code{n != 1}. \code{NULL} inputs are ignored. These dots support \link[rlang:list2]{tidy dots} features. In particular, if your patterns are stored in a list, you can splice that in with \code{!!!}.} } \value{ A vector of length 1 or \code{n}, matching the length of the logical input or output vectors, with the type (and attributes) of the first RHS. Inconsistent lengths or types will generate an error. } \description{ This function allows you to vectorise multiple \code{\link[=if_else]{if_else()}} statements. It is an R equivalent of the SQL \code{CASE WHEN} statement. If no cases match, \code{NA} is returned. } \examples{ x <- 1:50 case_when( x \%\% 35 == 0 ~ "fizz buzz", x \%\% 5 == 0 ~ "fizz", x \%\% 7 == 0 ~ "buzz", TRUE ~ as.character(x) ) # Like an if statement, the arguments are evaluated in order, so you must # proceed from the most specific to the most general. This won't work: case_when( TRUE ~ as.character(x), x \%\% 5 == 0 ~ "fizz", x \%\% 7 == 0 ~ "buzz", x \%\% 35 == 0 ~ "fizz buzz" ) # If none of the cases match, NA is used: case_when( x \%\% 5 == 0 ~ "fizz", x \%\% 7 == 0 ~ "buzz", x \%\% 35 == 0 ~ "fizz buzz" ) # Note that NA values in the vector x do not get special treatment. If you want # to explicitly handle NA values you can use the `is.na` function: x[2:4] <- NA_real_ case_when( x \%\% 35 == 0 ~ "fizz buzz", x \%\% 5 == 0 ~ "fizz", x \%\% 7 == 0 ~ "buzz", is.na(x) ~ "nope", TRUE ~ as.character(x) ) # All RHS values need to be of the same type. Inconsistent types will throw an error. # This applies also to NA values used in RHS: NA is logical, use # typed values like NA_real_, NA_complex, NA_character_, NA_integer_ as appropriate. case_when( x \%\% 35 == 0 ~ NA_character_, x \%\% 5 == 0 ~ "fizz", x \%\% 7 == 0 ~ "buzz", TRUE ~ as.character(x) ) case_when( x \%\% 35 == 0 ~ 35, x \%\% 5 == 0 ~ 5, x \%\% 7 == 0 ~ 7, TRUE ~ NA_real_ ) # case_when() evaluates all RHS expressions, and then constructs its # result by extracting the selected (via the LHS expressions) parts. # In particular NaN are produced in this case: y <- seq(-2, 2, by = .5) case_when( y >= 0 ~ sqrt(y), TRUE ~ y ) # This throws an error as NA is logical not numeric \dontrun{ case_when( x \%\% 35 == 0 ~ 35, x \%\% 5 == 0 ~ 5, x \%\% 7 == 0 ~ 7, TRUE ~ NA ) } # case_when is particularly useful inside mutate when you want to # create a new variable that relies on a complex combination of existing # variables starwars \%>\% select(name:mass, gender, species) \%>\% mutate( type = case_when( height > 200 | mass > 200 ~ "large", species == "Droid" ~ "robot", TRUE ~ "other" ) ) # `case_when()` is not a tidy eval function. If you'd like to reuse # the same patterns, extract the `case_when()` call in a normal # function: case_character_type <- function(height, mass, species) { case_when( height > 200 | mass > 200 ~ "large", species == "Droid" ~ "robot", TRUE ~ "other" ) } case_character_type(150, 250, "Droid") case_character_type(150, 150, "Droid") # Such functions can be used inside `mutate()` as well: starwars \%>\% mutate(type = case_character_type(height, mass, species)) \%>\% pull(type) # `case_when()` ignores `NULL` inputs. This is useful when you'd # like to use a pattern only under certain conditions. Here we'll # take advantage of the fact that `if` returns `NULL` when there is # no `else` clause: case_character_type <- function(height, mass, species, robots = TRUE) { case_when( height > 200 | mass > 200 ~ "large", if (robots) species == "Droid" ~ "robot", TRUE ~ "other" ) } starwars \%>\% mutate(type = case_character_type(height, mass, species, robots = FALSE)) \%>\% pull(type) } dplyr/man/backend_dbplyr.Rd0000644000176200001440000000737713614573562015443 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dbplyr.R \name{backend_dbplyr} \alias{backend_dbplyr} \alias{db_desc} \alias{sql_translate_env} \alias{db_list_tables} \alias{db_has_table} \alias{db_data_type} \alias{db_save_query} \alias{db_begin} \alias{db_commit} \alias{db_rollback} \alias{db_write_table} \alias{db_create_table} \alias{db_insert_into} \alias{db_create_indexes} \alias{db_create_index} \alias{db_drop_table} \alias{db_analyze} \alias{db_explain} \alias{db_query_fields} \alias{db_query_rows} \alias{sql_select} \alias{sql_subquery} \alias{sql_join} \alias{sql_semi_join} \alias{sql_set_op} \alias{sql_escape_string} \alias{sql_escape_ident} \title{Database and SQL generics.} \usage{ db_desc(x) sql_translate_env(con) db_list_tables(con) db_has_table(con, table) db_data_type(con, fields) db_save_query(con, sql, name, temporary = TRUE, ...) db_begin(con, ...) db_commit(con, ...) db_rollback(con, ...) db_write_table(con, table, types, values, temporary = FALSE, ...) db_create_table(con, table, types, temporary = FALSE, ...) db_insert_into(con, table, values, ...) db_create_indexes(con, table, indexes = NULL, unique = FALSE, ...) db_create_index(con, table, columns, name = NULL, unique = FALSE, ...) db_drop_table(con, table, force = FALSE, ...) db_analyze(con, table, ...) db_explain(con, sql, ...) db_query_fields(con, sql, ...) db_query_rows(con, sql, ...) sql_select(con, select, from, where = NULL, group_by = NULL, having = NULL, order_by = NULL, limit = NULL, distinct = FALSE, ...) sql_subquery(con, from, name = random_table_name(), ...) sql_join(con, x, y, vars, type = "inner", by = NULL, ...) sql_semi_join(con, x, y, anti = FALSE, by = NULL, ...) sql_set_op(con, x, y, method) sql_escape_string(con, x) sql_escape_ident(con, x) } \arguments{ \item{con}{A database connection.} \item{table}{A string, the table name.} \item{fields}{A list of fields, as in a data frame.} } \value{ Usually a logical value indicating success. Most failures should generate an error. However, \code{db_has_table()} should return \code{NA} if temporary tables cannot be listed with \code{\link[DBI:dbListTables]{DBI::dbListTables()}} (due to backend API limitations for example). As a result, you methods will rely on the backend to throw an error if a table exists when it shouldn't. } \description{ The \code{sql_} generics are used to build the different types of SQL queries. The default implementations in dbplyr generates ANSI 92 compliant SQL. The \code{db_} generics execute actions on the database. The default implementations in dbplyr typically just call the standard DBI S4 method. } \details{ A few backend methods do not call the standard DBI S4 methods including \itemize{ \item \code{db_data_type()}: Calls \code{\link[DBI:dbDataType]{DBI::dbDataType()}} for every field (e.g. data frame column) and returns a vector of corresponding SQL data types \item \code{db_save_query()}: Builds and executes a \code{CREATE [TEMPORARY] TABLE ...} SQL command. \item \code{db_create_index()}: Builds and executes a \code{CREATE INDEX ON
} SQL command. \item \code{db_drop_table()}: Builds and executes a \code{DROP TABLE [IF EXISTS]
} SQL command. \item \code{db_analyze()}: Builds and executes an \code{ANALYZE
} SQL command. } Currently, \code{\link[=copy_to]{copy_to()}} is the only user of \code{db_begin()}, \code{db_commit()}, \code{db_rollback()}, \code{db_write_table()}, \code{db_create_indexes()}, \code{db_drop_table()} and \code{db_analyze()}. If you find yourself overriding many of these functions it may suggest that you should just override \code{copy_to()} instead. \code{db_create_table()} and \code{db_insert_into()} have been deprecated in favour of \code{db_write_table()}. } \keyword{internal} dplyr/man/ranking.Rd0000644000176200001440000000356613614573562014125 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rank.R \name{ranking} \alias{ranking} \alias{row_number} \alias{ntile} \alias{min_rank} \alias{dense_rank} \alias{percent_rank} \alias{cume_dist} \title{Windowed rank functions.} \usage{ row_number(x) ntile(x = row_number(), n) min_rank(x) dense_rank(x) percent_rank(x) cume_dist(x) } \arguments{ \item{x}{a vector of values to rank. Missing values are left as is. If you want to treat them as the smallest or largest values, replace with Inf or -Inf before ranking.} \item{n}{number of groups to split up into.} } \description{ Six variations on ranking functions, mimicking the ranking functions described in SQL2003. They are currently implemented using the built in \code{rank} function, and are provided mainly as a convenience when converting between R and SQL. All ranking functions map smallest inputs to smallest outputs. Use \code{\link[=desc]{desc()}} to reverse the direction. } \details{ \itemize{ \item \code{row_number()}: equivalent to \code{rank(ties.method = "first")} \item \code{min_rank()}: equivalent to \code{rank(ties.method = "min")} \item \code{dense_rank()}: like \code{min_rank()}, but with no gaps between ranks \item \code{percent_rank()}: a number between 0 and 1 computed by rescaling \code{min_rank} to \code{[0, 1]} \item \code{cume_dist()}: a cumulative distribution function. Proportion of all values less than or equal to the current rank. \item \code{ntile()}: a rough rank, which breaks the input vector into \code{n} buckets. } } \examples{ x <- c(5, 1, 3, 2, 2, NA) row_number(x) min_rank(x) dense_rank(x) percent_rank(x) cume_dist(x) ntile(x, 2) ntile(runif(100), 10) # row_number can be used with single table verbs without specifying x # (for data frames and databases that support windowing) mutate(mtcars, row_number() == 1L) mtcars \%>\% filter(between(row_number(), 1, 10)) } dplyr/man/copy_to.Rd0000644000176200001440000000205213614573562014135 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/copy-to.r \name{copy_to} \alias{copy_to} \title{Copy a local data frame to a remote src} \usage{ copy_to(dest, df, name = deparse(substitute(df)), overwrite = FALSE, ...) } \arguments{ \item{dest}{remote data source} \item{df}{local data frame} \item{name}{name for new remote table.} \item{overwrite}{If \code{TRUE}, will overwrite an existing table with name \code{name}. If \code{FALSE}, will throw an error if \code{name} already exists.} \item{...}{other parameters passed to methods.} } \value{ a \code{tbl} object in the remote source } \description{ This function uploads a local data frame into a remote data source, creating the table definition as needed. Wherever possible, the new object will be temporary, limited to the current connection to the source. } \examples{ \dontrun{ iris2 <- dbplyr::src_memdb() \%>\% copy_to(iris, overwrite = TRUE) iris2 } } \seealso{ \code{\link[=collect]{collect()}} for the opposite action; downloading remote data into a local dbl. } dplyr/man/combine.Rd0000644000176200001440000000172213614573562014100 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bind.r \name{combine} \alias{combine} \title{Combine vectors} \usage{ combine(...) } \arguments{ \item{...}{Vectors to combine.} } \description{ \code{combine()} acts like \code{\link[=c]{c()}} or \code{\link[=unlist]{unlist()}} but uses consistent dplyr coercion rules. If \code{combine()} it is called with exactly one list argument, the list is simplified (similarly to \code{unlist(recursive = FALSE)}). \code{NULL} arguments are ignored. If the result is empty, \code{logical()} is returned. Use \code{\link[vctrs:vec_c]{vctrs::vec_c()}} if you never want to unlist. } \details{ \Sexpr[results=rd, stage=render]{dplyr:::lifecycle("questioning")} } \examples{ # combine applies the same coercion rules as bind_rows() f1 <- factor("a") f2 <- factor("b") c(f1, f2) unlist(list(f1, f2)) combine(f1, f2) combine(list(f1, f2)) } \seealso{ \code{bind_rows()} and \code{bind_cols()} in \link{bind}. } dplyr/man/all_equal.Rd0000644000176200001440000000327013614573562014423 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/all-equal.r \name{all_equal} \alias{all_equal} \alias{all.equal.tbl_df} \title{Flexible equality comparison for data frames} \usage{ all_equal(target, current, ignore_col_order = TRUE, ignore_row_order = TRUE, convert = FALSE, ...) \method{all.equal}{tbl_df}(target, current, ignore_col_order = TRUE, ignore_row_order = TRUE, convert = FALSE, ...) } \arguments{ \item{target, current}{Two data frames to compare.} \item{ignore_col_order}{Should order of columns be ignored?} \item{ignore_row_order}{Should order of rows be ignored?} \item{convert}{Should similar classes be converted? Currently this will convert factor to character and integer to double.} \item{...}{Ignored. Needed for compatibility with \code{all.equal()}.} } \value{ \code{TRUE} if equal, otherwise a character vector describing the reasons why they're not equal. Use \code{\link[=isTRUE]{isTRUE()}} if using the result in an \code{if} expression. } \description{ You can use \code{all_equal()} with any data frame, and dplyr also provides \code{tbl_df} methods for \code{\link[=all.equal]{all.equal()}}. } \examples{ scramble <- function(x) x[sample(nrow(x)), sample(ncol(x))] # By default, ordering of rows and columns ignored all_equal(mtcars, scramble(mtcars)) # But those can be overriden if desired all_equal(mtcars, scramble(mtcars), ignore_col_order = FALSE) all_equal(mtcars, scramble(mtcars), ignore_row_order = FALSE) # By default all_equal is sensitive to variable differences df1 <- data.frame(x = "a") df2 <- data.frame(x = factor("a")) all_equal(df1, df2) # But you can request dplyr convert similar types all_equal(df1, df2, convert = TRUE) } dplyr/man/summarise_all.Rd0000644000176200001440000001225213614573562015321 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/colwise-mutate.R \name{summarise_all} \alias{summarise_all} \alias{summarise_if} \alias{summarise_at} \alias{summarize_all} \alias{summarize_if} \alias{summarize_at} \title{Summarise multiple columns} \usage{ summarise_all(.tbl, .funs, ...) summarise_if(.tbl, .predicate, .funs, ...) summarise_at(.tbl, .vars, .funs, ..., .cols = NULL) summarize_all(.tbl, .funs, ...) summarize_if(.tbl, .predicate, .funs, ...) summarize_at(.tbl, .vars, .funs, ..., .cols = NULL) } \arguments{ \item{.tbl}{A \code{tbl} object.} \item{.funs}{A function \code{fun}, a quosure style lambda \code{~ fun(.)} or a list of either form.} \item{...}{Additional arguments for the function calls in \code{.funs}. These are evaluated only once, with \link[rlang:tidy-dots]{tidy dots} support.} \item{.predicate}{A predicate function to be applied to the columns or a logical vector. The variables for which \code{.predicate} is or returns \code{TRUE} are selected. This argument is passed to \code{\link[rlang:as_function]{rlang::as_function()}} and thus supports quosure-style lambda functions and strings representing function names.} \item{.vars}{A list of columns generated by \code{\link[=vars]{vars()}}, a character vector of column names, a numeric vector of column positions, or \code{NULL}.} \item{.cols}{This argument has been renamed to \code{.vars} to fit dplyr's terminology and is deprecated.} } \value{ A data frame. By default, the newly created columns have the shortest names needed to uniquely identify the output. To force inclusion of a name, even when not needed, name the input (see examples for details). } \description{ The \link{scoped} variants of \code{\link[=summarise]{summarise()}} make it easy to apply the same transformation to multiple variables. There are three variants. \itemize{ \item \code{summarise_all()} affects every variable \item \code{summarise_at()} affects variables selected with a character vector or vars() \item \code{summarise_if()} affects variables selected with a predicate function } } \section{Grouping variables}{ If applied on a grouped tibble, these operations are \emph{not} applied to the grouping variables. The behaviour depends on whether the selection is \strong{implicit} (\code{all} and \code{if} selections) or \strong{explicit} (\code{at} selections). \itemize{ \item Grouping variables covered by explicit selections in \code{summarise_at()} are always an error. Add \code{-group_cols()} to the \code{\link[=vars]{vars()}} selection to avoid this:\preformatted{data \%>\% summarise_at(vars(-group_cols(), ...), myoperation) } Or remove \code{group_vars()} from the character vector of column names:\preformatted{nms <- setdiff(nms, group_vars(data)) data \%>\% summarise_at(vars, myoperation) } \item Grouping variables covered by implicit selections are silently ignored by \code{summarise_all()} and \code{summarise_if()}. } } \section{Naming}{ The names of the created columns is derived from the names of the input variables and the names of the functions. \itemize{ \item if there is only one unnamed function, the names of the input variables are used to name the created columns \item if there is only one unnamed variable, the names of the functions are used to name the created columns. \item otherwise in the most general case, the created names are created by concatenating the names of the input variables and the names of the functions. } The names of the functions here means the names of the list of functions that is supplied. When needed and not supplied, the name of a function is the prefix "fn" followed by the index of this function within the unnamed functions in the list. Ultimately, names are made unique. } \examples{ by_species <- iris \%>\% group_by(Species) # The _at() variants directly support strings: starwars \%>\% summarise_at(c("height", "mass"), mean, na.rm = TRUE) # You can also supply selection helpers to _at() functions but you have # to quote them with vars(): starwars \%>\% summarise_at(vars(height:mass), mean, na.rm = TRUE) # The _if() variants apply a predicate function (a function that # returns TRUE or FALSE) to determine the relevant subset of # columns. Here we apply mean() to the numeric columns: starwars \%>\% summarise_if(is.numeric, mean, na.rm = TRUE) # If you want to apply multiple transformations, pass a list of # functions. When there are multiple functions, they create new # variables instead of modifying the variables in place: by_species \%>\% summarise_all(list(min, max)) # Note how the new variables include the function name, in order to # keep things distinct. Passing purrr-style lambdas often creates # better default names: by_species \%>\% summarise_all(list(~min(.), ~max(.))) # When that's not good enough, you can also supply the names explicitly: by_species \%>\% summarise_all(list(min = min, max = max)) # When there's only one function in the list, it modifies existing # variables in place. Give it a name to create new variables instead: by_species \%>\% summarise_all(list(med = median)) by_species \%>\% summarise_all(list(Q3 = quantile), probs = 0.75) } \seealso{ \link[=scoped]{The other scoped verbs}, \code{\link[=vars]{vars()}} } dplyr/man/tidyeval.Rd0000644000176200001440000000367613614573562014317 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils-tidy-eval.R \name{tidyeval} \alias{tidyeval} \alias{expr} \alias{enquo} \alias{enquos} \alias{sym} \alias{syms} \alias{.data} \alias{as_label} \title{Tidy eval helpers} \description{ \itemize{ \item \code{\link[rlang]{sym}()} creates a symbol from a string and \code{\link[rlang]{syms}()} creates a list of symbols from a character vector. \item \code{\link[rlang]{enquo}()} and \code{\link[rlang]{enquos}()} delay the execution of one or several function arguments. \code{enquo()} returns a single quoted expression, which is like a blueprint for the delayed computation. \code{enquos()} returns a list of such quoted expressions. \item \code{\link[rlang]{expr}()} quotes a new expression \emph{locally}. It is mostly useful to build new expressions around arguments captured with \code{\link[=enquo]{enquo()}} or \code{\link[=enquos]{enquos()}}: \code{expr(mean(!!enquo(arg), na.rm = TRUE))}. \item \code{\link[rlang]{as_name}()} transforms a quoted variable name into a string. Supplying something else than a quoted variable name is an error. That's unlike \code{\link[rlang]{as_label}()} which also returns a single string but supports any kind of R object as input, including quoted function calls and vectors. Its purpose is to summarise that object into a single label. That label is often suitable as a default name. If you don't know what a quoted expression contains (for instance expressions captured with \code{enquo()} could be a variable name, a call to a function, or an unquoted constant), then use \code{as_label()}. If you know you have quoted a simple variable name, or would like to enforce this, use \code{as_name()}. } To learn more about tidy eval and how to use these tools, visit \url{http://tidyeval.tidyverse.org} and the \href{https://adv-r.hadley.nz/metaprogramming.html}{Metaprogramming section} of \href{https://adv-r.hadley.nz}{Advanced R}. } \keyword{internal} dplyr/man/tally.Rd0000644000176200001440000000711113614573562013607 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/count-tally.R \name{tally} \alias{tally} \alias{count} \alias{add_tally} \alias{add_count} \title{Count/tally observations by group} \usage{ tally(x, wt = NULL, sort = FALSE, name = "n") count(x, ..., wt = NULL, sort = FALSE, name = "n", .drop = group_by_drop_default(x)) add_tally(x, wt, sort = FALSE, name = "n") add_count(x, ..., wt = NULL, sort = FALSE, name = "n") } \arguments{ \item{x}{a \code{\link[=tbl]{tbl()}} to tally/count.} \item{wt}{(Optional) If omitted (and no variable named \code{n} exists in the data), will count the number of rows. If specified, will perform a "weighted" tally by summing the (non-missing) values of variable \code{wt}. A column named \code{n} (but not \code{nn} or \code{nnn}) will be used as weighting variable by default in \code{tally()}, but not in \code{count()}. This argument is automatically \link[rlang:quo]{quoted} and later \link[rlang:eval_tidy]{evaluated} in the context of the data frame. It supports \link[rlang:quasiquotation]{unquoting}. See \code{vignette("programming")} for an introduction to these concepts.} \item{sort}{if \code{TRUE} will sort output in descending order of \code{n}} \item{name}{The output column name. If omitted, it will be \code{n}.} \item{...}{Variables to group by.} \item{.drop}{see \code{\link[=group_by]{group_by()}}} } \value{ A tbl, grouped the same way as \code{x}. } \description{ \code{tally()} is a convenient wrapper for summarise that will either call \code{\link[=n]{n()}} or \code{\link{sum}(n)} depending on whether you're tallying for the first time, or re-tallying. \code{count()} is similar but calls \code{\link[=group_by]{group_by()}} before and \code{\link[=ungroup]{ungroup()}} after. If the data is already grouped, \code{count()} adds an additional group that is removed afterwards. \code{add_tally()} adds a column \code{n} to a table based on the number of items within each existing group, while \code{add_count()} is a shortcut that does the grouping as well. These functions are to \code{\link[=tally]{tally()}} and \code{\link[=count]{count()}} as \code{\link[=mutate]{mutate()}} is to \code{\link[=summarise]{summarise()}}: they add an additional column rather than collapsing each group. } \note{ The column name in the returned data is given by the \code{name} argument, set to \code{"n"} by default. If the data already has a column by that name, the output column will be prefixed by an extra \code{"n"} as many times as necessary. } \examples{ # tally() is short-hand for summarise() mtcars \%>\% tally() mtcars \%>\% group_by(cyl) \%>\% tally() # count() is a short-hand for group_by() + tally() mtcars \%>\% count(cyl) # Note that if the data is already grouped, count() adds # an additional group that is removed afterwards mtcars \%>\% group_by(gear) \%>\% count(carb) # add_tally() is short-hand for mutate() mtcars \%>\% add_tally() # add_count() is a short-hand for group_by() + add_tally() mtcars \%>\% add_count(cyl) # count() and tally() are designed so that you can call # them repeatedly, each time rolling up a level of detail species <- starwars \%>\% count(species, homeworld, sort = TRUE) species species \%>\% count(species, sort = TRUE) # Change the name of the newly created column: species <- starwars \%>\% count(species, homeworld, sort = TRUE, name = "n_species_by_homeworld") species species \%>\% count(species, sort = TRUE, name = "n_species") # add_count() is useful for groupwise filtering # e.g.: show details for species that have a single member starwars \%>\% add_count(species) \%>\% filter(n == 1) } dplyr/man/coalesce.Rd0000644000176200001440000000231513614573562014241 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/coalesce.R \name{coalesce} \alias{coalesce} \title{Find first non-missing element} \usage{ coalesce(...) } \arguments{ \item{...}{Vectors. All inputs should either be length 1, or the same length as the first argument. These dots support \link[rlang:tidy-dots]{tidy dots} features.} } \value{ A vector the same length as the first \code{...} argument with missing values replaced by the first non-missing value. } \description{ Given a set of vectors, \code{coalesce()} finds the first non-missing value at each position. This is inspired by the SQL \code{COALESCE} function which does the same thing for \code{NULL}s. } \examples{ # Use a single value to replace all missing values x <- sample(c(1:5, NA, NA, NA)) coalesce(x, 0L) # Or match together a complete vector from missing pieces y <- c(1, 2, NA, NA, 5) z <- c(NA, NA, 3, 4, 5) coalesce(y, z) # Supply lists by splicing them into dots: vecs <- list( c(1, 2, NA, NA, 5), c(NA, NA, 3, 4, 5) ) coalesce(!!!vecs) } \seealso{ \code{\link[=na_if]{na_if()}} to replace specified values with a \code{NA}. \code{\link[tidyr:replace_na]{tidyr::replace_na()}} to replace \code{NA} with a value } dplyr/man/order_by.Rd0000644000176200001440000000210113451046652014253 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/order-by.R \name{order_by} \alias{order_by} \title{A helper function for ordering window function output} \usage{ order_by(order_by, call) } \arguments{ \item{order_by}{a vector to order_by} \item{call}{a function call to a window function, where the first argument is the vector being operated on} } \description{ This function makes it possible to control the ordering of window functions in R that don't have a specific ordering parameter. When translated to SQL it will modify the order clause of the OVER function. } \details{ This function works by changing the \code{call} to instead call \code{\link[=with_order]{with_order()}} with the appropriate arguments. } \examples{ order_by(10:1, cumsum(1:10)) x <- 10:1 y <- 1:10 order_by(x, cumsum(y)) df <- data.frame(year = 2000:2005, value = (0:5) ^ 2) scrambled <- df[sample(nrow(df)), ] wrong <- mutate(scrambled, running = cumsum(value)) arrange(wrong, year) right <- mutate(scrambled, running = order_by(year, cumsum(value))) arrange(right, year) } dplyr/man/progress_estimated.Rd0000644000176200001440000000233613451046652016363 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/progress.R \name{progress_estimated} \alias{progress_estimated} \title{Progress bar with estimated time.} \usage{ progress_estimated(n, min_time = 0) } \arguments{ \item{n}{Total number of items} \item{min_time}{Progress bar will wait until at least \code{min_time} seconds have elapsed before displaying any results.} } \value{ A ref class with methods \code{tick()}, \code{print()}, \code{pause()}, and \code{stop()}. } \description{ This reference class represents a text progress bar displayed estimated time remaining. When finished, it displays the total duration. The automatic progress bar can be disabled by setting option \code{dplyr.show_progress} to \code{FALSE}. } \examples{ p <- progress_estimated(3) p$tick() p$tick() p$tick() p <- progress_estimated(3) for (i in 1:3) p$pause(0.1)$tick()$print() p <- progress_estimated(3) p$tick()$print()$ pause(1)$stop() # If min_time is set, progress bar not shown until that many # seconds have elapsed p <- progress_estimated(3, min_time = 3) for (i in 1:3) p$pause(0.1)$tick()$print() \dontrun{ p <- progress_estimated(10, min_time = 3) for (i in 1:10) p$pause(0.5)$tick()$print() } } \keyword{internal} dplyr/man/se-deprecated.Rd0000644000176200001440000000735313614573562015177 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/count-tally.R, R/distinct.R, R/do.r, R/funs.R, % R/group-by.r, R/group-indices.R, R/manip.r, R/reexport-tidyselect.R \name{tally_} \alias{tally_} \alias{count_} \alias{add_tally_} \alias{add_count_} \alias{distinct_} \alias{do_} \alias{funs_} \alias{group_by_} \alias{group_indices_} \alias{filter_} \alias{slice_} \alias{summarise_} \alias{summarize_} \alias{mutate_} \alias{transmute_} \alias{arrange_} \alias{select_} \alias{rename_} \alias{se-deprecated} \alias{select_vars_} \alias{rename_vars_} \title{Deprecated SE versions of main verbs.} \usage{ tally_(x, wt, sort = FALSE) count_(x, vars, wt = NULL, sort = FALSE, .drop = group_by_drop_default(x)) add_tally_(x, wt, sort = FALSE) add_count_(x, vars, wt = NULL, sort = FALSE) distinct_(.data, ..., .dots, .keep_all = FALSE) do_(.data, ..., .dots = list()) funs_(dots, args = list(), env = base_env()) group_by_(.data, ..., .dots = list(), add = FALSE) group_indices_(.data, ..., .dots = list()) filter_(.data, ..., .dots = list()) slice_(.data, ..., .dots = list()) summarise_(.data, ..., .dots = list()) summarize_(.data, ..., .dots = list()) mutate_(.data, ..., .dots = list()) transmute_(.data, ..., .dots = list()) arrange_(.data, ..., .dots = list()) select_(.data, ..., .dots = list()) rename_(.data, ..., .dots = list()) select_vars_(vars, args, include = chr(), exclude = chr()) rename_vars_(vars, args) } \arguments{ \item{x}{a \code{\link[=tbl]{tbl()}} to tally/count.} \item{wt}{(Optional) If omitted (and no variable named \code{n} exists in the data), will count the number of rows. If specified, will perform a "weighted" tally by summing the (non-missing) values of variable \code{wt}. A column named \code{n} (but not \code{nn} or \code{nnn}) will be used as weighting variable by default in \code{tally()}, but not in \code{count()}. This argument is automatically \link[rlang:quo]{quoted} and later \link[rlang:eval_tidy]{evaluated} in the context of the data frame. It supports \link[rlang:quasiquotation]{unquoting}. See \code{vignette("programming")} for an introduction to these concepts.} \item{sort}{if \code{TRUE} will sort output in descending order of \code{n}} \item{vars}{Various meanings depending on the verb.} \item{.drop}{see \code{\link[=group_by]{group_by()}}} \item{.data}{A data frame.} \item{.keep_all}{If \code{TRUE}, keep all variables in \code{.data}. If a combination of \code{...} is not distinct, this keeps the first row of values.} \item{dots, .dots, ...}{Pair/values of expressions coercible to lazy objects.} \item{args}{Various meanings depending on the verb.} \item{env}{The environment in which functions should be evaluated.} \item{add}{When \code{add = FALSE}, the default, \code{group_by()} will override existing groups. To add to the existing groups, use \code{add = TRUE}.} \item{include, exclude}{Character vector of column names to always include/exclude.} } \description{ dplyr used to offer twin versions of each verb suffixed with an underscore. These versions had standard evaluation (SE) semantics: rather than taking arguments by code, like NSE verbs, they took arguments by value. Their purpose was to make it possible to program with dplyr. However, dplyr now uses tidy evaluation semantics. NSE verbs still capture their arguments, but you can now unquote parts of these arguments. This offers full programmability with NSE verbs. Thus, the underscored versions are now superfluous. } \details{ Unquoting triggers immediate evaluation of its operand and inlines the result within the captured expression. This result can be a value or an expression to be evaluated later with the rest of the argument. See \code{vignette("programming")} for more information. } \keyword{internal} dplyr/man/group_data.Rd0000644000176200001440000000210213614573562014602 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/group_data.R \name{group_rows} \alias{group_rows} \alias{group_data} \title{Grouping data} \usage{ group_rows(.data) group_data(.data) } \arguments{ \item{.data}{a tibble} } \value{ \code{group_data()} return a tibble with one row per group. The last column, always called \code{.rows} is a list of integer vectors indicating the rows for each group. If \code{.data} is a grouped data frame the first columns are the grouping variables. \code{group_rows()} just returns the list of indices. } \description{ Grouping data } \examples{ df <- tibble(x = c(1,1,2,2)) # one row group_data(df) group_rows(df) # 2 rows, one for each group group_by(df,x) \%>\% group_data() group_by(df,x) \%>\% group_rows() } \seealso{ Other grouping functions: \code{\link{group_by_all}}, \code{\link{group_by}}, \code{\link{group_indices}}, \code{\link{group_keys}}, \code{\link{group_map}}, \code{\link{group_nest}}, \code{\link{group_size}}, \code{\link{group_trim}}, \code{\link{groups}} } \concept{grouping functions} dplyr/man/slice.Rd0000644000176200001440000000433413614573562013565 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/manip.r \name{slice} \alias{slice} \title{Choose rows by position} \usage{ slice(.data, ..., .preserve = FALSE) } \arguments{ \item{.data}{A tbl.} \item{...}{Integer row values. Provide either positive values to keep, or negative values to drop. The values provided must be either all positive or all negative. Indices beyond the number of rows in the input are silently ignored. The arguments in \code{...} are automatically \link[rlang:quo]{quoted} and \link[rlang:eval_tidy]{evaluated} in the context of the data frame. They support \link[rlang:quasiquotation]{unquoting} and splicing. See \code{vignette("programming")} for an introduction to these concepts.} \item{.preserve}{when \code{FALSE} (the default), the grouping structure is recalculated based on the resulting data, otherwise it is kept as is.} } \description{ Choose rows by their ordinal position in the tbl. Grouped tbls use the ordinal position within the group. } \details{ Slice does not work with relational databases because they have no intrinsic notion of row order. If you want to perform the equivalent operation, use \code{\link[=filter]{filter()}} and \code{\link[=row_number]{row_number()}}. } \section{Tidy data}{ When applied to a data frame, row names are silently dropped. To preserve, convert to an explicit variable with \code{\link[tibble:rownames_to_column]{tibble::rownames_to_column()}}. } \examples{ slice(mtcars, 1L) # Similar to tail(mtcars, 1): slice(mtcars, n()) slice(mtcars, 5:n()) # Rows can be dropped with negative indices: slice(mtcars, -5:-n()) # In this case, the result will be equivalent to: slice(mtcars, 1:4) by_cyl <- group_by(mtcars, cyl) slice(by_cyl, 1:2) # Equivalent code using filter that will also work with databases, # but won't be as fast for in-memory data. For many databases, you'll # need to supply an explicit variable to use to compute the row number. filter(mtcars, row_number() == 1L) filter(mtcars, row_number() == n()) filter(mtcars, between(row_number(), 5, n())) } \seealso{ Other single table verbs: \code{\link{arrange}}, \code{\link{filter}}, \code{\link{mutate}}, \code{\link{select}}, \code{\link{summarise}} } \concept{single table verbs} dplyr/man/join.tbl_df.Rd0000644000176200001440000000721513614573562014657 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dataframe.R, R/tbl-df.r \name{nest_join.data.frame} \alias{nest_join.data.frame} \alias{join.tbl_df} \alias{inner_join.tbl_df} \alias{nest_join.tbl_df} \alias{left_join.tbl_df} \alias{right_join.tbl_df} \alias{full_join.tbl_df} \alias{semi_join.tbl_df} \alias{anti_join.tbl_df} \title{Join data frame tbls} \usage{ \method{nest_join}{data.frame}(x, y, by = NULL, copy = FALSE, keep = FALSE, name = NULL, ...) \method{inner_join}{tbl_df}(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ..., na_matches = pkgconfig::get_config("dplyr::na_matches")) \method{nest_join}{tbl_df}(x, y, by = NULL, copy = FALSE, keep = FALSE, name = NULL, ...) \method{left_join}{tbl_df}(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ..., na_matches = pkgconfig::get_config("dplyr::na_matches")) \method{right_join}{tbl_df}(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ..., na_matches = pkgconfig::get_config("dplyr::na_matches")) \method{full_join}{tbl_df}(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ..., na_matches = pkgconfig::get_config("dplyr::na_matches")) \method{semi_join}{tbl_df}(x, y, by = NULL, copy = FALSE, ..., na_matches = pkgconfig::get_config("dplyr::na_matches")) \method{anti_join}{tbl_df}(x, y, by = NULL, copy = FALSE, ..., na_matches = pkgconfig::get_config("dplyr::na_matches")) } \arguments{ \item{x}{tbls to join} \item{y}{tbls to join} \item{by}{a character vector of variables to join by. If \code{NULL}, the default, \code{*_join()} will do a natural join, using all variables with common names across the two tables. A message lists the variables so that you can check they're right (to suppress the message, simply explicitly list the variables that you want to join). To join by different variables on x and y use a named vector. For example, \code{by = c("a" = "b")} will match \code{x.a} to \code{y.b}.} \item{copy}{If \code{x} and \code{y} are not from the same data source, and \code{copy} is \code{TRUE}, then \code{y} will be copied into the same src as \code{x}. This allows you to join tables across srcs, but it is a potentially expensive operation so you must opt into it.} \item{keep}{If \code{TRUE} the by columns are kept in the nesting joins.} \item{name}{the name of the list column nesting joins create. If \code{NULL} the name of \code{y} is used.} \item{...}{included for compatibility with the generic; otherwise ignored.} \item{suffix}{If there are non-joined duplicate variables in \code{x} and \code{y}, these suffixes will be added to the output to disambiguate them. Should be a character vector of length 2.} \item{na_matches}{Use \code{"never"} to always treat two \code{NA} or \code{NaN} values as different, like joins for database sources, similarly to \code{merge(incomparables = FALSE)}. The default, \code{"na"}, always treats two \code{NA} or \code{NaN} values as equal, like \code{\link[=merge]{merge()}}. Users and package authors can change the default behavior by calling \code{pkgconfig::set_config("dplyr::na_matches" = "never")}.} } \description{ See \link{join} for a description of the general purpose of the functions. } \examples{ if (require("Lahman")) { batting_df <- tbl_df(Batting) person_df <- tbl_df(Master) uperson_df <- tbl_df(Master[!duplicated(Master$playerID), ]) # Inner join: match batting and person data inner_join(batting_df, person_df) inner_join(batting_df, uperson_df) # Left join: match, but preserve batting data left_join(batting_df, uperson_df) # Anti join: find batters without person data anti_join(batting_df, person_df) # or people who didn't bat anti_join(person_df, batting_df) } } dplyr/man/distinct.Rd0000644000176200001440000000354713614573562014314 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/distinct.R \name{distinct} \alias{distinct} \title{Select distinct/unique rows} \usage{ distinct(.data, ..., .keep_all = FALSE) } \arguments{ \item{.data}{a tbl} \item{...}{Optional variables to use when determining uniqueness. If there are multiple rows for a given combination of inputs, only the first row will be preserved. If omitted, will use all variables.} \item{.keep_all}{If \code{TRUE}, keep all variables in \code{.data}. If a combination of \code{...} is not distinct, this keeps the first row of values.} } \description{ Retain only unique/distinct rows from an input tbl. This is similar to \code{\link[=unique.data.frame]{unique.data.frame()}}, but considerably faster. } \details{ Comparing list columns is not fully supported. Elements in list columns are compared by reference. A warning will be given when trying to include list columns in the computation. This behavior is kept for compatibility reasons and may change in a future version. See examples. } \examples{ df <- tibble( x = sample(10, 100, rep = TRUE), y = sample(10, 100, rep = TRUE) ) nrow(df) nrow(distinct(df)) nrow(distinct(df, x, y)) distinct(df, x) distinct(df, y) # Can choose to keep all other variables as well distinct(df, x, .keep_all = TRUE) distinct(df, y, .keep_all = TRUE) # You can also use distinct on computed variables distinct(df, diff = abs(x - y)) # The same behaviour applies for grouped data frames # except that the grouping variables are always included df <- tibble( g = c(1, 1, 2, 2), x = c(1, 1, 2, 1) ) \%>\% group_by(g) df \%>\% distinct() df \%>\% distinct(x) # Values in list columns are compared by reference, this can lead to # surprising results tibble(a = as.list(c(1, 1, 2))) \%>\% glimpse() \%>\% distinct() tibble(a = as.list(1:2)[c(1, 1, 2)]) \%>\% glimpse() \%>\% distinct() } dplyr/man/all_vars.Rd0000644000176200001440000000224213614573562014265 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/colwise.R \name{all_vars} \alias{all_vars} \alias{any_vars} \title{Apply predicate to all variables} \usage{ all_vars(expr) any_vars(expr) } \arguments{ \item{expr}{A predicate expression. This variable supports \link[rlang:quasiquotation]{unquoting} and will be evaluated in the context of the data frame. It should return a logical vector. This argument is automatically \link[rlang:quo]{quoted} and later \link[rlang:eval_tidy]{evaluated} in the context of the data frame. It supports \link[rlang:quasiquotation]{unquoting}. See \code{vignette("programming")} for an introduction to these concepts.} } \description{ These quoting functions signal to scoped filtering verbs (e.g. \code{\link[=filter_if]{filter_if()}} or \code{\link[=filter_all]{filter_all()}}) that a predicate expression should be applied to all relevant variables. The \code{all_vars()} variant takes the intersection of the predicate expressions with \code{&} while the \code{any_vars()} variant takes the union with \code{|}. } \seealso{ \code{\link[=vars]{vars()}} for other quoting functions that you can use with scoped verbs. } dplyr/man/new_grouped_df.Rd0000644000176200001440000000240213614573562015447 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/grouped-df.r \name{new_grouped_df} \alias{new_grouped_df} \alias{validate_grouped_df} \title{Low-level construction and validation for the grouped_df class} \usage{ new_grouped_df(x, groups, ..., class = character()) validate_grouped_df(x) } \arguments{ \item{x}{A data frame} \item{groups}{The grouped structure, \code{groups} should be a data frame. Its last column should be called \code{.rows} and be a list of 1 based integer vectors that all are between 1 and the number of rows of \code{.data}.} \item{...}{additional attributes} \item{class}{additional class, will be prepended to canonical classes of a grouped data frame.} } \description{ \code{new_grouped_df()} is a constructor designed to be high-performance so only check types, not values. This means it is the caller's responsibility to create valid values, and hence this is for expert use only. \code{validate_grouped_df()} validates the attributes of a \code{grouped_df}. } \examples{ # 5 bootstrap samples tbl <- new_grouped_df( tibble(x = rnorm(10)), groups = tibble(".rows" := replicate(5, sample(1:10, replace = TRUE), simplify = FALSE)) ) # mean of each bootstrap sample summarise(tbl, x = mean(x)) } \keyword{internal} dplyr/man/location.Rd0000644000176200001440000000106113614573562014270 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/location.R \name{location} \alias{location} \alias{changes} \title{Print the location in memory of a data frame} \usage{ location(df) changes(x, y) } \arguments{ \item{df}{a data frame} \item{x, y}{two data frames to compare} } \description{ This is useful for understand how and when dplyr makes copies of data frames } \examples{ location(mtcars) mtcars2 <- mutate(mtcars, cyl2 = cyl * 2) location(mtcars2) changes(mtcars, mtcars) changes(mtcars, mtcars2) } \keyword{internal} dplyr/man/band_members.Rd0000644000176200001440000000166313451046652015100 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-bands.R \docType{data} \name{band_members} \alias{band_members} \alias{band_instruments} \alias{band_instruments2} \title{Band membership} \format{Each is a tibble with two variables and three observations} \usage{ band_members band_instruments band_instruments2 } \description{ These data sets describe band members of the Beatles and Rolling Stones. They are toy data sets that can be displayed in their entirety on a slide (e.g. to demonstrate a join). } \details{ \code{band_instruments} and \code{band_instruments2} contain the same data but use different column names for the first column of the data set. \code{band_instruments} uses \code{name}, which matches the name of the key column of \code{band_members}; \code{band_instruments2} uses \code{artist}, which does not. } \examples{ band_members band_instruments band_instruments2 } \keyword{datasets} dplyr/man/common_by.Rd0000644000176200001440000000041013614573562014437 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/join.r \name{common_by} \alias{common_by} \title{Extract out common by variables} \usage{ common_by(by = NULL, x, y) } \description{ Extract out common by variables } \keyword{internal} dplyr/man/group_by_drop_default.Rd0000644000176200001440000000121513614573562017037 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/group-by.r \name{group_by_drop_default} \alias{group_by_drop_default} \title{Default value for .drop argument of group_by} \usage{ group_by_drop_default(.tbl) } \arguments{ \item{.tbl}{A data frame} } \value{ \code{TRUE} unless \code{.tbl} is a grouped data frame that was previously obtained by \code{group_by(.drop = FALSE)} } \description{ Default value for .drop argument of group_by } \examples{ group_by_drop_default(iris) iris \%>\% group_by(Species) \%>\% group_by_drop_default() iris \%>\% group_by(Species, .drop = FALSE) \%>\% group_by_drop_default() } dplyr/DESCRIPTION0000644000176200001440000000341113615060710013110 0ustar liggesusersType: Package Package: dplyr Title: A Grammar of Data Manipulation Version: 0.8.4 Authors@R: c( person("Hadley", "Wickham", , "hadley@rstudio.com", c("aut", "cre"), comment = c(ORCID = "0000-0003-4757-117X")), person("Romain", "Fran\u00e7ois", role = "aut", comment = c(ORCID = "0000-0002-2444-4226")), person("Lionel", "Henry", role = "aut"), person("Kirill", "M\u00fcller", role = "aut", comment = c(ORCID = "0000-0002-1416-3412")), person("RStudio", role = c("cph", "fnd")) ) Description: A fast, consistent tool for working with data frame like objects, both in memory and out of memory. License: MIT + file LICENSE URL: http://dplyr.tidyverse.org, https://github.com/tidyverse/dplyr BugReports: https://github.com/tidyverse/dplyr/issues Depends: R (>= 3.2.0) Imports: ellipsis, assertthat (>= 0.2.0), glue (>= 1.3.0), magrittr (>= 1.5), methods, pkgconfig, R6, Rcpp (>= 1.0.1), rlang (>= 0.4.0), tibble (>= 2.0.0), tidyselect (>= 0.2.5), utils Suggests: bit64, callr, covr, crayon (>= 1.3.4), DBI, dbplyr, dtplyr, ggplot2, hms, knitr, Lahman, lubridate, MASS, mgcv, microbenchmark, nycflights13, rmarkdown, RMySQL, RPostgreSQL, RSQLite, testthat, withr, broom, purrr, readr LinkingTo: BH, plogr (>= 0.2.0), Rcpp (>= 1.0.1) VignetteBuilder: knitr Encoding: UTF-8 LazyData: yes RoxygenNote: 6.1.1 NeedsCompilation: yes Packaged: 2020-01-30 15:38:37 UTC; romainfrancois Author: Hadley Wickham [aut, cre] (), Romain François [aut] (), Lionel Henry [aut], Kirill Müller [aut] (), RStudio [cph, fnd] Maintainer: Hadley Wickham Repository: CRAN Date/Publication: 2020-01-31 17:20:08 UTC dplyr/build/0000755000176200001440000000000013614574175012520 5ustar liggesusersdplyr/build/vignette.rds0000644000176200001440000000051213614574175015055 0ustar liggesusersRn j٥ӭMe/d{E-A:{`l^@\?'re 73RA3\bѦoDXTe- 8sH{ -JdO k#fVic 2O4q́-}oVkPhawچqٻB!gMjfK뾇Ƒ dHv?1dplyr/build/dplyr.pdf0000644000176200001440000142706113614574165014357 0ustar liggesusers%PDF-1.5 % 2 0 obj << /Type /ObjStm /N 100 /First 804 /Length 1027 /Filter /FlateDecode >> stream xڍU˲8LZ/KJe5Uߙl6zb0csZC2)rw뜣~Ȳ Id’P$LNBXLG)H|%%I`HNJc͓r03ҙ"Hk<4iHY2:I 2F$fxsD{y=IE"Ac*YF .[!}MN:sr瞜e9@"HZ򐶎|n -!  <7G@.hh#!(CUD:4ga8JFe+ZU(9NB%5v]}+ c< #9hnX݀<ϑ (k`¢4ֲ<1 ap>hp\,jFXݳ#\xn"IcH2J`?YeUbX|ܤ&Ζs0bP$%/09)c@* f'c{t e:hԊ (k.q)Ps8ʭ~?{WC/Чa]S~-B>Vgm).}9?ϲC]_z]B}!7fc˴Cݱ8 m8\;Xބ7 v>lro$"ZZ&!:Hl`!6OۄCir)83?0qF7{ .9%hMn;5{dpn{[,),:cx&A7'm1 TaOȳ}w/#_LE6 ۲h ͓uٟy쮪rE]ctp Qom3'- c/xbs ] 7B4܅ L|݃G"Cm>3bV"M[Wflc86'9(XiMTSD)4WyT]/9rwy.)DڇЅ ;[ywv xo"akþ2x-'׿z_kŻixbr݌lK endstream endobj 301 0 obj << /Length 929 /Filter /FlateDecode >> stream xڕVMo6WV i")@ ltERw/eFf-KIeHyDҋ>873oA\@i!` ``0PE1 y=C^h'4wה'S5Rܙ KLCī'acp>0İrf%A2YgmzXk8<5PN_(68D.sn|>o|/Dwl~^ߏt Hug 1q 4V4FNϖԪ YG_.8gK:/,/-!GwqxX 7`jeO%PWRVw!asJgN}B *@̌}wWl/(K؉;F0Cʘ=7oӇ.VA 9BIcԔ%M ;-&k6^BE|TnˉdjNZvNrZ#K9J@J@-[u(r^j_^wGԟO0am辦7wVwn LEQQ4eml&㡒FMb#&v=wŤtg@v;u{)Ceŋ[M71Sf> stream x[[6~ϯ ѽ3)N`cg'8N/Ku66~صגΑwz zOGfOgU{QJPVHlOș&rwyQv;],RU: 6)|<_M`v&|OnڟӔS J7>ӥ^"%wq1b,Td4է Q6e&>YcU}H[.be4m<] j,J.d1X5^D]!b (v"Fl<#JZ[8ݺ0q6THVE&6ՠھwW4R=U@LMq(0?\3`&LQks1{v}*y蕐^fۊ~ܱ{i)Zi,4 :( $TNQ^-azpnkbN$vo%JμPԬmA}25TȠjm( ]~݄nq<6q(ܤ?swQp; Ҧ[PKdv RC>X8a@R9 >uG"!c:5[{C0}1x=: Zb k1C@ѪS-  Rb1Ŭ Io &_=_i+[1os^Mޜh=?]<"91 e1lq>p>TW!N}V{7T`[2JbmQաFD+6}ҒT\+:OW +wR \yma~h ʪD endstream endobj 418 0 obj << /Length 1409 /Filter /FlateDecode >> stream x\Ms6W(X`ؙܚɁiGBuﻠdGR()ڍq"g . <ݷa:b-hGI!8hd7E.'.@5HFj=n&դPn<] ݴuy8x˅x4aH>{P6<tӬn_.FG &D,EϦ*;FuCLq<߷(ȭ2%c/41p"3^} Xsnj hqX!q0Kǭ3)`&K^ ke-X0kZhJ5YB{\F(Q=.J}k #J{ji;Z"woKHң-+ȬeXu̪>IwF .HKhv pZ2aœ ճj'雭39T?ti4R3RIi۩` γMB'4wwp0l"^\h1˪7>DE;mْ96=Jeh^*Yō% =33ĻS2Oski ʜz@:8%XVnoÝfv4 }ߴ'kFRUkWMU7}ɚ$tλA57rG^uIgQҧVH=ַ!UBME֦\~-ofyUlӬ"Zfl㣈Y8'r1>)9:ti>n&Zr\ ɒP_لCC.՚ZdXZiYΥV6v z۹p{4ӾàPVL9~Ph., Pf׬Ϗv! wז](-taXH@dfծEXum_K#SŢlr8ކls/+uq)9,w5$qQZwz*_՞#WAD?O~.NDzD?i1E.XRնDN@\>:?}t>TY&';i/R/uNRc/߼v3*'ߖU7h!r?ۀ endstream endobj 203 0 obj << /Type /ObjStm /N 100 /First 849 /Length 2004 /Filter /FlateDecode >> stream xڽYo7~_(6];pr`˺T-$}I׻Wk?>?;o.&lOdA(BFC>@CQPP8yH>`LP1av4ч g#L( L916z shb$p1O&2MJlvY֕Z`}&3`RŔ 1Bb~e~޴V덌X=^\,XAKw Μr)Yfa>-f~I|[o]ۮ,nW߯ 5ZP(dKA*fZCE{rtr ?k_oov wyR _lx^E|,!@ZltB:/W?7o7rj>4</~7i׭/o±Oi| F9 m,iv`iw͑bG$ $\X'w}B.8%f/v=}o׿ 2dfrKum~7rJ;~Qm&sak~ܮ*wO) ϝ2`dAeTTfEe$I:ϫ>ϫ>XcǪU>V}X n$zu? 6G!d CRf%ˏ8=fޘ!wݴrb%a8p{vAa8`ف-^y˅O8 9y ܁9oͅp2„Aa,ӯ¡*ÒJ4^r.Tyb&tE~&tu?Q ZZZZZZZ)ZP):hAhA+ꫪꫪOle]ֲ.kY7tbHRUʠ2L*ʢRWWWWG%3!>Er?zT@B#scc+,;Ve<6XZgTN[*nي0rO{ RޱFKl);<ӓ'󣌼ibd/J7T?T0m\z؉t<71DȦ* endstream endobj 464 0 obj << /Length 1900 /Filter /FlateDecode >> stream xڵXݓ۶s/&&B H+mhH$(R\_w Hc{l. 6/zs<(XlLHd*fHu&w7~RH9SJDz>T6:"EzkpEU}us8j$ V7` TcsITT/~>)I*ƛEh@+H 6*kM/Ď ll8'J_1d6‰$О6gsΞ?yNe7gH(S't?-4P2$9ʵyc#kwLSW9 i%LOt/iGjͰ+')VAZӶOT,CKykB]B-D;IGI3n=YnG[u;K.cIXsP=)Ҥa}-3VMmU7KwfR<7׿|5$9jjlh~z3B))+hRJS[KW5=h mBQr D(۪Yޱb3hMf031ey`Az}V'u݂6 M;/8~R>d d-OsH8aZoWL"Π&?bXR' n]N1t$B  yrdw.R=f5~nӷ-RO#MYR܁TyB p*z!i3 E?S=jr \t~;Zw,h˃;?(hJR?_ͪ#F7nI[7{v]DQܸ8{b.[p;3(?C!$0D-{T#S񐀘[V$aI.? Ad"n|xpew3 ck,hϔ~PO4_ Y@eΒl(TBWI?6mS!I &A mlت dO3Y> stream xW[o6~Ї@ERahfX1 X"-&[.uwC).= #"|;kw~Of7;1C:C}p:2I3OnO7 CJ) %,\n'>N : #YuFs;sL'DxS}nuv0̪[wf7Tz 1'q˭RSG}W`F9!R& yzyb8 6##P/&R%;#I#ں,ǒYzJ\?(ey4 1$FU`:7͂,3 Mf 34O=EYcͺQRK< cBͲjT50r-B϶w s0߼)I(BXtyYH(+ED{JJ(2s-tI}ucs>rP#)(@iR'v46I9xϿ% )FjYf: /bSG(svr A@8'9 cB/wIeQ2$~tj-<@c_lU I{!,Iqai6BRL#[uHE^FHP:Lzʉ/mU) PkKHdÓ%3Ly'J/DAk AsdfŬ=X>EԻ:)ת.T-[R-(SU{66j;NWW߶ !m(l=ij=e&) :yRJC#,hH0FdL L- *Vuu\αE3]%CHM ؖ4Xi⢅;n~bOJEN N a9DD"`QzYC E#ïTD)I`3R$6Mbm! |lw6  _0OD^5Rd`BI)+Rgsһ(OL[e,OJ'M‹M ~J[ ?гu~D&Y.8Jua5 `vobP:ZUh Pnry-_0U RJQ;Rwlזqr6 z|#2tϐ1ѼQOZ3L^mMjdP§ȢNzC|Jq]=2) ="ۭdT ܘ*|9ll.u"MJ]NT)\yYs=){5T9]>9=WmUْ=c=XWp- =(7vrPt58ʂl&[s) ϒfK{E3}2΀Y[`ŧU$ An^U dt>As#?H$|(+^&em5{`ZX6 |14Wj=X؉v:[VٕAwz lj@ᣲ/EgF endstream endobj 505 0 obj << /Length 1627 /Filter /FlateDecode >> stream xڵXo6_!&5+~!ŚaÀabѶ0Yrݑ"9@x:x_tmuv9{sĒIoh.ɀyon80(&0%hdNx XpI' DF퇯0G;zycI_$ˬc:k˦!.w4[uQ)PhA=6]S'MBUӟ0xğp\NaϗNVMY!I<'7yANuNVIa'ԵNr eqЕ.WLgwwG{<$Bj79R؄ woXwDJA t$(Q`n d'!c- 1e uklg"1&v;( ӊ!T:ׇyܑ@~d@Evp,TPe^($J}QTŏju((uoo!mv˭2&-\ oH oɻϚ _HASbmǓhw8^ŸxosaFz[kTF*Ѩ}bGEcA&YL9>Iyn<褂`2l'1/p퉲juiws7E}'z!AEUe_gJ (D-- |)uzݧn4 KIz0c8P[7[Pߌ6΅JXR,m,ICF-ɴۘHͱ?fjZ OilI-HнY,YW6#ir4xB~ 2# FPZyUߋODq4@G甹@gGx9]~λ|'VOea0B>Mc\W܀^;yu&Ev\Cgdr^R|YXҘ:TY jT+`9&^,LD  q`UL~0> stream xڵXmo6_!`( 57ۀlh{Zw,ю6YrE$OtQHWz2$¿.KZE#&^0y21F/{%*Zɕ J_i2N@(H (e0M$I7 pgr\]5D p<\nEyrA5?bpz(%_TH053u^c$ m%{hBnZ+$^RZ&m,e[P/pfS};$!Mt^*ҕM2rήQ׍Һ+B&_uij]Fh,\aG=’W@HD3!z4 FEt駽CwlŜnr|!,Ƚwe^d @QdeSo'Dί ,Z}9;٫7/+Ϧ20eBFmiq2I;[e=8 Ph hľAY7 LNh]4.Uu'&T2GO@JQG_\ٍd xWeX ۉ ;֠$~TkW},D_ W/Ӿ,2xc39,-~ͳ[cEw9$B8 3@Z ˀF "|6 6f E.˴Ŭ5[QUV$~ -8$0dMhueH,}0(.em=zIIbOQ Q~/bN}L TepjuG=5n xd2f=&v!w\a#3Wl|'6@Tw!1ޠߤ\#m`'7>b챇9C?w ?8mҵKWHy_<f>nc w.~FrhP 6c/5j=P8 58n8 ifE,W\06 0LY0nN3%?0W)`9YfvoV(ۋɖ@-JUxX8DX:l,ڦ3SܡS 8gPI8:AXYup<":xm1}zF^nz $x&T ,¾_(lŇ(+k_v`lg߶ݷ2>"zVY(K1Unz..pIns|KvOѕ0 endstream endobj 427 0 obj << /Type /ObjStm /N 100 /First 889 /Length 2358 /Filter /FlateDecode >> stream xڽZn}WU}8Y  $Zf)ˋRY6G%FG5=z{8qb1.1u&$L 7D'\Xg $PH* %Rd( ^S0)ƓF3޳wRD+6;b|@ *QȸȆ}QaX< Š bB 8R(HTCPHa@zD2fOBR0D<^B %BNT>b1$;jw<. w𶠿$੨#oS@2M=xEgƏC4tZB14=Ơw0K,*SLL;PfT 3{]%Bey"5l<`:I!`ip!V MV< #0gœgSLfV9\$^aάց>5w(j)bsvjxWH$pS"<4 ,#:pEjvh\U.$N?yX,7|lqlWӽo欽ؘw@jP&xk9KR/iޘ˷KӼ4>NZ+ ՃM!GK1 `(1DBH">)V#!d8G b= \'szRԇ͈5I1 )ny@\qTmtխCH1Ddg=,i1@L2!ɖL1H4~϶pQ,@>WlQ:`l9"O>QQZpX?Kxڒ{SQ[ S9E 'KxPEzZ SYE(O{`(%3Qb%@Ӄצӻl,Ggj*nJ BvCMbDm(b`J) Cc$7 NQgm0)cE)ϋ|Fr|ުRSX+~W"1/0Czxi^|eKeI^.6k4]w;qݭ?MS'+LZv❚x*$*}s%ZY٨U^o dnvnw}z>c(:J9la7击yܕ%N铽^'ezJBߞ;!!  G-AXC'!>V50#ؘ {D0MW;K?w[ R -r8a4e(#q3M(a%fT37rfBJzVBK&W "wJ~D.FQc؏q?cՒ`@? M@6IΑcފx`Z*Z#HB^ʀ~x]n899 ݱmTAX;I~&6b3]q`BwY;MPW9ޓ͗yh&tJXd"Pw=9Y-^X~p^Tv' uEϐt zZ{8cE6{p^ hQM7v怣+=8$X?!.j<5%T^jn4A endstream endobj 562 0 obj << /Length 1831 /Filter /FlateDecode >> stream xڵX[F~_['saDCnVJM*"pҼ\0,mY3Ü9Az[Oz//~]_<}yx덧03"Z_1'M!#dqӅ7SGF>y{eXő<-(Q齾%qR hIYS1p 1ozy'ŔPZat|=%#muH{q0a<ОЄ>p :=_`QK$hAKó  O}՞ ??'u\y3Cc@Zp&@"MZT QSo&wtWonvIrEן6X K.Zu>V$YH5ɩwJ[O@С蚪ny,ihS'Kh:9։)fAZrFfqU|#RQ@G ԐN'vƀ `ȓ4`Wb onPwMUPY^-S|)ڛB‘ZҶw o;^GBCw T=ۡ -;m B~\pDL8O@B1ڈ`:h'\#Ջgć.'p:VͱÄ%, `c2g>z)p49I j)-5`O.me;)A0XKyf)Zb(h }/Ur'\#$5n08Wj_jQ 2#ͪIκZA7P]$p鮌Qy>|OKi(!%a&fwG?7s_Dj{~և~F~T~ݴoe`LRmub}PXNmh1Z@`qYCTӅ DáXxVv(`%*;RvyMNuޅЪw LO(E n:I[*\LcV5 ɊX[]!\qc&pfp]"6hw i ;|suu_#c`}^`Lפ1">^ Ћ3ufCoxfAYI$(-*gɣN׷oX/7l+bEtRFU8.:ouWOF,,V(h;O|Nt'f=wbXt1=}Qwۂ̯Mz˝y]  endstream endobj 577 0 obj << /Length 1265 /Filter /FlateDecode >> stream xWnF}WC)@iZS+q-!)G4)ӒS;p2)rv̙#,~>zuXbT& 1.%1&Y>%lP5[?y>4"`'$! "hxE+Gd.kF'UB蟡El<:uW  ,&8N6qQ2 Yfcoܧ>HzBܘ„W$8mOWax .:/A$1 o6cARWp;2R ~08n++f1*ju@vjH%[XB jԈcÕ"ͺtu.LsgP*!"9؁7+Jo*/ jWoB!pbJF#Oǚqp@ &za;NE. Mnq8b<|3p2"v٫n8b•eBD$V6_) ! Q"續ٴ +[yK7c!Sܺz߮TicJ1zHBG+ .ikf|9 3+W]mxoK[u=%/C 2N:KZ0Pά{xw.BhDcmȗ0COg9 N?Ka cuXlnjUy@_RPMpC# azx~&\@Q EbG@t! )L%Q}pquӋ2_gMm2~ -+.ZM},*z1(~֠ 溂s+fCأ2QNDcbY$:*Qf]^A#:i|EC:TD),DN$IPT0E!F3y|[Nn::i*{LRbmGhq0= '% 8?Hbu[ˀ nxxCwC]eO΅'~,;L6=\Ėޱk[r;Vٻlߧ@_<3/N 1╭|71V` Uoq endstream endobj 595 0 obj << /Length 1657 /Filter /FlateDecode >> stream xڽX[o6~ϯЇ@͊")QЬɰإq"-Q'MwIɒ#{ "o/7KHX{4G,٧k;I91{iᮋz<H3#.q`'%һ7[K/$L`Tx7ZF0 ǚ__5h8\@ Ny0I+ի\T]n`UZ; !Zѩp7diujBO윬9"J!TvYܮvKW V,/o+8IןO>FF,s|2bSZ’;oVO: CA"fWjByd5$ z8r0|; j6,k!j5Smm63Ԓ(cDJEaHhY>Q""DځIpg&cښ P_U:+؜sSk]j֋(w,H D0:d\,ɫvK[L`*ջF`^G}%K=h\g  98\91?U'|Gz"b$HbМJhp|`Ʉg WՏijջf&ݖbKZD@YN0fX/,d1^5$l_GDuZ렀Ube vIV;{.8췟tQg--|.ibaH~wp˱8Bs!;䆎) wMҦܑ /.OkuqI#HD>n'%nB}I8>ЪlJCe^UK;^.%`hɑS Խޜ6q{$Sr“>2?]=V':PM s:МaecRn#B}DBng[Nra 4oʮB|j#Ɂ#wZ5*qi{dξt}KWͧ+ kP%ɘڥr:ٺrU4[ 綀?< akfcrnIMa0_vڝ_o;zZGvEp$j۳yq ./aP㈟1o/@cF\>4D- / i]=$(/EBjA^,22!sFҚ~p1뵽똱ޑֲLNǺ(]foں;< ({\s0r i:{Qv[BrV83T-k.cX+ou p]T($IG6&إ_JPh:cHХ@|'&sKL;3%|׳$LgnUB'ܹbGNh%4twnt%Sҷ Fu}aUcbMsR! endstream endobj 610 0 obj << /Length 1422 /Filter /FlateDecode >> stream xڵW[o6~ 1#Drk6k:(Mڠm9'IwIR8y|WA5{{1;}y`Y\lE8PqD$g:. ô i9p^TED`Pȟt /5.m,oFz} U0)VbJЀrMtlE9,XQƊ#F'-5ܝM[lᐚDUC%7DCL0{-bNCs'4l"uKMl9u}mg":u(̪"R0h.|EhpSnbfF`PpPޢWB]Yd*-Zp&Ldß .PZS+ BvBtk-0 A:|D"f+LEHZ#i#}<-'u,~p]D&cH@0$7AAOҟjD=RR˴H]sM/2B`=Vb# pud(둬noLi=$*9^WIYV]ɁnXZv_6)vy:MtǢ `J>+,(R|LM'Sű %x݇.6LT,(@XT0i{IzšRå|o#Uha7pҹnQvnSmv(dNJ8;QѨzcPPsYٮͪ'zqh} JBЍ Ͷ~!]MZĈT}oy"MV~qí[}>j;рPFqamӵs*DȖ?]J7ꕻ[\] \5빌C[@'eշվ\' ȃw#k;Ũt+e>ʏK80oiQVuaml2$ۯ~BQadJxK,0 y8,3y# XAn, cn1DkƳdWE e]wxFa,(Ga8vvXJvu-dU4.i۴>HNgܺ"9Vd:Yoƍ~! XON'?N endstream endobj 628 0 obj << /Length 1772 /Filter /FlateDecode >> stream xڭXo6_!`{I}PСM= lbP$9*K$';ѱl%n t:݇x7^ཛr9;0^*XғA t{IH+R->^z~N* b)p,`2JI^w7u,BzϗFD&!ABJbT} Zϗ].{/o eОҊS Ei:6q}C9jg -հ*;b^/|QV dX5΀7b]-InuA=y|D<iN:vd,O؅%- $b_)5ZW ܢ릧-YW\Y {ZlHGn gކup & _>2kדA& uU{X:{b-Dbd!2Ho:m_ U۰e Vg @14-I7 ϭGW.у#k 2mq3H,8J -dTbH}"}kAlY['ԗ%+ uDn]V(1|T|Nt_BF\cDU|oi T'x(*cH# )wYkl5Jv@k:o;"HNHM$] ) @󉤔GmD@11Nj!r[jzHr% ҂uH"+:dܸPia;XS_QlQ3i(=@JR/J׳W"+tj;u)P T9z&xQ :V(y ;wbZBVeg% V=T Z WRĥD؟ !)FA>)vX _<\>%iڣc|HoSń[U9el_~ޖMε2@Ctj A~)iH%D"8Vo!0y.aޡa^NaN&KE9%T-qY#s|*RHWKz4smc$Pjn7@ A&jdl1:qkƶ=3~*DRa=!D9!&2 JC¯ *]LO?hm)BI[?eE4a5¶ swa؃VƆعQa7#͍8&C 3.Cu=m+9S!,bR*z +zlyb= `0ؠ,|iG 爫S46~օ8k/fmsuNƍl˧?Pn@`P@B70ɧzȡ _W1>f.ܱᮝ>&_ɣ ]r@k["$pzO4H1=iWSau^XP؅fUjNļ);{s5Z\Ӫ endstream endobj 639 0 obj << /Length 1464 /Filter /FlateDecode >> stream xڭWێ6}W(Eh6 @v]EZʔ:lI Z$53<3<3q7ɋׄ81/pK."4pE>E|If_'7 U 1V!ɗX#gD׎(QM>aL=_:$r0Q\΋מD P)<'!E& _&U lEk /ءrEG-WQ[#pQ#4,̥a#'P?ˆQ'-Jr^7eӤ%u)jh.XKA|L*6H6A2,fIc5,jWG5{LZZ*.8¬[DdVGH(|%ʊeW= P(:Wr@Ɏl.ף}Dޟ3HF '7LMQt cϲ59J͐,Oxٚc&#cSZM,gϞ< z?˪Fjn6ţ!@_{z ti#a\@¶Ez"+x6f ꟲFV V{/V 2tMi-1.BܖC+.l%3T f$U;vHي-1)uB0L v' ]øt#2ۍ1ă<VhJ[ASjW fp)NJvm"]JwU@Pׇl FrqMrWBM(E1>MWL6/>2K)9=0ӂ|y<^Lj&%k 0|Ӳ⛆}v_9Si/ryVdZ3/nǙM.' OK=|pcR-)A?9ʱ7#\IB *S!5 +jt#+u82liN5:B6:B{f61(SG}_oP.A N>}{T>F욕Ww7ZۛC {>H?}gW9 G],R<"39wCDnVi+2z 0w@?Q}5a.1AM%mxp'{ ]nu "12=SD e¹lUkS~7Z.E^@lh\=qP#oTDBV`cۜkj0@5[sQEH 4N5H#֢ JU(T cbئHu@!F 5_n endstream endobj 649 0 obj << /Length 1601 /Filter /FlateDecode >> stream xXKoFW J@M98:0 QzqVTeޙ]RhS 57߬e[K˶>FoGV \/fXu5#! (4JNgFm[^0ԥWۚG ,őUkaq,>~'z(=϶+Q(ԉ=fLBܤf+1oh8ѸjZۉIj-X4&42KHRsyҨ TѲ(By bHΔs>yL]45N<VѬ0w+A*Y#~PFs2cո⻲^aYgs\ulbU;JO)X "AIs8* 'pFbqsO36wG:yĀKv9f#慎9ɘBuHˢʪ`"J',)Xq@M7]gvT߾%0؇^6V>J-k]{{w,a,i"z{pGA~0?tjF@EQt*4H]/ٲq9L>%#AK;yI͆&2c%^~YWJ;vOK, $ x 3DY-P6v7I] Yh0"UQMY9 UЊ8MtMO)*ӧ[(Z"$0Wpѱ均^j8+*{ GD,pb|ǵGt pi$(n̏Ox^ZhwKM\gqB Zu MuUڸ\1?}x^ k'1}Ѐբր8A7pR/6G: an"a95N-E!$GtR}`!2TF]!( e𰂧u7=uJ#?95>z BZ׫W4>H84MËE@ӛ!{Yj' xyv'T,]%2Ibt=$k/IyMhȡ8V5@g- >\+*Alp2K/n96zR΅:{Py0pwڻ,Sa.dse]b(f %P>*HE3ZVc[jr:a2ꗖ:XmQ&9Ca`?/߃S 0F>ak*1?_JFg.ZO5#o4hSt_!8מKضwYJߑX-l)1$"y=W_.՟Jm*E5@2d+!=4wWα߭/Nf;#jT~(7bϟ*/-&k@ej~#LiuOֺ;453,F(Mr0"wW a~2%5@tCsy256ΆPVb ;m VYEw?30p endstream endobj 556 0 obj << /Type /ObjStm /N 100 /First 875 /Length 1546 /Filter /FlateDecode >> stream xY[S7~ϯ#8gҠ=AGm(^&p࣬|:,ɉZa];y`e>F xKZL7|6^< ==uDžYŧ^uMsDY7^.ylzxxѝ rGK}F3L%d2Ō}4J8ϴ|f,}1 _YǓe7뙄_ Ǿc/M5tX P;Ws7eb`{go'~~1]7 Gk7<3#@2 cT}ɺb|Up :Foj(Qww4; IPAMQ Qw]6ʿ\,ɫ{r $6պLǶmIs{`)c54bc J۰d0)WUVW*gb%Au$ mWqjG b>$VBy檻ew[쨴*6.PbASR#8E6083n;H)\`xFHx|ٔLFWfy#ڱ_f鐙^awHƍqyr~2z3ILR]*hQi&F0i `moleQ`mѾ |yϣmLGmh֣]/+HlB\Wc Gm`+u`8FՑ:FRQH23b9XN_C!1x)X. t#jޭ;v[/XNQbj㔬lyNy]Y=C++ endstream endobj 656 0 obj << /Length 1001 /Filter /FlateDecode >> stream xWo6~_AxB귂5%݊!Z-2Zmb2PRwmQb{؋IY>0!^ ~ ί}nyMvCC z"%;8z= D-ň B7&d4[ h^FJ@&>q՜ : v5DMXs~a(phǁ9^-5N3_4#6W3|ͩYv9i;hm8> 143ywm6AJGw7/ pODz+bl&2ZHp@2E䔀{ovOVs3y[<,%+K^ 0bb&c\dU`I-W留MYcLJ37R#=[\RYx~-guN%PNo`-e13 6^$_y]M8PjG$>eoڕwҋŁ2&[kֻɗ|j.M6IYH6ہbx΋(( yD`gG o,V*^U9^O.Wb)&X m[v9dl]i"+oQWJ̼.j *{tZ%le&Tr:ΙMVj7rn5YXysA+nA*/7?.W:ˊɾT5zOFX P.YvԪ5ȯSQQZGUԜȽПUۂa WY YP'C6P׎>]6NW;}Il t~=4@ -`ߵOC&MEh{dvf6E3߅kun$@xϏO ܜ͚Ҭ͇wVWPSki=A@E]\0D(b˃=aіm\jSgmvD 9tFI)O/oJ;Ooķ endstream endobj 663 0 obj << /Length 1615 /Filter /FlateDecode >> stream xXmo6_!d(f5+[ڤthKWtDd^~HJlqaC>(ɻ{Q\gΫяѓȉIx3_8u .SØ\1daHX1Z')E.U"Qs\y)cgx)D%ZV]껏'Su^+],)wLKb?>$z$F6Yi-:+ e(p+sdjPY*-`a{Pb7FaEh;$ SiQ;OKBQբU~Vœ¾>ڨ?k JfUm#JYQmdInjW{7x6zSk^?s[D 8g [e%7gwCb|sͶV>_e6H5 0nN!R#7g_niUAF5UU+RYY&ʪH"t[lb'JuOy>TsS""Z,\X}i^zr9-ă5͙J۪8_?ZL(p7 7IOA+.&Vz3MôߚΨvUez{qJb綅ܙv\ :R^<M43zj{f\w_hLuKŮ9}Ћ?՛1r><:%O C'Y>|t~`;v8$4s3zΏO=B.uU)R#'gQ6z$hWY#$啪͢(:бRY4d.ײO8 Qa( c@AEy_WUl7GWٗCd%k#`§QJR5S,k5] -Reҽ[ĵE>ozR$/*ƥ ;c3褤>'>Ŝ - 80pdd-o~1p>uۋ_fח7/.1ݷRSw,+WԎHeJe /e5dV3+:=v &" = .qdN2DC:jCٱon$U-$yZ6p^pe٤ّL{Sz jUn2æa[+YX+#S(Q<.8d".NN2 !,TpqMZmfJ*KTnl.UHTK߾9 sBOF9̰k{{?_Q,frf`0W9<鸀ihGcs eeӞy! w 9.3wq[ATM.,PzU~1m'6*E_(_\!> stream xڵWn6}W(^D ڇ--I]L;Be˕\;CZɖg"HĐ333$  ~x=:"I(R"(P%Rz܎b9z|'RF(S(1 :Fx9dMS=4Р]؋)"bn2o*Tj7SIiuᾥYIU Yz-"1e2v&Ɣ 4?Tg`;oZ$Jjzj4eW3+ߓ:A.L}o Q.y ލt8~._7v//]F+ ^m +ϪrûfZY6xe+_ON{4Yik<N8ݣ# ϋίGhЀ" ]n?`)2PD(`W{rA(ddnVDqk)Fc*M$c{T/DE#}CT7B EvC_eb5H j"t Eޚ0)|I.k?D"wL MTҮɎ,?ۂ|qz7+CA^nSX7Qת OfuTPa L1V@7 L8L_B%TE6C"5*M23cV߻YD [0@()%Ʃ50P/[UEYRHf<) H2&`ޞodaԄ9A͟5e+8Knbl m5lܑ>}& "v^Mdyp > 9x;+,U-)5l8.t XȈ"n%Y-j? uӖ59, X~iEz[[jm>wXÃUY/鯙T}/wF?5 ?3}Sb`Oƻ^%Wne>n)<`#dBȉ  endstream endobj 693 0 obj << /Length 1296 /Filter /FlateDecode >> stream xڝW[o6~:%E]m@&aC-Z!8 P؆; );׏ڣއۋIXyR£KJbzl}#IF$I@)fQ|11R=)#++a[y[Ƌ#ia^{O;}G >c$b^JS04% Iy/9x*}յfW8(W^,VG `O<&!XY'rIFh{ Um,ܱO~/}1_Y0N(%i ~}a0ֽHE15{l`IJo{)ZU%pـ҄jn,BFsNrIqjjy.T1ZGGcZ_[p#7ʸT1 7_"h7=ʯ:UHO3@.Nju/E9:,'kJ b߭9.?+۹ +<3yR/ R_wFVRNqks+7*TmKYnNM@QA+9"8)TD4qE[J 1~+_qP-ʖÕR d !9{QG_f>ZoE>>q.yx֢ǥ&Рá40v~vd>p+h|=وL~s(Ql.9G!OF7 i am֦pE7T5vRr!q^T>@%О5޺ڶ) ЄTؒ]=BEovljKT),SRehjHH!0|Bn8H$17|J #F8bW}7Cކi#y o۸U?,0V(N׈d|E zq3P8(6;+ebOOD4wnHP,I Ѵ FOg!OR3P8I!ܑ ۪񥒷Jn[. EZ[QFU :(X4}!QGF6r%;5TI+L+x~^ xd;͡bi,'^v׺{Rw]f?'T~NmZZ;kG"Ѽ|86H;ōs}UYRkdW٧!QR8w_&,diD5 \0 ߽ -?Y endstream endobj 707 0 obj << /Length 1438 /Filter /FlateDecode >> stream xڵWY6~#HMѠ(i -zBCʻ!%[nz`%3|Cލz?-_-H[m=KDy{ozǥo'ev5|`8eKaL&@ҺUm&P!Mf1^J DX%FþjM (6,`ٵeec eDܼrPq=L%lnp9._WPEhx!߇T4%5>) Ye1[B1P*ރKj]>W[;kMʪ*p :Y-F2UUY,T랻Y6$riFpqyZ;A$H LYJDolʹIk߇QXH݁Q f\iia;t/5ni{+՝*/~ys}e2F)faPL?%> uwB@jKb4P_&vh(l85g(G;nݜ/9&ݬU1|b <c<֠%' uY~{}ޅ!)l-G0jM"Xq{Y JϥF3onNQQ爫YJ(M&21Ӭp%mucN\6uL(VbS b7\*~9g(aQܣN ~8}1MeG'N |\* ;4zϵ>bgaz> stream xVm4":)/yqHO I7(Mzql@Zx?"M12N#.@e3omvU #i |Ղ3{_(6ĉ;̉ oe`nE"þEE"}p嶐K`gmL8,C-bW }d6! 0INQՍi.m\ u'2KPd4ʐ"cqEs&Af}[deԙ\iEXV{Ri %>4RYQ.Eetf(SD/x.v8ڲ+D%ETit[op~:@s\ӑRmtTsw`ϕdx`#"a,'.\kymPDMnڡt;l:OQ{( uS9uտ 4rIȵ镚?lM3:eTKto"H <"/90<}ﱔAs`Fא'95D`JŢf~b:-|җ5#tjysYۡD#gC7mnD%PR@a5hD ) 3(^u 7\ȣMU&06Ԕ ڏPYL(g*loR(LUMI*[*mΘAׯA3'wĮ_D]f2E~zl|O뤷ޮ$ endstream endobj 732 0 obj << /Length 1258 /Filter /FlateDecode >> stream xڵWkHB D}uhRRֶhsJ#}hvvzzg,fk!d1E1JĔD{_z|[|_2p34_-f3S걽RI1oUϾ|>~Sz;#Z{R)`^yF}ǣC%d^B%I#9|<FCd)f]6 Q9WqDegɉQF8{/fޝÌ YyKE S.ڮBIc_TcbdzEN/C,G¾4 EŐӧ` ߬F%P |;v@ˮ !GWf7;\UOފ³^9b_VGG&wPGmJDA|yIJH+< f˼00B`';$P$d.۬_k8g;DuձS-G_*@b__*Lmæ/bc+>X.F7ma2`>lHd&SؒhJlw0uYBl]YuX76$DcwM ʕ;A8tn>2&4ֿڥDRJ> stream xڽn6_!X@"FEE[`MXK7E,hȒJI;dˑ=9ь8u6MQ9}0rG,s >>]rDI(,oڼ\pr3=ih*1H\l&*ҍ4I*ڶJcDc24Roq|LE3`<$qqo n[+VqkS4Jxͥt0F) \rAcHb=0`NvcwCv *ļ4k b󶕾(p}A5Mݵͫ0[>)GyV[ZU"ouԵ଩JL&5$ IfE6tF9E4u8ئ.xSְ,€"lho h>/w}=P<ܥ9'd^|++%#샥 4h)W zij/_o_8rXoyVȖ( ԯpwܟJp2lCsFdXźnr_檀 ?6I̹_d Zyogՙpظ1lxo jSsY\eFg]P/Ɖٚo@sh;:VEnVj@ZfČaBuUU:kCHU6[73}j5BIlS].ށݻ_\_ qkZ/2^)?X>#l]=aPUmLW4e}9_jM'j7}5 tE;Z`g DѾLnx7drʄ=+ s;IBt¸ jnhHD!v#m b" )mcj!d@O"vRFܝ}]!QնѸ^Lb@Zs8"X[ސ`peK,D^+.Nݼ~(qʱ#A6J5XLa\J.#*iJ.2``\m"&X.X!v?j]GŰ} :Џ0E ! d'Mr^_%%B٦`<04ȸYyA6o! [в+Z n  }ނBS_@gwzj98pv^؁RYܰm&BJ{=U =ȗfY-;ܘ endstream endobj 653 0 obj << /Type /ObjStm /N 100 /First 879 /Length 1696 /Filter /FlateDecode >> stream xY]o[7 }c"K"EJAP6`>[v:mnWWCZX\pq.kr0}vT:.+ԉ$'$WWGbR2.R'C0PQSf &Z:`URB,J.VL2N#hEKW R'0*eXr5$d3g IlF0NN*VUyXIM gO1@0PQGm `p"9f N)69 jj'@k䀉 P*cJIl] ܅a 6`Pm]ܥ 1&s"Wl&q9$ADx*F  Δ2Af,$^Jb@\;kK0k`X0cKF=$1 jA%mEjIWv@H흞o~t\}XvN/fx~}/å@yR2TT{NO]4{;sWǩ_NF_r={ϔy.w#*yFM./:$Aιx gS Wa/ .]$Kz} 'n z>SՙtߴrqoO H\]͇Epodb6-& G o!Hk]w-`.g\1w *dJ`I0Lm}a61ʨC9y+E(g^ne~u' *Fp5bmiکǗr892v|0ܤ=-+L )cTv3ՇtIJܱf8`F4mF0,`Ij'!ކMvVwwM/_Scٮm꾍P=hsjPF )sݤ6Kl3w zRp#qa1Z=7b3­qTη C6T8)vgⰝ}"x@ni,e:[ؗ*r}DOB|UAr]^bFbטĺ+|00o_!khgl!$nQ2ԓt[ q~)IkƧ؞D:`>Ak84Rjo箇6 dF\>n4=> stream xڵ]o6=@PǢC7+}(E!t[Yr/7!eIQC _}ͭVwU9*ZgZn%~MF,N1{s#܍CވaD}sL" {s+XD`&1bݶ>4X N&Sũ۔ '"Qz& M#e H:y}վC2+jA|$K 5?C[$8쀿fA}?5g/\0L$* =}M=vusx["Lhu쬄Q9S%Ze <+KZޖ-LS&A YL%t<%tp`Zes :>"8LcPDR[暔 v?-tb bHwg\9 zhmn!NSjR}*`Ē%:\EZ5U~_`GTɢV*W7EUe9 Q S_#\np KG("|E+_(,D@ٶ4-Kv `lu+fO(kБt`^2grFK5it4Uxs,U|PB"iYůM Ӿ}x̚wj}\[e{S:ڈݘp( Zg_T@8/V1; YY=Z]ݐt.Bo1 >ZL;M06nBl?N:`Xv!u ^ڣ<~m L,.+rxXn1&Qba7Iu5~CoJv<  `Yʴ$){8Gtm ?)uQAuxz(Vf(&Lt5UЀ!gTVH&~ikJa9ܶh])Ի9@#-rMc&P5eV/ Iұ$'ȂPZk ^@fLw~@36U"҄yfM]|[6EuߺhoZNUG.=M{TQ[>5u$N )̍:y0mLȧbܟC^@,Ƅu"c8s{=-$]F M3k2Kgj'f8xZViL9;_b3購2cP㵳m[PZ3N0 &&š]8C=-sqR/9yZt t;}xn>cvdɋhYEyL)Cw񗺧EU@/2]Ͼh\=XjkOj 6suub6fHznN;Oxe dS=G-Gm B)"A{핲`^aA?=5Jn#f2yUR뱒Cy=(=R8TGE#zBIk(~'(_H5Kw] ţ|yqI"us=/JHTP0a>t6ˣL<7b*y;I/=ğuF9.o SE T%bjc-u]D{i2RP򙅊3_\OZSс.Ր+j1|I0k*֨mpEhb+7P4x(N8AW!oKscI)jli-U(|}6)\EQu FAa_7vZ;ݧ[imCj'yvPSImD p̒Ėĉ0mT#-,:ֿaBEv< 6Ŷ':ȕ ~npp!:jl Em, ݩ^L@p0ũ )ٷY~9;OY<ţfl~AgZfaYO [gɲ1"=a]P^e^2$)a. Qc3t 7ٕMW-~zqUwJ0!ha&#~S/Exd6kV\X^۱+7c/Bu?Vij endstream endobj 779 0 obj << /Length 1961 /Filter /FlateDecode >> stream xڭXo6_H鶇݂C[E'Zeɡ8y߾;%KP$Oǻwt]yNjXػX{a0!c/ ]{Nj΅q d' 5Ny='H=UBpm&dzsLeajՁ񡒘e)-Uo/˃-KiƌgSjmnP%~[j-ǤjM+Sw[XBVOKrveb 24)i> v-ÐeQ4AЯ'nSD$V-jPE~s]weN"D]v03QP{V~'E*#F&e&?68R{iq:n4aMhʨjǺ)hbAUxiفm9IBY*nUQbx0tjNr[E)@H~Dl܅Y(p"AW Gƈ3[`T=rF)DP3%p}Bi })*"=X \w(6v>vR9zٜCMihއ[7ۮ%I:bq%;`#@ob Xɂ0^:?b)vǪ4>&֥pȫf!!Fܷ0!j IHථq2nԪul8dtiDx(ۖJ.rjUbR56[<zܥ &}mn|{@L44(ֱnEQ8^8{m$}م, -Mx"LGLm6#-JXpas7Nx}&WH>T+]iJ[$; %%(w+MDA`hLXA8 b ?j۽‘mblF¡:Rar>)PjybQe[lH"qiF#Z ;FZd{iS-M-ld  &3nwd"PVQ OAjڵ[6jkW.& h ?DhG+ȯVJ hWZ Y#h}}"A+GD:~oh;&&I.0wpD|t5=)2z[mVXZcNb2\ܜvM4 =#E6'?^!3hex'j;zLA=J+)Y=Jl1<$drQTW^RU~#I豰眃7Xh86EY(C_\ ՜εab)'Y{}f\ j7.M1UIAp(xW#.1,'00 eyr Ǡx[S)$ ]>t<hH} endstream endobj 795 0 obj << /Length 1478 /Filter /FlateDecode >> stream xڵX[o6~zAfERaФX1= ]mkDzwx-tC"}"ףG/(JTf$cD,ʳDUv\ɋwoFף8@X`K}G,*VMc21E4?j6Vꋫb .T$ޜW$ C<EyMHn.p,3Ѯ4_Lܳo[?}-*kL:f=8ݙۺY@ 8LKcG7zTF,Ň)k.@z^o @P-wK D 2ˋPÄYHѯnFN1p>N]R[rimJyc6zXY+ـKݝ>UB!sK:oDTݡuD W|)"3@^^FtGVR,$W~{<_L;@FC73<%׍ ;gG=͝ FSOepb>E6 B/![3T̝twzyoOeg`Y~$Hr2g:}11> 5oQ(ITٙ $!LC$A<掽{Le4-Ư,, R!{6Du4k xؖ"p>Ѷ`%ƴBgTCb}(;%q =z븚zRNT .Qz`Nqixly1Syn.H16-ݼ؉,5HJiцJU5<8c 22+#or~慯.&FR8f7q&4 ?I80D&9: L wlE/w JCa(0tXO8Bʶ\hTm|'pXy M֨|UB4.[_%gsUB{$&K{ #DE K endstream endobj 811 0 obj << /Length 1438 /Filter /FlateDecode >> stream xڭW[o6~2tHdhkڢe"KDm}<-9J{Ig--e|:9Hd1=al%GZӹѦy"zA$F|Vϰ?D [Z C>vS0Q~"FgB`+|$nV͗mUWhD(Ag] -G\$Kiq (\׷o7o+?ή? ?.o BnX"ߨ}ho]5wx6|39]"svz}d͊v3S/Zi`cRl|fQVK f(p-(Ey9+d;Գ|y^jEa@$gϚOH|CjhҵE -0=3thV4Ml k`JFSFZP%.Z{9bUg/_ߗpؑz9YA@VfSaRk1 JD .$$"Q) YBqfpOٶ9gڅพ j߫R|44Li!]!ňh8gE>&]U_5~QոM>5H#>20񟵦S׊>^Q [U3[ m,BլB;eM$O]Q(Lͷ-DS-OMqW1G&s7A)Is( O.~-d@>5?cRjoCu;3N#Quw{t0A&!nj1`eVxIssJ2Uj~Y-EF.tjͤȁmD~eNuzZAJ=R\bx,::TNgL^_{qVQ. vӁoPp4~ص=EHtG`S.b붐bSuPh祿79U%ʇ2ƕ\98usTNMs[EnP訓N"a='+E='BICxiq[Ƅv` \SRPmqŒ}uT@U09|vf$EU68 Wد& y'%? A e;/B`zCT@( ^a?j'i.wwźn90 z+!#B]hYM5?:rmtcJwO>XtoLPF5xppv"`q~2"_f@:p4A p՜fyB޿%Ai:.Z endstream endobj 841 0 obj << /Length 2278 /Filter /FlateDecode >> stream xk 6@R 8K -_vPPJbC2' Β)Yg_Pgw~s֎|ի;)Ł=I8a1_ >u޹=FW|u+0 ʳ "EkmnI6՝N xTdbi$O) v6sEfs{紴M 3ZT0JzulY[Rr&"!K-V7r\]ȩ`>cT>h1l7qGES^\1r{7IaG8VƑ7[Gbr?ש(E]{ st^_\rXB9}Cus3ɰ= '`_% +$1 *Ƙ.T4<~ Vh"Wb畍0g"@ ]?l;*7];`T蔶WqӶrEfiaYȻS3ʆ|>Ʉ Hy(6o]0Z,Ҭ(1hbXd'\gf<.bo&b1AGTJ{{~;K"znF3.r֔2r/Mr?^ ѝg\!†{8kjZTmϢW17MM4H3ڲ"u2q>y1yxH+Ϥgf?6h 1[oFS<v3YOPmgdFs.ϖd/{!'ٺM1J}u nጯ5#YNjY%եB\*%YD5Vau"RgZ_1CŌD_udt92QiwiMb& Ta;jEI*Eٮ7ɶu|m#lլt<)n1b=(ZcpJXJ,Q @JmL\Rrfrѫ]. PF nU]أH+Hˇ)WI-Fqym8/0uAqe:Q~=Ÿ?C aϰr͡\^ZCǸm,H\C)Oj I=!}*Vwg@_?&_jjoG7bI'Z p({3.ZGH~F~)@?󂸿)2Qσnu*94N2d'$ TD_?e5SPBdb|Y$Ϣ>a{Yfu/tR=r٨pd4SVĺ&[^a[ZSj%qAJ.)ZSs2vfJIo5P~Uց>KӸB%TgTB6%7;y@B%La3!:B. "Rו^'XE^cQ9,߰:A*)~-Yua5+sЩ_@}JeBŁk'zyF d`Y/'\{ Xex&|\{CNn㚖U[_p4iDï8!Mghsf4\ɭ =]$/Z?Eb Wh)Q+>ҧ#R=ڊk:y.&33B{E0}}*W D ;N,> stream xڽXmo6_`1PZ`bm}Hi[^ Hʒ#'v6A :{,~18=NB!#Nc1\̜!oOkI PS|čK+6OI2{4Pzi\8kTE颣mc1uQhuKr9"\J~wrB~~?p.kɢreA7yPHG Sz+O)n[I)hͣ[CB:ԙ&oؙˏYעCQC/?u ;'Ҁ!ZL+X d+PmH F4=K#c>”1"CYSE:; !J% .q#Y%RoS \n"F4J`(J)P$@%Θz9ycC.n`zmTKBryI, I A cHI㷸zbZ*q9@>\C?'#JSG92a>R\v]ܷ<)t''ۃh98R#!{j/ BS/)-RQ Ŗ_xsTP@. y.҅|`"OLf_R| ӧLM/֢J B>8__)V$+=[ PZ^,aTf"/NFca޾U"c[L`Shz/0 ,"TqT1iv$:v)4|ˍ4K屾E_앜bzuߡ'? U"Ӳf]^Wэ~V,xşɡ0xtG}umP cӅΧ;}sxog|.\A[YPh&0SQƢҚ&oWcqfɪ*1h˨}ۚ Yg9>n -E]tH\iYC\{@b!- cESG΁^q6r`!eUK~{ H&sSd_g*cUa7kVeru?F}2^?7DF/әCOz}rb3?<~=Y2[qVob(ַhOQʑﲽfzsޣ^YUИ.0馉ѯcXlx)Ų'b~][柳RNzn#w%j./Ct2GY5fc3k${No{I56lȩkݨfJhU9 ˰J==D8;atsqWۍ#Ws ҏ?1,WśSr`B,_`^)5ϫx "J1 Ye]WFĺ`*ze6֠ttj܂'„̷Yf.2s{Ѳs\ ɭ+阢/3|pocr._\.xb\4Qi !'E|z-sǜƙ$>Z }B^/] c) endstream endobj 754 0 obj << /Type /ObjStm /N 100 /First 882 /Length 2256 /Filter /FlateDecode >> stream xڽZKo9Wpo3"YE# 0dw]`3N-ʒW& 0?~j1_\D6UM~w-9$G2r՞ENNRrQ]*Y0bt"f Rt\Y#B)墍`\CD0&j$JQ6ŽO; D) hpTmf$ U^+([HP :"")b=tCc,kU`4`j]Sm긦4tKm:6)2:H.1)xdo@t{@l"/9jBuӘhŚ%"( 0\FG\f{PLBh.M,m ^/7uOg܉\'赾jpf3t ?۶Zmm]{q7hfs5[w4q::d:݃ L1⣘B"1}v /~=;v|o| gXA蓹7aw} ēKxVXlc;QŇɵ?fq-{p`%b/l\=fىb6_OWQ< 8.b| q'/Xf}8.7z:@  ~??6zH(>~œ|EeZA}1Gڹh1DBߦ}FESȵO# w惈 zd]ND5I}Dd,޶-I2X}A#%7IJ_i} @& DghCAq4T4!LJrsՅՐQ|M ;"+A^ ;_?hHrWhx3?Yh_yv| JqĩG:ؓez3i=4ޯ>Aj령zJfE."96z#l n]\LqbـM2I< /ewv|^ݷz@nQT&I%t)g?hIYGLA ѪĹ@|prP9F-&vW7hOb\z\'-';Elhf}XsP );4[3=TNO/vj@k)6Z˭MͭmQ|6m>Nƹ"*"Rts!eC؝,O]z~1`]g$@|o M_ r+b/^\pΆJVq!9.g5`_%1dwr==0g+ >(A1}2LšF}Q$tA 8Ĵ;W,%Ň59kb`Eڝ%䧙/rYt5@NUQ!H\v/_  ԧTcx5e Cx p#bSZvbǓ+?8,O܋!}B8 u? J[,D>§T" o ]݁evQ!±t2+Խ@ɀBNX=%žF@e&?|滳׳h\Ndeל-#iv߻K`gd.AJObCԏخTq'j-6'}R=SHxbíNVpS)\]rmwZZҮdʠґvJPoߠDl0Z$xr x2$xd75c}8wĝQNW8+j:bȜ> stream xڭYmoF_A>T- r$ (pHMQ[THʮ,)L~) 3>3mG/uy;)Fr8fRȚi)uykUo//^pG<3nax[C+It#$Rt߹bJYU߾K&#$rcD䊽N|:8!*9J8wux*9Q`ذTP)@e\O4X2{G2N7e+k,EFM]QKy_6555^gm]UE7IKOS4Z<8t'ъ'L]~$jPEy%\dQM|p#zt K^uTshug}AOh:,&Ugw6l2q j~RA5je"E ߁xTxLa{ C Б"KD)'51{d"Mi:XΨ;*Yk^bV.{$pNp<0mS7ǚ8Sq/v&c1;zmq#toN h% O]-f.39Pr.WիJch/ZFuAǟRHprs_cR?K:?;CiG`<s6 -dכPڹ`¨ Wo QˊKfLE~\4%/ϭ$7J`g.l`3WE+Y49a@EK5} )RZg}z<ƛ˞F*0qC+_r[)-hc^a  b#f%{h {`!o拏BV]#hj5-3aFM\ 72G3f2$c0(4 -S=- uiz"?́WSkg׉bd1*;)6dG:Hs,1}YЊe8G2)ƈzu6Tͳ8FO_n(yJG#L.H9PW7m گȾ</jUAWʜ ̯3R1bqH')ANl_<玏A#AT2NluaS#,, {>+t@7!rf{9&z@ !Ij-?8q7!B߀STW:(N;hxd>}8 @Q賌6Lv$x= R o"x){S+iY"}kS8 79Ya42 GXIlhֺ4z!jx*҄A>pf(0szAA)ϻI-epm$*71WE^nXD}ObEt*Bbr.;U,O4Il!L7^5C+ҔaOu2kʇ6X-{6׃E0) ̨]'.,_}n{ ;~ $oskNh 3&?C&H| 8#,z#:!AVl礩IN6~&~} endstream endobj 898 0 obj << /Length 1865 /Filter /FlateDecode >> stream xڥWmo6_e(&1+R[v kS C[DBVݑ,يe(RR4y{c-ۋB+"|veQ!.w26>ٮrw;F.Ĩ=hpׅcD|+>K7 S?/zl7RO"-k!{ҬWeX͕>$^z9H2DNObQ HhL-h?˕9Rf]Evs4:VU69cQeƢƒSh!^[Šs3T2NW(u|ݦ?/GxBlΫWzQ?ꙌVEŷ J8jG=¡xŧ/'qڪ)%Gp3_C19U Xsj($C,J79Hޗ S^zMg8RT@P;}9쿠f<.Iȍ&Jѓ<=X7.D=rB!Mm c ,M,X`&kY`nB2S 8pGϲ֓jzZ;ԮuR# 3 ޣ Hhk?ѧQo.ϡ58$ DO|NDe4NƀC%3Qk0 IS6(K'xc i~lZF3bzmeZFA7ep6'= (vYM3\VK 8zӂׇs41$*a&?3Qzo72}]WC=\FKptr!ٳt¤K[hVsebvI"?_=*ue8cpE^/h+M!€Z8qJ4ZCqTb&a:.t tJB:׀2s +?~ߝ 8n">Qߺ̡C0w'8=[WcG)ܥxn5]n oX Ωh(e˝pu!V'u-D\J+ӅKQ #c&$qni\K;SqjN,V%QnӱbL3l15#>ĆɘgfL٨XV,QG>@;Ô`}>YƾTk4}ftVG,D}B>cƹy ?v:!- tnO'Ji7X6*cwnus변-(NuYuE9i01q8 W'{ y_yM33%3M;TTUWM;H\SJ|,i.ۍ##M3r9`/=_^8MuPuGB&46&ZOĥi}A5]sT*zS.[@*f,ǨϾwI*]_WnS@D$p&;!o#H4]̊οg endstream endobj 920 0 obj << /Length 1215 /Filter /FlateDecode >> stream xڵX[o6~ R]bw:,KݧdYvY'ɮ∊-' );%"O-HcB`.r34{gu>2k-bI*N͊e_RvR/0׼x sk-#ȃJ,⪒$D8w$Ĺ2zb;牏P=wo`5F#8u(pRy›jmeeSV fM߿",rx/ݪ 1N0X@169t3]nV=APj{=e[+q3Z8r?s 2˸ %(SB($x>l=j&/BS#=6-0-חȶ ЙCLR Qt@1esjBWt)Lsڔwh .߶e׳.II-&%D?v0 2HHrymEŽ &G |aQD3hۺs6޲_T]l߾O]]Y *8?bĎ/ endstream endobj 963 0 obj << /Length 2397 /Filter /FlateDecode >> stream xZ[o~ϯ$kwv -Nۤ=BDlٜ_fH6Ǘ؋B,p>|3Cf~ŷMf\g7wBSnه\_7?}^7EIA5ܷ_ i2i QFzyț.>E)Sɞk,ⷰDBKq?{4ڔ_1%cbAկu%Zh Lh¤Z$U+,aBjoS0C6H"vX ep*\iue;byU֮b_\[MP{ YDhc_5ԕɉCl K"}F nvaٺÿ7WHiǟGJ !l 7r_ J V0O)DQX@:zG(gaq :/FPD}l,-oFRaR<ȼqS ܶӪWc߄2 (n}zpiŖz W?5lͰux|mh4/:b_}AiSbufehr\VPQec1p"H+V)kl)8x7+JsBHi|.~axk"k>/\R84Xr^`e)(h: Wb# @:7Ht}G ZÇ-S8iDEM;|\Hɇatap`2ͯ:=:C'r\'_73U<zػ0 F|2D6wϯhȿ_<դ},2$X{~t6tU= @ ͈,N~fͷѹ%t4EyIX2;|me 2U{RLBfOIB R@J_ ayq5kjSe&$$f^#j<h{I^pwsVpTa4sC}~'VAvQ\*-@U@JfҴ 4ʁo4ypUY9bj1!W9k%eUwh'XL?rFw$~K^)gqMM`<+uA( JRE,wEMT&:hDzlQ@d?db*5<4 XBIBH!#ЙMIA~'*C!N:@ !Sj/ }JO Kޚ_IkuvP@ OfN8Rq8-ΠNz bǰ(&ھݫ~y>&XolSAF\iNeHIE} ~uPu8CLb1+dMVš< ydGXF= hQeFZ^puEAԩβ,-V@*j^;YL2P,:%ZmZ*tFqg} }6Jf=UrK eϢR!͆r&]B0~Azqe<|DB}vYXtM>޹MB_ËlP^]7t l>D}'@Y@[*c9iTɀUP*1<:u\%Y.R"9(Z%184UN6Z< 2X(Y̳~bœhajfSf+%` ty,V9]] ([^?zb lPg8yBA^i endstream endobj 878 0 obj << /Type /ObjStm /N 100 /First 890 /Length 2289 /Filter /FlateDecode >> stream xZ[[~ׯcBqF$-`~hAޕBF67Gl 9Ԑ8!OW8mrmv]V\mr92r 㽂T+WGdLxJ RJWvThV8QZLX(QCx@wU1XFEA:Խog @>js>ݏK7~Y_+ L6?{:/(b)!ؼ=\} ِ(CHhjP֍C|4c) 4m?E|5"xGL~bm5, v^â!^`1_.?nf<{7Sͫn~}-7h3V.6k}&r:;ucz>uK9 0L#4`-$ jvBZZj-wa4$w% C!6t\ΖW!mg?b2߃wa8|n?zH+h|s&nJޒ&""k``J< k2ti@{,Y'/&l3[.~  bLxUht)vCv7iNGdsQ #TlG[R?bVsғXK[af|_0 ~iS-.)6VZW4<:\,Dm,3'j)g |_Qm Bd\g@pld/#C(C~zD,8jZ^6n0?oI{' J{]׽Aۋ8 #&$0GR<$a6ħKp]ک#ܥqv8cֶ{m{]KJkSk|Tt`0Vc-=o>͇Z!llHJbR6wj\r>d&0R=)),)] MPfHN 'δ}Drr5#YS1w=,- x*{80\gu.rS/(`Y7!$91cdY.Qvw7E{^vқ6Go]Xӏ6">Ի1b_"&.p8$-?%iIK¤%aҒ0iI$LZ&- kזSצ6_j6_j6_j6_j6_j0d'JhK&$;3r~><·yZ>*p:Ҍ \#~|v]#hY Պ0;|F%0;h.-JIH bQNq5:\ͿʾkhSޥ8B \rvl M-a,]U,s= j\Mo# P(LI@_dF@E(o Sv'e\p# \9y,;KtUA]`hT-?b񂘾e xN Z%CO J]yEdP>Ddfe2jwd{Tv%Q ^Fdk(Q? S] Gol?ARK9Wz.UZ9VWKeϾNg´!E endstream endobj 985 0 obj << /Length 1067 /Filter /FlateDecode >> stream xڵWI6WQ[&E3AsK4P=V"i*L\LZ|wc;q`B{ |>}[<&LN=mir?|8G1M9QjM3F8H-) s ;,|DxAX&Yl sх ́כ)dA:2ǧX>7 ]JZ&-7}枒Ї/H:.rb.j@W_VSVHp`L}HGIa9^iNJK7zrrmԗtD[y!& iu[&g0SxE>X ~lsғw?0Go\k6D$4@%|0koSGیbV]G6aZ& l[ə嬑)QR q "17)O7vMsB¢kѫ֯󢣭Dah?T7/#][b?w:usRGEewjǞHJޱZ^׎bMevTF*e-ߢ DAOw˖Vu3Wkė:ozX <ԉ+=4-e,+^nȕKzk]6u-uک[ <ێttҊTEigq&bmZnկ6["V5|d,Q~YykT_nh hn:S$v> stream xY[o8~ϯ/6P*Ї.6)0f1) ŖmMe#d9$%K/;"]1QBut7DHŚ%xt7>{=2DS>n՟W ӈEH" 0tu3fJLh"N@>\$ &&2%s3zX61DyeeD"\7- (v|}1 8 Vu0x7I MXn23?E6}}iO*,X~fR5ZvP9?0Nbhy\i"s,U!a*A8ߩz~7!D$ꛎ1fi*]eCjX"ZW`1쩭=&tt9m:aZX+h0(uдL bl) 2 D3,ˠUkW` !F2C 9ZhgaGƮpԶIYeۥGhJz+0jBEHv4`̴e*2!uC%a]mYo+qucܷ"Pvox6f0f|`?J l#cIHHYa{ȝg0W뼬VA=rgc=. Un9ʌ ̿i=dMY}67$'%:N'R^6\^Tlf]8 fI췵.x]OWΨ`cY۳-!mA]8u>dg$),&.쾕 H!;:&Լ(9pK`scIg :`Q,jߖP!w)wt[w~~Ds>VLiMYHhm"K3%XXy&LE%9Na*ﮁ5p4XS3H{kvX_dUF V \#t0[\(0GThڳF;Etd߁%Coe]\K:,o{a:HGO)ۅJH(%XU:m%+\MY9!"+12t:+*b#>Uls@mɴT *rE:珷YLPAf} s"B*Q7־=jJ|2).fS%nG` )VCܣ(T= ZWZAawv^^ed0U!zT뼔UEVm,s4'DgwK"8im-k܈ O5wk*͛~jSԋ 43 % P80Jgtj@z{]_J` Kn}[[TzQ j)xݫr/ E#tH_Odm3*ltr-vswhd-Js<sGu0_O,zYv@̀.߮ҒLi H?L|sqJV-^v Sp|ܰlkǮ' z@.2*bxH*CY&ߩ1 } p@k_)1IĨ/n=lG6U@Is pCD@ّ;ITy UXqpsHBŗPSf/KG8f/Z^D7K@7HBV?o=]}zFg!y_6JX j61f[OQC߼jz*?Z5SWŲ7 ̷Di{eQ/{&/yWݛU5X?]X橡HfzYU7-*6w15ZQjnn4 ;'P endstream endobj 1019 0 obj << /Length 1232 /Filter /FlateDecode >> stream xڵWYoF~ׯX zou}i $QrKiBro@9}28lSh2G̅B"Xr&3t;\Tveap57 KEIxV/5Fu6U}fZ%mÇ5=]jwYűd1c4vϯ3+@ҹF_340+a\sh4fUE~%!:_jeQ{j[mY7i^n&5~7TpH>|&?_jפM~cJ&\s:kSLvم3vƬgygGw.-K+2 ӬT/ s+WTED(zP- >{mQs0D=PvW x#JPlrWQFܶBQ.f} * VFĦdXi޶D&3Nb5ٱzHѣHN$X$A`̥ާ.d~ój$.㶩-v|xܟ,<_ "y͝9&RvRwuDWn8-wVAqQaML \UŶ)6VQ?5@qHa=l}C@ vhL; V׶`}"8x΍BJa*\ )Ѻ;3`'{M̱EAlC}Q ط72־K4zsY9486^5IAb]M_x^_#\+޳~N>~zL{u׵j)csn"[rb8glXAPs5˴W 4V}o դ:;cuIT`&7)"a*e,+``B22p]xt\_us"&-09hx!q<0p*`wHfgE^f(f8X:;a ג~9w9ߨcg1ݐHYSZfMY?7h7y۱"kCX/R4B?f`!)G0?}> stream xڭXmo6_!`(57QT 谤@Im1h%O#q)@Ƿ>w4M|8L')W2a!U+J2E%Ǔ3!F;D =W]YmGG1 Kd|r7_}F,~LB'?UI /lr,vsuZ[3 Z|tp&$ftË=;EsņXң,XKr3e^O-h´\ǩ&2gb!gR.]jpQ'o7x:@6MM9!G te_vgl0I08vwf2ApRrh-3V]ez$/E*m4KsaB'νH{c l6Zҧk!Qy[.~$M>Sjoä!VXbʌ/vn߆KP-JH!Ovlx[:[0=+s)}*@4* ]CQu70f~CW q&ڛ_dCڙOGUL qS8L3+M/1k"3C$Q?K;蝹]0նm$QO(pAOpKάZvi,=;1n >[sUmOK<uoB2w{|&P7eF7\||=Ok h/j ]3Y84cH=|͇SmvWܸX{KPj0?j_b(NT&1}T ׊@hBg0bA|b/]9,sAϯMtbTݠlVV]='ЛOP{.\pԇNMԻ^1s#-ԫ^*(YZD(nΨ+4᪃ Y>TKcKx( ͇s鷓 *ph2:Q,w/J7uI鈇t#wy¢^ڔHKmyX(CE8_ImU_gU{3{jW5r6~"Et%[о MxbݲE'EZ{I&ԿBtrwaӆ;^D$)1n|6+λ^]1ظ\o$Os֭ _2r8]Fl ב2r& P1(KTSNCKzN ²Yʻum*_'xa4d[tп+a#ummֺC]1hc-'e3Xqlw9YZl endstream endobj 1066 0 obj << /Length 2201 /Filter /FlateDecode >> stream xYmB@@<:.hP hn~֦j,ɕn}gHJ}MoqE gh|B$4*a!ub4%Jvzzۛ0XK055@(o~&KCl2@@p1~/`TJ"q_ Gwr==lmP:!&hvC4\L8>;6߬k^( t,9Lpt?3$lgR@(Ō}2=A9I,GYD /E|^ncraG@ #49p]G1@Pp6Fk_xԝ."/GD>V6xKf8W'ue슗B8#{黗ki xmL͇0tA!nNQB 6KG_)XvJ0m1W10\E,۰:{%$ t ^o_xBHi3Xr!4>wSBnBȓ€\!O"'c9ٷQE=e?Y"h2 H{ #blJX)ײ8Lw ˌÛE䓟 ibnHun'h:(M/ }1G,<ޅ6 g//^&%*R4qӢG|_G6Eouµ}#=g>j yfpMTupv(Ӫ'wGt:m *\SŶsKl*~7W \mx.]WV^a?;Uȱ~9wu{ƾS"\>`szch. Iѳ7эw6?pYO#cVsOLhI|?D) endstream endobj 987 0 obj << /Type /ObjStm /N 100 /First 958 /Length 2200 /Filter /FlateDecode >> stream xZKo9W8sXU,>`y 'qrPl%0Ƒ Y߯me틻Z],~,֓t-'v$G1*xԱ=DžNE0CkJ`\@@ 8 *I0?W)+W0*C_c*2ՐfqDv\N:@XXS(rҖ0xP >)@PN(QBdˆQ( (b%&R 3j J8> A5M,GPvlIȾ6~u1Ɵ@ł%PU74PM[$m1)6Cv J4жh#@k3ÕSF 4I It)ե*KXQ.#Q(J*5 ri!r`@m ,ڤaۥsL( .bKĔ)JٕL^&C+;)}4*^_jCeՐm-K0YI9IzaTdT6OyS6\#:Y0l ?Ҭd͆05S <{z6wytvڞC­fbs~dOwVW"R? iXPm?f*_d8=p/`c L fOL-< ^v7QaoEv4|QB8ȞY]n!67nn]M{NhV(Z!se|ó ρ|u_4<՝b'/ZhHg'?f֛妭5|mχ^L=GP,W\-B/Tcطn.;GI`t4|D\Ӂ!"6|ڲ3Y՗$ U! Tt/v9!6'J'V! c{r|)~4!D!ˌH;8Xz-T`VP4)8 M{oֻv:("Bʱby 5N|LmrBQ@(#xIw؜.V_Z7|XmO߽֫~Bl̓]g2lP1qVB~n/TH,0-oBRoCxH,/'Qt_AɓKΗلh ,+8D&TZo'a싵EC$kgEZafx|f`<+|F3vseJWpdGM!:}ܩd4V6uO(>#͵Xn$E;}22_9}nBRIq$h$7Z,n6XnB"ce:4 H^Bɜ>~ Zxp#D#bډ4;Q:"EȤg&e\Y%ikuݤ^n^Ei~ 1Uuv@cqx;j8XHʕi9%MSPT5/s^hHF@1f1g')[I"A{}\/af-UD6l!gOH0e_ m!d;hM- =1=l\ \>5m 0ܨ Vq[ZX)u,w4[#cHV/VH_wx#yK/cٱsv9[{VD҉^ hK.YdS%I;BֳCL 6l5pKJq_,-jGb,hȐk]='~L!0-"\Rz+n02j" ju6V"bhĦSd GI lD1KJ{V=vob ؞;eRT^? oTԩ/Q𢎬?Glb,etJFC;`B{ 3`!!oe˜H^Xl̴'<hHEK :ph8Ossrg9 I.N:~q22=q'}c5Gqlc?X$mw(Ĭ endstream endobj 1081 0 obj << /Length 2367 /Filter /FlateDecode >> stream xڭY[o~ϯX@b" ;)vїvO3bˉ[r%y3C{yHYRd; "ssM&ՇXb5&a!uiJ: 7B V -kwˮ>^$BzFf"b{EľyʷFևHC4˶[p>o$K7 fXxd/}b]C[1 r c.JG} ]"S08ӕwwۢ%("48m~_F͟߃Wn{il‐0z,=n> PP@ۻڻ=:;ZG8 +iמNIzcyϻ=P dP-tOKLJ N&a` 3*[^Xҟ;ã7Ewh*|:hal|W 4 mG!̨gĠH1K@.;6@"Tf5``|UV&OU:W@W1b`dL׈f/Uf*ѯ@?lg}Y|V0 2oX96UIi&T=G{d[&aNoH'ol ;'"974Ċy OX3ڳfxc~,{]+pEY#W!)tHì}7j4sAO=2qxw0`J__8pu n- @;w[l 3q\_$~SOҚ.+ _y[yT{U#S IU=)/ڐ]$ϠZ;}̷m~y'oM|6X(h򝋲B 0 5fd"tzy<K a7J Mc/ۄ &:0&eIYFdPVF'/!ۇѕMJ&w0ªwh.^+jK%M:U) xh(T71@W%'en ֙㏟d}P endstream endobj 1100 0 obj << /Length 1487 /Filter /FlateDecode >> stream xXo6BpWbF$C6`aEM/m2ȱHJdNT;]qG?]N(u|s]Q;Q\,</G/.FFκv0aH ͗scH _!D"E_lgCIEi^F/6 s1ҙ#N}> JNn>OψD`Ʉ3|n'n^F]rB{0H52Zݽs xK",Hb*OR: ë&jib1œXMgx3&Py* em)V"Zm6ɔIU\djBpF8E|2 1F0fŹfn/B"y1,t3WE^Yb?AG@{.p se#*'}$!,"A4 3#m,bp[]QBU1ua}m֟Ú&9ߞ~#SUƿ¶](вw"taCL܉b8uUγ#Wʇn{hnBD]ӊou =4wLpL+(9IWݰĦ /ndo=#Hh3l:cz؇Apa&VCa /dƸ 3xwi{g!ג^`_@^i>Msjv6=鵑9[4*@QA꯶?' @Y57QyUZ[Yukjnnjݤcmin[z 7;)UT4@AVqPݲv6ǣ%rr+L:6^YkJhq]v>V +hG #U|U2ZVq]A^\ۍHAB D}o *ʼ !de^_ |2Xmh06˿ qSe+uqY٢jbVSӮ"_fYba~=dqMׁޡG"vl7V%}x~WOJ FakM6?9ǝ4;@Fըu]WyH+Ut*yP*6(''Q=~eQ١;j.%3 endstream endobj 1116 0 obj << /Length 1469 /Filter /FlateDecode >> stream xڵX[o6~U$m@Ŋw/m1(2h/8~II6nA ><|JGGo?O/^H#8"1b16c%pm.YdJ0 EB :S4 S@T,h82FcךSb<˘khWdG1HX?: Ysv ﳹ?' I+0Ib[$ȶ1p-f?YNBK ]]rʽ]vle9-~"l*g&D UEx*%cAb.YsS~o  +ìtv\KzIO_=/.lVY}e:;^JC:'Vbi+yji_|~,tX.w'uO?D/ endstream endobj 1139 0 obj << /Length 1387 /Filter /FlateDecode >> stream xڽXYo7~ׯX"Q\ 70Ve/:\V}䮬Wx|3ߐ3u/_K 2d8Mƈq(`4N\ïa8! ie\sdzL`k܅" GX-*ޚCT$NbFVC9"b~8hl4x[s$QX!l~1a./3X[,30l.XYl-q J~ŀ *IA|~{\UժO0d;#cK <)QO֍|Yy mj FLW%`<]T+g'7K {ۧ*8/+ؘlZ&i]͎7>oB<}}8Z !+@XhycYe}{#4F-E15*-Ң_ j?79CZDx5Dla_X`#!͐d -s\tU>^YY}ƞ8M+[fC:)ըDBl"`˶^;fa"*<ЫITuQ4vFsQD]ڊg:`aĩ]vm;#iĴ-(d̫]Zq&!|SG+?r5lUT*ogw+ϣȳz5`4^ t7r8QI .mx5e)l*L;Pf3Hj)9hza ("Y#)fc` L}o;B `)ѲMO,{{~_; kc@fsϾXW\1G!e=LpW(;\($t_|Y b$uD\7M2HaH؊JCsr R,K CʇS Ck2@}u d "˚B!`.u1#\|qẢq,G x>lT9 6(%mllyh0iֵ;?f#;NN(un]u I!RǀF!E\ [;HMy"lTPj~lBXq(i lYXj? jyCW^by?W$!a],8.uWEF]eZiwM,m"o j6E2}2`_n֣2t;>E #Dᰅh?MeZoF UnP ,|Ce.c:7l^w/˾uy?X;(/J)r?d;7 _hl/BQQF нp#C:FOʵa endstream endobj 1153 0 obj << /Length 1316 /Filter /FlateDecode >> stream xڽW[o6} &{fXh- Fm }H;Kl0 ]?C%2H?fgg"H$ ' , 4A`^CF7g̤"E$`)f|v=08`"2k,cfsM~nM@Z kًK[m&>s,)2IfܢWͲ*$9IvA5 թ=Pf)4⣢Rvz?艛دXL]UΗY۶+}Sl$sn&[Nmk4,4e#<3OQ̓$\_5eFkHXst3jlԭL#SUoG/ J@q1 sDO,tUT,j E*qPnq]u.:` DEDl2L|iۼ)>;lxQ׈P 꺯;]kj_AQ@+7*n71##0P(':`1CBKX$؉CgWd;Q@NGi[ UD VF Ll36Ƚ$ պѪw(6uާ4U7//;,jW_j‡KUV(|U3llՃy)F6ɤ, ݅=6}6PS^slq8 `ϑUK|?.p9A=^b /=[^9ssV n5\vݩF77k7UM*'EiHF{%ks^nnZ't aٷF_eBVڌW}s&h[{_֎|LٞDNNFqLNIGwU RLuN\NZJXEY2\Y8>%p?/#$!(..[B5CDⰫs]JYC#%?|whwuHLT"GY?5%`İfg{6D8ygd‰ܬܰJ[ɩc!c]`~Bxh!C?5T aaW,Д8iJ!ݭSRH}L+pK7;ף]u[tCF E=;mѷkeIz1n/C%uU<ɚ]MS)ZNţBpǭ endstream endobj 1166 0 obj << /Length 1709 /Filter /FlateDecode >> stream xXmo6_!d(&C^C5ÊVg,6Y$ى/%[vҢŶr:{,4a2ԉQ3;cDYFd|p*d>8y{uuD&(@aTI|uCŽg=?TkrY|L}z_^k$("ѓLֲ,(b!${Rw;CWuQ|;ӳ<%Sqi̓/6qD$ۈj1w:`5FDp)kL~{s|->CF&gz|om-ގy|@/(qI^r CNbg~MPc:@p gq@z)J܅nYDf5&$Fď>p{nQC)X8.YW{$x=$r!^Y&8 "dFo&G*;C? BN}luyԢ+LJU9Ggo( d`8%q()E8h5U,E.Zb ߙecVRRCQ2IffD0~,*|!I7UI]rU]y)L*M(V%S4JTfL_<Ƕ"uáv?NHz ^.V ͉mQ&oNbG-Էm{ }u?j(!8tTJ5>J^N%dy~4M]Occ~Ta_K3w5( /U/F2Bvu]br+.uQނ>d8|f,fm0u)*Qni[h~y(r7FkQVkEZLS͏vX_u."iC2mGKs ֚[>:1:u;_ȸwYםF溑 IT*UIťBv^àmcajBjQpy̯ሟW ,deX*y@ @0:@y#EZT~=ʁ.=v0jʜ 9i1 >j_z(jE( 2bK.JչyWfNj{O.͊f(+olif6VBYeV<#Q {ikǙYen u#W" ;u"j17=PR'F*6eR>oF!BzNljYlqSΘ9ݳveC}`8Ys/-fU=a#"3>E>{auH `#:F[j5A6uICpWrRNׁ 顱*Y3]P uCig^3Viݬ6|mΈچv#4̯zvy]#XŲvɲf`-\T_X5iLkkٸ& endstream endobj 1088 0 obj << /Type /ObjStm /N 100 /First 971 /Length 1903 /Filter /FlateDecode >> stream xZMo7W^(r@ H[ 'I,B)m4jȑpUrIFC򑜙ȵwgKjH&pV# MMx&;drj%`ShJ>:mtb*XH-4K>Ϝ F(lh_ Zh\0 m2$;o(zڋw%'Y2h潏]oaN;1XXp_6, gg.jy "%QjGGdԆلְ %drV{EJ*`lf`"S%>g Yl3ubX7afx&#!glD"`Ho$0-KaAj.E6x0HX(v"P[,FIq6`F=e!"(AWK] `:Gf*]YCeָآrmP0߈) f,՜ɔmK.-D)+HIJ6:{`6|v1?YKM*?O͛6?gWK-XؖN1XNOfu}qqzwzKZHśDy؂獴~No tPV^>mϟrHP( 46`ΰ ܬ<_ P͞>3W_V/`]rZq͠fp3B3Zq,84iMd@Z UeAY5t:2߫`4P:l NARYruDM( C}Y$&["(zgZZ޵*)XRP8|J8@(nV7 S2Oȏ8f~B=V`ff '͠f F%zd8O0GJɇqjBRځQfzyӂ8 41I9F~x޿09QL 55<vxskpu9 ?g&λC-xFZ{=y3ovNo ɒ9r(8[pջhjnjz3˔BA/Mh3j;6YG С}9_^\-6V ms8A"s _Y_gArAd $J:m B}褕{U~2)Ik3KKN8dⲁjr ee?A\C:lxs qa },ljˆ~<4q3~<ݭlps(.9λroILϝQ?yGʝ!({0w^$]AbH3cw`^Z 9B 9IXe@z@[VD #}ެ-ك{c±֬[;yRU} 9";U>Wuۋ[3uso^|ߑߜr]/8&On$n Kz endstream endobj 1184 0 obj << /Length 3068 /Filter /FlateDecode >> stream xZK60Ř70$6`Ij[VbK^IδV[1,ӦIXW/|?n>|Jy+a!8gJۅ%wKo';7L džʼ]7+n\6$,V"a+"vZxY2jz)SO]at*X ˸D'pL۴JMV82~/yci |X,ajZ lg`;6QKv2F,@;drO~KFvC=ی!=n 78bgRȅ , ,~sغ_HnͿVGgD Hqn{C{dbY(Q0o3nrS'Je6*kH%XcINY=>͖רr/ݔc0 w&LUTgyD8lᡏ41/nwA;d6mht :- l>~ȞRM[[ $K+Pex]XJt:v'ڒ=v:oxEkp ہ߃@nH>C ֑`cܡ^i\t? ,#7/\lɆ1SeAOzDߏufk1@ h5{JAٔ,t5j]n0MS"G7iƋo' jyb4.V&PL2\'hnYhF2'Zli]^X+N)ftFޞeQ64x= `Ph6i+=Pyun]Ϙ t&St8ӾS?}u!a gN (%c'k]/_ʃBNPJNA[t3++MDo+ Gm:ʀ5vBB/-gp| J͌c ư 0QJ 6r`+4s$/t6yz0WG|x~yhd8n˳!zuit#4HbS#axJ@^Ldpju{p9]5l}eZF?`9C5tA!(aHC"zcs4X9٣d<"ZJsM 3KQ ʝ'~ȤvYr1%;c;b]3N%Z\Ґd XECrH:B[v®mp]RBPF*yQ7i RjxgE:p+(XKnq>"c=sS kQO bA$]TzfQ q97z[xWXuCsQ@CE,v;`-0x<Lw^YSV,11 { x m SϛENiXʫʚcetţ;\Y}9MY(Ro!#/6,0;AD rs%{'^{MYqAYjil{y]6Euh5L-:+wM~ص3]Pӓ1AmɲT g^T޻v[]]Fjz8Gopë́$Q/sqhJҼKIѿj؎V/-1w:,s<4blrʿ  JX> 1_aC,ϐVQҍG=DH;-&j6ѽ۵%{ב?+ӅPA}h,TIz0#=8M 89م|N=0(|E+"-(St3D /C$ҝv`@.y)I嘤E \pCv $԰'<^8Jpì$ rD#X@ZpeŝbvF `"1Bni_Os;$ؒ`ˈ$[\ 1NLk\(0}UܙqfG]Fg/% M ]6`]N|P[d>HJ]z:Qt8諛0vCmkEmuEe%"Of]>1m3 hVu~`q/κy$b~O U_޼uE۾kTK`%c\ 1F'0_m@p@zug &{oy&Aio2b; 6+ϬFvLgVWmڛ*Yrz:9$G Ұ)0 P#: ڟd5phZPa>BXNO1nՄS}䴰}T[ͻ_w`p|XPX^з +ETՉHDc:5ܾvS e2ȗ D,Y!E3FB;R@ : 5J{ >/ٙ43mvcst%ڣ`7W7lzO4MF|Խ=3* endstream endobj 1191 0 obj << /Length 1893 /Filter /FlateDecode >> stream xڽX[oF~ \k¹qZ]n6]J$n(RˋsBm˱0d9o& Arś[΃$1E@p*,"K"]^}ͭ[."JZf"r-Li٭eִf\P4\'(?E& ࠉ뀑D'*[\DKmHIe˿"N> s'd]]^MxiQ`Cuutq`~VݺtӋZ[UOKB|6B>7|[CW'*^y"LD^Eѥ5QCBRfM~5y ѧ b.(Fȅ<3u)J:O9v 윁jc36Qܽ;ΑVcZU5w3f /lu~=C{\ "]wx !$D@!پKA"yKާE^Y87.^ q*3@ [guAy1;OԶVic'tpSVA n u͟"&,9RXQO1.\[L0(x ̳'tqSo8qb|nkݿM#4"aZ=Y>x$UJzqWeJY 7 Z m޴Ϙ]f^ Q-{M|ζbGfFߙPxp{X b pUZ0u¿Wdld|wWK V;I 3R 0DO ʾB#kfu1qrTv 2^bn*W]siW;`y9L#КUȚcp#۵ O&-ԝ@>ֽ]5weEuu(F;0-W3W .g`ֽw7nB݇;2(C븧##@@ɏ endstream endobj 1206 0 obj << /Length 1405 /Filter /FlateDecode >> stream xڭW[o6~^%2[ҵ[ӧdvȒGqwx&9rꢅ;<-y ,uJAK/Jc"$W<t,_}>n@ϼ8vZ0I}xyWʪ|ͺ&V׀hO>4 ݇SW6*`ʇN&QN`8g2@ 'PcY ;̒f$~4X]qzUzz ¸79?y϶U?p ScwAI^y4L`Mws3bOX$s l8v V.Nܷ&4G;>YMc].X8-֌΍뭳{6e͔ۇfN# pL'M=+&8W^i.،k!3BL9!,09VD#o @C*&Ldp0~޹yBO%#rS櫾a¿8黽10\װ޲;wr%2Ȑ(,kY\룝IwmS`B;GNE %rѵ?ϰ ;JpuPu-JB"*NJR;A0;Q]㹨7z=I5I_ T!*Sisəlй\9z=pyє] 6#t^<tנ[l)rm՗SK 't GɠsþԜ܍1|*Y|SU~iwR¨ ҬZ%>1?6'_{nƊ h*6J3_D.Sq ,!\*O =3P0 q!t (*ŧճL2KY]_\Llb P&# > stream xio~ 5sQ"P;(FfKaY͛]rɕDYZfx׼{gt7J22]fstv"thPHx| U,YbsoRV~W[e]qĉ}{(^B,ZCS` {6M ĊhMʗI5fSl_E Pؠ I WC}f MM+5LA[ fCV [w8SWn9鰂ZqT {`2^Ђ䁤I}iJ32 m-Mj/9=7vMG(]d@@0EM;7tmY}5PELʖT9B -DEZBe1.o[~DB(ҍ,XtR0"{ITfmXb d6 V(Ìi&I4#1L:DEbR FyOrhIcEWP`ӹkLr/!q/>J@3hP??~$f<ne\E>!Zpys킽"L %îlA5o\pqmpln9_b g Q`'}DEmj 3τ.+UzԾ׊*7DEӸp\mm[R; (|ax񞪇w ?A3TL<@cBS1l\f≯`z VL$Cѱ$삈˟\v'8@v ; 7ۖtd9Qݢ v}D>e!,4Goo~ ,{CAh<}#^;ʠ ûV)3HOVE`~zh -1ϋ-pJ=8z_p |4c|8$VP#Ob*_~tQdž 󨱻0iSEs 1l %1`=<ءJhO0iO֊CD{Ȥ 7)skʪƍcG6:ʃJx"v2+`Ssld`S ld&c6OS2;0(eJHǗ~ȪqvPY?B~勢>.*o^b+vW\ Ï5\^s~&C2HOWG endstream endobj 1280 0 obj << /Length 1332 /Filter /FlateDecode >> stream xڽWmo6_!t(`1CRoT ؀tPtXb"-!JL(R(lM`w#D4k` Ч">L6$}F!ideӭN57 \"qoѼ]5h.Dv?R vɼ9IVOӪgLu>GXiί؟32-g4TSʊf۱lZ> AV5Wޙ%UYC[$+3Y #2 aW"]Jn셾wļߚQ܋["J6eZ,AM]Fbτ4:Gz1&( '>b/I)ğyF4(JX#齛nq50M4;cP_ Rn/b'uFC$^Hȷ8@I+ͬf9cxbbu~rW[fݺy 3fuKs1Jpl+<WY>psؾte| 0=00Coްjܞٗ e_Ӛ.bռ<癀e6 zN_:RW1fQi\Zj m {Wctk&ږLN M [Hzim?uvB5}y,e&.PHT7L "ףȄ.a,vpB5<)t|*w>v "EVx-VZ)!غ`S۪-bmD`(֨[L|di\w棙̸Z'ƨl6Z#pQQ#ac1V`'6v/l]_8@hBzH3ZPlq $@2.Zs- >V|DzeqaݏYА{.GʈOWmeHlyC:ˆ|'#2 ?>bکI\zE!8tXi3vlGlq?h6λש:7:_ˬ^mGj+u!==ڒ᫴}]XǮʼvs} 1ܹ.,S -5J5 zςQ5pυ{՝@rx]!R2XY5*iN\H0\}usJٿp+AC> stream xڽXnF}W.JE^x3)ZM''H)r%HzwfwI4%˅Qp9s;m,z3zrqŹeum.\smpf]t3cJξ\|=PP`[ԢemߺW`Z'qڿ;LSHr#s@6^]\1A(<>'O0|3;=}OjUJvyQ髹Q;[-ѻPF(dq_$m"Iҿ" ,/Q5&h=x禊¢?};ڥJWVJbb+8Kw Z9#p 0FQ֛Lp#e2+>MH<+Zx, $pT=Fmgy1W(ߵib!盰, kHCTVaqA?Jus/׋[5+%*7@nR6WF.7Z%N]a&,t趱nB,BȖGk8;э{@b"[:&Gi]Wն@y $yYCm87t0eF}]e, fOF,HBSs,#vl[0pQ$-T>BUZ- 0xv҄Y Y}d.) kCdEh 8?ŮTOUm+[İ;QtВZ3IkpB?pPa(CЅcCP0_M90|**0v j!ܥ]F P8?P5o9P%mcU9UZwi4sTaP! sSPU^xH"È3U,"٪fUQ,{x9}n&ķ,?X7si*5ЬLjeg.a؂0im;#8qkaC:no0+S.u|h(Nc*PI2,wluni6Һ3J?7ݙĦ q5˼ؘ19Z0m2›&3lNАHz!BOM=:`28qL*}f3 @ؔ?{) as51kY٦qw*<Ůbs̿9Zq Hgp>q6n2Q^|uRuX S4yˋbx6\_g@ 49 NƧR#>Dz ",KMzzvk|P|*Õ{vY n_!1*Z!ޗ/d9<:xSfXzmώ5<aJatu72q3XZ=Nh~;e_;1چO;oN5bl0(f*0`pZGik>/H /{m>˺etjD/{q(v`PtQ M2o(MJ3-r$2QgUG8q`2T5h3.R;Mԯ܈" ‚6-15BA.T6zS4E.  .gayɗT5,imA 5jpxw^ *3E3k{ endstream endobj 1180 0 obj << /Type /ObjStm /N 100 /First 973 /Length 2278 /Filter /FlateDecode >> stream xZKo#7W EV9 vי,L[_QlG[[.6],~mmʨ^*6e9* HdS!C!YwAB7e m*fᓰ+OISTpnB`aB0{#2cEV6d0e7p,ɠe?$HV$;" &:D2# $I<(* 6B6/.+JPɂmrB J,&dWr%Yf`{#,F L UDY"D0І& yFF9_֕ju Lj@+ ,$¦@P x܈&Y |e̐Ϣ7v##R >IhةYOQATpT!2#g` E.!2"/oYd3S$=,S,!s" #- 7Hb1; Q3R(g(C0pod3Y2[ Ȯ`gWdɾ`B/XF9,Pc-$n 7__WW6T?J3|믟v,qjI翩_D'i?~DfѯjLj.eڛ(VBN}(!1wP\LvkuF?FujϷ^?v+N_.btm/MgoԕQF`ipN=/D`z=b֟V/uӬbb9e ~wWXl9h-kFd5'q"зjŻB.f^_f)=T}bd-Cp:|#x4 _n83Y#' S XϦ^m[/l gC`->:HI{vF8 5Tjwzv| |u$|D$wj5.wHʩ#3o!p+)<>.6? e1R"i0w`A;H=HaټkS.!r`[>4đ`Ł\9'}C7"{ 1O1k 9A^a0!Gp?5DB1eΈZ4#UU[L'e<_"\D3@㝊~\bȬe"&H/+Hud1w9`rS"}(B櫖`;0; YvŴkH2J01%+-Y*0QQB jmYȡ{fȥ?tUE9= OKv0&5ijny whiHg-"\9Ccz&:KYyh( iג Z8,;9rv spG'R%`_om&ڌŭMW{6bmݫ&ex|b0I+6|-?ay~|ӭId1o3V -9e_Mg|lyJ#; l 0V(= RXusLn-FHkqg-I8;aLJAR,gb~F$}H<|u: u/R$[^*ؘi?6fH9T`0{aXH٢|E7֭O |;,\±*ʕ| endstream endobj 1304 0 obj << /Length 2503 /Filter /FlateDecode >> stream xڽk6 @q6fHp@ 4En>4EYr$97!)ɖo68,s8yt觛n^5QƲ4Nm$8gRN9Kdm? _yRN4eY{f}go~x#`G"RaQh?G^fG{t,3zW.XQ忯|tw%dqUq.}[lʵG|;fZMrx_EkWzݗMMX|X7HWe:'ݦuWS5TE{^i `YwP%"oCUtE8x|((W'dSO I,yס,p 3Q{o'i&cj:N5_Jø憙${OޔJ0- ٗ qAkO*;VYwKMwhW%gzl]}P8R-M2`єއA׷e}Ͷ5뜤`yzfu+:vD̝DRn9p`,-.Z0 }\^`8Bqƌ1-<4zD9os>$8BPfP-oHzN*9Li V r)KloA i09iqzm^w@\l2 7&td1p~SR siS] @wbR o6\n(VOc}2W) ;]LγACi3Јs9x+3z9m|C5֔Z񐚾C Xhߢ,|?_._cqh{j.dγObנzTzDsN{УCxQ9!_=B3r^g6A~򵓚l.z cx\BH8_ѷ+M"%$G^ \9gCŝ _8ɜXF*<#CbgHsNy_7?V#?_aJIceS_!) "Jȡ.0(x:ft@T$U[DX3Us,)$-_I HLClF+$NHT9q Uɯ%L]yJ|`5ߡ)?71tMі)pXα_O=/+h.N䚰nC]55桟z1' X4 oS^C^0+uO^;.`lO3=`)X:Q7fԽa␔r: H#bCܶ epuo} ] bxM5\倎6AI4n݌j?L=O=kfb~\J endstream endobj 1315 0 obj << /Length 1323 /Filter /FlateDecode >> stream xڵX[4~﯈VH'&", @)BhY-n6Iuvoǎ$N{y}XfrryV ⅻk˱m +\ \kZoow˟:v@q!+&{脃sxbNnyxExyV7/H.ˉR}\>a*Gہ-^gk#7ws֯y.[H1,RVH>+X(uS& RiT+\:use=nVTjl8sIO&cG 99H/9Ec ϗrߦcc&k\O y&Jh!럟zഋP) "z1w*a0Hw*ľ0Ȑw"MefJTv*r/_( ũJFq7܊^ĭ9XG 󚌽_Z499P=JjţP&.6ψΎGQ@ȟ+DGq; QVV9 ւ?4auLZkG#Q Ȓ `>TaB<.C |(Jqr,L)b P0GP;E E9 UԘ2"!ySFVu-NF_>RZr>81D)<3'RŨǐWCᄳhjn򎑔'~bJJ3']2 K£K?Rpas%H2H2SpzdhcJ\/MptrW4֮.}1lt_E+>^GfJ;:Ugv iIwv5C0 ZIGNj Et1 WQ0 X'k )[y. Konu͌Ƭv'MN4+Vu`Mt+JW1jM/EkQkGDl"4"N?qhF3:XNx 쯇!Xǥk2&@,Ԉa:蹅F^{ xD "SfAac"4IsP*<,'&i[N xW}g[)^YviaB_"&@~H@|H-|A? jyqh8nFmGVw1#!Ln oVśM48m}[ endstream endobj 1322 0 obj << /Length 1526 /Filter /FlateDecode >> stream xڽWYoF~ׯ D!}p@h>%AVʒCeIQ ;~s,  ~|;A)KE@ H,%qYp;> ~}3|o'/Xi b̞VwM=XZCյ#!# y |i3.6mid7Z5Z5<.i窱>*JY['ӖPD}A:nKei:qtJ ˦kG+4.zq_ {84:owFNH|MH]#I/qriL5A<l"@#/<ٱc2bVE,9v矽\{DZCdojܼW/WTg ʪ(!$DZ}TڜЋv[.jz_a8PsZWJvˏ}.uYuENK.vXb~!}tykPOI 5襻zSB|D9|v8<7[@@g]'aXzI#4gvwz9C]Eytv1${w"Gds%[ZnzUC;CcdA|3lJo[I;L؎ז;#wY@r+4m . zF ë͔q9q4IJUjijA Mrhlj]-oT7("Lk˱~a`/ 7)iXƓBhЀj"D1wJXxUvN%{@4ʌ'e/zǐctw6&ܰ!. }^c&[pʮd [Y85X'p ?mte@%z+K>Wm4]gRm{m3K1H7{h5 { RKҊ9XLpr`cݠ9׊fZl#^ՙ1`0GXRc3\;Xvoa,]kdŌt6~w/Ef]Iw]e7Ixഊ&dQrWF'nty#.%]]$ _ي a3W6XAQ]?{WhpE!|igP.N|]뇚kv}naq5ںyk 7h 7߱OxVw_Ǿ#Q$H#A\gF06ȕ?F*8{cyp13X?V9cq}zXbX]x'.^ m? endstream endobj 1340 0 obj << /Length 1269 /Filter /FlateDecode >> stream xڥWn8}WYIQ`wn[ t- VmD/;)M0p̙!9;s,Z/_S(Hଷ1CbDbǚ,ҫy/W.e _l0jwEd(B0 ux0Fu~ZEt):՚ ٤vkpk8Dڧ>(Z+qDm˻m[!0dT} ?@}tþX]vqT7 : =oi:oe3jTg+yى">MDq=FB5ENs/霔> stream xVmo6_!&1+[|趤@X~Jۀ)[,)~G嘎 XaCa<ܛԛ'٦LN:sʫW5W ϵVi"BD9dgFv9( )5!V{X׍ЂZK&j˫c={p|t[c!H0cQHBqoـ"q!?0[,j7fMօT<"GF)@?f+Zt 6ھ2,_,ewmsrtO[N!/Lfz0̺- _B&~. endstream endobj 1368 0 obj << /Length 2319 /Filter /FlateDecode >> stream xY6-PmfDRϴⲇmOiВl+KY %[Ez\q93yر֖cՋ[)Eä[0O kX"돋^/ձy۫+ɟ-ֽ^zꗩSgˬ`j[Uj/n:̅C=Os蘛`\5і*[oOxoo.@oޘ܍n_yGJk9<*ۏ6xgf0'c9o>mUozDmwb_\']~^<ӧM~nE+NRMMPUV\5IDC1ryD - M4S $"%:sFu/jȳNٟ(ϱ,&$_A hc46Z۴nK9mOw:.ڟ |H '[W;s&ځF:˧?kUI+Ciܔ\ug*Z8V{K@9+ΊYI[^H`>k64_Ϲ]nevT\}Ad/AC@>lzEc@V>njvcƀA jwЧt&XWIW:6JuuU)^4ku%~gqtx'9LہÃ38g=yM /0'%;P?~sL+Olh 8TQEB֩&uXjȾLU4a:e'BOwNћ =[Φ)L3 p)YnϞ )AT6KEHĉhWTTZPwx \ =vQ6YUzЩ1=L*XV1ZC rGus] z):F`.PLЃs_h.A񞃾]09V1Jχ5~BU4& *0 Rі& Z;)>`ea0JG+,!~I+8fSvKuDw([HU 3A7Z3\lwhc@h?(OIt]K8 n?$*. > stream xڽX_o6ϧ@̊"%QaM!-KZElɣ~w% u#y<ߝx /^8z}q{ǃ {IH$(}VH$1<(T~DƫI}cXfwqԆ/UQ~O:kfK"YYѦJ}x{F)P)'!_EN?( ,j`❞7-t[w1Q_)#W _l3En h+eթ\ 88+WsnYtɚRO )cI%Z1N%2j30zgVʛ՟WwECz3*ogYמ%]y]U鯭oWD,9UʳFR[߼7fq?DEHO1͈usMv|7,񘭶i5R52ǢqsݧJwYIJ$g4EUtt:TTx4c+D[LV,+!v&lL|[btBǔg^K,~buؾj9h,u&EYQ:QC[3YB؝2T[ڞeTXji Oń~ehUYU9q`4R+uh'@b.)%[G@/˛vմ/g/K#d[뮪R%B8A=4pWD3¨A1Hx\JT=Ic{_u ࿇V?χwwsV=[#MMĤ'C2,kHMl x YΆ'LmnGJ™,ga2F^$,mؚ!^ E8VT;\ƣ1b`-O:EPܢCm B3!^JNBv=&X4vl3E%^n]^dMNd 3b2I=sc(o1hp4wlc~w[t5ٚQ!Tp՘ zX`P+ݜ7#̫taf*t~ c/L cwٖ௫7Z0HTm*FJ}K6C3%$\Ml=]RX:pex`r*j j]zDH/טa6fMKR4]GK1(;'LiYV vqV`/!)GN& $@ X̭c_ֆ8UFɜ8]Ml^8:՜XIy؀TK:nL)6*9zW[# RWڝڊ9iʢ=;ݿj81veofV7n^FCWRjblE[9:g8<;F_r|1 屴l}GBHxd1|t?wep8>JEY5܆X1.Ȉwz-dI` Zۏrvu endstream endobj 1297 0 obj << /Type /ObjStm /N 100 /First 967 /Length 1853 /Filter /FlateDecode >> stream xYo~_\g0]h"o\Џ"J䬬= $2rf8C>gC\b|&tdGC7y[F > 2&X\ILcSꄹrG֙  D[+r pY%bPYJy~I'#PD+PJ3a'$6^ BڇlA#O *gĞђ0Av|iWptkT +ZuטX\5{BY5:BuYFt?8r HI2JIX$g %wUa "j DJ] \-7D(-be$5贘1ͬ, -8eRU  XddFub1*xEWM*xqs*V|%*G==pL𝘣_t,jRj3B2hqstEtejh*IyCkWi5u;tpuwèh' s A6Bb!ʜiܽLڼ4x:_.ڗF7(Qb3np(A'Dw-Ҽ6]4/ #.92_o3L{%)Q ߶'rJo[7tQ- xE-{NڠE 徼F)91W o|e5jκɻvkߘ}ya]5?Avk8?I;_vcT' %X^v<$" _lk$Uj }ldZ =֒P$ȍǃfljlJ 0ono]81_?`]Tsnyu~^h^ո޼k~i8?MvzcMs=^]B=6/-c觠#P]مOmk q8R45EyxWc$۔U$ޜ':~䇥'3/ syV?/|S_I<> stream xڵVKo8WCefHb: & Emap$*Nr-Gʦ">p83 q p*dL` (bqu9_WognF@p1bpY9k6R -0+ه#%b[W6'_\x$)k7" x0A41{NdB@p̬$H q F-.FK{<7Q$hM޴ >dLQ:)TEwVkҔ3!nA_$䉅 wiQY]I'z V;*7tp?3-食7JwMЂONYs v^iUz 1CRFy)7ږ'TbF&d$FZgJDxF|P4b$ &qC@0s֝I')_u7n$lZ7+7NUP^鰱# ֠1b+͚r` _> W2B72{KXn+G0O Ϳnjfyܶrps`TGNyHl]lšgyQYyS)cnKK wUMs廛唑D t%lP?z!Θq$޵&ʤY *]u ^xm ;$K-f6O#D!=[SS'uJiAG#B"PEaj6Id}_Tu7l2~lE'xJ8ܞB@Lx.=bPq#%l6<"Et}~Hc@aZ cu 1K ?/Ġ_`zzX?v#d8ޚҵ>ԅέL$!׽T;9Wz#sw]j fJz3CVY oFQ!}ڤķև  &"j̭͇wnxlp;xlDZeEڵj:}ewnR]h4萃0ie^ endstream endobj 1402 0 obj << /Length 1475 /Filter /FlateDecode >> stream xڽWY6~[e ⒢(Q!E}ڤcӶ I)|Ib498z;z,~Z-4coGĔz zwH0sԙ{`H=0AgvzCH80IS]=~ Z9ua p&7+t6Wa]#x=c8yqBIo],?Po<|*Q-{,~yDFRԏ/ 3II٧K-ι _۪me/X~#10  2܇$CDDS|$,'+mV&#ĩrS!۠Bǽ]inyOYT7}QKY36@ #}\\ʝ j;Y*WLjo`|8](A i1 Ib>gYɄDDCM`V6V eTGWbCY?w.A%JbFs_$T Y} ݍ'XhPW:0pi)ްrKC|C[cq4OA={h D s (wl7_qNeVϩ<`y !ٺNبVm mjU[kRJp< F9r;OB4k8cdؘ?XWxG֊zBqBݕe֫w-'Xgw)u۷onK q*@/ҋ&lYo*v0?ϻ> Q@4eڹѨT}*`C4 18rѕh pR !`'m? endstream endobj 1416 0 obj << /Length 1593 /Filter /FlateDecode >> stream xڭio6{~3OTR_b(eQ&g$e5OET/Ϣ PjSmAAZY%»*O  67q+TUo4~i_].jFVX(g>HGDO| z1!­tmjlZsPf#WG7G P E$DQԙ#Ȁ[Z8>ו QD3G!hSe#䈎8b}V$s3Oȭ>L۬*rN!IȾLmΨ= hX߾TMZg+?!H7:}A~M,ц;g0xL_BzEVdGV c.~-+RA!ŵr<ҮU9F~*öYe/F+V.[E麃҈sN t@v<SƞI9wUWlkV$Y $qk4<p`!ܴ~E6T*~{ 6Q"D֭@㭦PT3|C$z̘8~o?deH"at ZsrյH Vxk|}[u-p HK߽ީ|fs4-R{C` Ym0jeƉ|sCA$Qh'&YXu{YvŕTR`mO11YSSd%,;l4;0&^r5iǑuo^K^p=1qoIt}`9FôED<=6ּv:D!fJnrڎZJSXo{ԡ̇.tADJZlqB/46n7q;^duO ={818ID?Jpl!Ж-|;|WCyPhwH`bD"zp6 DhgcLm(y8L?s#x='&W퇦Ui2 W.NPs䰋Dz_IBvp(q ?[&3'C3aᅚîeHk59aQN?~A=`*~L8tΗ`:oھ"}`oJ endstream endobj 1429 0 obj << /Length 1941 /Filter /FlateDecode >> stream xڭXm۸B@q _B[4)zm~Ym!䣤}ᐲ7XmH<3q󷻛uT"YtL%YgJFwsow?}DRi,e5UXJ pC(߾dRi̱U > dDرջoG"x(W+p7al+tDd.>&20RiN2EOLkb".K%%x}X3ԏ+z5u`7CSaD**4`:jMk ,-$Z 4%UC )- L3Q ֚5ÖWv~LåsZ BG\Y%Lg$q0ڶo+`GB+kʯ7Y7ǡq:3%UfzK2sm5S\6;F"`J{,G8Ӌu8l[dY1xr˔/K*+:}C KKyV|vZ W} 5C|,3/V-Kpݙ'=7Jڡ7XE~m? ,XY*άP;uu\꽱$%vGS՛'DKx}ЄMY}I-Ư]6B?pj8cX0eQm&m LGvg$fL8W$鄜2!'TH 쨞5}Yj88eisޮ/U{NfIhC}tY>q:v ?u5pɱX*qi˪El lJϏZTu2Vh[nKpY.]'5$Uٚ1`SɒGۢz4h` *Rn{\tD@`@V[Pqj&VqXin s(l:LaIo.;dx#M2BAue xd!*; .̨5kU-$6]囶ҧnPZ.<I !8RdsvD3)?t!DXxzL3_rk^^D'( c,fS{O{Ç0~nL-&GA3 9'9ZvmlȤ>;=,i v Y(xJpm3j2܆[&zP87/J1EޯV#?0:xI]Ex&,Q㫈kjAcAOYZDwY94R.yspJ9h$[ dġىȲ OPfl~ј$ȋof's!p`Sn"v@rIAٴ=en_AiOK4N shS`!mt7l0|"2A53=a"/$+F}HWjn&~>O^?8K0 @''hBg飋NCtyr>8Óy*ƽӭY^:gӐk\3U>:At江:јZս&B2K=<F='G/ P/}gzjzHJAȾe)c,lԮfx=7Rcn.> stream xڵYm۸~ M/iaM-94)PVBd' D[^;M )Ryy晡fǫ^r$n=A gQ0-n50o^,E<_M9\E9c9$r;,!0DKN'hi$R| I .bgux+<-cZ)"TL uW{BрEݻ'CDw,%<#VR*W~ f|&Btf S:e۫,C3ijGu;wr?jp4 :ͺ5'hwFigP!\GKgG^<(@L׼K=x̍Ym$m{~0w7l$K?!C:&%vM J /Ev@APY]Z)A@V~9+xh;kde7T+{"V xh]"Kq0RY }`.0a"O1 AQ+k>n7Np'|1C&U 4I ԑ _Cﻚ M;'""m`wWh0/y>H2"x5`D&K;?R8ߥFO(VumuM>d=H֎ On0%@=hL(7!Hc"!xr (l)-s;J$ }0"#bU1 o #9Q/(p(7 >@7°t0Ew\/*zZV.~?8~ 0Σ@ Q6NɁ aJ!֗C7#=h2yl&4Hͤ< bbhFn˶!TbCv_=*YUTID|%8 (H'xTH͔ov؞n$|HSMnD^H'Y,d1u2/y"N-A:8efЀ#pkk}?ʮvƃZL8 =txpsXA'v ])v_!w{.~ZG紞Bzvk͔vۏ=j?^jtzCugE I VhTCgr9$i*`wSds{|6'?\{eiW3ʺv ܲFn6Jn)ӭ.Ry(k8yG]T9pz{ΐa}#Gtm >.:꠹ endstream endobj 1456 0 obj << /Length 1720 /Filter /FlateDecode >> stream xXݏ6 _^ Qm˟Э6{:Q.F;H}+vz{؆.LIѶn-z9j2bn`]m-Ƕ + lS׺X]\% C#iDp}Zr$ٚK׶"xkEXn[QX_ʷoEըڱJҭYџ?d,{WZaB ))VLOOKD[96'@YFMXV!_Z,DZ5ߐ1AO ޿RCv@ ?Efxgܑ#;A JŘ8!4r,\Pq?YKm;[VgKB{ˎ|:@)Ų%fhTjeA=xR]F-(B3:-D6$z {_B ,X)@S䙾9ۛ 6wsLO6dg%5e4%+bv|;7,:urkDz} A~JYC"Qwes]PRrc L|Wt8ڂbÅ+yLoi~Mȼ9˨K*k\~tK>6ds Òc+vc6/WP&:j}s;RϘ-Rfu.Y"-_ʪtPGn9br#aBթ ; rɓ'W3|ۖ- .ױƶ6 Gֽ[g/{fn_鍀ȁX4CMcA6Q\)3/bE\[ꇲK<>JMN[=ԍN ^&"=Tittψ_K){um> stream xڭXo6BZ@jF,@%EbcюPKrHQWRx9+sN~O.pRF~̗<&ȉ#wmdYWɈ88ऩ"vfg~ktQsnƋ+s8ZRc&RAtzӌFeVu#L-^lk9wθ0dUKK_&u7 oԌݬܺQ_qx4[<O8\tE!k#TiݽV媽2\'_'{B" E1s2 I '@|\O:JwQ܁QHDOn",Mxt`&-iV }-ᓻUA_Vޚ['9zki8 qW͢7m^36 .sQPjQW];^9}opǽU ,/!m|F?V$@!LUFޖF%-zFֲrH|VS)8_7Jk'2 %k3P# CBU=UEi}srMa6ʡ% Ꮝ\ 7%n7X*3f-7/Ww{Q=` rKe-rـ:W#Lwݤ02ʼW]!|=]pD ?$ȭjI!AVօ3cCGk \YivaIک~  lDNmd.E!׬xl# , ^@pun{!i޷GD~!HæXħu0a^g^c>OY$ чA[؈ uBP@W^Ec殱X!ci<}g&̏ž$7\m4!TA>w @=\"Py:sg&С`;/3RuPI f`D"}yҾB'ZҗBu ˼QQMIýhQY0ñYVWzQِzMWK,/7]O#kJYJٵURAѧ`'3h3"-k dКDRjښVKIVeHNiN]*0KMEE 2)V8bD{: [5Xk:VPH]cҺR| qJնæV W<8 }B˒eJu `ȅ 㒻QgtnS$a\ Dn6Zh:pRVDʕ.v' 5X @0 / ݹD}g7䦮I2FbaB1ֲQ#[D3nQI=SHjcC{!xƪ33ۛvmoR xnQK- NF8_8-~B ŁLƯ*ɼwGBg9rجh̏o؈s$N-Ihra${÷pDE3t/ endstream endobj 1386 0 obj << /Type /ObjStm /N 100 /First 963 /Length 1975 /Filter /FlateDecode >> stream xYMs7WhRIJڭJުݕ} Q>!1LRZH~ݍ!;ٛ(Kx JڈaCTI6!fS%kq .:k!#A-F#D& 1.da} B C}QU /C`%:}t0>y2Y+;g*C.u3(.!~2N%A[ِDN H!v~KC54>(u3,% e%eQIcW8*.`V4! Jl+&1 gp*}Q*|+`H -QB4*]B)°(8~0{j1PT1%UbX){VϜa-tp`]#\eXJm>3UBE,ީ f'#'/PQj-cMࠄ GD}]^tH):FTE*{OjıNRډudjlp ѨɜA|bpgCUU g +C[8>qF|eLsƝoFC)p XY(YJpTxG_]2cӼoX}Es;j~|Trˌv٭vyCX?۳sʅ-a9zG7^`TNTend[u%{ٱ^Y,~`m~mwf ߲dxbäjFjm|%FEwOnq.bcS_|,i\E y+R|gu;xur>Յ=Yl]jkq_mc !N`S+orۺ[Wn~_xz4O=MМ-/ˠcEJFrp)5~{vrtr͂mƶhҌ8j^_:k-¸tBu9 ) qO4 +ɆLLi;UO7_ o2,--e3ӊDП\ }##eH1=G;[ B 'Em' edaz7J=@;E⬦g_>`S[ NB%*}1e|x4Mb=X& c<㡯 QH<7> Ҧ7*]7hdjSFZ*=SuQ]y;ԿygX4yW 8lܼ|zLnL"'|@>{Xjd)'I7!kD 'ײ_Уxf^ƓZ?z!\UsAG(:jA2|pa]}3aچ #[z`iM6,I YYl0X;>OWOp|ӤYtu)ٞ}w-~=uDe&PiOP^?Ru1 a&!S P+@#q}y9^LMː߈"dK'D\ƫ!Ż fOcW3%~wRT3!"#鉦{=/:׻yDS6}<>eC!K) U>0r$ַ8 gj|5dqGߕ(Qۊ Co@^N; #8}<[$ Xӷ }4)窒: b/CKcg\/-Jt%?}ϸ -"}"h/]?B` endstream endobj 1504 0 obj << /Length 2751 /Filter /FlateDecode >> stream xڵZKFϯ  oH"&A( 7#$eg.&%Rc)0n5QU]&Q}(e&zXEHqQtNS}(xd(ig:-uo`i[K~,R'ݖZ;:V)X˼~Y:5LÞ^!,#-P6UwTr|+\{dV?<>͵9w{Y + 8$i{ӣboj Ev/bNp=%uްj[/S7جɊ0M!8>,8pL5bBYOے&mo$ pofS?D:j?~?;zg,"ܽɄ) g`Sک}%)%)wkUo@Ҭ{T@8w>?^IFfIYe_H} RNiPy78BCqws;[`U6f:P{PWF =/>6H(>ky]L2):7[v]6 2a1{*,Ns~2btMpZJȶ-OH Y5a(g'L^ Y?fwA*گ3OpS;˹foM79'5aMOj?l:rHG%a*=)B5Lqba-ul^ M]-m{hY\ ƀ|xY{s.~G܂XvG570`N:CbX%8t wCJ{rp|GSzo .mʫ^~aq@GTٶƙSN GTBV;ێ@C0>y<g;{?' KZx^S썝Eҽ_@0^z@=v\%`u4ʫRV*5n'-u3\J7vHhfM U&a~2$'ǁos;exWBunPP yK fəZ3#g 6 X儹&$V|}|Tgt#ԋ0S\$b@HJjUU!Nyo Y찞 %LJWN|2_ז`:u[WY)| $ԧp@OU~+ڏ4I:I S*Г7sǘKKgʇ{ ^Jڏ#vv{HTbHz\ϋqngZ@l# X%*3n'.1{XKy |_Up_  Ox*`uQW>qP a==0Ja,Yˤ/O+j8nZiQH\O8dW?B^rx݉2p*Z'mqTkER@XS)ü{,2#n5MrU1 @[![S^zCyZge}O ^1:MV5BxWf*_*x<[zeP0$YJYQ O`w𔸂#wGMnyQL gO*Wƫ_@\DZ"g>vcy\Vs(=-b{C?_k6Y#d oK"@@:@;n̵T߆}A!v*+ny:S>"ʼn5Bs.WO1wBgt"s̼S؊7'/YtI*-`y:(x5 Y}a_N endstream endobj 1546 0 obj << /Length 2773 /Filter /FlateDecode >> stream xZK8me f 0`XAe0*%[jێAG4E$>YO䧻߽1xrΙ$93JN_*dz?'5, ɏ A"9; g2>z䧲8z:SVEXEiMVudeN/@1IgQS'*VxQUYOa(+:/vuTDskuP~s\zzv4y OӲ.ZL9U40m+|YcNP1!$KğO$aK4e[;(1-Ld7>YMƔ'?t;Yݿ:IJDzIH7p=ԧV 5s32e^PE[ 6 /XޤϣldҀM+CyMǣyJ+x$-dFqF 5QMCALZ; mrE_i-R&TIn{C>U x2 V%+Yؘ%!kV[ ~^)fm C9ƜV1 ȾV4z G(5lgV4 cFҙҺgԫd̤c@E&|[J98mQԒ%IoΫ='Nd>靃&1I;89mһkN.֙pxF5ѥ#hWسHVEIݦe^A;۩ѡNV[n:LAmؓO˩2*(gڌ}Q(joodbɄ3ݲK'Ui.;n$XА h+s)]V拊~tѾR Y%aJh(̱KbX!~w#r0>vyO,W qe<> `o7~RW?(*: xUE<ϾK`(\UOܟSuƷytwvR=t2kWQ,dS.SѾ-Җ_6UTt 'HL:P;:/|x~f̺͠Kӽ[0:* rdk ~luc7Ҝn9 2@%.[KX,tMe5G P݀]„ɀ36r98Kz-̳L]U?Ŧ@^$vB6 UDːeiH;T[r1ə4w@J(nS 3eYXbUXXXWQʺ 57t0[vW6U5n!&'oV+? endstream endobj 1580 0 obj << /Length 2427 /Filter /FlateDecode >> stream xZKsW| XYbrĮWJrXh\*ϳiѥ/͓PQͥI2? 9ҡE)y\amq)5ڹ"j6F&QϼMţد4ø+DtȵL.1/6$9Ҡ3 Y u̲ 2RE?eֶOA|:lo`BNX XUQÿ9˭%-PR#(0v bǡAU.mۈA&FD2Բw(:+XYI2qSm2kӼhxgOf[d=[Cs/w7樿yPc(5s6y8ѦuLIKOa(JKos-a.:Gں ?8.TV4G} {5ZȴQd?Š. ~n`d/&"ݑd!CNCcDJ"~N2jTR+z1*?ȝ{|zq!pWN=ʄ~Ygٷlwuk'@EGHZ ]za"Go'dv,>h'hA HKF}$c> /5vŲCס7%xkUWwXM-$BqFN&&_bwEs2TN `śDWAP[eWsa9ٳ$FYҹ$&I~CQAeXWgϫ"mEd>81 !ϓ G03/2:LmI/Y6()p0Pʞ7MP)oEv!a6F)Vb`\jrӀ /n; {8tӂWFKnioCe.|^6rJ^ XTf_rP9U2#HR{蕟  Ƒ| 7I93LеoM2"҉g DӰOjx/+SP#""wfc@ue3y6!UaePP /'^D@! : AE3d؀#lVKCv D}Uf/sS| (mtu^N(†"i 7)‚"ˆ2EsFC3T%C[ՖGeHNS90jH㬇R0#{ŕP'deO16'&n{MO +W݋͗ rgXx2֍kTյPܠ\kTC  C -w5oH)>CLt[2+ ^A8 D XW=95GHu"D-qQM_*2>T3YS? 2RBƵ'ats<6H_mo&QO2qt2awUk.U||E89 7a8"ģTQ;8a}Ss'UXL C15Øw`&ѯ1ilH LLi{@je#~ 8)PTT&aΟ`ä?aJ0?u &"6 HiHmr6̔x]P>ģhpxK,bIȢH5Gj<۟?lRװe9Rh/n' rCl> stream x[[o[~ ErC hEId[qR7AC F" m# |a# >X/Lz*SB!_FCPVrt` AaxxB&v4j٬ '{͇^H靈dQKCpT(gK%8!u?.ǎFhXMOOAsF dvқ w== 8v >c5Fl|  ba@ƢeeL/oXa#$6j#qK؜Mz)Ej"2lѢ"zN{Ph0X"lPY-Ċ>bEl#j=^LO;+$1A|髳Q(+n3YOZfu6Et;@.Ӯ+|Isϕ թ4ʜct̊ *(Mr}eJw_%-k\毭quE!HȍhUfhUfF4ΡqshCgjqƙgjqƙgjqf׵ z$xvҐ3 .7G\F^H)xzIP WN]P)Z~eH)n0xnt~t(`Mx 4<E 7@$ {H: Y44Mۑ`Ӝ,JN. (Oӻ`hr (e}Ep1Cy+BS{TI2;(HOuy$ڨkΆ׊;givs8َUY!YOy(I ձ} :#¦B4ybf Ԋ]?J)j/F)IXOsv͌Z zH彫DGY9V,z|iK);4|%#jB[{EDti(z^լBy׷]E`jx0@kHIPƇ(#,i˨>U*O=z0j`n%e4aѱh=J_yhuMħMIŭĭĭndݢ-њB5bk )$$m i M!48K,4ΩqNsjS89*́ 2{Kt;unMH ᆃو\ofJ޹C#&P6st~HIYW>m& SBѽymiGj8,pmw;$'|Ėz&T+X|~[$D{ @$= Hv)K-Zz78k z~d~s8녟Qp3ѱ;ͺ=f> stream xڵW[6~_]uL.jPuiUmCrIk'! `˱ܾckk9֯w?Vo-E:\DZi`c|Z'%p,>|Ywksi Bq퇕vt' A  g =HR84]>oЧUn@F2F0HH鿍 0;6떳647~z1 V2 'lN41JS=Z׫&YFY9h"^;Fj0 ܲAq]t6;C*3w荱=OTjK2ƚw%d(I$ lϝiU$ cNl/֩չ;*K%pؑ|@ٯdH¡Hg՗^_ɭ =u3Ā8܀0KjjǛYP$:(f&W:a'#HScD[u 0]_ŵ£FZĝy[ ɿ׊7|"xP$I%Fא* ˺ӌSHN#[ѥ_$)L1gQ02O|t 7N{ҕX12S['V釸AmM(0;.ɓ6yY[ Lr]`Ml@(ȶbpS%ѳtyDM?̏ endstream endobj 1614 0 obj << /Length 1782 /Filter /FlateDecode >> stream xڵXYoF~ׯ`( #@R4 (OIP"%HӼwf/qeA^s34E4zex:r'<ۈQJL4D Sd/_ 1)RAL5zP5f}WHQpfF%,VE}I0j kEEQy+FV928H< ъxќT)r(~4+$W9Wm8 ﴙ9ITvIxI;yNZ- dd"Y$dek0cI M+0!hAyqX |-q=jeknb֌ uqT3\]c-7KDHTY~M_4gsYԶʞ?E.roѧHxtgqUDR.a8,lp=OD4 itx呂@chǓ5C*N-}1VV| 1n.Cg:WXc`r*[T2!QQ<nnw2gfli4zo03el)S:NR03g"q }wB)'oa,z+J9QZ:1Cxۺ&۝Y諱[OړK +!];Lx;3^kMh̯m[SykZ]HH8"9XNKDr)8!b68Wqih[ӀJ$\ *Ƈ.bJE CGG:Yt@`Xb,M,=fi$V9*9&P쪳~E>? "T񦱵gi#DȼpOޞ^{諲j(PPhݱ.|"[<%S'3sЗnWRpK"@8M 䗆Bhr"p] p&`rLBax R4q}33هgؗ$g (4\ځ,ΐs™pxV!(GY^УlNUCb}r_7 &ik,kyyoָ813> ZrC^ !B8&~r%ջ*Y < ɮm[Bu((nG$Z|ayVV?H@e2 4JWgQݦ KMrJtϔ`= I!O'g5/-3f endstream endobj 1625 0 obj << /Length 1422 /Filter /FlateDecode >> stream xڭWIoFW`9 79$4:) 5R:J򥿽oJ$kozO^}|(2$S!,8D%x}Q\ ? ǃ0a(2Cq>|z>Y #(K3ؕ_%iڗFe%=;4a83ʅά, @'k>_=|i{ e5 0.sHQyQ=ӴrUH QeN[sp|yMϾ-FCt?Q\a؂8۶"Ğ\'SjV5ZMϭӲާw>bzNb R8Fq@^fk~eGUO #qQ7p|NyBG^V';I;8Uv.P]~^LoHY@o}7|`andÕ]լjŒ,bkl')|T2H5>f;%.G">[e;g$Uo0GW(YG>~r ﻠzL[ ntg^>sQ )_IgxVHCm0M= ?ilwU&X3řu]05:ў>:ÔFEp*߯ƶES7,V 3m&%Yu @~yb~%- L)W=xހQΩw])\?6gFPoHt%4qhm8ꝚZG^UH}Tͯ[G/Q[ .an'N W)8>Wzj!N]B?,`Mtѷbib_ƮfN|i/4 S[=bЃ#L+=. # Ms2f8%]iCPP? endstream endobj 1638 0 obj << /Length 1050 /Filter /FlateDecode >> stream xڝVK6Wh2!aͶȭ{, Zj-ɑl;Pd&M7{cnKm1J#/({ܻc~~bb)Ih$t;c'`@<6]<́h-c3܂oWW pccZ?P/ldM+/dġJ$ E "B` u d7ǵdnͷ˦KFDF[g2: tvY[W$YQw‰C8_g]i> stream xڵXY6~I}6 EiP"KI3J+]'m 1Cx[/~\^^s,O[n0&y-Kッj-?F"Y#KH1 Qe@]#"J==~Т6d/AхJ;Y A" XNgijL,]S -v5c%N~_nWjd3o*?(5ƐIHO+^ I)^,Kw BȭD̉&mq a7JI?!$!&7-~̤C etm10d..~=h_Z\1A(vﴡ݊26ip<\)bSt1Ы/}ݺ^9g.(p`=ڨbg{ceQ B8gv#Hg@ckwF[v<{ )o0? uZk[٭,v*% Hl0/fa.D,x@ &vSl'B٘GRn69}q;}-MQ+F;Z ivkGM+%W0p{]޻j.:-4oXŝ"ƙt+3].Vaې+ SPqvIÍv kw4O]媗+tRʺŏWc'(HBGRpó3/⌉("?1G>'_4)nJ}+<>,0fIJ*k0 %_XT⺭]s)Dr$`)q@u@mTfүԣR d:>!&'gW:c7e-ۋv;p ec endstream endobj 1676 0 obj << /Length 1589 /Filter /FlateDecode >> stream xڵXYo8~ϯk#c=ۢ%ѶK|%٦R\㛑=gx_/W8 3_8' <(qy+Jw(iDE6x=~s *a!KzN/:'"];Q tQ5"ʒ\)m.p8D1Pj?.D;<^^ω9w""ܺSc޺Ky>&a)dC15oS 臮2+ϋCQRl$*:'^Fcui.$BYSյ&V$]~k2ms}uoI*l3{hlhD(l|a,&blloҭeSM=FP 7VqRoy +~$^&]7Um?x[Q[Ui`%)1_OlawM1*B8x܄}[fQ56ܵXWVWdMJF{EJ )-! m_ׅ֜QC掷yR1_պ;_ h׉hб8R`\>x/n#>Ta1Z=fc\_1tlx9;DC!fWxxd6>}|7u)&M Ox ' GG=꺃0 c-y4y"l mV3WB2edїGޘs)/f%J܎0k|Sm;#8yW;$!.3UL->')&Z&kztBKVM+=έZMܮ!\²]k6%Txk]ܬH`H;kS1ȴ4h0% ?0~kӟݫc''=kf85Vf3~ }peFbҀ"Hy(ʱOEh@o,[$S|$?ҒX>2Ppsa7THf(e{)$ Äwt4|ڄMT ~C>tּ3J p>ufz}@1En5A@wߕ̧;̬Lf1hhm; 0䩹n>JSqƀI+Y,o (i;jWw1z楎hn/*A8 Kv B endstream endobj 1599 0 obj << /Type /ObjStm /N 100 /First 973 /Length 1925 /Filter /FlateDecode >> stream xZ[o[E~ϯGxY5RH}p7p {Ir"!g|<\wcNs6^#@BJ"Mh$ 1&:%QL d jyag7tp:/ٳѫ'f|X^nGoˋûG?}ۇ|m^kjWV[`nq33ziF-^-ܮfɗ櫯oY,P{\]-(k f˯ZrV^fħ nُ;ܒv"&FQTF`n? 1fo?n7]a;ӍNl<aF&Vs2|bqd!OߦRo ;9/1 cQ=Mb>mЮn+hWu %?N[>Ֆik+oZH :bÄH+uv>gL–?/O.J"fddKdbkQjƎ ђuKTEX;}p~/jH`+Xy e(>8y5~ʞnff~.ox Y1l41Pڒt/?տ1k:!{X;8+f܂胐׏eҏΜc߽Dg}\FRz-n2}t2]Ƒ.2hm&*K5Ǵԣt>>涑Ű]UHφaz?|1,m>kYQ<{2m]7vp荮{]{n[/4ܪh'[`R{rkDTInQXZ,wl;V-wGDȧMS ᵨ< w({j.jOnD^[c߽ pwj-`Izgt1$v5HЎ;cOǮ]uܰ #uNxr؋f)Mvl!op<1s<یsb],O|QU*fNLCy2"!([{A=Oۧ?}x1-_%SPzC:Y֗IuC ` oiQFF ,hq8b. KzPlv'x0|w菪< w`%ӓYܚKOnV; f endstream endobj 1697 0 obj << /Length 2323 /Filter /FlateDecode >> stream xڭYmo6_a_d REI݇Mo5-phBD,9zw慒lGIk7"3o۳wgo.`(3R@Yd5^~:|ه3vʙ?@(2lsrf$gD) >'G׫?2ޣ P$W2M\ҩҏZ"g oҤ`S7J XFekd(׫2؋"һG?|ֶU}&529X==@yIdE,6m^9w On D[ͨSJ5kb5q{RQ%86mܾi{O?̎05b6kgldCC<2-GMWiAMl=m^C)9Ӂr8*؉bo_ 9nn`ZO¯&Y@u p(Rw -)#UxUG<;1FxXUp*!^ڬ xV#Zr^*¼S6JD$~/Lx8\Z&׮ 4X$/[-p̪ 8Up;^;vI q9 M(삱z* mYv-NJ "CCzMݧ">dpHi@sZ ;EmӢءA`05S\Jj`.HJ+tIyDq&/yf1|ˡi0@1=rnf38fYv.DҪE2yziѡܫ2D~k 2lZ1jʫxsKBA)φG7uE#!k0|2rï-! 4:2HzEE"w1&*=Aɐ鰄i1]ii,8>N,A0cu}eBfD(x~0>(f>a2DL /OװYW 놅++72$2.SBE;0!~!4^Um&4@SmI8mtp-CE iۤe (5~HxGimyH[bEoǫ=ё ]'f;ǚg;[EJV۽:S!P *b4Z ^]ߘ t[>D#ե:DSHKLo)DlY(WR&q3p"C44ޯ}ӐTH.Oϫa r:7/dR 9^P3E$ƈX8WU+pi R+\vFGO&GcU$&5bT86IG"CJGްtuS2e1% 0U4POڬ=x\ٺUS{f["PX8E (kdnqTZD8gZ sW5n/'[pT-8bB _"mɂڈ }PА*,S+ p&j(~0BbG $?CJ?9/,1#/͋Ñ鿠@fp ߮}&-=w T oFpG,N7 $z b>].--vfm˷Yïb 8@3+젢pe1}t]{r>oGdvKKA m,GAb> endstream endobj 1709 0 obj << /Length 1432 /Filter /FlateDecode >> stream xڕX[o6~:su52ؚxhV;EdqHS : u.U$(ș>:uD$rQ{t|NWCOB{Q4B>!ᢦFsEA}muoáwgg rJf,FF 5'uRJտ^+95S}eަ+W1nԘzV@q YJVKfI/c8Ncrϖ!;Jl ˨QiҟG>#r+sz&/W/|>O/`8rRj'gƏGdݘ\\WY]&_rDc#$J;}V/놦o}qnTbl(:ćI\vs*ҭ qz<' ۘjJNNINkF\Ѣ(,^tKjSbT[J$UWq6c iPn{XeR%ϞؼLYY%? Mc+Eiqꊗ 4uiAZ o e$D}5EqPQ-el$q楫m~ Fzrk [Uс`Fݜ51ћC:aێ,l6ruUHuNar#$p&ՠlP~(_+?0Uͮ1j%KqEtoD@kv my~(:Zl=㏠~v$Z[4,˔dw#H\e,)fJJoё-? ڝmΈܝF5xݣguuvw//Wl[_{dQytuARGgיG'v֊4w$a9w#w9aJDh(yt?uCIm+I 1LsAӔ P[gjhiٰD\v@<&fL*MN͡~׻SM2F}oI_"U >f{ 7k)eu65Jq':-KWwG#6OAi8(Nîm{) endstream endobj 1717 0 obj << /Length 1827 /Filter /FlateDecode >> stream xڵXK6Ce`ER9dlHA$96&VɿCɖ֫MbS9fQ ꆱ 'y'6QDO4`qX¦M>-~N64JnW*쎋Ӿ޹{\Kloix#ʋrd3"wݴC : X*ONz:\hB*ed=eVIq's*:Lm+.VM;۳Hݴ4[P.H㼩g4+bMRu y,ؾ_QAJQ;Q W$S8)&H,aAI8 x7j6O<=<=XJ8f9TT լ޵]l5yU?6eZ\P ~ S2<\Wub{cJVo)Dj\";DI,f@?,hm۝m{_`\x :ڮHUKI6exvor奂Bs͊*k5NZºցc߼@I6zoS]]ytʴށ T+zo1{fOfs*`ֶ;JVZؑ`8Q|뾰ce[v[g`IxN f*TVBq:et&j\poM]]Fj /4S w Y#Zn3B{=4 h6`V%gfK[>`=ms2L;dkDPȦ|$='-׏BB/]' huÀ-QAcA= EK5vr([{- ; qW jt,8j!l|Ҩjc˪}qq\ :_}[cN,ȇJ%;o+mVɳǭ`.>]'땄|#9:S8K * endstream endobj 1750 0 obj << /Length 1928 /Filter /FlateDecode >> stream xڽYYs6~􉚉 -MN3ۗ4ly(sĘ5MWK?{$[{)Kpnz2om߈Qx@J"EZSܢ֪nnXVuTO8z57x Fo!C^]5׳2k9YTŬ=KWj>Cp{wDFP 3L#if/Jn"*VniA+pmBrBI?]} 5!Nb&H$ޢz)FRxOfiᅠerobbql‒8 $">h<dD$ |ŽBؗd#/ ) ĀcGc,&^a\bN4NSVZ7vӼOEfY׮:]>[X܂[l ;%& 烗@awa/ccwgbqQK}:' 1 2F{sP'm ]N8q>KgsIbLև[45S.Ģ۩B0 > wK]g>2cn @Xb,p e,5  kQ>  LNyQ(4JEp}Wa0/n*@8I P>8a/dT<1єGPʣT;γSt dg؛,1=!c ''篪S[>b+ՍBp@k;y!.&S@jcH(,==%H$a?}8sSm) VvTX7%l6"2Cb26' 5^~e3cVA:_ٿ,f*()y8D1€i1v D\n$[Z|Q |CYCJ#bH(5D/L)tHlV-WSYf ÍhB(J6Q'tmU6ڙqGsW!N-8 EچIQߩ0 Ee-iȅk9aµ0u_CjA2@]MZRYWnG{e8d#sg X>v1[m *n @B(h.ˬ]jG(u\LԸ\3.4p)HP[́(qFݚwH( ZK_CᅲKB)3&-K󷥃9 p4U`ҀUXj+  4+i"5-|2xHdL QR.P*3 VG7 / Qps |(*Oa5/iXq,4`!c[*=< ذIOхҳ 兀B 7\st3SL:F7;s66#fTMpuKB a#E,_P6oRepq"pǗ]Y?/({C8H\h= (%xK&БK`2(*!5Yy%#TKl<6@n=GG-!ה endstream endobj 1779 0 obj << /Length 1840 /Filter /FlateDecode >> stream xXmo6_t(f"Q6RuY6ՋCJvw#eQRk7(t/97vrzr~Nf1= IbύLHeeze'zL & JxFN%8GqFI8F`7y]Ν}7|nO F p-%/ LLLjW+%Z6R =qifQǭVuyc= Pc4 xX!YQ4$|ynUXТխWzlyE3% zYƒZVgmu VmՇv=%hD)M٥[L2'nʶ"_A榑o?Cho0q-o.ap~Y ďTQ'&IMII2`hRS64{JuFQ K 'MG%뒦key<V@^JHtc) rn!r, ~F[2 K/9&iK/UebjgMS$K&AYFQ[Yla"scÎ?jFzHH,_hO<+1<jOZA/=h!͡L{9/ #vdoz EskǑmY(1y["nͷujOf_\SpD渠xTf+k)@KU^ ьd2-4'x]52<%$,c nkHc$qf:K,5 \\zCAWӓ_n0'J|7 3g^\]{S8.SgEKds L,vת<0x&sþy]eu,Y/~دwBP!@=?ăFI3coS;3u%Ǟ86.hOB2+ve^ ?nif)(Qq3œM0K^4Z]J7%ڌd) L5QXǔZb@fQӇ*w?у '!>H[}쨹yɻ9 ٰ1@knvx͵]=mȐ=+YWu[],;`?(>r =\gMj@`u WW`rwe}Gs ]ag:%?} 1rdG_p$ּh[&jK#VwmX+!9@Rc>=ұr]E,JqRߧU8m8?G0xk!pkysn~&C%?{J,Kcz7sb~[w2 =ݲAvgWCDLOި}Q&e<Eb`0CB9;B@כ@llv]=W1bCbpM뀷${޷bszdwN endstream endobj 1793 0 obj << /Length 1866 /Filter /FlateDecode >> stream xڽXYoF~[) I.E( 4UM,JLJcb(VM5 $p| V1}o-}3NͬWGk?v7{OQ{ዟWk+jul+J%1 +w+;.^*D􁧼?[(k*W$<#ƱPkލ} S{J+h~n״_ @ʫ:@ue:$D[ZpDM$ y6)=\5gtyf 4#ӊ$1!$Ԛ$ZXRkk@w5x)Ъ5sk Z/ I YJE NH>^H o]y/пL5(4B7ՙ -w%8ݧX4m{@1/ugqZx7] $BgH),wl"} uB"@T%\oD01,g?zZ+JcluaLHb4[pN)r>%[¨h q__}>タKf8z%8fKB/4u-fcu-4 nnG.E5Pul",O`zmgȌh6ϰ/I&GM⃌M7ҡ12߇mrmk-$|#GAq q6|k +: *@cݖv^)f$gũ` _8ZnƲla4E61`V} qUfYJ+_4uaMŲ6 ;@d MUuJYOx|OgNZ_Z߂{WԊ7bvnOU[24$)*MYcݾ,g"zb.3- ?.iM?fW@Qm^lu"Ĉ9h(B@S ҖA\ԡ# j=IJ!!cSt(/WjF\yzOj!lL+ ¡:%Qk Mu6u.aLE`ޙ1uJRlAЌH,5]ւ@lc ~[EN><&d|LtIn}g~(Žc̩B 3v۷\)INrU`7f5f 2hW)X-`E{bjr7{8/Dbۃc0ܾ}smu{xHmfnh;Xr]7ŽfCRg:ެ4x[̜Ɲ):E8,dww#pܦ{ aw9I`e :gԅg>O~85}^V9kR ^ endstream endobj 1687 0 obj << /Type /ObjStm /N 100 /First 975 /Length 2514 /Filter /FlateDecode >> stream xZ[oܸ~ ЗX m]`NI4t,9M~cXq}ȏ~eJq">`;D ?A2RZ?8<<^w0X>?o&fp/;hIiP$ᡨ^%[An/trƩR!5v6,Tw' މWE2 o.TT7s6 H: EnV:% Y(Ǣ[곣|lI-yI0d%D?ӱtfgZHTpdHZ8 pStҝ_lfB :J% ;QI>|jAJ md9Y?V3d}]ʣJ~4tx2R#FeD0 r8 xc,X+٫g㺻bȞ3[ .DԒuwEθ= P)'5y0;! =u- BX1~~P~q!G*d+ gd܇J[8<+T/NeV?߳aUXCT+`(G{P$a*Gg{&w4Mdp=TeyZ.//e{v"ۮiZC]lc|F5k,_ HD'pOCN?_#vH=|H{R$j!W`Qs!FaAN ۪Sxk[u+_ b\W#2(PT23Lef*32-32-32-3'9@sqȠ?q1.͜SjX.>7yu^&׾Cןѓ7`WD) JmvX&Gj8Cۓ| qqٯinQ8PPIA(9. C whiMm  `6BAƽf;u*n 0 6X˦T`;rGbUS#@[0`׻@V_hy>]}}DݟA Iݤ˝9R[dܹޏXFQ*M LJL`ƒԉNCxCYJG"D(P:t$:WÞ[EXGQoz3A؁џhPݡsq |f}w:;?'jsN\C{$aE& _xR}ݞN/$sSٝ8>.WCOX)(Dn^L:[F$8 cL|)0,Bsz7&>[aӞI"=+Z#wRf(]'Xt,X|R&\)3ה$ѠO<;0tS6~ O Dv؜r=gD2#=u]w"꽲jYNٽsr.W F'8p|ѯ/fz>nO vU*gɞ"T9f_㰮/G endstream endobj 1806 0 obj << /Length 1991 /Filter /FlateDecode >> stream xڽXykߟB8dmu6d yx:f%ִlj00Ku*6/^2Y$L$Hb)2%MSՠ~pE "2."s>xPHYpo6`yè>^wu朋FeA E 2g܈ŭNEwxx,X}wWJf2JdZ3ZG>EFľ~_WIv]-2Z,I8Vk` &1ǝpzgXu``' p0*#fxI = ]1r* 2$URB8&HF<\ wUwiVh1Ry4aΠkA hZ G@LW5ߦZAf,;+9?IJ4Z(g8ٖ TgT*ejfs"LJʘqYc&3 դВI&2,,; <J$I"'/p4Y*cMw%R0nk>x̎Ӽj'ѷ9 \/I9M|3JܐJt@xdL9*{T@TEK1+9n|;} *)RrJiEi}^ 3/BHRʈ嶺hHP;MZr4,o7#9rr򻢟;s^2*,]U:ɪ3LUL%MYpĜ_~1-wvMN)D|EcެyZ|z'zxqS*,6vΥ0IBN@XH!%ZS]st*c *+b3j7t[ZhsmAAeq dWXV-j{|de!z j4n3g{Q]ql>S!B=\ѵI4J3ԉt-RkmRY>y j"|D1"WSrޝƄy_._ඖxBTIPc Y* j,Fe~9}khX4P/ܫn%(ihMyhe;Nwjۃ?S|vixRu:ǻQtD)J&x3ҿ^U6ϐ- @Z?٭C4qB6R֝R⑺ p#\qR8 \g;&O~xVRY;W ~Sӽn>1A0,M}J~=緖OYvl֟-Oؼ73); (&jB ~`X? {IKQ00^ǹ׵ݬPDe/V,K~A 8>o;Lch9Uu:^gԎ]?C&x'0=68v7^N)ua[7V~~N}hdhsNw*6vg@1wz /? *ydeWh =^=$^Vx*6 u^ u~D7?||{ԣ9Qi=h;9:d| endstream endobj 1827 0 obj << /Length 1810 /Filter /FlateDecode >> stream xڽXY6~Rk$RWMZAlЇ$Xm P:~o Yz&) i^3ǡ|o/WHw'^$w{里ꏋKJG+i?cpZᲉoξ }/130a&x,)nBH{[NWJ葮1ڬJbufO(ێ-^j,쫊ˢ-1BZn͉tG\yLa@ uP}]yݹ6ˮؔN]6]ԭe[cMYfy ɲ㑿֢@j2=vRHl`y)EvZj]Qk q4 v#xH@c Vu?;q|X40ses8wod.Jw{6@k`%L4 Q5饔Y缵lhZb!w_yv۟nw3 DpXjlêiLWXp#ዶ>NsMY,ixg%I}q8Iw:ۈsqzxS[̚hhMnOhC+rJ4I"$E|/jf$NcoQM&AWB۪ǂ$ åN^a*Qa,|XD#gWH4k)()X*䍾\$ӕPK,H[ %YOk;Ľ`!:ڃ*p@A+b0-TX6 S2pt [`C`2B mQ%7Qݞp$2 EZJDFIT$$MD,&P>IqXv=!BP!L,stpfcXJ:>F ]dYM%yǵb5%sN83s*#Q0jx[ɇ:\WòRjU®JVFL3Tlq˼=x-H<Z 惯 - $(_t/ tCF̏XC"dÕg,uFvX N"AYCA4U0#?rۢw[cH_>Tu@jM2hCBr(&I:33_euP%_%1hG$>5|BnrݴFv dKeBzym!fZ(KO֢5o fe0 JJJ|9N*:|61NO>:ڇٗ)XN!cF0sFt% F%.N1x yW@b!JߡZ߳ ,Z!.Q ךa[7Ό!aa 5c]Wh E̫w/_rϙgOB3~4~i?hEBpu#+˒$YP!\/BJA9ld 1`(Vn8 endstream endobj 1838 0 obj << /Length 1875 /Filter /FlateDecode >> stream xڽX[o6~ϯ02 v6cѶ]\]Jl:l( ~¸̝r"-3Y,l>:寷orH)\-F Cѕ+T96۷k x0!FGZF!Kbk) %c |"$f;kOn~Fp/<#ݮi 8EȄωӾ@]U̵ /rwkVEֶ*aIeIYa3y+s" ?QU֖zfmFF*[gy.gn_Xjp`eBov\D樚5} /B^fԱV'*-|`gI=2TfQQ~==NEVnGobTʪ\Y)(2y:b1K (MW=&rC5 YUyW~ ,M/1P; Z c_0,#-< <xؙ$?ҋR;Y>'PLk0p[6==j,DNKiF8MZvyKYiso3w5ij8\YXyRU^ \k F-j*ZbC_ٵU!l'35yQ骖7A}"ʔ*!iV/G%mR@,R bgب2)f$D5ZkHOy%QQ+ V x">dC) 6$Vk{9܎6Co$tY4*V؈t[(ZNR9,}Iwqw0|SӅVF-µyUt~F |SլTJ:U!_[3'hp*gqMG,%7QkJ#Í1͘ػ;p!̀{! ><21vc/Í䦮]o.ͱ:,4J]>#u՗+/r(YraZW?:0/g{MZhqgW4ra ]>A Yq~Bu?*3Gkbd…KMmq`6@ KhujlG!̍A [u0w 3nVҷ%2hU%>Ydz(1aYhh2 ÓjoCTkTd$.-&b06GPaIiЄaHk%SC;[.}2^"-=0 S5/ǮVx=$K[ᢖ@, NDWPdE}5$)J5`Z zSy Wb'<21C %Go!l.(I5QR] ,0IV+YN~|ev-]2'N쉵Jno鍲\4JGth9`1qL81{ѠVE3 {Yż%7~GΧETϋxւp`˺jd(NOUg(7oBR=w _A! #\ Gf\=(jݫ*٩U_h95&k%&^3 S*Ծ>y胯!N tKT3`w* _c>7lU@* bpsl9. 7׻1;iB endstream endobj 1846 0 obj << /Length 1241 /Filter /FlateDecode >> stream xڽWn6}W[,`1#(hvS`_ާEHB\R;Cq,zy)r838Dq* Vd"V1I,fѪ>sxy%呤T)S*5^iPha5ka7x9ˋkS> ?F`. X5߂_sIYcpX|n阂q,K$K-Buۛ6nLxǷ!JX'ђǬH 2 m%NcpnaCYzg&gok4qojIgσYozhzٰnՎ 7n7V< aS4.*q''귚B[I,63cwwڞ D/h㍖@Uc˗0pT"(w <ܘ^l=]@<7TA6%u_.lkHv7oMX|yb]O&fؙ/,$%z-B?91g}2'Z|ؒh1v`!HYc$~DZQ⩺gcw){1b'p ňwTe(bxOjK1`2DA۾.Ff> stream xڵXmo_!nezpA%zW9lHlwCjz)u8<?~$A9σqyPq%<|۫_0D3UwqP"xKG(?\}u(#gVnEb<yڕ"NoYXOc"hˍ>Lw G}KMAp9S7 4Co.TX[p}[eENl3Rk;x5D}Jk>eY(u#ZE#y2e;)G=,鞱2ؽ`wY8m# 4RFZajU>|w,t~Yh;4/'gHyy!"歫9J9{Z$7MM}2%ـ^,֞HWl3 ּ4/?1V%qnEb!e(OS|<5MExndo9h}d49_R݀Μp*bDjP<{0u*l,bqښG2I0Hcqx"9*oyj3]cL`cZ:5HБu.ۦjF {Kb24_ꗓ~2p`==3[8A_݀]G4͠Y-MZ̨!&'d<4mKKz՝F Eі%Z>T8OJҐJM#5udܲ 7$oeiWQwXgYTrAz'mKKk v9eq9̎G1hFq7@ptc%v%xӰɘ}P4o)en6._ p4c|t± c@xu@"e{v<\y)z.@lP0eQ09??5\.ȳH̅en3(_^I ! LVd8Xy((Hṟ83(m񿚴vNCD " D4pc06"}g@=:tYNcr;"Oyt_zBWpQ7=&t6xcGɨ6BB-d8HKmj(gŬ6ơ݌'eXcg9X`>Vn#]6sڨks."Pड_pRW,sMeSg-s8747Wq^Lq $iՂ;egq - @&r%Ɓ'Zh d8ƗiبBcI-I4: $[,D,BtVzf˥{7 u {.Rr0@''8fJoT '>Gbݸ_N @ uHzYLDϟt5HBE(a?A}Gqhnh@{rk3\/gz5\ңK2HonY ݉nO4sTC¯rmM-3YKn V6B_0Q$SƟ Oأ/ ry\=U7 GgnyI &{aIxӚᅏDo~{.uK MAgNgVTgb/(px\jWuӈ%6%8V3RP^ `' bfmr#:8O~K<# r?7FAg+$t$-> stream xڥX[o6~ϯ9@RlRև[2-Zma,9$%K$kyxx.߹xś8`w|J Hμۏo>p>QDi]v=I94BR/͏\G޽!-*v]ڬ*~P.Ygڭ;]4GѹNP{j$6kNת|ϜZ5]+J7K8r2xђL<&(N `f]6`!'S$Q^퍒"02 :QsI^u6l̬ұ˞<^6W_ؽP8:[]#gD;pX_@^QJ^%~IURyck7NWmNmΈ,{ V''Gӭ0>8.*wqݕW~:cռ*7Ou]0N¬!ºmrL3r˫㦮j*yaƤ4ݝAhc|ORZC?% 7܎dZ(#" q+ $|(}?M 2mx |O!atn, ~ e/[KYLD iPuΥ0 h[ .j۪)J;f9Zο*LN[ nzv܍mqɤ+"DŽ(6XcgtiZZv,\`zn\x@(z?=)q9`D2}@WG[!Ep%}٢m*g!9*(7jG/ͧm|x^"e"޴K `mǺ=e(\PCK;_#9죌K(c%ôX1- '3idmf{/]sD֬+|8q:\.H<@V7g3J v2ֵs}TK~4d=+!~7]œ 1#2݊It\vb>81D1,2Ipd-|HZu1e;z[\5EǑd PGf;4hIy|[eVS2 %>C`^%"`D t ~*}rUN'n2xEQNYz!: 4N |p(1]BJhNa~C F\@c6]612/,"kDf endstream endobj 1890 0 obj << /Length 1575 /Filter /FlateDecode >> stream xW{6?-N,?B[hHH)6BIBy~llrGw${{.J3Fx;_Xqe$Y]R£KbJg{_-E˶[~,G4$I wT łOdB8%gY^_jWnxl==cK9pWq{j ]WRKneSAwvq+_[CnC2.d"s) IK[e?s4!?#m".xxfv@Fi{%bh;U\F릲vڴM#Ft>rUӪC&bw٪]wrw4eO9%X6dWdvR>8)Z²*P;ڜD e-e9Ie&qMcCM U>EkOr[X{tV+WGԮRިeUӹoxց,?֨KuQo*mȁK\&>^ ]ۢ a!8=!7JyVb%ԉ}r2K~{st=Lx]ijɱOΨQNyyxz+8v@lH+/ "{(脾0NP"B1A q1cb$Ká  y9Ax3hRP+mESD$`8%eӔ4+3ʯ9Z˾N75gRԁi$ln{?RN$BXlݰ58*!b5s;1ݒ/!7)0M 1m>Í\3gV׀1Yղ0nޫvP7ΤdƫbS+*پ9 ,($kK>792j ͍;P\4<gҲ(/c ާ)ssh ;CPE{wy{cǛSvTA22j|\oL>$7]a{B [gle;n81gĘ}&#Pu`<nH endstream endobj 1801 0 obj << /Type /ObjStm /N 100 /First 970 /Length 1958 /Filter /FlateDecode >> stream xZ]o[7}c"g8!@ Ivȃ⨁QER|UǶVuv/2u5<Μ$ )Z(Z*Q"2[ȵ@qXp %l)a.$[$$͟c#q>rM>tG%eb,]@Vrϒg>,~v$k RaoHR\+B:2##ȷB7̑'ڟq\3V`_s7|X;4ƻUgsk!Y aT kcQ⋄R qeZT|cRS?|蠖"|ֵ[̗g4 °%In"` ʒGdA(ĂgP,HZ`nLغa~@W\s_M0R?%hꖢ0gV RH5,F Z]V]6ujY~:P^رy 0JR'FR|dR,jܱ8g`>2S¶q zp#80?Jؕ(fz[.ߞ}j\Z-Z+ #'բ8 $RnI\ŋ0{ 2^:_h 6$w`O6O߿ 7߶?-l ,V+>j\,Tݟx9v[8Ox M+Z{LTL{oV5&=cݶrbWMog}y_v9Dbۃ# T52:~f]YW~^_盫&A}U0}"'1!8D.֟CA$v!5&S0n­؃[SLX5τTJDqp>+`>N`BG3鉟g灹}>:'R$ODϱ0aàz@iJ- (kTc?XtRČ>@x-p8=qdO"eb(vÇz)-ߧ'hLdžݪP+ ED kB &b= d;_.'rϨJ(=@$|zNx,n0atv]L, b:qZ 227j/Ԣ!Vp36)MbBD%YFyTCIC!Lz& DQw ,n9aSF_ZACQޭdBb R@45`EX:_B)Z7P(a$4VՇ)Ӏ (l)zOF${p|~yStj~`cכ4 !OoPף9S7\RD{JxRS,.W*Y)]xg.i, 2UF/ԙ:SʔA@"g7Q$9 )q._y z{w7djqJT) XMƸ{!?*5˚l:$:t=tzСm%AGT vCT/9I s<?gͻ_&}5_\5~ pXMWbc8!}& ~pE҅jT>w"d{SOBhu).*;%"p> stream xڭRN0+#H7hnФ)Mhq)p@EVf3c 61OPt 1*cZ1Hi *\TS Xs Eù]'SGC ^9/0(]7~q\"T:\JyL%j, r7 5h,*a> stream x\s# _O˴?=ucJJզYU2JNOH2 /[_?Ko~aHf,cK~X-67?lC2[=#?cRkW&]7fsAl#_j1K|w7-|`4-4 ETVswTZpvؙRcl-[{ T+ȓ)B eY_>XVx+X6/L .yG<0#napk j]T98g\hTFO՛g* 4py3Uiݔ8!֠" HIqRWYiцZ;wƻ[ GzyYuɀ@;4zy;27ʑbHꈞϻ&Hc&xad6ƒ3-5)#ũ cHw{Xɓp ]};Ԧ> ~0D``DHh͊/ywAUZÄ`Υ2%Bɷl-tWBͱY$дe-B 2\x(!/ Ե❑MPIqnZ03 1o 0lq)f@W(S1-Hb2d4[%a*t*zyĥG[U)ȄHs,N4Ǣ|*WDtǴR"iIq$7^}~N~cߧUF%KR$^Ⱦ0ʓąZA ρX!IOTOǭ0x{E5Efi\㝃#⒲q Pf:igpb=Sw+8qpҨM'4 qs\y?ő!ME&5Og5, _#8"d3O (#W3"yipvvꚑxU>2$:;>Q'X#dHwh}R9x!Q ˮښuTBSqmE m^n3IjHn >ɘl[f]yF\e_VEY6yQuH[N26 -!Z{Z_N j xNpc($F^𤔅3M0VWy?K!p}Ֆ"jeӦE=鯃WiG6D~d#Ј\wwz)([*PH^=y1Xn耎 endstream endobj 1897 0 obj << /Type /ObjStm /N 100 /First 1005 /Length 2733 /Filter /FlateDecode >> stream xڽZM1p*E@I0$:(&0"Sc,rw8W}BJ {r9PW8(AdpPXsU2BQ~[Vn0`sFʡW@a2V(=HJ-T2?S,,1#:? GvlF 8/ cp^A/ (VTT#UH U[P# &X#PRxxg[4*x"N%M@J'R5z{ L˽VphOysw1|6l0XLĽg516D hkQx9o 擷"'cn0%4'bNJĆ4k3-KU9 %b#00a=oKBy YjyY\y02#j4 @-t;-vR/l0F$@DP̹XM)o<9}^`8矅ӟW(*ZJ$݇7o^|4c٩`#'äŸkOއ'O)"緞"")mc`h:c?E`D۷߾/ow?e[|7A;ߜݾ-ο^}uSxIu(AK-@8m󿼻-LƜyszo7~v.^~yB~d0G4ӨpwͳWogz2blD-2I_es󯲙Q4>1}e]sߧb,Y>Ҥ5lNS#ħ YG䚘Tސd3~4"էIXYHb,ޢQt2쐨 I rR wPx ;(CյISqbSUȟ&!Amw1DЏp6",G(ˢ% 'SD>M%vc AX֣ }ّȱ TEmRmgoHq!ARH(&3wzl}'$leHR[̬n. %HN\ :JؠP8 JuU}%:(Ljm^ΨL[9.p@h 5BCB[sRl%*tC c@nvPmeohԬ pW9,HؼQ)PH*Zbz/rT UWK ȉ.:R/I.$ 3z,CDJBE^^HHz:2I),+Z!,ʠ̱|z5 Wf)fipc<<11FupMshKo# +ň,Yv(oiA <.rcь!T( 4u +k hjUk4l9ݮHʕ|+} *Cc9^O;3c@?2ػYjE$BK~QQ*la'&W 9lXpmt^ fX/Oa;`JaB yIyKyNyeH/92w"{:̧IBKDUۘ=;X(ic5uP]hԑZ lk錼aKGrR;@֠$at6P3I1vPz@J{r3xeN(}72nuk3%=jK "dՎ, q>+%H0"ad_ٮ*dBdI)2*1?+M8ʌ Tk-Q2{[vT!Ixqםr òXH$$TP'CN:/$ZKT\'hʞ+I~ ?gl.2Ux&QPFtfN'F%9{sĄ H8C$Rw&NOa'qR-,t^yqV8dZDivwʘ):n#UNahǼ{>Me }d`wa-z>fGjܱ^P{K{cDI"pfv8뱆zvq gXBD{7XM:|g?oH,Ui~qh/1$ 6xl endstream endobj 2212 0 obj << /Length 3362 /Filter /FlateDecode >> stream x]o#_ P3$y,CW@Zߩ>R]P9'pE8rīzWW_|*ϼzu[ (SYÙYZW?|?:4ocWגw>Z_[oWw_\s#+RKE6jYU!/Ɲ'ڴfZ潋K67K\sTp I1##w^Z1Rf)WW 7Q ř20kUuswÏZH}ѻJ2<~=BN5GΫb^%H";"$yH\=H􁤴mŪݏ=q0 uPfHHnb @p_lx-!XlX<']\RL|m(Hu )(n8on/|N0 6,*ERn 1bO 0Hn5 `MP ?Yg!h}1)"(]]z]P4hKx0cT2pl -+}vE9$F|s[ _g!~EѵL{4pцx8zm"̍F4[! w>b2?mG)_ Yt/>x`g') 񏐌6;"<7&CX(& ,,D{KPeGBqUarN(K 'U)ᗉ 3p9g1\F3)}|heG3z-I0r,~LJ c{ܯ77>'SXĿuA#| YMK;þXe(ռ) v( eu2=7FeE/6`vNI $ΩP"V;MØ:b?| 0xT")0+@eYt1w<GB2ϥI?2՟#?#|HJٷs$mI;[xTЛN<CRO t AvaF%)k}x9 Ny]=eB%B[ Z'7L[|zZK"5Vx_THj`{D y&P#-.B-[]_mDG`[^ LCϯ5}S rwE7C?9R<7hlp+$)]m`dLqy }řq_Z,O 繛ۮ-1%g;0o>ی^`rrYMHiѶnƟP._0Zy[Yyh@͘Jɼx)#k 5OK T6B[:_?ޓD5!xK8b1V~/G)"Qߜ\YI3vQ:RD$Q gy|"J"f "WPˆW>Hݝ{_׻M/%5jޗwfH~}}x*,6Q|}‰ wz`=_'{C㗠bN3.Zj9)nxNv) bxX8: ftgi}l-0pb5jYG볏KբɨC,,>\{(#\_Y=ۮkܮ^1imzXgM|l ŕXqȋSqK8d b@Ta?m %=l +,m tr7X 8! ZvRaAf 76 9?sckΞ3E%faO3 q[iR9ۇնޗc'e~RZ endstream endobj 2009 0 obj << /Type /ObjStm /N 100 /First 1024 /Length 2974 /Filter /FlateDecode >> stream xڽ[[}_яKOץo $D`bF9wk~| igӧTU_>cd YƆ$ MՄ K9\4uOz~``UliQ--ymI}Tܤ;O?$D75,y9b\Mz*lT] Z+QЂm28FT82Pk-5DAZHN~VR/xxsk'LP~ 3Pmj꭭_;LVf# }LC]:l% _vqMѕk^༠YuL7 8q”41`$;R5P)BD&Jwe ? Uz£p~%e.EN%jЛ2Wja fM&0"^MƉCo ,Cu7i]6ȡ7Eo:׈;zFQA!U:b^[v-Ywbl7/`$.$.¬(Lxu ߽xqwzߟw>ޝ_?w/MA(oO>YN_1? j3e *׎>O/^7UO>c;n :amTtNR#k$o$0rDD, Qr<ߘDl3 =fcde3٘8NΨ$ o;ݒA_H'k#n$g33\b%:jVhĭ@J?MأgL&= g#n(T()+*80BdODCV&z\aH^#T _u֤|ɇQSC_>(D]nX \UOh~5EPz{ xWNW_L|LokWKt{9></~IH 5jx}_ iSCѰhhјO d d d d d d d d d d d d d d d d d d d dddddddddd5k @\r 5[ @nr -[ @r={ @y#G @<y3g @<y  q" EãQѢѣ1ȡA JhPBР%4(A JhPBР%4(A JhPBР%4(A JhPBР%4(A JhPBР%4(A JhPBР%4(A JhPBР%4(A JhPBР%4(A JhPBР%4(A JhPBР%4(A JhPBР%4(A jhPCР54A}= \$kD)JgR Y\ـ(jUI@bHm&O6$mzj(hO]19mBrX]ܑ۱;pK[a?[PXo6$%D~KjNXr6nkFK`ɉDy7P`dCxhXqY# +Ah)+T)T[+#mC&3^2k#;Q0g&:{fR&!',1l /TY\\PԉQ6FYQXI^ɶ'(j$KkYk6!QUScO4J沝 "05)pxkI0S/P3f.9ܵ . >Pˆ*]kE_q0xVYfpG1GhEGi]̎Bg~Ti+ q@OXGVĵ8)pwqDa0#Kp\yS7Rx3fbkUos.60? H Z|6--[^ b`1sbmƠÊB[6I-$c9PutAK1;q!VqhWF8l$!Wiae k5/wym=%uʱ6&o|3,x2獥ގם)crw1PgnS>\L$nmB[JԦQ % sVO{6XD %_Z8Fy2`~4w GzFN7 Lsou,2ʺ, . Նy\+~)/ϵT)~!y0WwN ZFn($m @u\ ^P}E{\GW&ڣWn̻s<뵓wYSZ<1_w;$"Ā^iC;]bB́/3C}oJ@3!u&amغ{z ;d>o c ?"[cf^ @~ (3|bJ4y ($FD; endstream endobj 2214 0 obj << /Type /ObjStm /N 100 /First 1014 /Length 2178 /Filter /FlateDecode >> stream xڽͮ$ )L6jG" 81*n aL~ƭZ Uy(RU{*K/Db@['=p 4VcP-ubJy" )Hk1D=FȘb$j4Quu\guJ[-q12k; p Ec$1 iGjհF-I#Kbw0A a0N\CpeYp*$DI,X5 nI{[E=6wq IIU%fJẐկ6..1hbaRcYjn$\ܴZa8~WKjVLjRskqo-x:V fuܹZfaKl^*lhGd >8T΃rr*ɵ]8[ A_[rocKnFqo>b>ZXkK̂E4 >蕱4l;C8-!jo!201DaGpG F#q#-bA!ָ҆0E I 5"Ɔ*h\ k k} kn?˧t/_n璘o?}_~X?o4>#)3 l;89KhDKFoӇ}__~7oqH?d#P{}Y aX:D)/5BZ YLkKX)-`\7 T;GԚN8B$gCzOB=:d6gh0wx:6 +E^<dNE4턅O$HG*"$v$-Ǧ?XmT}t,g!eΣ9ѸjAwh.`@x7sE: |p}l:V$gw!=Vl92nCCI;6&K*U ʎ-sN'83⠒9|`4TO@QLȟQL!V&meZMD_8$< )Ru8ԁ!@ mPGQ(r; NC=Z)>u8(w8+C< U<`@m( +P!~@h 3i"w+Z.+ M3rX*(TV~ P,C9* K<-+lBtU4 y}4 ,fC ) a+g/fvhLlm-c~B2hħK ϥ>`9+mibAA^! a vA^! aČ` :Q#4EXa.hD>Ɨh2*JQƑUABB;.)+CҜBB;&)+a߯f+qqh(#ޏkUخjDZl}/0vZdצbOUsbKUsbKUs➪ 73v"$V&6~!VK ;`4XxUsڰs9K+ҟ#v8ySjh%ӷVI#)Op>gЕI^|[`{9zFlƇBnׄDt= a4=;A`*Yev86-qDHvWOUՕʀI(A,"i$gV QX5:D@gجϖ?Qiѳc?[s endstream endobj 2377 0 obj << /Length 2890 /Filter /FlateDecode >> stream x\o_r~,z)zh^{XKk[=YrvZjNKp8?O&|?]_8qiГۉ9Sӻ?\=KY?qw~݇/~e7W/dw_cG/j+i:BΜS2!蓸W>LJfIaqnq_lc 3lcJ$$5[|u VR h\e/>_r!1BFA1M>\|Of?Kч 0WZbO(\[TK6%)Y-ΖneP .یC5ѳ<򮅖ײv F"ɧKD|䕓S+(%Bt*=$Q8~˄CS؆3cTdE,DvlY1`&*(KAM?u?O$NXδmc0KBwGXB&T؝p;pnwRR;g.%?P0%RIbweuWD Tr(sZ16ʆox7/v =Q!obeEKKy<)Q-T2 +_I:s!iM4=U*)N_A^rG](ATSTHH*םߎد70L)PR觍Z1ElSЧg"3\M]^3WđzOUi[x2'dIJzgM1_N!Egf;qڰ a"%oc@2qVK admmB^fRj kRT#{RBO헿Q;vn|. =v**eDJH+~1e#;X`VMun#B} -yRɝ%%;/Lr3Rf>5rE"["<˄Ͳ"ceA6֝ek+2ε΋Etx"Y_5VVo|9N#I!*N.9`׎>KRܸmf8q*GaVKgB(ChJDQҫKe1_c}zclQn51h$j,F@1 WV@󬱳;xcz;b;%*0jTé@5)jNVYn;UYD&&{$ I胰[k1Z&1_Oe9J! e#v9Lè0% 5V5f1dEĜ2+!XqH&_׻jy;mb1h%=,dp$i3A!\t#Oy\|]_]8w5XmY۸[̾w#@Qi篏H@S+:wn<>dٺg|y) dI:͟-r_Y??Z&CTtl(H*Vu5fu:95=慣vyzPN?WkR(kΟnpx)°2KZ[ʆi%\-o˼4L&͠+*z]B[&=  B6M!\ŇʜM풮 H &A7g벃ILfsJ-SlՔ@twײvb2}@@"17|MI&N4@ff'zniZ5|۸<:0l'N4 s˸:e^7"'qՔfN~]I[gRvWRZ,Z',ڑlοM)$S ODHm/G8OUQEѪV}xRC HI%8j$RZxTe>R/w8B% ں( RE4 7n$Mz9s;6}KOQ3OJU}߲&Jm}w񖉴-OJI9"5r$omm"tBy#%8eeʳr;q[oDX^@\IOJs@ƵȖwWW٦EFڑġbaXuNY'a羷O˩V8Wpo!O4*XߢK`4gCM0tvuUTz9=8cf0ͼq% ;t %h2uq$okBi:+x_v*]>_> stream xڽ[ˎ\Wpl,V`( EA F !ˀ9=c/- #v\N=H*c̒D hFM:6,xsiiFORIrdpsgKl$4pe~~?\-9vkglLmEKfF*u~)y2x]fg]W?O`%bJ|*żu)HIM(fρ'Qgs%bb6U[RJO2c;ףZIq^I}*ưU)9YkɫyZZijk#.fyQ璦Hdg4Md\ a84Z-Rr9L!hа=)fx SZQL9s)_D֢6pФj xXqX` 0b90FqaYs`<3qV_VU1=XLJ46 9E@hQBD[%,W_c vb4=J;41&R^;OwN_x￿G?rwhhf4dO/^7UO>gwhz`k5@Iqn$Fv,q"g֌8 01r<:g>NA΃ Ws![X$LwZDqBbj& $pp ;IXV(5k6Ic3&uLC{L DC5ilA8"Ͱ2zNu:<3%Usx Ƣ\!WbW0 bd0p\\1s"0&2d?_(8i&P4;BR֎2Ǚh3L}i,1p,w"_|y0XV|`L  4X pc2Fʮ1!yE,tf+f;*AC'Rl@GoˇwK$O^Q(?QAWW/+0;}}BCw~o5O0̤zSW߾42۹1*HkU~熴hhD>DCQѰhx4r -[ @nr -[ @r={ @<y#G @<y 3g @<y DCQѰhx4Z4z4F4YYYYYY94A jhPCР54A jhPCР54A jhPCР54A jhPC`xW494A jhPCР54A jhPCР54A jhPCРQoHQBLgG.ϭҭҖc |Z80qLa Bcj+}2(;(y.Jiyh(vѐF~<\aH!ZE+ H',PFpD$oНᑐX\H@*&qm'*~Au$3xDΊu!Q)v)IԞ=&j<'fM|d),;7IuS\H MmAౌՙꍐ $J+AB:ccJ5ȼ(^wǜ?yEF;z9f/ cuoi||ҽ>w-A8 ß(orVD7IԆh&6@|"|}I> stream xn# sH>ddܞQ-3![lI 3b+Uf37>2F)2(;Kqۇ'ma ?~wZӓ6?g|ϋfVRnYbW;=D)`K !&:9 O~50$Z1biNZ?冕X8bS6/|u= dWW'X}ϊ-1́R7uSbSS*kɴJn3G~ \gn/s"B"R)0A))G QEni"!GPT'-YbtٶvYA[Tiœ *n./ܸ N !R9:BtQ~gבf7pG)FR~R q3bB7ܯVb}fH0U,j*|@نR bBut_EҼ>F!yzE ^W[܈dXRa|[vWLv' JTy@wf H~G!A y$~P=eBɊMJ\tߊE_iesJ]7LGhFHg0,j`탹  *]ea#ZL mB1lGp ՟YSW/GRܵ.V`5Syt5 &`:+ DtB#:?C"|u H2rP<nlH(!\hƍGQHஈHHknPZWXV$`nEϐfyg*FPTp =ȯb%]CMZrwz4@}iLVZ<)QuqZVXQ!9D ɛ:}Gϰec^e8d6ũռ~ɹ 5ҹPNT< Ck$֯ =Wb鯘TL߶W@Rt\ɫ`K>5>\ 3j4ڒ&绶#)cFPn7)!)E\k*J(cJs;u6牵$K/OlqPĿ`(%$a1PZ]f_S'6=UP4Q7( 4Dn[wgsFm56i0!!5 !lj"M!=T*߆?#ֈ9z-y94e@x1.kVRz6R`PW;| /Zhj8(ڽ>fsK &wxR@Nȸ˲cI7W{J⶗k,AX1[Z|?,Ӏԅe]R#mRޑB˽&p\!bp!Ow$gFGFXΤ9ñ+kj-G*eQU娍i;GٶzAzzG^ ㌴k5&⢓:x閊X 1Y'3čpRQ/$Rn/L Y/KwpL{#/H4F!jSm':fL/n%VXErxށɊ\$݈{E[F}'^ɊjN#( ,R/ne)qo\Cr$ 9MK`p0>i[މ<;mOįz.nZ#^+x- 77њl<6yofc/_`+6Eh%)12ėwꆑ֨O$vww5hW>&*_eX@*y J:={!۳.MӧmGad9tn6|z4;eƷMuk; R?@Ol endstream endobj 2379 0 obj << /Type /ObjStm /N 100 /First 1014 /Length 2808 /Filter /FlateDecode >> stream xڽ[M1pXŪ" l J$`DAcאV34=AY>.֫<8 @qAxB*\KF=UQ vK|6T Ct9g$,ReDi$&'iYL2n%iVUj sTvsX٪$UM$b-Z&^OFeHՑUJ&c`a,/d5I MKťxHMŵ?ms1m52m:Ob)?.mS6m g}N3ʴQ$swG+ pˡ(iXţOcLZiTWmn) E . \ڴ{s7S=Qgg75ċ9 + xA8sn.9` xy ؟j3 8??>oC&4]5.݋w7>}xx|;_O_~Ǐ?|[ʻӟO9}懻[h6Jp=8eLM/^ӏ725X7C;.NHbl8&ٰH.WIB0?qAWfCF#i`e:\ Ӟ~ L3ܕܤ~-t &;0ge1"Z\ `ඐؐrzKB2++FrrnƔG_&!+ %whx#u[<#G kBC!TFrb+0]Hl Ԁy_!!}b#q}}O@(YlD x)(mfT%RWA:le1T2((͋lXd0e n>!;'r`Kc[DA|@IY$G<uxz`9"DZƵ˫ eT]KY:- vGD]@iz%}-E^zȂg])r׆Kq@p}\ L&$̐R+ B$>%D}&A7BO*\TKom<@?To 2d.J )-oh+|!&+Gn?Ir%o4^0g@be`jsPIEF?c(7*;)1͗D=8GxEˡ͑m̲\xeZCNČJXf ̭ZAD) 耻y=WcHHe9R\'*9ppth8pͣ1"PIkSPd=ù_ߊIZC@e RT9O:p?٣+un]8\J7pXZE=8x(7pX!O_8C]nJw K|E9Y6dy6ai Fw khVCf^ .͸:Ф]^Q͌H\z}_ h}yfT6sf\ƕۺ-2)R93?GJc?sڹF 38D+d s,N~#Hf Xy#Գe Q\b1p\pMܾq:F&/m H8fdyY/ǐ@; }!TNk[1 Kj#P&9yE}61TQ"s.Tlٿ'R9#gL(@>{ƳɄ$6@N%r~Pn尲Ţ .7^w=VӲ Yoо2CoLnݍC(} endstream endobj 2529 0 obj << /Type /ObjStm /N 100 /First 1014 /Length 2353 /Filter /FlateDecode >> stream xڽMe+L6*՗I d{gp!1E}W ́tZzNUuZi"|E(k,tk$Rf>"LyÓaʮ&7_㢈ɧ,}6 w>"sp`=L'); 8.kgE&`ʚl2X̢?ފ% MNoa5Aw^#|qYLT}8f\WlxSA.1eyq~SXxLBC׸Y|RQQSfR+  f` 3ȥIcIo!쓳@iK.%9 19εԹ,ci mi /Y:`*T#bɑq!e@F^f)--CLӕTeFreFe%l1yzU0߆NmzI%06a0%KNW'V_҇DpfٱR|V֟ak dG}K$=Zkc@@x~X.~/>Ϗ?.d}v|)?*^­*3ڨ:}[>|(叟\.(}[ 6@GTlVmQ${Sk[B0دëO; Gt k ^SA72tE$Ļ4;- 1NJ6+J/nIrh2@yw,(1(5kYFZ)"nBޭ›# ^Rd:1(6Bෟ3+\1Cld0n.`@,vʰȝPv䨎@'BI㕛p=^3Z@ -D q\5 2r1AZQg_mn#D&HH! mܟR=tN L1fȸ!l'TG@t"1N/i ؏MB6BtlL{2 |YtA0BT%$r(n^lOe}K PT5Ց< &c \ʟ6AlTU}F;+CPUcIbkev&9J. lHBdଓE0 A;)D7~ivE!@kĪ6Kn҅,a a9dت ]D=E!ߠlC L*dB`49kgQe ,*[\LtCͣZ|vhᆔ'A d0"y20bbA4nxcdYHx_4;r.*XK"'Ep(C jkO(cu$[!ޝi!rI,)> j^'MR@H)C uW0X1C؃H;5͟H j{$flsĸ7ꡇ ;ȓ![M:bة44ϭ.2|a~M$%կg1={~»dj9 )pAM)y`R) 3r-%GDм&0J3^_1"C=y.mݫlUUO{H#xhK*gIcT!Pn($OeHe0^/<)$$ȽnJ^qNkH9(t"(G69&) ΃.YPH/iF(; %`F m69N3H Y ]xB(Klx_H]XCi#tAuܩ dōQe3쏙!tulZm!> stream xXkd7 _c{-ْ!,lzX69lrhCY,ad2$37YOO$_Ѯ!,B* ҝ*Di(5`)^:rj{]R,FkKZȵ ) P!{ZzȽSKp.+cR)@IQAI#+r|_ԗaBC> m(JRr1E: 8"A3A1@5:('ςJ (h:xʆ\僗*]l*SjH-<ӎ=*X+\i8 2xحn ,_ruXTi}vJuRnO(yi43R[T$x6".i&0ȭ(cPcg<&bpǀ0u$Q e#4xWm@hsLM Dh;BgzB$ M&b`rlVO11.ie90>6J`+ j3==G.UZ/K|q"r@<3 tfg8NP'bPww/f^0T`δ\%#W8vDL^yy7 |f# ]b"3:c S ޅIˆ Dg.&<=%,l^%턐3' KG!a5t> stream x5;@@E@yW!^jBBJu&WJ0ȨcFg k7BzUmx1mA )9hu_T # endstream endobj 2540 0 obj << /Length 118 /Filter /FlateDecode >> stream x3135R0PT01V02U0PH1*24 ()Lr.'~8PKLz*r;8+r(D*ry(T0 ?`AՓ+ ,L endstream endobj 2541 0 obj << /Length 149 /Filter /FlateDecode >> stream x3135R0P0Bc3csCB.c46K$r9yr+p{E=}JJS ]  b<]00 @0?`d=0s@f d'n.WO@.sud endstream endobj 2553 0 obj << /Length1 2986 /Length2 27138 /Length3 0 /Length 28627 /Filter /FlateDecode >> stream xڜvT˲&wwCpwwwwww<].Af{=ɽ3ͬY꒯DAA(ng 5u6t6`gPX:@k,*N B dag#$3t)>;,ܼVf9, esCG{ 3/O1 ȐdJP27]-f@mjlkhd6燐5 搅=5HOl ryg*j|;0M\hMMh4ؚRSж))$@GP%MFLD2s1͝y3kɔD*G[Q; 3F@3 [\x8LrΎmfFff_Jabgk[]T\D+ع ,\\f7ߝ*Z)߆Rv7qW;?A5P5ffcFP/?Oj??_v_&:8K?*B4K73ߧI]HG@Ͼ7l@&'Α*lb%lkfIh`ll05vSW2@;'IHp0ǚ- _K@[  0tt4@` 3+`b319L.> :"5E&DD&߈ $q~#ǿ3I7b0IF&߈ $#Pt]7E@?A~#Pt]7EW@U~#P%T#E7q@\4F< MÿHtD6_Rv'P-~D߈j:G @99Kq?V@a[F 2v֠;$66Sea@33 av [Pο\@^@@kmhPL{iZe;?ÂT~Jwr"{؛m, @Ю[A'0uPut1e Eu13 \vI|aJ2(#忤l rCfaG koGb, o7:؁-F耤o!;^#qsIQMt29;h Pnv|uP\-Nv@P4S? (T|ߜA82}VlS%sO1Zy04T]jKgȤ2wUdzOU1~.` &U 薋".#QAd¸NIrh)"qpzO4h\e!.zmZFD(g&%?t]?EMwjIU*VՅ1+5qϯgKEK{zИ䪙0 he‘b(Qݤ%Bmyxߤ׽טR%5𕢆FT/bѥgdvq 騐ŏ)o$pѷK-zsR<j))̋7\`h|Mh}PN=m#x,K&dˆBgF4&AHڑE(зz$ocBn#`Ƴ-IF9yKs9od#h>u4, ODS IfS?teo&2}©ְJZzA6Rt͢b"2n 0faM,xnE[/EG Hʶ0 6Ur~Dtne@T]4$dž`.)»O$)tع0.P\$[m'~'z5P{H %a֎8~X4lhzjY;#S`9TR`9F76(nub缨+t9=ᦀx]o&6>}g.QrJb> eA4%I2p.Y}JÐWT !์lz] qDzôZYg\LVV,€0Ϩ$lb0J6^Ya|kžhn6Y |߯+ٷFֹⳀh]7W=_Tƺ9R|QT.L {;dWqv{on^P'uO$"6cpNƆ93>}MSt,!8=eG27b`';?37XH; 3zX{1ݸ"0omBb8jm{г gfE$\@sL QEHy2#g9fJn:s#u`W!zI~Ƭ|>fsAӒ! )=(5*2٦V۱bٳ"fW~'"[G~>na pI_3ImØT5i]F.DݑVk8OzN{l RxV+/XFmYY(0Z+>hn ,M?L* / 2 Jn `]/}lMD*Ѹ  YgqhD;v2q1V2\Њ^bB3bg[ioM#pլx$P/1-K|6fQ_S@92K/zH_8%FaaqA$>7uK^e?o;0;b9ߵ{MmE hݺi H9F-o06baT`洑MWp:dm.2Ow8TN`A(ZGB6;zs%yy F.B|\/)jNwմnB Lf+?Ol;֤A؏^~&N. AK̾W|ܓj2E 9MZalb&'k.72c|!Gz'*{, *)ٕ`-ɓ?r%@\:3*S`j1!Y\5἖55not˞7 TƩ,}P6c`p>f˧U%]G~ô~zt?b4YW= o5DFEݠz+;.Qɏ3RH*.)]>w~5_geyO(9raj/] Fq{+g'Dp]) .'~]V)4/!bӤ‡;Q 2uX\0DB)>N52(+\Sor|m*Z\/uʎfx^w; I\K)M?ՁDǼizO΀H^v0vR/%YzYuB'?7:} eQE\Jbm/8o>AOCUiצONY[wÒ܃ͱfcBLNlW2WxmEpÔ#PX !Q}6S=*d ң+"ѧ_Μ&ySM"Ap9pI=ִ4JnOagj*],_77[HûQi+ BCRGsh]xJ5,S4#XWx`o)n/ͩbp51 jO>QE? ycģt/mp{ڼD4@Y?@;&䚝E!IíeK(}ux"1||Ǥ[|j?/uyAmn%E B;Z$V:M\46@seNtfh1_a"ѯ+ FPr'ia߷7{+%{W$k{(FEvR_d`<93Ԑ{85Ǭ?`_XM]CwS1VjZDwZ)g:t_FMU2\3GƚEDMit\❤>:ll-'~+ChD b. *6v|U kWkm_$43Z)zcsK my6b9Bw_雾v»Pm0qcrǯʙƟ%pxĐ3(E=k>%9ϵ%+cV@qҚ}ȭ(: E q%j}3ϦyzC=Z('>y0Mg"%WYCMV4tx-^lD;VRyŞ"y6UJͪz{7&T?F9]T8坼mJjXv:Za 3[?`> Ό2TBQL,ͪ BL&T9gijM&䘷N*4oJ׭f^keeR 6}S i*5jۮ,GѪf})_/W6ռ7j~)Q!ǚ GƩ5agB"?t|N-̖4kxb)9n56$sņyrp/)& v4BzE,Lhm:"r{T+ /P֚+x*+pdbȧp\C؟q15l8_KTz0G5-I"?~T9 .& < 9<!3uq$osʶ+R|b7>asauz6[iC.$*^p]"PÊ݁v~T{Jaڽܾ_H ٌ5Bm5?: t`.`&Qweu ~vR%EKkewg_G}* 5`Z_b.k#w [Dl-^W4WlSuRU1TVHdiq|f=J?jM,Z3>$XP*K.b&XXG%Z,!s)Iv-«oltF#⚋kP7 n >שW" $-b~A)VVX[zSa]C=Y,]?mxD}nJ3ł:׼-qj?DZqbM~=q2q՗P)(~BHㅸwdM ΩZ߬y,q>>(R"Ջ[+8Y\_o@4*g5oJQjĵ}7FA9_B=CF9gcH|Oz%%ાd̰rLyELjkda^U^mn0&!fi(L/V˹HNY %}gvsȘŸG^Gj 2'#M{ 6'UB:U,QdmUw<;#7mYJ$ډEp`7."ʙ h[rYeevs(Hl( $vtU t=A7L'3ڻE~P Bhޓ&_䓡+)ߛ6@";==Ҿ]tW=.)tHֵ( nypJJ\"c`LrW5[-o3-ܪDmk ~%iL!7 ItɃNVdʇqeVɼx ھ>4FNU0 S+ҨdȷP:uk 7u gSq^0hYD we/ (Ǚym'q4YP5T;M9Łۡs6e5'ztFqҡK"W ~M*:f,RHz %OPI=܈K3+gNw#! ]Se>Gcl5c1_D#=nmFQiѷo W qv& _v8~U(AaW#U m:cG"ڂ5pƜ ?xS12>şN1] -H@ʖ,qU@GFulV(@MUjEĒ`а/*Mi?33/M!{җjq -?VC,F"^=6I/%xdcVY]/5*rC,N+=%,?)xGeȶ@T; "[N7D}-# 0RF A[aV=KV,]n'u 7|bWk-S` lM{A.9+l DVKۈĢ>y= (^);s'u%Bt.RzPߤ` Yg5%i;82e UHJx+~=pj֢U<,lUAU$@{A HUU7XAnyhTԖcX*MAX4J)U,H/a~70˲u}"q]8+29W̷LJ^,δ*xL:)=\STjJqR@ohUғ[=}߆0 QZ @7=J"jN~O~{ H0^0&2Ş{K[W@u _ DϘJ5ʅB"{|am-v5 I|Bx85WBjuTl3X/{MꃯLpbkQ>u<Œ%2yP'7d}R#D~ ҃{ē p;Uw}ٜ Yanh?z6^R "EeGkFvy7 ? ]#zC}ؗ눍bS5(r+/"qlbT ΁CxD⮖J 8W<Ai^A6FE-EBk[gRiW[=[spH kD9mwjL/dEBcuf1#ŭ9IXlx958:6_T݆vO|܇ ]S Ϣ 1B-L|SsOwVz"a_}c+QBy<:8@v4\U&u߈Zw̛V +$%10kPC3Y~֩)m';Xי- CBLjs}LYj"Y t Ӈ{]*44J,a5`=qsR_řTe9Dmɦ}:-BjBd?G*R㋹qRqϟ͜Z3Sk>lCxߪ% G_̎Ǥ2M]_ r[Xw>~ ;]鯤U/nlWj9a,OHEG ;Lh2:|OGuɝv՝BP:ʀe\Y04BܳfHA ` HqJOQSCfdNa[x3M%_UNrZEz^TJ0nB1{S(ݳ{ț\tGh݀)A=SPx2݊ !$bj-6?9K*Ϛyrrn]Ͷl%̺`j9Z }|oſІA{nbC &TEVX2.au;rJ(&ߴ43SPľHI\:3QKKF)5Cio-&)Eac+c-ԥKd'hg߭"8b(0%є(C? 806(+\7FȲv`G|z#L)t5REb&xؔ;yL<8# _#=V%yɹ3m _)C^m6Zthnkb'Wy\ڸOSk:GSҰja:`IdQg7{,+:sY1Tw˼C,k" 4(uPܶO׉iXMa:iOLM/| "JxuӾ u}HIU4YNbUCƠR1}#|/MlEu/SSM I~G8wBuL +_2TNbݢn@N%|1LݾZ*B _~Ϙm%9Nx3ɭЦj6DZ񈚕YB2r})AJ,S}^Hot9}%;HG[fdz1rԟ yGPw@; _|yO*|;f1\LYT.MKA*=93܅A+y#3pprVKڑt٩2l\uAf`>ϥI&kQޅo:?WFXK=ooe,K k s%S9lT쥈[-Y[?3G:9mf Dd&h&Vo0oN"vMc6s[T@K5k"&`k_8$[Xe46n!륾X$ģ2CD%?yڂXy'"1.y$7sS?I/P,i_䷴z G0rxIգWZXOzhթBLEkF%RDARr,=bpXnS`]}KuI4-4Xpca'# ɲ㯑msv ImmOJ:@? sº & S;]HRwI˼mr{E2|~Y$B"` 3ՠbhzez)6tIi1UO_0L#%փu4".umݠ3>]:}N- 4;9;C_5߸x>x..rrɑ 2c(ewDLIߞBtާ(:Ir76Á.XLݪ8R{aK89vAwӄTI.5rhO&f'԰ԀG7YK̼z6KVM)!(*SqLDZ챷9ܦrݥȱ^C;0-ϚGJ/;S" a1ߧ4WJs&mH_ٳZ]T$:l;>^*.hu=F2!p4-4{F`Ֆ6%yP kAEk|8vb'MdqZId%qӑ=ˀyf" _cER>/h#Gw]OCeyŞz\ߙvK)BPi`nSȖ䜥;Xqb9K9r#0i~i|,&ΊY3h`$s͗#GsY.rbAc2^b[/eNnSi!bK)|ۺ!=bqg^H2Sݭ-΢e NCA#"PgaZB#ߛg. d(I}n@#Gu4wkg1φ 5tu]K;խ?CcCi!ת$/mo,fc6U-R?k8$!x m,{eb`cjEʴ67::;c_ˊw>Qu/aDf|GpJ KáE ,E*_I+kY1ecr.p>~ҒfHmH;@j$tU?qͩHxK$08P皿 gt(|BcS"g`Y>3W,|!G?zw`"X)"PKfk-bkoc#:ۡDBS=2*88e?- ^ 9fZpbu`#]fWĕαiF"]ܙKDVMI-VF%ތ/zA dToۉc.su4mgHk-Mqa:h5ȇ*O3zΚ"qnN)GxUv3B"e7L&; Teu%J}ӣVtS渨gCrsTCsőeP ˽0]%3}s1ׯ91_`GsR[,v-[)wȝ{E&J#AIkpf6d.׊$[0?'HfDQ72N `S5gU!0ZS~ L^Drڵ0M@D.Q/%fˋh-~=FS{^WZdاwNЅPtVإK -0"W-HZ<d{uf6Ԣ!Vy. '<)G24MT?{znb$DX}FHl8 nN19[XSDYBV׭$Ͻ>uD'}Q{bRcqh㔵lnx(T/7T8 <_6M;vm|(6+zi@MBO>2!'75S tZΕ AfIr{CTI$tJDMmY$btb.q1|^'Іl\1 :ZoJ Ip]☔GbKZ/";GO<|/@l ezһ-tЯ΅raZy|9҉͚0ۛdžHsFH!s3Mxge P!u: <T.QDa7eJeyǒϧܩW#ar 6?B4uU& {pJU)nn%>W) @:._VUY,gq 2}cϊvR:`XY9mG'H`R]ZWyxRۻm(O!H:M[O,l m"O϶Gm޷FvwY$< ;9N1+ G:+(˺wL:a)D}[IJ EOսy-sEY j*+Rd !`"8a_U-xvC1ܹwnUR\4T<^$`f}|OS5Jp]zȲՉC6㿄H ʛT5SB ? Ҫ̔M2Dt"KۚfM'tl#0=Ht&M›? t}/1Uϛ S" 9mI CkH;|A\Z.=8^2qArhtu˴؍=KM~ߵ䌙X*)S'aHl9)G۹NrRH ZsEtYHwpͲ.gDŽIVEl? eը~OO )",~q7Bo`[IP|F_&>Ln9w>)c-'C'Ux~p5*暊UY"R!n)=0<%ʟAW?6eF{!߲h : z0;tC;E6bh7 =sR)lwU_,4=5$E P<$k^.Psd#.Um1o OP4!/"!O'-OhpG3"vQ]zA]pj=] f;ۉqe^oL\ɲ.%.IlӐУ -*T~xq^1 [SZ0tCD9}?]D edP'BDe9ήGJ3p|_*M&_큒f4YRj֩ݏY6bC%9k$P>_%Zv3$WD֗ޓP+l: ݨ6\bq4`!P4Vd% _$CQneuݧkj3 S(<#Շqs+2WL0 A(5azR:)IWWA}%*asGuCк0Y3|b`c)Odd:!9 .̻URwB` ]t3X{ZpQ:N;U%MƏ2 @~rȕrb`Y{> )FB-K׸ݚ[C<'V4.=Uɨ!Ր/y`>dR04[3WN*YI}@gnh?1" ן,SW& #Brpp7i=SAme~@+CUϳu|} (d S`)t 1 i KnT]茘]3yZľF.RO'sM Mu_iCr(nGQF(PH 4K(JYp|QDva&V-/6SYOtRݎ0p-oBDE܋װgZlf֞R0[{\"K(jg; Մn:^vpw+&Z=rH{k$$e[fxR|-py٫xdwE^AH&*Rf(#ȭVr:3'Gh}}+;nUdY IM1_Ny RINo\N@g>MNA@Z8?r3js{9}sóQ_ČDޟvgg\l_bN~\vuhn,(-֞ `bv⼡}3]W/Coa]G@+mFk^P ,ND~2,f\ Ӑz##i7;wΒNyq; G-NHT3#g3.n%C_,iPO]u̚ӘF0 B%n6y ֔ܺaեQ#/p $ @癉SvVE Za/ADSgQ|2rϊ^l \B:0ǣ[ij[\6j)XA4qgOpW<"GSaYiR% k`fDG3O82k ;L()jZ:rMug?څ*0O-'lHlbšz|ڞ"BU"9 LL*.T iGAY#U("@ˢcRv|!8D&QųdGD__ Wt x(A)Z RۛS#H RJS)wm! ,6>G,Q[ج5i-$RaE.z#ZgAJ#Hmٳ,[z;pPBnCcRf \b 74¦ jɄ~%nf[uZ"(x5 @_w""8^K&L5гSq( -Hal]2`0KN x1Op#A >al}}ΐ7C>I %{潚x}hV񢣘BĂR$hBrg jNw߂M#b9Y O f3SƋѱPQh{l 3܏ly|V$r]3Ul2`$dHBKou.T <'ҡ}Mu?ʡ6 zyBĔd }ۡr%ƣ9 u"V~#+D5fhvc7_e1sqo:cW1l&$bUۆsZ'T /%XЮEN_1z&DN~ygg3^0FPHt]`kp\1`W#)Iݓ 0UiQgS[2s$FԾO&,DLA\"I ޳?aЯFPdQ5T%h,ZZs8DO|}ڢ>do/~$$3An`nnԒotIM k*Q(|DV*0HP343g:K%[y|5G?춎hSlXUn OPřD &vPwFz3U n?C37LJ"aEni.J^Ir_sOJ_b2'06 mbѮ]J֯lc&S6H3,)"PT`>>tA嘆R@*SO#$3nye8=Fmj=krrnG<)0*sPWoթqgYȔzR0KKԗSljhY<)MvB4v{}[jxes]؂y`M*Dpd) !3jV.p<*nQ'6T95ZT/6Rk jf"bjƷ>g|ȺayKU?8vQ!Ҽ}RUHrQN(x {IU|AT?| {tI4I'zn2MX|fq?KqlN~*8Uj4fqh(b uw^B=V5Y OoDRcI;Ǿ <ʄ=]nD[!jrO)_ &ǪCaq1 p[Xy؈w޸lߌӻaP|,7d,7: ҆K>Ē|nhqb_/ٝ$3f[76[4WvȚt88p->C-xˋے^xcڥ+;hT2q|z"'ǵ΍ q#J`o OtfT-;"#ЂqS [fe'ϧ|f}.|X [y ?R)5A**̟Y ) oؠF̨A f8lјB\/i/0qlת dPqfZbTDM;:יc QpP諥d@<0BU1ՃSUKHcuRb FEPt&CG,q'F%Y9yy]}-vbS<7"=L+x2"T ע lxm0h|3^~|'uþ@@) LѿCukpid{}u@^!i(R '=}ܠ /ln"NcI hޙ\Izղx C6cMz̨-] O$ؖC|Al4aqQ3rLm p˓ggν>PRʥﶓXDEanT X c%_3{.|=#՟NSv=*!UKG&(IXVJ芈m֑h$hl,An˪0jH7[N]=OCߘs~_\Bv>5$ݳjo3D (aR|pāͨCLUS7_ hL|iE _a΁ˤ N,}pXڏx$7>: jfJPOk}uw_n(ZOY/:PzO UySKn7/OAᑗPΖ:7">vvgM_\`zQ gjn}nb&:X PG{JKsՑR浞ON\UcHU3ݤ{[@L`; 2}fY|q&q6&0$IH;  IEē t,7e%+6;̙\κ:X?ko1O b6Tg|[dӘa(Tpi N;7 qVw$s,5}o_xwYC :}e+VbuxĹp=}czρ₟@R2;xXe Ϩd^dcÒnUxo fn!KPmƲuw 3v;bda&Sђ]EP3Gjz2\ 9 _却0fmh|7p1 i1+]K;J}u[qل?|x+WCԅ\lsE RO3vDH6%3azbnuSO&%SJ)pDž]'X63!Jx_RCp+WkJJkRu ~IW$),; PJJD V`Ayg-*57G{.fA'y]#:{NGl^syʝ> e+]3 cDoϑ}XL Yϥ'z5f#qf>;  @ojgӱw :HJ'Pٸ8v r=Xl\H+S(_0!m5W!WE Sk#\P‰UzfbDfr 4%QRY.)}jL?aڛﴞu#IlvGu2Ak<"rҰtSQZJX0ںj8jMӮ J \ppj^w Zgp XO?3'l٘PIat@퀔)rV-9&1h:5۸M!p㧥"\z$((,XQS> $@NuS2d>0sEXrrJZˈ;;Y^<0(;+B}RoPrrT]g9M:R"@ ]c!.ēmYÐi*/o9{'(R:RkI^6Ec2xZ+zaAdHGnR{7HuEBFA1kX=bfG՟r[ǹ'~c^^ISvO"x@aA cWc`hSFp^>HTٛ܄&4W ڬyb(vV=]Zotϴ_^S UƏءBN(!b!kuwi?ȧUUrTD;잺g#%f9=_sGXk&/N1guId: %y+@.a*UL TΪ`Emt 0 khfp,0h3^Yv#\( Bi늿 N ^Mލp˦v)7,.Eٵ[= JPEh>W;zgB\`vټN'ׯdh(@{h;'lq[ꡍ$7{7fFVIhT)ԴKS$4 NGZ:;*o}]TSh>Yaj>iQ;|܆N^ja } I^KJZ]\=Y,`dEn3)]~r)o|i- +Bꢱ"l'{c֙iVz 2_O bƅCL!Q,vv;%\dl˸`S$ϒ3縗}?fC*fgX#X,+_i%@{D{(9Fh7\u I'ia/j`t],No2Ws*dud ԏٰ6._%E* ?\ % H2?peW{㱗_֕ ZPd8Ai>BX%/VVբZ.oZ 1=:rf ^p2 n6qs\8泇KW[K/64oSc7}-$D sēAAo9N Bb Jٱ"IL##dF!ɷ*LJǾ*sPqH=2 ؤh3ty~>,„B;5qM)c9tC]>G]wԼW~@YOaSϕc #ݗF>V]z!׬7KCux8u:, }ƽ㧛Doby%|p.nBjl\L3_ _a im$k3S eua$&5hˀNT!ZAjN T&Bg1Ai乇WH@ІeULG2WvӔM}uj5$o5 G>ӟ2nrjgL߶pJ54< +zBJ}wj#a4S@GX2R%`I `-"S9g-.Ɵ(v:|}DZȎn'M^4dn.#ˏ+@)-~z?tQB0BrVRo.]􃉕ZiݳrNW̎)w`]T=P:M47[S 1w]NyTYdk,FI%eh_c;sK܃ui#a)wqSgZNLĀ28P9FZ<.iޝ1Hz/mِY.݌ςߕy+Y LEXa.efp4S*]zvTGUijuPxMN?1OSv~Mҧ & v7P*$DMV #$rBsp5oi^}~$p )MW4}h%aeϛ$8/ xg=Ig <3Lcr%MFĶoV%+kM24^lfg'T8Sai*^nj8_6إ?JK ni{?f2sjR ee'@I)WeԂ$\@RBv@Ź1س˹}xܭ-O\ۨ GE^qCJL5ژu3;Kp乵Tr`T,i *s7D4Ϩ[Mo4fK-_~eagါ'Ekhz DcNGSv5ŅCP;_r)^"_̽sHJ&9r[6YV"XR0S ls-ɁR,bRhD,M[|_.M~#5#)D[rGqsS8r{6]C ueKĊaQ3n#K*Z,h_]"~dfkh^M,ɢvӈrh)#< xvIkNK jc婺#Qܼ^ݷàŬ:bMm;?ԉjA4;\ өU3W%*Lk 6y"t}mXfI[x͘ 'n4-"Św%t1ANUY9(rgڸ39;Ni#4TJ3ݦJn '2$B\@N 8b5s\>~A-wdMi"Uw^1X7+$qe%CI6Ż%^Ef&o2&9NDW65hb+U!>K,~^ԧPsKDm︝. S A /ܒs\Ӻryƃ WO̐ԃM}{-+ʢDԦ탤38JxlDYw:EǴ}D;*ue~yJjk6suc?›`SEPY(Ge_)kDb endstream endobj 2555 0 obj << /Length1 1777 /Length2 11053 /Length3 0 /Length 12170 /Filter /FlateDecode >> stream xڍP\@pki]@c;-,xp 3sWW]}e{ڧɕ՘ &;gf6V~8+ZlKL rtCe 2v~I;)@r.667??++?G~+ ؁% ` Ke309M Ζ ۗMmjS0B Z:;nnn,ƶN,G az& r9 (ۂn vS1wv3v^6`SӋ8@MVdXO&_{`ca;_޿p665y,`@<3췡lclbGƀb**l]"w]3ڂ윝' vlϓy`;3E5. YɿL^D,@.VVVn6r7aC/{=d 8;|oBfcM& ?_ ?]֗c^f;8_[?+['.qx1sٹXl/ %'9Y,4 (>(;0 ɷcSud;h)hhj*( 3$jfG@۷bj4I:~YYwKsдpJVFd 숿J oh3]1{dBo|3o%ۄ] 6:R@zGpv.5Af'6n(` փΚF`[+~ x̺ g]MUi%ӑ ?RipCԆut̛h{t23n^g0{aFC(2zb~-GD/An h;"𽬑_f})Vp0h'Aa%0.(JKnPA9MJmexn9%J';]%yٓ_Hw h76vxjx-DNt# ק"Uq:уG Qn7o6tiK Fg7(H_\+55 _!%Ocjhx7[G'gtxF:3@B kc% |o--WmiMWeߥQ2慷a-n)Fi`86QJɃȦ|B LΟ$WR|*HppJ*} о xwH51HÅَaܨ)*s3_$o8;!7w3p9aSW$Q@fxSx½4#E(M:PLWd|!4菡0;Eh/k+&q`]cB-KzcY }fL.Ura6 e0榇F)xl*);6v(AxAfO\s.66Fw,>賷)ɯV>XyIU5ďLJ/weAloH+TV 4[)/~:r9 xam:@7pɽB&r<ܑt&^Q w*2J|H"k.u]a.99b崨PN@۷y1(iJ֧ŒW\@PXrKguK=pDKx!8Qz&\\~l2Y~`!`԰_A,9F}O-<*p==iϾ6~NmYDgsϲ֟~FYSԿ ޟC0 f I~si,) rF7SVJ\qJ %ZgP{H=:تK8M'ڒWjYAJG2Ik; pǸJA?|1$_&$z迓/K4fp(yFذBLKS}utiKZr(04pUv^,+ o[?T (@pjwt>pHbS2PK#ۂXMP*)]wYaIo& .{o`6Wk7&6Bk)႐k[A70 цq5)>O-<ڌb]%M/곓nkqڣkydqaR lQR!ŕڌx*%X oW3hOI!NsNTKX}(G)E}IWuPm mn=B 2N//<2?F1%@`rڰvp^F[MB^x(LKͱI en6W`ŨH8GxsA/)CSFDŽ>&ﳘx^<;]V +e÷˯f]lymZy" >5!'  \|:.%N06\RUkqysk3~-Fu?dƺ(UdC/ba2gHB%C4KoWsyޱ nI2MvA7 hg&  RJ" [(DčIdv&k9O8,cUà'K6_t%rlMSVhZnLjiFf㾑Ӗ:7ź|DZv6,D!wyՂp>Lb2ؔ'[p#*R`:4Јrj#n[Z,[R.c#%h xq$-#^&oY Apӫa23moU|-O?fw-DeKQz]51"iʫÛZ) kZסs Vba@iB5)û ,ʂee/I'WsR$T]XiH5A0CZٕ+cycJcl#m j9Rҥ  Ah5"Ic=M̓Rɤ՝qq~@-ݺQ.ary›SN> *7$װm"+PAEov̅'6<$ P* }uM_ ۙmvx?)bQif.g\ґ'T?Աؐ/<4bt[7Z⺋+tqF9 ^Qn`U|/ osvDJNx2Pe,wsWeUYsl\syD-2e7CAMC0{K*n'{ ڤ_^˴VE+yL, ˩QxB,SAW8= =@9o\W惿q}kfeU 2'>ߟn4Q7r_z. ~AۿZip70DO͐Z=?MǛ"X`W#|_sKfuuz7bDꪁYz3WP#7׿J'X9N1<&ڢԏ 7XcMw&^u$PK8ٷzFuxǹcܑؼ$%Q_12 ;?ﱟ;XMFOx EpwE53+CV6^(m$C]FOi6+V): !ZY5#wVQNSmѼCr7Jd!L:RfN#Fܧ G9wݦ(oG.s{,khM9\ȿYkھ|/n\޶H-]y5NLL2KyI׾WB9 I?!e2kJmnɴ;3pr25|z~#]L[دUh6B`p[)5|aRd./\ׯ[*AЌ{aW|!EkK_[GP0_'^0 p Y)lF>tJ%X=m+M 9i!7_#r!Tn-pDT?\(@X J-=,냂ݾ|gNy+@OIH!؄ix; pv3Nx.xB ӕ*4sgIA9rMdtaun{OyjkkqGG@"}lMA]<,Ze6!Km@HE:4wSXqFT(VB&yfgP]Gc%5%G-ʻOhl2"3[k~ҸYDq0TOY u_\,1>2LSne } ͑UvllU_+:K Gc[BST3oZ(/sq/NIeD%̼$;4623%rsW^՘E+M8u~-U:ut1?R] Y]*AÄoÕmeڜ+`h1Ě]8|cAʾ,B[pݮrxeDD'2"x BJ(8? &!@2T$[\?.l4' ZCF,%ٌ$uu(#x ?)CVS-+EQhM> \J)Ai< F7nJqyRTg=NjNdţh-`F;>EifFiVzsO wwTXwHV`i׻O?pp=R(c X S㵋<1;qXu{?=n'F~; ['CۇpUH0 7lHn[*!ЀWiUd0;9cHI.J |'; w7: v%fK="a½C :h 'x3GeeYPXoGēϊ-T@;yJ[g=iNYg[ wltb 5rS!ݼTXcgqL5S n/? v,װ~l"+؊bAOmaKwЄ&xkhS{cJ\}CNZ26<?dY8MSLlf-De2|ӯH3 bIg=u5?ԭ@%(#EV<6[c)0guzSUXd[9FflRTGF ÈַUf(_N2 ⢧LjwVƓqd<,(gtQwSՐmZ"Gfo2H "[S29aĝ|wWbd wA?q$ THd<U+K#I#aQ*R\n9r}%"auɧiL+5c19@a%;FטϾsJCj^\F)B2#6_.}ނ2k70,T}[ $e1R\rouB vK_ɐ$QTt !ҝ2^#b<f=R-τQ׍;fFF}j:OМv F,7GV%JziҞG+=B'WHZ_tFKzfXyq芋{wL&G5X/@Z H:(= 2K(&f ( tɡn)0GSHW`_Y3w#VDzh4i2㣜84(K/(p:x=P%) ?DBŖ3'5K#<ڶHߥ]qB +aI;h땭1om; q >)75C-m= $r{DĺJ:djN"B,S^_'73f yjN9knVt}4jXX-CXUDB/+3sv{n~S=!\X uwX͛.3Qx.c6/2B>?jGV8VG]bɍFG[qCdAdii,{i;\Ld"lA9"#Qz8r-PH5-܏0C&e7r&dLQ8󍀹g_YBZO/0qF{Ęwۯ+S <.w|ccNC~M4/>qzNhhcɜ+JZ{a;?L齆 2z.g-'jEpt2רIM &P3h #ygXp8T$<+X|CseU7 &fiaS 0Im6QHL|5MVoTj\%[hq!!49ND|#[)h\{>\h,qLXPhFS+EW嵚 Ю/|Y+-3+!xƄ{_úxvD)p6 9=OJUA,Sy[1ZSPLŎd_KΕLQH.y`w'4S΁G4(ԛĵpDAmst)h:O+|Fq=a覱q% zi),fuNۛʃȈPbdto9JM_%*R}"VYuЈX=| v#pGk%%]tɤyQH'쿑bO>~`IXEm] 3zX=h0h4U^\(6argtF9'&eG0sd-JSڮLYR0Es&fx}I%xW/q?$Z&E"ԸmfHK zOz\6c{07Y G&&{&"x(g5MzqzfzB_@8PCZaЪ]κUisy5,):O"Z! T[Kr_aИ=Q]s%O zaqQ= q՗${d\x&qg:lrjΟNyg!tr򎙉j=$U#<.RByUjxmRfRѹ z3Nw)mg)(ˣbn}@?]*uCQGzܯo:a~ 䠠,x.z['&bMa2)4\o: J4"bmԭO' S[1){2(Qk3Cz{o]Vuf F,r/DYMn>;!JLXfRQ\~D BMnD6u搸@/ N_U&=M|%X,z҃Ajumvעengygɶ0퀞|O|7z}awvwVP3i4ऄ-!0 >J>p4-(IXo|3A7W@ kB7OJvf/Q,d_5-N< RUQBN#贞K _W9s.4'Yzqp\Bhd [a&Qn೎en>f%o=6[9Htsƌ9dg~nʺ*Ѹ\n1rR z\Płev5F - 8 QE F1i|cD&?~% z~5͛"n+XՅ1n#4i+"zNIn4^mpEEM %QkN[AWXxjXߒPS/8`@?)X endstream endobj 2557 0 obj << /Length1 2078 /Length2 16552 /Length3 0 /Length 17796 /Filter /FlateDecode >> stream xڌp[ Ƕ۶mgb6'M8Ķmۚ31ߜ`]}굺ku6 Pޕ `ffcdffPrG tvr3&n`uX8yYxdJ@9ˁ0wk!+':9{Y[̭l%IyFWOWz_ƶ.ݍlM>N )0Po}.V..Vidkm7sڻ3c߽}6>!s+{3d92i[9eac88@'Ԓ^Y2hqtpY?~|\݁Wg7?XXfV=ܟ?@;[yt?ʏOf`o#fՑW:x|88 Nvǃll<1Wt??) 4]Kr?lZoFnSg `]j]Q[;&j "F+I+O_vb``af?cejq}|Cߐfu ;;{}q|X> w\?>:QN_G!.0!$XLR $L#>)?"(!V>"}##g>?xuVLfQ0L8|l"~H~ij~G6m?#?2?|?@?X>t~$g";?6?T?T?Txc>2~P7Oo9d8_G@'neu率|I9TnOHI4[w"I#({Է«į> amTڟ}_ Ugᖧ NEa ԅ}_|5l[Ad)rܸ<<ƿ,Vs2Dk| *5\!re EDC˞z';f+fy\ިPgu%!E=J^))%;?aAN_s)@z|:ywi"'D[Ha&U+Z6ݏ .Z߄X^蟓vDw軝/PL3RI dJXj~#. >﹌E aEvzʓ& G._ ,Gtk0n1CQ ;y]Yؾ5q]aE:/Mb^s!ӚVy2>#!B{Wn^_x-ent=vMa)u~Δfwn I%RZh]gxE PCWucƍɓ-X_̑aΉU Pc[ylۏ9FϨC'~ӟ).6zb`J@o_U~`=Xomb-YXQlnc&DgKJyVNkvxJyq;NZԞ\AIUb_gT9iwמل狝~5)jI'rN<] H JgԈSu/;ջe8z;lTEIEXS֡"( 験no1 %P$ڤ8V#=.I|B7+KhxÄyF7F Yu_rABKqZ8V52 Us CcO4:VdWg=g_$`j.³I1_[%Ɵv;$d$/r^9Z!] 1Xw3z`^&H|ͫ.3 cdK( .jG!GXo} ﻵ<]9C@zj+_e6a@vݝr bЎ(E47oj[:x9D&&l^+] <:M?3lk1>&A"-$7e6tvNh tGU 3\nlL}b5Xa( FD(lHEK}rz|c؋g}Y#U#ʍՃӵmHVn?+߱dW|r7_+zN/KyYҞr1KuQ@+~Zsð (lxz}>ҹj>|RP?}Zxy)'biST A qyI 5H(^to !<2Zɂ~翜Р8]~ܤ.0RbMj}-Y6adރeQ׬騆}02ۊ"Uw?c v TM3|b:/Ɏ!0lms=^qTE' Mv.A` .~ߩF\|bYeEg96\&n9lct$s ũ\x3OeHR^f([{->Xz}*nM+K[A큝-5h [NhS wt6bBi͏hŻhVp1۩Q4CΗ9,.~ 06,<0ϤWv,񽪲Pnj! o >gd*XeUJunSidt7;hkbZ#dv 0&rDk"1=(1D_D5\xcIp7>V;HҠߓG5p)=@n VE L;9F ]t?PA,rgׄ+';[6=ʘۨ P40sg0(SzTͧ2~4cWu.ȉ̚ܟPi 0fOK"Ic+s=$$ŪҵjRg7HQ4tzSb(˦r Xz]N"֌Q\~tbՓmd묀4\ؘ.THb~`QVgqtȁ…}DU ۫;L[+EAsOtxb,ӢԜ~Xoy6SYZvfgEߎf`ˢ7»3E[깕Ky,}0}4Tg/S=<]v|`gqH`$3OًuŐxk.9ĥ6QM)m}l}b-~ᖣt;jc ԯRhÅ.+ Ŀ"b@9- ݟ %[ehHش'=~ȫNL`EER{@G}767.r,^L%\'j~+ ]DW-wBXJOmA20P(uԅY]:5v(j@ʑqٰ>eJڮ~^KM7뇱Tե&=gt u/½M|z̸^ 5iD2ldl]J \_|f(}u["+Tt^^*jnSoYv+lK7Vr$ѕ.nQ fQ+8bBm;B5̼68dglOOg-6ZiZ0!"m[Lv\k|@Oye|(jo uyU6-yJ'($!KHī|ȭIca'9B1N_NR AQhc '`LA6JRUZF'xOmc$'64 &boPI9E`M0N@ :i5b*]Wծ, a sC#NF|`r %׶2b,`S`ܩknVMQv/WT+֤҅e4Ցw޼ *ߛ-~=ڙ5MQQ}(@p7D^J| >a^&+ [:[xfhP5)e$bs0CL7I~h)WM,]hn̓Tq;f v1dhiAUM0,Kۙʵo/o3&bR7ȺɕT4R99'9|G#J h#\̅ bS1\*`%`Xm U7xQRCR7:D T hv0 @T O:w_T(WF$J3R9F;Bqe5wۧ10M{0dg̤g0;N!t/ ,w'r\uPd!O(mZ^cӉL;44yZ jmP;KUC d>7_QC;Ns~#ʢ GQi]qCF \w "] HyܸG7"澚a l7\+]8I\0z?b"u1 C!;&Ӻ6wet-К:!)/55)[rӻVeqF t%Icp}F R_U+`ZаWȵe-#/2t'fXj4+ $3 c1 {bwZ3v@ ;NF85TO6D`$Z?e1MJcӐDJT-sX*onJ& zzdddNN*YEt-7kŠDu 7>hO ؒ]Req֫jn.!78D6nDJf} [ÒU&G)Bb7I0q B#`w=񗩙>9 {}5AdE >d# 9{Zc$46U*K1i޸, .4\3}n-JhH?]OST5ƖKA믕յnMuk)G|wAW5#jUdG)P}Id= ,&ٺs z͔SOzIXJ!ވa|5SH,8XqyBk5UC9}{^58N&%N)-2;/wVQm-D!R:/] zAT~_/6= Y/՘/~Uŵэ퉤Rmġ' h$PV}iCn*z8,l=³fEWh7bNaCsinNXV2zn\UKַ:B4f~B"6DDzROcq|i ~sԫ!K̤K)q:'®ip(vdDžm梁'is4,h*;=pvh˵5g৺V6"Wrj~q3dċ߉{b.LDL6QĥF/{rH@yFlZT;z3?/K.*HC5 R^}hQZpj%SZ=r(J&E.H@#Z4pzEe=ݝdEiΦSn%>f~|i_<VN>}Q!KNzo&('%Ѓ&tgCW?1TKօ$6)"e=xV3 "CH<ϘmOL}0Ʌ+pbqm:y"-;4k"WvJz( + DQA,AQBٗV:xM"ߣ(ARwM#'#  Mm/e16;S q:NL\qDs7z]t$n{40ZLtsvMhcnvnVHYġ@xHD*()nf^#8<#’xoҗD ܱ GDmO~#C8Tw_1DE<ɝ=xmmz}z u-ӟ.,Vͧ X9un!KSíRQlmz[Fk7.!bFE:6˷ϋ_S"W%5JA~D %vCゟD*2$ya@{.e[ H dPytY?x6G\ezrb;лG㤦)  Nީ;4 jHI藽8]y@59nQ? <ϺyEG)U0r>tCq$֊5L%Af{ƥ5,:])EzjGPwHxiv}qyŒ~ţXE'\XT G!/I.3QGjܨK&qIv,'O>gP,bJL9bdh#`1tZtK8!>)HU}/٬}zn*_wܡO]f{2BSN!ݠ ͇P]yBuGAmiՉeu'=r(Xszјpǿv=nX""k*;ߦq Ü`JYOagnmUN]>@jL6 [~8gm㾩i bԦULoV׉JT^?Z[&"ޓ|=Rf Ѷ{2OW )C+ Jw ' OޏF%,~|5&3k ΣG(/(|5?bů5g2VwsoMO_}sG['ȡ,ʧeќFZG̤2O kyĥHR +{Br:B(:ңjSbNh5C){25x+{Ppr8Zm}M![ 2|*ӭF<6i(un*_Ж=N:V{PYK'Pm4ʔoet[η. Ά hKr Z #县}`c%P7tlݏ7jk4-ڝH累4҈kw}f=z`?-DQ,jZc^MXfE-;Bܙ1LZ~FuZxBbǑ 1y0_ .+y)@D>KB9ev :s H)`AUnRԛ(op>.g.P0Aԇ yxė WBB/^CpI[w &2fIUrY_sk@U=HD5!~1&v|et$NR4{+`;eq t}T}|V[yAJ#3XWEӞ{ܰ3dmQ'+D9,M]<@O)!p|5<z U@{!k6Pzr) ."o4ʷEYCjy?.\z^0׊ъYkn[Lۭ&~\^v%;nQÌn8,o.`Ra~}`S4ژW!|qi驢ZjlJ3v$"O_ ҶQO=ϓՏT%Pk@u%{Lj~ 767F@nESOF$Am"Yvq(~Mn64'6qmvMK*ݹ\s+ k>7~T!9KB)T2t_':0%An'FD+}!/[K} Mv6w)|u,G{sy7U3xuX˾ڮ(PNץJ?s)OϪld)[EdzIBcQsX4f[JmU%3@bfnᓆi/(ˢsMa HT(V#+Pl76x`zlm-f{4W}b}gFXtVZsa")ZmO+$S|p9u6Qy-%N5 %9Ad{K5VL O)QD-~m$[x9 IlEj>`H~9\H wJ ndgPXNF&K\73ɥ ͩGQOpVxVb7΅SOWw*28-cr+K<؄Yajc1rdMu_^B8R|y3h~ȅBQL?<4(c,0*UD U$k:Hۀ* ́)/km6-cgqA­4ɤn$50v5B%ܧɶ'Ȋ'3X"#9 &5g+>Ekch@lv&K7I-ܵX AL Ҝ"L vR)(c8U <}rɽY(oN+RB|n !5\X;Wٕ#ksXX MڏƆ3NY*AO^|y7R rGëCBrb8faҟfwh8xz9>M)R2~,fѥ.J$-O֔qK4MPz/$U.eΏ(16"cU 5zܘhӚpvR2m 됝J%&T!p!c064KIfM`Qp]F/Sr(rŜwcGSO905J=r-+7NCNJKqG=Iw$k5ūx+R!_E!Kvh >| TL/j;n5^]An[A#OnֳHukɇ '7g # Bˈ\ƓcNXZV ]]\=X ScJQ;)N;U$<>`d0#|w|K ~H3Sqz:.NepM!4 Y%`ixʒ}ysw/4!˵@a·%=@@Т0-\P=+bGnݨ"cw,ݹb i8ጸ$(>;1=n Y;/IˠR2#fl%71.YPt?^Nd35Y 0*#mPy:t 7QF\#pJlΟ [gh>grr'+2 GjX>F hAn%2mpII"܌-r54ZnL/J ZAG$醴24FsP$Ʒ#>%ߌ;+ҠOD6u1މ>Shپ\.{]W*Ł n"Ʒ&&: rg ˎ(kܢnl E3\Y--U *pZ*#v̮>IT+,=粜mcX 1weп]~[ohoJ,tOjȎoP::-:e1jF<8+߃vAY̫ {^EY #uNI<t\~Yֽ&8|jc/&Zzأ1s&z]a)׀+ΕA<&Oh78Nx(&y} `r%L(} d3j/+9q#urP"ą@k&[ :}c^2r Mh0A8'U-䶨4kwj{6eo%6^}={i=eow8%=?եB23>K2hm"orvˋZcvXM<*wcZ3< @U6CdIbv{}m ``^/<䖺y {?OppXՀ>fd9/n"jQ*<Fme NF1q&PϚ¢[9=mZms` uknJ|&JůLePұm343êAMbpba/9GCuâypx.U~T.X̗e"h ׎%&VPҮT*V_GWH1ž\|״&3F!N& 󳖷VkΓ؁gxЯO!8IM&Q}mfs(A)+[GMuy.>"$~F^)͌ -FdZ,,y^pfn;+ZdwVj`mqxXZ+Neq((K$1TsB U{'φ-|ɞ7R Z gFyVL78paAS~HXh#Rc9V:x\(NΤrҗ@/ ]{DdAμeC!K!v1FX_@5:œ%) N0ߗ"7'LA:CR$Y^F]SKZjO۴WCR;@Y!2*/V0 :;Ռ{sI6`@Bh ΉL&W@ޮ~x_9jj* -PL+h5b嫵"ersmpv[mLJ$h:NˋdqXf@!UL%p:n~(g묦#3G"mGb u͹b;7,n*-aoNzW:!,B󳙠wTp k/ (+M4 $aT56]T9ʯM1Fa4 0AݐÊf}{™A 6$xRY%Z bD8VmJpH)NgհПwz3$gӔ(( cWs4PvNYŢ"F)J $+ZyCfsn/"b⑤Ќ򛿲 lY:ڌ,}_ǐ$Zd?FutiQ C~~[WzQ/ݷV0\α"F"C𘴶۲JϱȞ&C<')%Bh9Ƴr_.~vl

qp[.ͤT ը2;4L>QJw y_ JDvK)BRhce$7ڃdH!*o[?έWګ, ΅]%!lL`E1us'&'y PPs͠y lRi_` i↺e껍̱3-٬QA]`Y—fofla4:~4su\H_(f%2 1kЕį@x)QOnl,?>ðB#&Tvȷ;זb;?4ֺvv?93yK(Wߛ3l5 O5xi` ̹’xB"(9X,,U; i皳_`+*n9bBDڂYx'f%:g.7qU8 &*H~w}D^,/lpvD `LJJ 2(egV s)E({me8kcId}(,lm/&,=h c(Yw2[UbD7G֭y&MݞBsY =0d@QTVA!t {"݀fQaEd=dG噆r~/+iJGsfYV0?U& wNH uhgQ/*0O tflnY5@BW-=.ob{:=V_BM1?YŘd".!N p7wW ʪw==i}> m5Pzv{&FMB_`̶*+?12vXv+hM7Cu۶d%J=$ a ( /]nv&uU40c?VCK=74SF<X,{i/(ql\UFrViWS˧'潿E*h(m]`xuT'R^ѓSʡw4U CDŠ(m^\ V5A?ۭ.QL-e0`FVn d@޳h!3Ӟ}O &D>,1=ʃp! ͍|ODΨ> ֕e, T(&iruӣNf\0g!j>;Pi՟t|$:?{r rv#T 2_Tf\]2_:f;aTnx8ma6t?ٯjdK6*g4sCպܵ79٥,O6=\qw>AtmM 4PL> stream xڍT- E CAC܊w-Zi)RG9?{#c$ke{ϵ4-@2;@RYBɍFGe造61$ &= 0/% H]m,Njce {_9KPPp=jc0kSEs `nyW FakQ͍hab gd=2@hk4v4:MK <6 S M|PG3 <4B9O 2:w.Y@,,aȡ qrKy2c|nn񻀖#'o >^˧1@>64/g+|o1@V6?Aڸ 8?'Y8@bq-yueFSB`pq8>G hWC,tNZ&RqxR. 98͟Gg ;q3I6`Ou=m.@ su%듇vAb18ظ,l`OE@@j6'p~.wIi-P瓔^\OhrCv)4FxMW A$0{Omm=ſ /T_a/T_);_?п>ÿ 7N.0d iby&rԳ?+?x 7g=W˵HhI).pG&$JbB",)EڱN5TeL%˰'Cbշ$5;qsjLќ; =#*f2vC5xˠ FQyςS u~bq f0n/;a3_?}e!YZoE&iC\TٯMt+qDJ&)ڎԬ+tzb=d. ^a<ۘwq Z(3MF )tCoi5 >gJ኎+8}* HB΋(&Kޣ/8 3v{]qD#%u̕G7!+}dSrB8EDyuH\% AV2V MHmu`=K[m:د[*쒅:S*9=MD&{A!,*[iq^[/ Ql6IL(_mi6c\pКE?GRӇߏEIOo!K,r}c-e+QxȂoN8oM *CO2ZeǎFÅ#\|uw`榙2l"䎃IMJ-u_H~_\_Zr qX񿠵Dbx:ԣs [pT){8l~9P'~|ʖ:1O[m9Ǣg K6ЧΑ\sKiy˫&fm'wc#Po]h*I-t^p7,%@y{2)C[ӻ=bT9INr+e;ˬبYxki E RTuIUMQ[ĜZ&~qW9,[s܎qF(lUzZh-r=u>}SIDm\䖟xǎ/z_Y`*5m~طw6~V>'Y:,>ᇥb?yETq&/M #zC*kQ!{b-=5|XMB7q/xwu6+z1- ֕jiu }_Ow\L" ba+=x_8"Qw*Fa)Q {ae뇘O]<2)-(ZrcVomUfc@PS Zv`BOrklLם.5h].,:ߚR<(EχIt1R`nI|]x#%jpBy oJ geA| F~u]j/UjA16h/"Vxd} IҖrc ]4"brrқ߭[᦬[%嬐2NRwֿ]kR$Ry}*ۯN"p:t|uL${7%j*@G1 QƆV/铧\j򫱛WxA::4VO3wk,A_,YW8x|^^& qtWv`Ӡ{I&Wh ?s~א֚ẹO9]>$zQ~C)X A+H'qրkcƁQaߖ`GȜUW _֞EOotlN{IC Bx;kGNr2(79&2{4C͍L^bV5hI8=R3½2ttUݏY;}̖,TaqC0XEypӐu>߼ߦGLt)$0kHX]ȩ]mn^Bt0r^ F ;Ih|?Xd+&h֐ u)_pY;%Ij j[38L*Dhtʷ7Asog8yh7tkڈ1x MhR :-=*I?\~jCeJ'ܲ\E[JA,eiҠ;+Q7?{~XDi#O[-9Xl/&ƫ7cd3 z 픎홂ve ;iy(a?6{+kWyɟ{ mn>C]/Σi0EsP޹n\ +6e{| )K>Þ{25R-ߡ]41k  Dz Gd۽ZMCPOIنsDKj}=ӕ 4i"ϩ yS xºn ǰG/ѐF{U'J0QIc"NQ_Ug"w { v]^j=Dwh95C6!mT́ۧi)WT]L2q5`P1# T]/X8Kхc-4QN*>Wj]RKQL4vć{}z{FDqj CQ o_ϐS˼!̐KVy3H^Ŧv~H X"g3m7C)CO׼3-8(RԯG!rFn~MJo¤hxJyK m_7B q,FG1v0//WL$_sY`a Vx;  [hI{g-`PQ`&<"{ۭ8NpB+en H <_Iڔ0_2dTdR_M#;^&Ogt1^Hof)Rs¾1X\Μ $!G'!in;zރrN܈iZ'ry宫 g?}ण g~VUo kLـ+5v1P  H걘th~KY`vQ=|ﲎyn: #a'I+TRm=z {g73c5KĿb9k.sH:1|G*esׄ"4# լ5Qv\Ӵmj_}$^:72J<m+OtfN^?j>bG8KJ_qX<NLEV pq3X։04,nإʇOѡ+ lxUh~\&TYօLԻ c+Ngn䏻2V򸕵hP"/DRqq#5mMRWWyBWG|=^$EO4}G{cvl5>nKm W@7Gq-H`59̫:kc)`2Bb^\΍/7ZyZ_wFߵB.OR6; KH5\r4q.BI3B V թ?A |KZ 'w1t &j][dR}B0Ȍ*Cdb4 4Pqs]"W uod `HGd $lzWG#6>Ur]6bk7Bp-Tek6ٱ*0ĿS `ћ] 7k4v0Ya!N[e8c/UMPS5c3JQp-EdcoX5SI XhiKWW\ y˹ ~d-B^x{L,CHڊtgPyxE"wA3EBQIL l\Cn){s6J2_!9q+w[<u_p$B8\6B ip .,Ĉ% e c(9\abДxpdo]%y(yzXX_`hPh+r(φQxe]}Zu%1|dP;K$rPa,z|e7s-MBXJ,E|aE/|}Zf$zըT[ KTu?Ήs虀O%gnS̊\ qIhRY0J}լ + f#6˼v*8&6TG D#x,ް@ëdon^7ċd&)7ATbW؏1 fM#FAN^jh8J. h1G\s qN*/JIpCgfAer<* 움VV9wǠf BF:d4ٷЩG2ښGo.Y¡UƢK׬pâ[U>1(vmQޝ]x?0'| D+E-|Fi>Ь}֙LKJ#U-YM7 DZ]%%7 ^lq&w{HM<>6/am66>-0#6x.Mvp" f}Ħu΍x(sKbE?]>zЈK˜ K-ٴd:wq2OƸ=^ԫx_"#8 )yL%/xF{ d;CY5y(= 4l31H2f(^4BR0/0z@ U?F+O0*f8a; # [dT4fpS % PBn]aJ5wlGD /Mz*gWRbyf{>j_`h)bMf~w/49[C |Bjo|mRvQT|")1El|bmq?;x@b3DA*ছ!RHTnE\3|1HX:a|(њdQ_ÝH+yǁc)k,Ia ~.K]:BAu#xUؖ_#nH&n92=k?JhH+]i0L*@|n!Rǖ+2NEx^jΛ hy(eϙ7Q~FY>ϓiO~XVNq-G/PV^…tCz|Z0w*Th!$|h?$Yø%˵kn|jK@jR"d뙮Jhbpiy`ZТk܊`]=^u87>@[FCs3#7[̛/k"!=l5:!˰Еp %oO uƒ_VC২xڅ4C߻ݼVHq ݞZ.(9gKQ${YGab)D5rdQg|y:)=2-"xy״0Eav>jϷb D*q$>^A˔!VXjI?$?dak^sc,.1]B<Ӗs,^z/>bX˿`aʩ'ކȋV2H{Uj\nFMJ,?#e>ˏ[xnnsdxr2~Բ2S{Sr_J\"On{iuR|t00އQzo `u6نC6]#y礝z[NG.T+c'f>Pk^f!oHF^Fuq/O9'/XmUOǁ NJY,1cLCߢ?Nv,ݝA> stream xڍwT6҄RE:QCH* $$ IU*H* H)*J/_PϽ_VJޙyfϳΛwv05$Iuu5 $, 89XW~) #RPF XOuW XK@@!Ho -Tx큺@-$p*#Qhߏ@n(,))~W:P C!.sïP8 2NX,JJPS@x=X'! C{# n? 8Np AÀx+ C`)04:HS!~u~l,W?_(醂 GWza! C< pWuPMOg>  Ga1Ōe۬WFX ?8ﻷuA =>[pP& $ą%D0w $x7 +pgA!Q@0? @<`@,?`0`pnoh 0{$_G,htO)ߟTRBz}B $"?]Op@/]ߨ{C? O]L/R42;R{+!npW??ښ#]D[ORؤwY8)}EW&Ң^YC"i!ɮxEtOnAKіzeZ T }3]QZVsbUXTD.W<3c3NVaӾ8;J\SQhB͌oF-ZhzU2mq߷kJ YWkqq4R Ȟl-28A9VRW[)a=A^ދ@=aGI`&t0@H߽.m:(PnT-7E੡pD/]O+SeIaݤe}J'?~iW'F(.6FU1R"H& s殰#3N5vVssJ,=.obH\zя N*ܲn{Y6!l:;^򵖯U`A%HvMYZ!N1vy:<mA-@I߫ ĽiNF !OHѠG7& @7t}g ajS%'$yg*=ƺݱKh"P (.mВ̜ F.Q~1G!TN^Dz;|Ш9`2Vp0;X^fQͺJ,gPջ7MfoHۋ<7.tAw;3!͇~<wx`l޳[c'iyMlq 5'Bgt+o-_p|n^N>vj8cgآ -ִ&h^ce`>x/8/ :e4x;6xدfu$2Tp<LV9Yߺe1JIvsȂx`^i3e7 h jg'zH֞*E`׺6 p{# mud+pai@&EV [[eU`W盟^7Q&C,lQR }2G|PSMJ"1nl}@@sP!+(/s.{ɚCC{rO:&|;u]~ %nTR_[#{&fcZI?2`X@hE)!gœ'{1=^4h92oeùakz;4veP,1̜;+f:<&.,=XipՄ=XeVAS@Υfx3(H~!M5f<2>;¥ܒGكr ѽ+oFK$׹gzAЃAgz9q:qOzMR+3a,}3.IOOL"LV$2D}׊Xaʌk +JfJRoV $Ѽ1K(j 0(MHA}!PWHCCx.%*o׻zo^F҈,x7sLi31@B,q3iU44yg-e uix8[~<+Jt^^Mff4#[ΦV'@mWj ИNOPnHԅ ÁS3qzџᷙ?yjbCsW>r{Srר{W|۬3[eCb-c{w;fZ|`dNCA&G}sJ> nkZ TDwR^|a>R|btD+DF38=hIR0e;іIͷ/k/FyO$U R&:)+5Q l,qG؂UMI|; dSQQo3m_\Rwߩzg%SrܤT˪Euk{aS3drEyg{صʲj!\a#1,εk]j$An3& Oq5#B藷ʋ QݢT^:*o"v3$D}rZRNy4ȫȚ<y9X=GVIĶj񌟨޵@ܫXt9 (Gs BȸRJ{\9Cb +m a779^$w{R)?K˦ݓlnQ s6~h-}}u@] &8Xơ@|(&AhoKjt3-l1NWcj >Z@]*Շdaav[Qww:BOi753{ӈѯ,_?zsHXlF@/rx*t|DžiPb;2jJr*8UeYvKqс8GЯsHT+Nh Eȫp[g.Q-MN\k׃B ̶K Q7Ӑ :T+C,J\[_L&ҡ#L+!ȗvfD+~Jj{E]p ,s=pPjBEsP*UC6uwpf\c'~nfY?tp[_\Ni'Q&"HLE뷨9'Ku[K6>ka 񽭥e[/=ڢϨ brgYVEJ0RVB!]jt4gw vo7{dBgN]NW|IGCyo{JsRGZl4K>Fl2| J4r3Y|춄Okw0Ĭߟm~]JlAj$VDbRt)?Ww|ܔvYHIVcML>'4 rvXQn{3j9Ax0 ^iJ`cŋ2 gKVY3!wog9 }DQ美-{5N@겹eա*T^h`']mk,cag䕩 M&. Dq7oB}[百^͍lxzܩ"PIdJƺgforדm3^9ZtHQ?<ơ{52qK$I_a+|SzR*tseWʑibcz[=Hhh%ʏ*dgq#)tYeBVmz0l$P Q8uL5ԶwegUV33jv"іB&P­<)u"%C(R%Hv#xQ+,GWU ]]|;҆ш! z?kMn`ZIFJzgЫBi(s;K;e5#zmI21ښKX#"r*M֬; #w4k^Y m ,r's֞=Sw.yqj]cAti{ŖbFKo~ɲk)+n|NT'mY?*z!b Ƣc_- ] KbfR:;I&*2<)[Vߒ_~O(4#!ØcMSw; C^DPշvS !I<*퐄K?QrVn%R.C8LbqTFhWh5G[%(n@ta'iv)`u$F@clEUoW_?=$% !lOA bG((wy4m dv K5.ES1)]P+ކ2l^Y?Շ*5}Aw+y?L'Ku2R]:C VQqՌT~?/6dmɿ\DnwXGy];p RE*j!9;a2O+ͣD.`1aE/%T8x֘:ο0Y)T|L~@Rt|dۆl#/` aqFz\_K_g~uPԑ9n^|:6lU־Ș6{GǪ1mtNQ?!E g^ؗQ>L<{N_Ed&svXHI'jgҟѐ:G'2E0}1t;h#o ~峊ƻ5_+w: <* k?_.P60FPfkq+:v8&R;#X R*+ ]'Qו e\ouF<.lrN[D/6 XKaQ_]Ȓpq@@uUk#$Մ`XcKptzy錔 AIBζt36 |E[ϝ>v圱5GD-?\Tu Z$"qr,8jLŅK;J2prݷ\s~ a~Ѳ$:cNLJ juxL> ͋y->jŁync>yRXPHid{G %źQxz qKʽwǟ;V>|Fz`Ga\xmI6.rv kz7ٌ(I(^ endstream endobj 2563 0 obj << /Length1 2697 /Length2 23623 /Length3 0 /Length 25142 /Filter /FlateDecode >> stream xڌP\i-Ӹ=6! @ܝz;3O2{UUpֶomNwAE(bjg ufdebɫXXؙXX,4Nv9AwF ;y;[5`caC;G^;#WKS<@@%fghin :&tV7Dl&Fy#g D#k%?!h-yܘl,-*@'++a ̘jNU̜݌hp5:@T@ۿ6x6V&+_F&&v6F3Kk @QB ds#2?98Z;;19YZJWPmMllNtwg?ڹz,mM~%abϬnk~ H[ftppjĠ |f$>f@/'#W `ji 0["Ơ;ZtX@ `hLl=~_fu1 -1-3W'*jb`0qX 7a,񇯴o2c7hjCb<M(!߄$\Rl,=1 3h@k`M5/<k@ bkno-$,݁J&Or_[fmi TsuA_:j|]NKm53bl\#GG#PA ES_C `fs@~u,K70Ff-o`q%~#Vo`ҿY7q@\~#E7qQqQ@\#E7qQ@\#E7qyhx@F713v42w̜;*@MEl &!}';k,mkȘMC6ESK# t#6 J.\.uo20r ¿!'/D_9۹8qo;kP,<-XdJ‡? *;2'A&ro5(=l!`G]v*U;ߝ\N]1 ~ MAv@Scb_/2 rrXw(9]'(}oR:Y9YcA/fg G3 .@PK] fn# 79P$OG26qq%ׇ h0kglUrEЍq{T`j[3k6:#pF$q miSZx방xG'Xfqc"_{Մw5>@6P8EQüst[s8tv[yKl1J=R7x*8sƙuf #{T&(K{rS>%615^ WIҏy&Bl7KhL{lՖ* 5 m[9`[5 X5{mf-7fVD<__Z^u?oC 4 nvh ҋ[/M'N.sJcYtM|mx.@Q¢|3OeB4^k«q{YaF(mnxܕheZ`tPZ%ӻRR >Bip@{|J|eƑ~ѠӽrQ}};J0сjT;S%E" n7g)D]lQ56G:ޔI)\轠70ΧV;Z0 T;?!) Z4_D U(<&G6Ɇ&6)+u9z|ֱdsi/f+n"uD5?GP,XGRRB, LF*'kr-pwBa;O\ٓʶ}i[T Ydsrl`5:YiW~tdf!L#6ghkU0sɂyki^EPdPzjdFdabj(4ƻ;gff/#KQ$%8U(_GwG' }gzå7ۜ5g XV.4o(tɝth0v]uRyN l+Qօu1M] 2 NʹvbdׄJw_EW2t[y_NV?a1 `Y%.bvZKս@8f; B&dMj2- u2 jE !I.Kͦ2\%DIiPӁw8 #×f2O0x+3Ws%.54}Z3}ror+OhɪPOl ys%P籞G[CS]Eś1BM6wҽdrUv[̑5Wd,qZv}T=n+lzveݫ*g!i!T\Q \zV$S~rI0-u)ԗ,Iϻ<~-' Y-E J +Ɍ 6e}Qu?сMpLh%^A͒1B 4a!lOnjm%{v9+ }V_Fu[ZWuf.OVF-5$ ?q(~l8h6?9~NE턃-%~V^W-B^RZ:^dޜp֚ |b,HgAxI<;:Q0 <Y >v%¤ qA۾O™lvp egVʲL${1&|y6csiςp2b/y*V9n;>ֆ$2x^<6QRSdپ?-u [KKA7~uTvի9,)Nc'{ɫبzw ELr= O_b{׋NLԛ&GQOضZbb=e%o?(|3ŗq0o @ 8p^η^hRx WJ(7q3 ҩ^2YL0Dc?bu [9~TNgc=ȏ,|VgH;ʉ#8f% =BBQu_B0YR>r5F'4)frȏ#EmrŢlnz e"CH].B %K5=}AaPA*Wp *G:OZ׽Z@y"ˆyJWyG/gSA3R4£ kT[I:%t=mO9H5Z4?uӼw^Me5MAMFOCW _y!xP:_Qz.xSSƩ<+J?LGDګNgvX^pdbb^&pL~ߎNIvXpm׌C̝RL)'toGөۡ0Q1|=0 $}c0(q "]7z&:qpr==Q>[`%ൄ=T|C!R+Dg+I2]X%WNJWt9Br`5~Jbia^q.\>ܭKOܱ&p* q4>_;1C3*uV~,Sv$^ҩ1TG :ƣβ?u`ߪF$BGETXEȺAΜV&o-|q5OpX͕~%V!k d>+ '5˶f7QH;KT0-h b;&\.t!)>m:(@3!&E$ A4NJeHeDV[iul#`žu}l(Ay]G (>XU|$k-g(+,A,|߱*;@|.KFtƗ@h;l-'9B;0Y 1*AKPeAd/I_ N=#PfW|{u_1 J\npRi*RL %i%ݓMKMkmLeRW7< . K°(.[ (Yi1n:xq䕴$KgHxJ'pp"B9W'h 2b3IY}Ctvt_JBa\\hGTMCg6%n )m&*E wt{)HQS{iT)BѲ{>ŀeB~h<&2i̇}5)po\4 rLivM}CVO}>HTi+gRo|{kG/b7d]sQj((`P҈Yp=7}<˄O3gJ3 ݷqk(i87neӐ•;uγZ vSRWBxuʩў>bšH̆Mʷ.KI˗.f>& dz3wG(o*ۜsv,y.rCz~V%4^ap+\z%y{~;ߠaSm?:}NaGB.HĈl}{Lj(7Aݟy*k(0+2L;Ynp*:C_}zYϖ,;rbuωK1.u9ݘ<*![ o^9޳upH]w;j3Rԏ/}n ƹ~\JdA|/&z,wu]GUY~i#B{$~unrz(Z$pD{ЧV?'Ddwڛ01r)\kU Դ?QīK~->J95Ր}ð]!RXP 5pnًZqMRY'?/,hEǯia%&:7\;x'3{Tb1~j"{fx)q J>|S-7Sj9 (Ϸ|*w=R.\ʽ)4|I/IUyˬяR5:2 *d;jt}ii8μkCC{@]BiY[)}!5=r5N!{,oôűoT]7g-杏_^9 q%| ; ճ#h} FUEF%M ]|0x)⡗f%dž;eW_q>%a9PrZ2H'5I03|awԊz ;֡0I8AR;z[y#N6@;$'GnN3߬lƦK4zLG?vVi|LWJ E<{To!6+։"/UU/2]odI/B5Vbb2RҕtV;A.2aZ?Vh^U UE=ۓ|OmeyK߸T'm-=% n;<2~3DḴ[˳01OTZА9, ;d}:!A@? ˈ?Y1R%R&Iԃӳu|rXm~\JXkKsVbC\>vN/_F6%9rΆ:>>/"{`b0R;8u/[!.UK%cOje5{B[EgME2&ds{"UUKb |TKó!; :CRS,|HS'%Z;L-z{5H+nl# oFF֛ fr ܯs^ DAQNRQ6+ep! GII$euwvR?3!'e'c뺤ΡcMA4'M!GxqqP)?t7(YC(7^@b<j6kJ^l;];v>@l^"ڨeHŞՂt1v_}}=C[EiFTR.ٞ=[9߇hML@GZs暋kZe5A풬z0IC[{IVp  v1u.rSY`Mhs1h.1\+&.&)F@^G|.a?H%ƚn2+")a"k]Z;,"G:fݴod6:ȃeaA@4z񱒺=]-qNaokGXזiSԲ80Z ף4o$/o̥!٨rS=H YkՑO{Շe~|O*F84@=\s%mY)^0*Fdx)yõi&ݱv7Ыr%fG}zm0kv^Uu7/׈k>2?^ZJnM._1#Kz0&2C88ddJ_ xu= )Lޑ]ڳEy~]eJ2Cr$i~!1vС&uHj}S݆wcZTیh c7O4O,~'9Q c>Hݓ OARd1?r$d)&2nnQ,xG4$GYJS[O5qH͹E0IU!""Wr4JC9Kt+$Ց/< /"% 5uLKш "5&u (0M~{Dx9g(ЛK,0fJa^zZkyY~-*j(3uSx ~IR !cpGp*Kxk0QZUM{qyZDtQgvUiQeRCKRKUq*JK{7+q ieއucw=K;ٷu07Djqùl;c5^ " ͕ RuJ1LrS.RmJsT*ٯ%QXG#+'GL3U,izT3&Ӎyab%1ġsۗ$5@ )9VO81I'͋'Z2AϏhsNbzZ3)إW_1qʲIMr`9vNS=5wZ"3gESʎyVy-CK}`F :b$ձ|]~ p)^S1ĒIDDH39]=Eǭt۫L0)G=u;<"pO[E 0.9sԬ^W~SݘC[:{)ga3լK;Ea85Tr9AѢ"4cj\~hףmW0s.}؇OR2r-,I흦P&tuәOG>U`Z%,jm %vk]P9R5! <ѳ{FθNm n6%CZTF.?hd}].:]iuҋN>i(`X`nP Ym3L$hb}q7X\Qn;C[LE HcMҺp˅4c%z<꓊Θ 9I&N/a|3^ypmb\e@ ^'>xv'=y|-V6t.-o&l<e&qo{,AFJ/TT砵fkKJ6t2u [rG쇡AU/L7xB$Zʆu0[mX3h4B`o_ SeWP|"a7+:MzT*q;( #5TWc=r$5 IJ1^eƣ 1EMg,FFv.5FF}Ƃq[l~//^Jk5j _YR\ä-BCHY?'>Bzx6kSg!e tuD;됒v&>/pEW؝ >jTj8#<6jPtY`q XJ Yg{q8@%"+x s[Q؆ )ƛ!(0 =I<ϳ'K~(Zp`X*|j2{yTGK&Ao]\g ^`8uKaoYn;gW[GU.ndWlPlq )fvyZq EmkUO6[Bn \W`!驖wUyMâ԰s+Px{ыF *]}/s:  \͵ͅTyvuQb.&u~pğ;|q6S֓hq>n6'Cpp=[H&})3Sy}?Ο|†a?6Z>ihIB12RJ77wm5ds?( ( Z<#M>LilD)͍mGAa|8֋5OpЃuTOin1J,1nոn2>5zg+w4wkȓ,IeorM~6u"SE߄HžI=]t t&VHuP_ny n,2pV+ݹdL,K` D\qPU+̇{4p=z Y|@w(jZ8z-Xuͩ p0>M@¡ xmߠ}U_\Z`)o͞=]p_1Ӱ.V 4DG%8lCA8pԔT8jP>r =|Zo1p -|Tx|+c-c1"wFH8ݭٱД,Q~MSd=^!g Ya,{ 0NrH4Tt[^Q+b0m 0 I@c#;-z9}EjTT@^}lZm@}pĠᧇ(=VvIQ&AVw%kQB1^!`aeppI"`CYHҊ^QWlgꄠt4O|c3=>mޟg3o^gf?û0ifF?yID <嗀|;`$uDF)͵+qxL{B^}pW-Hu vۨGFi8|veYxLY|3̾Ol\Ã$e5ܩS 7j釥[!ih7GfƊ`\`/N :L;g}O>סg2?$΁1Բv3.b='5;֤N7[ .:1v~J#ֺB S,aͧF75CN;Ot,C&1nu똍AU#xWR*xEK"ypyOrFU_w1g[Zc$?9d j7e]vuy (8:c^V =]@6^ǃFU5,ȎCѽG[L0j5jmf>`|ǁ.lNgWU.̲}|pL8>tSžNC`sMk1Mg^ yCgOK(.JxjE0-۠>c QcǺX]- ٠g ״;*>ciFe)fGGj0:(P) <=CԓTY n[?`?;tlƂZ$(s!IM6F zKs :z @f~r!Ys,щ8o`\_:K~i1#uZ$K cLxHrh"8N{!9]ZPaL ;BFpT7SR 1.X%u0$vIj}igѡ Խ `WaEJo闦ֱ~3fdfpd5UAO0錢BP>FAK ? ۗ09c+'%!d~܋T?t t;w& n=~ޙZ^ig%tW:u^Fpep]<)H ;Ǯ̶بh=GJ@"2fE/Qy(HPfdmWX9E-uc>[SR6 V]eK4te!o"Fz$* n<1z!:N6D>1~YrckPFU7 DxChJэK}Y9{ϑxiy|t?=9WX6mu^1Y+ZI1r]+OmWF|X(J1uGv.gx-ʽ@N |8xd7%O Gm1oNX$5&pnׯ&֖ԟ9~8G$D%mr[I!NVHXɘhfcfMrwdͪoY٠zWGN{d}G e|7MڮBtŻ]kC3 HZ ZS'vƱB$.xWC_ zdlZ4p+]+-nV`aC莾xt~c6/vZi2_2#4 mJAT ZDuENSb,(sCz󅵛D޽);! ϵ;FQ,x{>%9"%xdՌ:)"O}Փ.DEa|_(s~Π 1}^Ƚ鈎wKw*ogޖdzzy~cʤ~ *o{0iny/ _7OBDO% 5ceR UOMOtRac%淒a>r s[t8ުԂgۆ8Cp  ]֓^Y2_^cao(ƧjyT?bT%)!#Q>gC7RRhGV|Хǃ‘L|E3+n iPBn^xC]՝<oq1fn84%3c4 =TĻΎ/HfTIO ̠FALNG:|-,^f=k A `"OQUu!Ozl NE o,Qy)1MCʕV.nEi:R y0% &rjd;81T m5*&0oxj$F0lF.Y]@~ơ2MM7k7-Z+>J|uXw^֘߉ o%aB ɅG}z']g ŒzJ.%[,D/̟/o\kP2$8،vC%G "g,NꝂ@9?ՙ ~]K}9E#e M,JIS`a^GPA@_7%]Up\)\-AO䴵feyN_s/Ux 6:/y3<`q^C3m~di% R-AHr|lpɗsh8;vh\u.]IbP1 G:\?eAѳq>6blWW0tw #?<Kp*7@'E-f)'T8ܗPiknK!42AlT{7dĐ@UDTrc-bJl~ 7>- B}ZTm3ǐR.ݵ U;= !e '],|d24`ZCX~˞+$(DpV%k;lvoHYR7BТ]9A25Cd\MGWy-٢ay MCCY1\i݁:h!b6<{q2d1)lI8Z4#.~jF5-;us./{ YOpSI6]Gb 7:Ca/x=?}@sf{X߲ r7D.S\qףĝut% rbgCWXw6NboQl+H2 4;Bou^C"@>h1NS(V@˗HdGyy.] 93 F [ )6M N]p{mAiMҔ GVqrkpftCh+bjȾ!zo%nR}̰g'Ewxp@IuT-Q޿Q0$Cq*{[)B|.pI>JfXTqC<C Wԧ&{qUOktىʥ!>W8|m$dN:@r.TVq&5Ðy @&A1f|om޶:=y` 1;h'k{t;{: kFQi07,CTA4h'pnTv aN豲)>{ R)g~kTԡ/ pIYꢤ6ƹM?՘gF._6ߚ>t`[ ^n":r,S{UT .|t{]`,Oʎ-w&OZxߩ؎6J 3c B&6]aٽ[vIv)47ޖbRI}v橩7H G|e'לpGE`Gtg *E2*HK*㆜gB+a8 !]NOjФaڽwBDnX[Js$CI5m޾pD{mqar0%K *8oo)̢&.DǢL E+?R9%w.2Wi0a3"LH^_xiDa)gk%N@0XIt$lPAw''X> Kn }76ydʿ3Sx\c)ѺD#UkźG}4 N;(Hk1 $˃|׹J $] L6)ՀH2L;T*kǵL/7!2)̉F7N5Dsጻ%'ާiyɍ w+ R~+:2g %!$V _kVom&D8GPnM\j ae*lzZѩ*s%]c)| @E/W.,T}piypp~Gm+D7=k乆^U$ LrLSf)0NAtڟ1fcdh_W,i!Oa@A(`#ҒqH,peBNY1SLPZ6"A1ҕ5~Mh>K Ne9aon3\xp}8WN{Cތi"n_c,+ixZavֈpV)B_,޵0S(MulrtM:Ȧbs*bYyTL ״>C+e׈o!y:>rE~D?JX.#񀰎6mz@U>R7Z¨#šrl3~22KLRt5^ImC Hb &_$K4(rFL%Aġ2\c3QX hβ ߞۛmhbYB7@SqUj_FNTs,pL!Y1Qvp6 >B $f|&4lj?/([O@Ed8 4v7`n-xj >Aa=ˬ9܇8ꬥ"ʃp*oB=0b2&POhQ%sQkB$Vpx` 2ZQRyw) >.U++Q@=!>o4z@mۑ'1Tk-`Bu)[q7r$5ܵ32*Ƅ[:^^jGP3{0Ba:wJEayX+` VΈ`U6/S<0 %x-?j!){G(0n<8鬌8 >}9@넺:x{ u`g'O:A*V#hގP|)}^,BN~W?k ) TNu[7 tA֠=[$3c4VMޱF+VlE9APıHhmGP8d bǶ>rkCjU[S$Rz ѓp#9ی1k`@_t)Mdr"őDUT}m@6U[Rӧe@u S1RGpzI@R,XQ=ma~`n$£TuRc#^0.~2f,dS__yezz"sNŌMb`pr&$Vb^i7$ .o&u q!a33KR>fKlO{m !Ji CˣAct)Kfd8&>PpqhL?<)^ 5_v˝^̏8:s;-C/=0Vб1|qJ6|ߠm[Pn=5. :HRBaXZ P*`-_ozУVGזnrXbBe>@<ن7"Bvz_]Yq7T7㕩BqP KS1O~iP)#(!5NYԿld=1P@6Ș.R~ad1|tNH,fL.th@y A]Zbɚ4CTaSaKr%Өk:adH/m Ty,j˯I7d_#+0ĠhK(JsLe &ʖRMD/ bp8̌nN(O2鬉4c/8[U(OSѐޟC} WAh&pdF)د`yWQ/( ͜-ˉUs~3,Yh!~,~JDvԅ3H5.\ԨH nB$dbF3`k'D-0:4e% QŬ,~LK\Y;Љjd=Wgo98]PT6doOkR3N"9m_VGAt  [$A[S(&4WDjX]g2c`z]a|D#t͇ٮyx"/㱧 ?k =Jb)ކ]Jsi,''1[Okouoi:`qQ ,vNKw2FX|ֻ8F>;ӑT s=)$jL'K}}FyC*JS[^H0m &I zjjcwήi8 Ft6A* D"8Tf׷y۳UV(X"0JɈG y > Wh)0wBiȎ|)]3^-nkE+Q0d.zViT]*xɓ_.dl&"ͱ[v1e^DcpiGkS#&) MPD) >vV[W"t:L{vY?% l}Q.CZc2 Vj<~kS;^z ހNs$d( ^:)8̃syu"dڝkݷ-"E&s UNU]GLB5akPIV2bW3d|Oǣǽ+{&y2Csj|ڠֳ^S@ejLV y:,xiMXCO;ey<{C>h*Wg*Cq(bo҃tϭVUy%W~/l+b[A|4ݕMِ抾w*~A>|c(S_ޤܙsŒLNВAZGE,Ed >;P1:=2Zy7|o3^zke*x_xQߋ;[Y%X W&JX x 9+IM &u0ԸDeNWƠM1sJ7)ˑ%r_ Dx C#;Y IH,%fdtN2> !;%E-pn̅l[xʰOVJڮaF0#c;)$}>vh``ov9bL7^4ڀ_cǽj<*Fxh#H,~ꕚ疿#@5q?ԖE&}j襛.K A@Y)W2lZd0"=:ՖTDj"+Fݣ(aIW89[$g[ /XO^6'k5[|U Q4|bcFĉ2:}]Iⓑ=˭U`7{EN_>cmo"lOy*8 dM58QHL`+2 rG3ahgrY͞$ ml/AcpVYj xU MI3.O|Um!H'!us?MT]kLkƚ|к~ik "OPJP[f5oTÉ!п4 4H<T C;o'_;٧*~+-w䆅d)c}B`^Xg(!i Sz?o矲9zy#j [ evQEog?GGH}…?;_-aL-:[1߁Sx2},;tS fȍD ;'&pNE9|r3AtEb|"r]"zD֣ H"7 H{:>&cח#A$ Yy) ٣rW</ΦRR_p\b/-Sh$I<.*Co@rI%" @$f+XLR9q"h 8Cȧ +dVYm[?Zq zr߿m=8z*?諽 fWd"[eʟpI~|Isͷ svi~bTaD]vKTTJho*60U RqZxir C"[}^fߴ<&(>td.#<YyS{ل`/Lff ngS@vwРDh ;ʋIUPags)~rf3ÎEM H}7d5>=#NL͝GVk@~˦c5_3%Gz\9`}vnA$øL4Gxk =`UOzl`zH|Š^cIF( =Zҕe3G&[/w=̈+kYD A#Y?P`˺"=B_Dt1*cW}8H39DP xaJ(?uWfWwv\=-B`N-ZO}&IRГ+2b ޒ?9P s47Alp1|+mdk<xQhDZSejx=Q2N%l:)٦I1ej8`*GRr锼('\QG!f2gW--c*z:+'Rs,t).՗PMQ5ly@9w ^ b7dwquѪ[dޡ,(hD9h8`VҢzf7dPy9x+1 Cܴf6#|s]lc. 5S~tT ![jRn`ߪ0:u П#Esi3v(~ `4tHGj#'iJ}I%M=7sHo,*VU>X$M#ԛj̧[(pXDixB}ӎhL5I׉/|V8*yIŀ퍹13m/B\oMIԿuVVu E-xf84?Y$> stream xڍT6L#]t]t#C 0twH)Hw#Ҡ t H*{=5k~9X !P w8J@X(P5@> KaEz2PEBA[uu\¢a aI  J莔a @PuG!aN4ypyҒnP$ tA('mF0`AQ~ -B!d|||AnHG~ 0zBPW=Og'n00y@c-> 5   pB:(_?\=oA +r@Cmۯg9, {.q3yאʙ['J,W-1]?ڦMowC=2U<̄(`xhىާQ%ElPBq3<\4=mS/qgՌ@ið9bwqPLwxɿ̝ΒNݰh$\l&Sg tk [1a_Ӛ;u>ҷ3 qAhm m,T#cxDݜu*ɀMȖS)j@0jkݴO[=;iʴFH* nrE;FƤ U ؤkcځLJ֥@9*GcB= ):I 6-2xhG cB ~x`(:m} ,>Ee:J0n/#>2 5%<}Z:ȹ5v 87!. iZ8% m.<,ң9| +*{Y3Di CM6ګpOs`| ϵ} eKw->N9nK׿C^RVYs (:=.Q?ҧMHw ߅~^.?U\.HhV.)x:j24nP 0V è("%+K`=YE4JFٗw}uّ^1cQgEVק 5"KQ&C鴗m>S!Ki.|PB%zXD'(l'#hj9-{gܑ nFwVX"QNv'+:/r51We;^6g$FkYE=e%K'\W{M'T .]( ~S0dޟ?&vQlp0Xȼs}Ksl8)LJEwg$2wޫүCFNut`_x"R:/.qa[QG nL^mZ󩙖^ zf Ȧ´-o|R{UH;OdX{@ӺG oXҏԦ,xS"P=EΦ & j@"J,;Z•sΨAq)!E\Xt1"!Oy^ǶwKmj=gz:҆$jY!pL=eSљtd>& Q,M (@l6.E:FabxPu){d;V}'OԁQC $,XtapHBR;YmAJwFl#(Q? snV ~Z+vɧ3C@}>]*)9c-9"_1RJT/MゑY:- (][L wES3 P)?ېqln;92tXп! +>22#q\_uN9KkX 8*v] 6 ʾ &"cnF09HQ5pta3mt;8Ӝ*agx}U(9?h[8x_T3az4W.~^$$kBZ4@]i?4D#}AjϸN>"B+EOH UװòS*:M[ 1q)u 𔫖vBs_m/%Q0{Qv%{7˼w?0deLKwށw4Rb wnF.;H|[w[}rqpYSBX⇒pm"}&ZĜЋ{ ';IttK3n$DŽ@7;/Ҡ11[lp͕KwHŗF]^BĚ=ACO(IiHgX=iJ;(vsqTZy9JMD$mxlC11YYDWeT7K6!^SC>Y8).ZE!|KX>;rۗhmz#:@oD3lf^Ej!1ͱ> <̽$-!3/츝4*,$s{աGw\a|0j%M)viٱ9%JlBrӰl²tteĪtay5LZ|ZHpe:tgMEwlC< 񎽈4I r:\%PMXd?y]Ztsv}qe]z=3YAog*Fo= 78saO\I|;#BB!j^,%"Z8^wk0% _Nlu1yC#b"l ' S?Mi +m ߭MOu?7cW#f\r/r@wޞ(kwix䭵r3NYlHJ~8˹gVB[]Tj!(Aw3A]tظ ~kNش"Ɠ_/b>w:AeVFf'MOL?4 }wpx5z{E?e )cBa6 Uf⟤,ҵ& k.ߴ$3iGLD'T67ycJKB8F1]~];|&lv?፸湈(*ls2F4O;e;:+sث@mfgYIn'fMm䕫k2nם`Z2ݸTӋFӐS?I:$)~=@O/\ik#-UBi g s߸UÍ{TIF+K&d qGNtxv2ijj:(}aWmgnA;oDvGc!-pm' z jp@߀qM3ū7zN rcV:/]soCAdlLoB~/ 3Q$O}84m"|Do@LsHqM^w⫫% pwU2G LdsXRw)7'[0STM߷˶U9ZbQ=NBaR-/72REgyFu<ƒG[Rr]\U]'$L)Wßs9C *zCMve{Ca'h[FV@Vdܘ>zT 3XHTVY?^J >q|8C*hΖ:_"Muh1n]qqSy!侾! bf$EwF!dwcbqֽed3xdFFt?cKyVݕ}A(7`ۓ%X,K{ͬ,[=¤ (34$Qm>~qsQĒ<4mۘSO)SR/FPJܱw|YxdgB7#_]GY3lm?zbRyap1ʭ}~lJ* ]@}Qh׹; aחoe@C;hiEL';i  V;XM)b@HfI&U*,GڏFHQPc9 m&GgAQÚ9|޷`.cgiȫ`GZb^oP>qbWoGW4xjoZa㇦#;qc#)#z+oCL}%PE`;zg,C/VdF`DMgYWy;ޣ9[C960r_ȳ0 ͗ #b2գ,CsKWQs hEkŚ]]# #њzhh1'"ϓFӁb^ AA%C-T= 쏩X D)(!`do§œZ̊#IjuUl3| @O-yΦ|̗ $"53Q1"3gd.ߕr *@BrY9f/E _Xgơ4랟mnr<,qfsNҍqC - ^nP5B63*wN}W^rU~v!q 5ZBVYS`WwLZ%My..k7T+QUtwr0җ`D.͂/F"Pv: endstream endobj 2567 0 obj << /Length1 1859 /Length2 12790 /Length3 0 /Length 13943 /Filter /FlateDecode >> stream xڍPJӀ \\,,\K \9ڪyڦ{{DQ^l :330DTdLL LL, 'k@Gؖ QӛLPl v09x9y,LL6;Č\@94H! sw[8%ʄI;@219Ymv41M@@' Agd`dv0,@G Wy#Jc@ZQ͜\75hlk tP(m1ǀ030'ܿ lcgd5 Y'7':_F֎7##ߩ$Fo>G## vⶦ`#_&o˵z@falǨf wJM_9 n&mn[/v`;[/ 3   ` 2qA&or03Vzof vW̨!'"J<9X,LffVQ4+?|l};׀P7(|B"`4VHr3A$ݣ:A:NdoIݒbXP7VIg5pָ]Ʋkχ.Ow-r[ h)P8l7HOF.}Yίiʊ~-֬Je>lBS-v(~v~f} J@*ct+H^))Q* V/kW7CIbA^[4~x<0f?>n;qj>dzJ6W_$vjxb]F)}D uV#yA>qhWgFFf {ĝ*(Q87ah3Lxi0Hh WX*wUiDmìjl`D"TqhmCXLdök/TG=3M K!ZdnXRHN}oHk4S?7}xx46e;_DLRyKJ'W/88f4flN0|hz5WIEzj|wAq.pB9C"RT|zvS^bM.3כ^0_'Ta)>ߦW+ <*q.qk'D#mk+p:x)]y}Wp}t29?aBvG9 BZAL+\c+ hu f_<0`*Yzɷ~aa,FVK2 0NyTxw{Hq3,E㇪lD#I33c¼֏u&ON|*b\ 4 >T3[0.-^zmu~p~v)&hԏ!Zh!t!'!F=nIQk2ML>OPڧ“Sft"+)C%@i@i oF~zbRD ޾w,LBo.T/—,@V)uFgw̗w]t} Ġ&jBAѣ`"6ƕFvڞ 2&_BHٴ0Cy$f8^/D kAb16=+z cbexJCQ)daE^=Ln ?4cTx@<o\2M4CL=.WHz(BB#ݠQ>m%).9I}U?zXU7PbFrP$^?mW>\'a;$jFk5"9?_qj`9 l-ᘩ'̥#)%Ʃbk {[J*QW*߲Ӗ.L{va1MY|T-B^ y)k]҇rx#Db&SsxmZ}4'k?;&-g)?traf(rZ.̋<']z On~ QR($T֖u^ܵr14Rk{=LYbwJ͒3d"$ZջWfo؃m%Ar%[y7+ਗ਼: :L_71y k(Z a!t/58 RS\qWէ#Pw>+uԶT,W:ϱ~U@bPtqriTB|Qʧ6.]$] vFDw qlӂ;\A4I_P[; fQ?'ǑD^^sq~۵6_x+1[p= O&]H` w)huAtϔɸ[<ʯߪ6Ƽgg1 A?1ȸyl6 t1yZ{f' l0(0I+*MO-92=pݬ ; N$S-%s T7R?vW !.hڏY s= )~c#|e(*nVI(8͵4hj: [ ̶} ӓ k&%^ީ¬㺍c #B YFWQQtJ<>CmʻOk-*g p-( x8|m!/nK7jZDA^Q% 栟D|sЃq&i72&>+#&s)DRb nsþ?K\Ul,Yûo'X{8[(:YJ6&Z*PsȖNN &P37.c!"cȵ_"9x 4U~Fp@#AM9 T) 9U5`a-"93=L,QehFCUxL$Wn} `ǸQGnĪEQjvvԞo@RˁDؤ^, T?̌Rs{g2DZnKۉ/((۶eB&oǐ%[؝zE&[LU% 2Ծd2r/+ ZgL&J I^ʠ`dVv>7o?QaA)T7q>'!Znng`K}/ו`^KnT8>2[ B5xڼ9۫;d$Z: d1p=yx5œ)qJ3"۲Lg jTF,F[[LB#6;5>"}}M9ћ<']z`V"9,h){Lw5'KS}z*Es?uYl9|0UֆS]--Exu8gI)brĺ.39 3JH=ɛ SjMd|Kv(Zs |Znp0wF9ڛqc>SJ]3jzr1nbi9ݲM׈&q&֖H*tAOM}H%KI"c5xnZϏY(=f)hn# |F/ONk!(BsV!/f犃Sq"^` &O"l//=\┈\&[/zv}d}N ԰THn{ˠ-k!:I_[A/+B'2NZ|^J̑_8w^ 4a;[  qDpPh9 "~Gm`T> "`Eu0Kl #tjJvD$i始Kf >OYha3.kc0<ϟX;{15'[1`hq(FI y1. Ø_bOWJ1dß#F̹n8pl0"=鮅݀Em^>6LhyW[h6c̋0G:(2_*wP waO)P-9Jpxăm )*Ig=eR ? N*p ڲ`D4CNiЗ*ͬBY+,7IP0yc>1 L9&g>.U'}~:hzx&\׏ 3WHsy9U#jS8D?iC{Nހ*(E[zU"2hM| %)c6 ^{ 3TEM'lO#S#|!_@kN9]]R83˄#3_L% &zCУۓ'#頌h"xZ/ޘujGPoF6(*{;zR|>Q5^g)j[ptMěGl_-Fwgѳn5%@bSN:A˼Zhy%ud^mI Xd,{wUOފI2s-@Mˏvh[zUi;0 xHRXzWbGMmS5^t夑rϪ%_o0ʑ%2,kQ0ﵿͧx(85Lo'uɺu(p'ĵ;b^"LXi|퍇, -ǔ4"N m)S, dg,dPZm\WL302-SD0l-Ӏ|}Zޯқ!Qy".7 1Xz16TvYf գ@ſO=?UwpY(ҝ{솹Vʮ7q=EAÃlCu{s |տhTaC5cZEn; eCQ\}DqF\bZP ̾In'o*M%s-kב/^CAOGC 16­+y6; V:ou U|V iR>-)T.an%RfW{-Aeп#TuRl1 x7z#rN+C e :K>y*Yj\uRBZ[gp4͎/M(!s6R_z8 eAc=Hý׾lb?h:9Hg(x&B<}wʛ5T94+]ƣ|K&wfX'{_\ Z IW5nN~ ON#E7 a.`-샗n ׋V-(ODfʞq=+CK7D6#x)W,Nm+C{Qǭ{6w!9WZpyc@= @ ϧ׊Lސ,(.hs %u3[!hk,DS=Ø"IR$•ƑCIyGJȼ񆒇?6/؟n8T?ݽE<֦רF`{n{hQOlsX/wY1)ߜ-p4h oQQdde8ܔl.~lo2LcwCf&boSn~ӈ@]ㆷG0:#IsIZxYqa.&30oƷc Հn@?DaVz9 "s_f (vj8!J8,rGopŘ yFQ?$R~)+Cq](|⯅IZK)v;,yBզnqNUO',m 8s$(,-r3>|Ms:3KN]e RzL&u,c( 8GA,f~I"|IXؓAཥFY¦CXFtn-|!M(t|* nU\0֯v^6`cǼJUy1 d"3/m]ƚݚe̯M&+B׾୰̝D`_ *@ >Flb7Ff@W PD\𠅩rL30ʗQZ[٢{F ӛ:ITS>z}@V2$j{(d4!n̰ǕR&KQkBRhW=Y){t{$/KlNRIyYCЪ~ -8Cl0r8[@Yp["8vQ^dc~5 [E8S UiyC$zs/'BNb.9A?5Ql`I봿J}qy aBqQù#ĚᦴXYb6Y+3m [q3=l6i"tv SH',O)H=)qOa l0p/(K &.,Vփ3o_9T܎QⲈ .]/3U|܋AtW105BПbi'[?ɭy8ߏLܘw69Hi~X՜'eCSqږ(`e"d}aj.m]IjT>2PKGx$&0մ}z:kk_`TT;e 9f /[8 ^ 8V'S~wpl9rry6}cJ"?<-7{ vgƽCE!h:.0ݼBeh=ٮ|{==Ɍ<O2.r?1Zc@'QA!lbߤ!XV֚ٱIY9c 'Zu/KNKp@E` w#PJPJ$(!(zIRYZ'VcĵxAHKp(]viSNzXu.Qy mh\ ء6Ɛ轣idz`͉6i D;,Զ@Hc;X\nߺ~OtfI*W5\gU5>+✿r$UF7L w m9D=5q[Wx/?nYNsJNvVDzr??#;/!4\cؤȖ"Lo KcQϕ4f2ZW8x!%0h'tʌK\v_=GN,yCeVt d[A"vWYQz7CnΏ@EZ>d f|& Qs4D BeT`Sh[ZHBՂPdHU, iһ&6J*OKd# u+xknz/0fe-o9IaI[I,[P>MQKRE&Kjb]Ñj}VT~F @ʙ!=A,EKMC$B bm,Wviiu}jyP/WOǚ2Mdǎwi)1Oh;i`!ط xr؂YQc'v^ΥKw^Β Q/̜C0vz,js#I_Ety6e-DHʣϓ=>ѣfɰgZyv6Bܱ9 *8FkUW Ksz8gi*ʒ^K6gaҧĚXFݢP{C#?,,DO c)VK,c "}!mNIid19&|쮕v<3]|ņ;n5yrcIa[Qzw'} މ2IkJ܃\KfH+(roj;e%>y*¯ΘM7*$e!4#osSeoYTR+޼A ` +dd&UFGgZ ?)rA_վD=G;L1Y5'mTۂUoWsP՚=bs9J+yk{NflHWCL{a3QxvN(N)Rep!e^6=džrNV"c" ӻJU ܒVuA endstream endobj 2569 0 obj << /Length1 1370 /Length2 5960 /Length3 0 /Length 6892 /Filter /FlateDecode >> stream xڍwT6R HK7 tw03 ] !-4()%!ݍ}[us]ZD%m(aH.^n @ ~nItma҇!p d `Ma @$7&ȁ=67 A8Lpo7=ߏ5+**;vA0@ 8V;:pk(H'7 wd؀R AC$w񃝡NuGފ@ ~+C )W buwo|+iӿ E(@ 6P_|ˮKiNPDz\ nex@ܒ rYm~ɌOPq@\|yohMcGކp7_w*h2#ۭ~_mͿϿ xAq&ա-gUT\˟0[z"_s}U?q)'Hќ, b92 KVA,qvAhlvS&hQ[$L\ wV\"VE7g脀. +ݺmDǸhdJGfꮫ5w*Cqd۷ޞ|Jp" be(H2(2'c](1G[iuiexE}gmF_CE)"W`|d}hF/jN~0(.5IҪSPbE,f촗oC!vv5!}Yw_,a!o.oqهW؁G[U,JLقdOhBS+B>1| 3^iAK c݇'EB/=${&Q%:(wDq"F4g]L21~by*WH 4:t8|-0B ja)-9'Vuj:0 @{<=- mE ݖJ6rJeCޖ7FcsC;۫MAU-gi@1 ELCӳВe # '%EIP?I{pC2bo7j9>B ]MbeFtsWc ?mO9uJКoD^):4$Fչݣ 9x)&UTǾi1 טmJrHƑH)z!%_B 2~Xrz]Z^|.̣8*oX!YI:4DF:ɢ85鵣v]E+ %r$s۱s(e3C$vol6 Gkч AI9*4Gv;?+$GvoK-$Y-^ayr+!@Yg)ǡ%,gAt\ZM~™ԴzgvQI0l72ʎ_9 LQ`gYS7޴Fwt~n0#7W&DX%/KRTH#P71v,3V\hj$\ۺd`8 XdM:$w*@^EWk'銳#], jL|1܋3iwcݹ7^݈n/Hn>}0Xy'A `?->P*t.WtPD:xX-dL.Z{|J Dr^x@ݻ@Pg ]h9sēSIa/ Id?A9[IP >=~fMk0#(3uVHw BGfo`3ZHڼ)͝۝R*c9kG{?LFOokw-qaKP_з fVd=џoK#3df½̭ eԜC ۂ.pjRUpY˻LXkP~+h;+ӱð<wE&\ǫ8{X͍pNX]ꛃW .s Ke6@FqO 5YH aQCs;N)v x8aN˕SdCЭuop,a2jL@GR+=_v7e2t=3h18P .Q̛dݲ:#cAN([ߦVV=>EN]ZyZL.dk*ƭٗ d:ep9xBr;֋p3V? O&-& |ga0$_/cY##Loz#< a~ɠ?IUD|GֱrwE "Y[7@f|,Lz2͜ߪP dΞ^hBOhggs$t8@6\AubTWj<,Ue_޴ͻ#p_ɂjͥ־3N*C&F:9Տދ:D-XW`/q.R.+DWzJR̾i}.zv:~P/F !-rMN *,P~ ߞ jV_ Yçb4%7h|}Z^O/=+ʊ٫O9XӕnegM^Э2KYTruÛ`T;e U"o6o)cSh4&l&"7%"a wã:mL*yloIkew͚XU@fù))o,].` gmc;uM) _0v! KҜ%G Z\ݯ7GJL|pu+!y]>KR,IyCUrUMӐm3[˲cV-CRJ V>Ԋ Dy>mtU >CH:\wX}s-#5{(^c+)RE;}two$P$$Zڶ膔E0Zq? 2⦓L8uRI1mg21oL)˴R|îrC+`2?,KDIlK-9.hq,ܩ}fjs˨{sS<*{۟:#AZ؏DrZ+nt$% 0Pe+4M+?qbdJѦhi#IXԹ> &CP8vI!Cu3\CVݷ.У&%B]ϓ'>‚^ &sFt':z\͵srKO̺o(J|m=I!Jt.e6 n"V'Gq*OR{8O`̚AYrVD0EW1lL'KVT,IJDlεQNx3etr 8z ;I9kyW++mC\+iy63b6 = ]졯{xlPǽ l+Kz|,G^c ԟ2.j8$hF$\8! d)/de[ o r! mp Ű\2PfŸ4,*8F|Y_WmdL|;+fVll]Wcb$*F/jdZ%̄j,*eHFoTl֙.6ƃ<@;zB~tPV A>/zMY@i.[>wW/ҳ+QȾ: 3𨟿$r bj`Dz0Tq_~0=T$r ޳7 }?@Li eb % :{&22JG{j:&_Q:>/` 5uP]̰q>`}ì֊*Hm#PjV;?M2/&~N6fXHJctFCMʻ,n(ZRD^H3_hI(NY3sa^=nq0FphOLZIL&5Rpv]3S+7a/~Mg%S?Q]);"J^(SJȺT0V HH}<ϗ4Mg@Z/:.{,n5ܘU ?4\0Pb{2# G::6 >[dbAN;zv#&]zU>ص> '^ HDJ~F`7 Ҫ!gC?ʏ׺B7ǭFLZ Go`2*NZ[*&O4J_3֢pؖp]cF+ ajƼcuXameđMAl]5v]2I?T6WTa!+kY7lH "|~1-fv֫̀.b9(&#> stream xڍwTTk6HHI 04( " C")Ht -%]!! ;kڳz{mvf=C~yREmCC!a(" пDP$ K/" BclJ 44ܝB"!1)!q)  J D J -@("vE7fIJȻ@00.`3AJ%FJ zzz \Pn>' 0H(kdg4"v a!Qw8` յP_`|?O?ѿ࿃A`0v0g(@WEK_@3 y` [ w >|(0F `οfp" G~CB}sNp' 5UUWCQ (^`_]B̘|];P?Gy@h;;"@``4jcƜ?0b'0 *(=3 //0_XT ).; ?p;@n1w(G܀A` ps (w俲?y;;s? h)r{ HJ`/9P= ˇ @aHŨ%`̄E $MpIXT+#A8 `!DTB hD`w$GP/(hzq i8__Xj 5EsLf:hLU`)Kқ* xBϳ{6eђ%Q-ܱϟs~bA'Pg$15/]rxk3=Z+_QGMN[ID;/xht0o+EeV|iED+~ƾ/FJ{)ݘfyáJ1Àbѭ&6I*:(|Z+݄( gBCUJG@Ўu 6Kx$7?-+dne/oᩜP/Q[7rۃ~ZCD!*9υΔTq6u 8b wk3ZUq^EE$uwy+>_1(ih2X<k{}*m6%Na"4, }…zv Ge%5D£%#gJNǀDwi-L/z/pqK9Ò9ܡy~"g3J ޠnjvO` oz*hJN~:di5n-$<[+K&1ۺ+s \Tt20N E Sڜ+ݐu\9a޲`U@1<Ŋp |Oar892LȻڌ>9yfq~V=Ɋ O~Í3`y礭TLE~FU?xṬJJ:h l!#0=skZؿPr_-N N3.κz g.ʍ}'p_6!0 c׮VuLﰂ_JxKV+s~da{N>. J1ħ?xnrs6qnZ]uhd6xU8Vx$ PDPM77dNjJ~U_R_lZyywE%3&wpy(g_=}؝Fd#Qub,z,}CF{L =D$lݓ2jw+932j\.t?vUy RZge2.C/>OspO:ڦ*`Ra#5p WN ;_KDꢇ,DXCTRY3rzm?ةG)(\ƒ9m:>\8a/((=i*qd#twHNmydp?;r\ G)ȃ ݥo`3\°#CUsosmnše[3cl .v?nfB@Fe*L7E}נV,ͭE:!Kڜׅ^J'"ʜ6Zi~ԟ''j #Z 3lFgLv/Cߗ̗y5 wd$[aMo&E4_t_͌ ['תo=2WFDxP+TXޅ +nH^eˢB{!Rڊ[Y:t|mPV+d/ZʳHZY#3eYKV[t[84׷8ˏl?20 5 {5kMldpoxf}ݎS {1@pv K27 ُtwbى!<3QZ O'Ctd Fa|p*.1>(d 7sDž;cUaBЈ[e$4ey 〲W37Mɣ/Zt#)! E(E* \[]ތĶȬ}c rqG$y؛Qw/6&];wXi=괤(3R!3ݰ|tU␈E-Z92QbMnJ G/DZ ,&i$73%̗4'\.DC^^u .j?ǝ$46y{JڢUkULH}É*-46Cfd4SʩQ 5qn0{޳vԺ.Wޥ1RN\ccu[,*KgxMIb_X}눟xa'ǵr=\}Նݴ]ŠTAu2בM)R6Sp$/`MI>~DzXhDŽ4pHquHS;DZ97$Aw1#ikH,5KSM-K-#j}pcB\M%IJ\aQ!<>Xfa\ v;9ڠwӪFi[)2wXBkxݫ9S"7ۮU!Ưm !gL>^u%XNLUt52H|BKk˔ _~})~I:a$;#˹FKġߵm] -~ס+=ƒG7/?7::Ib>ȯf+gVEP ݷQNnEBIV|j͸ +r>oi*a4GǞ:<ܢ-um/Mػ; R,/g8=LYܗ2:.gD{ pj}ٱ *_hǻeȊ#YuE[kjQw2̩o|ehO͵є! z3!nrXpk[m4_^z$(ymϿ#.TT~<' 6_,e9ca⨏)Y=X Y%*Z^̈́l5N-3=ͼYTNH=C[Z.Sܛܶ6]c/^=,I}<9*0s>33{wQhחǶ4a1lZʓmӮhyWG^PvJ{txп=0dLo}tXrP"*"m׶$zyЍv[|-u1la]@t2ys q40|yyR'lq4;޳DPx'cm[WˇzֱsW>yց cm %d^q؂ņވ6vƱ9M?A6@pY&EIr )oʾ]`#Ï$*cb57 =%BH{Vw EmUغ G7pdL%, 2n+VWgL]8NkDvƵnM<7n3aUb[f>gԔv~o>nKSk\L~($<%FC˲|+Gh2D\nρ@&]b_0szhke-:#=bNKuq$bJ4PzEg}IRIUQ+T@V=If>)@8~J> Yvc`Oded,qg_ɊC1FkϬ ı O(?.'M 2Nqv) QcՆ>:kk+n*6K5DReO)̳@ pfSџ5 ̃qS" <~ddvCtM2p4h"υyNV =¢Ts e?I۞iY'=&O󾛺- 1ې,a̗V8?~~Yb]5vV|땖]hu3M׮!#cC(+dQ9Oa8ᙆx7zfz#R.>rx4!A8Ga|yVmfv=xFD-mR^B:} yfA}r;[l@ݤ+*.G!;>?A]F=v|ey0FB.%l8J8j7.rX7[kpOX* ?-p|ÙdF$vm3?s@m!Qj+yVH"v1f=W™[x UM#v`ͨ+5Եm!&REA+!+9KRj_ endstream endobj 2573 0 obj << /Length1 1386 /Length2 6039 /Length3 0 /Length 6990 /Filter /FlateDecode >> stream xڍxTSۺ5Ҥ#H7 & wAjHB$t^7J](]zQA^x}kk͹d30T`($F$[ PT!4c$f04 T,PD@4HBRQU C!ahN% III(<0 8ܰ!`0H#K {{{ B('y^7 0a^0(=hB$g8/1 C!H(0Ðul$W?ѿ#p #H/ Fa^`8n PW2 cBh8׌¿`Y UA4ɯT0v}+{GBt6Ex´T`&ۜ`PJ\\ =| ¿ ~;31`pG 0@tsEps#Ik9ƞ`0( 7 iݷ43(@PJ@ 1@?X-# W}e?#^?s顰̅xMtk;_YWwGo?_v#| `UjPs_ՅAn€jPB:a-+Vp /e77 3@0( |XA\w4]0YW AAMDL`|~ ,Da!쌁GɯؙhW98rLV{[0 B2?Ȅ8UbP欁gՈ" zX]tQeg: MqDmLПg'Dl* XG.d44Zxzl.˞#wN+-n"7Z^w D8N$Ytfom%7k2SiCu&'NwiW`O4(4zgGl)ð {x1)QMmX㸅ȣc7RՙݵwۍF=UsRպ\RfAd'dPYcBA{hۊQK,Uw ^4mu gxš? D?|p{jn+Aݥң"ę7Ej:"v"7[Q$[>S 7;<Qdnef&NJ[DVҡ5r=gUw8(BJ3{9Πsuwo!!|_mTEQkWM%i݈{1:O;̴LVAOE;747LE?!һ$}MaR4͕zWd'~ 3C?~ՖSv[&-Nn䃼@jie5{左[F׽Ts UIȧFr):]JZY4%P!M?WșhϏ$ءaSzGQ4cQ˚]WV?X[t8 4"Se =y<#0lZp\7.E{:pU"U^hzzIǶHaITX>oxYPb'yq)F~Oi7&lT?ˮge(l~90qV9]\|>\*Zdxv]W}[?+gM)e Pjo}q}G.Aj`{ƴ5=G3WC*IDzZ3+W- u˳m7fHqw0LgJ+hR7RI[<]6C3WILggdgltyͱJR%5j0[0r'm>8i(s>{meǏlp|in|;ԙvgn]I0S? !0j)n-R}E:/!#G㨛U9:o۴?5f>b?^\sNMܥb=!ڌ8wnc\6΂'2,Uϼr`}Ʀk^%]q[9NJ [x;N&"- 5z.6B<{5B޾K~'\}BЄeG4lz}]g$-!JXo*T2.?`gl`)V !d~oѣnW?wݑH ]@ O7}oz]y)1X R|[727r4UE]zaEi-U'U7yYhc-b0kx'8tx.Dѳkx%{@! f njuɁby蕋Iv|Ho J8 3$%ͽl˾&wIbpa[rfR cG(]S6!bs~P^Ξ}<ѐ&A$㰓[v²s&>'+Su oR!Oωm") gK[A!ţըC~moC| [P輱:Rǯ.n"cd67wK6Ù_'Sp|,F|a.2))9 \++ĺ| ,"bBnUhME3ƢQ/~;XT悔 MqwQ,;[П!%7QM9J0XHtvdK.8JpS\dYiہQļ J)N|[!=͚QbY%F~=Q?cґF՛^gl᦭*Ҫd_-Ei;·'Mc]L]ecgz z 6R kSHXܕj^TQ J̐e4>c V/cbje`rbqؙaΌ O`kn_EkV2BDKW i7Y͎rK%ȑ/ɷkhԵW{|Czn,)v_-vwı{ e yѼ5OR d;, ]kA\8]vn>&אY8Ca"r7q֚啢s;<5 Ll@.Or%Ռǣ==+䂓6sS/n2~ }URڈV0fo0pj22fm˨@.g^pdt,Pb쎆DY0g+*mռ?sngS~)nFXN`fLe鳨N}t2m `^uyu'cS]0 `%O)Ĕ J(RK0)a䫌  "MO-5Y@+횃-aF $O8fh1*N>niȩ.38Ep:Z=g\P_kn+:Xh߄oqʑxXv:#-"]SY 4{r#}1E(BuY0ՊcyOB4/rky8H»rCo 27n'EPf^X|;8Ԃ&Q`YKFY4@F3nfyXܤE)b /c=u1r5|!*x]m:1LJukgsC:!a\ ݅xVfO^z3z:G/NT+t kNQg7ʯ62OWNm7w|PlU((?=$F_d2R^_EU\UE"||wp_*IA؅ӊ)AĨq\ݱD?jTI?"+!r S ;/B،1ПKfv#{POlduk"'r OP5KֺAyY9XbiD*NQz)hrM3Sv{COEW=U#sSc/$.gK!Aj Cb%\cV 1B&m.T 2@"fUR_B>kqQy'E w؋,%t=/齗AA]ޣߑRFɓfab<Șp[Ci$q6qnyQ 7(%CYFXfr9bR3ȓPW@яPHVrJU͋7p,lk_*Oh}'yIk|N-LKR}şua sjR8Ė8w_noUmNf S`{*js,W|ƩI)i"flvX=5S]j}1w,oPN5b* ]*"KzKM%)։u.MCI.LDb#P3pAk˪kSE]u.z_|>M`qX>u"9=zڳaz s}%p^5`,hoN~Jxd~;B jwgTFCVclSd,iRоTsIXa-s*:EG-t>ğJX"[ss=d_SK hǧ'y~{j2K` ÍexlTI&yʞZԁ~᪸ nUmV}BWQ9MD`Ͼqn /ο`i$TעKr3ݬk-=mxA] Hb`#b\ ^y)Dgw06|bNmP`f&2E%{ E{S0d3)Fy!Pש݆mO/O&h@*-.>͍$lmKPYg5PCk-Ǧ *\Z&_&FLX?o-X=8~8 .+"=`Yδߜ7W@Ce+37q㼮Tw;?Fz0| /|;ܘ:o) Ds =K-a鴨\gWE > stream xڌPjbݝƃ; -܃_Μə{׶k Re53{3 #3/@LA] OArGO ttBh.7v~7TȺX,,\Vff;č]AfF BdajS "@G@hhjlP7='5/ = l P:]fJ(]#<@Bx؀LvN..vf@G;;@MFXoz`ado{d/gcSS{[c;d(I3:;24q7v5+uc drpvbtU#_a,ag&fok sv+?q#L92\4@]2yYܬgԒ/u࿔,krw{9Ύ.@*@Ow1o>G;7 3c3ʫ*EE^ lVf +;Q6;ؙxNOI;@o,E,3u-+ߌ$]llGol 8_-_S-ߧ4_5Yo4 ;#3r$h r6{kkuo6 ;݋ޏqz_7vf+'}~f@-3^rrD8LI0A<&".f`L2;Izw>?O鿈OzSXL;ήkAZE<zz]gjo>HkLfDx{6v{a;9.` /?⽛X@XA">7|xw{;b;Qsxi;˿K:77?r: ؼby/O!?ntD' {&z-{Ynpxa&c=d t;< .-sKq݁K|AV5AU"n HװZ;x*bWl"{Ǭ%oީKuM']X::t,ϚTݮghp?_eJS6Uܕ[P5fDfCjhm!w?I <|Ha_NL%8:Br8v͉/g4 }n Bm4&/SfgRr'JFբIz`/Rl#|N$݄jˀCgRz'2) I8E8ɩA5hrCSNI3# jW^ ,Sp# z6m?@(õ ji R'ޜR<\'V*AxcSy^CyjcDWy2cHdb<>Η-^xI:37Fa2+yNhS m‘oAտAo6Z)oDգqe> L郅$y֎pv ˪u|u!OՒ_(E祑dk. ]`R^22n^_ E\sӱSqLAƜrfl߯IxΗY29|cT=ZsZHL^)v|hTLtB>c.i/_T}~M$!'4h9y'glT"6&e>r=oE~?9j;)d򺯢ey8W џO/.nsJ2~!Uκ5#Rȩ9搽UN>aO,*8Q6 p~XhHxFϗe8Ή&ٸ6c(ϲ:r;PįF`7E"N9,_\չL?AC+ aiMd)5_ҊzDC m')m})hM.. ˏ9I Ra'&s-2g(u_&|I*csԟw ±#E@5+ԯh()<-gO4 PH+7qVH!kX.N{A>5}C/P£V A"vt1UO- <-JoGHMbo׫>2f&`+}>+f>mWfL҈4SGo6GA$SV䌱qb+8Cf;h:lcd$Ok=KW<:8:Ws>6-+,xkWyeDUUr1a?i#4UA`8 rrlͲ҄MBkc#44NKm#60/yL]͙0Ez$mc"Yv]Qe[^0kǧr_A-rgۭѿM{Rż镱\Nx(Yz]iɬx6d/?l8cuPJܤ(YM cPn&: ]gg.SC.q f)7ɜ]5.>6w7tMYΛmX|>*b{s. Q޼e(2I8[tt䪙6lsp[8OcӞcS b?9:tϿTP>@`ʣ,3PE#0K4)) ox $BNJD9eţbψɎ0{E,I`9 U!Zd.πDkcUGm* aH oE!crg^s(Odswg* ۼ p{|KТ\R˔,qkQnc 5sV,NKYnzdy|xGE8t< G>?Ba/@>64(*$2i$`jk"{ȻfG͐|VғP+ YQM!uO6O>(z#u| 0FНlأFdH6~o<\qG!8:7GksjauPpNu+(b4D=;TM/VzW:}Zsux{8w fo*9p~c m4gD|ދ?.$eD 25?BAk 5UG9[1v~1D`+cX6kv'Ho!*u~a6kensfAQ:S~\:QyPI"G/~ҏ @űY$hCŊy&U^ܒ +z" q*75r~sx:B(؞%׃_dC@]=#ŹE S9ւ2b'Bjç#s0Us X}?CtDMyX:itV^Ѧ=hO!s3H`_υ7jY : 70ق;˾m{4>7~ͥvqr(Z5mFSB/xCZhM;*u-$ Ino/rn<œ>UT乎0Z.E+`(q=D(7;Gu iKlVN:V?#~|A=u/_τqJǫAt}\ޡ#n=ӿu#:5V~cAjbU⇋t|ۇez[=O#C{]n\h0)6O师4 _ocBtB-WaPDE=AG)74t{s2m!~/\@(V~Ak>[ lGM>=T >箘^s(m6ٍyn{`a Y9^ݕ"Fd4soMg# 0D<"/#D5D1vrƖT$. 뮄Ă7c5˶o;G';ton}JzV9p!2ZŀBƁ_FuB+0!bbA-YW4s˨ݫgjj`J&ap`n:I"n˄Ċj%qoFVOHMn` Gӡ%J(NtN^Y.ӣ~%2X; 0q\>L _S|X*]4 cFMKz{>RHw]=:NkgoGmX5r~(*+.#κ3pFR'+ND 59x^{?Fm}0q1%%_9k`wV#ey~ӭ"8s>|2 c /=Ơ9+޾up9[zܳfvl(3aosz Fp:&EPgWȯlU<h gj -[q22Vl?(z)~! *eK+&2-\%26Rc+?F6щrbδ0x*+enM-0EyyBL@ a6w祳b38"qk?8*ڸ_ıyV ¹dT@fcg,T1b|mcf]Ҭ?ǹ`'浵x}frgF%a{2B֐SC?Kל?QwVnZ3^^TC``#? 'x8Ut\8Sbs+ rfC^Oz7-",I=Vi?j(rt[') m-;meq'+RE̷_yfNZ|#I7j `m(J'řoy%!οg¦3:='=!wJE=/cسI8g[sGV:ޝEqLğWh֊ƗK^ք 1"^KxV'x%o$4TO/ SFHή_Zr*R߁: mՋ~Z|`RRėXJ|H$!lL _1Вmܙ^_qvs6fب$ݸ*q&;M*n1>{l8I%[*og]F Drڪl^lqq?J>XJ t*TXAAX|𤖭xx8<| 6a S!H dhN{er)zz5y$i* WiȼqMSȟ5,gK23`| y>d_HfKtSd $ Ky9C5КQc<14S:̨.Q] /o ]1z'p~uFk3BȃT]ӿ|P>&_J4}c evYۉÓkIԄ,,=:̅ORǙ0`H[LecGQV)MJet: mZ0O̳Xcz(`9a(O\8oJ\5^r=Ӈh8KKbY#$y!!{"22?X 6z-Htn6-`R2&rNq0N b|6ࠡh wԸdٹzr24E7$&DN%,H/l}/yHG)䉽 6tT id{xk݃[ws..x+v]Che S_-ۢ  4oV=q\ (7O, U* )峡&M(#=·Gݳʸ,}/G^F J Z|hǥFBm$.C UStc|@j˹fXXi!ʚd@%Q1Mq2N1!;y9Y1eq(Z2m{]5:H+~ry_J7 ~J?9D Nkw9;ޭ)$} c[I'`D]jRurg ǘ&OY~l7):L D{r:Bo 倏|CQ9adʙy{lw yŽv+!Ta=M^>z+8zb 9}̴i?ƷFN ƳrJBǯB=I'tS}6&Ϊ +y؇~/W&}E.0>#s4)0n^0Z/E d0jdghH}ܥ:3, ^s?C/1l |0FH_<"H4?4(TJvnpb ņ/KD^r/k 1V'qVSlŅVO'}CH K3V-LSzٰİloNPp굥zcŭ̩XDUcߚ9yY24AL Bx37U|ZehFb)`\  bˊe5jxQ dKN0a(mm65,"J6D u7:g[TmW7<]=댟o|c=$dGo]^V{""hMtDB9.zWv,s3X17UxE3W\=fR%z-Ħ% B#a=_$?^u}@N6 \̀ɾx(ISx9c"[)yb>JgodG[jf(Fo%#z@8 e5\A"IbI!޽ W62t%tn&o# HP|>g67eDT J6a)AEoO. L6eci@ʤxn]֙"pw8g7M*0q-}ԮD 8JEF2 0T(j:znr2C`mJcV؏)oK]OI_Jf ٗjlmMN[FU :|KBztxHb Ue\ X9hr8[J.;{|{yus5UK_EF]!JL`fE!ށ8B\3P ^ K.UC`6¡ǰL79̧%Rw1[p㿳Ax,| Ԕu= ޺[UHUC6L䖗өGV*u,z}f[Rslբ($;(*^ȷ0Ư se4]DM3rg1 Bt~~xzh"C54;"I,T<`uH7z,j+ֽJ` Ⱥ F⊱B l4+`:R_vSsp3Eom T[2xZ;o+ BSh^1F-SGG-?^)jQ]w?N.|PBrK΀E:Y;ԑEtw`Rq^i{v, "E 鶆}5p<_qnk] FiG$pqQӲhP%xb٪e**<'Cu[B rn*@hֹ;ye=M%+J+mi3B|>avk9# 'kF> u!~&l8 ^3A ]~01v@rqv'*/;N &X%2k;dž_':$.ćJ%6H:{z+}\uQ^ h(XNk3HdìeXalP3FKO噻`y^>{hSz`./#7QR\^hSL&,!,#O1~7MmNO{q'sٞ@)# $cKNk*jWn+ A!!]Fh6s3KP:UEe!e]3|p|ir& AK8 Jno[Ʒv`iȂUM3ɽ[Qw{7gS]L: $54$lq]puwhx״H?N>uDKlj44Rj,6Ê&l*iTb^OND)sO ȷy:foSr)Vhy I~Msp@P rMyohB+cTF~<{%Vu)Kd&@-XMvu0f9`[HJvdPr& V/Y4%+C ו!SkX3IsquQ,&_'KNRtat7ܯkr4pt~ށhI$X;tU}Hj.OK*MO\r1^A}e6C -vd]ق=~y(6^=jEAL!ҩys _{ܓ=,9JZ͵.CY 8rGg_ Mz+r煴`CZcoO3NU;3T.^lj~yIR5ݡc5Խc^(5 gxRUxcM 6:a¸04#I``km-S;%E Ny{f1v-+6 ؟391J +|2ҤW@*woueKXyQ[ *šW~|$tfR:7 vtx)N_\ ,JfEUPUD i2aCtFE8;шn͡gra/ sRi,&;g>C(uyה7 pc},0QDxkށ6nΧr1r NOJ^ Zq k,ğ3_ϹOR"R, MO/zqb5{Hml9ҽq ]|gK>. Xox] $)*_rV9|'D<@$$L9!8#/!W'cWЩ$,i 2(i,ʔEhXGwcYP(~EZgE#⤺sX[i2ޞ=6,4LHDˆ0P2uHV" DbqQ:\O4ż1/a1-K5@zy}M|C-''m";jJ$~.+bc6UL,ʼnfeQPAƚn&5xڢ̼ " x1*%p@h:/GhtzԘ|]kЙ'?yo4KCa/] AuF"s;^ WA٘AL! R} IiEOtvH?5zNT{x#h;Yhy,S묳=Nҍ3TV8+'e;yTc@TkIXͨn.|p 1&૱GUi&Um@{)ڜaC^ZhX^hä6gn;#/wa5}*dG͉}CA_vP݄-wr# <[݃8Xg.c%B%U(:#*A3Iۻ'JWqoa Y}q;^ EqEQ5} -[[)~'n̡O1v:*_.Ύ sIߘ"j2~qj[SeVs)wuJ4ɡ=H֝X$2Ii7L&LJHK ymD1bۙ桟p6V{7ϕ8WVnAɃh yH*Z]E:Dt-B8"lʢYMkiwW?a*g5]!֮``""jQ50Cc@{dD_YV2ڇT-z[ri48#džĤ WX7Q+dQGHgpb ڡ ~817:Iڥ(odhX jGC-fBwre6zrAj -Zh^9rF4od1\*/9멘yi&T*#SHTz _TD~loC<tv-7YV&}`4L]Z7iSN?[s~gP dİBVfnxqpN69W;q,By M oU~醑xqivځ|fLQhV;qObg# 6JOMKW񻵰ydF&MGXo9Xݪ34OB勺^k^+WnC &/ntvV}7 w^;\`,yID_ 3c.q4+ `5e-X#ǃ"=>)IɋRcmܙGmI7Og:\!l8#$9uU=1#̾-)ŜrF%4*`,z19JBqHZsfXQ[J! "$3_D*a|Dv`sc8XT?yuz^D .X*^n[s3Vٰû 2s Ǥ$3<ՂBUdv ѷ[_z 30Vn4B2K4 >.WSMuLEA0n&\Qk$7*x򫝳戥ӉZZ%K}sqȫVG/n=DJa'yjeRԱ6XQq!%~-X&m؅Ұ}eTiB3Nfe÷=OLU{5S?h+9oJS05l2 tR@u%=FYATL=rKldd~1/ z}Ս)Ɨ@BE;3e8$CId*MMFMgmK/-BCQ-* !#1eٺ.hnI&JDŠ]6}dXgb'K#~dmy0)%D kt}B4Sl AhǑ*J+KDžQfɌM|%2OŦޝT@tTRkR!?ڒeӠ<- SQȬQ !['3Xק \op:)'E>*0<I:f !coZ6g<١M%LmyPYBreoL0SY5; ֪ YmC278ƸU 0]㉒O˨=xEtcS ` YGM^' ̷AanmmRZpmqCybq QCߕT0.6M'c/޽fdFbUo &ͣWSܺ|KѕڢKrMv;197^^e_FbXg|ew={yXO-JoḚ`ʆ0"]"e_IyNm\ O,:M|kJD9ۨ8>_k?[U>UKM"hAo]SrѿFZU6aص2ѧ R~-P5LoQsYbT$o ;ICJ=3g[zԝYɇrXb1+sCm*xcQl ~ tv)'h򬂵'I_PY J K Px1?|mwP|ckV{OP.wx't9YNy6^0Nbp1E'cDȑ,9 LVc@_Gȍw-9nK7$7:=,rU.Dzb$/@[9c}9>VES0XXӂžrXgd,w2J-wc_fH I8'XiJeGqF3`NVIVz (w'ڿ&O%"勭hfӮNMā^NpTxe%Rj9 #lEVYMhܝ+j%f[}['4_OGL€* G561426Y PMN9xÎ1.u`$([X>pppx22}KB6hTHF6`t/#FRy(͹ԝkUkn9?P)# )xdsJkV Oێ퐾Б1g%P Z/VvCŭBf)C]7P)a?0O9&`7Bj=' 26>Fq@mJw73>*zRtޠK#2_?^ &9c~H꺞r3'fm[,Yo(6 \%|gF\4xgN4>O{P@]2Vʕ>u;qziVەljN +TE#I$m54-ѩ96+ Z{6~<+B򵩳<@ڿ5ɵBo+%Jo?ZWApV*(kjZ ec#:䁬1{|np®ڑ׌@՜y,ug k\/b'Bo$‰b-s`亿?8$ jrp]Nr9P+YNF/7O~~KS|x ihѳw;;ޖmz).@J3|ɩ9`(Z|5w>NG _`3ęT?R9"@eY&cuX؛:I`CkI€ZB_i ߖ2,uah{wu#ٖ1Ɨ*! ^A1L "qXnsR@Gcm?[5֛򫅐1,m#WUcb7Ϋ{x\K`a4Ma yad+ '( Źgva%c2jNkYhQ4sĮ? ')B8N4TQ.x0Uٯ~C:}0okA ky]H+ub%W8EP :39cfs=6z{k߰kVC6V  ޞƖK6hB>m[Kcu̙ƵqL^ȕtjC!P46Sdn˅:rr18Ƕi;iyoP]KUL<y}CTꐲ0Z(tѱ&M#Fg7ɞ 'ʰ޼Lыp}eJ.|Zu VԒLǹb\ic>w:`k6 Wz W%ʦ253G1wW,;s—ٻFRE^?jސ]M+a/0c ^grMZX(h0LyOEF=b HJTFqd6J?<`9doU1W85#5IKć\!%KqIJa^QeZ|%-R^RͻNWӆڱ+wIcC7 8:n?|Q_ք#?W+H/h%aK ]HzS|Zq}#ƔbMBi 1sժQ RvC)3U{G endstream endobj 2531 0 obj << /Type /ObjStm /N 100 /First 966 /Length 3948 /Filter /FlateDecode >> stream x[ioG_1w0`Zu,0F7鐔o='(yX6==u=U]ÑKPp.,\9YxpeCJ+k(&N%*ʻ&](('ZB; vlŽ+_h(:@:[K>y CB/& 4 =pV{KkQ xS8jSza` c` @+GTy_Q/p J2`#,86I!7cdHP4R|@"Ei'F"%`n$#A>T`F€JZx'4 (AF\A)&VSg\(b DP iH(US1/hNP>,U%zTV[**HA{1:hF!7 FtO0vv#`QVM42hhDJ#uc=udW85+G7Hኘ,H` {Jp8maqa Ag CCDlBk\k+Eg,^lImQ>_ͅ!L#]SF1So¾z[[Ouny$8TAӸPxDw#s9<_r2_ MsL+٩ [ID So%qYOdJ$<3,6Id&xD3)FZZ'ICwI]m4jd0dVŐG5POJM0'-* >[[+4)vB% 1}ަ4;-l4 Uٹ‡NP <ꁮ 9/u(A1BϤ6%8uڵJW'A*ۻQFʞӱ ӪA,{W{2Ydȩ8x brOA3?WxO MxYnVr*, Mm#::ZœNhp]㯫zuZ+ī$B_Q߁l<,W&E/ MĻrG0dq<-.,FC8Tc@gmtg .x&ZU &nrsVéMRhF# ) 8:$6f\KX5G;U:vh16uH[ r26M}LL %'Q %-WbС7u8kZr^6e?\9C6{lgH1$R9C2 ɓ:Η}{}ϝO(rQ3(|q)>|"U hDG4hQ>Z %-ʩGL/сxlugYT%] \PL]"K GK[at'pHu!ЛXҲ$b RpJ$2Ζ.> r`fzŒN>aM#<a,f6ϰt෎Z¦{m}n냯0cchJ 㱸tTH0!롤·NTe@2ih3=^ik6΂>k./] XPSv >uTym3nآoﱸܧb(EkB:H΅=}L[qs[64w @qlr G}}pS|yB0Ș܏q!ji!c[:w14R#59KD17׬^B4 NH"Ӻf.߷尖,>q>]>o+.WG;:f^M>x]]\K8//օ햗xH,|*̇j)$g._?ޔż˓MuDӭ \>bmPGx"gX</Kx%~ʼnx#%ފw JQ^}Vrq&jV/܈OSVi57[!GRmaSq:[^_ϫt9_.*ř8[($~.z:/Ĺ8}9B\/-LXU%$./_\̫Z\XX\_}f K,>PM|c@K4*~ϖgz-~^/7٧9w344q_XW_zURlrUUb3AR\p?]*E&j+#tiL]~Ƶ=?yAw/'/n̚J{mݾ^ ~uk2RJ`/ v p ON(MJn- >OrP>zӻ^*z:_[UaOޡ*v8I[h[rU(vPyo@7kF[3Pwo lI'-:ya+X`76S^MөrVKM}ɍԍlYEe&{* I lm2Qx%'|P*:uu H{(1GF~)rP vhaq?6uM9MvQVijm]m-;?h?s[ġ;N. POZuЇ 0,=C0p a@W-hw_xN& `06 ly` `'-M=[wg$K4kL@VPj{0fmmzts H$eLTIirG1a|\Nbd`@߃YuP)wݹq+ ejs ht}d=+&oV6-iu+kkzW3w9gC^^e^gzy[Wyn*Yv as`x賊E9ZX-绲Y98iضX}LW]^&n-1E!b 3s?]juv?aѝ`^*dxlf_7 z3R|s{7v ~},mDʓ9tթV՗B~fy )\P}m%fS]bEz:gebnXWO1b~秮XcZ~|0o=cZ~l7k=c`Z~L;i0=@@0c@[~T=jPP=@@P .( endstream endobj 2582 0 obj << /Type /ObjStm /N 100 /First 927 /Length 3651 /Filter /FlateDecode >> stream xڕZK ϯ`nJe~SV%qJ\9>p$jYR}4%)fDh4^)Ye!G)g3UL:3yLfk3gLySg4wtx6g9sP`p@?@6@0΀5ʀ)R=|(8I hZRܢC8!: B+uq^iVW0, ^i3Wڕ&*p^Nw0!lbe@460>2, r^ /30T|B喞\f5 O!|*2[FQ!ȝT:q,D>jz Q'y_ P@ ”hA 9%i)@xx'oY'Z@ TG\9<$CN|*2X4xrU(DAsR1x4XkgTP)yTAP;`P&Y`*0~ %4Sh E7G F#flŊn0<9ڀmB٬L{S7}K35Tn b?V} ]5-fCWA*rveLA1(}+sT&ev]N23)WSv3UVWe_WfeZR&ez]OΙ)a='ʬ,L  :Q&% L  I?%'' R$K Sz\/%M p pI7%'& pR$I Szl+%N 0 0I3%'$ R̔$H Szt#%@O I=%@'@% RԔ$@K PSz$JJ@>% _O@$@I ȧJ@bL5@DՄ௒wuMW zב7^ w']Gt%̝ wqvuMV jב6Z g']Gd% vauutMU Zב5V W'X]GT%L uQ@tu4MT Jב4R G']GD% tAsuLS :'~D`s5ضO:'&a@iuLZOa○jL[XgWcקׯ;lP=ʠD]{@7}=Bv"<2N/$-Q~;fs_~ۇw8ZMޑ:=ۧ }=I9_?G x8 }MRUm}s{6C?ɠ_ƝUmp pH.oCնȌl[ HHI$_ =Y8JwSݡS,U74ϡPk%or ew{,R JP):(΋Y]6UT# ))ZbefCs84Sb7OOm}`s~Hy"a׃sPѹ-UrNbs-:uظmS"T.&_Q-xi1 \t&역WC|AB=q<{eXa| O.V^ӝT ϒ_I'6mzTdZfkOmsrv=|k =_o#tf`t,oH¹bZ6W^m</dV.%CTϩ{e эÒQ/If%灬7T.9*2n8@7qP[4aЂ7cW'x Ή4yH؁,cT k*W_d'".+[pjjEyOTs'Z(*><5qGp|u7j^i'&:Emps.}F 'ЯQNn̤hrif \l NxQ,o1x1+qlݱ|G$f3u;rJvǚqy;DIw1-c)2pY'Ʀs3Dz\s5Ԁ)N'^F_m+*F%7/:-kڡqg4N 4&WI炸}) YmU;qP-0g9n1H8Q'-2vd%7%4z]$qkBԊm߷:$h3]Kŕ'rF-1j-fOQ3ͦ&V_ I@h:] <)f6; +4^b^4a7FhX -RbÁucq^{Ru/Kps~+ݷa227;V8/O}3ţlnp5ڻ0\t݌̠f/Z:s0ī6yqRnn+WyٝDfH7`9Q LOtTrON]w!]/zZ6|! z&p_ u%9Lˤ6`F'J i<\a؅&g:͍]Sհy^sd@SmF*\ؔCw&ndMmZV @J« _+E"劯|mqWkM =bRgE&s#4f6EězyЀCx/3w]u5RWz4vQFYvufV$q1cl84,ʵ|Lna康墍aI0 <8 ˁ3'gnCWPglteu%[5.aGCAB?EY~sͺ.j0+<~x]7xxzg䆢sǾA/r㙶[(+(8w s s߃ǪJ㹺<9`[Vs_S{ :ċ~c6^(ؘ=1v̆6qk:7m}?,FTp詵W 3ta_ > stream xڕ\M$ϯȣZf%0&I7tw|CMOnj[}£*k= IH"܁X$,׌񐗺 Vix%ĬxKH˷%SZRXB =YMkIYU1x9(HVA/5'Kl߶E{EbII)kMQ/E 0s28rYlER^+trn(W^5[%.9|Qd(bOi5y)kv[YJLb",xT@Rt]tMYâa9,Z"дhu۲ Һi[j K[ai1ֆlK+jSYͪS^ZkC5ZA6lU8ԬCb-Y' IAY@GU4Ѳ=6ZADCzVb֢bGkMB߾>?ʻo˯߯ib ۫gx=p89i}{m,rw}韇OopcOp.nv!}χ[Ν= yqʫ׷Wdc\΋S(>>~C)τߞnlYj`](Cow^p򫁡ihxbbEڋڍo?ݬ40S m}˚Ө;`SO3ˣj.{t]F/Tqo᪬g×_>|;Ïw"H.elUqZ!N/a[_[koɰho)jGo޻uiRcK"[r p`W%Uo+24jhe>EXS9V/8fߤw w`<.G{tuiRj/1xº ѾSIqCT\kXְ-!i ӊ&^IaIH>„Cͻ]RWʨOPL}o Sj/~o٭оcy:3 . HzXs5gT}N ^]q I-Ya|EIk>gOdc9!u߯rԾ_%`AICP)RbAR 3F) Qu?אB&*,J=U@T 4LĊHe1Vj1@`qz\I1,]5uIK 9C1 յkW!@(}WuH^[* ] }WU$Q[*15c^zmqQ}r58@~6ǽ7['<bO\`+ۈX7bՙ3A۪ۙfͣOcY$P# ތZQ`@@iݤQgd.'*;Ȩ6BT7ۙAV ,,< Jbs9a&lkЉ2&8tY6e '0AgJW%A9k-G}])A+Uy\w@0Jfs7cҗe3iT ̺E$LdOcYQwHxn<: ,] 捗*K(z <H :f\Au;N1VBsu޼`~X0-eNyF8H#ǹ0&ʔM #ͻfa8B eIKp<Ev̅;B`d/I ccΌ!;漢R^]) 'atI L L0px9^ q(SRHTDחB!v4Sb)F1\^ O./vKiDu4߱k7nܳY9./nU[4*[NL+ţ:././mDivQGQe"]^&ڎ./OЉ[]'&~]'ǯ1ҏ6.//g1eԅbԅ弶;x~{6~0 1ge2?A—i?S\*&.R1̈́ELfqA\a&:~׊ĵb^ؖhQG3d:".3jqŝ;_ \cfZ5fED\cfڰpA}b1WD2=eט&L,a%. bqXh%̂xL5f|KFq{$_h!*. InqXd\2=p|5fQpX,. %2961б,pyuXxuXhoA8&}xfRR4:H@+L]-D[ SWv+mL'RQ' d<)T Wy`Mn\**sq'YL"&WJ S3 #HE"RQi/W\*jLYL"2Qr~\a"qȗĵ"rsw]x)ӳHqw%&_ E$.+ݍur;BƳHEk̺rn>bbbM9j/O7i@0DҔFEڒ#)!vhE!RQh8]u :u lV5s =Y?1q%7Z[@q (n yxGIFyC%#,['ʲ9%Sϡ ?pinFh҆w> endobj 2733 0 obj << /Type /ObjStm /N 19 /First 178 /Length 612 /Filter /FlateDecode >> stream xڍOo0 :&%JEQ`Xov;=WH q< ㏔%VV'+&*"G5¡h|" Xl2klRU.'cPNMX}QԐ^`K~IԖ9yZ<d˪z<_ܘ,!@"yY(<݂U& BDtzms@=A$4x"BAhu^νV BTE9&lJFԈz޸EEEDSIG7.gu@@@Մzp6d BCL 'q9K  !޸Vʡ!rG7t@h)Is Ah(Nۇrfߛe^Ј g(ߡMz_\jwt(ȡ z}U 0tTب f4usȁ72o?r}eA K^m%ꖾ.o獻fX)Ph endstream endobj 2753 0 obj << /Type /XRef /Index [0 2754] /Size 2754 /W [1 3 1] /Root 2751 0 R /Info 2752 0 R /ID [ ] /Length 6297 /Filter /FlateDecode >> stream x%i$~>sfϙ}vf}W|PmF! e#FL'ZB_\ [=JL ~}}ޟ_~Vvn%ɞvkcj Ψ82#'aCv==vs2;xࣶ5÷"ϒ4Z ĥI{ͅ90[$xsxW%"NZ.0E.;15ּɷM@lz^nUm͠'8^ߴn޴̴^Хoq ܦÁuc͇,5}NB}XKp57 [mwq!IX#x O)<ľˤoހ{`;xs[OI+X. ݉?LZ?b1R"]_X_I@w 䠻\Kc8Ѯt Ӎ4n\%etb@q tFvpdW? ;/aJ,=b0t C KZzE"ѕDtρ\u/t{]λW֯UFW6ѕ_Ӯt%n'_^|B60t1~FLruωҨ577c%jL77.7ma$>F|C|C|C|# 004667oދh MϢ-߆Ya훱>烆&oJ&~g8^h 8}sh9bшE# 048 4L7L7L7L7L7L7b84R84/ ѡjb/j^ŤF#l48Q4ҼFJ^sЯ葶./4O}mBUo0㿋`1,%հ:`3l}{aC N! \Zp! # ' ./G/\>gE[`C6#fX㙽^겷\p H&܂ n >ϱ1D7)<}9it< $+t={{H!Ctˉb^ $26M"0 E`(˖0`1*ff.̃¢$yy)޲`,VjXaI~|v-6 `;쀝 vQؔ$[0  p 8 4陳y!F颉s.kp7 FnBep 'OB]g Oh~\\N_}cEm 'Om,O?o!Or>}B7fGj>}zl7'U'}.\?Ygj~\$gj>}VD߈k gj>؏j?OǨS IK?O R^`Ԡc$pt 3~'$N!Yq!C}꿂$I~a/MOVet*%?>$/}Z J ~/`uZX$`dj5ܜ P6ú$6wlIGrʑ #poyNI03u '?XY8 pfg0nQ H&܂ ]}bD=u1bI;<@kdEGH$+N ~ډ!oKI{ֲ/eI_~>cx[:LwbwqXt!Ƨ?x+CmG:X&0R>aLgkk`;4vDs0؉UM?l u0ac$zDc׉fVg&I~X5jM>qXasut$j;vK;9J;/'1lehG%%%e<Lř .˘tKBK9(5ݒڒR[- -chВВR,rv^x6\Jm9]5VFs,#2J-ԒK-ԒK'RJ(ER^ʣ 0P C9"P}P C) BS_j%%厤vlPް3a "P@)]jݥ]@)"PJIP C) 0RJ['ۂͤ[QXxNY0 a^35#SL# # #$gYk_WK 沦 fC[mIg7ɦv.8ے=4p[I;I8Sp7py![@DNGR ';y|}x<'^Kx -=Kڏx |ũ$X@/>#7| Xq70M#GhtG'Ʊ~<ʤSO1I/fyI/$ q=~{LX; QۣGm=j{w ňޤyOzݣGwݽ;Qb`. \G1L/=IDO"z^K۱A@Tz^DE,z@6zB7̛0\01oC[ K`%,Lڿ0`9ԫհ:Xq`/L ?_Kby'8{?;0]I7N91tn//Ǯ57 &܆;p}x/!K^< x o-cj>WI<0tt14}?+ܤ `!paW9999999ӹiʜ˜МММܭ9A\6-@6rșΩͩͩͩͩE ?Cp HIIII;;2333333E99999繹ٜ1НӝӝӝӝF ωωωωωC|V%+++JDJ* ?6SI}+*!"""""""""""""""""""""""""""""""""""""""""""""""""""""[@&`LlsȧbXKa rX+a5zal-v;a=~pa8GpNi8Y8\ \kpn@ 7dp] 2), "`x` (`x = 1 & y > 2`) must not be named, do you need `==`?", fixed = TRUE ) }) test_that("filter handles passing ...", { df <- data.frame(x = 1:4) f <- function(...) { x1 <- 4 f1 <- function(y) y filter(df, ..., f1(x1) > x) } g <- function(...) { x2 <- 2 f(x > x2, ...) } res <- g() expect_equal(res$x, 3L) df <- group_by(df, x) res <- g() expect_equal(res$x, 3L) }) test_that("filter handles simple symbols", { df <- data.frame(x = 1:4, test = rep(c(T, F), each = 2)) res <- filter(df, test) gdf <- group_by(df, x) res <- filter(gdf, test) h <- function(data) { test2 <- c(T, T, F, F) filter(data, test2) } expect_equal(h(df), df[1:2, ]) f <- function(data, ...) { one <- 1 filter(data, test, x > one, ...) } g <- function(data, ...) { four <- 4 f(data, x < four, ...) } res <- g(df) expect_equal(res$x, 2L) expect_equal(res$test, TRUE) res <- g(gdf) expect_equal(res$x, 2L) expect_equal(res$test, TRUE) }) test_that("filter handlers scalar results", { expect_equivalent(filter(mtcars, min(mpg) > 0), mtcars) expect_equal(filter(group_by(mtcars, cyl), min(mpg) > 0), group_by(mtcars, cyl)) }) test_that("filter propagates attributes", { date.start <- ISOdate(2010, 01, 01, 0) test <- data.frame(Date = ISOdate(2010, 01, 01, 1:10)) test2 <- test %>% filter(Date < ISOdate(2010, 01, 01, 5)) expect_equal(test$Date[1:4], test2$Date) }) test_that("filter fails on integer indices", { expect_error( filter(mtcars, 1:2), "Argument 2 filter condition does not evaluate to a logical vector", fixed = TRUE ) expect_error( filter(group_by(mtcars, cyl), 1:2), "Argument 2 filter condition does not evaluate to a logical vector", fixed = TRUE ) }) test_that("filter discards NA", { temp <- data.frame( i = 1:5, x = c(NA, 1L, 1L, 0L, 0L) ) res <- filter(temp, x == 1) expect_equal(nrow(res), 2L) }) test_that("date class remains on filter (#273)", { x1 <- x2 <- data.frame( date = seq.Date(as.Date("2013-01-01"), by = "1 days", length.out = 2), var = c(5, 8) ) x1.filter <- x1 %>% filter(as.Date(date) > as.Date("2013-01-01")) x2$date <- x2$date + 1 x2.filter <- x2 %>% filter(as.Date(date) > as.Date("2013-01-01")) expect_equal(class(x1.filter$date), "Date") expect_equal(class(x2.filter$date), "Date") }) test_that("filter handles $ correctly (#278)", { d1 <- tbl_df(data.frame( num1 = as.character(sample(1:10, 1000, T)), var1 = runif(1000), stringsAsFactors = FALSE )) d2 <- data.frame(num1 = as.character(1:3), stringsAsFactors = FALSE) res1 <- d1 %>% filter(num1 %in% c("1", "2", "3")) res2 <- d1 %>% filter(num1 %in% d2$num1) expect_equal(res1, res2) }) test_that("filter returns the input data if no parameters are given", { expect_equivalent(filter(mtcars), mtcars) }) test_that("$ does not end call traversing. #502", { # Suppose some analysis options are set much earlier in the script analysis_opts <- list(min_outcome = 0.25) # Generate some dummy data d <- expand.grid(Subject = 1:3, TrialNo = 1:2, Time = 1:3) %>% tbl_df() %>% arrange(Subject, TrialNo, Time) %>% mutate(Outcome = (1:18 %% c(5, 7, 11)) / 10) # Do some aggregation trial_outcomes <- d %>% group_by(Subject, TrialNo) %>% summarise(MeanOutcome = mean(Outcome)) left <- filter(trial_outcomes, MeanOutcome < analysis_opts$min_outcome) right <- filter(trial_outcomes, analysis_opts$min_outcome > MeanOutcome) expect_equal(left, right) }) test_that("filter uses the allow list (#566)", { datesDF <- read.csv(stringsAsFactors = FALSE, text = " X 2014-03-13 16:08:19 2014-03-13 16:16:23 2014-03-13 16:28:28 2014-03-13 16:28:54 ") datesDF$X <- as.POSIXlt(datesDF$X) # error message from tibble expect_error(filter(datesDF, X > as.POSIXlt("2014-03-13"))) }) test_that("filter handles complex vectors (#436)", { d <- data.frame(x = 1:10, y = 1:10 + 2i) expect_equal(filter(d, x < 4)$y, 1:3 + 2i) expect_equal(filter(d, Re(y) < 4)$y, 1:3 + 2i) }) test_that("%in% works as expected (#126)", { df <- tibble(a = c("a", "b", "ab"), g = c(1, 1, 2)) res <- df %>% filter(a %in% letters) expect_equal(nrow(res), 2L) res <- df %>% group_by(g) %>% filter(a %in% letters) expect_equal(nrow(res), 2L) }) test_that("row_number does not segfault with example from #781", { z <- data.frame(a = c(1, 2, 3)) b <- "a" res <- z %>% filter(row_number(b) == 2) expect_equal(nrow(res), 0L) }) test_that("row_number works on 0 length columns (#3454)", { expect_identical( mutate(tibble(), a = row_number()), tibble(a = integer()) ) }) test_that("filter does not alter expression (#971)", { my_filter <- ~ am == 1 expect_equal(my_filter[[2]][[2]], as.name("am")) }) test_that("hybrid evaluation handles $ correctly (#1134)", { df <- tibble(x = 1:10, g = rep(1:5, 2)) res <- df %>% group_by(g) %>% filter(x > min(df$x)) expect_equal(nrow(res), 9L) }) test_that("filter correctly handles empty data frames (#782)", { res <- tibble() %>% filter(F) expect_equal(nrow(res), 0L) expect_equal(length(names(res)), 0L) }) test_that("filter(.,TRUE,TRUE) works (#1210)", { df <- data.frame(x = 1:5) res <- filter(df, TRUE, TRUE) expect_equal(res, df) }) test_that("filter, slice and arrange preserves attributes (#1064)", { df <- structure( data.frame(x = 1:10, g1 = rep(1:2, each = 5), g2 = rep(1:5, 2)), meta = "this is important" ) res <- filter(df, x < 5) %>% attr("meta") expect_equal(res, "this is important") res <- filter(df, x < 5, x > 4) %>% attr("meta") expect_equal(res, "this is important") res <- df %>% slice(1:50) %>% attr("meta") expect_equal(res, "this is important") res <- df %>% arrange(x) %>% attr("meta") expect_equal(res, "this is important") res <- df %>% summarise(n()) %>% attr("meta") expect_equal(res, "this is important") res <- df %>% group_by(g1) %>% summarise(n()) %>% attr("meta") expect_equal(res, "this is important") res <- df %>% group_by(g1, g2) %>% summarise(n()) %>% attr("meta") expect_equal(res, "this is important") }) test_that("filter works with rowwise data (#1099)", { df <- tibble(First = c("string1", "string2"), Second = c("Sentence with string1", "something")) res <- df %>% rowwise() %>% filter(grepl(First, Second, fixed = TRUE)) expect_equal(nrow(res), 1L) expect_equal(df[1, ], res) }) test_that("grouped filter handles indices (#880)", { res <- iris %>% group_by(Species) %>% filter(Sepal.Length > 5) res2 <- mutate(res, Petal = Petal.Width * Petal.Length) expect_equal(nrow(res), nrow(res2)) expect_identical(group_data(res), group_data(res2)) }) test_that("filter(FALSE) handles indices", { out <- mtcars %>% group_by(cyl) %>% filter(FALSE, .preserve = TRUE) %>% group_rows() expect_identical(out, list(integer(), integer(), integer())) out <- mtcars %>% group_by(cyl) %>% filter(FALSE, .preserve = FALSE) %>% group_rows() expect_identical(out, list()) }) test_that("filter handles S4 objects (#1366)", { env <- environment() Numbers <- suppressWarnings(setClass( "Numbers", slots = c(foo = "numeric"), contains = "integer", where = env )) setMethod("[", "Numbers", function(x, i, ...){ Numbers(unclass(x)[i, ...], foo = x@foo) }) on.exit(removeClass("Numbers", where = env)) df <- data.frame(x = Numbers(1:10, foo = 10)) res <- filter(df, x > 3) expect_true(isS4(res$x)) expect_is(res$x, "Numbers") expect_equal(res$x@foo, 10) }) test_that("hybrid lag and default value for string columns work (#1403)", { res <- mtcars %>% mutate(xx = LETTERS[gear]) %>% filter(xx == lag(xx, default = "foo")) xx <- LETTERS[mtcars$gear] ok <- xx == lag(xx, default = "foo") expect_equal(xx[ok], res$xx) res <- mtcars %>% mutate(xx = LETTERS[gear]) %>% filter(xx == lead(xx, default = "foo")) xx <- LETTERS[mtcars$gear] ok <- xx == lead(xx, default = "foo") expect_equal(xx[ok], res$xx) }) # .data and .env tests now in test-hybrid-traverse.R test_that("filter handles raw vectors (#1803)", { df <- tibble(a = 1:3, b = as.raw(1:3)) expect_identical(filter(df, a == 1), tibble(a = 1L, b = as.raw(1))) expect_identical(filter(df, b == 1), tibble(a = 1L, b = as.raw(1))) }) test_that("`vars` attribute is not added if empty (#2772)", { expect_identical(tibble(x = 1:2) %>% filter(x == 1), tibble(x = 1L)) }) test_that("filter handles list columns", { res <- tibble(a=1:2, x = list(1:10, 1:5)) %>% filter(a == 1) %>% pull(x) expect_equal(res, list(1:10)) res <- tibble(a=1:2, x = list(1:10, 1:5)) %>% group_by(a) %>% filter(a == 1) %>% pull(x) expect_equal(res, list(1:10)) }) test_that("hybrid function row_number does not trigger warning in filter (#3750)", { out <- tryCatch({ mtcars %>% filter(row_number() > 1, row_number() < 5); TRUE }, warning = function(w) FALSE ) expect_true(out) }) test_that("filter() preserve order accross groups (#3989)", { tb <- tibble(g = c(1, 2, 1, 2, 1), time = 5:1, x = 5:1) res1 <- tb %>% group_by(g) %>% filter(x <= 4) %>% arrange(time) res2 <- tb %>% group_by(g) %>% arrange(time) %>% filter(x <= 4) res3 <- tb %>% filter(x <= 4) %>% arrange(time) %>% group_by(g) expect_equal(res1, res2) expect_equal(res1, res3) expect_false(is.unsorted(res1$time)) expect_false(is.unsorted(res2$time)) expect_false(is.unsorted(res3$time)) }) test_that("filter() with two conditions does not freeze (#4049)", { expect_identical( iris %>% filter(Sepal.Length > 7, Petal.Length < 6), iris %>% filter(Sepal.Length > 7 & Petal.Length < 6) ) }) dplyr/tests/testthat/test-underscore.R0000644000176200001440000001613113614573562017675 0ustar liggesuserscontext("underscore") df <- tibble( a = c(1:3, 2:3), b = letters[c(1:4, 4L)] ) test_that("arrange_ works", { scoped_lifecycle_silence() expect_equal( arrange_(df, ~ -a), arrange(df, -a) ) expect_equal( arrange_(df, .dots = list(quote(-a))), arrange(df, -a) ) expect_equal( arrange_(df, .dots = list(~ -a)), arrange(df, -a) ) }) test_that("count_ works", { scoped_lifecycle_silence() expect_equal( count_(df, ~ b), count(df, b) ) expect_equal( count_(df, ~ b, wt = quote(a)), count(df, b, wt = a) ) wt <- 1:4 expect_identical( count_(df, "b", "wt"), count(df, b, wt = wt) ) expect_identical( add_count(df, b), add_count_(df, ~ b) ) }) test_that("distinct_ works", { scoped_lifecycle_silence() expect_equal( distinct_(df, ~ a), distinct(df, a) ) expect_equal( distinct_(df, .dots = list(quote(a))), distinct(df, a) ) expect_equal( distinct_(df, .dots = list(~ a)), distinct(df, a) ) expect_equal( distinct_(df %>% group_by(b), ~ a, .dots = NULL), distinct(df %>% group_by(b), a) ) expect_equal( distinct_(df %>% group_by(b), .dots = list(quote(a))), distinct(df %>% group_by(b), a) ) expect_equal( distinct_(df %>% group_by(b), .dots = list(~ a)), distinct(df %>% group_by(b), a) ) }) test_that("do_ works", { scoped_lifecycle_silence() expect_equal( do_(df, ~ tibble(-.$a)), do(df, tibble(-.$a)) ) expect_equal( do_(df, .dots = list(quote(dplyr::tibble(-.$a)))), do(df, tibble(-.$a)) ) expect_equal( do_(df, .dots = list(~ dplyr::tibble(-.$a))), do(df, tibble(-.$a)) ) foo <- "foobar" expect_identical( do_(df, .dots = "tibble(foo)"), do(df, tibble(foo)) ) expect_equal( do_(df %>% group_by(b), ~ tibble(-.$a)), do(df %>% group_by(b), tibble(-.$a)) ) expect_equal( do_(df %>% group_by(b), .dots = list(quote(dplyr::tibble(-.$a)))), do(df %>% group_by(b), tibble(-.$a)) ) expect_equal( do_(df %>% group_by(b), .dots = list(~ dplyr::tibble(-.$a))), do(df %>% group_by(b), tibble(-.$a)) ) }) test_that("filter_ works", { scoped_lifecycle_silence() expect_equal( filter_(df, ~ a > 1), filter(df, a > 1) ) expect_equal( filter_(df, .dots = list(quote(a > 1))), filter(df, a > 1) ) cnd <- rep(TRUE, 5) expect_identical( filter_(df, .dots = "cnd"), filter(df, cnd) ) }) test_that("group_by_ works", { scoped_lifecycle_silence() expect_equal( group_by_(df, ~ a), group_by(df, a) ) expect_equal( group_by_(df, ~ -a), group_by(df, -a) ) expect_equal( group_by_(df, .dots = "a"), group_by(df, a) ) expect_equal( group_by_(df, .dots = list(quote(-a))), group_by(df, -a) ) expect_equal( group_by_(df, .dots = list(~ -a)), group_by(df, -a) ) expect_warning( expect_equal( group_by_(df %>% rowwise(), ~ a), group_by(df %>% rowwise(), a) ), "rowwise" ) expect_warning( expect_equal( group_by_(df %>% rowwise(), ~ -a), group_by(df %>% rowwise(), -a) ), "rowwise" ) expect_warning( expect_equal( group_by_(df %>% rowwise(), .dots = "a"), group_by(df %>% rowwise(), a) ), "rowwise" ) expect_warning( expect_equal( group_by_(df %>% rowwise(), .dots = list(quote(-a))), group_by(df %>% rowwise(), -a) ), "rowwise" ) expect_warning( expect_equal( group_by_(df %>% rowwise(), .dots = list(~ -a)), group_by(df %>% rowwise(), -a) ), "rowwise" ) }) test_that("mutate_ works", { scoped_lifecycle_silence() expect_equal( mutate_(df, c = ~ -a), mutate(df, c = -a) ) expect_equal( mutate_(df, .dots = list(c = quote(-a))), mutate(df, c = -a) ) expect_equal( mutate_(df, .dots = list(c = ~ -a)), mutate(df, c = -a) ) expect_identical( mutate_(df, ~ -a), mutate(df, -a) ) foo <- "foobar" expect_identical( mutate_(df, .dots = "foo"), mutate(df, foo) ) }) test_that("rename_ works", { scoped_lifecycle_silence() expect_equal( rename_(df, c = ~ a), rename(df, c = a) ) expect_equal( rename_(df, .dots = list(c = quote(a))), rename(df, c = a) ) expect_equal( rename_(df, .dots = list(c = ~ a)), rename(df, c = a) ) }) test_that("select_ works", { scoped_lifecycle_silence() expect_equal( select_(df, ~ a), select(df, a) ) expect_equal( select_(df, ~ -a), select(df, -a) ) expect_equal( select_(df, .dots = "a"), select(df, a) ) expect_equal( select_(df, .dots = list(quote(-a))), select(df, -a) ) expect_equal( select_(df, .dots = list(~ -a)), select(df, -a) ) pos <- 1 expect_identical( select_(df, c = "pos"), select(df, c = pos) ) }) test_that("slice_ works", { scoped_lifecycle_silence() expect_equal( slice_(df, ~ 2:n()), slice(df, 2:n()) ) expect_equal( slice_(df, .dots = list(quote(2:n()))), slice(df, 2:n()) ) expect_equal( slice_(df, .dots = list(~ 2:n())), slice(df, 2:n()) ) pos <- 3 expect_identical( slice_(df, .dots = "pos:n()"), slice(df, pos:n()) ) }) test_that("summarise_ works", { scoped_lifecycle_silence() expect_equal( summarise_(df, ~ mean(a)), summarise(df, mean(a)) ) expect_equal( summarise_(df, .dots = list(quote(mean(a)))), summarise(df, mean(a)) ) expect_equal( summarise_(df, .dots = list(~ mean(a))), summarise(df, mean(a)) ) my_mean <- mean expect_identical( summarise_(df, .dots = "my_mean(a)"), summarise(df, my_mean(a)) ) expect_equal( summarise_(df %>% group_by(b), ~ mean(a)), summarise(df %>% group_by(b), mean(a)) ) expect_equal( summarise_(df %>% group_by(b), .dots = list(quote(mean(a)))), summarise(df %>% group_by(b), mean(a)) ) expect_equal( summarise_(df %>% group_by(b), .dots = list(~ mean(a))), summarise(df %>% group_by(b), mean(a)) ) }) test_that("summarize_ works", { scoped_lifecycle_silence() expect_equal( summarize_(df, ~ mean(a)), summarize(df, mean(a)) ) expect_equal( summarize_(df, .dots = list(quote(mean(a)))), summarize(df, mean(a)) ) expect_equal( summarize_(df, .dots = list(~ mean(a))), summarize(df, mean(a)) ) expect_equal( summarize_(df %>% group_by(b), ~ mean(a)), summarize(df %>% group_by(b), mean(a)) ) expect_equal( summarize_(df %>% group_by(b), .dots = list(quote(mean(a)))), summarize(df %>% group_by(b), mean(a)) ) expect_equal( summarize_(df %>% group_by(b), .dots = list(~ mean(a))), summarize(df %>% group_by(b), mean(a)) ) }) test_that("transmute_ works", { scoped_lifecycle_silence() expect_equal( transmute_(df, c = ~ -a), transmute(df, c = -a) ) expect_equal( transmute_(df, .dots = list(c = quote(-a))), transmute(df, c = -a) ) expect_equal( transmute_(df, .dots = list(c = ~ -a)), transmute(df, c = -a) ) foo <- "foobar" expect_identical( transmute_(df, .dots = "foo"), transmute(df, foo) ) }) dplyr/tests/testthat/test-window.R0000644000176200001440000000475713614573562017046 0ustar liggesuserscontext("Window functions") test_that("If n = 0, lead and lag return x", { expect_equal(lead(1:2, 0), 1:2) expect_equal(lag(1:2, 0), 1:2) }) test_that("If n = length(x), returns all missing", { miss <- rep(NA_integer_, 2) expect_equal(lead(1:2, 2), miss) expect_equal(lag(1:2, 2), miss) }) test_that("cumany and cumall handle NAs consistently (#408, #3749, #4132)", { batman <- c(NA, NA, NA, NA, NA) expect_true(all(is.na(cumany(batman)))) expect_true(all(is.na(cumall(batman)))) # normal usecases expect_identical( cumall(c(TRUE, NA, FALSE, NA)), c(TRUE, NA, FALSE, FALSE) ) expect_identical( cumall(c(FALSE, NA, TRUE)), c(FALSE, FALSE, FALSE) ) expect_identical( cumall(c(NA, TRUE)), c(NA, NA) ) expect_identical( cumall(c(NA, FALSE)), c(NA, FALSE) ) expect_identical( cumany(c(TRUE, NA, FALSE)), c(TRUE, TRUE, TRUE) ) expect_identical( cumany(c(FALSE, NA, TRUE)), c(FALSE, NA, TRUE) ) # scalars expect_true(is.na(cumall(NA))) expect_true(is.na(cumany(NA))) expect_true(cumall(TRUE)) expect_false(cumall(FALSE)) expect_true(cumany(TRUE)) expect_false(cumany(FALSE)) # degenerate cases expect_identical( cumall(logical()), logical() ) expect_identical( cumany(logical()), logical() ) # behaviour of degenerate logical vectors mimics that of base R functions x <- as.raw(c(2L, 9L, 0L)) class(x) <- "logical" expect_identical(cumall(x), x == TRUE) expect_identical(cumany(x), c(TRUE, TRUE, TRUE)) }) test_that("percent_rank ignores NAs (#1132)", { expect_equal(percent_rank(c(1:3, NA)), c(0, 0.5, 1, NA)) }) test_that("cume_dist ignores NAs (#1132)", { expect_equal(cume_dist(c(1:3, NA)), c(1 / 3, 2 / 3, 1, NA)) }) test_that("cummean is not confused by FP error (#1387)", { a <- rep(99, 9) expect_true(all(cummean(a) == a)) }) test_that("order_by() returns correct value", { expected <- int(15, 14, 12, 9, 5) expect_identical(order_by(5:1, cumsum(1:5)), expected) x <- 5:1 y <- 1:5 expect_identical(order_by(x, cumsum(y)), expected) }) test_that("order_by() works in arbitrary envs (#2297)", { env <- child_env("base") expect_equal( with_env(env, dplyr::order_by(5:1, cumsum(1:5))), rev(cumsum(rev(1:5))) ) expect_equal( order_by(5:1, cumsum(1:5)), rev(cumsum(rev(1:5))) ) }) test_that("order_by() fails when not supplied a call (#3065)", { expect_error(order_by(NULL, !!1L), "`call` must be a function call, not an integer vector") }) dplyr/tests/testthat/test-colwise-distinct.R0000644000176200001440000000170713451046652021005 0ustar liggesuserscontext("colwise distinct") test_that("scoped distinct is identical to manual distinct", { df <- tibble( x = rep(2:5, each=2), y = rep(2:3, each = 4), z = "a" ) expect_identical(distinct_all(df), distinct(df, x, y, z)) expect_identical(distinct_at(df, vars(x)), distinct(df, x)) expect_identical(distinct_if(df, is.integer), distinct(df, x, y)) }) test_that(".funs is applied to variables before getting distinct rows", { df <- tibble( x = rep(2:5, each=2), y = rep(2:3, each = 4) ) expect_identical(distinct_all(df, `-`), distinct(mutate_all(df,`-`), x, y)) }) test_that("scoped distinct applies to grouping variables (#3480)", { df <- tibble( g = rep(1:2, each = 4), x = rep(2:5, each = 2) / 2, y = rep(2:3, each = 4) / 2 ) out <- df[c(1, 3, 5, 8), ] expect_identical(distinct_all(df), out) expect_identical(distinct_at(df, vars(g, x, y)), out) expect_identical(distinct_if(df, is.numeric), out) }) dplyr/tests/testthat/test-n_distinct.R0000644000176200001440000000406013614573562017660 0ustar liggesuserscontext("n_distinct") test_that("n_distinct gives the correct results on iris", { expect_equal( sapply(iris, n_distinct), sapply(iris, function(.) length(unique(.))) ) }) df_var <- data.frame( l = c(T, F, F), i = c(1, 1, 2), d = Sys.Date() + c(1, 1, 2), f = factor(letters[c(1, 1, 2)]), n = c(1, 1, 2) + 0.5, t = Sys.time() + c(1, 1, 2), c = letters[c(1, 1, 2)], stringsAsFactors = FALSE ) test_that("n_distinct gives correct results for key types", { expect_equal( sapply(df_var, n_distinct), sapply(df_var, function(.) length(unique(.))) ) }) test_that("n_distinct treats NA correctly in the REALSXP case (#384)", { expect_equal(n_distinct(c(1.0, NA, NA)), 2) }) test_that("n_distinct recycles length 1 vectors (#3685)", { expect_equal(n_distinct(1, 1:4), 4) expect_equal(n_distinct(1:4, 1), 4) expect_error(n_distinct(1:2, 1:3)) d <- tibble(x = 1:4) res <- d %>% summarise(y = sum(x), n1 = n_distinct(y, x), n2 = n_distinct(x, y), n3 = n_distinct(y), n4 = n_distinct(identity(y)), n5 = n_distinct(x)) expect_equal(res$n1, 4) expect_equal(res$n2, 4) expect_equal(res$n3, 1) expect_equal(res$n4, 1) expect_equal(res$n5, 4) res <- tibble(g = c(1,1,1,1,2,2), x = c(1,2,3,1,1,2)) %>% group_by(g) %>% summarise(y = sum(x), n1 = n_distinct(y, x), n2 = n_distinct(x, y), n3 = n_distinct(y), n4 = n_distinct(identity(y)), n5 = n_distinct(x)) expect_equal(res$n1, c(3,2)) expect_equal(res$n2, c(3,2)) expect_equal(res$n3, c(1,1)) expect_equal(res$n4, c(1,1)) expect_equal(res$n5, c(3,2)) }) test_that("n_distinct handles expressions in na.rm (#3686)", { d <- tibble(x = c(1:4,NA)) yes <- TRUE no <- FALSE expect_equal(d %>% summarise(n = n_distinct(x, na.rm = T)) %>% pull(), 4) expect_equal(d %>% summarise(n = n_distinct(x, na.rm = F)) %>% pull(), 5) expect_equal(d %>% summarise(n = n_distinct(x, na.rm = yes)) %>% pull(), 4) expect_equal(d %>% summarise(n = n_distinct(x, na.rm = no)) %>% pull(), 5) expect_equal(d %>% summarise(n = n_distinct(x, na.rm = TRUE || TRUE)) %>% pull(), 4) }) dplyr/tests/testthat/utf-8.txt0000644000176200001440000000157213614573562016133 0ustar liggesusers# UTF-8 tests that can't be run on Windows CRAN # R CMD check will try to parse the file anyway, # we use a different file extension to avoid this. df <- data.frame(中文1 = 1:10, 中文2 = 1:10, eng = 1:10) df2 <- df %>% mutate(中文1 = 中文1 + 1) gdf2 <- df %>% group_by(eng) %>% mutate(中文1 = 中文1 + 1) expect_equal(strings_addresses(names(df)), strings_addresses(names(df2))) expect_equal(strings_addresses(names(df)), strings_addresses(names(gdf2))) df3 <- filter(df2, eng > 5) gdf3 <- filter(gdf2, eng > 5) expect_equal(strings_addresses(names(df)), strings_addresses(names(df3))) expect_equal(strings_addresses(names(df)), strings_addresses(names(gdf3))) df4 <- filter(df2, 中文1 > 5) gdf4 <- filter(gdf2, 中文1 > 5) expect_equal(strings_addresses(names(df)), strings_addresses(names(df4))) expect_equal(strings_addresses(names(df)), strings_addresses(names(gdf4))) dplyr/tests/testthat/test-near.R0000644000176200001440000000014313451046652016437 0ustar liggesuserscontext("near") test_that("near accepts nearby fp values", { expect_true(near(sqrt(2)^2, 2)) }) dplyr/tests/testthat/test-coalesce.R0000644000176200001440000000074613614573562017307 0ustar liggesuserscontext("coalesce") test_that("non-missing scalar replaces all missing values", { x <- c(NA, 1) expect_equal(coalesce(x, 1), c(1, 1)) }) test_that("finds non-missing values in multiple positions", { x1 <- c(1L, NA, NA) x2 <- c(NA, 2L, NA) x3 <- c(NA, NA, 3L) expect_equal(coalesce(x1, x2, x3), 1:3) }) test_that("error if invalid length", { expect_error( coalesce(1:2, 1:3), "Argument 2 must be length 2 (length of `x`) or one, not 3", fixed = TRUE ) }) dplyr/tests/testthat/test-nth-value.R0000644000176200001440000000177413567743067017444 0ustar liggesuserscontext("Nth value") test_that("nth works with lists", { x <- list(1, 2, 3) expect_equal(nth(x, 1), 1) expect_equal(nth(x, 4), NULL) expect_equal(nth(x, 4, default = 1), 1) }) test_that("negative values index from end", { x <- 1:5 expect_equal(nth(x, -1), 5) expect_equal(nth(x, -3), 3) }) test_that("indexing past ends returns default value", { expect_equal(nth(1:4, 5), NA_integer_) expect_equal(nth(1:4, -5), NA_integer_) expect_equal(nth(1:4, -10), NA_integer_) }) test_that("first uses default value for 0 length vectors", { expect_equal(first(logical()), NA) expect_equal(first(integer()), NA_integer_) expect_equal(first(numeric()), NA_real_) expect_equal(first(character()), NA_character_) expect_equal(first(list()), NULL) }) test_that("firsts uses default value for 0 length augmented vectors", { fc <- factor("a")[0] dt <- Sys.Date() tm <- Sys.time() expect_equal(first(fc[0]), fc[NA]) expect_equal(first(dt[0]), dt[NA]) expect_equal(first(tm[0]), tm[NA]) }) dplyr/tests/testthat/test-pull.R0000644000176200001440000000064613614573562016504 0ustar liggesuserscontext("pull") test_that("default extracts last var from data frame", { df <- tibble(x = 1:10, y = 1:10) expect_equal(pull(df), 1:10) }) test_that("can extract by name, or positive/negative position", { x <- 1:10 df <- tibble(x = x, y = runif(10)) expect_equal(pull(df, x), x) expect_equal(pull(df, 1L), x) expect_equal(pull(df, 1), x) expect_equal(pull(df, -2), x) expect_equal(pull(df, -2L), x) }) dplyr/tests/testthat/test-sets.R0000644000176200001440000001001713614573562016477 0ustar liggesuserscontext("Set ops") test_that("set operation give useful error message. #903", { alfa <- tibble( land = c("Sverige", "Norway", "Danmark", "Island", "GB"), data = rnorm(length(land)) ) beta <- tibble( land = c("Norge", "Danmark", "Island", "Storbritannien"), data2 = rnorm(length(land)) ) expect_error( intersect(alfa, beta), "not compatible: \n- Cols in y but not x: `data2`. \n- Cols in x but not y: `data`. \n", fixed = TRUE ) expect_error( union(alfa, beta), "not compatible: \n- Cols in y but not x: `data2`. \n- Cols in x but not y: `data`. \n", fixed = TRUE ) expect_error( setdiff(alfa, beta), "not compatible: \n- Cols in y but not x: `data2`. \n- Cols in x but not y: `data`. \n", fixed = TRUE ) }) test_that("set operations use coercion rules (#799)", { df1 <- tibble(x = 1:2, y = c(1, 1)) df2 <- tibble(x = 1:2, y = 1:2) expect_equal(nrow(union(df1, df2)), 3L) expect_equal(nrow(intersect(df1, df2)), 1L) expect_equal(nrow(setdiff(df1, df2)), 1L) df1 <- tibble(x = factor(letters[1:10])) df2 <- tibble(x = letters[6:15]) expect_warning(res <- intersect(df1, df2)) expect_equal(res, tibble(x = letters[6:10])) expect_warning(res <- intersect(df2, df1)) expect_equal(res, tibble(x = letters[6:10])) expect_warning(res <- union(df1, df2)) expect_equal(res, tibble(x = letters[1:15])) expect_warning(res <- union(df2, df1)) expect_equal(res, tibble(x = letters[1:15])) expect_warning(res <- setdiff(df1, df2)) expect_equal(res, tibble(x = letters[1:5])) expect_warning(res <- setdiff(df2, df1)) expect_equal(res, tibble(x = letters[11:15])) }) test_that("setdiff handles factors with NA (#1526)", { df1 <- tibble(x = factor(c(NA, "a"))) df2 <- tibble(x = factor("a")) res <- setdiff(df1, df2) expect_is(res$x, "factor") expect_equal(levels(res$x), "a") expect_true(is.na(res$x[1])) }) test_that("intersect does not unnecessarily coerce (#1722)", { df <- tibble(a = 1L) res <- intersect(df, df) expect_is(res$a, "integer") }) test_that("set operations reconstruct grouping metadata (#3587)", { df1 <- tibble(x = 1:4, g = rep(1:2, each = 2)) %>% group_by(g) df2 <- tibble(x = 3:6, g = rep(2:3, each = 2)) expect_equal(setdiff(df1, df2), filter(df1, x < 3)) expect_equal(intersect(df1, df2), filter(df1, x >= 3)) expect_equal(union(df1, df2), tibble(x = 1:6, g = rep(1:3, each = 2)) %>% group_by(g)) expect_equal(setdiff(df1, df2) %>% group_rows(), list(1:2)) expect_equal(intersect(df1, df2) %>% group_rows(), list(1:2)) expect_equal(union(df1, df2) %>% group_rows(), list(1:2, 3:4, 5:6)) }) test_that("set operations keep the ordering of the data (#3839)", { rev_df <- function(df) { df[rev(seq_len(nrow(df))), ] } df1 <- tibble(x = 1:4, g = rep(1:2, each = 2)) df2 <- tibble(x = 3:6, g = rep(2:3, each = 2)) expect_identical(setdiff(df1, df2), filter(df1, x < 3)) expect_identical(setdiff(rev_df(df1), df2), filter(rev_df(df1), x < 3)) expect_identical(intersect(df1, df2), filter(df1, x >= 3)) expect_identical(intersect(rev_df(df1), df2), filter(rev_df(df1), x >= 3)) expect_identical(union(df1, df2), tibble(x = 1:6, g = rep(1:3, each = 2))) expect_identical(union(rev_df(df1), df2), tibble(x = c(4:1, 5:6), g = rep(c(2:1, 3L), each = 2))) expect_identical(union(df1, rev_df(df2)), tibble(x = c(1:4, 6:5), g = rep(1:3, each = 2))) }) test_that("set operations remove duplicates", { df1 <- tibble(x = 1:4, g = rep(1:2, each = 2)) %>% bind_rows(., .) df2 <- tibble(x = 3:6, g = rep(2:3, each = 2)) expect_identical(setdiff(df1, df2), filter(df1, x < 3) %>% distinct()) expect_identical(intersect(df1, df2), filter(df1, x >= 3) %>% distinct()) expect_identical(union(df1, df2), tibble(x = 1:6, g = rep(1:3, each = 2))) }) test_that("set equality", { df1 <- tibble(x = 1:4, g = rep(1:2, each = 2)) %>% group_by(g) df2 <- tibble(x = 3:6, g = rep(2:3, each = 2)) expect_true(setequal(df1, df1)) expect_true(setequal(df2, df2)) expect_false(setequal(df1, df2)) expect_false(setequal(df2, df1)) }) dplyr/tests/testthat/test-count-tally.r0000644000176200001440000001426413614573562020044 0ustar liggesuserscontext("count-tally") # count ------------------------------------------------------------------- test_that("can count variable called n", { df <- data.frame(n = c(1, 1, 2, 2, 2)) out <- df %>% count(n) expect_equal(names(out), c("n", "nn")) expect_equal(out$nn, c(2, 3)) out <- df %>% count(n, sort = TRUE) expect_equal(out$nn, c(3, 2)) }) test_that("count preserves grouping of input", { df <- data.frame(g = c(1, 2, 2, 2)) out1 <- count(df, g) expect_equal(group_vars(out1), character()) df2 <- df %>% group_by(g) out2 <- count(df2) expect_equal(group_vars(out2), "g") }) test_that("grouped count includes group", { df <- data.frame(g = c(1, 2, 2, 2)) res <- df %>% group_by(g) %>% count() expect_equal(names(res), c("g", "n")) expect_equal(res$n, c(1, 3)) expect_equal(group_vars(res), "g") }) test_that("returns user defined variable name", { df <- data.frame(g = c(1, 1, 2, 2, 2)) var_name <- "number_n" res <- df %>% count(g, name = var_name) expect_equal(names(res), c("g", var_name)) expect_equal(res[[var_name]], c(2, 3)) }) test_that("count() does not ignore non-factor empty groups (#4013)", { d <- data.frame(x = c("a", "a", "b", "b"), value = 1:4, stringsAsFactors = FALSE) g <- d %>% group_by(x) %>% filter(value > 3, .preserve = TRUE) res <- count(g) expect_equal(nrow(res), 2L) expect_equal(res$x, c("a", "b")) expect_equal(res$n, c(0L, 1L)) }) test_that("returns error if user-defined name equals a grouped variable name", { df <- data.frame(g = c(1, 1, 2, 2, 2)) expect_error(df %>% count(g, name = "g")) }) # add_count --------------------------------------------------------------- test_that("can add counts of a variable called n", { df <- data.frame(n = c(1, 1, 2, 2, 2)) out <- df %>% add_count(n) expect_equal(names(out), c("n", "nn")) expect_equal(out$n, df$n) expect_equal(out$nn, c(2, 2, 3, 3, 3)) out <- df %>% add_count(n, sort = TRUE) expect_equal(out$nn, c(3, 3, 3, 2, 2)) }) test_that("add_count respects and preserves existing groups", { df <- data.frame(g = c(1, 2, 2, 2), val = c("b", "b", "b", "c")) res <- df %>% add_count(val) expect_equal(res$n, c(3, 3, 3, 1)) expect_no_groups(res) res <- df %>% group_by(g) %>% add_count(val) expect_equal(res$n, c(1, 2, 2, 1)) expect_groups(res, "g") }) test_that("adds counts column with user-defined name if it is not a grouped variable", { df <- data.frame(g = c(1, 1, 2, 2, 2), count = c(3, 2, 5, 5, 5)) name <- "count" out <- df %>% add_count(g, name = name) expect_equal(names(out), c("g", name)) expect_equal(out[[name]], c(2, 2, 3, 3, 3)) }) test_that("returns error if user-defined name equals a grouped variable", { df <- data.frame(g = c(1, 1, 2, 2, 2)) expect_error(df %>% add_count(g, name = "g")) }) # tally ------------------------------------------------------------------- test_that("weighted tally drops NAs (#1145)", { df <- tibble(x = c(1, 1, NA)) expect_equal(tally(df, x)$n, 2) }) test_that("returns column with user-defined name", { df <- tibble(g = c(1, 2, 2, 2), val = c("b", "b", "b", "c")) name <- "counts" res <- df %>% tally(name = name) expect_equal(names(res), name) }) test_that("returns column with user-defined name if it is not a grouped variable", { df <- tibble(g = c(1, 2, 2, 2), val = c("b", "b", "b", "c")) name <- "g" res <- df %>% tally(name = name) expect_equal(names(res), name) }) test_that("returns error if user-defined name equals a grouped variable", { df <- tibble(g = c(1, 2, 2, 2), val = c("b", "b", "b", "c")) name <- "g" expect_error(df %>% group_by(g) %>% tally(name = name)) }) # add_tally --------------------------------------------------------------- test_that("can add tallies of a variable", { df <- data.frame(a = c(1, 1, 2, 2, 2)) out <- df %>% group_by(a) %>% add_tally() expect_equal(names(out), c("a", "n")) expect_equal(out$a, df$a) expect_equal(out$n, c(2, 2, 3, 3, 3)) out <- df %>% group_by(a) %>% add_tally(sort = TRUE) expect_equal(out$n, c(3, 3, 3, 2, 2)) }) test_that("add_tally respects and preserves existing groups", { df <- data.frame(g = c(1, 2, 2, 2), val = c("b", "b", "b", "c")) res <- df %>% group_by(val) %>% add_tally() expect_equal(res$n, c(3, 3, 3, 1)) expect_groups(res, "val") res <- df %>% group_by(g, val) %>% add_tally() expect_equal(res$n, c(1, 2, 2, 1)) expect_groups(res, c("g", "val")) }) test_that("add_tally can be given a weighting variable", { df <- data.frame(a = c(1, 1, 2, 2, 2), w = c(1, 1, 2, 3, 4)) out <- df %>% group_by(a) %>% add_tally(wt = w) expect_equal(out$n, c(2, 2, 9, 9, 9)) out <- df %>% group_by(a) %>% add_tally(wt = w + 1) expect_equal(out$n, c(4, 4, 12, 12, 12)) }) test_that("adds column with user-defined variable name if it is not a grouped variable name", { df <- tibble(g = c(1, 2, 2, 2), val = c("b", "b", "b", "c")) name <- "val" res <- df %>% add_tally(name = name) expect_equal(names(res), c("g", "val")) }) test_that("returns error if user-defined name equals a grouped variable", { df <- tibble(g = c(1, 2, 2, 2), val = c("b", "b", "b", "c")) name <- "val" expect_error(df %>% group_by(val) %>% add_tally(name = name)) }) # count and .drop ---------------------------------------------------- test_that("count() deals with .drop", { d <- tibble( f1 = factor("b", levels = c("a", "b", "c")), f2 = factor("g", levels = c("e", "f", "g")), x = 48 ) res <- d %>% group_by(f1, .drop = TRUE) %>% count(f2, .drop = TRUE) res2 <- d %>% group_by(f1, .drop = TRUE) %>% count(f2) res3 <- d %>% group_by(f1, .drop = TRUE) %>% count(f2, .drop = FALSE) expect_equal(n_groups(res), 1L) expect_identical(res, res2) expect_equal(n_groups(res3), 3L) expect_equal(nrow(res3), 9L) }) test_that("add_count() respects .drop", { d <- tibble( f1 = factor("b", levels = c("a", "b", "c")), f2 = factor("g", levels = c("e", "f", "g")), x = 48 ) res1 <- d %>% group_by(f1) %>% add_count(f2, .drop = FALSE) res2 <- d %>% group_by(f1) %>% add_count(f2, .drop = TRUE) res3 <- d %>% group_by(f1) %>% add_count(f2) expect_identical(res2, res3) expect_equal(n_groups(res2), 1) expect_equal(n_groups(res1), 3) }) dplyr/tests/testthat/test-mutate.r0000644000176200001440000006570413614573562017075 0ustar liggesuserscontext("Mutate") test_that("repeated outputs applied progressively (data frame)", { df <- data.frame(x = 1) out <- mutate(df, z = x + 1, z = z + 1) expect_equal(nrow(out), 1) expect_equal(ncol(out), 2) expect_equal(out$z, 3) }) test_that("repeated outputs applied progressively (grouped_df)", { df <- data.frame(x = c(1, 1), y = 1:2) ds <- group_by(df, y) out <- mutate(ds, z = x + 1, z = z + 1) expect_equal(nrow(out), 2) expect_equal(ncol(out), 3) expect_equal(out$z, c(3L, 3L)) }) test_that("two mutates equivalent to one", { df <- tibble(x = 1:10, y = 6:15) df1 <- df %>% mutate(x2 = x * 2, y4 = y * 4) df2 <- df %>% mutate(x2 = x * 2) %>% mutate(y4 = y * 4) expect_equal(df1, df2) }) test_that("mutate can refer to variables that were just created (#140)", { res <- mutate(tbl_df(mtcars), cyl1 = cyl + 1, cyl2 = cyl1 + 1) expect_equal(res$cyl2, mtcars$cyl + 2) gmtcars <- group_by(tbl_df(mtcars), am) res <- mutate(gmtcars, cyl1 = cyl + 1, cyl2 = cyl1 + 1) res_direct <- mutate(gmtcars, cyl2 = cyl + 2) expect_equal(res$cyl2, res_direct$cyl2) }) test_that("mutate handles logical result (#141)", { x <- data.frame(x = 1:10, g = rep(c(1, 2), each = 5)) res <- tbl_df(x) %>% group_by(g) %>% mutate(r = x > mean(x)) expect_equal(res$r, rep(c(FALSE, FALSE, FALSE, TRUE, TRUE), 2)) }) test_that("mutate can rename variables (#137)", { res <- mutate(tbl_df(mtcars), cyl2 = cyl) expect_equal(res$cyl2, mtcars$cyl) res <- mutate(group_by(tbl_df(mtcars), am), cyl2 = cyl) expect_equal(res$cyl2, res$cyl) }) test_that("mutate refuses to modify grouping vars (#143)", { expect_error( mutate(group_by(tbl_df(mtcars), am), am = am + 2), "Column `am` can't be modified because it's a grouping variable", fixed = TRUE ) }) test_that("mutate handles constants (#152)", { res <- mutate(tbl_df(mtcars), zz = 1) expect_equal(res$zz, rep(1, nrow(mtcars))) }) test_that("mutate fails with wrong result size (#152)", { df <- group_by(data.frame(x = c(2, 2, 3, 3)), x) expect_equal(mutate(df, y = 1:2)$y, rep(1:2, 2)) expect_error( mutate(mtcars, zz = 1:2), "Column `zz` must be length 32 (the number of rows) or one, not 2", fixed = TRUE ) df <- group_by(data.frame(x = c(2, 2, 3, 3, 3)), x) expect_error( mutate(df, y = 1:2), "Column `y` must be length 3 (the group size) or one, not 2", fixed = TRUE ) }) test_that("mutate refuses to use symbols not from the data", { y <- 1:6 df <- group_by(data.frame(x = c(1, 2, 2, 3, 3, 3)), x) expect_error( mutate(df, z = y), "Column `z` must be length 1 (the group size), not 6", fixed = TRUE ) }) test_that("mutate recycles results of length 1", { df <- data.frame(x = c(2, 2, 3, 3)) expect_equal(mutate(tbl_df(df), z = length(x))$z, rep(4, 4)) expect_equal(mutate(group_by(df, x), z = length(x))$z, rep(2, 4)) int <- 1L str <- "foo" num <- 1 bool <- TRUE list <- list(NULL) res <- mutate(group_by(df, x), int = int, str = str, num = num, bool = bool, list = list) expect_equal(res$int, rep(int, 4)) expect_equal(res$str, rep(str, 4)) expect_equal(res$num, rep(num, 4)) expect_equal(res$bool, rep(bool, 4)) expect_equal(res$list, rep(list, 4)) }) test_that("mutate handles out of data variables", { today <- Sys.Date() now <- Sys.time() df <- data.frame(x = c(2, 2, 3, 3)) gdf <- group_by(df, x) int <- c(1L, 2L) str <- c("foo", "bar") num <- c(1, 2) bool <- c(TRUE, FALSE) dat <- rep(today, 2) tim <- rep(now, 2) res <- mutate( gdf, int = int, str = str, num = num, bool = bool, dat = dat, tim = tim ) expect_equal(res$int, rep(int, 2)) expect_equal(res$str, rep(str, 2)) expect_equal(res$num, rep(num, 2)) expect_equal(res$bool, rep(bool, 2)) expect_equal(res$dat, rep(dat, 2)) expect_equal(res$tim, rep(tim, 2)) int <- 1:6 expect_error( mutate(gdf, int = int), "Column `int` must be length 2 (the group size) or one, not 6", fixed = TRUE ) expect_error( mutate(tbl_df(df), int = int), "Column `int` must be length 4 (the number of rows) or one, not 6", fixed = TRUE ) int <- 1:4 str <- rep(c("foo", "bar"), 2) num <- c(1, 2, 3, 4) bool <- c(TRUE, FALSE, FALSE, TRUE) dat <- rep(today, 4) tim <- rep(now, 4) res <- mutate( tbl_df(df), int = int, str = str, num = num, bool = bool, tim = tim, dat = dat ) expect_equal(res$int, int) expect_equal(res$str, str) expect_equal(res$num, num) expect_equal(res$bool, bool) expect_equal(res$dat, dat) expect_equal(res$tim, tim) }) test_that("mutate handles passing ...", { df <- data.frame(x = 1:4) f <- function(...) { x1 <- 1 f1 <- function(x) x mutate(df, ..., x1 = f1(x1)) } g <- function(...) { x2 <- 2 f(x2 = x2, ...) } h <- function(before = "before", ..., after = "after") { g(before = before, ..., after = after) } res <- h(x3 = 3) expect_equal(res$x1, rep(1, 4)) expect_equal(res$x2, rep(2, 4)) expect_equal(res$before, rep("before", 4)) expect_equal(res$after, rep("after", 4)) df <- tbl_df(df) res <- h(x3 = 3) expect_equal(res$x1, rep(1, 4)) expect_equal(res$x2, rep(2, 4)) expect_equal(res$before, rep("before", 4)) expect_equal(res$after, rep("after", 4)) df <- group_by(df, x) res <- h(x3 = 3) expect_equal(res$x1, rep(1, 4)) expect_equal(res$x2, rep(2, 4)) expect_equal(res$before, rep("before", 4)) expect_equal(res$after, rep("after", 4)) }) test_that("mutate fails on unsupported column type", { df <- data.frame(created = c("2014/1/1", "2014/1/2", "2014/1/2")) expect_error( mutate(df, date = strptime(created, "%Y/%m/%d")), "Column `date` is of unsupported class POSIXlt; please use POSIXct instead", fixed = TRUE ) df <- data.frame( created = c("2014/1/1", "2014/1/2", "2014/1/2"), g = c(1, 1, 2) ) expect_error( mutate(group_by(df, g), date = strptime(created, "%Y/%m/%d")), "Column `date` is of unsupported class POSIXlt; please use POSIXct instead", fixed = TRUE ) }) test_that("mutate can handle POSIXlt columns (#3854)", { df <- data.frame(g=c(1,1,3)) df$created <- strptime(c("2014/1/1", "2014/1/2", "2014/1/2"), format = "%Y/%m/%d") res <- df %>% group_by(g) %>% mutate(Y = format(created, "%Y")) expect_true(all(res$Y == "2014")) }) test_that("mutate modifies same column repeatedly (#243)", { df <- data.frame(x = 1) expect_equal(mutate(df, x = x + 1, x = x + 1)$x, 3) }) test_that("mutate errors when results are not compatible accross groups (#299)", { d <- data.frame(x = rep(1:5, each = 3)) expect_error( mutate(group_by(d, x), val = ifelse(x < 3, "foo", 2)), "Column `val` can't be converted from character to numeric", fixed = TRUE ) }) test_that("assignments don't overwrite variables (#315)", { expect_equal( mutate(mtcars, cyl2 = { mpg <- cyl^2 -mpg } ), mutate(mtcars, cyl2 = -cyl^2) ) }) test_that("hybrid evaluator uses correct environment (#403)", { func1 <- function() { func2 <- function(x) floor(x) mutate(mtcars, xx = func2(mpg / sum(mpg))) } res <- func1() expect_equal(res$xx, rep(0, nrow(res))) }) test_that("mutate remove variables with = NULL syntax (#462)", { data <- mtcars %>% mutate(cyl = NULL) expect_false("cyl" %in% names(data)) data <- mtcars %>% group_by(disp) %>% mutate(cyl = NULL) expect_false("cyl" %in% names(data)) }) test_that("mutate strips names, but only if grouped (#1689, #2675)", { data <- tibble(a = 1:3) %>% mutate(b = setNames(nm = a)) expect_equal(names(data$b), as.character(1:3)) data <- tibble(a = 1:3) %>% rowwise() %>% mutate(b = setNames(nm = a)) expect_null(names(data$b)) data <- tibble(a = c(1, 1, 2)) %>% group_by(a) %>% mutate(b = setNames(nm = a)) expect_null(names(data$b)) }) test_that("mutate does not strip names of list-columns (#2675)", { vec <- list(a = 1, b = 2) data <- tibble(x = vec) data <- mutate(data, x) expect_identical(names(vec), c("a", "b")) expect_identical(names(data$x), c("a", "b")) }) test_that("mutate removes columns when the expression evaluates to NULL for all groups (#2945)", { df <- tibble(a = 1:3, b=4:6) gf <- group_by(df, a) rf <- rowwise(df) expect_equal( mutate(df, b = identity(NULL)), select(df, -b) ) expect_equal( mutate(gf, b = identity(NULL)), select(gf, -b) ) expect_equal( mutate(rf, b = identity(NULL)), select(rf,-b) ) }) test_that("mutate treats NULL specially when the expression sometimes evaulates to NULL (#2945)", { df <- tibble(a = 1:3, b=4:6) %>% group_by(a) expect_equal( mutate(df, if(a==1) NULL else "foo") %>% pull(), c(NA, "foo", "foo")) expect_equal( mutate(df, if(a==1) NULL else list(b)) %>% pull(), list(NULL, 5L, 6L)) }) test_that("mutate(rowwise_df) makes a rowwise_df (#463)", { one_mod <- data.frame(grp = "a", x = runif(5, 0, 1)) %>% tbl_df() %>% mutate(y = rnorm(x, x * 2, 1)) %>% group_by(grp) %>% do(mod = lm(y ~ x, data = .)) out <- one_mod %>% mutate(rsq = summary(mod)$r.squared) %>% mutate(aic = AIC(mod)) expect_is(out, "rowwise_df") expect_equal(nrow(out), 1L) expect_is(out$mod, "list") expect_is(out$mod[[1L]], "lm") }) test_that("mutate allows list columns (#555)", { df <- data.frame(x = c("a;b", "c;d;e"), stringsAsFactors = FALSE) res <- mutate(df, pieces = strsplit(x, ";")) expect_equal(res$pieces, list(c("a", "b"), c("c", "d", "e"))) }) test_that("hybrid evaluation goes deep enough (#554)", { res1 <- iris %>% mutate(test = 1 == 2 | row_number() < 10) res2 <- iris %>% mutate(test = row_number() < 10 | 1 == 2) expect_equal(res1, res2) }) test_that("hybrid does not segfault when given non existing variable (#569)", { # error message from rlang expect_error(mtcars %>% summarise(first(mp))) }) test_that("namespace extraction works in hybrid (#412)", { df <- data.frame(x = 1:2) expect_equal( mutate(df, y = base::mean(x)), mutate(df, y = mean(x)) ) expect_equal( mutate(df, y = stats::IQR(x)), mutate(df, y = IQR(x)) ) }) test_that("hybrid not get in the way of order_by (#169)", { df <- tibble(x = 10:1, y = 1:10) res <- mutate(df, z = order_by(x, cumsum(y))) expect_equal(res$z, rev(cumsum(10:1))) }) test_that("mutate supports difftime objects (#390)", { df <- tibble( grp = c(1, 1, 2, 2), val = c(1, 3, 4, 6), date1 = c(rep(Sys.Date() - 10, 2), rep(Sys.Date() - 20, 2)), date2 = Sys.Date() + c(1, 2, 1, 2), diffdate = difftime(date2, date1, unit = "days") ) res <- df %>% group_by(grp) %>% mutate(mean_val = mean(val), mean_diffdate = mean(diffdate)) expect_is(res$mean_diffdate, "difftime") expect_equal(as.numeric(res$mean_diffdate), c(11.5, 11.5, 21.5, 21.5)) res <- df %>% group_by(grp) %>% summarise(dt = mean(diffdate)) expect_is(res$dt, "difftime") expect_equal(as.numeric(res$dt), c(11.5, 21.5)) }) test_that("mutate works on zero-row grouped data frame (#596)", { dat <- data.frame(a = numeric(0), b = character(0)) res <- dat %>% group_by(b, .drop = FALSE) %>% mutate(a2 = a * 2) expect_is(res$a2, "numeric") expect_is(res, "grouped_df") expect_equal(res$a2, numeric(0)) expect_equal(group_rows(res), list()) expect_equal(group_data(res)$b, factor(character(0))) }) test_that("mutate works on zero-row rowwise data frame (#4224)", { dat <- data.frame(a = numeric(0)) res <- dat %>% rowwise() %>% mutate(a2 = a * 2) expect_is(res$a2, "numeric") expect_is(res, "rowwise_df") expect_equal(res$a2, numeric(0)) }) test_that("Non-ascii column names in version 0.3 are not duplicated (#636)", { skip("Currently failing (#2967)") df <- tibble(a = "1", b = "2") names(df) <- c("a", enc2native("\u4e2d")) res <- df %>% mutate_all(funs(as.numeric)) %>% names() expect_equal(res, names(df)) }) test_that("nested hybrid functions do the right thing (#637)", { res <- mtcars %>% mutate(mean(1)) expect_true(all(res[["mean(1)"]] == 1L)) }) test_that("mutate handles using and gathering complex data (#436)", { d <- tibble(x = 1:10, y = 1:10 + 2i) res <- mutate(d, real = Re(y), imag = Im(y), z = 2 * y, constant = 2 + 2i) expect_equal(names(res), c("x", "y", "real", "imag", "z", "constant")) expect_equal(res$real, Re(d$y)) expect_equal(res$imag, Im(d$y)) expect_equal(res$z, d$y * 2) expect_true(all(res$constant == 2 + 2i)) }) test_that("mutate forbids POSIXlt results (#670)", { expect_error( data.frame(time = "2014/01/01 10:10:10") %>% mutate(time = as.POSIXlt(time)), "Column `time` is of unsupported class POSIXlt; please use POSIXct instead", fixed = TRUE ) expect_error( data.frame(time = "2014/01/01 10:10:10", a = 2) %>% group_by(a) %>% mutate(time = as.POSIXlt(time)), "Column `time` is of unsupported class POSIXlt; please use POSIXct instead", fixed = TRUE ) }) test_that("constant factor can be handled by mutate (#715)", { d <- tibble(x = 1:2) %>% mutate(y = factor("A")) expect_true(is.factor(d$y)) expect_equal(d$y, factor(c("A", "A"))) }) test_that("row_number handles empty data frames (#762)", { df <- data.frame(a = numeric(0)) res <- df %>% mutate( row_number_0 = row_number(), row_number_a = row_number(a), ntile = ntile(a, 2), min_rank = min_rank(a), percent_rank = percent_rank(a), dense_rank = dense_rank(a), cume_dist = cume_dist(a) ) expect_equal( names(res), c("a", "row_number_0", "row_number_a", "ntile", "min_rank", "percent_rank", "dense_rank", "cume_dist") ) expect_equal(nrow(res), 0L) }) test_that("hybrid rank functions handle NA (#4427)", { df <- tibble(a = runif(1000, -1, 1), b = runif(1000, -1, 1)) df[df < 0] <- NA df <- df %>% mutate( gain = b - a, cume_dist_hybrid = cume_dist(gain), cume_dist_std = cume_dist(b - a), pct_rank_hybrid = percent_rank(gain), pct_rank_std = percent_rank(b-a) ) expect_equal(df$cume_dist_hybrid, df$cume_dist_std) expect_equal(df$pct_rank_hybrid, df$pct_rank_std) }) test_that("no utf8 invasion (#722)", { skip("fails on windows, but also on one cran machine") source("utf-8.txt", local = TRUE, encoding = "UTF-8") }) test_that("mutate works on empty data frames (#1142)", { df <- data.frame() res <- df %>% mutate() expect_equal(nrow(res), 0L) expect_equal(length(res), 0L) res <- df %>% mutate(x = numeric()) expect_equal(names(res), "x") expect_equal(nrow(res), 0L) expect_equal(length(res), 1L) }) test_that("mutate handles 0 rows rowwise (#1300)", { a <- tibble(x = 1) b <- tibble(y = character()) g <- function(y) { 1 } f <- function() { b %>% rowwise() %>% mutate(z = g(y)) } res <- f() expect_equal(nrow(res), 0L) }) test_that("rhs of mutate cannot be a data frame (#3298)", { df <- data.frame("a" = c(1, 2, 3), "b" = c(2, 3, 4), "base_col" = c(3, 4, 5)) expect_error( mutate(df, new_col = data.frame(1:3)), "Column `new_col` is of unsupported class data.frame" ) expect_error( mutate(group_by(df, a), new_col = data.frame(1:3)), "Column `new_col` is of unsupported class data.frame" ) expect_error( mutate(rowwise(df), new_col = data.frame(1:3)), "Column `new_col` is of unsupported class data.frame" ) }) test_that("regression test for #637", { res <- mtcars %>% mutate(xx = mean(1)) expect_true(all(res$xx == 1)) res <- mtcars %>% mutate(xx = sum(mean(mpg))) expect_true(all(res$xx == sum(mean(mtcars$mpg)))) }) test_that("mutate.rowwise handles factors (#886)", { res <- data.frame(processed = c("foo", "bar")) %>% rowwise() %>% mutate(processed_trafo = paste("test", processed)) expect_equal(res$processed_trafo, c("test foo", "test bar")) }) test_that("setting first column to NULL with mutate works (#1329)", { df <- data.frame(x = 1:10, y = 1:10) expect_equal(mutate(df, x = NULL), select(df, -x)) expect_equal(mutate(df, y = NULL), select(df, -y)) gdf <- group_by(df, y) expect_equal(select(gdf, -x), mutate(gdf, x = NULL)) }) test_that("mutate handles the all NA case (#958)", { x <- rep(c("Bob", "Jane"), each = 36) y <- rep(rep(c("A", "B", "C"), each = 12), 2) day <- rep(rep(1:12, 3), 2) values <- rep(rep(c(10, 11, 30, 12, 13, 14, 15, 16, 17, 18, 19, 20), 3), 2) df <- data.frame(x = x, y = y, day = day, values = values) df$values[1:12] <- NA res <- df %>% group_by(x, y) %>% mutate(max.sum = day[which.max(values)[1]]) %>% mutate(adjusted_values = ifelse(day < max.sum, 30, values)) expect_true(all(is.na(res$adjusted_values[1:12]))) }) test_that("rowwise mutate gives expected results (#1381)", { f <- function(x) ifelse(x < 2, NA_real_, x) res <- tibble(x = 1:3) %>% rowwise() %>% mutate(y = f(x)) expect_equal(res$y, c(NA, 2, 3)) }) test_that("mutate handles factors (#1414)", { d <- tibble( g = c(1, 1, 1, 2, 2, 3, 3), f = c("a", "b", "a", "a", "a", "b", "b") ) res <- d %>% group_by(g) %>% mutate(f2 = factor(f, levels = c("a", "b"))) expect_equal(as.character(res$f2), res$f) }) test_that("mutate handles results from one group with all NA values (#1463) ", { df <- tibble(x = c(1, 2), y = c(1, NA)) res <- df %>% group_by(x) %>% mutate(z = ifelse(y > 1, 1, 2)) expect_true(is.na(res$z[2])) expect_is(res$z, "numeric") }) test_that("rowwise mutate handles the NA special case (#1448)", { res <- data.frame(k = c(-1, 1, 1)) %>% rowwise() %>% mutate(l = ifelse(k > 0, 1, NA)) expect_is(res$l, "numeric") expect_true(is.na(res$l[1])) expect_true(!anyNA(res$l[-1])) res <- data.frame(k = rnorm(10)) %>% rowwise() %>% mutate(l = ifelse(k > 0, 1L, NA_integer_)) expect_true(all(is.na(res$l[res$k <= 0]))) expect_true(!any(is.na(res$l[res$k > 0]))) }) test_that("mutate disambiguates NA and NaN (#1448)", { Pass <- data.frame(P2 = c(0, 3, 2), F2 = c(0, 2, 0), id = 1:3) res <- Pass %>% group_by(id) %>% mutate(pass2 = P2 / (P2 + F2)) expect_true(is.nan(res$pass2[1])) res <- Pass %>% rowwise() %>% mutate(pass2 = P2 / (P2 + F2)) expect_true(is.nan(res$pass2[1])) Pass <- tibble( P1 = c(2L, 0L, 10L, 8L, 9L), F1 = c(0L, 2L, 0L, 4L, 3L), P2 = c(0L, 3L, 2L, 2L, 2L), F2 = c(0L, 2L, 0L, 1L, 1L), id = c(1, 2, 4, 4, 5) ) res <- Pass %>% group_by(id) %>% mutate( pass_rate = (P1 + P2) / (P1 + P2 + F1 + F2) * 100, pass_rate1 = P1 / (P1 + F1) * 100, pass_rate2 = P2 / (P2 + F2) * 100 ) expect_true(is.nan(res$pass_rate2[1])) }) test_that("hybrid evaluator leaves formulas untouched (#1447)", { d <- tibble(g = 1:2, training = list(mtcars, mtcars * 2)) mpg <- data.frame(x = 1:10, y = 1:10) res <- d %>% group_by(g) %>% mutate(lm_result = list(lm(mpg ~ wt, data = training[[1]]))) expect_is(res$lm_result, "list") expect_is(res$lm_result[[1]], "lm") expect_is(res$lm_result[[2]], "lm") }) test_that("lead/lag inside mutate handles expressions as value for default (#1411) ", { df <- tibble(x = 1:3) res <- mutate(df, leadn = lead(x, default = x[1]), lagn = lag(x, default = x[1])) expect_equal(res$leadn, lead(df$x, default = df$x[1])) expect_equal(res$lagn, lag(df$x, default = df$x[1])) res <- mutate(df, leadn = lead(x, default = c(1)), lagn = lag(x, default = c(1))) expect_equal(res$leadn, lead(df$x, default = 1)) expect_equal(res$lagn, lag(df$x, default = 1)) }) test_that("grouped mutate does not drop grouping attributes (#1020)", { d <- data.frame(subject = c("Jack", "Jill"), id = c(2, 1)) %>% group_by(subject) a1 <- names(attributes(d)) a2 <- names(attributes(d %>% mutate(foo = 1))) expect_equal(setdiff(a1, a2), character(0)) }) test_that("grouped mutate coerces integer + double -> double (#1892)", { df <- tibble( id = c(1, 4), value = c(1L, NA), group = c("A", "B") ) %>% group_by(group) %>% mutate(value = ifelse(is.na(value), 0, value)) expect_type(df$value, "double") expect_identical(df$value, c(1, 0)) }) test_that("grouped mutate coerces factor + character -> character (WARN) (#1892)", { factor_or_character <- function(x) { if (x > 3) { return(factor("hello")) } else { return("world") } } df <- tibble( id = c(1, 4), group = c("A", "B") ) %>% group_by(group) expect_warning( df <- df %>% mutate(value = factor_or_character(id)) ) expect_type(df$value, "character") expect_identical(df$value, c("world", "hello")) }) test_that("lead/lag works on more complex expressions (#1588)", { df <- tibble(x = rep(1:5, 2), g = rep(1:2, each = 5)) %>% group_by(g) res <- df %>% mutate(y = lead(x > 3)) expect_equal(res$y, rep(lead(1:5 > 3), 2)) }) test_that("Adding a Column of NA to a Grouped Table gives expected results (#1645)", { dataset <- tibble(A = 1:10, B = 10:1, group = factor(sample(LETTERS[25:26], 10, TRUE))) res <- dataset %>% group_by(group) %>% mutate(prediction = factor(NA)) expect_true(all(is.na(res$prediction))) expect_is(res$prediction, "factor") expect_equal(levels(res$prediction), character()) }) test_that("Deep copies are performed when needed (#1463)", { res <- data.frame(prob = c(F, T)) %>% rowwise() %>% mutate(model = list(x = prob)) expect_equal(unlist(res$model), c(FALSE, TRUE)) res <- data.frame(x = 1:4, g = c(1, 1, 1, 2)) %>% group_by(g) %>% mutate(model = list(y = x)) expect_equal(res$model[[1]], 1:3) expect_equal(res$model[[4]], 4) }) test_that("ntile falls back to R (#1750)", { res <- mutate(iris, a = ntile("Sepal.Length", 3)) expect_equal(res$a, rep(1, 150)) }) test_that("mutate() names pronouns correctly (#2686)", { expect_named(mutate(tibble(x = 1), .data$x), "x") expect_named(mutate(tibble(x = 1), .data[["x"]]), "x") }) test_that("mutate() supports unquoted values", { df <- tibble(g = c(1, 1, 2, 2, 2), x = 1:5) expect_identical(mutate(df, out = !!1), mutate(df, out = 1)) expect_identical(mutate(df, out = !!(1:5)), mutate(df, out = 1:5)) expect_identical(mutate(df, out = !!quote(1:5)), mutate(df, out = 1:5)) expect_error(mutate(df, out = !!(1:2)), "must be length 5 (the number of rows)", fixed = TRUE) expect_error(mutate(df, out = !!env(a = 1)), "unsupported type") gdf <- group_by(df, g) expect_identical(mutate(gdf, out = !!1), mutate(gdf, out = 1)) expect_identical(mutate(gdf, out = !!(1:5)), group_by(mutate(df, out = 1:5), g)) expect_error(mutate(gdf, out = !!quote(1:5)), "must be length 2 (the group size)", fixed = TRUE) expect_error(mutate(gdf, out = !!(1:2)), "must be length 5 (the group size)", fixed = TRUE) expect_error(mutate(gdf, out = !!env(a = 1)), "unsupported type") }) test_that("gathering handles promotion from raw", { df <- tibble(a = 1:4, g = c(1, 1, 2, 2)) # collecting raw in the first group, then other types expect_identical( df %>% group_by(g) %>% mutate(b = if (all(a < 3)) as.raw(a) else a) %>% pull(b), 1:4 ) expect_identical( df %>% group_by(g) %>% mutate(b = if (all(a < 3)) as.raw(a) else as.numeric(a)) %>% pull(b), as.numeric(1:4) ) }) # Error messages ---------------------------------------------------------- test_that("mutate handles raw vectors in columns (#1803)", { df <- tibble(a = 1:3, b = as.raw(1:3)) expect_identical(mutate(df, a = 1), tibble(a = 1, b = as.raw(1:3))) expect_identical(mutate(df, b = 1), tibble(a = 1:3, b = 1)) expect_identical(mutate(df, c = 1), tibble(a = 1:3, b = as.raw(1:3), c = 1)) expect_identical(mutate(df, c = as.raw(a)), tibble(a = 1:3, b = as.raw(1:3), c = as.raw(1:3))) df <- tibble(a = 1:4, g = c(1, 1, 2, 2)) expect_identical(mutate(df, b = as.raw(a)) %>% group_by(g) %>% pull(b), as.raw(1:4)) expect_identical(mutate(df, b = as.raw(a)) %>% rowwise() %>% pull(b), as.raw(1:4)) }) test_that("grouped mutate errors on incompatible column type (#1641)", { expect_error( tibble(x = 1) %>% mutate(y = mean), "Column `y` is of unsupported type function", fixed = TRUE ) expect_error( tibble(x = 1) %>% mutate(y = quote(a)), "Column `y` is of unsupported type symbol", fixed = TRUE ) }) test_that("can reuse new variables", { expect_equal( data.frame(c = 1) %>% mutate(c, gc = mean(c)), data.frame(c = 1, gc = 1) ) }) test_that("can use character vectors in grouped mutate (#2971)", { df <- tibble(x = 1:10000) %>% group_by(x) %>% mutate( y = as.character(runif(1L)), z = as.character(runif(1L)) ) expect_error(df %>% distinct(x, .keep_all = TRUE), NA) }) test_that("mutate() to UTF-8 column names", { skip_on_cran() df <- tibble(a = 1) %>% mutate("\u5e78" := a) expect_equal(colnames(df), c("a", "\u5e78")) }) test_that("grouped subsets are not lazy (#3360)", { make_call <- function(x) { quo(!!x) } res <- tibble(name = 1:2, value = letters[1:2]) %>% rowwise() %>% mutate(call = list(make_call(value))) %>% pull() expect_identical(res, list(make_call("a"), make_call("b"))) res <- tibble(name = 1:2, value = letters[1:2]) %>% group_by(name) %>% mutate(call = list(make_call(value))) %>% pull() expect_identical(res, list(make_call("a"), make_call("b"))) }) test_that("errors don't have tracebacks (#3662)", { err <- capture_condition(mutate(tibble(x = 1:10) %>% mutate(z = y))) expect_null(conditionCall(err)) err <- capture_condition(n_distinct()) expect_null(conditionCall(err)) }) test_that("columns are no longer available when set to NULL on mutate (#3799)", { tbl <- tibble(x = 1:2, y = 1:2) expect_error(mutate(tbl, y = NULL, a = +sum(y))) expect_error(mutate(tbl, y = NULL, a = sum(y))) tbl <- tbl %>% group_by(x) expect_error(mutate(tbl, y = NULL, a = +sum(y))) expect_error(mutate(tbl, y = NULL, a = sum(y))) }) test_that("rlang lambda inherit from the data mask (#3843)", { res <- iris %>% mutate_at( vars(starts_with("Petal")), ~ ifelse(Species == "setosa" & . < 1.5, NA, .) ) expected <- iris %>% mutate( Petal.Length = ifelse(Species == "setosa" & Petal.Length < 1.5, NA, Petal.Length), Petal.Width = ifelse(Species == "setosa" & Petal.Width < 1.5, NA, Petal.Width) ) expect_equal(res, expected) res <- iris %>% group_by(Species) %>% mutate_at( vars(starts_with("Petal")), ~ ifelse(Species == "setosa" & . < 1.5, NA, .) ) expected <- iris %>% group_by(Species) %>% mutate( Petal.Length = ifelse(Species == "setosa" & Petal.Length < 1.5, NA, Petal.Length), Petal.Width = ifelse(Species == "setosa" & Petal.Width < 1.5, NA, Petal.Width) ) expect_equal(res, expected) }) test_that("mutate() does not segfault when setting an unknown column to NULL (#4035)", { expect_true(all_equal(mutate(mtcars, dummy = NULL), mtcars)) }) test_that("mutate() skips evaluation of R expression for empty groups (#4088)", { count <- 0 d <- tibble(f = factor(c("a", "b"), levels = c("a", "b", "c"))) %>% group_by(f) res <- mutate(d, x = { count <<- count + 1; 675} ) expect_equal(count, 2L) d <- tibble(f = factor(c("c"), levels = c("a", "b", "c"))) %>% group_by(f) res <- mutate(d, x = { count <<- count + 1; 675} ) expect_equal(count, 3L) res <- tibble(f = factor(levels = c("a", "b", "c"))) %>% group_by(f, .drop = FALSE) %>% mutate(x = { count <<- count + 1; 675} ) expect_equal(count, 4L) expect_is(res$x, "numeric") }) dplyr/tests/testthat/test-rank.R0000644000176200001440000000241413614573562016456 0ustar liggesuserscontext("rank") ntile_h <- function(x, n) { tibble(x = x) %>% mutate(y = ntile(x, n)) %>% pull(y) } ntile_h_dplyr <- function(x, n) { tibble(x = x) %>% mutate(y = dplyr::ntile(x, n)) %>% pull(y) } test_that("ntile ignores number of NAs", { x <- c(1:3, NA, NA, NA) expect_equal(ntile(x, 3), x) expect_equal(ntile_h(x, 3), x) x1 <- c(1L, 1L, 1L, NA, NA, NA) expect_equal(ntile(x, 1), x1) expect_equal(ntile_h(x, 1), x1) }) test_that("ntile always returns an integer", { expect_equal(ntile(numeric(), 3), integer()) expect_equal(ntile_h(numeric(), 3), integer()) expect_equal(ntile(NA, 3), NA_integer_) expect_equal(ntile_h(NA, 3), NA_integer_) }) test_that("ntile handles character vectors consistently", { charvec_sort_test <- function() { x1 <- c("[", "]", NA, "B", "y", "a", "Z") x2 <- c("a", "b", "C") expect_equal(ntile_h(x1, 3), ntile_h_dplyr(x1, 3)) expect_equal(ntile_h(x2, 2), ntile_h_dplyr(x2, 2)) } # Test against both the local, and the C locale for collation charvec_sort_test() withr::with_collate("C", charvec_sort_test()) }) test_that("ntile() does not overflow (#4186)", { res <- tibble(a = 1:1e5) %>% mutate(b = ntile(n = 1e5)) %>% count(b) %>% pull() expect_true(all(res == 1L)) }) dplyr/tests/testthat/test-lazyeval-compat.R0000644000176200001440000000242313614573562020633 0ustar liggesuserscontext("lazyeval compatibility") test_that("can select negatively (#2519)", { scoped_lifecycle_silence() expect_identical(select_(mtcars, ~ -cyl), mtcars[-2]) }) test_that("select yields proper names", { scoped_lifecycle_silence() expect_identical(names(select_(mtcars, ~ cyl:hp)), c("cyl", "disp", "hp")) }) test_that("lazydots are named and arrange() doesn't fail (it assumes empty names)", { scoped_lifecycle_silence() dots <- compat_lazy_dots(list(), env(), "cyl") expect_identical(names(dots), "") expect_identical(arrange_(mtcars, "cyl"), arrange(mtcars, cyl)) }) test_that("mutate_each_() and summarise_each_() handle lazydots", { scoped_lifecycle_silence() cyl_chr <- mutate_each_(mtcars, funs(as.character), "cyl")$cyl expect_identical(cyl_chr, as.character(mtcars$cyl)) cyl_chr <- mutate_each_(mtcars, list(as.character), "cyl")$cyl expect_identical(cyl_chr, as.character(mtcars$cyl)) cyl_mean <- summarise_each_(mtcars, funs(mean), "cyl")$cyl expect_equal(cyl_mean, mean(mtcars$cyl)) cyl_mean <- summarise_each_(mtcars, list(mean), "cyl")$cyl expect_equal(cyl_mean, mean(mtcars$cyl)) }) test_that("select_vars_() handles lazydots", { scoped_lifecycle_silence() expect_identical(select_vars_(letters, c("a", "b")), set_names(c("a", "b"))) }) dplyr/tests/testthat/test-colwise-group-by.R0000644000176200001440000000207113451046652020723 0ustar liggesuserscontext("colwise group_by") test_that("group_by_ verbs take scoped inputs", { expect_identical(group_vars(group_by_all(mtcars)), names(mtcars)) expect_identical(group_vars(group_by_at(mtcars, vars(starts_with("d")))), c("disp", "drat")) expect_identical(group_vars(group_by_if(iris, is.factor)), "Species") }) test_that("group_by_ verbs accept optional operations", { df <- tibble(x = 1:2, y = 2:3) gdf <- group_by(mutate_all(df, as.factor), x, y) expect_identical(group_by_all(df, as.factor), gdf) expect_identical(group_by_if(df, is_integer, as.factor), gdf) expect_identical(group_by_at(df, vars(x:y), as.factor), gdf) }) test_that("group_by variants can group by an already grouped by data (#3351)", { tbl <- tibble(gr1 = rep(1:2, 4), gr2 = rep(c(1, 2), each = 4), x = 1:8) %>% group_by(gr1) expect_identical( group_by_at(tbl, vars(gr1, gr2)), group_by(tbl, gr1, gr2) ) expect_identical( group_by_all(tbl), group_by(tbl, gr1, gr2, x) ) expect_identical( group_by_if(tbl, is.integer), group_by(tbl, gr1, x) ) }) dplyr/tests/testthat/test-DBI.R0000644000176200001440000000054713614573562016126 0ustar liggesuserscontext("DBI") test_that("can work directly with DBI connection", { skip_if_not_installed("RSQLite") skip_if_not_installed("dbplyr") con <- DBI::dbConnect(RSQLite::SQLite(), ":memory:") df <- tibble(x = 1:10, y = letters[1:10]) df1 <- copy_to(con, df) df2 <- tbl(con, "df") expect_equal(collect(df1), df) expect_equal(collect(df2), df) }) dplyr/tests/testthat/test-colwise-select.R0000644000176200001440000001277513614573562020460 0ustar liggesuserscontext("colwise select") df <- tibble(x = 0L, y = 0.5, z = 1) test_that("can select/rename all variables", { expect_identical(select_all(df), df) expect_error( rename_all(df), "`.funs` must specify a renaming function", fixed = TRUE ) expect_identical(select_all(df, toupper), set_names(df, c("X", "Y", "Z"))) expect_identical(select_all(df, toupper), rename_all(df, toupper)) }) test_that("can select/rename with predicate", { expect_identical(select_if(df, is_integerish), select(df, x, z)) expect_error( rename_if(df, is_integerish), "`.funs` must specify a renaming function", fixed = TRUE ) expect_identical(select_if(df, is_integerish, toupper), set_names(df[c("x", "z")], c("X", "Z"))) expect_identical(rename_if(df, is_integerish, toupper), set_names(df, c("X", "y", "Z"))) }) test_that("can supply funs()", { scoped_lifecycle_silence() expect_identical(select_if(df, funs(is_integerish(.)), funs(toupper(.))), set_names(df[c("x", "z")], c("X", "Z"))) expect_identical(rename_if(df, funs(is_integerish(.)), funs(toupper(.))), set_names(df, c("X", "y", "Z"))) expect_identical(select_if(df, list(~is_integerish(.)), list(~toupper(.))), set_names(df[c("x", "z")], c("X", "Z"))) expect_identical(rename_if(df, list(~is_integerish(.)), list(~toupper(.))), set_names(df, c("X", "y", "Z"))) }) test_that("fails when more than one renaming function is supplied", { scoped_lifecycle_silence() expect_error( select_all(df, funs(tolower, toupper)), "`.funs` must contain one renaming function, not 2", fixed = TRUE ) expect_error( rename_all(df, funs(tolower, toupper)), "`.funs` must contain one renaming function, not 2", fixed = TRUE ) expect_error( select_all(df, list(tolower, toupper)), "`.funs` must contain one renaming function, not 2", fixed = TRUE ) expect_error( rename_all(df, list(tolower, toupper)), "`.funs` must contain one renaming function, not 2", fixed = TRUE ) }) test_that("can select/rename with vars()", { expect_identical(select_at(df, vars(x:y)), df[-3]) expect_error( rename_at(df, vars(x:y)), "`.funs` must specify a renaming function", fixed = TRUE ) expect_identical(select_at(df, vars(x:y), toupper), set_names(df[-3], c("X", "Y"))) expect_identical(rename_at(df, vars(x:y), toupper), set_names(df, c("X", "Y", "z"))) }) test_that("select variants can use grouping variables (#3351, #3480)", { tbl <- tibble(gr1 = rep(1:2, 4), gr2 = rep(1:2, each = 4), x = 1:8) %>% group_by(gr1) expect_identical( select(tbl, gr1), select_at(tbl, vars(gr1)) ) expect_identical( select_all(tbl), tbl ) expect_identical( select_if(tbl, is.integer), tbl ) }) test_that("select_if keeps grouping cols", { expect_silent(df <- iris %>% group_by(Species) %>% select_if(is.numeric)) expect_equal(df, tbl_df(iris[c(5, 1:4)])) }) test_that("select_if() handles non-syntactic colnames", { df <- tibble(`x 1` = 1:3) expect_identical(select_if(df, is_integer)[[1]], 1:3) }) test_that("select_if() handles quoted predicates", { expected <- select_if(mtcars, is_integerish) expect_identical(select_if(mtcars, "is_integerish"), expected) expect_identical(select_if(mtcars, ~ is_integerish(.x)), expected) }) test_that("rename_all() works with grouped data (#3363)", { df <- data.frame(a = 1, b = 2) out <- df %>% group_by(a) %>% rename_all(toupper) expect_identical(out, group_by(data.frame(A = 1, B = 2), A)) }) test_that("scoping (#3426)", { interface <- function(.tbl, .funs = list()) { impl(.tbl, .funs = .funs) } impl <- function(.tbl, ...) { select_all(.tbl, ...) } expect_identical( interface(mtcars, .funs = toupper), select_all(mtcars, .funs = list(toupper)) ) }) test_that("rename variants can rename a grouping variable (#3351)", { tbl <- tibble(gr1 = rep(1:2, 4), gr2 = rep(1:2, each = 4), x = 1:8) %>% group_by(gr1) res <- rename(tbl, GR1 = gr1, GR2 = gr2, X = x) expect_identical( rename_at(tbl, vars(everything()), toupper), res ) expect_identical( rename_all(tbl, toupper), res ) expect_identical( rename_if(tbl, is.integer, toupper), res ) }) test_that("select_all does not change the order of columns (#3351)", { tbl <- group_by(tibble(x = 1:4, y = 1:4), y) expect_identical(select_all(tbl), tbl) tbl <- group_by(tibble(x = 1:4, y = 1:4), x) expect_identical(select_all(tbl), tbl) tbl <- group_by(tibble(x = 1:4, y = 1:4, z = 1:4), y) expect_identical(select_all(tbl), tbl) }) test_that("mutate_all does not change the order of columns (#3351)", { tbl <- group_by(tibble(x = 1:4, y = 1:4), y) expect_message(expect_identical(names(mutate_all(tbl, identity)), names(tbl)), "ignored") tbl <- group_by(tibble(x = 1:4, y = 1:4), x) expect_message(expect_identical(names(mutate_all(tbl, identity)), names(tbl)), "ignored") tbl <- group_by(tibble(x = 1:4, y = 1:4, z = 1:4), y) expect_message(expect_identical(names(mutate_all(tbl, identity)), names(tbl)), "ignored") }) test_that("select_if() and rename_if() handles logical (#4213)", { ids <- "Sepal.Length" expect_identical( iris %>% select_if(!names(.) %in% ids), iris %>% select(-Sepal.Length) ) expect_identical( iris %>% rename_if(!names(.) %in% ids, toupper), iris %>% rename_at(setdiff(names(.), "Sepal.Length"), toupper) ) }) test_that("rename_at() handles empty selection (#4324)", { expect_identical( mtcars %>% rename_at(vars(contains("fake_col")),~paste0("NewCol.",.)), mtcars ) }) dplyr/tests/testthat/test-group_trim.R0000644000176200001440000000122413451046652017702 0ustar liggesuserscontext("test-group_trim") test_that("group_trim() is identity on non grouped data", { expect_identical(group_trim(iris), iris) }) test_that("group_trim() always regroups even if no factors", { res <- mtcars %>% group_by(cyl) %>% filter(cyl == 6, .preserve = TRUE) %>% group_trim() expect_equal(n_groups(res), 1L) }) test_that("group_trim() drops factor levels in data and grouping structure", { res <- iris %>% group_by(Species) %>% filter(Species == "setosa") %>% group_trim() expect_equal(n_groups(res), 1L) expect_equal(levels(res$Species), "setosa") expect_equal(levels(attr(res, "groups")$Species), "setosa") }) dplyr/tests/testthat/test-hybrid.R0000644000176200001440000006206313614573562017012 0ustar liggesuserscontext("hybrid") test_that("hybrid evaluation environment is cleaned up (#2358)", { get_data_mask_active_env <- function(e){ env_parent(env_parent(e)) } # Can't use pipe here, f and g should have top-level parent.env() df <- tibble(a = 1) %>% group_by(a) df <- mutate(df, f = { a list(function() {}) }) df <- mutate(df, g = { f list(quo(.)) }) df <- mutate(df, h = { g list(~ .) }) df <- mutate(df, i = { h list(.data) }) expect_warning( expect_null(get_data_mask_active_env(environment(df$f[[1]]))[["a"]]), "Hybrid callback proxy out of scope", fixed = TRUE ) expect_warning( expect_null(get_data_mask_active_env(environment(df$g[[1]]))[["g"]]), "Hybrid callback proxy out of scope", fixed = TRUE ) expect_warning( expect_null(get_data_mask_active_env(environment(df$h[[1]]))[["g"]]), "Hybrid callback proxy out of scope", fixed = TRUE ) expect_warning( expect_null(df$i[[1]][["h"]]), "Hybrid callback proxy out of scope", fixed = TRUE ) }) test_that("n() and n_distinct() use hybrid evaluation", { d <- tibble(a = 1:5) expect_hybrid(d, n()) expect_hybrid(d, dplyr::n()) expect_hybrid(d, (!!n)()) expect_not_hybrid(d, list(1:n())) expect_not_hybrid(d, n() + 1) c <- 1:5 expect_hybrid(d, n_distinct(a)) expect_hybrid(d, n_distinct(a, na.rm = TRUE)) expect_hybrid(d, n_distinct(a, na.rm = FALSE)) expect_hybrid(d, dplyr::n_distinct(a)) expect_hybrid(d, dplyr::n_distinct(a, na.rm = TRUE)) expect_hybrid(d, dplyr::n_distinct(a, na.rm = FALSE)) expect_hybrid(d, (!!n_distinct)(a)) expect_hybrid(d, (!!n_distinct)(a, na.rm = TRUE)) expect_hybrid(d, (!!n_distinct)(a, na.rm = FALSE)) expect_not_hybrid(d, n_distinct(c)) expect_not_hybrid(d, n_distinct(a, c)) d <- tibble(a = rep(1L, 3), b = 1:3) expect_hybrid(d, n_distinct(a, b)) expect_hybrid(d, n_distinct(a, b, na.rm = TRUE)) expect_hybrid(d, n_distinct(a, b, na.rm = FALSE)) expect_hybrid(d, dplyr::n_distinct(a, b)) expect_hybrid(d, dplyr::n_distinct(a, b, na.rm = TRUE)) expect_hybrid(d, dplyr::n_distinct(a, b, na.rm = FALSE)) expect_hybrid(d, (!!n_distinct)(a, b)) expect_hybrid(d, (!!n_distinct)(a, b, na.rm = TRUE)) expect_hybrid(d, (!!n_distinct)(a, b, na.rm = FALSE)) expect_not_hybrid(d, n_distinct()) }) test_that(" %in% is hybrid", { d <- tibble(a = rep(1L, 3), b = 1:3) expect_hybrid(d, a %in% b) expect_hybrid(d, (!!`%in%`)(a, b)) expect_not_hybrid(d, a %in% b[1]) expect_not_hybrid(d, a[1] %in% b) expect_not_hybrid(d, a %in% 1:3) }) test_that("min() and max() are hybrid", { d <- tibble(int = 1:2, dbl = c(1,2), chr = c("a", "b")) expect_hybrid(d, min(int)) expect_hybrid(d, min(dbl)) expect_hybrid(d, (!!min)(int)) expect_hybrid(d, (!!min)(dbl)) expect_hybrid(d, base::min(int)) expect_hybrid(d, base::min(dbl)) expect_not_hybrid(d, min(chr)) expect_hybrid(d, min(int, na.rm = TRUE)) expect_hybrid(d, min(dbl, na.rm = TRUE)) expect_hybrid(d, (!!min)(int, na.rm = TRUE)) expect_hybrid(d, (!!min)(dbl, na.rm = TRUE)) expect_hybrid(d, base::min(int, na.rm = TRUE)) expect_hybrid(d, base::min(dbl, na.rm = TRUE)) expect_not_hybrid(d, min(int, na.rm = pi == pi)) expect_not_hybrid(d, min(dbl, na.rm = pi == pi)) expect_not_hybrid(d, min(dbl, na.rm = F)) expect_not_hybrid(d, min(dbl, na.rm = T)) expect_not_hybrid(d, min(chr, na.rm = TRUE)) expect_hybrid(d, min(int, na.rm = FALSE)) expect_hybrid(d, min(dbl, na.rm = FALSE)) expect_hybrid(d, (!!min)(int, na.rm = FALSE)) expect_hybrid(d, (!!min)(dbl, na.rm = FALSE)) expect_hybrid(d, base::min(int, na.rm = FALSE)) expect_hybrid(d, base::min(dbl, na.rm = FALSE)) expect_not_hybrid(d, min(chr, na.rm = FALSE)) expect_hybrid(d, max(int)) expect_hybrid(d, max(dbl)) expect_hybrid(d, (!!max)(int)) expect_hybrid(d, (!!max)(dbl)) expect_hybrid(d, base::max(int)) expect_hybrid(d, base::max(dbl)) expect_not_hybrid(d, max(chr)) expect_hybrid(d, max(int, na.rm = TRUE)) expect_hybrid(d, max(dbl, na.rm = TRUE)) expect_hybrid(d, (!!max)(int, na.rm = TRUE)) expect_hybrid(d, (!!max)(dbl, na.rm = TRUE)) expect_hybrid(d, base::max(int, na.rm = TRUE)) expect_hybrid(d, base::max(dbl, na.rm = TRUE)) expect_not_hybrid(d, max(int, na.rm = pi == pi)) expect_not_hybrid(d, max(dbl, na.rm = pi == pi)) expect_not_hybrid(d, max(dbl, na.rm = F)) expect_not_hybrid(d, max(dbl, na.rm = T)) expect_not_hybrid(d, max(chr, na.rm = TRUE)) expect_hybrid(d, max(int, na.rm = FALSE)) expect_hybrid(d, max(dbl, na.rm = FALSE)) expect_hybrid(d, (!!max)(int, na.rm = FALSE)) expect_hybrid(d, (!!max)(dbl, na.rm = FALSE)) expect_hybrid(d, base::max(int, na.rm = FALSE)) expect_hybrid(d, base::max(dbl, na.rm = FALSE)) expect_not_hybrid(d, max(chr, na.rm = FALSE)) }) test_that("first() and last() are hybrid", { d <- tibble(int = 1:2, dbl = c(1,2), chr = c("a", "b")) expect_hybrid(d, first(int)) expect_hybrid(d, first(dbl)) expect_hybrid(d, first(chr)) expect_hybrid(d, (!!first)(int)) expect_hybrid(d, (!!first)(dbl)) expect_hybrid(d, (!!first)(chr)) expect_hybrid(d, dplyr::first(int)) expect_hybrid(d, dplyr::first(dbl)) expect_hybrid(d, dplyr::first(chr)) expect_hybrid(d, first(int, default = 1L)) expect_hybrid(d, first(dbl, default = 2)) expect_hybrid(d, first(chr, default = "")) expect_hybrid(d, (!!first)(int, default = 1L)) expect_hybrid(d, (!!first)(dbl, default = 2)) expect_hybrid(d, (!!first)(chr, default = "")) expect_hybrid(d, dplyr::first(int, default = 1L)) expect_hybrid(d, dplyr::first(dbl, default = 2)) expect_hybrid(d, dplyr::first(chr, default = "")) expect_hybrid(d, last(int)) expect_hybrid(d, last(dbl)) expect_hybrid(d, last(chr)) expect_hybrid(d, (!!last)(int)) expect_hybrid(d, (!!last)(dbl)) expect_hybrid(d, (!!last)(chr)) expect_hybrid(d, dplyr::last(int)) expect_hybrid(d, dplyr::last(dbl)) expect_hybrid(d, dplyr::last(chr)) expect_hybrid(d, last(int, default = 1L)) expect_hybrid(d, last(dbl, default = 2)) expect_hybrid(d, last(chr, default = "")) expect_hybrid(d, (!!first)(int, default = 1L)) expect_hybrid(d, (!!first)(dbl, default = 2)) expect_hybrid(d, (!!first)(chr, default = "")) expect_hybrid(d, dplyr::last(int, default = 1L)) expect_hybrid(d, dplyr::last(dbl, default = 2)) expect_hybrid(d, dplyr::last(chr, default = "")) expect_not_hybrid(d, int %>% first()) expect_not_hybrid(d, int %>% last()) }) test_that("nth(, n = ) is hybrid", { d <- tibble(int = 1:2, dbl = c(1,2), chr = c("a", "b")) expect_hybrid(d, nth(int, n = 1)) expect_hybrid(d, nth(int, n = 1L)) expect_hybrid(d, nth(int, n = -1)) expect_hybrid(d, nth(int, n = -1L)) expect_hybrid(d, (!!nth)(int, n = 1)) expect_hybrid(d, (!!nth)(int, n = 1L)) expect_hybrid(d, (!!nth)(int, n = -1)) expect_hybrid(d, (!!nth)(int, n = -1L)) expect_not_hybrid(d, nth(dbl, n = 2^40)) expect_not_hybrid(d, nth(int, n = NA)) expect_hybrid(d, dplyr::nth(int, n = 1)) expect_hybrid(d, dplyr::nth(int, n = 1L)) expect_hybrid(d, dplyr::nth(int, n = -1)) expect_hybrid(d, dplyr::nth(int, n = -1L)) expect_not_hybrid(d, dplyr::nth(int, n = NA)) expect_hybrid(d, nth(dbl, n = 1)) expect_hybrid(d, nth(dbl, n = 1L)) expect_hybrid(d, nth(dbl, n = -1)) expect_hybrid(d, nth(dbl, n = -1L)) expect_hybrid(d, (!!nth)(dbl, n = 1)) expect_hybrid(d, (!!nth)(dbl, n = 1L)) expect_hybrid(d, (!!nth)(dbl, n = -1)) expect_hybrid(d, (!!nth)(dbl, n = -1L)) expect_not_hybrid(d, nth(dbl, n = NA)) expect_hybrid(d, dplyr::nth(dbl, n = 1)) expect_hybrid(d, dplyr::nth(dbl, n = 1L)) expect_hybrid(d, dplyr::nth(dbl, n = -1)) expect_hybrid(d, dplyr::nth(dbl, n = -1L)) expect_not_hybrid(d, dplyr::nth(dbl, n = NA)) expect_hybrid(d, nth(chr, n = 1)) expect_hybrid(d, nth(chr, n = 1L)) expect_hybrid(d, nth(chr, n = -1)) expect_hybrid(d, nth(chr, n = -1L)) expect_hybrid(d, (!!nth)(chr, n = 1)) expect_hybrid(d, (!!nth)(chr, n = 1L)) expect_hybrid(d, (!!nth)(chr, n = -1)) expect_hybrid(d, (!!nth)(chr, n = -1L)) expect_not_hybrid(d, nth(chr, n = NA)) expect_hybrid(d, dplyr::nth(chr, n = 1)) expect_hybrid(d, dplyr::nth(chr, n = 1L)) expect_hybrid(d, dplyr::nth(chr, n = -1)) expect_hybrid(d, dplyr::nth(chr, n = -1L)) expect_not_hybrid(d, nth(chr, n = NA)) }) test_that("hybrid nth() handles negative n (#3821)", { d <- tibble(int = 1:2, dbl = c(1,2), chr = c("a", "b")) res <- summarise(d, int = nth(int, -1), dbl = nth(dbl, -1), chr = nth(chr, -1) ) expect_equal(res, summarise_all(d, nth, 2)) }) test_that("nth(, n = , default = ) is hybrid", { d <- tibble(int = 1:2, dbl = c(1,2), chr = c("a", "b")) expect_hybrid(d, nth(int, n = 1, default = 1L)) expect_hybrid(d, nth(int, n = 1L, default = 1L)) expect_hybrid(d, nth(int, n = -1, default = 1L)) expect_hybrid(d, nth(int, n = -1L, default = 1L)) expect_hybrid(d, (!!nth)(int, n = 1, default = 1L)) expect_hybrid(d, (!!nth)(int, n = 1L, default = 1L)) expect_hybrid(d, (!!nth)(int, n = -1, default = 1L)) expect_hybrid(d, (!!nth)(int, n = -1L, default = 1L)) expect_hybrid(d, dplyr::nth(int, n = 1, default = 1L)) expect_hybrid(d, dplyr::nth(int, n = 1L, default = 1L)) expect_hybrid(d, dplyr::nth(int, n = -1, default = 1L)) expect_hybrid(d, dplyr::nth(int, n = -1L, default = 1L)) expect_hybrid(d, nth(dbl, n = 1, default = 1)) expect_hybrid(d, nth(dbl, n = 1L, default = 1)) expect_hybrid(d, nth(dbl, n = -1, default = 1)) expect_hybrid(d, nth(dbl, n = -1L, default = 1)) expect_hybrid(d, (!!nth)(dbl, n = 1, default = 1)) expect_hybrid(d, (!!nth)(dbl, n = 1L, default = 1)) expect_hybrid(d, (!!nth)(dbl, n = -1, default = 1)) expect_hybrid(d, (!!nth)(dbl, n = -1L, default = 1)) expect_hybrid(d, dplyr::nth(dbl, n = 1, default = 1)) expect_hybrid(d, dplyr::nth(dbl, n = 1L, default = 1)) expect_hybrid(d, dplyr::nth(dbl, n = -1, default = 1)) expect_hybrid(d, dplyr::nth(dbl, n = -1L, default = 1)) expect_hybrid(d, nth(chr, n = 1, default = "")) expect_hybrid(d, nth(chr, n = 1L, default = "")) expect_hybrid(d, nth(chr, n = -1, default = "")) expect_hybrid(d, nth(chr, n = -1L, default = "")) expect_hybrid(d, (!!nth)(chr, n = 1, default = "")) expect_hybrid(d, (!!nth)(chr, n = 1L, default = "")) expect_hybrid(d, (!!nth)(chr, n = -1, default = "")) expect_hybrid(d, (!!nth)(chr, n = -1L, default = "")) expect_hybrid(d, dplyr::nth(chr, n = 1, default = "")) expect_hybrid(d, dplyr::nth(chr, n = 1L, default = "")) expect_hybrid(d, dplyr::nth(chr, n = -1, default = "")) expect_hybrid(d, dplyr::nth(chr, n = -1L, default = "")) }) test_that("Expression folds unary minus when looking for constant ints", { b <- -3L data <- tibble(a = 1:5) expect_hybrid(data, nth(a, n = -3L)) expect_hybrid(data, nth(a, n = b)) expect_hybrid(data, nth(a, n = -b)) expect_hybrid(data, nth(a, n = !!b)) }) test_that("lead() and lag() are hybrid", { d <- tibble(int = 1:2, dbl = c(1,2), chr = c("a", "b")) expect_hybrid(d, lead(int)) expect_hybrid(d, lead(dbl)) expect_hybrid(d, lead(chr)) expect_hybrid(d, (!!lead)(int)) expect_hybrid(d, (!!lead)(dbl)) expect_hybrid(d, (!!lead)(chr)) expect_hybrid(d, dplyr::lead(int)) expect_hybrid(d, dplyr::lead(dbl)) expect_hybrid(d, dplyr::lead(chr)) expect_hybrid(d, lead(int, n = 1)) expect_hybrid(d, lead(dbl, n = 1)) expect_hybrid(d, lead(chr, n = 1)) expect_hybrid(d, (!!lead)(int, n = 1)) expect_hybrid(d, (!!lead)(dbl, n = 1)) expect_hybrid(d, (!!lead)(chr, n = 1)) expect_hybrid(d, dplyr::lead(int, n = 1)) expect_hybrid(d, dplyr::lead(dbl, n = 1)) expect_hybrid(d, dplyr::lead(chr, n = 1)) expect_hybrid(d, lead(int, n = 1L)) expect_hybrid(d, lead(dbl, n = 1L)) expect_hybrid(d, lead(chr, n = 1L)) expect_hybrid(d, (!!lead)(int, n = 1L)) expect_hybrid(d, (!!lead)(dbl, n = 1L)) expect_hybrid(d, (!!lead)(chr, n = 1L)) expect_hybrid(d, dplyr::lead(int, n = 1L)) expect_hybrid(d, dplyr::lead(dbl, n = 1L)) expect_hybrid(d, dplyr::lead(chr, n = 1L)) }) test_that("lead() and lag() are not hybrid with negative `n`", { d <- tibble(int = 1:2) minus1 <- -1L expect_not_hybrid(d, lead(int, !!minus1)) expect_not_hybrid(d, lag(int, !!minus1)) }) test_that("lead() and lag() are echo with n == 0", { d <- tibble(int = 1:2) expect_equal(attr(hybrid_call(d, lead(int, n = 0L)), "cpp_class"), "echo") expect_equal(attr(hybrid_call(d, lag(int, n = 0L)), "cpp_class"), "echo") }) test_that("sum is hybrid", { d <- tibble(lgl = c(TRUE, FALSE), int = 1:2, dbl = c(1,2), chr = c("a", "b")) expect_hybrid(d, sum(lgl)) expect_hybrid(d, sum(int)) expect_hybrid(d, sum(dbl)) expect_hybrid(d, (!!sum)(lgl)) expect_hybrid(d, (!!sum)(int)) expect_hybrid(d, (!!sum)(dbl)) expect_hybrid(d, base::sum(lgl)) expect_hybrid(d, base::sum(int)) expect_hybrid(d, base::sum(dbl)) expect_not_hybrid(d, sum(chr)) expect_hybrid(d, sum(lgl, na.rm = TRUE)) expect_hybrid(d, sum(int, na.rm = TRUE)) expect_hybrid(d, sum(dbl, na.rm = TRUE)) expect_hybrid(d, (!!sum)(lgl, na.rm = TRUE)) expect_hybrid(d, (!!sum)(int, na.rm = TRUE)) expect_hybrid(d, (!!sum)(dbl, na.rm = TRUE)) expect_hybrid(d, base::sum(lgl, na.rm = TRUE)) expect_hybrid(d, base::sum(int, na.rm = TRUE)) expect_hybrid(d, base::sum(dbl, na.rm = TRUE)) expect_not_hybrid(d, sum(chr, na.rm = TRUE)) expect_hybrid(d, sum(lgl, na.rm = FALSE)) expect_hybrid(d, sum(int, na.rm = FALSE)) expect_hybrid(d, sum(dbl, na.rm = FALSE)) expect_hybrid(d, (!!sum)(lgl, na.rm = FALSE)) expect_hybrid(d, (!!sum)(int, na.rm = FALSE)) expect_hybrid(d, (!!sum)(dbl, na.rm = FALSE)) expect_hybrid(d, base::sum(lgl, na.rm = FALSE)) expect_hybrid(d, base::sum(int, na.rm = FALSE)) expect_hybrid(d, base::sum(dbl, na.rm = FALSE)) expect_not_hybrid(d, sum(chr, na.rm = FALSE)) }) test_that("mean is hybrid", { d <- tibble(lgl = c(TRUE, FALSE), int = 1:2, dbl = c(1,2), chr = c("a", "b")) expect_hybrid(d, mean(lgl)) expect_hybrid(d, mean(int)) expect_hybrid(d, mean(dbl)) expect_hybrid(d, (!!mean)(lgl)) expect_hybrid(d, (!!mean)(int)) expect_hybrid(d, (!!mean)(dbl)) expect_hybrid(d, base::mean(lgl)) expect_hybrid(d, base::mean(int)) expect_hybrid(d, base::mean(dbl)) expect_not_hybrid(d, mean(chr)) expect_hybrid(d, mean(lgl, na.rm = TRUE)) expect_hybrid(d, mean(int, na.rm = TRUE)) expect_hybrid(d, mean(dbl, na.rm = TRUE)) expect_hybrid(d, (!!mean)(lgl, na.rm = TRUE)) expect_hybrid(d, (!!mean)(int, na.rm = TRUE)) expect_hybrid(d, (!!mean)(dbl, na.rm = TRUE)) expect_hybrid(d, base::mean(lgl, na.rm = TRUE)) expect_hybrid(d, base::mean(int, na.rm = TRUE)) expect_hybrid(d, base::mean(dbl, na.rm = TRUE)) expect_not_hybrid(d, mean(chr, na.rm = TRUE)) expect_hybrid(d, mean(lgl, na.rm = FALSE)) expect_hybrid(d, mean(int, na.rm = FALSE)) expect_hybrid(d, mean(dbl, na.rm = FALSE)) expect_hybrid(d, (!!mean)(lgl, na.rm = FALSE)) expect_hybrid(d, (!!mean)(int, na.rm = FALSE)) expect_hybrid(d, (!!mean)(dbl, na.rm = FALSE)) expect_hybrid(d, base::mean(lgl, na.rm = FALSE)) expect_hybrid(d, base::mean(int, na.rm = FALSE)) expect_hybrid(d, base::mean(dbl, na.rm = FALSE)) expect_not_hybrid(d, mean(chr, na.rm = FALSE)) }) test_that("sd is hybrid", { d <- tibble(lgl = c(TRUE, FALSE), int = 1:2, dbl = c(1,2), chr = c("a", "b")) expect_hybrid(d, sd(lgl)) expect_hybrid(d, sd(int)) expect_hybrid(d, sd(dbl)) expect_hybrid(d, (!!sd)(lgl)) expect_hybrid(d, (!!sd)(int)) expect_hybrid(d, (!!sd)(dbl)) expect_hybrid(d, stats::sd(lgl)) expect_hybrid(d, stats::sd(int)) expect_hybrid(d, stats::sd(dbl)) expect_not_hybrid(d, sd(chr)) expect_hybrid(d, sd(lgl, na.rm = TRUE)) expect_hybrid(d, sd(int, na.rm = TRUE)) expect_hybrid(d, sd(dbl, na.rm = TRUE)) expect_hybrid(d, (!!sd)(lgl, na.rm = TRUE)) expect_hybrid(d, (!!sd)(int, na.rm = TRUE)) expect_hybrid(d, (!!sd)(dbl, na.rm = TRUE)) expect_hybrid(d, stats::sd(lgl, na.rm = TRUE)) expect_hybrid(d, stats::sd(int, na.rm = TRUE)) expect_hybrid(d, stats::sd(dbl, na.rm = TRUE)) expect_not_hybrid(d, sd(chr, na.rm = TRUE)) expect_hybrid(d, sd(lgl, na.rm = FALSE)) expect_hybrid(d, sd(int, na.rm = FALSE)) expect_hybrid(d, sd(dbl, na.rm = FALSE)) expect_hybrid(d, (!!sd)(lgl, na.rm = FALSE)) expect_hybrid(d, (!!sd)(int, na.rm = FALSE)) expect_hybrid(d, (!!sd)(dbl, na.rm = FALSE)) expect_hybrid(d, stats::sd(lgl, na.rm = FALSE)) expect_hybrid(d, stats::sd(int, na.rm = FALSE)) expect_hybrid(d, stats::sd(dbl, na.rm = FALSE)) expect_not_hybrid(d, sd(chr, na.rm = FALSE)) }) test_that("var is hybrid", { d <- tibble(lgl = c(TRUE, FALSE), int = 1:2, dbl = c(1,2), chr = c("a", "b")) expect_hybrid(d, var(lgl)) expect_hybrid(d, var(int)) expect_hybrid(d, var(dbl)) expect_hybrid(d, (!!var)(lgl)) expect_hybrid(d, (!!var)(int)) expect_hybrid(d, (!!var)(dbl)) expect_hybrid(d, stats::var(lgl)) expect_hybrid(d, stats::var(int)) expect_hybrid(d, stats::var(dbl)) expect_not_hybrid(d, var(chr)) expect_hybrid(d, var(lgl, na.rm = TRUE)) expect_hybrid(d, var(int, na.rm = TRUE)) expect_hybrid(d, var(dbl, na.rm = TRUE)) expect_hybrid(d, (!!var)(lgl, na.rm = TRUE)) expect_hybrid(d, (!!var)(int, na.rm = TRUE)) expect_hybrid(d, (!!var)(dbl, na.rm = TRUE)) expect_hybrid(d, stats::var(lgl, na.rm = TRUE)) expect_hybrid(d, stats::var(int, na.rm = TRUE)) expect_hybrid(d, stats::var(dbl, na.rm = TRUE)) expect_not_hybrid(d, var(chr, na.rm = TRUE)) expect_hybrid(d, var(lgl, na.rm = FALSE)) expect_hybrid(d, var(int, na.rm = FALSE)) expect_hybrid(d, var(dbl, na.rm = FALSE)) expect_hybrid(d, (!!var)(lgl, na.rm = FALSE)) expect_hybrid(d, (!!var)(int, na.rm = FALSE)) expect_hybrid(d, (!!var)(dbl, na.rm = FALSE)) expect_hybrid(d, stats::var(lgl, na.rm = FALSE)) expect_hybrid(d, stats::var(int, na.rm = FALSE)) expect_hybrid(d, stats::var(dbl, na.rm = FALSE)) expect_not_hybrid(d, var(chr, na.rm = FALSE)) }) test_that("row_number() is hybrid", { d <- tibble(a = 1:5) expect_hybrid(d, row_number()) expect_hybrid(d, (!!row_number)()) expect_hybrid(d, dplyr::row_number()) }) test_that("ntile() is hybrid", { d <- tibble(int = 1:2, dbl = c(1,2)) expect_hybrid(d, ntile(n = 2L)) expect_hybrid(d, ntile(n = 2)) expect_hybrid(d, (!!ntile)(n = 2L)) expect_hybrid(d, (!!ntile)(n = 2)) expect_hybrid(d, dplyr::ntile(n = 2L)) expect_hybrid(d, dplyr::ntile(n = 2)) expect_not_hybrid(d, ntile(n = NA_integer_)) expect_not_hybrid(d, ntile(n = NA_real_)) expect_not_hybrid(d, ntile(n = NA)) expect_hybrid(d, ntile(int, n = 2L)) expect_hybrid(d, ntile(int, n = 2)) expect_hybrid(d, (!!ntile)(int, n = 2L)) expect_hybrid(d, (!!ntile)(int, n = 2)) expect_hybrid(d, dplyr::ntile(int, n = 2L)) expect_hybrid(d, dplyr::ntile(int, n = 2)) expect_not_hybrid(d, ntile(int, n = NA_integer_)) expect_not_hybrid(d, ntile(int, n = NA_real_)) expect_not_hybrid(d, ntile(int, n = NA)) expect_hybrid(d, ntile(dbl, n = 2L)) expect_hybrid(d, ntile(dbl, n = 2)) expect_hybrid(d, (!!ntile)(dbl, n = 2L)) expect_hybrid(d, (!!ntile)(dbl, n = 2)) expect_hybrid(d, dplyr::ntile(dbl, n = 2L)) expect_hybrid(d, dplyr::ntile(dbl, n = 2)) expect_not_hybrid(d, ntile(dbl, n = NA_integer_)) expect_not_hybrid(d, ntile(dbl, n = NA_real_)) expect_not_hybrid(d, ntile(dbl, n = NA)) }) test_that("min_rank(), percent_rank(), dense_rank(), cume_dist() are hybrid", { d <- tibble(int = 1:2, dbl = c(1,2)) expect_hybrid(d, min_rank(int)) expect_hybrid(d, min_rank(dbl)) expect_hybrid(d, (!!min_rank)(int)) expect_hybrid(d, (!!min_rank)(dbl)) expect_hybrid(d, dplyr::min_rank(int)) expect_hybrid(d, dplyr::min_rank(dbl)) expect_hybrid(d, percent_rank(int)) expect_hybrid(d, percent_rank(dbl)) expect_hybrid(d, (!!percent_rank)(int)) expect_hybrid(d, (!!percent_rank)(dbl)) expect_hybrid(d, dplyr::percent_rank(int)) expect_hybrid(d, dplyr::percent_rank(dbl)) expect_hybrid(d, dense_rank(int)) expect_hybrid(d, dense_rank(dbl)) expect_hybrid(d, (!!dense_rank)(int)) expect_hybrid(d, (!!dense_rank)(dbl)) expect_hybrid(d, dplyr::dense_rank(int)) expect_hybrid(d, dplyr::dense_rank(dbl)) expect_hybrid(d, cume_dist(int)) expect_hybrid(d, cume_dist(dbl)) expect_hybrid(d, (!!cume_dist)(int)) expect_hybrid(d, (!!cume_dist)(dbl)) expect_hybrid(d, dplyr::cume_dist(int)) expect_hybrid(d, dplyr::cume_dist(dbl)) }) test_that("hybrid handlers don't nest", { d <- tibble(a = 1:5) expect_not_hybrid(d, mean(lag(a))) expect_not_hybrid(d, mean(row_number())) expect_not_hybrid(d, list(lag(cume_dist(a)))) }) test_that("simple handlers supports quosured symbols", { expect_hybrid(mtcars, mean(!!quo(cyl))) expect_hybrid(mtcars, sum(!!quo(cyl))) expect_hybrid(mtcars, sd(!!quo(cyl))) expect_hybrid(mtcars, var(!!quo(cyl))) expect_hybrid(mtcars, min(!!quo(cyl))) expect_hybrid(mtcars, max(!!quo(cyl))) expect_hybrid(mtcars, lead(!!quo(cyl))) expect_hybrid(mtcars, lag(!!quo(cyl))) }) test_that("window handlers supports quosured symbols", { expect_hybrid(mtcars, ntile(!!quo(disp), n = 2)) expect_hybrid(mtcars, min_rank(!!quo(disp))) expect_hybrid(mtcars, percent_rank(!!quo(disp))) expect_hybrid(mtcars, dense_rank(!!quo(disp))) expect_hybrid(mtcars, dense_rank(!!quo(disp))) }) test_that("n_distinct() handler supports quosured symbols", { expect_hybrid(mtcars, n_distinct(!!quo(cyl))) }) test_that("nth(), first() and last() support quosured symbols", { expect_hybrid(mtcars, first(!!quo(cyl))) expect_hybrid(mtcars, last(!!quo(cyl))) expect_hybrid(mtcars, nth(!!quo(cyl), n = 2)) expect_not_hybrid(mtcars, nth(!!quo(cyl), n = NA)) }) test_that("hybrid evaluation can be disabled locally (#3255)", { tbl <- data.frame(x = 1:10) first <- function(...) 42 expect_not_hybrid(tbl, first(x)) expect_hybrid(tbl, dplyr::first(x)) last <- function(...) 42 expect_not_hybrid(tbl, last(x)) expect_hybrid(tbl, dplyr::last(x)) nth <- function(...) 42 expect_not_hybrid(tbl, nth(x, n = 2L)) expect_hybrid(tbl, dplyr::nth(x, n = 2L)) mean <- function(...) 42 tbl <- data.frame(x = 1:10) expect_not_hybrid(tbl, mean(x)) expect_hybrid(tbl, base::mean(x)) var <- function(...) 42 expect_not_hybrid(tbl, var(x)) expect_hybrid(tbl, stats::var(x)) sd <- function(...) 42 expect_not_hybrid(tbl, sd(x)) expect_hybrid(tbl, stats::sd(x)) row_number <- function() 42 expect_not_hybrid(tbl, row_number(x)) expect_hybrid(tbl, dplyr::row_number(x)) ntile <- function(x, n) 42 expect_not_hybrid(tbl, ntile(x, n = 2)) expect_hybrid(tbl, dplyr::ntile(x, n = 2)) min_rank <- function(x) 42 expect_not_hybrid(tbl, min_rank(x)) expect_hybrid(tbl, dplyr::min_rank(x)) percent_rank <- function(x) 42 expect_not_hybrid(tbl, percent_rank(x)) expect_hybrid(tbl, dplyr::percent_rank(x)) dense_rank <- function(x) 42 expect_not_hybrid(tbl, dense_rank(x)) expect_hybrid(tbl, dplyr::dense_rank(x)) cume_dist <- function(x) 42 expect_not_hybrid(tbl, cume_dist(x)) expect_hybrid(tbl, dplyr::cume_dist(x)) lead <- function(x) 42 expect_not_hybrid(tbl, lead(x)) expect_hybrid(tbl, dplyr::lead(x)) lag <- function(x) 42 expect_not_hybrid(tbl, lag(x)) expect_hybrid(tbl, dplyr::lag(x)) `%in%` <- function(x, y) TRUE expect_not_hybrid(tbl, x %in% 3) min <- function(x) 42 expect_not_hybrid(tbl, min(x)) expect_hybrid(tbl, base::min(x)) max <- function(x) 42 expect_not_hybrid(tbl, max(x)) expect_hybrid(tbl, base::max(x)) n <- function() 42 expect_not_hybrid(tbl, n()) expect_hybrid(tbl, dplyr::n()) n_distinct <- function(...) 42 expect_not_hybrid(tbl, n_distinct(x)) expect_hybrid(tbl, dplyr::n_distinct(x)) }) test_that("verbs can nest with well defined behavior (#2080)", { df <- tibble(x = list( tibble(y = 1:2), tibble(y = 1:3), tibble(y = 1:4) )) nrows <- function(df) { df %>% summarise(n = n()) %>% .[["n"]] } nrows_magrittr_lambda <- . %>% summarise(n = n()) %>% .[["n"]] res <- mutate( df, n1 = x %>% map_int(nrows), n2 = x %>% map_int(. %>% summarise(n = n()) %>% .[["n"]]), n4 = map_int(x, function(df) summarise(df, n = n())[["n"]]), n5 = map_int(x, nrows_magrittr_lambda) ) expect_equal(res$n1, res$n2) expect_equal(res$n1, res$n4) expect_equal(res$n1, res$n5) }) test_that("hybrid first, last and nth operate within groups (#3868)", { first_ <- function(x) x[1] last_ <- function(x) tail(x, 1L) nth_ <- function(x, n) x[n] expect_identical( iris %>% group_by(Species) %>% summarise(Sepal.Length = first(Sepal.Length)), iris %>% group_by(Species) %>% summarise(Sepal.Length = first_(Sepal.Length)) ) expect_identical( iris %>% group_by(Species) %>% summarise(Sepal.Length = last(Sepal.Length)), iris %>% group_by(Species) %>% summarise(Sepal.Length = last_(Sepal.Length)) ) expect_identical( iris %>% group_by(Species) %>% summarise(Sepal.Length = nth(Sepal.Length, n = 2L)), iris %>% group_by(Species) %>% summarise(Sepal.Length = nth_(Sepal.Length, n = 2L)) ) }) test_that("hybrid resolves the symbol", { mean <- sum out <- summarise(data.frame(x = 1:10), mean(x)) expect_equal(out[[1]], sum(1:10)) call <- hybrid_call(data.frame(x = 1:10), mean(x)) expect_true(call) expect_equal(attr(call, "fun"), "sum") expect_equal(attr(call, "package"), "base") }) dplyr/tests/testthat/test-colwise.R0000644000176200001440000000241713614573562017173 0ustar liggesuserscontext("colwise utils") test_that("tbl_at_vars() errs on bad input", { expect_error( tbl_at_vars(iris, raw(3)), "`.vars` must be a character/numeric vector or a `vars()` object, not a raw vector", fixed = TRUE ) }) test_that("tbl_at_vars() treats `NULL` as empty inputs", { expect_identical(tbl_at_vars(mtcars, vars(NULL)), tbl_at_vars(mtcars, vars())) expect_identical( tibble::remove_rownames(mutate_at(mtcars, vars(NULL), `*`, 100)), tibble::remove_rownames(mtcars) ) }) test_that("tbl_if_vars() errs on bad input", { scoped_lifecycle_silence() expect_error( tbl_if_vars(iris, funs(identity, force), environment()), "`.predicate` must have length 1, not 2", fixed = TRUE ) .funs <- list(identity, force) .funs <- as_fun_list(.funs, caller_env()) expect_error( tbl_if_vars(iris, .funs, environment()), "`.predicate` must have length 1, not 2", fixed = TRUE ) }) test_that("lists of formulas are auto-named", { df <- tibble(x = 1:3, y = 4:6) out <- df %>% summarise_all(list(~ mean(.), ~sd(.x, na.rm = TRUE))) expect_named(out, c("x_mean", "y_mean", "x_sd", "y_sd")) out <- df %>% summarise_all(list(foobar = ~ mean(.), ~sd(.x, na.rm = TRUE))) expect_named(out, c("x_foobar", "y_foobar", "x_sd", "y_sd")) }) dplyr/tests/testthat/test-tbl.R0000644000176200001440000000101313614573562016276 0ustar liggesuserscontext("tbl") test_that("tbl_nongroup_vars() excludes group variables", { cube <- group_by(nasa, month) expect_identical(tbl_nongroup_vars(cube), setdiff(tbl_vars(cube), "month")) gdf <- group_by(mtcars, cyl) expect_identical(tbl_nongroup_vars(gdf), setdiff(tbl_vars(gdf), "cyl")) }) test_that("tbl_vars() records groups", { gdf <- group_by(mtcars, cyl, am) expect_is(tbl_vars(gdf), "dplyr_sel_vars") expect_true(is_sel_vars(tbl_vars(gdf))) expect_identical(tbl_vars(gdf) %@% groups, c("cyl", "am")) }) dplyr/tests/testthat/test-combine.R0000644000176200001440000001577313614573562017153 0ustar liggesuserscontext("combine") test_that("combine handles NULL (#1596, #3365)", { expect_equal(combine(list(NULL, 1, 2)), c(1, 2)) expect_equal(combine(list(1, NULL, 2)), c(1, 2)) expect_equal(combine(list(1, 2, NULL)), c(1, 2)) expect_equal(combine(), logical()) expect_equal(combine(list(NULL)), logical()) expect_equal(combine(list(NULL, NULL), list(NULL)), list(NULL, NULL, NULL)) expect_equal(combine(NULL, list(NULL, NULL)), list(NULL, NULL)) }) test_that("combine complains about incompatibilites", { expect_error( combine("a", 1), "Argument 2 can't be converted from numeric to character" ) expect_error( combine(factor("a"), 1L), "Argument 2 can't be converted from integer to factor" ) }) test_that("combine works with input that used to fail (#1780)", { no <- list(alpha = letters[1:3], omega = letters[24:26]) expect_equal(combine(no), unlist(no, use.names = FALSE)) }) test_that("combine works with NA and logical (#2203)", { # NA first expected_result <- c(NA, TRUE, FALSE, NA, TRUE) works1 <- combine(list(NA, TRUE, FALSE, NA, TRUE)) expect_equal(works1, expected_result) # NA length == 1 expected_result <- c(TRUE, FALSE, NA, TRUE) works1 <- combine(list(TRUE, FALSE, NA, TRUE)) expect_equal(works1, expected_result) # NA length > 1 expected_result <- c(TRUE, FALSE, NA, NA, TRUE) works3 <- combine(list(TRUE, FALSE, c(NA, NA), TRUE)) expect_equal(works3, expected_result) }) test_that("combine works with NA and integers (#2203)", { works <- combine(list(1L, 2L, NA, 4L)) expect_equal(works, c(1L, 2L, NA, 4L)) works <- combine(list(1L, 2L, c(NA, NA), 4L)) expect_equal(works, c(1L, 2L, NA, NA, 4L)) }) test_that("combine works with NA and factors (#2203)", { # NA first fac <- factor(c("a", "c", NA, "b"), levels = letters[1:3]) expected_result <- fac[c(3, 1, 3, 2)] works1 <- combine(list(NA, fac[1], NA, fac[2])) expect_equal(works1, expected_result) # NA length == 1 expected_result <- fac works1 <- combine(list(fac[1], fac[2], fac[3], fac[4])) expect_equal(works1, expected_result) works2 <- combine(list(fac[1], fac[2], NA, fac[4])) expect_equal(works2, expected_result) # NA length > 1 expected_result <- fac[c(1, 2, 3, 3, 4)] works3 <- combine(list(fac[1], fac[2], fac[c(3, 3)], fac[4])) expect_equal(works3, expected_result) works4 <- combine(list(fac[1], fac[2], c(NA, NA), fac[4])) expect_equal(works4, expected_result) }) test_that("combine works with NA and double (#2203)", { # NA first works <- combine(list(NA, 1.5, 2.5, NA, 4.5)) expect_equal(works, c(NA, 1.5, 2.5, NA, 4.5)) # NA length 1 works <- combine(list(1.5, 2.5, NA, 4.5)) expect_equal(works, c(1.5, 2.5, NA, 4.5)) # NA length > 1 works <- combine(list(1.5, 2.5, c(NA, NA), 4.5)) expect_equal(works, c(1.5, 2.5, NA, NA, 4.5)) }) test_that("combine works with NA and characters (#2203)", { # NA first works <- combine(list(NA, "a", "b", "c", NA, "e")) expect_equal(works, c(NA, "a", "b", "c", NA, "e")) # NA length 1 works <- combine(list("a", "b", "c", NA, "e")) expect_equal(works, c("a", "b", "c", NA, "e")) # NA length > 1 works <- combine(list("a", "b", "c", c(NA, NA), "e")) expect_equal(works, c("a", "b", "c", NA, NA, "e")) }) test_that("combine works with NA and POSIXct (#2203)", { # NA first works <- combine(list( NA, as.POSIXct("2010-01-01"), as.POSIXct("2010-01-02"), NA, as.POSIXct("2010-01-04") )) expect_equal(works, c(as.POSIXct(c( NA, "2010-01-01", "2010-01-02", NA, "2010-01-04" )))) # NA length 1 works <- combine(list( as.POSIXct("2010-01-01"), as.POSIXct("2010-01-02"), NA, as.POSIXct("2010-01-04") )) expect_equal(works, c(as.POSIXct(c( "2010-01-01", "2010-01-02", NA, "2010-01-04" )))) # NA length > 1 works <- combine(list( as.POSIXct("2010-01-01"), as.POSIXct("2010-01-02"), c(NA, NA), as.POSIXct("2010-01-04") )) expect_equal(works, c(as.POSIXct(c( "2010-01-01", "2010-01-02", NA, NA, "2010-01-04" )))) }) test_that("combine works with NA and Date (#2203)", { # NA first expected_result <- as.Date("2010-01-01") + c(NA, 1, 2, NA, 4) expect_equal(combine(as.list(expected_result)), expected_result) # NA length == 1 expected_result <- c(as.Date(c("2010-01-01", "2010-01-02", NA, "2010-01-04"))) works1 <- combine(list( as.Date("2010-01-01"), as.Date("2010-01-02"), as.Date(NA), as.Date("2010-01-04") )) expect_equal(works1, expected_result) works2 <- combine(list( as.Date("2010-01-01"), as.Date("2010-01-02"), NA, as.Date("2010-01-04") )) expect_equal(works2, expected_result) # NA length > 1 expected_result <- as.Date("2010-01-01") + c(0, 1, NA, NA, 3) works1 <- combine(split(expected_result, c(1, 2, 3, 3, 4))) expect_equal(works1, expected_result) works2 <- combine(list( as.Date("2010-01-01"), as.Date("2010-01-02"), c(NA, NA), as.Date("2010-01-04") )) expect_equal(works2, expected_result) }) test_that("combine works with NA and complex (#2203)", { # NA first expected_result <- c(NA, 1 + 2i) works1 <- combine(list(NA, 1 + 2i)) expect_equal(works1, expected_result) # NA length == 1 expected_result <- c(1, 2, NA, 4) + 1i expect_equal(combine(as.list(expected_result)), expected_result) works2 <- combine(list(1 + 1i, 2 + 1i, NA, 4 + 1i)) expect_equal(works2, expected_result) # NA length > 1 expected_result <- c(1, 2, NA, NA, 4) + 1i expect_equal( combine(split(expected_result, c(1, 2, 3, 3, 4))), expected_result ) works3 <- combine(list(1 + 1i, 2 + 1i, c(NA, NA), 4 + 1i)) expect_equal(works3, expected_result) }) test_that("combine works with integer64 (#1092)", { expect_equal( combine(bit64::as.integer64(2^34), bit64::as.integer64(2^35)), bit64::as.integer64(c(2^34, 2^35)) ) }) test_that("combine works with difftime", { expect_equal( combine(as.difftime(1, units = "mins"), as.difftime(1, units = "hours")), as.difftime(c(60, 3600), units = "secs") ) expect_equal( combine(as.difftime(1, units = "secs"), as.difftime(1, units = "secs")), as.difftime(c(1, 1), units = "secs") ) expect_equal( combine(as.difftime(1, units = "days"), as.difftime(1, units = "secs")), as.difftime(c(24 * 60 * 60, 1), units = "secs") ) expect_equal( combine(as.difftime(2, units = "weeks"), as.difftime(1, units = "secs")), as.difftime(c(2 * 7 * 24 * 60 * 60, 1), units = "secs") ) expect_equal( combine(as.difftime(2, units = "weeks"), as.difftime(3, units = "weeks")), as.difftime(c(2, 3), units = "weeks") ) }) test_that("combine works with hms and difftime", { expect_equal( combine(as.difftime(2, units = "weeks"), hms::hms(hours = 1)), as.difftime(c(2 * 7 * 24 * 60 * 60, 3600), units = "secs") ) expect_equal( combine(hms::hms(hours = 1), as.difftime(2, units = "weeks")), hms::hms(seconds = c(3600, 2 * 7 * 24 * 60 * 60)) ) }) test_that("combine uses tidy dots (#3407)", { chunks <- list(1,2,3) expect_equal(combine(!!!chunks), c(1,2,3)) }) # Uses helper-combine.R combine_coercion_types() dplyr/tests/testthat/helper-hybrid.R0000644000176200001440000000051613614573562017305 0ustar liggesusersexpect_hybrid <- function(data, expr, info = NULL, label = NULL) { expect_true(hybrid_impl(data, enquo(expr), rlang::caller_env()), info = info, label = label) } expect_not_hybrid <- function(data, expr, info = NULL, label = NULL) { expect_false(hybrid_impl(data, enquo(expr), rlang::caller_env()), info = info, label = label) } dplyr/tests/testthat/test-group-size.R0000644000176200001440000000113013614573562017621 0ustar liggesuserscontext("Group sizes") test_that("ungrouped data has 1 group, with group size = nrow()", { df <- tibble(x = rep(1:3, each = 10), y = rep(1:6, each = 5)) expect_equal(n_groups(df), 1L) expect_equal(group_size(df), 30) }) test_that("rowwise data has one group for each group", { rw <- rowwise(mtcars) expect_equal(n_groups(rw), 32) expect_equal(group_size(rw), rep(1, 32)) }) test_that("group_size correct for grouped data", { df <- tibble(x = rep(1:3, each = 10), y = rep(1:6, each = 5)) %>% group_by(x) expect_equal(n_groups(df), 3L) expect_equal(group_size(df), rep(10, 3)) }) dplyr/tests/testthat/test-active-bindings.R0000644000176200001440000000044413614573562020572 0ustar liggesuserscontext("test-active-bindings") test_that("Garbage collection keeps active bindings intact", { df <- tibble(a = 1:3, b = 3:1) res_df <- df %>% group_by(b) %>% mutate(c = { gc(); a }, d = { gc(); b }) %>% ungroup() expect_equal(df, res_df %>% select(a = c, b = d)) }) dplyr/tests/testthat/test-funs-predicates.R0000644000176200001440000000121213614573562020612 0ustar liggesuserscontext("funs-predicates") test_that("all_exprs() creates intersection", { expect_identical(all_exprs(am == 1), quo(am == 1)) quo <- set_env(quo((!!quo(cyl == 2)) & (!!quo(am == 1))), base_env()) expect_identical(all_exprs(cyl == 2, am == 1), quo) }) test_that("any_exprs() creates union", { expect_identical(any_exprs(am == 1), quo(am == 1)) quo <- set_env(quo((!!quo(cyl == 2)) | (!!quo(am == 1))), base_env()) expect_identical(any_exprs(cyl == 2, am == 1), quo) }) test_that("all_exprs() without expression returns an error", { expect_error( all_exprs(), "At least one expression must be given", fixed = TRUE ) }) dplyr/tests/testthat/test-group_split.R0000644000176200001440000000435713614573562020102 0ustar liggesuserscontext("group_split") test_that("group_split() keeps the grouping variables by default", { tbl <- tibble(x = 1:4, g = factor(rep(c("a", "b"), each = 2))) res <- group_split(tbl, g) expect_equivalent(res, list(tbl[1:2,], tbl[3:4,])) }) test_that("group_split() can discard the grouping variables with keep = FALSE", { tbl <- tibble(x = 1:4, g = factor(rep(c("a", "b"), each = 2))) res <- group_split(tbl, g, keep = FALSE) expect_equivalent(res, list(tbl[1:2, 1, drop = FALSE], tbl[3:4,1, drop = FALSE])) }) test_that("group_split() respects empty groups", { tbl <- tibble(x = 1:4, g = factor(rep(c("a", "b"), each = 2), levels = c("a", "b", "c"))) res <- group_split(tbl, g) expect_equivalent(res, list(tbl[1:2,], tbl[3:4,])) res <- group_split(tbl, g, .drop = FALSE) expect_equivalent(res, list(tbl[1:2,], tbl[3:4,], tbl[integer(), ])) }) test_that("group_split.grouped_df() warns about ...", { expect_warning(group_split(group_by(mtcars, cyl), cyl)) }) test_that("group_split.rowwise_df() warns about ...", { expect_warning(group_split(rowwise(mtcars), cyl)) }) test_that("group_split.grouped_df() works", { expect_equal( iris %>% group_by(Species) %>% group_split(), iris %>% group_split(Species) ) }) test_that("group_split / bind_rows round trip", { setosa <- iris %>% filter(Species == "setosa") chunks <- setosa %>% group_split(Species) expect_equal(length(chunks), 1L) expect_equal(bind_rows(chunks), setosa) chunks <- setosa %>% group_split(Species, .drop = FALSE) expect_equal(length(chunks), 3L) expect_equal(bind_rows(chunks), setosa) }) test_that("group_split() works if no grouping column", { expect_equivalent(group_split(iris), list(iris)) }) test_that("group_split(keep=FALSE) does not try to remove virtual grouping columns (#4045)", { iris3 <- iris[1:3,] rows <- list(c(1L, 3L, 2L), c(3L, 2L, 3L)) df <- new_grouped_df( iris3, groups = tibble(.bootstrap = 1:2, .rows := rows) ) res <- group_split(df, keep = FALSE) expect_equivalent( res, list(iris3[rows[[1L]],], iris3[rows[[2L]],]) ) }) test_that("group_split() respects .drop", { keys <- tibble(f = factor("b", levels = c("a", "b", "c"))) %>% group_keys(f, .drop = TRUE) expect_equal(nrow(keys), 1L) }) dplyr/tests/testthat/helper-combine.R0000644000176200001440000001706613614573562017450 0ustar liggesuserscombine_pair_test <- function(item_pair, var1, var2, result, can_combine = TRUE, warning = FALSE) { label_if_fail <- paste0( "combine(items[c(\"", var1, "\", \"", var2, "\")])" ) if (warning) { warning_regexp <- ".*" } else { warning_regexp <- NA } if (can_combine) { expect_warning( res <- combine(item_pair), regexp = warning_regexp, label = label_if_fail ) expect_equal( object = res, expected = result, label = label_if_fail, expected.label = deparse(result) ) } else { expect_warning( expect_error( combine(item_pair), "^Argument 2 can't be converted from [^ ]* to [^ ]*$", label = label_if_fail ), regexp = warning_regexp, label = label_if_fail ) } } can_be_combined <- function(item1, item2, class1, class2, all_na1, all_na2, known_to_dplyr1, known_to_dplyr2) { # Unknown classes will be stripped and ignored (#2406) if (!known_to_dplyr1) { class1 <- class(as.vector(item1)) } if (!known_to_dplyr2) { class2 <- class(as.vector(item2)) } # Two elements of the same class can be combined # NA values are also combinable if (identical(class1, class2) || all_na1 || all_na2) { return(TRUE) } # doubles and integers: if (all(c(class1, class2) %in% c("numeric", "integer"))) { return(TRUE) } # coerce factor with character if ( (identical(class1, "factor") && identical(class2, "character")) || (identical(class2, "factor") && identical(class1, "character")) ){ return(TRUE) } # All the other cases can't be combined return(FALSE) } give_a_warning <- function(item1, item2, class1, class2, known_to_dplyr1, known_to_dplyr2, can_be_combined) { # Unknown classes give a warning, because attributes may be wrong if (!known_to_dplyr1) { return(TRUE) } # If only the second element is of an unknown type to dplyr # Then the warning is only emmitted in case we can combine (otherwise the # error appears before) if (!known_to_dplyr2 && can_be_combined) { return(TRUE) } # factor and character give a warning when combined (coercion to character) if ( (identical(class1, "factor") && identical(class2, "character")) || (identical(class1, "character") && identical(class2, "factor")) ) { return(TRUE) } # Two factors give a warning if they don't have identical levels (coercion to character) if (identical(class1, "factor") && identical(class2, "factor")) { if (!identical(levels(item1), levels(item2))) { return(TRUE) } } # All other cases do not raise a warning return(FALSE) } combine_result <- function(item1, item2, class1, class2, all_na1, all_na2, known_to_dplyr1, known_to_dplyr2, can_combine, give_warning) { result <- NULL # Unknown classes will be stripped and ignored (#2406) if (!known_to_dplyr1) { class1 <- class(as.vector(item1)) } if (!known_to_dplyr2) { class2 <- class(as.vector(item2)) } if (can_combine) { # Custom coercions: # - Factor with character coerced to character # - Factor with Factor without same levels -> character # - Factor with NA is Factor # Otherwise use the default approach with unlist and add classes # if needed. if ((identical(class1, "factor") && identical(class2, "character")) || (identical(class2, "factor") && identical(class1,"character"))) { result <- c(as.character(item1), as.character(item2)) } else if ((identical(class1, "factor") && identical(class2, "factor")) && !identical(levels(item1), levels(item2))) { result <- c(as.character(item1), as.character(item2)) } else if ((is.factor(item1) && all(is.na(item2))) || (is.factor(item2) && all(is.na(item1)))) { result <- factor(c(as.character(item1), as.character(item2))) } else { # Default combination result result <- unlist( list(item1, item2), recursive = FALSE, use.names = FALSE ) # Add classes and attributes in some cases to the default if ((all(is.na(item1)) && "POSIXct" %in% class2) || (all(is.na(item2)) && "POSIXct" %in% class1) || ("POSIXct" %in% class1 && "POSIXct" %in% class2)) { class(result) <- c("POSIXct", "POSIXt") attr(result, "tzone") <- "" } else if (all_na1 && known_to_dplyr2) { class(result) <- class2 } else if (all_na2 && known_to_dplyr1) { class(result) <- class1 } else if (identical(class1, class2) && known_to_dplyr1) { class(result) <- class1 } } } list(result) } prepare_table_with_coercion_rules <- function() { items <- list( logicalvalue = TRUE, logicalNA = NA, anotherNA = c(NA, NA), integer = 4L, factor = factor("a"), another_factor = factor("b"), double = 4.5, character = "c", POSIXct = as.POSIXct("2010-01-01"), Date = as.Date("2016-01-01"), complex = 1 + 2i, int_with_class = structure(4L, class = "int_with_class"), num_with_class = structure(4.5, class = "num_with_class") ) special_non_vector_classes <- c( "factor", "POSIXct", "Date", "table", "AsIs", "integer64" ) pairs <- expand.grid(names(items), names(items)) pairs$can_combine <- FALSE pairs$warning <- FALSE pairs$item_pair <- vector("list", nrow(pairs)) pairs$result <- vector("list", nrow(pairs)) for (i in seq_len(nrow(pairs))) { item1 <- items[[pairs$Var1[i]]] item2 <- items[[pairs$Var2[i]]] class1 <- class(item1) class2 <- class(item2) all_na1 <- all(is.na(item1)) all_na2 <- all(is.na(item2)) known_to_dplyr1 <- is.vector(item1) || any(class1 %in% special_non_vector_classes) known_to_dplyr2 <- is.vector(item2) || any(class2 %in% special_non_vector_classes) pairs$can_combine[i] <- can_be_combined( item1, item2, class1, class2, all_na1, all_na2, known_to_dplyr1, known_to_dplyr2 ) pairs$warning[i] <- give_a_warning( item1, item2, class1, class2, known_to_dplyr1, known_to_dplyr2, can_be_combined = pairs$can_combine[i] ) pairs$item_pair[[i]] <- list(item1, item2) pairs$result[i] <- combine_result( item1, item2, class1, class2, all_na1, all_na2, known_to_dplyr1, known_to_dplyr2, pairs$can_combine[i], pairs$warning[i] ) } return(pairs) } print_pairs <- function(pairs) { pairs_printable <- pairs pairs_printable$result <- sapply( pairs$result, function(x) { if (is.null(x)) { "" } else { as.character(x) } } ) pairs_printable$result_class <- lapply( pairs$result, function(x) { if (is.null(x)) { "" } else { class(x) } } ) pairs_printable <- arrange( pairs_printable, desc(can_combine), warning, Var1, Var2 ) pairs_printable } combine_coercion_types <- function() { pairs <- prepare_table_with_coercion_rules() # knitr::kable(print_pairs(pairs)) for (i in seq_len(nrow(pairs))) { test_that(paste0("Coercion from ", pairs$Var1[i], " to ", pairs$Var2[i]), { combine_pair_test( item_pair = pairs$item_pair[[i]], var1 = pairs$Var1[i], var2 = pairs$Var2[i], result = pairs$result[[i]], can_combine = pairs$can_combine[i], warning = pairs$warning[i] ) }) } } dplyr/tests/testthat/test-rbind.R0000644000176200001440000002247713614573562016634 0ustar liggesuserscontext("rbind") rbind_list_warn <- function(...) { expect_warning(ret <- rbind_list(...), "bind_rows") ret } rbind_all_warn <- function(...) { expect_warning(ret <- rbind_list(...), "bind_rows") ret } df_var <- data.frame( l = c(T, F, F), i = c(1, 1, 2), d = Sys.Date() + c(1, 1, 2), f = factor(letters[c(1, 1, 2)]), n = c(1, 1, 2) + 0.5, t = Sys.time() + c(1, 1, 2), c = letters[c(1, 1, 2)], stringsAsFactors = FALSE ) test_that("rbind_list works on key types", { exp <- tbl_df(rbind(df_var, df_var, df_var)) expect_equal( rbind_list_warn(df_var, df_var, df_var), exp ) }) test_that("rbind_list reorders columns", { columns <- seq_len(ncol(df_var)) exp <- tbl_df(rbind(df_var, df_var, df_var)) expect_equal( rbind_list_warn( df_var, df_var[, sample(columns)], df_var[, sample(columns)] ), exp ) }) test_that("rbind_list promotes integer to numeric", { df <- data.frame(a = 1:5, b = 1:5) df2 <- df df2$a <- as.numeric(df$a) res <- rbind_list_warn(df, df2) expect_equal(typeof(res$a), "double") expect_equal(typeof(res$b), "integer") }) test_that("rbind_list promotes factor to character", { df <- data.frame(a = letters[1:5], b = 1:5, stringsAsFactors = TRUE) df2 <- df df2$a <- as.character(df$a) res <- rbind_list_warn(df, df2) expect_equal(typeof(res$a), "character") }) test_that("rbind_list doesn't promote factor to numeric", { df1 <- data.frame(a = 1:5, b = 1:5) df2 <- data.frame(a = 1:5, b = factor(letters[1:5])) expect_error(rbind_list_warn(df1, df2)) }) test_that("rbind_list doesn't coerce integer to factor", { df1 <- data.frame(a = 1:10, b = 1:10) df2 <- data.frame(a = 1:5, b = factor(letters[1:5])) expect_error(rbind_list_warn(df1, df2)) }) test_that("rbind_list coerces factor to character when levels don't match", { df1 <- data.frame(a = 1:3, b = factor(c("a", "b", "c"))) df2 <- data.frame(a = 1:3, b = factor(c("a", "b", "c"), levels = c("b", "c", "a", "d") )) expect_warning( res <- rbind_list(df1, df2), "Unequal factor levels: coercing to character" ) expect_equal(res$b, c("a", "b", "c", "a", "b", "c")) }) test_that("rbind handles NULL", { x <- cbind(a = 1:10, b = 1:10) y <- data.frame(x) res <- rbind_all_warn(list(y, y, NULL, y)) expect_equal(nrow(res), 30L) }) test_that("rbind handles NA in factors #279", { xx <- as.data.frame(list(a = as.numeric(NA), b = "c", c = "d")) zz <- as.data.frame(list(a = 1, b = as.character(NA), c = "b")) expect_warning(res <- rbind_list(xx, zz)) expect_equal(res$a, c(NA, 1.0)) expect_equal(res$b, c("c", NA)) expect_equal(res$c, c("d", "b")) }) test_that("rbind_all only accepts data frames #288", { ll <- list(c(1, 2, 3, 4, 5), c(6, 7, 8, 9, 10)) expect_error(rbind_all_warn(ll)) }) test_that("rbind propagates timezone for POSIXct #298", { dates1 <- data.frame( ID = c("a", "b", "c"), dates = structure(c(-247320000, -246196800, -245073600), tzone = "GMT", class = c("POSIXct", "POSIXt") ), stringsAsFactors = FALSE ) dates2 <- data.frame( ID = c("d", "e", "f"), dates = structure(c(-243864000, -242654400, -241444800), tzone = "GMT", class = c("POSIXct", "POSIXt") ), stringsAsFactors = FALSE ) alldates <- rbind_list_warn(dates1, dates2) expect_equal(attr(alldates$dates, "tzone"), "GMT") }) test_that("Collecter_Impl can collect INTSXP. #321", { res <- rbind_list_warn(data.frame(x = 0.5), data.frame(x = 1:3)) expect_equal(res$x, c(0.5, 1:3)) }) test_that("Collecter_Impl can collect LGLSXP. #321", { res <- rbind_list_warn(data.frame(x = 1:3), data.frame(x = NA)) expect_equal(res$x, c(1:3, NA)) }) test_that("rbind_all handles list columns (#463)", { dfl <- data.frame(x = I(list(1:2, 1:3, 1:4))) res <- rbind_all_warn(list(dfl, dfl)) expect_equal(rep(dfl$x, 2L), res$x) }) test_that("rbind_all creates tbl_df object", { res <- rbind_list_warn(tbl_df(mtcars)) expect_is(res, "tbl_df") }) test_that("string vectors are filled with NA not blanks before collection (#595)", { one <- mtcars[1:10, -10] two <- mtcars[11:32, ] two$char_col <- letters[1:22] res <- rbind_list_warn(one, two) expect_true(all(is.na(res$char_col[1:10]))) }) test_that("rbind handles data frames with no rows (#597)", { empty <- data.frame(result = numeric()) expect_equal(rbind_list_warn(empty), tbl_df(empty)) expect_equal(rbind_list_warn(empty, empty), tbl_df(empty)) expect_equal(rbind_list_warn(empty, empty, empty), tbl_df(empty)) }) test_that("rbind handles all NA columns (#493)", { mydata <- list( data.frame(x = c("foo", "bar")), data.frame(x = NA) ) res <- rbind_all_warn(mydata) expect_true(is.na(res$x[3])) expect_is(res$x, "factor") mydata <- list( data.frame(x = NA), data.frame(x = c("foo", "bar")) ) res <- rbind_all_warn(mydata) expect_true(is.na(res$x[1])) expect_is(res$x, "factor") }) test_that("bind_rows handles complex. #933", { df1 <- data.frame(r = c(1 + 1i, 2 - 1i)) df2 <- data.frame(r = c(1 - 1i, 2 + 1i)) df3 <- bind_rows(df1, df2) expect_equal(nrow(df3), 4L) expect_equal(df3$r, c(df1$r, df2$r)) }) test_that("bind_rows is careful about column names encoding #1265", { one <- data.frame(foo = 1:3, bar = 1:3) names(one) <- c("f\u00fc", "bar") two <- data.frame(foo = 1:3, bar = 1:3) names(two) <- c("f\u00fc", "bar") Encoding(names(one)[1]) <- "UTF-8" expect_equal(names(one), names(two)) res <- bind_rows(one, two) expect_equal(ncol(res), 2L) }) test_that("bind_rows handles POSIXct (#1125)", { df1 <- data.frame(date = as.POSIXct(NA)) df2 <- data.frame(date = as.POSIXct("2015-05-05")) res <- bind_rows(df1, df2) expect_equal(nrow(res), 2L) expect_true(is.na(res$date[1])) }) test_that("bind_rows respects ordered factors (#1112)", { l <- c("a", "b", "c", "d") id <- factor(c("a", "c", "d"), levels = l, ordered = TRUE) df <- data.frame(id = rep(id, 2), val = rnorm(6)) res <- bind_rows(df, df) expect_is(res$id, "ordered") expect_equal(levels(df$id), levels(res$id)) res <- group_by(df, id) %>% do(na.omit(.)) expect_is(res$id, "ordered") expect_equal(levels(df$id), levels(res$id)) }) test_that("bind_rows can handle lists (#1104)", { my_list <- list(list(x = 1, y = "a"), list(x = 2, y = "b")) res <- bind_rows(my_list) expect_equal(nrow(res), 2L) expect_is(res$x, "numeric") expect_is(res$y, "character") res <- bind_rows(list(x = 1, y = "a"), list(x = 2, y = "b")) expect_equal(nrow(res), 2L) expect_is(res$x, "numeric") expect_is(res$y, "character") }) test_that("rbind_list keeps ordered factors (#948)", { y <- rbind_list_warn( data.frame(x = factor(c(1, 2, 3), ordered = TRUE)), data.frame(x = factor(c(1, 2, 3), ordered = TRUE)) ) expect_is(y$x, "ordered") expect_equal(levels(y$x), as.character(1:3)) }) test_that("bind handles POSIXct of different tz ", { date1 <- structure(-1735660800, tzone = "America/Chicago", class = c("POSIXct", "POSIXt")) date2 <- structure(-1735660800, tzone = "UTC", class = c("POSIXct", "POSIXt")) date3 <- structure(-1735660800, class = c("POSIXct", "POSIXt")) df1 <- data.frame(date = date1) df2 <- data.frame(date = date2) df3 <- data.frame(date = date3) res <- bind_rows(df1, df2) expect_equal(attr(res$date, "tzone"), "UTC") res <- bind_rows(df1, df3) expect_equal(attr(res$date, "tzone"), "America/Chicago") res <- bind_rows(df2, df3) expect_equal(attr(res$date, "tzone"), "UTC") res <- bind_rows(df3, df3) expect_equal(attr(res$date, "tzone"), NULL) res <- bind_rows(df1, df2, df3) expect_equal(attr(res$date, "tzone"), "UTC") }) test_that("bind_rows() creates a column of identifiers (#1337)", { data1 <- mtcars[c(2, 3), ] data2 <- mtcars[1, ] out <- bind_rows(data1, data2, .id = "col") out_list <- bind_rows(list(data1, data2), .id = "col") expect_equal(names(out)[1], "col") expect_equal(out$col, c("1", "1", "2")) expect_equal(out_list$col, c("1", "1", "2")) out_labelled <- bind_rows(one = data1, two = data2, .id = "col") out_list_labelled <- bind_rows(list(one = data1, two = data2), .id = "col") expect_equal(out_labelled$col, c("one", "one", "two")) expect_equal(out_list_labelled$col, c("one", "one", "two")) }) test_that("empty data frame are handled (#1346)", { res <- tibble() %>% bind_rows(tibble(x = "a")) expect_equal(nrow(res), 1L) }) test_that("bind_rows handles POSIXct stored as integer (#1402)", { now <- Sys.time() df1 <- data.frame(time = now) expect_equal(class(bind_rows(df1)$time), c("POSIXct", "POSIXt")) df2 <- data.frame(time = seq(now, length.out = 1, by = 1)) expect_equal(class(bind_rows(df2)$time), c("POSIXct", "POSIXt")) res <- bind_rows(df1, df2) expect_equal(class(res$time), c("POSIXct", "POSIXt")) expect_true(all(res$time == c(df1$time, df2$time))) }) test_that("bind_rows warns on binding factor and character (#1485)", { df1 <- head(iris, 1) df2 <- tail(iris, 1) %>% mutate(Species = as.character(Species)) expect_warning(bind_rows(df1, df2), "binding factor and character vector, coercing into character vector") }) test_that("bind_rows() correctly handles consecutive NULLs (#4296)", { res <- list( a = tibble(expected_id = "a"), b = NULL, c = NULL, d = tibble(expected_id = "d"), c = NULL, e = tibble(expected_id = "e") ) %>% bind_rows(.id = "id") expect_equal(res$id, res$expected_id) }) dplyr/tests/testthat/test-arrange.r0000644000176200001440000001331313614573562017202 0ustar liggesuserscontext("Arrange") df2 <- data.frame( a = rep(c(NA, 1, 2, 3), each = 4), b = rep(c(0L, NA, 1L, 2L), 4), c = c(NA, NA, NA, NA, letters[10:21]), d = rep(c(T, NA, F, T), each = 4), id = 1:16, stringsAsFactors = FALSE ) equal_df <- function(x, y) { rownames(x) <- NULL rownames(y) <- NULL isTRUE(all.equal(x, y)) } test_that("local arrange sorts missing values to end", { na_last <- function(x) { n <- length(x) all(is.na(x[(n - 3):n])) } # Numeric expect_true(na_last(arrange(df2, a)$a)) expect_true(na_last(arrange(df2, desc(a))$a)) # Integer expect_true(na_last(arrange(df2, b)$b)) expect_true(na_last(arrange(df2, desc(b))$b)) # Character expect_true(na_last(arrange(df2, c)$c)) expect_true(na_last(arrange(df2, desc(c))$c)) # Logical expect_true(na_last(arrange(df2, d)$d)) expect_true(na_last(arrange(df2, desc(d))$d)) }) test_that("two arranges equivalent to one", { df <- tribble( ~ x, ~ y, 2, 1, 2, -1, 1, 1 ) df1 <- df %>% arrange(x, y) df2 <- df %>% arrange(y) %>% arrange(x) expect_equal(df1, df2) }) test_that("arrange handles list columns (#282)", { df <- data.frame(a = 2:1) df$b <- list("foo", "bar") res <- arrange(df, a) expect_equal(res$b, list("bar", "foo")) }) test_that("arrange handles the case where ... is missing (#338)", { expect_equivalent(arrange(mtcars), mtcars) }) test_that("arrange handles 0-rows data frames", { d <- data.frame(a = numeric(0)) expect_identical(d, arrange(d)) }) test_that("grouped arrange ignores group (#491 -> #1206)", { df <- data.frame(g = c(2, 1, 2, 1), x = c(4:1)) out <- df %>% group_by(g) %>% arrange(x) expect_equal(out$x, 1:4) }) test_that("arrange keeps the grouping structure (#605)", { dat <- tibble(g = c(2, 2, 1, 1), x = c(1, 3, 2, 4)) res <- dat %>% group_by(g) %>% arrange() expect_is(res, "grouped_df") expect_equal(res$x, dat$x) res <- dat %>% group_by(g) %>% arrange(x) expect_is(res, "grouped_df") expect_equal(res$x, 1:4) expect_equal(group_rows(res), list(c(2, 4), c(1, 3))) }) test_that("arrange handles complex vectors", { d <- data.frame(x = 1:10, y = 10:1 + 2i) res <- arrange(d, y) expect_equal(res$y, rev(d$y)) expect_equal(res$x, rev(d$x)) res <- arrange(res, desc(y)) expect_equal(res$y, d$y) expect_equal(res$x, d$x) d$y[c(3, 6)] <- NA res <- arrange(d, y) expect_true(all(is.na(res$y[9:10]))) res <- arrange(d, desc(y)) expect_true(all(is.na(res$y[9:10]))) }) test_that("arrange respects S4 classes #1105", { TestS4 <- suppressWarnings(setClass("TestS4", contains = "numeric")) setMethod('[', 'TestS4', function(x, i, ...){ TestS4(unclass(x)[i, ...]) }) on.exit(removeClass("TestS4")) df <- data.frame(p = TestS4(c(1, 2, 3)), x = 1:3) res <- arrange(df, p) expect_is(res$p, "TestS4") }) test_that("arrange works with empty data frame (#1142)", { df <- data.frame() res <- df %>% arrange() expect_equal(nrow(res), 0L) expect_equal(length(res), 0L) }) test_that("arrange respects locale (#1280)", { df2 <- tibble(words = c("casa", "\u00e1rbol", "zona", "\u00f3rgano")) res <- df2 %>% arrange(words) expect_equal(res$words, sort(df2$words)) res <- df2 %>% arrange(desc(words)) expect_equal(res$words, sort(df2$words, decreasing = TRUE)) }) test_that("duplicated column name is explicit about which column (#996)", { df <- data.frame(x = 1:10, x = 1:10) names(df) <- c("x", "x") # Error message created by tibble expect_error(df %>% arrange()) df <- data.frame(x = 1:10, x = 1:10, y = 1:10, y = 1:10) names(df) <- c("x", "x", "y", "y") # Error message created by tibble expect_error(df %>% arrange()) }) test_that("arrange fails gracefully on list columns (#1489)", { df <- expand.grid(group = 1:2, y = 1, x = 1) %>% group_by(group) %>% do(fit = lm(data = ., y ~ x)) expect_error( arrange(df, fit), "Argument 1 is of unsupported type list", fixed = TRUE ) }) test_that("arrange supports raw columns (#1803)", { df <- tibble(a = 1:3, b = as.raw(1:3)) expect_identical(arrange(df, a), df) expect_identical(arrange(df, b), df) expect_identical(arrange(df, desc(a)), df[3:1, ]) expect_identical(arrange(df, desc(b)), df[3:1, ]) }) test_that("arrange fails gracefully on matrix input (#1870)", { df <- tibble(a = 1:3, b = 4:6) expect_error( arrange(df, is.na(df)), "Argument 1 is of unsupported type matrix", fixed = TRUE ) }) test_that("arrange fails gracefully on data.frame input (#3153)", { df <- tibble(x = 1:150, iri = rnorm(150)) expect_error(arrange(df, iris), "Argument 1 is of unsupported type data.frame") }) test_that("arrange.data.frame recognizes the .by_group argument (#3546)", { df <- data.frame(foo=1:2, bar=2) res <- df %>% arrange(foo, .by_group=TRUE) expect_identical(res, df) }) test_that("desc() works (#4099)", { df <- data.frame(x = rep(1, 5), y = c(0, 3, 1.5, -5, 4)) %>% mutate(diff = x - y, absdiff = abs(x - y)) expect_identical( arrange(df, desc(abs(diff))), arrange(df, desc(absdiff)) ) }) test_that("arrange supports bit64::integer64 (#4366)", { df <- tibble(x = bit64::as.integer64(c(1, 3, 2, 1))) expect_identical( arrange(df, x), tibble(x = bit64::as.integer64(c(1, 1, 2, 3))) ) expect_identical( arrange(df, desc(x)), tibble(x = bit64::as.integer64(c(3, 2, 1, 1))) ) expect_identical( arrange(df, -x), tibble(x = bit64::as.integer64(c(3, 2, 1, 1))) ) }) # grouped_df -------------------------------------------------------------- test_that("can choose to include grouping vars", { df <- tibble(g = c(1, 2), x = c(2, 1)) %>% group_by(g) df1 <- df %>% arrange(x, .by_group = TRUE) df2 <- df %>% arrange(g, x) expect_equal(df1, df2) }) dplyr/tests/testthat/test-empty-groups.R0000644000176200001440000000546413614573562020206 0ustar liggesuserscontext("empty groups") df <- data_frame( e = 1, f = factor(c(1, 1, 2, 2), levels = 1:3), g = c(1, 1, 2, 2), x = c(1, 2, 1, 4)) %>% group_by(e, f, g, .drop = FALSE) test_that("filter and slice keep zero length groups", { expect_equal(group_size(filter(df, f == 1)), c(2, 0, 0) ) expect_equal(group_size(slice(df, 1)), c(1, 1, 0) ) }) test_that("filtering and slicing retains labels for zero length groups", { expect_equal( count(filter(df, f == 1)), tibble( e = 1, f = factor(1:3), g = c(1, NA, NA), n = c(2L, 0L, 0L) ) %>% group_by(e, f) ) expect_equal( count(slice(df, 1)), tibble( e = 1, f = factor(1:3), g = c(1, 2, NA), n = c(1L, 1L, 0L) ) %>% group_by(e, f) ) }) test_that("mutate keeps zero length groups", { expect_equal( group_size(mutate(df, z = 2)), c(2, 2, 0) ) }) test_that("summarise returns a row for zero length groups", { expect_equal( nrow(summarise(df, z = n())), 3L) }) test_that("arrange keeps zero length groups",{ expect_equal( group_size(arrange(df)), c(2, 2, 0) ) expect_equal( group_size(arrange(df, x)), c(2, 2, 0) ) }) test_that("bind_rows respect the drop attribute of grouped df",{ gg <- bind_rows(df, df) expect_equal(group_size(gg), c(4L,4L,0L)) }) test_that("joins respect zero length groups", { df1 <- tibble(f = factor( c(1,1,2,2), levels = 1:3), x = c(1,2,1,4)) %>% group_by(f) df2 <- tibble(f = factor( c(2,2,3,3), levels = 1:3), y = c(1,2,3,4)) %>% group_by(f) expect_equal(group_size(left_join( df1, df2, by = "f")), c(2,4)) expect_equal(group_size(right_join( df1, df2, by = "f")), c(4,2)) expect_equal(group_size(full_join( df1, df2, by = "f")), c(2,4,2)) expect_equal(group_size(anti_join( df1, df2, by = "f")), c(2)) expect_equal(group_size(inner_join( df1, df2, by = "f")), c(4)) df1 <- tibble(f = factor( c(1,1,2,2), levels = 1:3), x = c(1,2,1,4)) %>% group_by(f, .drop = FALSE) df2 <- tibble(f = factor( c(2,2,3,3), levels = 1:3), y = c(1,2,3,4)) %>% group_by(f, .drop = FALSE) expect_equal(group_size(left_join( df1, df2, by = "f")), c(2,4,0)) expect_equal(group_size(right_join( df1, df2, by = "f")), c(0,4,2)) expect_equal(group_size(full_join( df1, df2, by = "f")), c(2,4,2)) expect_equal(group_size(anti_join( df1, df2, by = "f")), c(2,0,0)) expect_equal(group_size(inner_join( df1, df2, by = "f")), c(0,4,0)) }) test_that("n_groups respects zero-length groups (#341)", { df <- tibble(x = factor(1:3, levels = 1:4)) %>% group_by(x, .drop = FALSE) expect_equal(n_groups(df), 4) }) test_that("summarise respects zero-length groups (#341)", { df <- tibble(x = factor(rep(1:3, each = 10), levels = 1:4)) out <- df %>% group_by(x, .drop = FALSE) %>% summarise(n = n()) expect_equal(out$n, c(10L, 10L, 10L, 0L)) }) dplyr/tests/testthat/test-group_data.R0000644000176200001440000000553413614573562017656 0ustar liggesuserscontext("group_data") test_that("group_rows works for 3 most important subclasses (#3489)", { df <- data.frame(x=c(1,1,2,2)) expect_equal(group_rows(df), list(1:4)) expect_equal(group_rows(group_by(df,x)), list(1:2, 3:4)) expect_equal(group_rows(rowwise(df)), as.list(1:4)) }) test_that("group_data() returns a tidy tibble (#3489)", { df <- tibble(x = c(1,1,2,2)) expect_identical( group_data(df), tibble(".rows" := list(1:4)) ) expect_identical( group_by(df,x) %>% group_data(), tibble::new_tibble(list(x = c(1,2), .rows = list(1:2, 3:4)), .drop = TRUE, nrow = 2L) ) expect_identical( rowwise(df) %>% group_data(), tibble(".rows" := as.list(1:4)) ) }) test_that("group_rows and group_data work with 0 rows data frames (#3489)", { df <- tibble(x=integer()) expect_identical(group_rows(df), list(integer())) expect_identical(group_rows(rowwise(df)), list()) expect_identical(group_rows(group_by(df, x)), list()) expect_identical(group_data(df), tibble(".rows" := list(integer()))) expect_identical(group_data(rowwise(df)), tibble(".rows" := list())) expect_identical( group_data(group_by(df, x)), tibble::new_tibble(list(x = integer(), .rows = list()), .drop = TRUE, nrow = 0L) ) }) test_that("GroupDataFrame checks the structure of the groups attribute", { df <- group_by(tibble(x = 1:4, g = rep(1:2, each = 2)), g) groups <- attr(df, "groups") groups[[2]] <- 1:2 attr(df, "groups") <- groups expect_error(group_data(df), "is a corrupt grouped_df") df <- group_by(tibble(x = 1:4, g = rep(1:2, each = 2)), g) groups <- attr(df, "groups") names(groups) <- c("g", "not.rows") attr(df, "groups") <- groups expect_error(group_data(df), "is a corrupt grouped_df") attr(df, "groups") <- tibble() expect_error(group_data(df), "is a corrupt grouped_df") attr(df, "groups") <- NA expect_error(group_data(df), "is a corrupt grouped_df") }) test_that("GroupedDataFrame is compatible with older style grouped_df (#3604)", { df <- tibble(x = 1:4, g = rep(1:2, each = 2)) attr(df, "vars") <- "g" attr(df, "class") <- c("grouped_df", "tbl_df", "tbl", "data.frame") expect_equal(expect_warning(group_rows(df)), list(1:2, 3:4)) df <- structure( data.frame(x=1), class = c("grouped_df", "tbl_df", "tbl", "data.frame"), vars = list(sym("x")) ) g <- expect_warning(group_data(df)) expect_equal(g$x, 1) expect_equal(g$.rows, list(1L)) expect_equal(attr(g, ".drop"), TRUE) expect_null(attr(df, "vars")) }) test_that("old group format repair does not keep a vars attribute around", { tbl <- tibble(x = 1:10, y = 1:10) attr(tbl, "vars") <- rlang::sym("x") class(tbl) <- c("grouped_df", "tbl_df", "tbl", "data.frame") expect_warning({ res <- tbl %>% group_by(y) }) expect_equal(group_vars(res), "y") expect_null(attr(res, " vars")) expect_null(attr(tbl, " vars")) }) dplyr/tests/testthat/test-ts.R0000644000176200001440000000052313614573562016150 0ustar liggesuserscontext("ts") test_that("filter and lag throw errors", { x <- ts(1:10) expect_error( filter(x), "`.data` must be a data source, not a ts object, do you want `stats::filter()`?", fixed = TRUE ) expect_error( lag(x), "`x` must be a vector, not a ts object, do you want `stats::lag()`?", fixed = TRUE ) }) dplyr/tests/testthat/test-union-all.R0000644000176200001440000000043313451046652017412 0ustar liggesuserscontext("union_all") test_that("union all on vectors concatenates", { expect_equal(union_all(1:3, 4:6), 1:6) }) test_that("union all on data frames calls bind rows", { df1 <- tibble(x = 1:2) df2 <- tibble(y = 1:2) expect_equal(union_all(df1, df2), bind_rows(df1, df2)) }) dplyr/tests/testthat/helper-astyle.R0000644000176200001440000000177413614573562017334 0ustar liggesusersvcapply <- function(X, FUN, ..., USE.NAMES = TRUE) { vapply(X = X, FUN = FUN, FUN.VALUE = character(1L), ..., USE.NAMES = USE.NAMES) } astyle <- function(extra_args = character()) { astyle_cmd <- "astyle" if (Sys.which(astyle_cmd) == "") { skip("astyle not found") } astyle_args <- c( "-n", "--indent=spaces=2", "--unpad-paren", "--pad-header", "--pad-oper", "--min-conditional-indent=0", "--align-pointer=type", "--align-reference=type" ) src_path <- normalizePath(map_chr(c("../../src", "../../inst/include"), testthat::test_path)) src_files <- dir(src_path, "[.](?:cpp|h)$", recursive = TRUE, full.names = TRUE) astyle_files <- grep("(?:RcppExports[.](?:cpp|h)|static_assert[.]h)", src_files, value = TRUE, invert = TRUE) output <- system2(astyle_cmd, c(astyle_args, astyle_files, extra_args), stdout = TRUE, stderr = TRUE) unchanged <- grepl("^Unchanged", output) if (any(!unchanged)) { rlang::warn(paste(output[!unchanged], collapse = "\n")) } } dplyr/tests/testthat/test-astyle.R0000644000176200001440000000024313614573562017022 0ustar liggesuserscontext("astyle") test_that("source code formatting", { skip_on_cran() skip_on_os("windows") skip_on_travis() expect_warning(astyle("--dry-run"), NA) }) dplyr/tests/testthat/test-group_keys.R0000644000176200001440000000145113614573562017712 0ustar liggesuserscontext("group_keys()") test_that("group_keys() works", { tbl <- tibble(x = 1:4, g = factor(rep(c("a", "b"), each = 2), levels = c("a", "b", "c"))) res <- group_keys(tbl, g) expect_equal(res, tibble(g = factor(c("a", "b"), levels = c("a", "b", "c")))) }) test_that("group_keys.grouped_df() warns about ...", { expect_warning(group_keys(group_by(mtcars, cyl), cyl)) }) test_that("group_keys.grouped_df() works", { expect_equal( iris %>% group_by(Species) %>% group_keys(), iris %>% group_keys(Species) ) }) test_that("group_keys.rowwise_df() is an error", { expect_error(group_keys(rowwise(iris))) }) test_that("group_split() respects .drop", { chunks <- tibble(f = factor("b", levels = c("a", "b", "c"))) %>% group_split(f, .drop = TRUE) expect_equal(length(chunks), 1L) }) dplyr/tests/testthat/test-top-n.R0000644000176200001440000000152013574646634016563 0ustar liggesuserscontext("top_n") test_that("top_n returns n rows", { test_df <- data.frame(x = 1:10, y = 11:20) top_four <- test_df %>% top_n(4, y) expect_equal(dim(top_four), c(4, 2)) }) test_that("top_n() handles missing `wt`", { df <- data.frame(x = c(10, 4, 1, 6, 3, 1, 1)) expect_message( regexp = "Selecting by x", expect_identical(top_n(df, 2)$x, c(10, 6)) ) }) test_that("top_n() handles calls", { expect_identical(top_n(mtcars, 2, -disp), top_n(mtcars, -2, disp)) }) test_that("top_n() quotes n", { expect_identical(top_n(mtcars, n() * .5), top_n(mtcars, 16)) }) test_that("top_frac() is a shorthand for top_n(n()*)", { expect_identical(top_n(mtcars, n() * .5, disp), top_frac(mtcars, .5, disp)) expect_message( regexp = "Selecting by carb", expect_identical(top_n(mtcars, n() * .5), top_frac(mtcars, .5)) ) }) dplyr/tests/testthat/test-funs.R0000644000176200001440000000624113614573562016500 0ustar liggesuserscontext("funs") test_that("fun_list is merged with new args", { scoped_lifecycle_silence() funs <- funs(fn = bar) funs <- as_fun_list(funs, env(), baz = "baz") expect_identical(funs$fn, quo(bar(., baz = "baz"))) }) test_that("funs() works with namespaced calls", { scoped_lifecycle_silence() expect_identical(summarise_all(mtcars, funs(base::mean(.))), summarise_all(mtcars, funs(mean(.)))) expect_identical(summarise_all(mtcars, funs(base::mean)), summarise_all(mtcars, funs(mean(.)))) }) test_that("funs() accepts quoted functions", { scoped_lifecycle_silence() expect_identical(funs(mean), funs("mean")) }) test_that("funs() accepts unquoted functions", { scoped_lifecycle_silence() funs <- funs(fn = !!mean) expect_identical(funs$fn, new_quosure(call2(base::mean, quote(.)))) }) test_that("funs() accepts quoted calls", { scoped_lifecycle_silence() expect_identical(funs(mean), funs(mean(.))) }) test_that("funs() gives a clear error message (#3368)", { scoped_lifecycle_silence() expect_error( funs(function(si) { mp[si] }), glue("`function(si) {{ mp[si] }}` must be a function name (quoted or unquoted) or an unquoted call, not `function`"), fixed = TRUE ) expect_error( funs(~mp[.]), "`~mp[.]` must be a function name (quoted or unquoted) or an unquoted call, not `~`", fixed = TRUE ) }) test_that("funs() can be merged with new arguments", { scoped_lifecycle_silence() fns <- funs(foo(.)) expect_identical(as_fun_list(fns, current_env(), foo = 1L), funs(foo(., foo = 1L))) }) enfun <- function(.funs, ...) { as_fun_list(.funs, caller_env(), ...) } test_that("can enfun() literal functions", { res <- enfun(identity(mean)) expect_equal(length(res), 1L) expect_identical(res[[1L]], mean) }) test_that("can enfun() named functions by expression", { res <- enfun(mean) expect_equal(length(res), 1L) expect_identical(res[[1L]], mean) }) test_that("local objects are not treated as symbols", { scoped_lifecycle_silence() mean <- funs(my_mean(.)) expect_identical(enfun(mean), mean) }) test_that("can enfun() character vectors", { res <- enfun(c("min", "max")) expect_equal(length(res), 2L) expect_equal(res[[1]], min) expect_equal(res[[2]], max) }) test_that("can enfun() purrr-style lambdas", { my_mean <- as_function(~ mean(.x)) res <- enfun(~ mean(.x)) expect_equal(length(res), 1L) expect_true(typeof(res[[1]]) == "closure") }) test_that("as_fun_list() uses rlang auto-naming", { nms <- names(as_fun_list(list(min, max), env())) # Just check they are labellised as literals enclosed in brackets to # insulate from upstream changes expect_true(all(grepl("^<", nms))) }) test_that("funs_ works", { scoped_lifecycle_silence() expect_equal( funs(mean), funs_(list(~ mean)) ) expect_equal( funs_(list("mean")), funs_(list(`environment<-`(~ mean, baseenv()))) ) expect_equal( funs(mean(.)), funs_(list(~ mean(.))) ) }) test_that("as_fun_list() auto names chr vectors (4307)", { expect_identical( data.frame(x = 1:10) %>% summarise_at("x", c("mean", "sum")), data.frame(x = 1:10) %>% summarise(mean = mean(x), sum = sum(x)) ) }) dplyr/tests/testthat/test-recode.R0000644000176200001440000001271613614573562016772 0ustar liggesuserscontext("recode") test_that("error if no arguments", { expect_error( recode(1:5), "No replacements provided" ) expect_error( recode("a"), "No replacements provided" ) expect_error( recode(factor("a")), "No replacements provided" ) }) test_that("error if unnamed", { expect_error( recode("a", b = 5, "c"), "Argument 3 must be named, not unnamed" ) expect_error( recode(factor("a"), b = 5, "c"), "Argument 3 must be named, not unnamed", fixed = TRUE ) }) test_that("error if missing given for factors", { expect_error( recode(factor("a"), a = 5, .missing = 10), "`.missing` is not supported for factors", fixed = TRUE ) }) test_that("positional substitution works", { expect_equal(recode(1:2, "a", "b"), c("a", "b")) }) test_that("names override positions", { expect_equal(recode(1:2, `2` = "b", `1` = "a"), c("a", "b")) }) test_that("numeric vals must be all named or not named at all", { expect_error( recode(1:2, "b", `1` = "a"), "Either all values must be named, or none must be named" ) }) test_that("named substitution works", { x1 <- letters[1:3] x2 <- factor(x1) expect_equal(recode(x1, a = "apple", .default = NA_character_), c("apple", NA, NA)) expect_equal(recode(x2, a = "apple", .default = NA_character_), factor(c("apple", NA, NA))) }) test_that("missing values replaced by missing argument", { expect_equal(recode(c(1, NA), "a"), c("a", NA)) expect_equal(recode(c(1, NA), "a", .missing = "b"), c("a", "b")) expect_equal(recode(c(letters[1:3], NA), .missing = "A"), c("a", "b", "c", "A")) }) test_that("unmatched value replaced by default argument", { expect_warning(expect_equal(recode(c(1, 2), "a"), c("a", NA))) expect_equal(recode(c(1, 2), "a", .default = "b"), c("a", "b")) expect_equal(recode(letters[1:3], .default = "A"), c("A", "A", "A")) }) test_that("missing and default place nicely together", { expect_equal( recode(c(1, 2, NA), "a", .default = "b", .missing = "c"), c("a", "b", "c") ) }) test_that("can give name x", { expect_equal(recode("x", x = "a"), "a") }) test_that(".default works when not all values are named", { x <- rep(1:3, 3) expect_equal(recode(x, `3` = 10L, .default = x), rep(c(1L, 2L, 10L), 3)) }) test_that(".default is aliased to .x when missing and compatible", { x <- letters[1:3] expect_equal(recode(x, a = "A"), c("A", "b", "c")) n <- 1:3 expect_equal(recode(n, `1` = 10L), c(10L, 2L, 3L)) }) test_that(".default is not aliased to .x when missing and not compatible", { x <- letters[1:3] expect_warning(expect_equal(recode(x, a = 1), c(1L, NA, NA))) n <- 1:3 expect_warning(expect_equal(recode(n, `1` = "a"), c("a", NA, NA))) }) test_that("conversion of unreplaced values to NA gives warning", { expect_warning(recode(1:3, `1` = "a"), "treated as NA") expect_warning(recode_factor(letters[1:3], b = 1, c = 2)) }) test_that(".dot argument works correctly (PR #2110)", { x1 <- letters[1:3] x2 <- 1:3 x3 <- factor(x1) expect_equal( recode(x1, a = "apple", b = "banana", .default = NA_character_), recode(x1, .default = NA_character_, !!!list(a = "apple", b = "banana")) ) expect_equal( recode(x1, a = "apple", b = "banana", .default = NA_character_), recode(x1, a = "apple", .default = NA_character_, !!!list(b = "banana")) ) expect_equal( recode(x2, "1" = 4, "2" = 5, .default = NA_real_), recode(x2, .default = NA_real_, !!!list("1" = 4, "2" = 5)) ) expect_equal( recode(x2, "1" = 4, "2" = 5, .default = NA_real_), recode(x2, "1" = 4, .default = NA_real_, !!!list("2" = 5)) ) expect_equal( recode_factor(x3, a = "apple", b = "banana", .default = NA_character_), recode_factor(x3, .default = NA_character_, !!!list(a = "apple", b = "banana")) ) }) # factor ------------------------------------------------------------------ test_that("default .default works with factors", { expect_equal(recode(factor(letters[1:3]), a = "A"), factor(c("A", "b", "c"))) }) test_that("can recode factor to double", { f <- factor(letters[1:3]) expect_equal(recode(f, a = 1, b = 2, c = 3), c(1, 2, 3)) expect_equal(recode(f, a = 1, b = 2), c(1, 2, NA)) expect_equal(recode(f, a = 1, b = 2, .default = 99), c(1, 2, 99)) }) test_that("recode_factor() handles .missing and .default levels", { x <- c(1:3, NA) expect_warning( expect_equal( recode_factor(x, `1` = "z", `2` = "y"), factor(c("z", "y", NA, NA), levels = c("z", "y")) ) ) expect_equal( recode_factor(x, `1` = "z", `2` = "y", .default = "D"), factor(c("z", "y", "D", NA), levels = c("z", "y", "D")) ) expect_equal( recode_factor(x, `1` = "z", `2` = "y", .default = "D", .missing = "M"), factor(c("z", "y", "D", "M"), c("z", "y", "D", "M")) ) }) test_that("recode_factor() handles vector .default", { expected <- factor(c("a", "z", "y"), levels = c("z", "y", "a")) x1 <- letters[1:3] x2 <- factor(x1) expect_equal(recode_factor(x1, b = "z", c = "y"), expected) expect_equal(recode_factor(x2, b = "z", c = "y"), expected) expect_equal(recode_factor(x1, b = "z", c = "y", .default = x1), expected) expect_equal(recode_factor(x2, b = "z", c = "y", .default = x1), expected) }) test_that("can recode factor with redundant levels", { expect_equal( recode(factor(letters[1:4]), d = "c", b = "a"), factor(c("a", "a", "c", "c"), levels = c("a", "c")) ) expect_equal( recode_factor(letters[1:4], d = "c", b = "a"), factor(c("a", "a", "c", "c"), levels = c("c", "a")) ) }) dplyr/tests/testthat/test-copying.R0000644000176200001440000000155113614573562017174 0ustar liggesuserscontext("Copying") test_that("coercion doesn't copy vars", { mtcars2 <- tbl_df(mtcars) mtcars3 <- as.data.frame(mtcars2) expect_equal(location(mtcars2)$vars, location(mtcars)$vars) expect_equal(location(mtcars3)$vars, location(mtcars)$vars) }) test_that("grouping and ungrouping doesn't copy vars", { mtcars2 <- group_by(mtcars, cyl) mtcars3 <- ungroup(mtcars2) expect_equal(location(mtcars2)$vars, location(mtcars)$vars) expect_equal(location(mtcars3)$vars, location(mtcars)$vars) }) test_that("mutate doesn't copy vars", { mtcars2 <- tbl_df(mtcars) mtcars3 <- mutate(mtcars2, cyl2 = cyl * 2) expect_equal(location(mtcars3)$vars[1:11], location(mtcars2)$vars) }) test_that("select doesn't copy vars", { mtcars2 <- tbl_df(mtcars) mtcars3 <- select(mtcars2, carb:mpg) expect_equal(location(mtcars3)$vars[11:1], location(mtcars2)$vars) }) dplyr/tests/testthat/test-between.R0000644000176200001440000000110313614573562017146 0ustar liggesuserscontext("between") test_that("returns NA if any argument is NA", { expect_equal(between(1, 1, NA), NA) expect_equal(between(1, NA, 1), NA) expect_equal(between(NA, 1, 1), NA) }) test_that("compatible with base R", { x <- runif(1e3) expect_equal(between(x, 0.25, 0.5), x >= 0.25 & x <= 0.5) }) test_that("warns when called on S3 object", { expect_warning(between(factor(1:5), 1, 3), "numeric vector with S3 class") }) test_that("unless it's a date or date time", { expect_warning(between(Sys.Date(), 1, 3), NA) expect_warning(between(Sys.time(), 1, 3), NA) }) dplyr/tests/testthat/test-colwise-mutate.R0000644000176200001440000004017313614573562020471 0ustar liggesuserscontext("colwise mutate/summarise") test_that("funs found in current environment", { f <- function(x) 1 df <- data.frame(x = c(2:10, 1000)) with_lifecycle_silence({ out <- summarise_all(df, funs(f, mean, median)) }) expect_equal(out, data.frame(f = 1, mean = 105.4, median = 6.5)) out <- summarise_all(df, list(f = f, mean = mean, median = median)) expect_equal(out, data.frame(f = 1, mean = 105.4, median = 6.5)) # TODO: expect_error(summarise_all(df, list(f, mean, median))) }) test_that("can use character vectors", { df <- data.frame(x = 1:3) scoped_lifecycle_silence() expect_equal(summarise_all(df, "mean"), summarise_all(df, funs(mean))) expect_equal(mutate_all(df, list(mean = "mean")), mutate_all(df, funs(mean = mean))) expect_equal(summarise_all(df, "mean"), summarise_all(df, list(mean))) expect_equal(mutate_all(df, list(mean = "mean")), mutate_all(df, list(mean = mean))) }) test_that("can use bare functions", { df <- data.frame(x = 1:3) scoped_lifecycle_silence() expect_equal(summarise_all(df, mean), summarise_all(df, funs(mean))) expect_equal(mutate_all(df, mean), mutate_all(df, funs(mean))) expect_equal(summarise_all(df, mean), summarise_all(df, list(mean))) expect_equal(mutate_all(df, mean), mutate_all(df, list(mean))) }) test_that("default names are smallest unique set", { df <- data.frame(x = 1:3, y = 1:3) scoped_lifecycle_silence() expect_named(summarise_at(df, vars(x:y), funs(mean)), c("x", "y")) expect_named(summarise_at(df, vars(x), funs(mean, sd)), c("mean", "sd")) expect_named(summarise_at(df, vars(x:y), funs(mean, sd)), c("x_mean", "y_mean", "x_sd", "y_sd")) expect_named(summarise_at(df, vars(x = x), funs(mean, sd)), c("x_mean", "x_sd")) expect_named(summarise_at(df, vars(x:y), list(mean)), c("x", "y")) expect_named(summarise_at(df, vars(x), list(mean = mean, sd = sd)), c("mean", "sd")) expect_named(summarise_at(df, vars(x:y), list(mean = mean, sd = sd)), c("x_mean", "y_mean", "x_sd", "y_sd")) expect_named(summarise_at(df, vars(x:y), funs(base::mean, stats::sd)), c("x_base::mean", "y_base::mean", "x_stats::sd", "y_stats::sd")) }) test_that("named arguments force complete named", { scoped_lifecycle_silence() df <- data.frame(x = 1:3, y = 1:3) expect_named(summarise_at(df, vars(x:y), funs(mean = mean)), c("x_mean", "y_mean")) expect_named(summarise_at(df, vars(x = x), funs(mean = mean, sd = sd)), c("x_mean", "x_sd")) expect_named(summarise_at(df, vars(x:y), list(mean = mean)), c("x_mean", "y_mean")) expect_named(summarise_at(df, vars(x = x), list(mean = mean, sd = sd)), c("x_mean", "x_sd")) }) expect_classes <- function(tbl, expected) { classes <- unname(map_chr(tbl, class)) classes <- paste0(substring(classes, 0, 1), collapse = "") expect_equal(classes, expected) } test_that("can select colwise", { columns <- iris %>% mutate_at(NULL, as.character) expect_classes(columns, "nnnnf") columns <- iris %>% mutate_at(vars(starts_with("Petal")), as.character) expect_classes(columns, "nnccf") numeric <- iris %>% mutate_at(c(1, 3), as.character) expect_classes(numeric, "cncnf") character <- iris %>% mutate_at("Species", as.character) expect_classes(character, "nnnnc") }) test_that("can probe colwise", { predicate <- iris %>% mutate_if(is.factor, as.character) expect_classes(predicate, "nnnnc") logical <- iris %>% mutate_if(c(TRUE, FALSE, TRUE, TRUE, FALSE), as.character) expect_classes(logical, "cnccf") }) test_that("non syntactic colnames work", { df <- tibble(`x 1` = 1:3) expect_identical(summarise_at(df, "x 1", sum)[[1]], 6L) expect_identical(summarise_if(df, is.numeric, sum)[[1]], 6L) expect_identical(summarise_all(df, sum)[[1]], 6L) expect_identical(mutate_all(df, `*`, 2)[[1]], (1:3) * 2) }) test_that("empty selection does not select everything (#2009, #1989)", { expect_equal( tibble::remove_rownames(mtcars), tibble::remove_rownames(mutate_if(mtcars, is.factor, as.character)) ) }) test_that("error is thrown with improper additional arguments", { # error messages by base R, not checked expect_error(mutate_all(mtcars, round, 0, 0)) expect_error(mutate_all(mtcars, mean, na.rm = TRUE, na.rm = TRUE)) }) test_that("predicate can be quoted", { expected <- mutate_if(mtcars, is_integerish, mean) expect_identical(mutate_if(mtcars, "is_integerish", mean), expected) expect_identical(mutate_if(mtcars, ~ is_integerish(.x), mean), expected) }) test_that("transmute verbs do not retain original variables", { scoped_lifecycle_silence() expect_named(transmute_all(tibble(x = 1:3, y = 1:3), funs(mean, sd)), c("x_mean", "y_mean", "x_sd", "y_sd")) expect_named(transmute_if(tibble(x = 1:3, y = 1:3), is_integer, funs(mean, sd)), c("x_mean", "y_mean", "x_sd", "y_sd")) expect_named(transmute_at(tibble(x = 1:3, y = 1:3), vars(x:y), funs(mean, sd)), c("x_mean", "y_mean", "x_sd", "y_sd")) expect_named(transmute_all(tibble(x = 1:3, y = 1:3), list(mean = mean, sd = sd)), c("x_mean", "y_mean", "x_sd", "y_sd")) expect_named(transmute_if(tibble(x = 1:3, y = 1:3), is_integer, list(mean = mean, sd = sd)), c("x_mean", "y_mean", "x_sd", "y_sd")) expect_named(transmute_at(tibble(x = 1:3, y = 1:3), vars(x:y), list(mean = mean, sd = sd)), c("x_mean", "y_mean", "x_sd", "y_sd")) }) test_that("can rename with vars() (#2594)", { expect_equal(mutate_at(tibble(x = 1:3), vars(y = x), mean), tibble(x = 1:3, y = c(2, 2, 2))) }) test_that("selection works with grouped data frames (#2624)", { gdf <- group_by(iris, Species) expect_identical(mutate_if(gdf, is.factor, as.character), gdf) }) test_that("at selection works even if not all ops are named (#2634)", { scoped_lifecycle_silence() df <- tibble(x = 1, y = 2) expect_identical(mutate_at(df, vars(z = x, y), funs(. + 1)), tibble(x = 1, y = 3, z = 2)) expect_identical(mutate_at(df, vars(z = x, y), list(~. + 1)), tibble(x = 1, y = 3, z = 2)) }) test_that("can use a purrr-style lambda", { expect_identical(summarise_at(mtcars, vars(1:2), ~ mean(.x)), summarise(mtcars, mpg = mean(mpg), cyl = mean(cyl))) }) test_that("mutate_at and transmute_at refuses to mutate a grouping variable (#3351, #3480)", { tbl <- tibble(gr1 = rep(1:2, 4), gr2 = rep(1:2, each = 4), x = 1:8) %>% group_by(gr1) expect_error( mutate_at(tbl, vars(gr1), sqrt), "Column `gr1` can't be modified because it's a grouping variable", fixed = TRUE ) expect_error( transmute_at(tbl, vars(gr1), sqrt), "Column `gr1` can't be modified because it's a grouping variable", fixed = TRUE ) }) test_that("mutate and transmute variants does not mutate grouping variable (#3351, #3480)", { tbl <- tibble(gr1 = rep(1:2, 4), gr2 = rep(1:2, each = 4), x = 1:8) %>% group_by(gr1) res <- mutate(tbl, gr2 = sqrt(gr2), x = sqrt(x)) expect_message(expect_identical(mutate_all(tbl, sqrt), res), "ignored") expect_message(expect_identical(transmute_all(tbl, sqrt), res), "ignored") expect_message(expect_identical(mutate_if(tbl, is.integer, sqrt), res), "ignored") expect_message(expect_identical(transmute_if(tbl, is.integer, sqrt), res), "ignored") expect_identical(transmute_at(tbl, vars(-group_cols()), sqrt), res) expect_identical(mutate_at(tbl, vars(-group_cols()), sqrt), res) }) test_that("summarise_at refuses to treat grouping variables (#3351, #3480)", { tbl <- tibble(gr1 = rep(1:2, 4), gr2 = rep(1:2, each = 4), x = 1:8) %>% group_by(gr1) expect_error( summarise_at(tbl, vars(gr1), mean) ) }) test_that("summarise variants does not summarise grouping variable (#3351, #3480)", { tbl <- tibble(gr1 = rep(1:2, 4), gr2 = rep(1:2, each = 4), x = 1:8) %>% group_by(gr1) res <- summarise(tbl, gr2 = mean(gr2), x = mean(x)) expect_identical(summarise_all(tbl, mean), res) expect_identical(summarise_if(tbl, is.integer, mean), res) }) test_that("summarise_at removes grouping variables (#3613)", { d <- tibble( x = 1:2, y = 3:4, g = 1:2) %>% group_by(g) res <- d %>% group_by(g) %>% summarise_at(-1, mean) expect_equal(names(res), c("g", "y")) }) # Deprecated --------------------------------------------------------- test_that("_each() and _all() families agree", { scoped_lifecycle_silence() df <- data.frame(x = 1:3, y = 1:3) expect_equal(summarise_each(df, funs(mean)), summarise_all(df, mean)) expect_equal(summarise_each(df, funs(mean), x), summarise_at(df, vars(x), mean)) expect_equal(summarise_each(df, funs(mean = mean), x), summarise_at(df, vars(x), funs(mean = mean))) expect_equal(summarise_each(df, funs(mean = mean), x:y), summarise_at(df, vars(x:y), funs(mean = mean))) expect_equal(summarise_each(df, funs(mean), x:y), summarise_at(df, vars(x:y), mean)) expect_equal(summarise_each(df, funs(mean), z = y), summarise_at(df, vars(z = y), mean)) expect_equal(summarise_each(df, list(mean)), summarise_all(df, mean)) expect_equal(summarise_each(df, list(mean), x), summarise_at(df, vars(x), mean)) expect_equal(summarise_each(df, list(mean = mean), x), summarise_at(df, vars(x), list(mean = mean))) expect_equal(summarise_each(df, list(mean = mean), x:y), summarise_at(df, vars(x:y), list(mean = mean))) expect_equal(summarise_each(df, list(mean), x:y), summarise_at(df, vars(x:y), mean)) expect_equal(summarise_each(df, list(mean), z = y), summarise_at(df, vars(z = y), mean)) expect_equal(mutate_each(df, funs(mean)), mutate_all(df, mean)) expect_equal(mutate_each(df, funs(mean), x), mutate_at(df, vars(x), mean)) expect_equal(mutate_each(df, funs(mean = mean), x), mutate_at(df, vars(x), funs(mean = mean))) expect_equal(mutate_each(df, funs(mean = mean), x:y), mutate_at(df, vars(x:y), funs(mean = mean))) expect_equal(mutate_each(df, funs(mean), x:y), mutate_at(df, vars(x:y), mean)) expect_equal(mutate_each(df, funs(mean), z = y), mutate_at(df, vars(z = y), mean)) expect_equal(mutate_each(df, list(mean)), mutate_all(df, mean)) expect_equal(mutate_each(df, list(mean), x), mutate_at(df, vars(x), mean)) expect_equal(mutate_each(df, list(mean = mean), x), mutate_at(df, vars(x), list(mean = mean))) expect_equal(mutate_each(df, list(mean = mean), x:y), mutate_at(df, vars(x:y), list(mean = mean))) expect_equal(mutate_each(df, list(mean), x:y), mutate_at(df, vars(x:y), mean)) expect_equal(mutate_each(df, list(mean), z = y), mutate_at(df, vars(z = y), mean)) }) test_that("group_by_(at,all) handle utf-8 names (#3829)", { skip_if(getRversion() <= "3.4.0") withr::with_locale( c(LC_CTYPE = "C"), { name <- "\u4e2d" tbl <- tibble(a = 1) %>% setNames(name) res <- group_by_all(tbl) %>% groups() expect_equal(res[[1]], sym(name)) res <- group_by_at(tbl, name) %>% groups() expect_equal(res[[1]], sym(name)) }) }) test_that("*_(all,at) handle utf-8 names (#2967)", { skip_if(getRversion() <= "3.4.0") scoped_lifecycle_silence() withr::with_locale( c(LC_CTYPE = "C"), { name <- "\u4e2d" tbl <- tibble(a = 1) %>% setNames(name) res <- tbl %>% mutate_all(funs(as.character)) %>% names() expect_equal(res, name) res <- tbl %>% mutate_at(name, funs(as.character)) %>% names() expect_equal(res, name) res <- tbl %>% summarise_all(funs(as.character)) %>% names() expect_equal(res, name) res <- tbl %>% summarise_at(name, funs(as.character)) %>% names() expect_equal(res, name) res <- tbl %>% mutate_all(list(as.character)) %>% names() expect_equal(res, name) res <- tbl %>% mutate_at(name, list(as.character)) %>% names() expect_equal(res, name) res <- tbl %>% summarise_all(list(as.character)) %>% names() expect_equal(res, name) res <- tbl %>% summarise_at(name, list(as.character)) %>% names() expect_equal(res, name) res <- select_at(tbl, name) %>% names() expect_equal(res, name) }) }) test_that("mutate_all() handles non syntactic names (#4094)", { skip("for now, will fix this after 0.8.0") tbl <- tibble(`..1` = "a") res <- mutate_all(tbl, toupper) expect_equal(names(tbl), names(res)) expect_equal(res[["..1"]], "A") }) test_that("summarise_at with multiple columns AND unnamed functions works (#4119)", { res <- storms %>% summarise_at(vars(wind, pressure), list(mean, median)) expect_equal(ncol(res), 4L) expect_equal(names(res), c("wind_fn1", "pressure_fn1", "wind_fn2", "pressure_fn2")) res <- storms %>% summarise_at(vars(wind, pressure), list(n = length, mean, median)) expect_equal(ncol(res), 6L) expect_equal(names(res), c("wind_n", "pressure_n", "wind_fn1", "pressure_fn1", "wind_fn2", "pressure_fn2")) }) test_that("mutate_at with multiple columns AND unnamed functions works (#4119)", { res <- storms %>% mutate_at(vars(wind, pressure), list(mean, median)) expect_equal(ncol(res), ncol(storms) + 4L) expect_equal( names(res), c(names(storms), c("wind_fn1", "pressure_fn1", "wind_fn2", "pressure_fn2")) ) }) test_that("colwise mutate have .data in scope of rlang lambdas (#4183)", { results <- list( iris %>% mutate_if(is.numeric, ~ . / iris$Petal.Width), iris %>% mutate_if(is.numeric, ~ . / Petal.Width), iris %>% mutate_if(is.numeric, ~ . / .data$Petal.Width), iris %>% mutate_if(is.numeric, list(~ . / iris$Petal.Width )), iris %>% mutate_if(is.numeric, list(~ . / Petal.Width )), iris %>% mutate_if(is.numeric, list(~ . / .data$Petal.Width)), iris %>% mutate_if(is.numeric, ~ .x / iris$Petal.Width), iris %>% mutate_if(is.numeric, ~ .x / Petal.Width), iris %>% mutate_if(is.numeric, ~ .x / .data$Petal.Width), iris %>% mutate_if(is.numeric, list(~ .x / iris$Petal.Width )), iris %>% mutate_if(is.numeric, list(~ .x / Petal.Width )), iris %>% mutate_if(is.numeric, list(~ .x / .data$Petal.Width)) ) for(i in 2:12) { expect_equal(results[[1]], results[[i]]) } }) test_that("can choose the name of vars with multiple funs (#4180)", { expect_identical( mtcars %>% group_by(cyl) %>% summarise_at(vars(DISP = disp), list(mean = mean, median = median)), mtcars %>% group_by(cyl) %>% summarise(DISP_mean = mean(disp), DISP_median = median(disp)) ) }) test_that("summarise_at() unquotes in lambda (#4287)", { df <- tibble::tibble(year = seq(2015, 2050, 5), P = 5.0 + 2.5 * year) year <- 2037 expect_equal( summarise_at(df, vars(-year), ~approx(x = year, y = ., xout = !!year)$y), summarise(df, P = approx(x = year, y = P, xout = !!year)$y) ) }) test_that("mutate_at() unquotes in lambdas (#4199)", { df <- tibble(a = 1:10, b = runif(1:10), c = letters[1:10]) varname <- "a" symname <- rlang::sym(varname) quoname <- enquo(symname) expect_identical( df %>% mutate(b = mean(!!quoname)), df %>% mutate_at(vars(matches("b")), list(~mean(!!quoname))) ) }) test_that("summarise_at() can refer to local variables and columns (#4304)", { # using local here in case someone wants to run the content of the test # as opposed to the test_that() call res <- local({ value <- 10 expect_identical( iris %>% summarise_at("Sepal.Length", ~ sum(. / value)), iris %>% summarise(Sepal.Length = sum(Sepal.Length / value)) ) }) }) test_that("colwise mutate handles formulas with constants (#4374)", { expect_identical( tibble(x = 12) %>% mutate_all(~ 42), tibble(x = 42) ) expect_identical( tibble(x = 12) %>% mutate_at("x", ~ 42), tibble(x = 42) ) }) test_that("colwise mutate gives correct error message if column not found (#4374)", { expect_error( mutate_at(tibble(), "test", ~ 1), "column.*test" # either: "Unknown column `test`" # or: "Can't subset columns that don't exist.\n\033[31mx\033[39m The column `test` doesn't exist." # # depending on which tidyselect is installed ) }) test_that("colwise mutate handle named chr vectors", { res <- tibble(x = 1:10) %>% mutate_at(c(y = "x"), mean) expect_identical(res, tibble(x = 1:10, y = 5.5)) }) test_that("colwise verbs soft deprecate quosures (#4330)", { with_lifecycle_errors({ expect_error( mutate_at(mtcars, vars(mpg), quo(mean(.))) ) expect_error( summarise_at(mtcars, vars(mpg), quo(mean(.))) ) }) expect_equal( transmute_at(mtcars, vars(mpg), ~. > mean(.)), transmute_at(mtcars, vars(mpg), quo(. > mean(.))) ) }) dplyr/tests/testthat/test-data_frame.R0000644000176200001440000000046513614573562017612 0ustar liggesuserscontext("data_frame") # add_rownames ----------------------------------------------------------- test_that("add_rownames keeps the tbl classes (#882)", { expect_warning( res <- mtcars %>% add_rownames("Make&Model"), "Deprecated" ) expect_equal(class(res), c("tbl_df", "tbl", "data.frame")) }) dplyr/tests/testthat/test-joins.r0000644000176200001440000010613613614573562016713 0ustar liggesuserscontext("Joins") # Univariate keys -------------------------------------------------------------- a <- data.frame(x = c(1, 1, 2, 3), y = 1:4) b <- data.frame(x = c(1, 2, 2, 4), z = 1:4) test_that("univariate inner join has all columns, repeated matching rows", { j <- inner_join(a, b, "x") expect_equal(names(j), c("x", "y", "z")) expect_equal(j$y, c(1, 2, 3, 3)) expect_equal(j$z, c(1, 1, 2, 3)) }) test_that("univariate left join has all columns, all rows", { j1 <- left_join(a, b, "x") j2 <- left_join(b, a, "x") expect_equal(names(j1), c("x", "y", "z")) expect_equal(names(j2), c("x", "z", "y")) expect_equal(j1$z, c(1, 1, 2, 3, NA)) expect_equal(j2$y, c(1, 2, 3, 3, NA)) }) test_that("univariate semi join has x columns, matching rows", { j1 <- semi_join(a, b, "x") j2 <- semi_join(b, a, "x") expect_equal(names(j1), c("x", "y")) expect_equal(names(j2), c("x", "z")) expect_equal(j1$y, 1:3) expect_equal(j2$z, 1:3) }) test_that("univariate anti join has x columns, missing rows", { j1 <- anti_join(a, b, "x") j2 <- anti_join(b, a, "x") expect_equal(names(j1), c("x", "y")) expect_equal(names(j2), c("x", "z")) expect_equal(j1$y, 4) expect_equal(j2$z, 4) }) test_that("univariate right join has all columns, all rows", { j1 <- right_join(a, b, "x") j2 <- right_join(b, a, "x") expect_equal(names(j1), c("x", "y", "z")) expect_equal(names(j2), c("x", "z", "y")) expect_equal(j1$x, c(1, 1, 2, 2, 4)) expect_equal(j1$y, c(1, 2, 3, 3, NA)) expect_equal(j1$z, c(1, 1, 2, 3, 4)) expect_equal(j2$x, c(1, 1, 2, 2, 3)) expect_equal(j2$y, c(1, 2, 3, 3, 4)) expect_equal(j2$z, c(1, 1, 2, 3, NA)) }) # Bivariate keys --------------------------------------------------------------- c <- data.frame( x = c(1, 1, 2, 3), y = c(1, 1, 2, 3), a = 1:4 ) d <- data.frame( x = c(1, 2, 2, 4), y = c(1, 2, 2, 4), b = 1:4 ) test_that("bivariate inner join has all columns, repeated matching rows", { j <- inner_join(c, d, c("x", "y")) expect_equal(names(j), c("x", "y", "a", "b")) expect_equal(j$a, c(1, 2, 3, 3)) expect_equal(j$b, c(1, 1, 2, 3)) }) test_that("bivariate left join has all columns, all rows", { j1 <- left_join(c, d, c("x", "y")) j2 <- left_join(d, c, c("x", "y")) expect_equal(names(j1), c("x", "y", "a", "b")) expect_equal(names(j2), c("x", "y", "b", "a")) expect_equal(j1$b, c(1, 1, 2, 3, NA)) expect_equal(j2$a, c(1, 2, 3, 3, NA)) }) test_that("bivariate semi join has x columns, matching rows", { j1 <- semi_join(c, d, c("x", "y")) j2 <- semi_join(d, c, c("x", "y")) expect_equal(names(j1), c("x", "y", "a")) expect_equal(names(j2), c("x", "y", "b")) expect_equal(j1$a, 1:3) expect_equal(j2$b, 1:3) }) test_that("bivariate anti join has x columns, missing rows", { j1 <- anti_join(c, d, c("x", "y")) j2 <- anti_join(d, c, c("x", "y")) expect_equal(names(j1), c("x", "y", "a")) expect_equal(names(j2), c("x", "y", "b")) expect_equal(j1$a, 4) expect_equal(j2$b, 4) }) # Duplicate column names -------------------------------------------------- e <- data.frame(x = c(1, 1, 2, 3), z = 1:4) f <- data.frame(x = c(1, 2, 2, 4), z = 1:4) test_that("univariate inner join has all columns, repeated matching rows", { j <- inner_join(e, f, "x") expect_equal(names(j), c("x", "z.x", "z.y")) expect_equal(j$z.x, c(1, 2, 3, 3)) expect_equal(j$z.y, c(1, 1, 2, 3)) }) test_that("univariate left join has all columns, all rows", { j1 <- left_join(e, f, "x") j2 <- left_join(f, e, "x") expect_equal(names(j1), c("x", "z.x", "z.y")) expect_equal(names(j2), c("x", "z.x", "z.y")) expect_equal(j1$z.y, c(1, 1, 2, 3, NA)) expect_equal(j2$z.y, c(1, 2, 3, 3, NA)) }) test_that("can control suffixes with suffix argument", { j1 <- inner_join(e, f, "x", suffix = c("1", "2")) j2 <- left_join(e, f, "x", suffix = c("1", "2")) j3 <- right_join(e, f, "x", suffix = c("1", "2")) j4 <- full_join(e, f, "x", suffix = c("1", "2")) expect_named(j1, c("x", "z1", "z2")) expect_named(j2, c("x", "z1", "z2")) expect_named(j3, c("x", "z1", "z2")) expect_named(j4, c("x", "z1", "z2")) }) test_that("can handle empty string in suffix argument, left side (#2228, #2182, #2007)", { j1 <- inner_join(e, f, "x", suffix = c("", "2")) j2 <- left_join(e, f, "x", suffix = c("", "2")) j3 <- right_join(e, f, "x", suffix = c("", "2")) j4 <- full_join(e, f, "x", suffix = c("", "2")) expect_named(j1, c("x", "z", "z2")) expect_named(j2, c("x", "z", "z2")) expect_named(j3, c("x", "z", "z2")) expect_named(j4, c("x", "z", "z2")) }) test_that("can handle empty string in suffix argument, right side (#2228, #2182, #2007)", { j1 <- inner_join(e, f, "x", suffix = c("1", "")) j2 <- left_join(e, f, "x", suffix = c("1", "")) j3 <- right_join(e, f, "x", suffix = c("1", "")) j4 <- full_join(e, f, "x", suffix = c("1", "")) expect_named(j1, c("x", "z1", "z")) expect_named(j2, c("x", "z1", "z")) expect_named(j3, c("x", "z1", "z")) expect_named(j4, c("x", "z1", "z")) }) test_that("disallow empty string in both sides of suffix argument (#2228)", { expect_error( inner_join(e, f, "x", suffix = c("", "")), "`suffix` can't be empty string for both `x` and `y` suffixes", fixed = TRUE ) expect_error( left_join(e, f, "x", suffix = c("", "")), "`suffix` can't be empty string for both `x` and `y` suffixes", fixed = TRUE ) expect_error( right_join(e, f, "x", suffix = c("", "")), "`suffix` can't be empty string for both `x` and `y` suffixes", fixed = TRUE ) expect_error( full_join(e, f, "x", suffix = c("", "")), "`suffix` can't be empty string for both `x` and `y` suffixes", fixed = TRUE ) }) test_that("disallow NA in any side of suffix argument", { expect_error( inner_join(e, f, "x", suffix = c(".x", NA)), "`suffix` can't be NA", fixed = TRUE ) expect_error( left_join(e, f, "x", suffix = c(NA, ".y")), "`suffix` can't be NA", fixed = TRUE ) expect_error( right_join(e, f, "x", suffix = c(NA_character_, NA)), "`suffix` can't be NA", fixed = TRUE ) expect_error( full_join(e, f, "x", suffix = c("x", NA)), "`suffix` can't be NA", fixed = TRUE ) }) test_that("doesn't add suffix to by columns in x (#3307)", { j1 <- inner_join(e, f, by = c("x" = "z")) j2 <- left_join(e, f, by = c("x" = "z")) j3 <- right_join(e, f, by = c("x" = "z")) j4 <- full_join(e, f, by = c("x" = "z")) expect_named(j1, c("x", "z", "x.y")) expect_named(j2, c("x", "z", "x.y")) expect_named(j3, c("x", "z", "x.y")) expect_named(j4, c("x", "z", "x.y")) }) g <- data.frame(A = 1, A.x = 2) h <- data.frame(B = 3, A.x = 4, A = 5) test_that("can handle 'by' columns with suffix (#3266)", { j1 <- inner_join(g, h, "A.x") j2 <- left_join(g, h, "A.x") j3 <- right_join(g, h, "A.x") j4 <- full_join(g, h, "A.x") expect_named(j1, c("A.x.x", "A.x", "B", "A.y")) expect_named(j2, c("A.x.x", "A.x", "B", "A.y")) expect_named(j3, c("A.x.x", "A.x", "B", "A.y")) expect_named(j4, c("A.x.x", "A.x", "B", "A.y")) }) test_that("can handle 'by' columns with suffix, reverse (#3266)", { j1 <- inner_join(h, g, "A.x") j2 <- left_join(h, g, "A.x") j3 <- right_join(h, g, "A.x") j4 <- full_join(h, g, "A.x") expect_named(j1, c("B", "A.x", "A.x.x", "A.y")) expect_named(j2, c("B", "A.x", "A.x.x", "A.y")) expect_named(j3, c("B", "A.x", "A.x.x", "A.y")) expect_named(j4, c("B", "A.x", "A.x.x", "A.y")) }) test_that("check suffix input", { expect_error( inner_join(e, f, "x", suffix = letters[1:3]), "`suffix` must be a character vector of length 2, not a character vector of length 3", fixed = TRUE ) expect_error( inner_join(e, f, "x", suffix = letters[1]), "`suffix` must be a character vector of length 2, not a character vector of length 1", fixed = TRUE ) expect_error( inner_join(e, f, "x", suffix = 1:2), "`suffix` must be a character vector of length 2, not an integer vector of length 2", fixed = TRUE ) }) # Misc -------------------------------------------------------------------- test_that("inner_join does not segfault on NA in factors (#306)", { a <- data.frame(x = c("p", "q", NA), y = c(1, 2, 3), stringsAsFactors = TRUE) b <- data.frame(x = c("p", "q", "r"), z = c(4, 5, 6), stringsAsFactors = TRUE) expect_warning(res <- inner_join(a, b, "x"), "joining factors with different levels") expect_equal(nrow(res), 2L) }) test_that("joins don't reorder columns #328", { a <- data.frame(a = 1:3) b <- data.frame(a = 1:3, b = 1, c = 2, d = 3, e = 4, f = 5) res <- left_join(a, b, "a") expect_equal(names(res), names(b)) }) test_that("join handles type promotions #123", { df <- data.frame( V1 = c(rep("a", 5), rep("b", 5)), V2 = rep(c(1:5), 2), V3 = c(101:110), stringsAsFactors = FALSE ) match <- data.frame( V1 = c("a", "b"), V2 = c(3.0, 4.0), stringsAsFactors = FALSE ) res <- semi_join(df, match, c("V1", "V2")) expect_equal(res$V2, 3:4) expect_equal(res$V3, c(103L, 109L)) }) test_that("indices don't get mixed up when nrow(x) > nrow(y). #365", { a <- data.frame(V1 = c(0, 1, 2), V2 = c("a", "b", "c"), stringsAsFactors = FALSE) b <- data.frame(V1 = c(0, 1), V3 = c("n", "m"), stringsAsFactors = FALSE) res <- inner_join(a, b, by = "V1") expect_equal(res$V1, c(0, 1)) expect_equal(res$V2, c("a", "b")) expect_equal(res$V3, c("n", "m")) }) test_that("join functions error on column not found #371", { expect_error( left_join(data.frame(x = 1:5), data.frame(y = 1:5), by = "x"), "`by` can't contain join column `x` which is missing from RHS", fixed = TRUE ) expect_error( left_join(data.frame(x = 1:5), data.frame(y = 1:5), by = "y"), "`by` can't contain join column `y` which is missing from LHS", fixed = TRUE ) expect_error( left_join(data.frame(x = 1:5), data.frame(y = 1:5)), "`by` required, because the data sources have no common variables", fixed = TRUE ) expect_error( left_join(data.frame(x = 1:5), data.frame(y = 1:5), by = 1:3), "`by` must be a (named) character vector, list, or NULL for natural joins (not recommended in production code), not an integer vector", fixed = TRUE ) }) test_that("inner_join is symmetric (even when joining on character & factor)", { foo <- tibble(id = factor(c("a", "b")), var1 = "foo") bar <- tibble(id = c("a", "b"), var2 = "bar") expect_warning(tmp1 <- inner_join(foo, bar, by = "id"), "joining factor and character") expect_warning(tmp2 <- inner_join(bar, foo, by = "id"), "joining character vector and factor") expect_is(tmp1$id, "character") expect_is(tmp2$id, "character") expect_equal(names(tmp1), c("id", "var1", "var2")) expect_equal(names(tmp2), c("id", "var2", "var1")) expect_equal(tmp1, tmp2) }) test_that("inner_join is symmetric, even when type of join var is different (#450)", { foo <- tbl_df(data.frame(id = 1:10, var1 = "foo")) bar <- tbl_df(data.frame(id = as.numeric(rep(1:10, 5)), var2 = "bar")) tmp1 <- inner_join(foo, bar, by = "id") tmp2 <- inner_join(bar, foo, by = "id") expect_equal(names(tmp1), c("id", "var1", "var2")) expect_equal(names(tmp2), c("id", "var2", "var1")) expect_equal(tmp1, tmp2) }) test_that("left_join by different variable names (#617)", { x <- tibble(x1 = c(1, 3, 2)) y <- tibble(y1 = c(1, 2, 3), y2 = c("foo", "foo", "bar")) res <- left_join(x, y, by = c("x1" = "y1")) expect_equal(names(res), c("x1", "y2")) expect_equal(res$x1, c(1, 3, 2)) expect_equal(res$y2, c("foo", "bar", "foo")) }) test_that("joins support complex vectors", { a <- data.frame(x = c(1, 1, 2, 3) * 1i, y = 1:4) b <- data.frame(x = c(1, 2, 2, 4) * 1i, z = 1:4) j <- inner_join(a, b, "x") expect_equal(names(j), c("x", "y", "z")) expect_equal(j$y, c(1, 2, 3, 3)) expect_equal(j$z, c(1, 1, 2, 3)) }) test_that("joins suffix variable names (#655)", { a <- data.frame(x = 1:10, y = 2:11) b <- data.frame(z = 5:14, x = 3:12) # x from this gets suffixed by .y res <- left_join(a, b, by = c("x" = "z")) expect_equal(names(res), c("x", "y", "x.y")) a <- data.frame(x = 1:10, z = 2:11) b <- data.frame(z = 5:14, x = 3:12) # x from this gets suffixed by .y res <- left_join(a, b, by = c("x" = "z")) expect_equal(names(res), c("x", "z", "x.y")) }) test_that("right_join gets the column in the right order #96", { a <- data.frame(x = 1:10, y = 2:11) b <- data.frame(x = 5:14, z = 3:12) res <- right_join(a, b) expect_equal(names(res), c("x", "y", "z")) a <- data.frame(x = 1:10, y = 2:11) b <- data.frame(z = 5:14, a = 3:12) res <- right_join(a, b, by = c("x" = "z")) expect_equal(names(res), c("x", "y", "a")) }) test_that("full_join #96", { a <- data.frame(x = 1:3, y = 2:4) b <- data.frame(x = 3:5, z = 3:5) res <- full_join(a, b, "x") expect_equal(res$x, 1:5) expect_equal(res$y[1:3], 2:4) expect_true(all(is.na(res$y[4:5]))) expect_true(all(is.na(res$z[1:2]))) expect_equal(res$z[3:5], 3:5) }) test_that("JoinStringFactorVisitor and JoinFactorStringVisitor handle NA #688", { x <- data.frame(Greek = c("Alpha", "Beta", NA), numbers = 1:3) y <- data.frame( Greek = c("Alpha", "Beta", "Gamma"), Letters = c("C", "B", "C"), stringsAsFactors = F ) expect_warning( res <- left_join(x, y, by = "Greek"), "Column `Greek` joining factor and character vector, coercing into character vector", fixed = TRUE ) expect_true(is.na(res$Greek[3])) expect_true(is.na(res$Letters[3])) expect_equal(res$numbers, 1:3) expect_warning( res <- left_join(y, x, by = "Greek"), "Column `Greek` joining character vector and factor, coercing into character vector", fixed = TRUE ) expect_equal(res$Greek, y$Greek) expect_equal(res$Letters, y$Letters) expect_equal(res$numbers[1:2], 1:2) expect_true(is.na(res$numbers[3])) }) test_that("JoinFactorFactorVisitor_SameLevels preserve levels order (#675)", { input <- data.frame(g1 = factor(c("A", "B", "C"), levels = c("B", "A", "C"))) output <- data.frame( g1 = factor(c("A", "B", "C"), levels = c("B", "A", "C")), g2 = factor(c("A", "B", "C"), levels = c("B", "A", "C")) ) res <- inner_join(group_by(input, g1), group_by(output, g1)) expect_equal(levels(res$g1), levels(input$g1)) expect_equal(levels(res$g2), levels(output$g2)) }) test_that("inner_join does not reorder (#684)", { test <- tibble(Greek = c("Alpha", "Beta", "Gamma"), Letters = LETTERS[1:3]) lookup <- tibble(Letters = c("C", "B", "C")) res <- inner_join(lookup, test) expect_equal(res$Letters, c("C", "B", "C")) }) test_that("joins coerce factors with different levels to character (#684)", { d1 <- tibble(a = factor(c("a", "b", "c"))) d2 <- tibble(a = factor(c("a", "e"))) expect_warning(res <- inner_join(d1, d2)) expect_is(res$a, "character") # different orders d2 <- d1 attr(d2$a, "levels") <- c("c", "b", "a") expect_warning(res <- inner_join(d1, d2)) expect_is(res$a, "character") }) test_that("joins between factor and character coerces to character with a warning (#684)", { d1 <- tibble(a = factor(c("a", "b", "c"))) d2 <- tibble(a = c("a", "e")) expect_warning(res <- inner_join(d1, d2)) expect_is(res$a, "character") expect_warning(res <- inner_join(d2, d1)) expect_is(res$a, "character") }) test_that("group column names reflect renamed duplicate columns (#2330)", { d1 <- tibble(x = 1:5, y = 1:5) %>% group_by(x, y) d2 <- tibble(x = 1:5, y = 1:5) res <- inner_join(d1, d2, by = "x") expect_groups(d1, c("x", "y")) expect_groups(res, c("x", "y.x")) }) test_that("group column names are null when joined data frames are not grouped (#2330)", { d1 <- tibble(x = 1:5, y = 1:5) d2 <- tibble(x = 1:5, y = 1:5) res <- inner_join(d1, d2, by = "x") expect_no_groups(res) }) # Guessing variables in x and y ------------------------------------------------ test_that("unnamed vars are the same in both tables", { by1 <- common_by_from_vector(c("x", "y", "z")) expect_equal(by1$x, c("x", "y", "z")) expect_equal(by1$y, c("x", "y", "z")) by2 <- common_by_from_vector(c("x" = "a", "y", "z")) expect_equal(by2$x, c("x", "y", "z")) expect_equal(by2$y, c("a", "y", "z")) }) test_that("join columns are not moved to the left (#802)", { df1 <- data.frame(x = 1, y = 1:5) df2 <- data.frame(y = 1:5, z = 2) out <- left_join(df1, df2) expect_equal(names(out), c("x", "y", "z")) }) test_that("join can handle multiple encodings (#769)", { text <- c("\xC9lise", "Pierre", "Fran\xE7ois") Encoding(text) <- "latin1" x <- tibble(name = text, score = c(5, 7, 6)) y <- tibble(name = text, attendance = c(8, 10, 9)) res <- left_join(x, y, by = "name") expect_equal(nrow(res), 3L) expect_equal(res$name, x$name) x <- tibble(name = factor(text), score = c(5, 7, 6)) y <- tibble(name = text, attendance = c(8, 10, 9)) res <- suppressWarnings(left_join(x, y, by = "name")) expect_equal(nrow(res), 3L) expect_equal(res$name, y$name) x <- tibble(name = text, score = c(5, 7, 6)) y <- tibble(name = factor(text), attendance = c(8, 10, 9)) res <- suppressWarnings(left_join(x, y, by = "name")) expect_equal(nrow(res), 3L) expect_equal(res$name, x$name) x <- tibble(name = factor(text), score = c(5, 7, 6)) y <- tibble(name = factor(text), attendance = c(8, 10, 9)) res <- suppressWarnings(left_join(x, y, by = "name")) expect_equal(nrow(res), 3L) expect_equal(res$name, x$name) }) test_that("join creates correctly named results (#855)", { x <- data.frame(q = c("a", "b", "c"), r = c("d", "e", "f"), s = c("1", "2", "3")) y <- data.frame(q = c("a", "b", "c"), r = c("d", "e", "f"), t = c("xxx", "xxx", "xxx")) res <- left_join(x, y, by = c("r", "q")) expect_equal(names(res), c("q", "r", "s", "t")) expect_equal(res$q, x$q) expect_equal(res$r, x$r) }) test_that("inner join gives same result as merge by default (#1281)", { set.seed(75) x <- data.frame( cat1 = sample(c("A", "B", NA), 5, 1), cat2 = sample(c(1, 2, NA), 5, 1), v = rpois(5, 3), stringsAsFactors = FALSE ) y <- data.frame( cat1 = sample(c("A", "B", NA), 5, 1), cat2 = sample(c(1, 2, NA), 5, 1), v = rpois(5, 3), stringsAsFactors = FALSE ) ij <- inner_join(x, y, by = c("cat1", "cat2")) me <- merge(x, y, by = c("cat1", "cat2")) expect_true(equal_data_frame(ij, me)) }) test_that("join handles matrices #1230", { df1 <- tibble(x = 1:10, text = letters[1:10]) df2 <- tibble(x = 1:5, text = "") df2$text <- matrix(LETTERS[1:10], nrow = 5) res <- left_join(df1, df2, by = c("x" = "x")) %>% filter(x > 5) text.y <- res$text.y expect_true(is.matrix(text.y)) expect_equal(dim(text.y), c(5, 2)) expect_true(all(is.na(text.y))) }) test_that("ordering of strings is not confused by R's collate order (#1315)", { a <- data.frame(character = c("\u0663"), set = c("arabic_the_language"), stringsAsFactors = F) b <- data.frame(character = c("3"), set = c("arabic_the_numeral_set"), stringsAsFactors = F) res <- b %>% inner_join(a, by = c("character")) expect_equal(nrow(res), 0L) res <- a %>% inner_join(b, by = c("character")) expect_equal(nrow(res), 0L) }) test_that("joins handle tzone differences (#819)", { date1 <- structure(-1735660800, tzone = "America/Chicago", class = c("POSIXct", "POSIXt")) date2 <- structure(-1735660800, tzone = "UTC", class = c("POSIXct", "POSIXt")) df1 <- data.frame(date = date1) df2 <- data.frame(date = date2) expect_equal(attr(left_join(df1, df1)$date, "tzone"), "America/Chicago") }) test_that("joins matches NA in character vector by default (#892, #2033)", { x <- data.frame( id = c(NA_character_, NA_character_), stringsAsFactors = F ) y <- expand.grid( id = c(NA_character_, NA_character_), LETTER = LETTERS[1:2], stringsAsFactors = F ) res <- left_join(x, y, by = "id") expect_true(all(is.na(res$id))) expect_equal(res$LETTER, rep(rep(c("A", "B"), each = 2), 2)) }) test_that("joins avoid name repetition (#1460)", { d1 <- data.frame(id = 1:5, foo = rnorm(5)) d2 <- data.frame(id = 1:5, foo = rnorm(5)) d3 <- data.frame(id = 1:5, foo = rnorm(5)) d <- d1 %>% left_join(d1, by = "id") %>% left_join(d2, by = "id") %>% left_join(d3, by = "id") expect_equal(names(d), c("id", "foo.x", "foo.y", "foo.x.x", "foo.y.y")) }) test_that("join functions are protected against empty by (#1496)", { x <- data.frame() y <- data.frame(a = 1) expect_error( left_join(x, y, by = names(x)), "`by` must specify variables to join by", fixed = TRUE ) expect_error( right_join(x, y, by = names(x)), "`by` must specify variables to join by", fixed = TRUE ) expect_error( semi_join(x, y, by = names(x)), "`by` must specify variables to join by", fixed = TRUE ) expect_error( full_join(x, y, by = names(x)), "`by` must specify variables to join by", fixed = TRUE ) expect_error( anti_join(x, y, by = names(x)), "`by` must specify variables to join by", fixed = TRUE ) expect_error( inner_join(x, y, by = names(x)), "`by` must specify variables to join by", fixed = TRUE ) }) test_that("joins takes care of duplicates in by (#1192)", { data2 <- tibble(a = 1:3) data1 <- tibble(a = 1:3, c = 3:5) res1 <- left_join(data1, data2, by = c("a", "a")) res2 <- left_join(data1, data2, by = c("a" = "a")) expect_equal(res1, res2) }) # Joined columns result in correct type ---------------------------------------- test_that("result of joining POSIXct is POSIXct (#1578)", { data1 <- tibble( t = seq(as.POSIXct("2015-12-01", tz = "UTC"), length.out = 2, by = "days"), x = 1:2 ) data2 <- inner_join(data1, data1, by = "t") res1 <- class(data2$t) expected <- c("POSIXct", "POSIXt") expect_identical(res1, expected) }) test_that("joins allows extra attributes if they are identical (#1636)", { tbl_left <- tibble( i = rep(c(1, 2, 3), each = 2), x1 = letters[1:6] ) tbl_right <- tibble( i = c(1, 2, 3), x2 = letters[1:3] ) attr(tbl_left$i, "label") <- "iterator" attr(tbl_right$i, "label") <- "iterator" res <- left_join(tbl_left, tbl_right, by = "i") expect_equal(attr(res$i, "label"), "iterator") attr(tbl_left$i, "foo") <- "bar" attributes(tbl_right$i) <- NULL attr(tbl_right$i, "foo") <- "bar" attr(tbl_right$i, "label") <- "iterator" res <- left_join(tbl_left, tbl_right, by = "i") expect_equal(attr(res$i, "label"), "iterator") expect_equal(attr(res$i, "foo"), "bar") }) test_that("joins work with factors of different levels (#1712)", { d1 <- iris[, c("Species", "Sepal.Length")] d2 <- iris[, c("Species", "Sepal.Width")] d2$Species <- factor(as.character(d2$Species), levels = rev(levels(d1$Species))) expect_warning(res1 <- left_join(d1, d2, by = "Species")) d1$Species <- as.character(d1$Species) d2$Species <- as.character(d2$Species) res2 <- left_join(d1, d2, by = "Species") expect_equal(res1, res2) }) test_that("anti and semi joins give correct result when by variable is a factor (#1571)", { big <- data.frame(letter = rep(c("a", "b"), each = 2), number = 1:2) small <- data.frame(letter = "b") expect_warning( aj_result <- anti_join(big, small, by = "letter"), "Column `letter` joining factors with different levels, coercing to character vector", fixed = TRUE ) expect_equal(aj_result$number, 1:2) expect_equal(aj_result$letter, factor(c("a", "a"), levels = c("a", "b"))) expect_warning( sj_result <- semi_join(big, small, by = "letter"), "Column `letter` joining factors with different levels, coercing to character vector", fixed = TRUE ) expect_equal(sj_result$number, 1:2) expect_equal(sj_result$letter, factor(c("b", "b"), levels = c("a", "b"))) }) test_that("inner join not crashing (#1559)", { df3 <- tibble( id = c(102, 102, 102, 121), name = c("qwer", "qwer", "qwer", "asdf"), k = factor(c("one", "two", "total", "one"), levels = c("one", "two", "total")), total = factor(c("tot", "tot", "tot", "tot"), levels = c("tot", "plan", "fact")), v = c(NA_real_, NA_real_, NA_real_, NA_real_), btm = c(25654.957609, 29375.7547216667, 55030.7123306667, 10469.3523273333), top = c(22238.368946, 30341.516924, 52579.88587, 9541.893144) ) df4 <- tibble( id = c(102, 102, 102, 121), name = c("qwer", "qwer", "qwer", "asdf"), k = factor(c("one", "two", "total", "one"), levels = c("one", "two", "total")), type = factor(c("fact", "fact", "fact", "fact"), levels = c("tot", "plan", "fact")), perc = c(0.15363485835208, -0.0318297270618471, 0.0466114830816894, 0.0971986553754823) ) # all we want here is to test that this does not crash expect_message(res <- replicate(100, df3 %>% inner_join(df4))) for (i in 2:100) expect_equal(res[, 1], res[, i]) }) # Encoding ---------------------------------------------------------------- test_that("join handles mix of encodings in data (#1885, #2118, #2271)", { with_non_utf8_encoding({ special <- get_native_lang_string() for (factor1 in c(FALSE, TRUE)) { for (factor2 in c(FALSE, TRUE)) { for (encoder1 in c(enc2native, enc2utf8)) { for (encoder2 in c(enc2native, enc2utf8)) { df1 <- data.frame(x = encoder1(special), y = 1, stringsAsFactors = factor1) df1 <- tbl_df(df1) df2 <- data.frame(x = encoder2(special), z = 2, stringsAsFactors = factor2) df2 <- tbl_df(df2) df <- data.frame(x = special, y = 1, z = 2, stringsAsFactors = factor1 && factor2) df <- tbl_df(df) info <- paste( factor1, factor2, Encoding(as.character(df1$x)), Encoding(as.character(df2$x)) ) if (factor1 != factor2) { warning_msg <- "coercing" } else { warning_msg <- NA } expect_warning_msg <- function(code, msg = warning_msg) { expect_warning( code, msg, info = paste(deparse(substitute(code)[[2]][[1]]), info) ) } expect_equal_df <- function(code, df_ = df) { code <- substitute(code) eval(bquote( expect_equal( .(code), df_, info = paste(deparse(code[[1]]), info) ) )) } expect_warning_msg(expect_equal_df(inner_join(df1, df2, by = "x"))) expect_warning_msg(expect_equal_df(left_join(df1, df2, by = "x"))) expect_warning_msg(expect_equal_df(right_join(df1, df2, by = "x"))) expect_warning_msg(expect_equal_df(full_join(df1, df2, by = "x"))) expect_warning_msg( expect_equal_df( semi_join(df1, df2, by = "x"), data.frame(x = special, y = 1, stringsAsFactors = factor1) ) ) expect_warning_msg( expect_equal_df( anti_join(df1, df2, by = "x"), data.frame(x = special, y = 1, stringsAsFactors = factor1)[0, ] ) ) } } } } }) }) test_that("left_join handles mix of encodings in column names (#1571)", { with_non_utf8_encoding({ special <- get_native_lang_string() df1 <- tibble(x = 1:6, foo = 1:6) names(df1)[1] <- special df2 <- tibble(x = 1:6, baz = 1:6) names(df2)[1] <- enc2native(special) expect_message(res <- left_join(df1, df2), special, fixed = TRUE) expect_equal(names(res), c(special, "foo", "baz")) expect_equal(res$foo, 1:6) expect_equal(res$baz, 1:6) expect_equal(res[[special]], 1:6) }) }) # Misc -------------------------------------------------------------------- test_that("NAs match in joins only with na_matches = 'na' (#2033)", { df1 <- tibble(a = NA) df2 <- tibble(a = NA, b = 1:3) for (na_matches in c("na", "never")) { accept_na_match <- (na_matches == "na") expect_equal(inner_join(df1, df2, na_matches = na_matches) %>% nrow(), 0 + 3 * accept_na_match) expect_equal(left_join(df1, df2, na_matches = na_matches) %>% nrow(), 1 + 2 * accept_na_match) expect_equal(right_join(df2, df1, na_matches = na_matches) %>% nrow(), 1 + 2 * accept_na_match) expect_equal(full_join(df1, df2, na_matches = na_matches) %>% nrow(), 4 - accept_na_match) expect_equal(anti_join(df1, df2, na_matches = na_matches) %>% nrow(), 1 - accept_na_match) expect_equal(semi_join(df1, df2, na_matches = na_matches) %>% nrow(), 0 + accept_na_match) } }) test_that("joins regroups (#1597, #3566)", { df1 <- tibble(a = 1:3) %>% group_by(a) df2 <- tibble(a = rep(1:4, 2)) %>% group_by(a) expect_grouped <- function(df) { expect_true(is_grouped_df(df)) } expect_grouped(inner_join(df1, df2)) expect_grouped(left_join(df1, df2)) expect_grouped(right_join(df2, df1)) expect_grouped(full_join(df1, df2)) expect_grouped(anti_join(df1, df2)) expect_grouped(semi_join(df1, df2)) }) test_that("join accepts tz attributes (#2643)", { # It's the same time: df1 <- tibble(a = as.POSIXct("2009-01-01 10:00:00", tz = "Europe/London")) df2 <- tibble(a = as.POSIXct("2009-01-01 11:00:00", tz = "Europe/Paris")) result <- inner_join(df1, df2, by = "a") expect_equal(nrow(result), 1) }) test_that("join takes LHS with warning if attributes inconsistent", { df1 <- tibble(a = 1:2, b = 2:1) df2 <- tibble( a = structure(1:2, foo = "bar"), c = 2:1 ) expect_warning( out1 <- left_join(df1, df2, by = "a"), "Column `a` has different attributes on LHS and RHS of join" ) expect_warning(out2 <- left_join(df2, df1, by = "a")) expect_warning( out3 <- left_join(df1, df2, by = c("b" = "a")), "Column `b`/`a` has different attributes on LHS and RHS of join" ) expect_equal(attr(out1$a, "foo"), NULL) expect_equal(attr(out2$a, "foo"), "bar") }) test_that("common_by() message", { df <- tibble(!!!set_names(letters, letters)) expect_message( left_join(df, df %>% select(1)), 'Joining, by = "a"', fixed = TRUE ) expect_message( left_join(df, df %>% select(1:3)), 'Joining, by = c("a", "b", "c")', fixed = TRUE ) expect_message( left_join(df, df), paste0("Joining, by = c(", paste0('"', letters, '"', collapse = ", "), ")"), fixed = TRUE ) }) test_that("semi- and anti-joins preserve order (#2964)", { expect_identical( tibble(a = 3:1) %>% semi_join(tibble(a = 1:3)), tibble(a = 3:1) ) expect_identical( tibble(a = 3:1) %>% anti_join(tibble(a = 4:6)), tibble(a = 3:1) ) }) test_that("join handles raw vectors", { df1 <- tibble(r = as.raw(1:4), x = 1:4) df2 <- tibble(r = as.raw(3:6), y = 3:6) expect_identical( left_join(df1, df2, by = "r"), tibble(r = as.raw(1:4), x = 1:4, y = c(NA, NA, 3:4)) ) expect_identical( right_join(df1, df2, by = "r"), tibble(r = as.raw(3:6), x = c(3:4, NA, NA), y = c(3:6)) ) expect_identical( full_join(df1, df2, by = "r"), tibble(r = as.raw(1:6), x = c(1:4, NA, NA), y = c(NA, NA, 3:6)) ) expect_identical( inner_join(df1, df2, by = "r"), tibble(r = as.raw(3:4), x = c(3:4), y = c(3:4)) ) }) test_that("nest_join works (#3570)",{ df1 <- tibble(x = c(1, 2), y = c(2, 3)) df2 <- tibble(x = c(1, 1), z = c(2, 3)) res <- nest_join(df1, df2, by = "x") expect_equal(names(res), c(names(df1), "df2")) expect_identical(res$df2[[1]], select(df2, z)) expect_identical(res$df2[[2]], tibble(z = double())) }) test_that("nest_join handles multiple matches in x (#3642)", { df1 <- tibble(x = c(1, 1)) df2 <- tibble(x = 1, y = 1:2) tbls <- df1 %>% nest_join(df2) %>% pull() expect_identical(tbls[[1]], tbls[[2]]) }) test_that("joins reject data frames with duplicate columns (#3243)", { df1 <- data.frame(x1 = 1:3, x2 = 1:3, y = 1:3) names(df1)[1:2] <- "x" df2 <- data.frame(x = 2:4, y = 2:4) expect_error( left_join(df1, df2, by = c("x", "y")), "name", fixed = TRUE ) expect_error( left_join(df2, df1, by = c("x", "y")), "Column `x` must have a unique name", fixed = TRUE ) expect_error( right_join(df1, df2, by = c("x", "y")), "name", fixed = TRUE ) expect_error( right_join(df2, df1, by = c("x", "y")), "Column `x` must have a unique name", fixed = TRUE ) expect_error( inner_join(df1, df2, by = c("x", "y")), "name", fixed = TRUE ) expect_error( inner_join(df2, df1, by = c("x", "y")), "Column `x` must have a unique name", fixed = TRUE ) expect_error( full_join(df1, df2, by = c("x", "y")), "name", fixed = TRUE ) expect_error( full_join(df2, df1, by = c("x", "y")), "Column `x` must have a unique name", fixed = TRUE ) expect_error( semi_join(df1, df2, by = c("x", "y")), "name", fixed = TRUE ) # FIXME: Compatibility, should throw an error eventually expect_warning( expect_equal( semi_join(df2, df1, by = c("x", "y")), data.frame(x = 2:3, y = 2:3) ), "Column `x` must have a unique name", fixed = TRUE ) expect_error( anti_join(df1, df2, by = c("x", "y")), "name", fixed = TRUE ) # FIXME: Compatibility, should throw an error eventually expect_warning( expect_equal( anti_join(df2, df1, by = c("x", "y")), data.frame(x = 4L, y = 4L) ), "Column `x` must have a unique name", fixed = TRUE ) }) test_that("joins reject data frames with NA columns (#3417)", { df_a <- tibble(B = c("a", "b", "c"), AA = 1:3) df_b <- tibble(AA = 2:4, C = c("aa", "bb", "cc")) df_aa <- df_a attr(df_aa, "names") <- c(NA, "AA") df_ba <- df_b attr(df_ba, "names") <- c("AA", NA) expect_error( left_join(df_aa, df_b), "Column `1` cannot have NA as name", fixed = TRUE ) expect_error( left_join(df_aa, df_ba), "Column `1` cannot have NA as name", fixed = TRUE ) expect_error( left_join(df_a, df_ba), "Column `2` cannot have NA as name", fixed = TRUE ) expect_error( right_join(df_aa, df_b), "Column `1` cannot have NA as name", fixed = TRUE ) expect_error( right_join(df_aa, df_ba), "Column `1` cannot have NA as name", fixed = TRUE ) expect_error( right_join(df_a, df_ba), "Column `2` cannot have NA as name", fixed = TRUE ) expect_error( inner_join(df_aa, df_b), "Column `1` cannot have NA as name", fixed = TRUE ) expect_error( inner_join(df_aa, df_ba), "Column `1` cannot have NA as name", fixed = TRUE ) expect_error( inner_join(df_a, df_ba), "Column `2` cannot have NA as name", fixed = TRUE ) expect_error( full_join(df_aa, df_b), "Column `1` cannot have NA as name", fixed = TRUE ) expect_error( full_join(df_aa, df_ba), "Column `1` cannot have NA as name", fixed = TRUE ) expect_error( full_join(df_a, df_ba), "Column `2` cannot have NA as name", fixed = TRUE ) expect_warning( semi_join(df_aa, df_b), "Column `1` cannot have NA as name", fixed = TRUE ) expect_warning( semi_join(df_aa, df_ba), "Column `1` cannot have NA as name", fixed = TRUE ) expect_warning( semi_join(df_a, df_ba), "Column `2` cannot have NA as name", fixed = TRUE ) expect_warning( anti_join(df_aa, df_b), "Column `1` cannot have NA as name", fixed = TRUE ) expect_warning( anti_join(df_aa, df_ba), "Column `1` cannot have NA as name", fixed = TRUE ) expect_warning( anti_join(df_a, df_ba), "Column `2` cannot have NA as name", fixed = TRUE ) }) dplyr/tests/testthat/test-overscope.R0000644000176200001440000000073413614573562017533 0ustar liggesuserscontext("overscope") test_that(".data has strict matching semantics (#2591)", { # testthat says to use class = # but I guess older versions of R don't have the newest testthat # because that gives me an error suppressWarnings(expect_error( tibble(a = 1) %>% mutate(c = .data$b), "Column `b` not found in `.data`" )) suppressWarnings(expect_error( tibble(a = 1:3) %>% group_by(a) %>% mutate(c = .data$b), "Column `b` not found in `.data`" )) }) dplyr/tests/testthat/helper-encoding.R0000644000176200001440000000245613614573562017617 0ustar liggesusersget_lang_strings <- function() { lang_strings <- c( de = "Gl\u00fcck", cn = "\u5e78\u798f", ru = "\u0441\u0447\u0430\u0441\u0442\u044c\u0435", ko = "\ud589\ubcf5" ) native_lang_strings <- enc2native(lang_strings) same <- (lang_strings == native_lang_strings) list( same = lang_strings[same], different = lang_strings[!same] ) } get_native_lang_string <- function() { lang_strings <- get_lang_strings() if (length(lang_strings$same) == 0) testthat::skip("No native language string available") lang_strings$same[[1L]] } get_alien_lang_string <- function() { lang_strings <- get_lang_strings() if (length(lang_strings$different) == 0) testthat::skip("No alien language string available") lang_strings$different[[1L]] } with_non_utf8_encoding <- function(code) { old_encoding <- set_non_utf8_encoding() on.exit(set_encoding(old_encoding), add = TRUE) code } set_non_utf8_encoding <- function() { if (.Platform$OS.type == "windows") return(NULL) tryCatch( locale <- set_encoding("en_US.ISO88591"), warning = function(e) { testthat::skip("Cannot set latin-1 encoding") } ) locale } set_encoding <- function(encoding) { if (is.null(encoding)) return(NULL) locale <- Sys.getlocale("LC_CTYPE") Sys.setlocale("LC_CTYPE", encoding) locale } dplyr/tests/testthat/test-tbl-cube.R0000644000176200001440000000672213614573562017226 0ustar liggesuserscontext("tbl_cube") test_that("construction errors", { expect_error( tbl_cube(1:3, 1:3), "`dimensions` must be a named list of vectors, not an integer vector", fixed = TRUE ) expect_error( tbl_cube(list(a = 1:3), 1:3), "`measures` must be a named list of arrays, not an integer vector", fixed = TRUE ) expect_error( tbl_cube(list(a = 1:3), list(b = 1:3)), "`measures` must be a named list of arrays, not a list", fixed = TRUE ) expect_error( tbl_cube(list(a = 1:3), list(b = array(1:3), c = array(1:2))), "Measure `c` needs dimensions [3], not [2]", fixed = TRUE ) }) test_that("coercion", { grid <- expand.grid(x = letters[1:3], y = letters[1:5], stringsAsFactors = FALSE) tbl <- table(x = grid$x, y = grid$y) tbl_as_df <- as.data.frame(tbl, stringsAsFactors = FALSE) expect_message(cube <- as.tbl_cube(tbl_as_df), "Using Freq as") expect_identical(cube$dims, list(x = letters[1:3], y = letters[1:5])) expect_identical(names(cube$mets), "Freq") expect_message(cube_met <- as.tbl_cube(tbl_as_df, met_name = "Freq"), NA) expect_identical(cube, cube_met) expect_message(cube_dim <- as.tbl_cube(tbl_as_df, dim_names = c("x", "y")), NA) expect_identical(cube, cube_dim) expect_message(cube_tbl <- as.tbl_cube(tbl), NA) expect_identical(cube, cube_tbl) }) test_that("incomplete", { d <- rbind( cbind(data.frame(s = 1), expand.grid(j = 1)), cbind(data.frame(s = 2), expand.grid(j = 1:2)) ) d$value <- 1:3 cube <- as.tbl_cube(d, met_name = "value") expect_true(is.na(as.data.frame(filter(cube, s == 1, j == 2))[["value"]])) expect_equal(filter(as_tibble(cube), s != 1 | j != 2), d) }) test_that("duplicate", { d <- rbind( cbind(data.frame(s = 1), expand.grid(j = c(1, 1))), cbind(data.frame(s = 2), expand.grid(j = 1:2)) ) d$value <- 1:4 expect_error( as.tbl_cube(d, met_name = "value"), "`x` must be unique in all combinations of dimension variables, duplicates: `s` = 1, `j` = 1", fixed = TRUE ) }) test_that("filter", { expect_equal( nasa %>% filter(month == 1) %>% filter(year == 2000), nasa %>% filter(year == 2000) %>% filter(month == 1) ) expect_equal( nasa %>% filter(month == 1) %>% filter(year == 2000), filter(nasa, month == 1, year == 2000) ) expect_equal( filter(nasa, month == 1, year == 2000), filter(nasa, year == 2000, month == 1) ) expect_error( filter(nasa, month == 1 & year == 2000), "`month == 1 & year == 2000` must refer to exactly one dimension, not `month`, `year`" ) }) test_that("summarise works with single group", { by_month <- group_by(nasa, month) out <- summarise(by_month, temp = mean(temperature)) expect_equal(names(out$dims), "month") expect_equal(names(out$mets), "temp") expect_equal(dim(out), c(12, 1)) }) test_that("can coerce to data_frame", { slice <- filter(nasa, year == 1995L, month == 1L) expect_identical( tbl_df(as.data.frame(slice, stringsAsFactors = FALSE)), as_tibble(slice) ) }) test_that("can coerce to table", { expect_is(as.table(nasa), "table") expect_equal(length(dim(as.table(nasa))), 4L) expect_equal(dimnames(as.table(nasa)), lapply(nasa$dims, as.character)) expect_equal(as.vector(as.table(nasa)), as.vector(nasa$mets[[1]])) expect_identical(as.table(nasa, measure = "ozone"), as.table(select(nasa, ozone))) }) test_that("group_vars() returns variables", { gcube <- group_by(nasa, month) expect_identical(group_vars(gcube), "month") }) dplyr/tests/testthat/test-lead-lag.R0000644000176200001440000000400313614573562017165 0ustar liggesuserscontext("Lead and lag") test_that("lead and lag preserve factors", { x <- factor(c("a", "b", "c")) expect_equal(levels(lead(x)), c("a", "b", "c")) expect_equal(levels(lag(x)), c("a", "b", "c")) }) test_that("lead and lag preserves dates and times", { x <- as.Date("2013-01-01") + 1:3 y <- as.POSIXct(x) expect_is(lead(x), "Date") expect_is(lag(x), "Date") expect_is(lead(y), "POSIXct") expect_is(lag(y), "POSIXct") }) test_that("#925 is fixed", { data <- tibble( name = c("Rob", "Pete", "Rob", "John", "Rob", "Pete", "John", "Pete", "John", "Pete", "Rob", "Rob"), time = c(3, 2, 5, 3, 2, 3, 2, 4, 1, 1, 4, 1) ) res <- data %>% group_by(name) %>% mutate(lag_time = lag(time)) expect_equal( res$lag_time[res$name == "Rob"], c(NA, head(data$time[data$name == "Rob"], -1)) ) expect_equal( res$lag_time[res$name == "Pete"], c(NA, head(data$time[data$name == "Pete"], -1)) ) expect_equal( res$lag_time[res$name == "John"], c(NA, head(data$time[data$name == "John"], -1)) ) }) test_that("#937 is fixed", { df <- tibble( name = rep(c("Al", "Jen"), 3), score = rep(c(100, 80, 60), 2) ) res <- df %>% group_by(name) %>% mutate(next.score = lead(score)) expect_equal( res$next.score[res$name == "Al"], c(tail(df$score[df$name == "Al"], -1), NA) ) expect_equal( res$next.score[res$name == "Jen"], c(tail(df$score[df$name == "Jen"], -1), NA) ) }) test_that("input checks", { expect_error( lead(letters, -1), "`n` must be a nonnegative integer scalar, not a double vector of length 1", fixed = TRUE ) expect_error( lead(letters, "1"), "`n` must be a nonnegative integer scalar, not a character vector of length 1", fixed = TRUE ) expect_error( lag(letters, -1), "`n` must be a nonnegative integer scalar, not a double vector of length 1", fixed = TRUE ) expect_error( lag(letters, "1"), "`n` must be a nonnegative integer scalar, not a character vector of length 1", fixed = TRUE ) }) dplyr/tests/testthat/test-internals.r0000644000176200001440000000054713614573562017567 0ustar liggesuserscontext("internals") test_that("comparisons works as expected (#275)", { res <- test_comparisons() expect_true(all(res)) }) test_that("join_match() works as expected", { res <- test_matches() expect_true(all(unlist(res))) }) test_that("wrapping of length values works as expected", { res <- test_length_wrap() expect_true(all(res)) }) dplyr/tests/testthat/test-sample.R0000644000176200001440000001012713614573562017004 0ustar liggesuserscontext("Sample") # Basic behaviour ------------------------------------------------------------- test_that("sample preserves class", { expect_is(sample_n(mtcars, 1), "data.frame") expect_is(sample_n(tbl_df(mtcars), 1), "tbl_df") expect_is(sample_frac(mtcars, 1), "data.frame") expect_is(sample_frac(tbl_df(mtcars), 1), "tbl_df") }) # Ungrouped -------------------------------------------------------------------- df <- data.frame( x = 1:2, y = c(0, 1) ) test_that("sample respects weight", { # error message from base R expect_error(sample_n(df, 2, weight = y)) expect_equal(sample_n(df, 1, weight = y)$x, 2) expect_error( sample_frac(df, 2), "`size` of sampled fraction must be less or equal to one, set `replace` = TRUE to use sampling with replacement", fixed = TRUE ) expect_error( sample_frac(df %>% group_by(y), 2), "`size` of sampled fraction must be less or equal to one, set `replace` = TRUE to use sampling with replacement", fixed = TRUE ) # error message from base R expect_error(sample_frac(df, 1, weight = y)) expect_equal(sample_frac(df, 0.5, weight = y)$x, 2) }) test_that("sample_* error message", { expect_error( check_weight(letters[1:2], 2), "`weight` must be a numeric, not a character vector", fixed = TRUE ) expect_error( check_weight(-1:-2, 2), "`weight` must be a vector with all values nonnegative, not -1", fixed = TRUE ) expect_error( check_weight(letters, 2), "`weight` must be a numeric, not a character vector" ) }) test_that("sample gives informative error for unknown type", { expect_error( sample_n(list()), "`tbl` must be a data frame, not a list", fixed = TRUE ) expect_error( sample_frac(list()), "`tbl` must be a data frame, not a list", fixed = TRUE ) }) # Grouped ---------------------------------------------------------------------- test_that("sampling grouped tbl samples each group", { sampled <- mtcars %>% group_by(cyl) %>% sample_n(2) expect_is(sampled, "grouped_df") expect_groups(sampled, "cyl") expect_equal(nrow(sampled), 6) expect_equal(map_int(group_rows(sampled), length), c(2,2,2)) }) test_that("can't sample more values than obs (without replacement)", { by_cyl <- mtcars %>% group_by(cyl) expect_error( sample_n(by_cyl, 10), "`size` must be less or equal than 7 (size of data), set `replace` = TRUE to use sampling with replacement", fixed = TRUE ) }) test_that("grouped sample respects weight", { df2 <- tibble( x = rep(1:2, 100), y = rep(c(0, 1), 100), g = rep(1:2, each = 100) ) grp <- df2 %>% group_by(g) # error message from base R expect_error(sample_n(grp, nrow(df2) / 2, weight = y)) expect_equal(sample_n(grp, 1, weight = y)$x, c(2, 2)) # error message from base R expect_error(sample_frac(grp, 1, weight = y)) expect_equal(sample_frac(grp, 0.5, weight = y)$x, rep(2, nrow(df2) / 2)) }) test_that("grouped sample accepts NULL weight from variable (for saeSim)", { df <- tibble( x = rep(1:2, 10), y = rep(c(0, 1), 10), g = rep(1:2, each = 10) ) weight <- NULL expect_error(sample_n(df, nrow(df), weight = weight), NA) expect_error(sample_frac(df, weight = weight), NA) grp <- df %>% group_by(g) expect_error(sample_n(grp, nrow(df) / 2, weight = weight), NA) expect_error(sample_frac(grp, weight = weight), NA) }) test_that("sample_n and sample_frac can call n() (#3413)", { df <- tibble( x = rep(1:2, 10), y = rep(c(0, 1), 10), g = rep(1:2, each = 10) ) gdf <- group_by(df, g) expect_equal(sample_n(df, n()), df) expect_equal(sample_n(gdf, n()), gdf) expect_equal(nrow(sample_n(df, n()-2L)), nrow(df)-2) expect_equal(nrow(sample_n(gdf, n()-2L)), nrow(df)-4) }) test_that("sample_n and sample_frac handles lazy grouped data frames (#3380)", { df1 <- data.frame(x = 1:10, y = rep(1:2, each=5)) df2 <- data.frame(x = 6:15, z = 1:10) res <- df1 %>% group_by(y) %>% anti_join(df2, by="x") %>% sample_n(1) expect_equal(nrow(res), 1L) res <- df1 %>% group_by(y) %>% anti_join(df2, by="x") %>% sample_frac(0.2) expect_equal(nrow(res), 1L) }) dplyr/tests/testthat/test-colwise-filter.R0000644000176200001440000000507613614573562020462 0ustar liggesuserscontext("colwise filter") test_that("filter_if()", { expect_identical(nrow(filter_if(mtcars, is_integerish, all_vars(. > 1))), 0L) expect_identical(nrow(filter_if(mtcars, is_integerish, all_vars(. > 0))), 7L) }) test_that("filter_at()", { sepal_large <- filter_at(iris, vars(starts_with("Sepal")), all_vars(. > 4)) sepal_large_expected <- filter(iris, Sepal.Length > 4, Sepal.Width > 4) expect_equal(sepal_large, sepal_large_expected) }) test_that("filter_all()", { expect_identical(filter_all(mtcars, any_vars(. > 200))$disp, mtcars$disp[mtcars$disp > 200]) }) test_that("aborts on empty selection", { expect_error( filter_if(mtcars, is_character, all_vars(. > 0)), "`.predicate` has no matching columns", fixed = TRUE ) }) test_that("aborts when supplied funs() or list", { expect_error( filter_all(mtcars, list(~. > 0)), "`.vars_predicate` must be a function or a call to `all_vars()` or `any_vars()`, not a list", fixed = TRUE ) expect_error( with_lifecycle_silence(filter_all(mtcars, funs(. > 0))), "`.vars_predicate` must be a function or a call to `all_vars()` or `any_vars()`, not a `fun_list` object", fixed = TRUE ) }) test_that("filter_at can filter by grouping variables (#3351, #3480)", { tbl <- tibble(gr1 = rep(1:2, 4), gr2 = rep(1:2, each = 4), x = 1:8) %>% group_by(gr1) expect_identical( filter_at(tbl, vars(gr1), all_vars(. > 1)), filter(tbl, gr1 > 1) ) }) test_that("filter_if and filter_all includes grouping variables (#3351, #3480)", { tbl <- tibble(gr1 = rep(1:2, 4), gr2 = rep(1:2, each = 4), x = 1:8) %>% group_by(gr1) res <- filter_all(tbl, all_vars(. > 1)) expect_true(all(res$gr1 > 1)) res <- filter_if(tbl, is.integer, all_vars(. > 1)) expect_true(all(res$gr1 > 1)) }) test_that("can supply functions to scoped filters", { exp <- as.list(mtcars[c(8, 9, 21), ]) out <- mtcars %>% filter_at(c("cyl", "am"), ~ .x == 4 | .x == 0) expect_identical(as.list(out), exp) out <- mtcars %>% filter_at(c("cyl", "am"), function(.x) .x == 4 | .x == 0) expect_identical(as.list(out), exp) }) test_that("colwise filter support .data$. in the quosure versions", { expect_identical( filter_if(iris, is.numeric, any_vars(.data$. > 4)), filter_if(iris, is.numeric, any_vars(. > 4)) ) expect_identical( filter_all(select(iris, -Species), any_vars(.data$. > 4)), filter_all(select(iris, -Species), any_vars(. > 4)) ) expect_identical( filter_at(iris, vars(contains(".")), any_vars(.data$. > 4)), filter_at(iris, vars(contains(".")), any_vars(. > 4)) ) }) dplyr/tests/testthat/test-slice.r0000644000176200001440000001310113614573562016655 0ustar liggesuserscontext("slice") test_that("slice handles numeric input (#226)", { g <- mtcars %>% group_by(cyl) res <- g %>% slice(1) expect_equal(nrow(res), 3) expect_equal(res, g %>% filter(row_number() == 1L)) expect_equal( mtcars %>% slice(1), mtcars %>% filter(row_number() == 1L) ) }) test_that("slice silently ignores out of range values (#226)", { expect_equal(slice(mtcars, c(2, 100)), slice(mtcars, 2)) g <- group_by(mtcars, cyl) expect_equal(slice(g, c(2, 100)), slice(g, 2)) }) test_that("slice works with negative indices", { res <- slice(mtcars, -(1:2)) exp <- tail(mtcars, -2) expect_equal(names(res), names(exp)) for (col in names(res)) { expect_equal(res[[col]], exp[[col]]) } }) test_that("slice forbids positive and negative together", { expect_error( mtcars %>% slice(c(-1, 2)), "Found 1 positive indices and 1 negative indices", fixed = TRUE ) expect_error( mtcars %>% slice(c(2:3, -1)), "Found 2 positive indices and 1 negative indices", fixed = TRUE ) }) test_that("slice works with grouped data", { g <- group_by(mtcars, cyl) res <- slice(g, 1:2) exp <- filter(g, row_number() < 3) expect_equal(res, exp) res <- slice(g, -(1:2)) exp <- filter(g, row_number() >= 3) expect_equal(res, exp) g <- group_by(data.frame(x = c(1, 1, 2, 2, 2)), x) expect_equal(group_keys(slice(g, 3, .preserve = TRUE))$x, c(1, 2)) expect_equal(group_keys(slice(g, 3, .preserve = FALSE))$x, 2) }) test_that("slice gives correct rows (#649)", { a <- tibble(value = paste0("row", 1:10)) expect_equal(slice(a, 1:3)$value, paste0("row", 1:3)) expect_equal(slice(a, c(4, 6, 9))$value, paste0("row", c(4, 6, 9))) a <- tibble( value = paste0("row", 1:10), group = rep(1:2, each = 5) ) %>% group_by(group) expect_equal(slice(a, 1:3)$value, paste0("row", c(1:3, 6:8))) expect_equal(slice(a, c(2, 4))$value, paste0("row", c(2, 4, 7, 9))) }) test_that("slice handles NA (#1235)", { df <- tibble(x = 1:3) expect_equal(nrow(slice(df, NA_integer_)), 0L) expect_equal(nrow(slice(df, c(1L, NA_integer_))), 1L) expect_equal(nrow(slice(df, c(-1L, NA_integer_))), 2L) df <- tibble(x = 1:4, g = rep(1:2, 2)) %>% group_by(g) expect_equal(nrow(slice(df, c(1, NA))), 2) expect_equal(nrow(slice(df, c(-1, NA))), 2) }) test_that("slice handles logical NA (#3970)", { df <- tibble(x = 1:3) expect_equal(nrow(slice(df, NA)), 0L) expect_error(slice(df, TRUE)) expect_error(slice(df, FALSE)) }) test_that("slice handles empty data frames (#1219)", { df <- data.frame(x = numeric()) res <- df %>% slice(1:3) expect_equal(nrow(res), 0L) expect_equal(names(res), "x") }) test_that("slice works fine if n > nrow(df) (#1269)", { slice_res <- mtcars %>% group_by(cyl) %>% slice(8) filter_res <- mtcars %>% group_by(cyl) %>% filter(row_number() == 8) expect_equal(slice_res, filter_res) }) test_that("slice strips grouped indices (#1405)", { res <- mtcars %>% group_by(cyl) %>% slice(1) %>% mutate(mpgplus = mpg + 1) expect_equal(nrow(res), 3L) expect_equal(group_rows(res), as.list(1:3)) }) test_that("slice works with zero-column data frames (#2490)", { expect_equal( tibble(a = 1:3) %>% select(-a) %>% slice(1) %>% nrow(), 1L ) }) test_that("slice works under gctorture2", { x <- tibble(y = 1:10) with_gctorture2(999, x2 <- slice(x, 1:10)) expect_identical(x, x2) }) test_that("slice correctly computes positive indices from negative indices (#3073)", { x <- tibble(y = 1:10) expect_identical(slice(x, -10:-30), tibble(y = 1:9)) }) test_that("slice handles raw matrices", { df <- tibble(a = 1:4, b = matrix(as.raw(1:8), ncol = 2)) expect_identical( slice(df, 1:2)$b, matrix(as.raw(c(1, 2, 5, 6)), ncol = 2) ) }) test_that("slice on ungrouped data.frame (not tibble) does not enforce tibble", { expect_equal(class(slice(mtcars, 2)), "data.frame") expect_equal(class(slice(mtcars, -2)), "data.frame") expect_equal(class(slice(mtcars, NA)), "data.frame") }) test_that("slice skips 0 (#3313)", { d <- tibble(x = 1:5, y = LETTERS[1:5], g = 1) expect_identical(slice(d, 0), slice(d, integer(0))) expect_identical(slice(d, c(0, 1)), slice(d, 1)) expect_identical(slice(d, c(0, 1, 2)), slice(d, c(1, 2))) expect_identical(slice(d, c(-1, 0)), slice(d, -1)) expect_identical(slice(d, c(0, -1)), slice(d, -1)) d <- group_by(d, g) expect_identical(slice(d, 0), slice(d, integer(0))) expect_identical(slice(d, c(0, 1)), slice(d, 1)) expect_identical(slice(d, c(0, 1, 2)), slice(d, c(1, 2))) expect_identical(slice(d, c(-1, 0)), slice(d, -1)) expect_identical(slice(d, c(0, -1)), slice(d, -1)) }) test_that("slice is not confused about dense groups (#3753)",{ df <- tibble(row = 1:3) expect_equal(slice(df, c(2,1,3))$row, c(2L,1L,3L)) expect_equal(slice(df, c(1,1,1))$row, rep(1L, 3)) }) test_that("slice accepts ... (#3804)", { expect_equal(slice(mtcars, 1, 2), slice(mtcars, 1:2)) expect_equal(slice(mtcars, 1, n()), slice(mtcars, c(1, nrow(mtcars)))) g <- mtcars %>% group_by(cyl) expect_equal(slice(g, 1, n()), slice(g, c(1, n()))) }) test_that("slice does not evaluate the expression in empty groups (#1438)", { res <- mtcars %>% group_by(cyl) %>% filter(cyl==6) %>% slice(1:2) expect_equal(nrow(res), 2L) expect_condition( res <- mtcars %>% group_by(cyl) %>% filter(cyl==6) %>% sample_n(size=3), NA ) expect_equal(nrow(res), 3L) }) test_that("column_subset() falls back to R indexing on esoteric data types (#4128)", { res <- slice(tibble::enframe(formals(rnorm)), 2:3) expect_identical(res, tibble(name = c("mean", "sd"), value = list(0, 1))) }) dplyr/tests/testthat/test-na-if.R0000644000176200001440000000066013614573562016516 0ustar liggesuserscontext("na_if") test_that("error for bad y length", { expect_error( na_if(1:3, 1:2), "`y` must be length 3 (same as `x`) or one, not 2", fixed = TRUE ) expect_error( na_if(1, 1:2), "`y` must be length 1 (same as `x`), not 2", fixed = TRUE ) }) test_that("scalar y replaces all matching x", { x <- c(0, 1, 0) expect_equal(na_if(x, 0), c(NA, 1, NA)) expect_equal(na_if(x, 1), c(0, NA, 0)) }) dplyr/tests/testthat/test-do.R0000644000176200001440000001401013614573562016120 0ustar liggesuserscontext("Do") # Grouped data frames ---------------------------------------------------------- df <- data.frame( g = c(1, 2, 2, 3, 3, 3), x = 1:6, y = 6:1 ) %>% group_by(g) test_that("can't use both named and unnamed args", { expect_error( df %>% do(x = 1, 2), "Arguments must either be all named or all unnamed", fixed = TRUE ) }) test_that("unnamed elements must return data frames", { expect_error( df %>% ungroup() %>% do(1), "Result must be a data frame, not numeric" ) expect_error( df %>% do(1), "Results 1, 2, 3 must be data frames, not numeric" ) expect_error( df %>% do("a"), "Results 1, 2, 3 must be data frames, not character" ) }) test_that("unnamed results bound together by row", { first <- df %>% do(head(., 1)) expect_equal(nrow(first), 3) expect_equal(first$g, 1:3) expect_equal(first$x, c(1, 2, 4)) }) test_that("can only use single unnamed argument", { expect_error( df %>% do(head, tail), "Can only supply one unnamed argument, not 2" ) }) test_that("named argument become list columns", { out <- df %>% do(nrow = nrow(.), ncol = ncol(.)) expect_equal(out$nrow, list(1, 2, 3)) # includes grouping columns expect_equal(out$ncol, list(3, 3, 3)) }) test_that("multiple outputs can access data (#2998)", { out <- do(tibble(a = 1), g = nrow(.), h = nrow(.)) expect_equal(names(out), c("g", "h")) expect_equal(out$g, list(1L)) expect_equal(out$h, list(1L)) }) test_that("colums in output override columns in input", { out <- df %>% do(data.frame(g = 1)) expect_equal(names(out), "g") expect_equal(out$g, c(1, 1, 1)) }) test_that("empty results preserved (#597)", { blankdf <- function(x) data.frame(blank = numeric(0)) dat <- data.frame(a = 1:2, b = factor(1:2)) expect_equal( dat %>% group_by(b, .drop = FALSE) %>% do(blankdf(.)), data.frame(b = factor(integer(), levels = 1:2), blank = numeric()) ) }) test_that("empty inputs give empty outputs (#597)", { out <- data.frame(a = numeric(), b = factor()) %>% group_by(b, .drop = FALSE) %>% do(data.frame()) expect_equal(out, data.frame(b = factor()) %>% group_by(b, .drop = FALSE)) out <- data.frame(a = numeric(), b = character()) %>% group_by(b, .drop = FALSE) %>% do(data.frame()) expect_equal(out, data.frame(b = character()) %>% group_by(b, .drop = FALSE)) }) test_that("grouped do evaluates args in correct environment", { a <- 10 f <- function(a) { mtcars %>% group_by(cyl) %>% do(a = a) } expect_equal(f(100)$a, list(100, 100, 100)) }) # Ungrouped data frames -------------------------------------------------------- test_that("ungrouped data frame with unnamed argument returns data frame", { out <- mtcars %>% do(head(.)) expect_is(out, "data.frame") expect_equal(dim(out), c(6, 11)) }) test_that("ungrouped data frame with named argument returns list data frame", { out <- mtcars %>% do(x = 1, y = 2:10) expect_is(out, "tbl_df") expect_equal(out$x, list(1)) expect_equal(out$y, list(2:10)) }) test_that("ungrouped do evaluates args in correct environment", { a <- 10 f <- function(a) { mtcars %>% do(a = a) } expect_equal(f(100)$a, list(100)) }) # Rowwise data frames ---------------------------------------------------------- test_that("can do on rowwise dataframe", { out <- mtcars %>% rowwise() %>% do(x = 1) exp <- tibble(x =rep(list(1), nrow(mtcars))) %>% rowwise() expect_identical(out, exp) }) # Zero row inputs -------------------------------------------------------------- test_that("empty data frames give consistent outputs", { dat <- tibble(x = numeric(0), g = character(0)) grp <- dat %>% group_by(g) emt <- grp %>% filter(FALSE) dat %>% do(data.frame()) %>% vapply(type_sum, character(1)) %>% length() %>% expect_equal(0) dat %>% do(data.frame(y = integer(0))) %>% vapply(type_sum, character(1)) %>% expect_equal(c(y = "int")) dat %>% do(data.frame(.)) %>% vapply(type_sum, character(1)) %>% expect_equal(c(x = "dbl", g = "chr")) dat %>% do(data.frame(., y = integer(0))) %>% vapply(type_sum, character(1)) %>% expect_equal(c(x = "dbl", g = "chr", y = "int")) dat %>% do(y = ncol(.)) %>% vapply(type_sum, character(1)) %>% expect_equal(c(y = "list")) # Grouped data frame should have same col types as ungrouped, with addition # of grouping variable grp %>% do(data.frame()) %>% vapply(type_sum, character(1)) %>% expect_equal(c(g = "chr")) grp %>% do(data.frame(y = integer(0))) %>% vapply(type_sum, character(1)) %>% expect_equal(c(g = "chr", y = "int")) grp %>% do(data.frame(.)) %>% vapply(type_sum, character(1)) %>% expect_equal(c(x = "dbl", g = "chr")) grp %>% do(data.frame(., y = integer(0))) %>% vapply(type_sum, character(1)) %>% expect_equal(c(x = "dbl", g = "chr", y = "int")) grp %>% do(y = ncol(.)) %>% vapply(type_sum, character(1)) %>% expect_equal(c(g = "chr", y = "list")) # A empty grouped dataset should have same types as grp emt %>% do(data.frame()) %>% vapply(type_sum, character(1)) %>% expect_equal(c(g = "chr")) emt %>% do(data.frame(y = integer(0))) %>% vapply(type_sum, character(1)) %>% expect_equal(c(g = "chr", y = "int")) emt %>% do(data.frame(.)) %>% vapply(type_sum, character(1)) %>% expect_equal(c(x = "dbl", g = "chr")) emt %>% do(data.frame(., y = integer(0))) %>% vapply(type_sum, character(1)) %>% expect_equal(c(x = "dbl", g = "chr", y = "int")) emt %>% do(y = ncol(.)) %>% vapply(type_sum, character(1)) %>% expect_equal(c(g = "chr", y = "list")) }) test_that("handling of empty data frames in do", { blankdf <- function(x) data.frame(blank = numeric(0)) dat <- data.frame(a = 1:2, b = factor(1:2)) res <- dat %>% group_by(b, .drop = FALSE) %>% do(blankdf(.)) expect_equal(names(res), c("b", "blank")) }) test_that("do() does not retain .drop attribute (#4176)", { res <- iris %>% group_by(Species) %>% do(data.frame(n=1)) expect_null(attr(res, ".drop", exact = TRUE)) }) dplyr/tests/testthat/test-new_grouped_df.R0000644000176200001440000000321113614573562020506 0ustar liggesuserscontext("new_grouped_df") test_that("new grouped_df checks that `group_data` has a `.rows` column (#3837)", { tbl <- tibble(x = 1:10) expect_error(new_grouped_df(tbl, tibble(other = list(1:2)))) }) test_that("new_grouped_df can create alternative grouping structures (#3837)", { tbl <- new_grouped_df( tibble(x = rnorm(10)), groups = tibble(".rows" := replicate(5, sample(1:10, replace = TRUE), simplify = FALSE)) ) res <- summarise(tbl, x = mean(x)) expect_equal(nrow(res), 5L) }) test_that("validate_grouped_df (#3837)", { df <- new_grouped_df( tibble(x = 1:10), groups = tibble(".rows" := list(1:5, -1L)) ) expect_error(validate_grouped_df(df), "indices of group 2 are out of bounds") attr(df, "groups")$.rows <- list(11L) expect_error(validate_grouped_df(df), "indices of group 1 are out of bounds") attr(df, "groups")$.rows <- list(0L) expect_error(validate_grouped_df(df), "indices of group 1 are out of bounds") attr(df, "groups")$.rows <- list(1) expect_error(validate_grouped_df(df), "`.rows` column is not a list of one-based integer vectors") attr(df, "groups") <- tibble() expect_error(validate_grouped_df(df), "The `groups` attribute is not a data frame with its last column called `.rows`") attr(df, "groups") <- NULL expect_error(validate_grouped_df(df), "The `groups` attribute is not a data frame with its last column called `.rows`") }) test_that("new_grouped_df does not have rownames (#4173)", { tbl <- new_grouped_df( tibble(x = rnorm(10)), groups = tibble(".rows" := replicate(5, sample(1:10, replace = TRUE), simplify = FALSE)) ) expect_false(tibble::has_rownames(tbl)) }) dplyr/tests/testthat/test-equality.r0000644000176200001440000001373613614573562017431 0ustar liggesuserscontext("Equality") # A data frame with all major types df_all <- data.frame( a = c(1, 2.5), b = 1:2, c = c(T, F), d = c("a", "b"), e = factor(c("a", "b")), f = Sys.Date() + 1:2, g = Sys.time() + 1:2, stringsAsFactors = FALSE ) test_that("data frames equal to themselves", { expect_true(all.equal(tbl_df(mtcars), tbl_df(mtcars))) expect_true(all.equal(tbl_df(iris), tbl_df(iris))) expect_true(all.equal(tbl_df(df_all), tbl_df(df_all))) }) test_that("data frames equal to random permutations of themselves", { scramble <- function(x) { x[sample(nrow(x)), sample(ncol(x)), drop = FALSE] } expect_equal(tbl_df(mtcars), tbl_df(scramble(mtcars))) expect_equal(tbl_df(iris), tbl_df(scramble(iris))) expect_equal(tbl_df(df_all), tbl_df(scramble(df_all))) }) test_that("data frames not equal if missing row", { expect_match(all.equal(tbl_df(mtcars), mtcars[-1, ]), "Different number of rows") expect_match(all.equal(tbl_df(iris), iris[-1, ]), "Different number of rows") expect_match(all.equal(tbl_df(df_all), df_all[-1, ]), "Different number of rows") }) test_that("data frames not equal if missing col", { expect_match( all.equal(tbl_df(mtcars), mtcars[, -1]), "Cols in x but not y: `mpg`" ) expect_match( all.equal(tbl_df(iris), iris[, -1]), "Cols in x but not y: `Sepal.Length`" ) expect_match( all.equal(tbl_df(df_all), df_all[, -1]), "Cols in x but not y: `a`" ) }) test_that("factors equal only if levels equal", { df1 <- tibble(x = factor(c("a", "b"))) df2 <- tibble(x = factor(c("a", "d"))) expect_equal( all.equal(df1, df2), "Factor levels not equal for column `x`" ) expect_equal( all.equal(df2, df1), "Factor levels not equal for column `x`" ) }) test_that("factor comparison requires strict equality of levels (#2440)", { df1 <- tibble(x = factor("a")) df2 <- tibble(x = factor("a", levels = c("a", "b"))) expect_equal( all.equal(df1, df2), "Factor levels not equal for column `x`" ) expect_equal( all.equal(df2, df1), "Factor levels not equal for column `x`" ) expect_warning(expect_true(all.equal(df1, df2, convert = TRUE)), "joining factors") expect_warning(expect_true(all.equal(df2, df1, convert = TRUE)), "joining factors") }) test_that("BoolResult does not overwrite singleton R_TrueValue", { dplyr:::equal_data_frame(mtcars, mtcars) expect_equal(class(2 == 2), "logical") }) test_that("all.equal.data.frame handles data.frames with NULL names", { x <- data.frame(LETTERS[1:3], rnorm(3)) names(x) <- NULL expect_true(all.equal(x, x)) }) test_that("data frame equality test with ignore_row_order=TRUE detects difference in number of rows. #1065", { DF1 <- tibble(a = 1:4, b = letters[1:4]) DF2 <- tibble(a = c(1:4, 4L), b = letters[c(1:4, 4L)]) expect_false(isTRUE(all.equal(DF1, DF2, ignore_row_order = TRUE))) DF1 <- tibble(a = c(1:4, 2L), b = letters[c(1:4, 2L)]) DF2 <- tibble(a = c(1:4, 4L), b = letters[c(1:4, 4L)]) expect_false(isTRUE(all.equal(DF1, DF2, ignore_row_order = TRUE))) }) test_that("all.equal handles NA_character_ correctly. #1095", { d1 <- tibble(x = c(NA_character_)) expect_true(all.equal(d1, d1)) d2 <- tibble(x = c(NA_character_, "foo", "bar")) expect_true(all.equal(d2, d2)) }) test_that("handle Date columns of different types, integer and numeric (#1204)", { a <- data.frame(date = as.Date("2015-06-07")) b <- data.frame(date = structure(as.integer(a$date), class = "Date")) expect_true(all.equal(a, b)) }) test_that("equality test fails when convert is FALSE and types don't match (#1484)", { df1 <- tibble(x = "a") df2 <- tibble(x = factor("a")) expect_equal( all_equal(df1, df2, convert = FALSE), "Incompatible type for column `x`: x character, y factor" ) expect_warning(all_equal(df1, df2, convert = TRUE)) }) test_that("equality handles data frames with 0 rows (#1506)", { df0 <- tibble(x = numeric(0), y = character(0)) expect_equal(df0, df0) }) test_that("equality handles data frames with 0 columns (#1506)", { df0 <- tibble(a = 1:10)[-1] expect_equal(df0, df0) }) test_that("equality handle raw columns", { df <- tibble(a = 1:3, b = as.raw(1:3)) expect_true(all.equal(df, df)) }) test_that("equality returns a message for convert = TRUE", { df1 <- tibble(x = 1:3) df2 <- tibble(x = as.character(1:3)) expect_match(all.equal(df1, df2), "Incompatible") expect_match(all.equal(df1, df2, convert = TRUE), "Incompatible") }) test_that("numeric and integer can be compared if convert = TRUE", { df1 <- tibble(x = 1:3) df2 <- tibble(x = as.numeric(1:3)) expect_match(all.equal(df1, df2), "Incompatible") expect_true(all.equal(df1, df2, convert = TRUE)) }) test_that("returns vector for more than one difference (#1819)", { expect_equal( all.equal(tibble(a = 1, b = 2), tibble(a = 1L, b = 2L)), c( "Incompatible type for column `a`: x numeric, y integer", "Incompatible type for column `b`: x numeric, y integer" ) ) }) test_that("returns UTF-8 column names (#2441)", { skip_on_cran() df1 <- tibble("\u5e78" := 1) df2 <- tibble("\u798f" := 1) expect_equal( all.equal(df1, df2), c( "Cols in y but not x: `\u798f`. ", "Cols in x but not y: `\u5e78`. " ), fixed = TRUE ) }) test_that("proper message formatting for set operations", { expect_error( union(tibble(a = 1), tibble(a = "1")), "not compatible: Incompatible type for column `a`: x numeric, y character", fixed = TRUE ) expect_error( union(tibble(a = 1, b = 2), tibble(a = "1", b = "2")), "not compatible: \n- Incompatible type for column `a`: x numeric, y character\n- Incompatible type for column `b`: x numeric, y character", fixed = TRUE ) }) test_that("ignore column order", { expect_equal( all.equal(tibble(a = 1, b = 2), tibble(b = 2, a = 1), ignore_col_order = FALSE), "Same column names, but different order" ) expect_equal( all.equal(tibble(a = 1, b = 2), tibble(a = 1), ignore_col_order = FALSE), "Cols in x but not y: `b`. " ) }) dplyr/tests/testthat/test-select.r0000644000176200001440000001213113614573562017037 0ustar liggesuserscontext("Select") test_that("select does not lose grouping (#147)", { df <- tibble(a = rep(1:4, 2), b = rep(1:4, each = 2), x = runif(8)) grouped <- df %>% group_by(a) %>% select(a, b, x) expect_groups(grouped, "a") }) test_that("grouping variables preserved with a message (#1511)", { df <- tibble(g = 1:3, x = 3:1) %>% group_by(g) expect_message(res <- select(df, x), "Adding missing grouping variables") expect_named(res, c("g", "x")) }) test_that("non-syntactic grouping variable is preserved (#1138)", { df <- tibble(`a b` = 1L) %>% group_by(`a b`) %>% select() expect_named(df, "a b") }) test_that("select doesn't fail if some names missing", { df1 <- data.frame(x = 1:10, y = 1:10, z = 1:10) df2 <- setNames(df1, c("x", "y", "")) # df3 <- setNames(df1, c("x", "", "")) expect_equal(select(df1, x), data.frame(x = 1:10)) expect_equal(select(df2, x), data.frame(x = 1:10)) # expect_equal(select(df3, x), data.frame(x = 1:10)) }) # Empty selects ------------------------------------------------- test_that("select with no args returns nothing", { empty <- select(mtcars) expect_equal(ncol(empty), 0) expect_equal(nrow(empty), 32) }) test_that("select excluding all vars returns nothing", { expect_equal(dim(select(mtcars, -(mpg:carb))), c(32, 0)) expect_equal(dim(select(mtcars, starts_with("x"))), c(32, 0)) expect_equal(dim(select(mtcars, -matches("."))), c(32, 0)) }) test_that("negating empty match returns everything", { df <- data.frame(x = 1:3, y = 3:1) expect_equal(select(df, -starts_with("xyz")), df) }) # Select variables ----------------------------------------------- test_that("select can be before group_by (#309)", { df <- data.frame( id = c(1, 1, 2, 2, 2, 3, 3, 4, 4, 5), year = c(2013, 2013, 2012, 2013, 2013, 2013, 2012, 2012, 2013, 2013), var1 = rnorm(10) ) dfagg <- df %>% group_by(id, year) %>% select(id, year, var1) %>% summarise(var1 = mean(var1)) expect_equal(names(dfagg), c("id", "year", "var1")) }) test_that("rename errors with invalid grouped data frame (#640)", { df <- tibble(a = 1:3, b = 2:4, d = 3:5) %>% group_by(a, b) df$a <- NULL expect_error( df %>% rename(e = d), "not found in groups metadata" ) expect_error( df %>% rename(e = b), "not found in groups metadata" ) }) test_that("rename() handles data pronoun", { expect_identical(rename(tibble(x = 1), y = .data$x), tibble(y = 1)) }) test_that("select succeeds in presence of raw columns (#1803)", { df <- tibble(a = 1:3, b = as.raw(1:3)) expect_identical(select(df, a), df["a"]) expect_identical(select(df, b), df["b"]) expect_identical(select(df, -b), df["a"]) }) test_that("arguments to select() don't match vars_select() arguments", { df <- tibble(a = 1) expect_identical(select(df, var = a), tibble(var = 1)) expect_identical(select(group_by(df, a), var = a), group_by(tibble(var = 1), var)) expect_identical(select(df, exclude = a), tibble(exclude = 1)) expect_identical(select(df, include = a), tibble(include = 1)) expect_identical(select(group_by(df, a), exclude = a), group_by(tibble(exclude = 1), exclude)) expect_identical(select(group_by(df, a), include = a), group_by(tibble(include = 1), include)) }) test_that("arguments to rename() don't match vars_rename() arguments (#2861)", { df <- tibble(a = 1) expect_identical(rename(df, var = a), tibble(var = 1)) expect_identical(rename(group_by(df, a), var = a), group_by(tibble(var = 1), var)) expect_identical(rename(df, strict = a), tibble(strict = 1)) expect_identical(rename(group_by(df, a), strict = a), group_by(tibble(strict = 1), strict)) }) test_that("can select() with .data pronoun (#2715)", { expect_identical(select(mtcars, .data$cyl), select(mtcars, cyl)) }) test_that("can select() with character vectors", { expect_identical(select(mtcars, "cyl", !!"disp", c("cyl", "am", "drat")), mtcars[c("cyl", "disp", "am", "drat")]) }) test_that("rename() to UTF-8 column names", { skip_on_os("windows") # needs an rlang update? #3049 df <- tibble(a = 1) %>% rename("\u5e78" := a) expect_equal(colnames(df), "\u5e78") }) test_that("select() treats NULL inputs as empty", { expect_identical(select(mtcars, cyl), select(mtcars, NULL, cyl, NULL)) }) test_that("can select() or rename() with strings and character vectors", { vars <- c(foo = "cyl", bar = "am") expect_identical(select(mtcars, !!!vars), select(mtcars, foo = cyl, bar = am)) expect_identical(select(mtcars, !!vars), select(mtcars, foo = cyl, bar = am)) expect_identical(rename(mtcars, !!!vars), rename(mtcars, foo = cyl, bar = am)) expect_identical(rename(mtcars, !!vars), rename(mtcars, foo = cyl, bar = am)) }) test_that("select works on empty names (#3601)", { df <- data.frame(x=1, y=2, z=3) colnames(df) <- c("x","y","") expect_identical(select(df, x)$x, 1) colnames(df) <- c("","y","z") expect_identical(select(df, y)$y, 2) }) test_that("select works on NA names (#3601)", { skip("to be discussed") df <- data.frame(x=1, y=2, z=3) colnames(df) <- c("x","y",NA) expect_identical(select(df, x)$x, 1) colnames(df) <- c(NA,"y","z") expect_identical(select(df, y)$y, 2) }) dplyr/tests/testthat/test-copy_to.R0000644000176200001440000000325213614573562017200 0ustar liggesuserscontext("copy_to") test_that("src_local only overwrites if overwrite = TRUE", { env <- new.env(parent = emptyenv()) env$x <- 1 src_env <- src_df(env = env) expect_error( copy_to(src_env, tibble(x = 1), name = "x"), "object with `name` = `x` must not already exist, unless `overwrite` = TRUE", fixed = TRUE ) df <- tibble(x = 1) copy_to(src_env, df, name = "x", overwrite = TRUE) expect_equal(env$x, df) }) test_that("src_local errs with pkg/env", { expect_error( src_df("base", new.env()), "Exactly one of `pkg` and `env` must be non-NULL, not 2", fixed = TRUE ) expect_error( src_df(), "Exactly one of `pkg` and `env` must be non-NULL, not 0", fixed = TRUE ) }) test_that("auto_copy() requires same source", { skip_if_not_installed("dbplyr") env <- new.env(parent = emptyenv()) env$iris <- iris src_iris <- src_df(env = env) src_mtcars <- src_sqlite(":memory:", create = TRUE) copy_to(src_mtcars, mtcars, "mtcars") expect_error( auto_copy(tbl(src_iris, "iris"), src_mtcars, name = "iris"), "`x` and `y` must share the same src, set `copy` = TRUE (may be slow)", fixed = TRUE ) expect_error( auto_copy(tbl(src_mtcars, "mtcars"), src_iris, name = "mtcars"), "`x` and `y` must share the same src, set `copy` = TRUE (may be slow)", fixed = TRUE ) }) test_that("src_sqlite() errs if path does not exist", { skip_if_not_installed("dbplyr") expect_error( src_sqlite(":memory:"), "`path` must already exist, unless `create` = TRUE", fixed = TRUE ) }) test_that("src_tbls() includes all tbls (#4326)", { expect_equal( src_tbls(src_df(env = env(. = iris))), "." ) }) dplyr/tests/testthat/test-group-by.r0000644000176200001440000003713613614573562017340 0ustar liggesuserscontext("Group by") df <- data.frame(x = rep(1:3, each = 10), y = rep(1:6, each = 5)) test_that("group_by with add = TRUE adds groups", { add_groups1 <- function(tbl) group_by(tbl, x, y, add = TRUE) add_groups2 <- function(tbl) group_by(group_by(tbl, x, add = TRUE), y, add = TRUE) expect_groups(add_groups1(df), c("x", "y")) expect_groups(add_groups2(df), c("x", "y")) }) test_that("group_by_ backwards compatibility with add = TRUE adds groups", { scoped_lifecycle_silence() add_groups_extendedclass <- function(tbl) { grouped <- group_by(tbl, x) group_by.default(grouped, y, add = TRUE) } expect_groups(add_groups_extendedclass(df), c("x", "y")) }) test_that("joins preserve grouping", { g <- group_by(df, x) expect_groups(inner_join(g, g, by = c("x", "y")), "x") expect_groups(left_join(g, g, by = c("x", "y")), "x") expect_groups(semi_join(g, g, by = c("x", "y")), "x") expect_groups(anti_join(g, g, by = c("x", "y")), "x") }) test_that("constructors drops groups", { df <- data.frame(x = 1:3) %>% group_by(x) expect_no_groups(tbl_df(df)) }) test_that("grouping by constant adds column (#410)", { grouped <- group_by(mtcars, "cyl") %>% summarise(foo = n()) expect_equal(names(grouped), c('"cyl"', "foo")) expect_equal(nrow(grouped), 1L) }) # Test full range of variable types -------------------------------------------- test_that("local group_by preserves variable types", { df_var <- tibble( l = c(T, F), i = 1:2, d = Sys.Date() + 1:2, f = factor(letters[1:2]), num = 1:2 + 0.5, t = Sys.time() + 1:2, c = letters[1:2] ) for (var in names(df_var)) { expected <- tibble(unique(df_var[[var]]), n = 1L) names(expected)[1] <- var summarised <- df_var %>% group_by(!!sym(var)) %>% summarise(n = n()) expect_equal(summarised, expected, info = var) } }) test_that("mutate does not loose variables (#144)", { df <- tbl_df(data.frame(a = rep(1:4, 2), b = rep(1:4, each = 2), x = runif(8))) by_ab <- group_by(df, a, b) by_a <- summarise(by_ab, x = sum(x)) by_a_quartile <- group_by(by_a, quartile = ntile(x, 4)) expect_equal(names(by_a_quartile), c("a", "b", "x", "quartile")) }) test_that("group_by uses shallow copy", { m1 <- group_by(mtcars, cyl) expect_no_groups(mtcars) expect_equal(dfloc(mtcars), dfloc(m1)) }) test_that("group_by handles NA in factors #341", { d <- tibble(x = 1:3, f = factor(c("a", "b", NA))) expect_warning(g <- group_by(d, f), "Factor `f` contains implicit NA") expect_equal(group_size(g), rep(1L, 3L)) d <- tibble( f1 = factor(c(1,1,2,2)), f2 = factor(c(1,2,1,NA)), x = 1:4 ) expect_warning(g <- group_by(d, f1, f2)) expect_equal(group_size(g), c(1L,1L,1L,1L)) expect_warning(g <- group_by(d, f1, f2, .drop = FALSE)) expect_equal(group_size(g), c(1L,1L,1L,0L,1L)) }) test_that("group_by orders by groups. #242", { df <- data.frame(a = sample(1:10, 3000, replace = TRUE)) %>% group_by(a) expect_equal(group_data(df)$a, 1:10) df <- data.frame(a = sample(letters[1:10], 3000, replace = TRUE), stringsAsFactors = FALSE) %>% group_by(a) expect_equal(group_data(df)$a, letters[1:10]) df <- data.frame(a = sample(sqrt(1:10), 3000, replace = TRUE)) %>% group_by(a) expect_equal(group_data(df)$a, sqrt(1:10)) }) test_that("group_by only allows grouping by columns whos class are on the allow list", { df <- data.frame(times = 1:5, x = 1:5) df$times <- as.POSIXlt(seq.Date(Sys.Date(), length.out = 5, by = "day")) expect_error( group_by(df, times), "Column `times` can't be used as a grouping variable because it's a POSIXlt/POSIXt", fixed = TRUE ) }) test_that("group_by only applies the allow list to grouping variables", { df <- data.frame(times = 1:5, x = 1:5) df$times <- as.POSIXlt(seq.Date(Sys.Date(), length.out = 5, by = "day")) res <- group_by(df, x, .drop = FALSE) expect_equal(groups(res), list(sym("x"))) expect_identical( group_data(res), structure(tibble(x := 1:5, ".rows" := as.list(1:5)), .drop = FALSE) ) res <- group_by(df, x) expect_equal(groups(res), list(sym("x"))) expect_identical( group_data(res), structure(tibble(x := 1:5, ".rows" := as.list(1:5)), .drop = TRUE) ) }) test_that("group_by fails when lists are used as grouping variables (#276)", { df <- data.frame(x = 1:3) df$y <- list(1:2, 1:3, 1:4) expect_error( group_by(df, y), "Column `y` can't be used as a grouping variable because it's a list", fixed = TRUE ) }) test_that("select(group_by(.)) implicitely adds grouping variables (#170)", { res <- mtcars %>% group_by(vs) %>% select(mpg) expect_equal(names(res), c("vs", "mpg")) }) test_that("grouped_df errors on NULL labels (#398)", { m <- mtcars %>% group_by(cyl) attr(m, "groups") <- NULL expect_error( m %>% do(mpg = mean(.$mpg)), "is a corrupt grouped_df", fixed = TRUE ) }) test_that("grouped_df errors on non-existent var (#2330)", { df <- data.frame(x = 1:5) expect_error( grouped_df(df, list(quote(y)), FALSE), "Column `y` is unknown" ) }) test_that("group_by only creates one group for NA (#401)", { x <- as.numeric(c(NA, NA, NA, 10:1, 10:1)) w <- c(20, 30, 40, 1:10, 1:10) * 10 n_distinct(x) # 11 OK res <- data.frame(x = x, w = w) %>% group_by(x) %>% summarise(n = n()) expect_equal(nrow(res), 11L) }) test_that("there can be 0 groups (#486)", { data <- tibble(a = numeric(0), g = character(0)) %>% group_by(g) expect_equal(length(data$a), 0L) expect_equal(length(data$g), 0L) expect_equal(map_int(group_rows(data), length), integer(0)) }) test_that("group_by works with zero-row data frames (#486)", { df <- data.frame(a = numeric(0), b = numeric(0), g = character(0)) dfg <- group_by(df, g, .drop = FALSE) expect_equal(dim(dfg), c(0, 3)) expect_groups(dfg, "g") expect_equal(group_size(dfg), integer(0)) x <- summarise(dfg, n = n()) expect_equal(dim(x), c(0, 2)) expect_no_groups(x) x <- mutate(dfg, c = b + 1) expect_equal(dim(x), c(0, 4)) expect_groups(x, "g") expect_equal(group_size(x), integer(0)) x <- filter(dfg, a == 100) expect_equal(dim(x), c(0, 3)) expect_groups(x, "g") expect_equal(group_size(x), integer(0)) x <- arrange(dfg, a, g) expect_equal(dim(x), c(0, 3)) expect_groups(x, "g") expect_equal(group_size(x), integer(0)) x <- select(dfg, a) # Only select 'a' column; should result in 'g' and 'a' expect_equal(dim(x), c(0, 2)) expect_groups(x, "g") expect_equal(group_size(x), integer(0)) }) test_that("grouped_df requires a list of symbols (#665)", { features <- list("feat1", "feat2", "feat3") # error message by assertthat expect_error(grouped_df(data.frame(feat1 = 1, feat2 = 2, feat3 = 3), features)) }) test_that("group_by gives meaningful message with unknow column (#716)", { expect_error( group_by(iris, wrong_name_of_variable), "Column `wrong_name_of_variable` is unknown", fixed = TRUE ) }) test_that("[ on grouped_df preserves grouping if subset includes grouping vars", { df <- tibble(x = 1:5, ` ` = 6:10) by_x <- df %>% group_by(x) expect_equal(by_x %>% groups(), by_x %>% `[`(1:2) %>% groups()) # non-syntactic name by_ns <- df %>% group_by(` `) expect_equal(by_ns %>% groups(), by_ns %>% `[`(1:2) %>% groups()) }) test_that("[ on grouped_df drops grouping if subset doesn't include grouping vars", { by_cyl <- mtcars %>% group_by(cyl) no_cyl <- by_cyl %>% `[`(c(1, 3)) expect_no_groups(no_cyl) expect_is(no_cyl, "tbl_df") }) test_that("group_by works after arrange (#959)", { df <- tibble(Log = c(1, 2, 1, 2, 1, 2), Time = c(10, 1, 3, 0, 15, 11)) res <- df %>% arrange(Time) %>% group_by(Log) %>% mutate(Diff = Time - lag(Time)) expect_true(all(is.na(res$Diff[c(1, 3)]))) expect_equal(res$Diff[c(2, 4, 5, 6)], c(1, 7, 10, 5)) }) test_that("group_by keeps attributes", { d <- data.frame(x = structure(1:10, foo = "bar")) gd <- group_by(d) expect_equal(attr(gd$x, "foo"), "bar") }) test_that("ungroup.rowwise_df gives a tbl_df (#936)", { res <- tbl_df(mtcars) %>% rowwise() %>% ungroup() %>% class() expect_equal(res, c("tbl_df", "tbl", "data.frame")) }) test_that(paste0("group_by handles encodings for native strings (#1507)"), { with_non_utf8_encoding({ special <- get_native_lang_string() df <- data.frame(x = 1:3, Eng = 2:4) for (names_converter in c(enc2native, enc2utf8)) { for (dots_converter in c(enc2native, enc2utf8)) { names(df) <- names_converter(c(special, "Eng")) res <- group_by(df, !!!syms(dots_converter(special))) expect_equal(names(res), names(df)) expect_groups(res, special) } } for (names_converter in c(enc2native, enc2utf8)) { names(df) <- names_converter(c(special, "Eng")) res <- group_by(df, !!!special) expect_equal(names(res), c(names(df), deparse(special))) expect_equal(groups(res), list(as.name(enc2native(deparse(special))))) } }) }) test_that("group_by handles raw columns (#1803)", { df <- tibble(a = 1:3, b = as.raw(1:3)) expect_identical(ungroup(group_by(df, a)), df) expect_identical(ungroup(group_by(df, b)), df) }) test_that("rowwise handles raw columns (#1803)", { df <- tibble(a = 1:3, b = as.raw(1:3)) expect_is(rowwise(df), "rowwise_df") }) test_that("group_by() names pronouns correctly (#2686)", { expect_named(group_by(tibble(x = 1), .data$x), "x") expect_named(group_by(tibble(x = 1), .data[["x"]]), "x") }) test_that("group_by() does not affect input data (#3028)", { x <- data.frame(old1 = c(1, 2, 3), old2 = c(4, 5, 6)) %>% group_by(old1) y <- x %>% select(new1 = old1, new2 = old2) expect_identical(groups(x), syms(quote(old1))) }) test_that("group_by() does not mutate for nothing when using the .data pronoun (#2752, #3533)", { expect_equal( iris %>% group_by(Species) %>% group_by(.data$Species), iris %>% group_by(Species) ) expect_equal( iris %>% group_by(Species) %>% group_by(.data[["Species"]]), iris %>% group_by(Species) ) df <- tibble(x = 1:5) attr(df, "y") <- 1 expect_equal( df %>% group_by(.data$x) %>% attr("y"), 1 ) expect_equal( df %>% group_by(.data[["x"]]) %>% attr("y"), 1 ) }) test_that("tbl_sum gets the right number of groups", { res <- data.frame(x=c(1,1,2,2)) %>% group_by(x) %>% tbl_sum() expect_equal(res, c("A tibble" = "4 x 1", "Groups" = "x [2]")) }) test_that("grouped data frames support drop=TRUE (#3714)", { expect_is(group_by(iris, Species)[ , "Sepal.Width", drop=TRUE], "numeric") expect_is(group_by(iris, Species)[ , c("Species", "Sepal.Width"), drop=TRUE], "grouped_df") }) test_that("group_by ignores empty quosures (3780)", { empty <- quo() expect_equal(group_by(mtcars, cyl), group_by(mtcars, cyl, !!empty)) }) test_that("group_cols() selects grouping variables", { expect_identical(select(mtcars, group_cols()), select(mtcars)) expect_identical(select(group_by(mtcars, cyl, am), group_cols()), group_by_all(select(mtcars, cyl, am))) expect_identical(mutate_at(group_by(iris, Species), vars(-group_cols()), `/`, 100), mutate_all(group_by(iris, Species), `/`, 100)) }) # Zero groups --------------------------------------------------- test_that("mutate handles grouped tibble with 0 groups (#3935)", { df <- tibble(x=integer()) %>% group_by(x) res <- mutate(df, y = mean(x), z = +mean(x), n = n()) expect_equal(names(res), c("x", "y", "z", "n")) expect_equal(nrow(res), 0L) expect_equal(res$y, double()) expect_equal(res$z, double()) expect_equal(res$n, integer()) }) test_that("summarise handles grouped tibble with 0 groups (#3935)", { df <- tibble(x=integer()) %>% group_by(x) res <- summarise(df, y = mean(x), z = +mean(x), n = n()) expect_equal(names(res), c("x", "y", "z", "n")) expect_equal(nrow(res), 0L) expect_equal(res$y, double()) expect_equal(res$n, integer()) expect_equal(res$z, double()) }) test_that("filter handles grouped tibble with 0 groups (#3935)", { df <- tibble(x=integer()) %>% group_by(x) res <- filter(df, x > 3L) expect_identical(df, res) }) test_that("select handles grouped tibble with 0 groups (#3935)", { df <- tibble(x=integer()) %>% group_by(x) res <- select(df, x) expect_identical(df, res) }) test_that("arrange handles grouped tibble with 0 groups (#3935)", { df <- tibble(x=integer()) %>% group_by(x) res <- arrange(df, x) expect_identical(df, res) }) test_that("group_by() with empty spec produces a grouped data frame with 0 grouping variables", { gdata <- group_data(group_by(iris)) expect_equal(names(gdata), ".rows") expect_equal(gdata$.rows, list(1:nrow(iris))) }) # .drop = TRUE --------------------------------------------------- test_that("group_by(.drop = TRUE) drops empty groups (4061)", { res <- iris %>% filter(Species == "setosa") %>% group_by(Species, .drop = TRUE) expect_identical( group_data(res), structure( tibble(Species = factor("setosa", levels = levels(iris$Species)), .rows := list(1:50)), .drop = TRUE ) ) expect_true(group_by_drop_default(res)) }) test_that("grouped data frames remember their .drop (#4061)", { res <- iris %>% filter(Species == "setosa") %>% group_by(Species, .drop = TRUE) res2 <- res %>% filter(Sepal.Length > 5) expect_true(group_by_drop_default(res2)) res3 <- res %>% filter(Sepal.Length > 5, .preserve = FALSE) expect_true(group_by_drop_default(res3)) res4 <- res3 %>% group_by(Species) expect_true(group_by_drop_default(res4)) expect_equal(nrow(group_data(res4)), 1L) }) test_that("grouped data frames remember their .drop = FALSE (#4337)", { res <- iris %>% filter(Species == "setosa") %>% group_by(Species, .drop = FALSE) expect_false(group_by_drop_default(res)) res2 <- res %>% group_by(Species) expect_false(group_by_drop_default(res2)) }) test_that("summarise maintains the .drop attribute (#4061)", { df <- tibble( f1 = factor("a", levels = c("a", "b", "c")), f2 = factor("d", levels = c("d", "e", "f", "g")), x = 42 ) res <- df %>% group_by(f1, f2, .drop = TRUE) expect_equal(n_groups(res), 1L) res2 <- summarise(res, x = sum(x)) expect_equal(n_groups(res2), 1L) expect_true(group_by_drop_default(res2)) }) test_that("joins maintain the .drop attribute (#4061)", { df1 <- group_by(tibble( f1 = factor(c("a", "b"), levels = c("a", "b", "c")), x = 42:43 ), f1, .drop = TRUE) df2 <- group_by(tibble( f1 = factor(c("a"), levels = c("a", "b", "c")), y = 1 ), f1, .drop = TRUE) res <- left_join(df1, df2) expect_equal(n_groups(res), 2L) df2 <- group_by(tibble( f1 = factor(c("a", "c"), levels = c("a", "b", "c")), y = 1:2 ), f1, .drop = TRUE) res <- full_join(df1, df2) expect_equal(n_groups(res), 3L) }) test_that("group_by(add = TRUE) sets .drop if the origonal data was .drop", { d <- tibble( f1 = factor("b", levels = c("a", "b", "c")), f2 = factor("g", levels = c("e", "f", "g")), x = 48 ) res <- group_by(group_by(d, f1, .drop = TRUE), f2, add = TRUE) expect_equal(n_groups(res), 1L) expect_true(group_by_drop_default(res)) }) test_that("group_by() makes a shallow copy of data even in the corner case", { df <- data.frame(x = 1:4) gdf <- group_by(df) expect_true(inherits(gdf, "tbl_df")) expect_false(inherits(df, "tbl_df")) }) test_that("group_by_drop_default() is forgiving about corrupt grouped df (#4306)",{ df <- tibble(x = 1:2, y = 1:2) %>% structure(class = c("grouped_df", "tbl_df", "tbl", "data.frame")) expect_true(group_by_drop_default(df)) }) test_that("group_by() puts NA groups last in STRSXP (#4227)", { res <- tibble(x = c("apple", NA, "banana"), y = 1:3) %>% group_by(x) %>% group_data() expect_identical(res$x, c("apple", "banana", NA_character_)) expect_identical(res$.rows, list(1L, 3L, 2L)) }) dplyr/tests/testthat/test-binds.R0000644000176200001440000004232513614573562016627 0ustar liggesuserscontext("binds") # error ------------------------------------------------------------------- test_that("bind_rows() and bind_cols() err for non-data frames (#2373)", { df1 <- tibble(x = 1) df2 <- structure(list(x = 1), class = "blah_frame") expect_error( bind_cols(df1, df2), "Argument 2 must be a data frame or a named atomic vector, not a blah_frame", fixed = TRUE ) expect_error( bind_rows(df1, df2), "Argument 2 must be a data frame or a named atomic vector, not a blah_frame", fixed = TRUE ) }) test_that("bind_rows() err for invalid ID", { df1 <- tibble(x = 1:3) df2 <- tibble(x = 4:6) expect_error( bind_rows(df1, df2, .id = 5), "`.id` must be a scalar string, not a double vector of length 1", fixed = TRUE ) }) # columns ----------------------------------------------------------------- test_that("cbind uses shallow copies", { df1 <- data.frame( int = 1:10, num = rnorm(10), cha = letters[1:10], stringsAsFactors = FALSE ) df2 <- data.frame( log = sample(c(T, F), 10, replace = TRUE), dat = seq.Date(Sys.Date(), length.out = 10, by = "day"), tim = seq(Sys.time(), length.out = 10, by = "1 hour") ) df <- bind_cols(df1, df2) expect_equal(dfloc(df1), dfloc(df)[names(df1)]) expect_equal(dfloc(df2), dfloc(df)[names(df2)]) }) test_that("bind_cols handles lists (#1104)", { exp <- tibble(x = 1, y = "a", z = 2) l1 <- list(x = 1, y = "a") l2 <- list(z = 2) expect_equal(bind_cols(l1, l2), exp) expect_equal(bind_cols(list(l1, l2)), exp) }) test_that("bind_cols handles empty argument list (#1963)", { expect_equal(bind_cols(), data.frame()) }) test_that("bind_cols handles all-NULL values (#2303)", { expect_identical(bind_cols(list(a = NULL, b = NULL)), data.frame()) expect_identical(bind_cols(NULL), data.frame()) }) test_that("bind_cols repairs names", { df <- tibble(a = 1, b = 2) bound <- bind_cols(df, df) repaired <- as_tibble(tibble::repair_names( data.frame(a = 1, b = 2, a = 1, b = 2, check.names = FALSE) )) expect_equal(bound, repaired) }) # rows -------------------------------------------------------------------- df_var <- tibble( l = c(T, F, F), i = c(1, 1, 2), d = Sys.Date() + c(1, 1, 2), f = factor(letters[c(1, 1, 2)]), n = c(1, 1, 2) + 0.5, t = Sys.time() + c(1, 1, 2), c = letters[c(1, 1, 2)] ) test_that("bind_rows() equivalent to rbind()", { exp <- tbl_df(rbind(df_var, df_var, df_var)) expect_equal(bind_rows(df_var, df_var, df_var), exp) expect_equal(bind_rows(list(df_var, df_var, df_var)), exp) }) test_that("bind_rows reorders columns", { df_var_scramble <- df_var[sample(ncol(df_var))] expect_equal( names(bind_rows(df_var, df_var_scramble)), names(df_var) ) }) test_that("bind_rows ignores NULL", { df <- tibble(a = 1) expect_equal(bind_rows(df, NULL), df) expect_equal(bind_rows(list(df, NULL)), df) }) test_that("bind_rows only accepts data frames or named vectors", { ll <- list(1:5, env(a = 1)) expect_error( bind_rows(ll), "Argument 1 must have names", fixed = TRUE ) ll <- list(tibble(a = 1:5), env(a = 1)) expect_error( bind_rows(ll), "Argument 2 must be a data frame or a named atomic vector, not a environment", fixed = TRUE ) }) test_that("bind_rows handles list columns (#463)", { dfl <- tibble(x = I(list(1:2, 1:3, 1:4))) res <- bind_rows(list(dfl, dfl)) expect_equal(rep(dfl$x, 2L), res$x) }) test_that("can bind lists of data frames #1389", { df <- tibble(x = 1) res <- bind_rows(list(df, df), list(df, df)) expect_equal(nrow(res), 4) }) test_that("bind_rows handles data frames with no rows (#597)", { df1 <- tibble(x = 1, y = factor("a")) df0 <- df1[0, ] expect_equal(bind_rows(df0), df0) expect_equal(bind_rows(df0, df0), df0) expect_equal(bind_rows(df0, df1), df1) }) test_that("bind_rows handles data frames with no columns (#1346)", { df1 <- tibble(x = 1, y = factor("a")) df0 <- df1[, 0] expect_equal(bind_rows(df0), df0) expect_equal(dim(bind_rows(df0, df0)), c(2, 0)) res <- bind_rows(df0, df1) expect_equal(res$x, c(NA, 1)) }) test_that("bind_rows handles lists with NULL values (#2056)", { df1 <- tibble(x = 1, y = 1) df2 <- tibble(x = 2, y = 2) lst1 <- list(a = df1, NULL, b = df2) df3 <- tibble( names = c("a", "b"), x = c(1, 2), y = c(1, 2) ) expect_equal(bind_rows(lst1, .id = "names"), df3) }) test_that("bind_rows handles lists with list() values (#2826)", { expect_equal(bind_rows(list(iris, list())), iris) }) test_that("bind_rows puts data frames in order received even if no columns (#2175)", { df2 <- tibble(x = 2, y = "b") df1 <- df2[, 0] res <- bind_rows(df1, df2) expect_equal(res$x, c(NA, 2)) expect_equal(res$y, c(NA, "b")) }) # Column coercion -------------------------------------------------------------- test_that("bind_rows promotes integer to numeric", { df1 <- tibble(a = 1L, b = 1L) df2 <- tibble(a = 1, b = 1L) res <- bind_rows(df1, df2) expect_equal(typeof(res$a), "double") expect_equal(typeof(res$b), "integer") }) test_that("bind_rows does not coerce logical to integer", { df1 <- tibble(a = FALSE) df2 <- tibble(a = 1L) expect_error( bind_rows(df1, df2), "Column `a` can't be converted from logical to integer", fixed = TRUE ) }) test_that("bind_rows promotes factor to character with warning", { df1 <- tibble(a = factor("a")) df2 <- tibble(a = "b") expect_warning( res <- bind_rows(df1, df2), "binding factor and character vector, coercing into character vector" ) expect_equal(typeof(res$a), "character") }) test_that("bind_rows coerces factor to character when levels don't match", { df1 <- data.frame(a = factor("a")) df2 <- data.frame(a = factor("b")) expect_warning( res <- bind_rows(df1, df2), "Unequal factor levels: coercing to character" ) expect_equal(res$a, c("a", "b")) }) test_that("bind_rows handles NA in factors #279", { df1 <- tibble(a = factor("a")) df2 <- tibble(a = factor(NA)) expect_warning(res <- bind_rows(df1, df2), "Unequal factor levels") expect_equal(res$a, c("a", NA)) }) test_that("bind_rows doesn't promote integer/numeric to factor", { df1 <- tibble(a = factor("a")) df2 <- tibble(a = 1L) df3 <- tibble(a = 1) expect_error( bind_rows(df1, df2), "Column `a` can't be converted from factor to integer", fixed = TRUE ) expect_error( bind_rows(df1, df3), "Column `a` can't be converted from factor to numeric", fixed = TRUE ) }) test_that("bind_rows preserves timezones #298", { dates1 <- data.frame( ID = c("a", "b", "c"), dates = structure(c(-247320000, -246196800, -245073600), tzone = "GMT", class = c("POSIXct", "POSIXt") ), stringsAsFactors = FALSE ) dates2 <- data.frame( ID = c("d", "e", "f"), dates = structure(c(-243864000, -242654400, -241444800), tzone = "GMT", class = c("POSIXct", "POSIXt") ), stringsAsFactors = FALSE ) alldates <- bind_rows(dates1, dates2) expect_equal(attr(alldates$dates, "tzone"), "GMT") }) test_that("bind_rows handles all NA columns (#493)", { mydata <- list( data.frame(x = c("foo", "bar")), data.frame(x = NA) ) res <- bind_rows(mydata) expect_true(is.na(res$x[3])) expect_is(res$x, "factor") mydata <- list( data.frame(x = NA), data.frame(x = c("foo", "bar")) ) res <- bind_rows(mydata) expect_true(is.na(res$x[1])) expect_is(res$x, "factor") }) test_that("bind_rows handles complex. #933", { df1 <- data.frame(r = c(1 + 1i, 2 - 1i)) df2 <- data.frame(r = c(1 - 1i, 2 + 1i)) df3 <- bind_rows(df1, df2) expect_equal(nrow(df3), 4L) expect_equal(df3$r, c(df1$r, df2$r)) }) test_that("bind_rows is careful about column names encoding #1265", { one <- data.frame(foo = 1:3, bar = 1:3) names(one) <- c("f\u00fc", "bar") two <- data.frame(foo = 1:3, bar = 1:3) names(two) <- c("f\u00fc", "bar") Encoding(names(one)[1]) <- "UTF-8" expect_equal(names(one), names(two)) res <- bind_rows(one, two) expect_equal(ncol(res), 2L) }) test_that("bind_rows handles POSIXct (#1125)", { df1 <- data.frame(date = as.POSIXct(NA)) df2 <- data.frame(date = as.POSIXct("2015-05-05")) res <- bind_rows(df1, df2) expect_equal(nrow(res), 2L) expect_true(is.na(res$date[1])) }) test_that("bind_rows respects ordered factors (#1112)", { l <- c("a", "b", "c", "d") id <- factor(c("a", "c", "d"), levels = l, ordered = TRUE) df <- data.frame(id = rep(id, 2), val = rnorm(6)) res <- bind_rows(df, df) expect_is(res$id, "ordered") expect_equal(levels(df$id), levels(res$id)) res <- group_by(df, id) %>% do(na.omit(.)) expect_is(res$id, "ordered") expect_equal(levels(df$id), levels(res$id)) }) test_that("bind_rows can handle lists (#1104)", { my_list <- list(tibble(x = 1, y = "a"), tibble(x = 2, y = "b")) res <- bind_rows(my_list) expect_equal(nrow(res), 2L) expect_is(res$x, "numeric") expect_is(res$y, "character") res <- bind_rows(list(x = 1, y = "a"), list(x = 2, y = "b")) expect_equal(nrow(res), 2L) expect_is(res$x, "numeric") expect_is(res$y, "character") }) test_that("bind_rows keeps ordered factors (#948)", { y <- bind_rows( data.frame(x = factor(c(1, 2, 3), ordered = TRUE)), data.frame(x = factor(c(1, 2, 3), ordered = TRUE)) ) expect_is(y$x, "ordered") expect_equal(levels(y$x), as.character(1:3)) }) test_that("bind handles POSIXct of different tz ", { date1 <- structure(-1735660800, tzone = "America/Chicago", class = c("POSIXct", "POSIXt")) date2 <- structure(-1735660800, tzone = "UTC", class = c("POSIXct", "POSIXt")) date3 <- structure(-1735660800, class = c("POSIXct", "POSIXt")) df1 <- data.frame(date = date1) df2 <- data.frame(date = date2) df3 <- data.frame(date = date3) res <- bind_rows(df1, df2) expect_equal(attr(res$date, "tzone"), "UTC") res <- bind_rows(df1, df3) expect_equal(attr(res$date, "tzone"), "America/Chicago") res <- bind_rows(df2, df3) expect_equal(attr(res$date, "tzone"), "UTC") res <- bind_rows(df3, df3) expect_equal(attr(res$date, "tzone"), NULL) res <- bind_rows(df1, df2, df3) expect_equal(attr(res$date, "tzone"), "UTC") }) test_that("bind_rows() creates a column of identifiers (#1337)", { data1 <- mtcars[c(2, 3), ] data2 <- mtcars[1, ] out <- bind_rows(data1, data2, .id = "col") out_list <- bind_rows(list(data1, data2), .id = "col") expect_equal(names(out)[1], "col") expect_equal(out$col, c("1", "1", "2")) expect_equal(out_list$col, c("1", "1", "2")) out_labelled <- bind_rows(one = data1, two = data2, .id = "col") out_list_labelled <- bind_rows(list(one = data1, two = data2), .id = "col") expect_equal(out_labelled$col, c("one", "one", "two")) expect_equal(out_list_labelled$col, c("one", "one", "two")) }) test_that("string vectors are filled with NA not blanks before collection (#595)", { one <- mtcars[1:10, -10] two <- mtcars[11:32, ] two$char_col <- letters[1:22] res <- bind_rows(one, two) expect_true(all(is.na(res$char_col[1:10]))) }) test_that("bind_rows handles POSIXct stored as integer (#1402)", { now <- Sys.time() df1 <- data.frame(time = now) expect_equal(class(bind_rows(df1)$time), c("POSIXct", "POSIXt")) df2 <- data.frame(time = seq(now, length.out = 1, by = 1)) expect_equal(class(bind_rows(df2)$time), c("POSIXct", "POSIXt")) res <- bind_rows(df1, df2) expect_equal(class(res$time), c("POSIXct", "POSIXt")) expect_true(all(res$time == c(df1$time, df2$time))) }) test_that("bind_cols accepts NULL (#1148)", { df1 <- tibble(a = 1:10, b = 1:10) df2 <- tibble(c = 1:10, d = 1:10) res1 <- bind_cols(df1, df2) res2 <- bind_cols(NULL, df1, df2) res3 <- bind_cols(df1, NULL, df2) res4 <- bind_cols(df1, df2, NULL) expect_equal(res1, res2) expect_equal(res1, res3) expect_equal(res1, res4) }) test_that("bind_rows handles 0-length named list (#1515)", { res <- bind_rows(list(a = 1)[-1]) expect_equal(nrow(res), 0L) expect_is(res, "data.frame") expect_equal(ncol(res), 0L) }) test_that("bind_rows handles promotion to strings (#1538)", { df1 <- tibble(b = c(1, 2)) df2 <- tibble(b = c(1L, 2L)) df3 <- tibble(b = factor(c("A", "B"))) df4 <- tibble(b = c("C", "D")) expect_error( bind_rows(df1, df3), "Column `b` can't be converted from numeric to factor", fixed = TRUE ) expect_error( bind_rows(df1, df4), "Column `b` can't be converted from numeric to character", fixed = TRUE ) expect_error( bind_rows(df2, df3), "Column `b` can't be converted from integer to factor", fixed = TRUE ) expect_error( bind_rows(df2, df4), "Column `b` can't be converted from integer to character", fixed = TRUE ) }) test_that("bind_rows infers classes from first result (#1692)", { d1 <- data.frame(a = 1:10, b = rep(1:2, each = 5)) d2 <- tbl_df(d1) d3 <- group_by(d1, b) d4 <- rowwise(d1) d5 <- list(a = 1:10, b = rep(1:2, each = 5)) expect_equal(class(bind_rows(d1, d1)), "data.frame") expect_equal(class(bind_rows(d2, d1)), c("tbl_df", "tbl", "data.frame")) res3 <- bind_rows(d3, d1) expect_equal(class(res3), c("grouped_df", "tbl_df", "tbl", "data.frame")) expect_equal(map_int(group_rows(res3), length), c(10, 10)) expect_equal(class(bind_rows(d4, d1)), c("rowwise_df", "tbl_df", "tbl", "data.frame")) expect_equal(class(bind_rows(d5, d1)), c("tbl_df", "tbl", "data.frame")) }) test_that("bind_cols infers classes from first result (#1692)", { d1 <- data.frame(a = 1:10, b = rep(1:2, each = 5)) d2 <- tibble(c = 1:10, d = rep(1:2, each = 5)) d3 <- group_by(d2, d) d4 <- rowwise(d2) d5 <- list(c = 1:10, d = rep(1:2, each = 5)) expect_equal(class(bind_cols(d1, d1)), "data.frame") expect_equal(class(bind_cols(d2, d1)), c("tbl_df", "tbl", "data.frame")) res3 <- bind_cols(d3, d1) expect_equal(class(res3), c("grouped_df", "tbl_df", "tbl", "data.frame")) expect_equal(map_int(group_rows(res3), length), c(5, 5)) expect_equal(class(bind_cols(d4, d1)), c("rowwise_df", "tbl_df", "tbl", "data.frame")) expect_equal(class(bind_cols(d5, d1)), c("tbl_df", "tbl", "data.frame")) }) test_that("bind_rows rejects POSIXlt columns (#1789)", { df <- tibble(x = Sys.time() + 1:12) df$y <- as.POSIXlt(df$x) expect_error( bind_rows(df, df), "Argument 2 can't be a list containing POSIXlt values", fixed = TRUE ) }) test_that("bind_rows rejects data frame columns (#2015)", { df <- list( x = 1:10, y = data.frame(a = 1:10, y = 1:10) ) class(df) <- "data.frame" attr(df, "row.names") <- .set_row_names(10) expect_error( dplyr::bind_rows(df, df), "Argument 2 can't be a list containing data frames", fixed = TRUE ) }) test_that("bind_rows accepts difftime objects", { df1 <- data.frame(x = as.difftime(1, units = "hours")) df2 <- data.frame(x = as.difftime(1, units = "mins")) res <- bind_rows(df1, df2) expect_equal(res$x, as.difftime(c(3600, 60), units = "secs")) }) test_that("bind_rows accepts hms objects", { df1 <- data.frame(x = hms::hms(hours = 1)) df2 <- data.frame(x = as.difftime(1, units = "mins")) res <- bind_rows(df1, df2) expect_equal(res$x, hms::hms(hours = c(1, 0), minutes = c(0, 1))) }) test_that("bind_rows() fails with unnamed vectors", { expect_error( bind_rows(1:2), "Argument 1 must have names", fixed = TRUE ) }) test_that("bind_rows() handles rowwise vectors", { expect_warning( regex = "character and factor", tbl <- bind_rows( tibble(a = "foo", b = "bar"), c(a = "A", b = "B"), set_names(factor(c("B", "B")), c("a", "b")) ) ) expect_identical(tbl, tibble(a = c("foo", "A", "B"), b = c("bar", "B", "B"))) id_tbl <- bind_rows(a = c(a = 1, b = 2), b = c(a = 3, b = 4), .id = "id") expect_identical(id_tbl, tibble(id = c("a", "b"), a = c(1, 3), b = c(2, 4))) }) test_that("bind_rows() accepts lists of dataframe-like lists as first argument", { expect_identical(bind_rows(list(list(a = 1, b = 2))), tibble(a = 1, b = 2)) }) test_that("columns that are OBJECT but have NULL class are handled gracefully (#3349)", { mod <- lm(y ~ ., data = freeny) data <- model.frame(mod) data_list <- list(data, data) res <- bind_rows(data_list) expect_equal(names(res), names(data)) }) # Vectors ------------------------------------------------------------ test_that("accepts named columns", { expect_identical(bind_cols(a = 1:2, b = 3:4), tibble(a = 1:2, b = 3:4)) expect_equal(bind_cols(!!!mtcars), as_tibble(mtcars)) }) test_that("uncompatible sizes fail", { expect_error( bind_cols(a = 1, mtcars), "Argument 2 must be length 1, not 32", fixed = TRUE ) expect_error( bind_cols(mtcars, a = 1:3), "Argument 2 must be length 32, not 3", fixed = TRUE ) }) test_that("unnamed vectors fail", { expect_error( bind_cols(1:2), "Argument 1 must have names", fixed = TRUE ) expect_error( bind_cols(!!!list(1:2)), "Argument 1 must have names", fixed = TRUE ) }) test_that("supports NULL values", { expect_identical(bind_cols(a = 1, NULL, b = 2, NULL), tibble(a = 1, b = 2)) }) test_that("bind_cols handles unnamed list (#3402)", { expect_identical( bind_cols(list(1, 2)), bind_cols(list(V1 = 1, V2 = 2)) ) }) test_that("bind_rows handles typed lists (#3924)", { df <- data.frame(x = 1, y = 2) lst <- structure(list(df, df, df), class = "special_lst") expect_equal(bind_rows(lst), bind_rows(df,df,df)) }) dplyr/tests/testthat/test-group_nest.R0000644000176200001440000000333013614573562017706 0ustar liggesuserscontext("group_nest") test_that("group_nest() works", { grouped <- group_by(starwars, species, homeworld) gdata <- group_data(grouped) res <- group_nest(starwars, species, homeworld) expect_is(pull(res), "list") expect_equal(select(res, -last_col()), select(gdata, -last_col())) nested <- bind_rows(!!!res$data) expect_equal(names(nested), setdiff(names(starwars), c("species", "homeworld"))) }) test_that("group_nest() can keep the grouping variables", { grouped <- group_by(starwars, species, homeworld) gdata <- group_data(grouped) res <- group_nest(starwars, species, homeworld, keep = TRUE) nested <- bind_rows(!!!res$data) expect_equal(names(nested), names(starwars)) }) test_that("group_nest() works on grouped data frames", { grouped <- group_by(starwars, species, homeworld) gdata <- group_data(grouped) res <- group_nest(grouped) expect_is(pull(res), "list") expect_equal(select(res, -last_col()), select(gdata, -last_col())) expect_equal(names(bind_rows(!!!res$data)), setdiff(names(starwars), c("species", "homeworld"))) res <- group_nest(grouped, keep = TRUE) expect_is(pull(res), "list") expect_equal(select(res, -last_col()), select(gdata, -last_col())) expect_equal(names(bind_rows(!!!res$data)), names(starwars)) }) test_that("group_nest.grouped_df() warns about ...", { expect_warning(group_nest(group_by(mtcars, cyl), cyl)) }) test_that("group_nest() works if no grouping column", { res <- group_nest(iris) expect_equal(res$data, list(iris)) expect_equal(names(res), "data") }) test_that("group_nest() respects .drop", { nested <- tibble(f = factor("b", levels = c("a", "b", "c")), x = 1, y = 2) %>% group_nest(f, .drop = TRUE) expect_equal(nrow(nested), 1L) }) dplyr/tests/testthat/test-distinct.R0000644000176200001440000001333113614573562017344 0ustar liggesuserscontext("Distinct") test_that("distinct equivalent to local unique when keep_all is TRUE", { df <- data.frame( x = c(1, 1, 1, 1), y = c(1, 1, 2, 2), z = c(1, 2, 1, 2) ) expect_equal(distinct(df), unique(df)) }) test_that("distinct for single column works as expected (#1937)", { df <- tibble( x = c(1, 1, 1, 1), y = c(1, 1, 2, 2), z = c(1, 2, 1, 2) ) expect_equal(distinct(df, x, .keep_all = FALSE), unique(df["x"])) expect_equal(distinct(df, y, .keep_all = FALSE), unique(df["y"])) }) test_that("distinct works for 0-sized columns (#1437)", { df <- tibble(x = 1:10) %>% select(-x) ddf <- distinct(df) expect_equal(ncol(ddf), 0L) }) test_that("if no variables specified, uses all", { df <- tibble(x = c(1, 1), y = c(2, 2)) expect_equal(distinct(df), tibble(x = 1, y = 2)) }) test_that("distinct keeps only specified cols", { df <- tibble(x = c(1, 1, 1), y = c(1, 1, 1)) expect_equal(df %>% distinct(x), tibble(x = 1)) }) test_that("unless .keep_all = TRUE", { df <- tibble(x = c(1, 1, 1), y = 3:1) expect_equal(df %>% distinct(x), tibble(x = 1)) expect_equal(df %>% distinct(x, .keep_all = TRUE), tibble(x = 1, y = 3L)) }) test_that("distinct doesn't duplicate columns", { df <- tibble(a = 1:3, b = 4:6) expect_named(df %>% distinct(a, a), "a") expect_named(df %>% group_by(a) %>% distinct(a), "a") }) test_that("grouped distinct always includes group cols", { df <- tibble(g = c(1, 2), x = c(1, 2)) out <- df %>% group_by(g) %>% distinct(x) expect_equal(df, out) }) test_that("empty grouped distinct equivalent to empty ungrouped", { df <- tibble(g = c(1, 2), x = c(1, 2)) df1 <- df %>% distinct() %>% group_by(g) df2 <- df %>% group_by(g) %>% distinct() expect_equal(df1, df2) }) test_that("distinct gives a warning when selecting an unknown column (#3140)", { df <- tibble(g = c(1, 2), x = c(1, 2)) expect_warning( distinct(df, aa), glue("Trying to compute distinct() for variables not found in the data: - `aa` This is an error, but only a warning is raised for compatibility reasons. The operation will return the input unchanged."), fixed = TRUE ) expect_warning( distinct(df, .data$aa), glue("Trying to compute distinct() for variables not found in the data: - `aa` This is an error, but only a warning is raised for compatibility reasons. The operation will return the input unchanged."), fixed = TRUE ) expect_warning( distinct(df, aa, x), glue("Trying to compute distinct() for variables not found in the data: - `aa` This is an error, but only a warning is raised for compatibility reasons. The following variables will be used: - x"), fixed = TRUE ) expect_warning( distinct(df, .data$aa, x), glue("Trying to compute distinct() for variables not found in the data: - `aa` This is an error, but only a warning is raised for compatibility reasons. The following variables will be used: - x"), fixed = TRUE ) expect_warning( distinct(df, g, aa, x), glue("Trying to compute distinct() for variables not found in the data: - `aa` This is an error, but only a warning is raised for compatibility reasons. The following variables will be used: - g - x"), fixed = TRUE ) expect_warning( distinct(df, g, .data$aa, x), glue("Trying to compute distinct() for variables not found in the data: - `aa` This is an error, but only a warning is raised for compatibility reasons. The following variables will be used: - g - x"), fixed = TRUE ) }) test_that("distinct on a new, mutated variable is equivalent to mutate followed by distinct", { df <- tibble(g = c(1, 2), x = c(1, 2)) df1 <- df %>% distinct(aa = g * 2) df2 <- df %>% mutate(aa = g * 2) %>% distinct(aa) expect_equal(df1, df2) }) test_that("distinct on a new, copied variable is equivalent to mutate followed by distinct (#3234)", { df <- tibble(g = c(1, 2), x = c(1, 2)) df1 <- df %>% distinct(aa = g) df2 <- df %>% mutate(aa = g) %>% distinct(aa) expect_equal(df1, df2) }) test_that("distinct on a dataframe or tibble with columns of type list throws an error", { df <- tibble( a = c("1", "1", "2", "2", "3", "3"), b = list("A") ) df2 <- data.frame(x = 1:5, y = I(list(1:3, 2:4, 3:5, 4:6, 5:7))) expect_warning( expect_identical(df %>% distinct(), df %>% slice(c(1, 3, 5))), "distinct() does not fully support columns of type `list`.\nList elements are compared by reference, see ?distinct for details.\nThis affects the following columns:\n- `b`", fixed = TRUE ) expect_warning( expect_identical(df2 %>% distinct(), df2), "distinct() does not fully support columns of type `list`.\nList elements are compared by reference, see ?distinct for details.\nThis affects the following columns:\n- `y`", fixed = TRUE ) }) test_that("distinct deals with Period and Interval from lubridate (#2568)", { skip_if_not(requireNamespace("lubridate", quietly = TRUE)) df <- tibble( x = lubridate::hm("10:30", "10:30", "0:0"), y = c("apple", "apple", "tomato") ) res <- distinct(df) expect_equal(res, df[c(1, 3), ]) df <- tibble( lubridate::interval(lubridate::ymd(20090201), lubridate::ymd(20090101)) ) expect_equal(df, distinct(df)) }) test_that("distinct handles 0 columns edge case (#2954)", { d <- select(data.frame(x= c(1, 1)), one_of(character(0))) res <- distinct(d) expect_equal(nrow(res), 1L) expect_equal(nrow(distinct(tibble())), 0L) }) test_that("distinct respects the order of the given variables (#3195)",{ d <- data.frame(x=1:2, y=3:4) expect_equal(names(distinct(d, y, x)), c("y", "x")) }) dplyr/tests/testthat/test-utils.R0000644000176200001440000000141013614573562016656 0ustar liggesuserscontext("utils") test_that("check_pkg() gives correct error message", { expect_error( dplyr:::check_pkg("`__foobarbaz__`", "foobar a baz"), 'The `__foobarbaz__` package is required to foobar a baz.\nPlease install it with `install.packages("`__foobarbaz__`")`', fixed = TRUE ) expect_error( dplyr:::check_pkg("`__foobarbaz__`", "foobar a baz", install = FALSE), "The `__foobarbaz__` package is required to foobar a baz." ) }) test_that("quo_is_variable_reference handles .data",{ expect_true(quo_is_variable_reference(quo(x))) expect_true(quo_is_variable_reference(quo(.data$x))) expect_true(quo_is_variable_reference(quo(.data[["x"]]))) quo <- new_quosure(quote(.data[[identity("x")]])) expect_false(quo_is_variable_reference(quo)) }) dplyr/tests/testthat/test-summarise.r0000644000176200001440000010065713614573562017600 0ustar liggesuserscontext("Summarise") test_that("repeated outputs applied progressively", { df <- data.frame(x = 5) out <- summarise(df, x = mean(x), x = x + 1) expect_equal(nrow(out), 1) expect_equal(ncol(out), 1) expect_equal(out$x, 6) }) test_that("repeated outputs applied progressively (grouped_df)", { df <- data.frame(x = c(1, 1), y = 1:2) ds <- group_by(df, y) out <- summarise(ds, z = mean(x), z = z + 1) expect_equal(nrow(out), 2) expect_equal(ncol(out), 2) expect_equal(out$z, c(2L, 2L)) }) test_that("summarise peels off a single layer of grouping", { df <- tibble(x = rep(1:4, each = 4), y = rep(1:2, each = 8), z = runif(16)) grouped <- df %>% group_by(x, y, z) expect_equal(group_vars(grouped), c("x", "y", "z")) expect_equal(group_vars(grouped %>% summarise(n = n())), c("x", "y")) }) test_that("summarise can refer to variables that were just created (#138)", { res <- summarise(tbl_df(mtcars), cyl1 = mean(cyl), cyl2 = cyl1 + 1) expect_equal(res$cyl2, mean(mtcars$cyl) + 1) gmtcars <- group_by(tbl_df(mtcars), am) res <- summarise(gmtcars, cyl1 = mean(cyl), cyl2 = cyl1 + 1) res_direct <- summarise(gmtcars, cyl2 = mean(cyl) + 1) expect_equal(res$cyl2, res_direct$cyl2) }) test_that("summarise can refer to factor variables that were just created (#2217)", { df <- tibble(a = 1:3) %>% group_by(a) res <- df %>% summarise(f = factor(if_else(a <= 1, "a", "b")), g = (f == "a")) expect_equal( res, tibble(a = 1:3, f = factor(c("a", "b", "b")), g = c(TRUE, FALSE, FALSE)) ) }) test_that("summarise refuses to modify grouping variable (#143)", { df <- data.frame(a = c(1, 2, 1, 2), b = c(1, 1, 2, 2), x = 1:4) ds <- group_by(tbl_df(df), a, b) expect_error( summarise(ds, a = mean(x), a = b + 1), "Column `a` can't be modified because it's a grouping variable" ) }) test_that("summarise gives proper errors (#153)", { df <- tibble( x = 1, y = c(1, 2, 2), z = runif(3) ) expect_error( summarise(df, identity(NULL)), "Column `identity(NULL)` is of unsupported type NULL", fixed = TRUE ) expect_error( summarise(df, log(z)), "Column `log(z)` must be length 1 (a summary value), not 3", fixed = TRUE ) expect_error( summarise(df, y[1:2]), "Column `y[1:2]` must be length 1 (a summary value), not 2", fixed = TRUE ) expect_error( summarise(df, env(a = 1)), "Column `env(a = 1)` is of unsupported type environment", fixed = TRUE ) gdf <- group_by(df, x, y) expect_error( summarise(gdf, identity(NULL)), "Column `identity(NULL)` is of unsupported type NULL", fixed = TRUE ) expect_error( summarise(gdf, z), "Column `z` must be length 1 (a summary value), not 2", fixed = TRUE ) expect_error( summarise(gdf, log(z)), "Column `log(z)` must be length 1 (a summary value), not 2", fixed = TRUE ) expect_error( summarise(gdf, y[1:2]), "Column `y[1:2]` must be length 1 (a summary value), not 2", fixed = TRUE ) expect_error( summarise(gdf, env(a = 1)), "Column `env(a = 1)` is of unsupported type environment", fixed = TRUE ) }) test_that("summarise handles constants (#153)", { df <- data.frame(a = 1:4) today <- Sys.Date() now <- Sys.time() res <- summarise( tbl_df(df), int = 1L, num = 1, str = "foo", bool = TRUE, date = today, time = now ) expect_equal(res$int, 1L) expect_equal(res$num, 1.0) expect_equal(res$str, "foo") expect_equal(res$bool, TRUE) expect_equal(res$date, today) expect_equal(res$time, now) res <- summarise( group_by(df, a), int = 1L, num = 1, str = "foo", bool = TRUE, date = today, time = now ) expect_equal(res$int, rep(1L, 4)) expect_equal(res$num, rep(1.0, 4)) expect_equal(res$str, rep("foo", 4)) expect_equal(res$bool, rep(TRUE, 4)) expect_equal(res$date, rep(today, 4)) expect_equal(res$time, rep(now, 4)) }) test_that("summarise handles passing ...", { df <- data.frame(x = 1:4) f <- function(...) { x1 <- 1 f1 <- function(x) x summarise(df, ..., x1 = f1(x1)) } g <- function(...) { x2 <- 2 f(x2 = x2, ...) } h <- function(before = "before", ..., after = "after") { g(before = before, ..., after = after) } res <- h(x3 = 3) expect_equal(res$x1, 1) expect_equal(res$x2, 2) expect_equal(res$before, "before") expect_equal(res$after, "after") df <- tbl_df(df) res <- h(x3 = 3) expect_equal(res$x1, 1) expect_equal(res$x2, 2) expect_equal(res$before, "before") expect_equal(res$after, "after") df <- group_by(df, x) res <- h(x3 = 3) expect_equal(res$x1, rep(1, 4)) expect_equal(res$x2, rep(2, 4)) expect_equal(res$before, rep("before", 4)) expect_equal(res$after, rep("after", 4)) }) test_that("summarise propagate attributes (#194)", { df <- data.frame( b = rep(1:2, 2), f = Sys.Date() + 1:4, g = Sys.time() + 1:4, stringsAsFactors = FALSE ) %>% group_by(b) min_ <- min res <- summarise(df, min_f = min(f), max_f = max(f), min_g = min(g), max_g = max(g), min__f = min_(f), min__g = min_(g) ) expect_equal(class(res$min_f), "Date") expect_equal(class(res$max_f), "Date") expect_equal(class(res$min__f), "Date") expect_equal(class(res$min_g), c("POSIXct", "POSIXt")) expect_equal(class(res$max_g), c("POSIXct", "POSIXt")) expect_equal(class(res$min__g), c("POSIXct", "POSIXt")) }) test_that("summarise strips names, but only if grouped (#2231, #2675)", { data <- tibble(a = 1:3) %>% summarise(b = setNames(nm = a[[1]])) expect_equal(names(data$b), "1") data <- tibble(a = 1:3) %>% rowwise() %>% summarise(b = setNames(nm = a)) expect_null(names(data$b)) data <- tibble(a = c(1, 1, 2)) %>% group_by(a) %>% summarise(b = setNames(nm = a[[1]])) expect_null(names(data$b)) }) test_that("summarise fails on missing variables", { # error messages from rlang expect_error(summarise(mtcars, a = mean(notthear))) }) test_that("summarise fails on missing variables when grouping (#2223)", { # error messages from rlang expect_error(summarise(group_by(mtcars, cyl), a = mean(notthear))) }) test_that("n() does not accept arguments", { expect_error( summarise(group_by(mtcars, cyl), n(hp)) ) }) test_that("hybrid nests correctly", { res <- group_by(mtcars, cyl) %>% summarise(a = if (n() > 10) 1 else 2) expect_equal(res$a, c(1, 2, 1)) res <- mtcars %>% summarise(a = if (n() > 10) 1 else 2) expect_equal(res$a, 1) }) test_that("hybrid min and max propagate attributes (#246)", { x <- data.frame( id = c(rep("a", 2), rep("b", 2)), date = as.POSIXct(c("2014-01-13", "2014-01-14", "2014-01-15", "2014-01-16"), tz = "GMT") ) y <- x %>% group_by(id) %>% summarise(max_date = max(date), min_date = min(date)) expect_true("tzone" %in% names(attributes(y$min_date))) expect_true("tzone" %in% names(attributes(y$max_date))) }) test_that("summarise can use newly created variable more than once", { df <- data.frame(id = c(1, 1, 2, 2, 3, 3), a = 1:6) %>% group_by(id) for (i in 1:10) { res <- summarise( df, biggest = max(a), smallest = min(a), diff1 = biggest - smallest, diff2 = smallest - biggest ) expect_equal(res$diff1, -res$diff2) } }) test_that("summarise creates an empty data frame with one row when no parameters are used", { res <- summarise(mtcars) expect_equal(nrow(res), 1L) }) test_that("summarise works with zero-row data frames", { res <- summarise(mtcars[0, ], n = n(), sum = sum(cyl), mean = mean(mpg), var = var(drat)) expect_equal(res, data.frame(n = 0L, sum = 0, mean = NaN, var = NA_real_)) }) test_that("summarise works with zero-column data frames (#3071)", { res <- summarise(mtcars[0], n = n()) expect_equal(res, data.frame(n = nrow(mtcars))) }) test_that("integer overflow (#304)", { groups <- rep(c("A", "B"), each = 3) values <- rep(1e9, 6) dat <- data.frame(groups, X1 = as.integer(values), X2 = values) # now group and summarise expect_warning( res <- group_by(dat, groups) %>% summarise(sum_integer = sum(X1), sum_numeric = sum(X2)), "integer overflow" ) expect_true(all(is.na(res$sum_integer))) expect_equal(res$sum_numeric, rep(3e9, 2L)) }) test_that("summarise checks outputs (#300)", { expect_error( summarise(mtcars, mpg, cyl), "Column `mpg` must be length 1 (a summary value), not 32", fixed = TRUE ) expect_error( summarise(mtcars, mpg + cyl), "Column `mpg + cyl` must be length 1 (a summary value), not 32", fixed = TRUE ) }) test_that("comment attribute is allowed (#346)", { test <- data.frame(A = c(1, 1, 0, 0), B = c(2, 2, 3, 3)) comment(test$B) <- "2nd Var" res <- group_by(test, A) expect_equal(comment(res$B), "2nd Var") }) test_that("AsIs class is allowed (#453)", { test <- data.frame(A = c(1, 1, 0, 0), B = I(c(2, 2, 3, 3))) res <- group_by(test, B) expect_equal(res$B, test$B) }) test_that("names attribute is not retained (#357)", { df <- data.frame(x = c(1:3), y = letters[1:3]) df <- group_by(df, y) m <- df %>% summarise( a = length(x), b = quantile(x, 0.5) ) expect_equal(m$b, c(1, 2, 3)) expect_null(names(m$b)) }) test_that("na.rm is supported (#168)", { df <- data.frame( x = c(1:5, NA, 7:10), y = rep(1:2, each = 5), z = c(rnorm(5), NA, rnorm(4)) ) res <- df %>% group_by(y) %>% summarise( mean_x = mean(x, na.rm = FALSE), mean_z = mean(z, na.rm = FALSE), min_x = min(x, na.rm = FALSE), min_z = min(z, na.rm = FALSE) ) expect_equal(res$mean_x[1], 3) expect_true(is.na(res$mean_x[2])) expect_equal(res$mean_z[1], mean(df$z[1:5])) expect_true(is.na(res$mean_z[2])) expect_equal(res$min_x[1], 1) expect_true(is.na(res$min_x[2])) expect_equal(res$min_z[1], min(df$z[1:5])) expect_true(is.na(res$min_z[2])) res <- df %>% group_by(y) %>% summarise( mean_x = mean(x, na.rm = TRUE), mean_z = mean(z, na.rm = TRUE), min_x = min(x, na.rm = TRUE), min_z = min(z, na.rm = TRUE) ) expect_equal(res$mean_x[1], 3) expect_equal(res$mean_x[2], 8.5) expect_equal(res$mean_z[1], mean(df$z[1:5])) expect_equal(res$mean_z[2], mean(df$z[7:10])) expect_equal(res$min_x[1], 1) expect_equal(res$min_x[2], 7) expect_equal(res$min_z[1], min(df$z[1:5])) expect_equal(res$min_z[2], min(df$z[7:10])) }) test_that("summarise hybrid functions can use summarized variables", { df <- data.frame(x = c(1:5, NA, 7:10), y = rep(1:2, each = 5)) %>% group_by(y) res <- summarise( df, x = mean(x), min = min(x), max = max(x), mean = mean(x), var = var(x) ) expect_identical(res$x, res$min) expect_identical(res$x, res$max) expect_identical(res$x, res$mean) expect_identical(res$var, rep(NA_real_, 2)) }) test_that("LazySubset is not confused about input data size (#452)", { res <- data.frame(a = c(10, 100)) %>% summarise(b = sum(a), c = sum(a) * 2) expect_equal(res$b, 110) expect_equal(res$c, 220) }) test_that("nth, first, last promote dates and times (#509)", { data <- tibble( ID = rep(letters[1:4], each = 5), date = Sys.Date() + 1:20, time = Sys.time() + 1:20, number = rnorm(20) ) res <- data %>% group_by(ID) %>% summarise( date2 = nth(date, 2), time2 = nth(time, 2), first_date = first(date), last_date = last(date), first_time = first(time), last_time = last(time) ) expect_is(res$date2, "Date") expect_is(res$first_date, "Date") expect_is(res$last_date, "Date") expect_is(res$time2, "POSIXct") expect_is(res$first_time, "POSIXct") expect_is(res$last_time, "POSIXct") # error messages from rlang expect_error(data %>% group_by(ID) %>% summarise(time2 = nth(times, 2))) }) test_that("nth, first, last preserves factor data (#509)", { dat <- tibble(a = rep(seq(1, 20, 2), 3), b = as.ordered(a)) dat1 <- dat %>% group_by(a) %>% summarise( der = nth(b, 2), first = first(b), last = last(b) ) expect_is(dat1$der, "ordered") expect_is(dat1$first, "ordered") expect_is(dat1$last, "ordered") expect_equal(levels(dat1$der), levels(dat$b)) }) test_that("nth handle negative value (#1584) ", { df <- data.frame( a = 1:10, b = 10:1, g = rep(c(1, 2), c(4, 6)) ) %>% group_by(g) res <- summarise( df, x1 = nth(a, -1L), x2 = nth(a, -1L, order_by = b), x3 = nth(a, -5L), x4 = nth(a, -5L, order_by = b), x5 = nth(a, -5L, default = 99), x6 = nth(a, -5L, order_by = b, default = 99) ) expect_equal(res$x1, c(4, 10)) expect_equal(res$x2, c(1, 5)) expect_true(is.na(res$x3[1])) expect_equal(res$x3[2], 6) expect_true(is.na(res$x4[1])) expect_equal(res$x4[2], 9) expect_equal(res$x5, c(99, 6)) expect_equal(res$x6, c(99, 9)) }) test_that("LazyGroupSubsets is robust about columns not from the data (#600)", { foo <- tibble(x = 1:10, y = 1:10) # error messages from rlang expect_error(foo %>% group_by(x) %>% summarise(first_y = first(z))) }) test_that("can summarise first(x[-1]) (#1980)", { expect_equal( tibble(x = 1:3) %>% summarise(f = first(x[-1])), tibble(f = 2L) ) }) test_that("hybrid eval handles $ and @ (#645)", { tmp <- expand.grid(a = 1:3, b = 0:1, i = 1:10) g <- tmp %>% group_by(a) f <- function(a, b) { list(x = 1:10) } res <- g %>% summarise( r = sum(b), n = length(b), p = f(r, n)$x[1] ) expect_equal(names(res), c("a", "r", "n", "p")) res <- tmp %>% summarise( r = sum(b), n = length(b), p = f(r, n)$x[1] ) expect_equal(names(res), c("r", "n", "p")) }) test_that("argument order_by in last is flexible enough to handle more than just a symbol (#626)", { res1 <- group_by(mtcars, cyl) %>% summarise( big = last(mpg[drat > 3], order_by = wt[drat > 3]), small = first(mpg[drat > 3], order_by = wt[drat > 3]), second = nth(mpg[drat > 3], 2, order_by = wt[drat > 3]) ) # turning off lazy eval last. <- last first. <- first nth. <- nth res2 <- group_by(mtcars, cyl) %>% summarise( big = last.(mpg[drat > 3], order_by = wt[drat > 3]), small = first.(mpg[drat > 3], order_by = wt[drat > 3]), second = nth.(mpg[drat > 3], 2, order_by = wt[drat > 3]) ) expect_equal(res1, res2) }) test_that("min(., na.rm=TRUE) correctly handles Dates that are coded as REALSXP (#755)", { dates <- as.Date(c("2014-01-01", "2013-01-01")) dd <- data.frame(Dates = dates) res <- summarise(dd, Dates = min(Dates, na.rm = TRUE)) expect_is(res$Dates, "Date") expect_equal(res$Dates, as.Date("2013-01-01")) }) test_that("nth handles expressions for n argument (#734)", { df <- data.frame(x = c(1:4, 7:9, 13:19), y = sample(100:999, 14)) idx <- which(df$x == 16) res <- df %>% summarize(abc = nth(y, n = which(x == 16))) expect_equal(res$abc, df$y[idx]) }) test_that("summarise is not polluted by logical NA (#599)", { dat <- data.frame(grp = rep(1:4, each = 2), val = c(NA, 2, 3:8)) Mean <- function(x, thresh = 2) { res <- mean(x, na.rm = TRUE) if (res > thresh) res else NA } res <- dat %>% group_by(grp) %>% summarise(val = Mean(val, thresh = 2)) expect_is(res$val, "numeric") expect_true(is.na(res$val[1])) }) test_that("summarise handles list output columns (#832)", { df <- tibble(x = 1:10, g = rep(1:2, each = 5)) res <- df %>% group_by(g) %>% summarise(y = list(x)) expect_equal(res$y[[1]], 1:5) expect_equal(res$y[[2]], 6:10) res <- df %>% group_by(g) %>% summarise(y = list(x + 1)) expect_equal(res$y[[1]], 1:5 + 1) expect_equal(res$y[[2]], 6:10 + 1) df <- tibble(x = 1:10, g = rep(1:2, each = 5)) res <- df %>% summarise(y = list(x)) expect_equal(res$y[[1]], 1:10) res <- df %>% summarise(y = list(x + 1)) expect_equal(res$y[[1]], 1:10 + 1) }) test_that("summarise works with empty data frame (#1142)", { df <- data.frame() res <- df %>% summarise() expect_equal(nrow(res), 1L) expect_equal(length(res), 0L) }) test_that("n_distint uses na.rm argument", { df <- data.frame(x = c(1:3, NA), g = rep(1:2, 2)) res <- summarise(df, n = n_distinct(x, na.rm = TRUE)) expect_equal(res$n, 3L) res <- group_by(df, g) %>% summarise(n = n_distinct(x, na.rm = TRUE)) expect_equal(res$n, c(2L, 1L)) }) test_that("n_distinct front end supports na.rm argument (#1052)", { x <- c(1:3, NA) expect_equal(n_distinct(x, na.rm = TRUE), 3L) }) test_that("n_distinct without arguments stops (#1957)", { expect_error( n_distinct(), "Need at least one column for `n_distinct()`", fixed = TRUE ) }) test_that("hybrid evaluation does not take place for objects with a class (#1237)", { mean.foo <- function(x) 42 df <- tibble(x = structure(1:10, class = "foo")) expect_equal(summarise(df, m = mean(x))$m[1], 42) env <- environment() Foo <- suppressWarnings(setClass("Foo", contains = "numeric", where = env)) suppressMessages(setMethod("mean", "Foo", function(x, ...) 42, where = env)) on.exit(removeClass("Foo", where = env)) df <- data.frame(x = Foo(c(1, 2, 3))) expect_equal(summarise(df, m = mean(x))$m[1], 42) }) test_that("summarise handles promotion of results (#893)", { df <- structure( list( price = c( 580L, 650L, 630L, 706L, 1080L, 3082L, 3328L, 4229L, 1895L, 3546L, 752L, 13003L, 814L, 6115L, 645L, 3749L, 2926L, 765L, 1140L, 1158L ), cut = structure(c( 2L, 4L, 4L, 2L, 3L, 2L, 2L, 3L, 4L, 1L, 1L, 3L, 2L, 4L, 3L, 3L, 1L, 2L, 2L, 2L ), .Label = c("Good", "Ideal", "Premium", "Very Good"), class = "factor" ) ), row.names = c(NA, -20L), .Names = c("price", "cut"), class = "data.frame" ) res <- df %>% group_by(cut) %>% select(price) %>% summarise(price = median(price)) expect_is(res$price, "numeric") }) test_that("summarise correctly handles logical (#1291)", { test <- expand.grid(id = 1:2, type = letters[1:2], sample = 1:2) %>% mutate(var = c(1, 0, 1, 1, 0, 0, 0, 1)) %>% mutate(var_l = as.logical(var)) %>% mutate(var_ch = as.character(var_l)) %>% arrange(id, type, sample) %>% group_by(id, type) test_sum <- test %>% ungroup() %>% group_by(id, type) %>% summarise( anyvar = any(var == 1), anyvar_l = any(var_l), anyvar_ch = any(var_ch == "TRUE") ) expect_equal(test_sum$anyvar, c(TRUE, TRUE, FALSE, TRUE)) }) test_that("summarise correctly handles NA groups (#1261)", { tmp <- tibble( a = c(1, 1, 1, 2, 2), b1 = NA_integer_, b2 = NA_character_ ) res <- tmp %>% group_by(a, b1) %>% summarise(n()) expect_equal(nrow(res), 2L) res <- tmp %>% group_by(a, b2) %>% summarise(n()) expect_equal(nrow(res), 2L) }) test_that("n_distinct handles multiple columns (#1084)", { df <- data.frame( x = rep(1:4, each = 2), y = rep(1:2, each = 4), g = rep(1:2, 4) ) res <- summarise(df, n = n_distinct(x, y)) expect_equal(res$n, 4L) res <- group_by(df, g) %>% summarise(n = n_distinct(x, y)) expect_equal(res$n, c(4L, 4L)) df$x[3] <- df$y[7] <- NA res <- summarise(df, n = n_distinct(x, y)) expect_equal(res$n, 6L) res <- summarise(df, n = n_distinct(x, y, na.rm = TRUE)) expect_equal(res$n, 4L) res <- group_by(df, g) %>% summarise(n = n_distinct(x, y)) expect_equal(res$n, c(4L, 4L)) res <- group_by(df, g) %>% summarise(n = n_distinct(x, y, na.rm = TRUE)) expect_equal(res$n, c(2L, 4L)) }) test_that("hybrid max works when not used on columns (#1369)", { df <- tibble(x = 1:1000) y <- 1:10 expect_equal(summarise(df, z = max(y))$z, 10) expect_equal(summarise(df, z = max(10))$z, 10) }) test_that("min and max handle empty sets in summarise (#1481, #3997)", { df <- tibble(A = numeric()) res <- df %>% summarise(Min = min(A, na.rm = TRUE), Max = max(A, na.rm = TRUE)) expect_equal(res$Min, Inf) expect_equal(res$Max, -Inf) }) test_that("lead and lag behave correctly in summarise (#1434)", { res <- mtcars %>% summarise( n = n(), leadn = lead(n), lagn = lag(n), leadn10 = lead(n, default = 10), lagn10 = lag(n, default = 10) ) expect_true(all(is.na(res$lagn))) expect_true(all(is.na(res$leadn))) expect_true(all(res$lagn10 == 10)) expect_true(all(res$leadn10 == 10)) res <- mtcars %>% group_by(cyl) %>% summarise( n = n(), leadn = lead(n), lagn = lag(n), leadn10 = lead(n, default = 10), lagn10 = lag(n, default = 10) ) expect_true(all(is.na(res$lagn))) expect_true(all(is.na(res$leadn))) expect_true(all(res$lagn10 == 10)) expect_true(all(res$leadn10 == 10)) res <- mtcars %>% rowwise() %>% summarise( n = n(), leadn = lead(n), lagn = lag(n), leadn10 = lead(n, default = 10), lagn10 = lag(n, default = 10) ) expect_true(all(is.na(res$lagn))) expect_true(all(is.na(res$leadn))) expect_true(all(res$lagn10 == 10)) expect_true(all(res$leadn10 == 10)) }) # .data and .env tests now in test-hybrid-traverse.R test_that("data.frame columns are supported in summarise (#1425)", { df <- data.frame(x1 = rep(1:3, times = 3), x2 = 1:9) df$x3 <- df %>% mutate(x3 = x2) res <- df %>% group_by(x1) %>% summarise(nr = nrow(x3)) expect_true(all(res$nr == 3)) }) test_that("summarise handles min/max of already summarised variable (#1622)", { df <- data.frame( FIRST_DAY = rep(seq(as.POSIXct("2015-12-01", tz = "UTC"), length.out = 2, by = "days"), 2), event = c("a", "a", "b", "b") ) df_summary <- df %>% group_by(event) %>% summarise(FIRST_DAY = min(FIRST_DAY), LAST_DAY = max(FIRST_DAY)) expect_equal(df_summary$FIRST_DAY, df_summary$LAST_DAY) }) test_that("summarise handles double summary (#3233)", { df <- data.frame(a = 1:3) df_summary <- df %>% summarise(b = sum(a), c = sum(b)) expect_equal(df_summary, data.frame(b = 6, c = 6)) df_summary <- df %>% summarise(b = mean(a), c = mean(b)) expect_equal(df_summary, data.frame(b = 2, c = 2)) df_summary <- df %>% summarise(b = var(a), c = var(b)) expect_equal(df_summary, data.frame(b = 1, c = NA_real_)) df_summary <- df %>% summarise(b = sd(a), c = sd(b)) expect_equal(df_summary, data.frame(b = 1, c = NA_real_)) }) test_that("group_by keeps classes (#1631)", { df <- data.frame(a = 1, b = as.Date(NA)) %>% group_by(a) %>% summarize(c = min(b)) expect_equal(class(df$c), "Date") df <- data.frame(a = 1, b = as.POSIXct(NA)) %>% group_by(a) %>% summarize(c = min(b)) expect_equal(class(df$c), c("POSIXct", "POSIXt")) }) test_that("hybrid n_distinct falls back to R evaluation when needed (#1657)", { dat3 <- data.frame(id = c(2, 6, 7, 10, 10)) res <- dat3 %>% summarise(n_unique = n_distinct(id[id > 6])) expect_equal(res$n_unique, 2) }) test_that("summarise() correctly coerces factors with different levels (#1678)", { res <- tibble(x = 1:3) %>% group_by(x) %>% summarise( y = if (x == 1) "a" else "b", z = factor(y) ) expect_is(res$z, "factor") expect_equal(levels(res$z), c("a", "b")) expect_equal(as.character(res$z), c("a", "b", "b")) }) test_that("summarise handles raw columns (#1803)", { df <- tibble(a = 1:3, b = as.raw(1:3)) expect_equal(summarise(df, c = sum(a)), tibble(c = 6L)) expect_identical(summarise(df, c = b[[1]]), tibble(c = as.raw(1))) }) test_that("dim attribute is stripped from grouped summarise (#1918)", { df <- data.frame(a = 1:3, b = 1:3) df_regular <- summarise(df, b = scale(b)[1, 1]) df_grouped <- summarise(group_by(df, a), b = scale(b)) df_rowwise <- summarise(rowwise(df), b = scale(b)) expect_null(dim(df$b)) expect_null(dim(df_grouped$b)) expect_null(dim(df_rowwise$b)) }) test_that("typing and NAs for grouped summarise (#1839)", { expect_identical( tibble(id = 1L, a = NA_character_) %>% group_by(id) %>% summarise(a = a[[1]]) %>% .$a, NA_character_ ) expect_identical( tibble(id = 1:2, a = c(NA, "a")) %>% group_by(id) %>% summarise(a = a[[1]]) %>% .$a, c(NA, "a") ) # Properly upgrade NA (logical) to character expect_identical( tibble(id = 1:2, a = 1:2) %>% group_by(id) %>% summarise(a = ifelse(all(a < 2), NA, "yes")) %>% .$a, c(NA, "yes") ) expect_error( tibble(id = 1:2, a = list(1, "2")) %>% group_by(id) %>% summarise(a = a[[1]]) %>% .$a, "Column `a` can't promote group 1 to numeric", fixed = TRUE ) expect_identical( tibble(id = 1:2, a = list(1, "2")) %>% group_by(id) %>% summarise(a = a[1]) %>% .$a, list(1, "2") ) }) test_that("typing and NAs for rowwise summarise (#1839)", { expect_identical( tibble(id = 1L, a = NA_character_) %>% rowwise() %>% summarise(a = a[[1]]) %>% .$a, NA_character_ ) expect_identical( tibble(id = 1:2, a = c(NA, "a")) %>% rowwise() %>% summarise(a = a[[1]]) %>% .$a, c(NA, "a") ) # Properly promote NA (logical) to character expect_identical( tibble(id = 1:2, a = 1:2) %>% group_by(id) %>% summarise(a = ifelse(all(a < 2), NA, "yes")) %>% .$a, c(NA, "yes") ) expect_error( tibble(id = 1:2, a = list(1, "2")) %>% rowwise() %>% summarise(a = a[[1]]) %>% .$a, "Column `a` can't promote group 1 to numeric", fixed = TRUE ) expect_error( tibble(id = 1:2, a = list(1, "2")) %>% rowwise() %>% summarise(a = a[1]) %>% .$a, "Column `a` can't promote group 1 to numeric", fixed = TRUE ) }) test_that("calculating an ordered factor preserves order (#2200)", { test_df <- tibble( id = c("a", "b"), val = 1:2 ) ret <- group_by(test_df, id) %>% summarize(level = ordered(val)) expect_s3_class(ret$level, "ordered") expect_equal(levels(ret$level), c("1", "2")) }) test_that("min, max preserves ordered factor data (#2200)", { test_df <- tibble( id = rep(c("a", "b"), 2), ord = ordered(c("A", "B", "B", "A"), levels = c("A", "B")) ) ret <- group_by(test_df, id) %>% summarize( min_ord = min(ord), max_ord = max(ord) ) expect_s3_class(ret$min_ord, "ordered") expect_s3_class(ret$max_ord, "ordered") expect_equal(levels(ret$min_ord), levels(test_df$ord)) expect_equal(levels(ret$max_ord), levels(test_df$ord)) }) test_that("ungrouped summarise() uses summary variables correctly (#2404)", { df <- tibble(value = seq(1:10)) out <- df %>% summarise(value = mean(value), sd = sd(value)) expect_equal(out$value, 5.5) expect_equal(out$sd, NA_real_) }) test_that("proper handling of names in summarised list columns (#2231)", { d <- tibble(x = rep(1:3, 1:3), y = 1:6, names = letters[1:6]) res <- d %>% group_by(x) %>% summarise(y = list(setNames(y, names))) expect_equal(names(res$y[[1]]), letters[[1]]) expect_equal(names(res$y[[2]]), letters[2:3]) expect_equal(names(res$y[[3]]), letters[4:6]) }) test_that("proper handling of NA factors (#2588)", { df <- tibble( x = c(1, 1, 2, 2, 3, 3), y = factor(c(NA, NA, NA, "2", "3", "3")) ) ret <- df %>% group_by(x) %>% summarise(y = y[1]) expect_identical(as.character(ret$y), c(NA, NA, "3")) }) test_that("can refer to previously summarised symbols", { expect_identical(summarise(group_by(mtcars, cyl), x = 1, z = x)[2:3], tibble(x = c(1, 1, 1), z = x)) expect_identical(summarise(group_by(mtcars, cyl), x = n(), z = x)[2:3], tibble(x = c(11L, 7L, 14L), z = x)) }) test_that("can refer to symbols if group size is one overall", { df <- tibble(x = LETTERS[3:1], y = 1:3) expect_identical( df %>% group_by(x) %>% summarise(z = y), tibble(x = LETTERS[1:3], z = 3:1) ) }) test_that("summarise() supports unquoted values", { df <- tibble(g = c(1, 1, 2, 2, 2), x = 1:5) expect_identical(summarise(df, out = !!1), tibble(out = 1)) expect_identical(summarise(df, out = !!quote(identity(1))), tibble(out = 1)) expect_error(summarise(df, out = !!(1:2)), "must be length 1 (the number of groups)", fixed = TRUE) expect_error(summarise(df, out = !!env(a = 1)), "unsupported type") gdf <- group_by(df, g) expect_identical(summarise(gdf, out = !!1), summarise(gdf, out = 1)) expect_identical(summarise(gdf, out = !!(1:2)), tibble(g = c(1, 2), out = 1:2)) expect_identical(summarise(gdf, out = !!quote(identity(1))), summarise(gdf, out = 1)) expect_error(summarise(gdf, out = !!(1:5)), "must be length 2 (the number of groups)", fixed = TRUE) expect_error(summarise(gdf, out = !!env(a = 1)), "unsupported type") }) test_that("first() and last() can be called without dplyr loaded (#3498)", { skip_if_not_installed("callr") df <- callr::r(function() { dplyr::summarise(tibble::tibble(a = 1:3), x = dplyr::first(.data$a), y = dplyr::last(.data$a), z = dplyr::first(c(.data$a)) ) }) expect_equal(df$x, 1L) expect_equal(df$y, 3L) expect_equal(df$z, 1L) }) test_that("hybrid sum handles NA correctly (#3528)",{ d <- tibble(x = c(1L,2L,NA) ) expect_equal( summarise(d, x = sum(x, na.rm = TRUE)), tibble(x = 3L)) expect_equal( summarise(d, x = sum(x, na.rm = FALSE)), tibble(x = NA_integer_)) expect_equal( summarise(d, x = sum(x)), tibble(x = NA_integer_)) d <- tibble(x = c(TRUE, FALSE, NA) ) expect_equal( summarise(d, x = sum(x, na.rm = TRUE)), tibble(x = 1L)) expect_equal( summarise(d, x = sum(x, na.rm = FALSE)), tibble(x = NA_integer_)) expect_equal( summarise(d, x = sum(x)), tibble(x = NA_integer_)) }) test_that("formulas are evaluated in the right environment (#3019)", { out <- mtcars %>% summarise(fn = list(rlang::as_function(~ list(~foo, environment())))) out <- out$fn[[1]]() expect_identical(environment(out[[1]]), out[[2]]) }) test_that("summarise correctly reconstruct group rows", { d <- tibble(x = 1:4, g1 = rep(1:2, 2), g2 = 1:4) %>% group_by(g1, g2) %>% summarise(x = x+1) expect_equal(group_rows(d), list(1:2, 3:4)) }) test_that("summarise can handle POSIXlt columns (#3854)", { df <- data.frame(g=c(1,1,3)) df$created <- strptime(c("2014/1/1", "2014/1/2", "2014/1/2"), format = "%Y/%m/%d") res <- df %>% group_by(g) %>% summarise(data = list(created)) expect_true(all(sapply(res$data, inherits, "POSIXlt"))) }) test_that("the data mask marks subsets as not mutable", { res <- mtcars %>% group_by(cyl) %>% summarise(ngroup = n(), shared = is_maybe_shared(environment(), sym("ngroup"))) expect_true(all(res$shared)) expect_true(all(maybe_shared_columns(res))) }) test_that("column_subset respects S3 local [. method (#3923)", { testS3Class <- function(x, X){ structure(x, class = "testS3Class", X = X) } `[.testS3Class` <- function(x, i, ...) { testS3Class(unclass(x)[i, ...], X = attr(x, "X")) } df <- tibble(x = rep(1:2, each = 5), y = testS3Class(1:10, X = 100)) res <- df %>% group_by(x) %>% summarise(chunk = list(y)) expect_equal(res$chunk[[1]], df$y[df$x == 1]) expect_equal(res$chunk[[1]], df$y[df$x == 1]) df$y <- testS3Class(matrix(1:20, ncol = 2), X = 200) res <- df %>% group_by(x) %>% summarise(chunk = list(y)) expect_equal(res$chunk[[1]], df$y[df$x == 1, , drop = FALSE]) expect_equal(res$chunk[[1]], df$y[df$x == 1, , drop = FALSE]) }) test_that("tidy eval does not infloop (#4049)", { df <- data.frame(x = 1:5) call <- expr(length(!!quo(x))) expect_identical(summarise(df, x = eval_tidy(call)), data.frame(x = 5L)) }) test_that("hybrid sum(), mean(), min(), max() treats NA and NaN correctly (#4108, #4163)", { res <- data.frame(x = c(1, NaN)) %>% summarise(sum = sum(x), mean = mean(x), max = max(x), min = min(x)) expect_true(is.nan(res$sum)) expect_true(is.nan(res$mean)) expect_true(is.nan(res$max)) expect_true(is.nan(res$min)) res <- data.frame(x = c(1, NaN)) %>% summarise( sum = sum(x, na.rm = TRUE), mean = mean(x, na.rm = TRUE), max = max(x, na.rm = TRUE), min = min(x, na.rm = TRUE) ) expect_equal(res$sum , 1) expect_equal(res$mean, 1) expect_equal(res$max , 1) expect_equal(res$min , 1) }) test_that("hybrid min() and max() coerce to integer if there is no infinity (#4258)", { tbl <- data.frame(a = 1L) %>% summarise_all(list(min = min, max = max)) expect_equal(tbl, data.frame(min = 1L, max = 1L)) expect_is(tbl$min, "integer") expect_is(tbl$max, "integer") tbl <- data.frame(a = 1L, b = factor("a", levels = c("a", "b"))) %>% group_by(b, .drop = FALSE) %>% summarise_all(list(min = min, max = max)) expect_equal(tbl, data.frame( b = factor(c("a", "b"), levels = c("a", "b")), min = c(1, Inf), max = c(1, -Inf) ) ) expect_is(tbl$min, "numeric") expect_is(tbl$max, "numeric") }) test_that("summarise() correctly handle summarised list columns (#4349)", { res <- tibble(grp = "grp") %>% group_by(grp) %>% summarise(z = list(1), y = z) expect_identical(res$z, res$y) expect_equal(res$z, list(1)) }) dplyr/tests/testthat/test-transmute.R0000644000176200001440000000276213614573562017553 0ustar liggesuserscontext("transmute") test_that("non-syntactic grouping variable is preserved (#1138)", { df <- tibble(`a b` = 1L) %>% group_by(`a b`) %>% transmute() expect_named(df, "a b") }) # Empty transmutes ------------------------------------------------- test_that("transmute with no args returns nothing", { empty <- transmute(mtcars) expect_equal(ncol(empty), 0) expect_equal(nrow(empty), 32) }) # transmute variables ----------------------------------------------- test_that("transmute succeeds in presence of raw columns (#1803)", { df <- tibble(a = 1:3, b = as.raw(1:3)) expect_identical(transmute(df, a), df["a"]) expect_identical(transmute(df, b), df["b"]) }) test_that("arguments to transmute() don't match vars_transmute() arguments", { df <- tibble(a = 1) expect_identical(transmute(df, var = a), tibble(var = 1)) expect_identical(transmute(df, exclude = a), tibble(exclude = 1)) expect_identical(transmute(df, include = a), tibble(include = 1)) }) test_that("arguments to rename() don't match vars_rename() arguments (#2861)", { df <- tibble(a = 1) expect_identical(rename(df, var = a), tibble(var = 1)) expect_identical(rename(group_by(df, a), var = a), group_by(tibble(var = 1), var)) expect_identical(rename(df, strict = a), tibble(strict = 1)) expect_identical(rename(group_by(df, a), strict = a), group_by(tibble(strict = 1), strict)) }) test_that("can transmute() with .data pronoun (#2715)", { expect_identical(transmute(mtcars, .data$cyl), transmute(mtcars, cyl)) }) dplyr/tests/testthat/test-case-when.R0000644000176200001440000001025013614573562017372 0ustar liggesuserscontext("case_when") test_that("zero inputs throws an error", { expect_error( case_when(), "No cases provided", fixed = TRUE ) }) test_that("error messages", { expect_error( case_when( paste(50) ), "Case 1 (`paste(50)`) must be a two-sided formula, not a character vector", fixed = TRUE ) expect_error( case_when( 50 ~ 1:3 ), "LHS of case 1 (`50`) must be a logical vector, not a double vector", fixed = TRUE ) }) test_that("cases must yield compatible lengths", { expect_error( case_when( c(TRUE, FALSE) ~ 1, c(FALSE, TRUE, FALSE) ~ 2, c(FALSE, TRUE, FALSE, NA) ~ 3 ), "`c(FALSE, TRUE, FALSE) ~ 2`, `c(FALSE, TRUE, FALSE, NA) ~ 3` must be length 2 or one, not 3, 4", fixed = TRUE ) expect_error( case_when( c(TRUE, FALSE) ~ 1:3, c(FALSE, TRUE) ~ 1:2 ), "`c(TRUE, FALSE) ~ 1:3` must be length 2 or one, not 3", fixed = TRUE ) }) test_that("matches values in order", { x <- 1:3 expect_equal( case_when( x <= 1 ~ 1, x <= 2 ~ 2, x <= 3 ~ 3 ), c(1, 2, 3) ) }) test_that("unmatched gets missing value", { x <- 1:3 expect_equal( case_when( x <= 1 ~ 1, x <= 2 ~ 2 ), c(1, 2, NA) ) }) test_that("missing values can be replaced (#1999)", { x <- c(1:3, NA) expect_equal( case_when( x <= 1 ~ 1, x <= 2 ~ 2, is.na(x) ~ 0 ), c(1, 2, NA, 0) ) }) test_that("NA conditions (#2927)", { expect_equal( case_when( c(TRUE, FALSE, NA) ~ 1:3, TRUE ~ 4L ), c(1L, 4L, 4L) ) }) test_that("atomic conditions (#2909)", { expect_equal( case_when( TRUE ~ 1:3, FALSE ~ 4:6 ), 1:3 ) expect_equal( case_when( NA ~ 1:3, TRUE ~ 4:6 ), 4:6 ) }) test_that("zero-length conditions and values (#3041)", { expect_equal( case_when( TRUE ~ integer(), FALSE ~ integer() ), integer() ) expect_equal( case_when( logical() ~ 1, logical() ~ 2 ), numeric() ) }) test_that("case_when can be used in anonymous functions (#3422)", { res <- tibble(a = 1:3) %>% mutate(b = (function(x) case_when(x < 2 ~ TRUE, TRUE ~ FALSE))(a)) %>% pull() expect_equal(res, c(TRUE, FALSE, FALSE)) }) test_that("case_when() can be used inside mutate()", { out <- mtcars[1:4, ] %>% mutate(out = case_when( cyl == 4 ~ 1, .data[["am"]] == 1 ~ 2, TRUE ~ 0 )) %>% pull() expect_identical(out, c(2, 2, 1, 0)) }) test_that("can pass quosures to case_when()", { fs <- local({ x <- 3:1 quos( x < 2 ~ TRUE, TRUE ~ FALSE ) }) expect_identical(case_when(!!!fs), c(FALSE, FALSE, TRUE)) }) test_that("can pass nested quosures to case_when()", { fs <- local({ foo <- mtcars$cyl[1:4] quos( !!quo(foo) == 4 ~ 1, TRUE ~ 0 ) }) expect_identical(case_when(!!!fs), c(0, 0, 1, 0)) }) test_that("can pass unevaluated formulas to case_when()", { x <- 6:8 fs <- exprs( x == 7L ~ TRUE, TRUE ~ FALSE ) expect_identical(case_when(!!!fs), c(FALSE, TRUE, FALSE)) out <- local({ x <- 7:9 case_when(!!!fs) }) expect_identical(out, c(TRUE, FALSE, FALSE)) }) test_that("unevaluated formulas can refer to data mask", { fs <- exprs( cyl == 4 ~ 1, am == 1 ~ 2, TRUE ~ 0 ) out <- mtcars[1:4, ] %>% mutate(out = case_when(!!!fs)) %>% pull() expect_identical(out, c(2, 2, 1, 0)) }) test_that("unevaluated formulas can contain quosures", { quo <- local({ n <- 4 quo(n) }) fs <- exprs( cyl == !!quo ~ 1, am == 1 ~ 2, TRUE ~ 0 ) out <- mtcars[1:4, ] %>% mutate(out = case_when(!!!fs)) %>% pull() expect_identical(out, c(2, 2, 1, 0)) }) test_that("NULL inputs are compacted", { x <- 1:3 bool <- FALSE out <- case_when( x == 2 ~ TRUE, if (bool) x == 3 ~ NA, TRUE ~ FALSE ) expect_identical(out, c(FALSE, TRUE, FALSE)) bool <- TRUE out <- case_when( x == 2 ~ TRUE, if (bool) x == 3 ~ NA, TRUE ~ FALSE ) expect_identical(out, c(FALSE, TRUE, NA)) }) dplyr/tests/testthat/test-if-else.R0000644000176200001440000000561013614573562017050 0ustar liggesuserscontext("if_else") test_that("first argument must be logical", { expect_error( if_else(1:10, 1, 2), "`condition` must be a logical vector, not an integer vector", fixed = TRUE ) }) test_that("true and false must be same length as condition (or length 1)", { expect_error( if_else(1:3 < 2, 1:2, 1:3), "`true` must be length 3 (length of `condition`) or one, not 2", fixed = TRUE ) expect_error( if_else(1:3 < 2, 1:3, 1:2), "`false` must be length 3 (length of `condition`) or one, not 2", fixed = TRUE ) }) test_that("true and false must be same type and same class", { expect_error( if_else(1:3 < 2, 1, 1L), "`false` must be a double vector, not an integer vector", fixed = TRUE ) x <- factor("x") y <- ordered("x") expect_error( if_else(1:3 < 2, x, y), "`false` must have class `factor`, not class `ordered/factor`", fixed = TRUE ) }) test_that("scalar true and false are vectorised", { x <- c(TRUE, TRUE, FALSE, FALSE) expect_equal(if_else(x, 1, 2), c(1, 1, 2, 2)) }) test_that("vector true and false are ok", { x <- c(-1, 0, 1) expect_equal(if_else(x < 0, x, 0), c(-1, 0, 0)) expect_equal(if_else(x > 0, x, 0), c(0, 0, 1)) }) test_that("missing values are missing", { expect_equal(if_else(c(TRUE, NA, FALSE), -1, 1), c(-1, NA, 1)) }) test_that("works with lists", { x <- list(1, 2, 3) expect_equal( if_else(c(TRUE, TRUE, FALSE), x, list(NULL)), list(1, 2, NULL) ) }) test_that("better factor support (#2197)", { skip("Currently failing") test_that("gives proper error messages for factor class (#2197)", { x <- factor(1:3, labels = letters[1:3]) expect_error( if_else(x == "a", "b", x), "asdf", fixed = TRUE ) expect_error( if_else(x == "a", 1L, x), "asdf", fixed = TRUE ) expect_error( if_else(x == "a", 1., x), "asdf", fixed = TRUE ) expect_error( if_else(x == "a", TRUE, x), "asdf", fixed = TRUE ) expect_error( if_else(x == "a", Sys.Date(), x), "asdf", fixed = TRUE ) expect_error( if_else(x == "a", x, "b"), "asdf", fixed = TRUE ) expect_error( if_else(x == "a", x, 1L), "asdf", fixed = TRUE ) expect_error( if_else(x == "a", x, 1.), "asdf", fixed = TRUE ) expect_error( if_else(x == "a", x, TRUE), "asdf", fixed = TRUE ) expect_error( if_else(x == "a", x, Sys.Date()), "asdf", fixed = TRUE ) }) test_that("works with factors as both `true` and `false` (#2197)", { x <- factor(1:3, labels = letters[1:3]) y <- factor(1:3, labels = letters[c(1, 2, 4)]) expect_equal(if_else(x == "a", x[[2]], x), x[c(2, 2, 3)]) expect_error( if_else(x == "a", x, y), "asdf levels in `false` don't match levels in `true`" ) }) }) dplyr/tests/testthat/helper-dplyr.R0000644000176200001440000000030713614573562017154 0ustar liggesusers # Silence soft-deprecation warnings until next tibble() release tibble <- function(...) { scoped_options(lifecycle_disable_verbose_retirement = TRUE) tibble::tibble(...) } data_frame <- tibble dplyr/tests/testthat/helper-torture.R0000644000176200001440000000005413451046652017517 0ustar liggesuserswith_gctorture2 <- withr::with_(gctorture2) dplyr/tests/testthat/test-hybrid-traverse.R0000644000176200001440000002341313614573562020637 0ustar liggesuserscontext("hybrid-traverse") test_df <- tibble( id = c(1L, 2L, 2L), a = 1:3, b = as.numeric(1:3), c = letters[1:3], d = c(TRUE, FALSE, NA), e = list(list(a = 1, x = 2), list(a = 2, x = 3), list(a = 3, x = 4)) ) test_that("$ is parsed correctly (#1400)", { grouping <- rowwise expect_equal( test_df %>% grouping() %>% mutate(f = e$x) %>% select(-e), test_df %>% mutate(f = as.numeric(2:4)) %>% grouping() %>% select(-e) ) }) test_that("$ is parsed correctly if column by the same name exists (#1400)", { grouping <- rowwise expect_equal( test_df %>% grouping() %>% mutate(f = e$a) %>% select(-e), test_df %>% mutate(f = as.numeric(1:3)) %>% grouping() %>% select(-e) ) }) test_that("[[ works for ungrouped access (#912)", { grouping <- identity expect_equal( test_df %>% grouping() %>% mutate(f = mean(test_df[["a"]])) %>% select(-e), test_df %>% mutate(f = mean(a)) %>% grouping() %>% select(-e) ) }) test_that("[[ works for rowwise access of list columns (#912)", { grouping <- rowwise df <- tibble( x = c("a", "b"), y = list(list(a = 1, b = 2), list(a = 3, b = 4)) ) expect_equal( df %>% rowwise() %>% transmute(z = y[[x]]), tibble(z = c(1, 4)) ) }) test_that("$ works for rle result (#2125)", { grouping <- identity expect_equal( test_df %>% grouping() %>% mutate(f = rle(b)$lengths) %>% select(-e), test_df %>% mutate(f = rep(1L, 3L)) %>% grouping() %>% select(-e) ) }) test_hybrid <- function(grouping) { test_that("case_when() works for LHS (#1719, #2244)", { expect_equal( test_df %>% grouping() %>% mutate(f = case_when(a == 1 ~ 1, a == 2 ~ 2, TRUE ~ 3)) %>% select(-e), test_df %>% mutate(f = b) %>% grouping() %>% select(-e) ) }) test_that("case_when() works for RHS (#1719, #2244)", { expect_equal( test_df %>% grouping() %>% mutate(f = case_when(a == 1 ~ as.numeric(a), a == 2 ~ b, TRUE ~ 3)) %>% select(-e), test_df %>% mutate(f = b) %>% grouping() %>% select(-e) ) }) test_that("assignments work (#1452)", { expect_false(env_has(nms = "xx")) expect_equal( test_df %>% grouping() %>% mutate(f = { xx <- 5 xx }) %>% select(-e), test_df %>% mutate(f = 5) %>% grouping() %>% select(-e) ) expect_false(env_has(nms = "xx")) }) test_that("assignments don't change variable (#315, #1452)", { expect_false(env_has(nms = "a")) expect_equal( test_df %>% grouping() %>% mutate(f = { a <- 5 a }) %>% select(-e), test_df %>% mutate(f = 5) %>% grouping() %>% select(-e) ) expect_false(env_has(nms = "a")) }) test_that("assignments don't carry over (#1452)", { skip("being discussed in #3813") expect_error( test_df %>% grouping() %>% mutate( f = { xx <- 5 xx }, g = xx ), "xx" ) }) test_that("assignments don't leak (#1452)", { expect_false(env_has(nms = "a")) test <- test_df %>% grouping() %>% mutate(f = { xx <- 5 xx }) expect_false(env_has(nms = "a")) }) test_that("[ works (#912)", { grouped_df <- test_df %>% grouping() expect_equal( grouped_df %>% mutate(f = mean(grouped_df["a"][[1]])) %>% select(-e), test_df %>% mutate(f = mean(a)) %>% grouping() %>% select(-e) ) }) test_that("interpolation works (#1012)", { var <- quo(b) expect_equal( test_df %>% grouping() %>% mutate(., f = mean(!!var)) %>% select(-e), test_df %>% grouping() %>% mutate(f = mean(b)) %>% select(-e) ) }) test_that("can compute 1 - ecdf(y)(y) (#2018)", { surv <- function(x) 1 - ecdf(x)(x) expect_equal( test_df %>% grouping() %>% mutate(., f = 1 - ecdf(b)(b)) %>% select(-e), test_df %>% grouping() %>% mutate(., f = surv(b)) %>% select(-e) ) }) test_that("filter understands .data (#1012)", { expect_equal( test_df %>% grouping() %>% filter({ b <- 5 .data$b < 2 }) %>% select(-e), test_df %>% grouping() %>% filter(b < 2) %>% select(-e) ) }) test_that("filter understands .data (#1012)", { expect_equal( test_df %>% grouping() %>% filter(.data[["b"]] < 2) %>% select(-e), test_df %>% grouping() %>% filter(b < 2) %>% select(-e) ) }) test_that("filter understands .data (#1012)", { idx <- 2L expect_equal( test_df %>% grouping() %>% filter(.data[[letters[[idx]]]] < 2) %>% select(-e), test_df %>% grouping() %>% filter(b < 2) %>% select(-e) ) }) test_that("filter understands .env (#1469)", { b <- 2L expect_equal( filter( test_df %>% grouping(), b < .env$b ) %>% select(-e), test_df %>% grouping() %>% filter(b < 2) %>% select(-e) ) }) test_that("filter understands get(..., .env) in a pipe (#1469)", { b <- 2L expect_equal( test_df %>% grouping() %>% filter(b < get("b", envir = .env)) %>% select(-e), test_df %>% grouping() %>% filter(b < 2) %>% select(-e) ) }) test_that("mutate understands .data (#1012)", { expect_equal( test_df %>% grouping() %>% mutate(f = { b <- 5 .data$b }) %>% select(-e), test_df %>% grouping() %>% mutate(f = b) %>% select(-e) ) }) test_that("mutate understands .data (#1012)", { expect_equal( test_df %>% grouping() %>% mutate(f = .data[["b"]]) %>% select(-e), test_df %>% grouping() %>% mutate(f = b) %>% select(-e) ) }) test_that("mutate understands .data (#1012)", { idx <- 2L expect_equal( test_df %>% grouping() %>% mutate(f = .data[[letters[[idx]]]]) %>% select(-e), test_df %>% grouping() %>% mutate(f = b) %>% select(-e) ) }) test_that("mutate understands .env (#1469)", { b <- 2L expect_equal( mutate( test_df %>% grouping(), f = .env$b ) %>% select(-e), test_df %>% grouping() %>% mutate(f = 2L) %>% select(-e) ) }) test_that("mutate understands get(..., .env) in a pipe (#1469)", { b <- 2L expect_equal( test_df %>% grouping() %>% mutate(f = get("b", .env)) %>% select(-e), test_df %>% grouping() %>% mutate(f = 2L) %>% select(-e) ) }) test_that("summarise understands .data (#1012)", { expect_equal( test_df %>% grouping() %>% summarise(f = { b <- 5 sum(.data$b) }), test_df %>% grouping() %>% summarise(f = sum(b)) ) }) test_that("summarise understands .data (#1012)", { expect_equal( test_df %>% grouping() %>% summarise(f = sum(.data[["b"]])), test_df %>% grouping() %>% summarise(f = sum(b)) ) }) test_that("summarise understands .data (#1012)", { idx <- 2L expect_equal( test_df %>% grouping() %>% summarise(f = sum(.data[[letters[[idx]]]])), test_df %>% grouping() %>% summarise(f = sum(b)) ) }) test_that("summarise understands .env (#1469)", { b <- 2L expect_equal( summarise( test_df %>% grouping(), f = .env$b ), test_df %>% grouping() %>% summarise(f = 2L) ) }) test_that("summarise understands get(..., .env) in a pipe (#1469)", { b <- 2L expect_equal( test_df %>% grouping() %>% summarise(f = get("b", .env)), test_df %>% grouping() %>% summarise(f = 2L) ) }) test_that("columns named .data and .env are overridden", { conflict_data <- tibble(id = test_df$id, .data = 1:3, .env = 3:1) expect_equal( conflict_data %>% grouping() %>% summarise(env = list(.env), data = list(.data)) %>% ungroup() %>% summarise( is_env_env = all(vapply(env, is.environment, logical(1))), is_data_env = all(vapply(env, is.environment, logical(1))) ), tibble(is_env_env = TRUE, is_data_env = TRUE) ) }) test_that("contents of columns named .data and .env can be accessed", { conflict_data <- tibble(id = test_df$id, .data = 1:3, .env = 3:1) expect_equal( conflict_data %>% grouping() %>% summarise( env = mean(.data$.env), data = mean(.data$.data) ), conflict_data %>% set_names("id", "data", "env") %>% grouping() %>% summarise_at(vars(env, data), list(mean)) ) scoped_lifecycle_silence() expect_equal( conflict_data %>% grouping() %>% summarise( env = mean(.data$.env), data = mean(.data$.data) ), conflict_data %>% set_names("id", "data", "env") %>% grouping() %>% summarise_at(vars(env, data), funs(mean)) ) }) } test_hybrid(identity) test_hybrid(rowwise) test_hybrid(. %>% group_by(!!quo(id))) dplyr/tests/testthat/test-group-indices.R0000644000176200001440000000462613614573562020302 0ustar liggesuserscontext("Group indices") test_that("group_indices from ungrouped or grouped gives same result", { res1 <- group_indices(mtcars, cyl, vs, am) res2 <- mtcars %>% group_by(cyl, vs, am) %>% group_indices() expect_equal(res1, res2) }) test_that("group_indices handles the case where no variable is given (#867)", { res <- group_indices(mtcars) expect_true(all(res == 1L)) }) test_that("group_indices handles grouped data and no arguments", { res1 <- mtcars %>% group_by(cyl) %>% group_indices() res2 <- mtcars %>% group_indices(cyl) expect_equal(res1, res2) }) test_that("group_indices can be used in mutate (#2160)", { res1 <- mtcars %>% mutate(., group_idx = group_indices(., cyl)) res2 <- mtcars %>% mutate(group_idx = as.integer(factor(cyl))) expect_equal(res1, res2) }) test_that("group indices are updated correctly for joined grouped data frames (#2330)", { d1 <- data.frame(x = 1:2, y = 1:2) %>% group_by(x, y) expect_equal(group_indices(d1), d1$x) d2 <- expand.grid(x = 1:2, y = 1:2) res <- inner_join(d1, d2, by = "x") expect_equal(group_indices(res), res$x) }) test_that("group_indices() works for rowwise data (#3491)", { df <- rowwise(data.frame(x = 1:10)) expect_equal(group_indices(df), 1:10) }) test_that("group_indices() warns when passed extra arguments on grouped or rowwise data", { df <- rowwise(data.frame(x = 1:10)) expect_warning(idx <- group_indices(df, x)) expect_equal(idx, 1:10) expect_warning(idx <- group_indices(group_by(df,x), x)) expect_equal(idx, 1:10) }) test_that("group_indices() can be used inside mutate (#1185)", { df <- tibble(v1 = c(3, 3, 2, 2, 3, 1), v2 = 1:6) %>% group_by(v1) expect_identical( pull(mutate(df, g = group_indices())), group_indices(df) ) df <- tibble(v1 = c(3, 3, 2, 2, 3, 1), v2 = 1:6) expect_identical( pull(mutate(df, g = group_indices())), group_indices(df) ) df <- rowwise(tibble(v1 = c(3, 3, 2, 2, 3, 1), v2 = 1:6)) expect_identical( pull(mutate(df, g = group_indices())), group_indices(df) ) }) test_that("group_indices() recognizes .drop", { d <- tibble(f = factor("b", levels = c("a", "b", "c"))) expect_equal(group_indices(d, f), 1L) expect_equal(group_indices(d, f, .drop = FALSE), 2L) # these two should return the same result (#4208): # d %>% group_indices(...) # d %>% group_by(...) %>% group_indices() d2 <- group_by(d, f) expect_equal(group_indices(d2), 1L) }) dplyr/tests/testthat/helper-groups.R0000644000176200001440000000063113614573562017341 0ustar liggesusersexpect_groups <- function(df, groups, info = NULL) { if (length(groups) == 0L) { expect_null(groups(df), info = info) expect_identical(group_vars(df), character(), info = info) } else { expect_identical(groups(df), lapply(enc2native(groups), as.name), info = info) expect_identical(group_vars(df), groups, info = info) } } expect_no_groups <- function(df) { expect_groups(df, NULL) } dplyr/tests/testthat/test-group_map.R0000644000176200001440000000577513614573562017531 0ustar liggesuserscontext("group_map") test_that("group_map() makes a grouped_df", { res <- group_by(mtcars, cyl) %>% group_map(~ head(.x, 2L)) expect_equal(length(res), 3L) res <- iris %>% group_by(Species) %>% filter(Species == "setosa") %>% group_map(~ tally(.x)) expect_equal(length(res), 1L) res <- iris %>% group_by(Species, .drop = FALSE) %>% filter(Species == "setosa") %>% group_map(~ tally(.x)) expect_equal(length(res), 3L) }) test_that("group_map() can return arbitrary objects", { expect_equal( group_by(mtcars, cyl) %>% group_map(~ 10), rep(list(10), 3) ) }) test_that("group_map() wants functions with at least 2 arguments, or ... (#3996)", { head1 <- function(d) head(d, 1) g <- iris %>% group_by(Species) expect_error(group_map(g, head1), "The function must accept at least two arguments") head1 <- function(d, ...) head(d, 1) expect_equal(length(group_map(g, head1)), 3L) }) test_that("group_map() works on ungrouped data frames (#4067)", { expect_identical( group_map(mtcars, ~ head(.x, 2L)), list(head(mtcars, 2L)) ) }) test_that("group_modify() makes a grouped_df", { res <- group_by(mtcars, cyl) %>% group_modify(~ head(.x, 2L)) expect_equal(nrow(res), 6L) expect_equal(group_rows(res), list(1:2, 3:4, 5:6)) res <- iris %>% group_by(Species) %>% filter(Species == "setosa") %>% group_modify(~ tally(.x)) expect_equal(nrow(res), 1L) expect_equal(group_rows(res), list(1L)) res <- iris %>% group_by(Species, .drop = FALSE) %>% filter(Species == "setosa") %>% group_modify(~ tally(.x)) expect_equal(nrow(res), 3L) expect_equal(group_rows(res), list(1L, 2L, 3L)) }) test_that("group_modify() rejects non data frames", { expect_error( group_by(mtcars, cyl) %>% group_modify(~ 10) ) }) test_that("group_modify() rejects data frames that contain the grouping variable", { expect_error( group_by(mtcars, cyl) %>% group_modify(~ data.frame(cyl = 19)) ) }) test_that("group_modify() wants functions with at least 2 arguments, or ... (#3996)", { head1 <- function(d) head(d, 1) g <- iris %>% group_by(Species) expect_error(group_modify(g, head1), "The function must accept at least two arguments") head1 <- function(d, ...) head(d, 1) expect_equal(nrow(group_modify(g, head1)), 3L) }) test_that("group_modify() works on ungrouped data frames (#4067)", { expect_identical( group_modify(mtcars, ~ head(.x, 2L)), head(mtcars, 2L) ) }) test_that("group_map() uses ptype on empty splits (#4421)", { res <- mtcars %>% group_by(cyl) %>% filter(hp > 1000) %>% group_map(~.x) expect_equivalent(res, list()) ptype <- attr(res, "ptype") expect_equal(names(ptype), setdiff(names(mtcars), "cyl")) expect_equal(nrow(ptype), 0L) expect_is(ptype, "data.frame") }) test_that("group_modify() uses ptype on empty splits (#4421)", { res <- mtcars %>% group_by(cyl) %>% filter(hp > 1000) %>% group_modify(~.x) expect_equal(res, group_by(mtcars[integer(0L), ], cyl)) }) dplyr/tests/testthat/test-colwise-arrange.R0000644000176200001440000000336413451046652020604 0ustar liggesuserscontext("colwise arrange") df <- mtcars[1:3] test_that("scoped arrange is identical to manual arrange", { expect_identical(arrange_all(df), arrange(df, mpg, cyl, disp)) expect_identical(arrange_at(df, vars(mpg)), arrange(df, mpg)) expect_identical(arrange_if(iris, is.factor), arrange(iris, Species)) }) test_that(".funs is applied to variables before sorting", { expect_identical(arrange_all(df, `-`), arrange(df, -mpg, -cyl, -disp)) }) test_that("arrange_at can arrange by grouping variables (#3351, #3332, #3480)", { tbl <- tibble(gr1 = rep(1:2, 4), gr2 = rep(1:2, each = 4), x = 1:8) %>% group_by(gr1) expect_identical( arrange_at(tbl, vars(gr1)), arrange(tbl, gr1) ) expect_identical( arrange_at(tbl, vars(-x)), arrange(tbl, gr1, gr2) ) }) test_that("arrange_all arranges by grouping variable (#3351, #3480)", { tbl <- tibble(gr1 = rep(1:2, 4), gr2 = rep(1:2, each = 4), x = 1:8) %>% group_by(gr1) expect_identical( arrange_all(tbl), arrange(tbl, gr1, gr2, x) ) expect_identical( arrange_all(tbl, desc), arrange(tbl, desc(gr1), desc(gr2), desc(x)) ) }) test_that("arrange_if arranges by grouping variable (#3351, #3480)", { tbl <- tibble(gr1 = rep(1:2, 4), gr2 = rep(1:2, each = 4), x = 1:8) %>% group_by(gr1) expect_identical( arrange_if(tbl, is.integer), arrange(tbl, gr1, gr2, x) ) }) test_that("scoped arrange respect .by_group (#3245)",{ d <- group_by(df, cyl) expect_identical( arrange_all(d, .by_group = TRUE), arrange(d, cyl, mpg, disp) ) expect_identical( arrange_if(d, is.numeric, .by_group = TRUE), arrange(d, cyl, mpg, disp) ) expect_identical( arrange_at(d, vars(mpg, disp), .by_group = TRUE), arrange(d, cyl, mpg, disp) ) }) dplyr/tests/testthat/test-mutate-windowed.R0000644000176200001440000002137713614573562020651 0ustar liggesuserscontext("Mutate - windowed") test_that("desc is correctly handled by window functions", { df <- data.frame( x = 1:10, y = seq(1, 10, by = 1), g = rep(c(1, 2), each = 5), s = c(letters[1:3], LETTERS[1:5], letters[4:5]) ) expect_equal(mutate(df, rank = min_rank(desc(x)))$rank, 10:1) expect_equal(mutate(group_by(df, g), rank = min_rank(desc(x)))$rank, rep(5:1, 2)) expect_equal(mutate(df, rank = row_number(desc(x)))$rank, 10:1) expect_equal(mutate(group_by(df, g), rank = row_number(desc(x)))$rank, rep(5:1, 2)) # Test character vector sorting charvec_sort_test <- function(df) { expect_equal( mutate(df, rank = row_number(desc(s)))$rank, mutate(df, rank = dplyr::row_number(desc(s)))$rank ) expect_equal( mutate(group_by(df, g), rank = row_number(desc(s)))$rank, mutate(group_by(df, g), rank = dplyr::row_number(desc(s)))$rank ) } # Test against both the local, and the C locale for collation charvec_sort_test(df) withr::with_collate("C", charvec_sort_test(df)) }) test_that("row_number gives correct results", { tmp <- data.frame( id = rep(c(1, 2), each = 5), value = c(1, 1, 2, 5, 0, 6, 4, 0, 0, 2), s = c(letters[1:2], LETTERS[1:4], letters[2:5]) ) res <- group_by(tmp, id) %>% mutate(var = row_number(value)) expect_equal(res$var, c(2, 3, 4, 5, 1, 5, 4, 1, 2, 3)) # Test character vector sorting by comparing C and R function outputs # Should be careful of testing against static return values due to locale differences charvec_sort_test <- function(tmp) { res2 <- group_by(tmp, id) %>% mutate(var = row_number(s), var_d = dplyr::row_number(s)) expect_equal(res2$var, res2$var_d) res3 <- data.frame(s = c("[", "]", NA, "a", "Z")) %>% mutate(var = row_number(s), var_d = dplyr::row_number(s)) expect_equal(res3$var, res3$var_d) } # Test against both the local, and the C locale for collation charvec_sort_test(tmp) withr::with_collate("C", charvec_sort_test(tmp)) }) test_that("row_number works with 0 arguments", { g <- group_by(mtcars, cyl) expect_equal(mutate(g, rn = row_number()), mutate(g, rn = 1:n())) }) test_that("cum(sum,min,max) works", { df <- data.frame(x = 1:10, y = seq(1, 10, by = 1), g = rep(c(1, 2), each = 5)) res <- mutate(df, csumx = cumsum(x), csumy = cumsum(y), cminx = cummin(x), cminy = cummin(y), cmaxx = cummax(x), cmaxy = cummax(y) ) expect_equal(res$csumx, cumsum(df$x)) expect_equal(res$csumy, cumsum(df$y)) expect_equal(res$cminx, cummin(df$x)) expect_equal(res$cminy, cummin(df$y)) expect_equal(res$cmaxx, cummax(df$x)) expect_equal(res$cmaxy, cummax(df$y)) res <- mutate(group_by(df, g), csumx = cumsum(x), csumy = cumsum(y), cminx = cummin(x), cminy = cummin(y), cmaxx = cummax(x), cmaxy = cummax(y) ) expect_equal(res$csumx, c(cumsum(df$x[1:5]), cumsum(df$x[6:10]))) expect_equal(res$csumy, c(cumsum(df$y[1:5]), cumsum(df$y[6:10]))) expect_equal(res$cminx, c(cummin(df$x[1:5]), cummin(df$x[6:10]))) expect_equal(res$cminy, c(cummin(df$y[1:5]), cummin(df$y[6:10]))) expect_equal(res$cmaxx, c(cummax(df$x[1:5]), cummax(df$x[6:10]))) expect_equal(res$cmaxy, c(cummax(df$y[1:5]), cummax(df$y[6:10]))) df$x[3] <- NA df$y[4] <- NA res <- mutate(df, csumx = cumsum(x), csumy = cumsum(y), cminx = cummin(x), cminy = cummin(y), cmaxx = cummax(x), cmaxy = cummax(y) ) expect_true(all(is.na(res$csumx[3:10]))) expect_true(all(is.na(res$csumy[4:10]))) expect_true(all(is.na(res$cminx[3:10]))) expect_true(all(is.na(res$cminy[4:10]))) expect_true(all(is.na(res$cmaxx[3:10]))) expect_true(all(is.na(res$cmaxy[4:10]))) }) test_that("lead and lag simple hybrid version gives correct results (#133)", { res <- group_by(mtcars, cyl) %>% mutate(disp_lag_2 = lag(disp, 2), disp_lead_2 = lead(disp, 2)) %>% summarise( lag1 = all(is.na(head(disp_lag_2, 2))), lag2 = all(!is.na(tail(disp_lag_2, -2))), lead1 = all(is.na(tail(disp_lead_2, 2))), lead2 = all(!is.na(head(disp_lead_2, -2))) ) expect_true(all(res$lag1)) expect_true(all(res$lag2)) expect_true(all(res$lead1)) expect_true(all(res$lead2)) }) test_that("min_rank handles columns full of NaN (#726)", { test <- data.frame( Name = c("a", "b", "c", "d", "e"), ID = c(1, 1, 1, 1, 1), expression = c(NaN, NaN, NaN, NaN, NaN) ) data <- group_by(test, ID) %>% mutate(rank = min_rank(expression)) expect_true(all(is.na(data$rank))) }) test_that("ntile works with one argument (#3418)", { df <- data.frame(x=1:42) expect_identical( mutate( df, nt = ntile(n = 9)), mutate( df, nt = ntile(row_number(), n = 9)) ) df <- group_by( data.frame(x=1:42, g = rep(1:7, each=6)), g ) expect_identical( mutate( df, nt = ntile(n = 4)), mutate( df, nt = ntile(row_number(), n = 4)) ) }) test_that("rank functions deal correctly with NA (#774)", { data <- tibble(x = c(1, 2, NA, 1, 0, NA)) res <- data %>% mutate( min_rank = min_rank(x), percent_rank = percent_rank(x), dense_rank = dense_rank(x), cume_dist = cume_dist(x), ntile = ntile(x, 2), row_number = row_number(x) ) expect_true(all(is.na(res$min_rank[c(3, 6)]))) expect_true(all(is.na(res$dense_rank[c(3, 6)]))) expect_true(all(is.na(res$percent_rank[c(3, 6)]))) expect_true(all(is.na(res$cume_dist[c(3, 6)]))) expect_true(all(is.na(res$ntile[c(3, 6)]))) expect_true(all(is.na(res$row_number[c(3, 6)]))) expect_equal(res$percent_rank[ c(1, 2, 4, 5) ], c(1 / 3, 1, 1 / 3, 0)) expect_equal(res$min_rank[ c(1, 2, 4, 5) ], c(2L, 4L, 2L, 1L)) expect_equal(res$dense_rank[ c(1, 2, 4, 5) ], c(2L, 3L, 2L, 1L)) expect_equal(res$cume_dist[ c(1, 2, 4, 5) ], c(.75, 1, .75, .25)) expect_equal(res$ntile[ c(1, 2, 4, 5) ], c(1L, 2L, 2L, 1L)) expect_equal(res$row_number[ c(1, 2, 4, 5) ], c(2L, 4L, 3L, 1L)) data <- tibble( x = rep(c(1, 2, NA, 1, 0, NA), 2), g = rep(c(1, 2), each = 6) ) res <- data %>% group_by(g) %>% mutate( min_rank = min_rank(x), percent_rank = percent_rank(x), dense_rank = dense_rank(x), cume_dist = cume_dist(x), ntile = ntile(x, 2), row_number = row_number(x) ) expect_true(all(is.na(res$min_rank[c(3, 6, 9, 12)]))) expect_true(all(is.na(res$dense_rank[c(3, 6, 9, 12)]))) expect_true(all(is.na(res$percent_rank[c(3, 6, 9, 12)]))) expect_true(all(is.na(res$cume_dist[c(3, 6, 9, 12)]))) expect_true(all(is.na(res$ntile[c(3, 6, 9, 12)]))) expect_true(all(is.na(res$row_number[c(3, 6, 9, 12)]))) expect_equal(res$percent_rank[ c(1, 2, 4, 5, 7, 8, 10, 11) ], rep(c(1 / 3, 1, 1 / 3, 0), 2)) expect_equal(res$min_rank[ c(1, 2, 4, 5, 7, 8, 10, 11) ], rep(c(2L, 4L, 2L, 1L), 2)) expect_equal(res$dense_rank[ c(1, 2, 4, 5, 7, 8, 10, 11) ], rep(c(2L, 3L, 2L, 1L), 2)) expect_equal(res$cume_dist[ c(1, 2, 4, 5, 7, 8, 10, 11) ], rep(c(.75, 1, .75, .25), 2)) expect_equal(res$ntile[ c(1, 2, 4, 5, 7, 8, 10, 11) ], rep(c(1L, 2L, 2L, 1L), 2)) expect_equal(res$row_number[ c(1, 2, 4, 5, 7, 8, 10, 11) ], rep(c(2L, 4L, 3L, 1L), 2)) }) test_that("lag and lead work on factors inside mutate (#955)", { test_factor <- factor(rep(c("A", "B", "C"), each = 3)) exp_lag <- test_factor != lag(test_factor) exp_lead <- test_factor != lead(test_factor) test_df <- tbl_df(data.frame(test = test_factor)) res <- test_df %>% mutate( is_diff_lag = (test != lag(test)), is_diff_lead = (test != lead(test)) ) expect_equal(exp_lag, res$is_diff_lag) expect_equal(exp_lead, res$is_diff_lead) }) test_that("lag handles default argument in mutate (#915)", { blah <- data.frame(x1 = c(5, 10, 20, 27, 35, 58, 5, 6), y = 8:1) blah <- mutate(blah, x2 = x1 - lag(x1, n = 1, default = 0), x3 = x1 - lead(x1, n = 1, default = 0), x4 = lag(x1, n = 1L, order_by = y), x5 = lead(x1, n = 1L, order_by = y) ) expect_equal(blah$x2, blah$x1 - lag(blah$x1, n = 1, default = 0)) expect_equal(blah$x3, blah$x1 - lead(blah$x1, n = 1, default = 0)) expect_equal(blah$x4, lag(blah$x1, n = 1L, order_by = blah$y)) expect_equal(blah$x5, lead(blah$x1, n = 1L, order_by = blah$y)) }) # FIXME: this should only fail if strict checking is on. # test_that("window functions fail if db doesn't support windowing", { # df_sqlite <- temp_load(temp_srcs("sqlite"), df)$sql %>% group_by(g) # ok <- collect(df_sqlite %>% mutate(x > 4)) # expect_equal(nrow(ok), 10) # # expect_error(df_sqlite %>% mutate(x > mean(x)), "does not support") # expect_error(df_sqlite %>% mutate(r = row_number()), "does not support") # }) test_that("dim attribute is stripped from grouped mutate (#1918)", { df <- data.frame(a = 1:3, b = 1:3) df_regular <- mutate(df, b = scale(b)) df_grouped <- mutate(group_by(df, a), b = scale(b)) df_rowwise <- mutate(rowwise(df), b = scale(b)) expect_null(dim(df$b)) expect_null(dim(df_grouped$b)) expect_null(dim(df_rowwise$b)) }) dplyr/tests/testthat.R0000644000176200001440000000006613451046652014541 0ustar liggesuserslibrary(testthat) library(dplyr) test_check("dplyr") dplyr/src/0000755000176200001440000000000013614574175012210 5ustar liggesusersdplyr/src/hybrid.cpp0000644000176200001440000000761313614573562014203 0ustar liggesusers#include "pch.h" #include #include #include namespace base { static SEXP primitive_bracket_one; static SEXP primitive_bracket_two; SEXP bracket_one() { return primitive_bracket_one; } SEXP bracket_two() { return primitive_bracket_two; } } namespace dplyr { namespace hybrid { // key = actual function static dplyr_hash_map hybrid_inline_map; // key = function name, need this for the pkg::fun case static dplyr_hash_map hybrid_named_map; inline SEXP force(SEXP x) { if (TYPEOF(x) == PROMSXP) { x = Rf_eval(x, R_BaseEnv); } return x; } dplyr_hash_map& get_hybrid_inline_map() { return hybrid_inline_map; } dplyr_hash_map& get_hybrid_named_map() { return hybrid_named_map; } void hybrid_init(SEXP env, SEXP name, SEXP package, hybrid_id id) { Rcpp::Shield fun(Rf_findVarInFrame3(env, name, FALSE)); hybrid_inline_map.insert( std::make_pair( force(fun), hybrid_function(name, package, id) ) ); hybrid_named_map.insert( std::make_pair( name, hybrid_function(name, package, id) ) ); } void init() { if (hybrid_inline_map.size() == 0) { Rcpp::Environment dplyr = Rcpp::Environment::namespace_env("dplyr"); hybrid_init(dplyr, symbols::n, symbols::dplyr, hybrid::N); hybrid_init(dplyr, symbols::group_indices, symbols::dplyr, hybrid::GROUP_INDICES); hybrid_init(dplyr, symbols::row_number, symbols::dplyr, hybrid::ROW_NUMBER); hybrid_init(dplyr, symbols::first, symbols::dplyr, hybrid::FIRST); hybrid_init(dplyr, symbols::last, symbols::dplyr, hybrid::LAST); hybrid_init(dplyr, symbols::nth, symbols::dplyr, hybrid::NTH); hybrid_init(dplyr, symbols::ntile, symbols::dplyr, hybrid::NTILE); hybrid_init(dplyr, symbols::min_rank, symbols::dplyr, hybrid::MIN_RANK); hybrid_init(dplyr, symbols::percent_rank, symbols::dplyr, hybrid::PERCENT_RANK); hybrid_init(dplyr, symbols::dense_rank, symbols::dplyr, hybrid::DENSE_RANK); hybrid_init(dplyr, symbols::cume_dist, symbols::dplyr, hybrid::CUME_DIST); hybrid_init(dplyr, symbols::lead, symbols::dplyr, hybrid::LEAD); hybrid_init(dplyr, symbols::lag, symbols::dplyr, hybrid::LAG); hybrid_init(dplyr, symbols::n_distinct, symbols::dplyr, hybrid::N_DISTINCT); SEXP base = R_BaseEnv; hybrid_init(base, symbols::sum, symbols::base, hybrid::SUM); hybrid_init(base, symbols::mean, symbols::base, hybrid::MEAN); hybrid_init(base, symbols::min, symbols::base, hybrid::MIN); hybrid_init(base, symbols::max, symbols::base, hybrid::MAX); hybrid_init(base, symbols::in, symbols::base, hybrid::IN); Rcpp::Environment stats = Rcpp::Environment::namespace_env("stats"); hybrid_init(stats, symbols::var, symbols::stats, hybrid::VAR); hybrid_init(stats, symbols::sd, symbols::stats, hybrid::SD); } ::base::primitive_bracket_one = Rf_eval(R_BracketSymbol, R_BaseEnv); ::base::primitive_bracket_two = Rf_eval(R_Bracket2Symbol, R_BaseEnv); } } } // [[Rcpp::init]] void init_hybrid_inline_map(DllInfo* /*dll*/) { dplyr::hybrid::init(); } // [[Rcpp::export(rng = false)]] Rcpp::List hybrids() { int n = dplyr::hybrid::hybrid_inline_map.size(); Rcpp::CharacterVector names(n); Rcpp::CharacterVector packages(n); Rcpp::List funs(n); dplyr_hash_map::iterator it = dplyr::hybrid::hybrid_inline_map.begin(); for (int i = 0; i < n; ++it, ++i) { names[i] = PRINTNAME(it->second.name); packages[i] = PRINTNAME(it->second.package); funs[i] = it->first; } Rcpp::List out = Rcpp::List::create( Rcpp::_["name"] = names, Rcpp::_["package"] = packages, Rcpp::_["fun"] = funs ); Rf_classgets(out, dplyr::NaturalDataFrame::classes()); dplyr::set_rownames(out, n); return out; } dplyr/src/summarise.cpp0000644000176200001440000001525713614573562014732 0ustar liggesusers#include "pch.h" #include #include #include #include #include #include #include #include namespace dplyr { static SEXP validate_unquoted_value(SEXP value, int nrows, const SymbolString& name) { int n = Rf_length(value); check_length(n, nrows, "the number of groups", name); // Recycle length 1 vectors if (n == 1) { value = constant_recycle(value, nrows, name); } return value; } SEXP reconstruct_groups(const Rcpp::DataFrame& old_groups, const Rcpp::List& new_indices, const Rcpp::IntegerVector& firsts, SEXP frame) { int nv = old_groups.size() - 1 ; Rcpp::Shield out(Rf_allocVector(VECSXP, nv)); Rcpp::Shield names(Rf_allocVector(STRSXP, nv)); Rcpp::Shield old_names(Rf_getAttrib(old_groups, symbols::names)); for (int i = 0; i < nv - 1; i++) { SET_VECTOR_ELT(out, i, column_subset(old_groups[i], firsts, frame)); SET_STRING_ELT(names, i, STRING_ELT(old_names, i)); } SET_VECTOR_ELT(out, nv - 1, new_indices); SET_STRING_ELT(names, nv - 1, Rf_mkChar(".rows")); set_rownames(out, new_indices.size()); set_class(out, NaturalDataFrame::classes()); copy_attrib(out, old_groups, symbols::dot_drop); Rf_namesgets(out, names); return out ; } template void structure_summarise(Rcpp::List& out, const SlicedTibble& df, SEXP frame) { set_class(out, NaturalDataFrame::classes()); } template <> void structure_summarise(Rcpp::List& out, const GroupedDataFrame& gdf, SEXP frame) { const Rcpp::DataFrame& df = gdf.data(); if (gdf.nvars() > 1) { copy_class(out, df); SymbolVector vars = gdf.get_vars(); vars.remove(gdf.nvars() - 1); Rcpp::DataFrame old_groups = gdf.group_data(); int nv = gdf.nvars() - 1; DataFrameVisitors visitors(old_groups, nv) ; int old_nrows = old_groups.nrow(); // the number of new groups int ngroups = 0; // sizes of each new group, there are at most old_nrows groups std::vector sizes(old_nrows); for (int i = 0; i < old_nrows;) { // go through one old group int start = i++; while (i < old_nrows && visitors.equal(start, i)) i++ ; sizes[ngroups++] = i - start; } // collect the new indices, now that we know the size Rcpp::List new_indices(ngroups); // the first index of each group Rcpp::IntegerVector firsts(Rcpp::no_init(ngroups)); int start = 0; for (int i = 0; i < ngroups; i++) { firsts[i] = start + 1; int n = sizes[i]; if (n) { new_indices[i] = Rcpp::IntegerVectorView(Rcpp::seq(start + 1, start + n)); } else { new_indices[i] = Rcpp::IntegerVectorView(0); } start += sizes[i]; } // groups Rcpp::DataFrame groups = reconstruct_groups(old_groups, new_indices, firsts, frame); GroupedDataFrame::set_groups(out, groups); } else { // clear groups and reset to non grouped classes GroupedDataFrame::strip_groups(out); Rf_classgets(out, NaturalDataFrame::classes()); } } template Rcpp::DataFrame summarise_grouped(const Rcpp::DataFrame& df, const QuosureList& dots, SEXP frame, SEXP caller_env) { SlicedTibble gdf(df); int nexpr = dots.size(); int nvars = gdf.nvars(); gdf.check_not_groups(dots); LOG_VERBOSE << "copying " << nvars << " variables to accumulator"; NamedListAccumulator accumulator; int i = 0; Rcpp::List results(nvars + nexpr); for (; i < nvars; i++) { LOG_VERBOSE << "copying " << gdf.symbol(i).get_utf8_cstring(); results[i] = gdf.label(i); accumulator.set(gdf.symbol(i), results[i]); } LOG_VERBOSE << "processing " << nexpr << " variables"; DataMask mask(gdf); for (int k = 0; k < nexpr; k++, i++) { LOG_VERBOSE << "processing variable " << k; Rcpp::checkUserInterrupt(); const NamedQuosure& quosure = dots[k]; LOG_VERBOSE << "processing variable " << quosure.name().get_utf8_cstring(); Rcpp::RObject result; // Unquoted vectors are directly used as column. Expressions are // evaluated in each group. Rcpp::Shield quo_expr(quosure.expr()); if (is_vector(quo_expr)) { result = validate_unquoted_value(quo_expr, gdf.ngroups(), quosure.name()); } else { result = hybrid::summarise(quosure, gdf, mask, caller_env); // If we could not find a direct Result, // we can use a GroupedCallReducer which will callback to R. if (result == R_UnboundValue) { mask.setup(); result = GroupedCallReducer(quosure, mask).process(gdf); } } check_not_null(result, quosure.name()); check_length(Rf_length(result), gdf.ngroups(), "a summary value", quosure.name()); results[i] = result; accumulator.set(quosure.name(), result); mask.input_summarised(quosure.name(), result); } Rcpp::List out = accumulator; // so that the attributes of the original tibble are preserved // as requested in issue #1064 copy_most_attributes(out, df); Rf_namesgets(out, accumulator.names().get_vector()); int nr = gdf.ngroups(); set_rownames(out, nr); structure_summarise(out, gdf, frame) ; return out; } } // [[Rcpp::export(rng = false)]] SEXP summarise_impl(Rcpp::DataFrame df, dplyr::QuosureList dots, SEXP frame, SEXP caller_env) { check_valid_colnames(df); if (Rcpp::is(df)) { return dplyr::summarise_grouped(df, dots, frame, caller_env); } else if (Rcpp::is(df)) { return dplyr::summarise_grouped(df, dots, frame, caller_env); } else { return dplyr::summarise_grouped(df, dots, frame, caller_env); } } namespace dplyr { template SEXP hybrid_template(Rcpp::DataFrame df, const Quosure& quosure, SEXP caller_env) { SlicedTibble gdf(df); Rcpp::Shield env(quosure.env()); Rcpp::Shield expr(quosure.expr()); DataMask mask(gdf); return hybrid::match(expr, gdf, mask, env, caller_env); } } // [[Rcpp::export(rng = false)]] SEXP hybrid_impl(Rcpp::DataFrame df, dplyr::Quosure quosure, SEXP caller_env) { check_valid_colnames(df); if (Rcpp::is(df)) { return dplyr::hybrid_template(df, quosure, caller_env); } else if (Rcpp::is(df)) { return dplyr::hybrid_template(df, quosure, caller_env); } else { return dplyr::hybrid_template(df, quosure, caller_env); } } dplyr/src/select.cpp0000644000176200001440000000543213614573562014176 0ustar liggesusers#include "pch.h" #include #include #include namespace dplyr { SEXP select_not_grouped(const Rcpp::DataFrame& df, const SymbolVector& keep, const SymbolVector& new_names) { Rcpp::Shield positions(r_match(keep.get_vector(), Rf_getAttrib(df, symbols::names))); int* p_positions = INTEGER(positions); int n = keep.size(); Rcpp::List res(n); for (int i = 0; i < n; i++) { int pos = p_positions[i]; if (pos < 1 || pos > df.size()) { std::stringstream s; if (pos == NA_INTEGER) { s << "NA"; } else { s << pos; } Rcpp::stop("invalid column index : %d for variable: '%s' = '%s'", s.str(), new_names[i].get_utf8_cstring(), keep[i].get_utf8_cstring()); } res[i] = df[ pos - 1 ]; } copy_most_attributes(res, df); Rf_namesgets(res, new_names.get_vector()); return res; } Rcpp::DataFrame select_grouped(const GroupedDataFrame& gdf, const SymbolVector& keep, const SymbolVector& new_names) { // start by selecting the columns without taking care of the grouping structure Rcpp::DataFrame copy = select_not_grouped(gdf.data(), keep, new_names); // then handle the groups attribute // it is almost the same as the groups attribute of the input data frame, but // names might change so we need to create a shallow copy and then deal with the names Rcpp::DataFrame groups(shallow_copy(Rcpp::List(gdf.group_data()))); // update the names of the grouping variables in case they are involved in // the selection, i.e. select(data, g1 = g2) Rcpp::Shield group_names(Rf_duplicate(Rf_getAttrib(groups, dplyr::symbols::names))); Rcpp::Shield positions(r_match(group_names, keep.get_vector())); int nl = gdf.nvars(); // maybe rename the variables in the groups metadata int* p_positions = INTEGER(positions); for (int i = 0; i < nl; i++) { int pos = p_positions[i]; if (pos != NA_INTEGER) { SET_STRING_ELT(group_names, i, new_names[pos - 1].get_sexp()); } else { bad_col(STRING_ELT(group_names, i), "not found in groups metadata. Probably a corrupt grouped_df object."); } } Rf_namesgets(groups, group_names); // then keep the grouping structure in the groups attribute GroupedDataFrame::set_groups(copy, groups) ; return copy; } } // [[Rcpp::export(rng = false)]] Rcpp::DataFrame select_impl(Rcpp::DataFrame df, Rcpp::CharacterVector vars) { check_valid_colnames(df); dplyr::SymbolVector s_vars(vars); dplyr::SymbolVector s_names_vars(Rf_getAttrib(vars, dplyr::symbols::names)); if (Rcpp::is(df)) { dplyr::GroupedDataFrame gdf(df); return dplyr::select_grouped(gdf, s_vars, s_names_vars); } else { return dplyr::select_not_grouped(df, s_vars, s_names_vars); } } dplyr/src/encoding.cpp0000644000176200001440000000275513614573562014512 0ustar liggesusers#include "pch.h" #include #include #include namespace dplyr { R_xlen_t get_first_reencode_pos(const Rcpp::CharacterVector& x) { R_xlen_t len = x.length(); for (R_xlen_t i = 0; i < len; ++i) { SEXP xi = x[i]; if (xi != NA_STRING && !IS_ASCII(xi) && !IS_UTF8(xi)) { return i; } } return len; } Rcpp::CharacterVector reencode_char(SEXP x) { if (Rf_isFactor(x)) return reencode_factor(x); #if (defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0)) // If ret is an Altrep call DATAPTR to materialize it fully here, since we // will be touching all the elements anyway. if (ALTREP(x)) { DATAPTR(x); } #endif Rcpp::CharacterVector ret(x); R_xlen_t first = get_first_reencode_pos(ret); if (first >= ret.length()) return ret; ret = clone(ret); R_xlen_t len = ret.length(); for (R_xlen_t i = first; i < len; ++i) { SEXP reti = ret[i]; if (reti != NA_STRING && !IS_ASCII(reti) && !IS_UTF8(reti)) { ret[i] = Rcpp::String(Rf_translateCharUTF8(reti), CE_UTF8); } } return ret; } Rcpp::CharacterVector reencode_factor(Rcpp::IntegerVector x) { Rcpp::CharacterVector levels(reencode_char(get_levels(x))); Rcpp::CharacterVector ret(x.length()); R_xlen_t nlevels = levels.length(); R_xlen_t len = x.length(); for (R_xlen_t i = 0; i < len; ++i) { int xi = x[i]; if (xi <= 0 || xi > nlevels) ret[i] = NA_STRING; else ret[i] = levels[xi - 1]; } return ret; } } dplyr/src/window.cpp0000644000176200001440000000571313614573562014230 0ustar liggesusers#include "pch.h" #include //' Cumulativate versions of any, all, and mean //' //' dplyr provides `cumall()`, `cumany()`, and `cummean()` to complete R's set //' of cumulative functions. //' //' @section Cumulative logical functions: //' //' These are particularly useful in conjunction with `filter()`: //' //' * `cumall(x)`: all cases until the first `FALSE`. //' * `cumall(!x)`: all cases until the first `TRUE`. //' * `cumany(x)`: all cases after the first `TRUE`. //' * `cumany(!x)`: all cases after the first `FALSE`. //' //' @param x For `cumall()` and `cumany()`, a logical vector; for //' `cummean()` an integer or numeric vector. //' @return A vector the same length as `x`. //' @export //' @examples //' # `cummean()` returns a numeric/integer vector of the same length //' # as the input vector. //' x <- c(1, 3, 5, 2, 2) //' cummean(x) //' cumsum(x) / seq_along(x) //' //' # `cumall()` and `cumany()` return logicals //' cumall(x < 5) //' cumany(x == 3) //' //' # `cumall()` vs. `cumany()` //' df <- data.frame( //' date = as.Date("2020-01-01") + 0:6, //' balance = c(100, 50, 25, -25, -50, 30, 120) //' ) //' # all rows after first overdraft //' df %>% filter(cumany(balance < 0)) //' # all rows until first overdraft //' df %>% filter(cumall(!(balance < 0))) // [[Rcpp::export(rng = false)]] Rcpp::LogicalVector cumall(Rcpp::LogicalVector x) { int n = x.length(); Rcpp::LogicalVector out(n, TRUE); int* p_x = x.begin(); int* p_out = out.begin(); // nothing to do as long as x[i] is TRUE int i = 0 ; for (; i < n; i++, ++p_x, ++p_out) { if (*p_x != TRUE) { break; } } if (i == n) { return out; } // set to NA as long as x[i] is NA or TRUE for (; i < n; i++, ++p_x, ++p_out) { if (*p_x == FALSE) { break; } *p_out = NA_LOGICAL; } if (i == n) { return out; } // then if we are here, the rest is FALSE for (; i < n; i++, ++p_out) { *p_out = FALSE; } return out; } //' @export //' @rdname cumall // [[Rcpp::export(rng = false)]] Rcpp::LogicalVector cumany(Rcpp::LogicalVector x) { int n = x.length(); Rcpp::LogicalVector out(n, FALSE); int* p_x = x.begin(); int* p_out = out.begin(); // nothing to do as long as x[i] is FALSE int i = 0 ; for (; i < n; i++, ++p_x, ++p_out) { if (*p_x != FALSE) { break; } } if (i == n) { return out; } // set to NA as long as x[i] is NA or FALSE for (; i < n; i++, ++p_x, ++p_out) { if (*p_x == TRUE) { break; } *p_out = NA_LOGICAL; } if (i == n) { return out; } // then if we are here, the rest is TRUE for (; i < n; i++, ++p_out) { *p_out = TRUE; } return out; } //' @export //' @rdname cumall // [[Rcpp::export(rng = false)]] Rcpp::NumericVector cummean(Rcpp::NumericVector x) { int n = x.length(); Rcpp::NumericVector out(Rcpp::no_init(n)); double sum = out[0] = x[0]; for (int i = 1; i < n; i++) { sum += x[i]; out[i] = sum / (i + 1.0); } return out; } dplyr/src/utils-bindings.cpp0000644000176200001440000000041413614573562015645 0ustar liggesusers#include "pch.h" #include #include // [[Rcpp::export(rng = false)]] SEXP materialize_binding(int idx, Rcpp::XPtr mask_proxy_xp) { LOG_VERBOSE << idx; return mask_proxy_xp->materialize(idx); } dplyr/src/init.cpp0000644000176200001440000000731013614573562013657 0ustar liggesusers#include "pch.h" #include #include #include namespace dplyr { SEXP get_date_classes() { static Rcpp::CharacterVector klasses(1, Rf_mkChar("Date")); return klasses; } inline SEXP init_time_classes() { Rcpp::Shield res(Rf_allocVector(STRSXP, 2)); SET_STRING_ELT(res, 0, Rf_mkChar("POSIXct")); SET_STRING_ELT(res, 1, Rf_mkChar("POSIXt")); return res; } SEXP get_time_classes() { static Rcpp::CharacterVector klasses(init_time_classes()); return klasses; } SEXP get_factor_classes() { static Rcpp::CharacterVector klasses(1, Rf_mkChar("factor")); return klasses; } SEXP mark_precious(SEXP x) { R_PreserveObject(x); return x; } SEXP symbols::package = Rf_install("package"); SEXP symbols::n = Rf_install("n"); SEXP symbols::tzone = Rf_install("tzone"); SEXP symbols::units = Rf_install("units"); SEXP symbols::dot_env = Rf_install(".env"); SEXP symbols::dot_data = Rf_install(".data"); SEXP symbols::sum = Rf_install("sum"); SEXP symbols::mean = Rf_install("mean"); SEXP symbols::var = Rf_install("var"); SEXP symbols::sd = Rf_install("sd"); SEXP symbols::n_distinct = Rf_install("n_distinct"); SEXP symbols::first = Rf_install("first"); SEXP symbols::last = Rf_install("last"); SEXP symbols::nth = Rf_install("nth"); SEXP symbols::group_indices = Rf_install("group_indices"); SEXP symbols::min = Rf_install("min"); SEXP symbols::max = Rf_install("max"); SEXP symbols::row_number = Rf_install("row_number"); SEXP symbols::ntile = Rf_install("ntile"); SEXP symbols::min_rank = Rf_install("min_rank"); SEXP symbols::percent_rank = Rf_install("percent_rank"); SEXP symbols::dense_rank = Rf_install("dense_rank"); SEXP symbols::cume_dist = Rf_install("cume_dist"); SEXP symbols::lead = Rf_install("lead"); SEXP symbols::lag = Rf_install("lag"); SEXP symbols::in = Rf_install("%in%"); SEXP symbols::narm = Rf_install("na.rm"); SEXP symbols::default_ = Rf_install("default"); SEXP symbols::dplyr = Rf_install("dplyr"); SEXP symbols::base = Rf_install("base"); SEXP symbols::stats = Rf_install("stats"); SEXP symbols::desc = Rf_install("desc"); SEXP symbols::double_colon = Rf_install("::"); SEXP symbols::na_rm = Rf_install("na.rm"); SEXP symbols::new_env = Rf_install("new.env"); SEXP symbols::comment = Rf_install("comment"); SEXP symbols::groups = Rf_install("groups"); SEXP symbols::vars = Rf_install("vars"); SEXP symbols::position = Rf_install("position"); SEXP symbols::op_minus = Rf_install("-"); SEXP symbols::str = Rf_install("str"); SEXP symbols::dot_Internal = Rf_install(".Internal"); SEXP symbols::inspect = Rf_install("inspect"); SEXP symbols::dot = Rf_install("."); SEXP symbols::dot_x = Rf_install(".x"); SEXP symbols::drop = Rf_install("drop"); SEXP symbols::rlang = Rf_install("rlang"); SEXP symbols::eval_tidy = Rf_install("eval_tidy"); SEXP symbols::quote = Rf_install("quote"); SEXP symbols::dot_drop = Rf_install(".drop"); SEXP symbols::warn_deprecated = Rf_install("warn_deprecated"); SEXP symbols::signal_soft_deprecated = Rf_install("signal_soft_deprecated"); SEXP symbols::call = Rf_install("call"); SEXP symbols::env = Rf_install("env"); SEXP symbols::fun = Rf_install("fun"); SEXP symbols::cpp_class = Rf_install("cpp_class"); SEXP symbols::levels = Rf_install("levels"); SEXP symbols::labels = Rf_install("labels"); SEXP symbols::indices = Rf_install("indices"); SEXP symbols::ptype = Rf_install("ptype"); SEXP symbols::names = R_NamesSymbol; SEXP symbols::formula = Rf_install("formula"); SEXP fns::quote = Rf_eval(Rf_install("quote"), R_BaseEnv); SEXP strings::POSIXct = STRING_ELT(get_time_classes(), 0); SEXP strings::POSIXt = STRING_ELT(get_time_classes(), 1); SEXP strings::Date = STRING_ELT(get_date_classes(), 0); SEXP vectors::factor = get_factor_classes(); } dplyr/src/join.cpp0000644000176200001440000001734213614573562013661 0ustar liggesusers#include "pch.h" #include #include #include #include #include namespace dplyr { inline bool is_bare_vector(SEXP x) { SEXP att = ATTRIB(x); // only allow R_Names. as in R's do_isvector while (att != R_NilValue) { SEXP tag = TAG(att); if (!(tag == R_NamesSymbol || tag == symbols::comment)) return false; att = CDR(att); } return true; } void warn_bad_var(const SymbolString& var_left, const SymbolString& var_right, std::string message, bool warn = true) { if (!warn) return; if (var_left == var_right) { std::string var_utf8 = var_left.get_utf8_cstring(); Rf_warningcall( R_NilValue, "Column `%s` %s", var_utf8.c_str(), message.c_str() ); } else { std::string left_utf8 = var_left.get_utf8_cstring(); std::string right_utf8 = var_right.get_utf8_cstring(); Rf_warningcall( R_NilValue, "Column `%s`/`%s` %s", left_utf8.c_str(), right_utf8.c_str(), message.c_str() ); } } void check_attribute_compatibility(const Column& left, const Column& right) { // Rely on R function based on all.equal static Rcpp::Function attr_equal = Rcpp::Function("attr_equal", Rcpp::Environment::namespace_env("dplyr")); Rcpp::Shield s_ok(attr_equal(left.get_data(), right.get_data())); if (!Rcpp::as(s_ok)) { warn_bad_var(left.get_name(), right.get_name(), "has different attributes on LHS and RHS of join"); } } template JoinVisitor* date_join_visitor_right(const Column& left, const Column& right) { switch (TYPEOF(right.get_data())) { case INTSXP: return new DateJoinVisitor(left, right); case REALSXP: return new DateJoinVisitor(left, right); default: Rcpp::stop("Date objects should be represented as integer or numeric"); } } template JoinVisitor* date_join_visitor(const Column& left, const Column& right) { switch (TYPEOF(left.get_data())) { case INTSXP: return date_join_visitor_right(left, right); case REALSXP: return date_join_visitor_right(left, right); default: Rcpp::stop("Date objects should be represented as integer or numeric"); } } template JoinVisitor* join_visitor(const Column& left, const Column& right, bool warn_) { // handle Date separately bool lhs_date = Rf_inherits(left.get_data(), "Date"); bool rhs_date = Rf_inherits(right.get_data(), "Date"); switch (lhs_date + rhs_date) { case 2: return date_join_visitor(left, right); case 1: Rcpp::stop("cannot join a Date object with an object that is not a Date object"); case 0: break; default: break; } bool lhs_time = Rf_inherits(left.get_data(), "POSIXct"); bool rhs_time = Rf_inherits(right.get_data(), "POSIXct"); switch (lhs_time + rhs_time) { case 2: return new POSIXctJoinVisitor(left, right); case 1: Rcpp::stop("cannot join a POSIXct object with an object that is not a POSIXct object"); case 0: break; default: break; } switch (TYPEOF(left.get_data())) { case CPLXSXP: { switch (TYPEOF(right.get_data())) { case CPLXSXP: return new JoinVisitorImpl(left, right, warn_); default: break; } break; } case INTSXP: { bool lhs_factor = Rf_inherits(left.get_data(), "factor"); switch (TYPEOF(right.get_data())) { case INTSXP: { bool rhs_factor = Rf_inherits(right.get_data(), "factor"); if (lhs_factor && rhs_factor) { if (same_levels(left.get_data(), right.get_data())) { return new JoinVisitorImpl(left, right, warn_); } else { warn_bad_var( left.get_name(), right.get_name(), "joining factors with different levels, coercing to character vector", warn_ ); return new JoinVisitorImpl( left.update_data(reencode_char(left.get_data())), right.update_data(reencode_char(right.get_data())), warn_ ); } } else if (!lhs_factor && !rhs_factor) { return new JoinVisitorImpl(left, right, warn_); } break; } case REALSXP: { if (!lhs_factor && is_bare_vector(right.get_data())) { return new JoinVisitorImpl(left, right, warn_); } break; // what else: perhaps we can have INTSXP which is a Date and REALSXP which is a Date too ? } case LGLSXP: { if (!lhs_factor) { return new JoinVisitorImpl(left, right, warn_); } break; } case STRSXP: { if (lhs_factor) { warn_bad_var( left.get_name(), right.get_name(), "joining factor and character vector, coercing into character vector", warn_ ); return new JoinVisitorImpl( left.update_data(reencode_char(left.get_data())), right.update_data(reencode_char(right.get_data())), warn_ ); } } default: break; } break; } case REALSXP: { switch (TYPEOF(right.get_data())) { case REALSXP: return new JoinVisitorImpl(left, right, warn_); case INTSXP: return new JoinVisitorImpl(left, right, warn_); default: break; } } case LGLSXP: { switch (TYPEOF(right.get_data())) { case LGLSXP: return new JoinVisitorImpl (left, right, warn_); case INTSXP: return new JoinVisitorImpl(left, right, warn_); case REALSXP: return new JoinVisitorImpl(left, right, warn_); default: break; } break; } case STRSXP: { switch (TYPEOF(right.get_data())) { case INTSXP: { if (Rf_inherits(right.get_data(), "factor")) { warn_bad_var( left.get_name(), right.get_name(), "joining character vector and factor, coercing into character vector", warn_ ); return new JoinVisitorImpl( left.update_data(reencode_char(left.get_data())), right.update_data(reencode_char(right.get_data())), warn_ ); } break; } case STRSXP: { return new JoinVisitorImpl( left.update_data(reencode_char(left.get_data())), right.update_data(reencode_char(right.get_data())), warn_ ); } default: break; } break; } case RAWSXP: { switch (TYPEOF(right.get_data())) { case RAWSXP: { return new JoinVisitorImpl (left, right, warn_); } default: break; } } default: break; } Rcpp::stop( "Can't join on '%s' x '%s' because of incompatible types (%s / %s)", left.get_name().get_utf8_cstring(), right.get_name().get_utf8_cstring(), get_single_class(left.get_data()), get_single_class(right.get_data()) ); } JoinVisitor* join_visitor(const Column& left, const Column& right, bool warn, bool accept_na_match) { if (accept_na_match) return join_visitor(left, right, warn); else return join_visitor(left, right, warn); } } dplyr/src/mutate.cpp0000644000176200001440000003272113614573562014217 0ustar liggesusers#include "pch.h" #include #include #include #include #include #include #include #include #include #include #include #include namespace dplyr { template inline const char* check_length_message() { return "the group size"; } template <> inline const char* check_length_message() { return "the number of rows"; } namespace internal { template class ConstantRecycler { public: ConstantRecycler(SEXP constant_, int n_) : constant(constant_), n(n_) {} inline SEXP collect() { Rcpp::Vector result(n, Rcpp::internal::r_vector_start(constant)[0]); copy_most_attributes(result, constant); return result; } private: SEXP constant; int n ; }; } inline SEXP constant_recycle(SEXP x, int n, const SymbolString& name) { if (Rf_inherits(x, "POSIXlt")) { bad_col(name, "is of unsupported class POSIXlt; please use POSIXct instead"); } switch (TYPEOF(x)) { case INTSXP: return internal::ConstantRecycler(x, n).collect(); case REALSXP: return internal::ConstantRecycler(x, n).collect(); case LGLSXP: return internal::ConstantRecycler(x, n).collect(); case STRSXP: return internal::ConstantRecycler(x, n).collect(); case CPLXSXP: return internal::ConstantRecycler(x, n).collect(); case VECSXP: return internal::ConstantRecycler(x, n).collect(); case RAWSXP: return internal::ConstantRecycler(x, n).collect(); default: break; } bad_col(name, "is of unsupported type {type}", Rcpp::_["type"] = Rf_type2char(TYPEOF(x))); } template class Gatherer; template class ListGatherer; template class MutateCallProxy { public: typedef typename SlicedTibble::slicing_index Index ; MutateCallProxy(const SlicedTibble& data_, DataMask& mask_, const NamedQuosure& quosure_) : data(data_), mask(mask_), quosure(quosure_.get()), expr(quosure_.expr()), name(quosure_.name()) {} SEXP get() { // literal NULL if (Rf_isNull(expr)) { return expr ; } // a symbol that is in the data, just return it if (TYPEOF(expr) == SYMSXP) { const ColumnBinding* subset_data = mask.maybe_get_subset_binding(CHAR(PRINTNAME(expr))); if (subset_data) return subset_data->get_data(); } // a call or symbol that is not in the data if (TYPEOF(expr) == LANGSXP || TYPEOF(expr) == SYMSXP) { return evaluate(); } // a constant if (Rf_length(expr) == 1) { return constant_recycle(expr, data.nrows(), name); } // something else return validate_unquoted_value(); } private: const SlicedTibble& data ; // where to find subsets of data variables DataMask& mask ; Quosure quosure; // expression unwrapped from the quosure SEXP expr; SymbolString name ; SEXP validate_unquoted_value() const { int nrows = data.nrows(); if (is_vector(expr)) check_length(Rf_length(expr), nrows, check_length_message(), name); else bad_col(name, "is of unsupported type {type}", Rcpp::_["type"] = Rf_type2char(TYPEOF(expr))); return expr; } SEXP evaluate() { const int ng = data.ngroups(); typename SlicedTibble::group_iterator git = data.group_begin(); int i = 0; while (!(*git).size()) { ++git; i++; } typename SlicedTibble::slicing_index indices = *git; Rcpp::RObject first(get(indices)); if (Rf_inherits(first, "POSIXlt")) { bad_col(name, "is of unsupported class POSIXlt; please use POSIXct instead"); } if (Rf_inherits(first, "data.frame")) { bad_col(name, "is of unsupported class data.frame"); } if (Rf_isNull(first)) { while (Rf_isNull(first)) { i++; if (i == ng) return R_NilValue; ++git; indices = *git; first = get(indices); } } check_supported_type(first, name); check_length(Rf_length(first), indices.size(), check_length_message(), name); if (ng > 1) { while (all_na(first)) { i++; if (i == ng) break; ++git; indices = *git; first = get(indices); } } SEXP res; if (TYPEOF(first) == VECSXP) { Rcpp::List list_first(first); ListGatherer gatherer(list_first, indices, const_cast(*this), data, i, name); res = PROTECT(gatherer.collect()); } else { Gatherer gatherer(first, indices, const_cast(*this), data, i, name); res = PROTECT(gatherer.collect()); } UNPROTECT(1); return res; } public: SEXP get(const Index& indices) { return mask.eval(quosure, indices) ; } }; template <> SEXP MutateCallProxy::evaluate() { NaturalDataFrame::group_iterator git = data.group_begin(); NaturalDataFrame::slicing_index indices = *git; Rcpp::RObject first(get(indices)); if (Rf_isNull(first)) return R_NilValue; if (Rf_inherits(first, "POSIXlt")) { bad_col(name, "is of unsupported class POSIXlt; please use POSIXct instead"); } if (Rf_inherits(first, "data.frame")) { bad_col(name, "is of unsupported class data.frame"); } check_supported_type(first, name); check_length(Rf_length(first), indices.size(), check_length_message(), name); if (Rf_length(first) == 1 && indices.size() != 1) { return constant_recycle(first, indices.size(), name); } return first; } template class Gatherer { public: typedef typename SlicedTibble::slicing_index Index; Gatherer( const Rcpp::RObject& first, const Index& indices, MutateCallProxy& proxy_, const SlicedTibble& gdf_, int first_non_na_, const SymbolString& name_ ) : gdf(gdf_), proxy(proxy_), first_non_na(first_non_na_), name(name_) { coll = collecter(first, gdf.nrows()); if (first_non_na < gdf.ngroups()) grab(first, indices); } ~Gatherer() { if (coll != 0) { delete coll; } } SEXP collect() { int ngroups = gdf.ngroups(); if (first_non_na == ngroups) return coll->get(); typename SlicedTibble::group_iterator git = gdf.group_begin(); int i = 0; for (; i < first_non_na; i++) ++git; ++git; i++; for (; i < ngroups; i++, ++git) { const Index& indices = *git; if (indices.size()) { Rcpp::Shield subset(proxy.get(indices)); grab(subset, indices); } } return coll->get(); } private: inline void grab(SEXP subset, const Index& indices) { int n = Rf_length(subset); if (n == indices.size()) { grab_along(subset, indices); } else if (n == 1) { grab_rep(subset, indices); } else if (Rf_isNull(subset)) { Rcpp::stop("incompatible types (NULL), expecting %s", coll->describe()); } else { check_length(n, indices.size(), check_length_message(), name); } } template void grab_along(SEXP subset, const Idx& indices) { if (coll->compatible(subset)) { // if the current source is compatible, collect coll->collect(indices, subset); } else if (coll->can_promote(subset)) { // setup a new Collecter Collecter* new_collecter = promote_collecter(subset, gdf.nrows(), coll); // import data from previous collecter. new_collecter->collect(NaturalSlicingIndex(gdf.nrows()), coll->get()); // import data from this chunk new_collecter->collect(indices, subset); // dispose the previous collecter and keep the new one. delete coll; coll = new_collecter; } else if (coll->is_logical_all_na()) { Collecter* new_collecter = collecter(subset, gdf.nrows()); new_collecter->collect(indices, subset); delete coll; coll = new_collecter; } else { bad_col(name, "can't be converted from {source_type} to {target_type}", Rcpp::_["source_type"] = coll->describe(), Rcpp::_["target_type"] = get_single_class(subset)); } } void grab_rep(SEXP value, const Index& indices) { int n = indices.size(); // FIXME: This can be made faster if `source` in `Collecter->collect(source, indices)` // could be of length 1 recycling the value. // TODO: create Collecter->collect_one(source, indices)? for (int j = 0; j < n; j++) { grab_along(value, RowwiseSlicingIndex(indices[j])); } } const SlicedTibble& gdf; MutateCallProxy& proxy; Collecter* coll; int first_non_na; const SymbolString& name; }; template class ListGatherer { public: typedef typename SlicedTibble::slicing_index Index; ListGatherer(Rcpp::List first, const Index& indices, MutateCallProxy& proxy_, const SlicedTibble& gdf_, int first_non_na_, const SymbolString& name_) : gdf(gdf_), proxy(proxy_), data(gdf.nrows()), first_non_na(first_non_na_), name(name_) { if (first_non_na < gdf.ngroups()) { grab(first, indices); } copy_most_attributes(data, first); } SEXP collect() { int ngroups = gdf.ngroups(); if (first_non_na == ngroups) return data; typename SlicedTibble::group_iterator git = gdf.group_begin(); int i = 0; for (; i < first_non_na; i++) ++git; ++git; i++; for (; i < ngroups; i++, ++git) { const Index& indices = *git; if (indices.size()) { Rcpp::Shield res(proxy.get(indices)); Rcpp::List subset(res); grab(subset, indices); } } return data; } private: inline void grab(const Rcpp::List& subset, const Index& indices) { int n = subset.size(); if (n == indices.size()) { grab_along(subset, indices); } else if (n == 1) { grab_rep(subset[0], indices); } else { check_length(n, indices.size(), check_length_message(), name); } } void grab_along(const Rcpp::List& subset, const Index& indices) { int n = indices.size(); for (int j = 0; j < n; j++) { data[ indices[j] ] = subset[j]; } } void grab_rep(SEXP value, const Index& indices) { int n = indices.size(); for (int j = 0; j < n; j++) { data[ indices[j] ] = value; } } const SlicedTibble& gdf; MutateCallProxy& proxy; Rcpp::List data; int first_non_na; const SymbolString name; }; } template Rcpp::DataFrame mutate_grouped(const Rcpp::DataFrame& df, const dplyr::QuosureList& dots, SEXP caller_env) { LOG_DEBUG << "initializing proxy"; SlicedTibble gdf(df); int nexpr = dots.size(); gdf.check_not_groups(dots); LOG_DEBUG << "copying data to accumulator"; dplyr::NamedListAccumulator accumulator; int ncolumns = df.size(); Rcpp::Shield column_names(Rf_getAttrib(df, dplyr::symbols::names)); for (int i = 0; i < ncolumns; i++) { accumulator.set(STRING_ELT(column_names, i), df[i]); } LOG_VERBOSE << "processing " << nexpr << " variables"; dplyr::DataMask mask(gdf) ; for (int i = 0; i < nexpr; i++) { Rcpp::checkUserInterrupt(); const dplyr::NamedQuosure& quosure = dots[i]; dplyr::SymbolString name = quosure.name(); LOG_VERBOSE << "Variable " << name.get_utf8_cstring(); Rcpp::RObject variable = dplyr::hybrid::window(quosure.expr(), gdf, mask, quosure.env(), caller_env) ; LOG_VERBOSE << "Checking result"; if (variable == R_UnboundValue) { LOG_VERBOSE << "Rechaining"; // NULL columns are not removed if `setup()` is not called here mask.setup(); variable = dplyr::MutateCallProxy(gdf, mask, quosure).get(); } if (Rf_isNull(variable)) { accumulator.rm(name); mask.rm(name); continue; } LOG_VERBOSE << "Finalizing"; if (!Rcpp::traits::same_type::value) { Rf_setAttrib(variable, R_NamesSymbol, R_NilValue); } mask.input_column(name, variable); accumulator.set(name, variable); } // basic structure of the data frame Rcpp::List res = accumulator; dplyr::set_class(res, dplyr::get_class(df)); dplyr::set_rownames(res, df.nrows()); // let the grouping class deal with the rest, e.g. the // groups attribute return SlicedTibble(res, gdf).data(); } template SEXP mutate_zero(const Rcpp::DataFrame& df, const dplyr::QuosureList& dots, SEXP caller_env, bool set_groups) { SlicedTibble tbl(df); if (tbl.ngroups() == 0 || tbl.nrows() == 0) { Rcpp::DataFrame res = mutate_grouped(df, dots, caller_env); if (set_groups) { dplyr::GroupedDataFrame::copy_groups(res, df); } return res; } return mutate_grouped(df, dots, caller_env); } // [[Rcpp::export(rng = false)]] SEXP mutate_impl(Rcpp::DataFrame df, dplyr::QuosureList dots, SEXP caller_env) { if (dots.size() == 0) return df; check_valid_colnames(df); if (Rcpp::is(df)) { return mutate_zero(df, dots, caller_env, false); } else if (Rcpp::is(df)) { return mutate_zero(df, dots, caller_env, true); } else { return mutate_grouped(df, dots, caller_env); } } dplyr/src/group_indices.cpp0000644000176200001440000005016713614573562015556 0ustar liggesusers#include "pch.h" #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include # if __cplusplus >= 201103L #define MOVE(x) std::move(x) # else #define MOVE(x) x # endif // [[Rcpp::export(rng = false)]] Rcpp::IntegerVector grouped_indices_grouped_df_impl(const dplyr::GroupedDataFrame& gdf) { int n = gdf.nrows(); Rcpp::IntegerVector res(Rcpp::no_init(n)); int ngroups = gdf.ngroups(); dplyr::GroupedDataFrameIndexIterator it = gdf.group_begin(); for (int i = 0; i < ngroups; i++, ++it) { const GroupedSlicingIndex& index = *it; int n_index = index.size(); for (int j = 0; j < n_index; j++) { res[ index[j] ] = i + 1; } } return res; } // [[Rcpp::export(rng = false)]] Rcpp::IntegerVector group_size_grouped_cpp(const dplyr::GroupedDataFrame& gdf) { return dplyr::hybrid::n_(gdf).summarise() ; } namespace dplyr { class IntRange { public: IntRange() : start(-1), size(0) {} IntRange(int start_, int size_): start(start_), size(size_) {} void add(const IntRange& other) { if (start < 0) { start = other.start; } size += other.size; } int start; int size; }; inline int plus_one(int i) { return i + 1; } class ListCollecter { public: ListCollecter(Rcpp::List& data_): data(data_), index(0) {} int collect(const std::vector& indices) { data[index] = Rcpp::IntegerVector(indices.begin(), indices.end(), plus_one); return index++; } private: Rcpp::List& data; int index; }; template class CopyVectorVisitor { public: // need to fix it in Rcpp first // https://github.com/RcppCore/Rcpp/issues/849 // typedef typename Rcpp::Vector Vec; typedef typename Rcpp::Vector Vec; CopyVectorVisitor(Vec target_, Vec origin_) : target(target_), origin(origin_) {} virtual void copy(const IntRange& target_range, int idx_origin) { std::fill_n( target.begin() + target_range.start, target_range.size, idx_origin == NA_INTEGER ? default_value() : origin[idx_origin] ); } private: Vec target; Vec origin; }; inline void copy_visit(const IntRange& target_range, int idx_origin, SEXP target, SEXP origin) { switch (TYPEOF(target)) { case INTSXP: CopyVectorVisitor(target, origin).copy(target_range, idx_origin); break; case REALSXP: CopyVectorVisitor(target, origin).copy(target_range, idx_origin); break; case LGLSXP: CopyVectorVisitor(target, origin).copy(target_range, idx_origin); break; case STRSXP: CopyVectorVisitor(target, origin).copy(target_range, idx_origin); break; case RAWSXP: CopyVectorVisitor(target, origin).copy(target_range, idx_origin); break; case CPLXSXP: CopyVectorVisitor(target, origin).copy(target_range, idx_origin); break; } } class Slicer { public: virtual ~Slicer() {}; virtual int size() = 0; virtual IntRange make(Rcpp::List& vec_groups, ListCollecter& indices_collecter) = 0; }; boost::shared_ptr slicer(const std::vector& index_range, int depth, const std::vector& data_, const DataFrameVisitors& visitors_, bool drop); class LeafSlicer : public Slicer { public: LeafSlicer(const std::vector& index_range_) : index_range(index_range_) {} virtual int size() { return 1; } virtual IntRange make(Rcpp::List& vec_groups, ListCollecter& indices_collecter) { return IntRange(indices_collecter.collect(index_range), 1); } virtual ~LeafSlicer() {}; private: const std::vector& index_range; }; class EchoVector { public: EchoVector(int n_) : n(n_) {} inline int operator[](int i) const { return i; } inline int size() const { return n; } private: int n; }; class FactorSlicer : public Slicer { public: typedef Rcpp::IntegerVector Factor; FactorSlicer(int depth_, const std::vector& index_range, const std::vector& data_, const DataFrameVisitors& visitors_, bool drop_) : depth(depth_), data(data_), visitors(visitors_), f(data[depth]), nlevels(Rf_length(Rf_getAttrib(f, symbols::levels))), indices(nlevels + 1), slicers(nlevels + 1), slicer_size(0), has_implicit_na(false), drop(drop_) { train(index_range); } virtual int size() { return slicer_size; } virtual IntRange make(Rcpp::List& vec_groups, ListCollecter& indices_collecter) { IntRange groups_range; SEXP x = vec_groups[depth]; for (int i = 0; i < nlevels; i++) { // collect the indices for that level IntRange idx = slicers[i]->make(vec_groups, indices_collecter); groups_range.add(idx); // fill the groups at these indices std::fill_n(INTEGER(x) + idx.start, idx.size, i + 1); } if (has_implicit_na) { // collect the indices for the implicit NA pseudo group IntRange idx = slicers[nlevels]->make(vec_groups, indices_collecter); groups_range.add(idx); // fill the groups at these indices std::fill_n(INTEGER(x) + idx.start, idx.size, NA_INTEGER); } return groups_range; } virtual ~FactorSlicer() {} private: void train(const std::vector& index_range) { // special case for depth==0 so that we don't have to build // the 0:(n-1) vector indices if (depth == 0) { train_impl(EchoVector(Rf_length(data[0]))); } else { train_impl(index_range); } if (!has_implicit_na) { indices.pop_back(); slicers.pop_back(); } // ---- for each level, train child slicers int n = nlevels + has_implicit_na; for (int i = 0; i < n; i++) { slicers[i] = slicer(indices[i], depth + 1, data, visitors, drop); slicer_size += slicers[i]->size(); } } template void train_impl(const Indices& range) { int n = range.size(); for (int i = 0; i < n; i++) { int idx = range[i]; int value = f[idx]; if (value == NA_INTEGER) { has_implicit_na = true; indices[nlevels].push_back(idx); } else { indices[value - 1].push_back(idx); } } } int depth; const std::vector& data; const DataFrameVisitors& visitors; Factor f; int nlevels; std::vector< std::vector > indices; std::vector< boost::shared_ptr > slicers; int slicer_size; bool has_implicit_na; bool drop; }; class VectorSlicer : public Slicer { private: typedef std::pair* > IndicesPair; class PairCompare { public: PairCompare(VectorVisitor* v_) : v(v_) {}; bool operator()(const IndicesPair& x, const IndicesPair& y) { return v->less(x.first, y.first); } private: VectorVisitor* v; }; public: VectorSlicer(int depth_, const std::vector& index_range, const std::vector& data_, const DataFrameVisitors& visitors_, bool drop_) : depth(depth_), // index_range(index_range_), data(data_), visitors(visitors_), visitor(visitors_.get(depth)), indices(), slicer_size(0), drop(drop_) { train(index_range); } virtual int size() { return slicer_size; } virtual IntRange make(Rcpp::List& vec_groups, ListCollecter& indices_collecter) { IntRange groups_range; int nlevels = slicers.size(); for (int i = 0; i < nlevels; i++) { // collect the indices for that level IntRange idx = slicers[i]->make(vec_groups, indices_collecter); groups_range.add(idx); // fill the groups at these indices copy_visit(idx, agents[i], vec_groups[depth], data[depth]); } return groups_range; } virtual ~VectorSlicer() {} private: void train(const std::vector& index_range) { if (depth == 0) { train_impl(EchoVector(Rf_length(data[0]))); } else { train_impl(index_range); } // ---- for each level, train child slicers int n = indices.size(); slicers.reserve(n); for (int i = 0; i < n; i++) { slicers.push_back(slicer(indices[i], depth + 1, data, visitors, drop)); slicer_size += slicers[i]->size(); } } template void train_impl(const Indices& index_range) { int n = index_range.size(); if (n == 0) { // deal with special case when index_range is empty agents.push_back(NA_INTEGER); // NA is used as a placeholder indices.push_back(std::vector()); // empty indices } else { Map map(visitor, n); // train the map for (int i = 0; i < n; i++) { int idx = index_range[i]; map[idx].push_back(idx); } // fill agents and indices int nlevels = map.size(); std::vector map_collect; for (Map::const_iterator it = map.begin(); it != map.end(); ++it) { map_collect.push_back(std::make_pair* >(int(it->first), &it->second)); } PairCompare compare(visitors.get(depth)); std::sort(map_collect.begin(), map_collect.end(), compare); // make sure the vectors are not resized indices.reserve(nlevels); agents.reserve(nlevels); slicers.reserve(nlevels); // ---- for each case, create indices for (int i = 0; i < nlevels; i++) { agents.push_back(map_collect[i].first); indices.push_back(MOVE(*map_collect[i].second)); } } } typedef VisitorSetIndexMap > Map; int depth; const std::vector data; const DataFrameVisitors& visitors; VectorVisitor* visitor; std::vector< int > agents; std::vector< std::vector > indices; std::vector< boost::shared_ptr > slicers; int slicer_size; bool drop; }; boost::shared_ptr slicer(const std::vector& index_range, int depth, const std::vector& data, const DataFrameVisitors& visitors, bool drop) { if (static_cast(depth) == data.size()) { return boost::shared_ptr(new LeafSlicer(index_range)); } else { SEXP x = data[depth]; if (Rf_isFactor(x) && !drop) { return boost::shared_ptr(new FactorSlicer(depth, index_range, data, visitors, drop)); } else { return boost::shared_ptr(new VectorSlicer(depth, index_range, data, visitors, drop)); } } } inline bool is_factor(SEXP x) { return Rf_inherits(x, "factor"); } bool has_no_factors(const std::vector& x) { return std::find_if(x.begin(), x.end(), is_factor) == x.end(); } } // [[Rcpp::export(rng = false)]] SEXP regroup(Rcpp::DataFrame grouping_data, SEXP frame) { size_t nc = grouping_data.size() - 1; // 1) only keep the rows with non empty groups size_t n = grouping_data.nrow(); std::vector keep; keep.reserve(n); Rcpp::ListView rows = grouping_data[nc]; for (size_t i = 0; i < n; i++) { if (LENGTH(rows[i]) > 0) keep.push_back(i + 1); } if (keep.size() == n) return grouping_data; Rcpp::IntegerVector r_keep(keep.begin(), keep.end()); grouping_data = dplyr::dataframe_subset(grouping_data, r_keep, "data.frame", frame); // 2) perform a group by so that factor levels are expanded dplyr::DataFrameVisitors visitors(grouping_data, nc); std::vector visited_data(nc); for (size_t i = 0; i < nc; i++) { visited_data[i] = grouping_data[i]; } SEXP drop = Rf_getAttrib(grouping_data, dplyr::symbols::dot_drop); boost::shared_ptr s = slicer(std::vector(), 0, visited_data, visitors, Rcpp::is(drop) && Rcpp::as(drop)); size_t ncases = s->size(); if (ncases == 1 && grouping_data.nrow() == 0 && dplyr::has_no_factors(visited_data)) { ncases = 0; } Rcpp::List vec_groups(nc + 1); Rcpp::List indices(ncases); dplyr::ListCollecter indices_collecter(indices); for (size_t i = 0; i < nc; i++) { vec_groups[i] = Rf_allocVector(TYPEOF(visited_data[i]), ncases); dplyr::copy_most_attributes(vec_groups[i], visited_data[i]); } if (ncases > 0) { s->make(vec_groups, indices_collecter); } // 3) translate indices on grouping_data to indices wrt the data Rcpp::ListView original_rows = grouping_data[nc]; for (size_t i = 0; i < ncases; i++) { if (LENGTH(indices[i]) == 1) { indices[i] = original_rows[Rcpp::as(indices[i]) - 1]; } } vec_groups[nc] = indices; Rf_namesgets(vec_groups, vec_names(grouping_data)); dplyr::set_rownames(vec_groups, ncases); Rf_classgets(vec_groups, dplyr::NaturalDataFrame::classes()); return vec_groups; } SEXP build_index_cpp(const Rcpp::DataFrame& data, const dplyr::SymbolVector& vars, bool drop) { const int nvars = vars.size(); Rcpp::Shield names(Rf_getAttrib(data, dplyr::symbols::names)); Rcpp::Shield indx(dplyr::r_match(vars.get_vector(), names)); int* p_indx = INTEGER(indx); std::vector visited_data(nvars); Rcpp::CharacterVector groups_names(nvars + 1); for (int i = 0; i < nvars; ++i) { int pos = p_indx[i]; if (pos == NA_INTEGER) { bad_col(vars[i], "is unknown"); } SEXP v = data[pos - 1]; visited_data[i] = v; groups_names[i] = STRING_ELT(names, pos - 1); if (!dplyr::allow_list(v) || TYPEOF(v) == VECSXP) { bad_col(vars[i], "can't be used as a grouping variable because it's a {type}", Rcpp::_["type"] = dplyr::get_single_class(v)); } } dplyr::DataFrameVisitors visitors(data, vars); boost::shared_ptr s = slicer(std::vector(), 0, visited_data, visitors, drop); int ncases = s->size(); if (ncases == 1 && data.nrow() == 0 && dplyr::has_no_factors(visited_data)) { ncases = 0; } // construct the groups data Rcpp::List vec_groups(nvars + 1); Rcpp::List indices(ncases); for (int i = 0; i < nvars; i++) { vec_groups[i] = Rf_allocVector(TYPEOF(visited_data[i]), ncases); dplyr::copy_most_attributes(vec_groups[i], visited_data[i]); } dplyr::ListCollecter indices_collecter(indices); if (ncases > 0) { s->make(vec_groups, indices_collecter); } vec_groups[nvars] = indices; groups_names[nvars] = ".rows"; // warn about NA in factors for (int i = 0; i < nvars; i++) { SEXP x = vec_groups[i]; if (Rf_isFactor(x)) { Rcpp::IntegerVector xi(x); if (std::find(xi.begin(), xi.end(), NA_INTEGER) < xi.end()) { Rcpp::warningcall(R_NilValue, tfm::format("Factor `%s` contains implicit NA, consider using `forcats::fct_explicit_na`", CHAR(groups_names[i].get()))); } } } Rf_namesgets(vec_groups, groups_names); dplyr::set_rownames(vec_groups, ncases); Rf_classgets(vec_groups, dplyr::NaturalDataFrame::classes()); Rf_setAttrib(vec_groups, dplyr::symbols::dot_drop, Rf_ScalarLogical(drop)); return vec_groups; } namespace dplyr { SEXP check_grouped(Rcpp::RObject data) { // compat with old style grouped data frames SEXP vars = Rf_getAttrib(data, symbols::vars); if (!Rf_isNull(vars)) { Rf_warningcall(R_NilValue, "Detecting old grouped_df format, replacing `vars` attribute by `groups`"); // only make the groups attribute if it does not yet exist if (Rf_isNull(Rf_getAttrib(data, symbols::groups))) { // using drop = true here because this is likely to play better with // older representations Rcpp::DataFrame groups = build_index_cpp(data, SymbolVector(vars), true); Rf_setAttrib(data, symbols::groups, groups); } // but always clean the pre 0.8.0 attributes Rf_setAttrib(data, symbols::vars, R_NilValue); Rf_setAttrib(data, symbols::indices, R_NilValue); Rf_setAttrib(data, symbols::labels, R_NilValue); } // get the groups attribute and check for consistency SEXP groups = Rf_getAttrib(data, symbols::groups); // groups must be a data frame if (!Rcpp::is(groups)) { bad_arg(".data", "is a corrupt grouped_df, the `\"groups\"` attribute must be a data frame"); } int nc = Rf_length(groups); // it must have at least 1 column if (nc < 1) { bad_arg(".data", "is a corrupt grouped_df, the `\"groups\"` attribute must have at least one column"); } // the last column must be a list and called `.rows` SEXP names = Rf_getAttrib(groups, R_NamesSymbol); SEXP last = VECTOR_ELT(groups, nc - 1); static Rcpp::String rows(".rows"); if (TYPEOF(last) != VECSXP || STRING_ELT(names, nc - 1) != rows.get_sexp()) { bad_arg(".data", "is a corrupt grouped_df, the `\"groups\"` attribute must have a list column named `.rows` as last column"); } return data ; } GroupedDataFrame::GroupedDataFrame(Rcpp::DataFrame x): data_(check_grouped(x)), symbols(group_vars()), groups(Rf_getAttrib(data_, symbols::groups)), nvars_(symbols.size()) {} GroupedDataFrame::GroupedDataFrame(Rcpp::DataFrame x, const GroupedDataFrame& model): data_(x), symbols(model.get_vars()), groups(build_index_cpp(data_, model.get_vars(), model.drops())), nvars_(symbols.size()) { set_groups(data_, groups); } SymbolVector GroupedDataFrame::group_vars() const { SEXP groups = Rf_getAttrib(data_, dplyr::symbols::groups); int n = Rf_length(groups) - 1; Rcpp::Shelter shelter; SEXP vars_attr = shelter(Rf_getAttrib(groups, R_NamesSymbol)); SEXP vars = shelter(Rf_allocVector(STRSXP, n)); for (int i = 0; i < n; i++) { SET_STRING_ELT(vars, i, STRING_ELT(vars_attr, i)); } return SymbolVector(vars); } } // [[Rcpp::export(rng = false)]] Rcpp::DataFrame grouped_df_impl(Rcpp::DataFrame data, const dplyr::SymbolVector& symbols, bool drop) { Rcpp::DataFrame copy(shallow_copy(data)); if (!symbols.size()) { dplyr::GroupedDataFrame::strip_groups(copy); Rf_classgets(copy, dplyr::NaturalDataFrame::classes()); return copy; } dplyr::set_class(copy, dplyr::GroupedDataFrame::classes()); // we've made a copy and we are about to create the groups // attribute, so we make sure there is no more a vars // attribute lurking around from the pre 0.8.0 area Rf_setAttrib(copy, dplyr::symbols::vars, R_NilValue); Rf_setAttrib(copy, dplyr::symbols::drop, R_NilValue); dplyr::GroupedDataFrame::set_groups(copy, build_index_cpp(copy, symbols, drop)); return copy; } // [[Rcpp::export(rng = false)]] Rcpp::DataFrame group_data_grouped_df(Rcpp::DataFrame data) { return dplyr::GroupedDataFrame(data).group_data(); } // [[Rcpp::export(rng = false)]] Rcpp::DataFrame ungroup_grouped_df(Rcpp::DataFrame df) { Rcpp::DataFrame copy(shallow_copy(df)); dplyr::GroupedDataFrame::strip_groups(copy); dplyr::set_class(copy, dplyr::NaturalDataFrame::classes()); return copy; } // [[Rcpp::export(rng = false)]] Rcpp::List group_split_impl(const dplyr::GroupedDataFrame& gdf, bool keep, SEXP frame) { Rcpp::ListView rows = gdf.indices(); R_xlen_t n = rows.size(); Rcpp::DataFrame group_data = gdf.group_data(); Rcpp::DataFrame data = gdf.data(); if (!keep) { Rcpp::Shield all_names(vec_names(data)); int nv = data.size(); dplyr_hash_set all_set; for (int i = 0; i < nv; i++) { all_set.insert(STRING_ELT(all_names, i)); } int ng = group_data.ncol() - 1; Rcpp::Shield group_names(vec_names(group_data)); for (int i = 0; i < ng; i++) { SEXP name = STRING_ELT(group_names, i); if (all_set.count(name)) all_set.erase(name); } Rcpp::IntegerVector kept_cols(all_set.size()); int k = 0; for (int i = 0; i < nv; i++) { if (all_set.count(STRING_ELT(all_names, i))) { kept_cols[k++] = i + 1; } } data = dplyr::DataFrameSelect(data, kept_cols, false); } dplyr::GroupedDataFrame::group_iterator git = gdf.group_begin(); Rcpp::List out(n); for (R_xlen_t i = 0; i < n; i++, ++git) { Rcpp::DataFrame out_i = dplyr::dataframe_subset(data, *git, dplyr::NaturalDataFrame::classes(), frame); dplyr::GroupedDataFrame::strip_groups(out_i); out[i] = out_i; } Rf_setAttrib( out, dplyr::symbols::ptype, dplyr::dataframe_subset(data, Rcpp::IntegerVector(0), dplyr::NaturalDataFrame::classes(), frame) ); return out; } dplyr/src/set.cpp0000644000176200001440000003155413614573562013516 0ustar liggesusers#include "pch.h" #include #include #include #include #include #include #include #include #include #include #include #include #include class RowTrack { public: RowTrack(const std::string& msg, int max_count_ = 10) : ss(), count(0), max_count(max_count_) { ss << msg; } void record(int i) { if (count > max_count) return; if (count) ss << ", "; int idx = i >= 0 ? (i + 1) : -i; ss << idx; if (count == max_count) ss << "[...]"; count++; } bool empty() const { return count == 0; } std::string str() const { return ss.str(); } private: std::stringstream ss; int count; int max_count; }; // [[Rcpp::export(rng = false)]] dplyr::BoolResult compatible_data_frame_nonames(Rcpp::DataFrame x, Rcpp::DataFrame y, bool convert) { int n = x.size(); if (n != y.size()) return dplyr::no_because(tfm::format("different number of columns : %d x %d", n, y.size())); if (convert) { for (int i = 0; i < n; i++) { try { boost::scoped_ptr v( dplyr::join_visitor( Column(x[i], dplyr::SymbolString("x")), Column(y[i], dplyr::SymbolString("y")), true, true ) ); } catch (...) { return dplyr::no_because("incompatible"); } } } else { for (int i = 0; i < n; i++) { SEXP xi = x[i], yi = y[i]; if (TYPEOF(xi) != TYPEOF(yi)) return dplyr::no_because("incompatible types"); if (TYPEOF(xi) == INTSXP) { if (Rf_inherits(xi, "factor") && Rf_inherits(yi, "factor")) { if (dplyr::same_levels(xi, yi)) continue; return dplyr::no_because("factors with different levels"); } if (Rf_inherits(xi, "factor")) return dplyr::no_because("cannot compare factor and integer"); if (Rf_inherits(yi, "factor")) return dplyr::no_because("cannot compare factor and integer"); } } } return dplyr::yes(); } bool same_factor_levels(SEXP x, SEXP y, std::stringstream& ss, const dplyr::SymbolString& name) { bool res = dplyr::same_levels(x, y); if (!res) { ss << "Factor levels not equal for column `" << name.get_utf8_cstring() << "`"; } return res; } bool type_compatible(SEXP x, SEXP y) { // if one is a matrix but not the other, the types are not compatible if (Rf_isMatrix(x) + Rf_isMatrix(y) == 1) { return false; } if (Rf_inherits(x, "Date")) return Rf_inherits(y, "Date"); switch (TYPEOF(x)) { case RAWSXP: return TYPEOF(y) == RAWSXP; case LGLSXP: return TYPEOF(y) == LGLSXP; case CPLXSXP: return TYPEOF(y) == CPLXSXP; case INTSXP: if (Rf_isFactor(x)) { return TYPEOF(y) == STRSXP || Rf_isFactor(y); } else if (Rf_inherits(x, "Date")) { return Rf_inherits(y, "Date"); } else { return !Rf_isFactor(y) && (TYPEOF(y) == INTSXP || TYPEOF(y) == REALSXP); } case REALSXP: return TYPEOF(y) == INTSXP || TYPEOF(y) == REALSXP; case STRSXP: return TYPEOF(y) == STRSXP || Rf_isFactor(y); case VECSXP: if (Rf_inherits(x, "data.frame")) { // TODO: also recurse into the df to check if // - same names // - same type for each column return Rf_inherits(y, "data.frame"); } else { return !Rf_inherits(y, "data.frame"); } default: break; } return false; } bool type_same(SEXP x, SEXP y, std::stringstream& ss, const dplyr::SymbolString& name) { // if one is a matrix but not the other, the types are not compatible if (Rf_isMatrix(x) + Rf_isMatrix(y) == 1) { return false; } if (Rf_inherits(x, "Date")) return Rf_inherits(y, "Date"); switch (TYPEOF(x)) { case RAWSXP: return TYPEOF(y) == RAWSXP; case LGLSXP: return TYPEOF(y) == LGLSXP; case CPLXSXP: return TYPEOF(y) == CPLXSXP; case INTSXP: if (Rf_isFactor(x)) { return Rf_isFactor(y) && same_factor_levels(x, y, ss, name); } else { return !Rf_isFactor(y) && TYPEOF(y) == INTSXP; } case REALSXP: if (Rf_inherits(x, "Date")) { return Rf_inherits(y, "Date"); } else { return TYPEOF(y) == REALSXP; } case STRSXP: return TYPEOF(y) == STRSXP; case VECSXP: if (Rf_inherits(x, "data.frame")) { // TODO: also recurse into the df to check if // - same names // - same type for each column return Rf_inherits(y, "data.frame"); } else { return !Rf_inherits(y, "data.frame"); } default: break; } return false; } std::string type_describe(SEXP x) { if (Rf_isMatrix(x)) { return "matrix"; } else if (Rf_inherits(x, "data.frame")) { return dplyr::get_single_class(x); } else if (Rf_inherits(x, "Date")) { return "Date"; } else if (Rf_isFactor(x)) { return dplyr::get_single_class(x); } else { return dplyr::get_single_class(x); } } // [[Rcpp::export(rng = false)]] dplyr::BoolResult compatible_data_frame(Rcpp::DataFrame x, Rcpp::DataFrame y, bool ignore_col_order = true, bool convert = false) { int n = x.size(); Rcpp::Shield x_names(Rf_getAttrib(x, dplyr::symbols::names)); Rcpp::Shield y_names(Rf_getAttrib(y, dplyr::symbols::names)); bool null_x = Rf_isNull(x_names); bool null_y = Rf_isNull(y_names); if (null_x && !null_y) { return dplyr::no_because("x does not have names, but y does"); } else if (null_y && !null_x) { return dplyr::no_because("y does not have names, but x does"); } else if (null_x && null_y) { return compatible_data_frame_nonames(x, y, convert); } Rcpp::CharacterVector names_x(x_names); Rcpp::CharacterVector names_y(y_names); Rcpp::CharacterVector names_y_not_in_x = setdiff(names_y, names_x); Rcpp::CharacterVector names_x_not_in_y = setdiff(names_x, names_y); if (!ignore_col_order) { if (names_y_not_in_x.size() == 0 && names_x_not_in_y.size() == 0) { // so the names are the same, check if they are in the same order for (int i = 0; i < n; i++) { if (names_x[i] != names_y[i]) { return dplyr::no_because("Same column names, but different order"); } } } } Rcpp::CharacterVector why; if (names_y_not_in_x.size()) { std::stringstream ss; ss << "Cols in y but not x: " << dplyr::collapse_utf8(names_y_not_in_x, ", ", "`") << ". "; why.push_back(Rcpp::String(ss.str(), CE_UTF8)); } if (names_x_not_in_y.size()) { std::stringstream ss; ss << "Cols in x but not y: " << dplyr::collapse_utf8(names_x_not_in_y, ", ", "`") << ". "; why.push_back(Rcpp::String(ss.str(), CE_UTF8)); } if (why.length() > 0) return dplyr::no_because(why); Rcpp::Shield orders(dplyr::r_match(names_x, names_y)); int* p_orders = INTEGER(orders); for (int i = 0; i < n; i++) { dplyr::SymbolString name = names_x[i]; SEXP xi = x[i], yi = y[p_orders[i] - 1]; std::stringstream ss; bool compatible = convert ? type_compatible(xi, yi) : type_same(xi, yi, ss, name); if (!compatible) { if (ss.str() == "") { ss << "Incompatible type for column `" << name.get_utf8_cstring() << "`: x " << type_describe(xi) << ", y " << type_describe(yi); } why.push_back(Rcpp::String(ss.str(), CE_UTF8)); } } if (why.length() > 0) return dplyr::no_because(why); return dplyr::yes(); } // [[Rcpp::export(rng = false)]] dplyr::BoolResult equal_data_frame(Rcpp::DataFrame x, Rcpp::DataFrame y, bool ignore_col_order = true, bool ignore_row_order = true, bool convert = false) { dplyr::BoolResult compat = compatible_data_frame(x, y, ignore_col_order, convert); if (!compat) return compat; typedef dplyr::VisitorSetIndexMap > Map; dplyr::SymbolVector x_names(Rf_getAttrib(x, dplyr::symbols::names)); dplyr::DataFrameJoinVisitors visitors(x, y, x_names, x_names, true, true); Map map(visitors); // train the map in both x and y int nrows_x = x.nrows(); int nrows_y = y.nrows(); if (nrows_x != nrows_y) return dplyr::no_because("Different number of rows"); if (x.size() == 0) return dplyr::yes(); for (int i = 0; i < nrows_x; i++) map[i].push_back(i); for (int i = 0; i < nrows_y; i++) map[-i - 1].push_back(-i - 1); RowTrack track_x("Rows in x but not y: "); RowTrack track_y("Rows in y but not x: "); RowTrack track_mismatch("Rows with difference occurences in x and y: "); bool ok = true; Map::const_iterator it = map.begin(); for (; it != map.end(); ++it) { // retrieve the indices ( -ves for y, +ves for x ) const std::vector& chunk = it->second; int n = chunk.size(); int count_left = 0, count_right = 0; for (int i = 0; i < n; i++) { if (chunk[i] < 0) count_right++; else count_left++; } if (count_right == 0) { track_x.record(chunk[0]); ok = false; } else if (count_left == 0) { track_y.record(chunk[0]); ok = false; } else if (count_left != count_right) { track_mismatch.record(chunk[0]); ok = false; } } if (!ok) { std::stringstream ss; if (! track_x.empty()) ss << track_x.str() << ". "; if (! track_y.empty()) ss << track_y.str() << ". "; if (! track_mismatch.empty()) ss << track_mismatch.str(); return dplyr::no_because(Rcpp::CharacterVector::create(Rcpp::String(ss.str(), CE_UTF8))); } if (ok && ignore_row_order) return dplyr::yes(); if (!ignore_row_order) { for (int i = 0; i < nrows_x; i++) { if (!visitors.equal(i, -i - 1)) { return dplyr::no_because("Same row values, but different order"); } } } return dplyr::yes(); } Rcpp::DataFrame reconstruct_metadata(Rcpp::DataFrame out, const Rcpp::DataFrame& x) { if (Rcpp::is(x)) { // go through the GroupedDataFrame class so that the groups attribute is generated return dplyr::GroupedDataFrame(out, x).data(); } else { // nothing to do for rowwise and natural data frames return out; } } // [[Rcpp::export(rng = false)]] Rcpp::DataFrame union_data_frame(Rcpp::DataFrame x, Rcpp::DataFrame y) { dplyr::BoolResult compat = compatible_data_frame(x, y, true, true); if (!compat) { Rcpp::stop("not compatible: %s", compat.why_not()); } typedef dplyr::VisitorSetIndexSet Set; dplyr::SymbolVector x_names(Rf_getAttrib(x, dplyr::symbols::names)); dplyr::DataFrameJoinVisitors visitors(x, y, x_names, x_names, true, true); Set set(visitors); int n_x = x.nrows(); int n_y = y.nrows(); std::vector indices; indices.reserve(n_x + n_y); for (int i = 0; i < n_x; i++) { std::pair inserted = set.insert(i); if (inserted.second) { indices.push_back(i); } } for (int i = 0; i < n_y; i++) { std::pair inserted = set.insert(-i - 1); if (inserted.second) { indices.push_back(-i - 1); } } return reconstruct_metadata(visitors.subset(indices, dplyr::get_class(x)), x); } // [[Rcpp::export(rng = false)]] Rcpp::DataFrame intersect_data_frame(Rcpp::DataFrame x, Rcpp::DataFrame y) { dplyr::BoolResult compat = compatible_data_frame(x, y, true, true); if (!compat) { Rcpp::stop("not compatible: %s", compat.why_not()); } typedef dplyr::VisitorSetIndexSet Set; dplyr::SymbolVector x_names(Rf_getAttrib(x, dplyr::symbols::names)); dplyr::DataFrameJoinVisitors visitors(x, y, x_names, x_names, true, true); Set set(visitors); int n_x = x.nrows(); int n_y = y.nrows(); dplyr::train_insert_right(set, n_y); std::vector indices; indices.reserve(std::min(n_x, n_y)); for (int i = 0; i < n_x; i++) { Set::iterator it = set.find(i); if (it != set.end()) { indices.push_back(*it); set.erase(it); } } return reconstruct_metadata(visitors.subset(indices, dplyr::get_class(x)), x); } // [[Rcpp::export(rng = false)]] Rcpp::DataFrame setdiff_data_frame(Rcpp::DataFrame x, Rcpp::DataFrame y) { dplyr::BoolResult compat = compatible_data_frame(x, y, true, true); if (!compat) { Rcpp::stop("not compatible: %s", compat.why_not()); } typedef dplyr::VisitorSetIndexSet Set; dplyr::SymbolVector y_names(Rf_getAttrib(y, dplyr::symbols::names)); dplyr::DataFrameJoinVisitors visitors(x, y, y_names, y_names, true, true); Set set(visitors); int n_x = x.nrows(); int n_y = y.nrows(); train_insert_right(set, n_y); std::vector indices; indices.reserve(n_x); for (int i = 0; i < n_x; i++) { std::pair inserted = set.insert(i); if (inserted.second) { indices.push_back(i); } } return reconstruct_metadata(visitors.subset(indices, dplyr::get_class(x)), x); } dplyr/src/bind.cpp0000644000176200001440000003135313614573562013634 0ustar liggesusers#include "pch.h" #include #include #include #include #include #include #include #include #include #include #include namespace dplyr { // From Rcpp::DataFrame static int df_rows_length(SEXP df) { SEXP n = R_NilValue; SEXP attrs = ATTRIB(df); while (attrs != R_NilValue) { if (TAG(attrs) == R_RowNamesSymbol) { n = CAR(attrs); break; } attrs = CDR(attrs); } if (n == R_NilValue) return 0; else if (TYPEOF(n) == INTSXP && LENGTH(n) == 2 && INTEGER(n)[0] == NA_INTEGER) return abs(INTEGER(n)[1]); else return LENGTH(n); } static R_xlen_t rows_length(SEXP x, bool rowwise) { if (TYPEOF(x) == VECSXP) { if (Rf_inherits(x, "data.frame")) return df_rows_length(x); else if (Rf_xlength(x) > 0) return Rf_xlength(VECTOR_ELT(x, 0)); else return 0; } else { if (rowwise) return 1; else return Rf_xlength(x); } } static R_xlen_t cols_length(SEXP x) { if (TYPEOF(x) == VECSXP) return Rf_xlength(x); else return 1; } static void inner_vector_check(SEXP x, int nrows, int arg) { if (!is_vector(x)) bad_pos_arg(arg + 1, "is a list, must contain atomic vectors"); if (OBJECT(x)) { if (Rf_inherits(x, "data.frame")) bad_pos_arg(arg + 1, "can't be a list containing data frames"); if (Rf_inherits(x, "POSIXlt")) bad_pos_arg(arg + 1, "can't be a list containing POSIXlt values"); } if (Rf_length(x) != nrows) { bad_pos_arg(arg + 1, "must be length {expected_size}, not {actual_size}", Rcpp::_["expected_size"] = nrows, Rcpp::_["actual_size"] = Rf_length(x)); } } static bool is_non_data_frame_object(SEXP x) { if (TYPEOF(x) != VECSXP) return false; if (!OBJECT(x)) return false; return !Rf_inherits(x, "data.frame"); } static void rbind_vector_check(SEXP x, R_xlen_t nrows, int arg) { if (!is_vector(x) || is_non_data_frame_object(x)) { bad_pos_arg(arg + 1, "must be a data frame or a named atomic vector, not a {type}", Rcpp::_["type"] = get_single_class(x)); } if (rows_length(x, true) != nrows) { bad_pos_arg(arg + 1, "must be length {expected_size}, not {actual_size}", Rcpp::_["expected_size"] = rows_length(x, true), Rcpp::_["actual_size"] = nrows); } if (vec_names(x) == R_NilValue) { bad_pos_arg(arg + 1, "must have names"); } } static void cbind_vector_check(SEXP x, R_xlen_t nrows, SEXP contr, int arg) { if (is_atomic(x) && !has_name_at(contr, arg)) bad_pos_arg(arg + 1, "must have names"); const R_xlen_t actual_nrows = rows_length(x, false); if (actual_nrows != nrows) { bad_pos_arg(arg + 1, "must be length {expected_size}, not {actual_size}", Rcpp::_["expected_size"] = nrows, Rcpp::_["actual_size"] = actual_nrows); } } static void rbind_type_check(SEXP x, int nrows, int arg) { int n = Rf_length(x); if (n == 0) return; rbind_vector_check(x, nrows, arg); if (TYPEOF(x) == VECSXP) { for (int i = 0; i < n; i++) inner_vector_check(VECTOR_ELT(x, i), nrows, i); } } static void cbind_type_check(SEXP x, int nrows, SEXP contr, int arg) { int n = Rf_length(x); if (n == 0) return; cbind_vector_check(x, nrows, contr, arg); if (TYPEOF(x) == VECSXP) { if (OBJECT(x) && !Rf_inherits(x, "data.frame")) { bad_pos_arg(arg + 1, "must be a data frame or a named atomic vector, not a {type}", Rcpp::_["type"] = get_single_class(x)); } for (int i = 0; i < n; i++) inner_vector_check(VECTOR_ELT(x, i), nrows, i); } } Rcpp::List rbind__impl(Rcpp::List dots, const dplyr::SymbolString& id) { int ndata = dots.size(); LOG_VERBOSE << "binding at most " << ndata << " chunks"; R_xlen_t n = 0; std::vector chunks; std::vector df_nrows; chunks.reserve(ndata); df_nrows.reserve(ndata); int k = 0; for (int i = 0; i < ndata; i++) { SEXP obj = dots[i]; if (Rf_isNull(obj)) continue; chunks.push_back(obj); R_xlen_t nrows = rows_length(chunks[k], true); df_nrows.push_back(nrows); n += nrows; k++; } ndata = chunks.size(); pointer_vector columns; LOG_VERBOSE << "binding " << ndata << " chunks"; SymbolVector names; k = 0; for (int i = 0; i < ndata; i++) { Rcpp::checkUserInterrupt(); SEXP df = chunks[i]; R_xlen_t nrows = df_nrows[i]; rbind_type_check(df, nrows, i); SymbolVector df_names(vec_names(df)); for (int j = 0; j < Rf_length(df); j++) { SEXP source; int offset; if (TYPEOF(df) == VECSXP) { source = VECTOR_ELT(df, j); offset = 0; } else { source = df; offset = j; } SymbolString name = df_names[j]; Collecter* coll = 0; R_xlen_t index = 0; for (; index < names.size(); index++) { if (name == names[index]) { coll = columns[index]; break; } } if (!coll) { coll = collecter(source, n); columns.push_back(coll); names.push_back(name); } if (coll->compatible(source)) { // if the current source is compatible, collect coll->collect(OffsetSlicingIndex(k, nrows), source, offset); } else if (coll->can_promote(source)) { // setup a new Collecter Collecter* new_collecter = promote_collecter(source, n, coll); // import data from this chunk new_collecter->collect(OffsetSlicingIndex(k, nrows), source, offset); // import data from previous collecter new_collecter->collect(NaturalSlicingIndex(k), coll->get()); // dispose the previous collecter and keep the new one. delete coll; columns[index] = new_collecter; } else if (all_na(source)) { // do nothing, the collecter already initialized data with the // right NA } else if (coll->is_logical_all_na()) { Collecter* new_collecter = collecter(source, n); new_collecter->collect(OffsetSlicingIndex(k, nrows), source, offset); delete coll; columns[index] = new_collecter; } else { bad_col(SymbolString(name), "can't be converted from {source_type} to {target_type}", Rcpp::_["source_type"] = coll->describe(), Rcpp::_["target_type"] = get_single_class(source)); } } k += nrows; } int nc = columns.size(); LOG_VERBOSE << "result has " << nc << " columns"; int has_id = id.is_empty() ? 0 : 1; Rcpp::List out(Rcpp::no_init(nc + has_id)); SymbolVector out_names(Rcpp::no_init(nc + has_id)); for (int i = 0; i < nc; i++) { out[i + has_id] = columns[i]->get(); out_names.set(i + has_id, names[i]); } // Add vector of identifiers if .id is supplied if (!id.is_empty()) { // extract the names SEXP dots_names(vec_names(dots)); if (Rf_isNull(dots_names)) { out[0] = Rf_allocVector(STRSXP, n); } else { // use the SEXP* directly so that we don't have to pay to check // that dots_names is a STRSXP every single time SEXP* p_dots_names = STRING_PTR(dots_names); SEXP* p_dots = get_vector_ptr(dots); // we create id_col now, so it is definitely younger than dots_names // this is surely write barrier proof SEXP id_col = PROTECT(Rf_allocVector(STRSXP, n)); SEXP* p_id_col = STRING_PTR(id_col); for (int i = 0; i < ndata; ++i, ++p_dots_names, ++p_dots) { // skip NULL on dots. because the way df_nrows is made above // need to skip dots_names too while (Rf_isNull(*p_dots)) { ++p_dots; ++p_dots_names; } p_id_col = std::fill_n(p_id_col, df_nrows[i], *p_dots_names); } out[0] = id_col; UNPROTECT(1); } out_names.set(0, id); } Rf_namesgets(out, out_names.get_vector()); set_rownames(out, n); LOG_VERBOSE << "result has " << n << " rows"; // infer the classes group info from the first (#1692) if (ndata) { SEXP first = chunks[0]; if (Rf_inherits(first, "data.frame")) { set_class(out, get_class(first)); if (Rcpp::is(first)) { out = GroupedDataFrame(out, GroupedDataFrame(first)).data(); } } else { set_class(out, NaturalDataFrame::classes()); } } else { set_class(out, NaturalDataFrame::classes()); } return out; } } extern "C" bool dplyr_is_bind_spliceable(SEXP x) { if (TYPEOF(x) != VECSXP) return false; if (Rf_inherits(x, "spliced")) return true; if (Rf_inherits(x, "data.frame")) return false; for (R_xlen_t i = 0; i != Rf_xlength(x); ++i) { if (is_atomic(VECTOR_ELT(x, i))) return false; } return true; } // [[Rcpp::export(rng = false)]] SEXP flatten_bindable(SEXP x) { // FIXME: This is temporary and should be replaced with rlang::flatten_if() typedef bool(*is_spliceable_t)(SEXP); typedef SEXP(*rlang_squash_if_t)(SEXP, SEXPTYPE, is_spliceable_t, int); static rlang_squash_if_t rlang_squash_if = (rlang_squash_if_t)R_GetCCallable("rlang", "rlang_squash_if"); return rlang_squash_if(x, VECSXP, &dplyr_is_bind_spliceable, 1); } // [[Rcpp::export(rng = false)]] Rcpp::List bind_rows_(Rcpp::List dots, SEXP id) { LOG_VERBOSE; if (Rf_isNull(id)) return rbind__impl(dots, dplyr::SymbolString()); else return rbind__impl(dots, dplyr::SymbolString(Rcpp::as(id))); } // [[Rcpp::export(rng = false)]] SEXP cbind_all(Rcpp::List dots) { int n_dots = dots.size(); // First check that the number of rows is the same based on first // nonnull element int first_i = -1; for (int i = 0; i != n_dots; ++i) { if (dots[i] != R_NilValue) { first_i = i; break; } } if (!n_dots || first_i == -1) return Rcpp::DataFrame(); SEXP first = dots[first_i]; const R_xlen_t nrows = dplyr::rows_length(first, false); dplyr::cbind_type_check(first, nrows, dots, 0); R_xlen_t nv = dplyr::cols_length(first); for (int i = first_i + 1; i < n_dots; i++) { SEXP current = dots[i]; if (Rf_isNull(current)) continue; dplyr::cbind_type_check(current, nrows, dots, i); nv += dplyr::cols_length(current); } // collect columns Rcpp::Shield out(Rf_allocVector(VECSXP, nv)); Rcpp::Shield out_names(Rf_allocVector(STRSXP, nv)); // Can't use CharacterVector because the result might be R_NilValue Rcpp::RObject dots_names = vec_names(dots); // then do the subsequent dfs for (int i = first_i, k = 0; i < n_dots; i++) { SEXP current = dots[i]; if (Rf_isNull(current)) continue; if (TYPEOF(current) == VECSXP) { Rcpp::Shield current_names(vec_names_or_empty(current)); int nc = Rf_length(current); for (int j = 0; j < nc; j++, k++) { SET_VECTOR_ELT(out, k, shared_SEXP(VECTOR_ELT(current, j))); SET_STRING_ELT(out_names, k, STRING_ELT(current_names, j)); } } else { SET_VECTOR_ELT(out, k, current); SET_STRING_ELT(out_names, k, STRING_ELT(dots_names, i)); k++; } Rcpp::checkUserInterrupt(); } // infer the classes and extra info (groups, etc ) from the first (#1692) if (Rf_inherits(first, "data.frame")) { dplyr::copy_most_attributes(out, first); } else { dplyr::set_class(out, dplyr::NaturalDataFrame::classes()); } Rf_namesgets(out, out_names); dplyr::set_rownames(out, nrows); return out; } // [[Rcpp::export(rng = false)]] SEXP combine_all(Rcpp::List data) { int nv = data.size(); // get the size of the output int n = 0; for (int i = 0; i < nv; i++) { n += Rf_length(data[i]); } // go to the first non NULL int i = 0; for (; i < nv; i++) { if (!Rf_isNull(data[i])) break; } if (i == nv) return Rcpp::LogicalVector(); // collect boost::scoped_ptr coll(dplyr::collecter(data[i], n)); int k = Rf_length(data[i]); coll->collect(NaturalSlicingIndex(k), data[i]); i++; for (; i < nv; i++) { SEXP current = data[i]; if (Rf_isNull(current)) continue; int n_current = Rf_length(current); if (coll->compatible(current)) { coll->collect(OffsetSlicingIndex(k, n_current), current); } else if (coll->can_promote(current)) { dplyr::Collecter* new_coll = promote_collecter(current, n, coll.get()); new_coll->collect(OffsetSlicingIndex(k, n_current), current); new_coll->collect(NaturalSlicingIndex(k), coll->get()); coll.reset(new_coll); } else { dplyr::bad_pos_arg(i + 1, "can't be converted from {source_type} to {target_type}", Rcpp::_["source_type"] = dplyr::get_single_class(current), Rcpp::_["target_type"] = dplyr::get_single_class(coll->get())); } k += n_current; } return coll->get(); } dplyr/src/Makevars0000644000176200001440000000035413614573562013705 0ustar liggesusers# Disable long types from C99 or CPP11 extensions PKG_CPPFLAGS = -I../inst/include -DRCPP_DEFAULT_INCLUDE_CALL=false -DCOMPILING_DPLYR -DRCPP_USING_UTF8_ERROR_STRING -DRCPP_USE_UNWIND_PROTECT -DBOOST_NO_AUTO_PTR ${DPLYR_COMPILER_FLAGS} dplyr/src/address.cpp0000644000176200001440000000422113614573562014337 0ustar liggesusers#include "pch.h" #include #include #include #include namespace dplyr { const char* address(SEXP x) { static char buffer[20]; snprintf(buffer, 20, "%p", reinterpret_cast(x)); return (const char*)buffer; } } // [[Rcpp::export(rng = false)]] Rcpp::CharacterVector loc(SEXP data) { return Rf_mkString(dplyr::address(data)); } // [[Rcpp::export(rng = false)]] Rcpp::CharacterVector dfloc(Rcpp::List df) { int n = df.size(); Rcpp::CharacterVector pointers(n); for (int i = 0; i < n; i++) { pointers[i] = dplyr::address(df[i]); } dplyr::copy_attrib(pointers, df, dplyr::symbols::names); return pointers; } // [[Rcpp::export(rng = false)]] Rcpp::CharacterVector plfloc(Rcpp::Pairlist data) { int n = data.size(); Rcpp::CharacterVector pointers(n), names(n); SEXP p = data; int i = 0; while (! Rf_isNull(p)) { pointers[i] = dplyr::address(CAR(p)); names[i] = PRINTNAME(TAG(p)); p = CDR(p); i++; } Rf_namesgets(pointers, names); return pointers; } // [[Rcpp::export(rng = false)]] Rcpp::CharacterVector strings_addresses(Rcpp::CharacterVector s) { static char buffer[20]; int n = s.size(); Rcpp::CharacterVector res(n); for (int i = 0; i < n; i++) { SEXP x = s[i]; snprintf(buffer, 20, "%p", reinterpret_cast(x)); res[i] = buffer; } Rf_namesgets(res, s); return res; } //' Enable internal logging //' //' Log entries, depending on the log level, will be printed to the standard //' error stream. //' //' @param log_level A character value, one of "WARN", "INFO", "DEBUG", "VERB", //' or "NONE". //' //' @keywords internal // [[Rcpp::export(rng = false)]] void init_logging(const std::string& log_level) { plog::init_r(log_level); } // [[Rcpp::export(rng = false)]] bool is_maybe_shared(SEXP env, SEXP name) { SEXP x = Rf_eval(name, env); return MAYBE_SHARED(x); } // [[Rcpp::export(rng = false)]] Rcpp::LogicalVector maybe_shared_columns(SEXP df) { int n = Rf_length(df); Rcpp::LogicalVector res(Rcpp::no_init(n)); for (int i = 0; i < n; i++) { res[i] = MAYBE_SHARED(VECTOR_ELT(df, i)); } return res; } dplyr/src/arrange.cpp0000644000176200001440000000667213614573562014345 0ustar liggesusers#include "pch.h" #include #include #include #include #include #include #include #include #include #include namespace dplyr { int64_t comparisons_int64::NA_INT64 = std::numeric_limits::min(); template SEXP arrange_template(const SlicedTibble& gdf, const QuosureList& quosures, SEXP frame) { const Rcpp::DataFrame& data = gdf.data(); if (data.size() == 0 || data.nrows() == 0) return data; int nargs = quosures.size(); if (nargs == 0) return data; check_valid_colnames(data); assert_all_allow_list(data); Rcpp::List variables(nargs); Rcpp::LogicalVector ascending(nargs); NaturalDataFrame ndf(data); DataMask mask(ndf); NaturalSlicingIndex indices_all(gdf.nrows()); for (int i = 0; i < nargs; i++) { const NamedQuosure& named_quosure = quosures[i]; SEXP expr = named_quosure.expr(); bool is_desc = TYPEOF(expr) == LANGSXP && symbols::desc == CAR(expr); expr = is_desc ? CADR(expr) : expr ; Rcpp::RObject v(R_NilValue); // if expr is a symbol from the data, just use it if (TYPEOF(expr) == SYMSXP) { const ColumnBinding* binding = mask.maybe_get_subset_binding(CHAR(PRINTNAME(expr))); if (binding) { v = binding->get_data(); } } // otherwise need to evaluate in the data mask mask.setup(); if (v.isNULL()) { if (is_desc) { // we need a new quosure that peels off `desc` from the original // quosure, and uses the same environment Quosure quo(PROTECT(rlang::quo_set_expr(named_quosure.get(), expr))); v = mask.eval(quo, indices_all); UNPROTECT(1); } else { // just use the original quosure v = mask.eval(named_quosure.get(), indices_all); } } if (!allow_list(v)) { Rcpp::stop("cannot arrange column of class '%s' at position %d", get_single_class(v), i + 1); } if (Rf_inherits(v, "data.frame")) { bad_pos_arg(i + 1, "is of unsupported type data.frame"); } else if (Rf_isMatrix(v)) { bad_pos_arg(i + 1, "is of unsupported type matrix"); } else { if (Rf_length(v) != data.nrows()) { Rcpp::stop("incorrect size (%d) at position %d, expecting : %d", Rf_length(v), i + 1, data.nrows()); } } variables[i] = v; ascending[i] = !is_desc; } Rf_namesgets(variables, quosures.names()); OrderVisitors o(variables, ascending, nargs); Rcpp::IntegerVector one_based_index = o.apply(); Rcpp::List res = DataFrameSubsetVisitors(data, frame).subset_all(one_based_index); // let the grouping class organise the rest (the groups attribute etc ...) return SlicedTibble(res, gdf).data(); } } // [[Rcpp::export(rng = false)]] SEXP arrange_impl(Rcpp::DataFrame df, dplyr::QuosureList quosures, SEXP frame) { if (Rcpp::is(df)) { return dplyr::arrange_template(dplyr::RowwiseDataFrame(df), quosures, frame); } else if (Rcpp::is(df)) { return dplyr::arrange_template(dplyr::GroupedDataFrame(df), quosures, frame); } else { return dplyr::arrange_template(dplyr::NaturalDataFrame(df), quosures, frame); } } dplyr/src/Makevars.win0000644000176200001440000000027213614573562014500 0ustar liggesusersPKG_CPPFLAGS = -I../inst/include -DRCPP_DEFAULT_INCLUDE_CALL=false -DCOMPILING_DPLYR -DRCPP_USING_UTF8_ERROR_STRING -DRCPP_USE_UNWIND_PROTECT -DBOOST_NO_AUTO_PTR ${DPLYR_COMPILER_FLAGS} dplyr/src/utils.cpp0000644000176200001440000002210613614573562014054 0ustar liggesusers#include "pch.h" #include #include #include #include #include #include #include #include SEXP child_env(SEXP parent) { Rcpp::Shield call(Rf_lang3(dplyr::symbols::new_env, Rf_ScalarLogical(TRUE), parent)); return Rf_eval(call, R_BaseEnv); } // [[Rcpp::export(rng = false)]] void check_valid_names(const Rcpp::CharacterVector& names, bool warn_only = false) { R_xlen_t n = XLENGTH(names); std::vector which_na; which_na.reserve(n); for (int i = 0; i < n; ++i) { if (STRING_ELT(names, i) == R_NaString) { which_na.push_back(i + 1); } } if (which_na.size() > 0) { dplyr::SymbolVector which_na_symbols(Rcpp::wrap(which_na)); Rcpp::String msg = msg_bad_cols(which_na_symbols, "cannot have NA as name"); if (warn_only) Rcpp::warning(msg.get_cstring()); else Rcpp::stop(msg.get_cstring()); } Rcpp::LogicalVector dup(duplicated(names)); if (any(dup).is_true()) { Rcpp::String msg = msg_bad_cols(dplyr::SymbolVector(static_cast(names[dup])), "must have a unique name"); if (warn_only) Rcpp::warning(msg.get_cstring()); else Rcpp::stop(msg.get_cstring()); } } // Need forwarder to avoid compilation warning for default argument void check_valid_colnames(const Rcpp::DataFrame& df, bool warn_only) { Rcpp::Shield names(vec_names_or_empty(df)); check_valid_names((SEXP)names, warn_only); } int check_range_one_based(int x, int max) { // Also covers NA if (x <= 0 || x > max) { Rcpp::stop("Index out of range"); } return x; } // [[Rcpp::export(rng = false)]] void assert_all_allow_list(const Rcpp::DataFrame& data) { // checking variables are on the allow list int nc = data.size(); for (int i = 0; i < nc; i++) { if (!dplyr::allow_list(data[i])) { dplyr::SymbolVector names(Rf_getAttrib(data, dplyr::symbols::names)); const dplyr::SymbolString& name_i = names[i]; SEXP v = data[i]; SEXP klass = Rf_getAttrib(v, R_ClassSymbol); if (!Rf_isNull(klass)) { bad_col(name_i, "is of unsupported class {type}", Rcpp::_["type"] = dplyr::get_single_class(v)); } else { bad_col(name_i, "is of unsupported type {type}", Rcpp::_["type"] = Rf_type2char(TYPEOF(v))); } } } } SEXP shared_SEXP(SEXP x) { MARK_NOT_MUTABLE(x); return x; } SEXP shallow_copy(const Rcpp::List& data) { int n = data.size(); Rcpp::List out(n); for (int i = 0; i < n; i++) { out[i] = shared_SEXP(data[i]); } copy_attributes(out, data); return out; } SEXP pairlist_shallow_copy(SEXP p) { Rcpp::Shield attr(Rf_cons(CAR(p), R_NilValue)); SEXP q = attr; SET_TAG(q, TAG(p)); p = CDR(p); while (!Rf_isNull(p)) { Rcpp::Shield s(Rf_cons(CAR(p), R_NilValue)); SETCDR(q, s); q = CDR(q); SET_TAG(q, TAG(p)); p = CDR(p); } return attr; } void copy_only_attributes(SEXP out, SEXP data) { SEXP att = ATTRIB(data); const bool has_attributes = !Rf_isNull(att); if (has_attributes) { LOG_VERBOSE << "copying attributes: " << Rcpp::CharacterVector(Rf_getAttrib(Rcpp::List(att), dplyr::symbols::names)); SET_ATTRIB(out, pairlist_shallow_copy(ATTRIB(data))); } } void copy_attributes(SEXP out, SEXP data) { copy_only_attributes(out, data); SET_OBJECT(out, OBJECT(data)); if (IS_S4_OBJECT(data)) SET_S4_OBJECT(out); } SEXP null_if_empty(SEXP x) { if (Rf_length(x)) return x; else return R_NilValue; } namespace dplyr { std::string get_single_class(SEXP x) { SEXP klass = Rf_getAttrib(x, R_ClassSymbol); if (!Rf_isNull(klass)) { Rcpp::CharacterVector classes(klass); return collapse_utf8(classes, "/"); } if (Rf_isMatrix(x)) { return "matrix"; } switch (TYPEOF(x)) { case RAWSXP: return "raw"; case INTSXP: return "integer"; case REALSXP : return "numeric"; case LGLSXP: return "logical"; case STRSXP: return "character"; case CPLXSXP: return "complex"; case VECSXP: return "list"; default: break; } // just call R to deal with other cases Rcpp::RObject class_call(Rf_lang2(R_ClassSymbol, x)); klass = Rf_eval(class_call, R_GlobalEnv); return CHAR(STRING_ELT(klass, 0)); } Rcpp::CharacterVector default_chars(SEXP x, R_xlen_t len) { if (Rf_isNull(x)) return Rcpp::CharacterVector(len); return x; } Rcpp::CharacterVector get_class(SEXP x) { SEXP class_attr = Rf_getAttrib(x, R_ClassSymbol); return default_chars(class_attr, 0); } void copy_attrib(SEXP out, SEXP origin, SEXP symbol) { Rf_setAttrib(out, symbol, Rcpp::Shield(Rf_getAttrib(origin, symbol))); } void copy_class(SEXP out, SEXP origin) { copy_attrib(out, origin, R_ClassSymbol); } void copy_names(SEXP out, SEXP origin) { copy_attrib(out, origin, R_NamesSymbol); } SEXP set_class(SEXP x, const Rcpp::CharacterVector& class_) { SEXP class_attr = class_.length() == 0 ? R_NilValue : (SEXP)class_; return Rf_setAttrib(x, R_ClassSymbol, class_attr); } Rcpp::CharacterVector get_levels(SEXP x) { SEXP levels_attr = Rf_getAttrib(x, R_LevelsSymbol); return default_chars(levels_attr, 0); } SEXP set_levels(SEXP x, const Rcpp::CharacterVector& levels) { return Rf_setAttrib(x, R_LevelsSymbol, levels); } bool same_levels(SEXP left, SEXP right) { return character_vector_equal(get_levels(left), get_levels(right)); } SEXP list_as_chr(SEXP x) { int n = Rf_length(x); Rcpp::CharacterVector chr(n); for (int i = 0; i != n; ++i) { SEXP elt = VECTOR_ELT(x, i); switch (TYPEOF(elt)) { case STRSXP: if (Rf_length(chr) == 1) { chr[i] = elt; continue; } break; case SYMSXP: chr[i] = PRINTNAME(elt); continue; default: break; } Rcpp::stop("corrupt grouped data frame"); } return chr; } bool character_vector_equal(const Rcpp::CharacterVector& x, const Rcpp::CharacterVector& y) { if ((SEXP)x == (SEXP)y) return true; if (x.length() != y.length()) return false; for (R_xlen_t i = 0; i < x.length(); ++i) { SEXP xi = x[i]; SEXP yi = y[i]; // Ideally we'd use Rf_Seql(), but this is not exported. if (Rf_NonNullStringMatch(xi, yi)) continue; if (xi == NA_STRING && yi == NA_STRING) continue; if (xi == NA_STRING || yi == NA_STRING) return false; if (CHAR(xi)[0] == 0 && CHAR(yi)[0] == 0) continue; return false; } return true; } } bool is_vector(SEXP x) { switch (TYPEOF(x)) { case LGLSXP: case INTSXP: case REALSXP: case CPLXSXP: case STRSXP: case RAWSXP: case VECSXP: return true; default: return false; } } bool is_atomic(SEXP x) { switch (TYPEOF(x)) { case LGLSXP: case INTSXP: case REALSXP: case CPLXSXP: case STRSXP: case RAWSXP: return true; default: return false; } } SEXP vec_names(SEXP x) { return Rf_getAttrib(x, R_NamesSymbol); } SEXP vec_names_or_empty(SEXP x) { SEXP nms = Rf_getAttrib(x, R_NamesSymbol); if (Rf_isNull(nms)) { return Rf_allocVector(STRSXP, LENGTH(x)); } return nms; } bool is_str_empty(SEXP str) { const char* c_str = CHAR(str); return strcmp(c_str, "") == 0; } bool has_name_at(SEXP x, R_len_t i) { SEXP nms = vec_names(x); return TYPEOF(nms) == STRSXP && !is_str_empty(STRING_ELT(nms, i)); } // [[Rcpp::export(rng = false)]] bool is_data_pronoun(SEXP expr) { if (TYPEOF(expr) != LANGSXP || Rf_length(expr) != 3) return false; SEXP first = CADR(expr); if (first != dplyr::symbols::dot_data) return false; SEXP second = CADDR(expr); SEXP fun = CAR(expr); // .data$x or .data$"x" if (fun == R_DollarSymbol && (TYPEOF(second) == SYMSXP || TYPEOF(second) == STRSXP)) return true; // .data[["x"]] if (fun == R_Bracket2Symbol && TYPEOF(second) == STRSXP) return true; return false; } // [[Rcpp::export(rng = false)]] bool is_variable_reference(SEXP expr) { // x if (TYPEOF(expr) == SYMSXP) return true; return is_data_pronoun(expr); } // [[Rcpp::export(rng = false)]] bool quo_is_variable_reference(SEXP quo) { return is_variable_reference(CADR(quo)); } // [[Rcpp::export(rng = false)]] bool quo_is_data_pronoun(SEXP quo) { return is_data_pronoun(CADR(quo)); } int get_size(SEXP x) { if (Rf_isMatrix(x)) { return INTEGER(Rf_getAttrib(x, R_DimSymbol))[0]; } else if (Rf_inherits(x, "data.frame")) { return Rcpp::DataFrame(x).nrows(); } else { return Rf_length(x); } } namespace dplyr { namespace lifecycle { void warn_deprecated(const std::string& s) { static Rcpp::Environment ns_dplyr(Rcpp::Environment::namespace_env("dplyr")); Rcpp::CharacterVector msg(Rcpp::CharacterVector::create(s)); Rcpp::Shield call(Rf_lang2(symbols::warn_deprecated, msg)); Rcpp::Rcpp_eval(call, ns_dplyr); } void signal_soft_deprecated(const std::string& s, SEXP caller_env) { static Rcpp::Environment ns_dplyr(Rcpp::Environment::namespace_env("dplyr")); Rcpp::CharacterVector msg(Rcpp::CharacterVector::create(s)); Rcpp::Shield call(Rf_lang4(symbols::signal_soft_deprecated, msg, msg, caller_env)); Rcpp::Rcpp_eval(call, ns_dplyr); } } } dplyr/src/rlang-export.c0000644000176200001440000000175513614573562015005 0ustar liggesusers#define R_NO_REMAP #include #include #include #if (defined(R_VERSION) && R_VERSION < R_Version(3, 4, 0)) SEXP R_MakeExternalPtrFn(DL_FUNC p, SEXP tag, SEXP prot) { fn_ptr ptr; ptr.fn = p; return R_MakeExternalPtr(ptr.p, tag, prot); } DL_FUNC R_ExternalPtrAddrFn(SEXP s) { fn_ptr ptr; ptr.p = EXTPTR_PTR(s); return ptr.fn; } #endif SEXP rlang_namespace(const char* ns) { SEXP call = PROTECT(Rf_lang2(Rf_install("getNamespace"), PROTECT(Rf_mkString(ns)))); SEXP ns_env = Rf_eval(call, R_BaseEnv); UNPROTECT(2); return ns_env; } void rlang_register_pointer(const char* ns, const char* ptr_name, DL_FUNC fn) { SEXP ptr = PROTECT(R_MakeExternalPtrFn(fn, R_NilValue, R_NilValue)); SEXP ptr_obj = PROTECT(Rf_allocVector(VECSXP, 1)); SET_VECTOR_ELT(ptr_obj, 0, ptr); Rf_setAttrib(ptr_obj, R_ClassSymbol, Rf_mkString("fn_pointer")); Rf_defineVar(Rf_install(ptr_name), ptr_obj, PROTECT(rlang_namespace(ns))); UNPROTECT(3); } dplyr/src/test.cpp0000644000176200001440000001074213614573562013676 0ustar liggesusers#include "pch.h" #include #include #include // [[Rcpp::export(rng = false)]] Rcpp::LogicalVector test_comparisons() { typedef dplyr::comparisons comp; return Rcpp::LogicalVector::create( comp::is_less(1.0, 2.0), !comp::is_less(2.0, 1.0), comp::is_less(NA_REAL, R_NaN), !comp::is_less(R_NaN, NA_REAL), !comp::is_less(NA_REAL, 1.0), !comp::is_less(R_NaN, 1.0), comp::is_less(1.0, NA_REAL), comp::is_less(1.0, R_NaN) ); } // [[Rcpp::export(rng = false)]] Rcpp::List test_matches() { typedef dplyr::join_match int_int_na; typedef dplyr::join_match real_real_na; typedef dplyr::join_match int_real_na; typedef dplyr::join_match real_int_na; typedef dplyr::join_match int_int; typedef dplyr::join_match real_real; typedef dplyr::join_match int_real; typedef dplyr::join_match real_int; return Rcpp::List::create( Rcpp::LogicalVector::create( int_int_na::is_match(1, 1), !int_int_na::is_match(1, 2), !int_int_na::is_match(1, NA_INTEGER), !int_int_na::is_match(NA_INTEGER, 1), int_int_na::is_match(NA_INTEGER, NA_INTEGER), int_int::is_match(1, 1), !int_int::is_match(1, 2), !int_int::is_match(1, NA_INTEGER), !int_int::is_match(NA_INTEGER, 1), !int_int::is_match(NA_INTEGER, NA_INTEGER) ), Rcpp::LogicalVector::create( real_real_na::is_match(1, 1), !real_real_na::is_match(1, 2), !real_real_na::is_match(1, NA_REAL), !real_real_na::is_match(NA_REAL, 1), !real_real_na::is_match(1, R_NaN), !real_real_na::is_match(R_NaN, 1), !real_real_na::is_match(R_NaN, NA_REAL), !real_real_na::is_match(NA_REAL, R_NaN), real_real_na::is_match(NA_REAL, NA_REAL), real_real_na::is_match(R_NaN, R_NaN), real_real::is_match(1, 1), !real_real::is_match(1, 2), !real_real::is_match(1, NA_REAL), !real_real::is_match(NA_REAL, 1), !real_real::is_match(1, R_NaN), !real_real::is_match(R_NaN, 1), !real_real::is_match(R_NaN, NA_REAL), !real_real::is_match(NA_REAL, R_NaN), !real_real::is_match(NA_REAL, NA_REAL), !real_real::is_match(R_NaN, R_NaN) ), Rcpp::LogicalVector::create( int_real_na::is_match(1, 1), !int_real_na::is_match(1, 2), !int_real_na::is_match(1, NA_REAL), !int_real_na::is_match(NA_INTEGER, 1), !int_real_na::is_match(1, R_NaN), !int_real_na::is_match(NA_INTEGER, R_NaN), int_real_na::is_match(NA_INTEGER, NA_REAL), int_real::is_match(1, 1), !int_real::is_match(1, 2), !int_real::is_match(1, NA_REAL), !int_real::is_match(NA_INTEGER, 1), !int_real::is_match(1, R_NaN), !int_real::is_match(NA_INTEGER, R_NaN), !int_real::is_match(NA_INTEGER, NA_REAL) ), Rcpp::LogicalVector::create( real_int_na::is_match(1, 1), !real_int_na::is_match(1, 2), !real_int_na::is_match(1, NA_INTEGER), !real_int_na::is_match(NA_REAL, 1), !real_int_na::is_match(R_NaN, 1), !real_int_na::is_match(R_NaN, NA_INTEGER), real_int_na::is_match(NA_REAL, NA_INTEGER), real_int::is_match(1, 1), !real_int::is_match(1, 2), !real_int::is_match(1, NA_INTEGER), !real_int::is_match(NA_REAL, 1), !real_int::is_match(R_NaN, 1), !real_int::is_match(R_NaN, NA_INTEGER), !real_int::is_match(NA_REAL, NA_INTEGER) ) ); } // [[Rcpp::export(rng = false)]] Rcpp::LogicalVector test_length_wrap() { R_xlen_t small = R_LEN_T_MAX / 2; Rcpp::RObject wrap_small(Rcpp::wrap(small)); #ifdef LONG_VECTOR_SUPPORT R_xlen_t large = (R_xlen_t)(R_LEN_T_MAX * 2.0); R_xlen_t missing = NA_INTEGER; Rcpp::RObject wrap_large(Rcpp::wrap(large)); Rcpp::RObject wrap_missing(Rcpp::wrap(missing)); return Rcpp::LogicalVector::create( Rcpp::as(wrap_small) == (double)small, Rcpp::as(wrap_large) == (double)large, Rcpp::as(wrap_missing) == (double)missing ); #else return Rcpp::LogicalVector::create( Rcpp::as(wrap_small) == (double)small ); #endif } dplyr/src/pch.h0000644000176200001440000000002213614573562013124 0ustar liggesusers#include dplyr/src/filter.cpp0000644000176200001440000003251213614573562014203 0ustar liggesusers#include "pch.h" #include #include #include #include #include #include #include #include #include #include #include namespace dplyr { inline void check_result_length(const Rcpp::LogicalVector& test, int n) { if (test.size() != n) { Rcpp::stop("Result must have length %d, not %d", n, test.size()); } } inline SEXP check_result_lgl_type(SEXP tmp) { if (TYPEOF(tmp) != LGLSXP) { bad_pos_arg(2, "filter condition does not evaluate to a logical vector"); } return tmp; } // class to collect indices for each group in a filter() template class GroupFilterIndices { typedef typename SlicedTibble::slicing_index slicing_index; const SlicedTibble& tbl; int n; Rcpp::LogicalVector test; std::vector groups; int ngroups; std::vector new_sizes; int k; typename SlicedTibble::group_iterator git; public: Rcpp::IntegerVector indices; Rcpp::List rows; GroupFilterIndices(const SlicedTibble& tbl_) : tbl(tbl_), n(tbl.data().nrow()), test(n), groups(n), ngroups(tbl.ngroups()), new_sizes(ngroups), k(0), git(tbl.group_begin()), rows(ngroups) {} // set the group i to be empty void empty_group(int i) { typename SlicedTibble::slicing_index idx = *git; int ng = idx.size(); for (int j = 0; j < ng; j++) { test[idx[j]] = FALSE; groups[idx[j]] = i; } new_sizes[i] = 0; ++git; } // the group i contains all the data from the original void add_dense_group(int i) { typename SlicedTibble::slicing_index idx = *git; int ng = idx.size(); for (int j = 0; j < ng; j++) { test[idx[j]] = TRUE; groups[idx[j]] = i; } k += new_sizes[i] = ng; ++git; } // the group i contains some data, available in g_test void add_group_lgl(int i, const Rcpp::LogicalVector& g_test) { typename SlicedTibble::slicing_index idx = *git; int ng = idx.size(); const int* p_test = g_test.begin(); int new_size = 0; for (int j = 0; j < ng; j++, ++p_test) { new_size += *p_test == TRUE; test[idx[j]] = *p_test == TRUE; groups[idx[j]] = i; } k += new_sizes[i] = new_size; ++git; } // the total number of rows // only makes sense when the object is fully trained inline int size() const { return k; } // once this has been trained on all groups // this materialize indices and rows void process() { indices = Rcpp::IntegerVector(Rcpp::no_init(k)); std::vector p_rows(ngroups); for (int i = 0; i < ngroups; i++) { rows[i] = Rf_allocVector(INTSXP, new_sizes[i]); p_rows[i] = INTEGER(rows[i]); } // process test and groups, fill indices and rows int* p_test = LOGICAL(test); std::vector rows_offset(ngroups, 0); int i = 0; for (int j = 0; j < n; j++, ++p_test) { if (*p_test == 1) { // update rows int group = groups[j]; p_rows[group][rows_offset[group]++] = i + 1; // update indices indices[i] = j + 1; i++; } } } }; // template class to rebuild the attributes // in the general case there is nothing to do template class FilterTibbleRebuilder { public: FilterTibbleRebuilder(const IndexCollector& index, const SlicedTibble& data) {} void reconstruct(Rcpp::List& out) {} }; // specific case for GroupedDataFrame, we need to take care of `groups` template class FilterTibbleRebuilder { public: FilterTibbleRebuilder(const IndexCollector& index_, const GroupedDataFrame& data_) : index(index_), data(data_) {} void reconstruct(Rcpp::List& out) { GroupedDataFrame::set_groups(out, update_groups(data.group_data(), index.rows)); } private: SEXP update_groups(Rcpp::DataFrame old, Rcpp::List indices) { int nc = old.size(); Rcpp::List groups(nc); copy_most_attributes(groups, old); copy_names(groups, old); // labels for (int i = 0; i < nc - 1; i++) groups[i] = old[i]; // indices groups[nc - 1] = indices; return groups; } const IndexCollector& index; const GroupedDataFrame& data; }; template SEXP structure_filter(const SlicedTibble& gdf, const IndexCollector& group_indices, SEXP frame) { const Rcpp::DataFrame& data = gdf.data(); // create the result data frame int nc = data.size(); Rcpp::List out(nc); // this is shared by all types of SlicedTibble copy_most_attributes(out, data); copy_class(out, data); copy_names(out, data); set_rownames(out, group_indices.size()); // retrieve the 1-based indices vector const Rcpp::IntegerVector& idx = group_indices.indices; // extract each column with column_subset for (int i = 0; i < nc; i++) { out[i] = column_subset(data[i], idx, frame); } // set the specific attributes // currently this only does anything for SlicedTibble = GroupedDataFrame FilterTibbleRebuilder(group_indices, gdf).reconstruct(out); return out; } template SEXP filter_template(const SlicedTibble& gdf, const Quosure& quo) { typedef typename SlicedTibble::group_iterator GroupIterator; typedef typename SlicedTibble::slicing_index slicing_index; // Proxy call_proxy(quo.expr(), gdf, quo.env()) ; GroupIterator git = gdf.group_begin(); DataMask mask(gdf) ; int ngroups = gdf.ngroups() ; // tracking the indices for each group GroupFilterIndices group_indices(gdf); // traverse each group and fill `group_indices` mask.setup(); for (int i = 0; i < ngroups; i++, ++git) { const slicing_index& indices = *git; int chunk_size = indices.size(); // empty group size. no need to evaluate the expression if (chunk_size == 0) { group_indices.empty_group(i) ; continue; } // the result of the expression in the group Rcpp::LogicalVector g_test = check_result_lgl_type(mask.eval(quo, indices)); if (g_test.size() == 1) { // we get length 1 so either we have an empty group, or a dense group, i.e. // a group that has all the rows from the original data if (g_test[0] == TRUE) { group_indices.add_dense_group(i) ; } else { group_indices.empty_group(i); } } else { // any other size, so we check that it is consistent with the group size check_result_length(g_test, chunk_size); group_indices.add_group_lgl(i, g_test); } } group_indices.process(); Rcpp::Shield env(quo.env()); return structure_filter(gdf, group_indices, env) ; } } // [[Rcpp::export(rng = false)]] SEXP filter_impl(Rcpp::DataFrame df, dplyr::Quosure quo) { if (df.nrows() == 0 || Rf_isNull(df)) { return df; } check_valid_colnames(df); assert_all_allow_list(df); if (Rcpp::is(df)) { return dplyr::filter_template(dplyr::GroupedDataFrame(df), quo); } else if (Rcpp::is(df)) { return dplyr::filter_template(dplyr::RowwiseDataFrame(df), quo); } else { return dplyr::filter_template(dplyr::NaturalDataFrame(df), quo); } } // ------------------------------------------------- slice() namespace dplyr { inline bool all_lgl_na(SEXP lgl) { R_xlen_t n = XLENGTH(lgl); int* p = LOGICAL(lgl); for (R_xlen_t i = 0; i < n; i++) { if (*p != NA_LOGICAL) { return false; } } return true; } inline void check_slice_result(SEXP tmp) { switch (TYPEOF(tmp)) { case INTSXP: case REALSXP: break; case LGLSXP: if (all_lgl_na(tmp)) break; default: Rcpp::stop("slice condition does not evaluate to an integer or numeric vector. "); } } struct SlicePositivePredicate { int max; SlicePositivePredicate(int max_) : max(max_) {} inline bool operator()(int i) const { return i > 0 && i <= max ; } }; struct SliceNegativePredicate { int min; SliceNegativePredicate(int max_) : min(-max_) {} inline bool operator()(int i) const { return i >= min && i < 0; } }; class CountIndices { public: CountIndices(int nr_, Rcpp::IntegerVector test_) : nr(nr_), test(test_), n_pos(0), n_neg(0) { for (int j = 0; j < test.size(); j++) { int i = test[j]; if (i > 0 && i <= nr) { n_pos++; } else if (i < 0 && i >= -nr) { n_neg++; } } if (n_neg > 0 && n_pos > 0) { Rcpp::stop("Indices must be either all positive or all negative, not a mix of both. Found %d positive indices and %d negative indices", n_pos, n_neg); } } inline bool is_positive() const { return n_pos > 0; } inline bool is_negative() const { return n_neg > 0; } inline int get_n_positive() const { return n_pos; } inline int get_n_negative() const { return n_neg; } private: int nr; Rcpp::IntegerVector test; int n_pos; int n_neg; }; template class GroupSliceIndices { typedef typename SlicedTibble::slicing_index slicing_index; const SlicedTibble& tbl; int n; std::vector slice_indices; int k; int ngroups; std::vector new_sizes; typename SlicedTibble::group_iterator git; public: Rcpp::IntegerVector indices; Rcpp::List rows; GroupSliceIndices(const SlicedTibble& tbl_) : tbl(tbl_), n(tbl.data().nrow()), slice_indices(), k(0), ngroups(tbl.ngroups()), git(tbl.group_begin()), rows(ngroups) { // reserve enough space for positions and groups for most cases // i.e. in most cases we need less than n slice_indices.reserve(n); } // set the group i to be empty void empty_group(int i) { rows[i] = Rf_allocVector(INTSXP, 0); ++git; } void add_group_slice_positive(int i, const Rcpp::IntegerVector& g_idx) { slicing_index old_indices = *git; int ng = g_idx.size(); SlicePositivePredicate pred(old_indices.size()); int old_k = k; for (int j = 0; j < ng; j++) { if (pred(g_idx[j])) { slice_indices.push_back(old_indices[g_idx[j] - 1] + 1); k++; } } if (old_k == k) { rows[i] = Rf_allocVector(INTSXP, 0); } else { rows[i] = Rcpp::IntegerVectorView(Rcpp::seq(old_k + 1, k)); } ++git; } void add_group_slice_negative(int i, const Rcpp::IntegerVector& g_idx) { slicing_index old_indices = *git; SliceNegativePredicate pred(old_indices.size()); Rcpp::LogicalVector test_lgl(old_indices.size(), TRUE); for (int j = 0; j < g_idx.size(); j++) { int idx = g_idx[j]; if (pred(idx)) { test_lgl[-idx - 1] = FALSE; } } int ng = std::count(test_lgl.begin(), test_lgl.end(), TRUE); if (ng == 0) { empty_group(i); } else { int old_k = k; Rcpp::IntegerVector test(ng); for (int j = 0; j < test_lgl.size(); j++) { if (test_lgl[j] == TRUE) { slice_indices.push_back(old_indices[j] + 1); k++; } } if (old_k == k) { rows[i] = Rf_allocVector(INTSXP, 0); } else { rows[i] = Rcpp::IntegerVectorView(Rcpp::seq(old_k + 1, k)); } ++git; } } // the total number of rows // only makes sense when the object is fully trained inline int size() const { return k; } // once this has been trained on all groups // this materialize indices and rows void process() { indices = Rcpp::wrap(slice_indices); } }; template Rcpp::DataFrame slice_template(const SlicedTibble& gdf, const dplyr::Quosure& quo) { typedef typename SlicedTibble::group_iterator group_iterator; typedef typename SlicedTibble::slicing_index slicing_index ; DataMask mask(gdf); const Rcpp::DataFrame& data = gdf.data() ; int ngroups = gdf.ngroups() ; SymbolVector names(Rf_getAttrib(data, symbols::names)); GroupSliceIndices group_indices(gdf); group_iterator git = gdf.group_begin(); mask.setup(); for (int i = 0; i < ngroups; i++, ++git) { const slicing_index& indices = *git; // empty group size. no need to evaluate the expression if (indices.size() == 0) { group_indices.empty_group(i) ; continue; } // evaluate the expression in the data mask Rcpp::Shield res(mask.eval(quo, indices)); check_slice_result(res); Rcpp::IntegerVector g_positions(res); // scan the results to see if all >= 1 or all <= -1 CountIndices counter(indices.size(), g_positions); if (counter.is_positive()) { group_indices.add_group_slice_positive(i, g_positions); } else if (counter.is_negative()) { group_indices.add_group_slice_negative(i, g_positions); } else { group_indices.empty_group(i); } } group_indices.process(); Rcpp::Shield quo_env(quo.env()); return structure_filter(gdf, group_indices, quo_env); } } // [[Rcpp::export(rng = false)]] SEXP slice_impl(Rcpp::DataFrame df, dplyr::Quosure quosure) { if (Rcpp::is(df)) { return dplyr::slice_template(dplyr::GroupedDataFrame(df), quosure); } else { return dplyr::slice_template(dplyr::NaturalDataFrame(df), quosure); } } dplyr/src/api.cpp0000644000176200001440000001515713614573562013475 0ustar liggesusers#include "pch.h" #include #include #include #include #include #include #include #include #include namespace dplyr { DataFrameVisitors::DataFrameVisitors(const Rcpp::DataFrame& data_) : data(data_), visitors(), visitor_names(vec_names_or_empty(data)) { for (int i = 0; i < data.size(); i++) { VectorVisitor* v = visitor(data[i]); visitors.push_back(v); } } DataFrameVisitors::DataFrameVisitors(const Rcpp::DataFrame& data_, const SymbolVector& names) : data(data_), visitors(), visitor_names(names) { int n = names.size(); Rcpp::Shield data_names(vec_names_or_empty(data)); Rcpp::Shield indices(r_match(names.get_vector(), data_names)); int* p_indices = INTEGER(indices); for (int i = 0; i < n; i++) { if (p_indices[i] == NA_INTEGER) { bad_col(names[i], "is unknown"); } SEXP column = data[p_indices[i] - 1]; visitors.push_back(visitor(column)); } } DataFrameVisitors::DataFrameVisitors(const Rcpp::DataFrame& data_, const Rcpp::IntegerVector& indices) : data(data_), visitors(), visitor_names() { Rcpp::Shield data_names(vec_names_or_empty(data)); int n = indices.size(); for (int i = 0; i < n; i++) { int pos = check_range_one_based(indices[i], data.size()); VectorVisitor* v = visitor(data[pos - 1]); visitors.push_back(v); visitor_names.push_back(STRING_ELT(data_names, pos - 1)); } } DataFrameVisitors::DataFrameVisitors(const Rcpp::DataFrame& data_, int n) : data(data_), visitors(n), visitor_names(n) { Rcpp::Shield data_names(vec_names_or_empty(data)); for (int i = 0; i < n; i++) { visitors[i] = visitor(data[i]); visitor_names.set(i, STRING_ELT(data_names, i)); } } DataFrameJoinVisitors::DataFrameJoinVisitors(const Rcpp::DataFrame& left_, const Rcpp::DataFrame& right_, const SymbolVector& names_left, const SymbolVector& names_right, bool warn_, bool na_match) : left(left_), right(right_), visitor_names_left(names_left), visitor_names_right(names_right), visitors(names_left.size()), warn(warn_) { Rcpp::Shield left_names(RCPP_GET_NAMES(left)); Rcpp::Shield right_names(RCPP_GET_NAMES(right)); Rcpp::Shield indices_left(names_left.match_in_table((SEXP)left_names)); Rcpp::Shield indices_right(names_right.match_in_table((SEXP)right_names)); int* p_indices_left = INTEGER(indices_left); int* p_indices_right = INTEGER(indices_right); R_xlen_t nvisitors = XLENGTH(indices_left); if (XLENGTH(indices_right) != nvisitors) { Rcpp::stop("Different size of join column index vectors"); } for (int i = 0; i < nvisitors; i++) { const SymbolString& name_left = names_left[i]; const SymbolString& name_right = names_right[i]; if (p_indices_left[i] == NA_INTEGER) { Rcpp::stop("'%s' column not found in lhs, cannot join", name_left.get_utf8_cstring()); } if (p_indices_right[i] == NA_INTEGER) { Rcpp::stop("'%s' column not found in rhs, cannot join", name_right.get_utf8_cstring()); } visitors[i] = join_visitor( Column(left[p_indices_left[i] - 1], name_left), Column(right[p_indices_right[i] - 1], name_right), warn, na_match ); } } DataFrameJoinVisitors::DataFrameJoinVisitors( const Rcpp::DataFrame& left_, const Rcpp::DataFrame& right_, const Rcpp::IntegerVector& indices_left, const Rcpp::IntegerVector& indices_right, bool warn_, bool na_match ) : left(left_), right(right_), visitor_names_left(), visitor_names_right(), visitors(indices_left.size()), warn(warn_) { if (indices_right.size() != size()) { Rcpp::stop("Different size of join column index vectors"); } SymbolVector left_names(Rf_getAttrib(left, symbols::names)); SymbolVector right_names(Rf_getAttrib(right, symbols::names)); for (int i = 0; i < size(); i++) { const int index_left = check_range_one_based(indices_left[i], left.size()); const int index_right = check_range_one_based(indices_right[i], right.size()); const SymbolString& name_left = left_names[index_left - 1]; const SymbolString& name_right = right_names[index_right - 1]; visitors[i] = join_visitor( Column(left[index_left - 1], name_left), Column(right[index_right - 1], name_right), warn, na_match ); visitor_names_left.push_back(name_left); visitor_names_right.push_back(name_right); } } JoinVisitor* DataFrameJoinVisitors::get(int k) const { return visitors[k]; } JoinVisitor* DataFrameJoinVisitors::get(const SymbolString& name) const { for (int i = 0; i < size(); i++) { if (name == visitor_names_left[i]) return get(i); } Rcpp::stop("visitor not found for name '%s' ", name.get_utf8_cstring()); } int DataFrameJoinVisitors::size() const { return visitors.size(); } CharacterVectorOrderer::CharacterVectorOrderer(const Rcpp::CharacterVector& data) : orders(Rcpp::no_init(data.size())) { int n = data.size(); if (n == 0) return; dplyr_hash_set set(n); // 1 - gather unique SEXP pointers from data SEXP* p_data = Rcpp::internal::r_vector_start(data); SEXP previous = *p_data++; set.insert(previous); for (int i = 1; i < n; i++, p_data++) { SEXP s = *p_data; // we've just seen this string, keep going if (s == previous) continue; // is this string in the set already set.insert(s); previous = s; } // retrieve unique strings from the set int n_uniques = set.size(); LOG_VERBOSE << "Sorting " << n_uniques << " unique character elements"; Rcpp::CharacterVector uniques(set.begin(), set.end()); static Rcpp::Function sort("sort", R_BaseEnv); Rcpp::Language call(sort, uniques); Rcpp::Shield s_uniques(call.fast_eval()); // order the uniques with a callback to R Rcpp::Shield o(r_match(uniques, s_uniques)); int* p_o = INTEGER(o); // combine uniques and o into a hash map for fast retrieval dplyr_hash_map map(n_uniques); for (int i = 0; i < n_uniques; i++) { map.insert(std::make_pair(uniques[i], p_o[i])); } // grab min ranks p_data = Rcpp::internal::r_vector_start(data); previous = *p_data++; int o_pos; orders[0] = o_pos = map.find(previous)->second; for (int i = 1; i < n; ++i, ++p_data) { SEXP s = *p_data; if (s == previous) { orders[i] = o_pos; continue; } previous = s; orders[i] = o_pos = map.find(s)->second; } } } dplyr/src/between.cpp0000644000176200001440000000311013614573562014337 0ustar liggesusers#include "pch.h" //' Do values in a numeric vector fall in specified range? //' //' This is a shortcut for `x >= left & x <= right`, implemented //' efficiently in C++ for local values, and translated to the //' appropriate SQL for remote tables. //' //' @param x A numeric vector of values //' @param left,right Boundary values //' @export //' @examples //' between(1:12, 7, 9) //' //' x <- rnorm(1e2) //' x[between(x, -1, 1)] // [[Rcpp::export(rng = false)]] Rcpp::LogicalVector between(Rcpp::NumericVector x, double left, double right) { int n = x.size(); Rcpp::LogicalVector out(Rcpp::no_init(n)); // Assume users know what they're doing with date/times. In the future // should ensure that left and right are the correct class too. if (!Rf_isNull(Rf_getAttrib(x, R_ClassSymbol)) && !Rf_inherits(x, "Date") && !Rf_inherits(x, "POSIXct")) { Rcpp::warningcall(R_NilValue, "between() called on numeric vector with S3 class"); } if (Rcpp::NumericVector::is_na(left) || Rcpp::NumericVector::is_na(right)) { for (int i = 0; i < n; ++i) out[i] = NA_LOGICAL; return out; } for (int i = 0; i < n; ++i) { if (Rcpp::NumericVector::is_na(x[i])) { out[i] = NA_LOGICAL; } else if ((x[i] >= left) && (x[i] <= right)) { out[i] = true; } else { out[i] = false; } } return out; } /*** R library(microbenchmark) betweenr <- function(x, left, right){ x >= left & x <= right } x <- c(NA, runif(1e4), NA) stopifnot(all.equal(between(x, 0.1, 0.9), betweenr(x, 0.1, 0.9))) microbenchmark( between(x, 0.1, 0.9), betweenr(x, 0.1, 0.9) ) */ dplyr/src/join_exports.cpp0000644000176200001440000003431113614573562015440 0ustar liggesusers#include "pch.h" #include #include #include #include #include #include #include #include #include #include #include #include #include namespace dplyr { Rcpp::DataFrame subset_join(Rcpp::DataFrame x, Rcpp::DataFrame y, const std::vector& indices_x, const std::vector& indices_y, const Rcpp::IntegerVector& by_x, const Rcpp::IntegerVector& by_y, const Rcpp::IntegerVector& aux_x, const Rcpp::IntegerVector& aux_y, Rcpp::CharacterVector classes, SEXP frame) { // construct out object Rcpp::List out(x.ncol() + aux_y.size()); // first the joined columns (all x columns keep their location) DataFrameJoinVisitors join_visitors(x, y, by_x, by_y, true, false); for (int i = 0; i < by_x.size(); i++) { JoinVisitor* v = join_visitors.get(i); out[by_x[i] - 1] = v->subset(indices_x); } // then the auxiliary x columns (all x columns keep their location) DataFrameSubsetVisitors subset_x(DataFrameSelect(x, aux_x), frame); // convert indices_x to 1-based R indices int n_x = indices_x.size(); Rcpp::IntegerVector indices_x_one_based(indices_x.size()); for (int j = 0; j < n_x; j++) { indices_x_one_based[j] = indices_x[j] < 0 ? NA_INTEGER : (indices_x[j] + 1); } // materialize the first few columns for (int i = 0; i < aux_x.size(); i++) { out[aux_x[i] - 1] = subset_x.subset_one(i, indices_x_one_based); } // convert indices_y int n_y = indices_y.size(); Rcpp::IntegerVector indices_y_one_based(indices_y.size()); for (int j = 0; j < n_y; j++) { indices_y_one_based[j] = indices_y[j] < 0 ? NA_INTEGER : (indices_y[j] + 1); } // then the auxiliary y columns (all y columns keep their relative location) DataFrameSubsetVisitors subset_y(DataFrameSelect(y, aux_y), frame); for (int i = 0, k = x.ncol(); i < aux_y.size(); i++, k++) { out[k] = subset_y.subset_one(i, indices_y_one_based); } int nrows = indices_x.size(); set_rownames(out, nrows); set_class(out, classes); return (SEXP)out; } template void push_back(TargetContainer& x, const SourceContainer& y) { x.insert(x.end(), y.begin(), y.end()); } template void push_back_right(TargetContainer& x, const SourceContainer& y) { // x.insert( x.end(), y.begin(), y.end() ); int n = y.size(); for (int i = 0; i < n; i++) { x.push_back(-y[i] - 1); } } template void push_back(Container& x, typename Container::value_type value, int n) { for (int i = 0; i < n; i++) x.push_back(value); } void check_by(const Rcpp::CharacterVector& by) { if (by.size() == 0) bad_arg("by", "must specify variables to join by"); } void check_by(const Rcpp::IntegerVector& by) { if (by.size() == 0) bad_arg("by", "must specify variables to join by"); } } // [[Rcpp::export(rng = false)]] Rcpp::DataFrame semi_join_impl(Rcpp::DataFrame x, Rcpp::DataFrame y, Rcpp::CharacterVector by_x, Rcpp::CharacterVector by_y, bool na_match, SEXP frame) { dplyr::check_by(by_x); typedef dplyr::VisitorSetIndexMap > Map; dplyr::DataFrameJoinVisitors visitors(x, y, dplyr::SymbolVector(by_x), dplyr::SymbolVector(by_y), true, na_match); Map map(visitors); // train the map in terms of x train_push_back(map, x.nrows()); int n_y = y.nrows(); // this will collect indices from rows in x that match rows in y // // allocate a big enough R vector Rcpp::IntegerVector indices(Rcpp::no_init(x.nrows())); int k = 0; for (int i = 0; i < n_y; i++) { // find a row in x that matches row i from y Map::iterator it = map.find(-i - 1); if (it != map.end()) { // collect the indices and remove them from the // map so that they are only found once. const std::vector& zero_based_chunk = it->second; for (size_t j = 0; j < zero_based_chunk.size(); j++, k++) { indices[k] = zero_based_chunk[j] + 1; } map.erase(it); } } // pretend indices is of length k SETLENGTH(indices, k); std::sort(indices.begin(), indices.end()); Rcpp::DataFrame res = dplyr::DataFrameSubsetVisitors(x, frame).subset_all(indices); // stop pretending SETLENGTH(indices, x.nrows()); return res; } // [[Rcpp::export(rng = false)]] Rcpp::DataFrame anti_join_impl(Rcpp::DataFrame x, Rcpp::DataFrame y, Rcpp::CharacterVector by_x, Rcpp::CharacterVector by_y, bool na_match, SEXP frame) { dplyr::check_by(by_x); typedef dplyr::VisitorSetIndexMap > Map; dplyr::DataFrameJoinVisitors visitors(x, y, dplyr::SymbolVector(by_x), dplyr::SymbolVector(by_y), true, na_match); Map map(visitors); int n_x = x.nrows(); // train the map in terms of x train_push_back(map, n_x); // remove the rows in x that match int n_y = y.nrows(); for (int i = 0; i < n_y; i++) { Map::iterator it = map.find(-i - 1); if (it != map.end()) map.erase(it); } // allocate a big enough R vector Rcpp::IntegerVector indices(n_x); int k = 0; for (Map::iterator it = map.begin(); it != map.end(); ++it) { const std::vector& zero_based_chunk = it->second; for (size_t j = 0; j < zero_based_chunk.size(); j++, k++) { indices[k] = zero_based_chunk[j] + 1; } } // pretend length SETLENGTH(indices, k); std::sort(indices.begin(), indices.end()); Rcpp::DataFrame res = dplyr::DataFrameSubsetVisitors(x, frame).subset_all(indices); // stop pretending SETLENGTH(indices, k); return res; } // [[Rcpp::export(rng = false)]] Rcpp::DataFrame inner_join_impl(Rcpp::DataFrame x, Rcpp::DataFrame y, Rcpp::IntegerVector by_x, Rcpp::IntegerVector by_y, Rcpp::IntegerVector aux_x, Rcpp::IntegerVector aux_y, bool na_match, SEXP frame ) { dplyr::check_by(by_x); typedef dplyr::VisitorSetIndexMap > Map; dplyr::DataFrameJoinVisitors visitors(x, y, by_x, by_y, false, na_match); Map map(visitors); int n_x = x.nrows(), n_y = y.nrows(); std::vector indices_x; std::vector indices_y; train_push_back_right(map, n_y); for (int i = 0; i < n_x; i++) { Map::iterator it = map.find(i); if (it != map.end()) { dplyr::push_back_right(indices_y, it->second); dplyr::push_back(indices_x, i, it->second.size()); } } return dplyr::subset_join(x, y, indices_x, indices_y, by_x, by_y, aux_x, aux_y, dplyr::get_class(x), frame ); } // [[Rcpp::export(rng = false)]] Rcpp::List nest_join_impl(Rcpp::DataFrame x, Rcpp::DataFrame y, Rcpp::IntegerVector by_x, Rcpp::IntegerVector by_y, Rcpp::IntegerVector aux_y, Rcpp::String yname, SEXP frame ) { dplyr::check_by(by_x); typedef dplyr::VisitorSetIndexMap > Map; dplyr::DataFrameJoinVisitors visitors(x, y, by_x, by_y, false, true); Map map(visitors); int n_x = x.nrows(), n_y = y.nrows(); dplyr::train_push_back_right(map, n_y); Rcpp::List list_col(n_x); dplyr::DataFrameSubsetVisitors y_subset_visitors(dplyr::DataFrameSelect(y, aux_y), frame); // to deal with the case where multiple rows of x match rows in y dplyr_hash_map resolved_map(y_subset_visitors.size()); // empty integer vector Rcpp::IntegerVector empty(0); for (int i = 0; i < n_x; i++) { // check if the i row of x matches rows in y Map::iterator it = map.find(i); if (it != map.end()) { // then check if we have already seen that match dplyr_hash_map::iterator rit = resolved_map.find(it->first); if (rit == resolved_map.end()) { // first time we see the match, perform the subset const std::vector& indices_negative = it->second; int n = indices_negative.size(); Rcpp::IntegerVector indices_one_based(n); for (int j = 0; j < n; j++) { indices_one_based[j] = -indices_negative[j]; } resolved_map[it->first] = list_col[i] = y_subset_visitors.subset_all(indices_one_based); } else { // we have seen that match already, just lazy duplicate the tibble that is // stored in the resolved map list_col[i] = Rf_lazy_duplicate(rit->second); } } else { list_col[i] = y_subset_visitors.subset_all(empty); } } int ncol_x = x.size(); Rcpp::List out(ncol_x + 1); Rcpp::Shield x_names(Rf_getAttrib(x, dplyr::symbols::names)); Rcpp::Shield new_names(Rf_allocVector(STRSXP, ncol_x + 1)); for (int i = 0; i < ncol_x; i++) { out[i] = x[i]; SET_STRING_ELT(new_names, i, STRING_ELT(x_names, i)); } out[ncol_x] = list_col ; SET_STRING_ELT(new_names, ncol_x, yname.get_sexp()); Rf_namesgets(out, new_names); dplyr::copy_attrib(out, x, R_ClassSymbol); dplyr::copy_attrib(out, x, R_RowNamesSymbol); dplyr::GroupedDataFrame::copy_groups(out, x) ; return out; } // [[Rcpp::export(rng = false)]] Rcpp::DataFrame left_join_impl(Rcpp::DataFrame x, Rcpp::DataFrame y, Rcpp::IntegerVector by_x, Rcpp::IntegerVector by_y, Rcpp::IntegerVector aux_x, Rcpp::IntegerVector aux_y, bool na_match, SEXP frame ) { dplyr::check_by(by_x); typedef dplyr::VisitorSetIndexMap > Map; dplyr::DataFrameJoinVisitors visitors(y, x, by_y, by_x, false, na_match); Map map(visitors); // train the map in terms of y train_push_back(map, y.nrows()); std::vector indices_x; std::vector indices_y; int n_x = x.nrows(); for (int i = 0; i < n_x; i++) { // find a row in y that matches row i in x Map::iterator it = map.find(-i - 1); if (it != map.end()) { dplyr::push_back(indices_y, it->second); dplyr::push_back(indices_x, i, it->second.size()); } else { indices_y.push_back(-1); // mark NA indices_x.push_back(i); } } return dplyr::subset_join(x, y, indices_x, indices_y, by_x, by_y, aux_x, aux_y, dplyr::get_class(x), frame ); } // [[Rcpp::export(rng = false)]] Rcpp::DataFrame right_join_impl(Rcpp::DataFrame x, Rcpp::DataFrame y, Rcpp::IntegerVector by_x, Rcpp::IntegerVector by_y, Rcpp::IntegerVector aux_x, Rcpp::IntegerVector aux_y, bool na_match, SEXP frame ) { dplyr::check_by(by_x); typedef dplyr::VisitorSetIndexMap > Map; dplyr::DataFrameJoinVisitors visitors(x, y, by_x, by_y, false, na_match); Map map(visitors); // train the map in terms of x train_push_back(map, x.nrows()); std::vector indices_x; std::vector indices_y; int n_y = y.nrows(); for (int i = 0; i < n_y; i++) { // find a row in y that matches row i in x Map::iterator it = map.find(-i - 1); if (it != map.end()) { dplyr::push_back(indices_x, it->second); dplyr::push_back(indices_y, i, it->second.size()); } else { indices_x.push_back(-i - 1); // point to the i-th row in the right table indices_y.push_back(i); } } return dplyr::subset_join(x, y, indices_x, indices_y, by_x, by_y, aux_x, aux_y, dplyr::get_class(x), frame ); } // [[Rcpp::export(rng = false)]] Rcpp::DataFrame full_join_impl(Rcpp::DataFrame x, Rcpp::DataFrame y, Rcpp::IntegerVector by_x, Rcpp::IntegerVector by_y, Rcpp::IntegerVector aux_x, Rcpp::IntegerVector aux_y, bool na_match, SEXP frame ) { dplyr::check_by(by_x); typedef dplyr::VisitorSetIndexMap > Map; dplyr::DataFrameJoinVisitors visitors(y, x, by_y, by_x, false, na_match); Map map(visitors); // train the map in terms of y train_push_back(map, y.nrows()); std::vector indices_x; std::vector indices_y; int n_x = x.nrows(), n_y = y.nrows(); // get both the matches and the rows from left but not right for (int i = 0; i < n_x; i++) { // find a row in y that matches row i in x Map::iterator it = map.find(-i - 1); if (it != map.end()) { dplyr::push_back(indices_y, it->second); dplyr::push_back(indices_x, i, it->second.size()); } else { indices_y.push_back(-1); // mark NA indices_x.push_back(i); } } // train a new map in terms of x this time dplyr::DataFrameJoinVisitors visitors2(x, y, by_x, by_y, false, na_match); Map map2(visitors2); train_push_back(map2, x.nrows()); for (int i = 0; i < n_y; i++) { // try to find row in x that matches this row of y Map::iterator it = map2.find(-i - 1); if (it == map2.end()) { indices_x.push_back(-i - 1); indices_y.push_back(i); } } return dplyr::subset_join(x, y, indices_x, indices_y, by_x, by_y, aux_x, aux_y, dplyr::get_class(x), frame ); } dplyr/src/rlang.cpp0000644000176200001440000000033713614573562014021 0ustar liggesusers#include #include namespace dplyr { namespace internal { const rlang_api_ptrs_t& rlang_api() { static rlang_api_ptrs_t ptrs; return ptrs; } } // namespace internal } // namespace dplyr dplyr/src/RcppExports.cpp0000644000176200001440000007624113614573562015216 0ustar liggesusers// Generated by using Rcpp::compileAttributes() -> do not edit by hand // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 #include "../inst/include/dplyr.h" #include "../inst/include/dplyr_types.h" #include using namespace Rcpp; // loc Rcpp::CharacterVector loc(SEXP data); RcppExport SEXP _dplyr_loc(SEXP dataSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< SEXP >::type data(dataSEXP); rcpp_result_gen = Rcpp::wrap(loc(data)); return rcpp_result_gen; END_RCPP } // dfloc Rcpp::CharacterVector dfloc(Rcpp::List df); RcppExport SEXP _dplyr_dfloc(SEXP dfSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::List >::type df(dfSEXP); rcpp_result_gen = Rcpp::wrap(dfloc(df)); return rcpp_result_gen; END_RCPP } // plfloc Rcpp::CharacterVector plfloc(Rcpp::Pairlist data); RcppExport SEXP _dplyr_plfloc(SEXP dataSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::Pairlist >::type data(dataSEXP); rcpp_result_gen = Rcpp::wrap(plfloc(data)); return rcpp_result_gen; END_RCPP } // strings_addresses Rcpp::CharacterVector strings_addresses(Rcpp::CharacterVector s); RcppExport SEXP _dplyr_strings_addresses(SEXP sSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::CharacterVector >::type s(sSEXP); rcpp_result_gen = Rcpp::wrap(strings_addresses(s)); return rcpp_result_gen; END_RCPP } // init_logging void init_logging(const std::string& log_level); RcppExport SEXP _dplyr_init_logging(SEXP log_levelSEXP) { BEGIN_RCPP Rcpp::traits::input_parameter< const std::string& >::type log_level(log_levelSEXP); init_logging(log_level); return R_NilValue; END_RCPP } // is_maybe_shared bool is_maybe_shared(SEXP env, SEXP name); RcppExport SEXP _dplyr_is_maybe_shared(SEXP envSEXP, SEXP nameSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< SEXP >::type env(envSEXP); Rcpp::traits::input_parameter< SEXP >::type name(nameSEXP); rcpp_result_gen = Rcpp::wrap(is_maybe_shared(env, name)); return rcpp_result_gen; END_RCPP } // maybe_shared_columns Rcpp::LogicalVector maybe_shared_columns(SEXP df); RcppExport SEXP _dplyr_maybe_shared_columns(SEXP dfSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< SEXP >::type df(dfSEXP); rcpp_result_gen = Rcpp::wrap(maybe_shared_columns(df)); return rcpp_result_gen; END_RCPP } // arrange_impl SEXP arrange_impl(Rcpp::DataFrame df, dplyr::QuosureList quosures, SEXP frame); RcppExport SEXP _dplyr_arrange_impl(SEXP dfSEXP, SEXP quosuresSEXP, SEXP frameSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::DataFrame >::type df(dfSEXP); Rcpp::traits::input_parameter< dplyr::QuosureList >::type quosures(quosuresSEXP); Rcpp::traits::input_parameter< SEXP >::type frame(frameSEXP); rcpp_result_gen = Rcpp::wrap(arrange_impl(df, quosures, frame)); return rcpp_result_gen; END_RCPP } // between Rcpp::LogicalVector between(Rcpp::NumericVector x, double left, double right); RcppExport SEXP _dplyr_between(SEXP xSEXP, SEXP leftSEXP, SEXP rightSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::NumericVector >::type x(xSEXP); Rcpp::traits::input_parameter< double >::type left(leftSEXP); Rcpp::traits::input_parameter< double >::type right(rightSEXP); rcpp_result_gen = Rcpp::wrap(between(x, left, right)); return rcpp_result_gen; END_RCPP } // flatten_bindable SEXP flatten_bindable(SEXP x); RcppExport SEXP _dplyr_flatten_bindable(SEXP xSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< SEXP >::type x(xSEXP); rcpp_result_gen = Rcpp::wrap(flatten_bindable(x)); return rcpp_result_gen; END_RCPP } // bind_rows_ Rcpp::List bind_rows_(Rcpp::List dots, SEXP id); RcppExport SEXP _dplyr_bind_rows_(SEXP dotsSEXP, SEXP idSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::List >::type dots(dotsSEXP); Rcpp::traits::input_parameter< SEXP >::type id(idSEXP); rcpp_result_gen = Rcpp::wrap(bind_rows_(dots, id)); return rcpp_result_gen; END_RCPP } // cbind_all SEXP cbind_all(Rcpp::List dots); RcppExport SEXP _dplyr_cbind_all(SEXP dotsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::List >::type dots(dotsSEXP); rcpp_result_gen = Rcpp::wrap(cbind_all(dots)); return rcpp_result_gen; END_RCPP } // combine_all SEXP combine_all(Rcpp::List data); RcppExport SEXP _dplyr_combine_all(SEXP dataSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::List >::type data(dataSEXP); rcpp_result_gen = Rcpp::wrap(combine_all(data)); return rcpp_result_gen; END_RCPP } // distinct_impl SEXP distinct_impl(Rcpp::DataFrame df, const Rcpp::IntegerVector& vars, const Rcpp::IntegerVector& keep, SEXP frame); RcppExport SEXP _dplyr_distinct_impl(SEXP dfSEXP, SEXP varsSEXP, SEXP keepSEXP, SEXP frameSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::DataFrame >::type df(dfSEXP); Rcpp::traits::input_parameter< const Rcpp::IntegerVector& >::type vars(varsSEXP); Rcpp::traits::input_parameter< const Rcpp::IntegerVector& >::type keep(keepSEXP); Rcpp::traits::input_parameter< SEXP >::type frame(frameSEXP); rcpp_result_gen = Rcpp::wrap(distinct_impl(df, vars, keep, frame)); return rcpp_result_gen; END_RCPP } // n_distinct_multi int n_distinct_multi(Rcpp::List variables, bool na_rm); RcppExport SEXP _dplyr_n_distinct_multi(SEXP variablesSEXP, SEXP na_rmSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::List >::type variables(variablesSEXP); Rcpp::traits::input_parameter< bool >::type na_rm(na_rmSEXP); rcpp_result_gen = Rcpp::wrap(n_distinct_multi(variables, na_rm)); return rcpp_result_gen; END_RCPP } // filter_impl SEXP filter_impl(Rcpp::DataFrame df, dplyr::Quosure quo); RcppExport SEXP _dplyr_filter_impl(SEXP dfSEXP, SEXP quoSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::DataFrame >::type df(dfSEXP); Rcpp::traits::input_parameter< dplyr::Quosure >::type quo(quoSEXP); rcpp_result_gen = Rcpp::wrap(filter_impl(df, quo)); return rcpp_result_gen; END_RCPP } // slice_impl SEXP slice_impl(Rcpp::DataFrame df, dplyr::Quosure quosure); RcppExport SEXP _dplyr_slice_impl(SEXP dfSEXP, SEXP quosureSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::DataFrame >::type df(dfSEXP); Rcpp::traits::input_parameter< dplyr::Quosure >::type quosure(quosureSEXP); rcpp_result_gen = Rcpp::wrap(slice_impl(df, quosure)); return rcpp_result_gen; END_RCPP } // grouped_indices_grouped_df_impl Rcpp::IntegerVector grouped_indices_grouped_df_impl(const dplyr::GroupedDataFrame& gdf); RcppExport SEXP _dplyr_grouped_indices_grouped_df_impl(SEXP gdfSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< const dplyr::GroupedDataFrame& >::type gdf(gdfSEXP); rcpp_result_gen = Rcpp::wrap(grouped_indices_grouped_df_impl(gdf)); return rcpp_result_gen; END_RCPP } // group_size_grouped_cpp Rcpp::IntegerVector group_size_grouped_cpp(const dplyr::GroupedDataFrame& gdf); RcppExport SEXP _dplyr_group_size_grouped_cpp(SEXP gdfSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< const dplyr::GroupedDataFrame& >::type gdf(gdfSEXP); rcpp_result_gen = Rcpp::wrap(group_size_grouped_cpp(gdf)); return rcpp_result_gen; END_RCPP } // regroup SEXP regroup(Rcpp::DataFrame grouping_data, SEXP frame); RcppExport SEXP _dplyr_regroup(SEXP grouping_dataSEXP, SEXP frameSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::DataFrame >::type grouping_data(grouping_dataSEXP); Rcpp::traits::input_parameter< SEXP >::type frame(frameSEXP); rcpp_result_gen = Rcpp::wrap(regroup(grouping_data, frame)); return rcpp_result_gen; END_RCPP } // grouped_df_impl Rcpp::DataFrame grouped_df_impl(Rcpp::DataFrame data, const dplyr::SymbolVector& symbols, bool drop); RcppExport SEXP _dplyr_grouped_df_impl(SEXP dataSEXP, SEXP symbolsSEXP, SEXP dropSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::DataFrame >::type data(dataSEXP); Rcpp::traits::input_parameter< const dplyr::SymbolVector& >::type symbols(symbolsSEXP); Rcpp::traits::input_parameter< bool >::type drop(dropSEXP); rcpp_result_gen = Rcpp::wrap(grouped_df_impl(data, symbols, drop)); return rcpp_result_gen; END_RCPP } // group_data_grouped_df Rcpp::DataFrame group_data_grouped_df(Rcpp::DataFrame data); RcppExport SEXP _dplyr_group_data_grouped_df(SEXP dataSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::DataFrame >::type data(dataSEXP); rcpp_result_gen = Rcpp::wrap(group_data_grouped_df(data)); return rcpp_result_gen; END_RCPP } // ungroup_grouped_df Rcpp::DataFrame ungroup_grouped_df(Rcpp::DataFrame df); RcppExport SEXP _dplyr_ungroup_grouped_df(SEXP dfSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::DataFrame >::type df(dfSEXP); rcpp_result_gen = Rcpp::wrap(ungroup_grouped_df(df)); return rcpp_result_gen; END_RCPP } // group_split_impl Rcpp::List group_split_impl(const dplyr::GroupedDataFrame& gdf, bool keep, SEXP frame); RcppExport SEXP _dplyr_group_split_impl(SEXP gdfSEXP, SEXP keepSEXP, SEXP frameSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< const dplyr::GroupedDataFrame& >::type gdf(gdfSEXP); Rcpp::traits::input_parameter< bool >::type keep(keepSEXP); Rcpp::traits::input_parameter< SEXP >::type frame(frameSEXP); rcpp_result_gen = Rcpp::wrap(group_split_impl(gdf, keep, frame)); return rcpp_result_gen; END_RCPP } // hybrids Rcpp::List hybrids(); RcppExport SEXP _dplyr_hybrids() { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; rcpp_result_gen = Rcpp::wrap(hybrids()); return rcpp_result_gen; END_RCPP } // semi_join_impl Rcpp::DataFrame semi_join_impl(Rcpp::DataFrame x, Rcpp::DataFrame y, Rcpp::CharacterVector by_x, Rcpp::CharacterVector by_y, bool na_match, SEXP frame); RcppExport SEXP _dplyr_semi_join_impl(SEXP xSEXP, SEXP ySEXP, SEXP by_xSEXP, SEXP by_ySEXP, SEXP na_matchSEXP, SEXP frameSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::DataFrame >::type x(xSEXP); Rcpp::traits::input_parameter< Rcpp::DataFrame >::type y(ySEXP); Rcpp::traits::input_parameter< Rcpp::CharacterVector >::type by_x(by_xSEXP); Rcpp::traits::input_parameter< Rcpp::CharacterVector >::type by_y(by_ySEXP); Rcpp::traits::input_parameter< bool >::type na_match(na_matchSEXP); Rcpp::traits::input_parameter< SEXP >::type frame(frameSEXP); rcpp_result_gen = Rcpp::wrap(semi_join_impl(x, y, by_x, by_y, na_match, frame)); return rcpp_result_gen; END_RCPP } // anti_join_impl Rcpp::DataFrame anti_join_impl(Rcpp::DataFrame x, Rcpp::DataFrame y, Rcpp::CharacterVector by_x, Rcpp::CharacterVector by_y, bool na_match, SEXP frame); RcppExport SEXP _dplyr_anti_join_impl(SEXP xSEXP, SEXP ySEXP, SEXP by_xSEXP, SEXP by_ySEXP, SEXP na_matchSEXP, SEXP frameSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::DataFrame >::type x(xSEXP); Rcpp::traits::input_parameter< Rcpp::DataFrame >::type y(ySEXP); Rcpp::traits::input_parameter< Rcpp::CharacterVector >::type by_x(by_xSEXP); Rcpp::traits::input_parameter< Rcpp::CharacterVector >::type by_y(by_ySEXP); Rcpp::traits::input_parameter< bool >::type na_match(na_matchSEXP); Rcpp::traits::input_parameter< SEXP >::type frame(frameSEXP); rcpp_result_gen = Rcpp::wrap(anti_join_impl(x, y, by_x, by_y, na_match, frame)); return rcpp_result_gen; END_RCPP } // inner_join_impl Rcpp::DataFrame inner_join_impl(Rcpp::DataFrame x, Rcpp::DataFrame y, Rcpp::IntegerVector by_x, Rcpp::IntegerVector by_y, Rcpp::IntegerVector aux_x, Rcpp::IntegerVector aux_y, bool na_match, SEXP frame); RcppExport SEXP _dplyr_inner_join_impl(SEXP xSEXP, SEXP ySEXP, SEXP by_xSEXP, SEXP by_ySEXP, SEXP aux_xSEXP, SEXP aux_ySEXP, SEXP na_matchSEXP, SEXP frameSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::DataFrame >::type x(xSEXP); Rcpp::traits::input_parameter< Rcpp::DataFrame >::type y(ySEXP); Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type by_x(by_xSEXP); Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type by_y(by_ySEXP); Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type aux_x(aux_xSEXP); Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type aux_y(aux_ySEXP); Rcpp::traits::input_parameter< bool >::type na_match(na_matchSEXP); Rcpp::traits::input_parameter< SEXP >::type frame(frameSEXP); rcpp_result_gen = Rcpp::wrap(inner_join_impl(x, y, by_x, by_y, aux_x, aux_y, na_match, frame)); return rcpp_result_gen; END_RCPP } // nest_join_impl Rcpp::List nest_join_impl(Rcpp::DataFrame x, Rcpp::DataFrame y, Rcpp::IntegerVector by_x, Rcpp::IntegerVector by_y, Rcpp::IntegerVector aux_y, Rcpp::String yname, SEXP frame); RcppExport SEXP _dplyr_nest_join_impl(SEXP xSEXP, SEXP ySEXP, SEXP by_xSEXP, SEXP by_ySEXP, SEXP aux_ySEXP, SEXP ynameSEXP, SEXP frameSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::DataFrame >::type x(xSEXP); Rcpp::traits::input_parameter< Rcpp::DataFrame >::type y(ySEXP); Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type by_x(by_xSEXP); Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type by_y(by_ySEXP); Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type aux_y(aux_ySEXP); Rcpp::traits::input_parameter< Rcpp::String >::type yname(ynameSEXP); Rcpp::traits::input_parameter< SEXP >::type frame(frameSEXP); rcpp_result_gen = Rcpp::wrap(nest_join_impl(x, y, by_x, by_y, aux_y, yname, frame)); return rcpp_result_gen; END_RCPP } // left_join_impl Rcpp::DataFrame left_join_impl(Rcpp::DataFrame x, Rcpp::DataFrame y, Rcpp::IntegerVector by_x, Rcpp::IntegerVector by_y, Rcpp::IntegerVector aux_x, Rcpp::IntegerVector aux_y, bool na_match, SEXP frame); RcppExport SEXP _dplyr_left_join_impl(SEXP xSEXP, SEXP ySEXP, SEXP by_xSEXP, SEXP by_ySEXP, SEXP aux_xSEXP, SEXP aux_ySEXP, SEXP na_matchSEXP, SEXP frameSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::DataFrame >::type x(xSEXP); Rcpp::traits::input_parameter< Rcpp::DataFrame >::type y(ySEXP); Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type by_x(by_xSEXP); Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type by_y(by_ySEXP); Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type aux_x(aux_xSEXP); Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type aux_y(aux_ySEXP); Rcpp::traits::input_parameter< bool >::type na_match(na_matchSEXP); Rcpp::traits::input_parameter< SEXP >::type frame(frameSEXP); rcpp_result_gen = Rcpp::wrap(left_join_impl(x, y, by_x, by_y, aux_x, aux_y, na_match, frame)); return rcpp_result_gen; END_RCPP } // right_join_impl Rcpp::DataFrame right_join_impl(Rcpp::DataFrame x, Rcpp::DataFrame y, Rcpp::IntegerVector by_x, Rcpp::IntegerVector by_y, Rcpp::IntegerVector aux_x, Rcpp::IntegerVector aux_y, bool na_match, SEXP frame); RcppExport SEXP _dplyr_right_join_impl(SEXP xSEXP, SEXP ySEXP, SEXP by_xSEXP, SEXP by_ySEXP, SEXP aux_xSEXP, SEXP aux_ySEXP, SEXP na_matchSEXP, SEXP frameSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::DataFrame >::type x(xSEXP); Rcpp::traits::input_parameter< Rcpp::DataFrame >::type y(ySEXP); Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type by_x(by_xSEXP); Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type by_y(by_ySEXP); Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type aux_x(aux_xSEXP); Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type aux_y(aux_ySEXP); Rcpp::traits::input_parameter< bool >::type na_match(na_matchSEXP); Rcpp::traits::input_parameter< SEXP >::type frame(frameSEXP); rcpp_result_gen = Rcpp::wrap(right_join_impl(x, y, by_x, by_y, aux_x, aux_y, na_match, frame)); return rcpp_result_gen; END_RCPP } // full_join_impl Rcpp::DataFrame full_join_impl(Rcpp::DataFrame x, Rcpp::DataFrame y, Rcpp::IntegerVector by_x, Rcpp::IntegerVector by_y, Rcpp::IntegerVector aux_x, Rcpp::IntegerVector aux_y, bool na_match, SEXP frame); RcppExport SEXP _dplyr_full_join_impl(SEXP xSEXP, SEXP ySEXP, SEXP by_xSEXP, SEXP by_ySEXP, SEXP aux_xSEXP, SEXP aux_ySEXP, SEXP na_matchSEXP, SEXP frameSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::DataFrame >::type x(xSEXP); Rcpp::traits::input_parameter< Rcpp::DataFrame >::type y(ySEXP); Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type by_x(by_xSEXP); Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type by_y(by_ySEXP); Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type aux_x(aux_xSEXP); Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type aux_y(aux_ySEXP); Rcpp::traits::input_parameter< bool >::type na_match(na_matchSEXP); Rcpp::traits::input_parameter< SEXP >::type frame(frameSEXP); rcpp_result_gen = Rcpp::wrap(full_join_impl(x, y, by_x, by_y, aux_x, aux_y, na_match, frame)); return rcpp_result_gen; END_RCPP } // mutate_impl SEXP mutate_impl(Rcpp::DataFrame df, dplyr::QuosureList dots, SEXP caller_env); RcppExport SEXP _dplyr_mutate_impl(SEXP dfSEXP, SEXP dotsSEXP, SEXP caller_envSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::DataFrame >::type df(dfSEXP); Rcpp::traits::input_parameter< dplyr::QuosureList >::type dots(dotsSEXP); Rcpp::traits::input_parameter< SEXP >::type caller_env(caller_envSEXP); rcpp_result_gen = Rcpp::wrap(mutate_impl(df, dots, caller_env)); return rcpp_result_gen; END_RCPP } // select_impl Rcpp::DataFrame select_impl(Rcpp::DataFrame df, Rcpp::CharacterVector vars); RcppExport SEXP _dplyr_select_impl(SEXP dfSEXP, SEXP varsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::DataFrame >::type df(dfSEXP); Rcpp::traits::input_parameter< Rcpp::CharacterVector >::type vars(varsSEXP); rcpp_result_gen = Rcpp::wrap(select_impl(df, vars)); return rcpp_result_gen; END_RCPP } // compatible_data_frame_nonames dplyr::BoolResult compatible_data_frame_nonames(Rcpp::DataFrame x, Rcpp::DataFrame y, bool convert); RcppExport SEXP _dplyr_compatible_data_frame_nonames(SEXP xSEXP, SEXP ySEXP, SEXP convertSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::DataFrame >::type x(xSEXP); Rcpp::traits::input_parameter< Rcpp::DataFrame >::type y(ySEXP); Rcpp::traits::input_parameter< bool >::type convert(convertSEXP); rcpp_result_gen = Rcpp::wrap(compatible_data_frame_nonames(x, y, convert)); return rcpp_result_gen; END_RCPP } // compatible_data_frame dplyr::BoolResult compatible_data_frame(Rcpp::DataFrame x, Rcpp::DataFrame y, bool ignore_col_order, bool convert); RcppExport SEXP _dplyr_compatible_data_frame(SEXP xSEXP, SEXP ySEXP, SEXP ignore_col_orderSEXP, SEXP convertSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::DataFrame >::type x(xSEXP); Rcpp::traits::input_parameter< Rcpp::DataFrame >::type y(ySEXP); Rcpp::traits::input_parameter< bool >::type ignore_col_order(ignore_col_orderSEXP); Rcpp::traits::input_parameter< bool >::type convert(convertSEXP); rcpp_result_gen = Rcpp::wrap(compatible_data_frame(x, y, ignore_col_order, convert)); return rcpp_result_gen; END_RCPP } // equal_data_frame dplyr::BoolResult equal_data_frame(Rcpp::DataFrame x, Rcpp::DataFrame y, bool ignore_col_order, bool ignore_row_order, bool convert); RcppExport SEXP _dplyr_equal_data_frame(SEXP xSEXP, SEXP ySEXP, SEXP ignore_col_orderSEXP, SEXP ignore_row_orderSEXP, SEXP convertSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::DataFrame >::type x(xSEXP); Rcpp::traits::input_parameter< Rcpp::DataFrame >::type y(ySEXP); Rcpp::traits::input_parameter< bool >::type ignore_col_order(ignore_col_orderSEXP); Rcpp::traits::input_parameter< bool >::type ignore_row_order(ignore_row_orderSEXP); Rcpp::traits::input_parameter< bool >::type convert(convertSEXP); rcpp_result_gen = Rcpp::wrap(equal_data_frame(x, y, ignore_col_order, ignore_row_order, convert)); return rcpp_result_gen; END_RCPP } // union_data_frame Rcpp::DataFrame union_data_frame(Rcpp::DataFrame x, Rcpp::DataFrame y); RcppExport SEXP _dplyr_union_data_frame(SEXP xSEXP, SEXP ySEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::DataFrame >::type x(xSEXP); Rcpp::traits::input_parameter< Rcpp::DataFrame >::type y(ySEXP); rcpp_result_gen = Rcpp::wrap(union_data_frame(x, y)); return rcpp_result_gen; END_RCPP } // intersect_data_frame Rcpp::DataFrame intersect_data_frame(Rcpp::DataFrame x, Rcpp::DataFrame y); RcppExport SEXP _dplyr_intersect_data_frame(SEXP xSEXP, SEXP ySEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::DataFrame >::type x(xSEXP); Rcpp::traits::input_parameter< Rcpp::DataFrame >::type y(ySEXP); rcpp_result_gen = Rcpp::wrap(intersect_data_frame(x, y)); return rcpp_result_gen; END_RCPP } // setdiff_data_frame Rcpp::DataFrame setdiff_data_frame(Rcpp::DataFrame x, Rcpp::DataFrame y); RcppExport SEXP _dplyr_setdiff_data_frame(SEXP xSEXP, SEXP ySEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::DataFrame >::type x(xSEXP); Rcpp::traits::input_parameter< Rcpp::DataFrame >::type y(ySEXP); rcpp_result_gen = Rcpp::wrap(setdiff_data_frame(x, y)); return rcpp_result_gen; END_RCPP } // summarise_impl SEXP summarise_impl(Rcpp::DataFrame df, dplyr::QuosureList dots, SEXP frame, SEXP caller_env); RcppExport SEXP _dplyr_summarise_impl(SEXP dfSEXP, SEXP dotsSEXP, SEXP frameSEXP, SEXP caller_envSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::DataFrame >::type df(dfSEXP); Rcpp::traits::input_parameter< dplyr::QuosureList >::type dots(dotsSEXP); Rcpp::traits::input_parameter< SEXP >::type frame(frameSEXP); Rcpp::traits::input_parameter< SEXP >::type caller_env(caller_envSEXP); rcpp_result_gen = Rcpp::wrap(summarise_impl(df, dots, frame, caller_env)); return rcpp_result_gen; END_RCPP } // hybrid_impl SEXP hybrid_impl(Rcpp::DataFrame df, dplyr::Quosure quosure, SEXP caller_env); RcppExport SEXP _dplyr_hybrid_impl(SEXP dfSEXP, SEXP quosureSEXP, SEXP caller_envSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::DataFrame >::type df(dfSEXP); Rcpp::traits::input_parameter< dplyr::Quosure >::type quosure(quosureSEXP); Rcpp::traits::input_parameter< SEXP >::type caller_env(caller_envSEXP); rcpp_result_gen = Rcpp::wrap(hybrid_impl(df, quosure, caller_env)); return rcpp_result_gen; END_RCPP } // test_comparisons Rcpp::LogicalVector test_comparisons(); RcppExport SEXP _dplyr_test_comparisons() { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; rcpp_result_gen = Rcpp::wrap(test_comparisons()); return rcpp_result_gen; END_RCPP } // test_matches Rcpp::List test_matches(); RcppExport SEXP _dplyr_test_matches() { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; rcpp_result_gen = Rcpp::wrap(test_matches()); return rcpp_result_gen; END_RCPP } // test_length_wrap Rcpp::LogicalVector test_length_wrap(); RcppExport SEXP _dplyr_test_length_wrap() { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; rcpp_result_gen = Rcpp::wrap(test_length_wrap()); return rcpp_result_gen; END_RCPP } // materialize_binding SEXP materialize_binding(int idx, Rcpp::XPtr mask_proxy_xp); RcppExport SEXP _dplyr_materialize_binding(SEXP idxSEXP, SEXP mask_proxy_xpSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< int >::type idx(idxSEXP); Rcpp::traits::input_parameter< Rcpp::XPtr >::type mask_proxy_xp(mask_proxy_xpSEXP); rcpp_result_gen = Rcpp::wrap(materialize_binding(idx, mask_proxy_xp)); return rcpp_result_gen; END_RCPP } // check_valid_names void check_valid_names(const Rcpp::CharacterVector& names, bool warn_only); RcppExport SEXP _dplyr_check_valid_names(SEXP namesSEXP, SEXP warn_onlySEXP) { BEGIN_RCPP Rcpp::traits::input_parameter< const Rcpp::CharacterVector& >::type names(namesSEXP); Rcpp::traits::input_parameter< bool >::type warn_only(warn_onlySEXP); check_valid_names(names, warn_only); return R_NilValue; END_RCPP } // assert_all_allow_list void assert_all_allow_list(const Rcpp::DataFrame& data); RcppExport SEXP _dplyr_assert_all_allow_list(SEXP dataSEXP) { BEGIN_RCPP Rcpp::traits::input_parameter< const Rcpp::DataFrame& >::type data(dataSEXP); assert_all_allow_list(data); return R_NilValue; END_RCPP } // is_data_pronoun bool is_data_pronoun(SEXP expr); RcppExport SEXP _dplyr_is_data_pronoun(SEXP exprSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< SEXP >::type expr(exprSEXP); rcpp_result_gen = Rcpp::wrap(is_data_pronoun(expr)); return rcpp_result_gen; END_RCPP } // is_variable_reference bool is_variable_reference(SEXP expr); RcppExport SEXP _dplyr_is_variable_reference(SEXP exprSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< SEXP >::type expr(exprSEXP); rcpp_result_gen = Rcpp::wrap(is_variable_reference(expr)); return rcpp_result_gen; END_RCPP } // quo_is_variable_reference bool quo_is_variable_reference(SEXP quo); RcppExport SEXP _dplyr_quo_is_variable_reference(SEXP quoSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< SEXP >::type quo(quoSEXP); rcpp_result_gen = Rcpp::wrap(quo_is_variable_reference(quo)); return rcpp_result_gen; END_RCPP } // quo_is_data_pronoun bool quo_is_data_pronoun(SEXP quo); RcppExport SEXP _dplyr_quo_is_data_pronoun(SEXP quoSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< SEXP >::type quo(quoSEXP); rcpp_result_gen = Rcpp::wrap(quo_is_data_pronoun(quo)); return rcpp_result_gen; END_RCPP } // cumall Rcpp::LogicalVector cumall(Rcpp::LogicalVector x); RcppExport SEXP _dplyr_cumall(SEXP xSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::LogicalVector >::type x(xSEXP); rcpp_result_gen = Rcpp::wrap(cumall(x)); return rcpp_result_gen; END_RCPP } // cumany Rcpp::LogicalVector cumany(Rcpp::LogicalVector x); RcppExport SEXP _dplyr_cumany(SEXP xSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::LogicalVector >::type x(xSEXP); rcpp_result_gen = Rcpp::wrap(cumany(x)); return rcpp_result_gen; END_RCPP } // cummean Rcpp::NumericVector cummean(Rcpp::NumericVector x); RcppExport SEXP _dplyr_cummean(SEXP xSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< Rcpp::NumericVector >::type x(xSEXP); rcpp_result_gen = Rcpp::wrap(cummean(x)); return rcpp_result_gen; END_RCPP } static const R_CallMethodDef CallEntries[] = { {"_dplyr_loc", (DL_FUNC) &_dplyr_loc, 1}, {"_dplyr_dfloc", (DL_FUNC) &_dplyr_dfloc, 1}, {"_dplyr_plfloc", (DL_FUNC) &_dplyr_plfloc, 1}, {"_dplyr_strings_addresses", (DL_FUNC) &_dplyr_strings_addresses, 1}, {"_dplyr_init_logging", (DL_FUNC) &_dplyr_init_logging, 1}, {"_dplyr_is_maybe_shared", (DL_FUNC) &_dplyr_is_maybe_shared, 2}, {"_dplyr_maybe_shared_columns", (DL_FUNC) &_dplyr_maybe_shared_columns, 1}, {"_dplyr_arrange_impl", (DL_FUNC) &_dplyr_arrange_impl, 3}, {"_dplyr_between", (DL_FUNC) &_dplyr_between, 3}, {"_dplyr_flatten_bindable", (DL_FUNC) &_dplyr_flatten_bindable, 1}, {"_dplyr_bind_rows_", (DL_FUNC) &_dplyr_bind_rows_, 2}, {"_dplyr_cbind_all", (DL_FUNC) &_dplyr_cbind_all, 1}, {"_dplyr_combine_all", (DL_FUNC) &_dplyr_combine_all, 1}, {"_dplyr_distinct_impl", (DL_FUNC) &_dplyr_distinct_impl, 4}, {"_dplyr_n_distinct_multi", (DL_FUNC) &_dplyr_n_distinct_multi, 2}, {"_dplyr_filter_impl", (DL_FUNC) &_dplyr_filter_impl, 2}, {"_dplyr_slice_impl", (DL_FUNC) &_dplyr_slice_impl, 2}, {"_dplyr_grouped_indices_grouped_df_impl", (DL_FUNC) &_dplyr_grouped_indices_grouped_df_impl, 1}, {"_dplyr_group_size_grouped_cpp", (DL_FUNC) &_dplyr_group_size_grouped_cpp, 1}, {"_dplyr_regroup", (DL_FUNC) &_dplyr_regroup, 2}, {"_dplyr_grouped_df_impl", (DL_FUNC) &_dplyr_grouped_df_impl, 3}, {"_dplyr_group_data_grouped_df", (DL_FUNC) &_dplyr_group_data_grouped_df, 1}, {"_dplyr_ungroup_grouped_df", (DL_FUNC) &_dplyr_ungroup_grouped_df, 1}, {"_dplyr_group_split_impl", (DL_FUNC) &_dplyr_group_split_impl, 3}, {"_dplyr_hybrids", (DL_FUNC) &_dplyr_hybrids, 0}, {"_dplyr_semi_join_impl", (DL_FUNC) &_dplyr_semi_join_impl, 6}, {"_dplyr_anti_join_impl", (DL_FUNC) &_dplyr_anti_join_impl, 6}, {"_dplyr_inner_join_impl", (DL_FUNC) &_dplyr_inner_join_impl, 8}, {"_dplyr_nest_join_impl", (DL_FUNC) &_dplyr_nest_join_impl, 7}, {"_dplyr_left_join_impl", (DL_FUNC) &_dplyr_left_join_impl, 8}, {"_dplyr_right_join_impl", (DL_FUNC) &_dplyr_right_join_impl, 8}, {"_dplyr_full_join_impl", (DL_FUNC) &_dplyr_full_join_impl, 8}, {"_dplyr_mutate_impl", (DL_FUNC) &_dplyr_mutate_impl, 3}, {"_dplyr_select_impl", (DL_FUNC) &_dplyr_select_impl, 2}, {"_dplyr_compatible_data_frame_nonames", (DL_FUNC) &_dplyr_compatible_data_frame_nonames, 3}, {"_dplyr_compatible_data_frame", (DL_FUNC) &_dplyr_compatible_data_frame, 4}, {"_dplyr_equal_data_frame", (DL_FUNC) &_dplyr_equal_data_frame, 5}, {"_dplyr_union_data_frame", (DL_FUNC) &_dplyr_union_data_frame, 2}, {"_dplyr_intersect_data_frame", (DL_FUNC) &_dplyr_intersect_data_frame, 2}, {"_dplyr_setdiff_data_frame", (DL_FUNC) &_dplyr_setdiff_data_frame, 2}, {"_dplyr_summarise_impl", (DL_FUNC) &_dplyr_summarise_impl, 4}, {"_dplyr_hybrid_impl", (DL_FUNC) &_dplyr_hybrid_impl, 3}, {"_dplyr_test_comparisons", (DL_FUNC) &_dplyr_test_comparisons, 0}, {"_dplyr_test_matches", (DL_FUNC) &_dplyr_test_matches, 0}, {"_dplyr_test_length_wrap", (DL_FUNC) &_dplyr_test_length_wrap, 0}, {"_dplyr_materialize_binding", (DL_FUNC) &_dplyr_materialize_binding, 2}, {"_dplyr_check_valid_names", (DL_FUNC) &_dplyr_check_valid_names, 2}, {"_dplyr_assert_all_allow_list", (DL_FUNC) &_dplyr_assert_all_allow_list, 1}, {"_dplyr_is_data_pronoun", (DL_FUNC) &_dplyr_is_data_pronoun, 1}, {"_dplyr_is_variable_reference", (DL_FUNC) &_dplyr_is_variable_reference, 1}, {"_dplyr_quo_is_variable_reference", (DL_FUNC) &_dplyr_quo_is_variable_reference, 1}, {"_dplyr_quo_is_data_pronoun", (DL_FUNC) &_dplyr_quo_is_data_pronoun, 1}, {"_dplyr_cumall", (DL_FUNC) &_dplyr_cumall, 1}, {"_dplyr_cumany", (DL_FUNC) &_dplyr_cumany, 1}, {"_dplyr_cummean", (DL_FUNC) &_dplyr_cummean, 1}, {NULL, NULL, 0} }; void init_hybrid_inline_map(DllInfo* /*dll*/); RcppExport void R_init_dplyr(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); init_hybrid_inline_map(dll); } dplyr/src/distinct.cpp0000644000176200001440000000476213614573562014545 0ustar liggesusers#include "pch.h" #include #include #include #include #include #include SEXP select_not_grouped(const Rcpp::DataFrame& df, const dplyr::SymbolVector& keep, const dplyr::SymbolVector& new_names); // [[Rcpp::export(rng = false)]] SEXP distinct_impl(Rcpp::DataFrame df, const Rcpp::IntegerVector& vars, const Rcpp::IntegerVector& keep, SEXP frame) { if (df.size() == 0) { Rcpp::DataFrame res = Rcpp::DataFrame::create(); dplyr::copy_most_attributes(res, df); dplyr::set_rownames(res, df.nrows() == 0 ? 0 : 1); return res ; } // No vars means ungrouped data with keep_all = TRUE. if (vars.size() == 0) return df; check_valid_colnames(df, true); dplyr::DataFrameVisitors visitors(df, vars); int n = df.nrows(); // allocate a big enough vector Rcpp::IntegerVector indices(n); dplyr::VisitorSetIndexSet set(visitors); int k = 0; for (int i = 0; i < n; i++) { if (set.insert(i).second) { indices[k++] = i + 1; } } // but then pretend it is smaller in case it is used in R subscripting SETLENGTH(indices, k); SEXP res = dplyr::DataFrameSubsetVisitors(dplyr::DataFrameSelect(df, keep), frame).subset_all(indices); // restore original length for GC bookkeeping SETLENGTH(indices, n); return res; } // [[Rcpp::export(rng = false)]] int n_distinct_multi(Rcpp::List variables, bool na_rm = false) { if (variables.length() == 0) { Rcpp::stop("Need at least one column for `n_distinct()`"); } int n = variables.size(); // get the number of rows of an hypothetical data frame // that would contain variables, taking into account potential // recycling of length 1 variables int length = get_size(variables[0]); for (int i = 1; i < n; i++) { int l = get_size(variables[i]); if (length == l) continue; if (length == 1 && l > 1) { length = l; } } dplyr::MultipleVectorVisitors visitors(variables, length, 1); typedef dplyr::VisitorHash Hash; typedef dplyr::VisitorEqualPredicate Pred; typedef dplyr_hash_set Set; Set set(n, Hash(visitors), Pred(visitors)); for (int i = 0; i < length; i++) { if (!na_rm || !visitors.is_na(i)) set.insert(i); } return set.size(); } dplyr/vignettes/0000755000176200001440000000000013614574175013431 5ustar liggesusersdplyr/vignettes/window-functions.Rmd0000644000176200001440000002166713451046652017417 0ustar liggesusers--- title: "Window functions" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Window functions} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- ```{r, include = FALSE} knitr::opts_chunk$set(collapse = T, comment = "#>") options(tibble.print_min = 4L, tibble.print_max = 4L) library(dplyr) set.seed(1014) ``` A __window function__ is a variation on an aggregation function. Where an aggregation function, like `sum()` and `mean()`, takes n inputs and return a single value, a window function returns n values. The output of a window function depends on all its input values, so window functions don't include functions that work element-wise, like `+` or `round()`. Window functions include variations on aggregate functions, like `cumsum()` and `cummean()`, functions for ranking and ordering, like `rank()`, and functions for taking offsets, like `lead()` and `lag()`. In this vignette, we'll use a small sample of the Lahman batting dataset, including the players that have won an award. ```{r} library(Lahman) batting <- Lahman::Batting %>% as_tibble() %>% select(playerID, yearID, teamID, G, AB:H) %>% arrange(playerID, yearID, teamID) %>% semi_join(Lahman::AwardsPlayers, by = "playerID") players <- batting %>% group_by(playerID) ``` Window functions are used in conjunction with `mutate()` and `filter()` to solve a wide range of problems. Here's a selection: ```{r, eval = FALSE} # For each player, find the two years with most hits filter(players, min_rank(desc(H)) <= 2 & H > 0) # Within each player, rank each year by the number of games played mutate(players, G_rank = min_rank(G)) # For each player, find every year that was better than the previous year filter(players, G > lag(G)) # For each player, compute avg change in games played per year mutate(players, G_change = (G - lag(G)) / (yearID - lag(yearID))) # For each player, find all where they played more games than average filter(players, G > mean(G)) # For each, player compute a z score based on number of games played mutate(players, G_z = (G - mean(G)) / sd(G)) ``` Before reading this vignette, you should be familiar with `mutate()` and `filter()`. ## Types of window functions There are five main families of window functions. Two families are unrelated to aggregation functions: * Ranking and ordering functions: `row_number()`, `min_rank()`, `dense_rank()`, `cume_dist()`, `percent_rank()`, and `ntile()`. These functions all take a vector to order by, and return various types of ranks. * Offsets `lead()` and `lag()` allow you to access the previous and next values in a vector, making it easy to compute differences and trends. The other three families are variations on familiar aggregate functions: * Cumulative aggregates: `cumsum()`, `cummin()`, `cummax()` (from base R), and `cumall()`, `cumany()`, and `cummean()` (from dplyr). * Rolling aggregates operate in a fixed width window. You won't find them in base R or in dplyr, but there are many implementations in other packages, such as [RcppRoll](https://cran.r-project.org/package=RcppRoll). * Recycled aggregates, where an aggregate is repeated to match the length of the input. These are not needed in R because vector recycling automatically recycles aggregates where needed. They are important in SQL, because the presence of an aggregation function usually tells the database to return only one row per group. Each family is described in more detail below, focussing on the general goals and how to use them with dplyr. For more details, refer to the individual function documentation. ## Ranking functions The ranking functions are variations on a theme, differing in how they handle ties: ```{r} x <- c(1, 1, 2, 2, 2) row_number(x) min_rank(x) dense_rank(x) ``` If you're familiar with R, you may recognise that `row_number()` and `min_rank()` can be computed with the base `rank()` function and various values of the `ties.method` argument. These functions are provided to save a little typing, and to make it easier to convert between R and SQL. Two other ranking functions return numbers between 0 and 1. `percent_rank()` gives the percentage of the rank; `cume_dist()` gives the proportion of values less than or equal to the current value. ```{r} cume_dist(x) percent_rank(x) ``` These are useful if you want to select (for example) the top 10% of records within each group. For example: ```{r} filter(players, cume_dist(desc(G)) < 0.1) ``` Finally, `ntile()` divides the data up into `n` evenly sized buckets. It's a coarse ranking, and it can be used in with `mutate()` to divide the data into buckets for further summary. For example, we could use `ntile()` to divide the players within a team into four ranked groups, and calculate the average number of games within each group. ```{r} by_team_player <- group_by(batting, teamID, playerID) by_team <- summarise(by_team_player, G = sum(G)) by_team_quartile <- group_by(by_team, quartile = ntile(G, 4)) summarise(by_team_quartile, mean(G)) ``` All ranking functions rank from lowest to highest so that small input values get small ranks. Use `desc()` to rank from highest to lowest. ## Lead and lag `lead()` and `lag()` produce offset versions of a input vector that is either ahead of or behind the original vector. ```{r} x <- 1:5 lead(x) lag(x) ``` You can use them to: * Compute differences or percent changes. ```{r, results = "hide"} # Compute the relative change in games played mutate(players, G_delta = G - lag(G)) ``` Using `lag()` is more convenient than `diff()` because for `n` inputs `diff()` returns `n - 1` outputs. * Find out when a value changes. ```{r, results = "hide"} # Find when a player changed teams filter(players, teamID != lag(teamID)) ``` `lead()` and `lag()` have an optional argument `order_by`. If set, instead of using the row order to determine which value comes before another, they will use another variable. This is important if you have not already sorted the data, or you want to sort one way and lag another. Here's a simple example of what happens if you don't specify `order_by` when you need it: ```{r} df <- data.frame(year = 2000:2005, value = (0:5) ^ 2) scrambled <- df[sample(nrow(df)), ] wrong <- mutate(scrambled, prev_value = lag(value)) arrange(wrong, year) right <- mutate(scrambled, prev_value = lag(value, order_by = year)) arrange(right, year) ``` ## Cumulative aggregates Base R provides cumulative sum (`cumsum()`), cumulative min (`cummin()`), and cumulative max (`cummax()`). (It also provides `cumprod()` but that is rarely useful). Other common accumulating functions are `cumany()` and `cumall()`, cumulative versions of `||` and `&&`, and `cummean()`, a cumulative mean. These are not included in base R, but efficient versions are provided by `dplyr`. `cumany()` and `cumall()` are useful for selecting all rows up to, or all rows after, a condition is true for the first (or last) time. For example, we can use `cumany()` to find all records for a player after they played a year with 150 games: ```{r, eval = FALSE} filter(players, cumany(G > 150)) ``` Like lead and lag, you may want to control the order in which the accumulation occurs. None of the built in functions have an `order_by` argument so `dplyr` provides a helper: `order_by()`. You give it the variable you want to order by, and then the call to the window function: ```{r} x <- 1:10 y <- 10:1 order_by(y, cumsum(x)) ``` This function uses a bit of non-standard evaluation, so I wouldn't recommend using it inside another function; use the simpler but less concise `with_order()` instead. ## Recycled aggregates R's vector recycling makes it easy to select values that are higher or lower than a summary. I call this a recycled aggregate because the value of the aggregate is recycled to be the same length as the original vector. Recycled aggregates are useful if you want to find all records greater than the mean or less than the median: ```{r, eval = FALSE} filter(players, G > mean(G)) filter(players, G < median(G)) ``` While most SQL databases don't have an equivalent of `median()` or `quantile()`, when filtering you can achieve the same effect with `ntile()`. For example, `x > median(x)` is equivalent to `ntile(x, 2) == 2`; `x > quantile(x, 75)` is equivalent to `ntile(x, 100) > 75` or `ntile(x, 4) > 3`. ```{r, eval = FALSE} filter(players, ntile(G, 2) == 2) ``` You can also use this idea to select the records with the highest (`x == max(x)`) or lowest value (`x == min(x)`) for a field, but the ranking functions give you more control over ties, and allow you to select any number of records. Recycled aggregates are also useful in conjunction with `mutate()`. For example, with the batting data, we could compute the "career year", the number of years a player has played since they entered the league: ```{r} mutate(players, career_year = yearID - min(yearID) + 1) ``` Or, as in the introductory example, we could compute a z-score: ```{r} mutate(players, G_z = (G - mean(G)) / sd(G)) ``` dplyr/vignettes/two-table.Rmd0000644000176200001440000002056113614573562015776 0ustar liggesusers--- title: "Two-table verbs" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Two-table verbs} %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} --- ```{r, echo = FALSE, message = FALSE} knitr::opts_chunk$set(collapse = T, comment = "#>") options(tibble.print_min = 5) library(dplyr) knit_print.tbl_df <- function(x, options) { knitr::knit_print(trunc_mat(x), options) } ``` It's rare that a data analysis involves only a single table of data. In practice, you'll normally have many tables that contribute to an analysis, and you need flexible tools to combine them. In dplyr, there are three families of verbs that work with two tables at a time: * Mutating joins, which add new variables to one table from matching rows in another. * Filtering joins, which filter observations from one table based on whether or not they match an observation in the other table. * Set operations, which combine the observations in the data sets as if they were set elements. (This discussion assumes that you have [tidy data](http://www.jstatsoft.org/v59/i10/), where the rows are observations and the columns are variables. If you're not familiar with that framework, I'd recommend reading up on it first.) All two-table verbs work similarly. The first two arguments are `x` and `y`, and provide the tables to combine. The output is always a new table with the same type as `x`. ## Mutating joins Mutating joins allow you to combine variables from multiple tables. For example, take the nycflights13 data. In one table we have flight information with an abbreviation for carrier, and in another we have a mapping between abbreviations and full names. You can use a join to add the carrier names to the flight data: ```{r, warning = FALSE} library("nycflights13") # Drop unimportant variables so it's easier to understand the join results. flights2 <- flights %>% select(year:day, hour, origin, dest, tailnum, carrier) flights2 %>% left_join(airlines) ``` ### Controlling how the tables are matched As well as `x` and `y`, each mutating join takes an argument `by` that controls which variables are used to match observations in the two tables. There are a few ways to specify it, as I illustrate below with various tables from nycflights13: * `NULL`, the default. dplyr will will use all variables that appear in both tables, a __natural__ join. For example, the flights and weather tables match on their common variables: year, month, day, hour and origin. ```{r} flights2 %>% left_join(weather) ``` * A character vector, `by = "x"`. Like a natural join, but uses only some of the common variables. For example, `flights` and `planes` have `year` columns, but they mean different things so we only want to join by `tailnum`. ```{r} flights2 %>% left_join(planes, by = "tailnum") ``` Note that the year columns in the output are disambiguated with a suffix. * A named character vector: `by = c("x" = "a")`. This will match variable `x` in table `x` to variable `a` in table `y`. The variables from use will be used in the output. Each flight has an origin and destination `airport`, so we need to specify which one we want to join to: ```{r} flights2 %>% left_join(airports, c("dest" = "faa")) flights2 %>% left_join(airports, c("origin" = "faa")) ``` ### Types of join There are four types of mutating join, which differ in their behaviour when a match is not found. We'll illustrate each with a simple example: ```{r} df1 <- tibble(x = c(1, 2), y = 2:1) df2 <- tibble(x = c(1, 3), a = 10, b = "a") ``` * `inner_join(x, y)` only includes observations that match in both `x` and `y`. ```{r} df1 %>% inner_join(df2) %>% knitr::kable() ``` * `left_join(x, y)` includes all observations in `x`, regardless of whether they match or not. This is the most commonly used join because it ensures that you don't lose observations from your primary table. ```{r} df1 %>% left_join(df2) ``` * `right_join(x, y)` includes all observations in `y`. It's equivalent to `left_join(y, x)`, but the columns will be ordered differently. ```{r} df1 %>% right_join(df2) df2 %>% left_join(df1) ``` * `full_join()` includes all observations from `x` and `y`. ```{r} df1 %>% full_join(df2) ``` The left, right and full joins are collectively know as __outer joins__. When a row doesn't match in an outer join, the new variables are filled in with missing values. ### Observations While mutating joins are primarily used to add new variables, they can also generate new observations. If a match is not unique, a join will add all possible combinations (the Cartesian product) of the matching observations: ```{r} df1 <- tibble(x = c(1, 1, 2), y = 1:3) df2 <- tibble(x = c(1, 1, 2), z = c("a", "b", "a")) df1 %>% left_join(df2) ``` ## Filtering joins Filtering joins match obserations in the same way as mutating joins, but affect the observations, not the variables. There are two types: * `semi_join(x, y)` __keeps__ all observations in `x` that have a match in `y`. * `anti_join(x, y)` __drops__ all observations in `x` that have a match in `y`. These are most useful for diagnosing join mismatches. For example, there are many flights in the nycflights13 dataset that don't have a matching tail number in the planes table: ```{r} library("nycflights13") flights %>% anti_join(planes, by = "tailnum") %>% count(tailnum, sort = TRUE) ``` If you're worried about what observations your joins will match, start with a `semi_join()` or `anti_join()`. `semi_join()` and `anti_join()` never duplicate; they only ever remove observations. ```{r} df1 <- tibble(x = c(1, 1, 3, 4), y = 1:4) df2 <- tibble(x = c(1, 1, 2), z = c("a", "b", "a")) # Four rows to start with: df1 %>% nrow() # And we get four rows after the join df1 %>% inner_join(df2, by = "x") %>% nrow() # But only two rows actually match df1 %>% semi_join(df2, by = "x") %>% nrow() ``` ## Set operations The final type of two-table verb is set operations. These expect the `x` and `y` inputs to have the same variables, and treat the observations like sets: * `intersect(x, y)`: return only observations in both `x` and `y` * `union(x, y)`: return unique observations in `x` and `y` * `setdiff(x, y)`: return observations in `x`, but not in `y`. Given this simple data: ```{r} (df1 <- tibble(x = 1:2, y = c(1L, 1L))) (df2 <- tibble(x = 1:2, y = 1:2)) ``` The four possibilities are: ```{r} intersect(df1, df2) # Note that we get 3 rows, not 4 union(df1, df2) setdiff(df1, df2) setdiff(df2, df1) ``` ## Coercion rules When joining tables, dplyr is a little more conservative than base R about the types of variable that it considers equivalent. This is mostly likely to surprise if you're working factors: * Factors with different levels are coerced to character with a warning: ```{r} df1 <- tibble(x = 1, y = factor("a")) df2 <- tibble(x = 2, y = factor("b")) full_join(df1, df2) %>% str() ``` * Factors with the same levels in a different order are coerced to character with a warning: ```{r} df1 <- tibble(x = 1, y = factor("a", levels = c("a", "b"))) df2 <- tibble(x = 2, y = factor("b", levels = c("b", "a"))) full_join(df1, df2) %>% str() ``` * Factors are preserved only if the levels match exactly: ```{r} df1 <- tibble(x = 1, y = factor("a", levels = c("a", "b"))) df2 <- tibble(x = 2, y = factor("b", levels = c("a", "b"))) full_join(df1, df2) %>% str() ``` * A factor and a character are coerced to character with a warning: ```{r} df1 <- tibble(x = 1, y = "a") df2 <- tibble(x = 2, y = factor("a")) full_join(df1, df2) %>% str() ``` Otherwise logicals will be silently upcast to integer, and integer to numeric, but coercing to character will raise an error: ```{r, error = TRUE, purl = FALSE} df1 <- tibble(x = 1, y = 1L) df2 <- tibble(x = 2, y = 1.5) full_join(df1, df2) %>% str() df1 <- tibble(x = 1, y = 1L) df2 <- tibble(x = 2, y = "a") full_join(df1, df2) %>% str() ``` ## Multiple-table verbs dplyr does not provide any functions for working with three or more tables. Instead use `purrr::reduce()` or `Reduce()`, as described in [Advanced R](http://adv-r.had.co.nz/Functionals.html#functionals-fp), to iteratively combine the two-table verbs to handle as many tables as you need. dplyr/vignettes/aaa.html0000644000176200001440000000762213575706636015055 0ustar liggesusers autoprint bug

autoprint bug

dplyr/vignettes/dplyr.Rmd0000644000176200001440000004670213451046652015231 0ustar liggesusers--- title: "Introduction to dplyr" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Introduction to dplyr} %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} --- ```{r, echo = FALSE, message = FALSE} knitr::opts_chunk$set(collapse = T, comment = "#>") options(tibble.print_min = 4L, tibble.print_max = 4L) library(dplyr) library(ggplot2) set.seed(1014) ``` When working with data you must: * Figure out what you want to do. * Describe those tasks in the form of a computer program. * Execute the program. The dplyr package makes these steps fast and easy: * By constraining your options, it helps you think about your data manipulation challenges. * It provides simple "verbs", functions that correspond to the most common data manipulation tasks, to help you translate your thoughts into code. * It uses efficient backends, so you spend less time waiting for the computer. This document introduces you to dplyr's basic set of tools, and shows you how to apply them to data frames. dplyr also supports databases via the dbplyr package, once you've installed, read `vignette("dbplyr")` to learn more. ## Data: nycflights13 To explore the basic data manipulation verbs of dplyr, we'll use `nycflights13::flights`. This dataset contains all `r nrow(nycflights13::flights)` flights that departed from New York City in 2013. The data comes from the US [Bureau of Transportation Statistics](http://www.transtats.bts.gov/DatabaseInfo.asp?DB_ID=120&Link=0), and is documented in `?nycflights13` ```{r} library(nycflights13) dim(flights) flights ``` Note that `nycflights13::flights` is a tibble, a modern reimagining of the data frame. It's particularly useful for large datasets because it only prints the first few rows. You can learn more about tibbles at ; in particular you can convert data frames to tibbles with `as_tibble()`. ## Single table verbs Dplyr aims to provide a function for each basic verb of data manipulation: * `filter()` to select cases based on their values. * `arrange()` to reorder the cases. * `select()` and `rename()` to select variables based on their names. * `mutate()` and `transmute()` to add new variables that are functions of existing variables. * `summarise()` to condense multiple values to a single value. * `sample_n()` and `sample_frac()` to take random samples. ### Filter rows with `filter()` `filter()` allows you to select a subset of rows in a data frame. Like all single verbs, the first argument is the tibble (or data frame). The second and subsequent arguments refer to variables within that data frame, selecting rows where the expression is `TRUE`. For example, we can select all flights on January 1st with: ```{r} filter(flights, month == 1, day == 1) ``` This is rougly equivalent to this base R code: ```{r, eval = FALSE} flights[flights$month == 1 & flights$day == 1, ] ``` ### Arrange rows with `arrange()` `arrange()` works similarly to `filter()` except that instead of filtering or selecting rows, it reorders them. It takes a data frame, and a set of column names (or more complicated expressions) to order by. If you provide more than one column name, each additional column will be used to break ties in the values of preceding columns: ```{r} arrange(flights, year, month, day) ``` Use `desc()` to order a column in descending order: ```{r} arrange(flights, desc(arr_delay)) ``` ### Select columns with `select()` Often you work with large datasets with many columns but only a few are actually of interest to you. `select()` allows you to rapidly zoom in on a useful subset using operations that usually only work on numeric variable positions: ```{r} # Select columns by name select(flights, year, month, day) # Select all columns between year and day (inclusive) select(flights, year:day) # Select all columns except those from year to day (inclusive) select(flights, -(year:day)) ``` There are a number of helper functions you can use within `select()`, like `starts_with()`, `ends_with()`, `matches()` and `contains()`. These let you quickly match larger blocks of variables that meet some criterion. See `?select` for more details. You can rename variables with `select()` by using named arguments: ```{r} select(flights, tail_num = tailnum) ``` But because `select()` drops all the variables not explicitly mentioned, it's not that useful. Instead, use `rename()`: ```{r} rename(flights, tail_num = tailnum) ``` ### Add new columns with `mutate()` Besides selecting sets of existing columns, it's often useful to add new columns that are functions of existing columns. This is the job of `mutate()`: ```{r} mutate(flights, gain = arr_delay - dep_delay, speed = distance / air_time * 60 ) ``` `dplyr::mutate()` is similar to the base `transform()`, but allows you to refer to columns that you've just created: ```{r} mutate(flights, gain = arr_delay - dep_delay, gain_per_hour = gain / (air_time / 60) ) ``` If you only want to keep the new variables, use `transmute()`: ```{r} transmute(flights, gain = arr_delay - dep_delay, gain_per_hour = gain / (air_time / 60) ) ``` ### Summarise values with `summarise()` The last verb is `summarise()`. It collapses a data frame to a single row. ```{r} summarise(flights, delay = mean(dep_delay, na.rm = TRUE) ) ``` It's not that useful until we learn the `group_by()` verb below. ### Randomly sample rows with `sample_n()` and `sample_frac()` You can use `sample_n()` and `sample_frac()` to take a random sample of rows: use `sample_n()` for a fixed number and `sample_frac()` for a fixed fraction. ```{r} sample_n(flights, 10) sample_frac(flights, 0.01) ``` Use `replace = TRUE` to perform a bootstrap sample. If needed, you can weight the sample with the `weight` argument. ### Commonalities You may have noticed that the syntax and function of all these verbs are very similar: * The first argument is a data frame. * The subsequent arguments describe what to do with the data frame. You can refer to columns in the data frame directly without using `$`. * The result is a new data frame Together these properties make it easy to chain together multiple simple steps to achieve a complex result. These five functions provide the basis of a language of data manipulation. At the most basic level, you can only alter a tidy data frame in five useful ways: you can reorder the rows (`arrange()`), pick observations and variables of interest (`filter()` and `select()`), add new variables that are functions of existing variables (`mutate()`), or collapse many values to a summary (`summarise()`). The remainder of the language comes from applying the five functions to different types of data. For example, I'll discuss how these functions work with grouped data. ## Patterns of operations The dplyr verbs can be classified by the type of operations they accomplish (we sometimes speak of their **semantics**, i.e., their meaning). The most important and useful distinction is between grouped and ungrouped operations. In addition, it is helpful to have a good grasp of the difference between select and mutate operations. ### Grouped operations The dplyr verbs are useful on their own, but they become even more powerful when you apply them to groups of observations within a dataset. In dplyr, you do this with the `group_by()` function. It breaks down a dataset into specified groups of rows. When you then apply the verbs above on the resulting object they'll be automatically applied "by group". Grouping affects the verbs as follows: * grouped `select()` is the same as ungrouped `select()`, except that grouping variables are always retained. * grouped `arrange()` is the same as ungrouped; unless you set `.by_group = TRUE`, in which case it orders first by the grouping variables * `mutate()` and `filter()` are most useful in conjunction with window functions (like `rank()`, or `min(x) == x`). They are described in detail in `vignette("window-functions")`. * `sample_n()` and `sample_frac()` sample the specified number/fraction of rows in each group. * `summarise()` computes the summary for each group. In the following example, we split the complete dataset into individual planes and then summarise each plane by counting the number of flights (`count = n()`) and computing the average distance (`dist = mean(distance, na.rm = TRUE)`) and arrival delay (`delay = mean(arr_delay, na.rm = TRUE)`). We then use ggplot2 to display the output. ```{r, warning = FALSE, message = FALSE, fig.width = 6} by_tailnum <- group_by(flights, tailnum) delay <- summarise(by_tailnum, count = n(), dist = mean(distance, na.rm = TRUE), delay = mean(arr_delay, na.rm = TRUE)) delay <- filter(delay, count > 20, dist < 2000) # Interestingly, the average delay is only slightly related to the # average distance flown by a plane. ggplot(delay, aes(dist, delay)) + geom_point(aes(size = count), alpha = 1/2) + geom_smooth() + scale_size_area() ``` You use `summarise()` with __aggregate functions__, which take a vector of values and return a single number. There are many useful examples of such functions in base R like `min()`, `max()`, `mean()`, `sum()`, `sd()`, `median()`, and `IQR()`. dplyr provides a handful of others: * `n()`: the number of observations in the current group * `n_distinct(x)`:the number of unique values in `x`. * `first(x)`, `last(x)` and `nth(x, n)` - these work similarly to `x[1]`, `x[length(x)]`, and `x[n]` but give you more control over the result if the value is missing. For example, we could use these to find the number of planes and the number of flights that go to each possible destination: ```{r} destinations <- group_by(flights, dest) summarise(destinations, planes = n_distinct(tailnum), flights = n() ) ``` When you group by multiple variables, each summary peels off one level of the grouping. That makes it easy to progressively roll-up a dataset: ```{r} daily <- group_by(flights, year, month, day) (per_day <- summarise(daily, flights = n())) (per_month <- summarise(per_day, flights = sum(flights))) (per_year <- summarise(per_month, flights = sum(flights))) ``` However you need to be careful when progressively rolling up summaries like this: it's ok for sums and counts, but you need to think about weighting for means and variances (it's not possible to do this exactly for medians). ### Selecting operations One of the appealing features of dplyr is that you can refer to columns from the tibble as if they were regular variables. However, the syntactic uniformity of referring to bare column names hides semantical differences across the verbs. A column symbol supplied to `select()` does not have the same meaning as the same symbol supplied to `mutate()`. Selecting operations expect column names and positions. Hence, when you call `select()` with bare variable names, they actually represent their own positions in the tibble. The following calls are completely equivalent from dplyr's point of view: ```{r} # `year` represents the integer 1 select(flights, year) select(flights, 1) ``` By the same token, this means that you cannot refer to variables from the surrounding context if they have the same name as one of the columns. In the following example, `year` still represents 1, not 5: ```r year <- 5 select(flights, year) ``` One useful subtlety is that this only applies to bare names and to selecting calls like `c(year, month, day)` or `year:day`. In all other cases, the columns of the data frame are not put in scope. This allows you to refer to contextual variables in selection helpers: ```{r} year <- "dep" select(flights, starts_with(year)) ``` These semantics are usually intuitive. But note the subtle difference: ```{r} year <- 5 select(flights, year, identity(year)) ``` In the first argument, `year` represents its own position `1`. In the second argument, `year` is evaluated in the surrounding context and represents the fifth column. For a long time, `select()` used to only understand column positions. Counting from dplyr 0.6, it now understands column names as well. This makes it a bit easier to program with `select()`: ```{r} vars <- c("year", "month") select(flights, vars, "day") ``` Note that the code above is somewhat unsafe because you might have added a column named `vars` to the tibble, or you might apply the code to another data frame containing such a column. To avoid this issue, you can wrap the variable in an `identity()` call as we mentioned above, as this will bypass column names. However, a more explicit and general method that works in all dplyr verbs is to unquote the variable with the `!!` operator. This tells dplyr to bypass the data frame and to directly look in the context: ```{r} # Let's create a new `vars` column: flights$vars <- flights$year # The new column won't be an issue if you evaluate `vars` in the # context with the `!!` operator: vars <- c("year", "month", "day") select(flights, !! vars) ``` This operator is very useful when you need to use dplyr within custom functions. You can learn more about it in `vignette("programming")`. However it is important to understand the semantics of the verbs you are unquoting into, that is, the values they understand. As we have just seen, `select()` supports names and positions of columns. But that won't be the case in other verbs like `mutate()` because they have different semantics. ### Mutating operations Mutate semantics are quite different from selection semantics. Whereas `select()` expects column names or positions, `mutate()` expects *column vectors*. Let's create a smaller tibble for clarity: ```{r} df <- select(flights, year:dep_time) ``` When we use `select()`, the bare column names stand for ther own positions in the tibble. For `mutate()` on the other hand, column symbols represent the actual column vectors stored in the tibble. Consider what happens if we give a string or a number to `mutate()`: ```{r} mutate(df, "year", 2) ``` `mutate()` gets length-1 vectors that it interprets as new columns in the data frame. These vectors are recycled so they match the number of rows. That's why it doesn't make sense to supply expressions like `"year" + 10` to `mutate()`. This amounts to adding 10 to a string! The correct expression is: ```{r} mutate(df, year + 10) ``` In the same way, you can unquote values from the context if these values represent a valid column. They must be either length 1 (they then get recycled) or have the same length as the number of rows. In the following example we create a new vector that we add to the data frame: ```{r} var <- seq(1, nrow(df)) mutate(df, new = var) ``` A case in point is `group_by()`. While you might think it has select semantics, it actually has mutate semantics. This is quite handy as it allows to group by a modified column: ```{r} group_by(df, month) group_by(df, month = as.factor(month)) group_by(df, day_binned = cut(day, 3)) ``` This is why you can't supply a column name to `group_by()`. This amounts to creating a new column containing the string recycled to the number of rows: ```{r} group_by(df, "month") ``` Since grouping with select semantics can be sometimes useful as well, we have added the `group_by_at()` variant. In dplyr, variants suffixed with `_at()` support selection semantics in their second argument. You just need to wrap the selection with `vars()`: ```{r} group_by_at(df, vars(year:day)) ``` You can read more about the `_at()` and `_if()` variants in the `?scoped` help page. ## Piping The dplyr API is functional in the sense that function calls don't have side-effects. You must always save their results. This doesn't lead to particularly elegant code, especially if you want to do many operations at once. You either have to do it step-by-step: ```{r, eval = FALSE} a1 <- group_by(flights, year, month, day) a2 <- select(a1, arr_delay, dep_delay) a3 <- summarise(a2, arr = mean(arr_delay, na.rm = TRUE), dep = mean(dep_delay, na.rm = TRUE)) a4 <- filter(a3, arr > 30 | dep > 30) ``` Or if you don't want to name the intermediate results, you need to wrap the function calls inside each other: ```{r} filter( summarise( select( group_by(flights, year, month, day), arr_delay, dep_delay ), arr = mean(arr_delay, na.rm = TRUE), dep = mean(dep_delay, na.rm = TRUE) ), arr > 30 | dep > 30 ) ``` This is difficult to read because the order of the operations is from inside to out. Thus, the arguments are a long way away from the function. To get around this problem, dplyr provides the `%>%` operator from magrittr. `x %>% f(y)` turns into `f(x, y)` so you can use it to rewrite multiple operations that you can read left-to-right, top-to-bottom: ```{r, eval = FALSE} flights %>% group_by(year, month, day) %>% select(arr_delay, dep_delay) %>% summarise( arr = mean(arr_delay, na.rm = TRUE), dep = mean(dep_delay, na.rm = TRUE) ) %>% filter(arr > 30 | dep > 30) ``` ## Other data sources As well as data frames, dplyr works with data that is stored in other ways, like data tables, databases and multidimensional arrays. ### Data table dplyr also provides [data table](http://datatable.r-forge.r-project.org/) methods for all verbs through [dtplyr](http://github.com/hadley/dtplyr). If you're using data.tables already this lets you to use dplyr syntax for data manipulation, and data.table for everything else. For multiple operations, data.table can be faster because you usually use it with multiple verbs simultaneously. For example, with data table you can do a mutate and a select in a single step. It's smart enough to know that there's no point in computing the new variable for rows you're about to throw away. The advantages of using dplyr with data tables are: * For common data manipulation tasks, it insulates you from the reference semantics of data.tables, and protects you from accidentally modifying your data. * Instead of one complex method built on the subscripting operator (`[`), it provides many simple methods. ### Databases dplyr also allows you to use the same verbs with a remote database. It takes care of generating the SQL for you so that you can avoid the cognitive challenge of constantly switching between languages. To use these capabilities, you'll need to install the dbplyr package and then read `vignette("dbplyr")` for the details. ### Multidimensional arrays / cubes `tbl_cube()` provides an experimental interface to multidimensional arrays or data cubes. If you're using this form of data in R, please get in touch so I can better understand your needs. ## Comparisons Compared to all existing options, dplyr: * abstracts away how your data is stored, so that you can work with data frames, data tables and remote databases using the same set of functions. This lets you focus on what you want to achieve, not on the logistics of data storage. * provides a thoughtful default `print()` method that doesn't automatically print pages of data to the screen (this was inspired by data table's output). Compared to base functions: * dplyr is much more consistent; functions have the same interface. So once you've mastered one, you can easily pick up the others * base functions tend to be based around vectors; dplyr is based around data frames Compared to plyr, dplyr: * is much much faster * provides a better thought out set of joins * only provides tools for working with data frames (e.g. most of dplyr is equivalent to `ddply()` + various functions, `do()` is equivalent to `dlply()`) Compared to virtual data frame approaches: * it doesn't pretend that you have a data frame: if you want to run lm etc, you'll still need to manually pull down the data * it doesn't provide methods for R summary functions (e.g. `mean()`, or `sum()`) dplyr/vignettes/aaa.R0000644000176200001440000000015613575706635014304 0ustar liggesusers## ----setup, include = FALSE---------------------------------------------- library(tibble) tibble(a = 1:10) dplyr/vignettes/compatibility.Rmd0000644000176200001440000002334613614573562016755 0ustar liggesusers--- title: "dplyr compatibility" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{dplyr compatibility} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r setup, include = FALSE} library(dplyr) knitr::opts_chunk$set(collapse = T, comment = "#>") ``` This vignette is aimed at package authors who need to update their code because of a backward incompatible change to dplyr. We do try and minimise backward incompatible changes as much as possible, but sometimes they are necessary in order to radically simplify existing code, or unlock a lot of potential value in the future. This vignette starts with some general advice on writing package code that works with multiple version of dplyr, then continues to discuss specific changes in dplyr versions. ## Working with multiple dplyr versions Ideally, you want to make sure that your package works with both the released version and the development version of dplyr. This is typically a little bit more work, but has two big advantages: 1. It's more convenient for your users, since they're not forced to update dplyr if they don't want to) 1. It's easier on CRAN since it doesn't require a massive coordinated release of multiple packages. To make code work with multiple versions of a package, your first tool is the simple if statement: ```{r, results = "hide"} if (utils::packageVersion("dplyr") > "0.5.0") { # code for new version } else { # code for old version } ``` Always condition on `> current-version`, not `>= next-version` because this will ensure that this branch is also used for the development version of the package. For example, if the current release is version "0.5.0", the development version will be "0.5.0.9000". Occasionally, you'll run into a situation where the `NAMESPACE` has changed and you need to conditionally import different functions. This typically occurs when functions are moved from one package to another. We try out best to provide automatic fallbacks, but this is not always possible. Often you can work around the problem by avoiding `importFrom` and using `::` instead. Do this where possible: ```{r, eval = FALSE} if (utils::packageVersion("dplyr") > "0.5.0") { dbplyr::build_sql(...) } else { dplyr::build_sql(...) } ``` This will generate an `R CMD check` NOTE (because the one of the functions will always be missing), but this is ok. Simply explain that you get the note because you have written a wrapper to make sure your code is backward compatible. Sometimes it's not possible to avoid `importFrom()`. For example you might be importing a generic so that you can define a method for it. In this case, you can take advantage of a little-known feature in the `NAMESPACE` file: you can include `if` statements. ```{r} #' @rawNamespace #' if (utils::packageVersion("dplyr") > "0.5.0") { #' importFrom("dbplyr", "build_sql") #' } else { #' importFrom("dplyr", "build_sql") #' } ``` ## dplyr 0.6.0 ### Database code moves to dbplyr Almost all database related code has been moved out of dplyr and into a new package, [dbplyr](http://github.com/hadley/dbplyr/). This makes dplyr simpler, and will make it easier to release fixes for bugs that only affect databases. If you've implemented a database backend for dplyr, please read the [backend news](https://github.com/hadley/dbplyr/blob/master/NEWS.md#backends) on the backend. Depending on what generics you use, and what generics you provide methods for you, you may need to write some conditional code. To help make this easier we've written `wrap_dbplyr_obj()` which will write the helper code for you: ```{r, eval = FALSE} wrap_dbplyr_obj("build_sql") wrap_dbplyr_obj("base_agg") ``` Simply copy the results of this function in your package. These will generate `R CMD check` NOTES, so make sure to tell CRAN that this is to ensure backward compatibility. ### Deprecation of underscored `verbs_()` Because the tidyeval framework allows us to combine SE and NSE semantics within the same functions, the underscored verbs have been softly deprecated. #### For users of SE_ verbs The legacy underscored versions take objects for which a `lazyeval::as.lazy()` method is defined. This includes symbols and calls, strings, and formulas. All of these objects have been replaced with quosures and you can call tidyeval verbs with unquoted quosures: ```{r, eval = FALSE} quo <- quo(cyl) select(mtcars, !! quo) ``` Symbolic expressions are also supported, but note that bare symbols and calls do not carry scope information. If you're referring to objects in the data frame, it's safe to omit specifying an enclosure: ```{r, results = "hide"} sym <- quote(cyl) select(mtcars, !! sym) call <- quote(mean(cyl)) summarise(mtcars, !! call) ``` Transforming objects into quosures is generally straightforward. To enclose with the current environment, you can unquote directly in `quo()` or you can use `as_quosure()`: ```{r} quo(!! sym) quo(!! call) rlang::as_quosure(sym) rlang::as_quosure(call) ``` Note that while formulas and quosures are very similar objects (and in the most general sense, formulas are quosures), they can't be used interchangeably in tidyeval functions. Early implementations did treat bare formulas as quosures, but this created compatibility issues with modelling functions of the stats package. Fortunately, it's easy to transform formulas to quosures that will self-evaluate in tidyeval functions: ```{r} f <- ~cyl f rlang::as_quosure(f) ``` Finally, and perhaps most importantly, **strings are not and should not be parsed**. As developers, it is tempting to try and solve problems using strings because we have been trained to work with strings rather than quoted expressions. However it's almost always the wrong way to approach the problem. The exception is for creating symbols. In that case it is perfectly legitimate to use strings: ```{r} rlang::sym("cyl") rlang::syms(letters[1:3]) ``` But you should never use strings to create calls. Instead you can use quasiquotation: ```{r} syms <- rlang::syms(c("foo", "bar", "baz")) quo(my_call(!!! syms)) fun <- rlang::sym("my_call") quo((!!fun)(!!! syms)) ``` Or create the call with `call2()`: ```{r} call <- rlang::call2("my_call", !!! syms) call rlang::as_quosure(call) # Or equivalently: quo(!! rlang::call2("my_call", !!! syms)) ``` Note that idioms based on `interp()` should now generally be avoided and replaced with quasiquotation. Where you used to interpolate: ```{r, eval=FALSE} lazyeval::interp(~ mean(var), var = rlang::sym("mpg")) ``` You would now unquote: ```{r, eval=FALSE} var <- "mpg" quo(mean(!! rlang::sym(var))) ``` See also `vignette("programming")` for more about quasiquotation and quosures. #### For package authors For package authors, rlang provides a [compatibility file](https://github.com/hadley/rlang/blob/master/R/compat-lazyeval.R) that you can copy to your package. `compat_lazy()` and `compat_lazy_dots()` turn lazy-able objects into proper quosures. This helps providing an underscored version to your users for backward compatibility. For instance, here is how we defined the underscored version of `filter()` in dplyr 0.6: ```{r, eval = FALSE} filter_.tbl_df <- function(.data, ..., .dots = list()) { dots <- compat_lazy_dots(.dots, caller_env(), ...) filter(.data, !!! dots) } ``` With tidyeval, S3 dispatch to the correct method might be an issue. In the past, the genericity of dplyr verbs was accomplished by dispatching in the underscored versions. Now that those are deprecated, we've turned the non-underscored verbs into S3 generics. We maintain backward compatibility by redispatching to old underscored verbs in the default methods of the new S3 generics. For example, here is how we redispatch `filter()`: ```{r, eval = FALSE} filter.default <- function(.data, ...) { filter_(.data, .dots = compat_as_lazy_dots(...)) } ``` This gets the job done in most cases. However, the default method will not be called for objects inheriting from one of the classes for which we provide non-underscored methods: `data.frame`, `tbl_df`, `tbl_cube` and `grouped_df`. An example of this is the `sf` package whose objects have classes `c("sf", "data.frame")`. Authors of such packages should provide a method for the non-underscored generic in order to be compatible with dplyr: ```{r, eval = FALSE} filter.sf <- function(.data, ...) { st_as_sf(NextMethod()) } ``` If you need help with this, please let us know! ### Deprecation of `mutate_each()` and `summarise_each()` These functions have been replaced by a more complete family of functions. This family has suffixes `_if`, `_at` and `_all` and includes more verbs than just `mutate` `summarise`. If you need to update your code to the new family, there are two relevant functions depending on which variables you apply `funs()` to. If you called `mutate_each()` without supplying a selection of variables, `funs` is applied to all variables. In this case, you should update your code to use `mutate_all()` instead: ```{r, eval = FALSE} mutate_each(starwars, funs(as.character)) mutate_all(starwars, funs(as.character)) ``` Note that the new verbs support bare functions as well, so you don't necessarily need to wrap with `funs()`: ```{r, eval = FALSE} mutate_all(starwars, as.character) ``` On the other hand, if you supplied a variable selection, you should use `mutate_at()`. The variable selection should be wrapped with `vars()`. ```{r, eval = FALSE} mutate_each(starwars, funs(as.character), height, mass) mutate_at(starwars, vars(height, mass), as.character) ``` `vars()` supports all the selection helpers that you usually use with `select()`: ```{r, eval = FALSE} summarise_at(mtcars, vars(starts_with("d")), mean) ``` Note that intead of a `vars()` selection, you can also supply character vectors of column names: ```{r, eval = FALSE} mutate_at(starwars, c("height", "mass"), as.character) ``` dplyr/vignettes/future/0000755000176200001440000000000013614573562014742 5ustar liggesusersdplyr/vignettes/future/dplyr_0.8.0_new_hybrid.Rmd0000644000176200001440000002403713614573562021503 0ustar liggesusers--- title: "New hybrid" output: github_document --- # overview This is a complete redesign of how we evaluate expression in dplyr. We no longer attempt to evaluate part of an expression. We now either: - recognize the entire expression, e.g. `n()` or `mean(x)` and use C++ code to evaluate it (this is what we call hybrid evaluation now, but I guess another term would be better. - if not, we use standard evaluation in a suitable environment # data mask When used internally in the c++ code, a tibble become one of the 3 classes `GroupedDataFrame`, `RowwiseDataFrame` or `NaturalDataFrame`. Most internal code is templated by these classes, e.g. `summarise` is: ```cpp // [[Rcpp::export]] SEXP summarise_impl(DataFrame df, QuosureList dots) { check_valid_colnames(df); if (is(df)) { return summarise_grouped(df, dots); } else if (is(df)) { return summarise_grouped(df, dots); } else { return summarise_grouped(df, dots); } } ``` The `DataMask` template class is used by both hybrid and standard evaluation to extract the relevant information from the columns (original columns or columns that have just been made by `mutate()` or `summarise()`) # standard evaluation ## meta information about the groups The functions `n()`, `row_number()` and `group_indices()` when called without arguments lack contextual information, i.e. the current group size and index, so they look for that information a the special environment ```r n <- function() { from_context("..group_size") } ``` The DataMask class is responsible for updating the variables `..group_size` and `..group_number` ```cpp // update the data context variables, these are used by n(), ... get_context_env()["..group_size"] = indices.size(); get_context_env()["..group_number"] = indices.group() + 1; ``` all other functions can just be called with standard evaluation in the data mask ## active and resolved bindings When doing standard evaluation, we need to install a data mask that evaluates the symbols from the data to the relevant subset. The simple solution would be to update the data mask at each iteration with subsets for all the variables but that would be potentially expensive and a waste, as we might not need all of the variables at a given time, e.g. in this case: ```r iris %>% group_by(Species) %>% summarise(Sepal.Length = +mean(Sepal.Length)) ``` We only need to materialize `Sepal.Length`, we don't need the other variables. `DataMask` installs an active binding for each variable in one of (the top) the environment in the data mask ancestry, the active binding function is generated by this function so that it holds an index and a pointer to the data mask in its enclosure. ```r .make_active_binding_fun <- function(index, subsets){ function() { materialize_binding(index, subsets) } } ``` When hit, the active binding calls the materialize_binding function : ```cpp // [[Rcpp::export]] SEXP materialize_binding(int idx, XPtr mask) { return mask->materialize(idx); } ``` The `DataMask<>::materialize(idx)` method returns the materialized subset, but also: - install the result in the bottom environment of the data mask, so that it mask the active binding. The point is to call the active binding only once. - remembers that the binding at position `idx` has been materialized, so that before evaluating the same expression in the next group, it is proactively materialized, because it is very likely that we need the same variables for all groups When we move to the next expression to evaluate, `DataMask` forgets about the materialized bindings so that the active binding can be triggered again as needed. use case of the DataMask class - before evaluating expressions, construct a DataMask from a tibble ```cpp DataMask mask(tbl); ``` - before evaluating a new expression, we need to `rechain(parent_env)` to prepare the data mask to evaluate expression with a given parent environment. This "forgets" about the materialized bindings. ```cpp mask.rechain(quosure.env()); ``` - before evaluating the expression ona new group, the indices are updated, this includes rematerializing the already materialized bindings # hybrid evaluation ## Use of DataMask Hybrid evaluation also uses the `DataMask<>` class, but it only needs to quickly retrieve the data for an entire column. This is what the `maybe_get_subset_binding` method does. ```cpp // returns a pointer to the ColumnBinding if it exists // this is mostly used by the hybrid evaluation const ColumnBinding* maybe_get_subset_binding(const SymbolString& symbol) const { int pos = symbol_map.find(symbol); if (pos >= 0) { return &column_bindings[pos]; } else { return 0; } } ``` when the symbol map contains the binding, we get a `ColumnBinding*`. These objects hold these fields: ```cpp // is this a summary binding, i.e. does it come from summarise bool summary; // symbol of the binding SEXP symbol; // data. it is own either by the original data frame or by the // accumulator, so no need for additional protection here SEXP data; ``` hybrid evaluation only needs `summary` and `data`. ## Expression When attempting to evaluate an expression with the hybrid evaluator, we first construct an `Expression` object. This class has methods to quickly check if the expression can be managed, e.g. ```cpp // sum( ) and base::sum( ) if (expression.is_fun(s_sum, s_base, ns_base)) { Column x; if (expression.is_unnamed(0) && expression.is_column(0, x)) { return sum_(data, x, /* na.rm = */ false, op); } else { return R_UnboundValue; } } ``` This checks that the call matches `sum()` or `base::sum()` where `` is a column from the data mask. In that example, the `Expression` class checks that: - the first argument is not named - the first argument is a column from the data Otherwise it means it is an expression that we can't handle, so we return `R_UnboundValue` which is the hybrid evaluation way to signal it gives up on handling the expression, and that it should be evaluated with standard evaluation. Expression has the following methods: - `inline bool is_fun(SEXP symbol, SEXP pkg, SEXP ns)` : are we calling `fun` ? If so does `fun` curently resolve to the function we intend to (it might not if the function is masked, which allows to do trghings like this:) ```r > n <- function() 42 > summarise(iris, nn = n()) nn 1 42 ``` - `bool is_valid() const` : is the expression valid. the Expressio, constructor rules out a few expressions that hjave no chance of being handled, such as pkg::fun() when `pkg` is none of `dplyr`, `stats` or `base` - `SEXP value(int i) const` : the expression at position i - `bool is_named(int i, SEXP symbol) const` : is the i'th argument named `symbol` - `bool is_scalar_logical(int i, bool& test) const` : is the i'th argument a scalar logical, we need this for handling e.g. `na.rm = TRUE` - `bool is_scalar_int(int i, int& out) const` is the i'th argument a scalar int, we need this for `n = ` - `bool is_column(int i, Column& column) const` is the i'th argument a column. ## hybrid_do The `hybrid_do` function uses methods from `Expression` to quickly assess if it can handle the expression and then calls the relevant function from `dplyr::hybrid::` to create the result at once: ```cpp if (expression.is_fun(s_sum, s_base, ns_base)) { // sum( ) and base::sum( ) Column x; if (expression.is_unnamed(0) && expression.is_column(0, x)) { return sum_(data, x, /* na.rm = */ false, op); } } else if (expression.is_fun(s_mean, s_base, ns_base)) { // mean( ) and base::mean( ) Column x; if (expression.is_unnamed(0) && expression.is_column(0, x)) { return mean_(data, x, false, op); } } else if ... ``` The functions in the C++ `dplyr::hybrid::` namespace create objects whose classes hold: - the type of output they create - the information they need (e.g. the column, the value of na.rm, ...) These classes all have these methods: - `summarise()` to return a result of the same size as the number of groups. This is used when op is a `Summary`. This returns `R_UnboundValue` to give up when the class can't do that, e.g. the classes behind `lag` - `window()` to return a result of the same size as the number of rows in the original data set. The classes typically don't provide these methods directly, but rather inherit, via CRTP one of: - `HybridVectorScalarResult`, so that the class only has to provide a `process` method, for example the `Count` class: ```cpp template class Count : public HybridVectorScalarResult > { public: typedef HybridVectorScalarResult > Parent ; Count(const SlicedTibble& data) : Parent(data) {} int process(const typename SlicedTibble::slicing_index& indices) const { return indices.size(); } } ; ``` `HybridVectorScalarResult` uses the result of `process` in both `summarise()` and `window()` - `HybridVectorVectorResult` expects a `fill` method, e.g. implementation of `ntile(n=)` uses this class that derive from HybridVectorVectorResult. ```cpp template class Ntile1 : public HybridVectorVectorResult > { public: typedef HybridVectorVectorResult Parent; Ntile1(const SlicedTibble& data, int ntiles_): Parent(data), ntiles(ntiles_) {} void fill(const typename SlicedTibble::slicing_index& indices, Rcpp::IntegerVector& out) const { int m = indices.size(); for (int j = m - 1; j >= 0; j--) { out[ indices[j] ] = (int)floor((ntiles * j) / m) + 1; } } private: int ntiles; }; ``` The result of `fill` is only used in `window()`. The `summarise()` method simpliy returns `R_UnboundValue` to give up. dplyr/vignettes/future/dplyr_0.8.0.Rmd0000644000176200001440000002120113614573562017257 0ustar liggesusers--- title: "dplyr 0.8.0" --- ```{r, echo = FALSE, message = FALSE} knitr::opts_chunk$set(collapse = T, comment = "#>") options(tibble.print_min = 4L, tibble.print_max = 4L) library(dplyr) ``` # More consistent use of factors ## Motivation The work on making factors used more respectfully originates from the issue 341, which has been waiting for attention for the past four years. `#341` identified the need to take care of empty groups. Empty groups can arise from two situations: - when one of the grouping variable in `group_by()` is a factor and one of its levels has no data, e.g. ```{r} tibble( x = 1:2, f = factor(c("a", "b"), levels = c("a", "b", "c")) ) %>% group_by(f) ``` The factor `f` has 3 levels, but only two are present in the data. - when all of the data from one group is `filter()`ed out, e.g. ```{r} tibble( x = 1:3, f = factor(c("a", "b", "c"))) %>% group_by(f) %>% filter(x < 2) ``` In that case, the grouped data before the filter has one row per level of `f`, and the filter only keeps the first row so makes 2 empty groups. ## Previous behaviour Older versions of `dplyr` did not make empty groups, because: - `group_by()` was building the grouping metadata only from the rows of the data, i.e. ignoring the conceptual grouping structure. - `filter()` was making a lazily grouped tibble, recording only the names of grouping variables, without producing the metadata, which was automatically made by a subsequent `group_by` whenever this was necessary in the future. ## Recusive slicing grouping algorithm A new grouping algorithm, inspired from `tidyr::complete` is used in `dplyr` 0.8.0 to solve the first issue. The algorithm recursively goes through the grouping variables. When a grouping variable is a factor, the groups are made from its levels. On any other variable (`character`, `integer`, ...) the groups are made from the unique values. Let's have a look at some examples, we'll use `tally()` to reveal the grouping structure and counts of groups: ```{r} df <- tibble( x = c(1,2,1,2), f = factor(c("a", "b", "a", "b"), levels = c("a", "b", "c")) ) df %>% group_by(f) %>% tally() ``` In this first example, we group by a factor, so we get as many groups as the number of factors. ```{r} df %>% group_by(f, x) %>% tally() ``` Here we group by the factor `f` and the numeric vector `x`. Again we get 3 groups, because for the levels "a" and "b" of `f`, there is only one value of `x`. The third group, associated with the level "c" sets the value of `x` to `NA` out of thin air. We call this a *sentinel NA* and we might make it obvious later that this is not the same as if we had a missing value in the data. ```{r} df %>% group_by(x, f) %>% tally() ``` In this case, we get more groups, and consequently more empty groups, because of the recursive slicing, first we find 2 unique values for the variable `x` (1 and 2), then we group by the factor `f` and therefore get 3 groups (because 3 levels) for each unique value of `x`. ## Propagation of the grouping structure `filter()` has been reworked to respect the grouping stucture and gains the `.preserve` argument to control which groups to keep. When `.preserve` is set to `TRUE` (the default) the groups of the filtered tibble are the same as the groups of the original tibble. ```{r} df %>% group_by(x, f) %>% filter(x == 1) %>% tally() df %>% group_by(f, x) %>% filter(x == 1) %>% tally() ``` When `.preserve` is set to `FALSE` the grouping structure is recalculated after the filtering. ```{r} df %>% group_by(x, f) %>% filter(x == 1, .preserve = FALSE) %>% tally() ``` Here we only get 3 groups, from the 3 levels of `f` within the unique value of `x` ```{r} df %>% group_by(f, x) %>% filter(x == 1, .preserve = FALSE) %>% tally() ``` In that case, we get 3 groups, but the values of `x` are slightly different, i.e. the value of `x` associated with the level "b" in the empty group is a sentinel NA. # Tidy grouping structure Previous versions of `dplyr` used a messy collection of attributes in the "grouped_df" class, which did not make it easy to reason about. `dplyr` 0.8.0 structures all the grouping information in a tibble with `n+1` columns (where `n` is the number of grouping variables) in the "groups" attribute. ```{r} df %>% group_by(f, x) %>% attr("groups") ``` The first columns identify the data for each of the group, one row per group. This is equivalent to the "labels" attribute used in previous versions of `dplyr`. The last column, always called `.rows` is a list column of integer vectors (possibly of length 0 for empty groups) identifying the indices of all the rows in the data that belong to the group. This is equivalent to the "indices" attribute used in previous versions. This grouping stucture tibble (maybe a gribble) can be retrieved by accessing the `groups` attribute, or preferably by using the `group_data()` generic, which has methods for ungrouped and row wise data too. ```{r} group_data(df) group_data(group_by(df, f)) group_data(rowwise(df)) ``` Similarly, the indices themselves can be retrieved using `group_rows()`: ```{r} group_rows(df) group_rows(group_by(df, f)) group_rows(rowwise(df)) ``` Having a consistent representation of the grouping structure makes it easier to reason about, and might open opportunities to discuss alternative ways of grouping # Hybrid evaluation cleanup **pending** The initial goal for hybrid evaluation was to bypass potentially expensive R evaluation, and replace it with more efficient C++ code. Unfortunately, there are situations where hybrid evaluation creates problems. There are two forms of hybrid evaluation in dplyr at the moment: full hybrid evaluation and hybrid folding. ## Full hybrid evaluation When the entire (summarise or mutate) expression can be handled, e.g. in `group_by(...) %>% summarise(m = mean(x))` the `mean` hybrid handler takes care of everything, i.e. calculate the mean of x for each group and structure that into a numeric vector. This does not need to allocate memory for each subset of `x` or the result of `mean(x)`. In addition, because it is dispatched internally, it does not need to pay the expensive price of S3 dispatch of the `mean` generic function from `base::`. This is where hybrid evaluation really makes a difference. Currently this is driven by a set of C++ classes inheriting from the virtual class `Result`, which is used for summary functions (such as `mean`) and window functions (such as `lead`). The proposal here is to rebase hybrid handlers on two virtual class (maybe templates) instead of one: - `template Window` would give a vector of type RTYPE of the right size. - `template Summary` would summarise into of value of the right type. `mutate` and `summarise` would recognise expressions that are hybridable, and use the information to allocate the result then iterate through the groups to fill the result. This needs careful refactoring. We believe that this will make the code much simpler, with the consequence that it will be easier to write new hybrid handlers, i.e. we can imagine something like `x == 2` to be handled hybridly in `filter` by using a class deriving from `Window`. ## Hybrid folding This is where hybrid evaluation creates problems, because it is sometimes too eager, and generally cannot faithfully mimic standard R evaulation. The original idea was to handle *parts* of the expression using the hybrid handlers, e.g. in the expression `%>% group_by(...) %>% summarise(m = 1 + mean(x))` we would handle `mean(x)` with the hybrid handler for `mean`, fold that into the expression and then fall back to r evaluation once we can no longer hybrid evaluate anything. Folding cannot be done once and for all groups, it is performed (including going through the expressions) for each group which has a price, we have to end with an R evaluation anyway, and then after that we still have no idea of what the result will be, so we collect and coerce the result with care. This has been the source of most of the "surprises" and also comes at a huge cost in terms of code complexity, and therefore maintainability. The proposal here is to totally abandon hybrid folding and replace it with an approach based on regular R evaluation. Expressions would be evaluated in an environment in which the names of the columns are mapped to their subsets in the current group, and where functions such as `n()` and `row_number()` produce the desired result. Letting go of hybrid folding and making it easier to implement full hybrid handlers will make hybrid evaluation simpler, more robust and less surprising. dplyr/vignettes/programming.Rmd0000644000176200001440000004464313614573562016431 0ustar liggesusers--- title: "Programming with dplyr" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Programming with dplyr} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- ```{r setup, echo = FALSE, message = FALSE} knitr::opts_chunk$set(collapse = T, comment = "#>") options(tibble.print_min = 4L, tibble.print_max = 4L) library(dplyr) set.seed(1014) ``` Most dplyr functions use non-standard evaluation (NSE). This is a catch-all term that means they don't follow the usual R rules of evaluation. Instead, they capture the expression that you typed and evaluate it in a custom way. This has two main benefits for dplyr code: * Operations on data frames can be expressed succinctly because you don't need to repeat the name of the data frame. For example, you can write `filter(df, x == 1, y == 2, z == 3)` instead of `df[df$x == 1 & df$y ==2 & df$z == 3, ]`. * dplyr can choose to compute results in a different way to base R. This is important for database backends because dplyr itself doesn't do any work, but instead generates the SQL that tells the database what to do. Unfortunately these benefits do not come for free. There are two main drawbacks: * Most dplyr arguments are not __referentially transparent__. That means you can't replace a value with a seemingly equivalent object that you've defined elsewhere. In other words, this code: ```{r} df <- tibble(x = 1:3, y = 3:1) filter(df, x == 1) ``` Is not equivalent to this code: ```{r, error = TRUE} my_var <- x filter(df, my_var == 1) ``` nor to this code: ```{r, error = TRUE} my_var <- "x" filter(df, my_var == 1) ``` This makes it hard to create functions with arguments that change how dplyr verbs are computed. * dplyr code is ambiguous. Depending on what variables are defined where, `filter(df, x == y)` could be equivalent to any of: ```{r, eval = FALSE} df[df$x == df$y, ] df[df$x == y, ] df[x == df$y, ] df[x == y, ] ``` This is useful when working interactively (because it saves typing and you quickly spot problems) but makes functions more unpredictable than you might desire. Fortunately, dplyr provides tools to overcome these challenges. They require a little more typing, but a small amount of upfront work is worth it because they help you save time in the long run. This vignette has two goals: * Show you how to use dplyr's __pronouns__ and __quasiquotation__ to write reliable functions that reduce duplication in your data analysis code. * To teach you the underlying theory including __quosures__, the data structure that stores both an expression and an environment, and __tidyeval__, the underlying toolkit. We'll start with a warmup, tying this problem to something you're more familiar with, then move on to some practical tools, then dive into the deeper theory. ## Warm up You might not have realised it, but you're already accomplished at solving this type of problem in another domain: strings. It's obvious that this function doesn't do what you want: ```{r} greet <- function(name) { "How do you do, name?" } greet("Hadley") ``` That's because `"` "quotes" its input: it doesn't interpret what you've typed, it just stores it in a string. One way to make the function do what you want is to use `paste()` to build up the string piece by piece: ```{r} greet <- function(name) { paste0("How do you do, ", name, "?") } greet("Hadley") ``` Another approach is exemplified by the __glue__ package: it allows you to "unquote" components of a string, replacing the string with the value of the R expression. This allows an elegant implementation of our function because `{name}` is replaced with the value of the `name` argument. ```{r} greet <- function(name) { glue::glue("How do you do, {name}?") } greet("Hadley") ``` ## Programming recipes The following recipes walk you through the basics of tidyeval, with the nominal goal of reducing duplication in dplyr code. The examples here are somewhat inauthentic because we've reduced them down to very simple components to make them easier to understand. They're so simple that you might wonder why we bother writing a function at all. But it's a good idea to learn the ideas on simple examples, so that you're better prepared to apply them to the more complex situations you'll see in your own code. ### Different data sets You already know how to write functions that work with the first argument of dplyr verbs: the data. That's because dplyr doesn't do anything special with that argument, so it's referentially transparent. For example, if you saw repeated code like this: ```{r, eval = FALSE} mutate(df1, y = a + x) mutate(df2, y = a + x) mutate(df3, y = a + x) mutate(df4, y = a + x) ``` You could already write a function to capture that duplication: ```{r} mutate_y <- function(df) { mutate(df, y = a + x) } ``` Unfortunately, there's a drawback to this simple approach: it can fail silently if one of the variables isn't present in the data frame, but is present in the global environment. ```{r} df1 <- tibble(x = 1:3) a <- 10 mutate_y(df1) ``` We can fix that ambiguity by being more explicit and using the `.data` pronoun. This will throw an informative error if the variable doesn't exist: ```{r, error = TRUE} mutate_y <- function(df) { mutate(df, y = .data$a + .data$x) } mutate_y(df1) ``` If this function is in a package, using `.data` also prevents `R CMD check` from giving a NOTE about undefined global variables (provided that you've also imported `rlang::.data` with `@importFrom rlang .data`). ### Different expressions Writing a function is hard if you want one of the arguments to be a variable name (like `x`) or an expression (like `x + y`). That's because dplyr automatically "quotes" those inputs, so they are not referentially transparent. Let's start with a simple case: you want to vary the grouping variable for a data summarization. ```{r} df <- tibble( g1 = c(1, 1, 2, 2, 2), g2 = c(1, 2, 1, 2, 1), a = sample(5), b = sample(5) ) df %>% group_by(g1) %>% summarise(a = mean(a)) df %>% group_by(g2) %>% summarise(a = mean(a)) ``` You might hope that this will work: ```{r, error = TRUE} my_summarise <- function(df, group_var) { df %>% group_by(group_var) %>% summarise(a = mean(a)) } my_summarise(df, g1) ``` But it doesn't. Maybe providing the variable name as a string will fix things? ```{r, error = TRUE} my_summarise(df, "g2") ``` Nope. If you look carefully at the error message, you'll see that it's the same in both cases. `group_by()` works like `"`: it doesn't evaluate its input; it quotes it. To make this function work, we need to do two things. We need to quote the input ourselves (so `my_summarise()` can take a bare variable name like `group_by()`), and then we need to tell `group_by()` not to quote its input (because we've done the quoting). How do we quote the input? We can't use `""` to quote the input, because that gives us a string. Instead we need a function that captures the expression and its environment (we'll come back to why this is important later on). There are two possible options we could use in base R, the function `quote()` and the operator `~`. Neither of these work quite the way we want, so we need a new function: `quo()`. `quo()` works like `"`: it quotes its input rather than evaluating it. ```{r} quo(g1) quo(a + b + c) quo("a") ``` `quo()` returns a __quosure__, which is a special type of formula. You'll learn more about quosures later on. Now that we've captured this expression, how do we use it with `group_by()`? It doesn't work if we just shove it into our naive approach: ```{r, error = TRUE} my_summarise(df, quo(g1)) ``` We get the same error as before, because we haven't yet told `group_by()` that we're taking care of the quoting. In other words, we need to tell `group_by()` not to quote its input, because it has been pre-quoted by `my_summarise()`. Yet another way of saying the same thing is that we want to __unquote__ `group_var`. In dplyr (and in tidyeval in general) you use `!!` to say that you want to unquote an input so that it's evaluated, not quoted. This gives us a function that actually does what we want. ```{r} my_summarise <- function(df, group_var) { df %>% group_by(!! group_var) %>% summarise(a = mean(a)) } my_summarise(df, quo(g1)) ``` Huzzah! There's just one step left: we want to call this function like we call `group_by()`: ```{r, eval = FALSE} my_summarise(df, g1) ``` This doesn't work because there's no object called `g1`. We need to capture what the user of the function typed and quote it for them. You might try using `quo()` to do that: ```{r, error = TRUE} my_summarise <- function(df, group_var) { quo_group_var <- quo(group_var) print(quo_group_var) df %>% group_by(!! quo_group_var) %>% summarise(a = mean(a)) } my_summarise(df, g1) ``` I've added a `print()` call to make it obvious what's going wrong here: `quo(group_var)` always returns `~group_var`. It is being too literal! We want it to substitute the value that the user supplied, i.e. to return `~g1`. By analogy to strings, we don't want `""`, instead we want some function that turns an argument into a string. That's the job of `enquo()`. `enquo()` uses some dark magic to look at the argument, see what the user typed, and return that value as a quosure. (Technically, this works because function arguments are evaluated lazily, using a special data structure called a __promise__.) ```{r} my_summarise <- function(df, group_var) { group_var <- enquo(group_var) print(group_var) df %>% group_by(!! group_var) %>% summarise(a = mean(a)) } my_summarise(df, g1) ``` (If you're familiar with `quote()` and `substitute()` in base R, `quo()` is equivalent to `quote()` and `enquo()` is equivalent to `substitute()`.) You might wonder how to extend this to handle multiple grouping variables: we'll come back to that a little later. ### Different input variable Now let's tackle something a bit more complicated. The code below shows a duplicate `summarise()` statement where we compute three summaries, varying the input variable. ```{r} summarise(df, mean = mean(a), sum = sum(a), n = n()) summarise(df, mean = mean(a * b), sum = sum(a * b), n = n()) ``` To turn this into a function, we start by testing the basic approach interactively: we quote the variable with `quo()`, then unquoting it in the dplyr call with `!!`. Notice that we can unquote anywhere inside a complicated expression. ```{r} my_var <- quo(a) summarise(df, mean = mean(!! my_var), sum = sum(!! my_var), n = n()) ``` You can also wrap `quo()` around the dplyr call to see what will happen from dplyr's perspective. This is a very useful tool for debugging. ```{r} quo(summarise(df, mean = mean(!! my_var), sum = sum(!! my_var), n = n() )) ``` Now we can turn our code into a function (remembering to replace `quo()` with `enquo()`), and check that it works: ```{r} my_summarise2 <- function(df, expr) { expr <- enquo(expr) summarise(df, mean = mean(!! expr), sum = sum(!! expr), n = n() ) } my_summarise2(df, a) my_summarise2(df, a * b) ``` ### Different input and output variable The next challenge is to vary the name of the output variables: ```{r} mutate(df, mean_a = mean(a), sum_a = sum(a)) mutate(df, mean_b = mean(b), sum_b = sum(b)) ``` This code is similar to the previous example, but there are two new wrinkles: * We create the new names by pasting together strings, so we need `quo_name()` to convert the input expression to a string. * `!! mean_name = mean(!! expr)` isn't valid R code, so we need to use the `:=` helper provided by rlang. ```{r} my_mutate <- function(df, expr) { expr <- enquo(expr) mean_name <- paste0("mean_", quo_name(expr)) sum_name <- paste0("sum_", quo_name(expr)) mutate(df, !! mean_name := mean(!! expr), !! sum_name := sum(!! expr) ) } my_mutate(df, a) ``` ### Capturing multiple variables It would be nice to extend `my_summarise()` to accept any number of grouping variables. We need to make three changes: * Use `...` in the function definition so our function can accept any number of arguments. * Use `enquos()` to capture all the `...` as a list of formulas. * Use `!!!` instead of `!!` to __splice__ the arguments into `group_by()`. ```{r} my_summarise <- function(df, ...) { group_var <- enquos(...) df %>% group_by(!!! group_var) %>% summarise(a = mean(a)) } my_summarise(df, g1, g2) ``` `!!!` takes a list of elements and splices them into to the current call. Look at the bottom of the `!!!` and think `...`. ```{r} args <- list(na.rm = TRUE, trim = 0.25) quo(mean(x, !!! args)) args <- list(quo(x), na.rm = TRUE, trim = 0.25) quo(mean(!!! args)) ``` Now that you've learned the basics of tidyeval through some practical examples, we'll dive into the theory. This will help you generalise what you've learned here to new situations. ## Quoting Quoting is the action of capturing an expression instead of evaluating it. All expression-based functions quote their arguments and get the R code as an expression rather than the result of evaluating that code. If you are an R user, you probably quote expressions on a regular basis. One of the most important quoting operators in R is the _formula_. It is famously used for the specification of statistical models: ```{r} disp ~ cyl + drat ``` The other quoting operator in base R is `quote()`. It returns a raw expression rather than a formula: ```{r} # Computing the value of the expression: toupper(letters[1:5]) # Capturing the expression: quote(toupper(letters[1:5])) ``` (Note that despite being called the double quote, `"` is not a quoting operator in this context, because it generates a string, not an expression.) In practice, the formula is the better of the two options because it captures the code and its execution __environment__. This is important because even simple expression can yield different values in different environments. For example, the `x` in the following two expressions refers to different values: ```{r} f <- function(x) { quo(x) } x1 <- f(10) x2 <- f(100) ``` It might look like the expressions are the same if you print them out. ```{r} x1 x2 ``` But if you inspect the environments using `rlang::get_env()` --- they're different. ```{r, message = FALSE} library(rlang) get_env(x1) get_env(x2) ``` Further, when we evaluate those formulas using `rlang::eval_tidy()`, we see that they yield different values: ```{r} eval_tidy(x1) eval_tidy(x2) ``` This is a key property of R: one name can refer to different values in different environments. This is also important for dplyr, because it allows you to combine variables and objects in a call: ```{r} user_var <- 1000 mtcars %>% summarise(cyl = mean(cyl) * user_var) ``` When an object keeps track of an environment, it is said to have an enclosure. This is the reason that functions in R are sometimes referred to as closures: ```{r} typeof(mean) ``` For this reason we use a special name to refer to one-sided formulas: __quosures__. One-sided formulas are quotes (they carry an expression) with an environment. Quosures are regular R objects. They can be stored in a variable and inspected: ```{r} var <- ~toupper(letters[1:5]) var # You can extract its expression: get_expr(var) # Or inspect its enclosure: get_env(var) ``` ## Quasiquotation > Put simply, quasi-quotation enables one to introduce symbols that stand for > a linguistic expression in a given instance and are used as that linguistic > expression in a different instance. --- [Willard van Orman Quine](https://en.wikipedia.org/wiki/Quasi-quotation) Automatic quoting makes dplyr very convenient for interactive use. But if you want to program with dplyr, you need some way to refer to variables indirectly. The solution to this problem is __quasiquotation__, which allows you to evaluate directly inside an expression that is otherwise quoted. Quasiquotation was coined by Willard van Orman Quine in the 1940s, and was adopted for programming by the LISP community in the 1970s. All expression-based functions in the tidyeval framework support quasiquotation. Unquoting cancels quotation of parts of an expression. There are three types of unquoting: * basic * unquote splicing * unquoting names ### Unquoting The first important operation is the basic unquote, which comes in a functional form, `UQ()`, and as syntactic-sugar, `!!`. ```{r} # Here we capture `letters[1:5]` as an expression: quo(toupper(letters[1:5])) # Here we capture the value of `letters[1:5]` quo(toupper(!! letters[1:5])) quo(toupper(UQ(letters[1:5]))) ``` It is also possible to unquote other quoted expressions. Unquoting such symbolic objects provides a powerful way of manipulating expressions. ```{r} var1 <- quo(letters[1:5]) quo(toupper(!! var1)) ``` You can safely unquote quosures because they track their environments, and tidyeval functions know how to evaluate them. This allows any depth of quoting and unquoting. ```{r} my_mutate <- function(x) { mtcars %>% select(cyl) %>% slice(1:4) %>% mutate(cyl2 = cyl + (!! x)) } f <- function(x) quo(x) expr1 <- f(100) expr2 <- f(10) my_mutate(expr1) my_mutate(expr2) ``` The functional form is useful in cases where the precedence of `!` causes problems: ```{r, error = TRUE} my_fun <- quo(fun) quo(!! my_fun(x, y, z)) quo(UQ(my_fun)(x, y, z)) my_var <- quo(x) quo(filter(df, !! my_var == 1)) quo(filter(df, UQ(my_var) == 1)) ``` ### Unquote-splicing The second unquote operation is unquote-splicing. Its functional form is `UQS()` and the syntactic shortcut is `!!!`. It takes a vector and inserts each element of the vector in the surrounding function call: ```{r} quo(list(!!! letters[1:5])) ``` A very useful feature of unquote-splicing is that the vector names become argument names: ```{r} x <- list(foo = 1L, bar = quo(baz)) quo(list(!!! x)) ``` This makes it easy to program with dplyr verbs that take named dots: ```{r} args <- list(mean = quo(mean(cyl)), count = quo(n())) mtcars %>% group_by(am) %>% summarise(!!! args) ``` ### Setting variable names The final unquote operation is setting argument names. You've seen one way to do that above, but you can also use the definition operator `:=` instead of `=`. `:=` supports unquoting on both the LHS and the RHS. The rules on the LHS are slightly different: the unquoted operand should evaluate to a string or a symbol. ```{r} mean_nm <- "mean" count_nm <- "count" mtcars %>% group_by(am) %>% summarise( !! mean_nm := mean(cyl), !! count_nm := n() ) ``` dplyr/R/0000755000176200001440000000000013614573575011625 5ustar liggesusersdplyr/R/nth-value.R0000644000176200001440000000436613614573562013660 0ustar liggesusers#' Extract the first, last or nth value from a vector #' #' These are straightforward wrappers around \code{\link{[[}}. The main #' advantage is that you can provide an optional secondary vector that defines #' the ordering, and provide a default value to use when the input is shorter #' than expected. #' #' @param x A vector #' @param n For `nth_value()`, a single integer specifying the position. #' Negative integers index from the end (i.e. `-1L` will return the #' last value in the vector). #' #' If a double is supplied, it will be silently truncated. #' @param order_by An optional vector used to determine the order #' @param default A default value to use if the position does not exist in #' the input. This is guessed by default for base vectors, where a #' missing value of the appropriate type is returned, and for lists, where #' a `NULL` is return. #' #' For more complicated objects, you'll need to supply this value. #' Make sure it is the same type as `x`. #' @return A single value. `[[` is used to do the subsetting. #' @export #' @examples #' x <- 1:10 #' y <- 10:1 #' #' first(x) #' last(y) #' #' nth(x, 1) #' nth(x, 5) #' nth(x, -2) #' nth(x, 11) #' #' last(x) #' # Second argument provides optional ordering #' last(x, y) #' #' # These functions always return a single value #' first(integer()) nth <- function(x, n, order_by = NULL, default = default_missing(x)) { stopifnot(length(n) == 1, is.numeric(n)) n <- trunc(n) if (n == 0 || n > length(x) || n < -length(x)) { return(default) } # Negative values index from RHS if (n < 0) { n <- length(x) + n + 1 } if (is.null(order_by)) { x[[n]] } else { x[[ order(order_by)[[n]] ]] } } #' @export #' @rdname nth first <- function(x, order_by = NULL, default = default_missing(x)) { nth(x, 1L, order_by = order_by, default = default) } #' @export #' @rdname nth last <- function(x, order_by = NULL, default = default_missing(x)) { nth(x, -1L, order_by = order_by, default = default) } default_missing <- function(x) { UseMethod("default_missing") } #' @export default_missing.default <- function(x) { if (!is.object(x) && is.list(x)) { NULL } else { x[NA_real_] } } #' @export default_missing.data.frame <- function(x) { rep(NA, nrow(x)) } dplyr/R/colwise.R0000644000176200001440000002106013614573561013407 0ustar liggesusers#' Operate on a selection of variables #' #' The variants suffixed with `_if`, `_at` or `_all` apply an #' expression (sometimes several) to all variables within a specified #' subset. This subset can contain all variables (`_all` variants), a #' [vars()] selection (`_at` variants), or variables selected with a #' predicate (`_if` variants). #' #' The verbs with scoped variants are: #' #' * [mutate()], [transmute()] and [summarise()]. See [summarise_all()]. #' * [filter()]. See [filter_all()]. #' * [group_by()]. See [group_by_all()]. #' * [rename()] and [select()]. See [select_all()]. #' * [arrange()]. See [arrange_all()] #' #' There are three kinds of scoped variants. They differ in the scope #' of the variable selection on which operations are applied: #' #' * Verbs suffixed with `_all()` apply an operation on all variables. #' #' * Verbs suffixed with `_at()` apply an operation on a subset of #' variables specified with the quoting function [vars()]. This #' quoting function accepts [tidyselect::vars_select()] helpers like #' [starts_with()]. Instead of a [vars()] selection, you can also #' supply an [integerish][rlang::is_integerish] vector of column #' positions or a character vector of column names. #' #' * Verbs suffixed with `_if()` apply an operation on the subset of #' variables for which a predicate function returns `TRUE`. Instead #' of a predicate function, you can also supply a logical vector. #' #' @param .tbl A `tbl` object. #' @param .funs A function `fun`, a quosure style lambda `~ fun(.)` or a list of either form. #' #' @param .vars A list of columns generated by [vars()], #' a character vector of column names, a numeric vector of column #' positions, or `NULL`. #' @param .predicate A predicate function to be applied to the columns #' or a logical vector. The variables for which `.predicate` is or #' returns `TRUE` are selected. This argument is passed to #' [rlang::as_function()] and thus supports quosure-style lambda #' functions and strings representing function names. #' @param ... Additional arguments for the function calls in #' `.funs`. These are evaluated only once, with [tidy #' dots][rlang::tidy-dots] support. #' #' @section Grouping variables: #' #' Most of these operations also apply on the grouping variables when #' they are part of the selection. This includes: #' #' * [arrange_all()], [arrange_at()], and [arrange_if()] #' * [distinct_all()], [distinct_at()], and [distinct_if()] #' * [filter_all()], [filter_at()], and [filter_if()] #' * [group_by_all()], [group_by_at()], and [group_by_if()] #' * [select_all()], [select_at()], and [select_if()] #' #' This is not the case for summarising and mutating variants where #' operations are *not* applied on grouping variables. The behaviour #' depends on whether the selection is **implicit** (`all` and `if` #' selections) or **explicit** (`at` selections). Grouping variables #' covered by explicit selections (with [summarise_at()], #' [mutate_at()], and [transmute_at()]) are always an error. For #' implicit selections, the grouping variables are always ignored. In #' this case, the level of verbosity depends on the kind of operation: #' #' * Summarising operations ([summarise_all()] and [summarise_if()]) #' ignore grouping variables silently because it is obvious that #' operations are not applied on grouping variables. #' #' * On the other hand it isn't as obvious in the case of mutating #' operations ([mutate_all()], [mutate_if()], [transmute_all()], and #' [transmute_if()]). For this reason, they issue a message #' indicating which grouping variables are ignored. #' #' @name scoped NULL #' Select variables #' #' This helper is intended to provide equivalent semantics to #' [select()]. It is used for instance in scoped summarising and #' mutating verbs ([mutate_at()] and [summarise_at()]). #' #' Note that verbs accepting a `vars()` specification also accept a #' numeric vector of positions or a character vector of column names. #' #' @param ... Variables to include/exclude in mutate/summarise. You #' can use same specifications as in [select()]. If missing, #' defaults to all non-grouping variables. #' #' These arguments are automatically [quoted][rlang::quo] and later #' [evaluated][rlang::eval_tidy] in the context of the data #' frame. They support [unquoting][rlang::quasiquotation]. See #' `vignette("programming")` for an introduction to these concepts. #' @seealso [all_vars()] and [any_vars()] for other quoting #' functions that you can use with scoped verbs. #' @export vars <- function(...) { quos(...) } #' Apply predicate to all variables #' #' These quoting functions signal to scoped filtering verbs #' (e.g. [filter_if()] or [filter_all()]) that a predicate expression #' should be applied to all relevant variables. The `all_vars()` #' variant takes the intersection of the predicate expressions with #' `&` while the `any_vars()` variant takes the union with `|`. #' #' @param expr A predicate expression. This variable supports #' [unquoting][rlang::quasiquotation] and will be evaluated in the #' context of the data frame. It should return a logical vector. #' #' This argument is automatically [quoted][rlang::quo] and later #' [evaluated][rlang::eval_tidy] in the context of the data #' frame. It supports [unquoting][rlang::quasiquotation]. See #' `vignette("programming")` for an introduction to these concepts. #' @seealso [vars()] for other quoting functions that you #' can use with scoped verbs. #' @export all_vars <- function(expr) { structure(enquo(expr), class = c("all_vars", "quosure", "formula")) } #' @rdname all_vars #' @export any_vars <- function(expr) { structure(enquo(expr), class = c("any_vars", "quosure", "formula")) } #' @export print.all_vars <- function(x, ...) { cat("\n") NextMethod() } #' @export print.any_vars <- function(x, ...) { cat("\n") NextMethod() } # Requires tbl_vars() method tbl_at_vars <- function(tbl, vars, .include_group_vars = FALSE) { if (.include_group_vars) { tibble_vars <- tbl_vars(tbl) } else { tibble_vars <- tbl_nongroup_vars(tbl) } if (is_null(vars)) { character() } else if (is_integerish(vars)) { tibble_vars[vars] } else if (is_quosures(vars) || is_character(vars)) { out <- tidyselect::vars_select(tibble_vars, !!!vars) if (!any(have_name(vars))) { names(out) <- NULL } out } else { bad_args(".vars", "must be a character/numeric vector or a `vars()` object, ", "not {friendly_type_of(vars)}" ) } } tbl_at_syms <- function(tbl, vars, .include_group_vars = FALSE) { vars <- tbl_at_vars(tbl, vars, .include_group_vars = .include_group_vars) set_names(syms(vars), names(vars)) } # Requires tbl_vars(), `[[`() and length() methods tbl_if_vars <- function(.tbl, .p, .env, ..., .include_group_vars = FALSE) { if (.include_group_vars) { tibble_vars <- tbl_vars(.tbl) } else { tibble_vars <- tbl_nongroup_vars(.tbl) } if (is_logical(.p)) { stopifnot(length(.p) == length(tibble_vars)) return(syms(tibble_vars[.p])) } if (inherits(.tbl, "tbl_lazy")) { inform("Applying predicate on the first 100 rows") .tbl <- collect(.tbl, n = 100) } if (is_fun_list(.p) || is_list(.p)) { if (length(.p) != 1) { bad_args(".predicate", "must have length 1, not {length(.p)}") } .p <- .p[[1]] } if (is_quosure(.p)) { .p <- quo_as_function(.p) } else { .p <- as_function(.p, .env) } n <- length(tibble_vars) selected <- new_logical(n) for (i in seq_len(n)) { column <- .tbl[[tibble_vars[[i]]]] selected[[i]] <- eval_tidy(.p(column, ...)) } tibble_vars[selected] } tbl_if_syms <- function(.tbl, .p, .env, ..., .include_group_vars = FALSE) { syms(tbl_if_vars(.tbl, .p, .env, ..., .include_group_vars = .include_group_vars)) } # The lambda must inherit from: # - Execution environment (bound arguments with purrr lambda syntax) # - Lexical environment (local variables) # - Data mask (other columns) # # So we need: # - Inheritance from closure -> lexical # - A maskable quosure as_inlined_function <- function(f, env, ...) { # Process unquote operator at inlining time f <- expr_interp(f) # Transform to a purrr-like lambda fn <- as_function(f, env = env) body(fn) <- expr({ # Force all arguments base::pairlist(...) # Transform the lambda body into a maskable quosure inheriting # from the execution environment `_quo` <- rlang::quo(!!body(fn)) # Evaluate the quosure in the mask rlang::eval_bare(`_quo`, base::parent.frame()) }) structure(fn, class = "inline_colwise_function", formula = f) } dplyr/R/src_dbi.R0000644000176200001440000001347513451046652013355 0ustar liggesusers#' Source for database backends #' #' @description #' For backward compatibility dplyr provides three srcs for popular #' open source databases: #' #' * `src_mysql()` connects to a MySQL or MariaDB database using [RMySQL::MySQL()]. #' * `src_postgres()` connects to PostgreSQL using [RPostgreSQL::PostgreSQL()] #' * `src_sqlite()` to connect to a SQLite database using [RSQLite::SQLite()]. #' #' However, modern best practice is to use [tbl()] directly on an `DBIConnection`. #' #' @details #' All data manipulation on SQL tbls are lazy: they will not actually #' run the query or retrieve the data unless you ask for it: they all return #' a new `tbl_dbi` object. Use [compute()] to run the query and save the #' results in a temporary in the database, or use [collect()] to retrieve the #' results to R. You can see the query with [show_query()]. #' #' For best performance, the database should have an index on the variables #' that you are grouping by. Use [explain()] to check that the database is using #' the indexes that you expect. #' #' There is one exception: [do()] is not lazy since it must pull the data #' into R. #' #' @param dbname Database name #' @param host,port Host name and port number of database #' @param user,username,password User name and password. #' #' Generally, you should avoid saving username and password in your #' scripts as it is easy to accidentally expose valuable credentials. #' Instead, retrieve them from environment variables, or use database #' specific credential scores. For example, with MySQL you can set up `my.cnf` #' as described in [RMySQL::MySQL()]. #' @param ... for the src, other arguments passed on to the underlying #' database connector, [DBI::dbConnect()]. For the tbl, included for #' compatibility with the generic, but otherwise ignored. #' @return An S3 object with class `src_dbi`, `src_sql`, `src`. #' @examples #' # Basic connection using DBI ------------------------------------------- #' if (require(dbplyr, quietly = TRUE)) { #' #' con <- DBI::dbConnect(RSQLite::SQLite(), ":memory:") #' copy_to(con, mtcars) #' #' DBI::dbListTables(con) #' #' # To retrieve a single table from a source, use `tbl()` #' con %>% tbl("mtcars") #' #' # You can also use pass raw SQL if you want a more sophisticated query #' con %>% tbl(sql("SELECT * FROM mtcars WHERE cyl == 8")) #' #' # To show off the full features of dplyr's database integration, #' # we'll use the Lahman database. lahman_sqlite() takes care of #' # creating the database. #' lahman_p <- lahman_sqlite() #' batting <- lahman_p %>% tbl("Batting") #' batting #' #' # Basic data manipulation verbs work in the same way as with a tibble #' batting %>% filter(yearID > 2005, G > 130) #' batting %>% select(playerID:lgID) #' batting %>% arrange(playerID, desc(yearID)) #' batting %>% summarise(G = mean(G), n = n()) #' #' # There are a few exceptions. For example, databases give integer results #' # when dividing one integer by another. Multiply by 1 to fix the problem #' batting %>% #' select(playerID:lgID, AB, R, G) %>% #' mutate( #' R_per_game1 = R / G, #' R_per_game2 = R * 1.0 / G #' ) #' #' # All operations are lazy: they don't do anything until you request the #' # data, either by `print()`ing it (which shows the first ten rows), #' # or by `collect()`ing the results locally. #' system.time(recent <- filter(batting, yearID > 2010)) #' system.time(collect(recent)) #' #' # You can see the query that dplyr creates with show_query() #' batting %>% #' filter(G > 0) %>% #' group_by(playerID) %>% #' summarise(n = n()) %>% #' show_query() #' } #' @name src_dbi NULL #' @rdname src_dbi #' @export src_mysql <- function(dbname, host = NULL, port = 0L, username = "root", password = "", ...) { check_dbplyr() check_pkg("RMySQL", "connect to MySQL/MariaDB") con <- DBI::dbConnect( RMySQL::MySQL(), dbname = dbname, host = host, port = port, username = username, password = password, ... ) dbplyr::src_dbi(con, auto_disconnect = TRUE) } #' @rdname src_dbi #' @export src_postgres <- function(dbname = NULL, host = NULL, port = NULL, user = NULL, password = NULL, ...) { check_dbplyr() check_pkg("RPostgreSQL", "connect to PostgreSQL") user <- user %||% if (in_travis()) "postgres" else "" con <- DBI::dbConnect( RPostgreSQL::PostgreSQL(), host = host %||% "", dbname = dbname %||% "", user = user, password = password %||% "", port = port %||% "", ... ) dbplyr::src_dbi(con, auto_disconnect = TRUE) } #' @rdname src_dbi #' @export #' @param path Path to SQLite database. You can use the special path #' ":memory:" to create a temporary in memory database. #' @param create if `FALSE`, `path` must already exist. If #' `TRUE`, will create a new SQLite3 database at `path` if #' `path` does not exist and connect to the existing database if #' `path` does exist. src_sqlite <- function(path, create = FALSE) { check_dbplyr() if (!create && !file.exists(path)) { bad_args("path", "must already exist, unless `create` = TRUE") } con <- DBI::dbConnect(RSQLite::SQLite(), path) RSQLite::initExtension(con) dbplyr::src_dbi(con, auto_disconnect = TRUE) } # S3 methods -------------------------------------------------------------- #' @export tbl.DBIConnection <- function(src, from, ...) { check_dbplyr() tbl(dbplyr::src_dbi(src, auto_disconnect = FALSE), from = from, ...) } #' @export copy_to.DBIConnection <- function(dest, df, name = deparse(substitute(df)), overwrite = FALSE, ...) { check_dbplyr() copy_to( dbplyr::src_dbi(dest, auto_disconnect = FALSE), df = df, name = name, overwrite = overwrite, ... ) } # S4 ---------------------------------------------------------------------- setOldClass(c("sql", "character")) setOldClass(c("ident", "sql", "character")) dplyr/R/group_split.R0000644000176200001440000000710113614573562014312 0ustar liggesusers#' Split data frame by groups #' #' \Sexpr[results=rd, stage=render]{dplyr:::lifecycle("experimental")} #' #' @family grouping functions #' #' @description Split data frame by groups #' #' @details #' #' [group_split()] works like [base::split()] but #' - it uses the grouping structure from [group_by()] and therefore is subject to the data mask #' - it does not name the elements of the list based on the grouping as this typically #' loses information and is confusing. #' #' [group_keys()] explains the grouping structure, by returning a data frame that has one row #' per group and one column per grouping variable. #' #' @section Grouped data frames: #' #' The primary use case for [group_split()] is with already grouped data frames, #' typically a result of [group_by()]. In this case [group_split()] only uses #' the first argument, the grouped tibble, and warns when `...` is used. #' #' Because some of these groups may be empty, it is best paried with [group_keys()] #' which identifies the representatives of each grouping variable for the group. #' #' @section Ungrouped data frames: #' #' When used on ungrouped data frames, [group_split()] and [group_keys()] forwards the `...` to #' [group_by()] before the split, therefore the `...` are subject to the data mask. #' #' Using these functions on an ungrouped data frame only makes sense if you need only one or the #' other, because otherwise the grouping algorithm is performed each time. #' #' @section Rowwise data frames: #' #' [group_split()] returns a list of one-row tibbles is returned, and the `...` are ignored and warned against #' #' @param .tbl A tbl #' @param ... Grouping specification, forwarded to [group_by()] #' @param keep Should the grouping columns be kept #' #' @return #' #' - [group_split()] returns a list of tibbles. Each tibble contains the rows of `.tbl` for the associated group and #' all the columns, including the grouping variables. #' #' - [group_keys()] returns a tibble with one row per group, and one column per grouping variable #' #' @examples #' #' # ----- use case 1 : on an already grouped tibble #' ir <- iris %>% #' group_by(Species) #' #' group_split(ir) #' group_keys(ir) #' #' # this can be useful if the grouped data has been altered before the split #' ir <- iris %>% #' group_by(Species) %>% #' filter(Sepal.Length > mean(Sepal.Length)) #' #' group_split(ir) #' group_keys(ir) #' #' # ----- use case 2: using a group_by() grouping specification #' #' # both group_split() and group_keys() have to perform the grouping #' # so it only makes sense to do this if you only need one or the other #' iris %>% #' group_split(Species) #' #' iris %>% #' group_keys(Species) #' #' @export group_split <- function(.tbl, ..., keep = TRUE) { UseMethod("group_split") } #' @export group_split.data.frame <- function(.tbl, ..., keep = TRUE) { if (dots_n(...)) { group_split_impl(group_by(.tbl, ...), isTRUE(keep), environment()) } else { structure(list(.tbl), ptype = .tbl[0L, ]) } } #' @export group_split.rowwise_df <- function(.tbl, ..., keep = TRUE) { if (dots_n(...)) { warn("... is ignored in group_split(), please use as_tibble() %>% group_split(...)") } if (!missing(keep)) { warn("keep is ignored in group_split()") } structure(map(seq_len(nrow(.tbl)), function(i) .tbl[i, ]), ptype = .tbl[0L, ]) } #' @export group_split.grouped_df <- function(.tbl, ..., keep = TRUE) { if (dots_n(...)) { warn("... is ignored in group_split(), please use group_by(..., add = TRUE) %>% group_split()") } group_split_impl(.tbl, isTRUE(keep), environment()) } dplyr/R/group_trim.R0000644000176200001440000000236113614573562014135 0ustar liggesusers#' Trim grouping structure #' #' \Sexpr[results=rd, stage=render]{dplyr:::lifecycle("experimental")} #' #' @family grouping functions #' #' @description #' Drop unused levels of all factors that are used as grouping variables, #' then recalculates the grouping structure. #' #' `group_trim()` is particularly useful after a [filter()] that is intended #' to select a subset of groups. #' #' @param .tbl A [grouped data frame][grouped_df()] #' @param .drop See [group_by()] #' #' @return A [grouped data frame][grouped_df()] #' #' @examples #' iris %>% #' group_by(Species) %>% #' filter(Species == "setosa", .preserve = TRUE) %>% #' group_trim() #' #' @export group_trim <- function(.tbl, .drop = group_by_drop_default(.tbl)) { UseMethod("group_trim") } #' @export group_trim.data.frame <- function(.tbl, .drop = group_by_drop_default(.tbl)) { .tbl } #' @export group_trim.grouped_df <- function(.tbl, .drop = group_by_drop_default(.tbl)) { vars <- group_vars(.tbl) ungrouped <- ungroup(.tbl) # names of the factors that should be droplevels()'d fgroups <- names(select_if(select_at(ungrouped, vars), is.factor)) # drop levels dropped <- mutate_at(ungrouped, fgroups, droplevels) # regroup group_by_at(dropped, vars, .drop = .drop) } dplyr/R/na_if.R0000644000176200001440000000224513614573562013023 0ustar liggesusers#' Convert values to NA #' #' This is a translation of the SQL command `NULL_IF`. It is useful #' if you want to convert an annoying value to `NA`. #' #' @param x Vector to modify #' @param y Value to replace with NA #' @return A modified version of `x` that replaces any values that #' are equal to `y` with NA. #' @seealso [coalesce()] to replace missing values with a specified #' value. #' #' [tidyr::replace_na()] to replace `NA` with a value. #' #' [recode()] to more generally replace values. #' @export #' @examples #' na_if(1:5, 5:1) #' #' x <- c(1, -1, 0, 10) #' 100 / x #' 100 / na_if(x, 0) #' #' y <- c("abc", "def", "", "ghi") #' na_if(y, "") #' #' # na_if is particularly useful inside mutate, #' # and is meant for use with vectors rather than entire data frames #' starwars %>% #' select(name, eye_color) %>% #' mutate(eye_color = na_if(eye_color, "unknown")) #' #' # na_if can also be used with scoped variants of mutate #' # like mutate_if to mutate multiple columns #' starwars %>% #' mutate_if(is.character, list(~na_if(., "unknown"))) na_if <- function(x, y) { check_length(y, x, fmt_args("y"), glue("same as {fmt_args(~x)}")) x[x == y] <- NA x } dplyr/R/zzz.r0000644000176200001440000000136313614573562012644 0ustar liggesusers.onLoad <- function(libname, pkgname) { op <- options() op.dplyr <- list( dplyr.show_progress = TRUE ) toset <- !(names(op.dplyr) %in% names(op)) if (any(toset)) options(op.dplyr[toset]) compat_lengths() invisible() } .onAttach <- function(libname, pkgname) { setHook(packageEvent("plyr", "attach"), function(...) { packageStartupMessage(rule()) packageStartupMessage( "You have loaded plyr after dplyr - this is likely ", "to cause problems.\nIf you need functions from both plyr and dplyr, ", "please load plyr first, then dplyr:\nlibrary(plyr); library(dplyr)" ) packageStartupMessage(rule()) }) } .onDetach <- function(libpath) { setHook(packageEvent("plyr", "attach"), NULL, "replace") } dplyr/R/dplyr.r0000644000176200001440000000322013614573561013132 0ustar liggesusers#' dplyr: a grammar of data manipulation #' #' dplyr provides a flexible grammar of data manipulation. It's the next #' iteration of plyr, focused on tools for working with data frames (hence the #' *d* in the name). #' #' It has three main goals: #' #' \itemize{ #' \item Identify the most important data manipulation verbs and make them #' easy to use from R. #' \item Provide blazing fast performance for in-memory data by writing key #' pieces in C++ (using Rcpp) #' \item Use the same interface to work with data no matter where it's stored, #' whether in a data frame, a data table or database. #' } #' #' To learn more about dplyr, start with the vignettes: #' `browseVignettes(package = "dplyr")` #' #' @section Package options: #' \describe{ #' \item{`dplyr.show_progress`}{Should lengthy operations such as `do()` #' show a progress bar? Default: `TRUE`} #' } #' #' @section Package configurations: #' These can be set on a package-by-package basis, or for the global environment. #' See [pkgconfig::set_config()] for usage. #' \describe{ #' \item{`dplyr::na_matches`}{Should `NA` values be matched in data frame joins #' by default? Default: `"na"` (for compatibility with dplyr v0.5.0 and earlier, #' subject to change), alternative value: `"never"` (the default #' for database backends, see [join.tbl_df()]).} #' } #' #' @useDynLib dplyr, .registration = TRUE #' @import rlang #' @importFrom assertthat assert_that is.flag on_failure<- #' @importFrom glue glue #' @importFrom Rcpp cppFunction Rcpp.plugin.maker #' @importFrom stats setNames update #' @importFrom utils head tail #' @importFrom methods is #' @importFrom pkgconfig get_config "_PACKAGE" dplyr/R/top-n.R0000644000176200001440000000373413614573562013010 0ustar liggesusers#' Select top (or bottom) n rows (by value) #' #' This is a convenient wrapper that uses [filter()] and #' [min_rank()] to select the top or bottom entries in each group, #' ordered by `wt`. #' #' @param x a [tbl()] to filter #' @param n number of rows to return for `top_n()`, fraction of rows to #' return for `top_frac()`. #' #' If `x` is grouped, this is the #' number (or fraction) of rows per group. Will include more rows if #' there are ties. #' #' If `n` is positive, selects the top rows. If negative, #' selects the bottom rows. #' #' @param wt (Optional). The variable to use for ordering. If not #' specified, defaults to the last variable in the tbl. #' #' @details #' Both `n` and `wt` are automatically [quoted][rlang::enquo] and later #' [evaluated][rlang::eval_tidy] in the context of the data #' frame. It supports [unquoting][rlang::quasiquotation]. #' #' @export #' @examples #' df <- data.frame(x = c(10, 4, 1, 6, 3, 1, 1)) #' df %>% top_n(2) #' #' # half the rows #' df %>% top_n(n() * .5) #' df %>% top_frac(.5) #' #' # Negative values select bottom from group. Note that we get more #' # than 2 values here because there's a tie: top_n() either takes #' # all rows with a value, or none. #' df %>% top_n(-2) #' #' if (require("Lahman")) { #' # Find 10 players with most games #' tbl_df(Batting) %>% #' group_by(playerID) %>% #' tally(G) %>% #' top_n(10) #' #' # Find year with most games for each player #' \dontrun{ #' tbl_df(Batting) %>% #' group_by(playerID) %>% #' top_n(1, G) #' } #' } top_n <- function(x, n, wt) { wt <- enquo(wt) if (quo_is_missing(wt)) { vars <- tbl_vars(x) wt_name <- vars[length(vars)] inform(glue("Selecting by ", wt_name)) wt <- sym(wt_name) } filter(x, top_n_rank({{ n }}, !!wt)) } top_n_rank <- function(n, wt) { if (n > 0) { min_rank(desc(wt)) <= n } else { min_rank(wt) <= abs(n) } } #' @export #' @rdname top_n top_frac <- function(x, n, wt) { top_n(x, {{ n }} * n(), {{ wt }}) } dplyr/R/bench-compare.r0000644000176200001440000000774013614573561014516 0ustar liggesusers#' Evaluate, compare, benchmark operations of a set of srcs. #' #' These functions support the comparison of results and timings across #' multiple sources. #' #' @param tbls,tbls_x,tbls_y A list of [tbl()]s. #' @param op A function with a single argument, called often with each #' element of `tbls`. #' @param ref For checking, a data frame to test results against. If not #' supplied, defaults to the results from the first `src`. #' @param compare A function used to compare the results. Defaults to #' `equal_data_frame` which ignores the order of rows and columns. #' @param times For benchmarking, the number of times each operation is #' repeated. #' @param \dots #' For `compare_tbls()`: additional parameters passed on the #' `compare()` function #' #' For `bench_tbls()`: additional benchmarks to run. #' @return #' `eval_tbls()`: a list of data frames. #' #' `compare_tbls()`: an invisible `TRUE` on success, otherwise #' an error is thrown. #' #' `bench_tbls()`: an object of class #' [microbenchmark::microbenchmark()] #' @seealso [src_local()] for working with local data #' @examples #' \dontrun{ #' if (require("microbenchmark") && has_lahman()) { #' lahman_local <- lahman_srcs("df", "sqlite") #' teams <- lapply(lahman_local, function(x) x %>% tbl("Teams")) #' #' compare_tbls(teams, function(x) x %>% filter(yearID == 2010)) #' bench_tbls(teams, function(x) x %>% filter(yearID == 2010)) #' #' # You can also supply arbitrary additional arguments to bench_tbls #' # if there are other operations you'd like to compare. #' bench_tbls(teams, function(x) x %>% filter(yearID == 2010), #' base = subset(Lahman::Teams, yearID == 2010)) #' #' # A more complicated example using multiple tables #' setup <- function(src) { #' list( #' src %>% tbl("Batting") %>% filter(stint == 1) %>% select(playerID:H), #' src %>% tbl("Master") %>% select(playerID, birthYear) #' ) #' } #' two_tables <- lapply(lahman_local, setup) #' #' op <- function(tbls) { #' semi_join(tbls[[1]], tbls[[2]], by = "playerID") #' } #' # compare_tbls(two_tables, op) #' bench_tbls(two_tables, op, times = 2) #' #' } #' } #' @name bench_compare #' @keywords internal NULL #' @export #' @rdname bench_compare bench_tbls <- function(tbls, op, ..., times = 10) { check_pkg("microbenchmark", "compute table benchmarks") # Generate call to microbenchmark function that evaluates op for each tbl calls <- lapply(seq_along(tbls), function(i) { substitute(op(tbls[[i]]), list(i = i)) }) names(calls) <- names(tbls) mb <- as.call(c( quote(microbenchmark::microbenchmark), calls, dots(...), list(times = times) )) eval(mb) } #' @export #' @rdname bench_compare compare_tbls <- function(tbls, op, ref = NULL, compare = equal_data_frame, ...) { results <- eval_tbls(tbls, op) expect_equal_tbls(results, compare = compare, ...) } #' @export #' @rdname bench_compare compare_tbls2 <- function(tbls_x, tbls_y, op, ref = NULL, compare = equal_data_frame, ...) { results <- eval_tbls2(tbls_x, tbls_y, op) expect_equal_tbls(results, compare = compare, ...) } expect_equal_tbls <- function(results, ref = NULL, compare = equal_data_frame, ...) { check_pkg("testthat", "compare tables") if (length(results) < 2 && is.null(ref)) { testthat::skip("Need at least two srcs to compare") } if (is.null(ref)) { ref <- results[[1]] ref_name <- names(results)[1] rest <- results[-1] } else { rest <- results ref_name <- "supplied comparison" } for (i in seq_along(rest)) { ok <- compare(ref, rest[[i]], ...) # if (!ok) browser() msg <- paste0( names(rest)[[i]], " not equal to ", ref_name, "\n", attr(ok, "comment") ) testthat::expect_true(ok, info = msg) } invisible(TRUE) } #' @export #' @rdname bench_compare eval_tbls <- function(tbls, op) { lapply(tbls, function(x) as.data.frame(op(x))) } #' @export #' @rdname bench_compare eval_tbls2 <- function(tbls_x, tbls_y, op) { Map(function(x, y) as.data.frame(op(x, y)), tbls_x, tbls_y) } dplyr/R/colwise-mutate.R0000644000176200001440000003660713614573561014721 0ustar liggesusers#' Summarise multiple columns #' #' @description #' #' The [scoped] variants of [summarise()] make it easy to apply the same #' transformation to multiple variables. #' There are three variants. #' * `summarise_all()` affects every variable #' * `summarise_at()` affects variables selected with a character vector or #' vars() #' * `summarise_if()` affects variables selected with a predicate function #' #' @inheritParams scoped #' @param .cols This argument has been renamed to `.vars` to fit #' dplyr's terminology and is deprecated. #' @return A data frame. By default, the newly created columns have the shortest #' names needed to uniquely identify the output. To force inclusion of a name, #' even when not needed, name the input (see examples for details). #' @seealso [The other scoped verbs][scoped], [vars()] #' #' @section Grouping variables: #' #' If applied on a grouped tibble, these operations are *not* applied #' to the grouping variables. The behaviour depends on whether the #' selection is **implicit** (`all` and `if` selections) or #' **explicit** (`at` selections). #' #' * Grouping variables covered by explicit selections in #' `summarise_at()` are always an error. Add `-group_cols()` to the #' [vars()] selection to avoid this: #' #' ``` #' data %>% #' summarise_at(vars(-group_cols(), ...), myoperation) #' ``` #' #' Or remove `group_vars()` from the character vector of column names: #' #' ``` #' nms <- setdiff(nms, group_vars(data)) #' data %>% summarise_at(vars, myoperation) #' ``` #' #' * Grouping variables covered by implicit selections are silently #' ignored by `summarise_all()` and `summarise_if()`. #' #' @section Naming: #' #' The names of the created columns is derived from the names of the #' input variables and the names of the functions. #' #' - if there is only one unnamed function, the names of the input variables #' are used to name the created columns #' #' - if there is only one unnamed variable, the names of the functions #' are used to name the created columns. #' #' - otherwise in the most general case, the created names are created by #' concatenating the names of the input variables and the names of the functions. #' #' The names of the functions here means the names of the list of functions #' that is supplied. When needed and not supplied, the name of a function #' is the prefix "fn" followed by the index of this function within the #' unnamed functions in the list. Ultimately, names are made #' unique. #' #' @examples #' by_species <- iris %>% #' group_by(Species) #' #' #' # The _at() variants directly support strings: #' starwars %>% #' summarise_at(c("height", "mass"), mean, na.rm = TRUE) #' #' # You can also supply selection helpers to _at() functions but you have #' # to quote them with vars(): #' starwars %>% #' summarise_at(vars(height:mass), mean, na.rm = TRUE) #' #' # The _if() variants apply a predicate function (a function that #' # returns TRUE or FALSE) to determine the relevant subset of #' # columns. Here we apply mean() to the numeric columns: #' starwars %>% #' summarise_if(is.numeric, mean, na.rm = TRUE) #' #' # If you want to apply multiple transformations, pass a list of #' # functions. When there are multiple functions, they create new #' # variables instead of modifying the variables in place: #' by_species %>% #' summarise_all(list(min, max)) #' #' # Note how the new variables include the function name, in order to #' # keep things distinct. Passing purrr-style lambdas often creates #' # better default names: #' by_species %>% #' summarise_all(list(~min(.), ~max(.))) #' #' # When that's not good enough, you can also supply the names explicitly: #' by_species %>% #' summarise_all(list(min = min, max = max)) #' #' # When there's only one function in the list, it modifies existing #' # variables in place. Give it a name to create new variables instead: #' by_species %>% summarise_all(list(med = median)) #' by_species %>% summarise_all(list(Q3 = quantile), probs = 0.75) #' @export summarise_all <- function(.tbl, .funs, ...) { funs <- manip_all(.tbl, .funs, enquo(.funs), caller_env(), ...) summarise(.tbl, !!!funs) } #' @rdname summarise_all #' @export summarise_if <- function(.tbl, .predicate, .funs, ...) { funs <- manip_if(.tbl, .predicate, .funs, enquo(.funs), caller_env(), ...) summarise(.tbl, !!!funs) } #' @rdname summarise_all #' @export summarise_at <- function(.tbl, .vars, .funs, ..., .cols = NULL) { .vars <- check_dot_cols(.vars, .cols) funs <- manip_at(.tbl, .vars, .funs, enquo(.funs), caller_env(), ...) summarise(.tbl, !!!funs) } #' @rdname summarise_all #' @export summarize_all <- summarise_all #' @rdname summarise_all #' @export summarize_if <- summarise_if #' @rdname summarise_all #' @export summarize_at <- summarise_at #' Mutate multiple columns #' #' @description #' #' The [scoped] variants of [mutate()] and [transmute()] make it easy to apply #' the same transformation to multiple variables. There are three variants: #' * _all affects every variable #' * _at affects variables selected with a character vector or vars() #' * _if affects variables selected with a predicate function: #' #' @inheritParams scoped #' @inheritParams summarise_all #' @return A data frame. By default, the newly created columns have the shortest #' names needed to uniquely identify the output. To force inclusion of a name, #' even when not needed, name the input (see examples for details). #' @seealso [The other scoped verbs][scoped], [vars()] #' #' @section Grouping variables: #' #' If applied on a grouped tibble, these operations are *not* applied #' to the grouping variables. The behaviour depends on whether the #' selection is **implicit** (`all` and `if` selections) or #' **explicit** (`at` selections). #' #' * Grouping variables covered by explicit selections in #' `mutate_at()` and `transmute_at()` are always an error. Add #' `-group_cols()` to the [vars()] selection to avoid this: #' #' ``` #' data %>% mutate_at(vars(-group_cols(), ...), myoperation) #' ``` #' #' Or remove `group_vars()` from the character vector of column names: #' #' ``` #' nms <- setdiff(nms, group_vars(data)) #' data %>% mutate_at(vars, myoperation) #' ``` #' #' * Grouping variables covered by implicit selections are ignored by #' `mutate_all()`, `transmute_all()`, `mutate_if()`, and #' `transmute_if()`. #' #' @inheritSection summarise_all Naming #' #' @examples #' iris <- as_tibble(iris) #' #' # All variants can be passed functions and additional arguments, #' # purrr-style. The _at() variants directly support strings. Here #' # we'll scale the variables `height` and `mass`: #' scale2 <- function(x, na.rm = FALSE) (x - mean(x, na.rm = na.rm)) / sd(x, na.rm) #' starwars %>% mutate_at(c("height", "mass"), scale2) #' #' # You can pass additional arguments to the function: #' starwars %>% mutate_at(c("height", "mass"), scale2, na.rm = TRUE) #' #' # You can also pass formulas to create functions on the spot, purrr-style: #' starwars %>% mutate_at(c("height", "mass"), ~scale2(., na.rm = TRUE)) #' #' # You can also supply selection helpers to _at() functions but you have #' # to quote them with vars(): #' iris %>% mutate_at(vars(matches("Sepal")), log) #' #' # The _if() variants apply a predicate function (a function that #' # returns TRUE or FALSE) to determine the relevant subset of #' # columns. Here we divide all the numeric columns by 100: #' starwars %>% mutate_if(is.numeric, scale2, na.rm = TRUE) #' #' # mutate_if() is particularly useful for transforming variables from #' # one type to another #' iris %>% mutate_if(is.factor, as.character) #' iris %>% mutate_if(is.double, as.integer) #' #' #' # Multiple transformations ---------------------------------------- #' #' # If you want to apply multiple transformations, pass a list of #' # functions. When there are multiple functions, they create new #' # variables instead of modifying the variables in place: #' iris %>% mutate_if(is.numeric, list(scale2, log)) #' #' # The list can contain purrr-style formulas: #' iris %>% mutate_if(is.numeric, list(~scale2(.), ~log(.))) #' #' # Note how the new variables include the function name, in order to #' # keep things distinct. The default names are not always helpful #' # but you can also supply explicit names: #' iris %>% mutate_if(is.numeric, list(scale = scale2, log = log)) #' #' # When there's only one function in the list, it modifies existing #' # variables in place. Give it a name to instead create new variables: #' iris %>% mutate_if(is.numeric, list(scale2)) #' iris %>% mutate_if(is.numeric, list(scale = scale2)) #' @export mutate_all <- function(.tbl, .funs, ...) { check_grouped(.tbl, "mutate", "all", alt = TRUE) funs <- manip_all(.tbl, .funs, enquo(.funs), caller_env(), ...) mutate(.tbl, !!!funs) } #' @rdname mutate_all #' @export mutate_if <- function(.tbl, .predicate, .funs, ...) { check_grouped(.tbl, "mutate", "if") funs <- manip_if(.tbl, .predicate, .funs, enquo(.funs), caller_env(), ...) mutate(.tbl, !!!funs) } #' @rdname mutate_all #' @export mutate_at <- function(.tbl, .vars, .funs, ..., .cols = NULL) { .vars <- check_dot_cols(.vars, .cols) funs <- manip_at(.tbl, .vars, .funs, enquo(.funs), caller_env(), .include_group_vars = TRUE, ...) mutate(.tbl, !!!funs) } #' @rdname mutate_all #' @export transmute_all <- function(.tbl, .funs, ...) { check_grouped(.tbl, "transmute", "all", alt = TRUE) funs <- manip_all(.tbl, .funs, enquo(.funs), caller_env(), ...) transmute(.tbl, !!!funs) } #' @rdname mutate_all #' @export transmute_if <- function(.tbl, .predicate, .funs, ...) { check_grouped(.tbl, "transmute", "if") funs <- manip_if(.tbl, .predicate, .funs, enquo(.funs), caller_env(), ...) transmute(.tbl, !!!funs) } #' @rdname mutate_all #' @export transmute_at <- function(.tbl, .vars, .funs, ..., .cols = NULL) { .vars <- check_dot_cols(.vars, .cols) funs <- manip_at(.tbl, .vars, .funs, enquo(.funs), caller_env(), .include_group_vars = TRUE, ...) transmute(.tbl, !!!funs) } # Helpers ----------------------------------------------------------------- manip_all <- function(.tbl, .funs, .quo, .env, ..., .include_group_vars = FALSE) { if (.include_group_vars) { syms <- syms(tbl_vars(.tbl)) } else { syms <- syms(tbl_nongroup_vars(.tbl)) } funs <- as_fun_list(.funs, .env, ...) manip_apply_syms(funs, syms, .tbl) } manip_if <- function(.tbl, .predicate, .funs, .quo, .env, ..., .include_group_vars = FALSE) { vars <- tbl_if_syms(.tbl, .predicate, .env, .include_group_vars = .include_group_vars) funs <- as_fun_list(.funs, .env, ...) manip_apply_syms(funs, vars, .tbl) } manip_at <- function(.tbl, .vars, .funs, .quo, .env, ..., .include_group_vars = FALSE) { syms <- tbl_at_syms(.tbl, .vars, .include_group_vars = .include_group_vars) funs <- as_fun_list(.funs, .env, ...) manip_apply_syms(funs, syms, .tbl) } check_grouped <- function(tbl, verb, suffix, alt = FALSE) { if (is_grouped_df(tbl)) { if (alt) { alt_line <- sprintf("Use `%s_at(df, vars(-group_cols()), myoperation)` to silence the message.", verb) } else { alt_line <- chr() } inform(paste_line( sprintf("`%s_%s()` ignored the following grouping variables:", verb, suffix), fmt_cols(group_vars(tbl)), alt_line )) } } check_dot_cols <- function(vars, cols) { if (is_null(cols)) { vars } else { inform("`.cols` has been renamed and is deprecated, please use `.vars`") if (missing(vars)) cols else vars } } manip_apply_syms <- function(funs, syms, tbl) { out <- vector("list", length(syms) * length(funs)) dim(out) <- c(length(syms), length(funs)) syms_position <- match(as.character(syms), tbl_vars(tbl)) for (i in seq_along(syms)) { pos <- syms_position[i] for (j in seq_along(funs)) { fun <- funs[[j]] if (is_quosure(fun)) { out[[i, j]] <- expr_substitute(funs[[j]], quote(.), syms[[i]]) } else { out[[i, j]] <- call2(funs[[j]], syms[[i]]) } attr(out[[i, j]], "position") <- pos } } dim(out) <- NULL # Use symbols as default names unnamed <- !have_name(syms) names(syms)[unnamed] <- map_chr(syms[unnamed], as_string) if (length(funs) == 1 && !attr(funs, "have_name")) { names(out) <- names(syms) } else { nms <- names(funs) %||% rep("", length(funs)) is_fun <- nms == "" | nms == "" nms[is_fun] <- paste0("fn", seq_len(sum(is_fun))) nms <- unique_names(nms, quiet = TRUE) names(funs) <- nms if (length(syms) == 1 && all(unnamed)) { names(out) <- names(funs) } else { syms_names <- ifelse(unnamed, map_chr(syms, as_string), names(syms)) grid <- expand.grid(var = syms_names, call = names(funs)) names(out) <- paste(grid$var, grid$call, sep = "_") } } out } # Deprecated -------------------------------------------------------------- #' Summarise and mutate multiple columns. #' #' \Sexpr[results=rd, stage=render]{dplyr:::lifecycle("deprecated")} #' #' @description #' #' `mutate_each()` and `summarise_each()` are deprecated in favour of #' a more featureful family of functions: [mutate_all()], #' [mutate_at()], [mutate_if()], [summarise_all()], [summarise_at()] #' and [summarise_if()]. #' #' The `_each()` functions have two replacements depending on what #' variables you want to apply `funs` to. To apply a function to all #' variables, use [mutate_all()] or [summarise_all()]. To apply a #' function to a selection of variables, use [mutate_at()] or #' [summarise_at()]. #' #' See the relevant section of `vignette("compatibility")` for more #' information. #' #' @keywords internal #' @export summarise_each <- function(tbl, funs, ...) { summarise_each_(tbl, funs, enquos(...)) } #' @export #' @rdname summarise_each summarise_each_ <- function(tbl, funs, vars) { signal_soft_deprecated(paste_line( "summarise_each() is deprecated", "Please use summarise_if(), summarise_at(), or summarise_all() instead: ", "", " - To map `funs` over all variables, use summarise_all()", " - To map `funs` over a selection of variables, use summarise_at()" )) if (is_empty(vars)) { vars <- tbl_nongroup_vars(tbl) } else { vars <- compat_lazy_dots(vars, caller_env()) vars <- tidyselect::vars_select(tbl_nongroup_vars(tbl), !!!vars) if (length(vars) == 1 && names(vars) == as_string(vars)) { vars <- unname(vars) } } if (is_character(funs)) { funs <- funs_(funs) } funs <- manip_at(tbl, vars, funs, enquo(funs), caller_env()) summarise(tbl, !!!funs) } #' @export #' @rdname summarise_each mutate_each <- function(tbl, funs, ...) { if (is_character(funs)) { funs <- funs_(funs) } mutate_each_(tbl, funs, enquos(...)) } #' @export #' @rdname summarise_each mutate_each_ <- function(tbl, funs, vars) { signal_soft_deprecated(paste_line( "mutate_each() is deprecated", "Please use mutate_if(), mutate_at(), or mutate_all() instead: ", "", " - To map `funs` over all variables, use mutate_all()", " - To map `funs` over a selection of variables, use mutate_at()" )) if (is_empty(vars)) { vars <- tbl_nongroup_vars(tbl) } else { vars <- compat_lazy_dots(vars, caller_env()) vars <- tidyselect::vars_select(tbl_nongroup_vars(tbl), !!!vars) if (length(vars) == 1 && names(vars) == as_string(vars)) { vars <- unname(vars) } } funs <- manip_at(tbl, vars, funs, enquo(funs), caller_env()) mutate(tbl, !!!funs) } #' @rdname summarise_each #' @export summarize_each <- summarise_each #' @rdname summarise_each #' @export summarize_each_ <- summarise_each_ dplyr/R/data-storms.R0000644000176200001440000000234313451046652014176 0ustar liggesusers#' Storm tracks data #' #' This data is a subset of the NOAA Atlantic hurricane database best track #' data, \url{http://www.nhc.noaa.gov/data/#hurdat}. The data includes the #' positions and attributes of 198 tropical storms, measured every six hours #' during the lifetime of a storm. #' #' @seealso The script to create the storms data set: \url{https://github.com/tidyverse/dplyr/blob/master/data-raw/storms.R} #' #' @format A tibble with 10,010 observations and 13 variables: #' \describe{ #' \item{name}{Storm Name} #' \item{year,month,day}{Date of report} #' \item{hour}{Hour of report (in UTC)} #' \item{lat,long}{Location of storm center} #' \item{status}{Storm classification (Tropical Depression, Tropical Storm, #' or Hurricane)} #' \item{category}{Saffir-Simpson storm category (estimated from wind speed. #' -1 = Tropical Depression, 0 = Tropical Storm)} #' \item{wind}{storm's maximum sustained wind speed (in knots)} #' \item{pressure}{Air pressure at the storm's center (in millibars)} #' \item{ts_diameter}{Diameter of the area experiencing tropical storm strength winds (34 knots or above)} #' \item{hu_diameter}{Diameter of the area experiencing hurricane strength winds (64 knots or above)} #' } #' @examples #' storms "storms" dplyr/R/data-starwars.R0000644000176200001440000000135413614573561014523 0ustar liggesusers#' Starwars characters #' #' This data comes from SWAPI, the Star Wars API, #' #' @format A tibble with 87 rows and 13 variables: #' \describe{ #' \item{name}{Name of the character} #' \item{height}{Height (cm)} #' \item{mass}{Weight (kg)} #' \item{hair_color,skin_color,eye_color}{Hair, skin, and eye colors} #' \item{birth_year}{Year born (BBY = Before Battle of Yavin)} #' \item{gender}{male, female, hermaphrodite, or none.} #' \item{homeworld}{Name of homeworld} #' \item{species}{Name of species} #' \item{films}{List of films the character appeared in} #' \item{vehicles}{List of vehicles the character has piloted} #' \item{starships}{List of starships the character has piloted} #' } #' @examples #' starwars "starwars" dplyr/R/colwise-filter.R0000644000176200001440000000664113614573561014702 0ustar liggesusers#' Filter within a selection of variables #' #' These [scoped] filtering verbs apply a predicate expression to a #' selection of variables. The predicate expression should be quoted #' with [all_vars()] or [any_vars()] and should mention the pronoun #' `.` to refer to variables. #' #' @inheritParams scoped #' @param .vars_predicate A quoted predicate expression as returned by #' [all_vars()] or [any_vars()]. #' #' Can also be a function or purrr-like formula. In this case, the #' intersection of the results is taken by default and there's #' currently no way to request the union. #' @param .preserve when `FALSE` (the default), the grouping structure #' is recalculated based on the resulting data, otherwise it is kept as is. #' @export #' #' @section Grouping variables: #' #' The grouping variables that are part of the selection are taken #' into account to determine filtered rows. #' #' @examples #' # While filter() accepts expressions with specific variables, the #' # scoped filter verbs take an expression with the pronoun `.` and #' # replicate it over all variables. This expression should be quoted #' # with all_vars() or any_vars(): #' all_vars(is.na(.)) #' any_vars(is.na(.)) #' #' #' # You can take the intersection of the replicated expressions: #' filter_all(mtcars, all_vars(. > 150)) #' #' # Or the union: #' filter_all(mtcars, any_vars(. > 150)) #' #' #' # You can vary the selection of columns on which to apply the #' # predicate. filter_at() takes a vars() specification: #' filter_at(mtcars, vars(starts_with("d")), any_vars((. %% 2) == 0)) #' #' # And filter_if() selects variables with a predicate function: #' filter_if(mtcars, ~ all(floor(.) == .), all_vars(. != 0)) #' #' #' # We're working on a new syntax to allow functions instead, #' # including purrr-like lambda functions. This is already #' # operational, but there's currently no way to specify the union of #' # the predicate results: #' mtcars %>% filter_at(vars(hp, vs), ~ . %% 2 == 0) filter_all <- function(.tbl, .vars_predicate, .preserve = FALSE) { syms <- syms(tbl_vars(.tbl)) pred <- apply_filter_syms(.vars_predicate, syms, .tbl) filter(.tbl, !!pred, .preserve = .preserve) } #' @rdname filter_all #' @export filter_if <- function(.tbl, .predicate, .vars_predicate, .preserve = FALSE) { syms <- tbl_if_syms(.tbl, .predicate, .include_group_vars = TRUE) pred <- apply_filter_syms(.vars_predicate, syms, .tbl) filter(.tbl, !!pred, .preserve = .preserve) } #' @rdname filter_all #' @export filter_at <- function(.tbl, .vars, .vars_predicate, .preserve = FALSE) { syms <- tbl_at_syms(.tbl, .vars, .include_group_vars = TRUE) pred <- apply_filter_syms(.vars_predicate, syms, .tbl) filter(.tbl, !!pred, .preserve = .preserve) } apply_filter_syms <- function(pred, syms, tbl) { if (is_empty(syms)) { bad_args(".predicate", "has no matching columns") } joiner <- all_exprs if (inherits_any(pred, c("all_vars", "any_vars"))) { if (inherits(pred, "any_vars")) { joiner <- any_exprs } pred <- map(syms, function(sym) expr_substitute(pred, quote(.), sym)) } else if (is_bare_formula(pred) || is_function(pred)) { pred <- as_function(pred) pred <- map(syms, function(sym) call2(pred, sym)) } else { bad_args(".vars_predicate", "must be a function or a call to `all_vars()` or `any_vars()`, ", "not {friendly_type_of(pred)}" ) } if (length(pred) == 1) { pred[[1L]] } else { joiner(!!!pred) } } dplyr/R/desc.r0000644000176200001440000000061613451046652012717 0ustar liggesusers#' Descending order #' #' Transform a vector into a format that will be sorted in descending order. #' This is useful within [arrange()]. #' #' @param x vector to transform #' @export #' @examples #' desc(1:10) #' desc(factor(letters)) #' #' first_day <- seq(as.Date("1910/1/1"), as.Date("1920/1/1"), "years") #' desc(first_day) #' #' starwars %>% arrange(desc(mass)) desc <- function(x) -xtfrm(x) dplyr/R/dbplyr.R0000644000176200001440000001200713451046652013232 0ustar liggesusers#' Database and SQL generics. #' #' The `sql_` generics are used to build the different types of SQL queries. #' The default implementations in dbplyr generates ANSI 92 compliant SQL. #' The `db_` generics execute actions on the database. The default #' implementations in dbplyr typically just call the standard DBI S4 #' method. #' #' A few backend methods do not call the standard DBI S4 methods including #' #' * `db_data_type()`: Calls [DBI::dbDataType()] for every field #' (e.g. data frame column) and returns a vector of corresponding SQL data #' types #' #' * `db_save_query()`: Builds and executes a #' `CREATE [TEMPORARY] TABLE
...` SQL command. #' #' * `db_create_index()`: Builds and executes a #' `CREATE INDEX ON
` SQL command. #' #' * `db_drop_table()`: Builds and executes a #' `DROP TABLE [IF EXISTS]
` SQL command. #' #' * `db_analyze()`: Builds and executes an #' `ANALYZE
` SQL command. #' #' Currently, [copy_to()] is the only user of `db_begin()`, `db_commit()`, #' `db_rollback()`, `db_write_table()`, `db_create_indexes()`, `db_drop_table()` and #' `db_analyze()`. If you find yourself overriding many of these #' functions it may suggest that you should just override `copy_to()` #' instead. #' #' `db_create_table()` and `db_insert_into()` have been deprecated #' in favour of `db_write_table()`. #' #' @return Usually a logical value indicating success. Most failures should generate #' an error. However, `db_has_table()` should return `NA` if #' temporary tables cannot be listed with [DBI::dbListTables()] (due to backend #' API limitations for example). As a result, you methods will rely on the #' backend to throw an error if a table exists when it shouldn't. #' @name backend_dbplyr #' @param con A database connection. #' @keywords internal NULL #' @name backend_dbplyr #' @export db_desc <- function(x) UseMethod("db_desc") #' @name backend_dbplyr #' @export sql_translate_env <- function(con) UseMethod("sql_translate_env") #' @name backend_dbplyr #' @export db_list_tables <- function(con) UseMethod("db_list_tables") #' @name backend_dbplyr #' @export #' @param table A string, the table name. db_has_table <- function(con, table) UseMethod("db_has_table") #' @name backend_dbplyr #' @export #' @param fields A list of fields, as in a data frame. db_data_type <- function(con, fields) UseMethod("db_data_type") #' @export #' @name backend_dbplyr #' @export db_save_query <- function(con, sql, name, temporary = TRUE, ...) { UseMethod("db_save_query") } #' @name backend_dbplyr #' @export db_begin <- function(con, ...) UseMethod("db_begin") #' @name backend_dbplyr #' @export db_commit <- function(con, ...) UseMethod("db_commit") #' @name backend_dbplyr #' @export db_rollback <- function(con, ...) UseMethod("db_rollback") #' @name backend_dbplyr #' @export db_write_table <- function(con, table, types, values, temporary = FALSE, ...) { UseMethod("db_write_table") } #' @name backend_dbplyr #' @export db_create_table <- function(con, table, types, temporary = FALSE, ...) { UseMethod("db_create_table") } #' @name backend_dbplyr #' @export db_insert_into <- function(con, table, values, ...) { UseMethod("db_insert_into") } #' @name backend_dbplyr #' @export db_create_indexes <- function(con, table, indexes = NULL, unique = FALSE, ...) { UseMethod("db_create_indexes") } #' @name backend_dbplyr #' @export db_create_index <- function(con, table, columns, name = NULL, unique = FALSE, ...) { UseMethod("db_create_index") } #' @name backend_dbplyr #' @export db_drop_table <- function(con, table, force = FALSE, ...) { UseMethod("db_drop_table") } #' @name backend_dbplyr #' @export db_analyze <- function(con, table, ...) UseMethod("db_analyze") #' @export #' @rdname backend_dbplyr db_explain <- function(con, sql, ...) { UseMethod("db_explain") } #' @rdname backend_dbplyr #' @export db_query_fields <- function(con, sql, ...) { UseMethod("db_query_fields") } #' @rdname backend_dbplyr #' @export db_query_rows <- function(con, sql, ...) { UseMethod("db_query_rows") } #' @rdname backend_dbplyr #' @export sql_select <- function(con, select, from, where = NULL, group_by = NULL, having = NULL, order_by = NULL, limit = NULL, distinct = FALSE, ...) { UseMethod("sql_select") } #' @export #' @rdname backend_dbplyr sql_subquery <- function(con, from, name = random_table_name(), ...) { UseMethod("sql_subquery") } #' @rdname backend_dbplyr #' @export sql_join <- function(con, x, y, vars, type = "inner", by = NULL, ...) { UseMethod("sql_join") } #' @rdname backend_dbplyr #' @export sql_semi_join <- function(con, x, y, anti = FALSE, by = NULL, ...) { UseMethod("sql_semi_join") } #' @rdname backend_dbplyr #' @export sql_set_op <- function(con, x, y, method) { UseMethod("sql_set_op") } #' @rdname backend_dbplyr #' @export sql_escape_string <- function(con, x) UseMethod("sql_escape_string") #' @rdname backend_dbplyr #' @export sql_escape_ident <- function(con, x) UseMethod("sql_escape_ident") dplyr/R/group_nest.R0000644000176200001440000000455413614573562014141 0ustar liggesusers group_nest_impl <- function(.tbl, .key, keep = FALSE){ mutate(group_keys(.tbl), !!.key := group_split_impl(.tbl, isTRUE(keep), environment())) } #' Nest a tibble using a grouping specification #' #' \Sexpr[results=rd, stage=render]{dplyr:::lifecycle("experimental")} #' #' @family grouping functions #' #' @description #' #' Nest a tibble using a grouping specification #' #' @param .tbl A tbl #' @param ... Grouping specification, forwarded to [group_by()] #' @param .key the name of the list column #' @param keep Should the grouping columns be kept in the list column. #' #' @details #' #' @section Grouped data frames: #' #' The primary use case for [group_nest()] is with already grouped data frames, #' typically a result of [group_by()]. In this case [group_nest()] only uses #' the first argument, the grouped tibble, and warns when `...` is used. #' #' @section Ungrouped data frames: #' #' When used on ungrouped data frames, [group_nest()] forwards the `...` to #' [group_by()] before nesting, therefore the `...` are subject to the data mask. #' #' @return A tbl with one row per unique combination of the grouping variables. #' The first columns are the grouping variables, followed by a list column of tibbles #' with matching rows of the remaining columns. #' #' @keywords internal #' @examples #' #' #----- use case 1: a grouped data frame #' iris %>% #' group_by(Species) %>% #' group_nest() #' #' # this can be useful if the grouped data has been altered before nesting #' iris %>% #' group_by(Species) %>% #' filter(Sepal.Length > mean(Sepal.Length)) %>% #' group_nest() #' #' #----- use case 2: using group_nest() on a ungrouped data frame with #' # a grouping specification that uses the data mask #' starwars %>% #' group_nest(species, homeworld) #' #' #' @export group_nest <- function(.tbl, ..., .key = "data", keep = FALSE){ UseMethod("group_nest") } #' @export group_nest.data.frame <- function(.tbl, ..., .key = "data", keep = FALSE) { if (dots_n(...)) { group_nest_impl(group_by(.tbl, ...), .key = .key, keep = keep) } else { tibble(!!.key := list(.tbl)) } } #' @export group_nest.grouped_df <- function(.tbl, ..., .key = "data", keep = FALSE) { if (dots_n(...)) { warn("... is ignored in group_nest(), please use group_by(..., add = TRUE) %>% group_nest()") } group_nest_impl(.tbl, .key = .key, keep = keep) } dplyr/R/compat-dbplyr.R0000644000176200001440000000361313451046652014516 0ustar liggesusers#' dbplyr compatibility functions #' #' @description #' In dplyr 0.7.0, a number of database and SQL functions moved from dplyr to #' dbplyr. The generic functions stayed in dplyr (since there is no easy way #' to conditionally import a generic from different packages), but many other #' SQL and database helper functions moved. If you have written a backend, #' these functions generate the code you need to work with both dplyr 0.5.0 #' dplyr 0.7.0. #' #' @keywords internal #' @export #' @examples #' if (requireNamespace("dbplyr", quietly = TRUE)) { #' wrap_dbplyr_obj("build_sql") #' wrap_dbplyr_obj("base_agg") #' } check_dbplyr <- function() { check_pkg("dbplyr", "communicate with database backends", install = FALSE) } #' @export #' @rdname check_dbplyr wrap_dbplyr_obj <- function(obj_name) { # Silence R CMD check NOTE `UQ<-` <- NULL obj <- getExportedValue("dbplyr", obj_name) obj_sym <- sym(obj_name) dbplyr_sym <- call("::", quote(dbplyr), obj_sym) dplyr_sym <- call("::", quote(dplyr), obj_sym) if (is.function(obj)) { args <- formals() pass_on <- map(set_names(names(args)), sym) dbplyr_call <- expr((!!dbplyr_sym)(!!!pass_on)) dplyr_call <- expr((!!dplyr_sym)(!!!pass_on)) } else { args <- list() dbplyr_call <- dbplyr_sym dplyr_call <- dplyr_sym } body <- expr({ if (utils::packageVersion("dplyr") > "0.5.0") { dplyr::check_dbplyr() !!dbplyr_call } else { !!dplyr_call } }) wrapper <- new_function(args, body, caller_env()) expr(!!obj_sym <- !!get_expr(wrapper)) } utils::globalVariables("!<-") #' @inherit dbplyr::sql #' @export sql <- function(...) { check_dbplyr() dbplyr::sql(...) } #' @inherit dbplyr::ident #' @export #' @examples #' # Identifiers are escaped with " #' if (requireNamespace("dbplyr", quietly = TRUE)) { #' ident("x") #' } ident <- function(...) { check_dbplyr() dbplyr::ident(...) } dplyr/R/join.r0000644000176200001440000002021013614573562012736 0ustar liggesusers#' Join two tbls together #' #' These are generic functions that dispatch to individual tbl methods - see the #' method documentation for details of individual data sources. `x` and #' `y` should usually be from the same data source, but if `copy` is #' `TRUE`, `y` will automatically be copied to the same source as `x`. #' #' @section Join types: #' #' Currently dplyr supports four types of mutating joins, two types of filtering joins, and #' a nesting join. #' #' \strong{Mutating joins} combine variables from the two data.frames: #' #' \describe{ #' \item{`inner_join()`}{return all rows from `x` where there are matching #' values in `y`, and all columns from `x` and `y`. If there are multiple matches #' between `x` and `y`, all combination of the matches are returned.} #' #' \item{`left_join()`}{return all rows from `x`, and all columns from `x` #' and `y`. Rows in `x` with no match in `y` will have `NA` values in the new #' columns. If there are multiple matches between `x` and `y`, all combinations #' of the matches are returned.} #' #' \item{`right_join()`}{return all rows from `y`, and all columns from `x` #' and y. Rows in `y` with no match in `x` will have `NA` values in the new #' columns. If there are multiple matches between `x` and `y`, all combinations #' of the matches are returned.} #' #' \item{`full_join()`}{return all rows and all columns from both `x` and `y`. #' Where there are not matching values, returns `NA` for the one missing.} #' } #' #' #' \strong{Filtering joins} keep cases from the left-hand data.frame: #' #' \describe{ #' \item{`semi_join()`}{return all rows from `x` where there are matching #' values in `y`, keeping just columns from `x`. #' #' A semi join differs from an inner join because an inner join will return #' one row of `x` for each matching row of `y`, where a semi #' join will never duplicate rows of `x`.} #' #' \item{`anti_join()`}{return all rows from `x` where there are not #' matching values in `y`, keeping just columns from `x`.} #' } #' #' \strong{Nesting joins} create a list column of data.frames: #' #' \describe{ #' \item{`nest_join()`}{return all rows and all columns from `x`. Adds a #' list column of tibbles. Each tibble contains all the rows from `y` #' that match that row of `x`. When there is no match, the list column is #' a 0-row tibble with the same column names and types as `y`. #' #' `nest_join()` is the most fundamental join since you can recreate the other joins from it. #' An `inner_join()` is a `nest_join()` plus an [tidyr::unnest()], and `left_join()` is a #' `nest_join()` plus an `unnest(.drop = FALSE)`. #' A `semi_join()` is a `nest_join()` plus a `filter()` where you check that every element of data has #' at least one row, and an `anti_join()` is a `nest_join()` plus a `filter()` where you check every element has zero rows. #' } #' } #' #' @section Grouping: #' #' Groups are ignored for the purpose of joining, but the result preserves #' the grouping of `x`. #' #' @param x,y tbls to join #' @param by a character vector of variables to join by. If `NULL`, the #' default, `*_join()` will do a natural join, using all variables with #' common names across the two tables. A message lists the variables so #' that you can check they're right (to suppress the message, simply #' explicitly list the variables that you want to join). #' #' To join by different variables on x and y use a named vector. #' For example, `by = c("a" = "b")` will match `x.a` to #' `y.b`. #' @param copy If `x` and `y` are not from the same data source, #' and `copy` is `TRUE`, then `y` will be copied into the #' same src as `x`. This allows you to join tables across srcs, but #' it is a potentially expensive operation so you must opt into it. #' @param suffix If there are non-joined duplicate variables in `x` and #' `y`, these suffixes will be added to the output to disambiguate them. #' Should be a character vector of length 2. #' @param name the name of the list column nesting joins create. If `NULL` the name of `y` is used. #' @param keep If `TRUE` the by columns are kept in the nesting joins. #' @param ... other parameters passed onto methods, for instance, `na_matches` #' to control how `NA` values are matched. See \link{join.tbl_df} for more. #' @name join #' @examples #' # "Mutating" joins combine variables from the LHS and RHS #' band_members %>% inner_join(band_instruments) #' band_members %>% left_join(band_instruments) #' band_members %>% right_join(band_instruments) #' band_members %>% full_join(band_instruments) #' #' # "Filtering" joins keep cases from the LHS #' band_members %>% semi_join(band_instruments) #' band_members %>% anti_join(band_instruments) #' #' # "Nesting" joins keep cases from the LHS and nests the RHS #' band_members %>% nest_join(band_instruments) #' #' # To suppress the message, supply by #' band_members %>% inner_join(band_instruments, by = "name") #' # This is good practice in production code #' #' # Use a named `by` if the join variables have different names #' band_members %>% full_join(band_instruments2, by = c("name" = "artist")) #' # Note that only the key from the LHS is kept NULL #' @rdname join #' @export inner_join <- function(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ...) { UseMethod("inner_join") } #' @rdname join #' @export left_join <- function(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ...) { UseMethod("left_join") } #' @rdname join #' @export right_join <- function(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ...) { UseMethod("right_join") } #' @rdname join #' @export full_join <- function(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ...) { UseMethod("full_join") } #' @rdname join #' @export semi_join <- function(x, y, by = NULL, copy = FALSE, ...) { UseMethod("semi_join") } #' @rdname join #' @export nest_join <- function(x, y, by = NULL, copy = FALSE, keep = FALSE, name = NULL, ...) { UseMethod("nest_join") } #' @rdname join #' @export anti_join <- function(x, y, by = NULL, copy = FALSE, ...) { UseMethod("anti_join") } #' Extract out common by variables #' #' @export #' @keywords internal common_by <- function(by = NULL, x, y) UseMethod("common_by", by) #' @export common_by.character <- function(by, x, y) { by <- common_by_from_vector(by) common_by.list(by, x, y) } common_by_from_vector <- function(by) { by <- by[!duplicated(by)] by_x <- names(by) %||% by by_y <- unname(by) # If x partially named, assume unnamed are the same in both tables by_x[by_x == ""] <- by_y[by_x == ""] list(x = by_x, y = by_y) } #' @export common_by.list <- function(by, x, y) { x_vars <- tbl_vars(x) if (!all(by$x %in% x_vars)) { bad_args("by", "can't contain join column {missing} which is missing from LHS", missing = fmt_obj(setdiff(by$x, x_vars)) ) } y_vars <- tbl_vars(y) if (!all(by$y %in% y_vars)) { bad_args("by", "can't contain join column {missing} which is missing from RHS", missing = fmt_obj(setdiff(by$y, y_vars)) ) } by } #' @export common_by.NULL <- function(by, x, y) { by <- intersect(tbl_vars(x), tbl_vars(y)) if (length(by) == 0) { bad_args("by", "required, because the data sources have no common variables") } inform(auto_by_msg(by)) list( x = by, y = by ) } auto_by_msg <- function(by) { by_quoted <- encodeString(by, quote = '"') if (length(by_quoted) == 1L) { by_code <- by_quoted } else { by_code <- paste0("c(", paste(by_quoted, collapse = ", "), ")") } paste0("Joining, by = ", by_code) } #' @export common_by.default <- function(by, x, y) { bad_args("by", "must be a (named) character vector, list, or NULL for ", "natural joins (not recommended in production code), not {friendly_type_of(by)}" ) } check_suffix <- function(x) { if (!is.character(x) || length(x) != 2) { bad_args("suffix", "must be a character vector of length 2, ", "not {friendly_type_of(x)} of length {length(x)}" ) } if (any(is.na(x))) { bad_args("suffix", "can't be NA") } if (all(x == "")) { bad_args("suffix", "can't be empty string for both `x` and `y` suffixes") } list(x = x[[1]], y = x[[2]]) } dplyr/R/tbl-cube.r0000644000176200001440000003165013614573562013506 0ustar liggesusers#' A data cube tbl #' #' A cube tbl stores data in a compact array format where dimension #' names are not needlessly repeated. They are particularly appropriate for #' experimental data where all combinations of factors are tried (e.g. #' complete factorial designs), or for storing the result of aggregations. #' Compared to data frames, they will occupy much less memory when variables #' are crossed, not nested. #' #' `tbl_cube` support is currently experimental and little performance #' optimisation has been done, but you may find them useful if your data #' already comes in this form, or you struggle with the memory overhead of the #' sparse/crossed of data frames. There is no support for hierarchical #' indices (although I think that would be a relatively straightforward #' extension to storing data frames for indices rather than vectors). #' #' @section Implementation: #' #' Manipulation functions: #' #' \itemize{ #' \item `select()` (M) #' #' \item `summarise()` (M), corresponds to roll-up, but rather more #' limited since there are no hierarchies. #' #' \item `filter()` (D), corresponds to slice/dice. #' #' \item `mutate()` (M) is not implemented, but should be relatively #' straightforward given the implementation of `summarise`. #' #' \item `arrange()` (D?) Not implemented: not obvious how much sense #' it would make #' } #' #' Joins: not implemented. See `vignettes/joins.graffle` for ideas. #' Probably straightforward if you get the indexes right, and that's probably #' some straightforward array/tensor operation. #' #' @export #' @param dimensions A named list of vectors. A dimension is a variable #' whose values are known before the experiment is conducted; they are #' fixed by design (in \pkg{reshape2} they are known as id variables). #' `tbl_cubes` are dense which means that almost every combination of #' the dimensions should have associated measurements: missing values require #' an explicit NA, so if the variables are nested, not crossed, the #' majority of the data structure will be empty. Dimensions are typically, #' but not always, categorical variables. #' @param measures A named list of arrays. A measure is something that is #' actually measured, and is not known in advance. The dimension of each #' array should be the same as the length of the dimensions. Measures are #' typically, but not always, continuous values. #' @seealso [as.tbl_cube()] for ways of coercing existing data #' structures into a `tbl_cube`. #' @examples #' # The built in nasa dataset records meterological data (temperature, #' # cloud cover, ozone etc) for a 4d spatio-temporal dataset (lat, long, #' # month and year) #' nasa #' head(as.data.frame(nasa)) #' #' titanic <- as.tbl_cube(Titanic) #' head(as.data.frame(titanic)) #' #' admit <- as.tbl_cube(UCBAdmissions) #' head(as.data.frame(admit)) #' #' as.tbl_cube(esoph, dim_names = 1:3) #' #' # Some manipulation examples with the NASA dataset -------------------------- #' #' # select() operates only on measures: it doesn't affect dimensions in any way #' select(nasa, cloudhigh:cloudmid) #' select(nasa, matches("temp")) #' #' # filter() operates only on dimensions #' filter(nasa, lat > 0, year == 2000) #' # Each component can only refer to one dimensions, ensuring that you always #' # create a rectangular subset #' \dontrun{filter(nasa, lat > long)} #' #' # Arrange is meaningless for tbl_cubes #' #' by_loc <- group_by(nasa, lat, long) #' summarise(by_loc, pressure = max(pressure), temp = mean(temperature)) tbl_cube <- function(dimensions, measures) { if (!is.list(dimensions) || any_apply(dimensions, Negate(is.atomic)) || is.null(names(dimensions))) { bad_args("dimensions", "must be a named list of vectors, ", "not {friendly_type_of(dimensions)}" ) } if (!is.list(measures) || any_apply(measures, Negate(is.array)) || is.null(names(measures))) { bad_args("measures", "must be a named list of arrays, ", "not {friendly_type_of(measures)}" ) } # Check measures have correct dimensions dims <- vapply(dimensions, length, integer(1), USE.NAMES = FALSE) dims_ok <- vapply( measures, function(x) identical(unname(dim(x)), dims), logical(1) ) if (any(!dims_ok)) { bad <- names(measures)[!dims_ok] bad_measures(bad, "needs dimensions {fmt_dims(dims)}, not {bad_dim}", bad_dim = fmt_dims(dim(measures[!dims_ok][[1L]])) ) } structure(list(dims = dimensions, mets = measures), class = "tbl_cube") } #' @export tbl_vars.tbl_cube <- function(x) names(x$dims) #' @export dim.tbl_cube <- function(x) { c(length(x$mets[[1]]), length(x$dims)) } #' @export same_src.tbl_cube <- function(x, y) { inherits(y, "tbl_cube") } #' @export print.tbl_cube <- function(x, ...) { cat("Source: local array ", dim_desc(x), "\n", sep = "") if (!is.null(x$groups)) { cat( "Grouped by: ", paste(names(x$dims)[x$groups], collapse = ", "), "\n", sep = "" ) } # Dimensions types <- vapply(x$dims, type_sum, character(1)) lengths <- vapply(x$dims, length, integer(1)) vars <- paste0("D: ", names(x$dims), " [", types, ", ", lengths, "]") cat(vars, sep = "\n") # Measures types <- vapply(x$mets, type_sum, character(1)) vars <- paste0("M: ", names(x$mets), " [", types, "]") cat(vars, sep = "\n") invisible(x) } # Coercion methods (from tbl_cube) --------------------------------------------- #' Coerce a `tbl_cube` to other data structures #' #' Supports conversion to tables, data frames, tibbles. #' #' @param x a `tbl_cube` #' @param ... Passed on to individual methods; otherwise ignored. #' @param measure A measure name or index, default: the first measure #' @name as.table.tbl_cube #' @export as.table.tbl_cube <- function(x, ..., measure = 1L) { ret <- x$mets[[measure]] dimnames(ret) <- x$dims class(ret) <- "table" ret } #' @rdname as.table.tbl_cube #' @export as.data.frame.tbl_cube <- function(x, ...) { dims <- expand.grid(x$dims, KEEP.OUT.ATTRS = FALSE, ...) mets <- lapply(x$mets, as.vector) all <- c(dims, mets) class(all) <- "data.frame" attr(all, "row.names") <- .set_row_names(nrow(dims)) all } #' @rdname as.table.tbl_cube #' @description For a cube, the data frame returned by #' [tibble::as_tibble()] resulting data frame contains the #' dimensions as character values (and not as factors). #' @export as_tibble.tbl_cube <- function(x, ...) { as_tibble(as.data.frame(x, ..., stringsAsFactors = FALSE)) } # Coercion methods ------------------------------------------------------------- #' Coerce an existing data structure into a `tbl_cube` #' #' @param x an object to convert. Built in methods will convert arrays, #' tables and data frames. #' @param ... Passed on to individual methods; otherwise ignored. #' @export as.tbl_cube <- function(x, ...) UseMethod("as.tbl_cube") #' @export #' @rdname as.tbl_cube #' @param dim_names names of the dimensions. Defaults to the names of #' @param met_name a string to use as the name for the measure #' the [dimnames()]. as.tbl_cube.array <- function(x, dim_names = names(dimnames(x)), met_name = deparse(substitute(x)), ...) { force(met_name) dims <- dimnames(x) dims <- lapply(dims, utils::type.convert, as.is = TRUE) mets <- setNames(list(undimname(x)), met_name) tbl_cube(dims, mets) } undimname <- function(x) { dimnames(x) <- NULL x } #' @export #' @rdname as.tbl_cube as.tbl_cube.table <- function(x, dim_names = names(dimnames(x)), met_name = "Freq", ...) { as.tbl_cube.array(unclass(x), dim_names = dim_names, met_name = met_name) } #' @export #' @rdname as.tbl_cube as.tbl_cube.matrix <- as.tbl_cube.array guess_met <- function(df) { if ("Freq" %in% names(df)) { met <- "Freq" } else { is_num <- vapply(df, is.numeric, logical(1L)) met <- names(df)[is_num] } inform(paste0("Using ", paste(met, collapse = ", "), " as measure column(s): use `met_name` to override.")) met } #' @export #' @rdname as.tbl_cube as.tbl_cube.data.frame <- function(x, dim_names = NULL, met_name = guess_met(x), ...) { if (is.null(dim_names)) { dim_names <- setdiff(names(x), met_name) } else { met_name <- NULL if (!is.character(dim_names)) { dim_names <- names(x)[dim_names] } } if (is.null(met_name)) { met_name <- setdiff(names(x), dim_names) } else if (!is.character(met_name)) { met_name <- names(x)[met_name] } dims <- lapply(x[dim_names], unique) n <- vapply(dims, length, integer(1)) grid <- expand.grid(dims, KEEP.OUT.ATTRS = FALSE, stringsAsFactors = FALSE) all <- left_join(grid, x, by = dim_names) if (nrow(all) > nrow(grid)) { dupe_row <- anyDuplicated(all[dim_names]) dupe <- unlist(all[dupe_row, dim_names]) bad_args("x", "must be unique in all combinations of dimension variables, ", "duplicates: {fmt_named(dupe)}" ) } mets <- lapply(met_name, function(i) array(all[[i]], unname(n))) names(mets) <- met_name tbl_cube(dims, mets) } # Verbs ------------------------------------------------------------------- #' @export select.tbl_cube <- function(.data, ...) { vars <- tidyselect::vars_select(names(.data$mets), ...) .data$mets <- .data$mets[vars] .data } #' @export select_.tbl_cube <- function(.data, ..., .dots = list()) { dots <- compat_lazy_dots(.dots, caller_env(), ...) select(.data, !!!dots) } #' @export rename.tbl_cube <- function(.data, ...) { vars <- tidyselect::vars_rename(names(.data$mets), !!!enquos(...)) .data$mets <- .data$mets[vars] .data } #' @export rename_.tbl_cube <- function(.data, ..., .dots = list()) { dots <- compat_lazy_dots(.dots, caller_env(), ...) rename(.data, !!!dots) } #' @export filter.tbl_cube <- function(.data, ...) { dots <- enquos(...) idx <- map2_int( seq_along(dots), dots, function(i, d) find_index_check(i, d, names(.data$dims)) ) for (i in seq_along(dots)) { sel <- eval_tidy(dots[[i]], .data$dims) sel <- sel & !is.na(sel) .data$dims[[idx[i]]] <- .data$dims[[idx[i]]][sel] .data$mets <- lapply(.data$mets, subs_index, idx[i], sel) } .data } #' @export filter_.tbl_cube <- function(.data, ..., .dots = list()) { dots <- compat_lazy_dots(.dots, caller_env(), ...) filter(.data, !!!dots) } find_index_check <- function(i, x, names) { idx <- find_index(quo_get_expr(x), names) if (length(idx) != 1) { bad_calls(x, "must refer to exactly one dimension, ", "not {fmt_obj(names[idx])}" ) } idx } find_index <- function(x, names) { # Base cases if (is.atomic(x)) return(integer()) if (is.name(x)) { var <- as.character(x) return(which(var == names)) } # Recursive case: function call stopifnot(is.call(x)) unlist(lapply(x[-1], find_index, names = names)) } #' @export group_by.tbl_cube <- function(.data, ..., add = FALSE, .drop = FALSE) { groups <- group_by_prepare(.data, ..., add = add) # Convert symbols to indices groups$data$groups <- match(groups$group_names, names(groups$data$dims)) groups$data } #' @export group_by_.tbl_cube <- function(.data, ..., .dots = list(), add = FALSE) { dots <- compat_lazy_dots(.dots, caller_env(), ...) group_by(.data, !!!dots, add = add) } #' @export groups.tbl_cube <- function(x) { lapply(group_vars(x), as.name) } #' @export group_vars.tbl_cube <- function(x) { names(x$dims[x$groups]) } # mutate and summarise operate similarly need to evaluate variables in special # context - need to use the same active environment tricks as in dplyr # for better performance #' @export summarise.tbl_cube <- function(.data, ...) { dots <- enquos(..., .named = TRUE) out_dims <- .data$dims[.data$groups] n <- lengths(out_dims) out_mets <- list() for (nm in names(dots)) { out_mets[[nm]] <- array(logical(), n) } slices <- expand.grid(map(out_dims, seq_along), KEEP.OUT.ATTRS = FALSE) # Loop over each group for (i in seq_len(nrow(slices))) { index <- as.list(slices[i, , drop = FALSE]) mets <- map( .data$mets, subs_index, i = .data$groups, val = index, drop = TRUE ) # Loop over each expression for (j in seq_along(dots)) { res <- eval_tidy(dots[[j]], mets) out_mets[[j]][i] <- res } } structure(list(dims = out_dims, mets = out_mets), class = "tbl_cube") } #' @export summarise_.tbl_cube <- function(.data, ..., .dots = list()) { dots <- compat_lazy_dots(.dots, caller_env(), ...) summarise(.data, !!!dots) } subs_index <- function(x, i, val, drop = FALSE) { dims <- length(dim(x) %||% 1) args <- rep(list(quote(expr = )), dims) if (length(i) == 1 && is.atomic(val)) { args[[i]] <- quote(val) } else if (length(i) >= 1 && is.list(val)) { exprs <- lapply( seq_along(i), function(i) as.call(c(quote(`[[`), quote(val), i)) ) args[i] <- exprs } else { abort("Invalid input") } args$drop <- drop call <- as.call(c(quote(`[`), quote(x), args)) eval_bare(call) } #' @export auto_copy.tbl_cube <- function(x, y, copy = FALSE, ...) { abort("Copying not supported by tbl_cube") } dplyr/R/dr.R0000644000176200001440000000175013614573561012353 0ustar liggesusersRcpp_version <- utils::packageVersion("Rcpp") R_version <- R.version.string #' Dr Dplyr checks your installation for common problems. #' #' Only run this if you are seeing problems, like random crashes. #' It's possible for `dr_dplyr` to return false positives, so there's no #' need to run if all is ok. #' #' @export #' @examples #' \dontrun{ #' dr_dplyr() #' } dr_dplyr <- function() { if (Rcpp_version != utils::packageVersion("Rcpp")) { warning( "Installed Rcpp (", utils::packageVersion("Rcpp"), ") different from ", "Rcpp used to build dplyr (", Rcpp_version, ").\n", "Please reinstall dplyr to avoid random crashes or undefined behavior.", call. = FALSE ) } if (R_version != R.version.string) { warning( "Installed R (", R.version.string, ") different from ", "R used to build dplyr (", R_version, ").\n", "Please reinstall dplyr to avoid random crashes or undefined behavior.", call. = FALSE ) } invisible(NULL) } dplyr/R/group_map.R0000644000176200001440000001311713614573562013740 0ustar liggesusers as_group_map_function <- function(.f) { .f <- rlang::as_function(.f) if (length(form <- formals(.f)) < 2 && ! "..." %in% names(form)){ stop("The function must accept at least two arguments. You can use ... to absorb unused components") } .f } #' Apply a function to each group #' #' \Sexpr[results=rd, stage=render]{dplyr:::lifecycle("experimental")} #' #' @description #' #' `group_map()`, `group_modify()` and `group_walk()` are purrr-style functions that can #' be used to iterate on grouped tibbles. #' #' @details #' #' Use `group_modify()` when `summarize()` is too limited, in terms of what you need #' to do and return for each group. `group_modify()` is good for "data frame in, data frame out". #' If that is too limited, you need to use a [nested][group_nest()] or [split][group_split()] workflow. #' `group_modify()` is an evolution of [do()], if you have used that before. #' #' Each conceptual group of the data frame is exposed to the function `.f` with two pieces of information: #' #' - The subset of the data for the group, exposed as `.x`. #' - The key, a tibble with exactly one row and columns for each grouping variable, exposed as `.y`. #' #' For completeness, `group_modify()`, `group_map` and `group_walk()` also work on #' ungrouped data frames, in that case the function is applied to the #' entire data frame (exposed as `.x`), and `.y` is a one row tibble with no #' column, consistently with [group_keys()]. #' #' @family grouping functions #' #' @param .tbl A grouped tibble #' @param .f A function or formula to apply to each group. It must return a data frame. #' #' If a __function__, it is used as is. It should have at least 2 formal arguments. #' #' If a __formula__, e.g. `~ head(.x)`, it is converted to a function. #' #' In the formula, you can use #' #' - `.` or `.x` to refer to the subset of rows of `.tbl` #' for the given group #' #' - `.y` to refer to the key, a one row tibble with one column per grouping variable #' that identifies the group #' #' @param ... Additional arguments passed on to `.f` #' @param keep are the grouping variables kept in `.x` #' #' @return #' - `group_modify()` returns a grouped tibble. In that case `.f` must return a data frame. #' - `group_map()` returns a list of results from calling `.f` on each group #' - `group_walk()` calls `.f` for side effects and returns the input `.tbl`, invisibly #' #' @examples #' #' # return a list #' mtcars %>% #' group_by(cyl) %>% #' group_map(~ head(.x, 2L)) #' #' # return a tibble grouped by `cyl` with 2 rows per group #' # the grouping data is recalculated #' mtcars %>% #' group_by(cyl) %>% #' group_modify(~ head(.x, 2L)) #' #' if (requireNamespace("broom", quietly = TRUE)) { #' # a list of tibbles #' iris %>% #' group_by(Species) %>% #' group_map(~ broom::tidy(lm(Petal.Length ~ Sepal.Length, data = .x))) #' #' # a restructured grouped tibble #' iris %>% #' group_by(Species) %>% #' group_modify(~ broom::tidy(lm(Petal.Length ~ Sepal.Length, data = .x))) #' } #' #' # a list of vectors #' iris %>% #' group_by(Species) %>% #' group_map(~ quantile(.x$Petal.Length, probs = c(0.25, 0.5, 0.75))) #' #' # to use group_modify() the lambda must return a data frame #' iris %>% #' group_by(Species) %>% #' group_modify(~ { #' quantile(.x$Petal.Length, probs = c(0.25, 0.5, 0.75)) %>% #' tibble::enframe(name = "prob", value = "quantile") #' }) #' #' iris %>% #' group_by(Species) %>% #' group_modify(~ { #' .x %>% #' purrr::map_dfc(fivenum) %>% #' mutate(nms = c("min", "Q1", "median", "Q3", "max")) #' }) #' #' # group_walk() is for side effects #' dir.create(temp <- tempfile()) #' iris %>% #' group_by(Species) %>% #' group_walk(~ write.csv(.x, file = file.path(temp, paste0(.y$Species, ".csv")))) #' list.files(temp, pattern = "csv$") #' unlink(temp, recursive = TRUE) #' #' # group_modify() and ungrouped data frames #' mtcars %>% #' group_modify(~ head(.x, 2L)) #' #' @export group_map <- function(.tbl, .f, ..., keep = FALSE) { .f <- as_group_map_function(.f) # call the function on each group chunks <- group_split(.tbl, keep = isTRUE(keep)) keys <- group_keys(.tbl) group_keys <- map(seq_len(nrow(keys)), function(i) keys[i, , drop = FALSE]) if (length(chunks)) { map2(chunks, group_keys, .f, ...) } else { # calling .f with .x and .y set to prototypes structure(list(), ptype = .f(attr(chunks, "ptype"), keys[integer(0L), ], ...)) } } #' @rdname group_map #' @export group_modify <- function(.tbl, .f, ..., keep = FALSE) { UseMethod("group_modify") } #' @export group_modify.data.frame <- function(.tbl, .f, ..., keep = FALSE) { .f <- as_group_map_function(.f) .f(.tbl, group_keys(.tbl), ...) } #' @export group_modify.grouped_df <- function(.tbl, .f, ..., keep = FALSE) { tbl_group_vars <- group_vars(.tbl) .f <- as_group_map_function(.f) fun <- function(.x, .y){ res <- .f(.x, .y, ...) if (!inherits(res, "data.frame")) { abort("The result of .f should be a data frame") } if (any(bad <- names(res) %in% tbl_group_vars)) { abort(sprintf( "The returned data frame cannot contain the original grouping variables : ", paste(names(res)[bad], collapse = ", ") )) } bind_cols(.y[rep(1L, nrow(res)), , drop = FALSE], res) } chunks <- group_map(.tbl, fun, ..., keep = keep) res <- if (length(chunks) > 0L) { bind_rows(!!!chunks) } else { attr(chunks, "ptype") } group_by(res, !!!groups(.tbl), .drop = group_by_drop_default(.tbl)) } #' @export #' @rdname group_map group_walk <- function(.tbl, .f, ...) { group_map(.tbl, .f, ...) .tbl } dplyr/R/utils-expr.R0000644000176200001440000000144713574646634014074 0ustar liggesusers expr_type_of <- function(x) { type <- typeof(x) if (type %in% c("symbol", "language", "pairlist", "NULL")) { type } else { "literal" } } switch_expr <- function(.x, ...) { switch(expr_type_of(.x), ...) } node_walk_replace <- function(node, old, new) { while (!is_null(node)) { switch_expr(node_car(node), language = node_walk_replace(node_cdar(node), old, new), symbol = if (identical(node_car(node), old)) node_poke_car(node, new) ) node <- node_cdr(node) } } expr_substitute <- function(expr, old, new) { expr <- duplicate(expr) switch(typeof(expr), quosure = node_walk_replace(quo_get_expr(expr), old, new), formula = , language = node_walk_replace(node_cdr(expr), old, new), symbol = if (identical(expr, old)) return(new) ) expr } dplyr/R/location.R0000644000176200001440000000422113614573562013553 0ustar liggesusers#' Print the location in memory of a data frame #' #' This is useful for understand how and when dplyr makes copies of data #' frames #' #' @param df a data frame #' @param x,y two data frames to compare #' @keywords internal #' @export #' @examples #' location(mtcars) #' #' mtcars2 <- mutate(mtcars, cyl2 = cyl * 2) #' location(mtcars2) #' #' changes(mtcars, mtcars) #' changes(mtcars, mtcars2) location <- function(df) { assert_that(is.data.frame(df)) structure(list( df = loc(df), vars = dfloc(df), attr = plfloc(attributes(df)) ), class = "location") } #' @export print.location <- function(x, ...) { cat("<", x$df, ">\n", sep = "") width <- max(nchar(c(names(x$vars), names(x$attr)))) + 1 def_list <- function(x) { term <- format(paste0(names(x), ":"), width = width) paste0(" * ", term, " <", format(x), ">") } vars <- paste0(def_list(x$vars), collapse = "\n") cat("Variables:\n", vars, "\n", sep = "") attr <- paste0(def_list(x$attr), collapse = "\n") cat("Attributes:\n", attr, "\n", sep = "") invisible(x) } #' @rdname location #' @export changes <- function(x, y) { x <- location(x) y <- location(y) if (x$df == y$df) { cat("\n") return(invisible()) } # match up x vars to y vars vars <- match_up(x$vars, y$vars) attr <- match_up(x$attr, y$attr) width <- max(nchar(rownames(vars)), nchar(rownames(attr))) if (nrow(vars) > 0) rownames(vars) <- format(rownames(vars), width = width) if (nrow(attr) > 0) rownames(attr) <- format(rownames(attr), width = width) if (nrow(vars) > 0) { cat("Changed variables:\n") print(vars, quote = FALSE) } if (nrow(vars) > 0 && nrow(attr)) cat("\n") if (nrow(attr) > 0) { cat("Changed attributes:\n") print(attr, quote = FALSE) } } match_up <- function(x, y) { both <- intersect(names(x), names(y)) added <- setdiff(names(x), names(y)) deleted <- setdiff(names(y), names(x)) out <- cbind( old = c(x[both], x[added], rep("", length(deleted))), new = c(y[both], rep("", length(added)), y[deleted]) ) rownames(out) <- c(both, added, deleted) out[out[, "old"] != out[, "new"], , drop = FALSE] } dplyr/R/utils.r0000644000176200001440000000343213614573562013146 0ustar liggesusers#' @importFrom magrittr %>% #' @export magrittr::`%>%` dots <- function(...) { eval_bare(substitute(alist(...))) } deparse_trunc <- function(x, width = getOption("width")) { text <- deparse(x, width.cutoff = width) if (length(text) == 1 && nchar(text) < width) return(text) paste0(substr(text[1], 1, width - 3), "...") } any_apply <- function(xs, f) { for (x in xs) { if (f(x)) return(TRUE) } FALSE } deparse_names <- function(x) { x <- map_if(x, is_quosure, quo_squash) x <- map_if(x, is_bare_formula, f_rhs) map_chr(x, deparse) } commas <- function(...) paste0(..., collapse = ", ") in_travis <- function() identical(Sys.getenv("TRAVIS"), "true") named <- function(...) { x <- c(...) missing_names <- names2(x) == "" names(x)[missing_names] <- x[missing_names] x } unique_name <- local({ i <- 0 function() { i <<- i + 1 paste0("zzz", i) } }) succeeds <- function(x, quiet = FALSE) { tryCatch( # { x TRUE }, error = function(e) { if (!quiet) { inform(paste0("Error: ", e$message)) } FALSE } ) } is_1d <- function(x) { # dimension check is for matrices and data.frames (is_atomic(x) || is.list(x)) && length(dim(x)) <= 1 } random_table_name <- function(n = 10) { paste0(sample(letters, n, replace = TRUE), collapse = "") } attr_equal <- function(x, y) { attr_x <- attributes(x) if (!is.null(attr_x)) { attr_x <- attr_x[sort(names(attr_x))] } attr_y <- attributes(y) if (!is.null(attr_y)) { attr_y <- attr_y[sort(names(attr_y))] } isTRUE(all.equal(attr_x, attr_y)) } unstructure <- function(x) { attributes(x) <- NULL x } compact_null <- function(x) { Filter(function(elt) !is.null(elt), x) } paste_line <- function(...) { paste(chr(...), collapse = "\n") } dplyr/R/group_data.R0000644000176200001440000000211013614573562014063 0ustar liggesusers#' @rdname group_data #' @export group_rows <- function(.data) { group_data(.data)[[".rows"]] } #' Grouping data #' #' @family grouping functions #' @param .data a tibble #' #' @return `group_data()` return a tibble with one row per group. The last column, always called `.rows` #' is a list of integer vectors indicating the rows for each group. #' If `.data` is a grouped data frame the first columns are the grouping variables. #' `group_rows()` just returns the list of indices. #' #' @examples #' df <- tibble(x = c(1,1,2,2)) #' #' # one row #' group_data(df) #' group_rows(df) #' #' # 2 rows, one for each group #' group_by(df,x) %>% group_data() #' group_by(df,x) %>% group_rows() #' #' @export group_data <- function(.data) { UseMethod("group_data") } #' @export group_data.data.frame <- function(.data) { rows <- list(seq_len(nrow(.data))) tibble(".rows" := rows) } #' @export group_data.rowwise_df <- function(.data) { rows <- as.list(seq_len(nrow(.data))) tibble(".rows" := rows) } #' @export group_data.grouped_df <- function(.data) { group_data_grouped_df(.data) } dplyr/R/bind.r0000644000176200001440000001126313614573561012722 0ustar liggesusers#' Efficiently bind multiple data frames by row and column #' #' This is an efficient implementation of the common pattern of #' `do.call(rbind, dfs)` or `do.call(cbind, dfs)` for binding many #' data frames into one. #' #' The output of `bind_rows()` will contain a column if that column #' appears in any of the inputs. #' #' @section Deprecated functions: #' `rbind_list()` and `rbind_all()` have been deprecated. Instead use #' `bind_rows()`. #' #' @param ... Data frames to combine. #' #' Each argument can either be a data frame, a list that could be a data #' frame, or a list of data frames. #' #' When row-binding, columns are matched by name, and any missing #' columns will be filled with NA. #' #' When column-binding, rows are matched by position, so all data #' frames must have the same number of rows. To match by value, not #' position, see [join]. #' @param .id Data frame identifier. #' #' When `.id` is supplied, a new column of identifiers is #' created to link each row to its original data frame. The labels #' are taken from the named arguments to `bind_rows()`. When a #' list of data frames is supplied, the labels are taken from the #' names of the list. If no names are found a numeric sequence is #' used instead. #' @return `bind_rows()` and `bind_cols()` return the same type as #' the first input, either a data frame, `tbl_df`, or `grouped_df`. #' @aliases rbind_all rbind_list #' @examples #' one <- mtcars[1:4, ] #' two <- mtcars[11:14, ] #' #' # You can supply data frames as arguments: #' bind_rows(one, two) #' #' # The contents of lists are spliced automatically: #' bind_rows(list(one, two)) #' bind_rows(split(mtcars, mtcars$cyl)) #' bind_rows(list(one, two), list(two, one)) #' #' #' # In addition to data frames, you can supply vectors. In the rows #' # direction, the vectors represent rows and should have inner #' # names: #' bind_rows( #' c(a = 1, b = 2), #' c(a = 3, b = 4) #' ) #' #' # You can mix vectors and data frames: #' bind_rows( #' c(a = 1, b = 2), #' tibble(a = 3:4, b = 5:6), #' c(a = 7, b = 8) #' ) #' #' #' # Note that for historical reasons, lists containing vectors are #' # always treated as data frames. Thus their vectors are treated as #' # columns rather than rows, and their inner names are ignored: #' ll <- list( #' a = c(A = 1, B = 2), #' b = c(A = 3, B = 4) #' ) #' bind_rows(ll) #' #' # You can circumvent that behaviour with explicit splicing: #' bind_rows(!!!ll) #' #' #' # When you supply a column name with the `.id` argument, a new #' # column is created to link each row to its original data frame #' bind_rows(list(one, two), .id = "id") #' bind_rows(list(a = one, b = two), .id = "id") #' bind_rows("group 1" = one, "group 2" = two, .id = "groups") #' #' # Columns don't need to match when row-binding #' bind_rows(data.frame(x = 1:3), data.frame(y = 1:4)) #' \dontrun{ #' # Rows do need to match when column-binding #' bind_cols(data.frame(x = 1), data.frame(y = 1:2)) #' } #' #' bind_cols(one, two) #' bind_cols(list(one, two)) #' @name bind NULL #' @export #' @rdname bind bind_rows <- function(..., .id = NULL) { x <- flatten_bindable(dots_values(...)) if (!length(x)) { # Handle corner cases gracefully, but always return a tibble if (inherits(x, "data.frame")) { return(x) } else { return(tibble()) } } if (!is_null(.id)) { if (!(is_string(.id))) { bad_args(".id", "must be a scalar string, ", "not {friendly_type_of(.id)} of length {length(.id)}" ) } if (!all(have_name(x) | map_lgl(x, is_empty))) { x <- compact(x) names(x) <- seq_along(x) } } bind_rows_(x, .id) } #' @export #' @rdname bind bind_cols <- function(...) { x <- flatten_bindable(dots_values(...)) out <- cbind_all(x) tibble::repair_names(out) } #' Combine vectors #' #' \Sexpr[results=rd, stage=render]{dplyr:::lifecycle("questioning")} #' #' @description #' `combine()` acts like [c()] or #' [unlist()] but uses consistent dplyr coercion rules. #' #' If `combine()` it is called with exactly one list argument, the list is #' simplified (similarly to `unlist(recursive = FALSE)`). `NULL` arguments are #' ignored. If the result is empty, `logical()` is returned. #' Use [vctrs::vec_c()] if you never want to unlist. #' #' @param ... Vectors to combine. #' #' @seealso #' `bind_rows()` and `bind_cols()` in [bind]. #' #' @export #' @examples #' # combine applies the same coercion rules as bind_rows() #' f1 <- factor("a") #' f2 <- factor("b") #' c(f1, f2) #' unlist(list(f1, f2)) #' #' combine(f1, f2) #' combine(list(f1, f2)) combine <- function(...) { args <- list2(...) if (length(args) == 1 && is.list(args[[1]])) { combine_all(args[[1]]) } else { combine_all(args) } } dplyr/R/rbind.R0000644000176200001440000000300113614573562013034 0ustar liggesuserslist_or_dots <- function(...) { dots <- list2(...) if (!length(dots)) { return(dots) } # Old versions specified that first argument could be a list of # dataframeable objects if (is_list(dots[[1]])) { dots[[1]] <- map_if(dots[[1]], is_dataframe_like, as_tibble) } # Need to ensure that each component is a data frame or a vector # wrapped in a list: dots <- map_if(dots, is_dataframe_like, function(x) list(as_tibble(x))) dots <- map_if(dots, is_atomic, list) dots <- map_if(dots, is.data.frame, list) unlist(dots, recursive = FALSE) } is_dataframe_like <- function(x) { if (is_null(x)) { return(FALSE) } # data frames are not data lists if (is.data.frame(x)) { return(FALSE) } # Must be a list if (!is_list(x)) { return(FALSE) } # 0 length named list (#1515) if (!is_null(names(x)) && length(x) == 0) { return(TRUE) } # With names if (!is_named(x)) { return(FALSE) } # Where each element is an 1d vector or list if (!every(x, is_1d)) { return(FALSE) } # All of which have the same length n <- lengths(x) if (any(n != n[1])) { return(FALSE) } TRUE } # Deprecated functions ---------------------------------------------------- #' @export #' @rdname bind #' @usage NULL rbind_list <- function(...) { .Deprecated("bind_rows()") tbl_df(bind_rows_(list_or_dots(...), id = NULL)) } #' @export #' @rdname bind #' @usage NULL rbind_all <- function(x, id = NULL) { .Deprecated("bind_rows()") bind_rows_(x, id = id) } dplyr/R/if_else.R0000644000176200001440000000343213451046652013346 0ustar liggesusers#' Vectorised if #' #' Compared to the base [ifelse()], this function is more strict. #' It checks that `true` and `false` are the same type. This #' strictness makes the output type more predictable, and makes it somewhat #' faster. #' #' @param condition Logical vector #' @param true,false Values to use for `TRUE` and `FALSE` values of #' `condition`. They must be either the same length as `condition`, #' or length 1. They must also be the same type: `if_else()` checks that #' they have the same type and same class. All other attributes are #' taken from `true`. #' @param missing If not `NULL`, will be used to replace missing #' values. #' @return Where `condition` is `TRUE`, the matching value from #' `true`, where it's `FALSE`, the matching value from `false`, #' otherwise `NA`. #' @export #' @examples #' x <- c(-5:5, NA) #' if_else(x < 0, NA_integer_, x) #' if_else(x < 0, "negative", "positive", "missing") #' #' # Unlike ifelse, if_else preserves types #' x <- factor(sample(letters[1:5], 10, replace = TRUE)) #' ifelse(x %in% c("a", "b", "c"), x, factor(NA)) #' if_else(x %in% c("a", "b", "c"), x, factor(NA)) #' # Attributes are taken from the `true` vector, if_else <- function(condition, true, false, missing = NULL) { if (!is.logical(condition)) { bad_args("condition", "must be a logical vector, not {friendly_type_of(condition)}") } out <- true[rep(NA_integer_, length(condition))] out <- replace_with( out, condition, true, fmt_args(~ true), glue("length of {fmt_args(~condition)}") ) out <- replace_with( out, !condition, false, fmt_args(~ false), glue("length of {fmt_args(~condition)}") ) out <- replace_with( out, is.na(condition), missing, fmt_args(~ missing), glue("length of {fmt_args(~condition)}") ) out } dplyr/R/inline.r0000644000176200001440000000021513614573562013260 0ustar liggesusersinlineCxxPlugin <- Rcpp.plugin.maker( include.before = "#include ", package = "dplyr", LinkingTo = c("Rcpp", "BH", "dplyr") ) dplyr/R/explain.r0000644000176200001440000000255013451046652013440 0ustar liggesusers#' Explain details of a tbl #' #' This is a generic function which gives more details about an object than #' [print()], and is more focused on human readable output than #' [str()]. #' #' @section Databases: #' Explaining a `tbl_sql` will run the SQL `EXPLAIN` command which #' will describe the query plan. This requires a little bit of knowledge about #' how `EXPLAIN` works for your database, but is very useful for #' diagnosing performance problems. #' #' @export #' @param x An object to explain #' @param ... Other parameters possibly used by generic #' @return The first argument, invisibly. #' @examples #' \donttest{ #' if (require("dbplyr")) { #' #' lahman_s <- lahman_sqlite() #' batting <- tbl(lahman_s, "Batting") #' batting %>% show_query() #' batting %>% explain() #' #' # The batting database has indices on all ID variables: #' # SQLite automatically picks the most restrictive index #' batting %>% filter(lgID == "NL" & yearID == 2000L) %>% explain() #' #' # OR's will use multiple indexes #' batting %>% filter(lgID == "NL" | yearID == 2000) %>% explain() #' #' # Joins will use indexes in both tables #' teams <- tbl(lahman_s, "Teams") #' batting %>% left_join(teams, c("yearID", "teamID")) %>% explain() #' } #' } explain <- function(x, ...) { UseMethod("explain") } #' @export #' @rdname explain show_query <- function(x, ...) { UseMethod("show_query") } dplyr/R/compute-collect.r0000644000176200001440000000256213614573561015107 0ustar liggesusers#' Force computation of a database query #' #' `compute()` stores results in a remote temporary table. #' `collect()` retrieves data into a local tibble. #' `collapse()` is slightly different: it doesn't force computation, but #' instead forces generation of the SQL query. This is sometimes needed to work #' around bugs in dplyr's SQL generation. #' #' All functions preserve grouping and ordering. #' #' @param x A tbl #' @param name Name of temporary table on database. #' @param ... Other arguments passed on to methods #' @inheritParams copy_to.src_sql #' @seealso [copy_to()], the opposite of `collect()`: it takes a local data #' frame and uploads it to the remote source. #' @export #' @examples #' if (require(dbplyr)) { #' mtcars2 <- src_memdb() %>% #' copy_to(mtcars, name = "mtcars2-cc", overwrite = TRUE) #' #' remote <- mtcars2 %>% #' filter(cyl == 8) %>% #' select(mpg:drat) #' #' # Compute query and save in remote table #' compute(remote) #' #' # Compute query bring back to this session #' collect(remote) #' #' # Creates a fresh query based on the generated SQL #' collapse(remote) #' } compute <- function(x, name = random_table_name(), ...) { UseMethod("compute") } #' @export #' @rdname compute collect <- function(x, ...) { UseMethod("collect") } #' @export #' @rdname compute collapse <- function(x, ...) { UseMethod("collapse") } dplyr/R/error.R0000644000176200001440000001041713614573561013077 0ustar liggesuserscheck_pkg <- function(name, reason, install = TRUE) { if (is_installed(name)) { return(invisible(TRUE)) } glubort(NULL, "The {name} package is required to {reason}.", if (install) '\nPlease install it with `install.packages("{name}")`' else "" ) } # ngettext() does extra work, this function is a simpler version ntext <- function(n, msg1, msg2) { if (n == 1) msg1 else msg2 } bad <- function(..., .envir = parent.frame()) { glubort(NULL, ..., .envir = parent.frame()) } bad_args <- function(args, ..., .envir = parent.frame()) { glubort(fmt_args(args), ..., .envir = .envir) } bad_pos_args <- function(pos_args, ..., .envir = parent.frame()) { glubort(fmt_pos_args(pos_args), ..., .envir = .envir) } bad_calls <- function(calls, ..., .envir = parent.frame()) { glubort(fmt_calls(calls), ..., .envir = .envir) } bad_named_calls <- function(named_calls, ..., .envir = parent.frame()) { glubort(fmt_named_calls(named_calls), ..., .envir = .envir) } bad_eq_ops <- function(named_calls, ..., .envir = parent.frame()) { glubort(fmt_wrong_eq_ops(named_calls), ..., .envir = .envir) } bad_cols <- function(cols, ..., .envir = parent.frame()) { glubort(fmt_cols(cols), ..., .envir = .envir) } bad_measures <- function(measures, ..., .envir = parent.frame()) { glubort(fmt_measures(measures), ..., .envir = .envir) } glubort <- function(header, ..., .envir = parent.frame(), .abort = abort) { text <- glue(..., .envir = .envir) if (!is_null(header)) text <- paste0(header, " ", text) .abort(text) } fmt_args <- function(x) { x <- parse_args(x) fmt_obj(x) } fmt_pos_args <- function(x) { args <- ntext(length(x), "Argument", "Arguments") glue("{args} {fmt_comma(x)}") } fmt_calls <- function(...) { x <- parse_named_call(...) fmt_obj(x) } fmt_named_calls <- function(...) { x <- parse_named_call(...) fmt_named(x) } fmt_wrong_eq_ops <- function(...) { x <- parse_named_call(...) fmt_comma( paste0(fmt_obj1(names2(x)), " (", fmt_obj1(paste0(names2(x), " = ", x)), ")") ) } fmt_cols <- function(x) { cols <- ntext(length(x), "Column", "Columns") glue("{cols} {fmt_obj(x)}") } fmt_measures <- function(x) { measures <- ntext(length(x), "Measure", "Measures") glue("{measures} {fmt_obj(x)}") } fmt_named <- function(x) { fmt_comma(paste0(fmt_obj1(names2(x)), " = ", x)) } fmt_obj <- function(x) { fmt_comma(fmt_obj1(x)) } fmt_obj1 <- function(x) { paste0("`", x, "`") } fmt_classes <- function(x) { paste(class(x), collapse = "/") } fmt_dims <- function(x) { paste0("[", paste0(x, collapse = " x "), "]") } fmt_comma <- function(..., .max = 6) { x <- paste0(...) if (length(x) > .max) { length(x) <- .max x[[.max]] <- "..." } commas(x) } fmt_items <- function(x, .max = 6) { if (length(x) > .max) { more <- glue("({length(x) - (.max - 1)} more)") length(x) <- .max x[.max] <- more } paste0(glue("- {x}"), collapse = "\n") } parse_args <- function(x) { # convert single formula to list of length 1 x <- unlist(list(x), recursive = FALSE) is_fml <- map_lgl(x, is_formula) x[is_fml] <- map_chr(map(x[is_fml], "[[", 2), as_string) unlist(x) } parse_named_call <- function(x) { map_chr(x, quo_text) } # From rlang friendly_type_of <- function(x) { if (is.object(x)) { sprintf("a `%s` object", fmt_classes(x)) } else { as_friendly_type(typeof(x)) } } 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 ) } dplyr/R/colwise-group-by.R0000644000176200001440000000404113614573561015151 0ustar liggesusers#' Group by a selection of variables #' #' These [scoped] variants of [group_by()] group a data frame by a #' selection of variables. Like [group_by()], they have optional #' [mutate] semantics. #' #' @family grouping functions #' @inheritParams scoped #' @inheritParams group_by #' @param .add See [group_by()] #' #' @export #' #' @section Grouping variables: #' #' Existing grouping variables are maintained, even if not included in #' the selection. #' #' @examples #' # Group a data frame by all variables: #' group_by_all(mtcars) #' #' # Group by variables selected with a predicate: #' group_by_if(iris, is.factor) #' #' # Group by variables selected by name: #' group_by_at(mtcars, vars(vs, am)) #' #' # Like group_by(), the scoped variants have optional mutate #' # semantics. This provide a shortcut for group_by() + mutate(): #' d <- tibble(x=c(1,1,2,2), y=c(1,2,1,2)) #' group_by_all(d, as.factor) #' group_by_if(iris, is.factor, as.character) group_by_all <- function(.tbl, .funs = list(), ..., .add = FALSE, .drop = group_by_drop_default(.tbl)) { funs <- manip_all(.tbl, .funs, enquo(.funs), caller_env(), ...) if (!length(funs)) { funs <- syms(tbl_vars(.tbl)) } .group_by_static_drop(.tbl, !!!funs, add = .add, .drop = .drop) } #' @rdname group_by_all #' @export group_by_at <- function(.tbl, .vars, .funs = list(), ..., .add = FALSE, .drop = group_by_drop_default(.tbl)) { funs <- manip_at(.tbl, .vars, .funs, enquo(.funs), caller_env(), .include_group_vars = TRUE, ...) if (!length(funs)) { funs <- tbl_at_syms(.tbl, .vars, .include_group_vars = TRUE) } .group_by_static_drop(.tbl, !!!funs, add = .add, .drop = .drop) } #' @rdname group_by_all #' @export group_by_if <- function(.tbl, .predicate, .funs = list(), ..., .add = FALSE, .drop = group_by_drop_default(.tbl)) { funs <- manip_if(.tbl, .predicate, .funs, enquo(.funs), caller_env(), .include_group_vars = TRUE, ...) if (!length(funs)) { funs <- tbl_if_syms(.tbl, .predicate, .include_group_vars = TRUE) } .group_by_static_drop(.tbl, !!!funs, add = .add, .drop = .drop) } dplyr/R/utils-replace-with.R0000644000176200001440000000301113451046652015453 0ustar liggesusersreplace_with <- function(x, i, val, name, reason = NULL) { if (is.null(val)) { return(x) } check_length(val, x, name, reason) check_type(val, x, name) check_class(val, x, name) i[is.na(i)] <- FALSE if (length(val) == 1L) { x[i] <- val } else { x[i] <- val[i] } x } check_length <- function(x, template, header, reason = NULL) { check_length_val(length(x), length(template), header, reason) } check_length_col <- function(length_x, n, name, reason = NULL, .abort = abort) { check_length_val(length_x, n, fmt_cols(name), reason, .abort = .abort) } check_length_val <- function(length_x, n, header, reason = NULL, .abort = abort) { if (all(length_x %in% c(1L, n))) { return() } if (is.null(reason)) { reason <- "" } else { reason <- glue(" ({reason})") } if (n == 1) { glubort(header, "must be length 1{reason}, not {commas(length_x)}", .abort = .abort) } else { glubort(header, "must be length {n}{reason} or one, not {commas(length_x)}", .abort = .abort) } } check_type <- function(x, template, header) { if (identical(typeof(x), typeof(template))) { return() } glubort(header, "must be {friendly_type_of(template)}, not {friendly_type_of(x)}") } check_class <- function(x, template, header) { if (!is.object(x)) { return() } if (identical(class(x), class(template))) { return() } exp_classes <- fmt_classes(template) out_classes <- fmt_classes(x) glubort(header, "must have class `{exp_classes}`, not class `{out_classes}`") } dplyr/R/manip.r0000644000176200001440000006327413614573562013124 0ustar liggesusers#' Return rows with matching conditions #' #' Use `filter()` to choose rows/cases where conditions are true. Unlike #' base subsetting with `[`, rows where the condition evaluates to `NA` are #' dropped. #' #' Note that dplyr is not yet smart enough to optimise filtering optimisation #' on grouped datasets that don't need grouped calculations. For this reason, #' filtering is often considerably faster on [ungroup()]ed data. #' #' @section Useful filter functions: #' #' * [`==`], [`>`], [`>=`] etc #' * [`&`], [`|`], [`!`], [xor()] #' * [is.na()] #' * [between()], [near()] #' #' @section Grouped tibbles: #' #' Because filtering expressions are computed within groups, they may #' yield different results on grouped tibbles. This will be the case #' as soon as an aggregating, lagging, or ranking function is #' involved. Compare this ungrouped filtering: #' #' ``` #' starwars %>% filter(mass > mean(mass, na.rm = TRUE)) #' ``` #' #' With the grouped equivalent: #' #' ``` #' starwars %>% group_by(gender) %>% filter(mass > mean(mass, na.rm = TRUE)) #' ``` #' #' The former keeps rows with `mass` greater than the global average #' whereas the latter keeps rows with `mass` greater than the gender #' average. #' #' It is valid to use grouping variables in filter expressions. #' #' When applied on a grouped tibble, `filter()` automatically [rearranges][arrange] #' the tibble by groups for performance reasons. #' #' @section Tidy data: #' When applied to a data frame, row names are silently dropped. To preserve, #' convert to an explicit variable with [tibble::rownames_to_column()]. #' #' @section Scoped filtering: #' The three [scoped] variants ([filter_all()], [filter_if()] and #' [filter_at()]) make it easy to apply a filtering condition to a #' selection of variables. #' #' @family single table verbs #' @param .data A tbl. All main verbs are S3 generics and provide methods #' for [tbl_df()], [dtplyr::tbl_dt()] and [dbplyr::tbl_dbi()]. #' @param ... Logical predicates defined in terms of the variables in `.data`. #' Multiple conditions are combined with `&`. Only rows where the #' condition evaluates to `TRUE` are kept. #' #' The arguments in `...` are automatically [quoted][rlang::quo] and #' [evaluated][rlang::eval_tidy] in the context of the data #' frame. They support [unquoting][rlang::quasiquotation] and #' splicing. See `vignette("programming")` for an introduction to #' these concepts. #' @param .preserve when `FALSE` (the default), the grouping structure #' is recalculated based on the resulting data, otherwise it is kept as is. #' @return An object of the same class as `.data`. #' @seealso [filter_all()], [filter_if()] and [filter_at()]. #' @export #' @examples #' filter(starwars, species == "Human") #' filter(starwars, mass > 1000) #' #' # Multiple criteria #' filter(starwars, hair_color == "none" & eye_color == "black") #' filter(starwars, hair_color == "none" | eye_color == "black") #' #' # Multiple arguments are equivalent to and #' filter(starwars, hair_color == "none", eye_color == "black") #' #' #' # The filtering operation may yield different results on grouped #' # tibbles because the expressions are computed within groups. #' # #' # The following filters rows where `mass` is greater than the #' # global average: #' starwars %>% filter(mass > mean(mass, na.rm = TRUE)) #' #' # Whereas this keeps rows with `mass` greater than the gender #' # average: #' starwars %>% group_by(gender) %>% filter(mass > mean(mass, na.rm = TRUE)) #' #' #' # Refer to column names stored as strings with the `.data` pronoun: #' vars <- c("mass", "height") #' cond <- c(80, 150) #' starwars %>% #' filter( #' .data[[vars[[1]]]] > cond[[1]], #' .data[[vars[[2]]]] > cond[[2]] #' ) #' #' # For more complex cases, knowledge of tidy evaluation and the #' # unquote operator `!!` is required. See https://tidyeval.tidyverse.org/ #' # #' # One useful and simple tidy eval technique is to use `!!` to bypass #' # the data frame and its columns. Here is how to filter the columns #' # `mass` and `height` relative to objects of the same names: #' mass <- 80 #' height <- 150 #' filter(starwars, mass > !!mass, height > !!height) filter <- function(.data, ..., .preserve = FALSE) { UseMethod("filter") } #' @export filter.default <- function(.data, ..., .preserve = FALSE) { filter_(.data, .dots = compat_as_lazy_dots(...)) } #' @export #' @rdname se-deprecated filter_ <- function(.data, ..., .dots = list()) { signal_soft_deprecated(paste_line( "filter_() is deprecated. ", "Please use filter() instead", "", "The 'programming' vignette or the tidyeval book can help you", "to program with filter() : https://tidyeval.tidyverse.org" )) UseMethod("filter_") } #' Choose rows by position #' #' Choose rows by their ordinal position in the tbl. Grouped tbls use #' the ordinal position within the group. #' #' Slice does not work with relational databases because they have no #' intrinsic notion of row order. If you want to perform the equivalent #' operation, use [filter()] and [row_number()]. #' #' @family single table verbs #' @param .data A tbl. #' @param ... Integer row values. Provide either positive values to keep, #' or negative values to drop. The values provided must be either all #' positive or all negative. Indices beyond the number of rows in the #' input are silently ignored. #' #' The arguments in `...` are automatically [quoted][rlang::quo] and #' [evaluated][rlang::eval_tidy] in the context of the data #' frame. They support [unquoting][rlang::quasiquotation] and #' splicing. See `vignette("programming")` for an introduction to #' these concepts. #' @inheritParams filter #' @inheritSection filter Tidy data #' @export #' @examples #' slice(mtcars, 1L) #' # Similar to tail(mtcars, 1): #' slice(mtcars, n()) #' slice(mtcars, 5:n()) #' # Rows can be dropped with negative indices: #' slice(mtcars, -5:-n()) #' # In this case, the result will be equivalent to: #' slice(mtcars, 1:4) #' #' by_cyl <- group_by(mtcars, cyl) #' slice(by_cyl, 1:2) #' #' # Equivalent code using filter that will also work with databases, #' # but won't be as fast for in-memory data. For many databases, you'll #' # need to supply an explicit variable to use to compute the row number. #' filter(mtcars, row_number() == 1L) #' filter(mtcars, row_number() == n()) #' filter(mtcars, between(row_number(), 5, n())) slice <- function(.data, ..., .preserve = FALSE) { UseMethod("slice") } #' @export slice.default <- function(.data, ..., .preserve = FALSE) { slice_(.data, .dots = compat_as_lazy_dots(...)) } #' @export #' @rdname se-deprecated slice_ <- function(.data, ..., .dots = list()) { signal_soft_deprecated(paste_line( "slice_() is deprecated. ", "Please use slice() instead", "", "The 'programming' vignette or the tidyeval book can help you", "to program with slice() : https://tidyeval.tidyverse.org" )) UseMethod("slice_") } #' Reduce multiple values down to a single value #' #' Create one or more scalar variables summarizing the variables of an #' existing tbl. Tbls with groups created by [group_by()] will result in one #' row in the output for each group. Tbls with no groups will result in one row. #' #' `summarise()` and `summarize()` are synonyms. #' #' @section Useful functions: #' #' * Center: [mean()], [median()] #' * Spread: [sd()], [IQR()], [mad()] #' * Range: [min()], [max()], [quantile()] #' * Position: [first()], [last()], [nth()], #' * Count: [n()], [n_distinct()] #' * Logical: [any()], [all()] #' #' @section Backend variations: #' #' The data frame backend supports creating a variable and using it in the #' same summary. This means that previously created summary variables can be #' further transformed or combined within the summary, as in [mutate()]. #' However, it also means that summary variables with the same names as previous #' variables overwrite them, making those variables unavailable to later summary #' variables. #' #' This behaviour may not be supported in other backends. To avoid unexpected #' results, consider using new names for your summary variables, especially when #' creating multiple summaries. #' #' @export #' @inheritParams filter #' @inheritSection filter Tidy data #' @param ... Name-value pairs of summary functions. The name will be the #' name of the variable in the result. The value should be an expression #' that returns a single value like `min(x)`, `n()`, or `sum(is.na(y))`. #' #' The arguments in `...` are automatically [quoted][rlang::quo] and #' [evaluated][rlang::eval_tidy] in the context of the data #' frame. They support [unquoting][rlang::quasiquotation] and #' splicing. See `vignette("programming")` for an introduction to #' these concepts. #' @family single table verbs #' @return An object of the same class as `.data`. One grouping level will #' be dropped. #' @examples #' # A summary applied to ungrouped tbl returns a single row #' mtcars %>% #' summarise(mean = mean(disp), n = n()) #' #' # Usually, you'll want to group first #' mtcars %>% #' group_by(cyl) %>% #' summarise(mean = mean(disp), n = n()) #' #' # Each summary call removes one grouping level (since that group #' # is now just a single row) #' mtcars %>% #' group_by(cyl, vs) %>% #' summarise(cyl_n = n()) %>% #' group_vars() #' #' #' # Reusing variable names when summarising may lead to unexpected results #' mtcars %>% #' group_by(cyl) %>% #' summarise(disp = mean(disp), sd = sd(disp), double_disp = disp * 2) #' #' #' # Refer to column names stored as strings with the `.data` pronoun: #' var <- "mass" #' summarise(starwars, avg = mean(.data[[var]], na.rm = TRUE)) #' #' # For more complex cases, knowledge of tidy evaluation and the #' # unquote operator `!!` is required. See https://tidyeval.tidyverse.org/ #' # #' # One useful and simple tidy eval technique is to use `!!` to #' # bypass the data frame and its columns. Here is how to divide the #' # column `mass` by an object of the same name: #' mass <- 100 #' summarise(starwars, avg = mean(mass / !!mass, na.rm = TRUE)) summarise <- function(.data, ...) { UseMethod("summarise") } #' @export summarise.default <- function(.data, ...) { summarise_(.data, .dots = compat_as_lazy_dots(...)) } #' @export #' @rdname se-deprecated summarise_ <- function(.data, ..., .dots = list()) { signal_soft_deprecated(paste_line( "summarise_() is deprecated. ", "Please use summarise() instead", "", "The 'programming' vignette or the tidyeval book can help you", "to program with summarise() : https://tidyeval.tidyverse.org" )) UseMethod("summarise_") } #' @rdname summarise #' @export summarize <- summarise #' @rdname se-deprecated #' @export summarize_ <- summarise_ #' Create or transform variables #' #' `mutate()` adds new variables and preserves existing ones; #' `transmute()` adds new variables and drops existing ones. Both #' functions preserve the number of rows of the input. #' New variables overwrite existing variables of the same name. #' #' @section Useful functions available in calculations of variables: #' #' * [`+`], [`-`], [log()], etc., for their usual mathematical meanings #' #' * [lead()], [lag()] #' #' * [dense_rank()], [min_rank()], [percent_rank()], [row_number()], #' [cume_dist()], [ntile()] #' #' * [cumsum()], [cummean()], [cummin()], [cummax()], [cumany()], [cumall()] #' #' * [na_if()], [coalesce()] #' #' * [if_else()], [recode()], [case_when()] #' #' @section Grouped tibbles: #' #' Because mutating expressions are computed within groups, they may #' yield different results on grouped tibbles. This will be the case #' as soon as an aggregating, lagging, or ranking function is #' involved. Compare this ungrouped mutate: #' #' ``` #' starwars %>% #' mutate(mass / mean(mass, na.rm = TRUE)) %>% #' pull() #' ``` #' #' With the grouped equivalent: #' #' ``` #' starwars %>% #' group_by(gender) %>% #' mutate(mass / mean(mass, na.rm = TRUE)) %>% #' pull() #' ``` #' #' The former normalises `mass` by the global average whereas the #' latter normalises by the averages within gender levels. #' #' Note that you can't overwrite a grouping variable within #' `mutate()`. #' #' `mutate()` does not evaluate the expressions when the group is empty. #' #' @section Scoped mutation and transmutation: #' #' The three [scoped] variants of `mutate()` ([mutate_all()], #' [mutate_if()] and [mutate_at()]) and the three variants of #' `transmute()` ([transmute_all()], [transmute_if()], #' [transmute_at()]) make it easy to apply a transformation to a #' selection of variables. #' #' @export #' @inheritParams filter #' @inheritSection filter Tidy data #' @param ... Name-value pairs of expressions, each with length 1 or the same #' length as the number of rows in the group (if using [group_by()]) or in the entire #' input (if not using groups). The name of each argument will be the name of #' a new variable, and the value will be its corresponding value. Use a `NULL` #' value in `mutate` to drop a variable. New variables overwrite existing variables #' of the same name. #' #' The arguments in `...` are automatically [quoted][rlang::quo] and #' [evaluated][rlang::eval_tidy] in the context of the data #' frame. They support [unquoting][rlang::quasiquotation] and #' splicing. See `vignette("programming")` for an introduction to #' these concepts. #' @family single table verbs #' @return An object of the same class as `.data`. #' @examples #' # Newly created variables are available immediately #' mtcars %>% as_tibble() %>% mutate( #' cyl2 = cyl * 2, #' cyl4 = cyl2 * 2 #' ) #' #' # You can also use mutate() to remove variables and #' # modify existing variables #' mtcars %>% as_tibble() %>% mutate( #' mpg = NULL, #' disp = disp * 0.0163871 # convert to litres #' ) #' #' #' # window functions are useful for grouped mutates #' mtcars %>% #' group_by(cyl) %>% #' mutate(rank = min_rank(desc(mpg))) #' # see `vignette("window-functions")` for more details #' #' # You can drop variables by setting them to NULL #' mtcars %>% mutate(cyl = NULL) #' #' # mutate() vs transmute -------------------------- #' # mutate() keeps all existing variables #' mtcars %>% #' mutate(displ_l = disp / 61.0237) #' #' # transmute keeps only the variables you create #' mtcars %>% #' transmute(displ_l = disp / 61.0237) #' #' #' # The mutate operation may yield different results on grouped #' # tibbles because the expressions are computed within groups. #' # The following normalises `mass` by the global average: #' starwars %>% #' mutate(mass / mean(mass, na.rm = TRUE)) %>% #' pull() #' #' # Whereas this normalises `mass` by the averages within gender #' # levels: #' starwars %>% #' group_by(gender) %>% #' mutate(mass / mean(mass, na.rm = TRUE)) %>% #' pull() #' #' # Note that you can't overwrite grouping variables: #' gdf <- mtcars %>% group_by(cyl) #' try(mutate(gdf, cyl = cyl * 100)) #' #' #' # Refer to column names stored as strings with the `.data` pronoun: #' vars <- c("mass", "height") #' mutate(starwars, prod = .data[[vars[[1]]]] * .data[[vars[[2]]]]) #' #' # For more complex cases, knowledge of tidy evaluation and the #' # unquote operator `!!` is required. See https://tidyeval.tidyverse.org/ #' # #' # One useful and simple tidy eval technique is to use `!!` to #' # bypass the data frame and its columns. Here is how to divide the #' # column `mass` by an object of the same name: #' mass <- 100 #' mutate(starwars, mass = mass / !!mass) mutate <- function(.data, ...) { UseMethod("mutate") } #' @export mutate.default <- function(.data, ...) { mutate_(.data, .dots = compat_as_lazy_dots(...)) } #' @export #' @rdname se-deprecated mutate_ <- function(.data, ..., .dots = list()) { signal_soft_deprecated(paste_line( "mutate_() is deprecated. ", "Please use mutate() instead", "", "The 'programming' vignette or the tidyeval book can help you", "to program with mutate() : https://tidyeval.tidyverse.org" )) UseMethod("mutate_") } #' @rdname mutate #' @export transmute <- function(.data, ...) { UseMethod("transmute") } #' @rdname se-deprecated #' @export transmute_ <- function(.data, ..., .dots = list()) { signal_soft_deprecated(paste_line( "transmute_() is deprecated. ", "Please use transmute() instead", "", "The 'programming' vignette or the tidyeval book can help you", "to program with transmute() : https://tidyeval.tidyverse.org" )) UseMethod("transmute_") } #' @export transmute.default <- function(.data, ...) { dots <- enquos(..., .named = TRUE) out <- mutate(.data, !!!dots) keep <- names(dots) select(out, one_of(keep)) } #' @export transmute_.default <- function(.data, ..., .dots = list()) { dots <- compat_lazy_dots(.dots, caller_env(), ...) transmute(.data, !!!dots) } #' @export transmute.grouped_df <- function(.data, ...) { dots <- enquos(..., .named = TRUE) out <- mutate(.data, !!!dots) keep <- names(dots) .select_grouped_df(out, one_of(keep), notify = FALSE) } #' @export transmute_.grouped_df <- function(.data, ..., .dots = list()) { dots <- compat_lazy_dots(.dots, caller_env(), ...) transmute(.data, !!!dots) } #' Arrange rows by variables #' #' Order tbl rows by an expression involving its variables. #' #' @section Locales: #' The sort order for character vectors will depend on the collating sequence #' of the locale in use: see [locales()]. #' #' @section Missing values: #' Unlike base sorting with `sort()`, `NA` are: #' * always sorted to the end for local data, even when wrapped with `desc()`. #' * treated differently for remote data, depending on the backend. #' #' @export #' @inheritParams filter #' @inheritSection filter Tidy data #' @param ... Comma separated list of unquoted variable names, or expressions #' involving variable names. Use [desc()] to sort a variable in descending order. #' @family single table verbs #' @return An object of the same class as `.data`. #' @examples #' arrange(mtcars, cyl, disp) #' arrange(mtcars, desc(disp)) #' #' # grouped arrange ignores groups #' by_cyl <- mtcars %>% group_by(cyl) #' by_cyl %>% arrange(desc(wt)) #' # Unless you specifically ask: #' by_cyl %>% arrange(desc(wt), .by_group = TRUE) arrange <- function(.data, ...) { UseMethod("arrange") } #' @export arrange.default <- function(.data, ...) { arrange_(.data, .dots = compat_as_lazy_dots(...)) } #' @export #' @rdname se-deprecated arrange_ <- function(.data, ..., .dots = list()) { signal_soft_deprecated(paste_line( "arrange_() is deprecated. ", "Please use arrange() instead", "", "The 'programming' vignette or the tidyeval book can help you", "to program with arrange() : https://tidyeval.tidyverse.org" )) UseMethod("arrange_") } #' @export #' @rdname arrange #' @param .by_group If `TRUE`, will sort first by grouping variable. Applies to #' grouped data frames only. arrange.grouped_df <- function(.data, ..., .by_group = FALSE) { if (.by_group) { dots <- c(quos(!!!groups(.data)), enquos(...)) } else { dots <- enquos(...) } arrange_impl(.data, dots, environment()) } #' Select/rename variables by name #' #' Choose or rename variables from a tbl. #' `select()` keeps only the variables you mention; `rename()` #' keeps all variables. #' #' These functions work by column index, not value; thus, an expression #' like `select(data.frame(x = 1:5, y = 10), z = x+1)` does not create a variable #' with values `2:6`. (In the current implementation, the expression `z = x+1` #' wouldn't do anything useful.) To calculate using column values, see #' [mutate()]/[transmute()]. #' #' @section Useful functions: #' As well as using existing functions like `:` and `c()`, there are #' a number of special functions that only work inside `select()`: #' #' * [starts_with()], [ends_with()], [contains()] #' * [matches()] #' * [num_range()] #' * [one_of()] #' * [everything()] #' * [group_cols()] #' #' To drop variables, use `-`. #' #' Note that except for `:`, `-` and `c()`, all complex expressions #' are evaluated outside the data frame context. This is to prevent #' accidental matching of data frame variables when you refer to #' variables from the calling context. #' #' @section Scoped selection and renaming: #' #' The three [scoped] variants of `select()` ([select_all()], #' [select_if()] and [select_at()]) and the three variants of #' `rename()` ([rename_all()], [rename_if()], [rename_at()]) make it #' easy to apply a renaming function to a selection of variables. #' #' @inheritParams filter #' @inheritSection filter Tidy data #' @param ... One or more unquoted expressions separated by commas. #' You can treat variable names like they are positions, so you can #' use expressions like `x:y` to select ranges of variables. #' #' Positive values select variables; negative values drop variables. #' If the first expression is negative, `select()` will automatically #' start with all variables. #' #' Use named arguments, e.g. `new_name = old_name`, to rename selected variables. #' #' The arguments in `...` are automatically [quoted][rlang::quo] and #' [evaluated][rlang::eval_tidy] in a context where column names #' represent column positions. They also support #' [unquoting][rlang::quasiquotation] and splicing. See #' `vignette("programming")` for an introduction to these concepts. #' #' See [select helpers][tidyselect::select_helpers] for more details and #' examples about tidyselect helpers such as `starts_with()`, `everything()`, ... #' @return An object of the same class as `.data`. #' @family single table verbs #' @export #' @examples #' iris <- as_tibble(iris) # so it prints a little nicer #' select(iris, starts_with("Petal")) #' select(iris, ends_with("Width")) #' #' # Move Species variable to the front #' select(iris, Species, everything()) #' #' # Move Sepal.Length variable to back #' # first select all variables except Sepal.Length, then re select Sepal.Length #' select(iris, -Sepal.Length, Sepal.Length) #' #' df <- as.data.frame(matrix(runif(100), nrow = 10)) #' df <- tbl_df(df[c(3, 4, 7, 1, 9, 8, 5, 2, 6, 10)]) #' select(df, V4:V6) #' select(df, num_range("V", 4:6)) #' #' # Drop variables with - #' select(iris, -starts_with("Petal")) #' #' # Select the grouping variables: #' starwars %>% group_by(gender) %>% select(group_cols()) #' #' #' # The .data pronoun is available: #' select(mtcars, .data$cyl) #' select(mtcars, .data$mpg : .data$disp) #' #' # However it isn't available within calls since those are evaluated #' # outside of the data context. This would fail if run: #' # select(mtcars, identical(.data$cyl)) #' #' #' # Renaming ----------------------------------------- #' # * select() keeps only the variables you specify #' select(iris, petal_length = Petal.Length) #' #' # * rename() keeps all variables #' rename(iris, petal_length = Petal.Length) #' #' # * select() can rename variables in a group #' select(iris, obs = starts_with('S')) #' #' # Unquoting ---------------------------------------- #' #' # Like all dplyr verbs, select() supports unquoting of symbols: #' vars <- list( #' var1 = sym("cyl"), #' var2 = sym("am") #' ) #' select(mtcars, !!!vars) #' #' # For convenience it also supports strings and character #' # vectors. This is unlike other verbs where strings would be #' # ambiguous. #' vars <- c(var1 = "cyl", var2 ="am") #' select(mtcars, !!vars) #' rename(mtcars, !!vars) select <- function(.data, ...) { UseMethod("select") } #' @export select.default <- function(.data, ...) { select_(.data, .dots = compat_as_lazy_dots(...)) } #' @export #' @rdname se-deprecated select_ <- function(.data, ..., .dots = list()) { signal_soft_deprecated(paste_line( "select_() is deprecated. ", "Please use select() instead", "", "The 'programming' vignette or the tidyeval book can help you", "to program with select() : https://tidyeval.tidyverse.org" )) UseMethod("select_") } #' @export select.list <- function(.data, ...) { abort("`select()` doesn't handle lists.") } #' @rdname select #' @export rename <- function(.data, ...) { UseMethod("rename") } #' @export rename.default <- function(.data, ...) { rename_(.data, .dots = compat_as_lazy_dots(...)) } #' @rdname se-deprecated #' @export rename_ <- function(.data, ..., .dots = list()) { signal_soft_deprecated(paste_line( "rename_() is deprecated. ", "Please use rename() instead", "", "The 'programming' vignette or the tidyeval book can help you", "to program with rename() : https://tidyeval.tidyverse.org" )) UseMethod("rename_") } #' The number of observations in the current group. #' #' This function is implemented specifically for each data source and can only #' be used from within [summarise()], [mutate()] and #' [filter()]. #' #' @export #' @examples #' if (require("nycflights13")) { #' carriers <- group_by(flights, carrier) #' summarise(carriers, n()) #' mutate(carriers, n = n()) #' filter(carriers, n() < 100) #' } n <- function() { from_context("..group_size") } #' Deprecated SE versions of main verbs. #' #' dplyr used to offer twin versions of each verb suffixed with an #' underscore. These versions had standard evaluation (SE) semantics: #' rather than taking arguments by code, like NSE verbs, they took #' arguments by value. Their purpose was to make it possible to #' program with dplyr. However, dplyr now uses tidy evaluation #' semantics. NSE verbs still capture their arguments, but you can now #' unquote parts of these arguments. This offers full programmability #' with NSE verbs. Thus, the underscored versions are now superfluous. #' #' Unquoting triggers immediate evaluation of its operand and inlines #' the result within the captured expression. This result can be a #' value or an expression to be evaluated later with the rest of the #' argument. See `vignette("programming")` for more information. #' #' @name se-deprecated #' @param .data A data frame. #' @param dots,.dots,... Pair/values of expressions coercible to lazy objects. #' @param vars Various meanings depending on the verb. #' @param args Various meanings depending on the verb. #' @keywords internal NULL dplyr/R/group-indices.R0000644000176200001440000000364013614573562014517 0ustar liggesusers#' Group id. #' #' Generate a unique id for each group #' #' @family grouping functions #' @keywords internal #' @seealso [group_by()] #' @param .data a tbl #' @inheritParams group_by #' @inheritParams filter #' @export #' @examples #' group_indices(mtcars, cyl) group_indices <- function(.data, ...) { UseMethod("group_indices") } #' @export group_indices.default <- function(.data, ...) { if (missing(.data)) { rep.int(from_context("..group_number"), from_context("..group_size")) } else { group_indices_(.data, .dots = compat_as_lazy_dots(...)) } } #' @export #' @rdname se-deprecated group_indices_ <- function(.data, ..., .dots = list()) { signal_soft_deprecated(paste_line( "group_indices_() is deprecated. ", "Please use group_indices() instead" )) UseMethod("group_indices_") } #' @export group_indices.data.frame <- function(.data, ..., .drop = TRUE) { dots <- enquos(...) if (length(dots) == 0L) { return(rep(1L, nrow(.data))) } grouped_indices_grouped_df_impl(group_by(.data, !!!dots, .drop = .drop)) } #' @export group_indices_.data.frame <- function(.data, ..., .dots = list()) { dots <- compat_lazy_dots(.dots, caller_env(), ...) group_indices(.data, !!!dots) } #' @export group_indices.rowwise_df <- function(.data, ...) { if (dots_n(...)) { warn("group_indices_.rowwise_df ignores extra arguments") } seq_len(nrow(.data)) } #' @export group_indices_.rowwise_df <- function(.data, ..., .dots = list()) { dots <- compat_lazy_dots(.dots, caller_env(), ...) group_indices(.data, !!!dots) } #' @importFrom rlang dots_n #' @export group_indices.grouped_df <- function(.data, ...) { if (dots_n(...)) { warn("group_indices_.grouped_df ignores extra arguments") } grouped_indices_grouped_df_impl(.data) } #' @export group_indices_.grouped_df <- function(.data, ..., .dots = list()) { dots <- compat_lazy_dots(.dots, caller_env(), ...) group_indices(.data, !!!dots) } dplyr/R/all-equal.r0000644000176200001440000000334013614573561013660 0ustar liggesusers#' Flexible equality comparison for data frames #' #' You can use `all_equal()` with any data frame, and dplyr also provides #' `tbl_df` methods for [all.equal()]. #' #' @param target,current Two data frames to compare. #' @param ignore_col_order Should order of columns be ignored? #' @param ignore_row_order Should order of rows be ignored? #' @param convert Should similar classes be converted? Currently this will #' convert factor to character and integer to double. #' @param ... Ignored. Needed for compatibility with `all.equal()`. #' @return `TRUE` if equal, otherwise a character vector describing #' the reasons why they're not equal. Use [isTRUE()] if using the #' result in an `if` expression. #' @export #' @examples #' scramble <- function(x) x[sample(nrow(x)), sample(ncol(x))] #' #' # By default, ordering of rows and columns ignored #' all_equal(mtcars, scramble(mtcars)) #' #' # But those can be overriden if desired #' all_equal(mtcars, scramble(mtcars), ignore_col_order = FALSE) #' all_equal(mtcars, scramble(mtcars), ignore_row_order = FALSE) #' #' # By default all_equal is sensitive to variable differences #' df1 <- data.frame(x = "a") #' df2 <- data.frame(x = factor("a")) #' all_equal(df1, df2) #' # But you can request dplyr convert similar types #' all_equal(df1, df2, convert = TRUE) all_equal <- function(target, current, ignore_col_order = TRUE, ignore_row_order = TRUE, convert = FALSE, ...) { res <- equal_data_frame(target, current, ignore_col_order = ignore_col_order, ignore_row_order = ignore_row_order, convert = convert ) if (res) { TRUE } else { attr(res, "comment") } } #' @export #' @rdname all_equal #' @method all.equal tbl_df all.equal.tbl_df <- all_equal dplyr/R/do.r0000644000176200001440000001346113614573561012412 0ustar liggesusers#' Do anything #' #' \Sexpr[results=rd, stage=render]{dplyr:::lifecycle("questioning")} #' #' @description This is a general purpose complement to the specialised #' manipulation functions [filter()], [select()], [mutate()], #' [summarise()] and [arrange()]. You can use `do()` #' to perform arbitrary computation, returning either a data frame or #' arbitrary objects which will be stored in a list. This is particularly #' useful when working with models: you can fit models per group with #' `do()` and then flexibly extract components with either another #' `do()` or `summarise()`. #' #' For an empty data frame, the expressions will be evaluated once, even in the #' presence of a grouping. This makes sure that the format of the resulting #' data frame is the same for both empty and non-empty input. #' #' @section Alternative: #' #' `do()` is marked as questioning as of dplyr 0.8.0, and may be advantageously #' replaced by [group_map()]. #' #' @section Connection to plyr: #' #' If you're familiar with plyr, `do()` with named arguments is basically #' equivalent to [plyr::dlply()], and `do()` with a single unnamed argument #' is basically equivalent to [plyr::ldply()]. However, instead of storing #' labels in a separate attribute, the result is always a data frame. This #' means that `summarise()` applied to the result of `do()` can #' act like `ldply()`. #' #' @inheritParams filter #' @param .data a tbl #' @param ... Expressions to apply to each group. If named, results will be #' stored in a new column. If unnamed, should return a data frame. You can #' use `.` to refer to the current group. You can not mix named and #' unnamed arguments. #' @return #' `do()` always returns a data frame. The first columns in the data frame #' will be the labels, the others will be computed from `...`. Named #' arguments become list-columns, with one element for each group; unnamed #' elements must be data frames and labels will be duplicated accordingly. #' #' Groups are preserved for a single unnamed input. This is different to #' [summarise()] because `do()` generally does not reduce the #' complexity of the data, it just expresses it in a special way. For #' multiple named inputs, the output is grouped by row with #' [rowwise()]. This allows other verbs to work in an intuitive #' way. #' @export #' @examples #' by_cyl <- group_by(mtcars, cyl) #' do(by_cyl, head(., 2)) #' #' models <- by_cyl %>% do(mod = lm(mpg ~ disp, data = .)) #' models #' #' summarise(models, rsq = summary(mod)$r.squared) #' models %>% do(data.frame(coef = coef(.$mod))) #' models %>% do(data.frame( #' var = names(coef(.$mod)), #' coef(summary(.$mod))) #' ) #' #' models <- by_cyl %>% do( #' mod_linear = lm(mpg ~ disp, data = .), #' mod_quad = lm(mpg ~ poly(disp, 2), data = .) #' ) #' models #' compare <- models %>% do(aov = anova(.$mod_linear, .$mod_quad)) #' # compare %>% summarise(p.value = aov$`Pr(>F)`) #' #' if (require("nycflights13")) { #' # You can use it to do any arbitrary computation, like fitting a linear #' # model. Let's explore how carrier departure delays vary over the time #' carriers <- group_by(flights, carrier) #' group_size(carriers) #' #' mods <- do(carriers, mod = lm(arr_delay ~ dep_time, data = .)) #' mods %>% do(as.data.frame(coef(.$mod))) #' mods %>% summarise(rsq = summary(mod)$r.squared) #' #' \dontrun{ #' # This longer example shows the progress bar in action #' by_dest <- flights %>% group_by(dest) %>% filter(n() > 100) #' library(mgcv) #' by_dest %>% do(smooth = gam(arr_delay ~ s(dep_time) + month, data = .)) #' } #' } do <- function(.data, ...) { UseMethod("do") } #' @export do.default <- function(.data, ...) { do_(.data, .dots = compat_as_lazy_dots(...)) } #' @export #' @rdname se-deprecated do_ <- function(.data, ..., .dots = list()) { signal_soft_deprecated(paste_line( "do_() is deprecated. ", "Please use group_map() instead" )) UseMethod("do_") } #' @export do.NULL <- function(.data, ...) { NULL } #' @export do_.NULL <- function(.data, ..., .dots = list()) { NULL } # Helper functions ------------------------------------------------------------- env_bind_do_pronouns <- function(env, data) { if (is_function(data)) { bind <- env_bind_active } else { bind <- env_bind } # Use `:=` for `.` to avoid partial matching with `.env` bind(env, "." := data, .data = data) } label_output_dataframe <- function(labels, out, groups, .drop) { data_frame <- vapply(out[[1]], is.data.frame, logical(1)) if (any(!data_frame)) { bad("Results {bad} must be data frames, not {first_bad_class}", bad = fmt_comma(which(!data_frame)), first_bad_class = fmt_classes(out[[1]][[which.min(data_frame)]]) ) } rows <- vapply(out[[1]], nrow, numeric(1)) out <- bind_rows(out[[1]]) if (!is.null(labels)) { # Remove any common columns from labels labels <- labels[setdiff(names(labels), names(out))] # Repeat each row to match data labels <- labels[rep(seq_len(nrow(labels)), rows), , drop = FALSE] rownames(labels) <- NULL grouped_df(bind_cols(labels, out), groups, .drop) } else { rowwise(out) } } label_output_list <- function(labels, out, groups) { if (!is.null(labels)) { labels[names(out)] <- out rowwise(labels) } else { class(out) <- "data.frame" attr(out, "row.names") <- .set_row_names(length(out[[1]])) rowwise(out) } } named_args <- function(args) { # Arguments must either be all named or all unnamed. named <- sum(names2(args) != "") if (!(named == 0 || named == length(args))) { abort("Arguments must either be all named or all unnamed") } if (named == 0 && length(args) > 1) { bad("Can only supply one unnamed argument, not {length(args)}") } # Check for old syntax if (named == 1 && names(args) == ".f") { abort("do syntax changed in dplyr 0.2. Please see documentation for details") } named != 0 } dplyr/R/grouped-df.r0000644000176200001440000002260113614573562014041 0ustar liggesusers#' A grouped data frame. #' #' The easiest way to create a grouped data frame is to call the `group_by()` #' method on a data frame or tbl: this will take care of capturing #' the unevaluated expressions for you. #' #' @keywords internal #' @param data a tbl or data frame. #' @param vars a character vector or a list of [name()] #' @param drop When `.drop = TRUE`, empty groups are dropped. #' @export grouped_df <- function(data, vars, drop = FALSE) { assert_that( is.data.frame(data), (is.list(vars) && all(sapply(vars, is.name))) || is.character(vars) ) if (is.list(vars)) { vars <- deparse_names(vars) } grouped_df_impl(data, unname(vars), drop) } #' Low-level construction and validation for the grouped_df class #' #' `new_grouped_df()` is a constructor designed to be high-performance so only #' check types, not values. This means it is the caller's responsibility #' to create valid values, and hence this is for expert use only. #' #' @param x A data frame #' @param groups The grouped structure, `groups` should be a data frame. #' Its last column should be called `.rows` and be #' a list of 1 based integer vectors that all are between 1 and the number of rows of `.data`. #' @param class additional class, will be prepended to canonical classes of a grouped data frame. #' @param ... additional attributes #' #' @examples #' # 5 bootstrap samples #' tbl <- new_grouped_df( #' tibble(x = rnorm(10)), #' groups = tibble(".rows" := replicate(5, sample(1:10, replace = TRUE), simplify = FALSE)) #' ) #' # mean of each bootstrap sample #' summarise(tbl, x = mean(x)) #' #' @importFrom tibble new_tibble #' @keywords internal #' @export new_grouped_df <- function(x, groups, ..., class = character()) { stopifnot( is.data.frame(x), is.data.frame(groups), tail(names(groups), 1L) == ".rows" ) new_tibble( x, groups = groups, ..., nrow = NROW(x), class = c(class, "grouped_df") ) } #' @description #' `validate_grouped_df()` validates the attributes of a `grouped_df`. #' #' @rdname new_grouped_df #' @export validate_grouped_df <- function(x) { assert_that(is_grouped_df(x)) groups <- attr(x, "groups") assert_that( is.data.frame(groups), ncol(groups) > 0, names(groups)[ncol(groups)] == ".rows", is.list(groups[[ncol(groups)]]), msg = "The `groups` attribute is not a data frame with its last column called `.rows`" ) n <- nrow(x) rows <- groups[[ncol(groups)]] for (i in seq_along(rows)) { indices <- rows[[i]] assert_that( is.integer(indices), msg = "`.rows` column is not a list of one-based integer vectors" ) assert_that( all(indices >= 1 & indices <= n), msg = glue("indices of group {i} are out of bounds") ) } x } setOldClass(c("grouped_df", "tbl_df", "tbl", "data.frame")) #' @rdname grouped_df #' @export is.grouped_df <- function(x) inherits(x, "grouped_df") #' @rdname grouped_df #' @export is_grouped_df <- is.grouped_df group_sum <- function(x) { grps <- n_groups(x) paste0(commas(group_vars(x)), " [", big_mark(grps), "]") } #' @export tbl_sum.grouped_df <- function(x) { c( NextMethod(), c("Groups" = group_sum(x)) ) } #' @export group_size.grouped_df <- function(x) { group_size_grouped_cpp(x) } #' @export n_groups.grouped_df <- function(x) { nrow(group_data(x)) } #' @export groups.grouped_df <- function(x) { syms(group_vars(x)) } #' @export group_vars.grouped_df <- function(x) { groups <- group_data(x) if (is.character(groups)) { # lazy grouped groups } else if (is.data.frame(groups)) { # resolved, extract from the names of the data frame head(names(groups), -1L) } else if (is.list(groups)) { # Need this for compatibility with existing packages that might # use the old list of symbols format map_chr(groups, as_string) } } #' @export as.data.frame.grouped_df <- function(x, row.names = NULL, optional = FALSE, ...) { x <- ungroup(x) class(x) <- "data.frame" x } #' @export as_tibble.grouped_df <- function(x, ...) { x <- ungroup(x) class(x) <- c("tbl_df", "tbl", "data.frame") x } #' @export ungroup.grouped_df <- function(x, ...) { ungroup_grouped_df(x) } #' @importFrom tibble is_tibble #' @export `[.grouped_df` <- function(x, i, j, drop = FALSE) { y <- NextMethod() if (isTRUE(drop) && !is_tibble(y)) { return(y) } group_names <- group_vars(x) if (!all(group_names %in% names(y))) { tbl_df(y) } else { grouped_df(y, group_names, group_by_drop_default(x)) } } #' @method rbind grouped_df #' @export rbind.grouped_df <- function(...) { bind_rows(...) } #' @method cbind grouped_df #' @export cbind.grouped_df <- function(...) { bind_cols(...) } #' Select grouping variables #' #' This selection helpers matches grouping variables. It can be used #' in [select()] or [vars()][scoped] selections. #' #' @inheritParams tidyselect::select_helpers #' @seealso [groups()] and [group_vars()] for retrieving the grouping #' variables outside selection contexts. #' #' @examples #' gdf <- iris %>% group_by(Species) #' #' # Select the grouping variables: #' gdf %>% select(group_cols()) #' #' # Remove the grouping variables from mutate selections: #' gdf %>% mutate_at(vars(-group_cols()), `/`, 100) #' @export group_cols <- function(vars = peek_vars()) { if (is_sel_vars(vars)) { matches <- match(vars %@% groups, vars) if (anyNA(matches)) { abort("Can't find the grouping variables") } matches } else { int() } } # One-table verbs -------------------------------------------------------------- # see arrange.r for arrange.grouped_df .select_grouped_df <- function(.data, ..., notify = TRUE) { # Pass via splicing to avoid matching vars_select() arguments vars <- tidyselect::vars_select(tbl_vars(.data), !!!enquos(...)) vars <- ensure_group_vars(vars, .data, notify = notify) select_impl(.data, vars) } #' @export select.grouped_df <- function(.data, ...) { .select_grouped_df(.data, !!!enquos(...), notify = TRUE) } #' @export select_.grouped_df <- function(.data, ..., .dots = list()) { dots <- compat_lazy_dots(.dots, caller_env(), ...) select.grouped_df(.data, !!!dots) } ensure_group_vars <- function(vars, data, notify = TRUE) { group_names <- group_vars(data) missing <- setdiff(group_names, vars) if (length(missing) > 0) { if (notify) { inform(glue( "Adding missing grouping variables: ", paste0("`", missing, "`", collapse = ", ") )) } vars <- c(set_names(missing, missing), vars) } vars } #' @export rename.grouped_df <- function(.data, ...) { vars <- tidyselect::vars_rename(names(.data), ...) select_impl(.data, vars) } #' @export rename_.grouped_df <- function(.data, ..., .dots = list()) { dots <- compat_lazy_dots(.dots, caller_env(), ...) rename(.data, !!!dots) } # Do --------------------------------------------------------------------------- #' @export do.grouped_df <- function(.data, ...) { index <- group_rows(.data) labels <- select(group_data(.data), -last_col()) attr(labels, ".drop") <- NULL # Create ungroup version of data frame suitable for subsetting group_data <- ungroup(.data) args <- enquos(...) named <- named_args(args) mask <- new_data_mask(new_environment()) n <- length(index) m <- length(args) # Special case for zero-group/zero-row input if (n == 0) { if (named) { out <- rep_len(list(list()), length(args)) out <- set_names(out, names(args)) out <- label_output_list(labels, out, groups(.data)) } else { env_bind_do_pronouns(mask, group_data) out <- eval_tidy(args[[1]], mask) out <- out[0, , drop = FALSE] out <- label_output_dataframe(labels, list(list(out)), groups(.data), group_by_drop_default(.data)) } return(out) } # Add pronouns with active bindings that resolve to the current # subset. `_i` is found in environment of this function because of # usual scoping rules. group_slice <- function(value) { if (missing(value)) { group_data[index[[`_i`]], , drop = FALSE] } else { group_data[index[[`_i`]], ] <<- value } } env_bind_do_pronouns(mask, group_slice) out <- replicate(m, vector("list", n), simplify = FALSE) names(out) <- names(args) p <- progress_estimated(n * m, min_time = 2) for (`_i` in seq_len(n)) { for (j in seq_len(m)) { out[[j]][`_i`] <- list(eval_tidy(args[[j]], mask)) p$tick()$print() } } if (!named) { label_output_dataframe(labels, out, groups(.data), group_by_drop_default(.data)) } else { label_output_list(labels, out, groups(.data)) } } #' @export do_.grouped_df <- function(.data, ..., env = caller_env(), .dots = list()) { dots <- compat_lazy_dots(.dots, env, ...) do(.data, !!!dots) } # Set operations --------------------------------------------------------------- #' @export distinct.grouped_df <- function(.data, ..., .keep_all = FALSE) { dist <- distinct_prepare( .data, vars = enquos(...), group_vars = group_vars(.data), .keep_all = .keep_all ) vars <- match_vars(dist$vars, dist$data) keep <- match_vars(dist$keep, dist$data) out <- distinct_impl(dist$data, vars, keep, environment()) grouped_df(out, groups(.data), group_by_drop_default(.data)) } #' @export distinct_.grouped_df <- function(.data, ..., .dots = list(), .keep_all = FALSE) { dots <- compat_lazy_dots(.dots, caller_env(), ...) distinct(.data, !!!dots, .keep_all = .keep_all) } dplyr/R/case_when.R0000644000176200001440000001613113614573561013701 0ustar liggesusers#' A general vectorised if #' #' This function allows you to vectorise multiple [if_else()] #' statements. It is an R equivalent of the SQL `CASE WHEN` statement. #' If no cases match, `NA` is returned. #' #' @param ... A sequence of two-sided formulas. The left hand side (LHS) #' determines which values match this case. The right hand side (RHS) #' provides the replacement value. #' #' The LHS must evaluate to a logical vector. The RHS does not need to be #' logical, but all RHSs must evaluate to the same type of vector. #' #' Both LHS and RHS may have the same length of either 1 or `n`. The #' value of `n` must be consistent across all cases. The case of #' `n == 0` is treated as a variant of `n != 1`. #' #' `NULL` inputs are ignored. #' #' These dots support [tidy dots][rlang::list2] features. In #' particular, if your patterns are stored in a list, you can #' splice that in with `!!!`. #' @export #' @return A vector of length 1 or `n`, matching the length of the logical #' input or output vectors, with the type (and attributes) of the first #' RHS. Inconsistent lengths or types will generate an error. #' @examples #' x <- 1:50 #' case_when( #' x %% 35 == 0 ~ "fizz buzz", #' x %% 5 == 0 ~ "fizz", #' x %% 7 == 0 ~ "buzz", #' TRUE ~ as.character(x) #' ) #' #' # Like an if statement, the arguments are evaluated in order, so you must #' # proceed from the most specific to the most general. This won't work: #' case_when( #' TRUE ~ as.character(x), #' x %% 5 == 0 ~ "fizz", #' x %% 7 == 0 ~ "buzz", #' x %% 35 == 0 ~ "fizz buzz" #' ) #' #' # If none of the cases match, NA is used: #' case_when( #' x %% 5 == 0 ~ "fizz", #' x %% 7 == 0 ~ "buzz", #' x %% 35 == 0 ~ "fizz buzz" #' ) #' #' # Note that NA values in the vector x do not get special treatment. If you want #' # to explicitly handle NA values you can use the `is.na` function: #' x[2:4] <- NA_real_ #' case_when( #' x %% 35 == 0 ~ "fizz buzz", #' x %% 5 == 0 ~ "fizz", #' x %% 7 == 0 ~ "buzz", #' is.na(x) ~ "nope", #' TRUE ~ as.character(x) #' ) #' #' # All RHS values need to be of the same type. Inconsistent types will throw an error. #' # This applies also to NA values used in RHS: NA is logical, use #' # typed values like NA_real_, NA_complex, NA_character_, NA_integer_ as appropriate. #' case_when( #' x %% 35 == 0 ~ NA_character_, #' x %% 5 == 0 ~ "fizz", #' x %% 7 == 0 ~ "buzz", #' TRUE ~ as.character(x) #' ) #' case_when( #' x %% 35 == 0 ~ 35, #' x %% 5 == 0 ~ 5, #' x %% 7 == 0 ~ 7, #' TRUE ~ NA_real_ #' ) #' #' # case_when() evaluates all RHS expressions, and then constructs its #' # result by extracting the selected (via the LHS expressions) parts. #' # In particular NaN are produced in this case: #' y <- seq(-2, 2, by = .5) #' case_when( #' y >= 0 ~ sqrt(y), #' TRUE ~ y #' ) #' #' # This throws an error as NA is logical not numeric #' \dontrun{ #' case_when( #' x %% 35 == 0 ~ 35, #' x %% 5 == 0 ~ 5, #' x %% 7 == 0 ~ 7, #' TRUE ~ NA #' ) #' } #' #' # case_when is particularly useful inside mutate when you want to #' # create a new variable that relies on a complex combination of existing #' # variables #' starwars %>% #' select(name:mass, gender, species) %>% #' mutate( #' type = case_when( #' height > 200 | mass > 200 ~ "large", #' species == "Droid" ~ "robot", #' TRUE ~ "other" #' ) #' ) #' #' #' # `case_when()` is not a tidy eval function. If you'd like to reuse #' # the same patterns, extract the `case_when()` call in a normal #' # function: #' case_character_type <- function(height, mass, species) { #' case_when( #' height > 200 | mass > 200 ~ "large", #' species == "Droid" ~ "robot", #' TRUE ~ "other" #' ) #' } #' #' case_character_type(150, 250, "Droid") #' case_character_type(150, 150, "Droid") #' #' # Such functions can be used inside `mutate()` as well: #' starwars %>% #' mutate(type = case_character_type(height, mass, species)) %>% #' pull(type) #' #' # `case_when()` ignores `NULL` inputs. This is useful when you'd #' # like to use a pattern only under certain conditions. Here we'll #' # take advantage of the fact that `if` returns `NULL` when there is #' # no `else` clause: #' case_character_type <- function(height, mass, species, robots = TRUE) { #' case_when( #' height > 200 | mass > 200 ~ "large", #' if (robots) species == "Droid" ~ "robot", #' TRUE ~ "other" #' ) #' } #' #' starwars %>% #' mutate(type = case_character_type(height, mass, species, robots = FALSE)) %>% #' pull(type) case_when <- function(...) { fs <- compact_null(list2(...)) n <- length(fs) if (n == 0) { abort("No cases provided") } query <- vector("list", n) value <- vector("list", n) default_env <- caller_env() quos_pairs <- map2(fs, seq_along(fs), validate_formula, default_env, current_env()) for (i in seq_len(n)) { pair <- quos_pairs[[i]] query[[i]] <- eval_tidy(pair$lhs, env = default_env) value[[i]] <- eval_tidy(pair$rhs, env = default_env) if (!is.logical(query[[i]])) { abort_case_when_logical(pair$lhs, i, query[[i]]) } } m <- validate_case_when_length(query, value, fs) out <- value[[1]][rep(NA_integer_, m)] replaced <- rep(FALSE, m) for (i in seq_len(n)) { out <- replace_with(out, query[[i]] & !replaced, value[[i]], NULL) replaced <- replaced | (query[[i]] & !is.na(query[[i]])) } out } validate_formula <- function(x, i, default_env, dots_env) { # Formula might be quosured if (is_quosure(x)) { default_env <- quo_get_env(x) x <- quo_get_expr(x) } if (!is_formula(x)) { arg <- substitute(...(), dots_env)[[1]] abort_case_when_formula(arg, i, x) } if (is_null(f_lhs(x))) { abort("formulas must be two-sided") } # Formula might be unevaluated, e.g. if it's been quosured env <- f_env(x) %||% default_env list( lhs = new_quosure(f_lhs(x), env), rhs = new_quosure(f_rhs(x), env) ) } abort_case_when_formula <- function(arg, i, obj) { deparsed <- fmt_obj1(deparse_trunc(arg)) type <- friendly_type_of(obj) abort(glue("Case {i} ({deparsed}) must be a two-sided formula, not {type}")) } abort_case_when_logical <- function(lhs, i, query) { deparsed <- fmt_obj1(deparse_trunc(quo_squash(lhs))) type <- friendly_type_of(query) abort(glue("LHS of case {i} ({deparsed}) must be a logical vector, not {type}")) } validate_case_when_length <- function(query, value, fs) { lhs_lengths <- lengths(query) rhs_lengths <- lengths(value) all_lengths <- unique(c(lhs_lengths, rhs_lengths)) if (length(all_lengths) <= 1) { return(all_lengths[[1]]) } non_atomic_lengths <- all_lengths[all_lengths != 1] len <- non_atomic_lengths[[1]] if (length(non_atomic_lengths) == 1) { return(len) } inconsistent_lengths <- non_atomic_lengths[-1] lhs_problems <- lhs_lengths %in% inconsistent_lengths rhs_problems <- rhs_lengths %in% inconsistent_lengths problems <- lhs_problems | rhs_problems bad_calls( fs[problems], check_length_val(inconsistent_lengths, len, header = NULL, .abort = identity) ) } dplyr/R/pull.R0000644000176200001440000000235213614573562012722 0ustar liggesusers#' Pull out a single variable #' #' This works like `[[` for local data frames, and automatically collects #' before indexing for remote data tables. #' #' @param .data A table of data #' @inheritParams tidyselect::vars_pull #' @export #' @examples #' mtcars %>% pull(-1) #' mtcars %>% pull(1) #' mtcars %>% pull(cyl) #' #' # Also works for remote sources #' if (requireNamespace("dbplyr", quietly = TRUE)) { #' df <- dbplyr::memdb_frame(x = 1:10, y = 10:1, .name = "pull-ex") #' df %>% #' mutate(z = x * y) %>% #' pull() #' } #' pull <- function(.data, var = -1) { UseMethod("pull") } #' @export pull.data.frame <- function(.data, var = -1) { var <- tidyselect::vars_pull(names(.data), !!enquo(var)) .data[[var]] } # FIXME: remove this once dbplyr uses vars_pull() find_var <- function(expr, vars) { var_env <- set_names(as.list(seq_along(vars)), vars) var <- eval_tidy(expr, var_env) if (!is.numeric(var) || length(var) != 1) { bad_args("var", "must evaluate to a single number") } var <- as.integer(var) n <- length(vars) if (is.na(var) || abs(var) > n || var == 0L) { bad_args("var", "must be a value between {-n} and {n} (excluding zero), not {var}") } if (var < 0) { var <- var + n + 1 } vars[[var]] } dplyr/R/near.R0000644000176200001440000000066213451046652012667 0ustar liggesusers#' Compare two numeric vectors #' #' This is a safe way of comparing if two vectors of floating point numbers #' are (pairwise) equal. This is safer than using `==`, because it has #' a built in tolerance #' #' @param x,y Numeric vectors to compare #' @param tol Tolerance of comparison. #' @export #' @examples #' sqrt(2) ^ 2 == 2 #' near(sqrt(2) ^ 2, 2) near <- function(x, y, tol = .Machine$double.eps^0.5) { abs(x - y) < tol } dplyr/R/RcppExports.R0000644000176200001440000001657013614573575014252 0ustar liggesusers# Generated by using Rcpp::compileAttributes() -> do not edit by hand # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 loc <- function(data) { .Call(`_dplyr_loc`, data) } dfloc <- function(df) { .Call(`_dplyr_dfloc`, df) } plfloc <- function(data) { .Call(`_dplyr_plfloc`, data) } strings_addresses <- function(s) { .Call(`_dplyr_strings_addresses`, s) } #' Enable internal logging #' #' Log entries, depending on the log level, will be printed to the standard #' error stream. #' #' @param log_level A character value, one of "WARN", "INFO", "DEBUG", "VERB", #' or "NONE". #' #' @keywords internal init_logging <- function(log_level) { invisible(.Call(`_dplyr_init_logging`, log_level)) } is_maybe_shared <- function(env, name) { .Call(`_dplyr_is_maybe_shared`, env, name) } maybe_shared_columns <- function(df) { .Call(`_dplyr_maybe_shared_columns`, df) } arrange_impl <- function(df, quosures, frame) { .Call(`_dplyr_arrange_impl`, df, quosures, frame) } #' Do values in a numeric vector fall in specified range? #' #' This is a shortcut for `x >= left & x <= right`, implemented #' efficiently in C++ for local values, and translated to the #' appropriate SQL for remote tables. #' #' @param x A numeric vector of values #' @param left,right Boundary values #' @export #' @examples #' between(1:12, 7, 9) #' #' x <- rnorm(1e2) #' x[between(x, -1, 1)] between <- function(x, left, right) { .Call(`_dplyr_between`, x, left, right) } flatten_bindable <- function(x) { .Call(`_dplyr_flatten_bindable`, x) } bind_rows_ <- function(dots, id) { .Call(`_dplyr_bind_rows_`, dots, id) } cbind_all <- function(dots) { .Call(`_dplyr_cbind_all`, dots) } combine_all <- function(data) { .Call(`_dplyr_combine_all`, data) } distinct_impl <- function(df, vars, keep, frame) { .Call(`_dplyr_distinct_impl`, df, vars, keep, frame) } n_distinct_multi <- function(variables, na_rm = FALSE) { .Call(`_dplyr_n_distinct_multi`, variables, na_rm) } filter_impl <- function(df, quo) { .Call(`_dplyr_filter_impl`, df, quo) } slice_impl <- function(df, quosure) { .Call(`_dplyr_slice_impl`, df, quosure) } grouped_indices_grouped_df_impl <- function(gdf) { .Call(`_dplyr_grouped_indices_grouped_df_impl`, gdf) } group_size_grouped_cpp <- function(gdf) { .Call(`_dplyr_group_size_grouped_cpp`, gdf) } regroup <- function(grouping_data, frame) { .Call(`_dplyr_regroup`, grouping_data, frame) } grouped_df_impl <- function(data, symbols, drop) { .Call(`_dplyr_grouped_df_impl`, data, symbols, drop) } group_data_grouped_df <- function(data) { .Call(`_dplyr_group_data_grouped_df`, data) } ungroup_grouped_df <- function(df) { .Call(`_dplyr_ungroup_grouped_df`, df) } group_split_impl <- function(gdf, keep, frame) { .Call(`_dplyr_group_split_impl`, gdf, keep, frame) } hybrids <- function() { .Call(`_dplyr_hybrids`) } semi_join_impl <- function(x, y, by_x, by_y, na_match, frame) { .Call(`_dplyr_semi_join_impl`, x, y, by_x, by_y, na_match, frame) } anti_join_impl <- function(x, y, by_x, by_y, na_match, frame) { .Call(`_dplyr_anti_join_impl`, x, y, by_x, by_y, na_match, frame) } inner_join_impl <- function(x, y, by_x, by_y, aux_x, aux_y, na_match, frame) { .Call(`_dplyr_inner_join_impl`, x, y, by_x, by_y, aux_x, aux_y, na_match, frame) } nest_join_impl <- function(x, y, by_x, by_y, aux_y, yname, frame) { .Call(`_dplyr_nest_join_impl`, x, y, by_x, by_y, aux_y, yname, frame) } left_join_impl <- function(x, y, by_x, by_y, aux_x, aux_y, na_match, frame) { .Call(`_dplyr_left_join_impl`, x, y, by_x, by_y, aux_x, aux_y, na_match, frame) } right_join_impl <- function(x, y, by_x, by_y, aux_x, aux_y, na_match, frame) { .Call(`_dplyr_right_join_impl`, x, y, by_x, by_y, aux_x, aux_y, na_match, frame) } full_join_impl <- function(x, y, by_x, by_y, aux_x, aux_y, na_match, frame) { .Call(`_dplyr_full_join_impl`, x, y, by_x, by_y, aux_x, aux_y, na_match, frame) } mutate_impl <- function(df, dots, caller_env) { .Call(`_dplyr_mutate_impl`, df, dots, caller_env) } select_impl <- function(df, vars) { .Call(`_dplyr_select_impl`, df, vars) } compatible_data_frame_nonames <- function(x, y, convert) { .Call(`_dplyr_compatible_data_frame_nonames`, x, y, convert) } compatible_data_frame <- function(x, y, ignore_col_order = TRUE, convert = FALSE) { .Call(`_dplyr_compatible_data_frame`, x, y, ignore_col_order, convert) } equal_data_frame <- function(x, y, ignore_col_order = TRUE, ignore_row_order = TRUE, convert = FALSE) { .Call(`_dplyr_equal_data_frame`, x, y, ignore_col_order, ignore_row_order, convert) } union_data_frame <- function(x, y) { .Call(`_dplyr_union_data_frame`, x, y) } intersect_data_frame <- function(x, y) { .Call(`_dplyr_intersect_data_frame`, x, y) } setdiff_data_frame <- function(x, y) { .Call(`_dplyr_setdiff_data_frame`, x, y) } summarise_impl <- function(df, dots, frame, caller_env) { .Call(`_dplyr_summarise_impl`, df, dots, frame, caller_env) } hybrid_impl <- function(df, quosure, caller_env) { .Call(`_dplyr_hybrid_impl`, df, quosure, caller_env) } test_comparisons <- function() { .Call(`_dplyr_test_comparisons`) } test_matches <- function() { .Call(`_dplyr_test_matches`) } test_length_wrap <- function() { .Call(`_dplyr_test_length_wrap`) } materialize_binding <- function(idx, mask_proxy_xp) { .Call(`_dplyr_materialize_binding`, idx, mask_proxy_xp) } check_valid_names <- function(names, warn_only = FALSE) { invisible(.Call(`_dplyr_check_valid_names`, names, warn_only)) } assert_all_allow_list <- function(data) { invisible(.Call(`_dplyr_assert_all_allow_list`, data)) } is_data_pronoun <- function(expr) { .Call(`_dplyr_is_data_pronoun`, expr) } is_variable_reference <- function(expr) { .Call(`_dplyr_is_variable_reference`, expr) } quo_is_variable_reference <- function(quo) { .Call(`_dplyr_quo_is_variable_reference`, quo) } quo_is_data_pronoun <- function(quo) { .Call(`_dplyr_quo_is_data_pronoun`, quo) } #' Cumulativate versions of any, all, and mean #' #' dplyr provides `cumall()`, `cumany()`, and `cummean()` to complete R's set #' of cumulative functions. #' #' @section Cumulative logical functions: #' #' These are particularly useful in conjunction with `filter()`: #' #' * `cumall(x)`: all cases until the first `FALSE`. #' * `cumall(!x)`: all cases until the first `TRUE`. #' * `cumany(x)`: all cases after the first `TRUE`. #' * `cumany(!x)`: all cases after the first `FALSE`. #' #' @param x For `cumall()` and `cumany()`, a logical vector; for #' `cummean()` an integer or numeric vector. #' @return A vector the same length as `x`. #' @export #' @examples #' # `cummean()` returns a numeric/integer vector of the same length #' # as the input vector. #' x <- c(1, 3, 5, 2, 2) #' cummean(x) #' cumsum(x) / seq_along(x) #' #' # `cumall()` and `cumany()` return logicals #' cumall(x < 5) #' cumany(x == 3) #' #' # `cumall()` vs. `cumany()` #' df <- data.frame( #' date = as.Date("2020-01-01") + 0:6, #' balance = c(100, 50, 25, -25, -50, 30, 120) #' ) #' # all rows after first overdraft #' df %>% filter(cumany(balance < 0)) #' # all rows until first overdraft #' df %>% filter(cumall(!(balance < 0))) cumall <- function(x) { .Call(`_dplyr_cumall`, x) } #' @export #' @rdname cumall cumany <- function(x) { .Call(`_dplyr_cumany`, x) } #' @export #' @rdname cumall cummean <- function(x) { .Call(`_dplyr_cummean`, x) } dplyr/R/data-nasa.r0000644000176200001440000000205513614573561013636 0ustar liggesusers#' NASA spatio-temporal data #' #' This data comes from the ASA 2007 data expo, #' \url{http://stat-computing.org/dataexpo/2006/}. The data are geographic and #' atmospheric measures on a very coarse 24 by 24 grid covering Central #' America. The variables are: temperature (surface and air), ozone, #' air pressure, and cloud cover (low, mid, and high). All variables are #' monthly averages, with observations for Jan 1995 to Dec 2000. These data #' were obtained from the NASA Langley Research Center Atmospheric Sciences #' Data Center (with permission; see important copyright terms below). #' #' @section Dimensions: #' #' \itemize{ #' \item `lat`, `long`: latitude and longitude #' \item `year`, `month`: month and year #' } #' #' @section Measures: #' #' \itemize{ #' \item `cloudlow`, `cloudmed`, `cloudhigh`: cloud cover #' at three heights #' \item `ozone` #' \item `surftemp` and `temperature` #' \item `pressure` #' } #' @docType data #' @name nasa #' @usage nasa #' @format A [tbl_cube] with 41,472 observations. #' @examples #' nasa NULL dplyr/R/progress.R0000644000176200001440000000754513451046652013615 0ustar liggesusers#' Progress bar with estimated time. #' #' This reference class represents a text progress bar displayed estimated #' time remaining. When finished, it displays the total duration. The #' automatic progress bar can be disabled by setting option #' `dplyr.show_progress` to `FALSE`. #' #' @param n Total number of items #' @param min_time Progress bar will wait until at least `min_time` #' seconds have elapsed before displaying any results. #' @return A ref class with methods `tick()`, `print()`, #' `pause()`, and `stop()`. #' @keywords internal #' @export #' @examples #' p <- progress_estimated(3) #' p$tick() #' p$tick() #' p$tick() #' #' p <- progress_estimated(3) #' for (i in 1:3) p$pause(0.1)$tick()$print() #' #' p <- progress_estimated(3) #' p$tick()$print()$ #' pause(1)$stop() #' #' # If min_time is set, progress bar not shown until that many #' # seconds have elapsed #' p <- progress_estimated(3, min_time = 3) #' for (i in 1:3) p$pause(0.1)$tick()$print() #' #' \dontrun{ #' p <- progress_estimated(10, min_time = 3) #' for (i in 1:10) p$pause(0.5)$tick()$print() #' } progress_estimated <- function(n, min_time = 0) { Progress$new(n, min_time = min_time) } #' @importFrom R6 R6Class Progress <- R6::R6Class("Progress", public = list( n = NULL, i = 0, init_time = NULL, stopped = FALSE, stop_time = NULL, min_time = NULL, last_update = NULL, initialize = function(n, min_time = 0, ...) { self$n <- n self$min_time <- min_time self$begin() }, begin = function() { "Initialise timer. Call this before beginning timing." self$i <- 0 self$last_update <- self$init_time <- now() self$stopped <- FALSE self }, pause = function(x) { "Sleep for x seconds. Useful for testing." Sys.sleep(x) self }, width = function() { getOption("width") - nchar("|100% ~ 99.9 h remaining") - 2 }, tick = function() { "Process one element" if (self$stopped) return(self) if (self$i == self$n) abort("No more ticks") self$i <- self$i + 1 self }, stop = function() { if (self$stopped) return(self) self$stopped <- TRUE self$stop_time <- now() self }, print = function(...) { if (!isTRUE(getOption("dplyr.show_progress")) || # user sepecifies no progress !interactive() || # not an interactive session !is.null(getOption("knitr.in.progress"))) { # dplyr used within knitr document return(invisible(self)) } now_ <- now() if (now_ - self$init_time < self$min_time || now_ - self$last_update < 0.05) { return(invisible(self)) } self$last_update <- now_ if (self$stopped) { overall <- show_time(self$stop_time - self$init_time) if (self$i == self$n) { cat_line("Completed after ", overall) cat("\n") } else { cat_line("Killed after ", overall) cat("\n") } return(invisible(self)) } avg <- (now() - self$init_time) / self$i time_left <- (self$n - self$i) * avg nbars <- trunc(self$i / self$n * self$width()) cat_line( "|", str_rep("=", nbars), str_rep(" ", self$width() - nbars), "|", format(round(self$i / self$n * 100), width = 3), "% ", "~", show_time(time_left), " remaining" ) invisible(self) } ) ) cat_line <- function(...) { msg <- paste(..., sep = "", collapse = "") gap <- max(c(0, getOption("width") - nchar(msg, "width"))) cat("\r", msg, rep.int(" ", gap), sep = "") utils::flush.console() } str_rep <- function(x, i) { paste(rep.int(x, i), collapse = "") } show_time <- function(x) { if (x < 60) { paste(round(x), "s") } else if (x < 60 * 60) { paste(round(x / 60), "m") } else { paste(round(x / (60 * 60)), "h") } } now <- function() proc.time()[[3]] dplyr/R/id.r0000644000176200001440000000372113614573562012403 0ustar liggesusers#' Compute a unique numeric id for each unique row in a data frame. #' #' Properties: #' \itemize{ #' \item `order(id)` is equivalent to `do.call(order, df)` #' \item rows containing the same data have the same value #' \item if `drop = FALSE` then room for all possibilities #' } #' #' @param .variables list of variables #' @param drop drop unused factor levels? #' @return a numeric vector with attribute n, giving total number of #' possibilities #' @keywords internal #' @export id <- function(.variables, drop = FALSE) { warn("`id()` is deprecated") # Drop all zero length inputs lengths <- vapply(.variables, length, integer(1)) .variables <- .variables[lengths != 0] if (length(.variables) == 0) { n <- nrow(.variables) %||% 0L return(structure(seq_len(n), n = n)) } # Special case for single variable if (length(.variables) == 1) { return(id_var(.variables[[1]], drop = drop)) } # Calculate individual ids ids <- rev(lapply(.variables, id_var, drop = drop)) p <- length(ids) # Calculate dimensions ndistinct <- vapply(ids, attr, "n", FUN.VALUE = numeric(1), USE.NAMES = FALSE) n <- prod(ndistinct) if (n > 2^31) { # Too big for integers, have to use strings, which will be much slower :( char_id <- do.call("paste", c(ids, sep = "\r")) res <- match(char_id, unique(char_id)) } else { combs <- c(1, cumprod(ndistinct[-p])) mat <- do.call("cbind", ids) res <- c((mat - 1L) %*% combs + 1L) } attr(res, "n") <- n if (drop) { id_var(res, drop = TRUE) } else { structure(as.integer(res), n = attr(res, "n")) } } id_var <- function(x, drop = FALSE) { if (length(x) == 0) return(structure(integer(), n = 0L)) if (!is.null(attr(x, "n")) && !drop) return(x) if (is.factor(x) && !drop) { id <- as.integer(addNA(x, ifany = TRUE)) n <- length(levels(x)) } else { levels <- sort(unique(x), na.last = TRUE) id <- match(x, levels) n <- max(id) } structure(id, n = n) } dplyr/R/rank.R0000644000176200001440000000472213614573562012704 0ustar liggesusers#' Windowed rank functions. #' #' Six variations on ranking functions, mimicking the ranking functions #' described in SQL2003. They are currently implemented using the built in #' `rank` function, and are provided mainly as a convenience when #' converting between R and SQL. All ranking functions map smallest inputs #' to smallest outputs. Use [desc()] to reverse the direction. #' #' * `row_number()`: equivalent to `rank(ties.method = "first")` #' #' * `min_rank()`: equivalent to `rank(ties.method = "min")` #' #' * `dense_rank()`: like `min_rank()`, but with no gaps between #' ranks #' #' * `percent_rank()`: a number between 0 and 1 computed by #' rescaling `min_rank` to `[0, 1]` #' #' * `cume_dist()`: a cumulative distribution function. Proportion #' of all values less than or equal to the current rank. #' #' * `ntile()`: a rough rank, which breaks the input vector into #' `n` buckets. #' #' @name ranking #' @param x a vector of values to rank. Missing values are left as is. #' If you want to treat them as the smallest or largest values, replace #' with Inf or -Inf before ranking. #' @examples #' x <- c(5, 1, 3, 2, 2, NA) #' row_number(x) #' min_rank(x) #' dense_rank(x) #' percent_rank(x) #' cume_dist(x) #' #' ntile(x, 2) #' ntile(runif(100), 10) #' #' # row_number can be used with single table verbs without specifying x #' # (for data frames and databases that support windowing) #' mutate(mtcars, row_number() == 1L) #' mtcars %>% filter(between(row_number(), 1, 10)) NULL #' @export #' @rdname ranking row_number <- function(x) { if (missing(x)){ seq_len(from_context("..group_size")) } else { rank(x, ties.method = "first", na.last = "keep") } } # Definition from # http://blogs.msdn.com/b/craigfr/archive/2008/03/31/ranking-functions-rank-dense-rank-and-ntile.aspx #' @param n number of groups to split up into. #' @export #' @rdname ranking ntile <- function(x = row_number(), n) { len <- sum(!is.na(x)) if (len == 0L) { rep(NA_integer_, length(x)) } else { as.integer(floor(n * (row_number(x) - 1) / len + 1)) } } #' @export #' @rdname ranking min_rank <- function(x) rank(x, ties.method = "min", na.last = "keep") #' @export #' @rdname ranking dense_rank <- function(x) { match(x, sort(unique(x))) } #' @export #' @rdname ranking percent_rank <- function(x) { (min_rank(x) - 1) / (sum(!is.na(x)) - 1) } #' @export #' @rdname ranking cume_dist <- function(x) { rank(x, ties.method = "max", na.last = "keep") / sum(!is.na(x)) } dplyr/R/join-vars.R0000644000176200001440000000334613614573562013662 0ustar liggesusersjoin_vars <- function(x_names, y_names, by, suffix = list(x = ".x", y = ".y")) { # Record position of join keys idx <- get_join_var_idx(x_names, y_names, by) x_names_by <- x_names[idx$x$by] x_names_aux <- x_names[idx$x$aux] y_names_aux <- y_names[idx$y$aux] # Add suffix where needed x_new <- x_names x_new[idx$x$aux] <- add_suffixes(x_names_aux, c(x_names_by, y_names_aux), suffix$x) y_new <- add_suffixes(y_names_aux, x_names, suffix$y) x_x <- seq_along(x_names) x_y <- idx$y$by[match(x_names, by$x)] y_x <- rep_along(idx$y$aux, NA) y_y <- seq_along(idx$y$aux) # Return a list with 3 parallel vectors # At each position, values in the 3 vectors represent # alias - name of column in join result # x - position of column from left table or NA if only from right table # y - position of column from right table or NA if only from left table ret <- list(alias = c(x_new, y_new), x = c(x_x, y_x), y = c(x_y, y_y)) # In addition, the idx component contains indices of "by" and "aux" variables # for x and y, respectively (see get_join_var_idx()) ret$idx <- idx ret } get_join_var_idx <- function(x_names, y_names, by) { x_idx <- get_by_aux(x_names, by$x) y_idx <- get_by_aux(y_names, by$y) list(x = x_idx, y = y_idx) } get_by_aux <- function(names, by) { if (length(by) > 0) { by <- match(by, names) aux <- seq_along(names)[-by] } else { by <- integer() aux <- seq_along(names) } list(by = by, aux = aux) } add_suffixes <- function(x, y, suffix) { if (identical(suffix, "")) { return(x) } out <- rep_along(x, na_chr) for (i in seq_along(x)) { nm <- x[[i]] while (nm %in% y || nm %in% out) { nm <- paste0(nm, suffix) } out[[i]] <- nm } out } dplyr/R/ts.R0000644000176200001440000000021713451046652012364 0ustar liggesusers#' @export filter.ts <- function(.data, ...) { bad_args(".data", "must be a data source, not a ts object, do you want `stats::filter()`?") } dplyr/R/reexport-tidyselect.R0000644000176200001440000000646013614573562015771 0ustar liggesusers # Flag to disable hotpatching from old tidyselect versions peek_vars <- tidyselect::peek_vars # Alias required for help links in downstream packages #' @aliases select_helpers #' @importFrom tidyselect contains #' @export tidyselect::contains #' @importFrom tidyselect ends_with #' @export tidyselect::ends_with #' @importFrom tidyselect everything #' @export tidyselect::everything #' @importFrom tidyselect matches #' @export tidyselect::matches #' @importFrom tidyselect num_range #' @export tidyselect::num_range #' @importFrom tidyselect one_of #' @export tidyselect::one_of #' @importFrom tidyselect starts_with #' @export tidyselect::starts_with #' @importFrom tidyselect last_col #' @export tidyselect::last_col #' Select variables #' #' \Sexpr[results=rd, stage=render]{dplyr:::lifecycle("deprecated")} #' #' @description #' #' **Retired**: These functions now live in the tidyselect package as #' [tidyselect::vars_select()], [tidyselect::vars_rename()] and #' [tidyselect::vars_pull()]. These dplyr aliases are soft-deprecated #' and will be deprecated sometimes in the future. #' #' @param vars A character vector of existing column names. #' @param ... Expressions to compute. #' @param include,exclude Character vector of column names to always #' include/exclude. #' @param strict If `TRUE`, will throw an error if you attempt to #' rename a variable that doesn't exist. #' @param var A variable specified as in the same argument of #' [tidyselect::vars_pull()]. #' @export select_vars <- function(vars = chr(), ..., include = chr(), exclude = chr()) { signal_soft_deprecated(paste_line( "select_vars() is deprecated. ", "Please use tidyselect::vars_select() instead" )) tidyselect::vars_select(.vars = vars, ..., .include = include, .exclude = exclude) } #' @rdname select_vars #' @inheritParams tidyselect::vars_rename #' @export rename_vars <- function(vars = chr(), ..., strict = TRUE) { signal_soft_deprecated(paste_line( "rename_vars() is deprecated. ", "Please use tidyselect::vars_rename() instead" )) tidyselect::vars_rename(.vars = vars, ..., .strict = strict) } #' @rdname select_vars #' @inheritParams tidyselect::vars_pull #' @export select_var <- function(vars, var = -1) { signal_soft_deprecated(paste_line( "select_var() is deprecated. ", "Please use tidyselect::vars_pull() instead" )) tidyselect::vars_pull(vars, !!enquo(var)) } #' @rdname select_vars #' @export current_vars <- function(...) { signal_soft_deprecated(paste_line( "current_vars() is deprecated. ", "Please use tidyselect::peek_vars() instead" )) tidyselect::peek_vars(...) } #' @rdname se-deprecated #' @param include,exclude Character vector of column names to always #' include/exclude. #' @export select_vars_ <- function(vars, args, include = chr(), exclude = chr()) { signal_soft_deprecated(paste_line( "select_vars_() is deprecated. ", "Please use tidyselect::vars_select() instead" )) args <- compat_lazy_dots(args, caller_env()) select_vars(vars, !!!args, include = include, exclude = exclude) } #' @export #' @rdname se-deprecated rename_vars_ <- function(vars, args) { signal_soft_deprecated(paste_line( "rename_vars_() is deprecated. ", "Please use tidyselect::vars_rename() instead" )) args <- compat_lazy_dots(args, caller_env()) rename_vars(vars, !!!args) } dplyr/R/colwise-arrange.R0000644000176200001440000000331513614573561015027 0ustar liggesusers#' Arrange rows by a selection of variables #' #' These [scoped] variants of [arrange()] sort a data frame by a #' selection of variables. Like [arrange()], you can modify the #' variables before ordering with the `.funs` argument. #' #' @inheritParams scoped #' @inheritParams arrange #' #' @section Grouping variables: #' #' The grouping variables that are part of the selection participate #' in the sorting of the data frame. #' #' @export #' @examples #' df <- as_tibble(mtcars) #' df #' arrange_all(df) #' #' # You can supply a function that will be applied before taking the #' # ordering of the variables. The variables of the sorted tibble #' # keep their original values. #' arrange_all(df, desc) #' arrange_all(df, list(~desc(.))) arrange_all <- function(.tbl, .funs = list(), ..., .by_group = FALSE) { funs <- manip_all(.tbl, .funs, enquo(.funs), caller_env(), .include_group_vars = TRUE, ...) if (!length(funs)) { funs <- syms(tbl_vars(.tbl)) } arrange(.tbl, !!!funs, .by_group = .by_group) } #' @rdname arrange_all #' @export arrange_at <- function(.tbl, .vars, .funs = list(), ..., .by_group = FALSE) { funs <- manip_at(.tbl, .vars, .funs, enquo(.funs), caller_env(), .include_group_vars = TRUE, ...) if (!length(funs)) { funs <- tbl_at_syms(.tbl, .vars, .include_group_vars = TRUE) } arrange(.tbl, !!!funs, .by_group = .by_group) } #' @rdname arrange_all #' @export arrange_if <- function(.tbl, .predicate, .funs = list(), ..., .by_group = FALSE) { funs <- manip_if(.tbl, .predicate, .funs, enquo(.funs), caller_env(), .include_group_vars = TRUE, ...) if (!length(funs)) { funs <- tbl_if_syms(.tbl, .predicate, .include_group_vars = TRUE) } arrange(.tbl, !!!funs, .by_group = .by_group) } dplyr/R/funs.R0000644000176200001440000001317413614573561012724 0ustar liggesusers#' Create a list of functions calls. #' #' \Sexpr[results=rd, stage=render]{dplyr:::lifecycle("soft-deprecated")} #' #' @description #' #' `funs()` provides a flexible way to generate a named list of #' functions for input to other functions like [summarise_at()]. #' #' @param ... A list of functions specified by: #' #' - Their name, `"mean"` #' - The function itself, `mean` #' - A call to the function with `.` as a dummy argument, #' `mean(., na.rm = TRUE)` #' #' These arguments are automatically [quoted][rlang::quo]. They #' support [unquoting][rlang::quasiquotation] and splicing. See #' `vignette("programming")` for an introduction to these concepts. #' #' The following notations are **not** supported, see examples: #' #' - An anonymous function, `function(x) mean(x, na.rm = TRUE)` #' - An anonymous function in \pkg{purrr} notation, `~mean(., na.rm = TRUE)` #' #' @param .args,args A named list of additional arguments to be added to all #' function calls. As `funs()` is being deprecated, use other methods to #' supply arguments: `...` argument in [scoped verbs][summarise_at()] or make #' own functions with [purrr::partial()]. #' @export #' @examples #' funs(mean, "mean", mean(., na.rm = TRUE)) #' #' # Override default names #' funs(m1 = mean, m2 = "mean", m3 = mean(., na.rm = TRUE)) #' #' # If you have function names in a vector, use funs_ #' fs <- c("min", "max") #' funs_(fs) #' #' # Not supported #' \dontrun{ #' funs(function(x) mean(x, na.rm = TRUE)) #' funs(~mean(x, na.rm = TRUE))} funs <- function(..., .args = list()) { signal_soft_deprecated(paste_line( "funs() is soft deprecated as of dplyr 0.8.0", "Please use a list of either functions or lambdas: ", "", " # Simple named list: ", " list(mean = mean, median = median)", "", " # Auto named with `tibble::lst()`: ", " tibble::lst(mean, median)", "", " # Using lambdas", " list(~ mean(., trim = .2), ~ median(., na.rm = TRUE))" )) dots <- enquos(...) default_env <- caller_env() funs <- map(dots, function(quo) as_fun(quo, default_env, .args)) new_funs(funs) } new_funs <- function(funs) { attr(funs, "have_name") <- any(names2(funs) != "") # Workaround until rlang:::label() is exported temp <- map(funs, function(fn) node_car(quo_get_expr(fn))) temp <- exprs_auto_name(temp) names(funs) <- names(temp) class(funs) <- "fun_list" funs } as_fun_list <- function(.funs, .env, ...) { args <- list2(...) if (is_fun_list(.funs)) { if (!is_empty(args)) { .funs[] <- map(.funs, call_modify, !!!args) } return(.funs) } if (is_list(.funs) && length(.funs) > 1) { .funs <- auto_name_formulas(.funs) } if (!is_character(.funs) && !is_list(.funs)) { .funs <- list(.funs) } if(is_character(.funs) && is_null(names(.funs)) && length(.funs) != 1L) { names(.funs) <- .funs } funs <- map(.funs, function(.x){ if (is_formula(.x)) { if (is_quosure(.x)) { signal_soft_deprecated(paste_line( "Using quosures is deprecated", "Please use a one-sided formula, a function, or a function name" ), env = .env) .x <- new_formula(NULL, quo_squash(.x), quo_get_env(.x)) } .x <- as_inlined_function(.x, env = .env) } else { if (is_character(.x)) { .x <- get(.x, .env, mode = "function") } else if (!is_function(.x)) { abort("expecting a one sided formula, a function, or a function name.") } if (length(args)) { .x <- new_quosure( call2(.x, quote(.), !!!args), env = .env ) } } .x }) attr(funs, "have_name") <- any(names2(funs) != "") funs } auto_name_formulas <- function(funs) { where <- !have_name(funs) & map_lgl(funs, function(x) is_bare_formula(x) && is_call(f_rhs(x))) names(funs)[where] <- map_chr(funs[where], function(x) as_label(f_rhs(x)[[1]])) funs } as_fun <- function(.x, .env, .args) { quo <- as_quosure(.x, .env) # For legacy reasons, we support strings. Those are enclosed in the # empty environment and need to be switched to the caller environment. quo <- quo_set_env(quo, fun_env(quo, .env)) expr <- quo_get_expr(quo) if (is_call(expr, c("function", "~"))) { top_level <- as_string(expr[[1]]) bad_args(quo_text(expr), "must be a function name (quoted or unquoted) or an unquoted call, not `{top_level}`") } if (is_call(expr) && !is_call(expr, c("::", ":::"))) { expr <- call_modify(expr, !!!.args) } else { expr <- call2(expr, quote(.), !!!.args) } set_expr(quo, expr) } quo_as_function <- function(quo) { new_function(exprs(. = ), quo_get_expr(quo), quo_get_env(quo)) } fun_env <- function(quo, default_env) { env <- quo_get_env(quo) if (is_null(env) || identical(env, empty_env())) { default_env } else { env } } is_fun_list <- function(x) { inherits(x, "fun_list") } #' @export `[.fun_list` <- function(x, i) { structure(NextMethod(), class = "fun_list", has_names = attr(x, "has_names") ) } #' @export print.fun_list <- function(x, ..., width = getOption("width")) { cat("\n") names <- format(names(x)) code <- map_chr(x, function(x) deparse_trunc(quo_get_expr(x), width - 2 - nchar(names[1]))) cat(paste0("$ ", names, ": ", code, collapse = "\n")) cat("\n") invisible(x) } #' @export #' @rdname se-deprecated #' @inheritParams funs #' @param env The environment in which functions should be evaluated. funs_ <- function(dots, args = list(), env = base_env()) { signal_soft_deprecated(paste_line( "funs_() is deprecated. ", "Please use list() instead" )) dots <- compat_lazy_dots(dots, caller_env()) funs(!!!dots, .args = args) } dplyr/R/utils-format.r0000644000176200001440000000317113614573562014434 0ustar liggesusers#' Describing dimensions #' #' Prints the dimensions of an array-like object in a user-friendly manner, #' substituting `NA` with ?? (for SQL queries). #' #' @param x Object to show dimensions for. #' @export #' @keywords internal #' @examples #' dim_desc(mtcars) dim_desc <- function(x) { d <- dim(x) d2 <- big_mark(d) d2[is.na(d)] <- "??" fmt_dims(d2) } wrap <- function(..., indent = 0) { x <- paste0(..., collapse = "") wrapped <- strwrap( x, indent = indent, exdent = indent + 2, width = getOption("width") ) paste0(wrapped, collapse = "\n") } ruler <- function(width = getOption("width")) { x <- seq_len(width) y <- case_when( x %% 10 == 0 ~ as.character((x %/% 10) %% 10), x %% 5 == 0 ~ "+", TRUE ~ "-" ) cat(y, "\n", sep = "") cat(x %% 10, "\n", sep = "") } rule <- function(pad = "-", gap = 2L) { paste0(rep(pad, getOption("width") - gap), collapse = "") } named_rule <- function(..., pad = "-") { if (nargs() == 0) { title <- "" } else { title <- paste0(...) } paste0(title, " ", rule(pad = pad, gap = nchar(title) - 1)) } #' @export print.BoolResult <- function(x, ...) { cat(x) if (!x) cat(": ", attr(x, "comment"), sep = "") cat("\n") } # function for the thousand separator, # returns "," unless it's used for the decimal point, in which case returns "." big_mark <- function(x, ...) { mark <- if (identical(getOption("OutDec"), ",")) "." else "," formatC(x, big.mark = mark, ...) } paste_line <- function(..., .trailing = FALSE) { lines <- paste(chr(...), collapse = "\n") if (.trailing) { lines <- paste0(lines, "\n") } lines } dplyr/R/group-by.r0000644000176200001440000001440013614573561013546 0ustar liggesusers#' Group by one or more variables #' #' @description #' Most data operations are done on groups defined by variables. #' `group_by()` takes an existing tbl and converts it into a grouped tbl #' where operations are performed "by group". `ungroup()` removes grouping. #' #' @section Tbl types: #' #' `group_by()` is an S3 generic with methods for the three built-in #' tbls. See the help for the corresponding classes and their manip #' methods for more details: #' #' \itemize{ #' \item data.frame: [grouped_df] #' \item data.table: [dtplyr::grouped_dt] #' \item SQLite: [src_sqlite()] #' \item PostgreSQL: [src_postgres()] #' \item MySQL: [src_mysql()] #' } #' #' @section Scoped grouping: #' #' The three [scoped] variants ([group_by_all()], [group_by_if()] and #' [group_by_at()]) make it easy to group a dataset by a selection of #' variables. #' #' @family grouping functions #' @param .data a tbl #' @param ... Variables to group by. All tbls accept variable names. #' Some tbls will accept functions of variables. Duplicated groups #' will be silently dropped. #' @param add When `add = FALSE`, the default, `group_by()` will #' override existing groups. To add to the existing groups, use #' `add = TRUE`. #' @param .drop When `.drop = TRUE`, empty groups are dropped. See [group_by_drop_default()] for #' what the default value is for this argument. #' @inheritParams filter #' #' @return A [grouped data frame][grouped_df()], unless the combination of `...` and `add` #' yields a non empty set of grouping columns, a regular (ungrouped) data frame #' otherwise. #' #' @export #' @examples #' by_cyl <- mtcars %>% group_by(cyl) #' #' # grouping doesn't change how the data looks (apart from listing #' # how it's grouped): #' by_cyl #' #' # It changes how it acts with the other dplyr verbs: #' by_cyl %>% summarise( #' disp = mean(disp), #' hp = mean(hp) #' ) #' by_cyl %>% filter(disp == max(disp)) #' #' # Each call to summarise() removes a layer of grouping #' by_vs_am <- mtcars %>% group_by(vs, am) #' by_vs <- by_vs_am %>% summarise(n = n()) #' by_vs #' by_vs %>% summarise(n = sum(n)) #' #' # To removing grouping, use ungroup #' by_vs %>% #' ungroup() %>% #' summarise(n = sum(n)) #' #' # You can group by expressions: this is just short-hand for #' # a mutate/rename followed by a simple group_by #' mtcars %>% group_by(vsam = vs + am) #' #' # By default, group_by overrides existing grouping #' by_cyl %>% #' group_by(vs, am) %>% #' group_vars() #' #' # Use add = TRUE to instead append #' by_cyl %>% #' group_by(vs, am, add = TRUE) %>% #' group_vars() #' #' # when factors are involved, groups can be empty #' tbl <- tibble( #' x = 1:10, #' y = factor(rep(c("a", "c"), each = 5), levels = c("a", "b", "c")) #' ) #' tbl %>% #' group_by(y) %>% #' group_rows() #' group_by <- function(.data, ..., add = FALSE, .drop = group_by_drop_default(.data)) { UseMethod("group_by") } #' @export group_by.default <- function(.data, ..., add = FALSE, .drop = group_by_drop_default(.data)) { group_by_(.data, .dots = compat_as_lazy_dots(...), add = add) } #' @export #' @rdname se-deprecated #' @inheritParams group_by group_by_ <- function(.data, ..., .dots = list(), add = FALSE) { signal_soft_deprecated(paste_line( "group_by_() is deprecated. ", "Please use group_by() instead", "", "The 'programming' vignette or the tidyeval book can help you", "to program with group_by() : https://tidyeval.tidyverse.org" )) UseMethod("group_by_") } #' @rdname group_by #' @export #' @param x A [tbl()] ungroup <- function(x, ...) { UseMethod("ungroup") } #' Prepare for grouping. #' #' `*_prepare()` performs standard manipulation that is needed prior #' to actual data processing. They are only be needed by packages #' that implement dplyr backends. #' #' @return A list #' \item{data}{Modified tbl} #' \item{groups}{Modified groups} #' @export #' @keywords internal group_by_prepare <- function(.data, ..., .dots = list(), add = FALSE) { new_groups <- c(enquos(...), compat_lazy_dots(.dots, caller_env())) new_groups <- new_groups[!map_lgl(new_groups, quo_is_missing)] # If any calls, use mutate to add new columns, then group by those .data <- add_computed_columns(.data, new_groups) # Once we've done the mutate, we need to name all objects new_groups <- exprs_auto_name(new_groups) group_names <- names(new_groups) if (add) { group_names <- c(group_vars(.data), group_names) } group_names <- unique(group_names) list( data = .data, groups = syms(group_names), group_names = group_names ) } add_computed_columns <- function(.data, vars) { is_symbol <- map_lgl(vars, quo_is_variable_reference) named <- have_name(vars) needs_mutate <- named | !is_symbol # Shortcut necessary, otherwise all columns are analyzed in mutate(), # this can change behavior mutate_vars <- vars[needs_mutate] if (length(mutate_vars) == 0L) return(.data) mutate(.data, !!!mutate_vars) } #' Return grouping variables #' #' `group_vars()` returns a character vector; `groups()` returns a list of #' symbols. #' #' @family grouping functions #' @param x A [tbl()] #' #' @seealso [group_cols()] for matching grouping variables in #' [selection contexts][select]. #' @export #' @examples #' df <- tibble(x = 1, y = 2) %>% group_by(x, y) #' group_vars(df) #' groups(df) groups <- function(x) { UseMethod("groups") } #' @export groups.default <- function(x) NULL #' @rdname groups #' @export group_vars <- function(x) { UseMethod("group_vars") } #' @export group_vars.default <- function(x) { deparse_names(groups(x)) } #' Default value for .drop argument of group_by #' #' @param .tbl A data frame #' #' @return `TRUE` unless `.tbl` is a grouped data frame that was previously #' obtained by `group_by(.drop = FALSE)` #' #' @examples #' group_by_drop_default(iris) #' #' iris %>% #' group_by(Species) %>% #' group_by_drop_default() #' #' iris %>% #' group_by(Species, .drop = FALSE) %>% #' group_by_drop_default() #' #' @export group_by_drop_default <- function(.tbl) { UseMethod("group_by_drop_default") } #' @export group_by_drop_default.default <- function(.tbl) { TRUE } #' @export group_by_drop_default.grouped_df <- function(.tbl) { tryCatch({ !identical(attr(group_data(.tbl), ".drop"), FALSE) }, error = function(e){ TRUE }) } dplyr/R/compat-lazyeval.R0000644000176200001440000000425113473155657015062 0ustar liggesusers# nocov start - compat-lazyeval (last updated: rlang 0.3.0) # This file serves as a reference for compatibility functions for lazyeval. # Please find the most recent version in rlang's repository. warn_underscored <- function() { return(NULL) warn(paste( "The underscored versions are deprecated in favour of", "tidy evaluation idioms. Please see the documentation", "for `quo()` in rlang" )) } warn_text_se <- function() { return(NULL) warn("Text parsing is deprecated, please supply an expression or formula") } compat_lazy <- function(lazy, env = caller_env(), warn = TRUE) { if (warn) warn_underscored() if (missing(lazy)) { return(quo()) } if (is_quosure(lazy)) { return(lazy) } if (is_formula(lazy)) { return(as_quosure(lazy, env)) } out <- switch(typeof(lazy), symbol = , language = new_quosure(lazy, env), character = { if (warn) warn_text_se() parse_quo(lazy[[1]], env) }, logical = , integer = , double = { if (length(lazy) > 1) { warn("Truncating vector to length 1") lazy <- lazy[[1]] } new_quosure(lazy, env) }, list = if (inherits(lazy, "lazy")) { lazy = new_quosure(lazy$expr, lazy$env) } ) if (is_null(out)) { abort(sprintf("Can't convert a %s to a quosure", typeof(lazy))) } else { out } } compat_lazy_dots <- function(dots, env, ..., .named = FALSE) { if (missing(dots)) { dots <- list() } if (inherits(dots, c("lazy", "formula"))) { dots <- list(dots) } else { dots <- unclass(dots) } dots <- c(dots, list(...)) warn <- TRUE for (i in seq_along(dots)) { dots[[i]] <- compat_lazy(dots[[i]], env, warn) warn <- FALSE } named <- have_name(dots) if (.named && any(!named)) { nms <- vapply(dots[!named], function(x) expr_text(get_expr(x)), character(1)) names(dots)[!named] <- nms } names(dots) <- names2(dots) dots } compat_as_lazy <- function(quo) { structure(class = "lazy", list( expr = get_expr(quo), env = get_env(quo) )) } compat_as_lazy_dots <- function(...) { structure(class = "lazy_dots", lapply(enquos(...), compat_as_lazy)) } # nocov end dplyr/R/distinct.R0000644000176200001440000001205613614573561013570 0ustar liggesusers#' Select distinct/unique rows #' #' Retain only unique/distinct rows from an input tbl. This is similar #' to [unique.data.frame()], but considerably faster. #' #' Comparing list columns is not fully supported. #' Elements in list columns are compared by reference. #' A warning will be given when trying to include list columns in the #' computation. #' This behavior is kept for compatibility reasons and may change in a future #' version. #' See examples. #' #' @param .data a tbl #' @param ... Optional variables to use when determining uniqueness. If there #' are multiple rows for a given combination of inputs, only the first #' row will be preserved. If omitted, will use all variables. #' @param .keep_all If `TRUE`, keep all variables in `.data`. #' If a combination of `...` is not distinct, this keeps the #' first row of values. #' @inheritParams filter #' @export #' @examples #' df <- tibble( #' x = sample(10, 100, rep = TRUE), #' y = sample(10, 100, rep = TRUE) #' ) #' nrow(df) #' nrow(distinct(df)) #' nrow(distinct(df, x, y)) #' #' distinct(df, x) #' distinct(df, y) #' #' # Can choose to keep all other variables as well #' distinct(df, x, .keep_all = TRUE) #' distinct(df, y, .keep_all = TRUE) #' #' # You can also use distinct on computed variables #' distinct(df, diff = abs(x - y)) #' #' # The same behaviour applies for grouped data frames #' # except that the grouping variables are always included #' df <- tibble( #' g = c(1, 1, 2, 2), #' x = c(1, 1, 2, 1) #' ) %>% group_by(g) #' df %>% distinct() #' df %>% distinct(x) #' #' # Values in list columns are compared by reference, this can lead to #' # surprising results #' tibble(a = as.list(c(1, 1, 2))) %>% glimpse() %>% distinct() #' tibble(a = as.list(1:2)[c(1, 1, 2)]) %>% glimpse() %>% distinct() distinct <- function(.data, ..., .keep_all = FALSE) { UseMethod("distinct") } #' @export distinct.default <- function(.data, ..., .keep_all = FALSE) { distinct_(.data, .dots = compat_as_lazy_dots(...), .keep_all = .keep_all) } #' @export #' @rdname se-deprecated #' @inheritParams distinct distinct_ <- function(.data, ..., .dots, .keep_all = FALSE) { signal_soft_deprecated(paste_line( "distinct_() is deprecated. ", "Please use distinct() instead", "", "The 'programming' vignette or the tidyeval book can help you", "to program with distinct() : https://tidyeval.tidyverse.org" )) UseMethod("distinct_") } #' Same basic philosophy as group_by_prepare(): lazy_dots comes in, list of data and #' vars (character vector) comes out. #' @rdname group_by_prepare #' @export distinct_prepare <- function(.data, vars, group_vars = character(), .keep_all = FALSE) { stopifnot(is_quosures(vars), is.character(group_vars)) # If no input, keep all variables if (length(vars) == 0) { vars <- list_cols_warning(.data, seq_along(.data)) return(list( data = .data, vars = vars, keep = seq_along(.data) )) } # If any calls, use mutate to add new columns, then distinct on those .data <- add_computed_columns(.data, vars) vars <- exprs_auto_name(vars) # Once we've done the mutate, we no longer need lazy objects, and # can instead just use their names missing_vars <- setdiff(names(vars), names(.data)) if (length(missing_vars) > 0) { missing_items <- fmt_items(fmt_obj(missing_vars)) vars <- vars[names(vars) %in% names(.data)] if (length(vars) > 0) { true_vars <- glue("The following variables will be used: {fmt_items(names(vars))}") } else { true_vars <- "The operation will return the input unchanged." } msg <- glue("Trying to compute distinct() for variables not found in the data: {missing_items} This is an error, but only a warning is raised for compatibility reasons. {true_vars} ") warn(msg) } new_vars <- unique(c(names(vars), group_vars)) # Keep the order of the variables out_vars <- intersect(new_vars, names(.data)) if (.keep_all) { keep <- seq_along(.data) } else { keep <- unique(out_vars) } out_vars <- list_cols_warning(.data, out_vars) list(data = .data, vars = out_vars, keep = keep) } #' Throw an error if there are tbl columns of type list #' #' @noRd list_cols_warning <- function(df, keep_cols) { df_keep <- df[keep_cols] lists <- map_lgl(df_keep, is.list) if (any(lists)) { items <- fmt_items(fmt_obj(names(df_keep)[lists])) warn( glue("distinct() does not fully support columns of type `list`. List elements are compared by reference, see ?distinct for details. This affects the following columns: {items}") ) } keep_cols } #' Efficiently count the number of unique values in a set of vector #' #' This is a faster and more concise equivalent of `length(unique(x))` #' #' @param \dots vectors of values #' @param na.rm if `TRUE` missing values don't count #' @examples #' x <- sample(1:10, 1e5, rep = TRUE) #' length(unique(x)) #' n_distinct(x) #' @export n_distinct <- function(..., na.rm = FALSE) { n_distinct_multi(list(...), na.rm) } dplyr/R/utils-bindings.R0000644000176200001440000000023013614573562014672 0ustar liggesusers.make_active_binding_fun <- function(index, mask_proxy_xp) { force(mask_proxy_xp) function() { materialize_binding(index, mask_proxy_xp) } } dplyr/R/compat-future-group_by.R0000644000176200001440000000104613472711534016357 0ustar liggesusers# workaround so that methods that do not have the .drop argument yet # don't create the auto mutate .drop column # # things like count() and group_by_all() # can call .group_by_static_drop() instead of group_by() # so that .drop is only part of the group_by() call if it is FALSE # # this is only meant to stay in dplyr until 0.8.0 to give # implementers of group_by() methods a chance to add .drop in their # arguments .group_by_static_drop <- function(..., .drop) { if(.drop) { group_by(...) } else { group_by(..., .drop = FALSE) } } dplyr/R/dataframe.R0000644000176200001440000001762413614573561013701 0ustar liggesusers# Grouping methods ------------------------------------------------------------ #' Convert row names to an explicit variable. #' #' Deprecated, use [tibble::rownames_to_column()] instead. #' #' @param df Input data frame with rownames. #' @param var Name of variable to use #' @keywords internal #' @export #' @examples #' mtcars %>% tbl_df() #' #' mtcars %>% add_rownames() add_rownames <- function(df, var = "rowname") { warning( "Deprecated, use tibble::rownames_to_column() instead.", call. = FALSE ) stopifnot(is.data.frame(df)) rn <- as_tibble(setNames(list(rownames(df)), var)) rownames(df) <- NULL bind_cols(rn, df) } # Grouping methods ------------------------------------------------------------ #' @export group_by.data.frame <- function(.data, ..., add = FALSE, .drop = group_by_drop_default(.data)) { groups <- group_by_prepare(.data, ..., add = add) grouped_df(groups$data, groups$group_names, .drop) } #' @export group_by_.data.frame <- function(.data, ..., .dots = list(), add = FALSE) { dots <- compat_lazy_dots(.dots, caller_env(), ...) group_by(.data, !!!dots, add = add) } #' @export ungroup.data.frame <- function(x, ...) x #' @export group_size.data.frame <- function(x) nrow(x) #' @export n_groups.data.frame <- function(x) 1L # Manipulation functions ------------------------------------------------------ # These could potentially be rewritten to avoid any copies, but since this # is just a convenience layer, I didn't bother. They should still be fast. #' @export filter.data.frame <- function(.data, ..., .preserve = FALSE) { as.data.frame(filter(tbl_df(.data), ..., .preserve = .preserve)) } #' @export filter_.data.frame <- function(.data, ..., .dots = list()) { dots <- compat_lazy_dots(.dots, caller_env(), ...) filter(.data, !!!dots) } #' @export slice.data.frame <- function(.data, ..., .preserve = FALSE) { as.data.frame(slice(tbl_df(.data), ..., .preserve = .preserve)) } #' @export slice_.data.frame <- function(.data, ..., .dots = list()) { dots <- compat_lazy_dots(.dots, caller_env(), ...) slice(.data, !!!dots) } #' @export summarise.data.frame <- function(.data, ...) { as.data.frame(summarise(tbl_df(.data), ...)) } #' @export summarise_.data.frame <- function(.data, ..., .dots = list()) { dots <- compat_lazy_dots(.dots, caller_env(), ...) summarise(.data, !!!dots) } #' @export mutate.data.frame <- function(.data, ...) { as.data.frame(mutate(tbl_df(.data), ...)) } #' @export mutate_.data.frame <- function(.data, ..., .dots = list()) { dots <- compat_lazy_dots(.dots, caller_env(), ...) mutate(.data, !!!dots) } #' @export arrange.data.frame <- function(.data, ..., .by_group = FALSE) { as.data.frame(arrange(tbl_df(.data), ..., .by_group = .by_group)) } #' @export arrange_.data.frame <- function(.data, ..., .dots = list(), .by_group = FALSE) { dots <- compat_lazy_dots(.dots, caller_env(), ...) arrange(.data, !!!dots, .by_group = .by_group) } #' @export select.data.frame <- function(.data, ...) { # Pass via splicing to avoid matching vars_select() arguments vars <- tidyselect::vars_select(tbl_vars(.data), !!!enquos(...)) select_impl(.data, vars) } #' @export select_.data.frame <- function(.data, ..., .dots = list()) { dots <- compat_lazy_dots(.dots, caller_env(), ...) select(.data, !!!dots) } #' @export rename.data.frame <- function(.data, ...) { vars <- tidyselect::vars_rename(names(.data), !!!enquos(...)) select_impl(.data, vars) } #' @export rename_.data.frame <- function(.data, ..., .dots = list()) { dots <- compat_lazy_dots(.dots, caller_env(), ...) rename(.data, !!!dots) } # Joins ------------------------------------------------------------------------ #' @export inner_join.data.frame <- function(x, y, by = NULL, copy = FALSE, ...) { as.data.frame(inner_join(tbl_df(x), y, by = by, copy = copy, ...)) } #' @export left_join.data.frame <- function(x, y, by = NULL, copy = FALSE, ...) { as.data.frame(left_join(tbl_df(x), y, by = by, copy = copy, ...)) } #' @export #' @rdname join.tbl_df nest_join.data.frame <- function(x, y, by = NULL, copy = FALSE, keep = FALSE, name = NULL, ... ) { as.data.frame(nest_join(tbl_df(x), y, by = by, copy = copy, ..., keep = keep, name = name)) } #' @export right_join.data.frame <- function(x, y, by = NULL, copy = FALSE, ...) { as.data.frame(right_join(tbl_df(x), y, by = by, copy = copy, ...)) } #' @export full_join.data.frame <- function(x, y, by = NULL, copy = FALSE, ...) { as.data.frame(full_join(tbl_df(x), y, by = by, copy = copy, ...)) } #' @export semi_join.data.frame <- function(x, y, by = NULL, copy = FALSE, ...) { as.data.frame(semi_join(tbl_df(x), y, by = by, copy = copy, ...)) } #' @export anti_join.data.frame <- function(x, y, by = NULL, copy = FALSE, ...) { as.data.frame(anti_join(tbl_df(x), y, by = by, copy = copy, ...)) } # Set operations --------------------------------------------------------------- #' @export intersect.data.frame <- function(x, y, ...) { out <- intersect_data_frame(x, y) reconstruct_set(out, x) } #' @export union.data.frame <- function(x, y, ...) { out <- union_data_frame(x, y) reconstruct_set(out, x) } #' @export union_all.data.frame <- function(x, y, ...) { out <- bind_rows(x, y) reconstruct_set(out, x) } #' @export setdiff.data.frame <- function(x, y, ...) { out <- setdiff_data_frame(x, y) reconstruct_set(out, x) } #' @export setequal.data.frame <- function(x, y, ...) { out <- equal_data_frame(x, y) as.logical(out) } reconstruct_set <- function(out, x) { if (is_grouped_df(x)) { out <- grouped_df_impl(out, group_vars(x), group_by_drop_default(x)) } out } #' @export distinct.data.frame <- function(.data, ..., .keep_all = FALSE) { dist <- distinct_prepare(.data, enquos(...), .keep_all = .keep_all) vars <- match_vars(dist$vars, dist$data) keep <- match_vars(dist$keep, dist$data) distinct_impl(dist$data, vars, keep, environment()) } #' @export distinct_.data.frame <- function(.data, ..., .dots = list(), .keep_all = FALSE) { dots <- compat_lazy_dots(.dots, caller_env(), ...) distinct(.data, !!!dots, .keep_all = .keep_all) } # Do --------------------------------------------------------------------------- #' @export do.data.frame <- function(.data, ...) { args <- enquos(...) named <- named_args(args) # Create custom data mask with `.` pronoun mask <- new_data_mask(new_environment()) env_bind_do_pronouns(mask, .data) if (!named) { out <- eval_tidy(args[[1]], mask) if (!inherits(out, "data.frame")) { bad("Result must be a data frame, not {fmt_classes(out)}") } } else { out <- map(args, function(arg) list(eval_tidy(arg, mask))) names(out) <- names(args) out <- tibble::as_tibble(out, validate = FALSE) } out } #' @export do_.data.frame <- function(.data, ..., .dots = list()) { dots <- compat_lazy_dots(.dots, caller_env(), ...) do(.data, !!!dots) } # Random samples --------------------------------------------------------------- #' @export sample_n.data.frame <- function(tbl, size, replace = FALSE, weight = NULL, .env = NULL, ...) { if (!is_null(.env)) { inform("`.env` is deprecated and no longer has any effect") } size <- enquo(size) weight <- enquo(weight) slice(tbl, sample.int(n(), check_size(!!size, n(), replace = replace), replace = replace, prob = !!weight)) } #' @export sample_frac.data.frame <- function(tbl, size = 1, replace = FALSE, weight = NULL, .env = NULL, ...) { if (!is_null(.env)) { inform("`.env` is deprecated and no longer has any effect") } size <- enquo(size) weight <- enquo(weight) slice(tbl, sample.int(n(), round(n() * check_frac(!!size, replace = replace)), replace = replace, prob = !!weight)) } # Misc ------------------------------------------------------------------------- #' @export collect.data.frame <- function(x, ...) x #' @export compute.data.frame <- function(x, ...) x #' @export collapse.data.frame <- function(x, ...) x dplyr/R/utils-tidy-eval.R0000644000176200001440000000455713614573562015013 0ustar liggesusers#' Tidy eval helpers #' #' @description #' #' * \code{\link[rlang]{sym}()} creates a symbol from a string and #' \code{\link[rlang]{syms}()} creates a list of symbols from a #' character vector. #' #' * \code{\link[rlang]{enquo}()} and \code{\link[rlang]{enquos}()} #' delay the execution of one or several function arguments. #' \code{enquo()} returns a single quoted expression, which is like #' a blueprint for the delayed computation. \code{enquos()} returns #' a list of such quoted expressions. #' #' * \code{\link[rlang]{expr}()} quotes a new expression _locally_. It #' is mostly useful to build new expressions around arguments #' captured with [enquo()] or [enquos()]: #' \code{expr(mean(!!enquo(arg), na.rm = TRUE))}. #' #' * \code{\link[rlang]{as_name}()} transforms a quoted variable name #' into a string. Supplying something else than a quoted variable #' name is an error. #' #' That's unlike \code{\link[rlang]{as_label}()} which also returns #' a single string but supports any kind of R object as input, #' including quoted function calls and vectors. Its purpose is to #' summarise that object into a single label. That label is often #' suitable as a default name. #' #' If you don't know what a quoted expression contains (for instance #' expressions captured with \code{enquo()} could be a variable #' name, a call to a function, or an unquoted constant), then use #' \code{as_label()}. If you know you have quoted a simple variable #' name, or would like to enforce this, use \code{as_name()}. #' #' To learn more about tidy eval and how to use these tools, visit #' \url{http://tidyeval.tidyverse.org} and the #' \href{https://adv-r.hadley.nz/metaprogramming.html}{Metaprogramming #' section} of \href{https://adv-r.hadley.nz}{Advanced R}. #' #' @md #' @name tidyeval #' @keywords internal #' @importFrom rlang expr enquo enquos sym syms .data := as_name as_label #' @aliases expr enquo enquos sym syms .data as_label #' @export expr enquo enquos sym syms .data as_label NULL #' Other tidy eval tools #' #' These tidy eval tools are no longer recommended for normal usage, #' but are still exported for compatibility. See [`?tidyeval`][tidyeval] #' for the recommended tools. #' #' @keywords internal #' @name tidyeval-compat #' @aliases quo quos quo_name ensym ensyms enexpr enexprs #' @export quo quos quo_name ensym ensyms enexpr enexprs NULL dplyr/R/data-bands.R0000644000176200001440000000135313451046652013736 0ustar liggesusers#' Band membership #' #' These data sets describe band members of the Beatles and Rolling Stones. They #' are toy data sets that can be displayed in their entirety on a slide (e.g. to #' demonstrate a join). #' #' `band_instruments` and `band_instruments2` contain the same data but use #' different column names for the first column of the data set. #' `band_instruments` uses `name`, which matches the name of the key column of #' `band_members`; `band_instruments2` uses `artist`, which does not. #' #' @format Each is a tibble with two variables and three observations #' @examples #' band_members #' band_instruments #' band_instruments2 "band_members" #' @rdname band_members "band_instruments" #' @rdname band_members "band_instruments2" dplyr/R/src-local.r0000644000176200001440000000377713614573562013701 0ustar liggesusers#' A local source. #' #' This is mainly useful for testing, since makes it possible to refer to #' local and remote tables using exactly the same syntax. #' #' Generally, `src_local()` should not be called directly, but instead #' one of the constructors should be used. #' #' @param tbl name of the function used to generate `tbl` objects #' @param pkg,env Either the name of a package or an environment object in #' which to look for objects. #' @keywords internal #' @export #' @examples #' if (require("Lahman")) { #' batting_df <- tbl(src_df("Lahman"), "Batting") #' } src_local <- function(tbl, pkg = NULL, env = NULL) { if (!xor(is.null(pkg), is.null(env))) { glubort(NULL, "Exactly one of `pkg` and `env` must be non-NULL, ", "not {(!is.null(pkg)) + (!is.null(env))}" ) } if (!is.null(pkg)) { env <- getNamespaceInfo(pkg, "lazydata") name <- paste0("") } else { stopifnot(is.environment(env)) name <- utils::capture.output(print(env)) } structure( list(tbl_f = match.fun(tbl), name = name, env = env), class = c("src_local", "src") ) } #' @rdname src_local #' @export src_df <- function(pkg = NULL, env = NULL) { src_local("tbl_df", pkg, env) } #' @export src_tbls.src_local <- function(x, ...) { objs <- ls(envir = x$env, all.names = TRUE) Filter(function(obj) is.data.frame(get(obj, envir = x$env)), objs) } #' @export tbl.src_local <- function(src, from, ...) { src$tbl_f(get(from, src$env)) } #' @export copy_to.src_local <- function(dest, df, name = deparse(substitute(df)), overwrite = FALSE, ...) { if (!overwrite && exists(name, envir = dest$env, inherits = FALSE)) { glubort(NULL, "object with `name` = {fmt_obj(name)} must not already exist, ", "unless `overwrite` = TRUE" ) } assign(name, envir = dest$env, df) tbl(dest, name) } #' @export format.src_local <- function(x, ...) { paste0( "src: ", x$name, "\n", wrap("tbls: ", paste0(sort(src_tbls(x)), collapse = ", ")) ) } dplyr/R/context.R0000644000176200001440000000027313614573561013431 0ustar liggesuserscontext_env <- new_environment() from_context <- function(what){ context_env[[what]] %||% abort(glue("{expr} should only be called in a data context", expr = deparse(sys.call(-1)))) } dplyr/R/funs-predicates.R0000644000176200001440000000320313614573561015035 0ustar liggesusers## Return the union or intersection of predicate expressions. ## ## `all_exprs()` and `any_exprs()` take predicate expressions and join them ## into a single predicate. They assume vectorised expressions by ## default and join them with `&` or `|`. Note that this will also ## work with scalar predicates, but if you want to be explicit you can ## set `.vectorised` to `FALSE` to join by `&&` or `||`. ## ## @param ... Predicate expressions. ## @param .vectorised If `TRUE`, predicates are joined with `&` or ## `|`. Otherwise, they are joined with `&&` or `||`. ## @return A [quosure][rlang::quo]. ## @export ## @examples ## all_exprs(cyl > 3, am == 1) ## any_exprs(cyl > 3, am == 1) ## any_exprs(cyl > 3, am == 1, .vectorised = FALSE) all_exprs <- function(..., .vectorised = TRUE) { op <- if (.vectorised) quote(`&`) else quote(`&&`) quo_reduce(..., .op = op) } ## @rdname all_exprs ## @export any_exprs <- function(..., .vectorised = TRUE) { op <- if (.vectorised) quote(`|`) else quote(`||`) quo_reduce(..., .op = op) } ## @param .op Can be a function or a quoted name of a function. If a ## quoted name, the default environment is the [base ## environment][rlang::base_env] unless you supply a ## [quosure][rlang::quo]. quo_reduce <- function(..., .op) { stopifnot(is_symbol(.op) || is_function(.op)) dots <- enquos(...) if (length(dots) == 0) { abort("At least one expression must be given") } else if (length(dots) == 1) { return(dots[[1]]) } op_quo <- as_quosure(.op, base_env()) op <- quo_get_expr(op_quo) expr <- reduce(dots, function(x, y) expr((!!op)((!!x), (!!y)))) new_quosure(expr, quo_get_env(op_quo)) } dplyr/R/colwise-distinct.R0000644000176200001440000000370713614573561015236 0ustar liggesusers#' Select distinct rows by a selection of variables #' #' These [scoped] variants of [distinct()] extract distinct rows by a #' selection of variables. Like `distinct()`, you can modify the #' variables before ordering with the `.funs` argument. #' #' @param .keep_all If `TRUE`, keep all variables in `.data`. #' If a combination of `...` is not distinct, this keeps the #' first row of values. #' @inheritParams scoped #' @export #' #' @section Grouping variables: #' #' The grouping variables that are part of the selection are taken #' into account to determine distinct rows. #' #' @examples #' df <- tibble(x = rep(2:5, each = 2) / 2, y = rep(2:3, each = 4) / 2) #' df #' distinct_all(df) #' distinct_at(df, vars(x,y)) #' distinct_if(df, is.numeric) #' #' # You can supply a function that will be applied before extracting the distinct values #' # The variables of the sorted tibble keep their original values. #' distinct_all(df, round) #' arrange_all(df, list(~round(.))) distinct_all <- function(.tbl, .funs = list(), ..., .keep_all = FALSE) { funs <- manip_all(.tbl, .funs, enquo(.funs), caller_env(), .include_group_vars = TRUE, ...) if (!length(funs)) { funs <- syms(tbl_vars(.tbl)) } distinct(.tbl, !!!funs, .keep_all = .keep_all) } #' @rdname distinct_all #' @export distinct_at <- function(.tbl, .vars, .funs = list(), ..., .keep_all = FALSE) { funs <- manip_at(.tbl, .vars, .funs, enquo(.funs), caller_env(), .include_group_vars = TRUE, ...) if (!length(funs)) { funs <- tbl_at_syms(.tbl, .vars, .include_group_vars = TRUE) } distinct(.tbl, !!!funs, .keep_all = .keep_all) } #' @rdname distinct_all #' @export distinct_if <- function(.tbl, .predicate, .funs = list(), ..., .keep_all = FALSE) { funs <- manip_if(.tbl, .predicate, .funs, enquo(.funs), caller_env(), .include_group_vars = TRUE, ...) if (!length(funs)) { funs <- tbl_if_syms(.tbl, .predicate, .include_group_vars = TRUE) } distinct(.tbl, !!!funs, .keep_all = .keep_all) } dplyr/R/failwith.r0000644000176200001440000000075413614573561013620 0ustar liggesusers#' Fail with specified value. #' #' Deprecated. Please use [purrr::possibly()] instead. #' #' @param default default value #' @param f function #' @param quiet all error messages be suppressed? #' @return a function #' @seealso [plyr::try_default()] #' @keywords internal #' @export failwith <- function(default = NULL, f, quiet = FALSE) { warn("Deprecated: please use `purrr::possibly()` instead") function(...) { out <- default try(out <- f(...), silent = quiet) out } } dplyr/R/copy-to.r0000644000176200001440000000314413614573561013377 0ustar liggesusers#' Copy a local data frame to a remote src #' #' This function uploads a local data frame into a remote data source, creating #' the table definition as needed. Wherever possible, the new object will be #' temporary, limited to the current connection to the source. #' #' @param dest remote data source #' @param df local data frame #' @param name name for new remote table. #' @param overwrite If `TRUE`, will overwrite an existing table with #' name `name`. If `FALSE`, will throw an error if `name` already #' exists. #' @param ... other parameters passed to methods. #' @seealso [collect()] for the opposite action; downloading remote data into #' a local dbl. #' @return a `tbl` object in the remote source #' @export #' @examples #' \dontrun{ #' iris2 <- dbplyr::src_memdb() %>% copy_to(iris, overwrite = TRUE) #' iris2 #' } copy_to <- function(dest, df, name = deparse(substitute(df)), overwrite = FALSE, ...) { UseMethod("copy_to") } #' Copy tables to same source, if necessary #' #' @param x,y `y` will be copied to `x`, if necessary. #' @param copy If `x` and `y` are not from the same data source, #' and `copy` is `TRUE`, then `y` will be copied into the #' same src as `x`. This allows you to join tables across srcs, but #' it is a potentially expensive operation so you must opt into it. #' @param ... Other arguments passed on to methods. #' @export auto_copy <- function(x, y, copy = FALSE, ...) { if (same_src(x, y)) return(y) if (!copy) { glubort(NULL, "`x` and `y` must share the same src, ", "set `copy` = TRUE (may be slow)" ) } UseMethod("auto_copy") } dplyr/R/lengths.R0000644000176200001440000000023313614573562013406 0ustar liggesuserslengths <- function(x) { map_int(x, length) } compat_lengths <- function() { if (getRversion() >= "3.2.0") { rm("lengths", inherits = TRUE) } } dplyr/R/match-vars.R0000644000176200001440000000014713614573562014013 0ustar liggesusersmatch_vars <- function(vars, data) { if (is.numeric(vars)) return(vars) match(vars, names(data)) } dplyr/R/colwise-select.R0000644000176200001440000000764013614573561014674 0ustar liggesusers#' Select and rename a selection of variables #' #' @description #' #' These [scoped] variants of [select()] and [rename()] operate on a #' selection of variables. The semantics of these verbs have subtle #' but important differences: #' #' * Selection drops variables that are not in the selection while #' renaming retains them. #' #' * The renaming function is optional for selection but not for #' renaming. #' #' The `_if` and `_at` variants always retain grouping variables for grouped #' data frames. #' #' @inheritParams scoped #' @param .funs A function `fun`, a purrr style lambda `~ fun(.)` or a list of either form. #' #' @section Grouping variables: #' #' Existing grouping variables are always kept in the data frame, even #' if not included in the selection. #' #' @examples #' #' # Supply a renaming function: #' select_all(mtcars, toupper) #' select_all(mtcars, "toupper") #' select_all(mtcars, list(~toupper(.))) #' #' # Selection drops unselected variables: #' is_whole <- function(x) all(floor(x) == x) #' select_if(mtcars, is_whole, toupper) #' select_at(mtcars, vars(-contains("ar"), starts_with("c")), toupper) #' #' # But renaming retains them: #' rename_if(mtcars, is_whole, toupper) #' rename_at(mtcars, vars(-(1:3)), toupper) #' rename_all(mtcars, toupper) #' #' # The renaming function is optional for selection: #' select_if(mtcars, is_whole) #' select_at(mtcars, vars(-everything())) #' select_all(mtcars) #' @export select_all <- function(.tbl, .funs = list(), ...) { funs <- as_fun_list(.funs, caller_env(), ...) vars <- tbl_vars(.tbl) syms <- vars_select_syms(vars, funs, .tbl) select(.tbl, !!!syms) } #' @rdname select_all #' @export rename_all <- function(.tbl, .funs = list(), ...) { funs <- as_fun_list(.funs, caller_env(), ...) vars <- tbl_vars(.tbl) syms <- vars_select_syms(vars, funs, .tbl, strict = TRUE) rename(.tbl, !!!syms) } #' @rdname select_all #' @export select_if <- function(.tbl, .predicate, .funs = list(), ...) { funs <- as_fun_list(.funs, caller_env(), ...) if (!is_logical(.predicate)) { .predicate <- as_fun_list(.predicate, caller_env()) } vars <- tbl_if_vars(.tbl, .predicate, caller_env(), .include_group_vars = TRUE) syms <- vars_select_syms(vars, funs, .tbl) select(.tbl, !!!syms) } #' @rdname select_all #' @export rename_if <- function(.tbl, .predicate, .funs = list(), ...) { funs <- as_fun_list(.funs, caller_env(), ...) if (!is_logical(.predicate)) { .predicate <- as_fun_list(.predicate, caller_env()) } vars <- tbl_if_vars(.tbl, .predicate, caller_env(), .include_group_vars = TRUE) syms <- vars_select_syms(vars, funs, .tbl, strict = TRUE) rename(.tbl, !!!syms) } #' @rdname select_all #' @export select_at <- function(.tbl, .vars, .funs = list(), ...) { vars <- tbl_at_vars(.tbl, .vars, .include_group_vars = TRUE) funs <- as_fun_list(.funs, caller_env(), ...) syms <- vars_select_syms(vars, funs, .tbl) select(.tbl, !!!syms) } #' @rdname select_all #' @export rename_at <- function(.tbl, .vars, .funs = list(), ...) { vars <- tbl_at_vars(.tbl, .vars, .include_group_vars = TRUE) funs <- as_fun_list(.funs, caller_env(), ...) syms <- vars_select_syms(vars, funs, .tbl, strict = TRUE) rename(.tbl, !!!syms) } vars_select_syms <- function(vars, funs, tbl, strict = FALSE) { if (length(funs) > 1) { bad_args(".funs", "must contain one renaming function, not {length(funs)}") } else if (length(funs) == 1) { fun <- funs[[1]] if (is_quosure(fun)) { fun <- quo_as_function(fun) } syms <- if (length(vars)) { set_names(syms(vars), fun(vars)) } else { set_names(syms(vars)) } } else if (!strict) { syms <- syms(vars) } else { bad_args(".funs", "must specify a renaming function") } group_vars <- group_vars(tbl) group_syms <- syms(group_vars) has_group_sym <- group_syms %in% syms new_group_syms <- set_names(group_syms[!has_group_sym], group_vars[!has_group_sym]) c(new_group_syms, syms) } dplyr/R/tbl.r0000644000176200001440000000434513614573562012573 0ustar liggesusers#' Create a table from a data source #' #' This is a generic method that dispatches based on the first argument. #' #' @param src A data source #' @param ... Other arguments passed on to the individual methods #' @export tbl <- function(src, ...) { UseMethod("tbl") } #' Create a "tbl" object #' #' `tbl()` is the standard constructor for tbls. `as.tbl()` coerces, #' and `is.tbl()` tests. #' #' @keywords internal #' @export #' @param subclass name of subclass. "tbl" is an abstract base class, so you #' must supply this value. `tbl_` is automatically prepended to the #' class name #' @param object to test/coerce. #' @param ... For `tbl()`, other fields used by class. For `as.tbl()`, #' other arguments passed to methods. #' @examples #' as.tbl(mtcars) make_tbl <- function(subclass, ...) { subclass <- paste0("tbl_", subclass) structure(list(...), class = c(subclass, "tbl")) } #' @rdname tbl #' @export is.tbl <- function(x) inherits(x, "tbl") #' @export #' @rdname tbl #' @param x an object to coerce to a `tbl` as.tbl <- function(x, ...) UseMethod("as.tbl") #' @export as.tbl.tbl <- function(x, ...) x tbl_vars_dispatch <- function(x) { UseMethod("tbl_vars") } new_sel_vars <- function(vars, group_vars) { structure( vars, groups = group_vars, class = c("dplyr_sel_vars", "character") ) } #' List variables provided by a tbl. #' #' `tbl_vars()` returns all variables while `tbl_nongroup_vars()` #' returns only non-grouping variables. The `groups` attribute #' of the object returned by `tbl_vars()` is a character vector of the #' grouping columns. #' #' @export #' @param x A tbl object #' @seealso [group_vars()] for a function that returns grouping #' variables. #' @keywords internal tbl_vars <- function(x) { return(new_sel_vars(tbl_vars_dispatch(x), group_vars(x))) # For roxygen and static analysis UseMethod("tbl_vars") } #' @rdname tbl_vars #' @export tbl_nongroup_vars <- function(x) { setdiff(tbl_vars(x), group_vars(x)) } is_sel_vars <- function(x) { inherits(x, "dplyr_sel_vars") } #' @export print.dplyr_sel_vars <- function(x, ...) { cat("\n") print(unstructure(x)) groups <- attr(x, "groups") if (length(groups)) { cat("Groups:\n") print(groups) } invisible(x) } dplyr/R/count-tally.R0000644000176200001440000001564513614573561014231 0ustar liggesusers#' Count/tally observations by group #' #' @description #' `tally()` is a convenient wrapper for summarise that will either call #' [n()] or \code{\link{sum}(n)} depending on whether you're tallying #' for the first time, or re-tallying. `count()` is similar but calls #' [group_by()] before and [ungroup()] after. If the data is already #' grouped, `count()` adds an additional group that is removed afterwards. #' #' `add_tally()` adds a column `n` to a table based on the number #' of items within each existing group, while `add_count()` is a shortcut that #' does the grouping as well. These functions are to [tally()] #' and [count()] as [mutate()] is to [summarise()]: #' they add an additional column rather than collapsing each group. #' #' @note #' The column name in the returned data is given by the `name` argument, #' set to `"n"` by default. #' #' If the data already has a column by that name, the output column #' will be prefixed by an extra `"n"` as many times as necessary. #' #' @param x a [tbl()] to tally/count. #' @param ... Variables to group by. #' @param wt (Optional) If omitted (and no variable named `n` exists in the #' data), will count the number of rows. #' If specified, will perform a "weighted" tally by summing the #' (non-missing) values of variable `wt`. A column named `n` (but not `nn` or #' `nnn`) will be used as weighting variable by default in `tally()`, but not #' in `count()`. This argument is automatically [quoted][rlang::quo] and later #' [evaluated][rlang::eval_tidy] in the context of the data #' frame. It supports [unquoting][rlang::quasiquotation]. See #' `vignette("programming")` for an introduction to these concepts. #' @param sort if `TRUE` will sort output in descending order of `n` #' @param name The output column name. If omitted, it will be `n`. #' @param .drop see [group_by()] #' @return A tbl, grouped the same way as `x`. #' @export #' @examples #' # tally() is short-hand for summarise() #' mtcars %>% tally() #' mtcars %>% group_by(cyl) %>% tally() #' # count() is a short-hand for group_by() + tally() #' mtcars %>% count(cyl) #' # Note that if the data is already grouped, count() adds #' # an additional group that is removed afterwards #' mtcars %>% group_by(gear) %>% count(carb) #' #' # add_tally() is short-hand for mutate() #' mtcars %>% add_tally() #' # add_count() is a short-hand for group_by() + add_tally() #' mtcars %>% add_count(cyl) #' #' # count() and tally() are designed so that you can call #' # them repeatedly, each time rolling up a level of detail #' species <- #' starwars %>% #' count(species, homeworld, sort = TRUE) #' species #' species %>% count(species, sort = TRUE) #' #' # Change the name of the newly created column: #' species <- #' starwars %>% #' count(species, homeworld, sort = TRUE, name = "n_species_by_homeworld") #' species #' species %>% #' count(species, sort = TRUE, name = "n_species") #' #' # add_count() is useful for groupwise filtering #' # e.g.: show details for species that have a single member #' starwars %>% #' add_count(species) %>% #' filter(n == 1) tally <- function(x, wt = NULL, sort = FALSE, name = "n") { wt <- enquo(wt) if (quo_is_missing(wt) && "n" %in% tbl_vars(x)) { inform("Using `n` as weighting variable") wt <- quo(n) } if (quo_is_missing(wt) || quo_is_null(wt)) { n <- quo(n()) } else { n <- quo(sum(!!wt, na.rm = TRUE)) } n_name <- n_name(group_vars(x), name) if (name != "n" && name %in% group_vars(x)) { abort(glue("Column `{name}` already exists in grouped variables")) } out <- summarise(x, !!n_name := !!n) if (sort) { arrange(out, desc(!!sym(n_name))) } else { out } } #' @rdname se-deprecated #' @inheritParams tally #' @export tally_ <- function(x, wt, sort = FALSE) { signal_soft_deprecated(paste_line( "tally_() is deprecated. ", "Please use tally() instead", "", "The 'programming' vignette or the tidyeval book can help you", "to program with tally() : https://tidyeval.tidyverse.org" )) wt <- compat_lazy(wt, caller_env()) tally(x, wt = !!wt, sort = sort) } n_name <- function(x, name = "n") { while (name %in% x) { name <- paste0("n", name) } name } #' @export #' @rdname tally count <- function(x, ..., wt = NULL, sort = FALSE, name = "n", .drop = group_by_drop_default(x)) { groups <- group_vars(x) if (dots_n(...)) { x <- .group_by_static_drop(x, ..., add = TRUE, .drop = .drop) } x <- tally(x, wt = !!enquo(wt), sort = sort, name = name) x <- .group_by_static_drop(x, !!!syms(groups), add = FALSE, .drop = .drop) x } #' @export #' @rdname se-deprecated count_ <- function(x, vars, wt = NULL, sort = FALSE, .drop = group_by_drop_default(x)) { signal_soft_deprecated(paste_line( "count_() is deprecated. ", "Please use count() instead", "", "The 'programming' vignette or the tidyeval book can help you", "to program with count() : https://tidyeval.tidyverse.org" )) vars <- compat_lazy_dots(vars, caller_env()) wt <- wt %||% quo(NULL) wt <- compat_lazy(wt, caller_env()) count(x, !!!vars, wt = !!wt, sort = sort, .drop = .drop) } #' @rdname tally #' @export add_tally <- function(x, wt, sort = FALSE, name = "n") { wt <- enquo(wt) if (quo_is_missing(wt) && "n" %in% tbl_vars(x)) { inform("Using `n` as weighting variable") wt <- quo(n) } if (quo_is_missing(wt) || quo_is_null(wt)) { n <- quo(n()) } else { n <- quo(sum(!!wt, na.rm = TRUE)) } n_name <- n_name(group_vars(x), name) if (name != "n" && name %in% group_vars(x)) { abort(glue("Column `{name}` already exists in grouped variables")) } out <- mutate(x, !!n_name := !!n) if (sort) { out <- arrange(out, desc(!!sym(n_name))) } grouped_df(out, group_vars(x), drop = group_by_drop_default(x)) } #' @rdname se-deprecated #' @export add_tally_ <- function(x, wt, sort = FALSE) { signal_soft_deprecated(paste_line( "add_tally_() is deprecated. ", "Please use add_tally() instead", "", "The 'programming' vignette or the tidyeval book can help you", "to program with add_tally() : https://tidyeval.tidyverse.org" )) wt <- compat_lazy(wt, caller_env()) add_tally(x, !!wt, sort = sort) } #' @rdname tally #' @export add_count <- function(x, ..., wt = NULL, sort = FALSE, name = "n") { g <- group_vars(x) grouped <- group_by(x, ..., add = TRUE) out <- add_tally(grouped, wt = !!enquo(wt), sort = sort, name = name) grouped_df(out, g, drop = group_by_drop_default(grouped)) } #' @rdname se-deprecated #' @export add_count_ <- function(x, vars, wt = NULL, sort = FALSE) { signal_soft_deprecated(paste_line( "add_count_() is deprecated. ", "Please use add_count() instead", "", "The 'programming' vignette or the tidyeval book can help you", "to program with add_count() : https://tidyeval.tidyverse.org" )) vars <- compat_lazy_dots(vars, caller_env()) wt <- wt %||% quo(NULL) wt <- compat_lazy(wt, caller_env()) add_count(x, !!!vars, wt = !!wt, sort = sort) } dplyr/R/src.r0000644000176200001440000000243113614573562012573 0ustar liggesusers#' Create a "src" object #' #' `src()` is the standard constructor for srcs and `is.src()` tests. #' #' @keywords internal #' @export #' @param subclass name of subclass. "src" is an abstract base class, so you #' must supply this value. `src_` is automatically prepended to the #' class name #' @param ... fields used by object. #' #' These dots are evaluated with [explicit splicing][rlang::dots_list]. #' @param x object to test for "src"-ness. src <- function(subclass, ...) { subclass <- paste0("src_", subclass) structure(dots_list(...), class = c(subclass, "src")) } #' @rdname src #' @export is.src <- function(x) inherits(x, "src") #' @export print.src <- function(x, ...) { cat(format(x, ...), "\n", sep = "") } #' List all tbls provided by a source. #' #' This is a generic method which individual src's will provide methods for. #' Most methods will not be documented because it's usually pretty obvious what #' possible results will be. #' #' @param x a data src. #' @export #' @keywords internal src_tbls <- function(x) { UseMethod("src_tbls") } #' Figure out if two sources are the same (or two tbl have the same source) #' #' @param x,y src or tbls to test #' @return a logical flag #' @export #' @keywords internal same_src <- function(x, y) { UseMethod("same_src") } dplyr/R/lead-lag.R0000644000176200001440000000416413614573562013417 0ustar liggesusers#' Lead and lag. #' #' Find the "next" or "previous" values in a vector. Useful for comparing values #' ahead of or behind the current values. #' #' @param x a vector of values #' @param n a positive integer of length 1, giving the number of positions to #' lead or lag by #' @param default value used for non-existent rows. Defaults to `NA`. #' @param order_by override the default ordering to use another vector #' @param ... Needed for compatibility with lag generic. #' @importFrom stats lag #' @examples #' lead(1:10, 1) #' lead(1:10, 2) #' #' lag(1:10, 1) #' lead(1:10, 1) #' #' x <- runif(5) #' cbind(ahead = lead(x), x, behind = lag(x)) #' #' # Use order_by if data not already ordered #' df <- data.frame(year = 2000:2005, value = (0:5) ^ 2) #' scrambled <- df[sample(nrow(df)), ] #' #' wrong <- mutate(scrambled, prev = lag(value)) #' arrange(wrong, year) #' #' right <- mutate(scrambled, prev = lag(value, order_by = year)) #' arrange(right, year) #' @name lead-lag NULL #' @export #' @rdname lead-lag lead <- function(x, n = 1L, default = NA, order_by = NULL, ...) { if (!is.null(order_by)) { return(with_order(order_by, lead, x, n = n, default = default)) } if (length(n) != 1 || !is.numeric(n) || n < 0) { bad_args("n", "must be a nonnegative integer scalar, ", "not {friendly_type_of(n)} of length {length(n)}" ) } if (n == 0) return(x) xlen <- length(x) n <- pmin(n, xlen) out <- c(x[-seq_len(n)], rep(default, n)) attributes(out) <- attributes(x) out } #' @export #' @rdname lead-lag lag <- function(x, n = 1L, default = NA, order_by = NULL, ...) { if (!is.null(order_by)) { return(with_order(order_by, lag, x, n = n, default = default)) } if (inherits(x, "ts")) { bad_args("x", "must be a vector, not a ts object, do you want `stats::lag()`?") } if (length(n) != 1 || !is.numeric(n) || n < 0) { bad_args("n", "must be a nonnegative integer scalar, ", "not {friendly_type_of(n)} of length {length(n)}" ) } if (n == 0) return(x) xlen <- length(x) n <- pmin(n, xlen) out <- c(rep(default, n), x[seq_len(xlen - n)]) attributes(out) <- attributes(x) out } dplyr/R/tbl-df.r0000644000176200001440000002242213614573562013156 0ustar liggesusers#' Create a data frame tbl. #' #' Deprecated: please use [tibble::as_tibble()] instead. #' #' @export #' @keywords internal #' @param data a data frame tbl_df <- function(data) { # Works in tibble < 1.5.0 too, because .name_repair will be # swallowed by the ellipsis as_tibble(data, .name_repair = "check_unique") } #' @export as.tbl.data.frame <- function(x, ...) { tbl_df(x) } #' @export tbl_vars.data.frame <- function(x) { names(x) } #' @export same_src.data.frame <- function(x, y) { is.data.frame(y) } #' @export auto_copy.tbl_df <- function(x, y, copy = FALSE, ...) { as.data.frame(y) } # Verbs ------------------------------------------------------------------------ #' @export arrange.tbl_df <- function(.data, ..., .by_group = FALSE) { dots <- enquos(...) arrange_impl(.data, dots, environment()) } #' @export arrange_.tbl_df <- function(.data, ..., .dots = list(), .by_group = FALSE) { dots <- compat_lazy_dots(.dots, caller_env(), ...) arrange_impl(.data, dots, environment()) } #' @export filter.tbl_df <- function(.data, ..., .preserve = FALSE) { dots <- enquos(...) if (any(have_name(dots))) { bad <- dots[have_name(dots)] bad_eq_ops(bad, "must not be named, do you need `==`?") } else if (is_empty(dots)) { return(.data) } quo <- all_exprs(!!!dots, .vectorised = TRUE) out <- filter_impl(.data, quo) if (!.preserve && is_grouped_df(.data)) { attr(out, "groups") <- regroup(attr(out, "groups"), environment()) } out } #' @export filter_.tbl_df <- function(.data, ..., .dots = list()) { dots <- compat_lazy_dots(.dots, caller_env(), ...) filter(.data, !!!dots) } #' @export slice.tbl_df <- function(.data, ..., .preserve = FALSE) { dots <- enquos(...) if (is_empty(dots)) { return(.data) } quo <- quo(c(!!!dots)) out <- slice_impl(.data, quo) if (!.preserve && is_grouped_df(.data)) { attr(out, "groups") <- regroup(attr(out, "groups"), environment()) } out } #' @export slice_.tbl_df <- function(.data, ..., .dots = list()) { dots <- compat_lazy_dots(.dots, caller_env(), ...) slice(.data, !!!dots) } #' @export mutate.tbl_df <- function(.data, ...) { dots <- enquos(..., .named = TRUE) mutate_impl(.data, dots, caller_env()) } #' @export mutate_.tbl_df <- function(.data, ..., .dots = list()) { dots <- compat_lazy_dots(.dots, caller_env(), ..., .named = TRUE) mutate_impl(.data, dots, caller_env()) } #' @export summarise.tbl_df <- function(.data, ...) { dots <- enquos(..., .named = TRUE) summarise_impl(.data, dots, environment(), caller_env()) } #' @export summarise_.tbl_df <- function(.data, ..., .dots = list()) { dots <- compat_lazy_dots(.dots, caller_env(), ..., .named = TRUE) summarise_impl(.data, dots, environment(), caller_env()) } # Joins ------------------------------------------------------------------------ #' Join data frame tbls #' #' See [join] for a description of the general purpose of the #' functions. #' #' @inheritParams inner_join #' @param ... included for compatibility with the generic; otherwise ignored. #' @param na_matches #' Use `"never"` to always treat two `NA` or `NaN` values as #' different, like joins for database sources, similarly to #' `merge(incomparables = FALSE)`. #' The default, `"na"`, always treats two `NA` or `NaN` values as equal, like [merge()]. #' Users and package authors can change the default behavior by calling #' `pkgconfig::set_config("dplyr::na_matches" = "never")`. #' @examples #' if (require("Lahman")) { #' batting_df <- tbl_df(Batting) #' person_df <- tbl_df(Master) #' #' uperson_df <- tbl_df(Master[!duplicated(Master$playerID), ]) #' #' # Inner join: match batting and person data #' inner_join(batting_df, person_df) #' inner_join(batting_df, uperson_df) #' #' # Left join: match, but preserve batting data #' left_join(batting_df, uperson_df) #' #' # Anti join: find batters without person data #' anti_join(batting_df, person_df) #' # or people who didn't bat #' anti_join(person_df, batting_df) #' } #' @name join.tbl_df NULL check_na_matches <- function(na_matches) { na_matches <- match.arg(na_matches, choices = c("na", "never")) accept_na_match <- (na_matches == "na") accept_na_match } #' @export #' @rdname join.tbl_df inner_join.tbl_df <- function(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ..., na_matches = pkgconfig::get_config("dplyr::na_matches")) { check_valid_names(tbl_vars(x)) check_valid_names(tbl_vars(y)) by <- common_by(by, x, y) suffix <- check_suffix(suffix) na_matches <- check_na_matches(na_matches) y <- auto_copy(x, y, copy = copy) vars <- join_vars(tbl_vars(x), tbl_vars(y), by, suffix) by_x <- vars$idx$x$by by_y <- vars$idx$y$by aux_x <- vars$idx$x$aux aux_y <- vars$idx$y$aux out <- inner_join_impl(x, y, by_x, by_y, aux_x, aux_y, na_matches, environment()) names(out) <- vars$alias reconstruct_join(out, x, vars) } #' @export #' @rdname join.tbl_df nest_join.tbl_df <- function(x, y, by = NULL, copy = FALSE, keep = FALSE, name = NULL, ...) { name_var <- name %||% expr_name(enexpr(y)) check_valid_names(tbl_vars(x)) check_valid_names(tbl_vars(y)) by <- common_by(by, x, y) y <- auto_copy(x, y, copy = copy) vars <- join_vars(tbl_vars(x), tbl_vars(y), by) by_x <- vars$idx$x$by by_y <- vars$idx$y$by aux_y <- vars$idx$y$aux if (keep) { aux_y <- c(by_y, aux_y) } out <- nest_join_impl(x, y, by_x, by_y, aux_y, name_var, environment()) out } #' @export #' @rdname join.tbl_df left_join.tbl_df <- function(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ..., na_matches = pkgconfig::get_config("dplyr::na_matches")) { check_valid_names(tbl_vars(x)) check_valid_names(tbl_vars(y)) by <- common_by(by, x, y) suffix <- check_suffix(suffix) na_matches <- check_na_matches(na_matches) y <- auto_copy(x, y, copy = copy) vars <- join_vars(tbl_vars(x), tbl_vars(y), by, suffix) by_x <- vars$idx$x$by by_y <- vars$idx$y$by aux_x <- vars$idx$x$aux aux_y <- vars$idx$y$aux out <- left_join_impl(x, y, by_x, by_y, aux_x, aux_y, na_matches, environment()) names(out) <- vars$alias reconstruct_join(out, x, vars) } #' @export #' @rdname join.tbl_df right_join.tbl_df <- function(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ..., na_matches = pkgconfig::get_config("dplyr::na_matches")) { check_valid_names(tbl_vars(x)) check_valid_names(tbl_vars(y)) by <- common_by(by, x, y) suffix <- check_suffix(suffix) na_matches <- check_na_matches(na_matches) y <- auto_copy(x, y, copy = copy) vars <- join_vars(tbl_vars(x), tbl_vars(y), by, suffix) by_x <- vars$idx$x$by by_y <- vars$idx$y$by aux_x <- vars$idx$x$aux aux_y <- vars$idx$y$aux out <- right_join_impl(x, y, by_x, by_y, aux_x, aux_y, na_matches, environment()) names(out) <- vars$alias reconstruct_join(out, x, vars) } #' @export #' @rdname join.tbl_df full_join.tbl_df <- function(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ..., na_matches = pkgconfig::get_config("dplyr::na_matches")) { check_valid_names(tbl_vars(x)) check_valid_names(tbl_vars(y)) by <- common_by(by, x, y) suffix <- check_suffix(suffix) na_matches <- check_na_matches(na_matches) y <- auto_copy(x, y, copy = copy) vars <- join_vars(tbl_vars(x), tbl_vars(y), by, suffix) by_x <- vars$idx$x$by by_y <- vars$idx$y$by aux_x <- vars$idx$x$aux aux_y <- vars$idx$y$aux out <- full_join_impl(x, y, by_x, by_y, aux_x, aux_y, na_matches, environment()) names(out) <- vars$alias reconstruct_join(out, x, vars) } #' @export #' @rdname join.tbl_df semi_join.tbl_df <- function(x, y, by = NULL, copy = FALSE, ..., na_matches = pkgconfig::get_config("dplyr::na_matches")) { check_valid_names(tbl_vars(x), warn_only = TRUE) check_valid_names(tbl_vars(y), warn_only = TRUE) by <- common_by(by, x, y) y <- auto_copy(x, y, copy = copy) out <- semi_join_impl(x, y, by$x, by$y, check_na_matches(na_matches), environment()) if (is_grouped_df(x)) { out <- grouped_df_impl(out, group_vars(x), group_by_drop_default(x)) } out } #' @export #' @rdname join.tbl_df anti_join.tbl_df <- function(x, y, by = NULL, copy = FALSE, ..., na_matches = pkgconfig::get_config("dplyr::na_matches")) { check_valid_names(tbl_vars(x), warn_only = TRUE) check_valid_names(tbl_vars(y), warn_only = TRUE) by <- common_by(by, x, y) y <- auto_copy(x, y, copy = copy) out <- anti_join_impl(x, y, by$x, by$y, check_na_matches(na_matches), environment()) if (is_grouped_df(x)) { out <- grouped_df_impl(out, group_vars(x), group_by_drop_default(x)) } out } reconstruct_join <- function(out, x, vars) { if (is_grouped_df(x)) { groups_in_old <- match(group_vars(x), tbl_vars(x)) groups_in_alias <- match(groups_in_old, vars$x) out <- grouped_df_impl(out, vars$alias[groups_in_alias], group_by_drop_default(x)) } out } # Set operations --------------------------------------------------------------- #' @export # Can't use NextMethod() in R 3.1, r-lib/rlang#486 distinct.tbl_df <- distinct.data.frame #' @export # Can't use NextMethod() in R 3.1, r-lib/rlang#486 distinct_.tbl_df <- distinct_.data.frame dplyr/R/group-size.r0000644000176200001440000000074513614573562014116 0ustar liggesusers#' Calculate group sizes. #' #' @family grouping functions #' @param x a grouped tbl #' @export #' @examples #' if (require("nycflights13")) { #' #' by_day <- flights %>% group_by(year, month, day) #' n_groups(by_day) #' group_size(by_day) #' #' by_dest <- flights %>% group_by(dest) #' n_groups(by_dest) #' group_size(by_dest) #' } #' @keywords internal group_size <- function(x) UseMethod("group_size") #' @export #' @rdname group_size n_groups <- function(x) UseMethod("n_groups") dplyr/R/recode.R0000644000176200001440000002177213614573562013216 0ustar liggesusers#' Recode values #' #' This is a vectorised version of [switch()]: you can replace #' numeric values based on their position or their name, and character or factor #' values only by their name. This is an S3 generic: dplyr provides methods for #' numeric, character, and factors. For logical vectors, use [if_else()]. For #' more complicated criteria, use [case_when()]. #' #' You can use `recode()` directly with factors; it will preserve the existing #' order of levels while changing the values. Alternatively, you can #' use `recode_factor()`, which will change the order of levels to match #' the order of replacements. See the [forcats](http://forcats.tidyverse.org/) #' package for more tools for working with factors and their levels. #' #' @param .x A vector to modify #' @param ... Replacements. For character and factor `.x`, these should be named #' and replacement is based only on their name. For numeric `.x`, these can be #' named or not. If not named, the replacement is done based on position i.e. #' `.x` represents positions to look for in replacements. See examples. #' #' When named, the argument names should be the current values to be replaced, and the #' argument values should be the new (replacement) values. #' #' All replacements must be the same type, and must have either #' length one or the same length as `.x`. #' #' These dots support [tidy dots][rlang::tidy-dots] features. #' @param .default If supplied, all values not otherwise matched will #' be given this value. If not supplied and if the replacements are #' the same type as the original values in `.x`, unmatched #' values are not changed. If not supplied and if the replacements #' are not compatible, unmatched values are replaced with `NA`. #' #' `.default` must be either length 1 or the same length as #' `.x`. #' @param .missing If supplied, any missing values in `.x` will be #' replaced by this value. Must be either length 1 or the same length as #' `.x`. #' @param .ordered If `TRUE`, `recode_factor()` creates an #' ordered factor. #' @return A vector the same length as `.x`, and the same type as #' the first of `...`, `.default`, or `.missing`. #' `recode_factor()` returns a factor whose levels are in the same order as #' in `...`. The levels in `.default` and `.missing` come last. #' @seealso [na_if()] to replace specified values with a `NA`. #' #' [coalesce()] to replace missing values with a specified value. #' #' [tidyr::replace_na()] to replace `NA` with a value. #' @export #' @examples #' # For character values, recode values with named arguments only. Unmatched #' # values are unchanged. #' char_vec <- sample(c("a", "b", "c"), 10, replace = TRUE) #' recode(char_vec, a = "Apple") #' recode(char_vec, a = "Apple", b = "Banana") #' #' # Use .default as replacement for unmatched values #' recode(char_vec, a = "Apple", b = "Banana", .default = NA_character_) #' #' # Use a named character vector for unquote splicing with !!! #' level_key <- c(a = "apple", b = "banana", c = "carrot") #' recode(char_vec, !!!level_key) #' #' # For numeric values, named arguments can also be used #' num_vec <- c(1:4, NA) #' recode(num_vec, `2` = 20L, `4` = 40L) #' #' # Or if you don't name the arguments, recode() matches by position. #' # (Only works for numeric vector) #' recode(num_vec, "a", "b", "c", "d") #' # .x (position given) looks in (...), then grabs (... value at position) #' # so if nothing at position (here 5), it uses .default or NA. #' recode(c(1,5,3), "a", "b", "c", "d", .default = "nothing") #' #' # Note that if the replacements are not compatible with .x, #' # unmatched values are replaced by NA and a warning is issued. #' recode(num_vec, `2` = "b", `4` = "d") #' # use .default to change the replacement value #' recode(num_vec, "a", "b", "c", .default = "other") #' # use .missing to replace missing values in .x #' recode(num_vec, "a", "b", "c", .default = "other", .missing = "missing") #' #' # For factor values, use only named replacements #' # and supply default with levels() #' factor_vec <- factor(c("a", "b", "c")) #' recode(factor_vec, a = "Apple", .default = levels(factor_vec)) #' #' # Use recode_factor() to create factors with levels ordered as they #' # appear in the recode call. The levels in .default and .missing #' # come last. #' recode_factor(num_vec, `1` = "z", `2` = "y", `3` = "x") #' recode_factor(num_vec, `1` = "z", `2` = "y", `3` = "x", #' .default = "D") #' recode_factor(num_vec, `1` = "z", `2` = "y", `3` = "x", #' .default = "D", .missing = "M") #' #' # When the input vector is a compatible vector (character vector or #' # factor), it is reused as default. #' recode_factor(letters[1:3], b = "z", c = "y") #' recode_factor(factor(letters[1:3]), b = "z", c = "y") #' #' # Use a named character vector to recode factors with unquote splicing. #' level_key <- c(a = "apple", b = "banana", c = "carrot") #' recode_factor(char_vec, !!!level_key) recode <- function(.x, ..., .default = NULL, .missing = NULL) { UseMethod("recode") } #' @export recode.numeric <- function(.x, ..., .default = NULL, .missing = NULL) { values <- list2(...) nms <- have_name(values) if (all(nms)) { vals <- as.double(names(values)) } else if (all(!nms)) { vals <- seq_along(values) } else { abort("Either all values must be named, or none must be named.") } n <- length(.x) template <- find_template(values, .default, .missing) out <- template[rep(NA_integer_, n)] replaced <- rep(FALSE, n) for (i in seq_along(values)) { out <- replace_with(out, .x == vals[i], values[[i]], paste0("Vector ", i)) replaced[.x == vals[i]] <- TRUE } .default <- validate_recode_default(.default, .x, out, replaced) out <- replace_with(out, !replaced & !is.na(.x), .default, "`.default`") out <- replace_with(out, is.na(.x), .missing, "`.missing`") out } #' @export recode.character <- function(.x, ..., .default = NULL, .missing = NULL) { .x <- as.character(.x) values <- list2(...) if (!all(have_name(values))) { bad <- which(!have_name(values)) + 1 bad_pos_args(bad, "must be named, not unnamed") } n <- length(.x) template <- find_template(values, .default, .missing) out <- template[rep(NA_integer_, n)] replaced <- rep(FALSE, n) for (nm in names(values)) { out <- replace_with(out, .x == nm, values[[nm]], paste0("`", nm, "`")) replaced[.x == nm] <- TRUE } .default <- validate_recode_default(.default, .x, out, replaced) out <- replace_with(out, !replaced & !is.na(.x), .default, "`.default`") out <- replace_with(out, is.na(.x), .missing, "`.missing`") out } #' @export recode.factor <- function(.x, ..., .default = NULL, .missing = NULL) { values <- list2(...) if (length(values) == 0) { abort("No replacements provided") } if (!all(have_name(values))) { bad <- which(!have_name(values)) + 1 bad_pos_args(bad, "must be named, not unnamed") } if (!is.null(.missing)) { bad_args(".missing", "is not supported for factors") } n <- length(levels(.x)) template <- find_template(values, .default, .missing) out <- template[rep(NA_integer_, n)] replaced <- rep(FALSE, n) for (nm in names(values)) { out <- replace_with( out, levels(.x) == nm, values[[nm]], paste0("`", nm, "`") ) replaced[levels(.x) == nm] <- TRUE } .default <- validate_recode_default(.default, .x, out, replaced) out <- replace_with(out, !replaced, .default, "`.default`") if (is.character(out)) { levels(.x) <- out .x } else { out[as.integer(.x)] } } find_template <- function(values, .default = NULL, .missing = NULL) { x <- compact(c(values, .default, .missing)) if (length(x) == 0) { abort("No replacements provided") } x[[1]] } validate_recode_default <- function(default, x, out, replaced) { default <- recode_default(x, default, out) if (is.null(default) && sum(replaced & !is.na(x)) < length(out[!is.na(x)])) { warning( "Unreplaced values treated as NA as .x is not compatible. ", "Please specify replacements exhaustively or supply .default", call. = FALSE ) } default } recode_default <- function(x, default, out) { UseMethod("recode_default") } recode_default.default <- function(x, default, out) { same_type <- identical(typeof(x), typeof(out)) if (is.null(default) && same_type) { x } else { default } } recode_default.factor <- function(x, default, out) { if (is.null(default)) { if ((is.character(out) || is.factor(out)) && is.factor(x)) { levels(x) } else { out[NA_integer_] } } else { default } } #' @rdname recode #' @export recode_factor <- function(.x, ..., .default = NULL, .missing = NULL, .ordered = FALSE) { values <- list2(...) recoded <- recode(.x, !!!values, .default = .default, .missing = .missing) all_levels <- unique(c(values, recode_default(.x, .default, recoded), .missing)) recoded_levels <- if (is.factor(recoded)) levels(recoded) else unique(recoded) levels <- intersect(all_levels, recoded_levels) factor(recoded, levels, ordered = .ordered) } dplyr/R/coalesce.R0000644000176200001440000000257413614573561013531 0ustar liggesusers#' Find first non-missing element #' #' Given a set of vectors, `coalesce()` finds the first non-missing value #' at each position. This is inspired by the SQL `COALESCE` function #' which does the same thing for `NULL`s. #' #' @param ... Vectors. All inputs should either be length 1, or the #' same length as the first argument. #' #' These dots support [tidy dots][rlang::tidy-dots] features. #' @return A vector the same length as the first `...` argument with #' missing values replaced by the first non-missing value. #' @seealso [na_if()] to replace specified values with a `NA`. #' [tidyr::replace_na()] to replace `NA` with a value #' @export #' @examples #' # Use a single value to replace all missing values #' x <- sample(c(1:5, NA, NA, NA)) #' coalesce(x, 0L) #' #' # Or match together a complete vector from missing pieces #' y <- c(1, 2, NA, NA, 5) #' z <- c(NA, NA, 3, 4, 5) #' coalesce(y, z) #' #' # Supply lists by splicing them into dots: #' vecs <- list( #' c(1, 2, NA, NA, 5), #' c(NA, NA, 3, 4, 5) #' ) #' coalesce(!!!vecs) coalesce <- function(...) { if (missing(..1)) { abort("At least one argument must be supplied") } values <- list2(...) x <- values[[1]] values <- values[-1] for (i in seq_along(values)) { x <- replace_with( x, is.na(x), values[[i]], glue("Argument {i + 1}"), glue("length of {fmt_args(~x)}") ) } x } dplyr/R/sample.R0000644000176200001440000000716713614573562013240 0ustar liggesusers#' Sample n rows from a table #' #' This is a wrapper around [sample.int()] to make it easy to #' select random rows from a table. It currently only works for local #' tbls. #' #' @param tbl tbl of data. #' @param size For `sample_n()`, the number of rows to select. #' For `sample_frac()`, the fraction of rows to select. #' If `tbl` is grouped, `size` applies to each group. #' @param replace Sample with or without replacement? #' @param weight Sampling weights. This must evaluate to a vector of #' non-negative numbers the same length as the input. Weights are #' automatically standardised to sum to 1. #' #' This argument is automatically [quoted][rlang::quo] and later #' [evaluated][rlang::eval_tidy] in the context of the data #' frame. It supports [unquoting][rlang::quasiquotation]. See #' `vignette("programming")` for an introduction to these concepts. #' @param .env This variable is deprecated and no longer has any #' effect. To evaluate `weight` in a particular context, you can #' now unquote a [quosure][rlang::quosure]. #' @param ... ignored #' #' @name sample #' @examples #' by_cyl <- mtcars %>% group_by(cyl) #' #' # Sample fixed number per group #' sample_n(mtcars, 10) #' sample_n(mtcars, 50, replace = TRUE) #' sample_n(mtcars, 10, weight = mpg) #' #' sample_n(by_cyl, 3) #' sample_n(by_cyl, 10, replace = TRUE) #' sample_n(by_cyl, 3, weight = mpg / mean(mpg)) #' #' # Sample fixed fraction per group #' # Default is to sample all data = randomly resample rows #' sample_frac(mtcars) #' #' sample_frac(mtcars, 0.1) #' sample_frac(mtcars, 1.5, replace = TRUE) #' sample_frac(mtcars, 0.1, weight = 1 / mpg) #' #' sample_frac(by_cyl, 0.2) #' sample_frac(by_cyl, 1, replace = TRUE) NULL #' @rdname sample #' @export sample_n <- function(tbl, size, replace = FALSE, weight = NULL, .env = NULL, ...) { UseMethod("sample_n") } #' @rdname sample #' @export sample_frac <- function(tbl, size = 1, replace = FALSE, weight = NULL, .env = NULL, ...) { UseMethod("sample_frac") } # Data frames (and tbl_df) ----------------------------------------------------- # Grouped data frames ---------------------------------------------------------- # Default method --------------------------------------------------------------- #' @export sample_n.default <- function(tbl, size, replace = FALSE, weight = NULL, .env = parent.frame(), ...) { bad_args("tbl", "must be a data frame, not {friendly_type_of(tbl)}") } #' @export sample_frac.default <- function(tbl, size = 1, replace = FALSE, weight = NULL, .env = parent.frame(), ...) { bad_args("tbl", "must be a data frame, not {friendly_type_of(tbl)}") } # Helper functions ------------------------------------------------------------- check_weight <- function(x, n) { if (is.null(x)) return() if (!is.numeric(x)) { bad_args("weight", "must be a numeric, not {friendly_type_of(x)}") } if (any(x < 0)) { bad_args("weight", "must be a vector with all values nonnegative, ", "not {x[x < 0][[1]]}" ) } if (length(x) != n) { bad_args("weight", "must be a length {n} (same as data), ", "not {length(x)}" ) } x / sum(x) } check_size <- function(size, n, replace = FALSE) { if (size <= n || replace) return(invisible(size)) bad_args("size", "must be less or equal than {n} (size of data), ", "set `replace` = TRUE to use sampling with replacement" ) } check_frac <- function(size, replace = FALSE) { if (size <= 1 || replace) return(invisible(size)) bad_args("size", "of sampled fraction must be less or equal to one, ", "set `replace` = TRUE to use sampling with replacement" ) } dplyr/R/hybrid.R0000644000176200001440000000132413614573562013225 0ustar liggesusers#' Inspect how dplyr evaluates an expression #' #' @param .data a tibble #' @param expr an expression #' #' @examples #' # hybrid evaulation #' hybrid_call(iris, n()) #' #' # standard evaluation #' hybrid_call(iris, n() + 1L) #' @export hybrid_call <- function(.data, expr){ UseMethod("hybrid_call") } #' @export hybrid_call.data.frame <- function(.data, expr){ hybrid_impl(.data, enquo(expr), caller_env()) } #' @export print.hybrid_call <- function(x, ...){ if(isTRUE(x)){ cat("\n") cat( " call : ") print(attr(x, "call")) cat( " C++ class :", attr(x, "cpp_class")) } else { cat("\n") cat( " call : ") print(attr(x, "call")) } } dplyr/R/group_keys.R0000644000176200001440000000116213614573562014133 0ustar liggesusersgroup_keys_impl <- function(.data) { select(group_data(.data), -last_col()) } #' @rdname group_split #' @export group_keys <- function(.tbl, ...) { UseMethod("group_keys") } #' @export group_keys.data.frame <- function(.tbl, ...){ group_keys_impl(group_by(.tbl, ...)) } #' @export group_keys.grouped_df <- function(.tbl, ...) { if (dots_n(...)) { warn("... is ignored in group_keys(), please use group_by(..., add = TRUE) %>% group_keys()") } group_keys_impl(.tbl) } #' @export group_keys.rowwise_df <- function(.tbl, ...) { abort("group_keys() is not meaningful for row wise data frames") } dplyr/R/compat-lifecycle.R0000644000176200001440000001445313614573561015172 0ustar liggesusers# nocov start - compat-lifecycle (last updated: rlang 0.3.0.9000) # 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)) { if (rlang::is_true(rlang::peek_option("lifecycle_disable_warnings"))) { return(invisible(NULL)) } if (rlang::is_true(rlang::peek_option("lifecycle_verbose_soft_deprecation")) || rlang::is_reference(topenv(env), rlang::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) { 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 <- .Defunct } else { signal <- .Deprecated } signal(msg = paste0( msg, "\n", silver("This warning is displayed once per session.") )) } deprecation_env <- new.env(parent = emptyenv()) stop_defunct <- function(msg) { .Defunct(msg = msg) } scoped_lifecycle_silence <- function(frame = rlang::caller_env()) { rlang::scoped_options(.frame = frame, lifecycle_disable_warnings = TRUE ) } with_lifecycle_silence <- function(expr) { scoped_lifecycle_silence() expr } scoped_lifecycle_warnings <- function(frame = rlang::caller_env()) { rlang::scoped_options(.frame = frame, lifecycle_disable_warnings = FALSE, lifecycle_verbose_soft_deprecation = TRUE, lifecycle_repeat_warnings = TRUE ) } with_lifecycle_warnings <- function(expr) { scoped_lifecycle_warnings() expr } scoped_lifecycle_errors <- function(frame = rlang::caller_env()) { scoped_lifecycle_warnings(frame = frame) rlang::scoped_options(.frame = frame, lifecycle_warnings_as_errors = TRUE ) } with_lifecycle_errors <- function(expr) { scoped_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"`. #' #' @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 = , 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 } # nocov end dplyr/R/compat-purrr.R0000644000176200001440000001067113614573561014403 0ustar liggesusers# nocov start - compat-purrr (last updated: rlang 0.3.0.9000) # 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), ...) } 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, ...) { out <- mapply(.f, .x, .y, MoreArgs = list(...), SIMPLIFY = FALSE) if (length(out) == length(.x)) { set_names(out, names(.x)) } else { set_names(out, NULL) } } 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") } walk2 <- function(.x, .y, .f, ...) { map2(.x, .y, .f, ...) invisible(.x) } args_recycle <- function(args) { lengths <- lengths(args) 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 } compact <- function(.x) { Filter(length, .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 } imap <- function(.x, .f, ...) { map2(.x, vec_index(.x), .f, ...) } vec_index <- function(x) { names(x) %||% seq_along(x) } # nocov end dplyr/R/compat-name-repair.R0000644000176200001440000001202113614573561015420 0ustar liggesusers# compat-name-repair (last updated: tibble 2.0.1.9000) # This file serves as a reference for compatibility functions for # name repair in tibble, until name repair is available in rlang. error_name_length_required <- function() { "`n` must be specified, when the `names` attribute is `NULL`." } minimal_names <- function(name, n) { if (is.null(name) && missing(n)) { abort(error_name_length_required()) } ## TODO: address scenarios where name is not NULL and n != length(name)? if (is.null(name)) { rep_len("", n) } else { name %|% "" } } set_minimal_names <- function(x) { new_names <- minimal_names(names(x), n = length(x)) set_names(x, new_names) } unique_names <- function(name, quiet = FALSE, transform = identity) { min_name <- minimal_names(name) naked_name <- strip_pos(min_name) naked_is_empty <- (naked_name == "") new_name <- transform(naked_name) new_name <- append_pos(new_name, needs_suffix = naked_is_empty) duped_after <- duplicated(new_name) | duplicated(new_name, fromLast = TRUE) new_name <- append_pos(new_name, duped_after) if (!quiet) { describe_repair(name, new_name) } new_name } set_unique_names <- function(x, quiet = FALSE) { x <- set_minimal_names(x) new_names <- unique_names(names(x), quiet = quiet) set_names(x, new_names) } universal_names <- function(name, quiet = FALSE) { unique_names(name, quiet = quiet, transform = make_syntactic) } set_universal_names <- function(x, quiet = FALSE) { x <- set_minimal_names(x) new_names <- universal_names(names(x), quiet = quiet) set_names(x, new_names) } ## makes each individual name syntactic ## does not enforce unique-ness make_syntactic <- function(name) { name[is.na(name)] <- "" name[name == ""] <- "." name[name == "..."] <- "...." name <- sub("^_", "._", name) new_name <- make.names(name) X_prefix <- grepl("^X", new_name) & !grepl("^X", name) new_name[X_prefix] <- sub("^X", "", new_name[X_prefix]) dot_suffix <- which(new_name == paste0(name, ".")) new_name[dot_suffix] <- sub("^(.*)[.]$", ".\\1", new_name[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_name, pattern = regex) needs_dots <- which(re$numbers != "") needs_third_dot <- (re$leftovers[needs_dots] == "") re$leading_dots[needs_dots] <- ifelse(needs_third_dot, "...", "..") new_name <- paste0(re$leading_dots, re$numbers, re$leftovers) new_name } append_pos <- function(name, needs_suffix) { need_append_pos <- which(needs_suffix) name[need_append_pos] <- paste0(name[need_append_pos], "..", need_append_pos) name } strip_pos <- function(name) { rx <- "[.][.][1-9][0-9]*$" gsub(rx, "", name) %|% "" } describe_repair <- function(orig_name, name) { stopifnot(length(orig_name) == length(name)) new_names <- name != minimal_names(orig_name) if (any(new_names)) { msg <- bullets( "New names:", paste0( tick_if_needed(orig_name[new_names]), " -> ", tick_if_needed(name[new_names]), .problem = "" ) ) message(msg) } } ## 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 } # A better version (with far more dependencies) exists in msg-format.R 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") ) } # FIXME: Also exists in pillar, do we need to export? 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 } dplyr/R/rowwise.r0000644000176200001440000000671113614573562013510 0ustar liggesusers#' Group input by rows #' #' \Sexpr[results=rd, stage=render]{dplyr:::lifecycle("questioning")} #' #' See [this repository](https://github.com/jennybc/row-oriented-workflows) #' for alternative ways to perform row-wise operations #' #' `rowwise()` is used for the results of [do()] when you #' create list-variables. It is also useful to support arbitrary #' complex operations that need to be applied to each row. #' #' Currently, rowwise grouping only works with data frames. Its #' main impact is to allow you to work with list-variables in #' [summarise()] and [mutate()] without having to #' use \code{[[1]]}. This makes `summarise()` on a rowwise tbl #' effectively equivalent to [plyr::ldply()]. #' #' @param data Input data frame. #' @export #' @examples #' df <- expand.grid(x = 1:3, y = 3:1) #' df_done <- df %>% rowwise() %>% do(i = seq(.$x, .$y)) #' df_done #' df_done %>% summarise(n = length(i)) rowwise <- function(data) { stopifnot(is.data.frame(data)) assert_all_allow_list(data) structure(data, class = c("rowwise_df", "tbl_df", "tbl", "data.frame")) } setOldClass(c("rowwise_df", "tbl_df", "tbl", "data.frame")) #' @export print.rowwise_df <- function(x, ..., n = NULL, width = NULL) { cat("Source: local data frame ", dim_desc(x), "\n", sep = "") cat("Groups: \n") cat("\n") print(trunc_mat(x, n = n, width = width)) invisible(x) } #' @export ungroup.rowwise_df <- function(x, ...) { class(x) <- c("tbl_df", "tbl", "data.frame") x } #' @export as.data.frame.rowwise_df <- function(x, row.names, optional, ...) { class(x) <- "data.frame" x } #' @export group_size.rowwise_df <- function(x) { rep.int(1L, nrow(x)) } #' @export n_groups.rowwise_df <- function(x) { nrow(x) } #' @export group_by.rowwise_df <- function(.data, ..., add = FALSE, .drop = group_by_drop_default(.data)) { warn("Grouping rowwise data frame strips rowwise nature") .data <- ungroup(.data) groups <- group_by_prepare(.data, ..., add = add) grouped_df(groups$data, groups$group_names, .drop) } #' @export group_by_.rowwise_df <- function(.data, ..., .dots = list(), add = FALSE, .drop = FALSE) { dots <- compat_lazy_dots(.dots, caller_env(), ...) group_by(.data, !!!dots, add = add, .drop = .drop) } # Do --------------------------------------------------------------------------- #' @export do.rowwise_df <- function(.data, ...) { # Create ungroup version of data frame suitable for subsetting group_data <- ungroup(.data) args <- enquos(...) named <- named_args(args) # Create new environment, inheriting from parent, with an active binding # for . that resolves to the current subset. `_i` is found in environment # of this function because of usual scoping rules. mask <- new_data_mask(new_environment()) current_row <- function() lapply(group_data[`_i`, , drop = FALSE], "[[", 1) env_bind_do_pronouns(mask, current_row) n <- nrow(.data) m <- length(args) out <- replicate(m, vector("list", n), simplify = FALSE) names(out) <- names(args) p <- progress_estimated(n * m, min_time = 2) for (`_i` in seq_len(n)) { for (j in seq_len(m)) { out[[j]][`_i`] <- list(eval_tidy(args[[j]], mask)) p$tick()$print() } } if (!named) { label_output_dataframe(NULL, out, groups(.data), group_by_drop_default(.data)) } else { label_output_list(NULL, out, groups(.data)) } } #' @export do_.rowwise_df <- function(.data, ..., .dots = list()) { dots <- compat_lazy_dots(.dots, caller_env(), ...) do(.data, !!!dots) } dplyr/R/sets.r0000644000176200001440000000355313614573562012770 0ustar liggesusers#' Set operations #' #' These functions override the set functions provided in base to make them #' generic so that efficient versions for data frames and other tables can be #' provided. The default methods call the base versions. Beware that #' `intersect()`, `union()` and `setdiff()` remove duplicates. #' #' @param x,y objects to perform set function on (ignoring order) #' @param ... other arguments passed on to methods #' @name setops #' @examples #' mtcars$model <- rownames(mtcars) #' first <- mtcars[1:20, ] #' second <- mtcars[10:32, ] #' #' intersect(first, second) #' union(first, second) #' setdiff(first, second) #' setdiff(second, first) #' #' union_all(first, second) #' setequal(mtcars, mtcars[32:1, ]) #' #' # Handling of duplicates: #' a <- data.frame(column = c(1:10, 10)) #' b <- data.frame(column = c(1:5, 5)) #' #' # intersection is 1 to 5, duplicates removed (5) #' intersect(a, b) #' #' # union is 1 to 10, duplicates removed (5 and 10) #' union(a, b) #' #' # set difference, duplicates removed (10) #' setdiff(a, b) #' #' # union all does not remove duplicates #' union_all(a, b) NULL #' @rdname setops #' @export intersect <- function(x, y, ...) UseMethod("intersect") #' @rdname setops #' @export union <- function(x, y, ...) UseMethod("union") #' @rdname setops #' @export union_all <- function(x, y, ...) UseMethod("union_all") #' @rdname setops #' @export setdiff <- function(x, y, ...) UseMethod("setdiff") #' @rdname setops #' @export setequal <- function(x, y, ...) UseMethod("setequal") #' @export intersect.default <- function(x, y, ...) base::intersect(x, y, ...) #' @export union.default <- function(x, y, ...) base::union(x, y, ...) #' @export union_all.default <- function(x, y, ...) combine(x, y, ...) #' @export setdiff.default <- function(x, y, ...) base::setdiff(x, y, ...) #' @export setequal.default <- function(x, y, ...) base::setequal(x, y, ...) dplyr/R/reexport-tibble.r0000644000176200001440000000235713574646634015130 0ustar liggesusers# dataframe --------------------------------------------------------------- #' @importFrom tibble data_frame #' @export tibble::data_frame #' @importFrom tibble data_frame_ #' @export tibble::data_frame_ #' @importFrom tibble as_data_frame #' @export tibble::as_data_frame #' @importFrom tibble lst #' @export tibble::lst #' @importFrom tibble lst_ #' @export tibble::lst_ #' @importFrom tibble add_row #' @export tibble::add_row # type_sum ---------------------------------------------------------------- #' @importFrom tibble type_sum #' @export tibble::type_sum # glimpse ----------------------------------------------------------------- #' @importFrom tibble glimpse #' @export tibble::glimpse # frame-data -------------------------------------------------------------- #' @importFrom tibble frame_data #' @export tibble::frame_data #' @importFrom tibble tribble #' @export tibble::tribble #' @importFrom tibble tibble #' @export tibble::tibble #' @importFrom tibble as_tibble #' @export tibble::as_tibble #' @importFrom tibble view tibble::view # utils ------------------------------------------------------------------- #' @importFrom tibble trunc_mat #' @export tibble::trunc_mat #' @importFrom tibble tbl_sum #' @export tibble::tbl_sum dplyr/R/order-by.R0000644000176200001440000000337313614573562013475 0ustar liggesusers#' A helper function for ordering window function output #' #' This function makes it possible to control the ordering of window functions #' in R that don't have a specific ordering parameter. When translated to SQL #' it will modify the order clause of the OVER function. #' #' This function works by changing the `call` to instead call #' [with_order()] with the appropriate arguments. #' #' @param order_by a vector to order_by #' @param call a function call to a window function, where the first argument #' is the vector being operated on #' @export #' @examples #' order_by(10:1, cumsum(1:10)) #' x <- 10:1 #' y <- 1:10 #' order_by(x, cumsum(y)) #' #' df <- data.frame(year = 2000:2005, value = (0:5) ^ 2) #' scrambled <- df[sample(nrow(df)), ] #' #' wrong <- mutate(scrambled, running = cumsum(value)) #' arrange(wrong, year) #' #' right <- mutate(scrambled, running = order_by(year, cumsum(value))) #' arrange(right, year) order_by <- function(order_by, call) { quo <- enquo(call) expr <- quo_get_expr(quo) if (!is_call(expr)) { type <- friendly_type_of(expr) bad_args("call", "must be a function call, not { type }") } fn <- set_expr(quo, node_car(expr)) args <- node_cdr(expr) args <- map(args, new_quosure, quo_get_env(quo)) expr <- expr(with_order(!!order_by, !!fn, !!!args)) eval_tidy(expr) } #' Run a function with one order, translating result back to original order #' #' This is used to power the ordering parameters of dplyr's window functions #' #' @param order_by vector to order by #' @param fun window function #' @param x,... arguments to `f` #' @keywords internal #' @export with_order <- function(order_by, fun, x, ...) { ord <- order(order_by) undo <- match(seq_along(order_by), ord) out <- fun(x[ord], ...) out[undo] } dplyr/NEWS.md0000644000176200001440000024652113614573561012527 0ustar liggesusers# dplyr 0.8.4 (2020-01-30) * Adapt tests to changes in dependent packages. # dplyr 0.8.3 (2019-07-04) * Fixed performance regression introduced in version 0.8.2 (#4458). # dplyr 0.8.2 (2019-06-28) ## New functions * `top_frac(data, proportion)` is a shorthand for `top_n(data, proportion * n())` (#4017). ## colwise changes * Using quosures in colwise verbs is deprecated (#4330). * Updated `distinct_if()`, `distinct_at()` and `distinct_all()` to include `.keep_all` argument (@beansrowning, #4343). * `rename_at()` handles empty selection (#4324). * `*_if()` functions correctly handle columns with special names (#4380). * colwise functions support constants in formulas (#4374). ## Hybrid evaluation changes * hybrid rank functions correctly handle NA (#4427). * `first()`, `last()` and `nth()` hybrid version handles factors (#4295). ## Minor changes * `top_n()` quotes its `n` argument, `n` no longer needs to be constant for all groups (#4017). * `tbl_vars()` keeps information on grouping columns by returning a `dplyr_sel_vars` object (#4106). * `group_split()` always sets the `ptype` attribute, which make it more robust in the case where there are 0 groups. * `group_map()` and `group_modify()` work in the 0 group edge case (#4421) * `select.list()` method added so that `select()` does not dispatch on lists (#4279). * `view()` is reexported from tibble (#4423). * `group_by()` puts NA groups last in character vectors (#4227). * `arrange()` handles integer64 objects (#4366). * `summarise()` correctly resolves summarised list columns (#4349). # dplyr 0.8.1 (2019-05-14) ## Breaking changes * `group_modify()` is the new name of the function previously known as `group_map()` ## New functions * `group_map()` now only calls the function on each group and return a list. * `group_by_drop_default()`, previously known as `dplyr:::group_drops()` is exported (#4245). ## Minor changes * Lists of formulas passed to colwise verbs are now automatically named. * `group_by()` does a shallow copy even in the no groups case (#4221). * Fixed `mutate()` on rowwise data frames with 0 rows (#4224). * Fixed handling of bare formulas in colwise verbs (#4183). * Fixed performance of `n_distinct()` (#4202). * `group_indices()` now ignores empty groups by default for `data.frame`, which is consistent with the default of `group_by()` (@yutannihilation, #4208). * Fixed integer overflow in hybrid `ntile()` (#4186). * colwise functions `summarise_at()` ... can rename vars in the case of multiple functions (#4180). * `select_if()` and `rename_if()` handle logical vector predicate (#4213). * hybrid `min()` and `max()` cast to integer when possible (#4258). * `bind_rows()` correctly handles the cases where there are multiple consecutive `NULL` (#4296). * Support for R 3.1.* has been dropped. The minimal R version supported is now 3.2.0. https://www.tidyverse.org/articles/2019/04/r-version-support/ * `rename_at()` handles empty selection (#4324). # dplyr 0.8.0.1 (2019-02-15) * Fixed integer C/C++ division, forced released by CRAN (#4185). # dplyr 0.8.0 (2019-02-14) ## Breaking changes * The error `could not find function "n"` or the warning ```Calling `n()` without importing or prefixing it is deprecated, use `dplyr::n()` ``` indicates when functions like `n()`, `row_number()`, ... are not imported or prefixed. The easiest fix is to import dplyr with `import(dplyr)` in your `NAMESPACE` or `#' @import dplyr` in a roxygen comment, alternatively such functions can be imported selectively as any other function with `importFrom(dplyr, n)` in the `NAMESPACE` or `#' @importFrom dplyr n` in a roxygen comment. The third option is to prefix them, i.e. use `dplyr::n()` * If you see `checking S3 generic/method consistency` in R CMD check for your package, note that : - `sample_n()` and `sample_frac()` have gained `...` - `filter()` and `slice()` have gained `.preserve` - `group_by()` has gained `.drop` * ```Error: `.data` is a corrupt grouped_df, ...``` signals code that makes wrong assumptions about the internals of a grouped data frame. ## New functions * New selection helpers `group_cols()`. It can be called in selection contexts such as `select()` and matches the grouping variables of grouped tibbles. * `last_col()` is re-exported from tidyselect (#3584). * `group_trim()` drops unused levels of factors that are used as grouping variables. * `nest_join()` creates a list column of the matching rows. `nest_join()` + `tidyr::unnest()` is equivalent to `inner_join` (#3570). ```r band_members %>% nest_join(band_instruments) ``` * `group_nest()` is similar to `tidyr::nest()` but focusing on the variables to nest by instead of the nested columns. ```r starwars %>% group_by(species, homeworld) %>% group_nest() starwars %>% group_nest(species, homeworld) ``` * `group_split()` is similar to `base::split()` but operating on existing groups when applied to a grouped data frame, or subject to the data mask on ungrouped data frames ```r starwars %>% group_by(species, homeworld) %>% group_split() starwars %>% group_split(species, homeworld) ``` * `group_map()` and `group_walk()` are purrr-like functions to iterate on groups of a grouped data frame, jointly identified by the data subset (exposed as `.x`) and the data key (a one row tibble, exposed as `.y`). `group_map()` returns a grouped data frame that combines the results of the function, `group_walk()` is only used for side effects and returns its input invisibly. ```r mtcars %>% group_by(cyl) %>% group_map(~ head(.x, 2L)) ``` * `distinct_prepare()`, previously known as `distinct_vars()` is exported. This is mostly useful for alternative backends (e.g. `dbplyr`). ## Major changes * `group_by()` gains the `.drop` argument. When set to `FALSE` the groups are generated based on factor levels, hence some groups may be empty (#341). ```r # 3 groups tibble( x = 1:2, f = factor(c("a", "b"), levels = c("a", "b", "c")) ) %>% group_by(f, .drop = FALSE) # the order of the grouping variables matter df <- tibble( x = c(1,2,1,2), f = factor(c("a", "b", "a", "b"), levels = c("a", "b", "c")) ) df %>% group_by(f, x, .drop = FALSE) df %>% group_by(x, f, .drop = FALSE) ``` The default behaviour drops the empty groups as in the previous versions. ```r tibble( x = 1:2, f = factor(c("a", "b"), levels = c("a", "b", "c")) ) %>% group_by(f) ``` * `filter()` and `slice()` gain a `.preserve` argument to control which groups it should keep. The default `filter(.preserve = FALSE)` recalculates the grouping structure based on the resulting data, otherwise it is kept as is. ```r df <- tibble( x = c(1,2,1,2), f = factor(c("a", "b", "a", "b"), levels = c("a", "b", "c")) ) %>% group_by(x, f, .drop = FALSE) df %>% filter(x == 1) df %>% filter(x == 1, .preserve = TRUE) ``` * The notion of lazily grouped data frames have disappeared. All dplyr verbs now recalculate immediately the grouping structure, and respect the levels of factors. * Subsets of columns now properly dispatch to the `[` or `[[` method when the column is an object (a vector with a class) instead of making assumptions on how the column should be handled. The `[` method must handle integer indices, including `NA_integer_`, i.e. `x[NA_integer_]` should produce a vector of the same class as `x` with whatever represents a missing value. ## Minor changes * `tally()` works correctly on non-data frame table sources such as `tbl_sql` (#3075). * `sample_n()` and `sample_frac()` can use `n()` (#3527) * `distinct()` respects the order of the variables provided (#3195, @foo-bar-baz-qux) and handles the 0 rows and 0 columns special case (#2954). * `combine()` uses tidy dots (#3407). * `group_indices()` can be used without argument in expressions in verbs (#1185). * Using `mutate_all()`, `transmute_all()`, `mutate_if()` and `transmute_if()` with grouped tibbles now informs you that the grouping variables are ignored. In the case of the `_all()` verbs, the message invites you to use `mutate_at(df, vars(-group_cols()))` (or the equivalent `transmute_at()` call) instead if you'd like to make it explicit in your code that the operation is not applied on the grouping variables. * Scoped variants of `arrange()` respect the `.by_group` argument (#3504). * `first()` and `last()` hybrid functions fall back to R evaluation when given no arguments (#3589). * `mutate()` removes a column when the expression evaluates to `NULL` for all groups (#2945). * grouped data frames support `[, drop = TRUE]` (#3714). * New low-level constructor `new_grouped_df()` and validator `validate_grouped_df` (#3837). * `glimpse()` prints group information on grouped tibbles (#3384). * `sample_n()` and `sample_frac()` gain `...` (#2888). * Scoped filter variants now support functions and purrr-like lambdas: ```r mtcars %>% filter_at(vars(hp, vs), ~ . %% 2 == 0) ``` ## Lifecycle * `do()`, `rowwise()` and `combine()` are questioning (#3494). * `funs()` is soft-deprecated and will start issuing warnings in a future version. ## Changes to column wise functions * Scoped variants for `distinct()`: `distinct_at()`, `distinct_if()`, `distinct_all()` (#2948). * `summarise_at()` excludes the grouping variables (#3613). * `mutate_all()`, `mutate_at()`, `summarise_all()` and `summarise_at()` handle utf-8 names (#2967). ## Performance * R expressions that cannot be handled with native code are now evaluated with unwind-protection when available (on R 3.5 and later). This improves the performance of dplyr on data frames with many groups (and hence many expressions to evaluate). We benchmarked that computing a grouped average is consistently twice as fast with unwind-protection enabled. Unwind-protection also makes dplyr more robust in corner cases because it ensures the C++ destructors are correctly called in all circumstances (debugger exit, captured condition, restart invokation). * `sample_n()` and `sample_frac()` gain `...` (#2888). * Improved performance for wide tibbles (#3335). * Faster hybrid `sum()`, `mean()`, `var()` and `sd()` for logical vectors (#3189). * Hybrid version of `sum(na.rm = FALSE)` exits early when there are missing values. This considerably improves performance when there are missing values early in the vector (#3288). * `group_by()` does not trigger the additional `mutate()` on simple uses of the `.data` pronoun (#3533). ## Internal * The grouping metadata of grouped data frame has been reorganized in a single tidy tibble, that can be accessed with the new `group_data()` function. The grouping tibble consists of one column per grouping variable, followed by a list column of the (1-based) indices of the groups. The new `group_rows()` function retrieves that list of indices (#3489). ```r # the grouping metadata, as a tibble group_by(starwars, homeworld) %>% group_data() # the indices group_by(starwars, homeworld) %>% group_data() %>% pull(.rows) group_by(starwars, homeworld) %>% group_rows() ``` * Hybrid evaluation has been completely redesigned for better performance and stability. ## Documentation * Add documentation example for moving variable to back in `?select` (#3051). * column wise functions are better documented, in particular explaining when grouping variables are included as part of the selection. ### Deprecated and defunct functions * `mutate_each()` and `summarise_each()` are deprecated. # dplyr 0.7.6 * `exprs()` is no longer exported to avoid conflicts with `Biobase::exprs()` (#3638). * The MASS package is explicitly suggested to fix CRAN warnings on R-devel (#3657). * Set operations like `intersect()` and `setdiff()` reconstruct groups metadata (#3587) and keep the order of the rows (#3839). * Using namespaced calls to `base::sort()` and `base::unique()` from C++ code to avoid ambiguities when these functions are overridden (#3644). * Fix rchk errors (#3693). # dplyr 0.7.5 (2018-04-14) ## Breaking changes for package developers * The major change in this version is that dplyr now depends on the selecting backend of the tidyselect package. If you have been linking to `dplyr::select_helpers` documentation topic, you should update the link to point to `tidyselect::select_helpers`. * Another change that causes warnings in packages is that dplyr now exports the `exprs()` function. This causes a collision with `Biobase::exprs()`. Either import functions from dplyr selectively rather than in bulk, or do not import `Biobase::exprs()` and refer to it with a namespace qualifier. ## Bug fixes * `distinct(data, "string")` now returns a one-row data frame again. (The previous behavior was to return the data unchanged.) * `do()` operations with more than one named argument can access `.` (#2998). * Reindexing grouped data frames (e.g. after `filter()` or `..._join()`) never updates the `"class"` attribute. This also avoids unintended updates to the original object (#3438). * Fixed rare column name clash in `..._join()` with non-join columns of the same name in both tables (#3266). * Fix `ntile()` and `row_number()` ordering to use the locale-dependent ordering functions in R when dealing with character vectors, rather than always using the C-locale ordering function in C (#2792, @foo-bar-baz-qux). * Summaries of summaries (such as `summarise(b = sum(a), c = sum(b))`) are now computed using standard evaluation for simplicity and correctness, but slightly slower (#3233). * Fixed `summarise()` for empty data frames with zero columns (#3071). ## Major changes * `enexpr()`, `expr()`, `exprs()`, `sym()` and `syms()` are now exported. `sym()` and `syms()` construct symbols from strings or character vectors. The `expr()` variants are equivalent to `quo()`, `quos()` and `enquo()` but return simple expressions rather than quosures. They support quasiquotation. * dplyr now depends on the new tidyselect package to power `select()`, `rename()`, `pull()` and their variants (#2896). Consequently `select_vars()`, `select_var()` and `rename_vars()` are soft-deprecated and will start issuing warnings in a future version. Following the switch to tidyselect, `select()` and `rename()` fully support character vectors. You can now unquote variables like this: ``` vars <- c("disp", "cyl") select(mtcars, !! vars) select(mtcars, -(!! vars)) ``` Note that this only works in selecting functions because in other contexts strings and character vectors are ambiguous. For instance strings are a valid input in mutating operations and `mutate(df, "foo")` creates a new column by recycling "foo" to the number of rows. ## Minor changes * Support for raw vector columns in `arrange()`, `group_by()`, `mutate()`, `summarise()` and `..._join()` (minimal `raw` x `raw` support initially) (#1803). * `bind_cols()` handles unnamed list (#3402). * `bind_rows()` works around corrupt columns that have the object bit set while having no class attribute (#3349). * `combine()` returns `logical()` when all inputs are `NULL` (or when there are no inputs) (#3365, @zeehio). * `distinct()` now supports renaming columns (#3234). * Hybrid evaluation simplifies `dplyr::foo()` to `foo()` (#3309). Hybrid functions can now be masked by regular R functions to turn off hybrid evaluation (#3255). The hybrid evaluator finds functions from dplyr even if dplyr is not attached (#3456). * In `mutate()` it is now illegal to use `data.frame` in the rhs (#3298). * Support `!!!` in `recode_factor()` (#3390). * `row_number()` works on empty subsets (#3454). * `select()` and `vars()` now treat `NULL` as empty inputs (#3023). * Scoped select and rename functions (`select_all()`, `rename_if()` etc.) now work with grouped data frames, adapting the grouping as necessary (#2947, #3410). `group_by_at()` can group by an existing grouping variable (#3351). `arrange_at()` can use grouping variables (#3332). * `slice()` no longer enforce tibble classes when input is a simple `data.frame`, and ignores 0 (#3297, #3313). * `transmute()` no longer prints a message when including a group variable. ## Documentation * Improved documentation for `funs()` (#3094) and set operations (e.g. `union()`) (#3238, @edublancas). ## Error messages * Better error message if dbplyr is not installed when accessing database backends (#3225). * `arrange()` fails gracefully on `data.frame` columns (#3153). * Corrected error message when calling `cbind()` with an object of wrong length (#3085). * Add warning with explanation to `distinct()` if any of the selected columns are of type `list` (#3088, @foo-bar-baz-qux), or when used on unknown columns (#2867, @foo-bar-baz-qux). * Show clear error message for bad arguments to `funs()` (#3368). * Better error message in `..._join()` when joining data frames with duplicate or `NA` column names. Joining such data frames with a semi- or anti-join now gives a warning, which may be converted to an error in future versions (#3243, #3417). * Dedicated error message when trying to use columns of the `Interval` or `Period` classes (#2568). * Added an `.onDetach()` hook that allows for plyr to be loaded and attached without the warning message that says functions in dplyr will be masked, since dplyr is no longer attached (#3359, @jwnorman). ## Performance * `sample_n()` and `sample_frac()` on grouped data frame are now faster especially for those with large number of groups (#3193, @saurfang). ## Internal * Compute variable names for joins in R (#3430). * Bumped Rcpp dependency to 0.12.15 to avoid imperfect detection of `NA` values in hybrid evaluation fixed in RcppCore/Rcpp#790 (#2919). * Avoid cleaning the data mask, a temporary environment used to evaluate expressions. If the environment, in which e.g. a `mutate()` expression is evaluated, is preserved until after the operation, accessing variables from that environment now gives a warning but still returns `NULL` (#3318). # dplyr 0.7.4 * Fix recent Fedora and ASAN check errors (#3098). * Avoid dependency on Rcpp 0.12.10 (#3106). # dplyr 0.7.3 * Fixed protection error that occurred when creating a character column using grouped `mutate()` (#2971). * Fixed a rare problem with accessing variable values in `summarise()` when all groups have size one (#3050). * `distinct()` now throws an error when used on unknown columns (#2867, @foo-bar-baz-qux). * Fixed rare out-of-bounds memory write in `slice()` when negative indices beyond the number of rows were involved (#3073). * `select()`, `rename()` and `summarise()` no longer change the grouped vars of the original data (#3038). * `nth(default = var)`, `first(default = var)` and `last(default = var)` fall back to standard evaluation in a grouped operation instead of triggering an error (#3045). * `case_when()` now works if all LHS are atomic (#2909), or when LHS or RHS values are zero-length vectors (#3048). * `case_when()` accepts `NA` on the LHS (#2927). * Semi- and anti-joins now preserve the order of left-hand-side data frame (#3089). * Improved error message for invalid list arguments to `bind_rows()` (#3068). * Grouping by character vectors is now faster (#2204). * Fixed a crash that occurred when an unexpected input was supplied to the `call` argument of `order_by()` (#3065). # dplyr 0.7.2 * Move build-time vs. run-time checks out of `.onLoad()` and into `dr_dplyr()`. # dplyr 0.7.1 * Use new versions of bindrcpp and glue to avoid protection problems. Avoid wrapping arguments to internal error functions (#2877). Fix two protection mistakes found by rchk (#2868). * Fix C++ error that caused compilation to fail on mac cran (#2862) * Fix undefined behaviour in `between()`, where `NA_REAL` were assigned instead of `NA_LOGICAL`. (#2855, @zeehio) * `top_n()` now executes operations lazily for compatibility with database backends (#2848). * Reuse of new variables created in ungrouped `mutate()` possible again, regression introduced in dplyr 0.7.0 (#2869). * Quosured symbols do not prevent hybrid handling anymore. This should fix many performance issues introduced with tidyeval (#2822). # dplyr 0.7.0 ## New data, functions, and features * Five new datasets provide some interesting built-in datasets to demonstrate dplyr verbs (#2094): * `starwars` dataset about starwars characters; has list columns * `storms` has the trajectories of ~200 tropical storms * `band_members`, `band_instruments` and `band_instruments2` has some simple data to demonstrate joins. * New `add_count()` and `add_tally()` for adding an `n` column within groups (#2078, @dgrtwo). * `arrange()` for grouped data frames gains a `.by_group` argument so you can choose to sort by groups if you want to (defaults to `FALSE`) (#2318) * New `pull()` generic for extracting a single column either by name or position (either from the left or the right). Thanks to @paulponcet for the idea (#2054). This verb is powered with the new `select_var()` internal helper, which is exported as well. It is like `select_vars()` but returns a single variable. * `as_tibble()` is re-exported from tibble. This is the recommend way to create tibbles from existing data frames. `tbl_df()` has been softly deprecated. `tribble()` is now imported from tibble (#2336, @chrMongeau); this is now prefered to `frame_data()`. ## Deprecated and defunct * dplyr no longer messages that you need dtplyr to work with data.table (#2489). * Long deprecated `regroup()`, `mutate_each_q()` and `summarise_each_q()` functions have been removed. * Deprecated `failwith()`. I'm not even sure why it was here. * Soft-deprecated `mutate_each()` and `summarise_each()`, these functions print a message which will be changed to a warning in the next release. * The `.env` argument to `sample_n()` and `sample_frac()` is defunct, passing a value to this argument print a message which will be changed to a warning in the next release. ## Databases This version of dplyr includes some major changes to how database connections work. By and large, you should be able to continue using your existing dplyr database code without modification, but there are two big changes that you should be aware of: * Almost all database related code has been moved out of dplyr and into a new package, [dbplyr](http://github.com/hadley/dbplyr/). This makes dplyr simpler, and will make it easier to release fixes for bugs that only affect databases. `src_mysql()`, `src_postgres()`, and `src_sqlite()` will still live dplyr so your existing code continues to work. * It is no longer necessary to create a remote "src". Instead you can work directly with the database connection returned by DBI. This reflects the maturity of the DBI ecosystem. Thanks largely to the work of Kirill Muller (funded by the R Consortium) DBI backends are now much more consistent, comprehensive, and easier to use. That means that there's no longer a need for a layer in between you and DBI. You can continue to use `src_mysql()`, `src_postgres()`, and `src_sqlite()`, but I recommend a new style that makes the connection to DBI more clear: ```R library(dplyr) con <- DBI::dbConnect(RSQLite::SQLite(), ":memory:") DBI::dbWriteTable(con, "mtcars", mtcars) mtcars2 <- tbl(con, "mtcars") mtcars2 ``` This is particularly useful if you want to perform non-SELECT queries as you can do whatever you want with `DBI::dbGetQuery()` and `DBI::dbExecute()`. If you've implemented a database backend for dplyr, please read the [backend news](https://github.com/hadley/dbplyr/blob/master/NEWS.md#backends) to see what's changed from your perspective (not much). If you want to ensure your package works with both the current and previous version of dplyr, see `wrap_dbplyr_obj()` for helpers. ## UTF-8 * Internally, column names are always represented as character vectors, and not as language symbols, to avoid encoding problems on Windows (#1950, #2387, #2388). * Error messages and explanations of data frame inequality are now encoded in UTF-8, also on Windows (#2441). * Joins now always reencode character columns to UTF-8 if necessary. This gives a nice speedup, because now pointer comparison can be used instead of string comparison, but relies on a proper encoding tag for all strings (#2514). * Fixed problems when joining factor or character encodings with a mix of native and UTF-8 encoded values (#1885, #2118, #2271, #2451). * Fix `group_by()` for data frames that have UTF-8 encoded names (#2284, #2382). * New `group_vars()` generic that returns the grouping as character vector, to avoid the potentially lossy conversion to language symbols. The list returned by `group_by_prepare()` now has a new `group_names` component (#1950, #2384). ## Colwise functions * `rename()`, `select()`, `group_by()`, `filter()`, `arrange()` and `transmute()` now have scoped variants (verbs suffixed with `_if()`, `_at()` and `_all()`). Like `mutate_all()`, `summarise_if()`, etc, these variants apply an operation to a selection of variables. * The scoped verbs taking predicates (`mutate_if()`, `summarise_if()`, etc) now support S3 objects and lazy tables. S3 objects should implement methods for `length()`, `[[` and `tbl_vars()`. For lazy tables, the first 100 rows are collected and the predicate is applied on this subset of the data. This is robust for the common case of checking the type of a column (#2129). * Summarise and mutate colwise functions pass `...` on the the manipulation functions. * The performance of colwise verbs like `mutate_all()` is now back to where it was in `mutate_each()`. * `funs()` has better handling of namespaced functions (#2089). * Fix issue with `mutate_if()` and `summarise_if()` when a predicate function returns a vector of `FALSE` (#1989, #2009, #2011). ## Tidyeval dplyr has a new approach to non-standard evaluation (NSE) called tidyeval. It is described in detail in `vignette("programming")` but, in brief, gives you the ability to interpolate values in contexts where dplyr usually works with expressions: ```{r} my_var <- quo(homeworld) starwars %>% group_by(!!my_var) %>% summarise_at(vars(height:mass), mean, na.rm = TRUE) ``` This means that the underscored version of each main verb is no longer needed, and so these functions have been deprecated (but remain around for backward compatibility). * `order_by()`, `top_n()`, `sample_n()` and `sample_frac()` now use tidyeval to capture their arguments by expression. This makes it possible to use unquoting idioms (see `vignette("programming")`) and fixes scoping issues (#2297). * Most verbs taking dots now ignore the last argument if empty. This makes it easier to copy lines of code without having to worry about deleting trailing commas (#1039). * [API] The new `.data` and `.env` environments can be used inside all verbs that operate on data: `.data$column_name` accesses the column `column_name`, whereas `.env$var` accesses the external variable `var`. Columns or external variables named `.data` or `.env` are shadowed, use `.data$...` and/or `.env$...` to access them. (`.data` implements strict matching also for the `$` operator (#2591).) The `column()` and `global()` functions have been removed. They were never documented officially. Use the new `.data` and `.env` environments instead. * Expressions in verbs are now interpreted correctly in many cases that failed before (e.g., use of `$`, `case_when()`, nonstandard evaluation, ...). These expressions are now evaluated in a specially constructed temporary environment that retrieves column data on demand with the help of the `bindrcpp` package (#2190). This temporary environment poses restrictions on assignments using `<-` inside verbs. To prevent leaking of broken bindings, the temporary environment is cleared after the evaluation (#2435). ## Verbs ### Joins * [API] `xxx_join.tbl_df(na_matches = "never")` treats all `NA` values as different from each other (and from any other value), so that they never match. This corresponds to the behavior of joins for database sources, and of database joins in general. To match `NA` values, pass `na_matches = "na"` to the join verbs; this is only supported for data frames. The default is `na_matches = "na"`, kept for the sake of compatibility to v0.5.0. It can be tweaked by calling `pkgconfig::set_config("dplyr::na_matches", "na")` (#2033). * `common_by()` gets a better error message for unexpected inputs (#2091) * Fix groups when joining grouped data frames with duplicate columns (#2330, #2334, @davidkretch). * One of the two join suffixes can now be an empty string, dplyr no longer hangs (#2228, #2445). * Anti- and semi-joins warn if factor levels are inconsistent (#2741). * Warnings about join column inconsistencies now contain the column names (#2728). ### Select * For selecting variables, the first selector decides if it's an inclusive selection (i.e., the initial column list is empty), or an exclusive selection (i.e., the initial column list contains all columns). This means that `select(mtcars, contains("am"), contains("FOO"), contains("vs"))` now returns again both `am` and `vs` columns like in dplyr 0.4.3 (#2275, #2289, @r2evans). * Select helpers now throw an error if called when no variables have been set (#2452) * Helper functions in `select()` (and related verbs) are now evaluated in a context where column names do not exist (#2184). * `select()` (and the internal function `select_vars()`) now support column names in addition to column positions. As a result, expressions like `select(mtcars, "cyl")` are now allowed. ### Other * `recode()`, `case_when()` and `coalesce()` now support splicing of arguments with rlang's `!!!` operator. * `count()` now preserves the grouping of its input (#2021). * `distinct()` no longer duplicates variables (#2001). * Empty `distinct()` with a grouped data frame works the same way as an empty `distinct()` on an ungrouped data frame, namely it uses all variables (#2476). * `copy_to()` now returns it's output invisibly (since you're often just calling for the side-effect). * `filter()` and `lag()` throw informative error if used with ts objects (#2219) * `mutate()` recycles list columns of length 1 (#2171). * `mutate()` gives better error message when attempting to add a non-vector column (#2319), or attempting to remove a column with `NULL` (#2187, #2439). * `summarise()` now correctly evaluates newly created factors (#2217), and can create ordered factors (#2200). * Ungrouped `summarise()` uses summary variables correctly (#2404, #2453). * Grouped `summarise()` no longer converts character `NA` to empty strings (#1839). ## Combining and comparing * `all_equal()` now reports multiple problems as a character vector (#1819, #2442). * `all_equal()` checks that factor levels are equal (#2440, #2442). * `bind_rows()` and `bind_cols()` give an error for database tables (#2373). * `bind_rows()` works correctly with `NULL` arguments and an `.id` argument (#2056), and also for zero-column data frames (#2175). * Breaking change: `bind_rows()` and `combine()` are more strict when coercing. Logical values are no longer coerced to integer and numeric. Date, POSIXct and other integer or double-based classes are no longer coerced to integer or double as there is chance of attributes or information being lost (#2209, @zeehio). * `bind_cols()` now calls `tibble::repair_names()` to ensure that all names are unique (#2248). * `bind_cols()` handles empty argument list (#2048). * `bind_cols()` better handles `NULL` inputs (#2303, #2443). * `bind_rows()` explicitly rejects columns containing data frames (#2015, #2446). * `bind_rows()` and `bind_cols()` now accept vectors. They are treated as rows by the former and columns by the latter. Rows require inner names like `c(col1 = 1, col2 = 2)`, while columns require outer names: `col1 = c(1, 2)`. Lists are still treated as data frames but can be spliced explicitly with `!!!`, e.g. `bind_rows(!!! x)` (#1676). * `rbind_list()` and `rbind_all()` now call `.Deprecated()`, they will be removed in the next CRAN release. Please use `bind_rows()` instead. * `combine()` accepts `NA` values (#2203, @zeehio) * `combine()` and `bind_rows()` with character and factor types now always warn about the coercion to character (#2317, @zeehio) * `combine()` and `bind_rows()` accept `difftime` objects. * `mutate` coerces results from grouped dataframes accepting combinable data types (such as `integer` and `numeric`). (#1892, @zeehio) ## Vector functions * `%in%` gets new hybrid handler (#126). * `between()` returns NA if `left` or `right` is `NA` (fixes #2562). * `case_when()` supports `NA` values (#2000, @tjmahr). * `first()`, `last()`, and `nth()` have better default values for factor, Dates, POSIXct, and data frame inputs (#2029). * Fixed segmentation faults in hybrid evaluation of `first()`, `last()`, `nth()`, `lead()`, and `lag()`. These functions now always fall back to the R implementation if called with arguments that the hybrid evaluator cannot handle (#948, #1980). * `n_distinct()` gets larger hash tables given slightly better performance (#977). * `nth()` and `ntile()` are more careful about proper data types of their return values (#2306). * `ntile()` ignores `NA` when computing group membership (#2564). * `lag()` enforces integer `n` (#2162, @kevinushey). * hybrid `min()` and `max()` now always return a `numeric` and work correctly in edge cases (empty input, all `NA`, ...) (#2305, #2436). * `min_rank("string")` no longer segfaults in hybrid evaluation (#2279, #2444). * `recode()` can now recode a factor to other types (#2268) * `recode()` gains `.dots` argument to support passing replacements as list (#2110, @jlegewie). ## Other minor changes and bug fixes * Many error messages are more helpful by referring to a column name or a position in the argument list (#2448). * New `is_grouped_df()` alias to `is.grouped_df()`. * `tbl_vars()` now has a `group_vars` argument set to `TRUE` by default. If `FALSE`, group variables are not returned. * Fixed segmentation fault after calling `rename()` on an invalid grouped data frame (#2031). * `rename_vars()` gains a `strict` argument to control if an error is thrown when you try and rename a variable that doesn't exist. * Fixed undefined behavior for `slice()` on a zero-column data frame (#2490). * Fixed very rare case of false match during join (#2515). * Restricted workaround for `match()` to R 3.3.0. (#1858). * dplyr now warns on load when the version of R or Rcpp during installation is different to the currently installed version (#2514). * Fixed improper reuse of attributes when creating a list column in `summarise()` and perhaps `mutate()` (#2231). * `mutate()` and `summarise()` always strip the `names` attribute from new or updated columns, even for ungrouped operations (#1689). * Fixed rare error that could lead to a segmentation fault in `all_equal(ignore_col_order = FALSE)` (#2502). * The "dim" and "dimnames" attributes are always stripped when copying a vector (#1918, #2049). * `grouped_df` and `rowwise` are registered officially as S3 classes. This makes them easier to use with S4 (#2276, @joranE, #2789). * All operations that return tibbles now include the `"tbl"` class. This is important for correct printing with tibble 1.3.1 (#2789). * Makeflags uses PKG_CPPFLAGS for defining preprocessor macros. * astyle formatting for C++ code, tested but not changed as part of the tests (#2086, #2103). * Update RStudio project settings to install tests (#1952). * Using `Rcpp::interfaces()` to register C callable interfaces, and registering all native exported functions via `R_registerRoutines()` and `useDynLib(.registration = TRUE)` (#2146). * Formatting of grouped data frames now works by overriding the `tbl_sum()` generic instead of `print()`. This means that the output is more consistent with tibble, and that `format()` is now supported also for SQL sources (#2781). # dplyr 0.5.0 ## Breaking changes ### Existing functions * `arrange()` once again ignores grouping (#1206). * `distinct()` now only keeps the distinct variables. If you want to return all variables (using the first row for non-distinct values) use `.keep_all = TRUE` (#1110). For SQL sources, `.keep_all = FALSE` is implemented using `GROUP BY`, and `.keep_all = TRUE` raises an error (#1937, #1942, @krlmlr). (The default behaviour of using all variables when none are specified remains - this note only applies if you select some variables). * The select helper functions `starts_with()`, `ends_with()` etc are now real exported functions. This means that you'll need to import those functions if you're using from a package where dplyr is not attached. i.e. `dplyr::select(mtcars, starts_with("m"))` used to work, but now you'll need `dplyr::select(mtcars, dplyr::starts_with("m"))`. ### Deprecated and defunct functions * The long deprecated `chain()`, `chain_q()` and `%.%` have been removed. Please use `%>%` instead. * `id()` has been deprecated. Please use `group_indices()` instead (#808). * `rbind_all()` and `rbind_list()` are formally deprecated. Please use `bind_rows()` instead (#803). * Outdated benchmarking demos have been removed (#1487). * Code related to starting and signalling clusters has been moved out to [multidplyr](http://github.com/hadley/multidplyr). ## New functions * `coalesce()` finds the first non-missing value from a set of vectors. (#1666, thanks to @krlmlr for initial implementation). * `case_when()` is a general vectorised if + else if (#631). * `if_else()` is a vectorised if statement: it's a stricter (type-safe), faster, and more predictable version of `ifelse()`. In SQL it is translated to a `CASE` statement. * `na_if()` makes it easy to replace a certain value with an `NA` (#1707). In SQL it is translated to `NULL_IF`. * `near(x, y)` is a helper for `abs(x - y) < tol` (#1607). * `recode()` is vectorised equivalent to `switch()` (#1710). * `union_all()` method. Maps to `UNION ALL` for SQL sources, `bind_rows()` for data frames/tbl\_dfs, and `combine()` for vectors (#1045). * A new family of functions replace `summarise_each()` and `mutate_each()` (which will thus be deprecated in a future release). `summarise_all()` and `mutate_all()` apply a function to all columns while `summarise_at()` and `mutate_at()` operate on a subset of columns. These columuns are selected with either a character vector of columns names, a numeric vector of column positions, or a column specification with `select()` semantics generated by the new `columns()` helper. In addition, `summarise_if()` and `mutate_if()` take a predicate function or a logical vector (these verbs currently require local sources). All these functions can now take ordinary functions instead of a list of functions generated by `funs()` (though this is only useful for local sources). (#1845, @lionel-) * `select_if()` lets you select columns with a predicate function. Only compatible with local sources. (#497, #1569, @lionel-) ## Local backends ### dtplyr All data table related code has been separated out in to a new dtplyr package. This decouples the development of the data.table interface from the development of the dplyr package. If both data.table and dplyr are loaded, you'll get a message reminding you to load dtplyr. ### Tibble Functions related to the creation and coercion of `tbl_df`s, now live in their own package: [tibble](http://blog.rstudio.org/2016/03/24/tibble-1-0-0/). See `vignette("tibble")` for more details. * `$` and `[[` methods that never do partial matching (#1504), and throw an error if the variable does not exist. * `all_equal()` allows to compare data frames ignoring row and column order, and optionally ignoring minor differences in type (e.g. int vs. double) (#821). The test handles the case where the df has 0 columns (#1506). The test fails fails when convert is `FALSE` and types don't match (#1484). * `all_equal()` shows better error message when comparing raw values or when types are incompatible and `convert = TRUE` (#1820, @krlmlr). * `add_row()` makes it easy to add a new row to data frame (#1021) * `as_data_frame()` is now an S3 generic with methods for lists (the old `as_data_frame()`), data frames (trivial), and matrices (with efficient C++ implementation) (#876). It no longer strips subclasses. * The internals of `data_frame()` and `as_data_frame()` have been aligned, so `as_data_frame()` will now automatically recycle length-1 vectors. Both functions give more informative error messages if you attempting to create an invalid data frame. You can no longer create a data frame with duplicated names (#820). Both check for `POSIXlt` columns, and tell you to use `POSIXct` instead (#813). * `frame_data()` properly constructs rectangular tables (#1377, @kevinushey), and supports list-cols. * `glimpse()` is now a generic. The default method dispatches to `str()` (#1325). It now (invisibly) returns its first argument (#1570). * `lst()` and `lst_()` which create lists in the same way that `data_frame()` and `data_frame_()` create data frames (#1290). * `print.tbl_df()` is considerably faster if you have very wide data frames. It will now also only list the first 100 additional variables not already on screen - control this with the new `n_extra` parameter to `print()` (#1161). When printing a grouped data frame the number of groups is now printed with thousands separators (#1398). The type of list columns is correctly printed (#1379) * Package includes `setOldClass(c("tbl_df", "tbl", "data.frame"))` to help with S4 dispatch (#969). * `tbl_df` automatically generates column names (#1606). ### tbl_cube * new `as_data_frame.tbl_cube()` (#1563, @krlmlr). * `tbl_cube`s are now constructed correctly from data frames, duplicate dimension values are detected, missing dimension values are filled with `NA`. The construction from data frames now guesses the measure variables by default, and allows specification of dimension and/or measure variables (#1568, @krlmlr). * Swap order of `dim_names` and `met_name` arguments in `as.tbl_cube` (for `array`, `table` and `matrix`) for consistency with `tbl_cube` and `as.tbl_cube.data.frame`. Also, the `met_name` argument to `as.tbl_cube.table` now defaults to `"Freq"` for consistency with `as.data.frame.table` (@krlmlr, #1374). ## Remote backends * `as_data_frame()` on SQL sources now returns all rows (#1752, #1821, @krlmlr). * `compute()` gets new parameters `indexes` and `unique_indexes` that make it easier to add indexes (#1499, @krlmlr). * `db_explain()` gains a default method for DBIConnections (#1177). * The backend testing system has been improved. This lead to the removal of `temp_srcs()`. In the unlikely event that you were using this function, you can instead use `test_register_src()`, `test_load()`, and `test_frame()`. * You can now use `right_join()` and `full_join()` with remote tables (#1172). ### SQLite * `src_memdb()` is a session-local in-memory SQLite database. `memdb_frame()` works like `data_frame()`, but creates a new table in that database. * `src_sqlite()` now uses a stricter quoting character, `` ` ``, instead of `"`. SQLite "helpfully" will convert `"x"` into a string if there is no identifier called x in the current scope (#1426). * `src_sqlite()` throws errors if you try and use it with window functions (#907). ### SQL translation * `filter.tbl_sql()` now puts parens around each argument (#934). * Unary `-` is better translated (#1002). * `escape.POSIXt()` method makes it easier to use date times. The date is rendered in ISO 8601 format in UTC, which should work in most databases (#857). * `is.na()` gets a missing space (#1695). * `if`, `is.na()`, and `is.null()` get extra parens to make precendence more clear (#1695). * `pmin()` and `pmax()` are translated to `MIN()` and `MAX()` (#1711). * Window functions: * Work on ungrouped data (#1061). * Warning if order is not set on cumulative window functions. * Multiple partitions or ordering variables in windowed functions no longer generate extra parentheses, so should work for more databases (#1060) ### Internals This version includes an almost total rewrite of how dplyr verbs are translated into SQL. Previously, I used a rather ad-hoc approach, which tried to guess when a new subquery was needed. Unfortunately this approach was fraught with bugs, so in this version I've implemented a much richer internal data model. Now there is a three step process: 1. When applied to a `tbl_lazy`, each dplyr verb captures its inputs and stores in a `op` (short for operation) object. 2. `sql_build()` iterates through the operations building to build up an object that represents a SQL query. These objects are convenient for testing as they are lists, and are backend agnostics. 3. `sql_render()` iterates through the queries and generates the SQL, using generics (like `sql_select()`) that can vary based on the backend. In the short-term, this increased abstraction is likely to lead to some minor performance decreases, but the chance of dplyr generating correct SQL is much much higher. In the long-term, these abstractions will make it possible to write a query optimiser/compiler in dplyr, which would make it possible to generate much more succinct queries. If you have written a dplyr backend, you'll need to make some minor changes to your package: * `sql_join()` has been considerably simplified - it is now only responsible for generating the join query, not for generating the intermediate selects that rename the variable. Similarly for `sql_semi_join()`. If you've provided new methods in your backend, you'll need to rewrite. * `select_query()` gains a distinct argument which is used for generating queries for `distinct()`. It loses the `offset` argument which was never used (and hence never tested). * `src_translate_env()` has been replaced by `sql_translate_env()` which should have methods for the connection object. There were two other tweaks to the exported API, but these are less likely to affect anyone. * `translate_sql()` and `partial_eval()` got a new API: now use connection + variable names, rather than a `tbl`. This makes testing considerably easier. `translate_sql_q()` has been renamed to `translate_sql_()`. * Also note that the sql generation generics now have a default method, instead methods for DBIConnection and NULL. ## Minor improvements and bug fixes ### Single table verbs * Avoiding segfaults in presence of `raw` columns (#1803, #1817, @krlmlr). * `arrange()` fails gracefully on list columns (#1489) and matrices (#1870, #1945, @krlmlr). * `count()` now adds additional grouping variables, rather than overriding existing (#1703). `tally()` and `count()` can now count a variable called `n` (#1633). Weighted `count()`/`tally()` ignore `NA`s (#1145). * The progress bar in `do()` is now updated at most 20 times per second, avoiding uneccessary redraws (#1734, @mkuhn) * `distinct()` doesn't crash when given a 0-column data frame (#1437). * `filter()` throws an error if you supply an named arguments. This is usually a type: `filter(df, x = 1)` instead of `filter(df, x == 1)` (#1529). * `summarise()` correctly coerces factors with different levels (#1678), handles min/max of already summarised variable (#1622), and supports data frames as columns (#1425). * `select()` now informs you that it adds missing grouping variables (#1511). It works even if the grouping variable has a non-syntactic name (#1138). Negating a failed match (e.g. `select(mtcars, -contains("x"))`) returns all columns, instead of no columns (#1176) The `select()` helpers are now exported and have their own documentation (#1410). `one_of()` gives a useful error message if variables names are not found in data frame (#1407). * The naming behaviour of `summarise_each()` and `mutate_each()` has been tweaked so that you can force inclusion of both the function and the variable name: `summarise_each(mtcars, funs(mean = mean), everything())` (#442). * `mutate()` handles factors that are all `NA` (#1645), or have different levels in different groups (#1414). It disambiguates `NA` and `NaN` (#1448), and silently promotes groups that only contain `NA` (#1463). It deep copies data in list columns (#1643), and correctly fails on incompatible columns (#1641). `mutate()` on a grouped data no longer droups grouping attributes (#1120). `rowwise()` mutate gives expected results (#1381). * `one_of()` tolerates unknown variables in `vars`, but warns (#1848, @jennybc). * `print.grouped_df()` passes on `...` to `print()` (#1893). * `slice()` correctly handles grouped attributes (#1405). * `ungroup()` generic gains `...` (#922). ### Dual table verbs * `bind_cols()` matches the behaviour of `bind_rows()` and ignores `NULL` inputs (#1148). It also handles `POSIXct`s with integer base type (#1402). * `bind_rows()` handles 0-length named lists (#1515), promotes factors to characters (#1538), and warns when binding factor and character (#1485). bind_rows()` is more flexible in the way it can accept data frames, lists, list of data frames, and list of lists (#1389). * `bind_rows()` rejects `POSIXlt` columns (#1875, @krlmlr). * Both `bind_cols()` and `bind_rows()` infer classes and grouping information from the first data frame (#1692). * `rbind()` and `cbind()` get `grouped_df()` methods that make it harder to create corrupt data frames (#1385). You should still prefer `bind_rows()` and `bind_cols()`. * Joins now use correct class when joining on `POSIXct` columns (#1582, @joel23888), and consider time zones (#819). Joins handle a `by` that is empty (#1496), or has duplicates (#1192). Suffixes grow progressively to avoid creating repeated column names (#1460). Joins on string columns should be substantially faster (#1386). Extra attributes are ok if they are identical (#1636). Joins work correct when factor levels not equal (#1712, #1559). Anti- and semi-joins give correct result when by variable is a factor (#1571), but warn if factor levels are inconsistent (#2741). A clear error message is given for joins where an explicit `by` contains unavailable columns (#1928, #1932). Warnings about join column inconsistencies now contain the column names (#2728). * `inner_join()`, `left_join()`, `right_join()`, and `full_join()` gain a `suffix` argument which allows you to control what suffix duplicated variable names recieve (#1296). * Set operations (`intersect()`, `union()` etc) respect coercion rules (#799). `setdiff()` handles factors with `NA` levels (#1526). * There were a number of fixes to enable joining of data frames that don't have the same encoding of column names (#1513), including working around bug 16885 regarding `match()` in R 3.3.0 (#1806, #1810, @krlmlr). ### Vector functions * `combine()` silently drops `NULL` inputs (#1596). * Hybrid `cummean()` is more stable against floating point errors (#1387). * Hybrid `lead()` and `lag()` received a considerable overhaul. They are more careful about more complicated expressions (#1588), and falls back more readily to pure R evaluation (#1411). They behave correctly in `summarise()` (#1434). and handle default values for string columns. * Hybrid `min()` and `max()` handle empty sets (#1481). * `n_distinct()` uses multiple arguments for data frames (#1084), falls back to R evaluation when needed (#1657), reverting decision made in (#567). Passing no arguments gives an error (#1957, #1959, @krlmlr). * `nth()` now supports negative indices to select from end, e.g. `nth(x, -2)` selects the 2nd value from the end of `x` (#1584). * `top_n()` can now also select bottom `n` values by passing a negative value to `n` (#1008, #1352). * Hybrid evaluation leaves formulas untouched (#1447). # dplyr 0.4.3 ## Improved encoding support Until now, dplyr's support for non-UTF8 encodings has been rather shaky. This release brings a number of improvement to fix these problems: it's probably not perfect, but should be a lot better than the previously version. This includes fixes to `arrange()` (#1280), `bind_rows()` (#1265), `distinct()` (#1179), and joins (#1315). `print.tbl_df()` also recieved a fix for strings with invalid encodings (#851). ## Other minor improvements and bug fixes * `frame_data()` provides a means for constructing `data_frame`s using a simple row-wise language. (#1358, @kevinushey) * `all.equal()` no longer runs all outputs together (#1130). * `as_data_frame()` gives better error message with NA column names (#1101). * `[.tbl_df` is more careful about subsetting column names (#1245). * `arrange()` and `mutate()` work on empty data frames (#1142). * `arrange()`, `filter()`, `slice()`, and `summarise()` preserve data frame meta attributes (#1064). * `bind_rows()` and `bind_cols()` accept lists (#1104): during initial data cleaning you no longer need to convert lists to data frames, but can instead feed them to `bind_rows()` directly. * `bind_rows()` gains a `.id` argument. When supplied, it creates a new column that gives the name of each data frame (#1337, @lionel-). * `bind_rows()` respects the `ordered` attribute of factors (#1112), and does better at comparing `POSIXct`s (#1125). The `tz` attribute is ignored when determining if two `POSIXct` vectors are comparable. If the `tz` of all inputs is the same, it's used, otherwise its set to `UTC`. * `data_frame()` always produces a `tbl_df` (#1151, @kevinushey) * `filter(x, TRUE, TRUE)` now just returns `x` (#1210), it doesn't internally modify the first argument (#971), and it now works with rowwise data (#1099). It once again works with data tables (#906). * `glimpse()` also prints out the number of variables in addition to the number of observations (@ilarischeinin, #988). * Joins handles matrix columns better (#1230), and can join `Date` objects with heterogenous representations (some `Date`s are integers, while other are numeric). This also improves `all.equal()` (#1204). * Fixed `percent_rank()` and `cume_dist()` so that missing values no longer affect denominator (#1132). * `print.tbl_df()` now displays the class for all variables, not just those that don't fit on the screen (#1276). It also displays duplicated column names correctly (#1159). * `print.grouped_df()` now tells you how many groups there are. * `mutate()` can set to `NULL` the first column (used to segfault, #1329) and it better protects intermediary results (avoiding random segfaults, #1231). * `mutate()` on grouped data handles the special case where for the first few groups, the result consists of a `logical` vector with only `NA`. This can happen when the condition of an `ifelse` is an all `NA` logical vector (#958). * `mutate.rowwise_df()` handles factors (#886) and correctly handles 0-row inputs (#1300). * `n_distinct()` gains an `na_rm` argument (#1052). * The `Progress` bar used by `do()` now respects global option `dplyr.show_progress` (default is TRUE) so you can turn it off globally (@jimhester #1264, #1226). * `summarise()` handles expressions that returning heterogenous outputs, e.g. `median()`, which that sometimes returns an integer, and other times a numeric (#893). * `slice()` silently drops columns corresponding to an NA (#1235). * `ungroup.rowwise_df()` gives a `tbl_df` (#936). * More explicit duplicated column name error message (#996). * When "," is already being used as the decimal point (`getOption("OutDec")`), use "." as the thousands separator when printing out formatted numbers (@ilarischeinin, #988). ## Databases * `db_query_fields.SQLiteConnection` uses `build_sql` rather than `paste0` (#926, @NikNakk) * Improved handling of `log()` (#1330). * `n_distinct(x)` is translated to `COUNT(DISTINCT(x))` (@skparkes, #873). * `print(n = Inf)` now works for remote sources (#1310). ## Hybrid evaluation * Hybrid evaluation does not take place for objects with a class (#1237). * Improved `$` handling (#1134). * Simplified code for `lead()` and `lag()` and make sure they work properly on factors (#955). Both repsect the `default` argument (#915). * `mutate` can set to `NULL` the first column (used to segfault, #1329). * `filter` on grouped data handles indices correctly (#880). * `sum()` issues a warning about integer overflow (#1108). # dplyr 0.4.2 This is a minor release containing fixes for a number of crashes and issues identified by R CMD CHECK. There is one new "feature": dplyr no longer complains about unrecognised attributes, and instead just copies them over to the output. * `lag()` and `lead()` for grouped data were confused about indices and therefore produced wrong results (#925, #937). `lag()` once again overrides `lag()` instead of just the default method `lag.default()`. This is necesary due to changes in R CMD check. To use the lag function provided by another package, use `pkg::lag`. * Fixed a number of memory issues identified by valgrind. * Improved performance when working with large number of columns (#879). * Lists-cols that contain data frames now print a slightly nicer summary (#1147) * Set operations give more useful error message on incompatible data frames (#903). * `all.equal()` gives the correct result when `ignore_row_order` is `TRUE` (#1065) and `all.equal()` correctly handles character missing values (#1095). * `bind_cols()` always produces a `tbl_df` (#779). * `bind_rows()` gains a test for a form of data frame corruption (#1074). * `bind_rows()` and `summarise()` now handles complex columns (#933). * Workaround for using the constructor of `DataFrame` on an unprotected object (#998) * Improved performance when working with large number of columns (#879). # dplyr 0.4.1 * Don't assume that RPostgreSQL is available. # dplyr 0.4.0 ## New features * `add_rownames()` turns row names into an explicit variable (#639). * `as_data_frame()` efficiently coerces a list into a data frame (#749). * `bind_rows()` and `bind_cols()` efficiently bind a list of data frames by row or column. `combine()` applies the same coercion rules to vectors (it works like `c()` or `unlist()` but is consistent with the `bind_rows()` rules). * `right_join()` (include all rows in `y`, and matching rows in `x`) and `full_join()` (include all rows in `x` and `y`) complete the family of mutating joins (#96). * `group_indices()` computes a unique integer id for each group (#771). It can be called on a grouped_df without any arguments or on a data frame with same arguments as `group_by()`. ## New vignettes * `vignette("data_frames")` describes dplyr functions that make it easier and faster to create and coerce data frames. It subsumes the old `memory` vignette. * `vignette("two-table")` describes how two-table verbs work in dplyr. ## Minor improvements * `data_frame()` (and `as_data_frame()` & `tbl_df()`) now explicitly forbid columns that are data frames or matrices (#775). All columns must be either a 1d atomic vector or a 1d list. * `do()` uses lazyeval to correctly evaluate its arguments in the correct environment (#744), and new `do_()` is the SE equivalent of `do()` (#718). You can modify grouped data in place: this is probably a bad idea but it's sometimes convenient (#737). `do()` on grouped data tables now passes in all columns (not all columns except grouping vars) (#735, thanks to @kismsu). `do()` with database tables no longer potentially includes grouping variables twice (#673). Finally, `do()` gives more consistent outputs when there are no rows or no groups (#625). * `first()` and `last()` preserve factors, dates and times (#509). * Overhaul of single table verbs for data.table backend. They now all use a consistent (and simpler) code base. This ensures that (e.g.) `n()` now works in all verbs (#579). * In `*_join()`, you can now name only those variables that are different between the two tables, e.g. `inner_join(x, y, c("a", "b", "c" = "d"))` (#682). If non-join colums are the same, dplyr will add `.x` and `.y` suffixes to distinguish the source (#655). * `mutate()` handles complex vectors (#436) and forbids `POSIXlt` results (instead of crashing) (#670). * `select()` now implements a more sophisticated algorithm so if you're doing multiples includes and excludes with and without names, you're more likely to get what you expect (#644). You'll also get a better error message if you supply an input that doesn't resolve to an integer column position (#643). * Printing has recieved a number of small tweaks. All `print()` method methods invisibly return their input so you can interleave `print()` statements into a pipeline to see interim results. `print()` will column names of 0 row data frames (#652), and will never print more 20 rows (i.e. `options(dplyr.print_max)` is now 20), not 100 (#710). Row names are no never printed since no dplyr method is guaranteed to preserve them (#669). `glimpse()` prints the number of observations (#692) `type_sum()` gains a data frame method. * `summarise()` handles list output columns (#832) * `slice()` works for data tables (#717). Documentation clarifies that slice can't work with relational databases, and the examples show how to achieve the same results using `filter()` (#720). * dplyr now requires RSQLite >= 1.0. This shouldn't affect your code in any way (except that RSQLite now doesn't need to be attached) but does simplify the internals (#622). * Functions that need to combine multiple results into a single column (e.g. `join()`, `bind_rows()` and `summarise()`) are more careful about coercion. Joining factors with the same levels in the same order preserves the original levels (#675). Joining factors with non-identical levels generates a warning and coerces to character (#684). Joining a character to a factor (or vice versa) generates a warning and coerces to character. Avoid these warnings by ensuring your data is compatible before joining. `rbind_list()` will throw an error if you attempt to combine an integer and factor (#751). `rbind()`ing a column full of `NA`s is allowed and just collects the appropriate missing value for the column type being collected (#493). `summarise()` is more careful about `NA`, e.g. the decision on the result type will be delayed until the first non NA value is returned (#599). It will complain about loss of precision coercions, which can happen for expressions that return integers for some groups and a doubles for others (#599). * A number of functions gained new or improved hybrid handlers: `first()`, `last()`, `nth()` (#626), `lead()` & `lag()` (#683), `%in%` (#126). That means when you use these functions in a dplyr verb, we handle them in C++, rather than calling back to R, and hence improving performance. Hybrid `min_rank()` correctly handles `NaN` values (#726). Hybrid implementation of `nth()` falls back to R evaluation when `n` is not a length one integer or numeric, e.g. when it's an expression (#734). Hybrid `dense_rank()`, `min_rank()`, `cume_dist()`, `ntile()`, `row_number()` and `percent_rank()` now preserve NAs (#774) * `filter` returns its input when it has no rows or no columns (#782). * Join functions keep attributes (e.g. time zone information) from the left argument for `POSIXct` and `Date` objects (#819), and only only warn once about each incompatibility (#798). ## Bug fixes * `[.tbl_df` correctly computes row names for 0-column data frames, avoiding problems with xtable (#656). `[.grouped_df` will silently drop grouping if you don't include the grouping columns (#733). * `data_frame()` now acts correctly if the first argument is a vector to be recycled. (#680 thanks @jimhester) * `filter.data.table()` works if the table has a variable called "V1" (#615). * `*_join()` keeps columns in original order (#684). Joining a factor to a character vector doesn't segfault (#688). `*_join` functions can now deal with multiple encodings (#769), and correctly name results (#855). * `*_join.data.table()` works when data.table isn't attached (#786). * `group_by()` on a data table preserves original order of the rows (#623). `group_by()` supports variables with more than 39 characters thanks to a fix in lazyeval (#705). It gives meaninful error message when a variable is not found in the data frame (#716). * `grouped_df()` requires `vars` to be a list of symbols (#665). * `min(.,na.rm = TRUE)` works with `Date`s built on numeric vectors (#755). * `rename_()` generic gets missing `.dots` argument (#708). * `row_number()`, `min_rank()`, `percent_rank()`, `dense_rank()`, `ntile()` and `cume_dist()` handle data frames with 0 rows (#762). They all preserve missing values (#774). `row_number()` doesn't segfault when giving an external variable with the wrong number of variables (#781). * `group_indices` handles the edge case when there are no variables (#867). * Removed bogus `NAs introduced by coercion to integer range` on 32-bit Windows (#2708). # dplyr 0.3.0.1 * Fixed problem with test script on Windows. # dplyr 0.3 ## New functions * `between()` vector function efficiently determines if numeric values fall in a range, and is translated to special form for SQL (#503). * `count()` makes it even easier to do (weighted) counts (#358). * `data_frame()` by @kevinushey is a nicer way of creating data frames. It never coerces column types (no more `stringsAsFactors = FALSE`!), never munges column names, and never adds row names. You can use previously defined columns to compute new columns (#376). * `distinct()` returns distinct (unique) rows of a tbl (#97). Supply additional variables to return the first row for each unique combination of variables. * Set operations, `intersect()`, `union()` and `setdiff()` now have methods for data frames, data tables and SQL database tables (#93). They pass their arguments down to the base functions, which will ensure they raise errors if you pass in two many arguments. * Joins (e.g. `left_join()`, `inner_join()`, `semi_join()`, `anti_join()`) now allow you to join on different variables in `x` and `y` tables by supplying a named vector to `by`. For example, `by = c("a" = "b")` joins `x.a` to `y.b`. * `n_groups()` function tells you how many groups in a tbl. It returns 1 for ungrouped data. (#477) * `transmute()` works like `mutate()` but drops all variables that you didn't explicitly refer to (#302). * `rename()` makes it easy to rename variables - it works similarly to `select()` but it preserves columns that you didn't otherwise touch. * `slice()` allows you to selecting rows by position (#226). It includes positive integers, drops negative integers and you can use expression like `n()`. ## Programming with dplyr (non-standard evaluation) * You can now program with dplyr - every function that does non-standard evaluation (NSE) has a standard evaluation (SE) version ending in `_`. This is powered by the new lazyeval package which provides all the tools needed to implement NSE consistently and correctly. * See `vignette("nse")` for full details. * `regroup()` is deprecated. Please use the more flexible `group_by_()` instead. * `summarise_each_q()` and `mutate_each_q()` are deprecated. Please use `summarise_each_()` and `mutate_each_()` instead. * `funs_q` has been replaced with `funs_`. ## Removed and deprecated features * `%.%` has been deprecated: please use `%>%` instead. `chain()` is defunct. (#518) * `filter.numeric()` removed. Need to figure out how to reimplement with new lazy eval system. * The `Progress` refclass is no longer exported to avoid conflicts with shiny. Instead use `progress_estimated()` (#535). * `src_monetdb()` is now implemented in MonetDB.R, not dplyr. * `show_sql()` and `explain_sql()` and matching global options `dplyr.show_sql` and `dplyr.explain_sql` have been removed. Instead use `show_query()` and `explain()`. ## Minor improvements and bug fixes * Main verbs now have individual documentation pages (#519). * `%>%` is simply re-exported from magrittr, instead of creating a local copy (#496, thanks to @jimhester) * Examples now use `nycflights13` instead of `hflights` because it the variables have better names and there are a few interlinked tables (#562). `Lahman` and `nycflights13` are (once again) suggested packages. This means many examples will not work unless you explicitly install them with `install.packages(c("Lahman", "nycflights13"))` (#508). dplyr now depends on Lahman 3.0.1. A number of examples have been updated to reflect modified field names (#586). * `do()` now displays the progress bar only when used in interactive prompts and not when knitting (#428, @jimhester). * `glimpse()` now prints a trailing new line (#590). * `group_by()` has more consistent behaviour when grouping by constants: it creates a new column with that value (#410). It renames grouping variables (#410). The first argument is now `.data` so you can create new groups with name x (#534). * Now instead of overriding `lag()`, dplyr overrides `lag.default()`, which should avoid clobbering lag methods added by other packages. (#277). * `mutate(data, a = NULL)` removes the variable `a` from the returned dataset (#462). * `trunc_mat()` and hence `print.tbl_df()` and friends gets a `width` argument to control the deafult output width. Set `options(dplyr.width = Inf)` to always show all columns (#589). * `select()` gains `one_of()` selector: this allows you to select variables provided by a character vector (#396). It fails immediately if you give an empty pattern to `starts_with()`, `ends_with()`, `contains()` or `matches()` (#481, @leondutoit). Fixed buglet in `select()` so that you can now create variables called `val` (#564). * Switched from RC to R6. * `tally()` and `top_n()` work consistently: neither accidentally evaluates the the `wt` param. (#426, @mnel) * `rename` handles grouped data (#640). ## Minor improvements and bug fixes by backend ### Databases * Correct SQL generation for `paste()` when used with the collapse parameter targeting a Postgres database. (@rbdixon, #1357) * The db backend system has been completely overhauled in order to make it possible to add backends in other packages, and to support a much wider range of databases. See `vignette("new-sql-backend")` for instruction on how to create your own (#568). * `src_mysql()` gains a method for `explain()`. * When `mutate()` creates a new variable that uses a window function, automatically wrap the result in a subquery (#484). * Correct SQL generation for `first()` and `last()` (#531). * `order_by()` now works in conjunction with window functions in databases that support them. ### Data frames/`tbl_df` * All verbs now understand how to work with `difftime()` (#390) and `AsIs` (#453) objects. They all check that colnames are unique (#483), and are more robust when columns are not present (#348, #569, #600). * Hybrid evaluation bugs fixed: * Call substitution stopped too early when a sub expression contained a `$` (#502). * Handle `::` and `:::` (#412). * `cumany()` and `cumall()` properly handle `NA` (#408). * `nth()` now correctly preserve the class when using dates, times and factors (#509). * no longer substitutes within `order_by()` because `order_by()` needs to do its own NSE (#169). * `[.tbl_df` always returns a tbl_df (i.e. `drop = FALSE` is the default) (#587, #610). `[.grouped_df` preserves important output attributes (#398). * `arrange()` keeps the grouping structure of grouped data (#491, #605), and preserves input classes (#563). * `contains()` accidentally matched regular expressions, now it passes `fixed = TRUE` to `grep()` (#608). * `filter()` asserts all variables are white listed (#566). * `mutate()` makes a `rowwise_df` when given a `rowwise_df` (#463). * `rbind_all()` creates `tbl_df` objects instead of raw `data.frame`s. * If `select()` doesn't match any variables, it returns a 0-column data frame, instead of the original (#498). It no longer fails when if some columns are not named (#492) * `sample_n()` and `sample_frac()` methods for data.frames exported. (#405, @alyst) * A grouped data frame may have 0 groups (#486). Grouped df objects gain some basic validity checking, which should prevent some crashes related to corrupt `grouped_df` objects made by `rbind()` (#606). * More coherence when joining columns of compatible but different types, e.g. when joining a character vector and a factor (#455), or a numeric and integer (#450) * `mutate()` works for on zero-row grouped data frame, and with list columns (#555). * `LazySubset` was confused about input data size (#452). * Internal `n_distinct()` is stricter about it's inputs: it requires one symbol which must be from the data frame (#567). * `rbind_*()` handle data frames with 0 rows (#597). They fill character vector columns with `NA` instead of blanks (#595). They work with list columns (#463). * Improved handling of encoding for column names (#636). * Improved handling of hybrid evaluation re $ and @ (#645). ### Data tables * Fix major omission in `tbl_dt()` and `grouped_dt()` methods - I was accidentally doing a deep copy on every result :( * `summarise()` and `group_by()` now retain over-allocation when working with data.tables (#475, @arunsrinivasan). * joining two data.tables now correctly dispatches to data table methods, and result is a data table (#470) ### Cubes * `summarise.tbl_cube()` works with single grouping variable (#480). # dplyr 0.2 ## Piping dplyr now imports `%>%` from magrittr (#330). I recommend that you use this instead of `%.%` because it is easier to type (since you can hold down the shift key) and is more flexible. With you `%>%`, you can control which argument on the RHS recieves the LHS by using the pronoun `.`. This makes `%>%` more useful with base R functions because they don't always take the data frame as the first argument. For example you could pipe `mtcars` to `xtabs()` with: mtcars %>% xtabs( ~ cyl + vs, data = .) Thanks to @smbache for the excellent magrittr package. dplyr only provides `%>%` from magrittr, but it contains many other useful functions. To use them, load `magrittr` explicitly: `library(magrittr)`. For more details, see `vignette("magrittr")`. `%.%` will be deprecated in a future version of dplyr, but it won't happen for a while. I've also deprecated `chain()` to encourage a single style of dplyr usage: please use `%>%` instead. ## Do `do()` has been completely overhauled. There are now two ways to use it, either with multiple named arguments or a single unnamed arguments. `group_by()` + `do()` is equivalent to `plyr::dlply`, except it always returns a data frame. If you use named arguments, each argument becomes a list-variable in the output. A list-variable can contain any arbitrary R object so it's particularly well suited for storing models. library(dplyr) models <- mtcars %>% group_by(cyl) %>% do(lm = lm(mpg ~ wt, data = .)) models %>% summarise(rsq = summary(lm)$r.squared) If you use an unnamed argument, the result should be a data frame. This allows you to apply arbitrary functions to each group. mtcars %>% group_by(cyl) %>% do(head(., 1)) Note the use of the `.` pronoun to refer to the data in the current group. `do()` also has an automatic progress bar. It appears if the computation takes longer than 5 seconds and lets you know (approximately) how much longer the job will take to complete. ## New verbs dplyr 0.2 adds three new verbs: * `glimpse()` makes it possible to see all the columns in a tbl, displaying as much data for each variable as can be fit on a single line. * `sample_n()` randomly samples a fixed number of rows from a tbl; `sample_frac()` randomly samples a fixed fraction of rows. Only works for local data frames and data tables (#202). * `summarise_each()` and `mutate_each()` make it easy to apply one or more functions to multiple columns in a tbl (#178). ## Minor improvements * If you load plyr after dplyr, you'll get a message suggesting that you load plyr first (#347). * `as.tbl_cube()` gains a method for matrices (#359, @paulstaab) * `compute()` gains `temporary` argument so you can control whether the results are temporary or permanent (#382, @cpsievert) * `group_by()` now defaults to `add = FALSE` so that it sets the grouping variables rather than adding to the existing list. I think this is how most people expected `group_by` to work anyway, so it's unlikely to cause problems (#385). * Support for [MonetDB](http://www.monetdb.org) tables with `src_monetdb()` (#8, thanks to @hannesmuehleisen). * New vignettes: * `memory` vignette which discusses how dplyr minimises memory usage for local data frames (#198). * `new-sql-backend` vignette which discusses how to add a new SQL backend/source to dplyr. * `changes()` output more clearly distinguishes which columns were added or deleted. * `explain()` is now generic. * dplyr is more careful when setting the keys of data tables, so it never accidentally modifies an object that it doesn't own. It also avoids unnecessary key setting which negatively affected performance. (#193, #255). * `print()` methods for `tbl_df`, `tbl_dt` and `tbl_sql` gain `n` argument to control the number of rows printed (#362). They also works better when you have columns containing lists of complex objects. * `row_number()` can be called without arguments, in which case it returns the same as `1:n()` (#303). * `"comment"` attribute is allowed (white listed) as well as names (#346). * hybrid versions of `min`, `max`, `mean`, `var`, `sd` and `sum` handle the `na.rm` argument (#168). This should yield substantial performance improvements for those functions. * Special case for call to `arrange()` on a grouped data frame with no arguments. (#369) ## Bug fixes * Code adapted to Rcpp > 0.11.1 * internal `DataDots` class protects against missing variables in verbs (#314), including the case where `...` is missing. (#338) * `all.equal.data.frame` from base is no longer bypassed. we now have `all.equal.tbl_df` and `all.equal.tbl_dt` methods (#332). * `arrange()` correctly handles NA in numeric vectors (#331) and 0 row data frames (#289). * `copy_to.src_mysql()` now works on windows (#323) * `*_join()` doesn't reorder column names (#324). * `rbind_all()` is stricter and only accepts list of data frames (#288) * `rbind_*` propagates time zone information for `POSIXct` columns (#298). * `rbind_*` is less strict about type promotion. The numeric `Collecter` allows collection of integer and logical vectors. The integer `Collecter` also collects logical values (#321). * internal `sum` correctly handles integer (under/over)flow (#308). * `summarise()` checks consistency of outputs (#300) and drops `names` attribute of output columns (#357). * join functions throw error instead of crashing when there are no common variables between the data frames, and also give a better error message when only one data frame has a by variable (#371). * `top_n()` returns `n` rows instead of `n - 1` (@leondutoit, #367). * SQL translation always evaluates subsetting operators (`$`, `[`, `[[`) locally. (#318). * `select()` now renames variables in remote sql tbls (#317) and implicitly adds grouping variables (#170). * internal `grouped_df_impl` function errors if there are no variables to group by (#398). * `n_distinct` did not treat NA correctly in the numeric case #384. * Some compiler warnings triggered by -Wall or -pedantic have been eliminated. * `group_by` only creates one group for NA (#401). * Hybrid evaluator did not evaluate expression in correct environment (#403). # dplyr 0.1.3 ## Bug fixes * `select()` actually renames columns in a data table (#284). * `rbind_all()` and `rbind_list()` now handle missing values in factors (#279). * SQL joins now work better if names duplicated in both x and y tables (#310). * Builds against Rcpp 0.11.1 * `select()` correctly works with the vars attribute (#309). * Internal code is stricter when deciding if a data frame is grouped (#308): this avoids a number of situations which previously causedd . * More data frame joins work with missing values in keys (#306). # dplyr 0.1.2 ## New features * `select()` is substantially more powerful. You can use named arguments to rename existing variables, and new functions `starts_with()`, `ends_with()`, `contains()`, `matches()` and `num_range()` to select variables based on their names. It now also makes a shallow copy, substantially reducing its memory impact (#158, #172, #192, #232). * `summarize()` added as alias for `summarise()` for people from countries that don't don't spell things correctly ;) (#245) ## Bug fixes * `filter()` now fails when given anything other than a logical vector, and correctly handles missing values (#249). `filter.numeric()` proxies `stats::filter()` so you can continue to use `filter()` function with numeric inputs (#264). * `summarise()` correctly uses newly created variables (#259). * `mutate()` correctly propagates attributes (#265) and `mutate.data.frame()` correctly mutates the same variable repeatedly (#243). * `lead()` and `lag()` preserve attributes, so they now work with dates, times and factors (#166). * `n()` never accepts arguments (#223). * `row_number()` gives correct results (#227). * `rbind_all()` silently ignores data frames with 0 rows or 0 columns (#274). * `group_by()` orders the result (#242). It also checks that columns are of supported types (#233, #276). * The hybrid evaluator did not handle some expressions correctly, for example in `if(n() > 5) 1 else 2` the subexpression `n()` was not substituted correctly. It also correctly processes `$` (#278). * `arrange()` checks that all columns are of supported types (#266). It also handles list columns (#282). * Working towards Solaris compatibility. * Benchmarking vignette temporarily disabled due to microbenchmark problems reported by BDR. # dplyr 0.1.1 ## Improvements * new `location()` and `changes()` functions which provide more information about how data frames are stored in memory so that you can see what gets copied. * renamed `explain_tbl()` to `explain()` (#182). * `tally()` gains `sort` argument to sort output so highest counts come first (#173). * `ungroup.grouped_df()`, `tbl_df()`, `as.data.frame.tbl_df()` now only make shallow copies of their inputs (#191). * The `benchmark-baseball` vignette now contains fairer (including grouping times) comparisons with `data.table`. (#222) ## Bug fixes * `filter()` (#221) and `summarise()` (#194) correctly propagate attributes. * `summarise()` throws an error when asked to summarise an unknown variable instead of crashing (#208). * `group_by()` handles factors with missing values (#183). * `filter()` handles scalar results (#217) and better handles scoping, e.g. `filter(., variable)` where `variable` is defined in the function that calls `filter`. It also handles `T` and `F` as aliases to `TRUE` and `FALSE` if there are no `T` or `F` variables in the data or in the scope. * `select.grouped_df` fails when the grouping variables are not included in the selected variables (#170) * `all.equal.data.frame()` handles a corner case where the data frame has `NULL` names (#217) * `mutate()` gives informative error message on unsupported types (#179) * dplyr source package no longer includes pandas benchmark, reducing download size from 2.8 MB to 0.5 MB. dplyr/MD50000644000176200001440000006244513615060710011726 0ustar liggesusersa1a584fb7e783d797a22166d65666b86 *DESCRIPTION c7180788a8ec3035d54fc733f8939ade *LICENSE a092fa9ba553fd69cd17269bf6e806da *NAMESPACE 5c1790a9e1035f33163d6f6703d8eb50 *NEWS.md ae53055e23b26545fe4807bfed356246 *R/RcppExports.R 385c938e7ddaf4321adf4ee195f23f64 *R/all-equal.r 40d48bf1090b5a00ef4164c093a439ad *R/bench-compare.r 1f12f8b0dc718ffd7ddb1d89e0783d58 *R/bind.r 6805231ff58da2ae7845e27e80b734c2 *R/case_when.R 1021383a9a9e0201d7c21ae84967090a *R/coalesce.R de8225f024b269206363b32c59f4c1dc *R/colwise-arrange.R 19bf2e2bcf2e82aecf3f234289f44ec9 *R/colwise-distinct.R fe589a95f3bed022d62e1ae855217d44 *R/colwise-filter.R 6c9f860fab2fcec58d1849ac3ae7c1e5 *R/colwise-group-by.R 6e31ee57539735fe5772d9265cbb6e10 *R/colwise-mutate.R 12732d441599a40c6cd0d4e8ff965ebc *R/colwise-select.R 511e6b383ee19fb8cbdfd96eda6e4fc3 *R/colwise.R ee44784be10c1bcd3d8c87a5c0148d37 *R/compat-dbplyr.R 4e2534cf903b0aa7d817bb6d999304b9 *R/compat-future-group_by.R 2486707bbf68a9564c9b782e753c6699 *R/compat-lazyeval.R 5d46ce35ae41346df357a027b0837b68 *R/compat-lifecycle.R 452419a67c0fe93926672ef0c9bbf6cc *R/compat-name-repair.R 7a8dcd7f4d7f6b0361202f08128acb0d *R/compat-purrr.R dc4ec82504fd1f99c5de95eb3fcfcf41 *R/compute-collect.r 84786121e817962f2bb7bc069b4626f1 *R/context.R 1d3ba34ddd4ca746c6c5d3cb567c3b8b *R/copy-to.r 8078e5336a770e8443cdd7cf1873bc4e *R/count-tally.R 69ad54c9e8ff6c60be3239e99ceb1d9f *R/data-bands.R a08ae483d3ebcd598d3b457c77415561 *R/data-nasa.r c11f9a6ce16ea9d659aa93e36f133a42 *R/data-starwars.R 89e5bdb4b68a8fe03836bd4623b251e5 *R/data-storms.R 3c1aaab366538dd5afcb9d9f75619d23 *R/dataframe.R 15ed50b9e7d6f0db6881250facc997cf *R/dbplyr.R 4a41a291a9396a2e2692a05eb8a08982 *R/desc.r bba63005146a2b0c750b1a03aad7bced *R/distinct.R 9db8f28781ed81c4c5c9e2f29a6c6079 *R/do.r 2a0327b403800767638e8f6c924cb482 *R/dplyr.r ce0d3e95149be325fb2338305b748d92 *R/dr.R 8da194a0ef37067312e78cc06cae6787 *R/error.R 64db247d9d02897dfa0770acbe43a9b3 *R/explain.r 55f7f1e4983897a6a1823e06b1931921 *R/failwith.r f9919f1d27730f70376959d60ba419e0 *R/funs-predicates.R 1d7f51fd3599d60e0e0075dfc585b623 *R/funs.R 09c90a443871dda38c0aab64ecc7c24e *R/group-by.r c400220cbf4105306bd6ba53c8367bb2 *R/group-indices.R 96284b909c3e0531a0b35d37ab335968 *R/group-size.r 7cfd207c81026679a5f5799fe918b929 *R/group_data.R 3f4f3be0eea029d529f6f79f5c7715a1 *R/group_keys.R 824c8f66faaa7b38b5dafef2e7d510a0 *R/group_map.R 75cc1733949cde872025afe0a57ce11b *R/group_nest.R 9c5588ba3083c18c45e30bdc416196b2 *R/group_split.R cee98dd55e0ffc1090e24520cb1f0acd *R/group_trim.R 5d9947c0cf1d4088652fe7b51438cbca *R/grouped-df.r 88a3bc6140855aaeb4a215cc6ba0b535 *R/hybrid.R ddab701f521a5f1537d0c6d5b99347ac *R/id.r 8b8723e805875439fc9d369ad72827b3 *R/if_else.R cbbb63ead2d57c3f54c79af335b67a46 *R/inline.r 868eb09fc81ec74a83762aae2bc19c18 *R/join-vars.R 94f3a46a70d65ae30f816f2e94c71da9 *R/join.r e863ae47fc6114cfa73a563001f55288 *R/lead-lag.R 74a23d9b18ff1affcc9db32e58152d28 *R/lengths.R 75cfc3074889bddeaa6e526370c1d55c *R/location.R 98d9f6e7e9e80b7278938b0c41cc761d *R/manip.r 19151d6b1702d5140d5beca1c3b5a538 *R/match-vars.R 95d9d2fc77a3bfff6713dfe58e1ef85d *R/na_if.R 9f92869c84547da11884ad5523fc4697 *R/near.R 3c76c37d9fb4f6f094a75319aaeddae8 *R/nth-value.R 3583da4aecb96d78158ba8b9ae088ebb *R/order-by.R 8f1738d2972fa729df8a4307b1bef343 *R/progress.R 1a3ce68627dbedd646cc2cceb7073150 *R/pull.R 86475a1ce25ce35c05918cf8c41c66c5 *R/rank.R 5ed26768afdf407f8aceb4dd0df3f4a7 *R/rbind.R 90421fe195ca189258226a8432b0195f *R/recode.R e53aeb79a0d711ca52f32369e6b4f9b1 *R/reexport-tibble.r 5950de33660c3457a27b43dfd3c9ed90 *R/reexport-tidyselect.R 681887ec90e6e8182c755a9d5cce2bd7 *R/rowwise.r 61a475c71469627ad92f24910549f0fa *R/sample.R c8cff197ad1a21702fc738897ba73688 *R/sets.r 65b646c2d9dc319f8e1367ad7fb7ce0a *R/src-local.r 4944ea83dd1f1f8c7ddbcda96cbfe354 *R/src.r ee54aeb7ac8f03e4776b46bd18dd32e9 *R/src_dbi.R c65aacaeee2c5b2c0d86770f25d4231a *R/tbl-cube.r 25956292f75defbe001aee87400d90e4 *R/tbl-df.r bf4e2442cb0f9f0d799a9c84c10756c4 *R/tbl.r 227955a7bdc0bd1be2f001a0e27a420e *R/top-n.R 76d10c70d94a48bb5cf644707dee557a *R/ts.R 4172520627229c482862cce661e7d892 *R/utils-bindings.R b1a4e9f9be53c7141bcc0a28be2d58ae *R/utils-expr.R ea34ae9a8cebbf7b20a18dc884b43cef *R/utils-format.r e871a60aa0c5e04a0307c9115fd56797 *R/utils-replace-with.R 4ce6b95fdcca2b71ae4d621476de742c *R/utils-tidy-eval.R 042cb4810af703d3bdc9c7ebb14deb4b *R/utils.r 973f9efc20f25b9de77e443d0f719b01 *R/zzz.r 8756ff2dd938dea3a2774637028a1263 *README.md ea07e3ee174d59e65bd7ca8784207fd6 *build/dplyr.pdf 5945f0b7600bac7110347d7d20ed445f *build/vignette.rds a79561c8013e7a7f3c23d509f4918bf8 *data/band_instruments.rda 3aa4b1478fc31219480e88c876c3aeed *data/band_instruments2.rda 4d44ad5e4198daccbd4227dca895750b *data/band_members.rda db40a0145d2a88069865e7f18d3dcf1f *data/nasa.rda d23ee77269003009efa2b7a5fd95e84d *data/starwars.rda beee782d83b4bd711c01658781fbf643 *data/storms.rda 64b4162c11f3b7cca450f39a380f9b2f *inst/doc/compatibility.R b6ef692a53b1730f572fc4bb24bcebdf *inst/doc/compatibility.Rmd 54dfa00c9c216b2356ae3d183365a945 *inst/doc/compatibility.html 517cadf4db98fab1155e5ee7d9f6b5da *inst/doc/dplyr.R 9b47681a9d447e5d1953702b91e0071d *inst/doc/dplyr.Rmd 5a1dce7fd83393aa71166de587f9aede *inst/doc/dplyr.html 4bd86cb23a0b15708c63789a0c488da4 *inst/doc/programming.R 4c4c847727bf145d7fecbd0628cdb4c0 *inst/doc/programming.Rmd ceb389863716eba6e15d1da2c941ed3f *inst/doc/programming.html 770dd016e1e928d4a7db5f04ea6da15d *inst/doc/two-table.R 88f2cd45baee6686ddcc8d42e11e87d2 *inst/doc/two-table.Rmd eebce97ef8e51d6f3855f4597d802ca2 *inst/doc/two-table.html 77eb825ba25548dff1d42dc4b43a6d58 *inst/doc/window-functions.R 3ec1d9c26f39f6396fdedb8abb763f85 *inst/doc/window-functions.Rmd 1d76b9d9d082421f3875c95b85eaf508 *inst/doc/window-functions.html d29bc330bd10ca2769ea6168dca26ede *inst/include/dplyr.h 050ebb37dba540317e105fb77f76eec1 *inst/include/dplyr/Collecter.h 12e8a314c17a341b1e7fcd4bc4ced079 *inst/include/dplyr/NamedListAccumulator.h 8dd33a54b3436c5fc5bbd066a601db26 *inst/include/dplyr/allow_list.h bc2d1d5017f6aa294157a229d0f8e3db *inst/include/dplyr/checks.h 968c72563fe150a4903095b32b3321ab *inst/include/dplyr/config.h 4ffac3fbd643157a33b3d734a7d91b3d *inst/include/dplyr/data/DataMask.h cfb0813cff1f3090c8f795db2141b545 *inst/include/dplyr/data/GroupedDataFrame.h 74d0bf3fcde5a511d909ac62f832d2e5 *inst/include/dplyr/data/NaturalDataFrame.h 906b304ae959ee4f3bfe94ed89364bc7 *inst/include/dplyr/data/RowwiseDataFrame.h 42d1b01ea6d533ff94a5ba40278591fa *inst/include/dplyr/dplyr.h cfbb198ff309921d371a0b000a5cabc5 *inst/include/dplyr/hybrid/Column.h c59cd6105d6d21677a0dc4fa95fb6bde *inst/include/dplyr/hybrid/Dispatch.h f79806ae79f252679633d7e2d79602de *inst/include/dplyr/hybrid/Expression.h ac18039443b87b6771ee39a36d0adf0b *inst/include/dplyr/hybrid/HybridVectorScalarResult.h 0a8c0263166f2c4af85b8e2ad4e8fb46 *inst/include/dplyr/hybrid/HybridVectorSummaryRecycleResult.h 19d5e0b7fa274ac7916d74233d943605 *inst/include/dplyr/hybrid/HybridVectorVectorResult.h 57024fac590dae7b935d230be9d668a6 *inst/include/dplyr/hybrid/hybrid.h b963cda1657c6945d45dad19ff8502ba *inst/include/dplyr/hybrid/scalar_result/first_last.h 3ea9a9c8c6db8deb455ec2a30df4e541 *inst/include/dplyr/hybrid/scalar_result/group_indices.h 3d5babd37964346552ff801270fd1917 *inst/include/dplyr/hybrid/scalar_result/mean_sd_var.h b720311c8cd0cc991566bfcde1920a64 *inst/include/dplyr/hybrid/scalar_result/min_max.h e0706ebc04701dd6ca82864f86722e36 *inst/include/dplyr/hybrid/scalar_result/n.h d1ba74435b5b1f065690e2d019164769 *inst/include/dplyr/hybrid/scalar_result/n_distinct.h 1b7614490456b2115f6e63b4b02b082a *inst/include/dplyr/hybrid/scalar_result/sum.h 30e32be598dee61ef4bae411ae1b645b *inst/include/dplyr/hybrid/vector_result/echo.h 82f3b596caeae96d47ea61adbb921e7b *inst/include/dplyr/hybrid/vector_result/in.h 98eab97cdb1ebab5ed4ff566ba4f50df *inst/include/dplyr/hybrid/vector_result/lead_lag.h 310f489ee8ba54da34f3e86ecc978ebe *inst/include/dplyr/hybrid/vector_result/ntile.h b0713254860c093975c253badd9f598b *inst/include/dplyr/hybrid/vector_result/rank.h d919356c5d5035bb2802b94d0f7ddc5d *inst/include/dplyr/hybrid/vector_result/row_number.h 72a7cdbb9c26702093ce5f027e27e59f *inst/include/dplyr/lifecycle.h 16a0fd827820351e222cc887fa2c3731 *inst/include/dplyr/main.h 09352e101485fb42cff222d9c5eb9329 *inst/include/dplyr/standard/GroupedCallReducer.h 8d5e243146acd52f6d70aa792b9f7752 *inst/include/dplyr/symbols.h 1e2906bf49719fefa96aca7f79740df2 *inst/include/dplyr/visitor_set/VisitorEqualPredicate.h 9cf1e53f07ee689dbdfdceabcffb73d7 *inst/include/dplyr/visitor_set/VisitorHash.h ffa81819c00e48af72e4283da6335626 *inst/include/dplyr/visitor_set/VisitorSetEqual.h bc8aba742b74033a7a0198fe0a6bb1db *inst/include/dplyr/visitor_set/VisitorSetEqualPredicate.h c15359ece2c8557e0cfe62dbb9b5496e *inst/include/dplyr/visitor_set/VisitorSetGreater.h 1b49528f5cf032a2f09d37b50df6ccac *inst/include/dplyr/visitor_set/VisitorSetHash.h 4f41a7cb1a7661898fa6bb9a6e068a94 *inst/include/dplyr/visitor_set/VisitorSetHasher.h f34345e9bbfb9de527f657018940b584 *inst/include/dplyr/visitor_set/VisitorSetIndexMap.h 783a06ac112d4ed1d80d909a1bfef7d7 *inst/include/dplyr/visitor_set/VisitorSetIndexSet.h f6b089ffb4ac972e41327e6cf4a7a631 *inst/include/dplyr/visitor_set/VisitorSetLess.h 38cdeded34ff55544dec4fb5accd4f76 *inst/include/dplyr/visitor_set/visitor_set.h 8676a9b1a53e82b81b61f2c2cb3c86dd *inst/include/dplyr/visitors/CharacterVectorOrderer.h d4ed9b4dc52aa892563e2af1aa60a485 *inst/include/dplyr/visitors/Comparer.h e100e8bd943184d73cc174b36d79a664 *inst/include/dplyr/visitors/SliceVisitor.h ebf0f46dac294da1aa4b56a5852027e2 *inst/include/dplyr/visitors/join/Column.h e33eff4f4d6c6247053ce9c752375323 *inst/include/dplyr/visitors/join/DataFrameJoinVisitors.h ec984221e6a3b0b092a85b5b39644c72 *inst/include/dplyr/visitors/join/JoinVisitor.h 7e08bd69357c6994e194c6ae0bd0c0d4 *inst/include/dplyr/visitors/join/JoinVisitorImpl.h e6fe3f904734b2e697eeedeafa65c860 *inst/include/dplyr/visitors/join/join_match.h 3c5f89d91a9f3220f52f25f4cfb3b8a9 *inst/include/dplyr/visitors/order/Order.h cbf33710b157bab89f9133320955e311 *inst/include/dplyr/visitors/order/OrderVisitor.h dcf1c4f890bad28d53f01d4019130c6b *inst/include/dplyr/visitors/order/OrderVisitorImpl.h ac88d8f9d8ef224f140e644371e4cae5 *inst/include/dplyr/visitors/subset/DataFrameSelect.h 9cf27431f13b2ae73b7e3869772a97df *inst/include/dplyr/visitors/subset/DataFrameSubsetVisitors.h 016f0b10990bb8cc58dea0b5fc42f0df *inst/include/dplyr/visitors/subset/column_subset.h 65c1dd663a1fada8e802712c857f1049 *inst/include/dplyr/visitors/vector/DataFrameColumnVisitor.h 06b2a02ccfd07d1c0128fb25db293256 *inst/include/dplyr/visitors/vector/DataFrameVisitors.h be9474b4ee53bd2c7f2bc1ba1b2a6343 *inst/include/dplyr/visitors/vector/MatrixColumnVisitor.h ff833d7b518f701aca1e114a2c1255c0 *inst/include/dplyr/visitors/vector/MultipleVectorVisitors.h 934033f2b4774cfef63482d2d1ae83c6 *inst/include/dplyr/visitors/vector/VectorVisitor.h ce01e90599d188f2565e48f0c534ad5a *inst/include/dplyr/visitors/vector/VectorVisitorImpl.h f51b21bb6904529c5141f5c9e1c9921b *inst/include/dplyr/visitors/vector/visitor_impl.h 74772d26365bae288bb41a1a6d42cd88 *inst/include/dplyr/workarounds/installChar.h 0f10f6bdf53eb88da5c34f5c38092485 *inst/include/dplyr/workarounds/static_assert.h acbe82c8b4bffbbdc46a7dcf396f25d5 *inst/include/dplyr/workarounds/xlen.h a6daee6035f1f80ea673df677e539d83 *inst/include/dplyr_types.h 82b929bfe98b923eaf0afa2dd619cd02 *inst/include/solaris/solaris.h 52289ccf0fc7637bdf51acba90330fcf *inst/include/tools/BoolResult.h 0e8b2ad09aaeaadaa6b25e1028dabcc3 *inst/include/tools/Quosure.h bb04d42428b0a392e5e65fda19ef78f9 *inst/include/tools/SlicingIndex.h d0bd5306cdf79bec5d8de8e15d0ad9c3 *inst/include/tools/SymbolMap.h c21357fe3007d83021fb340534debd14 *inst/include/tools/SymbolString.h 227a066bedc789a8905141ead40050f2 *inst/include/tools/SymbolVector.h 9802e237f7dd3068a0a7603e573ccabd *inst/include/tools/VectorView.h aa83b8835ccaf6d6e8ca0c26c5ed184c *inst/include/tools/all_na.h 110a85ac3010b69f32fa5dfc198069d4 *inst/include/tools/bad.h c66fc6823140ef9d512ae2fd097d9c89 *inst/include/tools/collapse.h ab5fc9d5168f43457e6a1ca782671c38 *inst/include/tools/comparisons.h e85c59c67a86dfa2a50ccf5c823f33fe *inst/include/tools/debug.h 0f915e4d692389ef7f73b86cf63c7103 *inst/include/tools/default_value.h 962269a145adfd445321135dc73a379a *inst/include/tools/encoding.h 50beb9b6cf568996c36e4a8868b43509 *inst/include/tools/hash.h a6e4cafcfc1180be39d3e9cc362b2d1c *inst/include/tools/match.h 98edc649bdf9089bc5c0e361b2071bd4 *inst/include/tools/pointer_vector.h e138d5a777a12072994f5de444ebee94 *inst/include/tools/rlang-export.h 495af6216ce93eb4112d6fb4a7eff2c8 *inst/include/tools/scalar_type.h 00408c919bded58e61c9afbd9f278294 *inst/include/tools/set_rownames.h 6700d3f80e57fb79110a9f91d896c172 *inst/include/tools/tools.h 8c0b4ad334d9be1f0b5ce771d07dba65 *inst/include/tools/train.h 4a2183608fb05f258801ca22c8585e32 *inst/include/tools/utils.h b4c89445e3db249afa86d5de667de6f9 *inst/include/tools/vector_class.h a225fd929ff032a7d0de024080c53317 *man/add_rownames.Rd 70ee9ebe9bb2903bc7f86cf199b92e3a *man/all_equal.Rd a1084e3cf5b851c74e441d4e6465ba4f *man/all_vars.Rd 32c7392867708ffb021f19ed9ae1f72e *man/arrange.Rd 5945ae4be5228f6f6af3ff9a87bd5203 *man/arrange_all.Rd 4843d998d2354dfeaaa7017f50c2676c *man/as.table.tbl_cube.Rd 4ef9ac02e06e8231e47bc0ba603f047c *man/as.tbl_cube.Rd 137be2eff7b7ad639f186670f6d93a00 *man/auto_copy.Rd da960221d2ac181140e7cacd96c61c82 *man/backend_dbplyr.Rd e81531ed16876cb1bcfc57b89f4e4673 *man/band_members.Rd f55745a7ca8fcd8f1ae802c698079b1d *man/bench_compare.Rd 9db637fef15fb86469d465aee5b74a2e *man/between.Rd ad5697145ca82b52b9cbe21ec0e434db *man/bind.Rd 9cbd57e8b8051e4b13ee09185ea02818 *man/case_when.Rd 642f0eb963c751440246875da69eee76 *man/check_dbplyr.Rd 6125b900f3729f44dd73371a2a8a5ada *man/coalesce.Rd e532a477793819795f2333bfae043145 *man/combine.Rd a9e659ed5ca31b048ac71cb9e66b383e *man/common_by.Rd 8b57c8dc55db0515b925f21809335928 *man/compute.Rd fa3a60bf5ff8fb77fa26864f0a5eef96 *man/copy_to.Rd b00862f42ca7f5f8878de9dd4b6b31eb *man/cumall.Rd f0c7978518fbd44832836a74288b6bca *man/desc.Rd 88537f8e714f9460fbce7cd0952dd552 *man/dim_desc.Rd 73fe6bf2a842bc192d03267f891e37fc *man/distinct.Rd b00054090dcbd4daa4e369f925af0d81 *man/distinct_all.Rd c98b9193c5706d3cc538403c69401783 *man/do.Rd b88cafbe6a56e41f6209931419354391 *man/dplyr-package.Rd 252cd38bb67d05ca39c7099f34e297bd *man/dr_dplyr.Rd 9e046c5f3b2e55fd1f238d08bbe0ae99 *man/explain.Rd 9c4243b2d1393ce697564ff1e2f8575a *man/failwith.Rd 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 46de21252239c5a23d400eae83ec6b2d *man/figures/lifecycle-retired.svg 6902bbfaf963fbc4ed98b86bda80caa2 *man/figures/lifecycle-soft-deprecated.svg 53b3f893324260b737b3c46ed2a0e643 *man/figures/lifecycle-stable.svg 07a131391baa568b5e0902cf435ead19 *man/figures/logo.png 0120df40cde06d9586a03f4f59283ae7 *man/filter.Rd c62b46fe1d4eb6e8ad4ad578805b8afe *man/filter_all.Rd ed609059a6a56203030d48890bd39fff *man/funs.Rd 73d3fb5aec284d3bfc2e7b9f102d24cc *man/group_by.Rd 4e015c61dbeb2658aee2c3e8d2fdf111 *man/group_by_all.Rd cec4dcbcaa5db027a5c8d5a864aed6f7 *man/group_by_drop_default.Rd 936605934a2760a6aa9f422f25b6ff87 *man/group_by_prepare.Rd fff41563cf197fb3a789855897579a13 *man/group_cols.Rd d90acf1def3f281cd9eb76ace94eea3b *man/group_data.Rd bc7fbc7a59dcee66a08515163886b7db *man/group_indices.Rd 20685f17d16c741e9362bb5284cc3a0b *man/group_map.Rd b396d5c45514a9313b22f8ba0e96be50 *man/group_nest.Rd 5e5e384d05a17a739f8c8b6981e6af66 *man/group_size.Rd 4bd989783e2330b1843df13a43de69dd *man/group_split.Rd 9727fec123e7da78940c9815eefdf06d *man/group_trim.Rd a09ec695e64e0970130eb976044e7546 *man/grouped_df.Rd 565e7377b8b2ade72e1d11928618741d *man/groups.Rd 648a2210f1c417750c6b66eb9e08cd34 *man/hybrid_call.Rd dfe21ce2272cf6af5ec2d6e84dda7434 *man/id.Rd 2be780f90d448694b77d55fe3a2d03da *man/ident.Rd ac526ee481cb8465b06783bacaa9d5ea *man/if_else.Rd fed1d0a4957c37ae234ceb655095f717 *man/init_logging.Rd c6dfb6b69ff9890f8ae4d1b8fc1e3dc2 *man/join.Rd e7ce8263cab4af22a8b2269d42319854 *man/join.tbl_df.Rd 1fd64a5056b2e7e63cad54a5baef1a0f *man/lead-lag.Rd f2baa420397b241a7ce5524389d30165 *man/location.Rd accd69a53d9368ad2b36f225c9f99c44 *man/make_tbl.Rd c2da4b7a43fb543a3c8c2c771066293f *man/mutate.Rd 216202cba98df23c2cbcad79827163ec *man/mutate_all.Rd 90e12533ec0313b5c8c188bcba95c4a4 *man/n.Rd cef0c5bd879094aee163f5dd0bddf95f *man/n_distinct.Rd 550c170bd084af36b701c24198d22718 *man/na_if.Rd f611dd22872f69b715412a9aeebb58fa *man/nasa.Rd 0c99aebdb1662bb9e9fc97334212cc4d *man/near.Rd 15b923281778d2f983208ec104749662 *man/new_grouped_df.Rd 4d3bedee0f9023f032ef29bb1123e66e *man/nth.Rd 535b4dbee16f84764a5a889687d83159 *man/order_by.Rd 2366ead0f1e2d68dc23d5d7698509eca *man/progress_estimated.Rd 44e78e319da9183fe0c5d8bc0738600d *man/pull.Rd ce0f344f61528aa5b60af40d3b9b9185 *man/ranking.Rd 138bfc0b0ff5c678bbaed7e61a10386f *man/recode.Rd cb2ec3788183a429614284c997810ca4 *man/reexports.Rd 2b3fb38750aa4c760fc24834767414c0 *man/rowwise.Rd f7b4ab90ebcaec811366c956b4d1401a *man/same_src.Rd 6440f7ffac6df482a0eadd5c00b00d7b *man/sample.Rd c4d8c06a21e9a7717bd4d761a5185fe9 *man/scoped.Rd 8ab0a9e82b1a6b8dfff93e4802daacfe *man/se-deprecated.Rd 475ff934280f881b890cd5f4088b18c3 *man/select.Rd 4721201ca5c3d3b8a7a6102f56fe5541 *man/select_all.Rd 982c4748dcd5c91b7d271e4ab7e03651 *man/select_vars.Rd f4f385405f6a63285ae63c65e0bae7a0 *man/setops.Rd 6fed9c3bc97069b4a45bc9c005d6324c *man/slice.Rd 58452b35baf6118d7567b5cc0ce5aa9d *man/sql.Rd cd2f983efae88f0f38d5556f0dceb39d *man/src.Rd 504c9da62e2f9065c8afa9805c60119e *man/src_dbi.Rd 9c7f779fcfff545a30993f402e3725ac *man/src_local.Rd d989d2d5844137626d8aef870f08517a *man/src_tbls.Rd c52615a2da3cdf11e122bf096a7333ac *man/starwars.Rd 2c982dd196f1cf47ff8c1813e0d20e1b *man/storms.Rd 67c63cec7f8b9ff03da417053d5b05b2 *man/summarise.Rd 65dc2124b61a005d2fd907306ba0d4e5 *man/summarise_all.Rd 06ed06b716dad26bc213a68bf21e985a *man/summarise_each.Rd a1d93ca560ba85293fae24e8c71f16ad *man/tally.Rd 4e70bd464f7c1dfa062b8cd00995742d *man/tbl.Rd 5318e0f8a9dfe58ed56ec709eb61a103 *man/tbl_cube.Rd 88cf6cccf58b2795bee20b292bacbd33 *man/tbl_df.Rd 8f5ecb0ada84315a04fe57b85e683bda *man/tbl_vars.Rd ce60303f189989fd9c2d1c62fd958bf1 *man/tidyeval-compat.Rd 531b67e8ede906a719de01f5d377d0f7 *man/tidyeval.Rd 5144643a4cc90def3875534effb860f6 *man/top_n.Rd 434ad5854848abd0a46bc2c91c056ba7 *man/vars.Rd 0f716a00c40a985424f71afd4d758a80 *man/with_order.Rd 85a686ce99378d59926e020bffcf031c *src/Makevars 702033af765731fc265df15e283cf4e3 *src/Makevars.win fd49250f98bdeff280a6163ae4952882 *src/RcppExports.cpp ac260c2161d88bbf0042a77c327da5a9 *src/address.cpp ac324d32c831f9e600c47e4f2b68d47e *src/api.cpp 38113f57b3bb58144f8386c2e9104982 *src/arrange.cpp e524d2bd38b30dda06c7acf83f86e300 *src/between.cpp 9efa932e2fa4686757ec31777ebd16d4 *src/bind.cpp 0a25dd1fffb7fb8475b349ee7585a5fd *src/distinct.cpp ef713b7bdec1bc541d3d8a76278b33dd *src/encoding.cpp f0e2fe1b4298754a09c2c32d28775bb7 *src/filter.cpp 6e70de8b0db46fe1d3df796a9b566114 *src/group_indices.cpp 43d282e18dc54a2de06d339039ec2938 *src/hybrid.cpp 315cc8d89b5678600f1ffc711e0c9745 *src/init.cpp 3cf239b4ace7d1c3ad135ff56ce5bca6 *src/join.cpp ba6fb319767a49fa58568cb0226590ba *src/join_exports.cpp c4c2fa578a914be3a53d0e01aa4773df *src/mutate.cpp 3d1f112b1c24d6ccb497bf7688319277 *src/pch.h 601b3dc608aee72d232bd41d91552ec0 *src/rlang-export.c 6342158e563c3450db54cf35e2d9f034 *src/rlang.cpp f8472193d9d8a4f2500632baa7882c4a *src/select.cpp 250900bfdd467cabdbb1da16d6f1da84 *src/set.cpp 04ac6f4f7ad276db9c12ab926ab2e5cb *src/summarise.cpp 2004b85312a7b4c913d8b446a1e870da *src/test.cpp fb03046ca504aba5a771411b253dbd9a *src/utils-bindings.cpp 992ae8a9fd89f9c85b97cb8e996c3cef *src/utils.cpp 5ddb1bbef23ad2e4388424a3cbab4d53 *src/window.cpp 60c24a9c9c03f728e0d81d86fa6ca4d0 *tests/testthat.R e9248c4f9645bef5724077c1960b1446 *tests/testthat/helper-astyle.R aa7f034a9288aa06da9af160d69e8f36 *tests/testthat/helper-combine.R e66df44f42a67f819cb36b7f454312eb *tests/testthat/helper-dplyr.R 18ee78e4be8490b9f052ff557e490b2e *tests/testthat/helper-encoding.R 75a00613129fa9eb76608bdda725f4f9 *tests/testthat/helper-groups.R e14ad174bca4fd5ceef67a7ec39d6c58 *tests/testthat/helper-hybrid.R 5c40bc3557d7e68c3f963b4f428f5c20 *tests/testthat/helper-torture.R e9d8127c14ea4a64ffcbf9230229a8a9 *tests/testthat/test-DBI.R 6cbae5a357bb89b10511df899c9e5707 *tests/testthat/test-active-bindings.R a07ae688f7371a2715dcec8918e374fb *tests/testthat/test-arrange.r 49113f7f672913fe11e374d7f5c3c544 *tests/testthat/test-astyle.R 5433288875c5cedb640f9aad2f48550c *tests/testthat/test-between.R caab51fdedd91c4796d1b3f9e09455d3 *tests/testthat/test-binds.R ef0efb097771c2069a966082d03ed4de *tests/testthat/test-case-when.R 84b7a73b11d5900d181d8c9e53abf837 *tests/testthat/test-coalesce.R 6f80015621d345669f5f9c5e52315d11 *tests/testthat/test-colwise-arrange.R cc8083b4e3657d77edc805798519e829 *tests/testthat/test-colwise-distinct.R dbc7f5c5b0ce76795347cec661db102b *tests/testthat/test-colwise-filter.R 359785e92e4db4d185b265de5e2d285b *tests/testthat/test-colwise-group-by.R c877ed40bb0eaaf6844897bcc16f5634 *tests/testthat/test-colwise-mutate.R 14d1b908f029f71bdf2fcec2c7c42a9f *tests/testthat/test-colwise-select.R f67447369b3bec434c7d8dba3344763f *tests/testthat/test-colwise.R 6e9d53eed39c7f0fbc0d68e837f79d51 *tests/testthat/test-combine.R 90d084c37cfdb4344c745e020e952d3d *tests/testthat/test-copy_to.R 39988efc666e80566c47eb579443096d *tests/testthat/test-copying.R d29b5f539fa4cbb7e03d1099391c7228 *tests/testthat/test-count-tally.r 6ed341fde2d49835a4c45d3c6396a4d5 *tests/testthat/test-data_frame.R 8041b02d03aaa3672b6c17dcdf55ca7c *tests/testthat/test-distinct.R 2a1166d633a8d4583287ee6c46f57d19 *tests/testthat/test-do.R 1058721e82264da0213486cce2397762 *tests/testthat/test-empty-groups.R 3d8222eaf31abb34242ab9514a7cf9a2 *tests/testthat/test-equality.r 2b9727d28209482331d89716f06558fa *tests/testthat/test-filter.r b4d9becfd0b48b6cb3836e2223be5f8f *tests/testthat/test-funs-predicates.R aefd39ca65fbf239c05557b11abd1699 *tests/testthat/test-funs.R 0c164b2167096a0c3f4948af829abb53 *tests/testthat/test-group-by.r 30f2c22e1060655f779d2b2a7ac4d195 *tests/testthat/test-group-indices.R 4ff048365f4d82fcb137b021213e257a *tests/testthat/test-group-size.R 3c957baa45f045dba7a9d4d0b0cc6fe1 *tests/testthat/test-group_data.R 84461e413e53f15e7f163bb1f85b75e6 *tests/testthat/test-group_keys.R 0052c69e85121c7b1634d7a24bdf143a *tests/testthat/test-group_map.R 13b099d702496c9f90839db07fcecfa3 *tests/testthat/test-group_nest.R f66fdf6dd99934ce0c3ef984c8dd9f26 *tests/testthat/test-group_split.R c729196688b795c8b00ced3c3d421674 *tests/testthat/test-group_trim.R 2b177071c612775b25bcf7ccd616abfd *tests/testthat/test-hybrid-traverse.R f447454a7dabe3303c01e9bd37551583 *tests/testthat/test-hybrid.R 317896501dca3547b7921908416d9430 *tests/testthat/test-if-else.R 9083be60b404381c0aa9d7a88edd195b *tests/testthat/test-internals.r 8de42d9b258f7b6a3c0c35eab7bf50bc *tests/testthat/test-joins.r afa42ede622d86632312a410eb9daf5d *tests/testthat/test-lazyeval-compat.R 3fcd1edca619eb3342aaa0f86513bf47 *tests/testthat/test-lead-lag.R 151b4cf8ca128db7baddda2093e1d5d5 *tests/testthat/test-mutate-windowed.R 679c22c48ce6ac1b459a295659297dd4 *tests/testthat/test-mutate.r eba64f383e1362bc4bd5fff38d60328d *tests/testthat/test-n_distinct.R 7e5620dc7a74958744f339d8df3a485c *tests/testthat/test-na-if.R 8cd23acee47e4b128d9e46628116ac16 *tests/testthat/test-near.R f2a3d59e2c6b0e8b526c7ef7f1bc8bb7 *tests/testthat/test-new_grouped_df.R ec98e22acefd5e4b62d0149c45224df8 *tests/testthat/test-nth-value.R da5ee450ee9bbf22b7a057d634f14f4a *tests/testthat/test-overscope.R 546c5b7434481129ca36f709b86d86ca *tests/testthat/test-pull.R 7363e2db41ae67e216118e3a5b53c4e3 *tests/testthat/test-rank.R 5b9e5359c95de486bb600354b8a1807c *tests/testthat/test-rbind.R 6d8c07435fe9e49da68bdf47770d9417 *tests/testthat/test-recode.R 829346184b8426ce6b31333806514998 *tests/testthat/test-sample.R 409eb19bafd57f9123b65edf165c499c *tests/testthat/test-select.r c5de90a0e9cf9d963dd458881289c69d *tests/testthat/test-sets.R a74d207daff919692a1a56441a84920f *tests/testthat/test-slice.r 5482ae77493245c115eaef8c7fe3bdbf *tests/testthat/test-summarise.r 295a06bca3b262d6b1f1a2a2793f16ff *tests/testthat/test-tbl-cube.R 7e804a61c6fa3a34fb562329b95f0a85 *tests/testthat/test-tbl.R c0db70ac692198bec991bde3ac532cda *tests/testthat/test-top-n.R 47b72c21ef6b2494c0d8e2c91f17a035 *tests/testthat/test-transmute.R 059ed6902eef67772ce4077422722ecc *tests/testthat/test-ts.R 6f52aa226e09c3c4ea327e8e7ff9a0d9 *tests/testthat/test-underscore.R b66034a9387db9a49c0a5189bca353e0 *tests/testthat/test-union-all.R 32569dc0c435e497e585e82826e5d321 *tests/testthat/test-utils.R 97dd603568dba0f61dc74f95a0662ae8 *tests/testthat/test-window.R a49019f22ad9e9314d08b68597f369ad *tests/testthat/utf-8.txt fd4b85cb062af355f869ca5d2895c52b *vignettes/aaa.R 9508ba86d6bc31ba3196f2f8719d7907 *vignettes/aaa.html b6ef692a53b1730f572fc4bb24bcebdf *vignettes/compatibility.Rmd 9b47681a9d447e5d1953702b91e0071d *vignettes/dplyr.Rmd 8da947f2f3c625755fa60e2168a32190 *vignettes/future/dplyr_0.8.0.Rmd 98f32477943b7cc59b7545fdad95c50d *vignettes/future/dplyr_0.8.0_new_hybrid.Rmd 4c4c847727bf145d7fecbd0628cdb4c0 *vignettes/programming.Rmd 88f2cd45baee6686ddcc8d42e11e87d2 *vignettes/two-table.Rmd 3ec1d9c26f39f6396fdedb8abb763f85 *vignettes/window-functions.Rmd dplyr/inst/0000755000176200001440000000000013614574175012376 5ustar liggesusersdplyr/inst/doc/0000755000176200001440000000000013614574175013143 5ustar liggesusersdplyr/inst/doc/window-functions.Rmd0000644000176200001440000002166713451046652017131 0ustar liggesusers--- title: "Window functions" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Window functions} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- ```{r, include = FALSE} knitr::opts_chunk$set(collapse = T, comment = "#>") options(tibble.print_min = 4L, tibble.print_max = 4L) library(dplyr) set.seed(1014) ``` A __window function__ is a variation on an aggregation function. Where an aggregation function, like `sum()` and `mean()`, takes n inputs and return a single value, a window function returns n values. The output of a window function depends on all its input values, so window functions don't include functions that work element-wise, like `+` or `round()`. Window functions include variations on aggregate functions, like `cumsum()` and `cummean()`, functions for ranking and ordering, like `rank()`, and functions for taking offsets, like `lead()` and `lag()`. In this vignette, we'll use a small sample of the Lahman batting dataset, including the players that have won an award. ```{r} library(Lahman) batting <- Lahman::Batting %>% as_tibble() %>% select(playerID, yearID, teamID, G, AB:H) %>% arrange(playerID, yearID, teamID) %>% semi_join(Lahman::AwardsPlayers, by = "playerID") players <- batting %>% group_by(playerID) ``` Window functions are used in conjunction with `mutate()` and `filter()` to solve a wide range of problems. Here's a selection: ```{r, eval = FALSE} # For each player, find the two years with most hits filter(players, min_rank(desc(H)) <= 2 & H > 0) # Within each player, rank each year by the number of games played mutate(players, G_rank = min_rank(G)) # For each player, find every year that was better than the previous year filter(players, G > lag(G)) # For each player, compute avg change in games played per year mutate(players, G_change = (G - lag(G)) / (yearID - lag(yearID))) # For each player, find all where they played more games than average filter(players, G > mean(G)) # For each, player compute a z score based on number of games played mutate(players, G_z = (G - mean(G)) / sd(G)) ``` Before reading this vignette, you should be familiar with `mutate()` and `filter()`. ## Types of window functions There are five main families of window functions. Two families are unrelated to aggregation functions: * Ranking and ordering functions: `row_number()`, `min_rank()`, `dense_rank()`, `cume_dist()`, `percent_rank()`, and `ntile()`. These functions all take a vector to order by, and return various types of ranks. * Offsets `lead()` and `lag()` allow you to access the previous and next values in a vector, making it easy to compute differences and trends. The other three families are variations on familiar aggregate functions: * Cumulative aggregates: `cumsum()`, `cummin()`, `cummax()` (from base R), and `cumall()`, `cumany()`, and `cummean()` (from dplyr). * Rolling aggregates operate in a fixed width window. You won't find them in base R or in dplyr, but there are many implementations in other packages, such as [RcppRoll](https://cran.r-project.org/package=RcppRoll). * Recycled aggregates, where an aggregate is repeated to match the length of the input. These are not needed in R because vector recycling automatically recycles aggregates where needed. They are important in SQL, because the presence of an aggregation function usually tells the database to return only one row per group. Each family is described in more detail below, focussing on the general goals and how to use them with dplyr. For more details, refer to the individual function documentation. ## Ranking functions The ranking functions are variations on a theme, differing in how they handle ties: ```{r} x <- c(1, 1, 2, 2, 2) row_number(x) min_rank(x) dense_rank(x) ``` If you're familiar with R, you may recognise that `row_number()` and `min_rank()` can be computed with the base `rank()` function and various values of the `ties.method` argument. These functions are provided to save a little typing, and to make it easier to convert between R and SQL. Two other ranking functions return numbers between 0 and 1. `percent_rank()` gives the percentage of the rank; `cume_dist()` gives the proportion of values less than or equal to the current value. ```{r} cume_dist(x) percent_rank(x) ``` These are useful if you want to select (for example) the top 10% of records within each group. For example: ```{r} filter(players, cume_dist(desc(G)) < 0.1) ``` Finally, `ntile()` divides the data up into `n` evenly sized buckets. It's a coarse ranking, and it can be used in with `mutate()` to divide the data into buckets for further summary. For example, we could use `ntile()` to divide the players within a team into four ranked groups, and calculate the average number of games within each group. ```{r} by_team_player <- group_by(batting, teamID, playerID) by_team <- summarise(by_team_player, G = sum(G)) by_team_quartile <- group_by(by_team, quartile = ntile(G, 4)) summarise(by_team_quartile, mean(G)) ``` All ranking functions rank from lowest to highest so that small input values get small ranks. Use `desc()` to rank from highest to lowest. ## Lead and lag `lead()` and `lag()` produce offset versions of a input vector that is either ahead of or behind the original vector. ```{r} x <- 1:5 lead(x) lag(x) ``` You can use them to: * Compute differences or percent changes. ```{r, results = "hide"} # Compute the relative change in games played mutate(players, G_delta = G - lag(G)) ``` Using `lag()` is more convenient than `diff()` because for `n` inputs `diff()` returns `n - 1` outputs. * Find out when a value changes. ```{r, results = "hide"} # Find when a player changed teams filter(players, teamID != lag(teamID)) ``` `lead()` and `lag()` have an optional argument `order_by`. If set, instead of using the row order to determine which value comes before another, they will use another variable. This is important if you have not already sorted the data, or you want to sort one way and lag another. Here's a simple example of what happens if you don't specify `order_by` when you need it: ```{r} df <- data.frame(year = 2000:2005, value = (0:5) ^ 2) scrambled <- df[sample(nrow(df)), ] wrong <- mutate(scrambled, prev_value = lag(value)) arrange(wrong, year) right <- mutate(scrambled, prev_value = lag(value, order_by = year)) arrange(right, year) ``` ## Cumulative aggregates Base R provides cumulative sum (`cumsum()`), cumulative min (`cummin()`), and cumulative max (`cummax()`). (It also provides `cumprod()` but that is rarely useful). Other common accumulating functions are `cumany()` and `cumall()`, cumulative versions of `||` and `&&`, and `cummean()`, a cumulative mean. These are not included in base R, but efficient versions are provided by `dplyr`. `cumany()` and `cumall()` are useful for selecting all rows up to, or all rows after, a condition is true for the first (or last) time. For example, we can use `cumany()` to find all records for a player after they played a year with 150 games: ```{r, eval = FALSE} filter(players, cumany(G > 150)) ``` Like lead and lag, you may want to control the order in which the accumulation occurs. None of the built in functions have an `order_by` argument so `dplyr` provides a helper: `order_by()`. You give it the variable you want to order by, and then the call to the window function: ```{r} x <- 1:10 y <- 10:1 order_by(y, cumsum(x)) ``` This function uses a bit of non-standard evaluation, so I wouldn't recommend using it inside another function; use the simpler but less concise `with_order()` instead. ## Recycled aggregates R's vector recycling makes it easy to select values that are higher or lower than a summary. I call this a recycled aggregate because the value of the aggregate is recycled to be the same length as the original vector. Recycled aggregates are useful if you want to find all records greater than the mean or less than the median: ```{r, eval = FALSE} filter(players, G > mean(G)) filter(players, G < median(G)) ``` While most SQL databases don't have an equivalent of `median()` or `quantile()`, when filtering you can achieve the same effect with `ntile()`. For example, `x > median(x)` is equivalent to `ntile(x, 2) == 2`; `x > quantile(x, 75)` is equivalent to `ntile(x, 100) > 75` or `ntile(x, 4) > 3`. ```{r, eval = FALSE} filter(players, ntile(G, 2) == 2) ``` You can also use this idea to select the records with the highest (`x == max(x)`) or lowest value (`x == min(x)`) for a field, but the ranking functions give you more control over ties, and allow you to select any number of records. Recycled aggregates are also useful in conjunction with `mutate()`. For example, with the batting data, we could compute the "career year", the number of years a player has played since they entered the league: ```{r} mutate(players, career_year = yearID - min(yearID) + 1) ``` Or, as in the introductory example, we could compute a z-score: ```{r} mutate(players, G_z = (G - mean(G)) / sd(G)) ``` dplyr/inst/doc/compatibility.html0000644000176200001440000007575213614574167016723 0ustar liggesusers dplyr compatibility

dplyr compatibility

This vignette is aimed at package authors who need to update their code because of a backward incompatible change to dplyr. We do try and minimise backward incompatible changes as much as possible, but sometimes they are necessary in order to radically simplify existing code, or unlock a lot of potential value in the future.

This vignette starts with some general advice on writing package code that works with multiple version of dplyr, then continues to discuss specific changes in dplyr versions.

Working with multiple dplyr versions

Ideally, you want to make sure that your package works with both the released version and the development version of dplyr. This is typically a little bit more work, but has two big advantages:

  1. It’s more convenient for your users, since they’re not forced to update dplyr if they don’t want to)

  2. It’s easier on CRAN since it doesn’t require a massive coordinated release of multiple packages.

To make code work with multiple versions of a package, your first tool is the simple if statement:

Always condition on > current-version, not >= next-version because this will ensure that this branch is also used for the development version of the package. For example, if the current release is version “0.5.0”, the development version will be “0.5.0.9000”.

Occasionally, you’ll run into a situation where the NAMESPACE has changed and you need to conditionally import different functions. This typically occurs when functions are moved from one package to another. We try out best to provide automatic fallbacks, but this is not always possible. Often you can work around the problem by avoiding importFrom and using :: instead. Do this where possible:

This will generate an R CMD check NOTE (because the one of the functions will always be missing), but this is ok. Simply explain that you get the note because you have written a wrapper to make sure your code is backward compatible.

Sometimes it’s not possible to avoid importFrom(). For example you might be importing a generic so that you can define a method for it. In this case, you can take advantage of a little-known feature in the NAMESPACE file: you can include if statements.

dplyr 0.6.0

Database code moves to dbplyr

Almost all database related code has been moved out of dplyr and into a new package, dbplyr. This makes dplyr simpler, and will make it easier to release fixes for bugs that only affect databases. If you’ve implemented a database backend for dplyr, please read the backend news on the backend.

Depending on what generics you use, and what generics you provide methods for you, you may need to write some conditional code. To help make this easier we’ve written wrap_dbplyr_obj() which will write the helper code for you:

Simply copy the results of this function in your package.

These will generate R CMD check NOTES, so make sure to tell CRAN that this is to ensure backward compatibility.

Deprecation of underscored verbs_()

Because the tidyeval framework allows us to combine SE and NSE semantics within the same functions, the underscored verbs have been softly deprecated.

For users of SE_ verbs

The legacy underscored versions take objects for which a lazyeval::as.lazy() method is defined. This includes symbols and calls, strings, and formulas. All of these objects have been replaced with quosures and you can call tidyeval verbs with unquoted quosures:

Symbolic expressions are also supported, but note that bare symbols and calls do not carry scope information. If you’re referring to objects in the data frame, it’s safe to omit specifying an enclosure:

Transforming objects into quosures is generally straightforward. To enclose with the current environment, you can unquote directly in quo() or you can use as_quosure():

Note that while formulas and quosures are very similar objects (and in the most general sense, formulas are quosures), they can’t be used interchangeably in tidyeval functions. Early implementations did treat bare formulas as quosures, but this created compatibility issues with modelling functions of the stats package. Fortunately, it’s easy to transform formulas to quosures that will self-evaluate in tidyeval functions:

Finally, and perhaps most importantly, strings are not and should not be parsed. As developers, it is tempting to try and solve problems using strings because we have been trained to work with strings rather than quoted expressions. However it’s almost always the wrong way to approach the problem. The exception is for creating symbols. In that case it is perfectly legitimate to use strings:

But you should never use strings to create calls. Instead you can use quasiquotation:

Or create the call with call2():

Note that idioms based on interp() should now generally be avoided and replaced with quasiquotation. Where you used to interpolate:

You would now unquote:

See also vignette("programming") for more about quasiquotation and quosures.

For package authors

For package authors, rlang provides a compatibility file that you can copy to your package. compat_lazy() and compat_lazy_dots() turn lazy-able objects into proper quosures. This helps providing an underscored version to your users for backward compatibility. For instance, here is how we defined the underscored version of filter() in dplyr 0.6:

With tidyeval, S3 dispatch to the correct method might be an issue. In the past, the genericity of dplyr verbs was accomplished by dispatching in the underscored versions. Now that those are deprecated, we’ve turned the non-underscored verbs into S3 generics.

We maintain backward compatibility by redispatching to old underscored verbs in the default methods of the new S3 generics. For example, here is how we redispatch filter():

This gets the job done in most cases. However, the default method will not be called for objects inheriting from one of the classes for which we provide non-underscored methods: data.frame, tbl_df, tbl_cube and grouped_df. An example of this is the sf package whose objects have classes c("sf", "data.frame"). Authors of such packages should provide a method for the non-underscored generic in order to be compatible with dplyr:

If you need help with this, please let us know!

Deprecation of mutate_each() and summarise_each()

These functions have been replaced by a more complete family of functions. This family has suffixes _if, _at and _all and includes more verbs than just mutate summarise.

If you need to update your code to the new family, there are two relevant functions depending on which variables you apply funs() to. If you called mutate_each() without supplying a selection of variables, funs is applied to all variables. In this case, you should update your code to use mutate_all() instead:

Note that the new verbs support bare functions as well, so you don’t necessarily need to wrap with funs():

On the other hand, if you supplied a variable selection, you should use mutate_at(). The variable selection should be wrapped with vars().

vars() supports all the selection helpers that you usually use with select():

Note that intead of a vars() selection, you can also supply character vectors of column names:

dplyr/inst/doc/programming.R0000644000176200001440000001724513614574172015616 0ustar liggesusers## ----setup, echo = FALSE, message = FALSE-------------------------------- knitr::opts_chunk$set(collapse = T, comment = "#>") options(tibble.print_min = 4L, tibble.print_max = 4L) library(dplyr) set.seed(1014) ## ------------------------------------------------------------------------ df <- tibble(x = 1:3, y = 3:1) filter(df, x == 1) ## ---- error = TRUE------------------------------------------------------- my_var <- x filter(df, my_var == 1) ## ---- error = TRUE------------------------------------------------------- my_var <- "x" filter(df, my_var == 1) ## ---- eval = FALSE------------------------------------------------------- # df[df$x == df$y, ] # df[df$x == y, ] # df[x == df$y, ] # df[x == y, ] ## ------------------------------------------------------------------------ greet <- function(name) { "How do you do, name?" } greet("Hadley") ## ------------------------------------------------------------------------ greet <- function(name) { paste0("How do you do, ", name, "?") } greet("Hadley") ## ------------------------------------------------------------------------ greet <- function(name) { glue::glue("How do you do, {name}?") } greet("Hadley") ## ---- eval = FALSE------------------------------------------------------- # mutate(df1, y = a + x) # mutate(df2, y = a + x) # mutate(df3, y = a + x) # mutate(df4, y = a + x) ## ------------------------------------------------------------------------ mutate_y <- function(df) { mutate(df, y = a + x) } ## ------------------------------------------------------------------------ df1 <- tibble(x = 1:3) a <- 10 mutate_y(df1) ## ---- error = TRUE------------------------------------------------------- mutate_y <- function(df) { mutate(df, y = .data$a + .data$x) } mutate_y(df1) ## ------------------------------------------------------------------------ df <- tibble( g1 = c(1, 1, 2, 2, 2), g2 = c(1, 2, 1, 2, 1), a = sample(5), b = sample(5) ) df %>% group_by(g1) %>% summarise(a = mean(a)) df %>% group_by(g2) %>% summarise(a = mean(a)) ## ---- error = TRUE------------------------------------------------------- my_summarise <- function(df, group_var) { df %>% group_by(group_var) %>% summarise(a = mean(a)) } my_summarise(df, g1) ## ---- error = TRUE------------------------------------------------------- my_summarise(df, "g2") ## ------------------------------------------------------------------------ quo(g1) quo(a + b + c) quo("a") ## ---- error = TRUE------------------------------------------------------- my_summarise(df, quo(g1)) ## ------------------------------------------------------------------------ my_summarise <- function(df, group_var) { df %>% group_by(!! group_var) %>% summarise(a = mean(a)) } my_summarise(df, quo(g1)) ## ---- eval = FALSE------------------------------------------------------- # my_summarise(df, g1) ## ---- error = TRUE------------------------------------------------------- my_summarise <- function(df, group_var) { quo_group_var <- quo(group_var) print(quo_group_var) df %>% group_by(!! quo_group_var) %>% summarise(a = mean(a)) } my_summarise(df, g1) ## ------------------------------------------------------------------------ my_summarise <- function(df, group_var) { group_var <- enquo(group_var) print(group_var) df %>% group_by(!! group_var) %>% summarise(a = mean(a)) } my_summarise(df, g1) ## ------------------------------------------------------------------------ summarise(df, mean = mean(a), sum = sum(a), n = n()) summarise(df, mean = mean(a * b), sum = sum(a * b), n = n()) ## ------------------------------------------------------------------------ my_var <- quo(a) summarise(df, mean = mean(!! my_var), sum = sum(!! my_var), n = n()) ## ------------------------------------------------------------------------ quo(summarise(df, mean = mean(!! my_var), sum = sum(!! my_var), n = n() )) ## ------------------------------------------------------------------------ my_summarise2 <- function(df, expr) { expr <- enquo(expr) summarise(df, mean = mean(!! expr), sum = sum(!! expr), n = n() ) } my_summarise2(df, a) my_summarise2(df, a * b) ## ------------------------------------------------------------------------ mutate(df, mean_a = mean(a), sum_a = sum(a)) mutate(df, mean_b = mean(b), sum_b = sum(b)) ## ------------------------------------------------------------------------ my_mutate <- function(df, expr) { expr <- enquo(expr) mean_name <- paste0("mean_", quo_name(expr)) sum_name <- paste0("sum_", quo_name(expr)) mutate(df, !! mean_name := mean(!! expr), !! sum_name := sum(!! expr) ) } my_mutate(df, a) ## ------------------------------------------------------------------------ my_summarise <- function(df, ...) { group_var <- enquos(...) df %>% group_by(!!! group_var) %>% summarise(a = mean(a)) } my_summarise(df, g1, g2) ## ------------------------------------------------------------------------ args <- list(na.rm = TRUE, trim = 0.25) quo(mean(x, !!! args)) args <- list(quo(x), na.rm = TRUE, trim = 0.25) quo(mean(!!! args)) ## ------------------------------------------------------------------------ disp ~ cyl + drat ## ------------------------------------------------------------------------ # Computing the value of the expression: toupper(letters[1:5]) # Capturing the expression: quote(toupper(letters[1:5])) ## ------------------------------------------------------------------------ f <- function(x) { quo(x) } x1 <- f(10) x2 <- f(100) ## ------------------------------------------------------------------------ x1 x2 ## ---- message = FALSE---------------------------------------------------- library(rlang) get_env(x1) get_env(x2) ## ------------------------------------------------------------------------ eval_tidy(x1) eval_tidy(x2) ## ------------------------------------------------------------------------ user_var <- 1000 mtcars %>% summarise(cyl = mean(cyl) * user_var) ## ------------------------------------------------------------------------ typeof(mean) ## ------------------------------------------------------------------------ var <- ~toupper(letters[1:5]) var # You can extract its expression: get_expr(var) # Or inspect its enclosure: get_env(var) ## ------------------------------------------------------------------------ # Here we capture `letters[1:5]` as an expression: quo(toupper(letters[1:5])) # Here we capture the value of `letters[1:5]` quo(toupper(!! letters[1:5])) quo(toupper(UQ(letters[1:5]))) ## ------------------------------------------------------------------------ var1 <- quo(letters[1:5]) quo(toupper(!! var1)) ## ------------------------------------------------------------------------ my_mutate <- function(x) { mtcars %>% select(cyl) %>% slice(1:4) %>% mutate(cyl2 = cyl + (!! x)) } f <- function(x) quo(x) expr1 <- f(100) expr2 <- f(10) my_mutate(expr1) my_mutate(expr2) ## ---- error = TRUE------------------------------------------------------- my_fun <- quo(fun) quo(!! my_fun(x, y, z)) quo(UQ(my_fun)(x, y, z)) my_var <- quo(x) quo(filter(df, !! my_var == 1)) quo(filter(df, UQ(my_var) == 1)) ## ------------------------------------------------------------------------ quo(list(!!! letters[1:5])) ## ------------------------------------------------------------------------ x <- list(foo = 1L, bar = quo(baz)) quo(list(!!! x)) ## ------------------------------------------------------------------------ args <- list(mean = quo(mean(cyl)), count = quo(n())) mtcars %>% group_by(am) %>% summarise(!!! args) ## ------------------------------------------------------------------------ mean_nm <- "mean" count_nm <- "count" mtcars %>% group_by(am) %>% summarise( !! mean_nm := mean(cyl), !! count_nm := n() ) dplyr/inst/doc/two-table.Rmd0000644000176200001440000002056113614573562015510 0ustar liggesusers--- title: "Two-table verbs" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Two-table verbs} %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} --- ```{r, echo = FALSE, message = FALSE} knitr::opts_chunk$set(collapse = T, comment = "#>") options(tibble.print_min = 5) library(dplyr) knit_print.tbl_df <- function(x, options) { knitr::knit_print(trunc_mat(x), options) } ``` It's rare that a data analysis involves only a single table of data. In practice, you'll normally have many tables that contribute to an analysis, and you need flexible tools to combine them. In dplyr, there are three families of verbs that work with two tables at a time: * Mutating joins, which add new variables to one table from matching rows in another. * Filtering joins, which filter observations from one table based on whether or not they match an observation in the other table. * Set operations, which combine the observations in the data sets as if they were set elements. (This discussion assumes that you have [tidy data](http://www.jstatsoft.org/v59/i10/), where the rows are observations and the columns are variables. If you're not familiar with that framework, I'd recommend reading up on it first.) All two-table verbs work similarly. The first two arguments are `x` and `y`, and provide the tables to combine. The output is always a new table with the same type as `x`. ## Mutating joins Mutating joins allow you to combine variables from multiple tables. For example, take the nycflights13 data. In one table we have flight information with an abbreviation for carrier, and in another we have a mapping between abbreviations and full names. You can use a join to add the carrier names to the flight data: ```{r, warning = FALSE} library("nycflights13") # Drop unimportant variables so it's easier to understand the join results. flights2 <- flights %>% select(year:day, hour, origin, dest, tailnum, carrier) flights2 %>% left_join(airlines) ``` ### Controlling how the tables are matched As well as `x` and `y`, each mutating join takes an argument `by` that controls which variables are used to match observations in the two tables. There are a few ways to specify it, as I illustrate below with various tables from nycflights13: * `NULL`, the default. dplyr will will use all variables that appear in both tables, a __natural__ join. For example, the flights and weather tables match on their common variables: year, month, day, hour and origin. ```{r} flights2 %>% left_join(weather) ``` * A character vector, `by = "x"`. Like a natural join, but uses only some of the common variables. For example, `flights` and `planes` have `year` columns, but they mean different things so we only want to join by `tailnum`. ```{r} flights2 %>% left_join(planes, by = "tailnum") ``` Note that the year columns in the output are disambiguated with a suffix. * A named character vector: `by = c("x" = "a")`. This will match variable `x` in table `x` to variable `a` in table `y`. The variables from use will be used in the output. Each flight has an origin and destination `airport`, so we need to specify which one we want to join to: ```{r} flights2 %>% left_join(airports, c("dest" = "faa")) flights2 %>% left_join(airports, c("origin" = "faa")) ``` ### Types of join There are four types of mutating join, which differ in their behaviour when a match is not found. We'll illustrate each with a simple example: ```{r} df1 <- tibble(x = c(1, 2), y = 2:1) df2 <- tibble(x = c(1, 3), a = 10, b = "a") ``` * `inner_join(x, y)` only includes observations that match in both `x` and `y`. ```{r} df1 %>% inner_join(df2) %>% knitr::kable() ``` * `left_join(x, y)` includes all observations in `x`, regardless of whether they match or not. This is the most commonly used join because it ensures that you don't lose observations from your primary table. ```{r} df1 %>% left_join(df2) ``` * `right_join(x, y)` includes all observations in `y`. It's equivalent to `left_join(y, x)`, but the columns will be ordered differently. ```{r} df1 %>% right_join(df2) df2 %>% left_join(df1) ``` * `full_join()` includes all observations from `x` and `y`. ```{r} df1 %>% full_join(df2) ``` The left, right and full joins are collectively know as __outer joins__. When a row doesn't match in an outer join, the new variables are filled in with missing values. ### Observations While mutating joins are primarily used to add new variables, they can also generate new observations. If a match is not unique, a join will add all possible combinations (the Cartesian product) of the matching observations: ```{r} df1 <- tibble(x = c(1, 1, 2), y = 1:3) df2 <- tibble(x = c(1, 1, 2), z = c("a", "b", "a")) df1 %>% left_join(df2) ``` ## Filtering joins Filtering joins match obserations in the same way as mutating joins, but affect the observations, not the variables. There are two types: * `semi_join(x, y)` __keeps__ all observations in `x` that have a match in `y`. * `anti_join(x, y)` __drops__ all observations in `x` that have a match in `y`. These are most useful for diagnosing join mismatches. For example, there are many flights in the nycflights13 dataset that don't have a matching tail number in the planes table: ```{r} library("nycflights13") flights %>% anti_join(planes, by = "tailnum") %>% count(tailnum, sort = TRUE) ``` If you're worried about what observations your joins will match, start with a `semi_join()` or `anti_join()`. `semi_join()` and `anti_join()` never duplicate; they only ever remove observations. ```{r} df1 <- tibble(x = c(1, 1, 3, 4), y = 1:4) df2 <- tibble(x = c(1, 1, 2), z = c("a", "b", "a")) # Four rows to start with: df1 %>% nrow() # And we get four rows after the join df1 %>% inner_join(df2, by = "x") %>% nrow() # But only two rows actually match df1 %>% semi_join(df2, by = "x") %>% nrow() ``` ## Set operations The final type of two-table verb is set operations. These expect the `x` and `y` inputs to have the same variables, and treat the observations like sets: * `intersect(x, y)`: return only observations in both `x` and `y` * `union(x, y)`: return unique observations in `x` and `y` * `setdiff(x, y)`: return observations in `x`, but not in `y`. Given this simple data: ```{r} (df1 <- tibble(x = 1:2, y = c(1L, 1L))) (df2 <- tibble(x = 1:2, y = 1:2)) ``` The four possibilities are: ```{r} intersect(df1, df2) # Note that we get 3 rows, not 4 union(df1, df2) setdiff(df1, df2) setdiff(df2, df1) ``` ## Coercion rules When joining tables, dplyr is a little more conservative than base R about the types of variable that it considers equivalent. This is mostly likely to surprise if you're working factors: * Factors with different levels are coerced to character with a warning: ```{r} df1 <- tibble(x = 1, y = factor("a")) df2 <- tibble(x = 2, y = factor("b")) full_join(df1, df2) %>% str() ``` * Factors with the same levels in a different order are coerced to character with a warning: ```{r} df1 <- tibble(x = 1, y = factor("a", levels = c("a", "b"))) df2 <- tibble(x = 2, y = factor("b", levels = c("b", "a"))) full_join(df1, df2) %>% str() ``` * Factors are preserved only if the levels match exactly: ```{r} df1 <- tibble(x = 1, y = factor("a", levels = c("a", "b"))) df2 <- tibble(x = 2, y = factor("b", levels = c("a", "b"))) full_join(df1, df2) %>% str() ``` * A factor and a character are coerced to character with a warning: ```{r} df1 <- tibble(x = 1, y = "a") df2 <- tibble(x = 2, y = factor("a")) full_join(df1, df2) %>% str() ``` Otherwise logicals will be silently upcast to integer, and integer to numeric, but coercing to character will raise an error: ```{r, error = TRUE, purl = FALSE} df1 <- tibble(x = 1, y = 1L) df2 <- tibble(x = 2, y = 1.5) full_join(df1, df2) %>% str() df1 <- tibble(x = 1, y = 1L) df2 <- tibble(x = 2, y = "a") full_join(df1, df2) %>% str() ``` ## Multiple-table verbs dplyr does not provide any functions for working with three or more tables. Instead use `purrr::reduce()` or `Reduce()`, as described in [Advanced R](http://adv-r.had.co.nz/Functionals.html#functionals-fp), to iteratively combine the two-table verbs to handle as many tables as you need. dplyr/inst/doc/dplyr.html0000644000176200001440000052151313614574172015167 0ustar liggesusers Introduction to dplyr

Introduction to dplyr

When working with data you must:

  • Figure out what you want to do.

  • Describe those tasks in the form of a computer program.

  • Execute the program.

The dplyr package makes these steps fast and easy:

  • By constraining your options, it helps you think about your data manipulation challenges.

  • It provides simple “verbs”, functions that correspond to the most common data manipulation tasks, to help you translate your thoughts into code.

  • It uses efficient backends, so you spend less time waiting for the computer.

This document introduces you to dplyr’s basic set of tools, and shows you how to apply them to data frames. dplyr also supports databases via the dbplyr package, once you’ve installed, read vignette("dbplyr") to learn more.

Data: nycflights13

To explore the basic data manipulation verbs of dplyr, we’ll use nycflights13::flights. This dataset contains all 336776 flights that departed from New York City in 2013. The data comes from the US Bureau of Transportation Statistics, and is documented in ?nycflights13

Note that nycflights13::flights is a tibble, a modern reimagining of the data frame. It’s particularly useful for large datasets because it only prints the first few rows. You can learn more about tibbles at http://tibble.tidyverse.org; in particular you can convert data frames to tibbles with as_tibble().

Single table verbs

Dplyr aims to provide a function for each basic verb of data manipulation:

  • filter() to select cases based on their values.
  • arrange() to reorder the cases.
  • select() and rename() to select variables based on their names.
  • mutate() and transmute() to add new variables that are functions of existing variables.
  • summarise() to condense multiple values to a single value.
  • sample_n() and sample_frac() to take random samples.

Filter rows with filter()

filter() allows you to select a subset of rows in a data frame. Like all single verbs, the first argument is the tibble (or data frame). The second and subsequent arguments refer to variables within that data frame, selecting rows where the expression is TRUE.

For example, we can select all flights on January 1st with:

This is rougly equivalent to this base R code:

Arrange rows with arrange()

arrange() works similarly to filter() except that instead of filtering or selecting rows, it reorders them. It takes a data frame, and a set of column names (or more complicated expressions) to order by. If you provide more than one column name, each additional column will be used to break ties in the values of preceding columns:

Use desc() to order a column in descending order:

Select columns with select()

Often you work with large datasets with many columns but only a few are actually of interest to you. select() allows you to rapidly zoom in on a useful subset using operations that usually only work on numeric variable positions:

There are a number of helper functions you can use within select(), like starts_with(), ends_with(), matches() and contains(). These let you quickly match larger blocks of variables that meet some criterion. See ?select for more details.

You can rename variables with select() by using named arguments:

But because select() drops all the variables not explicitly mentioned, it’s not that useful. Instead, use rename():

Add new columns with mutate()

Besides selecting sets of existing columns, it’s often useful to add new columns that are functions of existing columns. This is the job of mutate():

dplyr::mutate() is similar to the base transform(), but allows you to refer to columns that you’ve just created:

If you only want to keep the new variables, use transmute():

Summarise values with summarise()

The last verb is summarise(). It collapses a data frame to a single row.

It’s not that useful until we learn the group_by() verb below.

Commonalities

You may have noticed that the syntax and function of all these verbs are very similar:

  • The first argument is a data frame.

  • The subsequent arguments describe what to do with the data frame. You can refer to columns in the data frame directly without using $.

  • The result is a new data frame

Together these properties make it easy to chain together multiple simple steps to achieve a complex result.

These five functions provide the basis of a language of data manipulation. At the most basic level, you can only alter a tidy data frame in five useful ways: you can reorder the rows (arrange()), pick observations and variables of interest (filter() and select()), add new variables that are functions of existing variables (mutate()), or collapse many values to a summary (summarise()). The remainder of the language comes from applying the five functions to different types of data. For example, I’ll discuss how these functions work with grouped data.

Patterns of operations

The dplyr verbs can be classified by the type of operations they accomplish (we sometimes speak of their semantics, i.e., their meaning). The most important and useful distinction is between grouped and ungrouped operations. In addition, it is helpful to have a good grasp of the difference between select and mutate operations.

Grouped operations

The dplyr verbs are useful on their own, but they become even more powerful when you apply them to groups of observations within a dataset. In dplyr, you do this with the group_by() function. It breaks down a dataset into specified groups of rows. When you then apply the verbs above on the resulting object they’ll be automatically applied “by group”.

Grouping affects the verbs as follows:

  • grouped select() is the same as ungrouped select(), except that grouping variables are always retained.

  • grouped arrange() is the same as ungrouped; unless you set .by_group = TRUE, in which case it orders first by the grouping variables

  • mutate() and filter() are most useful in conjunction with window functions (like rank(), or min(x) == x). They are described in detail in vignette("window-functions").

  • sample_n() and sample_frac() sample the specified number/fraction of rows in each group.

  • summarise() computes the summary for each group.

In the following example, we split the complete dataset into individual planes and then summarise each plane by counting the number of flights (count = n()) and computing the average distance (dist = mean(distance, na.rm = TRUE)) and arrival delay (delay = mean(arr_delay, na.rm = TRUE)). We then use ggplot2 to display the output.

You use summarise() with aggregate functions, which take a vector of values and return a single number. There are many useful examples of such functions in base R like min(), max(), mean(), sum(), sd(), median(), and IQR(). dplyr provides a handful of others:

  • n(): the number of observations in the current group

  • n_distinct(x):the number of unique values in x.

  • first(x), last(x) and nth(x, n) - these work similarly to x[1], x[length(x)], and x[n] but give you more control over the result if the value is missing.

For example, we could use these to find the number of planes and the number of flights that go to each possible destination:

When you group by multiple variables, each summary peels off one level of the grouping. That makes it easy to progressively roll-up a dataset:

However you need to be careful when progressively rolling up summaries like this: it’s ok for sums and counts, but you need to think about weighting for means and variances (it’s not possible to do this exactly for medians).

Selecting operations

One of the appealing features of dplyr is that you can refer to columns from the tibble as if they were regular variables. However, the syntactic uniformity of referring to bare column names hides semantical differences across the verbs. A column symbol supplied to select() does not have the same meaning as the same symbol supplied to mutate().

Selecting operations expect column names and positions. Hence, when you call select() with bare variable names, they actually represent their own positions in the tibble. The following calls are completely equivalent from dplyr’s point of view:

By the same token, this means that you cannot refer to variables from the surrounding context if they have the same name as one of the columns. In the following example, year still represents 1, not 5:

One useful subtlety is that this only applies to bare names and to selecting calls like c(year, month, day) or year:day. In all other cases, the columns of the data frame are not put in scope. This allows you to refer to contextual variables in selection helpers:

These semantics are usually intuitive. But note the subtle difference:

In the first argument, year represents its own position 1. In the second argument, year is evaluated in the surrounding context and represents the fifth column.

For a long time, select() used to only understand column positions. Counting from dplyr 0.6, it now understands column names as well. This makes it a bit easier to program with select():

Note that the code above is somewhat unsafe because you might have added a column named vars to the tibble, or you might apply the code to another data frame containing such a column. To avoid this issue, you can wrap the variable in an identity() call as we mentioned above, as this will bypass column names. However, a more explicit and general method that works in all dplyr verbs is to unquote the variable with the !! operator. This tells dplyr to bypass the data frame and to directly look in the context:

This operator is very useful when you need to use dplyr within custom functions. You can learn more about it in vignette("programming"). However it is important to understand the semantics of the verbs you are unquoting into, that is, the values they understand. As we have just seen, select() supports names and positions of columns. But that won’t be the case in other verbs like mutate() because they have different semantics.

Mutating operations

Mutate semantics are quite different from selection semantics. Whereas select() expects column names or positions, mutate() expects column vectors. Let’s create a smaller tibble for clarity:

When we use select(), the bare column names stand for ther own positions in the tibble. For mutate() on the other hand, column symbols represent the actual column vectors stored in the tibble. Consider what happens if we give a string or a number to mutate():

mutate() gets length-1 vectors that it interprets as new columns in the data frame. These vectors are recycled so they match the number of rows. That’s why it doesn’t make sense to supply expressions like "year" + 10 to mutate(). This amounts to adding 10 to a string! The correct expression is:

In the same way, you can unquote values from the context if these values represent a valid column. They must be either length 1 (they then get recycled) or have the same length as the number of rows. In the following example we create a new vector that we add to the data frame:

A case in point is group_by(). While you might think it has select semantics, it actually has mutate semantics. This is quite handy as it allows to group by a modified column:

This is why you can’t supply a column name to group_by(). This amounts to creating a new column containing the string recycled to the number of rows:

Since grouping with select semantics can be sometimes useful as well, we have added the group_by_at() variant. In dplyr, variants suffixed with _at() support selection semantics in their second argument. You just need to wrap the selection with vars():

You can read more about the _at() and _if() variants in the ?scoped help page.

Piping

The dplyr API is functional in the sense that function calls don’t have side-effects. You must always save their results. This doesn’t lead to particularly elegant code, especially if you want to do many operations at once. You either have to do it step-by-step:

Or if you don’t want to name the intermediate results, you need to wrap the function calls inside each other:

This is difficult to read because the order of the operations is from inside to out. Thus, the arguments are a long way away from the function. To get around this problem, dplyr provides the %>% operator from magrittr. x %>% f(y) turns into f(x, y) so you can use it to rewrite multiple operations that you can read left-to-right, top-to-bottom:

Other data sources

As well as data frames, dplyr works with data that is stored in other ways, like data tables, databases and multidimensional arrays.

Data table

dplyr also provides data table methods for all verbs through dtplyr. If you’re using data.tables already this lets you to use dplyr syntax for data manipulation, and data.table for everything else.

For multiple operations, data.table can be faster because you usually use it with multiple verbs simultaneously. For example, with data table you can do a mutate and a select in a single step. It’s smart enough to know that there’s no point in computing the new variable for rows you’re about to throw away.

The advantages of using dplyr with data tables are:

  • For common data manipulation tasks, it insulates you from the reference semantics of data.tables, and protects you from accidentally modifying your data.

  • Instead of one complex method built on the subscripting operator ([), it provides many simple methods.

Databases

dplyr also allows you to use the same verbs with a remote database. It takes care of generating the SQL for you so that you can avoid the cognitive challenge of constantly switching between languages. To use these capabilities, you’ll need to install the dbplyr package and then read vignette("dbplyr") for the details.

Multidimensional arrays / cubes

tbl_cube() provides an experimental interface to multidimensional arrays or data cubes. If you’re using this form of data in R, please get in touch so I can better understand your needs.

Comparisons

Compared to all existing options, dplyr:

  • abstracts away how your data is stored, so that you can work with data frames, data tables and remote databases using the same set of functions. This lets you focus on what you want to achieve, not on the logistics of data storage.

  • provides a thoughtful default print() method that doesn’t automatically print pages of data to the screen (this was inspired by data table’s output).

Compared to base functions:

  • dplyr is much more consistent; functions have the same interface. So once you’ve mastered one, you can easily pick up the others

  • base functions tend to be based around vectors; dplyr is based around data frames

Compared to plyr, dplyr:

  • is much much faster

  • provides a better thought out set of joins

  • only provides tools for working with data frames (e.g. most of dplyr is equivalent to ddply() + various functions, do() is equivalent to dlply())

Compared to virtual data frame approaches:

  • it doesn’t pretend that you have a data frame: if you want to run lm etc, you’ll still need to manually pull down the data

  • it doesn’t provide methods for R summary functions (e.g. mean(), or sum())

dplyr/inst/doc/dplyr.Rmd0000644000176200001440000004670213451046652014743 0ustar liggesusers--- title: "Introduction to dplyr" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Introduction to dplyr} %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} --- ```{r, echo = FALSE, message = FALSE} knitr::opts_chunk$set(collapse = T, comment = "#>") options(tibble.print_min = 4L, tibble.print_max = 4L) library(dplyr) library(ggplot2) set.seed(1014) ``` When working with data you must: * Figure out what you want to do. * Describe those tasks in the form of a computer program. * Execute the program. The dplyr package makes these steps fast and easy: * By constraining your options, it helps you think about your data manipulation challenges. * It provides simple "verbs", functions that correspond to the most common data manipulation tasks, to help you translate your thoughts into code. * It uses efficient backends, so you spend less time waiting for the computer. This document introduces you to dplyr's basic set of tools, and shows you how to apply them to data frames. dplyr also supports databases via the dbplyr package, once you've installed, read `vignette("dbplyr")` to learn more. ## Data: nycflights13 To explore the basic data manipulation verbs of dplyr, we'll use `nycflights13::flights`. This dataset contains all `r nrow(nycflights13::flights)` flights that departed from New York City in 2013. The data comes from the US [Bureau of Transportation Statistics](http://www.transtats.bts.gov/DatabaseInfo.asp?DB_ID=120&Link=0), and is documented in `?nycflights13` ```{r} library(nycflights13) dim(flights) flights ``` Note that `nycflights13::flights` is a tibble, a modern reimagining of the data frame. It's particularly useful for large datasets because it only prints the first few rows. You can learn more about tibbles at ; in particular you can convert data frames to tibbles with `as_tibble()`. ## Single table verbs Dplyr aims to provide a function for each basic verb of data manipulation: * `filter()` to select cases based on their values. * `arrange()` to reorder the cases. * `select()` and `rename()` to select variables based on their names. * `mutate()` and `transmute()` to add new variables that are functions of existing variables. * `summarise()` to condense multiple values to a single value. * `sample_n()` and `sample_frac()` to take random samples. ### Filter rows with `filter()` `filter()` allows you to select a subset of rows in a data frame. Like all single verbs, the first argument is the tibble (or data frame). The second and subsequent arguments refer to variables within that data frame, selecting rows where the expression is `TRUE`. For example, we can select all flights on January 1st with: ```{r} filter(flights, month == 1, day == 1) ``` This is rougly equivalent to this base R code: ```{r, eval = FALSE} flights[flights$month == 1 & flights$day == 1, ] ``` ### Arrange rows with `arrange()` `arrange()` works similarly to `filter()` except that instead of filtering or selecting rows, it reorders them. It takes a data frame, and a set of column names (or more complicated expressions) to order by. If you provide more than one column name, each additional column will be used to break ties in the values of preceding columns: ```{r} arrange(flights, year, month, day) ``` Use `desc()` to order a column in descending order: ```{r} arrange(flights, desc(arr_delay)) ``` ### Select columns with `select()` Often you work with large datasets with many columns but only a few are actually of interest to you. `select()` allows you to rapidly zoom in on a useful subset using operations that usually only work on numeric variable positions: ```{r} # Select columns by name select(flights, year, month, day) # Select all columns between year and day (inclusive) select(flights, year:day) # Select all columns except those from year to day (inclusive) select(flights, -(year:day)) ``` There are a number of helper functions you can use within `select()`, like `starts_with()`, `ends_with()`, `matches()` and `contains()`. These let you quickly match larger blocks of variables that meet some criterion. See `?select` for more details. You can rename variables with `select()` by using named arguments: ```{r} select(flights, tail_num = tailnum) ``` But because `select()` drops all the variables not explicitly mentioned, it's not that useful. Instead, use `rename()`: ```{r} rename(flights, tail_num = tailnum) ``` ### Add new columns with `mutate()` Besides selecting sets of existing columns, it's often useful to add new columns that are functions of existing columns. This is the job of `mutate()`: ```{r} mutate(flights, gain = arr_delay - dep_delay, speed = distance / air_time * 60 ) ``` `dplyr::mutate()` is similar to the base `transform()`, but allows you to refer to columns that you've just created: ```{r} mutate(flights, gain = arr_delay - dep_delay, gain_per_hour = gain / (air_time / 60) ) ``` If you only want to keep the new variables, use `transmute()`: ```{r} transmute(flights, gain = arr_delay - dep_delay, gain_per_hour = gain / (air_time / 60) ) ``` ### Summarise values with `summarise()` The last verb is `summarise()`. It collapses a data frame to a single row. ```{r} summarise(flights, delay = mean(dep_delay, na.rm = TRUE) ) ``` It's not that useful until we learn the `group_by()` verb below. ### Randomly sample rows with `sample_n()` and `sample_frac()` You can use `sample_n()` and `sample_frac()` to take a random sample of rows: use `sample_n()` for a fixed number and `sample_frac()` for a fixed fraction. ```{r} sample_n(flights, 10) sample_frac(flights, 0.01) ``` Use `replace = TRUE` to perform a bootstrap sample. If needed, you can weight the sample with the `weight` argument. ### Commonalities You may have noticed that the syntax and function of all these verbs are very similar: * The first argument is a data frame. * The subsequent arguments describe what to do with the data frame. You can refer to columns in the data frame directly without using `$`. * The result is a new data frame Together these properties make it easy to chain together multiple simple steps to achieve a complex result. These five functions provide the basis of a language of data manipulation. At the most basic level, you can only alter a tidy data frame in five useful ways: you can reorder the rows (`arrange()`), pick observations and variables of interest (`filter()` and `select()`), add new variables that are functions of existing variables (`mutate()`), or collapse many values to a summary (`summarise()`). The remainder of the language comes from applying the five functions to different types of data. For example, I'll discuss how these functions work with grouped data. ## Patterns of operations The dplyr verbs can be classified by the type of operations they accomplish (we sometimes speak of their **semantics**, i.e., their meaning). The most important and useful distinction is between grouped and ungrouped operations. In addition, it is helpful to have a good grasp of the difference between select and mutate operations. ### Grouped operations The dplyr verbs are useful on their own, but they become even more powerful when you apply them to groups of observations within a dataset. In dplyr, you do this with the `group_by()` function. It breaks down a dataset into specified groups of rows. When you then apply the verbs above on the resulting object they'll be automatically applied "by group". Grouping affects the verbs as follows: * grouped `select()` is the same as ungrouped `select()`, except that grouping variables are always retained. * grouped `arrange()` is the same as ungrouped; unless you set `.by_group = TRUE`, in which case it orders first by the grouping variables * `mutate()` and `filter()` are most useful in conjunction with window functions (like `rank()`, or `min(x) == x`). They are described in detail in `vignette("window-functions")`. * `sample_n()` and `sample_frac()` sample the specified number/fraction of rows in each group. * `summarise()` computes the summary for each group. In the following example, we split the complete dataset into individual planes and then summarise each plane by counting the number of flights (`count = n()`) and computing the average distance (`dist = mean(distance, na.rm = TRUE)`) and arrival delay (`delay = mean(arr_delay, na.rm = TRUE)`). We then use ggplot2 to display the output. ```{r, warning = FALSE, message = FALSE, fig.width = 6} by_tailnum <- group_by(flights, tailnum) delay <- summarise(by_tailnum, count = n(), dist = mean(distance, na.rm = TRUE), delay = mean(arr_delay, na.rm = TRUE)) delay <- filter(delay, count > 20, dist < 2000) # Interestingly, the average delay is only slightly related to the # average distance flown by a plane. ggplot(delay, aes(dist, delay)) + geom_point(aes(size = count), alpha = 1/2) + geom_smooth() + scale_size_area() ``` You use `summarise()` with __aggregate functions__, which take a vector of values and return a single number. There are many useful examples of such functions in base R like `min()`, `max()`, `mean()`, `sum()`, `sd()`, `median()`, and `IQR()`. dplyr provides a handful of others: * `n()`: the number of observations in the current group * `n_distinct(x)`:the number of unique values in `x`. * `first(x)`, `last(x)` and `nth(x, n)` - these work similarly to `x[1]`, `x[length(x)]`, and `x[n]` but give you more control over the result if the value is missing. For example, we could use these to find the number of planes and the number of flights that go to each possible destination: ```{r} destinations <- group_by(flights, dest) summarise(destinations, planes = n_distinct(tailnum), flights = n() ) ``` When you group by multiple variables, each summary peels off one level of the grouping. That makes it easy to progressively roll-up a dataset: ```{r} daily <- group_by(flights, year, month, day) (per_day <- summarise(daily, flights = n())) (per_month <- summarise(per_day, flights = sum(flights))) (per_year <- summarise(per_month, flights = sum(flights))) ``` However you need to be careful when progressively rolling up summaries like this: it's ok for sums and counts, but you need to think about weighting for means and variances (it's not possible to do this exactly for medians). ### Selecting operations One of the appealing features of dplyr is that you can refer to columns from the tibble as if they were regular variables. However, the syntactic uniformity of referring to bare column names hides semantical differences across the verbs. A column symbol supplied to `select()` does not have the same meaning as the same symbol supplied to `mutate()`. Selecting operations expect column names and positions. Hence, when you call `select()` with bare variable names, they actually represent their own positions in the tibble. The following calls are completely equivalent from dplyr's point of view: ```{r} # `year` represents the integer 1 select(flights, year) select(flights, 1) ``` By the same token, this means that you cannot refer to variables from the surrounding context if they have the same name as one of the columns. In the following example, `year` still represents 1, not 5: ```r year <- 5 select(flights, year) ``` One useful subtlety is that this only applies to bare names and to selecting calls like `c(year, month, day)` or `year:day`. In all other cases, the columns of the data frame are not put in scope. This allows you to refer to contextual variables in selection helpers: ```{r} year <- "dep" select(flights, starts_with(year)) ``` These semantics are usually intuitive. But note the subtle difference: ```{r} year <- 5 select(flights, year, identity(year)) ``` In the first argument, `year` represents its own position `1`. In the second argument, `year` is evaluated in the surrounding context and represents the fifth column. For a long time, `select()` used to only understand column positions. Counting from dplyr 0.6, it now understands column names as well. This makes it a bit easier to program with `select()`: ```{r} vars <- c("year", "month") select(flights, vars, "day") ``` Note that the code above is somewhat unsafe because you might have added a column named `vars` to the tibble, or you might apply the code to another data frame containing such a column. To avoid this issue, you can wrap the variable in an `identity()` call as we mentioned above, as this will bypass column names. However, a more explicit and general method that works in all dplyr verbs is to unquote the variable with the `!!` operator. This tells dplyr to bypass the data frame and to directly look in the context: ```{r} # Let's create a new `vars` column: flights$vars <- flights$year # The new column won't be an issue if you evaluate `vars` in the # context with the `!!` operator: vars <- c("year", "month", "day") select(flights, !! vars) ``` This operator is very useful when you need to use dplyr within custom functions. You can learn more about it in `vignette("programming")`. However it is important to understand the semantics of the verbs you are unquoting into, that is, the values they understand. As we have just seen, `select()` supports names and positions of columns. But that won't be the case in other verbs like `mutate()` because they have different semantics. ### Mutating operations Mutate semantics are quite different from selection semantics. Whereas `select()` expects column names or positions, `mutate()` expects *column vectors*. Let's create a smaller tibble for clarity: ```{r} df <- select(flights, year:dep_time) ``` When we use `select()`, the bare column names stand for ther own positions in the tibble. For `mutate()` on the other hand, column symbols represent the actual column vectors stored in the tibble. Consider what happens if we give a string or a number to `mutate()`: ```{r} mutate(df, "year", 2) ``` `mutate()` gets length-1 vectors that it interprets as new columns in the data frame. These vectors are recycled so they match the number of rows. That's why it doesn't make sense to supply expressions like `"year" + 10` to `mutate()`. This amounts to adding 10 to a string! The correct expression is: ```{r} mutate(df, year + 10) ``` In the same way, you can unquote values from the context if these values represent a valid column. They must be either length 1 (they then get recycled) or have the same length as the number of rows. In the following example we create a new vector that we add to the data frame: ```{r} var <- seq(1, nrow(df)) mutate(df, new = var) ``` A case in point is `group_by()`. While you might think it has select semantics, it actually has mutate semantics. This is quite handy as it allows to group by a modified column: ```{r} group_by(df, month) group_by(df, month = as.factor(month)) group_by(df, day_binned = cut(day, 3)) ``` This is why you can't supply a column name to `group_by()`. This amounts to creating a new column containing the string recycled to the number of rows: ```{r} group_by(df, "month") ``` Since grouping with select semantics can be sometimes useful as well, we have added the `group_by_at()` variant. In dplyr, variants suffixed with `_at()` support selection semantics in their second argument. You just need to wrap the selection with `vars()`: ```{r} group_by_at(df, vars(year:day)) ``` You can read more about the `_at()` and `_if()` variants in the `?scoped` help page. ## Piping The dplyr API is functional in the sense that function calls don't have side-effects. You must always save their results. This doesn't lead to particularly elegant code, especially if you want to do many operations at once. You either have to do it step-by-step: ```{r, eval = FALSE} a1 <- group_by(flights, year, month, day) a2 <- select(a1, arr_delay, dep_delay) a3 <- summarise(a2, arr = mean(arr_delay, na.rm = TRUE), dep = mean(dep_delay, na.rm = TRUE)) a4 <- filter(a3, arr > 30 | dep > 30) ``` Or if you don't want to name the intermediate results, you need to wrap the function calls inside each other: ```{r} filter( summarise( select( group_by(flights, year, month, day), arr_delay, dep_delay ), arr = mean(arr_delay, na.rm = TRUE), dep = mean(dep_delay, na.rm = TRUE) ), arr > 30 | dep > 30 ) ``` This is difficult to read because the order of the operations is from inside to out. Thus, the arguments are a long way away from the function. To get around this problem, dplyr provides the `%>%` operator from magrittr. `x %>% f(y)` turns into `f(x, y)` so you can use it to rewrite multiple operations that you can read left-to-right, top-to-bottom: ```{r, eval = FALSE} flights %>% group_by(year, month, day) %>% select(arr_delay, dep_delay) %>% summarise( arr = mean(arr_delay, na.rm = TRUE), dep = mean(dep_delay, na.rm = TRUE) ) %>% filter(arr > 30 | dep > 30) ``` ## Other data sources As well as data frames, dplyr works with data that is stored in other ways, like data tables, databases and multidimensional arrays. ### Data table dplyr also provides [data table](http://datatable.r-forge.r-project.org/) methods for all verbs through [dtplyr](http://github.com/hadley/dtplyr). If you're using data.tables already this lets you to use dplyr syntax for data manipulation, and data.table for everything else. For multiple operations, data.table can be faster because you usually use it with multiple verbs simultaneously. For example, with data table you can do a mutate and a select in a single step. It's smart enough to know that there's no point in computing the new variable for rows you're about to throw away. The advantages of using dplyr with data tables are: * For common data manipulation tasks, it insulates you from the reference semantics of data.tables, and protects you from accidentally modifying your data. * Instead of one complex method built on the subscripting operator (`[`), it provides many simple methods. ### Databases dplyr also allows you to use the same verbs with a remote database. It takes care of generating the SQL for you so that you can avoid the cognitive challenge of constantly switching between languages. To use these capabilities, you'll need to install the dbplyr package and then read `vignette("dbplyr")` for the details. ### Multidimensional arrays / cubes `tbl_cube()` provides an experimental interface to multidimensional arrays or data cubes. If you're using this form of data in R, please get in touch so I can better understand your needs. ## Comparisons Compared to all existing options, dplyr: * abstracts away how your data is stored, so that you can work with data frames, data tables and remote databases using the same set of functions. This lets you focus on what you want to achieve, not on the logistics of data storage. * provides a thoughtful default `print()` method that doesn't automatically print pages of data to the screen (this was inspired by data table's output). Compared to base functions: * dplyr is much more consistent; functions have the same interface. So once you've mastered one, you can easily pick up the others * base functions tend to be based around vectors; dplyr is based around data frames Compared to plyr, dplyr: * is much much faster * provides a better thought out set of joins * only provides tools for working with data frames (e.g. most of dplyr is equivalent to `ddply()` + various functions, `do()` is equivalent to `dlply()`) Compared to virtual data frame approaches: * it doesn't pretend that you have a data frame: if you want to run lm etc, you'll still need to manually pull down the data * it doesn't provide methods for R summary functions (e.g. `mean()`, or `sum()`) dplyr/inst/doc/two-table.html0000644000176200001440000013654013614574174015737 0ustar liggesusers Two-table verbs

Two-table verbs

It’s rare that a data analysis involves only a single table of data. In practice, you’ll normally have many tables that contribute to an analysis, and you need flexible tools to combine them. In dplyr, there are three families of verbs that work with two tables at a time:

  • Mutating joins, which add new variables to one table from matching rows in another.

  • Filtering joins, which filter observations from one table based on whether or not they match an observation in the other table.

  • Set operations, which combine the observations in the data sets as if they were set elements.

(This discussion assumes that you have tidy data, where the rows are observations and the columns are variables. If you’re not familiar with that framework, I’d recommend reading up on it first.)

All two-table verbs work similarly. The first two arguments are x and y, and provide the tables to combine. The output is always a new table with the same type as x.

Mutating joins

Mutating joins allow you to combine variables from multiple tables. For example, take the nycflights13 data. In one table we have flight information with an abbreviation for carrier, and in another we have a mapping between abbreviations and full names. You can use a join to add the carrier names to the flight data:

Controlling how the tables are matched

As well as x and y, each mutating join takes an argument by that controls which variables are used to match observations in the two tables. There are a few ways to specify it, as I illustrate below with various tables from nycflights13:

Types of join

There are four types of mutating join, which differ in their behaviour when a match is not found. We’ll illustrate each with a simple example:

x y a b
1 2 10 a
  • left_join(x, y) includes all observations in x, regardless of whether they match or not. This is the most commonly used join because it ensures that you don’t lose observations from your primary table.

  • right_join(x, y) includes all observations in y. It’s equivalent to left_join(y, x), but the columns will be ordered differently.

  • full_join() includes all observations from x and y.

  • The left, right and full joins are collectively know as outer joins. When a row doesn’t match in an outer join, the new variables are filled in with missing values.

    Observations

    While mutating joins are primarily used to add new variables, they can also generate new observations. If a match is not unique, a join will add all possible combinations (the Cartesian product) of the matching observations:

    Filtering joins

    Filtering joins match obserations in the same way as mutating joins, but affect the observations, not the variables. There are two types:

    • semi_join(x, y) keeps all observations in x that have a match in y.
    • anti_join(x, y) drops all observations in x that have a match in y.

    These are most useful for diagnosing join mismatches. For example, there are many flights in the nycflights13 dataset that don’t have a matching tail number in the planes table:

    If you’re worried about what observations your joins will match, start with a semi_join() or anti_join(). semi_join() and anti_join() never duplicate; they only ever remove observations.

    Set operations

    The final type of two-table verb is set operations. These expect the x and y inputs to have the same variables, and treat the observations like sets:

    • intersect(x, y): return only observations in both x and y
    • union(x, y): return unique observations in x and y
    • setdiff(x, y): return observations in x, but not in y.

    Given this simple data:

    The four possibilities are:

    Coercion rules

    When joining tables, dplyr is a little more conservative than base R about the types of variable that it considers equivalent. This is mostly likely to surprise if you’re working factors:

    Otherwise logicals will be silently upcast to integer, and integer to numeric, but coercing to character will raise an error:

    Multiple-table verbs

    dplyr does not provide any functions for working with three or more tables. Instead use purrr::reduce() or Reduce(), as described in Advanced R, to iteratively combine the two-table verbs to handle as many tables as you need.

    dplyr/inst/doc/window-functions.html0000644000176200001440000010075613614574175017357 0ustar liggesusers Window functions

    Window functions

    A window function is a variation on an aggregation function. Where an aggregation function, like sum() and mean(), takes n inputs and return a single value, a window function returns n values. The output of a window function depends on all its input values, so window functions don’t include functions that work element-wise, like + or round(). Window functions include variations on aggregate functions, like cumsum() and cummean(), functions for ranking and ordering, like rank(), and functions for taking offsets, like lead() and lag().

    In this vignette, we’ll use a small sample of the Lahman batting dataset, including the players that have won an award.

    Window functions are used in conjunction with mutate() and filter() to solve a wide range of problems. Here’s a selection:

    Before reading this vignette, you should be familiar with mutate() and filter().

    Types of window functions

    There are five main families of window functions. Two families are unrelated to aggregation functions:

    • Ranking and ordering functions: row_number(), min_rank(), dense_rank(), cume_dist(), percent_rank(), and ntile(). These functions all take a vector to order by, and return various types of ranks.

    • Offsets lead() and lag() allow you to access the previous and next values in a vector, making it easy to compute differences and trends.

    The other three families are variations on familiar aggregate functions:

    • Cumulative aggregates: cumsum(), cummin(), cummax() (from base R), and cumall(), cumany(), and cummean() (from dplyr).

    • Rolling aggregates operate in a fixed width window. You won’t find them in base R or in dplyr, but there are many implementations in other packages, such as RcppRoll.

    • Recycled aggregates, where an aggregate is repeated to match the length of the input. These are not needed in R because vector recycling automatically recycles aggregates where needed. They are important in SQL, because the presence of an aggregation function usually tells the database to return only one row per group.

    Each family is described in more detail below, focussing on the general goals and how to use them with dplyr. For more details, refer to the individual function documentation.

    Ranking functions

    The ranking functions are variations on a theme, differing in how they handle ties:

    If you’re familiar with R, you may recognise that row_number() and min_rank() can be computed with the base rank() function and various values of the ties.method argument. These functions are provided to save a little typing, and to make it easier to convert between R and SQL.

    Two other ranking functions return numbers between 0 and 1. percent_rank() gives the percentage of the rank; cume_dist() gives the proportion of values less than or equal to the current value.

    These are useful if you want to select (for example) the top 10% of records within each group. For example:

    Finally, ntile() divides the data up into n evenly sized buckets. It’s a coarse ranking, and it can be used in with mutate() to divide the data into buckets for further summary. For example, we could use ntile() to divide the players within a team into four ranked groups, and calculate the average number of games within each group.

    All ranking functions rank from lowest to highest so that small input values get small ranks. Use desc() to rank from highest to lowest.

    Lead and lag

    lead() and lag() produce offset versions of a input vector that is either ahead of or behind the original vector.

    You can use them to:

    lead() and lag() have an optional argument order_by. If set, instead of using the row order to determine which value comes before another, they will use another variable. This is important if you have not already sorted the data, or you want to sort one way and lag another.

    Here’s a simple example of what happens if you don’t specify order_by when you need it:

    Cumulative aggregates

    Base R provides cumulative sum (cumsum()), cumulative min (cummin()), and cumulative max (cummax()). (It also provides cumprod() but that is rarely useful). Other common accumulating functions are cumany() and cumall(), cumulative versions of || and &&, and cummean(), a cumulative mean. These are not included in base R, but efficient versions are provided by dplyr.

    cumany() and cumall() are useful for selecting all rows up to, or all rows after, a condition is true for the first (or last) time. For example, we can use cumany() to find all records for a player after they played a year with 150 games:

    Like lead and lag, you may want to control the order in which the accumulation occurs. None of the built in functions have an order_by argument so dplyr provides a helper: order_by(). You give it the variable you want to order by, and then the call to the window function:

    This function uses a bit of non-standard evaluation, so I wouldn’t recommend using it inside another function; use the simpler but less concise with_order() instead.

    Recycled aggregates

    R’s vector recycling makes it easy to select values that are higher or lower than a summary. I call this a recycled aggregate because the value of the aggregate is recycled to be the same length as the original vector. Recycled aggregates are useful if you want to find all records greater than the mean or less than the median:

    While most SQL databases don’t have an equivalent of median() or quantile(), when filtering you can achieve the same effect with ntile(). For example, x > median(x) is equivalent to ntile(x, 2) == 2; x > quantile(x, 75) is equivalent to ntile(x, 100) > 75 or ntile(x, 4) > 3.

    You can also use this idea to select the records with the highest (x == max(x)) or lowest value (x == min(x)) for a field, but the ranking functions give you more control over ties, and allow you to select any number of records.

    Recycled aggregates are also useful in conjunction with mutate(). For example, with the batting data, we could compute the “career year”, the number of years a player has played since they entered the league:

    Or, as in the introductory example, we could compute a z-score:

    dplyr/inst/doc/two-table.R0000644000176200001440000000661713614574173015174 0ustar liggesusers## ---- echo = FALSE, message = FALSE-------------------------------------- knitr::opts_chunk$set(collapse = T, comment = "#>") options(tibble.print_min = 5) library(dplyr) knit_print.tbl_df <- function(x, options) { knitr::knit_print(trunc_mat(x), options) } ## ---- warning = FALSE---------------------------------------------------- library("nycflights13") # Drop unimportant variables so it's easier to understand the join results. flights2 <- flights %>% select(year:day, hour, origin, dest, tailnum, carrier) flights2 %>% left_join(airlines) ## ------------------------------------------------------------------------ flights2 %>% left_join(weather) ## ------------------------------------------------------------------------ flights2 %>% left_join(planes, by = "tailnum") ## ------------------------------------------------------------------------ flights2 %>% left_join(airports, c("dest" = "faa")) flights2 %>% left_join(airports, c("origin" = "faa")) ## ------------------------------------------------------------------------ df1 <- tibble(x = c(1, 2), y = 2:1) df2 <- tibble(x = c(1, 3), a = 10, b = "a") ## ------------------------------------------------------------------------ df1 %>% inner_join(df2) %>% knitr::kable() ## ------------------------------------------------------------------------ df1 %>% left_join(df2) ## ------------------------------------------------------------------------ df1 %>% right_join(df2) df2 %>% left_join(df1) ## ------------------------------------------------------------------------ df1 %>% full_join(df2) ## ------------------------------------------------------------------------ df1 <- tibble(x = c(1, 1, 2), y = 1:3) df2 <- tibble(x = c(1, 1, 2), z = c("a", "b", "a")) df1 %>% left_join(df2) ## ------------------------------------------------------------------------ library("nycflights13") flights %>% anti_join(planes, by = "tailnum") %>% count(tailnum, sort = TRUE) ## ------------------------------------------------------------------------ df1 <- tibble(x = c(1, 1, 3, 4), y = 1:4) df2 <- tibble(x = c(1, 1, 2), z = c("a", "b", "a")) # Four rows to start with: df1 %>% nrow() # And we get four rows after the join df1 %>% inner_join(df2, by = "x") %>% nrow() # But only two rows actually match df1 %>% semi_join(df2, by = "x") %>% nrow() ## ------------------------------------------------------------------------ (df1 <- tibble(x = 1:2, y = c(1L, 1L))) (df2 <- tibble(x = 1:2, y = 1:2)) ## ------------------------------------------------------------------------ intersect(df1, df2) # Note that we get 3 rows, not 4 union(df1, df2) setdiff(df1, df2) setdiff(df2, df1) ## ------------------------------------------------------------------------ df1 <- tibble(x = 1, y = factor("a")) df2 <- tibble(x = 2, y = factor("b")) full_join(df1, df2) %>% str() ## ------------------------------------------------------------------------ df1 <- tibble(x = 1, y = factor("a", levels = c("a", "b"))) df2 <- tibble(x = 2, y = factor("b", levels = c("b", "a"))) full_join(df1, df2) %>% str() ## ------------------------------------------------------------------------ df1 <- tibble(x = 1, y = factor("a", levels = c("a", "b"))) df2 <- tibble(x = 2, y = factor("b", levels = c("a", "b"))) full_join(df1, df2) %>% str() ## ------------------------------------------------------------------------ df1 <- tibble(x = 1, y = "a") df2 <- tibble(x = 2, y = factor("a")) full_join(df1, df2) %>% str() dplyr/inst/doc/programming.html0000644000176200001440000022234413614574173016360 0ustar liggesusers Programming with dplyr

    Programming with dplyr

    Most dplyr functions use non-standard evaluation (NSE). This is a catch-all term that means they don’t follow the usual R rules of evaluation. Instead, they capture the expression that you typed and evaluate it in a custom way. This has two main benefits for dplyr code:

    • Operations on data frames can be expressed succinctly because you don’t need to repeat the name of the data frame. For example, you can write filter(df, x == 1, y == 2, z == 3) instead of df[df$x == 1 & df$y ==2 & df$z == 3, ].

    • dplyr can choose to compute results in a different way to base R. This is important for database backends because dplyr itself doesn’t do any work, but instead generates the SQL that tells the database what to do.

    Unfortunately these benefits do not come for free. There are two main drawbacks:

    Fortunately, dplyr provides tools to overcome these challenges. They require a little more typing, but a small amount of upfront work is worth it because they help you save time in the long run.

    This vignette has two goals:

    • Show you how to use dplyr’s pronouns and quasiquotation to write reliable functions that reduce duplication in your data analysis code.

    • To teach you the underlying theory including quosures, the data structure that stores both an expression and an environment, and tidyeval, the underlying toolkit.

    We’ll start with a warmup, tying this problem to something you’re more familiar with, then move on to some practical tools, then dive into the deeper theory.

    Warm up

    You might not have realised it, but you’re already accomplished at solving this type of problem in another domain: strings. It’s obvious that this function doesn’t do what you want:

    That’s because " “quotes” its input: it doesn’t interpret what you’ve typed, it just stores it in a string. One way to make the function do what you want is to use paste() to build up the string piece by piece:

    Another approach is exemplified by the glue package: it allows you to “unquote” components of a string, replacing the string with the value of the R expression. This allows an elegant implementation of our function because {name} is replaced with the value of the name argument.

    Programming recipes

    The following recipes walk you through the basics of tidyeval, with the nominal goal of reducing duplication in dplyr code. The examples here are somewhat inauthentic because we’ve reduced them down to very simple components to make them easier to understand. They’re so simple that you might wonder why we bother writing a function at all. But it’s a good idea to learn the ideas on simple examples, so that you’re better prepared to apply them to the more complex situations you’ll see in your own code.

    Different data sets

    You already know how to write functions that work with the first argument of dplyr verbs: the data. That’s because dplyr doesn’t do anything special with that argument, so it’s referentially transparent. For example, if you saw repeated code like this:

    You could already write a function to capture that duplication:

    Unfortunately, there’s a drawback to this simple approach: it can fail silently if one of the variables isn’t present in the data frame, but is present in the global environment.

    We can fix that ambiguity by being more explicit and using the .data pronoun. This will throw an informative error if the variable doesn’t exist:

    If this function is in a package, using .data also prevents R CMD check from giving a NOTE about undefined global variables (provided that you’ve also imported rlang::.data with @importFrom rlang .data).

    Different expressions

    Writing a function is hard if you want one of the arguments to be a variable name (like x) or an expression (like x + y). That’s because dplyr automatically “quotes” those inputs, so they are not referentially transparent. Let’s start with a simple case: you want to vary the grouping variable for a data summarization.

    You might hope that this will work:

    But it doesn’t.

    Maybe providing the variable name as a string will fix things?

    Nope.

    If you look carefully at the error message, you’ll see that it’s the same in both cases. group_by() works like ": it doesn’t evaluate its input; it quotes it.

    To make this function work, we need to do two things. We need to quote the input ourselves (so my_summarise() can take a bare variable name like group_by()), and then we need to tell group_by() not to quote its input (because we’ve done the quoting).

    How do we quote the input? We can’t use "" to quote the input, because that gives us a string. Instead we need a function that captures the expression and its environment (we’ll come back to why this is important later on). There are two possible options we could use in base R, the function quote() and the operator ~. Neither of these work quite the way we want, so we need a new function: quo().

    quo() works like ": it quotes its input rather than evaluating it.

    quo() returns a quosure, which is a special type of formula. You’ll learn more about quosures later on.

    Now that we’ve captured this expression, how do we use it with group_by()? It doesn’t work if we just shove it into our naive approach:

    We get the same error as before, because we haven’t yet told group_by() that we’re taking care of the quoting. In other words, we need to tell group_by() not to quote its input, because it has been pre-quoted by my_summarise(). Yet another way of saying the same thing is that we want to unquote group_var.

    In dplyr (and in tidyeval in general) you use !! to say that you want to unquote an input so that it’s evaluated, not quoted. This gives us a function that actually does what we want.

    Huzzah!

    There’s just one step left: we want to call this function like we call group_by():

    This doesn’t work because there’s no object called g1. We need to capture what the user of the function typed and quote it for them. You might try using quo() to do that:

    I’ve added a print() call to make it obvious what’s going wrong here: quo(group_var) always returns ~group_var. It is being too literal! We want it to substitute the value that the user supplied, i.e. to return ~g1.

    By analogy to strings, we don’t want "", instead we want some function that turns an argument into a string. That’s the job of enquo(). enquo() uses some dark magic to look at the argument, see what the user typed, and return that value as a quosure. (Technically, this works because function arguments are evaluated lazily, using a special data structure called a promise.)

    (If you’re familiar with quote() and substitute() in base R, quo() is equivalent to quote() and enquo() is equivalent to substitute().)

    You might wonder how to extend this to handle multiple grouping variables: we’ll come back to that a little later.

    Different input variable

    Now let’s tackle something a bit more complicated. The code below shows a duplicate summarise() statement where we compute three summaries, varying the input variable.

    To turn this into a function, we start by testing the basic approach interactively: we quote the variable with quo(), then unquoting it in the dplyr call with !!. Notice that we can unquote anywhere inside a complicated expression.

    You can also wrap quo() around the dplyr call to see what will happen from dplyr’s perspective. This is a very useful tool for debugging.

    Now we can turn our code into a function (remembering to replace quo() with enquo()), and check that it works:

    Capturing multiple variables

    It would be nice to extend my_summarise() to accept any number of grouping variables. We need to make three changes:

    • Use ... in the function definition so our function can accept any number of arguments.

    • Use enquos() to capture all the ... as a list of formulas.

    • Use !!! instead of !! to splice the arguments into group_by().

    !!! takes a list of elements and splices them into to the current call. Look at the bottom of the !!! and think ....

    Now that you’ve learned the basics of tidyeval through some practical examples, we’ll dive into the theory. This will help you generalise what you’ve learned here to new situations.

    Quoting

    Quoting is the action of capturing an expression instead of evaluating it. All expression-based functions quote their arguments and get the R code as an expression rather than the result of evaluating that code. If you are an R user, you probably quote expressions on a regular basis. One of the most important quoting operators in R is the formula. It is famously used for the specification of statistical models:

    The other quoting operator in base R is quote(). It returns a raw expression rather than a formula:

    (Note that despite being called the double quote, " is not a quoting operator in this context, because it generates a string, not an expression.)

    In practice, the formula is the better of the two options because it captures the code and its execution environment. This is important because even simple expression can yield different values in different environments. For example, the x in the following two expressions refers to different values:

    It might look like the expressions are the same if you print them out.

    But if you inspect the environments using rlang::get_env() — they’re different.

    Further, when we evaluate those formulas using rlang::eval_tidy(), we see that they yield different values:

    This is a key property of R: one name can refer to different values in different environments. This is also important for dplyr, because it allows you to combine variables and objects in a call:

    When an object keeps track of an environment, it is said to have an enclosure. This is the reason that functions in R are sometimes referred to as closures:

    For this reason we use a special name to refer to one-sided formulas: quosures. One-sided formulas are quotes (they carry an expression) with an environment.

    Quosures are regular R objects. They can be stored in a variable and inspected:

    Quasiquotation

    Put simply, quasi-quotation enables one to introduce symbols that stand for a linguistic expression in a given instance and are used as that linguistic expression in a different instance. — Willard van Orman Quine

    Automatic quoting makes dplyr very convenient for interactive use. But if you want to program with dplyr, you need some way to refer to variables indirectly. The solution to this problem is quasiquotation, which allows you to evaluate directly inside an expression that is otherwise quoted.

    Quasiquotation was coined by Willard van Orman Quine in the 1940s, and was adopted for programming by the LISP community in the 1970s. All expression-based functions in the tidyeval framework support quasiquotation. Unquoting cancels quotation of parts of an expression. There are three types of unquoting:

    • basic
    • unquote splicing
    • unquoting names

    Unquoting

    The first important operation is the basic unquote, which comes in a functional form, UQ(), and as syntactic-sugar, !!.

    It is also possible to unquote other quoted expressions. Unquoting such symbolic objects provides a powerful way of manipulating expressions.

    You can safely unquote quosures because they track their environments, and tidyeval functions know how to evaluate them. This allows any depth of quoting and unquoting.

    The functional form is useful in cases where the precedence of ! causes problems:

    Unquote-splicing

    The second unquote operation is unquote-splicing. Its functional form is UQS() and the syntactic shortcut is !!!. It takes a vector and inserts each element of the vector in the surrounding function call:

    A very useful feature of unquote-splicing is that the vector names become argument names:

    This makes it easy to program with dplyr verbs that take named dots:

    Setting variable names

    The final unquote operation is setting argument names. You’ve seen one way to do that above, but you can also use the definition operator := instead of =. := supports unquoting on both the LHS and the RHS.

    The rules on the LHS are slightly different: the unquoted operand should evaluate to a string or a symbol.

    dplyr/inst/doc/dplyr.R0000644000176200001440000001306713614574172014424 0ustar liggesusers## ---- echo = FALSE, message = FALSE-------------------------------------- knitr::opts_chunk$set(collapse = T, comment = "#>") options(tibble.print_min = 4L, tibble.print_max = 4L) library(dplyr) library(ggplot2) set.seed(1014) ## ------------------------------------------------------------------------ library(nycflights13) dim(flights) flights ## ------------------------------------------------------------------------ filter(flights, month == 1, day == 1) ## ---- eval = FALSE------------------------------------------------------- # flights[flights$month == 1 & flights$day == 1, ] ## ------------------------------------------------------------------------ arrange(flights, year, month, day) ## ------------------------------------------------------------------------ arrange(flights, desc(arr_delay)) ## ------------------------------------------------------------------------ # Select columns by name select(flights, year, month, day) # Select all columns between year and day (inclusive) select(flights, year:day) # Select all columns except those from year to day (inclusive) select(flights, -(year:day)) ## ------------------------------------------------------------------------ select(flights, tail_num = tailnum) ## ------------------------------------------------------------------------ rename(flights, tail_num = tailnum) ## ------------------------------------------------------------------------ mutate(flights, gain = arr_delay - dep_delay, speed = distance / air_time * 60 ) ## ------------------------------------------------------------------------ mutate(flights, gain = arr_delay - dep_delay, gain_per_hour = gain / (air_time / 60) ) ## ------------------------------------------------------------------------ transmute(flights, gain = arr_delay - dep_delay, gain_per_hour = gain / (air_time / 60) ) ## ------------------------------------------------------------------------ summarise(flights, delay = mean(dep_delay, na.rm = TRUE) ) ## ------------------------------------------------------------------------ sample_n(flights, 10) sample_frac(flights, 0.01) ## ---- warning = FALSE, message = FALSE, fig.width = 6-------------------- by_tailnum <- group_by(flights, tailnum) delay <- summarise(by_tailnum, count = n(), dist = mean(distance, na.rm = TRUE), delay = mean(arr_delay, na.rm = TRUE)) delay <- filter(delay, count > 20, dist < 2000) # Interestingly, the average delay is only slightly related to the # average distance flown by a plane. ggplot(delay, aes(dist, delay)) + geom_point(aes(size = count), alpha = 1/2) + geom_smooth() + scale_size_area() ## ------------------------------------------------------------------------ destinations <- group_by(flights, dest) summarise(destinations, planes = n_distinct(tailnum), flights = n() ) ## ------------------------------------------------------------------------ daily <- group_by(flights, year, month, day) (per_day <- summarise(daily, flights = n())) (per_month <- summarise(per_day, flights = sum(flights))) (per_year <- summarise(per_month, flights = sum(flights))) ## ------------------------------------------------------------------------ # `year` represents the integer 1 select(flights, year) select(flights, 1) ## ------------------------------------------------------------------------ year <- "dep" select(flights, starts_with(year)) ## ------------------------------------------------------------------------ year <- 5 select(flights, year, identity(year)) ## ------------------------------------------------------------------------ vars <- c("year", "month") select(flights, vars, "day") ## ------------------------------------------------------------------------ # Let's create a new `vars` column: flights$vars <- flights$year # The new column won't be an issue if you evaluate `vars` in the # context with the `!!` operator: vars <- c("year", "month", "day") select(flights, !! vars) ## ------------------------------------------------------------------------ df <- select(flights, year:dep_time) ## ------------------------------------------------------------------------ mutate(df, "year", 2) ## ------------------------------------------------------------------------ mutate(df, year + 10) ## ------------------------------------------------------------------------ var <- seq(1, nrow(df)) mutate(df, new = var) ## ------------------------------------------------------------------------ group_by(df, month) group_by(df, month = as.factor(month)) group_by(df, day_binned = cut(day, 3)) ## ------------------------------------------------------------------------ group_by(df, "month") ## ------------------------------------------------------------------------ group_by_at(df, vars(year:day)) ## ---- eval = FALSE------------------------------------------------------- # a1 <- group_by(flights, year, month, day) # a2 <- select(a1, arr_delay, dep_delay) # a3 <- summarise(a2, # arr = mean(arr_delay, na.rm = TRUE), # dep = mean(dep_delay, na.rm = TRUE)) # a4 <- filter(a3, arr > 30 | dep > 30) ## ------------------------------------------------------------------------ filter( summarise( select( group_by(flights, year, month, day), arr_delay, dep_delay ), arr = mean(arr_delay, na.rm = TRUE), dep = mean(dep_delay, na.rm = TRUE) ), arr > 30 | dep > 30 ) ## ---- eval = FALSE------------------------------------------------------- # flights %>% # group_by(year, month, day) %>% # select(arr_delay, dep_delay) %>% # summarise( # arr = mean(arr_delay, na.rm = TRUE), # dep = mean(dep_delay, na.rm = TRUE) # ) %>% # filter(arr > 30 | dep > 30) dplyr/inst/doc/window-functions.R0000644000176200001440000000656413614574174016615 0ustar liggesusers## ---- include = FALSE---------------------------------------------------- knitr::opts_chunk$set(collapse = T, comment = "#>") options(tibble.print_min = 4L, tibble.print_max = 4L) library(dplyr) set.seed(1014) ## ------------------------------------------------------------------------ library(Lahman) batting <- Lahman::Batting %>% as_tibble() %>% select(playerID, yearID, teamID, G, AB:H) %>% arrange(playerID, yearID, teamID) %>% semi_join(Lahman::AwardsPlayers, by = "playerID") players <- batting %>% group_by(playerID) ## ---- eval = FALSE------------------------------------------------------- # # For each player, find the two years with most hits # filter(players, min_rank(desc(H)) <= 2 & H > 0) # # Within each player, rank each year by the number of games played # mutate(players, G_rank = min_rank(G)) # # # For each player, find every year that was better than the previous year # filter(players, G > lag(G)) # # For each player, compute avg change in games played per year # mutate(players, G_change = (G - lag(G)) / (yearID - lag(yearID))) # # # For each player, find all where they played more games than average # filter(players, G > mean(G)) # # For each, player compute a z score based on number of games played # mutate(players, G_z = (G - mean(G)) / sd(G)) ## ------------------------------------------------------------------------ x <- c(1, 1, 2, 2, 2) row_number(x) min_rank(x) dense_rank(x) ## ------------------------------------------------------------------------ cume_dist(x) percent_rank(x) ## ------------------------------------------------------------------------ filter(players, cume_dist(desc(G)) < 0.1) ## ------------------------------------------------------------------------ by_team_player <- group_by(batting, teamID, playerID) by_team <- summarise(by_team_player, G = sum(G)) by_team_quartile <- group_by(by_team, quartile = ntile(G, 4)) summarise(by_team_quartile, mean(G)) ## ------------------------------------------------------------------------ x <- 1:5 lead(x) lag(x) ## ---- results = "hide"--------------------------------------------------- # Compute the relative change in games played mutate(players, G_delta = G - lag(G)) ## ---- results = "hide"--------------------------------------------------- # Find when a player changed teams filter(players, teamID != lag(teamID)) ## ------------------------------------------------------------------------ df <- data.frame(year = 2000:2005, value = (0:5) ^ 2) scrambled <- df[sample(nrow(df)), ] wrong <- mutate(scrambled, prev_value = lag(value)) arrange(wrong, year) right <- mutate(scrambled, prev_value = lag(value, order_by = year)) arrange(right, year) ## ---- eval = FALSE------------------------------------------------------- # filter(players, cumany(G > 150)) ## ------------------------------------------------------------------------ x <- 1:10 y <- 10:1 order_by(y, cumsum(x)) ## ---- eval = FALSE------------------------------------------------------- # filter(players, G > mean(G)) # filter(players, G < median(G)) ## ---- eval = FALSE------------------------------------------------------- # filter(players, ntile(G, 2) == 2) ## ------------------------------------------------------------------------ mutate(players, career_year = yearID - min(yearID) + 1) ## ------------------------------------------------------------------------ mutate(players, G_z = (G - mean(G)) / sd(G)) dplyr/inst/doc/compatibility.Rmd0000644000176200001440000002334613614573562016467 0ustar liggesusers--- title: "dplyr compatibility" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{dplyr compatibility} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r setup, include = FALSE} library(dplyr) knitr::opts_chunk$set(collapse = T, comment = "#>") ``` This vignette is aimed at package authors who need to update their code because of a backward incompatible change to dplyr. We do try and minimise backward incompatible changes as much as possible, but sometimes they are necessary in order to radically simplify existing code, or unlock a lot of potential value in the future. This vignette starts with some general advice on writing package code that works with multiple version of dplyr, then continues to discuss specific changes in dplyr versions. ## Working with multiple dplyr versions Ideally, you want to make sure that your package works with both the released version and the development version of dplyr. This is typically a little bit more work, but has two big advantages: 1. It's more convenient for your users, since they're not forced to update dplyr if they don't want to) 1. It's easier on CRAN since it doesn't require a massive coordinated release of multiple packages. To make code work with multiple versions of a package, your first tool is the simple if statement: ```{r, results = "hide"} if (utils::packageVersion("dplyr") > "0.5.0") { # code for new version } else { # code for old version } ``` Always condition on `> current-version`, not `>= next-version` because this will ensure that this branch is also used for the development version of the package. For example, if the current release is version "0.5.0", the development version will be "0.5.0.9000". Occasionally, you'll run into a situation where the `NAMESPACE` has changed and you need to conditionally import different functions. This typically occurs when functions are moved from one package to another. We try out best to provide automatic fallbacks, but this is not always possible. Often you can work around the problem by avoiding `importFrom` and using `::` instead. Do this where possible: ```{r, eval = FALSE} if (utils::packageVersion("dplyr") > "0.5.0") { dbplyr::build_sql(...) } else { dplyr::build_sql(...) } ``` This will generate an `R CMD check` NOTE (because the one of the functions will always be missing), but this is ok. Simply explain that you get the note because you have written a wrapper to make sure your code is backward compatible. Sometimes it's not possible to avoid `importFrom()`. For example you might be importing a generic so that you can define a method for it. In this case, you can take advantage of a little-known feature in the `NAMESPACE` file: you can include `if` statements. ```{r} #' @rawNamespace #' if (utils::packageVersion("dplyr") > "0.5.0") { #' importFrom("dbplyr", "build_sql") #' } else { #' importFrom("dplyr", "build_sql") #' } ``` ## dplyr 0.6.0 ### Database code moves to dbplyr Almost all database related code has been moved out of dplyr and into a new package, [dbplyr](http://github.com/hadley/dbplyr/). This makes dplyr simpler, and will make it easier to release fixes for bugs that only affect databases. If you've implemented a database backend for dplyr, please read the [backend news](https://github.com/hadley/dbplyr/blob/master/NEWS.md#backends) on the backend. Depending on what generics you use, and what generics you provide methods for you, you may need to write some conditional code. To help make this easier we've written `wrap_dbplyr_obj()` which will write the helper code for you: ```{r, eval = FALSE} wrap_dbplyr_obj("build_sql") wrap_dbplyr_obj("base_agg") ``` Simply copy the results of this function in your package. These will generate `R CMD check` NOTES, so make sure to tell CRAN that this is to ensure backward compatibility. ### Deprecation of underscored `verbs_()` Because the tidyeval framework allows us to combine SE and NSE semantics within the same functions, the underscored verbs have been softly deprecated. #### For users of SE_ verbs The legacy underscored versions take objects for which a `lazyeval::as.lazy()` method is defined. This includes symbols and calls, strings, and formulas. All of these objects have been replaced with quosures and you can call tidyeval verbs with unquoted quosures: ```{r, eval = FALSE} quo <- quo(cyl) select(mtcars, !! quo) ``` Symbolic expressions are also supported, but note that bare symbols and calls do not carry scope information. If you're referring to objects in the data frame, it's safe to omit specifying an enclosure: ```{r, results = "hide"} sym <- quote(cyl) select(mtcars, !! sym) call <- quote(mean(cyl)) summarise(mtcars, !! call) ``` Transforming objects into quosures is generally straightforward. To enclose with the current environment, you can unquote directly in `quo()` or you can use `as_quosure()`: ```{r} quo(!! sym) quo(!! call) rlang::as_quosure(sym) rlang::as_quosure(call) ``` Note that while formulas and quosures are very similar objects (and in the most general sense, formulas are quosures), they can't be used interchangeably in tidyeval functions. Early implementations did treat bare formulas as quosures, but this created compatibility issues with modelling functions of the stats package. Fortunately, it's easy to transform formulas to quosures that will self-evaluate in tidyeval functions: ```{r} f <- ~cyl f rlang::as_quosure(f) ``` Finally, and perhaps most importantly, **strings are not and should not be parsed**. As developers, it is tempting to try and solve problems using strings because we have been trained to work with strings rather than quoted expressions. However it's almost always the wrong way to approach the problem. The exception is for creating symbols. In that case it is perfectly legitimate to use strings: ```{r} rlang::sym("cyl") rlang::syms(letters[1:3]) ``` But you should never use strings to create calls. Instead you can use quasiquotation: ```{r} syms <- rlang::syms(c("foo", "bar", "baz")) quo(my_call(!!! syms)) fun <- rlang::sym("my_call") quo((!!fun)(!!! syms)) ``` Or create the call with `call2()`: ```{r} call <- rlang::call2("my_call", !!! syms) call rlang::as_quosure(call) # Or equivalently: quo(!! rlang::call2("my_call", !!! syms)) ``` Note that idioms based on `interp()` should now generally be avoided and replaced with quasiquotation. Where you used to interpolate: ```{r, eval=FALSE} lazyeval::interp(~ mean(var), var = rlang::sym("mpg")) ``` You would now unquote: ```{r, eval=FALSE} var <- "mpg" quo(mean(!! rlang::sym(var))) ``` See also `vignette("programming")` for more about quasiquotation and quosures. #### For package authors For package authors, rlang provides a [compatibility file](https://github.com/hadley/rlang/blob/master/R/compat-lazyeval.R) that you can copy to your package. `compat_lazy()` and `compat_lazy_dots()` turn lazy-able objects into proper quosures. This helps providing an underscored version to your users for backward compatibility. For instance, here is how we defined the underscored version of `filter()` in dplyr 0.6: ```{r, eval = FALSE} filter_.tbl_df <- function(.data, ..., .dots = list()) { dots <- compat_lazy_dots(.dots, caller_env(), ...) filter(.data, !!! dots) } ``` With tidyeval, S3 dispatch to the correct method might be an issue. In the past, the genericity of dplyr verbs was accomplished by dispatching in the underscored versions. Now that those are deprecated, we've turned the non-underscored verbs into S3 generics. We maintain backward compatibility by redispatching to old underscored verbs in the default methods of the new S3 generics. For example, here is how we redispatch `filter()`: ```{r, eval = FALSE} filter.default <- function(.data, ...) { filter_(.data, .dots = compat_as_lazy_dots(...)) } ``` This gets the job done in most cases. However, the default method will not be called for objects inheriting from one of the classes for which we provide non-underscored methods: `data.frame`, `tbl_df`, `tbl_cube` and `grouped_df`. An example of this is the `sf` package whose objects have classes `c("sf", "data.frame")`. Authors of such packages should provide a method for the non-underscored generic in order to be compatible with dplyr: ```{r, eval = FALSE} filter.sf <- function(.data, ...) { st_as_sf(NextMethod()) } ``` If you need help with this, please let us know! ### Deprecation of `mutate_each()` and `summarise_each()` These functions have been replaced by a more complete family of functions. This family has suffixes `_if`, `_at` and `_all` and includes more verbs than just `mutate` `summarise`. If you need to update your code to the new family, there are two relevant functions depending on which variables you apply `funs()` to. If you called `mutate_each()` without supplying a selection of variables, `funs` is applied to all variables. In this case, you should update your code to use `mutate_all()` instead: ```{r, eval = FALSE} mutate_each(starwars, funs(as.character)) mutate_all(starwars, funs(as.character)) ``` Note that the new verbs support bare functions as well, so you don't necessarily need to wrap with `funs()`: ```{r, eval = FALSE} mutate_all(starwars, as.character) ``` On the other hand, if you supplied a variable selection, you should use `mutate_at()`. The variable selection should be wrapped with `vars()`. ```{r, eval = FALSE} mutate_each(starwars, funs(as.character), height, mass) mutate_at(starwars, vars(height, mass), as.character) ``` `vars()` supports all the selection helpers that you usually use with `select()`: ```{r, eval = FALSE} summarise_at(mtcars, vars(starts_with("d")), mean) ``` Note that intead of a `vars()` selection, you can also supply character vectors of column names: ```{r, eval = FALSE} mutate_at(starwars, c("height", "mass"), as.character) ``` dplyr/inst/doc/programming.Rmd0000644000176200001440000004464313614573562016143 0ustar liggesusers--- title: "Programming with dplyr" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Programming with dplyr} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- ```{r setup, echo = FALSE, message = FALSE} knitr::opts_chunk$set(collapse = T, comment = "#>") options(tibble.print_min = 4L, tibble.print_max = 4L) library(dplyr) set.seed(1014) ``` Most dplyr functions use non-standard evaluation (NSE). This is a catch-all term that means they don't follow the usual R rules of evaluation. Instead, they capture the expression that you typed and evaluate it in a custom way. This has two main benefits for dplyr code: * Operations on data frames can be expressed succinctly because you don't need to repeat the name of the data frame. For example, you can write `filter(df, x == 1, y == 2, z == 3)` instead of `df[df$x == 1 & df$y ==2 & df$z == 3, ]`. * dplyr can choose to compute results in a different way to base R. This is important for database backends because dplyr itself doesn't do any work, but instead generates the SQL that tells the database what to do. Unfortunately these benefits do not come for free. There are two main drawbacks: * Most dplyr arguments are not __referentially transparent__. That means you can't replace a value with a seemingly equivalent object that you've defined elsewhere. In other words, this code: ```{r} df <- tibble(x = 1:3, y = 3:1) filter(df, x == 1) ``` Is not equivalent to this code: ```{r, error = TRUE} my_var <- x filter(df, my_var == 1) ``` nor to this code: ```{r, error = TRUE} my_var <- "x" filter(df, my_var == 1) ``` This makes it hard to create functions with arguments that change how dplyr verbs are computed. * dplyr code is ambiguous. Depending on what variables are defined where, `filter(df, x == y)` could be equivalent to any of: ```{r, eval = FALSE} df[df$x == df$y, ] df[df$x == y, ] df[x == df$y, ] df[x == y, ] ``` This is useful when working interactively (because it saves typing and you quickly spot problems) but makes functions more unpredictable than you might desire. Fortunately, dplyr provides tools to overcome these challenges. They require a little more typing, but a small amount of upfront work is worth it because they help you save time in the long run. This vignette has two goals: * Show you how to use dplyr's __pronouns__ and __quasiquotation__ to write reliable functions that reduce duplication in your data analysis code. * To teach you the underlying theory including __quosures__, the data structure that stores both an expression and an environment, and __tidyeval__, the underlying toolkit. We'll start with a warmup, tying this problem to something you're more familiar with, then move on to some practical tools, then dive into the deeper theory. ## Warm up You might not have realised it, but you're already accomplished at solving this type of problem in another domain: strings. It's obvious that this function doesn't do what you want: ```{r} greet <- function(name) { "How do you do, name?" } greet("Hadley") ``` That's because `"` "quotes" its input: it doesn't interpret what you've typed, it just stores it in a string. One way to make the function do what you want is to use `paste()` to build up the string piece by piece: ```{r} greet <- function(name) { paste0("How do you do, ", name, "?") } greet("Hadley") ``` Another approach is exemplified by the __glue__ package: it allows you to "unquote" components of a string, replacing the string with the value of the R expression. This allows an elegant implementation of our function because `{name}` is replaced with the value of the `name` argument. ```{r} greet <- function(name) { glue::glue("How do you do, {name}?") } greet("Hadley") ``` ## Programming recipes The following recipes walk you through the basics of tidyeval, with the nominal goal of reducing duplication in dplyr code. The examples here are somewhat inauthentic because we've reduced them down to very simple components to make them easier to understand. They're so simple that you might wonder why we bother writing a function at all. But it's a good idea to learn the ideas on simple examples, so that you're better prepared to apply them to the more complex situations you'll see in your own code. ### Different data sets You already know how to write functions that work with the first argument of dplyr verbs: the data. That's because dplyr doesn't do anything special with that argument, so it's referentially transparent. For example, if you saw repeated code like this: ```{r, eval = FALSE} mutate(df1, y = a + x) mutate(df2, y = a + x) mutate(df3, y = a + x) mutate(df4, y = a + x) ``` You could already write a function to capture that duplication: ```{r} mutate_y <- function(df) { mutate(df, y = a + x) } ``` Unfortunately, there's a drawback to this simple approach: it can fail silently if one of the variables isn't present in the data frame, but is present in the global environment. ```{r} df1 <- tibble(x = 1:3) a <- 10 mutate_y(df1) ``` We can fix that ambiguity by being more explicit and using the `.data` pronoun. This will throw an informative error if the variable doesn't exist: ```{r, error = TRUE} mutate_y <- function(df) { mutate(df, y = .data$a + .data$x) } mutate_y(df1) ``` If this function is in a package, using `.data` also prevents `R CMD check` from giving a NOTE about undefined global variables (provided that you've also imported `rlang::.data` with `@importFrom rlang .data`). ### Different expressions Writing a function is hard if you want one of the arguments to be a variable name (like `x`) or an expression (like `x + y`). That's because dplyr automatically "quotes" those inputs, so they are not referentially transparent. Let's start with a simple case: you want to vary the grouping variable for a data summarization. ```{r} df <- tibble( g1 = c(1, 1, 2, 2, 2), g2 = c(1, 2, 1, 2, 1), a = sample(5), b = sample(5) ) df %>% group_by(g1) %>% summarise(a = mean(a)) df %>% group_by(g2) %>% summarise(a = mean(a)) ``` You might hope that this will work: ```{r, error = TRUE} my_summarise <- function(df, group_var) { df %>% group_by(group_var) %>% summarise(a = mean(a)) } my_summarise(df, g1) ``` But it doesn't. Maybe providing the variable name as a string will fix things? ```{r, error = TRUE} my_summarise(df, "g2") ``` Nope. If you look carefully at the error message, you'll see that it's the same in both cases. `group_by()` works like `"`: it doesn't evaluate its input; it quotes it. To make this function work, we need to do two things. We need to quote the input ourselves (so `my_summarise()` can take a bare variable name like `group_by()`), and then we need to tell `group_by()` not to quote its input (because we've done the quoting). How do we quote the input? We can't use `""` to quote the input, because that gives us a string. Instead we need a function that captures the expression and its environment (we'll come back to why this is important later on). There are two possible options we could use in base R, the function `quote()` and the operator `~`. Neither of these work quite the way we want, so we need a new function: `quo()`. `quo()` works like `"`: it quotes its input rather than evaluating it. ```{r} quo(g1) quo(a + b + c) quo("a") ``` `quo()` returns a __quosure__, which is a special type of formula. You'll learn more about quosures later on. Now that we've captured this expression, how do we use it with `group_by()`? It doesn't work if we just shove it into our naive approach: ```{r, error = TRUE} my_summarise(df, quo(g1)) ``` We get the same error as before, because we haven't yet told `group_by()` that we're taking care of the quoting. In other words, we need to tell `group_by()` not to quote its input, because it has been pre-quoted by `my_summarise()`. Yet another way of saying the same thing is that we want to __unquote__ `group_var`. In dplyr (and in tidyeval in general) you use `!!` to say that you want to unquote an input so that it's evaluated, not quoted. This gives us a function that actually does what we want. ```{r} my_summarise <- function(df, group_var) { df %>% group_by(!! group_var) %>% summarise(a = mean(a)) } my_summarise(df, quo(g1)) ``` Huzzah! There's just one step left: we want to call this function like we call `group_by()`: ```{r, eval = FALSE} my_summarise(df, g1) ``` This doesn't work because there's no object called `g1`. We need to capture what the user of the function typed and quote it for them. You might try using `quo()` to do that: ```{r, error = TRUE} my_summarise <- function(df, group_var) { quo_group_var <- quo(group_var) print(quo_group_var) df %>% group_by(!! quo_group_var) %>% summarise(a = mean(a)) } my_summarise(df, g1) ``` I've added a `print()` call to make it obvious what's going wrong here: `quo(group_var)` always returns `~group_var`. It is being too literal! We want it to substitute the value that the user supplied, i.e. to return `~g1`. By analogy to strings, we don't want `""`, instead we want some function that turns an argument into a string. That's the job of `enquo()`. `enquo()` uses some dark magic to look at the argument, see what the user typed, and return that value as a quosure. (Technically, this works because function arguments are evaluated lazily, using a special data structure called a __promise__.) ```{r} my_summarise <- function(df, group_var) { group_var <- enquo(group_var) print(group_var) df %>% group_by(!! group_var) %>% summarise(a = mean(a)) } my_summarise(df, g1) ``` (If you're familiar with `quote()` and `substitute()` in base R, `quo()` is equivalent to `quote()` and `enquo()` is equivalent to `substitute()`.) You might wonder how to extend this to handle multiple grouping variables: we'll come back to that a little later. ### Different input variable Now let's tackle something a bit more complicated. The code below shows a duplicate `summarise()` statement where we compute three summaries, varying the input variable. ```{r} summarise(df, mean = mean(a), sum = sum(a), n = n()) summarise(df, mean = mean(a * b), sum = sum(a * b), n = n()) ``` To turn this into a function, we start by testing the basic approach interactively: we quote the variable with `quo()`, then unquoting it in the dplyr call with `!!`. Notice that we can unquote anywhere inside a complicated expression. ```{r} my_var <- quo(a) summarise(df, mean = mean(!! my_var), sum = sum(!! my_var), n = n()) ``` You can also wrap `quo()` around the dplyr call to see what will happen from dplyr's perspective. This is a very useful tool for debugging. ```{r} quo(summarise(df, mean = mean(!! my_var), sum = sum(!! my_var), n = n() )) ``` Now we can turn our code into a function (remembering to replace `quo()` with `enquo()`), and check that it works: ```{r} my_summarise2 <- function(df, expr) { expr <- enquo(expr) summarise(df, mean = mean(!! expr), sum = sum(!! expr), n = n() ) } my_summarise2(df, a) my_summarise2(df, a * b) ``` ### Different input and output variable The next challenge is to vary the name of the output variables: ```{r} mutate(df, mean_a = mean(a), sum_a = sum(a)) mutate(df, mean_b = mean(b), sum_b = sum(b)) ``` This code is similar to the previous example, but there are two new wrinkles: * We create the new names by pasting together strings, so we need `quo_name()` to convert the input expression to a string. * `!! mean_name = mean(!! expr)` isn't valid R code, so we need to use the `:=` helper provided by rlang. ```{r} my_mutate <- function(df, expr) { expr <- enquo(expr) mean_name <- paste0("mean_", quo_name(expr)) sum_name <- paste0("sum_", quo_name(expr)) mutate(df, !! mean_name := mean(!! expr), !! sum_name := sum(!! expr) ) } my_mutate(df, a) ``` ### Capturing multiple variables It would be nice to extend `my_summarise()` to accept any number of grouping variables. We need to make three changes: * Use `...` in the function definition so our function can accept any number of arguments. * Use `enquos()` to capture all the `...` as a list of formulas. * Use `!!!` instead of `!!` to __splice__ the arguments into `group_by()`. ```{r} my_summarise <- function(df, ...) { group_var <- enquos(...) df %>% group_by(!!! group_var) %>% summarise(a = mean(a)) } my_summarise(df, g1, g2) ``` `!!!` takes a list of elements and splices them into to the current call. Look at the bottom of the `!!!` and think `...`. ```{r} args <- list(na.rm = TRUE, trim = 0.25) quo(mean(x, !!! args)) args <- list(quo(x), na.rm = TRUE, trim = 0.25) quo(mean(!!! args)) ``` Now that you've learned the basics of tidyeval through some practical examples, we'll dive into the theory. This will help you generalise what you've learned here to new situations. ## Quoting Quoting is the action of capturing an expression instead of evaluating it. All expression-based functions quote their arguments and get the R code as an expression rather than the result of evaluating that code. If you are an R user, you probably quote expressions on a regular basis. One of the most important quoting operators in R is the _formula_. It is famously used for the specification of statistical models: ```{r} disp ~ cyl + drat ``` The other quoting operator in base R is `quote()`. It returns a raw expression rather than a formula: ```{r} # Computing the value of the expression: toupper(letters[1:5]) # Capturing the expression: quote(toupper(letters[1:5])) ``` (Note that despite being called the double quote, `"` is not a quoting operator in this context, because it generates a string, not an expression.) In practice, the formula is the better of the two options because it captures the code and its execution __environment__. This is important because even simple expression can yield different values in different environments. For example, the `x` in the following two expressions refers to different values: ```{r} f <- function(x) { quo(x) } x1 <- f(10) x2 <- f(100) ``` It might look like the expressions are the same if you print them out. ```{r} x1 x2 ``` But if you inspect the environments using `rlang::get_env()` --- they're different. ```{r, message = FALSE} library(rlang) get_env(x1) get_env(x2) ``` Further, when we evaluate those formulas using `rlang::eval_tidy()`, we see that they yield different values: ```{r} eval_tidy(x1) eval_tidy(x2) ``` This is a key property of R: one name can refer to different values in different environments. This is also important for dplyr, because it allows you to combine variables and objects in a call: ```{r} user_var <- 1000 mtcars %>% summarise(cyl = mean(cyl) * user_var) ``` When an object keeps track of an environment, it is said to have an enclosure. This is the reason that functions in R are sometimes referred to as closures: ```{r} typeof(mean) ``` For this reason we use a special name to refer to one-sided formulas: __quosures__. One-sided formulas are quotes (they carry an expression) with an environment. Quosures are regular R objects. They can be stored in a variable and inspected: ```{r} var <- ~toupper(letters[1:5]) var # You can extract its expression: get_expr(var) # Or inspect its enclosure: get_env(var) ``` ## Quasiquotation > Put simply, quasi-quotation enables one to introduce symbols that stand for > a linguistic expression in a given instance and are used as that linguistic > expression in a different instance. --- [Willard van Orman Quine](https://en.wikipedia.org/wiki/Quasi-quotation) Automatic quoting makes dplyr very convenient for interactive use. But if you want to program with dplyr, you need some way to refer to variables indirectly. The solution to this problem is __quasiquotation__, which allows you to evaluate directly inside an expression that is otherwise quoted. Quasiquotation was coined by Willard van Orman Quine in the 1940s, and was adopted for programming by the LISP community in the 1970s. All expression-based functions in the tidyeval framework support quasiquotation. Unquoting cancels quotation of parts of an expression. There are three types of unquoting: * basic * unquote splicing * unquoting names ### Unquoting The first important operation is the basic unquote, which comes in a functional form, `UQ()`, and as syntactic-sugar, `!!`. ```{r} # Here we capture `letters[1:5]` as an expression: quo(toupper(letters[1:5])) # Here we capture the value of `letters[1:5]` quo(toupper(!! letters[1:5])) quo(toupper(UQ(letters[1:5]))) ``` It is also possible to unquote other quoted expressions. Unquoting such symbolic objects provides a powerful way of manipulating expressions. ```{r} var1 <- quo(letters[1:5]) quo(toupper(!! var1)) ``` You can safely unquote quosures because they track their environments, and tidyeval functions know how to evaluate them. This allows any depth of quoting and unquoting. ```{r} my_mutate <- function(x) { mtcars %>% select(cyl) %>% slice(1:4) %>% mutate(cyl2 = cyl + (!! x)) } f <- function(x) quo(x) expr1 <- f(100) expr2 <- f(10) my_mutate(expr1) my_mutate(expr2) ``` The functional form is useful in cases where the precedence of `!` causes problems: ```{r, error = TRUE} my_fun <- quo(fun) quo(!! my_fun(x, y, z)) quo(UQ(my_fun)(x, y, z)) my_var <- quo(x) quo(filter(df, !! my_var == 1)) quo(filter(df, UQ(my_var) == 1)) ``` ### Unquote-splicing The second unquote operation is unquote-splicing. Its functional form is `UQS()` and the syntactic shortcut is `!!!`. It takes a vector and inserts each element of the vector in the surrounding function call: ```{r} quo(list(!!! letters[1:5])) ``` A very useful feature of unquote-splicing is that the vector names become argument names: ```{r} x <- list(foo = 1L, bar = quo(baz)) quo(list(!!! x)) ``` This makes it easy to program with dplyr verbs that take named dots: ```{r} args <- list(mean = quo(mean(cyl)), count = quo(n())) mtcars %>% group_by(am) %>% summarise(!!! args) ``` ### Setting variable names The final unquote operation is setting argument names. You've seen one way to do that above, but you can also use the definition operator `:=` instead of `=`. `:=` supports unquoting on both the LHS and the RHS. The rules on the LHS are slightly different: the unquoted operand should evaluate to a string or a symbol. ```{r} mean_nm <- "mean" count_nm <- "count" mtcars %>% group_by(am) %>% summarise( !! mean_nm := mean(cyl), !! count_nm := n() ) ``` dplyr/inst/doc/compatibility.R0000644000176200001440000000674013614574166016146 0ustar liggesusers## ----setup, include = FALSE---------------------------------------------- library(dplyr) knitr::opts_chunk$set(collapse = T, comment = "#>") ## ---- results = "hide"--------------------------------------------------- if (utils::packageVersion("dplyr") > "0.5.0") { # code for new version } else { # code for old version } ## ---- eval = FALSE------------------------------------------------------- # if (utils::packageVersion("dplyr") > "0.5.0") { # dbplyr::build_sql(...) # } else { # dplyr::build_sql(...) # } ## ------------------------------------------------------------------------ #' @rawNamespace #' if (utils::packageVersion("dplyr") > "0.5.0") { #' importFrom("dbplyr", "build_sql") #' } else { #' importFrom("dplyr", "build_sql") #' } ## ---- eval = FALSE------------------------------------------------------- # wrap_dbplyr_obj("build_sql") # # wrap_dbplyr_obj("base_agg") ## ---- eval = FALSE------------------------------------------------------- # quo <- quo(cyl) # select(mtcars, !! quo) ## ---- results = "hide"--------------------------------------------------- sym <- quote(cyl) select(mtcars, !! sym) call <- quote(mean(cyl)) summarise(mtcars, !! call) ## ------------------------------------------------------------------------ quo(!! sym) quo(!! call) rlang::as_quosure(sym) rlang::as_quosure(call) ## ------------------------------------------------------------------------ f <- ~cyl f rlang::as_quosure(f) ## ------------------------------------------------------------------------ rlang::sym("cyl") rlang::syms(letters[1:3]) ## ------------------------------------------------------------------------ syms <- rlang::syms(c("foo", "bar", "baz")) quo(my_call(!!! syms)) fun <- rlang::sym("my_call") quo((!!fun)(!!! syms)) ## ------------------------------------------------------------------------ call <- rlang::call2("my_call", !!! syms) call rlang::as_quosure(call) # Or equivalently: quo(!! rlang::call2("my_call", !!! syms)) ## ---- eval=FALSE--------------------------------------------------------- # lazyeval::interp(~ mean(var), var = rlang::sym("mpg")) ## ---- eval=FALSE--------------------------------------------------------- # var <- "mpg" # quo(mean(!! rlang::sym(var))) ## ---- eval = FALSE------------------------------------------------------- # filter_.tbl_df <- function(.data, ..., .dots = list()) { # dots <- compat_lazy_dots(.dots, caller_env(), ...) # filter(.data, !!! dots) # } ## ---- eval = FALSE------------------------------------------------------- # filter.default <- function(.data, ...) { # filter_(.data, .dots = compat_as_lazy_dots(...)) # } ## ---- eval = FALSE------------------------------------------------------- # filter.sf <- function(.data, ...) { # st_as_sf(NextMethod()) # } ## ---- eval = FALSE------------------------------------------------------- # mutate_each(starwars, funs(as.character)) # mutate_all(starwars, funs(as.character)) ## ---- eval = FALSE------------------------------------------------------- # mutate_all(starwars, as.character) ## ---- eval = FALSE------------------------------------------------------- # mutate_each(starwars, funs(as.character), height, mass) # mutate_at(starwars, vars(height, mass), as.character) ## ---- eval = FALSE------------------------------------------------------- # summarise_at(mtcars, vars(starts_with("d")), mean) ## ---- eval = FALSE------------------------------------------------------- # mutate_at(starwars, c("height", "mass"), as.character) dplyr/inst/include/0000755000176200001440000000000013614573562014020 5ustar liggesusersdplyr/inst/include/tools/0000755000176200001440000000000013614573562015160 5ustar liggesusersdplyr/inst/include/tools/bad.h0000644000176200001440000001344513614573562016066 0ustar liggesusers#ifndef DPLYR_DPLYR_BAD_H #define DPLYR_DPLYR_BAD_H #include #include namespace dplyr { template void NORET bad_arg(const SymbolString& arg, C1 arg1) { using Rcpp::_; static Rcpp::Function bad_fun = Rcpp::Function("bad_args", Rcpp::Environment::namespace_env("dplyr")); static Rcpp::Function identity = Rcpp::Function("identity", Rcpp::Environment::base_env()); Rcpp::String message = bad_fun(Rcpp::CharacterVector::create(arg.get_string()), arg1, _[".abort"] = identity); message.set_encoding(CE_UTF8); Rcpp::stop(message.get_cstring()); } template void NORET bad_arg(const SymbolString& arg, C1 arg1, C2 arg2) { using Rcpp::_; static Rcpp::Function bad_fun = Rcpp::Function("bad_args", Rcpp::Environment::namespace_env("dplyr")); static Rcpp::Function identity = Rcpp::Function("identity", Rcpp::Environment::base_env()); Rcpp::String message = bad_fun(Rcpp::CharacterVector::create(arg.get_string()), arg1, arg2, _[".abort"] = identity); message.set_encoding(CE_UTF8); Rcpp::stop(message.get_cstring()); } template void NORET bad_arg(const SymbolString& arg, C1 arg1, C2 arg2, C3 arg3) { using Rcpp::_; static Rcpp::Function bad_fun = Rcpp::Function("bad_args", Rcpp::Environment::namespace_env("dplyr")); static Rcpp::Function identity = Rcpp::Function("identity", Rcpp::Environment::base_env()); Rcpp::String message = bad_fun(Rcpp::CharacterVector::create(arg.get_string()), arg1, arg2, arg3, _[".abort"] = identity); message.set_encoding(CE_UTF8); Rcpp::stop(message.get_cstring()); } template void NORET bad_pos_arg(int pos_arg, C1 arg1) { using Rcpp::_; static Rcpp::Function bad_fun = Rcpp::Function("bad_pos_args", Rcpp::Environment::namespace_env("dplyr")); static Rcpp::Function identity = Rcpp::Function("identity", Rcpp::Environment::base_env()); Rcpp::String message = bad_fun(pos_arg, arg1, _[".abort"] = identity); message.set_encoding(CE_UTF8); Rcpp::stop(message.get_cstring()); } template void NORET bad_pos_arg(int pos_arg, C1 arg1, C2 arg2) { using Rcpp::_; static Rcpp::Function bad_fun = Rcpp::Function("bad_pos_args", Rcpp::Environment::namespace_env("dplyr")); static Rcpp::Function identity = Rcpp::Function("identity", Rcpp::Environment::base_env()); Rcpp::String message = bad_fun(pos_arg, arg1, arg2, _[".abort"] = identity); message.set_encoding(CE_UTF8); Rcpp::stop(message.get_cstring()); } template void NORET bad_pos_arg(int pos_arg, C1 arg1, C2 arg2, C3 arg3) { using Rcpp::_; static Rcpp::Function bad_fun = Rcpp::Function("bad_pos_args", Rcpp::Environment::namespace_env("dplyr")); static Rcpp::Function identity = Rcpp::Function("identity", Rcpp::Environment::base_env()); Rcpp::String message = bad_fun(pos_arg, arg1, arg2, arg3, _[".abort"] = identity); message.set_encoding(CE_UTF8); Rcpp::stop(message.get_cstring()); } template void NORET bad_col(const SymbolString& col, C1 arg1) { using Rcpp::_; static Rcpp::Function bad_fun = Rcpp::Function("bad_cols", Rcpp::Environment::namespace_env("dplyr")); static Rcpp::Function identity = Rcpp::Function("identity", Rcpp::Environment::base_env()); Rcpp::String message = bad_fun(Rcpp::CharacterVector::create(col.get_string()), arg1, _[".abort"] = identity); message.set_encoding(CE_UTF8); Rcpp::stop(message.get_cstring()); } template void NORET bad_col(const SymbolString& col, C1 arg1, C2 arg2) { using Rcpp::_; static Rcpp::Function bad_fun = Rcpp::Function("bad_cols", Rcpp::Environment::namespace_env("dplyr")); static Rcpp::Function identity = Rcpp::Function("identity", Rcpp::Environment::base_env()); Rcpp::String message = bad_fun(Rcpp::CharacterVector::create(col.get_string()), arg1, arg2, _[".abort"] = identity); message.set_encoding(CE_UTF8); Rcpp::stop(message.get_cstring()); } template void NORET bad_col(const SymbolString& col, C1 arg1, C2 arg2, C3 arg3) { using Rcpp::_; static Rcpp::Function bad_fun = Rcpp::Function("bad_cols", Rcpp::Environment::namespace_env("dplyr")); static Rcpp::Function identity = Rcpp::Function("identity", Rcpp::Environment::base_env()); Rcpp::String message = bad_fun(Rcpp::CharacterVector::create(col.get_string()), arg1, arg2, arg3, _[".abort"] = identity); message.set_encoding(CE_UTF8); Rcpp::stop(message.get_cstring()); } template Rcpp::String msg_bad_cols(const SymbolVector& cols, C1 arg1) { using Rcpp::_; static Rcpp::Function bad_fun = Rcpp::Function("bad_cols", Rcpp::Environment::namespace_env("dplyr")); static Rcpp::Function identity = Rcpp::Function("identity", Rcpp::Environment::base_env()); Rcpp::String message = bad_fun(cols.get_vector(), arg1, _[".abort"] = identity); message.set_encoding(CE_UTF8); return message; } template Rcpp::String msg_bad_cols(const SymbolVector& cols, C1 arg1, C2 arg2) { using Rcpp::_; static Rcpp::Function bad_fun = Rcpp::Function("bad_cols", Rcpp::Environment::namespace_env("dplyr")); static Rcpp::Function identity = Rcpp::Function("identity", Rcpp::Environment::base_env()); Rcpp::String message = bad_fun(cols.get_vector(), arg1, arg2, _[".abort"] = identity); message.set_encoding(CE_UTF8); return message; } template Rcpp::String msg_bad_cols(const SymbolVector& cols, C1 arg1, C2 arg2, C3 arg3) { using Rcpp::_; static Rcpp::Function bad_fun = Rcpp::Function("bad_cols", Rcpp::Environment::namespace_env("dplyr")); static Rcpp::Function identity = Rcpp::Function("identity", Rcpp::Environment::base_env()); Rcpp::String message = bad_fun(cols.get_vector(), arg1, arg2, arg3, _[".abort"] = identity); message.set_encoding(CE_UTF8); return message; } } #endif // DPLYR_DPLYR_BAD_H dplyr/inst/include/tools/VectorView.h0000644000176200001440000000040713614573562017427 0ustar liggesusers#ifndef dplyr_tools_VectorView_H #define dplyr_tools_VectorView_H namespace Rcpp { typedef Vector IntegerVectorView; typedef Vector ListView; typedef DataFrame_Impl DataFrameView; } #endif dplyr/inst/include/tools/scalar_type.h0000644000176200001440000000047413614573562017644 0ustar liggesusers#ifndef DPLYR_SCALAR_TYPE_H #define DPLYR_SCALAR_TYPE_H namespace dplyr { namespace traits { template struct scalar_type { typedef typename Rcpp::traits::storage_type::type type; }; template <> struct scalar_type { typedef Rcpp::String type; }; } } #endif //DPLYR_SCALAR_TYPE_H dplyr/inst/include/tools/set_rownames.h0000644000176200001440000000053413614573562020041 0ustar liggesusers#ifndef dplyr_tools_set_rownames_H #define dplyr_tools_set_rownames_H namespace dplyr { template inline void set_rownames(Df& data, int n) { Rcpp::Shield row_names(Rf_allocVector(INTSXP, 2)); INTEGER(row_names)[0] = NA_INTEGER; INTEGER(row_names)[1] = -n; Rf_setAttrib(data, R_RowNamesSymbol, row_names); } } #endif dplyr/inst/include/tools/BoolResult.h0000644000176200001440000000222113614573562017420 0ustar liggesusers#ifndef dplyr_tools_BoolResult_H #define dplyr_tools_BoolResult_H #include #include namespace dplyr { class BoolResult { public: BoolResult(bool result_) : result(result_) {} BoolResult(bool result_, const Rcpp::CharacterVector& msg) : result(result_), message(msg) {} inline operator SEXP() const { Rcpp::LogicalVector res = Rcpp::LogicalVector::create(result); Rf_setAttrib(res, symbols::comment, message); Rcpp::Shield klass(Rf_mkString("BoolResult")); Rf_classgets(res, klass); return res; } inline operator bool() const { return result; } inline std::string why_not() const { R_xlen_t n = message.length(); if (n == 0) return ""; if (n == 1) return std::string(message[0]); std::stringstream ss; ss << "\n"; for (int i = 0; i < n; ++i) { ss << "- " << std::string(message[i]) << "\n"; } return ss.str(); } private: bool result; Rcpp::CharacterVector message; }; inline BoolResult no_because(const Rcpp::CharacterVector& msg) { return BoolResult(false, msg); } inline BoolResult yes() { return true; } } #endif dplyr/inst/include/tools/encoding.h0000644000176200001440000000262213614573562017121 0ustar liggesusers#ifndef DPLYR_ENCODING_H #define DPLYR_ENCODING_H #define TYPE_BITS 5 #define BYTES_MASK (1<<1) #define LATIN1_MASK (1<<2) #define UTF8_MASK (1<<3) #define ASCII_MASK (1<<6) struct sxpinfo_struct { // *INDENT-OFF* SEXPTYPE type : TYPE_BITS;/* ==> (FUNSXP == 99) %% 2^5 == 3 == CLOSXP * -> warning: `type' is narrower than values * of its type * when SEXPTYPE was an enum */ // *INDENT-ON* unsigned int obj : 1; unsigned int named : 2; unsigned int gp : 16; unsigned int mark : 1; unsigned int debug : 1; unsigned int trace : 1; /* functions and memory tracing */ unsigned int spare : 1; /* currently unused */ unsigned int gcgen : 1; /* old generation number */ unsigned int gccls : 3; /* node class */ }; /* Tot: 32 */ #ifndef IS_BYTES #define IS_BYTES(x) (reinterpret_cast(x)->gp & BYTES_MASK) #endif #ifndef IS_LATIN1 #define IS_LATIN1(x) (reinterpret_cast(x)->gp & LATIN1_MASK) #endif #ifndef IS_ASCII #define IS_ASCII(x) (reinterpret_cast(x)->gp & ASCII_MASK) #endif #ifndef IS_UTF8 #define IS_UTF8(x) (reinterpret_cast(x)->gp & UTF8_MASK) #endif namespace dplyr { Rcpp::CharacterVector reencode_factor(Rcpp::IntegerVector x); Rcpp::CharacterVector reencode_char(SEXP x); } #endif dplyr/inst/include/tools/hash.h0000644000176200001440000000250513614573562016256 0ustar liggesusers#ifndef dplyr_HASH_H #define dplyr_HASH_H #include #ifndef dplyr_hash_map #if defined(_WIN32) #define dplyr_hash_map RCPP_UNORDERED_MAP #else #include #define dplyr_hash_map boost::unordered_map #endif #endif // #ifndef dplyr_hash_map #ifndef dplyr_hash_set #if defined(_WIN32) #define dplyr_hash_set RCPP_UNORDERED_SET #else #include #define dplyr_hash_set boost::unordered_set #endif #endif // #ifndef dplyr_hash_set // FIXME: remove this when Rcpp provides a hash function for Rcomplex #if defined(_WIN32) #if __cplusplus >= 201103L namespace std { template<> struct hash { std::size_t operator()(const Rcomplex& cx) const { std::hash hasher; size_t seed = hasher(cx.r); boost::hash_combine(seed, hasher(cx.i)); return seed; } }; } #elif defined(HAS_TR1_UNORDERED_SET) namespace std { namespace tr1 { template<> struct hash { std::size_t operator()(const Rcomplex& cx) const { std::tr1::hash hasher; size_t seed = hasher(cx.r); boost::hash_combine(seed, hasher(cx.i)); return seed; } }; } } #endif #endif inline std::size_t hash_value(const Rcomplex& cx) { boost::hash hasher; size_t seed = hasher(cx.r); boost::hash_combine(seed, hasher(cx.i)); return seed; } #endif dplyr/inst/include/tools/SlicingIndex.h0000644000176200001440000000646713614573562017726 0ustar liggesusers#ifndef dplyr_tools_SlicingIndex_H #define dplyr_tools_SlicingIndex_H #include // A SlicingIndex allows specifying which rows of a data frame are selected in which order, basically a 0:n -> 0:m map. // It also can be used to split a data frame in groups. // Important special cases can be implemented without materializing the map. class SlicingIndex { public: virtual ~SlicingIndex() {}; virtual int size() const = 0; virtual int operator[](int i) const = 0; virtual int group() const = 0; }; // A GroupedSlicingIndex is the most general slicing index, // the 0:n -> 0:m map is specified and stored as an IntegerVector. // A group identifier can be assigned on construction. // It is used in grouped operations (group_by()). class GroupedSlicingIndex : public SlicingIndex { public: GroupedSlicingIndex(): data(), group_index(-1), preserved(true) { R_PreserveObject(data); } ~GroupedSlicingIndex() { if (preserved) { R_ReleaseObject(data); } } GroupedSlicingIndex(SEXP data_, int group_) : data(data_), group_index(group_), preserved(false) {} GroupedSlicingIndex(int group_) : data(Rf_ScalarInteger(group_ + 1)), group_index(group_), preserved(true) { R_PreserveObject(data); } virtual int size() const { return data.size(); } virtual int operator[](int i) const { return data[i] - 1; } virtual int group() const { return group_index; } inline operator SEXP() const { return data; } private: // in general we don't need to protect data because // it is already protected by the .rows column of the grouped_df // // but we do when using the default constructor, hence the // R_PreserveObject / R_ReleaseObject above Rcpp::IntegerVectorView data; int group_index; bool preserved; }; // A RowwiseSlicingIndex selects a single row, which is also the group ID by definition. // It is used in rowwise operations (rowwise()). class RowwiseSlicingIndex : public SlicingIndex { public: RowwiseSlicingIndex(): start(0) {} RowwiseSlicingIndex(const int start_) : start(start_) {} inline int size() const { return 1; } inline int operator[](int i) const { return start; } inline int group() const { return start; } inline operator SEXP() const { return Rf_ScalarInteger(start + 1); } private: int start; }; // A NaturalSlicingIndex selects an entire data frame as a single group. // It is used when the entire data frame needs to be processed by a processor that expects a SlicingIndex // to address the rows. class NaturalSlicingIndex : public SlicingIndex { public: NaturalSlicingIndex(): n(0) {} NaturalSlicingIndex(const int n_) : n(n_) {} virtual int size() const { return n; } virtual int operator[](int i) const { return i; } virtual int group() const { return 0 ; } private: int n; }; // An OffsetSlicingIndex selects a consecutive part of a data frame, starting at a specific row. // It is used for binding data frames vertically (bind_rows()). class OffsetSlicingIndex : public SlicingIndex { public: OffsetSlicingIndex(const int start_, const int n_) : start(start_), n(n_) {} inline int size() const { return n; } inline int operator[](int i) const { return i + start; } inline int group() const { return 0; } private: int start, n; }; #endif dplyr/inst/include/tools/match.h0000644000176200001440000000122613614573562016426 0ustar liggesusers#ifndef dplyr_tools_match_h #define dplyr_tools_match_h namespace dplyr { inline SEXP r_match(SEXP x, SEXP y, SEXP incomparables = R_NilValue) { static Rcpp::Function match("match", R_BaseEnv); if (R_VERSION == R_Version(3, 3, 0)) { // Work around matching bug in R 3.3.0: #1806 // https://bugs.r-project.org/bugzilla3/show_bug.cgi?id=16885 if (Rf_isNull(incomparables)) { Rcpp::Shield empty_lgl(Rf_allocVector(LGLSXP, 0)); return match(x, y, NA_INTEGER, empty_lgl); } else { return match(x, y, NA_INTEGER, incomparables); } } else { return match(x, y, NA_INTEGER, incomparables); } } } #endif dplyr/inst/include/tools/Quosure.h0000644000176200001440000000440213614573562016774 0ustar liggesusers#ifndef dplyr__Quosure_h #define dplyr__Quosure_h #include #include #include "SymbolVector.h" #include namespace dplyr { class Quosure { public: Quosure(SEXP data_) : data(data_) {} inline operator SEXP() const { return data; } SEXP expr() const { return rlang::quo_get_expr(data); } SEXP env() const { return rlang::quo_get_env(data); } private: // quosure typically come from the R side, so don't need // further protection, so it's the user responsability to protect // them if needed, as in arrange.cpp SEXP data; }; class NamedQuosure { public: NamedQuosure(SEXP data_, SymbolString name__) : quosure(data_), name_(name__) {} SEXP expr() const { return quosure.expr(); } SEXP env() const { return quosure.env(); } const SymbolString& name() const { return name_; } SEXP get() const { return quosure; } bool is_rlang_lambda() const { SEXP expr_ = expr(); return TYPEOF(expr_) == LANGSXP && Rf_inherits(CAR(expr_), "rlang_lambda_function"); } private: Quosure quosure; SymbolString name_; }; } // namespace dplyr namespace dplyr { class QuosureList { public: QuosureList(const Rcpp::List& data_) : data() { int n = data_.size(); if (n == 0) return; data.reserve(n); Rcpp::Shield names(Rf_getAttrib(data_, symbols::names)); for (int i = 0; i < n; i++) { SEXP x = data_[i]; if (!rlang::is_quosure(x)) { Rcpp::stop("corrupt tidy quote"); } data.push_back(NamedQuosure(x, SymbolString(STRING_ELT(names, i)))); } } const NamedQuosure& operator[](int i) const { return data[i]; } int size() const { return data.size(); } bool single_env() const { if (data.size() <= 1) return true; SEXP env = data[0].env(); for (size_t i = 1; i < data.size(); i++) { if (data[i].env() != env) return false; } return true; } SEXP names() const { R_xlen_t n = data.size(); Rcpp::Shield out(Rf_allocVector(STRSXP, n)); for (size_t i = 0; i < data.size(); ++i) { SET_STRING_ELT(out, i, data[i].name().get_sexp()); } return out; } private: std::vector data; }; } // namespace dplyr #endif dplyr/inst/include/tools/SymbolMap.h0000644000176200001440000000641113614573562017236 0ustar liggesusers#ifndef dplyr_tools_SymbolMap_h #define dplyr_tools_SymbolMap_h #include #include #include #include #include namespace dplyr { enum Origin { HASH, RMATCH, NEW }; struct SymbolMapIndex { int pos; Origin origin; SymbolMapIndex(int pos_, Origin origin_) : pos(pos_), origin(origin_) {} }; class SymbolMap { private: dplyr_hash_map lookup; SymbolVector names; SymbolMap(const SymbolMap&) ; public: SymbolMap(): lookup(), names() {} SymbolMap(int n, const Rcpp::CharacterVector& names_): lookup(n), names((SEXP)names_) { train_lookup(); } SymbolMap(const SymbolVector& names_): lookup(names_.size()), names(names_) { train_lookup(); } SymbolMap(const Rcpp::DataFrame& tbl): lookup(tbl.size()), names(Rf_getAttrib(tbl, symbols::names)) { train_lookup(); } SymbolMapIndex insert(const SymbolString& name) { // first, lookup the map dplyr_hash_map::const_iterator it = lookup.find(name.get_sexp()); if (it != lookup.end()) { return SymbolMapIndex(it->second, HASH); } int idx = names.match(name); if (idx != NA_INTEGER) { // if it is in the names, insert it in the map with the right index lookup.insert(std::make_pair(name.get_sexp(), idx - 1)); return SymbolMapIndex(idx - 1, RMATCH); } else { // otherwise insert it at the back idx = names.size(); lookup.insert(std::make_pair(name.get_sexp(), idx)); names.push_back(name.get_string()); return SymbolMapIndex(idx, NEW); } } const SymbolVector& get_names() const { return names; } SymbolString get_name(const int i) const { return names[i]; } int size() const { return names.size(); } bool has(const SymbolString& name) const { return lookup.find(name.get_sexp()) != lookup.end(); } int find(const SymbolString& name) const { dplyr_hash_map::const_iterator it = lookup.find(name.get_sexp()); return it == lookup.end() ? -1 : it->second; } int get(const SymbolString& name) const { dplyr_hash_map::const_iterator it = lookup.find(name.get_sexp()); if (it == lookup.end()) { Rcpp::stop("variable '%s' not found", name.get_utf8_cstring()); } return it->second; } SymbolMapIndex rm(const SymbolString& name) { dplyr_hash_map::const_iterator it = lookup.find(name.get_sexp()); if (it != lookup.end()) { int idx = it->second; names.remove(idx); for (dplyr_hash_map::iterator it = lookup.begin(); it != lookup.end();) { int k = it->second; if (k < idx) { // nothing to do in that case ++it; continue; } else if (k == idx) { // need to remove the data from the hash table it = lookup.erase(it); continue; } else { // decrement the index it->second--; ++it; } } return SymbolMapIndex(idx, HASH); } return SymbolMapIndex(names.size(), NEW); } private: void train_lookup() { int n = names.size(); for (int i = 0; i < n; i++) { lookup.insert(std::make_pair(names[i].get_sexp(), i)); } } }; } #endif dplyr/inst/include/tools/collapse.h0000644000176200001440000000125213614573562017133 0ustar liggesusers#ifndef dplyr_collapse_H #define dplyr_collapse_H namespace dplyr { template const char* to_string_utf8(typename Rcpp::traits::storage_type::type from) { SEXP s = Rcpp::internal::r_coerce(from); return Rf_translateCharUTF8(s); } template std::string collapse_utf8(const Rcpp::Vector& x, const char* sep = ", ", const char* quote = "") { std::stringstream ss; int n = x.size(); if (n > 0) { ss << quote << to_string_utf8(x[0]) << quote; for (int i = 1; i < n; i++) { const char* st = to_string_utf8(x[i]); ss << sep << quote << st << quote; } } return ss.str(); } } #endif dplyr/inst/include/tools/SymbolString.h0000644000176200001440000000263313614573562017771 0ustar liggesusers#ifndef dplyr_tools_SymbolString_h #define dplyr_tools_SymbolString_h #include namespace dplyr { class SymbolString { public: SymbolString() {} SymbolString(const char* str) : s(str) {} SymbolString(SEXP other) : s(other) {} SymbolString(const Rcpp::String& other) : s(other) {} SymbolString(const Rcpp::String::StringProxy& other) : s(other) {} SymbolString(const Rcpp::String::const_StringProxy& other) : s(other) {} // Symbols are always encoded in the native encoding (#1950) explicit SymbolString(const Rcpp::Symbol& symbol) : s(CHAR(PRINTNAME(symbol)), CE_NATIVE) {} public: const Rcpp::String& get_string() const { return s; } const Rcpp::Symbol get_symbol() const { return Rcpp::Symbol(Rf_translateChar(s.get_sexp())); } const std::string get_utf8_cstring() const { static Rcpp::Environment rlang = Rcpp::Environment::namespace_env("rlang"); static Rcpp::Function as_string = Rcpp::Function("as_string", rlang); Rcpp::Shield call(Rf_lang2(R_QuoteSymbol, get_symbol())); Rcpp::Shield utf8_string(as_string(call)); return CHAR(STRING_ELT(utf8_string, 0)); } bool is_empty() const { return s == ""; } SEXP get_sexp() const { return s.get_sexp(); } bool operator==(const SymbolString& other) const { return Rf_NonNullStringMatch(get_sexp(), other.get_sexp()); } private: Rcpp::String s; }; } #endif dplyr/inst/include/tools/utils.h0000644000176200001440000000777013614573562016504 0ustar liggesusers#ifndef dplyr_tools_utils_H #define dplyr_tools_utils_H #include void check_valid_colnames(const Rcpp::DataFrame& df, bool warn_only = false); int check_range_one_based(int x, int max); void assert_all_allow_list(const Rcpp::DataFrame&); SEXP shared_SEXP(SEXP x); SEXP shallow_copy(const Rcpp::List& data); SEXP pairlist_shallow_copy(SEXP p); void copy_attributes(SEXP out, SEXP data); SEXP null_if_empty(SEXP x); bool is_vector(SEXP x); bool is_atomic(SEXP x); SEXP vec_names(SEXP x); SEXP vec_names_or_empty(SEXP x); bool is_str_empty(SEXP str); bool has_name_at(SEXP x, R_len_t i); SEXP child_env(SEXP parent); int get_size(SEXP x); namespace dplyr { SEXP get_time_classes(); SEXP get_date_classes(); SEXP constant_recycle(SEXP x, int n, const SymbolString& name); std::string get_single_class(SEXP x); Rcpp::CharacterVector default_chars(SEXP x, R_xlen_t len); Rcpp::CharacterVector get_class(SEXP x); SEXP set_class(SEXP x, const Rcpp::CharacterVector& class_); void copy_attrib(SEXP out, SEXP origin, SEXP symbol); void copy_class(SEXP out, SEXP origin); void copy_names(SEXP out, SEXP origin); Rcpp::CharacterVector get_levels(SEXP x); SEXP set_levels(SEXP x, const Rcpp::CharacterVector& levels); bool same_levels(SEXP left, SEXP right); bool character_vector_equal(const Rcpp::CharacterVector& x, const Rcpp::CharacterVector& y); SymbolVector get_vars(SEXP x); // effectively the same as copy_attributes but without names and dims inline void copy_most_attributes(SEXP out, SEXP data) { Rf_copyMostAttrib(data, out); } namespace internal { // *INDENT-OFF* struct rlang_api_ptrs_t { SEXP (*quo_get_expr)(SEXP quo); SEXP (*quo_set_expr)(SEXP quo, SEXP expr); SEXP (*quo_get_env)(SEXP quo); SEXP (*quo_set_env)(SEXP quo, SEXP env); SEXP (*new_quosure)(SEXP expr, SEXP env); bool (*is_quosure)(SEXP x); SEXP (*as_data_pronoun)(SEXP data); SEXP (*as_data_mask)(SEXP data, SEXP parent); SEXP (*new_data_mask)(SEXP bottom, SEXP top); SEXP (*eval_tidy)(SEXP expr, SEXP data, SEXP env); rlang_api_ptrs_t() { quo_get_expr = (SEXP (*)(SEXP)) R_GetCCallable("rlang", "rlang_quo_get_expr"); quo_set_expr = (SEXP (*)(SEXP, SEXP)) R_GetCCallable("rlang", "rlang_quo_set_expr"); quo_get_env = (SEXP (*)(SEXP)) R_GetCCallable("rlang", "rlang_quo_get_env"); quo_set_env = (SEXP (*)(SEXP, SEXP)) R_GetCCallable("rlang", "rlang_quo_set_env"); new_quosure = (SEXP (*)(SEXP, SEXP)) R_GetCCallable("rlang", "rlang_new_quosure"); is_quosure = (bool (*)(SEXP)) R_GetCCallable("rlang", "rlang_is_quosure"); as_data_pronoun = (SEXP (*)(SEXP)) R_GetCCallable("rlang", "rlang_as_data_pronoun"); as_data_mask = (SEXP (*)(SEXP, SEXP)) R_GetCCallable("rlang", "rlang_as_data_mask"); new_data_mask = (SEXP (*)(SEXP, SEXP)) R_GetCCallable("rlang", "rlang_new_data_mask_3.0.0"); eval_tidy = (SEXP (*)(SEXP, SEXP, SEXP)) R_GetCCallable("rlang", "rlang_eval_tidy"); } }; // *INDENT-ON* const rlang_api_ptrs_t& rlang_api(); } // namespace internal } // dplyr namespace rlang { inline SEXP quo_get_expr(SEXP quo) { return dplyr::internal::rlang_api().quo_get_expr(quo); } inline SEXP quo_set_expr(SEXP quo, SEXP expr) { return dplyr::internal::rlang_api().quo_set_expr(quo, expr); } inline SEXP quo_get_env(SEXP quo) { return dplyr::internal::rlang_api().quo_get_env(quo); } inline bool is_quosure(SEXP x) { return dplyr::internal::rlang_api().is_quosure(x); } inline SEXP new_data_mask(SEXP bottom, SEXP top) { return dplyr::internal::rlang_api().new_data_mask(bottom, top); } inline SEXP as_data_pronoun(SEXP data) { return dplyr::internal::rlang_api().as_data_pronoun(data); } inline SEXP eval_tidy(SEXP expr, SEXP data, SEXP env) { return dplyr::internal::rlang_api().eval_tidy(expr, data, env); } inline SEXP new_quosure(SEXP expr, SEXP env) { return dplyr::internal::rlang_api().new_quosure(expr, env); } } #endif // #ifndef dplyr_tools_utils_H dplyr/inst/include/tools/vector_class.h0000644000176200001440000000114713614573562020023 0ustar liggesusers#ifndef dplyr_vector_class_H #define dplyr_vector_class_H namespace dplyr { template inline std::string vector_class(); template <> inline std::string vector_class() { return "integer"; } template <> inline std::string vector_class() { return "numeric"; } template <> inline std::string vector_class() { return "character"; } template <> inline std::string vector_class() { return "logical"; } template <> inline std::string vector_class() { return "list"; } template <> inline std::string vector_class() { return "complex"; } } #endif dplyr/inst/include/tools/all_na.h0000644000176200001440000000057113614573562016562 0ustar liggesusers#ifndef dplyr_tools_all_na_H #define dplyr_tools_all_na_H template inline bool all_na_impl(const Rcpp::Vector& x) { return all(is_na(x)).is_true(); } template <> inline bool all_na_impl(const Rcpp::NumericVector& x) { return all(is_na(x) & !is_nan(x)).is_true(); } inline bool all_na(SEXP x) { RCPP_RETURN_VECTOR(all_na_impl, x); } #endif dplyr/inst/include/tools/tools.h0000644000176200001440000000037513614573562016476 0ustar liggesusers#ifndef dplyr_tools_tools_H #define dplyr_tools_tools_H #include #include #include #include #include #include #include #endif dplyr/inst/include/tools/pointer_vector.h0000644000176200001440000000224213614573562020373 0ustar liggesusers#ifndef dplyr_tools_pointer_vector_H #define dplyr_tools_pointer_vector_H namespace dplyr { template class pointer_vector { public: typedef typename std::vector Vector; typedef typename Vector::reference reference; typedef typename Vector::const_reference const_reference; typedef typename Vector::size_type size_type; typedef typename Vector::value_type value_type; typedef typename Vector::iterator iterator; pointer_vector() : data() {} pointer_vector(size_type n) : data(n) {} inline ~pointer_vector() { typedef typename Vector::size_type size_type; size_type n = data.size(); // shortcut to avoid decreasing iterator past begin() if (n == 0) return; iterator it = data.end(); --it; for (size_type i = 0; i < n; --it, i++) delete *it; } inline reference operator[](size_type i) { return data[i]; } inline const_reference operator[](size_type i) const { return data[i]; } inline void push_back(const value_type& value) { data.push_back(value); } inline size_type size() const { return data.size(); } private: Vector data; pointer_vector(const pointer_vector&); }; } #endif dplyr/inst/include/tools/train.h0000644000176200001440000000237013614573562016450 0ustar liggesusers#ifndef dplyr_train_h #define dplyr_train_h namespace dplyr { template inline void iterate_with_interupts(Op op, int n) { int i = 0; if (n > DPLYR_MIN_INTERUPT_SIZE) { int m = n / DPLYR_INTERUPT_TIMES; for (int k = 0; k < DPLYR_INTERUPT_TIMES; k++) { for (int j = 0; j < m; j++, i++) op(i); Rcpp::checkUserInterrupt(); } } for (; i < n; i++) op(i); } template struct push_back_op { push_back_op(Map& map_) : map(map_) {} inline void operator()(int i) { map[i].push_back(i); } Map& map; }; template struct push_back_right_op { push_back_right_op(Map& map_) : map(map_) {} inline void operator()(int i) { map[-i - 1].push_back(-i - 1); } Map& map; }; template inline void train_push_back(Map& map, int n) { iterate_with_interupts(push_back_op(map), n); } template inline void train_push_back_right(Map& map, int n) { iterate_with_interupts(push_back_right_op(map), n); } template inline void train_insert(Set& set, int n) { for (int i = 0; i < n; i++) set.insert(i); } template inline void train_insert_right(Set& set, int n) { for (int i = 0; i < n; i++) set.insert(-i - 1); } } #endif dplyr/inst/include/tools/comparisons.h0000644000176200001440000000714313614573562017673 0ustar liggesusers#ifndef dplyr_comparison_H #define dplyr_comparison_H namespace dplyr { template struct comparisons { typedef typename Rcpp::traits::storage_type::type STORAGE; static inline bool is_less(STORAGE lhs, STORAGE rhs) { if (is_na(lhs)) return false; if (is_na(rhs)) return true; return lhs < rhs; } static inline bool is_greater(STORAGE lhs, STORAGE rhs) { return lhs > rhs; } static inline bool equal_or_both_na(STORAGE lhs, STORAGE rhs) { return lhs == rhs; } static inline bool is_na(STORAGE x) { return Rcpp::traits::is_na(x); } }; struct comparisons_int64 { static inline bool is_less(int64_t lhs, int64_t rhs) { if (is_na(lhs)) return false; if (is_na(rhs)) return true; return lhs < rhs; } static inline bool is_greater(int64_t lhs, int64_t rhs) { return lhs > rhs; } static inline bool equal_or_both_na(int64_t lhs, int64_t rhs) { return lhs == rhs; } static inline bool is_na(int64_t x) { return x == NA_INT64; } static int64_t NA_INT64; }; template <> struct comparisons { typedef Rbyte STORAGE; static inline bool is_less(STORAGE lhs, STORAGE rhs) { return lhs < rhs; } static inline bool is_greater(STORAGE lhs, STORAGE rhs) { return lhs > rhs; } static inline bool equal_or_both_na(STORAGE lhs, STORAGE rhs) { return lhs == rhs; } static inline bool is_na(STORAGE) { return false ; } }; template <> struct comparisons { static inline bool is_less(SEXP lhs, SEXP rhs) { // we need this because CHAR(NA_STRING) gives "NA" if (is_na(lhs)) return false; if (is_na(rhs)) return true; return strcmp(CHAR(lhs), CHAR(rhs)) < 0; } static inline bool is_greater(SEXP lhs, SEXP rhs) { if (is_na(lhs)) return false; if (is_na(rhs)) return true; return strcmp(CHAR(lhs), CHAR(rhs)) > 0; } static inline bool equal_or_both_na(SEXP lhs, SEXP rhs) { return lhs == rhs; } static inline bool is_na(SEXP x) { return Rcpp::traits::is_na(x); } }; // taking advantage of the particularity of NA_REAL template <> struct comparisons { static inline bool is_less(double lhs, double rhs) { if (is_nan(lhs)) { return false; } else if (is_na(lhs)) { return is_nan(rhs); } else { // lhs >= rhs is false if rhs is NA or NaN return !(lhs >= rhs); } } static inline bool is_greater(double lhs, double rhs) { if (is_nan(lhs)) { return false; } else if (is_na(lhs)) { return is_nan(rhs); } else { // lhs <= rhs is false if rhs is NA or NaN return !(lhs <= rhs); } } static inline bool equal_or_both_na(double lhs, double rhs) { return lhs == rhs || (is_nan(lhs) && is_nan(rhs)) || (is_na(lhs) && is_na(rhs)); } static inline bool is_na(double x) { return ISNA(x); } static inline bool is_nan(double x) { return Rcpp::traits::is_nan(x); } }; template <> struct comparisons { static inline bool is_less(Rcomplex lhs, Rcomplex rhs) { if (is_na(lhs)) return false; if (is_na(rhs)) return true; return lhs.r < rhs.r || (lhs.r == rhs.r && lhs.i < rhs.i); } static inline bool is_greater(Rcomplex lhs, Rcomplex rhs) { if (is_na(lhs)) return false; if (is_na(rhs)) return true; return !(lhs.r < rhs.r || (lhs.r == rhs.r && lhs.i <= rhs.i)); } static inline bool equal_or_both_na(Rcomplex lhs, Rcomplex rhs) { return lhs.r == rhs.r && lhs.i == rhs.i; } static inline bool is_na(Rcomplex x) { return Rcpp::traits::is_na(x); } }; } #endif dplyr/inst/include/tools/debug.h0000644000176200001440000000074513614573562016425 0ustar liggesusers#ifndef dplyr_tools_debug_H #define dplyr_tools_debug_H #include // borrowed from Rcpp11 #ifndef RCPP_DEBUG_OBJECT #define RCPP_DEBUG_OBJECT(OBJ) Rf_PrintValue( Rf_eval( Rf_lang2( dplyr::symbols::str, OBJ ), R_GlobalEnv ) ); #endif #ifndef RCPP_INSPECT_OBJECT #define RCPP_INSPECT_OBJECT(OBJ) Rf_PrintValue( Rf_eval( Rf_lang2( dplyr::symbols::dot_Internal, Rf_lang2( dplyr::symbols::inspect, OBJ ) ), R_GlobalEnv ) ); #endif #endif // #ifndef dplyr_tools_debug_H dplyr/inst/include/tools/rlang-export.h0000644000176200001440000000067213614573562017760 0ustar liggesusers#ifndef RLANG_EXPORT_H #define RLANG_EXPORT_H #define R_NO_REMAP #include #include #include #if (defined(R_VERSION) && R_VERSION < R_Version(3, 4, 0)) typedef union { void* p; DL_FUNC fn; } fn_ptr; SEXP R_MakeExternalPtrFn(DL_FUNC p, SEXP tag, SEXP prot); DL_FUNC R_ExternalPtrAddrFn(SEXP s); #endif void rlang_register_pointer(const char* ns, const char* ptr_name, DL_FUNC fn); #endif dplyr/inst/include/tools/SymbolVector.h0000644000176200001440000000407413614573562017766 0ustar liggesusers#ifndef dplyr_tools_SymbolVector_h #define dplyr_tools_SymbolVector_h #include #include #include namespace dplyr { class SymbolVector { public: SymbolVector() {} template explicit SymbolVector(T v_) : v(v_) {} explicit SymbolVector(SEXP x) : v(init(x)) {} explicit SymbolVector(Rcpp::RObject x) : v(init(x)) {} void push_back(const SymbolString& s) { v.push_back(s.get_string()); } void remove(const R_xlen_t idx) { v.erase(v.begin() + idx); } const SymbolString operator[](const R_xlen_t i) const { return SymbolString(v[i]); } void set(int i, const SymbolString& x) { v[i] = x.get_string(); } R_xlen_t size() const { return v.size(); } int match(const SymbolString& s) const { Rcpp::Shield vs(Rf_ScalarString(s.get_sexp())); Rcpp::Shield res(r_match(vs, v)); return Rcpp::as(res); } SEXP match_in_table(const Rcpp::CharacterVector& t) const { return r_match(v, t); } const Rcpp::CharacterVector& get_vector() const { return v; } private: Rcpp::CharacterVector v; SEXP init(SEXP x_) { Rcpp::Shield x(x_); switch (TYPEOF(x)) { case NILSXP: return Rcpp::CharacterVector(); case STRSXP: return x; case VECSXP: { R_xlen_t n = XLENGTH(x); Rcpp::CharacterVector res(n); for (R_xlen_t i = 0; i < n; i++) { SEXP elt = VECTOR_ELT(x, i); if (TYPEOF(elt) != SYMSXP) { Rcpp::stop("cannot convert to SymbolVector"); } res[i] = PRINTNAME(elt); } return res; } default: break; } return x; } }; } namespace Rcpp { template <> inline SEXP wrap(const dplyr::SymbolVector& x) { return x.get_vector(); } template <> class ConstReferenceInputParameter { public: typedef const dplyr::SymbolVector& const_reference ; ConstReferenceInputParameter(SEXP x_) : obj(x_) {} inline operator const_reference() { return obj ; } private: dplyr::SymbolVector obj ; } ; } #endif dplyr/inst/include/tools/default_value.h0000644000176200001440000000110613614573562020147 0ustar liggesusers#ifndef dplyr_dplyr_default_value_H #define dplyr_dplyr_default_value_H namespace dplyr { template inline typename Rcpp::traits::storage_type::type default_value() { return Rcpp::Vector::get_na() ; } template <> inline Rbyte default_value() { return (Rbyte)0 ; } template <> inline SEXP default_value() { return R_NilValue ; } template inline bool is_nan(typename Rcpp::Vector::stored_type value) { return false; } template <> inline bool is_nan(double value) { return R_IsNaN(value); } } #endif dplyr/inst/include/solaris/0000755000176200001440000000000013614573562015474 5ustar liggesusersdplyr/inst/include/solaris/solaris.h0000644000176200001440000000115313614573562017321 0ustar liggesusers#ifndef DPLYR_SOLARIS_H #define DPLYR_SOLARIS_H #if defined(__SUNPRO_CC) && !defined(Rcpp__platform__solaris_h) namespace Rcpp { namespace traits { template struct is_convertible< std::vector, SEXP> : public false_type {}; template <> struct is_convertible : public false_type {}; template struct is_convertible< sugar::Minus_Vector_Primitive< RTYPE, NA, Vector >, SEXP> : public false_type {}; template struct is_convertible< sugar::Plus_Vector_Primitive< RTYPE, NA, Vector >, SEXP> : public false_type {}; } } #endif #endif dplyr/inst/include/dplyr/0000755000176200001440000000000013615060710015135 5ustar liggesusersdplyr/inst/include/dplyr/config.h0000644000176200001440000000031313614573562016565 0ustar liggesusers#ifndef DPLYR_CONFIG_H #define DPLYR_CONFIG_H #ifndef DPLYR_MIN_INTERUPT_SIZE #define DPLYR_MIN_INTERUPT_SIZE 10000 #endif #ifndef DPLYR_INTERUPT_TIMES #define DPLYR_INTERUPT_TIMES 10 #endif #endif dplyr/inst/include/dplyr/allow_list.h0000644000176200001440000000104113614573562017470 0ustar liggesusers#ifndef dplyr_allow_list_H #define dplyr_allow_list_H namespace dplyr { inline bool allow_list(SEXP x) { if (Rf_isMatrix(x)) { // might have to refine later return true; } switch (TYPEOF(x)) { case RAWSXP: return true; case INTSXP: return true; case REALSXP: return true; case LGLSXP: return true; case STRSXP: return true; case CPLXSXP: return true; case VECSXP: { if (Rf_inherits(x, "POSIXlt")) return false; return true; } default: break; } return false; } } #endif dplyr/inst/include/dplyr/Collecter.h0000644000176200001440000004651513614573562017252 0ustar liggesusers#ifndef dplyr_Collecter_H #define dplyr_Collecter_H #include #include #include #include #include #include #include namespace dplyr { static inline bool inherits_from(SEXP x, const std::set& classes) { if (Rf_isNull(Rf_getAttrib(x, R_ClassSymbol))) { return true; } std::vector x_classes, inherited_classes; x_classes = Rcpp::as< std::vector >(Rf_getAttrib(x, R_ClassSymbol)); std::sort(x_classes.begin(), x_classes.end()); std::set_intersection(x_classes.begin(), x_classes.end(), classes.begin(), classes.end(), std::back_inserter(inherited_classes)); return !inherited_classes.empty(); } static bool is_class_known(SEXP x) { static std::set known_classes; if (known_classes.empty()) { known_classes.insert("hms"); known_classes.insert("difftime"); known_classes.insert("POSIXct"); known_classes.insert("factor"); known_classes.insert("Date"); known_classes.insert("AsIs"); known_classes.insert("integer64"); known_classes.insert("table"); } if (OBJECT(x)) { return inherits_from(x, known_classes); } else { return true; } } static inline void warn_loss_attr(SEXP x) { /* Attributes are lost with unknown classes */ if (!is_class_known(x)) { Rf_warning("Vectorizing '%s' elements may not preserve their attributes", CHAR(STRING_ELT(Rf_getAttrib(x, R_ClassSymbol), 0))); } } static inline bool all_logical_na(SEXP x, SEXPTYPE xtype) { return LGLSXP == xtype && all_na(x); } class Collecter { public: virtual ~Collecter() {}; virtual void collect(const SlicingIndex& index, SEXP v, int offset = 0) = 0; virtual SEXP get() = 0; virtual bool compatible(SEXP) = 0; virtual bool can_promote(SEXP) const = 0; virtual bool is_factor_collecter() const { return false; } virtual bool is_logical_all_na() const { return false; } virtual std::string describe() const = 0; }; template class Collecter_Impl : public Collecter { public: typedef typename Rcpp::traits::storage_type::type STORAGE; Collecter_Impl(int n_): data(n_, Rcpp::traits::get_na()) {} void collect(const SlicingIndex& index, SEXP v, int offset = 0) { if (all_logical_na(v, TYPEOF(v))) { collect_logicalNA(index); } else { collect_sexp(index, v, offset); } } inline SEXP get() { return data; } inline bool compatible(SEXP x) { return RTYPE == TYPEOF(x) || all_logical_na(x, TYPEOF(x)); } bool can_promote(SEXP) const { return false; } std::string describe() const { return vector_class(); } bool is_logical_all_na() const { return all_logical_na(data, RTYPE); } protected: Rcpp::Vector data; private: void collect_logicalNA(const SlicingIndex& index) { for (int i = 0; i < index.size(); i++) { data[index[i]] = Rcpp::traits::get_na(); } } void collect_sexp(const SlicingIndex& index, SEXP v, int offset = 0) { warn_loss_attr(v); Rcpp::Vector source(v); STORAGE* source_ptr = Rcpp::internal::r_vector_start(source); source_ptr = source_ptr + offset; for (int i = 0; i < index.size(); i++) { data[index[i]] = source_ptr[i]; } } }; template <> class Collecter_Impl : public Collecter { public: Collecter_Impl(int n_): data(n_, NA_REAL) {} void collect(const SlicingIndex& index, SEXP v, int offset = 0) { warn_loss_attr(v); Rcpp::NumericVector source(v); double* source_ptr = source.begin() + offset; for (int i = 0; i < index.size(); i++) { data[index[i]] = source_ptr[i]; } } inline SEXP get() { return data; } inline bool compatible(SEXP x) { int RTYPE = TYPEOF(x); return (RTYPE == REALSXP && !Rf_inherits(x, "POSIXct") && !Rf_inherits(x, "Date")) || (RTYPE == INTSXP && !Rf_inherits(x, "factor")) || all_logical_na(x, RTYPE); } bool can_promote(SEXP) const { return false; } std::string describe() const { return "numeric"; } protected: Rcpp::NumericVector data; }; template <> class Collecter_Impl : public Collecter { public: Collecter_Impl(int n_): data(n_, NA_STRING) {} void collect(const SlicingIndex& index, SEXP v, int offset = 0) { warn_loss_attr(v); if (TYPEOF(v) == STRSXP) { collect_strings(index, v, offset); } else if (Rf_inherits(v, "factor")) { collect_factor(index, v, offset); } else if (all_logical_na(v, TYPEOF(v))) { collect_logicalNA(index, v); } else { Rcpp::CharacterVector vec(v); collect_strings(index, vec, offset); } } inline SEXP get() { return data; } inline bool compatible(SEXP x) { return (STRSXP == TYPEOF(x)) || Rf_inherits(x, "factor") || all_logical_na(x, TYPEOF(x)); } bool can_promote(SEXP) const { return false; } std::string describe() const { return "character"; } protected: Rcpp::CharacterVector data; private: void collect_logicalNA(const SlicingIndex& index, Rcpp::LogicalVector) { int n = index.size(); for (int i = 0; i < n; i++) { SET_STRING_ELT(data, index[i], NA_STRING); } } void collect_strings(const SlicingIndex& index, Rcpp::CharacterVector source, int offset = 0) { SEXP* p_source = Rcpp::internal::r_vector_start(source) + offset; int n = index.size(); for (int i = 0; i < n; i++) { SET_STRING_ELT(data, index[i], p_source[i]); } } void collect_factor(const SlicingIndex& index, Rcpp::IntegerVector source, int offset = 0) { Rcpp::CharacterVector levels = get_levels(source); Rf_warning("binding character and factor vector, coercing into character vector"); for (int i = 0; i < index.size(); i++) { if (source[i] == NA_INTEGER) { data[index[i]] = NA_STRING; } else { data[index[i]] = levels[source[i + offset] - 1]; } } } }; template <> class Collecter_Impl : public Collecter { public: Collecter_Impl(int n_): data(n_, NA_INTEGER) {} void collect(const SlicingIndex& index, SEXP v, int offset = 0) { warn_loss_attr(v); Rcpp::IntegerVector source(v); int* source_ptr = source.begin() + offset; for (int i = 0; i < index.size(); i++) { data[index[i]] = source_ptr[i]; } } inline SEXP get() { return data; } inline bool compatible(SEXP x) { int RTYPE = TYPEOF(x); return ((INTSXP == RTYPE) && !Rf_inherits(x, "factor")) || all_logical_na(x, RTYPE); } bool can_promote(SEXP x) const { return TYPEOF(x) == REALSXP && !Rf_inherits(x, "POSIXct") && !Rf_inherits(x, "Date"); } std::string describe() const { return "integer"; } protected: Rcpp::IntegerVector data; }; template <> class Collecter_Impl : public Collecter { public: Collecter_Impl(int n_): data(n_, (Rbyte)0) {} void collect(const SlicingIndex& index, SEXP v, int offset = 0) { warn_loss_attr(v); Rcpp::RawVector source(v); Rbyte* source_ptr = source.begin() + offset; for (int i = 0; i < index.size(); i++) { data[index[i]] = source_ptr[i]; } } inline SEXP get() { return data; } inline bool compatible(SEXP x) { return TYPEOF(x) == RAWSXP ; } bool can_promote(SEXP x) const { return (TYPEOF(x) == REALSXP && !Rf_inherits(x, "POSIXct") && !Rf_inherits(x, "Date")) || (TYPEOF(x) == INTSXP && !Rf_inherits(x, "factor")) ; } std::string describe() const { return "raw"; } protected: Rcpp::RawVector data; }; template class TypedCollecter : public Collecter_Impl { public: TypedCollecter(int n, SEXP types_) : Collecter_Impl(n), types(types_) {} inline SEXP get() { Rcpp::Vector data = Collecter_Impl::data; set_class(data, types); return data; } inline bool compatible(SEXP x) { Rcpp::String type = STRING_ELT(types, 0); return Rf_inherits(x, type.get_cstring()) || all_logical_na(x, TYPEOF(x)); } inline bool can_promote(SEXP) const { return false; } std::string describe() const { return collapse_utf8(types); } private: SEXP types; }; class POSIXctCollecter : public Collecter_Impl { public: typedef Collecter_Impl Parent; POSIXctCollecter(int n, SEXP tz_) : Parent(n), tz(tz_) {} void collect(const SlicingIndex& index, SEXP v, int offset = 0) { if (Rf_inherits(v, "POSIXct")) { Parent::collect(index, v, offset); update_tz(v); } else if (all_logical_na(v, TYPEOF(v))) { Parent::collect(index, v, offset); } } inline SEXP get() { Rf_classgets(data, get_time_classes()); if (!tz.isNULL()) { Rf_setAttrib(Parent::data, symbols::tzone, tz); } return Parent::data; } inline bool compatible(SEXP x) { return Rf_inherits(x, "POSIXct") || all_logical_na(x, TYPEOF(x)); } inline bool can_promote(SEXP) const { return false; } std::string describe() const { return collapse_utf8(get_time_classes()); } private: void update_tz(SEXP v) { Rcpp::RObject v_tz(Rf_getAttrib(v, symbols::tzone)); // if the new tz is NULL, keep previous value if (v_tz.isNULL()) return; if (tz.isNULL()) { // if current tz is NULL, grab the new one tz = v_tz; } else { // none are NULL, so compare them // if they are equal, fine if (STRING_ELT(tz, 0) == STRING_ELT(v_tz, 0)) return; // otherwise, settle to UTC tz = Rf_mkString("UTC"); } } Rcpp::RObject tz; }; class DifftimeCollecter : public Collecter_Impl { public: typedef Collecter_Impl Parent; DifftimeCollecter(int n, std::string units_, SEXP types_) : Parent(n), units(units_), types(types_) {} void collect(const SlicingIndex& index, SEXP v, int offset = 0) { if (Rf_inherits(v, "difftime")) { collect_difftime(index, v, offset); } else if (all_logical_na(v, TYPEOF(v))) { Parent::collect(index, v, offset); } } inline SEXP get() { Rf_classgets(Parent::data, types); Rf_setAttrib(Parent::data, symbols::units, Rcpp::Shield(Rf_mkString(units.c_str()))); return Parent::data; } inline bool compatible(SEXP x) { return Rf_inherits(x, "difftime") || all_logical_na(x, TYPEOF(x)); } inline bool can_promote(SEXP) const { return false; } std::string describe() const { return collapse_utf8(types); } private: bool is_valid_difftime(Rcpp::RObject x) { if (!Rf_inherits(x, "difftime") || TYPEOF(x) != REALSXP) { return false; } Rcpp::Shield units(Rf_getAttrib(x, symbols::units)); if (TYPEOF(units) != STRSXP) { return false; } return get_units_map().is_valid_difftime_unit( CHAR(STRING_ELT(units, 0)) ); } void collect_difftime(const SlicingIndex& index, Rcpp::RObject v, int offset = 0) { if (!is_valid_difftime(v)) { Rcpp::stop("Invalid difftime object"); } Rcpp::Shield units_attr(Rf_getAttrib(v, symbols::units)); std::string v_units = Rcpp::as(units_attr); if (!get_units_map().is_valid_difftime_unit(units)) { // if current unit is NULL, grab the new one units = v_units; // then collect the data: Parent::collect(index, v, offset); } else { // We had already defined the units. // Does the new vector have the same units? if (units == v_units) { Parent::collect(index, v, offset); } else { // If units are different convert the existing data and the new vector // to seconds (following the convention on // r-source/src/library/base/R/datetime.R) double factor_data = get_units_map().time_conversion_factor(units); if (factor_data != 1.0) { for (int i = 0; i < Parent::data.size(); i++) { Parent::data[i] = factor_data * Parent::data[i]; } } units = "secs"; double factor_v = get_units_map().time_conversion_factor(v_units); if (Rf_length(v) < index.size()) { Rcpp::stop("Wrong size of vector to collect"); } for (int i = 0; i < index.size(); i++) { Parent::data[index[i]] = factor_v * (REAL(v)[i + offset]); } } } } class UnitsMap { typedef std::map units_map; const units_map valid_units; static units_map create_valid_units() { units_map valid_units; double factor = 1; // Acceptable units based on r-source/src/library/base/R/datetime.R valid_units.insert(std::make_pair("secs", factor)); factor *= 60; valid_units.insert(std::make_pair("mins", factor)); factor *= 60; valid_units.insert(std::make_pair("hours", factor)); factor *= 24; valid_units.insert(std::make_pair("days", factor)); factor *= 7; valid_units.insert(std::make_pair("weeks", factor)); return valid_units; } public: UnitsMap() : valid_units(create_valid_units()) {} bool is_valid_difftime_unit(const std::string& x_units) const { return (valid_units.find(x_units) != valid_units.end()); } double time_conversion_factor(const std::string& v_units) const { units_map::const_iterator it = valid_units.find(v_units); if (it == valid_units.end()) { Rcpp::stop("Invalid difftime units (%s).", v_units.c_str()); } return it->second; } }; static const UnitsMap& get_units_map() { static UnitsMap map; return map; } private: std::string units; SEXP types; }; class FactorCollecter : public Collecter { public: typedef dplyr_hash_map LevelsMap; FactorCollecter(int n, SEXP model_): data(n, Rcpp::IntegerVector::get_na()), model(model_), levels(get_levels(model_)), levels_map() { int nlevels = levels.size(); for (int i = 0; i < nlevels; i++) levels_map[ levels[i] ] = i + 1; } bool is_factor_collecter() const { return true; } void collect(const SlicingIndex& index, SEXP v, int offset = 0) { if (offset != 0) Rcpp::stop("Nonzero offset ot supported by FactorCollecter"); if (Rf_inherits(v, "factor") && has_same_levels_as(v)) { collect_factor(index, v); } else if (all_logical_na(v, TYPEOF(v))) { collect_logicalNA(index); } } inline SEXP get() { set_levels(data, levels); set_class(data, get_class(model)); return data; } inline bool compatible(SEXP x) { return ((Rf_inherits(x, "factor") && has_same_levels_as(x)) || all_logical_na(x, TYPEOF(x))); } inline bool can_promote(SEXP x) const { return TYPEOF(x) == STRSXP || Rf_inherits(x, "factor"); } inline bool has_same_levels_as(SEXP x) const { Rcpp::CharacterVector levels_other = get_levels(x); int nlevels = levels_other.size(); if (nlevels != (int)levels_map.size()) return false; for (int i = 0; i < nlevels; i++) if (! levels_map.count(levels_other[i])) return false; return true; } inline std::string describe() const { return "factor"; } private: Rcpp::IntegerVector data; Rcpp::RObject model; Rcpp::CharacterVector levels; LevelsMap levels_map; void collect_factor(const SlicingIndex& index, SEXP v) { // here we can assume that v is a factor with the right levels // we however do not assume that they are in the same order Rcpp::IntegerVector source(v); Rcpp::CharacterVector levels = get_levels(source); SEXP* levels_ptr = Rcpp::internal::r_vector_start(levels); int* source_ptr = Rcpp::internal::r_vector_start(source); for (int i = 0; i < index.size(); i++) { if (source_ptr[i] == NA_INTEGER) { data[ index[i] ] = NA_INTEGER; } else { SEXP x = levels_ptr[ source_ptr[i] - 1 ]; data[ index[i] ] = levels_map.find(x)->second; } } } void collect_logicalNA(const SlicingIndex& index) { for (int i = 0; i < index.size(); i++) { data[ index[i] ] = NA_INTEGER; } } }; template <> inline bool Collecter_Impl::can_promote(SEXP) const { return is_logical_all_na(); } inline Collecter* collecter(SEXP model, int n) { switch (TYPEOF(model)) { case INTSXP: if (Rf_inherits(model, "POSIXct")) return new POSIXctCollecter(n, Rf_getAttrib(model, symbols::tzone)); if (Rf_inherits(model, "factor")) return new FactorCollecter(n, model); if (Rf_inherits(model, "Date")) return new TypedCollecter(n, get_date_classes()); return new Collecter_Impl(n); case REALSXP: if (Rf_inherits(model, "POSIXct")) return new POSIXctCollecter(n, Rf_getAttrib(model, symbols::tzone)); if (Rf_inherits(model, "difftime")) return new DifftimeCollecter( n, Rcpp::as(Rf_getAttrib(model, symbols::units)), Rf_getAttrib(model, R_ClassSymbol)); if (Rf_inherits(model, "Date")) return new TypedCollecter(n, get_date_classes()); if (Rf_inherits(model, "integer64")) return new TypedCollecter(n, Rcpp::CharacterVector::create("integer64")); return new Collecter_Impl(n); case CPLXSXP: return new Collecter_Impl(n); case LGLSXP: return new Collecter_Impl(n); case STRSXP: return new Collecter_Impl(n); case VECSXP: if (Rf_inherits(model, "POSIXlt")) { Rcpp::stop("POSIXlt not supported"); } if (Rf_inherits(model, "data.frame")) { Rcpp::stop("Columns of class data.frame not supported"); } return new Collecter_Impl(n); case RAWSXP: return new Collecter_Impl(n); default: break; } Rcpp::stop("is of unsupported type %s", Rf_type2char(TYPEOF(model))); } inline Collecter* promote_collecter(SEXP model, int n, Collecter* previous) { // handle the case where the previous collecter was a // Factor collecter and model is a factor. when this occurs, we need to // return a Collecter_Impl because the factors don't have the // same levels if (Rf_inherits(model, "factor") && previous->is_factor_collecter()) { Rf_warning("Unequal factor levels: coercing to character"); return new Collecter_Impl(n); } // logical NA can be promoted to whatever type comes next if (previous->is_logical_all_na()) { return collecter(model, n); } switch (TYPEOF(model)) { case INTSXP: if (Rf_inherits(model, "Date")) return new TypedCollecter(n, get_date_classes()); if (Rf_inherits(model, "factor")) return new Collecter_Impl(n); return new Collecter_Impl(n); case REALSXP: if (Rf_inherits(model, "POSIXct")) return new POSIXctCollecter(n, Rf_getAttrib(model, symbols::tzone)); if (Rf_inherits(model, "Date")) return new TypedCollecter(n, get_date_classes()); if (Rf_inherits(model, "integer64")) return new TypedCollecter(n, Rcpp::CharacterVector::create("integer64")); return new Collecter_Impl(n); case LGLSXP: return new Collecter_Impl(n); case STRSXP: if (previous->is_factor_collecter()) Rf_warning("binding factor and character vector, coercing into character vector"); return new Collecter_Impl(n); default: break; } Rcpp::stop("is of unsupported type %s", Rf_type2char(TYPEOF(model))); } } #endif dplyr/inst/include/dplyr/visitor_set/0000755000176200001440000000000013614573562017524 5ustar liggesusersdplyr/inst/include/dplyr/visitor_set/VisitorSetIndexMap.h0000644000176200001440000000215613614573562023442 0ustar liggesusers#ifndef dplyr_VisitorSetIndexMap_H #define dplyr_VisitorSetIndexMap_H #include #include #include namespace dplyr { template class VisitorSetIndexMap : public dplyr_hash_map, VisitorSetEqualPredicate > { private: typedef VisitorSetHasher Hasher; typedef VisitorSetEqualPredicate EqualPredicate; typedef typename dplyr_hash_map Base; public: VisitorSetIndexMap() : Base(), visitors(0) {} VisitorSetIndexMap(VisitorSet& visitors_) : Base(1024, Hasher(&visitors_), EqualPredicate(&visitors_)), visitors(&visitors_) {} VisitorSetIndexMap(VisitorSet* visitors_) : Base(1024, Hasher(visitors_), EqualPredicate(visitors_)), visitors(visitors_) {} VisitorSetIndexMap(VisitorSet* visitors_, int size) : Base(std::min(size, 64), Hasher(visitors_), EqualPredicate(visitors_)), visitors(visitors_) {} VisitorSet* visitors; }; } #endif dplyr/inst/include/dplyr/visitor_set/VisitorSetGreater.h0000644000176200001440000000114513614573562023323 0ustar liggesusers#ifndef dplyr_VisitorSetGreater_H #define dplyr_VisitorSetGreater_H namespace dplyr { template class VisitorSetGreater { public: bool greater(int i, int j) const { if (i == j) return false; const Class& obj = static_cast(*this); int n = obj.size(); for (int k = 0; k < n; k++) { typename Class::visitor_type* visitor = obj.get(k); if (! visitor->equal(i, j)) { return visitor->greater(i, j); } } // if we end up here, it means rows i and j are equal // we break the tie using the indices return i < j; } }; } #endif dplyr/inst/include/dplyr/visitor_set/VisitorSetHasher.h0000644000176200001440000000057513614573562023152 0ustar liggesusers#ifndef dplyr_VisitorSetHasher_H #define dplyr_VisitorSetHasher_H namespace dplyr { template class VisitorSetHasher { public: VisitorSetHasher() : visitors(0) {} VisitorSetHasher(VisitorSet* visitors_) : visitors(visitors_) {}; inline size_t operator()(int i) const { return visitors->hash(i); } private: VisitorSet* visitors; }; } #endif dplyr/inst/include/dplyr/visitor_set/VisitorSetEqualPredicate.h0000644000176200001440000000065613614573562024630 0ustar liggesusers#ifndef dplyr_VisitorSetEqualPredicate_H #define dplyr_VisitorSetEqualPredicate_H namespace dplyr { template class VisitorSetEqualPredicate { public: VisitorSetEqualPredicate() : visitors(0) {} VisitorSetEqualPredicate(VisitorSet* visitors_) : visitors(visitors_) {}; inline bool operator()(int i, int j) const { return visitors->equal(i, j); } private: VisitorSet* visitors; }; } #endif dplyr/inst/include/dplyr/visitor_set/VisitorSetLess.h0000644000176200001440000000112613614573562022637 0ustar liggesusers#ifndef dplyr_VisitorSetLess_H #define dplyr_VisitorSetLess_H namespace dplyr { template class VisitorSetLess { public: bool less(int i, int j) const { if (i == j) return false; const Class& obj = static_cast(*this); int n = obj.size(); for (int k = 0; k < n; k++) { typename Class::visitor_type* visitor = obj.get(k); if (! visitor->equal(i, j)) { return visitor->less(i, j); } } // if we end up here, it means rows i and j are equal // we break the tie using the indices return i < j; } }; } #endif dplyr/inst/include/dplyr/visitor_set/visitor_set.h0000644000176200001440000000024513614573562022250 0ustar liggesusers#ifndef dplyr_visitor_set_H #define dplyr_visitor_set_H #include #include #endif dplyr/inst/include/dplyr/visitor_set/VisitorSetHash.h0000644000176200001440000000101513614573562022611 0ustar liggesusers#ifndef dplyr_VisitorSetHash_H #define dplyr_VisitorSetHash_H #include namespace dplyr { template class VisitorSetHash { public: size_t hash(int j) const { const Class& obj = static_cast(*this); int n = obj.size(); if (n == 0) { Rcpp::stop("Need at least one column for `hash()`"); } size_t seed = obj.get(0)->hash(j); for (int k = 1; k < n; k++) { boost::hash_combine(seed, obj.get(k)->hash(j)); } return seed; } }; } #endif dplyr/inst/include/dplyr/visitor_set/VisitorSetIndexSet.h0000644000176200001440000000150713614573562023457 0ustar liggesusers#ifndef dplyr_VisitorSetIndexSet_H #define dplyr_VisitorSetIndexSet_H #include #include #include namespace dplyr { template class VisitorSetIndexSet : public dplyr_hash_set, VisitorSetEqualPredicate > { private: typedef VisitorSetHasher Hasher; typedef VisitorSetEqualPredicate EqualPredicate; typedef dplyr_hash_set Base; public: VisitorSetIndexSet() : Base() {} VisitorSetIndexSet(VisitorSet& visitors_) : Base(1024, Hasher(&visitors_), EqualPredicate(&visitors_)) {} VisitorSetIndexSet(VisitorSet* visitors_) : Base(1024, Hasher(visitors_), EqualPredicate(visitors_)) {} }; } #endif dplyr/inst/include/dplyr/visitor_set/VisitorSetEqual.h0000644000176200001440000000124513614573562023002 0ustar liggesusers#ifndef dplyr_VisitorSetEqual_H #define dplyr_VisitorSetEqual_H namespace dplyr { template class VisitorSetEqual { public: bool equal(int i, int j) const { const Class& obj = static_cast(*this); if (i == j) return true; int n = obj.size(); for (int k = 0; k < n; k++) if (! obj.get(k)->equal(i, j)) return false; return true; } bool equal_or_both_na(int i, int j) const { const Class& obj = static_cast(*this); if (i == j) return true; int n = obj.size(); for (int k = 0; k < n; k++) if (! obj.get(k)->equal_or_both_na(i, j)) return false; return true; } }; } #endif dplyr/inst/include/dplyr/visitor_set/VisitorEqualPredicate.h0000644000176200001440000000053413614573562024147 0ustar liggesusers#ifndef dplyr_VisitorEqualPredicate_H #define dplyr_VisitorEqualPredicate_H namespace dplyr { template class VisitorEqualPredicate { public: VisitorEqualPredicate(const Visitor& v_) : v(v_) {} inline bool operator()(int i, int j) const { return v.equal_or_both_na(i, j); } private: const Visitor& v; }; } #endif dplyr/inst/include/dplyr/visitor_set/VisitorHash.h0000644000176200001440000000044013614573562022136 0ustar liggesusers#ifndef dplyr_VisitorHash_H #define dplyr_VisitorHash_H namespace dplyr { template class VisitorHash { public: VisitorHash(const Visitor& v_) : v(v_) {} inline size_t operator()(int i) const { return v.hash(i); } private: const Visitor& v; }; } #endif dplyr/inst/include/dplyr/data/0000755000176200001440000000000013614573562016063 5ustar liggesusersdplyr/inst/include/dplyr/data/RowwiseDataFrame.h0000644000176200001440000000354413614573562021446 0ustar liggesusers#ifndef dplyr_tools_RowwiseDataFrame_H #define dplyr_tools_RowwiseDataFrame_H #include #include #include #include namespace dplyr { class RowwiseDataFrame; class RowwiseDataFrameIndexIterator { public: RowwiseDataFrameIndexIterator() : i(0) {} RowwiseDataFrameIndexIterator& operator++() { ++i; return *this; } RowwiseSlicingIndex operator*() const { return RowwiseSlicingIndex(i); } int i; }; class RowwiseDataFrame { public: typedef RowwiseDataFrameIndexIterator group_iterator; typedef RowwiseSlicingIndex slicing_index; RowwiseDataFrame(SEXP x): data_(x) {} RowwiseDataFrame(SEXP x, const RowwiseDataFrame& /* model */): data_(x) {} group_iterator group_begin() const { return RowwiseDataFrameIndexIterator(); } Rcpp::DataFrame& data() { return data_; } const Rcpp::DataFrame& data() const { return data_; } inline int nvars() const { return 0; } inline SymbolString symbol(int) { Rcpp::stop("Rowwise data frames don't have grouping variables"); } inline SEXP label(int) { return R_NilValue; } inline int nrows() const { return data_.nrows(); } inline int ngroups() const { return nrows(); } inline R_xlen_t max_group_size() const { return 1; } inline const SymbolVector& get_vars() const { return vars; } static inline Rcpp::CharacterVector classes() { static Rcpp::CharacterVector classes = Rcpp::CharacterVector::create("rowwise_df", "tbl_df", "tbl", "data.frame"); return classes; } void check_not_groups(const QuosureList& quosures) const {} private: Rcpp::DataFrame data_; SymbolVector vars; }; } namespace Rcpp { template <> inline bool is(SEXP x) { return Rf_inherits(x, "rowwise_df"); } } #endif dplyr/inst/include/dplyr/data/NaturalDataFrame.h0000644000176200001440000000362213614573562021412 0ustar liggesusers#ifndef dplyr_tools_NaturalDataFrame_H #define dplyr_tools_NaturalDataFrame_H #include #include #include #include namespace dplyr { class NaturalDataFrame; class NaturalDataFrameIndexIterator { public: NaturalDataFrameIndexIterator(int n_): n(n_) {} NaturalDataFrameIndexIterator& operator++() { return *this; } NaturalSlicingIndex operator*() const { return NaturalSlicingIndex(n); } private: int n; }; class NaturalDataFrame { public: typedef NaturalDataFrameIndexIterator group_iterator; typedef NaturalSlicingIndex slicing_index; NaturalDataFrame(SEXP x): data_(x) {} NaturalDataFrame(SEXP x, const NaturalDataFrame& /* model */): data_(x) {} NaturalDataFrameIndexIterator group_begin() const { return NaturalDataFrameIndexIterator(nrows()); } SymbolString symbol(int i) const { return SymbolString() ; } Rcpp::DataFrame& data() { return data_; } const Rcpp::DataFrame& data() const { return data_; } inline int ngroups() const { return 1; } inline int nvars() const { return 0; } inline int nrows() const { return data_.nrows(); } inline SEXP label(int i) const { return R_NilValue ; } inline bool has_group(const SymbolString& g) const { return false ; } inline int size() const { return data_.size() ; } inline SEXP operator[](int i) { return data_[i]; } inline const SymbolVector& get_vars() const { return vars; } static inline Rcpp::CharacterVector classes() { static Rcpp::CharacterVector classes = Rcpp::CharacterVector::create("tbl_df", "tbl", "data.frame"); return classes; } inline R_xlen_t max_group_size() const { return nrows(); } void check_not_groups(const QuosureList& quosures) const {} private: Rcpp::DataFrame data_; SymbolVector vars; }; } #endif dplyr/inst/include/dplyr/data/DataMask.h0000644000176200001440000004364313614573562017733 0ustar liggesusers#ifndef dplyr_DataMask_H #define dplyr_DataMask_H #include #include #include #include #include #include #include #include #include SEXP eval_callback(void* data_); namespace dplyr { template class DataMask; template class DataMaskProxy; template class DataMaskWeakProxy; // Manages a single binding, used by the DataMask classes below template struct ColumnBinding { private: typedef typename SlicedTibble::slicing_index Index; // is this a summary binding, i.e. does it come from summarise bool summary; // symbol of the binding SEXP symbol; // data. it is own either by the original data frame or by the // accumulator, so no need for additional protection here SEXP data; public: ColumnBinding(bool summary_, SEXP symbol_, SEXP data_) : summary(summary_), symbol(symbol_), data(data_) {} // the active binding function calls eventually calls DataMask<>::materialize // which calls this method inline SEXP get( const Index& indices, SEXP mask_resolved) { return materialize(indices, mask_resolved); } inline void clear(SEXP mask_resolved) { Rf_defineVar(symbol, R_UnboundValue, mask_resolved); } // summary accessor bool is_summary() const { return summary; } // data accessor inline SEXP get_data() const { return data; } void rm() { data = R_NilValue; } bool is_null() const { return data == R_NilValue; } // update the resolved binding in mask_resolved withe the given indices // DataMask<> only calls this on previously materialized bindings // this is only used for its side effect of storing the result // in the right environment inline void update_indices( const Index& indices, SEXP mask_resolved) { materialize(indices, mask_resolved); } // setup the active binding with a function made by dplyr:::.make_active_binding_fun // // .make_active_binding_fun holds the position and a pointer to the DataMask inline void install( SEXP mask_active, SEXP mask_resolved, int pos, boost::shared_ptr< DataMaskProxy >& data_mask_proxy ) { static Rcpp::Function make_active_binding_fun( ".make_active_binding_fun", Rcpp::Environment::namespace_env("dplyr") ); // external pointer to the weak proxy of the data mask // eventually this calls back to the reak DataMask Rcpp::XPtr< DataMaskWeakProxy > weak_proxy( new DataMaskWeakProxy(data_mask_proxy) ); Rcpp::Shield fun(make_active_binding_fun(pos, weak_proxy)); R_MakeActiveBinding( // the name of the binding symbol, // the function fun, // where to set it up as an active binding mask_active ); } // nothing to do here, this is only relevant for ColumnBinding inline void update(SEXP mask_active, SEXP mask_resolved) {} // remove the binding in the mask_active environment // so that standard evaluation does not find it // // this is a fairly expensive callback to R, but it only happens // when we use the syntax = NULL inline void detach(SEXP mask_active, SEXP mask_resolved) { Rcpp::Language("rm", symbol, Rcpp::_["envir"] = mask_active).eval(R_BaseEnv); } private: // materialize the subset of data using column_subset // and store the result in the given environment inline SEXP materialize( const typename SlicedTibble::slicing_index& indices, SEXP mask_resolved) { SEXP frame = ENCLOS(ENCLOS(mask_resolved)); // materialize Rcpp::Shield value(summary ? column_subset(data, Index(indices.group()), frame) : column_subset(data, indices, frame) ); MARK_NOT_MUTABLE(value); // store it in the mask_resolved environment Rf_defineVar(symbol, value, mask_resolved); return value; } }; // special case for NaturalDataFrame because there is no need // for active bindings in this case // // - if this is a summary, it is length 1 and can be returned as is // - otherwise, it can also be returned as is because the // NaturalDataFrame::slicing_index always want the entire column template <> struct ColumnBinding { public: ColumnBinding(bool summary_, SEXP symbol_, SEXP data_) : summary(summary_), symbol(symbol_), data(data_) {} // nothing to do here, this is never actually used inline SEXP get( const NaturalDataFrame::slicing_index& indices, SEXP mask_resolved) { return data; } inline void clear(SEXP mask_resolved) {} bool is_summary() const { return summary; } inline SEXP get_data() const { return data; } void rm() { data = R_NilValue; } bool is_null() const { return data == R_NilValue; } // never used inline void update_indices( const NaturalDataFrame::slicing_index& /* indices */, SEXP /* env */) {} // TODO: when .data knows how to look ancestry, this should use mask_resolved instead // // it does not really install an active binding because there is no need for that inline void install( SEXP mask_active, SEXP mask_resolved, int /* pos */, boost::shared_ptr< DataMaskProxy >& /* data_mask_proxy */) { Rf_defineVar(symbol, data, mask_active); } // update the (not so active) binding // this is used by cases like // mutate( x = fun(x) ) inline void update(SEXP mask_active, SEXP mask_resolved) { Rf_defineVar(symbol, data, mask_active); } // remove the binding in the mask_active environment // so that standard evaluation does not find it inline void detach(SEXP mask_active, SEXP mask_resolved) { Rcpp::Language("rm", symbol, Rcpp::_["envir"] = mask_active).eval(); } private: bool summary; SEXP symbol; SEXP data; }; // base class for instantiations of the DataMaskWeakProxy<> template // the base class is used when called from the active binding in R class DataMaskWeakProxyBase { public: DataMaskWeakProxyBase() { LOG_VERBOSE; } virtual ~DataMaskWeakProxyBase() { LOG_VERBOSE; } virtual SEXP materialize(int idx) = 0; }; // This holds a pointer to a real DataMask<> // // A DataMaskProxy<> is only used in a shared_ptr> // that is held by the DataMask<> // // This is needed because weak_ptr needs a shared_ptr template class DataMaskProxy { private: DataMask* real; public: DataMaskProxy(DataMask* real_) : real(real_) {} SEXP materialize(int idx) { return real->materialize(idx); } }; // This holds a weak_ptr to a DataMaskProxy that ultimately // calls back to the DataMask if it is still alive template class DataMaskWeakProxy : public DataMaskWeakProxyBase { private: boost::weak_ptr< DataMaskProxy > real; public: DataMaskWeakProxy(boost::shared_ptr< DataMaskProxy > real_) : real(real_) {} virtual SEXP materialize(int idx) { int nprot = 0; SEXP res = R_NilValue; { boost::shared_ptr< DataMaskProxy > lock(real.lock()); if (lock) { res = PROTECT(lock.get()->materialize(idx)); ++nprot; } } if (nprot == 0) { Rcpp::warning("Hybrid callback proxy out of scope"); } UNPROTECT(nprot); return res; } }; // typical use // // // a tibble (grouped, rowwise, or natural) // SlicedTibble data(...) ; // DataMask mask(data); // // if using hybrid evaluation, we only need to check for existence of variables // in the map with mask.maybe_get_subset_binding(SymbolString) // This returns a ColumnBinding // // if using standard evaluation, first the data_mask must be rechain() // so that it's top environment has the env as a parent // // data_mask.rechain(SEXP env) ; // // this effectively sets up the R data mask, so that we can evaluate r expressions // so for each group: // // data_mask.update(indices) // // this keeps a track of the current indices // - for bindings that have not been resolved before, nothing needs to happen // // - for bindings that were previously resolved (as tracked by the // materialized vector) they are re-materialized pro-actively // in the resolved environment template class DataMask { typedef typename SlicedTibble::slicing_index slicing_index; private: // data for the unwind-protect callback struct MaskData { SEXP expr; SEXP mask; SEXP env; }; public: // constructor // - fills the symbol map quickly (no hashing), assuming // the names are all different // - fills the column_bindings vector // // - delays setting up the environment until needed DataMask(const SlicedTibble& gdf) : column_bindings(), symbol_map(gdf.data()), active_bindings_ready(false), proxy(new DataMaskProxy(this)) { const Rcpp::DataFrame& data = gdf.data(); Rcpp::Shield names(Rf_getAttrib(data, symbols::names)); int n = data.size(); LOG_INFO << "processing " << n << " vars: " << names; // install the column_bindings without lookups in symbol_map // i.e. not using input_column for (int i = 0; i < n; i++) { column_bindings.push_back( ColumnBinding( false, SymbolString(STRING_ELT(names, i)).get_symbol(), data[i] ) ); } previous_group_size = get_context_env()["..group_size"]; previous_group_number = get_context_env()["..group_number"]; } ~DataMask() { get_context_env()["..group_size"] = previous_group_size; get_context_env()["..group_number"] = previous_group_number; if (active_bindings_ready) { clear_resolved(); } } // returns a pointer to the ColumnBinding if it exists // this is mostly used by the hybrid evaluation const ColumnBinding* maybe_get_subset_binding(const SymbolString& symbol) const { int pos = symbol_map.find(symbol); if (pos >= 0 && !column_bindings[pos].is_null()) { return &column_bindings[pos]; } else { return 0; } } const ColumnBinding* get_subset_binding(int position) const { const ColumnBinding& res = column_bindings[position]; if (res.is_null()) { return 0; } return &res; } // remove this variable from the environments void rm(const SymbolString& symbol) { int idx = symbol_map.find(symbol); if (idx < 0) return; if (active_bindings_ready) { column_bindings[idx].detach(mask_active, mask_resolved); } // so that hybrid evaluation does not find it // see maybe_get_subset_binding above column_bindings[idx].rm(); } // add a new binding, used by mutate void input_column(const SymbolString& symbol, SEXP x) { input_impl(symbol, false, x); } // add a new summarised variable, used by summarise void input_summarised(const SymbolString& symbol, SEXP x) { input_impl(symbol, true, x); } // the number of bindings int size() const { return column_bindings.size(); } // no need to call this when treating the expression with hybrid evaluation // this is why the setup if the environments is lazy, // as we might not need them at all void setup() { if (!active_bindings_ready) { Rcpp::Shelter shelter; // the active bindings have not been used at all // so setup the environments ... mask_active = shelter(child_env(R_EmptyEnv)); mask_resolved = shelter(child_env(mask_active)); // ... and install the bindings for (size_t i = 0; i < column_bindings.size(); i++) { column_bindings[i].install(mask_active, mask_resolved, i, proxy); } // setup the data mask with // // bottom : the environment with the "resolved" bindings, // this is initially empty but gets filled // as soon as the active binding is resolved // // top : the environment containing active bindings. // // data_mask : where .data etc ... are installed data_mask = shelter(rlang::new_data_mask(mask_resolved, mask_active)); // install the pronoun Rf_defineVar(symbols::dot_data, shelter(rlang::as_data_pronoun(data_mask)), data_mask); active_bindings_ready = true; } else { clear_resolved(); } } SEXP get_data_mask() const { return data_mask; } // get ready to evaluate an R expression for a given group // as identified by the indices void update(const slicing_index& indices) { // hold the current indices, as they might be needed by the active bindings set_current_indices(indices); // re-materialize the bindings that we know we need // because they have been used by previous groups when evaluating the same // expression for (size_t i = 0; i < materialized.size(); i++) { column_bindings[materialized[i]].update_indices(indices, mask_resolved); } } // called from the active binding, see utils-bindings.(R|cpp) // // the bindings are installed in the mask_bindings environment // with this R function: // // .make_active_binding_fun <- function(index, mask_proxy_xp){ // function() { // materialize_binding(index, mask_proxy_xp) // } // } // // each binding is instaled only once, the function holds: // - index: the position in the column_bindings vector // - mask_proxy_xp : an external pointer to (a proxy to) this DataMask // // materialize_binding is defined in utils-bindings.cpp as: // // SEXP materialize_binding( // int idx, // XPtr mask_proxy_xp) // { // return mask_proxy_xp->materialize(idx); // } virtual SEXP materialize(int idx) { // materialize the subset (or just fetch it on the Natural case) // // the materialized result is stored in // the mask_resolved environment, // so we don't need to further protect `res` SEXP res = column_bindings[idx].get( get_current_indices(), mask_resolved ); // remember to pro-actievely materialize this binding on the next group materialized.push_back(idx); return res; } SEXP eval(const Quosure& quo, const slicing_index& indices) { // update the bindings update(indices); // update the data context variables, these are used by n(), ... get_context_env()["..group_size"] = indices.size(); get_context_env()["..group_number"] = indices.group() + 1; #if (R_VERSION < R_Version(3, 5, 0)) Rcpp::Shield call_quote(Rf_lang2(fns::quote, quo)); Rcpp::Shield call_eval_tidy(Rf_lang3(rlang_eval_tidy(), quo, data_mask)); return Rcpp::Rcpp_fast_eval(call_eval_tidy, R_BaseEnv); #else // TODO: forward the caller env of dplyr verbs to `eval_tidy()` MaskData data = { quo, data_mask, R_BaseEnv }; return Rcpp::unwindProtect(&eval_callback, (void*) &data); #endif } private: // forbid copy construction of this class DataMask(const DataMask&); DataMask(); // the bindings managed by this data mask std::vector< ColumnBinding > column_bindings ; // indices of the bdings that have been materialized std::vector materialized ; // symbol map, used to retrieve a binding from its name SymbolMap symbol_map; // The 3 environments of the data mask Rcpp::Environment mask_active; // where the active bindings live Rcpp::Environment mask_resolved; // where the resolved active bindings live Rcpp::Environment data_mask; // actual data mask, contains the .data pronoun // are the active bindings ready ? bool active_bindings_ready; // The current indices const slicing_index* current_indices; // previous values for group_number and group_size Rcpp::RObject previous_group_size; Rcpp::RObject previous_group_number; boost::shared_ptr< DataMaskProxy > proxy; void set_current_indices(const slicing_index& indices) { current_indices = &indices; } const slicing_index& get_current_indices() { return *current_indices; } // input a new binding, from mutate or summarise void input_impl(const SymbolString& symbol, bool summarised, SEXP x) { // lookup in the symbol map for the position and whether it is a new binding SymbolMapIndex index = symbol_map.insert(symbol); ColumnBinding binding(summarised, symbol.get_symbol(), x); if (index.origin == NEW) { // when this is a new variable, install the active binding // but only if the bindings have already been installed // otherwise, nothing needs to be done if (active_bindings_ready) { binding.install(mask_active, mask_resolved, index.pos, proxy); } // push the new binding at the end of the vector column_bindings.push_back(binding); } else { // otherwise, update it if (active_bindings_ready) { binding.update(mask_active, mask_resolved); } column_bindings[index.pos] = binding; } } Rcpp::Environment& get_context_env() const { static Rcpp::Environment context_env( Rcpp::Environment::namespace_env("dplyr")["context_env"] ); return context_env; } void clear_resolved() { // remove the materialized bindings from the mask_resolved environment for (size_t i = 0; i < materialized.size(); i++) { column_bindings[materialized[i]].clear(mask_resolved); } // forget about which indices are materialized materialized.clear(); } static SEXP eval_callback(void* data_) { MaskData* data = (MaskData*) data_; return rlang::eval_tidy(data->expr, data->mask, data->env); } static SEXP rlang_eval_tidy() { static Rcpp::Language call("::", symbols::rlang, symbols::eval_tidy); return call; } }; } #endif dplyr/inst/include/dplyr/data/GroupedDataFrame.h0000644000176200001440000000771513614573562021420 0ustar liggesusers#ifndef dplyr_tools_GroupedDataFrame_H #define dplyr_tools_GroupedDataFrame_H #include #include #include #include #include #include #include namespace dplyr { class GroupedDataFrame; class GroupedDataFrameIndexIterator { public: GroupedDataFrameIndexIterator(const GroupedDataFrame& gdf_); GroupedDataFrameIndexIterator& operator++(); GroupedSlicingIndex operator*() const; int i; const GroupedDataFrame& gdf; Rcpp::ListView indices; }; class GroupedDataFrame { private: GroupedDataFrame(const GroupedDataFrame&); public: typedef GroupedDataFrameIndexIterator group_iterator; typedef GroupedSlicingIndex slicing_index; GroupedDataFrame(Rcpp::DataFrame x); GroupedDataFrame(Rcpp::DataFrame x, const GroupedDataFrame& model); group_iterator group_begin() const { return GroupedDataFrameIndexIterator(*this); } SymbolString symbol(int i) const { return symbols.get_name(i); } Rcpp::DataFrame& data() { return data_; } const Rcpp::DataFrame& data() const { return data_; } inline int size() const { return data_.size(); } inline int ngroups() const { return groups.nrow(); } inline int nvars() const { return nvars_ ; } inline int nrows() const { return data_.nrows(); } inline SEXP label(int i) const { return groups[i]; } inline bool has_group(const SymbolString& g) const { return symbols.has(g); } inline SEXP indices() const { return groups[groups.size() - 1] ; } inline const SymbolVector& get_vars() const { return symbols.get_names(); } inline const Rcpp::DataFrame& group_data() const { return groups; } template static void set_groups(Data& x, SEXP groups) { Rf_setAttrib(x, symbols::groups, groups); } template static void strip_groups(Data& x) { set_groups(x, R_NilValue); } template static void copy_groups(Data1& x, const Data2& y) { copy_attrib(x, y, symbols::groups); } static inline Rcpp::CharacterVector classes() { static Rcpp::CharacterVector classes = Rcpp::CharacterVector::create("grouped_df", "tbl_df", "tbl", "data.frame"); return classes; } bool drops() const { SEXP drop_attr = Rf_getAttrib(groups, symbols::dot_drop); return Rf_isNull(drop_attr) || (Rcpp::is(drop_attr) && LOGICAL(drop_attr)[0] != FALSE); } inline R_xlen_t max_group_size() const { R_xlen_t res = 0; SEXP rows = indices(); R_xlen_t ng = XLENGTH(rows); for (R_xlen_t i = 0; i < ng; i++) { res = std::max(XLENGTH(VECTOR_ELT(rows, i)), res); } return res; } void check_not_groups(const QuosureList& quosures) const { int n = quosures.size(); for (int i = 0; i < n; i++) { if (has_group(quosures[i].name())) bad_col(quosures[i].name(), "can't be modified because it's a grouping variable"); } } private: SymbolVector group_vars() const ; Rcpp::DataFrame data_; SymbolMap symbols; Rcpp::DataFrame groups; int nvars_; }; inline GroupedDataFrameIndexIterator::GroupedDataFrameIndexIterator(const GroupedDataFrame& gdf_) : i(0), gdf(gdf_), indices(gdf.indices()) {} inline GroupedDataFrameIndexIterator& GroupedDataFrameIndexIterator::operator++() { i++; return *this; } inline GroupedSlicingIndex GroupedDataFrameIndexIterator::operator*() const { return GroupedSlicingIndex(indices[i], i); } } namespace Rcpp { template <> inline bool is(SEXP x) { return Rf_inherits(x, "grouped_df"); } template <> class ConstReferenceInputParameter { public: typedef const dplyr::GroupedDataFrame& const_reference ; ConstReferenceInputParameter(SEXP x_) : df(x_), obj(df) {} inline operator const_reference() { return obj ; } private: DataFrame df; dplyr::GroupedDataFrame obj ; } ; } #endif dplyr/inst/include/dplyr/visitors/0000755000176200001440000000000013614573562017034 5ustar liggesusersdplyr/inst/include/dplyr/visitors/vector/0000755000176200001440000000000013614573562020336 5ustar liggesusersdplyr/inst/include/dplyr/visitors/vector/DataFrameVisitors.h0000644000176200001440000000247513614573562024106 0ustar liggesusers#ifndef dplyr_DataFrameVisitors_H #define dplyr_DataFrameVisitors_H #include #include #include #include #include #include #include namespace dplyr { class DataFrameVisitors : public VisitorSetEqual, public VisitorSetHash, public VisitorSetLess, public VisitorSetGreater { private: const Rcpp::DataFrame& data; pointer_vector visitors; SymbolVector visitor_names; public: typedef VectorVisitor visitor_type; DataFrameVisitors(const Rcpp::DataFrame& data_); DataFrameVisitors(const Rcpp::DataFrame& data_, const SymbolVector& names); DataFrameVisitors(const Rcpp::DataFrame& data_, const Rcpp::IntegerVector& indices); DataFrameVisitors(const Rcpp::DataFrame& data_, int n); inline int size() const { return visitors.size(); } inline VectorVisitor* get(int k) const { return visitors[k]; } const SymbolString name(int k) const { return visitor_names[k]; } inline int nrows() const { return data.nrows(); } }; } // namespace dplyr #endif dplyr/inst/include/dplyr/visitors/vector/DataFrameColumnVisitor.h0000644000176200001440000000161413614573562025073 0ustar liggesusers#ifndef dplyr_DataFrameColumnVisitors_H #define dplyr_DataFrameColumnVisitors_H #include namespace dplyr { class DataFrameColumnVisitor : public VectorVisitor { public: DataFrameColumnVisitor(const Rcpp::DataFrame& data_) : data(data_), visitors(data) {} inline size_t hash(int i) const { return visitors.hash(i); } inline bool equal(int i, int j) const { return visitors.equal(i, j); } inline bool equal_or_both_na(int i, int j) const { return visitors.equal_or_both_na(i, j); } inline bool less(int i, int j) const { return visitors.less(i, j); } inline bool greater(int i, int j) const { return visitors.greater(i, j); } virtual int size() const { return visitors.nrows(); } bool is_na(int) const { return false; } private: Rcpp::DataFrame data; DataFrameVisitors visitors; }; } #endif dplyr/inst/include/dplyr/visitors/vector/VectorVisitorImpl.h0000644000176200001440000000645613614573562024166 0ustar liggesusers#ifndef dplyr_VectorVisitor_Impl_H #define dplyr_VectorVisitor_Impl_H #include #include #include #include #include #include namespace dplyr { /** * Implementations */ template class VectorVisitorImpl : public VectorVisitor { typedef comparisons compare; public: typedef Rcpp::Vector VECTOR; /** * The type of data : int, double, SEXP, Rcomplex */ typedef typename Rcpp::traits::storage_type::type STORAGE; /** * Hasher for that type of data */ typedef boost::hash hasher; VectorVisitorImpl(const VECTOR& vec_) : vec(vec_) {} /** * implementations */ size_t hash(int i) const { return hash_fun(vec[i]); } inline bool equal(int i, int j) const { return compare::equal_or_both_na(vec[i], vec[j]); } inline bool less(int i, int j) const { return compare::is_less(vec[i], vec[j]); } inline bool equal_or_both_na(int i, int j) const { return compare::equal_or_both_na(vec[i], vec[j]); } inline bool greater(int i, int j) const { return compare::is_greater(vec[i], vec[j]); } int size() const { return vec.size(); } bool is_na(int i) const { return VECTOR::is_na(vec[i]); } protected: VECTOR vec; hasher hash_fun; }; template class RecyclingVectorVisitorImpl : public VectorVisitor { public: typedef Rcpp::Vector VECTOR; RecyclingVectorVisitorImpl(const VECTOR& vec_, int g_, int n_) : vec(vec_), g(g_), n(n_) {} /** * implementations */ size_t hash(int i) const { return 0 ; } inline bool equal(int i, int j) const { return true; } inline bool less(int i, int j) const { return false; } inline bool equal_or_both_na(int i, int j) const { return true; } inline bool greater(int i, int j) const { return false; } int size() const { return n; } bool is_na(int i) const { return VECTOR::is_na(vec[g]); } protected: VECTOR vec; int g; int n; }; template <> class VectorVisitorImpl : public VectorVisitor { public: typedef comparisons int_compare; VectorVisitorImpl(const Rcpp::CharacterVector& vec_) : vec(reencode_char(vec_)), has_orders(false) {} size_t hash(int i) const { return reinterpret_cast(get_item(i)); } inline bool equal(int i, int j) const { return equal_or_both_na(i, j); } inline bool less(int i, int j) const { provide_orders(); return int_compare::is_less(orders[i], orders[j]); } inline bool equal_or_both_na(int i, int j) const { return get_item(i) == get_item(j); } inline bool greater(int i, int j) const { provide_orders(); return int_compare::is_greater(orders[i], orders[j]); } int size() const { return vec.size(); } bool is_na(int i) const { return Rcpp::CharacterVector::is_na(vec[i]); } private: SEXP get_item(const int i) const { return static_cast(vec[i]); } void provide_orders() const { if (has_orders) return; orders = CharacterVectorOrderer(vec).get(); has_orders = true; } private: Rcpp::CharacterVector vec; mutable Rcpp::IntegerVector orders; mutable bool has_orders; }; } #endif dplyr/inst/include/dplyr/visitors/vector/MultipleVectorVisitors.h0000644000176200001440000000360613614573562025235 0ustar liggesusers#ifndef dplyr_MultipleVectorVisitors_H #define dplyr_MultipleVectorVisitors_H #include #include #include #include #include #include #include namespace dplyr { class MultipleVectorVisitors : public VisitorSetEqual, public VisitorSetHash, public VisitorSetLess, public VisitorSetGreater { private: // TODO: this does not need to be shared_ptr std::vector< boost::shared_ptr > visitors; int length; int ngroups; public: typedef VectorVisitor visitor_type; MultipleVectorVisitors(const Rcpp::List& data, int length_, int ngroups_) : visitors(), length(length_), ngroups(ngroups_) { visitors.reserve(data.size()); int n = data.size(); for (int i = 0; i < n; i++) { push_back(data[i]); } } inline int size() const { return visitors.size(); } inline VectorVisitor* get(int k) const { return visitors[k].get(); } inline int nrows() const { return length; } inline bool is_na(int index) const { int n = size(); for (int i = 0; i < n; i++) if (visitors[i]->is_na(index)) return true; return false; } private: // prevent copy construction MultipleVectorVisitors(const MultipleVectorVisitors&); inline void push_back(SEXP x) { int s = get_size(x); if (s == length) { visitors.push_back(boost::shared_ptr(visitor(x))); } else if (s != ngroups) { Rcpp::stop("incompatible size, should be either %d or %d (the number of groups)", length, ngroups); } } }; } // namespace dplyr #include #endif dplyr/inst/include/dplyr/visitors/vector/visitor_impl.h0000644000176200001440000000360713614573562023235 0ustar liggesusers#ifndef dplyr_visitor_impl_H #define dplyr_visitor_impl_H #include #include #include namespace dplyr { inline VectorVisitor* visitor_matrix(SEXP vec); inline VectorVisitor* visitor_vector(SEXP vec); inline VectorVisitor* visitor(SEXP vec) { if (Rf_isMatrix(vec)) { return visitor_matrix(vec); } else { return visitor_vector(vec); } } inline VectorVisitor* visitor_matrix(SEXP vec) { switch (TYPEOF(vec)) { case CPLXSXP: return new MatrixColumnVisitor(vec); case INTSXP: return new MatrixColumnVisitor(vec); case REALSXP: return new MatrixColumnVisitor(vec); case LGLSXP: return new MatrixColumnVisitor(vec); case STRSXP: return new MatrixColumnVisitor(vec); case VECSXP: return new MatrixColumnVisitor(vec); default: break; } Rcpp::stop("unsupported matrix type %s", Rf_type2char(TYPEOF(vec))); } inline VectorVisitor* visitor_vector(SEXP vec) { switch (TYPEOF(vec)) { case CPLXSXP: return new VectorVisitorImpl(vec); case INTSXP: return new VectorVisitorImpl(vec); case REALSXP: return new VectorVisitorImpl(vec); case LGLSXP: return new VectorVisitorImpl(vec); case STRSXP: return new VectorVisitorImpl(vec); case RAWSXP: return new VectorVisitorImpl(vec); case VECSXP: { if (Rf_inherits(vec, "data.frame")) { return new DataFrameColumnVisitor(vec); } if (Rf_inherits(vec, "POSIXlt")) { Rcpp::stop("POSIXlt not supported"); } return new VectorVisitorImpl(vec); } default: break; } // should not happen, safeguard against segfaults anyway Rcpp::stop("is of unsupported type %s", Rf_type2char(TYPEOF(vec))); } } #endif dplyr/inst/include/dplyr/visitors/vector/VectorVisitor.h0000644000176200001440000000151213614573562023330 0ustar liggesusers#ifndef dplyr_VectorVisitor_H #define dplyr_VectorVisitor_H namespace dplyr { /** * Vector visitor base class, defines the interface */ class VectorVisitor { public: virtual ~VectorVisitor() {} /** hash the element of the visited vector at index i */ virtual size_t hash(int i) const = 0; /** are the elements at indices i and j equal */ virtual bool equal(int i, int j) const = 0; /** are the elements at indices i and j equal or both NA */ virtual bool equal_or_both_na(int i, int j) const = 0; /** is the i element less than the j element */ virtual bool less(int i, int j) const = 0; /** is the i element less than the j element */ virtual bool greater(int i, int j) const = 0; virtual int size() const = 0; virtual bool is_na(int i) const = 0; }; inline VectorVisitor* visitor(SEXP vec); } #endif dplyr/inst/include/dplyr/visitors/vector/MatrixColumnVisitor.h0000644000176200001440000000716313614573562024520 0ustar liggesusers#ifndef dplyr_MatrixColumnVisitor_H #define dplyr_MatrixColumnVisitor_H #include namespace dplyr { template class MatrixColumnVisitor : public VectorVisitor { public: typedef typename Rcpp::traits::storage_type::type STORAGE; typedef typename Rcpp::Matrix::Column Column; class ColumnVisitor { public: typedef typename Rcpp::traits::storage_type::type STORAGE; typedef comparisons compare; typedef boost::hash hasher; ColumnVisitor(Rcpp::Matrix& data, int column) : column(data.column(column)) {} inline size_t hash(int i) const { return hash_fun(const_cast(column)[i]); } inline bool equal(int i, int j) const { return compare::equal_or_both_na(const_cast(column)[i], const_cast(column)[j]); } inline bool less(int i, int j) const { return compare::is_less(const_cast(column)[i], const_cast(column)[j]); } inline bool equal_or_both_na(int i, int j) const { return compare::equal_or_both_na(const_cast(column)[i], const_cast(column)[j]); } inline bool greater(int i, int j) const { return compare::is_greater(const_cast(column)[i], const_cast(column)[j]); } private: Column column; hasher hash_fun; }; MatrixColumnVisitor(const Rcpp::Matrix& data_) : data(data_), visitors() { for (int h = 0; h < data.ncol(); h++) { visitors.push_back(ColumnVisitor(data, h)); } } inline size_t hash(int i) const { size_t seed = visitors[0].hash(i); for (size_t h = 1; h < visitors.size(); h++) { boost::hash_combine(seed, visitors[h].hash(i)); } return seed; } inline bool equal(int i, int j) const { if (i == j) return true; for (size_t h = 0; h < visitors.size(); h++) { if (!visitors[h].equal(i, j)) return false; } return true; } inline bool equal_or_both_na(int i, int j) const { if (i == j) return true; for (size_t h = 0; h < visitors.size(); h++) { if (!visitors[h].equal_or_both_na(i, j)) return false; } return true; } inline bool less(int i, int j) const { if (i == j) return false; for (size_t h = 0; h < visitors.size(); h++) { const ColumnVisitor& v = visitors[h]; if (!v.equal(i, j)) { return v.less(i, j); } } return i < j; } inline bool greater(int i, int j) const { if (i == j) return false; for (size_t h = 0; h < visitors.size(); h++) { const ColumnVisitor& v = visitors[h]; if (!v.equal(i, j)) { return v.greater(i, j); } } return i < j; } inline int size() const { return data.nrow(); } bool is_na(int) const { return false; } private: Rcpp::Matrix data; std::vector visitors; }; template class RecyclingMatrixColumnVisitor : public VectorVisitor { public: typedef typename Rcpp::traits::storage_type::type STORAGE; RecyclingMatrixColumnVisitor(const Rcpp::Matrix& data_, int g_, int n_) : data(data_), g(g_), n(n_) {} inline size_t hash(int i) const { return 0; } inline bool equal(int i, int j) const { return true; } inline bool equal_or_both_na(int i, int j) const { return true; } inline bool less(int i, int j) const { return false; } inline bool greater(int i, int j) const { return false; } inline int size() const { return n; } bool is_na(int) const { return false; } private: Rcpp::Matrix data; int g; int n; }; } #endif dplyr/inst/include/dplyr/visitors/join/0000755000176200001440000000000013614573562017773 5ustar liggesusersdplyr/inst/include/dplyr/visitors/join/DataFrameJoinVisitors.h0000644000176200001440000000334013614573562024353 0ustar liggesusers#ifndef dplyr_DataFrameJoinVisitors_H #define dplyr_DataFrameJoinVisitors_H #include #include #include #include #include #include #include #include namespace dplyr { class DataFrameJoinVisitors : public VisitorSetEqual, public VisitorSetHash { public: DataFrameJoinVisitors( const Rcpp::DataFrame& left_, const Rcpp::DataFrame& right_, const SymbolVector& names_left, const SymbolVector& names_right, bool warn_, bool na_match ); DataFrameJoinVisitors( const Rcpp::DataFrame& left_, const Rcpp::DataFrame& right_, const Rcpp::IntegerVector& indices_left, const Rcpp::IntegerVector& indices_right, bool warn_, bool na_match ); JoinVisitor* get(int k) const; JoinVisitor* get(const SymbolString& name) const; int size() const; template inline Rcpp::DataFrame subset(const Container& index, const Rcpp::CharacterVector& classes) { int nrows = index.size(); const int nvisitors = size(); Rcpp::List out(nvisitors); for (int k = 0; k < nvisitors; k++) { out[k] = get(k)->subset(index); } set_class(out, classes); set_rownames(out, nrows); Rf_namesgets(out, visitor_names_left.get_vector()); return (SEXP)out; } private: const Rcpp::DataFrame& left; const Rcpp::DataFrame& right; SymbolVector visitor_names_left; SymbolVector visitor_names_right; pointer_vector visitors; bool warn; }; } #endif dplyr/inst/include/dplyr/visitors/join/JoinVisitorImpl.h0000644000176200001440000001670613614573562023257 0ustar liggesusers#ifndef dplyr_JoinVisitorImpl_H #define dplyr_JoinVisitorImpl_H #include #include #include #include #include #include namespace dplyr { JoinVisitor* join_visitor(const Column& left, const Column& right, bool warn, bool accept_na_match = true); void check_attribute_compatibility(const Column& left, const Column& right); template class DualVector { public: enum { RTYPE = (LHS_RTYPE > RHS_RTYPE ? LHS_RTYPE : RHS_RTYPE) }; typedef Rcpp::Vector LHS_Vec; typedef Rcpp::Vector RHS_Vec; typedef Rcpp::Vector Vec; typedef typename Rcpp::traits::storage_type::type LHS_STORAGE; typedef typename Rcpp::traits::storage_type::type RHS_STORAGE; typedef typename Rcpp::traits::storage_type::type STORAGE; public: DualVector(LHS_Vec left_, RHS_Vec right_) : left(left_), right(right_) {} LHS_STORAGE get_left_value(const int i) const { if (i < 0) Rcpp::stop("get_left_value() called with negative argument"); return left[i]; } RHS_STORAGE get_right_value(const int i) const { if (i >= 0) Rcpp::stop("get_right_value() called with nonnegative argument"); return right[-i - 1]; } bool is_left_na(const int i) const { return left.is_na(get_left_value(i)); } bool is_right_na(const int i) const { return right.is_na(get_right_value(i)); } bool is_na(const int i) const { if (i >= 0) return is_left_na(i); else return is_right_na(i); } LHS_STORAGE get_value_as_left(const int i) const { if (i >= 0) return get_left_value(i); else { RHS_STORAGE x = get_right_value(i); if (LHS_RTYPE == RHS_RTYPE) return x; else return Rcpp::internal::r_coerce(x); } } RHS_STORAGE get_value_as_right(const int i) const { if (i >= 0) { LHS_STORAGE x = get_left_value(i); if (LHS_RTYPE == RHS_RTYPE) return x; else return Rcpp::internal::r_coerce(x); } else return get_right_value(i); } STORAGE get_value(const int i) const { if (RTYPE == LHS_RTYPE) return get_value_as_left(i); else return get_value_as_right(i); } template SEXP subset(iterator it, const int n) { // We use the fact that LGLSXP < INTSXP < REALSXP, this defines our coercion precedence Rcpp::RObject ret; if (LHS_RTYPE == RHS_RTYPE) ret = subset_same(it, n); else if (LHS_RTYPE > RHS_RTYPE) ret = subset_left(it, n); else ret = subset_right(it, n); copy_most_attributes(ret, left); return ret; } template SEXP subset_same(iterator it, const int n) { Vec res(Rcpp::no_init(n)); for (int i = 0; i < n; i++, ++it) { res[i] = get_value(*it); } return res; } template SEXP subset_left(iterator it, const int n) { LHS_Vec res(Rcpp::no_init(n)); for (int i = 0; i < n; i++, ++it) { res[i] = get_value_as_left(*it); } return res; } template SEXP subset_right(iterator it, const int n) { RHS_Vec res(Rcpp::no_init(n)); for (int i = 0; i < n; i++, ++it) { res[i] = get_value_as_right(*it); } return res; } private: LHS_Vec left; RHS_Vec right; }; template class JoinVisitorImpl : public JoinVisitor { protected: typedef DualVector Storage; typedef boost::hash hasher; typedef typename Storage::LHS_Vec LHS_Vec; typedef typename Storage::RHS_Vec RHS_Vec; typedef typename Storage::Vec Vec; public: JoinVisitorImpl(const Column& left, const Column& right, const bool warn) : dual((SEXP)left.get_data(), (SEXP)right.get_data()) { if (warn) check_attribute_compatibility(left, right); } inline size_t hash(int i) { // If NAs don't match, we want to distribute their hashes as evenly as possible if (!ACCEPT_NA_MATCH && dual.is_na(i)) return static_cast(i); typename Storage::STORAGE x = dual.get_value(i); return hash_fun(x); } inline bool equal(int i, int j) { if (LHS_RTYPE == RHS_RTYPE) { // Shortcut for same data type return join_match::is_match(dual.get_value(i), dual.get_value(j)); } else if (i >= 0 && j >= 0) { return join_match::is_match(dual.get_left_value(i), dual.get_left_value(j)); } else if (i < 0 && j < 0) { return join_match::is_match(dual.get_right_value(i), dual.get_right_value(j)); } else if (i >= 0 && j < 0) { return join_match::is_match(dual.get_left_value(i), dual.get_right_value(j)); } else { return join_match::is_match(dual.get_right_value(i), dual.get_left_value(j)); } } SEXP subset(const std::vector& indices) { return dual.subset(indices.begin(), indices.size()); } SEXP subset(const VisitorSetIndexSet& set) { return dual.subset(set.begin(), set.size()); } public: hasher hash_fun; private: Storage dual; }; template class POSIXctJoinVisitor : public JoinVisitorImpl { typedef JoinVisitorImpl Parent; public: POSIXctJoinVisitor(const Column& left, const Column& right) : Parent(left, right, false), tzone(R_NilValue) { Rcpp::Shield tzone_left(Rf_getAttrib(left.get_data(), symbols::tzone)); Rcpp::Shield tzone_right(Rf_getAttrib(right.get_data(), symbols::tzone)); bool null_left = Rf_isNull(tzone_left); bool null_right = Rf_isNull(tzone_right); if (null_left && null_right) return; if (null_left) { tzone = tzone_right; } else if (null_right) { tzone = tzone_left; } else { if (STRING_ELT(tzone_left, 0) == STRING_ELT(tzone_right, 0)) { tzone = tzone_left; } else { tzone = Rf_mkString("UTC"); } } } inline SEXP subset(const std::vector& indices) { return promote(Parent::subset(indices)); } inline SEXP subset(const VisitorSetIndexSet& set) { return promote(Parent::subset(set)); } private: inline SEXP promote(Rcpp::NumericVector x) { Rf_classgets(x, get_time_classes()); if (!tzone.isNULL()) { Rf_setAttrib(x, symbols::tzone, tzone); } return x; } private: Rcpp::RObject tzone; }; class DateJoinVisitorGetter { public: virtual ~DateJoinVisitorGetter() {}; virtual double get(int i) = 0; virtual bool is_na(int i) const = 0; }; template class DateJoinVisitor : public JoinVisitorImpl { typedef JoinVisitorImpl Parent; public: DateJoinVisitor(const Column& left, const Column& right) : Parent(left, right, false) {} inline SEXP subset(const std::vector& indices) { return promote(Parent::subset(indices)); } inline SEXP subset(const VisitorSetIndexSet& set) { return promote(Parent::subset(set)); } private: static SEXP promote(SEXP x) { Rf_classgets(x, get_date_classes()); return x; } private: typename Parent::hasher hash_fun; }; } #endif dplyr/inst/include/dplyr/visitors/join/JoinVisitor.h0000644000176200001440000000067513614573562022433 0ustar liggesusers#ifndef dplyr_JoinVisitor_H #define dplyr_JoinVisitor_H #include namespace dplyr { class DataFrameJoinVisitors; class JoinVisitor { public: virtual ~JoinVisitor() {} virtual size_t hash(int i) = 0; virtual bool equal(int i, int j) = 0; virtual SEXP subset(const std::vector& indices) = 0; virtual SEXP subset(const VisitorSetIndexSet& set) = 0; }; } #endif dplyr/inst/include/dplyr/visitors/join/Column.h0000644000176200001440000000074713614573562021411 0ustar liggesusers#ifndef DPLYR_DPLYR_COLUMN_H #define DPLYR_DPLYR_COLUMN_H class Column { public: Column(SEXP data_, const dplyr::SymbolString& name_) : data(data_), name(name_) {} public: const Rcpp::RObject& get_data() const { return data; } const dplyr::SymbolString& get_name() const { return name; } Column update_data(SEXP new_data) const { return Column(new_data, name); } private: Rcpp::RObject data; dplyr::SymbolString name; }; #endif //DPLYR_DPLYR_COLUMN_H dplyr/inst/include/dplyr/visitors/join/join_match.h0000644000176200001440000000475313614573562022270 0ustar liggesusers#ifndef dplyr_join_match_H #define dplyr_join_match_H #include namespace dplyr { // not defined on purpose template struct join_match; // specialization when LHS_TYPE == RHS_TYPE template struct join_match { typedef comparisons compare; typedef typename Rcpp::traits::storage_type::type STORAGE; static inline bool is_match(STORAGE lhs, STORAGE rhs) { return compare::equal_or_both_na(lhs, rhs) && (ACCEPT_NA_MATCH || !compare::is_na(lhs)); } }; // NaN also don't match for reals template struct join_match { typedef comparisons compare; static inline bool is_match(double lhs, double rhs) { if (ACCEPT_NA_MATCH) return compare::equal_or_both_na(lhs, rhs); else return lhs == rhs && (ACCEPT_NA_MATCH || (!compare::is_na(lhs) && !compare::is_nan(lhs))); } }; // works for both LHS_RTYPE = INTSXP and LHS_RTYPE = LGLSXP template struct join_match_int_double { static inline bool is_match(int lhs, double rhs) { LOG_VERBOSE << lhs << " " << rhs; if (double(lhs) == rhs) { return (lhs != NA_INTEGER); } else { if (ACCEPT_NA_MATCH) return (lhs == NA_INTEGER && ISNA(rhs)); else return false; } } }; template struct join_match : join_match_int_double {}; template struct join_match : join_match_int_double {}; template struct join_match_double_int { static inline bool is_match(double lhs, int rhs) { return join_match_int_double::is_match(rhs, lhs); } }; template struct join_match : join_match_double_int {}; template struct join_match : join_match_double_int {}; template struct join_match : join_match {}; template struct join_match : join_match {}; } #endif // #ifndef dplyr_join_match_H dplyr/inst/include/dplyr/visitors/CharacterVectorOrderer.h0000644000176200001440000000053213614573562023607 0ustar liggesusers#ifndef dplyr_CharacterVectorOrderer_H #define dplyr_CharacterVectorOrderer_H #include namespace dplyr { class CharacterVectorOrderer { public: CharacterVectorOrderer(const Rcpp::CharacterVector& data_); inline Rcpp::IntegerVector get() const { return orders; } private: Rcpp::IntegerVector orders; }; } #endif dplyr/inst/include/dplyr/visitors/SliceVisitor.h0000644000176200001440000000174013614573562021626 0ustar liggesusers#ifndef dplyr_visitors_SliceVisitor_h #define dplyr_visitors_SliceVisitor_h namespace dplyr { namespace visitors { template class SliceVisitor { public: typedef typename Vector::stored_type stored_type; SliceVisitor(const Vector& data_, const Index& index_) : data(data_), index(index_) {} inline stored_type operator[](int i) const { return data[index[i]]; } inline int size() const { return index.size(); } private: const Vector& data; const Index& index; }; template class WriteSliceVisitor { public: typedef typename Vector::Proxy Proxy; typedef typename Vector::stored_type stored_type; WriteSliceVisitor(Vector& data_, const Index& index_) : data(data_), index(index_) {} inline Proxy operator[](int i) { return data[index[i]]; } inline int size() const { return index.size(); } private: Vector& data; const Index& index; }; } } #endif dplyr/inst/include/dplyr/visitors/order/0000755000176200001440000000000013614573562020147 5ustar liggesusersdplyr/inst/include/dplyr/visitors/order/OrderVisitor.h0000644000176200001440000000056013614573562022754 0ustar liggesusers#ifndef dplyr_OrderVisitor_H #define dplyr_OrderVisitor_H namespace dplyr { class OrderVisitor { public: virtual ~OrderVisitor() {} /** are the elements at indices i and j equal */ virtual bool equal(int i, int j) const = 0; /** is the i element less than the j element */ virtual bool before(int i, int j) const = 0; }; } // namespace dplyr #endif dplyr/inst/include/dplyr/visitors/order/Order.h0000644000176200001440000000231213614573562021371 0ustar liggesusers#ifndef dplyr_Order_H #define dplyr_Order_H #include #include namespace dplyr { class OrderVisitors { private: class Compare { public: Compare(const OrderVisitors& obj_) : obj(obj_) {} inline bool operator()(int i, int j) const { if (i == j) return false; for (int k = 0; k < obj.n; k++) { if (! obj.visitors[k]->equal(i - 1, j - 1)) { return obj.visitors[k]->before(i - 1, j - 1); } } return i < j; } private: const OrderVisitors& obj; }; public: OrderVisitors(Rcpp::List args, Rcpp::LogicalVector ascending, int n_) : visitors(n_), n(n_), nrows(0) { nrows = Rf_length(args[0]); for (int i = 0; i < n; i++) { visitors[i] = order_visitor(args[i], ascending[i], i); } } inline Rcpp::IntegerVector apply() const { if (nrows == 0) return Rcpp::IntegerVector(0); Rcpp::IntegerVector x = Rcpp::seq(1, nrows); std::sort(x.begin(), x.end(), Compare(*this)); return x; } pointer_vector visitors; int n; int nrows; private: OrderVisitors(const OrderVisitors&); }; } // namespace dplyr #endif dplyr/inst/include/dplyr/visitors/order/OrderVisitorImpl.h0000644000176200001440000001565313614573562023607 0ustar liggesusers#ifndef dplyr_OrderVectorVisitor_Impl_H #define dplyr_OrderVectorVisitor_Impl_H #include #include #include #include #include #include #include namespace dplyr { // version used for ascending = true template class OrderVectorVisitorImpl : public OrderVisitor { typedef comparisons compare; public: /** * The type of data : int, double, SEXP, Rcomplex */ typedef typename Rcpp::traits::storage_type::type STORAGE; OrderVectorVisitorImpl(const VECTOR& vec_) : vec(vec_) {} inline bool equal(int i, int j) const { return compare::equal_or_both_na(vec[i], vec[j]); } inline bool before(int i, int j) const { return compare::is_less(vec[i], vec[j]); } private: VECTOR vec; }; // version used for ascending = false template class OrderVectorVisitorImpl : public OrderVisitor { typedef comparisons compare; public: /** * The type of data : int, double, SEXP, Rcomplex */ typedef typename Rcpp::traits::storage_type::type STORAGE; OrderVectorVisitorImpl(const VECTOR& vec_) : vec(vec_) {} inline bool equal(int i, int j) const { return compare::equal_or_both_na(vec[i], vec[j]); } inline bool before(int i, int j) const { return compare::is_greater(vec[i], vec[j]); } private: VECTOR vec; }; template class OrderCharacterVectorVisitorImpl : public OrderVisitor { public: OrderCharacterVectorVisitorImpl(const Rcpp::CharacterVector& vec_) : vec(vec_), orders(CharacterVectorOrderer(vec).get()) {} inline bool equal(int i, int j) const { return orders.equal(i, j); } inline bool before(int i, int j) const { return orders.before(i, j); } private: Rcpp::CharacterVector vec; OrderVectorVisitorImpl orders; }; // ---------- int 64 template class OrderInt64VectorVisitor : public OrderVisitor { public: OrderInt64VectorVisitor(const Rcpp::NumericVector& vec_) : vec(vec_), data(reinterpret_cast(vec.begin())) {} inline bool equal(int i, int j) const { return comparisons_int64::equal_or_both_na(data[i], data[j]); } inline bool before(int i, int j) const { return ascensing ? comparisons_int64::is_less(data[i], data[j]) : comparisons_int64::is_greater(data[i], data[j]); } private: Rcpp::NumericVector vec; int64_t* data; }; // ---------- data frame columns // ascending = true template class OrderVisitorDataFrame : public OrderVisitor { public: OrderVisitorDataFrame(const Rcpp::DataFrame& data_) : data(data_), visitors(data) {} inline bool equal(int i, int j) const { return visitors.equal(i, j); } inline bool before(int i, int j) const { return visitors.less(i, j); } private: Rcpp::DataFrame data; DataFrameVisitors visitors; }; template <> class OrderVisitorDataFrame : public OrderVisitor { public: OrderVisitorDataFrame(const Rcpp::DataFrame& data_) : data(data_), visitors(data) {} inline bool equal(int i, int j) const { return visitors.equal(i, j); } inline bool before(int i, int j) const { return visitors.greater(i, j); } private: Rcpp::DataFrame data; DataFrameVisitors visitors; }; // ---------- matrix columns // ascending = true template class OrderVisitorMatrix : public OrderVisitor { public: OrderVisitorMatrix(const Rcpp::Matrix& data_) : data(data_), visitors(data) {} inline bool equal(int i, int j) const { return visitors.equal(i, j); } inline bool before(int i, int j) const { return visitors.less(i, j); } private: Rcpp::Matrix data; MatrixColumnVisitor visitors; }; // ascending = false template class OrderVisitorMatrix : public OrderVisitor { public: OrderVisitorMatrix(const Rcpp::Matrix& data_) : data(data_), visitors(data) {} inline bool equal(int i, int j) const { return visitors.equal(i, j); } inline bool before(int i, int j) const { return visitors.greater(i, j); } private: Rcpp::Matrix data; MatrixColumnVisitor visitors; }; inline OrderVisitor* order_visitor(SEXP vec, const bool ascending, const int i); template OrderVisitor* order_visitor_asc(SEXP vec); template OrderVisitor* order_visitor_asc_matrix(SEXP vec); template OrderVisitor* order_visitor_asc_vector(SEXP vec); inline OrderVisitor* order_visitor(SEXP vec, const bool ascending, const int i) { try { if (ascending) { return order_visitor_asc(vec); } else { return order_visitor_asc(vec); } } catch (const Rcpp::exception& e) { bad_pos_arg(i + 1, e.what()); } } template inline OrderVisitor* order_visitor_asc(SEXP vec) { if (Rf_isMatrix(vec)) { return order_visitor_asc_matrix(vec); } else { return order_visitor_asc_vector(vec); } } template inline OrderVisitor* order_visitor_asc_matrix(SEXP vec) { switch (check_supported_type(vec)) { case DPLYR_INTSXP: return new OrderVisitorMatrix(vec); case DPLYR_REALSXP: return new OrderVisitorMatrix(vec); case DPLYR_LGLSXP: return new OrderVisitorMatrix(vec); case DPLYR_STRSXP: return new OrderVisitorMatrix(vec); case DPLYR_CPLXSXP: return new OrderVisitorMatrix(vec); case DPLYR_RAWSXP: return new OrderVisitorMatrix(vec); case DPLYR_VECSXP: Rcpp::stop("Matrix can't be a list"); } Rcpp::stop("Unreachable"); return 0; } template inline OrderVisitor* order_visitor_asc_vector(SEXP vec) { switch (TYPEOF(vec)) { case INTSXP: return new OrderVectorVisitorImpl >(vec); case REALSXP: if (Rf_inherits(vec, "integer64")) { return new OrderInt64VectorVisitor(vec); } return new OrderVectorVisitorImpl >(vec); case LGLSXP: return new OrderVectorVisitorImpl >(vec); case STRSXP: return new OrderCharacterVectorVisitorImpl(vec); case CPLXSXP: return new OrderVectorVisitorImpl >(vec); case RAWSXP: return new OrderVectorVisitorImpl >(vec); case VECSXP: { if (Rf_inherits(vec, "data.frame")) { return new OrderVisitorDataFrame(vec); } break; } default: break; } Rcpp::stop("is of unsupported type %s", Rf_type2char(TYPEOF(vec))); } } #endif dplyr/inst/include/dplyr/visitors/subset/0000755000176200001440000000000013614573562020341 5ustar liggesusersdplyr/inst/include/dplyr/visitors/subset/DataFrameSelect.h0000644000176200001440000000303513614573562023477 0ustar liggesusers#ifndef DPLY_VISITORS_SUBSET_DataFrameSelect_H #define DPLY_VISITORS_SUBSET_DataFrameSelect_H #include #include namespace dplyr { class DataFrameSelect { private: Rcpp::List data; public: DataFrameSelect(const Rcpp::DataFrame& data_, const SymbolVector& names): data(names.size()) { Rcpp::Shield data_names(vec_names_or_empty(data_)); Rcpp::Shield indices(names.match_in_table((SEXP)data_names)); R_xlen_t n = XLENGTH(indices); int* p_indices = INTEGER(indices); Rcpp::Shield out_names(Rf_allocVector(STRSXP, n)); for (R_xlen_t i = 0; i < n; i++) { R_xlen_t pos = p_indices[i]; if (pos == NA_INTEGER) { bad_col(names[i], "is unknown"); } data[i] = data_[pos - 1]; SET_STRING_ELT(out_names, i, STRING_ELT(data_names, pos - 1)); } Rf_namesgets(data, out_names); copy_class(data, data_); } DataFrameSelect(const Rcpp::DataFrame& data_, const Rcpp::IntegerVector& indices, bool check = true) : data(indices.size()) { Rcpp::Shield data_names(vec_names_or_empty(data_)); int n = indices.size(); Rcpp::Shield out_names(Rf_allocVector(STRSXP, n)); for (int i = 0; i < n; i++) { int pos = check ? check_range_one_based(indices[i], data_.size()) : indices[i]; SET_STRING_ELT(out_names, i, STRING_ELT(data_names, pos - 1)); data[i] = data_[pos - 1]; } Rf_namesgets(data, out_names); copy_class(data, data_); } inline operator SEXP() const { return data; } }; } #endif dplyr/inst/include/dplyr/visitors/subset/column_subset.h0000644000176200001440000001431613614573562023401 0ustar liggesusers#ifndef DPLY_VISITORS_SUBSET_column_subset_H #define DPLY_VISITORS_SUBSET_column_subset_H #include #include #include #include #include #include namespace base { SEXP bracket_one(); SEXP bracket_two(); } namespace dplyr { namespace traits { template struct can_mark_na ; template <> struct can_mark_na { typedef Rcpp::traits::true_type type; }; template <> struct can_mark_na { typedef Rcpp::traits::false_type type; }; template <> struct can_mark_na { typedef Rcpp::traits::false_type type; }; template <> struct can_mark_na { typedef Rcpp::traits::false_type type; }; } template SEXP column_subset_vector_impl(const Rcpp::Vector& x, const Index& index, Rcpp::traits::true_type) { typedef typename Rcpp::Vector::stored_type STORAGE; int n = index.size(); Rcpp::Vector res(Rcpp::no_init(n)); for (int i = 0; i < n; i++) { res[i] = index[i] == NA_INTEGER ? default_value() : (STORAGE)x[index[i] - 1]; } copy_most_attributes(res, x); return res; } template SEXP column_subset_vector_impl(const Rcpp::Vector& x, const Index& index, Rcpp::traits::false_type) { int n = index.size(); Rcpp::Vector res(Rcpp::no_init(n)); for (int i = 0; i < n; i++) { res[i] = x[index[i]]; } copy_most_attributes(res, x); return res; } template <> inline SEXP column_subset_vector_impl(const Rcpp::List& x, const RowwiseSlicingIndex& index, Rcpp::traits::true_type) { return x[index[0]]; } template <> inline SEXP column_subset_vector_impl(const Rcpp::List& x, const RowwiseSlicingIndex& index, Rcpp::traits::false_type) { return x[index[0]]; } template SEXP column_subset_matrix_impl(const Rcpp::Matrix& x, const Index& index, Rcpp::traits::true_type) { int n = index.size(); int nc = x.ncol(); Rcpp::Matrix res(Rcpp::no_init(n, nc)); for (int i = 0; i < n; i++) { if (index[i] >= 1) { res.row(i) = x.row(index[i] - 1); } else { res.row(i) = Rcpp::Vector(nc, default_value()); } } copy_most_attributes(res, x); return res; } template SEXP column_subset_matrix_impl(const Rcpp::Matrix& x, const Index& index, Rcpp::traits::false_type) { int n = index.size(); int nc = x.ncol(); Rcpp::Matrix res(Rcpp::no_init(n, nc)); for (int i = 0; i < n; i++) { res.row(i) = x.row(index[i]); } copy_most_attributes(res, x); return res; } template SEXP column_subset_impl(SEXP x, const Index& index) { if (Rf_isMatrix(x)) { return column_subset_matrix_impl(x, index, typename traits::can_mark_na::type()); } else { return column_subset_vector_impl(x, index, typename traits::can_mark_na::type()); } } template Rcpp::DataFrame dataframe_subset(const Rcpp::List& data, const Index& index, Rcpp::CharacterVector classes, SEXP frame); template SEXP r_column_subset(SEXP x, const Index& index, SEXP frame) { Rcpp::Shield one_based_index(index); if (Rf_isMatrix(x)) { Rcpp::Shield call(Rf_lang5(base::bracket_one(), x, one_based_index, R_MissingArg, Rf_ScalarLogical(false))); SET_TAG(CDR(CDR(CDDR(call))), dplyr::symbols::drop); return Rcpp::Rcpp_eval(call, frame); } else { Rcpp::Shield call(Rf_lang3(base::bracket_one(), x, one_based_index)); return Rcpp::Rcpp_eval(call, frame); } } template <> inline SEXP r_column_subset(SEXP x, const RowwiseSlicingIndex& index, SEXP frame) { if (Rf_isMatrix(x)) { Rcpp::Shield call(Rf_lang4(base::bracket_one(), x, index, R_MissingArg)); return Rcpp::Rcpp_eval(call, frame); } else { Rcpp::Shield call(Rf_lang3(base::bracket_two(), x, index)); return Rcpp::Rcpp_eval(call, frame); } } inline bool is_trivial_POSIXct(SEXP x, SEXP klass) { return TYPEOF(x) == REALSXP && TYPEOF(klass) == STRSXP && Rf_length(klass) == 2 && STRING_ELT(klass, 0) == strings::POSIXct && STRING_ELT(klass, 1) == strings::POSIXt; } inline bool is_trivial_Date(SEXP x, SEXP klass) { return TYPEOF(x) == REALSXP && TYPEOF(klass) == STRSXP && Rf_length(klass) == 1 && STRING_ELT(klass, 0) == strings::Date; } template SEXP column_subset(SEXP x, const Index& index, SEXP frame) { if (Rf_inherits(x, "data.frame")) { return dataframe_subset(x, index, Rf_getAttrib(x, R_ClassSymbol), frame); } SEXP klass = Rf_getAttrib(x, R_ClassSymbol); // trivial types, treat them specially if (!OBJECT(x) && Rf_isNull(klass)) { switch (TYPEOF(x)) { case LGLSXP: return column_subset_impl(x, index); case RAWSXP: return column_subset_impl(x, index); case INTSXP: return column_subset_impl(x, index); case STRSXP: return column_subset_impl(x, index); case REALSXP: return column_subset_impl(x, index); case CPLXSXP: return column_subset_impl(x, index); case VECSXP: return column_subset_impl(x, index); default: break; } } // special case POSIXct (#3988) if (is_trivial_POSIXct(x, klass)) { return column_subset_impl(x, index); } // special case Date (#3988) if (is_trivial_Date(x, klass)) { return column_subset_impl(x, index); } // anything else, fall back to R indexing and // possibly dispatch on [ or [[ return r_column_subset(x, index, frame); } template Rcpp::DataFrame dataframe_subset(const Rcpp::List& data, const Index& index, Rcpp::CharacterVector classes, SEXP frame) { int nc = data.size(); Rcpp::List res(nc); for (int i = 0; i < nc; i++) { res[i] = column_subset(data[i], index, frame); } copy_most_attributes(res, data); set_class(res, classes); set_rownames(res, index.size()); copy_names(res, data); return (SEXP)res; } } #endif dplyr/inst/include/dplyr/visitors/subset/DataFrameSubsetVisitors.h0000644000176200001440000000142313614573562025267 0ustar liggesusers#ifndef DPLY_VISITORS_SUBSET_DataFrameSubsetVisitors_H #define DPLY_VISITORS_SUBSET_DataFrameSubsetVisitors_H #include #include #include namespace dplyr { class DataFrameSubsetVisitors { private: Rcpp::DataFrame data; SEXP frame; public: DataFrameSubsetVisitors(const Rcpp::DataFrame& data_, SEXP frame_): data(data_), frame(frame_) {} inline int size() const { return data.size(); } template Rcpp::DataFrame subset_all(const Index& index) const { return dataframe_subset(data, index, get_class(data), frame); } template SEXP subset_one(int i, const Index& index) const { return column_subset(data[i], index, frame); } }; } #endif dplyr/inst/include/dplyr/visitors/Comparer.h0000644000176200001440000000174313614573562020762 0ustar liggesusers#ifndef dplyr_visitors_Comparer_h #define dplyr_visitors_Comparer_h #include namespace dplyr { namespace visitors { template class Comparer { public: typedef typename Vector::stored_type stored_type; Comparer(const Vector& vec_) : vec(vec_) {} inline bool operator()(int i, int j) const { stored_type lhs = vec[i], rhs = vec[j]; return comparisons::equal_or_both_na(lhs, rhs) ? i < j : comparisons::is_less(lhs, rhs) ; } private: const Vector& vec; }; template class Comparer { public: typedef typename Vector::stored_type stored_type; Comparer(const Vector& vec_) : vec(vec_) {} inline bool operator()(int i, int j) const { stored_type lhs = vec[i], rhs = vec[j]; return comparisons::equal_or_both_na(lhs, rhs) ? i < j : comparisons::is_greater(lhs, rhs) ; } private: const Vector& vec; }; } } #endif dplyr/inst/include/dplyr/lifecycle.h0000644000176200001440000000031413614573562017260 0ustar liggesusers#ifndef DPLYR_LIFECYCLE_H #define DPLYR_LIFECYCLE_H namespace dplyr { namespace lifecycle { void warn_deprecated(const std::string&); void signal_soft_deprecated(const std::string&, SEXP); } } #endif dplyr/inst/include/dplyr/NamedListAccumulator.h0000644000176200001440000000231513614573562021404 0ustar liggesusers#ifndef dplyr_NamedListAccumulator_H #define dplyr_NamedListAccumulator_H #include #include #include namespace dplyr { template class NamedListAccumulator { private: SymbolMap symbol_map; std::vector data; // owns the results public: NamedListAccumulator() {} inline void set(const SymbolString& name, Rcpp::RObject x) { if (! Rcpp::traits::same_type::value) check_supported_type(x, name); MARK_NOT_MUTABLE(x); SymbolMapIndex index = symbol_map.insert(name); if (index.origin == NEW) { data.push_back(x); } else { data[index.pos] = x; } } inline void rm(const SymbolString& name) { SymbolMapIndex index = symbol_map.rm(name); if (index.origin != NEW) { data.erase(data.begin() + index.pos); } } inline operator Rcpp::List() const { Rcpp::List out = wrap(data); Rf_namesgets(out, symbol_map.get_names().get_vector()); return out; } inline size_t size() const { return data.size(); } inline const SymbolVector& names() const { return symbol_map.get_names(); } }; } #endif dplyr/inst/include/dplyr/main.h0000644000176200001440000000046613614573562016255 0ustar liggesusers#ifndef dplyr_dplyr_main_H #define dplyr_dplyr_main_H #include #include #include #include #include #include #include #endif // #ifndef dplyr_dplyr_main_H dplyr/inst/include/dplyr/dplyr.h0000644000176200001440000000161113614573562016454 0ustar liggesusers#ifndef dplyr_dplyr_dplyr_H #define dplyr_dplyr_dplyr_H #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #endif // #ifndef dplyr_dplyr_dplyr_H dplyr/inst/include/dplyr/standard/0000755000176200001440000000000013614573562016752 5ustar liggesusersdplyr/inst/include/dplyr/standard/GroupedCallReducer.h0000644000176200001440000002654413614573562022651 0ustar liggesusers#ifndef dplyr_GroupedCallReducer_H #define dplyr_GroupedCallReducer_H #include #include #include #include #include #include #include #include #include namespace dplyr { class IDelayedProcessor { public: IDelayedProcessor() {} virtual ~IDelayedProcessor() {} virtual bool try_handle(const Rcpp::RObject& chunk) = 0; virtual IDelayedProcessor* promote(const Rcpp::RObject& chunk) = 0; virtual SEXP get() = 0; virtual std::string describe() = 0; }; template bool valid_conversion(int rtype) { return rtype == RTYPE; } template <> inline bool valid_conversion(int rtype) { switch (rtype) { case REALSXP: case INTSXP: case LGLSXP: return true; default: break; } return false; } template <> inline bool valid_conversion(int rtype) { switch (rtype) { case INTSXP: case LGLSXP: return true; default: break; } return false; } template inline bool valid_promotion(int) { return false; } template <> inline bool valid_promotion(int rtype) { return rtype == REALSXP; } template <> inline bool valid_promotion(int rtype) { return rtype == REALSXP || rtype == INTSXP; } template class DelayedProcessor : public IDelayedProcessor { public: typedef typename traits::scalar_type::type STORAGE; typedef Rcpp::Vector Vec; DelayedProcessor(const Rcpp::RObject& first_result, int ngroups_, const SymbolString& name_) : res(Rcpp::no_init(ngroups_)), pos(0), seen_na_only(true), name(name_) { LOG_VERBOSE; if (!try_handle(first_result)) { Rcpp::stop("cannot handle result of type %i for column '%s'", first_result.sexp_type(), name.get_utf8_cstring()); } copy_most_attributes(res, first_result); } DelayedProcessor(int pos_, const Rcpp::RObject& chunk, SEXP res_, const SymbolString& name_) : pos(pos_), seen_na_only(false), name(name_) { LOG_VERBOSE; copy_most_attributes(res, chunk); // We need to copy carefully here to avoid accessing uninitialized // parts of res_, which triggers valgrind failures and is inefficient Rcpp::Shelter shelter; R_xlen_t orig_length = Rf_xlength(res_); SEXP short_res_ = shelter(Rf_xlengthgets(res_, pos)); res = shelter(Rf_xlengthgets(shelter(Rcpp::as(short_res_)), orig_length)); // try_handle() changes pos as a side effect, needs to be done after copying // (we don't care about the unnecessary copy in the failure case) if (!try_handle(chunk)) { Rcpp::stop("cannot handle result of type %i in promotion for column '%s'", chunk.sexp_type(), name.get_utf8_cstring() ); } } virtual bool try_handle(const Rcpp::RObject& chunk) { LOG_VERBOSE; check_supported_type(chunk, name); check_length(Rf_length(chunk), 1, "a summary value", name); int rtype = TYPEOF(chunk); if (!valid_conversion(rtype)) { return false; } // copy, and memoize the copied value const typename Vec::stored_type& converted_chunk = (res[pos++] = Rcpp::as(chunk)); if (!Vec::is_na(converted_chunk)) seen_na_only = false; return true; } virtual IDelayedProcessor* promote(const Rcpp::RObject& chunk) { LOG_VERBOSE; if (!can_promote(chunk)) { LOG_VERBOSE << "can't promote"; return 0; } int rtype = TYPEOF(chunk); switch (rtype) { case LGLSXP: return new DelayedProcessor(pos, chunk, res, name); case INTSXP: return new DelayedProcessor(pos, chunk, res, name); case REALSXP: return new DelayedProcessor(pos, chunk, res, name); case CPLXSXP: return new DelayedProcessor(pos, chunk, res, name); case STRSXP: return new DelayedProcessor(pos, chunk, res, name); default: break; } return 0; } virtual SEXP get() { return res; } virtual std::string describe() { return vector_class(); } private: bool can_promote(const Rcpp::RObject& chunk) { return seen_na_only || valid_promotion(TYPEOF(chunk)); } private: Vec res; int pos; bool seen_na_only; const SymbolString name; }; template class FactorDelayedProcessor : public IDelayedProcessor { private: typedef dplyr_hash_map LevelsMap; public: FactorDelayedProcessor(SEXP first_result, int ngroups, const SymbolString& name_) : res(Rcpp::no_init(ngroups)), pos(0), name(name_) { copy_most_attributes(res, first_result); Rcpp::CharacterVector levels = get_levels(first_result); int n = levels.size(); for (int i = 0; i < n; i++) levels_map[ levels[i] ] = i + 1; if (!try_handle(first_result)) Rcpp::stop("cannot handle factor result for column '%s'", name.get_utf8_cstring()); } virtual bool try_handle(const Rcpp::RObject& chunk) { Rcpp::CharacterVector lev = get_levels(chunk); update_levels(lev); int val = Rcpp::as(chunk); if (val != NA_INTEGER) val = levels_map[lev[val - 1]]; res[pos++] = val; return true; } virtual IDelayedProcessor* promote(const Rcpp::RObject&) { return 0; } virtual SEXP get() { int n = levels_map.size(); Rcpp::CharacterVector levels(n); LevelsMap::iterator it = levels_map.begin(); for (int i = 0; i < n; i++, ++it) { levels[it->second - 1] = it->first; } set_levels(res, levels); return res; } virtual std::string describe() { return "factor"; } private: void update_levels(const Rcpp::CharacterVector& lev) { int nlevels = levels_map.size(); int n = lev.size(); for (int i = 0; i < n; i++) { SEXP s = lev[i]; if (! levels_map.count(s)) { levels_map.insert(std::make_pair(s, ++nlevels)); } } } Rcpp::IntegerVector res; int pos; LevelsMap levels_map; const SymbolString name; }; template class DelayedProcessor : public IDelayedProcessor { public: DelayedProcessor(SEXP first_result, int ngroups, const SymbolString& name_) : res(ngroups), pos(0), name(name_) { copy_most_attributes(res, first_result); if (!try_handle(first_result)) Rcpp::stop("cannot handle list result for column '%s'", name.get_utf8_cstring()); } virtual bool try_handle(const Rcpp::RObject& chunk) { if (Rcpp::is(chunk) && Rf_length(chunk) == 1) { res[pos++] = Rf_duplicate(VECTOR_ELT(chunk, 0)); return true; } return false; } virtual IDelayedProcessor* promote(const Rcpp::RObject&) { return 0; } virtual SEXP get() { return res; } virtual std::string describe() { return "list"; } private: Rcpp::List res; int pos; const SymbolString name; }; template IDelayedProcessor* get_delayed_processor(SEXP first_result, int ngroups, const SymbolString& name) { check_supported_type(first_result, name); check_length(Rf_length(first_result), 1, "a summary value", name); if (Rf_inherits(first_result, "factor")) { return new FactorDelayedProcessor(first_result, ngroups, name); } else if (Rcpp::is(first_result)) { return new DelayedProcessor(first_result, ngroups, name); } else if (Rcpp::is(first_result)) { return new DelayedProcessor(first_result, ngroups, name); } else if (Rcpp::is(first_result)) { return new DelayedProcessor(first_result, ngroups, name); } else if (Rcpp::is(first_result)) { return new DelayedProcessor(first_result, ngroups, name); } else if (Rcpp::is(first_result)) { return new DelayedProcessor(first_result, ngroups, name); } else if (TYPEOF(first_result) == CPLXSXP) { return new DelayedProcessor(first_result, ngroups, name); } Rcpp::stop("unknown result of type %d for column '%s'", TYPEOF(first_result), name.get_utf8_cstring()); } template class GroupedCallReducer { public: typedef typename SlicedTibble::slicing_index Index ; GroupedCallReducer(const NamedQuosure& quosure_, DataMask& data_mask_) : quosure(quosure_), data_mask(data_mask_) { data_mask.setup(); } SEXP process(const SlicedTibble& gdf) ; inline SEXP process_chunk(const Index& indices) { return data_mask.eval(quosure.get(), indices); } const SymbolString& get_name() const { return quosure.name(); } private: const NamedQuosure& quosure; DataMask& data_mask; }; template class process_data { public: process_data(const SlicedTibble& gdf, GroupedCallReducer& chunk_source_) : git(gdf.group_begin()), ngroups(gdf.ngroups()), chunk_source(chunk_source_) {} SEXP run() { if (ngroups == 0) { LOG_INFO << "no groups to process"; return get_processed_empty(); } LOG_INFO << "processing groups"; process_first(); process_rest(); return get_processed(); } private: void process_first() { Rcpp::RObject first_result = fetch_chunk(); LOG_INFO << "instantiating delayed processor for type " << type2name(first_result) << " for column `" << chunk_source.get_name().get_utf8_cstring() << "`"; processor.reset(get_delayed_processor< GroupedCallReducer >(first_result, ngroups, chunk_source.get_name())); LOG_VERBOSE << "processing " << ngroups << " groups with " << processor->describe() << " processor"; } void process_rest() { for (int i = 1; i < ngroups; ++i) { const Rcpp::RObject& chunk = fetch_chunk(); if (!try_handle_chunk(chunk)) { LOG_VERBOSE << "not handled group " << i; handle_chunk_with_promotion(chunk, i); } } } bool try_handle_chunk(const Rcpp::RObject& chunk) const { return processor->try_handle(chunk); } void handle_chunk_with_promotion(const Rcpp::RObject& chunk, const int i) { IDelayedProcessor* new_processor = processor->promote(chunk); if (!new_processor) { bad_col(chunk_source.get_name(), "can't promote group {group} to {type}", Rcpp::_["group"] = i, Rcpp::_["type"] = processor->describe()); } LOG_VERBOSE << "promoted group " << i; processor.reset(new_processor); } Rcpp::RObject fetch_chunk() { Rcpp::RObject chunk = chunk_source.process_chunk(*git); ++git; return chunk; } SEXP get_processed() const { return processor->get(); } SEXP get_processed_empty() { SEXP res = PROTECT(chunk_source.process_chunk(typename SlicedTibble::slicing_index())); // recycle res 0 times SEXP out = PROTECT(Rf_allocVector(TYPEOF(res), 0)); copy_attributes(out, res); UNPROTECT(2); return out; } private: typename SlicedTibble::group_iterator git; const int ngroups; boost::scoped_ptr processor; GroupedCallReducer& chunk_source; }; template inline SEXP GroupedCallReducer::process(const SlicedTibble& gdf) { return process_data(gdf, *this).run(); } template <> inline SEXP GroupedCallReducer::process(const NaturalDataFrame& gdf) { return process_chunk(NaturalSlicingIndex(gdf.nrows())) ; } } #endif dplyr/inst/include/dplyr/checks.h0000644000176200001440000000464713614573562016576 0ustar liggesusers#ifndef dplyr_checks_H #define dplyr_checks_H #include #include namespace dplyr { enum SupportedType { DPLYR_LGLSXP = LGLSXP, DPLYR_INTSXP = INTSXP, DPLYR_REALSXP = REALSXP, DPLYR_CPLXSXP = CPLXSXP, DPLYR_STRSXP = STRSXP, DPLYR_VECSXP = VECSXP, DPLYR_RAWSXP = RAWSXP }; inline std::string type_name(SEXP x) { switch (TYPEOF(x)) { case NILSXP: return "NULL"; case SYMSXP: return "symbol"; case S4SXP: return "S4"; case LGLSXP: return "logical vector"; case INTSXP: return "integer vector"; case REALSXP: return "double vector"; case STRSXP: return "character vector"; case CPLXSXP: return "complex vector"; case RAWSXP: return "raw vector"; case VECSXP: return "list"; case LANGSXP: return "quoted call"; case EXPRSXP: return "expression"; case ENVSXP: return "environment"; case SPECIALSXP: case BUILTINSXP: case CLOSXP: return "function"; // Everything else can fall back to R's default default: return std::string(Rf_type2char(TYPEOF(x))); } } inline SupportedType check_supported_type(SEXP x, const SymbolString& name = Rcpp::String()) { switch (TYPEOF(x)) { case LGLSXP: return DPLYR_LGLSXP; case INTSXP: return DPLYR_INTSXP; case REALSXP: return DPLYR_REALSXP; case CPLXSXP: return DPLYR_CPLXSXP; case STRSXP: return DPLYR_STRSXP; case VECSXP: return DPLYR_VECSXP; case RAWSXP: return DPLYR_RAWSXP; default: if (name.is_empty()) { Rcpp::stop("is of unsupported type %s", type_name(x)); } else { bad_col(name, "is of unsupported type {type}", Rcpp::_["type"] = type_name(x)); } } } inline void check_length(const int actual, const int expected, const char* comment, const SymbolString& name) { if (actual == expected || actual == 1) return; static Rcpp::Function check_length_col("check_length_col", Rcpp::Environment::namespace_env("dplyr")); static Rcpp::Function identity("identity", Rcpp::Environment::base_env()); Rcpp::String message = check_length_col(actual, expected, Rcpp::CharacterVector::create(name.get_sexp()), std::string(comment), Rcpp::_[".abort"] = identity); message.set_encoding(CE_UTF8); Rcpp::stop(message.get_cstring()); } inline void check_not_null(SEXP result, const SymbolString& name) { if (Rf_isNull(result)) { bad_col(name, "is of unsupported type NULL"); } } } #endif dplyr/inst/include/dplyr/workarounds/0000755000176200001440000000000013614573562017530 5ustar liggesusersdplyr/inst/include/dplyr/workarounds/xlen.h0000644000176200001440000000054013614573562020646 0ustar liggesusers#ifndef DPLYR_WORKAROUND_XLEN_H #define DPLYR_WORKAROUND_XLEN_H #ifdef LONG_VECTOR_SUPPORT namespace Rcpp { template <> inline SEXP wrap(const R_xlen_t& x) { if (x < -R_SHORT_LEN_MAX || x > R_SHORT_LEN_MAX) { return Rf_ScalarReal(static_cast(x)); } else { return Rf_ScalarInteger(static_cast(x)); } } } #endif #endif dplyr/inst/include/dplyr/workarounds/static_assert.h0000644000176200001440000001743513614573562022563 0ustar liggesusers// (C) Copyright John Maddock 2000. // Use, modification and distribution are subject to the // Boost Software License, Version 1.0. (See accompanying file // LICENSE_1_0.txt or copy at http://www.boost.org/LICENSE_1_0.txt) // See http://www.boost.org/libs/static_assert for documentation. /* Revision history: 02 August 2000 Initial version. */ #ifndef BOOST_STATIC_ASSERT_HPP #define BOOST_STATIC_ASSERT_HPP #include #include #if defined(__GNUC__) && !defined(__GXX_EXPERIMENTAL_CXX0X__) // // This is horrible, but it seems to be the only we can shut up the // "anonymous variadic macros were introduced in C99 [-Wvariadic-macros]" // warning that get spewed out otherwise in non-C++11 mode. // #pragma GCC system_header #endif #ifndef BOOST_NO_CXX11_STATIC_ASSERT # ifndef BOOST_NO_CXX11_VARIADIC_MACROS # define BOOST_STATIC_ASSERT_MSG( ... ) static_assert(__VA_ARGS__) # else # define BOOST_STATIC_ASSERT_MSG( B, Msg ) BOOST_STATIC_ASSERT( B ) # endif #else # define BOOST_STATIC_ASSERT_MSG( B, Msg ) BOOST_STATIC_ASSERT( B ) #endif #ifdef __BORLANDC__ // // workaround for buggy integral-constant expression support: #define BOOST_BUGGY_INTEGRAL_CONSTANT_EXPRESSIONS #endif #if defined(__GNUC__) && (__GNUC__ == 3) && ((__GNUC_MINOR__ == 3) || (__GNUC_MINOR__ == 4)) // gcc 3.3 and 3.4 don't produce good error messages with the default version: # define BOOST_SA_GCC_WORKAROUND #endif // // If the compiler issues warnings about old C style casts, // then enable this: // #if defined(__GNUC__) && ((__GNUC__ > 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ >= 4))) # ifndef BOOST_NO_CXX11_VARIADIC_MACROS # define BOOST_STATIC_ASSERT_BOOL_CAST( ... ) ((__VA_ARGS__) == 0 ? false : true) # else # define BOOST_STATIC_ASSERT_BOOL_CAST( x ) ((x) == 0 ? false : true) # endif #else # ifndef BOOST_NO_CXX11_VARIADIC_MACROS # define BOOST_STATIC_ASSERT_BOOL_CAST( ... ) (bool)(__VA_ARGS__) # else # define BOOST_STATIC_ASSERT_BOOL_CAST(x) (bool)(x) # endif #endif // // If the compiler warns about unused typedefs then enable this: // #if defined(__GNUC__) && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ >= 7))) || (defined(__apple_build_version__) && (__apple_build_version__ >= 7000000)) # define BOOST_STATIC_ASSERT_UNUSED_ATTRIBUTE __attribute__((unused)) #else # define BOOST_STATIC_ASSERT_UNUSED_ATTRIBUTE #endif #ifndef BOOST_NO_CXX11_STATIC_ASSERT # ifndef BOOST_NO_CXX11_VARIADIC_MACROS # define BOOST_STATIC_ASSERT( ... ) static_assert(__VA_ARGS__, #__VA_ARGS__) # else # define BOOST_STATIC_ASSERT( B ) static_assert(B, #B) # endif #else namespace boost { // HP aCC cannot deal with missing names for template value parameters template struct STATIC_ASSERTION_FAILURE; template <> struct STATIC_ASSERTION_FAILURE { enum { value = 1 }; }; // HP aCC cannot deal with missing names for template value parameters template struct static_assert_test {}; } // // Implicit instantiation requires that all member declarations be // instantiated, but that the definitions are *not* instantiated. // // It's not particularly clear how this applies to enum's or typedefs; // both are described as declarations [7.1.3] and [7.2] in the standard, // however some compilers use "delayed evaluation" of one or more of // these when implicitly instantiating templates. We use typedef declarations // by default, but try defining BOOST_USE_ENUM_STATIC_ASSERT if the enum // version gets better results from your compiler... // // Implementation: // Both of these versions rely on sizeof(incomplete_type) generating an error // message containing the name of the incomplete type. We use // "STATIC_ASSERTION_FAILURE" as the type name here to generate // an eye catching error message. The result of the sizeof expression is either // used as an enum initialiser, or as a template argument depending which version // is in use... // Note that the argument to the assert is explicitly cast to bool using old- // style casts: too many compilers currently have problems with static_cast // when used inside integral constant expressions. // #if !defined(BOOST_BUGGY_INTEGRAL_CONSTANT_EXPRESSIONS) #if defined(BOOST_MSVC) && (BOOST_MSVC < 1300) // __LINE__ macro broken when -ZI is used see Q199057 // fortunately MSVC ignores duplicate typedef's. #define BOOST_STATIC_ASSERT( B ) \ typedef ::boost::static_assert_test<\ sizeof(::boost::STATIC_ASSERTION_FAILURE< (bool)( B ) >)\ > boost_static_assert_typedef_ #elif defined(BOOST_MSVC) && defined(BOOST_NO_CXX11_VARIADIC_MACROS) #define BOOST_STATIC_ASSERT( B ) \ typedef ::boost::static_assert_test<\ sizeof(::boost::STATIC_ASSERTION_FAILURE< BOOST_STATIC_ASSERT_BOOL_CAST ( B ) >)>\ BOOST_JOIN(boost_static_assert_typedef_, __COUNTER__) #elif defined(BOOST_MSVC) #define BOOST_STATIC_ASSERT(...) \ typedef ::boost::static_assert_test<\ sizeof(::boost::STATIC_ASSERTION_FAILURE< BOOST_STATIC_ASSERT_BOOL_CAST (__VA_ARGS__) >)>\ BOOST_JOIN(boost_static_assert_typedef_, __COUNTER__) #elif (defined(BOOST_INTEL_CXX_VERSION) || defined(BOOST_SA_GCC_WORKAROUND)) && defined(BOOST_NO_CXX11_VARIADIC_MACROS) // agurt 15/sep/02: a special care is needed to force Intel C++ issue an error // instead of warning in case of failure # define BOOST_STATIC_ASSERT( B ) \ typedef char BOOST_JOIN(boost_static_assert_typedef_, __LINE__) \ [ ::boost::STATIC_ASSERTION_FAILURE< BOOST_STATIC_ASSERT_BOOL_CAST( B ) >::value ] #elif (defined(BOOST_INTEL_CXX_VERSION) || defined(BOOST_SA_GCC_WORKAROUND)) && !defined(BOOST_NO_CXX11_VARIADIC_MACROS) // agurt 15/sep/02: a special care is needed to force Intel C++ issue an error // instead of warning in case of failure # define BOOST_STATIC_ASSERT(...) \ typedef char BOOST_JOIN(boost_static_assert_typedef_, __LINE__) \ [ ::boost::STATIC_ASSERTION_FAILURE< BOOST_STATIC_ASSERT_BOOL_CAST( __VA_ARGS__ ) >::value ] #elif defined(__sgi) // special version for SGI MIPSpro compiler #define BOOST_STATIC_ASSERT( B ) \ BOOST_STATIC_CONSTANT(bool, \ BOOST_JOIN(boost_static_assert_test_, __LINE__) = ( B )); \ typedef ::boost::static_assert_test<\ sizeof(::boost::STATIC_ASSERTION_FAILURE< \ BOOST_JOIN(boost_static_assert_test_, __LINE__) >)>\ BOOST_JOIN(boost_static_assert_typedef_, __LINE__) #elif BOOST_WORKAROUND(__MWERKS__, <= 0x3003) // special version for CodeWarrior <= 8.x #define BOOST_STATIC_ASSERT( B ) \ BOOST_STATIC_CONSTANT(int, \ BOOST_JOIN(boost_static_assert_test_, __LINE__) = \ sizeof(::boost::STATIC_ASSERTION_FAILURE< BOOST_STATIC_ASSERT_BOOL_CAST( B ) >) ) #else // generic version # ifndef BOOST_NO_CXX11_VARIADIC_MACROS # define BOOST_STATIC_ASSERT( ... ) \ typedef ::boost::static_assert_test<\ sizeof(::boost::STATIC_ASSERTION_FAILURE< BOOST_STATIC_ASSERT_BOOL_CAST( __VA_ARGS__ ) >)>\ BOOST_JOIN(boost_static_assert_typedef_, __LINE__) BOOST_STATIC_ASSERT_UNUSED_ATTRIBUTE # else # define BOOST_STATIC_ASSERT( B ) \ typedef ::boost::static_assert_test<\ sizeof(::boost::STATIC_ASSERTION_FAILURE< BOOST_STATIC_ASSERT_BOOL_CAST( B ) >)>\ BOOST_JOIN(boost_static_assert_typedef_, __LINE__) BOOST_STATIC_ASSERT_UNUSED_ATTRIBUTE # endif #endif #else // alternative enum based implementation: # ifndef BOOST_NO_CXX11_VARIADIC_MACROS # define BOOST_STATIC_ASSERT( ... ) \ enum { BOOST_JOIN(boost_static_assert_enum_, __LINE__) \ = sizeof(::boost::STATIC_ASSERTION_FAILURE< (bool)( __VA_ARGS__ ) >) } # else # define BOOST_STATIC_ASSERT(B) \ enum { BOOST_JOIN(boost_static_assert_enum_, __LINE__) \ = sizeof(::boost::STATIC_ASSERTION_FAILURE< (bool)( B ) >) } # endif #endif #endif // defined(BOOST_NO_CXX11_STATIC_ASSERT) #endif // BOOST_STATIC_ASSERT_HPP dplyr/inst/include/dplyr/workarounds/installChar.h0000644000176200001440000000035313614573562022146 0ustar liggesusers#ifndef DPLYR_WORKAROUNDS_INSTALLCHAR_H #define DPLYR_WORKAROUNDS_INSTALLCHAR_H // installChar was introduced in R 3.2.0 #ifndef installChar #define installChar(x) Rf_install(CHAR(x)) #define Rf_installChar installChar #endif #endif dplyr/inst/include/dplyr/symbols.h0000644000176200001440000000321013614573562017007 0ustar liggesusers#ifndef DPLYR_SYMBOLS_H #define DPLYR_SYMBOLS_H namespace dplyr { struct symbols { static SEXP package; static SEXP n; static SEXP tzone; static SEXP units; static SEXP dot_env; static SEXP dot_data; static SEXP sum; static SEXP mean; static SEXP var; static SEXP sd; static SEXP n_distinct; static SEXP first; static SEXP last; static SEXP nth; static SEXP group_indices; static SEXP min; static SEXP max; static SEXP row_number; static SEXP ntile; static SEXP min_rank; static SEXP percent_rank; static SEXP dense_rank; static SEXP cume_dist; static SEXP lead; static SEXP lag; static SEXP in; static SEXP narm; static SEXP default_; static SEXP dplyr; static SEXP base; static SEXP stats; static SEXP desc; static SEXP double_colon; static SEXP na_rm; static SEXP new_env; static SEXP comment; static SEXP groups; static SEXP vars; static SEXP position; static SEXP op_minus; static SEXP str; static SEXP dot_Internal; static SEXP inspect; static SEXP dot; static SEXP dot_x; static SEXP drop; static SEXP rlang; static SEXP eval_tidy; static SEXP quote; static SEXP dot_drop; static SEXP warn_deprecated; static SEXP signal_soft_deprecated; static SEXP call; static SEXP env; static SEXP fun; static SEXP cpp_class; static SEXP levels; static SEXP labels; static SEXP indices; static SEXP ptype; static SEXP names; static SEXP formula; }; struct fns { static SEXP quote; }; struct strings { static SEXP POSIXct; static SEXP POSIXt; static SEXP Date; }; struct vectors { static SEXP factor; }; } // namespace dplyr #endif dplyr/inst/include/dplyr/hybrid/0000755000176200001440000000000013614573562016433 5ustar liggesusersdplyr/inst/include/dplyr/hybrid/Expression.h0000644000176200001440000003115713614573562020752 0ustar liggesusers#ifndef dplyr_hybrid_expression_h #define dplyr_hybrid_expression_h #include #include #include #include #include namespace dplyr { namespace hybrid { enum hybrid_id { NOMATCH, IN, MAX, MEAN, MIN, SUM, CUME_DIST, DENSE_RANK, FIRST, GROUP_INDICES, LAG, LAST, LEAD, MIN_RANK, N, N_DISTINCT, NTH, NTILE, PERCENT_RANK, ROW_NUMBER, SD, VAR }; struct hybrid_function { hybrid_function(SEXP name_, SEXP package_, hybrid_id id_) : name(name_), package(package_), id(id_) {} SEXP name; SEXP package; hybrid_id id; }; dplyr_hash_map& get_hybrid_inline_map(); dplyr_hash_map& get_hybrid_named_map(); // When we do hybrid evaluation of fun(...) we need to make // sure that fun is the function we want, and not masked struct FindFunData { const SEXP symbol; const SEXP env; SEXP res; FindFunData(SEXP symbol_, SEXP env_) : symbol(symbol_), env(env_), res(R_NilValue) {} inline Rboolean findFun() { return R_ToplevelExec(protected_findFun, reinterpret_cast(this)); } static void protected_findFun(void* data) { FindFunData* find_data = reinterpret_cast(data); find_data->protected_findFun(); } inline void protected_findFun() { SEXP rho = env; while (rho != R_EmptyEnv) { SEXP vl = Rf_findVarInFrame3(rho, symbol, TRUE); if (vl != R_UnboundValue) { // a promise, we need to evaluate it to find out if it // is a function promise if (TYPEOF(vl) == PROMSXP) { PROTECT(vl); vl = Rf_eval(vl, rho); UNPROTECT(1); } // we found a function if (TYPEOF(vl) == CLOSXP || TYPEOF(vl) == BUILTINSXP || TYPEOF(vl) == SPECIALSXP) { res = vl; return; } // a missing, just let R evaluation work as we have no way to // assert if the missing argument would have evaluated to a function or data if (vl == R_MissingArg) { return; } } // go in the parent environment rho = ENCLOS(rho); } return; } }; template class Expression { private: SEXP expr; SEXP env; SEXP caller_env; SEXP func; SEXP package; bool valid; const DataMask& data_mask; int n; std::vector values; std::vector tags; hybrid_id id; SEXP dot_alias; int colwise_position; public: typedef std::pair ArgPair; Expression(SEXP expr_, const DataMask& data_mask_, SEXP env_, SEXP caller_env_) : expr(expr_), env(env_), caller_env(caller_env_), func(R_NilValue), package(R_NilValue), data_mask(data_mask_), n(0), id(NOMATCH), dot_alias(R_NilValue), colwise_position(-1) { // handle the case when the expression has been colwise spliced SEXP position_attr = Rf_getAttrib(expr, symbols::position); if (!Rf_isNull(position_attr)) { colwise_position = Rcpp::as(position_attr); } // the function called, e.g. n, or dplyr::n SEXP head = CAR(expr); // when it's a inline_colwise_function, we use the formula attribute // to test for hybridability if (TYPEOF(head) == CLOSXP && Rf_inherits(head, "inline_colwise_function")) { dot_alias = CADR(expr); expr = CADR(Rf_getAttrib(head, symbols::formula)); if (TYPEOF(expr) != LANGSXP) { return; } head = CAR(expr); } if (TYPEOF(head) == SYMSXP) { handle_symbol(head); } else if (TYPEOF(head) == CLOSXP || TYPEOF(head) == BUILTINSXP || TYPEOF(head) == SPECIALSXP) { handle_function(head); } else if (TYPEOF(head) == LANGSXP && Rf_length(head) == 3 && CAR(head) == symbols::double_colon && TYPEOF(CADR(head)) == SYMSXP && TYPEOF(CADDR(head)) == SYMSXP) { handle_explicit(head); } handle_arguments(expr); } // the number of arguments in the call inline int size() const { return n; } inline hybrid_id get_id() const { return id; } // expression or value for the ith argument inline SEXP value(int i) const { return values[i]; } // is the i-th argument called `symbol` inline bool is_named(int i, SEXP symbol) const { return tags[i] == symbol; } // is the i-th argument unnamed inline bool is_unnamed(int i) const { return Rf_isNull(tags[i]); } // is the ith argument a logical scalar inline bool is_scalar_logical(int i, bool& test) const { SEXP val = values[i]; bool res = TYPEOF(val) == LGLSXP && Rf_length(val) == 1 ; if (res) { test = LOGICAL(val)[0]; } return res; } // is the i-th argument a scalar int inline bool is_scalar_int(int i, int& out) const { SEXP val = values[i]; bool unary_minus = false; // unary minus if (TYPEOF(val) == LANGSXP && Rf_length(val) == 2 && CAR(val) == symbols::op_minus) { val = CADR(val); unary_minus = true; } // symbol if (TYPEOF(val) == SYMSXP) { // reject if it's a column Column col; if (is_column(i, col)) { return false; } // keep trying if this the symbol is a binding in the .env val = Rf_findVarInFrame3(env, val, FALSE); if (val == R_UnboundValue) { return false; } } switch (TYPEOF(val)) { case INTSXP: { if (Rf_length(val) != 1) return false; int value = INTEGER(val)[0]; if (Rcpp::IntegerVector::is_na(value)) { return false; } out = unary_minus ? -value : value; return true; } case REALSXP: { if (Rf_length(val) != 1) return false; int value = Rcpp::internal::r_coerce(REAL(val)[0]); if (Rcpp::IntegerVector::is_na(value)) { return false; } out = unary_minus ? -value : value; return true; } default: break; } return false; } // is the ith argument a column inline bool is_column(int i, Column& column) const { LOG_VERBOSE << "is_column(" << i << ")"; SEXP val = PROTECT(values[i]); int nprot = 1; // when val is a quosure, grab its expression // // this allows for things like mean(!!quo(x)) or mean(!!quo(!!sym("x"))) // to go through hybrid evaluation if (rlang::is_quosure(val)) { LOG_VERBOSE << "is quosure"; val = PROTECT(rlang::quo_get_expr(val)); nprot++; } LOG_VERBOSE << "is_column_impl(false)"; bool result = is_column_impl(i, val, column, false) || is_desc_column_impl(i, val, column); UNPROTECT(nprot); return result; } inline SEXP get_fun() const { return func; } inline SEXP get_package() const { return package; } private: SEXP resolve_rlang_lambda(SEXP f) { if (Rf_inherits(f, "rlang_lambda_function") && Rf_length(expr) == 2 && TYPEOF(CADR(expr)) == SYMSXP) { dot_alias = CADR(expr); // look again: SEXP body = BODY(f); if (TYPEOF(body) == BCODESXP) { body = VECTOR_ELT(BODY_EXPR(body), 0); } if (TYPEOF(body) == LANGSXP) { SEXP head = CAR(body); if (TYPEOF(head) == SYMSXP) { // the body's car of the lambda is a symbol // need to resolve it FindFunData finder_lambda(head, CLOENV(f)); if (finder_lambda.findFun()) { f = finder_lambda.res; expr = body; } } else if (TYPEOF(head) == CLOSXP || TYPEOF(head) == BUILTINSXP || TYPEOF(head) == SPECIALSXP) { // already a function, just use that f = head; } } } return f; } inline bool is_desc_column_impl(int i, SEXP val, Column& column) const { return TYPEOF(val) == LANGSXP && Rf_length(val) == 1 && CAR(val) == symbols::desc && is_column_impl(i, CADR(val), column, true) ; } inline bool is_column_impl(int i, SEXP val, Column& column, bool desc) const { if (TYPEOF(val) == SYMSXP) { return test_is_column(i, val, column, desc); } if (TYPEOF(val) == LANGSXP && Rf_length(val) == 3 && CADR(val) == symbols::dot_data) { SEXP fun = CAR(val); SEXP rhs = CADDR(val); if (fun == R_DollarSymbol) { // .data$x if (TYPEOF(rhs) == SYMSXP) return test_is_column(i, rhs, column, desc); // .data$"x" if (TYPEOF(rhs) == STRSXP && Rf_length(rhs) == 1) return test_is_column(i, Rf_installChar(STRING_ELT(rhs, 0)), column, desc); } else if (fun == R_Bracket2Symbol) { // .data[["x"]] if (TYPEOF(rhs) == STRSXP && Rf_length(rhs) == 1) return test_is_column(i, Rf_installChar(STRING_ELT(rhs, 0)), column, desc); } } return false; } inline bool test_is_column(int i, Rcpp::Symbol s, Column& column, bool desc) const { bool is_alias = !Rf_isNull(dot_alias) && (s == symbols::dot || s == symbols::dot_x); SEXP data; if (i == 0 && colwise_position > 0 && is_alias) { // we know the position for sure because this has been colwise spliced const ColumnBinding* subset = data_mask.get_subset_binding(colwise_position - 1); if (subset->is_summary()) { return false; } data = subset->get_data(); } else { // otherwise use the hashmap if (is_alias) { s = dot_alias; } SymbolString symbol(s); // does the data mask have this symbol, and if so is it a real column (not a summarised) const ColumnBinding* subset = data_mask.maybe_get_subset_binding(symbol); if (!subset || subset->is_summary()) { return false; } data = subset->get_data() ; } column.data = data; column.is_desc = desc; return true; } inline void handle_symbol_match(FindFunData& finder) { // The function resolves to finder.res // If this happens to be a rlang_lambda_function we need to look further SEXP f = resolve_rlang_lambda(finder.res); dplyr_hash_map& map = get_hybrid_inline_map(); dplyr_hash_map::const_iterator it = map.find(f); if (it != map.end()) { func = it->second.name; package = it->second.package; id = it->second.id; } } inline void handle_symbol_workaround(SEXP head) { dplyr_hash_map& named_map = get_hybrid_named_map(); dplyr_hash_map::const_iterator it = named_map.find(head); if (it != named_map.end()) { // here when the name of the function is known by hybrid but the // function by that name was not found // // that means the relevant package was not loaded // // in 0.8.0 we warn and proceed anyway, to ease the transition from older versions func = head; package = it->second.package; id = it->second.id; std::stringstream stream; stream << "Calling `" << CHAR(PRINTNAME(head)) << "()` without importing or prefixing it is deprecated, use `" << CHAR(PRINTNAME(package)) << "::" << CHAR(PRINTNAME(head)) << "()`."; lifecycle::signal_soft_deprecated(stream.str(), caller_env); } } inline void handle_symbol(SEXP head) { // the head is a symbol, so we lookup what it resolves to // then match that against the hash map FindFunData finder(head, env); if (finder.findFun()) { if (Rf_isNull(finder.res)) { // no match was found, but // handle n(), row_number(), group_indices() in case dplyr is not imported // this is a workaround to smooth the transition to 0.8.0 handle_symbol_workaround(head); } else { handle_symbol_match(finder); } } } inline void handle_function(SEXP head) { // head is an inlined function. if it is an rlang_lambda_function, we need to look inside SEXP f = resolve_rlang_lambda(head); dplyr_hash_map::const_iterator it = get_hybrid_inline_map().find(f); if (it != get_hybrid_inline_map().end()) { func = it->second.name; package = it->second.package; id = it->second.id; } } inline void handle_explicit(SEXP head) { // a call of the `::` function, so we do not need lookup func = CADDR(head); package = CADR(head); dplyr_hash_map::const_iterator it = get_hybrid_named_map().find(func); if (it != get_hybrid_named_map().end() && it->second.package == package) { id = it->second.id; } } inline void handle_arguments(SEXP expr) { for (SEXP p = CDR(expr); !Rf_isNull(p); p = CDR(p)) { n++; values.push_back(CAR(p)); tags.push_back(TAG(p)); } } }; } } #endif dplyr/inst/include/dplyr/hybrid/HybridVectorScalarResult.h0000644000176200001440000000243113614573562023535 0ustar liggesusers#ifndef DPLYR_HYBRID_HybridVectorScalarResult_H #define DPLYR_HYBRID_HybridVectorScalarResult_H namespace dplyr { namespace hybrid { template class HybridVectorScalarResult { public: typedef typename Rcpp::Vector Vec ; typedef typename Vec::stored_type stored_type; HybridVectorScalarResult(const SlicedTibble& data_) : data(data_) {} inline Vec summarise() const { int ng = data.ngroups(); Vec vec(Rcpp::no_init(ng)); typename SlicedTibble::group_iterator git = data.group_begin(); for (int i = 0; i < ng; i++, ++git) { vec[i] = self()->process(*git); } return vec ; } inline Vec window() const { int ng = data.ngroups(); int nr = data.nrows(); Vec vec(Rcpp::no_init(nr)); typename SlicedTibble::group_iterator git = data.group_begin(); for (int i = 0; i < ng; i++, ++git) { const typename SlicedTibble::slicing_index& indices = *git; stored_type res = self()->process(indices); int ni = indices.size(); for (int j = 0; j < ni; j++) { vec[indices[j]] = res; } } return vec ; } private: const SlicedTibble& data; inline const Impl* self() const { return static_cast(this); } }; } } #endif dplyr/inst/include/dplyr/hybrid/Dispatch.h0000644000176200001440000000110013614573562020333 0ustar liggesusers#ifndef dplyr_hybrid_dispatch_h #define dplyr_hybrid_dispatch_h #include #include namespace dplyr { namespace hybrid { struct Summary { template inline SEXP operator()(const T& obj) const { return obj.summarise(); } }; struct Window { template inline SEXP operator()(const T& obj) const { return obj.window(); } }; struct Match { template inline SEXP operator()(const T& obj) const { return Rf_mkString(DEMANGLE(T)); } }; } } #endif dplyr/inst/include/dplyr/hybrid/scalar_result/0000755000176200001440000000000013614573562021276 5ustar liggesusersdplyr/inst/include/dplyr/hybrid/scalar_result/n.h0000644000176200001440000000163313614573562021707 0ustar liggesusers#ifndef dplyr_hybrid_count_h #define dplyr_hybrid_count_h #include namespace dplyr { namespace hybrid { template class Count : public HybridVectorScalarResult > { public: typedef HybridVectorScalarResult > Parent ; Count(const SlicedTibble& data) : Parent(data) {} int process(const typename SlicedTibble::slicing_index& indices) const { return indices.size(); } } ; template inline Count n_(const SlicedTibble& data) { return Count(data); } template inline SEXP n_dispatch(const SlicedTibble& data, const Expression& expression, const Operation& op) { return expression.size() == 0 ? op(n_(data)) : R_UnboundValue; } } } #endif dplyr/inst/include/dplyr/hybrid/scalar_result/mean_sd_var.h0000644000176200001440000001511613614573562023731 0ustar liggesusers#ifndef dplyr_hybrid_mean_h #define dplyr_hybrid_mean_h #include #include #include namespace dplyr { namespace hybrid { namespace internal { template class Impl > class SimpleDispatchImpl : public HybridVectorScalarResult < REALSXP, SlicedTibble, SimpleDispatchImpl > { public : typedef typename Rcpp::Vector::stored_type STORAGE; typedef HybridVectorScalarResult Parent ; SimpleDispatchImpl(const SlicedTibble& data, Column vec) : Parent(data), data_ptr(Rcpp::internal::r_vector_start(vec.data)) {} double process(const typename SlicedTibble::slicing_index& indices) const { return Impl::process(data_ptr, indices); } private: STORAGE* data_ptr; } ; template < typename SlicedTibble, template class Impl, typename Operation > class SimpleDispatch { public: SimpleDispatch(const SlicedTibble& data_, Column variable_, bool narm_, const Operation& op_): data(data_), variable(variable_), narm(narm_), op(op_) {} SEXP get() const { // dispatch to the method below based on na.rm if (narm) { return operate_narm(); } else { return operate_narm(); } } private: const SlicedTibble& data; Column variable; bool narm; const Operation& op; template SEXP operate_narm() const { // try to dispatch to the right class switch (TYPEOF(variable.data)) { case INTSXP: return op(SimpleDispatchImpl(data, variable)); case REALSXP: return op(SimpleDispatchImpl(data, variable)); case LGLSXP: return op(SimpleDispatchImpl(data, variable)); } // give up, effectively let R evaluate the call return R_UnboundValue; } }; // ------- mean template struct MeanImpl { static double process(typename Rcpp::traits::storage_type::type* ptr, const slicing_index& indices) { typedef typename Rcpp::traits::storage_type::type STORAGE; long double res = 0.0; int n = indices.size(); int m = n; for (int i = 0; i < n; i++) { STORAGE value = ptr[ indices[i] ]; // REALSXP and !NA_RM: we don't test for NA here because += NA will give NA // this is faster in the most common case where there are no NA // if there are NA, we could return quicker as in the version for // INTSXP, but we would penalize the most common case // // INTSXP, LGLSXP: no shortcut, need to test if (NA_RM || RTYPE == INTSXP || RTYPE == LGLSXP) { // both NA and NaN if (Rcpp::traits::is_na(value)) { if (!NA_RM) { // make sure we return the right kind of naan // because of this: // mean(c(NaN, 1)) -> NaN // mean(c(NA, 1) ) -> NA // // there are no NaN for INTSXP so we return NA_REAL in that case return RTYPE == REALSXP ? value : NA_REAL; } --m; continue; } } res += value; } if (m == 0) return R_NaN; res /= m; // Correcting accuracy of result, see base R implementation if (R_FINITE(res)) { long double t = 0.0; for (int i = 0; i < n; i++) { STORAGE value = ptr[indices[i]]; // need to take both NA and NaN into account here if (!NA_RM || ! Rcpp::traits::is_na(value)) { t += value - res; } } res += t / m; } return (double)res; } }; // ------------- var inline double square(double x) { return x * x; } template struct VarImpl { typedef typename Rcpp::Vector::stored_type STORAGE; static double process(typename Rcpp::traits::storage_type::type* data_ptr, const slicing_index& indices) { int n = indices.size(); if (n <= 1) return NA_REAL; double m = MeanImpl::process(data_ptr, indices); if (!R_FINITE(m)) return m; double sum = 0.0; int count = 0; for (int i = 0; i < n; i++) { STORAGE current = data_ptr[indices[i]]; if (NA_RM && Rcpp::Vector::is_na(current)) continue; sum += square(current - m); count++; } if (count <= 1) return NA_REAL; return sum / (count - 1); } }; template struct SdImpl { static double process(typename Rcpp::traits::storage_type::type* data_ptr, const slicing_index& indices) { return sqrt(VarImpl::process(data_ptr, indices)); } }; } // namespace internal template class Impl> SEXP meansdvar_dispatch(const SlicedTibble& data, const Expression& expression, const Operation& op) { Column x; bool na_rm = false; switch (expression.size()) { case 1: // fun( ) if (expression.is_unnamed(0) && expression.is_column(0, x) && x.is_trivial()) { return internal::SimpleDispatch(data, x, na_rm, op).get(); } case 2: // fun( , na.rm = ) if (expression.is_unnamed(0) && expression.is_column(0, x) && x.is_trivial() && expression.is_named(1, symbols::narm) && expression.is_scalar_logical(1, na_rm) ) { return internal::SimpleDispatch(data, x, na_rm, op).get(); } default: break; } return R_UnboundValue; } template SEXP mean_dispatch(const SlicedTibble& data, const Expression& expression, const Operation& op) { return meansdvar_dispatch(data, expression, op); } template SEXP var_dispatch(const SlicedTibble& data, const Expression& expression, const Operation& op) { return meansdvar_dispatch(data, expression, op); } template SEXP sd_dispatch(const SlicedTibble& data, const Expression& expression, const Operation& op) { return meansdvar_dispatch(data, expression, op); } } } #endif dplyr/inst/include/dplyr/hybrid/scalar_result/n_distinct.h0000644000176200001440000000536313614573562023614 0ustar liggesusers#ifndef dplyr_hybrid_n_distinct_h #define dplyr_hybrid_n_distinct_h #include #include #include #include #include namespace dplyr { namespace hybrid { namespace internal { template class N_Distinct : public HybridVectorScalarResult > { public: typedef HybridVectorScalarResult Parent ; typedef VisitorHash Hash; typedef VisitorEqualPredicate Pred; typedef dplyr_hash_set Set; N_Distinct(const SlicedTibble& data, const Rcpp::List& columns_, int nrows_, int ngroups_): Parent(data), visitors(columns_, nrows_, ngroups_), set(data.max_group_size(), Hash(visitors), Pred(visitors)) {} inline int process(const typename SlicedTibble::slicing_index& indices) const { set.clear(); int n = indices.size(); for (int i = 0; i < n; i++) { int index = indices[i]; if (!NARM || !visitors.is_na(index)) set.insert(index); } return set.size(); } private: MultipleVectorVisitors visitors; mutable Set set; }; } template SEXP n_distinct_dispatch(const SlicedTibble& tbl, const Expression& expression, const Operation& op) { std::vector columns; columns.reserve(tbl.data().size()); Rcpp::Shelter shelter; bool narm = false; int n = expression.size(); for (int i = 0; i < n; i++) { Column column; if (expression.is_named(i, symbols::narm)) { bool test ; // if we have na.rm= TRUE, or na.rm = FALSE, we can handle it if (expression.is_scalar_logical(i, test)) { narm = test; } else { // otherwise, we need R to evaluate it, so we give up return R_UnboundValue; } } else if (expression.is_column(i, column) && column.is_trivial()) { columns.push_back(shelter(column.data)); } else { // give up, R will handle the call return R_UnboundValue; } } // let R handle the call if (!columns.size()) { return R_UnboundValue; } Rcpp::Shield s_columns(Rcpp::wrap(columns)); Rcpp::List lst_columns(s_columns); SEXP res; if (narm) { internal::N_Distinct distinct(tbl, lst_columns, tbl.nrows(), tbl.ngroups()); res = PROTECT(op(distinct)); } else { internal::N_Distinct distinct(tbl, lst_columns, tbl.nrows(), tbl.ngroups()); res = PROTECT(op(distinct)); } UNPROTECT(1); return res; } } } #endif dplyr/inst/include/dplyr/hybrid/scalar_result/min_max.h0000644000176200001440000001047313614573562023104 0ustar liggesusers#ifndef dplyr_hybrid_min_max_h #define dplyr_hybrid_min_max_h #include #include #include #include namespace dplyr { namespace hybrid { namespace internal { template class MinMax : public HybridVectorScalarResult > { public: typedef HybridVectorScalarResult Parent ; typedef typename Rcpp::Vector::stored_type STORAGE; MinMax(const SlicedTibble& data, Column column_): Parent(data), column(column_.data), warn(false) {} ~MinMax() {} inline double process(const typename SlicedTibble::slicing_index& indices) const { const int n = indices.size(); double res = Inf; for (int i = 0; i < n; ++i) { STORAGE current = column[indices[i]]; // both NA and NaN in the REALSXP case if (Rcpp::traits::is_na(current)) { if (NA_RM) { continue; } else { return RTYPE == REALSXP ? current : NA_REAL; } } else { if (is_better(current, res)) { res = current; } } } return res; } private: Rcpp::Vector column; mutable bool warn; static const double Inf; inline static bool is_better(const double current, const double res) { if (MINIMUM) return current < res; else return res < current ; } }; template const double MinMax::Inf = (MINIMUM ? R_PosInf : R_NegInf); inline bool is_infinite(double x) { return !R_FINITE(x); } template SEXP maybe_coerce_minmax(SEXP x) { if (TYPEOF(x) != REALSXP) return x; double* end = REAL(x) + XLENGTH(x); if (std::find_if(REAL(x), end, is_infinite) != end) { return x; } return Rcpp::as< Rcpp::Vector >(x); } } // min( ) template SEXP minmax_narm(const SlicedTibble& data, Column x, const Operation& op) { // only handle basic number types, anything else goes through R switch (TYPEOF(x.data)) { case RAWSXP: return internal::maybe_coerce_minmax(Rcpp::Shield(op(internal::MinMax(data, x)))); case INTSXP: return internal::maybe_coerce_minmax(Rcpp::Shield(op(internal::MinMax(data, x)))); case REALSXP: return op(internal::MinMax(data, x)); default: break; } return R_UnboundValue; } template SEXP minmax_(const SlicedTibble& data, Column x, bool narm, const Operation& op) { if (narm) { return minmax_narm(data, x, op) ; } else { return minmax_narm(data, x, op) ; } } template SEXP minmax_dispatch(const SlicedTibble& data, const Expression& expression, const Operation& op) { Column x; switch (expression.size()) { case 1: // min( ) if (expression.is_unnamed(0) && expression.is_column(0, x) && x.is_trivial()) { return minmax_(data, x, false, op) ; } case 2: // min( , na.rm = ) bool test; if (expression.is_unnamed(0) && expression.is_column(0, x) && x.is_trivial() && expression.is_named(1, symbols::narm) && expression.is_scalar_logical(1, test)) { return minmax_(data, x, test, op) ; } default: break; } return R_UnboundValue; } template SEXP min_dispatch(const SlicedTibble& data, const Expression& expression, const Operation& op) { return minmax_dispatch(data, expression, op); } template SEXP max_dispatch(const SlicedTibble& data, const Expression& expression, const Operation& op) { return minmax_dispatch(data, expression, op); } } } #endif dplyr/inst/include/dplyr/hybrid/scalar_result/group_indices.h0000644000176200001440000000163013614573562024301 0ustar liggesusers#ifndef dplyr_hybrid_group_indices_h #define dplyr_hybrid_group_indices_h #include namespace dplyr { namespace hybrid { namespace internal { template class GroupIndices : public HybridVectorScalarResult > { public: typedef HybridVectorScalarResult Parent ; GroupIndices(const SlicedTibble& data) : Parent(data) {} inline int process(const typename SlicedTibble::slicing_index& indices) const { return indices.group() + 1; } }; } // group_indices() template inline SEXP group_indices_dispatch(const SlicedTibble& data, const Expression& expression, const Operation& op) { return expression.size() == 0 ? op(internal::GroupIndices(data)) : R_UnboundValue; } } } #endif dplyr/inst/include/dplyr/hybrid/scalar_result/first_last.h0000644000176200001440000001553413614573562023631 0ustar liggesusers#ifndef dplyr_hybrid_first_last_h #define dplyr_hybrid_first_last_h #include #include #include #include #include namespace dplyr { namespace hybrid { namespace internal { template class Nth2 : public HybridVectorScalarResult > { public: typedef HybridVectorScalarResult Parent ; typedef typename Rcpp::Vector::stored_type STORAGE; Nth2(const SlicedTibble& data, Column column_, int pos_): Parent(data), column(column_.data), pos(pos_), def(default_value()) {} Nth2(const SlicedTibble& data, Column column_, int pos_, SEXP def_): Parent(data), column(column_.data), pos(pos_), def(Rcpp::internal::r_vector_start(def_)[0]) {} inline STORAGE process(const typename SlicedTibble::slicing_index& indices) const { int n = indices.size(); if (n == 0) return def ; if (pos > 0 && pos <= n) { return column[indices[pos - 1]]; } else if (pos < 0 && pos >= -n) { return column[indices[n + pos]]; } return def; } private: Rcpp::Vector column; int pos; STORAGE def; }; template class Nth2_Factor : public Nth2 { typedef Nth2 Parent; typedef typename Parent::Vec Vec; public: Nth2_Factor(const SlicedTibble& data, Column column_, int pos_) : Parent(data, column_, pos_), column(column_) {} Nth2_Factor(const SlicedTibble& data, Column column_, int pos_, SEXP def_) : Parent(data, column_, pos_, def_), column(column_) {} inline Vec summarise() const { return promote(Parent::summarise()); } inline Vec window() const { return promote(Parent::window()); } private: Column column; inline Vec promote(const Vec& res) const { copy_most_attributes(res, column.data); return res; } }; } // nth( , n = ) template SEXP nth2_(const SlicedTibble& data, Column x, int pos, const Operation& op) { if (Rf_isFactor(x.data)) { return op(internal::Nth2_Factor(data, x, pos)); } else if (x.is_trivial()) { switch (TYPEOF(x.data)) { case LGLSXP: return op(internal::Nth2(data, x, pos)); case RAWSXP: return op(internal::Nth2(data, x, pos)); case INTSXP: return op(internal::Nth2(data, x, pos)); case REALSXP: return op(internal::Nth2(data, x, pos)); case CPLXSXP: return op(internal::Nth2(data, x, pos)); case STRSXP: return op(internal::Nth2(data, x, pos)); case VECSXP: return op(internal::Nth2(data, x, pos)); default: break; } } return R_UnboundValue; } // first( ) template SEXP first1_(const SlicedTibble& data, Column x, const Operation& op) { return nth2_(data, x, 1, op); } // first( ) template SEXP last1_(const SlicedTibble& data, Column x, const Operation& op) { return nth2_(data, x, -1, op); } // nth( , n = ) template SEXP nth3_default(const SlicedTibble& data, Column x, int pos, SEXP def, const Operation& op) { if (TYPEOF(x.data) != TYPEOF(def) || Rf_length(def) != 1) return R_UnboundValue; switch (TYPEOF(x.data)) { case LGLSXP: return op(internal::Nth2(data, x, pos, def)); case RAWSXP: return op(internal::Nth2(data, x, pos, def)); case INTSXP: return op(internal::Nth2(data, x, pos, def)); case REALSXP: return op(internal::Nth2(data, x, pos, def)); case CPLXSXP: return op(internal::Nth2(data, x, pos, def)); case STRSXP: return op(internal::Nth2(data, x, pos, def)); case VECSXP: return op(internal::Nth2(data, x, pos, def)); default: break; } return R_UnboundValue; } // first( , default = ) template SEXP first2_(const SlicedTibble& data, Column x, SEXP def, const Operation& op) { return nth3_default(data, x, 1, def, op); } // last( , default = ) template SEXP last2_(const SlicedTibble& data, Column x, SEXP def, const Operation& op) { return nth3_default(data, x, -1, def, op); } template SEXP first_dispatch(const SlicedTibble& data, const Expression& expression, const Operation& op) { Column x; switch (expression.size()) { case 1: // first( ) if (expression.is_unnamed(0) && expression.is_column(0, x)) { return first1_(data, x, op); } break; case 2: // first( , default = ) if (expression.is_unnamed(0) && expression.is_column(0, x) && expression.is_named(1, symbols::default_)) { return first2_(data, x, /* default = */ expression.value(1), op); } default: break; } return R_UnboundValue; } template SEXP last_dispatch(const SlicedTibble& data, const Expression& expression, const Operation& op) { Column x; switch (expression.size()) { case 1: // last( ) if (expression.is_unnamed(0) && expression.is_column(0, x)) { return last1_(data, x, op); } break; case 2: // last( , default = ) if (expression.is_unnamed(0) && expression.is_column(0, x) && expression.is_named(1, symbols::default_)) { return last2_(data, x, /* default = */ expression.value(1), op); } default: break; } return R_UnboundValue; } template inline SEXP nth_dispatch(const SlicedTibble& data, const Expression& expression, const Operation& op) { Column x; int n; switch (expression.size()) { case 2: // nth( , n = ) if (expression.is_unnamed(0) && expression.is_column(0, x) && expression.is_named(1, symbols::n) && expression.is_scalar_int(1, n)) { return nth2_(data, x, n, op); } break; case 3: // nth( , n = , default = ) if (expression.is_unnamed(0) && expression.is_column(0, x) && expression.is_named(1, symbols::n) && expression.is_scalar_int(1, n) && expression.is_named(2, symbols::default_)) { return nth3_default(data, x, n, expression.value(2), op); } default: break; } return R_UnboundValue; } } } #endif dplyr/inst/include/dplyr/hybrid/scalar_result/sum.h0000644000176200001440000000730013614573562022253 0ustar liggesusers#ifndef dplyr_hybrid_sum_h #define dplyr_hybrid_sum_h #include #include #include namespace dplyr { namespace hybrid { namespace internal { template struct SumImpl { static STORAGE process(STORAGE* data_ptr, const slicing_index& indices) { long double res = 0; int n = indices.size(); for (int i = 0; i < n; i++) { STORAGE value = data_ptr[indices[i]]; // this is both NA and NaN if (Rcpp::traits::is_na(value)) { if (NA_RM) { continue; } return value; } res += value; } if (RTYPE == INTSXP && (res > INT_MAX || res <= INT_MIN)) { Rcpp::warning("integer overflow - use sum(as.numeric(.))"); return Rcpp::traits::get_na(); } return (STORAGE)res; } }; // General case (for INTSXP and LGLSXP) template class SumTemplate : public HybridVectorScalarResult < RTYPE == LGLSXP ? INTSXP : RTYPE, SlicedTibble, SumTemplate > { public : static const int rtype = RTYPE == LGLSXP ? INTSXP : RTYPE; typedef typename Rcpp::Vector::stored_type STORAGE; typedef HybridVectorScalarResult Parent ; SumTemplate(const SlicedTibble& data_, Column column_) : Parent(data_), data_ptr(Rcpp::internal::r_vector_start(column_.data)) {} STORAGE process(const typename SlicedTibble::slicing_index& indices) const { return SumImpl::process(data_ptr, indices); } private: STORAGE* data_ptr; }; template class SumDispatch { public: SumDispatch(const SlicedTibble& data_, Column variable_, bool narm_, const Operation& op_): data(data_), variable(variable_), narm(narm_), op(op_) {} SEXP get() const { // dispatch to the method below based on na.rm if (narm) { return operate_narm(); } else { return operate_narm(); } } private: const SlicedTibble& data; Column variable; bool narm; const Operation& op; template SEXP operate_narm() const { // try to dispatch to the right class switch (TYPEOF(variable.data)) { case INTSXP: return op(SumTemplate(data, variable)); case REALSXP: return op(SumTemplate(data, variable)); case LGLSXP: return op(SumTemplate(data, variable)); } // give up, effectively let R evaluate the call return R_UnboundValue; } }; } // namespace internal template SEXP sum_(const SlicedTibble& data, Column variable, bool narm, const Operation& op) { return internal::SumDispatch(data, variable, narm, op).get(); } template SEXP sum_dispatch(const SlicedTibble& data, const Expression& expression, const Operation& op) { Column x; switch (expression.size()) { case 1: // sum( ) if (expression.is_unnamed(0) && expression.is_column(0, x) && x.is_trivial()) { return sum_(data, x, /* na.rm = */ false, op); } break; case 2: bool test; if (expression.is_unnamed(0) && expression.is_column(0, x) && x.is_trivial() && expression.is_named(1, symbols::narm) && expression.is_scalar_logical(1, test) ) { return sum_(data, x, test, op); } default: break; } return R_UnboundValue; } } } #endif dplyr/inst/include/dplyr/hybrid/Column.h0000644000176200001440000000043713614573562020045 0ustar liggesusers#ifndef dplyr_hybrid_column_h #define dplyr_hybrid_column_h namespace dplyr { namespace hybrid { struct Column { SEXP data; bool is_desc; inline bool is_trivial() const { return !Rf_isObject(data) && !Rf_isS4(data) && RCPP_GET_CLASS(data) == R_NilValue; } }; } } #endif dplyr/inst/include/dplyr/hybrid/hybrid.h0000644000176200001440000000711613614573562020072 0ustar liggesusers#ifndef dplyr_hybrid_hybrid_h #define dplyr_hybrid_hybrid_h #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include namespace dplyr { namespace hybrid { #define HYBRID_HANDLE_CASE(__ID__, __FUN__) case __ID__: return __FUN__##_dispatch(data, expression, op); template SEXP hybrid_do(SEXP expr, const SlicedTibble& data, const DataMask& mask, SEXP env, SEXP caller_env, const Operation& op) { if (TYPEOF(expr) != LANGSXP) return R_UnboundValue; Expression expression(expr, mask, env, caller_env); switch (expression.get_id()) { HYBRID_HANDLE_CASE(N, n) HYBRID_HANDLE_CASE(N_DISTINCT, n_distinct) HYBRID_HANDLE_CASE(GROUP_INDICES, group_indices) HYBRID_HANDLE_CASE(ROW_NUMBER, row_number) HYBRID_HANDLE_CASE(SUM, sum) HYBRID_HANDLE_CASE(MEAN, mean) HYBRID_HANDLE_CASE(VAR, var) HYBRID_HANDLE_CASE(SD, sd) HYBRID_HANDLE_CASE(FIRST, first) HYBRID_HANDLE_CASE(LAST, last) HYBRID_HANDLE_CASE(NTH, nth) HYBRID_HANDLE_CASE(MIN, min) HYBRID_HANDLE_CASE(MAX, max) HYBRID_HANDLE_CASE(NTILE, ntile) HYBRID_HANDLE_CASE(MIN_RANK, min_rank) HYBRID_HANDLE_CASE(DENSE_RANK, dense_rank) HYBRID_HANDLE_CASE(PERCENT_RANK, percent_rank) HYBRID_HANDLE_CASE(CUME_DIST, cume_dist) HYBRID_HANDLE_CASE(LEAD, lead) HYBRID_HANDLE_CASE(LAG, lag) HYBRID_HANDLE_CASE(IN, in) case NOMATCH: break; } return R_UnboundValue; } template SEXP summarise(const NamedQuosure& quosure, const SlicedTibble& data, const DataMask& mask, SEXP caller_env) { return hybrid_do(quosure.expr(), data, mask, quosure.env(), caller_env, Summary()); } template SEXP window(SEXP expr, const SlicedTibble& data, const DataMask& mask, SEXP env, SEXP caller_env) { return hybrid_do(expr, data, mask, env, caller_env, Window()); } template SEXP match(SEXP expr, const SlicedTibble& data, const DataMask& mask, SEXP env, SEXP caller_env) { bool test = !is_vector(expr); Rcpp::RObject klass; if (test) { klass = hybrid_do(expr, data, mask, env, caller_env, Match()); test = klass != R_UnboundValue; } Rcpp::LogicalVector res(1, test) ; Rf_classgets(res, Rf_mkString("hybrid_call")); Rf_setAttrib(res, symbols::call, expr); Rf_setAttrib(res, symbols::env, env); if (test) { Expression expression(expr, mask, env, caller_env); Rf_setAttrib(res, symbols::fun, Rf_ScalarString(PRINTNAME(expression.get_fun()))); Rf_setAttrib(res, symbols::package, Rf_ScalarString(PRINTNAME(expression.get_package()))); Rf_setAttrib(res, symbols::cpp_class, klass); Rcpp::Shield expr_clone(Rf_duplicate(expr)); Rcpp::Shield call(Rf_lang3(symbols::double_colon, expression.get_package(), expression.get_fun())); SETCAR(expr_clone, call); Rf_setAttrib(res, symbols::call, expr_clone); } return res; } } } #undef HYBRID_HANDLE_CASE #endif dplyr/inst/include/dplyr/hybrid/HybridVectorSummaryRecycleResult.h0000644000176200001440000000175213614573562025301 0ustar liggesusers#ifndef DPLYR_HYBRID_HybridVectorSummaryRecycleResult_H #define DPLYR_HYBRID_HybridVectorSummaryRecycleResult_H #include namespace dplyr { namespace hybrid { template class HybridVectorSummaryRecycleResult : public HybridVectorVectorResult > { public: typedef HybridVectorVectorResult Parent; typedef Rcpp::Vector Vector; HybridVectorSummaryRecycleResult(const SlicedTibble& data) : Parent(data) {} void fill(const typename SlicedTibble::slicing_index& indices, Vector& out) const { int n = indices.size(); typename Vector::stored_type value = self()->value(indices); for (int i = 0; i < n; i++) out[indices[i]] = value; } private: inline const Impl* self() const { return static_cast(this); } }; } } #endif dplyr/inst/include/dplyr/hybrid/vector_result/0000755000176200001440000000000013614573562021333 5ustar liggesusersdplyr/inst/include/dplyr/hybrid/vector_result/in.h0000644000176200001440000000534413614573562022120 0ustar liggesusers#ifndef dplyr_hybrid_in_h #define dplyr_hybrid_in_h #include #include #include #include namespace dplyr { namespace hybrid { namespace internal { template class In_Column_Column : public HybridVectorVectorResult > { public: typedef HybridVectorVectorResult Parent; typedef Rcpp::Vector Vector; typedef typename Vector::stored_type stored_type; In_Column_Column(const SlicedTibble& data, SEXP x, SEXP y) : Parent(data), lhs(x), rhs(y) {} void fill(const typename SlicedTibble::slicing_index& indices, Rcpp::LogicalVector& out) const { int n = indices.size(); dplyr_hash_set set(n); for (int i = 0; i < indices.size(); i++) { set.insert((stored_type)rhs[indices[i]]); } for (int i = 0; i < n; i++) { stored_type value = lhs[indices[i]]; if (Vector::is_na(value)) { out[ indices[i] ] = false; } else { out[ indices[i] ] = set.count(value); } } } private: Vector lhs; Vector rhs; }; } template inline SEXP in_column_column(const SlicedTibble& data, Column col_x, Column col_y, const Operation& op) { if (TYPEOF(col_x.data) != TYPEOF(col_y.data)) return R_UnboundValue; SEXP x = col_x.data, y = col_y.data; switch (TYPEOF(x)) { case LGLSXP: return op(internal::In_Column_Column(data, x, y)); case RAWSXP: return op(internal::In_Column_Column(data, x, y)); case INTSXP: return op(internal::In_Column_Column(data, x, y)); case REALSXP: return op(internal::In_Column_Column(data, x, y)); case STRSXP: return op(internal::In_Column_Column(data, x, y)); case CPLXSXP: return op(internal::In_Column_Column(data, x, y)); case VECSXP: return op(internal::In_Column_Column(data, x, y)); default: break; } return R_UnboundValue; } template inline SEXP in_dispatch(const SlicedTibble& data, const Expression& expression, const Operation& op) { if (expression.size() == 2) { // %in% Column lhs; Column rhs; if (expression.is_unnamed(0) && expression.is_column(0, lhs) && lhs.is_trivial() && expression.is_unnamed(1) && expression.is_column(1, rhs) && rhs.is_trivial()) { return in_column_column(data, lhs, rhs, op); } } return R_UnboundValue; } } } #endif dplyr/inst/include/dplyr/hybrid/vector_result/ntile.h0000644000176200001440000001016413614573562022621 0ustar liggesusers#ifndef dplyr_hybrid_ntile_h #define dplyr_hybrid_ntile_h #include #include #include #include #include #include #include namespace dplyr { namespace hybrid { namespace internal { template class Ntile1 : public HybridVectorVectorResult > { public: typedef HybridVectorVectorResult Parent; Ntile1(const SlicedTibble& data, int ntiles_): Parent(data), ntiles(ntiles_) {} void fill(const typename SlicedTibble::slicing_index& indices, Rcpp::IntegerVector& out) const { int m = indices.size(); double ratio = static_cast(ntiles) / m; for (int j = m - 1; j >= 0; j--) { out[ indices[j] ] = static_cast(floor(ratio * j)) + 1; } } private: int ntiles; }; template class Ntile2 : public HybridVectorVectorResult > { public: typedef HybridVectorVectorResult Parent; typedef visitors::SliceVisitor, typename SlicedTibble::slicing_index> SliceVisitor; typedef visitors::WriteSliceVisitor WriteSliceVisitor; typedef visitors::Comparer Comparer; Ntile2(const SlicedTibble& data, SEXP x, int ntiles_): Parent(data), vec(x), ntiles(ntiles_) {} void fill(const typename SlicedTibble::slicing_index& indices, Rcpp::IntegerVector& out) const { int n = indices.size(); SliceVisitor slice(vec, indices); WriteSliceVisitor out_slice(out, indices); std::vector idx(n); for (int i = 0; i < n; i++) idx[i] = i; // sort idx by vec in the subset given by indices std::sort(idx.begin(), idx.end(), Comparer(slice)); // deal with NA int m = indices.size(); int j = m - 1; for (; j >= 0; j--) { if (Rcpp::traits::is_na(slice[idx[j]])) { m--; out_slice[idx[j]] = NA_INTEGER; } else { break; } } double ratio = static_cast(ntiles) / m; for (; j >= 0; j--) { out_slice[idx[j]] = static_cast(floor(ratio * j)) + 1; } } private: Rcpp::Vector vec; int ntiles; }; template inline SEXP ntile_2(const SlicedTibble& data, SEXP x, bool is_desc, int n, const Operation& op) { if (is_desc) { return op(Ntile2(data, x, n)); } else { return op(Ntile2(data, x, n)); } } } template inline internal::Ntile1 ntile_1(const SlicedTibble& data, int ntiles) { return internal::Ntile1(data, ntiles); } template inline SEXP ntile_2(const SlicedTibble& data, Column& column, int n, const Operation& op) { switch (TYPEOF(column.data)) { case INTSXP: return internal::ntile_2(data, column.data, column.is_desc, n, op); case REALSXP: return internal::ntile_2(data, column.data, column.is_desc, n, op); default: break; } return R_UnboundValue; } template SEXP ntile_dispatch(const SlicedTibble& data, const Expression& expression, const Operation& op) { int n; switch (expression.size()) { case 1: // ntile( n = ) if (expression.is_named(0, symbols::n) && expression.is_scalar_int(0, n)) { return op(ntile_1(data, n)); } case 2: // ntile( , n = ) Column x; if (expression.is_unnamed(0) && expression.is_column(0, x) && x.is_trivial() && expression.is_named(1, symbols::n) && expression.is_scalar_int(1, n)) { return ntile_2(data, x, n, op); } default: break; } return R_UnboundValue; } } } #endif dplyr/inst/include/dplyr/hybrid/vector_result/echo.h0000644000176200001440000000052613614573562022425 0ustar liggesusers#ifndef dplyr_hybrid_echo_h #define dplyr_hybrid_echo_h #include namespace dplyr { namespace hybrid { inline SEXP echo(SEXP x, const Summary&) { return R_UnboundValue; } inline SEXP echo(SEXP x, const Window&) { return x; } inline SEXP echo(SEXP x, const Match&) { return Rf_mkString("echo"); } } } #endif dplyr/inst/include/dplyr/hybrid/vector_result/lead_lag.h0000644000176200001440000001142713614573562023241 0ustar liggesusers#ifndef dplyr_hybrid_lead_lag_h #define dplyr_hybrid_lead_lag_h #include #include #include #include #include #include #include namespace dplyr { namespace hybrid { namespace internal { template class Lead : public HybridVectorVectorResult > { public: typedef HybridVectorVectorResult Parent; typedef Rcpp::Vector Vector; typedef visitors::SliceVisitor SliceVisitor; typedef visitors::WriteSliceVisitor WriteSliceVisitor; Lead(const SlicedTibble& data, SEXP x, int n_) : Parent(data), vec(x), n(n_) {} void fill(const typename SlicedTibble::slicing_index& indices, Vector& out) const { int chunk_size = indices.size(); SliceVisitor vec_slice(vec, indices); WriteSliceVisitor out_slice(out, indices); int i = 0; for (; i < chunk_size - n; i++) { out_slice[i] = vec_slice[i + n]; } for (; i < chunk_size; i++) { out_slice[i] = default_value(); } } private: Vector vec; int n; }; template class Lag : public HybridVectorVectorResult > { public: typedef HybridVectorVectorResult Parent; typedef Rcpp::Vector Vector; typedef visitors::SliceVisitor SliceVisitor; typedef visitors::WriteSliceVisitor WriteSliceVisitor; Lag(const SlicedTibble& data, SEXP x, int n_) : Parent(data), vec(x), n(n_) {} void fill(const typename SlicedTibble::slicing_index& indices, Vector& out) const { int chunk_size = indices.size(); SliceVisitor vec_slice(vec, indices); WriteSliceVisitor out_slice(out, indices); int n_def = std::min(chunk_size, n); int i = 0; for (; i < n_def; ++i) { out_slice[i] = default_value(); } for (; i < chunk_size; ++i) { out_slice[i] = vec_slice[i - n]; } } private: Vector vec; int n; }; template class Impl> inline SEXP lead_lag_dispatch3(const SlicedTibble& data, SEXP x, int n, const Operation& op) { switch (TYPEOF(x)) { case LGLSXP: return op(Impl(data, x, n)); case RAWSXP: return op(Impl(data, x, n)); case INTSXP: return op(Impl(data, x, n)); case REALSXP: return op(Impl(data, x, n)); case STRSXP: return op(Impl(data, x, n)); case CPLXSXP: return op(Impl(data, x, n)); case VECSXP: return op(Impl(data, x, n)); default: break; } return R_UnboundValue; } template class Impl> inline SEXP lead_lag(const SlicedTibble& data, Column column, int n, const Operation& op) { if (n == 0) { return echo(column.data, op); } return lead_lag_dispatch3(data, column.data, n, op); } } template class Impl> SEXP lead_lag_dispatch(const SlicedTibble& data, const Expression& expression, const Operation& op) { Column x; switch (expression.size()) { case 1: // lead( ) if (expression.is_unnamed(0) && expression.is_column(0, x) && x.is_trivial()) { return internal::lead_lag(data, x, 1, op); } break; case 2: // lead( , n = ) int n; if (expression.is_unnamed(0) && expression.is_column(0, x) && x.is_trivial() && expression.is_named(1, symbols::n) && expression.is_scalar_int(1, n) && n >= 0) { return internal::lead_lag(data, x, n, op); } default: break; } return R_UnboundValue; } template inline SEXP lead_dispatch(const SlicedTibble& data, const Expression& expression, const Operation& op) { return lead_lag_dispatch(data, expression, op); } template inline SEXP lag_dispatch(const SlicedTibble& data, const Expression& expression, const Operation& op) { return lead_lag_dispatch(data, expression, op); } } } #endif dplyr/inst/include/dplyr/hybrid/vector_result/row_number.h0000644000176200001440000000646313614573562023674 0ustar liggesusers#ifndef dplyr_hybrid_row_number_h #define dplyr_hybrid_row_number_h #include #include #include #include #include namespace dplyr { namespace hybrid { namespace internal { template class RowNumber0 : public HybridVectorVectorResult > { public: typedef HybridVectorVectorResult > Parent; RowNumber0(const SlicedTibble& data) : Parent(data) {} void fill(const typename SlicedTibble::slicing_index& indices, Rcpp::IntegerVector& out) const { int n = indices.size(); for (int i = 0; i < n; i++) { out[indices[i]] = i + 1 ; } } }; template class RowNumber1 : public HybridVectorVectorResult > { public: typedef HybridVectorVectorResult Parent; typedef typename Rcpp::Vector::stored_type STORAGE; typedef visitors::SliceVisitor, typename SlicedTibble::slicing_index> SliceVisitor; typedef visitors::WriteSliceVisitor WriteSliceVisitor; typedef visitors::Comparer Comparer; RowNumber1(const SlicedTibble& data, SEXP x) : Parent(data), vec(x) {} void fill(const typename SlicedTibble::slicing_index& indices, Rcpp::IntegerVector& out) const { int n = indices.size(); SliceVisitor slice(vec, indices); WriteSliceVisitor out_slice(out, indices); std::vector idx(n); for (int i = 0; i < n; i++) idx[i] = i; // sort idx by vec in the subset given by indices std::sort(idx.begin(), idx.end(), Comparer(slice)); // deal with NA int m = indices.size(); int j = m - 1; for (; j >= 0; j--) { if (Rcpp::traits::is_na(slice[idx[j]])) { out_slice[idx[j]] = NA_INTEGER; } else { break; } } for (; j >= 0; j--) { out_slice[idx[j]] = j + 1; } } private: Rcpp::Vector vec; }; } template inline internal::RowNumber0 row_number_(const SlicedTibble& data) { return internal::RowNumber0(data); } template inline SEXP row_number_1(const SlicedTibble& data, Column column, const Operation& op) { SEXP x = column.data; switch (TYPEOF(x)) { case INTSXP: return op(internal::RowNumber1(data, x)); case REALSXP: return op(internal::RowNumber1(data, x)); default: break; } return R_UnboundValue; } template SEXP row_number_dispatch(const SlicedTibble& data, const Expression& expression, const Operation& op) { switch (expression.size()) { case 0: // row_number() return op(row_number_(data)); case 1: // row_number( ) Column x; if (expression.is_unnamed(0) && expression.is_column(0, x) && x.is_trivial()) { return row_number_1(data, x, op); } default: break; } return R_UnboundValue; } } } #endif dplyr/inst/include/dplyr/hybrid/vector_result/rank.h0000644000176200001440000001670213614573562022445 0ustar liggesusers#ifndef dplyr_hybrid_rank_h #define dplyr_hybrid_rank_h #include #include #include #include #include namespace dplyr { namespace hybrid { namespace internal { struct min_rank_increment { typedef Rcpp::IntegerVector OutputVector; typedef int scalar_type; enum { rtype = INTSXP }; template inline int post_increment(const Container& x, int) const { return x.size(); } template inline int pre_increment(const Container&, int) const { return 0; } inline int start() const { return 1; } }; struct dense_rank_increment { typedef Rcpp::IntegerVector OutputVector; typedef int scalar_type; enum { rtype = INTSXP }; template inline int post_increment(const Container&, int) const { return 1; } template inline int pre_increment(const Container&, int) const { return 0; } inline int start() const { return 1; } }; struct percent_rank_increment { typedef Rcpp::NumericVector OutputVector; typedef double scalar_type; enum { rtype = REALSXP }; template inline double post_increment(const Container& x, int m) const { return (double)x.size() / (m - 1); } template inline double pre_increment(const Container&, int) const { return 0.0; } inline double start() const { return 0.0; } }; struct cume_dist_increment { typedef Rcpp::NumericVector OutputVector; typedef double scalar_type; enum { rtype = REALSXP }; template inline double post_increment(const Container&, int) const { return 0.0; } template inline double pre_increment(const Container& x, int m) const { return (double)x.size() / m; } inline double start() const { return 0.0; } }; template class RankComparer { typedef comparisons compare; public: typedef typename Rcpp::traits::storage_type::type STORAGE; inline bool operator()(STORAGE lhs, STORAGE rhs) const { if (ascending) { return compare::is_less(lhs, rhs); } else { return compare::is_greater(lhs, rhs); } } }; template class RankEqual { typedef comparisons compare; public: typedef typename Rcpp::traits::storage_type::type STORAGE; inline bool operator()(STORAGE lhs, STORAGE rhs) const { return compare::equal_or_both_na(lhs, rhs); } }; template inline T fix_na(T value) { return value; } template <> inline double fix_na(double value) { return R_IsNA(value) ? NA_REAL : value; } template class RankImpl : public HybridVectorVectorResult >, public Increment { public: typedef HybridVectorVectorResult Parent; typedef typename Increment::OutputVector OutputVector; typedef typename Rcpp::traits::storage_type::type STORAGE; typedef visitors::SliceVisitor, typename SlicedTibble::slicing_index> SliceVisitor; typedef visitors::WriteSliceVisitor WriteSliceVisitor; typedef RankComparer Comparer; typedef RankEqual Equal; typedef dplyr_hash_map, boost::hash, Equal > Map; typedef std::map*, Comparer> oMap; RankImpl(const SlicedTibble& data, SEXP x) : Parent(data), vec(x) {} void fill(const typename SlicedTibble::slicing_index& indices, OutputVector& out) const { Map map; SliceVisitor slice(vec, indices); WriteSliceVisitor out_slice(out, indices); int m = indices.size(); for (int j = 0; j < m; j++) { map[ fix_na(slice[j]) ].push_back(j); } STORAGE na = Rcpp::traits::get_na(); typename Map::const_iterator it = map.find(na); if (it != map.end()) { m -= it->second.size(); } oMap ordered; it = map.begin(); for (; it != map.end(); ++it) { ordered[it->first] = &it->second; } typename oMap::const_iterator oit = ordered.begin(); typename Increment::scalar_type j = Increment::start(); for (; oit != ordered.end(); ++oit) { STORAGE key = oit->first; const std::vector& chunk = *oit->second; int n = chunk.size(); j += Increment::pre_increment(chunk, m); if (Rcpp::traits::is_na(key)) { typename Increment::scalar_type inc_na = Rcpp::traits::get_na< Rcpp::traits::r_sexptype_traits::rtype >(); for (int k = 0; k < n; k++) { out_slice[ chunk[k] ] = inc_na; } } else { for (int k = 0; k < n; k++) { out_slice[ chunk[k] ] = j; } } j += Increment::post_increment(chunk, m); } } private: Rcpp::Vector vec; }; template inline SEXP rank_impl(const SlicedTibble& data, SEXP x, bool is_desc, const Operation& op) { if (is_desc) { return op(RankImpl(data, x)); } else { return op(RankImpl(data, x)); } } template inline SEXP rank_(const SlicedTibble& data, Column column, const Operation& op) { SEXP x = column.data; switch (TYPEOF(x)) { case INTSXP: return internal::rank_impl(data, x, column.is_desc, op); case REALSXP: return internal::rank_impl(data, x, column.is_desc, op); default: break; } return R_UnboundValue; } } template SEXP rank_dispatch(const SlicedTibble& data, const Expression& expression, const Operation& op) { Column x; if (expression.is_unnamed(0) && expression.is_column(0, x) && x.is_trivial()) { return internal::rank_(data, x, op); } return R_UnboundValue; } template inline SEXP min_rank_dispatch(const SlicedTibble& data, const Expression& expression, const Operation& op) { return rank_dispatch(data, expression, op); } template inline SEXP dense_rank_dispatch(const SlicedTibble& data, const Expression& expression, const Operation& op) { return rank_dispatch(data, expression, op); } template inline SEXP percent_rank_dispatch(const SlicedTibble& data, const Expression& expression, const Operation& op) { return rank_dispatch(data, expression, op); } template inline SEXP cume_dist_dispatch(const SlicedTibble& data, const Expression& expression, const Operation& op) { return rank_dispatch(data, expression, op); } } } #endif dplyr/inst/include/dplyr/hybrid/HybridVectorVectorResult.h0000644000176200001440000000173513614573562023600 0ustar liggesusers#ifndef DPLYR_HYBRID_HybridVectorVectorResult_H #define DPLYR_HYBRID_HybridVectorVectorResult_H namespace dplyr { namespace hybrid { template class HybridVectorVectorResult { public: typedef typename Rcpp::Vector Vec ; typedef typename Vec::stored_type stored_type; HybridVectorVectorResult(const SlicedTibble& data_) : data(data_) {} inline Vec window() const { int ng = data.ngroups(); int nr = data.nrows(); Vec vec = init(nr); typename SlicedTibble::group_iterator git = data.group_begin(); for (int i = 0; i < ng; i++, ++git) { self()->fill(*git, vec); } return vec ; } inline SEXP summarise() const { // we let R handle it return R_UnboundValue; } private: const SlicedTibble& data; inline const Impl* self() const { return static_cast(this); } inline Vec init(int n) const { return Rcpp::no_init(n); } }; } } #endif dplyr/inst/include/dplyr_types.h0000644000176200001440000000033413614573562016547 0ustar liggesusers#include #include #include #include #include // avoid inclusion of package header file #define dplyr_dplyr_H dplyr/inst/include/dplyr.h0000644000176200001440000000015413614573562015323 0ustar liggesusers#ifndef RCPP_dplyr_dplyr_H #define RCPP_dplyr_dplyr_H #include #endif // RCPP_dplyr_H_GEN_