ggplot2 の拡張

この vignette は、ggplot2 2.0.0 で提供される公式の拡張メカニズムを文書化したものです。 この vignette は、?Stat, ?Geom, ?theme で見られる低レベルの詳細に対する高レベルの補助的なものです。新しいstat、geom、またはthemeを作成してggplot2を拡張する方法を学びます。

このドキュメントを読んでいると、なぜこのような設計になっているのかと頭を悩ませるようなことがたくさん出てきます。 ほとんどは歴史的な偶然です。 ggplot2を書き始めたとき、私はひどく優秀なRプログラマーではなかったので、多くの疑わしい決定をしました。 2.0.0のリリースでは、これらの問題を可能な限りクリーンアップしましたが、いくつかの修正は単に努力の価値がありませんでした。

ggproto

すべての ggplot2 オブジェクトは、オブジェクト指向プログラミングの ggproto システムを使用して構築されています。 この OO システムは、ggplot2 という 1 つの場所でのみ使用されています。 これはほとんど歴史的な偶然です。ggplot2は、私が可変型オブジェクトを必要としたため、protoを使用してスタートしました。これはmutatrや参照クラス、R6が作られるずっと前のことで、protoが唯一のゲームでした。

しかし、なぜ ggproto なのでしょうか? ggplot2に公式の拡張メカニズムを追加しようとしたとき、protoオブジェクトが別のパッケージで拡張されたときに問題を引き起こす大きな問題が見つかりました(メソッドは、拡張が追加されたパッケージではなく、ggplot2で評価されました) 。R6への変換を試みましたが、ggplot2のニーズには適合しませんでした。 protoを修正することもできましたが、それにはまずprotoがどのように機能しているかを正確に理解する必要があり、次にその変更がprotoの他のユーザーに影響を与えないことを確認する必要がありました。

言い方は悪いですが、これは新しいOOシステムを発明することが、実際には問題に対する正しい答えだったというケースです。 幸いなことに、Winston は今では OO システムを作るのが得意なので、ggproto を考え出すのに1日しかかかりませんでした。 このシステムは、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

まず、点の集合の凸包(c hull)を与える非常に単純な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")
)

最も重要な2つのコンポーネントは、計算を行う compute_group() メソッドと、統計が機能するためにどの美学が存在しなければならないかをリストアップした required_aes フィールドです。

次にレイヤー関数を書きます。残念ながら、初期の設計ミスで、これらを stat_() または geom_() と呼んでいました。すべてのレイヤーには、stat_()geom_() が含まれているため、より正確な表現となっています。

すべてのレイヤー関数は同じ形式で、関数の引数にデフォルトを指定してから、...params 引数に送って layer() 関数を呼び出します。 ... の中の引数は、geom の引数(stat wrapper を作っている場合)、stat の引数( geom wrapper を作っている場合)、または設定される美学のいずれかになります。 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() 関数をパッケージの名前空間にインポートする必要があることに注意してください)。

レイヤー関数ができたら、新しい stat を試してみましょう。

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

(ジオムのデフォルトを変更して、毎回 fill = NA を指定する必要がないようにする方法については、後で説明します)。

一旦この基本的なオブジェクトを書いてしまえば、ggplot2は多くのことを無料で提供してくれます。例えば、ggplot2は、各グループ内で一定の美観を自動的に保持します。

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 のパラメータ

より複雑な統計では、いくつかの計算を行います。簡単なバージョンの geom_smooth() を実装して、プロットにベストフィットの線を追加してみましょう。 ここでは、Stat を継承したStatLmと、レイヤ関数である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)

なお、レイヤの引数に新しいパラメータを明示的に含める 必要 はなく、 ... はいずれにせよ適切な場所に渡されます。 しかし、ユーザーがそれを知ることができるように、どこかに記録しておく必要があります。以下に簡単な例を示します。 注意点は @inheritParams ggplot2::stat_identity: これは stat_identity() で定義されたすべてのパラメーターのドキュメントを自動的に継承します。

#' @export
#' @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_lm()をエクスポートする必要があります。 また、基本的なオブジェクトを拡張したい場合には、 StatLm をエクスポートすることも考えられますが、これは慎重に行う必要があります。

デフォルトの選択

グループごとではなく、データセット全体に対して一度だけ実行すべき計算がある場合があります。 このような場合には、適切なデフォルト値を選択することが有効です。 例えば、密度の推定を行う場合、プロット全体で1つの帯域幅を選ぶのが妥当です。 以下の Stat は、各グループの “ベスト” なバンド幅の平均値を選択することにより、すべてのグループに1つのバンド幅を選択する stat_density() のバリエーションを作成します(これについての理論的な正当性はありませんが、不合理ではないと思われます)。

これを行うために、setup_params() メソッドをオーバーライドします。 このメソッドは、データとパラメータのリストを受け取り、更新されたリストを返します。

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() を使って有効数字数桁のみを表示します)。

変数名とデフォルトの美学

この stat は、もうひとつの重要なポイントを示しています。 この stat を他の geom で使用できるようにするには、y の代わりに density という変数を返す必要があります。そして、densityy に自動的にマッピングするように default_aes を設定し、ユーザーがそれをオーバーライドし、異なる geom で使用できるようにします。

StatDensityCommon <- ggproto("StatDensity2", Stat, 
  required_aes = "x",
  default_aes = aes(y = stat(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 = stat(density))) + 
  stat_density_common(bandwidth = 1, geom = "point")

しかし、この統計を area geom で使用すると、うまくいきません。area がお互いに重ならないのです。:

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

これは,各密度が独立して計算されているため,推定される x が揃わないためです。 この問題は,setup_params() でデータの範囲を一度計算することで解決できます.

StatDensityCommon <- ggproto("StatDensityCommon", Stat, 
  required_aes = "x",
  default_aes = aes(y = stat(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 = stat(density))) + 
  stat_density_common(bandwidth = 1, geom = "raster")

演習問題

  1. alphahull パッケージのように、alpha hull を計算するために stat_chull を拡張します。 新しいstatは、alphaという引数を取る必要があります。

  2. 最終バージョンの StatDensityCommon を、ユーザが minmax を指定できるように変更する。 layer 関数と compute_group() メソッドの両方を変更する必要があります。

    注意:レイヤー関数にパラメータを追加する際には注意が必要です。 次のような 名前 col, color, pch, cex, lty, lwd, srt, adj, bg, fg, min, max は、 ベースとなるグラフィカルなパラメータ名に合わせて、意図的に名前を変更しています。 グラフィカルなパラメータ名に合わせて意図的に改名されています。 例えば、レイヤーに min として渡された値は、setup_params のリストには ymin と表示されます。 レイヤのパラメータにこれらの名前を使わないことをお勧めします。

  3. StatLmggplot2::StatSmooth を比較対照してください。 どのような重要な違いが、StatSmoothStatLm よりも複雑にしているでしょう?

新しい geom の作成

ggplot2 は grid の上に構築されているので、grid を使った描画の基本を知っておく必要があります。 もし、本気で新しいジオムを追加したいのであれば、Paul Murrell 氏のR graphicsを購入することをお勧めします。 これを読めば、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_params, coord) {
    coords <- coord$transform(data, panel_params)
    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つの部分のフィールド/メソッドを常に提供する必要があります。

draw_panel()`には3つの引数があります。

データを変換するには、 panel_paramscoord を一緒に使う必要があります。これにより、位置変数が0-1の範囲にスケーリングされたデータフレームが作成されます。このデータを使って、grid grob関数を呼び出します。(非Cartesian座標系の変換は非常に複雑です。既存のggplot2 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_params, coord) {
    n <- nrow(data)
    if (n <= 2) return(grid::nullGrob())

    coords <- coord$transform(data, panel_params)
    # 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)

ここではいくつか注意すべき点があります。

これを実際の GeomPolygon と比較してみるといいでしょう。これが draw_panel() をオーバーライドしているのがわかると思いますが、これは polygonGrob() が一度の呼び出しで複数のポリゴンを生成するようにいくつかのトリックを使っているからです。これはかなり複雑ですが、パフォーマンスは向上します。

既存の geom からの継承

既存の geom にちょっとした修正を加えたい場合があります。 このような場合、Geom を継承するのではなく、既存のサブクラスを継承することができます。 例えば、GeomPolygon のデフォルトを変更して、StatChull との相性を良くしたいとします。

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()

しかし、凸包は主にポリゴンでできているので、ここではそれが適切と思われます。

練習問題

  1. GeomPoint “と”GeomSimplePoint "を比較対照してください。

  2. GeomPolygonGeomSimplePolygon を比較対照してください。

複数の向きを持つ geom と stat

いくつかのレイヤは特定の方向性を持っています。 例えば、geom_bar() は、1つの軸に沿ってバーを表示し、geom_line() は、1つの軸で入力をソートする、などです。 これらの geom を別の方向で使用するためのオリジナルのアプローチは,x軸とy軸の位置を切り替えるためにプロットに coord_flip() を追加することでした. ggplot2 v3.3 以降では、すべての geom は、coord_flip() がなくても、両方の方向でネイティブに動作します。 このメカニズムは、レイヤーがマッピングされたデータから方向を推測しようとするか、あるいは、orientation パラメータを使ってユーザーから指示を受けるというものです。 この機能を新しい stats や geom で再現するには、いくつかのステップが必要です。 ここでは、ゼロから新しいものを作るのではなく、例として箱ひげ図のレイヤーを見てみましょう。

全方位の stat

実際に方向を推測するのは、setup_params()has_flipped_aes() ヘルパーを使って行います。

StatBoxplot$setup_params
#> <ggproto method>
#>   <Wrapper function>
#>     function (...) 
#> f(...)
#> 
#>   <Inner function (f)>
#>     function (data, params) 
#> {
#>     params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = TRUE, 
#>         group_has_equal = TRUE, main_is_optional = TRUE)
#>     data <- flip_data(data, params$flipped_aes)
#>     has_x <- !(is.null(data$x) && is.null(params$x))
#>     has_y <- !(is.null(data$y) && is.null(params$y))
#>     if (!has_x && !has_y) {
#>         abort("stat_boxplot() requires an x or y aesthetic.")
#>     }
#>     params$width <- params$width %||% (resolution(data$x %||% 
#>         0) * 0.75)
#>     if (is.double(data$x) && !has_groups(data) && any(data$x != 
#>         data$x[1L])) {
#>         warn(glue("Continuous {flipped_names(params$flipped_aes)$x} aesthetic -- did you forget aes(group=...)?"))
#>     }
#>     params
#> }

続いて、flip_data() を呼び出して,データが水平方向になっていることを確認します。 残りのコードでは、データが特定の方向にあると仮定することができます。 同じことが setup_data() でも起こります。:

StatBoxplot$setup_data
#> <ggproto method>
#>   <Wrapper function>
#>     function (...) 
#> f(...)
#> 
#>   <Inner function (f)>
#>     function (data, params) 
#> {
#>     data <- flip_data(data, params$flipped_aes)
#>     data$x <- data$x %||% 0
#>     data <- remove_missing(data, na.rm = params$na.rm, vars = "x", 
#>         name = "stat_boxplot")
#>     flip_data(data, params$flipped_aes)
#> }

データは(必要に応じて)反転され、操作され、返されるときに反転されます。

計算中は、このようにflip_data()で挟んでいますが、データが返される直前には、データが反転されたかどうかを示すflipped_aes列も取得されます。これにより これにより、statはgeomに向きがすでに決定されていることを伝えることができます。

全方位型 geom

geom の設定はほとんど同じですが、いくつかの工夫があります。 has_flipped_aes()は、setup_params()でも使用されており、通常、statが与えるflipped_aes列からピックアップされます。 setup_data() では、位置調整の前に flipped_aes が存在することを確認するために、flipped_aes が再割り当てされることがよくあります。 これは、geom が向きを処理しない stat(多くの場合、stat_identity())と一緒に使用される場合に必要です。:

GeomBoxplot$setup_data
#> <ggproto method>
#>   <Wrapper function>
#>     function (...) 
#> f(...)
#> 
#>   <Inner function (f)>
#>     function (data, params) 
#> {
#>     data$flipped_aes <- params$flipped_aes
#>     data <- flip_data(data, params$flipped_aes)
#>     data$width <- data$width %||% params$width %||% (resolution(data$x, 
#>         FALSE) * 0.9)
#>     if (!is.null(data$outliers)) {
#>         suppressWarnings({
#>             out_min <- vapply(data$outliers, min, numeric(1))
#>             out_max <- vapply(data$outliers, max, numeric(1))
#>         })
#>         data$ymin_final <- pmin(out_min, data$ymin)
#>         data$ymax_final <- pmax(out_max, data$ymax)
#>     }
#>     if (is.null(params) || is.null(params$varwidth) || !params$varwidth || 
#>         is.null(data$relvarwidth)) {
#>         data$xmin <- data$x - data$width/2
#>         data$xmax <- data$x + data$width/2
#>     }
#>     else {
#>         data$relvarwidth <- data$relvarwidth/max(data$relvarwidth)
#>         data$xmin <- data$x - data$relvarwidth * data$width/2
#>         data$xmax <- data$x + data$relvarwidth * data$width/2
#>     }
#>     data$width <- NULL
#>     if (!is.null(data$relvarwidth)) 
#>         data$relvarwidth <- NULL
#>     flip_data(data, params$flipped_aes)
#> }

draw_*() メソッドでは、flip_data() の呼び出しの間に、データの操作を再び挟みます。 グロブを作成したり、他の geom からドローメソッドを呼び出したりする前に、データが反転していることを確認することが重要です。

必要な美観への対応

無指向性レイヤーには、通常、2種類の必須美観セットがあります。 どちらのセットを使用するかは、多くの場合、方向を知る方法です。 これを適切に処理するために、StatGeom クラスの required_aes フィールドは | (or) 演算子を理解します。 GeomBoxplot を見ると、これがどのように使われているかがわかります。

GeomBoxplot$required_aes
#> [1] "x|y"            "lower|xlower"   "upper|xupper"   "middle|xmiddle"
#> [5] "ymin|xmin"      "ymax|xmax"

これは ggplot2 に、| より前のすべての美学が必要であるか、| より後のすべての美学が必要であるかを指示します。

曖昧なレイヤー

レイヤーの中には、データの向きを明確に解釈できないものがあります。 典型的な例は geom_line() で、慣習的に x 軸に沿って表示されます。 データ自体にはそれを示すものはありません。 これらの geom では、ユーザーは orientation = "y" を設定することで、反転した方向を示さなければならない。 stat や geom は、データフォーマットに基づく推測をキャンセルするために、ambiguous = TRUEhas_flipped_aes() を呼び出します。 例として、GeomLinesetup_params()メソッドを見てみましょう。:

GeomLine$setup_params
#> <ggproto method>
#>   <Wrapper function>
#>     function (...) 
#> f(...)
#> 
#>   <Inner function (f)>
#>     function (data, params) 
#> {
#>     params$flipped_aes <- has_flipped_aes(data, params, ambiguous = TRUE)
#>     params
#> }

自分でテーマを作る

自分で完全なテーマを作る場合には、いくつか知っておくべきことがあります。

要素の上書き

デフォルトでは、新しいテーマ要素を追加すると、既存のテーマの値を継承します。例えば、以下のコードでは、キーカラーを赤に設定していますが、既存の塗りつぶし色を継承しています。

theme_grey()$legend.key
#> List of 5
#>  $ fill         : chr "grey95"
#>  $ colour       : logi NA
#>  $ size         : NULL
#>  $ linetype     : NULL
#>  $ inherit.blank: logi TRUE
#>  - 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 5
#>  $ fill         : chr "grey95"
#>  $ colour       : chr "red"
#>  $ size         : NULL
#>  $ linetype     : NULL
#>  $ inherit.blank: logi FALSE
#>  - 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 5
#>  $ fill         : NULL
#>  $ colour       : chr "red"
#>  $ size         : NULL
#>  $ linetype     : NULL
#>  $ inherit.blank: logi FALSE
#>  - attr(*, "class")= chr [1:2] "element_rect" "element"

グローバル要素

プロットのグローバルな外観に影響を与える要素は4つあります。

Element Theme function Description
line element_line() all line elements
rect element_rect() all rectangular elements
text element_text() all text
title element_text() all text in title elements (plot, axes & legend)

これらは、より具体的な設定に引き継がれるデフォルトのプロパティを設定します。 これらは、全体的な「背景」色や全体的なフォント設定(ファミリーやサイズなど)を設定するのに最も便利です。

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"))

一般的には、これらの値を変更することからテーマの作成を始めます。

完全と不完全

完全なテーマオブジェクトと不完全なテーマオブジェクトの違いを理解しておくと便利です。完全*なテーマオブジェクトとは、テーマ関数を complete = TRUE という属性で呼び出して生成されるものです。

テーマ関数 theme_grey()theme_bw() は完全なテーマ関数の例です。theme()` の呼び出しは 不完全 なテーマオブジェクトを生成します。これは、完全なテーマオブジェクトを返すのではなく、テーマオブジェクトの (ローカルな) 変更を表すからです。不完全なテーマを完全なテーマに追加すると、結果は完全なテーマになります。

完全なテーマと不完全なテーマは,ggplot オブジェクトに追加されたときに多少異なる動作をします.

新しい facet の作成

ggplot2 の拡張機能の中で、より困難な課題の一つは、新しい facet システムを作成することです。 その理由は、新しい facet を作成すると、画面上に(ほとんど)すべてのものがどのように描かれるかの責任を負うことになり、多くの人は、ggplot2 のレンダリングが構築されている gtablegrid を直接使用した経験がないからです。 もしあなたが facet 拡張に踏み込もうとするならば、上記のパッケージに習熟することを強くお勧めします。

ggplot2 の facet クラスは、広範囲のタスクの責任を負うので、非常に強力です。 facetオブジェクトの主なタスクは以下の通りです。

facet オブジェクトの主なタスクは以下の通りです。

機能を実装しなければならないこれら3つのタスクとは別に、いくつかの追加の拡張ポイントがあり、そこでは適切なデフォルトが提供されています。 これらは一般的には無視しても構いませんが、意欲的な開発者はこれらをオーバーライドして、さらにコントロールすることができます。

新しい facet クラスがどのように作成されるかを示すために、簡単に始めて、必要なメソッドを順に見ていき、単純にプロットを2つのパネルに複製する facet_duplicate() を作成します。 この後、より強力な可能性を示すために、少しいじってみましょう。

レイアウト指定の作成

facet の文脈におけるレイアウトとは、データとそれを格納するパネルとの間のマッピングを定義する data.frame であり、どの位置のスケールを使用すべきかを定義するものです。 出力には少なくとも PANEL, SCALE_X, SCALE_Y の列が含まれていなければなりませんが、データを正しいパネルに割り当てるためにもっと多くの列が含まれることもあります(facet_grid() は各パネルに関連付けられた facet 変数も返します)。 それでは、レイアウトの複製を定義する関数を作ってみましょう。

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

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

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

ggplot2 がどのデータをどこに置くべきかを知るためには、データをパネルに割り当てる必要があります。 マッピングステップの目的は、どのパネルに属しているかを示す PANEL 列をレイヤーデータに割り当てることです。

mapping <- function(data, layout, params) {
  if (is.null(data) || nrow(data) == 0) {
    return(cbind(data, PANEL = integer(0)))
  }
  rbind(
    cbind(data, PANEL = 1L),
    cbind(data, PANEL = 2L)
  )
}

ここでは、まず、空の data.frame が得られたかどうかを調べ、 データがない場合は、データを複製し、元のデータを1枚目のパネルに、新しいデータを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 クラスの組み立て

通常、すべてのメソッドはクラス定義の中で、GeomStat と同じように定義されます。 ここでは、順番に見ていけるように分割しています。 後は、関数を正しいメソッドに割り当て、コンストラクタを作成するだけです。

# 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()

facet をもっと活用する

上の例はかなり使い勝手が悪かったので、実際に使えるように拡張してみましょう。 ここでは、軸をY方向に変換したパネルを追加する facet を作成してみます。

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 (is.null(data) || nrow(data) == 0) {
      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 <- lapply(seq_len(max(layout$SCALE_X)), function(i) 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 accommodate 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
    if (params$horizontal) {
      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])
        panel_table <- gtable::gtable_add_grob(panel_table,
          axes$y$right[i], 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)
        panel_table <- gtable::gtable_add_grob(panel_table,
          axes$y$left[i], t = panel_pos_v, l = panel_pos_h[i],
          clip = "off")
      }
    } else {
        panel_table <- gtable::gtable_add_cols(panel_table, axis_width_r[1], panel_pos_h)
        panel_table <- gtable::gtable_add_grob(panel_table,
          axes$y$right, t = panel_pos_v, l = panel_pos_h + 1,
          clip = "off")
        panel_table <- gtable::gtable_add_cols(panel_table, axis_width_l[1], panel_pos_h - 1)
        panel_table <- gtable::gtable_add_grob(panel_table,
          axes$y$left, t = panel_pos_v, l = panel_pos_h,
          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 ブロックが発生しています。 一般的に、これは facet 拡張を記述する際の大きな課題であり、これらのメソッドを記述する際には非常に細心の注意を払う必要があります。

さて、話はここまでにして、私たちが作ったパワフルな facet 拡張が機能するかどうか見てみましょう。:

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

既存の facet 機能の拡張

facet クラスのレンダリング部分はしばしば困難な開発ステップであるため、既存の facet クラスを利用して様々な新しい facet 機能を実現することが可能です。 以下では、入力データをランダムにいくつかのパネルに分割する facet_bootstrap() クラスを作るために、facet_wrap() をサブクラス化します。

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_layoutmap_data のメソッドをインターセプトして、データを変数で分割する代わりに、 サンプリングパラメータ(n はパネルの数、prop は各パネルのデータの割合)に基づいて、行をパネルにランダムに割り当てるというものです。 ここで重要なのは、compute_layout が返すレイアウトが FacetWrap の有効なレイアウトであることです。 なぜなら、FacetWrapdraw_panel メソッドがすべての作業を行ってくれると期待しているからです。 したがって、FacetWrap や FacetGrid をサブクラス化する場合は、そのレイアウト仕様の性質を理解しておく必要があります。

演習問題

  1. FacetTransを書き換えて、変換のベクトルを受け取り、各変換ごとに追加のパネルを作成する。
  2. FacetWrap の実装に基づいて、FacetTrans を strip.placement のテーマ設定を考慮して書き換えてください。
  3. 同じデータで複数のレイヤーを追加することに関連して、FacetBootstrapにどのような注意点があるかを考える。