廿TT

譬如水怙牛過窓櫺 頭角四蹄都過了 因甚麼尾巴過不得

ggplot2 でミニ棒グラフ行列を描画する geom_barmatrix を書きました

今日の川柳

library(tidyverse)
geom_barmatrix <- function(mapping = NULL, data = NULL,
                           stat = "identity",position ="identity",
                           ...,
                           width = NULL,
                           binwidth = NULL,
                           na.rm = FALSE,
                           show.legend = NA,
                           inherit.aes = TRUE) {
  
  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomBarmatrix,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      width = width,
      na.rm = na.rm,
      ...
    )
  )
}

GeomBarmatrix <- ggproto("GeomBarmatrix", GeomRect,
                         required_aes = c("x", "y","inner_y"),
                         
                         setup_data = function(data, params) {
                           data$width <- data$width %||%
                             params$width %||% (resolution(data$x, FALSE) * 0.9)
                           transform(data,
                                     ymin = y, ymax = y+0.9*inner_y/max(inner_y)*min(diff(unique(sort(y)))),
                                     xmin = x - width / 2, xmax = x + width / 2, width = NULL
                           )
                         },
                         
                         draw_panel = function(data, panel_params, coord, width = NULL) {
                           GeomRect$draw_panel(data, panel_params, coord)
                         })

geom_barmatrixframe <- function(mapping = NULL, data = NULL,
                                stat = "identity",position ="identity",
                                ...,
                                width = NULL,
                                binwidth = NULL,
                                na.rm = FALSE,
                                show.legend = NA,
                                inherit.aes = TRUE) {
  
  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomBarmatrixframe,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      width = width,
      na.rm = na.rm,
      ...
    )
  )
}

GeomBarmatrixframe <- ggproto("GeomBarmatrixframe", GeomRect,
                              required_aes = c("x", "y"),
                              default_aes = aes(colour = "Black", fill = NA, size = 0.5, linetype = 1,
                                                alpha = NA),
                              
                              setup_data = function(data, params) {
                                data$width <- data$width %||%
                                  params$width %||% (resolution(data$x, FALSE) * 0.9)
                                transform(data,
                                          ymin = y, ymax = y+0.9*min(diff(unique(sort(y)))),
                                          xmin = x - width / 2, xmax = x + width / 2, 
                                          width = NULL)
                                
                              },
                              
                              draw_panel = function(data, panel_params, coord, width = NULL) {
                                GeomRect$draw_panel(data, panel_params, coord)
                              })

以下、デモです。

総務省労働力調査「第12表 年齢階級別就業者数」と「第13表 年齢階級別完全失業者数」を使います。

統計局ホームページ/労働力調査(基本集計) 平成30年(2018年)4月分結果

そのままの形式だと扱いにくかったので加工したファイルを置いておきます。

https://gist.github.com/abikoushi/f565a3bdce8490a82cee22de6577217f

年代、性別、年ごとの就業者数のグラフです。太い棒の高さが就業者数です。

f:id:abrahamcow:20180616073434p:plain

shitsugyo_and_shugyo_shasu <-read.csv("shitsugyo_and_shugyo_shasu.csv")
ggplot(shitsugyo_and_shugyo_shasu,aes(x=age,y=year,inner_y=shugyo))+
  geom_barmatrix()+
  facet_wrap(~sex)+
  theme_bw()

枠がついていたほうが見やすいかなと思って geom_barmatrixframe も書きました。

geom_barmatrixframe を足してやるとこうなります。

f:id:abrahamcow:20180616073759p:plain

(なんかコップに黒い液体が満たされているように見える)

ggplot(shitsugyo_and_shugyo_shasu,aes(x=age,y=year,inner_y=shugyo))+
  geom_barmatrixframe()+
  geom_barmatrix()+
  facet_wrap(~sex)+
  theme_bw(base_family = "Osaka")

棒の色で失業率も表すと4次元棒グラフが出来上がります。

f:id:abrahamcow:20180616073948p:plain

ggplot(shitsugyo_and_shugyo_shasu,aes(x=age,y=year,inner_y=shugyo))+
  geom_barmatrix(aes(fill=shitsugyo/(shugyo+shitsugyo)))+
  geom_barmatrixframe()+
  scale_fill_continuous(labels=scales::percent)+
  facet_wrap(~sex)+
  labs(fill="失業率")+
  theme_bw(base_family="Osaka")

枠とっちゃって x 軸を連続量っぽく見せる手もあります。

f:id:abrahamcow:20180616165617p:plain

ggplot(shitsugyo_and_shugyo_shasu,aes(x=age,y=year,inner_y=shugyo))+
  geom_barmatrix(aes(fill=shitsugyo/(shugyo+shitsugyo)),width = 1)+
  scale_fill_continuous(labels=scales::percent)+
  facet_wrap(~sex)+
  labs(fill="失業率")+
  theme_bw(base_family="Osaka")
  • 積み上げ棒グラフにも対応したい
  • 内側にも小さい y 軸をつけたい

けどどうやればいいかわからない。教えていただけると嬉しいです。