経過表というものがある。一般用語なのかはしらないが、いつぞやにどういうことをしてどういうことが起きてどういうように値が変化したか、みたいなことをひたすら書く表である。
これを、普通ならエクセル内のデータを折れ線グラフにしてppt に貼り付けて、イベントをちくいち追加して…というように作るが、面倒なので全部Rでやる。
実際のデータは少し加工した。
# データの読み込み d <- read.delim("clipboard", row=1) # 日付 最初から最後まで全部出す f <- as.Date(rownames(d)) # 本当はlist 管理にしてfor で回すのが賢い # 細かな微調整のためにひとつずつやるはめに # Event の設定 ev1 <- as.Date("2016-01-01") # もっとも大事なイベントもしくは起点 day7 <- ev1 + (-5:7)*7 - 0.5 # 1週間ごとに補助線いれる ev2 <- as.Date("2016-01-25") # イベントその2 ev3 <- as.Date("2016-02-01") # イベントその2 # 期間の設定 # 適当に5つ int0 <- mapply(as.Date, c("2015-12-25", "2016-01-01")) int1 <- mapply(as.Date, c("2015-12-31", "2016-02-07")) int2 <- c(as.Date("2015-12-31"), f[length(f)]) int3 <- mapply(as.Date, c("2016-01-21", "2016-02-12")) int4 <- mapply(as.Date, c("2016-01-31", "2016-02-12")) int5 <- mapply(as.Date, c("2015-12-30", "2016-01-04")) # plot したいもの n <- d$n # もっとも示したいデータ lv <- d[, grep("P", colnames(d))] # 適当につけておきたいデータ xl <- c(int0[1], f[length(f)-2]) # xlim 終わりまでプロットすると間延びする idx <- -7:41 # ev1 を起点として前後何日分プロットするか ################# layout(matrix(2:1, nr=2), heights=c(1,3)) # 上下に比率を変えてプロット ### 1つめ par(mar=c(4.1, 5, 4.5, 1), cex.axis=1.6, cex.lab=1.6, cex=1.2) yl <- c(0, 2.5) # ylim plot(f, n, type="n", xaxt="n", xlab="", ylab=expression("Count ["*10^3*"]"), xlim=xl, ylim=yl, las=1) # 枠だけ pa <- par()$usr abline(h=seq(0, 5, by=0.5), lty=3) polygon(ev2+c(-1,1,1,-1)*0.5, pa[c(3,3,4,4)], col="lightgreen", border=NA) text(ev2, pa[4], "Event 2", srt=90, adj=c(1.1, NA)) polygon(ev1+c(-1,1,1,-1)*0.5, pa[c(3,3,4,4)], col="lightgreen", border=NA) text(ev1, pa[4], "Event 1", srt=90, adj=c(1.04, NA)) polygon(ev3+c(-1,1,1,-1)*0.5, pa[c(3,3,4,4)], col="lightgreen", border=NA) text(ev3, pa[4], "Event 3", srt=90, adj=c(1.08, NA)) lines(f[!is.na(n)], na.omit(n), type="o", pch=15, lwd=3) abline(v=f-0.5, lty=3) abline(v=day7, lwd=2) text(pa[1], pa[3], "day", xpd=TRUE, pos=1) text(ev1 + idx, pa[3], idx, xpd=TRUE ,pos=1) # 期間の表示 # ひとつずらすには ld をN + 1/2 にする ld <- 0.3 # 帯の縦幅 polygon(int1[c(1,2,2,1)]-0.5, pa[4]+rep(0:1, each=2)*ld, col="skyblue", xpd=TRUE) text(int1[1]-0.5, pa[4]+ld/2, "Interval 1", xpd=TRUE, pos=4) polygon(int2[c(1,2,2,1)]-0.5, pa[4]+rep(0:1, each=2)*ld+ld, col="green", xpd=TRUE) text(int2[1]-0.5, pa[4]+ld*3/2, "Interval 2", xpd=TRUE, pos=4) polygon(int0[c(1,2,2,1)]-0.5, pa[4]+rep(0:1, each=2)*ld-ld, col="violet", xpd=TRUE) text(int0[1]-0.5, pa[4]-ld/2, "Interval 0", xpd=TRUE, pos=4) polygon(int3[c(1,2,2,1)]-0.5, pa[4]+rep(0:1, each=2)*ld+ld*2, col="peachpuff", xpd=TRUE) text(int3[1]-0.5, pa[4]+ld*5/2, "Interval 3", xpd=TRUE, pos=4) polygon(int4[c(1,2,2,1)]-0.5, pa[4]+rep(0:1, each=2)*ld+ld*3, col="peachpuff", xpd=TRUE) text(int4[1]-0.5, pa[4]+ld*7/2, "Interval 4", xpd=TRUE, pos=4) polygon(int5[c(1,2,2,1)]-0.5, pa[4]+rep(0:1, each=2)*ld+ld*2, col="magenta1", xpd=TRUE) text(int5[1]-0.5, pa[4]+ld*5/2, "Interval 5", xpd=TRUE, pos=4) # 定期的なイベントの表示 hcol <- c(grey(0.95), "pink", "orange", "red") yadj <- 0.55 # box をどこに配置するかのy座標 yld <- 0.15 # box の縦幅 for(i in which(!is.na(d$scale) & f <= xl[2])){ xi <- f[i]+c(-1,1,1,-1)*0.5 yi <- pa[3]-yadj+c(-1,-1,1,1)*yld polygon(xi, yi, xpd=TRUE, col=hcol[d$scale[i]]) text(f[i], pa[3]-yadj, d$scale[i], xpd=TRUE) } text(pa[1], pa[3]-yadj, "Scale", xpd=TRUE) # 同時にやったりする処置や同時に起きたイベントを縦割りで表示する hcol <- c("yellow", "red") for(i in seq(nrow(d))){ j <- !is.na(d[i, c("pc", "rbc")]) xi <- f[i]+c(-1,1,1,-1)*0.5 if ( sum(j) == 1 ){ yi <- pa[3]-yadj-yld*2+c(-1,-1,1,1)*yld polygon(xi, yi, xpd=TRUE, col=hcol[j]) } else if ( sum(j) == 2 ) { yi0 <- pa[3]-yadj-yld*2+c(0,0,1,1)*yld yi1 <- pa[3]-yadj-yld*2+c(-1,-1,0,0)*yld polygon(xi, yi0, xpd=TRUE, col=hcol[1]) polygon(xi, yi1, xpd=TRUE, col=hcol[2]) } } text(pa[1], pa[3]-yadj-yld*2, "Procedure", xpd=TRUE) ### 2つめ yl <- c(0, max(lv, na.rm=TRUE)) lcol <- c("red", "green3") par(mar=c(0.2, 5, 1.5, 1), cex.axis=1.4, cex.lab=1.6, cex=1.2) matplot(f, lv, type="n", xaxt="n", xlab="", ylab=expression("parameters"), xlim=xl, ylim=yl, las=1, xpd=TRUE, cex.lab=1.1) for(j in seq(ncol(lv))) lines(f[!is.na(lv[,j])], na.omit(lv[,j]), type="o", pch=15, lwd=3, col=lcol[j]) abline(v=f-0.5, lty=3) abline(v=day7, lwd=2) abline(h=seq(0, 150, by=50), lty=3) legend("topright", legend=paste("P", 1:2), col=lcol, lty=1, pch=15, lwd=3, bg="white") pa <- par()$usr text(pa[1], pa[4], "day", xpd=TRUE, pos=3) text(ev1 + idx, pa[4], idx, xpd=TRUE ,pos=3)
day P1 P2 scale pc rbc n 2015-12-15 NA NA NA NA 2015-12-16 NA NA NA NA 2015-12-17 NA NA NA NA 2015-12-18 39 36 NA 1.33 2015-12-19 NA NA NA NA 2015-12-20 35 29 NA 1.1 2015-12-21 NA NA NA NA 2015-12-22 NA NA NA NA 2015-12-23 NA NA NA NA 2015-12-24 55 52 NA 1.03 2015-12-25 NA NA NA NA 2015-12-26 102 119 1 0.9 2015-12-27 88 119 1 1.06 2015-12-28 57 94 1 1.12 2015-12-29 NA NA 1 1 NA 2015-12-30 NA NA 1 NA 2015-12-31 46 57 1 1 0.66 2016-01-01 NA NA 1 0.74 2016-01-02 30 38 1 1 0.94 2016-01-03 NA NA 1 NA 2016-01-04 29 35 1 1 0.24 2016-01-05 22 27 1 0 2016-01-06 NA NA 1 1 1 0 2016-01-07 21 24 1 0 2016-01-08 NA NA 1 1 0.02 2016-01-09 17 18 2 1 0 2016-01-10 15 16 2 0 2016-01-11 15 14 4 1 0 2016-01-12 NA NA 4 1 NA 2016-01-13 NA NA 4 1 NA 2016-01-14 16 10 4 1 0.01 2016-01-15 NA NA 4 NA 2016-01-16 18 11 4 1 1 0.1 2016-01-17 NA NA 4 NA 2016-01-18 38 30 3 1 1 0.08 2016-01-19 NA NA 3 1 NA 2016-01-20 NA NA 3 1 NA 2016-01-21 58 83 3 1 1 0.36 2016-01-22 NA NA 3 NA 2016-01-23 33 61 2 1 1 0.37 2016-01-24 NA NA 2 1 NA 2016-01-25 39 65 2 1 0.61 2016-01-26 NA NA 3 1 NA 2016-01-27 NA NA 2 NA 2016-01-28 80 133 3 1.05 2016-01-29 NA NA 3 1 NA 2016-01-30 71 111 2 1 0.93 2016-01-31 NA NA 2 1 NA 2016-02-01 78 106 2 1 1.46 2016-02-02 NA NA 2 1 NA 2016-02-03 NA NA 2 1 1 NA 2016-02-04 110 152 2 1 1.6 2016-02-05 NA NA 2 NA 2016-02-06 71 116 2 1 1.94 2016-02-07 66 106 2 1.91 2016-02-08 57 84 2 1 2.38 2016-02-09 NA NA 2 NA 2016-02-10 NA NA 1 1 NA 2016-02-11 60 74 1 4.19 2016-02-12 NA NA 1 NA
