├── plots ├── fcn │ ├── animated_gif_libraries.r │ ├── empty_ggplot.R │ ├── make_lpx_mask_overalltimes.r │ ├── global_map_ggplot.r │ ├── average_grids.r │ ├── levelplot_forgif_wetloss_only.R │ ├── levelplot_forgif.R │ ├── timeline_drainage_country_facet.r │ └── gif_wetloss_wetchimp_20thcentury.r ├── map │ ├── old │ │ ├── map_libraries.r │ │ ├── map_stdev_natwetl_at1700.r │ │ ├── combine_maps.r │ │ ├── map_period_max_wetloss_rate.r │ │ ├── ggplot_wetlossmap_0.5_blank.r │ │ ├── ggplot_wetlossmap_0.5.r │ │ └── ggplot_wetlossmap.R │ ├── get_davidson_histcase_polygons.r │ ├── map_historical_cases_poly_v2.r │ ├── map_historical_cases_poly.r │ └── get_wetindex_points.r ├── themes │ ├── gif_map_theme.r │ ├── map_theme.r │ ├── line_plot_theme.r │ └── map_raster_theme.r ├── artif_drainage │ ├── cultiv_wetland_only_percountryarea.r │ ├── lineplot │ │ ├── facet_sigmoid_all_national.r │ │ └── facet_sigmoid_all.r │ ├── lineplot_drainage_interpolated_1000ha.r │ ├── barplot_totaldrainage.r │ ├── lineplot_drainage_inter_n_extrapol_1000ha.r │ ├── old │ │ ├── map_forestry_drainage_stats.R │ │ ├── map_peatland_drainage_stats.R │ │ └── map_artif_drainage_stats.r │ ├── map_percent_drained.r │ └── peat_extr_cumul_plot_si.r ├── lineplot │ ├── line_plot_sum_nat_wetland_20th.R │ ├── old │ │ ├── line_plot_remwer_per_wettype.r │ │ ├── line_plot_remwet_ensemble_global.R │ │ ├── line_plot_remwet_perc_since1700.R │ │ ├── line_plot_facet_comparison_remwet_histcases.r │ │ ├── line_plot_stocker_sum_wet_peat_area.R │ │ └── line_plot_remwet_global.R │ └── line_plot_sum_nat_wetland_all.R ├── fit │ └── theta_boxplot.r ├── fig2abcd │ ├── fig1a_2022_drainarea.r │ ├── fig1c_wetland1700.R │ └── fig1b_2022_preswet.r ├── wetloss_drivers │ ├── stacked_area_plot_global_wetloss_n_remaining.r │ └── stacked_area_plot_global_wetloss_since1700.r ├── gif │ ├── gif_map_monthly_stocker_wetarea.R │ └── gif_wetloss_since1700.R ├── fig3abc │ ├── fig3_2021_v2.r │ ├── fig3_2021.r │ └── fig3a_2021.r ├── hist_cases │ ├── fig4ab_histcases.r │ └── line_plot_historical_cases.r ├── nat_wet │ └── barplot_wetchimp_area.r └── si_figures │ └── si_figures.r └── data_proc ├── fcn ├── latin_hypercube.r ├── fcn_ifrm.r ├── import_libraries.r ├── fcn_get_polygons_for_histcases.r ├── get_hydecroparea_in_polygons.r ├── fcn_raster_in_poly_sum_area.r └── fcn_get_polygons_for_drainage.r ├── distrib_drainage ├── fcn_distrib │ ├── fcn_print_distrib_ticker.r │ ├── fcn_make_perc_overlap.r │ ├── fcn_distrib_drainage_theta.r │ └── fcn_distrib_drainage_pasture.r ├── make_grid_isocodes.r └── bayesian_param_fit_with_df_v2.r ├── artif_drainage ├── old │ ├── combine_drainage_wetcultiv_data.r │ ├── us_subnat_drainage.r │ ├── apply_sigmoid_drained.r │ ├── make_cropland_shp.R │ ├── make_forestry_shp.r │ ├── make_peatland_shp.r │ ├── read_nat_artif_drainage_v2.r │ ├── get_forestry_in_drain_countries.R │ └── get_cropland_in_drain_countries.r ├── comb_interp_drainage_wetcult.r └── apply_sigmoid_drained_nat.r ├── fit ├── mcmc_init │ ├── fix_poland_subnat.r │ ├── init_grid_template.r │ ├── init_drainage_stats.r │ ├── init_nat_grid_isocode.r │ ├── init_natwet.r │ ├── init_davidson_histcases.r │ ├── init_perc_crop_drained.r │ ├── init_potwet_every_run.r │ └── init_drainage_stats_subnat.r ├── fcn_run_modfit.r ├── modfit │ ├── fcn_run_modfit.r │ └── compile_modfit_pars.r ├── fcn_run_mcmc.r ├── mcmc_fit │ ├── fcn_run_mcmc.r │ ├── members │ │ ├── run_mcmc_s2_p1.r │ │ ├── run_mcmc_s2_p2.r │ │ ├── run_mcmc_s2_p3.r │ │ ├── run_mcmc_s3_p1.r │ │ ├── run_mcmc_s3_p2.r │ │ ├── run_mcmc_s3_p3.r │ │ ├── run_mcmc_s4_p1.r │ │ ├── run_mcmc_s4_p2 .r │ │ ├── run_mcmc_s4_p3.r │ │ ├── run_mcmc_s1_p1.r │ │ ├── run_mcmc_s1_p2.r │ │ └── run_mcmc_s1_p3.r │ ├── fcn_make_wetloss_df.r │ ├── fcn_get_pars_range.r │ └── run_finalmap_lh_pars.R ├── compile_mcmc_pars.r ├── calc_sum_remwet_ci_range.r └── run_fit_2021.r ├── natwet ├── preswet │ ├── make_preswet_swampsglwd.r │ ├── get_corr_layers.R │ └── agg_glwd3_preswet.r ├── potwet │ ├── prep_potwet_v2.r │ └── prep_potwet.r └── old │ ├── make_ensemble_fromoverlays.r │ └── make_ensemble_fromoverlays_w6000bc.r ├── hist_cases ├── get_davidson2014_cases.r ├── wetindex_calc_loss.r ├── format_historical_cases.r ├── old │ └── ensemble_mean_grid_peryear.r ├── make_polygon_histcases_nat_subnat.r └── prep_peat_hist_cases_2021.r └── overlay └── get_drainage_stat_subset_for_distrib.r /plots/fcn/animated_gif_libraries.r: -------------------------------------------------------------------------------- 1 | library(rasterVis) 2 | library(ncdf4) 3 | library(dplyr) 4 | library(animation) 5 | library(raster) 6 | library(rasterVis) 7 | library(maptools) 8 | library(maps) 9 | library(animation) 10 | -------------------------------------------------------------------------------- /plots/map/old/map_libraries.r: -------------------------------------------------------------------------------- 1 | library(rworldmap) 2 | 3 | library(sp) 4 | library(maptools) 5 | library(rgdal) 6 | library(rgeos) 7 | library(raster) 8 | library(ggmap) 9 | library(scales) 10 | library(RColorBrewer) 11 | #library(Cairo) 12 | library(ggridges) -------------------------------------------------------------------------------- /plots/map/old/map_stdev_natwetl_at1700.r: -------------------------------------------------------------------------------- 1 | remwet_Mkm2_stack <- readRDS('./output/results/wetloss/grid/remwet_Mkm2_stack_0.5deg.rds') 2 | 3 | 4 | 5 | ## this is probably not the right one to use 6 | remwet_Mkm2_stack <- sel.by.pattern(remwet_Mkm2_stack, "1700") 7 | remwet_Mkm2_stack <- sel.by.pattern(remwet_Mkm2_stack, "rdm") 8 | 9 | remwet_Mkm2_stack_rng <- max(remwet_Mkm2_stack) - min(remwet_Mkm2_stack) 10 | 11 | -------------------------------------------------------------------------------- /plots/themes/gif_map_theme.r: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | gif_map_theme <- function(base_size=7){ 5 | theme_minimal() + 6 | 7 | theme(legend.position=c(0.1, 0.4), 8 | legend.title = element_blank(), 9 | axis.line = element_blank(), 10 | axis.text = element_blank(), 11 | axis.title = element_blank(), 12 | panel.grid.major = element_blank(), 13 | panel.grid.minor = element_blank()) } 14 | -------------------------------------------------------------------------------- /data_proc/fcn/latin_hypercube.r: -------------------------------------------------------------------------------- 1 | install.packages('lhs') 2 | library(lhs) 3 | 4 | # An n by k Latin Hypercube Sample matrix with values uniformly distributed on [0,1] 5 | set.seed(1234) 6 | a <- randomLHS(10,3) 7 | a <- a * 50 8 | a 9 | 10 | # Latin Hypercube sampling generates more efficient estimates of desired parameters than simple Monte Carlo sampling. 11 | p <- improvedLHS(1000, 3, 5) 12 | p <- p * 40 13 | p 14 | # b <- augmentLHS(a, 2) -------------------------------------------------------------------------------- /data_proc/fcn/fcn_ifrm.r: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------# 2 | #/ create function that tests if object exists ------ 3 | 4 | 5 | exist <- function(x) { return(exists(deparse(substitute(x))))} 6 | 7 | # if exist remove 8 | ifrm <- function(obj, env = globalenv()) { 9 | obj <- deparse(substitute(obj)) 10 | if(exists(obj, envir = env)) { rm(list = obj, envir = env) } 11 | } 12 | -------------------------------------------------------------------------------- /data_proc/distrib_drainage/fcn_distrib/fcn_print_distrib_ticker.r: -------------------------------------------------------------------------------- 1 | 2 | # PRINT AREA TICKER 3 | 4 | sum_drain_distrib <- round(sum(df$drain_distrib, na.rm=T), 1) # Area to distributed 5 | sum_excess_drain <- round(sum(df$excess, na.rm=T), 1) # Area exceeding pixel-wise limit 6 | pred_remain_drain <- round(sum_drain_stat - sum_drain_distrib, 1) # Area remaining to distrib 7 | 8 | print(paste0(' n:', nb_redist,' stat:', sum_drain_stat, ', distrib: ', 9 | sum_drain_distrib, ', excess:', sum_excess_drain, ', remain:', pred_remain_drain)) 10 | -------------------------------------------------------------------------------- /plots/artif_drainage/cultiv_wetland_only_percountryarea.r: -------------------------------------------------------------------------------- 1 | 2 | # plot timline of -------------------------------------------------------------- 3 | ggplot(cultwet) + 4 | geom_point(aes(x=year, y=drained_area_irrig, color=type)) + 5 | geom_line(aes(x=year, y=drained_area_irrig, color= type)) + 6 | facet_wrap(~country_name, scales= "free") + 7 | line_plot_theme 8 | 9 | 10 | 11 | ### save plot ------------------------------------------------------------------ 12 | ggsave( 13 | "./output/figures/artif_drainage/cultivated_wetland_aquastat.png", 14 | dpi=300, width=180, height=80, units='mm' , type = "cairo-png") 15 | 16 | dev.off() 17 | 18 | -------------------------------------------------------------------------------- /data_proc/artif_drainage/old/combine_drainage_wetcultiv_data.r: -------------------------------------------------------------------------------- 1 | 2 | # read in the national drainage statistics database 3 | source('data_proc/artif_drainage/read_nat_artif_drainage_v2.r') 4 | 5 | # area of agriculture in wetland (valley bottom, spate irrig) 6 | # append it to drainage table 7 | source('data_proc/artif_drainage/aquastat_wetland_cultiv.r') 8 | 9 | 10 | # combine databases of drainag and wetland cultivation. 11 | drainstat <- bind_rows(drained, cultwet) 12 | 13 | 14 | ### TO DO: 15 | # - combine the spate irrig in the total drain 16 | 17 | # write out the data 18 | write.csv(drainstat, "../output/results/artif_drainage/drained_wetcult_ha_v3.csv") 19 | -------------------------------------------------------------------------------- /plots/fcn/empty_ggplot.R: -------------------------------------------------------------------------------- 1 | # make empty grob 2 | 3 | make_empty_ggplot <- function (){ 4 | 5 | empty<- ggplot() + 6 | 7 | geom_point(aes(1,1), colour="white") + 8 | 9 | theme( 10 | plot.background = element_blank(), 11 | panel.grid.major = element_blank(), 12 | panel.grid.minor = element_blank(), 13 | panel.border = element_blank(), 14 | axis.line = element_blank(), 15 | panel.background = element_blank(), 16 | axis.title.x = element_blank(), 17 | axis.title.y = element_blank(), 18 | axis.text.x = element_blank(), 19 | axis.text.y = element_blank(), 20 | axis.ticks = element_blank()) 21 | 22 | return(empty) 23 | } 24 | -------------------------------------------------------------------------------- /plots/fcn/make_lpx_mask_overalltimes.r: -------------------------------------------------------------------------------- 1 | 2 | # read remaining wetland 3 | remwet_Mkm2_stack <- readRDS('./output/results/wetloss/grid/remwet_Mkm2_stack_2.5deg.rds') 4 | 5 | 6 | 7 | # make a mask of the full extent in LPX ========================================= 8 | r_start <-max(remwet_Mkm2_stack[[grep(pattern="6000", names(remwet_Mkm2_stack))]]) 9 | r_end <- max(remwet_Mkm2_stack[[grep(pattern="1980", names(remwet_Mkm2_stack))]]) 10 | 11 | # make function 12 | # introduce na in rst1 for all locations that are non-na in rst2 13 | r_mask <- overlay(r_start, r_end, fun = function(x, y) { 14 | x[!is.na(y[])] <- 99 15 | x[!is.na(x[])] <- 1 16 | return(x) }) 17 | 18 | r_mask_robin <- prep_raster_into_robin_map(r_mask) 19 | -------------------------------------------------------------------------------- /data_proc/fit/mcmc_init/fix_poland_subnat.r: -------------------------------------------------------------------------------- 1 | 2 | # poland 3 | # 4 | # gadm1_st <- st_read("../data/gadm36", "gadm36_1") 5 | # 6 | # poland1 <- gadm1_st %>% 7 | # filter(GID_0=='POL') %>% 8 | # mutate() 9 | # 10 | 11 | 12 | GID_1 <- c('POL.1_1', 'POL.2_1', 'POL.3_1', 'POL.4_1', 'POL.5_1', 'POL.6_1', 13 | 'POL.7_1', 'POL.8_1', 'POL.9_1', 'POL.10_1','POL.11_1','POL.12_1', 14 | 'POL.13_1', 'POL.14_1', 'POL.15_1', 'POL.16_1') 15 | 16 | HASC_1fix <- c('PL.DS', 'PL.KP', 'PL.LD', 'PL.LU', 'PL.LB', 'PL.MA', 17 | 'PL.MZ', 'PL.OP', 'PL.PK', 'PL.PD', 'PL.PM', 'PL.SL', 18 | 'PL.SK', 'PL.WM', 'PL.WP', 'PL.ZP') 19 | 20 | 21 | poland_subnat_fix <- data.frame(GID_1, HASC_1fix) 22 | # names(poland_subnat_fix) <- c('GID_1', 'HASC_1fix') -------------------------------------------------------------------------------- /plots/map/get_davidson_histcase_polygons.r: -------------------------------------------------------------------------------- 1 | 2 | # get Davidson histcase polygon data ==================================================== 3 | 4 | # save the spatial data data 5 | #histcases_poly <- readRDS("./output/results/histcases_poly.rds") 6 | histcases_poly <- readOGR("../data/hist_records/davidson_sites_gis", "davidson_sites") 7 | 8 | # project shapefile to Robinson for plotting 9 | histcases_poly_robin <- spTransform(histcases_poly, CRS("+proj=robin")) 10 | 11 | # add id column 12 | histcases_poly_robin@data$id <- as.numeric(rownames(histcases_poly_robin@data)) 13 | 14 | # convert to df 15 | histcases_poly_df <- fortify(histcases_poly_robin, region = 'id') 16 | 17 | # merge the attribute table back to spatial df 18 | histcases_poly_df <- merge(histcases_poly_df, histcases_poly_robin@data, by="id") 19 | 20 | 21 | 22 | -------------------------------------------------------------------------------- /plots/fcn/global_map_ggplot.r: -------------------------------------------------------------------------------- 1 | ### ggplot map of remwet 2 | 3 | 4 | 5 | 6 | global_map_ggplot <- function(t, pal){ 7 | 8 | t <- as(t, "SpatialPixelsDataFrame") 9 | t <- as.data.frame(t) 10 | t$layer <- t[,names(t)[1]] 11 | tno0 <- t[t$layer > 0,] 12 | 13 | plot<- ggplot() + 14 | 15 | geom_tile(data=t, 16 | aes_string(x='x', y='y'), fill='grey90') + 17 | geom_tile(data=tno0, 18 | aes_string(x='x', y='y', fill=names(t)[1])) + 19 | coord_equal() + 20 | theme_minimal() + 21 | scale_fill_distiller(palette=pal, direction=1) + 22 | theme(legend.position=c(0.1, 0.4), 23 | axis.line = element_blank(), 24 | axis.text = element_blank(), 25 | axis.title = element_blank(), 26 | panel.grid.major = element_blank(), 27 | panel.grid.minor = element_blank()) 28 | 29 | return(plot) 30 | 31 | } -------------------------------------------------------------------------------- /plots/artif_drainage/lineplot/facet_sigmoid_all_national.r: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------# 2 | #/ Plot facets 3 | 4 | predall <- read.csv("../output/results/artif_drainage/drained_wetcult_km2_sigmoidpred_march2021.csv") 5 | 6 | 7 | m <- 8 | ggplot() + 9 | geom_line(data = predall, aes(x= year, y= pred_drained, color=type)) + 10 | geom_point(data= d_nat, aes(x= year, y= drained_area_tot, color=type), size=0.6) + 11 | expand_limits(y=0) + 12 | facet_wrap(~country_name, scales="free") + 13 | line_plot_theme + 14 | theme(legend.position = c(0.9, 0.03)) + 15 | ylab("Area drained (km^2)") + xlab("") 16 | 17 | 18 | 19 | # save plot 20 | ggsave(plot=m, 21 | filename="../output/figures/artif_drainage/sigmoid/all/drain_sigmoid_predall_maxed_march2021_v2.png", 22 | width=400, height=280, dpi=300, units='mm') #, type = "cairo") 23 | 24 | dev.off() 25 | 26 | -------------------------------------------------------------------------------- /plots/fcn/average_grids.r: -------------------------------------------------------------------------------- 1 | 2 | # create a function that averages raster stacks by year 3 | average_grids <- function(year_vector, raster_stack, list_to_subset){ 4 | 5 | # if 6 | if (exist(list_to_subset)){ 7 | remwet_Mkm2_stack <- sel.by.pattern(remwet_Mkm2_stack, 8 | paste(toMatch,collapse="|")) } 9 | 10 | # create empty stack 11 | mean_stack <- stack() 12 | 13 | # loop through years 14 | for (y in year_vector){ 15 | 16 | # subset by year 17 | sel_r <- sel.by.pattern(raster_stack, y) 18 | 19 | # average grids 20 | mean_sel_r <- mean(sel_r) 21 | 22 | # name grids 23 | names(mean_sel_r) <- paste0("mean_year_", y) 24 | 25 | # add averaged grid to output stack 26 | mean_stack <- stack(mean_stack, mean_sel_r) 27 | } 28 | 29 | # return the stack of averaged grids 30 | return(mean_stack) 31 | } 32 | -------------------------------------------------------------------------------- /data_proc/fit/mcmc_init/init_grid_template.r: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------# 2 | #/ Get pixel area grid (from HYDE- excl. open water) 3 | # AND GRID TEMPLATE 4 | 5 | # map with maximum landarea available per gridcell in km2 6 | maxlncr <- raster('../data/lucc/hyde32_beta/general_files/maxln_cr.asc', 7 | crs='+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0') 8 | 9 | origin(maxlncr) <- c(0, 0) 10 | maxlncr <- extend(maxlncr, extent(-180, 180, -90, 90)) 11 | maxlncr <- aggregate(maxlncr, fact=6, fun='sum') 12 | maxlncr_df <- data.frame(as(maxlncr, 'SpatialPointsDataFrame'))[1:3] 13 | maxlncr_df$x = round(maxlncr_df$x, 2) 14 | maxlncr_df$y = round(maxlncr_df$y, 2) 15 | 16 | landarea = maxlncr_df$maxln_cr 17 | 18 | maxlncr_df_xy <- maxlncr_df[2:3] # Get coordinates to use as common mask 19 | 20 | 21 | # Cropt to extent of outputs 22 | maxlncr_crop <- crop(maxlncr, extent(-180, 180, -56, 84)) 23 | -------------------------------------------------------------------------------- /plots/lineplot/line_plot_sum_nat_wetland_20th.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | i <- "./output/results/natwet/global_sum_nat_wetland_20th.csv" 4 | sum_nat_wet_20th <- read.csv(i, stringsAsFactors = F) %>% 5 | gather(year_type, year, year_end:year_start) %>% 6 | dplyr::select(-one_of('year_type')) 7 | 8 | 9 | # plot ========================================================================= 10 | 11 | # declare breakpoints 12 | mybreaks <- c(1901, 1932, 1993, 2004, 2010) 13 | 14 | ggplot(sum_nat_wet_20th) + 15 | geom_line(aes(x=year, wet_Mkm2, color=name), size=2) + 16 | scale_x_continuous(breaks=mybreaks, labels=mybreaks) + 17 | xlab("Year") + 18 | ylab("Natural wetland area (10^6 km2)") 19 | 20 | 21 | 22 | 23 | ### save plot ------------------------------------------------------------------ 24 | ggsave("../../output/figures/line_plot_sum_nat_wet_20th.png", 25 | width=178, height=120, dpi=600, units='mm', type = "cairo-png") 26 | 27 | dev.off() 28 | -------------------------------------------------------------------------------- /data_proc/fit/fcn_run_modfit.r: -------------------------------------------------------------------------------- 1 | #/ Wrapper function that sets MCMC parameters ---------------- 2 | # Argument: 3 | # s_i = simwet index 4 | # p_i = preswet index 5 | # niteration= number of mcmc iterations 6 | 7 | library(FME) 8 | 9 | # /----------------------------------------------------------------------------- 10 | #/ Run modfit 11 | 12 | run_modfit <- function(s_i, p_i, niteration) { 13 | 14 | # set initial params 15 | startingparams <- c(theta_rice = 2, theta_pasture = 1, theta_urban = 2) 16 | 17 | 18 | fit <- modFit(f = make_wetloss_df, 19 | p = startingparams, #c(2, 0.5, 3), 20 | s_i=s_i, 21 | p_i=p_i, # additional arguments passed to function f 22 | lower=c(0.0001, 0.0001, 0.0001), 23 | upper=c(100, 100, 100), 24 | method='Pseudo', # Pseudorandom fit 25 | control = c(numiter = niteration, verbose = TRUE)) 26 | 27 | 28 | return(fit) 29 | } 30 | 31 | 32 | 33 | -------------------------------------------------------------------------------- /data_proc/artif_drainage/comb_interp_drainage_wetcult.r: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------- 2 | #/ Read interpolated drainage area table 3 | drainage <- read.csv('../output/results/artif_drainage/drained_wetcult_km2_sigmoidpred_march2021.csv') #%>% dplyr::select(-X) 4 | 5 | 6 | # Get Wetcult interpolated 7 | wetcult <- read.csv('../output/results/artif_drainage/wetcult_ha_interpol_v2.csv') %>% 8 | mutate(type = 'Wetland Cultiv.') %>% 9 | # remove columns 10 | dplyr::select(-c(zone, perc_wetcult, cropland_area_km2)) %>% 11 | # Make ISO code column 12 | mutate(country_name = countrycode(iso_a3,'iso3c','country.name',warn=F)) 13 | 14 | 15 | names(wetcult) <- c('year', 'iso_a3', 'pred_drained', 'type', 'country_name') 16 | 17 | ## Bind them together 18 | drainage_wetcult <- bind_rows(drainage, wetcult) 19 | 20 | 21 | # Save to file 22 | write.csv(drainage_wetcult, '../output/results/artif_drainage/drained_wetcult_sigmoid_interp_comb_march2021.csv', row.names=F) 23 | -------------------------------------------------------------------------------- /data_proc/natwet/preswet/make_preswet_swampsglwd.r: -------------------------------------------------------------------------------- 1 | # make preswet from SWAMPS-GLWD 2 | 3 | # /----------------------------------------------------------------------------# 4 | #/ Get 0.5deg grid from SWAMPS-GLWD netcdf 5 | f <- "../../upch4/data/swampsglwd/v2/gcp-ch4_wetlands_2000-2017_05deg.nc" 6 | Fw <- brick(f, varname="Fw") 7 | 8 | # filter to 2000-2010 average 9 | # Fw <- Fw[[73 : 132]] 10 | Fw <- Fw[[1 : 132]] 11 | 12 | # Get mean of raster stack 13 | Fw_max <- calc(Fw, fun = max, na.rm = T) 14 | Aw_max = Fw_max * area(Fw_max) 15 | 16 | 17 | # Save raster 18 | writeRaster(Aw_max, 19 | filename='../output/results/natwet/grid/swampsglwd_preswet.tif', 20 | format="GTiff", overwrite=TRUE) 21 | 22 | 23 | 24 | 25 | 26 | 27 | # # Convert to dataframe 28 | # Fwdf <- as(Fw,'SpatialPointsDataFrame') 29 | # # Convert to sf points 30 | # pts_05deg <- st_as_sf(Fwdf) 31 | # # Add ID column; one point per row 32 | # pts_05deg$pt_id <- as.numeric(rownames(pts_05deg)) 33 | # 34 | # # Clean up environment 35 | # rm(Fw, f) 36 | -------------------------------------------------------------------------------- /data_proc/fcn/import_libraries.r: -------------------------------------------------------------------------------- 1 | 2 | # import libraries 3 | library(cowplot) 4 | library(countrycode) 5 | 6 | library(dplyr) 7 | library(gridExtra) 8 | library(geosphere) 9 | library(gganimate) 10 | library(ggplot2) 11 | library(ggrepel) 12 | library(grid) 13 | 14 | library(maptools) 15 | library(maps) 16 | library(ncdf4) 17 | library(stringi) 18 | library(stringr) 19 | library(scales) 20 | library(tidyr) 21 | library(raster) 22 | # library(rasterVis) 23 | library(RColorBrewer) 24 | 25 | library(rworldmap) 26 | library(sf) 27 | library(sp) 28 | library(rgdal) 29 | library(rgeos) 30 | library(raster) 31 | library(ggmap) 32 | library(scales) 33 | #library(Cairo) 34 | # library(ggridges) 35 | 36 | 37 | 38 | # package of unzip 39 | library(utils) 40 | library(raster) 41 | library(ncdf4) 42 | 43 | # library(mc2d) 44 | # library(animation) 45 | 46 | # import package that has some ts interpolation functions 47 | library(zoo) 48 | # library(ggpubr) 49 | library(fasterize) 50 | 51 | 52 | # monte carlo 53 | # fitdistrplus package is convenient for assessing a parametric distribution of data 54 | 55 | #rm(list=ls()) # clear memory 56 | 57 | -------------------------------------------------------------------------------- /plots/fcn/levelplot_forgif_wetloss_only.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | # wetland mapping theme 4 | mapTheme <- rasterTheme(region = rev(brewer.pal(10, "RdBu")), 5 | axis.line = list(col = "transparent"), 6 | scales = list(x = list(draw = FALSE))) 7 | 8 | 9 | 10 | wet_plt<- levelplot(wet, 11 | margin = list(draw=F), 12 | #at=cutpts, 13 | cuts=10, # nb of colors 14 | pretty=TRUE, 15 | #main=paste0("Natural wetland cover"), 16 | par.strip.text= list(cex=0.5, lines=10, fontface='bold'), 17 | axes=FALSE, box=FALSE, 18 | scales=list(draw=FALSE), 19 | xlab=NULL, ylab=NULL, 20 | par.settings = mapTheme, 21 | colorkey=list(space="right"), 22 | xlim=c(-180, 180), 23 | ylim=c(-70, 90)) + 24 | latticeExtra::layer(grid.text("Natural wetland %", 25 | x=0, y=.35, just='left')) 26 | 27 | print(wet_plt) 28 | -------------------------------------------------------------------------------- /data_proc/natwet/preswet/get_corr_layers.R: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------# 2 | #/ Read correction layers -------------- 3 | 4 | # JRC static 5 | JRC <- stack('../data/natwet/wad2m_corr_layers/Global_JRC_025deg_WGS84_fraction.nc') 6 | JRC <- JRC * area(JRC) 7 | 8 | # Mirca Rice 12 months 9 | MIRCA <- stack('../data/natwet/wad2m_corr_layers/MIRCA_monthly_irrigated_rice_area_025deg_frac.nc') 10 | MIRCA <- calc(MIRCA, fun=max, na.rm=T) 11 | MIRCA <- MIRCA * area(MIRCA) 12 | 13 | # Coastal mask (Static) 14 | COAST <- stack('../data/natwet/wad2m_corr_layers/MODIS_coastal_mask_025deg.nc') 15 | COAST <- COAST * area(COAST) 16 | 17 | # CIFOR wetland map (Static) 18 | CIFOR <- stack('../data/natwet/wad2m_corr_layers/cifor_wetlands_area_025deg_frac.nc') 19 | CIFOR <- CIFOR * area(CIFOR) 20 | 21 | # NCSCD peatland map (static) 22 | NCSCD <- stack('../data/natwet/wad2m_corr_layers/NCSCD_fraction_025deg.nc') 23 | NCSCD <- NCSCD * area(NCSCD) 24 | 25 | # NCSCD peatland map (static) 26 | GLWD <- stack('../data/natwet/wad2m_corr_layers/GLWD_wetlands_025deg_frac.nc') 27 | GLWD <- GLWD * area(GLWD) 28 | 29 | -------------------------------------------------------------------------------- /data_proc/artif_drainage/old/us_subnat_drainage.r: -------------------------------------------------------------------------------- 1 | ### US CENSUS - IMPROVED FARMLAND 2 | 3 | test <- readGDAL('./data/artif_drained/grids/cty2mc/cty2mc.e00') 4 | 5 | acr_file = "./data/artif_drained/grids/cty2mc/cty2mc.e00" 6 | dr = ogr.GetDriverByName("AVCE00") 7 | f = dr.Open(arc_file) 8 | 9 | library(RArcInfo) 10 | 11 | #Number of polygons 12 | nmuni<-length(palmuni[[1]][[1]]) 13 | e00toavc('./data/artif_drained/grids/cty2mc/cty2mc.e00', "valencia") 14 | 15 | 16 | 17 | 18 | # this gets tehe data 19 | palmuni<-get.paldata(".", "valencia") 20 | 21 | 22 | 23 | patmuni<-get.tabledata("./info", "VALENCIA.PAT") 24 | 25 | patmuni <- as.data.frame(patmuni) 26 | 27 | 28 | plotpal(arc=arcsmuni, palmuni) 29 | 30 | 31 | 32 | arcsmuni<-get.arcdata(".", "valencia") 33 | bnd.muni<-get.bnddata("info/", "VALENCIA.BND") 34 | l <- get.labdata(datadir, coverage, filename="lab.adf") 35 | 36 | 37 | #Number of polygons 38 | nmuni<-length(patmuni[[1]][[1]]) 39 | municipios<-data.frame(1:nmuni, patmuni$"VALENCIA-ID") 40 | names(municipios)<-c("INDEX", "CODMUNICI") 41 | #Datafiles to be used 42 | unemp<-read.table(file="data_valencia.csv", sep=";", 43 | dec = ",",skip=1) 44 | -------------------------------------------------------------------------------- /data_proc/fit/mcmc_init/init_drainage_stats.r: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------# 2 | #/ Read drained area time-series; interpolated from national statistics. 3 | # Country level 4 | 5 | # d = '../output/results/artif_drainage/drained_wetcult_sigmoid_interp_comb.csv' 6 | # drained_wetcult_km2_sigmoidpred_nov2020 7 | d = "../output/results/artif_drainage/drained_wetcult_sigmoid_interp_comb_nov2020.csv" 8 | 9 | drainage <- read.csv(d) %>% 10 | filter(!is.na(country_name)) %>% 11 | mutate(iso_a3 = countrycode(country_name,'country.name','iso3c',warn=F)) %>% 12 | dplyr::select(-c(X)) %>% 13 | unique() 14 | 15 | # REMOVE DUPLICATE ROWS - THIS SHOULD HAPPEN UPSTREAM OF HERE !!! 16 | drainage <- drainage[!duplicated(drainage[,c('year','country_name','type')]),] 17 | 18 | # Rename types so it matches object names 19 | drainage[drainage$type=='Forestry', 'type'] <- 'forestry' 20 | drainage[drainage$type=='Peat Extraction', 'type'] <- 'peatextr' 21 | drainage[drainage$type=='Cropland', 'type'] <- 'cropland' 22 | drainage[drainage$type=='Wetland Cultiv.', 'type'] <- 'wetcultiv' -------------------------------------------------------------------------------- /plots/themes/map_theme.r: -------------------------------------------------------------------------------- 1 | 2 | ### Create map ggplot theme_opts ---------------------------------------------------- 3 | 4 | theme_fig <- function(base_size = 9){ 5 | theme_bw(base_size=base_size) + 6 | theme(plot.title = element_text(face='bold',size=14,hjust=0), 7 | plot.background = element_rect(fill='white'), 8 | 9 | # PANEL 10 | panel.grid.minor = element_blank(), 11 | panel.grid.major = element_blank(), 12 | panel.background = element_rect(fill='white'), 13 | panel.border = element_blank(), 14 | 15 | # AXIS 16 | axis.text = element_blank(), 17 | axis.title = element_blank(), 18 | axis.line = element_line(colour='white'), 19 | axis.ticks = element_blank(), 20 | 21 | # LEGEND 22 | #legend.title = element_blank(), 23 | legend.key = element_blank(), 24 | legend.position="bottom", 25 | legend.box="horizontal", 26 | legend.text=element_text(size=7), 27 | legend.spacing = unit(0, "mm"), 28 | legend.key.size = unit(3, "mm")) } -------------------------------------------------------------------------------- /data_proc/distrib_drainage/fcn_distrib/fcn_make_perc_overlap.r: -------------------------------------------------------------------------------- 1 | 2 | 3 | # /----------------------------------------------------------------------------# 4 | #/ Calculate each pixels % of national overlap (of wet-LU) ----- 5 | # by dividing the pixels by the national total of overlap. 6 | # Why are there negative values? becaus of negative pot-wet? 7 | 8 | make_perc_overlap <- function(rdm_overlay, str_draintype) { 9 | 10 | names(rdm_overlay) <- 'rdm_overlay' 11 | 12 | # Subset the geo_unit df 13 | geo_units_sub <- geo_units_alltypes %>% filter(type == str_draintype) 14 | 15 | # Bind rdm overlay with country index 16 | z <- bind_cols(geo_units_sub, rdm_overlay) %>% #, ciso_df) %>% 17 | group_by(GID_0, HASC_1) %>% #iso_a3) %>% 18 | # Calculate fraction of rdm overlap per country 19 | mutate(perc_overlap = rdm_overlay / sum(rdm_overlay, na.rm=T)) %>% 20 | # Fill NAs as 0s 21 | mutate(perc_overlap = ifelse(is.na(perc_overlap), 0, perc_overlap)) %>% 22 | ungroup() 23 | 24 | # Use column name that'll work with the rest... eventually clean this up 25 | z$iso_a3 <- z$GID_0 26 | 27 | # perc_overlap <- rdm_overlay / z$overlap_sum 28 | return(z) 29 | } -------------------------------------------------------------------------------- /plots/fit/theta_boxplot.r: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------# 2 | #/ Plot theta values histogram per member -------- 3 | 4 | # get parameters 5 | best_pars_df <- read.csv('../output/results/fit/lh/parameters/best_pars_lh_2021.csv') 6 | 7 | 8 | p_names=c('GIEMSv2','GLWD3','WAD2M') 9 | s_names=c('DLEM','ORCHIDEE','SDGVM','LPJ-wsl') 10 | 11 | # convert to long format 12 | pars_df_long <- best_pars_df %>% 13 | pivot_longer(theta_rice:theta_urban, names_to='theta_name', values_to='theta_val') %>% 14 | mutate(s_name=s_names[s_i], p_name=p_names[p_i]) 15 | 16 | 17 | 18 | 19 | #TODO: Make violin plot 20 | ggplot(pars_df_long) + 21 | # geom_histogram(aes(x=theta_val, fill=theta_name), bins=20) + 22 | # geom_violin(aes(x=theta_name, y=theta_val, fill=theta_name), bins=20) + 23 | geom_boxplot(aes(x=theta_name, y=theta_val, fill=theta_name, color=theta_name), alpha=0.6, width=0.2) + #, bins=20) + 24 | # facet_grid(s_name~p_name, scales='free') + 25 | facet_rep_grid(s_name~p_name) + 26 | line_plot_theme + 27 | xlab('') + ylab('Theta parameter value') + 28 | theme(legend.position = 'none') 29 | 30 | 31 | ggsave('../output/figures/theta_values_facet_v2.png', 32 | width=190, height=220, dpi=600, units='mm' ) 33 | -------------------------------------------------------------------------------- /plots/themes/line_plot_theme.r: -------------------------------------------------------------------------------- 1 | 2 | line_plot_theme <- 3 | theme_bw() + 4 | theme( 5 | 6 | ### ALL TEXT (inherited everywhere) 7 | text = element_text(size=9, colour='black'), 8 | 9 | ### FACET STRIP 10 | strip.text = element_text(size=9, face='bold',hjust= 0), #, vjust = -0.5), 11 | strip.background = element_blank(), 12 | 13 | ### LEGEND 14 | legend.text = element_text(size = 9), 15 | legend.background = element_blank(), 16 | legend.key.size = unit(4, "mm"), 17 | legend.title=element_blank(), 18 | #legend.position = 'top', 19 | legend.direction = 'vertical', 20 | legend.justification = "left", 21 | 22 | 23 | ### AXES 24 | axis.line = element_line(colour = "black", size=0.3), 25 | axis.text = element_text(size=7, colour='black'), 26 | axis.ticks = element_line(colour='black', size=0.3), 27 | 28 | 29 | ### PANEL 30 | panel.grid.minor = element_blank(), 31 | panel.grid.major = element_blank(), 32 | # panel.background = element_rect(fill=NA, colour = "black", size=0.1), 33 | panel.spacing = unit(.05, "lines"), 34 | panel.border = element_blank()) #rect(color = "black", fill = NA, size = 0.1)) 35 | -------------------------------------------------------------------------------- /data_proc/fit/modfit/fcn_run_modfit.r: -------------------------------------------------------------------------------- 1 | #/ Wrapper function that sets MCMC parameters ---------------- 2 | # Argument: 3 | # s_i = simwet index 4 | # p_i = preswet index 5 | # niteration= number of mcmc iterations 6 | 7 | library(FME) 8 | 9 | # /----------------------------------------------------------------------------- 10 | #/ Run modfit 11 | run_modfit <- function(s_i, p_i, niteration) { 12 | 13 | # set initial params 14 | params <- c(theta_rice = 2, theta_pasture = 1, theta_urban = 2) 15 | 16 | 17 | MCMC <- modMCMC(f=make_wetloss_df, # function to be evaluated 18 | p=params, # initial values for the parameters to be optimized over 19 | s_i, # additional arguments passed to function f 20 | p_i, 21 | lower=c(0.0001, 0.0001, 0.0001), 22 | upper=c(10, 10, 10), 23 | niter=niteration, # 4, 24 | var0=0.4, # 0.4 # prior mean for σ2 25 | wvar0=0.0, # prior accuracy; =1, equal weight given to prior and current value; 0 then the prior is ignored. 26 | # outputlength=niter 27 | updatecov=2 ) 28 | 29 | return(MCMC) 30 | } 31 | 32 | 33 | 34 | 35 | -------------------------------------------------------------------------------- /data_proc/hist_cases/get_davidson2014_cases.r: -------------------------------------------------------------------------------- 1 | #/ GET DAVIDSON2014 CASES ------------------------------------------------- 2 | 3 | 4 | # read data histcases Shapefile 5 | # hist_poly <- readOGR("../output/results/histcases/davidson_sites_manmod.shp") 6 | hist_poly <- readOGR("../data/hist_records/davidson_sites_gis/davidson_sites_wdata.shp") 7 | 8 | hist_poly <- subset(hist_poly, src_id != 0) # remove records without a paired source_id 9 | 10 | # read the manually curated datatable 11 | # "./data/hist_records/wetland_loss_cases_combined_v2_manmod.csv", 12 | hist_data <- 13 | read.csv('../output/results/histcases/histcases_loss_v2_manmod_p.csv') %>% 14 | select(-c(full.citation, Comment, ef_comment)) 15 | 16 | # join poly and data on id 17 | histcasesdata <- merge(hist_poly, hist_data, by=c("src_id","rec_id")) 18 | 19 | # Get data table of joined df (why?) 20 | h = histcasesdata@data 21 | 22 | # save as RDS again 23 | saveRDS(histcasesdata, "../data/hist_records/davidson_sites_gis/davidson_sites_wdata_manmod.rds") 24 | 25 | 26 | 27 | 28 | 29 | #### 30 | # FIX FUCK UP 31 | 32 | hist_poly <- readOGR("../data/hist_records/davidson_sites_gis/davidson_sites_wdata.shp") 33 | # hist_polymod <- readOGR("../output/results/histcases/davidson_sites_manmod.shp")@data 34 | 35 | 36 | hist_poly <- merge(hist_poly, hist_polymod, by='name') 37 | -------------------------------------------------------------------------------- /plots/lineplot/old/line_plot_remwer_per_wettype.r: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | wetloss_pertype <- read.csv('./output/results/wettype/remwet_perc_wettype_since1700.csv') 5 | 6 | 7 | 8 | 9 | # plot area ==================================================================== 10 | #wettype_perc_bylat <- 11 | ggplot(wetloss_pertype) + 12 | 13 | # add lines 14 | geom_line(aes(x=year,y=perc_remwet, color=Name), size=0.35) + 15 | 16 | # make multiple facets per lat slices 17 | facet_wrap(~type, nrow=1, scales="free_y") + 18 | xlab("") + ylab("Wetland area percentage change since 1700 (%))") + 19 | 20 | 21 | # axes limit 22 | scale_x_continuous(expand=c(0,0))+ 23 | scale_y_continuous(expand=c(0,0), limits=c(15, 100))+ 24 | #scale_color_brewer(name="Wetland area (% of 1700 area)", palette = "Set1")+ 25 | 26 | 27 | line_plot_theme + 28 | theme(legend.position = c(0.1, 0.3)) 29 | 30 | 31 | 32 | # save to file ------------------------------------------------ 33 | 34 | # save figure to file 35 | ggsave('./output/figures/wettype_remwet_perc_v2.pdf', 36 | width=178, height=80, dpi=600, units="mm") 37 | 38 | ### Save figure to file 39 | ggsave('./output/figures/wettype_remwet_perc_v2.png', 40 | width=178, height=80, dpi=600, units="mm", type = "cairo-png") 41 | 42 | dev.off() 43 | -------------------------------------------------------------------------------- /plots/themes/map_raster_theme.r: -------------------------------------------------------------------------------- 1 | 2 | 3 | ### Create map ggplot theme_opts ---------------------------------------------------- 4 | 5 | theme_raster_map <- function(base_size = 6){ 6 | 7 | theme_bw(base_size=base_size) + 8 | 9 | theme(plot.title = element_text(face='bold',size=14,hjust=0), 10 | 11 | panel.grid.minor = element_blank(), 12 | panel.grid.major = element_blank(), 13 | panel.background = element_rect(fill='white'), 14 | plot.background = element_rect(fill='white'), 15 | panel.border = element_blank(), 16 | 17 | axis.text = element_blank(), 18 | axis.title = element_blank(), 19 | axis.line = element_line(colour='white'), 20 | axis.ticks = element_blank(), 21 | 22 | 23 | #legend.key = element_blank(), 24 | #legend.title = element_blank(), 25 | #legend.position="bottom", 26 | #legend.box="horizontal", 27 | legend.background = element_blank(), 28 | legend.title = element_text(size=6, color="black"), 29 | legend.text=element_text(size=6, color="black"), 30 | legend.direction = "vertical", 31 | legend.spacing = unit(0, "mm"), 32 | legend.key.size = unit(2.5, "mm")) } 33 | -------------------------------------------------------------------------------- /data_proc/fcn/fcn_get_polygons_for_histcases.r: -------------------------------------------------------------------------------- 1 | # create function selecting shapefile for histcases 2 | # 3 | # histcases = the table 4 | # shapefile = shapefile 5 | # join field from table 6 | # join field from shapefile 7 | # id = "rec_id" 8 | 9 | 10 | 11 | get_histcase_shapefile <- function(histcases, shapefile, byx, byy, id){ 12 | 13 | 14 | # loop through histcases 15 | for (i in seq(1, nrow(histcases))) { 16 | 17 | # get the record id of the histcase 18 | t_rec_id <- histcases[i,id] 19 | 20 | print(t_rec_id) 21 | 22 | # extract the single histcase row 23 | temp_case <- histcases[histcases$rec_id==t_rec_id,] 24 | 25 | # reset the polygon from which selection is made 26 | shapefile_forjoin <- shapefile 27 | 28 | # join the data to the polygons 29 | shapefile_forjoin <- merge(shapefile_forjoin, temp_case, by.x= byx, by.y= byy) 30 | 31 | # remove polygons without match 32 | t_cases_poly <- shapefile_forjoin[!is.na(shapefile_forjoin@data$rec_id),] 33 | 34 | # if the first loop iteration 35 | if (i==1){ 36 | # create output 37 | outpoly <- t_cases_poly 38 | # else append to output 39 | } else { outpoly <- rbind(outpoly, t_cases_poly, makeUniqueIDs = TRUE) } 40 | } 41 | 42 | 43 | return(outpoly) 44 | } -------------------------------------------------------------------------------- /data_proc/fit/fcn_run_mcmc.r: -------------------------------------------------------------------------------- 1 | #/ Wrapper function that sets MCMC parameters ---------------- 2 | # Argument: 3 | # s_i = simwet index; simulated wetland map fed as input. 4 | # p_i = preswet index; present-day wetland map fed as input. 5 | # niteration= number of mcmc iterations 6 | 7 | library(FME) 8 | 9 | # /----------------------------------------------------------------------------- 10 | #/ Run modMCMC 11 | run_mcmc <- function(s_i, p_i, niteration) { 12 | 13 | # set starting value of parameters 14 | startingparams <- c(theta_rice = 2, theta_pasture = 0.5, theta_urban = 2) 15 | 16 | MCMC <- modMCMC(f=make_wetloss_df, # function to be evaluated 17 | p=startingparams, # initial values for the parameters to be optimized over 18 | s_i, # additional arguments passed to function f 19 | p_i, 20 | lower=c(0.0001, 0.0001, 0.0001), 21 | upper=c(100, 100, 100), 22 | niter=niteration, # 4, 23 | var0=1, # 0.4 # prior mean for σ2 24 | wvar0=0.0, # prior accuracy; =1, equal weight given to prior and current value; 0 then the prior is ignored. 25 | # outputlength=niter 26 | updatecov=2 ) 27 | 28 | return(MCMC) 29 | } 30 | 31 | -------------------------------------------------------------------------------- /data_proc/fit/mcmc_fit/fcn_run_mcmc.r: -------------------------------------------------------------------------------- 1 | #/ Wrapper function that sets MCMC parameters ---------------- 2 | # Argument: 3 | # s_i = simwet index; simulated wetland map fed as input. 4 | # p_i = preswet index; present-day wetland map fed as input. 5 | # niteration= number of mcmc iterations 6 | 7 | library(FME) 8 | 9 | # /----------------------------------------------------------------------------- 10 | #/ Run modMCMC 11 | run_my_mcmc <- function(s_i, p_i, niteration) { 12 | 13 | # set starting value of parameters 14 | params <- c(theta_rice = 1, theta_pasture = 1, theta_urban = 1) 15 | 16 | MCMC <- modMCMC(f=make_wetloss_df, # function to be evaluated 17 | p=params, # initial values for the parameters to be optimized over 18 | s_i, # additional arguments passed to function f 19 | p_i, 20 | lower=c(0.0001, 0.0001, 0.0001), 21 | upper=c(10, 10, 10), 22 | niter=niteration, # 4, 23 | var0=0.4, # 0.4 # prior mean for σ2 24 | wvar0=0.0, # prior accuracy; =1, equal weight given to prior and current value; 0 then the prior is ignored. 25 | # outputlength=niter 26 | updatecov=2 ) 27 | 28 | return(MCMC) 29 | } 30 | 31 | -------------------------------------------------------------------------------- /data_proc/natwet/potwet/prep_potwet_v2.r: -------------------------------------------------------------------------------- 1 | 2 | 3 | # /--------------------------------------------------- 4 | #/ Get simwet stack 5 | simwet_stack <- stack('../output/results/natwet/simwet/simwet_stack.tif') 6 | names(simwet_stack) <- c('orchidee2_km2', 'SDGVM2_km2', 'dlem2_km2', 'zhang_wpot') 7 | simwet_stack <- raster::aggregate(simwet_stack, fact=2, fun=sum, na.rm=TRUE) 8 | 9 | 10 | # /--------------------------------------------------- 11 | #/ Get preswet mamax stack 12 | preswet_stack <- stack('../output/results/natwet/preswet/preswet_stack.tif') 13 | names(preswet_stack) <- c('wad2m_Aw_mamax', 'glwd3_akmw', 'giems2_mamax_corr') 14 | preswet_stack <- aggregate(preswet_stack, fact=2, fun=sum, na.rm=TRUE) 15 | 16 | 17 | # /--------------------------------------------------- 18 | #/ Present-day wetland - maximum area 19 | preswet_max_stack <- stack( '../output/results/natwet/preswet/preswet_stack_max.tif') 20 | names(preswet_max_stack) <- c('wad2m', 'glwd3', 'giems2') 21 | # preswet_stack <- aggregate(preswet_stack, fact=2, fun=sum, na.rm=TRUE) 22 | 23 | 24 | 25 | # SIMWET: 26 | # - ORCHIDEE EXP#2 27 | # - SDGVM (35-45Mkm2) 28 | # - DLEM (wet) 29 | # - Zhen wPot (LPJ-wsl) 30 | 31 | # PRESWET 32 | # - WAD2M 33 | # - GLWD 34 | # - GIEMSv2 35 | 36 | 37 | 38 | ### PLOT GRID OF POTWET (PRESWET X SIMWET) 39 | if(0){ source('plots/nat_wet/map_potwet_grid.r') } 40 | -------------------------------------------------------------------------------- /data_proc/fit/mcmc_init/init_nat_grid_isocode.r: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------# 2 | #/ MAKE GRID OF COUNTRY ISO CODES FROM GADM0 - SO ITS HARMONIZED WITH SUBNAT 3 | 4 | 5 | gadm0_st <- st_read("../data/gadm36", "gadm36_0") %>% 6 | filter(!NAME_0 %in% c('Antarctica', 'Kiribati', 'Micronesia', 'Samoa', 'Fiji')) %>% 7 | mutate(nat_id = as.numeric(as.factor(GID_0))) 8 | 9 | # make df of gadm0 data 10 | gadm0_st_df <- gadm0_st %>% st_drop_geometry() # data.frame(gadm0_st[,c('GID_0','NAME_0','nat_id')]) 11 | 12 | 13 | 14 | 15 | # /----------------------------------------------------------------------------# 16 | #/ Convert GADM0 to raster 0.25deg raster then aggregate to 0.5deg, to prevent cutting-off coastlines 17 | gadm0_st_nat_id_r <- fasterize(gadm0_st, template_025deg, field = "nat_id", fun="first") 18 | gadm0_st_nat_id_r <- raster::aggregate(gadm0_st_nat_id_r, fact=2, fun=modal, ties='first', na.rm=T) 19 | 20 | # then to df 21 | gadm0_st_nat_id_df <- raster2df(gadm0_st_nat_id_r) 22 | 23 | names(gadm0_st_nat_id_df) <- c('nat_id', 'x', 'y') 24 | 25 | # Join data to df pixels 26 | gadm0_st_nat_id_df <- left_join(gadm0_st_nat_id_df, gadm0_st_df , by='nat_id') 27 | 28 | # join 29 | # use old name for df 30 | ciso_df <- left_join(maxlncr_df_xy, gadm0_st_nat_id_df, by=c('x','y')) 31 | 32 | names(ciso_df) <- c('x','y','nat_id','iso_a3','country_name') 33 | 34 | -------------------------------------------------------------------------------- /plots/lineplot/old/line_plot_remwet_ensemble_global.R: -------------------------------------------------------------------------------- 1 | 2 | wetloss_ensemble_prc <- read.csv("./output/results/wetloss/wetloss_ensemble_prc") 3 | 4 | 5 | # read davison data 6 | f<-"./data/hist_records/source_specific/davidson_2014/davidson2014_global_percent_wetloss.csv" 7 | davidson2014 <- read.csv(f, stringsAsFactors = F) %>% filter(!is.na(percentage_fromtext_nfig4)) 8 | 9 | 10 | 11 | # percentage plot with ribbon ================================================== 12 | 13 | ggplot(wetloss_ensemble_prc) + 14 | 15 | geom_line(aes(x=year, y= remwet_prc_since1700_mean), color='blue', size=0.3) + 16 | 17 | geom_ribbon(aes(x=year, ymin=remwet_prc_since1700_min, ymax=remwet_prc_since1700_max), 18 | fill='blue', alpha=0.2) + 19 | 20 | 21 | geom_line(data=davison2014, 22 | aes(x=ï..year_start, y= percentage_fromtext_nfig4), 23 | color='black', size=0.3) + 24 | 25 | geom_point(data=davison2014, 26 | aes(x=ï..year_start, y= percentage_fromtext_nfig4), 27 | color='black', size=0.6) + 28 | 29 | xlab("") + ylab("Remaining wetland (%)") + 30 | line_plot_theme 31 | 32 | 33 | 34 | # save figure to file 35 | ggsave('./output/figures/remwet_global_ensemblemean_vs_davidson.png', 36 | width=87, height=80, dpi=600, units="mm", type = "cairo-png") 37 | dev.off() 38 | 39 | 40 | 41 | # delete objects 42 | rm(wetloss_ensemble_prc, f, davidson2014) 43 | 44 | -------------------------------------------------------------------------------- /plots/fcn/levelplot_forgif.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | # set mapping theme 4 | mapTheme <- rasterTheme(region = rev(brewer.pal(10, "RdBu")), 5 | axis.line = list(col = "transparent"), 6 | scales = list(x = list(draw = FALSE))) 7 | 8 | 9 | cutpts <- seq(0, 1, 0.05) # set symbol cutoffs 10 | 11 | 12 | if(yrs[t]<0){ 13 | yr_label <- paste0(yrs[t]*-1, 'BC') 14 | } else { 15 | yr_label <- paste0(yrs[t], 'AD') 16 | } 17 | 18 | 19 | 20 | 21 | # plot glacier/submerged land 22 | plt<- levelplot(glacier, 23 | margin = F, 24 | col.regions='grey90', 25 | pretty=TRUE, 26 | par.settings = mapTheme, 27 | main=paste0("Inundated percentage \n ", month.abb[m], " ", yr_label), 28 | par.strip.text=list(cex=0.5, lines=10, fontface='bold'), 29 | axes=FALSE, box=FALSE, 30 | scales=list(draw=FALSE), 31 | xlab=NULL, ylab=NULL, 32 | colorkey=F)#list(space="bottom", draw=FALSE)) 33 | 34 | 35 | # plot inundated % 36 | plt<- plt + levelplot(lu, 37 | #margin = F, 38 | at=cutpts, 39 | cuts=10, # nb of colors 40 | pretty=TRUE, 41 | par.settings = mapTheme, 42 | colorkey=list(space="bottom")) 43 | 44 | 45 | print(plt) 46 | 47 | 48 | 49 | 50 | -------------------------------------------------------------------------------- /data_proc/fit/mcmc_fit/members/run_mcmc_s2_p1.r: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------# 2 | #/ SET WD ---------- 3 | library(here); here() # setwd to the location of the project 4 | source('./data_proc/prep_init.r') # Prep functions, themes, etc. 5 | library(ggpubr) #ggarrange 6 | library(fasterize) 7 | options(row.names=FALSE, scipen = 999) 8 | 9 | 10 | # /----------------------------------------------------------------------------- 11 | #/ Run the MCMC 12 | source('./data_proc/distrib_drainage/bayesian_param_fit_with_df_v2.r') 13 | 14 | 15 | 16 | # /------------------------------------------------------------------ 17 | #/ Prep MCMC, changing the preswet 18 | # Args: s_i, p_i, niteration 19 | s_i = 2 20 | p_i = 1 21 | niteration= 1000 22 | 23 | # /------------------------------------------------------------------ 24 | #/ Run MCMC & save 25 | # ptm <- proc.time() 26 | myMCMC <- run_my_mcmc(s_i, p_i, niteration) 27 | # proc.time() - ptm 28 | 29 | out_f <- paste0('../output/results/mcmc/mcmc_obj/s', s_i, '_', 'p', p_i, 'i', niteration, '.rds') 30 | saveRDS(myMCMC, out_f) 31 | 32 | 33 | # /------------------------------------------------------------------ 34 | #/ Get and save parameters 35 | pars <- get_pars_range(myMCMC) 36 | out_f <- paste0('../output/results/mcmc/parameters/s', s_i, '_', 'p', p_i, 'i', niteration, '.rds') 37 | write.csv(pars, out_f) 38 | 39 | -------------------------------------------------------------------------------- /data_proc/fit/mcmc_fit/members/run_mcmc_s2_p2.r: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------# 2 | #/ SET WD ---------- 3 | library(here); here() # setwd to the location of the project 4 | source('./data_proc/prep_init.r') # Prep functions, themes, etc. 5 | library(ggpubr) #ggarrange 6 | library(fasterize) 7 | options(row.names=FALSE, scipen = 999) 8 | 9 | 10 | # /----------------------------------------------------------------------------- 11 | #/ Run the MCMC 12 | source('./data_proc/distrib_drainage/bayesian_param_fit_with_df_v2.r') 13 | 14 | 15 | 16 | # /------------------------------------------------------------------ 17 | #/ Prep MCMC, changing the preswet 18 | # Args: s_i, p_i, niteration 19 | s_i = 2 20 | p_i = 2 21 | niteration= 1000 22 | 23 | # /------------------------------------------------------------------ 24 | #/ Run MCMC & save 25 | # ptm <- proc.time() 26 | myMCMC <- run_my_mcmc(s_i, p_i, niteration) 27 | # proc.time() - ptm 28 | 29 | out_f <- paste0('../output/results/mcmc/mcmc_obj/s', s_i, '_', 'p', p_i, 'i', niteration, '.rds') 30 | saveRDS(myMCMC, out_f) 31 | 32 | 33 | # /------------------------------------------------------------------ 34 | #/ Get and save parameters 35 | pars <- get_pars_range(myMCMC) 36 | out_f <- paste0('../output/results/mcmc/parameters/s', s_i, '_', 'p', p_i, 'i', niteration, '.rds') 37 | write.csv(pars, out_f) 38 | 39 | -------------------------------------------------------------------------------- /data_proc/fit/mcmc_fit/members/run_mcmc_s2_p3.r: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------# 2 | #/ SET WD ---------- 3 | library(here); here() # setwd to the location of the project 4 | source('./data_proc/prep_init.r') # Prep functions, themes, etc. 5 | library(ggpubr) #ggarrange 6 | library(fasterize) 7 | options(row.names=FALSE, scipen = 999) 8 | 9 | 10 | # /----------------------------------------------------------------------------- 11 | #/ Run the MCMC 12 | source('./data_proc/distrib_drainage/bayesian_param_fit_with_df_v2.r') 13 | 14 | 15 | 16 | # /------------------------------------------------------------------ 17 | #/ Prep MCMC, changing the preswet 18 | # Args: s_i, p_i, niteration 19 | s_i = 2 20 | p_i = 3 21 | niteration= 1000 22 | 23 | # /------------------------------------------------------------------ 24 | #/ Run MCMC & save 25 | # ptm <- proc.time() 26 | myMCMC <- run_my_mcmc(s_i, p_i, niteration) 27 | # proc.time() - ptm 28 | 29 | out_f <- paste0('../output/results/mcmc/mcmc_obj/s', s_i, '_', 'p', p_i, 'i', niteration, '.rds') 30 | saveRDS(myMCMC, out_f) 31 | 32 | 33 | # /------------------------------------------------------------------ 34 | #/ Get and save parameters 35 | pars <- get_pars_range(myMCMC) 36 | out_f <- paste0('../output/results/mcmc/parameters/s', s_i, '_', 'p', p_i, 'i', niteration, '.rds') 37 | write.csv(pars, out_f) 38 | 39 | -------------------------------------------------------------------------------- /data_proc/fit/mcmc_fit/members/run_mcmc_s3_p1.r: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------# 2 | #/ SET WD ---------- 3 | library(here); here() # setwd to the location of the project 4 | source('./data_proc/prep_init.r') # Prep functions, themes, etc. 5 | library(ggpubr) #ggarrange 6 | library(fasterize) 7 | options(row.names=FALSE, scipen = 999) 8 | 9 | 10 | # /----------------------------------------------------------------------------- 11 | #/ Run the MCMC 12 | source('./data_proc/distrib_drainage/bayesian_param_fit_with_df_v2.r') 13 | 14 | 15 | 16 | # /------------------------------------------------------------------ 17 | #/ Prep MCMC, changing the preswet 18 | # Args: s_i, p_i, niteration 19 | s_i = 3 20 | p_i = 1 21 | niteration= 1000 22 | 23 | # /------------------------------------------------------------------ 24 | #/ Run MCMC & save 25 | # ptm <- proc.time() 26 | myMCMC <- run_my_mcmc(s_i, p_i, niteration) 27 | # proc.time() - ptm 28 | 29 | out_f <- paste0('../output/results/mcmc/mcmc_obj/s', s_i, '_', 'p', p_i, 'i', niteration, '.rds') 30 | saveRDS(myMCMC, out_f) 31 | 32 | 33 | # /------------------------------------------------------------------ 34 | #/ Get and save parameters 35 | pars <- get_pars_range(myMCMC) 36 | out_f <- paste0('../output/results/mcmc/parameters/s', s_i, '_', 'p', p_i, 'i', niteration, '.rds') 37 | write.csv(pars, out_f) 38 | 39 | -------------------------------------------------------------------------------- /data_proc/fit/mcmc_fit/members/run_mcmc_s3_p2.r: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------# 2 | #/ SET WD ---------- 3 | library(here); here() # setwd to the location of the project 4 | source('./data_proc/prep_init.r') # Prep functions, themes, etc. 5 | library(ggpubr) #ggarrange 6 | library(fasterize) 7 | options(row.names=FALSE, scipen = 999) 8 | 9 | 10 | # /----------------------------------------------------------------------------- 11 | #/ Run the MCMC 12 | source('./data_proc/distrib_drainage/bayesian_param_fit_with_df_v2.r') 13 | 14 | 15 | 16 | # /------------------------------------------------------------------ 17 | #/ Prep MCMC, changing the preswet 18 | # Args: s_i, p_i, niteration 19 | s_i = 3 20 | p_i = 2 21 | niteration= 1000 22 | 23 | # /------------------------------------------------------------------ 24 | #/ Run MCMC & save 25 | # ptm <- proc.time() 26 | myMCMC <- run_my_mcmc(s_i, p_i, niteration) 27 | # proc.time() - ptm 28 | 29 | out_f <- paste0('../output/results/mcmc/mcmc_obj/s', s_i, '_', 'p', p_i, 'i', niteration, '.rds') 30 | saveRDS(myMCMC, out_f) 31 | 32 | 33 | # /------------------------------------------------------------------ 34 | #/ Get and save parameters 35 | pars <- get_pars_range(myMCMC) 36 | out_f <- paste0('../output/results/mcmc/parameters/s', s_i, '_', 'p', p_i, 'i', niteration, '.rds') 37 | write.csv(pars, out_f) 38 | 39 | -------------------------------------------------------------------------------- /data_proc/fit/mcmc_fit/members/run_mcmc_s3_p3.r: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------# 2 | #/ SET WD ---------- 3 | library(here); here() # setwd to the location of the project 4 | source('./data_proc/prep_init.r') # Prep functions, themes, etc. 5 | library(ggpubr) #ggarrange 6 | library(fasterize) 7 | options(row.names=FALSE, scipen = 999) 8 | 9 | 10 | # /----------------------------------------------------------------------------- 11 | #/ Run the MCMC 12 | source('./data_proc/distrib_drainage/bayesian_param_fit_with_df_v2.r') 13 | 14 | 15 | 16 | # /------------------------------------------------------------------ 17 | #/ Prep MCMC, changing the preswet 18 | # Args: s_i, p_i, niteration 19 | s_i = 3 20 | p_i = 3 21 | niteration= 1000 22 | 23 | # /------------------------------------------------------------------ 24 | #/ Run MCMC & save 25 | # ptm <- proc.time() 26 | myMCMC <- run_my_mcmc(s_i, p_i, niteration) 27 | # proc.time() - ptm 28 | 29 | out_f <- paste0('../output/results/mcmc/mcmc_obj/s', s_i, '_', 'p', p_i, 'i', niteration, '.rds') 30 | saveRDS(myMCMC, out_f) 31 | 32 | 33 | # /------------------------------------------------------------------ 34 | #/ Get and save parameters 35 | pars <- get_pars_range(myMCMC) 36 | out_f <- paste0('../output/results/mcmc/parameters/s', s_i, '_', 'p', p_i, 'i', niteration, '.rds') 37 | write.csv(pars, out_f) 38 | 39 | -------------------------------------------------------------------------------- /data_proc/fit/mcmc_fit/members/run_mcmc_s4_p1.r: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------# 2 | #/ SET WD ---------- 3 | library(here); here() # setwd to the location of the project 4 | source('./data_proc/prep_init.r') # Prep functions, themes, etc. 5 | library(ggpubr) #ggarrange 6 | library(fasterize) 7 | options(row.names=FALSE, scipen = 999) 8 | 9 | 10 | # /----------------------------------------------------------------------------- 11 | #/ Run the MCMC 12 | source('./data_proc/distrib_drainage/bayesian_param_fit_with_df_v2.r') 13 | 14 | 15 | 16 | # /------------------------------------------------------------------ 17 | #/ Prep MCMC, changing the preswet 18 | # Args: s_i, p_i, niteration 19 | s_i = 4 20 | p_i = 1 21 | niteration= 1000 22 | 23 | # /------------------------------------------------------------------ 24 | #/ Run MCMC & save 25 | # ptm <- proc.time() 26 | myMCMC <- run_my_mcmc(s_i, p_i, niteration) 27 | # proc.time() - ptm 28 | 29 | out_f <- paste0('../output/results/mcmc/mcmc_obj/s', s_i, '_', 'p', p_i, 'i', niteration, '.rds') 30 | saveRDS(myMCMC, out_f) 31 | 32 | 33 | # /------------------------------------------------------------------ 34 | #/ Get and save parameters 35 | pars <- get_pars_range(myMCMC) 36 | out_f <- paste0('../output/results/mcmc/parameters/s', s_i, '_', 'p', p_i, 'i', niteration, '.rds') 37 | write.csv(pars, out_f) 38 | 39 | -------------------------------------------------------------------------------- /data_proc/fit/mcmc_fit/members/run_mcmc_s4_p2 .r: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------# 2 | #/ SET WD ---------- 3 | library(here); here() # setwd to the location of the project 4 | source('./data_proc/prep_init.r') # Prep functions, themes, etc. 5 | library(ggpubr) #ggarrange 6 | library(fasterize) 7 | options(row.names=FALSE, scipen = 999) 8 | 9 | 10 | # /----------------------------------------------------------------------------- 11 | #/ Run the MCMC 12 | source('./data_proc/distrib_drainage/bayesian_param_fit_with_df_v2.r') 13 | 14 | 15 | 16 | # /------------------------------------------------------------------ 17 | #/ Prep MCMC, changing the preswet 18 | # Args: s_i, p_i, niteration 19 | s_i = 4 20 | p_i = 2 21 | niteration= 1000 22 | 23 | # /------------------------------------------------------------------ 24 | #/ Run MCMC & save 25 | # ptm <- proc.time() 26 | myMCMC <- run_my_mcmc(s_i, p_i, niteration) 27 | # proc.time() - ptm 28 | 29 | out_f <- paste0('../output/results/mcmc/mcmc_obj/s', s_i, '_', 'p', p_i, 'i', niteration, '.rds') 30 | saveRDS(myMCMC, out_f) 31 | 32 | 33 | # /------------------------------------------------------------------ 34 | #/ Get and save parameters 35 | pars <- get_pars_range(myMCMC) 36 | out_f <- paste0('../output/results/mcmc/parameters/s', s_i, '_', 'p', p_i, 'i', niteration, '.rds') 37 | write.csv(pars, out_f) 38 | 39 | -------------------------------------------------------------------------------- /data_proc/fit/mcmc_fit/members/run_mcmc_s4_p3.r: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------# 2 | #/ SET WD ---------- 3 | library(here); here() # setwd to the location of the project 4 | source('./data_proc/prep_init.r') # Prep functions, themes, etc. 5 | library(ggpubr) #ggarrange 6 | library(fasterize) 7 | options(row.names=FALSE, scipen = 999) 8 | 9 | 10 | # /----------------------------------------------------------------------------- 11 | #/ Run the MCMC 12 | source('./data_proc/distrib_drainage/bayesian_param_fit_with_df_v2.r') 13 | 14 | 15 | 16 | # /------------------------------------------------------------------ 17 | #/ Prep MCMC, changing the preswet 18 | # Args: s_i, p_i, niteration 19 | s_i = 4 20 | p_i = 3 21 | niteration= 1000 22 | 23 | # /------------------------------------------------------------------ 24 | #/ Run MCMC & save 25 | # ptm <- proc.time() 26 | myMCMC <- run_my_mcmc(s_i, p_i, niteration) 27 | # proc.time() - ptm 28 | 29 | out_f <- paste0('../output/results/mcmc/mcmc_obj/s', s_i, '_', 'p', p_i, 'i', niteration, '.rds') 30 | saveRDS(myMCMC, out_f) 31 | 32 | 33 | # /------------------------------------------------------------------ 34 | #/ Get and save parameters 35 | pars <- get_pars_range(myMCMC) 36 | out_f <- paste0('../output/results/mcmc/parameters/s', s_i, '_', 'p', p_i, 'i', niteration, '.rds') 37 | write.csv(pars, out_f) 38 | 39 | -------------------------------------------------------------------------------- /data_proc/fit/mcmc_fit/members/run_mcmc_s1_p1.r: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------# 2 | #/ SET WD ---------- 3 | library(here); here() # setwd to the location of the project 4 | source('./data_proc/prep_init.r') # Prep functions, themes, etc. 5 | library(ggpubr) #ggarrange 6 | library(fasterize) 7 | options(row.names=FALSE, scipen = 999) 8 | 9 | 10 | 11 | # /----------------------------------------------------------------------------- 12 | #/ Run the MCMC 13 | source('./data_proc/distrib_drainage/bayesian_param_fit_with_df_v2.r') 14 | 15 | 16 | 17 | # /------------------------------------------------------------------ 18 | #/ Prep MCMC, changing the preswet 19 | # Args: s_i, p_i, niteration 20 | s_i = 1 21 | p_i = 1 22 | niteration= 1000 23 | 24 | # /------------------------------------------------------------------ 25 | #/ Run MCMC & save 26 | # ptm <- proc.time() 27 | myMCMC <- run_my_mcmc(s_i, p_i, niteration) 28 | # proc.time() - ptm 29 | 30 | out_f <- paste0('../output/results/mcmc/mcmc_obj/s', s_i, '_', 'p', p_i, 'i', niteration, '.rds') 31 | saveRDS(myMCMC, out_f) 32 | 33 | 34 | # /------------------------------------------------------------------ 35 | #/ Get and save parameters 36 | pars <- get_pars_range(myMCMC) 37 | out_f <- paste0('../output/results/mcmc/parameters/s', s_i, '_', 'p', p_i, 'i', niteration, '.rds') 38 | write.csv(pars, out_f) 39 | 40 | -------------------------------------------------------------------------------- /data_proc/fit/mcmc_fit/members/run_mcmc_s1_p2.r: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------# 2 | #/ SET WD ---------- 3 | library(here); here() # setwd to the location of the project 4 | source('./data_proc/prep_init.r') # Prep functions, themes, etc. 5 | library(ggpubr) #ggarrange 6 | library(fasterize) 7 | options(row.names=FALSE, scipen = 999) 8 | 9 | 10 | 11 | # /----------------------------------------------------------------------------- 12 | #/ Run the MCMC 13 | source('./data_proc/distrib_drainage/bayesian_param_fit_with_df_v2.r') 14 | 15 | 16 | 17 | # /------------------------------------------------------------------ 18 | #/ Prep MCMC, changing the preswet 19 | # Args: s_i, p_i, niteration 20 | s_i = 1 21 | p_i = 2 22 | niteration= 1000 23 | 24 | # /------------------------------------------------------------------ 25 | #/ Run MCMC & save 26 | # ptm <- proc.time() 27 | myMCMC <- run_my_mcmc(s_i, p_i, niteration) 28 | # proc.time() - ptm 29 | 30 | out_f <- paste0('../output/results/mcmc/mcmc_obj/s', s_i, '_', 'p', p_i, 'i', niteration, '.rds') 31 | saveRDS(myMCMC, out_f) 32 | 33 | 34 | # /------------------------------------------------------------------ 35 | #/ Get and save parameters 36 | pars <- get_pars_range(myMCMC) 37 | out_f <- paste0('../output/results/mcmc/parameters/s', s_i, '_', 'p', p_i, 'i', niteration, '.rds') 38 | write.csv(pars, out_f) 39 | 40 | -------------------------------------------------------------------------------- /data_proc/fit/mcmc_fit/members/run_mcmc_s1_p3.r: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------# 2 | #/ SET WD ---------- 3 | library(here); here() # setwd to the location of the project 4 | source('./data_proc/prep_init.r') # Prep functions, themes, etc. 5 | library(ggpubr) #ggarrange 6 | library(fasterize) 7 | options(row.names=FALSE, scipen = 999) 8 | 9 | 10 | 11 | # /----------------------------------------------------------------------------- 12 | #/ Run the MCMC 13 | source('./data_proc/distrib_drainage/bayesian_param_fit_with_df_v2.r') 14 | 15 | 16 | 17 | # /------------------------------------------------------------------ 18 | #/ Prep MCMC, changing the preswet 19 | # Args: s_i, p_i, niteration 20 | s_i = 1 21 | p_i = 3 22 | niteration= 1000 23 | 24 | # /------------------------------------------------------------------ 25 | #/ Run MCMC & save 26 | # ptm <- proc.time() 27 | myMCMC <- run_my_mcmc(s_i, p_i, niteration) 28 | # proc.time() - ptm 29 | 30 | out_f <- paste0('../output/results/mcmc/mcmc_obj/s', s_i, '_', 'p', p_i, 'i', niteration, '.rds') 31 | saveRDS(myMCMC, out_f) 32 | 33 | 34 | # /------------------------------------------------------------------ 35 | #/ Get and save parameters 36 | pars <- get_pars_range(myMCMC) 37 | out_f <- paste0('../output/results/mcmc/parameters/s', s_i, '_', 'p', p_i, 'i', niteration, '.rds') 38 | write.csv(pars, out_f) 39 | 40 | -------------------------------------------------------------------------------- /plots/artif_drainage/lineplot_drainage_interpolated_1000ha.r: -------------------------------------------------------------------------------- 1 | 2 | 3 | ## plot for in between years --------------------------------------------------- 4 | drained_area_interp_plot <- ggplot() + 5 | 6 | geom_point(data=subset(d, type=="cropland"), aes(x=year, y=drained_area_tot), color='blue', size=0.4) + 7 | geom_line(data=subset(di, type=="cropland"), aes(x=year, y=ts_drained_area_tot), color='blue',size=0.4, alpha=0.3) + 8 | 9 | geom_point(data=subset(d, type=="forestry"), aes(x=year, y=drained_area_tot), color='green', size=0.4) + 10 | geom_line(data=subset(di, type=="forestry"), aes(x=year, y=ts_drained_area_tot), color='green',size=0.4, alpha=0.3) + 11 | 12 | geom_point(data=subset(d, type=="peatland"), aes(x=year, y=drained_area_tot), color='brown', size=0.4) + 13 | geom_line(data=subset(di, type=="peatland"), aes(x=year, y=ts_drained_area_tot), color='brown',size=0.4, alpha=0.3) + 14 | 15 | #geom_bar(data=a, (aes=)) 16 | scale_x_continuous(limits=c(1900, 2010)) + 17 | 18 | expand_limits(y=0) + 19 | facet_wrap(~country_name, scales="free") + 20 | #facet_grid(type~continent, scales="free") + 21 | line_plot_theme + 22 | theme(legend.position = c(0.8, 0.1)) + 23 | ylab("Area drained (1000 ha)") + xlab("") 24 | 25 | 26 | ### save plot 27 | ggsave(plot=drained_area_interp_plot, 28 | "./output/figures/artif_drainage/artif_drainage_nat_interp_area_v2.png", 29 | dpi=300, width=550, height=300, units='mm' , type = "cairo-png") 30 | 31 | dev.off() -------------------------------------------------------------------------------- /plots/fig2abcd/fig1a_2022_drainarea.r: -------------------------------------------------------------------------------- 1 | 2 | # /----------------------------------------------------------------------------# 3 | #/ FIG 1a 4 | 5 | fig2b_onlyloss <- 6 | 7 | ggplot()+ 8 | # countries background & outline 9 | geom_polygon(data=countries_robin_df, aes(long, lat, group=group), fill='grey90', color=NA, size=0.08) + 10 | 11 | # Coastline 12 | geom_path(data=coastsCoarse_robin_df, aes(long, lat, group=group), color='grey70', size=0.1) + 13 | 14 | # Add wetloss raster 15 | geom_raster(data=grid_remwet_perc_robin_df, aes(x=x, y=y, fill=cumloss_perc)) + 16 | 17 | # Add outline bounding box 18 | geom_path(data=bbox_robin_df, aes(long, lat, group=group), color='black', size=0.08) + 19 | 20 | coord_equal() + theme_raster_map() + 21 | 22 | # scale_y_continuous(limits=c(-6600000, 8953595)) + 23 | # '#fff385' 24 | scale_fill_gradient(low='#ffd11a', high='#e60000', 25 | breaks=c(1, 25, 50, 75, 100), 26 | limits=c(1, 100)) + 27 | # 28 | guides(fill = guide_colorbar(nbin=10, raster=F, 29 | barheight = 0.4, barwidth=7, 30 | frame.colour=c('black'), frame.linewidth=0.7, 31 | ticks.colour='black', direction='horizontal', 32 | title = expression(paste('Percentage of wetland loss\n (% of wetland area in 1700)')))) + 33 | 34 | theme(legend.position = 'bottom', 35 | legend.direction = 'horizontal') 36 | 37 | fig2b_onlyloss 38 | 39 | 40 | -------------------------------------------------------------------------------- /data_proc/artif_drainage/old/apply_sigmoid_drained.r: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------# 2 | #/ Apply the fit to countries with 3+ pts ---- 3 | 4 | # Get function that applies sigmoid 5 | source('./data_proc/artif_drainage/fcn/fcn_apply_sigmoid_drainage.r') 6 | 7 | # make list of years 8 | y = seq(1700, 2020, 10) 9 | 10 | ifrm(predall) 11 | 12 | # get unique cases, to then loop through 13 | ucases <- unique(d[,c('country_name','continent', 'type')]) 14 | 15 | # loop unique cases 16 | for (i in 1:nrow(ucases)){ 17 | 18 | c = as.character(ucases[i,'country_name']) 19 | t = as.character(ucases[i,'type']) 20 | o = as.character(ucases[i,'continent']) 21 | 22 | # subset data to unique case 23 | di = d %>% filter(d$country_name == c & d$type == t) 24 | 25 | # apply the sigmoid fit 26 | pred <- applysigmoid(di, fitall) 27 | 28 | # Cap the drained area to the maximum data point 29 | pred[pred$pred_drained > max(di$drained_area_tot),'pred_drained'] <- max(di$drained_area_tot) 30 | 31 | # append to output 32 | if (!exist(predall)){predall <- pred} else{ predall <- bind_rows(predall, pred)} 33 | } 34 | 35 | 36 | # /----------------------------------------------------------------------------# 37 | #/ Save predicted drained area 38 | write.csv(predall, "../output/results/artif_drainage/drained_wetcult_ha_sigmoidpred_v2.csv") 39 | 40 | 41 | 42 | 43 | # FACEt plot 44 | source('./plot/artif_drain/lineplot/facet_sigmoid_all.r') -------------------------------------------------------------------------------- /data_proc/fit/modfit/compile_modfit_pars.r: -------------------------------------------------------------------------------- 1 | 2 | # Set dir where modFit object are located 3 | p <- '../output/results/fit/mcmc/mcmc_obj/i3000' 4 | 5 | # List of modFit configs 6 | fls <- list.files(path=p, full.names = F) 7 | 8 | # Create empty df 9 | par_df <- data.frame() 10 | 11 | # /----------------------------------------------------------------------------# 12 | #/ Loop through files 13 | for (f in fls) { 14 | 15 | print(f) 16 | 17 | # Open modFit object 18 | t <- readRDS(paste0(p, '/', f)) 19 | # plot(t, Full=T) 20 | 21 | # Extract individual parameters 22 | # row <- data.frame(f, t$par[1], t$par[2], t$par[3], t$ssr) 23 | row <- data.frame(f, t$bestpar[1], t$bestpar[2], t$bestpar[3]) #, t$SS) 24 | 25 | # append row to df 26 | par_df <- bind_rows(par_df, row) 27 | 28 | } 29 | 30 | 31 | # Rename columns 32 | names(par_df) <- c('run_id','theta_rice','theta_pasture','theta_urban','ssr') 33 | 34 | # Convert columns of run IDs 35 | par_df <- par_df %>% 36 | mutate(s = as.numeric(substr(run_id, 9, 9)), 37 | p = as.numeric(substr(run_id, 12, 12))) 38 | 39 | 40 | # /----------------------------------------------------------------------------# 41 | #/ Write to csv 42 | write.csv(par_df, '../output/results/mcmc/parameters/pars_modFit_v2.csv') 43 | 44 | 45 | 46 | 47 | f= fls[12] 48 | t <- readRDS(paste0(p, '/', f)) 49 | summary(t, cov=TRUE) 50 | print(t) 51 | FME::print.summary(t) 52 | 53 | plot(t$rsstrace, type='line') 54 | 55 | plot(t, full=T) 56 | 57 | # Largest residuals: 58 | # Yangtze 14 has lasrgest resids 59 | # Montana: n53 has reds\\sid 40 60 | # Wyoming: n77 has resid of 22 -------------------------------------------------------------------------------- /plots/wetloss_drivers/stacked_area_plot_global_wetloss_n_remaining.r: -------------------------------------------------------------------------------- 1 | 2 | # get global sum data 3 | 4 | 5 | #read.csv('../../output/results/global_sum_wetland_loss.csv') %>% 6 | 7 | globsums <- read.csv("./output/results/wetloss/sum/wetloss_ensemble_prc.csv") 8 | 9 | 10 | 11 | # gather(var, dat, tot_remwet_Mkm2:tot_irrice_Mkm2) %>% 12 | # filter(!year %in% c(1700, 2000)) 13 | 14 | 15 | # set year breaks 16 | mybreaks <- seq(-6000, 0, 2000) 17 | 18 | # make area plot 19 | #wetloss_plot <- 20 | ggplot(globsums) + 21 | 22 | geom_area(data=subset(globsums, var %in% c("tot_remwet_Mkm2","tot_wetloss_Mkm2","tot_convtorice_Mkm2")), 23 | aes(x=year, y=dat, fill=var)) + 24 | 25 | geom_line(data=subset(globsums, var=='tot_crop_Mkm2'), 26 | aes(x=year, y=dat, color='black'), size=1) + 27 | 28 | geom_line(data=subset(globsums, var=='tot_ir_ice_Mkm2'), 29 | aes(x=year, y=dat, color='pink'), size=1) + 30 | 31 | xlab("Year") + ylab("Area (Mkm2)") + 32 | scale_x_continuous(expand=c(0,0), breaks=mybreaks, labels=mybreaks, limits = c(-6000, max(mybreaks))) + 33 | scale_y_continuous(expand=c(0,0)) + 34 | scale_colour_manual(name = 'Human Land Cover', 35 | values =c('black'='black','pink'='pink'), labels = c('cropland','irrigated rice')) 36 | 37 | wetloss_plot 38 | 39 | 40 | ### save plot ------------------------------------------------------------------ 41 | ggsave("../../output/figures/area_plot_sum_wetloss.png", wetloss_plot, 42 | width=178, height=180, dpi=600, units='mm', type = "cairo-png") 43 | 44 | dev.off() 45 | -------------------------------------------------------------------------------- /data_proc/distrib_drainage/make_grid_isocodes.r: -------------------------------------------------------------------------------- 1 | 2 | # Needs this grid of maximum landarea to run the ISOGRID function 3 | maxlncr <- raster('../data/lucc/hyde32_beta/general_files/maxln_cr.asc', 4 | crs='+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0') 5 | origin(maxlncr) <- c(0,0) 6 | maxlncr <- extend(maxlncr, extent(-180, 180, -90, 90)) 7 | maxlncr <- aggregate(maxlncr, fact=6, fun='sum') 8 | 9 | 10 | 11 | # /----------------------------------------------------------------------------- 12 | #/ MAKE GRID OF COUNTRY ISO CODES 13 | 14 | library(rworldmap) 15 | sPDF <- getMap()[getMap()$ADMIN!='Antarctica','ISO_A3'] 16 | 17 | # this has 242 observations (hence 242 indiv countries) 18 | isolookup <- as.data.frame(sPDF$ISO_A3) 19 | isolookup$val <- as.numeric(sPDF$ISO_A3) 20 | 21 | # then we lose some small countries in the gridding 22 | ciso <- rasterize(sPDF, maxlncr, "ISO_A3") 23 | ciso <- ratify(ciso) 24 | 25 | 26 | isolookup2 <- isolookup %>% filter(isolookup$val %in% c(levels(ciso)[[1]])$ID) 27 | names(isolookup2) <- c("ISO_A3", "ID") 28 | isolookup2 <- isolookup2[,c("ID", "ISO_A3")] 29 | isolookup2$ISO_A3 <- as.character(isolookup2$ISO_A3) 30 | # levels(ciso) <- isolookup2 31 | 32 | 33 | # CONVERT TO DF 34 | ciso_df <- data.frame(as(ciso, 'SpatialPointsDataFrame')) %>% 35 | left_join(., isolookup2, by=c('layer'='ID')) %>% 36 | dplyr::select(x,y,ISO_A3) 37 | 38 | 39 | # ciso_df <- raster2df(ciso) 40 | ciso_df$x = round(ciso_df$x, 2) 41 | ciso_df$y = round(ciso_df$y, 2) 42 | ciso_df <- left_join(maxlncr_df_xy, ciso_df, by=c('x','y')) 43 | # ciso_df_adm3a <- ciso_df$layer 44 | # names(ciso_df_adm3a) <- c('adm3a') -------------------------------------------------------------------------------- /data_proc/distrib_drainage/fcn_distrib/fcn_distrib_drainage_theta.r: -------------------------------------------------------------------------------- 1 | # Theta distrib (unbounded) applies to rice and urban 2 | 3 | # /----------------------------------------------------------------------------# 4 | #/ For theta drainage, just cap drainage to allowable. no redistribution. ------ 5 | distrib_drainage_theta <- function(rdm_overlay, theta) { 6 | 7 | # /--------------------------------------------------------------------------# 8 | #/ ALLOWABLE drainage grid; So drainage cannot exceed potwet or LUarea 9 | # The POTWET area shouldn't be used for capping, just relative distribution 10 | allowable = get(paste0(v,'_eligible')) 11 | names(allowable) <- c('allowable') 12 | 13 | # glimpse(allowable) 14 | 15 | 16 | 17 | # /--------------------------------------------------------------------------# 18 | #/ Calculate each pixels % of national overlap (of wet-LU) ------- 19 | #/ Distribute drainage stats 20 | 21 | # print('rdm_overlay') 22 | # glimpse(rdm_overlay) 23 | # print('theta') 24 | # print(theta) 25 | 26 | # df <- data.frame(rdm_overlay) %>% mutate(t = .[[1]] * theta) %>% select(t) 27 | df <- rdm_overlay[1] * theta ## <--- BLOWS UP HERE 28 | names(df) <- 'drain_distrib' 29 | 30 | df <- df %>% 31 | bind_cols(., allowable) %>% 32 | # Cutoff ceiling value of drainage 33 | mutate(excess = ifelse( drain_distrib > allowable, drain_distrib-allowable, 0), 34 | drain_distrib = ifelse( drain_distrib > allowable, allowable, drain_distrib)) 35 | 36 | # Print sum area 37 | print(paste0(' - ', round(sum(df$drain_distrib, na.rm=T), 4), ' Mkm2')) 38 | 39 | return(df$drain_distrib) 40 | } 41 | -------------------------------------------------------------------------------- /plots/artif_drainage/lineplot/facet_sigmoid_all.r: -------------------------------------------------------------------------------- 1 | 2 | # /----------------------------------------------------------------------------# 3 | #/ Plot facets 4 | predall <- read.csv("./output/results/artif_drainage/drained_wetcult_ha_sigmoidpred.csv") 5 | 6 | 7 | m <- ggplot() + 8 | geom_line(data = predall, aes(x= year, y= pred_drained, color=type)) + 9 | geom_point(data= d, aes(x= year, y= drained_area_tot, color=type)) + 10 | expand_limits(y=0) + 11 | facet_wrap(~country_name, scales="free") + 12 | line_plot_theme + 13 | theme(legend.position = c(0.9, 0.03)) + 14 | ylab("Area drained (km^2)") + xlab("") 15 | 16 | ### save plot 17 | ggsave(plot=m, "./output/figures/artif_drainage/sigmoid/all/drain_sigmoid_predall_maxed.png", 18 | width=16.5, height=12.5, dpi=300, units='in' , type = "cairo-png") 19 | 20 | dev.off() 21 | 22 | 23 | 24 | # # /----------------------------------------------------------------------------# 25 | # #/ Make plot that stacks all curves 26 | # predall <- predall %>% 27 | # group_by(country_name, type) %>% 28 | # mutate(max_pred_drained = max(pred_drained)) %>% 29 | # mutate(perc_drained_ofmax = pred_drained/max_pred_drained) %>% 30 | # ungroup() 31 | # 32 | # 33 | # # /----------------------------------------------------------------------------# 34 | # #/ Plot facets 35 | # m <- ggplot() + 36 | # geom_line(data = predall, aes(x= year, y= perc_drained_ofmax, group=country_name, color=continent)) + 37 | # expand_limits(y=0) + 38 | # facet_grid(continent~type, scales="free", space="free") + 39 | # line_plot_theme + 40 | # theme(legend.position = "none") + # c(0.9, 0.03) 41 | # ylab("Area drained (km^2)") + xlab("") 42 | -------------------------------------------------------------------------------- /data_proc/fcn/get_hydecroparea_in_polygons.r: -------------------------------------------------------------------------------- 1 | # Description: 2 | # loop through polygons, find closest HYDE year, 3 | # then extract the total area from raster within each polygon. 4 | 5 | 6 | 7 | get_raster_closest_yr <- function(draintype, polygons, raster_stack){ 8 | 9 | # create output df for extracted data 10 | output_df <- data.frame() 11 | 12 | # loop through histcases (combinations of locations x period) 13 | for (i in seq(1, nrow(polygons))) { 14 | 15 | # select single histcase polygon 16 | temp_poly <- polygons[i,] 17 | 18 | # find closest time value in hyde years to histcase year 19 | closest_hyde_year <- hyde_yrs[which.min(abs(hyde_yrs - temp_poly$year))] 20 | 21 | # get the index of the closest year 22 | t <- match(closest_hyde_year, hyde_yrs) 23 | 24 | # get rasters of closest year (by matching names) 25 | temp_raster <-raster_stack[[grep(pattern=closest_hyde_year, names(raster_stack))]] 26 | #temp_raster <- raster(h, varname=draintype, band = hyde_indx[t], level=4) # get cropland; in km2 27 | 28 | # extract the value from wetloss rasters 29 | sum_raster <- raster::extract(temp_raster, temp_poly, fun=sum, na.rm=T, df=T) 30 | 31 | # add row to extracted data output df 32 | sum_r <- bind_cols(temp_poly@data, sum_raster[draintype], data.frame(closest_lu_year = closest_hyde_year)) 33 | 34 | # print ticker 35 | print(paste0(temp_poly@data$country_name, " in ", closest_hyde_year, ": ", round(sum_raster[draintype]), " km^2")) 36 | 37 | 38 | # add row to extracted data output df 39 | output_df <- bind_rows(output_df, sum_r) 40 | 41 | } 42 | return(output_df) 43 | } -------------------------------------------------------------------------------- /plots/fcn/timeline_drainage_country_facet.r: -------------------------------------------------------------------------------- 1 | 2 | country_facet_timeline <- function (input_df, output_dir){ 3 | 4 | ## plot for in between years --------------------------------------------------- 5 | drained_area_interp_plot <- 6 | 7 | ggplot() + 8 | 9 | # plot cropland 10 | geom_point(data=subset(d, type=="cropland"), aes(x=year, y=drained_area_tot), color='blue', size=0.4) + 11 | geom_line(data=subset(di, type=="cropland"), aes(x=year, y=ts_drained_area_tot), color='blue',size=0.4, alpha=0.3) + 12 | 13 | # plot forestry 14 | geom_point(data=subset(d, type=="forestry"), aes(x=year, y=drained_area_tot), color='green', size=0.4) + 15 | geom_line(data=subset(di, type=="forestry"), aes(x=year, y=ts_drained_area_tot), color='green',size=0.4, alpha=0.3) + 16 | 17 | # plot peatland 18 | geom_point(data=subset(d, type=="peatland"), aes(x=year, y=drained_area_tot), color='brown', size=0.4) + 19 | geom_line(data=subset(di, type=="peatland"), aes(x=year, y=ts_drained_area_tot), color='brown',size=0.4, alpha=0.3) + 20 | 21 | #geom_bar(data=a, (aes=)) 22 | scale_x_continuous(limits=c(1900, 2010)) + 23 | 24 | expand_limits(y=0) + 25 | facet_wrap(~country_name, scales="free") + 26 | 27 | line_plot_theme + 28 | theme(legend.position = c(0.8, 0.1)) + 29 | ylab("Area drained (1000 ha)") + xlab("") 30 | 31 | 32 | ### save plot 33 | ggsave(plot=drained_area_interp_plot, 34 | output_dir, 35 | dpi=300, width=550, height=300, units='mm' , type = "cairo-png") 36 | 37 | dev.off() 38 | 39 | } 40 | 41 | 42 | 43 | output_dir <- "./output/figures/artif_drainage/artif_drainage_nat_interp_area_v2.png" -------------------------------------------------------------------------------- /data_proc/hist_cases/wetindex_calc_loss.r: -------------------------------------------------------------------------------- 1 | # Description: This script calculates %loss per WET index site 2 | 3 | # read in WET database 4 | wetdb <- read.csv("../data/WETindex/WET_database_2017_FINAL_151217_geo.csv", 5 | stringsAsFactors = F) %>% 6 | 7 | # select columns that are unique per SITE, not different years of data 8 | dplyr::select(record_ID, WET.update, Country, Country.scale., Locality, Year, Time.of.year, Area..ha., Drivers, 9 | Natural.artificial, WET.classification, Reference) %>% 10 | mutate(Area..ha. = as.numeric(Area..ha.)) %>% 11 | # Remove duplicates 12 | unique() %>% 13 | group_by(record_ID, Country, Country.scale., Locality, Natural.artificial, WET.classification, Reference) %>% 14 | summarize(year_start = min(Year), 15 | year_end = max(Year), 16 | period_length_years = max(Year) - min(Year), 17 | Area_change_km2 = (max(Area..ha.) - min(Area..ha.)) *0.01, 18 | Area_start_km2 = max(Area..ha.)*0.01, 19 | perc_loss = round((max(Area..ha.) - min(Area..ha.))/ max(Area..ha.) *100, 2 )) %>% 20 | ungroup() 21 | 22 | 23 | 24 | 25 | glimpse(wetdb) 26 | 27 | 28 | # /----------------------------------------------------------------------------# 29 | #/ Filter 30 | wetdb_filt <- wetdb %>% 31 | dplyr::filter(period_length_years >= 30, 32 | Area_start_km2 >= 1000, 33 | Natural.artificial == 'Natural', 34 | WET.classification %in% c('Mixed inland wetland', 'Marshes on peat soils', 35 | 'Mixed wetland types', 'Lakes, pools & marshes')) 36 | 37 | 38 | write.csv(wetdb_filt, "../data/WETindex/WETdb_filt.csv") 39 | 40 | 41 | 42 | 43 | 44 | -------------------------------------------------------------------------------- /data_proc/artif_drainage/old/make_cropland_shp.R: -------------------------------------------------------------------------------- 1 | # Description: 2 | 3 | 4 | # create record IDs 5 | drained_ag <- drained %>% dplyr::filter(type == "cropland") 6 | 7 | 8 | #==============================================================================# 9 | ### Make shapefile of nat drainage stats --------------------------------------- 10 | #==============================================================================# 11 | 12 | # extract cropland area for year and country from HYDE to calculate % drained 13 | 14 | # get function that gets polygons for each row 15 | source("./scripts/r/data_proc/fcn/fcn_get_polygons_for_drainage.r") 16 | 17 | # create a shapefile with a polygon for each record row 18 | # (some repeat because data from multiple years) 19 | artdrain_ag_nat <- sel_countries_in_shp(drained_ag, countries, "iso_a3", "adm0_a3", "rec_id") 20 | 21 | 22 | # join the data table to shapefile, using rec_id as key 23 | artdrain_ag_nat@data <- merge(artdrain_ag_nat@data, as.data.frame(drained), 24 | by="rec_id", all.x=T, all.y=F) 25 | 26 | 27 | #==============================================================================# 28 | ### SAVE OUTPUT POLYGONS -------------------------------------------------- 29 | #==============================================================================# 30 | 31 | # save the filtered table... is this necessary? 32 | #saveRDS(drained, "./output/results/artif_drainage/drained_ag_stats.rds") 33 | 34 | # save the selected shapefile as rds 35 | saveRDS(artdrain_ag_nat, "./output/results/artif_drainage/artdrain_ag_nat.rds") 36 | 37 | 38 | rm(histcases, histcases_nat, histcases_subnat, countries_shp, 39 | subnat_shp, h_c_shp, h_s_shp, histcases_shp) 40 | 41 | -------------------------------------------------------------------------------- /data_proc/distrib_drainage/fcn_distrib/fcn_distrib_drainage_pasture.r: -------------------------------------------------------------------------------- 1 | ################################################################################ 2 | distrib_drainage_pasture <- function(rdm_overlay, theta, year) { 3 | 4 | 5 | #/ ALLOWABLE drainage grid; So drainage cannot exceed potwet or LUarea 6 | # The POTWET area shouldn't be used for capping, just relative distribution 7 | # this is why now only the LU area is used as allowable cap 8 | # allowable = data.frame(get(v)[y]) 9 | allowable = get(paste0(v,'_eligible')) 10 | names(allowable) <- c('allowable') 11 | #allowable[allowable>3000] <- 3000 # Cap allowable to the area of gridcell 12 | 13 | 14 | # /--------------------------------------------------------------------------# 15 | #/ Calculate each pixels % of national overlap (of wet-LU) ------- 16 | 17 | #/ Distribute drainage stats 18 | df <- rdm_overlay * theta 19 | 20 | names(df) <- 'drain_distrib' 21 | 22 | df <- df %>% 23 | # Bind allowable area, as col 24 | bind_cols(., allowable) %>% 25 | # Bind country code area, as col 26 | bind_cols(., ciso_df) %>% 27 | mutate(year=year) %>% 28 | left_join(., cropland_perc_drained, by=c('iso_a3'='iso_a3', 'year'='year')) %>% 29 | ### BIG BIG BIG CHANGE - NOV 2021 - RELAX LIMIT ON PASTURE : removed the * 1.5 30 | mutate(crop_drain_cap = crop_drain_perc * allowable) %>% 31 | mutate(drain_distrib = ifelse( drain_distrib > crop_drain_cap, crop_drain_cap, drain_distrib)) 32 | # mutate(drain_distrib = ifelse( drain_distrib > allowable, allowable, drain_distrib)) 33 | 34 | 35 | print(paste0(' - ', round(sum(df$drain_distrib, na.rm=T), 4), ' Mkm2')) 36 | 37 | return(df$drain_distrib) 38 | } 39 | 40 | -------------------------------------------------------------------------------- /plots/map/old/combine_maps.r: -------------------------------------------------------------------------------- 1 | 2 | # function of lpx mask 3 | source('./scripts/r/plots/fcn/make_lpx_mask_overalltimes.r') 4 | 5 | # set legend position in maps 6 | l_pos <- c(0.18, 0.4) 7 | 8 | 9 | # map baseline wetland cover 10 | source('./scripts/r/plots/map_natwet_in6000bc.r') 11 | source('./scripts/r/plots/map_natwet_in1700.r') 12 | 13 | 14 | # map wetloss rate (km^2 year^-1) 15 | # source('./scripts/r/plots/map_remloss_rate_since6000bc.r') 16 | # source('./scripts/r/plots/map_remloss_rate_since1700.r') 17 | 18 | 19 | # revised by using wetland % change 20 | source('./scripts/r/plots/map_perc_remwet_since1700.r') 21 | source('./scripts/r/plots/map_perc_remwet_since6000bc.r') 22 | 23 | 24 | # MAP period of max wetloss 25 | source('./scripts/r/plots/map_period_max_wetloss_rate_since_6000bc.r') 26 | source('./scripts/r/plots/map_period_max_wetloss_rate_since_1700.r') 27 | 28 | 29 | 30 | 31 | c <- plot_grid(map_natwet_in6000bc, map_natwet_in1700ad, 32 | map_remloss_rate_since6000bc, map_remloss_rate_since1700, 33 | map_max_wetlossrate_since6000bc, map_max_wetlossrate_since1700, 34 | ncol=2, nrow=3, align="hv", 35 | labels=c("A","B","C","D","E","F")) 36 | 37 | 38 | 39 | ### Save figure to file -------------------------------------------------------- 40 | ggsave('./output/figures/maps_combined_aligned_v10.pdf', c, 41 | width=178, height=150, dpi=600, units="mm")#, type = "cairo-png") 42 | dev.off() 43 | 44 | ### Save figure to file -------------------------------------------------------- 45 | ggsave('./output/figures/maps_combined_aligned_v10.png', c, 46 | width=178, height=150, dpi=600, units="mm")#, type = "cairo-png") 47 | 48 | dev.off() 49 | -------------------------------------------------------------------------------- /plots/fcn/gif_wetloss_wetchimp_20thcentury.r: -------------------------------------------------------------------------------- 1 | # Save the raster stacks as R objects 2 | wetloss_Mk2_stack <- readRDS('../../output/results/wetloss_Mk2_stack_wetchimp.rds') 3 | remwet_Mkm2_stack <- readRDS('../../output/results/remwet_Mkm2_stack_wetchimp.rds') 4 | 5 | 6 | 7 | 8 | # read raster of gridcell area, accounting for projection 9 | area <- raster("../../data/ease_area_grid/area_easewgs84_0p5deg_corrextent.tif") 10 | 11 | 12 | wetloss_perc_stack <- wetloss_Mk2_stack / area * 100 13 | # transfer names 14 | names(wetloss_perc_stack) <- names(wetloss_Mk2_stack) 15 | 16 | 17 | # subset the stack per model name 18 | subset_stack <- function(greppattern, stack){ 19 | i <- grep(greppattern, names(stack)) 20 | t <- stack[[i]] } 21 | 22 | 23 | wetloss_perc_stack_DLEM <- subset_stack("DLEM", wetloss_perc_stack) 24 | wetloss_perc_stack_SDGVM <- subset_stack("SDGVM", wetloss_perc_stack) 25 | wetloss_perc_stack_pot <- subset_stack("wetland_potential", wetloss_perc_stack) 26 | wetloss_perc_stack_fmax <- subset_stack("fmax", wetloss_perc_stack) 27 | 28 | 29 | 30 | #ani.options("convert") 31 | saveGIF({ 32 | 33 | for(i in seq(1, length(names(DLEM_wetloss_Mk2_stack)))){ 34 | 35 | DLEM_temp <- wetloss_perc_stack_DLEM[[i]] 36 | DLEM_temp <- wetloss_perc_stack_SDGVM[[i]] 37 | DLEM_temp <- wetloss_perc_stack_pot[[i]] 38 | DLEM_temp <- wetloss_perc_stack_fmax[[i]] 39 | 40 | # print counter 41 | print(names(wet)) 42 | 43 | # plot wetloss w/ levelplot 44 | source('./plots/fcn/levelplot_forgif_wetloss_only.r') 45 | 46 | 47 | } 48 | }, movie.name = "../../output/figures/gif/wetloss_since1700.gif", 49 | ani.width=600, ani.height=300, interval = 0.5, clean=TRUE) 50 | 51 | dev.off() -------------------------------------------------------------------------------- /data_proc/fit/mcmc_init/init_natwet.r: -------------------------------------------------------------------------------- 1 | 2 | # /----------------------------------------------------------------------------# 3 | #/.. Read present day wetland GeoTiff ----- 4 | 5 | wad2m_preswet <- raster('../output/results/natwet/grid/swampsglwd_preswet.tif') # / 10^6 6 | wad2m_preswet_df = raster2df(wad2m_preswet) 7 | wad2m_preswet_df <- left_join(maxlncr_df_xy, wad2m_preswet_df, by=c('x','y')) 8 | wad2m_preswet_df <- wad2m_preswet_df$swampsglwd_preswet 9 | 10 | 11 | # GLWD3 (classes 4-12) 12 | glwd3_wet_frac <- raster( '../output/results/natwet/preswet/glwd3_wet_fw.tif') 13 | crs(glwd3_wet_frac) <- CRS('+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0') 14 | glwd3_wet_a <- glwd3_wet_frac * raster::area(glwd3_wet_frac) 15 | glwd3_wet_a <- aggregate(glwd3_wet_a, fact=2, fun=sum, na.rm=T) 16 | glwd3_wet_a_df = raster2df(glwd3_wet_a) 17 | glwd3_wet_a_df$x = round(glwd3_wet_a_df$x, 2) 18 | glwd3_wet_a_df$y = round(glwd3_wet_a_df$y, 2)# round coordinates for join 19 | glwd3_wet_a_df <- left_join(maxlncr_df_xy, glwd3_wet_a_df, by=c('x','y')) 20 | glwd3_wet_a_df <- glwd3_wet_a_df$layer 21 | 22 | 23 | # GIEMS v2 (minus GLWD 1-3) 24 | giems2_wet <- raster('../output/results/natwet/preswet/old/giems2_max_wet.tif') 25 | giems2_wet <- aggregate(giems2_wet, fact=2, fun=sum) # aggregate to 0.5deg 26 | giems2_wet_df = raster2df(giems2_wet) # Convert to df 27 | giems2_wet_df <- left_join(maxlncr_df_xy, giems2_wet_df, by=c('x','y')) 28 | giems2_wet_df <- giems2_wet_df$giems2_max_wet 29 | 30 | 31 | # Get global sums 32 | # cellStats(wad2m_preswet, stat='sum', na.rm=T)/10^6 33 | # cellStats(glwd3_wet_a, stat='sum', na.rm=T)/10^6 34 | # cellStats(giems2_wet, stat='sum', na.rm=T)/10^6 35 | 36 | # pres_wet <- raster('../output/results/potwet/pres_wet.tif') / 10^6 -------------------------------------------------------------------------------- /plots/gif/gif_map_monthly_stocker_wetarea.R: -------------------------------------------------------------------------------- 1 | # import packages 2 | library(ncdf4) 3 | library(raster) 4 | library(rasterVis) 5 | library(maptools) 6 | library(maps) 7 | library(animation) 8 | 9 | setwd('C:/Users/efluet/Dropbox/Chap3_holocene_global_wetland_loss') 10 | #setwd('C:/Users/efluet/Dropbox/Chap3_holocene_global_wetland_loss/scripts/r') 11 | #setwd('../../output/fig/gif/') 12 | 13 | d <- './data/nat_wetland_map/trace21_129.cdf' 14 | #d <- 'C:/Users/efluet/Dropbox/Chap3_holocene_global_wetland_loss/data/nat_wetland_map/trace21_129.cdf' 15 | nc <- nc_open(d) 16 | 17 | 18 | yrs <- c(unique(ncvar_get( nc, attributes(nc$dim)$names[4]))) # get year labels 19 | yrs <- yrs[yrs > -10105] # filter to only years since 10kBC 20 | yrnb <- seq(1, length(yrs), 30) # subsample the timeseries 21 | 22 | 23 | #ani.options("convert") 24 | saveGIF({ 25 | 26 | # # The "%02d" is a placeholder for a two character counter (01,02 etc.). 27 | # png(file="example%02d.png", 28 | # width=300, height=200, units="mm", res=300) 29 | 30 | # loop through the years ===================================================== 31 | for (t in yrnb){ 32 | 33 | for(m in seq(1, 12, 1)){ 34 | 35 | print(paste0("now mapping:", t, " ", m)) 36 | 37 | # read a specific band 38 | lu <- raster(d, varname="inund", band = t, level=m) 39 | 40 | # read a specific band 41 | glacier <- raster(d, varname="lu_area", 42 | band = t, level=4) 43 | 44 | # run the plot 45 | source('./plots/fcn/levelplot_forgif.R') 46 | 47 | } 48 | } 49 | }, movie.name = "./output/figs/gif/inund_stocker_post10k_v6.gif", ani.width=600, ani.height=300, interval = 0.05, clean=TRUE) 50 | 51 | -------------------------------------------------------------------------------- /plots/fig3abc/fig3_2021_v2.r: -------------------------------------------------------------------------------- 1 | # Dataframe of 2 | corr_r2_df <- data.frame() 3 | 4 | # Run without thetas 5 | # test_theta=1 6 | # pars='avg' 7 | 8 | # Matrix facet plot 9 | for (s_i in c(1,2,3,4)) { 10 | for (p_i in c(1,2,3)) { 11 | 12 | print(paste0('s', s_i, ' p', p_i)) 13 | 14 | # /----------------------------------------------------------------------------# 15 | #/ Fig 2 A - Case studies map 16 | source('plots/fig3abc/fig3a_2021_v2.r') 17 | 18 | # /----------------------------------------------------------------------------# 19 | #/ Fig 2 B - scatterplot vs CaseStudies (Davidson, WET, ...) 20 | source('plots/fig3abc/fig3b_2021.r') 21 | 22 | 23 | # /----------------------------------------------------------------------------# 24 | #/ Make multipanel plot ------ 25 | 26 | # arrange plots grob into layout 27 | fig3 <- plot_grid(fig3a_histcase_map, fig3_scatter, # fig3c_cumulplot, 28 | ncol=1, nrow=2, 29 | rel_heights = c(0.45, 1), # 1), 30 | labels = c('A','B')) #,'C'), 31 | # align='v') 32 | 33 | # fig3 34 | 35 | # /----------------------------------------------------------------------------# 36 | #/ Save figure to file -------- 37 | if(1){ 38 | ggsave(paste0('../output/figures/fig3/v12/fig3ab_2021_s',s_i,'_p',p_i,'_t', test_theta, '_', pars, '_v12.png'), fig3, 39 | width=90, height=230, dpi=600, units='mm' ) 40 | 41 | ggsave(paste0('../output/figures/fig3/v12/fig3ab_2021_s',s_i,'_p',p_i,'_t', test_theta, '_', pars, '_v12.pdf'), fig3, 42 | width=90, height=230, dpi=600, units='mm') 43 | } 44 | 45 | # end of loop 46 | } 47 | } 48 | 49 | -------------------------------------------------------------------------------- /plots/gif/gif_wetloss_since1700.R: -------------------------------------------------------------------------------- 1 | 2 | # get hyde years =============================================================== 3 | h <- './output/results/hyde32_0.5.nc' 4 | hyde_yrs <- sort(nc_open(h)$dim$time$vals) 5 | 6 | 7 | 8 | # Save the raster stacks as R objects 9 | wetloss_Mk2_stack <- readRDS('./output/results/wetloss_Mk2_stack_wetchimp.rds') 10 | remwet_Mkm2_stack <- readRDS('./output/results/remwet_Mkm2_stack_wetchimp.rds') 11 | 12 | names(wetloss_Mk2_stack) 13 | wetloss_Mk2_stack_dlem <- raster::subset(wetloss_Mk2_stack, grep('weta_1_DLEM', names(wetloss_Mk2_stack), value = T)) 14 | wetloss_Mk2_stack_fmax <- raster::subset(wetloss_Mk2_stack, grep('fmax', names(wetloss_Mk2_stack), value = T)) 15 | wetloss_Mk2_stack_SDGVM <- raster::subset(wetloss_Mk2_stack, grep('weta_1_SDGVM', names(wetloss_Mk2_stack), value = T)) 16 | 17 | 18 | 19 | source("./plots/fcn/global_map_ggplot.r") 20 | 21 | 22 | saveGIF({ 23 | 24 | # why are 1850 and 1950 disapearing? plot global timeline? 25 | 26 | # loop through hyde years ====================================================== 27 | for (i in 1:length(hyde_yrs)){ 28 | 29 | 30 | d <- wetloss_Mk2_stack_dlem[[i]] 31 | d <- global_map_ggplot(d, 'OrRd') 32 | 33 | s <- wetloss_Mk2_stack_SDGVM[[i]] 34 | s <- global_map_ggplot(s, 'YlGn') 35 | 36 | f <- wetloss_Mk2_stack_fmax[[i]] 37 | f <- global_map_ggplot(f, 'YlGn') 38 | 39 | 40 | grid.arrange(d, s, f, ncol=1) 41 | 42 | } 43 | }, movie.name = "./output/figures/gif/natwet_remwet_wggplot.gif", ani.width=400, ani.height=600, interval = 0.5, clean=TRUE) 44 | dev.off() 45 | 46 | 47 | # ideas for plot =============================================================== 48 | # peak year of wetland loss 49 | # remaining % since 10kBC, since 0AD, since pre-industrial 50 | 51 | -------------------------------------------------------------------------------- /data_proc/fcn/fcn_raster_in_poly_sum_area.r: -------------------------------------------------------------------------------- 1 | # Description: loop through polygons, find closest HYDE year, 2 | # then extract the total area from raster within each polygon. 3 | 4 | 5 | 6 | ### Temporary variables 7 | # polygons <- artdrain_forest_natpoly 8 | # raster_stack <- wood_harvest 9 | # year_vector <- c(1500,1600,1700,seq(1800,2000,10)) 10 | 11 | 12 | 13 | get_raster_closest_yr <- function(draintype, polygons, raster_stack, year_vector){ 14 | 15 | # create output df for extracted data 16 | output_df <- data.frame() 17 | 18 | 19 | 20 | # loop through histcases 21 | for (i in seq(1, nrow(polygons))) { 22 | 23 | # select single histcase polygon 24 | temp_poly <- polygons[i,] 25 | 26 | # find closest time value in hyde years to histcase year 27 | closest_year <- year_vector[which.min(abs(year_vector - temp_poly$year))] 28 | 29 | #t <- match(closest_year, year_vector) 30 | 31 | # get rasters of closest year (by matching names) 32 | temp_raster <-raster_stack[[grep(pattern=closest_year, names(raster_stack))]] 33 | 34 | 35 | # extract the value from wetloss rasters ----------------------- 36 | 37 | sum_raster <- raster::extract(temp_raster, temp_poly, fun=sum, na.rm=T, df=T) 38 | names(sum_raster) <- c("id", draintype) 39 | 40 | # add row to extracted data output df 41 | sum_r <- bind_cols(temp_poly@data, sum_raster[draintype], data.frame(closest_lu_year = closest_year)) 42 | 43 | # print ticker 44 | print(paste0(temp_poly@data$country_name, " in ", closest_year, ": ", round(sum_raster[draintype], 1), " km^2")) 45 | 46 | # add row to extracted data output df 47 | output_df <- bind_rows(output_df, sum_r) 48 | 49 | } 50 | 51 | return(output_df) 52 | } -------------------------------------------------------------------------------- /data_proc/artif_drainage/old/make_forestry_shp.r: -------------------------------------------------------------------------------- 1 | # Description: 2 | 3 | 4 | # create record IDs 5 | drained_forestry <- drained %>% dplyr::filter(type == "forestry") 6 | 7 | 8 | #==============================================================================# 9 | ### Make shapefile of nat drainage stats --------------------------------------- 10 | #==============================================================================# 11 | 12 | # extract cropland area for year and country from HYDE to calculate % drained 13 | 14 | # get function that gets polygons for each row 15 | source("./scripts/r/data_proc/fcn/fcn_get_polygons_for_drainage.r") 16 | 17 | # create a shapefile with a polygon for each record row 18 | # (some repeat because data from multiple years) 19 | artdrain_forestry_natpoly <- sel_countries_in_shp(drained_forestry, countries, "iso_a3", "adm0_a3", "rec_id") 20 | 21 | 22 | # join the data table to shapefile, using rec_id as key 23 | artdrain_forestry_natpoly@data <- merge(artdrain_forestry_natpoly@data, as.data.frame(drained), 24 | by="rec_id", all.x=T, all.y=F) 25 | 26 | 27 | #==============================================================================# 28 | ### SAVE OUTPUT POLYGONS -------------------------------------------------- 29 | #==============================================================================# 30 | 31 | # save the filtered table... is this necessary? 32 | #saveRDS(drained, "./output/results/artif_drainage/drained_ag_stats.rds") 33 | 34 | # save the selected shapefile as rds 35 | saveRDS(artdrain_forestry_natpoly, "./output/results/artif_drainage/artdrain_forestry_natpoly.rds") 36 | 37 | 38 | # delete objects -------------------------------------------- 39 | rm(histcases, histcases_nat, histcases_subnat, countries_shp, 40 | subnat_shp, h_c_shp, h_s_shp, histcases_shp) 41 | 42 | -------------------------------------------------------------------------------- /data_proc/artif_drainage/old/make_peatland_shp.r: -------------------------------------------------------------------------------- 1 | # Description: 2 | 3 | 4 | # create record IDs 5 | drained_peatland <- drained %>% dplyr::filter(type == "peatland") 6 | 7 | 8 | #==============================================================================# 9 | ### Make shapefile of nat drainage stats --------------------------------------- 10 | #==============================================================================# 11 | 12 | # extract cropland area for year and country from HYDE to calculate % drained 13 | 14 | # get function that gets polygons for each row 15 | source("./scripts/r/data_proc/fcn/fcn_get_polygons_for_drainage.r") 16 | 17 | # create a shapefile with a polygon for each record row 18 | # (some repeat because data from multiple years) 19 | artdrain_peatland_natpoly <- sel_countries_in_shp(drained_peatland, countries, "iso_a3", "adm0_a3", "rec_id") 20 | 21 | 22 | # join the data table to shapefile, using rec_id as key 23 | artdrain_peatland_natpoly@data <- merge(artdrain_peatland_natpoly@data, as.data.frame(drained), 24 | by="rec_id", all.x=T, all.y=F) 25 | 26 | 27 | #==============================================================================# 28 | ### SAVE OUTPUT POLYGONS -------------------------------------------------- 29 | #==============================================================================# 30 | 31 | # save the filtered table... is this necessary? 32 | #saveRDS(drained, "./output/results/artif_drainage/drained_ag_stats.rds") 33 | 34 | # save the selected shapefile as rds 35 | saveRDS(artdrain_peatland_natpoly, "./output/results/artif_drainage/artdrain_peatland_natpoly.rds") 36 | 37 | 38 | # delete objects -------------------------------------------- 39 | rm(histcases, histcases_nat, histcases_subnat, countries_shp, 40 | subnat_shp, h_c_shp, h_s_shp, histcases_shp) 41 | 42 | -------------------------------------------------------------------------------- /plots/map/old/map_period_max_wetloss_rate.r: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | hyde_yrs<- readRDS('./output/results/hyde_yrs_all.rds') 5 | 6 | 7 | wetloss_Mk2_stack 8 | 9 | 10 | 11 | names(wetloss_Mk2_stack) 12 | 13 | 14 | 15 | 16 | # get the raster number of max wetloss 17 | which.max.na <- function(x, ...) ifelse(length(x) == sum(is.na(x)), 0, which.max(x)) 18 | 19 | max_wetloss_r <- calc(wetloss_Mk2_stack, which.max.na) 20 | values(max_wetloss_r)[values(max_wetloss_r)== 0] = NA 21 | 22 | 23 | # 24 | for (i in seq(1, nlayers(wetloss_Mk2_stack), 1)){ 25 | 26 | yr <- hyde_yrs[i] 27 | 28 | values(max_wetloss_r)[values(max_wetloss_r)== i] = yr 29 | 30 | } 31 | plot(max_wetloss_r) 32 | 33 | 34 | # PLOT the map ================================================================= 35 | 36 | # set mapping theme 37 | mapTheme <- rasterTheme(region = rev(brewer.pal(5, "RdYlGn")), 38 | axis.line = list(col = "transparent"), 39 | scales = list(x = list(draw = FALSE))) 40 | 41 | 42 | cutpts <- c(-10000, -4000, -2000, 0, 1700, 1850, 2000) 43 | 44 | 45 | 46 | png("../../output/figures/map_period_max_wetloss.png", width=1800, height=1000, res=300) 47 | 48 | # plot glacier/submerged land 49 | plt<- levelplot(max_wetloss_r, 50 | margin = F, 51 | #col.regions='grey90', 52 | pretty=TRUE, 53 | at=cutpts, 54 | par.settings = mapTheme, 55 | #main=paste0("Inundated percentage \n ", month.abb[m], " ", yr_label), 56 | par.strip.text=list(cex=0.5, lines=10, fontface='bold'), 57 | axes=FALSE, box=FALSE, 58 | scales=list(draw=FALSE), 59 | xlab=NULL, ylab=NULL) #list(space="bottom", draw=FALSE)) 60 | 61 | print(plt) 62 | dev.off() 63 | -------------------------------------------------------------------------------- /data_proc/fit/compile_mcmc_pars.r: -------------------------------------------------------------------------------- 1 | 2 | # Set dir where modFit object are located 3 | p <- '../output/results/fit/mcmc/mcmc_obj/i3000' 4 | 5 | # List of modFit configs 6 | fls <- list.files(path=p, full.names = F) 7 | 8 | # Create empty df 9 | par_df <- data.frame() 10 | 11 | # /----------------------------------------------------------------------------# 12 | #/ Loop through files 13 | for (f in fls) { 14 | 15 | print(f) 16 | 17 | # Open modFit object 18 | MCMCout <- readRDS(paste0(p, '/', f)) 19 | 20 | # Extract individual parameters 21 | # row <- data.frame(f, t$bestpar[1], t$bestpar[2], t$bestpar[3]) #, t$SS) 22 | 23 | pars <- as.data.frame(MCMCout$pars) %>% 24 | mutate(SS = MCMCout$SS) %>% 25 | mutate(sig = MCMCout$sig[,1]) %>% 26 | distinct() %>% 27 | arrange(SS) %>% 28 | mutate(run_id = f) %>% 29 | mutate(s = as.numeric(substr(run_id, 10, 10)), 30 | p = as.numeric(substr(run_id, 13, 13))) 31 | 32 | # Get the best parameters based on SS 33 | pars_row <- pars[1, ] # pars[1:10, ] 34 | 35 | # append row to df 36 | par_df <- bind_rows(par_df, pars_row) 37 | 38 | } 39 | 40 | 41 | # Rename columns 42 | names(par_df) <- c('run_id','theta_rice','theta_pasture','theta_urban','ssr','run_id','s_i','p_i') 43 | 44 | 45 | glimpse(par_df) 46 | 47 | 48 | # /----------------------------------------------------------------------------# 49 | #/ Write to csv 50 | write.csv(par_df, '../output/results/fit/mcmc/parameters/pars_modMCMC_2021.csv') 51 | 52 | 53 | 54 | 55 | # f= fls[12] 56 | # t <- readRDS(paste0(p, '/', f)) 57 | # summary(t, cov=TRUE) 58 | # print(t) 59 | # FME::print.summary(t) 60 | # 61 | # plot(t$rsstrace, type='line') 62 | # 63 | # plot(t, full=T) 64 | 65 | # Largest residuals: 66 | # Yangtze 14 has lasrgest resids 67 | # Montana: n53 has reds\\sid 40 68 | # Wyoming: n77 has resid of 22 -------------------------------------------------------------------------------- /plots/artif_drainage/barplot_totaldrainage.r: -------------------------------------------------------------------------------- 1 | 2 | ### Barplot of value types in the time-series ------------------------------- 3 | 4 | # Read in data 5 | die <- read.csv("./output/results/artif_drainage/drained_wetcult_ha_sigmoidpred.csv", 6 | stringsAsFactors = T) 7 | 8 | # prep for plot 9 | die_forplot <- die %>% 10 | group_by(type, year, continent) %>% 11 | dplyr::summarize(pred_drained = sum(pred_drained)) %>% 12 | ungroup() %>% 13 | mutate(type= stri_trans_totitle(type)) 14 | 15 | 16 | # /----------------------------------------------------------------------------- 17 | #/ Make the plot 18 | barplot_baltype <- 19 | 20 | ggplot(die_forplot) + 21 | 22 | geom_bar(aes(x=year, y=pred_drained/1000, fill=continent), 23 | color='white', size=0.1, 24 | position = "stack", stat="identity") + 25 | 26 | scale_y_continuous(expand=c(0,0))+ 27 | scale_x_continuous(expand=c(0,0), labels = seq(1700,2000,50), breaks= seq(1700,2000,50)) + 28 | 29 | 30 | ylab(expression(paste("Drained area (10"^{3},' km'^{2}," )" ))) + 31 | xlab("") + 32 | 33 | facet_wrap(~type, scales="free_y") + 34 | line_plot_theme + 35 | 36 | theme(legend.position = c(0.02, 0.8)) 37 | 38 | barplot_baltype 39 | 40 | 41 | 42 | # /----------------------------------------------------------------------------- 43 | #/ Save plot 44 | ggsave(plot=barplot_baltype, 45 | "./output/figures/artif_drainage/barplot_draintype.png", 46 | dpi=300, width=180, height=100, units='mm' , type = "cairo-png") 47 | 48 | dev.off() 49 | 50 | 51 | 52 | 53 | 54 | 55 | # value types: data, interpolated, extrapolated 56 | 57 | # convert to factor 58 | #die$valtype <- factor(die$valtype, levels = c("extrapol","interp","data")) 59 | -------------------------------------------------------------------------------- /data_proc/distrib_drainage/bayesian_param_fit_with_df_v2.r: -------------------------------------------------------------------------------- 1 | # Metropolis-Hastings (DRAM) 2 | # Likelihood function of the model that we want to fit is the probability (density) 3 | # expected the observed data to occur conditional on the parameters of the model 4 | #------------------------------------------------------------------------------# 5 | 6 | 7 | # /----------------------------------------------------------------------------# 8 | #/ Initialize MCMC run (only once) 9 | source('./data_proc/overlay/initial_mcmc_fitting_df_v2.r', local=T) 10 | 11 | # /----------------------------------------------------------------------------# 12 | #/ Make function that takes in theta parameters, does the overlapping, compares to Davidson's sites 13 | source('./data_proc/mcmc_fit/fcn_make_wetloss_df.r', local=T) 14 | 15 | 16 | # /----------------------------------------------------------------------------# 17 | #/ Wrapper function that sets MCMC parameters --------- 18 | source('./data_proc/mcmc_fit/fcn_run_mcmc.r', local=T) 19 | 20 | 21 | # /----------------------------------------------------------------------------# 22 | #/ Function that gets 0.025, 0.50, 0.974 percentile of theta parameters ------ 23 | source('./data_proc/mcmc_fit/fcn_get_pars_range.r', local=T) 24 | 25 | 26 | 27 | 28 | 29 | # Save for each run: 30 | # - figure of parameter convergence across runs 31 | # - figure of posterior parameter value 32 | # - best params 33 | 34 | # library(ggmcmc) 35 | # 36 | # parDRAM <- ggmcmc::ggs(MCMC_1_1) #multDRAM) ## to convert objet for using by all ggs_* graphical functions 37 | # ggmcmc::ggs_traceplot(parDRAM) 38 | 39 | # /------------------------------------------ 40 | #/ COMBINE - dec2020 move to later 41 | # pars_all <- bind_rows(pars_giems2, pars_wad2m, pars_glwd) 42 | # write.csv(pars_all, '../output/results/mcmc_pars/mcmc_pars_all_dec2020.csv') 43 | -------------------------------------------------------------------------------- /plots/fig2abcd/fig1c_wetland1700.R: -------------------------------------------------------------------------------- 1 | 2 | # /----------------------------------------------------------------------------# 3 | #/ FIG 1-A: BUT ONLY 1700 WETLAND AREA 4 | 5 | 6 | # Filter wetloss grid to 7 | grid_remwet_perc_robin_df <- WGSraster2dfROBIN(Fwet1700_r) %>% 8 | # Percentage loss above a certain % 9 | # filter(cumloss_perc > 1) %>% # map_cumullossperc_floor) %>% 10 | # Where pixels had originally >5% wetland 11 | filter(Fwet1700 * 100 > 5) # map_Fwet1700_floor) 12 | 13 | 14 | 15 | fig2b_1700wet <- 16 | 17 | ggplot()+ 18 | # countries background & outline 19 | geom_polygon(data=countries_robin_df, aes(long, lat, group=group), fill='grey90', color=NA, size=0.08) + 20 | 21 | # Coastline 22 | geom_path(data=coastsCoarse_robin_df, aes(long, lat, group=group), color='grey70', size=0.1) + 23 | 24 | # Add wetloss raster 25 | geom_raster(data=grid_remwet_perc_robin_df, aes(x=x, y=y, fill=Fwet1700*100)) + 26 | 27 | # Add outline bounding box 28 | geom_path(data=bbox_robin_df, aes(long, lat, group=group), color='black', size=0.08) + 29 | 30 | coord_equal() + theme_raster_map() + 31 | 32 | # scale_y_continuous(limits=c(-6600000, 8953595)) + 33 | # '#fff385' 34 | scale_fill_gradient(low='#97cf99', high='#183b19', #'#1e4a20', 35 | breaks=c(5, 25, 50, 75, 100), 36 | limits=c(5, 100)) + 37 | # 38 | guides(fill = guide_colorbar(nbin=10, raster=F, 39 | barheight = 0.4, barwidth=7, 40 | frame.colour=c('black'), frame.linewidth=0.7, 41 | ticks.colour='black', direction='horizontal', 42 | title = expression(paste('Wetland extent in 1700 \n(% of cell)')))) + 43 | 44 | theme(legend.position = 'bottom', 45 | legend.direction = 'horizontal') 46 | 47 | fig2b_1700wet 48 | 49 | 50 | -------------------------------------------------------------------------------- /plots/hist_cases/fig4ab_histcases.r: -------------------------------------------------------------------------------- 1 | # FIG 4 A & B PANELS 2 | # arrange in grid -------------------------------------------------------------- 3 | # set tight margins so plots are close side-by-side 4 | 5 | 6 | # Combine consump map & inset 7 | histcase_map_grob = ggplotGrob(histcase_map) 8 | wetloss_cumulplot_w_inset = wetloss_cumulplot + annotation_custom(grob = histcase_map_grob, 9 | xmin= 1, 10 | xmax= 99, 11 | ymin= 1.05, 12 | ymax= 1.5) 13 | 14 | 15 | # Dimensions of each margin: t, r, b, l (To remember order, think trouble). 16 | wetloss_scatterplot_m <- wetloss_scatterplot + theme(plot.margin=unit(c(40, 2, 2, 1), 'mm')) 17 | wetloss_cumulplot_w_inset_m <- wetloss_cumulplot_w_inset + theme(plot.margin=unit(c(40, 1, 2, 2), 'mm')) 18 | 19 | 20 | 21 | 22 | # arrange plots grob into layout 23 | library(ggpubr) #ggarrange 24 | p <- ggarrange(wetloss_scatterplot_m, wetloss_cumulplot_w_inset_m, 25 | 26 | ncol=2, nrow=1, 27 | # rel_heights = c(2, 0.1), 28 | # rel_widths = c(1, 1), 29 | 30 | labels = c('A', 'B'), 31 | align='h') 32 | 33 | # p 34 | 35 | 36 | # /----------------------------------------------------------------------------# 37 | #/ Save figure to file -------- 38 | 39 | ggsave('../output/figures/fig4ab_wetloss_histcases_v4.png', p, 40 | width=180, height=130, dpi=300, units='mm') #type = 'cairo-png') 41 | 42 | ggsave('../output/figures/fig4ab_wetloss_histcases_v4.pdf', p, 43 | width=180, height=130, dpi=300, units='mm') #type = 'cairo-png') 44 | 45 | dev.off() 46 | 47 | -------------------------------------------------------------------------------- /data_proc/hist_cases/format_historical_cases.r: -------------------------------------------------------------------------------- 1 | library(countrycode) # package for country iso code 2 | library(measurements) # package for lat/long conversion 3 | 4 | 5 | # read hitorical cases data 6 | # f <- './data/hist_records/wetland_loss_cases_combined_v2.csv' 7 | f <- './data/hist_records/wetland_loss_cases_combined_v2_manmod.csv' 8 | 9 | histcases <- 10 | read.csv(f, stringsAsFactors = F, na.strings=c("", " ","NA")) %>% 11 | mutate(nb_yrs = as.numeric(nb_yrs), 12 | perc_change_numeric = as.numeric(perc_change_numeric)) 13 | 14 | # convert from decimal minutes to decimal degrees 15 | histcases$lat_pt2 = measurements::conv_unit(histcases$lat_pt, from = 'deg_dec_min', to = 'dec_deg') 16 | histcases$long_pt2 = measurements::conv_unit(histcases$long_pt, from = 'deg_dec_min', to = 'dec_deg') 17 | 18 | 19 | 20 | histcases <- histcases %>% 21 | # make country code column for joining with polygon 22 | mutate(country_code = countrycode(histcases$country, 'country.name','iso3c',warn=T)) %>% 23 | dplyr::select(-one_of("long_pt","lat_pt", "X", "X.1")) %>% 24 | 25 | filter(yr_start>1500) %>% 26 | mutate(yr_start = ifelse(yr_start<1700, 1700, yr_start)) %>% 27 | 28 | filter(nb_yrs > 10) %>% 29 | filter(perc_change_numeric < 100) %>% 30 | filter(!is.na(yr_start), !is.na(yr_end)) 31 | 32 | 33 | # write formatted histcase output 34 | write.csv(histcases, './output/results/histcases_loss_v2_manmod_p.csv') 35 | 36 | 37 | # delete objects 38 | rm(histcases, f) 39 | 40 | 41 | 42 | 43 | 44 | 45 | # convert columns to numeric 46 | # histcases$nb_yrs <- as.numeric(histcases$nb_yrs) 47 | # histcases$perc_change_numeric <- as.numeric(histcases$perc_change_numeric) 48 | 49 | 50 | # filter to remove outlier records 51 | # i.e. with large increase (for plotting purpose; but also could be faulty record) 52 | # PROBLEM: REMOVES VAN ASSELEN DATA DURING FILE 53 | #histcases <- histcases[histcases$perc_change_numeric < 200,] 54 | 55 | -------------------------------------------------------------------------------- /plots/artif_drainage/lineplot_drainage_inter_n_extrapol_1000ha.r: -------------------------------------------------------------------------------- 1 | 2 | die_subset <- die[1:7440,] 3 | 4 | 5 | ## plot for in between years --------------------------------------------------- 6 | drained_area_inter_n_extrapol_plot <- ggplot() + 7 | 8 | 9 | ## Cropland 10 | geom_point(data=subset(die, type=="cropland" & valtype == "data"), aes(x=year, y=ts_drained_area_tot, shape=valtype), color='blue', size=1.8) + 11 | #geom_line(data=subset(die_subset, type=="cropland"), aes(x=year, y=ts_drained_area_tot), color='blue',size=0.8, alpha=0.3, line="dash") + 12 | geom_line(data=subset(die, type=="cropland"), aes(x=year, y= ts_drained_area_tot_templateapplied), color='blue', size=0.8, alpha=0.5) + 13 | 14 | 15 | ## 16 | geom_point(data=subset(die, type=="forestry"), aes(x=year, y=ts_drained_area_tot), color='green', size=0.4) + 17 | geom_line(data=subset(die, type=="forestry"), aes(x=year, y=ts_drained_area_tot_templateapplied), color='green',size=0.4, alpha=0.3) + 18 | 19 | geom_point(data=subset(die, type=="peatland"), aes(x=year, y=ts_drained_area_tot), color='brown', size=0.4) + 20 | geom_line(data=subset(die, type=="peatland"), aes(x=year, y=ts_drained_area_tot_templateapplied), color='brown',size=0.4, alpha=0.3) + 21 | 22 | #geom_bar(data=a, (aes=)) 23 | scale_x_continuous(limits=c(1700, 2020)) + 24 | scale_shape(solid = FALSE) + 25 | 26 | expand_limits(y=0) + 27 | facet_wrap(~country_name, scales="free") + 28 | #facet_grid(type~continent, scales="free") + 29 | line_plot_theme + 30 | theme(legend.position = c(0.8, 0.1)) + 31 | ylab("Area drained (1000 ha)") + xlab("") 32 | 33 | drained_area_inter_n_extrapol_plot 34 | 35 | 36 | ### save plot 37 | ggsave(plot=drained_area_inter_n_extrapol_plot, 38 | "./output/figures/artif_drainage/artif_drainage_nat_interp_n_extra_area_v2.png", 39 | dpi=300, width=550, height=300, units='mm' , type = "cairo-png") 40 | 41 | dev.off() 42 | -------------------------------------------------------------------------------- /plots/map/map_historical_cases_poly_v2.r: -------------------------------------------------------------------------------- 1 | # Get Davidson data 2 | source('./plots/map/get_davidson_histcase_polygons.r') 3 | # Get WET index sites 4 | source('./plots/map/get_wetindex_points.r') 5 | 6 | 7 | # /----------------------------------------------------------------------------# 8 | #/ MAP HISTORICAL CASES COUNTRIES --------- 9 | 10 | histcase_map <- 11 | ggplot() + 12 | 13 | # add background country polygons 14 | geom_polygon(data=countries_robin_df, aes(long, lat, group=group), fill='grey85') + 15 | 16 | # add outline of background countries 17 | #geom_path(data=countries_robin_df, aes(long, lat, group=group), color='white', size=0.1) + 18 | 19 | # add countries with wetloss data; colored by value 20 | geom_polygon(data=histcases_poly_df, aes(long, lat, group=group), alpha=1, fill="blue") + 21 | 22 | # add outline of country with data 23 | geom_path(data=histcases_poly_df, aes(long, lat, group=group), color='white', size=0.1) + 24 | 25 | # Wet Index points 26 | geom_point(data=wetindex_pts_robin_df, aes(Longitude.1, Latitude.1), color='red', size=0.02) + 27 | 28 | # Add outline bounding box 29 | geom_path(data=bbox_robin_df, aes(long, lat, group=group), color="black", size=0.25) + 30 | 31 | scale_y_continuous(limits=c(-6600000, 8953595)) + 32 | 33 | coord_equal() + theme_fig() + 34 | scale_fill_distiller(palette = 3) + 35 | theme(legend.position="top") + 36 | theme(plot.margin = unit(c(-2,-1,-2,-1), "mm")) 37 | 38 | histcase_map 39 | 40 | 41 | # # /---------------------------------------------------------------- 42 | # #/ Save figure to file ----- 43 | # ggsave('./output/figures/hist_cases/map_histcase_davidson_wetindex.png', 44 | # width=87, height=60, dpi=800, units="mm", type = "cairo-png") 45 | # dev.off() 46 | 47 | 48 | 49 | 50 | # delete objects 51 | rm(histcases_poly, histcases_poly_df, histcases_poly_robin, 52 | countries_robin_df, bbox_robin_df, map) 53 | -------------------------------------------------------------------------------- /data_proc/fit/mcmc_init/init_davidson_histcases.r: -------------------------------------------------------------------------------- 1 | # library(geosphere) 2 | # library(fasterize) 3 | # 4 | 5 | # 6 | # # /----------------------------------------------------------------------------# 7 | # #/ Get histcases polygon 8 | # 9 | # # histcases <- readRDS("../data/hist_records/davidson_sites_gis/davidson_sites_wdata_manmod.rds") # Manually produced on 9 Sept 2019 10 | # histcases <- readRDS("../data/hist_records/davidson_sites_gis/histcases_wdata_2021.rds") # Updated April 2021 11 | # 12 | # # exclude polygons without a start date 13 | # histcases <- histcases[!is.na(histcases$yr_start),] 14 | # 15 | # histcases <- histcases[histcases$src_id %in% c(31, 92, 129, 136, 144),] 16 | # 17 | # # Calculate area of polygons from m^2 to million km2 18 | # histcases$areapoly_mkm2 <- areaPolygon(histcases) /10^5 /10^6 19 | # 20 | # 21 | # # /------------------------------------------------------------- 22 | # #/ Convert histcases to raster_df 23 | # histcases_recid = fasterize(st_as_sf(histcases), template, field='src_id') 24 | # histcases_df <- raster2df(histcases_recid) 25 | # names(histcases_df) <- c('src_id','x','y') 26 | # histcases_df <- left_join(maxlncr_df_xy, histcases_df, by=c('x','y')) 27 | # 28 | # 29 | # # /----------------------------------------------------------------------------# 30 | # #/ fix to correct continent column for African cases 31 | # histcases_df <- 32 | # left_join(histcases_df, histcases@data, by='rec_id') %>% 33 | # mutate(country = ifelse(country=='Niger/Mali', 'Niger', country)) %>% 34 | # mutate(country_code = countrycode(country, 'country.name', 'iso3c')) %>% 35 | # mutate(continent = countrycode(country, 'country.name', 'continent')) %>% 36 | # # Round years to decade 37 | # mutate(yr_start_rnd = round(yr_start, -1), yr_end_rnd = round(yr_end, -1)) %>% 38 | # mutate(yr_end_rnd = ifelse(yr_end_rnd==2010, 2000, yr_end_rnd)) 39 | # 40 | 41 | 42 | histcases_df <- read.csv("../output/results/histcases/histcases_wdata_2021_rasterdf.csv") 43 | -------------------------------------------------------------------------------- /plots/artif_drainage/old/map_forestry_drainage_stats.R: -------------------------------------------------------------------------------- 1 | # description: map drainage as percentage of country -------------------------- 2 | #==============================================================================# 3 | 4 | # read drainage shp 5 | artdrain_forest_natpoly <- readRDS("./output/results/artif_drainage/artdrain_nat_poly_forestry.rds") 6 | 7 | # Fortify & reproject polygons to ggplot-mappable df 8 | artdrain_forest_natpoly_df <- prep_poly_into_robin_map_wdata(artdrain_forest_natpoly) 9 | 10 | 11 | #==============================================================================# 12 | # make ggplot map -------------------------------------------- 13 | #==============================================================================# 14 | 15 | map <- 16 | 17 | ggplot(bbox_robin_df, aes(long, lat)) + 18 | 19 | # add background country polygons 20 | geom_polygon(data=countries_robin_df, 21 | aes(long, lat, group=group), fill='grey85') + 22 | 23 | # add data countries 24 | geom_polygon(data=artdrain_forest_natpoly_df, 25 | aes(long, lat, group=group, fill= fraction_drained*100), alpha=1) + 26 | 27 | 28 | # add country outline 29 | geom_path(data=countries_robin_df, aes(long, lat, group=group), color='white', size=0.1) + 30 | 31 | # Add outline bounding box 32 | geom_path(data=bbox_robin_df, aes(long, lat, group=group), color="black", size=0.2) + 33 | 34 | 35 | coord_equal() + theme_fig() + 36 | scale_fill_distiller(type="seq", direction=1, palette = 2) + 37 | theme(legend.position="top") + 38 | theme(plot.margin = unit(c(-2,-3,-2,-10), "mm")) + 39 | guides(fill = guide_colorbar(barwidth = 14, barheight = 0.5)) + 40 | 41 | labs(fill = "Secondary forest % drained") 42 | 43 | 44 | map 45 | 46 | 47 | 48 | ### save figure to file ================================================== 49 | 50 | ggsave('./output/figures/artif_drainage/map/perc_drained_forestry.png', 51 | width=178, height=90, dpi=600, units="mm")#, type = "cairo-png") 52 | dev.off() 53 | 54 | -------------------------------------------------------------------------------- /data_proc/artif_drainage/apply_sigmoid_drained_nat.r: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------# 2 | #/ Apply the fit to countries with 3 or fewer pts ---------- 3 | 4 | # Get function that applies sigmoid 5 | source('./data_proc/artif_drainage/fcn/fcn_apply_sigmoid_drainage.r') 6 | 7 | # make list of years 8 | y = seq(1700, 2020, 10) 9 | 10 | ifrm(predall) 11 | 12 | # get NATIONAL unique cases, with at least 1 data points, to which the sigmoid can be applied 13 | # to then loop through these unique cases 14 | d_nat <- d %>% filter(region == '' & !is.na(year) & !is.na(country_name)) 15 | ucases <- unique(d_nat[,c('country_name','continent', 'type')]) 16 | 17 | 18 | # /----------------------------------------------------------------------------# 19 | #/ loop unique cases (country x type combinations) to apply sigmoid 20 | for (i in 1:nrow(ucases)){ 21 | 22 | c = as.character(ucases[i,'country_name']) 23 | t = as.character(ucases[i,'type']) 24 | o = as.character(ucases[i,'continent']) 25 | 26 | # If NA country 27 | # if(is.na(c)){ next } 28 | 29 | # subset data to unique case 30 | di = d_nat %>% filter(country_name == c & type == t) 31 | 32 | # Apply sigmoid function fitting 33 | pred <- applysigmoid(di, fitall) 34 | 35 | # Cap the drained area to the maximum data point; i.e. apply a ceiling value 36 | pred[pred$pred_drained > max(di$drained_area_tot),'pred_drained'] <- max(di$drained_area_tot) 37 | 38 | # Append to output 39 | if (!exist(predall)){predall <- pred} else{ predall <- bind_rows(predall, pred)} 40 | } 41 | 42 | 43 | 44 | # /----------------------------------------------------------------------------# 45 | #/ Save predicted drained area 46 | write.csv(predall, "../output/results/artif_drainage/drained_wetcult_km2_sigmoidpred_march2021.csv", row.names=F) 47 | 48 | 49 | 50 | # /----------------------------------------------------------------------------# 51 | #/ Facet plot 52 | source('./plots/artif_drainage/lineplot/facet_sigmoid_all_national.r') 53 | -------------------------------------------------------------------------------- /plots/nat_wet/barplot_wetchimp_area.r: -------------------------------------------------------------------------------- 1 | 2 | 3 | # /----------------------------------------------------------------------------# 4 | #/ Get file ------------ 5 | 6 | wetchimp_area_sum <- read.csv("./output/results/natwet/sum_wetchimp_grids.csv") 7 | 8 | 9 | wetchimp_area_sum$experiment <- factor(wetchimp_area_sum$experiment, levels = c(1, 2, 3)) 10 | 11 | 12 | # ADD EMPTY COLUMN 13 | # o <- as.data.frame(table(wetchimp_area_sum$experiment, 14 | # wetchimp_area_sum$model, 15 | # wetchimp_area_sum$extension)) 16 | # o$Freq <- NULL 17 | # names(o) <- c("experiment", "model", "extension") 18 | # wetchimp_area_sum <- bind_rows(wetchimp_area_sum, o) 19 | 20 | 21 | # /----------------------------------------------------------------------------# 22 | #/ Make figure of Wetchimp SUMs ------------ 23 | 24 | #wetchimplot <- 25 | ggplot(wetchimp_area_sum) + 26 | geom_bar(aes(x=extension, y= wet_Mkm2, fill= experiment), 27 | color='black', size=0.2, width= 0.8, position="dodge", stat="identity") + 28 | 29 | facet_wrap(~ model, scales="free") + 30 | scale_y_continuous(expand=c(0,0)) + 31 | scale_fill_discrete(labels = c(" Exp.1-Equilibrium (1901-1931)", 32 | " Exp.2-Transient (1993-2004)", 33 | " Exp.3-Optimal (1993-2004)")) + 34 | coord_flip() + 35 | 36 | xlab("") + 37 | ylab(expression(paste("Global wetland area (10"^{6},' km'^{2},")"))) + 38 | line_plot_theme + 39 | theme(panel.grid.major.x = element_line(color="grey80", size=0.2), 40 | legend.position = c(0.6, 0.2)) 41 | 42 | 43 | #wetchimplot 44 | 45 | # /----------------------------------------------------------------------------- 46 | #/ Save plot 47 | ggsave(#plot=wetchimplot, 48 | "./output/figures/barplot_wetchimplot_wetarea_modelfacet.png", 49 | dpi=300, width=180, height=100, units='mm' , type = "cairo-png") 50 | 51 | dev.off() 52 | -------------------------------------------------------------------------------- /plots/lineplot/old/line_plot_remwet_perc_since1700.R: -------------------------------------------------------------------------------- 1 | 2 | wetloss_all <- read.csv("./output/results/wetloss/sum/wetloss_all_area.csv") %>% 3 | filter(year >= 1700) 4 | 5 | wetloss_all_mean <- wetloss_all %>% 6 | group_by(year) %>% 7 | summarize(mean_tot_remwet_Mkm2 = mean(tot_remwet_Mkm2), 8 | mean_remwet_prc_since1700 = mean(remwet_prc_since1700)) 9 | 10 | # get max area lost??? 11 | max(wetloss_all_mean$mean_tot_remwet_Mkm2) - min(wetloss_all_mean$mean_tot_remwet_Mkm2) 12 | 13 | 14 | 15 | # REMWET PERCENTAGE PLOT ====================================================== 16 | 17 | # read davison data 18 | f<-"./data/hist_records/source_specific/davidson_2014/davidson2014_global_percent_wetloss.csv" 19 | davidson2014 <- read.csv(f, stringsAsFactors = F) %>% filter(!is.na(percentage_fromtext_nfig4)) 20 | 21 | 22 | 23 | ggplot(wetloss_all) + 24 | 25 | # add lines 26 | geom_line(aes(x=year, y=remwet_prc_since1700, color=name, group=paste0(name, overlap))) + 27 | 28 | # add points for each scenario 29 | geom_point(aes(x=year, y=remwet_prc_since1700, color=name, shape=overlap), fill='white') + 30 | 31 | # add ensemble mean line 32 | geom_line(data=wetloss_all_mean, aes(x=year, y=mean_remwet_prc_since1700), color='darkblue') + 33 | 34 | # Add nick davidson's estimates 35 | geom_line(data=davidson2014, aes(x=ï..year_start, y= percentage_fromtext_nfig4), 36 | color='black', size=0.3) + 37 | 38 | geom_point(data=davidson2014, aes(x=ï..year_start, y= percentage_fromtext_nfig4), 39 | color='black', size=0.6) + 40 | 41 | # select shapes- empty point shape 42 | scale_shape_manual(values=c(21, 22, 24)) + 43 | line_plot_theme 44 | 45 | 46 | 47 | # save figure to file 48 | ggsave('./output/figures/lineplot_remwet_global_perc_allcomb_since1700.png', 49 | width=178, height=90, dpi=600, units="mm", type = "cairo-png") 50 | dev.off() 51 | 52 | 53 | # delete objects 54 | rm(f, davidson2014, wetloss_all) 55 | -------------------------------------------------------------------------------- /data_proc/fit/calc_sum_remwet_ci_range.r: -------------------------------------------------------------------------------- 1 | 2 | # Get range of estimates from 3 | runs <- c('s1_p1', 's1_p2', 's1_p3', 's2_p1', 's2_p2', 's2_p3', 4 | 's3_p1', 's3_p2', 's3_p3', 's4_p1', 's4_p2', 's4_p3') 5 | 6 | # /----------------------------------------------------------------------------# 7 | #/ GET RANGE OF MEAN PARS --------- 8 | 9 | remwet_sum_mean_range <- data.frame() 10 | pars = 'avg' 11 | 12 | # Loop to append all mean par runs in a single df 13 | for(r in runs){ 14 | 15 | f <- paste0('../output/results/wetloss/sum/sum_remwet_', r,'_t', test_theta, '_', pars, '_v1.csv') 16 | remwet_sum <- read.csv(f) %>% mutate(run = r)# read file 17 | remwet_sum_mean_range <- bind_rows(remwet_sum_mean_range, remwet_sum) 18 | } 19 | 20 | # Get min & max of mean par runs 21 | remwet_sum_mean_range <- 22 | remwet_sum_mean_range %>% 23 | dplyr::select(-X) %>% 24 | group_by(year) %>% 25 | summarise_all(list(min=min, max=max, median=median)) #.funs=c(min,max)) 26 | 27 | 28 | # /----------------------------------------------------------------------------# 29 | #/ GET RANGE OF MIN/MAX PARS --------- 30 | 31 | remwet_sum_minmax_range <- data.frame() 32 | 33 | # Loop through min and max runs 34 | for(r in runs){ 35 | 36 | # print(r) 37 | # Read in files 38 | pars='min' 39 | f_min <- paste0('../output/results/wetloss/sum/sum_remwet_', r,'_t', test_theta,'_', pars, '_v1.csv') 40 | pars='max' 41 | f_max <- paste0('../output/results/wetloss/sum/sum_remwet_', r,'_t', test_theta,'_', pars, '_v1.csv') 42 | 43 | remwet_sum_min <- read.csv(f_min) 44 | remwet_sum_max <- read.csv(f_max) 45 | 46 | remwet_sum_minmax_range <- bind_rows(remwet_sum_minmax_range, remwet_sum_min, remwet_sum_max) 47 | } 48 | 49 | # Calculate range 50 | remwet_sum_minmax_range <- 51 | remwet_sum_minmax_range %>% 52 | dplyr::select(-X) %>% 53 | group_by(year) %>% 54 | summarise_all(list(min = min, max=max)) 55 | 56 | 57 | # reset the pars variable 58 | pars <- 'avg' 59 | 60 | -------------------------------------------------------------------------------- /data_proc/natwet/potwet/prep_potwet.r: -------------------------------------------------------------------------------- 1 | 2 | # SIMWET: 3 | # - ORCHIDEE EXP#2 4 | # - SDGVM (35-45Mkm2) 5 | # - DLEM (wet) 6 | # - Zhen wPot 7 | 8 | # PRESWET 9 | # - WAD2M 10 | # - GLWD 11 | # - GIEMSv2 12 | 13 | # POTWET = SIMWET - PRESWET 14 | 15 | 16 | # Get simwet stack 17 | simwet_stack <- stack('../output/results/natwet/simwet/simwet_stack.tif') 18 | names(simwet_stack) <- c('orchidee2_km2', 'SDGVM2_km2', 'dlem2_km2', 'zhang_wpot') 19 | simwet_stack <- aggregate(simwet_stack, factor=2, fun=sum) 20 | simwet_stack 21 | 22 | # Get preswet stack 23 | preswet_stack <- stack('../output/results/natwet/preswet/preswet_stack.tif') 24 | names(preswet_stack) <- c('wad2m_Aw_mamax', 'glwd3_akmw', 'giems2_mamax_corr') 25 | preswet_stack <- aggregate(preswet_stack, factor=2, fun=sum) 26 | preswet_stack 27 | 28 | 29 | # /----------------------------------------------------------------------------# 30 | #/ CALC DIFF ---------------------- 31 | 32 | # Initialize output 33 | potwet_stack <- stack() 34 | 35 | # Loop through rasters, calculating the difference 36 | for (s in c(1:nlayers(simwet_stack))){ 37 | 38 | print(paste('s', s)) 39 | simwet_temp <- simwet_stack[[s]] 40 | simwet_temp[is.na(simwet_temp)] <- 0 41 | 42 | for (p in c(1:nlayers(preswet_stack))){ 43 | 44 | print(paste(' |- p', p)) 45 | preswet_temp <- preswet_stack[[p]] 46 | preswet_temp[is.na(preswet_temp)] <- 0 47 | 48 | # potwet <- simwet_temp - preswet_temp 49 | potwet<- overlay(simwet_temp, 50 | preswet_temp, 51 | fun=function(r1, r2){return(r1-r2)}) 52 | 53 | names(potwet) <- paste0(names(simwet_temp),'_',names(preswet_temp)) 54 | 55 | potwet[potwet<0] <- 0 56 | 57 | potwet_stack <- stack(potwet_stack, potwet) 58 | 59 | } 60 | } 61 | 62 | # Save potwet to file 63 | writeRaster(potwet_stack, '../output/results/natwet/potwet_n12_stack.tif') 64 | 65 | #sum the layers 66 | datasum <- cellStats(potwet_stack, stat='sum', na.rm=TRUE)/10^6 67 | -------------------------------------------------------------------------------- /plots/fig3abc/fig3_2021.r: -------------------------------------------------------------------------------- 1 | 2 | # /----------------------------------------------------------------------------# 3 | #/ Fig 2 A - Case studies map 4 | source('plots/fig3abc/fig3a_2021_v2.r') 5 | 6 | # /----------------------------------------------------------------------------# 7 | #/ Fig 2 B - scatterplot vs CaseStudies (Davidson, WET, ...) 8 | source('plots/fig3abc/fig3b_2021.r') 9 | 10 | # /----------------------------------------------------------------------------# 11 | #/ Fig 3 C - cumul lineplot 12 | source('plots/fig3abc/fig3c_2021.r') 13 | 14 | 15 | 16 | # /----------------------------------------------------------------------------# 17 | #/ Make multipanel plot ------ 18 | 19 | # arrange plots grob into layout 20 | fig3 <- plot_grid(fig3a_histcase_map, fig3_scatter, fig3c_cumulplot, 21 | ncol=1, nrow=3, 22 | rel_heights = c(0.4, 1.3, 1), 23 | labels = c('A','B','C'), 24 | align='v') 25 | 26 | # fig3 27 | 28 | # /----------------------------------------------------------------------------# 29 | #/ Save figure to file -------- 30 | 31 | ggsave('../output/figures/fig3/fig3abc_2021_v2.png', fig3, 32 | width=90, height=220, dpi=600, units='mm' ) 33 | 34 | ggsave('../output/figures/fig3/fig3abc_2021_v2.pdf', fig3, 35 | width=90, height=220, dpi=600, units='mm') 36 | 37 | dev.off() 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | # fig2a_wetarea_lineplot <- remwet_winset 46 | # set tight margins so plots are close side-by-side 47 | # fig2a <- fig2a + theme(plot.margin=unit(c(3, 3, 4, 3), 'mm')) 48 | # fig2c <- fig2c + theme(plot.margin=unit(c(3, 3, 4, 3), 'mm')) 49 | # 50 | 51 | # arrange in grid -------------------------------------------------------------- 52 | # set tight margins so plots are close side-by-side 53 | # Dimensions of each margin: t, r, b, l (To remember order, think trouble). 54 | # fig2b <- fig2b + theme(plot.margin=unit(c(-13, -5.5, -9, 1), 'mm')) 55 | # fig2d <- fig2d + theme(plot.margin=unit(c(-13, -5.5, -9, 1), 'mm')) 56 | 57 | -------------------------------------------------------------------------------- /data_proc/natwet/preswet/agg_glwd3_preswet.r: -------------------------------------------------------------------------------- 1 | 2 | 3 | ## AGGREGATE GLWD WETLAND FRACTION 4 | # read in GLWD3 5 | if(0){ 6 | g <- "../../Chap2_wetland_classification_GIEMS-D15C/data/glwd/glwd_3/glwd_3.adf" 7 | glwd3 <- raster(g, RAT=FALSE) 8 | 9 | rcl <- rbind(c(1,NA), 10 | c(2,NA), 11 | c(3,NA), 12 | c(4, 1), 13 | c(5, 1), 14 | c(6, 1), 15 | c(7, 1), 16 | c(8, 1), 17 | c(9, 1), 18 | c(10,.75), 19 | c(11,.375), 20 | c(12,.125)) 21 | rcl <- data.frame(rcl) 22 | 23 | 24 | # Substitute values in raster 25 | glwd3 <- subs(glwd3, rcl, by='X1', which='X2') 26 | 27 | # aggregate to 0.25 grid (0.25/0.0083333 = 30) 28 | glwd3_agg <- aggregate(glwd3, fact=30, na.rm=TRUE, fun="sum") 29 | # extent(glwd3_agg) <- extent(-180,180,-90,90) 30 | 31 | glwd3_agg_frac <- glwd3_agg/900 32 | 33 | writeRaster(glwd3_agg_frac, '../output/results/preswet/glwd3_wet_fw.tif', overwrite=T) 34 | } 35 | 36 | 37 | # /---------------------------------------------------------------------- 38 | #/ AGGREGATE GLWD OPEN WATER INTO: FRACTION OF 0.25DEG 39 | # read in GLWD3 40 | if(0){ 41 | g <- "../../Chap2_wetland_classification_GIEMS-D15C/data/glwd/glwd_3/glwd_3.adf" 42 | glwd3 <- raster(g, RAT=FALSE) 43 | 44 | rcl <- rbind(c(1,1), 45 | c(2,1), 46 | c(3,1), 47 | c(4,NA), 48 | c(5,NA), 49 | c(6,NA), 50 | c(7,NA), 51 | c(8,NA), 52 | c(9,NA), 53 | c(10,NA), 54 | c(11,NA), 55 | c(12,NA)) 56 | rcl <- data.frame(rcl) 57 | 58 | glwd3 <- subs(glwd3, rcl, by='X1', which='X2') 59 | 60 | 61 | # aggregate to 0.25 grid (0.25/0.0083333 = 30) 62 | glwd3_agg <- aggregate(glwd3, fact=30, na.rm=TRUE, fun="sum") 63 | # extent(glwd3_agg) <- extent(-180,180,-90,90) 64 | 65 | glwd3_agg_frac <- glwd3_agg/900 66 | 67 | writeRaster(glwd3_agg_frac, '../output/results/preswet/glwd3_ow_fw.tif', overwrite=T) 68 | } 69 | 70 | 71 | -------------------------------------------------------------------------------- /plots/lineplot/old/line_plot_facet_comparison_remwet_histcases.r: -------------------------------------------------------------------------------- 1 | # compare histcases to wetloss % from gis data 2 | 3 | 4 | 5 | 6 | remwet <- read.csv("../../output/results/histcase_remwet_extracted.csv") %>% 7 | # calc % loss 8 | mutate(perc_change_numeric = (remwet_end-remwet_start)/remwet_start*100) %>% 9 | mutate(yr_start = hyde_yr_start, yr_end = hyde_yr_end) %>% 10 | select(rec_id, yr_start, yr_end, perc_change_numeric) %>% 11 | mutate(name = "remwet") 12 | 13 | 14 | histcases <- read.csv('../../output/results/historic_cases_wetland_loss_mod.csv', stringsAsFactors=F) %>% 15 | select(rec_id, country, yr_start, yr_end, perc_change_numeric) %>% 16 | mutate(name = "histcase") 17 | 18 | 19 | 20 | 21 | comb <- inner_join(remwet, histcases, by="rec_id") %>% 22 | mutate(remwet_perc_loss = -(remwet_start-remwet_end)/remwet_start*100) 23 | 24 | 25 | ggplot(comb) + 26 | geom_point(data=comb, aes(x=remwet_perc_loss, y=perc_change_numeric)) 27 | 28 | 29 | 30 | 31 | #comb <- bind_rows(remwet, histcases) # %>% gather(a, b, yr_start, yr_end) 32 | 33 | 34 | # comb <- inner_join(remwet, histcases, by="rec_id") %>% 35 | # # select some columns 36 | # select(rec_id, year_start, year_end, perc_change_numeric, 37 | # hyde_year_start, hyde_year_end, remwet_perc_loss) 38 | # gather(a, b, 39 | # year_start, year_end, hyde_year_start, hyde_year_end) %>% 40 | # mutate(c = ifelse(grepl("hyde",comb$a), remwet_perc_loss, perc_change_numeric)) 41 | 42 | 43 | 44 | # # should the polygond be rasterized? 45 | # 46 | # map <- ggplot() + # bbox_robin_df, aes(long, lat) 47 | # 48 | # # add countries with data 49 | # geom_polygon(data=histcases_poly_sub, 50 | # aes(long, lat, group=group, 51 | # fill= perc_change_numeric), alpha=1) + 52 | # 53 | # coord_equal() + #theme_fig() + 54 | # #scale_fill_distiller(palette = 3) + 55 | # theme(legend.position="top") + 56 | # theme(plot.margin = unit(c(-2,-3,-2,-10), "mm")) 57 | # 58 | # map 59 | -------------------------------------------------------------------------------- /plots/artif_drainage/map_percent_drained.r: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------# 2 | #/ Convert polygons to df for plotting 3 | # Using custom function 4 | artdrain_type_nat_df <- prep_poly_into_robin_map_wdata(artdrain_type_nat) 5 | 6 | # Assign colors to drainage type 7 | # shouldn't this subset to the latest year of data? 8 | if(draintype=="cropland"){ typecolor <- "Blues"} 9 | if(draintype=="forestry"){ typecolor <- 2} 10 | if(draintype=="peatland"){ typecolor <- 7} 11 | 12 | 13 | 14 | # /----------------------------------------------------------------------------# 15 | #/ Make map 16 | map <- 17 | 18 | # set common parameters 19 | ggplot(bbox_robin_df, aes(long, lat)) + 20 | 21 | # Add country polygons 22 | geom_polygon(data=countries_robin_df, 23 | aes(long, lat, group=group), fill='grey90') + 24 | 25 | # add data countries 26 | geom_polygon(data=artdrain_type_nat_df, 27 | aes(long, lat, group=group, fill= f_drained*100)) + 28 | 29 | # add country outline 30 | geom_path(data=countries_robin_df, 31 | aes(long, lat, group=group), color='white', size=0.1) + 32 | 33 | 34 | geom_path(data=artdrain_type_nat_df, 35 | aes(long, lat, group=group), color="black", size=0.11) + 36 | 37 | # Add outline bounding box 38 | geom_path(data=bbox_robin_df, 39 | aes(long, lat, group=group), color="black", size=0.2) + 40 | 41 | 42 | coord_equal() + theme_fig() + 43 | scale_fill_distiller(type="seq", direction=1, palette = typecolor) + 44 | theme(legend.position="right", 45 | legend.direction = "vertical", 46 | plot.margin = unit(c(-2,-1,-2,-4), "mm")) + 47 | guides(fill = guide_colorbar(barwidth = 1, barheight = 15)) + 48 | 49 | labs(fill = paste0(draintype, " % drained")) 50 | 51 | 52 | #map 53 | 54 | # /----------------------------------------------------------------------------# 55 | #/ Save figure to file 56 | outdirfig <- paste0('./output/figures/artif_drainage/map/perc_drained_', draintype,'_v6.png') 57 | ggsave(outdirfig, width=178, height=90, dpi=600, units="mm") 58 | #dev.off() 59 | -------------------------------------------------------------------------------- /plots/artif_drainage/peat_extr_cumul_plot_si.r: -------------------------------------------------------------------------------- 1 | ## First run data reading; don't run all 2 | source('./data_proc/artif_drainage/process_peat_extr_weight.r') 3 | 4 | 5 | # /----------------------------------------------------------------------------# 6 | #/ Country plot of annual peat extraction rates 7 | p <- 8 | ggplot() + 9 | # ggplot(drained_peatex) + 10 | geom_path(data=subset(drained_peatex, !is.na(country_name) & !is.na(drained_weight)), 11 | aes(x=decade, y=drained_weight/1000, group=country_name, color=country_name), na.rm=T, size=0.4) + 12 | # Data points 13 | geom_point(data=subset(drained_peatex_dat,!is.na(country_name) & !is.na(drained_weight) & unit != 'subnational'), 14 | aes(x=year, y=drained_weight, group=country_name, color=country_name), 15 | size=0.3, alpha=0.5) + 16 | scale_x_continuous(limits=c(1700, 2020)) + 17 | ylab("Annual peat volume extracted (×1000 tonnes per year)") + xlab('') + 18 | facet_wrap(~country_name, scales='free', ncol=7) + 19 | line_plot_theme + 20 | theme(legend.position = 'none') 21 | 22 | ggsave("../output/figures/artif_drainage/sigmoid/peat_extract/peat_extract_tonsyear_v6.png", p, 23 | width=310, height=200, dpi=500, units='mm') 24 | 25 | dev.off() 26 | 27 | 28 | # /----------------------------------------------------------------------------# 29 | #/ County plot of cumulative peat extraction 30 | pc <- 31 | ggplot(subset(drained_peatex_int, !is.na(country_name))) + 32 | geom_path(aes(x=decade, y=drained_weight_cumsum/1000, group=country_name, color=country_name), size=0.4) + 33 | geom_point(aes(x=decade, y=drained_weight_cumsum/1000, group=country_name, color=country_name), size=0.3) + 34 | scale_x_continuous(limits=c(1700, 2020)) + 35 | scale_y_continuous(breaks=pretty_breaks(n=4)) + 36 | ylab("Cumulative peat volume extracted (×1000 tonnes)") + xlab('') + 37 | facet_wrap(~country_name, scales='free', ncol=7) + 38 | line_plot_theme + 39 | theme(legend.position = 'none') 40 | 41 | ggsave("../output/figures/artif_drainage/sigmoid/peat_extract/peat_extract_cumulvol_v6.png", pc, 42 | width=310, height=200, dpi=500, units='mm') 43 | 44 | dev.off() 45 | -------------------------------------------------------------------------------- /data_proc/fit/mcmc_fit/fcn_make_wetloss_df.r: -------------------------------------------------------------------------------- 1 | # Make function that takes in theta parameters, does the overlapping, compares to Davidson's sites 2 | make_wetloss_df <- function(p, s_i, p_i){ 3 | 4 | theta_rice = p[1] 5 | theta_pasture = p[2] 6 | theta_urban = p[3] 7 | 8 | # Functions that distribute different types of drainage (has to be inside function) 9 | source('./data_proc/overlay/fcn_distrib_drainage_stats_serial_v6_fordf_subnat.r', local=T) 10 | 11 | 12 | # Loop through years & LU - running wetland loss mapping 13 | source('./data_proc/overlay/full_serial_formcmc_faster_with_df_v4.r', local=T) 14 | 15 | 16 | # /------------------------------------------------------- 17 | #/ CALC RESIDUALS FROM HISTCASES 18 | # residuals 19 | resid <- cs_joined$map_perc_lost - cs_joined$perc_change_numeric 20 | # Weight residuals 21 | resid <- resid * (cs_joined$areapoly_mkm2 / var(cs_joined$areapoly_mkm2)) 22 | # Remove NA's that appear when dividing by 0. This happens to 23 | resid = resid[!is.na(resid)] 24 | # return(resid) 25 | 26 | 27 | # /--------------------------------------------------------------------------# 28 | #/ COST FUNCTION WITH FME::modCost; added on 28 Dec 2020 29 | 30 | # Format observation df 31 | obs_out <- data.frame(name = rep('wetloss', nrow(cs_joined))) 32 | obs_out$time <- 1:nrow(cs_joined) 33 | obs_out$val <- cs_joined$map_perc_lost * (cs_joined$areapoly_mkm2 / var(cs_joined$areapoly_mkm2)) 34 | 35 | # Format model output df 36 | model_out <- data.frame(time = 1:nrow(cs_joined)) 37 | model_out$wetloss <- cs_joined$perc_change_numeric * (cs_joined$areapoly_mkm2 / var(cs_joined$areapoly_mkm2)) * -1 38 | 39 | # Use modCost function; for input to modFit 40 | cost <- FME::modCost(model= model_out, obs = obs_out, y = 'val') 41 | 42 | return(cost) 43 | 44 | } 45 | 46 | 47 | 48 | # x = 'time', 49 | # obs_out$name <- 'wetloss' 50 | # obs_out$id <- NULL 51 | # obs_df <- data.frame(cs_joined$map_perc_lost * cs_joined$areapoly_mkm2) 52 | 53 | # 2.(optional) value of the independent variable (default column name = "time") ### NONE 54 | # 3.value of the observation 55 | # 4.(optional) value of the error -------------------------------------------------------------------------------- /data_proc/fit/mcmc_init/init_perc_crop_drained.r: -------------------------------------------------------------------------------- 1 | 2 | # /----------------------------------------------------------------------------# 3 | #/ CALCULATE % CROPLAND DRAINED PER COUNTRY & YEAR AS CAP FOR PASTURE DRAINAGE 4 | 5 | 6 | # /----------------------------------------------------------------------------# 7 | #/ Get total area of cropland per country x year 8 | cropland_nat <- 9 | # Bind cropland area griddf to griddf of country IDs 10 | bind_cols(cropland, ciso_df) %>% 11 | dplyr::select(-x, -y) %>% 12 | pivot_longer(cols=X1700:X2000, names_to='year', values_to='cropland_area') %>% 13 | mutate(year=as.numeric(substring(year, 2, 5))) %>% 14 | # filter(!is.na(nat_id)) %>% 15 | group_by(iso_a3, year) %>% 16 | dplyr::summarise(cropland_area = sum(cropland_area, na.rm=T), .groups="drop") %>% 17 | ungroup() 18 | 19 | 20 | # /----------------------------------------------------------------------------# 21 | #/ Get area of drained cropland 22 | 23 | drainage_cropland <- drainage %>% 24 | filter(type=='cropland') %>% 25 | group_by( year, iso_a3) %>% 26 | summarise(pred_drained = mean(pred_drained, na.rm=T), .groups="drop") %>% 27 | # left_join(., isolookup2, by=c('iso_a3'='iso_a3')) %>% 28 | ungroup() %>% 29 | distinct() %>% 30 | filter(!is.na(iso_a3)) %>% 31 | dplyr::select(iso_a3, year, pred_drained) 32 | 33 | 34 | 35 | # /----------------------------------------------------------------------------# 36 | #/ Join cropland cap to drainage data; calculate % drained per country & year 37 | # use as cap to pasture drainage ------- 38 | 39 | cropland_perc_drained <- 40 | left_join(cropland_nat, drainage_cropland, by=c('iso_a3'='iso_a3', 'year'='year')) %>% 41 | mutate(crop_drain_perc = pred_drained/cropland_area) %>% 42 | # Cap % at 1 43 | mutate(crop_drain_perc = ifelse(crop_drain_perc>1, 1, crop_drain_perc)) %>% 44 | mutate(crop_drain_perc = ifelse(is.na(crop_drain_perc), 0, crop_drain_perc)) %>% 45 | dplyr::select(iso_a3, year, crop_drain_perc) 46 | 47 | -------------------------------------------------------------------------------- /data_proc/artif_drainage/old/read_nat_artif_drainage_v2.r: -------------------------------------------------------------------------------- 1 | # output: filtered drainage data table 2 | 3 | # read the national drainage database 4 | drained <- read.csv('../data/artif_drained/all_drain_stat_comb_v4.csv') %>% 5 | 6 | filter(exclude != "exclude") %>% 7 | filter(region == "") %>% 8 | filter(unit == "national") %>% 9 | 10 | # remove total drainage stats 11 | filter(type != "total") %>% 12 | 13 | # convert weight to ha: 10t dry peat per hectare 14 | # mutate(drained_area_tot = ifelse(!is.na(drained_weight), drained_weight /3000 /1000, drained_area_tot)) %>% 15 | 16 | 17 | # conert area from 1000 ha to km^2 ( / 100 * 1000) 18 | mutate(drained_area_tot = as.numeric(drained_area_tot)) %>% 19 | mutate(drained_area_tot = drained_area_tot / 100 * 1000) %>% 20 | 21 | # add country codes 22 | mutate(iso_a3 = countrycode(country,'country.name','iso3c',warn=F)) %>% 23 | mutate(country_name = countrycode(iso_a3,'iso3c','country.name',warn=F)) %>% 24 | 25 | # calc decade 26 | mutate(decade=round(year,-1)) %>% 27 | 28 | # get the average per type x country x year 29 | group_by(type, iso_a3, country_name, year, Comment, Source) %>% 30 | dplyr::select_if(., is.numeric) %>% 31 | summarise_all(funs(mean)) %>% 32 | ungroup() %>% 33 | select(-id, -Arable.land.and.permanent.crops, -currently_expl) %>% 34 | filter(!is.na(country_name)) 35 | 36 | 37 | 38 | 39 | # filter data to the major drained area timelines 40 | drained <- drained %>% 41 | filter(!is.na(drained_area_tot)) %>% # has non-null data 42 | filter(drained_area_tot > 0) %>% # is bigger than 10 43 | filter(!is.na(year)) %>% # has a year 44 | filter(!is.na(iso_a3)) # is a country code 45 | 46 | 47 | # after all the filtering, add a unique record_id for each row. 48 | drained <- as.data.frame(drained) %>% mutate(rec_id = row.names(drained)) 49 | -------------------------------------------------------------------------------- /plots/map/map_historical_cases_poly.r: -------------------------------------------------------------------------------- 1 | 2 | # GEt Davidson data 3 | source('./plots/map/get_davidson_histcase_polygons.r') 4 | # Get 5 | source('./plots/map/get_wetindex_points.r') 6 | 7 | wetindex_pts_robin_df <- wetindex_pts_robin_df %>% 8 | mutate(wetloss_perc_1700to1970 <- wetloss_perc_1700to1970 * -1) %>% 9 | filter(Ramsar.type != 'Human-made') %>% 10 | filter(! Land.cover..from.paper. %in% c('Seagrass','Mangroves', 'Oyster reef')) 11 | 12 | 13 | 14 | 15 | # MAP HISTORICAL CASES COUNTRIES =============================================== 16 | map <- ggplot() + 17 | 18 | # add background country polygons 19 | geom_polygon(data=countries_robin_df, aes(long, lat, group=group), fill='grey85') + 20 | 21 | # add outline of background countries 22 | #geom_path(data=countries_robin_df, aes(long, lat, group=group), color='white', size=0.1) + 23 | 24 | # add countries with wetloss data; colored by value 25 | geom_polygon(data=histcases_poly_df, aes(long, lat, group=group), alpha=1, fill="blue") + 26 | 27 | # add outline of country with data 28 | geom_path(data=histcases_poly_df, aes(long, lat, group=group), color='white', size=0.1) + 29 | 30 | # Wet Index points 31 | geom_point(data=wetindex_pts_robin_df, aes(Longitude.1, Latitude.1), color='red', size=0.2) + 32 | 33 | # Add outline bounding box 34 | geom_path(data=bbox_robin_df, aes(long, lat, group=group), color="black", size=0.2) + 35 | 36 | scale_y_continuous(limits=c(-6600000, 8953595)) + 37 | 38 | coord_equal() + theme_fig() + 39 | scale_fill_distiller(palette = 3) + 40 | theme(legend.position="top") + 41 | theme(plot.margin = unit(c(-2,-1,-2,-1), "mm")) 42 | 43 | map 44 | 45 | 46 | # /---------------------------------------------------------------- 47 | #/ Save figure to file ----- 48 | ggsave('./output/figures/hist_cases/map_histcase_davidson_wetindex.png', 49 | width=87, height=60, dpi=800, units="mm", type = "cairo-png") 50 | dev.off() 51 | 52 | 53 | 54 | 55 | # delete objects 56 | rm(histcases_poly, histcases_poly_df, histcases_poly_robin, 57 | countries_robin_df, bbox_robin_df, map) 58 | -------------------------------------------------------------------------------- /plots/map/old/ggplot_wetlossmap_0.5_blank.r: -------------------------------------------------------------------------------- 1 | library(gridExtra) 2 | library(raster) 3 | library(rasterVis) 4 | library(latticeExtra) 5 | library(grid) 6 | 7 | # rename years 8 | if(yr<0){ 9 | yr_label <- paste0(yr*-1, 'BC') 10 | } else { 11 | yr_label <- paste0(yr, 'AD') 12 | } 13 | 14 | 15 | 16 | 17 | # wetloss in 1700 as natwet 18 | natwet_0.5 <- wetloss_mean_stack0.5[[1]] 19 | wet <- as(natwet_0.5, "SpatialPixelsDataFrame") 20 | wet <- as.data.frame(wet) 21 | names(wet) <- c("layer","x","y") 22 | 23 | 24 | blank_tile = wet 25 | 26 | 27 | 28 | # make adjoining map =========================================================== 29 | # map wetland 30 | wet_plt <- ggplot() + 31 | 32 | geom_tile(data=blank_tile, aes(x=x, y=y), fill= 'grey90') + 33 | # add background country polygons 34 | #geom_polygon(data=countries_df, aes(long, lat, group=group), fill='grey90') + 35 | 36 | coord_equal() + 37 | gif_map_theme() + 38 | scale_fill_distiller(palette='Blues', direction=1, limits=c(0,1)) + 39 | theme(legend.position=c(0.1, 0.4)) 40 | 41 | 42 | # plot cropland ================================================================ 43 | cropland_plt <- ggplot() + 44 | 45 | geom_tile(data=blank_tile, aes(x=x, y=y), fill= 'grey90') + 46 | # add background country polygons 47 | # geom_polygon(data=countries_df, aes(long, lat, group=group), fill='grey90') + 48 | 49 | coord_equal() + 50 | gif_map_theme() + 51 | scale_fill_distiller(palette='YlGn', direction=1, limits=c(0,1)) + 52 | theme(legend.position=c(0.1, 0.4)) 53 | 54 | 55 | # plot wetloss =============================================================== 56 | 57 | wetloss_plt <- ggplot() + 58 | 59 | geom_tile(data=blank_tile, aes(x=x, y=y), fill= 'grey90') + 60 | 61 | # add background country polygons 62 | # geom_polygon(data=countries_df, aes(long, lat, group=group), fill='grey90') + 63 | 64 | coord_equal() + 65 | gif_map_theme() + 66 | scale_fill_distiller(palette='OrRd', direction=1, limits=c(0,1)) + 67 | theme(legend.position=c(0.1, 0.4)) 68 | 69 | 70 | 71 | # combine as a grid 72 | post_1700_maps <- arrangeGrob(wet_plt, cropland_plt, wetloss_plt, nrow=1) 73 | 74 | rm(wet_plt, cropland_plt, wetloss_plt) -------------------------------------------------------------------------------- /data_proc/artif_drainage/old/get_forestry_in_drain_countries.R: -------------------------------------------------------------------------------- 1 | # Description: Extracts forestry area from countries with drainage data 2 | # Read in the wood harvest reconstruction of Hurtt et al 2006, 2011 3 | # data used is the gridcell fraction of secondary forest harvested 1) young and 2) mature. 4 | # Only secondary forest because primary forest wouldn't be drained. 5 | 6 | 7 | 8 | 9 | 10 | ####~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 11 | 12 | # get polygon of countries w drainage 13 | artdrain_forest_natpoly <- readRDS("./output/results/artif_drainage/artdrain_forest_natpoly.rds") 14 | 15 | 16 | wood_harvest <- readRDS("./data/hurtt_wood_harvest/wood_harvest.rds") 17 | 18 | 19 | ### Extract secondary forestry area -------------------------------------------- 20 | 21 | # this could be modified to also extract forest/peatlands... later 22 | source("./scripts/r/data_proc/fcn/fcn_raster_in_poly_sum_area.r") 23 | 24 | # run function that loops through polygons 25 | year_vector <- c(1500,1600,1700,seq(1800,2000,10)) 26 | area_extract <- get_raster_closest_yr(artdrain_forest_natpoly, wood_harvest, year_vector) 27 | 28 | 29 | # select a few columns (to avoid the .x & .y duplicated columns) 30 | area_extract <- area_extract[,c("rec_id","area","closest_year")] 31 | 32 | # merge new columns to polygons 33 | artdrain_forest_natpoly <- merge(artdrain_forest_natpoly, area_extract, by="rec_id") 34 | 35 | # remove the 0 area extracted 36 | artdrain_forest_natpoly <- subset(artdrain_forest_natpoly, area>0) 37 | 38 | # calculate percentage of cropla drained 39 | artdrain_forest_natpoly$fraction_drained <- (artdrain_forest_natpoly$drained_area_tot) / artdrain_forest_natpoly$area 40 | 41 | 42 | #==============================================================================# 43 | # Save output --------------------------------------------------------------- 44 | #==============================================================================# 45 | 46 | # write out dataframe 47 | saveRDS(area_extract, "./output/results/artif_drainage/artdrain_nat_forestry.rds") 48 | 49 | # write out polygon 50 | saveRDS(artdrain_forest_natpoly, "./output/results/artif_drainage/artdrain_nat_poly_forestry.rds") 51 | 52 | # delete variables 53 | rm(hyde_yrs, drain_poly, h, hyde, hyde_indx, area_extract) 54 | -------------------------------------------------------------------------------- /data_proc/overlay/get_drainage_stat_subset_for_distrib.r: -------------------------------------------------------------------------------- 1 | 2 | get_drainage_stat_subset_for_distrib <- function(drainage, str_draintype, y){ 3 | 4 | # /--------------------------------------------------------------------------# 5 | #/ Get drainage stats to calculate the new drainage to map ------- 6 | drainage_sub <- drainage %>% 7 | # Filter data 8 | filter(year == years[y], type == str_draintype) %>% 9 | # join numeral code of country 10 | # left_join(., isolookup2, by=c('iso_a3'='iso_a3')) %>% 11 | distinct() %>% 12 | # Remove rows without a numeric country code 13 | filter(!is.na(iso_a3)) %>% 14 | dplyr::select(iso_a3, HASC_1, pred_drained) 15 | 16 | # /--------------------------------------------------------------------------# 17 | #/ If after 1700, get drainage from previous year 18 | if (y > 1 ){ 19 | 20 | drainage_sub_prev <- drainage %>% 21 | filter(year == years[y-1], type == str_draintype) %>% 22 | # left_join(., isolookup2, by=c('iso_a3'='iso_a3')) %>% 23 | distinct() %>% 24 | filter(!is.na(iso_a3)) %>% 25 | # dplyr::select(iso_a3, pred_drained) %>% # ID, 26 | plyr::rename(c('pred_drained' = 'prev_pred_drained')) %>% 27 | dplyr::select(iso_a3, HASC_1, prev_pred_drained) 28 | 29 | # /------------------------------------------------------------------------# 30 | #/ Calculate the new drained area for this time step 31 | # As the difference between current and previous drainage. 32 | drainage_sub <- left_join(drainage_sub, drainage_sub_prev, by=c('iso_a3','HASC_1')) %>% 33 | mutate(pred_drained = pred_drained - prev_pred_drained) 34 | 35 | 36 | } 37 | 38 | drainage_sub <- drainage_sub %>% distinct() 39 | 40 | new_drain_from_stats <- round(sum(drainage_sub$pred_drained, na.rm = T),0) 41 | print(paste(' - new drain from stats: ', new_drain_from_stats)) 42 | 43 | 44 | return(drainage_sub) 45 | } -------------------------------------------------------------------------------- /plots/hist_cases/line_plot_historical_cases.r: -------------------------------------------------------------------------------- 1 | 2 | # write formatted histcase output 3 | histcases <- read.csv('./output/results/histcases_mod/historic_cases_wetland_loss_mod.csv') 4 | 5 | 6 | 7 | 8 | 9 | # plot wetland loss duration =================================== 10 | ggplot(histcases) + 11 | geom_hline(yintercept = 0) + 12 | geom_point(aes(x=nb_yrs, y=perc_change_numeric, color=continent), 13 | size=1, alpha=0.3) + 14 | xlab('Record Length (years)') + 15 | ylab("Wetland area change (%)") + 16 | ylim(-100, 150) + 17 | line_plot_theme 18 | 19 | 20 | ### save plot 21 | ggsave("./output/figures/scatter_plot_hist_cases_percrate_length.png", 22 | width=98, height=90, dpi=600, units='mm', type = "cairo-png") 23 | 24 | dev.off() 25 | 26 | 27 | 28 | 29 | # PLOT - lines of histcases wetloss ============================================== 30 | 31 | # subset database that has both start and end 32 | histcases_compcases <- histcases %>% 33 | 34 | # select data columns 35 | dplyr::select(rec_id, continent, yr_start, yr_end, perc_change_numeric) %>% 36 | # keep cases 37 | filter(complete.cases(.)) %>% 38 | gather(year_name, year, yr_start:yr_end) %>% 39 | mutate(perc_change_numeric= ifelse(year_name=='yr_start', 40 | 100, 100+perc_change_numeric)) 41 | 42 | 43 | # get package that does ggzoom 44 | library(ggforce) 45 | 46 | # makeplot 47 | ggplot(histcases_compcases) + 48 | 49 | # points 50 | geom_point(aes(x=year, y=perc_change_numeric, group=rec_id, color=continent), 51 | size=0.2, alpha=0.8) + 52 | 53 | # plot lines between pairs of pts 54 | geom_line(aes(x=year, y=perc_change_numeric, group=rec_id, color=continent), 55 | alpha=0.3, size=0.45) + 56 | 57 | # axes labels 58 | xlab('Year') + ylab("Wetland area remaining (%)") + 59 | 60 | line_plot_theme + 61 | theme(legend.direction = "vertical", 62 | legend.position = "right") + 63 | 64 | # add a zoomed-in panel 65 | facet_zoom(x = year>=1900) 66 | 67 | 68 | ### save plot 69 | ggsave("./output/figures/scatter_plot_hist_cases_perc_rate_lines.png", 70 | width=178, height=120, dpi=600, units='mm', type = "cairo-png") 71 | 72 | dev.off() 73 | 74 | -------------------------------------------------------------------------------- /data_proc/natwet/old/make_ensemble_fromoverlays.r: -------------------------------------------------------------------------------- 1 | # process ensemble 2 | 3 | 4 | 5 | # read overlay output of diff resolutions 6 | wetloss_all_0.5 <- read.csv('./output/results/global_sum_wetloss_wetchimp_0.5_3subgrid.csv') 7 | wetloss_all_1.0 <- read.csv('./output/results/global_sum_wetloss_wetchimp_3subgrid.csv') 8 | 9 | wetloss_all_0.5$res <- 0.5 10 | wetloss_all_1.0$res <- 1.0 11 | 12 | # combine into one df 13 | wetloss_all <- bind_rows(wetloss_all_0.5, wetloss_all_1.0) 14 | 15 | # remove temps 16 | rm(wetloss_all_0.5, wetloss_all_1.0) 17 | 18 | 19 | 20 | # prepare remwer data ========================================================= 21 | 22 | # get remaining wetland area in 1700, to calc remwet percent from then 23 | wetarea_in1700 <- wetloss_all %>% 24 | 25 | # keep years after 1700 26 | filter(year == 1700) %>% 27 | # select columns 28 | dplyr::select(name, overlap, tot_remwet_Mkm2) %>% 29 | # rename column to reflect its only in 1700 30 | rename(tot_remwet_Mkm2_in1700 = tot_remwet_Mkm2) 31 | 32 | 33 | # prep data 34 | wetloss_all<- wetloss_all %>% 35 | 36 | # remove years not ending in 10 37 | filter(year %% 10 ==0) %>% 38 | 39 | # join the remwet in 1700 and calc percent remaining area since then 40 | left_join(., wetarea_in1700, by=c("name", "overlap")) %>% 41 | 42 | # calculate the % from the 1700 wetcover 43 | mutate(remwet_prc_since1700 = tot_remwet_Mkm2 / tot_remwet_Mkm2_in1700 * 100) 44 | 45 | 46 | 47 | 48 | # calculate the ensemble min, mean, max 49 | wetloss_ensemble_prc <- wetloss_all %>% 50 | 51 | # remove non-numeric columns from the summarize 52 | dplyr::select(-one_of(c("X","name", "overlap","res"))) %>% 53 | # group by year 54 | mutate(year = as.character(year)) %>% 55 | group_by(year) %>% 56 | # calculate the summary values 57 | summarise_all(.funs=c('mean', 'min', 'max')) %>% 58 | # return year to a numeric 59 | mutate(year= as.numeric(year)) 60 | 61 | 62 | 63 | # write outputs 64 | write.csv(wetloss_all, "./output/results/wetloss/wetloss_all") 65 | write.csv(wetloss_ensemble_prc, "./output/results/wetloss/wetloss_ensemble_prc") 66 | 67 | 68 | 69 | # delete objects 70 | rm(wetloss_all, wetarea_in1700, wetloss_ensemble_prc) 71 | 72 | -------------------------------------------------------------------------------- /plots/lineplot/line_plot_sum_nat_wetland_all.R: -------------------------------------------------------------------------------- 1 | 2 | # read in global sums from WETCHIMP data 3 | i <- "./output/results/old/global_sum_nat_wetland_20th.csv" 4 | sum_nat_wet_20th <- read.csv(i, stringsAsFactors = F) %>% 5 | gather(year_type, year, year_end:year_start) %>% 6 | dplyr::select(-one_of(c('year_type',"X"))) 7 | 8 | 9 | 10 | i <- "./output/results/old/global_sum_wetloss_v2.csv" 11 | sum_nat_wet_lpx <- read.csv(i, stringsAsFactors = F) %>% 12 | mutate(wet_Mkm2 = tot_wet_Mkm2, 13 | name = "LPX-DYTOP (Stocker et al. 2017)") %>% 14 | dplyr::select(year, name, wet_Mkm2) 15 | 16 | 17 | 18 | sumarea_orchidee <- readRDS("./output/results/natwet/natwet_orchidee.rds") 19 | 20 | 21 | 22 | 23 | # combine rows 24 | sum_nat_wet_comb <- bind_rows(sum_nat_wet_20th, sum_nat_wet_lpx) 25 | 26 | # remove pieces 27 | rm(sum_nat_wet_20th, sum_nat_wet_lpx) 28 | 29 | # declare time break for x-axis 30 | mybreaks <- c(1850, 1901, 1932, 1993, 2004) 31 | 32 | 33 | 34 | # plot 6000BC-2000AD =========================================================== 35 | ggplot(sum_nat_wet_comb) + 36 | geom_line(aes(x=year, wet_Mkm2, color=name), size=1) + 37 | geom_point(aes(x=year, wet_Mkm2, color=name), size=1) + 38 | 39 | scale_x_continuous(breaks=mybreaks, labels=mybreaks) + 40 | xlab("Year") + ylab("Natural wetland area (10^6 km2)") + 41 | xlim(-6000, 2000) + ylim(5,15) 42 | 43 | 44 | # plot 1850 onward --------------------------------------------------- 45 | ggplot(sum_nat_wet_comb) + 46 | 47 | geom_line(aes(x=year, wet_Mkm2, color=name)) + 48 | #geom_point(aes(x=year, wet_Mkm2, color=name), size=1) + 49 | 50 | geom_line(data=sumarea_orchidee, aes(x=year, y=tot_natwet_Mkm2, color=model)) + 51 | 52 | scale_x_continuous(breaks=mybreaks, labels=mybreaks, 53 | limits=c(1850,2010), expand=c(0,0)) + 54 | scale_y_continuous(limits=c(0,65), expand=c(0,0)) + 55 | xlab("Year") + 56 | ylab("Natural wetland area (10^6 km2)") 57 | 58 | 59 | 60 | ### save plot ------------------------------------------------------------------ 61 | ggsave("./output/figures/natwet_lineplot/line_plot_sum_nat_wet_post1850.png", 62 | width=240, height=120, dpi=600, units='mm') #, type = "cairo-png") 63 | 64 | dev.off() 65 | -------------------------------------------------------------------------------- /data_proc/fcn/fcn_get_polygons_for_drainage.r: -------------------------------------------------------------------------------- 1 | # DESCRIPTION --------------------- 2 | # Create A function selecting shapefile for each individual table row 3 | 4 | 5 | ### ARGUMENTS ----------------- 6 | # histcases = the table 7 | # shapefile = shapefile 8 | # join field from table 9 | # join field from shapefile 10 | # id = record identifier column (e.g. "rec_id") 11 | 12 | 13 | ### TEMP VARIABLES FOR DEBUGGING -------- 14 | # table <- drained_type 15 | # byx <- "iso_a3" 16 | # shapefile <- countries 17 | # byy <- "iso_a3" 18 | # id <- "rec_id" 19 | 20 | 21 | 22 | ### FUNCTION ----------------- 23 | sel_countries_in_shp <- function(table, shapefile, byx, byy, id){ 24 | 25 | # convert the coutnry code field to character, for later matching 26 | shapefile@data[,byy] <- as.character(shapefile@data[,byy]) 27 | 28 | # filter shapefile by adm country codes, reduces the pool to loop from later on 29 | t <- c(table[, byx]) 30 | subset_shp <- subset(shapefile, iso_a3 %in% t) # the [[]] removes the names from the vector 31 | 32 | 33 | # loop through table & extract remwet value for each polygon 34 | for (i in seq(1, nrow(table))) { 35 | 36 | print(i) 37 | 38 | # subset row 39 | temp_row <- table[i,] 40 | 41 | # get record id of single 42 | temp_id <- as.numeric(temp_row[,id]) 43 | 44 | # reset the polygon from which selection is made 45 | shp_forjoin <- subset_shp 46 | 47 | # select polygon matching the iso code 48 | temp_poly <- shp_forjoin[shp_forjoin@data[,byy] == as.character(temp_row[,byx]),] 49 | 50 | # print(paste0(shp_forjoin@data[,byy], " ", as.character(temp_row[,byx]))) 51 | 52 | # if one or more polygon is a match (of ISO code) 53 | if (dim(temp_poly)[1] > 0){ 54 | 55 | # write the id 56 | temp_poly@data$rec_id <- temp_id 57 | 58 | # if the first loop iteration, create the output shp instead of appending 59 | 60 | # create output 61 | if (i==1){ outpoly <- temp_poly 62 | 63 | # else, if not the 1st loop, append the polygon to output 64 | } else { outpoly <- rbind(outpoly, temp_poly, makeUniqueIDs = TRUE) } 65 | } 66 | 67 | } 68 | 69 | # outputs the selected shapefile 70 | return(outpoly) 71 | } 72 | -------------------------------------------------------------------------------- /plots/si_figures/si_figures.r: -------------------------------------------------------------------------------- 1 | 2 | # /----------------------------------------------------------------------------# 3 | #/ SI PLOTS & TABLES ------ 4 | 5 | # FIG 1.5 - sigmoid data points 6 | source('./plots/artif_drainage/fig1p5_drainstats.r') 7 | source('./plots/artif_drainage/sigmoid_template_facet.r') 8 | 9 | 10 | # table; Combine run r^2 and drained area for SI table 11 | source('data_proc/fit/finalize_run_df_forSI.r') 12 | 13 | #/ Fig 3 C - cumul lineplot of regional& WETindex data & KS test 14 | source('plots/fig3abc/fig3c_2021_forSI.r') 15 | 16 | 17 | # SI plot - maps of drainage database country & subnat units - 2021 18 | source('./plots/artif_drainage/map_drain_data_nat.r') 19 | source('./plots/artif_drainage/subnat/map_subnat_units.r') 20 | 21 | # SI plot - lineplot interpolated drainage data country - 2021 22 | source('./plots/artif_drainage/si_lineplot_sigmoid_reconstruct.r') 23 | 24 | #/ Figure with time distribution histogram of drainage stats 25 | source('plots/artif_drainage/histogram_timedistribution_drainstats.r') 26 | 27 | # SI plot - map of generalized regions for sigmoid parameters 28 | source('./plots/artif_drainage/map_sigmoid_regions.r') 29 | 30 | # Map of preswet, potwet grid 31 | # source('./plots/figSI_map_matrix.r') 32 | source('./plots/nat_wet/map_potwet_grid.r') 33 | 34 | # Maps of present-day wetlands (one map per input data) 35 | source('./plots/nat_wet/si_preswet_stack_map.r') 36 | source('./plots/nat_wet/si_simwet_stack_map.r') 37 | 38 | # SI plot - lineplots of mapped wetloss per lu (extracted from grid_drain_perlu) 39 | source('./plots/lineplot/facet_country_grid_drain_perlu.r') 40 | 41 | # Map of max drainage rate time period 42 | source('./plots/map/max_loss_rate_map_forSI.r') 43 | 44 | # Map LU drivers in separate maps 45 | source('./plots/map/map_ludrivers_facet.r') 46 | 47 | # Map peatland regions 48 | source('./plots/per_basin/map_peat_regions.r') 49 | 50 | #/ Fig.2A lineplot but with area - with all reconstructions 51 | source('plots/fig2abcd/fig2a_wetarea_lineplot.r') 52 | 53 | #/ Panel of wetloss map figure 2B 54 | source('plots/fig2abcd/panel_fig2b_wetloss_forsi.r') 55 | 56 | #/ SI - Boxplot of theta parameters 57 | source('plots/fit/theta_boxplot.r') 58 | 59 | # SI - Peat extraction rates and cumul 60 | source('plots/artif_drainage/peat_extr_cumul_plot_si.r') 61 | 62 | -------------------------------------------------------------------------------- /data_proc/hist_cases/old/ensemble_mean_grid_peryear.r: -------------------------------------------------------------------------------- 1 | # Description: Averages wetland area grids from 2 | 3 | 4 | # get 5 | source("./scripts/r/plots/fcn/average_grids.r") 6 | 7 | 8 | # create ouput directory string 9 | odir <- './output/results/wetloss/grid/' 10 | 11 | # create function that tests if object exists 12 | exist <- function(x) { return(exists(deparse(substitute(x))))} 13 | 14 | 15 | # get hyde years ===================================================== 16 | hyde_yrs_all <- readRDS('./output/results/hyde_yrs/hyde_yrs_all.rds') 17 | hyde_yrs_all <- hyde_yrs_all[hyde_yrs_all >= -6000] 18 | hyde_yrs_all <- abs(hyde_yrs_all) 19 | 20 | hyde_yrs_since1700 <- readRDS('./output/results/hyde_yrs/hyde_yrs_since1700.rds') 21 | 22 | 23 | 24 | 25 | ### ENSEMBLE MEAN OF ============================ 26 | 27 | # get remwet & wetloss grids 28 | remwet_Mkm2_stack <- readRDS('./output/results/wetloss/grid/remwet_Mkm2_stack_2.5deg.rds') 29 | wetloss_Mkm2_stack <- readRDS('./output/results/wetloss/grid/wetloss_Mkm2_stack_2.5deg.rds') 30 | 31 | # subset of models 32 | toMatch <- c("lpxdytop") 33 | 34 | # averate remwet since 1700 35 | mean_stack <- average_grids(hyde_yrs_all, remwet_Mkm2_stack, toMatch) 36 | saveRDS(mean_stack, paste0(odir, 'remwet_Mkm2_stack_2.5deg_mean_year.rds')) 37 | 38 | # averate wetloss since 1700 39 | mean_stack <- average_grids(hyde_yrs_all, wetloss_Mkm2_stack, toMatch) 40 | saveRDS(mean_stack, paste0(odir, 'wetloss_Mkm2_stack_2.5deg_mean_year.rds')) 41 | 42 | 43 | 44 | 45 | ################################################################################ 46 | 47 | # get remwet 48 | remwet_Mkm2_stack <- readRDS('./output/results/wetloss/grid/remwet_Mkm2_stack_0.5deg.rds') 49 | wetloss_Mkm2_stack <- readRDS('./output/results/wetloss/grid/wetloss_Mkm2_stack_0.5deg.rds') 50 | 51 | 52 | # list of models to include; excluding SDGVM because of exceedingly high wetalnd area 53 | toMatch <- c("DLEM","fmax") 54 | 55 | 56 | # averate remwet since 6000BC 57 | mean_stack <- average_grids(hyde_yrs_all, remwet_Mkm2_stack) 58 | saveRDS(mean_stack, paste0(odir, 'remwet_Mkm2_stack_0.5deg_mean_year.rds')) 59 | 60 | # averate wetloss since 6000BC 61 | mean_stack <- average_grids(hyde_yrs_all, wetloss_Mkm2_stack) 62 | saveRDS(mean_stack, paste0(odir, 'wetloss_Mkm2_stack_0.5deg_mean_year.rds')) 63 | 64 | 65 | -------------------------------------------------------------------------------- /data_proc/fit/run_fit_2021.r: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------# 2 | #/ This is the script to copy in every R member 3 | 4 | 5 | # SET WD 6 | setwd(here()) 7 | source('./data_proc/prep_init.r') # Prep functions, themes, etc. 8 | options(row.names=FALSE, scipen = 999) 9 | # library(fasterize) 10 | # library(raster) 11 | # library(dplyr) 12 | # library(countrycode) 13 | # library(fasterize) 14 | # library(sf) 15 | 16 | 17 | 18 | ##################################### 19 | cs_peat=0 # Include peatland histcases in comparison or not 20 | 21 | # Run config 22 | test_theta = 0 # use test theta values (of 3, 0.5, 5) 23 | null_theta = 0 # use null theta values (of 0,0,0) 24 | test_potwet = 0 # use testing potwet (combination of preswet #1 and simwet #4) ?dbl check numbers 25 | update_potwet = 0 # whether to subtract drained area from potwet; !!! turning this off reduces need for expanding allowable & filling overlap 26 | save_all_output = 0 # Save all outputs for fig 2 & 3 27 | 28 | # Drain_distrib config 29 | fill_val = 10e-4 # Fill value for perc_overlap; influences balance between real LUoverlap and filled 30 | scale_allowable = 1 31 | expand_perc_overlap = 1 # Expand perc_overlap to every...? 32 | nb_repeats = 4 # Number of redistribution loops 33 | 34 | ####################################### 35 | # Args: s_i, p_i, niteration 36 | s_i = 4 37 | p_i = 1 38 | niteration = 3 39 | ###################################### 40 | 41 | 42 | 43 | # 1 44 | # Initialize inputs for fitting (run once at the start) 45 | source('./data_proc/overlay/initialize_prefitting.r') 46 | 47 | 48 | # 2 49 | # Get function that takes in theta parameters, 50 | # does the drain distrib, compares to histcases, then outputs residuals 51 | # This is the function that gets optimized 52 | source('./data_proc/fit/fcn_runmodel_getresiduals_2021.r', local=T) 53 | 54 | 55 | # 3 56 | # Wrapper functions that sets the p_i & s_i parameters 57 | source('./data_proc/fit/fcn_run_mcmc.r', local=T) 58 | source('./data_proc/fit/fcn_run_modfit.r', local=T) 59 | 60 | 61 | # 4 62 | # Run the fitting 63 | fit <- run_modfit(s_i, p_i, niteration) 64 | # fit <- run_mcmc(s_i, p_i, niteration) 65 | 66 | # 5 67 | # Save output 68 | out_f <- paste0('../output/results/fit/modfit_s', s_i, '_p', p_i, '_i', niteration, '.rds') 69 | saveRDS(fit, out_f) 70 | 71 | -------------------------------------------------------------------------------- /data_proc/fit/mcmc_fit/fcn_get_pars_range.r: -------------------------------------------------------------------------------- 1 | s# /----------------------------------------------------------------------------# 2 | #/ Function that gets 0.025, 0.50, 0.974 percentile of theta parameters ------ 3 | get_pars_range <- function(MCMCout) { 4 | 5 | # Get parameters in df 6 | MCMCpars <- as.data.frame(MCMCout$pars) 7 | 8 | # Remove first 50% of iterations as burn in 9 | # MCMCpars <- MCMCpars[seq(nrow(MCMCpars)*0.5, nrow(MCMCpars), by=1),] 10 | 11 | # Get 5% and 95% parameters 12 | # Each of the three parameter value is taken separately; low parameters -> low loss, high params -> high loss 13 | pars_sel <- data.frame(lapply(MCMCpars[1:3], quantile, prob = c(0.025, 0.975), names = TRUE)) 14 | pars_sel$type <- row.names(pars_sel) 15 | 16 | 17 | 18 | # The bestpar are selected based on the ones giving the the highest probability (funp). 19 | # the parameter set that gave the highest probability. 20 | # Not sure why SS or residuals are not used to determine bestpar 21 | bestpar <- as.data.frame(MCMCout$bestpar) %>% t() 22 | names(bestpar) <- c('theta_rice', 'theta_pasture', 'theta_urban') 23 | 24 | 25 | pars <- as.data.frame(MCMCout$pars) %>% # [1001:2000,] 26 | mutate(SS = MCMCout$SS) %>% 27 | mutate(sig = MCMCout$sig[,1]) %>% 28 | distinct() %>% 29 | arrange(SS) 30 | 31 | pars <- pars[1:10, ] 32 | 33 | # filter(SS == min(SS)) 34 | # filter(sig == min(sig)) 35 | 36 | 37 | glimpse(pars) 38 | 39 | ### GET BEST PARS BASED ON FUNP 40 | pars <- as.data.frame(MCMCout$pars) %>% 41 | mutate(SS = MCMCout$SS) %>% 42 | mutate(sig = MCMCout$sig[,1]) %>% 43 | dplyr::filter(theta_rice == bestpar[1,'theta_rice'] & 44 | theta_pasture == bestpar[1,'theta_pasture'] & 45 | theta_urban == bestpar[1,'theta_urban']) 46 | glimpse(pars) 47 | 48 | 49 | # find the iteration no that had best par 50 | # use the iteration to get the SS 51 | 52 | 53 | 54 | # Get best parameter (diff var in mcmc object) 55 | bestpar <- as.data.frame(t(MCMCout$bestpar)) %>% mutate(type='bestvar', var_model=max(MCMCout$sig)) 56 | 57 | pars_sel <- bind_rows(pars_sel, bestpar) 58 | pars_sel$type <- c('low','high','best') 59 | # Write preswet name in column 60 | pars_sel$preswet <- names(preswet_stack)[p_i] #preswet_name 61 | pars_sel$niter <- nrow(MCMCpars) 62 | 63 | return(pars_sel) 64 | } -------------------------------------------------------------------------------- /data_proc/fit/mcmc_init/init_potwet_every_run.r: -------------------------------------------------------------------------------- 1 | # Initialize the preswet and potwet dfgrids 2 | 3 | # the indices for simwet and preswet 4 | if (test_potwet) { s_i = 4 ; p_i = 1 } 5 | 6 | 7 | # /------------------------------------------------------------------ 8 | #/ Get simwet 9 | simwet <- simwet_stack[[s_i]] # 1 - 4 10 | simwet_df <- left_join(maxlncr_df_xy, raster2df(simwet), by=c('x','y')) 11 | 12 | # /------------------------------------------------------------------ 13 | #/ Get preswet - mamax 14 | 15 | preswet <- preswet_stack[[p_i]] # 1-3 16 | # Convert preswet to grid df 17 | preswet_df <- left_join(maxlncr_df_xy, raster2df(preswet), by=c('x','y')) 18 | # Select 3rd column; the one containing data 19 | preswet_df <- preswet_df[[3]] 20 | 21 | 22 | # /------------------------------------------------------------------ 23 | #/ Get preswet - mamax 24 | 25 | if(preswet_max == 1){ 26 | 27 | preswet <- preswet_max_stack[[p_i]] # 1-3 28 | # Convert preswet to grid df 29 | preswet_df <- left_join(maxlncr_df_xy, raster2df(preswet), by=c('x','y')) 30 | # Select 3rd column; the one containing data 31 | preswet_df <- preswet_df[[3]] 32 | } 33 | 34 | 35 | # /------------------------------------------------------------------ 36 | #/ Calculate potwet: Used to distribute drainage 37 | potwet <- simwet - preswet 38 | # 0 negative values 39 | potwet[potwet<0] <- 0.0001 # 0 40 | # ensure potwet cannot be greater than pixarea 41 | potwet <- min(potwet, maxlncr) 42 | # Convert to standard df grid 43 | potwet_df <- left_join(maxlncr_df_xy, raster2df(potwet), by=c('x','y')) 44 | # Select column 45 | potwet_df <- potwet_df$layer 46 | 47 | 48 | ##### 49 | # Diagnosis maps 50 | if(0){ 51 | ggplot() + geom_tile(data=preswet_df, aes(x,y,fill=layer)) 52 | 53 | ggplot() + geom_tile(data=simwet_df, aes(x,y,fill=SDGVM2_km2)) 54 | 55 | ggplot() + 56 | geom_tile(data=potwet_df, aes(x,y,fill=layer)) + 57 | geom_tile(data=subset(potwet_df, layer==0), aes(x,y), fill='red') 58 | 59 | } 60 | 61 | # /----------------------------------------------------------------------------# 62 | #/ Make empty output df ------ 63 | total_drain_perlu_peryear <- 64 | data.frame(lu_type = character(), 65 | year = numeric(), 66 | new_drain_km2 = numeric(), 67 | cumul_drain_km2 = numeric(), 68 | rem_potwet_km2 = numeric()) 69 | 70 | 71 | total_drain_perlu_peryear <- data.frame() 72 | -------------------------------------------------------------------------------- /plots/artif_drainage/old/map_peatland_drainage_stats.R: -------------------------------------------------------------------------------- 1 | # description: map drainage as percentage of country -------------------------- 2 | #==============================================================================# 3 | 4 | # read drainage shp 5 | artdrain_peatland_natpoly <- readRDS("./output/results/artif_drainage/artdrain_nat_poly_peatland.rds") 6 | 7 | 8 | 9 | # Fortify & reproject polygons to ggplot-mappable df 10 | artdrain_peatland_natpoly_df <- prep_poly_into_robin_map_wdata(artdrain_peatland_natpoly) 11 | 12 | 13 | #==============================================================================# 14 | # make ggplot map -------------------------------------------- 15 | #==============================================================================# 16 | 17 | map <- 18 | 19 | ggplot(bbox_robin_df, aes(long, lat)) + 20 | 21 | # add background country polygons 22 | geom_polygon(data=countries_robin_df, 23 | aes(long, lat, group=group), fill='grey85') + 24 | 25 | # add data countries 26 | geom_polygon(data=artdrain_peatland_natpoly_df, 27 | aes(long, lat, group=group, fill= fraction_drained*100), alpha=1) + 28 | 29 | 30 | # add country outline 31 | geom_path(data=countries_robin_df, aes(long, lat, group=group), color='white', size=0.1) + 32 | 33 | # Add outline bounding box 34 | geom_path(data=bbox_robin_df, aes(long, lat, group=group), color="black", size=0.2) + 35 | 36 | 37 | coord_equal() + theme_fig() + 38 | scale_fill_distiller(type="seq", direction=1, palette = 7) + 39 | theme(legend.position="top") + 40 | theme(plot.margin = unit(c(-2,-3,-2,-10), "mm")) + 41 | guides(fill = guide_colorbar(barwidth = 14, barheight = 0.5)) + 42 | 43 | labs(fill = "Secondary forest % drained") 44 | 45 | 46 | map 47 | 48 | 49 | 50 | ### save figure to file ================================================== 51 | 52 | ggsave('./output/figures/artif_drainage/map/perc_drained_peatland.png', 53 | width=178, height=90, dpi=600, units="mm")#, type = "cairo-png") 54 | dev.off() 55 | 56 | 57 | 58 | 59 | 60 | 61 | # test; why do i lose some unique drainage data? 62 | # the ..._df suffux means that it is foritified as df for plotting 63 | # u <- artdrain_ag_nat@data[,c("rec_id","iso_a3","year","drained_area_tot")] 64 | # sort(unique(u$artdrain_nat_df)) 65 | # unique(artdrain_ag_nat_df$drained_area_tot) 66 | 67 | #artdrain_ag_nat_df <- artdrain_ag_nat_df[,c("country_name","decade","drained_area_tot","cropland")] -------------------------------------------------------------------------------- /plots/map/old/ggplot_wetlossmap_0.5.r: -------------------------------------------------------------------------------- 1 | library(gridExtra) 2 | library(raster) 3 | library(rasterVis) 4 | library(latticeExtra) 5 | library(grid) 6 | 7 | # rename years 8 | if(yr<0){ 9 | yr_label <- paste0(yr*-1, 'BC') 10 | } else { 11 | yr_label <- paste0(yr, 'AD') 12 | } 13 | 14 | 15 | 16 | # make adjoining map =========================================================== 17 | 18 | # # percentage wetland 19 | wet <- as(natwet_f, "SpatialPixelsDataFrame") 20 | wet <- as.data.frame(wet) 21 | names(wet) <- c("layer","x","y") 22 | wet <- wet[wet$layer > 0,] 23 | 24 | 25 | # map wetland 26 | wet_plt <- ggplot() + 27 | 28 | geom_tile(data=blank_tile, aes(x=x, y=y), fill= 'grey90') + 29 | geom_tile(data=wet, aes(x=x, y=y, fill=layer)) + 30 | 31 | coord_equal() + 32 | gif_map_theme() + 33 | scale_fill_distiller(palette='Blues', direction=1, limits=c(0,1)) + 34 | theme(legend.position=c(0.1, 0.4)) 35 | 36 | 37 | # plot cropland ================================================================ 38 | 39 | # cropland fraction 40 | c_f <- as(c_f, "SpatialPixelsDataFrame") 41 | c_f <- as.data.frame(c_f) 42 | c_f <- c_f[c_f$layer > 0,] 43 | 44 | cropland_plt <- ggplot() + 45 | 46 | geom_tile(data=blank_tile, aes(x=x, y=y), fill= 'grey90') + 47 | # add background mask 48 | geom_tile(data=c_f, aes(x=x, y=y, fill=layer)) + 49 | 50 | coord_equal() + 51 | gif_map_theme() + 52 | scale_fill_distiller(palette='YlGn', direction=1, limits=c(0,1)) + 53 | theme(legend.position=c(0.1, 0.4)) 54 | 55 | 56 | 57 | # plot wetloss =============================================================== 58 | 59 | 60 | # cropland fraction 61 | wetloss <- as(wetloss_f, "SpatialPixelsDataFrame") 62 | wetloss <- as.data.frame(wetloss) 63 | names(wetloss) <- c("layer","x","y") 64 | wetloss <- wetloss[wetloss$layer > 0,] 65 | 66 | wetloss_plt <- ggplot() + 67 | 68 | # add background mask 69 | geom_tile(data=blank_tile, aes(x=x, y=y), fill= 'grey90') + 70 | geom_tile(data=wetloss, aes(x=x, y=y, fill=layer)) + 71 | 72 | coord_equal() + 73 | gif_map_theme() + 74 | scale_fill_distiller(palette='OrRd', direction=1, limits=c(0,1)) + 75 | theme(legend.position=c(0.1, 0.4)) 76 | 77 | 78 | 79 | 80 | #grid.arrange(wet_plt, cropland_plt, wetloss_plt, timeline, ncol=1, heights = c(1,1,1,0.1)) 81 | 82 | post_1700_maps <- arrangeGrob(wet_plt, cropland_plt, wetloss_plt, nrow=1) 83 | 84 | rm(wet_plt, cropland_plt, wetloss_plt) 85 | -------------------------------------------------------------------------------- /data_proc/hist_cases/make_polygon_histcases_nat_subnat.r: -------------------------------------------------------------------------------- 1 | 2 | # get function that gets polygons 3 | source("./scripts/data_proc/fcn/fcn_get_polygons_for_histcases.r") 4 | 5 | 6 | # Read formatted histcases from data file 7 | histcases <- read.csv(#'./output/results/histcases_mod/historic_cases_wetland_loss_mod.csv', 8 | './output/results/histcases_loss_v2_manmod_p.csv', 9 | stringsAsFactors = F) %>% 10 | # add field of adminitrative code 11 | mutate(adm0_a3 = country_code) 12 | 13 | 14 | # split histcases into national / subnational 15 | histcases_nat <- histcases %>% filter(is.na(region)) 16 | histcases_subnat <- histcases %>% filter(!is.na(region)) 17 | 18 | 19 | # get country shpfiles 20 | countries_shp <- readOGR("./data/nat_earth", "ne_110m_admin_0_countries") 21 | # get subnational unit shpfiles 22 | subnat_shp <- readOGR("./data/nat_earth", "ne_10m_admin_1_states_provinces") 23 | # remove region column to avoid conflict with histcase's region column 24 | subnat_shp <- subset(subnat_shp, select = -c(region) ) 25 | 26 | 27 | # select the polygons for each 28 | h_c_shp <- get_histcase_shapefile(histcases_nat, countries_shp, "adm0_a3", "adm0_a3", "rec_id") 29 | h_s_shp <- get_histcase_shapefile(histcases_subnat, subnat_shp, "name", "region", "rec_id") 30 | 31 | # rename some columns, so the colnames are same in country and subnat 32 | names(h_s_shp)[85] <- 'adm0_a3' 33 | names(h_s_shp)[1] <- 'region' 34 | 35 | 36 | 37 | 38 | # set list of columns to keep 39 | cols <- c('rec_id','adm0_a3','country','region','yr_start', 40 | 'yr_end',"rate_loss_km2_yr","perc_change_numeric", "perc_change_per_yr") 41 | 42 | # select columns to keep from the polygons 43 | h_c_shp <- h_c_shp[c(cols)] 44 | h_s_shp <- h_s_shp[c(cols)] 45 | 46 | # combine country and sub_nat objects 47 | histcases_shp <- rbind(h_c_shp, h_s_shp, makeUniqueIDs = TRUE) 48 | 49 | 50 | 51 | # SAVE OUTPUT POLYGONS ========================================================= 52 | 53 | # save as shapefile 54 | writeOGR(histcases_shp, dsn="./output/results/histcases/histcases_poly_mod_sep2019.shp", 55 | layer = 'historical_cases_poly', driver="ESRI Shapefile") 56 | 57 | # save as rds 58 | saveRDS(histcases_shp, "./output/results/histcases/histcases_poly_mod_sep2019.rds") 59 | 60 | 61 | # delete objects 62 | rm(histcases, histcases_nat, histcases_subnat, countries_shp, 63 | subnat_shp, h_c_shp, h_s_shp, histcases_shp) 64 | 65 | 66 | -------------------------------------------------------------------------------- /plots/artif_drainage/old/map_artif_drainage_stats.r: -------------------------------------------------------------------------------- 1 | # description: map drainage as percentage of country -------------------------- 2 | #==============================================================================# 3 | 4 | # read drainage shp 5 | #artdrain_ag_nat <- readRDS("./output/results/artif_drainage/artdrain_ag_nat.rds") 6 | artdrain_ag_natpoly <- readRDS("./output/results/artif_drainage/artdrain_nat_poly_wcroparea.rds") 7 | 8 | # Fortify & reproject polygons to ggplot-mappable df 9 | artdrain_ag_natpoly_df <- prep_poly_into_robin_map_wdata(artdrain_ag_natpoly) 10 | 11 | 12 | #==============================================================================# 13 | # make ggplot map -------------------------------------------- 14 | #==============================================================================# 15 | 16 | map <- 17 | 18 | ggplot(bbox_robin_df, aes(long, lat)) + 19 | 20 | # add background country polygons 21 | geom_polygon(data=countries_robin_df, 22 | aes(long, lat, group=group), fill='grey85') + 23 | 24 | # add data countries 25 | geom_polygon(data=artdrain_ag_natpoly_df, 26 | aes(long, lat, group=group, fill= fraction_drained*100), alpha=1) + 27 | 28 | 29 | # add country outline 30 | geom_path(data=countries_robin_df, aes(long, lat, group=group), color='white', size=0.1) + 31 | 32 | # Add outline bounding box 33 | geom_path(data=bbox_robin_df, aes(long, lat, group=group), color="black", size=0.2) + 34 | 35 | 36 | coord_equal() + theme_fig() + 37 | scale_fill_distiller(type="seq", direction=1, palette = "Blues") + 38 | theme(legend.position="top") + 39 | theme(plot.margin = unit(c(-2,-3,-2,-10), "mm")) + 40 | guides(fill = guide_colorbar(barwidth = 14, barheight = 0.5)) + 41 | 42 | labs(fill = "Cropland % drained") 43 | 44 | 45 | map 46 | 47 | 48 | 49 | ### save figure to file ================================================== 50 | 51 | ggsave('./output/figures/artif_drainage/map/perc_drained_cropland.png', 52 | width=178, height=90, dpi=600, units="mm")#, type = "cairo-png") 53 | dev.off() 54 | 55 | 56 | 57 | 58 | 59 | 60 | # test; why do i lose some unique drainage data? 61 | # the ..._df suffux means that it is foritified as df for plotting 62 | # u <- artdrain_ag_nat@data[,c("rec_id","iso_a3","year","drained_area_tot")] 63 | # sort(unique(u$artdrain_nat_df)) 64 | # unique(artdrain_ag_nat_df$drained_area_tot) 65 | 66 | #artdrain_ag_nat_df <- artdrain_ag_nat_df[,c("country_name","decade","drained_area_tot","cropland")] -------------------------------------------------------------------------------- /plots/wetloss_drivers/stacked_area_plot_global_wetloss_since1700.r: -------------------------------------------------------------------------------- 1 | 2 | source("./plots/themes/line_plot_theme.R") 3 | 4 | # write summed area of wetloss, remaining, etc... to output 5 | wetchimp_wetloss <- read.csv('../../output/results/global_sum_wetloss_wetchimp.csv') %>% 6 | mutate(remwet_perc_from6000BC = tot_remwet_Mkm2/tot_wet_Mkm2) %>% 7 | gather(var, dat, tot_wet_Mkm2:remwet_perc_from6000BC) 8 | 9 | 10 | globsums<- wetchimp_wetloss 11 | 12 | # set year breaks 13 | mybreaks <- seq(1700, 2000, 100) 14 | 15 | 16 | # make area plot 17 | area_wetloss_plot <- 18 | ggplot() + 19 | geom_area(data=subset(globsums, var %in% c("tot_remwet_Mkm2","tot_wetloss_Mkm2","tot_convtorice_Mkm2")), 20 | aes(x=year, y=dat, fill=var)) + 21 | 22 | geom_line(data=subset(globsums, var=='tot_crop_Mkm2'), 23 | aes(x=year, y=dat), color='black', size=1) + 24 | 25 | geom_line(data=subset(globsums, var=='tot_ir_rice_Mkm2'), 26 | aes(x=year, y=dat), size=1 , color='pink') + 27 | 28 | xlab("Year") + ylab("Area (Mkm2)") + 29 | scale_x_continuous(expand=c(0,0), breaks=mybreaks, labels=mybreaks)+#, limits = c(-6000, max(mybreaks))) + 30 | scale_y_continuous(expand=c(0,0)) + 31 | scale_colour_manual(name = 'Human Land Cover', 32 | values =c('black'='black','pink'='pink'), labels = c('cropland','irrigated rice')) + 33 | 34 | facet_wrap(~name) + 35 | line_plot_theme#, scales="free") 36 | 37 | area_wetloss_plot 38 | 39 | 40 | 41 | 42 | 43 | # make area plot 44 | wetloss_plot <- 45 | ggplot() + 46 | # geom_area(data=subset(globsums, var %in% c("tot_remwet_Mkm2","tot_wetloss_Mkm2","tot_convtorice_Mkm2")), 47 | # aes(x=year, y=dat, fill=var)) + 48 | 49 | geom_line(data=subset(globsums, var=='remwet_perc_from6000BC'), 50 | aes(x=year, y=dat, color=name), size=1) + 51 | 52 | # geom_line(data=subset(globsums, var=='tot_ir_rice_Mkm2'), 53 | # aes(x=year, y=dat), size=1 , color='pink') + 54 | 55 | xlab("Year") + ylab("Area (Mkm2)") + 56 | scale_x_continuous(expand=c(0,0), breaks=mybreaks, labels=mybreaks) + 57 | scale_y_continuous(expand=c(0,0), limits = c(0, 1)) + 58 | # scale_colour_manual(name = 'Human Land Cover', 59 | # values =c('black'='black','pink'='pink'), labels = c('cropland','irrigated rice')) + 60 | 61 | #facet_wrap(~name) + 62 | line_plot_theme#, scales="free") 63 | wetloss_plot 64 | -------------------------------------------------------------------------------- /plots/lineplot/old/line_plot_stocker_sum_wet_peat_area.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | # open connection to netcdf file 4 | t <- './data/nat_wetland_map/trace21_129.cdf' 5 | nc <- nc_open(t) 6 | 7 | # get time labels 8 | year <- c(unique(ncvar_get( nc, attributes(nc$dim)$names[4]))) 9 | year_sub <- seq(1, length(year), 1) # subsample the timeseries 10 | 11 | # subset specific variables 12 | nc_inund <- ncvar_get(nc, 'inund') #subset to inund var 13 | gridarea <- ncvar_get(nc, 'area') #subset to area var 14 | nc_luarea <- ncvar_get(nc, 'lu_area') #subset to area var 15 | 16 | 17 | # create empty df for output 18 | output_df <- data.frame(year=numeric(), 19 | sum_inund_Mkm2=numeric(), 20 | sum_peatland_Mkm2=numeric()) 21 | 22 | 23 | # loop through subset of years 24 | for (y in year_sub){ 25 | 26 | # get peatland area 27 | peatland_f <- nc_luarea[ , ,2,y] # 3rd dimension is lu type: k=2 peatlands 28 | peatland_a <- gridarea * peatland_f # get inundated area 29 | sum_peatland_Mkm2 <- sum(peatland_a, na.rm = TRUE) * 10^-6 * 10^-6 # sum to Mkm2 30 | 31 | # get inund area 32 | inund_f <- apply(nc_inund[ , , , y], c(1,2), max) # get elementwise max value 33 | inund_a <- gridarea * inund_f # get inundated area 34 | sum_inund_Mkm2 <- sum(inund_a, na.rm = TRUE) * 10^-6 * 10^-6 # sum to Mkm2 35 | 36 | 37 | # append sums to df 38 | output_df <- rbind(output_df, 39 | data.frame(year = year[y], 40 | sum_inund_Mkm2 = sum_inund_Mkm2, 41 | sum_peatland_Mkm2= sum_peatland_Mkm2)) 42 | } 43 | 44 | # convert output df to long format 45 | output_df <- output_df %>% 46 | gather(type, value, sum_inund_Mkm2:sum_peatland_Mkm2) %>% 47 | mutate(type= ifelse(type=='sum_inund_Mkm2','Max monthly inund.', 'Peatland')) 48 | 49 | 50 | 51 | 52 | # line plot wet area & peatland over 10k ======================================= 53 | ggplot(output_df) + 54 | geom_line(aes(x=year, y=value, color=type), size=0.3) + 55 | 56 | ylab('Global area (km2 10^6)') + 57 | scale_x_continuous(limits=c(-10000, 2000), expand=c(0,0)) + 58 | scale_y_continuous(limits=c(0,12), expand=c(0,0)) + 59 | 60 | theme_bw() + # declare theme elements 61 | line_plot_theme 62 | 63 | 64 | 65 | 66 | # save figure to file 67 | ggsave('../../output/figs/lpxdytop_global_inund_peatland_holocene.png', 68 | width=87, height=70, dpi=600, units="mm", type = "cairo-png") 69 | dev.off() 70 | 71 | 72 | -------------------------------------------------------------------------------- /plots/map/get_wetindex_points.r: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------# 2 | #/ Read in WET database ------ 3 | wetdb <- read.csv("../data/WETindex/WET_database_2017_FINAL_151217_geo.csv", 4 | stringsAsFactors = F) %>% 5 | 6 | # select columns that are unique per SITE, not different years of data 7 | dplyr::select(record_ID, WET.update, Country, Country.scale., Continent.scale., 8 | Ramsar.region, WET.Subregion, Locality, Latitude, Longitude, 9 | Land.cover..from.paper., Natural.artificial, 10 | Ramsar.type, Ramsar.category, WET.classification, 11 | WETclass_binomial, Binomial, Management, Discusses.drivers., 12 | Drivers, Indicates.what.transition.was.from.to., Transition.to...) %>% 13 | unique() 14 | 15 | 16 | wetdb$Latitude <- as.numeric(wetdb$Latitude) 17 | wetdb$Longitude <- as.numeric(wetdb$Longitude) 18 | 19 | 20 | # /----------------------------------------------------------------------------# 21 | #/ Split DB into point and polygon locations ------- 22 | wetdb_pts <- wetdb %>% 23 | 24 | filter(Country.scale. != "yes") %>% 25 | 26 | # convert coordinates to numeric values 27 | mutate(Longitude = as.numeric(Longitude), 28 | Latitude = as.numeric(Latitude)) %>% 29 | 30 | # remove blank coordinates 31 | filter(!is.na(Longitude) & !is.na(Latitude)) %>% 32 | 33 | mutate(Longitude=as.numeric(Longitude), 34 | Latitude=as.numeric(Latitude)) %>% 35 | 36 | # correct erroneous coordinates 37 | mutate(Longitude=ifelse(Longitude>180 | Longitude< -180, Longitude/10, Longitude), 38 | Latitude=ifelse(Latitude>90 | Latitude< -90, Latitude/10, Latitude)) 39 | 40 | 41 | 42 | # /----------------------------------------------------------------------------# 43 | #/ 44 | wetindex_pts <- SpatialPointsDataFrame(coords=wetdb_pts[c("Longitude","Latitude")], data=wetdb_pts) 45 | crs(wetindex_pts) <- CRS("+proj=longlat +datum=WGS84") 46 | wetindex_pts_robin <- spTransform(wetindex_pts, CRS("+proj=robin")) 47 | wetindex_pts_robin_df <- data.frame(wetindex_pts_robin) 48 | 49 | 50 | # filter to inland & non-man-made wetlands 51 | wetindex_pts_robin_df <- wetindex_pts_robin_df %>% 52 | # mutate(wetloss_perc_1700to1970 <- wetloss_perc_1700to1970 * -1) %>% 53 | filter(Ramsar.type != 'Human-made') %>% 54 | filter(! Land.cover..from.paper. %in% c('Seagrass','Mangroves', 'Oyster reef')) %>% 55 | dplyr::select(-record_ID) 56 | 57 | 58 | -------------------------------------------------------------------------------- /plots/fig3abc/fig3a_2021.r: -------------------------------------------------------------------------------- 1 | # Get Davidson data 2 | source('./plots/map/get_davidson_histcase_polygons.r') 3 | # Get WET index sites 4 | source('./plots/map/get_wetindex_points.r') 5 | 6 | 7 | 8 | 9 | # /----------------------------------------------------------------------------# 10 | #/ MAP HISTORICAL CASES COUNTRIES --------- 11 | 12 | library(ggnewscale) 13 | 14 | fig3a_histcase_map <- 15 | 16 | ggplot() + 17 | 18 | # add background country polygons 19 | geom_polygon(data=countries_robin_df, aes(long, lat, group=group), fill='grey85') + 20 | 21 | # add countries with wetloss data; colored by value 22 | # geom_polygon(data=histcases_poly_df, aes(long, lat, group=group), alpha=1, fill="blue") + 23 | geom_polygon(data=histcases_poly_df, aes(long, lat, group=group, fill='Davidson 2014')) + 24 | scale_fill_manual(values='blue', name='') + 25 | 26 | # add outline of country with data 27 | geom_path(data=histcases_poly_df, aes(long, lat, group=group), color='white', size=0.1) + 28 | 29 | # Wet Index points 30 | geom_point(data=wetindex_pts_robin_df, aes(Longitude.1, Latitude.1, 31 | color='Wetland Extent\nTrends (WET) Index\n(Darrah et al. 2019)'), size=0.02) + 32 | scale_color_manual(values='red', name='') + 33 | 34 | # Add outline bounding box 35 | geom_path(data=bbox_robin_df, aes(long, lat, group=group), color="black", size=0.25) + 36 | # scale_fill_distiller(palette = 3) + 37 | 38 | # new_scale_fill() + 39 | 40 | ## Make fake layer for legend 41 | scale_y_continuous(limits=c(-6600000, 8953595)) + 42 | coord_equal() + theme_fig() + 43 | theme(legend.position=c(0., 0.45), 44 | # legend.direction = 'vertical', 45 | legend.box = "vertical", 46 | legend.key.size = unit(.5, 'cm'), 47 | legend.background = element_rect(fill=NA, 48 | size=0.2, linetype="solid", 49 | colour ="white")) + # "top" 50 | theme(plot.margin = unit(c(-2,-5,-2, 4), "mm")) 51 | 52 | 53 | fig3a_histcase_map 54 | 55 | 56 | 57 | # # /---------------------------------------------------------------- 58 | # #/ Save figure to file ----- 59 | # ggsave('./output/figures/hist_cases/map_histcase_davidson_wetindex.png', 60 | # width=87, height=60, dpi=800, units="mm", type = "cairo-png") 61 | # dev.off() 62 | 63 | 64 | 65 | 66 | # delete objects 67 | # rm(histcases_poly, histcases_poly_df, histcases_poly_robin, 68 | # countries_robin_df, bbox_robin_df, map) 69 | -------------------------------------------------------------------------------- /data_proc/natwet/old/make_ensemble_fromoverlays_w6000bc.r: -------------------------------------------------------------------------------- 1 | # process ensemble 2 | 3 | 4 | 5 | # read overlay output of diff resolutions 6 | dir <- './output/results/wetloss/sum/' 7 | wetloss_all_0.5 <- read.csv(paste0(dir, 'global_sum_wetloss_wetchimp_0.5_3subgrid.csv')) 8 | wetloss_all_1.0 <- read.csv(paste0(dir, 'global_sum_wetloss_wetchimp_3subgrid.csv')) 9 | wetloss_all_2.5 <- read.csv(paste0(dir, 'global_sum_wetloss_2.5_3subgrid.csv')) 10 | 11 | # fill column of resolution 12 | wetloss_all_0.5$res <- 0.5 13 | wetloss_all_1.0$res <- 1.0 14 | wetloss_all_2.5$res <- 2.5 15 | 16 | # combine into one df 17 | wetloss_all <- bind_rows(wetloss_all_0.5, wetloss_all_1.0, wetloss_all_2.5) 18 | 19 | # remove temps 20 | rm(wetloss_all_0.5, wetloss_all_1.0, wetloss_all_2.5) 21 | 22 | 23 | 24 | # prepare remwer data ========================================================= 25 | 26 | # get remaining wetland area in 1700, to calc remwet percent from then 27 | wetarea_in1700 <- wetloss_all %>% 28 | 29 | # keep years after 1700 30 | filter(year == 1700) %>% 31 | # select columns 32 | dplyr::select(name, overlap, tot_remwet_Mkm2) %>% 33 | # rename column to reflect its only in 1700 34 | rename(tot_remwet_Mkm2_in1700 = tot_remwet_Mkm2) 35 | 36 | 37 | # prep data 38 | wetloss_all<- wetloss_all %>% 39 | 40 | # remove years not ending in 0 ( to remove 2001-2009) 41 | filter(year %% 10 ==0) %>% 42 | 43 | # join the remwet in 1700 and calc percent remaining area since then 44 | left_join(., wetarea_in1700, by=c("name", "overlap")) %>% 45 | 46 | # calculate the % from the 1700 wetcover 47 | mutate(remwet_prc_since1700 = tot_remwet_Mkm2 / tot_remwet_Mkm2_in1700 * 100) 48 | 49 | 50 | 51 | 52 | # calculate the ensemble min, mean, max 53 | wetloss_ensemble_prc <- wetloss_all %>% 54 | 55 | # remove non-numeric columns from the summarize 56 | dplyr::select(-one_of(c("X","name", "overlap","res"))) %>% 57 | # group by year 58 | mutate(year = as.character(year)) %>% 59 | group_by(year) %>% 60 | # calculate the summary values 61 | summarise_all(.funs=c('mean', 'min', 'max')) %>% 62 | # return year to a numeric 63 | mutate(year= as.numeric(year)) 64 | 65 | 66 | 67 | # write outputs 68 | write.csv(wetloss_all, "./output/results/wetloss/sum/wetloss_all_area.csv") 69 | write.csv(wetloss_ensemble_prc, "./output/results/wetloss/sum/wetloss_ensemble_prc.csv") 70 | 71 | 72 | 73 | # delete objects 74 | rm(wetloss_all, wetarea_in1700, wetloss_ensemble_prc) 75 | 76 | -------------------------------------------------------------------------------- /plots/lineplot/old/line_plot_remwet_global.R: -------------------------------------------------------------------------------- 1 | 2 | wetloss_all <- read.csv("./output/results/wetloss/wetloss_all") 3 | 4 | wetloss_all_mean <- wetloss_all %>% 5 | group_by(year) %>% 6 | summarize(mean_tot_remwet_Mkm2 = mean(tot_remwet_Mkm2)) 7 | 8 | 9 | max(wetloss_all_mean$mean_tot_remwet_Mkm2) - min(wetloss_all_mean$mean_tot_remwet_Mkm2) 10 | 11 | 12 | # RemWet AREA Mkm^2 plot ====================================================== 13 | ggplot(wetloss_all) + 14 | geom_line(aes(x=year, y= tot_remwet_Mkm2, color=name, 15 | group=paste0(name, overlap)), size=0.3) + 16 | geom_point(aes(x=year, y= tot_remwet_Mkm2, color=name, shape=overlap), 17 | fill='white', size=0.6) + 18 | 19 | geom_line(data=wetloss_all_mean, 20 | aes(x=year, y= mean_tot_remwet_Mkm2), 21 | color="black", size=0.3) + 22 | 23 | 24 | # axis labels 25 | labs(x="", y=expression(Remaining~wetland~area~(km^{2}))) + 26 | scale_shape_manual(values=c(21, 22, 24)) + 27 | line_plot_theme 28 | 29 | 30 | 31 | # save figure to file 32 | ggsave('./output/figures/remwet_global_area_allcomb_since1700.png', 33 | width=178, height=90, dpi=600, units="mm", type = "cairo-png") 34 | dev.off() 35 | 36 | 37 | 38 | 39 | 40 | 41 | # REMWET pERCENTAGE PLOT ====================================================== 42 | 43 | # read davison data 44 | f<-"./data/hist_records/source_specific/davidson_2014/davidson2014_global_percent_wetloss.csv" 45 | davidson2014 <- read.csv(f, stringsAsFactors = F) %>% filter(!is.na(percentage_fromtext_nfig4)) 46 | 47 | 48 | 49 | ggplot(wetloss_all) + 50 | 51 | geom_line(aes(x=year, y= remwet_prc_since1700, color=name, 52 | group=paste0(name, overlap))) + 53 | geom_point(aes(x=year, y= remwet_prc_since1700, color=name, shape=overlap), fill='white') + 54 | 55 | 56 | geom_line(data=davidson2014, aes(x=ï..year_start, y= percentage_fromtext_nfig4), 57 | color='black', size=0.3) + 58 | 59 | geom_point(data=davidson2014, aes(x=ï..year_start, y= percentage_fromtext_nfig4), 60 | color='black', size=0.6) + 61 | 62 | # empty point shape 63 | scale_shape_manual(values=c(21, 22, 24)) + 64 | line_plot_theme 65 | 66 | 67 | 68 | # save figure to file 69 | ggsave('./output/figures/remwet_global_percent_allcomb_since1700.png', 70 | width=178, height=90, dpi=600, units="mm", type = "cairo-png") 71 | dev.off() 72 | 73 | 74 | # delete objects 75 | rm(f, davidson2014, wetloss_all) 76 | -------------------------------------------------------------------------------- /data_proc/artif_drainage/old/get_cropland_in_drain_countries.r: -------------------------------------------------------------------------------- 1 | # Description: Extracts the agriculture area from HYDE in countries with drainage data 2 | 3 | 4 | 5 | # get hyde years 6 | hyde_yrs <- readRDS("./output/results/hyde_yrs/hyde_yrs_since1700.rds") 7 | 8 | # get polygon of countries w drainage 9 | drain_poly <- readRDS("./output/results/artif_drainage/artdrain_ag_nat.rds") 10 | 11 | ### read hyde ncdf at teh 0.5 resolution 12 | h <- './output/results/hyde_resampled/hyde32_0.5.nc' 13 | hyde <- nc_open(h) 14 | hyde_yrs <- sort(hyde$dim$time$vals) 15 | hyde_indx <- match(hyde_yrs, hyde$dim$time$vals) 16 | 17 | 18 | #==============================================================================# 19 | ### Extract cropland area ---------------------------------------------- 20 | #==============================================================================# 21 | 22 | # this could be modified to also extract forest/peatlands... later 23 | source("./scripts/r/data_proc/fcn/get_hydecroparea_in_polygons.r") 24 | 25 | # run function that loops through polygons 26 | area_extract <- get_raster_closest_yr(artdrain_ag_nat) 27 | 28 | # select a few columns (to avoid the .x & .y duplicated columns) 29 | area_extract <- area_extract[,c("rec_id","cropland","closest_hyde_year")] 30 | 31 | # merge new columns to polygons 32 | cols_to_keep <- names(drain_poly)[c(1,66:76)] 33 | drain_poly@data <- drain_poly@data[,cols_to_keep] 34 | drain_poly <- merge(drain_poly, area_extract, by="rec_id") 35 | 36 | 37 | #==============================================================================# 38 | ### CALCULATE PERCENTAGE ----------------------------------------------- 39 | #==============================================================================# 40 | 41 | # calculate percentage of cropla drained 42 | drain_poly$fraction_drained <- (drain_poly$drained_area_tot) / drain_poly$cropland 43 | 44 | drain_poly[drain_poly$fraction_drained>1,"fraction_drained"] <- 1 45 | 46 | 47 | #==============================================================================# 48 | # Save output --------------------------------------------------------------- 49 | #==============================================================================# 50 | 51 | # write out dataframe 52 | saveRDS(area_extract, "./output/results/artif_drainage/artdrain_nat_wcroparea.rds") 53 | 54 | # write out dataframe 55 | saveRDS(drain_poly, "./output/results/artif_drainage/artdrain_nat_poly_wcroparea.rds") 56 | 57 | # delete variables 58 | rm(hyde_yrs, drain_poly, h, hyde, hyde_indx, area_extract) 59 | -------------------------------------------------------------------------------- /data_proc/hist_cases/prep_peat_hist_cases_2021.r: -------------------------------------------------------------------------------- 1 | # Prep peatland histcases 2 | 3 | 4 | # /----------------------------------------------------------------- 5 | #/ PEATLANDS 6 | # cs_peat = 1 7 | # if (cs_peat==1){} 8 | 9 | # read data hist cases Shapefile 10 | hist_peat_poly <- readOGR("../data/hist_records/histcases_peat_simp.shp" , GDAL1_integer64_policy=T) 11 | 12 | # remove records without a paired source_id 13 | hist_peat_poly <- subset(hist_peat_poly, rec_id != 0) 14 | 15 | 16 | # /----------------------------------------------------------------------------# 17 | #/ read the data table; manually curated 18 | hist_data <- 19 | read.csv("../data/hist_records/histcases_2021.csv") %>% 20 | dplyr::select(-c(full.citation, Comment, ef_comment)) 21 | 22 | 23 | # /----------------------------------------------------------------------------# 24 | #/ join poly and data on id 25 | hist_peat <- merge(hist_peat_poly, hist_data, by.x="rec_id", by.y="rec_id") 26 | 27 | # exclude polygons without a start date 28 | hist_peat <- hist_peat[!is.na(hist_peat$yr_start),] 29 | 30 | # Calculate area of polygons from m^2 to million km2 31 | hist_peat$areapoly_mkm2 <- areaPolygon(hist_peat) /10^5 /10^6 32 | 33 | # Get area df 34 | histpeat_area <- 35 | hist_peat@data %>% 36 | dplyr::select(rec_id, areapoly_mkm2) %>% 37 | group_by(rec_id) %>% 38 | summarize(areapoly_mkm2= sum(areapoly_mkm2, na.rm=T)) 39 | 40 | 41 | 42 | # /----------------------------------------------------------------------------# 43 | #/ Convert histcases to raster_df 44 | hist_peat_recid = fasterize(st_as_sf(hist_peat), template, field='rec_id', fun='last') 45 | hist_peat_df <- raster2df(hist_peat_recid) 46 | names(hist_peat_df) <- c('rec_id','x','y') 47 | hist_peat_df <- left_join(maxlncr_df_xy, hist_peat_df, by=c('x','y')) 48 | 49 | 50 | 51 | # /----------------------------------------------------------------------------# 52 | #/ fix to correct continent column for African cases 53 | hist_peat_df <- 54 | left_join(hist_peat_df, hist_data, by=c('rec_id'='rec_id')) %>% 55 | left_join(., histpeat_area, by='rec_id') %>% 56 | mutate(country_code = countrycode(country, 'country.name', 'iso3c')) %>% 57 | mutate(continent = countrycode(country, 'country.name', 'continent')) %>% 58 | # Round years to decade 59 | mutate(yr_start_rnd = round(yr_start, -1), yr_end_rnd = round(yr_end, -1)) %>% 60 | mutate(yr_end_rnd = ifelse(yr_end_rnd==2010, 2000, yr_end_rnd)) 61 | 62 | 63 | # Save raster df 64 | write.csv(hist_peat_df, "../output/results/histcases/histpeat_wdata_2021_rasterdf.csv", row.names=FALSE) 65 | 66 | 67 | 68 | -------------------------------------------------------------------------------- /data_proc/fit/mcmc_init/init_drainage_stats_subnat.r: -------------------------------------------------------------------------------- 1 | # /----------------------------------------------------------------------------# 2 | #/ Read drained area time-series; interpolated from national statistics. 3 | 4 | # d = "../output/results/artif_drainage/drained_wetcult_sigmoid_interp_comb_nov2020.csv" 5 | d = "../output/results/artif_drainage/drained_wetcult_sigmoid_interp_comb_march2021.csv" 6 | 7 | 8 | drainage <- read.csv(d) %>% 9 | filter(!is.na(country_name)) %>% 10 | mutate(iso_a3 = countrycode(country_name,'country.name','iso3c',warn=F)) %>% 11 | # dplyr::select(-c(X)) %>% 12 | unique() %>% 13 | filter(!is.na(pred_drained)) 14 | 15 | # REMOVE DUPLICATE ROWS - THIS SHOULD HAPPEN UPSTREAM OF HERE !!! 16 | drainage <- drainage[!duplicated(drainage[,c('year','country_name','type')]),] 17 | 18 | 19 | 20 | # /----------------------------------------------------------------------------# 21 | #/ READ SUBNAT 22 | drainage_subnat <- read.csv('../data/artif_drained/all_drain_stat_comb_v7_subnatperc.csv') 23 | # glimpse(drainage_subnat) 24 | 25 | 26 | # /----------------------------------------------------------------------------# 27 | #/ JOIN NAT & SUBNAT DATA 28 | # Join subnat % of drainage to National Area drained 29 | drainage <- left_join(drainage, drainage_subnat, by=c('iso_a3', 'type')) %>% 30 | # calculate subnational drainage 31 | mutate(pred_drained = ifelse(!is.na(perc_subnat_drain), pred_drained * perc_subnat_drain, pred_drained)) %>% 32 | # mutate(pred_drained_subnat = ifelse(!is.na(perc_subnat_drain), pred_drained * perc_subnat_drain, pred_drained)) %>% 33 | # Remove rows without a numeric country code 34 | filter(!is.na(iso_a3)) %>% 35 | filter(!is.na(pred_drained)) %>% 36 | 37 | # TEMP FIX - THERE ARE SUBNAT DUPLICATES IN THE DRAINAGE STATS DATABASE 38 | group_by(year, country_name, type, continent, iso_a3, country, HASC_1, subnat_id, nat_id) %>% 39 | dplyr::summarise(pred_drained = mean(pred_drained, na.rm=T)) %>% 40 | # pred_drained_subnat = mean(pred_drained_subnat, na.rm=T)) %>% 41 | ungroup() 42 | 43 | 44 | 45 | # /----------------------------------------------------------------------------# 46 | #/ Rename types so it matches object names 47 | drainage[drainage$type=='Forestry', 'type'] <- 'forestry' 48 | drainage[drainage$type=='Peat Extraction', 'type'] <- 'peatextr' 49 | drainage[drainage$type=='Cropland', 'type'] <- 'cropland' 50 | drainage[drainage$type=='Wetland Cultiv.', 'type'] <- 'wetcultiv' 51 | 52 | -------------------------------------------------------------------------------- /plots/map/old/ggplot_wetlossmap.R: -------------------------------------------------------------------------------- 1 | library(gridExtra) 2 | library(raster) 3 | library(rasterVis) 4 | library(latticeExtra) 5 | library(grid) 6 | 7 | # rename years 8 | if(yr<0){ 9 | yr_label <- paste0(yr*-1, 'BC') 10 | } else { 11 | yr_label <- paste0(yr, 'AD') 12 | } 13 | 14 | 15 | 16 | # plot nat wet ================================================================= 17 | 18 | # # percentage wetland 19 | wet <- as(wet, "SpatialPixelsDataFrame") 20 | wet <- as.data.frame(wet) 21 | 22 | # glacier 23 | glacier <- as(g, "SpatialPixelsDataFrame") 24 | glacier <- as.data.frame(glacier) 25 | 26 | # map wetland 27 | wet_plt <- ggplot() + 28 | geom_tile(data=glacier, aes(x=x, y=y), fill='grey80') + 29 | # add background mask 30 | geom_tile(data=wet, aes(x=x, y=y, fill=layer)) + 31 | coord_equal() + 32 | scale_fill_distiller(palette='Blues', direction=1, limits=c(0,1)) + 33 | gif_map_theme() 34 | 35 | 36 | # plot cropland ================================================================ 37 | 38 | # cropland fraction 39 | c_f <- as(c/a, "SpatialPixelsDataFrame") 40 | c_f <- as.data.frame(c_f) 41 | c_f2 <- c_f[c_f$layer > 0,] 42 | 43 | cropland_plt <- ggplot() + 44 | geom_tile(data=glacier, aes(x=x, y=y), fill='grey80') + 45 | # add background mask 46 | geom_tile(data=c_f2, aes(x=x, y=y, fill=layer)) + 47 | 48 | coord_equal() + 49 | scale_fill_distiller(palette='YlGn', direction=1, limits=c(0,1)) + 50 | gif_map_theme() 51 | 52 | 53 | 54 | # plot wetloss ================================================================ 55 | 56 | # cropland fraction 57 | wetloss <- as(wetloss_f, "SpatialPixelsDataFrame") 58 | wetloss <- as.data.frame(wetloss) 59 | wetloss <- wetloss[wetloss$layer > 0,] 60 | 61 | 62 | wetloss_plt <- ggplot() + 63 | geom_tile(data=glacier, aes(x=x, y=y), fill='grey80') + 64 | # add background mask 65 | geom_tile(data=wetloss, aes(x=x, y=y, fill=layer)) + 66 | 67 | coord_equal() + 68 | scale_fill_distiller(palette='OrRd', direction=1, limits=c(0,1)) + 69 | gif_map_theme() 70 | 71 | 72 | 73 | 74 | # arrange into a grid ========================================================== 75 | #grid.arrange(wet_plt, cropland_plt, wetloss_plt, timeline, ncol=1, heights = c(1,1,1,0.1)) 76 | # y <- arrangeGrob(p1, p2, ncol = 1) 77 | # grid.draw(y) 78 | 79 | library(gridExtra) 80 | pre_1700_maps <- arrangeGrob(wet_plt, cropland_plt, wetloss_plt, nrow=1) 81 | 82 | -------------------------------------------------------------------------------- /plots/fig2abcd/fig1b_2022_preswet.r: -------------------------------------------------------------------------------- 1 | 2 | 3 | # # Filter wetloss grid to 4 | # grid_remwet_perc_robin_df <- WGSraster2dfROBIN(r) %>% 5 | # # Percentage loss above a certain % 6 | # # filter(cumloss_perc > 1) %>% # map_cumullossperc_floor) %>% 7 | # # Where pixels had originally >5% wetland 8 | # filter(Fwet1700 * 100 > 5) # map_Fwet1700_floor) 9 | # 10 | 11 | 12 | # Get wetland in 1700 13 | # Fwet1700_r <- r[[2]] 14 | 15 | # plot(r_wet1700) 16 | 17 | # Get preswet 18 | preswet <- preswet_max_stack[[p_i]] 19 | preswet <- preswet / area(preswet) * 100 20 | 21 | 22 | # Apply extent from raster to preswet raster 23 | crs(Fwet1700_r) <- crs(preswet) 24 | # preswet <-setExtent(preswet, extent(r_wet1700), keepres=TRUE) 25 | preswet <- crop(preswet, extent(Fwet1700_r)) 26 | 27 | 28 | # Stack preswet on raster of ('cumloss_perc', 'Fwet1700'))]) 29 | fig1b_r <- stack(Fwet1700_r, preswet) 30 | names(fig1b_r) <- c('cumulloss_perc','Fwet1700', 'preswet') 31 | 32 | fig1b_df <- WGSraster2dfROBIN(fig1b_r) %>% 33 | mutate(perc_change = Fwet1700*100 - preswet) %>% 34 | filter(perc_change >= 1) 35 | 36 | # glimpse(fig1b_df) 37 | 38 | 39 | 40 | 41 | # /----------------------------------------------------------------------------# 42 | #/ FIG 1-A: BUT ONLY present WETLAND AREA 43 | 44 | 45 | fig2b_preswetonly_percchange <- 46 | 47 | ggplot()+ 48 | 49 | # countries background & outline 50 | geom_polygon(data=countries_robin_df, aes(long, lat, group=group), fill='grey90', color=NA, size=0.08) + 51 | 52 | # Coastline 53 | geom_path(data=coastsCoarse_robin_df, aes(long, lat, group=group), color='grey70', size=0.1) + 54 | 55 | # Add high wetland regions 56 | # geom_raster(data=preswet_df, aes(x=x, y=y, fill=Fpreswet)) + 57 | geom_raster(data=fig1b_df, aes(x=x, y=y, fill=perc_change)) + 58 | 59 | 60 | scale_fill_gradient(low='#99ccff', high='#00307A', #'#003d99', 61 | breaks=c(1, 25, 50, 75, 100), 62 | limits=c(1, 100)) + 63 | 64 | 65 | # Add outline bounding box 66 | geom_path(data=bbox_robin_df, aes(long, lat, group=group), color='black', size=0.08) + 67 | 68 | coord_equal() + theme_raster_map() + 69 | 70 | # 71 | guides(fill = guide_colorbar(nbin=10, raster=F, 72 | barheight = 0.4, barwidth=7, 73 | frame.colour=c('black'), frame.linewidth=0.7, 74 | ticks.colour='black', direction='horizontal', 75 | title = expression(paste('Wetland extent decline since 1700\n (% of cell)')))) + 76 | 77 | theme(legend.position = 'bottom', 78 | legend.direction = 'horizontal') 79 | 80 | fig2b_preswetonly_percchange 81 | -------------------------------------------------------------------------------- /data_proc/fit/mcmc_fit/run_finalmap_lh_pars.R: -------------------------------------------------------------------------------- 1 | # Description: This script uses output of MCMC, and produces final outputs 2 | # using fitted parameters. 3 | # It runs the same process as tht in the MCMC, but less optimized, and 4 | # this version saves outputs to disc (not kept in memory). 5 | 6 | 7 | 8 | # /----------------------------------------------------------------------------# 9 | #/ config 10 | cs_peat=0 # Include peatland histcases in comparison or not 11 | 12 | # Run config 13 | test_theta = 0 # use test theta values (of 3, 0.5, 5) 14 | null_theta = 0 # use null theta values (of 0,0,0) 15 | test_potwet = 0 # use testing potwet (combination of preswet #1 and simwet #4) ?dbl check numbers 16 | preswet_max = 1 # Use larger preswet area instead of mamax preswet 17 | update_potwet = 0 # whether to subtract drained area from potwet; !!! turning this off reduces need for expanding allowable & filling overlap 18 | save_all_output = 1 # Save all outputs for figures 2 & 3 19 | 20 | # Drain_distrib config 21 | fill_val = 10e-4 # Fill value for perc_overlap; influences balance between real LUoverlap and filled 22 | scale_allowable = 1 # Scale up allowable, for forestry and peat during redistribution loop 23 | expand_perc_overlap = 1 # Expand perc_overlap to every 24 | nb_repeats = 10 # Number of redistribution loops 25 | 26 | pars='avg' 27 | 28 | # /----------------------------------------------------------------------------# 29 | #/ CREATE EMPTY DF OUTPUTS ------- 30 | 31 | # /----------------------------------------------------------------------------# 32 | #/ GET LH PARAMETER RANGES ------- 33 | # pars_all <- read.csv('../output/results/fit/mcmc/parameters/pars_modMCMC_2021.csv') #v1 34 | pars_all <- read.csv('../output/results/fit/lh/parameters/pars_mean_lh_2021.csv') 35 | glimpse(pars_all) 36 | 37 | # INTIALIZE MODMCMC & MODFIT 38 | source('data_proc/overlay/initialize_prefitting.r', local=FALSE) 39 | 40 | # /----------------------------------------------------------------------------# 41 | #/ LOOP THROUGH FITTED PARAMETERS 42 | 43 | for (i in 1:nrow(pars_all)) { 44 | 45 | # Set parameters 46 | theta_rice = as.numeric(pars_all[i, 'theta_rice']) 47 | theta_pasture = as.numeric(pars_all[i, 'theta_pasture']) 48 | theta_urban = as.numeric(pars_all[i, 'theta_urban']) 49 | s_i = as.numeric(pars_all[i, 's_i']) 50 | p_i = as.numeric(pars_all[i, 'p_i']) 51 | 52 | 53 | # /--------------------------------------------------------------------------# 54 | #/.. Run the wetland loss mapping -------- 55 | source('data_proc/overlay/run_draindistrib_loop_jan2021.r', local=FALSE) 56 | 57 | } 58 | 59 | --------------------------------------------------------------------------------