第2章 数量を把握するデータ可視化

図の右上のshowボタンを押すとRのコードが表示されます。

2.1 数量と図形の大きさを紐づける

2.1.1 図形の大きさと数量を紐づける

library(conflicted)
library(tidyverse)
library(ggpubr)

label <- c("支持する", "支持しない", "どちらとも\nいえない", "無回答")
data.frame(
  label=factor(label, levels = rev(label)),
  data=c(40, 32, 25, 3)
  ) |>
  ggdonutchart(
    x = "data",
    label = "label",
    fill = "label",
    palette = c("darkgray", "lightgray", "red", "blue")
    ) +
  theme(legend.position = "none")

2.1.2 ワードクラウドを用いた「頻度と見た目の大きさ」の紐づけ

ストップワードが違うようで、全く一緒にはならないです。

library(conflicted)
library(tidyverse)
library(tidytext)
library(wordcloud2)

# テキストデータ
df <- data.frame(
  text = "Clustering coefficients for correlation networks, Energy landscape analysis of neuroimaging data, Simulation of space acquisition process of pedestrians using proxemic floor field model, Pedestrian flow through multiple bottlenecks, Closer to critical resting-state neural dynamics in individuals with higher fluid intelligence, Reinforcement learning explains conditional cooperation and its moody cousin, Jam-absorption driving with a car-following model, Age‐related changes in the ease of dynamical transitions in human brain activity, Potential global jamming transition in aviation networks, Methodology and theoretical basis of forward genetic screening for sleep/wakefulness in mice, Jamming transitions in force-based models for pedestrian dynamics, Inflow process of pedestrians to a confined space, Exact solution of a heterogeneous multilane asymmetric simple exclusion process, Exact stationary distribution of an asymmetric simple exclusion process with Langmuir kinetics and memory reservoirs, Taming macroscopic jamming in transportation networks, A demonstration experiment of a theory of jam-absorption driving, A balance network for the asymmetric simple exclusion process, Reinforcement learning account of network reciprocity, Towards understanding network topology and robustness of logistics systems, Inflow process: A counterpart of evacuation, Analysis on a single segment of evacuation network, Dynamics of assembly production flow, Presynaptic inhibition of dopamine neurons controls optimistic bias, Bridging the micro-macro gap between single-molecular behavior and bulk hydrolysis properties of cellulase, Cluster size distribution in 1D-CA traffic models, Modelling state‐transition dynamics in resting‐state brain signals by the hidden Markov and Gaussian mixture models, Positive congestion effect on a totally asymmetric simple exclusion process with an adsorption lane, Metastability in pedestrian evacuation, Constructing quantum dark solitons with stable scattering properties, The Autonomous Sensory Meridian Response Activates the Parasympathetic Nervous System, Trait, staging, and state markers of psychosis based on functional alteration of salience-related networks in the high-risk, first episode, and chronic stages, Critical brain dynamics and human intelligence, Influence of velocity variance of a single particle on cellular automaton models, Collective motion of oscillatory walkers, Reinforcing critical links for robust network logistics: A centrality measure for substitutability, Dynamic transitions between brain states predict auditory attentional fluctuations, Associations of conservatism/jumping to conclusions biases with aberrant salience and default mode network, Model retraining and information sharing in a supply chain with long-term fluctuating demands, Functional alterations of salience-related networks are associated with traits, staging, and the state of psychosis."
)

df |>
  unnest_tokens(word, text) |>
  count(word, sort = TRUE, name = "freq") |>
  anti_join(stop_words, by = join_by(word)) |>
  wordcloud2(shape = "square", shuffle = FALSE)

2.1.3 ツリーマップによるグループ情報の付与

library(conflicted)
library(tidyverse)
library(treemapify)
library(gapminder)
library(viridis)

# gapminderデータセットから2007年のデータを抽出
df <- gapminder |>
  dplyr::filter(year == 2007)

df |>
  ggplot(aes(area = pop, fill = lifeExp, label = country, subgroup = continent)) +
  geom_treemap() +
  geom_treemap_text(colour = "black", place = "topleft", reflow = TRUE) +
  geom_treemap_subgroup_border() +
  geom_treemap_subgroup_text(
    place = "centre", grow = TRUE, alpha = 0.6, colour = "black",
    fontface = "italic", min.size = 0
    ) +
  scale_fill_viridis(option = "turbo", direction = -1) +
#  scale_fill_gradient2(
#    low  = "red", mid  = "white", high = "blue", midpoint = mean(df$lifeExp)
#    ) +
  theme(aspect.ratio = 1/2)

2.2 大きさを比較する

2.2.1 棒グラフの例

library(conflicted)
library(tidyverse)
library(patchwork)

#データの定義
week <- c("月曜", "火曜", "水曜", "木曜", "金曜", "土曜", "日曜")
data <- data.frame(
  week = factor(week, levels = week),
  sales = c(30, 25, 35, 28, 22, 34, 35),
  card_member = c(20, 13, 20, 14, 14, 20, 25),
  non_member = c(10, 12, 15, 14, 8, 14, 10)
)

#基本的な棒グラフの作成
p1 <- data |>
  ggplot(aes(x = week, y = sales)) + 
  geom_col(fill = "blue") + 
  theme(axis.title.x = element_blank(), legend.position = "none") +
  labs(title = "基本的な棒グラフ",  x= "", y = "売上 [万円]")

#積み上げ棒グラフの作成
data_long <- data |>
  select(!sales) |>
  pivot_longer(!week, names_to = "membership", values_to = "sales")

p2 <- data_long |>
  ggplot(aes(x=week, y=sales, fill=membership)) +
  geom_col(position = "stack") + 
  theme(
    axis.title.x = element_blank(),
    legend.position = "none"
    ) +
  labs(y = "売上 [万円]", title = "積み上げ棒グラフ")

#水平棒グラフの作成
p3 <- data_long |>
  ggplot(aes(x=week, y=sales, fill=membership)) +
  geom_col(position = "dodge") + 
  coord_flip() + 
  theme(
    legend.title = element_blank(),
    legend.position = c(0.9, 0.2)
      ) +
  labs(y = "売上 [万円]", x = "", title = "水平棒グラフ／集団棒グラフ") +
  scale_fill_hue(name = "カード会員", labels = c(card_member = "カード会員", non_member ="非会員") )

#プロットの並べ方設定
(p1 + p2) / p3

2.2.2 折れ線グラフの例

library(conflicted)
library(tidyverse)
library(patchwork)

week <- c("月曜日", "火曜日", "水曜日", "木曜日", "金曜日", "土曜日", "日曜日")
set.seed(0)
data.frame(
  曜日 = factor(week, levels = week),
  Aさん = rnorm(7, 36, 0.2),
  Bさん = rnorm(7, 36, 0.2)
  ) |>
  pivot_longer(!曜日) |>
  ggplot(aes(x=曜日, y = value, group = name, color = name, linetype = name, shape = name)) + 
  geom_line() +
  geom_point() + 
  theme(
    legend.title = element_blank(),
    legend.position = c(0.9, 0.8)
    ) +
    labs(y = "体温[℃]", title="折れ線グラフ") + 
  theme(aspect.ratio = 1/2)

2.2.3 見やすさのための折れ線グラフ

library(conflicted)
library(tidyverse)
library(patchwork)

people <- LETTERS[1:7]
set.seed(0)
df <- data.frame(
  人 = c(people, people),
  temp = rnorm(14, mean = 36.0, sd = 0.2),
  time_of_day = c(rep("夕方", 7), rep("早朝", 7))
  )

# マーカーのみの折れ線グラフをプロット
p1 <- df |>
  ggplot(aes(
    x = 人, y = temp, group = time_of_day, shape = time_of_day,
    color = time_of_day, linetype = time_of_day)) +
  geom_point() +
  labs(title = "マーカーのみプロット", x = "", y = "体温 [℃]" ) +
  theme(
    aspect.ratio = 1,
    legend.title = element_blank(),
    legend.position = c(0.8, 0.8)
    )

p2 <- p1 +
  geom_line() +
  labs(title = "見やすさのための補助の折れ線を追加")

p1 + p2

2.3 標本を視えるようにする

2.3.1 平均値の棒グラフの危険性

library(conflicted)
library(tidyverse)
library(patchwork)

p1 <- data.frame(
  x = c("商品1","商品2"),
  avg = c(100, 80)
  ) |>
  ggplot(aes(x = x, y = avg)) +
  geom_col(fill = c("blue","orange")) +
  theme(axis.title.x = element_blank()) +
  labs(y = "日別販売数（平均）", title = "平均値のみ比較") +
  coord_cartesian(ylim = c(0, 130))

# データの生成
n_small <- 30
n_large <- 4
set.seed(0)
df_small_var <- bind_rows(
  data.frame(
    商品 = rep("商品1", n_small),
    日別販売数 = rnorm(n_small, 100, 5) # 平均100、標準偏差5の正規分布に従う乱数を30個生成
    ), 
  data.frame(
    商品 = rep("商品2", n_small),
    日別販売数 = rnorm(n_small, 80, 5) # 平均80、標準偏差5の正規分布に従う乱数を30個生成
    )
  ) 

p2 <- df_small_var |>
  ggplot(aes(x=商品, y=日別販売数, color = 商品)) + 
  geom_jitter(width = 0.1, height = 0) +
  theme(
    axis.title.x = element_blank(),
    legend.position = "none"
    )+
  labs(title = "サンプルサイズ大\nばらつき小") +
  coord_cartesian(ylim = c(0, 130))

set.seed(1)
df_large_var <- bind_rows(
  data.frame(
    商品 = rep("商品1", n_large),
    日別販売数 = rnorm(n_large, 100, 20) # 平均100、標準偏差20の正規分布に従う乱数を4個生成
  ),
  data.frame(
    商品 = rep("商品2", n_large),
    日別販売数 = rnorm(n_large, 80, 20) # 平均80、標準偏差20の正規分布に従う乱数を4個生成
  )
)

p3 <- df_large_var |>
  ggplot(aes(x=商品, y=日別販売数, color = 商品)) + 
  geom_jitter(width = 0.1, height = 0) +
  theme(
    axis.title.x = element_blank(),
    legend.position = "none"
  )+
  labs(title = "サンプルサイズ小\nばらつき大") +
  coord_cartesian(ylim = c(0, 130))

p1 + p2 + p3

2.3.2 様々な標本の可視化

library(conflicted)
library(tidyverse)
library(ggbeeswarm)
library(patchwork)

num_samples <- 100 # サンプルサイズ
set.seed(0)
data <- data.frame(
  Value = c(
    rnorm(num_samples, 100, 10), # 平均100、標準偏差10の正規分布
    rnorm(num_samples, 80, 20)   # 平均80、標準偏差20の正規分布
    ),
  Category = c(
    rep("商品3", num_samples), 
    rep("商品4", num_samples)
    )
  )

# ggplot2の基本設定
plt <- data |>
  ggplot(aes(x=Category, y=Value)) +
  theme(
    axis.title.x = element_blank(),
    axis.title.y = element_blank(),
    legend.position = "none"
  )

# ストリッププロット (Dodge position)
p1 <- plt +
  geom_jitter(aes(color = Category), height = 0, width = 0.1)+
  scale_y_continuous(limits = c(0, 140)) +
  labs(title = "ストリッププロット")

# スウォームプロット
p2 <- plt +
  geom_beeswarm(aes(color = Category),cex = 3) +
  labs(title = "スウォームプロット")

# ヒストグラム
p3 <- data |>
  ggplot(aes(y=Value, fill=Category)) +
  geom_histogram(alpha=0.5, position='identity') +
  labs(title = "ヒストグラム") +
  theme(
    axis.title.x = element_blank(),
    axis.title.y = element_blank(),
    legend.title = element_blank(),
    legend.position = c(0.8, 0.8)
  )

# バイオリンプロット
p4 <- plt + 
  geom_violin(aes(fill = Category), trim=FALSE) +
  geom_boxplot(width = .1, fill = "gray", color="black")+
  stat_summary(fun = mean, geom = "point", 
               shape =16, size = 2, color = "red", alpha = 0.5)+
  scale_y_continuous(limits = c(0, 140))+
  labs(title = "バイオリンプロット")

# エラーバー付き棒グラフ
p5 <- plt +
  stat_summary(aes(fill = Category),fun = "mean", geom = "bar") +
  stat_summary(geom = "errorbar",
               fun.data = "mean_sdl",
               width = 0.1, color = "black") +
  scale_y_continuous(limits = c(0, 140))+
  labs(title = "エラーバー付き棒グラフ")

# 箱ひげ図
p6 <- plt +
  geom_boxplot(aes(fill = Category)) +
  scale_y_continuous(limits = c(0, 140))+
  labs(title = "箱ひげ図")

(p1 + p2 + p3) / (p4 + p5 + p6)

2.3.3 箱髭図の構成要素

library(conflicted)
library(tidyverse)
library(ggbeeswarm)

set.seed(0)
data.frame(
  Value = rnorm(100, mean=80, sd=20),
  Category = "商品4"
  ) |>
  ggplot(aes(x=Category, y=Value)) +
  geom_boxplot(fill = "orange", width = 0.5) +
  geom_beeswarm(shape = 21, cex = 3, fill = "orange", alpha=0.6) +
  coord_cartesian(ylim = c(0,140)) +
  labs(title = "箱髭図で表現されるデータの特徴") +
  theme(
    legend.position="none", 
    axis.title.x=element_blank(), 
    axis.title.y=element_blank()
    )

第2章はここまで。