Skip to content

Commit

Permalink
Merge pull request #1 from Deltares-research/wg-server
Browse files Browse the repository at this point in the history 
Wg server
  • Loading branch information
@tanerumit
tanerumit authored Feb 1, 2024
2 parents eb0b689 + 4cec844 commit 460583f
Show file tree
Hide file tree
Showing 5 changed files with 7,781 additions and 20,910 deletions.
1 change: 0 additions & 1 deletion DESCRIPTION
View file
Original file line number Diff line number Diff line change
Expand Up @@ -22,7 +22,6 @@ Imports:
parallel,
patchwork,
scales,
sf,
stats,
tidyr,
utils
Expand Down
56 changes: 23 additions & 33 deletions R/generateWeatherSeries.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -300,33 +300,29 @@ generateWeatherSeries <- function(

if(evaluate.model) {

# Sample evenly from the grid cells
sampleGrids <- sf::st_as_sf(weather.grid[,c("x","y")], coords=c("x","y")) %>%
sf::st_sample(size = min(evaluate.grid.num, ngrids), type="regular") %>%
sf::st_cast("POINT") %>% sf::st_coordinates() %>% as_tibble() %>%
left_join(weather.grid[,c("x","y","id")], by = c("X"="x","Y"="y")) %>%
pull(id)

rlz_sample <- list()
for (n in 1:realization.num) {
rlz_sample[[n]] <- lapply(rlz[[n]][sampleGrids], function(x)
mutate(x, date = sim_dates_d$date, .before = 1))
}

obs_sample <- lapply(weather.data[sampleGrids], function(x)
dplyr::mutate(x, date = weather.date, .before = 1))

suppressWarnings(
evaluateWegen(daily.sim = rlz_sample,
daily.obs = obs_sample,
output.path = plots_path,
variables = variable.names,
variable.labels = variable.labels,
variable.units = variable.units,
realization.num = realization.num,
wet.quantile = mc.wet.quantile,
extreme.quantile = mc.extreme.quantile)
)
sampleGrids <- sample(grids, size = min(evaluate.grid.num, ngrids))
#sampleGrids <- 1:(min(evaluate.grid.num, ngrids))

rlz_sample <- list()
for (n in 1:realization.num) {
rlz_sample[[n]] <- lapply(rlz[[n]][sampleGrids], function(x)
mutate(x, date = sim_dates_d$date, .before = 1))
}

obs_sample <- lapply(weather.data[sampleGrids], function(x)
dplyr::mutate(x, date = weather.date, .before = 1))

suppressWarnings(
evaluateWegen(daily.sim = rlz_sample,
daily.obs = obs_sample,
output.path = plots_path,
variables = variable.names,
variable.labels = variable.labels,
variable.units = variable.units,
realization.num = realization.num,
wet.quantile = mc.wet.quantile,
extreme.quantile = mc.extreme.quantile)
)

} else {
message(cat(as.character(Sys.time()), "- Comparison of climate statistics skipped"))
Expand All @@ -339,9 +335,3 @@ generateWeatherSeries <- function(
return(list(resampled = resampled_dates, dates = sim_dates_d$date))

}






160 changes: 91 additions & 69 deletions R/imposeClimateChanges.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -33,44 +33,63 @@ imposeClimateChanges <- function(

{

# Number of grid cells
ngrids <- length(climate.data)

# Year and month indices
year_vec <- as.numeric(format(sim.dates,"%Y"))
year_ind <- year_vec - min(year_vec) + 1
month_ind <- as.numeric(format(sim.dates,"%m"))

# Define daily temperature change factors

### Define Daily temperature change factors

# Transient changes (gradual)
if(isTRUE(transient.temp.change)) {
tempf1 <- sapply(1:12, function(x)
seq(0, change.factor.temp.mean[x], length.out = max(year_ind)))
} else {
seq(0, change.factor.temp.mean[x] * 2, length.out = max(year_ind)))

# Step changes
} else {
tempf1 <- sapply(1:12, function(x)
rep(change.factor.temp.mean[x]/2, length.out = max(year_ind)))
rep(change.factor.temp.mean[x], length.out = max(year_ind)))
}

tempf2 <- sapply(1:length(sim.dates), function(x) tempf1[year_ind[x], month_ind[x]])
tempf2 <- sapply(1:length(sim.dates),
function(x) tempf1[year_ind[x], month_ind[x]])

# Define daily precipitation change factors
### Define Daily precipitation change factors

# Transient changes (gradual)
if(isTRUE(transient.precip.change)) {

# Set constraint on maximum change (i.e., maximum = 99%)
min_precipf = 0.01

precip_mean_deltaf <- (change.factor.precip.mean - 1) * 2 + 1
precip_meanf <- sapply(1:12,
function(m) seq(1, change.factor.precip.mean[m], length.out = max(year_ind)))
function(m) seq(1, precip_mean_deltaf[m], length.out = max(year_ind)))
precip_meanf[precip_meanf < min_precipf] <- min_precipf

precip_var_deltaf <- (change.factor.precip.variance - 1) * 2 + 1
precip_varf <- sapply(1:12,
function(m) seq(1, change.factor.precip.variance[m], length.out = max(year_ind)))
function(m) seq(1, precip_var_deltaf[m], length.out = max(year_ind)))
precip_varf[precip_varf < min_precipf] <- min_precipf

} else {
# Step changes
} else {
precip_meanf <- sapply(1:12,
function(m) rep(change.factor.precip.mean[m]/2, max(year_ind)))
function(m) rep(change.factor.precip.mean[m], max(year_ind)))
precip_varf <- sapply(1:12,
function(m) rep(change.factor.precip.variance[m]/2, max(year_ind)))
function(m) rep(change.factor.precip.variance[m], max(year_ind)))
}

##############################################################################

# Apply climate changes (per grid)
for (x in 1:ngrids) {

# Perturb daily precipitation using quantile mapping
# Perturb daily precipitation (by quantile mapping)
climate.data[[x]]$precip <- weathergenr::quantileMapping(
value = climate.data[[x]]$precip,
mon.ts = month_ind,
Expand All @@ -79,74 +98,77 @@ imposeClimateChanges <- function(
var.change = precip_varf,
fit.method = "mme")

# Perturb temp, temp_min, and temp_max by delta factors
# Perturb temp, temp_min, and temp_max (by additive delta factors)
climate.data[[x]]$temp <- climate.data[[x]]$temp + tempf2
climate.data[[x]]$temp_min <- climate.data[[x]]$temp_min + tempf2
climate.data[[x]]$temp_max <- climate.data[[x]]$temp_max + tempf2

# Calculate adjusted PET based on temperature variables
if(isTRUE(calculate.pet)) {
climate.data[[x]]$pet <- with(climate.data[[x]], hargreavesPet(
months = month_ind, temp = temp, tdiff = temp_max - temp_min,
lat = climate.grid$y[x]))
climate.data[[x]]$pet <- with(climate.data[[x]],
hargreavesPet(months = month_ind,
temp = temp,
tdiff = temp_max - temp_min,
lat = climate.grid$y[x]))
}

}

# Replace possible infinite/NA values with zero
# Replace possible infinite/NA values with zeros
climate.data <- lapply(1:length(climate.data), function(y)
do.call(tibble, lapply(climate.data[[y]], function(x) replace(x, is.infinite(x), 0))))


# # Set number of cores for parallel computing
# if(compute.parallel == TRUE) {
#
# if(is.null(num.cores)) num.cores <- parallel::detectCores()-1
# cl <- parallel::makeCluster(num.cores)
# doParallel::registerDoParallel(cl)
# `%d%` <- foreach::`%dopar%`
#
# } else {
#
# `%d%` <- foreach::`%do%`
# }

##############################################################################
##############################################################################

# precip <- foreach::foreach(x=seq_len(ngrids)) %d% {
#
# weathergenr::quantileMapping(
# value = climate.data[[x]]$precip,
# mon.ts = month_ind,
# year.ts = year_ind,
# mean.change = precip_meanf,
# var.change = precip_varf,
# fit.method = fit.method)
# }
#
# if(compute.parallel == TRUE) parallel::stopCluster(cl)
#
# for (x in 1:ngrids) {
#
# # Perturb temp, temp_min, and temp_max by delta factors
# climate.data[[x]]$precip <- precip[[x]]
# climate.data[[x]]$temp <- climate.data[[x]]$temp + tempf2
# climate.data[[x]]$temp_min <- climate.data[[x]]$temp_min + tempf2
# climate.data[[x]]$temp_max <- climate.data[[x]]$temp_max + tempf2
#
# if(isTRUE(calculate.pet)) {
# climate.data[[x]]$pet <- with(climate.data[[x]], hargreavesPet(
# months = month_ind, temp = temp, tdiff = temp_max - temp_min,
# lat = climate.grid$y[x]))
# }
#
# }
#
# # Replace possible infinite/NA values with zero
# climate.data <- lapply(1:length(climate.data), function(y)
# do.call(tibble::tibble, lapply(climate.data[[y]],
# function(x) replace(x, is.infinite(x) | is.na(x), 0))))
do.call(tibble, lapply(climate.data[[y]],
function(x) replace(x, is.infinite(x), 0))))

return(climate.data)

}

# # Set number of cores for parallel computing
# if(compute.parallel == TRUE) {
#
# if(is.null(num.cores)) num.cores <- parallel::detectCores()-1
# cl <- parallel::makeCluster(num.cores)
# doParallel::registerDoParallel(cl)
# `%d%` <- foreach::`%dopar%`
#
# } else {
#
# `%d%` <- foreach::`%do%`
# }

##############################################################################
##############################################################################

# precip <- foreach::foreach(x=seq_len(ngrids)) %d% {
#
# weathergenr::quantileMapping(
# value = climate.data[[x]]$precip,
# mon.ts = month_ind,
# year.ts = year_ind,
# mean.change = precip_meanf,
# var.change = precip_varf,
# fit.method = fit.method)
# }
#
# if(compute.parallel == TRUE) parallel::stopCluster(cl)
#
# for (x in 1:ngrids) {
#
# # Perturb temp, temp_min, and temp_max by delta factors
# climate.data[[x]]$precip <- precip[[x]]
# climate.data[[x]]$temp <- climate.data[[x]]$temp + tempf2
# climate.data[[x]]$temp_min <- climate.data[[x]]$temp_min + tempf2
# climate.data[[x]]$temp_max <- climate.data[[x]]$temp_max + tempf2
#
# if(isTRUE(calculate.pet)) {
# climate.data[[x]]$pet <- with(climate.data[[x]], hargreavesPet(
# months = month_ind, temp = temp, tdiff = temp_max - temp_min,
# lat = climate.grid$y[x]))
# }
#
# }
#
# # Replace possible infinite/NA values with zero
# climate.data <- lapply(1:length(climate.data), function(y)
# do.call(tibble::tibble, lapply(climate.data[[y]],
# function(x) replace(x, is.infinite(x) | is.na(x), 0))))
Loading

0 comments on commit 460583f

Please sign in to comment.