Packages

pacman::p_load(
  tidyverse,
  psych
)

Content

デモデータとしてpsych::bfiを使います。

data(bfi, package = "psych")

ロードされるデータのうち、bfiは2800行28列のデータで、列の最初の25項目は5因子に分かれるパーソナリティに関する項目が各5つずつ、残りの3列は性別、学歴、年齢が含まれています。

str(bfi)

'data.frame':   2800 obs. of  28 variables:
 $ A1       : int  2 2 5 4 2 6 2 4 4 2 ...
 $ A2       : int  4 4 4 4 3 6 5 3 3 5 ...
 $ A3       : int  3 5 5 6 3 5 5 1 6 6 ...
 $ A4       : int  4 2 4 5 4 6 3 5 3 6 ...
 $ A5       : int  4 5 4 5 5 5 5 1 3 5 ...
 $ C1       : int  2 5 4 4 4 6 5 3 6 6 ...
 $ C2       : int  3 4 5 4 4 6 4 2 6 5 ...
 $ C3       : int  3 4 4 3 5 6 4 4 3 6 ...
 $ C4       : int  4 3 2 5 3 1 2 2 4 2 ...
 $ C5       : int  4 4 5 5 2 3 3 4 5 1 ...
 $ E1       : int  3 1 2 5 2 2 4 3 5 2 ...
 $ E2       : int  3 1 4 3 2 1 3 6 3 2 ...
 $ E3       : int  3 6 4 4 5 6 4 4 NA 4 ...
 $ E4       : int  4 4 4 4 4 5 5 2 4 5 ...
 $ E5       : int  4 3 5 4 5 6 5 1 3 5 ...
 $ N1       : int  3 3 4 2 2 3 1 6 5 5 ...
 $ N2       : int  4 3 5 5 3 5 2 3 5 5 ...
 $ N3       : int  2 3 4 2 4 2 2 2 2 5 ...
 $ N4       : int  2 5 2 4 4 2 1 6 3 2 ...
 $ N5       : int  3 5 3 1 3 3 1 4 3 4 ...
 $ O1       : int  3 4 4 3 3 4 5 3 6 5 ...
 $ O2       : int  6 2 2 3 3 3 2 2 6 1 ...
 $ O3       : int  3 4 5 4 4 5 5 4 6 5 ...
 $ O4       : int  4 3 5 3 3 6 6 5 6 5 ...
 $ O5       : int  3 3 2 5 3 1 1 3 1 2 ...
 $ gender   : int  1 2 2 2 1 2 1 1 1 2 ...
 $ education: int  NA NA NA NA NA 3 NA 2 1 NA ...
 $ age      : int  16 18 17 17 17 21 18 19 19 17 ...

bfi.keysの方は、25項目のパーソナリティに関する項目がそれぞれのど下位尺度を構成するのかという情報がlist形式で収められています。頭に-がついているのは、逆転項目のしるしです。

bfi.keys

$agree
[1] "-A1" "A2"  "A3"  "A4"  "A5" 

$conscientious
[1] "C1"  "C2"  "C3"  "-C4" "-C5"

$extraversion
[1] "-E1" "-E2" "E3"  "E4"  "E5" 

$neuroticism
[1] "N1" "N2" "N3" "N4" "N5"

$openness
[1] "O1"  "-O2" "O3"  "O4"  "-O5"

このデータのそれぞれの下位尺度ごとにα係数を求めたいとなった場合、ふつうはこんな感じになると思います。

res_alpha_a <- bfi |>
  select(A1:A5) |>
  psych::alpha(
    keys = "A1"
  )

res_alpha_a

res_alpha_c <- bfi |>
  select(C1:C5) |>
  psych::alpha(
    keys = c("C4", "C5")
  )

res_alpha_c

列名選択と逆転項目の指定を自分で頑張る方法です。これを5因子分繰り返します。可読性は悪くないので、これでも十分な気がします。

ただ、せっかくなのでほとんどをRに任せて１回の処理でできたら、それもそれでいい気がします。ということで試してみました。

やりやすいデータの場合

まず、処理しやすいようにデータをlong型にします。ついでにtibble::rownames_to_column()でrownameをid列に変えておきます。id列がないとtidyr::pivot_wider()出来なくなるので、少なくともその処理の前にはやっておきます。

bfi |>
  rownames_to_column(var = "id") |>
  pivot_longer(
1    cols = matches("\\w\\d"),
    names_to = "items"
  )

1: 引数colsはtidy-selectの文法なので-c(id, gender, education, age)でもいいです。longにしたい列名が「文字1文字数字1文字」なのがわかっているので、dplyr::matches()で正規表現を使って絞りました。

# A tibble: 70,000 × 6
   id    gender education   age items value
   <chr>  <int>     <int> <int> <chr> <int>
 1 61617      1        NA    16 A1        2
 2 61617      1        NA    16 A2        4
 3 61617      1        NA    16 A3        3
 4 61617      1        NA    16 A4        4
 5 61617      1        NA    16 A5        4
 6 61617      1        NA    16 C1        2
 7 61617      1        NA    16 C2        3
 8 61617      1        NA    16 C3        3
 9 61617      1        NA    16 C4        4
10 61617      1        NA    16 C5        4
# ℹ 69,990 more rows

次に、nest用の列を作ってnestします。今回は列名に下位尺度が入っているので、それを抽出すれば簡単にnest用の列が完成です。やりやすいデータとはこのことを言っています。

bfi |>
  rownames_to_column(var = "id") |>
  pivot_longer(
    cols = matches("\\w\\d"),
    names_to = "items"
  ) |>
  mutate(
1    nest_key = str_extract(items, "^.") |>
2      tolower()
  ) |>
3  nest(.by = nest_key)

1: items（列名のベクトル）の各要素から最初の一文字だけ抜ければいいので、stringr::str_extract()でいいです。
2: あとでbfi.keysから抽出しやすくすために、小文字にします。
3: nestに使った列以外の残りは、引数.keysを指定しなければdata列にまとまります。

# A tibble: 5 × 2
  nest_key data                 
  <chr>    <list>               
1 a        <tibble [14,000 × 6]>
2 c        <tibble [14,000 × 6]>
3 e        <tibble [14,000 × 6]>
4 n        <tibble [14,000 × 6]>
5 o        <tibble [14,000 × 6]>

nestされたデータを処理します。data列はlistなので、中の各要素を処理したいときはpurrr::map()が使えます。data列の各要素はデータフレームで、しかもaの行はAで始まる項目だけ、cの行はCで始まる項目だけ、eの行は…のlongデータになっています。そのため、map()の中でwide型に直して必要列以外取り除き、psych::alpha()に入れてあげればいいわけです。

bfi |>
  rownames_to_column(var = "id") |>
  pivot_longer(
    cols = matches("\\w\\d"),
    names_to = "items"
  ) |>
  mutate(
    nest_key = str_extract(items, "^.") |>
      tolower()
  ) |>
  nest(.by = nest_key) |>
  mutate(
1    bfi_key_name = str_subset(
      names(bfi.keys),
      pattern = paste0("^", nest_key)
    ),
    res_alpha = map(
      .x = data,
      .f = \(x) {
         x |>
          pivot_wider(
            names_from = items,
            values_from = value
          ) |>
          select(matches("\\w\\d")) |>
          psych::alpha(
2            keys = bfi.keys[[bfi_key_name]] |>
3              str_subset(pattern = "^-") |>
              str_remove(pattern = "^-")
          )
      }
    ) |>
4      set_names(bfi_key_name),
5    .by = nest_key
  )

1: alpha()の中でbfi.keysの要素名を使えるようにしたいので、ここで抜き出しておきます。
2: まさに上の処理で抜き出した要素名をここで使います。
3: 引数keysは、逆転する項目の項目名を文字列ベクトルで入れるか、逆転する項目は-1、そのままの項目は1にした数値ベクトルを入れます。今回は前者で入れるので、bfi.keysの各要素（文字列ベクトル）のうち、stringr::str_subset()を使って-で始まる項目だけを抽出して、str_remove()で-を取り除きます。
4: map()の戻り値のlistに名前を付けたいのでmap() |> purrr::set_names()とします。nestデータのほかの列の要素を使えるので、dplyr::group_map() |> set_names()よりもいい気がします。
5: 引数.byにnest_key列を指定して、実質rowwise処理をします。これを指定することで、(2)の処理で[[bfi_key_name]]のところにbfi_key_name列の要素が1つだけ入ります。これがないと、(2)の処理で要素5の文字列ベクトルc（"agree", "conscientious", ...）が[[の中に入ってしまうのでエラーになります。

# A tibble: 5 × 4
  nest_key data                  bfi_key_name  res_alpha   
  <chr>    <list>                <chr>         <named list>
1 a        <tibble [14,000 × 6]> agree         <psych>     
2 c        <tibble [14,000 × 6]> conscientious <psych>     
3 e        <tibble [14,000 × 6]> extraversion  <psych>     
4 n        <tibble [14,000 × 6]> neuroticism   <psych>     
5 o        <tibble [14,000 × 6]> openness      <psych>

最後に結果が詰まったres_alpha列だけ取り出します。データフレームからある1列の要素を取り出すときはdplyr::pull()が使えます。res_alpha列はmap()を使って作ったので、各下位尺度のα係数が入ったlistが返ってきます。

bfi |>
  rownames_to_column(var = "id") |>
  pivot_longer(
    cols = matches("\\w\\d"),
    names_to = "items"
  ) |>
  mutate(
    nest_key = str_extract(items, "^.") |>
      tolower()
  ) |>
  nest(.by = nest_key) |>
  mutate(
    bfi_key_name = str_subset(
      names(bfi.keys),
      pattern = paste0("^", nest_key)
    ),
    res_alpha = map(
      .x = data,
      .f = \(x) {
         x |>
          pivot_wider(
            names_from = items,
            values_from = value
          ) |>
          select(matches("\\w\\d")) |>
          psych::alpha(
            keys = bfi.keys[[bfi_key_name]] |> 
              str_subset(pattern = "^-") |> 
              str_remove(pattern = "^-")
          )
      }
    ) |>
      set_names(bfi_key_name),
    .by = nest_key
  ) |>
1  pull(res_alpha)

1: pullは最後に作られた列を返すので、実はpull()だけでもres_alpha列を引っ張ってこれます。

$agree

Reliability analysis   
Call: psych::alpha(x = select(pivot_wider(x, names_from = items, values_from = value), 
    matches("\\w\\d")), keys = str_remove(str_subset(bfi.keys[[bfi_key_name]], 
    pattern = "^-"), pattern = "^-"))

  raw_alpha std.alpha G6(smc) average_r S/N   ase mean  sd median_r
       0.7      0.71    0.68      0.33 2.5 0.009  4.7 0.9     0.34

    95% confidence boundaries 
         lower alpha upper
Feldt     0.69   0.7  0.72
Duhachek  0.69   0.7  0.72

 Reliability if an item is dropped:
    raw_alpha std.alpha G6(smc) average_r S/N alpha se  var.r med.r
A1-      0.72      0.72    0.67      0.40 2.6   0.0087 0.0065  0.38
A2       0.62      0.63    0.58      0.29 1.7   0.0119 0.0168  0.29
A3       0.60      0.61    0.56      0.28 1.6   0.0124 0.0094  0.32
A4       0.69      0.69    0.65      0.36 2.3   0.0098 0.0157  0.37
A5       0.64      0.66    0.60      0.32 1.9   0.0111 0.0125  0.34

 Item statistics 
       n raw.r std.r r.cor r.drop mean  sd
A1- 2784  0.58  0.57  0.38   0.31  4.6 1.4
A2  2773  0.73  0.75  0.67   0.56  4.8 1.2
A3  2774  0.76  0.77  0.71   0.59  4.6 1.3
A4  2781  0.65  0.63  0.47   0.39  4.7 1.5
A5  2784  0.69  0.70  0.59   0.49  4.6 1.3

Non missing response frequency for each item
      1    2    3    4    5    6 miss
A1 0.33 0.29 0.14 0.12 0.08 0.03 0.01
A2 0.02 0.05 0.05 0.20 0.37 0.31 0.01
A3 0.03 0.06 0.07 0.20 0.36 0.27 0.01
A4 0.05 0.08 0.07 0.16 0.24 0.41 0.01
A5 0.02 0.07 0.09 0.22 0.35 0.25 0.01

$conscientious

Reliability analysis   
Call: psych::alpha(x = select(pivot_wider(x, names_from = items, values_from = value), 
    matches("\\w\\d")), keys = str_remove(str_subset(bfi.keys[[bfi_key_name]], 
    pattern = "^-"), pattern = "^-"))

  raw_alpha std.alpha G6(smc) average_r S/N    ase mean   sd median_r
      0.73      0.73    0.69      0.35 2.7 0.0081  4.3 0.95     0.34

    95% confidence boundaries 
         lower alpha upper
Feldt     0.71  0.73  0.74
Duhachek  0.71  0.73  0.74

 Reliability if an item is dropped:
    raw_alpha std.alpha G6(smc) average_r S/N alpha se  var.r med.r
C1       0.69      0.70    0.64      0.36 2.3   0.0093 0.0037  0.35
C2       0.67      0.68    0.62      0.34 2.1   0.0099 0.0056  0.34
C3       0.69      0.69    0.64      0.36 2.3   0.0096 0.0070  0.36
C4-      0.65      0.66    0.60      0.33 2.0   0.0107 0.0037  0.32
C5-      0.69      0.69    0.63      0.36 2.2   0.0096 0.0017  0.35

 Item statistics 
       n raw.r std.r r.cor r.drop mean  sd
C1  2779  0.65  0.67  0.54   0.45  4.5 1.2
C2  2776  0.70  0.71  0.60   0.50  4.4 1.3
C3  2780  0.66  0.67  0.54   0.46  4.3 1.3
C4- 2774  0.74  0.73  0.64   0.55  4.4 1.4
C5- 2784  0.72  0.68  0.57   0.48  3.7 1.6

Non missing response frequency for each item
      1    2    3    4    5    6 miss
C1 0.03 0.06 0.10 0.24 0.37 0.21 0.01
C2 0.03 0.09 0.11 0.23 0.35 0.20 0.01
C3 0.03 0.09 0.11 0.27 0.34 0.17 0.01
C4 0.28 0.29 0.17 0.16 0.08 0.02 0.01
C5 0.18 0.20 0.12 0.22 0.17 0.10 0.01

$extraversion

Reliability analysis   
Call: psych::alpha(x = select(pivot_wider(x, names_from = items, values_from = value), 
    matches("\\w\\d")), keys = str_remove(str_subset(bfi.keys[[bfi_key_name]], 
    pattern = "^-"), pattern = "^-"))

  raw_alpha std.alpha G6(smc) average_r S/N   ase mean  sd median_r
      0.76      0.76    0.73      0.39 3.2 0.007  4.1 1.1     0.38

    95% confidence boundaries 
         lower alpha upper
Feldt     0.75  0.76  0.78
Duhachek  0.75  0.76  0.78

 Reliability if an item is dropped:
    raw_alpha std.alpha G6(smc) average_r S/N alpha se  var.r med.r
E1-      0.73      0.73    0.67      0.40 2.6   0.0084 0.0044  0.38
E2-      0.69      0.69    0.63      0.36 2.3   0.0095 0.0028  0.35
E3       0.73      0.73    0.67      0.40 2.7   0.0082 0.0071  0.40
E4       0.70      0.70    0.65      0.37 2.4   0.0091 0.0033  0.38
E5       0.74      0.74    0.69      0.42 2.9   0.0078 0.0043  0.42

 Item statistics 
       n raw.r std.r r.cor r.drop mean  sd
E1- 2777  0.72  0.70  0.59   0.52  4.0 1.6
E2- 2784  0.78  0.76  0.69   0.61  3.9 1.6
E3  2775  0.68  0.70  0.58   0.50  4.0 1.4
E4  2791  0.75  0.75  0.66   0.58  4.4 1.5
E5  2779  0.64  0.66  0.52   0.45  4.4 1.3

Non missing response frequency for each item
      1    2    3    4    5    6 miss
E1 0.24 0.23 0.15 0.16 0.13 0.09 0.01
E2 0.19 0.24 0.12 0.22 0.14 0.09 0.01
E3 0.05 0.11 0.15 0.30 0.27 0.13 0.01
E4 0.05 0.09 0.10 0.16 0.34 0.26 0.00
E5 0.03 0.08 0.10 0.22 0.34 0.22 0.01

$neuroticism

Reliability analysis   
Call: psych::alpha(x = select(pivot_wider(x, names_from = items, values_from = value), 
    matches("\\w\\d")), keys = str_remove(str_subset(bfi.keys[[bfi_key_name]], 
    pattern = "^-"), pattern = "^-"))

  raw_alpha std.alpha G6(smc) average_r S/N    ase mean  sd median_r
      0.81      0.81     0.8      0.47 4.4 0.0056  3.2 1.2     0.41

    95% confidence boundaries 
         lower alpha upper
Feldt      0.8  0.81  0.82
Duhachek   0.8  0.81  0.82

 Reliability if an item is dropped:
   raw_alpha std.alpha G6(smc) average_r S/N alpha se  var.r med.r
N1      0.76      0.76    0.71      0.44 3.1   0.0075 0.0061  0.41
N2      0.76      0.76    0.72      0.45 3.2   0.0073 0.0054  0.41
N3      0.76      0.76    0.73      0.44 3.1   0.0077 0.0178  0.39
N4      0.80      0.80    0.77      0.49 3.9   0.0064 0.0181  0.49
N5      0.81      0.81    0.79      0.52 4.3   0.0059 0.0137  0.53

 Item statistics 
      n raw.r std.r r.cor r.drop mean  sd
N1 2778  0.80  0.80  0.76   0.67  2.9 1.6
N2 2779  0.79  0.79  0.75   0.65  3.5 1.5
N3 2789  0.81  0.81  0.74   0.67  3.2 1.6
N4 2764  0.72  0.71  0.60   0.54  3.2 1.6
N5 2771  0.68  0.67  0.53   0.49  3.0 1.6

Non missing response frequency for each item
      1    2    3    4    5    6 miss
N1 0.24 0.24 0.15 0.19 0.12 0.07 0.01
N2 0.12 0.19 0.15 0.26 0.18 0.10 0.01
N3 0.18 0.23 0.13 0.21 0.16 0.09 0.00
N4 0.17 0.24 0.15 0.22 0.14 0.09 0.01
N5 0.24 0.24 0.14 0.18 0.12 0.09 0.01

$openness

Reliability analysis   
Call: psych::alpha(x = select(pivot_wider(x, names_from = items, values_from = value), 
    matches("\\w\\d")), keys = str_remove(str_subset(bfi.keys[[bfi_key_name]], 
    pattern = "^-"), pattern = "^-"))

  raw_alpha std.alpha G6(smc) average_r S/N   ase mean   sd median_r
       0.6      0.61    0.57      0.24 1.5 0.012  4.6 0.81     0.23

    95% confidence boundaries 
         lower alpha upper
Feldt     0.58   0.6  0.62
Duhachek  0.58   0.6  0.62

 Reliability if an item is dropped:
    raw_alpha std.alpha G6(smc) average_r S/N alpha se  var.r med.r
O1       0.53      0.53    0.48      0.22 1.1    0.014 0.0092  0.23
O2-      0.57      0.57    0.51      0.25 1.3    0.013 0.0076  0.22
O3       0.50      0.50    0.44      0.20 1.0    0.015 0.0071  0.20
O4       0.61      0.62    0.56      0.29 1.6    0.012 0.0044  0.29
O5-      0.51      0.53    0.47      0.22 1.1    0.015 0.0116  0.20

 Item statistics 
       n raw.r std.r r.cor r.drop mean  sd
O1  2778  0.62  0.65  0.52   0.39  4.8 1.1
O2- 2800  0.65  0.60  0.43   0.33  4.3 1.6
O3  2772  0.67  0.69  0.59   0.45  4.4 1.2
O4  2786  0.50  0.52  0.29   0.22  4.9 1.2
O5- 2780  0.67  0.66  0.52   0.42  4.5 1.3

Non missing response frequency for each item
      1    2    3    4    5    6 miss
O1 0.01 0.04 0.08 0.22 0.33 0.33 0.01
O2 0.29 0.26 0.14 0.16 0.10 0.06 0.00
O3 0.03 0.05 0.11 0.28 0.34 0.20 0.01
O4 0.02 0.04 0.06 0.17 0.32 0.39 0.01
O5 0.27 0.32 0.19 0.13 0.07 0.03 0.01

ということで、元のdfからmapを使って一気にα係数を求めることができました。一つのnamed listに下位尺度5つ分の出力が詰まっているので、オブジェクトに入れた際にGrobal Env.がオブジェクトだらけにならないというのはいい点かもしれないです。

やりやすくなさそうなデータの場合

bfiデータは列名に下位尺度の分類が含まれていたのでやりやすかったのですが、実際に扱うデータだとそうはいかない場合もあると思います。というわけで、bfiを少しいじってこんなデータを用意してみました。

改造の処理はこちら

bfiの列をデモグラフィック列（26-28）以外ランダムに並べ替えるために、列番号をシャッフルします。

set.seed(20251025)

(vec_col_order <- c(sample(1:25), 26:28))

 [1] 23  7 13 25  1  3  5 10 17  8 21 22 15 16  4 19  6 18  9 20 12 11  2 14 24
[26] 26 27 28

後でkeyを作る用のベクトルを作成。チェック用に元のbfiの列名を名前に付けておきます。

vec_names_df_test <- c(
  paste0("q1_x", 1:25),
  paste0("q2_x", 1:3)
) |>
  setNames(
    colnames(bfi[, vec_col_order])
  )

vec_names_df_test

       O3        C2        E3        O5        A1        A3        A5        C5 
  "q1_x1"   "q1_x2"   "q1_x3"   "q1_x4"   "q1_x5"   "q1_x6"   "q1_x7"   "q1_x8" 
       N2        C3        O1        O2        E5        N1        A4        N4 
  "q1_x9"  "q1_x10"  "q1_x11"  "q1_x12"  "q1_x13"  "q1_x14"  "q1_x15"  "q1_x16" 
       C1        N3        C4        N5        E2        E1        A2        E4 
 "q1_x17"  "q1_x18"  "q1_x19"  "q1_x20"  "q1_x21"  "q1_x22"  "q1_x23"  "q1_x24" 
       O4    gender education       age 
 "q1_x25"   "q2_x1"   "q2_x2"   "q2_x3"

列番号をシャッフルしたベクトルを使って、列を並び替えたdfを作ります。ついでにid列もつけておきます。

df_test <- bfi[, vec_col_order] |>
  `colnames<-`(vec_names_df_test) |>
  rownames_to_column(var = "id")

colnames(df_test)

 [1] "id"     "q1_x1"  "q1_x2"  "q1_x3"  "q1_x4"  "q1_x5"  "q1_x6"  "q1_x7" 
 [9] "q1_x8"  "q1_x9"  "q1_x10" "q1_x11" "q1_x12" "q1_x13" "q1_x14" "q1_x15"
[17] "q1_x16" "q1_x17" "q1_x18" "q1_x19" "q1_x20" "q1_x21" "q1_x22" "q1_x23"
[25] "q1_x24" "q1_x25" "q2_x1"  "q2_x2"  "q2_x3"

構成要素の分類を示すkeyを作ります。実際の場合はnamed listを自力で作成すればいいと思います（それか、psych::make.keys()あたりを使うか）。今回は手入力したくないのでゴリ押します。

list_test_keys <-
  names(bfi.keys) |>
  str_extract(pattern = "^.") |>
  toupper() |>
  set_names() |>
  map(
    .f = \(x){
      temp_vec <- vec_names_df_test[1:25]
      temp_vec[str_starts(names(temp_vec), x)]
    }
  ) |>
  map(
    .f = \(x) {
      if_else(
        names(x) %in% unlist(bfi.keys),
        x,
        paste0("-", x) |>
          set_names(names(x))
      )
    }
  )

list_test_keys

$A
      A1       A3       A5       A4       A2 
"-q1_x5"  "q1_x6"  "q1_x7" "q1_x15" "q1_x23" 

$C
       C2        C5        C3        C1        C4 
  "q1_x2"  "-q1_x8"  "q1_x10"  "q1_x17" "-q1_x19" 

$E
       E3        E5        E2        E1        E4 
  "q1_x3"  "q1_x13" "-q1_x21" "-q1_x22"  "q1_x24" 

$N
      N2       N1       N4       N3       N5 
 "q1_x9" "q1_x14" "q1_x16" "q1_x18" "q1_x20" 

$O
       O3        O5        O1        O2        O4 
  "q1_x1"  "-q1_x4"  "q1_x11" "-q1_x12"  "q1_x25"

手入力の方がむしろ省コードだし楽だろ！！という指摘は今回はなかったことにします。

ちなみに逆転項目の設定はちゃんとできています。

data.frame(
  enframe(
    unlist(list_test_keys)
  ) |>
    arrange(name),
  enframe(
    unlist(bfi.keys)
  )
)

   name   value         name.1 value.1
1  A.A1  -q1_x5         agree1     -A1
2  A.A2  q1_x23         agree2      A2
3  A.A3   q1_x6         agree3      A3
4  A.A4  q1_x15         agree4      A4
5  A.A5   q1_x7         agree5      A5
6  C.C1  q1_x17 conscientious1      C1
7  C.C2   q1_x2 conscientious2      C2
8  C.C3  q1_x10 conscientious3      C3
9  C.C4 -q1_x19 conscientious4     -C4
10 C.C5  -q1_x8 conscientious5     -C5
11 E.E1 -q1_x22  extraversion1     -E1
12 E.E2 -q1_x21  extraversion2     -E2
13 E.E3   q1_x3  extraversion3      E3
14 E.E4  q1_x24  extraversion4      E4
15 E.E5  q1_x13  extraversion5      E5
16 N.N1  q1_x14   neuroticism1      N1
17 N.N2   q1_x9   neuroticism2      N2
18 N.N3  q1_x18   neuroticism3      N3
19 N.N4  q1_x16   neuroticism4      N4
20 N.N5  q1_x20   neuroticism5      N5
21 O.O1  q1_x11      openness1      O1
22 O.O2 -q1_x12      openness2     -O2
23 O.O3   q1_x1      openness3      O3
24 O.O4  q1_x25      openness4      O4
25 O.O5  -q1_x4      openness5     -O5

元のデータと行数列数は一緒ですが、列名と順番が変わりました。コードブックの作成が必須ですね。

str(df_test)

'data.frame':   2800 obs. of  29 variables:
 $ id    : chr  "61617" "61618" "61620" "61621" ...
 $ q1_x1 : int  3 4 5 4 4 5 5 4 6 5 ...
 $ q1_x2 : int  3 4 5 4 4 6 4 2 6 5 ...
 $ q1_x3 : int  3 6 4 4 5 6 4 4 NA 4 ...
 $ q1_x4 : int  3 3 2 5 3 1 1 3 1 2 ...
 $ q1_x5 : int  2 2 5 4 2 6 2 4 4 2 ...
 $ q1_x6 : int  3 5 5 6 3 5 5 1 6 6 ...
 $ q1_x7 : int  4 5 4 5 5 5 5 1 3 5 ...
 $ q1_x8 : int  4 4 5 5 2 3 3 4 5 1 ...
 $ q1_x9 : int  4 3 5 5 3 5 2 3 5 5 ...
 $ q1_x10: int  3 4 4 3 5 6 4 4 3 6 ...
 $ q1_x11: int  3 4 4 3 3 4 5 3 6 5 ...
 $ q1_x12: int  6 2 2 3 3 3 2 2 6 1 ...
 $ q1_x13: int  4 3 5 4 5 6 5 1 3 5 ...
 $ q1_x14: int  3 3 4 2 2 3 1 6 5 5 ...
 $ q1_x15: int  4 2 4 5 4 6 3 5 3 6 ...
 $ q1_x16: int  2 5 2 4 4 2 1 6 3 2 ...
 $ q1_x17: int  2 5 4 4 4 6 5 3 6 6 ...
 $ q1_x18: int  2 3 4 2 4 2 2 2 2 5 ...
 $ q1_x19: int  4 3 2 5 3 1 2 2 4 2 ...
 $ q1_x20: int  3 5 3 1 3 3 1 4 3 4 ...
 $ q1_x21: int  3 1 4 3 2 1 3 6 3 2 ...
 $ q1_x22: int  3 1 2 5 2 2 4 3 5 2 ...
 $ q1_x23: int  4 4 4 4 3 6 5 3 3 5 ...
 $ q1_x24: int  4 4 4 4 4 5 5 2 4 5 ...
 $ q1_x25: int  4 3 5 3 3 6 6 5 6 5 ...
 $ q2_x1 : int  1 2 2 2 1 2 1 1 1 2 ...
 $ q2_x2 : int  NA NA NA NA NA 3 NA 2 1 NA ...
 $ q2_x3 : int  16 18 17 17 17 21 18 19 19 17 ...

そして構成要素の分類のkeyも用意しました。要素のベクトルに名前がついているのはチェックのためで、本来はないと思ってください。QualtricsとかMicrosoft Formsとかには項目をランダムに提示する機能があるので、それを使えば列をこんなにシャッフルする必要はないんですが、「よくわからなかったので、尺度の項目の順番を自分で頑張ってシャッフルしちゃいました…」という事案はあると思います。

list_test_keys

$A
      A1       A3       A5       A4       A2 
"-q1_x5"  "q1_x6"  "q1_x7" "q1_x15" "q1_x23" 

$C
       C2        C5        C3        C1        C4 
  "q1_x2"  "-q1_x8"  "q1_x10"  "q1_x17" "-q1_x19" 

$E
       E3        E5        E2        E1        E4 
  "q1_x3"  "q1_x13" "-q1_x21" "-q1_x22"  "q1_x24" 

$N
      N2       N1       N4       N3       N5 
 "q1_x9" "q1_x14" "q1_x16" "q1_x18" "q1_x20" 

$O
       O3        O5        O1        O2        O4 
  "q1_x1"  "-q1_x4"  "q1_x11" "-q1_x12"  "q1_x25"

というわけで、こちらのデータでもmap()でalpha()を一気に処理してみようと思います。先ほどはデータセットの列名に下位尺度の分類が入っていたので処理が少なく済みましたが、今回はそうではないので処理が少し増えます。

まずlong型にした後、新たにマッチ用の列を作って逆転項目に-をつけます。（別にわざわざ新しい列を作らなくてもいいのですが、alpha()の出力のときに項目名の前後に-がつくのが気になるので、あえてマッチ用の列を作っています。）

df_test |>
  pivot_longer(
    cols = starts_with("q1"),
    names_to = "items"
  ) |>
  mutate(
    match_items = if_else(
      items %in% unlist(list_test_keys),
      items,
      str_c("-", items)
    )
  )

# A tibble: 70,000 × 7
   id    q2_x1 q2_x2 q2_x3 items  value match_items
   <chr> <int> <int> <int> <chr>  <int> <chr>      
 1 61617     1    NA    16 q1_x1      3 q1_x1      
 2 61617     1    NA    16 q1_x2      3 q1_x2      
 3 61617     1    NA    16 q1_x3      3 q1_x3      
 4 61617     1    NA    16 q1_x4      3 -q1_x4     
 5 61617     1    NA    16 q1_x5      2 -q1_x5     
 6 61617     1    NA    16 q1_x6      3 q1_x6      
 7 61617     1    NA    16 q1_x7      4 q1_x7      
 8 61617     1    NA    16 q1_x8      4 -q1_x8     
 9 61617     1    NA    16 q1_x9      4 q1_x9      
10 61617     1    NA    16 q1_x10     3 q1_x10     
# ℹ 69,990 more rows

次に、マッチ用の列をdplyr::case_match()に入れて、分類用のリストと照合します。case_match()は、第一引数.xにマッチさせたいベクトル、以降はtwo-sided formula形式で処理を書いていきます。左側（LHS）はマッチさせたい要素、右側（RHS）にはマッチしたものに対する出力を入れます。このformulaの部分だけは頑張って書かないといけません。今回は分類リストがnamed listでその要素は文字列ベクトルなので、各要素にマッチしたらその要素のリスト名（＝下位尺度の分類）を返すようにします。

df_test |>
  pivot_longer(
    cols = starts_with("q1"),
    names_to = "items"
  ) |>
  mutate(
    match_items = if_else(
      items %in% unlist(list_test_keys),
      items,
      str_c("-", items)
    ),
    nest_key = case_match(
      match_items,
      list_test_keys[["A"]] ~ "A",
      list_test_keys[["C"]] ~ "C",
      list_test_keys[["E"]] ~ "E",
      list_test_keys[["N"]] ~ "N",
      list_test_keys[["O"]] ~ "O",
    )
  )

# A tibble: 70,000 × 8
   id    q2_x1 q2_x2 q2_x3 items  value match_items nest_key
   <chr> <int> <int> <int> <chr>  <int> <chr>       <chr>   
 1 61617     1    NA    16 q1_x1      3 q1_x1       O       
 2 61617     1    NA    16 q1_x2      3 q1_x2       C       
 3 61617     1    NA    16 q1_x3      3 q1_x3       E       
 4 61617     1    NA    16 q1_x4      3 -q1_x4      O       
 5 61617     1    NA    16 q1_x5      2 -q1_x5      A       
 6 61617     1    NA    16 q1_x6      3 q1_x6       A       
 7 61617     1    NA    16 q1_x7      4 q1_x7       A       
 8 61617     1    NA    16 q1_x8      4 -q1_x8      C       
 9 61617     1    NA    16 q1_x9      4 q1_x9       N       
10 61617     1    NA    16 q1_x10     3 q1_x10      C       
# ℹ 69,990 more rows

後の処理は先ほどと変わりません。nestしたうえでmap処理をしていけばいいです。

df_test |>
  pivot_longer(
    cols = starts_with("q1"),
    names_to = "items"
  ) |>
  mutate(
    match_items = if_else(
      items %in% unlist(list_test_keys),
      items,
      str_c("-", items)
    ),
    nest_key = case_match(
      match_items,
      list_test_keys[["A"]] ~ "A",
      list_test_keys[["C"]] ~ "C",
      list_test_keys[["E"]] ~ "E",
      list_test_keys[["N"]] ~ "N",
      list_test_keys[["O"]] ~ "O"
    )
  ) |>
  nest(.by = nest_key) |>
1  arrange(nest_key) |>
  mutate(
    res_alpha = map(
      .x = data,
      .f = \(x) {
        x |>
2          select(-match_items) |>
          pivot_wider(
            names_from = items,
            values_from = value
          ) |>
          select(starts_with("q1")) |>
          psych::alpha(
            keys = list_test_keys[[nest_key]] |>
              str_subset("^-") |>
              str_remove("^-")
          )
      }
    ) |>
      set_names(nest_key),
    .by = nest_key
  ) |>
  pull(res_alpha)

1: dplyrとかで実装されている引数.byはデータを出現順に並べるので、データによっては出力がきれいな順番（A, B, C, … ）にならないです。なので見やすくするためにdplyr::arrange()でソートしておきます。
2: マッチ用の列は残しておくとwide型にしたときにデータがズレるので外しておきます。マッチ用の列を作っていなかったら省略してOKです。

$A

Reliability analysis   
Call: psych::alpha(x = select(pivot_wider(select(x, -match_items), 
    names_from = items, values_from = value), starts_with("q1")), 
    keys = str_remove(str_subset(list_test_keys[[nest_key]], 
        "^-"), "^-"))

  raw_alpha std.alpha G6(smc) average_r S/N   ase mean  sd median_r
       0.7      0.71    0.68      0.33 2.5 0.009  4.7 0.9     0.34

    95% confidence boundaries 
         lower alpha upper
Feldt     0.69   0.7  0.72
Duhachek  0.69   0.7  0.72

 Reliability if an item is dropped:
       raw_alpha std.alpha G6(smc) average_r S/N alpha se  var.r med.r
q1_x5-      0.72      0.72    0.67      0.40 2.6   0.0087 0.0065  0.38
q1_x6       0.60      0.61    0.56      0.28 1.6   0.0124 0.0094  0.32
q1_x7       0.64      0.66    0.60      0.32 1.9   0.0111 0.0125  0.34
q1_x15      0.69      0.69    0.65      0.36 2.3   0.0098 0.0157  0.37
q1_x23      0.62      0.63    0.58      0.29 1.7   0.0119 0.0168  0.29

 Item statistics 
          n raw.r std.r r.cor r.drop mean  sd
q1_x5- 2784  0.58  0.57  0.38   0.31  4.6 1.4
q1_x6  2774  0.76  0.77  0.71   0.59  4.6 1.3
q1_x7  2784  0.69  0.70  0.59   0.49  4.6 1.3
q1_x15 2781  0.65  0.63  0.47   0.39  4.7 1.5
q1_x23 2773  0.73  0.75  0.67   0.56  4.8 1.2

Non missing response frequency for each item
          1    2    3    4    5    6 miss
q1_x5  0.33 0.29 0.14 0.12 0.08 0.03 0.01
q1_x6  0.03 0.06 0.07 0.20 0.36 0.27 0.01
q1_x7  0.02 0.07 0.09 0.22 0.35 0.25 0.01
q1_x15 0.05 0.08 0.07 0.16 0.24 0.41 0.01
q1_x23 0.02 0.05 0.05 0.20 0.37 0.31 0.01

$C

Reliability analysis   
Call: psych::alpha(x = select(pivot_wider(select(x, -match_items), 
    names_from = items, values_from = value), starts_with("q1")), 
    keys = str_remove(str_subset(list_test_keys[[nest_key]], 
        "^-"), "^-"))

  raw_alpha std.alpha G6(smc) average_r S/N    ase mean   sd median_r
      0.73      0.73    0.69      0.35 2.7 0.0081  4.3 0.95     0.34

    95% confidence boundaries 
         lower alpha upper
Feldt     0.71  0.73  0.74
Duhachek  0.71  0.73  0.74

 Reliability if an item is dropped:
        raw_alpha std.alpha G6(smc) average_r S/N alpha se  var.r med.r
q1_x2        0.67      0.68    0.62      0.34 2.1   0.0099 0.0056  0.34
q1_x8-       0.69      0.69    0.63      0.36 2.2   0.0096 0.0017  0.35
q1_x10       0.69      0.69    0.64      0.36 2.3   0.0096 0.0070  0.36
q1_x17       0.69      0.70    0.64      0.36 2.3   0.0093 0.0037  0.35
q1_x19-      0.65      0.66    0.60      0.33 2.0   0.0107 0.0037  0.32

 Item statistics 
           n raw.r std.r r.cor r.drop mean  sd
q1_x2   2776  0.70  0.71  0.60   0.50  4.4 1.3
q1_x8-  2784  0.72  0.68  0.57   0.48  3.7 1.6
q1_x10  2780  0.66  0.67  0.54   0.46  4.3 1.3
q1_x17  2779  0.65  0.67  0.54   0.45  4.5 1.2
q1_x19- 2774  0.74  0.73  0.64   0.55  4.4 1.4

Non missing response frequency for each item
          1    2    3    4    5    6 miss
q1_x2  0.03 0.09 0.11 0.23 0.35 0.20 0.01
q1_x8  0.18 0.20 0.12 0.22 0.17 0.10 0.01
q1_x10 0.03 0.09 0.11 0.27 0.34 0.17 0.01
q1_x17 0.03 0.06 0.10 0.24 0.37 0.21 0.01
q1_x19 0.28 0.29 0.17 0.16 0.08 0.02 0.01

$E

Reliability analysis   
Call: psych::alpha(x = select(pivot_wider(select(x, -match_items), 
    names_from = items, values_from = value), starts_with("q1")), 
    keys = str_remove(str_subset(list_test_keys[[nest_key]], 
        "^-"), "^-"))

  raw_alpha std.alpha G6(smc) average_r S/N   ase mean  sd median_r
      0.76      0.76    0.73      0.39 3.2 0.007  4.1 1.1     0.38

    95% confidence boundaries 
         lower alpha upper
Feldt     0.75  0.76  0.78
Duhachek  0.75  0.76  0.78

 Reliability if an item is dropped:
        raw_alpha std.alpha G6(smc) average_r S/N alpha se  var.r med.r
q1_x3        0.73      0.73    0.67      0.40 2.7   0.0082 0.0071  0.40
q1_x13       0.74      0.74    0.69      0.42 2.9   0.0078 0.0043  0.42
q1_x21-      0.69      0.69    0.63      0.36 2.3   0.0095 0.0028  0.35
q1_x22-      0.73      0.73    0.67      0.40 2.6   0.0084 0.0044  0.38
q1_x24       0.70      0.70    0.65      0.37 2.4   0.0091 0.0033  0.38

 Item statistics 
           n raw.r std.r r.cor r.drop mean  sd
q1_x3   2775  0.68  0.70  0.58   0.50  4.0 1.4
q1_x13  2779  0.64  0.66  0.52   0.45  4.4 1.3
q1_x21- 2784  0.78  0.76  0.69   0.61  3.9 1.6
q1_x22- 2777  0.72  0.70  0.59   0.52  4.0 1.6
q1_x24  2791  0.75  0.75  0.66   0.58  4.4 1.5

Non missing response frequency for each item
          1    2    3    4    5    6 miss
q1_x3  0.05 0.11 0.15 0.30 0.27 0.13 0.01
q1_x13 0.03 0.08 0.10 0.22 0.34 0.22 0.01
q1_x21 0.19 0.24 0.12 0.22 0.14 0.09 0.01
q1_x22 0.24 0.23 0.15 0.16 0.13 0.09 0.01
q1_x24 0.05 0.09 0.10 0.16 0.34 0.26 0.00

$N

Reliability analysis   
Call: psych::alpha(x = select(pivot_wider(select(x, -match_items), 
    names_from = items, values_from = value), starts_with("q1")), 
    keys = str_remove(str_subset(list_test_keys[[nest_key]], 
        "^-"), "^-"))

  raw_alpha std.alpha G6(smc) average_r S/N    ase mean  sd median_r
      0.81      0.81     0.8      0.47 4.4 0.0056  3.2 1.2     0.41

    95% confidence boundaries 
         lower alpha upper
Feldt      0.8  0.81  0.82
Duhachek   0.8  0.81  0.82

 Reliability if an item is dropped:
       raw_alpha std.alpha G6(smc) average_r S/N alpha se  var.r med.r
q1_x9       0.76      0.76    0.72      0.45 3.2   0.0073 0.0054  0.41
q1_x14      0.76      0.76    0.71      0.44 3.1   0.0075 0.0061  0.41
q1_x16      0.80      0.80    0.77      0.49 3.9   0.0064 0.0181  0.49
q1_x18      0.76      0.76    0.73      0.44 3.1   0.0077 0.0178  0.39
q1_x20      0.81      0.81    0.79      0.52 4.3   0.0059 0.0137  0.53

 Item statistics 
          n raw.r std.r r.cor r.drop mean  sd
q1_x9  2779  0.79  0.79  0.75   0.65  3.5 1.5
q1_x14 2778  0.80  0.80  0.76   0.67  2.9 1.6
q1_x16 2764  0.72  0.71  0.60   0.54  3.2 1.6
q1_x18 2789  0.81  0.81  0.74   0.67  3.2 1.6
q1_x20 2771  0.68  0.67  0.53   0.49  3.0 1.6

Non missing response frequency for each item
          1    2    3    4    5    6 miss
q1_x9  0.12 0.19 0.15 0.26 0.18 0.10 0.01
q1_x14 0.24 0.24 0.15 0.19 0.12 0.07 0.01
q1_x16 0.17 0.24 0.15 0.22 0.14 0.09 0.01
q1_x18 0.18 0.23 0.13 0.21 0.16 0.09 0.00
q1_x20 0.24 0.24 0.14 0.18 0.12 0.09 0.01

$O

Reliability analysis   
Call: psych::alpha(x = select(pivot_wider(select(x, -match_items), 
    names_from = items, values_from = value), starts_with("q1")), 
    keys = str_remove(str_subset(list_test_keys[[nest_key]], 
        "^-"), "^-"))

  raw_alpha std.alpha G6(smc) average_r S/N   ase mean   sd median_r
       0.6      0.61    0.57      0.24 1.5 0.012  4.6 0.81     0.23

    95% confidence boundaries 
         lower alpha upper
Feldt     0.58   0.6  0.62
Duhachek  0.58   0.6  0.62

 Reliability if an item is dropped:
        raw_alpha std.alpha G6(smc) average_r S/N alpha se  var.r med.r
q1_x1        0.50      0.50    0.44      0.20 1.0    0.015 0.0071  0.20
q1_x4-       0.51      0.53    0.47      0.22 1.1    0.015 0.0116  0.20
q1_x11       0.53      0.53    0.48      0.22 1.1    0.014 0.0092  0.23
q1_x12-      0.57      0.57    0.51      0.25 1.3    0.013 0.0076  0.22
q1_x25       0.61      0.62    0.56      0.29 1.6    0.012 0.0044  0.29

 Item statistics 
           n raw.r std.r r.cor r.drop mean  sd
q1_x1   2772  0.67  0.69  0.59   0.45  4.4 1.2
q1_x4-  2780  0.67  0.66  0.52   0.42  4.5 1.3
q1_x11  2778  0.62  0.65  0.52   0.39  4.8 1.1
q1_x12- 2800  0.65  0.60  0.43   0.33  4.3 1.6
q1_x25  2786  0.50  0.52  0.29   0.22  4.9 1.2

Non missing response frequency for each item
          1    2    3    4    5    6 miss
q1_x1  0.03 0.05 0.11 0.28 0.34 0.20 0.01
q1_x4  0.27 0.32 0.19 0.13 0.07 0.03 0.01
q1_x11 0.01 0.04 0.08 0.22 0.33 0.33 0.01
q1_x12 0.29 0.26 0.14 0.16 0.10 0.06 0.00
q1_x25 0.02 0.04 0.06 0.17 0.32 0.39 0.01

こちらのデータでもうまくできました。

Conclusion

というわけで、purrr::map()の中でpsych::alpha()を使って、元のdfから一気にα係数の処理をしてみました。コードの可読性という観点からみると下位尺度ごとに処理をしてオブジェクトに入れていく方法の方が見てわかりやすいし、コードの量もそれほど多くならないので、map処理で一気にやる方法が実用的かはわかりません。ただ、パイプフローの中でシーケンシャルに進められる点やミスの原因となる要素の手入力を減らせる点が個人的にはいいと思います。