gtパッケージの使い方については以下を参考にしました。

準備

疑似データの作成

学力検査データ

library(dplyr)
## 
## Attaching package: 'dplyr'
## The following objects are masked from 'package:stats':
## 
##     filter, lag
## The following objects are masked from 'package:base':
## 
##     intersect, setdiff, setequal, union
kokuA.norm <-data.frame(as.integer(rnorm(1200, mean = 10, sd = 2)))
colnames(kokuA.norm) <- c("kokuA")
kokuA.norm$kokuA <- as.numeric(kokuA.norm$kokuA)
kokuA.norm.0.14 <- kokuA.norm %>% 
                 dplyr::filter(kokuA >= 1 & kokuA <= 14)

kokuA.uni <- data.frame(
  as.integer(runif(2000 - nrow(kokuA.norm.0.14), min = 0, max = 14))
  )
colnames(kokuA.uni) <- c("kokuA")
kokuA.moto <- rbind(kokuA.norm.0.14, kokuA.uni)
kokuA.spl <- sample(kokuA.moto, length(kokuA.moto))

kokuB.norm <-data.frame(as.integer(rnorm(1200, mean = 7, sd = 2)))
colnames(kokuB.norm) <- c("kokuB")
kokuB.norm$kokuB <- as.numeric(kokuB.norm$kokuB)
kokuB.norm.0.9 <- kokuB.norm %>% 
                 dplyr::filter(kokuB >= 1 & kokuB <= 9)

kokuB.uni <- data.frame(
  as.integer(runif(2000 - nrow(kokuB.norm.0.9), min = 0, max = 9))
  )
colnames(kokuB.uni) <- c("kokuB")
kokuB.moto <- rbind(kokuB.norm.0.9, kokuB.uni)
kokuB.spl <- sample(kokuB.moto, length(kokuB.moto))

sansA.norm <-data.frame(as.integer(rnorm(1200, mean = 12, sd = 2)))
colnames(sansA.norm) <- c("sansA")
sansA.norm$sansA <- as.numeric(sansA.norm$sansA)
sansA.norm.0.16 <- sansA.norm %>% 
                 dplyr::filter(sansA >= 1 & sansA <= 16)

sansA.uni <- data.frame(
  as.integer(runif(2000 - nrow(sansA.norm.0.16), min = 0, max = 16))
  )
colnames(sansA.uni) <- c("sansA")
sansA.moto <- rbind(sansA.norm.0.16, sansA.uni)
sansA.spl <- sample(sansA.moto, length(sansA.moto))

sansB.norm <-data.frame(as.integer(rnorm(1200, mean = 9, sd = 2)))
colnames(sansB.norm) <- c("sansB")
sansB.norm$sansB <- as.numeric(sansB.norm$sansB)
sansB.norm.0.13 <- sansB.norm %>% 
                 dplyr::filter(sansB >= 1 & sansB <= 13)

sansB.uni <- data.frame(
  as.integer(runif(2000 - nrow(sansB.norm.0.13), min = 0, max = 13))
  )
colnames(sansB.uni) <- c("sansB")
sansB.moto <- rbind(sansB.norm.0.13, sansB.uni)
sansB.spl <- sample(sansB.moto, length(sansB.moto))

id <- data.frame(c(1:2000)); colnames(id) <- c("id")
ach <- cbind(id, kokuA.spl, kokuB.spl, sansA.spl, sansB.spl)

質問紙調査データ

id     <- data.frame(c(1:300))
schl   <- data.frame(c(rep(c(10001:10015), each = 10),
                     rep(c(20001:20015), each = 10)))
age    <- data.frame(as.integer(runif(300 , min = 22, max = 54)))
gender <- data.frame(as.integer(runif(300 , min = 1, max = 3)))
# 整数の場合1以上3未満として範囲を1から2にする
q01    <- data.frame(as.integer(runif(300 , min = 1, max = 4)))
q02    <- data.frame(as.integer(runif(300 , min = 1, max = 4)))
q03    <- data.frame(as.integer(runif(300 , min = 1, max = 4)))
q04    <- data.frame(as.integer(runif(300 , min = 1, max = 4)))

ques <- cbind(id, schl, age, gender, q01, q02, q03, q04)
colnames(ques) <- c("id", "schl", "age", "gender", 
                    "q01", "q02", "q03", "q04")
setwd("/Users/Shared/R")

学力検査データの処理

通過率をデータに加える

ach$kokuA_prop <- ach$kokuA / 14
ach$kokuB_prop <- ach$kokuB / 9
ach$sansA_prop <- ach$sansA / 16
ach$sansB_prop <- ach$sansB / 13

以下のように列が追加されている

head(ach)
##   id kokuA kokuB sansA sansB kokuA_prop kokuB_prop sansA_prop sansB_prop
## 1  1     8     8    10     9  0.5714286  0.8888889     0.6250  0.6923077
## 2  2     9     4    14     6  0.6428571  0.4444444     0.8750  0.4615385
## 3  3    10     7     7    11  0.7142857  0.7777778     0.4375  0.8461538
## 4  4     7     6    15     7  0.5000000  0.6666667     0.9375  0.5384615
## 5  5    13     7    10     9  0.9285714  0.7777778     0.6250  0.6923077
## 6  6     9     6     9     8  0.6428571  0.6666667     0.5625  0.6153846

論文に載せられる表を出力する

上のように表示されたデータを,いわゆるcut and pasteすれば表を作ることは出来る。しかし,不注意極まりない自分は信用できないので,機械に作業をしていただく。

まず,表の元となるデータを作る。

exam <- c("国語A", "国語B", "算数A", "算数B")
m <- c(mean(ach$kokuA_prop), mean(ach$kokuB_prop), 
       mean(ach$sansA_prop), mean(ach$sansB_prop))
sd <- c(sd(ach$kokuA_prop), sd(ach$kokuB_prop), 
       sd(ach$sansA_prop), sd(ach$sansB_prop))
ach.table <- data.frame(cbind(exam, m, sd))

表をきれいに作るパッケージを読み込み,とりあえず出力させてみる。

ach.table$m <- as.numeric(ach.table$m)
ach.table$sd <- as.numeric(ach.table$sd)
library(tidyverse)
library(gt)
ach.table %>% gt()
exam m sd
国語A 0.5915357 0.2350388
国語B 0.5727778 0.2751440
算数A 0.6139688 0.2348820
算数B 0.5834615 0.2322431

わりときれいな表になっている。これを,APA styleに合わせてみる。まず,有効数字を揃える。

tab.1 <- ach.table %>% gt()
tab.2 <- tab.1 %>%
  fmt_number(
    columns = c("m", "sd"),
    decimals = 2) 

列名を振り直して,統計量を示すアルファベットを斜体にする

tab.3 <- tab.2 %>%
    cols_label(
    exam = md("教科"), # md は markdown記法
    m    = md("*M*"),
    sd = md("*SD*")
  )
tab.3
教科 M SD
国語A 0.59 0.24
国語B 0.57 0.28
算数A 0.61 0.23
算数B 0.58 0.23

さらにAPAスタイルに合わせる

tab.4 <- tab.3 %>%
tab_options(table.width = pct(25), # 表全体の幅をやや拡げる
            table_body.hlines.width = 0, # tableの中の水平線は引かない
            column_labels.border.top.width = 2, 
            column_labels.border.top.color = "black", 
            column_labels.border.bottom.width = 2,
            column_labels.border.bottom.color = "black",
            # 最上列上下の水平線は細く黒く
            table_body.border.bottom.color = "black" #最下線は黒
            ) %>% 
cols_align(align = "center", columns = c("m", "sd"))
  # 2列目移行は中央寄せ(APA 7thから)
tab.4  
教科 M SD
国語A 0.59 0.24
国語B 0.57 0.28
算数A 0.61 0.23
算数B 0.58 0.23

もっと工夫すると,次のようなことができる。

# 4教科のテストについて
exam <- c("国語A", "国語B", "算数A", "算数B")
# 素点の平均と標準偏差を求め
m <- c(mean(ach$kokuA), mean(ach$kokuB), 
       mean(ach$sansA), mean(ach$sansB))
sd <- c(sd(ach$kokuA), sd(ach$kokuB), 
       sd(ach$sansA), sd(ach$sansB))
# 通過率の平均と標準偏差を求め
m_prop <- c(mean(ach$kokuA_prop), mean(ach$kokuB_prop), 
       mean(ach$sansA_prop), mean(ach$sansB_prop))
sd_prop <- c(sd(ach$kokuA_prop), sd(ach$kokuB_prop), 
       sd(ach$sansA_prop), sd(ach$sansB_prop))
# これらをまとめた表にして
ach.tab <- data.frame(cbind(exam, m, sd, m_prop, sd_prop))
# MとSDを数値型にして
ach.tab$m  <- as.numeric(ach.tab$m)
ach.tab$sd <- as.numeric(ach.tab$sd)
ach.tab$m_prop  <- as.numeric(ach.tab$m_prop)
ach.tab$sd_prop <- as.numeric(ach.tab$sd_prop)

# APAスタイルにあわせた出力を得て
gt.tab <- ach.tab %>% 
  gt() %>%# gtパッケージで表
  fmt_number(columns = c("m", "sd", "m_prop", "sd_prop"), decimals = 2) %>%
  # 有効数字揃え
  cols_label(exam = md("教科"), m = md("*M*"), sd = md("*SD*"), 
             m_prop = md("*M*"), sd_prop = md("*SD*"))  %>%
  # 列名を振り直してMとSDは斜体
  tab_spanner(label = "素点", columns = c("m", "sd")) %>%
  tab_spanner(label = "通過率", columns = c("m_prop", "sd_prop")) %>%
  tab_options(table.width = pct(50), # 表全体の幅をやや拡げる
          table_body.hlines.width = 0, # tableの中の水平線は引かない
          # spannerの下線を適切にするための設定
          column_labels.border.top.width = 2, 
          column_labels.border.top.color = "black", 
          column_labels.border.bottom.width = 1, 
          column_labels.border.bottom.color = "black",
          table.border.top.width = 2,
          table_body.border.top.color = "black", #最上線は黒
          table.border.bottom.width = 2,
          table_body.border.bottom.color = "black" #最下線は黒
          ) %>% 
  # 2列目以降は中央寄せ(APA 7thから)
  cols_align(align = "center", 
          columns = c("m", "sd", "m_prop", "sd_prop"))
gt.tab
教科 素点 通過率
M SD M SD
国語A 8.28 3.29 0.59 0.24
国語B 5.16 2.48 0.57 0.28
算数A 9.82 3.76 0.61 0.23
算数B 7.58 3.02 0.58 0.23

タイトルも付けてみる

gt.title <- gt.tab %>%
  tab_header(title = md("**Table 1**<br>教科別の平均と標準偏差")) %>%
  tab_style(
  style=cell_text(align="left"),
  locations = cells_title("title")) %>%
  tab_options(
    heading.title.font.size = px(16),
    table.border.top.width = 0, #タイトルの上の線はなし
    column_labels.border.top.width = 3, # タイトル下の線はあり 調整のため3
    column_labels.border.top.color = "black"
    )

gt.title
Table 1
教科別の平均と標準偏差
教科 素点 通過率
M SD M SD
国語A 8.28 3.29 0.59 0.24
国語B 5.16 2.48 0.57 0.28
算数A 9.82 3.76 0.61 0.23
算数B 7.58 3.02 0.58 0.23

注釈も付けてみる

gt.rem <- gt.title %>%
# ここは表の内容の脚注
  tab_footnote(
    footnote = "正答数",
    location = cells_column_spanners(spanners = "素点")) %>%
  tab_footnote(footnote = "平均",
     locations = cells_column_labels(columns = c(m, m_prop))) %>%
  tab_footnote(footnote = "標準偏差",
     locations = cells_column_labels(columns = c(sd, sd_prop))) %>%
  tab_options(table.border.bottom.width = 0) %>% #注の下の線は無し
  tab_source_note(source_note = md("このページの「疑似データの作成」セクションで作ったデータから作表したもので*実際のデータではなく*__疑似データを集計したものである。__"))
gt.rem
Table 1
教科別の平均と標準偏差
教科 素点1 通過率
M2 SD3 M2 SD3
国語A 8.28 3.29 0.59 0.24
国語B 5.16 2.48 0.57 0.28
算数A 9.82 3.76 0.61 0.23
算数B 7.58 3.02 0.58 0.23
このページの「疑似データの作成」セクションで作ったデータから作表したもので実際のデータではなく疑似データを集計したものである。
1 正答数
2 平均
3 標準偏差

出力を画像として保存する

あとから微修正ができなくなるが,信頼を得るために必要なことである。コードの下に出力されるのは生成されたpngファイルである。任意のディレクトリに保存されるので,あとは貼り付けるだけでよい。

gtsave(gt.rem, "表の例_01.png")

# TeXがいい
gtsave(gt.rem, "gt_rem.tex")

質問紙調査データの例

データはこのような形

head(ques)
##   id  schl age gender q01 q02 q03 q04
## 1  1 10001  50      1   3   2   1   2
## 2  2 10001  32      2   3   1   1   3
## 3  3 10001  35      1   3   3   2   3
## 4  4 10001  24      1   1   3   3   2
## 5  5 10001  49      1   1   1   1   1
## 6  6 10001  22      2   1   2   1   1

クロス集計

例えば,年齢とq01とのクロス集計をしてみる。

# 年齢して層別化してデータに追加する
ques2 <- ques # 元のデータを保持しておく
ques2 <- ques2 %>%
  dplyr::mutate(
    cat = case_when(
      age < 30 ~ 1,
      age < 40 ~ 2,
      age < 50 ~ 3,
      TRUE ~ 4)
    )

# カテゴリを因子型にする
## 年齢
ques2$cat <- factor(ques2$cat,
                   levels = c(1,2,3,4),
                   labels = c("20代","30代","40代","50代以上"), 
                   ordered=TRUE)

## q01
ques2$q01 <- factor(ques2$q01,
                   levels = c(1,2,3),
                   labels = c("全く","時々","頻繁"), 
                   ordered=TRUE)
head(ques2)
##   id  schl age gender  q01 q02 q03 q04      cat
## 1  1 10001  50      1 頻繁   2   1   2 50代以上
## 2  2 10001  32      2 頻繁   1   1   3     30代
## 3  3 10001  35      1 頻繁   3   2   3     30代
## 4  4 10001  24      1 全く   3   3   2     20代
## 5  5 10001  49      1 全く   1   1   1     40代
## 6  6 10001  22      2 全く   2   1   1     20代

データが変わっていることが分かる。

クロス集計自体は,簡単である。

tab01 <- table(ques2$cat, ques2$q01)
tab01
##           
##            全く 時々 頻繁
##   20代       25   33   22
##   30代       30   29   31
##   40代       27   34   27
##   50代以上   15    7   20

用途によって様々な形式がある。

# 行と列の合計欄を付ける
tab02 <- addmargins(tab01)
tab02
##           
##            全く 時々 頻繁 Sum
##   20代       25   33   22  80
##   30代       30   29   31  90
##   40代       27   34   27  88
##   50代以上   15    7   20  42
##   Sum        97  103  100 300
# 行方向の割合
tab03 <- addmargins(prop.table(tab01, margin = 1))
tab03
##           
##                 全く      時々      頻繁       Sum
##   20代     0.3125000 0.4125000 0.2750000 1.0000000
##   30代     0.3333333 0.3222222 0.3444444 1.0000000
##   40代     0.3068182 0.3863636 0.3068182 1.0000000
##   50代以上 0.3571429 0.1666667 0.4761905 1.0000000
##   Sum      1.3097944 1.2877525 1.4024531 4.0000000
# 有効数字を少なくする
round(tab03, 2)
##           
##            全く 時々 頻繁  Sum
##   20代     0.31 0.41 0.28 1.00
##   30代     0.33 0.32 0.34 1.00
##   40代     0.31 0.39 0.31 1.00
##   50代以上 0.36 0.17 0.48 1.00
##   Sum      1.31 1.29 1.40 4.00
# 列方向の割合
tab04 <- addmargins(prop.table(tab01, margin = 2))
round(tab04,2) # 和が100にならない場合がある
##           
##            全く 時々 頻繁  Sum
##   20代     0.26 0.32 0.22 0.80
##   30代     0.31 0.28 0.31 0.90
##   40代     0.28 0.33 0.27 0.88
##   50代以上 0.15 0.07 0.20 0.42
##   Sum      1.00 1.00 1.00 3.00

ここまでのデータが揃うと,以下のような表を作ることができる。

# 人数の行列を分割する
tab.n.20 <- tab02[1, -4] # 1行目 合計列なし
tab.n.30 <- tab02[2, -4] # 2行目 合計列なし
tab.n.40 <- tab02[3, -4] # 3行目 合計列なし
tab.n.50 <- tab02[4, -4] # 4行目 合計列なし

# 行方向の割合を分割
tab.r.20 <- tab03[1, -4] # 1行目 合計列なし
tab.r.30 <- tab03[2, -4] # 2行目 合計列なし
tab.r.40 <- tab03[3, -4] # 3行目 合計列なし
tab.r.50 <- tab03[4, -4] # 4行目 合計列なし

# 列方向の割合を分割
tab.c.20 <- tab04[1, -4] # 1行目 合計列なし
tab.c.30 <- tab04[2, -4] # 2行目 合計列なし
tab.c.40 <- tab04[3, -4] # 3行目 合計列なし
tab.c.50 <- tab04[4, -4] # 4行目 合計列なし

# 分割したデータを積み上げ直す
tab.40 <- rbind(tab.n.20, tab.r.20, tab.c.20,
                tab.n.30, tab.r.30, tab.c.30,
                tab.n.40, tab.r.40, tab.c.40,
                tab.n.50, tab.r.50, tab.c.50)
tab.40
##                全く        時々       頻繁
## tab.n.20 25.0000000 33.00000000 22.0000000
## tab.r.20  0.3125000  0.41250000  0.2750000
## tab.c.20  0.2577320  0.32038835  0.2200000
## tab.n.30 30.0000000 29.00000000 31.0000000
## tab.r.30  0.3333333  0.32222222  0.3444444
## tab.c.30  0.3092784  0.28155340  0.3100000
## tab.n.40 27.0000000 34.00000000 27.0000000
## tab.r.40  0.3068182  0.38636364  0.3068182
## tab.c.40  0.2783505  0.33009709  0.2700000
## tab.n.50 15.0000000  7.00000000 20.0000000
## tab.r.50  0.3571429  0.16666667  0.4761905
## tab.c.50  0.1546392  0.06796117  0.2000000

これを,報告できるような表に変換する

library(tidyverse) # 必要に応じて読み込む
library(gt) # 必要に応じて読み込む

tab.40.df <- data.frame(tab.40) # データの形を変換する
# 年齢のグループを付ける
tab.40.df$agegroup <- c(1,1,1,2,2,2,3,3,3,4,4,4)
tab.40.df$agegroup <- factor(tab.40.df$agegroup,
                   levels = c(1,2,3,4),
                   labels = c("20代","30代","40代","50代以上"), 
                   ordered = TRUE)
# 出力の内容の名前を付ける
tab.40.df$out <- c(1,2,3,1,2,3,1,2,3,1,2,3)
tab.40.df$out <- factor(tab.40.df$out,
                   levels = c(1,2,3),
                   labels = c("度数","行の割合","列の割合"), 
                   ordered = FALSE)
# 列を並び替える
tab.40.df.2 <- tab.40.df[c(4,5,1:3)]
tab.40.df.2
##          agegroup      out       全く        時々       頻繁
## tab.n.20     20代     度数 25.0000000 33.00000000 22.0000000
## tab.r.20     20代 行の割合  0.3125000  0.41250000  0.2750000
## tab.c.20     20代 列の割合  0.2577320  0.32038835  0.2200000
## tab.n.30     30代     度数 30.0000000 29.00000000 31.0000000
## tab.r.30     30代 行の割合  0.3333333  0.32222222  0.3444444
## tab.c.30     30代 列の割合  0.3092784  0.28155340  0.3100000
## tab.n.40     40代     度数 27.0000000 34.00000000 27.0000000
## tab.r.40     40代 行の割合  0.3068182  0.38636364  0.3068182
## tab.c.40     40代 列の割合  0.2783505  0.33009709  0.2700000
## tab.n.50 50代以上     度数 15.0000000  7.00000000 20.0000000
## tab.r.50 50代以上 行の割合  0.3571429  0.16666667  0.4761905
## tab.c.50 50代以上 列の割合  0.1546392  0.06796117  0.2000000
cross.tab <- tab.40.df.2 %>% gt()
cross.tab
agegroup out 全く 時々 頻繁
20代 度数 25.0000000 33.00000000 22.0000000
20代 行の割合 0.3125000 0.41250000 0.2750000
20代 列の割合 0.2577320 0.32038835 0.2200000
30代 度数 30.0000000 29.00000000 31.0000000
30代 行の割合 0.3333333 0.32222222 0.3444444
30代 列の割合 0.3092784 0.28155340 0.3100000
40代 度数 27.0000000 34.00000000 27.0000000
40代 行の割合 0.3068182 0.38636364 0.3068182
40代 列の割合 0.2783505 0.33009709 0.2700000
50代以上 度数 15.0000000 7.00000000 20.0000000
50代以上 行の割合 0.3571429 0.16666667 0.4761905
50代以上 列の割合 0.1546392 0.06796117 0.2000000

さらに,加工する。

cross.tab <- tab.40.df.2 %>% 
  gt(groupname_col = "agegroup") %>%
  fmt_number(
    columns = c(3:5),
    rows = c(1, 4, 7, 10), # 1,4,7,10行目は実数
    decimals = 0) %>%
  fmt_number(
    columns = c(3:5),
    rows = c(2:3, 5:6, 8:9, 11:12), # 1,4,7,10行目以外は割合
    decimals = 2) %>%
  cols_label(
    agegroup = md("年齢"), 
    out    = ("")) %>%
  tab_spanner(label = "頻度", columns = c(3:5)) %>%
  cols_align(align = "left", columns = c(2)) %>%
  tab_options(table_body.hlines.width = 0, # tableの中の水平線は引かない
#  table.border.top.width = 0, #タイトルの上の線を消す,
#  table.border.bottom.width = 0, #注の下の線を消す
  heading.title.font.size = px(16), #タイトルのフォントサイズ
#  row_group.border.bottom.width = 0, #セクション名の下の線を消す
#  stub.border.width = 0,
  column_labels.border.top.width = 3, # 変数名の行の線
  column_labels.border.top.color = "black", 
  column_labels.border.bottom.width = 2, # 変数名の行の線
  column_labels.border.bottom.color = "black", 
  table_body.border.bottom.color = "black", #テーブルの下線を黒く
  row_group.border.top.color = "black", #セクション名の上の線を黒
  row_group.border.top.width = 1, #セクション名の上の線を細く
  row_group.border.bottom.color = "white", #セクション名の上の線を消す
  row_group.border.bottom.width = 1, #セクション名の上の線を細く
  table.border.top.width = 0, #タイトルの上の線はなし
  table.width = pct(30)) %>% 
tab_header(title = md("**Table 2**<br>年齢となんとかの頻度の関係")) %>%
  tab_style(
  style=cell_text(align="left"),
  locations = cells_title("title")
  ) 

cross.tab
Table 2
年齢となんとかの頻度の関係
頻度
全く 時々 頻繁
20代
度数 25 33 22
行の割合 0.31 0.41 0.28
列の割合 0.26 0.32 0.22
30代
度数 30 29 31
行の割合 0.33 0.32 0.34
列の割合 0.31 0.28 0.31
40代
度数 27 34 27
行の割合 0.31 0.39 0.31
列の割合 0.28 0.33 0.27
50代以上
度数 15 7 20
行の割合 0.36 0.17 0.48
列の割合 0.15 0.07 0.20

pdfで保存できるのだが,print-readyにするには少し調整が必要だと思われる。 私の好みはTeX。

gtsave(cross.tab, "crosstab.pdf")
gtsave(cross.tab, "crosstab.tex")

TeX出力例

出力するには,プリアンブルに\usepackage{booktabs}と書く必要がある。

gtパッケージとしてはイタリックで指定した部分が 下線になってしまうので, 生成されたTeXファイルを少々いじる必要がありそうです。