RでdplyrっぽいNSE（非標準評価）できる関数を書く
あきるRでdplyrっぽくNSEでクロス集計できる関数を書く
dplyrっぽいNSEの関数を書く練習にxtabsをdplyrっぽく使えるような関数を書きたい。
練習が目的なので、クロス集計表を作成する手段としてはそんなに実用的ではないかも。クロス集計をしたい場合、わりと最近にcrosstableというパッケージがリリースされていて、これを使っておけばだいたいなんでもできそう。
ここで使うデータ
crosstable::mtcars2から一部の列だけを抽出したデータを使う。中身はmtcarsと同じなので、たまにmtcarsも出てくる。
dat <-
crosstable::mtcars2 |>
dplyr::select(cyl, vs, am, gear, carb)
dplyr::glimpse(dat)
#> Rows: 32
#> Columns: 5
#> $ cyl <fct> 6, 6, 4, 6, 8, 6, 8, 4, 4, 6, 6, 8, 8, 8, 8, 8, 8, 4, 4, 4, 4, 8, 8, 8, 8, …
#> $ vs <labelled> "vshaped", "vshaped", "straight", "straight", "vshaped", "straight", "…
#> $ am <labelled> "manual", "manual", "manual", "auto", "auto", "auto", "auto", "auto", …
#> $ gear <fct> 4, 4, 4, 3, 3, 3, 3, 4, 4, 4, 4, 3, 3, 3, 3, 3, 3, 4, 4, 4, 3, 3, 3, 3, 3, …
#> $ carb <labelled> 4, 4, 1, 1, 2, 1, 4, 2, 2, 4, 4, 3, 3, 3, 4, 4, 4, 1, 2, 1, 1, 2, 2, 4…
xtabsの使い方
xtabsはこんな感じで使う関数。第1引数にformulaを渡すとクロス集計ができる。
xtabs(~ cyl + vs + am, dat) |>
addmargins() |>
ftable()
#> am auto manual Sum
#> cyl vs
#> 4 straight 3 7 10
#> vshaped 0 1 1
#> Sum 3 8 11
#> 6 straight 4 0 4
#> vshaped 0 3 3
#> Sum 4 3 7
#> 8 straight 0 0 0
#> vshaped 12 2 14
#> Sum 12 2 14
#> Sum straight 7 7 14
#> vshaped 12 6 18
#> Sum 19 13 32
ただし、こいつは第1引数についてはNSEとSEの区別がない関数なので、実はformulaを文字列として書いて渡してもちゃんと動く。
xtabs("~ cyl + vs + am", dat) |>
addmargins() |>
ftable()
#> am auto manual Sum
#> cyl vs
#> 4 straight 3 7 10
#> vshaped 0 1 1
#> Sum 3 8 11
#> 6 straight 4 0 4
#> vshaped 0 3 3
#> Sum 4 3 7
#> 8 straight 0 0 0
#> vshaped 12 2 14
#> Sum 12 2 14
#> Sum straight 7 7 14
#> vshaped 12 6 18
#> Sum 19 13 32
ちなみに、本筋とはまったく関係ないが、こういう結果はtibble::as_tibbleで縦長のtibbleにできて便利。
xtabs(~ cyl + vs + am, dat) |>
ftable() |>
tibble::as_tibble()
#> # A tibble: 12 × 4
#> cyl vs am Freq
#> <fct> <fct> <fct> <int>
#> 1 4 straight auto 3
#> 2 6 straight auto 4
#> 3 8 straight auto 0
#> 4 4 vshaped auto 0
#> 5 6 vshaped auto 0
#> 6 8 vshaped auto 12
#> 7 4 straight manual 7
#> 8 6 straight manual 0
#> 9 8 straight manual 0
#> 10 4 vshaped manual 1
#> 11 6 vshaped manual 3
#> 12 8 vshaped manual 2
rlang::enquosとかを使えばできそう？
この練習のモチベーションとして、xtabsの次のような点を改善する関数を書きたい。
- これだとパイプとあわせて使いづらいので、集計するデータフレームは第1引数にとるようにしたい
- いちいちformulaを書くのはめんどくさいので、クロス集計したい列名だけを
my_xtabs(dat, cyl, vs)みたいなかたちで渡せるようにしたい
イメージとしては、関数のなかでformulaを文字列として組み立ててxtabsに渡せば実現できそう。ただし、2をやるポイントして、これはNSE（Non Standard Evalutation:非標準評価）というやつなので、書くのにちょっと工夫がいる。
たとえば、単純に次のようにしても動かない。これはエラーメッセージの通りで、cylもvsもdatのなかにしか存在しないオブジェクトなんだから、それはそうだろう。
my_xtabs <- \(tbl, ...) {
fml <- paste("~", paste(..., collapse = " + "))
xtabs(fml, tbl) |>
addmargins() |>
ftable()
}
my_xtabs(dat, cyl, vs)
#> Error in paste(..., collapse = " + "): object 'cyl' not found
こういうことをやる場合で、dplyrの関数なんかをラップするときは書き方のパターンとしてだいたい決まっていて、ユーザーから渡される引数をクオートしておけば動く。たとえば、dplyr::filterをラップしたいぜという場合は、rlang::enquoやrlang::enquosとかいうのを使って、次のように書くと動くようになる。
my_filter <- \(tbl, col, val) {
# Bad: `dplyr::filter(tbl, col > val, carb == 2)`
dplyr::filter(tbl, !!rlang::enquo(col) > val, .data$carb == 2)
}
my_filter(mtcars, cyl, 6)
#> mpg cyl disp hp drat wt qsec vs am gear carb
#> Hornet Sportabout 18.7 8 360 175 3.15 3.440 17.02 0 0 3 2
#> Dodge Challenger 15.5 8 318 150 2.76 3.520 16.87 0 0 3 2
#> AMC Javelin 15.2 8 304 150 3.15 3.435 17.30 0 0 3 2
#> Pontiac Firebird 19.2 8 400 175 3.08 3.845 17.05 0 0 3 2
rlang::ensymsを使おう
じゃあ、今の場合でもこうすればいいのかというのと、残念ながらそれも違う。
my_xtabs <- \(tbl, ...) {
fml <- paste("~", paste(!!rlang::enquos(...), collapse = " + "))
xtabs(fml, tbl) |>
addmargins() |>
ftable()
}
my_xtabs(dat, cyl, vs)
#> Error in !rlang::enquos(...): invalid argument type
!!(bang-bang)とか!!!(bang-bang-bang), あと{{}}(curly-curly)とかいうオペレータは、実はオペレータではない。というと意味不明かもしれないが、たとえば!!がbang-bangとして機能するのはざっくりいうとrlangの文脈のなかだけで、ここでは否定の演算子を二重にしたものとして解釈されている。で、ここでは、否定の演算子の後ろにlogicalではなくてfunctionが来ているから「型がまちがっているぜ」というエラーが出ている。
じゃあどうすればいいのかというと、なんとなく正しそうなアプローチとして、まずrlang::enquosのことは忘れたほうがいい。ここでは別に...をquosuresにしてbang-bangするメリットはないので、rlang::ensymsで受け取ると上手くいく。
xtabs_tidy1 <- \(tbl, ...) {
fml <- paste("~", paste(rlang::ensyms(...), collapse = " + "))
icecream::ic(fml)
xtabs(fml, tbl) |>
addmargins() |>
ftable()
}
xtabs_tidy1(dat, cyl, vs)
#> ℹ ic| `fml`: chr "~ cyl + vs"
#> vs straight vshaped Sum
#> cyl
#> 4 10 1 11
#> 6 4 3 7
#> 8 0 14 14
#> Sum 14 18 32
xtabs_tidy1(dat, "cyl", "vs")
#> ℹ ic| `fml`: chr "~ cyl + vs"
#> vs straight vshaped Sum
#> cyl
#> 4 10 1 11
#> 6 4 3 7
#> 8 0 14 14
#> Sum 14 18 32
おまけ
tidyselect対応にしたい
これでもまだ列指定がめんどくさいことがありそうなので、tidyselectのヘルパー関数で列をごっそり指定できると便利そう。
tidyselectで...を受け取りたいときは、次のような書き方をしろとヘルプに書かれている。tidyselect::eval_selectは、評価式で指定された列のデータフレーム中での位置をあらわす名前付きベクトルを返してくる。
tidyselect::eval_select(rlang::expr(c(cyl, vs)), dat) |> str()
#> Named int [1:2] 1 2
#> - attr(*, "names")= chr [1:2] "cyl" "vs"
これを使うようにすると、tidyselect対応できる。
xtabs_tidy2 <- \(tbl, ...) {
loc <- tidyselect::eval_select(rlang::expr(c(...)), tbl)
fml <- paste("~", paste(colnames(tbl)[loc], collapse = " + "))
icecream::ic(fml)
xtabs(fml, tbl) |>
addmargins() |>
ftable()
}
xtabs_tidy2(dat, 1:3)
#> ℹ ic| `fml`: chr "~ cyl + vs + am"
#> am auto manual Sum
#> cyl vs
#> 4 straight 3 7 10
#> vshaped 0 1 1
#> Sum 3 8 11
#> 6 straight 4 0 4
#> vshaped 0 3 3
#> Sum 4 3 7
#> 8 straight 0 0 0
#> vshaped 12 2 14
#> Sum 12 2 14
#> Sum straight 7 7 14
#> vshaped 12 6 18
#> Sum 19 13 32
xtabs_tidy2(dat, contains("a"))
#> ℹ ic| `fml`: chr "~ am + gear + carb"
#> carb 1 2 3 4 6 8 Sum
#> am gear
#> auto 3 3 4 3 5 0 0 15
#> 4 0 2 0 2 0 0 4
#> 5 0 0 0 0 0 0 0
#> Sum 3 6 3 7 0 0 19
#> manual 3 0 0 0 0 0 0 0
#> 4 4 2 0 2 0 0 8
#> 5 0 2 0 1 1 1 5
#> Sum 4 4 0 3 1 1 13
#> Sum 3 3 4 3 5 0 0 15
#> 4 4 4 0 4 0 0 12
#> 5 0 2 0 1 1 1 5
#> Sum 7 10 3 10 1 1 32
formulaの左辺も指定できるようにする
まあ、そういうこともあるかもしれない。たとえば、次のようにする。
xtabs_tidy3 <- \(tbl, ..., .by = NULL) {
loc <- tidyselect::eval_select(rlang::expr(c(...)), tbl)
fml <- paste(
ifelse(missing(.by), "", rlang::ensym(.by)),
"~",
paste(colnames(tbl)[loc], collapse = " + ")
)
icecream::ic(fml)
xtabs(fml, tbl) |>
addmargins() |>
ftable()
}
mtcars |>
dplyr::select(cyl, vs, am, gear, carb) |>
xtabs_tidy3(cyl, vs, am, .by = gear)
#> ℹ ic| `fml`: chr "gear ~ cyl + vs + am"
#> am 0 1 Sum
#> cyl vs
#> 4 0 0 5 5
#> 1 11 29 40
#> Sum 11 34 45
#> 6 0 0 13 13
#> 1 14 0 14
#> Sum 14 13 27
#> 8 0 36 10 46
#> 1 0 0 0
#> Sum 36 10 46
#> Sum 0 36 28 64
#> 1 25 29 54
#> Sum 61 57 118
Rのデータフレームの行を任意の順番に並び替える関数
やりたいこと
こういうデータフレームがあったとして、
require(tidyverse)
(df <- dplyr::select(mpg, model, year, displ))
## # A tibble: 234 × 3
## model year displ
## <chr> <int> <dbl>
## 1 a4 1999 1.8
## 2 a4 1999 1.8
## 3 a4 2008 2
## 4 a4 2008 2
## 5 a4 1999 2.8
## 6 a4 1999 2.8
## 7 a4 2008 3.1
## 8 a4 quattro 1999 1.8
## 9 a4 quattro 1999 1.8
## 10 a4 quattro 2008 2
## # … with 224 more rows
model列の値によって行を任意順に並び替えたい（アルファベットの昇順や降順ではなく）。
ふつうのやり方
このとき、ふつうのやり方なら、levelsを指定したうえでfactorにして整列させればよい。
model_arranged <- sample(unique(df$model), 38)
df |>
dplyr::mutate(model = factor(model, levels = model_arranged)) |>
dplyr::arrange(model)
## # A tibble: 234 × 3
## model year displ
## <fct> <int> <dbl>
## 1 camry solara 1999 2.2
## 2 camry solara 1999 2.2
## 3 camry solara 2008 2.4
## 4 camry solara 2008 2.4
## 5 camry solara 1999 3
## 6 camry solara 1999 3
## 7 camry solara 2008 3.3
## 8 impreza awd 1999 2.2
## 9 impreza awd 1999 2.2
## 10 impreza awd 1999 2.5
## # … with 224 more rows
ただ、ここではmodel列は38水準あるので、ふつうに任意順にしようとすると本当はmodel_arrangedに38水準の順序をいちいち全部書かないといけない。
ちょっと楽なやり方
それはめんどくさいので、ここでは次のような関数を用意する。
reorder_cases_with <- function(df, col, patterns) {
col <- rlang::enquo(col)
stopifnot(is.character(dplyr::pull(df, !!col)))
for (str in patterns) {
cases <- stringr::str_which(dplyr::pull(df, !!col), str)
df <- df[c(cases, setdiff(seq_len(nrow(df)), cases)), ]
}
df
}
patternsに文字列ベクトルを与えると、各要素に部分一致した水準を順繰りにデータフレームの先頭にまとめて並び替えるような処理をしている。
reorder_cases_with(df, model, c("4wd", "a6"))
## # A tibble: 234 × 3
## model year displ
## <chr> <int> <dbl>
## 1 a6 quattro 1999 2.8
## 2 a6 quattro 2008 3.1
## 3 a6 quattro 2008 4.2
## 4 k1500 tahoe 4wd 2008 5.3
## 5 k1500 tahoe 4wd 2008 5.3
## 6 k1500 tahoe 4wd 1999 5.7
## 7 k1500 tahoe 4wd 1999 6.5
## 8 dakota pickup 4wd 2008 3.7
## 9 dakota pickup 4wd 2008 3.7
## 10 dakota pickup 4wd 1999 3.9
## # … with 224 more rows