昨日の記事の続編ですが、昨日の記事のことは忘れていいです。
gghighlightについて
グラフ作りにおいて、必要な情報だけを色付けてくれるパッケージ(yutannihilation氏作)
http://notchained.hatenablog.com/entry/2017/09/29/212444
library(ggplot2)
library(gghighlight)
gghighlight_point(iris, aes(x = Sepal.Length, y = Sepal.Width, color = Species), Species == 'setosa', use_direct_label = FALSE)
ただし、
- 限られたgeomにしか使えない
- highlightはaesthenticsになっていない
といった課題がある。
前者についてはggplot_add()の登場によって解決できる見通しっぽい。
https://yutani.rbind.io/post/2017-11-07-ggplot-add/
でも実は既にあるggplot2の実装で両方解決できるんじゃね?
と思ったので試してみました。
だいたいのgeomに対応できました。
多分geom_smooth以外。
geom_quantileはいけた。
以下はggprotoの知識が必要です。
yutannihilation氏のExtending ggplot2(和訳)を理解して下さい。
https://qiita.com/yutannihilation/items/f30baef75a0ac02bb2f0
練習
散布図のhighlight(hl)したい点だけを描写するgeom_point_hlを作ってみる。
ggplotでは、与えられたデータに対して、様々な演算を行っています。
例えばgeom_boxplotではデータに対して、分位点や外れ値を計算し、使いやすいデータに整形した上で、プロットしています。
計算の仕方はgeom_*(stat = 'hogehoge')というstat引数で指定されています(geom_pointなら'identity', geom_boxplotなら'boxplot)。
この使いやすいデータに整形というところがミソで、オリジナルの計算方法を定義し、statに指定すれば、いらないデータを削ることが可能です。
では散布図の審美的属性(aethentics; aes)にhighlightを追加して、highlightにTRUEが指定されている値のみをプロットするようにしてみましょう。
# 計算方法を定義
# ggprotoによるStatの作成
StatPointHL <- ggproto(
'StatPointHL', #新しいstatのクラス名
Stat, #継承したいggprotoオブジェクト
compute_group = #グループごとに必要な情報以外を消す
function(data, ...) data[data$highlight, ],
required_aes = c('x', 'y', 'highlight') #審美的属性には散布図に必要なxとy以外に、強調したいデータかをTRUE/FALSEで示すhighlightを追加
)
# geom_point_hlを作成
geom_point_hl <- geom_point # geom_pointをコピーして
formals(geom_point_hl)$stat <- StatPointHL #stat引数を上書き
# プロットしてみる
ggplot(iris, aes(x = Sepal.Length, y = Sepal.Width, color = Species, highlight = Species == 'setosa')) +
geom_point_hl()
irisのsetosa種についてのみのプロットが得られました。
boxplotについてhighlightしたいものだけ描写する
さて、実際にはboxplotなどでは複雑な計算が行われているのは既知の通り。
ということは、StatBoxplotHLを作ろうとすると、compute_groupで、データのフィルタリングと演算両方を定義しなければなりません。
これはコードが長くなりかねない…………!
というか、既に演算方法については決めてあるので、これをコピペするのも愚かです。
例えばStatBoxplotのcompute_groupはStatBoxplot$compute_groupで取り出すことができます。
StatBoxplot$compute_group
それなら、適宜削ったデータを、親のcompute_groupに渡せばOKですね。
function(data, ...) StatBoxplot$compute_group(data = data[data$highlight, ], ...)
実際にはcompute_layerやcompute_panelも使われることがあるはずなので、これらもついでにwrapしましょう。
先の例ではgeom_point_hlを作りましたが、実際には、stat引数を調整するだけでいいので、その場限りの利用であれば、geom_boxplot_hlを作る必要はありません。
#計算方法の定義
StatBoxplotHL <- ggproto(
'StatBoxplotHL', #新しいstatのクラス名
StatBoxplot, #継承したいggprotoオブジェクト
compute_group = #グループごとに必要な情報以外を消す
function(data, ...) StatBoxplot$compute_group(data = data[data$highlight, ], ...),
compute_layer = #レイヤに必要な情報以外を消す
function(data, ...) StatBoxplot$compute_layer(data = data[data$highlight, ], ...),
compute_panel = #パネルに必要な情報以外を消す
function(data, ...) StatBoxplot$compute_panel(data = data[data$highlight, ], ...),
required_aes = c('x', 'y', 'highlight') #審美的属性には散布図に必要なxとy以外に、強調したいデータかをTRUE/FALSEで示すhighlightを追加
)
#使用例
ggplot(iris, aes(x = Species, y = Sepal.Width, highlight = Species == 'setosa')) +
geom_boxplot(stat = StatBoxplotHL)
実装
任意のgeom_についてhighlightしたいものだけ描写する
どんどん汎用的にしていきましょう。
あるgeom_についてハイライト版を作りたいとき、イチイチ継承する計算方法(Stat)を調べるのは面倒です。
各geomが指定しているstat引数から、継承相手を探してきましょう。
それにはggplot2:::find_subclassを使います。
ggplot2:::find_subclass("Stat", 'boxplot', parent.frame())
# [Show in New Window] [Clear Output] [Expand/Collapse Output]
#
# <ggproto object: Class StatBoxplot, Stat>
# aesthetics: function
# compute_group: function
# compute_layer: function
# compute_panel: function
# default_aes: uneval
# extra_params: na.rm
# finish_layer: function
# non_missing_aes: weight
# parameters: function
# required_aes: x y
# retransform: TRUE
# setup_data: function
# setup_params: function
# super: <ggproto object: Class Stat>
これを利用して任意のgeomからStatを探してくる関数
find_stat_from_geomを定義します。
#関数定義
find_stat_from_geom <- function(geom) {
ggplot2:::find_subclass("Stat", formals(geom)$stat, parent.frame())
}
#仕様例
find_stat_from_geom(geom_point)
# [Show in New Window] [Clear Output] [Expand/Collapse Output]
#
# <ggproto object: Class StatIdentity, Stat>
# aesthetics: function
# compute_group: function
# compute_layer: function
# compute_panel: function
# default_aes: uneval
# extra_params: na.rm
# finish_layer: function
# non_missing_aes:
# parameters: function
# required_aes:
# retransform: TRUE
# setup_data: function
# setup_params: function
# super: <ggproto object: Class Stat>
これを使うと任意のgeomに用いられるStatについてHL版を作成できます。
この時、任意のStatから、指定したMethod(compute_groupなど)を取り出し、必要なデータのみを渡すようにwrapする関数function_hlも定義しておきます。
#compute_group, layer, panelのラッパー
function_hl <- function(nm, stat) {
function(data, ...) stat[[nm]](data = data[data$highlight, ], ...)
}
#ハイライトするデータだけを表示するようにしてくれるggprotoオブジェクト(Stat)を返す関数
ggproto_hl <- function(geom) {
stat <- find_stat_from_geom(geom)
ggplot2::ggproto(
paste0(class(stat)[1], 'HL'),
stat,
compute_group = function_hl('compute_group', stat),
compute_layer = function_hl('compute_layer', stat),
compute_panel = function_hl('compute_panel', stat),
required_aes = c(stat$required_aes, 'highlight')
)
}
#使用例
ggplot(iris, aes(x = Sepal.Length, color = Species, highlight = Species == 'setosa')) +
geom_density(stat = ggproto_hl(geom_density))
任意のgeom_についてlowlightしたいものだけ描写し、地味にする
では、同様にggproto_llを定義しましょう。
この時、function_hlとggproto_hlに対応するfunction_ll、ggproto_llでは、表示するデータの見た目をhighlightするデータより地味に見せるため、見た目を変化させる引数Lを追加します。
ここではcolour = NAにしてみました。
scale_colour_*のna.values引数の値が採用されます(既定値: gray50)
#compute_group, layer, panelのラッパー
function_ll <- function(nm, stat, LL) {
function(data, ...) {
data <- data[!data$highlight, ]
data[names(LL)] <- LL #lowlightするデータの見た目を変更
stat[[nm]](data = data, ...)
}
}
#ハイライトするデータだけを表示するようにしてくれるggprotoオブジェクト(Stat)を返す関数
ggproto_ll <- function(geom, LL = list(colour = NA)) {
stat <- find_stat_from_geom(geom)
ggplot2::ggproto(
paste0(class(stat)[1], 'HL'),
stat,
compute_group = function_ll('compute_group', stat, LL),
compute_layer = function_ll('compute_layer', stat, LL),
compute_panel = function_ll('compute_panel', stat, LL),
required_aes = c(stat$required_aes, 'highlight')
)
}
#data[names(LL)] <- LLをコメントアウトしないと動きません
ggplot(iris, aes(x = Sepal.Length, color = Species, highlight = Species == 'setosa')) +
geom_density(stat = ggproto_ll(geom_density))
ただし、このコードを実行すると、
Error in seq.default(h[1], h[2], length.out = n) : 'to' must be a finite number
というエラーが返ってしまいます。
これはcolour属性を指定しているくせに全部NAなのが原因です。
LL = list(colour = 'else')
とすると動きます。
ggplot(iris, aes(x = Sepal.Length, color = Species, highlight = Species == 'setosa')) +
geom_density(stat = ggproto_ll(geom_density, LL = list(colour = 'else')))
また、colourがちゃんと指定できるlayerと重なっていれば、LL = list(colour = NA)でもOKです。
ggplot(iris, aes(x = Sepal.Length, color = Species, highlight = Species == 'setosa')) +
geom_density() +
geom_density(stat = ggproto_ll(geom_density))
この例では、lowlightした灰色の線が緑と青の線に重なっているため、結果的に、highlightすべきsetosaが目立っています。
highlight == TRUEなデータはhighlightし、そうでないデータはlowlightする
ggproto_hlとggproto_llを組み合わせると、gghighlightのような挙動が実現できます。
ggplot(iris, aes(x = Sepal.Length, y = Sepal.Width, color = Species, highlight = Species == 'setosa')) +
geom_point(stat = ggproto_ll(geom_point)) +
geom_point(stat = ggproto_hl(geom_point))
ですが、誰もこんな冗長な書き方はしたくないと思います。
任意のgeomに対しhighlight版geomを返す高階関数を定義
しました!
やっていることは2つのレイヤ(LLとHL)の重ね合わせですからpurrr::pmapを使って、geomのstatだけを自動指定しましょう。
高階関数なので、返ってきた関数に引数を与えることで、shapeやsizeを調整可能です。
library(purrr)
#高階関数定義
gghl <- function(geom, LL = list(colour = NA)) {
function(...) {
list(stat = list(
ggproto_ll(geom, LL),
ggproto_hl(geom)
)) %>%
purrr::pmap(geom, ...)
}
}
#使用例
ggplot(iris, aes(x = Sepal.Length, y = Sepal.Width, color = Species, highlight = Species == 'setosa')) +
gghl(geom_point, LL = list(colour = NA, size = 1))(aes(size = 10)) +
scale_size_identity()
繰り返し使うものを定義するのもOK
geom_density_hl <- gghl(geom_density)
ggplot(iris, aes(x = Sepal.Width, color = Species, highlight = Species == 'setosa')) +
geom_density_hl()
これで、代替のgeomに対応できたはずですが、geom_smoothだけはうまくいっていません。
ggplot(iris, aes(x = Sepal.Length, y = Sepal.Width, color = Species, highlight = Species == 'setosa')) +
gghl(geom_smooth)()
# Computation failed in `stat_smooth()`: object 'auto' of mode 'function' was not found
# Computation failed in `stat_smooth()`: object 'auto' of mode 'function' was not found
geom_quantileはうまくいきます
ggplot(iris, aes(x = Sepal.Length, y = Sepal.Width, color = Species, highlight = Species == 'setosa')) +
gghl(geom_point)() +
gghl(geom_quantile)()
補足
これまでaes(highlight = hoge == fuga)という形でhighlightを指定していましたが、勿論、data.frameにhighlightするか決める論理値の列を入れてもOKです。
iris$hl <- iris$Species == 'setosa'
ggplot(iris, aes(x = Sepal.Length, y = Sepal.Width, color = Species, highlight = hl)) +
gghl(geom_point, LL = list(colour = NA, alpha = 0.3))()
完成版
説明は上ですでにしています
現在geom_smoothと格闘中
function_hl <- function(nm, stat) {
function(data, ...) stat[[nm]](data = data[data$highlight, ], ...)
}
ggproto_hl <- function(geom) {
stat <- ggplot2:::find_subclass("Stat", formals(geom)$stat, parent.frame())
ggplot2::ggproto(
paste0(class(stat)[1], 'HL'),
stat,
compute_group = function_hl('compute_group', stat),
compute_layer = function_hl('compute_layer', stat),
compute_panel = function_hl('compute_panel', stat),
required_aes = c(stat$required_aes, 'highlight')
)
}
function_ll <- function(nm, stat, LL) {
function(data, ...) {
data <- data[!data$highlight, ]
data[names(LL)] <- LL
stat[[nm]](data = data, ...)
}
}
ggproto_ll <- function(geom, LL = list(colour = NA)) {
stat <- ggplot2:::find_subclass("Stat", formals(geom)$stat, parent.frame())
ggplot2::ggproto(
paste0(class(stat)[1], 'HL'),
stat,
compute_group = function_ll('compute_group', stat, LL),
compute_layer = function_ll('compute_layer', stat, LL),
compute_panel = function_ll('compute_panel', stat, LL),
required_aes = c(stat$required_aes, 'highlight')
)
}
gghl <- function(geom, LL = list(colour = NA)) {
function(...) {
list(stat = list(
ggproto_ll(geom, LL),
ggproto_hl(geom)
)) %>%
purrr::pmap(geom, ...)
}
}