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")
出力するには,プリアンブルに\usepackage{booktabs}
と書く必要がある。
gtパッケージとしてはイタリックで指定した部分が 下線になってしまうので, 生成されたTeXファイルを少々いじる必要がありそうです。