Revision 43791b64
Added by Benoit Parmentier over 10 years ago
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
revisions 2 multi-timescale paper additional modif residuals analysis