2016年11月10日木曜日

R で数理生物学入門:低密度の影響



今回は数理生物学入門 p.7 の低密度の影響についてです。
いわゆるアリー効果というやつで、次の式で表されます。

$dx/dt = rx(x-a)(1-x/K)$ ... (1)

$a$ は低密度の影響が現れる閾値で、$0<a<K$ と定義されます。$x$ がこの閾値を超えるか超えないかで個体数の挙動が変わってくるというわけです。試しに $x<a$ を考えてみると、式 (1) の $(x-a)$ がマイナスになるので $dx/dt$ もマイナスとなります。変化量がマイナスなので確かに個体数は時間とともに減少します。逆に $x>a$ を考えてみると、$dx/dt > 0$ で個体数が増加することがわかります。



今回も詳しい解説は本書を参照してもらうとして、ここでは式 (1) を表現するプログラムを示します。以下がそのプログラムです。
#作成日時 : 11:07 2016/11/05
#作成者名:T. Nakano
rm(list=ls())
gc();gc()

# /////////////////////////////////////////////////////////////////////

# 変数の設定 ---------------------------
r = 0.03            # 内的自然増加率
K = 100             # 環境収容力
x = 30              # 個体数の初期値
a = 20              # 0 < a < K
dt = 0.1            # ちょっとだけ進める時間
T = 100             # 計算回数

# 計算 --------------------------------
N <- x
for(i in 1:T){
dx <-  r*x*(x-a)*(1-x/K)*dt
x <- x+dx
N <- c(N, x)
}

# 描画 -------------------------------
plot(0:T*dt, N, type="l", xlab="t")
abline(h=K, lty=2)


このプログラムはロジスティック成長のプログラムとほとんど同じです。ロジスティック成長のときにマルサス係数 $m$ を $r(1-x/K)$ に置き換えたのですが、今回はこれに $(x-a)$ を書き加えただけです。そして、$a$ が入ったので変数の設定で $a$ を定義しておきました。




以下のプログラムで本書の図1.5(a) を再現できます。
#作成日時 : 11:07 2016/11/05
#作成者名:T. Nakano
rm(list=ls())
gc();gc()

# /////////////////////////////////////////////////////////////////////

# 変数の設定 ---------------------------
r = 0.03            # 内的自然増加率
K = 100             # 環境収容力
x = 19              # 個体数の初期値
a = 20              # 0 < a < K
dt = 0.1            # ちょっとだけ進める時間
T = 100             # 計算回数

# 計算 --------------------------------
N <- x
for(i in 1:T){
dx <-  r*x*(x-a)*(1-x/K)*dt
x <- x+dx
N <- c(N, x)
}

plot(0:T*dt, N, type="l", xlab="時間 t", ylab="個体数 x", ylim=c(0, 160))

# 変数の設定 ---------------------------
x = 21             # 個体数の初期値

# 計算 --------------------------------
N <- x
for(i in 1:T){
dx <-  r*x*(x-a)*(1-x/K)*dt
x <- x+dx
N <- c(N, x)
}

lines(0:T*dt, N, type="l")

# 変数の設定 ---------------------------
x = 150             # 個体数の初期値

# 計算 --------------------------------
N <- x
for(i in 1:T){
dx <-  r*x*(x-a)*(1-x/K)*dt
x <- x+dx
N <- c(N, x)
}

lines(0:T*dt, N, type="l")

abline(h=c(K, a), lty=2)
text(10, K, label="x = K", pos=3)
text(10, a, label="x = a", pos=3)






また、以下のプログラムで本書の図1.5(b) を再現できます。これは個体数と増殖率の関係なので、$rx(x-a)(1-x/K)$ の $x$ に 0 から 120 までの値を与えて計算した結果をグラフにしました。

#作成日時 : 11:07 2016/11/05
#作成者名:T. Nakano
rm(list=ls())
gc();gc()

# /////////////////////////////////////////////////////////////////////

# 変数の設定 ---------------------------
r = 0.03            # 内的自然増加率
K = 100             # 環境収容力
a = 20              # 0 < a < K

# 計算 --------------------------------
x = 0:120
dx.dt <-  r*x*(x-a)*(1-x/K)

plot(x, dx.dt, type="l", ylim=c(-40, 40), ylab="増殖率", xlab="個体数 x")
points(c(0, a, K), c(0, 0, 0), pch=c(16, 21, 16))
abline(h=0)

text(a, 0, label="a", pos=1)
text(K, 0, label="K", pos=1)

2016年10月21日金曜日

R で数理生物学入門:ロジスティック成長



今回は数理生物学入門 p.4 のロジスティック成長です。

$dx / dt = rx(1-x/K)$ … (1)

$r$ は内的自然増加率、$K$ は環境収容力を表しています。
環境収容力は、その環境に何個体入れるかという値です。
つまり、個体数 $x$ が既に $K$ に達していると、それ以上増えることができないということになります。
実際に $x=K$ とすると、右辺は $rK(1-K/K)=0$ となり、すなわち $dx=0$ となって、確かに増加しないことがわかります。
逆に $x$ の値が小さいときは $r$ の値がほぼダイレクトに反映されるようになっていることがわかります。

数式の解説は本書に任せるとして、この場ではプログラムを考えてみます。
早速ですが、この数式のプログラムは以下の通りです。

#作成日時 : 15:33 2016/10/15
#作成者名:T. Nakano
rm(list=ls())
gc();gc()

# /////////////////////////////////////////////////////////////////////

# 変数の設定 ---------------------------
r = 1            # 内的自然増加率
K = 100          # 環境収容力
x = 1            # 個体数の初期値
dt = 0.1         # ちょっとだけ進める時間
T = 100          # 計算回数

# 計算 --------------------------------
N <- x
for(i in 1:T){
dx <-  r*x*(1-x/K)*dt     # 式(3)
x <- x+dx                 # 式(2)
N <- c(N, x)
}

# 描画 -------------------------------
plot(0:T*dt, N, type="l", xlab="t")
abline(h=K, lty=2)



このプログラムについて説明します。
と言っても、基本的には前回の指数増殖と同じで、

$x_{t+1}=x_t+dx$ … (2)

に持ち込んでいます。
ここで $dx$ は式(1)から、

$dx=rx(1-x/K)\times dt$ …(3)

となります。
今回の式 (3) は前回の式 (3) と比較するとわかるように、マルサス係数 $m$ を $r(1-x/K)$ に置き換えたものになっているので、プログラムの方もそのように変更しました。




以下のプログラムで本書のグラフを再現できます。
#作成日時 : 15:33 2016/10/15
#作成者名:T. Nakano
rm(list=ls())
gc();gc()

# /////////////////////////////////////////////////////////////////////

# 変数の設定 ---------------------------
r = 1            # 内的自然増加率
K = 100          # 環境収容力
x = 1            # 個体数の初期値
dt = 0.1         # ちょっとだけ進める時間
T = 100          # 計算回数

# 計算 --------------------------------
N <- x
for(i in 1:T){
dx <-  r*x*(1-x/K)*dt      # 式(3)
x <- x+dx                  # 式(2)
N <- c(N, x)
}

plot(0:T*dt, N, type="l", xlab="時間 t", ylab="個体数 x", ylim=c(0, 160))
abline(h=K, lty=2)

# 変数の設定 ---------------------------
x = 50             # 個体数の初期値

# 計算 --------------------------------
N <- x
for(i in 1:T){
dx <-  r*x*(1-x/K)*dt      # 式(3)
x <- x+dx          # 式(2)
N <- c(N, x)
}

lines(0:T*dt, N, type="l")

# 変数の設定 ---------------------------
x = 150             # 個体数の初期値

# 計算 --------------------------------
N <- x
for(i in 1:T){
dx <-  r*x*(1-x/K)*dt      # 式(3)
x <- x+dx                  # 式(2)
N <- c(N, x)
}

lines(0:T*dt, N, type="l")

text(10, 100, label="x = K", pos=3)





shiny を使うと以下のようになります。

ui.R
library(shiny)

shinyUI(fluidPage(

  # Application title
  titlePanel("ロジスティック成長"),

  sidebarLayout(
    sidebarPanel(
      numericInput("r","r =", value = 1),
      numericInput("K","K =", value = 100),
      numericInput("x","x =", value = 1),
      numericInput("dt","dt =", value = 0.1),
      numericInput("T","T =", value = 100)
    ),

    mainPanel("ロジスティック成長",
      plotOutput("logi")
    )
  )
))




server.R
library(shiny)

shinyServer(function(input, output) {

  output$logi <- renderPlot({
    # 変数の設定 ---------------------------
    r = input$r            # 内的自然増加率
    K = input$K            # 環境収容力
    x = input$x            # 個体数の初期値
    dt = input$dt          # ちょっとだけ進める時間
    T = input$T            # 計算回数

    ymax <- 150
    if(ymax < x) ymax <- x

    # 計算 --------------------------------
    N <- x
    for(i in 1:T){
      dx <-  r*x*(1-x/K)*dt      # 式(3)
      x <- x+dx                  # 式(2)
      N <- c(N, x)
    }

    # 描画 -------------------------------
    plot(0:T*dt, N, type="l", xlab="t", ylim=c(0,ymax))
    abline(h=K, lty=2)

  })

})





2016年10月3日月曜日

R で数理生物学入門:指数増殖


巌佐庸先生の数理生物学入門は非常に面白く、分かりやすく書かれており、感銘を受けました。この素晴らしい書籍を手にされた読者のうち、数式が苦手な方の一助になればと思い、自分が理解を深めるために作った R コードを公開したいと思いました。

というわけで、本書で紹介されている数式を R に起こして勝手にサポートしたいと思います!具体的には、数値解を求める R コードを公開します (どこまでできるか分かりませんが)。解析解 (数式としての解) の説明については、本書や他の書籍をご参照下さい。

まずは手始めに本書 p.3 の

$dx/dt = mx$   … (1)

についてです。
本書によると
$x(t) = x(0)e^{mt}$ が解であることは式の両辺に直接代入して確かめることができる。
この結果は、一定の環境がしばらく続くと個体数が時間とともに指数関数を描いて増大することを表している。


とのことですが、数式が苦手だと、いきなり「???」が浮かぶことになります。数式が得意な人達には分からない感覚だと思いますが、現に「???」が浮かびフリーズすることがあるんです。

でも、諦めなくていいんです!
R を使えば、別の道から解いていけるんです。

本当なら積分して解析解を求めるのがいいんだと思うんですが、数学的テクニックがなければそれも叶いません。そういうときは数値解を計算していくことで近似的に解を求めることができるんです。ここでいう数値解を計算するということは、具体的な値を代入して、数値として解を算出していくことです。今回の場合だと、式 (1) は $x$ の増加を記述するための数式なので、数値解では具体的な $x$ の値を算出していくことが最終目標になります。

今回が基本の数式となるので、ちょっと真面目に考えてみます。
説明が少しまどろっこしくなりますが、ご容赦願います。

式 (1) の左辺 $dx/dt$ は、言い換えると「$t$ がちょっと動いたときに $x$ がどれぐらい動いたか」を表しています。「$t$ がちょっと動いたとき」が $dt$ で、「$x$ がどれぐらい動いたか」が $dx$ で表されているわけです。もう少し格好良く言えば、それぞれ $t$ の変化量、$x$ の変化量と表現できます。

本書より、$x$ が個体数、$t$ が時刻なので、式 (1) の左辺 $dx/dt$ は、言い換えると「時間がちょっと進んだときの個体数の増加分 ($m < 0$ なら減少分) 」を表していることになります。「時間がちょっと進んだ」というのは、単位を任意で 1 進んだとすると、$t+1$ と表せます。$t$ を今の時刻とすると、$t+1$ は次の時刻と言えるわけです。

ここで、「次の時刻の個体数」というものは、「今の時刻の個体数」に「時間がちょっと進んだときの個体数の増加分」を加えたものになります。なので、次の時刻の個体数を $x_{t+1}$、今の時刻の個体数を $x_t$、時間がちょっと進んだときの個体数の増加分を $dx$ とすると、次の時刻の個体数は、

$x_{t+1}=x_t+dx$  …  (2)

と表せます。そして $dx$ は式 (1) を変形すると、

$dx=mx\times dt$  … (3)

というように求めることができます。ここで式 (3) の $x$ は「今の個体数」になるので $x_t$ となります。ここまでくれば、式 (2) と (3) から $x_{t+1}$ を求めることができます。そして求めた $x_{t+1}$ を $x_t$ に代入し、次の $x_{t+1}$ を順々に求めていけばいいわけです。

というわけで、この方針でプログラムを組んだものが以下のコードです。

#作成日時 : 13:14 2016/09/25
#作成者名:T. Nakano
rm(list=ls())
gc();gc()

# /////////////////////////////////////////////////////////////////////

# 変数の設定 ---------------------------
m = 0.1            # マルサス係数
x = 10             # 個体数の初期値
dt = 0.1           # ちょっとだけ進める時間

# 計算 --------------------------------
N <- x
for(i in 1:1000){
dx <-  m*x*dt      # 式(3)
x <- x+dx          # 式(2)
N <- c(N, x)
}

plot(0:1000*dt, N, type="l", xlab="t")

2016年9月13日火曜日

番外編:お菓子300円問題

突然ですが…、
小学校の遠足の時「お菓子は 300 円までね~」っていうルールは無かったですか?そして、これをキッチリ使い切りたいっていう悩ましい問題に陥って駄菓子屋さんの前で長い時間を過ごしたことかと思います。ということで、今回は小学生の気持ちに戻って、「お菓子 300 円問題」を R で解決してみたいと思います。

計算自体はとても簡単です。
予め、欲しいお菓子の名前と金額を csv ファイルにまとめておき、ランダムに取り出してお小遣いから引いていきます。そして、お小遣いが0円になったら計算を終了します。もしお小遣いがマイナスになったら初めから計算し直します。


使い方 -----------------
・欲しいお菓子の名前と金額を csv ファイルを作成します。例はこちら
・以下のコードを実行し、csv ファイルを選択します。
以上

#作成日時 : 12:28 2016/09/12
#作成者名:T. Nakano
rm(list=ls())
gc();gc()

# /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

# 変数の設定 -----------------------------------------------------
# お小遣い
bgt <- 300    # 円

# データの読込み -------------------------------------------------
library(tcltk)
fileName <- tclvalue(tkgetOpenFile())
act1 <- unlist(strsplit(fileName,"/"))
act1 <- act1[-length(act1)]

directory <- NULL
if(length(act1)!=1){
for(i in 1:(length(act1)-1)){
directory <- paste(directory,act1[i],"/",sep="")
}
}
directory <- paste(directory,act1[length(act1)],sep="")
setwd(directory)
DT <- read.csv(fileName, header=T)

# 計算開始 ------------------------------------------------------
N <- round(bgt/min(DT$金額))

for(j in 1:1000){
WR <- NULL
for(i in 1:N){
elm <- round(1+runif(1)*(nrow(DT)-1))
WR <- rbind(WR, DT[elm,])
if(bgt-sum(WR$金額)<=0) break
}
if(bgt==sum(WR$金額)){
WR <- WR[order(WR$お菓子),]
write.csv(WR, file="お菓子購入リスト.csv", row.names=F)
View(WR)
break
}
}

# コメント --------------------
if(j==1000){
cat(paste(bgt,"円ちょうどになりませんでした。", "\n","「お菓子と金額.csv」を変更して再計算してください。", sep=""), "\n")
}else if(j < 1000){
cat(paste(bgt,"円ちょうどになりました。", "\n", "ファイルを保存しましたのでお菓子を買いに行きましょう。", sep=""), "\n")
}


今回は「お菓子300円問題」ということでしたが、例えば、友達とバーベキュー等をするときにも使えるかと思います。バーベキュー等のときは駄菓子と違って商品の金額のキリが悪いことがあります(牛肉876円とか)。そういうときは一の位が 1 円か 9 円のものが入っている方が計算がうまくいきますよ。








2016年4月19日火曜日

R で推移行列モデル ~ Shiny の活用~

前回、推移行列モデルを R で行うコードを紹介しました。
各齢の生残率の状態が保持されると仮定すれば、将来の個体群の齢構成がどうなるかということが計算できました。

ですが、現実の問題として、保全施策や個体群の維持管理などを考えたとき、「どの齢の生残率を高く保っておかなければいけないか?」といったことを考える必要がもあると思います。

これを推移行列モデルで計算するなら、$p_1, p_2, p_3, …, p_{w-1}$ を変更し、再計算を繰り返さなければなりません。例えば、1 歳の個体を保護対象とせず全滅させてしまったらどうなるかということを計算するには、$p_1 = 0$ で再計算する必要があります。さらに、2 歳の個体を半分は保護するとか、1 歳から 4 歳までを満遍なく守るとか、1 歳から 4 歳にかけて守る量を減らしてみるとかいう計算をするとなると、その度に $p$ を打ち直して計算するという、探索的な計算をしないといけないわけです。





どう考えても面倒です。
そこで、R のパッケージ Shiny を活用します。


Shiny に関する説明は、他で説明されている方がいますので、そちらにお任せします。Shiny を実行して得られるものは web アプリです。このアプリは、こちらの入力に対する再計算結果やグラフ表示を返してくれます。こちらからの値の入力方法はいくつも用意されており、直接打ち込むタイプのテキスト入力や数値入力がある他、マウスで操作するスライダーバーやチェックボックス・ラジオボタン・セレクトボックスなどがあり、日付を入力する際はカレンダーを利用することもできます。数値や条件を入力すると即座に結果を返してくれるので、面倒で探索的な計算には非常に有効です。



使い方 --------------------------
まず、RStudio の File → New Project → New Directory → Shiny Web Application を選択します。そして、Directory name に任意の名前を入れて、この名前のフォルダを作る場所を Create project as subdirectory of の Browse ボタンで選びます。すると、RStudio に ui.R と server.R というタブができます。(この時点で Run App をクリックすると、ヒストグラムのバーの数を変更して表示するアプリが出てくるので、Shiny がどんなものなのか触ってみるといいと思います。)

次に、ui.R と server.R を書き換えます。
以下が推移行列モデルの ui.R と server.R ですので、それぞれをコピペして書き換えて下さい。
この ui.R はスライダーバーなどの入力パネルを作るコードで、server.R は計算するコードです。
server.R はほとんど R コードと一緒です。

最後に、両方とも書き換えたら Run App をクリックすると推移行列モデルのアプリが表示されます。


「よし!自分で作ろう!」という方はチュートリアルをご一読下さい。


ui.R

# ui.R

shinyUI(fluidPage(
  titlePanel(h1("推移行列モデル")),

  sidebarLayout(
    sidebarPanel(sliderInput("p1", "p1", min = 0, max = 1, value = 0.505, step = 0.001),
                 sliderInput("p2", "p2", min = 0, max = 1, value = 0.723, step = 0.001),
                 sliderInput("p3", "p3", min = 0, max = 1, value = 0.553, step = 0.001),
                 sliderInput("p4", "p4", min = 0, max = 1, value = 0.229, step = 0.001),
                 sliderInput("range", "グラフの範囲", min = 0, max = 100, value = 10)
                 ),
    mainPanel("加入個体数",
              plotOutput("recruit"))
  )
))


server.R

#作成日時 : 15:00 2015/10/20
#作成者名:T. Nakano
rm(list=ls())
gc();gc()

# ///////////////////////////////////////////////////////////////////

library(shiny)

shinyServer(function(input, output) {
  output$recruit <- renderPlot({

    # データ入力 ----------------------------------------------------
    LM <- c(0, 0.699, 3.754, 6.747, 4.414,
            input$p1, 0, 0, 0, 0,
            0, input$p2, 0, 0, 0,
            0, 0, input$p3, 0, 0,
            0, 0, 0, input$p4, 0)

    LM <- matrix(LM, ncol=sqrt(length(LM)), byrow=T)

    # 計算開始 ------------------------------------------------------
    DT <- N <- rep(10, ncol(LM))

    for(i in 1:input$range){
      act1N <- rep(N, nrow(LM))
      act1N <- matrix(act1N, ncol=length(N), byrow=T)

      N <- apply(LM*act1N, 1, sum)
      DT <- c(DT, N)
    }

    WR <- matrix(DT, ncol=length(N), byrow=T)

    # 加入量のグラフ --------------------------------------------------
    par(family="Meiryo")
    maintxt <- paste("固有値 =", round(abs(eigen(LM)$values[1]), 3))
    k<- 1:input$range
    barplot(WR[k,1], ylab="個体数", xlab="時刻 (年)", names.arg=k, main=maintxt)

  })

})





出力されるアプリの画面





グラフの範囲のスライダーバーを動かすと、棒グラフの x 軸が変更されます。
つまり、計算される世代数が変わるということです。

p1~p4 は推移行列モデルの $p_1 ~ p_4$ に対応しています。
このスライダーバーを動かすと、各齢の生残率を変更し、再計算されます。
つまり、p1~p4 を動かすだけで、探索的な計算ができるというわけです。


Shiny を使うことで解析の全てが完了するわけではありませんが、値の当たりをつけたり、解析の方向性を検討するということには有効なんじゃないかなぁ、と感じました。




2016年3月16日水曜日

R で推移行列モデル

今回は R で推移行列モデルを計算するコードを紹介します。
推移行列モデルの詳細は書籍:海洋ベントスの生態学を参照して下さい。



早速ですが、推移行列モデルとは以下のような数式で表されます。

\begin{align*}
A =
\begin{pmatrix}
f_1 & f_2 & f_3 & ... & f_{w-1} & f_w \\
p_1 & 0 & 0 & ... & 0 & 0 \\
0 & p_2 & 0 & ... & 0 & 0 \\
0 & 0 & p_3 & ... & 0 & 0 \\
. & . & . & ... & . & . \\
. & . & . & ... & . & . \\
. & . & . & ... & . & . \\
0 & 0 & 0 & ... & p_{w-1} & 0
\end{pmatrix}
\end{align*}

ここで、$w$ はコホートの最高齢を表して、第 1 行目は各齢における繁殖量を表しているとのことです。$p_x$ は齢別生存率を表しており、例えば $p_1$ は 1 歳から 2 歳までの生残率を意味します。この値の算出には、予めコホート解析 (混合正規分布の分解) で得られたコホートの生残率が使えそうです。


次に、時刻 $t$ における個体群の年齢構成を以下のように記述します。

\begin{align*}
n_t =
\begin{pmatrix}
n_1 \\
n_2 \\
n_3 \\
. \\
. \\
. \\
n_w
\end{pmatrix}
\end{align*}

ここでは、$n_1$ は 1 歳の個体数、$n_2$ は 2 歳の個体数...、というように表されています。
そして、これらの行列を使って、以下のように時刻 $t+1$ における年齢構成を計算します。

$n_{t+1}=A\times n_t$


そして、この $n_{t+1}$ を $n_t$ とし、繰り返し計算することで未来の年齢構成を予測することができるわけです。どうして掛け算するだけで次の世代が計算できるのかということに関しては、行列の計算方法を考えると分かると思います。





プログラムについて --------------------------------------------
基本的には推移行列と齢構成のベクトルを繰返し計算するコードです。

推移行列から個体群増加率 λ が算出でき、これが λ > 1 なら個体群は増加するそうです。この λ は推移行列の最大固有値だということなので、以下のコードでは eigen() 関数で算出しています。



自分のデータで解析するときは、


1. 計算したい世代数を入力する
2. 以下のコードの変数 LM に推移行列を入力する
3. 個体群の年齢構成の初期値 N を入力する (デフォルトでは各齢 10 個体)
4. 実行


という手順で行って下さい。






#作成日時 : 15:00 2015/10/20
#作成者名:T. Nakano
rm(list=ls())
gc();gc()

# ////////////////////////////////////////////////////////////////

# 変数の設定 ---------------------------------------------------
# 計算したい世代数 ----------
f <- 100

# データ入力 ----------
LM <- c(0, 0.699, 3.754, 6.747, 4.414,
              0.505, 0, 0, 0, 0,
              0, 0.723, 0, 0, 0,
              0, 0, 0.553, 0, 0,
              0, 0, 0, 0.229, 0)

# 個体群の年齢構成の初期値 -----
RN <- sqrt(length(LM))
N <- rep(10, RN)
DT <- N


# 計算開始 ---------------------------------------------------
LM <- matrix(LM, ncol=RN, byrow=T)

# 行列の計算 -----
for(i in 1:(f-1)){
act1N <- rep(N, nrow(LM))
act1N <- matrix(act1N, ncol=length(N), byrow=T)
N <- apply(LM*act1N, 1, sum)
DT <- c(DT, N)
}

WR <- matrix(DT, ncol=length(N), byrow=T)

# 固有値 λ --------------------------
eigen(LM)$values[1]

# 加入量のグラフ -------------------
k <- 1:10    # 最大 1:nrow(WR)
barplot(WR[k,1], xlab="世代数", ylab="加入量", names.arg=k)