Project

General

Profile

« Previous | Next » 

Revision 43791b64

Added by Benoit Parmentier over 10 years ago

revisions 2 multi-timescale paper additional modif residuals analysis

View differences:

climate/research/oregon/interpolation/multi_timescale_paper_interpolation.R
1302 1302
var_background <- elev #raster image used as background image
1303 1303
names_var <- c("mod1","mod2","mod3","mod4","mod5","mod6","mod7")
1304 1304

  
1305
#Compute MAE per station, plots and other information on residuals
1306

  
1305 1307
interp_method <- "gam_CAI"
1306 1308
list_data_v <- list_data_v_all$gam_CAI
1307 1309
data_mae_gam_CAI_obj  <- plot_MAE_per_station_fun(list_data_v,names_var,interp_method,var_background,stat_loc,out_suffix)
......
1314 1316
list_data_v <- list_data_v_all$gwr_CAI
1315 1317
data_mae_gwr_CAI_obj  <- plot_MAE_per_station_fun(list_data_v,names_var,interp_method,var_background,stat_loc,out_suffix)
1316 1318

  
1317
plot_MAE_per_station_fun <- function(list_data_v,names_var,interp_method,var_background,stat_loc,out_suffix){
1318
  #Function to create a series of residuals MAE plots...
1319
  
1320
  mae_fun<-function(x){mean(abs(x))} #Mean Absolute Error give a residuals vector
1321
  sd_abs_fun<-function(x){sd(abs(x))} #sd Absolute Error give a residuals vector
1322
  
1323
  ### Start script ###
1324
  
1325
  data_v_test <- list_data_v[[1]]
1326
  #Convert sp data.frame and combined them in one unique df, see function define earlier
1327
  data_v_combined <-convert_spdf_to_df_from_list(list_data_v) #long rownames
1328
  
1329
  #names_var_all<-c("res_mod1","res_mod2","res_mod3","res_mod4","res_mod5","res_mod6","res_mod7")#,"res_mod8","res_mod9","res_mod10")
1330
  names_var_all <- res_model_name <- paste("res",names_var,sep="_")
1331

  
1332
  t<-melt(data_v_combined,
1333
        measure=names_var_all, 
1334
        id=c("id"),
1335
        na.rm=T)
1336

  
1337
  names(data_v_combined)
1338
  mae_tb<-cast(t,id~variable,mae_fun) #join to station location...
1339

  
1340
  data_v_mae <-merge(mae_tb,stat_loc,by.x=c("id"),by.y=c("STAT_ID"))
1341

  
1342
  coords<- data_v_mae[c('longitude','latitude')]              #Define coordinates in a data frame
1343
  CRS_interp<-proj4string(data_v_test)
1344
  coordinates(data_v_mae)<-coords                      #Assign coordinates to the data frame
1345
  proj4string(data_v_mae)<- proj4string(stat_loc)                #Assign coordinates reference system in PROJ4 format
1346
  data_v_mae<-spTransform(data_v_mae,CRS(CRS_interp))     #Project from WGS84 to new coord. system
1347

  
1348
  list_p_mae <- vector("list", length(names_var_all))
1349
  #names_var <- c("mod1","mod2","mod3","mod7")
1350

  
1351
  for (k in 1:length(names_var)){
1352
    model_name <- names_var[k]
1353
    res_model_name <- paste("res",model_name,sep="_")
1354

  
1355
    p1 <- levelplot(var_background,scales = list(draw = FALSE), colorkey = FALSE,par.settings = GrTheme)
1356
    df_tmp=subset(data_v_mae,data_v_mae[[res_model_name]]!="NaN")
1357
  
1358
    p2 <- bubble(df_tmp,res_model_name, main=paste("Average MAE per station for ",model_name," ",interp_method, sep=""),
1359
               na.rm=TRUE)
1360
    p3 <- p2 + p1 + p2 #to force legend...
1361
    list_p_mae[[k]] <- p3
1362
  }
1363
  
1364
  data_mae_obj <- list(list_p_mae,data_v_mae)
1365
  names(data_mae_obj) <- c("list_p_mae","data_v_mae")
1366
  return(data_mae_obj)
1367
}
1319
#####
1320
#Make MAE maps per station for gam_CAI, kriging_CAI, gwr_CAI
1368 1321

  
1369 1322
list_p_mae <- data_mae_gam_CAI_obj$list_p_mae
1370 1323
interp_method <- "gam_CAI"
1371

  
1372 1324
layout_m<-c(1,4) # works if set to this?? ok set the resolution...
1373 1325

  
1374 1326
png(paste("Figure10_paper_","average_MAE_",interp_method,out_prefix,".png", sep=""),
1375 1327
    height=480*layout_m[1],width=480*layout_m[2])
1376

  
1377 1328
grid.arrange(list_p_mae[[1]],list_p_mae[[2]],list_p_mae[[3]],list_p_mae[[7]], ncol=4)
1378
      
1379 1329
dev.off()   
1380 1330

  
1381 1331
list_p_mae <- data_mae_kriging_CAI_obj$list_p_mae
1382

  
1383 1332
layout_m<-c(1,4) # works if set to this?? ok set the resolution...
1384 1333
interp_method <- "kriging_CAI"
1385 1334

  
1386 1335
png(paste("Figure10_paper_","average_MAE_",interp_method,out_prefix,".png", sep=""),
1387 1336
    height=480*layout_m[1],width=480*layout_m[2])
1388

  
1389 1337
grid.arrange(list_p_mae[[1]],list_p_mae[[2]],list_p_mae[[3]],list_p_mae[[7]], ncol=4)
1390
      
1391 1338
dev.off()   
1392 1339

  
1393 1340
list_p_mae <- data_mae_gwr_CAI_obj$list_p_mae
......
1396 1343

  
1397 1344
png(paste("Figure10_paper_","average_MAE_",interp_method,out_prefix,".png", sep=""),
1398 1345
    height=480*layout_m[1],width=480*layout_m[2])
1399

  
1400 1346
grid.arrange(list_p_mae[[1]],list_p_mae[[2]],list_p_mae[[3]],list_p_mae[[7]], ncol=4)
1401
      
1402 1347
dev.off()   
1403 1348

  
1404
# boxplot compare lat*lon, lat*lon+elev , lat*lon+LST for  all three methods?
1349
#####
1350
## MAE Histogram plots: Show histo for mod1,mod2,mod3 and mod7 for gam, kriging and  gwr
1405 1351

  
1406
# Do MAE per stations for the best model  for  kriging, GWR and GAM/.
1407
names(data_mae_gam_CAI_obj)
1408
data_v_mae_gam_CAI <- data_mae_gam_CAI_obj$data_v_mae
1409
data_v_mae_kriging_CAI <- data_mae_kriging_CAI_obj$data_v_mae
1410
data_v_mae_gwr_CAI <- data_mae_gwr_CAI_obj$data_v_mae
1352
layout_m <- c(3,4) # works if set to this?? ok set the resolution...      
1411 1353

  
1412
## Histogram plots: Show histo for mod1,mod2,mod3 and mod7 for gam, kriging and  gwr
1354
png(paste("Figure11_paper_","_histogram_",out_prefix,".png", sep=""),
1355
    height=480*layout_m[1],width=480*layout_m[2])
1356
grid.arrange(     
1357
data_mae_gam_CAI_obj$list_p_hist[[1]],
1358
data_mae_gam_CAI_obj$list_p_hist[[2]],
1359
data_mae_gam_CAI_obj$list_p_hist[[3]],
1360
data_mae_gam_CAI_obj$list_p_hist[[7]],
1413 1361

  
1414
#Combine fig??
1362
data_mae_kriging_CAI_obj$list_p_hist[[1]],
1363
data_mae_kriging_CAI_obj$list_p_hist[[2]],
1364
data_mae_kriging_CAI_obj$list_p_hist[[3]],
1365
data_mae_kriging_CAI_obj$list_p_hist[[7]],
1415 1366

  
1416
#hist(data_v_mae_gam_CAI$res_mod1,breaks=c(1,2,3))
1417
hist(data_v_mae_gam_CAI$res_mod1) #,breaks=c(1,2,3))
1418
hist(data_v_mae_kriging_CAI$res_mod1)
1419
hist(data_v_mae_gwr_CAI$res_mod1)
1367
data_mae_gwr_CAI_obj$list_p_hist[[1]],
1368
data_mae_gwr_CAI_obj$list_p_hist[[2]],
1369
data_mae_gwr_CAI_obj$list_p_hist[[3]],
1370
data_mae_gwr_CAI_obj$list_p_hist[[7]],
1420 1371

  
1421
hist(data_v_mae_gam_CAI$res_mod2) #,breaks=c(1,2,3))
1422
hist(data_v_mae_kriging_CAI$res_mod2)
1423
hist(data_v_mae_gwr_CAI$res_mod2)
1372
ncol=4)
1424 1373

  
1425
hist(data_v_mae_gam_CAI$res_mod3) #,breaks=c(1,2,3))
1426
hist(data_v_mae_kriging_CAI$res_mod3)
1427
hist(data_v_mae_gwr_CAI$res_mod3)
1374
dev.off()
1428 1375

  
1429
hist(data_v_mae_gam_CAI$res_mod7) #,breaks=c(1,2,3))
1430
hist(data_v_mae_kriging_CAI$res_mod7)
1431
hist(data_v_mae_gwr_CAI$res_mod7)
1376
# boxplot compare lat*lon, lat*lon+elev , lat*lon+LST for  all three methods?
1377
# Do MAE per stations for the best model  for  kriging, GWR and GAM/.
1378
names(data_mae_gam_CAI_obj)
1379
data_v_mae_gam_CAI <- data_mae_gam_CAI_obj$data_v_mae
1380
data_v_mae_kriging_CAI <- data_mae_kriging_CAI_obj$data_v_mae
1381
data_v_mae_gwr_CAI <- data_mae_gwr_CAI_obj$data_v_mae
1432 1382

  
1433
### Figure 13: Analysing residuals and relationship to elevation for mod1, mod2 and mod4 ######
1434 1383

  
1435
#raster_predicton object for baseline 1 () s(lat,lon) + s(elev)) and baseline 2 (slat,lon))      
1436
#list_data_v <- lapply(1:365,function(i){raster_prediction_obj_2$validation_mod_obj[[i]]$data_v}) #testing with residuals
1437
#l_formulas<-(extract_from_list_obj(raster_prediction_obj_2$method_mod_obj,"formulas")) #get vector of dates
1384
####### Now map of residuals for supplementary material
1438 1385

  
1439
test <- do.call(rbind,list_data_v$gam_CAI)        
1440
data_v_ag <-test                
1441
cor(test$res_mod1,test$elev)
1442
cor(test$res_mod2,test$elev,use="complete.obs") #decrease in corellation when using elev
1443
cor(test$res_mod1,test$LST,,use="complete.obs")
1444
cor(test$res_mod3,test$LST,use="complete.obs") #decrease in correlation when using LST
1445
                     
1446
brks<- c(0,500,1000,1500,2000)
1447
lab_brks<-1:4
1448
elev_rcstat<-cut(data_v_ag$elev,breaks=brks,labels=lab_brks,right=F)
1386
###########################################
1387
### Figure 11: map of residuals...for a specific date...
1449 1388

  
1450
#Now set up plotting device
1389
#names(list_raster_obj_files)<- c("gam_daily","kriging_daily","gwr_daily_a","gwr_daily_b",
1390
#                                 "gam_CAI","kriging_CAI","gwr_CAI",
1391
#                                 "gam_fss","kriging_fss","gwr_fss")
1451 1392

  
1452
layout_m <- c(1,3) # works if set to this?? ok set the resolution...      
1453
png(paste("Figure_13_paper_","residuals_MAE_",out_prefix,".png", sep=""),
1393
list_data_v <-lapply(list_raster_obj_files[5:7],FUN=function(x){x<-load_obj(x);extract_list_from_list_obj(x$validation_mod_obj,"data_v")})                           
1394
index <- 244
1395
list_data_v_gam_CAI <- list_data_v$gam_CAI
1396
var_background <- subset(s_raster,"elev_s")
1397
interp_method <- "gam_CAI"
1398
names_var <- c("mod1","mod2","mod3","mod4","mod5","mod6","mod7")
1399
#names_mod <- names(raster_prediction_obj_2$method_mod_obj[[index]][[y_var_name]]) #names of models to plot
1400
date_selected <-  c("20100901")
1401

  
1402
list_p <- plot_residuals_map_fun(list_data_v_gam_CAI,date_selected,index,names_var,interp_method,var_background)
1403

  
1404
#layout_m<-c(4,3) # works if set to this?? ok set the resolution...
1405
#png(paste("Figure_11_paper_","_residuals_",date_selected,"_",out_prefix,".png", sep=""),
1406
#    height=480*layout_m[1],width=480*layout_m[2])
1407
#
1408
#grid.arrange(list_p[[1]],list_p[[2]],list_p[[3]],
1409
#             list_p[[4]],list_p[[5]],list_p[[6]],
1410
#             list_p[[7]],ncol=3)
1411
#dev.off()   
1412

  
1413
layout_m<-c(1,3) # works if set to this?? ok set the resolution...
1414
png(paste("Figure_s5a_paper_","_residuals_",date_selected,"_",out_prefix,".png", sep=""),
1454 1415
    height=480*layout_m[1],width=480*layout_m[2])
1455
    #height=480*6,width=480*4)
1416
grid.arrange(list_p[[1]],list_p[[2]],list_p[[3]],
1417
             ncol=3)  
1418
dev.off() 
1456 1419

  
1457
p_bw1<-bwplot(data_v_ag$res_mod1~elev_rcstat,do.out=F,ylim=c(-15,15),
1458
         ylab=list(label="Residuals (deg C)",cex=1.5),
1459
         xlab=list(label="Elevation classes (meter)",cex=1.5),
1460
         main=list(label="Residuals vs elev for mod1=lat*lon",cex=1.8),
1461
         scales = list(x = list(at = c(1, 2, 3, 4), #provide tick location and labels
1462
                               labels = c("0-500","500-1000","1000-1500","1500-2000"))),
1463
                       par.settings = list(axis.text = list(font = 2, cex = 1.3), #control the font size!!
1464
        par.main.text=list(font=2,cex=2),strip.background=list(col="white")),
1465
        par.strip.text=list(font=2,cex=1.5)
1466
        )
1467

  
1468
p_bw1<-bwplot(data_v_ag$res_mod1~data_v_ag$LST,do.out=F,ylim=c(-15,15),
1469
         ylab=list(label="Residuals (deg C)",cex=1.5),
1470
         xlab=list(label="Elevation classes (meter)",cex=1.5),
1471
         main=list(label="Residuals vs elev for mod1=lat*lon",cex=1.8),
1472
         scales = list(x = list(at = c(1, 2, 3, 4), #provide tick location and labels
1473
                               labels = c("0-500","500-1000","1000-1500","1500-2000"))),
1474
                       par.settings = list(axis.text = list(font = 2, cex = 1.3), #control the font size!!
1475
        par.main.text=list(font=2,cex=2),strip.background=list(col="white")),
1476
        par.strip.text=list(font=2,cex=1.5)
1477
        )
1478

  
1479
p_bw2 <- bwplot(data_v_ag$res_mod2~elev_rcstat,do.out=F,ylim=c(-15,15),
1480
         ylab=list(label="Residuals (deg C)",cex=1.5),
1481
         xlab=list(label="Elevation classes (meter)",cex=1.5),
1482
         main=list(label="Residuals vs elev for mod5=lat*lon+LST",cex=1.8),
1483
         scales = list(x = list(at = c(1, 2, 3, 4), 
1484
                               labels = c("0-500","500-1000","1000-1500","1500-2000"))),
1485
         par.settings = list(axis.text = list(font = 2, cex = 1.3), #control the font size!!
1486
         par.main.text=list(font=2,cex=2),strip.background=list(col="white")),
1487
         par.strip.text=list(font=2,cex=1.5)
1488
         )
1489

  
1490
p_bw3 <- bwplot(data_v_ag$res_mod7~elev_rcstat,do.out=F,ylim=c(-15,15),
1491
         ylab=list(label="Residuals (deg C)",cex=1.5),
1492
         xlab=list(label="Elevation classes (meter)",cex=1.5),
1493
         main=list(label="Residuals vs elev for mod2=lat*lon+elev",cex=1.8),
1494
         scales = list(x = list(at = c(1, 2, 3, 4), 
1495
                               labels = c("0-500","500-1000","1000-1500","1500-2000"))),
1496
         par.settings = list(axis.text = list(font = 2, cex = 1.3), #control the font size!!
1497
                par.main.text=list(font=2,cex=2),strip.background=list(col="white")),
1498
                par.strip.text=list(font=2,cex=1.5)
1499
                )
1500
grid.arrange(p_bw1,p_bw2,p_bw3,ncol=3)
1501
dev.off()
1420
layout_m<-c(1,3) # works if set to this?? ok set the resolution...
1421
png(paste("Figure_s5b_paper_","_residuals_",date_selected,"_",out_prefix,".png", sep=""),
1422
    height=480*layout_m[1],width=480*layout_m[2])
1502 1423

  
1424
grid.arrange(list_p[[4]],list_p[[5]],list_p[[6]],
1425
             ncol=3)  
1426
dev.off() 
1503 1427

  
1428
layout_m<-c(1,3) # works if set to this?? ok set the resolution...
1429
png(paste("Figure_s5c_paper_","_residuals_",date_selected,"_",out_prefix,".png", sep=""),
1430
    height=480*layout_m[1],width=480*layout_m[2])
1431
grid.arrange(list_p[[7]],
1432
             ncol=3)  
1433
dev.off() 
1504 1434

  
1505 1435
###################### END OF SCRIPT #######################
1506 1436

  
1507
# #LAND COVER ###########################################
1508

  
1509
#INFORMATION
1437
#LAND COVER INFORMATION
1510 1438

  
1511 1439
# LC1: Evergreen/deciduous needleleaf trees
1512 1440
# LC2: Evergreen broadleaf trees

Also available in: Unified diff