京橋のバイオインフォマティシャンの日常

南国のビーチパラソルの下で、Rプログラムを打ってる日常を求めて、、Daily Life of Bioinformatician in Kyobashi of Osaka

RでODE(常微分方程式)【R言語/ODEを用いて生化学の主要反応速度論モデルを数値的に解いてみたの巻】

はじめに

Rで、常微分方程式(ODE; Ordinary Differential Equation)の初期値問題を扱いたいと思います。

日本の生物系学部の講義では、あまり教えてくれないけども、 生化学・酵素化学の反応速度論は、ODEを一度解いて理解しないと 『酵素反応とは何か??』とかよく分からないまま、講義が終わってしまいます。

当時の私は、生化学で反応速度論をやっている人は「複雑な式を並べて反応モデル」を作り、なんて賢い研究者なのかと憧れを持っていました。 その後、実際には、反応速度論の基礎が分かれば、「誰でもできるやんけ」ということになりましたが。

当然ながら、複雑で解きにくいモデルとか何をモデル化するかとかいう課題もありますし、パソコンの計算性能がまだ脆弱だった時代にODEを解くのは大変な研究であったことは言うまでもありません。

仙人、ODEの課題は難しそうです。どうしましょう・・・

基本さえ分かれば、R言語の数値計算パッケージで簡単に解けてしまうものじゃよ。

それでは、本題に入っていきましょう。

解析解と数値解

数学的な問題の解は、「解析解」と「数値解」に大きく分けられて、両者は対義語ともなります。

解析解とは、数式を変形させて得られる解、つまりは解析式のことを言います。 解析解は必ずしも厳密解ではなく、近似解である場合もあります。

一方、数値解とは、実際に数値を代入して何らかのアルゴリズムを使用して、繰り返し計算して得られる解のことを言います。 ODEを数値的に解く場合、方程式に初期値を与えてみて、各項目の数値を計算することから、初期値問題の数値計算法とも呼ばれます。

解析解については、記事の補足で触れていますが、 今回実際に、Rでやるのは数値解析の内容となります。

今回扱う反応式の事例

  • 一次反応
  • 逐次反応
  • 可逆反応・不可逆反応
  • ミカエリス-メンテンの酵素反応モデル
  • 変則的な反応モデル

について、モデル式、R言語での実行プログラムと、反応モデルを解いた結果のモーションチャートなどを解説していきます。

実行環境

以下が、実行環境です。

実行環境
macOS Big Sur (バージョン11.5.2)
MacBook Air (M1, 2020)
チップ Apple M1
メモリ 16GB

パッケージ準備

今回使用する、Rパッケージを準備します。

#パッケージ・インストール
pack <- c("deSolve", "ggplot2", "animation", "tidyverse", "gganimate", "plotly", "htmltools")
install.packages(pack[!(pack %in% unique(rownames(installed.packages())))])

#ロード
for(n in 1:length(pack)){ eval(parse(text = paste0("library(", pack[n], ")"))) }; rm("n", "pack")

一次反応モデルの数値解析

一次反応モデル

まずは、最もシンプルなモデルである、一次反応モデルについて数値計算してみます。 簡単にして、[A]が減少して、それに伴い、[B]が生成されるモデルです。

それでは、Rで、一次反応モデルの連立方程式を定義します。

#連立方程式の定義
Kinetics <- function(t, c, parms){
  k1 <- parms$k1
  r <- rep(0, length(c))
  r[1] = -k1*c["A"]
  r[2] = k1*c["A"]
  return(list(r))}

次に、初期値を、[A]=1、[B]=0、k1=0.5に設定します。時間軸は0.1刻みにします。

cinitのベクトルは、各分子種の初期濃度です。[]は各濃度値であることを示します。 また、parmsには速度定数kをlist型で与えます。 速度定数kは、その値が大きくなると反応速度は速くなり、小さくなると遅くなります。

方程式の作り方としては、1つの矢印ごとに式を作ります。 左辺は状態ではなく、例えばd[A]/dtなので、時間tあたりの[A]の変化量ということになります。

また、重要なポイントとしては、矢印の元は変化量がマイナス(+)となり、矢印の先は変化量がプラス(+)となります。つまりは、速度定数kは必ずプラスの値としますので、[A]は-k[A]の速度で減少して、逆に[B]はk[A]の速度で増加するということになります。

#初期値
cinit <- c(A = 1, B = 0)
parms <- list(k1 = 0.5)

#時間軸
t <- seq(0, 10, by=0.1)

それでは、deSolve::ode関数で数値計算します。

#解析実行
Results <- deSolve::ode(y=cinit, times=t, 
                        func=Kinetics, parms=parms, method="lsoda")

これで、計算完了です。以下に、deSolve::odeの引数について解説します。

yは、ODEシステムの初期値 (状態)をベクトルで与えます。 ODEシステムにおける変数の現在の推定値です。 name属性がある場合、出力行列のラベルにその名前が使用されます。

timesは、出力の時間列で、timesの最初の値は初期時間にする必要があります。

funcには、時刻tにおけるODEシステム(モデル定義)の微分値を計算するR関数を与えます。 この関数では、y、times、parmsを定義します。 parmsでは、funcの関数に渡されるパラメータを定義します。

methodでは、使用する積分器を指定します。 rkMethodクラスのリスト、あるいは文字列で"lsoda"、"lsode"、"lsodes"、"lsodar"、"vode"、"daspk"、"euler"、"rk4"、"ode23"、"ode45"、"radau"、"bdf"、"bdf_d"、"adams"、"impAdams"あるいは"impAdams_d"、"iteration"のいずれかを指定します。 また、デフォルトで使用される積分器は、「lsoda」です。

それでは、数値計算の結果について観ていきます。

#結果表示
head(Results)
#     time         A          B
#[1,]  0.0 1.0000000 0.00000000
#[2,]  0.1 0.9512284 0.04877161
#[3,]  0.2 0.9048383 0.09516172
#[4,]  0.3 0.8607090 0.13929099
#[5,]  0.4 0.8187322 0.18126785
#[6,]  0.5 0.7788021 0.22119787

#簡易プロット(1) plot関数
plot(Results)

#簡易プロット(2) matplot関数
par(mgp=c(2.5, 1, 0))
matplot(Results[,1], Results[,2:3], type="l", lwd=1.5, xlab="Time", ylab="Abundance ratio", cex.lab=1.25)
legend("right", legend=c("A", "B"), col=c("black", "red"), pch="", lty=c(1,2), lwd=2, cex=1)

簡易プロット(1)

簡易プロット(2)

[A]が一次的に下がって、それに対して、[B]が一次的に増加していくのが分かると思います。

animationパッケージでモーションチャート作成

次に、animationパッケージでアニメーション図を作成してみます。

matplot関数とsaveGIF関数を組み合わせます。

#実行
animation::saveGIF({for(n in 1:nrow(Results)){
matplot(Results[,1][1:n], data.frame(Results[,2][1:n], Results[,3][1:n]), type="l", lty=1, lwd=3, col=c("black", "red"), xlab="Time", ylab="", xlim=c(0,8), ylim=c(0,1), cex.lab=2, cex.axis=2)
legend("right", legend=c("A", "B"), col=c("black", "red"), pch="", lty=1, lwd=3, cex=2)
matpoints(Results[,1][n], Results[,2][n], pch=16, col="black", cex=2)
matpoints(Results[,1][n], Results[,3][n], pch=16, col="red", cex=2)
}}, movie.name = "01_motion.gif", interval = 0.1, nmax = nrow(Results), ani.width = 600, ani.height = 600)

animationでのgifアニメーション

ggplot2でモーションチャート作成

モダンなRプログラミングということで、ggplotでモーションチャートを作成してみます。

#DF化
Dat <- data.frame(Results)

#データ調整
Dat$frame <- as.numeric(rownames(Dat))
Dat0 <- tidyr::gather(Dat, key=Mol, value= val, A, B, -c(frame, time))

#表示
head(Dat0)
#  time frame Mol       val
#1  0.0     1   A 1.0000000
#2  0.1     2   A 0.9512284
#3  0.2     3   A 0.9048383
#4  0.3     4   A 0.8607090
#5  0.4     5   A 0.8187322
#6  0.5     6   A 0.7788021

#フレーム補正のパラメータ
a <- nrow(Dat0)/length(unique(Dat0$Mol))
b <- max(Dat0$time)

#実行
p <- ggplot(Dat0, aes(x = time, y = val, color = Mol)) + 
  geom_point(size = 5, show.legend = TRUE) + 
  geom_path(size = 1, alpha = 0.5, show.legend = FALSE) + 
  gganimate::transition_reveal(along = frame) +
  labs(title = "一次反応モデル", subtitle = paste0("Time: {round(frame_along*b/a, 2)}")) +
  theme_gray(base_family = "HiraKakuPro-W3")

#gif画像の出力: 実行時間 15秒くらい
gganimate::animate(p, fps = 5, duration = 20, width = 700, height = 700,
        renderer = gifski_renderer("01_ggplot_motion.gif"))

ggplot2でのgifアニメーション

plot_lyでモーションチャート作成

最近マイブームのplot_lyでモーションチャートを作成します。 今回は、こっちをメインで使用します。

#累積ラインデータセットの作成関数
accumulate_by <- function(dat, var) {
  var <- lazyeval::f_eval(var, dat)
  lvls <- plotly:::getLevels(var)
  dats <- lapply(seq_along(lvls), function(x) {
    cbind(dat[var %in% lvls[seq(1, x)], ], X = lvls[[x]])
  })
  dplyr::bind_rows(dats)
}

#累積実行
Dat1 <- Dat0 %>% accumulate_by(~frame)

#表示
head(Dat1)
#  time frame Mol        val X
#1  0.0     1   A 1.00000000 1
#2  0.0     1   B 0.00000000 1
#3  0.0     1   A 1.00000000 2
#4  0.1     2   A 0.95122839 2
#5  0.0     1   B 0.00000000 2
#6  0.1     2   B 0.04877161 2

#plot_ly実行
fig <- plotly::plot_ly(Dat1,
    x = ~time, 
    y = ~val,  
    split = ~Mol,
    frame = ~X,
    type = 'scatter',
    mode = 'lines') %>%
  layout(title = '一次反応モデル', 
         plot_bgcolor = "#e5ecf650", 
         xaxis = list(title = 'Time'), 
         yaxis = list(title = 'Abundance ratio'), 
         legend = list(title=list(text='<b>Mol</b>')),
         margin = list(l = 80, r = 80, b = 80, t = 60, pad = 0)) %>% 
  animation_opts(frame = a, transition = 0, redraw = FALSE)

#作図
fig

#保存
fig %>% htmltools::save_html(file="01_plotly_motion.html")

https://kumes.github.io/Blog/R_ODE/01_plotly_motion.html

htmlリンクをクリックすると、実際のモーションチャートが見えます。

逐次反応モデルの数値解析

逐次反応モデル

次に、3つ以上の分子種が連続的に反応することを想定した、逐次反応モデルについて数値計算を行なってみます。

モデルとしては、3つの分子種(A, B, C)あるいは4つの分子種(A, B, C, D)を想定します。

それでは、Rで逐次反応モデルの連立方程式を定義します。

逐次反応モデル: 3つの分子種(A, B, C)

これは、AからB、BからCが逐次的に生成されるモデルです。

#連立方程式の定義
Kinetics <- function(t, c, parms){
  k1 <- parms$k1
  k2 <- parms$k2
  r <- rep(0, length(c))
  r[1] = -k1*c["A"]
  r[2] = k1*c["A"] - k2*c["B"]
  r[3] = k2*c["B"]
  return(list(r))}

次に、初期値を、[A]=1、[B]=0、[C]=0、k1=0.5、k2=0.4に設定します。時間軸は0.1刻みにします。

#初期値
cinit <- c(A = 1, B = 0, C = 0)
parms <- list(k1 = 0.5, k2 = 0.4)

#時間軸
t <- seq(0, 10, by=0.1)

それでは、deSolve::ode関数で数値計算します。

#解析実行
Results <- deSolve::ode(y=cinit, times=t, 
                        func=Kinetics, parms=parms, method="lsoda")

#簡易プロット
par(mgp=c(2.5, 1, 0))
matplot(Results[,1], Results[,2:ncol(Results)], type="l", lwd=1.5, xlab="Time", ylab="Abundance ratio", cex.lab=1.25)
legend("right", legend=colnames(Results)[2:ncol(Results)], 
       col=1:(ncol(Results)-1), pch="", lty=1:(ncol(Results)-1), lwd=2, cex=1)

簡易プロット

続いて、plot_lyでモーションチャートを作成します。

#累積ラインデータセットの作成関数
source("https://gist.githubusercontent.com/kumeS/c516415c9ab4d25a2a6ae078e4d87837/raw/5be7e171ae9ce03c6110fa6a1ccb20d69aa45412/accumulate_by.R")

#DF化・データ調整・累積化
Dat <- data.frame(Results)
Dat$frame <- as.numeric(rownames(Dat))
Dat0 <- tidyr::gather(Dat, key=Mol, value= val, A, B, C, -c(frame, time))
Dat1 <- Dat0 %>% accumulate_by(~frame)
a <- nrow(Dat0)/length(unique(Dat0$Mol))

#plot_ly実行
fig <- plotly::plot_ly(Dat1,
    x = ~time, 
    y = ~val,  
    split = ~Mol,
    frame = ~X,
    type = 'scatter',
    mode = 'lines') %>%
  layout(title = '逐次反応モデル: 3つの分子種', 
         plot_bgcolor = "#e5ecf650", 
         xaxis = list(title = 'Time'), 
         yaxis = list(title = 'Abundance ratio'), 
         legend = list(title=list(text='<b>Mol</b>')),
         margin = list(l = 80, r = 80, b = 80, t = 60, pad = 0)) %>% 
  animation_opts(frame = a, 
                 transition = 0,
                 redraw = FALSE)

#作図
fig

#保存
fig %>% htmltools::save_html(file="02_plotly_motion_3.html")

https://kumes.github.io/Blog/R_ODE/02_plotly_motion_3.html

htmlリンクをクリックすると、実際のモーションチャートが見えます。

逐次反応モデル: 4つの分子種(A, B, C, D)

これは、AからB、BからC、CからDが逐次的に生成されるモデルです。

#連立方程式の定義
Kinetics <- function(t, c, parms){
  k1 <- parms$k1
  k2 <- parms$k2
  k3 <- parms$k3
  r <- rep(0, length(c))
  r[1] = -k1*c["A"]
  r[2] = k1*c["A"] - k2*c["B"]
  r[3] = k2*c["B"] - k3*c["C"]
  r[4] = k3*c["C"]
  return(list(r))}

次に、初期値を、[A]=1、[B]=0、[C]=0、[D]=0、k1=0.5、k2=0.4、k3=0.3に設定します。時間軸は0.1刻みにします。

#初期値
cinit <- c(A = 1, B = 0, C = 0, D = 0)
parms <- list(k1 = 0.5, k2 = 0.4, k3 = 0.3)

#時間軸
t <- seq(0, 10, by=0.1)

それでは、deSolve::ode関数で数値計算します。

#解析実行
Results <- deSolve::ode(y=cinit, times=t, 
                        func=Kinetics, parms=parms, method="lsoda")

#簡易プロット
par(mgp=c(2.5, 1, 0))
matplot(Results[,1], Results[,2:ncol(Results)], type="l", lwd=1.5, xlab="Time", ylab="Abundance ratio", cex.lab=1.25)
legend("right", legend=colnames(Results)[2:ncol(Results)], 
       col=1:(ncol(Results)-1), pch="", lty=1:(ncol(Results)-1), lwd=2, cex=0.75)

簡易プロット

続いて、plot_lyでモーションチャートを作成します。

#累積ラインデータセットの作成関数
source("https://gist.githubusercontent.com/kumeS/c516415c9ab4d25a2a6ae078e4d87837/raw/5be7e171ae9ce03c6110fa6a1ccb20d69aa45412/accumulate_by.R")

#DF化・データ調整・累積化
Dat <- data.frame(Results)
Dat$frame <- as.numeric(rownames(Dat))
Dat0 <- tidyr::gather(Dat, key=Mol, value= val, A, B, C, D, -c(frame, time))
Dat1 <- Dat0 %>% accumulate_by(~frame)
a <- nrow(Dat0)/length(unique(Dat0$Mol))

#plot_ly実行
fig <- plotly::plot_ly(Dat1,
    x = ~time, 
    y = ~val,  
    split = ~Mol,
    frame = ~X,
    type = 'scatter',
    mode = 'lines') %>%
  layout(title = '逐次反応モデル: 4つの分子種', 
         plot_bgcolor = "#e5ecf650", 
         xaxis = list(title = 'Time'), 
         yaxis = list(title = 'Abundance ratio'), 
         legend = list(title=list(text='<b>Mol</b>')),
         margin = list(l = 80, r = 80, b = 80, t = 60, pad = 0)) %>% 
  animation_opts(frame = a, 
                 transition = 0,
                 redraw = FALSE)

#作図
fig

#保存
fig %>% htmltools::save_html(file="02_plotly_motion_4.html")

https://kumes.github.io/Blog/R_ODE/02_plotly_motion_4.html

htmlリンクをクリックすると、実際のモーションチャートが見えます。

平衡反応モデルの数値解析

平衡反応モデル

続いて、平衡反応モデルについて数値計算を行なってみます。

モデルとしては、後半の反応(k2)が可逆反応の場合と不可逆反応の場合とを想定します。

それでは、まずは、不可逆反応の平衡反応モデルの連立方程式を定義します。

平衡反応モデル① 不可逆反応

A、BとCの間の反応が可逆反応で、CからDへの反応が不可逆反応であるモデルを定義します。

#連立方程式の定義
Kinetics <- function(t, c, parms){
  k1 <- parms$k1
  k2 <- parms$k2
  k3 <- parms$k3
  r <- rep(0, length(c))
  r[1] = -k1*c["A"]*c["B"] + k2*c["C"]
  r[2] = -k1*c["A"]*c["B"] + k2*c["C"]
  r[3] = k1*c["A"]*c["B"] - k2*c["C"] - k3*c["C"]
  r[4] = k3*c["C"]
  return(list(r))}

次に、初期値を、[A]=1、[B]=0.8、[C]=0、[D]=0、k1=1、k2=0.8、k3=1に設定します。時間軸は0.1刻みにします。

#初期値
cinit <- c(A = 1, B = 0.8, C = 0, D = 0)
parms <- list(k1 = 1, k2 = 0.8, k3 = 1)

#時間軸
t <- seq(0, 10, by=0.1)

それでは、deSolve::ode関数で数値計算します。

#解析実行
Results <- deSolve::ode(y=cinit, times=t, 
                        func=Kinetics, parms=parms, method="lsoda")

#累積ラインデータセットの作成関数
source("https://gist.githubusercontent.com/kumeS/c516415c9ab4d25a2a6ae078e4d87837/raw/5be7e171ae9ce03c6110fa6a1ccb20d69aa45412/accumulate_by.R")

#DF化・データ調整・累積化
Dat <- data.frame(Results)
Dat$frame <- as.numeric(rownames(Dat))
Dat0 <- tidyr::gather(Dat, key=Mol, value= val, A, B, C, D, -c(frame, time))
Dat1 <- Dat0 %>% accumulate_by(~frame)
a <- nrow(Dat0)/length(unique(Dat0$Mol))

#plot_ly実行
fig <- plotly::plot_ly(Dat1,
    x = ~time, 
    y = ~val,  
    split = ~Mol,
    frame = ~X,
    type = 'scatter',
    mode = 'lines') %>%
  layout(title = '平衡反応モデル: 不可逆反応', 
         plot_bgcolor = "#e5ecf650", 
         xaxis = list(title = 'Time'), 
         yaxis = list(title = 'Abundance ratio'), 
         legend = list(title=list(text='<b>Mol</b>')),
         margin = list(l = 80, r = 80, b = 80, t = 60, pad = 0)) %>% 
  animation_opts(frame = a, transition = 0, redraw = FALSE)

#作図
fig

#保存
fig %>% htmltools::save_html(file="03_plotly_motion_1.html")

https://kumes.github.io/Blog/R_ODE/03_plotly_motion_1.html

htmlリンクをクリックすると、実際のモーションチャートが見えます。

平衡反応モデル② 可逆反応

次に、可逆反応の平衡反応モデルの連立方程式を定義します。

A、BとCの間の反応が可逆反応で、CからDへの反応も可逆な反応モデルを定義します。

#連立方程式の定義
Kinetics <- function(t, c, parms){
  k1 <- parms$k1
  k2 <- parms$k2
  k3 <- parms$k3
  k4 <- parms$k4
  r <- rep(0, length(c))
  r[1] = -k1*c["A"]*c["B"] + k2*c["C"]
  r[2] = -k1*c["A"]*c["B"] + k2*c["C"]
  r[3] = k1*c["A"]*c["B"] - k2*c["C"] - k3*c["C"] + k4*c["D"]
  r[4] = k3*c["C"] - k4*c["D"]
  return(list(r))}

次に、初期値を、[A]=1、[B]=0.8、[C]=0、[D]=0、k1=1、k2=0.8、k3=1、k4=0.8に設定します。時間軸は0.1刻みにします。

#初期値
cinit <- c(A = 1, B = 0.8, C = 0, D = 0)
parms <- list(k1 = 1, k2 = 0.8, k3 = 1, k4 = 0.8)

#時間軸
t <- seq(0, 10, by=0.1)

それでは、deSolve::ode関数で数値計算します。

#解析実行
Results <- deSolve::ode(y=cinit, times=t, 
                        func=Kinetics, parms=parms, method="lsoda")

#累積ラインデータセットの作成関数
source("https://gist.githubusercontent.com/kumeS/c516415c9ab4d25a2a6ae078e4d87837/raw/5be7e171ae9ce03c6110fa6a1ccb20d69aa45412/accumulate_by.R")

#DF化・データ調整・累積化
Dat <- data.frame(Results)
Dat$frame <- as.numeric(rownames(Dat))
Dat0 <- tidyr::gather(Dat, key=Mol, value= val, A, B, C, D, -c(frame, time))
Dat1 <- Dat0 %>% accumulate_by(~frame)
a <- nrow(Dat0)/length(unique(Dat0$Mol))

#plot_ly実行
fig <- plotly::plot_ly(Dat1,
    x = ~time, 
    y = ~val,  
    split = ~Mol,
    frame = ~X,
    type = 'scatter',
    mode = 'lines') %>%
  layout(title = '平衡反応モデル: 可逆反応', 
         plot_bgcolor = "#e5ecf650", 
         xaxis = list(title = 'Time'), 
         yaxis = list(title = 'Abundance ratio'), 
         legend = list(title=list(text='<b>Mol</b>')),
         margin = list(l = 80, r = 80, b = 80, t = 60, pad = 0)) %>% 
  animation_opts(frame = a, transition = 0, redraw = FALSE)

#作図
fig

#保存
fig %>% htmltools::save_html(file="03_plotly_motion_2.html")

https://kumes.github.io/Blog/R_ODE/03_plotly_motion_2.html

htmlリンクをクリックすると、実際のモーションチャートが見えます。

酵素化学への常微分方程式の応用

ミカエリス・メンテン式のプロット

次は、酵素化学分野でとても有名な、ミカエリス・メンテン速度論を取り扱います。 この式は、1913年にドイツの生化学者Leonor Michaelisとカナダの生化学者Maud L. Mentenによって提案されました。

通常、迅速平衡法あるいは定常状態法を仮定して、このミカエリス・メンテン式は導かれるが、ここでは、下記の「酵素反応 不可逆反応モデル」と「酵素反応 可逆反応モデル」という数値解析の課題として扱います。

酵素反応モデル

酵素反応 不可逆反応モデルの数値解析

それでは、酵素反応の不可逆反応モデルの連立方程式を定義します。

このモデルは、P(プロダクト)の生成が一方方向のモデルです。

#連立方程式の定義
Kinetics <- function(t, c, parms){
  k1 <- parms$k1
  k2 <- parms$k2
  k3 <- parms$k3
  r <- rep(0, length(c))
  r[1] = -k1*c["E"]*c["S"] + k2*c["ES"]
  r[2] = -k1*c["E"]*c["S"] + (k2+k3)*c["ES"]
  r[3] = k1*c["E"]*c["S"] - (k2+k3)*c["ES"]
  r[4] = k3*c["ES"]
  return(list(r))}

次に、初期値を、[S]=1、[E]=1、[ES]=0、[P]=0、k1=1、k2=0.8、k3=1に設定します。時間軸は0.1刻みにします。

#初期値
cinit <- c(S = 1, E = 1, ES = 0, P = 0)
parms <- list(k1 = 1, k2 = 0.8, k3 = 1)

#時間軸
t <- seq(0, 10, by=0.1)

それでは、deSolve::ode関数で数値計算します。

#解析実行
Results <- deSolve::ode(y=cinit, times=t, 
                        func=Kinetics, parms=parms, method="lsoda")

#累積ラインデータセットの作成関数
source("https://gist.githubusercontent.com/kumeS/c516415c9ab4d25a2a6ae078e4d87837/raw/5be7e171ae9ce03c6110fa6a1ccb20d69aa45412/accumulate_by.R")

#DF化・データ調整・累積化
Dat <- data.frame(Results)
Dat$frame <- as.numeric(rownames(Dat))
Dat0 <- tidyr::gather(Dat, key=Mol, value= val, S, E, ES, P, -c(frame, time))
Dat1 <- Dat0 %>% accumulate_by(~frame)
a <- nrow(Dat0)/length(unique(Dat0$Mol))

#plot_ly実行
fig <- plotly::plot_ly(Dat1,
    x = ~time, 
    y = ~val,  
    split = ~Mol,
    frame = ~X,
    type = 'scatter',
    mode = 'lines') %>%
  layout(title = '酵素反応: 不可逆反応モデル', 
         plot_bgcolor = "#e5ecf650", 
         xaxis = list(title = 'Time'), 
         yaxis = list(title = 'Abundance ratio'), 
         legend = list(title=list(text='<b>Mol</b>')),
         margin = list(l = 80, r = 80, b = 80, t = 60, pad = 0)) %>% 
  animation_opts(frame = a, transition = 0, redraw = FALSE)

#作図
fig

#保存
fig %>% htmltools::save_html(file="04_plotly_motion_1.html")

https://kumes.github.io/Blog/R_ODE/04_plotly_motion_1.html

htmlリンクをクリックすると、実際のモーションチャートが見えます。

基質過剰・酵素低量の条件下で 不可逆反応モデルの数値解析を行うと・・・

連立方程式は上記と同じで、基質濃度([S])を変えて、反応速度をプロットしてみます。

初期値を[E]=0.1、[ES]=0、[P]=0、k1=1、k2=0.8、k3=1に設定します。時間軸は0.1刻みにします。

[S]は、2、4、6、10、15、20...という感じで複数条件を設定します。

#時間軸
t <- seq(0, 10, by=0.1)

#初期値(1)
cinit <- c(S = 2, E = 0.1, ES = 0, P = 0)
parms <- list(k1 = 1, k2 = 0.8, k3 = 1)

#解析実行
Results1 <- deSolve::ode(y=cinit, times=t, 
                        func=Kinetics, parms=parms, method="lsoda")

#初期値(2)
cinit <- c(S = 4, E = 0.1, ES = 0, P = 0)
parms <- list(k1 = 1, k2 = 0.8, k3 = 1)

#解析実行
Results2 <- deSolve::ode(y=cinit, times=t, 
                        func=Kinetics, parms=parms, method="lsoda")

#初期値(3)
cinit <- c(S = 6, E = 0.1, ES = 0, P = 0)
parms <- list(k1 = 1, k2 = 0.8, k3 = 1)

#解析実行
Results3 <- deSolve::ode(y=cinit, times=t, 
                        func=Kinetics, parms=parms, method="lsoda")

#初期値(4)
cinit <- c(S = 10, E = 0.1, ES = 0, P = 0)
parms <- list(k1 = 1, k2 = 0.8, k3 = 1)

#解析実行
Results4 <- deSolve::ode(y=cinit, times=t, 
                        func=Kinetics, parms=parms, method="lsoda")

#初期値(5)
cinit <- c(S = 15, E = 0.1, ES = 0, P = 0)
parms <- list(k1 = 1, k2 = 0.8, k3 = 1)

#解析実行
Results5 <- deSolve::ode(y=cinit, times=t, 
                        func=Kinetics, parms=parms, method="lsoda")

#初期値(6)
cinit <- c(S = 20, E = 0.1, ES = 0, P = 0)
parms <- list(k1 = 1, k2 = 0.8, k3 = 1)

#解析実行
Results6 <- deSolve::ode(y=cinit, times=t, 
                        func=Kinetics, parms=parms, method="lsoda")

#初期値(7)
cinit <- c(S = 30, E = 0.1, ES = 0, P = 0)
parms <- list(k1 = 1, k2 = 0.8, k3 = 1)

#解析実行
Results7 <- deSolve::ode(y=cinit, times=t, 
                        func=Kinetics, parms=parms, method="lsoda")

#初期値(8)
cinit <- c(S = 50, E = 0.1, ES = 0, P = 0)
parms <- list(k1 = 1, k2 = 0.8, k3 = 1)

#解析実行
Results8 <- deSolve::ode(y=cinit, times=t, 
                        func=Kinetics, parms=parms, method="lsoda")

#初期値(9)
cinit <- c(S = 100, E = 0.1, ES = 0, P = 0)
parms <- list(k1 = 1, k2 = 0.8, k3 = 1)

#解析実行
Results9 <- deSolve::ode(y=cinit, times=t, 
                        func=Kinetics, parms=parms, method="lsoda")

#結合
Results.c <- data.frame(time=Results1[,c("time")],
                        P002=Results1[,c("P")],
                        P004=Results2[,c("P")],
                        P006=Results3[,c("P")],
                        P010=Results4[,c("P")],
                        P015=Results5[,c("P")],
                        P020=Results6[,c("P")],
                        P030=Results7[,c("P")],
                        P050=Results8[,c("P")],
                        P100=Results9[,c("P")])

それでは、deSolve::ode関数で数値計算します。

#累積ラインデータセットの作成関数
source("https://gist.githubusercontent.com/kumeS/c516415c9ab4d25a2a6ae078e4d87837/raw/5be7e171ae9ce03c6110fa6a1ccb20d69aa45412/accumulate_by.R")

#DF化・データ調整・累積化
Dat <- data.frame(Results.c)
Dat$frame <- as.numeric(rownames(Dat))
Dat0 <- tidyr::gather(Dat, key=Mol, 
                      value= val, P002, P004, P006, P010, P015, P020, P030, P050, P100, -c(frame, time))
Dat1 <- Dat0 %>% accumulate_by(~frame)
a <- nrow(Dat0)/length(unique(Dat0$Mol))

#plot_ly実行
fig <- plotly::plot_ly(Dat1,
    x = ~time, 
    y = ~val,  
    split = ~Mol,
    frame = ~X,
    type = 'scatter',
    mode = 'lines') %>%
  layout(title = '酵素反応: 基質可変での反応速度', 
         plot_bgcolor = "#e5ecf650", 
         xaxis = list(title = 'Time'), 
         yaxis = list(title = 'Abundance ratio'), 
         legend = list(title=list(text='<b>Mol</b>')),
         margin = list(l = 80, r = 80, b = 80, t = 60, pad = 0)) %>% 
  animation_opts(frame = a, transition = 0, redraw = FALSE)

#作図
fig

#保存
fig %>% htmltools::save_html(file="04_plotly_motion_kahen.html")

https://kumes.github.io/Blog/R_ODE/04_plotly_motion_kahen.html

次に、反応の初速を計算して、基質濃度[S]に対してプロットしてみます。

#表示
head(Results.c)

#DF作成
res <- data.frame(S=c(2, 4, 6, 10, 15, 20, 30, 50, 100),
                  V=NA)

#傾きの計算
res$V[1] <- lm(P002 ~ time, data = Results.c)$coefficients[2]
res$V[2] <- lm(P004 ~ time, data = Results.c)$coefficients[2]
res$V[3] <- lm(P006 ~ time, data = Results.c)$coefficients[2]
res$V[4] <- lm(P010 ~ time, data = Results.c)$coefficients[2]
res$V[5] <- lm(P015 ~ time, data = Results.c)$coefficients[2]
res$V[6] <- lm(P020 ~ time, data = Results.c)$coefficients[2]
res$V[7] <- lm(P030 ~ time, data = Results.c)$coefficients[2]
res$V[8] <- lm(P050 ~ time, data = Results.c)$coefficients[2]
res$V[9] <- lm(P100 ~ time, data = Results.c)$coefficients[2]

#プロット
par(mgp=c(2.5, 1, 0))
matplot(res$S, res$V, type="b", pch=21, lwd=1.5, xlab="[S]", ylab="Reaction rate (v)", cex.lab=1.25)

基質濃度と反応速度のプロット

基質濃度[S]に対して、反応速度(v、ここでは反応の初速となる)をプロットしますと、上記のような飽和曲線が得られます。

Vmaxは基質濃度が無限大のときの反応速度となります。 だいたい、0.1くらいに収束すると思われます。

また、Kmはミカエリス・メンテン定数と言い、v = Vmax /2(最大速度の半分の速度)を与える基質濃度として表されます。

ja.wikipedia.org

酵素反応 可逆反応モデルの数値解析

続いて、酵素反応の可逆反応モデルをやってみます

このモデルでは、P(プロダクト)の生成が可逆方向のモデルです。

それでは、その連立方程式を定義します。

#連立方程式の定義
Kinetics <- function(t, c, parms){
  k1 <- parms$k1
  k2 <- parms$k2
  k3 <- parms$k3
  k4 <- parms$k4
  r <- rep(0, length(c))
  r[1] = -k1*c["E"]*c["S"] + k2*c["ES"]
  r[2] = -k1*c["E"]*c["S"] + (k2+k3)*c["ES"] - k4*c["E"]*c["P"]
  r[3] = k1*c["E"]*c["S"] - (k2+k3)*c["ES"] + k4*c["E"]*c["P"]
  r[4] = k3*c["ES"] - k4*c["E"]*c["P"]
  return(list(r))}

次に、初期値を、[S]=1、[E]=1、[ES]=0、[P]=0、k1=1、k2=0.8、k3=1、k3=4に設定します。時間軸は0.1刻みにします。

#初期値
cinit <- c(S = 1, E = 1, ES = 0, P = 0)
parms <- list(k1 = 1, k2 = 0.8, k3 = 1, k4 = 0.5)

#時間軸
t <- seq(0, 10, by=0.1)

それでは、deSolve::ode関数で数値計算します。

#解析実行
Results <- deSolve::ode(y=cinit, times=t, 
                        func=Kinetics, parms=parms, method="lsoda")

#累積ラインデータセットの作成関数
source("https://gist.githubusercontent.com/kumeS/c516415c9ab4d25a2a6ae078e4d87837/raw/5be7e171ae9ce03c6110fa6a1ccb20d69aa45412/accumulate_by.R")

#DF化・データ調整・累積化
Dat <- data.frame(Results)
Dat$frame <- as.numeric(rownames(Dat))
Dat0 <- tidyr::gather(Dat, key=Mol, value= val, S, E, ES, P, -c(frame, time))
Dat1 <- Dat0 %>% accumulate_by(~frame)
a <- nrow(Dat0)/length(unique(Dat0$Mol))

#plot_ly実行
fig <- plotly::plot_ly(Dat1,
    x = ~time, 
    y = ~val,  
    split = ~Mol,
    frame = ~X,
    type = 'scatter',
    mode = 'lines') %>%
  layout(title = '酵素反応: 可逆反応モデル', 
         plot_bgcolor = "#e5ecf650", 
         xaxis = list(title = 'Time'), 
         yaxis = list(title = 'Abundance ratio'), 
         legend = list(title=list(text='<b>Mol</b>')),
         margin = list(l = 80, r = 80, b = 80, t = 60, pad = 0)) %>% 
  animation_opts(frame = a, transition = 0, redraw = FALSE)

#作図
fig

#保存
fig %>% htmltools::save_html(file="04_plotly_motion_2.html")

https://kumes.github.io/Blog/R_ODE/04_plotly_motion_2.html

htmlリンクをクリックすると、実際のモーションチャートが見えます。

変則的な反応システムでの数値計算

ここからは、少し変則な反応系について連立方程式を作成してみます。

四角型、逆コ型、菱形モデルと名付けています。

「□型」の反応モデル

「□型」の反応モデル

それでは、四角型の反応モデルの連立方程式を定義します。

#連立方程式の定義
Kinetics <- function(t, c, parms){
  k1 <- parms$k1
  k2 <- parms$k2
  k3 <- parms$k3
  k4 <- parms$k4
  k5 <- parms$k5
  r <- rep(0, length(c))
  r[1] = -k1*c["A"] - k3*c["A"] + k2*c["B"] + k4*c["DA"]
  r[2] = k1*c["A"] - k2*c["B"] - k3*c["B"]
  r[3] = k3*c["A"] - k4*c["DA"] - k5*c["DA"]
  r[4] = k3*c["B"] + k5*c["DA"]
  return(list(r))}

次に、初期値を、[A]=1、[B]=1、[DA]=0、[DB]=0、k1=1、k2=0.8、k3=1、k4 = 0.5、k5 = 1に設定します。時間軸は0.1刻みにします。

#初期値
cinit <- c(A = 1, B = 1, DA = 0, DB = 0)
parms <- list(k1 = 1, k2 = 0.8, k3 = 1, k4 = 0.5, k5 = 1)

#時間軸
t <- seq(0, 10, by=0.1)

それでは、deSolve::ode関数で数値計算します。

#解析実行
Results <- deSolve::ode(y=cinit, times=t, 
                        func=Kinetics, parms=parms, method="lsoda")

#累積ラインデータセットの作成関数
source("https://gist.githubusercontent.com/kumeS/c516415c9ab4d25a2a6ae078e4d87837/raw/5be7e171ae9ce03c6110fa6a1ccb20d69aa45412/accumulate_by.R")

#DF化・データ調整・累積化
Dat <- data.frame(Results)
Dat$frame <- as.numeric(rownames(Dat))
Dat0 <- tidyr::gather(Dat, key=Mol, value= val, A, B, DA, DB, -c(frame, time))
Dat1 <- Dat0 %>% accumulate_by(~frame)
a <- nrow(Dat0)/length(unique(Dat0$Mol))

#plot_ly実行
fig <- plotly::plot_ly(Dat1,
    x = ~time, 
    y = ~val,  
    split = ~Mol,
    frame = ~X,
    type = 'scatter',
    mode = 'lines') %>%
  layout(title = '四角型の反応モデル', 
         plot_bgcolor = "#e5ecf650", 
         xaxis = list(title = 'Time'), 
         yaxis = list(title = 'Abundance ratio'), 
         legend = list(title=list(text='<b>Mol</b>')),
         margin = list(l = 80, r = 80, b = 80, t = 60, pad = 0)) %>% 
  animation_opts(frame = a, transition = 0, redraw = FALSE)

#作図
fig

#保存
fig %>% htmltools::save_html(file="05_plotly_motion.html")

https://kumes.github.io/Blog/R_ODE/05_plotly_motion.html

「逆コの字」の反応モデル

「逆コの字」の反応モデル

逆コの字型という感じで、ここまでくると名前の付け方が適当になりますね。

#連立方程式の定義
Kinetics <- function(t, c, parms){
  k1 <- parms$k1
  k2 <- parms$k2
  k3 <- parms$k3
  k4 <- parms$k4
  k5 <- parms$k5
  r <- rep(0, length(c))
  r[1] = -k1*c["A"] - k3*c["A"] + k2*c["B"]
  r[2] = k1*c["A"] - k2*c["B"]
  r[3] = k3*c["A"] - k4*c["DA"]
  r[4] = k4*c["DA"] - k5*c["DB"]
  r[5] = k5*c["DB"]
  return(list(r))}

次に、初期値を、[A]=1、[B]=1、[DA]=0、[DB]=0、[DC]=0、k1=1、k2=0.8、k3=1、k4 = 0.5、k5 = 1に設定します。時間軸は0.1刻みにします。

#初期値
cinit <- c(A = 1, B = 1, DA = 0, DB = 0, DC = 0)
parms <- list(k1 = 1, k2 = 0.8, k3 = 1, k4 = 0.5, k5 = 1)

#時間軸
t <- seq(0, 10, by=0.1)

それでは、deSolve::ode関数で数値計算します。

#解析実行
Results <- deSolve::ode(y=cinit, times=t, 
                        func=Kinetics, parms=parms, method="lsoda")

#累積ラインデータセットの作成関数
source("https://gist.githubusercontent.com/kumeS/c516415c9ab4d25a2a6ae078e4d87837/raw/5be7e171ae9ce03c6110fa6a1ccb20d69aa45412/accumulate_by.R")

#DF化・データ調整・累積化
Dat <- data.frame(Results)
Dat$frame <- as.numeric(rownames(Dat))
Dat0 <- tidyr::gather(Dat, key=Mol, value= val, A, B, DA, DB, DC, -c(frame, time))
Dat1 <- Dat0 %>% accumulate_by(~frame)
a <- nrow(Dat0)/length(unique(Dat0$Mol))

#plot_ly実行
fig <- plotly::plot_ly(Dat1,
    x = ~time, 
    y = ~val,  
    split = ~Mol,
    frame = ~X,
    type = 'scatter',
    mode = 'lines') %>%
  layout(title = '逆コの字型の反応モデル', 
         plot_bgcolor = "#e5ecf650", 
         xaxis = list(title = 'Time'), 
         yaxis = list(title = 'Abundance ratio'), 
         legend = list(title=list(text='<b>Mol</b>')),
         margin = list(l = 80, r = 80, b = 80, t = 60, pad = 0)) %>% 
  animation_opts(frame = a, transition = 0, redraw = FALSE)

#作図
fig

#保存
fig %>% htmltools::save_html(file="06_plotly_motion.html")

https://kumes.github.io/Blog/R_ODE/06_plotly_motion.html

「◇型」の反応モデル

「◇型」の反応モデル

それでは、菱形モデルをやってみます。 このモデルは、A → Bの反応途中に、中間状態の平衡(IA ⇄ IB)を仮定しているモデルです。

#連立方程式の定義
Kinetics <- function(t, c, parms){
  k1 <- parms$k1
  k2 <- parms$k2
  k3 <- parms$k3
  k4 <- parms$k4
  k5 <- parms$k5
  k6 <- parms$k6
  r <- rep(0, length(c))
  r[1] = -k1*c["A"] - k2*c["A"]
  r[2] = k1*c["A"] - k3*c["IA"] + k4*c["IB"] - k5*c["IA"]
  r[3] = k2*c["A"] + k3*c["IA"] - k4*c["IB"] - k6*c["IB"]
  r[4] = k5*c["IA"] + k6*c["IB"]
  return(list(r))}

次に、初期値を、[A]=1、[B]=0、[IA]=0、[IB]=0、k1=1、k2=0.8、k3=0.2、k4(=k-3) = 0.1、k5(=k4) = 1、k6(=k5) = 0.5に設定します。時間軸は0.1刻みにします。

今更ながら、cinitのインデックスの順番とlist(r)の順番は同じが良いらしいです。

#初期値
cinit <- c(A = 1, IA = 0, IB = 0, B = 0)
parms <- list(k1 = 1, k2 = 0.8, k3 = 0.2, k4 = 0.1, k5 = 1, k6 = 0.5)

#時間軸
t <- seq(0, 5, by=0.05)

それでは、deSolve::ode関数で数値計算します。

#解析実行
Results <- deSolve::ode(y=cinit, times=t, 
                        func=Kinetics, parms=parms, method="lsoda")

#累積ラインデータセットの作成関数
source("https://gist.githubusercontent.com/kumeS/c516415c9ab4d25a2a6ae078e4d87837/raw/5be7e171ae9ce03c6110fa6a1ccb20d69aa45412/accumulate_by.R")

#DF化・データ調整・累積化
Dat <- data.frame(Results)
Dat$frame <- as.numeric(rownames(Dat))
Dat0 <- tidyr::gather(Dat, key=Mol, value= val, A, B, IA, IB, -c(frame, time))
Dat1 <- Dat0 %>% accumulate_by(~frame)
a <- nrow(Dat0)/length(unique(Dat0$Mol))

#plot_ly実行
fig <- plotly::plot_ly(Dat1,
    x = ~time, 
    y = ~val,  
    split = ~Mol,
    frame = ~X,
    type = 'scatter',
    mode = 'lines') %>%
  layout(title = '菱形の反応モデル', 
         plot_bgcolor = "#e5ecf650", 
         xaxis = list(title = 'Time'), 
         yaxis = list(title = 'Abundance ratio'), 
         legend = list(title=list(text='<b>Mol</b>')),
         margin = list(l = 80, r = 80, b = 80, t = 60, pad = 0)) %>% 
  animation_opts(frame = a, transition = 0, redraw = FALSE)

#作図
fig

#保存
fig %>% htmltools::save_html(file="07_plotly_motion.html")

https://kumes.github.io/Blog/R_ODE/07_plotly_motion.html

「改変◇型」の反応モデル

「改変◇型」の反応モデル

最後に、改変の菱形モデルをやります。 これは、上記の菱形モデルに加えて、A⇄Bの平衡反応を考慮したものです。

#連立方程式の定義
Kinetics <- function(t, c, parms){
  k1 <- parms$k1
  k2 <- parms$k2
  k3 <- parms$k3
  k4 <- parms$k4
  k5 <- parms$k5
  k6 <- parms$k6
  k7 <- parms$k7
  k8 <- parms$k8
  r <- rep(0, length(c))
  r[1] = -k1*c["A"] - k2*c["A"] + k7*c["B"] - k8*c["A"]
  r[2] = k1*c["A"] - k3*c["IA"] + k4*c["IB"] - k5*c["IA"]
  r[3] = k2*c["A"] + k3*c["IA"] - k4*c["IB"] - k6*c["IB"]
  r[4] = k5*c["IA"] + k6*c["IB"] - k7*c["B"] + k8*c["A"]
  return(list(r))}

次に、初期値を、[A]=1、[B]=0、[IA]=0、[IB]=0、k1=1、k2=0.8、k3=0.2、k4(=k-3) = 0.1、k5(=k4) = 1、k6(=k5) = 0.5、k7(=k6) = 0.5、k8(=k7) = 0.75に設定します。時間軸は0.1刻みにします。

今更ながら、cinitのインデックスの順番とlist(r)の順番は同じが良いらしいです。

#初期値
cinit <- c(A = 1, IA = 0, IB = 0, B = 0)
parms <- list(k1 = 1, k2 = 0.8, k3 = 0.2, k4 = 0.1, k5 = 1, k6 = 0.5, k7 = 0.5, k8 = 0.75)

#時間軸
t <- seq(0, 5, by=0.05)

それでは、deSolve::ode関数で数値計算します。

#解析実行
Results <- deSolve::ode(y=cinit, times=t, 
                        func=Kinetics, parms=parms, method="lsoda")

#累積ラインデータセットの作成関数
source("https://gist.githubusercontent.com/kumeS/c516415c9ab4d25a2a6ae078e4d87837/raw/5be7e171ae9ce03c6110fa6a1ccb20d69aa45412/accumulate_by.R")

#DF化・データ調整・累積化
Dat <- data.frame(Results)
Dat$frame <- as.numeric(rownames(Dat))
Dat0 <- tidyr::gather(Dat, key=Mol, value= val, A, B, IA, IB, -c(frame, time))
Dat1 <- Dat0 %>% accumulate_by(~frame)
a <- nrow(Dat0)/length(unique(Dat0$Mol))

#plot_ly実行
fig <- plotly::plot_ly(Dat1,
    x = ~time, 
    y = ~val,  
    split = ~Mol,
    frame = ~X,
    type = 'scatter',
    mode = 'lines') %>%
  layout(title = '改変菱形の反応モデル', 
         plot_bgcolor = "#e5ecf650", 
         xaxis = list(title = 'Time'), 
         yaxis = list(title = 'Abundance ratio'), 
         legend = list(title=list(text='<b>Mol</b>')),
         margin = list(l = 80, r = 80, b = 80, t = 60, pad = 0)) %>% 
  animation_opts(frame = a, transition = 0, redraw = FALSE)

#作図
fig

#保存
fig %>% htmltools::save_html(file="08_plotly_motion.html")

https://kumes.github.io/Blog/R_ODE/08_plotly_motion.html

まとめ

「RでODE」というテーマで執筆しました。

ODEを通して、生化学反応の仕組みが少しでも理解できたら、数式を見ても楽しくなります。また、身近にODE計算できるツールとして、Rが利用できると、何かと便利です。

計算科学領域では、生化学的な反応を単にODEで解くだけではなくて、細胞空間レベルで反応シミュレーションすることも行われています。

最近では、Zane R. Thornburgらの研究によって、最小細胞である、JCVI-syn3Aの全細胞完全動力学モデル(WCM)についても報告されている。

ミクロな反応シミュレーションによって、生命科学の理解はますます進んでいくものと思われますね。

補足: 速度論の数学的基礎 (解析式)

以下、解析式を導く際の数学的な解説をしています。ご参考までに。

1. 変数分離形積分法 (同時方程式)

2. 定数係数1階線形微分方程式の公式

3. 零次反応

4. 一次反応

5.二次反応

6. 二成分反応

7. 可逆一次反応I

8. 可逆一次反応II

9. 半減期

参考資料

www.anarchive-beta.com

qiita.com

plotly.com

【R言語とWebスクレイピングとアニメーショングラフ】仮想通貨や株価変動をモーションチャートで観察してみた件【S&P100のスキャッチャープロット編】

はじめに

いま、このブログでは「アニメーショングラフ」推しなのですが、、、 「バー・チャート・レース」が少し見難いようにも思えてきて、 散布図(スキャッチャープロット)のモーションチャートをやってみることにしました。

この記事では、S&Pダウ・ジョーンズ・インデックスが算出しているアメリカの株価指数の1つである、SP100の各銘柄の時系列データ(日足)について、「モーションチャート(Motion chart)」を作成します。

SP100はちょうど100銘柄から構成されているので、100点のスキャッチャープロットとなります。

さぁ、モーションチャート作図をやっていきましょう。

関連記事

skume.net

skume.net

実行環境

実行環境
macOS Big Sur (バージョン11.5.2)
MacBook Air (M1, 2020)
チップ Apple M1
メモリ 16GB

パッケージ準備

今回使用する、Rパッケージを準備します。

ここをスキップして、以下のスクリプトを読み込むのでもOKです。

#パッケージ・インストール
pack <- c("rvest", "quantmod", "magrittr", "tidyr", "tidyverse", "plotly", "gapminder", "dygraphs", "htmltools")
install.packages(pack[!(pack %in% unique(rownames(installed.packages())))])

#ロード
for(n in 1:length(pack)){ eval(parse(text = paste0("library(", pack[n], ")"))) }; rm("n", "pack")

getSP100.Rスクリプトを読み込んでも、Rパッケージがインストールできます。

同時に、今回使用する、getSP100_list、SP100_ChartData、SP100_ChartData_modといった関数群を読み込まれます。

#スクリプトの読み込み
source("https://gist.githubusercontent.com/kumeS/e8dca57f2ba101b2ef9714ce59400460/raw/dfdcf08fdbc7fbd41eb909520c4bb0bc52adf460/getSP100.R")

SP100銘柄のデータ取得

https://en.wikipedia.org/wiki/S%26P_100

まず、getSP100_list関数では、ウェブスクレイピングを介して、ウィキペディアの該当ページからSP100の銘柄リストを取得します。

さて、下記を実行していきます。

#SP100銘柄リストの取得
SP100List <- getSP100_list()

#表示
head(SP100List)
#                       Company Ticker                 Sector
#1                        Apple   AAPL Information Technology
#2                       AbbVie   ABBV            Health Care
#3                       Abbott    ABT            Health Care
#4                    Accenture    ACN Information Technology
#5                        Adobe   ADBE Information Technology
#6 American International Group    AIG             Financials

次に、2022年年初からのSP100のデータを取得します。

#SP100のデータ取得: 実行時間 3分くらい
ChartData <- SP100_ChartData(Dat=SP100List, term=c("2022-01-01", "2022-12-31"))

#いったん、RDS保存
saveRDS(ChartData, "SP100_ChartData.Rds")

#ダウンロード
#browseURL("https://github.com/kumeS/Blog/raw/master/R_BarChart/Chart_03/SP100_ChartData.Rds")
#ChartData <- readRDS("SP100_ChartData.Rds")

#表示
head(ChartData)
#                       Company Ticker                 Sector       date close dclose dclose2 ranking
#1                        Apple   AAPL Information Technology 2022-01-03   100      0 #F0F5F0       1
#2                       AbbVie   ABBV            Health Care 2022-01-03   100      0 #F0F5F0       2
#3                       Abbott    ABT            Health Care 2022-01-03   100      0 #F0F5F0       3
#4                    Accenture    ACN Information Technology 2022-01-03   100      0 #F0F5F0       4
#5                        Adobe   ADBE Information Technology 2022-01-03   100      0 #F0F5F0       5
#6 American International Group    AIG             Financials 2022-01-03   100      0 #F0F5F0       6

このステップで、SP100の銘柄リストと値動きのデータが取得できました。

続いて、SP100_ChartData_mod関数で、データの補正を行います。

#データ補正: 全銘柄を使用
ChartData1 <- SP100_ChartData_mod(ChartData)

#表示
head(ChartData1)
#  Company Ticker      Sector CompanyTicker    CompanySector       date close dclose dclose2 ranking
#1      3M    MMM Industrials      3M (MMM) 3M (Industrials) 2022-01-03 100.0    0.0 #F0F5F0      64
#2      3M    MMM Industrials      3M (MMM) 3M (Industrials) 2022-01-04 101.4    1.4 #F0F5F0      38
#3      3M    MMM Industrials      3M (MMM) 3M (Industrials) 2022-01-05 101.0    1.0 #F0F5F0      40
#4      3M    MMM Industrials      3M (MMM) 3M (Industrials) 2022-01-06 100.1    0.1 #F0F5F0      46
#5      3M    MMM Industrials      3M (MMM) 3M (Industrials) 2022-01-07 101.2    1.2 #F0F5F0      42
#6      3M    MMM Industrials      3M (MMM) 3M (Industrials) 2022-01-10  99.8   -0.2 #FCF3F3      52

plotlyによるモーションチャート(motion chart)の作図

それでは、取得したSP100の値動きデータを使って、モーションチャートを作成します。 値動きの大きさによって、マーカーのサイズが変わるように設定します。

#のべ日の作成
ChartData1$Day <- as.numeric(ChartData1$date) - min(as.numeric(ChartData1$date)) + 1
#マーカーのサイズ
ChartData1$Size <- (4*abs(ChartData1$dclose)/100 +1)*5
#サイズの範囲
range(ChartData1$Size)
#[1]  5.00 21.58

#plot_ly実行
fig <- plot_ly(ChartData1,
    x = ~ranking, 
    y = ~close, 
    size = ~Size, 
    color = ~Sector, 
    frame = ~Day,
    text = ~CompanySector,
    hoverinfo = "text",
    hovertemplate = paste('ranking: %{x}', '<br>%{text}',
                          '<br>Relative: %{y}<extra></extra>'),
    type = 'scatter',
    mode = 'markers'
  ) %>%
  layout(title = 'SP100 Y2022', 
         plot_bgcolor = "#e5ecf650", 
         xaxis = list(title = 'Ranking'), 
         yaxis = list(title = 'Relative price'), 
         legend = list(title=list(text='<b>Sector</b>')))

#作図: 30秒くらいかかる
fig

#保存
fig %>% htmltools::save_html(file="SP100_motion_chart.html")

https://kumes.github.io/Blog/R_BarChart/Chart_03/02_SP100_motion_chart.html

散布図だと、プロットがガチャガチャしても、何だか許容できますね。

dygraphsによるインタラクティブな作図

dygraphsパッケージは、dygraphs JavaScriptチャート・ライブラリへのRインターフェースです。 Rで時系列データを図表化するために、豊富な機能を提供しています。

このdygraphsパッケージは、xts時系列オブジェクト(または、xtsに変換可能なあらゆるオブジェクト)を自動的にプロットします。

#ワイド型への変換
ChartData2 <- ChartData1[,c("CompanySector", "date", "close")]
ChartData2.s <- spread(ChartData2, key = CompanySector, value = close)

#行名を変更する
rownames(ChartData2.s) <- as.character(ChartData2.s$date)
ChartData2.s <- ChartData2.s[,-1]

#表示(一部)
head(ChartData2.s)
#           3M (Industrials) Abbott (Health Care) AbbVie (Health Care)
#2022-01-03            100.0                100.0                100.0
#2022-01-04            101.4                 97.6                 99.8
#2022-01-05            101.0                 97.2                100.3
#2022-01-06            100.1                 97.2                 99.9
#2022-01-07            101.2                 97.5                 99.6
#2022-01-10             99.8                 97.3                100.7

#5つのサンプリング
x <- sample(1:ncol(ChartData2.s), 5)

#5つの可視化
p2 <- dygraph(ChartData2.s[,x],
        main = "SP100 Y2022",
        ylab = "Relative price") %>%
  dyRangeSelector(height = 20)  %>%
  dyLegend(show = "follow", width = 250, hideOnMouseOut = T, labelsSeparateLines = T)

#可視化
p2

#保存
p2 %>% htmltools::save_html(file="SP100_dygraph_p2.html")

https://kumes.github.io/Blog/R_BarChart/Chart_03/06_SP100_dygraph_p2.html

dygraphはプロットはサンプル数が多くなるとあまり使い物にならないかも。。 せいぜい、3-5サンプルくらいまでかな。

まとめ

SP100銘柄の2022年年初からのモーションチャートを作成しました。

バーがガンガン動く「バーチャートレース」よりも、 散布図のモーションチャートの方が目に優しい気がします。 私だけかもですが。

補足

plotlyによるインタラクティブチャート + ハイライト

ハイライトした、plotlyチャートの作成をやってみました。

#表示
head(ChartData1)

#ハイライト表示
g <- highlight_key(ChartData1, ~Ticker)

#作図
p <- plot_ly(g) %>%
  group_by(Ticker) %>%
  add_lines(x = ~date, y = ~close, color = ~CompanySector) %>%
  layout(xaxis = list(title = ""),
         yaxis = list(title = "Changes (%)"), showlegend = F) %>%
  highlight(selected = attrs_selected(showlegend = FALSE)) %>% 
  highlight(on = "plotly_click", 
                off = "plotly_doubleclick",
                persistent = FALSE,
                color = "red",
                selected = attrs_selected(opacity = 0.5))

#可視化
p

#保存
p %>% htmltools::save_html(file="SP100_plot_ly_p.html")

https://kumes.github.io/Blog/R_BarChart/Chart_03/07_SP100_plot_ly_p.html

ggplotlyによるインタラクティブチャート

plotlyパッケージ内のggplotlyという関数で、ggplot2::ggplot()のオブジェクトを plotlyオブジェクトに変換できる。マジで!!

#表示
head(ChartData1)

#ggplotで作図
p <- ggplot(ChartData1,
       aes(x = date, y = dclose, 
           group = CompanySector, 
           color = Sector)) + 
  geom_line()

#ggplotで可視化
p

##Plotlyで可視化
p1 <- ggplotly(p)

#保存
p1 %>% htmltools::save_html(file="SP100_ggplotly_p1.html")

これが、ggplotで可視化した結果です。

ggplotで可視化した結果

これが、ggplotlyで可視化した結果です。

https://kumes.github.io/Blog/R_BarChart/Chart_03/04_SP100_ggplotly_p1.html

この変換はとても簡単で、感動的です。

plotlyによるモーションチャートの実行テスト

gapminderのデータセットには、 国や地域ごと平均余命、人口、一人当たりのGDPを経時データが含まれています。

#テストデータ
df <- gapminder

#表示
head(df)
#  country     continent  year lifeExp      pop gdpPercap
#  <fct>       <fct>     <int>   <dbl>    <int>     <dbl>
#1 Afghanistan Asia       1952    28.8  8425333      779.
#2 Afghanistan Asia       1957    30.3  9240934      821.
#3 Afghanistan Asia       1962    32.0 10267083      853.
#4 Afghanistan Asia       1967    34.0 11537966      836.
#5 Afghanistan Asia       1972    36.1 13079460      740.
#6 Afghanistan Asia       1977    38.4 14880372      786.

#plot_ly実行
fig <- plot_ly(df,
    x = ~gdpPercap, 
    y = ~lifeExp, 
    size = ~pop, 
    color = ~continent, 
    frame = ~year, 
    text = ~country, 
    hoverinfo = "text",
    type = 'scatter',
    mode = 'markers'
  )

#レイアウト
fig <- fig %>% layout(
    xaxis = list( type = "log" )
  )

#作図
fig

#保存
fig %>% htmltools::save_html(file="test_motion_chart.html")

https://kumes.github.io/Blog/R_BarChart/Chart_03/05_test_motion_chart.html

ffmpegによる、mov形式をgifに変換する

ターミナルを起動して、ffmpegで変換します。

#インストール
brew install ffmpeg

#MOV形式からのgif変換: 横幅を750にする
ffmpeg -i input.mov -vf scale=750:-1 -r 10 output.gif

参考資料

ladal.edu.au

plotly.com

plotly.com

plotly.com

stackoverflow.com

rstudio.github.io

plotly-r.com

R言語でヒートマップ入門:インタラクティブなヒートマップでデータ分析をもっと楽しくしよう!!

はじめに

過去に、heatmap.2パッケージと階層的クラスタリングを使って、ヒートマップの描く方を紹介しました。 こんなヒートマップでした。いま思うと、懐かしいような、古めかしい感じがしますね。

 

今回は、R言語でのヒートマップの特集ということで、 色々なパッケージのヒートマップ表現を調査して、取り上げてみました。

ヒートマップとは、データを可視化するため、 「数値データの高い・低いの表」を「色や濃淡」セルのグリットに変換して表現した視覚化法、あるいはデータ解析法の1つです。 数値の一覧を目視するよりも、データ間の意味や差異がより直感的に導けますし、 「色や濃淡」の曖昧な表現から、データ全体のニュアンスを掴む行為とも言えます。

また、項目間の近縁関係のパターンを強調するために並べられ、しばしばデンドログラムが添えられます。 こうすることで、ヒートマップの見え方が大きく変わり、データからふとした新しい発見にも繋がるかもで、 それは、このヒートマップ解析の興味深いところです。 ヒートマップは、観測値、相関関係、欠損値パターンなどを可視化するために、多くの分野で使用されています。

この記事では、色々なパッケージでのヒートマップの作り方に加えて、 インタラクティブにヒートマップを作成・可視化できるパッケージを紹介します。 全体を通じて、ツール間の比較ができ、良し悪しも感じてもらえるのではと思います。

実行環境

実行環境は以下の通りです。

macOS Big Sur (バージョン11.5.2)
MacBook Air (M1, 2020)
チップ Apple M1
メモリ 16GB

Rパッケージの読み込み

R環境を立ち上げて、必要なパッケージをインストールしておきます。

#パッケージ・インストール
pack <- c("htmlwidgets", "qtlcharts", "qtl", "iheatmapr", "heatmap3", "heatmaply", "remotes", "corrplot")
install.packages(pack[!(pack %in% unique(rownames(installed.packages())))])

#ロード
for(n in 1:length(pack)){ eval(parse(text = paste0("library(", pack[n], ")"))) }; rm("n", "pack")

heatmap3パッケージを用いた、ハイカラなヒートマップ表現

heatmap2というパッケージがありますが、最近、heatmap3というのも出ているようです。

heatmap3は、改良されたヒートマップパッケージで、Rのオリジナル関数'heatmap'と 完全な互換性で、便利な機能を提供すると説明されています。

それでは、早速、heatmap3のサンプルコードを実行してみます。

heatmap3でのヒートマップ作成(1)シンプルなヒートマップ

この実行例では、乱数を生成して、サンプルデータを作成・利用して、シンプルなヒートマップを作成します。

#乱数でサンプルデータ作成
rnormData <- matrix(rnorm(1000), 40, 25)
#head(rnormData)

#微調整
rnormData[1:15, seq(6, 25, 2)] <- rnormData[1:15, seq(6, 25, 2)] + 2
rnormData[16:40, seq(7, 25, 2)] = rnormData[16:40, seq(7, 25, 2)] + 4

#列名を与える
colnames(rnormData) <- c(paste("Control", 1:5, sep = ""),
                         paste(c("TrtA", "TrtB"), rep(1:10,each=2), sep = ""))
#行名を与える
rownames(rnormData) <- paste("Probe", 1:40, sep = "")

#グループのカラーリング
ColSideColors <- cbind(Group1=c(rep("steelblue2",5), rep(c("brown1", "mediumpurple2"),10)),
                       Group2=sample(c("steelblue2","brown1", "mediumpurple2"),25,replace=TRUE))

#特定セルのカラーリング
colorCell <- data.frame(row=c(1,3,5),col=c(2,4,6),
                      color=c("green4","black","orange2"),stringsAsFactors=FALSE)

#特定セルのハイライト
highlightCell <- data.frame(row=c(2,4,6),col=c(1,3,5),
                            color=c("black", "green4","orange2"),lwd=1:3,stringsAsFactors=FALSE)

#ヒートマップ実行
heatmap3(rnormData,
         ColSideColors=ColSideColors, 
         showRowDendro=FALSE,
         colorCell=colorCell,
         highlightCell=highlightCell)

#注釈
#ColSideColors: 水平サイドバーの色名を含む長さncol(x)の文字ベクトル
#showRowDendro: 行のデンドログラムをプロットするかどうかを指定する論理値
#colorCell: 3つの列を持つ data.frame で、どのセルが特定の色で着色されるか
#highlightCell: 3列または4列の data.frame で、どのセルが特定の色の矩形でハイライトされるか

 

このヒートマップはインタラクティブではない分、見栄えが良いような気がしますね。

heatmap3でのヒートマップ作成(2)少し複雑なヒートマップ

次には、少し複雑なヒートマップの作成を実行します。

#乱数でサンプルデータ作成
ColSideAnn <- data.frame(Information=rnorm(25),
                         Group=c(rep("Control",5),rep(c("TrtA","TrtB"),10)),
                         stringsAsFactors=TRUE)

#行名を与える(上記の実行から使用した変数転用)
row.names(ColSideAnn) <- colnames(rnormData)

#カラーパレット作成
RowSideColors <- colorRampPalette(c("chartreuse4", "white", "firebrick"))(40)

result <- heatmap3(rnormData,
                   ColSideCut=1.2,
                   ColSideAnn=ColSideAnn,
                   ColSideFun=function(x) {showAnn(x)},
                   ColSideWidth=0.8,
                   RowSideColors=RowSideColors,
                   col=colorRampPalette(c("green","black", "red"))(1024),
                   RowAxisColors=1,
                   legendfun=function() {showLegend(legend=c("Low","High"), col=c("chartreuse4","firebrick"))},
                   verbose=TRUE)
#注釈
#ColSideCut: coloumデンドログラムをカットする際に使用される数値
#ColSideAnn: 連続変数と因子変数をアノテーション情報として持つデータフレーム。
#ColSideFun: 列方向に注釈やラベリング図を生成するために使用される関数
#ColSideWidth: 数値列の側面領域の高さ
#RowSideColors: (オプション) nrow(x) の長さの文字ベクトル
#RowAxisColors: RowSideColors のどの色を行軸のラベルの色として使用するかを示す整数値
#legendfun: 関数で、図の左上に凡例を生成する。

 

実際、ヒートマップの調整は結構ややこしいです。

heatmaplyパッケージを使った、ヒートマップ作図

次に、heatmaplyパッケージは、ggplot2とplotly.jsのエンジンをベースにして開発されています。 d3heatmapと同様のヒートマップを生成しますが、plotly.jsはより大きなサイズの行列を扱えて、 デンドログラムからのズーム機能の点で優れているようです。

デフォルトのplot_method = "ggplot"の代わりに、 plot_method = "plotly"を選択することもできます。

heatmaplyによる通常のヒートマップ

まずは、mtcarsのデータセットで、heatmaply関数のシンプル実行をしてみます。

#データ表示
head(mtcars)
#                   mpg cyl disp  hp drat    wt  qsec vs am gear carb
#Mazda RX4         21.0   6  160 110 3.90 2.620 16.46  0  1    4    4
#Mazda RX4 Wag     21.0   6  160 110 3.90 2.875 17.02  0  1    4    4
#Datsun 710        22.8   4  108  93 3.85 2.320 18.61  1  1    4    1
#Hornet 4 Drive    21.4   6  258 110 3.08 3.215 19.44  1  0    3    1
#Hornet Sportabout 18.7   8  360 175 3.15 3.440 17.02  0  0    3    2
#Valiant           18.1   6  225 105 2.76 3.460 20.22  1  0    3    1

#実行
heatmaply(mtcars)

https://kumes.github.io/Blog/R_heatmap/04_heatmaply.html

heatmaply_corによる相関ヒートマップ

heatmaply_corは、相関行列に適したヒートマップ関数です。 具体的には、限界値は -1 から 1 に設定され、 カラーパレットはRdBuになっています。

#実行
heatmaply_cor(
  x = cor(mtcars),
  xlab = "Features",
  ylab = "Features",
  k_col = 2,
  k_row = 2
)

https://kumes.github.io/Blog/R_heatmap/05_heatmaply_cor.html

heatmaplyによるpercentizeヒートマップ

percentize関数を使った、経験的パーセンタイル変換は、変数のランクを取ることに似た挙動です。 違いは、変換された変数を比較したり解釈したりするのがよりシンプルになることです。

これは、ヒートマップ(例:heatmaply)において、複数の変数を比較するのに便利な側面があります。

#実行
heatmaply(
  percentize(mtcars),
  xlab = "Features",
  ylab = "Cars", 
  main = "Data transformation using 'percentize'"
)

https://kumes.github.io/Blog/R_heatmap/06_heatmaply_percentile.html

qtlchartsパッケージのiplotCorrを利用した、相関行列のヒートマップ表現

qtlchartsパッケージは、D3.jsを使った、ウェブベースのインタラクティブチャートを提供しています。 パッケージの主な用途は、遺伝子座を実験的に同定するための解析ツールのようです。 その中の1つの関数である、iplotCorrを使用します。

#データ読み込み
data(geneExpr)

#設定
chartOpts <- list(cortitle="Correlation matrix", scattitle="Scatterplot")

#ヒートマップ実行
iplotCorr(mat=geneExpr$expr, group=geneExpr$genotype, 
          reorder=TRUE, chartOpts=chartOpts)

https://kumes.github.io/Blog/R_heatmap/07_iplotCorr.html

次に、Spearmanの相関行列を使う方法です。

# Spearmanの相関行列計算
corr <- cor(geneExpr$expr, method="spearman", use="pairwise.complete.obs")

#設定
chartOpts <- list(cortitle="Spearman matrix", scattitle="Scatterplot")

# 階層的クラスタリングによる並び替え
o <- hclust(as.dist(1-corr))$order

#ヒートマップ実行
iplotCorr(mat=geneExpr$expr[,o], group=geneExpr$genotype, 
          corr=corr[o,o], chartOpts=chartOpts)

https://kumes.github.io/Blog/R_heatmap/08_iplotCorr.html

iheatmaprパッケージを用いたヒートマップ作成

iheatmaprパッケージは、複雑かつインタラクティブなヒートマップを構築するためのRパッケージです。

#データ読み込み
data(measles, package = "iheatmapr")

#ヘッド表示
head(measles)
#                1930  1931  1932  1933  1934
#ALABAMA         4389  8934   270  1735 15849
#ALASKA             0     0     0     0     0
#AMERICAN.SAMOA     0     0     0     0     0
#ARIZONA         2107  2135    86  1261  1022
#ARKANSAS         996   849    99  5438  7222
#CALIFORNIA     43585 27807 12618 26551 25650

#実行:メインのみ
main_heatmap(measles, name = "Measles<br>Cases", x_categorical = FALSE,
             layout = list(font = list(size = 8)))

まずは、main_heatmapのみの結果です。

https://kumes.github.io/Blog/R_heatmap/09_iheatmapr_main.html

#実行
main_heatmap(measles, name = "Measles<br>Cases", x_categorical = FALSE,
             layout = list(font = list(size = 8))) %>%
  add_col_groups(ifelse(1930:2001 < 1961,"No","Yes"),
                  side = "bottom", name = "Vaccine<br>Introduced?",
                  title = "Vaccine?",
                  colors = c("lightgray","blue")) %>%
  add_col_labels(ticktext = seq(1930,2000,10),font = list(size = 8)) %>%
  add_row_labels(size = 0.3,font = list(size = 6)) %>% 
  add_col_summary(layout = list(title = "Average<br>across<br>states"),
                  yname = "summary")  %>%                 
  add_col_title("Measles Cases from 1930 to 2001", side= "top") %>%
  add_row_summary(groups = TRUE, type = "bar",
                  layout = list(title = "Average<br>per<br>year",
                                font = list(size = 8)))

main_heatmapの結果に、6つのレイアーを付与して、最終的に複雑なヒートマップ図を作成します。

https://kumes.github.io/Blog/R_heatmap/10_iheatmapr.html

corrplotパッケージを用いた、相関ヒートマップ解析

corrplotは、相関行列を視覚的に探索するツールで、変数間の隠れたパターンを検出するのに役立ちます。また、自動的な変数の並べ替えをサポートしています。また、可視化方法、グラフィックレイアウト、色、凡例、テキストラベルなど、豊富なプロットオプションを提供しています。相関の統計的な有意性を判断するためのp値や信頼区間も提供しています。

#データ準備: mtcarsは自動車の燃費などに関するデータ
head(mtcars)
#                   mpg cyl disp  hp drat    wt  qsec vs am gear carb
#Mazda RX4         21.0   6  160 110 3.90 2.620 16.46  0  1    4    4
#Mazda RX4 Wag     21.0   6  160 110 3.90 2.875 17.02  0  1    4    4
#Datsun 710        22.8   4  108  93 3.85 2.320 18.61  1  1    4    1
#Hornet 4 Drive    21.4   6  258 110 3.08 3.215 19.44  1  0    3    1
#Hornet Sportabout 18.7   8  360 175 3.15 3.440 17.02  0  0    3    2
#Valiant           18.1   6  225 105 2.76 3.460 20.22  1  0    3    1

#相関の計算
M <- cor(mtcars)

#デフォルト相関行列
corrplot(M, method = 'circle')

#数字表示有りの相関行列
corrplot(M, method = 'number') # colorful number

corrmorantを使った、相関行列マップ

ヒートマップのパッケージとは言い難いのですが、、このパッケージも追記しておきます。

corrmorantパッケージは、通常のggplot2構文で相関行列のプロットを作図できます。 さらに、相関行列に基づく探索的データ解析のための大規模な可視化ツール群を提供しています。

#インストール
remotes::install_github("r-link/corrmorant")
library(corrmorant)

#データ読み込み
data(drosera)

#表示
head(drosera)
#   species variety petiole_length petiole_width blade_length blade_width
#1 capensis   rubra          54.00          1.95        38.30        3.95
#2 capensis   rubra          45.90          1.15        27.60        2.95
#3 capensis   rubra          21.20          0.85        21.85        2.65
#4 capensis   rubra          56.40          1.65        38.20        3.30
#5 capensis   rubra          28.60          1.00        15.80        2.80
#6 capensis   rubra          32.85          1.50        24.65        4.40

#詳細
str(drosera)
#'data.frame': 150 obs. of  6 variables:
# $ species       : Factor w/ 3 levels "capensis","madagascariensis",..: 1 1 1 1 1 1 1 1 1 1 ...
# $ variety       : Factor w/ 3 levels "alba","rubra",..: 2 2 2 2 2 2 2 2 2 2 ...
# $ petiole_length: num  54 45.9 21.2 56.4 28.6 ...
# $ petiole_width : num  1.95 1.15 0.85 1.65 1 1.5 1.85 1.65 2.4 1.5 ...
# $ blade_length  : num  38.3 27.6 21.9 38.2 15.8 ...
# $ blade_width   : num  3.95 2.95 2.65 3.3 2.8 4.4 4.8 3.4 3.9 4.4 ...

それでは、droseraのデータを使って、ggcorrmを実行します。 mappingで、colとfillにはspeciesの列を指定します。 2列目のvariety列が無視されるのは、Factorだからですかね。

#実行
ggcorrm(drosera, mapping = aes(col = species, fill = species)) +
  lotri(geom_smooth(alpha = 0.4, method = "lm")) +
  lotri(geom_point(alpha = 0.4)) +
  utri_corrtext(nrow = 2, squeeze = 0.6) +
  dia_names(y_pos = 0.15, size = 3) +
  dia_density(lower = 0.3, color = 1, alpha = 0.4)

#注釈
#lotri: プロットパネルのサブセットへのggplotレイヤーのマッピングを変更するために使用できるセレクタ関数
#utri_corrtext: プロットの非対角成分での二変量相関の強さをテキストラベルで表示するために使用されます。
#dia_names: プロットの変数名を対角成分の適切な位置にプロットします。
#dia_density: プロットの対角パネルに密度カーブを追加します。

以下のような、結果が得られます。

まとめ

R言語でのヒートマップ特集ということで、最近流行りのヒートマップ表現について調査してみました。 ヒートマップもインタラクティブな可視化が多くなってきている印象ですね。

1つのヒートマップ上に、色々な情報や解析結果を盛り込めるのは良いのですが、 実行コードが複雑で、覚えるのがやや面倒な感じがします。私だけでしょうか。。

参考資料

cran.r-project.org

kbroman.org

github.com

www.karada-good.net

github.com

cran.r-project.org

cran.r-project.org

github.com