1
|
#### Evaluate the feasibility of correcting for orbital bias in cloud cover
|
2
|
library(raster)
|
3
|
library(rasterVis)
|
4
|
library(doMC)
|
5
|
library(multicore)
|
6
|
library(foreach)
|
7
|
library(rgdal)
|
8
|
registerDoMC(4)
|
9
|
library(plyr)
|
10
|
library(mgcv)
|
11
|
library(sampling)
|
12
|
|
13
|
setwd("~/acrobates/adamw/projects/cloud")
|
14
|
|
15
|
|
16
|
## set raster options
|
17
|
rasterOptions(maxmemory=1e8)
|
18
|
|
19
|
## get CF data
|
20
|
## Get list of available files
|
21
|
#df=data.frame(path=list.files("data/mod09cloud",pattern="*.tif$",full=T,recur=T),stringsAsFactors=F)
|
22
|
#df[,c("month")]=do.call(rbind,strsplit(basename(df$path),"_|[.]|-"))[,c(6)]
|
23
|
#df$date=as.Date(paste(2013,"_",df$month,"_15",sep=""),"%Y_%m_%d")
|
24
|
#df=df[order(df$date),]
|
25
|
|
26
|
#d=stack(df$path,bands=1)
|
27
|
#names(d)=df$month
|
28
|
|
29
|
reg=extent(c(-1434564.00523,1784892.95369, 564861.173869, 1880991.3772))
|
30
|
reg=extent(c(-2187230.72881, 4017838.07688, -339907.592509, 3589340.63805)) #all sahara
|
31
|
reg=extent(c(-12020769.9608, 10201058.231, -3682105.25271, 3649806.08382)) #large equitorial
|
32
|
#reg=extent(c(-151270.082307, 557321.958761, 1246351.8356, 1733123.75947))
|
33
|
|
34
|
d=crop(stack("data/mcd09/2014113_combined_20002013_MOD09_1-img-0000000000-0000000000.tif"),reg)
|
35
|
d=crop(stack("/Users/adamw/GoogleDrive/EarthEngineOutput/ee_combined/2014113_combined_20002013_MOD09_1-img-0000000000-0000000000.tif"),reg)
|
36
|
|
37
|
names(d)=c("cf","cfsd","nobs","pobs")
|
38
|
cd=coordinates(d)
|
39
|
cdr=rasterFromXYZ(cbind(cd,cd))
|
40
|
names(cdr)
|
41
|
d=stack(d,cdr)
|
42
|
#obs=crop(raster("data/mcd09/2014113_combined_20002013_MOD09_1-img-0000000000-0000000000.tif",band=4),reg)
|
43
|
#levelplot(stack(obs,d))
|
44
|
|
45
|
#plot(obs,d)
|
46
|
|
47
|
#pts=sampleStratified(d[["pobs"]], size=10000, exp=10, na.rm=TRUE, xy=FALSE, ext=NULL, sp=FALSE)
|
48
|
pts=sampleRandom(d, size=10000, na.rm=TRUE, xy=T, ext=NULL, sp=T)
|
49
|
pts=pts[pts$nobs>0,] #drop data from missing tiles
|
50
|
|
51
|
#dt=data.frame(cf=as.numeric(values(d[["cf"]])),obs=as.numeric(values(d[["pobs"]])))
|
52
|
#dt[,c("x","y")]=coordinates(d)
|
53
|
#dt=dt[dt$obs>0,] #drop data from missing tiles
|
54
|
|
55
|
#s=1:nrow(dt)
|
56
|
#s=sample(1:nrow(dt),10000)
|
57
|
#s=strata(dt, stratanames=dt$obs, size=1000)
|
58
|
|
59
|
lm1=bam(cf~s(x,y,pobs),data=pts@data)
|
60
|
summary(lm1)
|
61
|
#beta=coef(lm1)["pobs"]; beta
|
62
|
d2=d
|
63
|
d2[["pobs"]]=100
|
64
|
|
65
|
pred1=raster::predict(d,lm1,file=paste("data/bias/pred1.tif",sep=""),format="GTiff",dataType="INT1U",overwrite=T,NAflag=255)#lm1=bam(as.vector(d[["cf"]]) ~ as.vector(d[["pobs"]]))
|
66
|
pred2=raster::predict(d2,lm1,file=paste("data/bias/pred2.tif",sep=""),format="GTiff",dataType="INT1U",overwrite=T,NAflag=255)#lm1=bam(as.vector(d[["cf"]]) ~ as.vector(d[["pobs"]]))
|
67
|
pred3=overlay(pred1,pred2,function(x,y) x-y,file="data/bias/pred3.tif",overwrite=T)
|
68
|
biasc=overlay(d[["cf"]], pred3,fun=sum,file="data/bias/biasc.tif",overwrite=T)
|
69
|
|
70
|
|
71
|
#getbias=function(x) return((100-x)*beta)
|
72
|
#getbias(beta,87)
|
73
|
#bias=calc(d[["pobs"]],getbias,file=paste("data/bias/bias.tif",sep=""),format="GTiff",dataType="INT1U",overwrite=T,NAflag=255)
|
74
|
#dc=overlay(d[["cf"]],bias,fun=function(x,y) x+y,
|
75
|
# file=paste("data/bias/biasc.tif",sep=""),
|
76
|
# format="GTiff",dataType="INT1U",overwrite=T,NAflag=255) #,options=c("COMPRESS=LZW","ZLEVEL=9"))
|
77
|
#levelplot(stack(d,dc))
|
78
|
|
79
|
|
80
|
library(multicore)
|
81
|
|
82
|
Mode <- function(x) {
|
83
|
ux <- unique(x)
|
84
|
ux[which.max(tabulate(match(x, ux)))]
|
85
|
}
|
86
|
#rasterOptions(maxmemory)#=50GB)
|
87
|
## set up processing chunks
|
88
|
nrw=nrow(d)
|
89
|
nby=20
|
90
|
nrwg=seq(1,nrw,by=nby)
|
91
|
writeLines(paste("Processing ",length(nrwg)," groups and",nrw,"lines"))
|
92
|
|
93
|
## Parallel loop to conduct moving window analysis and quantify pixels with significant shifts across pp or lulc boundaries
|
94
|
output=mclapply(nrwg,function(ti){
|
95
|
## Extract focal areas
|
96
|
ngb=c(51,101)
|
97
|
vals_cf=getValuesFocal(d,ngb=ngb,row=ti,nrows=nby)
|
98
|
vals_obs=getValuesFocal(obs,ngb=ngb,row=ti,nrows=nby)
|
99
|
## extract bias
|
100
|
bias=raster(matrix(do.call(rbind,lapply(1:nrow(vals_cf),function(i) {
|
101
|
# if(i%in%round(seq(1,nrow(vals_cf),len=100))) print(i)
|
102
|
tobs=vals_obs[i,] #vector of indices
|
103
|
tval=vals_cf[i,] # vector of values
|
104
|
lm1=lm(tval~tobs,na.rm=T)
|
105
|
dif=round(predict(lm1)-predict(lm1,newdata=data.frame(tobs=median(tobs,na.rm=T))))
|
106
|
return(dif)
|
107
|
})),nrow=nby,ncol=ncol(d),byrow=T)) # turn it back into a raster
|
108
|
## update raster and write it
|
109
|
extent(bias)=extent(d[ti:(ti+nby-1),1:ncol(d),drop=F])
|
110
|
projection(bias)=projection(d)
|
111
|
NAvalue(bias) <- 255
|
112
|
writeRaster(bias,file=paste("data/bias/tiles/bias_",ti,".tif",sep=""),
|
113
|
format="GTiff",dataType="INT1U",overwrite=T,NAflag=255) #,options=c("COMPRESS=LZW","ZLEVEL=9")
|
114
|
print(ti)
|
115
|
}
|
116
|
)
|
117
|
|
118
|
#levelplot(d)
|
119
|
#plot(obs)
|
120
|
|
121
|
system("gdalbuildvrt -srcnodata 255 -vrtnodata 255 data/bias/bias.vrt `find data/bias/tiles -name 'bias*tif'` ")
|
122
|
system("gdalwarp -srcnodata 255 `find data/bias/tiles -name 'bias*tif'` data/bias/bias_movingwindow.tif ")
|
123
|
|
124
|
n=5000
|
125
|
ps=SpatialPoints(cbind(lon=runif(n,-180,10),lat=runif(n,-30,30)))
|
126
|
ps=SpatialPoints(cbind(lon=runif(n,-10,10),lat=runif(n,-5,30)))
|
127
|
|
128
|
projection(ps)=projection(d)
|
129
|
|
130
|
psd=extract(d,ps,sp=F)[,12]
|
131
|
psd=cbind.data.frame(cf=psd,pobs=extract(obs,ps,sp=F))
|
132
|
psd$cf[psd$cf<0]=NA
|
133
|
ps2=SpatialPointsDataFrame(ps,data=psd)
|
134
|
|
135
|
writeOGR(ps2,"output","MODIS_ObservationValidation",driver="ESRI Shapefile")
|
136
|
|
137
|
|
138
|
ps=readOGR("output","MODIS_ObservationValidation")
|
139
|
|
140
|
xyplot(cf~pobs,data=ps@data[!is.na(ps$cf)&ps$pobs>50,])
|
141
|
|
142
|
keep=T
|
143
|
keep=ps$cf<12&ps$pobs>80
|
144
|
lm1=lm(cf~pobs,data=ps@data[keep,])
|
145
|
summary(lm1)
|
146
|
|
147
|
|
148
|
pred=predict(lm1,newdata=ps@data[keep,],type="response")
|
149
|
|
150
|
plot(cf~pobs,data=ps@data[keep,],xlim=c(78,100))
|
151
|
points(pred~ps$pobs[keep],col="red")
|
152
|
|
153
|
|
154
|
|
155
|
#### fiddle with binomial
|
156
|
n=11
|
157
|
p=seq(0,1,len=n)
|
158
|
obs=1:30
|
159
|
|
160
|
mat=expand.grid(p=p,obs=obs)
|
161
|
mat$obsh=apply(sapply(1:14,function(x) rbinom(nrow(mat),size=mat$obs,prob=mat$p)),1,mean)
|
162
|
mat$ph=mat$obsh/mat$obs
|
163
|
mat$bias=mat$ph-mat$p
|
164
|
|
165
|
#### Simulate clouds
|
166
|
n=10
|
167
|
p=seq(0,1,len=n)
|
168
|
obs=10:30
|
169
|
|
170
|
## true clouds
|
171
|
mat=expand.grid(p=p,obs=obs)
|
172
|
|
173
|
res=matrix(nrow=nrow(mat),ncol=1000)
|
174
|
for(r in 1:1000){
|
175
|
clouds=sapply(1:30,function(x) rbinom(nrow(mat),size=1,prob=mat$p))
|
176
|
for(i in 1:nrow(mat)){
|
177
|
res[i,r]=
|
178
|
mean(sample(clouds[i,],mat$obs[i]))
|
179
|
}
|
180
|
|
181
|
}
|
182
|
|
183
|
mat$ph=apply(res,1,mean)
|
184
|
#mat$ph=mat$obsh/mat$obs
|
185
|
mat$bias=mat$ph-mat$p
|
186
|
|
187
|
|
188
|
levelplot(bias~p*obs,data=mat,col.regions=rainbow(100,end=0.8),at=seq(min(mat$bias),max(mat$bias),len=n),ylab="Observations in a 30-day month",xlab="'True' Cloud Frequency (%) ")
|
189
|
|
190
|
hist(mat$bias)
|
191
|
plot(mat$p~mat$ph)
|
192
|
summary(mat)
|