Project

General

Profile

« Previous | Next » 

Revision ab884b16

Added by Benoit Parmentier over 11 years ago

adding GWR daily method, modifications in interpolation day function script

View differences:

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