Revision f1777c19
Added by Benoit Parmentier over 8 years ago
climate/research/oregon/interpolation/global_product_assessment_part1_functions.R | ||
---|---|---|
4 | 4 |
#Combining tables and figures for individual runs for years and tiles. |
5 | 5 |
#AUTHOR: Benoit Parmentier |
6 | 6 |
#CREATED ON: 05/24/2016 |
7 |
#MODIFIED ON: 08/31/2016
|
|
7 |
#MODIFIED ON: 09/04/2016
|
|
8 | 8 |
#Version: 1 |
9 | 9 |
#PROJECT: Environmental Layers project |
10 | 10 |
#COMMENTS: Initial commit, script based on part NASA biodiversity conference |
... | ... | |
277 | 277 |
return(new.shape) |
278 | 278 |
} |
279 | 279 |
|
280 |
plot_stations_val_by_date <- function(i,list_param){ |
|
281 |
# |
|
282 |
# |
|
283 |
#function to plot residuals by date |
|
284 |
# |
|
285 |
|
|
286 |
##### |
|
287 |
|
|
288 |
l_dates <- list_param$l_dates |
|
289 |
model_name <- list_param$model_name |
|
290 |
station_type_name <- list_param$station_type_name |
|
291 |
var_selected <- list_param$var_selected |
|
292 |
#list_df_points_dates <- |
|
293 |
df_combined_data_points <- list_param$df_combined_data_points |
|
294 |
countries_shp <- list_param$countries_shp |
|
295 |
proj_str <- list_param$proj_str |
|
296 |
out_suffix <- list_param$out_suffix |
|
297 |
out_dir <- list_param$out_dir |
|
298 |
|
|
299 |
### STARTFUNCTION #### |
|
300 |
|
|
301 |
date_processed <- l_dates[i] |
|
302 |
|
|
303 |
df_points <- subset(df_combined_data_points,date==date_processed) |
|
304 |
#df_points <- list_df_points_dates[[i]] |
|
305 |
#plot(df_points) |
|
306 |
freq_tile_id <- as.data.frame(table(df_points$tile_id)) |
|
307 |
freq_tile_id$date <- date_processed |
|
308 |
names(freq_tile_id) <- c("tile_id","freq","date") |
|
309 |
|
|
310 |
#plot(df_points,add=T) |
|
311 |
coordinates(df_points) <- cbind(df_points$x,df_points$y) |
|
312 |
#proj4string(df_points) <- CRS_locs_WGS84 |
|
313 |
proj4string(df_points) <- proj_str |
|
314 |
# # No spatial duplicates |
|
315 |
df_points_day <- remove.duplicates(df_points) #remove duplicates... |
|
316 |
#plot(df_points_day) |
|
317 |
#dim(df_points_day) |
|
318 |
#dim(df_points) |
|
319 |
#plot(df_points) |
|
320 |
|
|
321 |
##layer to be clipped |
|
322 |
if(class(countries_shp)!="SpatialPolygonsDataFrame"){ |
|
323 |
reg_layer <- readOGR(dsn=dirname(countries_shp),sub(".shp","",basename(countries_shp))) |
|
324 |
}else{ |
|
325 |
reg_layer <- countries_shp |
|
326 |
} |
|
327 |
|
|
328 |
#extent_df_points_day <- extent(df_points_day) |
|
329 |
|
|
330 |
reg_layer_clipped <- gClip(shp=reg_layer, bb=df_points_day , keep.attribs=TRUE,outDir=NULL,outSuffix=NULL) |
|
331 |
|
|
332 |
#data_stations_var_pred <- aggregate(id ~ date, data = data_stations, min) |
|
333 |
#data_stations_var_pred <- aggregate(id ~ x + y + date + dailyTmax + mod1 + res_mod1 , data = data_stations, min) |
|
334 |
|
|
335 |
#change the formula later on to use different y_var_name (tmin and precip) |
|
336 |
data_stations_var_pred <- aggregate(id ~ x + y + date + dailyTmax + res_mod1 + tile_id + reg ,data = df_points, mean ) #+ mod1 + res_mod1 , data = data_stations, min) |
|
337 |
dim(data_stations_var_pred) |
|
338 |
#> dim(data_stations_var_pred) |
|
339 |
#[1] 11171 5 |
|
340 |
|
|
341 |
data_stations_var_pred$date_str <- data_stations_var_pred$date |
|
342 |
data_stations_var_pred$date <- as.Date(strptime(data_stations_var_pred$date_str,"%Y%m%d")) |
|
343 |
coordinates(data_stations_var_pred) <- cbind(data_stations_var_pred$x,data_stations_var_pred$y) |
|
344 |
#data_stations_var_pred$constant <- c(1000,2000) |
|
345 |
#plot(data_stations_var_pred) |
|
346 |
#plot(reg_layer) |
|
347 |
#res_pix <- 1200 |
|
348 |
res_pix <- 800 |
|
349 |
col_mfrow <- 1 |
|
350 |
row_mfrow <- 1 |
|
351 |
|
|
352 |
png_filename <- paste("Figure_ac_metrics_map_stations_l_",station_type_name,"_",model_name,"_",y_var_name,"_",date_processed, |
|
353 |
"_",out_suffix,".png",sep="") |
|
354 |
png(filename=png_filename, |
|
355 |
width=col_mfrow*res_pix,height=row_mfrow*res_pix) |
|
356 |
#plot(data_stations_var_pred |
|
357 |
#p_shp <- spplot(reg_layer_clipped,"ISO3" ,col.regions=NA, col="black") #ok problem solved!! |
|
358 |
#title("(a) Mean for 1 January") |
|
359 |
#p <- bubble(data_stations_var_pred,"constant",main=paste0("Average Residuals by validation stations ", |
|
360 |
# date_processed, |
|
361 |
# "for ",var_selected)) |
|
362 |
#p <- spplot(data_stations_var_pred,"constant",col.regions=NA, col="black", |
|
363 |
# main=paste0("Average Residuals by validation stations ",pch=3,cex=10, |
|
364 |
# date_processed, "for ",var_selected)) |
|
365 |
|
|
366 |
#p1 <- p+p_shp |
|
367 |
#try(print(p1)) #error raised if number of missing values below a threshold does not exist |
|
368 |
|
|
369 |
title_str <- paste0("Stations ",station_type_name," on ",date_processed, " for ",y_var_name," ", var_selected) |
|
370 |
plot(reg_layer_clipped,main=title_str) |
|
371 |
plot(data_stations_var_pred,add=T,cex=0.5,col="blue") |
|
372 |
legend("topleft",legend=paste("n= ", nrow(data_stations_var_pred)),bty = "n") |
|
373 |
|
|
374 |
dev.off() |
|
375 |
|
|
376 |
res_pix <- 800 |
|
377 |
col_mfrow <- 1 |
|
378 |
row_mfrow <- 1 |
|
379 |
png_filename <- paste("Figure_ac_metrics_map_stations",station_type_name,"averaged","_fixed_intervals_",model_name,y_var_name,date_processed, |
|
380 |
out_suffix,".png",sep="_") |
|
381 |
png(filename=png_filename, |
|
382 |
width=col_mfrow*res_pix,height=row_mfrow*res_pix) |
|
383 |
|
|
384 |
#model_name[j] |
|
385 |
title_str <- paste0("Average Residuals by ",station_type_name," stations ",date_processed, " for ",y_var_name," ", var_selected) |
|
386 |
#p_shp <- layer(sp.polygons(reg_layer, lwd=1, col='black')) |
|
387 |
p_shp <- spplot(reg_layer,"ISO3" ,col.regions=NA, col="black") #ok problem solved!! |
|
388 |
#title("(a) Mean for 1 January") |
|
389 |
class_intervals <- c(-20,-10,-5,-4,-3,-2,-1,0,1,2,3,4,5,10,20) |
|
390 |
p <- bubble(data_stations_var_pred,zcol="res_mod1",key.entries = class_intervals , |
|
391 |
fill=F, #plot circle with filling |
|
392 |
#col= matlab.like(length(class_intervals)), |
|
393 |
main=title_str) |
|
394 |
p1 <- p + p_shp |
|
395 |
try(print(p1)) #error raised if number of missing values below a threshold does not exist |
|
396 |
|
|
397 |
dev.off() |
|
398 |
|
|
399 |
#### Add additional plot with quantiles and min max?... |
|
400 |
|
|
401 |
|
|
402 |
#library(classInt) |
|
403 |
#breaks.qt <- classIntervals(palo_alto$PrCpInc, n = 6, style = "quantile", intervalClosure = "right") |
|
404 |
#spplot(palo_alto, "PrCpInc", col = "transparent", col.regions = my.palette, |
|
405 |
# at = breaks.qt$brks) |
|
406 |
|
|
407 |
#### histogram of values |
|
408 |
res_pix <- 800 |
|
409 |
col_mfrow <- 1 |
|
410 |
row_mfrow <- 1 |
|
411 |
png_filename <- paste("Figure_ac_metrics_histograms_stations",station_type_name,"averaged",model_name,y_var_name,date_processed, |
|
412 |
out_suffix,".png",sep="_") |
|
413 |
png(filename=png_filename, |
|
414 |
width=col_mfrow*res_pix,height=row_mfrow*res_pix) |
|
415 |
|
|
416 |
title_str <- paste0("Stations ",station_type_name," on ",date_processed, " for ",y_var_name," ", var_selected) |
|
417 |
|
|
418 |
h<- histogram(data_stations_var_pred$res_mod1,breaks=seq(-50,50,5), |
|
419 |
main=title_str) |
|
420 |
|
|
421 |
print(h) |
|
422 |
dev.off() |
|
423 |
|
|
424 |
##Make data.frame with dates for later use!! |
|
425 |
#from libary mosaic |
|
426 |
df_basic_stat <- fav_stats(data_stations_var_pred$res_mod1) |
|
427 |
df_basic_stat$date <- date_processed |
|
428 |
#df_basic_stat$reg <- reg |
|
429 |
#quantile(data_stations_var_pred$res_mod1,c(1,5,10,90,95,99)) |
|
430 |
df_quantile_val <- quantile(data_stations_var_pred$res_mod1,c(0.01,0.05,0.10,0.45,0.50,0.55,0.90,0.95,0.99)) |
|
431 |
#names(df_quantile_val) |
|
432 |
#as.list(df_quantile_val) |
|
433 |
#df_test <- data.frame(names(df_quantile_val))[numeric(0), ] |
|
434 |
|
|
435 |
|
|
436 |
#quantile(c(1,5,10,90,95,99),data_stations_var_pred$res_mod1,) |
|
437 |
#rmse(data_stations_var_pred$res_mod1) |
|
438 |
|
|
439 |
plot_obj <- list(data_stations_var_pred,df_basic_stat,df_quantile_val,freq_tile_id) |
|
440 |
names(plot_obj) <- c("data_stations_var_pred","df_basic_stat","df_quantile_val","freq_tile_id") |
|
441 |
|
|
442 |
return(plot_obj) |
|
443 |
} |
|
444 |
|
|
280 | 445 |
############################ END OF SCRIPT ################################## |
Also available in: Unified diff
adding function to plot residuals by stations to product assessment part 1 function script