2015年7月30日木曜日

R と Google Earth ~等値線図の作成~

前回に引き続き今回も Google Earth を扱いたいと思います

緯度経度情報を含む平面的なデータがあるとき、やはり真っ先に「俯瞰的に情報を把握したい」と思うのではないでしょうか。
そんなときに便利なのが等値線図 (コンター) ですよね。

でもこの等値線図、どうやって描きますか?
Surfer に GMTこの他にも様々なソフトがありますよね

もちろん R にも contour() という関数があり、等値線図を描くことができます。しかし、contour() を利用する前には補間をしておかなければなりません。補間の種類は色々とあるのですが、今回はクリギングができるパッケージを紹介したいと思います。

そして等値線図を R で表示しただけでは、海岸線が表示されていないので、あまり意味がありません。
そこで、今回は、Google Earth に等値線図を貼り付けるコードを紹介したいと思います。

出力イメージはこんな感じです。



なにはともあれデータが必要なのでこちらのテストデータをご利用下さい。
このデータは前回 Google Earth にプロットした九州西部の AMeDAS の緯度経度データと気温のデータです
データは 2014 年 3 月 30 日 12:00 のものです。

必要となるパッケージは automap です。
それと表示用の Google Earth です


使い方 ---------------------------
はじめにプログラム上部に、変更可能な変数があるので、任意の値を設定して下さい。
xgn = 300 はテストデータの西端と東端の間を 300 等分したときの点という意味です。
ygn は北端と南端で同様のことを意味します
つまり、この値を増やすほど詳細に計算されますが、計算速度は当然落ちますし、結果のファイルも重たくなります。

これに関連して、reso で解像度を設定できます。reso = 1 のときは 480×480 ピクセルです。
これもあまりに大きくすると、綺麗ですが重たくなりますので、使用している PC のスペックに合わせて設定して下さい。

色の設定ではデフォルトで、白 → オレンジ に変わるようになっています。
R で指定できる色に変更可能ですし、カンマで切って繋げれば、複数設定することもできます。
例えば c("white", "orange", "red") な感じ

プログラムを実行すると、ファイル選択ウィンドウが開くので、テストデータあるいはご自分で作成したファイルを選んで下さい。
以上です。

読み込んだファイルがあるフォルダに「ファイル名_等値線図.kml」というファイルができているはずです。
これを開くと等値線図が見れます。


プログラムについて ---------------
補間に関しては、パッケージ automap の関数 autoKrige() に任せっきりです。
どのようなモデルで補間するかとかも指定できるので automap.pdf で確認して下さい。
デフォルトでは model="Gau" です。
途中でバリオグラムが表示されるので、正しく補間されているか確認して下さい。

特に自作関数は使ってないので、気になるところは一行ずつ実行してもらうと中身が分かると思います。



#作成日時 : 9:18 2011/07/06
 #作成者名:T. Nakano
 rm(list=ls())
 gc();gc()

 library(automap)
 # ////////////////  Google Earth で等値線図作成  ///////////////////

 # 変更可 -----------------------------------------------------------
 # 等値線の本数 ----------
 LN = 10

 # 等値線の値の桁数 -----
 dgt = 1

 # 外挿計算 --------------
 extrapolate = "off"          # on or off

 # 補間点数 --------------
 xgn = 300                       # x 軸方向に xgn 分割する
 ygn = 300                       # y 軸方向に ygn 分割する

 # 解像度 ----------------
 reso = 2

 # 色の設定 --------------
 cols = colorRamp(c("white", "orange"))

 # データの読込み -------------------------------------------------
 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)
 SRX <- read.csv(fileName, header=T)

 DT <- data.frame(x=SRX$LON, y=SRX$LAT, data=SRX$DATA)
 coordinates(DT) =~ x+y

 # 補間地点の緯度経度整理 -----------------------------------------
 Xst <- seq(min(SRX$LON), max(SRX$LON), length=xgn)
 Yst <- seq(min(SRX$LAT), max(SRX$LAT), length=ygn)

 Xip <- rep(Xst, each=length(Yst))
 Yip <- rep(Yst, length(Xst))
 Ncode <- data.frame(x=Xip, y=Yip)

 # クリギング -------------------------------------------------------
 gridded(Ncode)=~x+y
 kriging_result <- autoKrige(data~1, DT, Ncode, model="Gau")
 WR <- data.frame(LON=Xip, LAT=Yip, PRED=kriging_result$krige_output$var1.pred)
 plot(kriging_result)

 # 凸閉包で外挿除外 -------------------------------------------------
 if(extrapolate=="off"){
 act1 <- data.frame(x=SRX$LON, y=SRX$LAT)
 hullpnt <- chull(act1)
 hullpnt <- c(hullpnt,hullpnt[1])
 poly <- act1[hullpnt,]
 pip <- point.in.polygon(Xip,Yip,poly$x,poly$y)
 hullDT <- data.frame(x=Xip,y=Yip,pip)
 WR[which(hullDT$pip == 0), 3] <- NA
 }

 # コンター作成 ----------------------------------------------------
 con.x <- unique(WR$LON)
 con.y <- unique(WR$LAT)
 con.z <- matrix(WR$PRED, ncol=length(con.x), byrow=T)

 # 出力設定 ----------
 xlength <- max(SRX$LON)-min(SRX$LON)               # デバイスサイズの計算
 ylength <- max(SRX$LAT)-min(SRX$LAT)
 xratio <- xlength/xlength
 yratio <- ylength/xlength
 png("filledcontour_kirg.png", xratio*480*reso, yratio*480*reso)
 par(xaxs = "i", yaxs = "i", mar=c(0,0,0,0), omi=c(0,0,0,0), bg="transparent", xaxt="n", yaxt="n")

 # コンター作成 ------
 image(con.x, con.y, con.z, col=rgb(cols(0:(LN-1)/(LN-1))/255), bg="transparent", bty="n")
 maxn <- max(con.z[which(!is.na(con.z))])
 minn <- min(con.z[which(!is.na(con.z))])
 LV <- round(seq(minn, maxn, length=LN+1), dgt)
 contour(con.x, con.y, con.z, levels=LV, add=T, labcex=reso)
 points(SRX$LON, SRX$LAT, pch=16, col=4, cex=reso)

 dev.off()

 # KML 作成 ----------------------------------------------------------
 GEfn <- paste(unlist(strsplit(fileName, ".csv")), "_等値線図.kml", sep="")
 sink(GEfn)
 cat('<?xml version="1.0" encoding="UTF-8"?>
 <kml xmlns="http://www.opengis.net/kml/2.2">
 <GroundOverlay>
 <name>Contour</name>
 <color>5cffffff</color>
 <Icon>
 <href>filledcontour_kirg.png</href>
 <viewRefreshTime>0</viewRefreshTime>
 </Icon>
 <altitude>300</altitude>
 <altitudeMode>clampToGround</altitudeMode>
 <LatLonBox id="contour">
 <north>',max(SRX$LAT),'</north>
 <south>',min(SRX$LAT),'</south>
 <east>',max(SRX$LON),'</east>
 <west>',min(SRX$LON),'</west>
 </LatLonBox>
 </GroundOverlay>
 </kml>', sep='')
 sink()


2015年6月27日土曜日

R と Google Earth ~地点図の作成~

今回は R と Goole Earth の連携をご紹介したいと思います
というのも、緯度経度情報は意外とよく使うわりには一括で表示したりするのが面倒くさい!と感じたからです。

例えば、手元に多数の緯度経度データがあり、その位置関係を確認したい、他人に説明するときの簡単な資料を作りたい、というときに、Google Earth の [追加] → [目印] で一個一個入力なんてしてられないですよね。

ということで、R を使って Google Earth に地点を一括入力するプログラムを作りました。
出力イメージはこんな感じです。



今回使用した緯度経度データは、気象庁で公開されている九州西部の AMeDAS の設置場所です。
緯度経度データを整理したものをこちらに置いておきますので、テストデータとしてご使用下さい。


テストデータはこんな感じで並んでいます。

地点名 緯度 経度
Nagasaki 32.73333 129.8667
Nomozaki 32.57833 129.74
Ohmura 32.91667 129.9133
Ohseto 32.94833 129.6333
Sasebo 33.15833 129.7267

注意
・地点名に日本語は使えないようです (kml 形式の関係かな?)。
・緯度経度データは度表示 (10進法) です。



使い方
以下のプログラムを実行すると、ファイル選択ウィンドウが開くので、テストデータあるいはご自分で作成したファイルを選んで下さい。
以上です。

読み込んだファイルがあるフォルダに「ファイル名_地点図.kml」というファイルができているはずです。
これを開くと Google Earth が起動し地点図が表示されます




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

library(tcltk)
#////////////////  Google Earth で地点図作成  ///////////////////////////////////////////////////////////////////////
# 関数の設定 ----------------------------------------------------------# 地点情報を kml ファイルに変換する関数 -------------------------------
fun_KML <- function(地点名,緯度,経度,PointSize=0.8){
cat('<Placemark>
<name>',地点名,'</name>
<Point>
<coordinates>',経度,',',緯度,',0</coordinates>
</Point>
<Style>
<IconStyle>
<Icon>
<href>http://maps.google.com/mapfiles/kml/shapes/shaded_dot.png</href>
</Icon>
<color>ff0000ff</color>
<scale>',PointSize,'</scale>
</IconStyle>
</Style>
</Placemark>','\n', sep='')
}

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

directory <- NULL
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)
DT$地点名 <- as.character(DT$地点名)

# KML ファイル作成 ---------------------------------------------------
GEfn <- paste(unlist(strsplit(fileName, ".csv")), "_地点図.kml", sep="")
sink(GEfn)
cat('<?xml version="1.0" encoding="UTF-8"?>
<kml xmlns="http://www.opengis.net/kml/2.2">
<Folder>','\n')
for(i in 1:length(DT$緯度)){
fun_KML(DT$地点名[i],DT$緯度[i],DT$経度[i])
}
cat('</Folder>
</kml>','\n')
sink()






2015年5月24日日曜日

R で混合正規分布の分解 ~連続でコホート解析する~

前回の 2 回までで、混合正規分布から正規分布を単離する方法をご紹介しました。
これらのコードは調査 1 回分のデータを解析するものでした。

しかし、通常、個体群の調査は 1 回で終わることなく、同じフィールドで繰り返し行われます。ということは、データも調査 1 回分ではなく、複数回分あるはずです。

前回のコードで解析しようとすると、データをわざわざ Excel で 1 回分だけ取り出して、csv で保存して、R で解析して、また別の 1 回分のデータを Excel 取り出して、csv で保存して、R で解析して、また……、csv で……、解析して……。

面倒くさいこと極まりないですよね。

しかも、1 回 1 回の解析を別々で行うということは、コホートに ID を付けずに解析することになるので、成長や生残を追跡することができません。成長や生残が追跡できないということは、もはやコホート解析とは呼べないんじゃないかとも思います。



ということで、今回は、前回のコードを拡張し、データを全部ひっくるめて読み込んで、1 回分のデータを抽出するところから R にやってもらい、そしてコホートに ID を付けていくことで、後々の成長・生残の解析ができる形に持って行こうというコードを作りました。


さらに、このコードではデータファイルがあるフォルダに、正規分布が割り当てられたグラフが PDF 形式で書き出され、それぞれのパラメーターの値が csv 形式で書き出されるようにしておきました。


テストデータをこちらに置いておきます。
今回のコードの実行用に使用するなり、自分のデータを整形する参考にするなり、ご自由にお使い下さい。



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

library(mixtools)
library(tcltk)
# /////////////////////////////////////////////////////////////////////////////////

#ダイアログボックスから文字を記入する関数 ----------------------------------------
library(tcltk)
modalDialog <- function(title,question,entryInit,entryWidth=30,returnValOnCancel="ID_CANCEL"){
  dlg <- tktoplevel()
  tkwm.deiconify(dlg)
  tkgrab.set(dlg)
  tkfocus(dlg)
  tkwm.title(dlg,title)
  textEntryVarTcl <- tclVar(paste(entryInit))
  textEntryWidget <- tkentry(dlg,width=paste(entryWidth),textvariable=textEntryVarTcl)
  tkgrid(tklabel(dlg,text="       "))
  tkgrid(tklabel(dlg,text=question),textEntryWidget)
  tkgrid(tklabel(dlg,text="       "))
  ReturnVal <- returnValOnCancel
  onOK <- function()
  {
    ReturnVal <<- tclvalue(textEntryVarTcl)
    tkgrab.release(dlg)
    tkdestroy(dlg)
  }
  OK.but     <-tkbutton(dlg,text="   OK   ",command=onOK)
  tkgrid(OK.but)
  tkgrid(tklabel(dlg,text="    "))
  tkfocus(dlg)
  tkbind(textEntryWidget, "<Return>", onOK)
  tkwait.window(dlg)

  return(ReturnVal)

}

# データの読み込み --------------------------------------------------------------
# データが整理されている csv ファイルを選択する。
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)
WR <- read.csv(fileName, header=T)
WR$TL <- as.numeric(as.character(WR$TL))

# コホート解析開始 ---------------------------------------------------------------
PARA <- NULL
unidate <- unique(WR$date)
for(i in 1:length(unidate)){
DT <- WR[which(WR$date==unidate[i]),]

for(j in 1:200){
# ヒストグラムを書く -------------------------------------------------------------
win.graph()
#pitch=(max(WR$TL)-min(WR$TL))/15     # だいたいバーが15本
pitch=1
BKS <- seq(-pitch, max(WR$TL)+pitch*2, by=pitch)

TLhist <- hist(DT$TL, breaks=BKS, plot=F)
hist(DT$TL, breaks=BKS, main=unidate[i], ylim=c(0,max(TLhist$counts)*1.5))

# 初期値を設定する ---------------------------------------------------------------
# ピークと思われるところを全てクリックする。
# 右クリック → 停止 で locator() を止める。
int <- locator()

# 正規分布を単離する -------------------------------------------------------------
if(length(int$x)==1){
NM <- data.frame(mu=mean(DT$TL), sigma=sd(DT$TL), lambda=1)
xdt <- seq(min(DT$TL), max(DT$TL), length=200)
lines(xdt, NM$lambda*dnorm(xdt, mean=NM$mu, sd=NM$sigma)*length(DT$TL)*pitch, col=2)

}else if(length(int$x) > 1){
NM <- normalmixEM(DT$TL, mu=int$x)
xdt <- seq(min(DT$TL), max(DT$TL), length=200)
for(j in 1:length(int$x)){
lines(xdt, NM$lambda[j]*dnorm(xdt, mean=NM$mu[j], sd=NM$sigma[j])*length(DT$TL)*pitch, col=2)
}
}    # if(length(int$x)==1)

cond <- tkmessageBox(message="コホート分けをやり直しますか?",icon="question",type="yesno",default="yes")
if(as.character(cond)=="no") break
}     # for(j in 1:200)

PARA1 <- data.frame(mu=NM$mu, sigma=NM$sigma, N=NM$lambda*length(DT$TL), lambda=NM$lambda)

maxdt <- PARA1$lambda*dnorm(PARA1$mu, mean=PARA1$mu, sd=PARA1$sigma)*length(DT$TL)*pitch
text(PARA1$mu, maxdt, labels=paste("age", 1:length(maxdt), sep=""), pos=3)

CN <- NULL
for(j in 1:length(maxdt)){
ReturnVal <- modalDialog("cohort name", paste("age", j, " → ") ,"")
CN <- c(CN, ReturnVal)
}

hist(DT$TL, breaks=BKS, main=unidate[i], ylim=c(0,max(TLhist$counts)*1.5))
for(j in 1:length(int$x)){
lines(xdt, NM$lambda[j]*dnorm(xdt, mean=NM$mu[j], sd=NM$sigma[j])*length(DT$TL)*pitch, col=2)
}
text(PARA1$mu, maxdt, labels=CN, pos=3)

PARA1 <- data.frame(cohort=CN, date=unidate[i], PARA1)

PARA <- rbind(PARA, PARA1)
}     # for(i in 1:length(unidate))

View(PARA)

# 結果を保存する ----------------------------------------------------
write.csv(PARA, file="混合正規分布の分解_結果_パラメーター.csv", row.names=F)

pdf("混合正規分布の分解_結果_ヒストグラム.pdf")
mxv <- NULL
for(i in 1:length(unidate)){
DT <- WR[which(WR$date==unidate[i]),]
BKS <- seq(-pitch, max(WR$TL)+pitch*2, by=pitch)
TLhist <- hist(DT$TL, breaks=BKS, plot=F)
mxv <- c(mxv, max(TLhist$counts))
}

BKS <- seq(-pitch, max(WR$TL)+pitch*2, by=pitch)

for(i in 1:length(unidate)){
DT <- WR[which(WR$date==unidate[i]),]
hist(DT$TL, breaks=BKS, main="", ylim=c(0,max(mxv)*1.5))
legtxt <- paste(unidate[i], "\n", "N = ", nrow(DT) ,sep="")
legend("topleft", legend=legtxt, bty="n", cex=0.8)

PARA1 <- PARA[which(PARA$date==unidate[i]),]
xdt <- seq(-pitch, ceiling(max(WR$TL))+pitch*2+0.5, length=200)
for(j in 1:nrow(PARA)){
lines(xdt, PARA1$lambda[j]*dnorm(xdt, mean=PARA1$mu[j], sd=PARA1$sigma[j])*length(DT$TL)*pitch, col=2)
}

maxdt2 <- NULL
for(j in 1:nrow(PARA)){
act1DT <- max(PARA1$lambda[j]*dnorm(xdt, mean=PARA1$mu[j], sd=PARA1$sigma[j])*length(DT$TL)*pitch)
maxdt2 <- c(maxdt2, act1DT)
}
text(PARA1$mu, maxdt2, labels=PARA1$cohort, pos=3)

}

dev.off()



このコードを実行すると、まずデータファイルを指定するよう求められます。
データファイルをしてすると、ファイルが読み込まれ、1 回目の調査のデータが抽出されます。
そして、前回同様、locator が発動し、ピークをクリックして初期値を与えるよう求められます。

全てクリックし終えたところで、右クリック → 停止 で locator() を止めます。
すると今回は、「コホート分けをやり直しますか?」と R に質問されます。




「はい」か「いいえ」で答えてあげて下さい。
「はい」の場合、もう一度ピークをクリックし直せます。
「いいえ」の場合、それ以降のコードが実行されます。

すると、コホートの名前を入力するよう求められます。




コホート名を入力するウィンドウに書いてある age1 というのは、図中の age1 に対応しています。コホートの数だけコホート名を入力するよう求めてくるので、全てに名前を付けてあげて下さい。(これがコホートの ID になります。)


ここまでが調査 1 回分の解析の手順です。
次からは 2 回目の調査のデータが抽出され、上記内容が繰り返されます。





2 回目以降は、前回の単離結果を見ながらピークをクリックしていくのが良いと思ったので、前回の結果を残しておくことにしました。
以下のようにグラフをずらすと前回の結果を見ることができます。
ちなみに前のグラフには、命名したコホート名がグラフ内に記されています。





前回の結果を確認しながら今回のピークを判定しクリックして下さい。
全てクリックし終えたら locator を止めて下さい。
(ここでも、やり直すかと聞かれるので答えてあげて下さい。)

次に、前回のコホート名を確認しながら今回のコホート名を入力して下さい。
ここで、2 回目以降は、前回の判定を確認しながら、同じコホートだと判断できるものには同じコホート名を入力して下さい。この時、大文字と小文字は区別されるので注意してください。


ここまでくれば、あとは同じことを繰り返していくだけです。
そして、全ての作業が終了すると、PDF と csv ファイルが作成されます。


[修正]
2015/10/07
先日、ヒストグラムが上手く書けないというご指摘をいただいたので、その部分を変更しました。

2015/10/15
日付と個体数をグラフ左上に表示できるように変更しました。

2016/02/10
データを読み込んだとき、TL が Factor という型になってしまい、正常に解析できないという問題が見つかりました。
これについて、
WR <- read.csv(fileName, header=T)
の下に、
WR$TL <- as.numeric(as.character(WR$TL))
を入れることで対処しました。

2016/02/10
混合正規分布でない場合、すなわち単一の正規分布で構成されている場合でも解析できるように変更しました。