├── header.tex ├── calc_flue_est_flue0.R ├── selyears_jules.jnl ├── calc_flue_est_alpha.R ├── analyse_powerlaw.R ├── func_flue_est.R ├── remove_outliers.R ├── identify_pattern.R ├── define_grids.R ├── stress_exp.R ├── selyears_lpx.R ├── selyears_sdgvm.R ├── selyears_dlem.R ├── plot_fig_1.R ├── preproc_sdgvm.R ├── plot_linearfit.R ├── preproc_lpx.R ├── compl_df_flue_est.R ├── preproc_orchidee.R ├── reshape_isam.R ├── get_ahlstroem_f.R ├── stress_quad_1sided.R ├── get_linearfit3.R ├── get_aalpha.R ├── get_ann_vpm.R ├── README.md ├── plot_fit_fvar_vs_time.R ├── selyears_orchidee.R ├── get_meteo_fluxnet2015.R ├── getannual_orchidee.R ├── get_linearfit4.R ├── get_linearfit.R ├── calc_soilm.R ├── get_fluxdata_fluxnet2015_annual.R ├── get_nlsfit.R ├── regrid_jung.R ├── execute_reshape_align_nn_fluxnet2015.R ├── prepare_data_openaccess.R ├── map_effects_gpp_var.R ├── clean_fluxnet.R ├── plot_fit_gpp_vs_time.R ├── plot_map_siteoverview.R ├── get_fluxdata_fluxnet2015.R ├── plot_ahlstroem.R ├── map_effects_gpp_relvar.R ├── analyse_modobs.R ├── complement_all.R ├── plot_map.R ├── plot_linearfit2.R ├── integrate_gridcell.R ├── plot_fit_vs_soilmoist.R ├── plot_bias_all.R ├── map_effects_gpp_mean.R ├── data_openaccess └── README.md ├── nature.csl ├── gapfill_nn.R ├── get_modobs_fluxnet2015.R ├── plot_map_gpploss.R ├── get_modobs.R ├── get_linearfit_II.R ├── plot_fig_5.R ├── get_linearfit_V.R ├── plot_fig_3.R ├── get_linearfit_IV.R ├── plot_fig_2.R ├── plot_jung.R ├── plot_fig_4.R ├── plot_aligned_all.R ├── plot_bias_nn_8d.R └── get_extremes_zscheischler.R /header.tex: -------------------------------------------------------------------------------- 1 | \renewcommand{\thetable}{S\arabic{table}} -------------------------------------------------------------------------------- /calc_flue_est_flue0.R: -------------------------------------------------------------------------------- 1 | calc_flue_est_flue0 <- function( x, flue0, cpar, dpar ){ 2 | beta <- (flue0 - 1.0) / (cpar - dpar)^2 3 | flue_est <- beta * (x - dpar)^2 + 1 4 | return( flue_est ) 5 | } -------------------------------------------------------------------------------- /selyears_jules.jnl: -------------------------------------------------------------------------------- 1 | use "/Users/benjaminstocker/data/trendy/v5/JULES/S2/CRU-NCEP_1p1.update.vn4.6.S2.Annual.gpp.nc" 2 | 3 | let gpp_sub=gpp[l=123:156] 4 | 5 | save/clobber/file="/Users/benjaminstocker/data/trendy/v5/JULES/S2/CRU-NCEP_1p1.update.vn4.6.S2.Annual.gpp_sub.nc" gpp_sub -------------------------------------------------------------------------------- /calc_flue_est_alpha.R: -------------------------------------------------------------------------------- 1 | calc_flue_est_alpha <- function( x, alpha, apar, bpar, cpar, dpar ){ 2 | flue0 <- apar + bpar * alpha 3 | beta <- (flue0 - 1.0) / (cpar - dpar)^2 4 | flue_est <- beta * (x - dpar)^2 + 1 5 | flue_est <- ifelse( x>dpar, 1, ifelse( x<0, 0, flue_est ) ) 6 | return( flue_est ) 7 | } 8 | -------------------------------------------------------------------------------- /analyse_powerlaw.R: -------------------------------------------------------------------------------- 1 | # install.packages("devtools") 2 | # devtools::install_github("csgillespie/poweRlaw", subdir="pkg") 3 | 4 | library("poweRlaw") 5 | 6 | test <- relvar$MTE 7 | test <- test[which(test>0)] 8 | 9 | ## continuous power-law 10 | d_cpl = conpl$new(test) 11 | 12 | ## infer model parameters and update object 13 | est = estimate_xmin(d_cpl) 14 | d_cpl$setXmin(est) 15 | 16 | plot(d_cpl) 17 | lines(d_cpl) 18 | 19 | # ## continuous log-normal 20 | # d_cln = conlnorm$new(test) 21 | # plot(d_cln) 22 | # lines(d_cln) 23 | 24 | ## test if data is drawn from a power law distribution 25 | bs_cpl = bootstrap_p( d_cpl, no_of_sims=1000, threads=2 ) 26 | plot(bs_cpl, trim=0.1) 27 | print(bs_cpl$p) 28 | -------------------------------------------------------------------------------- /func_flue_est.R: -------------------------------------------------------------------------------- 1 | ## get flue0 : maximum fLUE reduction at low soil moisture 2 | calc_flue0 <- function( alpha ){ 3 | ## equation from correct_bysoilm.R 4 | y <- 0.1 + 0.92 * alpha 5 | y <- min( y, 1.0 ) 6 | y <- max( y, 0.0 ) 7 | return( y ) 8 | } 9 | 10 | calc_beta <- function( flue0 ){ 11 | x0 <- 0.125 12 | x1 <- 0.75 13 | y <- (flue0 - 1.0) / (x0 - x1)^2 14 | return( y ) 15 | } 16 | 17 | calc_flue_est <- function( soilm, beta ){ 18 | 19 | x1 <- 0.75 20 | 21 | # if (soilm>x1) { 22 | # y <- 1 23 | # } else { 24 | # y <- beta * ( soilm - x1 )^2 + 1.0 25 | # } 26 | # y <- min( 1.0, beta * ( soilm - x1 )^2 + 1.0 ) 27 | y <- beta * ( soilm - x1 )^2 + 1.0 28 | 29 | return( y ) 30 | 31 | } -------------------------------------------------------------------------------- /remove_outliers.R: -------------------------------------------------------------------------------- 1 | remove_outliers_fXX <- function( vec, coef=1.5 ) { 2 | ## use the command boxplot.stats()$out which use the Tukey’s method to identify the outliers ranged above and below the *IQR. 3 | outlier <- boxplot.stats( vec, coef=coef )$out 4 | outlier <- outlier[ which( outlier>1.0 | outlier<0.0 ) ] 5 | vec[ which( is.element( vec, outlier ) ) ] <- NA 6 | return( vec ) 7 | } 8 | 9 | remove_outliers <- function( vec, coef=1.5 ) { 10 | ## use the command boxplot.stats()$out which use the Tukey’s method to identify the outliers ranged above and below the *IQR. 11 | outlier <- boxplot.stats( vec, coef=coef )$out 12 | vec[ which( is.element( vec, outlier ) ) ] <- NA 13 | return( vec ) 14 | } -------------------------------------------------------------------------------- /identify_pattern.R: -------------------------------------------------------------------------------- 1 | identify_pattern <- function( vec ){ 2 | 3 | eps <- 1e-4 4 | 5 | vec <- as.numeric(as.character(vec)) 6 | 7 | ## identify all numbers that appear more than once (already suspicious) 8 | counts <- as.data.frame( table( vec ) ) 9 | counts <- counts[ order(-counts$Freq), ] 10 | counts <- counts[ which(counts$Freq>2), ] 11 | 12 | ## convert factors to numeric 13 | counts$vec <- as.numeric(levels(counts$vec))[counts$vec] 14 | 15 | for (idx in 1:nrow(counts)){ 16 | 17 | ## find where this value appears 18 | pos <- which( abs(vec-counts$vec[idx])% round( 2 ) 9 | eq <- paste0( "y = ", cf[1], ifelse(sign(cf[2])==1, " + ", " - "), abs(cf[2]), " x " ) 10 | mtext( eq, adj=0.05, line=-2.1 ) 11 | 12 | if (!is.null(nlsfit)){ 13 | abline( a=coef(nlsfit)[[ "apar" ]], b=coef(nlsfit)[[ "bpar" ]], col="red" ) 14 | eqfit <- paste0( "y = ", format( coef(nlsfit)[[ "apar" ]], digits=2 ), ifelse(sign(coef(nlsfit)[[ "bpar" ]])==1, " + ", " - "), format( abs(coef(nlsfit)[[ "bpar" ]]), digits=2 ), " x " ) 15 | text( 0.3, 1.0, eqfit, adj=0.0, col="red" ) 16 | } 17 | 18 | } -------------------------------------------------------------------------------- /preproc_lpx.R: -------------------------------------------------------------------------------- 1 | library(dplyr) 2 | library(ncdf4) 3 | 4 | nc <- nc_open( paste0( myhome, "data/trendy/v5/LPX-Bern/S2/LPX_S2_gpp.nc" ) ) 5 | gpp <- ncvar_get( nc, varid="gpp" ) 6 | lon <- nc$dim$longitude$vals 7 | lat <- nc$dim$latitude$vals 8 | nc_close(nc) 9 | 10 | ## get time from a different file 11 | nc <- nc_open( paste0( myhome, "data/trendy/v5/CLM/S2/CLM4.5_S2_gpp.nc" ) ) 12 | time_units <- nc$dim$time$units 13 | time <- nc$dim$time$vals 14 | nc_close(nc) 15 | 16 | gpp <- array( gpp, dim = c(360,180,1,1872)) 17 | 18 | cdf.write( gpp, "gpp", 19 | lon, lat, 20 | filnam = paste0( myhome, "data/trendy/v5/LPX-Bern/S2/LPX_S2_gpp_NICE.nc" ), 21 | nvars = 1, 22 | time = time, 23 | make.zdim = TRUE, 24 | z_dim = 1, 25 | make.tdim = TRUE, 26 | units_time = time_units, 27 | units_var1 = "kg C m-2 s-1", 28 | glob_hist = "created by soilm_global/preproc_lpx.R" 29 | ) 30 | -------------------------------------------------------------------------------- /compl_df_flue_est.R: -------------------------------------------------------------------------------- 1 | compl_df_flue_est <- function( df, linearfit, x0_fix=0.9 ){ 2 | 3 | ## this requires columns in 'df' called 'soilm_mean' and 'meanalpha' 4 | 5 | require(dplyr) 6 | 7 | source("stress_quad_1sided.R") 8 | 9 | ## Merge mean annual alpha (AET/PET) values into this dataframe 10 | if (is.null(df$meanalpha)){ 11 | load( "../sofun/utils_sofun/analysis_sofun/fluxnet2015/data/alpha_fluxnet2015.Rdata" ) # loads 'df_alpha' 12 | df <- df %>% left_join( rename( df_alpha, meanalpha=alpha ), by="mysitename" ) 13 | } 14 | 15 | ##------------------------------------ 16 | ## add estimated fLUE values to data frame 17 | ##------------------------------------ 18 | ## Estimate fLUE based on linear fit between fLUE0 and mean-alpha (fixed "tie points") 19 | df <- df %>% mutate( flue_est = stress_quad_1sided_alpha( soilm_mean, meanalpha, x0_fix, coef(linearfit$linmod)[["(Intercept)"]], coef(linearfit$linmod)[["meanalpha"]] ) ) 20 | 21 | return( df ) 22 | 23 | } -------------------------------------------------------------------------------- /preproc_orchidee.R: -------------------------------------------------------------------------------- 1 | library(dplyr) 2 | library(ncdf4) 3 | 4 | source("../utilities/get_days_since.R") 5 | 6 | nc <- nc_open( paste0( myhome, "data/trendy/v5/ORCHIDEE/S2/orchidee_S2_gpp.nc" ) ) 7 | gpp <- ncvar_get( nc, varid="gpp" ) 8 | lon <- nc$dim$longitude$vals 9 | lat <- nc$dim$latitude$vals 10 | nc_close(nc) 11 | 12 | ## take only years up to 2015 13 | gpp <- gpp[,,1:1380] 14 | 15 | gpp <- array( gpp, dim = c(720,360,1,1380)) 16 | 17 | ## get time from a different file 18 | time <- get_days_since( 1901, 1380, "months" ) 19 | 20 | cdf.write( gpp, "gpp", 21 | lon, lat, 22 | filnam = paste0( myhome, "data/trendy/v5/ORCHIDEE/S2/orchidee_S2_gpp_NICE.nc" ), 23 | nvars = 1, 24 | time = time, 25 | make.zdim = TRUE, 26 | z_dim = 1, 27 | make.tdim = TRUE, 28 | units_time = "days since 1970-01-01 00:00:00", 29 | units_var1 = "kg C m-2 s-1", 30 | glob_hist = "created by soilm_global/preproc_orchidee.R" 31 | ) 32 | -------------------------------------------------------------------------------- /reshape_isam.R: -------------------------------------------------------------------------------- 1 | library(ncdf4) 2 | library(abind) 3 | 4 | print("getting gpp ...") 5 | nc <- nc_open( "/Users/benjaminstocker/data/trendy/v5/ISAM/S2/ISAM_S2_gpp_sub_tmp.nc" ) 6 | lon <- nc$dim$LON$vals 7 | lat <- nc$dim$LAT$vals 8 | gpp <- ncvar_get( nc, varid="GPP" ) 9 | 10 | print("getting time from CLM file ...") 11 | nc_time <- nc_open( "/Users/benjaminstocker/data/trendy/v5/CLM/S2/CLM4.5_S2_gpp_sub.nc" ) 12 | time_units <- nc_time$dim$time$units 13 | time <- nc_time$dim$time$vals 14 | 15 | gpp_resh <- array( gpp, dim=c(length(lon), length(lat), dim(gpp)[4]*12) ) 16 | 17 | ## write reshaped GPP to file 18 | cdf.write( gpp_resh, "gpp", 19 | lon, lat, 20 | filnam = "/Users/benjaminstocker/data/trendy/v5/ISAM/S2/ISAM_S2_gpp_sub.nc", 21 | nvars = 1, 22 | time = time+31, 23 | make.tdim = TRUE, 24 | units_time = time_units, 25 | long_name_var1 = "Gross primary productivity", 26 | units_var1 = "gC m-2 month-1" 27 | ) 28 | 29 | nc_close( nc ) 30 | nc_close( nc_time ) 31 | -------------------------------------------------------------------------------- /get_ahlstroem_f.R: -------------------------------------------------------------------------------- 1 | get_ahlstroem_f <- function( arr, isabs=FALSE ){ 2 | ##--------------------------------------------------- 3 | ## requires as input a 3D array with lon x lat x time 4 | ## and values being annual detrended anomalies 5 | ## index quantifies the degree to which each gridcell contributes to the global signal 6 | ##--------------------------------------------------- 7 | 8 | ## use gridcell total not per unit area 9 | if (isabs==FALSE){ 10 | source( "integrate_gridcell.R" ) 11 | arr_abs <- integrate_gridcell( arr, global=FALSE, overwrite=TRUE ) 12 | glob <- apply( arr_abs, c(3), FUN=sum, na.rm=TRUE ) 13 | } else { 14 | arr_abs <- arr 15 | glob <- apply( arr_abs, c(3), FUN=sum, na.rm=TRUE ) 16 | } 17 | 18 | ahlstroem_f <- arr[,,1] 19 | ahlstroem_f[] <- NA 20 | for (ilon in seq(dim(arr)[1])){ 21 | for (ilat in seq(dim(arr)[2])){ 22 | if (!is.na(arr[ilon,ilat,1])){ 23 | ahlstroem_f[ilon,ilat] <- sum( arr_abs[ilon,ilat,] * abs( glob ) / glob ) / sum( abs( glob ) ) 24 | } 25 | } 26 | } 27 | return( ahlstroem_f ) 28 | } -------------------------------------------------------------------------------- /stress_quad_1sided.R: -------------------------------------------------------------------------------- 1 | stress_quad_1sided <- function( x, x0, beta ){ 2 | outstress <- 1.0 - beta * ( x - x0 ) ^ 2 3 | outstress <- ifelse( x>x0, 1, ifelse( x<0, 0, outstress ) ) 4 | return( outstress ) 5 | } 6 | 7 | stress_quad_1sided_alpha <- function( x, alpha, x0, apar, bpar ){ 8 | 9 | y0 <- apar + bpar * alpha 10 | beta <- (1 - y0) / x0^2 11 | outstress <- 1.0 - beta * ( x - x0 ) ^ 2 12 | outstress <- ifelse( x>x0, 1, ifelse( x<0, 0, outstress ) ) 13 | outstress <- ifelse( outstress>1, 1, ifelse( outstress<0, 0, outstress ) ) 14 | 15 | return( outstress ) 16 | 17 | } 18 | 19 | 20 | stress_quad_1sided_alpha_grasstree <- function( x, alpha, x0, apar, bpar, classid=NA ){ 21 | 22 | ## the first element is for non-grasses 23 | if (classid %in% c("GRA", "CSH") ){ 24 | y0 <- apar[2] + bpar[2] * alpha 25 | } else { 26 | y0 <- apar[1] + bpar[1] * alpha 27 | } 28 | 29 | beta <- (1 - y0) / x0^2 30 | outstress <- 1.0 - beta * ( x - x0 ) ^ 2 31 | outstress <- ifelse( x>x0, 1, ifelse( x<0, 0, outstress ) ) 32 | outstress <- ifelse( outstress>1, 1, ifelse( outstress<0, 0, outstress ) ) 33 | 34 | return( outstress ) 35 | 36 | } 37 | -------------------------------------------------------------------------------- /get_linearfit3.R: -------------------------------------------------------------------------------- 1 | get_linearfit3 <- function( df, useweights=FALSE ){ 2 | ##------------------------------------------------------------------------ 3 | ## Fit a and b parameters to minimise the difference between GPPobs and 4 | ## GPP_Pmodel * fLUEest 5 | ## This is different from linearfit2 because it fits directly. 6 | ##------------------------------------------------------------------------ 7 | require(minpack.lm) 8 | 9 | source("stress_quad_1sided.R") 10 | 11 | if (useweights){ 12 | weights <- 1.0 - df$fvar 13 | weights <- ifelse( weights<0, 0, weights ) 14 | weights <- ifelse( is.na(weights), 0, weights ) 15 | # weights <- weights^2 16 | } else { 17 | weights <- rep( 1.0, nrow(df) ) 18 | } 19 | 20 | fit <- try( 21 | nlsLM( 22 | ratio_obs_mod_pmodel ~ stress_quad_1sided_alpha( soilm_splash220, meanalpha, x0=0.9, apar, bpar ), 23 | data = df, 24 | start = list( apar=0.2, bpar=0.5 ), 25 | lower = c( apar=-1, bpar=0.0 ), 26 | upper = c( apar=0.5, bpar=2.0 ), 27 | algorithm="port", 28 | weights = weights 29 | ) 30 | ) 31 | return( fit ) 32 | } -------------------------------------------------------------------------------- /get_aalpha.R: -------------------------------------------------------------------------------- 1 | library(ncdf4) 2 | library(dplyr) 3 | 4 | ## get AET 5 | if (!exists("aet")){ 6 | print("getting aet ...") 7 | nc <- nc_open( paste( myhome, "data/pmodel_output/Pmod_output_global_AET_C3_s1982-01-01_e2011-12-31_r15_8.nc", sep="") ) 8 | aet <- ncvar_get( nc, varid="AET" ) 9 | lon <- nc$dim$longitude$vals 10 | lat <- nc$dim$latitude$vals 11 | nc_close( nc ) 12 | } 13 | 14 | ## get PET 15 | if (!exists("pet")){ 16 | print("getting pet ...") 17 | nc <- nc_open( paste( myhome, "data/pmodel_output/Pmod_output_global_PET_C3_s1982-01-01_e2011-12-31_r15_8.nc", sep="") ) 18 | pet <- ncvar_get( nc, varid="PET" ) 19 | nc_close( nc ) 20 | } 21 | 22 | ## calculate monthly alpha = monthly AET / monthly PET 23 | if (!exists("malpha")) malpha <- aet / pet 24 | malpha[ which(is.infinite(malpha)) ] <- NA 25 | 26 | ## get mean AET/PET as an average across annual values 27 | if (!exists("aalpha")) aalpha <- apply( malpha, c(1,2), FUN = function(x) min( 1.0, mean( x, na.rm=TRUE ) ) ) 28 | 29 | ## write to file 30 | cdf.write( aalpha, "alpha", 31 | lon, lat, 32 | filnam = "data/alpha_Pmod_SPLASH.nc", 33 | long_name_var1 = "annual mean AET/PET, based on monthly values", 34 | units_var1 = "fraction" 35 | ) 36 | -------------------------------------------------------------------------------- /get_ann_vpm.R: -------------------------------------------------------------------------------- 1 | source("~/.Rprofile") 2 | library(raster) 3 | library(dplyr) 4 | library(abind) 5 | 6 | yearstart = 2000 7 | yearend = 2016 8 | 9 | for (year in yearstart:yearend){ 10 | 11 | rasta <- raster( paste0( myhome, "data/gpp_vpm/GPP.VPM.", as.character(year), ".v20.HD.tif" ) ) 12 | arr <- rasta %>% 13 | as.array() %>% aperm( perm = c(2,1,3) ) 14 | arr <- arr[,,1] 15 | 16 | if (year==2000){ 17 | gpp <- arr 18 | lon <- seq(-179.75, 179.75, by=0.5) 19 | lat <- seq(-89.75,89.75, by=0.5) 20 | } else { 21 | gpp <- abind( gpp, arr, along=3 ) 22 | } 23 | 24 | } 25 | 26 | ## write annual GPP to file 27 | outfilnam <- paste0( myhome, "/data/gpp_vpm/gpp_vpm_ann.nc") 28 | cdf.write( gpp, "gpp", 29 | lon, rev(lat), 30 | filnam = outfilnam, 31 | nvars = 1, 32 | time = yearstart:yearend, 33 | make.tdim = TRUE, 34 | units_time = "year", 35 | long_name_var1 = "Gross primary productivity", 36 | units_var1 = "gC m-2 year-1", 37 | glob_hist = "created using soilm_global/get_ann_vpm.R based on original files data/gpp_vpm/GPP.VPM.*.v20.HD.tif, downloaded from https://figshare.com/collections/A_global_moderate_resolution_dataset_of_gross_primary_production_of_vegetation_for_2000-2016/3789814." 38 | ) 39 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # soilm_global 2 | 3 | [![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.2543324.svg)](https://doi.org/10.5281/zenodo.2543324) 4 | 5 | This repository contains all R code to reproduce the analysis used for the paper *Satellite monitoring underestimates the impact of drought on terrestrial primary production*. 6 | 7 | A detailed description of the scope, method, and algorithms is given by the RMarkdown file `si_soilm_global.Rmd`. 8 | 9 | To get this repository, change into a suitable directory and clone by 10 | ```bash 11 | cd 12 | git clone https://github.com/stineb/soilm_global.git . 13 | ``` 14 | 15 | To render the RMarkdown file, execute all code, and thereby fully reproduce all analysis, simply enter the following command in RStudio (after making sure the 'rmarkdown' package is installed): 16 | ```r 17 | install.packages("rmarkdown", type = "source") 18 | rmarkdown::render_site() 19 | ``` 20 | 21 | Please also note the data use policy, described in `./si_soilm_global.Rmd` and `./LICENSE`. When using this code, please cite the paper Stocker et al. (2019) *Nature Geoscience*. This code is released with a DOI on [Zenodo](http://doi.org/10.5281/zenodo.1286966), where the latest version corresponds to tag `v1.0`. Model outputs from site-scale and global simulations are available on Zenodo with doi:10.5281/zenodo.1423484. 22 | 23 | beni stocker, 18.1.2019 24 | -------------------------------------------------------------------------------- /plot_fit_fvar_vs_time.R: -------------------------------------------------------------------------------- 1 | plot_fit_fvar_vs_time <- function( linearfit1, linearfit_mid, linearfit_strong, ddf=NULL, nice_agg=NULL , makepdf=FALSE){ 2 | 3 | require(dplyr) 4 | require(lubridate) 5 | require(zoo) 6 | 7 | if (!is.null(ddf)){ 8 | ##----------------------------------------------- 9 | ## Time series: fLUE and fLUEest from approaches I, II, and III 10 | ##----------------------------------------------- 11 | filn <- "fig/flue_est_per_site.pdf" 12 | if (makepdf) print( paste( "plotting fLUE and fLUEest vs. time for each site into file ", filn, "..." ) ) 13 | if (makepdf) pdf( filn, width = 10, height = 6 ) 14 | for (sitename in linearfit_mid$data$mysitename){ 15 | 16 | df_tmp <- dplyr::filter(nice_agg, mysitename==sitename) 17 | 18 | if (nrow(df_tmp)>0){ 19 | 20 | par(las=1) 21 | plot( df_tmp$date, df_tmp[[ "fvar" ]], type="l", xlab="time", ylab="fLUE", col="black", ylim = c(0.0, 1.2) ) 22 | # lines( df_tmp$date, df_tmp[[ "fvar_smooth" ]], col="black" ) 23 | lines( df_tmp$date, df_tmp$flue_est_I, col="springgreen3" ) 24 | lines( df_tmp$date, df_tmp$flue_est_IV, col="royalblue3" ) 25 | lines( df_tmp$date, df_tmp$flue_est_II, col="tomato" ) 26 | title( sitename ) 27 | legend( "bottomright", c("approach I", "approach IV", "approach III"), lty=1, bty="n", lwd=2, col=c("springgreen3", "royalblue3", "tomato") ) 28 | abline( h=0.2, lty=3 ) 29 | 30 | } 31 | } 32 | if (makepdf) dev.off() 33 | 34 | } 35 | 36 | } -------------------------------------------------------------------------------- /selyears_orchidee.R: -------------------------------------------------------------------------------- 1 | library(ncdf4) 2 | library(abind) 3 | 4 | print("getting gpp ...") 5 | nc <- nc_open( "/Users/benjaminstocker/data/trendy/v5/ORCHIDEE/S2/orchidee_S2_gpp_1981_1990.nc" ) 6 | lon <- nc$dim$longitude$vals 7 | lat <- nc$dim$latitude$vals 8 | gpp_1 <- ncvar_get( nc, varid="gpp" ) 9 | nc_close( nc ) 10 | 11 | nc <- nc_open( "/Users/benjaminstocker/data/trendy/v5/ORCHIDEE/S2/orchidee_S2_gpp_1991_2000.nc" ) 12 | gpp_2 <- ncvar_get( nc, varid="gpp" ) 13 | nc_close( nc ) 14 | 15 | nc <- nc_open( "/Users/benjaminstocker/data/trendy/v5/ORCHIDEE/S2/orchidee_S2_gpp_2001_2014.nc" ) 16 | gpp_3 <- ncvar_get( nc, varid="gpp" ) 17 | nc_close( nc ) 18 | 19 | nc <- nc_open( "/Users/benjaminstocker/data/trendy/v5/ORCHIDEE/S2/orchidee_S2_gpp_2015_2016.nc" ) 20 | gpp_4 <- ncvar_get( nc, varid="gpp" ) 21 | nc_close( nc ) 22 | 23 | print("getting time from CLM file ...") 24 | nc_time <- nc_open( "/Users/benjaminstocker/data/trendy/v5/CLM/S2/CLM4.5_S2_gpp_sub.nc" ) 25 | time_units <- nc_time$dim$time$units 26 | time <- nc_time$dim$time$vals 27 | # calendar <- nc_time$dim$time$calendar 28 | 29 | gpp <- abind( gpp_1, gpp_2, gpp_3, gpp_4, along=3 ) 30 | 31 | gpp_sub <- gpp[,,13:(dim(gpp)[3]-12)] 32 | 33 | cdf.write( gpp_sub, "gpp", 34 | lon, lat, 35 | filnam = "/Users/benjaminstocker/data/trendy/v5/ORCHIDEE/S2/orchidee_S2_gpp_sub.nc", 36 | nvars = 1, 37 | time = time+30, 38 | make.tdim = TRUE, 39 | units_time = time_units, 40 | long_name_var1 = "Gross primary productivity", 41 | units_var1 = "gC m-2 month-1" 42 | ) 43 | 44 | nc_close( nc ) 45 | nc_close( nc_time ) -------------------------------------------------------------------------------- /get_meteo_fluxnet2015.R: -------------------------------------------------------------------------------- 1 | get_meteo_fluxnet2015 <- function( path ){ 2 | ##-------------------------------------------------------------------- 3 | ## Function returns a dataframe containing all the data of flux-derived 4 | ## GPP for the station implicitly given by path (argument). 5 | ## Specific for FLUXNET 2015 data 6 | ## Returns variables in the following units: 7 | ## temp: deg C 8 | ## vpd : Pa 9 | ## prec: mm d-1 10 | ## nrad: J m-2 d-1 11 | ## swin: J m-2 d-1 12 | ## ppfd: mol m-2 d-1 13 | ##-------------------------------------------------------------------- 14 | require(dplyr) 15 | require(lubridate) 16 | 17 | ## from flux to energy conversion, umol/J (Meek et al., 1984), same as used in SPLASH (see Eq.50 in spash_doc.pdf) 18 | kfFEC <- 2.04 19 | 20 | ## get daily meteo data 21 | meteo <- read_csv( path, na="-9999", col_types = cols() ) %>% 22 | mutate( date = ymd( TIMESTAMP ) ) %>% 23 | rename( temp = TA_F, 24 | vpd = VPD_F, 25 | prec = P_F, 26 | swin = SW_IN_F 27 | ) %>% 28 | mutate( swin = swin * 60 * 60 * 24, # given in W m-2, required in J m-2 d-1 29 | ppfd = swin * kfFEC * 1.0e-6, # convert from J/m2/d to mol/m2/d 30 | vpd = vpd * 1e2, # given in hPa, required in Pa 31 | ccov = NA, 32 | nrad = ifelse( is.element( "NETRAD", names(.) ), as.numeric(NETRAD) * 60 * 60 * 24, NA ) # given in W m-2 (avg.), required in J m-2 (daily total) 33 | ) %>% 34 | select( date, temp, prec, nrad, ppfd, vpd, ccov ) 35 | 36 | return( meteo ) 37 | } -------------------------------------------------------------------------------- /getannual_orchidee.R: -------------------------------------------------------------------------------- 1 | library(ncdf4) 2 | library(abind) 3 | 4 | print("getting gpp ...") 5 | nc <- nc_open( "/Users/benjaminstocker/data/trendy/v5/ORCHIDEE/S2/orchidee_S2_gpp_1981_1990.nc" ) 6 | lon <- nc$dim$longitude$vals 7 | lat <- nc$dim$latitude$vals 8 | gpp_1 <- ncvar_get( nc, varid="gpp" ) 9 | nc_close( nc ) 10 | 11 | nc <- nc_open( "/Users/benjaminstocker/data/trendy/v5/ORCHIDEE/S2/orchidee_S2_gpp_1991_2000.nc" ) 12 | gpp_2 <- ncvar_get( nc, varid="gpp" ) 13 | nc_close( nc ) 14 | 15 | nc <- nc_open( "/Users/benjaminstocker/data/trendy/v5/ORCHIDEE/S2/orchidee_S2_gpp_2001_2014.nc" ) 16 | gpp_3 <- ncvar_get( nc, varid="gpp" ) 17 | nc_close( nc ) 18 | 19 | nc <- nc_open( "/Users/benjaminstocker/data/trendy/v5/ORCHIDEE/S2/orchidee_S2_gpp_2015_2016.nc" ) 20 | gpp_4 <- ncvar_get( nc, varid="gpp" ) 21 | nc_close( nc ) 22 | 23 | gpp <- abind( gpp_1, gpp_2, gpp_3, gpp_4, along=3 ) 24 | 25 | # gpp_resh <- array( gpp, dim=c(length(lon), length(lat), 12, dim(gpp)[3]/12) ) 26 | 27 | # gpp_ann <- apply( gpp_resh, c(1,2,4), FUN = sum ) 28 | 29 | # ## write reshaped GPP to file 30 | # cdf.write( gpp_ann, "gpp", 31 | # lon, lat, 32 | # filnam = "/Users/benjaminstocker/data/trendy/v5/ORCHIDEE/S2/orchidee_S2_gpp_ann.nc", 33 | # nvars = 1, 34 | # time = 1981:2016, 35 | # make.tdim = TRUE, 36 | # units_time = "years", 37 | # long_name_var1 = "Gross primary productivity", 38 | # units_var1 = "gC m-2 year-1" 39 | # ) 40 | 41 | # cdf.write( gpp_ann[,,2:35], "gpp", 42 | # lon, lat, 43 | # filnam = "/Users/benjaminstocker/data/trendy/v5/ORCHIDEE/S2/orchidee_S2_gpp_ann_sub.nc", 44 | # nvars = 1, 45 | # time = 1982:2015, 46 | # make.tdim = TRUE, 47 | # units_time = "years", 48 | # long_name_var1 = "Gross primary productivity", 49 | # units_var1 = "gC m-2 year-1" 50 | # ) -------------------------------------------------------------------------------- /get_linearfit4.R: -------------------------------------------------------------------------------- 1 | binned_bias_sse <- function( df, par ){ 2 | 3 | require(dplyr) 4 | require(tidyr) 5 | 6 | source("stress_quad_1sided.R") 7 | 8 | ## calculate stress as a function of soil moisture, and meanalpha given apar (par[1]) and bpar (par[2]) 9 | df <- df %>% mutate( flue_est = stress_quad_1sided_alpha( soilm_mean, meanalpha, 0.9, par[1], par[2] ) ) %>% 10 | 11 | ## correct modelled, i.e. modify bias accordingly 12 | mutate( bias_pmodel_corr = bias_pmodel * flue_est ) 13 | 14 | ## bin data vs. fLUE (fvar) 15 | nbins <- 10 16 | bins <- seq( 0.0, 1.0, 1.0/nbins ) 17 | xvals <- bins[1:(length(bins)-1)] + (bins[2]-bins[1])/2 18 | df <- tibble( fvar=df$fvar, bias_pmodel_corr=df$bias_pmodel_corr ) 19 | df <- df %>% mutate( inbenibin = cut( fvar , breaks = bins ) ) %>% group_by( inbenibin ) 20 | tmp <- df %>% summarise( median=median( bias_pmodel_corr, na.rm=TRUE ) ) %>% complete( inbenibin, fill = list( median = NA ) ) %>% dplyr::select( median ) 21 | bias_pmodel_corr <- unlist(tmp)[1:nbins] 22 | 23 | ## calculate sum of square errors of median within bins 24 | sse <- sum( log(bias_pmodel_corr) ) 25 | 26 | ## return sse because that's what needs to be minimised 27 | return(sse) 28 | 29 | } 30 | 31 | out <- optim( par=c(0,1), binned_bias_sse, df=filter(ddf, bias_pmodel < 10) ) 32 | 33 | ## plot 34 | ## calculate stress as a function of soil moisture, and meanalpha given apar (par[1]) and bpar (par[2]) 35 | ddf <- ddf %>% mutate( flue_est = stress_quad_1sided_alpha( soilm_mean, meanalpha, 0.9, out$par[1], out$par[2] ) ) %>% 36 | 37 | ## correct modelled, i.e. modify bias accordingly 38 | mutate( bias_pmodel_corr = bias_pmodel * flue_est ) 39 | 40 | ## bin data vs. fLUE (fvar) 41 | nbins <- 5 42 | bins <- seq( 0.0, 1.0, 1.0/nbins ) 43 | xvals <- bins[1:(length(bins)-1)] + (bins[2]-bins[1])/2 44 | tmp <- tibble( fvar=ddf$fvar, bias_pmodel_corr=ddf$bias_pmodel_corr ) 45 | tmp <- tmp %>% mutate( inbenibin = cut( fvar , breaks = bins ) ) %>% group_by( inbenibin ) 46 | boxplot( log(bias_pmodel_corr) ~ inbenibin, data=tmp, outline=FALSE ) 47 | abline( h=0, lty=3 ) 48 | -------------------------------------------------------------------------------- /get_linearfit.R: -------------------------------------------------------------------------------- 1 | get_linearfit <- function( df, monthly=FALSE ){ 2 | ##------------------------------------------------------------------------ 3 | ## This gets the "y-axis intersect" as the flue (fvar) value in the lowest soil moisture bin (0-10%) -> y0 4 | ## and fits a linear model between mean site alpha value and y0. 5 | ## This is preferred over directly fitting to fLUE due to the small number of 6 | ## data points at low soil moisture. 7 | ##------------------------------------------------------------------------ 8 | require(dplyr) 9 | require(tidyr) 10 | 11 | if (monthly){ 12 | ## add date and MOY to dataframe nice_agg 13 | df <- df %>% mutate( date = as.POSIXct( as.Date( paste( as.character( year ), "-01-01", sep="" ) ) + doy - 1 )) 14 | df <- df %>% mutate( moy = as.numeric( format( date, format="%m" ) ) ) 15 | 16 | ## aggregate nice_agg to monthly values 17 | df <- df %>% group_by( mysitename, year, moy ) %>% summarise( fvar = mean( fvar, na.rm=TRUE ), soilm_mean = mean( soilm_mean, na.rm=TRUE ) ) 18 | } 19 | 20 | ##------------------------------------------------------------------------ 21 | ## Determine maximum LUE reduction (mean fLUE in lowest bin) for each site (-> df_flue0) 22 | ##------------------------------------------------------------------------ 23 | ## Bin values and get mean fLUE for soil moisture < 0.25 for each site (:= flue0) 24 | intervals <- seq(0, 1, 0.25) 25 | df$ininterval <- NULL 26 | df <- df %>% mutate( ininterval = cut( soilm_mean , breaks = intervals ) ) %>% group_by( mysitename, ininterval ) 27 | df_flue0 <- df %>% dplyr::summarise( y0=mean( fvar, na.rm=TRUE ) ) %>% 28 | complete( ininterval, fill = list( y0 = NA ) ) %>% 29 | dplyr::filter( ininterval=="(0,0.25]" ) 30 | 31 | ## Merge mean annual alpha (AET/PET) values into this dataframe 32 | load( "./data/alpha_fluxnet2015.Rdata" ) # loads 'df_alpha' 33 | df_flue0 <- df_flue0 %>% left_join( rename( df_alpha, meanalpha=alpha ), by="mysitename" ) 34 | 35 | ##------------------------------------------------------------------------ 36 | ## Fit linear model 37 | ##------------------------------------------------------------------------ 38 | linmod <- lm( y0 ~ meanalpha, data=df_flue0 ) 39 | 40 | return( list( linmod=linmod, data=df_flue0 ) ) 41 | 42 | } -------------------------------------------------------------------------------- /calc_soilm.R: -------------------------------------------------------------------------------- 1 | calc_soilm <- function( prec, et, method="bucket" ){ 2 | 3 | ## Arguments 4 | ## prec : precipitation (mm d-1) 5 | ## et : ecosystem-scale evapotranspiration (mm d-1) 6 | 7 | ## Parameters 8 | ndayyear <- 365 9 | nyrspinup <- 1 # number of spinup years 10 | whc <- 220.0 # water holding capacity (mm) 11 | 12 | ## keenan parameters 13 | por <- 0.4 14 | hg <- 1 15 | 16 | ## orthbucket parameters 17 | # exp_runoff <- 6.4 18 | exp_runoff <- 6.4 19 | 20 | nsteps <- length(prec) 21 | outsoilm <- rep( NA, nsteps ) 22 | 23 | ##--------------------------------------------------------- 24 | ## Spinup soil moisture with first 365 days' data 25 | ##--------------------------------------------------------- 26 | soilm <- whc 27 | for (idx in seq( nyrspinup * ndayyear )){ 28 | 29 | useidx <- idx %% ndayyear 30 | if (useidx==0) {useidx <- 1} 31 | 32 | if (method=="bucket"){ 33 | runoff <- max( 0.0, soilm + prec[idx] - whc ) 34 | 35 | } else if (method=="keenan"){ 36 | runoff <- 0.0001 * hg * (1.0 - por) * prec[idx] 37 | runoff <- runoff + 0.01 * soilm # add drainage 38 | 39 | } else if (method=="orthbucket"){ 40 | 41 | if (soilm < 0.01 * whc && prec[idx]<0.5*whc){ 42 | runoff <- 0.0 43 | } else { 44 | runoff <- ( min( 1.0, ( ( soilm / whc ) ^ exp_runoff ) ) ) * prec[idx] 45 | } 46 | 47 | } 48 | 49 | soilm <- min( max( 0.0, soilm + prec[idx] - et[idx] - runoff ), whc ) 50 | 51 | } 52 | 53 | ##--------------------------------------------------------- 54 | ## Run forward 55 | ##--------------------------------------------------------- 56 | for (idx in seq(nsteps)){ 57 | 58 | if (method=="bucket"){ 59 | runoff <- max( 0.0, soilm + prec[idx] - whc ) 60 | 61 | } else if (method=="keenan"){ 62 | runoff <- 0.0001 * hg * (1.0 - por) * prec[idx] 63 | runoff <- runoff + 0.01 * soilm # add drainage 64 | 65 | } else if (method=="orthbucket"){ 66 | 67 | if (soilm < 0.01 * whc && prec[idx]<0.5*whc){ 68 | runoff <- 0.0 69 | } else { 70 | runoff <- ( min( 1.0, ( ( soilm / whc ) ^ exp_runoff ) ) ) * prec[idx] 71 | } 72 | 73 | } 74 | 75 | soilm <- min( max( 0.0, soilm + prec[idx] - et[idx] - runoff ), whc ) 76 | 77 | outsoilm[idx] <- soilm 78 | 79 | } 80 | 81 | return( outsoilm ) 82 | 83 | } -------------------------------------------------------------------------------- /get_fluxdata_fluxnet2015_annual.R: -------------------------------------------------------------------------------- 1 | get_fluxdata_fluxnet2015_annual <- function( sitename, add_swcvars=FALSE ){ 2 | ##-------------------------------------------------------------------- 3 | ## Function returns a dataframe containing all the data of flux-derived 4 | ## GPP for the station implicitly given by path (argument). 5 | ## Specific for FLUXNET 2015 data 6 | ## Returns variables in the following units: 7 | ## temp: deg C 8 | ## vpd : Pa 9 | ## prec: mm d-1 10 | ## nrad: J m-2 d-1 11 | ## swin: J m-2 d-1 12 | ## ppfd: mol m-2 d-1 13 | ##-------------------------------------------------------------------- 14 | require(dplyr) 15 | require(readr) 16 | require(lubridate) 17 | 18 | # ## xxx debug ------------- 19 | # path = "/Users/benjaminstocker/data/FLUXNET-2015_Tier1/20160128/point-scale_none_1d/original/unpacked/FLX_AR-SLu_FLUXNET2015_FULLSET_DD_2009-2011_1-3.csv" 20 | # add_swcvars = TRUE 21 | # ## ----------------------- 22 | 23 | # print( paste( "getting FLUXNET 2015 data for site", sitename ) ) 24 | dirnam_obs <- paste0( myhome, "data/FLUXNET-2015_Tier1/20160128/point-scale_none_1y/original/unpacked/" ) 25 | allfiles <- list.files( dirnam_obs ) 26 | allfiles <- allfiles[ which( grepl( "FULLSET", allfiles ) ) ] 27 | allfiles <- allfiles[ which( grepl( "3.csv", allfiles ) ) ] 28 | filnam_obs <- allfiles[ which( grepl( sitename, allfiles ) ) ] 29 | path <- paste0( dirnam_obs, filnam_obs ) 30 | 31 | ## from flux to energy conversion, umol/J (Meek et al., 1984), same as used in SPLASH (see Eq.50 in spash_doc.pdf) 32 | kfFEC <- 2.04 33 | 34 | ## molar mass of C 35 | c_molmass <- 12.0107 36 | 37 | ## get data 38 | adf <- read_csv( path, na="-9999", col_types = cols() ) %>% 39 | mutate( year = TIMESTAMP ) 40 | 41 | ## convert units. given in umolCO2 m-2 s-1. converted to gC m-2 d-1 42 | adf <- adf %>% mutate( 43 | GPP_NT_VUT_REF = as.numeric(GPP_NT_VUT_REF) , 44 | GPP_NT_VUT_USTAR50 = as.numeric(GPP_NT_VUT_USTAR50), 45 | GPP_DT_VUT_REF = as.numeric(GPP_DT_VUT_REF) , 46 | GPP_DT_VUT_USTAR50 = as.numeric(GPP_DT_VUT_USTAR50), 47 | LE_F_MDS = as.numeric(LE_F_MDS), ## W m-2 -> J m-2 d-1 48 | gpp_obs = ( GPP_NT_VUT_REF + GPP_DT_VUT_REF ) / 2 49 | ) 50 | 51 | return( adf ) 52 | } -------------------------------------------------------------------------------- /get_nlsfit.R: -------------------------------------------------------------------------------- 1 | get_nlsfit <- function( df, target="fvar", monthly=FALSE, bin=FALSE, x0_fix=0.9 ){ 2 | 3 | require(minpack.lm) 4 | require(dplyr) 5 | require(tidyr) 6 | 7 | source("calc_flue_est_alpha.R") 8 | source("stress_quad_1sided.R") 9 | 10 | if (monthly){ 11 | ## add date and MOY to dataframe nice_agg 12 | df <- df %>% mutate( date = as.POSIXct( as.Date( paste( as.character( year ), "-01-01", sep="" ) ) + doy - 1 )) 13 | df <- df %>% mutate( moy = as.numeric( format( date, format="%m" ) ) ) 14 | 15 | ## aggregate nice_agg to monthly values 16 | df <- df %>% group_by( mysitename, year, moy ) %>% summarise( fvar = mean( fvar, na.rm=TRUE ), soilm_mean = mean( soilm_mean, na.rm=TRUE ) ) 17 | } 18 | 19 | if (bin){ 20 | nsbins <- 10 21 | sbins <- seq( 0.0, 1.0, 1.0/nsbins ) 22 | xvals <- sbins[1:(length(sbins)-1)] + (sbins[2]-sbins[1])/2 23 | 24 | ## Get median by interval and get fvar_vs_soilm for this site (used for clustering) 25 | df$insbin <- NULL 26 | df <- df %>% mutate( insbin = cut( soilm_mean, breaks = sbins ) ) %>% group_by( insbin, mysitename ) 27 | df <- df %>% summarise( soilm_mean=mean( soilm_mean, na.rm=TRUE ), fvar=mean( fvar, na.rm=TRUE ), ratio_obs_mod=mean( ratio_obs_mod, na.rm=TRUE ) ) %>% 28 | complete( insbin, fill = list( fvar = NA ) ) 29 | } 30 | 31 | ## Merge mean annual alpha (AET/PET) values into this dataframe 32 | if (is.null(df$meanalpha)){ 33 | load( "../sofun/utils_sofun/analysis_sofun/fluxnet2015/data/alpha_fluxnet2015.Rdata" ) # loads 'df_alpha' 34 | df <- df %>% left_join( rename( df_alpha, meanalpha=alpha ), by="mysitename" ) 35 | } 36 | 37 | ##------------------------------------ 38 | ## Estimate fLUE using non-linear least squares on quadratic function 39 | ##------------------------------------ 40 | eq <- paste0( target, " ~ stress_quad_1sided_alpha( soilm_mean, meanalpha, x0, apar, bpar )" ) 41 | nlsfit <- try( 42 | nlsLM( 43 | # fvar ~ calc_flue_est_alpha( soilm_mean, meanalpha, apar, bpar, cpar, dpar ), 44 | # fvar ~ stress_quad_1sided_alpha( soilm_mean, meanalpha, x0, apar, bpar ), 45 | eq, 46 | data=df, 47 | start=list( x0=0.9, apar=-0.19, bpar=0.96 ), 48 | lower=c( 0.9, apar=-1 , bpar=0.1 ), 49 | upper=c( 0.9, apar=1 , bpar=2 ), 50 | algorithm="port" 51 | ) 52 | ) 53 | 54 | return( nlsfit ) 55 | 56 | } -------------------------------------------------------------------------------- /regrid_jung.R: -------------------------------------------------------------------------------- 1 | vec_res <- c( 0.5, 1.0, 1.5, 2.5, 3, 4, 4.5, 5, 6, 7.5, 9, 10, 12, 15, 18, 20, 22.5, 30, 36, 45, 60, 90, 180, 360 ) 2 | 3 | filpath_DETR <- c( "/Users/benjaminstocker/data/pmodel_fortran_output/v2/gpp_pmodel_s0_DETR.nc", 4 | "/Users/benjaminstocker/data/pmodel_fortran_output/v2/gpp_pmodel_s1a_DETR.nc", 5 | "/Users/benjaminstocker/data/pmodel_fortran_output/v2/gpp_pmodel_s1b_DETR.nc", 6 | "/Users/benjaminstocker/data/pmodel_fortran_output/v2/gpp_pmodel_s1c_DETR.nc" 7 | ) 8 | 9 | filpath_ANN <- c( "/Users/benjaminstocker/data/pmodel_fortran_output/v2/gpp_pmodel_s0_ANN.nc", 10 | "/Users/benjaminstocker/data/pmodel_fortran_output/v2/gpp_pmodel_s1a_ANN.nc", 11 | "/Users/benjaminstocker/data/pmodel_fortran_output/v2/gpp_pmodel_s1b_ANN.nc", 12 | "/Users/benjaminstocker/data/pmodel_fortran_output/v2/gpp_pmodel_s1c_ANN.nc" 13 | ) 14 | 15 | ## regrid using 'cdo remapbil' 16 | for ( ires in 2:(length(vec_res)-1) ){ 17 | 18 | for (isim in 1:length(filpath_DETR)){ 19 | 20 | ## regrid detrended file 21 | gridfile <- paste0("grids/grid_", sprintf("%02d", ires),".txt") 22 | infile <- filpath_DETR[isim] 23 | outfile <- gsub( "DETR", paste0("DETR_REGR", sprintf("%02d", ires)), infile ) 24 | cmd <- paste0( "cdo remapbil,", gridfile, " ", infile, " ", outfile ) 25 | print( cmd ) 26 | system( cmd ) 27 | 28 | ## regrid ANN file 29 | gridfile <- paste0("grids/grid_", sprintf("%02d", ires),".txt") 30 | infile <- filpath_ANN[isim] 31 | outfile <- gsub( "ANN", paste0("ANN_REGR", sprintf("%02d", ires)), infile ) 32 | cmd <- paste0( "cdo remapbil,", gridfile, " ", infile, " ", outfile ) 33 | print( cmd ) 34 | system( cmd ) 35 | 36 | } 37 | 38 | } 39 | 40 | ## the last one (global) has to be treated a bit differently using 'cdo fldmean' 41 | ires <- length(vec_res) 42 | for (isim in 1:length(filpath_DETR)){ 43 | 44 | ## regrid detrended file 45 | gridfile <- paste0("grids/grid_", sprintf("%02d", ires),".txt") 46 | infile <- filpath_DETR[isim] 47 | outfile <- gsub( "DETR", paste0("DETR_REGR", sprintf("%02d", ires)), infile ) 48 | cmd <- paste0( "cdo fldmean ", infile, " ", outfile ) 49 | print( cmd ) 50 | system( cmd ) 51 | 52 | ## regrid ANN file 53 | gridfile <- paste0("grids/grid_", sprintf("%02d", ires),".txt") 54 | infile <- filpath_ANN[isim] 55 | outfile <- gsub( "ANN", paste0("ANN_REGR", sprintf("%02d", ires)), infile ) 56 | cmd <- paste0( "cdo fldmean ", infile, " ", outfile ) 57 | print( cmd ) 58 | system( cmd ) 59 | 60 | } 61 | -------------------------------------------------------------------------------- /execute_reshape_align_nn_fluxnet2015.R: -------------------------------------------------------------------------------- 1 | ##------------------------------------------------ 2 | # This script executes this function for all sites where fLUE droughts are identified (`successcode==1`) 3 | # and combines dataframes into combined large dataframes containing all sites' data, saved in `data/data_aligned_agg.Rdata`: 4 | # - `df_dday_agg` 5 | # - `df_dday_modis_agg` 6 | # - `df_dday_mte_agg` 7 | # - `df_dday_aggbydday_agg` 8 | ##------------------------------------------------ 9 | require(dplyr) 10 | require(readr) 11 | 12 | source( "reshape_align_nn_fluxnet2015.R" ) 13 | 14 | ##------------------------------------------------ 15 | ## Select all sites for which method worked (codes 1 and 2 determined by 'nn_getfail_fluxnet2015.R') 16 | ##------------------------------------------------ 17 | siteinfo <- read_csv( "successcodes.csv" ) 18 | do.sites <- dplyr::filter( siteinfo, successcode==1 )$mysitename 19 | 20 | # ## add classid column 21 | # tmp <- read.csv( paste( myhome, "sofun/input_fluxnet2015_sofun/siteinfo_fluxnet2015_sofun.csv", sep="") ) 22 | # siteinfo <- siteinfo %>% left_join( dplyr::select(tmp, mysitename, classid ) ) 23 | 24 | print( "aligning data for all sites ...") 25 | 26 | ## initialise aggregated data 27 | df_dday_agg <- c() 28 | df_dday_8d_agg <- c() 29 | df_dday_aggbydday_agg <- c() 30 | df_dday_aggbydday_8d_agg <- c() 31 | 32 | for (sitename in do.sites){ 33 | 34 | print( paste( "reshaping for site", sitename ) ) 35 | out <- reshape_align_nn_fluxnet2015( sitename, nam_target="lue_obs_evi", overwrite=TRUE, verbose=FALSE ) 36 | 37 | if (!is.null(out$df_dday)) df_dday_agg <- bind_rows( df_dday_agg, out$df_dday ) 38 | if (!is.null(out$df_dday_aggbydday)) df_dday_aggbydday_agg <- bind_rows( df_dday_aggbydday_agg, out$df_dday_aggbydday ) 39 | if (!is.null(out$df_dday_aggbydday_8d)) df_dday_aggbydday_8d_agg <- bind_rows( df_dday_aggbydday_8d_agg, out$df_dday_aggbydday_8d ) 40 | if (!is.null(out$df_dday_8d )) df_dday_8d_agg <- bind_rows( df_dday_8d_agg , out$df_dday_8d ) 41 | 42 | } 43 | 44 | 45 | print("... done.") 46 | 47 | if ( length( dplyr::filter( siteinfo, successcode==1 )$mysitename ) == length( do.sites ) ){ 48 | ##------------------------------------------------ 49 | ## Aggregated data from MODIS and MTE around drought events 50 | ##------------------------------------------------ 51 | filn <- "data/data_aligned_agg.Rdata" 52 | print( paste( "saving variables 'df_dday_agg', 'df_dday_8d_agg', and 'df_dday_aggbydday_agg' to file:", filn ) ) 53 | save( df_dday_agg, df_dday_8d_agg, df_dday_aggbydday_agg, df_dday_aggbydday_8d_agg, file=filn ) 54 | 55 | } else { 56 | 57 | print("WARNING: NO SAVING AT THE END!") 58 | 59 | } 60 | -------------------------------------------------------------------------------- /prepare_data_openaccess.R: -------------------------------------------------------------------------------- 1 | library(dplyr) 2 | library(readr) 3 | 4 | ##------------------------------------------------ 5 | ## Data filtered to fLUE-drought-affected periods 6 | ##------------------------------------------------ 7 | ## Load aligned aggregated data; prepared by 'execute_reshape_align_nn_fluxnet2015.R', calling 'reshape_align_nn_fluxnet2015.R' 8 | load( "data/data_aligned_agg.Rdata" ) 9 | 10 | ## IMPORTANT: REMOVE DUPLICATE ROWS (were introduced because one date can below to multiple drought instances (within their before-after window) ) 11 | df_dday_agg <- df_dday_agg %>% select( -dday, -inst ) %>% unique() 12 | df_dday_8d_agg <- df_dday_8d_agg %>% select( -dday, -inst ) %>% unique() 13 | 14 | ## Select variables for which data can be made publicly accessible 15 | df_dday_agg <- df_dday_agg %>% select( site_id = mysitename, date, soilm_splash, flue = fvar, beta_a = flue_est_I, 16 | beta_b = flue_est_IV, beta_c = flue_est_III, alpha, gpp_pmodel 17 | ) 18 | df_dday_8d_agg <- df_dday_8d_agg %>% select( site_id = mysitename, date, soilm_splash, flue = fvar, beta_a = flue_est_I, 19 | beta_b = flue_est_IV, beta_c = flue_est_III, alpha, gpp_pmodel 20 | ) 21 | 22 | if (!dir.exists("./data_openaccess")) system("mkdir data_openaccess") 23 | 24 | write_csv( df_dday_agg, path = "data_openaccess/gpp_alg_daily_fluxnet_stocker18natgeo.csv" ) 25 | write_csv( df_dday_8d_agg, path = "data_openaccess/gpp_alg_8daily_fluxnet_stocker18natgeo.csv" ) 26 | 27 | ##------------------------------------------------ 28 | ## Full data with reliable soil moisture information 29 | ##------------------------------------------------ 30 | # Load aggregated data from all sites, created by plot_nn_fVAR_fluxnet2015.R: 31 | load( "data/nice_all_agg_lue_obs_evi.Rdata" ) # loads 'nice_agg' 32 | load( "data/nice_all_8d_agg_lue_obs_evi.Rdata" ) # loads 'nice_8d' 33 | 34 | successcodes <- read.csv( "successcodes.csv" ) 35 | do.sites <- dplyr::filter( successcodes, successcode==1 | successcode==2 )$mysitename 36 | 37 | ## Use only sites where NN method worked (i.e. that had clear and identifiable soil moisture limitation) 38 | nice_agg <- nice_agg %>% filter( mysitename %in% do.sites ) 39 | nice_8d_agg <- nice_8d_agg %>% filter( mysitename %in% do.sites ) 40 | 41 | ## Select variables for which data can be made publicly accessible 42 | nice_agg <- nice_agg %>% select( site_id = mysitename, date , gpp_pmodel, aet_splash = aet_pmodel, pet_splash = pet_pmodel ) 43 | nice_8d_agg <- nice_8d_agg %>% select( site_id = mysitename, date_start, gpp_pmodel, aet_splash = aet_pmodel, pet_splash = pet_pmodel ) 44 | 45 | write_csv( nice_agg, path = "data_openaccess/gpp_daily_fluxnet_stocker18natgeo.csv" ) 46 | write_csv( nice_8d_agg, path = "data_openaccess/gpp_8daily_fluxnet_stocker18natgeo.csv" ) 47 | -------------------------------------------------------------------------------- /map_effects_gpp_var.R: -------------------------------------------------------------------------------- 1 | library(ncdf4) 2 | library(RColorBrewer) 3 | source("plot_map.R") 4 | 5 | source("~/.Rprofile") 6 | 7 | ##------------------------------------------------------------------------ 8 | ## GPP interannual (absolute) variance change 9 | ##------------------------------------------------------------------------ 10 | fil_s0 <- "gpp_pmodel_s0_VAR.nc" 11 | fil_s1b <- "gpp_pmodel_s1b_VAR.nc" 12 | 13 | dir <- paste0( myhome, "/data/pmodel_fortran_output/v2/") 14 | 15 | ## S0 16 | nc <- nc_open( paste0( dir, fil_s0 ) ) 17 | gpp_s0 <- ncvar_get( nc, varid="gpp" ) 18 | lon <- nc$dim$lon$vals 19 | lat <- nc$dim$lat$vals 20 | time <- nc$dim$time$vals 21 | nc_close(nc) 22 | 23 | ## S1 24 | nc <- nc_open( paste0( dir, fil_s1b ) ) 25 | gpp_s1b <- ncvar_get( nc, varid="gpp" ) 26 | nc_close(nc) 27 | 28 | # ##----------------------------------------------------- 29 | # ## Plot absolute variance in S1 30 | # ##----------------------------------------------------- 31 | # plot_map( gpp_s1*1e-3, lev=c( 0, 40, 10 ), maxval = 200 ) 32 | # 33 | # ##----------------------------------------------------- 34 | # ## Difference in absolute variance 35 | # ##----------------------------------------------------- 36 | # plot_map( (gpp_s1 - gpp_s0)*1e-3, lev=c( -10, 10, 10 ), positive = FALSE, maxval=60, minval=-60 ) 37 | 38 | # ##----------------------------------------------------- 39 | # ## Amplification in absolute variance 40 | # ##----------------------------------------------------- 41 | # color <- c( "royalblue4", "wheat", "tomato2", "tomato4" ) 42 | # lev <- c( 0, 4, 10 ) 43 | # maxval = 35 44 | # minval = NA 45 | # # par( mar=c(4,3,3,1),xaxs="i", yaxs="i",las=1, mgp=c(3,1,0)) 46 | # out.mycolorbar <- mycolorbar( color, lev, orient="v", plot=FALSE, maxval=maxval, minval=minval ) 47 | # plot_map( gpp_s1b/gpp_s0, lev=lev, maxval=maxval, color = out.mycolorbar$colors ) 48 | 49 | # plot_map( gpp_s1b - gpp_s0, lev=seq(-5000,13000,2000), minval=-169000, maxval=83000, toplefttext=expression(paste("")), toprighttext=expression(paste("g C m"^-2, " yr"^-1 ) ), color=c( "royalblue4", "wheat", "tomato2", "tomato4" ) ) 50 | 51 | # hist( gpp_s0, xlim=c(0,50000), breaks=300, col=rgb(0,0,0,0.3) ) 52 | # hist( gpp_s1b, breaks=300, col=rgb(1,0,0,0.3), add=TRUE ) 53 | 54 | # ## Analyse distribution factor vs. aridity (mean annual AET/PET) 55 | # ncfiln <- "../data/greve/ep_over_p_cru_ncep.nc" 56 | # if (!file.exists(ncfiln)) { 57 | # epop <- array( 1, dim=c(720,360) ) 58 | # } else { 59 | # nc <- nc_open( ncfiln ) 60 | # epop <- ncvar_get( nc, varid="EP_OVER_P_CRU_NCEP" ) 61 | # } 62 | # alpha <- 1/epop 63 | 64 | # diff <- gpp_s1b - gpp_s0 65 | # df <- tibble( diff = c(diff), alpha = c(alpha) ) %>% 66 | # filter( !is.na(diff) & !is.na(alpha) ) %>% 67 | # mutate( inbin = cut( alpha, breaks = c(0, 0.05, 0.2, 0.5, 0.7, 1.3, 3) ) ) 68 | 69 | # par(las=1) 70 | # myboxplot( log(diff) ~ inbin, data = df, outline=FALSE, 71 | # col=colorRampPalette( rev( c( "royalblue4", "wheat", "tomato2", "tomato4" ) ) )( 6 ), 72 | # ylab="Difference", xlab="Aridity index") 73 | # abline(h=1, lty=3) 74 | -------------------------------------------------------------------------------- /clean_fluxnet.R: -------------------------------------------------------------------------------- 1 | clean_fluxnet_gpp <- function( gpp_nt, gpp_dt, qflag_reichstein, qflag_lasslop, cutoff=0.80 ){ 2 | ##-------------------------------------------------------------------- 3 | ## Cleans daily data using criteria 1-4 as documented in Tramontana et al., 2016 4 | ## gpp_nt: based on nighttime flux decomposition ("NT") 5 | ## gpp_dt: based on daytime flux decomposition ("DT") 6 | ##-------------------------------------------------------------------- 7 | 8 | ## Remove data points that are based on too much gap-filled data in the underlying half-hourly data 9 | gpp_nt[ which(qflag_reichstein < cutoff) ] <- NA ## based on fraction of data based on gap-filled half-hourly 10 | gpp_dt[ which(qflag_lasslop < cutoff) ] <- NA ## based on fraction of data based on gap-filled half-hourly 11 | 12 | ## Remove data points where the two flux decompositions are inconsistent, 13 | ## i.e. where the residual of their regression is above the 97.5% or below the 2.5% quantile. 14 | res <- as.numeric(gpp_nt) - as.numeric(gpp_dt) 15 | q025 <- quantile( res, probs = 0.025, na.rm=TRUE ) 16 | q975 <- quantile( res, probs = 0.975, na.rm=TRUE ) 17 | 18 | gpp_nt[ res > q975 | res < q025 ] <- NA 19 | gpp_dt[ res > q975 | res < q025 ] <- NA 20 | 21 | ## remove negative GPP 22 | gpp_nt[ which(gpp_nt<0) ] <- NA 23 | gpp_dt[ which(gpp_dt<0) ] <- NA 24 | 25 | return( list( gpp_nt=gpp_nt, gpp_dt=gpp_dt ) ) 26 | } 27 | 28 | clean_fluxnet_et <- function( et, qflag_et, cutoff=0.2 ){ 29 | ##-------------------------------------------------------------------- 30 | ##-------------------------------------------------------------------- 31 | source( "identify_pattern.R" ) 32 | 33 | ## Remove data points that are based on too much gap-filled data in the underlying half-hourly data 34 | # frac_data_thresh <- 0.2 ## fraction of data based on gap-filled half-hourly 35 | et[ qflag_et < cutoff ] <- NA 36 | 37 | if ( any(!is.na(qflag_et)) ){ et[ is.na(qflag_et) ] <- NA } 38 | 39 | et <- identify_pattern( et ) 40 | 41 | return( et ) 42 | } 43 | 44 | clean_fluxnet_swc <- function( swc, qflag_swc, frac_data_thresh=0.2 ){ 45 | ##-------------------------------------------------------------------- 46 | ## frac_data_thresh: fraction of data based on gap-filled half-hourly 47 | ##-------------------------------------------------------------------- 48 | ## Remove data points that are based on too much gap-filled data in the underlying half-hourly data 49 | swc[ qflag_swc < frac_data_thresh ] <- NA 50 | swc <- as.numeric( swc ) 51 | 52 | return( swc ) 53 | } 54 | 55 | cleandata_nn <- function( data, varnam ){ 56 | ##------------------------------------------------ 57 | ## Remove cold days and days where GPP is negative 58 | ##------------------------------------------------ 59 | require( dplyr ) 60 | 61 | if (varnam=="gpp_obs"){ 62 | data <- filter( data, !is.na(gpp_obs) ) 63 | data <- filter( data, gpp_obs > 0.0 ) 64 | 65 | } else if (varnam=="et_obs"){ 66 | data <- filter( data, !is.na( et_obs ) ) 67 | 68 | } else if (varnam=="wue_obs"){ 69 | data <- filter( data, !is.na( wue_obs ) ) 70 | 71 | } else if (varnam=="lue_obs"){ 72 | data <- filter( data, !is.na( lue_obs ) ) 73 | 74 | } 75 | 76 | return( data ) 77 | } 78 | 79 | -------------------------------------------------------------------------------- /plot_fit_gpp_vs_time.R: -------------------------------------------------------------------------------- 1 | plot_fit_gpp_vs_time <- function( linearfit1, linearfit_mid, linearfit_strong, ddf=NULL, nice_agg=NULL, makepdf=FALSE ){ 2 | 3 | require(dplyr) 4 | require(lubridate) 5 | 6 | if (!is.null(ddf)){ 7 | 8 | ##----------------------------------------------- 9 | ## Time series: GPPobs and (GPP_Pmodel * fLUEest) from approaches I, II, and III 10 | ## aggregated to weekly 11 | ##----------------------------------------------- 12 | nice_agg <- nice_agg %>% mutate( inlowbin1 = ifelse( fvar < 0.2, 1, NA ), inlowbin2 = ifelse( fvar < 0.3, 1, NA ), inlowbin3 = ifelse( fvar < 0.4, 1, NA ) ) 13 | wdf <- nice_agg %>% mutate( gpp_pmodel_I = gpp_pmodel * flue_est_I, 14 | gpp_pmodel_IV = gpp_pmodel * flue_est_IV , 15 | gpp_pmodel_III = gpp_pmodel * flue_est_III ) %>% 16 | group_by( mysitename, week(date), year(date) ) %>% 17 | summarise( gpp_obs = mean(gpp_obs, na.rm=TRUE), 18 | gpp_pmodel = mean(gpp_pmodel , na.rm=TRUE), 19 | gpp_pmodel_I = mean(gpp_pmodel_I, na.rm=TRUE), 20 | gpp_pmodel_IV = mean(gpp_pmodel_IV, na.rm=TRUE), 21 | gpp_pmodel_III = mean(gpp_pmodel_III, na.rm=TRUE), 22 | date = mean(date) 23 | ) %>% 24 | mutate( year=year(date)) %>% 25 | arrange( mysitename, year, date ) 26 | 27 | filn <- "fig/gpp_per_site.pdf" 28 | if (makepdf) print( paste( "plotting GPPobs and (GPP_Pmodel * fLUEest) vs. time for each site into file ", filn, "..." ) ) 29 | if (makepdf) pdf( filn, width = 10, height = 6 ) 30 | for (sitename in linearfit_mid$data$mysitename){ 31 | 32 | df_tmp <- dplyr::filter(wdf, mysitename==sitename) 33 | 34 | if (nrow(df_tmp)>0 && any(!is.na(df_tmp$gpp_obs))){ 35 | 36 | par(las=1) 37 | plot( df_tmp$date, df_tmp$gpp_obs, xlab="time", ylab="GPP (gC m-2 d-1)", col=add_alpha("black", 0.5), pch=16, ylim=c( 0, max( c( df_tmp$gpp_obs, df_tmp$gpp_pmodel ), na.rm=TRUE ) ) ) 38 | lines( df_tmp$date, df_tmp$gpp_pmodel, col="grey50" ) 39 | lines( df_tmp$date, df_tmp$gpp_pmodel_I, col="springgreen3" ) 40 | lines( df_tmp$date, df_tmp$gpp_pmodel_IV, col="royalblue3" ) 41 | lines( df_tmp$date, df_tmp$gpp_pmodel_III, col="tomato" ) 42 | title( sitename ) 43 | 44 | legend( "topright", c("P-model", "corrected, approach I", "corrected, approach II", "corrected, approach III"), lty=1, bty="n", lwd=2, col=c("grey50", "springgreen3", "royalblue3", "tomato") ) 45 | legend( "topleft", c("fLUE bin (0.0-0.2)", "fLUE bin (0.2-0.3)", "fLUE bin (0.3-0.4)"), pch=16, bty="n", col=c("red", "orange", "yellow") ) 46 | 47 | with( filter(nice_agg, mysitename==sitename), points( date, inlowbin3*0.0, pch=16, col="yellow" ) ) 48 | with( filter(nice_agg, mysitename==sitename), points( date, inlowbin2*0.0, pch=16, col="orange" ) ) 49 | with( filter(nice_agg, mysitename==sitename), points( date, inlowbin1*0.0, pch=16, col="red" ) ) 50 | } 51 | } 52 | if (makepdf) dev.off() 53 | } 54 | 55 | } -------------------------------------------------------------------------------- /plot_map_siteoverview.R: -------------------------------------------------------------------------------- 1 | plot_map_siteoverview <- function( df, background, plotfiln=NA ){ 2 | 3 | require( ncdf4, quietly = TRUE ) 4 | require( fields, quietly = TRUE ) 5 | require( sp, quietly = TRUE ) 6 | require( maptools, quietly = TRUE ) 7 | require( dplyr, quietly = TRUE ) 8 | 9 | source("../utilities/mycolorbar.R") 10 | 11 | ## half degree resolution 12 | lon <- seq(-179.75, 179.75, 0.5) 13 | lat <- seq(-89.75, 89.75, 0.5) 14 | 15 | magn <- 4 16 | ncols <- 2 17 | nrows <- 1 18 | widths <- rep(1.4*magn,ncols) 19 | widths[2] <- 0.17*widths[1] 20 | heights <- rep(magn,nrows) 21 | order <- matrix( c(1,2), nrows, ncols, byrow=FALSE) 22 | 23 | ylim <- c(-60,85) 24 | lat.labels <- seq(-90, 90, 30) 25 | lat.short <- seq(-90, 90, 10) 26 | lon.labels <- seq(-180, 180, 60) 27 | lon.short <- seq(-180, 180, 10) 28 | 29 | a <- sapply( lat.labels, function(x) bquote(.(x)*degree ~ N) ) 30 | b <- sapply( lon.labels, function(x) bquote(.(x)*degree ~ E) ) 31 | 32 | if (!is.na(plotfiln)) pdf( plotfiln, width=sum(widths), height=sum(heights) ) 33 | 34 | panel <- layout( 35 | order, 36 | widths=widths, 37 | heights=heights, 38 | TRUE 39 | ) 40 | # layout.show( panel ) 41 | 42 | ## Color key 43 | par( mar=c(3,3,1,1),xaxs="i", yaxs="i",las=1) 44 | color <- rev( c( "royalblue3", "wheat", "tomato" )) 45 | # color <- rev( c( "royalblue4","royalblue2", "wheat", "tomato2", "tomato4" )) 46 | lev <- c(0,0.2,0.3,0.4,0.6,0.7,1,1.3,1.6,2,2.5,3) 47 | out.mycolorbar <- mycolorbar( color, lev, orient="v", plot=FALSE, maxval=150 ) 48 | 49 | par( mar=c(3,3,1,1),xaxs="i", yaxs="i",las=1) 50 | image( 51 | seq(-179.75, 179.75, 0.5), seq(-89.75, 89.75, 0.5), 52 | background, 53 | ylim=c(-60,85), 54 | # zlim=range(lev), 55 | yaxt="n", xaxt="n", 56 | col=out.mycolorbar$colors, breaks=out.mycolorbar$margins 57 | ) 58 | map( add=TRUE, interior=FALSE, resolution=0, lwd=0.5 ) 59 | 60 | axis( 2, at=lat.labels, lab=do.call(expression,a), cex.axis=0.7, lwd=1.5 ) 61 | axis( 2, at=lat.short, lab=F, lwd=1, tck=-0.01 ) 62 | 63 | axis( 4, at=lat.labels, lab=F, lwd=1.5 ) 64 | axis( 4, at=lat.short, lab=F, lwd=1, tck=-0.01 ) 65 | 66 | axis( 1, at=lon.labels, lab=do.call(expression,b), cex.axis=0.7, lwd=1.5 ) 67 | axis( 1, at=lon.short, lab=F, lwd=1, tck=-0.01 ) 68 | 69 | axis( 3, at=lon.labels, lab=F, lwd=1.5 ) 70 | axis( 3, at=lon.short, lab=F, lwd=1, tck=-0.01 ) 71 | 72 | # growtype <- list( herb=c("GRA", "CRO"), sav=c("SAV", "WSA"), shrub=c("OSH", "CSH"), woody_dec=c("MF", "DBF"), woody_evg=c("ENF", "EBF"), wet=c("WET") ) 73 | 74 | ## Sites used for the analysis 75 | with( dplyr::filter( df, group==2 ), points( lon, lat, col='black', pch=19, cex=0.5 ) ) 76 | with( dplyr::filter( df, group==1 ), points( lon, lat, col='black', pch=21, bg='springgreen2', cex=0.9 ) ) 77 | 78 | # ## Sites not used for the analysis 79 | # with( dplyr::filter( df, !(used) ), points( lon, lat, col='red', pch=4, cex=0.8 ) ) 80 | 81 | # legend( "left", c("Selected sites", "Not selected sites" ), pch=c( 21, 4 ), bty="n", col=c( "black", "red" ), pt.bg=c( "springgreen", "black" ), cex=1.2, box.col="white" ) 82 | 83 | out.mycolorbar <- mycolorbar( color, lev, orient="v", plot=TRUE, maxval=150 ) 84 | 85 | 86 | if (!is.na(plotfiln)) dev.off() 87 | 88 | } 89 | 90 | 91 | 92 | 93 | 94 | -------------------------------------------------------------------------------- /get_fluxdata_fluxnet2015.R: -------------------------------------------------------------------------------- 1 | get_fluxdata_fluxnet2015 <- function( path, add_swcvars=FALSE ){ 2 | ##-------------------------------------------------------------------- 3 | ## Function returns a dataframe containing all the data of flux-derived 4 | ## GPP for the station implicitly given by path (argument). 5 | ## Specific for FLUXNET 2015 data 6 | ## Returns variables in the following units: 7 | ## temp: deg C 8 | ## vpd : Pa 9 | ## prec: mm d-1 10 | ## nrad: J m-2 d-1 11 | ## swin: J m-2 d-1 12 | ## ppfd: mol m-2 d-1 13 | ##-------------------------------------------------------------------- 14 | require(dplyr) 15 | require(lubridate) 16 | 17 | source("clean_fluxnet.R") 18 | 19 | # ## xxx debug ------------- 20 | # path = "/Users/benjaminstocker/data/FLUXNET-2015_Tier1/20160128/point-scale_none_1d/original/unpacked/FLX_AR-SLu_FLUXNET2015_FULLSET_DD_2009-2011_1-3.csv" 21 | # add_swcvars = TRUE 22 | # ## ----------------------- 23 | 24 | ## from flux to energy conversion, umol/J (Meek et al., 1984), same as used in SPLASH (see Eq.50 in spash_doc.pdf) 25 | kfFEC <- 2.04 26 | 27 | ## molar mass of C 28 | c_molmass <- 12.0107 29 | 30 | ## get data 31 | ddf <- read_csv( path, na="-9999", col_types = cols() ) %>% 32 | mutate( date = ymd( TIMESTAMP ) ) 33 | 34 | ## convert units. given in umolCO2 m-2 s-1. converted to gC m-2 d-1 35 | ddf <- ddf %>% mutate( 36 | GPP_NT_VUT_REF = as.numeric(GPP_NT_VUT_REF) * 1e-6 * 60 * 60 * 24 * c_molmass, 37 | GPP_NT_VUT_USTAR50 = as.numeric(GPP_NT_VUT_USTAR50) * 1e-6 * 60 * 60 * 24 * c_molmass, 38 | GPP_DT_VUT_REF = as.numeric(GPP_DT_VUT_REF) * 1e-6 * 60 * 60 * 24 * c_molmass, 39 | GPP_DT_VUT_USTAR50 = as.numeric(GPP_DT_VUT_USTAR50) * 1e-6 * 60 * 60 * 24 * c_molmass, 40 | LE_F_MDS = as.numeric(LE_F_MDS) * 60 * 60 * 24 ## W m-2 -> J m-2 d-1 41 | ) 42 | 43 | ## clean data 44 | out_clean <- clean_fluxnet_gpp( ddf$GPP_NT_VUT_REF, ddf$GPP_DT_VUT_REF, ddf$NEE_VUT_REF_NIGHT_QC, ddf$NEE_VUT_REF_DAY_QC, cutoff=0.5 ) 45 | ddf$GPP_NT_VUT_REF <- out_clean$gpp_nt 46 | ddf$GPP_DT_VUT_REF <- out_clean$gpp_dt 47 | 48 | ddf$LE_F_MDS_good <- clean_fluxnet_et( ddf$LE_F_MDS, ddf$LE_F_MDS_QC, cutoff=0.5 ) 49 | ddf$LE_F_MDS <- clean_fluxnet_et( ddf$LE_F_MDS, ddf$LE_F_MDS_QC, cutoff=0.2 ) 50 | 51 | 52 | if (add_swcvars){ 53 | 54 | full <- ddf 55 | ddf <- ddf %>% dplyr::select( date, GPP_NT_VUT_REF, GPP_NT_VUT_USTAR50, GPP_DT_VUT_REF, GPP_DT_VUT_USTAR50, LE_F_MDS, LE_F_MDS_good ) 56 | 57 | ## collect additional SWC variables for different depths provided for each site 58 | ddf_swc <- full %>% dplyr::select( date ) 59 | relevant <- names(full)[(is.element( substr(names(full), start=1, stop=3), "SWC" ))] 60 | swcvars <- relevant[ which( !substr( relevant, start=nchar(relevant)-1, stop=nchar(relevant) )=="QC") ] 61 | swcqcvars <- relevant[ which( substr( relevant, start=nchar(relevant)-1, stop=nchar(relevant) )=="QC") ] 62 | if (length(swcvars)>0){ 63 | for (ivar in 1:length(swcvars)){ 64 | ddf_swc[[ swcvars[ivar] ]] <- clean_fluxnet_swc( full[[ swcvars[ivar] ]], full[[ swcqcvars[ivar] ]] ) 65 | } 66 | } 67 | out <- list( obs=ddf, obs_swc=ddf_swc ) 68 | 69 | } else { 70 | 71 | ddf <- ddf %>% dplyr::select( date, GPP_NT_VUT_REF, GPP_NT_VUT_USTAR50, GPP_DT_VUT_REF, GPP_DT_VUT_USTAR50, LE_F_MDS, LE_F_MDS_good ) 72 | out <- list( obs=ddf, obs_swc=NA ) 73 | 74 | } 75 | 76 | return( out ) 77 | } -------------------------------------------------------------------------------- /plot_ahlstroem.R: -------------------------------------------------------------------------------- 1 | library(ncdf4) 2 | library(abind) 3 | 4 | source("get_ahlstroem_f.R") 5 | source("../utilities/plot_map.R") 6 | 7 | 8 | get_stocker_f <- function( eff, anom, isabs=FALSE ){ 9 | ##--------------------------------------------------- 10 | ## requires as input a 3D effay with lon x lat x time 11 | ## and values being annual detrended anomalies 12 | ## index quantifies the degree to which each gridcell contributes to the global signal 13 | ##--------------------------------------------------- 14 | 15 | ## use gridcell total not per unit area 16 | if (isabs==FALSE){ 17 | source( "integrate_gridcell.R" ) 18 | 19 | eff_abs <- integrate_gridcell( eff, global=FALSE, overwrite=TRUE ) 20 | anom_abs <- integrate_gridcell( anom, global=FALSE, overwrite=TRUE ) 21 | 22 | eff_glob <- apply( eff_abs, c(3), FUN=sum, na.rm=TRUE ) 23 | anom_glob <- apply( anom_abs, c(3), FUN=sum, na.rm=TRUE ) 24 | } else { 25 | 26 | eff_abs <- eff 27 | eff_glob <- apply( eff_abs, c(3), FUN=sum, na.rm=TRUE ) 28 | anom_glob <- apply( anom_abs, c(3), FUN=sum, na.rm=TRUE ) 29 | } 30 | 31 | stocker_f <- eff[,,1] 32 | stocker_f[] <- NA 33 | for (ilon in seq(dim(eff)[1])){ 34 | for (ilat in seq(dim(eff)[2])){ 35 | if (!is.na(eff[ilon,ilat,1])){ 36 | # ## version 1 37 | # stocker_f[ilon,ilat] <- sum( eff_abs[ilon,ilat,] * abs( anom_glob ) / eff_glob ) / sum( abs( anom_glob ) ) 38 | 39 | ## version 2 40 | stocker_f[ilon,ilat] <- sum( eff_abs[ilon,ilat,] * abs( anom_glob ) / anom_glob ) / sum( abs( anom_glob ) ) 41 | } 42 | } 43 | } 44 | return( stocker_f ) 45 | } 46 | 47 | 48 | filpath_detr <- c( paste0( myhome, "/data/pmodel_fortran_output/v2/gpp_pmodel_s0_DETR.nc"), 49 | paste0( myhome, "/data/pmodel_fortran_output/v2/gpp_pmodel_s1a_DETR.nc"), 50 | paste0( myhome, "/data/pmodel_fortran_output/v2/gpp_pmodel_s1b_DETR.nc"), 51 | paste0( myhome, "/data/pmodel_fortran_output/v2/gpp_pmodel_s1c_DETR.nc") 52 | ) 53 | 54 | modl <- c( "Pmodel_S0", "Pmodel_S1a", "Pmodel_S1b", "Pmodel_S1c") 55 | 56 | detr <- list() 57 | for (idx in seq(length(modl))){ 58 | 59 | ## Read detrended GPP for IAV 60 | if (file.exists(filpath_detr[idx])){ 61 | 62 | ## read file 63 | nc <- nc_open( filpath_detr[idx] ) 64 | detr[[ modl[idx] ]] <- try( ncvar_get( nc, varid="gpp" ) ) 65 | nc_close(nc) 66 | 67 | } 68 | 69 | } 70 | 71 | ## get difference 72 | detr[[ "diffa" ]] <- detr[[ "Pmodel_S0" ]] - detr[[ "Pmodel_S1a" ]] 73 | detr[[ "diffb" ]] <- detr[[ "Pmodel_S0" ]] - detr[[ "Pmodel_S1b" ]] 74 | detr[[ "diffc" ]] <- detr[[ "Pmodel_S0" ]] - detr[[ "Pmodel_S1c" ]] 75 | 76 | ## get ahlstroem-f 77 | # ahlstroem_fa <- get_ahlstroem_f( detr$diffa, isabs=FALSE ) 78 | ahlstroem_fb <- get_ahlstroem_f( detr$diffb, isabs=FALSE ) 79 | # ahlstroem_fc <- get_ahlstroem_f( detr$diffc, isabs=FALSE ) 80 | 81 | ahlstroem_f <- abind( ahlstroem_fa, ahlstroem_fb, ahlstroem_fc, along = 3 ) %>% 82 | apply( c(1,2), FUN = mean ) 83 | 84 | par( mgp=c(3,1,0) ) 85 | 86 | plot_map( ahlstroem_fb*1e4, lev=seq(-2.5,2.5,0.5), positive=FALSE, maxval=4, file="fig/map_ahlstroem_gpploss.pdf" ) # 87 | 88 | # ## version 1 89 | # stocker_fb <- get_stocker_f( detr$diffb, detr$Pmodel_S0, isabs=FALSE ) 90 | # plot_map( stocker_fb*1e4, lev=seq(-5,5,0.5), positive=FALSE, maxval=30, minval=-30, file="fig/map_stocker_gpploss.pdf" ) # 91 | 92 | ## version 2 93 | stocker_fb <- get_stocker_f( detr$diffb, detr$Pmodel_S1b, isabs=FALSE ) 94 | plot_map( stocker_fb*1e4, lev=seq(-0.5,0.5,0.1), positive=FALSE, maxval=30, minval=-30, file="fig/map_stocker_gpploss.pdf" ) # 95 | 96 | 97 | 98 | -------------------------------------------------------------------------------- /map_effects_gpp_relvar.R: -------------------------------------------------------------------------------- 1 | library(ncdf4) 2 | library(RColorBrewer) 3 | library( ncdf4, quietly = TRUE ) 4 | library( fields, quietly = TRUE ) 5 | library( sp, quietly = TRUE ) 6 | library( maptools, quietly = TRUE ) 7 | library( dplyr, quietly = TRUE ) 8 | 9 | source("../utilities/myboxplot.R") 10 | source("plot_map.R") 11 | 12 | ## file name for figure 13 | filn <- "fig/map_gpp_relvar_diff.pdf" 14 | 15 | ##------------------------------------------------------------------------ 16 | ## GPP interannual relative variance change 17 | ##------------------------------------------------------------------------ 18 | fil_s0 <- "gpp_pmodel_s0_RELVAR.nc" 19 | fil_s1 <- "gpp_pmodel_s1_RELVAR.nc" 20 | fil_s1a <- "gpp_pmodel_s1a_RELVAR.nc" 21 | fil_s1b <- "gpp_pmodel_s1b_RELVAR.nc" 22 | fil_s1c <- "gpp_pmodel_s1c_RELVAR.nc" 23 | 24 | dir <- paste0( myhome, "/data/pmodel_fortran_output/v2/") 25 | 26 | ## S0 27 | nc <- nc_open( paste0( dir, fil_s0 ) ) 28 | gpp_s0 <- ncvar_get( nc, varid="gpp" ) 29 | lon <- nc$dim$lon$vals 30 | lat <- nc$dim$lat$vals 31 | time <- nc$dim$time$vals 32 | nc_close(nc) 33 | 34 | # ## S1 35 | # nc <- nc_open( paste0( dir, fil_s1 ) ) 36 | # gpp_s1 <- ncvar_get( nc, varid="gpp" ) 37 | # nc_close(nc) 38 | # 39 | # ## S1a 40 | # nc <- nc_open( paste0( dir, fil_s1a ) ) 41 | # gpp_s1a <- ncvar_get( nc, varid="gpp" ) 42 | # nc_close(nc) 43 | 44 | ## S1b 45 | nc <- nc_open( paste0( dir, fil_s1b ) ) 46 | gpp_s1b <- ncvar_get( nc, varid="gpp" ) 47 | nc_close(nc) 48 | 49 | # ## S1c 50 | # nc <- nc_open( paste0( dir, fil_s1c ) ) 51 | # gpp_s1c <- ncvar_get( nc, varid="gpp" ) 52 | # nc_close(nc) 53 | 54 | ## calculate amplification factor (field) 55 | ampl <- gpp_s1b / gpp_s0 56 | 57 | # ##----------------------------------------------------- 58 | # ## Plot relative variance in S1 59 | # ##----------------------------------------------------- 60 | # # plot_map( gpp_s1b / gpp_s0, lev=c( 0, 4, 10 ), 61 | # # toplefttext=expression(paste("Amplification of GPP relative variance")), 62 | # # toprighttext=expression(paste("fraction")), 63 | # # maxval = 35, positive = FALSE, color = c( "royalblue4", "wheat", "tomato2", "tomato4" ) 64 | # # ) 65 | 66 | # plot_map( gpp_s1b - gpp_s0, lev=c( -5, 15, 10 ), 67 | # toplefttext=expression(paste("Difference in GPP relative variance")), 68 | # toprighttext=expression(paste("unitless")), 69 | # maxval = 35, positive = FALSE, color = c( "royalblue4", "wheat", "tomato2", "tomato4" ) 70 | # ) 71 | 72 | # plot_map( gpp_s1b - gpp_s0, lev=c( -7, 13, 10 ), 73 | # toplefttext=expression(paste("Difference in GPP relative variance")), 74 | # toprighttext=expression(paste("unitless")), 75 | # maxval = 35, positive = FALSE, color = c( "royalblue4", "wheat", "tomato2", "tomato4" ) 76 | # ) 77 | 78 | # ## Density distribution of relative variance in s0 and s1b 79 | # hist( gpp_s0, xlim=c(0,40), breaks=300, col=rgb(0,0,0,0.3) ) 80 | # hist( gpp_s1b, breaks=300, col=rgb(1,0,0,0.3), add=TRUE ) 81 | 82 | 83 | # hist(ampl, xlim=c(0,10), breaks=300) 84 | # abline(v=1, col="red") 85 | 86 | ## Analyse distribution factor vs. aridity (mean annual AET/PET) 87 | ncfiln <- "../data/greve/ep_over_p_cru_ncep.nc" 88 | if (!file.exists(ncfiln)) { 89 | epop <- array( 1, dim=c(720,360) ) 90 | } else { 91 | nc <- nc_open( ncfiln ) 92 | epop <- ncvar_get( nc, varid="EP_OVER_P_CRU_NCEP" ) 93 | } 94 | alpha <- 1/epop 95 | 96 | # hist( 1/epop, xlim=c(1,5), breaks = 3000 ) 97 | 98 | df_pixels <- tibble( ampl = c(ampl), alpha = c(alpha) ) %>% 99 | filter( !is.na(ampl) & !is.na(alpha) ) %>% 100 | mutate( inbin = cut( alpha, breaks = c(0, 0.05, 0.2, 0.5, 0.7, 1.3, 3) ) ) 101 | 102 | 103 | -------------------------------------------------------------------------------- /analyse_modobs.R: -------------------------------------------------------------------------------- 1 | analyse_modobs <- function( mod, obs, 2 | plot.fil=NA, 3 | plot.xlab="observed", 4 | plot.ylab="modelled", 5 | xlim=NA, 6 | ylim=NA, 7 | plot.title=NA, 8 | plot.col=NA, 9 | do.plot=TRUE, 10 | plot.linmod=TRUE, 11 | corner="bottomright", 12 | lab.xpos=0.75, 13 | lab.ypos=0.75, 14 | ... ){ 15 | 16 | .libPaths( c( .libPaths(), "/home/bstocker/R/x86_64-pc-linux-gnu-library/3.3") ) 17 | 18 | syshome <- Sys.getenv( "HOME" ) 19 | source( paste( syshome, "/.Rprofile", sep="" ) ) 20 | 21 | library(Metrics) 22 | library(hydroGOF) 23 | library(LSD) 24 | 25 | ## get statistics 26 | idxs <- which(!is.na(mod) & !is.na(obs)) 27 | numb <- sum(!is.na(obs)) 28 | rmse <- Metrics::rmse( obs[idxs], mod[idxs] ) 29 | prmse <- 100 * rmse / mean( obs, na.rm = TRUE ) 30 | linmod <- lm( mod ~ obs ) 31 | # rsq <- summary( linmod )$r.squared 32 | rsq <- summary( linmod )$adj.r.squared 33 | nse <- hydroGOF::NSE( mod, obs, na.rm=TRUE ) 34 | # pbias <- sum( mod[idxs] - obs[idxs] ) / sum( obs[idxs] ) 35 | pbias <- mean( (mod[idxs] - obs[idxs]) / obs[idxs] ) 36 | ptoohi <- sum( mod[idxs] > obs[idxs] ) / length( idxs ) 37 | # pbias <- hydroGOF::p( mod, obs, na.rm=TRUE ) 38 | 39 | ## plot 40 | if (do.plot){ 41 | 42 | if (!is.na(plot.fil)){ 43 | pdf( plot.fil, width=6, height=6 ) 44 | } 45 | 46 | par( las=1, mar=c(4.5,4.5,3,2) ) 47 | 48 | if (is.na(xlim)) xlim <- c( min(range(mod, na.rm=TRUE)[1], range(obs, na.rm=TRUE)[1]), max(range(mod, na.rm=TRUE)[2], range(obs, na.rm=TRUE)[2]) ) 49 | if (is.na(ylim)) ylim <- xlim 50 | 51 | heatscatter( 52 | obs, 53 | mod, 54 | main="", 55 | xlim=xlim, 56 | ylim=ylim, 57 | xlab=plot.xlab, 58 | ylab=plot.ylab, 59 | ... 60 | ) 61 | abline( c(0,0), c(1,1), col="red" ) 62 | if (plot.linmod) abline( linmod, col="red", lty=2 ) 63 | 64 | # mtext( paste( "RMSE =", format( rmse, digits = 3 ) ), side=3, line=0, cex=1.0, adj=0.0 ) 65 | # mtext( bquote( R^2 == .(format( rsq, digits = 3) ) ), side=3, line=1, cex=1.0, adj=0.0 ) 66 | # mtext( paste( "NSE =", format( nse, digits = 3 ) ), side=3, line=2, cex=1.0, adj=0.0 ) 67 | # mtext( paste( "N =", format( sum(!is.na(obs)), digits = 1 ) ), side=3, line=0, cex=1.0, adj=1.0 ) 68 | 69 | if (corner=="bottomright"){ 70 | x0 <- lab.xpos*xlim[2] 71 | y0 <- seq(1, 5, 1) * (ylim[2]-ylim[1]) * 0.06 72 | } else if (corner=="topleft"){ 73 | x0 <- 0.05*xlim[2] 74 | y0 <- lab.ypos*(ylim[2]-ylim[1])+ylim[1] 75 | } 76 | 77 | text( x0, y0[1], paste( "bias =", format( pbias, digits = 3 ), "%" ), adj=0.0, cex=0.8 ) 78 | text( x0, y0[2], paste( "RMSE =", format( rmse, digits = 2 ), " (", format( prmse, digits = 2 ), "%)", sep="" ), adj=0.0, cex=0.8 ) 79 | text( x0, y0[3], bquote( italic(R)^2 == .(format( rsq, digits = 2) ) ), adj=0.0, cex=0.8 ) 80 | text( x0, y0[4], paste( "NSE =", format( nse, digits = 2 ) ), adj=0.0, cex=0.8 ) 81 | text( x0, y0[5], paste( "N =", format( numb, digits = 1 ) ), adj=0.0, cex=0.8 ) 82 | 83 | title( plot.title, cex.main=0.9, font=1 ) 84 | if (!is.na(plot.fil)){ 85 | dev.off() 86 | } 87 | } 88 | 89 | ## return statistics 90 | out <- list( rmse=rmse, linmod=linmod, rsq=rsq, nse=nse, prmse=prmse, pbias=pbias, ptoohi=ptoohi, N=numb ) 91 | return( out ) 92 | } 93 | -------------------------------------------------------------------------------- /complement_all.R: -------------------------------------------------------------------------------- 1 | complment_all <- function( linearfit ){ 2 | 3 | source("compl_df_flue_est.R") 4 | 5 | x0_fix = 0.9 6 | 7 | ## complementing 'data/nice_nn_agg_lue_obs_evi.Rdata' 8 | load( "data/nice_nn_agg_lue_obs_evi.Rdata" ) # loads 'nice_agg' 9 | nice_agg <- compl_df_flue_est( nice_agg, linearfit, x0_fix=x0_fix ) 10 | save( nice_agg, file="data/nice_nn_agg_lue_obs_evi_L2.Rdata" ) 11 | 12 | ## complementing 'data/nice_nn_agg_lue_obs_evi.Rdata' 13 | load( "data/nice_nn_modis_agg_lue_obs_evi.Rdata" ) # loads 'modis_agg' 14 | modis_agg <- compl_df_flue_est( modis_agg, linearfit, x0_fix=x0_fix ) 15 | save( modis_agg, file="data/nice_nn_modis_agg_lue_obs_evi_L2.Rdata" ) 16 | 17 | ## complementing 'data/nice_nn_modis_agg_lue_obs_evi.Rdata' 18 | load( "data/nice_nn_mte_agg_lue_obs_evi.Rdata" ) # loads 'mte_agg' 19 | mte_agg <- compl_df_flue_est( mte_agg, linearfit, x0_fix=x0_fix ) 20 | save( mte_agg, file="data/nice_nn_mte_agg_lue_obs_evi_L2.Rdata" ) 21 | 22 | ## complementing 'data/nice_nn_agg_lue_obs_evi.Rdata' 23 | load( "data/nice_all_agg_lue_obs_evi.Rdata" ) # loads 'nice_agg' 24 | nice_agg <- compl_df_flue_est( nice_agg, linearfit, x0_fix=x0_fix ) 25 | save( nice_agg, file="data/nice_all_agg_lue_obs_evi_L2.Rdata" ) 26 | 27 | ## complementing 'data/nice_all_agg_lue_obs_evi.Rdata' 28 | load( "data/nice_all_modis_agg_lue_obs_evi.Rdata" ) # loads 'modis_agg' 29 | modis_agg <- compl_df_flue_est( modis_agg, linearfit, x0_fix=x0_fix ) 30 | save( modis_agg, file="data/nice_all_modis_agg_lue_obs_evi_L2.Rdata" ) 31 | 32 | ## complementing 'data/nice_all_modis_agg_lue_obs_evi.Rdata' 33 | load( "data/nice_all_mte_agg_lue_obs_evi.Rdata" ) # loads 'mte_agg' 34 | mte_agg <- compl_df_flue_est( mte_agg, linearfit, x0_fix=x0_fix ) 35 | save( mte_agg, file="data/nice_all_mte_agg_lue_obs_evi_L2.Rdata" ) 36 | 37 | 38 | # ## complementing 'data/nice_all_modis_agg_lue_obs_evi.Rdata' 39 | # load( "data/data_aligned_agg.Rdata" ) # loads 'mte_agg' 40 | # df_dday_agg <- compl_df_flue_est( df_dday_agg, linearfit, x0_fix=x0_fix ) 41 | # df_dday_modis_agg <- compl_df_flue_est( df_dday_modis_agg, linearfit, x0_fix=x0_fix ) 42 | # df_dday_mte_agg <- compl_df_flue_est( df_dday_mte_agg, linearfit, x0_fix=x0_fix ) 43 | # save( df_dday_agg, df_dday_modis_agg, df_dday_mte_agg, df_dday_aggbydday_agg, file="data/data_aligned_agg_L2.Rdata" ) 44 | 45 | 46 | ## complement nice files 47 | files <- list.files("data", pattern = "nice_nn_*") 48 | files <- files[-grep("L2", files, fixed=TRUE )] 49 | files <- files[-grep("agg_lue_obs_evi", files, fixed=TRUE )] 50 | 51 | files2 <- list.files("data", pattern = "nice_all_*") 52 | files2 <- files2[-grep("L2", files2, fixed=TRUE )] 53 | files2 <- files2[-grep("agg_lue_obs_evi", files2, fixed=TRUE )] 54 | 55 | files <- c( files, files2 ) 56 | 57 | for (ifil in files){ 58 | 59 | load( paste0( "data/", ifil ) ) 60 | nice <- compl_df_flue_est( nice, linearfit, x0_fix=x0_fix ) 61 | save( nice, file=paste0( "data/", ifil ) ) 62 | 63 | } 64 | 65 | ## complement modis files 66 | files <- list.files("data", pattern = "modis_*") 67 | files <- files[-grep("df_dday", files, fixed=TRUE )] 68 | files <- files[-grep("nice", files, fixed=TRUE )] 69 | 70 | for (ifil in files){ 71 | 72 | load( paste0( "data/", ifil ) ) 73 | nice_to_modis <- compl_df_flue_est( nice_to_modis, linearfit, x0_fix=x0_fix ) 74 | save( nice_to_modis, file=paste0( "data/", ifil ) ) 75 | 76 | } 77 | 78 | 79 | ## complement mte files 80 | files <- list.files("data", pattern = "mte_*") 81 | files <- files[-grep("df_dday", files, fixed=TRUE )] 82 | files <- files[-grep("nice", files, fixed=TRUE )] 83 | 84 | for (ifil in files){ 85 | 86 | load( paste0( "data/", ifil ) ) 87 | nice_to_mte <- compl_df_flue_est( nice_to_mte, linearfit, x0_fix=x0_fix ) 88 | save( nice_to_mte, file=paste0( "data/", ifil ) ) 89 | 90 | } 91 | 92 | } -------------------------------------------------------------------------------- /plot_map.R: -------------------------------------------------------------------------------- 1 | plot_map <- function( arr, lev, file=NA, positive=TRUE, toplefttext=NA, toprighttext=NA, minval=NA, maxval=NA, color=NA, stippling = NA ){ 2 | 3 | require( ncdf4, quietly = TRUE ) 4 | require( fields, quietly = TRUE ) 5 | require( sp, quietly = TRUE ) 6 | require( maptools, quietly = TRUE ) 7 | require( dplyr, quietly = TRUE ) 8 | 9 | if ( dim(arr)[1]==720 && dim(arr)[2]==360 ){ 10 | 11 | ## half degree resolution 12 | lon <- seq(-179.75, 179.75, 0.5) 13 | lat <- seq(-89.75, 89.75, 0.5) 14 | 15 | } else if ( dim(arr)[1]==360 && dim(arr)[2]==180 ){ 16 | 17 | ## one degree resolution 18 | lon <- seq(-179.5, 179.5, 1.0 ) 19 | lat <- seq(-89.5, 89.5, 1.0 ) 20 | 21 | } 22 | 23 | magn <- 4 24 | ncols <- 2 25 | nrows <- 1 26 | widths <- rep(1.4*magn,ncols) 27 | widths[2] <- 0.17*widths[1] 28 | heights <- rep(magn,nrows) 29 | order <- matrix( c(1,2), nrows, ncols, byrow=FALSE) 30 | 31 | ylim <- c(-60,85) 32 | lat.labels <- seq(-90, 90, 30) 33 | lat.short <- seq(-90, 90, 10) 34 | lon.labels <- seq(-180, 180, 60) 35 | lon.short <- seq(-180, 180, 10) 36 | 37 | a <- sapply( lat.labels, function(x) if (x>0) {bquote(.(x)*degree ~N)} else if (x==0) {bquote(.(x)*degree)} else {bquote(.(-x)*degree ~S)} ) 38 | b <- sapply( lon.labels, function(x) if (x>0) {bquote(.(x)*degree ~E)} else if (x==0) {bquote(.(x)*degree)} else {bquote(.(-x)*degree ~W)}) 39 | 40 | if (!is.na(file)) pdf( file, width=sum(widths), height=sum(heights) ) 41 | 42 | panel <- layout( 43 | order, 44 | widths=widths, 45 | heights=heights, 46 | TRUE 47 | ) 48 | # layout.show( panel ) 49 | 50 | ## Color key 51 | if (identical(color,NA)){ 52 | if (positive){ 53 | color <- c( "wheat", "tomato2", "tomato4" ) 54 | } else { 55 | color <- c( "royalblue4", "royalblue2", "wheat", "tomato2", "tomato4" ) 56 | } 57 | } 58 | 59 | # lev <- c( 0, 0.5, 0.7, 0.8, 0.9, 0.95, 1, 1.01, 1.02, 1.05, 1.1, 1.2, 1.5, 2, 999 ) 60 | # lev <- seq(-2,2,0.2) 61 | # lev <- c( 0, 0.2, 0.4, 0.6, 0.8, 0.9, 1, 1.1, 1.2, 1.5, 2, 3, 999 ) 62 | 63 | out.mycolorbar <- mycolorbar( color, lev, orient="v", plot=FALSE, maxval=maxval, minval=minval ) 64 | 65 | par( mar=c(3,3,3,1),xaxs="i", yaxs="i",las=1) 66 | image( 67 | lon, lat, 68 | arr, 69 | ylim=c(-60,85), 70 | # zlim=range(lev), 71 | yaxt="n", xaxt="n", 72 | col=out.mycolorbar$colors, breaks=out.mycolorbar$margins, 73 | xlab="", ylab="" 74 | ) 75 | map( add=TRUE, interior=FALSE, resolution=0, lwd=0.5 ) 76 | 77 | axis( 2, at=lat.labels, lab=do.call(expression,a), cex.axis=0.7, lwd=1.5 ) 78 | axis( 2, at=lat.short, lab=F, lwd=1, tck=-0.01 ) 79 | 80 | axis( 4, at=lat.labels, lab=F, lwd=1.5 ) 81 | axis( 4, at=lat.short, lab=F, lwd=1, tck=-0.01 ) 82 | 83 | axis( 1, at=lon.labels, lab=do.call(expression,b), cex.axis=0.7, lwd=1.5 ) 84 | axis( 1, at=lon.short, lab=F, lwd=1, tck=-0.01 ) 85 | 86 | axis( 3, at=lon.labels, lab=F, lwd=1.5 ) 87 | axis( 3, at=lon.short, lab=F, lwd=1, tck=-0.01 ) 88 | 89 | if (!is.na(toplefttext)) mtext( toplefttext, line=1, adj=0 ) 90 | if (!is.na(toprighttext)) mtext( toprighttext, line=1, adj=1 ) 91 | 92 | ## Add stippling (taken from https://stackoverflow.com/questions/11736996/adding-stippling-to-image-contour-plot) 93 | if (!identical(stippling, NA)){ 94 | incl <- which( stippling == 1 ) 95 | grd <- expand.grid( x=lon, y=lat ) 96 | incl <- incl[ seq(4,length(incl), by=4) ] 97 | points( grd$x[incl], grd$y[incl], pch=".", cex=1 ) 98 | } 99 | 100 | 101 | ## Color key 102 | par( mar=c(3,3,3,1),xaxs="i", yaxs="i",las=1) 103 | out.mycolorbar <- mycolorbar( color, lev, orient="v", plot=TRUE, maxval=maxval, minval=minval ) 104 | 105 | if (!is.na(file)) dev.off() 106 | 107 | } -------------------------------------------------------------------------------- /plot_linearfit2.R: -------------------------------------------------------------------------------- 1 | plot_linearfit2 <- function( linearfit2, linearfit, target="fvar", df=NULL ){ 2 | 3 | require(dplyr) 4 | 5 | ## merge vegetation class info into data frame 6 | load( "../nn_fluxnet2015/data/overview_data_fluxnet2015_L1.Rdata" ) # loads 'overview' 7 | linearfit$data <- linearfit$data %>% left_join( dplyr::select( overview, mysitename, classid ), by="mysitename" ) 8 | 9 | growtype <- list( herb=c("GRA", "CRO"), sav=c("SAV", "WSA"), shrub=c("OSH", "CSH"), woody_dec=c("MF", "DBF"), woody_evg=c("ENF", "EBF"), wet=c("WET") ) 10 | 11 | ##----------------------------------------------- 12 | ## Plot scatter plot: fLUE0 vs. alpha (one point per site) 13 | ##----------------------------------------------- 14 | par( las=1 ) 15 | with( linearfit$data, plot( meanalpha, y0, pch=16, xlab="AET/PET", ylab=expression(paste("fLUE"[0])), xlim=c(0,1.1), type="n" ) ) 16 | abline( linearfit$linmod, col="black", lty=2 ) 17 | abline( linearfit2$linmod, col="black" ) 18 | 19 | mtext( line=-1.5, bquote( italic(R)^2 == .(format( summary( linearfit2$linmod )$r.squared, digits = 2) ) ), adj=0.1, cex=1 ) 20 | cf <- coef(linearfit2$linmod) %>% round( 2 ) 21 | eq <- paste0( "y = ", cf[1], ifelse(sign(cf[2])==1, " + ", " - "), abs(cf[2]), " x " ) 22 | mtext( line=-2.5, eq, adj=0.1 ) 23 | 24 | ## herbaceous 25 | with( dplyr::filter( linearfit$data, classid %in% (growtype$herb) ), points( meanalpha, y0, pch=16, col='black', cex=1.0 ) ) 26 | 27 | ## savannah 28 | with( dplyr::filter( linearfit$data, classid %in% (growtype$sav) ), points( meanalpha, y0, pch=18, col='black', cex=1.2 ) ) 29 | 30 | ## evergreen (woody) 31 | with( dplyr::filter( linearfit$data, classid %in% (growtype$woody_evg) ), points( meanalpha, y0, pch=17, col='black', cex=1.0 ) ) 32 | 33 | ## wetland 34 | with( dplyr::filter( linearfit$data, classid %in% (growtype$wet) ), points( meanalpha, y0, pch=25, col='black', bg='black' ) ) 35 | 36 | ## deciduous 37 | with( dplyr::filter( linearfit$data, classid %in% (growtype$woody_dec) ), points( meanalpha, y0, pch=15, col='black' ) ) 38 | 39 | ## shrublands 40 | with( dplyr::filter( linearfit$data, classid %in% (growtype$shrub) ), points( meanalpha, y0, pch=8, col='black' ) ) 41 | 42 | ## label: site name 43 | with( linearfit$data, text( meanalpha+0.02, y0, mysitename, adj=c(0,0.5), col='black', cex=0.6 ) ) 44 | 45 | ## legend 46 | legend( "bottomright", c("herbaceous", "savannah", "woody evergreen", "wetlands", "shrublands", "woody deciduous"), pch=c(16,18,17,25,8,15), bty="n", cex=0.8, inset=c(0.05,0) ) 47 | 48 | 49 | if (!is.null(df)){ 50 | filn <- "fig/fit_to_bias_plot_per_site.pdf" 51 | print( paste( "plotting fLUE vs. soil moisture for each site into file ", filn, "..." ) ) 52 | ##----------------------------------------------- 53 | ## Plot scatter plot: fLUE vs. soil moisture for each site 54 | ##----------------------------------------------- 55 | pdf( filn, width = 5, height = 4 ) 56 | for (sitename in linearfit2$data$mysitename){ 57 | 58 | df_tmp <- dplyr::filter(df, mysitename==sitename) 59 | data_tmp <- dplyr::filter( linearfit2$data, mysitename==sitename ) 60 | 61 | 62 | par(las=1) 63 | plot( df_tmp$soilm_mean, df_tmp[[ target ]], xlim=c(0,1), ylim=c(0,1.2), pch=16, xlab="soil water content (fraction)", ylab="fLUE", col=add_alpha("royalblue3", 0.2) ) 64 | abline( h=1.0, lwd=0.5 ) 65 | title( sitename ) 66 | 67 | if (!is.na(dplyr::select( data_tmp, meanalpha))){ 68 | 69 | ## Plot 1-sided curve using estimated y0 as a function of mean alpha (red) 70 | mycurve( function(x) stress_quad_1sided_alpha( x, 71 | dplyr::select( data_tmp, meanalpha), 72 | dplyr::select( data_tmp, x0), 73 | coef(linearfit2$linmod)[["(Intercept)"]], 74 | coef(linearfit2$linmod)[["meanalpha"]] 75 | ), 76 | from=0.0, to=1.0, col='red', add=TRUE, lwd=2 ) 77 | 78 | } 79 | } 80 | dev.off() 81 | } 82 | 83 | } -------------------------------------------------------------------------------- /integrate_gridcell.R: -------------------------------------------------------------------------------- 1 | integrate_gridcell <- function( arr, global=TRUE, overwrite=FALSE ){ 2 | 3 | ## get area array 4 | if ( dim(arr)[1]==720 && dim(arr)[2]==360 ){ 5 | 6 | ## half degree resolution 7 | print("found halfdegree resolution.") 8 | areafil <- paste0( myhome, "data/landmasks/area_halfdeg.nc") 9 | 10 | if (file.exists(areafil)&&!overwrite){ 11 | 12 | print("reading from file.") 13 | nc <- nc_open( areafil ) 14 | arr_area <- ncvar_get( nc, varid="area" ) 15 | nc_close( nc ) 16 | 17 | } else { 18 | 19 | dx <- 0.5 20 | dy <- 0.5 21 | lon <- seq(-179.75, 179.75, by=dx ) 22 | lat <- seq(-89.75, 89.75, by=dy ) 23 | if (length(dim(arr))==3){ 24 | arr_area <- arr[,,1] 25 | arr_tmp <- arr[,,1] 26 | } else if (length(dim(arr))==2) { 27 | arr_area <- arr 28 | arr_tmp <- arr 29 | } else { 30 | print("cannot deal with this number of dimensions") 31 | } 32 | arr_area[] <- NA 33 | for (ilon in seq(dim(arr)[1])){ 34 | for (ilat in seq(dim(arr)[2])){ 35 | if (!is.na(arr_tmp[ilon,ilat])){ 36 | arr_area[ilon,ilat] <- area( lat[ilat], dx=dx, dy=dy ) 37 | } 38 | } 39 | } 40 | cdf.write( arr_area, "area", 41 | lon, lat, 42 | filnam = areafil, 43 | nvars = 1, 44 | make.tdim = FALSE, 45 | long_name_var1 = "gridcell area", 46 | units_var1 = "m2", 47 | glob_hist = "created by soilm_global/integrate_global.R", 48 | glob_title = "gridcell area" 49 | ) 50 | } 51 | 52 | } else if ( dim(arr)[1]==360 && dim(arr)[2]==180 ){ 53 | 54 | ## one degree resolution 55 | print("found one degree resolution.") 56 | areafil <- paste0( myhome, "/data/landmasks/area_1x1deg.nc") 57 | 58 | if (file.exists(areafil)&&!overwrite){ 59 | 60 | nc <- nc_open( areafil ) 61 | arr_area <- ncvar_get( nc, varid="area" ) 62 | nc_close( nc ) 63 | 64 | } else { 65 | 66 | dx <- 1.0 67 | dy <- 1.0 68 | lon <- seq(-175.5, 175.5, dx ) 69 | lat <- seq(-89.5, 89.5, dy ) 70 | arr_area <- arr[,,1] 71 | arr_area[] <- NA 72 | for (ilon in seq(dim(arr)[1])){ 73 | for (ilat in seq(dim(arr)[2])){ 74 | if (!is.na(arr[ilon,ilat,])){ 75 | arr_area[ilon,ilat] <- area( lat[ilat], dx=dx, dy=dy ) 76 | } 77 | } 78 | } 79 | cdf.write( arr_area, "area", 80 | lon, lat, 81 | filnam = areafil, 82 | nvars = 1, 83 | make.tdim = FALSE, 84 | long_name_var1 = "gridcell area", 85 | units_var1 = "m2", 86 | glob_hist = "created by soilm_global/integrate_global.R", 87 | glob_title = "gridcell area" 88 | ) 89 | } 90 | 91 | } 92 | 93 | if (!global){ 94 | 95 | ## actually integrate 96 | if (length(dim(arr))==2){ 97 | 98 | ## 2D array 99 | out <- arr * arr_area 100 | 101 | } else if (length(dim(arr))==3){ 102 | 103 | ## 3D arry 104 | ## get global total unlimited GPP over time 105 | out <- sweep( arr, c(1,2), arr_area, "*", check.margin=FALSE ) 106 | 107 | } else { 108 | 109 | print("cannot deal with this number of dimensions") 110 | out <- NA 111 | 112 | } 113 | 114 | } else { 115 | 116 | ## actually integrate 117 | if (length(dim(arr))==2){ 118 | 119 | ## 2D array 120 | arr_abs <- arr * arr_area 121 | out <- sum( arr_abs, na.rm=TRUE ) 122 | 123 | } else if (length(dim(arr))==3){ 124 | 125 | ## 3D arry 126 | ## get global total unlimited GPP over time 127 | arr_abs <- sweep( arr, c(1,2), arr_area, "*", check.margin=FALSE ) 128 | out <- apply( arr_abs, c(3), FUN=sum, na.rm=TRUE ) 129 | 130 | # ## This is a correct application of sweep, as demonstrated below... 131 | # arr_abs_test <- arr * NA 132 | # for (itim in seq(dim(arr)[3])){ 133 | # arr_abs_test[,,itim] <- arr[,,itim] * arr_area[,] 134 | # } 135 | # print(all.equal( arr_abs, arr_abs_test )) 136 | 137 | 138 | } else { 139 | 140 | print("cannot deal with this number of dimensions") 141 | out <- NA 142 | 143 | } 144 | 145 | } 146 | 147 | return( out ) 148 | 149 | } -------------------------------------------------------------------------------- /plot_fit_vs_soilmoist.R: -------------------------------------------------------------------------------- 1 | plot_fit_vs_soilmoist <- function( linearfit_low, linearfit_mid, linearfit_strong, ddf=NULL, nice_agg=NULL, makepdf=FALSE ){ 2 | 3 | require(dplyr, quietly = TRUE, warn.conflicts = FALSE ) 4 | require(lubridate, quietly = TRUE, warn.conflicts = FALSE ) 5 | 6 | source("../utilities/add_alpha.R") 7 | source("../utilities/mycurve.R") 8 | source("stress_exp.R") 9 | source("calc_flue_est_alpha.R") 10 | source("stress_quad_1sided.R") 11 | 12 | if (!is.null(ddf)){ 13 | 14 | ##----------------------------------------------- 15 | ## Plot scatter plot: fLUE vs. soil moisture for each site 16 | ##----------------------------------------------- 17 | filn <- "fig/fit_to_bias_plot_per_site.pdf" 18 | if (makepdf) print( paste( "plotting fLUE vs. soil moisture for each site into file ", filn, "..." ) ) 19 | if (makepdf) pdf( filn, width = 5, height = 4 ) 20 | # for (sitename in linearfit_mid$data$mysitename){ 21 | for (sitename in unique(ddf$mysitename)){ 22 | 23 | df_tmp <- dplyr::filter( ddf, mysitename==sitename) 24 | data_tmp <- dplyr::filter( ddf, mysitename==sitename ) 25 | 26 | classid <- unique(df_tmp$classid) 27 | 28 | par(las=1) 29 | plot( df_tmp$soilm_mean, df_tmp[[ "fvar" ]], xlim=c(0,1), ylim=c(0,1.2), pch=16, xlab="soil water content (fraction)", ylab=expression( paste("fLUE and ", beta) ), col=add_alpha("black", 0.2) ) 30 | abline( h=1.0, lwd=0.5 ) 31 | mtext( sitename, line = 0.25, font = 2, adj = 0 ) 32 | 33 | if (!is.na(dplyr::select( data_tmp, meanalpha))){ 34 | 35 | ## Curve from approach I 36 | mycurve( function(x) calc_flue_est_alpha( x, 37 | alpha=unique(dplyr::select( data_tmp, meanalpha)), 38 | apar=coef(linearfit_low$linmod)[1], 39 | bpar=coef(linearfit_low$linmod)[2], 40 | cpar=0.125, 41 | dpar=0.75 42 | ), 43 | from=0.0, to=1.0, col='springgreen3', add=TRUE, lwd=2 ) 44 | 45 | ## Curve from approach IV (mid) 46 | mycurve( function(x) stress_quad_1sided_alpha_grasstree( x, 47 | unique(dplyr::select( data_tmp, meanalpha)), 48 | x0=0.9, 49 | c(coef(linearfit_mid$linmod_tree)[["(Intercept)"]],coef(linearfit_mid$linmod_grass)[["(Intercept)"]]), 50 | c(coef(linearfit_mid$linmod_tree)[["meanalpha"]],coef(linearfit_mid$linmod_grass)[["meanalpha"]]), 51 | classid 52 | ), 53 | from=0.0, to=1.0, col='royalblue3', add=TRUE, lwd=2 ) 54 | 55 | ## Curve from approach III (strong) 56 | mycurve( function(x) stress_quad_1sided_alpha( x, 57 | unique(dplyr::select( data_tmp, meanalpha)), 58 | x0=0.9, 59 | coef(linearfit_strong$linmod)[["(Intercept)"]], 60 | coef(linearfit_strong$linmod)[["meanalpha"]] 61 | ), 62 | from=0.0, to=1.0, col='tomato', add=TRUE, lwd=2 ) 63 | 64 | 65 | # # Curve from approach 5 66 | # mycurve( function(x) stress_exp_alpha( x, 67 | # alpha=dplyr::select( data_tmp, meanalpha), 68 | # coef(linearfit5$linmod_y0)[1], 69 | # coef(linearfit5$linmod_y0)[2], 70 | # coef(linearfit5$linmod_curve)[1], 71 | # coef(linearfit5$linmod_curve)[2] 72 | # ), 73 | # from=0.0, to=1.0, col='royalblue3', add=TRUE, lwd=2 ) 74 | 75 | 76 | legend( "bottomright", c( expression(beta[a]), expression(beta[b]), expression(beta[c]) ), lty=1, bty="n", lwd=2, col=c("springgreen3", "royalblue3", "tomato") ) 77 | 78 | } 79 | } 80 | if (makepdf) dev.off() 81 | 82 | } 83 | 84 | } -------------------------------------------------------------------------------- /plot_bias_all.R: -------------------------------------------------------------------------------- 1 | source("../utilities/myboxplot.R") 2 | 3 | siteinfo <- read.csv( "siteinfo_fluxnet2015_sofun.csv" ) 4 | 5 | ##------------------------------------------------ 6 | ## Select only sites that were in NN FLUXNET 2015 analysis 7 | ##------------------------------------------------ 8 | # Load aggregated data from all sites, created by plot_nn_fVAR_fluxnet2015.R: 9 | load( "data/nice_all_agg_lue_obs_evi.Rdata" ) # loads 'nice_agg', for open-access reproducability, use reduced dataset 'gpp_daily_fluxnet_stocker18natgeo.csv' available from Zenodo XXX instead 10 | load( "data/nice_all_8d_agg_lue_obs_evi.Rdata" ) # loads 'nice_8d', for open-access reproducability, use reduced dataset 'gpp_8daily_fluxnet_stocker18natgeo.csv' available from Zenodo XXX instead 11 | 12 | successcodes <- read.csv( "successcodes.csv" ) 13 | do.sites <- dplyr::filter( successcodes, successcode==1 | successcode==2 )$mysitename 14 | 15 | ## Use only sites where NN method worked (i.e. that had clear and identifiable soil moisture limitation) 16 | nice_agg <- nice_agg %>% filter( mysitename %in% do.sites ) 17 | nice_8d_agg <- nice_8d_agg %>% filter( mysitename %in% do.sites ) 18 | 19 | ##------------------------------------------------ 20 | ## Bin data w.r.t. alpha 21 | ##------------------------------------------------ 22 | binwidth <- 0.2 23 | alphabins <- seq( from=0, to=1, by=binwidth ) 24 | soilmbins <- seq( from=0, to=1, by=binwidth ) 25 | nice_agg <- nice_agg %>% mutate( inalphabin = cut( as.numeric(alpha), breaks = alphabins ) ) 26 | nice_8d_agg <- nice_8d_agg %>% mutate( inalphabin = cut( as.numeric(alpha), breaks = alphabins ) ) 27 | 28 | ##------------------------------------------------ 29 | ## Get bias 30 | ##------------------------------------------------ 31 | nice_8d_agg <- nice_8d_agg %>% mutate( bias_pmodel_diff = gpp_pmodel - gpp_obs, 32 | bias_modis_diff = gpp_modis - gpp_obs, 33 | bias_vpm_diff = gpp_vpm - gpp_obs, 34 | bias_bess_v1_diff = gpp_bess_v1 - gpp_obs, 35 | bias_mte_diff = gpp_mte - gpp_obs 36 | ) 37 | nice_agg <- nice_agg %>% mutate( bias_pmodel_diff = gpp_pmodel - gpp_obs, 38 | bias_bess_v1_diff = gpp_bess_v1 - gpp_obs 39 | ) 40 | 41 | ##------------------------------------------------ 42 | ## Bin data w.r.t. alpha 43 | ##------------------------------------------------ 44 | 45 | plot_bias_all <- function( nice_agg, nice_8d_agg, filn=NA ){ 46 | 47 | xlim <- c(0.5,5.5) 48 | ylim <- c(-4,4) 49 | 50 | if (!is.na(filn)) pdf(filn, width = 7, height = 6) 51 | par(xaxs="i", yaxs="i", mgp=c(2.5,1,0), las=1) 52 | 53 | plot( xlim, ylim, type="n", ylim=ylim, xlab = "AET/PET bin", ylab = expression( paste("modelled / observed GPP (ratio)" ) ), xlim=xlim, axes=FALSE ) 54 | 55 | rect( 5:1-0.5, rep(ylim[1], 6), 5:1+0.5, rep(ylim[2], 6), border = NA, col=colorRampPalette( c("wheat3", "white") )( 5 ) ) 56 | 57 | ## bias in P-model versus alpha 58 | bp <- myboxplot( log( bias_bess_v1 ) ~ inalphabin, data=nice_agg, add=TRUE, at=5:1+0.3, col="royalblue3", axes=FALSE, boxwex=0.2, outline=FALSE ) 59 | # myboxplot( bias_bess_v1_diff ~ inalphabin, data=nice_agg, add=TRUE, at=5:1+0.3, col="royalblue3", axes=FALSE, boxwex=0.2, outline=FALSE) 60 | 61 | text( x = 5:1, y = 3.5, labels = paste( "N =", bp$n ), cex=0.8 ) 62 | 63 | ## bias in MODIS versus alpha 64 | myboxplot( log(bias_vpm) ~ inalphabin, data=nice_8d_agg, add=TRUE, at=5:1+0.1, col="springgreen3", axes=FALSE, boxwex=0.2, outline=FALSE ) 65 | # myboxplot( bias_vpm_diff ~ inalphabin, data=nice_8d_agg, add=TRUE, at=5:1+0.1, col="springgreen3", axes=FALSE, boxwex=0.2, outline=FALSE ) 66 | 67 | ## bias in VPM versus alpha 68 | myboxplot( log(bias_modis) ~ inalphabin, data=nice_8d_agg, add=TRUE, at=5:1-0.1, col="orchid", axes=FALSE, boxwex=0.2, outline=FALSE ) 69 | # myboxplot( bias_modis_diff ~ inalphabin, data=nice_8d_agg, add=TRUE, at=5:1-0.1, col="orchid", axes=FALSE, boxwex=0.2, outline=FALSE ) 70 | 71 | ## bias in BESS v1 versus alpha 72 | myboxplot( log( bias_pmodel ) ~ inalphabin, data=nice_agg, at=5:1-0.3, add=TRUE, col="tomato", boxwex=0.2, outline=FALSE ) 73 | # myboxplot( bias_pmodel_diff ~ inalphabin, data=nice_agg, at=5:1-0.3, add=TRUE, col="tomato", boxwex=0.2, outline=FALSE ) 74 | 75 | # ## MTE 76 | # myboxplot( bias_mte_diff ~ infbin, data = df_dday_8d_agg, add=TRUE, at=5:1-0.4, col="tomato", axes=FALSE, boxwex=0.2 ) 77 | 78 | abline( h=0, lty=3 ) 79 | legend("bottomright", c("P-model", "MODIS", "VPM", "BESS"), fill=c("tomato", "orchid", "springgreen3", "royalblue3"), bty="n") 80 | 81 | if (!is.na(filn)) dev.off() 82 | } 83 | 84 | 85 | 86 | -------------------------------------------------------------------------------- /map_effects_gpp_mean.R: -------------------------------------------------------------------------------- 1 | library(ncdf4) 2 | library(dplyr) 3 | library(RColorBrewer) 4 | source("plot_map.R") 5 | 6 | get_trend <- function( vec ){ 7 | if (is.na(vec[1])){ 8 | slope <- NA 9 | signif <- FALSE 10 | } else { 11 | df <- tibble( x = seq(length(vec)), y = vec ) 12 | linmod <- lm( y ~ x, data = df ) 13 | slope <- coef(linmod)[2] 14 | ci <- confint(linmod)[2,] 15 | # if (ci[1] < 0.0 && 0.0 < ci[2]) slope <- NA 16 | if (ci[1] < 0.0 && 0.0 < ci[2]) { 17 | signif <- FALSE 18 | } else { 19 | signif <- TRUE 20 | } 21 | } 22 | return( c(slope, signif) ) 23 | } 24 | 25 | ##------------------------------------------------------------------------ 26 | ## TREND in relative GPP reduction, across globe 27 | ##------------------------------------------------------------------------ 28 | fil_s0 <- "gpp_pmodel_s0_ANN.nc" 29 | fil_s1b <- "gpp_pmodel_s1b_ANN.nc" 30 | 31 | dir <- paste0( myhome, "/data/pmodel_fortran_output/v2/") 32 | 33 | nc <- nc_open( paste0( dir, fil_s0 ) ) 34 | gpp_s0 <- ncvar_get( nc, varid="gpp" ) 35 | lon <- nc$dim$lon$vals 36 | lat <- nc$dim$lat$vals 37 | time <- nc$dim$time$vals 38 | nc_close(nc) 39 | 40 | ## S1b 41 | nc <- nc_open( paste0( dir, fil_s1b ) ) 42 | gpp_s1b <- ncvar_get( nc, varid="gpp" ) 43 | nc_close(nc) 44 | 45 | ## get relative reduction in annual GPP due to soil moisture 46 | gpp_reldiff <- -100 * ( 1.0 - gpp_s1b/gpp_s0 ) 47 | gpp_absdiff <- gpp_s1b - gpp_s0 48 | 49 | ## get linear trend in each gridcell 50 | # trend_abs <- apply( gpp_absdiff, c(1,2), FUN = get_trend ) 51 | trend_rel <- apply( gpp_reldiff, c(1,2), FUN = get_trend ) 52 | 53 | # ## plot absolute difference 54 | # plot_map( trend_abs[1,,], lev = c(-5, 5, 10), positive = FALSE, minval = -20, maxval = 40 ) 55 | 56 | ## plot relative difference (positive value meaning that the relative difference due to soil moisture is getting less negative = less of a reduction in GPP in relative terms) 57 | plot_map( trend_rel[1,,], lev = c(-0.5, 0.5, 10), positive = FALSE, minval = -1.4, maxval = 2.0 ) # , stippling = trend_rel[2,,] 58 | 59 | ##------------------------------------------------------------------------ 60 | ## Get mean annual GPP fields 61 | ##------------------------------------------------------------------------ 62 | fil_s0 <- "gpp_pmodel_s0_MEAN.nc" 63 | fil_s1 <- "gpp_pmodel_s1_MEAN.nc" 64 | fil_s1b <- "gpp_pmodel_s1b_MEAN.nc" 65 | 66 | dir <- paste0( myhome, "/data/pmodel_fortran_output/v2/") 67 | 68 | nc <- nc_open( paste0( dir, fil_s0 ) ) 69 | gpp_s0 <- ncvar_get( nc, varid="gpp" ) 70 | lon <- nc$dim$lon$vals 71 | lat <- nc$dim$lat$vals 72 | time <- nc$dim$time$vals 73 | nc_close(nc) 74 | 75 | ## S1 76 | nc <- nc_open( paste0( dir, fil_s1 ) ) 77 | gpp_s1 <- ncvar_get( nc, varid="gpp" ) 78 | nc_close(nc) 79 | 80 | ## S1b 81 | nc <- nc_open( paste0( dir, fil_s1b ) ) 82 | gpp_s1b <- ncvar_get( nc, varid="gpp" ) 83 | nc_close(nc) 84 | 85 | 86 | ##----------------------------------------------------- 87 | ## absolute GPP (gC m-2 yr-1) 88 | ##----------------------------------------------------- 89 | cols <- colorRampPalette( brewer.pal(9,"YlOrRd"))(10) 90 | 91 | plot_map( gpp_s0, lev = c( 0, 4500, 10 ), 92 | toplefttext=expression(paste("GPP, no soil moisture limitation")), 93 | toprighttext=expression(paste("gC m"^{-2}, "yr"^{-1})), 94 | maxval=4600, color=cols 95 | , file = "fig/map_gpp_nolimit.pdf" 96 | ) 97 | 98 | plot_map( gpp_s1b, lev = c( 0, 4500, 10 ), 99 | toplefttext=expression(paste("GPP, with soil moisture limitation")), 100 | toprighttext=expression(paste("gC m"^{-2}, "yr"^{-1})), 101 | maxval=4600, color=cols 102 | , file = "fig/map_gpp_limit.pdf" 103 | ) 104 | 105 | ##----------------------------------------------------- 106 | ## absolute GPP loss (gC m-2 yr-1) 107 | ##----------------------------------------------------- 108 | plot_map( gpp_s0 - gpp_s1b, lev = c( 0, 400, 10 ), 109 | toplefttext=expression(paste("GPP loss")), 110 | toprighttext=expression(paste("gC m"^{-2}, "yr"^{-1})), 111 | maxval=1900 112 | , file = "fig/map_gpp_loss_abs.pdf" 113 | ) 114 | 115 | ##----------------------------------------------------- 116 | ## relative GPP loss (percent) 117 | ##----------------------------------------------------- 118 | plot_map( (1-(gpp_s1b / gpp_s0))*100, lev=c( 0, 70, 14 ), 119 | toplefttext=expression(paste("GPP loss")), 120 | toprighttext=expression(paste("%")), 121 | maxval = 100 122 | , file = "fig/map_gpp_loss_rel.pdf" 123 | ) 124 | 125 | save( gpp_s0, gpp_s1b, trend_rel, file="data/gpp_loss.Rdata" ) 126 | 127 | -------------------------------------------------------------------------------- /data_openaccess/README.md: -------------------------------------------------------------------------------- 1 | # Data from article Stocker et al. (2018b) *Nature Geosci.* 2 | 3 | The datasets provided here include: 4 | 5 | - Site-level GPP model results from the P-model (Wang et al., 2017) 6 | - Model outputs from global simulations with the P-model (Wang et al., 2017) as implemented for the study by Stocker et al. (2018b) 7 | 8 | This data may be used to partly reproduce results presented in Stocker et al. (2018b) *Nature Geosci.*. "Partly" because we used data for our analysis that was not open access but was confidentially shared with us. This includes remote sensing-based GPP estimates from the BESS and VPM models. Other open access data that was used for the analysis may not be distributed under this DOI. This includes FLUXNET 2015 data and MODIS data. 9 | 10 | For reproducing results of Stocker et al. (2018b) regarding site-scale evaluations, run for example the scripts `plot_bias_all.R` and `plot_bias_problem.R`, available from (Github)[https://github.com/stineb/soilm_global] or (Zenodo)[https://zenodo.org/record/1286966#.W6TFipMzbUI], using CSV files provided here (see comments in scripts). For more insight, including analysis of global simulation outputs, see RMarkdown file `si_soilm_global.Rmd`. This renders the supplementary information PDF document provided along with Stocker et al. (2018b), which is available also on (RPubs)[http://rpubs.com/stineb/si_soilm_global2]. 11 | 12 | The present datasets are prepared by script `prepare_data_openaccess.R ` on (Github)[https://github.com/stineb/soilm_global] or (Zenodo)[https://zenodo.org/record/1286966#.W6TFipMzbUI]. 13 | 14 | ## Data description 15 | 16 | ### Site-level data 17 | 18 | Data is provided as CSV files: 19 | 20 | - `gpp_daily_fluxnet_stocker18natgeo.csv`: Daily data for full time series (not including MODIS GPP) 21 | - `gpp_8daily_fluxnet_stocker18natgeo.csv`: Data aggregated to 8-day periods corresponding to MODIS dates (including MODIS GPP) 22 | - `gpp_alg_daily_fluxnet_stocker18natgeo.csv`: Data filtered to periods with substantial soil moisture effects ("fLUE droughts" following Stocker et al. (2018a)) 23 | - `gpp_alg_8daily_fluxnet_stocker18natgeo.csv`: Data aggregated to 8-day periods and filtered to periods with substantial soil moisture effects. 24 | 25 | Each column is a variable with the following name and units (not all variables are available in all files): 26 | 27 | - `site_id`: FLUXNET site ID 28 | - `date`: Date of measurement, units: YYYY-MM-DD 29 | - `gpp_pmodel` and `gpp_modis`: Simulated GPP from the P-model and MODIS (see Stocker et al. (2018b), Methods, RS models), units: g C m-2 d-1 (mean across 8 day periods in respective files) 30 | - `aet_splash`: Simulated actual evapotranspiration from the SPLASH model (Davis et al., 2017), units: mm d-1 31 | - `pet_splash`: Simulated potential evapotranspiration from the SPLASH model (Davis et al., 2017), units: mm d-1 32 | - `soilm_splash`: Soil moisture simulated by the SPLASH model (Davis et al., 2017), normalised to vary between zero and one at the maximum water holding capacity, unitless. 33 | - `flue`: fLUE estimate from Stocker et al. (2018). Estimates soil moisture stress on light use efficiency from flux data, unitless. 34 | - `beta_a`, `beta_b`, and `beta_c`: Empirical soil moisture stress, used as multiplier to simulated GPP as described in Stocker et al. (2018b), unitless. 35 | 36 | ### Global P-model simulation outputs 37 | 38 | GPP and soil moisture output is provided as NetCDF files for simulations s0, and s1b (see Stocker et al. (2018b)). All meta information is provided therein. Files for simulation s1b are names as follows (for outputs from other simulations replace s1b with other simulation name). The fraction of each gridcell covered by land (not open water or ice) is given by separate file `s1b_fapar3g_v2_global.fland.nc`. 39 | 40 | - `s1b_fapar3g_v2_global.d.gpp.nc`: Daily GPP from simulation s1b. 41 | - `s1b_fapar3g_v2_global.d.wcont.nc`: Daily soil moisture from simulation s1b. 42 | 43 | Due to limited total file size allowed for uploads to Zenodo, only outputs from s1b are provided here. Other outputs may be obtained upon request addressed to benjamin.stocker@gmail.com. 44 | 45 | ## References 46 | 47 | Davis, T. W. et al. Simple process-led algorithms for simulating habitats (SPLASH v.1.0): robust indices of radiation, evapotranspiration and plant-available moisture. Geoscientific Model Development 10, 689–708 (2017). 48 | Hufkens, K. khufkens/gee_subset: Google Earth Engine subset script & library. (2017). doi:10.5281/zenodo.833789Running, S. W. et al. A Continuous Satellite-Derived Measure of Global Terrestrial Primary Production. Bioscience 54, 547–560 (2004). 49 | Stocker, B. et al., Quantifying soil moisture impacts on light use efficiency across biomes, New Phytologist, doi: 10.1111/nph.15123 (2018a). 50 | Stocker, B. et al., Satellite monitoring underestimates the impact of drought on terrestrial primary productivity, Nature Geoscience (2018b). XXX STILL IN REVIEW XXX 51 | Wang, H. et al. Towards a universal model for carbon dioxide uptake by plants. Nat Plants 3, 734–741 (2017). 52 | -------------------------------------------------------------------------------- /nature.csl: -------------------------------------------------------------------------------- 1 | 2 | 134 | -------------------------------------------------------------------------------- /gapfill_nn.R: -------------------------------------------------------------------------------- 1 | gapfill_nn <- function( data, predictors, nam_target, package="neuralnet" ){ 2 | ##-------------------------------------------------------------------- 3 | ## Gap-fill using NN 4 | ## 5 | ## Arguments: 6 | ## data: data frame with gaps in column corresponding to nam_target 7 | ## predictors: name of columns in 'data' used as input to the NN 8 | ## nam_target: name of the column in 'data' used as target for the NN training 9 | ##-------------------------------------------------------------------- 10 | 11 | if (package=="neuralnet"){ 12 | ##-------------------------------------------------------------------- 13 | ## Using package neuralnet 14 | ##-------------------------------------------------------------------- 15 | library( neuralnet ) 16 | 17 | ## identify NAs 18 | na_idxs <- which( is.na( data$le_f_mds ) ) 19 | 20 | ## for training use data with NAs removed 21 | train <- data[ -na_idxs, ] 22 | 23 | ## scale variables to within [0,1] 24 | maxs <- apply(train, 2, max) 25 | mins <- apply(train, 2, min) 26 | train_ <- as.data.frame( scale( train, center = mins, scale = maxs - mins ) ) 27 | data_ <- as.data.frame( scale( data, center = mins, scale = maxs - mins ) ) 28 | 29 | ## train the NN 30 | forml <- as.formula( paste( nam_target, "~", paste( predictors, collapse=" + " ) ) ) 31 | 32 | nn <- neuralnet( forml, data=train_, hidden=6, linear.output=TRUE, lifesign="full", threshold=0.02, rep=1 ) 33 | # nn <- repeat_neuralnet( forml, train_, test_, predictors, hidden=6, linear.output=TRUE, lifesign=lifesign, threshold=threshold, rep=nrep ) 34 | 35 | ## predicting 36 | pred_nn_ <- try( compute( nn, subset( data_, select=predictors ) ) ) 37 | 38 | if (class(pred_nn_)!="try-error"){ 39 | 40 | ## scaling back 41 | range <- max( train[[ nam_target ]] ) - min( train[[ nam_target ]] ) 42 | offset <- min( train[[ nam_target ]] ) 43 | pred_nn <- pred_nn_$net.result * range + offset 44 | 45 | } 46 | 47 | # ## plot for verification 48 | # plot( seq(nrow(data)), data[[ nam_target]], type="l" ) ## with gaps 49 | # # lines( na_idxs, pred_nn[na_idxs], col='red' ) ## gap-filled 50 | # lines( seq(nrow(data)), pred_nn, col='red' ) ## gap-filled 51 | 52 | ## fill gaps 53 | data[[ nam_target ]][ na_idxs ] <- pred_nn[ na_idxs ] 54 | 55 | 56 | } else if (package=="caret"){ 57 | ##-------------------------------------------------------------------- 58 | ## Using package caret 59 | ##-------------------------------------------------------------------- 60 | .libPaths( c( .libPaths(), "/home/bstocker/R/x86_64-pc-linux-gnu-library/3.3") ) 61 | 62 | require( caret ) 63 | require( nnet ) 64 | 65 | ## some predictors may be NA. Approximate by linear interpolation. 66 | for (ipred in predictors){ 67 | ## if first value is NA, fill with second 68 | if ( is.na(data[[ ipred ]][1]) ) { data[[ ipred ]][1] <- data[[ ipred ]][2] } 69 | 70 | ## if last value is NA then fill with second-last 71 | if ( is.na(data[[ ipred ]][nrow(data)]) ) { data[[ ipred ]][nrow(data)] <- data[[ ipred ]][nrow(data)-1] } 72 | 73 | ## fill NAs in between time series 74 | data[[ ipred ]][ which(is.na(data[[ ipred ]])) ] <- approx( data$year_dec, data[[ ipred ]] )$y[ which(is.na(data[[ ipred ]])) ] 75 | 76 | } 77 | # print(apply(data, 2, FUN = function (x) sum(is.na(x)))) 78 | 79 | ## this has caused a problem before due to values being too hight -> weird 80 | data[[ nam_target ]] <- data[[ nam_target ]] * 1e-6 81 | 82 | ## identify NAs 83 | na_idxs <- which( is.na( data[[ nam_target ]] ) ) 84 | 85 | ## for training use data with NAs removed 86 | train <- data[ -na_idxs, ] 87 | 88 | preprocessParams <- preProcess( train, method=c("range") ) 89 | traincotrlParams <- trainControl( method="repeatedcv", number=10, repeats=3, verboseIter=FALSE, p=0.75 ) # take best of 10 repetitions of training with 75% used for training (25% for testing) 90 | 91 | forml <- as.formula( paste( nam_target, "~", paste( predictors, collapse=" + " ) ) ) 92 | nn <- train( 93 | forml, 94 | data = train, #training, 95 | method = "nnet", 96 | linout = TRUE, 97 | tuneGrid = expand.grid( .decay = c(1e-3), .size = c(20) ), 98 | preProc = "range", # c("center", "scale"), # "range", # preProc = preprocessParams 99 | trControl = traincotrlParams, 100 | trace = FALSE 101 | ) 102 | 103 | pred_nn <- as.vector( predict( nn, data )) 104 | # pred_nn <- pred_nn * 1e6 105 | 106 | # ## plot for verification 107 | # plot( seq(nrow(data)), data[[ nam_target]], type="n" ) ## with gaps 108 | # lines( seq(nrow(data)), pred_nn, col='red' ) ## gap-filled 109 | # lines( seq(nrow(data)), data[[ nam_target]] ) ## with gaps 110 | 111 | ## fill gaps 112 | data[[ nam_target ]][ na_idxs ] <- pred_nn[ na_idxs ] 113 | 114 | ## revert 115 | data[[ nam_target ]] <- data[[ nam_target ]] * 1e6 116 | 117 | } 118 | 119 | return( data ) 120 | 121 | } 122 | -------------------------------------------------------------------------------- /get_modobs_fluxnet2015.R: -------------------------------------------------------------------------------- 1 | get_modobs_fluxnet2015 <- function( sitename, simsuite, outputset, data=NA, getvars=c( "gpp", "wcont", "aet", "pet" ), add_swcvars=TRUE, whc=NA, overwrite=overwrite, overwrite_dosites=overwrite_dosites ){ 2 | 3 | # ## XXX debug------------------------------------------ 4 | # sitename = "AR-SLu" 5 | # whc = 268 6 | # simsuite = "fluxnet2015" 7 | # data = list() 8 | # outputset = c( "s16" ) 9 | # getvars = c( "gpp", "wcont", "aet", "pet" ) 10 | # add_swcvars = TRUE 11 | # overwrite = TRUE 12 | # overwrite_dosites = TRUE 13 | # ##---------------------------------------------------- 14 | 15 | require(readr) 16 | 17 | source( "get_fluxdata_fluxnet2015.R" ) 18 | source( "get_meteo_fluxnet2015.R" ) 19 | source( "get_daily_modelout.R" ) 20 | 21 | avl2015 <- TRUE 22 | avl_mod <- rep( TRUE, length(outputset) ) 23 | 24 | norm_to_max <- function( vec ){ 25 | vec <- ( vec - min( vec, na.rm=TRUE ) ) / ( max( vec, na.rm=TRUE ) - min( vec, na.rm=TRUE ) ) 26 | return( vec ) 27 | } 28 | 29 | ##--------------------------------------------------------- 30 | ## read SOFUN output data for each output set -> ddf as list 31 | ##--------------------------------------------------------- 32 | print( paste( "getting model output data ..." ) ) 33 | site <- list() 34 | ddf <- list() 35 | 36 | kdx <- 0 37 | for (iset in outputset){ 38 | kdx <- kdx + 1 39 | 40 | dirnam_mod <- paste( myhome, "sofun/output_nc_fluxnet2015_sofun/", iset, "/", sep="" ) 41 | 42 | ddf_tmp <- try( get_daily_modelout( sitename, dirnam_mod, getvars ) ) 43 | 44 | if (class(ddf_tmp)=="try-error") { 45 | 46 | print( paste( "error opening", path ) ) 47 | avl_mod[kdx] <- FALSE 48 | missing_mod[[ iset ]] <- c( missing_mod[[ iset ]], sitename ) 49 | 50 | } else { 51 | 52 | ## For comparison with FLUXNET 2015 data, normalise simulated soil moisture to between 0 and 1 53 | print( "WARNING: Normalising simulated soil moisture to WHC given for each site.") 54 | ddf_tmp <- ddf_tmp %>% mutate( wcont = wcont / whc ) 55 | 56 | ## add to list 57 | ddf[[ iset ]] <- ddf_tmp 58 | 59 | } 60 | } 61 | 62 | 63 | ##--------------------------------------------------------- 64 | ## read FLUXNET 2015 data -> ddf_obs, ddf_swc_obs 65 | ##--------------------------------------------------------- 66 | print( paste( "getting FLUXNET 2015 data ..." ) ) 67 | dirnam_obs <- paste0( myhome, "data/FLUXNET-2015_Tier1/20160128/point-scale_none_1d/original/unpacked/" ) 68 | allfiles <- list.files( dirnam_obs ) 69 | allfiles <- allfiles[ which( grepl( "FULLSET", allfiles ) ) ] 70 | allfiles <- allfiles[ which( grepl( "3.csv", allfiles ) ) ] 71 | filnam_obs <- allfiles[ which( grepl( sitename, allfiles ) ) ] 72 | path <- paste0( dirnam_obs, filnam_obs ) 73 | 74 | out <- try( get_fluxdata_fluxnet2015( path, add_swcvars=add_swcvars ) ) 75 | 76 | if (class(out)=="try-error") { 77 | print( paste( "error opening", path ) ) 78 | avl2015 <- FALSE 79 | } else { 80 | ## Normalise observational soil moisture to within minimum (=0) and maximum (=1), and 81 | out$obs_swc <- out$obs_swc %>% mutate_at( vars(starts_with("SWC_F_MDS")), funs(norm_to_max(.)) ) 82 | 83 | ## get mean soil observational moisture across different depths (if available) 84 | out$obs_swc <- out$obs_swc %>% 85 | mutate( soilm_obs_mean = apply( select( out$obs_swc, starts_with("SWC_F_MDS") ), 1, FUN=mean, na.rm=TRUE ) ) %>% 86 | mutate( soilm_obs_mean = ifelse( is.nan(soilm_obs_mean), NA, soilm_obs_mean ) ) 87 | } 88 | 89 | ##--------------------------------------------------------- 90 | ## read input data -> ddf_in 91 | ##--------------------------------------------------------- 92 | ## climate 93 | print( paste( "getting climate input data ..." ) ) 94 | dirnam_obs <- paste0( myhome, "data/FLUXNET-2015_Tier1/20160128/point-scale_none_1d/original/unpacked/" ) 95 | allfiles <- list.files( dirnam_obs ) 96 | allfiles <- allfiles[ which( grepl( "FULLSET", allfiles ) ) ] 97 | filnam_obs <- allfiles[ which( grepl( sitename, allfiles ) ) ] 98 | filn <- paste0( dirnam_obs, filnam_obs ) 99 | if ( length(filnam_obs)>0 ){ 100 | ddf_inclim <- try( get_meteo_fluxnet2015( filn ) ) 101 | } 102 | if (class(ddf_inclim)=="try-error"){ 103 | missing_inclim <- c( missing_inclim, sitename ) 104 | } 105 | 106 | ## fAPAR 107 | print( paste( "getting fapar input data (MODIS FPAR) ..." ) ) 108 | filn <- paste0( myhome, "sofun/input_fluxnet2015_sofun/sitedata/fapar/", sitename, "/dfapar_MODIS_FPAR_MCD15A3H_", sitename, "_gee_subset.csv" ) 109 | ddf_infpar <- try( read_csv( filn ) ) 110 | if (class(ddf_infpar)=="try-error"){ 111 | missing_infpar <- c( missing_infpar, sitename ) 112 | } else { 113 | ddf_infpar <- ddf_infpar %>% rename( fpar = modisvar_interpol ) %>% select( date, fpar ) %>% mutate( date = ymd(date) ) 114 | } 115 | 116 | 117 | ##--------------------------------------------------------- 118 | ## Check if any data is available 119 | ##--------------------------------------------------------- 120 | if (length(ddf)==0){ 121 | cont <- FALSE 122 | ddf <- NA 123 | } else { 124 | cont <- TRUE 125 | } 126 | 127 | if (cont){ 128 | if (avl2015){ 129 | 130 | ## add to list 131 | ddf$obs <- out$obs 132 | ddf$inp <- ddf_inclim %>% left_join( ddf_infpar, by = "date" ) 133 | ddf$swc_obs <- out$obs_swc 134 | 135 | } else { 136 | 137 | ddf$obs <- NA 138 | ddf$inp <- NA 139 | ddf$swc_obs <- NA 140 | 141 | } 142 | 143 | ##--------------------------------------------------------- 144 | ## add ddf list to list of this site 145 | ##--------------------------------------------------------- 146 | data[[ sitename ]]$ddf <- ddf 147 | 148 | } else { 149 | 150 | data[[ sitename ]]$ddf <- NA 151 | 152 | } 153 | 154 | return( data ) 155 | 156 | } 157 | -------------------------------------------------------------------------------- /plot_map_gpploss.R: -------------------------------------------------------------------------------- 1 | library(ncdf4) 2 | library(fields) 3 | library(sp) 4 | library(maptools) 5 | library(dplyr) 6 | 7 | syshome <- Sys.getenv( "HOME" ) 8 | source( paste( syshome, "/.Rprofile", sep="" ) ) 9 | 10 | ## get GPP 11 | if (!exists("gpp")){ 12 | print("getting gpp ...") 13 | nc <- nc_open( paste( myhome, "data/pmodel_output/Pmod_output_global_GPP_C3_s1982-01-01_e2011-12-31_r15_8.nc", sep="") ) 14 | gpp <- ncvar_get( nc, varid="GPP" ) 15 | nc_close( nc ) 16 | } 17 | 18 | ## get annual mean alpha (AET/PET) 19 | if (!exists("aalpha")){ 20 | print("getting gpp ...") 21 | nc <- nc_open( "data/alpha_Pmod_SPLASH.nc" ) 22 | aalpha <- ncvar_get( nc, varid="ALPHA" ) 23 | nc_close( nc ) 24 | } 25 | 26 | 27 | 28 | ## get %GPP loss as a function of AET/PET from Fig. 9a in Stocker et al. in prep. 29 | calc_gpploss <- function( alpha ){ 30 | out <- ( 52.3 - 54.1 * alpha ) 31 | return( out ) 32 | } 33 | gpploss_frac <- apply( aalpha, c(1,2), FUN = calc_gpploss ) 34 | 35 | gpploss_frac[ which( gpploss_frac>100 ) ] <- 100 36 | gpploss_frac[ which( gpploss_frac<0 ) ] <- 0 37 | 38 | ## get mean annual GPP 39 | print("get mean annual GPP...") 40 | agpp <- apply( gpp, c(1,2), FUN = function(x) sum( x, na.rm=TRUE )/12 ) 41 | 42 | ## get absolute GPP loss 43 | print("get annual GPP loss ...") 44 | gpploss <- agpp * gpploss_frac * 1e-3 45 | 46 | 47 | ##------------------------ 48 | ## %GPP loss, map 49 | ##------------------------ 50 | magn <- 4 51 | ncols <- 2 52 | nrows <- 1 53 | widths <- rep(1.6*magn,ncols) 54 | widths[2] <- 0.25*widths[1] 55 | heights <- rep(magn,nrows) 56 | order <- matrix( c(1,2), nrows, ncols, byrow=FALSE) 57 | 58 | ylim <- c(-60,85) 59 | lat.labels <- seq(-90, 90, 30) 60 | lat.short <- seq(-90, 90, 10) 61 | lon.labels <- seq(-180, 180, 60) 62 | lon.short <- seq(-180, 180, 10) 63 | 64 | a <- sapply( lat.labels, function(x) bquote(.(x)*degree ~ N) ) 65 | b <- sapply( lon.labels, function(x) bquote(.(x)*degree ~ E) ) 66 | 67 | pdf( "fig/map_gpploss_frac.pdf", width=sum(widths), height=sum(heights) ) 68 | 69 | panel <- layout( 70 | order, 71 | widths=widths, 72 | heights=heights, 73 | TRUE 74 | ) 75 | # layout.show( panel ) 76 | 77 | ## Color key 78 | # par( mar=c(3,3,1,1),xaxs="i", yaxs="i",las=1) 79 | color <- c( "wheat", "tomato" ) 80 | lev <- c( 0, 50, 10 ) 81 | out.mycolorbar <- mycolorbar( color, lev, orient="v", plot=FALSE, maxval=100 ) 82 | 83 | par( mar=c(3,3,1,1),xaxs="i", yaxs="i",las=1) 84 | image( 85 | seq(-179.75, 179.75, 0.5), seq(-89.75, 89.75, 0.5), 86 | gpploss_frac, 87 | ylim=c(-60,85), 88 | # zlim=range(lev), 89 | yaxt="n", xaxt="n", 90 | col=out.mycolorbar$colors, breaks=out.mycolorbar$margins, 91 | xlab="", ylab="" 92 | ) 93 | map( add=TRUE, interior=FALSE, resolution=0, lwd=0.5 ) 94 | 95 | axis( 2, at=lat.labels, lab=do.call(expression,a), cex.axis=0.7, lwd=1.5 ) 96 | axis( 2, at=lat.short, lab=F, lwd=1, tck=-0.01 ) 97 | 98 | axis( 4, at=lat.labels, lab=F, lwd=1.5 ) 99 | axis( 4, at=lat.short, lab=F, lwd=1, tck=-0.01 ) 100 | 101 | axis( 1, at=lon.labels, lab=do.call(expression,b), cex.axis=0.7, lwd=1.5 ) 102 | axis( 1, at=lon.short, lab=F, lwd=1, tck=-0.01 ) 103 | 104 | axis( 3, at=lon.labels, lab=F, lwd=1.5 ) 105 | axis( 3, at=lon.short, lab=F, lwd=1, tck=-0.01 ) 106 | 107 | ## Color key 108 | par( mar=c(3,3,1,1),xaxs="i", yaxs="i",las=1) 109 | out.mycolorbar <- mycolorbar( color, lev, orient="v", plot=TRUE, maxval=1 ) 110 | 111 | dev.off() 112 | 113 | 114 | ##------------------------ 115 | ## absolute GPP loss, map 116 | ##------------------------ 117 | magn <- 4 118 | ncols <- 2 119 | nrows <- 1 120 | widths <- rep(1.6*magn,ncols) 121 | widths[2] <- 0.25*widths[1] 122 | heights <- rep(magn,nrows) 123 | order <- matrix( c(1,2), nrows, ncols, byrow=FALSE) 124 | 125 | ylim <- c(-60,85) 126 | lat.labels <- seq(-90, 90, 30) 127 | lat.short <- seq(-90, 90, 10) 128 | lon.labels <- seq(-180, 180, 60) 129 | lon.short <- seq(-180, 180, 10) 130 | 131 | a <- sapply( lat.labels, function(x) bquote(.(x)*degree ~ N) ) 132 | b <- sapply( lon.labels, function(x) bquote(.(x)*degree ~ E) ) 133 | 134 | pdf( "fig/map_gpploss_abs.pdf", width=sum(widths), height=sum(heights) ) 135 | 136 | panel <- layout( 137 | order, 138 | widths=widths, 139 | heights=heights, 140 | TRUE 141 | ) 142 | # layout.show( panel ) 143 | 144 | ## Color key 145 | # par( mar=c(3,3,1,1),xaxs="i", yaxs="i",las=1) 146 | color <- c( "wheat", "tomato" ) 147 | lev <- c( 0, 100, 10 ) 148 | out.mycolorbar <- mycolorbar( color, lev, orient="v", plot=FALSE, maxval=1000 ) 149 | 150 | par( mar=c(3,3,1,1),xaxs="i", yaxs="i",las=1) 151 | image( 152 | seq(-179.75, 179.75, 0.5), seq(-89.75, 89.75, 0.5), 153 | gpploss, 154 | ylim=c(-60,85), 155 | # zlim=range(lev), 156 | yaxt="n", xaxt="n", 157 | col=out.mycolorbar$colors, breaks=out.mycolorbar$margins, 158 | xlab="", ylab="" 159 | ) 160 | map( add=TRUE, interior=FALSE, resolution=0, lwd=0.5 ) 161 | 162 | axis( 2, at=lat.labels, lab=do.call(expression,a), cex.axis=0.7, lwd=1.5 ) 163 | axis( 2, at=lat.short, lab=F, lwd=1, tck=-0.01 ) 164 | 165 | axis( 4, at=lat.labels, lab=F, lwd=1.5 ) 166 | axis( 4, at=lat.short, lab=F, lwd=1, tck=-0.01 ) 167 | 168 | axis( 1, at=lon.labels, lab=do.call(expression,b), cex.axis=0.7, lwd=1.5 ) 169 | axis( 1, at=lon.short, lab=F, lwd=1, tck=-0.01 ) 170 | 171 | axis( 3, at=lon.labels, lab=F, lwd=1.5 ) 172 | axis( 3, at=lon.short, lab=F, lwd=1, tck=-0.01 ) 173 | 174 | ## Color key 175 | par( mar=c(3,3,1,1),xaxs="i", yaxs="i",las=1) 176 | out.mycolorbar <- mycolorbar( color, lev, orient="v", plot=TRUE, maxval=1 ) 177 | 178 | dev.off() 179 | -------------------------------------------------------------------------------- /get_modobs.R: -------------------------------------------------------------------------------- 1 | #################################################### 2 | ## Reads in model output data and observational data 3 | ## from FLUXNET and arranges it all by site with: 4 | ## fluxnet$$ddf$obs $[data frame] 5 | ## $$[data frame] 6 | ## $ddf_stat$rmse 7 | ## etc. 8 | ## 9 | ## Units: 10 | ## GPP : gC m-2 d-1 11 | ## ET : J m-2 d-1 12 | ## SWC : 0 13 | ## 14 | #################################################### 15 | get_modobs <- function( simsuite, outputset, add_swcvars=TRUE, add_swcvars_etbucket=FALSE, overwrite=TRUE, overwrite_dosites=TRUE ){ 16 | 17 | # ## xxx debug ---------------- 18 | # simsuite = "fluxnet2015" 19 | # outputset = "s16" 20 | # add_swcvars=TRUE 21 | # add_swcvars_etbucket = FALSE 22 | # overwrite = TRUE 23 | # overwrite_dosites = TRUE 24 | # ##--------------------------- 25 | 26 | require(dplyr) 27 | require(readr) 28 | require(ggplot2) 29 | 30 | ## get from other repository 'utilities' 31 | source( paste0( myhome, "utilities/conv_noleap_to_ymd.R" ) ) 32 | 33 | source("get_daily_modelout.R") 34 | source("add_swcvars_fluxnet2015.R") 35 | source("get_modobs_fluxnet2015.R") 36 | 37 | siteinfo <- read_csv( paste0( myhome, "/siteinfo_fluxnet2015_sofun.csv" ) ) 38 | datafilnam <- paste0( "data/modobs_fluxnet2015_", paste( outputset, collapse="_"), "_with_SWC_v5" ) 39 | datafilnam_flat <- paste0( "data/df_modobs_fluxnet2015_", paste( outputset, collapse="_"), "_with_SWC_v5" ) 40 | 41 | ## Exclude sites for which no fapar data is available 42 | df_error_fapar <- read_csv( paste0( myhome, "sofun/input_fluxnet2015_sofun/error_missing_forcingdata_MODIS_FPAR_MCD15A3H_fluxnet2015.csv" ) ) 43 | siteinfo <- siteinfo %>% left_join( df_error_fapar, by="mysitename") %>% rename( error_fapar = error ) %>% filter( error_fapar == 0 ) 44 | 45 | if (overwrite){ 46 | 47 | ## re-do all sites selected above (by do.sites) 48 | do.sites_eff <- seq(nrow(siteinfo)) 49 | fluxnet <- list() 50 | missing_2015 <- c() 51 | missing_mod <- list() 52 | missing_inclim <- c() 53 | missing_inevi <- c() 54 | missing_infpar <- c() 55 | 56 | } else { 57 | 58 | if (overwrite_dosites) { 59 | 60 | do.sites_eff <- do.sites 61 | 62 | } else { 63 | ## do only sites that are missing in the list 'fluxnet' loaded from 'datafilnam' 64 | load( datafilnam ) 65 | allsites <- as.character( siteinfo$mysitename )[ do.sites ] 66 | avl <- ls(fluxnet) 67 | addsites <- setdiff(allsites, avl) 68 | do.sites_eff <- which( is.element( allsites, addsites ) ) 69 | 70 | } 71 | 72 | } 73 | 74 | do.sites_names <- as.character( siteinfo$mysitename[do.sites_eff] ) 75 | 76 | for (sitename in do.sites_names){ 77 | 78 | #--------------------------------------------------------- 79 | # Get model output and input data 80 | #--------------------------------------------------------- 81 | print( paste( "Getting data for site ", sitename ) ) 82 | fluxnet <- get_modobs_fluxnet2015( 83 | sitename, 84 | simsuite = simsuite, 85 | outputset = outputset, 86 | data = fluxnet, 87 | getvars = c( "gpp", "wcont", "aet", "pet" ), 88 | add_swcvars = add_swcvars, 89 | whc = siteinfo$whc[which(siteinfo$mysitename==sitename)], 90 | overwrite = TRUE, 91 | overwrite_dosites = TRUE 92 | ) 93 | 94 | } 95 | 96 | #--------------------------------------------------------- 97 | # Re-arrange data into a single flat dataframe (only implemented for using single SOFUN outputset) 98 | #--------------------------------------------------------- 99 | print("converting to flat data frame (tibble)...") 100 | df_fluxnet <- tibble() 101 | missing_ddf <- c() 102 | for (sitename in do.sites_names){ 103 | if ( ncol(fluxnet[[sitename]]$ddf[[ outputset ]])>0 ){ 104 | 105 | ## combine separate dataframes into single one 106 | df_site <- fluxnet[[ sitename ]]$ddf[[ outputset ]] %>% 107 | mutate( mysitename=sitename ) %>% 108 | left_join( fluxnet[[ sitename ]]$ddf$obs, by = "date" ) %>% 109 | left_join( fluxnet[[ sitename ]]$ddf$swc_obs, by = "date" ) %>% 110 | left_join( fluxnet[[ sitename ]]$ddf$inp, by = "date" ) 111 | 112 | ## rename 113 | df_site <- df_site %>% rename( soilm_splash = wcont ) 114 | 115 | df_fluxnet <- df_fluxnet %>% bind_rows( df_site ) 116 | 117 | } else { 118 | 119 | missing_ddf <- c( missing_ddf, sitename ) 120 | 121 | } 122 | } 123 | 124 | 125 | #--------------------------------------------------------- 126 | # Save complete data to single Rdata file 127 | #--------------------------------------------------------- 128 | print("writing to files...") 129 | 130 | ## Nested data list 131 | save( fluxnet, missing_2015, missing_mod, missing_inclim, missing_inevi, file=paste0(datafilnam, ".Rdata") ) 132 | 133 | ## Flat data frame 134 | write_csv( df_fluxnet, path=paste0( datafilnam_flat, ".csv" ) ) 135 | save( df_fluxnet, file=paste0( datafilnam_flat, ".Rdata" ) ) 136 | print("... done saving.") 137 | 138 | # ## Check soil moisture data 139 | # plot_soilm <- function( df_site ){ 140 | # pl <- ggplot( df_site, aes( x=date, y=value, color=variable ) ) + 141 | # geom_line( aes( y = wcont, col = "SOFUN s14") ) + 142 | # geom_line( aes( y = SWC_F_MDS_1, col="SWC_F_MDS_1")) + 143 | # ggtitle( sitename ) 144 | # plot(pl) 145 | # } 146 | # 147 | # # for (sitename in unique(df_fluxnet$mysitename)){ 148 | # # plot_soilm( filter( df_fluxnet, mysitename==sitename ) ) 149 | # # } 150 | # 151 | # lapply( do.sites_names, function(x) plot_soilm( filter( df_fluxnet, mysitename==x ) ) ) 152 | 153 | } 154 | -------------------------------------------------------------------------------- /get_linearfit_II.R: -------------------------------------------------------------------------------- 1 | get_yintersect <- function( df, target="ratio_obs_mod_pmodel", bin=TRUE, beta_min=0.01, x0_fix=0.8, agg=NA, useweights=FALSE, doplot=FALSE ){ 2 | 3 | require(dplyr) 4 | require(tidyr) 5 | require(minpack.lm) 6 | 7 | source("stress_quad_1sided.R") 8 | 9 | if (!is.element(target, names(df))||!is.element("soilm_mean", names(df))){ 10 | 11 | print("ERROR: missing variables fvar or soilm_mean in get_yintersect") 12 | return(NA) 13 | 14 | } else { 15 | 16 | ## Get median by bin and get fvar_vs_soilm for this site (used for clustering) 17 | if (bin){ 18 | nbins <- 10 19 | bins <- seq( 0.0, 1.0, 1.0/nbins ) 20 | xvals <- bins[1:(length(bins)-1)] + (bins[2]-bins[1])/2 21 | df$inbin <- NULL 22 | df <- df %>% mutate( inbin = cut( fvar , breaks = bins ) ) %>% group_by( inbin ) 23 | tmp <- df %>% summarise( median=median( fvar, na.rm=TRUE ) ) %>% complete( inbin, fill = list( median = NA ) ) %>% dplyr::select( median ) 24 | yvals <- unlist(tmp)[1:nbins] 25 | df_tmp <- data.frame( soilm_mean=xvals, fvar=yvals ) 26 | } else { 27 | df_tmp <- df 28 | } 29 | 30 | ##------------------------------------------------ 31 | ## Aggregate data to N-daily means before fitting 32 | ##------------------------------------------------ 33 | if (!is.na(agg)){ 34 | df_tmp <- df_tmp %>% mutate( date = as.POSIXct( as.Date( paste( as.character(year), "-01-01", sep="" ) ) + doy - 1 ) ) 35 | breaks <- seq.POSIXt( df_tmp$date[1], df_tmp$date[nrow(df_tmp)], by=paste0( as.character(agg), " days" ) ) 36 | df_tmp <- df_tmp %>% mutate( inbin = cut( as.numeric(date), breaks = breaks ) ) %>% #, right = FALSE 37 | group_by( inbin ) %>% summarise_all( mean, na.rm=TRUE ) 38 | } 39 | 40 | ##------------------------------------------------ 41 | ## Fit by medians in bis - 1SIDED 42 | ##------------------------------------------------ 43 | if (useweights){ 44 | weights <- 1.0 - df_tmp$fvar 45 | weights <- ifelse( weights<0, 0, weights ) 46 | weights <- ifelse( is.na(weights), 0, weights ) 47 | weights <- weights^2 48 | } else { 49 | weights <- rep( 1.0, nrow(df_tmp) ) 50 | } 51 | 52 | ## parabolic stress function 53 | eq <- paste0( target, " ~ stress_quad_1sided( soilm_mean, x0, beta )") 54 | fit <- try( 55 | nlsLM( 56 | eq, 57 | data=df_tmp, 58 | start=list( x0=x0_fix, beta=1.0 ), 59 | lower=c( x0_fix, beta_min ), 60 | upper=c( x0_fix, 99 ), 61 | algorithm="port", 62 | weights = weights 63 | ) 64 | ) 65 | 66 | if (doplot){ 67 | 68 | par( las=1 ) 69 | with( df_tmp, plot( soilm_mean, fvar, xlim=c(0,1), ylim=c(0,1.2), pch=16, xlab="soil water content (fraction)", ylab="fLUE", col=add_alpha("black", 0.2) ) ) 70 | 71 | ## Curve 72 | if (class(fit)!="try-error"){ 73 | ## parabolic stress function 74 | mycurve( function(x) stress_quad_1sided( x, x0 = 0.9, coef(fit)[[ "beta" ]] ), from=0.0, to=1.0, col='royalblue3', add=TRUE, lwd=2 ) 75 | } 76 | mtext( df_tmp$mysitename[1], line = 0.5, adj = 0.0, font = 2 ) 77 | 78 | } 79 | 80 | # return coefficients of fitted function 81 | ## parabolic stress function 82 | if (class(fit)!="try-error"){ 83 | out <- c( coef(fit), y0=stress_quad_1sided( 0.0, x0_fix, coef(fit)[[ "beta" ]] ) ) 84 | } else { 85 | out <- c( x0=NA, beta=NA, y0=NA ) 86 | } 87 | 88 | return( out ) 89 | 90 | } 91 | } 92 | 93 | 94 | get_linearfit_II <- function( df, target="ratio_obs_mod_pmodel", monthly=FALSE, bin=TRUE, x0_fix=0.8, agg=NA, useweights=FALSE, doplot=FALSE ){ 95 | ##------------------------------------------------------------------------ 96 | ## This first fits the y-axis intersect using a stress function ('stress_quad_1sided()'), 97 | ## and then fits a linear model between between this y-axis intersect and the site-level mean alpha. 98 | ##------------------------------------------------------------------------ 99 | 100 | require(dplyr) 101 | require(tidyr) 102 | 103 | beta_min <- 0.01 104 | 105 | if (monthly){ 106 | ## add date and MOY to dataframe nice_agg 107 | df <- df %>% mutate( date = as.POSIXct( as.Date( paste( as.character( year ), "-01-01", sep="" ) ) + doy - 1 )) 108 | df <- df %>% mutate( moy = as.numeric( format( date, format="%m" ) ) ) 109 | 110 | ## aggregate nice_agg to monthly values 111 | df <- df %>% group_by( mysitename, year, moy ) %>% summarise( fvar = mean( fvar, na.rm=TRUE ), soilm_mean = mean( soilm_mean, na.rm=TRUE ) ) 112 | } 113 | 114 | df_flue0 <- df %>% dplyr::select( mysitename ) %>% unique() 115 | 116 | ## Merge mean annual alpha (AET/PET) values into this dataframe 117 | load( "../sofun/utils_sofun/analysis_sofun/fluxnet2015/data/alpha_fluxnet2015.Rdata" ) # loads 'df_alpha' 118 | df_flue0 <- df_flue0 %>% left_join( rename( df_alpha, meanalpha=alpha ), by="mysitename" ) 119 | 120 | ##------------------------------------------------------------------------ 121 | ## Get y-axis intersect for each site 122 | ##------------------------------------------------------------------------ 123 | df_flue0 <- df_flue0 %>% mutate( flue0 = NA ) 124 | out <- c() 125 | for (sitename in df_flue0$mysitename){ 126 | out <- rbind( out, get_yintersect( 127 | dplyr::select( dplyr::filter( df, mysitename==sitename ), mysitename, date, soilm_mean, ratio_obs_mod_pmodel, fvar ), 128 | target=target, bin=bin, beta_min=beta_min, x0_fix=x0_fix, agg=agg, useweights=useweights, doplot=doplot 129 | ) 130 | ) 131 | } 132 | 133 | out <- as.data.frame( cbind( df_flue0, out ) ) 134 | 135 | ##------------------------------------------------------------------------ 136 | ## Fit linear model 137 | ##------------------------------------------------------------------------ 138 | linmod <- lm( y0 ~ meanalpha, data=dplyr::filter( out, y0 > -1 ) ) 139 | 140 | return( list( linmod=linmod, data=dplyr::filter( out, y0 > -1 ) ) ) 141 | 142 | } -------------------------------------------------------------------------------- /plot_fig_5.R: -------------------------------------------------------------------------------- 1 | require(fields) ## for image.plot() function 2 | require(dplyr) 3 | require(ncdf4) 4 | require(lubridate) 5 | require(fields) 6 | require(sp) 7 | require(maptools) 8 | library(RColorBrewer) 9 | library(igraph) # for fit_power_law() 10 | 11 | myboxplot <- function( ... ){ 12 | boxplot( ..., staplewex=0, whisklty=1, outpch=16, outcex=0.5 ) 13 | } 14 | 15 | # print("loading data...") 16 | # load("data/extremes.Rdata") 17 | # load("data/impacts_extremes.Rdata") 18 | # load("data/extremes_located.Rdata") 19 | 20 | ##------------------------------------------------------------ 21 | ## Plot by continent 22 | ##------------------------------------------------------------ 23 | print("plotting...") 24 | cont <- c("NA", "SA", "EA", "AF", "AU") 25 | continent <- c("North America", "South America", "Eurasia", "Africa", "Australia") 26 | 27 | magn <- 0.7 28 | ncols <- 3 29 | nrows <- 2 30 | widths <- rep(6*magn,ncols) 31 | heights <- rep(5*magn,nrows) 32 | order <- matrix( seq(nrows*ncols), nrows, ncols, byrow=TRUE) 33 | 34 | fct_powerlaw <- function( x, xmin, alpha ){ 35 | xmin * x ^ alpha 36 | } 37 | 38 | pdf( "fig/fig_5.pdf", width=sum(widths), height = sum(heights) ) 39 | 40 | panel <- layout( 41 | order, 42 | widths=widths, 43 | heights=heights, 44 | TRUE 45 | ) 46 | # layout.show( panel ) 47 | 48 | ## Plot PDF of x>X 49 | for (icont in 1:5){ 50 | 51 | ## load fit data if available, otherwise get new 52 | filn_powerlawfit <- paste0( "data/d_cpl_cont", icont, ".Rdata" ) 53 | 54 | if (file.exists(filn_powerlawfit)){ 55 | 56 | load( filn_powerlawfit ) 57 | 58 | } else { 59 | 60 | library(poweRlaw) # https://cran.r-project.org/web/packages/poweRlaw/vignettes/b_powerlaw_examples.pdf 61 | 62 | ## Power Law fitting using "poweRlaw" package 63 | ## continuous power-law 64 | d_cpl_s1b = conpl$new(-list_impacts[[icont]]$s1b*1e-15) 65 | d_cpl_s0 = conpl$new(-list_impacts[[icont]]$s0*1e-15) 66 | 67 | ## infer model parameters and update object 68 | est_s1b = estimate_xmin(d_cpl_s1b) 69 | if (cont[icont]=="EA"){ 70 | est_s0 <- est_s1b 71 | } else { 72 | est_s0 = estimate_xmin(d_cpl_s0 ) 73 | } 74 | 75 | d_cpl_s1b$setXmin(est_s1b) 76 | d_cpl_s0$setXmin(est_s0) 77 | 78 | save( d_cpl_s1b, d_cpl_s0, file = filn_powerlawfit ) 79 | 80 | } 81 | 82 | par( xaxs="r", yaxs="r", las=1, mgp=c(3.5,1,0), mar=c(4.5, 4.5, 2, 1)) 83 | 84 | out <- plot( d_cpl_s1b, pch=16, col = rgb(1,0,0,0.5), xlim=c(range(c(-list_impacts[[icont]]$s1b*1e-15, -list_impacts[[icont]]$s0*1e-15))), xlab="", ylab="" ) 85 | mtext( "Impact (Pg C)", side = 1, line = 3, cex = 0.8 ) 86 | mtext( "p( Impact > x )", side = 2, line = 3.2, las=0, cex = 0.8 ) 87 | out_lines_s1b <- lines(d_cpl_s1b, col = rgb(1,0,0,1), xlab="Impact (PgC)", ylab="p(Impact>x)") 88 | par(new=TRUE) 89 | plot( d_cpl_s0, pch=16, col = rgb(0,0,0,0.5), xlim=c(range(c(-list_impacts[[icont]]$s1b*1e-15, -list_impacts[[icont]]$s0*1e-15))), axes=FALSE, xlab="", ylab="" ) 90 | out_lines_s0 <- lines( d_cpl_s0, col = rgb(0,0,0,1)) 91 | 92 | if (icont==1) legend( "bottomleft", pch=16, col=c(rgb(1,0,0,1), rgb(0,0,0,1)), legend=c("s1","s0"), bty="n", cex = 1.2 ) 93 | mtext( paste0( letters[icont], ") ", continent[icont]), font=2, adj = 0, line = 0.5, cex = 1 ) 94 | 95 | ## back-calculate xmin and alpha from lines outout 96 | alpha_s0 <- (log(out_lines_s0$y[2]) - log(out_lines_s0$y[1])) / (log(out_lines_s0$x[2]) - log(out_lines_s0$x[1])) 97 | xmin_s0 <- out_lines_s0$y[1] / out_lines_s0$x[1] ^ alpha_s0 98 | 99 | alpha_s1b <- (log(out_lines_s1b$y[2]) - log(out_lines_s1b$y[1])) / (log(out_lines_s1b$x[2]) - log(out_lines_s1b$x[1])) 100 | xmin_s1b <- out_lines_s1b$y[1] / out_lines_s1b$x[1] ^ alpha_s1b 101 | 102 | pred_s0 <- tibble( x = seq( min(out_lines_s0$x), max(out_lines_s0$x), length.out = 100 ) ) %>% 103 | # mutate( y = fct_powerlaw( x, d_cpl_s0$xmin, -(d_cpl_s0$pars-1) ) ) 104 | mutate( y = fct_powerlaw( x, xmin_s0, -(d_cpl_s0$pars-1) ) ) %>% # this works perfectly, but don't know why 105 | mutate( y1 = fct_powerlaw( x, xmin_s1b, -(d_cpl_s1b$pars-1) ) ) 106 | 107 | pred_s1b <- tibble( x = seq( min(out_lines_s1b$x), max(out_lines_s1b$x), length.out = 100 ) ) %>% 108 | # mutate( y = fct_powerlaw( x, d_cpl_s1b$xmin, -(d_cpl_s1b$pars-1) ) ) 109 | mutate( y = fct_powerlaw( x, xmin_s1b, -(d_cpl_s1b$pars-1) ) ) %>% # this works perfectly, but don't know why 110 | mutate( y0 = fct_powerlaw( x, xmin_s0, -(d_cpl_s0$pars-1) ) ) 111 | 112 | lines( out_lines_s0, lwd=2, col="black" ) 113 | lines( out_lines_s1b, lwd=2, col="red" ) 114 | 115 | lines( pred_s0, lwd=2, lty=2 ) 116 | lines( pred_s1b, lwd=2, lty=2, col="red" ) 117 | # lines( pred_s1b$x, pred_s1b$y0, lwd=2, lty=2, col="green" ) 118 | 119 | ## get mean amplification of probability 120 | # pred_s1b <- pred_s1b %>% mutate( ampl_prob = y/y0 ) 121 | # out <- exp( mean( log(pred_s1b$ampl_prob) ) ) 122 | 123 | pred_s0 <- pred_s0 %>% mutate( ampl_prob = y1/y ) 124 | ampl <- mean(pred_s0$ampl_prob) # exp( mean( log(pred_s0$ampl_prob) ) ) 125 | 126 | print( paste( cont[icont], " Amplification of probability:", ampl ) ) 127 | 128 | # mtext( expression( paste( alpha[s0], "= -", d_cpl_s0$pars ) ), line-1, adj = 1 ) 129 | mtext( bquote( italic(N) == .( format( length(list_impacts[[icont]]$s1b), digits = 3 ) ) ), line = -1.4, adj = 0.95, cex=0.9 ) 130 | mtext( bquote( alpha[s0] == .( format( d_cpl_s0$pars, digits = 3 ) ) ), line = -2.7, adj = 0.95, cex=0.9 ) 131 | mtext( bquote( alpha[s1b] == .( format( d_cpl_s1b$pars, digits = 3 ) ) ), line = -3.9, adj = 0.95, cex=0.9, col="red" ) 132 | mtext( bquote( italic(A) == .( format( ampl, digits = 3 ) ) ), line = -5.1, adj = 0.95, cex=0.9, col="red" ) 133 | 134 | } 135 | 136 | ## Plot difference s1 - s0, relative (no dependence of amplification factor on size found) 137 | par(las=1) 138 | 139 | myboxplot( ampl_s1b ~ icont, data=df_impacts, ylab="s1b/s0", col="grey70", names=cont, ylim=c(0.2,3) ) 140 | abline( h=1, lty=3 ) 141 | 142 | mtext( paste0( letters[icont+1], ")"), font=2, adj = 0, line = 0.5, cex = 1 ) 143 | 144 | dev.off() 145 | -------------------------------------------------------------------------------- /get_linearfit_V.R: -------------------------------------------------------------------------------- 1 | ## This works like get_linearfit5.R but with a different functional form of the soil moisture stress function: 2-parameter exponential instead of parabolic 2 | 3 | get_yintersect <- function( df, target="fvar", bin=TRUE, beta_min=0.01, x0_fix=0.8, agg=NA, useweights=FALSE, doplot=FALSE ){ 4 | 5 | require(dplyr) 6 | require(tidyr) 7 | require(minpack.lm) 8 | 9 | source("stress_exp.R") 10 | 11 | if (!is.element(target, names(df))||!is.element("soilm_splash", names(df))){ 12 | 13 | print("ERROR: missing variables fvar or soilm_splash in get_yintersect") 14 | return(NA) 15 | 16 | } else { 17 | 18 | ## Get median by bin and get fvar_vs_soilm for this site (used for clustering) 19 | if (bin){ 20 | nbins <- 10 21 | bins <- seq( 0.0, 1.0, 1.0/nbins ) 22 | xvals <- bins[1:(length(bins)-1)] + (bins[2]-bins[1])/2 23 | df$inbin <- NULL 24 | df <- df %>% mutate( inbin = cut( fvar , breaks = bins ) ) %>% group_by( inbin ) 25 | tmp <- df %>% summarise( median=median( fvar, na.rm=TRUE ) ) %>% complete( inbin, fill = list( median = NA ) ) %>% dplyr::select( median ) 26 | yvals <- unlist(tmp)[1:nbins] 27 | df_tmp <- data.frame( soilm_splash=xvals, fvar=yvals ) 28 | } else { 29 | df_tmp <- df 30 | } 31 | 32 | ##------------------------------------------------ 33 | ## Aggregate data to N-daily means before fitting 34 | ##------------------------------------------------ 35 | if (!is.na(agg)){ 36 | df_tmp <- df_tmp %>% mutate( date = as.POSIXct( as.Date( paste( as.character(year), "-01-01", sep="" ) ) + doy - 1 ) ) 37 | breaks <- seq.POSIXt( df_tmp$date[1], df_tmp$date[nrow(df_tmp)], by=paste0( as.character(agg), " days" ) ) 38 | df_tmp <- df_tmp %>% mutate( inbin = cut( as.numeric(date), breaks = breaks ) ) %>% #, right = FALSE 39 | group_by( inbin ) %>% summarise_all( mean, na.rm=TRUE ) 40 | } 41 | 42 | ##------------------------------------------------ 43 | ## Fit by medians in bis - 1SIDED 44 | ##------------------------------------------------ 45 | if (useweights){ 46 | weights <- 1.0 - df_tmp$fvar 47 | weights <- ifelse( weights<0, 0, weights ) 48 | weights <- ifelse( is.na(weights), 0, weights ) 49 | weights <- weights^2 50 | } else { 51 | weights <- rep( 1.0, nrow(df_tmp) ) 52 | } 53 | 54 | ## exponential stress function 55 | eq <- paste0( target, " ~ stress_exp( soilm_splash, y0, curve )") 56 | fit <- try( 57 | nlsLM( 58 | eq, 59 | data=df_tmp, 60 | start=list( y0=0.0, curve=3.0 ), 61 | lower=c( -5, 1.0 ), 62 | upper=c( 1.0, 99.0 ), 63 | algorithm="port" 64 | ) 65 | ) 66 | 67 | if (doplot){ 68 | 69 | par( las=1 ) 70 | with( df_tmp, plot( soilm_splash, fvar, xlim=c(0,1), ylim=c(0,1.2), pch=16, xlab="soil water content (fraction)", ylab="fLUE", col=add_alpha("black", 0.2) ) ) 71 | 72 | ## Curve 73 | if (class(fit)!="try-error"){ 74 | ## exponential stress function 75 | mycurve( function(x) stress_exp( x, y0 = coef(fit)[[ "y0" ]], curve = coef(fit)[[ "curve" ]]), from=0.0, to=1.0, col='royalblue3', add=TRUE, lwd=2 ) 76 | } 77 | mtext( df_tmp$mysitename[1], line = 0.5, adj = 0.0, font = 2 ) 78 | 79 | } 80 | 81 | ## exponential stress function 82 | if (class(fit)!="try-error"){ 83 | out <- c( coef(fit) ) 84 | } else { 85 | out <- c( y0=NA, curve=NA ) 86 | } 87 | 88 | return( out ) 89 | 90 | } 91 | } 92 | 93 | 94 | get_linearfit_V <- function( df, target="ratio_obs_mod_pmodel", monthly=FALSE, bin=TRUE, x0_fix=0.8, agg=NA, useweights=FALSE, doplot=FALSE ){ 95 | ##------------------------------------------------------------------------ 96 | ## This first fits the y-axis intersect using a stress function ('stress_quad_1sided()'), 97 | ## and then fits a linear model between between this y-axis intersect and the site-level mean alpha. 98 | ##------------------------------------------------------------------------ 99 | 100 | require(dplyr) 101 | require(tidyr) 102 | 103 | siteinfo <- read_csv("../sofun/input_fluxnet2015_sofun/siteinfo_fluxnet2015_sofun.csv") 104 | 105 | beta_min <- 0.01 106 | 107 | if (monthly){ 108 | ## add date and MOY to dataframe nice_agg 109 | df <- df %>% mutate( date = as.POSIXct( as.Date( paste( as.character( year ), "-01-01", sep="" ) ) + doy - 1 )) 110 | df <- df %>% mutate( moy = as.numeric( format( date, format="%m" ) ) ) 111 | 112 | ## aggregate nice_agg to monthly values 113 | df <- df %>% group_by( mysitename, year, moy ) %>% summarise( fvar = mean( fvar, na.rm=TRUE ), soilm_splash = mean( soilm_splash, na.rm=TRUE ) ) 114 | } 115 | 116 | df_flue0 <- df %>% dplyr::select( mysitename ) %>% unique() 117 | 118 | ## Merge mean annual alpha (AET/PET) values into this dataframe 119 | load( "../sofun/utils_sofun/analysis_sofun/fluxnet2015/data/alpha_fluxnet2015.Rdata" ) # loads 'df_alpha' 120 | df_flue0 <- df_flue0 %>% left_join( rename( df_alpha, meanalpha=alpha ), by="mysitename" ) 121 | 122 | ##------------------------------------------------------------------------ 123 | ## Get y-axis intersect for each site 124 | ##------------------------------------------------------------------------ 125 | df_flue0 <- df_flue0 %>% mutate( flue0 = NA ) 126 | out <- c() 127 | for (sitename in df_flue0$mysitename){ 128 | out <- rbind( out, get_yintersect( 129 | dplyr::select( dplyr::filter( df, mysitename==sitename ), mysitename, date, soilm_splash, ratio_obs_mod_pmodel, fvar ), 130 | target=target, bin=bin, beta_min=beta_min, x0_fix=x0_fix, agg=agg, useweights=useweights, doplot=doplot 131 | ) 132 | ) 133 | } 134 | 135 | out <- as.data.frame( cbind( df_flue0, out ) ) 136 | 137 | ##------------------------------------------------------------------------ 138 | ## Fit linear models 139 | ##------------------------------------------------------------------------ 140 | out <- out %>% left_join( select( siteinfo, mysitename, classid ), by = "mysitename" ) 141 | 142 | linmod_y0_tree <- lm( y0 ~ meanalpha, data=dplyr::filter( out, !(classid %in% c("GRA", "CSH") ) ) ) 143 | linmod_y0_grass <- lm( y0 ~ meanalpha, data=dplyr::filter( out, classid %in% c("GRA", "CSH") ) ) 144 | 145 | linmod_curve <- lm( curve ~ meanalpha, data=out ) 146 | 147 | return( list( linmod_curve=linmod_curve, linmod_y0_tree=linmod_y0_tree, linmod_y0_grass=linmod_y0_grass, data=out ) ) 148 | 149 | } -------------------------------------------------------------------------------- /plot_fig_3.R: -------------------------------------------------------------------------------- 1 | library( RColorBrewer ) 2 | library( fields, quietly = TRUE ) 3 | library( sp, quietly = TRUE ) 4 | library( maptools, quietly = TRUE ) 5 | library( dplyr, quietly = TRUE ) 6 | 7 | source("../utilities/add_alpha.R") 8 | 9 | load("data/relvar.Rdata") 10 | load("data/ampl_agg_jung.Rdata") 11 | 12 | ## file name for figure 13 | filn <- "fig/fig_3.pdf" 14 | 15 | ##----------------------------------------------------- 16 | ## Panel layout 17 | ##----------------------------------------------------- 18 | magn <- 4 19 | ncols <- 3 20 | nrows <- 1 21 | widths <- rep(1.4*magn,ncols) 22 | widths[2] <- 0.17*widths[1] 23 | widths[1] <- 0.80*widths[3] 24 | heights <- rep(magn,nrows) 25 | order <- matrix( c(1,2,3), nrows, ncols, byrow=TRUE ) 26 | 27 | parinit <- par( no.readonly=TRUE ) 28 | if (!is.na(filn)) pdf( filn, width=sum(widths), height=sum(heights) ) 29 | 30 | panel <- layout( 31 | order, 32 | widths=widths, 33 | heights=heights, 34 | TRUE 35 | ) 36 | # layout.show( panel ) 37 | 38 | ##----------------------------------------------------- 39 | ## Jung plot 40 | ##----------------------------------------------------- 41 | vec_res <- c( 0.5, 1.0, 1.5, 2.5, 3, 4, 4.5, 5, 6, 7.5, 9, 10, 12, 15, 18, 20, 22.5, 30, 36, 45, 60, 90, 180, 360 ) 42 | 43 | par( parinit, mar=c(4,4,3,1), xaxs="i", yaxs="i",las=1, mgp=c(3,1,0) ) 44 | # par(las=1, mar=c(4,4,1,1), new=FALSE, fig=c(0, 1, 0, 1) ) 45 | # with( ampl_agg, plot( resnr, relvar_median, type="l", col="black", lwd=2, ylim=c(0,10), xaxt = "n", xlab="Spatial resolution (degrees)", ylab="Amplification" ) ) 46 | with( ampl_agg, plot( resnr, relvar_median, type="l", col="black", lwd=2, ylim=c(0,10), xaxt = "n", xlab=bquote( "Spatial resolution "(degree) ), ylab="Amplification" ) ) 47 | axis( 1, at=seq(length(vec_res)), labels=as.character( vec_res ) ) 48 | with( ampl_agg, polygon( c(rev(resnr), resnr), c(relvar_q01, relvar_q99), col=add_alpha("tomato2", 0.25), border = NA ) ) 49 | with( ampl_agg, polygon( c(rev(resnr), resnr), c(relvar_q05, relvar_q95), col=add_alpha("tomato2", 0.25), border = NA ) ) 50 | with( ampl_agg, polygon( c(rev(resnr), resnr), c(relvar_q10, relvar_q90), col=add_alpha("tomato2", 0.25), border = NA ) ) 51 | with( ampl_agg, polygon( c(rev(resnr), resnr), c(relvar_q25, relvar_q75), col=add_alpha("tomato2", 0.25), border = NA ) ) 52 | abline( h = 1.0, lty=3 ) 53 | mtext( "a)", font=2, adj = 0, line = 0.5, cex = 1 ) 54 | 55 | 56 | ##----------------------------------------------------- 57 | ## Map change in relative variance 58 | ##----------------------------------------------------- 59 | arr = gpp_s1b / gpp_s0 60 | 61 | # toplefttext = expression(paste("GPP amplification of relative variance")) 62 | # toprighttext = expression(paste("fraction")) 63 | minval = NA 64 | maxval = 35 65 | color = c( "royalblue4", "wheat", "tomato2", "tomato4" ) 66 | lev=c( 0, 4, 10 ) 67 | 68 | ## half degree resolution 69 | lon <- seq(-179.75, 179.75, 0.5) 70 | lat <- seq(-89.75, 89.75, 0.5) 71 | 72 | ylim <- c(-60,85) 73 | lat.labels <- seq(-90, 90, 30) 74 | lat.short <- seq(-90, 90, 10) 75 | lon.labels <- seq(-180, 180, 60) 76 | lon.short <- seq(-180, 180, 10) 77 | 78 | a <- sapply( lat.labels, function(x) if (x>0) {bquote(.(x)*degree ~N)} else if (x==0) {bquote(.(x)*degree)} else {bquote(.(-x)*degree ~S)} ) 79 | b <- sapply( lon.labels, function(x) if (x>0) {bquote(.(x)*degree ~E)} else if (x==0) {bquote(.(x)*degree)} else {bquote(.(-x)*degree ~W)}) 80 | 81 | color <- c( "royalblue4", "wheat", "tomato2", "tomato4" ) 82 | lev <- c( 0, 4, 10 ) 83 | maxval = 35 84 | minval = NA 85 | par( mar=c(4,3,3,1),xaxs="i", yaxs="i",las=1, mgp=c(3,1,0)) 86 | out.mycolorbar <- mycolorbar( color, lev, orient="v", plot=TRUE, maxval=maxval, minval=minval ) 87 | 88 | par( mar=c(4,2.5,3,1), xaxs="i", yaxs="i",las=1, mgp=c(3,1,0)) 89 | image( 90 | lon, lat, 91 | arr, 92 | ylim=c(-60,85), 93 | # zlim=range(lev), 94 | yaxt="n", xaxt="n", 95 | col=out.mycolorbar$colors, breaks=out.mycolorbar$margins, 96 | xlab="", ylab="" 97 | ) 98 | map( add=TRUE, interior=FALSE, resolution=0, lwd=0.5 ) 99 | 100 | axis( 2, at=lat.labels, lab=do.call(expression,a), cex.axis=0.7, lwd=1.5 ) 101 | axis( 2, at=lat.short, lab=F, lwd=1, tck=-0.01 ) 102 | 103 | axis( 4, at=lat.labels, lab=F, lwd=1.5 ) 104 | axis( 4, at=lat.short, lab=F, lwd=1, tck=-0.01 ) 105 | 106 | axis( 1, at=lon.labels, lab=do.call(expression,b), cex.axis=0.7, lwd=1.5 ) 107 | axis( 1, at=lon.short, lab=F, lwd=1, tck=-0.01 ) 108 | 109 | axis( 3, at=lon.labels, lab=F, lwd=1.5 ) 110 | axis( 3, at=lon.short, lab=F, lwd=1, tck=-0.01 ) 111 | 112 | # mtext( expression(paste("GPP amplification of relative variance")), line=1, adj=0 ) 113 | # mtext( expression(paste("fraction")), line=1, adj=1 ) 114 | 115 | rect( -179, -50, -100, 7.5, border = NA, col="white" ) 116 | 117 | mtext( "b)", font=2, adj = 0, line = 0.5, cex = 1 ) 118 | 119 | ##----------------------------------------------------- 120 | ## Inset: Empirical cumulative distribution function of the amplification factor 121 | ##----------------------------------------------------- 122 | vec <- c( gpp_s1a / gpp_s0 ) 123 | vec <- vec[!is.na(vec)] 124 | ecdf_ampl_a <- ecdf( vec ) 125 | 126 | vec <- c( gpp_s1b / gpp_s0 ) 127 | vec <- vec[!is.na(vec)] 128 | ecdf_ampl_b <- ecdf( vec ) 129 | 130 | vec <- c( gpp_s1c / gpp_s0 ) 131 | vec <- vec[!is.na(vec)] 132 | ecdf_ampl_c <- ecdf( vec ) 133 | 134 | ## Inset 1 135 | u <- par("usr") 136 | v <- c( 137 | grconvertX(u[1:2], "user", "ndc"), 138 | grconvertY(u[3:4], "user", "ndc") 139 | ) 140 | v_orig <- v 141 | v <- c( v[1]+0.035, v[1]+0.12*v[2], v[3]+0.10*v[4], v[3]+0.36*v[4] ) 142 | par( fig=v, new=TRUE, mar=c(0,0,0,0), mgp=c(3,0.2,0) ) 143 | xlim <- c(0.75,25) 144 | ylim <- c(0.001, 1) 145 | plot( xlim, ylim, type="n", xlim=xlim, log="xy", ylim=ylim, xlab = "", ylab = "", bg="white", cex.axis=0.7, tck=-0.03 ) 146 | mtext( "Amplification", side=1, line=1, adj=0.5, cex = 0.7 ) 147 | mtext( "ECDF", side=2, line=1.7, adj=0.5, cex = 0.7, las=0 ) 148 | rect( xlim[1], ylim[1], xlim[2], ylim[2], border = NA, col="white" ) 149 | curve( 1.0 - ecdf_ampl_b(x), from=xlim[1], to=xlim[2], col="red", add=TRUE ) 150 | polygon( c( seq(xlim[1], xlim[2], by=0.1 ), rev( seq(xlim[1], xlim[2], by=0.1 ) ) ), c( 1 - ecdf_ampl_a( seq(xlim[1], xlim[2], by=0.1 ) ), rev( 1- ecdf_ampl_c( seq(xlim[1], xlim[2], by=0.1 ) ) ) ), border = NA, col = rgb(1,0,0,0.4) ) 151 | abline( v=1, lty=3 ) 152 | box() 153 | 154 | 155 | if (!is.na(filn)) dev.off() 156 | 157 | -------------------------------------------------------------------------------- /get_linearfit_IV.R: -------------------------------------------------------------------------------- 1 | ##------------------------------------------------ 2 | ## identical to get_linearfit2.R except that two different linear models are fitted - one for grasslands/shrublands and one for others 3 | ##------------------------------------------------ 4 | get_yintersect <- function( df, target="ratio_obs_mod_pmodel", bin=TRUE, beta_min=0.01, x0_fix=0.8, agg=NA, useweights=FALSE, doplot=FALSE ){ 5 | 6 | require(dplyr) 7 | require(tidyr) 8 | require(minpack.lm) 9 | 10 | source("stress_quad_1sided.R") 11 | 12 | if (!is.element(target, names(df))||!is.element("soilm_mean", names(df))){ 13 | 14 | print("ERROR: missing variables fvar or soilm_mean in get_yintersect") 15 | return(NA) 16 | 17 | } else { 18 | 19 | ## Get median by bin and get fvar_vs_soilm for this site (used for clustering) 20 | if (bin){ 21 | nbins <- 10 22 | bins <- seq( 0.0, 1.0, 1.0/nbins ) 23 | xvals <- bins[1:(length(bins)-1)] + (bins[2]-bins[1])/2 24 | df$inbin <- NULL 25 | df <- df %>% mutate( inbin = cut( fvar , breaks = bins ) ) %>% group_by( inbin ) 26 | tmp <- df %>% summarise( median=median( fvar, na.rm=TRUE ) ) %>% complete( inbin, fill = list( median = NA ) ) %>% dplyr::select( median ) 27 | yvals <- unlist(tmp)[1:nbins] 28 | df_tmp <- data.frame( soilm_mean=xvals, fvar=yvals ) 29 | } else { 30 | df_tmp <- df 31 | } 32 | 33 | ##------------------------------------------------ 34 | ## Aggregate data to N-daily means before fitting 35 | ##------------------------------------------------ 36 | if (!is.na(agg)){ 37 | df_tmp <- df_tmp %>% mutate( date = as.POSIXct( as.Date( paste( as.character(year), "-01-01", sep="" ) ) + doy - 1 ) ) 38 | breaks <- seq.POSIXt( df_tmp$date[1], df_tmp$date[nrow(df_tmp)], by=paste0( as.character(agg), " days" ) ) 39 | df_tmp <- df_tmp %>% mutate( inbin = cut( as.numeric(date), breaks = breaks ) ) %>% #, right = FALSE 40 | group_by( inbin ) %>% summarise_all( mean, na.rm=TRUE ) 41 | } 42 | 43 | ##------------------------------------------------ 44 | ## Fit by medians in bis - 1SIDED 45 | ##------------------------------------------------ 46 | if (useweights){ 47 | weights <- 1.0 - df_tmp$fvar 48 | weights <- ifelse( weights<0, 0, weights ) 49 | weights <- ifelse( is.na(weights), 0, weights ) 50 | weights <- weights^2 51 | } else { 52 | weights <- rep( 1.0, nrow(df_tmp) ) 53 | } 54 | 55 | if (nrow(filter(df_tmp, soilm_mean<0.5))>0){ 56 | 57 | ## parabolic stress function 58 | eq <- paste0( target, " ~ stress_quad_1sided( soilm_mean, x0, beta )") 59 | fit <- try( 60 | nlsLM( 61 | eq, 62 | data=df_tmp, 63 | start=list( x0=x0_fix, beta=1.0 ), 64 | lower=c( x0_fix, beta_min ), 65 | upper=c( x0_fix, 99 ), 66 | algorithm="port", 67 | weights = weights 68 | ) 69 | ) 70 | 71 | if (doplot){ 72 | 73 | par( las=1 ) 74 | with( df_tmp, plot( soilm_mean, fvar, xlim=c(0,1), ylim=c(0,1.2), pch=16, xlab="soil water content (fraction)", ylab="fLUE", col=add_alpha("black", 0.2) ) ) 75 | 76 | ## Curve 77 | if (class(fit)!="try-error"){ 78 | ## parabolic stress function 79 | mycurve( function(x) stress_quad_1sided( x, x0 = 0.9, coef(fit)[[ "beta" ]] ), from=0.0, to=1.0, col='royalblue3', add=TRUE, lwd=2 ) 80 | } 81 | mtext( df_tmp$mysitename[1], line = 0.5, adj = 0.0, font = 2 ) 82 | 83 | } 84 | 85 | # return coefficients of fitted function 86 | ## parabolic stress function 87 | if (class(fit)!="try-error"){ 88 | out <- c( coef(fit), y0=stress_quad_1sided( 0.0, x0_fix, coef(fit)[[ "beta" ]] ) ) 89 | } else { 90 | out <- c( x0=NA, beta=NA, y0=NA ) 91 | } 92 | 93 | } else { 94 | out <- c( x0=NA, beta=NA, y0=NA ) 95 | } 96 | 97 | return( out ) 98 | 99 | } 100 | } 101 | 102 | 103 | get_linearfit_IV <- function( df, target="ratio_obs_mod_pmodel", monthly=FALSE, bin=TRUE, x0_fix=0.8, agg=NA, useweights=FALSE, doplot=FALSE ){ 104 | ##------------------------------------------------------------------------ 105 | ## This first fits the y-axis intersect using a stress function ('stress_quad_1sided()'), 106 | ## and then fits a linear model between between this y-axis intersect and the site-level mean alpha. 107 | ##------------------------------------------------------------------------ 108 | 109 | require(dplyr) 110 | require(tidyr) 111 | require(readr) 112 | 113 | beta_min <- 0.01 114 | 115 | siteinfo <- read_csv("../sofun/input_fluxnet2015_sofun/siteinfo_fluxnet2015_sofun.csv") 116 | 117 | if (monthly){ 118 | ## add date and MOY to dataframe nice_agg 119 | df <- df %>% mutate( date = as.POSIXct( as.Date( paste( as.character( year ), "-01-01", sep="" ) ) + doy - 1 )) 120 | df <- df %>% mutate( moy = as.numeric( format( date, format="%m" ) ) ) 121 | 122 | ## aggregate nice_agg to monthly values 123 | df <- df %>% group_by( mysitename, year, moy ) %>% summarise( fvar = mean( fvar, na.rm=TRUE ), soilm_mean = mean( soilm_mean, na.rm=TRUE ) ) 124 | } 125 | 126 | df_flue0 <- df %>% dplyr::select( mysitename ) %>% unique() 127 | 128 | ## Merge mean annual alpha (AET/PET) values into this dataframe 129 | load( "../sofun/utils_sofun/analysis_sofun/fluxnet2015/data/alpha_fluxnet2015.Rdata" ) # loads 'df_alpha' 130 | df_flue0 <- df_flue0 %>% left_join( rename( df_alpha, meanalpha=alpha ), by="mysitename" ) 131 | 132 | ##------------------------------------------------------------------------ 133 | ## Get y-axis intersect for each site 134 | ##------------------------------------------------------------------------ 135 | df_flue0 <- df_flue0 %>% mutate( flue0 = NA ) 136 | out <- c() 137 | for (sitename in df_flue0$mysitename){ 138 | out <- rbind( out, get_yintersect( 139 | dplyr::select( dplyr::filter( df, mysitename==sitename ), mysitename, date, soilm_mean, ratio_obs_mod_pmodel, fvar ), 140 | target=target, bin=bin, beta_min=beta_min, x0_fix=x0_fix, agg=agg, useweights=useweights, doplot=doplot 141 | ) 142 | ) 143 | } 144 | 145 | out <- as.data.frame( cbind( df_flue0, out ) ) 146 | 147 | ##------------------------------------------------------------------------ 148 | ## Fit linear models 149 | ##------------------------------------------------------------------------ 150 | out <- out %>% left_join( select( siteinfo, mysitename, classid ), by = "mysitename" ) 151 | 152 | linmod_tree <- lm( y0 ~ meanalpha, data=dplyr::filter( out, !(classid %in% c("GRA", "CSH") ) & y0 > -1 ) ) 153 | linmod_grass <- lm( y0 ~ meanalpha, data=dplyr::filter( out, classid %in% c("GRA", "CSH") & y0 > -1 ) ) 154 | 155 | return( list( linmod_tree=linmod_tree, linmod_grass=linmod_grass, data=out ) ) 156 | 157 | } -------------------------------------------------------------------------------- /plot_fig_2.R: -------------------------------------------------------------------------------- 1 | require( fields, quietly = TRUE ) 2 | require( sp, quietly = TRUE ) 3 | require( maptools, quietly = TRUE ) 4 | require( dplyr, quietly = TRUE ) 5 | 6 | source("../utilities/add_alpha.R") 7 | source("../utilities/mycolorbar.R") 8 | 9 | ## load global GPP time series, prepared by plot_effects_gpp_tseries.R 10 | load("data/gpp_glob_tseries.Rdata") 11 | 12 | ## load fields ('gpp_s1b', 'gpp_s0', 'trend_rel'), derived by map_effects_gpp_mean.R 13 | load("data/gpp_loss.Rdata" ) 14 | 15 | ##------------------------------------------------------------------------ 16 | ## Panel 17 | ##------------------------------------------------------------------------ 18 | magn <- 4 19 | ncols <- 3 20 | nrows <- 2 21 | widths <- rep(1.4*magn,ncols) 22 | widths[2] <- 0.15*widths[1] 23 | widths[3] <- 0.80*widths[1] 24 | heights <- rep(magn,nrows) 25 | order <- matrix( c(1:6), nrows, ncols, byrow=TRUE ) 26 | 27 | pdf( "fig/fig_2.pdf", width=sum(widths), height = sum(heights) ) 28 | 29 | par(las=1) 30 | 31 | panel <- layout( 32 | order, 33 | widths=widths, 34 | heights=heights, 35 | TRUE 36 | ) 37 | # layout.show( panel ) 38 | 39 | ##------------------------------------------------------------------------ 40 | ## map GPP loss 41 | ##------------------------------------------------------------------------ 42 | # out <- gpp_s0 - gpp_s1b 43 | out <- (1-(gpp_s1b / gpp_s0))*100 44 | lon <- seq(-179.75, 179.75, 0.5) 45 | lat <- seq(-89.75, 89.75, 0.5) 46 | 47 | ylim <- c(-60,85) 48 | lat.labels <- seq(-90, 90, 30) 49 | lat.short <- seq(-90, 90, 10) 50 | lon.labels <- seq(-180, 180, 60) 51 | lon.short <- seq(-180, 180, 10) 52 | 53 | a <- sapply( lat.labels, function(x) if (x>0) {bquote(.(x)*degree ~N)} else if (x==0) {bquote(.(x)*degree)} else {bquote(.(-x)*degree ~S)} ) 54 | b <- sapply( lon.labels, function(x) if (x>0) {bquote(.(x)*degree ~E)} else if (x==0) {bquote(.(x)*degree)} else {bquote(.(-x)*degree ~W)}) 55 | 56 | color <- c( "wheat", "tomato2", "tomato4" ) 57 | 58 | # lev = c( 0, 400, 10 ) 59 | lev=c( 0, 70, 7 ) 60 | out.mycolorbar <- mycolorbar( color, lev, orient="v", plot=FALSE, maxval=max(out, na.rm=TRUE), minval=min(out, na.rm=TRUE) ) 61 | 62 | par( mar=c(4,3,2,1),xaxs="i", yaxs="i",las=1) 63 | image( 64 | lon, lat, 65 | out, 66 | ylim=c(-60,85), 67 | yaxt="n", xaxt="n", 68 | col=out.mycolorbar$colors, breaks=out.mycolorbar$margins, 69 | xlab="", ylab="" 70 | ) 71 | map( add=TRUE, interior=FALSE, resolution=0, lwd=0.5 ) 72 | 73 | axis( 2, at=lat.labels, lab=do.call(expression,a), cex.axis=0.9, lwd=1.5 ) 74 | axis( 2, at=lat.short, lab=F, lwd=1, tck=-0.01 ) 75 | 76 | axis( 4, at=lat.labels, lab=F, lwd=1.5 ) 77 | axis( 4, at=lat.short, lab=F, lwd=1, tck=-0.01 ) 78 | 79 | axis( 1, at=lon.labels, lab=do.call(expression,b), cex.axis=0.9, lwd=1.5 ) 80 | axis( 1, at=lon.short, lab=F, lwd=1, tck=-0.01 ) 81 | 82 | axis( 3, at=lon.labels, lab=F, lwd=1.5 ) 83 | axis( 3, at=lon.short, lab=F, lwd=1, tck=-0.01 ) 84 | 85 | mtext( "a)", font=2, adj = 0, line = 0.5, cex = 1.2 ) 86 | 87 | ## Color key 88 | par( mar=c(4,3,2,1),xaxs="i", yaxs="i",las=1) 89 | out.mycolorbar <- mycolorbar( color, lev, orient="v", plot=TRUE, maxval=1900 ) 90 | 91 | ##------------------------------------------------------------------------ 92 | ## time series 93 | ##------------------------------------------------------------------------ 94 | par( mar=c(4,4.2,2,1), mgp =c(2.8,1,0)) 95 | with( df, plot( year, gpp_s1b, type="n", ylim=c(100,160), xlab="Year", ylab=expression( paste("Global GPP (Pg C yr"^-1, ")" ) ), cex.lab=1.2 ) ) 96 | with( df, polygon( c( year, rev(year)), c(gpp_s1a, rev(gpp_s1c)), border = NA, col=rgb(0,0,0,0.3) ) ) 97 | 98 | with( df, lines( year, gpp_s1b, lty=2, lwd=1.5, col="tomato" ) ) 99 | with( df, lines( year, gpp_s0, col="tomato", lwd=1.5 ) ) 100 | with( df, lines( year, gpp_modis, col="orchid", lwd=1.5 ) ) 101 | with( df, lines( year, gpp_vpm, col="springgreen3", lwd=1.5 ) ) 102 | with( df, lines( year, gpp_bess, col="royalblue3", lwd=1.5 ) ) 103 | # with( df, lines( year, gpp_mte, col="darkgoldenrod3", lwd=1.5 ) ) 104 | 105 | legend("topleft", c( "P-model, s0", "P-model, s1b (grey range: s1a - s1c)", "MODIS", "VPM", "BESS" ), bty = "n", lty = c(1,2,1,1,1), lwd=1.5, col=c("tomato", "tomato", "orchid", "springgreen3", "royalblue3") ) 106 | mtext( "b)", font=2, adj = 0, line = 0.5, cex = 1.2 ) 107 | 108 | ##------------------------------------------------------------------------ 109 | ## map GPP loss trend 110 | ##------------------------------------------------------------------------ 111 | # plot_map( trend_rel[1,,], lev = c(-0.5, 0.5, 10), positive = FALSE, minval = -1.4, maxval = 2.0 ) 112 | out <- trend_rel[1,,] 113 | out[which( trend_rel[2,,] == 0 )] <- NA 114 | color <- rev(c( "royalblue4", "royalblue2", "wheat", "tomato2", "tomato4" )) 115 | 116 | lev = c(-0.5, 0.5, 10) 117 | out.mycolorbar <- mycolorbar( color, lev, orient="v", plot=FALSE, minval = -1.4, maxval = 2.0 ) 118 | 119 | par( mar=c(4,3,2,1),xaxs="i", yaxs="i",las=1) 120 | image( 121 | lon, lat, 122 | out, 123 | ylim=c(-60,85), 124 | yaxt="n", xaxt="n", 125 | col=out.mycolorbar$colors, breaks=out.mycolorbar$margins, 126 | xlab="", ylab="" 127 | ) 128 | map( add=TRUE, interior=FALSE, resolution=0, lwd=0.5 ) 129 | 130 | axis( 2, at=lat.labels, lab=do.call(expression,a), cex.axis=0.9, lwd=1.5 ) 131 | axis( 2, at=lat.short, lab=F, lwd=1, tck=-0.01 ) 132 | 133 | axis( 4, at=lat.labels, lab=F, lwd=1.5 ) 134 | axis( 4, at=lat.short, lab=F, lwd=1, tck=-0.01 ) 135 | 136 | axis( 1, at=lon.labels, lab=do.call(expression,b), cex.axis=0.9, lwd=1.5 ) 137 | axis( 1, at=lon.short, lab=F, lwd=1, tck=-0.01 ) 138 | 139 | axis( 3, at=lon.labels, lab=F, lwd=1.5 ) 140 | axis( 3, at=lon.short, lab=F, lwd=1, tck=-0.01 ) 141 | 142 | # ## add stippling 143 | # incl <- which( trend_rel[2,,] == 1 ) 144 | # grd <- expand.grid( x=lon, y=lat ) 145 | # incl <- incl[ seq(4,length(incl), by=4) ] 146 | # points( grd$x[incl], grd$y[incl], pch=".", cex=1 ) 147 | # 148 | mtext( "c)", font=2, adj = 0, line = 0.5, cex = 1.2 ) 149 | 150 | ## Color key 151 | par( mar=c(4,3,2,1), xaxs="i", yaxs="i", las=1) 152 | out.mycolorbar <- mycolorbar( color, lev, orient="v", plot=TRUE, minval = -1.4, maxval = 2.0 ) 153 | 154 | 155 | ##------------------------------------------------------------------------ 156 | ## time series GPP loss % 157 | ##------------------------------------------------------------------------ 158 | linmod_s1b_releff <- lm( -100*(1-gpp_s1b/gpp_s0) ~ year, data=df ) 159 | 160 | ci <- confint(linmod_s1b_releff) 161 | newx <- seq( min(df$year)-5, max(df$year)+5, length.out=100 ) 162 | preds <- predict( linmod_s1b_releff, newdata = data.frame( year = newx ), interval = 'confidence' ) 163 | 164 | par( mar=c(4,4.2,2,1), mgp =c(2.8,1,0)) 165 | with( df, plot( year, -100*(1-gpp_s1b/gpp_s0), pch=16, col="black", lty=1, xlab="Year", ylim=c(-16, -14), ylab=expression( paste("Reduction in global GPP (%)" ) ), xlim=c(1981,2017), cex.lab=1.2 ) ) 166 | polygon( c( rev(newx), newx ), c( rev(preds[,3]), preds[,2] ), col = rgb(0,0,0,0.3), border = NA ) 167 | abline( linmod_s1b_releff, lwd = 1.5, col="red" ) 168 | text( 1984, -15.9, bquote( italic("slope") == .(format(coef(linmod_s1b_releff)[2], digits = 2) ) ~ "["* .(format( ci[2,1], digits = 2 )) ~ "-" ~ .(format( ci[2,2], digits = 2 ))*"]" ~ "yr" ^-1 ), adj=0, cex=1.2 ) 169 | mtext( "d)", font=2, adj = 0, line = 0.5, cex = 1.2 ) 170 | 171 | dev.off() -------------------------------------------------------------------------------- /plot_jung.R: -------------------------------------------------------------------------------- 1 | library(ncdf4) 2 | library(dplyr) 3 | library(abind) 4 | 5 | source("../utilities/add_alpha.R") 6 | 7 | overwrite <- FALSE 8 | outfiln <- "data/ampl_jung.Rdata" 9 | 10 | vec_res <- c( 0.5, 1.0, 1.5, 2.5, 3, 4, 4.5, 5, 6, 7.5, 9, 10, 12, 15, 18, 20, 22.5, 30, 36, 45, 60, 90, 180, 360 ) 11 | 12 | filpath_detr <- c( paste0( myhome, "/data/pmodel_fortran_output/v2/gpp_pmodel_s0_DETR.nc" ), 13 | paste0( myhome, "/data/pmodel_fortran_output/v2/gpp_pmodel_s1a_DETR.nc" ), 14 | paste0( myhome, "/data/pmodel_fortran_output/v2/gpp_pmodel_s1b_DETR.nc" ), 15 | paste0( myhome, "/data/pmodel_fortran_output/v2/gpp_pmodel_s1c_DETR.nc" ) 16 | ) 17 | 18 | filpath_nice <- c( paste0( myhome, "/data/pmodel_fortran_output/v2/gpp_pmodel_s0_ANN.nc" ), 19 | paste0( myhome, "/data/pmodel_fortran_output/v2/gpp_pmodel_s1a_ANN.nc" ), 20 | paste0( myhome, "/data/pmodel_fortran_output/v2/gpp_pmodel_s1b_ANN.nc" ), 21 | paste0( myhome, "/data/pmodel_fortran_output/v2/gpp_pmodel_s1c_ANN.nc" ) 22 | ) 23 | 24 | modl <- c( "Pmodel_S0", "Pmodel_S1a", "Pmodel_S1b", "Pmodel_S1c") 25 | 26 | if (!file.exists(outfiln) || overwrite){ 27 | 28 | ampl_1a <- data.frame() 29 | ampl_1b <- data.frame() 30 | ampl_1c <- data.frame() 31 | 32 | for ( ires in 1:length(vec_res) ){ 33 | 34 | print(paste("resolution number", ires)) 35 | 36 | detr <- list() 37 | nice <- list() 38 | for (idx in seq(length(modl))){ 39 | 40 | ## Read detrended GPP for IAV 41 | if (file.exists(filpath_detr[idx])){ 42 | 43 | ## read file detrended file 44 | if (ires==1){ 45 | filn <- filpath_detr[idx] 46 | } else { 47 | filn <- gsub( "DETR", paste0("DETR_REGR", sprintf("%02d", ires)), filpath_detr[idx] ) 48 | } 49 | nc <- nc_open( filn ) 50 | detr[[ modl[idx] ]] <- ncvar_get( nc, varid="gpp" ) 51 | nc_close(nc) 52 | 53 | ## read file non-detrended file 54 | if (ires==1){ 55 | filn <- filpath_nice[idx] 56 | } else { 57 | filn <- gsub( "ANN", paste0("ANN_REGR", sprintf("%02d", ires)), filpath_nice[idx] ) 58 | } 59 | nc <- nc_open( filn ) 60 | nice[[ modl[idx] ]] <- ncvar_get( nc, varid="gpp" ) 61 | nc_close(nc) 62 | 63 | } 64 | 65 | } 66 | 67 | ## Get variance and relative variance arrays for all simulations 68 | var <- list() 69 | relvar <- list() 70 | mean <- list() 71 | for (idx in seq(length(modl))){ 72 | 73 | if (ires==length(vec_res)){ 74 | 75 | var[[ modl[idx] ]] <- var( c( detr[[ modl[idx] ]] ), na.rm = TRUE ) 76 | mean[[ modl[idx] ]] <- mean( c( nice[[ modl[idx] ]] ), na.rm = TRUE ) 77 | relvar[[ modl[idx] ]] <- var[[ modl[idx] ]] / mean[[ modl[idx] ]] 78 | 79 | } else { 80 | 81 | var[[ modl[idx] ]] <- apply( detr[[ modl[idx] ]], c(1,2), FUN = var ) 82 | mean[[ modl[idx] ]] <- apply( nice[[ modl[idx] ]], c(1,2), FUN = mean ) 83 | relvar[[ modl[idx] ]] <- var[[ modl[idx] ]] / mean[[ modl[idx] ]] 84 | 85 | } 86 | 87 | } 88 | 89 | ## Get amplification of relative variance, array and vector 90 | char_ires <- sprintf( "%02d", ires ) 91 | 92 | ampl_arr_1a <- relvar[[ "Pmodel_S1a" ]] / relvar[[ "Pmodel_S0" ]] 93 | ampl_arr_1b <- relvar[[ "Pmodel_S1b" ]] / relvar[[ "Pmodel_S0" ]] 94 | ampl_arr_1c <- relvar[[ "Pmodel_S1c" ]] / relvar[[ "Pmodel_S0" ]] 95 | 96 | tmp_relvar_1a <- c( ampl_arr_1a ) 97 | tmp_relvar_1b <- c( ampl_arr_1b ) 98 | tmp_relvar_1c <- c( ampl_arr_1c ) 99 | 100 | idxs <- which( !is.na(tmp_relvar_1a) | !is.na(tmp_relvar_1b) | !is.na(tmp_relvar_1c) ) 101 | 102 | tmp_relvar_1a <- tmp_relvar_1a[ idxs ] 103 | tmp_relvar_1b <- tmp_relvar_1b[ idxs ] 104 | tmp_relvar_1c <- tmp_relvar_1c[ idxs ] 105 | 106 | addrows <- data.frame( relvar=tmp_relvar_1a, resnr=rep(ires, length(idxs)) ) 107 | ampl_1a <- rbind( ampl_1a, addrows ) 108 | 109 | addrows <- data.frame( relvar=tmp_relvar_1b, resnr=rep(ires, length(idxs)) ) 110 | ampl_1b <- rbind( ampl_1b, addrows ) 111 | 112 | addrows <- data.frame( relvar=tmp_relvar_1c, resnr=rep(ires, length(idxs)) ) 113 | ampl_1c <- rbind( ampl_1c, addrows ) 114 | 115 | } 116 | 117 | save( ampl_1a, ampl_1b, ampl_1c, file=outfiln ) 118 | 119 | } else { 120 | 121 | load( outfiln ) 122 | 123 | } 124 | 125 | ## aggregate to get mean (median and quantiles) amplification 126 | ampl_agg_1a <- ampl_1a %>% group_by( resnr ) %>% 127 | summarise( 128 | relvar_mean = mean( relvar, na.rm=TRUE ), 129 | relvar_median = median( relvar, na.rm=TRUE ), 130 | relvar_q01 = quantile( relvar, probs=0.01 ), 131 | relvar_q05 = quantile( relvar, probs=0.05 ), 132 | relvar_q10 = quantile( relvar, probs=0.10 ), 133 | relvar_q90 = quantile( relvar, probs=0.90 ), 134 | relvar_q95 = quantile( relvar, probs=0.95 ), 135 | relvar_q99 = quantile( relvar, probs=0.99 ), 136 | relvar_q25 = quantile( relvar, probs=0.25 ), 137 | relvar_q75 = quantile( relvar, probs=0.75 ) 138 | ) 139 | ampl_agg_1b <- ampl_1b %>% group_by( resnr ) %>% 140 | summarise( 141 | relvar_mean = mean( relvar, na.rm=TRUE ), 142 | relvar_median = median( relvar, na.rm=TRUE ), 143 | relvar_q01 = quantile( relvar, probs=0.01 ), 144 | relvar_q05 = quantile( relvar, probs=0.05 ), 145 | relvar_q10 = quantile( relvar, probs=0.10 ), 146 | relvar_q90 = quantile( relvar, probs=0.90 ), 147 | relvar_q95 = quantile( relvar, probs=0.95 ), 148 | relvar_q99 = quantile( relvar, probs=0.99 ), 149 | relvar_q25 = quantile( relvar, probs=0.25 ), 150 | relvar_q75 = quantile( relvar, probs=0.75 ) 151 | ) 152 | ampl_agg_1c <- ampl_1c %>% group_by( resnr ) %>% 153 | summarise( 154 | relvar_mean = mean( relvar, na.rm=TRUE ), 155 | relvar_median = median( relvar, na.rm=TRUE ), 156 | relvar_q01 = quantile( relvar, probs=0.01 ), 157 | relvar_q05 = quantile( relvar, probs=0.05 ), 158 | relvar_q10 = quantile( relvar, probs=0.10 ), 159 | relvar_q90 = quantile( relvar, probs=0.90 ), 160 | relvar_q95 = quantile( relvar, probs=0.95 ), 161 | relvar_q99 = quantile( relvar, probs=0.99 ), 162 | relvar_q25 = quantile( relvar, probs=0.25 ), 163 | relvar_q75 = quantile( relvar, probs=0.75 ) 164 | ) 165 | 166 | # ## take mean across ensembles 167 | # ampl_agg <- abind( ampl_agg_1a, ampl_agg_1b, ampl_agg_1c, along = 3 ) %>% 168 | # apply( c(1,2), FUN = mean ) %>% 169 | # as_tibble() 170 | 171 | ## use s1b as standard 172 | ampl_agg <- ampl_agg_1b 173 | 174 | save( ampl_agg, file="data/ampl_agg_jung.Rdata" ) 175 | 176 | ## Plot scale dependence of soil moisture effect on GPP interannual variance 177 | # pdf("fig/plot_jung.pdf", width = 5, height = 4 ) 178 | par(las=1, mar=c(4,4,1,1)) 179 | with( ampl_agg, plot( resnr, relvar_median, type="l", col="black", lwd=2, ylim=c(0,1e1), xaxt = "n", xlab="spatial resolution (degrees)", ylab="ampl. of rel. var. of ann. GPP" ) ) 180 | axis( 1, at=seq(length(vec_res)), labels=as.character( vec_res ) ) 181 | with( ampl_agg, polygon( c(rev(resnr), resnr), c(relvar_q01, relvar_q99), col=add_alpha("tomato2", 0.25), border = NA ) ) 182 | with( ampl_agg, polygon( c(rev(resnr), resnr), c(relvar_q05, relvar_q95), col=add_alpha("tomato2", 0.25), border = NA ) ) 183 | with( ampl_agg, polygon( c(rev(resnr), resnr), c(relvar_q10, relvar_q90), col=add_alpha("tomato2", 0.25), border = NA ) ) 184 | with( ampl_agg, polygon( c(rev(resnr), resnr), c(relvar_q25, relvar_q75), col=add_alpha("tomato2", 0.25), border = NA ) ) 185 | abline( h = 1.0, lty=3 ) 186 | # dev.off() 187 | 188 | 189 | 190 | 191 | -------------------------------------------------------------------------------- /plot_fig_4.R: -------------------------------------------------------------------------------- 1 | library(ncdf4) 2 | library(abind) 3 | 4 | source("../utilities/plot_map.R") 5 | source("../utilities/mycolorbar.R") 6 | 7 | myhome <- "/alphadata01/bstocker/" 8 | 9 | get_stocker_f <- function( eff, anom, isabs=FALSE ){ 10 | ##--------------------------------------------------- 11 | ## requires as input a 3D effay with lon x lat x time 12 | ## and values being annual detrended anomalies 13 | ## index quantifies the degree to which each gridcell contributes to the global signal 14 | ##--------------------------------------------------- 15 | 16 | ## use gridcell total not per unit area 17 | if (isabs==FALSE){ 18 | source( "../utilities/integrate_gridcell.R" ) 19 | 20 | eff_abs <- integrate_gridcell( eff, global=FALSE, overwrite=FALSE ) 21 | anom_abs <- integrate_gridcell( anom, global=FALSE, overwrite=FALSE ) 22 | 23 | eff_glob <- apply( eff_abs, c(3), FUN=sum, na.rm=TRUE ) 24 | anom_glob <- apply( anom_abs, c(3), FUN=sum, na.rm=TRUE ) 25 | } else { 26 | 27 | eff_abs <- eff 28 | eff_glob <- apply( eff_abs, c(3), FUN=sum, na.rm=TRUE ) 29 | anom_glob <- apply( anom_abs, c(3), FUN=sum, na.rm=TRUE ) 30 | } 31 | 32 | stocker_f <- eff[,,1] 33 | stocker_f[] <- NA 34 | for (ilon in seq(dim(eff)[1])){ 35 | for (ilat in seq(dim(eff)[2])){ 36 | if (!is.na(eff[ilon,ilat,1])){ 37 | stocker_f[ilon,ilat] <- sum( eff_abs[ilon,ilat,] * abs( anom_glob ) / anom_glob ) / sum( abs( anom_glob ) ) 38 | } 39 | } 40 | } 41 | return( stocker_f ) 42 | } 43 | 44 | 45 | filpath_detr <- c( paste0( myhome, "/data/pmodel_fortran_output/v2/gpp_pmodel_s0_DETR.nc"), 46 | paste0( myhome, "/data/pmodel_fortran_output/v2/gpp_pmodel_s1a_DETR.nc"), 47 | paste0( myhome, "/data/pmodel_fortran_output/v2/gpp_pmodel_s1b_DETR.nc"), 48 | paste0( myhome, "/data/pmodel_fortran_output/v2/gpp_pmodel_s1c_DETR.nc") 49 | ) 50 | 51 | modl <- c( "Pmodel_S0", "Pmodel_S1a", "Pmodel_S1b", "Pmodel_S1c") 52 | 53 | detr <- list() 54 | for (idx in seq(length(modl))){ 55 | 56 | ## Read detrended GPP for IAV 57 | if (file.exists(filpath_detr[idx])){ 58 | 59 | ## read file 60 | nc <- nc_open( filpath_detr[idx] ) 61 | detr[[ modl[idx] ]] <- try( ncvar_get( nc, varid="gpp" ) ) 62 | nc_close(nc) 63 | 64 | } else { 65 | print(paste("file does not exist:", filpath_detr[idx])) 66 | } 67 | 68 | } 69 | 70 | ## get difference 71 | detr[[ "diffa" ]] <- detr[[ "Pmodel_S0" ]] - detr[[ "Pmodel_S1a" ]] 72 | detr[[ "diffb" ]] <- detr[[ "Pmodel_S0" ]] - detr[[ "Pmodel_S1b" ]] 73 | detr[[ "diffc" ]] <- detr[[ "Pmodel_S0" ]] - detr[[ "Pmodel_S1c" ]] 74 | 75 | stocker_fb <- get_stocker_f( detr$diffb, detr$Pmodel_S1b, isabs=FALSE ) 76 | 77 | # for (it in 1:5){ 78 | # ahlstroem_fb <- get_stocker_f( detr$Pmodel_S1b[,,((it-1)*7+1):((it-1)*7+7)], detr$Pmodel_S1b[,,((it-1)*7+1):((it-1)*7+7)], isabs=FALSE ) 79 | # plot_map( ahlstroem_fb*1e4, lev=seq(-1,1,0.2), positive=FALSE, maxval=30, minval=-30, file=paste0("fig/map_ahlstroem", as.character(it), ".pdf") ) # 80 | # } 81 | # ahlstroem_fb <- get_stocker_f( detr$Pmodel_S1b, detr$Pmodel_S1b, isabs=FALSE ) 82 | # plot_map( ahlstroem_fb*1e4, lev=seq(-1,1,0.2), positive=FALSE, maxval=30, minval=-30, file=paste0("fig/map_ahlstroem.pdf") ) # 83 | 84 | 85 | # ahlstroem_fb <- get_stocker_f( detr$Pmodel_S0, detr$Pmodel_S0, isabs=FALSE ) 86 | # plot_map( ahlstroem_fb*1e4, lev=seq(-1,1,0.2), positive=FALSE, maxval=30, minval=-30, file=paste0("fig/map_ahlstroem_s0.pdf") ) # 87 | 88 | # ##----------------------------------------------------- 89 | # ## Plot without inset 90 | # ##----------------------------------------------------- 91 | # plot_map( stocker_fb*1e4, lev=seq(-0.5,0.5,0.1), positive=FALSE, maxval=30, minval=-30 ) 92 | 93 | ##----------------------------------------------------- 94 | ## Plot with inset 95 | ##----------------------------------------------------- 96 | filn <- "fig/fig_4.pdf" 97 | 98 | arr = stocker_fb*1e4 99 | toplefttext = expression(paste("")) 100 | toprighttext = expression(paste("")) 101 | minval = -30 102 | maxval = 30 103 | color <- c( "royalblue4", "royalblue2", "wheat", "tomato2", "tomato4" ) 104 | lev = seq(-0.5,0.5,0.1) 105 | 106 | ## half degree resolution 107 | lon <- seq(-179.75, 179.75, 0.5) 108 | lat <- seq(-89.75, 89.75, 0.5) 109 | 110 | magn <- 4 111 | ncols <- 2 112 | nrows <- 1 113 | widths <- rep(1.6*magn,ncols) 114 | widths[1] <- 0.15*widths[1] 115 | heights <- rep(magn,nrows) 116 | order <- matrix( c(1,2), nrows, ncols, byrow=FALSE) 117 | 118 | ylim <- c(-60,85) 119 | lat.labels <- seq(-90, 90, 30) 120 | lat.short <- seq(-90, 90, 10) 121 | lon.labels <- seq(-180, 180, 60) 122 | lon.short <- seq(-180, 180, 10) 123 | 124 | a <- sapply( lat.labels, function(x) if (x>0) {bquote(.(x)*degree ~N)} else if (x==0) {bquote(.(x)*degree)} else {bquote(.(-x)*degree ~S)} ) 125 | b <- sapply( lon.labels, function(x) if (x>0) {bquote(.(x)*degree ~E)} else if (x==0) {bquote(.(x)*degree)} else {bquote(.(-x)*degree ~W)}) 126 | 127 | if (!is.na(filn)) pdf( filn, width=sum(widths), height=sum(heights) ) 128 | 129 | panel <- layout( 130 | order, 131 | widths=widths, 132 | heights=heights, 133 | TRUE 134 | ) 135 | # layout.show( panel ) 136 | 137 | ## Color key 138 | par( mar=c(2.5,3,1,1),xaxs="i", yaxs="i",las=1, mgp=c(3,1,0)) 139 | out.mycolorbar <- mycolorbar( color, lev, orient="v", plot=TRUE, maxval=maxval, minval=minval ) 140 | 141 | par( mar=c(2.5,2.5,1,1),xaxs="i", yaxs="i",las=1, mgp=c(3,1,0)) 142 | image( 143 | lon, lat, 144 | arr, 145 | ylim=c(-60,85), 146 | # zlim=range(lev), 147 | yaxt="n", xaxt="n", 148 | col=out.mycolorbar$colors, breaks=out.mycolorbar$margins, 149 | xlab="", ylab="" 150 | ) 151 | map( add=TRUE, interior=FALSE, resolution=0, lwd=0.5 ) 152 | 153 | axis( 2, at=lat.labels, lab=do.call(expression,a), cex.axis=0.7, lwd=1.5 ) 154 | axis( 2, at=lat.short, lab=F, lwd=1, tck=-0.01 ) 155 | 156 | axis( 4, at=lat.labels, lab=F, lwd=1.5 ) 157 | axis( 4, at=lat.short, lab=F, lwd=1, tck=-0.01 ) 158 | 159 | axis( 1, at=lon.labels, lab=do.call(expression,b), cex.axis=0.7, lwd=1.5 ) 160 | axis( 1, at=lon.short, lab=F, lwd=1, tck=-0.01 ) 161 | 162 | axis( 3, at=lon.labels, lab=F, lwd=1.5 ) 163 | axis( 3, at=lon.short, lab=F, lwd=1, tck=-0.01 ) 164 | 165 | mtext( expression(paste("GPP amplification of relative variance")), line=1, adj=0 ) 166 | mtext( expression(paste("fraction")), line=1, adj=1 ) 167 | 168 | rect( -179, -50, -100, 7.5, border = NA, col="white" ) 169 | 170 | ##----------------------------------------------------- 171 | ## Inset: Empirical cumulative distribution function of the amplification factor 172 | ##----------------------------------------------------- 173 | ## Inset 1 174 | u <- par("usr") 175 | v <- c( 176 | grconvertX(u[1:2], "user", "ndc"), 177 | grconvertY(u[3:4], "user", "ndc") 178 | ) 179 | v_orig <- v 180 | v <- c( v[1]+0.03, v[1]+0.2*v[2], v[3]+0.10*v[4], v[3]+0.32*v[4] ) 181 | par( fig=v, new=TRUE, mar=c(0,0,0,0), mgp=c(3,0.5,0) ) 182 | hist( arr, breaks=50, main="", freq = FALSE, xlim=c(-0.75,0.75), cex.axis=0.7, axes=FALSE, col="grey70" ) 183 | axis( 1, cex.axis=0.7 ) 184 | 185 | # plot( xlim, ylim, type="n", xlim=xlim, log="xy", ylim=ylim, xlab = "", ylab = "", bg="white", cex.axis=0.7, tck=-0.03 ) 186 | # mtext( "amplification", side=1, line=1, adj=0.5, cex = 0.7 ) 187 | # mtext( "ECDF", side=2, line=1.7, adj=0.5, cex = 0.7, las=0 ) 188 | # rect( xlim[1], ylim[1], xlim[2], ylim[2], border = NA, col="white" ) 189 | # curve( 1.0 - ecdf_ampl(x), from=xlim[1], to=xlim[2], col="red", add=TRUE ) 190 | # polygon( c( seq(xlim[1], xlim[2], by=0.1 ), rev( seq(xlim[1], xlim[2], by=0.1 ) ) ), c( 1 - ecdf_ampl_a( seq(xlim[1], xlim[2], by=0.1 ) ), rev( 1- ecdf_ampl_c( seq(xlim[1], xlim[2], by=0.1 ) ) ) ), border = NA, col = rgb(1,0,0,0.4) ) 191 | # abline( v=1, lty=3 ) 192 | # box() 193 | 194 | if (!is.na(filn)) dev.off() 195 | 196 | -------------------------------------------------------------------------------- /plot_aligned_all.R: -------------------------------------------------------------------------------- 1 | lmp <- function(modelobject) { 2 | if (class(modelobject) != "lm") stop("Not an object of class 'lm' ") 3 | f <- summary(modelobject)$fstatistic 4 | p <- pf(f[1],f[2],f[3],lower.tail=F) 5 | attributes(p) <- NULL 6 | return(p) 7 | } 8 | 9 | inverse <- function( x ){ 1/x } 10 | 11 | normalise <- function( x, norm ){ x/norm } 12 | 13 | smooth_runminmax <- function( x, y ){ 14 | source( "../utilities/cutna_headtail.R" ) 15 | idxs_drop <- cutna_headtail( y ) 16 | if (length(idxs_drop)>0) { x <- x[-idxs_drop] } 17 | if (length(idxs_drop)>0) { y <- y[-idxs_drop] } 18 | x[is.nan(x)] <- NA 19 | x[is.infinite(x)] <- NA 20 | fld <- approx( x, y, xout=x )$y 21 | min <- smooth.spline( x, caTools::runmin( fld, k=7 ), spar=0.01 )$y 22 | max <- smooth.spline( x, caTools::runmax( fld, k=7 ), spar=0.01 )$y 23 | tmp <- approx( x, zoo::rollmean( fld, k=7, fill=NA ), xout=x )$y 24 | idxs<- which(!is.na(tmp)) 25 | tmp <- smooth.spline( x[idxs], tmp[idxs], spar=0.01 )$y 26 | mean <- rep(NA, length(x)) 27 | mean[idxs] <- tmp 28 | return( list( x=x, min=min, max=max, mean=mean ) ) 29 | } 30 | 31 | spline_with_gaps <- function( xvals, yvals, nice, spar=NULL ){ 32 | idxs <- which( !is.na(yvals) & !is.nan(yvals) ) 33 | tmp <- smooth.spline( xvals[idxs], yvals[idxs], spar=spar ) 34 | tmp <- data.frame( year_dec=tmp$x, yvals=tmp$y ) 35 | nice <- nice %>% left_join( tmp, by="year_dec" ) 36 | return( nice$yvals ) 37 | } 38 | 39 | plot_aligned_all <- function( ddf, ddf_8d, filn=NA ){ 40 | ##------------------------------------------------ 41 | ## Aligned plots for all sites combined into clusters (3 rows) 42 | ##------------------------------------------------ 43 | require(dplyr) 44 | require(tidyr) 45 | source("../utilities/add_alpha.R") 46 | 47 | before <- 30 48 | after <- 100 49 | 50 | if (!is.na(filn)) pdf( plotfiln, width=6, height=5 ) 51 | 52 | ##-------------------------------------------------------- 53 | ## fLUE 54 | ##-------------------------------------------------------- 55 | par( las=1, mar=c(4,4,2,2), mgp=c(2.7,1,0), xpd=FALSE, xaxs="i", yaxs="r" ) 56 | # ylim <- c(0.5,1.1) 57 | ylim <- c(0.8,2.5) 58 | xlim <- c(-20,80) 59 | 60 | plot( c(-before,after), ylim, type="n", xlab="Days after drought onset", ylab=expression( paste( "fLUE"^-1, "and bias (mod./obs., fraction)")), axes=FALSE, xlim=xlim ) 61 | 62 | axis( 2, lwd = 1.5 ) 63 | axis( 2, at = seq( ylim[1], ylim[2], by=0.05 ), labels = FALSE, tck=-0.01 ) 64 | axis( 4, labels=FALSE, lwd = 1.5 ) 65 | axis( 4, at = seq( ylim[1], ylim[2], by=0.05 ), labels = FALSE, tck=-0.01 ) 66 | axis( 1, xlab="days after drought onset", lwd=1.5 ) 67 | axis( 1, at = seq( xlim[1], xlim[2], by=5 ), labels = FALSE, tck=-0.01 ) 68 | axis( 3, labels=FALSE, lwd=1.5 ) 69 | axis( 3, at = seq( xlim[1], xlim[2], by=5 ), labels = FALSE, tck=-0.01 ) 70 | abline( h=1.0, col='grey40', lwd=0.5 ) 71 | 72 | axis(1,lwd=1.5); axis(1,at=seq(xlim[1],xlim[2],by=20),labels=F,tck=-0.01) 73 | rect( 0, -99, after, 99, col=colorRampPalette( c("wheat3", "white") )( 5 )[2], border=NA ) # rgb(0,0,0,0.2) 74 | 75 | box( lwd=1.5 ) 76 | 77 | ## Get median level of the three variables within each bin, pooling data for all days and instances (drought events) 78 | median <- ddf %>% group_by( dday ) %>% 79 | summarise( fvar = median( 1/fvar , na.rm=TRUE ) ) %>% 80 | complete( dday ) 81 | upper <- ddf %>% group_by( dday ) %>% 82 | summarise( fvar = quantile( 1/fvar, 0.75, na.rm=TRUE ) ) %>% 83 | complete( dday ) 84 | lower <- ddf %>% group_by( dday ) %>% 85 | summarise( fvar = quantile( 1/fvar, 0.25, na.rm=TRUE ) ) %>% 86 | complete( dday ) 87 | 88 | polygon( c( median$dday, rev(median$dday) ), c( lower$fvar, rev(upper$fvar) ), col=add_alpha("black", 0.3), border=NA ) 89 | lines( median, col='black', lwd=2 ) 90 | 91 | 92 | ##-------------------------------------------------------- 93 | ## Bias P-model 94 | ##-------------------------------------------------------- 95 | ## Get median level of the three variables within each bin, pooling data for all days and instances (drought events) 96 | median <- ddf %>% group_by( dday ) %>% 97 | summarise( bias = median( bias_pmodel_norm , na.rm=TRUE ) ) %>% 98 | complete( dday ) 99 | upper <- ddf %>% group_by( dday ) %>% 100 | summarise( bias = quantile( bias_pmodel_norm, 0.75, na.rm=TRUE ) ) %>% 101 | complete( dday ) 102 | lower <- ddf %>% group_by( dday ) %>% 103 | summarise( bias = quantile( bias_pmodel_norm, 0.25, na.rm=TRUE ) ) %>% 104 | complete( dday ) 105 | 106 | # polygon( c( median$dday, rev(median$dday) ), c( lower$bias, rev(upper$bias) ), col=add_alpha("tomato", 0.3), border=NA ) 107 | lines( median, col='tomato', lwd=2 ) 108 | 109 | ##-------------------------------------------------------- 110 | ## Bias BESS 111 | ##-------------------------------------------------------- 112 | ## Get median level of the three variables within each bin, pooling data for all days and instances (drought events) 113 | median <- ddf %>% group_by( dday ) %>% 114 | summarise( bias = median( bias_bess_v1_norm , na.rm=TRUE ) ) %>% 115 | complete( dday ) 116 | upper <- ddf %>% group_by( dday ) %>% 117 | summarise( bias = quantile( bias_bess_v1_norm, 0.75, na.rm=TRUE ) ) %>% 118 | complete( dday ) 119 | lower <- ddf %>% group_by( dday ) %>% 120 | summarise( bias = quantile( bias_bess_v1_norm, 0.25, na.rm=TRUE ) ) %>% 121 | complete( dday ) 122 | 123 | # polygon( c( median$dday, rev(median$dday) ), c( lower$bias, rev(upper$bias) ), col=add_alpha("royalblue3", 0.3), border=NA ) 124 | lines( median, col='royalblue3', lwd=2 ) 125 | 126 | ##-------------------------------------------------------- 127 | ## Bias MODIS 128 | ##-------------------------------------------------------- 129 | ## Get median level of the three variables within each bin, pooling data for all days and instances (drought events) 130 | median <- ddf_8d %>% group_by( dday ) %>% 131 | summarise( bias = median( bias_modis_norm , na.rm=TRUE ) ) %>% 132 | complete( dday ) 133 | upper <- ddf_8d %>% group_by( dday ) %>% 134 | summarise( bias = quantile( bias_modis_norm, 0.75, na.rm=TRUE ) ) %>% 135 | complete( dday ) 136 | lower <- ddf_8d %>% group_by( dday ) %>% 137 | summarise( bias = quantile( bias_modis_norm, 0.25, na.rm=TRUE ) ) %>% 138 | complete( dday ) 139 | 140 | # polygon( c( median$dday, rev(median$dday) ), c( lower$bias, rev(upper$bias) ), col=add_alpha("springgreen1", 0.3), border=NA ) 141 | lines( median, col='orchid', lwd=2 ) 142 | 143 | ##-------------------------------------------------------- 144 | ## Bias VPM 145 | ##-------------------------------------------------------- 146 | ## Get median level of the three variables within each bin, pooling data for all days and instances (drought events) 147 | median <- ddf_8d %>% group_by( dday ) %>% 148 | summarise( bias = median( bias_vpm_norm , na.rm=TRUE ) ) %>% 149 | complete( dday ) 150 | upper <- ddf_8d %>% group_by( dday ) %>% 151 | summarise( bias = quantile( bias_vpm_norm, 0.75, na.rm=TRUE ) ) %>% 152 | complete( dday ) 153 | lower <- ddf_8d %>% group_by( dday ) %>% 154 | summarise( bias = quantile( bias_vpm_norm, 0.25, na.rm=TRUE ) ) %>% 155 | complete( dday ) 156 | 157 | # polygon( c( median$dday, rev(median$dday) ), c( lower$bias, rev(upper$bias) ), col=add_alpha("springgreen4", 0.3), border=NA ) 158 | lines( median, col='springgreen3', lwd=2 ) 159 | 160 | legend( "topleft", c( expression(paste("fLUE"^-1)), "P-model", "BESS", "MODIS", "VPM"), bty="n", lty=1, lwd=2, col=c( "black" ,"tomato", "royalblue3","orchid", "springgreen3"), cex=1.0 ) 161 | 162 | if (!is.na(filn)) dev.off() 163 | 164 | } 165 | 166 | # ##------------------------------------------------ 167 | # ## Select all sites for which method worked (codes 1 and 2 determined by 'nn_getfail_fluxnet2015.R') 168 | # ##------------------------------------------------ 169 | # load( "data/data_aligned_agg.Rdata" ) 170 | # plot_aligned_all( df_dday_agg, df_dday_8d_agg, filn=NA ) 171 | 172 | -------------------------------------------------------------------------------- /plot_bias_nn_8d.R: -------------------------------------------------------------------------------- 1 | syshome <- Sys.getenv( "HOME" ) 2 | source( paste( syshome, "/.Rprofile", sep="" ) ) 3 | 4 | require(dplyr) 5 | require(LSD) 6 | 7 | source( "analyse_modobs.R" ) 8 | source( "remove_outliers.R" ) 9 | source( "compl_df_flue_est.R" ) 10 | 11 | getpeak <- function( vec ) { 12 | vec <- vec[!is.na(vec)] %>% remove_outliers( coef=5.0 ) 13 | dens <- density( vec, kernel=c("gaussian") ) 14 | peak <- dens$x[ dens$y==max(dens$y) ] 15 | return( peak ) 16 | } 17 | 18 | getlhalfpeak <- function( vec, lev=0.5 ) { 19 | require(dplyr) 20 | vec <- vec[!is.na(vec)] %>% remove_outliers( coef=5.0 ) 21 | dens <- density( vec, kernel=c("gaussian") ) 22 | peak <- dens$x[dens$y==max(dens$y)] 23 | df_tmp <- tibble( x=dens$x, y=dens$y ) %>% filter( x% remove_outliers( coef=5.0 ) 31 | dens <- density( vec, kernel=c("gaussian") ) 32 | peak <- dens$x[dens$y==max(dens$y)] 33 | df_tmp <- tibble( x=dens$x, y=dens$y ) %>% filter( x>peak ) 34 | halfpeak <- df_tmp$x[ which.min( abs( df_tmp$y - lev * max(dens$y) ) ) ] 35 | return( halfpeak ) 36 | } 37 | 38 | 39 | siteinfo <- read.csv( paste( myhome, "sofun/input_fluxnet2015_sofun/siteinfo_fluxnet2015_sofun.csv", sep="") ) 40 | 41 | ## Load aligned aggregated data 42 | load( "data/data_aligned_agg.Rdata" ) # loads 'df_dday_agg', 'df_dday_8d_agg', 'df_dday_mte_agg', 'df_dday_bess_agg', 'df_dday_vpm_agg' 43 | 44 | # ## Estimate soil moisture correction (adds column 'flue_est' to dataframe) 45 | # load( "data/linearfit2_ratio.Rdata" ) 46 | # df_dday_8d_agg <- compl_df_flue_est( df_dday_8d_agg, linearfit2, x0_fix=0.9 ) 47 | 48 | ## group data by fLUE 49 | nbins <- 10 50 | binwidth <- 1.0/nbins 51 | fvarbins <- seq( from=0, to=1, by=binwidth ) 52 | xvals <- fvarbins[1:nbins]+binwidth/2 53 | 54 | df_dday_8d_agg <- df_dday_8d_agg %>% mutate( infvarbin = cut( fvar, breaks = fvarbins ) ) %>% 55 | mutate( ifelse( is.nan(ratio_obs_mod_pmodel), NA, ratio_obs_mod_pmodel ) ) 56 | 57 | ##------------------------------------------------ 58 | ## GPPobs/GPPmod vs. fLUE 59 | ##------------------------------------------------ 60 | 61 | ## panel setup 62 | magn <- 3 63 | ncols <- 2 64 | nrows <- 3 65 | widths <- c(magn, 0.92*magn ) 66 | heights <- 1.2*c(0.6*magn,0.6*magn,0.7*magn) 67 | order <- matrix(seq(ncols*nrows),nrows,ncols,byrow=TRUE) 68 | 69 | pdf( "fig/bias_vs_fvar_uncorrected_8d.pdf", width=sum(widths), height=sum(heights) ) 70 | 71 | panel <- layout( 72 | order, 73 | widths=widths, 74 | heights=heights, 75 | TRUE 76 | ) 77 | # layout.show(panel) 78 | 79 | #--------------------------------------------------------- 80 | # P-model 81 | #--------------------------------------------------------- 82 | ## point cloud 83 | par( las=1, mar=c(2,4.5,2.5,1) ) 84 | xlim <- c(0,1.2) 85 | ylim <- c(0,2.5) 86 | with( 87 | filter( df_dday_8d_agg, ratio_obs_mod_pmodel<5 ), # necessary to get useful bins with heatscatter() 88 | heatscatter( 89 | fvar, 90 | ratio_obs_mod_pmodel, 91 | xlab="", 92 | ylab="GPP observed / GPP modelled", 93 | xlim=xlim, 94 | ylim=ylim, 95 | main="", 96 | cexplot = 1.2 97 | ) 98 | ) 99 | 100 | abline( h=1.0, lwd=0.5, lty=2 ) 101 | abline( v=1.0, lwd=0.5, lty=2 ) 102 | lines( c(-99,99), c(-99,99), col='black' ) 103 | mtext( "P-model", line=0.5, adj=0, font=2, cex=0.8 ) 104 | 105 | ## draw the legend 106 | legend( "topleft", legend=c("low density", "", "", "", "high density"), pch=19, col=colorRampPalette( c("gray60", "navy", "red", "yellow"))(5), bty="n", cex=0.8 ) 107 | 108 | #--------------------------------------------------------- 109 | # MODIS 110 | #--------------------------------------------------------- 111 | par( las=1, mar=c(2,2.5,2.5,1) ) 112 | xlim <- c(0,1.2) 113 | ylim <- c(0,3) 114 | with( 115 | filter( df_dday_8d_agg, ratio_obs_mod_modis<5 ), # necessary to get useful bins with heatscatter() 116 | heatscatter( 117 | fvar, 118 | ratio_obs_mod_modis, 119 | xlab="", 120 | ylab="", 121 | xlim=xlim, 122 | ylim=ylim, 123 | cexplot=1.2, 124 | main="" 125 | ) 126 | ) 127 | 128 | abline( h=1.0, lwd=0.5, lty=2 ) 129 | abline( v=1.0, lwd=0.5, lty=2 ) 130 | lines( c(-99,99), c(-99,99), col='black' ) 131 | mtext( "MOD17A2H", line=0.5, adj=0, font=2, cex=0.8 ) 132 | 133 | #--------------------------------------------------------- 134 | # BESS v1 135 | #--------------------------------------------------------- 136 | par( las=1, mar=c(2,4.5,2.5,1) ) 137 | xlim <- c(0,1.2) 138 | ylim <- c(0,3) 139 | with( 140 | filter( df_dday_8d_agg, ratio_obs_mod_bess_v1<5 ), # necessary to get useful bins with heatscatter() 141 | heatscatter( 142 | fvar, 143 | ratio_obs_mod_bess_v1, 144 | xlab="", 145 | ylab="GPP observed / GPP modelled", 146 | xlim=xlim, 147 | ylim=ylim, 148 | main="", 149 | cexplot = 1.2 150 | ) 151 | ) 152 | 153 | abline( h=1.0, lwd=0.5, lty=2 ) 154 | abline( v=1.0, lwd=0.5, lty=2 ) 155 | lines( c(-99,99), c(-99,99), col='black' ) 156 | mtext( "BESS v1", line=0.5, adj=0, font=2, cex=0.8 ) 157 | 158 | 159 | #--------------------------------------------------------- 160 | # BESS v2 161 | #--------------------------------------------------------- 162 | par( las=1, mar=c(2,2.5,2.5,1) ) 163 | xlim <- c(0,1.2) 164 | ylim <- c(0,3) 165 | with( 166 | filter( df_dday_8d_agg, ratio_obs_mod_bess_v2<5 ), # necessary to get useful bins with heatscatter() 167 | heatscatter( 168 | fvar, 169 | ratio_obs_mod_bess_v2, 170 | xlab="", 171 | ylab="", 172 | xlim=xlim, 173 | ylim=ylim, 174 | main="", 175 | cexplot = 1.2 176 | ) 177 | ) 178 | 179 | abline( h=1.0, lwd=0.5, lty=2 ) 180 | abline( v=1.0, lwd=0.5, lty=2 ) 181 | lines( c(-99,99), c(-99,99), col='black' ) 182 | mtext( "BESS v2", line=0.5, adj=0, font=2, cex=0.8 ) 183 | 184 | #--------------------------------------------------------- 185 | # VPM 186 | #--------------------------------------------------------- 187 | par( las=1, mar=c(4,4.5,2.5,1) ) 188 | xlim <- c(0,1.2) 189 | ylim <- c(0,3) 190 | with( 191 | filter( df_dday_8d_agg, ratio_obs_mod_vpm<5 ), # necessary to get useful bins with heatscatter() 192 | heatscatter( 193 | fvar, 194 | ratio_obs_mod_vpm, 195 | xlab="fLUE", 196 | ylab="GPP observed / GPP modelled", 197 | xlim=xlim, 198 | ylim=ylim, 199 | cexplot=1.2, 200 | main="" 201 | ) 202 | ) 203 | 204 | abline( h=1.0, lwd=0.5, lty=2 ) 205 | abline( v=1.0, lwd=0.5, lty=2 ) 206 | lines( c(-99,99), c(-99,99), col='black' ) 207 | mtext( "VPM", line=0.5, adj=0, font=2, cex=0.8 ) 208 | 209 | #--------------------------------------------------------- 210 | # MTE 211 | #--------------------------------------------------------- 212 | par( las=1, mar=c(4,2.5,2.5,1) ) 213 | with( 214 | filter( df_dday_8d_agg, ratio_obs_mod_mte<5 ), # necessary to get useful bins with heatscatter() 215 | heatscatter( 216 | fvar, 217 | ratio_obs_mod_mte, 218 | xlab="fLUE", 219 | ylab="", 220 | xlim=xlim, 221 | ylim=ylim, 222 | cexplot=1.2, 223 | main="" 224 | ) 225 | 226 | ) 227 | abline( h=1.0, lwd=0.5, lty=2 ) 228 | abline( v=1.0, lwd=0.5, lty=2 ) 229 | lines( c(-99,99), c(-99,99), col='black' ) 230 | mtext( "FLUXCOM MTE", line=0.5, adj=0, font=2, cex=0.8 ) 231 | 232 | 233 | dev.off() 234 | 235 | 236 | -------------------------------------------------------------------------------- /get_extremes_zscheischler.R: -------------------------------------------------------------------------------- 1 | # make anomalies 2 | require(raster) 3 | require(neuroim) 4 | require(dplyr) 5 | require(ncdf4) 6 | require(lubridate) 7 | 8 | myboxplot <- function( ... ){ 9 | boxplot( ..., staplewex=0, whisklty=1, outline=FALSE ) 10 | } 11 | 12 | 13 | ##----------------------- 14 | overwrite <- FALSE 15 | ##----------------------- 16 | 17 | outfile <- "data/extremes.Rdata" 18 | nconts <- 5 19 | 20 | ##------------------------------------------------------------ 21 | ## Identify events 22 | ##------------------------------------------------------------ 23 | if (!file.exists(outfile)||overwrite){ 24 | 25 | ## Define continents from SREX regions 26 | # SREX <- raster("/net/exo/landclim/data/dataset/SREX-Region-Masks/20120709/0.5deg_lat-lon_time-invariant/processed/netcdf/srex-region-masks_20120709.srex_mask_SREX_masks_all.05deg.time-invariant.nc") 27 | SREX <- raster("~/data/landmasks/srex-region-masks_20120709.srex_mask_SREX_masks_all.05deg.time-invariant.nc") 28 | subsets <- list() 29 | 30 | # subsets[[1]] <- 1:6 # north plus central america 31 | # subsets[[2]] <- 7:10 # south america 32 | # subsets[[3]] <- 11:13 # europe 33 | # subsets[[4]] <- 14:17 # africa 34 | # subsets[[5]] <- 18:23 # asia excluding southeast asia (24) 35 | # subsets[[6]] <- 24:26 # australia 36 | 37 | subsets[[1]] <- 1:6 # north plus central america 38 | subsets[[2]] <- 7:10 # south america 39 | subsets[[3]] <- c(11:13, 18:23) # europe + asia 40 | subsets[[4]] <- 14:17 # africa 41 | subsets[[5]] <- 24:26 # australia 42 | 43 | nconts <- length(subsets) 44 | 45 | CC_list <- list() 46 | 47 | idx_largest <- list() 48 | 49 | fit_s0 <- list() 50 | fit_s1a <- list() 51 | fit_s1b <- list() 52 | fit_s1c <- list() 53 | 54 | IMPACT_s0 <- list() 55 | IMPACT_s1a <- list() 56 | IMPACT_s1b <- list() 57 | IMPACT_s1c <- list() 58 | 59 | ## load monthly anomalies created beforehand with 'proc_nc_fields.sh' 60 | print("loading anomaly files...") 61 | ANOM_s0_all <- brick("~/data/pmodel_fortran_output/v2/gpp_pmodel_s0_MON_ANOM.nc") 62 | ANOM_s1a_all <- brick("~/data/pmodel_fortran_output/v2/gpp_pmodel_s1a_MON_ANOM.nc") 63 | ANOM_s1b_all <- brick("~/data/pmodel_fortran_output/v2/gpp_pmodel_s1b_MON_ANOM.nc") 64 | ANOM_s1c_all <- brick("~/data/pmodel_fortran_output/v2/gpp_pmodel_s1c_MON_ANOM.nc") 65 | 66 | ## reorder dimensions and multiply with gridcell surface area 67 | print("reorder dimensions...") 68 | ANOM_s0.a <- aperm(as.array(ANOM_s0_all * area(ANOM_s0_all)),c(2,1,3))[,360:1,] 69 | ANOM_s1a.a <- aperm(as.array(ANOM_s1a_all * area(ANOM_s1a_all)),c(2,1,3))[,360:1,] 70 | ANOM_s1b.a <- aperm(as.array(ANOM_s1b_all * area(ANOM_s1b_all)),c(2,1,3))[,360:1,] 71 | ANOM_s1c.a <- aperm(as.array(ANOM_s1c_all * area(ANOM_s1c_all)),c(2,1,3))[,360:1,] 72 | 73 | ## Loop over continents 74 | latx <- 360 75 | for (j in 1:nconts) { 76 | 77 | print(paste("continent",as.character(j),"/ ", as.character(nconts) )) 78 | 79 | # define mask for only 1 continent 80 | Na <- SREX %in% subsets[[j]] 81 | 82 | ## mask out values 83 | ANOM_s1a <- mask( ANOM_s1a_all, Na, maskvalue=0 ) 84 | ANOM_s1b <- mask( ANOM_s1b_all, Na, maskvalue=0 ) 85 | ANOM_s1c <- mask( ANOM_s1c_all, Na, maskvalue=0 ) 86 | 87 | ## get quantiles based on simulation s1c 88 | q_all <- quantile( as.vector(ANOM_s1b), c(0.01,0.02,0.03,0.05,0.1,0.9,0.95), na.rm = TRUE ) 89 | 90 | # same quantiles (computed over the combined dataset) 91 | EXT05_s1b <- ANOM_s1b < q_all[2] 92 | 93 | EXT05_s1b <- aperm( as.array(EXT05_s1b), c(2,1,3) )[,latx:1,] == TRUE 94 | print(" identifying events...") 95 | CC_s1 <- connComp3D( EXT05_s1b ) 96 | 97 | ## keep only events gt 200 98 | print(" calculating impacts...") 99 | CC_s1$index[CC_s1$size < 50] <- 0 100 | 101 | # make list with indices pointing to equal index 102 | # CC_s1$list are the indeces pointing to respective events, it's a list with length equal number of events 103 | CC_s1$list <- sapply( 1:max(CC_s1$index), function(x) which(CC_s1$index == x) ) 104 | 105 | # find largest extremes defined by impact 106 | IMPACT_s0[[j]] <- unlist( lapply( CC_s1$list, function(x) sum(ANOM_s0.a[x])) ) 107 | IMPACT_s1a[[j]] <- unlist( lapply( CC_s1$list, function(x) sum(ANOM_s1a.a[x])) ) 108 | IMPACT_s1b[[j]] <- unlist( lapply( CC_s1$list, function(x) sum(ANOM_s1b.a[x])) ) 109 | IMPACT_s1c[[j]] <- unlist( lapply( CC_s1$list, function(x) sum(ANOM_s1c.a[x])) ) 110 | 111 | # attach to list 112 | CC_list[[j]] <- CC_s1 113 | 114 | } 115 | 116 | print("saving...") 117 | save( CC_list, IMPACT_s0, IMPACT_s1a, IMPACT_s1b, IMPACT_s1c, file=outfile ) 118 | 119 | } else { 120 | 121 | load(outfile) 122 | 123 | } 124 | 125 | ##------------------------------------------------------------ 126 | ## Get size of events (impact), dataframe 127 | ##------------------------------------------------------------ 128 | ## Size difference of the 10 largest extremes 129 | ## sort by descending s1c impacts 130 | print("constructing impacts dataframe...") 131 | list_impacts <- list() 132 | for (icont in 1:nconts){ 133 | df_impacts <- tibble( s0 = IMPACT_s0[[icont]], s1a = IMPACT_s1a[[icont]], s1b = IMPACT_s1b[[icont]], s1c = IMPACT_s1c[[icont]] ) %>% 134 | filter( s0<0 & s1a<0 & s1b<0 & s1c<0 ) %>% 135 | mutate( rank = rank( s1b ), 136 | ampl_s1a = s1a / s0, 137 | ampl_s1b = s1b / s0, 138 | ampl_s1c = s1c / s0, 139 | icont = icont, 140 | event_no = 1:nrow(.) 141 | ) %>% 142 | mutate( ampl_mean = rowMeans( dplyr::select(., starts_with("ampl")) ) ) 143 | list_impacts[[icont]] <- df_impacts 144 | } 145 | 146 | ## combine list into single dataframe (tibble) and get rank by size across all continents (impact in s1b) 147 | df_impacts <- bind_rows( list_impacts ) %>% 148 | mutate( rank_global = rank( s1b ) ) %>% 149 | arrange( s1b ) 150 | 151 | ##------------------------------------------------------------ 152 | ## Save all data needed for plotting later (plot_fig_5.R) 153 | ##------------------------------------------------------------ 154 | save( df_impacts, list_impacts, ANOM_s0.a, ANOM_s1b.a, CC_list, file = "data/impacts_extremes.Rdata") 155 | 156 | ##------------------------------------------------------------ 157 | ## Locate events in time and space (only 141 biggest) 158 | ##------------------------------------------------------------ 159 | ## integrate over ten largest events globally 160 | ## get dates from NetCDF file 161 | print("plot events...") 162 | nc <- nc_open( "/alphadata01/bstocker//data/pmodel_fortran_output/v2/gpp_pmodel_s0_MON_ANOM.nc" ) 163 | nc_close(nc) 164 | date <- ymd( "2001-01-01" ) + days( floor(nc$dim$time$vals) ) 165 | nevents <- 200 166 | 167 | overwrite_located <- TRUE 168 | filn_located <- "data/extremes_located.Rdata" 169 | 170 | if (file.exists(filn_located)&&!overwrite_located){ 171 | 172 | load( filn_located ) 173 | 174 | } else { 175 | 176 | list_event_time <- list() 177 | list_event_lonlat <- list() 178 | 179 | df_event_time <- tibble() 180 | arr_event_lonlat <- array( NA, dim = c(720,360,nevents) ) 181 | addmap <- FALSE 182 | 183 | for (irank in 1:nevents){ 184 | 185 | print( paste( " event ranked", as.character(irank) ) ) 186 | tmp <- df_impacts %>% filter( rank_global==irank ) 187 | myicont <- tmp$icont 188 | myevent_no <- tmp$event_no 189 | rank_global <- tmp$rank_global 190 | 191 | ## create array that contains anomaly for voxels in this event and NA otherwise 192 | ## ... based on s0 193 | LargestE_s0 <- NA * ANOM_s0.a 194 | LargestE_s0[CC_list[[myicont]]$list[[myevent_no]]] <- ANOM_s0.a[CC_list[[myicont]]$list[[myevent_no]]] 195 | 196 | ## ... based on s1b 197 | LargestE_s1b <- NA * ANOM_s1b.a 198 | LargestE_s1b[CC_list[[myicont]]$list[[myevent_no]]] <- ANOM_s1b.a[CC_list[[myicont]]$list[[myevent_no]]] 199 | 200 | ## integrate over lon-lat, projecting onto time 201 | event_time_s0 <- apply( LargestE_s0 , 3, sum, na.rm = TRUE ) * 1e-15 202 | event_time_s1b <- apply( LargestE_s1b, 3, sum, na.rm = TRUE ) * 1e-15 203 | 204 | addrows <- tibble( date=date, year=year(date), month=month(date), impact_s0=event_time_s0, impact_s1b=event_time_s1b, icont=myicont, event_no=myevent_no, rank_global=rank_global ) %>% 205 | filter( abs(impact_s0)>0 | abs(impact_s1b)>0 ) 206 | df_event_time <- bind_rows( df_event_time, addrows ) 207 | 208 | ## integrate over time, projecting into lon-lat, based on s1b 209 | arr_event_lonlat[,,irank] <- apply( LargestE_s1b, 1:2, sum, na.rm = TRUE ) 210 | arr_event_lonlat[ arr_event_lonlat==0 ] <- NA 211 | 212 | ## plot map of impact, integrated over time 213 | # yearchar <- df_event_time %>% dplyr::filter( event_no==myevent_no & icont==myicont ) %>% mutate( year=year(date)) %>% dplyr::select(year) %>% table() %>% sort() %>% names() 214 | # if (irank <= nevents_plot) plot_map( -arr_event_lonlat[,,irank], col = cols[irank], add=addmap, file=paste0( "fig/map_event_", sprintf( "%02d", irank ), ".pdf" ), text=yearchar[1] ) 215 | 216 | } 217 | 218 | save( arr_event_lonlat, df_event_time, file=filn_located ) 219 | 220 | } 221 | --------------------------------------------------------------------------------