表題通り、サブサンプルに分けた各データに対して複数モデルを適用したい。

より具体的に書くと、以下のdropoutさんの記事では

複数のモデルを当てはめる場合 diamondデータに対して、3モデルを適用

サブサンプルに分けて分析する場合 diamondデータをclarity毎にサブサンプルをnestで作成しそれぞれに対して、1モデルを適用

といったことをnestとmapを使ってモダンに処理する方法の紹介をしている。

dropout009.hatenablog.com

これらを複合して、「diamondデータをclarity毎にサブサンプルを作成しそれぞれに対して、3モデルを適用」といったことをおこないたい。

複数のモデルを当てはめる場合サブサンプルに分けて分析する場合

これら処理だけをまとめると

library(tidyverse)
library(tidymodels)

df = diamonds %>% 
  mutate_if(is.ordered, factor, ordered = FALSE)

# 複数model
formulas = c(log(price) ~ clarity,
             log(price) ~ clarity + carat,
             log(price) ~ clarity + log(carat)) %>% 
  enframe("model_no", "formula")

# 1. 1データに対して複数モデルを適応
formulas %>% 
  mutate(model = map(formula, lm, data = df))

# 2. サブサンプルごとに1モデルを適応
# dfをclarityごとにサブサンプルに分ける
df_nested = df %>% 
  group_by(clarity) %>%
  nest() %>% 
  arrange(clarity)

df_nested %>% 
  mutate(model = map(data, ~lm(log(price) ~ log(carat), data = .)))

となる。
ちなみに、上記記事の各関数詳細などを自分なりに解釈してトレースした過去記事はこちら

knknkn.hatenablog.com

このとき、

lmで適用するデータをclarity毎に変える
lmで適用するモデル式を変える

この2つをおこなう。つまり、上記コードの

# 1.formula毎に適用
formulas %>% 
  mutate(model = map(formula, lm, data = df))

# 2. data毎に適用
df_nested %>% 
  mutate(model = map(data, ~lm(log(price) ~ log(carat), data = .)))

このどちらかの部分に対して、formulaかdataを動的に変えることが必要になる。
mapは1引数を2引数目のfunction(モデル式部分)に適用することができる。そのため、formulaとdataどちらとも変えることはできない。

そのため、引数を2つfunctionに渡すことができるmap2を使用する。

なお、はじめのコードにあるモデル式は以下となる。

log(price) ~ clarity,
log(price) ~ clarity + carat
log(price) ~ clarity + log(carat))

今回。clarity毎にしたサブサンプルを使用するため、式の意味を考えると上記3式のclarity部分は必要ない(特に1つ目はlog(price)だけの式になる）ので、今回のモチベーションに合わせるためclarityサブサンプル毎の場合ほぼ同じ意味になる*1以下の2式に修正して適用する。

log(price) ~ carat
log(price) ~ log(carat))

実践

モデル式一覧の作成

まずはモデル式一覧を作成する。

# formula候補一覧のデータフレーム 

formulas = c(log(price) ~ carat,
             log(price) ~ log(carat)) %>%
  enframe("model_no", "formula")

## サブサンプルに分けない場合以下
# formulas = c(log(price) ~ clarity + carat,
#              log(price) ~ clarity + log(carat)) %>%
#   enframe("model_no", "formula")

モデル式とclarityのセットを作成

次に、map2に指定するために上で作成したformulasに各clarityを付与した列を作成する。

# サブセット一覧の組み合わせ
formulas = formulas %>% 
  expand_grid(tibble(subset = unique(df$clarity))) # model_noごとに各clarityを付け加える。6model * 8clarity

f:id:chito_ng:20200620164723p:plain:w300

後に記述するが、formulasオブジェクトに対してmap2で処理した結果をmutateで加えるため、map2に渡す引数をすべてformulasオブジェクトで完結させるために各clarityを付与した列を作成している。

なお、expand_gridは、適用するオブジェクトに対してexpand_grid内で指定したデータとの全組み合わせを作成する関数となる。
例えば、以下のコードは1,2,3を取るxと1,2を取るyの全組み合わせを出力する。

expand_grid(x = 1:3, y = 1:2)

f:id:chito_ng:20200620164449p:plain:w300

rdrr.io

サブサンプルに分けた各データに対して複数モデルを適用する

# map2() で2変数の組み合わせを並列処理
df_result = formulas %>% 
  # 第2引数.y(subset)で絞り込みをしたデータに対して第1引数.x(formula)を適用
  mutate(model = map2(formula, subset, ~lm(.x, data = filter(df, clarity == .y))))

モデルの結果を係数とともに示すと以下のようになる。

df_result %>% 
  mutate(tidied = map(model, tidy)) %>% 
  select(model_no, subset, tidied) %>% 
  unnest() %>% 
  mutate_if(is.double, round, digits=3)

f:id:chito_ng:20200620165855p:plain:w500

おまけ

元のソースのmapのままforを組み合わせると以下のようになる。

df = diamonds %>% 
  mutate_if(is.ordered, factor, ordered = FALSE)

# 複数model
formulas = c(log(price) ~ carat,
             log(price) ~ log(carat)) %>% 
  enframe("model_no", "formula")

# clarityの一覧
clarities = df %>% 
  distinct(clarity) %>%
  pull()

# 1. 1データに対して複数モデルを適応をloop
df_output = data.frame() # 空のDF

for (i_clarity in clarities) {
  # サブサンプルを作成
  df_filtered_clarity = df %>% 
    filter(clarity == i_clarity)
                                      
  df_output_ = formulas %>% 
    mutate(subsumple = i_clarity,
           model = map(formula, lm, data = df_filtered_clarity))
  
  # df_output_を結合していく
  df_output = df_output %>% 
    bind_rows(df_output_)
}