新型肺炎COVID-19 の潜伏期間をrstanで推定する

読んだ。
Incubation period of 2019 novel coronavirus (2019-nCoV) infections among travellers from Wuhan, China, 20-28 January 2020. - PubMed - NCBI

最初に武漢で肺炎が発生したときに、88症例について感染履歴を聴取して、ワイブル分布で潜伏期間を推定すると平均6.4日(95% credible interval (CI): 5.6–7.7)、潜伏期間の幅は2.1から11.1日(2.5th to 97.5th percentile)だった、という。
論文ではワイブル分布のほかに、ガンマ分布、対数正規分布で推定して、looicでもっともよかったのがワイブル分布だった、と言っている。
supplemental にスクリプトがあったのでぱくってやってみる。

結果としてはだいぶずれたような気がする。

weibull gamma lognormal
2.5% 4.629226 5.531133 5.174367
50% 6.828260 6.353485 6.070993
97.5% 9.616947 7.583359 7.347166
looIC 480.119496 524.649064 586.254024

前処理にtidyverseがうざすぎるのでこちらで前処理したデータを置いておく。

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

# tidyverse がうざいので加工済みデータを置いておく
input <- list(N=88, 
tStartExposure=c(-2,-18,-18,10,3,8,12,13,-18,-18,8,10,-11,-18,-18,-18,12,-18,-18,-18,-18,-18,-18,11,11,-18,-18,-18,-18,-18,12,12,15,15,-18,-18,-18,-18,19,-18,-18,-18,-18,-18,-18,-18,18,-18,-18,6,-18,-18,-18,9,-18,11,-18,-18,-18,-18,-18,-18,-18,-18,-18,-18,19,-18,-18,-18,-18,-18,-18,-18,13,13,-18,-18,-18,-18,-18,-18,13,-18,-18,-18,-18,-18),
tEndExposure=c(3,12,3,11,4,16,16,16,15,15,16,11,9,2,12,17,15,17,18,13,16,11,18,14,18,20,12,10,17,15,15,14,17,20,18,13,23,23,22,20,21,21,21,15,21,17,20,18,20,7,20,20,20,20,18,22,22,18,18,18,9,20,18,22,23,19,19,22,22,13,22,22,23,23,17,17,22,18,18,22,18,20,15,20,19,23,22,22),
tSymptomOnset=c(3,15,4,14,9,16,16,16,16,16,16,14,10,10,14,20,19,19,20,20,17,13,19,19,20,21,18,18,18,16,20,16,20,20,19,17,24,24,23,21,23,23,23,21,22,24,24,19,21,14,23,23,21,20,21,22,23,19,23,21,13,22,24,25,25,25,25,24,24,21,23,23,24,25,18,18,23,22,22,24,24,25,22,25,25,24,25,25)
)

# 3つの確率分布を一気に作る
dists <- c("weibull", "gamma", "lognormal")
code <- sprintf("
  data{
    int<lower=1> N;
    vector[N] tStartExposure;
    vector[N] tEndExposure;
    vector[N] tSymptomOnset;
  }
  parameters{
    real<lower=0> par[2];
    vector<lower=0, upper=1>[N] uE;	// Uniform value for sampling between start and end exposure
  }
  transformed parameters{
    vector[N] tE; 	// infection moment
    tE = tStartExposure + uE .* (tEndExposure - tStartExposure);
  }
  model{
    // Contribution to likelihood of incubation period
    target += %s_lpdf(tSymptomOnset -  tE  | par[1], par[2]);
  }
  generated quantities {
    // likelihood for calculation of looIC
    vector[N] log_lik;
    for (i in 1:N) {
      log_lik[i] = %s_lpdf(tSymptomOnset[i] -  tE[i]  | par[1], par[2]);
    }
  }
", dists, dists)
names(code) <- dists

m0 <- mapply(stan_model, model_code=code)
fit <- mapply(sampling, m0, list(input), iter=10000, warmup=3000, chain=4)
ps <- mapply(function(z) extract(z)$par, fit, SIMPLIFY=FALSE)

# 確率分布のパラメータから得られる解析的な平均値
means <- cbind(ps$weibull[,1]*factorial(1+1/ps$weibull[,2]+1),
               ps$gamma[,1] / ps$gamma[,2],
               exp(ps$lognormal[,1]))
alpha <- c(0.025, 0.5, 0.975)
res <- apply(means, 2, quantile, alpha)
ll <- mapply(function(z) loo(extract_log_lik(z))$looic, fit)
rbind(res, looIC=ll)

新型肺炎COVID-19の感染力R0を推定する

読んだ。
www.ncbi.nlm.nih.gov
巷を賑わせているCOVID-19だが、厚生労働省がダイヤモンド・プリンセス号のPCR陽性者数を逐一ネットに挙げていたので、この論文にもあるようにそこからデータを取ってきて、COVID-19の感染力を推定しようと思った。
Basic reproduction number - Wikipedia

ここで、感染症の感染力とは、いろいろゴニョゴニョやった結果、R_0 と呼ばれる、感染者ひとりが何人に感染させるか、という推定値で感染力の強さがわかる。ここで、この論文での推定値はR_0=2.28 (95% CI 2.06-2.52) ということになっている。
COVID-19は飛沫感染ということになっているので、だいたい1-3くらいのR_0 である。例えば、最強の空気感染の感染形態をもつ麻疹は、R_0=18 くらいあるようなので、めっちゃ強い(小並感
ちなみに、感染力R_0 がわかると、集団のどれくらいの人が免疫をつければ感染を押さえ込めるかがモデル的にわかって、1-\frac{1}{R_0} となる。R_0<1 なら勝手に感染が収束するし、R_0>1なら少しは集団免疫がないと感染が大爆発する。季節性インフルエンザはR_0=3 くらいなので、60-70% くらいがワクチン接種をして集団免疫をつけると感染の大流行が防げるし、感染力の強い麻疹は、95% くらいが集団免疫をつけないと大流行する。
昔、こんなことをやった。
mikuhatsune.hatenadiary.com

さて、論文のとおりにやってみよう。論文ではまず、日本に停泊したダイヤモンド・プリンセス号のPCR陽性者数を、厚生労働省の発表から取ってきたようである。しかし、第8報(なぜか全角である)だけ引用されていて、停泊して隔離(?)され始めた2月3日から2月16日までのデータを利用したようだが、正直データは集まらないと思う。
横浜港に寄港したクルーズ船内で確認された新型コロナウイルス感染症について
新型コロナウイルス感染症の現在の状況と厚生労働省の対応について(令和2年2月6日版)
横浜港で検疫中のクルーズ船内で確認された新型コロナウイルス感染症について(第3報)
横浜港で検疫中のクルーズ船内で確認された新型コロナウイルス感染症について(第4報)
横浜港で検疫中のクルーズ船内で確認された新型コロナウイルス感染症について(第5報)
横浜港で検疫中のクルーズ船内で確認された新型コロナウイルス感染症について(第6報)
新型コロナウイルス感染症の現在の状況と厚生労働省の対応について(令和2年2月12日版)
横浜港で検疫中のクルーズ船内で確認された新型コロナウイルス感染症について(第8報)
横浜港で検疫中のクルーズ船内で確認された新型コロナウイルス感染症について(第9報)
横浜港で検疫中のクルーズ船内で確認された新型コロナウイルス感染症について(第10報)
横浜港で検疫中のクルーズ船内で確認された新型コロナウイルス感染症について(第11報)
横浜港で検疫中のクルーズ船内で確認された新型コロナウイルス感染症について(第12報)
横浜港で検疫中のクルーズ船内で確認された新型コロナウイルス感染症について(第13報)
横浜港で検疫中のクルーズ船内で確認された新型コロナウイルス感染症について(第14報)
横浜港で検疫中のクルーズ船内で確認された新型コロナウイルス感染症について(2月23日公表分)
横浜港で検疫中のクルーズ船内で確認された新型コロナウイルス感染症について(2月26日公表分)

実はwiki にまとまっていた。
クルーズ客船における2019年コロナウイルス感染症の流行状況 - Wikipedia

論文ではearlyR というパッケージのget_Rという関数でR_0 の推定を行なっている。これには感染から発症までの期間 serial interval というものが必要らしく、ガンマ分布で近似しているようなので、こちらの論文から平均 7.5、標準偏差 3.4 となるようにすると、shape=4.865917、scale=1.541333 となる。
Early Transmission Dynamics in Wuhan, China, of Novel Coronavirus-Infected Pneumonia. - PubMed - NCBI

f:id:MikuHatsune:20200317233338p:plain

2月16日までのデータで論文の通り(? データがあっているのかわからないしコードも本当にあっているのかわからないのでわからない)に実行すると、R_0=2.322 だった。
f:id:MikuHatsune:20200317233653p:plain

さて、ダイヤモンド・プリンセス号のデータは2月26日まであって、プロットをみる限りでは2月20日くらいから感染者数の急激な増加は収まっているようにみえるので、2月26日までのデータでやってみる。ここで、PCR陽性が判明した2月5日から、1日ずつ増加させてみながらR_0 を推定すると、感染拡大の超初期は莫大に感染が増えている(R_0 が大きい)が、なんらかの値に収束していくようである。こういうようにR_0 を推定するのが果たして正しいのかどうかは知らない。
ここで、R_0 の収束にはdrc パッケージのEXD.3 関数を用い、漸近モデルとした。このとき、R_0=1.62 くらいだった。
(飛んでいる日は前後の感染者総数および検査総数から適当に補完してシミュレーションしたので、若干のばらつきがある)
f:id:MikuHatsune:20200317234030p:plain

get_R の仕様をまだよく読み込んでないのだが、\lambda というのが感染の勢い(?) を表している。ここでは観察から14日目(2月19日)にピークで、その後感染拡大の勢いが小さくなっている。
f:id:MikuHatsune:20200317234357p:plain

本当にこれであっているのかよくわからないので、サンプルでエボラをやってみた。2014年にエボラの大流行があって、outbreaks というパッケージにデータが入っている。エボラ自体は血液感染で、R_0=2 くらいらしい。
これもCOVID-19 と同じようにやってみると、結局R_0=1.5 くらいになった。いいのかよくわからない。
f:id:MikuHatsune:20200317234517p:plain

積んでるリスト
Time-varying transmission dynamics of Novel Coronavirus Pneumonia in China | bioRxiv
www.ncbi.nlm.nih.gov
https://web.stanford.edu/~jhj1/teachingdocs/Jones-on-R0.pdf

dat <- read.delim("corona_infection.txt", stringsAsFactors=FALSE)

library(earlyR)
library(incidence)
library(drc)
library(stringr)
library(outbreaks)

# 論文のデータを再現する
xx <- seq(0, 23, length=1000)
x <- 0:21

m0 <- 7.5
sd0 <- 3.4

# ガンマ分布のパラメータに戻す
a <- (m0/sd0)^2
s <- (sd0^2/m0)

plot(xx, dgamma(xx, shape=a, scale=s), type="l", xlab="Days after onset", ylab="", lwd=3)
points(x, dgamma(x, shape=a, scale=s), pch=15)

# 厚生労働省のデータは飛んでいる日があるので
# 飛んでいる前後の日のデータから適当にサンプリングして補完する
n <- dat$total_positive
positive_N_simulator <- function(n){
  r <- rle(is.na(n))
  r0 <- tapply(n, rep(seq(r$lengths), r$lengths), c)
  r1 <- tapply(seq(n), rep(seq(r0), sapply(r0, length)), c)
  r2 <- sapply(sapply(r0, is.na), any)
  r3 <- sapply(r1[r2], length)
  r4 <- list(n[sapply(r1[r2], head, 1) - 1], n[sapply(r1[r2], tail, 1) + 1])
  r5 <- sapply(mapply(function(z) sample(r4[[1]][z]:r4[[2]][z], size=r3[z], replace=FALSE), seq(r3)), sort)
  n1 <- replace(n, is.na(n), unlist(r5))
  n2 <- mapply(rbinom, n=1, size=unlist(r5), prob=sample(na.omit(dat$total_positive/dat$total_n), size=1))
  N <- replace(dat$test_positive, is.na(dat$test_positive), diff(n1)[which(is.na(dat$test_positive))-1])
  return(N)
}

# wiki からとったデータ
total <- 3711
wiki <- c(10, 20, 61, 64, 70, 135, 135, 174, 218, 218, 285, 355, 454, 542, 621, 634, 691, 705, 706, 706, 712)
N <- c(wiki[1], diff(wiki))

# 飛んでいる日を適当に補完してシミュレーション
iter <- 50
R0 <- matrix(NA, nrow(dat), iter)
for(j in seq(iter)){
  N <- positive_N_simulator(dat$total_positive)
  for(i in 2:length(N)){
    inc <- incidence(rep(seq(N[1:i]), N[1:i]))
    res <- get_R(inc, si_mean=m0, si_sd=sd0, max_R=20)
    R0[i,j] <- res$R_ml
  }
}

# フィッテング
Y <- c(R0)
X <- c(row(R0))
fit <- drm(Y ~ X, fct=EXD.3())
cur <- predict(fit, as.data.frame(xx))

yl <- c(0, max(R0, na.rm=TRUE))
txt <- format(as.Date(dat$date), "%m/%d")
rownames(R0) <- txt
par(mar=c(4, 5, 2, 2))
matplot(R0, pch=16, xaxt="n", ylim=yl, las=2, xlab="", ylab=expression(R[0]), col=1, cex.lab=2)
axis(1, at=seq(nrow(R0)), labels=txt, las=2)
abline(h=1, lty=3)
lines(xx, cur, lwd=3, col="red")


# エボラでやってみる
onset <- outbreaks::ebola_sim$linelist$date_of_onset
N <- table(onset)
R0 <- rep(0, length(N))
res <- vector("list", length(N))
for(i in 2:length(R0)){
  inc <- incidence(rep(seq(N[1:i]), N[1:i]))
  res[[i]] <- get_R(inc, disease="ebola", max_R=20)
  R0[i] <- res[[i]]$R_ml
}
xx <- seq(0, 200, length=1000)
Y <- R0[R0 > 0]
X <- seq(R0)[R0 > 0]
fit <- drm(Y ~ X, fct=EXD.3())
cur <- predict(fit, as.data.frame(xx))

xl <- c(0, length(N))
par(mfrow=c(3, 1), mar=c(4, 5, 2, 2), cex.lab=1.5, las=1)
plot(R0, xlab="Date", ylab=expression(R[0]), xlim=xl, pch=15)
lines(xx, cur, lwd=3, col="red")
abline(h=1, lty=3)
plot(res[[40]]) # 適当に40日目
plot(tail(res, 1)[[1]], "lambda", xlim=xl)
date	test_positive	test_n	asymptomatic	total_positive	total_n	total_asymptomatic	title	url
2020-02-05	10	31		10	31		横浜港に寄港したクルーズ船内で確認された新型コロナウイルス感染症について	https://www.mhlw.go.jp/stf/newpage_09276.html
2020-02-06	10	71		20	102		新型コロナウイルス感染症の現在の状況と厚生労働省の対応について(令和2年2月6日版)	https://www.mhlw.go.jp/stf/newpage_09360.html
2020-02-07	41	171		61	273		横浜港に寄港したクルーズ船内で確認された新型コロナウイルス感染症について	https://www.mhlw.go.jp/stf/newpage_09340.html
2020-02-08	3	6		64	279		横浜港に寄港したクルーズ船内で確認された新型コロナウイルス感染症について(第4報)	https://www.mhlw.go.jp/stf/newpage_09398.html
2020-02-09	6	57		70	336		横浜港で検疫中のクルーズ船内で確認された新型コロナウイルス感染症について(第5報)	https://www.mhlw.go.jp/stf/newpage_09405.html
2020-02-10	65	103		135	439		横浜港で検疫中のクルーズ船内で確認された新型コロナウイルス感染症について(第6報)	https://www.mhlw.go.jp/stf/newpage_09419.html
2020-02-11
2020-02-12	39	67		174	492		新型コロナウイルス感染症の現在の状況と厚生労働省の対応について(令和2年2月12日版)	https://www.mhlw.go.jp/stf/newpage_09450.html
2020-02-13	44	221		218	713		横浜港で検疫中のクルーズ船内で確認された新型コロナウイルス感染症について(第8報)	https://www.mhlw.go.jp/stf/newpage_09425.html
2020-02-14								
2020-02-15	67	217	38	285	930	73	横浜港で検疫中のクルーズ船内で確認された新型コロナウイルス感染症について(第9報)	https://www.mhlw.go.jp/stf/newpage_09542.html
2020-02-16	70	289	38	355	1219	111	横浜港で検疫中のクルーズ船内で確認された新型コロナウイルス感染症について(第10報)	https://www.mhlw.go.jp/stf/newpage_09547.html
2020-02-17	99	504	70	454	1723	189	横浜港で検疫中のクルーズ船内で確認された新型コロナウイルス感染症について(第11報)	https://www.mhlw.go.jp/stf/newpage_09568.html
2020-02-18	88	681	65	542	2404	254	横浜港で検疫中のクルーズ船内で確認された新型コロナウイルス感染症について(第12報)	https://www.mhlw.go.jp/stf/newpage_09606.html
2020-02-19	79	607	68	621	3011	322	横浜港で検疫中のクルーズ船内で確認された新型コロナウイルス感染症について(第13報)	https://www.mhlw.go.jp/stf/newpage_09640.html
2020-02-20	13	52	6	634	3063	328	横浜港で検疫中のクルーズ船内で確認された新型コロナウイルス感染症について(第14報)	https://www.mhlw.go.jp/stf/newpage_09668.html
2020-02-21								
2020-02-22								
2020-02-23	57	831	52	691	3894	380	横浜港で検疫中のクルーズ船内で確認された新型コロナウイルス感染症について(223日公表分)	https://www.mhlw.go.jp/stf/newpage_09708.html
2020-02-24								
2020-02-25								
2020-02-26	14	167	12	705	4061	392	横浜港で検疫中のクルーズ船内で確認された新型コロナウイルス感染症について(226日公表分)	https://www.mhlw.go.jp/stf/newpage_09783.html

rstanで自分で定義した確率分布からサンプリングする:Johnson's SU 分布

本当はこの通りにしたかったが、自作関数のサンプリングが遅すぎたので先に正規分布normalからのサンプリングがvectorかひとつひとつかtargetかで変わるのかを検証していた。
結論から言うと組み込みのvector型サンプリングは速いが、自作関数はひとつひとつサンプリングすることになるので、圧倒的遅さ。
mikuhatsune.hatenadiary.com

これをやっていたが、実際のデータはやはり単純にガンマ分布ではあてはまりが悪かった。
mikuhatsune.hatenadiary.com
というわけで原点から最頻値が遠くて、かつ、左右非対称な分布をゴリ押ししようと思っていたら、Gumbel 分布gumbel)でできるようだが、もっと歪ませたいと思っていたら、Johnson's SU 分布とうものがあるらしい。これは、適当な変換を挟んで正規分布に従うようにして、確率密度関数
\frac{\delta}{\sqrt{2 \pi \lambda^2}}\frac{1}{\sqrt{1+(\frac{x-\xi}{\lambda})^2}}e^{-\frac{1}{2}*(\gamma+\delta\sinh^{-1} (\frac{x-\xi}{\lambda}))^2}
となる。これをrstanで定義すると
delta/(2*pi()*lambda^2)^0.5 * 1/(1+((x-xi)/lambda)^2)^0.5 * exp(-0.5*(gamma+delta*asinh((x-xi)/lambda))^2)
となる。

Johnson 関数群自体はSuppDistsパッケージで使える。適当に正の範囲(といっても定義域は負もある)で最頻値が50程度で左右非対称な分布を作る。パラメータを与えると、sJohnson関数で平均や分散など得られる。

sJohnson(parms)
$title
[1] "Johnson Distribution"

$gamma
[1] -5.5

$delta
[1] 2

$xi
[1] 7.5

$lambda
[1] 5

$type
SU 
 3 

$Mean
[1] 51.63246

$Median
[1] 46.44676

$Mode
[1] 37.23034

$Variance
[1] 561.298

$SD
[1] 23.69173

$ThirdCentralMoment
[1] -23119.93

$FourthCentralMoment
[1] 2784825

$PearsonsSkewness...mean.minus.mode.div.SD
[1] 0.6078967

$Skewness...sqrtB1
[1] -1.738587

$Kurtosis...B2.minus.3
[1] 5.83916


推定した結果はそこそこよい。しかし時間がクッソかかった。
f:id:MikuHatsune:20200314214536p:plain

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

library(SuppDists)
parms <- list(gamma=-5.5, delta=2, xi=7.5, lambda=5, type="SU")
n <- 3000
hoge <- rJohnson(n, parms)

code <- "
  functions{ //手作り正規分布を定義
    real johnsonSU_lpdf(real x, real gamma, real delta, real xi, real lambda){
      real tmp;
      tmp = delta/(2*pi()*lambda^2)^0.5 * 1/(1+((x-xi)/lambda)^2)^0.5 * exp(-0.5*(gamma+delta*asinh((x-xi)/lambda))^2);
      return log(tmp);
    }
  }
  data {
    int<lower=0> N;
    real<lower=0> y[N];
  }
  parameters {
  real gamma;
  real<lower=0> delta;
  real xi;
  real<lower=0> lambda;
  }
  model {
    for(i in 1:N){
    y[i] ~ johnsonSU(gamma, delta, xi, lambda);
    }
  }
"

m0 <- stan_model(model_code=code)
standata <- list(N=length(hoge), y=hoge)
fit <- sampling(m0, standata, iter=1000, warmup=500, chain=4)
ex <- extract(fit, pars=head(fit@model_pars, -1))
pa <- c(lapply(ex, median), type="SU")


x <- seq(0, 200, length=300)
d0 <- dJohnson(x, parms)
d1 <- dJohnson(x, pa)
hist(hoge, nclass=100, freq=F, main="Johnson SU", col="yellow")
lines(x, d0, col=2, lwd=4)
lines(x, d1, col=4, lwd=4)

rstanでの確率分布からのサンプリングの速さを比較する

rstanで自作関数、というかrstanに実装されていない確率分布からサンプリングをしたくてコードを書いていたが、その前にコードの書き方でサンプリングの効率というか速さが違うので速くなる書き方をしよう、という検証。
結論から言うと、実装されている関数ならば、vector 型でサンプリングするのがよく、自作関数を作るとひとつのrealもしくはintでサンプリングするので、遅い。

5つのパターンを比較する。どれも正規分布N(1, 1)からデータを作り、正規分布normal(m, s)で推定する。
code0は、vector型でy ~ normal(m, s)とサンプリングする。
code1は、ひとつひとつy[i] ~ normal(m, s)とサンプリングする。
code2は、target記法を用いてtarget += normal(y[i] | m, s)とサンプリングする。
code3は、自作関数tmp = delta/(2*pi()*lambda^2)^0.5 * 1/(1+((x-xi)/lambda)^2)^0.5 * exp(-0.5*(gamma+delta*asinh((x-xi)/lambda))^2); を定義し、code1のようにひとつひとつサンプリングする。
code4は、code3の自作関数をtarget記法でサンプリングする。
ちなみにrstanで自作関数を利用するとき、func_lpdfで関数を定義し、返り値はlog(return)とする。また、target記法で利用するときは、func_lpdfで記述する。

結果としてはcode0vector型でのサンプリングが一番早かった。rstanに定義されている関数を利用する場合は、ひとつひとつサンプリングするcode1のほうがtarget記法より速いようだった。
自作関数を利用する場合は、target記法のほうが速そうな気がする。
f:id:MikuHatsune:20200312225316p:plain

hoge <- rnorm(300, 1, 1)
code0 <- "
    data {
    int<lower=0> N;
    real y[N];
  }
  parameters {
    real m;
    real<lower=0> s;
  }
  model {
    y ~ normal(m, s);
  }
"
code1 <- "
    data {
    int<lower=0> N;
    real y[N];
  }
  parameters {
    real m;
    real<lower=0> s;
  }
  model {
    for(i in 1:N){
      y[i] ~ normal(m, s);
    }
  }
"
code2 <- "
    data {
    int<lower=0> N;
    real y[N];
  }
  parameters {
    real m;
    real<lower=0> s;
  }
  model {
    for(i in 1:N){
      target += normal_lpdf(y[i] | m, s);
    }
  }
"
code3 <- "
  functions{ //手作り正規分布を定義
    real my_lpdf(real x, real m, real s){
      real tmp;
      tmp = 1/(2*pi()*s^2)^0.5 * exp(-0.5*((x-m)/s)^2);
      return log(tmp);
    }
  }
  data {
    int<lower=0> N;
    real y[N];
  }
  parameters {
    real m;
    real<lower=0> s;
  }
  model {
    for(i in 1:N){
      y[i] ~ my(m, s);
    }
  }
"
code4 <- "
  functions{ //手作り正規分布を定義
    real my_lpdf(real x, real m, real s){
      real tmp;
      tmp = 1/(2*pi()*s^2)^0.5 * exp(-0.5*((x-m)/s)^2);
      return log(tmp);
    }
  }
  data {
    int<lower=0> N;
    real y[N];
  }
  parameters {
    real m;
    real<lower=0> s;
  }
  model {
    for(i in 1:N){
      target += my_lpdf(y[i] | m, s);
    }
  }
"
codes <- list(code0, code1, code2, code3, code4)
names(codes) <- c("vector", "elementwise", "element_target", "self_function", "self_target")

# 一括してコンパイルするが
# コンピュータのメモリが貧弱だと並列にすると死ぬかもしれない
library(rstan)
rstan_options(auto_write=TRUE)
# options(mc.cores=parallel::detectCores())


ms <- mapply(stan_model, model_code=codes)
standata <- list(N=length(hoge), y=hoge)
fits <- mapply(function(z) sampling(z, standata, iter=2000, warmup=1000, chain=100), ms)

elp <- mapply(function(w) colSums(mapply(function(z) attributes(z)$elapsed_time, w@sim$samples)), fits)


library(vioplot)
vioplot(elp, horizontal=TRUE, side="right", yaxt="n", xlab="elapsed time [sec]")
abline(h=seq(ncol(elp)), lty=3)
axis(1)
text(par()$usr[2], seq(ncol(elp))+0.3, colnames(elp), xpd=TRUE, pos=2)

臨床に直結しそうで、ベッドサイドですぐに役立ちそうなエビデンスはぶっちゃけ書かれていない

読んだ。

COI:定価は高かったけど古くなったのでくっそ安くなってたので買って積んでた。読み始めてから知り合いがいたことに気づいた。

インテンシヴィストっぽく、とあるテーマにたいして文献検索してPICOをまとめただけの本。解説部分と文献検索結果がだいたい7:3くらいな感じなので、500Pくらいあるけど実質300Pくらい。
ほとんどの項目が強固なエビデンスでやったほうがよい、というものではないので、結局その病院ルールで治療が進みそうな感じがする。集中治療しらんけど。

EGDTについて
www.ncbi.nlm.nih.gov
の論文、本文中では

主要アウトカムの病院内死亡率がScvO2 群で23%(95% CI 17-30%)、乳酸群で17%(95% CI 11-24%)であり、統計学的に差がないことが証明された。

と書いているが、統計学的に差がないことを証明する統計学手法があったらぜひ知りたい、と思って原著を確認すると

OBJECTIVE: To test the hypothesis of noninferiority between lactate clearance and central venous oxygen saturation (ScvO2) as goals of early sepsis resuscitation.

10%マージンを設定した非劣性デザインであって

CONCLUSION: Among patients with septic shock who were treated to normalize central venous and mean arterial pressure, additional management to normalize lactate clearance compared with management to normalize ScvO2 did not result in significantly different in-hospital mortality.

乳酸クリアランスを指標にしたショック管理はCVとってScvO2 を管理するのとは、統計学的には有意な差にはならなかった、と言っているだけであって、差がない、とは言ってないので解散。

薦める理由がない。

こういうことだったようだ:酸素療法・NPPV・CHDF

読んだ。

こういうことだったのか!! 酸素療法

こういうことだったのか!! 酸素療法

  • 作者:小尾口 邦彦
  • 発売日: 2017/04/19
  • メディア: 単行本(ソフトカバー)
こういうことだったのか!! NPPV

こういうことだったのか!! NPPV

  • 作者:小尾口 邦彦
  • 発売日: 2017/07/19
  • メディア: 単行本(ソフトカバー)
こういうことだったのか!! CHDF

こういうことだったのか!! CHDF

  • 作者:小尾口 邦彦
  • 発売日: 2018/02/27
  • メディア: 単行本(ソフトカバー)
COI:職場にあった。

各々2000円くらいなので買ってもまあよい。
麻酔的には馴染みがないが、ICU的にはよく使われる医療機器。
生理学的なところの整理と、医療機器の説明があったのでそれなりにわかりやすいとは思う。
ただし、実際の患者にどう使うか(使ったか)というのはあまり記載がないので、そこらへんを知りたいなら意識高くインテンシヴィストを読まなければならないかもしれない。

令和2年2月21日版の国内コロナ陽性者をgooglevisでやる

www.mhlw.go.jp
これの2月20日12:00現在、確認されている国内の発生状況の国内事例(チャーター便帰国者を除く)をgooglevisを使って都道府県名別にプロットしてみようと思った。
googlevisクッソ使いにくい。
厚生労働省もがんばっているのだろうが、(令和2年2月21日版)って半角と全角が入り乱れいるのが謎だし、2月19日版のデータでは年齢が40<代っていう人がいてがんばれ、って思った。




GeoChartID1d202ba7ad88






新型コロナウイルス感染症の現在の状況と厚生労働省の対応について(令和2年2月21日版)

library(googleVis)
library(stringr)
library(textreadr)
url <- "https://www.mhlw.go.jp/stf/newpage_09670.html" # 2月19日版
url <- "https://www.mhlw.go.jp/stf/newpage_09690.html" # 2月21日版
webpage <-"新型コロナウイルス感染症の現在の状況と厚生労働省の対応について(令和2年2月21日版)" 
html <- read_html(url)

idx0 <- which(str_detect(html, "確認されている国内の発生状況は以下のとおり"))
idx1 <- which(str_detect(html, "2/19"))
idx2 <- which(str_detect(html, "男|女"))
idx3 <- which(str_detect(html, "武漢市からのチャーター便帰国者に係る発生状況"))
idx4 <- idx2[idx2 < idx3]

pref <- c('北海道','青森','岩手','宮城','秋田','山形','福島','茨城','栃木','群馬','埼玉','千葉','東京','神奈川','新潟','富山','石川','福井','山梨','長野','岐阜','静岡','愛知','三重','滋賀','京都','大阪','兵庫','奈良','和歌山','鳥取','島根','岡山','広島','山口','徳島','香川','愛媛','高知','福岡','佐賀','長崎','熊本','大分','宮崎','鹿児島','沖縄')

mat <- matrix(html[c(t(outer(idx4, -2:1, "+")))], nc=4, byrow=TRUE)
colnames(mat) <- c("date", "age", "sex", "pref")
mat[,4] <- str_replace(mat[,4], "[都道府県]$", "")
mat[,4] <- ifelse(mat[,4]=="中国", NA, mat[,4])
mat <- as.data.frame(mat)
mat[,1] <- as.Date(sprintf("2020/%s", mat[,1]))

dat <- data.frame(table(factor(mat$pref, pref)))
colnames(dat) <- c("pref", "N")

opt <- list(region="JP", displayMode="regions", resolution="provinces", height=500, width=800)
c0 <- seq(min(dat$N), max(dat$N), length=7)
opt$colorAxis <- paste0("{values:[", paste(c0, collapse=","), "], colors:['", paste0(matlab::jet.colors(length(c0)), collapse="','"), "']}", collapse="")

gmap <- gvisGeoChart(dat, "pref", "N", options=opt)
gmap$html$caption <- NULL
#gmap$html$footer <- NULL
gmap$html$footer <- str_replace(gmap$html$footer,
                                "<span> \n  .+\n  .+\n</span>",
                                sprintf("<span><a href='%s' target='_blank'>%s</a></span>", url, webpage))
plot(gmap)