Rで様々な表を書く。
パラメータの多いStanの結果も美しい表に。

author: Unadon (見習い飯炊き兵) 動作環境:Mac OS Sierra 10.12.1; R version3.3.1; rstan 2.10.1

 

table1.jpeg table2.jpeg table3.jpeg gtable.jpeg gtableColor.jpeg formattableColor.jpeg

はじめに

Rを使う時、私はわざわざ表など使わず、”head(data)”なんかでデータの確認を済ませてしまったりすることが多いです。

でも、他人と共有するとなると、見せ方を考えなければならない。それで、面倒だけどエクセルにコピペして…とやっていました。

また、Rのコンソールに収まりきれないデータを確認したいときなども、何らかの手立てを考える必要があるとおもいます。

今回は、そんなデータの確認に使える”表の出力”についてまとめていきます。

本稿のお品書き

  1. package{DT}: dataframeをHTMLの表に一発変換(データが大きい場合有用)
  2. package{knitr}: dataframeをLatexやmarkdown記法の表に変換
  3. package{gtable&gridExtra}: dataframeを表で画像化
  4. package{formattable}: 魅せる表を作成
  5. 大規模なStanの結果をformattableでスクロール可能に見やすくする
  6. 最後に全てのコードをまとめ

よく使うので、tidyverseは最初に読み込んでおきましょう。

#データ成形用パッケージ
library(tidyverse)

1.package{DT}: dataframeをHTMLの表に一発変換(データが大きい場合有用)

一番シンプルなのはこれだと思います。

出力がHTMLのため、パワーポイントなどに貼り付けるのには向かないですが、便利で簡単です。

#
# 1.データフレームがそのまま表になる。ただし、HTMLのTable
#

library(DT) #DataTableパッケージ
DT::datatable(iris,  #第一引数にデータフレームを指定
              rownames = FALSE, #
              colnames= c("1","2","3","4","5"),
              caption = "DTpackage test")

このような結果が出力されます。RstudioのViewerに出てきでグリグリ動きます。

table1.jpeg

HTMLの状態で以下に載っけておきます。

HTMLShow 100 entry にすると、確認しやすいですね。ブログ状だと見にくいですが

2. package{knitr}: dataframeをLatexやmarkdown記法の表に変換

ブログを書く時やRmarkdownで使えます。

私が使っているブログjekyll-now2はmarkdownやhtmlで表がきれいに出ないので、若干悲しい。


#
# 2. データフレーム(表)を、markdown,LaTex,HTML,pandoc形式の
#    コードに変換する→LaTexやブログに貼る
#

library(knitr) #変換用パッケージの万能選手

#サンプルデータ
data<-iris[c(1:10),]
head(data)

#以下のkabel関数を実行し、Consoleに吐き出されたコードを
#LaTexならLaTexに貼り付けるだけ
kable(data, format = "html")
kable(data, format = "latex")
kable(data, format = "markdown")
kable(data, format = "pandoc")


markdown出力ですと、こういう形でConsoleにはりだされます。 あとは、コピペでOKです。便利。

kable(data, format = "markdown")


| Sepal.Length| Sepal.Width| Petal.Length| Petal.Width|Species |
|------------:|-----------:|------------:|-----------:|:-------|
|          5.1|         3.5|          1.4|         0.2|setosa  |
|          4.9|         3.0|          1.4|         0.2|setosa  |
|          4.7|         3.2|          1.3|         0.2|setosa  |
|          4.6|         3.1|          1.5|         0.2|setosa  |
|          5.0|         3.6|          1.4|         0.2|setosa  |
|          5.4|         3.9|          1.7|         0.4|setosa  |
|          4.6|         3.4|          1.4|         0.3|setosa  |
|          5.0|         3.4|          1.5|         0.2|setosa  |
|          4.4|         2.9|          1.4|         0.2|setosa  |
|          4.9|         3.1|          1.5|         0.1|setosa  |

3. package{gtable&gridExtra}: dataframeを表で画像化

パワポに表の画像を貼り付けたいときはこちら。

色や細かい形式にこだわりなければ3行で済みます。 基本的な流れは、 まず、データフレームを用意し(行番号などが気になる方は削除したり変えたり)、 次に、データフレームをセルの配置情報を持ったデータ型に変換し(gridExtra::tableGrob())、 最後に、grid.draw()で描画です。

#
#  3. データフレーム(表)を”画像”で出力する
#

library(gtable)   #表を書くやつ
library(gridExtra) #配置情報を含むデータに変換
library(grid) 

#RowNameを変えて使ってみたいので、SubNoを行名に入れてみる
Sub<-c()
for (i in 1:nrow(data)){Sub[i]<-paste("sub",i)}
rownames(data)<-Sub


#セルの位置情報を持ったデータ型に変換
g <- gridExtra::tableGrob(data) 

#描画
grid.draw(g)

gtable.jpeg

いい感じです。

gtableの表に枠をつけたり、色を塗り重ねる

パワポかなんかでやったほうが断然はやいですが、データがコロコロ変わったりした場合の汎用性や、再現性はコードでやったほうがいいですね。

先程上で描画した、シンプルな表情報が格納されたgに、どんどんgtable_add_grob()で情報を継ぎ足していきます。

油絵で上から色を重ねたりするイメージです。

#枠つけたり色塗りしたい場合
g <- gtable::gtable_add_grob(g, #第一引数にデータを指定
                             grobs = rectGrob(gp=gpar(col="white",#枠線の色
                                                      fill="red", #Fillは塗りつぶし
                                                      lwd=5, #枠線の太さ
                                                      alpha=0.2)), #透過性
                             t = 2,  #Topの略。塗りつぶし枠の上限
                             b = nrow(g)-5, #bottomの略。枠の下限、行数をnrowで取得し指定すれば一番下まで
                             l = 2, #left。左側。  
                             r = ncol(g)-1#右側
                             )

#ggplot同様に、追加していけば色々な塗りつぶしや枠付ができる。
#次は緑の枠を表の下側につける
g <- gtable::gtable_add_grob(g, #第一引数にデータを指定
                             grobs = rectGrob(gp=gpar(col="white",#枠線の色
                                                      fill="green", #Fillは塗りつぶし
                                                      lwd=5, #枠線の太さ
                                                      alpha=0.2)), 
                             t = 7,  #Topの略。塗りつぶし枠の上限
                             b = nrow(g), #bottomの略。枠の下限、行数をnrowで取得し指定すれば一番下まで
                             l = 2, #left。左側。  
                             r = ncol(g)-1#右側
)

#なくても可
grid.newpage()

#描画
grid.draw(g)

よいしょ。

gtableColor.jpeg

うまい具合に枠線と塗りつぶし図形がつきました。

4. package{formattable}: 魅せる表を作成

これ以降は全てformattableを使っていきます。

魅せる表、伝えたいところを伝える表、わかった気にさせる表。

とにかく美しい表をHTML出力することができるので、有用です。

まずはインストールしましょう。

CRANからでも(install.packages())、devtoolsを使ってGithubから落としてもOKです。

#
#   4. formattableによる”伝えるための表”を作成
#       HTML形式で出力される。
#

#devtools::install_github("renkun-ken/formattable")
#install.packages("formattable")
library(formattable)

最もシンプルな表から

順番にやりましょう。まずは、データフレームをそのままformattableで出力してみます。

#
# 4.1. 最もシンプルな表をirisで
#
library(formattable)

#data.frame
iris %>% head(5) -> temp

#描画
formattable::formattable(temp)

formattable.jpeg

これを土台に、色々遊んでいくわけです。

表の中に横向き棒グラフを入れる

棒グラフ機能(color_bar())は便利です。数値情報が見やすい表と、値の大小や相対性を伝えやすい棒グラフが同時に描けるのです。

formattable(データ, list(色んな設定))をいれていきます。今回は、各列のデータのセルに棒グラフを入れていきます。

#
# 4.2. irisの各列の値に従って棒グラフを入れるcolor_barを用いる。
#
library(formattable)
#dataframe
iris %>% head(5) -> temp

#描画
formattable::formattable(temp,#第一引数にデータを。第二引数にリストを入れる。
                         list(Sepal.Length=color_bar("tomato"), #データフレームの列名 = color_bar(”色”)
                              Sepal.Width=color_bar("steelblue"),
                              Petal.Length=color_bar("olivedrab"),
                              Petal.Width=color_bar("orange")))

formattableColor.jpeg

値が似てるので棒グラフ感が出ませんでしたが、出力できました。

セルの塗りつぶし・ランキング・文字のフォントや記号の追加

irisではない新しいデータフレームをつくってから、いろいろといじってみます。

まずはデータフレームを作成

df <- data.frame(
    ID = sample(paste0("Sub", 1:10), 10, replace = TRUE),
    age = c(12, 14, 18, 18, 19, 15, 18, 23, 30, 16),
    grade = c("C", "A", "A", "C", "B", "B", "B", "A", "C", "C"),
    test1_score = c(6.9, 9.5, 5.6, 8.9, 3.1, 9.3, 7.3, 9.9, 8.5, 8.6),
    test2_score = c(7.1, 6.1, 9.2, 5.1, 8.9, 5.5, 9.2, 6.3, 9.1, 8.8),
    final_score = c(9, 5.3, 9.4, 8.3, 9, 8.9, 7.25, 6.6, 9.8, 5.7),
    pass = c(TRUE, FALSE, TRUE, FALSE, TRUE, TRUE, TRUE, FALSE, FALSE, FALSE),
    stringsAsFactors = FALSE)

head(df)

つづいて、formattable(df, list(列名= , 列名= …))の列名=以降に色々指定を入れていきます。

・ color_tile() : セルの塗りつぶし

2色までの指定が可能です。値の昇順で色がグラデーションします。

・ formatter():データ値によって色を変えたりする。

”span”はデフォルト。style=で色などの設定をしていくのですが、そのまま 列名のデータがx ~のxにはいります。

「xには~の後の設定を適用しますよ」と読むことができます。

#
#  4.3 セルの塗りつぶし・ランキング・文字のフォントや記号の追加
#

library(formattable)

#上で作成したdfをつかって表を作成
formattable(df, list(
    age = color_tile("white", "orange"), # 年齢は高いほど白→オレンジへ
    grade = formatter("span", #grade の列について、次の行で色々指定。"span"は気にしない。デフォルト。
                      style = x ~ ifelse(x == "A", style(color = "green", font.weight = "bold"), NA)),
    test1_score = color_bar("tomato"),#test1の得点には、棒グラフ表示をつける。色は”tomato”。Rのデフォルトカラーの一つ
    test2_score = color_bar("steelblue"),
    final_score = formatter("span",#ランキング昨日の追加
                            style = x ~ style(color = ifelse(rank(-x) <= 3, "green", "gray")),
                            x ~ sprintf("%.2f (rank: %g)", x, rank(-x))),
    pass = formatter("span", #
                           style = x ~ style(color = ifelse(x, "green", "red")),
                           x ~ icontext(ifelse(x, "ok", "remove"), ifelse(x, "OK", "NO")))
))

よいしょ。きれいですね。

5. 大規模なStanの結果をformattableでスクロール可能に見やすくする

ここまでに紹介したformattableの使い方で、 Stanの推定結果をまとめて見たいと思います。

私はよくパラメータが10000個以上のモデルで推定をするので、推定結果の出力が一望できるのは本当にありがたい。

今回は、パラメータ16個くらい?の多変量の相関モデルでやってみます。ブログが重くなるので。

#
#   5. Stanの結果をformaatableで
#

#library and directory
library(rstan)
library(formattable)

rstan_options(auto_write = TRUE)
options(mc.cores = parallel::detectCores())

#
# 目的: 多変量間の相関係数の推定(Pearson)
#

#Initaial Settings-------------------------------------------
#サンプリング数
iterations =c(2000)
#Warm-up数
warmup=c(1000)
#チェーン数
chains=c(3)
#thinning
thin =c(1)
#推定に使用するパラメータ
parameters=c("rho","sigma","Sig") #log_likは必ず最後
#あとで結果を確認したいパラメータ
parameters2<-c("rho")

#データセットの読み込み(行は参加者,列は変数。Headerあり)
#read data サンプルデータ
dat<-iris


#変数間相関を求めたいデータの列名
varNames<-c("Sepal.Length","Sepal.Width","Petal.Length","Petal.Width")

#Data shaping
Dat<-data.matrix(dat[,varNames])

#------------------------------------------------------------


#Number of variables and Subjects
Nvar<-length(Dat[1,])
Nsub<-length(Dat[,1])

#sqrt(Cov)*SD matrix
spd<-cov(Dat)*(Nsub-1)


modelCorr <-"
data {
    int Nsub;
int Nvar;
matrix[Nvar,Nvar] spd;
}

parameters{
vector<lower=0>[Nvar]sigma;
corr_matrix[Nvar]rho;
}

transformed parameters{
cov_matrix[Nvar] Sig;
Sig = quad_form_diag(rho,sigma);
}

model{
//sigma ~ cauchy(0,5);
rho ~ lkj_corr(1);//uninformed prior
spd ~ wishart(Nsub-1,Sig);
}

"

#data and parameters to be passed on stan
datastan = list(Nsub=Nsub,Nvar=Nvar,spd=spd)

#StanFit
fit<-stan(model_code=modelCorr,
          data=datastan,pars=parameters,
                  iter = iterations,chains = chains,thin = thin)


ここまでで、Stanの推定が完了しました。

ここから結果を見てみます。summary(fit)$summaryで結果の要約が出力されます。

私はseとか50%タイルとか特にいらないので、列を絞って取り出しています。

#Summary
Summary<-summary(fit)$summary[,c(1,3,4,8,9,10)]
print(Summary)

いつもならこうです。

超絶見にくい。

summarySummary.jpeg

formattableでStanの推定結果の要約をまとめる

上記で格納したSummaryをつかって、表を作っていきます。

特に皆様はコードをいじることなく、 各々が実行したモデルの結果をSummary<-summary(フィットfitなど)$summaryしてくだされば、あとは以下のコードを実行するだけでOKです。

#結果をデータフレームに
df<-data.frame(Summary)
#RhatのたまにあるNaNは数値認識されないのでゼロで置き換え
df$Rhat[is.nan(df$Rhat)]<-0
#小数点第3ケタまでにする
for(i in 1 : length(df)){df[,i]<-digits(df[,i],3)}
#lp___を取り除く
df<-df[-length(df$mean),]

#結果を表で描画
formattable(df, list(
    mean = formatter("span",style = x ~ style(color=ifelse(x <0, "steelblue","tomato"))),
    sd = color_bar("orange"),
    X2.5. = formatter("span",style = x ~ ifelse(x <0, style(color = "steelblue", font.weight = "bold"),NA)),
    X97.5. = formatter("span",style = x ~ ifelse(x <0, style(color = "steelblue", font.weight = "bold"),NA)),
    n_eff = formatter("span",style = x ~ style(color = ifelse(rank(-x) <= c(length(df$n_eff)-1), "gray", "tomato")),
                             x ~ sprintf("%.2f (rank: %g)", x, rank(-x))),
    Rhat = formatter("span", x ~digits(x,2),
                             style = x ~ style(color = ifelse(x>=1.1, "tomato", "green")),
                             x ~ icontext(ifelse(x<1.1, "ok", "remove"), ifelse(x<1.1, "Yes", "No")))
))

よいしょ。

超絶見やすい!

最後に

formattableが採用するRcolorsの名前一覧を出しておきます。

Rcolors.jpeg

このサイトからコード等を引用しています。

# 1.Define R Color Data ----
# RGB codes
color.rgb <- t(col2rgb(colors()))
# Hexadecimal codes
color.hex <- rgb(color.rgb[,1], color.rgb[,2], color.rgb[,3], maxColorValue = 255)
# Text highlighting
color.text <- ifelse(apply(color.rgb, 1, mean) > 127, "black", "white")
# Consolidate
color.df <- data.frame(name = colors(),
                       red = color.rgb[, "red"],
                       green = color.rgb[, "green"],
                       blue = color.rgb[, "blue"],
                       hex = color.hex,
                       text = color.text)

#Plot R Colors By Name ----
# configure graphical device
n.col <- 11
n.row <- 60
par(pin = c(11.692, 6.267), mai=c(0.5, 0.5, 0.5, 0.5))
# create plot
plot(c(0, n.col), c(0, n.row), 
     type = "n", 
     bty = "n", 
     ylab = "", 
     xlab = "", 
     axes = FALSE)
title("R Colors By Name")

for(i in 1:n.col){
    color.count <- (i-1) * n.row
    color.mod <- length(colors()) - color.count
    y.val <- ifelse(color.mod < n.row, n.row - color.mod + 1, 1)
    color.names <- as(color.df[color.count + 1:n.row, "name"], "character")
    rect(i - 1, y.val - 0.5, i, n.row:y.val + 0.5, border = "black", col = color.names)
    text.color <- as(color.df[color.count + 1:n.row, "text"], "character")
    text(i-0.5, n.row:y.val, labels = color.names, cex = 0.5, col = text.color)
}

# reset graphical device
par(op)

Enjoy!!

6. 全てのまとめコード

##############################################
# Rで表を扱う
##############################################
invisible({rm(list=ls());gc();gc()})

#データ成形用パッケージ
library(tidyverse)

#Index-----------------------------------------------------------------
# 1. package{DT}: dataframeをHTMLの表に一発変換(データが大きい場合有用)
# 2. package{knitr}: dataframeをLatexやmarkdown記法の表に変換
# 3. package{gtable&gridExtra}: dataframeを表で画像化
# 4. package{formattable}: 美しい魅せる表を作成
# 5. 大規模なStanの結果をformattableでスクロール可能に見やすくする
#----------------------------------------------------------------------

#
#
# 1.データフレームがそのまま表になる。ただし、HTMLのTable
#
#

library(DT)
DT::datatable(iris, 
              rownames = FALSE,
              colnames= c("萼の長さ","萼の幅","花弁の長さ","花弁の幅","アヤメの品種"),
              caption = "DTpackage test")

#
#
# 2. データフレーム(表)を、markdown,LaTex,HTML,pandoc形式の
#    コードに変換する→LaTexやブログに貼る
#
#

library(knitr) #変換用パッケージの万能選手

#サンプルデータ
data<-iris[c(1:10),]
head(data)

#以下のkabel関数を実行し、Consoleに吐き出されたコードを
#LaTexならLaTexに貼り付けるだけ
kable(data, format = "html")
kable(data, format = "latex")
kable(data, format = "markdown")
kable(data, format = "pandoc")





#
#
#  3. データフレーム(表)を”画像”で出力する
#
#

library(gtable)   #表を書くやつ
library(gridExtra) #表を空間上の配置データに変換
library(grid) #何やってるかわからん

#RowNameを変えて使ってみたいので、SubNoを行名に入れてみる
Sub<-c()
for (i in 1:nrow(data)){Sub[i]<-paste("sub",i)}
rownames(data)<-Sub


#あとはデータフレームを突っ込んだら全部やってくれる

#gridExtraのtableGrobでデータフレームを
#セルの位置情報を持ったデータ型に変換
g <- gridExtra::tableGrob(data) 

#描画
grid.draw(g)

#枠つけたり色塗りしたい場合
g <- gtable::gtable_add_grob(g, #第一引数にデータを指定
                             grobs = rectGrob(gp=gpar(col="white",#枠線の色
                                                      fill="red", #Fillは塗りつぶし
                                                      lwd=5, #枠線の太さ
                                                      alpha=0.2)), 
                             t = 2,  #Topの略。塗りつぶし枠の上限
                             b = nrow(g)-5, #bottomの略。枠の下限、行数をnrowで取得し指定すれば一番下まで
                             l = 2, #left。左側。  
                             r = ncol(g)-1#右側
                             )

#ggplot同様に、追加していけば色々な塗りつぶしや枠付ができる
g <- gtable::gtable_add_grob(g, #第一引数にデータを指定
                             grobs = rectGrob(gp=gpar(col="white",#枠線の色
                                                      fill="green", #Fillは塗りつぶし
                                                      lwd=5, #枠線の太さ
                                                      alpha=0.2)), 
                             t = 7,  #Topの略。塗りつぶし枠の上限
                             b = nrow(g), #bottomの略。枠の下限、行数をnrowで取得し指定すれば一番下まで
                             l = 2, #left。左側。  
                             r = ncol(g)-1#右側
)

#なくても可
grid.newpage()

#描画
grid.draw(g)




#
#
#   4. formattableによる”伝えるための表”を作成
#       HTML形式で出力される
#           今回は4つの例を用いる
#

#devtools::install_github("renkun-ken/formattable")
#install.packages("formattable")
library(formattable)


#
# 4.1. 最もシンプルな表をirisで
#
library(formattable)
iris %>% head(5) -> temp
formattable::formattable(temp)


#
# 4.2. irisの各列の値に従って棒グラフを入れるcolor_barを用いる。
#
library(formattable)
formattable::formattable(temp,
                         list(Sepal.Length=color_bar("tomato"),
                              Sepal.Width=color_bar("steelblue"),
                              Petal.Length=color_bar("olivedrab"),
                              Petal.Width=color_bar("orange")))
                              
#
#
#  4.3. セルの塗りつぶし、条件でフォントの色変更、ランキング
#
#
library(formattable)
df <- data.frame(
    ID = sample(paste0("Sub", 1:10), 10, replace = TRUE),
    age = c(12, 14, 18, 18, 19, 15, 18, 23, 30, 16),
    grade = c("C", "A", "A", "C", "B", "B", "B", "A", "C", "C"),
    test1_score = c(6.9, 9.5, 5.6, 8.9, 3.1, 9.3, 7.3, 9.9, 8.5, 8.6),
    test2_score = c(7.1, 6.1, 9.2, 5.1, 8.9, 5.5, 9.2, 6.3, 9.1, 8.8),
    final_score = c(9, 5.3, 9.4, 8.3, 9, 8.9, 7.25, 6.6, 9.8, 5.7),
    pass = c(TRUE, FALSE, TRUE, FALSE, TRUE, TRUE, TRUE, FALSE, FALSE, FALSE),
    stringsAsFactors = FALSE)

head(df)


formattable(df, list(
    age = color_tile("white", "orange"),
    grade = formatter("span",
                      style = x ~ ifelse(x == "A", style(color = "green", font.weight = "bold"), NA)),
    test1_score = color_bar("tomato"),
    test2_score = color_bar("steelblue"),
    final_score = formatter("span",
                            style = x ~ style(color = ifelse(rank(-x) <= 3, "green", "gray")),
                            x ~ sprintf("%.2f (rank: %g)", x, rank(-x))),
    pass = formatter("span", 
                           style = x ~ style(color = ifelse(x, "green", "red")),
                           x ~ icontext(ifelse(x, "ok", "remove"), ifelse(x, "OK", "NO")))
))


#
#
#   5. Stanの結果をformaatableで
#
#


#library and directory
library(rstan)

rstan_options(auto_write = TRUE)
options(mc.cores = parallel::detectCores())

#
# 目的: 多変量間の相関係数の推定(Pearson)
#

#Options-----------------------------------------------------
# 1. Convergence Diagnosis: 収束診断 
# 2. Parameters Visualization of Correlation Coefficients
# 3. MAP estimate 
#------------------------------------------------------------




#Initaial Settings-------------------------------------------
#サンプリング数
iterations =c(2000)
#Warm-up数
warmup=c(1000)
#チェーン数
chains=c(3)
#thinning
thin =c(1)
#推定に使用するパラメータ
parameters=c("rho","sigma","Sig") #log_likは必ず最後
#あとで結果を確認したいパラメータ
parameters2<-c("rho")

#データセットの読み込み(行は参加者,列は変数。Headerあり)
#dat<-read.csv("iris.csv")
#read data サンプルデータ
dat<-iris


#変数間相関を求めたいデータの列名
varNames<-c("Sepal.Length","Sepal.Width","Petal.Length","Petal.Width")

#Data shaping
Dat<-data.matrix(dat[,varNames])

#------------------------------------------------------------


#Number of variables and Subjects
Nvar<-length(Dat[1,])
Nsub<-length(Dat[,1])

#sqrt(Cov)*SD matrix
spd<-cov(Dat)*(Nsub-1)


modelCorr <-"
data {
    int Nsub;
int Nvar;
matrix[Nvar,Nvar] spd;
}

parameters{
vector<lower=0>[Nvar]sigma;
corr_matrix[Nvar]rho;
}

transformed parameters{
cov_matrix[Nvar] Sig;
Sig = quad_form_diag(rho,sigma);
}

model{
//sigma ~ cauchy(0,5);
rho ~ lkj_corr(1);//uninformed prior
spd ~ wishart(Nsub-1,Sig);
}

"

#data and parameters to be passed on stan
datastan = list(Nsub=Nsub,Nvar=Nvar,spd=spd)

#StanFit
fit<-stan(model_code=modelCorr,
          data=datastan,pars=parameters,
                  iter = iterations,chains = chains,thin = thin)

#Summary
Summary<-summary(fit)$summary[,c(1,3,4,8,9,10)]
print(Summary)



#結果をデータフレームに
df<-data.frame(Summary)
#RhatのたまにあるNaNは数値認識されないのでゼロで置き換え
df$Rhat[is.nan(df$Rhat)]<-0
#小数点第3ケタまでにする
for(i in 1 : length(df)){df[,i]<-digits(df[,i],3)}
#lp___を取り除く
df<-df[-length(df$mean),]




#結果を表で描画
formattable(df, list(
    mean = formatter("span",style = x ~ style(color=ifelse(x <0, "steelblue","tomato"))),
    sd = color_bar("orange"),
    X2.5. = formatter("span",style = x ~ ifelse(x <0, style(color = "steelblue", font.weight = "bold"),NA)),
    X97.5. = formatter("span",style = x ~ ifelse(x <0, style(color = "steelblue", font.weight = "bold"),NA)),
    n_eff = formatter("span",style = x ~ style(color = ifelse(rank(-x) <= c(length(df$n_eff)-1), "gray", "tomato")),
                             x ~ sprintf("%.2f (rank: %g)", x, rank(-x))),
    Rhat = formatter("span", x ~digits(x,2),
                             style = x ~ style(color = ifelse(x>=1.1, "tomato", "green")),
                             x ~ icontext(ifelse(x<1.1, "ok", "remove"), ifelse(x<1.1, "Yes", "No")))
))


# 1.Define R Color Data ----
# RGB codes
color.rgb <- t(col2rgb(colors()))
# Hexadecimal codes
color.hex <- rgb(color.rgb[,1], color.rgb[,2], color.rgb[,3], maxColorValue = 255)
# Text highlighting
color.text <- ifelse(apply(color.rgb, 1, mean) > 127, "black", "white")
# Consolidate
color.df <- data.frame(name = colors(),
                       red = color.rgb[, "red"],
                       green = color.rgb[, "green"],
                       blue = color.rgb[, "blue"],
                       hex = color.hex,
                       text = color.text)




#Plot R Colors By Name ----
# configure graphical device
n.col <- 11
n.row <- 60
par(pin = c(11.692, 6.267), mai=c(0.5, 0.5, 0.5, 0.5))
# create plot
plot(c(0, n.col), c(0, n.row), 
     type = "n", 
     bty = "n", 
     ylab = "", 
     xlab = "", 
     axes = FALSE)
title("R Colors By Name")

for(i in 1:n.col){
    color.count <- (i-1) * n.row
    color.mod <- length(colors()) - color.count
    y.val <- ifelse(color.mod < n.row, n.row - color.mod + 1, 1)
    color.names <- as(color.df[color.count + 1:n.row, "name"], "character")
    rect(i - 1, y.val - 0.5, i, n.row:y.val + 0.5, border = "black", col = color.names)
    text.color <- as(color.df[color.count + 1:n.row, "text"], "character")
    text(i-0.5, n.row:y.val, labels = color.names, cex = 0.5, col = text.color)
}

# reset graphical device
par(op)

Written on February 3, 2017