From 8f804ce0c852608c36e5b6458a77f4fb14157f34 Mon Sep 17 00:00:00 2001 From: heaston-indecon Date: Wed, 11 Oct 2023 15:56:31 -0400 Subject: [PATCH] Updated all pipe operators to base --- FrEDI/R/aggregate_impacts.R | 406 +++++++++--------- FrEDI/R/convertTemps.R | 2 +- FrEDI/R/get_plots.R | 270 ++++++------ FrEDI/R/get_sectorInfo.R | 18 +- FrEDI/R/import_inputs.R | 100 ++--- FrEDI/R/run_fredi.R | 590 +++++++++++++-------------- FrEDI/R/run_fredi_sv.R | 424 +++++++++---------- FrEDI/R/temps2slr.R | 62 +-- FrEDI/R/utils.R | 746 +++++++++++++++++----------------- FrEDI/R/utils_import_inputs.R | 20 +- FrEDI/R/utils_sv.R | 292 ++++++------- 11 files changed, 1465 insertions(+), 1465 deletions(-) diff --git a/FrEDI/R/aggregate_impacts.R b/FrEDI/R/aggregate_impacts.R index 65bf9d5d..adb0ea2f 100644 --- a/FrEDI/R/aggregate_impacts.R +++ b/FrEDI/R/aggregate_impacts.R @@ -36,7 +36,7 @@ #' df_tempExOut <- run_fredi(aggLevels="none", pv=TRUE, silent=TRUE) #' #' ### Aggregate temperature binning summary across multiple columns -#' agg_tempExOut <- df_tempExOut %>% aggregate_impacts(columns=c("annual_impacts", "discounted_impacts")) +#' agg_tempExOut <- df_tempExOut |> aggregate_impacts(columns=c("annual_impacts", "discounted_impacts")) #' #' @references Environmental Protection Agency (EPA). 2021. Technical Documentation on The Framework for Evaluating Damages and Impacts (FrEDI). Technical Report EPA 430-R-21-004, EPA, Washington, DC. Available at . #' @@ -58,23 +58,23 @@ aggregate_impacts <- function( ### Not used currently; preserving it in messaging logicals for the future msgUser <- T ### Modes...specifically SLR interpolation only - xMode <- ifelse(is.null(mode), "all", mode) %>% tolower + xMode <- ifelse(is.null(mode), "all", mode) |> tolower() ###### Ungroup Data ###### - data <- data %>% ungroup #; names(data) %>% print + data <- data |> ungroup() #; names(data) |> print() ###### Years Info ###### ### Years in data # c_npdRefYear <- 2090 - c_dataYears <- data$year %>% unique - # has_plus2090vals <- (c_dataYears[which(c_dataYears > c_npdRefYear)] %>% length) > 0 + c_dataYears <- data$year |> unique() + # has_plus2090vals <- (c_dataYears[which(c_dataYears > c_npdRefYear)] |> length()) > 0 ###### SLR Info ###### # assign("slr_cm", rDataList[["slr_cm"]]) assign("co_models", rDataList[["co_models"]]) - co_slrs <- co_models %>% filter(modelType=="slr") - co_slrs <- co_slrs %>% mutate_at(.vars=c("model_dot", "model_label"), as.character) - co_slrs <- co_slrs %>% as.data.frame + co_slrs <- co_models |> filter(modelType=="slr") + co_slrs <- co_slrs |> mutate_at(.vars=c("model_dot", "model_label"), as.character) + co_slrs <- co_slrs |> as.data.frame() ###### Load Sector Info ###### name_dfSectors <- "co_sectors" @@ -83,10 +83,10 @@ aggregate_impacts <- function( assign(name_dfSectors, rDataList[[name_dfSectors]]) - co_sectors <- co_sectors %>% select(all_of(sectorCols_old)) - co_sectors <- co_sectors %>% rename_with(~sectorCols_new, .cols=sectorCols_old) - # co_sectors <- co_sectors %>% (function(y){names(y) <- c(sectorCols_new); return(y)}) - co_sectors <- co_sectors %>% mutate(model_type = model_type %>% toupper()) + co_sectors <- co_sectors |> select(all_of(sectorCols_old)) + co_sectors <- co_sectors |> rename_with(~sectorCols_new, .cols=sectorCols_old) + # co_sectors <- co_sectors |> (function(y){names(y) <- c(sectorCols_new); return(y)}) + co_sectors <- co_sectors |> mutate(model_type = model_type |> toupper()) rm("sectorCols_old", "sectorCols_new") ###### Load Variant Info ###### @@ -98,13 +98,13 @@ aggregate_impacts <- function( variantCols_old <- c("sector_id", "variant_label") variantCols_new <- c("sector_id", "variant") variantCols_other <- c("sectorprimary", "includeaggregate") - co_variants <- co_variants %>% select(c(all_of(variantCols_old), all_of(variantCols_other))) - # co_variants <- co_variants %>% (function(y){names(y) <- c(variantCols_new, variantCols_other); return(y)}) - co_variants <- co_variants %>% rename_with(~variantCols_new, .cols=variantCols_old) + co_variants <- co_variants |> select(c(all_of(variantCols_old), all_of(variantCols_other))) + # co_variants <- co_variants |> (function(y){names(y) <- c(variantCols_new, variantCols_other); return(y)}) + co_variants <- co_variants |> rename_with(~variantCols_new, .cols=variantCols_old) rm("variantCols_old", "variantCols_new", "variantCols_other") ### Combine sector and variant info - co_sector_variants <- co_sectors %>% left_join(co_variants, by = "sector_id") %>% select(-c("sector_id")) + co_sector_variants <- co_sectors |> left_join(co_variants, by = "sector_id") |> select(-c("sector_id")) ###### Groups Columns ###### @@ -115,9 +115,9 @@ aggregate_impacts <- function( groupByCols <- default_groupByCols } ### Check if columns for grouping are there - names_data0 <- data %>% names + names_data0 <- data |> names() is_groupByCol <- groupByCols %in% names_data0 - which_notPresentGroups <- (!is_groupByCol) %>% which + which_notPresentGroups <- (!is_groupByCol) |> which() ### Message user if some columns aren't present if(length(which_notPresentGroups) > 0){ groupByCols <- groupByCols[which(is_groupByCol)] @@ -128,13 +128,13 @@ aggregate_impacts <- function( } ### Add sector primary and include aggregate - # newGroupCols <- c("sectorprimary", "includeaggregate") %>% - newGroupCols <- c("sectorprimary", "includeaggregate", "physicalmeasure") %>% - (function(y){y[which(!(y %in% groupByCols))]}) %>% - (function(y){y[which(y %in% names_data0)]}) + # newGroupCols <- c("sectorprimary", "includeaggregate") |> + newGroupCols <- c("sectorprimary", "includeaggregate", "physicalmeasure") |> + (function(y){y[which(!(y %in% groupByCols))]})() |> + (function(y){y[which(y %in% names_data0)]})() ### If length(newGroupCols)>0, add them if(length(newGroupCols)>0){ - groupByCols <- groupByCols %>% c(newGroupCols) + groupByCols <- groupByCols |> c(newGroupCols) } ### Remove extra names rm("is_groupByCol", "which_notPresentGroups", "newGroupCols") @@ -147,7 +147,7 @@ aggregate_impacts <- function( else {summaryCols <- columns} is_sumByCol <- summaryCols %in% names_data0 - which_notPresentSums <- (!is_sumByCol) %>% which + which_notPresentSums <- (!is_sumByCol) |> which() ### Message user if some columns aren't present if(length(which_notPresentSums) > 0){ summaryCols <- summaryCols[which(is_sumByCol)] @@ -159,22 +159,22 @@ aggregate_impacts <- function( rm("is_sumByCol", "which_notPresentSums") summaryCol1 <- summaryCols[1] ### Add physical impacts summary column - newSumCols <- c("physical_impacts") %>% - (function(y){y[which(!(y %in% summaryCols))]}) %>% - (function(y){y[which(y %in% names_data0)]}) + newSumCols <- c("physical_impacts") |> + (function(y){y[which(!(y %in% summaryCols))]})() |> + (function(y){y[which(y %in% names_data0)]})() ### If length(newGroupCols)>0, add them if(length(newSumCols)>0){ - summaryCols <- summaryCols %>% c(newSumCols) + summaryCols <- summaryCols |> c(newSumCols) } ### Number of summary columns - num_summaryCols <- summaryCols %>% length - data <- data %>% mutate_at(.vars=c(all_of(groupByCols)), as.character) + num_summaryCols <- summaryCols |> length() + data <- data |> mutate_at(.vars=c(all_of(groupByCols)), as.character) ###### Aggregation Levels ###### ### Types of summarization to do: default aggList0 <- c("national", "modelaverage", "impactyear", "impacttype", "all") if(!is.null(aggLevels)){ - aggLevels <- aggLevels %>% tolower() + aggLevels <- aggLevels |> tolower() ### If the user specified none, return the data if("none" %in% aggLevels){ aggLevels <- c() @@ -207,215 +207,215 @@ aggregate_impacts <- function( ###### Standardize Columns ###### ### Associated Columns - baseScenarioCols <- c("year", "gdp_usd", "national_pop", "gdp_percap") %>% (function(y){y[which(y %in% names(data))]}) - regionalPopCols <- c("year", "region", "reg_pop") %>% (function(y){y[which(y %in% names(data))]}) - nationalPopCols <- c("year", "region", "national_pop") %>% (function(y){y[which(y %in% names(data))]}) - driverScenarioCols <- c("year", "model_type", "driverType", "driverUnit", "driverValue") %>% (function(y){y[which(y %in% names(data))]}) + baseScenarioCols <- c("year", "gdp_usd", "national_pop", "gdp_percap") |> (function(y){y[which(y %in% names(data))]})() + regionalPopCols <- c("year", "region", "reg_pop") |> (function(y){y[which(y %in% names(data))]})() + nationalPopCols <- c("year", "region", "national_pop") |> (function(y){y[which(y %in% names(data))]})() + driverScenarioCols <- c("year", "model_type", "driverType", "driverUnit", "driverValue") |> (function(y){y[which(y %in% names(data))]})() ### List of standardized columns - standardCols <- c(baseScenarioCols, regionalPopCols, nationalPopCols) %>% unique - # standardCols <- c(standardCols) %>% unique - # summaryCols <- c(summaryCols) %>% unique + standardCols <- c(baseScenarioCols, regionalPopCols, nationalPopCols) |> unique() + # standardCols <- c(standardCols) |> unique() + # summaryCols <- c(summaryCols) |> unique() ### Standardize columns - standardCols <- c(groupByCols, standardCols, driverScenarioCols, summaryCols) %>% unique + standardCols <- c(groupByCols, standardCols, driverScenarioCols, summaryCols) |> unique() ### If "national" aggregation, filter out national totals if(nationalAgg){ - data <- data %>% filter(region!="National Total") + data <- data |> filter(region!="National Total") } ### If modelAverage %in% aggLevels, filter out model averages if(modelAveAgg){ - data <- data %>% filter(!(model %in% c("Average", "Model Average"))) + data <- data |> filter(!(model %in% c("Average", "Model Average"))) } - data <- data[,(names(data) %in% standardCols)]#; names(data) %>% print + data <- data[,(names(data) %in% standardCols)]#; names(data) |> print ###### Base Scenario Info ###### ### Some values are the same for all runs and regions...separate those values - sectorsList <- data$sector %>% unique - sector0 <- sectorsList %>% first - variant0 <- (data %>% filter(sector==sector0))$variant %>% unique %>% first - region0 <- (data %>% filter(sector==sector0))$region %>% unique %>% first - model0 <- (data %>% filter(sector==sector0))$model %>% unique %>% first - impactType0 <- (data %>% filter(sector==sector0))$impactType %>% unique %>% first + sectorsList <- data$sector |> unique() + sector0 <- sectorsList |> first() + variant0 <- (data |> filter(sector==sector0))$variant |> unique() |> first() + region0 <- (data |> filter(sector==sector0))$region |> unique() |> first() + model0 <- (data |> filter(sector==sector0))$model |> unique() |> first() + impactType0 <- (data |> filter(sector==sector0))$impactType |> unique() |> first() ### Base Scenario and regional population - baseScenario <- data %>% filter(sector == sector0, variant == variant0, region == region0, model == model0, impactType == impactType0) - regionalPop <- data %>% filter(sector == sector0, variant == variant0, model == model0, impactType == impactType0) + baseScenario <- data |> filter(sector == sector0, variant == variant0, region == region0, model == model0, impactType == impactType0) + regionalPop <- data |> filter(sector == sector0, variant == variant0, model == model0, impactType == impactType0) ### Filter to impact types if(impactTypesAgg){ - impactType0 <- baseScenario$impactType %>% unique %>% first - baseScenario <- baseScenario %>% filter(impactType == impactType0) - regionalPop <- regionalPop %>% filter(impactType == impactType0) + impactType0 <- baseScenario$impactType |> unique() |> first() + baseScenario <- baseScenario |> filter(impactType == impactType0) + regionalPop <- regionalPop |> filter(impactType == impactType0) } ### Filter to impact years if(impactYearsAgg){ - impactYear0 <- baseScenario$impactYear %>% unique %>% first - baseScenario <- baseScenario %>% filter(impactYear == impactYear0) - regionalPop <- regionalPop %>% filter(impactYear == impactYear0) + impactYear0 <- baseScenario$impactYear |> unique() |> first() + baseScenario <- baseScenario |> filter(impactYear == impactYear0) + regionalPop <- regionalPop |> filter(impactYear == impactYear0) } ### Select columns ### Base Scenario, regional population, national population - baseScenario <- baseScenario %>% select(all_of(baseScenarioCols)) - regionalPop <- regionalPop %>% select(all_of(regionalPopCols)) + baseScenario <- baseScenario |> select(all_of(baseScenarioCols)) + regionalPop <- regionalPop |> select(all_of(regionalPopCols)) ### Create national population scenario from the base scenario - nationalPop <- baseScenario %>% - mutate(region = "National Total") %>% - select(all_of(nationalPopCols)) %>% + nationalPop <- baseScenario |> + mutate(region = "National Total") |> + select(all_of(nationalPopCols)) |> rename(reg_pop=national_pop) ###### Driver Scenario ###### ### Get unique model types, sectors, variants, and models - names_x <- data %>% names - modelTypesList <- data$model_type %>% unique - driverScenario <- modelTypesList %>% + names_x <- data |> names() + modelTypesList <- data$model_type |> unique() + driverScenario <- modelTypesList |> lapply(function(model_type_i){ ### Filter to sector - df_i <- data %>% filter(model_type==model_type_i) - sector_i <- df_i$sector %>% unique %>% first - df_i <- df_i %>% filter(sector == sector_i) + df_i <- data |> filter(model_type==model_type_i) + sector_i <- df_i$sector |> unique() |> first() + df_i <- df_i |> filter(sector == sector_i) ### Filter to variant - variant_i <- df_i$variant %>% unique %>% first - df_i <- df_i %>% filter(variant == variant_i) + variant_i <- df_i$variant |> unique() |> first() + df_i <- df_i |> filter(variant == variant_i) ### Filter to impact type if("impactType" %in% names_x){ - type_i <- df_i$impactType %>% unique %>% first - df_i <- df_i %>% filter(impactType == type_i) + type_i <- df_i$impactType |> unique() |> first() + df_i <- df_i |> filter(impactType == type_i) } ### Filter to region if("region" %in% names_x){ - region_i <- df_i$region %>% unique %>% first - df_i <- df_i %>% filter(region == region_i) + region_i <- df_i$region |> unique() |> first() + df_i <- df_i |> filter(region == region_i) } ### Filter to model if("model" %in% names_x){ - model_i <- df_i$model %>% unique %>% first - df_i <- df_i %>% filter(model == model_i) + model_i <- df_i$model |> unique() |> first() + df_i <- df_i |> filter(model == model_i) } ### Filter to impact year if("impactYear" %in% names_x){ - year_i <- df_i$impactYear %>% unique %>% first - df_i <- df_i %>% filter(impactYear == year_i) + year_i <- df_i$impactYear |> unique() |> first() + df_i <- df_i |> filter(impactYear == year_i) } ### Select columns - df_i <- df_i %>% select(all_of(driverScenarioCols)) + df_i <- df_i |> select(all_of(driverScenarioCols)) ### Return return(df_i) - }) %>% (function(x){do.call(rbind, x)}) - # driverScenario %>% dim %>% print + }) |> (function(x){do.call(rbind, x)})() + # driverScenario |> dim() |> print() ###### Aggregation ###### # if(requiresAgg){ # if(msgUser) message("Aggregating impacts...") # } ###### Save a copy of the data - scenarioCols <- c(baseScenarioCols, regionalPopCols, nationalPopCols, driverScenarioCols) %>% unique %>% - (function(y){y[which(!(y %in% c(groupByCols, "year")))]}) #; scenarioCols %>% print + scenarioCols <- c(baseScenarioCols, regionalPopCols, nationalPopCols, driverScenarioCols) |> unique() |> + (function(y){y[which(!(y %in% c(groupByCols, "year")))]})() #; scenarioCols |> print() ### Select appropriate columns - df_aggImpacts <- data %>% select(-c(all_of(scenarioCols))) - # df_aggImpacts %>% nrow %>% print; df_aggImpacts %>% head %>% glimpse + df_aggImpacts <- data |> select(-c(all_of(scenarioCols))) + # df_aggImpacts |> nrow() |> print(); df_aggImpacts |> head() |> glimpse() ###### Impact Years ###### ### Separate into years after 2090 and before 2090 if(impactYearsAgg){ if(msgUser) message("\t", "Interpolating between impact year estimates...") ### Ungroup first - df_aggImpacts <- df_aggImpacts %>% ungroup + df_aggImpacts <- df_aggImpacts |> ungroup() # summaryCol1 <- summaryCols[1] ### Group by columns groupCols0 <- groupByCols[which(groupByCols != "impactYear" )] ### Impact years - impactYears <- c(2010, 2090) %>% as.character + impactYears <- c(2010, 2090) |> as.character() impactYear1 <- impactYears[1] impactYear2 <- impactYears[2] ### Separate data into years > 2090, years <= 2090 c_cutoff_yr <- 2090 - df_aggImp_1 <- df_aggImpacts %>% filter(year <= c_cutoff_yr) - df_aggImp_2 <- df_aggImpacts %>% filter(year > c_cutoff_yr) + df_aggImp_1 <- df_aggImpacts |> filter(year <= c_cutoff_yr) + df_aggImp_2 <- df_aggImpacts |> filter(year > c_cutoff_yr) rm("df_aggImpacts") ### Then do the post-2090 results ### Exclude 2010 results - df_aggImpacts <- df_aggImp_2 %>% filter(impactYear != impactYear1) %>% mutate(impactYear="Interpolation") + df_aggImpacts <- df_aggImp_2 |> filter(impactYear != impactYear1) |> mutate(impactYear="Interpolation") rm("df_aggImp_2") ### Process pre-2090: ### Separate out observations without impact years - df_naYears <- df_aggImp_1 %>% filter(!(impactYear %in% impactYears)) %>% mutate(impactYear="Interpolation") + df_naYears <- df_aggImp_1 |> filter(!(impactYear %in% impactYears)) |> mutate(impactYear="Interpolation") ### New upper and lower column names new_2090SummaryCols <- paste(summaryCols, "2090", sep="_") new_2010SummaryCols <- paste(summaryCols, "2010", sep="_") ### Filter to impact year in impact years - df_impYears <- df_aggImp_1 %>% filter(impactYear %in% impactYears) - nrow_impYrs <- df_impYears %>% nrow + df_impYears <- df_aggImp_1 |> filter(impactYear %in% impactYears) + nrow_impYrs <- df_impYears |> nrow() rm("df_aggImp_1") ### For nrow_impYrs > 0 if(nrow_impYrs){ ### Filter to other lower models and then bind with the zero values, drop model column - df2090 <- df_impYears %>% filter(impactYear == impactYear2) %>% select(-c("impactYear")) - df2090 <- df2090 %>% (function(y){ - y <- y %>% as.data.frame + df2090 <- df_impYears |> filter(impactYear == impactYear2) |> select(-c("impactYear")) + df2090 <- df2090 |> (function(y){ + y <- y |> as.data.frame() y[,new_2090SummaryCols] <- y[,summaryCols] return(y) - }) + })() ### Drop summary columns from 2010 - df2010 <- df_impYears %>% filter(impactYear == impactYear1) %>% select(-c("impactYear")) - df2010 <- df2010 %>% (function(y){ - y <- y %>% as.data.frame + df2010 <- df_impYears |> filter(impactYear == impactYear1) |> select(-c("impactYear")) + df2010 <- df2010 |> (function(y){ + y <- y |> as.data.frame() y[,new_2010SummaryCols] <- y[,summaryCols] return(y) - }) %>% + })() |> select(-c(all_of(summaryCols))) ### Join upper and lower data frames and calculate the numerator, denominator, and adjustment factor - df_impYears <- df2090 %>% left_join(df2010, by=c(groupCols0, "year")) + df_impYears <- df2090 |> left_join(df2010, by=c(groupCols0, "year")) rm("df2090", "df2010") ### Add Impact year numerator and denominator - df_impYears <- df_impYears %>% mutate(numer_yr = year-as.numeric(impactYear1)) - df_impYears <- df_impYears %>% mutate(denom_yr = as.numeric(impactYear2)-as.numeric(impactYear1)) - df_impYears <- df_impYears %>% mutate(adj_yr = numer_yr/denom_yr) + df_impYears <- df_impYears |> mutate(numer_yr = year-as.numeric(impactYear1)) + df_impYears <- df_impYears |> mutate(denom_yr = as.numeric(impactYear2)-as.numeric(impactYear1)) + df_impYears <- df_impYears |> mutate(adj_yr = numer_yr/denom_yr) ### Iterate over summary columns for(i in 1:num_summaryCols){ ### Upper/lower col_i <- summaryCols[i] - col_i_2010 <- col_i %>% paste("2010", sep="_") - col_i_2090 <- col_i %>% paste("2090", sep="_") + col_i_2010 <- col_i |> paste("2010", sep="_") + col_i_2090 <- col_i |> paste("2090", sep="_") ### Calculate numerator and denominator - df_impYears <- df_impYears %>% as.data.frame + df_impYears <- df_impYears |> as.data.frame() df_impYears$new_factor <- df_impYears[,col_i_2090] - df_impYears[,col_i_2010] df_impYears$new_value <- df_impYears[,col_i_2010] - # df_slrOther %>% names %>% print + # df_slrOther |> names() |> print() ### Update the new value - oldCol_i <- col_i %>% c() - newCol_i <- "new_value" %>% c() + oldCol_i <- col_i |> c() + newCol_i <- "new_value" |> c() ### Mutate and rename - df_impYears <- df_impYears %>% mutate(new_value = new_value + new_factor * adj_yr) - df_impYears <- df_impYears %>% select(-c(all_of(col_i), "new_factor")) - df_impYears <- df_impYears %>% rename_with(~oldCol_i[which(newCol_i==.x)], .cols=newCol_i) - df_impYears <- df_impYears %>% select(-c(all_of(col_i_2010), all_of(col_i_2090))) + df_impYears <- df_impYears |> mutate(new_value = new_value + new_factor * adj_yr) + df_impYears <- df_impYears |> select(-c(all_of(col_i), "new_factor")) + df_impYears <- df_impYears |> rename_with(~oldCol_i[which(newCol_i==.x)], .cols=newCol_i) + df_impYears <- df_impYears |> select(-c(all_of(col_i_2010), all_of(col_i_2090))) rm("i", "col_i", "col_i_2010", "col_i_2090", "oldCol_i", "newCol_i") } ### End for(i in 1:num_summaryCols) - df_impYears <- df_impYears %>% mutate(impactYear="Interpolation") - df_impYears <- df_impYears %>% select(-c("numer_yr", "denom_yr", "adj_yr")) + df_impYears <- df_impYears |> mutate(impactYear="Interpolation") + df_impYears <- df_impYears |> select(-c("numer_yr", "denom_yr", "adj_yr")) } rm("impactYears", "impactYear1", "impactYear2", "new_2010SummaryCols", "new_2090SummaryCols") rm("groupCols0", "c_cutoff_yr") ### Add back into values without NA years ### Join post 2090 results with earlier results - df_aggImp_1 <- df_impYears %>% rbind(df_naYears) %>% mutate(impactYear="Interpolation") - df_aggImpacts <- df_aggImpacts %>% rbind(df_aggImp_1) + df_aggImp_1 <- df_impYears |> rbind(df_naYears) |> mutate(impactYear="Interpolation") + df_aggImpacts <- df_aggImpacts |> rbind(df_aggImp_1) rm("df_impYears", "df_naYears", "df_aggImp_1") } - # paste0("Finished impact year interpolation: ", nrow(df_aggImpacts)) %>% print; df_aggImpacts %>% head %>% glimpse + # paste0("Finished impact year interpolation: ", nrow(df_aggImpacts)) |> print(); df_aggImpacts |> head() |> glimpse() ###### Model Averages ###### ### Average values across models @@ -423,95 +423,95 @@ aggregate_impacts <- function( modelAveMsg <- ifelse(xMode=="slrinterpolation", "Interpolating SLR impacts..." , "Calculating model averages...") if(msgUser) message("\t", modelAveMsg) ### Ungroup first - df_aggImpacts <- df_aggImpacts %>% mutate_at(.vars=c("model"), as.character) %>% ungroup + df_aggImpacts <- df_aggImpacts |> mutate_at(.vars=c("model"), as.character) |> ungroup() ### Group by columns groupCols0 <- groupByCols[which(groupByCols != "model" )] ### Separate model types - df_gcm <- df_aggImpacts %>% filter(tolower(model_type)=="gcm") - df_slr <- df_aggImpacts %>% filter(tolower(model_type)=="slr") + df_gcm <- df_aggImpacts |> filter(tolower(model_type)=="gcm") + df_slr <- df_aggImpacts |> filter(tolower(model_type)=="slr") rm("df_aggImpacts") ###### GCM ####### if(nrow(df_gcm)){ ### Names of agg impacts - names_gcms <- df_gcm %>% names + names_gcms <- df_gcm |> names() ### Calculate number of non missing values ### Group data, sum data, calculate averages, and drop NA column - df_modelAves <- df_gcm %>% (function(w){ - w$not_isNA <- (!is.na(w[,summaryCol1] %>% as.vector))*1 + df_modelAves <- df_gcm |> (function(w){ + w$not_isNA <- (!is.na(w[,summaryCol1] |> as.vector()))*1 return(w) - }) - df_modelAves <- df_modelAves %>% - group_by_at(c(all_of(groupCols0), "year")) %>% - summarize_at(.vars=c(all_of(summaryCols), "not_isNA"), sum, na.rm=T) %>% ungroup - df_modelAves <- df_modelAves %>% mutate(not_isNA = not_isNA %>% na_if(0)) %>% - as.data.frame %>% (function(x){ + })() + df_modelAves <- df_modelAves |> + group_by_at(c(all_of(groupCols0), "year")) |> + summarize_at(.vars=c(all_of(summaryCols), "not_isNA"), sum, na.rm=T) |> ungroup() + df_modelAves <- df_modelAves |> mutate(not_isNA = not_isNA |> na_if(0)) |> + as.data.frame() |> (function(x){ x[,summaryCols] <- x[,summaryCols] / x$not_isNA return(x) - }) - df_modelAves <- df_modelAves %>% select(-c("not_isNA")) - df_modelAves <- df_modelAves %>% mutate(model = "Average") + })() + df_modelAves <- df_modelAves |> select(-c("not_isNA")) + df_modelAves <- df_modelAves |> mutate(model = "Average") ### Add observations back in - # df_aggImpacts <- df_aggImpacts %>% rbind(df_modelAves) - df_gcm <- df_gcm %>% rbind(df_modelAves) + # df_aggImpacts <- df_aggImpacts |> rbind(df_modelAves) + df_gcm <- df_gcm |> rbind(df_modelAves) rm("names_gcms", "df_modelAves") } ### End if nrow(df_gcm) ### Bind GCM and SLR results - df_aggImpacts <- df_gcm %>% rbind(df_slr) + df_aggImpacts <- df_gcm |> rbind(df_slr) rm( "df_gcm", "df_slr", "groupCols0") } ### End if "model" %in% aggLevels - # paste0("Finished model aggregation: ", nrow(df_aggImpacts)) %>% print; df_aggImpacts %>% head %>% glimpse + # paste0("Finished model aggregation: ", nrow(df_aggImpacts)) |> print(); df_aggImpacts |> head() |> glimpse() ###### National Totals ###### if(nationalAgg){ if(msgUser) message("\t", "Calculating national totals...") ### Ungroup first - df_aggImpacts <- df_aggImpacts %>% ungroup + df_aggImpacts <- df_aggImpacts |> ungroup() ### Group by columns groupCols0 <- groupByCols[which(groupByCols != "region" )] ### Filter to national values and not national values ### Calculate number of non missing values - df_national <- df_aggImpacts %>% (function(w){ - w <- w %>% as.data.frame + df_national <- df_aggImpacts |> (function(w){ + w <- w |> as.data.frame() w$not_isNA <- (!is.na(w[,summaryCol1]))*1 return(w) - }) + })() ### Group data, sum data, calculate averages, and drop NA column - df_national <- df_national %>% - group_by_at(c(all_of(groupCols0), "year")) %>% - summarize_at(vars(all_of(summaryCols), not_isNA), sum, na.rm=T) %>% ungroup - df_national <- df_national %>% mutate(not_isNA = (not_isNA>=1)*1) - df_national <- df_national %>% mutate(not_isNA = not_isNA %>% na_if(0)) - df_national <- df_national %>% (function(x){ + df_national <- df_national |> + group_by_at(c(all_of(groupCols0), "year")) |> + summarize_at(vars(all_of(summaryCols), not_isNA), sum, na.rm=T) |> ungroup() + df_national <- df_national |> mutate(not_isNA = (not_isNA>=1)*1) + df_national <- df_national |> mutate(not_isNA = not_isNA |> na_if(0)) + df_national <- df_national |> (function(x){ x[, summaryCols] <- x[, summaryCols]*x$not_isNA; return(x) - }) - df_national <- df_national %>% select(-c("not_isNA")) - df_national <- df_national %>% mutate(region="National Total") + })() + df_national <- df_national |> select(-c("not_isNA")) + df_national <- df_national |> mutate(region="National Total") ### Add back into regional values and bind national population to impact types - df_aggImpacts <- df_aggImpacts %>% rbind(df_national); - regionalPop <- regionalPop %>% rbind(nationalPop) + df_aggImpacts <- df_aggImpacts |> rbind(df_national); + regionalPop <- regionalPop |> rbind(nationalPop) ### Remove values rm("df_national", "nationalPop", "groupCols0") } ### End if national - # paste0("Finished national totals: ", nrow(df_aggImpacts)) %>% print; df_aggImpacts %>% head %>% glimpse - # "got here1" %>% print + # paste0("Finished national totals: ", nrow(df_aggImpacts)) |> print; df_aggImpacts |> head |> glimpse + # "got here1" |> print ###### Impact Types ###### ### Summarize by Impact Type if(impactTypesAgg){ if(msgUser) message("\t", "Summing across impact types...") ### Ungroup first - df_aggImpacts <- df_aggImpacts %>% ungroup + df_aggImpacts <- df_aggImpacts |> ungroup() ### Group by columns dropCols0 <- c("physicalmeasure", "physical_impacts") - df_aggImpacts <- df_aggImpacts %>% (function(y){ - names_y <- y %>% names + df_aggImpacts <- df_aggImpacts |> (function(y){ + names_y <- y |> names() names_y <- names_y[which(!(names_y %in% dropCols0))] - y <- y %>% select(all_of(names_y)) + y <- y |> select(all_of(names_y)) return(y) - }) + })() ### Names - # namesAgg0 <- df_aggImpacts %>% names + # namesAgg0 <- df_aggImpacts |> names() ### Columns groupByCols <- groupByCols[which(!(groupByCols %in% c(dropCols0)))] summaryCols <- summaryCols[which(!(summaryCols %in% c(dropCols0)))] @@ -519,84 +519,84 @@ aggregate_impacts <- function( standardCols <- standardCols[which(!(standardCols %in% c(dropCols0)))] ### GroupByCols groupCols0 <- groupByCols[which(!(groupByCols %in% c("impactType")))] - # nGroupCols0 <- groupCols0 %>% length + # nGroupCols0 <- groupCols0 |> length() ### Separate into observations that have a single impact type and those with multiple impacts ### Rename impact type for those with one impact - df_aggImpacts1 <- df_aggImpacts %>% filter(impactType=="N/A") %>% mutate(impactType="all") - df_aggImpactsN <- df_aggImpacts %>% filter(impactType!="N/A") - # "aggregate_impacts: got here2" %>% print + df_aggImpacts1 <- df_aggImpacts |> filter(impactType=="N/A") |> mutate(impactType="all") + df_aggImpactsN <- df_aggImpacts |> filter(impactType!="N/A") + # "aggregate_impacts: got here2" |> print() ### Remove df_aggImpacts rm("df_aggImpacts") ### Summarize at impact types: Count number of impact types - df_aggImpactsN <- df_aggImpactsN %>% (function(w){ - w <- w %>% as.data.frame + df_aggImpactsN <- df_aggImpactsN |> (function(w){ + w <- w |> as.data.frame() w$not_isNA <- (!is.na(w[,summaryCol1]))*1 return(w) - }) + })() ### Calculate number of observations - df_aggImpactsN <- df_aggImpactsN %>% - group_by_at(.vars=c(all_of(groupCols0), "year")) %>% - summarize_at(.vars=c(all_of(summaryCols), "not_isNA"), sum, na.rm=T) %>% - as.data.frame %>% ungroup - - # "aggregate_impacts: got here3" %>% print - df_aggImpactsN <- df_aggImpactsN %>% mutate(not_isNA = (not_isNA > 0)*1) - df_aggImpactsN <- df_aggImpactsN %>% mutate(not_isNA = not_isNA %>% na_if(0)) - df_aggImpactsN <- df_aggImpactsN %>% (function(x){ + df_aggImpactsN <- df_aggImpactsN |> + group_by_at(.vars=c(all_of(groupCols0), "year")) |> + summarize_at(.vars=c(all_of(summaryCols), "not_isNA"), sum, na.rm=T) |> + as.data.frame() |> ungroup() + + # "aggregate_impacts: got here3" |> print() + df_aggImpactsN <- df_aggImpactsN |> mutate(not_isNA = (not_isNA > 0)*1) + df_aggImpactsN <- df_aggImpactsN |> mutate(not_isNA = not_isNA |> na_if(0)) + df_aggImpactsN <- df_aggImpactsN |> (function(x){ x[, summaryCols] <- x[, summaryCols]*x$not_isNA; return(x) - }) - df_aggImpactsN <- df_aggImpactsN %>% select(-c("not_isNA")) - df_aggImpactsN <- df_aggImpactsN %>% mutate(impactType="all") %>% as.data.frame - # "aggregate_impacts: got here4" %>% print + })() + df_aggImpactsN <- df_aggImpactsN |> select(-c("not_isNA")) + df_aggImpactsN <- df_aggImpactsN |> mutate(impactType="all") |> as.data.frame() + # "aggregate_impacts: got here4" |> print() ### Add to impacts - # df_aggImpacts <- df_oneImpact %>% rbind(df_nImpacts) %>% mutate(impactType="all") + # df_aggImpacts <- df_oneImpact |> rbind(df_nImpacts) |> mutate(impactType="all") # rm("df_oneImpact", "df_nImpacts") - df_aggImpacts <- df_aggImpacts1 %>% rbind(df_aggImpactsN) + df_aggImpacts <- df_aggImpacts1 |> rbind(df_aggImpactsN) rm("df_aggImpacts1", "df_aggImpactsN", "groupCols0") - # "aggregate_impacts: got here5" %>% print + # "aggregate_impacts: got here5" |> print() } ### End if impactType in aggLevels ###### Join Base Scenario Info with Aggregated Data ###### ### Join national info with population - # "aggregate_impacts: got here6" %>% print - # df_base %>% head %>% glimpse %>% print - regionalPop <- regionalPop %>% mutate(year = year %>% as.numeric) - df_base <- baseScenario %>% mutate(year = year %>% as.numeric) - df_base <- df_base %>% left_join(regionalPop , by=c("year")) - df_base <- df_base %>% left_join(driverScenario, by=c("year")) + # "aggregate_impacts: got here6" |> print() + # df_base |> head() |> glimpse() |> print() + regionalPop <- regionalPop |> mutate(year = year |> as.numeric()) + df_base <- baseScenario |> mutate(year = year |> as.numeric()) + df_base <- df_base |> left_join(regionalPop , by=c("year")) + df_base <- df_base |> left_join(driverScenario, by=c("year")) rm("regionalPop", "baseScenario", "driverScenario") - # df_base %>% dim %>% print ### 1470 rows, 13 columns + # df_base |> dim() |> print() ### 1470 rows, 13 columns ### Names - aggNames <- df_aggImpacts %>% names; #aggNames %>% print - svNames <- co_sector_variants %>% names; #svNames %>% print + aggNames <- df_aggImpacts |> names(); #aggNames |> print() + svNames <- co_sector_variants |> names(); #svNames |> print() svJoin <- c("model_type", "sector", "variant") svDrop <- svNames[which((svNames %in% aggNames) & !(svNames %in% svJoin))] - # "aggregate_impacts: got here7" %>% print + # "aggregate_impacts: got here7" |> print() - df_return <- df_aggImpacts %>% left_join(co_sector_variants %>% select(-c(all_of(svDrop))), by = c(all_of(svJoin))) - df_return <- df_return %>% left_join(df_base , by = c("year", "region", "model_type")) + df_return <- df_aggImpacts |> left_join(co_sector_variants |> select(-c(all_of(svDrop))), by = c(all_of(svJoin))) + df_return <- df_return |> left_join(df_base , by = c("year", "region", "model_type")) rm("df_aggImpacts", "svDrop", "svJoin", "svNames") ###### Reformat sectorprimary and includeaggregate, which were converted to character - c_aggColumns <- c("sectorprimary", "includeaggregate") %>% (function(y){y[which(y %in% names(df_return))]}) + c_aggColumns <- c("sectorprimary", "includeaggregate") |> (function(y){y[which(y %in% names(df_return))]})() if(length(c_aggColumns)){ - df_return <- df_return %>% mutate_at(.vars=c(all_of(c_aggColumns)), as.numeric) + df_return <- df_return |> mutate_at(.vars=c(all_of(c_aggColumns)), as.numeric) } ###### Order Columns ###### ### Order the data frame and ungroup ### Column indices of columns used in ordering - return_names <- df_return %>% names - orderColNames <- c(groupByCols, "year") %>% (function(y){y[which(y %in% return_names)]}) #; "got here10" %>% print - df_return <- df_return %>% arrange_at(.vars=c(all_of(orderColNames))) + return_names <- df_return |> names() + orderColNames <- c(groupByCols, "year") |> (function(y){y[which(y %in% return_names)]})() #; "got here10" |> print() + df_return <- df_return |> arrange_at(.vars=c(all_of(orderColNames))) ###### Return ###### ### Grouping columns, driver columns, scenario columns ### Make sure data is ungrouped and a data frame object - df_return <- df_return %>% select( all_of(standardCols)) - df_return <- df_return %>% ungroup %>% as.data.frame + df_return <- df_return |> select( all_of(standardCols)) + df_return <- df_return |> ungroup() |> as.data.frame() ### Return object # if(msgUser) message("\n", "Finished...") diff --git a/FrEDI/R/convertTemps.R b/FrEDI/R/convertTemps.R index f37d3fd2..985aab52 100644 --- a/FrEDI/R/convertTemps.R +++ b/FrEDI/R/convertTemps.R @@ -33,7 +33,7 @@ convertTemps <- function( c0 <- 0 ### Update c1 <- 1.421 ### Update - toType <- from %>% tolower + toType <- from |> tolower() if(from == "global"){ temp_global <- temps new_temps <- c1*temp_global + c0 diff --git a/FrEDI/R/get_plots.R b/FrEDI/R/get_plots.R index a8451fe6..c7c3ba90 100644 --- a/FrEDI/R/get_plots.R +++ b/FrEDI/R/get_plots.R @@ -44,16 +44,16 @@ #' df_tempExOut <- get_fredi(aggLevels="none", pv=TRUE, silent=TRUE) #' #' ### Aggregate temperature binning summary across multiple columns -#' agg_tempExOut <- df_tempExOut %>% aggregate_impacts(columns=c("annual_impacts", "discounted_impacts")) +#' agg_tempExOut <- df_tempExOut |> aggregate_impacts(columns=c("annual_impacts", "discounted_impacts")) #' #' ### Create list of plots for aggregated results -#' agg_plotList <- agg_tempExOut %>% get_plots() +#' agg_plotList <- agg_tempExOut |> get_plots() #' #' ### Create list of heatmaps for regional values only: -#' reg_plotList <- agg_tempExOut %>% filter(region!="National Total") %>% get_plots(plotTypes="heatmaps") +#' reg_plotList <- agg_tempExOut |> filter(region!="National Total") |> get_plots(plotTypes="heatmaps") #' #' ### Create list of annual plots for national values only: -#' nation_plotList <- agg_tempExOut %>% filter(region=="National Total") %>% get_plots(plotTypes="annual") +#' nation_plotList <- agg_tempExOut |> filter(region=="National Total") |> get_plots(plotTypes="annual") #' #' @references Environmental Protection Agency (EPA). 2021. Technical Documentation on The Framework for Evaluating Damages and Impacts (FrEDI). Technical Report EPA 430-R-21-004, EPA, Washington, DC. Available at . @@ -89,7 +89,7 @@ get_plots <- function( if(is.null(plotTypes)){ plotTypesList <- def_plotTypes } else{ - plotTypesList <- plotTypes %>% tolower + plotTypesList <- plotTypes |> tolower() if("all" %in% plotTypesList){ plotTypesList <- def_plotTypes } else if("none" %in% plotTypesList){ @@ -117,11 +117,11 @@ get_plots <- function( column <- default_column } ### Keep track of the data names, filter to the standardized data names, then add a dummy column for the column to plot - data <- data %>% + data <- data |> (function(y){ y$valueColumn <- y[,column] return(y) - }) + })() ###### Parameter Type ###### ### Whether results are discounted or not @@ -136,7 +136,7 @@ get_plots <- function( ###### Subdirectory names ###### ### Names of directory as uppercase/lowercase discount_uc <- ifelse(undiscounted, "Undiscounted", "Discounted") - discount_lc <- discount_uc %>% tolower + discount_lc <- discount_uc |> tolower() message("In get_plots():") ###### Prepare directories ##### @@ -144,53 +144,53 @@ get_plots <- function( if(save & !is.null(directory)){ ### Directory names for parent image directory, then heatmaps and annual ### Try to create directories for images - # results_dir <- directory %>% file.path(img_suffix, sep="/") + # results_dir <- directory |> file.path(img_suffix, sep="/") results_dir <- directory - heat_dir <- results_dir %>% file.path("heatmaps", sep="/") - ann_dir <- results_dir %>% file.path("ribbon", sep="/") + heat_dir <- results_dir |> file.path("heatmaps", sep="/") + ann_dir <- results_dir |> file.path("ribbon", sep="/") ### Check if the directories exist: - dir_exists <- directory %>% dir.exists() - resultsDir_exists <- results_dir %>% dir.exists() - heatDir_exists <- heat_dir %>% dir.exists() - ribDir_exists <- ann_dir %>% dir.exists() + dir_exists <- directory |> dir.exists() + resultsDir_exists <- results_dir |> dir.exists() + heatDir_exists <- heat_dir |> dir.exists() + ribDir_exists <- ann_dir |> dir.exists() ### If the directory doesn't exist, try to create the directory and image directory and then check again to see if it exists if(!dir_exists){ message("Creating specified directory to save results...") ### Try to create all directories - try_dir <- try(directory %>% dir.create(), silent=T) - try_resultsDir <- try(results_dir %>% dir.create(), silent=T) - if(doHeat) try_heat <- try(heat_dir %>% dir.create(), silent=T) - if(doAnn) try_rib <- try(ann_dir %>% dir.create(), silent=T) + try_dir <- try(directory |> dir.create(), silent=T) + try_resultsDir <- try(results_dir |> dir.create(), silent=T) + if(doHeat) try_heat <- try(heat_dir |> dir.create(), silent=T) + if(doAnn) try_rib <- try(ann_dir |> dir.create(), silent=T) ### then check if they exist - dir_exists <- directory %>% dir.exists() - resultsDir_exists <- results_dir %>% dir.exists() - heatDir_exists <- heat_dir %>% dir.exists() - ribDir_exists <- ann_dir %>% dir.exists() + dir_exists <- directory |> dir.exists() + resultsDir_exists <- results_dir |> dir.exists() + heatDir_exists <- heat_dir |> dir.exists() + ribDir_exists <- ann_dir |> dir.exists() } else{ if(!resultsDir_exists){ ### Try to create directories - try_resultsDir <- try(results_dir %>% dir.create(), silent=T) - if(doHeat) try_heat <- try(heat_dir %>% dir.create(), silent=T) - if(doAnn) try_rib <- try(ann_dir %>% dir.create(), silent=T) + try_resultsDir <- try(results_dir |> dir.create(), silent=T) + if(doHeat) try_heat <- try(heat_dir |> dir.create(), silent=T) + if(doAnn) try_rib <- try(ann_dir |> dir.create(), silent=T) ### then check if they exist - resultsDir_exists <- results_dir %>% dir.exists() - heatDir_exists <- heat_dir %>% dir.exists() - ribDir_exists <- ann_dir %>% dir.exists() + resultsDir_exists <- results_dir |> dir.exists() + heatDir_exists <- heat_dir |> dir.exists() + ribDir_exists <- ann_dir |> dir.exists() } else{ ### Check for the heatmaps directory if(!heatDir_exists & doHeat){ - try_heat <- try(heat_dir %>% dir.create(), silent=T) - heatDir_exists <- heat_dir %>% dir.exists() + try_heat <- try(heat_dir |> dir.create(), silent=T) + heatDir_exists <- heat_dir |> dir.exists() } ### End if heatmap directory doesn't exist ### Check for the ribbon directory if(!ribDir_exists & doAnn){ - try_rib <- try(ann_dir %>% dir.create(), silent=T) - ribDir_exists <- ann_dir %>% dir.exists() + try_rib <- try(ann_dir |> dir.create(), silent=T) + ribDir_exists <- ann_dir |> dir.exists() } ### End if ribbon directory doesn't exist } ### End if results directory doesn't exist } ### End if directory doesn't exist @@ -198,19 +198,19 @@ get_plots <- function( ###### Data Information ###### ### Sectors, models, regions, combinations - sectorsList <- data$sector %>% unique() - numSectors <- sectorsList %>% length() + sectorsList <- data$sector |> unique() + numSectors <- sectorsList |> length() - modelTypesList <- data$model_type %>% unique() - numModels <- modelTypesList %>% length() + modelTypesList <- data$model_type |> unique() + numModels <- modelTypesList |> length() - regionsList <- data$region %>% unique() - numRegions <- regionsList %>% length() + regionsList <- data$region |> unique() + numRegions <- regionsList |> length() ### Unique sectors, variants, impact types ### impact types - impactTypes <- data$impactType %>% unique() - numImpactTypes <- impactTypes %>% length() + impactTypes <- data$impactType |> unique() + numImpactTypes <- impactTypes |> length() ### Unique Groups if(is.null(groupVars)){groupVars <- c("sector", "variant")} @@ -251,7 +251,7 @@ get_plots <- function( ###### Plot Labels ###### ### Base label for impacts and unit - base_plot_label <- discount_uc %>% paste("Annual Impacts") + base_plot_label <- discount_uc |> paste("Annual Impacts") base_unitStart <- "(" base_unitEnd <- "2015$)" ylab_unitEnd <- base_unitEnd @@ -261,24 +261,24 @@ get_plots <- function( message("\t", "Creating heat maps of impacts...") ### Adjust data: remove national total for heatmaps ### Non NA values - # dataHeat <- data %>% filter(region!="National Total") + # dataHeat <- data |> filter(region!="National Total") dataHeat <- data - non_na_heat <- which(!is.na(dataHeat[,column])) %>% length() + non_na_heat <- which(!is.na(dataHeat[,column])) |> length() ###### Get Limits ###### if(non_na_heat>0){ - heat_scaleInfo <- dataHeat %>% fun_getScale(scaleCol = "valueColumn") + heat_scaleInfo <- dataHeat |> fun_getScale(scaleCol = "valueColumn") heat_power1000 <- heat_scaleInfo$power1000 which_globUnit <- which(df_units$log10mod3<=heat_power1000) if(length(which_globUnit) > 0){ ### Scale - globMax_unit <- df_units %>% filter(log10mod3==max(df_units$log10mod3[which_globUnit])) - scale_global <- globMax_unit$unitValue %>% max + globMax_unit <- df_units |> filter(log10mod3==max(df_units$log10mod3[which_globUnit])) + scale_global <- globMax_unit$unitValue |> max() unit_global <- globMax_unit$unitLabel[which(globMax_unit$unitValue==scale_global)] ### Adjust data - dataHeat <- dataHeat %>% mutate(valueColumn = valueColumn/scale_global) + dataHeat <- dataHeat |> mutate(valueColumn = valueColumn/scale_global) ### Adjust unit scale label if(unit_global!=""){ ylab_unitEnd <- paste0(unit_global, ", ", base_unitEnd) @@ -289,56 +289,56 @@ get_plots <- function( c_heatMapYears <- seq(minYear, maxYear, by = 5) ##### Y Label - impactLab_heat <- base_plot_label %>% paste(base_unitStart) %>% paste0(ylab_unitEnd) - # yLab_heat <- groupVarLabels %>% paste(base_unitStart, collapse=", ") - groupLab_heat <- groupVarLabels %>% paste(collapse = ", " ) - yLab_heat <- impactLab_heat %>% paste0(", by ", groupLab_heat) + impactLab_heat <- base_plot_label |> paste(base_unitStart) |> paste0(ylab_unitEnd) + # yLab_heat <- groupVarLabels |> paste(base_unitStart, collapse=", ") + groupLab_heat <- groupVarLabels |> paste(collapse = ", " ) + yLab_heat <- impactLab_heat |> paste0(", by ", groupLab_heat) ### Iterate over model types for(modelType_i in modelTypesList){ ### Data for Model - # data_model_i <- data %>% filter(model_type == modelType_i) + # data_model_i <- data |> filter(model_type == modelType_i) - # data_model_i <- data %>% filter(model_type == modelType_i) - data_model_i <- dataHeat %>% filter(model_type == modelType_i) + # data_model_i <- data |> filter(model_type == modelType_i) + data_model_i <- dataHeat |> filter(model_type == modelType_i) ### Refactor model names if(tolower(modelType_i)=="slr"){ # refModelList <- c(paste(c(0, 30, seq(50, 250, by=50)), "cm"), "Interpolation") - # data_model_i <- data_model_i %>% mutate(model = model %>% factor(levels=refModelList)) + # data_model_i <- data_model_i |> mutate(model = model |> factor(levels=refModelList)) refModelList <- c("Interpolation") - data_model_i <- data_model_i %>% mutate(model = model %>% as.character %>% factor(levels=refModelList)) - # data_model_i %>% filter(!is.na(valueColumn)) %>% filter(year > 2090) %>% nrow %>% print - # (data_model_i %>% filter(!is.na(valueColumn)) %>% filter(year > 2090))$valueColumn %>% range %>% print + data_model_i <- data_model_i |> mutate(model = model |> as.character() |> factor(levels=refModelList)) + # data_model_i |> filter(!is.na(valueColumn)) |> filter(year > 2090) |> nrow() |> print() + # (data_model_i |> filter(!is.na(valueColumn)) |> filter(year > 2090))$valueColumn |> range() |> print() } else{ - data_model_i <- data_model_i %>% mutate( model = model %>% as.character()) - models_i <- data_model_i$model %>% as.character %>% unique + data_model_i <- data_model_i |> mutate( model = model |> as.character()) + models_i <- data_model_i$model |> as.character() |> unique() is_aveCol_i <- (models_i == "Average" | models_i == "Model Average") ### Put average columns last - modelLevels_i <- models_i[which(!is_aveCol_i)] %>% c(models_i[which(is_aveCol_i)]) - # models_i %>% print; modelLevels_i %>% print - data_model_i <- data_model_i %>% mutate(model = model %>% as.character %>% factor(levels=modelLevels_i)) + modelLevels_i <- models_i[which(!is_aveCol_i)] |> c(models_i[which(is_aveCol_i)]) + # models_i |> print(); modelLevels_i |> print() + data_model_i <- data_model_i |> mutate(model = model |> as.character() |> factor(levels=modelLevels_i)) - # data_model_i %>% filter(!is.na(valueColumn)) %>% filter(model%in% c("GCM Ensemble", "MRI-CGCM3")) %>% nrow %>% print - # (data_model_i %>% filter(!is.na(valueColumn)) %>% filter(model%in% c("GCM Ensemble", "MRI-CGCM3")))$valueColumn %>% range(na.rm=T) %>% print + # data_model_i |> filter(!is.na(valueColumn)) |> filter(model%in% c("GCM Ensemble", "MRI-CGCM3")) |> nrow() |> print() + # (data_model_i |> filter(!is.na(valueColumn)) |> filter(model%in% c("GCM Ensemble", "MRI-CGCM3")))$valueColumn |> range(na.rm=T) |> print() } ### Unique sectors, variants, impact types - unique_combos_heat <- data_model_i %>% group_by_at(.vars = groupVars) %>% summarize(n=n()) - numCombos_heat <- unique_combos_heat %>% nrow() - data_model_i$group_name <- (1:nrow(data_model_i)) %>% lapply(function(j){ - # data_model_i[j, groupVars] %>% paste(collapse="\n\t") - data_model_i[j, groupVars] %>% paste(collapse=", ") - }) %>% unlist() + unique_combos_heat <- data_model_i |> group_by_at(.vars = groupVars) |> summarize(n=n()) + numCombos_heat <- unique_combos_heat |> nrow() + data_model_i$group_name <- (1:nrow(data_model_i)) |> lapply(function(j){ + # data_model_i[j, groupVars] |> paste(collapse="\n\t") + data_model_i[j, groupVars] |> paste(collapse=", ") + }) |> unlist() rm("unique_combos_heat") - # numCombos_heat %>% print() + # numCombos_heat |> print() ### Height Info fig_heat_ht_model <- base_heat_ht + base_heat_ht_per * numCombos_heat * numRegions assign(paste("fig_heat_ht", tolower(modelType_i), sep="_"), fig_heat_ht_model) - # fig_heat_ht_model %>% print + # fig_heat_ht_model |> print() ### Model Title @@ -348,13 +348,13 @@ get_plots <- function( p_title <- paste(p_title_i_obj, collapse = " ") ### Model Plot - p_model <- data_model_i %>% - # arrange(desc(group_name)) %>% - # mutate(valueColumn = valueColumn / (10^3)^heat_power1000 ) %>% - # filter(year %in% seq(2010, 2090, by=5)) %>% - filter(year %in% c_heatMapYears) %>% - mutate(group_name = group_name %>% factor) %>% - mutate(group_name = group_name %>% factor(levels=rev(levels(group_name)))) %>% + p_model <- data_model_i |> + # arrange(desc(group_name)) |> + # mutate(valueColumn = valueColumn / (10^3)^heat_power1000 ) |> + # filter(year %in% seq(2010, 2090, by=5)) |> + filter(year %in% c_heatMapYears) |> + mutate(group_name = group_name |> factor()) |> + mutate(group_name = group_name |> factor(levels=rev(levels(group_name)))) |> ggplot(., aes(x=year, y=group_name, fill=valueColumn)) + geom_tile(color = "white") + scale_fill_gradient2(impactLab_heat, low="darkblue", high="darkred") + @@ -387,44 +387,44 @@ get_plots <- function( ###### Get Plots for Each Sector ###### for(sector_i in sectorsList){ - # sector_i %>% print + # sector_i |> print() ### Initialize plot list and titles plot0_list <- list() base_rib_title <- sector_i ylab_unitEnd_i <- base_unitEnd ### Base unit ### Filter to data and get number of variants - data0_i <- data %>% filter(sector==sector_i) %>% - filter(model!="Average") %>% - filter(model!="Model Average") %>% + data0_i <- data |> filter(sector==sector_i) |> + filter(model!="Average") |> + filter(model!="Model Average") |> as.data.frame() - model_type_i <- (data0_i$model_type %>% unique)[1] ### Refactor model names + model_type_i <- (data0_i$model_type |> unique())[1] ### Refactor model names ### Number of models - models_i <- data0_i$model %>% unique - n_models_i <- models_i %>% length + models_i <- data0_i$model |> unique() + n_models_i <- models_i |> length() if(tolower(model_type_i)=="slr"){ refModelList <- c("Interpolation") - data0_i <- data0_i %>% mutate(model = model %>% factor(levels=refModelList)) + data0_i <- data0_i |> mutate(model = model |> factor(levels=refModelList)) } else{ - # models_i <- data0_i$model %>% unique + # models_i <- data0_i$model |> unique() is_aveCol_i <- (models_i == "Average" | models_i == "Model Average") ### Put average columns last - modelLevels_i <- models_i[which(!is_aveCol_i)] %>% c(models_i[which(is_aveCol_i)]) - data0_i <- data0_i %>% mutate(model = model %>% factor(levels=modelLevels_i)) + modelLevels_i <- models_i[which(!is_aveCol_i)] |> c(models_i[which(is_aveCol_i)]) + data0_i <- data0_i |> mutate(model = model |> factor(levels=modelLevels_i)) } ### Get model averages for undiscounted a ### Annual undiscounted: convert to millions and then get averages if(tolower(model_type_i)=="gcm"){ # if(n_models_i>1){ - data0_i <- data0_i %>% + data0_i <- data0_i |> get_annual_model_stats(yVar = "valueColumn", groupCol = c(groupVars, "region", "year")) - has_non_na_i <- (data0_i %>% filter(!is.na(modelMax)) %>% nrow()) > 0 + has_non_na_i <- (data0_i |> filter(!is.na(modelMax)) |> nrow()) > 0 } else{ - has_non_na_i <- (data0_i %>% filter(!is.na(valueColumn)) %>% nrow()) > 0 + has_non_na_i <- (data0_i |> filter(!is.na(valueColumn)) |> nrow()) > 0 } @@ -433,11 +433,11 @@ get_plots <- function( if(has_non_na_i){ # if(n_models_i>1){ if(tolower(model_type_i)=="gcm"){ - ann_scaleInfo <- data0_i %>% - gather(key="valueType", value="valueColumn", c("modelMin", "modelAve", "modelMax")) %>% + ann_scaleInfo <- data0_i |> + gather(key="valueType", value="valueColumn", c("modelMin", "modelAve", "modelMax")) |> fun_getScale(scaleCol = "valueColumn") } else{ - ann_scaleInfo <- data0_i %>% fun_getScale(scaleCol = "valueColumn") + ann_scaleInfo <- data0_i |> fun_getScale(scaleCol = "valueColumn") } ann_power1000 <- ann_scaleInfo$power1000 @@ -447,19 +447,19 @@ get_plots <- function( ### If there is a scalar that exists, scale the data if(length(which_i_unit) > 0){ - max_i_unit <- df_units %>% filter(log10mod3==max(df_units$log10mod3[which_i_unit])) - scale_i <- max_i_unit$unitValue %>% max + max_i_unit <- df_units |> filter(log10mod3==max(df_units$log10mod3[which_i_unit])) + scale_i <- max_i_unit$unitValue |> max() unit_i <- max_i_unit$unitLabel[which(max_i_unit$unitValue==scale_i)] - # ann_power1000 %>% print - # scale_i %>% print + # ann_power1000 |> print() + # scale_i |> print() ### Scale the data # if(n_models_i>1){ if(tolower(model_type_i)=="gcm"){ - data0_i <- data0_i %>% mutate(modelAve = modelAve/scale_i, modelMin=modelMin/scale_i, modelMax=modelMax/scale_i) - # data0_i <- data0_i %>% mutate_at(.vars=c("modelAve", "modelMin", "modelMax"), function(y){y/scale_i}) + data0_i <- data0_i |> mutate(modelAve = modelAve/scale_i, modelMin=modelMin/scale_i, modelMax=modelMax/scale_i) + # data0_i <- data0_i |> mutate_at(.vars=c("modelAve", "modelMin", "modelMax"), function(y){y/scale_i}) } else{ - data0_i <- data0_i %>% mutate(valueColumn = valueColumn/scale_i) + data0_i <- data0_i |> mutate(valueColumn = valueColumn/scale_i) } ylab_unitEnd_i <- paste0(unit_i, ", ", base_unitEnd) @@ -467,28 +467,28 @@ get_plots <- function( ### Plot label for y yLab_unit_i <- paste0(base_unitStart, ylab_unitEnd_i) - yLab0_reg_i <- base_plot_label %>% paste(yLab_unit_i) - yLab0_nat_i <- base_plot_label %>% paste(yLab_unit_i) + yLab0_reg_i <- base_plot_label |> paste(yLab_unit_i) + yLab0_nat_i <- base_plot_label |> paste(yLab_unit_i) ### Get regional plots) # if(n_models_i>1){ if(tolower(model_type_i)=="gcm"){ - plot0_reg_i <- data0_i %>% - filter(region!="National Total") %>% + plot0_reg_i <- data0_i |> + filter(region!="National Total") |> ggplot() + geom_ribbon( aes(x=year, ymin=modelMin, ymax = modelMax, fill=region), alpha=0.25) + geom_line(aes(x=year, y=modelAve, colour=region, linetype=model), size = 0.5, alpha=0.85) } else{ - plot0_reg_i <- data0_i %>% - filter(region!="National Total") %>% + plot0_reg_i <- data0_i |> + filter(region!="National Total") |> ggplot() + geom_line(aes(x=year, y=valueColumn, colour=region, linetype=model), size = 0.5, alpha=0.85) } plot0_reg_i <- plot0_reg_i + - # data0_i %>% - # filter(region!="National Total") %>% + # data0_i |> + # filter(region!="National Total") |> # # ggplot() + # geom_ribbon( aes(x=year, ymin=modelMin, ymax = modelMax, fill=region), alpha=0.25) + @@ -518,20 +518,20 @@ get_plots <- function( ### Facet the plot, and scales if("National Total" %in% regionsList){ if(tolower(model_type_i)=="gcm"){ - plot0_nat_i <- data0_i %>% filter(region=="National Total") %>% + plot0_nat_i <- data0_i |> filter(region=="National Total") |> ggplot() + geom_ribbon(aes(x=year, ymin=modelMin, ymax = modelMax), fill = "grey24", alpha=0.25) + geom_line(aes(x=year, y=modelAve, linetype=model), size = 0.5, colour = "grey24", alpha=0.85) } else{ - plot0_nat_i <- data0_i %>% filter(region=="National Total") %>% + plot0_nat_i <- data0_i |> filter(region=="National Total") |> ggplot() + geom_line(aes(x=year, y=valueColumn, linetype=model), size = 0.5, colour = "grey24", alpha=0.85) } plot0_nat_i <- plot0_nat_i + - # data0_i %>% filter(region=="National Total") %>% + # data0_i |> filter(region=="National Total") |> # # ggplot() + # geom_ribbon(aes(x=year, ymin=modelMin, ymax = modelMax), fill = "grey24", alpha=0.25) + @@ -566,21 +566,21 @@ get_plots <- function( ### Save images and plot list if the results directory exists if(resultsDir_exists){ message("\t", "Saving results...") - fpath_data <- results_dir %>% file.path("outputPlots.RData") - list_plotOuts %>% save(file=fpath_data) + fpath_data <- results_dir |> file.path("outputPlots.RData") + list_plotOuts |> save(file=fpath_data) ###### Save heat maps ###### ### Save heatmaps if the directory exists if(heatDir_exists & doHeat){ message("\t\t", "Saving heatmaps...") - heatMaps <- list_plotOuts[["heatmaps"]] %>% names + heatMaps <- list_plotOuts[["heatmaps"]] |> names() ### Iterate Over Model Types for(modelType_i in heatMaps){ ### File name and path - fName_i <- discount_lc %>% - paste("impacts_as_heatmap_by", modelType_i, sep="_") %>% + fName_i <- discount_lc |> + paste("impacts_as_heatmap_by", modelType_i, sep="_") |> paste(def_img_device, sep=".") - fPath_i <- heat_dir %>% file.path(fName_i) + fPath_i <- heat_dir |> file.path(fName_i) ### Plot i plot_i <- list_plotOuts[["heatmaps"]][[modelType_i]] ### Plot height @@ -592,7 +592,7 @@ get_plots <- function( if("ggplot" %in% class(plot_i) & !is.null(plot_i)){ ### Try to save the file try_heat <- try( - fPath_i %>% + fPath_i |> ggsave( plot = plot_i, device = def_img_device, @@ -616,29 +616,29 @@ get_plots <- function( ### Save ribbon plots if the directory exists if(ribDir_exists & doAnn){ message("\t\t", "Saving ribbon plots...") - sectorPlots <- list_plotOuts[["ribbon"]] %>% names + sectorPlots <- list_plotOuts[["ribbon"]] |> names() for(sector_i in sectorPlots){ plotList0_i <- list_plotOuts[["ribbon"]][[sector_i]] ### Number of variants - num_variant_i <- (data %>% filter(sector == sector_i))$variant %>% unique() %>% length() + num_variant_i <- (data |> filter(sector == sector_i))$variant |> unique() |> length() def_rib_width <- base_rib_width + base_rib_width_per * num_variant_i ### Regions for j - regions_i <- plotList0_i %>% names + regions_i <- plotList0_i |> names() for(region_j in regions_i){ ### Plot k plot_j <- plotList0_i[[region_j]] if(!is.null(plot_j)){ ### File names and shorten - fPath_j <- sector_i %>% - paste(region_j, sep="_") %>% - paste(def_img_device, sep=".") %>% - (function(y){gsub("/", "", y)}) - fPath_j <- ann_dir %>% file.path(fPath_j) %>% - (function(k){gsub(" and ", "", k)}) %>% - (function(k){gsub("Variant", "", k)}) %>% - (function(k){gsub(" ", "", k)}) + fPath_j <- sector_i |> + paste(region_j, sep="_") |> + paste(def_img_device, sep=".") |> + (function(y){gsub("/", "", y)})() + fPath_j <- ann_dir |> file.path(fPath_j) |> + (function(k){gsub(" and ", "", k)})() |> + (function(k){gsub("Variant", "", k)})() |> + (function(k){gsub(" ", "", k)})() ### Plot height num_reg_i <- ifelse(region_j=="national", 1, numRegions) @@ -649,7 +649,7 @@ get_plots <- function( if("ggplot" %in% class(plot_j) & !is.null(plot_j)){ ### Save plot try_j <- try( - fPath_j %>% + fPath_j |> ggsave(plot = plot_j, device = def_img_device, width = fig_rib_width, diff --git a/FrEDI/R/get_sectorInfo.R b/FrEDI/R/get_sectorInfo.R index e0f21202..d7eb5223 100644 --- a/FrEDI/R/get_sectorInfo.R +++ b/FrEDI/R/get_sectorInfo.R @@ -51,26 +51,26 @@ get_sectorInfo <- function( # co_sectorsRef$sector_label assign("co_sectorsRef", rDataList[["co_sectors"]]) - co_sectorsRef <- co_sectorsRef %>% - select(-c("sector_id")) %>% - rename(sector = sector_label) %>% - rename(model_type = modelType) %>% - mutate(model_type = model_type %>% toupper) + co_sectorsRef <- co_sectorsRef |> + select(-c("sector_id")) |> + rename(sector = sector_label) |> + rename(model_type = modelType) |> + mutate(model_type = model_type |> toupper()) ### Sort - co_sectorsRef <- co_sectorsRef %>% arrange_at(.vars=c("sector")) + co_sectorsRef <- co_sectorsRef |> arrange_at(.vars=c("sector")) ### GCM or SLR gcm_string <- "GCM" if(gcmOnly){ - co_sectorsRef <- co_sectorsRef %>% filter(model_type==gcm_string) + co_sectorsRef <- co_sectorsRef |> filter(model_type==gcm_string) } else if(slrOnly){ - co_sectorsRef <- co_sectorsRef %>% filter(model_type!=gcm_string) + co_sectorsRef <- co_sectorsRef |> filter(model_type!=gcm_string) } ### If not description, return names only if(!description){ return_obj <- co_sectorsRef$sector } else{ - return_obj <- co_sectorsRef %>% as.data.frame + return_obj <- co_sectorsRef |> as.data.frame() } return(return_obj) diff --git a/FrEDI/R/import_inputs.R b/FrEDI/R/import_inputs.R index 47b9051a..1ea0cc71 100644 --- a/FrEDI/R/import_inputs.R +++ b/FrEDI/R/import_inputs.R @@ -40,19 +40,19 @@ #' #' @examples #' ### Path to example scenarios -#' scenariosPath <- system.file(package="FrEDI") %>% file.path("extdata","scenarios") +#' scenariosPath <- system.file(package="FrEDI") |> file.path("extdata","scenarios") #' #' ### View example scenario names -#' scenariosPath %>% list.files +#' scenariosPath |> list.files() #' #' ### Temperature Scenario File Name -#' tempInputFile <- scenariosPath %>% file.path("GCAM_scenario.csv") +#' tempInputFile <- scenariosPath |> file.path("GCAM_scenario.csv") #' #' ### SLR Scenario File Name -#' slrInputFile <- scenariosPath %>% file.path("slr_from_gcam.csv") +#' slrInputFile <- scenariosPath |> file.path("slr_from_gcam.csv") #' #' ### Population Scenario File Name -#' popInputFile <- scenariosPath %>% file.path("pop_scenario.csv") +#' popInputFile <- scenariosPath |> file.path("pop_scenario.csv") #' #' ### Import inputs #' example_inputsList <- import_inputs( @@ -84,17 +84,17 @@ import_inputs <- function( popform = "wide" ### "wide" or "long" ### Previously: "gather", "spread" ){ ###### Messaging ###### - hasAnyInputs <- list(tempfile, slrfile, popfile, gdpfile) %>% - lapply(function(x){!is.null(x)}) %>% - unlist %>% any + hasAnyInputs <- list(tempfile, slrfile, popfile, gdpfile) |> + lapply(function(x){!is.null(x)}) |> + unlist() |> any() silent <- TRUE msgUser <- ifelse(silent, FALSE, TRUE) msg0 <- "" - msg1 <- msg0 %>% paste0("\t") - msg2 <- msg1 %>% paste0("\t") - msg3 <- msg2 %>% paste0("\t") + msg1 <- msg0 |> paste0("\t") + msg2 <- msg1 |> paste0("\t") + msg3 <- msg2 |> paste0("\t") if(hasAnyInputs){ - "\n" %>% paste0(msg0) %>% paste0("In import_inputs():") %>% message + "\n" |> paste0(msg0) |> paste0("In import_inputs():") |> message() } ###### Defaults ###### @@ -108,14 +108,14 @@ import_inputs <- function( ### is declared. Check whether inputs temperatures are already in CONUS degrees temptype_default <- "conus" temptype <- ifelse(is.null(temptype), temptype_default, temptype) - conus <- (tolower(temptype) == "conus"); #conus %>% print + conus <- (tolower(temptype) == "conus"); #conus |> print() ###### Initialize Inputs List ###### ### Get input scenario info: co_inputScenarioInfo name_dfScenarioInfo <- "co_inputScenarioInfo" assign(name_dfScenarioInfo, rDataList[[name_dfScenarioInfo]]) input_names_vector <- co_inputScenarioInfo$inputName - num_inputNames <- co_inputScenarioInfo %>% nrow + num_inputNames <- co_inputScenarioInfo |> nrow() ###### Initialize Results List ###### inputsList <- list() @@ -126,17 +126,17 @@ import_inputs <- function( inputInfo_i <- co_inputScenarioInfo[i,] ### Input name and label - input_i <- inputInfo_i$inputName %>% unique - msgName_i <- inputInfo_i$inputType %>% unique + input_i <- inputInfo_i$inputName |> unique() + msgName_i <- inputInfo_i$inputType |> unique() ### Input argument and run_fredi argument - inputArg_i <- inputInfo_i$importArgName %>% unique - inputName_i <- inputInfo_i$tempBinListName %>% unique + inputArg_i <- inputInfo_i$importArgName |> unique() + inputName_i <- inputInfo_i$tempBinListName |> unique() ### Min and Max Values - min_i <- inputInfo_i$inputMin %>% unique - max_i <- inputInfo_i$inputMax %>% unique + min_i <- inputInfo_i$inputMin |> unique() + max_i <- inputInfo_i$inputMax |> unique() ###### Column Info ###### - region_i <- inputInfo_i$region %>% unique - valueCol_i <- inputInfo_i$valueCol %>% unique + region_i <- inputInfo_i$region |> unique() + valueCol_i <- inputInfo_i$valueCol |> unique() ### Initialize column names numCols_i <- colNames_i <- c("year", valueCol_i) ### Add region column @@ -150,43 +150,43 @@ import_inputs <- function( ###### Parse File ###### ### Parse inputArg_i and add to the list, then check if it is null - inputFile_i <- parse(text=inputArg_i) %>% eval - isNullFile_i <- inputFile_i %>% is.null + inputFile_i <- parse(text=inputArg_i) |> eval() + isNullFile_i <- inputFile_i |> is.null() # list_i[["inputFile"]] <- inputFile_i - # isNullFile_i <- list_i[["inputFile"]] %>% is.null + # isNullFile_i <- list_i[["inputFile"]] |> is.null() ###### Format Data Frame ###### if(!isNullFile_i){ - msg1 %>% paste0("User supplied ", msgName_i, " input...") %>% message - msg2 %>% paste0("Importing data from ", inputFile_i, "...") %>% message + msg1 |> paste0("User supplied ", msgName_i, " input...") |> message() + msg2 |> paste0("Importing data from ", inputFile_i, "...") |> message() ### Try to import the file and initialize the list value - fileInput_i <- inputFile_i %>% fun_tryInput(silent=T) + fileInput_i <- inputFile_i |> fun_tryInput(silent=T) fileStatus_i <- fileInput_i[["fileStatus"]] df_input_i <- fileInput_i[["fileInput"]] ### Message the user - if(msgUser){ msg2 %>% paste0(fileInput_i[["fileMsg"]]) %>% message } + if(msgUser){ msg2 |> paste0(fileInput_i[["fileMsg"]]) |> message() } ######## For loaded data ###### ### If the load is a success, add results to the input list if(fileStatus_i=="loaded"){ - msg2 %>% paste0("Formatting ", msgName_i, " inputs...") %>% message + msg2 |> paste0("Formatting ", msgName_i, " inputs...") |> message() ###### Gather population inputs ###### if(input_i=="pop" & wide_pop){ - msg3 %>% paste0("User specified `popform='wide'`...") %>% - paste0("Gathering population by region...") %>% - message + msg3 |> paste0("User specified `popform='wide'`...") |> + paste0("Gathering population by region...") |> + message() names(df_input_i)[1] <- colNames_i[1] - df_input_i <- df_input_i %>% gather(key = "region", value="reg_pop", -year) + df_input_i <- df_input_i |> gather(key = "region", value="reg_pop", -year) } ###### Standardize All Columns ###### ### Rename Inputs and Convert all columns to numeric ### Rename Inputs and Convert all columns to numeric - df_input_i <- df_input_i %>% - rename_inputs(colNames_i) %>% - mutate_all(as.character) %>% + df_input_i <- df_input_i |> + rename_inputs(colNames_i) |> + mutate_all(as.character) |> mutate_at(vars(all_of(numCols_i)), as.numeric) ###### Convert Global Temps to CONUS ###### @@ -194,37 +194,37 @@ import_inputs <- function( ### aren't already in CONUS degrees if((input_i=="temp") & (!conus)){ ### Message user - msg3 %>% paste0("User specified `temptype='global'`...") %>% message - msg3 %>% paste0("Converting global temperatures to CONUS temperatures...") %>% message + msg3 |> paste0("User specified `temptype='global'`...") |> message() + msg3 |> paste0("Converting global temperatures to CONUS temperatures...") |> message() ### Convert temps - df_input_i <- df_input_i %>% mutate(temp_C = temp_C %>% convertTemps(from="global")) + df_input_i <- df_input_i |> mutate(temp_C = temp_C |> convertTemps(from="global")) } # ###### Check Input ###### - # msg2 %>% paste0("Checking values...") %>% message + # msg2 |> paste0("Checking values...") |> message() # ### Values # values_i <- df_input_i[,valueCol_i] # ### Substitute NULL for missing values for min and max # if(is.na(min_i)) min_i <- NULL; if(is.na(max_i)) max_i <- NULL # ### Check the status - # flag_i <- values_i %>% check_inputs(xmin = min_i, xmax = max_i) + # flag_i <- values_i |> check_inputs(xmin = min_i, xmax = max_i) # ### Return and message the user if there is a flag: # flagStatus_i <- flag_i$flagged # flagRows_i <- flag_i$rows # ### If flag, message user and return flagStatus_i # if(flagStatus_i){ # ### Message labels - # numrows_i <- flagRows_i %>% length + # numrows_i <- flagRows_i |> length() # years_i <- df_input_i$year[flagRows_i]; yearsLabel_i <- paste(years_i, collapse=",") # rangeLabel_i <- paste0("c(", min_i , ",", max_i, ")") # ### Create message and message user - # msg1_i <- msg2 %>% paste("Error in importing inputs for", msgName_i) %>% paste0("!") - # msg2_i <- msg3 %>% paste(inputName_i, "has", numrows_i, "values outside of defined range", rangeLabel_i) - # msg3_i <- msg3 %>% paste("Please correct values", msgName_i, "values for years", yearsLabel_i) %>% paste0("...") + # msg1_i <- msg2 |> paste("Error in importing inputs for", msgName_i) |> paste0("!") + # msg2_i <- msg3 |> paste(inputName_i, "has", numrows_i, "values outside of defined range", rangeLabel_i) + # msg3_i <- msg3 |> paste("Please correct values", msgName_i, "values for years", yearsLabel_i) |> paste0("...") # ### Message user - # "\n" %>% paste0(msg0) %>% paste0("Warning:") %>% message - # msg1_i %>% message; msg2_i %>% message; msg3_i %>% message - # "\n" %>% paste0(msg0) %>% paste0("Exiting...") %>% message + # "\n" |> paste0(msg0) |> paste0("Warning:") |> message() + # msg1_i |> message(); msg2_i |> message(); msg3_i |> message() + # "\n" |> paste0(msg0) |> paste0("Exiting...") |> message() # # ### Return list with error and flagged rows # returnList <- list( @@ -244,7 +244,7 @@ import_inputs <- function( } ### End iterate on i ###### Return input list ###### - msg0 %>% paste0("Finished.") %>% message + msg0 |> paste0("Finished.") |> message() return(inputsList) } diff --git a/FrEDI/R/run_fredi.R b/FrEDI/R/run_fredi.R index 8020b37e..e169d4bd 100644 --- a/FrEDI/R/run_fredi.R +++ b/FrEDI/R/run_fredi.R @@ -76,30 +76,30 @@ #' #' ### Load climate scenarios and glimpse data #' data("gcamScenarios") -#' gcamScenarios %>% glimpse +#' gcamScenarios |> glimpse() #' #' ### Load population scenario and glimpse data #' data(popScenario) -#' popScenario %>% glimpse +#' popScenario |> glimpse() #' #' ### Subset climate scenario -#' temps1 <- gcamScenarios %>% filter(scenario=="ECS_3.0_ref_0") %>% select(year, temp_C) +#' temps1 <- gcamScenarios |> filter(scenario=="ECS_3.0_ref_0") |> select(year, temp_C) #' #' ### Run custom scenario #' run2 <- run_fredi(inputsList=list(tempInput=temps1, popInput=popScenario)) #' #' ### Load scenarios from file: -#' scenariosPath <- system.file(package="FrEDI") %>% file.path("extdata","scenarios") -#' scenariosPath %>% list.files +#' scenariosPath <- system.file(package="FrEDI") |> file.path("extdata","scenarios") +#' scenariosPath |> list.files() #' #' ### Temperature Scenario File Name -#' tempInputFile <- scenariosPath %>% file.path("GCAM_scenario.csv") +#' tempInputFile <- scenariosPath |> file.path("GCAM_scenario.csv") #' #' ### SLR Scenario File Name -#' slrInputFile <- scenariosPath %>% file.path("slr_from_GCAM.csv") +#' slrInputFile <- scenariosPath |> file.path("slr_from_GCAM.csv") #' #' ### Population Scenario File Name -#' popInputFile <- scenariosPath %>% file.path("pop_scenario.csv") +#' popInputFile <- scenariosPath |> file.path("pop_scenario.csv") #' #' ### Import inputs #' x_inputs <- import_inputs( @@ -178,7 +178,7 @@ run_fredi <- function( ### Years maxYear <- maxYear0 list_years <- minYear:maxYear - # maxYear %>% print; list_years %>% max %>% print + # maxYear |> print(); list_years |> max() |> print() ###### Aggregation level ###### ### Types of summarization to do: default @@ -186,7 +186,7 @@ run_fredi <- function( aggList0 <- c("national", "modelaverage", "impactyear", "impacttype") if(!is.null(aggLevels)){ ### Aggregation levels - aggLevels <- aggLevels %>% tolower() + aggLevels <- aggLevels |> tolower() aggLevels <- aggLevels[which(aggLevels %in% c(aggList0, "all", "none"))] doAgg <- "none" %in% aggLevels ### If none specified, no aggregation (only SLR interpolation) @@ -232,12 +232,12 @@ run_fredi <- function( } ### End if(length(missing_sectors)>=1) } ### End else(is.null(sectorList)) ### Number of sectors - num_sectors <- sectorList %>% length + num_sectors <- sectorList |> length() ###### Load Inputs ###### ### Create logicals and initialize inputs list list_inputs <- co_inputScenarioInfo$inputName - num_inputNames <- co_inputScenarioInfo %>% nrow + num_inputNames <- co_inputScenarioInfo |> nrow() if(is.null(inputsList)) {inputsList <- list()}else{message("Checking input values...")} ### Iterate over the input list @@ -246,16 +246,16 @@ run_fredi <- function( for(i in 1:num_inputNames){ inputInfo_i <- co_inputScenarioInfo[i,] ### Input name and label - input_i <- inputInfo_i$inputName %>% unique - msgName_i <- inputInfo_i$inputType %>% unique + input_i <- inputInfo_i$inputName |> unique() + msgName_i <- inputInfo_i$inputType |> unique() ### Input run_fredi argument - inputName_i <- inputInfo_i$tempBinListName %>% unique + inputName_i <- inputInfo_i$tempBinListName |> unique() ### Min and Max Values - min_i <- inputInfo_i$inputMin %>% unique - max_i <- inputInfo_i$inputMax %>% unique + min_i <- inputInfo_i$inputMin |> unique() + max_i <- inputInfo_i$inputMax |> unique() ###### Column Info ###### - region_i <- inputInfo_i$region %>% unique - valueCol_i <- inputInfo_i$valueCol %>% unique + region_i <- inputInfo_i$region |> unique() + valueCol_i <- inputInfo_i$valueCol |> unique() ### Initialize column names numCols_i <- colNames_i <- c("year", valueCol_i) #; print(colNames_i) ### Add region column @@ -286,8 +286,8 @@ run_fredi <- function( ### User inputs: temperatures have already been converted to CONUS temperatures. Filter to desired range. ### Name the reference year temperature ### Add the point where impacts are zero - refYear_temp <- (co_modelTypes %>% filter(modelUnitType=="temperature"))$modelRefYear %>% unique - # co_modelTypes %>% names %>% print + refYear_temp <- (co_modelTypes |> filter(modelUnitType=="temperature"))$modelRefYear |> unique() + # co_modelTypes |> names() |> print() ### If no user input (default): Use temperature scenario for one region if(has_tempUpdate){ @@ -295,25 +295,25 @@ run_fredi <- function( ### Select appropriate columns ### Remove missing values of years, temperatures ### Zero out series at the temperature reference year - tempInput <- tempInput %>% select(c("year", "temp_C")) - tempInput <- tempInput %>% filter(!is.na(temp_C) & !(is.na(year))) - tempInput <- tempInput %>% filter(year > refYear_temp) - tempInput <- data.frame(year= refYear_temp, temp_C = 0) %>% rbind(tempInput) + tempInput <- tempInput |> select(c("year", "temp_C")) + tempInput <- tempInput |> filter(!is.na(temp_C) & !(is.na(year))) + tempInput <- tempInput |> filter(year > refYear_temp) + tempInput <- data.frame(year= refYear_temp, temp_C = 0) |> rbind(tempInput) ### Interpolate annual values and then drop region - temp_df <- tempInput %>% (function(x){ - minYear_x <- x$year %>% min + temp_df <- tempInput (function(x){ + minYear_x <- x$year |> min() interpYrs <- refYear_temp:maxYear ### Interpolate - x_interp <- x %>% interpolate_annual( + x_interp <- x |> interpolate_annual( years = interpYrs, column = "temp_C", rule = 1:2 - ) %>% select(-c("region")) + ) |> select(-c("region")) return(x_interp) - }) - temp_df <- temp_df %>% rename(temp_C_conus = temp_C) - temp_df <- temp_df %>% mutate(temp_C_global = temp_C_conus %>% convertTemps(from="conus")) + })() + temp_df <- temp_df |> rename(temp_C_conus = temp_C) + temp_df <- temp_df |> mutate(temp_C_global = temp_C_conus |> convertTemps(from="conus")) # rm("tempInput") } ### End if(has_tempUpdate) ### Load default temperature scenario @@ -322,12 +322,12 @@ run_fredi <- function( tempInput <- co_defaultTemps temp_df <- tempInput } ### End else(has_tempUpdate) - # temp_df %>% nrow %>% print + # temp_df |> nrow() |> print() ###### SLR Scenario ###### ### Year where SLR impacts are zero - refYear_slr <- (co_modelTypes %>% filter(modelUnitType=="slr"))$modelRefYear %>% unique - # co_modelTypes %>% names %>% print + refYear_slr <- (co_modelTypes |> filter(modelUnitType=="slr"))$modelRefYear |> unique() + # co_modelTypes |> names() |> print() ### Follow similar procedure to temperatures ### Select appropriate columns @@ -335,22 +335,22 @@ run_fredi <- function( ### Zero out series at the temperature reference year if(has_slrUpdate){ message("Creating SLR scenario from user inputs...") - slrInput <- slrInput %>% select(c("year", "slr_cm")) - slrInput <- slrInput %>% filter(!is.na(slr_cm) & !is.na(year)) - slrInput <- slrInput %>% filter(year > refYear_slr) - slrInput <- data.frame(year= refYear_slr, slr_cm = 0) %>% rbind(slrInput) + slrInput <- slrInput |> select(c("year", "slr_cm")) + slrInput <- slrInput |> filter(!is.na(slr_cm) & !is.na(year)) + slrInput <- slrInput |> filter(year > refYear_slr) + slrInput <- data.frame(year= refYear_slr, slr_cm = 0) |> rbind(slrInput) ### Interpolate values - slr_df <- slrInput %>% (function(x){ - minYear_x <- x$year %>% min + slr_df <- slrInput |> (function(x){ + minYear_x <- x$year |> min() interpYrs <- refYear_slr:maxYear ### Interpolate annual values - x_interp <- x %>% interpolate_annual( + x_interp <- x |> interpolate_annual( years = interpYrs, column = "slr_cm", rule = 1:2 - ) %>% select(-c("region")) + ) |> select(-c("region")) return(x_interp) - }) + })() # rm("slrInput") } ### else(has_slrUpdate) ### If there is no SLR scenario, calculate from temperatures @@ -358,29 +358,29 @@ run_fredi <- function( ### Then convert global temps to SLR else{ message("Creating SLR scenario from temperature scenario...") - slr_df <- temp_df %>% (function(x){temps2slr(temps = x$temp_C_global, years = x$year)}) + slr_df <- temp_df |> (function(x){temps2slr(temps = x$temp_C_global, years = x$year)})() } ### End else(has_slrUpdate) - # slr_df %>% nrow %>% print - # slr_df %>% head %>% print - # slr_df$year %>% range %>% print + # slr_df |> nrow() |> print() + # slr_df |> head() |> print() + # slr_df$year |> range() |> print() ###### Driver Scenario ###### ### Format the temperature and SLR values - temp_df <- temp_df %>% select(c("year", "temp_C_conus")) %>% - rename(modelUnitValue = temp_C_conus) %>% mutate(modelType="gcm") - slr_df <- slr_df %>% select(c("year", "slr_cm")) %>% - rename(modelUnitValue=slr_cm) %>% mutate(modelType="slr") + temp_df <- temp_df |> select(c("year", "temp_C_conus")) |> + rename(modelUnitValue = temp_C_conus) |> mutate(modelType="gcm") + slr_df <- slr_df |> select(c("year", "slr_cm")) |> + rename(modelUnitValue=slr_cm) |> mutate(modelType="slr") ###### Combine Scenarios and bind with the model type info ### R Bind the SLR values ### Join with info about models ### Filter to the years used by the R tool - co_modelTypes <- co_modelTypes %>% rename(modelType = modelType_id) - co_modelType0 <- co_modelTypes %>% select(c("modelType")) - df_drivers <- temp_df %>% rbind(slr_df) - df_drivers <- df_drivers %>% filter( year >= minYear) %>% filter(year <= maxYear) - # df_drivers %>% names %>% print; co_modelType0 %>% names %>% print - df_drivers <- df_drivers %>% left_join(co_modelType0, by = "modelType") + co_modelTypes <- co_modelTypes |> rename(modelType = modelType_id) + co_modelType0 <- co_modelTypes |> select(c("modelType")) + df_drivers <- temp_df |> rbind(slr_df) + df_drivers <- df_drivers |> filter( year >= minYear) |> filter(year <= maxYear) + # df_drivers |> names() |> print(); co_modelType0 |> names() |> print() + df_drivers <- df_drivers |> left_join(co_modelType0, by = "modelType") ### Update inputs in outputs list returnList[["driverScenarios"]][["temp"]] <- temp_df returnList[["driverScenarios"]][["slr" ]] <- slr_df @@ -394,13 +394,13 @@ run_fredi <- function( popCols0 <- c("year", "region", "reg_pop") if(has_gdpUpdate){ message("Creating GDP scenario from user inputs...") - gdp_df <- gdpInput %>% filter(!is.na(gdp_usd)) %>% filter(!is.na(year)) - gdp_df <- gdp_df %>% interpolate_annual(years= c(list_years), column = "gdp_usd", rule = 2) %>% select(-c("region")) + gdp_df <- gdpInput |> filter(!is.na(gdp_usd)) |> filter(!is.na(year)) + gdp_df <- gdp_df |> interpolate_annual(years= c(list_years), column = "gdp_usd", rule = 2) |> select(-c("region")) rm("gdpInput") } ### End if(has_gdpUpdate) else{ message("No GDP scenario provided...Using default GDP scenario...") - gdp_df <- gdp_default %>% select(c(all_of(gdpCols0))) + gdp_df <- gdp_default |> select(c(all_of(gdpCols0))) rm("gdp_default") } ### End else(has_gdpUpdate) @@ -408,42 +408,42 @@ run_fredi <- function( if(has_popUpdate){ message("Creating Population scenario from user inputs...") ### Standardize region and then interpolate - pop_df <- popInput %>% mutate(region = gsub(" ", ".", region)) - pop_df <- pop_df %>% interpolate_annual(years= c(list_years), column = "reg_pop", rule = 2) %>% ungroup - # pop_df %>% glimpse + pop_df <- popInput |> mutate(region = gsub(" ", ".", region)) + pop_df <- pop_df |> interpolate_annual(years= c(list_years), column = "reg_pop", rule = 2) |> ungroup() + # pop_df |> glimpse() ### Calculate national population - national_pop <- pop_df %>% group_by_at(.vars=c("year")) %>% summarize_at(.vars=c("reg_pop"), sum, na.rm=T) %>% ungroup - national_pop <- national_pop %>% rename(national_pop = reg_pop) - # national_pop %>% glimpse + national_pop <- pop_df |> group_by_at(.vars=c("year")) |> summarize_at(.vars=c("reg_pop"), sum, na.rm=T) |> ungroup() + national_pop <- national_pop |> rename(national_pop = reg_pop) + # national_pop |> glimpse() rm("popInput") } ### if(has_popUpdate) else{ message("Creating Population scenario from defaults...") ### Select columns and filter - pop_df <- pop_default %>% select(c(all_of(popCols0))) - national_pop <- national_pop_default %>% select("year", "national_pop") + pop_df <- pop_default |> select(c(all_of(popCols0))) + national_pop <- national_pop_default |> select("year", "national_pop") rm("pop_default", "national_pop_default") } ### End else(has_popUpdate) ### Message user if(has_gdpUpdate|has_popUpdate){if(msgUser){messages_data[["updatePopGDP"]]}} ### Filter to correct years - gdp_df <- gdp_df %>% filter(year >= minYear) %>% filter(year <= maxYear) - pop_df <- pop_df %>% filter(year >= minYear) %>% filter(year <= maxYear) - national_pop <- national_pop %>% filter(year >= minYear) %>% filter(year <= maxYear) + gdp_df <- gdp_df |> filter(year >= minYear) |> filter(year <= maxYear) + pop_df <- pop_df |> filter(year >= minYear) |> filter(year <= maxYear) + national_pop <- national_pop |> filter(year >= minYear) |> filter(year <= maxYear) ### National scenario - # gdp_df %>% glimpse; national_pop %>% glimpse; - national_scenario <- gdp_df %>% left_join(national_pop, by=c("year")) - national_scenario <- national_scenario %>% mutate(gdp_percap = gdp_usd/national_pop) + # gdp_df |> glimpse(); national_pop |> glimpse(); + national_scenario <- gdp_df |> left_join(national_pop, by=c("year")) + national_scenario <- national_scenario |> mutate(gdp_percap = gdp_usd/national_pop) ### Update inputs in outputs list returnList[["driverScenarios"]][["gdp"]] <- gdp_df returnList[["driverScenarios"]][["pop"]] <- pop_df - # gdp_df %>% nrow %>% print; national_pop %>% nrow %>% print; national_scenario %>% nrow %>% print + # gdp_df |> nrow() |> print(); national_pop |> nrow() |> print(); national_scenario |> nrow() |> print() rm("gdp_df", "national_pop") ### Updated scenario - updatedScenario <- national_scenario %>% left_join(pop_df, by=c("year")) - updatedScenario <- updatedScenario %>% arrange_at(.vars=c("region", "year")) - # updatedScenario %>% group_by_at(.vars=c("region", "year")) %>% summarize(n=n(), .groups="keep") %>% ungroup %>% filter(n>1) %>% nrow %>% print + updatedScenario <- national_scenario |> left_join(pop_df, by=c("year")) + updatedScenario <- updatedScenario |> arrange_at(.vars=c("region", "year")) + # updatedScenario |> group_by_at(.vars=c("region", "year")) |> summarize(n=n(), .groups="keep") |> ungroup() |> filter(n>1) |> nrow() |> print() ###### Update Scalars ###### if(msgUser) message("", list_messages[["updateScalars"]]$try, "") @@ -451,79 +451,79 @@ run_fredi <- function( # mutateVals0 <- c("reg_pop", "physScalar", "regional") ### Filter main scalars to correct years and filter out regional population ### Join with regPopScalar - df_mainScalars <- df_mainScalars %>% filter(year >= minYear) %>% filter(year <= maxYear) - df_mainScalars <- df_mainScalars %>% filter(scalarName!="reg_pop") - df_mainScalars <- df_mainScalars %>% (function(df0, pop0 = pop_df, popCols = popCols0){ + df_mainScalars <- df_mainScalars |> filter(year >= minYear) |> filter(year <= maxYear) + df_mainScalars <- df_mainScalars |> filter(scalarName!="reg_pop") + df_mainScalars <- df_mainScalars |> (function(df0, pop0 = pop_df, popCols = popCols0){ ### Format population - pop0 <- pop0 %>% select(c(all_of(popCols))) - pop0 <- pop0 %>% rename(value=reg_pop) - pop0 <- pop0 %>% mutate(scalarName = "reg_pop") - pop0 <- pop0 %>% mutate(scalarType = "physScalar") - pop0 <- pop0 %>% mutate(national_or_regional = "regional") + pop0 <- pop0 |> select(c(all_of(popCols))) + pop0 <- pop0 |> rename(value=reg_pop) + pop0 <- pop0 |> mutate(scalarName = "reg_pop") + pop0 <- pop0 |> mutate(scalarType = "physScalar") + pop0 <- pop0 |> mutate(national_or_regional = "regional") ### Bind regional population with other scalars - df0 <- df0 %>% rbind(pop0) + df0 <- df0 |> rbind(pop0) return(df0) - }) + })() ###### NPD Scalars ###### if(do_npd){ ###### Scalars for SLR past 2090 ###### ### Scalars for SLR # slr_sectors <- c("CoastalProperties", "HTF") - co_npdScalars <- data.frame(sector = c("CoastalProperties", "HTF")) %>% - mutate(npd_scalarType = c("gdp_percap", "gdp_usd")) %>% - mutate(c1 = c(1, 0.1625)) %>% - mutate(exp0 = c(ifelse(is.null(elasticity), 0.45, elasticity), 1)) %>% + co_npdScalars <- data.frame(sector = c("CoastalProperties", "HTF")) |> + mutate(npd_scalarType = c("gdp_percap", "gdp_usd")) |> + mutate(c1 = c(1, 0.1625)) |> + mutate(exp0 = c(ifelse(is.null(elasticity), 0.45, elasticity), 1)) |> mutate(c2 = c(0, 0.8375)) ### Columns select0 <- c("year", "gdp_usd", "gdp_percap") gather0 <- c("gdp_usd", "gdp_percap") ### Calculate scalars and gather scalars - npdScalars <- national_scenario %>% filter(year >= refYear) - npdScalars <- npdScalars %>% select(c(all_of(select0))) - npdScalars <- npdScalars %>% gather(key = "npd_scalarType", value="npd_scalarValue", c(all_of(gather0))) + npdScalars <- national_scenario |> filter(year >= refYear) + npdScalars <- npdScalars |> select(c(all_of(select0))) + npdScalars <- npdScalars |> gather(key = "npd_scalarType", value="npd_scalarValue", c(all_of(gather0))) rm("select0", "gather0") ### Get 2090 values and then bind them - npdScalars <- npdScalars %>% (function(npd0, co_npd = co_npdScalars){ + npdScalars <- npdScalars |> (function(npd0, co_npd = co_npdScalars){ #### Columns join0 <- c("npd_scalarType") ### Filter to year and drop year column, rename scalar value - npd1 <- npd0 %>% filter(year == refYear) %>% select(-c("year")) - npd1 <- npd1 %>% rename(npd_scalarValueRef = npd_scalarValue) + npd1 <- npd0 |> filter(year == refYear) |> select(-c("year")) + npd1 <- npd1 |> rename(npd_scalarValueRef = npd_scalarValue) ### Join with scalar and sector info - npd0 <- npd0 %>% left_join(npd1, by = c(all_of(join0))) - npd0 <- npd0 %>% left_join(co_npd, by = c(all_of(join0))) + npd0 <- npd0 |> left_join(npd1, by = c(all_of(join0))) + npd0 <- npd0 |> left_join(co_npd, by = c(all_of(join0))) return(npd0) - }) + })() ### Calculate scalar value and drop scalar columns select0 <- c("c1", "exp0", "npd_scalarValueRef") - npdScalars <- npdScalars %>% mutate(npd_scalarValue = c1 * (npd_scalarValue / npd_scalarValueRef)**exp0) - npdScalars <- npdScalars %>% select(-c(all_of(select0))) + npdScalars <- npdScalars |> mutate(npd_scalarValue = c1 * (npd_scalarValue / npd_scalarValueRef)**exp0) + npdScalars <- npdScalars |> select(-c(all_of(select0))) rm("select0") - # (npdScalars %>% filter(year > 2090))$year %>% head %>% print + # (npdScalars |> filter(year > 2090))$year |> head() |> print() ### Join with regional population - npdScalars <- npdScalars %>% (function(npd0, pop0 = pop_df, refYear0 = refYear){ + npdScalars <- npdScalars |> (function(npd0, pop0 = pop_df, refYear0 = refYear){ ### Columns join0 <- c("year", "region", "reg_pop") ### Separate population - pop1 <- pop0 %>% filter(year >= refYear0) %>% select(c(all_of(join0))) - pop2 <- pop0 %>% filter(year == refYear0) %>% select(c(join0[2:3])) %>% rename(reg_popRef = reg_pop) + pop1 <- pop0 |> filter(year >= refYear0) |> select(c(all_of(join0))) + pop2 <- pop0 |> filter(year == refYear0) |> select(c(join0[2:3])) |> rename(reg_popRef = reg_pop) ### Join by year - npd0 <- npd0 %>% left_join(pop1, by = c("year")) + npd0 <- npd0 |> left_join(pop1, by = c("year")) ### Join by region - npd0 <- npd0 %>% left_join(pop2, by = c("region")) + npd0 <- npd0 |> left_join(pop2, by = c("region")) ### Return return(npd0) - }) + })() ### Calculate value and rename values - npdScalars <- npdScalars %>% mutate(npd_scalarValue = npd_scalarValue + c2 * (reg_pop / reg_popRef)) - npdScalars <- npdScalars %>% select(-c("c2", "reg_pop", "reg_popRef")) + npdScalars <- npdScalars |> mutate(npd_scalarValue = npd_scalarValue + c2 * (reg_pop / reg_popRef)) + npdScalars <- npdScalars |> select(-c("c2", "reg_pop", "reg_popRef")) ### Rename values - npdScalars <- npdScalars %>% mutate(econScalar = npd_scalarValue) - npdScalars <- npdScalars %>% mutate(physEconScalar = npd_scalarValue) - npdScalars <- npdScalars %>% select(-c("npd_scalarValue", "npd_scalarType")) - npdScalars <- npdScalars %>% filter(year > refYear) + npdScalars <- npdScalars |> mutate(econScalar = npd_scalarValue) + npdScalars <- npdScalars |> mutate(physEconScalar = npd_scalarValue) + npdScalars <- npdScalars |> select(-c("npd_scalarValue", "npd_scalarType")) + npdScalars <- npdScalars |> filter(year > refYear) } @@ -536,30 +536,30 @@ run_fredi <- function( message("\t\t", "Using default elasticity values.") }} - initialResults <- df_results0 %>% filter(year >= minYear) %>% filter(year <= maxYear) - initialResults <- initialResults %>% filter(sector %in% sectorList) + initialResults <- df_results0 |> filter(year >= minYear) |> filter(year <= maxYear) + initialResults <- initialResults |> filter(sector %in% sectorList) rm("df_results0") - # paste0("Initial Results: ", nrow(initialResults)) %>% print; initialResults %>% glimpse - # updatedScenario %>% glimpse + # paste0("Initial Results: ", nrow(initialResults)) |> print(); initialResults |> glimpse() + # updatedScenario |> glimpse() ### Update scalar values - # initialResults$region %>% unique %>% print; updatedScenario$region %>% unique %>% print - initialResults <- initialResults %>% left_join(updatedScenario, by = c("year", "region")) - initialResults <- initialResults %>% match_scalarValues(df_mainScalars, scalarType="physScalar") - initialResults <- initialResults %>% get_econAdjValues(scenario = updatedScenario, multipliers=co_econMultipliers[,1]) - initialResults <- initialResults %>% calcScalars(elasticity = elasticity) + # initialResults$region |> unique() |> print(); updatedScenario$region |> unique() |> print() + initialResults <- initialResults |> left_join(updatedScenario, by = c("year", "region")) + initialResults <- initialResults |> match_scalarValues(df_mainScalars, scalarType="physScalar") + initialResults <- initialResults |> get_econAdjValues(scenario = updatedScenario, multipliers=co_econMultipliers[,1]) + initialResults <- initialResults |> calcScalars(elasticity = elasticity) rm("df_mainScalars", "updatedScenario") ### df_mainScalars no longer needed - # paste0("Initial Results: ", nrow(initialResults)) %>% print; initialResults %>% head %>% glimpse + # paste0("Initial Results: ", nrow(initialResults)) |> print(); initialResults |> head() |> glimpse() ###### Initialize Results for NPD ###### if(do_npd){ ### Get initial results for NPD - initialResults_npd <- initialResults %>% filter((sector %in% co_npdScalars$sector & year > refYear)) - initialResults_npd <- initialResults_npd %>% select(-c("econScalar", "physEconScalar")) - initialResults_npd <- initialResults_npd %>% left_join(npdScalars, by = c("sector", "year", "region")); + initialResults_npd <- initialResults |> filter((sector %in% co_npdScalars$sector & year > refYear)) + initialResults_npd <- initialResults_npd |> select(-c("econScalar", "physEconScalar")) + initialResults_npd <- initialResults_npd |> left_join(npdScalars, by = c("sector", "year", "region")); # ### Adjust NPD scalars - initialResults <- initialResults %>% filter(!(sector %in% co_npdScalars$sector & year > refYear)) - initialResults <- initialResults %>% rbind(initialResults_npd) + initialResults <- initialResults |> filter(!(sector %in% co_npdScalars$sector & year > refYear)) + initialResults <- initialResults |> rbind(initialResults_npd) rm("initialResults_npd", "co_npdScalars", "npdScalars") } ### Message the user @@ -568,12 +568,12 @@ run_fredi <- function( ###### Scenario ID ###### ### Create scenario ID and separate by model type - initialResults <- initialResults %>% mutate(model_type=modelType) - initialResults_slr <- initialResults %>% filter(modelType=="slr") - initialResults <- initialResults %>% filter(modelType!="slr") + initialResults <- initialResults |> mutate(model_type=modelType) + initialResults_slr <- initialResults |> filter(modelType=="slr") + initialResults <- initialResults |> filter(modelType!="slr") ### Number of GCM and SLR rows - nrow_gcm <- initialResults %>% nrow - nrow_slr <- initialResults_slr %>% nrow + nrow_gcm <- initialResults |> nrow() + nrow_slr <- initialResults_slr |> nrow() ###### Scaled Impacts ###### ### Initialize and empty data frame df_scenarioResults @@ -585,43 +585,43 @@ run_fredi <- function( ###### GCM Scaled Impacts ###### if(nrow_gcm){ ### Drivers - df_drivers_gcm <- df_drivers %>% filter(modelType == "gcm") + df_drivers_gcm <- df_drivers |> filter(modelType == "gcm") ### Get scenario id - # initialResults_slr <- initialResults_slr %>% get_scenario_id(include=c()) - initialResults <- initialResults %>% left_join(co_models, by="modelType") - initialResults <- initialResults %>% get_scenario_id(include=c("model_dot", "region")) - initialResults <- initialResults %>% select(-c("model_type")) + # initialResults_slr <- initialResults_slr |> get_scenario_id(include=c()) + initialResults <- initialResults |> left_join(co_models, by="modelType") + initialResults <- initialResults |> get_scenario_id(include=c("model_dot", "region")) + initialResults <- initialResults |> select(-c("model_type")) ### Get list of unique impact functions - impFunNames <- list_impactFunctions %>% names %>% unique + impFunNames <- list_impactFunctions |> names() |> unique() ### Check whether the scenario has an impact function (scenarios with all missing values have no functions) - gcmAllFuncs <- initialResults$scenario_id %>% unique + gcmAllFuncs <- initialResults$scenario_id |> unique() df_gcm_i <- data.frame(scenario_id = gcmAllFuncs) - df_gcm_i <- df_gcm_i %>% mutate(hasScenario = (scenario_id %in% impFunNames)*1) + df_gcm_i <- df_gcm_i |> mutate(hasScenario = (scenario_id %in% impFunNames)*1) ### Figure out which have functions which_hasFunc <- which(df_gcm_i$hasScenario==1) gcmHasFuns <- length(which_hasFunc)>=1 gcmNoFuns <- !(length(gcmAllFuncs) == length(which_hasFunc)) - # impFunNames[1:5] %>% print; gcmAllFuncs[1:5] %>% print; which_hasFunc %>% head %>% print + # impFunNames[1:5] |> print(); gcmAllFuncs[1:5] |> print(); which_hasFunc |> head() |> print() ### Get impacts for scenario_ids that have functions if(gcmHasFuns){ - hasFunNames <- df_gcm_i[which_hasFunc, "scenario_id"] %>% unique + hasFunNames <- df_gcm_i[which_hasFunc, "scenario_id"] |> unique() hasFunsList <- list_impactFunctions[which(impFunNames %in% hasFunNames)] ### Get impacts - imp_hasFuns <- hasFunsList %>% interpolate_impacts(xVar = df_drivers_gcm$modelUnitValue, years = df_drivers_gcm$year) - imp_hasFuns <- imp_hasFuns %>% rename(modelUnitValue = xVar) %>% filter(year>=minYear) - imp_hasFuns <- imp_hasFuns %>% select(c(all_of(impactSelectCols))) - # df_scenarioResults %>% names %>% print - df_scenarioResults <- df_scenarioResults %>% rbind(imp_hasFuns) + imp_hasFuns <- hasFunsList |> interpolate_impacts(xVar = df_drivers_gcm$modelUnitValue, years = df_drivers_gcm$year) + imp_hasFuns <- imp_hasFuns |> rename(modelUnitValue = xVar) |> filter(year>=minYear) + imp_hasFuns <- imp_hasFuns |> select(c(all_of(impactSelectCols))) + # df_scenarioResults |> names() |> print() + df_scenarioResults <- df_scenarioResults |> rbind(imp_hasFuns) rm("hasFunNames", "hasFunsList", "imp_hasFuns") } #; return(df_i) if(gcmNoFuns){ imp_noFuns <- df_gcm_i[-which_hasFunc,] - imp_noFuns <- imp_noFuns %>% mutate(scaled_impacts = NA, joinCol = 1) - imp_noFuns <- imp_noFuns %>% left_join(df_drivers_gcm %>% mutate(joinCol = 1), by=c("joinCol")) - imp_noFuns <- imp_noFuns %>% select(c(all_of(impactSelectCols))) - # df_scenarioResults %>% names %>% print; imp_noFuns %>% names %>% print - df_scenarioResults <- df_scenarioResults %>% rbind(imp_noFuns) + imp_noFuns <- imp_noFuns |> mutate(scaled_impacts = NA, joinCol = 1) + imp_noFuns <- imp_noFuns |> left_join(df_drivers_gcm |> mutate(joinCol = 1), by=c("joinCol")) + imp_noFuns <- imp_noFuns |> select(c(all_of(impactSelectCols))) + # df_scenarioResults |> names() |> print(); imp_noFuns |> names() |> print() + df_scenarioResults <- df_scenarioResults |> rbind(imp_noFuns) rm("imp_noFuns") } rm("df_drivers_gcm", "gcmAllFuncs", "which_hasFunc", "gcmHasFuns", "gcmNoFuns") @@ -629,144 +629,144 @@ run_fredi <- function( ###### SLR Scaled Impacts ###### if(nrow_slr){ - # "got here1" %>% print + # "got here1" |> print() ### Filter to appropriate number of years - slrImpacts <- slrImpacts %>% filter(year <= maxYear) - slrExtremes <- slrExtremes %>% filter(year <= maxYear) - slrDrivers <- df_drivers %>% filter(modelType=="slr") #%>% rename(model_type=modelType) + slrImpacts <- slrImpacts |> filter(year <= maxYear) + slrExtremes <- slrExtremes |> filter(year <= maxYear) + slrDrivers <- df_drivers |> filter(modelType=="slr") #|> rename(model_type=modelType) ###### ** SLR Scaled Impacts Above Max ####### ### Examine driver values: combine with extremeSs - slrMax <- (co_modelTypes %>% filter(modelType=="slr"))$modelMaxOutput[1] + slrMax <- (co_modelTypes |> filter(modelType=="slr"))$modelMaxOutput[1] ### Combine SLR with extremes and filter to appropriate years df_slrMax <- slrDrivers - df_slrMax <- df_slrMax %>% left_join(slrExtremes, by=c("year")) - df_slrMax <- df_slrMax %>% filter(modelUnitValue >= driverValue_ref) - slrMaxYears <- df_slrMax %>% get_uniqueValues(column="year") + df_slrMax <- df_slrMax |> left_join(slrExtremes, by=c("year")) + df_slrMax <- df_slrMax |> filter(modelUnitValue >= driverValue_ref) + slrMaxYears <- df_slrMax |> get_uniqueValues(column="year") ### Calculate scaled impacts for values > slrMax - df_slrMax <- df_slrMax %>% mutate(deltaDriver = modelUnitValue - driverValue_ref) - df_slrMax <- df_slrMax %>% mutate(scaled_impacts = impacts_intercept + impacts_slope * deltaDriver) - # df_slrMax %>% filter(deltaDriver < 0) %>% nrow %>% print + df_slrMax <- df_slrMax |> mutate(deltaDriver = modelUnitValue - driverValue_ref) + df_slrMax <- df_slrMax |> mutate(scaled_impacts = impacts_intercept + impacts_slope * deltaDriver) + # df_slrMax |> filter(deltaDriver < 0) |> nrow() |> print() ###### ** SLR Other Scaled Impacts ####### ### Get impacts and create scenario ID for values <= slrMax - df_slrImpacts <- slrDrivers %>% filter(!(year %in% slrMaxYears)) - df_slrImpacts <- df_slrImpacts %>% left_join(slrImpacts, by=c("year")) - # "got here2" %>% print + df_slrImpacts <- slrDrivers |> filter(!(year %in% slrMaxYears)) + df_slrImpacts <- df_slrImpacts |> left_join(slrImpacts, by=c("year")) + # "got here2" |> print() ###### ** SLR Interpolation ###### - nrow_oth <- df_slrImpacts %>% nrow - # nrow_oth %>% print + nrow_oth <- df_slrImpacts |> nrow() + # nrow_oth |> print() if(nrow_oth){ ### Group by cols cols0 <- c("modelType", "modelUnitValue") cols1 <- c("model_type", "driverValue") cols2 <- c("lower_model", "upper_model") ### Group by cols - slr_names <- df_slrImpacts %>% names + slr_names <- df_slrImpacts |> names() slrGroupByCols <- c("sector", "variant", "impactYear", "impactType", "model", "model_dot", "region", "scenario_id") - slrGroupByCols <- slrGroupByCols[which(slrGroupByCols %in% slr_names)] %>% c(cols1) + slrGroupByCols <- slrGroupByCols[which(slrGroupByCols %in% slr_names)] |> c(cols1) # rm("slrGroupByCols", "slr_names") #### Interpolate driver values - slrDrivers <- slrDrivers %>% rename_at(.vars=c(all_of(cols0)), ~cols1) - slrScenario <- slrDrivers %>% filter(tolower(model_type)=="slr") %>% select(-c("model_type")) - # "got here3" %>% print - slrScenario <- slrScenario %>% slr_Interp_byYear - slrScenario <- slrScenario %>% mutate_at(.vars=c(all_of(cols2)), function(y){gsub(" ", "", y)}) - # "got here4" %>% print - # df_slrImpacts$model %>% unique %>% print + slrDrivers <- slrDrivers |> rename_at(.vars=c(all_of(cols0)), ~cols1) + slrScenario <- slrDrivers |> filter(tolower(model_type)=="slr") |> select(-c("model_type")) + # "got here3" |> print() + slrScenario <- slrScenario |> slr_Interp_byYear() + slrScenario <- slrScenario |> mutate_at(.vars=c(all_of(cols2)), function(y){gsub(" ", "", y)}) + # "got here4" |> print() + # df_slrImpacts$model |> unique() |> print() # return(slrScenario) - # df_slrImpacts %>% names %>% print; slrScenario %>% names %>% print + # df_slrImpacts |> names() |> print(); slrScenario |> names() |> print() ### Interpolate - # df_slrImpacts %>% filter(!is.na(scaled_impacts)) %>% nrow %>% print - df_slrImpacts <- df_slrImpacts %>% rename_at(.vars=c(all_of(cols0[2])), ~cols1[2]) - # "got here5" %>% print - df_slrImpacts <- df_slrImpacts %>% fredi_slrInterp(slr_x = slrScenario, groupByCols=slrGroupByCols) - # "got here6" %>% print - # # "got here" %>% print - # df_slrImpacts %>% filter(!is.na(scaled_impacts)) %>% nrow %>% print - # # df_slrImpacts %>% names %>% print - - df_slrImpacts <- df_slrImpacts %>% rename_at(.vars=c(all_of(cols1[2])), ~cols0[2]) - # df_slrImpacts %>% filter(!is.na(scaled_impacts)) %>% nrow %>% print - # df_slrImpacts %>% names %>% print + # df_slrImpacts |> filter(!is.na(scaled_impacts)) |> nrow() |> print() + df_slrImpacts <- df_slrImpacts |> rename_at(.vars=c(all_of(cols0[2])), ~cols1[2]) + # "got here5" |> print() + df_slrImpacts <- df_slrImpacts |> fredi_slrInterp(slr_x = slrScenario, groupByCols=slrGroupByCols) + # "got here6" |> print() + # # "got here" |> print() + # df_slrImpacts |> filter(!is.na(scaled_impacts)) |> nrow() |> print() + # # df_slrImpacts |> names() |> print() + + df_slrImpacts <- df_slrImpacts |> rename_at(.vars=c(all_of(cols1[2])), ~cols0[2]) + # df_slrImpacts |> filter(!is.na(scaled_impacts)) |> nrow() |> print() + # df_slrImpacts |> names() |> print() rm("slrGroupByCols", "slr_names", "slrScenario") rm("cols0", "cols1") } rm("nrow_oth") - # df_slrImpacts %>% filter(!is.na(scaled_impacts)) %>% nrow %>% print + # df_slrImpacts |> filter(!is.na(scaled_impacts)) |> nrow() |> print() ### Get scenario ID and adjust the model value - # df_slrMax %>% names %>% print - df_slrMax <- df_slrMax %>% mutate(model_dot = "Interpolation") - df_slrImpacts <- df_slrImpacts %>% mutate(model_dot = "Interpolation") + # df_slrMax |> names() |> print() + df_slrMax <- df_slrMax |> mutate(model_dot = "Interpolation") + df_slrImpacts <- df_slrImpacts |> mutate(model_dot = "Interpolation") ### Scenario ID - df_slrMax <- df_slrMax %>% get_scenario_id(include=c("model_dot", "region")) - df_slrImpacts <- df_slrImpacts %>% get_scenario_id(include=c("model_dot", "region")) - # df_slrMax$scenario_id %>% unique %>% head %>% print + df_slrMax <- df_slrMax |> get_scenario_id(include=c("model_dot", "region")) + df_slrImpacts <- df_slrImpacts |> get_scenario_id(include=c("model_dot", "region")) + # df_slrMax$scenario_id |> unique() |> head() |> print() # ### Check names - # df_slrMax %>% names %>% print - # check_max_ids <- df_slrMax$scenario_id; # check_max_ids %>% head %>% print; rm("check_max_ids) + # df_slrMax |> names() |> print() + # check_max_ids <- df_slrMax$scenario_id; # check_max_ids |> head() |> print(); rm("check_max_ids) ###### ** SLR Join Scaled Impacts ###### ### Add other results back in - # "got here7" %>% print - df_slrMax <- df_slrMax %>% select(c(all_of(impactSelectCols))) - df_slrImpacts <- df_slrImpacts %>% select(c(all_of(impactSelectCols))) - df_slrMax_ids <- df_slrMax$scenario_id %>% unique %>% sort - df_slrImp_ids <- df_slrImpacts$scenario_id %>% unique %>% sort - # df_slrMax_ids %>% head %>% print; df_slrImp_ids %>% head %>% print - - # slrMaxYears %>% length %>% print - # df_slrMax %>% filter(!is.na(scaled_impacts)) %>% nrow %>% print - # df_slrImpacts %>% filter(!is.na(scaled_impacts)) %>% nrow %>% print - # "got here8" %>% print - - df_slrImpacts <- df_slrImpacts %>% rbind(df_slrMax) - df_slrImpacts <- df_slrImpacts %>% arrange_at(.vars=c("scenario_id", "year")) - df_slrImpacts <- df_slrImpacts %>% filter(!is.na(scaled_impacts)) - # df_slrImpacts <- df_slrImpacts %>% mutate(across("scenario_id",str_replace, '(\\d)[0-9]{1,3}cm', '\\Interpolation')) + # "got here7" |> print() + df_slrMax <- df_slrMax |> select(c(all_of(impactSelectCols))) + df_slrImpacts <- df_slrImpacts |> select(c(all_of(impactSelectCols))) + df_slrMax_ids <- df_slrMax$scenario_id |> unique() |> sort() + df_slrImp_ids <- df_slrImpacts$scenario_id |> unique() |> sort() + # df_slrMax_ids |> head() |> print(); df_slrImp_ids |> head() |> print() + + # slrMaxYears |> length() |> print() + # df_slrMax |> filter(!is.na(scaled_impacts)) |> nrow() |> print() + # df_slrImpacts |> filter(!is.na(scaled_impacts)) |> nrow() |> print() + # "got here8" |> print() + + df_slrImpacts <- df_slrImpacts |> rbind(df_slrMax) + df_slrImpacts <- df_slrImpacts |> arrange_at(.vars=c("scenario_id", "year")) + df_slrImpacts <- df_slrImpacts |> filter(!is.na(scaled_impacts)) + # df_slrImpacts <- df_slrImpacts |> mutate(across("scenario_id",str_replace, '(\\d)[0-9]{1,3}cm', '\\Interpolation')) rm("df_slrMax") - # df_slrImpacts %>% filter(!is.na(scaled_impacts)) %>% nrow %>% print + # df_slrImpacts |> filter(!is.na(scaled_impacts)) |> nrow() |> print() ### Bind with other results - # df_scenarioResults %>% names %>% print; df_slrImpacts$scenario_id %>% head %>% print - df_scenarioResults <- df_scenarioResults %>% rbind(df_slrImpacts) + # df_scenarioResults |> names() |> print(); df_slrImpacts$scenario_id |> head() |> print() + df_scenarioResults <- df_scenarioResults |> rbind(df_slrImpacts) rm("df_slrImpacts") - # "got here9" %>% print + # "got here9" |> print() ###### ** SLR Initial Results ####### ### Separate initial results out - # # initialResults_slr <- initialResults_slr %>% mutate(scenario_id = scenario_id) - # initialResults_slr %>% names %>% print + # # initialResults_slr <- initialResults_slr |> mutate(scenario_id = scenario_id) + # initialResults_slr |> names() |> print() ### Join with model type or model ### Add additional columns and get scenario ID - initialResults_slr <- initialResults_slr %>% left_join(co_modelTypes, by="modelType") + initialResults_slr <- initialResults_slr |> left_join(co_modelTypes, by="modelType") modelCols0 <- c("model_id", "model_dot", "model_underscore", "model_label") initialResults_slr[,modelCols0] <- "Interpolation" - initialResults_slr <- initialResults_slr %>% get_scenario_id(include=c("model_dot", "region")) + initialResults_slr <- initialResults_slr |> get_scenario_id(include=c("model_dot", "region")) rm("modelCols0") - # "got here" %>% print - in_slrImp_ids <- initialResults_slr$scenario_id %>% unique %>% sort - # in_slrImp_ids %>% head %>% print + # "got here" |> print() + in_slrImp_ids <- initialResults_slr$scenario_id |> unique() |> sort() + # in_slrImp_ids |> head() |> print() check_inMax_ids <- df_slrMax_ids[!(df_slrMax_ids %in% in_slrImp_ids)]; check_inSlr_ids <- df_slrImp_ids[!(df_slrImp_ids %in% in_slrImp_ids)]; - # check_inMax_ids %>% head %>% print; check_inSlr_ids %>% head %>% print + # check_inMax_ids |> head() |> print(); check_inSlr_ids |> head() |> print() - # # df_impacts %>% names %>% print - # # initialResults_slr$scenario_id %>% head %>% print - # initialResults_slr %>% filter(!is.na(econScalarValue)) %>% nrow %>% print + # # df_impacts |> names() |> print() + # # initialResults_slr$scenario_id |> head() |> print() + # initialResults_slr |> filter(!is.na(econScalarValue)) |> nrow() |> print() ###### ** SLR Bind Initial Results ####### ### Arrange and bind with other results - initialResults_slr <- initialResults_slr %>% select(-c("model_type")) - initialResults_slr <- initialResults_slr %>% arrange_at(.vars=c("scenario_id", "year")) + initialResults_slr <- initialResults_slr |> select(-c("model_type")) + initialResults_slr <- initialResults_slr |> arrange_at(.vars=c("scenario_id", "year")) - # names1 <- initialResults_slr %>% names; names2 <- initialResults %>% names; # names1[!(names1 %in% names2)] %>% print - # initialResults_slr %>% names %>% print; initialResults %>% names %>% print - initialResults <- initialResults %>% rbind(initialResults_slr) + # names1 <- initialResults_slr |> names(); names2 <- initialResults |> names(); # names1[!(names1 %in% names2)] |> print() + # initialResults_slr |> names() |> print(); initialResults |> names() |> print() + initialResults <- initialResults |> rbind(initialResults_slr) rm("initialResults_slr") } rm("impactSelectCols") @@ -774,50 +774,50 @@ run_fredi <- function( ###### Calculate Impacts ###### ### Join results with initialized results and update missing observations with NA ### Remove intermediate values - # initialResults %>% names %>% print; df_scenarioResults %>% names %>% print - df_impacts <- initialResults %>% left_join(df_scenarioResults, by=c("scenario_id", "year")); + # initialResults |> names |> print(); df_scenarioResults |> names() |> print() + df_impacts <- initialResults |> left_join(df_scenarioResults, by=c("scenario_id", "year")); rm("initialResults") if(msgUser) message("\t", list_messages[["scaledImpacts"]]$success) - # df_impacts %>% names %>% print - # initialResults$modelUnit_label %>% unique %>% print - # df_impacts %>% filter(modelUnit_label=="cm") %>% filter(!is.na(scaled_impacts)) %>% nrow %>% print - # (df_impacts %>% filter(modelUnit_label=="cm"))$year %>% range %>% print + # df_impacts |> names() |> print() + # initialResults$modelUnit_label |> unique() |> print() + # df_impacts |> filter(modelUnit_label=="cm") |> filter(!is.na(scaled_impacts)) |> nrow() |> print() + # (df_impacts |> filter(modelUnit_label=="cm"))$year |> range() |> print() ### Physical impacts = physScalar * scaled_impacts ### Annual impacts = phys-econ scalar value by the scaled impacts - # df_impacts <- df_impacts %>% mutate(hasPhysImpacts = 1 * !is.na(physicalmeasure)) - # df_impacts <- df_impacts %>% mutate(hasPhysImpacts = 1 * !is.na(physScalar)) - df_impacts <- df_impacts %>% mutate(physical_impacts = scaled_impacts * physScalar) - df_impacts <- df_impacts %>% mutate(annual_impacts = scaled_impacts * physEconScalar) - # df_impacts <- df_impacts %>% select(-c("hasPhysImpacts")) #%>% as.data.frame + # df_impacts <- df_impacts |> mutate(hasPhysImpacts = 1 * !is.na(physicalmeasure)) + # df_impacts <- df_impacts |> mutate(hasPhysImpacts = 1 * !is.na(physScalar)) + df_impacts <- df_impacts |> mutate(physical_impacts = scaled_impacts * physScalar) + df_impacts <- df_impacts |> mutate(annual_impacts = scaled_impacts * physEconScalar) + # df_impacts <- df_impacts |> select(-c("hasPhysImpacts")) #|> as.data.frame() ###### Add Scenario Information ###### ### Add in model info message("Formatting results", "...") - df_impacts <- df_impacts %>% filter(year>=minYear) %>% rename(model_type = modelType) - df_drivers <- df_drivers %>% filter(year>=minYear) %>% rename(model_type = modelType) - df_results <- df_impacts %>% left_join(df_drivers, by=c("year", "model_type")) + df_impacts <- df_impacts |> filter(year>=minYear) |> rename(model_type = modelType) + df_drivers <- df_drivers |> filter(year>=minYear) |> rename(model_type = modelType) + df_results <- df_impacts |> left_join(df_drivers, by=c("year", "model_type")) rm("df_impacts") - # (df_results %>% filter(modelUnit_label=="cm"))$year %>% range %>% print - # df_results %>% filter(modelUnit_label=="cm") %>% filter(!is.na(scaled_impacts)) %>% nrow %>% print + # (df_results |> filter(modelUnit_label=="cm"))$year |> range() |> print() + # df_results |> filter(modelUnit_label=="cm") |> filter(!is.na(scaled_impacts)) |> nrow() |> print() ### Update inputs in outputs list returnList[["results"]] <- df_results ###### Format Outputs ###### ### Refactor sectors, variants, impactTypes - co_variants <- co_variants %>% mutate(sector_variant = paste(sector_id, variant_id, sep="_")) - co_impactTypes <- co_impactTypes %>% mutate(sector_impactType = paste(sector_id, impactType_id, sep="_")) + co_variants <- co_variants |> mutate(sector_variant = paste(sector_id, variant_id, sep="_")) + co_impactTypes <- co_impactTypes |> mutate(sector_impactType = paste(sector_id, impactType_id, sep="_")) #### Rename Sector Columns - df_results <- df_results %>% rename(sector_id = sector, sector = sector_label) + df_results <- df_results |> rename(sector_id = sector, sector = sector_label) #### Regions - # df_results %>% names %>% print + # df_results |> names() |> print() reg_lvls <- co_regions$region_dot reg_lbls <- co_regions$region_label - df_results <- df_results %>% rename(region_id = region) - df_results <- df_results %>% mutate(region = region_id %>% factor(reg_lvls, reg_lbls)) + df_results <- df_results |> rename(region_id = region) + df_results <- df_results |> mutate(region = region_id |> factor(reg_lvls, reg_lbls)) rm("reg_lvls", "reg_lbls") ### Model types and models @@ -825,30 +825,30 @@ run_fredi <- function( modelCols1 <- c("model" , "model_type" , "driverValue" , "driverUnit", "driverType") modelCols2 <- c("model_id", "model_dot", "model_underscore", "modelUnit_id") modelCols3 <- c("modelRefYear", "modelMaxOutput", "modelUnitScale", "modelMaxExtrap") - df_results <- df_results %>% select(-c("model_type")) - df_results <- df_results %>% rename_at(.vars=c(all_of(modelCols0)), ~modelCols1) - df_results <- df_results %>% select(-c(all_of(modelCols2), all_of(modelCols3))) + df_results <- df_results |> select(-c("model_type")) + df_results <- df_results |> rename_at(.vars=c(all_of(modelCols0)), ~modelCols1) + df_results <- df_results |> select(-c(all_of(modelCols2), all_of(modelCols3))) rm("modelCols0", "modelCols1", "modelCols2", "modelCols3") - # df_results %>% names %>% print - # (df_results %>% filter(driverUnit=="cm"))$year %>% range %>% print + # df_results |> names() |> print() + # (df_results |> filter(driverUnit=="cm"))$year |> range() |> print() ### Variant labels var_lvls <- co_variants$sector_variant var_lbls <- co_variants$variant_label - df_results <- df_results %>% mutate(sect_var = sector_id %>% paste(variant, sep="_")) - df_results <- df_results %>% mutate(variant = sect_var %>% factor(var_lvls, var_lbls)) - df_results <- df_results %>% select(-c("sect_var")) + df_results <- df_results |> mutate(sect_var = sector_id |> paste(variant, sep="_")) + df_results <- df_results |> mutate(variant = sect_var |> factor(var_lvls, var_lbls)) + df_results <- df_results |> select(-c("sect_var")) rm("var_lvls", "var_lbls") - # (df_results %>% filter(driverUnit=="cm"))$year %>% range %>% print + # (df_results |> filter(driverUnit=="cm"))$year |> range() |> print() ### Impact types imp_lvls <- co_impactTypes$sector_impactType imp_lbls <- co_impactTypes$impactType_label - df_results <- df_results %>% mutate(sect_imp = sector_id %>% paste(impactType, sep="_")) - df_results <- df_results %>% mutate(impactType = sect_imp %>% factor(imp_lvls, imp_lbls)) - df_results <- df_results %>% select(-c("sect_imp", "sector_id")) + df_results <- df_results |> mutate(sect_imp = sector_id |> paste(impactType, sep="_")) + df_results <- df_results |> mutate(impactType = sect_imp |> factor(imp_lvls, imp_lbls)) + df_results <- df_results |> select(-c("sect_imp", "sector_id")) rm("imp_lvls", "imp_lbls") - # (df_results %>% filter(driverUnit=="cm"))$year %>% range %>% print + # (df_results |> filter(driverUnit=="cm"))$year |> range() |> print() ###### Columns ###### ### Scalar column names, Sector info names, Scenario names @@ -856,20 +856,20 @@ run_fredi <- function( cAddCols0 <- c("sectorprimary", "includeaggregate") cSectorInfoNames <- c("modelUnitType", "c0", "c1", "exp0", "year0") cScenarioNames <- c("scenario_id") - cScalarNames <- c("physScalarName", "physAdjName", "damageAdjName", "physScalar") %>% - c("physScalarValue", "physAdjValue" , "damageAdjValue") %>% - c("econScalarName" , "econMultiplierName" , "econScalar") %>% - c("econScalarValue", "econMultiplierValue", "econAdjValue", "econMultiplier") %>% + cScalarNames <- c("physScalarName", "physAdjName", "damageAdjName", "physScalar") |> + c("physScalarValue", "physAdjValue" , "damageAdjValue") |> + c("econScalarName" , "econMultiplierName" , "econScalar") |> + c("econScalarValue", "econMultiplierValue", "econAdjValue", "econMultiplier") |> c("physEconScalar" , "scaled_impacts") selectCols0 <- c(cScenarioNames, cScalarNames, cSectorInfoNames) ### Convert to character and drop sector id - df_results <- df_results %>% mutate_at(.vars = c(all_of(cGroupByCols0)), as.character) - df_results <- df_results %>% filter(!is.na(sector)) - # (df_results %>% filter(driverUnit=="cm"))$year %>% range %>% print + df_results <- df_results |> mutate_at(.vars = c(all_of(cGroupByCols0)), as.character) + df_results <- df_results |> filter(!is.na(sector)) + # (df_results |> filter(driverUnit=="cm"))$year |> range() |> print() ###### Testing ###### - if(!testing) {df_results <- df_results %>% select(-c(all_of(selectCols0)))} + if(!testing) {df_results <- df_results |> select(-c(all_of(selectCols0)))} ###### Aggregation ###### @@ -878,38 +878,38 @@ run_fredi <- function( ### Aggregation types aggGroupByCols <- cGroupByCols0 includeAggCol <- c("includeaggregate") - if( doPrimary){df_results <- df_results %>% filter(includeaggregate==1) %>% select(-c(all_of(includeAggCol)))} - if(!doPrimary){aggGroupByCols <- aggGroupByCols %>% c(includeAggCol)} + if( doPrimary){df_results <- df_results |> filter(includeaggregate==1) |> select(-c(all_of(includeAggCol)))} + if(!doPrimary){aggGroupByCols <- aggGroupByCols |> c(includeAggCol)} ### If the user specifies primary type, filter to primary types and variants and drop that column - # df_results %>% nrow %>% print; df_results %>% head %>% glimpse - df_results <- df_results %>% as.data.frame %>% aggregate_impacts(aggLevels = aggLevels, groupByCols = aggGroupByCols) - # df_results %>% nrow %>% print; df_results %>% head %>% glimpse + # df_results |> nrow() |> print(); df_results |> head() |> glimpse() + df_results <- df_results |> as.data.frame() |> aggregate_impacts(aggLevels = aggLevels, groupByCols = aggGroupByCols) + # df_results |> nrow() |> print(); df_results |> head() |> glimpse() rm("aggGroupByCols") } - # df_results %>% names %>% print + # df_results |> names() |> print() ###### Order the Output ###### ### Convert levels to character ### Order the rows, then order the columns if(!testing){ - resultNames <- df_results %>% names + resultNames <- df_results |> names() groupByCols <- c("sector", "variant", "impactYear", "impactType", "region", "model_type", "model", "year") driverCols <- c("driverValue", "driverUnit", "driverType") nonGroupCols <- resultNames[which(!(resultNames %in% c(groupByCols, driverCols)))] orderColIndex <- which(names(data) %in% groupByCols) - selectCols <- c(groupByCols, driverCols, nonGroupCols) %>% (function(x){x[x!="annual_impacts"] %>% c("annual_impacts")}) + selectCols <- c(groupByCols, driverCols, nonGroupCols) |> (function(x){x[x!="annual_impacts"] |> c("annual_impacts")})() ### Select columns - df_results <- df_results %>% select(c(all_of(selectCols))) %>% arrange_at(.vars=c(all_of(groupByCols))) + df_results <- df_results |> select(c(all_of(selectCols))) |> arrange_at(.vars=c(all_of(groupByCols))) } - # c_aggColumns <- c("sectorprimary", "includeaggregate") %>% (function(y){y[which(y %in% names(df_results))]}) - # if(length(c_aggColumns)>0){df_results <- df_results %>% mutate_at(.vars=c(all_of(c_aggColumns)), as.numeric)} + # c_aggColumns <- c("sectorprimary", "includeaggregate") |> (function(y){y[which(y %in% names(df_results))]})() + # if(length(c_aggColumns)>0){df_results <- df_results |> mutate_at(.vars=c(all_of(c_aggColumns)), as.numeric)} ###### Format as Data Frame ###### ### Format as data frame ### Update results in list - df_results <- df_results %>% ungroup %>% as.data.frame + df_results <- df_results |> ungroup() |> as.data.frame() returnList[["results"]] <- df_results ### Which object to return if(outputList) {returnObj <- returnList} diff --git a/FrEDI/R/run_fredi_sv.R b/FrEDI/R/run_fredi_sv.R index 724702f6..1e06fa89 100644 --- a/FrEDI/R/run_fredi_sv.R +++ b/FrEDI/R/run_fredi_sv.R @@ -109,9 +109,9 @@ run_fredi_sv <- function( pkgPath <- NULL pkgPath <- ifelse(is.null(pkgPath), system.file(package="FrEDI"), pkgPath); rDataType <- "rds" - #pkgPath %>% print - impactsPath <- pkgPath %>% file.path("extdata", "sv", "impactLists") - # impactsPath <- libPath %>% file.path("FrEDI", "extdata", "sv", "impactLists") + #pkgPath |> print() + impactsPath <- pkgPath |> file.path("extdata", "sv", "impactLists") + # impactsPath <- libPath |> file.path("FrEDI", "extdata", "sv", "impactLists") ### Assign previous configuration objects for(i in 1:length(fredi_config)) assign(names(fredi_config)[i], fredi_config[[i]]) @@ -127,9 +127,9 @@ run_fredi_sv <- function( silent <- ifelse(is.null(silent), T, silent) msgUser <- !silent msg0 <- "" - msg1 <- msg0 %>% paste0("\t") - msg2 <- msg1 %>% paste0("\t") - msg3 <- msg2 %>% paste0("\t") + msg1 <- msg0 |> paste0("\t") + msg2 <- msg1 |> paste0("\t") + msg3 <- msg2 |> paste0("\t") ###### Sector Info ###### ### Objects <- @@ -142,33 +142,33 @@ run_fredi_sv <- function( # co_modelTypes <- rDataList$co_modelTypes ### Sector names if(is.null(sector)){ - sector_msg1 <- paste0("Please select a sector: ") %>% print - sector_msg2 <- 1:nrow(sectorInfo) %>% lapply(function(i){ + sector_msg1 <- paste0("Please select a sector: ") |> print() + sector_msg2 <- 1:nrow(sectorInfo) |> lapply(function(i){ sector_i <- sectorInfo$sector[i] msg_i <- paste0(i, ". ", sector_i) - msg_i %>% print + msg_i |> print() # return(msg_i) - }) #%>% unlist %>% paste(collapse="") - # sector_msg3 <- sector_msg1 %>% paste0(sector_msg2) + }) #|> unlist() |> paste(collapse="") + # sector_msg3 <- sector_msg1 |> paste0(sector_msg2) sector_msg3 <- "Enter a number:" - sector_input <- readline(prompt = sector_msg3) %>% as.numeric + sector_input <- readline(prompt = sector_msg3) |> as.numeric() sector <- sectorInfo$sector[sector_input] rm("sector_msg1", "sector_msg2", "sector_msg3", "sector_input") } c_sector <- sector - paste0("Running FrEDI SV for sector '", c_sector, "':") %>% message + paste0("Running FrEDI SV for sector '", c_sector, "':") |> message() ### Sector info - which_sector <- (svSectorInfo$sector == c_sector) %>% which #; which_sector %>% print + which_sector <- (svSectorInfo$sector == c_sector) |> which() #; which_sector |> print() df_sectorInfo <- svSectorInfo[which_sector,] c_variants <- df_sectorInfo[["variant_abbr" ]][which_sector] c_variantLabels <- df_sectorInfo[["variant_label"]][which_sector] rm("which_sector") ###### Invalid Sectors ###### - which_sector <- (sectorInfo$sector == c_sector) %>% which #; which_sector %>% print - c_popWtCol <- sectorInfo[["popWeightCol"]][which_sector] %>% tolower - c_modelType <- sectorInfo[["modelType" ]][which_sector] %>% tolower + which_sector <- (sectorInfo$sector == c_sector) |> which() #; which_sector |> print() + c_popWtCol <- sectorInfo[["popWeightCol"]][which_sector] |> tolower() + c_modelType <- sectorInfo[["modelType" ]][which_sector] |> tolower() rm("which_sector") - df_validGroups <- svDemoInfo %>% get_validGroups(df1 = svValidTypes, col0 = c_popWtCol) + df_validGroups <- svDemoInfo |> get_validGroups(df1 = svValidTypes, col0 = c_popWtCol) # return(df_validGroups) ###### Check Driver Inputs ###### @@ -189,76 +189,76 @@ run_fredi_sv <- function( ### Scenario ranges tempRange <- c(0, 6) slrRange <- c(0, 200) - driverRange <- c(0) %>% c(ifelse(c_modelType=="slr", slrRange[2], tempRange[2])) + driverRange <- c(0) |> c(ifelse(c_modelType=="slr", slrRange[2], tempRange[2])) ### Check inputs if(has_driverInput){ - msg1 %>% message("Checking `driverInput` values...") + msg1 |> message("Checking `driverInput` values...") ### Check that the input is a data frame - class_driverInput <- driverInput %>% class + class_driverInput <- driverInput |> class() if(!("data.frame" %in% class_driverInput)){ - msg2 %>% message("Error: `driverInput` must have `class='data.frame'`!", "\n") - msg2 %>% message("Exiting...") + msg2 |> message("Error: `driverInput` must have `class='data.frame'`!", "\n") + msg2 |> message("Exiting...") return() } ### End if(!("data.frame" %in% class_driverInput)) ### Info about driverInputs - driverInputCols <- driverInput %>% names; # driverInputCols %>% print - has_scenarioCol <- "scenario" %in% driverInputCols; #has_scenarioCol %>% print - has_yearCol <- "year" %in% driverInputCols; #has_scenarioCol %>% print + driverInputCols <- driverInput |> names(); # driverInputCols |> print() + has_scenarioCol <- "scenario" %in% driverInputCols; #has_scenarioCol |> print() + has_yearCol <- "year" %in% driverInputCols; #has_scenarioCol |> print() ### Check scenarios if(has_scenarioCol){ - msg1 %>% message("Checking scenarios in `driverInput`...") + msg1 |> message("Checking scenarios in `driverInput`...") ### If scenarios are present, check the number of scenarios - c_scenarios <- driverInput$scenario %>% unique - n_scenarios <- c_scenarios %>% length + c_scenarios <- driverInput$scenario |> unique() + n_scenarios <- c_scenarios |> length() if(n_scenarios > 4){ - msg2 %>% message("Warning: `driverInput` has more than four distinct scenarios!", "") - msg3 %>% message("Only the first four scenarios will be used...", "\n") - c_scenarios <- c_scenarios[1:4]; n_scenarios <- c_scenarios %>% length - driverInput <- driverInput %>% filter(scenario %in% c_scenarios) + msg2 |> message("Warning: `driverInput` has more than four distinct scenarios!", "") + msg3 |> message("Only the first four scenarios will be used...", "\n") + c_scenarios <- c_scenarios[1:4]; n_scenarios <- c_scenarios |> length() + driverInput <- driverInput |> filter(scenario %in% c_scenarios) } ### End if(n_scenarios > 4) } ### End if(has_scenarioCol) else{ - msg2 %>% message("Error: `driverInput` must have column='scenario' present`!", "\n") - msg2 %>% message("Exiting...") + msg2 |> message("Error: `driverInput` must have column='scenario' present`!", "\n") + msg2 |> message("Exiting...") return() } ### End else(has_scenarioCol) rm("has_scenarioCol") ### Check input years if(!has_yearCol){ - msg2 %>% message("Error: `driverInput` must have column='year' present`!", "\n") - msg2 %>% message("Exiting...") + msg2 |> message("Error: `driverInput` must have column='year' present`!", "\n") + msg2 |> message("Exiting...") return() } ### if(!has_yearCol) rm("has_yearCol") ### Check for SLR inputs if(has_driverInput & check_slrInput){ - msg1 %>% message("Checking `driverInput` values for SLR scenario...") + msg1 |> message("Checking `driverInput` values for SLR scenario...") ### Check for SLR columns slrCols_inInput <- slrCols %in% driverInputCols if(all(slrCols_inInput)){ - msg2 %>% message("All SLR scenario columns present in `driverInput`...") + msg2 |> message("All SLR scenario columns present in `driverInput`...") ### Filter to non-missing data - driverInput <- driverInput %>% filter(!is.na(year) & !is.na(slr_cm) & !is.na(scenario)) + driverInput <- driverInput |> filter(!is.na(year) & !is.na(slr_cm) & !is.na(scenario)) ### Check non-missing values - if(driverInput %>% nrow){ - df_nonNA <- driverInput %>% - group_by_at(.vars=c("scenario")) %>% - summarize(n=n(), .groups="keep") %>% ungroup + if(driverInput |> nrow()){ + df_nonNA <- driverInput |> + group_by_at(.vars=c("scenario")) |> + summarize(n=n(), .groups="keep") |> ungroup() naIssues <- !all(df_nonNA$n >= 2) rm("df_nonNA") - } ### End if(driverInput %>% nrow) + } ### End if(driverInput |> nrow()) else{ naIssues <- TRUE - } ### End else(driverInput %>% nrow) + } ### End else(driverInput |> nrow()) ### If missing values are an issue: if(naIssues){ - msg2 %>% message("Error: each scenario must have at least two non-missing values for \'slr_cm\'!", "\n") - msg2 %>% message("Exiting...") + msg2 |> message("Error: each scenario must have at least two non-missing values for \'slr_cm\'!", "\n") + msg2 |> message("Exiting...") return() } ### End if(naIssues) has_slrInput <- TRUE ; has_tempInput <- FALSE; check_tempInput <- FALSE @@ -266,9 +266,9 @@ run_fredi_sv <- function( } ### End if(all(slrCols_inInput)) ### Message user about missing columns else{ - msg1 %>% message("Warning: `driverInput` is missing the following SLR scenario input columns:") - msg2 %>% message("\'", paste(slrCols[!slrCols_inInput], collapse="\', \'"),"'...", "\n") - msg1 %>% message("Looking for temperature scenario instead", "...", "\n") + msg1 |> message("Warning: `driverInput` is missing the following SLR scenario input columns:") + msg2 |> message("\'", paste(slrCols[!slrCols_inInput], collapse="\', \'"),"'...", "\n") + msg1 |> message("Looking for temperature scenario instead", "...", "\n") has_slrInput <- FALSE; has_tempInput <- FALSE; check_tempInput <- TRUE } ### End else(all(slrCols_inInput)) rm("slrCols_inInput") @@ -276,39 +276,39 @@ run_fredi_sv <- function( ### Otherwise, check temperature inputs if(has_driverInput & check_tempInput){ - ifelse(check_slrInput, msg2, msg1) %>% message("Checking `driverInput` values for temperature scenario...") + ifelse(check_slrInput, msg2, msg1) |> message("Checking `driverInput` values for temperature scenario...") ### Check for temperature columns tempCols_inInput <- (tempCols %in% driverInputCols) if(all(tempCols_inInput)){ - ifelse(check_slrInput, msg3, msg2) %>% message("All temperature scenario columns present...") + ifelse(check_slrInput, msg3, msg2) |> message("All temperature scenario columns present...") ### Filter to non-missing data - driverInput <- driverInput %>% filter(!is.na(year) & !is.na(temp_C)) + driverInput <- driverInput |> filter(!is.na(year) & !is.na(temp_C)) ### Check non-missing values - if(driverInput %>% nrow){ - df_nonNA <- driverInput %>% - filter(!is.na(year) & !is.na(temp_C)) %>% - group_by_at(.vars=c("scenario")) %>% - summarize(n=n(), .groups="keep") %>% ungroup + if(driverInput |> nrow()){ + df_nonNA <- driverInput |> + filter(!is.na(year) & !is.na(temp_C)) |> + group_by_at(.vars=c("scenario")) |> + summarize(n=n(), .groups="keep") |> ungroup() naIssues <- !all(df_nonNA$n >= 2) rm("df_nonNA") - } ### End if(driverInput %>% nrow) + } ### End if(driverInput |> nrow()) else{ naIssues <- TRUE - } ### End else(driverInput %>% nrow) + } ### End else(driverInput |> nrow()) ### If naIssues if(naIssues){ - msg2 %>% message("Error: each scenario must have at least two non-missing values for \'temp_C\'!", "\n") - msg2 %>% message("Exiting...") + msg2 |> message("Error: each scenario must have at least two non-missing values for \'temp_C\'!", "\n") + msg2 |> message("Exiting...") return() } ### End if(naIssues) has_tempInput <- TRUE; check_tempInput <- TRUE rm("naIssues") } ### End if(all(tempCols_inInput)) else{ - msg2 %>% message("Warning: `driverInput` is missing the following temperature scenario input columns...") - msg2 %>% message("\'", paste(tempCols[!tempCols_inInput], collapse="\', \'"),"'...", "\n") - msg2 %>% message("Exiting...") + msg2 |> message("Warning: `driverInput` is missing the following temperature scenario input columns...") + msg2 |> message("\'", paste(tempCols[!tempCols_inInput], collapse="\', \'"),"'...", "\n") + msg2 |> message("Exiting...") return() } ### End else(all(tempCols_inInput)) rm("tempCols_inInput") @@ -326,47 +326,47 @@ run_fredi_sv <- function( ###### Check Population Inputs ###### ### Check that the input is a data frame if(check_popInput){ - msg1 %>% message("Checking `popInput` values...") - class_popInput <- popInput %>% class + msg1 |> message("Checking `popInput` values...") + class_popInput <- popInput |> class() if(!("data.frame" %in% class_popInput)){ - msg2 %>% message("Error: `popInput` must have `class='data.frame'`!", "\n") - msg2 %>% message("Exiting...") + msg2 |> message("Error: `popInput` must have `class='data.frame'`!", "\n") + msg2 |> message("Exiting...") return() } ### End if(!("data.frame" %in% class_popInput)) ### Check for popInput columns ### Info about popInputs - popInputCols <- popInput %>% names + popInputCols <- popInput |> names() popCols_inInput <- (popCols %in% popInputCols) if(all(popCols_inInput)){ - msg2 %>% message("All population scenario columns present in `popInput`...") + msg2 |> message("All population scenario columns present in `popInput`...") ### Filter to non-missing data - popInput <- popInput %>% filter(!is.na(year) & !is.na(region) & !is.na(reg_pop)) + popInput <- popInput |> filter(!is.na(year) & !is.na(region) & !is.na(reg_pop)) ### Check input Population values: no repeating years - if(popInput %>% nrow){ - df_dups <- popInput %>% - group_by_at(.vars=c("year", "region")) %>% - summarize(n=n(), .groups="keep") %>% ungroup + if(popInput |> nrow()){ + df_dups <- popInput |> + group_by_at(.vars=c("year", "region")) |> + summarize(n=n(), .groups="keep") |> ungroup() checkIssues <- any(df_dups$n > 1) rm("df_dups") - } ### End if(popInput %>% nrow) + } ### End if(popInput |> nrow()) else{ checkIssues <- TRUE } ### If there are issues with years: if(checkIssues){ - msg2 %>% message("Error: duplicate years present in `popInput`!") - msg2 %>% message("Exiting...") + msg2 |> message("Error: duplicate years present in `popInput`!") + msg2 |> message("Exiting...") return() } ### End if(checkIssues) rm("checkIssues") ### Check input Population values: population >= 0 checkIssues <- (popInput$reg_pop < 0) - anyIssues <- checkIssues %>% any + anyIssues <- checkIssues |> any() if(anyIssues){ - msg2 %>% message("Error: Values for 'reg_pop' in `popInput` must be greater than zero!") - msg2 %>% message("Exiting...") + msg2 |> message("Error: Values for 'reg_pop' in `popInput` must be greater than zero!") + msg2 |> message("Exiting...") return() } ### End if(checkIssues) has_popInput <- TRUE @@ -374,18 +374,18 @@ run_fredi_sv <- function( } ### End if(all(popCols_inInput)) else{ ### Exit and message the user - # msg1 %>% message("Using default regional population scenario", "...", "\n") + # msg1 |> message("Using default regional population scenario", "...", "\n") # has_popInput <- FALSE - msg2 %>% message("Error: `popInput` is missing the following input columns:") - msg3 %>% message("'", paste(popCols[!popCols_inInput], collapse="', '"),"'...", "\n") - msg2 %>% message("Exiting...") + msg2 |> message("Error: `popInput` is missing the following input columns:") + msg3 |> message("'", paste(popCols[!popCols_inInput], collapse="', '"),"'...", "\n") + msg2 |> message("Exiting...") return() } ### End else(all(popCols_inInput)) rm("class_popInput", "popInputCols", "popCols_inInput") } ### End if(check_popInput) ###### Driver Scenario ###### - paste0("\n", msg1) %>% message("Preparing driver scenario...") + paste0("\n", msg1) |> message("Preparing driver scenario...") ###### ** Temperature Scenario ###### ### User inputs: temperatures have already been converted to CONUS temperatures. Filter to desired range. @@ -400,59 +400,59 @@ run_fredi_sv <- function( checkTemp3 <- c_modelType == "slr" & !has_tempInput & !has_slrInput if(checkTemp0 | checkTemp1){ ### Message user - # if(checkTemp1){msg1 %>% message("No SLR inputs provided...")} - msg2 %>% message("Using temperature scenario from user inputs...") + # if(checkTemp1){msg1 |> message("No SLR inputs provided...")} + msg2 |> message("Using temperature scenario from user inputs...") ### Format inputs - driverInput <- driverInput %>% select(c(all_of(tempCols))) %>% rename(driverValue = temp_C) + driverInput <- driverInput |> select(c(all_of(tempCols))) |> rename(driverValue = temp_C) } ### End if(checkTemp0 | checkTemp1) else if(checkTemp2 | checkTemp3){ ### Otherwise use default scenario and add scenario column - msg2 %>% message("Using default temperature scenario...") - # rDataList$co_defaultTemps %>% names %>% print - driverInput <- rDataList$co_defaultTemps %>% - mutate(temp_C = temp_C_global %>% convertTemps(from="global")) %>% + msg2 |> message("Using default temperature scenario...") + # rDataList$co_defaultTemps |> names() |> print() + driverInput <- rDataList$co_defaultTemps |> + mutate(temp_C = temp_C_global |> convertTemps(from="global")) |> mutate(scenario="FrEDI Default") ### Select columns - driverInput <- driverInput %>% select(c(all_of(tempCols))) %>% rename(driverValue = temp_C) + driverInput <- driverInput |> select(c(all_of(tempCols))) |> rename(driverValue = temp_C) } ### End else if(checkTemp2 | checkTemp3) ### Interpolate temperatures over scenarios: if(checkTemp0 | checkTemp1 | checkTemp2 | checkTemp3){ ### Scenarios - c_scenarios <- driverInput$scenario %>% unique - n_scenarios <- c_scenarios %>% length + c_scenarios <- driverInput$scenario |> unique() + n_scenarios <- c_scenarios |> length() ### Ref year - refYearTemp <- (rDataList$co_modelTypes %>% filter(modelUnitType=="temperature"))$modelRefYear[1] + refYearTemp <- (rDataList$co_modelTypes |> filter(modelUnitType=="temperature"))$modelRefYear[1] ### Drivers - drivers_df <- c_scenarios %>% lapply(function( + drivers_df <- c_scenarios |> lapply(function( scenario_i, data_x = driverInput, refYear_x = refYearTemp, refValue_x = 0, maxYear_x = maxYear ){ ### - Filter to scenario i and drop scenario column ### - Zero out series at the temperature reference year - # tempInput %>% names %>% print - input_i <- data_x %>% filter(scenario==scenario_i) %>% select(-c("scenario")) - input_i <- input_i %>% filter(year > refYear_x) %>% filter(year <= maxYear_x) - input_i <- data.frame(year= refYear_x, driverValue = refValue_x) %>% rbind(input_i) + # tempInput |> names() |> print() + input_i <- data_x |> filter(scenario==scenario_i) |> select(-c("scenario")) + input_i <- input_i |> filter(year > refYear_x) |> filter(year <= maxYear_x) + input_i <- data.frame(year= refYear_x, driverValue = refValue_x) |> rbind(input_i) ### Then, interpolate ### - Use minimum series year to determine interpolation years ### - Add a dummy region for National Total for interpolate_annual ### - Interpolate, drop dummy region, and add scenario back in years_i <- refYear_x:maxYear_x - input_i <- input_i %>% - mutate(region="National Total") %>% - interpolate_annual(years = years_i, column = "driverValue", rule = 1:2) %>% + input_i <- input_i |> + mutate(region="National Total") |> + interpolate_annual(years = years_i, column = "driverValue", rule = 1:2) |> select(-c("region")) ### Add scenario - input_i <- input_i %>% mutate(scenario = scenario_i) + input_i <- input_i |> mutate(scenario = scenario_i) ### Return return(input_i) - }) %>% (function(x){do.call(rbind, x)}) + }) |> (function(x){do.call(rbind, x)})() ### Add driver unit - drivers_df <- drivers_df %>% mutate(driverUnit = "degrees Celsius") + drivers_df <- drivers_df |> mutate(driverUnit = "degrees Celsius") ### Remove values rm("driverInput", "refYearTemp") } ### End if(checkTemp0 | checkTemp1 | checkTemp2 | checkTemp3) @@ -473,90 +473,90 @@ run_fredi_sv <- function( ### First convert temperatures to global temperatures ### Then convert global temps to SLR if(checkSLR0){ - msg2 %>% message("Using SLR scenario from user inputs...") - driverInput <- driverInput %>% select(c(all_of(slrCols))) + msg2 |> message("Using SLR scenario from user inputs...") + driverInput <- driverInput |> select(c(all_of(slrCols))) ### Scenarios - c_scenarios <- driverInput$scenario %>% unique - n_scenarios <- c_scenarios %>% length + c_scenarios <- driverInput$scenario |> unique() + n_scenarios <- c_scenarios |> length() ### Ref year - refYearSLR <- (rDataList$co_modelTypes %>% filter(modelUnitType=="slr"))$modelRefYear[1] + refYearSLR <- (rDataList$co_modelTypes |> filter(modelUnitType=="slr"))$modelRefYear[1] ### Drivers - drivers_df <- c_scenarios %>% lapply(function( + drivers_df <- c_scenarios |> lapply(function( scenario_i, data_x = driverInput, refYear_x = refYearSLR, refValue_x = 0, maxYear_x = maxYear ){ ### - Filter to scenario i and drop scenario column ### - Zero out series at the temperature reference year - # tempInput %>% names %>% print - input_i <- data_x %>% filter(scenario==scenario_i) %>% select(-c("scenario")) - input_i <- input_i %>% filter(year > refYear_x) %>% filter(year <= maxYear_x) %>% rename(driverValue = slr_cm) - input_i <- data.frame(year= refYear_x, driverValue = refValue_x) %>% rbind(input_i) + # tempInput |> names() |> print() + input_i <- data_x |> filter(scenario==scenario_i) |> select(-c("scenario")) + input_i <- input_i |> filter(year > refYear_x) |> filter(year <= maxYear_x) |> rename(driverValue = slr_cm) + input_i <- data.frame(year= refYear_x, driverValue = refValue_x) |> rbind(input_i) ### Then, interpolate ### - Use minimum series year to determine interpolation years ### - Add a dummy region for National Total for interpolate_annual ### - Interpolate, drop dummy region, and add scenario back in years_i <- refYear_x:maxYear_x - input_i <- input_i %>% mutate(region="National Total") - input_i <- input_i %>% interpolate_annual(years = years_i, column = "driverValue", rule = 1:2) - input_i <- input_i %>% select(-c("region")) + input_i <- input_i |> mutate(region="National Total") + input_i <- input_i |> interpolate_annual(years = years_i, column = "driverValue", rule = 1:2) + input_i <- input_i |> select(-c("region")) ### Add scenario - input_i <- input_i %>% mutate(scenario = scenario_i) + input_i <- input_i |> mutate(scenario = scenario_i) ### Return return(input_i) - }) %>% (function(x){do.call(rbind, x)}) + }) |> (function(x){do.call(rbind, x)})() ### Add driver unit - drivers_df <- drivers_df %>% mutate(driverUnit = "cm") + drivers_df <- drivers_df |> mutate(driverUnit = "cm") ### Remove values rm("driverInput", "refYearSLR") } ### End if(checkSLR0) else if(checkSLR1){ - msg2 %>% message("Creating SLR scenario from temperature scenario...") - drivers_df <- c_scenarios %>% lapply(function( + msg2 |> message("Creating SLR scenario from temperature scenario...") + drivers_df <- c_scenarios |> lapply(function( scenario_i, data_x = drivers_df ){ - data_i <- data_x %>% filter(scenario==scenario_i) - data_i <- data_i %>% mutate(temp_C = driverValue %>% convertTemps(from="conus")) + data_i <- data_x |> filter(scenario==scenario_i) + data_i <- data_i |> mutate(temp_C = driverValue |> convertTemps(from="conus")) data_i <- temps2slr(temps = data_i$temp_C, years = data_i$year) - data_i <- data_i %>% rename(driverValue=slr_cm) - data_i <- data_i %>% mutate(scenario=scenario_i) + data_i <- data_i |> rename(driverValue=slr_cm) + data_i <- data_i |> mutate(scenario=scenario_i) return(data_i) - }) %>% (function(scenarios_i){do.call(rbind, scenarios_i)}) + }) |> (function(scenarios_i){do.call(rbind, scenarios_i)})() ### Add driver unit - drivers_df <- drivers_df %>% mutate(driverUnit = "cm") + drivers_df <- drivers_df |> mutate(driverUnit = "cm") } ### End else if(checkSLR0) - # drivers_df %>% names %>% print + # drivers_df |> names() |> print() ### Remove intermediate objects rm("checkSLR0", "checkSLR1") ###### ** Standardize Driver Scenarios ###### ### Subset to desired years - drivers_df <- drivers_df %>% filter(year %in% list_years_by5) + drivers_df <- drivers_df |> filter(year %in% list_years_by5) ###### Population Scenario ###### - paste0("\n", msg1) %>% message("Preparing population scenario...") + paste0("\n", msg1) |> message("Preparing population scenario...") ###### Region Population Scenario ###### ### Population inputs if(has_popInput) { - msg2 %>% message("Creating population scenario from user inputs...") - pop_df <- popInput %>% select(c(all_of(popCols))) - pop_df <- pop_df %>% interpolate_annual(years= list_years_by5, column = "reg_pop", rule = 2:2) - pop_df <- pop_df %>% rename(region_pop = reg_pop) + msg2 |> message("Creating population scenario from user inputs...") + pop_df <- popInput |> select(c(all_of(popCols))) + pop_df <- pop_df |> interpolate_annual(years= list_years_by5, column = "reg_pop", rule = 2:2) + pop_df <- pop_df |> rename(region_pop = reg_pop) rm("popInput") } ### End if(has_popInput) else { - # msg1 %>% message("No population scenario provided...") - msg2 %>% message("Using default population scenario...") + # msg1 |> message("No population scenario provided...") + msg2 |> message("Using default population scenario...") pop_df <- svPopList$iclus_region_pop } ### End else(has_popInput) ### Standardize population data - pop_df <- pop_df %>% filter(year >= minYear) %>% filter(year <= maxYear) - pop_df <- pop_df %>% mutate(region = gsub("\\.", " ", region)) + pop_df <- pop_df |> filter(year >= minYear) |> filter(year <= maxYear) + pop_df <- pop_df |> mutate(region = gsub("\\.", " ", region)) ###### County Population Scenario ###### - msg2 %>% message("Calculating county population from regional population...") + msg2 |> message("Calculating county population from regional population...") df_popProj <- calc_countyPop( regPop = pop_df, funList = svPopList$popProjList, @@ -566,38 +566,38 @@ run_fredi_sv <- function( ###### Calculate Impacts ###### ### Iterate over adaptations/variants - df_results <- 1:nrow(df_sectorInfo) %>% lapply(function( + df_results <- 1:nrow(df_sectorInfo) |> lapply(function( row_i, info_x = df_sectorInfo, scenarios_x = c_scenarios ){ - # scenarios_x %>% print + # scenarios_x |> print() ### Which SV data to use - svName_i <- ifelse(c_sector=="Coastal Properties", "svDataCoastal", "svData"); # svName_i %>% print - # svDataList[[svName_i]] %>% names %>% print; # return() + svName_i <- ifelse(c_sector=="Coastal Properties", "svDataCoastal", "svData"); # svName_i |> print() + # svDataList[[svName_i]] |> names() |> print(); # return() ### Sector info info_i <- info_x[row_i,] sectorAbbr_i <- info_i$impactList_fileExt[1] variantLabel_i <- info_i$variant_label[1] variantAbbr_i <- info_i$variant_abbr[1] weightsCol_i <- info_i$popWeightCol[1] - # info_i %>% print + # info_i |> print() ### Which impacts list to use - impactsName_i <- "impactsList" %>% - paste(sectorAbbr_i, sep="_") %>% - paste0(ifelse(is.na(variantAbbr_i), "", "_")) %>% + impactsName_i <- "impactsList" |> + paste(sectorAbbr_i, sep="_") |> + paste0(ifelse(is.na(variantAbbr_i), "", "_")) |> paste0(ifelse(is.na(variantAbbr_i), "", variantAbbr_i)) - impactsPath_i <- impactsPath %>% file.path(impactsName_i) %>% paste0(".", rDataType) + impactsPath_i <- impactsPath |> file.path(impactsName_i) |> paste0(".", rDataType) ###### Iterate Over Scenarios ###### - results_i <- scenarios_x %>% lapply(function(scenario_j){ - paste0("\n", msg1) %>% message("Calculating impacts for sector='", c_sector, "', variant='", + results_i <- scenarios_x |> lapply(function(scenario_j){ + paste0("\n", msg1) |> message("Calculating impacts for sector='", c_sector, "', variant='", variantLabel_i, "', scenario='", scenario_j, "'...") ###### Scaled Impacts ###### - drivers_j <- drivers_df %>% filter(scenario == scenario_j) %>% select(-c("scenario")) - # drivers_j %>% glimpse + drivers_j <- drivers_df |> filter(scenario == scenario_j) |> select(-c("scenario")) + # drivers_j |> glimpse() ### Get impact list, calculate scaled impacts, remove impact list - if(!exists("impactsList_j")){impactsList_j <- impactsPath_i %>% readRDS} - # impactsList_j[[as.character(29031880500)]](1.667535543) %>% print; return() + if(!exists("impactsList_j")){impactsList_j <- impactsPath_i |> readRDS()} + # impactsList_j[[as.character(29031880500)]](1.667535543) |> print(); return() impacts_j <- calc_tractScaledImpacts( funList = impactsList_j, driverValues = drivers_j, @@ -608,10 +608,10 @@ run_fredi_sv <- function( ###### Total Impacts ###### ### Confirm year is numeric and filter out missing impacts - impacts_j <- impacts_j %>% mutate(year = year %>% as.character %>% as.numeric) + impacts_j <- impacts_j |> mutate(year = year |> as.character() |> as.numeric()) ### Calculate impacts by tract - impacts_j <- impacts_j %>% calc_tractImpacts( + impacts_j <- impacts_j |> calc_tractImpacts( sector = c_sector, popData = df_popProj, svInfo = svDataList[[svName_i]], @@ -622,39 +622,39 @@ run_fredi_sv <- function( .msg0 = msg2, .testing = .testing ) - impacts_j <- impacts_j %>% mutate(scenario = scenario_j) + impacts_j <- impacts_j |> mutate(scenario = scenario_j) - # (impacts_j$impPop_ref != 0) %>% which %>% length %>% print + # (impacts_j$impPop_ref != 0) |> which() |> length() |> print() ###### Return Impacts ###### return(impacts_j) }) ###### Bind Results ###### ### Bind results and add variant level - results_i <- results_i %>% (function(y){do.call(rbind, y)}) - results_i <- results_i %>% mutate(variant = variantLabel_i) + results_i <- results_i|> (function(y){do.call(rbind, y)})() + results_i <- results_i |> mutate(variant = variantLabel_i) ###### Adjust SV Group Values ###### if(!.testing){ valSuff0 <- c("ref", "sv") ### Join and adjust results valueAdj valCols0 <- c("impPop", "impact", "national_highRiskPop", "regional_highRiskPop", "aveRate") - valCols1 <- valCols0 %>% lapply(function(col_j){col_j %>% paste(valSuff0, sep="_")}) %>% unlist + valCols1 <- valCols0 |> lapply(function(col_j){col_j |> paste(valSuff0, sep="_")}) |> unlist() drop0 <- c("validGroups", "weightCol", "validType", "valueAdj") ### Adjust results - # df_validGroups %>% glimpse; results_i %>% glimpse - results_i <- results_i %>% left_join(df_validGroups, by = c("svGroupType")) - results_i <- results_i %>% mutate_at(.vars=c(all_of(valCols1)), function(col_j){col_j * results_i$valueAdj}) - results_i <- results_i %>% select(-c(all_of(drop0))); rm("drop0") - # (results_i$impPop_ref != 0) %>% which %>% length %>% print - # results_i %>% names %>% print + # df_validGroups |> glimpse(); results_i |> glimpse() + results_i <- results_i |> left_join(df_validGroups, by = c("svGroupType")) + results_i <- results_i |> mutate_at(.vars=c(all_of(valCols1)), function(col_j){col_j * results_i$valueAdj}) + results_i <- results_i |> select(-c(all_of(drop0))); rm("drop0") + # (results_i$impPop_ref != 0) |> which() |> length() |> print() + # results_i |> names() |> print() rm("valCols1") ###### Replace Driver Values ###### valCols0 <- valCols0[!(valCols0 %in% c("impPop"))] - valCols1 <- valCols0 %>% lapply(function(col_j){col_j %>% paste(valSuff0, sep="_")}) %>% unlist - # valCols1 %>% print - # driverRange %>% print; results_i$driverValue %>% range %>% print + valCols1 <- valCols0 |> lapply(function(col_j){col_j |> paste(valSuff0, sep="_")}) |> unlist() + # valCols1 |> print() + # driverRange |> print(); results_i$driverValue |> range() |> print() which0_i <- (results_i$driverValue < driverRange[1]) | (results_i$driverValue > driverRange[2]) - # results_i %>% glimpse + # results_i |> glimpse() results_i[which0_i, valCols1] <- NA rm("valCols0", "valSuff0") } @@ -663,29 +663,29 @@ run_fredi_sv <- function( }) ###### Format Results ###### ### Bind results and ungroup - df_results <- df_results %>% (function(x){do.call(rbind, x)}) - df_results <- df_results %>% ungroup %>% as.data.frame + df_results <- df_results (function(x){do.call(rbind, x)})() + df_results <- df_results |> ungroup() |> as.data.frame() ###### Save Results ###### if(save){ - msg1 %>% paste0("Saving results to Excel...") %>% message + msg1 |> paste0("Saving results to Excel...") |> message() ###### File Info ###### ###### Template Info - inFilePath <- system.file(package="FrEDI") %>% file.path("extdata", "sv") + inFilePath <- system.file(package="FrEDI") |> file.path("extdata", "sv") inFileName <- "FrEDI SV Graphics Template.xlsx" ###### Workbook Info - excel_wb_path <- inFilePath %>% file.path(inFileName) - excel_wb_exists <- excel_wb_path %>% file.exists; #excel_wb_exists %>% print + excel_wb_path <- inFilePath |> file.path(inFileName) + excel_wb_exists <- excel_wb_path |> file.exists(); #excel_wb_exists |> print() excel_wb_sheets <- c("FrEDI Outputs 1", "FrEDI Outputs 2") ###### Outfile Info and add date if specified - outFileBase <- "FrEDI" %>% paste("SV", "Outputs", c_sector, sep="_") #; outFileBase %>% print - outFileName <- outFileBase %>% paste0(".xlsx"); #outFileName %>% print + outFileBase <- "FrEDI" |> paste("SV", "Outputs", c_sector, sep="_") #; outFileBase |> print() + outFileName <- outFileBase |> paste0(".xlsx"); #outFileName |> print() if(addDate){ - today <- Sys.Date() %>% format("%Y%m%d") + today <- Sys.Date() |> format("%Y%m%d") outFileName <- paste(today, outFileName, sep="_") } - outFilePath <- outpath %>% file.path(outFileName) + outFilePath <- outpath |> file.path(outFileName) ###### Workbook Info df_readme1 <- data.frame(x=c(c_sector, as.character(Sys.Date()))) @@ -700,55 +700,55 @@ run_fredi_sv <- function( df_readme2 <- data.frame(x=c_variantLabels) ###### Check Directory and File ###### - outDirExists <- outFilePath %>% dirname %>% dir.exists - outFileExists <- outFilePath %>% file.exists + outDirExists <- outFilePath |> dirname() |> dir.exists() + outFileExists <- outFilePath |> file.exists() if(!excel_wb_exists){ - msg2 %>% paste0("Warning: Excel template '", inFileName, "' not found in '", inFilePath, "'...") %>% message - msg2 %>% paste0("Exiting without saving...") %>% message + msg2 |> paste0("Warning: Excel template '", inFileName, "' not found in '", inFilePath, "'...") |> message() + msg2 |> paste0("Exiting without saving...") |> message() } ### What to do if the directory doesn't exist if(!outDirExists){ - msg2 %>% paste0("Warning: `outpath='", outpath, "' does not exist...", "\n") %>% message - msg2 %>% paste0("Exiting without saving...") %>% message + msg2 |> paste0("Warning: `outpath='", outpath, "' does not exist...", "\n") |> message() + msg2 |> paste0("Exiting without saving...") |> message() } ### What to do if the directory exists if(outFileExists & !overwrite){ - msg2 %>% paste0("Warning: Excel file '", outFileName,"' already exists!") %>% message + msg2 |> paste0("Warning: Excel file '", outFileName,"' already exists!") |> message() overwritePrompt <- paste0("Overwrite existing file (y/n)?") - overwriteInput <- readline(prompt = overwritePrompt) %>% tolower; #rm("overwritePrompt") + overwriteInput <- readline(prompt = overwritePrompt) |> tolower(); #rm("overwritePrompt") overwrite <- ifelse(overwriteInput == "y", T, overwrite) } ###### If not overwrite, then return and exit writeFile <- (outFileExists & overwrite) | (!outFileExists) if(!writeFile){ - msg2 %>% paste0("Exiting without saving...") %>% message + msg2 |> paste0("Exiting without saving...") |> message() } ### End if(!writeFile) else{ ### Open the workbook and write ReadMe info - if(msgUser){ msg2 %>% paste0("Formatting workbook...") %>% message} - excel_wb <- excel_wb_path %>% loadWorkbook() + if(msgUser){ msg2 |> paste0("Formatting workbook...") |> message()} + excel_wb <- excel_wb_path |> loadWorkbook() ### Write sector, date/time, and variant info to workbook ### sector & date/time info - excel_wb %>% writeData( + excel_wb |> writeData( x = df_readme1, sheet = "ReadMe", startCol = 3, startRow = 3, colNames = F ) ####### Write variant info - excel_wb %>% writeData( + excel_wb |> writeData( x = df_readme2, sheet = "ReadMe", startCol = 3, startRow = 7, colNames = F ) ###### Add Styles # https://rdrr.io/cran/openxlsx/man/addStyle.html for(i in 1:nrow(co_formatting)){ - df_info_i <- co_formatting[i,] %>% as.data.frame + df_info_i <- co_formatting[i,] |> as.data.frame() format_i <- df_info_i$styleName[1] - sheet_i <- df_info_i$worksheet[1] #; sheet_i %>% print + sheet_i <- df_info_i$worksheet[1] #; sheet_i |> print() rows_i <- (df_info_i$first_row[1]):(df_info_i$end_row[1]) cols_i <- (df_info_i$first_col[1]):(df_info_i$end_col[1]) ### Style style_i <- format_styles[[format_i]] ### Add the style to the workbook - excel_wb %>% addStyle( + excel_wb |> addStyle( style = style_i, sheet = sheet_i, rows = rows_i, cols = cols_i, gridExpand = T, stack = T @@ -758,31 +758,31 @@ run_fredi_sv <- function( } ###### Write results - if(msgUser){ msg2 %>% paste0("Writing results...") %>% message} + if(msgUser){ msg2 |> paste0("Writing results...") |> message()} for(i in 1:nrow(df_sectorInfo)){ variant_i <- df_sectorInfo$variant_label[i] sheet_i <- excel_wb_sheets[i] label_i <- c_variantLabels[i] ### Filter results and rename - results_i <- df_results %>% filter(variant == variant_i) - results_i <- results_i %>% mutate(variant = label_i) + results_i <- df_results |> filter(variant == variant_i) + results_i <- results_i |> mutate(variant = label_i) ### Save results - excel_wb %>% writeData( + excel_wb |> writeData( x = results_i, sheet = sheet_i, startCol = 1, startRow = 2, colNames = F, na.string = "" ) rm("i", "variant_i", "sheet_i", "label_i", "results_i") } ### Save object - excel_wb %>% saveWorkbook(file=outFilePath, overwrite = overwrite) + excel_wb |> saveWorkbook(file=outFilePath, overwrite = overwrite) rm("excel_wb") } ### End if overwrite ### System time - # sysTime4 <- Sys.time(); (sysTime4 - sysTime3) %>% print + # sysTime4 <- Sys.time(); (sysTime4 - sysTime3) |> print() } ### End if save ###### Return Object ###### - msg1 %>% paste0("Finished.") %>% message - df_results <- df_results %>% ungroup %>% as.data.frame + msg1 |> paste0("Finished.") |> message() + df_results <- df_results |> ungroup() |> as.data.frame() returnList <- df_results # if(.testing) {returnList <- list(results = df_results, county_pop = df_popProj)} diff --git a/FrEDI/R/temps2slr.R b/FrEDI/R/temps2slr.R index e95bc744..6d7d9375 100644 --- a/FrEDI/R/temps2slr.R +++ b/FrEDI/R/temps2slr.R @@ -34,13 +34,13 @@ #temps2slr(years = seq(2020, 2080, 10), temps =1:7) #' #' ### Path to example scenarios -#' scenariosPath <- system.file(package="FrEDI") %>% file.path("extdata","scenarios") +#' scenariosPath <- system.file(package="FrEDI") |> file.path("extdata","scenarios") #' ### View example scenario names #' -#' scenariosPath %>% list.files +#' scenariosPath |> list.files() #' #' ### Temperature Scenario File Name -#' tempInputFile <- scenariosPath %>% file.path("GCAM_scenario.csv") +#' tempInputFile <- scenariosPath |> file.path("GCAM_scenario.csv") #' #' ### Import example temperature scenario #' example_inputsList <- import_inputs(tempfile = tempInputFile) @@ -91,7 +91,7 @@ temps2slr <- function( assign(names(temps2slr_constants)[i], temps2slr_constants[[i]]) } #### Reference year is 2000 - ref_year0 <- rDataList[["co_modelTypes"]] %>% filter(modelType_id == "slr") %>% (function(x){x$modelRefYear[1]}) + ref_year0 <- rDataList[["co_modelTypes"]] |> filter(modelType_id == "slr") |> (function(x){x$modelRefYear[1]})() # year0 <- ref_year0 eqtemp_offset <- 0.62 @@ -105,17 +105,17 @@ temps2slr <- function( # ### Filter to years of interest 2000-2090 # # max_year <- 2090 # new_years <- seq(year0, max_year) - # num_x <- new_years %>% length() + # num_x <- new_years |> length() # ind_x <- 1:num_x # ### Initialize Data - # df_x0 <- data.frame(year = years, temp_C = temps) %>% - # filter(year >= year0) %>% + # df_x0 <- data.frame(year = years, temp_C = temps) |> + # filter(year >= year0) |> # filter(year <= max_year) # # # # pull out 2000 data - # temp_C0 <- (df_x0 %>% filter(year == 2000))$temp_C[1] + # temp_C0 <- (df_x0 |> filter(year == 2000))$temp_C[1] # # ###To-do exit gracefully within tempbin() # if(is.na(temp_C0)) { @@ -127,23 +127,23 @@ temps2slr <- function( ###### Initialize Data ###### ### Filter NA values and make sure values are numeric - df_x0 <- data.frame(year = years, temp_C = temps) %>% - mutate_at(c("year", "temp_C"), as.character) %>% - mutate_at(c("year", "temp_C"), as.numeric) %>% - filter(!is.na(year) & !is.na(temp_C)) %>% + df_x0 <- data.frame(year = years, temp_C = temps) |> + mutate_at(c("year", "temp_C"), as.character) |> + mutate_at(c("year", "temp_C"), as.numeric) |> + filter(!is.na(year) & !is.na(temp_C)) |> arrange_at(.vars=c("year")) ### Check that there are no duplicate rows ### Unique years in the data - years0 <- df_x0$year %>% unique - hasDuplicates <- (df_x0 %>% nrow) > (years0 %>% length) + years0 <- df_x0$year |> unique() + hasDuplicates <- (df_x0 |> nrow()) > (years0 |> length()) if(hasDuplicates){ message("\t", "Warning:") message("\t\t", "In 'temps2slr()': There are duplicate years in the inputs.") message("\t\t\t", "Averaging values for duplicate years...") - df_x0 <- df_x0 %>% - group_by_at(.vars = c("year")) %>% + df_x0 <- df_x0 |> + group_by_at(.vars = c("year")) |> summarize_at(c("temp_C"), mean, na.rm=T) } @@ -153,8 +153,8 @@ temps2slr <- function( checkRefYear <- (ref_year0 %in% df_x0$year) ### If 2020 not found, check for values above and below 2000 if(!checkRefYear){ - minYearInput0 <- df_x0$year %>% min(na.rm=T) - maxYearInput0 <- df_x0$year %>% max(na.rm=T) + minYearInput0 <- df_x0$year |> min(na.rm=T) + maxYearInput0 <- df_x0$year |> max(na.rm=T) checkRefYear <- (minYearInput0 < ref_year0) & (maxYearInput0 > ref_year0) } @@ -171,7 +171,7 @@ temps2slr <- function( } ### If there is a valid temperature series else{ - year0 <- df_x0$year %>% min(na.rm=T) + year0 <- df_x0$year |> min(na.rm=T) ###### Standardize data ##### ### Filter to years of interest 2000-2090 @@ -180,36 +180,36 @@ temps2slr <- function( new_years <- seq(ref_year0, max_year) - num_x <- new_years %>% length() + num_x <- new_years |> length() ind_x <- 1:num_x ###### Interpolate the data ##### ### Interpolated Data # function require annual data df_x1 <- - data.frame(year = new_years0, temp_C = NA) %>% + data.frame(year = new_years0, temp_C = NA) |> mutate(temp_C=approx( x = df_x0$year, y = df_x0$temp_C, xout = new_years0, rule = 2 - )$y) %>% - filter(year>=ref_year0) %>% - mutate(equilTemp = NA, slr_mm = NA) %>% - select(year, temp_C, equilTemp, slr_mm) %>% - mutate(yearFrom0 = year - ref_year0) %>% + )$y) |> + filter(year>=ref_year0) |> + mutate(equilTemp = NA, slr_mm = NA) |> + select(year, temp_C, equilTemp, slr_mm) |> + mutate(yearFrom0 = year - ref_year0) |> mutate(phi = phi0 * exp(-yearFrom0 / tau2)) ###### Series ###### ### Calculate base values - df_x <- df_x1 %>% + df_x <- df_x1 |> ### Equilibrium temps (function(k){ for(i in ind_x){ if(i == 1){ ### Initialize temperature - temp_C0 <- (df_x1 %>% filter(year==ref_year0))$temp_C[1] + temp_C0 <- (df_x1 |> filter(year==ref_year0))$temp_C[1] k$equilTemp[i] <- temp_C0 - eqtemp_offset k$slr_mm[i] <- 0 } else{ @@ -218,11 +218,11 @@ temps2slr <- function( } } return(k) - }) %>% + })() |> ### GMSL in cm - select(year, slr_mm) %>% - mutate(slr_cm = slr_mm * mm2cm) %>% # convert from mm to cm + select(year, slr_mm) |> + mutate(slr_cm = slr_mm * mm2cm) |> # convert from mm to cm select(-slr_mm) return(df_x) diff --git a/FrEDI/R/utils.R b/FrEDI/R/utils.R index a7f9e00e..3778b3ed 100644 --- a/FrEDI/R/utils.R +++ b/FrEDI/R/utils.R @@ -5,7 +5,7 @@ get_vector <- function( ){ ### Select column and get values as vector col0 <- ifelse(is.null(column), c(), column) - vals0 <- data[[column]] %>% as.vector + vals0 <- data[[column]] |> as.vector() ### Return return(vals0) } @@ -15,11 +15,11 @@ get_uniqueValues <- function( data, column = NULL, sort=TRUE ){ ### Select column and get values as vector - vals0 <- data %>% get_vector(column) - vals0 <- vals0 %>% unique - # vals0 %>% print + vals0 <- data |> get_vector(column) + vals0 <- vals0 |> unique() + # vals0 |> print() ### Sort - if(sort){vals0 <- vals0 %>% sort} + if(sort){vals0 <- vals0 |> sort()} ### Return return(vals0) } @@ -31,7 +31,7 @@ get_msgPrefix <- function(level=1){ msg0 <- "\t" ### Message indent level 0 mcom <- ", " ### Comma for collapsing lists mqu0 <- "\'" ### Message quote - mqu1 <- mqu0 %>% paste0(mcom, mqu0, collapse="") + mqu1 <- mqu0 |> paste0(mcom, mqu0, collapse="") mend0 <- "..." msg_x <- msg0 return(msg_x) @@ -52,27 +52,27 @@ interpolate_annual <- function( ){ ###### Data Info ###### ##### Columns - dataCols <- data %>% names + dataCols <- data |> names() defCols <- c("year", "region") defCol0 <- dataCols[!(dataCols %in% defCols)][1] column0 <- ifelse(is.null(column), defCol0, column) othCols <- dataCols[!(dataCols %in% c(defCols, column0))] rm("defCol0") ###### Format data - data <- data %>% filter(!is.na(column0)) - values0 <- data %>% get_vector(column0) - years0 <- data %>% get_vector(defCols[1]) + data <- data |> filter(!is.na(column0)) + values0 <- data |> get_vector(column0) + years0 <- data |> get_vector(defCols[1]) ### Interpolation years doYears <- is.null(years) if(doYears){ - years <- years0 %>% range(na.rm=TRUE); + years <- years0 |> range(na.rm=TRUE); years <- years[1]:years[2] }; rm("doYears") ##### Regions regions0 <- region addRegion <- !("region" %in% dataCols) - if(addRegion) {data <- data %>% mutate(region = regions0[1])} - else {regions0 <- data %>% get_uniqueValues("region")} + if(addRegion) {data <- data |> mutate(region = regions0[1])} + else {regions0 <- data |> get_uniqueValues("region")} rm("addRegion") ###### Interpolation Info ###### @@ -83,29 +83,29 @@ interpolate_annual <- function( repRule <- length(rule) < 2 defRule <- c(1) if(nullRule){rule <- defRule} - if(repRule ){rule <- rule %>% rep(2)} + if(repRule ){rule <- rule |> rep(2)} method <- ifelse(is.null(method), "linear", method) ###### Interpolate missing values for each region ###### ### Filter to the region and then interpolate missing values cols0 <- c("x", "y"); cols1 <- c("year", column0) - df_interp <- regions0 %>% lapply(function(region_i){ + df_interp <- regions0 |> lapply(function(region_i){ ### Values - which_i <- (data$region==region_i) %>% which + which_i <- (data$region==region_i) |> which() x_i <- years0[which_i] y_i <- values0[which_i] ### Approximate new_i <- approx(x = x_i, y = y_i, xout = years, rule = rule, method = method) - new_i <- new_i %>% as.data.frame - new_i <- new_i %>% rename_at(.vars=c(all_of(cols0)), ~cols1) - new_i <- new_i %>% mutate(region = region_i) + new_i <- new_i |> as.data.frame() + new_i <- new_i |> rename_at(.vars=c(all_of(cols0)), ~cols1) + new_i <- new_i |> mutate(region = region_i) ### Return return(new_i) - }) %>% (function(i){do.call(rbind, i)}) - # df_interp %>% names %>% print - # new_i <- new_i %>% select(c(all_of(dataCols))) - # new_i <- new_i %>% select(c(all_of(defCols), all_of(column0))) + }) |> (function(i){do.call(rbind, i)})() + # df_interp |> names() |> print() + # new_i <- new_i |> select(c(all_of(dataCols))) + # new_i <- new_i |> select(c(all_of(defCols), all_of(column0))) ### Return return(df_interp) } ### End function @@ -125,46 +125,46 @@ match_scalarValues <- function( scalarType ){ ### Scalar columns to rename - newColNames <- scalarType %>% paste0(c("Name", "Value")) - renameCols <- "scalarName" %>% c("value") + newColNames <- scalarType |> paste0(c("Name", "Value")) + renameCols <- "scalarName" |> c("value") ### Scalar identifier column scalarColName <- newColNames[1] scalarValName <- newColNames[2] ### Rename the scalar identifier column to match that of the data - scalarNames_1 <- scalars %>% names + scalarNames_1 <- scalars |> names() names(scalars)[which(scalarNames_1 == renameCols[1])] <- scalarColName ###### Get scalars of particular type ###### - scalars <- scalars %>% filter(scalarType==scalarType) + scalars <- scalars |> filter(scalarType==scalarType) ###### Separate scalar info into national and regional ###### - scalars_regional <- scalars %>% filter(national_or_regional == "regional") - scalars_national <- scalars %>% filter(national_or_regional == "national") + scalars_regional <- scalars |> filter(national_or_regional == "regional") + scalars_national <- scalars |> filter(national_or_regional == "national") ###### ScalarName == "None" ###### ### Filter the data to those for which the scalar identifier == "none"...value = 1 - df_none <- data %>% filter(data[,scalarColName] == "none") %>% mutate(value = 1) + df_none <- data |> filter(data[,scalarColName] == "none") |> mutate(value = 1) ###### Regional values ###### - scalars_regional <- scalars %>% filter(national_or_regional == "regional") - scalarNames_reg <- scalars_regional[,scalarColName] %>% unique - df_regional <- data %>% - filter(!(data[,scalarColName] == "none") & data[,scalarColName] %in% scalarNames_reg) %>% - left_join(scalars_regional, by=c("year", "region", scalarColName)) %>% + scalars_regional <- scalars |> filter(national_or_regional == "regional") + scalarNames_reg <- scalars_regional[,scalarColName] |> unique() + df_regional <- data |> + filter(!(data[,scalarColName] == "none") & data[,scalarColName] %in% scalarNames_reg) |> + left_join(scalars_regional, by=c("year", "region", scalarColName)) |> select(-c("scalarType", "national_or_regional")) ###### National values ###### - scalars_national <- scalars %>% filter(national_or_regional == "national") %>% select(-region) - scalarNames_nat <- scalars_national[,scalarColName] %>% unique - df_national <- data %>% - filter(!(data[,scalarColName] == "none") & data[,scalarColName] %in% scalarNames_nat) %>% - left_join(scalars_national, by=c("year", scalarColName)) %>% + scalars_national <- scalars |> filter(national_or_regional == "national") |> select(-region) + scalarNames_nat <- scalars_national[,scalarColName] |> unique() + df_national <- data |> + filter(!(data[,scalarColName] == "none") & data[,scalarColName] %in% scalarNames_nat) |> + left_join(scalars_national, by=c("year", scalarColName)) |> select(-c("scalarType", "national_or_regional")) ###### Rename value column ###### df_x <- rbind(df_none, df_regional, df_national) - names_x <- df_x %>% names + names_x <- df_x |> names() names(df_x)[which(names_x == renameCols[2])] <- scalarValName ###### Return results values ###### @@ -185,35 +185,35 @@ get_econAdjValues <- function( scenario, ### Population and GDP scenario multipliers ### List of multipliers ){ - # data %>% names %>% print; + # data |> names() |> print(); ###### Multipliers multiplier0 <- "none" multipliers <- multipliers[multipliers!=multiplier0] ###### Scenario information - cRegions <- scenario$region %>% unique - cNames <- scenario %>% names; cNames <- cNames[cNames %in% multipliers] + cRegions <- scenario$region |> unique() + cNames <- scenario |> names(); cNames <- cNames[cNames %in% multipliers] ###### Format scalar data ###### Get values for a single region since the multipliers are the same for all regions ###### Gather scenario information - scalars <- scenario %>% filter(region==cRegions[1]) - scalars <- scalars %>% select(c("year", all_of(cNames))) - scalars <- scalars %>% gather(key="econMultiplierName", value="econMultiplierValue", -c("year")) - # data %>% names %>% print; scalars %>% names %>% print + scalars <- scenario |> filter(region==cRegions[1]) + scalars <- scalars |> select(c("year", all_of(cNames))) + scalars <- scalars |> gather(key="econMultiplierName", value="econMultiplierValue", -c("year")) + # data |> names() |> print(); scalars |> names() |> print() ###### Multiplier Adjustment ### Rename scalars and convert year to character cols0 <- c("year" , "econMultiplierName", "econMultiplierValue") cols1 <- c("year0", "econAdjName" , "econAdjValue") - scalarAdj <- scalars %>% rename_at(.vars=c(all_of(cols0)), ~cols1) - scalarAdj <- scalarAdj %>% mutate(year0 = year0 %>% as.character) + scalarAdj <- scalars |> rename_at(.vars=c(all_of(cols0)), ~cols1) + scalarAdj <- scalarAdj |> mutate(year0 = year0 |> as.character()) # rm("cols0", "cols1") - # data$year %>% class %>% print; scalarAdj$year %>% class %>% print + # data$year |> class() |> print(); scalarAdj$year |> class() |> print() ###### Format data and separate - # data %>% names %>% print; scalarAdj %>% names %>% print - data <- data %>% mutate(econAdjName = econMultiplierName) - df_none <- data %>% filter(econMultiplierName == multiplier0) - df_oth <- data %>% filter(econMultiplierName != multiplier0) + # data |> names() |> print(); scalarAdj |> names() |> print() + data <- data |> mutate(econAdjName = econMultiplierName) + df_none <- data |> filter(econMultiplierName == multiplier0) + df_oth <- data |> filter(econMultiplierName != multiplier0) rm("data") ###### ScalarName == "None" ### Columns @@ -223,12 +223,12 @@ get_econAdjValues <- function( ### Set econMultiplierValue, econAdjValue == 1 if scalarMultiplierName=none if(nrow(df_none)) {df_none[,mutate0] <- 1} ###### Other Multipliers - df_oth <- df_oth %>% left_join(scalars , by=c(cols0[!(cols0 %in% mutate0)])) - # df_oth %>% names %>% print; scalars %>% names %>% print - # scalarAdj$year0 %>% class %>% print; df_oth$year0 %>% class %>% print - df_oth <- df_oth %>% left_join(scalarAdj, by=c(cols1[!(cols1 %in% mutate0)])) + df_oth <- df_oth |> left_join(scalars , by=c(cols0[!(cols0 %in% mutate0)])) + # df_oth |> names() |> print(); scalars |> names() |> print() + # scalarAdj$year0 |> class() |> print(); df_oth$year0 |> class() |> print() + df_oth <- df_oth |> left_join(scalarAdj, by=c(cols1[!(cols1 %in% mutate0)])) ###### Rename value column - df_x <- df_none %>% rbind(df_oth) %>% select(-c(all_of(drop0))) + df_x <- df_none |> rbind(df_oth) |> select(-c(all_of(drop0))) ###### Return results values return(df_x) } @@ -246,31 +246,31 @@ calcScalars <- function( ){ ###### Calculate physical scalar ###### ### Physical scalars are the product of the physical scalar, the physical adjustment, and the damage adjustment - df_x <- data %>% mutate(physScalar = physScalarValue * physAdjValue * damageAdjValue ) + df_x <- data |> mutate(physScalar = physScalarValue * physAdjValue * damageAdjValue ) ###### Adjust Elasticity for VSL ###### ### Adjust Elasticity for VSL only if(!is.null(elasticity)){ - df_not_vsl <- df_x %>% filter(econScalarName!="vsl_usd") - df_vsl <- df_x %>% filter(econScalarName=="vsl_usd") %>% mutate(exp0 = elasticity) - df_x <- df_not_vsl %>% rbind(df_vsl); rm("df_not_vsl", "df_vsl") - # if(is.numeric(elasticity)){df_x <- df_x %>% mutate(exp0 = elasticity)} + df_not_vsl <- df_x |> filter(econScalarName!="vsl_usd") + df_vsl <- df_x |> filter(econScalarName=="vsl_usd") |> mutate(exp0 = elasticity) + df_x <- df_not_vsl |> rbind(df_vsl); rm("df_not_vsl", "df_vsl") + # if(is.numeric(elasticity)){df_x <- df_x |> mutate(exp0 = elasticity)} } ###### Calculate economic adjustment ###### ### Economic multipliers are the economic multiplier value divided by the adjustment ### The economic multiplier value is 1, GDP, or GDP per capita ### The economic adjustment value is usually the economic multiplier value at a reference year - df_x <- df_x %>% mutate(econMultiplier = (econMultiplierValue / econAdjValue)**exp0 ) + df_x <- df_x |> mutate(econMultiplier = (econMultiplierValue / econAdjValue)**exp0 ) ###### Calculate economic scalar ###### ### The economic scalar is calculated using the following equation. ### Constants c0, c1, and exp0 are from the - df_x <- df_x %>% mutate(econScalar = c0 + c1 * econScalarValue * (econMultiplier) ) + df_x <- df_x |> mutate(econScalar = c0 + c1 * econScalarValue * (econMultiplier) ) ###### Calculate economic-physical scalar ###### ### Combine the physical and economic scalar. - df_x <- df_x %>% mutate(physEconScalar = econScalar * physScalar ) + df_x <- df_x |> mutate(physEconScalar = econScalar * physScalar ) ###### Return ###### return(df_x) @@ -287,25 +287,25 @@ get_scenario_id <- function( msg0 <- "\t" ### Message indent level 0 mcom <- ", " ### Comma for collapsing lists mqu0 <- "\'" ### Message quote - mqu1 <- mqu0 %>% paste0(mcom, mqu0, collapse="") + mqu1 <- mqu0 |> paste0(mcom, mqu0, collapse="") mend0 <- "..." ### Columns to include main0 <- c("sector", "variant", "impactYear", "impactType", "model_type") - cols0 <- main0 %>% c(include) + cols0 <- main0 |> c(include) ### Check names - names0 <- data_x %>% names + names0 <- data_x |> names() cCheck <- (cols0 %in% names0) - nCheck <- (!cCheck) %>% which %>% length + nCheck <- (!cCheck) |> which() |> length() if(nCheck){ - c("In get_scenario_id:") %>% c(mnl0, msg0) %>% - c("Data is missing columns ") %>% c(mqu0, paste(cols0[!cCheck], collapse=mqu1), mqu0, mend0) %>% - c("Creating `scenario_id` from columns ") %>% c(mqu0, paste(cols0[cCheck], collapse=mqu1), mqu0, mend0) + c("In get_scenario_id:") |> c(mnl0, msg0) |> + c("Data is missing columns ") |> c(mqu0, paste(cols0[!cCheck], collapse=mqu1), mqu0, mend0) |> + c("Creating `scenario_id` from columns ") |> c(mqu0, paste(cols0[cCheck], collapse=mqu1), mqu0, mend0) ### New names cols0 <- cols0[cCheck] } scen_x <- data_x[,cols0] - scen_x <- scen_x %>% apply(1, function(x){as.vector(x) %>% paste(collapse ="_")}) %>% unlist - data_x <- data_x %>% mutate(scenario_id = scen_x) + scen_x <- scen_x |> apply(1, function(x){as.vector(x) |> paste(collapse ="_")}) |> unlist() + data_x <- data_x |> mutate(scenario_id = scen_x) return(data_x) } @@ -335,16 +335,16 @@ get_impactFunctions <- function( x$yIn <- x[, yCol] ###### Extend from/to ###### ### Make sure they are numeric - extend_from <- extend_from %>% as.character %>% as.numeric - extend_to <- extend_to %>% as.character %>% as.numeric + extend_from <- extend_from |> as.character() |> as.numeric() + extend_to <- extend_to |> as.character() |> as.numeric() ###### Groups ###### ### Column Names # names_x <- c(groupCol, xCol, yCol) ### Create groups and get group keys ### Group keys - x <- x %>% group_by(group_id) - groups_x <- (x %>% group_keys)$group_id %>% unique + x <- x |> group_by(group_id) + groups_x <- (x |> group_keys())$group_id |> unique() ### Initialize data xIn_min <- 0 @@ -353,24 +353,24 @@ get_impactFunctions <- function( # df_0 <- data.frame(xIn = 0, yIn = 0) ###### Generate list of impact functions ###### ### Iterate over the groups - list_x <- x %>% + list_x <- x |> group_map(function(.x, .y, .keep=T){ - group_i <- .x[,groupCol] %>% unique + group_i <- .x[,groupCol] |> unique() ###### Subset values ###### ### Subset data to scenario name and exclude NA values, then add a zero value - df_i <- .x %>% select(xIn, yIn) %>% filter(!is.na(yIn)) - df_i <- df_0 %>% rbind(df_i) + df_i <- .x |> select(xIn, yIn) |> filter(!is.na(yIn)) + df_i <- df_0 |> rbind(df_i) ###### Information about Extrapolation values ###### ### Length of df_i - len_i <- df_i %>% nrow + len_i <- df_i |> nrow() # ### Extend values out to 10 degrees of warming xIn_max <- df_i$xIn[len_i] yIn_max <- df_i$yIn[len_i] yMaxNew <- NA - # extrapolate %>% print + # extrapolate |> print(()) ### Whether to extend values ### Extend values out to the specified value ### - Find linear relationship between last two points @@ -378,19 +378,19 @@ get_impactFunctions <- function( # extrapolate <- TRUE extrapolate <- (xIn_max == extend_from) & (extend_from!=extend_to) if(extend_all) extrapolate <- TRUE - # extrapolate %>% print + # extrapolate |> print() if(extrapolate){ df_ref_i <- df_i[len_i + -1:0,] - # df_ref_i %>% print + # df_ref_i |> print() ### Get linear trend lm_i <- lm(yIn~xIn, data=df_ref_i) ### Extend values df_new_i <- data.frame(xIn = seq(xIn_max + unitScale, extend_to, unitScale)) - df_new_i <- df_new_i %>% mutate(yIn = xIn * lm_i$coefficients[2] + lm_i$coefficients[1]) + df_new_i <- df_new_i |> mutate(yIn = xIn * lm_i$coefficients[2] + lm_i$coefficients[1]) ### Bind the new observations with the other observations - df_i <- df_i %>% rbind(df_new_i) + df_i <- df_i |> rbind(df_new_i) ### Sort and get new y value to extend to - which_i <- (df_i$xIn == extend_to) %>% which + which_i <- (df_i$xIn == extend_to) |> which() yMaxNew <- df_i$yIn[which_i] } @@ -430,15 +430,15 @@ interpolate_impacts <- function( years = NULL ### Years ){ ### Names of functions and number of functions - functionNames <- functions %>% names - numFunctions <- functions %>% length + functionNames <- functions |> names() + numFunctions <- functions |> length() ### Iterate over the groups - scaledImpacts_x <- 1:numFunctions %>% lapply(function(i){ + scaledImpacts_x <- 1:numFunctions |> lapply(function(i){ ### Group, get group function, then get impacts scenario_i <- functionNames[i] fun_i <- functions[[scenario_i]] - scaledImpacts_i <- xVar %>% fun_i + scaledImpacts_i <- xVar |> fun_i() df_i <- data.frame( year = years, xVar = xVar, @@ -446,8 +446,8 @@ interpolate_impacts <- function( scenario_id = scenario_i ) return(df_i) - }) %>% (function(i){do.call(rbind, i)}) ### End group map - # scaledImpacts_x %>% names %>% print + }) |> (function(i){do.call(rbind, i)})() ### End group map + # scaledImpacts_x |> names() |> print() return(scaledImpacts_x) } @@ -462,16 +462,16 @@ get_annual_model_stats <- function( groupCol = c("sector", "variant", "model_type", "impactType", "impactYear") ### Column(s) to use for grouping ){ ###### Ungroup data ###### - # data <- data %>% ungroup + # data <- data |> ungroup() ###### Subset to sector ###### ### Get unique sectors if none are specified - defaultSectors <- data$sector %>% as.character %>% unique + defaultSectors <- data$sector |> as.character() |> unique() if(is.null(sectors)){sectors <- defaultSectors} ###### Names of Data ###### ### Models - model_labels <- data$model %>% unique - num_models <- model_labels %>% length + model_labels <- data$model |> unique() + num_models <- model_labels |> length() ###### Rename the columns ###### ### To standardize @@ -479,24 +479,24 @@ get_annual_model_stats <- function( newColNames <- c("yvar") ### Keep track of the data names, filter to the standardized data names, then rename the desired column - # data %>% names %>% print - data <- data %>% + # data |> names() |> print() + data <- data |> (function(y){ - names_y <- y %>% names + names_y <- y |> names() whichVar <- which(names_y == yVar) names(y)[whichVar] <- "yvar" return(y) - }) + })() ###### Which observations are NA ###### ### Determine which observations are NA - data <- data %>% - mutate(not_na = !is.na(yvar)) %>% + data <- data |> + mutate(not_na = !is.na(yvar)) |> mutate(not_na = not_na * 1) ### Model Type model_aves_x <- c("Model Average", "Interpolation") ### Labels for model averages - model_type_x <- (data$model_type %>% unique)[1] + model_type_x <- (data$model_type |> unique())[1] model_label_x <- ifelse(tolower(model_type_x)=="gcm", model_aves_x[1], model_aves_x[2]) ###### Reshape the data ###### @@ -505,57 +505,57 @@ get_annual_model_stats <- function( groupByCols <- default_groupCols[which(default_groupCols %in% names(data))] ### Reshape the data and prepare a column indicating which rows have is.na() for all models - data <- data %>% - select(c(all_of(groupByCols))) %>% + data <- data |> + select(c(all_of(groupByCols))) |> mutate(not_na = !is.na(yvar)) ###### Summarize by group columns ###### ### Add group column with year groupByCols <- groupByCols[which(!(groupByCols %in% c("model", "yvar")))] - df_summary <- data %>% - group_by_at(c(all_of(groupByCols))) %>% - summarize_at(.vars = c("not_na"), sum, na.rm=T) %>% - rename(sum_notNA = not_na) %>% + df_summary <- data |> + group_by_at(c(all_of(groupByCols))) |> + summarize_at(.vars = c("not_na"), sum, na.rm=T) |> + rename(sum_notNA = not_na) |> mutate( sum_notNA = (sum_notNA > 0)*1, - sum_notNA = sum_notNA %>% na_if(0) + sum_notNA = sum_notNA |> na_if(0) ) ###### Add the summary back into the data ###### groupByCols - data <- data %>% left_join(df_summary, by = c(groupByCols)) + data <- data |> left_join(df_summary, by = c(groupByCols)) ###### Calculate stats ###### ### Separate observations that are all NA from those that have at least one non NA value - is_naOnly <- data$sum_notNA %>% is.na + is_naOnly <- data$sum_notNA |> is.na() ### Treat NA only values separate from those with non NA values ### First figure out which are which - which_naOnly <- is_naOnly %>% which - which_nMiss <- (!is_naOnly) %>% which + which_naOnly <- is_naOnly |> which() + which_nMiss <- (!is_naOnly) |> which() ### Number of each - num_naOnly <- which_naOnly %>% length - num_nMiss <- which_nMiss %>% length + num_naOnly <- which_naOnly |> length() + num_nMiss <- which_nMiss |> length() ### Initialize dataframes data_naOnly <- data.frame() data_nMiss <- data.frame() if(num_naOnly > 0){ - data_naOnly <- data[which_naOnly,] %>% select(-sum_notNA) %>% + data_naOnly <- data[which_naOnly,] |> select(-sum_notNA) |> mutate(min = NA, mean = NA, max=NA) } if(num_nMiss > 0){ - data_nMiss <- data[which_nMiss,] %>% select(-sum_notNA) %>% - group_by_at(c(all_of(groupByCols))) %>% + data_nMiss <- data[which_nMiss,] |> select(-sum_notNA) |> + group_by_at(c(all_of(groupByCols))) |> summarize_at(.vars=c("yvar"), tibble::lst(min, mean, max), na.rm=T) } ###### Bind results together ###### - df_results <- data_nMiss %>% - rbind(data_naOnly) %>% - mutate(model=model_label_x) %>% - rename(modelMin = min, modelAve=mean, modelMax=max) %>% - ungroup + df_results <- data_nMiss |> + rbind(data_naOnly) |> + mutate(model=model_label_x) |> + rename(modelMin = min, modelAve=mean, modelMax=max) |> + ungroup() ###### Return ###### return(df_results) @@ -572,10 +572,10 @@ slr_Interp_byYear <- function( ###### Defaults ###### ### Rename y Column if(is.null(yCol)){yCol <- "driverValue"} - oldColName_y <- yCol %>% c() - newColName_y <- "yValue" %>% c() - newColRef_y <- newColName_y %>% paste0("_ref") - data <- data %>% rename_at(.vars=c(all_of(oldColName_y)), ~newColName_y) + oldColName_y <- yCol |> c() + newColName_y <- "yValue" |> c() + newColRef_y <- newColName_y |> paste0("_ref") + data <- data |> rename_at(.vars=c(all_of(oldColName_y)), ~newColName_y) ### Messaging if(is.null(silent)){silent <- T} if(silent){msgUser <- F} else{msgUser <- T} @@ -583,32 +583,32 @@ slr_Interp_byYear <- function( ###### Assign data ###### ### SLR scenario info assign("co_models", rDataList[["co_models"]]) - co_slrs <- co_models %>% filter(modelType=="slr") %>% rename(model=model_label) + co_slrs <- co_models |> filter(modelType=="slr") |> rename(model=model_label) slr_levels <- c("0cm", co_slrs$model_dot) slr_labels <- c("0 cm", co_slrs$model) - slr_orders <- slr_levels %>% factor(levels=slr_levels) %>% as.numeric - slr_min <- (slr_orders %>% min(na.rm=T)) #+ 1 - slr_max <- slr_orders %>% max(na.rm=T) + slr_orders <- slr_levels |> factor(levels=slr_levels) |> as.numeric() + slr_min <- (slr_orders |> min(na.rm=T)) #+ 1 + slr_max <- slr_orders |> max(na.rm=T) ### Sea level rise information assign("slr_df", rDataList[["slr_cm"]]) - df_slr_years <- slr_df$year %>% unique + df_slr_years <- slr_df$year |> unique() ### Refactor model - slr_df <- slr_df %>% - mutate(model = model %>% as.character) %>% - mutate(model_factor = model %>% factor(slr_levels, slr_labels)) %>% - mutate(model_level = model_factor %>% as.numeric) %>% - arrange_at(.vars=c("model_level", "year")) %>% - mutate(model = model_factor %>% as.character) %>% - select(-c("model_factor")) %>% as.data.frame + slr_df <- slr_df |> + mutate(model = model |> as.character()) |> + mutate(model_factor = model |> factor(slr_levels, slr_labels)) |> + mutate(model_level = model_factor |> as.numeric()) |> + arrange_at(.vars=c("model_level", "year")) |> + mutate(model = model_factor |> as.character()) |> + select(-c("model_factor")) |> as.data.frame() ### Character vector of model names c_slrs0 <- slr_labels ### Check that years are unique - data_years <- data$year %>% unique - n_data_years <- data_years %>% length - nrows_data <- data %>% nrow + data_years <- data$year |> unique() + n_data_years <- data_years |> length() + nrows_data <- data |> nrow() check_unique_years <- nrows_data > n_data_years if(check_unique_years){ @@ -616,14 +616,14 @@ slr_Interp_byYear <- function( message("\t", "values for 'yCol' are not unique...") message("\t", "Averaging over 'yCol' values...") } - data <- data %>% group_by_at(c("year")) %>% summarize_at(c("yValue"), mean, na.rm=T) + data <- data |> group_by_at(c("year")) |> summarize_at(c("yValue"), mean, na.rm=T) } rm("n_data_years", "nrows_data", "check_unique_years") ###### Prepare data ###### ### Filter to appropriate years - data <- data %>% filter(year %in% df_slr_years) - n_years <- data %>% nrow + data <- data |> filter(year %in% df_slr_years) + n_years <- data |> nrow() ###### Standard Columns ###### ### JoinCols @@ -631,62 +631,62 @@ slr_Interp_byYear <- function( select0 <- c("year", newColName_y, newColRef_y, "model") select1 <- c("year", newColName_y, "lower_model", "upper_model", "lower_slr", "upper_slr") ### Format data - # y <- y %>% mutate(model_factor = model_factor %>% as.character) + # y <- y |> mutate(model_factor = model_factor |> as.character()) x <- data; rm("data") - y <- slr_df %>% rename(yValue_ref = driverValue); rm("slr_df") + y <- slr_df |> rename(yValue_ref = driverValue); rm("slr_df") ### Join - z <- x %>% left_join(y, by = "year") + z <- x |> left_join(y, by = "year") ### Filter observations - z_lo <- z %>% filter(yValue_ref <= yValue); #n_lo <- z_lo %>% nrow - z_hi <- z %>% filter(yValue_ref >= yValue); #n_hi <- z_hi %>% nrow + z_lo <- z |> filter(yValue_ref <= yValue); #n_lo <- z_lo |> nrow() + z_hi <- z |> filter(yValue_ref >= yValue); #n_hi <- z_hi |> nrow() ### Figure if years are missing yrs_z <- x$year - yrs_lo <- z_lo$year %>% unique %>% sort; nas_lo <- yrs_z[!(yrs_z %in% yrs_lo)] - yrs_hi <- z_hi$year %>% unique %>% sort; nas_hi <- yrs_z[!(yrs_z %in% yrs_hi)] + yrs_lo <- z_lo$year |> unique() |> sort(); nas_lo <- yrs_z[!(yrs_z %in% yrs_lo)] + yrs_hi <- z_hi$year |> unique() |> sort(); nas_hi <- yrs_z[!(yrs_z %in% yrs_hi)] ### Add years to data - dfNaLo <- data.frame(year = yrs_lo, model_level = slr_min) %>% left_join(z, by = c(all_of(join0))) - dfNaHi <- data.frame(year = yrs_lo, model_level = slr_max) %>% left_join(z, by = c(all_of(join0))) + dfNaLo <- data.frame(year = yrs_lo, model_level = slr_min) |> left_join(z, by = c(all_of(join0))) + dfNaHi <- data.frame(year = yrs_lo, model_level = slr_max) |> left_join(z, by = c(all_of(join0))) ### Add missing values back in - z_lo <- z_lo %>% rbind(dfNaLo) %>% arrange_at(.vars=c(join0[1])) - z_hi <- z_hi %>% rbind(dfNaHi) %>% arrange_at(.vars=c(join0[1])) + z_lo <- z_lo |> rbind(dfNaLo) |> arrange_at(.vars=c(join0[1])) + z_hi <- z_hi |> rbind(dfNaHi) |> arrange_at(.vars=c(join0[1])) ### Get low values - x_lo <- z_lo %>% - group_by_at(.vars=c("year")) %>% - summarize_at(.vars=c("model_level"), max, na.rm=T) %>% ungroup %>% + x_lo <- z_lo |> + group_by_at(.vars=c("year")) |> + summarize_at(.vars=c("model_level"), max, na.rm=T) |> ungroup() |> (function(a, b = x){ - b %>% left_join(a, by = c("year")) - }) %>% - left_join(y, by=c("year", "model_level")) %>% - select(c(all_of(select0))) %>% + b |> left_join(a, by = c("year")) + })() |> + left_join(y, by=c("year", "model_level")) |> + select(c(all_of(select0))) |> rename(lower_slr = yValue_ref, lower_model = model) ### Get hi values - x_hi <- z_hi %>% - group_by_at(.vars=c("year")) %>% - summarize_at(.vars=c("model_level"), min, na.rm=T) %>% ungroup %>% + x_hi <- z_hi |> + group_by_at(.vars=c("year")) |> + summarize_at(.vars=c("model_level"), min, na.rm=T) |> ungroup() |> (function(a, b = x){ - b %>% left_join(a, by = c("year")) - }) %>% - left_join(y, by=c("year", "model_level")) %>% - select(c(all_of(select0))) %>% + b |> left_join(a, by = c("year")) + })() |> + left_join(y, by=c("year", "model_level")) |> + select(c(all_of(select0))) |> rename(upper_slr = yValue_ref, upper_model = model) ### Join all - z <- x_lo %>% left_join(x_hi, by = c("year", all_of(newColName_y))) - z <- z %>% select(c(all_of(select1))) + z <- x_lo |> left_join(x_hi, by = c("year", all_of(newColName_y))) + z <- z |> select(c(all_of(select1))) ### Add adjustment - z <- z %>% - mutate(denom_slr = upper_slr - lower_slr ) %>% - mutate(numer_slr = upper_slr - yValue) %>% - mutate(adj_slr = numer_slr / denom_slr ) %>% - mutate(is_inf = adj_slr %>% is.infinite) %>% - mutate(adj_slr = adj_slr * (!is_inf)) %>% - mutate(adj_slr = adj_slr %>% replace_na(0)) %>% + z <- z |> + mutate(denom_slr = upper_slr - lower_slr ) |> + mutate(numer_slr = upper_slr - yValue) |> + mutate(adj_slr = numer_slr / denom_slr ) |> + mutate(is_inf = adj_slr |> is.infinite()) |> + mutate(adj_slr = adj_slr * (!is_inf)) |> + mutate(adj_slr = adj_slr |> replace_na(0)) |> select(-c("is_inf")) ### Rename yValue and return - df_return <- z %>% rename_at(.vars=c(all_of(newColName_y)), ~oldColName_y) + df_return <- z |> rename_at(.vars=c(all_of(newColName_y)), ~oldColName_y) return(df_return) } @@ -707,7 +707,7 @@ fun_slrModel2Height <- function( ### Value types and priority valTypes <- c("numeric", "character", "factor") valType0 <- valType - valType0 <- valTypes %>% (function(y, types_y=valTypes){ + valType0 <- valTypes |> (function(y, types_y=valTypes){ ls1 <- ls0 <- types_y c0 <- ls0[1] %in% y c1 <- ls0[2] %in% y @@ -716,14 +716,14 @@ fun_slrModel2Height <- function( else if(c1) {ls1 <- ls0[2]} else {ls1 <- ls0[3]} return(ls1) - }) + })() do_numb <- "numeric" %in% valType do_char <- "character" %in% valType do_fact <- "factor" %in% valType - # valType %>% print; labelType %>% print + # valType |> print(); labelType |> print() ### Label types and priority labTypes <- c("numeric", "character") - label_x0 <- labelType %>% + label_x0 <- labelType |> (function(y, types_y=labTypes){ ls1 <- ls0 <- types_y c0 <- do_numb | do_char @@ -732,19 +732,19 @@ fun_slrModel2Height <- function( else if(c1) {ls1 <- ls0[1]} else {ls1 <- ls0[2]} return(ls1) - }) - # label_x0 %>% print + })() + # label_x0 |> print() labChar <- "character" %in% label_x0 - # label_x0 %>% print; labChar %>% print + # label_x0 |> print(); labChar |> print() ### Original labels - lvl_x0 <- col_x %>% unique + lvl_x0 <- col_x |> unique() df_x0 <- data.frame(levels=lvl_x0) ### Standardize df_x0$labels <- gsub("_" , "", df_x0$levels) df_x0$numbers <- gsub("cm", "", df_x0$labels) - df_x0$values <- df_x0$numbers %>% as.character %>% as.numeric + df_x0$values <- df_x0$numbers |> as.character() |> as.numeric() ### Sprt - df_x0 <- df_x0 %>% arrange_at(.vars=c("values")) + df_x0 <- df_x0 |> arrange_at(.vars=c("values")) ### Create factor list list_x <- list(factors=df_x0) ### Adjust values @@ -752,9 +752,9 @@ fun_slrModel2Height <- function( if(do_values){ if(labChar){labels_x <- df_x0$labels} else {labels_x <- df_x0$values} - vals_x <- col_x %>% factor(levels=df_x0$levels, labels=labels_x) - if(do_char){vals_x <- vals_x %>% as.character} - if(do_numb){vals_x <- vals_x %>% as.numeric } + vals_x <- col_x |> factor(levels=df_x0$levels, labels=labels_x) + if(do_char){vals_x <- vals_x |> as.character()} + if(do_numb){vals_x <- vals_x |> as.numeric()} list_x[["values"]] <- vals_x } ### Return list @@ -783,9 +783,9 @@ fun_slrConfigExtremes <- function( arrange0 <- c(cDriver0, cSlr0) arrange1 <- c(cImpact0, cSlr0) ### Other cols slr_x - slrCols0 <- slr_x %>% names %>% (function(x){x[!(x %in% c(arrange0, modCols0, cYear0))]}) %>% c(cYear0) - impCols0 <- imp_x %>% names %>% (function(x){x[!(x %in% c(arrange1, modCols0, cYear0))]}) %>% c(cYear0) - # slrCols0 %>% print; impCols0 %>% print + slrCols0 <- slr_x |> names() |> (function(x){x[!(x %in% c(arrange0, modCols0, cYear0))]})() |> c(cYear0) + impCols0 <- imp_x |> names() |> (function(x){x[!(x %in% c(arrange1, modCols0, cYear0))]})() |> c(cYear0) + # slrCols0 |> print(); impCols0 |> print() ### Join Cols join0 <- c(cYear0, cSlr0) # join1 <- c(impCols0) @@ -797,106 +797,106 @@ fun_slrConfigExtremes <- function( suffix0 <- c("1", "2") bounds0 <- c("lower", "upper") drop0 <- - c(cDriver0 %>% paste0(suffix0)) %>% - c(cImpact0 %>% paste0(suffix0)) %>% - c(cSlr0 %>% paste0(suffix0)) %>% + c(cDriver0 |> paste0(suffix0)) |> + c(cImpact0 |> paste0(suffix0)) |> + c(cSlr0 |> paste0(suffix0)) |> c("delta_impacts", "delta_driverValue") ### Prepare data ### SLR Heights: slr_df; SLR Impacts: imp_df - slr_df <- slr_x %>% mutate(model_cm = model_dot %>% fun_slrModel2Height(include="values")) - imp_df <- imp_x %>% mutate(model_cm = model_dot %>% fun_slrModel2Height(include="values")) + slr_df <- slr_x |> mutate(model_cm = model_dot |> fun_slrModel2Height(include="values")) + imp_df <- imp_x |> mutate(model_cm = model_dot |> fun_slrModel2Height(include="values")) rm("slr_x", "imp_x") - # slr_df %>% head %>% glimpse; imp_df %>% head %>% glimpse + # slr_df |> head() |> glimpse(); imp_df |> head() |> glimpse() ### Get upper and lower for each year - slrYears <- slr_df$year %>% unique %>% sort - slr_extr <- slrYears %>% lapply(function( + slrYears <- slr_df$year |> unique() |> sort() + slr_extr <- slrYears |> lapply(function( year_i, data_x = slr_df, data_y = imp_df ){ ### Filter data - dfx_i <- data_x %>% filter(year==year_i) %>% select(-c(all_of(modCols0))) - dfy_i <- data_y %>% filter(year==year_i) %>% select(-c(all_of(modCols0))) - # if(year_i %in% slrYears[1]){"got here1" %>% print; dfx_i %>% head %>% glimpse} + dfx_i <- data_x |> filter(year==year_i) |> select(-c(all_of(modCols0))) + dfy_i <- data_y |> filter(year==year_i) |> select(-c(all_of(modCols0))) + # if(year_i %in% slrYears[1]){"got here1" |> print(); dfx_i |> head() |> glimpse()} ### Driver values: ### - Get driver values and then unique driver values ### - Figure out which the last values belong to - vals_i <- dfx_i$driverValue %>% unique %>% sort(decreasing=TRUE) + vals_i <- dfx_i$driverValue |> unique() |> sort(decreasing=TRUE) ### Add value addVal_i <- length(vals_i) == 1 - if(addVal_i){vals_i <- vals_i %>% rep(2)} + if(addVal_i){vals_i <- vals_i |> rep(2)} ref_i <- data.frame( year = year_i, driverValue = vals_i[1:2], valueType = bounds0[2:1] ) - # if(year_i %in% slrYears[1]){"got here2" %>% print; ref_i %>% head %>% glimpse} + # if(year_i %in% slrYears[1]){"got here2" |> print(); ref_i |> head() |> glimpse()} ### Filter dfx_i to driver values %in% first_i and add an order - dfx_i <- dfx_i %>% left_join(ref_i, by=c(all_of(cYear0), all_of(cDriver0))) - dfx_i <- dfx_i %>% filter(!is.na(valueType)) - # if(year_i %in% slrYears[1]){"got here2" %>% print; dfx_i %>% head %>% glimpse} + dfx_i <- dfx_i |> left_join(ref_i, by=c(all_of(cYear0), all_of(cDriver0))) + dfx_i <- dfx_i |> filter(!is.na(valueType)) + # if(year_i %in% slrYears[1]){"got here2" |> print(); dfx_i |> head() |> glimpse()} # rm("vals_i", "ref_i") ### Join impacts with ref_i - # if(year_i %in% slrYears[1]){dfy_i %>% filter(is.na(sector)) %>% nrow %>% print} + # if(year_i %in% slrYears[1]){dfy_i |> filter(is.na(sector)) |> nrow() |> print()} ### Join with driver values - dfy_i <- dfy_i %>% left_join(dfx_i, by = c(all_of(join0))) - dfy_i <- dfy_i %>% filter(!is.na(valueType)) - # if(year_i %in% slrYears[1]){"got here3" %>% print; dfy_i %>% head %>% glimpse} + dfy_i <- dfy_i |> left_join(dfx_i, by = c(all_of(join0))) + dfy_i <- dfy_i |> filter(!is.na(valueType)) + # if(year_i %in% slrYears[1]){"got here3" |> print(); dfy_i |> head() |> glimpse()} ### Get maximum impacts - df_i <- dfy_i %>% - group_by_at(.vars=c(all_of(group0))) %>% - summarize_at(.vars=c(all_of(cImpact0)), max, na.rm=T) %>% ungroup + df_i <- dfy_i |> + group_by_at(.vars=c(all_of(group0))) |> + summarize_at(.vars=c(all_of(cImpact0)), max, na.rm=T) |> ungroup() ### Filter to maximum impacts and get associated model - df_i <- df_i %>% left_join(dfy_i, by = c(all_of(group1))) - df_i <- df_i %>% - group_by_at(.vars=c(all_of(group1))) %>% - summarize_at(.vars=c(all_of(cSlr0)), max, na.rm=T) %>% ungroup - # if(year_i %in% slrYears[1]){"got here4" %>% print; df_i %>% head %>% glimpse} + df_i <- df_i |> left_join(dfy_i, by = c(all_of(group1))) + df_i <- df_i |> + group_by_at(.vars=c(all_of(group1))) |> + summarize_at(.vars=c(all_of(cSlr0)), max, na.rm=T) |> ungroup() + # if(year_i %in% slrYears[1]){"got here4" |> print(); df_i |> head() |> glimpse()} return(df_i) - }) %>% (function(df_i){do.call(rbind, df_i)}) + }) |> (function(df_i){do.call(rbind, df_i)})() ### Select and arrange - # slr_extr %>% names %>% print - slr_extr <- slr_extr %>% select(c(all_of(group1), all_of(cSlr0))) - slr_extr <- slr_extr %>% arrange_at(.vars=c(all_of(group1))) + # slr_extr |> names() |> print() + slr_extr <- slr_extr |> select(c(all_of(group1), all_of(cSlr0))) + slr_extr <- slr_extr |> arrange_at(.vars=c(all_of(group1))) ### Spread lower and upper values and join them together - slr_extr <- slr_extr %>% (function(data_x){ + slr_extr <- slr_extr |> (function(data_x){ ### Separate into lower and upper values and join data - data_lo <- data_x %>% filter(valueType=="lower") %>% select(-c(all_of(cOrder0))) - data_up <- data_x %>% filter(valueType!="lower") %>% select(-c(all_of(cOrder0))) + data_lo <- data_x |> filter(valueType=="lower") |> select(-c(all_of(cOrder0))) + data_up <- data_x |> filter(valueType!="lower") |> select(-c(all_of(cOrder0))) ### Rename columns - data_lo <- data_lo %>% rename_at(.vars=c(all_of(rename0)), ~paste0(rename0, "1")) - data_up <- data_up %>% rename_at(.vars=c(all_of(rename0)), ~paste0(rename0, "2")) - data_x <- data_up %>% left_join(data_lo, by = c(all_of(impCols0))) - # data_x %>% names %>% print + data_lo <- data_lo |> rename_at(.vars=c(all_of(rename0)), ~paste0(rename0, "1")) + data_up <- data_up |> rename_at(.vars=c(all_of(rename0)), ~paste0(rename0, "2")) + data_x <- data_up |> left_join(data_lo, by = c(all_of(impCols0))) + # data_x |> names() |> print() ### Calculate differences - data_x <- data_x %>% mutate(delta_impacts = scaled_impacts2 - scaled_impacts1) - data_x <- data_x %>% mutate(delta_driverValue = driverValue2 - driverValue1) + data_x <- data_x |> mutate(delta_impacts = scaled_impacts2 - scaled_impacts1) + data_x <- data_x |> mutate(delta_driverValue = driverValue2 - driverValue1) ### Calculate absolute values - data_x <- data_x %>% mutate(delta_impacts = delta_impacts %>% abs) - data_x <- data_x %>% mutate(delta_driverValue = delta_driverValue %>% abs) + data_x <- data_x |> mutate(delta_impacts = delta_impacts |> abs()) + data_x <- data_x |> mutate(delta_driverValue = delta_driverValue |> abs()) ### Calculate slope and intercept - data_x <- data_x %>% mutate(driverValue_ref = ifelse(driverValue2 > driverValue1 , driverValue2 , driverValue1)) - data_x <- data_x %>% mutate(impacts_intercept = ifelse(scaled_impacts2 > scaled_impacts1, scaled_impacts2, scaled_impacts1)) - data_x <- data_x %>% mutate(impacts_slope = delta_impacts/delta_driverValue) + data_x <- data_x |> mutate(driverValue_ref = ifelse(driverValue2 > driverValue1 , driverValue2 , driverValue1)) + data_x <- data_x |> mutate(impacts_intercept = ifelse(scaled_impacts2 > scaled_impacts1, scaled_impacts2, scaled_impacts1)) + data_x <- data_x |> mutate(impacts_slope = delta_impacts/delta_driverValue) # ### Check values - # data_x %>% filter(driverValue2 < driverValue1 ) %>% nrow %>% print ### 0 - # data_x %>% filter(scaled_impacts2 < scaled_impacts1) %>% nrow %>% print ### 467 - # data_x %>% filter(impacts_slope < 0) %>% nrow %>% print ### 467 - # data_x %>% filter(impacts_slope < 0 & impacts_intercept < 0) %>% nrow %>% print + # data_x |> filter(driverValue2 < driverValue1 ) |> nrow() |> print() ### 0 + # data_x |> filter(scaled_impacts2 < scaled_impacts1) |> nrow() |> print() ### 467 + # data_x |> filter(impacts_slope < 0) |> nrow() |> print() ### 467 + # data_x |> filter(impacts_slope < 0 & impacts_intercept < 0) |> nrow() |> print() ### Replace zeros - which0 <- (data_x$delta_driverValue == 0) %>% which + which0 <- (data_x$delta_driverValue == 0) |> which() data_x$impacts_slope[which0] <- 0 - # data_x %>% names %>% print + # data_x |> names() |> print() ### Drop intermediate columns and return - data_x <- data_x %>% select(-c(all_of(drop0))) + data_x <- data_x |> select(-c(all_of(drop0))) return(data_x) - }) - # # ext_slr %>% glimpse %>% print; + })() + # # ext_slr |> glimpse() |> print(); # ### Format and Return - # # slr_extr %>% names %>% print - # slr_extr <- slr_extr %>% arrange_at(.vars=c(all_of(impCols0))) + # # slr_extr |> names() |> print() + # slr_extr <- slr_extr |> arrange_at(.vars=c(all_of(impCols0))) # slr_extr[,c(modCols0, cSlr0)] <- "Interpolation" return(slr_extr) } @@ -910,18 +910,18 @@ extend_slr <- function( arrange_x = c("model", "year") ){ ### Values - maxYear_x <- x$year %>% max + maxYear_x <- x$year |> max() ### Format Dataframes - x_nu <- data.frame(year = (maxYear_x + 1):newMax_x) %>% mutate(dummyCol = 1) - x_up <- x %>% filter(year == maxYear_x) %>% mutate(dummyCol = 1) %>% select(-c("year")) - x_lo <- x %>% filter(year <= maxYear_x) + x_nu <- data.frame(year = (maxYear_x + 1):newMax_x) |> mutate(dummyCol = 1) + x_up <- x |> filter(year == maxYear_x) |> mutate(dummyCol = 1) |> select(-c("year")) + x_lo <- x |> filter(year <= maxYear_x) rm("x") ### Join data - x_up <- x_up %>% left_join(x_nu, by = c("dummyCol")) %>% select(-c("dummyCol")) - x <- x_lo %>% rbind(x_up) + x_up <- x_up |> left_join(x_nu, by = c("dummyCol")) |> select(-c("dummyCol")) + x <- x_lo |> rbind(x_up) rm("x_nu", "x_up", "x_lo") ### Arrange and standardize model type - x <- x %>% arrange_at(.vars = c(all_of(arrange_x))) %>% mutate(model_type = "slr") + x <- x |> arrange_at(.vars = c(all_of(arrange_x))) |> mutate(model_type = "slr") return(x) } @@ -935,63 +935,63 @@ fun_getNeighbors <- function( # ### Mutate data ### Add a dummy column with a standardized name - values <- values %>% as.data.frame + values <- values |> as.data.frame() values$newCol <- values[,col] ### Look for equal values - values_equal <- values %>% filter(newCol==x) - num_equal <- values_equal %>% nrow + values_equal <- values |> filter(newCol==x) + num_equal <- values_equal |> nrow() ### If there are equal values, get the upper and lower value if(num_equal>0){ ### If there is only one value that is equal, return that value twice if(num_equal==1){ - lo_order <- values_equal$order %>% unique + lo_order <- values_equal$order |> unique() hi_order <- lo_order } ### If there is more than one value that is equal, return the lower most and uppermost equal values else{ c_orders <- values_equal$order - lo_order <- values_equal$order %>% min(na.rm=T) - hi_order <- values_equal$order %>% max(na.rm=T) + lo_order <- values_equal$order |> min(na.rm=T) + hi_order <- values_equal$order |> max(na.rm=T) } } ### If there are no equal values, figure if there are any values below the value else{ - values_below <- values %>% filter(newCol < x) - num_below <- values_below %>% nrow + values_below <- values |> filter(newCol < x) + num_below <- values_below |> nrow() ### Get the values above it - values_above <- values %>% filter(newCol > x) - num_above <- values_above %>% nrow + values_above <- values |> filter(newCol > x) + num_above <- values_above |> nrow() ### If there are values below, get the values above it if(num_below==0){ ### Return the zero value for the low value and the first value above for the hi value lo_order <- 1 - hi_order <- values_above$order %>% min(na.rm=T) + hi_order <- values_above$order |> min(na.rm=T) } else{ ### Figure out if there are any values above it if(num_above==0){ ### Return the max value for the low value and the hi value - lo_order <- values_below$order %>% max(na.rm=T) + lo_order <- values_below$order |> max(na.rm=T) hi_order <- lo_order } ### If there are some numbers above and below it else{ ### Return the max value for the low value and the hi value - lo_order <- values_below$order %>% max(na.rm=T) - hi_order <- values_above$order %>% min(na.rm=T) + lo_order <- values_below$order |> max(na.rm=T) + hi_order <- values_above$order |> min(na.rm=T) } } } - # lo_order %>% print - lo_values <- values %>% filter(order==lo_order) %>% mutate(type="lower") - hi_values <- values %>% filter(order==hi_order) %>% mutate(type="upper") - new_values <- lo_values %>% rbind(hi_values) + # lo_order |> print() + lo_values <- values |> filter(order==lo_order) |> mutate(type="lower") + hi_values <- values |> filter(order==hi_order) |> mutate(type="upper") + new_values <- lo_values |> rbind(hi_values) - new_values <- lo_values %>% rbind(hi_values) + new_values <- lo_values |> rbind(hi_values) return(new_values) } @@ -1002,34 +1002,34 @@ fun_formatScalars <- function( info_x, ### rDataList$co_scalarInfo years_x ### rDataList$list_years ){ - names_x <- data_x$scalarName %>% unique - num_x <- names_x %>% length - new_x <- 1:num_x %>% lapply(function(i){ + names_x <- data_x$scalarName |> unique() + num_x <- names_x |> length() + new_x <- 1:num_x |> lapply(function(i){ ### Figure out name, method, region name_i <- names_x[i] - # name_i %>% print + # name_i |> print() ### Dataframes - scalar_i <- data_x %>% filter(scalarName==name_i) - info_i <- info_x %>% filter(scalarName==name_i) + scalar_i <- data_x |> filter(scalarName==name_i) + info_i <- info_x |> filter(scalarName==name_i) ### Info about scalar method_i <- info_i$constant_or_dynamic[1] method_i <- ifelse(method_i=="constant", method_i, "linear") # region_i <- info_i$national_or_regional[1] ### Interpolate data - scalar_i <- scalar_i %>% interpolate_annual( + scalar_i <- scalar_i |> interpolate_annual( years = years_x, column = "value", rule = 1:2, method = method_i) ### Add in name and return - scalar_i <- scalar_i %>% mutate(scalarName=name_i) + scalar_i <- scalar_i |> mutate(scalarName=name_i) return(scalar_i) - }) %>% (function(scalars_i){do.call(rbind, scalars_i)}) + }) |> (function(scalars_i){do.call(rbind, scalars_i)})() ### Join info select0 <- c("scalarName", "scalarType", "national_or_regional") select1 <- c("scalarName", "region", "year", "value") - info_x <- info_x %>% select(c(all_of(select0))) - new_x <- new_x %>% select(c(all_of(select1))) - new_x <- new_x %>% left_join(info_x, by=c("scalarName")) + info_x <- info_x |> select(c(all_of(select0))) + new_x <- new_x |> select(c(all_of(select1))) + new_x <- new_x |> left_join(info_x, by=c("scalarName")) ### Return return(new_x) } @@ -1053,9 +1053,9 @@ fun_getScale <- if(is.null(nTicks)){nTicks <- 5} ### Min/max values - data <- data %>% as.data.frame - xMin <- data[,scaleCol] %>% min(na.rm=T) - xMax <- data[,scaleCol] %>% max(na.rm=T) + data <- data |> as.data.frame() + xMin <- data[,scaleCol] |> min(na.rm=T) + xMax <- data[,scaleCol] |> max(na.rm=T) ### Set minimum to zero unless the minimum is less than zero if(xMin > 0){ @@ -1074,20 +1074,20 @@ fun_getScale <- value = c(xMin, xMax), bound = c(floor(xMin), ceiling(xMax)), boundType = c("floor", "ceiling") - ) %>% + ) |> ### Absolute value, Power of 10 and y-scale info - mutate(bound_abs = bound %>% abs) %>% + mutate(bound_abs = bound |> abs()) |> ### Calculate log 10 and replace values of infinity with 0 - mutate(log10 = (bound_abs %>% log10)) %>% - mutate(log10 = log10 %>% abs %>% na_if(Inf)) %>% - mutate(log10 = log10 %>% replace_na(0)) %>% + mutate(log10 = (bound_abs |> log10())) |> + mutate(log10 = log10 |> abs() |> na_if(Inf)) |> + mutate(log10 = log10 |> replace_na(0)) |> ### Then get the floor of the log10 value - mutate(power10 = log10 %>% floor) + mutate(power10 = log10 |> floor()) ### Get maximum power of 10, then scale to zero for negative numbers ### Integer division of power of 10 by 3 to get number of thousands ### Then get the modulus of the thousands - x_power10Max <- df_minMax$power10 %>% max(na.rm=T) + x_power10Max <- df_minMax$power10 |> max(na.rm=T) x_power1000 <- x_power10Max %/% 3 x_mod1000 <- x_power10Max %% 3 @@ -1105,15 +1105,15 @@ fun_getScale <- ### Determine unit of breaks in power of 10 x_unit_p10 <- 0.5 x_breaks_p10 <- seq(x_range_p10[1], x_range_p10[2], by = x_unit_p10) - n_Ticks <- x_breaks_p10 %>% length + n_Ticks <- x_breaks_p10 |> length() if(n_Ticks>nTicks){ x_unit_p10 <- 1 x_breaks_p10 <- seq(x_range_p10[1], x_range_p10[2], by = x_unit_p10) - n_Ticks <- x_breaks_p10 %>% length + n_Ticks <- x_breaks_p10 |> length() if(n_Ticks>nTicks){ x_unit_p10 <- 2 x_breaks_p10 <- seq(x_range_p10[1], x_range_p10[2], by = x_unit_p10) - n_Ticks <- x_breaks_p10 %>% length + n_Ticks <- x_breaks_p10 |> length() } } x_breaks <- x_breaks_p10 * 10^x_power10Max @@ -1137,17 +1137,17 @@ fredi_slrInterp <- function( data_x, slr_x, ### slrScenario groupByCols - # drivers_x ### driverScenario %>% filter(tolower(model_type)=="slr") %>% select(-c("model_type")) - # drivers_x, ### driverScenario %>% filter(tolower(model_type)=="slr") %>% select(-c("model_type")) + # drivers_x ### driverScenario |> filter(tolower(model_type)=="slr") |> select(-c("model_type")) + # drivers_x, ### driverScenario |> filter(tolower(model_type)=="slr") |> select(-c("model_type")) ){ #data_x <-df_slrImpacts #slr_x = slrScenario #groupByCols=slrGroupByCols - names_slr <- data_x %>% names; #names_slr %>% print + names_slr <- data_x |> names(); #names_slr |> print() ### Summary columns slrSumCols <- c("scaled_impacts") - n_slrSumCols <- slrSumCols %>% length + n_slrSumCols <- slrSumCols |> length() bounds0 <- c("lower", "upper") mutate0 <- c("model", "slr") slrMutCols <- c("lower_model", "upper_model") @@ -1155,119 +1155,119 @@ fredi_slrInterp <- function( ### Info names ### "year", "driverValue", "lower_model" , "upper_model", "lower_slr" , "upper_slr" data_xAdj <- slr_x; rm("slr_x") - names_slrAdj <- data_xAdj %>% names; #names_slrAdj %>% print + names_slrAdj <- data_xAdj |> names(); #names_slrAdj |> print() other_slrCols <- names_slrAdj[which(names_slrAdj!="year")] join_slrCols <- c(groupByCols, "year") ### sectorprimary, includeaggregate join_cols0 <- c("driverValue", "year") ### Other columns dropCols0 <- c("model", "model_dot") otherCols0 <- c("modelType", "denom_slr", "numer_slr", "adj_slr") - joinCols1 <- join_slrCols[!(join_slrCols %in% dropCols0)] %>% - c(bounds0 %>% paste("model", sep="_")) %>% - c(bounds0 %>% paste("slr", sep="_")) %>% + joinCols1 <- join_slrCols[!(join_slrCols %in% dropCols0)] |> + c(bounds0 |> paste("model", sep="_")) |> + c(bounds0 |> paste("slr", sep="_")) |> c(otherCols0) ### Format values - data_xAdj <- data_xAdj %>% mutate_at(.vars=c(all_of(slrMutCols)), as.character) + data_xAdj <- data_xAdj |> mutate_at(.vars=c(all_of(slrMutCols)), as.character) ### Join with slrInfo and convert columns to character - data_xAdj <- data_xAdj %>% mutate(equal_models = lower_model == upper_model) - data_x <- data_x %>% left_join(data_xAdj, by=all_of(join_cols0)) - # data_x %>% filter(!is.na(scaled_impacts)) %>% nrow %>% print + data_xAdj <- data_xAdj |> mutate(equal_models = lower_model == upper_model) + data_x <- data_x |> left_join(data_xAdj, by=all_of(join_cols0)) + # data_x |> filter(!is.na(scaled_impacts)) |> nrow() |> print() rm("data_xAdj") ### Filter to conditions - data_xEqual <- data_x %>% filter( equal_models) %>% select(-c("equal_models")); - data_xOther <- data_x %>% filter(!equal_models) %>% select(-c("equal_models")); - # data_x %>% names %>% print - # data_x$model %>% unique %>% print - # data_x$model_dot %>% unique %>% print - # data_x$lower_model %>% unique %>% print - # data_x$upper_model %>% unique %>% print - # c(nrow(data_xEqual), nrow(data_xOther)) %>% print + data_xEqual <- data_x |> filter( equal_models) |> select(-c("equal_models")); + data_xOther <- data_x |> filter(!equal_models) |> select(-c("equal_models")); + # data_x |> names() |> print() + # data_x$model |> unique() |> print() + # data_x$model_dot |> unique() |> print() + # data_x$lower_model |> unique() |> print() + # data_x$upper_model |> unique() |> print() + # c(nrow(data_xEqual), nrow(data_xOther)) |> print() rm("data_x") ### Process observations that are equal if(nrow(data_xEqual)){ ### Filter observations that are zeros only and make the summary column values zero - data_xEqual0 <- data_xEqual %>% filter(lower_model=="0cm") %>% filter(model_dot=="30cm") - data_xEqual1 <- data_xEqual %>% filter(lower_model!="0cm") %>% filter(model_dot==lower_model) - # c(nrow(data_xEqual0), nrow(data_xEqual1)) %>% print + data_xEqual0 <- data_xEqual |> filter(lower_model=="0cm") |> filter(model_dot=="30cm") + data_xEqual1 <- data_xEqual |> filter(lower_model!="0cm") |> filter(model_dot==lower_model) + # c(nrow(data_xEqual0), nrow(data_xEqual1)) |> print() rm("data_xEqual") ### For observations that are zeros only and make the summary column values zero - data_xEqual0 <- data_xEqual0 %>% mutate_at(.vars=c(all_of(slrSumCols)), function(y){0}) + data_xEqual0 <- data_xEqual0 |> mutate_at(.vars=c(all_of(slrSumCols)), function(y){0}) ### Bind values back together - data_xEqual <- data_xEqual0 %>% rbind(data_xEqual1) + data_xEqual <- data_xEqual0 |> rbind(data_xEqual1) rm("data_xEqual0", "data_xEqual1") ### Rename the model_dot, select appropriate columns - data_xEqual <- data_xEqual %>% mutate(model_dot="Interpolation") - # data_xEqual %>% names%>% print - data_xEqual <- data_xEqual %>% select(c(all_of(names_slr))) %>% select(-c(all_of(dropCols0))) + data_xEqual <- data_xEqual |> mutate(model_dot="Interpolation") + # data_xEqual |> names|> print() + data_xEqual <- data_xEqual |> select(c(all_of(names_slr))) |> select(-c(all_of(dropCols0))) } ### End if length(which_equal) > 0 ### Observations that are greater than zero if(nrow(data_xOther)){ ### Lower and upper column names and new names - # slrSumCols %>% print - lowerSumCols <- slrSumCols %>% paste("lower", sep="_") - upperSumCols <- slrSumCols %>% paste("upper", sep="_") + # slrSumCols |> print() + lowerSumCols <- slrSumCols |> paste("lower", sep="_") + upperSumCols <- slrSumCols |> paste("upper", sep="_") ### Filter lower model_dot observations to those with a lower model_dot value == "0 cm" and others and drop model_dot column - data_xLower0 <- data_xOther %>% filter(lower_model=="0cm") #%>% mutate(lower_model = "30cm") - data_xLower1 <- data_xOther %>% filter(lower_model!="0cm") - # data_xLower <- data_xLower0 %>% rbind(data_xLower1) %>% + data_xLower0 <- data_xOther |> filter(lower_model=="0cm") #|> mutate(lower_model = "30cm") + data_xLower1 <- data_xOther |> filter(lower_model!="0cm") + # data_xLower <- data_xLower0 |> rbind(data_xLower1) |> # rm("data_xLower0", "data_xLower1") - data_xUpper <- data_xOther %>% filter(model_dot==upper_model) + data_xUpper <- data_xOther |> filter(model_dot==upper_model) rm("data_xOther") ### Rename columns - data_xLower0 <- data_xLower0 %>% rename_with(~lowerSumCols[which(slrSumCols==.x)], .cols=slrSumCols) - data_xLower1 <- data_xLower1 %>% rename_with(~lowerSumCols[which(slrSumCols==.x)], .cols=slrSumCols) - data_xUpper <- data_xUpper %>% rename_with(~upperSumCols[which(slrSumCols==.x)], .cols=slrSumCols) + data_xLower0 <- data_xLower0 |> rename_with(~lowerSumCols[which(slrSumCols==.x)], .cols=slrSumCols) + data_xLower1 <- data_xLower1 |> rename_with(~lowerSumCols[which(slrSumCols==.x)], .cols=slrSumCols) + data_xUpper <- data_xUpper |> rename_with(~upperSumCols[which(slrSumCols==.x)], .cols=slrSumCols) # rm("lowerSumCols", "upperSumCols") ### Convert values for observations with a lower model_dot value =="0 cm" to zero then filter to lower models - data_xLower0 <- data_xLower0 %>% mutate_at(.vars=c(all_of(lowerSumCols)), function(y){0}) - data_xLower0 <- data_xLower0 %>% filter(model_dot=="30 cm") - data_xLower1 <- data_xLower1 %>% filter(model_dot==lower_model) - data_xLower <- data_xLower0 %>% rbind(data_xLower1) + data_xLower0 <- data_xLower0 |> mutate_at(.vars=c(all_of(lowerSumCols)), function(y){0}) + data_xLower0 <- data_xLower0 |> filter(model_dot=="30 cm") + data_xLower1 <- data_xLower1 |> filter(model_dot==lower_model) + data_xLower <- data_xLower0 |> rbind(data_xLower1) rm("data_xLower0", "data_xLower1") ### Drop columns - # namesLower <- data_xLower %>% names; namesUpper <- data_xUpper %>% names - # namesLower %>% print; namesUpper %>% print - # dropCols0[!(dropCols0 %in% namesLower)] %>% print; dropCols0[!(dropCols0 %in% namesUpper)] %>% print + # namesLower <- data_xLower |> names(); namesUpper <- data_xUpper |> names() + # namesLower |> print(); namesUpper |> print() + # dropCols0[!(dropCols0 %in% namesLower)] |> print(); dropCols0[!(dropCols0 %in% namesUpper)] |> print() - data_xLower <- data_xLower %>% select(-c(all_of(dropCols0))) - data_xUpper <- data_xUpper %>% select(-c(all_of(dropCols0))) + data_xLower <- data_xLower |> select(-c(all_of(dropCols0))) + data_xUpper <- data_xUpper |> select(-c(all_of(dropCols0))) ### Join upper and lower data frames - # data_xLower %>% names %>% print; data_xUpper %>% names %>% print - # joinCols0 %>% print - # namesLower[!(namesLower %in% namesUpper)] %>% print; namesUpper[!(namesUpper %in% namesLower)] %>% print - data_xOther <- data_xLower %>% left_join(data_xUpper, by = c(all_of(joinCols1))) + # data_xLower |> names() |> print(); data_xUpper |> names() |> print() + # joinCols0 |> print() + # namesLower[!(namesLower %in% namesUpper)] |> print(); namesUpper[!(namesUpper %in% namesLower)] |> print() + data_xOther <- data_xLower |> left_join(data_xUpper, by = c(all_of(joinCols1))) rm("data_xLower", "data_xUpper") ### Calculate the new value - # data_xOther %>% names %>% print + # data_xOther |> names() |> print() slrLowerVals <- data_xOther[, lowerSumCols] slrUpperVals <- data_xOther[, upperSumCols] - # slrOtherAdj <- data_xOther[, "adj_slr"] %>% as.vector - slrOtherAdj <- data_xOther %>% get_vector(column = "adj_slr") + # slrOtherAdj <- data_xOther[, "adj_slr"] |> as.vector() + slrOtherAdj <- data_xOther |> get_vector(column = "adj_slr") slrNewFactors <- (slrUpperVals - slrLowerVals) * (1 - slrOtherAdj) slrNewValues <- slrLowerVals + slrNewFactors data_xOther[,slrSumCols] <- slrNewValues rm("slrLowerVals", "slrUpperVals", "slrOtherAdj", "slrNewFactors", "slrNewValues") rm("lowerSumCols", "upperSumCols") ### When finished, drop columns and mutate model_dot column - # data_xOther %>% names %>% print; names_slr %>% print + # data_xOther |> names() |> print(); names_slr |> print() names_slr0 <- names_slr[!(names_slr %in% dropCols0)] - # data_xOther <- data_xOther %>% mutate(model_dot="Interpolation") - data_xOther <- data_xOther %>% select(c(all_of(names_slr0))) + # data_xOther <- data_xOther |> mutate(model_dot="Interpolation") + data_xOther <- data_xOther |> select(c(all_of(names_slr0))) } ### End if (nrow(data_xOther) > 0) ### Bind SLR averages together - # c(nrow(data_xEqual), nrow(data_xOther)) %>% print - # data_xEqual %>% names %>% print; data_xOther %>% names %>% print - data_x <- data_xEqual %>% rbind(data_xOther) - # data_x %>% nrow %>% print + # c(nrow(data_xEqual), nrow(data_xOther)) |> print() + # data_xEqual |> names() |> print(); data_xOther |> names() |> print() + data_x <- data_xEqual |> rbind(data_xOther) + # data_x |> nrow() |> print() rm("data_xEqual", "data_xOther") return(data_x) diff --git a/FrEDI/R/utils_import_inputs.R b/FrEDI/R/utils_import_inputs.R index f602e4c2..b764d245 100644 --- a/FrEDI/R/utils_import_inputs.R +++ b/FrEDI/R/utils_import_inputs.R @@ -9,9 +9,9 @@ fun_tryInput <- function( ###### Messaging ###### msgUser <- ifelse(silent, FALSE, TRUE) msg0 <- ifelse(is.null(msg0), "", msg0) - msg1 <- msg0 %>% paste0("\t") - msg2 <- msg1 %>% paste0("\t") - msg3 <- msg2 %>% paste0("\t") + msg1 <- msg0 |> paste0("\t") + msg2 <- msg1 |> paste0("\t") + msg3 <- msg2 |> paste0("\t") ###### Initialize results ###### return_list <- list() @@ -20,11 +20,11 @@ fun_tryInput <- function( ### Check if the file exists and try to load the file ### Set input to null if it doesn't exist if(!is.null(filename)){ - fileExists <- filename %>% file.exists + fileExists <- filename |> file.exists() ### If the file exists, try loading the file and then check the class of the result if(fileExists){ - fileInput <- try(filename %>% read.csv, silent=T) - classInput <- fileInput %>% class + fileInput <- try(filename |> read.csv(), silent=T) + classInput <- fileInput |> class() inputExists <- ("data.frame" %in% classInput) ### If loading the inputs was successful @@ -45,7 +45,7 @@ fun_tryInput <- function( ### Message the user # message("\t", return_list[["fileMsg"]]) - if(msgUser){ msg0 %>% paste0(return_list[["fileMsg"]]) %>% message } + if(msgUser){ msg0 |> paste0(return_list[["fileMsg"]]) |> message() } } ###### Return ###### @@ -60,9 +60,9 @@ rename_inputs <- function( new_names ){ ### Get the length of the new names - data_names <- data %>% names - num_names <- new_names %>% length - num_dataCols <- data %>% ncol + data_names <- data |> names() + num_names <- new_names |> length() + num_dataCols <- data |> ncol() if(num_dataCols>num_names){ data <- data[,1:num_names] diff --git a/FrEDI/R/utils_sv.R b/FrEDI/R/utils_sv.R index 98804114..900d413d 100644 --- a/FrEDI/R/utils_sv.R +++ b/FrEDI/R/utils_sv.R @@ -70,30 +70,30 @@ get_sv_sectorInfo <- function( ### - Format modelType as uppercase ### - Add variant label ### - Add driver value - sectorInfo <- sectorInfo %>% select(c(all_of(select0))) - sectorInfo <- sectorInfo %>% mutate(modelType = modelType %>% toupper) - sectorInfo <- sectorInfo %>% mutate( - variants = sector %>% lapply(function(sector_i){ - variants_i <- (svSectorInfo %>% filter(sector==sector_i))$variant_label %>% paste(collapse=", ") + sectorInfo <- sectorInfo |> select(c(all_of(select0))) + sectorInfo <- sectorInfo |> mutate(modelType = modelType |> toupper()) + sectorInfo <- sectorInfo |> mutate( + variants = sector |> lapply(function(sector_i){ + variants_i <- (svSectorInfo |> filter(sector==sector_i))$variant_label |> paste(collapse=", ") return(variants_i) - }) %>% unlist) - sectorInfo <- sectorInfo %>% mutate(driverUnit=ifelse(modelType=="GCM", "degrees Celsius", "cm")) + }) |> unlist()) + sectorInfo <- sectorInfo |> mutate(driverUnit=ifelse(modelType=="GCM", "degrees Celsius", "cm")) ### Select and arrange - sectorInfo <- sectorInfo %>% select(c(all_of(select1))) - sectorInfo <- sectorInfo %>% arrange_at(.vars=c("sector")) + sectorInfo <- sectorInfo |> select(c(all_of(select1))) + sectorInfo <- sectorInfo |> arrange_at(.vars=c("sector")) ### GCM or SLR doFilter <- (gcmOnly | slrOnly) if(doFilter){ cFilter <- ifelse(gcmOnly, TRUE, FALSE) gcm_string <- "GCM" - sectorInfo <- sectorInfo %>% mutate(is_gcm = modelType==gcm_string) - sectorInfo <- sectorInfo %>% filter(is_gcm == cFilter) - sectorInfo <- sectorInfo %>% select(-c("is_gcm")) + sectorInfo <- sectorInfo |> mutate(is_gcm = modelType==gcm_string) + sectorInfo <- sectorInfo |> filter(is_gcm == cFilter) + sectorInfo <- sectorInfo |> select(-c("is_gcm")) } ### If not description, return names only if(!description) {return_obj <- sectorInfo$sector} - else {return_obj <- sectorInfo %>% as.data.frame} + else {return_obj <- sectorInfo |> as.data.frame()} ### Return return(return_obj) } @@ -110,49 +110,49 @@ calc_countyPop <- function( years = seq(2010, 2090, by=5) ){ - c_regions <- regPop$region %>% unique + c_regions <- regPop$region |> unique() ### Iterate over regions - x_popProj <- c_regions %>% lapply(function(region_i){ + x_popProj <- c_regions |> lapply(function(region_i){ ### Subset population projection to a specific region ### Get states in the region ### Get unique years - df_i <- regPop %>% filter(region==region_i) - states_i <- funList[[region_i]] %>% names - years_i <- df_i$year %>% unique %>% sort + df_i <- regPop |> filter(region==region_i) + states_i <- funList[[region_i]] |> names() + years_i <- df_i$year |> unique() |> sort() ### Iterate over states - regionPop_i <- states_i %>% lapply(function(state_j){ + regionPop_i <- states_i |> lapply(function(state_j){ ### Function for state j fun_j <- funList[[region_i]][[state_j]]$state2region - # state_j %>% print + # state_j |> print() df_j <- data.frame(x = years_i, y = fun_j(years_i)) - df_j <- df_j %>% rename(year = x, ratioState2RegionPop = y) - df_j <- df_j %>% mutate(state = state_j, region = region_i) + df_j <- df_j |> rename(year = x, ratioState2RegionPop = y) + df_j <- df_j |> mutate(state = state_j, region = region_i) ### Get list of counties in the state - geoids_j <- funList[[region_i]][[state_j]]$county2state %>% names - statePop_j <- geoids_j %>% lapply(function(geoid_k){ + geoids_j <- funList[[region_i]][[state_j]]$county2state |> names() + statePop_j <- geoids_j |> lapply(function(geoid_k){ fun_k <- funList[[region_i]][[state_j]]$county2state[[geoid_k]] if(!is.null(fun_k)) {y_k <- fun_k(years_i)} else {y_k <- NA} df_k <- data.frame(year = years_i, ratioCounty2StatePop = y_k) - df_k <- df_k %>% mutate(state = state_j, geoid10 = geoid_k) + df_k <- df_k |> mutate(state = state_j, geoid10 = geoid_k) return(df_k) - }) %>% (function(z){do.call(rbind, z)}) + }) |> (function(z){do.call(rbind, z)})() ### Join with state population - df_j <- df_j %>% left_join(statePop_j, by = c("state", "year")) + df_j <- df_j |> left_join(statePop_j, by = c("state", "year")) return(df_j) - }) %>% (function(y){do.call(rbind, y)}) + }) |> (function(y){do.call(rbind, y)})() ### Join with regional population - df_i <- df_i %>% left_join(regionPop_i, by = c("region", "year")) - df_i <- df_i %>% mutate(state_pop = region_pop * ratioState2RegionPop) - df_i <- df_i %>% mutate(county_pop = state_pop * ratioCounty2StatePop) + df_i <- df_i |> left_join(regionPop_i, by = c("region", "year")) + df_i <- df_i |> mutate(state_pop = region_pop * ratioState2RegionPop) + df_i <- df_i |> mutate(county_pop = state_pop * ratioCounty2StatePop) ### Return return(df_i) - }) %>% (function(x){do.call(rbind, x)}) + }) |> (function(x){do.call(rbind, x)})() ### Return - x_popProj <- x_popProj %>% as.data.frame + x_popProj <- x_popProj |> as.data.frame() return(x_popProj) } @@ -168,29 +168,29 @@ calc_tractScaledImpacts <- function( ){ ### Messaging msg0 <- .msg0 - msg1 <- msg0 %>% paste("\t") - msg2 <- msg1 %>% paste("\t") - msg3 <- msg2 %>% paste("\t") + msg1 <- msg0 |> paste("\t") + msg2 <- msg1 |> paste("\t") + msg3 <- msg2 |> paste("\t") msgUser <- !silent - msg0 %>% paste0("Calculating scaled impacts for each tract...") %>% message + msg0 |> paste0("Calculating scaled impacts for each tract...") |> message() ### Names of functions - c_tracts <- funList %>% names - years_x <- driverValues$year %>% as.vector - values_x <- driverValues[,xCol] %>% as.vector - funcs_x <- funList %>% names + c_tracts <- funList |> names() + years_x <- driverValues$year |> as.vector() + values_x <- driverValues[,xCol] |> as.vector() + funcs_x <- funList |> names() # # c_tracts <- c_tracts[1:1e3]; funcs_x <- funcs_x[1:1e3] # c_tracts <- c(29031880500); # c_tracts <- seq(c_tracts - 10, c_tracts + 10); - # c_tracts <- c_tracts %>% as.character + # c_tracts <- c_tracts |> as.character() ###### Iterate over Tracts ###### - data_x <- c_tracts %>% lapply(function(tract_i){ + data_x <- c_tracts |> lapply(function(tract_i){ ### Initialize data df_i <- data.frame(year = years_x, fips = tract_i) y_i <- NA ### Function for tract i and whether the function exists - which_i <- (funcs_x %in% c(tract_i)) %>% which + which_i <- (funcs_x %in% c(tract_i)) |> which() fun_i <- funList[[which_i]] has_fun_i <- (!is.null(fun_i)) @@ -198,18 +198,18 @@ calc_tractScaledImpacts <- function( ### Add values to the dataframe if(has_fun_i){y_i <- fun_i(values_x)} ### Add values - df_i <- df_i %>% mutate(sv_impact = y_i) - # fun_i(1.667535543) %>% print; df_i %>% print + df_i <- df_i |> mutate(sv_impact = y_i) + # fun_i(1.667535543) |> print(); df_i |> print() ### Sleep and return # Sys.sleep(sleep) return(df_i) }) ### Bind and join with driver values - data_x <- data_x %>% (function(x){do.call(rbind, x)}) - data_x <- data_x %>% left_join(driverValues, by = c("year")) + data_x <- data_x |> (function(x){do.call(rbind, x)})() + data_x <- data_x |> left_join(driverValues, by = c("year")) ### Final time - msg1 %>% paste0("Finished calculating tract-level impacts.") %>% message + msg1 |> paste0("Finished calculating tract-level impacts.") |> message() return(data_x) } @@ -240,23 +240,23 @@ calc_tractImpacts <- function( .testing = FALSE ){ ###### Constants ###### - # paste0("Calculating total impacts for each tract...") %>% message + # paste0("Calculating total impacts for each tract...") |> message() x_sysTime1 <- Sys.time() - regions <- popData$region %>% unique - tracts <- scaledImpacts$fips %>% unique + regions <- popData$region |> unique() + tracts <- scaledImpacts$fips |> unique() ###### Messages ###### msg0 <- .msg0 - msg1 <- msg0 %>% paste0("\t") - msg2 <- msg1 %>% paste0("\t") - msg3 <- msg2 %>% paste0("\t") + msg1 <- msg0 |> paste0("\t") + msg2 <- msg1 |> paste0("\t") + msg3 <- msg2 |> paste0("\t") msgUser <- !silent ###### Column Names ###### ### Other info c_svDataDropCols <- c("svCounty") - c_svOtherDropCols <- c("state", "county", "geoid10") %>% - c("ratioTract2CountyPop", "ratioState2RegionPop", "ratioCounty2StatePop") %>% + c_svOtherDropCols <- c("state", "county", "geoid10") |> + c("ratioTract2CountyPop", "ratioState2RegionPop", "ratioCounty2StatePop") |> c("region_pop", "state_pop", "county_pop") c_svJoinPopCols <- c("region", "state", "geoid10") c_svJoinImpactsCols <- c("fips", "year") @@ -266,32 +266,32 @@ calc_tractImpacts <- function( else if(sector=="Air Quality - Premature Mortality") {c_svNACols <- c("sv_plus65")} c_svGroupCols <- svGroups[svGroups %in% names(svInfo)] c_svWeightCols <- c("children", "highRiskLabor", "sv_plus65") - c_svWeightCols1<- c_svWeightCols %>% (function(x){x[which(!(x %in% c("sv_plus65")))]}) + c_svWeightCols1<- c_svWeightCols |> (function(x){x[which(!(x %in% c("sv_plus65")))]})() ###### Other Info ###### ### Eventually, import from svDemographics c_sector <- sector - weightsCol <- weightCol #; weightsCol %>% print + weightsCol <- weightCol #; weightsCol |> print() svGroupCols <- svGroups[svGroups %in% names(svInfo)] - # svGroups %>% print; svGroupCols %>% print + # svGroups |> print(); svGroupCols |> print() ###### Format Data ###### - popData <- popData %>% filter(year %in% years) - scaledImpacts <- scaledImpacts %>% filter(year %in% years) %>% filter(!is.na(driverUnit)) + popData <- popData |> filter(year %in% years) + scaledImpacts <- scaledImpacts |> filter(year %in% years) |> filter(!is.na(driverUnit)) ###### Total Impacts ###### - msg0 %>% paste0("Calculating total impacts for each tract...") %>% message + msg0 |> paste0("Calculating total impacts for each tract...") |> message() ### Format svInfo - Add column for none and drop other columns c_dropCols0 <- c("svCounty") - x_impacts <- svInfo %>% mutate(none = 1) %>% select(-c(all_of(c_dropCols0))) + x_impacts <- svInfo |> mutate(none = 1) |> select(-c(all_of(c_dropCols0))) rm("svInfo"); rm("c_dropCols0") ### Join svInfo with population projections by region, state, geoid10 c_joinCols0 <- c("region", "state", "geoid10") - x_impacts <- x_impacts %>% left_join(popData, by = all_of(c_joinCols0)) + x_impacts <- x_impacts |> left_join(popData, by = all_of(c_joinCols0)) rm("popData"); rm("c_joinCols0") ### Join svInfo with the impacts by fips number and drop missing values - x_impacts <- x_impacts %>% left_join(scaledImpacts, by = c("year", "fips")) - x_impacts <- x_impacts %>% filter(!is.na(driverUnit)) + x_impacts <- x_impacts |> left_join(scaledImpacts, by = c("year", "fips")) + x_impacts <- x_impacts |> filter(!is.na(driverUnit)) rm("scaledImpacts") # ### Sleep # Sys.sleep(sleep) @@ -299,20 +299,20 @@ calc_tractImpacts <- function( ###### Population Weight ###### ### Add population weight column - c_weightCols <- c("children", "highRiskLabor") %>% (function(y){y[y %in% names(x_impacts)]}) - x_impacts <- x_impacts %>% mutate(popWeight = x_impacts[[weightsCol]]) - x_impacts <- x_impacts %>% select(-c(all_of(c_weightCols))) - # (x_impacts$popWeight != 0) %>% which %>% length %>% print + c_weightCols <- c("children", "highRiskLabor") |> (function(y){y[y %in% names(x_impacts)]})() + x_impacts <- x_impacts |> mutate(popWeight = x_impacts[[weightsCol]]) + x_impacts <- x_impacts |> select(-c(all_of(c_weightCols))) + # (x_impacts$popWeight != 0) |> which() |> length() |> print() rm("c_weightCols") ###### Tract Population ###### ### Calculate total tract population and drop columns - c_dropCols1 <- c("state", "county", "geoid10") %>% - c("ratioTract2CountyPop", "ratioState2RegionPop", "ratioCounty2StatePop") %>% + c_dropCols1 <- c("state", "county", "geoid10") |> + c("ratioTract2CountyPop", "ratioState2RegionPop", "ratioCounty2StatePop") |> c("region_pop", "state_pop", "county_pop") - x_impacts <- x_impacts %>% mutate(tract_totPop = county_pop * ratioTract2CountyPop) - x_impacts <- x_impacts %>% select(-c(all_of(c_dropCols1))) - # (x_impacts$tract_totPop != 0) %>% which %>% length %>% print + x_impacts <- x_impacts |> mutate(tract_totPop = county_pop * ratioTract2CountyPop) + x_impacts <- x_impacts |> select(-c(all_of(c_dropCols1))) + # (x_impacts$tract_totPop != 0) |> which() |> length() |> print() rm("c_dropCols1") ###### Non-Meaningful Groups ###### @@ -320,68 +320,68 @@ calc_tractImpacts <- function( if (sector=="Air Quality - Childhood Asthma" ) {c_svNACols <- c("sv_noHS", "sv_plus65")} else if(sector=="Air Quality - Premature Mortality") {c_svNACols <- c("sv_plus65")} else {c_svNACols <- c()} - x_impacts <- x_impacts %>% mutate_at(.vars=c(all_of(c_svNACols)), function(z){0}) + x_impacts <- x_impacts |> mutate_at(.vars=c(all_of(c_svNACols)), function(z){0}) rm("c_svNACols") ###### National Terciles ###### - # x_impacts %>% glimpse - if(msgUser) {msg1 %>% paste0("Calculating national terciles...") %>% message} - else {msg2 %>% paste0("...") %>% message} + # x_impacts |> glimpse() + if(msgUser) {msg1 |> paste0("Calculating national terciles...") |> message()} + else {msg2 |> paste0("...") |> message()} ### Columns groupsNat0 <- c("year") tractNat0 <- c("national_highRiskTract") cutoffNat0 <- c("national_cutoff") scaledImpact0 <- c("sv_impact") ### Calculate terciles and rename column - quants_national <- x_impacts %>% select(c(all_of(groupsNat0), all_of(scaledImpact0))) - quants_national <- quants_national %>% - group_by_at (.vars = c(all_of(groupsNat0))) %>% - summarize_at(.vars = c(all_of(scaledImpact0)), calc_terciles) %>% ungroup + quants_national <- x_impacts |> select(c(all_of(groupsNat0), all_of(scaledImpact0))) + quants_national <- quants_national |> + group_by_at (.vars = c(all_of(groupsNat0))) |> + summarize_at(.vars = c(all_of(scaledImpact0)), calc_terciles) |> ungroup() ### Rename - quants_national <- quants_national %>% rename_at(.vars=all_of(scaledImpact0), ~all_of(cutoffNat0)) - if(.testing){quants_national %>% filter(year==2050) %>% glimpse} + quants_national <- quants_national |> rename_at(.vars=all_of(scaledImpact0), ~all_of(cutoffNat0)) + if(.testing){quants_national |> filter(year==2050) |> glimpse()} ### Join with national quantiles - if(msgUser) {msg2 %>% paste0("Joining national terciles to tract-level data...") %>% message} - else {msg3 %>% paste0(msg1, "...") %>% message} - x_impacts <- x_impacts %>% left_join(quants_national, by = c(all_of(groupsNat0))); + if(msgUser) {msg2 |> paste0("Joining national terciles to tract-level data...") |> message()} + else {msg3 |> paste0(msg1, "...") |> message()} + x_impacts <- x_impacts |> left_join(quants_national, by = c(all_of(groupsNat0))); rm("quants_national"); ### Figure out which tracts are high risk ### Calculate high risk populations - if(msgUser) {msg2 %>% paste0("Calculating national high risk populations...") %>% message} - else {msg3 %>% paste0(msg1, "...") %>% message} + if(msgUser) {msg2 |> paste0("Calculating national high risk populations...") |> message()} + else {msg3 |> paste0(msg1, "...") |> message()} x_impacts[[tractNat0]] <- (x_impacts[[scaledImpact0]] > x_impacts[[cutoffNat0]]) * 1 - x_impacts <- x_impacts %>% select(-c(all_of(cutoffNat0))); + x_impacts <- x_impacts |> select(-c(all_of(cutoffNat0))); rm("cutoffNat0") # Sys.sleep(sleep) ###### Regional Terciles ###### - if(msgUser) {msg1 %>% paste0("Calculating regional terciles...") %>% message} - else {msg3 %>% paste0("...") %>% message} + if(msgUser) {msg1 |> paste0("Calculating regional terciles...") |> message()} + else {msg3 |> paste0("...") |> message()} ### Columns groupsReg0 <- c(groupsNat0, "region") tractReg0 <- c("regional_highRiskTract") cutoffReg0 <- c("regional_cutoff") ### 126 rows ### Calculate terciles and rename column - quants_regional <- x_impacts %>% select(c(all_of(groupsReg0), all_of(scaledImpact0))) - quants_regional <- quants_regional %>% - group_by_at(.vars=c(all_of(groupsReg0))) %>% - summarize_at(.vars=c(all_of(scaledImpact0)), calc_terciles) %>% ungroup + quants_regional <- x_impacts |> select(c(all_of(groupsReg0), all_of(scaledImpact0))) + quants_regional <- quants_regional |> + group_by_at(.vars=c(all_of(groupsReg0))) |> + summarize_at(.vars=c(all_of(scaledImpact0)), calc_terciles) |> ungroup() ### Rename - quants_regional <- quants_regional %>% rename_at(.vars=all_of(scaledImpact0), ~all_of(cutoffReg0)) - if(.testing){quants_regional %>% filter(year==2050) %>% glimpse} + quants_regional <- quants_regional |> rename_at(.vars=all_of(scaledImpact0), ~all_of(cutoffReg0)) + if(.testing){quants_regional |> filter(year==2050) |> glimpse()} ### Join with regional quantiles - if(msgUser){msg2 %>% paste0("Joining regional terciles to tract-level data...") %>% message} - else {msg3 %>% paste0(msg1, "...") %>% message} - x_impacts <- x_impacts %>% left_join(quants_regional, by = c(all_of(groupsReg0))); + if(msgUser){msg2 |> paste0("Joining regional terciles to tract-level data...") |> message()} + else {msg3 |> paste0(msg1, "...") |> message()} + x_impacts <- x_impacts |> left_join(quants_regional, by = c(all_of(groupsReg0))); rm("quants_regional"); ### Regional High Risk Tracts ### Figure out which tracts are high risk ### Calculate high risk populations - if(msgUser) {msg2 %>% paste0("Calculating regional high risk populations...") %>% message} - else {msg3 %>% paste0("...") %>% message} + if(msgUser) {msg2 |> paste0("Calculating regional high risk populations...") |> message()} + else {msg3 |> paste0("...") |> message()} x_impacts[[tractReg0]] <- (x_impacts[[scaledImpact0]] > x_impacts[[cutoffReg0]]) * 1 - x_impacts <- x_impacts %>% select(-c(all_of(cutoffReg0))); + x_impacts <- x_impacts |> select(-c(all_of(cutoffReg0))); rm("cutoffReg0") # Sys.sleep(sleep) @@ -392,28 +392,28 @@ calc_tractImpacts <- function( c_impact0 <- c("tract_impact") ### - Impacted population (e.g., children for Air Quality) (Impacted population = population*popWeight) x_impacts[[c_impPop0]] <- x_impacts[[c_pop0 ]] * x_impacts[["popWeight"]] - # (x_impacts$tract_impPop != 0) %>% which %>% length %>% print + # (x_impacts$tract_impPop != 0) |> which() |> length() |> print() ### - Calculate SV impacts for ref pop and impacted SV pop (Impacts = impacted population*sv_impact) x_impacts[[c_impact0]] <- x_impacts[[c_impPop0]] * x_impacts[["sv_impact"]] - # x_impacts %>% print # (x_impacts$tract_impact != 0) %>% which %>% length %>% print + # x_impacts |> print() # (x_impacts$tract_impact != 0) |> which() |> length() |> print() ### Drop columns - # x_impacts <- x_impacts %>% select(-c("popWeight", "sv_impact", all_of(c_pop0))) - x_impacts <- x_impacts %>% select(-c(all_of(c_pop0))) + # x_impacts <- x_impacts |> select(-c("popWeight", "sv_impact", all_of(c_pop0))) + x_impacts <- x_impacts |> select(-c(all_of(c_pop0))) rm("c_pop0") ###### Gather Groups ###### ### Gather by svGroupType: all the main SV variables, and racial vars - x_impacts <- x_impacts %>% gather(key = "svGroupType", value = "svRatio2Ref", c(all_of(svGroups))) + x_impacts <- x_impacts |> gather(key = "svGroupType", value = "svRatio2Ref", c(all_of(svGroups))) ###### Tract Values ###### ### Columns c_suffix0 <- c("ref", "sv") - c_impPop1 <- c_impPop0 %>% paste(c_suffix0, sep="_") - c_impact1 <- c_impact0 %>% paste(c_suffix0, sep="_") + c_impPop1 <- c_impPop0 |> paste(c_suffix0, sep="_") + c_impact1 <- c_impact0 |> paste(c_suffix0, sep="_") ### New columns sumCols0 <- c(c_impPop0, c_impact0) - refSumCols0 <- sumCols0 %>% paste("ref", sep="_") - svSumCols0 <- sumCols0 %>% paste("sv" , sep="_") + refSumCols0 <- sumCols0 |> paste("ref", sep="_") + svSumCols0 <- sumCols0 |> paste("sv" , sep="_") ### - Calculate SV ref pop ("refPop") and weighted (impacted) SV pop ("impactPop") svRatio2Ref0 <- x_impacts[["svRatio2Ref"]] x_impacts[, refSumCols0] <- x_impacts[, sumCols0] * (1 - svRatio2Ref0) @@ -421,37 +421,37 @@ calc_tractImpacts <- function( rm("svRatio2Ref0"); rm("sumCols0", "refSumCols0", "svSumCols0") ### Calculate high-risk populations # popNat0 <- c("national_highRiskPop") - popNat1 <- c("national_highRiskPop") %>% paste(c_suffix0, sep="_") - popReg1 <- c("regional_highRiskPop") %>% paste(c_suffix0, sep="_") + popNat1 <- c("national_highRiskPop") |> paste(c_suffix0, sep="_") + popReg1 <- c("regional_highRiskPop") |> paste(c_suffix0, sep="_") x_impacts[,popNat1] <- x_impacts[,c_impPop1] * x_impacts[[tractNat0]] x_impacts[,popReg1] <- x_impacts[,c_impPop1] * x_impacts[[tractReg0]] rm("tractNat0", "tractReg0") ###### Regional Summaries ###### if(!.testing){ - if(msgUser){msg1 %>% paste0( "Calculating regional summaries...") %>% message} - sumCols0 <- c(c_impPop1, c_impact1) %>% c(popNat1, popReg1) + if(msgUser){msg1 |> paste0( "Calculating regional summaries...") |> message()} + sumCols0 <- c(c_impPop1, c_impact1) |> c(popNat1, popReg1) groupCols0 <- c("region", "svGroupType", "driverUnit", "driverValue", "year") ### Group by the grouping columns and summarize the summary columns - x_impacts <- x_impacts %>% - group_by_at (.vars=c(all_of(groupCols0))) %>% - summarize_at(.vars=c(all_of(sumCols0)), sum, na.rm=T) %>% ungroup - # (x_impacts$tract_impPop_ref != 0) %>% which %>% length %>% print + x_impacts <- x_impacts |> + group_by_at (.vars=c(all_of(groupCols0))) |> + summarize_at(.vars=c(all_of(sumCols0)), sum, na.rm=T) |> ungroup() + # (x_impacts$tract_impPop_ref != 0) |> which() |> length() |> print() ### Select all of the relevant columns - x_impacts <- x_impacts %>% select(c(all_of(groupCols0), all_of(sumCols0))) + x_impacts <- x_impacts |> select(c(all_of(groupCols0), all_of(sumCols0))) ### Replace tract in summary names - x_impacts <- x_impacts %>% rename_at(.vars=c(all_of(sumCols0)), ~gsub("tract_", "", sumCols0)); + x_impacts <- x_impacts |> rename_at(.vars=c(all_of(sumCols0)), ~gsub("tract_", "", sumCols0)); rm("sumCols0", "groupCols0") ###### Average Rates ###### ### Convert 0 values to NA and then to zero - rateCols0 <- c("aveRate") %>% paste(c_suffix0, sep="_") + rateCols0 <- c("aveRate") |> paste(c_suffix0, sep="_") c_impPop1 <- gsub("tract_", "", c_impPop1) c_impact1 <- gsub("tract_", "", c_impact1) x_impacts[, rateCols0] <- x_impacts[,c_impact1] / x_impacts[,c_impPop1] ### Replace NA values - which0_ref <- (x_impacts$impPop_ref == 0) %>% which - which0_sv <- (x_impacts$impPop_sv == 0) %>% which + which0_ref <- (x_impacts$impPop_ref == 0) |> which() + which0_sv <- (x_impacts$impPop_sv == 0) |> which() x_impacts[["aveRate_ref"]][which0_ref] <- 0 x_impacts[["aveRate_sv" ]][which0_sv ] <- 0 rm("which0_ref", "which0_sv") @@ -460,10 +460,10 @@ calc_tractImpacts <- function( # Sys.sleep(sleep) ### Dataframe - x_impacts <- x_impacts %>% as.data.frame + x_impacts <- x_impacts |> as.data.frame() ###### Return ###### - msg1 %>% paste0("Finished calculating total impacts.") %>% message + msg1 |> paste0("Finished calculating total impacts.") |> message() return(x_impacts) } @@ -477,28 +477,28 @@ get_validGroups <- function( old0 <- c("colName" , "valid_popWeightCols") new0 <- c("svGroupType", "validGroups") ### Reshape svDemoInfo - df0 <- df0 %>% filter(colType %in% c("bipoc")) %>% select(c(old0[1])) - df0 <- df0 %>% rename_at(.vars=c(old0[1]), ~c(new0[1])) - # df0 <- df0 %>% mutate(validGroups = "none") + df0 <- df0 |> filter(colType %in% c("bipoc")) |> select(c(old0[1])) + df0 <- df0 |> rename_at(.vars=c(old0[1]), ~c(new0[1])) + # df0 <- df0 |> mutate(validGroups = "none") # children, highRiskLabor, sv_plus65, none - df0 <- df0 %>% mutate(validGroups = "children, highRiskLabor, sv_plus65, none") + df0 <- df0 |> mutate(validGroups = "children, highRiskLabor, sv_plus65, none") ### Reshape svValidTypes - df1 <- df1 %>% select(c(new0[1], old0[2])) - df1 <- df1 %>% rename_at(.vars=c(old0[2]), ~c(new0[2])) + df1 <- df1 |> select(c(new0[1], old0[2])) + df1 <- df1 |> rename_at(.vars=c(old0[2]), ~c(new0[2])) ### Bind - df0 <- df1 %>% rbind(df0) + df0 <- df1 |> rbind(df0) rm("df1", "old0", "new0") ### Calculate weight columns - col0 <- col0 %>% as.character %>% tolower - groups0 <- df0$validGroups %>% as.vector %>% as.character %>% tolower - valid0 <- groups0 %>% str_match(col0) %>% unlist %>% as.vector - # col0 %>% print; groups0 %>% print; valid0 %>% print - - df0 <- df0 %>% mutate(weightCol = col0) - df0 <- df0 %>% mutate(validType = valid0) - df0 <- df0 %>% mutate(valueAdj = (1*!is.na(validType))) - # df0 %>% glimpse + col0 <- col0 |> as.character() |> tolower() + groups0 <- df0$validGroups |> as.vector() |> as.character() |> tolower() + valid0 <- groups0 |> str_match(col0) |> unlist() |> as.vector() + # col0 |> print(); groups0 |> print(); valid0 |> print() + + df0 <- df0 |> mutate(weightCol = col0) + df0 <- df0 |> mutate(validType = valid0) + df0 <- df0 |> mutate(valueAdj = (1*!is.na(validType))) + # df0 |> glimpse() ### Return return(df0) }