Extending ggplot2（和訳）

この記事は、Rのggplot2パッケージの「Extending ggplot2」というVignetteを訳したものです。原文はGPL-2ライセンスで公開されているggplot2パッケージに含まれ、著作権はHadley Wickhamに帰属します。この翻訳文にもGPL-2ライセンスが適用されます。

Note that the original document is provided under the license of GPL-2 and the copyright belongs to Hadley Wickham, one of the authors of ggplot2.

---

このvignetteには、ggplot2 2.0.0で公式に提供される拡張メカニズムについて書きます。 このvignetteは、?Statや?Geomや?themeで読むことができる低レベルな詳細をまとめたものです。 新しいstat、geom、themeをつくってggplot2を拡張する方法を身に着けることができるでしょう。

これを読み進めるにつれてあなたは、頭を掻きむしり、いったいなぜこんなふうにつくったんだ？と首をかしげるものをたくさん目にするでしょう。 それらの多くは、歴史的経緯です。ggplot2の開発を始めたころ私はあまりよいRのプログラマではありませんでした。 私たちは2.0.0のリリースで可能な限り多くの問題を解決しましたが、苦労もむなしくうまく修正できないものもありました。

ggproto

すべてのggplot2のオブジェクトは、ggprotoのオブジェクト指向プログラミングシステムを使って作られています。

このオブジェクト指向システムはたったひとつの場所でしか使われていません。それは、ggplot2です。 これはほとんどが歴史的経緯です。ggplot2はmutableなオブジェクトのためにprotoを使って始まりました。これは（短命だった）mutatrや参照クラスやR6よりずっと昔の話です。protoだけが唯一の選択肢だったのです。

でもそれでは、なぜggprotoなのでしょう。 ggplot2の公式の拡張メカニズムを追加しようとしたとき、私たちは大きな問題に気付きました。protoオブジェクトが別のパッケージで拡張されていると問題が起こるのです（メソッドはその拡張が追加されたパッケージではなくggplot2パッケージで評価されます）。R6に切り替えようと試みましたが、ggplot2の要求と合致しませんでした。 protoを改造することもできましたが、そうすると、まずprotoがどのように機能するかを正確に理解することになり、さらにその変更がprotoの他のユーザーに影響を与えないことを確認しなくてはいけなくなります。

おかしな話ですが、これは、新しいオブジェクト指向を発明するというのが問題に対する正しい答えだったケースです！ 幸運にもWinstonはオブジェクト指向システムをつくるのにとても長けていて、たった1日でggprotoを思いつきました。ggprotoはggplot2が必要とするprotoの機能をすべて保持し、一方でパッケージ間にまたがる継承もうまく機能させます。

以下はggprotoの簡単な使用例です。

A <- ggproto("A", NULL,
  x = 1,
  inc = function(self) {
    self$x <- self$x + 1
  }
)
A$x

#> [1] 1

A$inc()
A$x

#> [1] 2

A$inc()
A$inc()
A$x

#> [1] 4

ggplot2のクラスの多くはイミュータブルで静的です。つまり、そのメソッドはクラスの中で状態を使うことも変化させることもしません。これらのクラスはほとんどの場合、関連するメソッドをまとめるのに便利な方法として使われています。

新しいgeomやstatをつくるには、これから説明するようにStatやGeomを継承して新しいggprotoをつくってそのメソッドをオーバーライドするだけです。

新しいstatをつくる

もっとも単純なstat

とても単純なstatをつくることから始めます。点の集合の凸包を得るstatです。まず、Statを継承するggprotoオブジェクトをつくります。

StatChull <- ggproto("StatChull", Stat,
  compute_group = function(data, scales) {
    data[chull(data$x, data$y), , drop = FALSE]
  },
  
  required_aes = c("x", "y")
)

もっとも重要な部分は、compute_group()メソッド（計算を実行します）とrequired_aesフィールド（このstatが動くのに存在しなければいけないaestheticsをリストアップします）です。

次に、layer関数を書きます。不幸にも、早期の設計ミスにより私はこれらをstat_()やgeom_()と名付けてしまいました。layer_()関数とするべきでした。これはより実体に即した表記です。なぜなら、すべてのレイヤーがstatにもgeomにも関わっているからです。

すべてのlayer関数は同じ形式に従います。関数の引数にデフォルト引数を設定して、layer()を呼び、...をそのparam引数に渡します。 ...に含まれる引数は、geomの引数（statのラッパーの場合）かstatの引数（geomのラッパーの場合）かセットするaestheticsのいずれかです。layer()が、異なるパラメータを分離して正しい場所に格納することの面倒を見てくれます。

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

（注：もし自分のパッケージの中でこれを書くなら、ggplot2::layer()と明示的に呼ぶか、layer()関数をパッケージの名前空間にインポートするか、いずれかを行う必要があります）

いったんlayer関数を手にすれば、新しいstatを試すことができるようになります。

ggplot(mpg, aes(displ, hwy)) + 
  geom_point() + 
  stat_chull(fill = NA, colour = "black")

（fill=NAと毎回指定しなくてもいいようにgeomのデフォルトを変更する方法は後ほど出てきます）

ひとたびこの基本的なオブジェクトを書き上げると、ggplot2が提供するたくさんの機能を自由に使えるようになります。例えば、ggplot2はそれぞれのグループで固定のaestheticsを自動で保存してくれます。

ggplot(mpg, aes(displ, hwy, colour = drv)) + 
  geom_point() + 
  stat_chull(fill = NA)

凸包を別の方法で表示するようにデフォルトのgeomをオーバーライドすることもできます。

ggplot(mpg, aes(displ, hwy)) + 
  stat_chull(geom = "point", size = 4, colour = "red") +
  geom_point()

Statのパラメータ

さらに複雑なstatはいくつかの計算を行います。プロットにもっともフィットする線を追加する、簡単なバージョンのgeom_smooth()を実装してみましょう。Statを継承したStatLmとlayer関数stat_lm()をつくります。

StatLm <- ggproto("StatLm", Stat, 
  required_aes = c("x", "y"),
  
  compute_group = function(data, scales) {
    rng <- range(data$x, na.rm = TRUE)
    grid <- data.frame(x = rng)
    
    mod <- lm(y ~ x, data = data)
    grid$y <- predict(mod, newdata = grid)
    
    grid
  }
)

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

ggplot(mpg, aes(displ, hwy)) + 
  geom_point() + 
  stat_lm()

StatLmはパラメータを持たないため柔軟性がありません。モデルの式やグリッドを生成するのに使われる点の数をユーザーが操作できるようにしたい、と思うかもしれません。そうするには、compute_group()メソッドと先ほどのラッパー関数に引数を追加します。

StatLm <- ggproto("StatLm", Stat, 
  required_aes = c("x", "y"),
  
  compute_group = function(data, scales, params, n = 100, formula = y ~ x) {
    rng <- range(data$x, na.rm = TRUE)
    grid <- data.frame(x = seq(rng[1], rng[2], length = n))
    
    mod <- lm(formula, data = data)
    grid$y <- predict(mod, newdata = grid)
    
    grid
  }
)

stat_lm <- function(mapping = NULL, data = NULL, geom = "line",
                    position = "identity", na.rm = FALSE, show.legend = NA, 
                    inherit.aes = TRUE, n = 50, formula = y ~ x, 
                    ...) {
  layer(
    stat = StatLm, data = data, mapping = mapping, geom = geom, 
    position = position, show.legend = show.legend, inherit.aes = inherit.aes,
    params = list(n = n, formula = formula, na.rm = na.rm, ...)
  )
}

ggplot(mpg, aes(displ, hwy)) + 
  geom_point() + 
  stat_lm(formula = y ~ poly(x, 10)) + 
  stat_lm(formula = y ~ poly(x, 10), geom = "point", colour = "red", n = 20)

注意すべき点として、新しいパラメータを明示的にlayerの引数に含めることは、必ずやらなくてはいけないわけではありません。いずれにせよ...は正しい位置に渡されます。しかし、ユーザーがそれについて知ることができるようにどこかにドキュメントを書く必要はあるでしょう。 ここに短い例があります。@inheritParams ggplot2::stat_identityは、stat_identity()について定義されたすべてのパラメータについてのドキュメントを自動的に継承してくれます。

#' @inheritParams ggplot2::stat_identity
#' @param formula The modelling formula passed to \code{lm}. Should only 
#'   involve \code{y} and \code{x}
#' @param n Number of points used for interpolation.
stat_lm <- function(mapping = NULL, data = NULL, geom = "line",
                    position = "identity", na.rm = FALSE, show.legend = NA, 
                    inherit.aes = TRUE, n = 50, formula = y ~ x, 
                    ...) {
  layer(
    stat = StatLm, data = data, mapping = mapping, geom = geom, 
    position = position, show.legend = show.legend, inherit.aes = inherit.aes,
    params = list(n = n, formula = formula, na.rm = na.rm, ...)
  )
}

デフォルト値を使う

場合によっては、それぞれのデータに対して一度づつではなく、データセット全体に行うべき計算があります。 これは、理にかなったデフォルト値を選ぶのに役立ちます。例えば、密度推定を行いたいとき、プロット全体に対してひとつのバンド幅を選ぶのは妥当なことでしょう。 以下のStatは、それぞれのグループに最適なバンド幅の平均を全グループのバンド幅として使う（この方法に論理的な根拠はありませんが、非合理的ではなさそうに見えます）、stat_density()の一種をつくります。

そうするためには、setup_param()メソッドをオーバーライドします。これは、データとパラメータのリストを渡すと更新されたリストを返します。

StatDensityCommon <- ggproto("StatDensityCommon", Stat, 
  required_aes = "x",
  
  setup_params = function(data, params) {
    if (!is.null(params$bandwidth))
      return(params)
    
    xs <- split(data$x, data$group)
    bws <- vapply(xs, bw.nrd0, numeric(1))
    bw <- mean(bws)
    message("Picking bandwidth of ", signif(bw, 3))
    
    params$bandwidth <- bw
    params
  },
  
  compute_group = function(data, scales, bandwidth = 1) {
    d <- density(data$x, bw = bandwidth)
    data.frame(x = d$x, y = d$y)
  }  
)

stat_density_common <- function(mapping = NULL, data = NULL, geom = "line",
                                position = "identity", na.rm = FALSE, show.legend = NA, 
                                inherit.aes = TRUE, bandwidth = NULL,
                                ...) {
  layer(
    stat = StatDensityCommon, data = data, mapping = mapping, geom = geom, 
    position = position, show.legend = show.legend, inherit.aes = inherit.aes,
    params = list(bandwidth = bandwidth, na.rm = na.rm, ...)
  )
}

ggplot(mpg, aes(displ, colour = drv)) + 
  stat_density_common()

#> Picking bandwidth of 0.345

ggplot(mpg, aes(displ, colour = drv)) + 
  stat_density_common(bandwidth = 0.5)

私はNULLをデフォルト値にすることをお薦めします。もしも重要なパラメータを自動で選ぶのであれば、message()でユーザーに伝えるのがいいでしょう。(あと、浮動小数点のパラメータを表示するときはsignif()を使って数桁だけを見せるのがいいでしょう)

変数名とデフォルトのaesthetics

以下のstatは別の重要な点を示しています。もしも他のgeomといっしょにこのstatを使いたい場合は、yではなくdensityという名前の変数を返すべきです。 そうすることで、densityをyに自動的にマップするようにdefault_aesを設定することができます。ユーザーはこのaestheticsをオーバーライドして別のgeomで使うことができます。

StatDensityCommon <- ggproto("StatDensity2", Stat, 
  required_aes = "x",
  default_aes = aes(y = ..density..),

  compute_group = function(data, scales, bandwidth = 1) {
    d <- density(data$x, bw = bandwidth)
    data.frame(x = d$x, density = d$y)
  }  
)

ggplot(mpg, aes(displ, drv, colour = ..density..)) + 
  stat_density_common(bandwidth = 1, geom = "point")

しかし、このstatをareaのgeomと組み合わせると正しく動作しません。面が積み重なっていません。

ggplot(mpg, aes(displ, fill = drv)) + 
  stat_density_common(bandwidth = 1, geom = "area", position = "stack")

これはなぜかというと、各グループの密度が別々に計算されていてxの推定値が含まれていないからです。この問題は、setup_param()で一度だけデータの範囲を計算するようにすることで解決できます。

StatDensityCommon <- ggproto("StatDensityCommon", Stat, 
  required_aes = "x",
  default_aes = aes(y = ..density..),

  setup_params = function(data, params) {
    min <- min(data$x) - 3 * params$bandwidth
    max <- max(data$x) + 3 * params$bandwidth
    
    list(
      bandwidth = params$bandwidth,
      min = min,
      max = max,
      na.rm = params$na.rm
    )
  },
  
  compute_group = function(data, scales, min, max, bandwidth = 1) {
    d <- density(data$x, bw = bandwidth, from = min, to = max)
    data.frame(x = d$x, density = d$y)
  }  
)

ggplot(mpg, aes(displ, fill = drv)) + 
  stat_density_common(bandwidth = 1, geom = "area", position = "stack")

ggplot(mpg, aes(displ, drv, fill = ..density..)) + 
  stat_density_common(bandwidth = 1, geom = "raster")

Exercises

1. stat_chullを拡張して、alphahullがやっているようにアルファシェイプを計算するようにしなさい。 新しいstatはalphaを引数に取ること。
2. StatDensityCommonの最終バージョンに変更を加え、ユーザーがminとmaxパラメーターを指定できるようにしなさい。layer関数と compute_group()メソッドの両方を変更する必要がある。
3. StatLmとggplot2::StatSmoothを比較しなさい。StatSmoothをStatLmより複雑にしている重要な違いは何？

新しいgeomをつくる

新しいgeomをつくるのは、gridについて知る必要があるため、新しいstatをつくるより難しいです。 ggplot2はgridの上に成り立っているので、gridでプロットを描く基本について知る必要があります。 もしも新しいgeomをつくることを真剣に検討しているのであればPaul MurrellのR graphics（邦訳：Rグラフィックス）を購入することをお薦めします。この本はgridでプロットを描くために知る必要があることをすべて教えてくれます。

簡単なgeom

簡単な例から始めるのが簡単でしょう。以下のコードはgeom_point()の簡単なバージョンです：

GeomSimplePoint <- ggproto("GeomSimplePoint", Geom,
  required_aes = c("x", "y"),
  default_aes = aes(shape = 19, colour = "black"),
  draw_key = draw_key_point,

  draw_panel = function(data, panel_scales, coord) {
    coords <- coord$transform(data, panel_scales)
    grid::pointsGrob(
      coords$x, coords$y,
      pch = coords$shape,
      gp = grid::gpar(col = coords$colour)
    )
  }
)

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

ggplot(mpg, aes(displ, hwy)) + 
  geom_simple_point()

これはあたらしいstatを定義する時ととてもよく似ています。上に示した4つに対してフィールドまたはメソッドを指定する必要があります。

• required_aesはユーザが指定しなければならないすべてのaestheticsを並べたcharacterのベクトルです。

• default_aesは、デフォルト値を持つaestheticsのリストです。

• draw_keyは凡例のキーを描画するのに使われる関数を提供します。?draw_keyを見れば組み込みのkey関数のリストを見ることができます。

• draw_group()は魔法が起こる場所です。この関数は3つの引数を取って、1つのgrid grobを返します。これはそれぞれのパネルに対して1回づつ呼ばれます。 これは以下により詳しく説明しますが、もっとも複雑な部分です。

draw_group()は3つの引数を持っています：

• data: それぞれのaestheticsに対してひとつのカラムを持つデータフレーム

• panel_scales: 現在のパネルのxとyのスケールに関する情報を含んだリスト

• coord: 座標系について記述しているオブジェクト

一般的に、panel_scalesとcoordが直接使われることはないでしょう。しかし、データを変形させるために常にこれらを使うことになります：coords <- coord$transform(data, panel_scales) これは、position変数が0～1の範囲にスケールされたデータフレームを作成します。それから、このデータが返ってきて、grid grob関数が呼び出されます。（非直行座標系での変形はとても複雑です。既存のggplot2のgeomが受け付ける形にデータを変形して、そのgeomに渡すのがいいでしょう）

集合的なgeom

draw_panel()をオーバーライドするのは、1つの行で1つの要素だけが描画されるなら、もっとも適切なやり方です。他の場合だと、グループごとに要素を描きたくなります。たとえば、多角形を例にとると、各行は多角形の1つの頂点を与えます。この場合には、draw_group()をオーバーライドするべきです。

以下はGeomPolygonの簡単なバージョンです。

GeomSimplePolygon <- ggproto("GeomPolygon", Geom,
  required_aes = c("x", "y"),
  
  default_aes = aes(
    colour = NA, fill = "grey20", size = 0.5,
    linetype = 1, alpha = 1
  ),

  draw_key = draw_key_polygon,

  draw_group = function(data, panel_scales, coord) {
    n <- nrow(data)
    if (n <= 2) return(grid::nullGrob())

    coords <- coord$transform(data, panel_scales)
    # A polygon can only have a single colour, fill, etc, so take from first row
    first_row <- coords[1, , drop = FALSE]

    grid::polygonGrob(
      coords$x, coords$y, 
      default.units = "native",
      gp = grid::gpar(
        col = first_row$colour,
        fill = scales::alpha(first_row$fill, first_row$alpha),
        lwd = first_row$size * .pt,
        lty = first_row$linetype
      )
    )
  }
)
geom_simple_polygon <- function(mapping = NULL, data = NULL, stat = "chull",
                                position = "identity", na.rm = FALSE, show.legend = NA, 
                                inherit.aes = TRUE, ...) {
  layer(
    geom = GeomSimplePolygon, mapping = mapping, data = data, stat = stat, 
    position = position, show.legend = show.legend, inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, ...)
  )
}

ggplot(mpg, aes(displ, hwy)) + 
  geom_point() + 
  geom_simple_polygon(aes(colour = class), fill = NA)

いくつか特筆すべき点があります：

• 1つの行につき1つの多角形を描くのではなく1つのグループにつき1つの多角形を描きたいので、draw_layer()の代わりにdraw_group()をオーバーライドしています。 オリジナルのGeomPolygonのソースコードを見たなら、実際にはgeom_layer()をオーバーライドしていることに気づくでしょう。これはpolygonGrobをつくるためのいくつかの トリックが1回の呼び出しで複数の多角形を生成するからです。これはかなり複雑ですが、パフォーマンスに優れています。

• もしデータが2つ以下の点しか含まない場合、多角形を描こうとする意味はないので、nullGrob()を返します。 これはNULLに相当するものです：これは何も描画せず場所も取らないgrobです。

• 単位について注意すべきは、xとyが「ネイティブな」単位で描かれるという点です（pointGrobのデフォルトの 単位はネイティブなので、何も変更する必要はありません）。lwdはポイント単位ですが、ggplot2はmm単位を使うので、 修正するための要素.ptを掛ける必要があります。

既存のgeomからの継承

ときどき、既存のgeomに小さな変更を加えたくなります。この場合、Geomを継承するよりも、既に存在するサブクラスを継承することができます。たとえば、StatChullと組み合わせてうまく動くようにGeomPolygonのデフォルトを変更したくなります：

GeomPolygonHollow <- ggproto("GeomPolygonHollow", GeomPolygon,
  default_aes = aes(colour = "black", fill = NA, size = 0.5, linetype = 1,
    alpha = NA)
  )
geom_chull <- function(mapping = NULL, data = NULL, 
                       position = "identity", na.rm = FALSE, show.legend = NA, 
                       inherit.aes = TRUE, ...) {
  layer(
    stat = StatChull, geom = GeomPolygonHollow, data = data, mapping = mapping,
    position = position, show.legend = show.legend, inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, ...)
  )
}

ggplot(mpg, aes(displ, hwy)) + 
  geom_point() + 
  geom_chull()

このやり方では別のgeomをこのstatと組み合わせることはできませんが、凸包がおおむね多角形の機能となったので、ここでは適切だと思われます。

Exercises

1. GeomPointとGeomSimplePointを比較しなさい。
2. GeomPolygonとGeomSimplePolygonを比較しなさい。

自分のthemeをつくる

もし自分の完全なthemeをつくろうとするなら、いくつか知る必要があることがあります：

• 既存のelementに変更を加えるのではなく、オーバーライドする
• themeの（ほぼ）すべてのelementに影響を与える4つのグローバルなelement
• 完全なelement vs 不完全なelement

elementのオーバーライド

デフォルトでは、新しいtheme elementを追加すると、既存のテーマから値を継承します。例えば、以下のコードはkeyのcolourを赤に設定していますが、既存のfillを継承しています。

theme_grey()$legend.key

#> List of 4
#>  $ fill    : chr "grey95"
#>  $ colour  : chr "white"
#>  $ size    : NULL
#>  $ linetype: NULL
#>  - attr(*, "class")= chr [1:2] "element_rect" "element"

new_theme <- theme_grey() + theme(legend.key = element_rect(colour = "red"))
new_theme$legend.key

#> List of 4
#>  $ fill    : chr "grey95"
#>  $ colour  : chr "red"
#>  $ size    : NULL
#>  $ linetype: NULL
#>  - attr(*, "class")= chr [1:2] "element_rect" "element"

完全にオーバーライドするには+ではなく%+replace%を使います。

new_theme <- theme_grey() %+replace% theme(legend.key = element_rect(colour = "red"))
new_theme$legend.key

#> List of 4
#>  $ fill    : NULL
#>  $ colour  : chr "red"
#>  $ size    : NULL
#>  $ linetype: NULL
#>  - attr(*, "class")= chr [1:2] "element_rect" "element"

グローバルなelement

プロット全体の見え方に影響するelementが4つあります：

Element	Theme function	概要
line	element_line()	すべての線
rect	element_rect()	すべての長方形
text	element_text()	すべてのテキスト
title	element_text()	タイトル要素（プロット、軸、凡例）のすべてのテキスト

これらは、より詳細な設定から継承されるデフォルトの属性をセットします。全体のbackgroundの色や全体のフォント設定（familyやsize）を設定するのに便利です。

df <- data.frame(x = 1:3, y = 1:3)
base <- ggplot(df, aes(x, y)) + 
  geom_point() + 
  theme_minimal()

base

base + theme(text = element_text(colour = "red"))

一般的には、これらの値を変更するところからthemeづくりを始めるべきでしょう。

完全なelement vs 不完全なelement

完全なthemeオブジェクトと不完全なthemeオブジェクトの違いについて理解するのは有用です。完全なthemeオブジェクトは、complete = TRUEを付けてtheme関数を呼び出すことで生成されます。

theme_grey()とtheme_bw()は完全なtheme関数の例です。 theme()は不完全なthemeオブジェクトを生成します。なぜなら、それらは、themeオブジェクトの部分的な変更を表すのであって、完全なthemeオブジェクトそれ自体を返すものではないからです。 不完全なthemeと完全なthemeを足し合わせると、完全なthemeｖができます。

完全なthemeと不完全なthemeはggplotオブジェクトに足しあわされた時はやや異なる挙動をします。

• 不完全なthemeを足し合わせると、今のthemeオブジェクトを拡張し、theme()の呼び出しに定義されたelementの属性のみを置き換えます。

• 完全なthemeを足し合わせると、既存のthemeを取り除き、新しいthemeを適用します。

新しいfacettingをつくる

ggplot2拡張のより困難な課題の1つは、新しいfacetting systemを作成することです。その理由は、新しいfacettingを作成する時には画面上の描画の（ほぼ）すべての責任を負わなければならないことと、ggplot2のレンダリングの土台となっているgtableパッケージとgridパッケージを直接使用した経験がある人はあまりいないからです。facettingの拡張拡張に挑戦することを決めた場合は、これらのパッケージで熟練を得ることを強く推奨します。

ggplot2のFacetクラスは、幅広いタスクの責任を負う非常に強力なクラスです。ファセットオブジェクトの主なタスクは次のとおりです。

• レイアウトを定義する。すなわち、データを異なるプロット領域（パネル）に分割すること、およびどのパネルが位置スケールを共有するかということです。
• プロットデータを正しいパネルにマップする。複数のパネルにデータが存在する必要がある場合はそれをコピーします（facet_grid()のマージンなど）。
• すべてのパネルを最終的なgtableに組み立て、それぞれの軸、ストリップ（訳注：facetのラベル）、装飾を追加します。

機能を実装する必要があるこれらの3つのタスクの他に、適切なデフォルトが提供されている追加の拡張ポイントがいくつかあります。これらは一般的に無視することができますが、冒険的な開発者はそれらをオーバーライドしてさらに制御することができます：

• 各パネルのスケールの初期化と調整
• 各パネルの前後に装飾
• 軸ラベルの描画

新しいfacettingのクラスがどのように作成されるかを示すため、はじめはシンプルに、それぞれの必要なメソッドを順番に実行して、プロットを2つのパネルに複製するだけのfacet_duplicate()を作成します。その後、より強力な可能性のいくつかを示すためにそれを少し使ってみます。

新しいレイアウトの定義をつくる

facettingというコンテキストでのレイアウトは、データとそれが常駐すべきパネルとの間のマッピングと、どのスケールを使用すべきかを定義するdata.frameです。 少なくとも PANEL、 SCALE_X、 SCALE_Yの列が含まれている必要がありますが、多くの場合はさらに、適切なパネルにデータを割り当てるのに役立つ列が含まれています（例：facet_grid()はパネルそれぞれに紐づいている変数を返します）。 では、重複したレイアウトを定義する関数を作ってみましょう。

layout <- function(data, params) {
  data.frame(PANEL = c(1L, 2L), SCALE_X = 1L, SCALE_Y = 1L)
}

これは、facettingが入力データとパラメータに関係なく2つのパネルを定義するだけなので、非常に簡単です。

パネルへのデータのマッピング

どのデータがどこに行くか知るために、ggplot2はそのパネルに割り当てられるべきデータを必要とします。マッピングのステップの目的は、PANEL列をそのパネルに所属すべきデータを特定しつつ割り当てることです。

mapping <- function(data, layout, params) {
  if (plyr::empty(data)) {
    return(cbind(data, PANEL = integer(0)))
  }
  rbind(
    cbind(data, PANEL = 1L),
    cbind(data, PANEL = 2L)
  )
}

さて、最初に空の data.frameを取得したかどうかを調べ、もしそうでなければデータを複製して元のデータを最初のパネルに割り当て、新しいデータを2番目のパネルに割り当てます。

パネルの配置

上記の2つの関数は一見簡単そうに見えましたが、この最後の関数はもう少し作業が必要です。 私たちの目標は、2つのパネルを軸を挟んで左右（または上下）に描くことです。

render <- function(panels, layout, x_scales, y_scales, ranges, coord, data,
                   theme, params) {
  # Place panels according to settings
  if (params$horizontal) {
    # Put panels in matrix and convert to a gtable
    panels <- matrix(panels, ncol = 2)
    panel_table <- gtable::gtable_matrix("layout", panels, 
      widths = unit(c(1, 1), "null"), heights = unit(1, "null"), clip = "on")
    # Add spacing according to theme
    panel_spacing <- if (is.null(theme$panel.spacing.x)) {
      theme$panel.spacing
    } else {
      theme$panel.spacing.x
    }
    panel_table <- gtable::gtable_add_col_space(panel_table, panel_spacing)
  } else {
    panels <- matrix(panels, ncol = 1)
    panel_table <- gtable::gtable_matrix("layout", panels, 
      widths = unit(1, "null"), heights = unit(c(1, 1), "null"), clip = "on")
    panel_spacing <- if (is.null(theme$panel.spacing.y)) {
      theme$panel.spacing
    } else {
      theme$panel.spacing.y
    }
    panel_table <- gtable::gtable_add_row_space(panel_table, panel_spacing)
  }
  # Name panel grobs so they can be found later
  panel_table$layout$name <- paste0("panel-", c(1, 2))
  
  # Construct the axes
  axes <- render_axes(ranges[1], ranges[1], coord, theme, 
    transpose = TRUE)

  # Add axes around each panel
  panel_pos_h <- panel_cols(panel_table)$l
  panel_pos_v <- panel_rows(panel_table)$t
  axis_width_l <- unit(grid::convertWidth(
    grid::grobWidth(axes$y$left[[1]]), "cm", TRUE), "cm")
  axis_width_r <- unit(grid::convertWidth(
    grid::grobWidth(axes$y$right[[1]]), "cm", TRUE), "cm")
  ## We do it reverse so we don't change the position of panels when we add axes
  for (i in rev(panel_pos_h)) {
    panel_table <- gtable::gtable_add_cols(panel_table, axis_width_r, i)
    panel_table <- gtable::gtable_add_grob(panel_table, 
      rep(axes$y$right, length(panel_pos_v)), t = panel_pos_v, l = i + 1, 
      clip = "off")
    panel_table <- gtable::gtable_add_cols(panel_table, axis_width_l, i - 1)
    panel_table <- gtable::gtable_add_grob(panel_table, 
      rep(axes$y$left, length(panel_pos_v)), t = panel_pos_v, l = i, 
      clip = "off")
  }
  ## Recalculate as gtable has changed
  panel_pos_h <- panel_cols(panel_table)$l
  panel_pos_v <- panel_rows(panel_table)$t
  axis_height_t <- unit(grid::convertHeight(
    grid::grobHeight(axes$x$top[[1]]), "cm", TRUE), "cm")
  axis_height_b <- unit(grid::convertHeight(
    grid::grobHeight(axes$x$bottom[[1]]), "cm", TRUE), "cm")
  for (i in rev(panel_pos_v)) {
    panel_table <- gtable::gtable_add_rows(panel_table, axis_height_b, i)
    panel_table <- gtable::gtable_add_grob(panel_table, 
      rep(axes$x$bottom, length(panel_pos_h)), t = i + 1, l = panel_pos_h, 
      clip = "off")
    panel_table <- gtable::gtable_add_rows(panel_table, axis_height_t, i - 1)
    panel_table <- gtable::gtable_add_grob(panel_table, 
      rep(axes$x$top, length(panel_pos_h)), t = i, l = panel_pos_h, 
      clip = "off")
  }
  panel_table
}

Facetクラスの組み立て

通常、すべてのメソッドは Geomと Statの場合と同じようにクラス定義の中で定義されます。 ここで私たちはそれを分けて、それぞれを順番に定義していくことができました。 残っているのは、これらの関数を適切なメソッドに割り当てるのと同時にコンストラクタを作ることです。

# Constructor: shrink is required to govern whether scales are trained on 
# Stat-transformed data or not.
facet_duplicate <- function(horizontal = TRUE, shrink = TRUE) {
  ggproto(NULL, FacetDuplicate,
    shrink = shrink,
    params = list(
      horizontal = horizontal
    )
  )
}

FacetDuplicate <- ggproto("FacetDuplicate", Facet,
  compute_layout = layout,
  map_data = mapping,
  draw_panels = render
)

これですべて組み立てられたので、さっそく試してみましょう。

p <- ggplot(mtcars, aes(x = hp, y = mpg)) + geom_point()
p

p + facet_duplicate()

もっとfacetsでいろいろやってみる

上記の例はほとんど役に立ちませんでした。私たちはこれから、実際に有用な機能を追加するためにこれを拡張することを試みていきます。 Y軸を変換したパネルを追加するfacettingを作成します：

library(scales)

facet_trans <- function(trans, horizontal = TRUE, shrink = TRUE) {
  ggproto(NULL, FacetTrans,
    shrink = shrink,
    params = list(
      trans = scales::as.trans(trans),
      horizontal = horizontal
    )
  )
}

FacetTrans <- ggproto("FacetTrans", Facet,
  # Almost as before but we want different y-scales for each panel
  compute_layout = function(data, params) {
    data.frame(PANEL = c(1L, 2L), SCALE_X = 1L, SCALE_Y = c(1L, 2L))
  },
  # Same as before
  map_data = function(data, layout, params) {
    if (plyr::empty(data)) {
      return(cbind(data, PANEL = integer(0)))
    }
    rbind(
      cbind(data, PANEL = 1L),
      cbind(data, PANEL = 2L)
    )
  },
  # This is new. We create a new scale with the defined transformation
  init_scales = function(layout, x_scale = NULL, y_scale = NULL, params) {
    scales <- list()
    if (!is.null(x_scale)) {
      scales$x <- plyr::rlply(max(layout$SCALE_X), x_scale$clone())
    }
    if (!is.null(y_scale)) {
      y_scale_orig <- y_scale$clone()
      y_scale_new <- y_scale$clone()
      y_scale_new$trans <- params$trans
      # Make sure that oob values are kept
      y_scale_new$oob <- function(x, ...) x
      scales$y <- list(y_scale_orig, y_scale_new)
    }
    scales
  },
  # We must make sure that the second scale is trained on transformed data
  train_scales = function(x_scales, y_scales, layout, data, params) {
    # Transform data for second panel prior to scale training
    if (!is.null(y_scales)) {
      data <- lapply(data, function(layer_data) {
        match_id <- match(layer_data$PANEL, layout$PANEL)
        y_vars <- intersect(y_scales[[1]]$aesthetics, names(layer_data))
        trans_scale <- layer_data$PANEL == 2L
        for (i in y_vars) {
          layer_data[trans_scale, i] <- y_scales[[2]]$transform(layer_data[trans_scale, i])
        }
        layer_data
      })
    }
    Facet$train_scales(x_scales, y_scales, layout, data, params)
  },
  # this is where we actually modify the data. It cannot be done in $map_data as that function
  # doesn't have access to the scales
  finish_data = function(data, layout, x_scales, y_scales, params) {
    match_id <- match(data$PANEL, layout$PANEL)
    y_vars <- intersect(y_scales[[1]]$aesthetics, names(data))
    trans_scale <- data$PANEL == 2L
    for (i in y_vars) {
      data[trans_scale, i] <- y_scales[[2]]$transform(data[trans_scale, i])
    }
    data
  },
  # A few changes from before to accomodate that axes are now not duplicate of each other
  # We also add a panel strip to annotate the different panels
  draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord,
                         data, theme, params) {
    # Place panels according to settings
    if (params$horizontal) {
      # Put panels in matrix and convert to a gtable
      panels <- matrix(panels, ncol = 2)
      panel_table <- gtable::gtable_matrix("layout", panels, 
        widths = unit(c(1, 1), "null"), heights = unit(1, "null"), clip = "on")
      # Add spacing according to theme
      panel_spacing <- if (is.null(theme$panel.spacing.x)) {
        theme$panel.spacing
      } else {
        theme$panel.spacing.x
      }
      panel_table <- gtable::gtable_add_col_space(panel_table, panel_spacing)
    } else {
      panels <- matrix(panels, ncol = 1)
      panel_table <- gtable::gtable_matrix("layout", panels, 
        widths = unit(1, "null"), heights = unit(c(1, 1), "null"), clip = "on")
      panel_spacing <- if (is.null(theme$panel.spacing.y)) {
        theme$panel.spacing
      } else {
        theme$panel.spacing.y
      }
      panel_table <- gtable::gtable_add_row_space(panel_table, panel_spacing)
    }
    # Name panel grobs so they can be found later
    panel_table$layout$name <- paste0("panel-", c(1, 2))
    
    # Construct the axes
    axes <- render_axes(ranges[1], ranges, coord, theme, 
      transpose = TRUE)
  
    # Add axes around each panel
    grobWidths <- function(x) {
      unit(vapply(x, function(x) {
        grid::convertWidth(
          grid::grobWidth(x), "cm", TRUE)
      }, numeric(1)), "cm")
    }
    panel_pos_h <- panel_cols(panel_table)$l
    panel_pos_v <- panel_rows(panel_table)$t
    axis_width_l <- grobWidths(axes$y$left)
    axis_width_r <- grobWidths(axes$y$right)
    ## We do it reverse so we don't change the position of panels when we add axes
    for (i in rev(seq_along(panel_pos_h))) {
      panel_table <- gtable::gtable_add_cols(panel_table, axis_width_r[i], panel_pos_h[i])
      if (params$horizontal) {
        panel_table <- gtable::gtable_add_grob(panel_table, 
          rep(axes$y$right[i], length(panel_pos_v)), t = panel_pos_v, l = panel_pos_h[i] + 1, 
          clip = "off")
      } else {
        panel_table <- gtable::gtable_add_grob(panel_table, 
          rep(axes$y$right, length(panel_pos_v)), t = panel_pos_v, l = panel_pos_h[i] + 1, 
          clip = "off")
      }
      panel_table <- gtable::gtable_add_cols(panel_table, axis_width_l[i], panel_pos_h[i] - 1)
      if (params$horizontal) {
        panel_table <- gtable::gtable_add_grob(panel_table, 
        rep(axes$y$left[i], length(panel_pos_v)), t = panel_pos_v, l = panel_pos_h[i], 
        clip = "off")
      } else {
        panel_table <- gtable::gtable_add_grob(panel_table, 
        rep(axes$y$left, length(panel_pos_v)), t = panel_pos_v, l = panel_pos_h[i], 
        clip = "off")
      }
    }
    ## Recalculate as gtable has changed
    panel_pos_h <- panel_cols(panel_table)$l
    panel_pos_v <- panel_rows(panel_table)$t
    axis_height_t <- unit(grid::convertHeight(
      grid::grobHeight(axes$x$top[[1]]), "cm", TRUE), "cm")
    axis_height_b <- unit(grid::convertHeight(
      grid::grobHeight(axes$x$bottom[[1]]), "cm", TRUE), "cm")
    for (i in rev(panel_pos_v)) {
      panel_table <- gtable::gtable_add_rows(panel_table, axis_height_b, i)
      panel_table <- gtable::gtable_add_grob(panel_table, 
        rep(axes$x$bottom, length(panel_pos_h)), t = i + 1, l = panel_pos_h, 
        clip = "off")
      panel_table <- gtable::gtable_add_rows(panel_table, axis_height_t, i - 1)
      panel_table <- gtable::gtable_add_grob(panel_table, 
        rep(axes$x$top, length(panel_pos_h)), t = i, l = panel_pos_h, 
        clip = "off")
    }
    
    # Add strips
    strips <- render_strips(
      x = data.frame(name = c("Original", paste0("Transformed (", params$trans$name, ")"))),
      labeller = label_value, theme = theme)
    
    panel_pos_h <- panel_cols(panel_table)$l
    panel_pos_v <- panel_rows(panel_table)$t
    strip_height <- unit(grid::convertHeight(
      grid::grobHeight(strips$x$top[[1]]), "cm", TRUE), "cm")
    for (i in rev(seq_along(panel_pos_v))) {
      panel_table <- gtable::gtable_add_rows(panel_table, strip_height, panel_pos_v[i] - 1)
      if (params$horizontal) {
        panel_table <- gtable::gtable_add_grob(panel_table, strips$x$top, 
          t = panel_pos_v[i], l = panel_pos_h, clip = "off")
      } else {
        panel_table <- gtable::gtable_add_grob(panel_table, strips$x$top[i], 
          t = panel_pos_v[i], l = panel_pos_h, clip = "off")
      }
    }
    
    
    panel_table
  }
)

非常に明白なように、 draw_panelメソッドは、いったん複数の可能性を考慮に入れると、非常に扱いにくくなります。 水平レイアウトと垂直レイアウトの両方をサポートしたいという事実は、上記のコードのif/elseブロックの多用につながってしまっています。facetsの拡張を書くときには、一般に、これは大きな課題です。そのため、これらのメソッドを記述する際に非常に細心の注意を払うようにしてください。

おしゃべりは終わりです。新しいfacetting拡張機能がうまく動くか見てみましょう：

ggplot(mtcars, aes(x = hp, y = mpg)) + geom_point() + facet_trans('sqrt')

既存のfacet関数の拡張

facetクラスの描画部分は難しい開発ステップであることが多いため、既存のfacettingクラスに乗っかって様々な新しいfacetingを作り上げることが可能です。以下では、facet_wrap()のサブクラスを使って、入力データを多数のパネルにランダムに分割するfacet_bootstarp()クラスを作成します。

facet_bootstrap <- function(n = 9, prop = 0.2, nrow = NULL, ncol = NULL, 
  scales = "fixed", shrink = TRUE, strip.position = "top") {
  
  facet <- facet_wrap(~.bootstrap, nrow = nrow, ncol = ncol, scales = scales, 
    shrink = shrink, strip.position = strip.position)
  facet$params$n <- n
  facet$params$prop <- prop
  ggproto(NULL, FacetBootstrap,
    shrink = shrink,
    params = facet$params
  )
}

FacetBootstrap <- ggproto("FacetBootstrap", FacetWrap,
  compute_layout = function(data, params) {
    id <- seq_len(params$n)

    dims <- wrap_dims(params$n, params$nrow, params$ncol)
    layout <- data.frame(PANEL = factor(id))

    if (params$as.table) {
      layout$ROW <- as.integer((id - 1L) %/% dims[2] + 1L)
    } else {
      layout$ROW <- as.integer(dims[1] - (id - 1L) %/% dims[2])
    }
    layout$COL <- as.integer((id - 1L) %% dims[2] + 1L)

    layout <- layout[order(layout$PANEL), , drop = FALSE]
    rownames(layout) <- NULL

    # Add scale identification
    layout$SCALE_X <- if (params$free$x) id else 1L
    layout$SCALE_Y <- if (params$free$y) id else 1L

    cbind(layout, .bootstrap = id)
  },
  map_data = function(data, layout, params) {
    if (is.null(data) || nrow(data) == 0) {
      return(cbind(data, PANEL = integer(0)))
    }
    n_samples <- round(nrow(data) * params$prop)
    new_data <- lapply(seq_len(params$n), function(i) {
      cbind(data[sample(nrow(data), n_samples), , drop = FALSE], PANEL = i)
    })
    do.call(rbind, new_data)
  }
)

ggplot(diamonds, aes(carat, price)) + 
  geom_point(alpha = 0.1) + 
  facet_bootstrap(n = 9, prop = 0.05)

上記で行っている処理は、 compute_layoutと map_dataメソッドをインターセプトし、データを変数で分割するのではなく、サンプリングパラメータに基づいてランダムに行を各パネルに割り当てることです（nはパネルの数を、 propは各パネルのデータの割合を決定する）。 ここで重要なのは compute_layoutによって返されたレイアウトが FacetWrapのための有効なレイアウトであることです。なぜなら、私たちはFacetWrapの draw_panelメソッドがすべての仕事を果たしてくれることを当てにしているためです。 したがって、FacetWrapまたはFacetGridのサブクラスを作成する場合は、レイアウト仕様の性質を必ず理解しておいてください。

練習

1. FacetTransを書き換えて、変換のベクトルを取得し、変換ごとに追加のパネルを作成しなさい。
2. FacetWrap実装に基づいて、strip.placementテーマの設定を考慮に入れてfacetTransを書き換えなさい。
3. FacetBootstrapには、特に同じデータを持つ複数のレイヤーを追加する際にどのような注意点があるか考えなさい。