分布を見る
イントロ
研究者向けにプロ野球のデータを使ってRとggplot2の使い方を紹介してます。もともとラボメンバーの興味を得るために野球データを使っていますが、打率、左打ち、チームなどの専門用語を適宜生物学的専門用語に脳内変換して眺めてください。今回は与えられたデータの分布を見ます。
目的
- ggplot2でヒストグラムかきます
- ggplot2で箱ひげ図かきます
- ggplot2で散布図かきます
- 散布図で点が重なるときの対策を講じます
プロ野球データ（打者）のデータをロードする
こちらのエントリで作成したプロ野球データの打者データを使っていきます。
打者のデータbatting.csvはこちらからダウンロードできます。
library(tidyverse)
# load data into memory
df <- read_csv(file.path("data", "batting.csv"))
## Parsed with column specification: ## cols( ## .default = col_double(), ## Name = col_character(), ## CS = col_logical(), ## GDP = col_logical(), ## IBB = col_logical(), ## League = col_character(), ## Team = col_character(), ## PlayerID = col_character(), ## Bats = col_character() ## )
## See spec(...) for full column specifications.
## Warning: 23681 parsing failures. ## row col expected actual file ## 1014 CS 1/0/T/F/TRUE/FALSE 4 'data/batting.csv' ## 1016 CS 1/0/T/F/TRUE/FALSE 11 'data/batting.csv' ## 1017 CS 1/0/T/F/TRUE/FALSE 3 'data/batting.csv' ## 1018 CS 1/0/T/F/TRUE/FALSE 3 'data/batting.csv' ## 1019 CS 1/0/T/F/TRUE/FALSE 2 'data/batting.csv' ## .... ... .................. ...... .................. ## See problems(...) for more details.
おそらく似たような警告が出ているのではないでしょうか。これは、read_csvがファイルから読み出すときに、各カラムごとに自動的に「型」を判断するのですが、デフォルトだと最初の1000行を使うから生じた警告です。なので、そのあたりを考慮すれば警告なしにデータを読み込めます。
# this column should be an intger, but it's not. is(df$CS)
## [1] "logical" "vector"
# read_csv guesses the column types from the first guess_max rows.
# The default guess_max is 1000, which is not enough to reach to
# the meaningful row in CS column starting from row 1014.
# Let's get the line number of batting.csv
R.utils::countLines(file.path("data","batting.csv"))
## [1] 31080 ## attr(,"lastLineHasNewline") ## [1] TRUE
# and give a larger number for guessing.
df <- read_csv(file.path("data", "batting.csv"), guess_max = 30000)
## Parsed with column specification: ## cols( ## .default = col_double(), ## Name = col_character(), ## League = col_character(), ## Team = col_character(), ## PlayerID = col_character(), ## Bats = col_character() ## )
## See spec(...) for full column specifications.
df
## # A tibble: 31,079 x 31 ## Rk Name Age G PA AB R H `2B` `3B` HR RBI SB ## <dbl> <chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> ## 1 1 Yosh… 17 5 3 2 1 2 0 0 0 1 0 ## 2 2 Chuj… 18 7 27 24 2 5 1 0 0 3 1 ## 3 3 Junz… 21 14 66 49 3 10 1 0 0 4 2 ## 4 4 Kats… 29 5 14 13 3 4 0 0 0 3 1 ## 5 5 Eiji… 19 9 34 28 4 7 0 0 0 3 0 ## 6 6 Take… 26 13 59 51 5 11 0 0 0 6 1 ## 7 7 Kazu… 19 14 69 60 7 13 4 0 0 5 3 ## 8 8 Hisa… 17 7 15 10 1 2 1 0 0 1 0 ## 9 9 Nori… 25 14 67 59 6 15 0 2 0 7 2 ## 10 10 Yuki… 25 12 33 29 2 6 0 0 0 4 0 ## # … with 31,069 more rows, and 18 more variables: CS <dbl>, BB <dbl>, ## # SO <dbl>, BA <dbl>, OBP <dbl>, SLG <dbl>, OPS <dbl>, TB <dbl>, GDP <dbl>, ## # HBP <dbl>, SH <dbl>, SF <dbl>, IBB <dbl>, League <chr>, Team <chr>, ## # Year <dbl>, PlayerID <chr>, Bats <chr>
はい。今度は警告なしに読めましたね。
年齢分布
それでは、さっそく打者の年齢の分布を見ていきましょう。
# basic stuff summary(df$Age)
## Min. 1st Qu. Median Mean 3rd Qu. Max. NA's ## 16.00 23.00 26.00 26.82 30.00 48.00 1
# histogram ggplot(df) + geom_histogram(aes(x = Age), binwidth = 1)
## Warning: Removed 1 rows containing non-finite values (stat_bin).
80年分のデータですが、それっぽい分布だと思います。
次はチームごとの年齢分布を見てみましょう。
# boxplots over teams ggplot(df) + geom_boxplot(aes(x = Age, y = Team)) + scale_y_discrete(limits = rev(unique(sort(df$Team))))
## Warning: Removed 1 rows containing non-finite values (stat_boxplot).
いろんなことが見えてきますね。チームによっては40代後半の選手がぱらぱらと在籍してますね。ぱっとみると南海あたりがいちばん年齢分布が若そうですが、、、並べ替えてみましょう。
# boxplots over teams in median-age-order team_order<-df%>% group_by(Team)%>% summarize(median = median(Age, na.rm = TRUE))%>% arrange(median, Team)%>% select(Team)%>% unlist() ggplot(df) + geom_boxplot(aes(x = Age, y = Team)) + scale_y_discrete(limits = rev(team_order))
## Warning: Removed 1 rows containing non-finite values (stat_boxplot).
一番若いのは大東京軍、黒鷲軍、そして南海ですね。大東京軍は実は大洋ホエールズの一部だったんですね。親近感わきます。
今度は個別の選手を見てみましょう。
df%>% arrange(desc(Age))%>% select(Name, Age, Team, Year)%>% print(n = 20)
## # A tibble: 31,079 x 4 ## Name Age Team Year ## <chr> <dbl> <chr> <dbl> ## 1 Shinji Hamasaki* 48 Hankyu Braves 1950 ## 2 Masahiro Yamamoto* 48 Chunichi Dragons 2014 ## 3 Yoshio Yuasa 47 Mainichi Orions 1950 ## 4 Masahiro Yamamoto* 47 Chunichi Dragons 2013 ## 5 Shinji Hamasaki* 46 Hankyu Braves 1948 ## 6 Kimiyasu Kudo* 46 Yokohama Bay Stars 2009 ## 7 Masahiro Yamamoto* 46 Chunichi Dragons 2012 ## 8 Shinji Hamasaki* 45 Hankyu Braves 1947 ## 9 Tadashi Wakabayashi? 45 Mainichi Orions 1953 ## 10 Yoshiyuki Iwamoto 45 Toei Flyers 1957 ## 11 Katsuya Nomura 45 Seibu Lions 1980 ## 12 Toru Nimura 45 Chiba Lotte Marines 1997 ## 13 Kimiyasu Kudo* 45 Yokohama Bay Stars 2008 ## 14 Fumio Ono 44 Tokyu Flyers 1949 ## 15 Yoshiyuki Iwamoto 44 Toei Flyers 1956 ## 16 Katsuya Nomura 44 Seibu Lions 1979 ## 17 Hiromitsu Kadota* 44 Fukuoka Daiei Hawks 1992 ## 18 Toru Nimura 44 Chiba Lotte Marines 1996 ## 19 Hiromitsu Ochiai 44 Nippon Ham Fighters 1998 ## 20 Kimiyasu Kudo* 44 Yokohama Bay Stars 2007 ## # … with 31,059 more rows
レジェンドばかりです・・・。ヤママサもすごいが、浜崎真二選手もすごい！45歳で選手兼総監督としてプロ野球に入団したらしいです・・・。今の自分よりも年上。
次は年代別に見ていきましょう。
# boxplots over years ggplot(df) + geom_boxplot(aes(x = Age, y = factor(Year))) + scale_y_discrete(limits = rev(unique(sort(factor(df$Year)))))
## Warning: Removed 1 rows containing non-finite values (stat_boxplot).
もう少し視覚に訴えるために、箱ひげ図ではなく、散布図にしてみましょう。
# scatter plot, Age x Year, #1
ggplot(df) +
geom_point(aes(x = Age, y = Year), size = 1) +
scale_y_reverse(expand=c(0,0),
breaks = function(x){scales::breaks_width(10)(c(min(x), max(x)))})
## Warning: Removed 1 rows containing missing values (geom_point).
なんだか点が少ないですね。3万人以上のデータがあるはずなんですが、こんなに少なく見えるのは、今回のような整数のデータの散布図だと、1つの座標に何個もデータがかぶることがあるからです。点が1個しかなくても、100個あっても、同じように見えてしまいます。そこで、geom_jitterを使うと見やすくなります。
# jitter plot, Age x Year
ggplot(df) +
geom_jitter(aes(x = Age, y = Year),
width = 0.5, height = 0.3, size = 1, alpha = 0.3, shape = 16) +
scale_y_reverse(expand=c(0,0),
breaks = function(x){scales::breaks_width(10)(c(min(x), max(x)))})
## Warning: Removed 1 rows containing missing values (geom_point).
戦時中の隙間がその後数年も影を引いているのがよくわかります。。。
点の重なりを解消する他の方法としては、密度に変換する方法もあります。
# density_2d #1, Age x Year
ggplot(df) +
stat_density_2d(aes(x = Age, y = Year, fill = after_stat(density)),
geom = "raster", contour = FALSE) +
scale_x_continuous(expand = c(0,0)) +
scale_y_reverse(expand=c(0,0),
breaks = function(x){scales::breaks_width(10)(c(min(x), max(x)))}) +
scale_fill_distiller("Density", palette = "Spectral")
## Warning: Removed 1 rows containing non-finite values (stat_density2d).
あるいは、こんなこともできます。
# density_2d #2, Age x Year
ggplot(df) +
stat_density_2d(aes(x = Age, y = Year, size = after_stat(density)),
geom = "point", n=30, contour = FALSE) +
scale_x_continuous(expand=c(0,0)) +
scale_y_reverse(expand=c(0,0),
breaks = function(x){scales::breaks_width(10)(c(min(x), max(x)))})
## Warning: Removed 1 rows containing non-finite values (stat_density2d).
打席の位置（左・右・スイッチ）
スイッチヒッターはいつの時代も憧れだと思います。実際に昔からスイッチの選手はどのくらいいたのでしょうか？さっそくみてみましょう。なお、同じ選手が年ごとに登録されているので、1選手を1カウントとするためにBatsとPlayerIDでuniqueを通しています。同じ選手が年によって異なる登録をしているとダブりますが。
# extract the batting stance info
batting_stances <- c("right", "left", "both", "unknown")
df2 <- df%>%
select(Bats, PlayerID)%>%
unique()%>%
mutate(Bats = factor(Bats, batting_stances))
# count players who regsitered multiple batting-stances
df2%>%
group_by(PlayerID)%>%
summarize(n=n())%>%
filter(n>1)
## # A tibble: 0 x 2 ## # … with 2 variables: PlayerID <chr>, n <int>
ダブってませんね。では、とりあえず数を見てみましょう。
# basic stuff ggplot(df2) + geom_bar(aes(x = Bats))
全体的に右が多いのは納得ですね。それではさっそくチーム別にみてみましょう。
# distribution over teams, #1 df2 <- df%>% mutate(Bats = factor(Bats, batting_stances)) ggplot(df2) + geom_bar(aes(y = Team, fill = Bats)) + scale_fill_brewer(palette = "Set1") + scale_x_continuous(expand=c(0,0)) + scale_y_discrete(limits = rev(unique(sort(df$Team))))
# distribution over teams, #2
ggplot(df2) +
geom_histogram(aes(x = Team, fill = Bats), stat="count", position="fill") +
scale_fill_brewer(palette = "Set1") +
scale_y_discrete("Ratio", expand=c(0,0)) +
scale_x_discrete(limits = rev(unique(sort(df$Team)))) +
coord_flip()
## Warning: Ignoring unknown parameters: binwidth, bins, pad
我らがホエールズの誇るスイッチヒッターを列挙しておきます。
df2%>% filter(str_detect(Team, "(Taiyo|Bay)"), Bats=="both")%>% select(Name, Team)%>% unique()%>% print(n=30)
## # A tibble: 29 x 2 ## Name Team ## <chr> <chr> ## 1 Chikara Morinaka# Taiyo Whales ## 2 Kaname Yashiki# Yokohama Taiyo Whales ## 3 Yutaka Takagi# Yokohama Taiyo Whales ## 4 Mark Budaska# Yokohama Taiyo Whales ## 5 Hirokazu Kato# Yokohama Taiyo Whales ## 6 Leon Lee# Yokohama Taiyo Whales ## 7 Koichi Muraoka# Yokohama Taiyo Whales ## 8 Masahiro Takahashi# Yokohama Taiyo Whales ## 9 Jerry White# Yokohama Taiyo Whales ## 10 Takashi Okawa# Yokohama Taiyo Whales ## 11 R.J. Reynolds# Yokohama Taiyo Whales ## 12 Takashi Okawa# Yokohama Bay Stars ## 13 Yutaka Takagi# Yokohama Bay Stars ## 14 Masahiro Takahashi# Yokohama Bay Stars ## 15 Kaname Yashiki# Yokohama Bay Stars ## 16 Tomo Ohka# Yokohama Bay Stars ## 17 Yuichi Furukawa# Yokohama Bay Stars ## 18 Kiyoshi Arai# Yokohama Bay Stars ## 19 Tatsuhiko Kinjo# Yokohama Bay Stars ## 20 Daisuke Kanda# Yokohama Bay Stars ## 21 Kazunori Tanaka# Yokohama Bay Stars ## 22 Cedrick Bowers# Yokohama Bay Stars ## 23 Marc Kroon# Yokohama Bay Stars ## 24 Daisuke Hayakawa# Yokohama Bay Stars ## 25 Kensuke Uchimura# Yokohama Bay Stars ## 26 Kazuki Mishima# Yokohama Bay Stars ## 27 Masashi Nishimori# Yokohama Bay Stars ## 28 Hiroki Minei# Yokohama Bay Stars ## 29 Elian Herrera# Yokohama Bay Stars
スーパーカートリオがきちんと入ってますね。そして、三嶋一輝選手がスイッチであることや、このデータからは全くわかりませんが、彼が周船寺小学校出身であることを知りました。テンション上がります。
次は年代ごとの分布を見ていきましょう。
# distribution over time, #1
ggplot(df2) +
geom_bar(aes(y = Year, fill = Bats)) +
scale_fill_brewer(palette = "Set1") +
scale_x_continuous(expand = c(0,0)) +
scale_y_reverse(expand = c(0,0),
breaks = function(x){scales::breaks_width(10)(c(min(x), max(x)))})
# distribution over time, #2
ggplot(df2) +
geom_histogram(aes(x = Year, fill = Bats), stat="count", position="fill") +
scale_fill_brewer(palette = "Set1") +
scale_y_discrete("Ratio", expand=c(0,0)) +
scale_x_reverse(expand=c(0,0),
breaks = function(x){scales::breaks_width(10)(c(min(x), max(x)))}) +
coord_flip()
## Warning: Ignoring unknown parameters: binwidth, bins, pad
これをみると、左バッターが徐々に増えていること、スイッチは60年代以降に増えてきたが、ピークは90年代あたりということがわかります。
sessioninfo::session_info(c("tidyverse"))
## ─ Session info ─────────────────────────────────────────────────────────────── ## setting value ## version R version 3.6.3 (2020-02-29) ## os macOS Mojave 10.14.6 ## system x86_64, darwin15.6.0 ## ui RStudio ## language (EN) ## collate ja_JP.UTF-8 ## ctype ja_JP.UTF-8 ## tz Asia/Tokyo ## date 2020-05-18 ## ## ─ Packages ─────────────────────────────────────────────────────────────────── ## package * version date lib source ## askpass 1.1 2019-01-13 [1] CRAN (R 3.6.0) ## assertthat 0.2.1 2019-03-21 [1] CRAN (R 3.6.0) ## backports 1.1.6 2020-04-05 [1] CRAN (R 3.6.2) ## base64enc 0.1-3 2015-07-28 [1] CRAN (R 3.6.0) ## BH 1.72.0-3 2020-01-08 [1] CRAN (R 3.6.0) ## broom 0.5.6 2020-04-20 [1] CRAN (R 3.6.2) ## callr 3.4.3 2020-03-28 [1] CRAN (R 3.6.2) ## cellranger 1.1.0 2016-07-27 [1] CRAN (R 3.6.0) ## cli 2.0.2 2020-02-28 [1] CRAN (R 3.6.0) ## clipr 0.7.0 2019-07-23 [1] CRAN (R 3.6.0) ## colorspace 1.4-1 2019-03-18 [1] CRAN (R 3.6.0) ## crayon 1.3.4 2017-09-16 [1] CRAN (R 3.6.0) ## curl 4.3 2019-12-02 [1] CRAN (R 3.6.0) ## DBI 1.1.0 2019-12-15 [1] CRAN (R 3.6.0) ## dbplyr 1.4.3 2020-04-19 [1] CRAN (R 3.6.2) ## desc 1.2.0 2018-05-01 [1] CRAN (R 3.6.0) ## digest 0.6.25 2020-02-23 [1] CRAN (R 3.6.0) ## dplyr * 0.8.5 2020-03-07 [1] CRAN (R 3.6.0) ## ellipsis 0.3.0 2019-09-20 [1] CRAN (R 3.6.0) ## evaluate 0.14 2019-05-28 [1] CRAN (R 3.6.0) ## fansi 0.4.1 2020-01-08 [1] CRAN (R 3.6.0) ## farver 2.0.3 2020-01-16 [1] CRAN (R 3.6.0) ## forcats * 0.5.0 2020-03-01 [1] CRAN (R 3.6.0) ## fs 1.4.1 2020-04-04 [1] CRAN (R 3.6.3) ## generics 0.0.2 2018-11-29 [1] CRAN (R 3.6.0) ## ggplot2 * 3.3.0 2020-03-05 [1] CRAN (R 3.6.0) ## glue 1.4.0 2020-04-03 [1] CRAN (R 3.6.1) ## gtable 0.3.0 2019-03-25 [1] CRAN (R 3.6.0) ## haven 2.2.0 2019-11-08 [1] CRAN (R 3.6.0) ## highr 0.8 2019-03-20 [1] CRAN (R 3.6.0) ## hms 0.5.3 2020-01-08 [1] CRAN (R 3.6.0) ## htmltools 0.4.0 2019-10-04 [1] CRAN (R 3.6.0) ## httr 1.4.1 2019-08-05 [1] CRAN (R 3.6.0) ## isoband 0.2.1 2020-04-12 [1] CRAN (R 3.6.2) ## jsonlite 1.6.1 2020-02-02 [1] CRAN (R 3.6.0) ## knitr * 1.28 2020-02-06 [1] CRAN (R 3.6.0) ## labeling 0.3 2014-08-23 [1] CRAN (R 3.6.0) ## lattice 0.20-41 2020-04-02 [1] CRAN (R 3.6.3) ## lifecycle 0.2.0 2020-03-06 [1] CRAN (R 3.6.0) ## lubridate 1.7.8 2020-04-06 [1] CRAN (R 3.6.2) ## magrittr 1.5 2014-11-22 [1] CRAN (R 3.6.0) ## markdown * 1.1 2019-08-07 [1] CRAN (R 3.6.0) ## MASS 7.3-51.6 2020-04-26 [1] CRAN (R 3.6.2) ## Matrix 1.2-18 2019-11-27 [1] CRAN (R 3.6.3) ## mgcv 1.8-31 2019-11-09 [1] CRAN (R 3.6.3) ## mime 0.9 2020-02-04 [1] CRAN (R 3.6.0) ## modelr 0.1.7 2020-04-30 [1] CRAN (R 3.6.2) ## munsell 0.5.0 2018-06-12 [1] CRAN (R 3.6.0) ## nlme 3.1-147 2020-04-13 [1] CRAN (R 3.6.2) ## openssl 1.4.1 2019-07-18 [1] CRAN (R 3.6.0) ## pillar 1.4.4 2020-05-05 [1] CRAN (R 3.6.3) ## pkgbuild 1.0.8 2020-05-07 [1] CRAN (R 3.6.3) ## pkgconfig 2.0.3 2019-09-22 [1] CRAN (R 3.6.0) ## pkgload 1.0.2 2018-10-29 [1] CRAN (R 3.6.0) ## plogr 0.2.0 2018-03-25 [1] CRAN (R 3.6.0) ## plyr 1.8.6 2020-03-03 [1] CRAN (R 3.6.0) ## praise 1.0.0 2015-08-11 [1] CRAN (R 3.6.0) ## prettyunits 1.1.1 2020-01-24 [1] CRAN (R 3.6.0) ## processx 3.4.2 2020-02-09 [1] CRAN (R 3.6.0) ## progress 1.2.2 2019-05-16 [1] CRAN (R 3.6.0) ## ps 1.3.2 2020-02-13 [1] CRAN (R 3.6.0) ## purrr * 0.3.4 2020-04-17 [1] CRAN (R 3.6.2) ## R6 2.4.1 2019-11-12 [1] CRAN (R 3.6.0) ## RColorBrewer 1.1-2 2014-12-07 [1] CRAN (R 3.6.0) ## Rcpp 1.0.4.6 2020-04-09 [1] CRAN (R 3.6.3) ## readr * 1.3.1 2018-12-21 [1] CRAN (R 3.6.0) ## readxl 1.3.1 2019-03-13 [1] CRAN (R 3.6.0) ## rematch 1.0.1 2016-04-21 [1] CRAN (R 3.6.0) ## reprex 0.3.0 2019-05-16 [1] CRAN (R 3.6.0) ## reshape2 1.4.4 2020-04-09 [1] CRAN (R 3.6.2) ## rlang 0.4.6 2020-05-02 [1] CRAN (R 3.6.2) ## rmarkdown * 2.1 2020-01-20 [1] CRAN (R 3.6.0) ## rprojroot 1.3-2 2018-01-03 [1] CRAN (R 3.6.0) ## rstudioapi 0.11 2020-02-07 [1] CRAN (R 3.6.0) ## rvest 0.3.5 2019-11-08 [1] CRAN (R 3.6.0) ## scales 1.1.0 2019-11-18 [1] CRAN (R 3.6.0) ## selectr 0.4-2 2019-11-20 [1] CRAN (R 3.6.1) ## stringi 1.4.6 2020-02-17 [1] CRAN (R 3.6.0) ## stringr * 1.4.0 2019-02-10 [1] CRAN (R 3.6.0) ## sys 3.3 2019-08-21 [1] CRAN (R 3.6.0) ## testthat 2.3.2 2020-03-02 [1] CRAN (R 3.6.0) ## tibble * 3.0.1 2020-04-20 [1] CRAN (R 3.6.2) ## tidyr * 1.0.3 2020-05-07 [1] CRAN (R 3.6.3) ## tidyselect 1.0.0 2020-01-27 [1] CRAN (R 3.6.0) ## tidyverse * 1.3.0 2019-11-21 [1] CRAN (R 3.6.0) ## tinytex 0.22 2020-04-17 [1] CRAN (R 3.6.2) ## utf8 1.1.4 2018-05-24 [1] CRAN (R 3.6.0) ## vctrs 0.2.4 2020-03-10 [1] CRAN (R 3.6.0) ## viridisLite 0.3.0 2018-02-01 [1] CRAN (R 3.6.0) ## whisker 0.4 2019-08-28 [1] CRAN (R 3.6.0) ## withr 2.2.0 2020-04-20 [1] CRAN (R 3.6.2) ## xfun 0.13 2020-04-13 [1] CRAN (R 3.6.2) ## xml2 1.3.2 2020-04-23 [1] CRAN (R 3.6.2) ## yaml 2.2.1 2020-02-01 [1] CRAN (R 3.6.0) ## ## [1] /Library/Frameworks/R.framework/Versions/3.6/Resources/library