Project

General

Profile

« Previous | Next » 

Revision f1777c19

Added by Benoit Parmentier over 8 years ago

adding function to plot residuals by stations to product assessment part 1 function script

View differences:

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