Revision f67776b9
Added by Benoit Parmentier over 8 years ago
climate/research/oregon/interpolation/global_product_assessment_part1_functions.R | ||
---|---|---|
1 |
#################################### INTERPOLATION OF TEMPERATURES ####################################### |
|
2 |
####################### Assessment of product part 1 functions: mosaic and accuracy ############################## |
|
3 |
#This script contains functions and uses the worklfow code applied to the globe. Results currently reside on NEX/PLEIADES NASA. |
|
4 |
#Combining tables and figures for individual runs for years and tiles. |
|
5 |
#AUTHOR: Benoit Parmentier |
|
6 |
#CREATED ON: 05/24/2016 |
|
7 |
#MODIFIED ON: 05/24/2016 |
|
8 |
#Version: 1 |
|
9 |
#PROJECT: Environmental Layers project |
|
10 |
#COMMENTS: Initial commit, script based on part NASA biodiversity conference |
|
11 |
#TODO: |
|
12 |
#1) Add plot broken down by year and region |
|
13 |
#2) Modify code for overall assessment accross all regions and year |
|
14 |
#3) Clean up |
|
15 |
|
|
16 |
#First source these files: |
|
17 |
#Resolved call issues from R. |
|
18 |
#source /nobackupp6/aguzman4/climateLayers/sharedModules2/etc/environ.sh |
|
19 |
# |
|
20 |
#setfacl -Rmd user:aguzman4:rwx /nobackupp8/bparmen1/output_run10_1500x4500_global_analyses_pred_1992_10052015 |
|
21 |
|
|
22 |
################################################################################################# |
|
23 |
|
|
24 |
### Loading R library and packages |
|
25 |
#library used in the workflow production: |
|
26 |
library(gtools) # loading some useful tools |
|
27 |
library(mgcv) # GAM package by Simon Wood |
|
28 |
library(sp) # Spatial pacakge with class definition by Bivand et al. |
|
29 |
library(spdep) # Spatial pacakge with methods and spatial stat. by Bivand et al. |
|
30 |
library(rgdal) # GDAL wrapper for R, spatial utilities |
|
31 |
library(gstat) # Kriging and co-kriging by Pebesma et al. |
|
32 |
library(fields) # NCAR Spatial Interpolation methods such as kriging, splines |
|
33 |
library(raster) # Hijmans et al. package for raster processing |
|
34 |
library(gdata) # various tools with xls reading, cbindX |
|
35 |
library(rasterVis) # Raster plotting functions |
|
36 |
library(parallel) # Parallelization of processes with multiple cores |
|
37 |
library(maptools) # Tools and functions for sp and other spatial objects e.g. spCbind |
|
38 |
library(maps) # Tools and data for spatial/geographic objects |
|
39 |
library(reshape) # Change shape of object, summarize results |
|
40 |
library(plotrix) # Additional plotting functions |
|
41 |
library(plyr) # Various tools including rbind.fill |
|
42 |
library(spgwr) # GWR method |
|
43 |
library(automap) # Kriging automatic fitting of variogram using gstat |
|
44 |
library(rgeos) # Geometric, topologic library of functions |
|
45 |
#RPostgreSQL # Interface R and Postgres, not used in this script |
|
46 |
library(gridExtra) |
|
47 |
#Additional libraries not used in workflow |
|
48 |
library(pgirmess) # Krusall Wallis test with mulitple options, Kruskalmc {pgirmess} |
|
49 |
library(colorRamps) |
|
50 |
library(zoo) |
|
51 |
library(xts) |
|
52 |
library(lubridate) |
|
53 |
|
|
54 |
###### Function used in the script ####### |
|
55 |
|
|
56 |
#Used to load RData object saved within the functions produced. |
|
57 |
load_obj <- function(f){ |
|
58 |
env <- new.env() |
|
59 |
nm <- load(f, env)[1] |
|
60 |
env[[nm]] |
|
61 |
} |
|
62 |
|
|
63 |
pre_process_raster_mosaic_fun <- function(i,list_param){ |
|
64 |
|
|
65 |
|
|
66 |
## Extract parameters |
|
67 |
|
|
68 |
lf <- list_param$lf |
|
69 |
python_bin <- list_param$python_bin |
|
70 |
infile_mask <- list_param$infile_mask |
|
71 |
scaling <- list_param$scaling |
|
72 |
mask_pred <- list_param$mask_pred |
|
73 |
NA_flag_val <- list_param$NA_flag_val |
|
74 |
out_suffix <- list_param$out_suffix |
|
75 |
out_dir <- list_param$out_dir |
|
76 |
|
|
77 |
raster_name_in <- lf[i] |
|
78 |
|
|
79 |
#Step 1: match extent and resolution |
|
80 |
|
|
81 |
lf_files <- c(raster_name_in) #match to mask |
|
82 |
rast_ref <- infile_mask |
|
83 |
##Maching resolution is probably only necessary for the r mosaic function |
|
84 |
#Modify later to take into account option R or python... |
|
85 |
list_param_raster_match <- list(lf_files,rast_ref,file_format,python_bin,out_suffix,out_dir) |
|
86 |
names(list_param_raster_match) <- c("lf_files","rast_ref","file_format","python_bin","out_suffix","out_dir_str") |
|
87 |
r_pred_matched <- raster_match(1,list_param_raster_match) |
|
88 |
raster_name_in <- c(r_pred_matched) |
|
89 |
|
|
90 |
#Step 2: mask |
|
91 |
if(mask_pred==TRUE){ |
|
92 |
r_mask <- raster(infile_mask) |
|
93 |
extension_str <- extension(raster_name_in) |
|
94 |
raster_name_tmp <- gsub(extension_str,"",basename(raster_name_in)) |
|
95 |
raster_name <- file.path(out_dir,paste(raster_name_tmp,"_masked.tif",sep = "")) |
|
96 |
r_pred <- mask(raster(raster_name_in),r_mask,filename = raster_name,overwrite = TRUE) |
|
97 |
} |
|
98 |
|
|
99 |
NAvalue(r_pred) <- NA_flag_val |
|
100 |
#r_pred <- setMinMax(r_pred) |
|
101 |
|
|
102 |
#Step 3: remove scaling factor |
|
103 |
raster_name_in <- filename(r_pred) |
|
104 |
extension_str <- extension(raster_name_in) |
|
105 |
raster_name_tmp <- gsub(extension_str,"",basename(filename(r_pred))) |
|
106 |
raster_name_out <- file.path(out_dir,paste(raster_name_tmp,"_rescaled.tif",sep = "")) |
|
107 |
#r_pred <- overlay(r_pred, fun=function(x){x*1/scaling},filename=raster_name,overwrite=T) |
|
108 |
|
|
109 |
#raster_name_in <- "comp_r_m_use_edge_weights_weighted_mean_gam_CAI_dailyTmax_19990102_reg4_1999_m_gam_CAI_dailyTmax_19990102_reg4_1999_m__meeting_NASA_reg4_04292016_masked.tif" |
|
110 |
python_cmd <- file.path(python_bin,"gdal_calc.py") |
|
111 |
cmd_str3 <- paste(python_cmd, |
|
112 |
paste("-A ", raster_name_in,sep=""), |
|
113 |
paste("--outfile=",raster_name_out,sep=""), |
|
114 |
#paste("--type=","Int32",sep=""), |
|
115 |
"--co='COMPRESS=LZW'", |
|
116 |
paste("--NoDataValue=",NA_flag_val,sep=""), |
|
117 |
paste("--calc='(A)*",scaling,"'",sep=""), |
|
118 |
"--overwrite",sep=" ") #division by zero is problematic... |
|
119 |
#system(cmd_str3) |
|
120 |
system(cmd_str3) |
|
121 |
#NAvalue(r_pred) <- NA_flag_val |
|
122 |
#r_pred <- |
|
123 |
r_pred <- setMinMax(raster(raster_name_out)) |
|
124 |
|
|
125 |
return(raster_name_out) |
|
126 |
} |
|
127 |
|
|
128 |
plot_raster_mosaic <- function(i,list_param){ |
|
129 |
#Function to plot mosaic for poster |
|
130 |
# |
|
131 |
l_dates <- list_param$l_dates |
|
132 |
r_mosaiced_scaled <- list_param$r_mosaiced_scaled |
|
133 |
NA_flag_val <- list_param$NA_flag_val |
|
134 |
out_dir <- list_param$out_dir |
|
135 |
out_suffix <- list_param$out_suffix |
|
136 |
region_name <- list_param$region_name |
|
137 |
variable_name <- list_param$variable_name |
|
138 |
|
|
139 |
#for (i in 1:length(nlayers(r_mosaic_scaled))){ |
|
140 |
|
|
141 |
date_proc <- l_dates[i] |
|
142 |
r_pred <- subset(r_mosaic_scaled,i) |
|
143 |
NAvalue(r_pred)<- NA_flag_val |
|
144 |
|
|
145 |
date_proc <- l_dates[i] |
|
146 |
date_val <- as.Date(strptime(date_proc,"%Y%m%d")) |
|
147 |
#month_name <- month.name(date_val) |
|
148 |
month_str <- format(date_val, "%b") ## Month, char, abbreviated |
|
149 |
year_str <- format(date_val, "%Y") ## Year with century |
|
150 |
day_str <- as.numeric(format(date_val, "%d")) ## numeric month |
|
151 |
date_str <- paste(month_str," ",day_str,", ",year_str,sep="") |
|
152 |
|
|
153 |
res_pix <- 1200 |
|
154 |
#res_pix <- 480 |
|
155 |
col_mfrow <- 1 |
|
156 |
row_mfrow <- 1 |
|
157 |
|
|
158 |
png_filename <- file.path(out_dir,paste("Figure4_clim_mosaics_day_","_",date_proc,"_",region_name,"_",out_suffix,".png",sep ="")) |
|
159 |
title_str <- paste("Predicted ",variable_name, " on ",date_str , " ", sep = "") |
|
160 |
|
|
161 |
png(filename=png_filename,width = col_mfrow * res_pix,height = row_mfrow * res_pix) |
|
162 |
plot(r_pred,main =title_str,cex.main =1.5,col=matlab.like(255),zlim=c(-50,50), |
|
163 |
legend.shrink=0.8,legend.width=0.8) |
|
164 |
#axis.args = list(cex.axis = 1.6), #control size of legend z |
|
165 |
#legend.args=list(text='dNBR', side=4, line=2.5, cex=2.2)) |
|
166 |
#legend.args=list(text='dNBR', side=4, line=2.49, cex=1.6)) |
|
167 |
dev.off() |
|
168 |
|
|
169 |
return(png_filename) |
|
170 |
} |
|
171 |
|
|
172 |
extract_date <- function(i,x,item_no=NULL){ |
|
173 |
y <- unlist(strsplit(x[[i]],"_")) |
|
174 |
if(is.null(item_no)){ |
|
175 |
date_str <- y[length(y)-2] #count from end |
|
176 |
}else{ |
|
177 |
date_str <- y[item_no] |
|
178 |
} |
|
179 |
return(date_str) |
|
180 |
} |
|
181 |
|
|
182 |
############################ END OF SCRIPT ################################## |
Also available in: Unified diff
initial commit for function script for global product assessment part 1