Revision ab884b16
Added by Benoit Parmentier over 11 years ago
climate/research/oregon/interpolation/interpolation_method_day_function_multisampling.R | ||
---|---|---|
151 | 151 |
return(day_prediction_obj) |
152 | 152 |
} |
153 | 153 |
|
154 |
#Could merge both auto? |
|
155 |
predict_autokrige_gwr_raster_model<-function(method_interp,list_formulas,r_stack,data_training,out_filename){ |
|
156 |
#This functions performs predictions on a raster grid given input models. |
|
157 |
#It can be used at the daily or/and monthly time scale... |
|
158 |
#Arguments: list of fitted models, raster stack of covariates |
|
159 |
# method_interp must be equal to "gwr" or "kriging" |
|
160 |
#Output: spatial grid data frame of the subset of tiles |
|
161 |
|
|
162 |
list_fitted_models<-vector("list",length(list_formulas)) |
|
163 |
list_rast_pred<-vector("list",length(list_formulas)) |
|
164 |
#s_sgdf<-as(r_stack,"SpatialGridDataFrame") #Conversion to spatial grid data frame, only convert the necessary layers!! |
|
165 |
proj4string(data_training) <- projection(r_stack) |
|
166 |
for (k in 1:length(list_formulas)){ |
|
167 |
formula_mod<-list_formulas[[k]] |
|
168 |
raster_name<-out_filename[[k]] |
|
169 |
#mod<- try(gam(formula, data=data_training)) #change to any model!! |
|
170 |
s_spdf<-select_var_stack(r_stack,formula_mod,spdf=TRUE) |
|
171 |
col_names<-all.vars(formula_mod) #extract terms names from formula object |
|
172 |
if (length(col_names)==1){ |
|
173 |
data_fit <-data_training |
|
174 |
}else{ |
|
175 |
data_fit <- remove_na_spdf(col_names,data_training) |
|
176 |
} |
|
177 |
|
|
178 |
if(method_interp=="kriging"){ |
|
179 |
mod <- try(autoKrige(formula_mod, input_data=data_fit,new_data=s_spdf,data_variogram=data_fit)) |
|
180 |
} |
|
181 |
|
|
182 |
if(method_interp=="gwr"){ |
|
183 |
bwGm <-try(gwr.sel(formula_mod,data=data_fit,gweight=gwr.Gauss, verbose = FALSE)) |
|
184 |
mod <- try(gwr(formula_mod, data=data_fit, bandwidth=bwGm, gweight=gwr.Gauss, hatmatrix=TRUE)) |
|
185 |
} |
|
186 |
#mod <- try(autoKrige(formula_mod, input_data=data_training,new_data=s_spdf,data_variogram=data_training)) |
|
187 |
|
|
188 |
model_name<-paste("mod",k,sep="") |
|
189 |
assign(model_name,mod) |
|
190 |
|
|
191 |
if (inherits(mod,"autoKrige") | inherits(mod,"gwr")){ #change to c("gam","autoKrige") |
|
192 |
if(method_interp=="kriging"){ |
|
193 |
rpred<-mod$krige_output #Extracting the SptialGriDataFrame from the autokrige object |
|
194 |
y_pred<-rpred$var1.pred #is the order the same? |
|
195 |
raster_pred <- rasterize(rpred,r_stack,"var1.pred",fun=mean) |
|
196 |
mod$krige_output<-NULL |
|
197 |
} |
|
198 |
if(method_interp=="gwr"){ |
|
199 |
rpred <- gwr(formula_mod, data_fit, bandwidth=bwGm, fit.points =s_spdf,predict=TRUE, se.fit=TRUE,fittedGWRobject=mod) |
|
200 |
#y_pred<-rpred$var1.pred #is the order the same? |
|
201 |
raster_pred<-rasterize(rpred$SDF,r_stack,"pred",fun=mean) |
|
202 |
} |
|
203 |
|
|
204 |
names(raster_pred)<-"y_pred" |
|
205 |
writeRaster(raster_pred, filename=raster_name,overwrite=TRUE) #Writing the data in a raster file format... |
|
206 |
#print(paste("Interpolation:","mod", j ,sep=" ")) |
|
207 |
list_rast_pred[[k]]<-raster_name |
|
208 |
list_fitted_models[[k]]<-mod |
|
209 |
|
|
210 |
} |
|
211 |
if (inherits(mod,"try-error")) { |
|
212 |
print(paste("no autokrige/gwr model fitted:",mod,sep=" ")) #change message for any model type... |
|
213 |
list_fitted_models[[k]]<-mod |
|
214 |
} |
|
215 |
} |
|
216 |
day_prediction_obj <-list(list_fitted_models,list_rast_pred) |
|
217 |
names(day_prediction_obj) <-c("list_fitted_models","list_rast_pred") |
|
218 |
return(day_prediction_obj) |
|
219 |
} |
|
220 |
|
|
154 | 221 |
fit_models<-function(list_formulas,data_training){ |
155 | 222 |
#This functions several models and returns model objects. |
156 | 223 |
#Arguments: - list of formulas for GAM models |
... | ... | |
490 | 557 |
|
491 | 558 |
} |
492 | 559 |
|
560 |
run_interp_day_fun <-function(i,list_param){ |
|
561 |
|
|
562 |
#Make this a function with multiple argument that can be used by mcmapply?? |
|
563 |
#This function performs interpolation at daily time scale. Modifications made |
|
564 |
#to run three possible methods: gwr, kriging and gam. |
|
565 |
#Arguments: |
|
566 |
#1)list_index: j |
|
567 |
#2)covar_rast: covariates raster images used in the modeling |
|
568 |
#3)covar_names: names of input variables |
|
569 |
#4)lst_avg: list of LST climatogy names, may be removed later on |
|
570 |
#5)list_models: list input models for bias calculation |
|
571 |
#6)sampling_obj: data at the daily time scale |
|
572 |
#7)var: TMAX or TMIN, variable being interpolated |
|
573 |
#8)y_var_name: output name, not used at this stage |
|
574 |
#9)out_prefix |
|
575 |
#10) out_path |
|
576 |
|
|
577 |
#The output is a list of four shapefile names produced by the function: |
|
578 |
#1) clim: list of output names for raster climatologies |
|
579 |
#2) data_month: monthly training data for bias surface modeling |
|
580 |
#3) mod: list of model objects fitted |
|
581 |
#4) formulas: list of formulas used in bias modeling |
|
582 |
|
|
583 |
### PARSING INPUT ARGUMENTS |
|
584 |
#list_param_runGAMFusion<-list(i,clim_yearlist,sampling_obj,var,y_var_name, out_prefix) |
|
585 |
|
|
586 |
index<-list_param$list_index |
|
587 |
s_raster<-list_param$covar_rast |
|
588 |
covar_names<-list_param$covar_names |
|
589 |
lst_avg<-list_param$lst_avg |
|
590 |
list_models<-list_param$list_models |
|
591 |
dst<-list_param$dst #monthly station dataset |
|
592 |
sampling_obj<-list_param$sampling_obj |
|
593 |
var<-list_param$var |
|
594 |
y_var_name<-list_param$y_var_name |
|
595 |
interpolation_method <-list_param$interpolation_method |
|
596 |
out_prefix<-list_param$out_prefix |
|
597 |
out_path<-list_param$out_path |
|
598 |
|
|
599 |
|
|
600 |
ghcn.subsets<-sampling_obj$ghcn_data_day |
|
601 |
sampling_dat <- sampling_obj$sampling_dat |
|
602 |
sampling <- sampling_obj$sampling_index |
|
603 |
|
|
604 |
########## |
|
605 |
# STEP 1 - Read in information and get traing and testing stations |
|
606 |
############# |
|
607 |
|
|
608 |
date<-strptime(sampling_dat$date[i], "%Y%m%d") # interpolation date being processed |
|
609 |
month<-strftime(date, "%m") # current month of the date being processed |
|
610 |
LST_month<-paste("mm_",month,sep="") # name of LST month to be matched |
|
611 |
proj_str<-proj4string(dst) #get the local projection information from monthly data |
|
612 |
|
|
613 |
#Adding layer LST to the raster stack |
|
614 |
#names(s_raster)<-covar_names |
|
615 |
pos<-match("LST",names(s_raster)) #Find the position of the layer with name "LST", if not present pos=NA |
|
616 |
s_raster<-dropLayer(s_raster,pos) # If it exists drop layer |
|
617 |
LST<-subset(s_raster,LST_month) |
|
618 |
names(LST)<-"LST" |
|
619 |
s_raster<-addLayer(s_raster,LST) #Adding current month |
|
620 |
|
|
621 |
###Regression part 1: Creating a validation dataset by creating training and testing datasets |
|
622 |
data_day<-ghcn.subsets[[i]] |
|
623 |
mod_LST <- ghcn.subsets[[i]][,match(LST_month, names(ghcn.subsets[[i]]))] #Match interpolation date and monthly LST average |
|
624 |
data_day$LST <- as.data.frame(mod_LST)[,1] #Add the variable LST to the daily dataset |
|
625 |
dst$LST<-dst[[LST_month]] #Add the variable LST to the monthly dataset |
|
626 |
|
|
627 |
ind.training<-sampling[[i]] |
|
628 |
ind.testing <- setdiff(1:nrow(data_day), ind.training) |
|
629 |
data_s <- data_day[ind.training, ] #Training dataset currently used in the modeling |
|
630 |
data_v <- data_day[ind.testing, ] #Testing/validation dataset using input sampling |
|
631 |
|
|
632 |
ns<-nrow(data_s) |
|
633 |
nv<-nrow(data_v) |
|
634 |
#i=1 |
|
635 |
date_proc<-sampling_dat$date[i] |
|
636 |
date_proc<-strptime(sampling_dat$date[i], "%Y%m%d") # interpolation date being processed |
|
637 |
mo<-as.integer(strftime(date_proc, "%m")) # current month of the date being processed |
|
638 |
day<-as.integer(strftime(date_proc, "%d")) |
|
639 |
year<-as.integer(strftime(date_proc, "%Y")) |
|
640 |
|
|
641 |
#### STEP 2: PREPARE DATA |
|
642 |
|
|
643 |
#Clean out this part: make this a function call, should be done ine data preparation to retain the generality of the function |
|
644 |
|
|
645 |
x<-as.data.frame(data_v) |
|
646 |
d<-as.data.frame(data_s) |
|
647 |
for (j in 1:nrow(x)){ |
|
648 |
if (x$value[j]== -999.9){ |
|
649 |
x$value[j]<-NA |
|
650 |
} |
|
651 |
} |
|
652 |
for (j in 1:nrow(d)){ |
|
653 |
if (d$value[j]== -999.9){ |
|
654 |
d$value[j]<-NA |
|
655 |
} |
|
656 |
} |
|
657 |
pos<-match("value",names(d)) #Find column with name "value" |
|
658 |
names(d)[pos]<-y_var_name |
|
659 |
pos<-match("value",names(x)) #Find column with name "value" |
|
660 |
names(x)[pos]<-y_var_name |
|
661 |
pos<-match("station",names(d)) #Find column with station ID |
|
662 |
names(d)[pos]<-c("id") |
|
663 |
pos<-match("station",names(x)) #Find column with name station ID |
|
664 |
names(x)[pos]<-c("id") |
|
665 |
|
|
666 |
data_s<-d |
|
667 |
data_v<-x |
|
668 |
|
|
669 |
data_s$y_var <- data_s[[y_var_name]] #Adding the variable modeled |
|
670 |
data_v$y_var <- data_v[[y_var_name]] |
|
671 |
|
|
672 |
#Adding back spatal definition |
|
673 |
|
|
674 |
coordinates(data_s)<-cbind(data_s$x,data_s$y) |
|
675 |
proj4string(data_s)<-proj_str |
|
676 |
coordinates(data_v)<-cbind(data_v$x,data_v$y) |
|
677 |
proj4string(data_v)<-proj_str |
|
678 |
#### STEP3: NOW FIT AND PREDICT MODEL |
|
679 |
|
|
680 |
list_formulas<-lapply(list_models,as.formula,env=.GlobalEnv) #mulitple arguments passed to lapply!! |
|
681 |
#models names |
|
682 |
cname<-paste("mod",1:length(list_formulas),sep="") #change to more meaningful name? |
|
683 |
names(list_formulas) <- cname |
|
684 |
#Now generate output file names for the predictions... |
|
685 |
list_out_filename<-vector("list",length(list_formulas)) |
|
686 |
names(list_out_filename)<-cname |
|
687 |
|
|
688 |
for (k in 1:length(list_out_filename)){ |
|
689 |
#i indicate which day is predicted, y_var_name indicates TMIN or TMAX |
|
690 |
data_name<-paste(y_var_name,"_predicted_",names(list_formulas)[k],"_", |
|
691 |
sampling_dat$date[i],"_",sampling_dat$prop[i], |
|
692 |
"_",sampling_dat$run_samp[i],sep="") |
|
693 |
raster_name<-file.path(out_path,paste(interpolation_method,"_",data_name,out_prefix,".tif", sep="")) |
|
694 |
list_out_filename[[k]]<-raster_name |
|
695 |
} |
|
696 |
|
|
697 |
#now fit and predict values for raster image... |
|
698 |
|
|
699 |
if (interpolation_method=="gam_daily"){ |
|
700 |
mod_list<-fit_models(list_formulas,data_s) #only gam at this stage |
|
701 |
names(mod_list)<-cname |
|
702 |
rast_day_list<-predict_raster_model(mod_list,s_raster,list_out_filename) |
|
703 |
names(rast_day_list)<-cname |
|
704 |
} |
|
705 |
|
|
706 |
## need to change to use combined gwr autokrige function |
|
707 |
if (interpolation_method=="kriging_daily"){ |
|
708 |
day_prediction_obj<-predict_auto_krige_raster_model(list_formulas,s_raster,data_s,list_out_filename) |
|
709 |
mod_list <-day_prediction_obj$list_fitted_models |
|
710 |
rast_day_list <-day_prediction_obj$list_rast_pred |
|
711 |
names(rast_day_list)<-cname |
|
712 |
} |
|
713 |
|
|
714 |
if (interpolation_method=="gwr_daily"){ |
|
715 |
method_interp <- "gwr" |
|
716 |
day_prediction_obj<-predict_autokrige_gwr_raster_model(method_interp,list_formulas,s_raster,data_s,list_out_filename) |
|
717 |
mod_list <-day_prediction_obj$list_fitted_models |
|
718 |
rast_day_list <-day_prediction_obj$list_rast_pred |
|
719 |
names(rast_day_list)<-cname |
|
720 |
} |
|
721 |
#Some models will not be predicted...remove them |
|
722 |
rast_day_list<-rast_day_list[!sapply(rast_day_list,is.null)] #remove NULL elements in list |
|
723 |
|
|
724 |
#Prepare object to return |
|
725 |
|
|
726 |
day_obj<- list(rast_day_list,data_s,data_v,sampling_dat[i,],mod_list,list_models) |
|
727 |
obj_names<-c(y_var_name,"data_s","data_v","sampling_dat","mod","formulas") |
|
728 |
names(day_obj)<-obj_names |
|
729 |
save(day_obj,file= file.path(out_path,paste("day_obj_",interpolation_method,"_",var,"_",sampling_dat$date[i],"_",sampling_dat$prop[i], |
|
730 |
"_",sampling_dat$run_samp[i],out_prefix,".RData",sep=""))) |
|
731 |
return(day_obj) |
|
732 |
|
|
733 |
} |
|
493 | 734 |
|
Also available in: Unified diff
adding GWR daily method, modifications in interpolation day function script