From 8a8b9ddde6865b9e1ca6177f37de3408b323ef5b Mon Sep 17 00:00:00 2001 From: Karen Noiva Date: Fri, 2 Aug 2024 19:01:53 -0400 Subject: [PATCH] Fixed issues with plotting scaled impacts Fixed issues with plotting SLR scaled impacts (change in levels for SLR heights) --- R/configTests.R | 649 +++++++++++++------------ R/configTests_utils.R | 836 +------------------------------- R/create_scaledImpact_plot.R | 318 ++++++++++++ R/create_scaledImpact_plots.R | 379 +++++++++++++++ R/utils_create_report_figures.R | 180 +++---- R/utils_save_report_objects.R | 7 +- 6 files changed, 1152 insertions(+), 1217 deletions(-) create mode 100644 R/create_scaledImpact_plot.R create mode 100644 R/create_scaledImpact_plots.R diff --git a/R/configTests.R b/R/configTests.R index aefa1e5..9f0ec1d 100644 --- a/R/configTests.R +++ b/R/configTests.R @@ -15,10 +15,9 @@ dataInfo_test <- function( dataList = list(), outPath = ".", csvName = "dataInfo_test", - save = TRUE, ### Whether to save results to file - return = TRUE ### Whether to return results + save = TRUE, ### Whether to save results to file + return = TRUE ### Whether to return results ) { - #dataList <- list_reshapeData ###### List Info ###### ### List names ### Length of list and list names @@ -30,9 +29,8 @@ dataInfo_test <- function( ###### List Object Types ###### ### Get info on object types and add names ### Simplify list of types - # cTypes <- c("data.frame", "list", "character", "numeric") + # c("data.frame", "list", "character", "numeric") listTypes <- listNames |> map(~ (dataList[[.]] |> class())) |> set_names(listNames) - # listTypes[1] |> print() ### Simplify types listTypes <- listNames |> map(~ case_when( ("data.frame" %in% listTypes[[.]]) ~ "data.frame", @@ -41,7 +39,6 @@ dataInfo_test <- function( ("numeric" %in% listTypes[[.]]) ~ "numeric", TRUE ~ "N/A" )) |> set_names(listNames) - # c(length(listTypes), names(listTypes) |> length()) |> print() ###### Initial Table Info ###### ### Initialize table of info...make methods specific to class @@ -49,20 +46,17 @@ dataInfo_test <- function( df_info <- tibble(table = listNames) df_info <- df_info |> mutate(itemClass = listTypes |> unlist()) - ### Count number of columns in each table - ### Count number of rows in each table - ### Count number of distinct rows in each table - ### Count number of missing values + ### In each table, count number of: columns, rows, distinct rows, and + ### - Columns + ### - Rows + ### - Distinct rows + ### - Number of columns with all missing values ### Expressions - # num_cols <- listNames |> map(~ .x |> fun_nCol(a=listTypes, b=dataList)) |> unlist() - # num_rows <- listNames |> map(~ .x |> fun_nRow(a=listTypes, b=dataList)) |> unlist() - # unique_rows <- listNames |> map(~ .x |> fun_nUnq(a=listTypes, b=dataList)) |> unlist() - # cols_wAllNA <- listNames |> map(~ .x |> fun_nNna(a=listTypes, b=dataList)) |> unlist() - nCols0 <- list(z=listNames, a=listTypes, b=dataList) |> pmap(fun_nCol) |> unlist() - nRows0 <- list(z=listNames, a=listTypes, b=dataList) |> pmap(fun_nRow) |> unlist() - unique0 <- list(z=listNames, a=listTypes, b=dataList) |> pmap(fun_nUnq) |> unlist() + nCols0 <- list(z=listNames, a=listTypes, b=dataList) |> pmap(fun_nCol ) |> unlist() + nRows0 <- list(z=listNames, a=listTypes, b=dataList) |> pmap(fun_nRow ) |> unlist() + unique0 <- list(z=listNames, a=listTypes, b=dataList) |> pmap(fun_nUnq ) |> unlist() allNACols <- list(z=listNames, a=listTypes, b=dataList) |> pmap(fun_allNA) |> unlist() - allNACols |> print() + # allNACols |> print() ### Add to df_info df_info <- df_info |> mutate(num_cols = nCols0 ) @@ -80,17 +74,8 @@ dataInfo_test <- function( except0 <- c() df_info <- df_info |> mutate(has_dups = case_when( table %in% except0 ~ F, - .default = num_rows == unique_rows + .default = !(num_rows == unique_rows) )) ### End mutate - # df_info <- df_info |> mutate(has_dups = case_when( - # table %in% except0 ~ F, - # num_rows == unique_rows ~ F, - # itemClass %in% c("list", "data.frame") ~ F, - # # itemClass == "list" ~ F, - # # num_rows == unique_rows ~ F, - # # table %in% except0 ~ F, - # # .default = T - # )) ### End mutate ### Check whether all tests are passed df_info <- df_info |> mutate(passed = case_when( # itemClass == "list" ~ T, @@ -110,7 +95,7 @@ dataInfo_test <- function( ### Message user "Checking tables..." |> message() - msg_flags <- ifelse(hasFlags, "Some tables don't pass", "All tables pass") |> paste0("...") + msg_flags <- hasFlags |> ifelse("Some tables don't pass", "All tables pass") |> paste0("...") "\t" |> paste0(msg_flags) |> message() rm(msg_flags) @@ -163,6 +148,7 @@ add_gen_plot <- function( ){ ### Info plotNames <- c("temp", "slr", "gdp", "pop") + doPop <- "pop" %in% (plotName |> tolower()) # plotNames <- plotsList |> names() ### Plot info @@ -170,8 +156,14 @@ add_gen_plot <- function( fType0 <- "png" units0 <- "in" dpi0 <- 200 - width0 <- 6.0 - height0 <- 4.5 + # width0 <- 6.0 + # height0 <- 4.5 + width0 <- 6.0 + (doPop |> ifelse(4, 0)) + height0 <- 4.5 + (doPop |> ifelse(0, 0)) + + + ### Adjust width and height for population + list0 <- plotsList[[plotName]] plot0 <- list0[["plot"]] @@ -229,10 +221,11 @@ general_config_test <- function( # byState = TRUE, ### Whether to run results by state (deprecated) outPath = ".", ### Where to save results xlsxName = "generalConfig_testResults.xlsx", ### File name for outputs + doPlots = FALSE, ### Whether to create scaled impact plots return = TRUE, ### Whether to return results save = TRUE, ### Whether to save results to file - overwrite = TRUE, ### Whether to overwrite an existing file if saving - fredi_config = NULL ### fredi_config list object + overwrite = TRUE ### Whether to overwrite an existing file if saving + # fredi_config = NULL ### fredi_config list object ){ ###### Create Workbook ###### if(save) { @@ -246,6 +239,9 @@ general_config_test <- function( wbook0 <- createWorkbook() } ### End if(save) + ###### Assign Objects ###### + configList0 <- configuredData[["fredi_config"]] + for(name_i in configList0 |> names()) {name_i |> assign(configList0[[name_i]]); rm(name_i)} ###### Initialize List ###### ### Initialize list for saving values @@ -333,6 +329,7 @@ general_config_test <- function( names0 <- list0 |> names() list0 <- list(name0_i = names0, list0_i = list0) df0 <- list0 |> pmap(function(name0_i, list0_i){ + # name0_i |> print() df0_i <- list0_i |> dataInfo_test(save=F, return=T) df0_i <- df0_i |> mutate(listName = name0_i) return(df0_i) @@ -353,19 +350,24 @@ general_config_test <- function( saveList[[cfigName0]] <- dataResults - ###### Default Values ###### + ###### Configuration Values ###### ### Items from fredi_config: - listConfig0 <- fredi_config - c_defaults0 <- c("aggList0" , "minYear", "maxYear", "baseYear0", "rate0") - c_defaults1 <- c("aggLevels", "minYear", "maxYear", "baseYear" , "rate" ) - n_defaults0 <- listConfig0 |> names() - w_defaults0 <- (n_defaults0 %in% c_defaults0) |> which() - ### Filter to specified items, update names - listConfig1 <- listConfig0[w_defaults0] + # listConfig0 <- configuredData[["fredi_config"]] + ### Drop messages from list + drop0 <- c("messages_data", "list_messages") + listConfig0 <- configList0 |> (function(list0, x=drop0){list0[!((list0 |> names()) %in% x)]})() + rm(drop0) + # ### + # c_defaults0 <- c("aggList0" , "minYear0", "maxYear0") + # c_defaults1 <- c("aggLevels", "minYear", "maxYear") + # n_defaults0 <- listConfig0 |> names() + # w_defaults0 <- (n_defaults0 %in% c_defaults0) |> which() + # ### Filter to specified items, update names + # listConfig1 <- listConfig0[w_defaults0] ### Create table - defaultsList <- listConfig1 |> names() |> map(function( + defaultsList <- listConfig0 |> names() |> map(function( name_i, - list0 = listConfig1 + list0 = listConfig0 ){ val0_i <- list0[[name_i]] type_i <- val0_i |> class() |> paste(collapse=", ") @@ -374,8 +376,8 @@ general_config_test <- function( return(df_i) }) |> bind_rows() ### Update parameter names - defaultsList <- defaultsList |> mutate(parameter=parameter |> factor(c_defaults0, c_defaults1)) - defaultsList <- defaultsList |> mutate(parameter=parameter |> as.character()) + # defaultsList <- defaultsList |> mutate(parameter=parameter |> factor(c_defaults0, c_defaults1)) + # defaultsList <- defaultsList |> mutate(parameter=parameter |> as.character()) ### Add table to list saveList[[defParam0]] <- defaultsList @@ -394,46 +396,80 @@ general_config_test <- function( ###### Default Plots ###### ### Plot values - lab_tmp0 <- expression("CONUS Degrees of Warming ("~degree*C*")") + lab_yrs0 <- "Year" lim_yrs0 <- c(2000, 2300) brk_yrs0 <- seq(lim_yrs0[1], lim_yrs0[2], by=20) ### Temp plot - configuredData$scenarioData |> names() |> print() - temp_plot <- configuredData$scenarioData[["gcam_default"]] |> - ggplot() + - geom_line(aes(x = year, y = temp_C_conus)) + - scale_x_continuous(lab_yrs0, breaks=brk_yrs0, limits=lim_yrs0) + - scale_y_continuous(lab_tmp0) + - ggtitle("Default Temperature Scenario") + # configuredData$scenarioData |> names() |> print() + temp_plot <- configuredData$scenarioData[["gcam_default"]] |> (function(df0){ + years0 <- df0 |> pull(year) |> get_years_fromData() + labYrs <- "Year" + limYrs <- years0 |> range() + brkYrs <- limYrs[1] |> seq(limYrs[2], by=20) + yLab0 <- expression("CONUS Degrees of Warming ("~degree*C*")") + p0 <- df0 |> ggplot() + + geom_line(aes(x = year, y = temp_C_conus)) + + scale_x_continuous(labYrs, breaks=brkYrs, limits=limYrs) + + scale_y_continuous(yLab0) + + ggtitle("Default Temperature Scenario") + return(p0) + })() + ### SLR plot - slr_plot <- configuredData$scenarioData[["gcam_default"]] |> - ggplot() + - geom_line(aes(x = year, y = slr_cm)) + - scale_x_continuous(lab_yrs0, breaks=brk_yrs0, limits=lim_yrs0) + - scale_y_continuous("SLR (cm)") + - ggtitle("Default SLR Scenario") + slr_plot <- configuredData$scenarioData[["gcam_default"]] |> (function(df0){ + years0 <- df0 |> pull(year) |> get_years_fromData() + labYrs <- "Year" + limYrs <- years0 |> range() + brkYrs <- limYrs[1] |> seq(limYrs[2], by=20) + p0 <- df0 |> ggplot() + + geom_line(aes(x = year, y = slr_cm)) + + scale_x_continuous(lab_yrs0, breaks=brkYrs, limits=limYrs) + + scale_y_continuous("SLR (cm)") + + ggtitle("Default SLR Scenario") + return(p0) + })() + + ### GDP Plot: Convert to Billions - gdp_plot <- configuredData$scenarioData[["gdp_default"]] |> - mutate(gdp_usd = gdp_usd / 1e12) |> - ggplot() + - geom_line(aes(x = year, y = gdp_usd)) + - scale_x_continuous(lab_yrs0, breaks=brk_yrs0, limits=lim_yrs0) + - scale_y_continuous("U.S. National GDP (2015$, trillions)") + - ggtitle("Default GDP Scenario") + gdp_plot <- configuredData$scenarioData[["gdp_default"]] |> (function(df0){ + years0 <- df0 |> pull(year) |> get_years_fromData() + labYrs <- "Year" + limYrs <- years0 |> range() + brkYrs <- limYrs[1] |> seq(limYrs[2], by=20) + df0 <- df0 |> mutate(gdp_usd = gdp_usd / 1e12) + p0 <- df0 |> ggplot() + + geom_line(aes(x = year, y = gdp_usd)) + + scale_x_continuous(labYrs, breaks=brkYrs, limits=limYrs) + + scale_y_continuous("U.S. National GDP (2015$, trillions)") + + ggtitle("Default GDP Scenario") + return(p0) + })() + ### Pop plot - pop_plot <- configuredData$scenarioData[["pop_default"]] |> - mutate(pop = pop / 1e6) |> - ggplot() + - geom_line(aes(x = year, y = pop, color = state), alpha = 0.75) + - scale_x_continuous(lab_yrs0, breaks=brk_yrs0, limits=lim_yrs0) + - scale_y_continuous("State Population (millions)") + - # theme(axis.text.x = element_text(angle=90)) + - theme(legend.position = "bottom") + - scale_color_discrete("State") + - ggtitle("Default Population Scenario") + pop_plot <- configuredData$scenarioData[["pop_default"]] |> (function(df0){ + years0 <- df0 |> pull(year) |> get_years_fromData() + labYrs <- "Year" + limYrs <- years0 |> range() + brkYrs <- limYrs[1] |> seq(limYrs[2], by=20) + + df0 <- df0 |> mutate(pop = pop / 1e6) + df1 <- df0 |> filter(year == 2050) + p0 <- df0 |> ggplot() + + geom_line(aes(x=year, y=pop, color=region, group=interaction(region, state)), alpha = 0.75) + + scale_x_continuous(labYrs, breaks=brkYrs, limits=limYrs) + + scale_y_continuous("State Population (millions)") + + geom_text(data=df1, aes(x=year, y=pop, label=postal), stat="identity", alpha=0.6) + + facet_grid(.~region) + + # theme(axis.text.x = element_text(angle=90)) + + theme(legend.position = "bottom") + + scale_color_discrete("State") + + ggtitle("Default Population Scenario") + return(p0) + })() + ### Add plots to list listPlots[["temp"]] <- list(plot=temp_plot) |> c(listPlots[["temp"]]) @@ -464,19 +500,22 @@ general_config_test <- function( } ### End if(save) ###### Create Scaled Impact Results ###### - ### Get results - scaledData <- configuredData |> get_fredi_sectorOptions_results() - scaledPlots <- configuredData |> get_scaled_impact_plots() - ### Save - if(save) { - wbook0 |> addWorksheet(sheetName = "scaledImpacts_data") - wbook0 |> writeDataTable(sheet = "scaledImpacts_data", scaledData) - rm(name_i) - } ### End if(save) - - ### Add to return list, drop intermediate objects - saveList[["scaledImpactsPlots"]] <- list(data=scaledData, plots=scaledPlots) - rm(scaledData, scaledPlots) + # ### Get results + if(doPlots) { + scaledData <- configuredData |> get_fredi_sectorOptions_results() + scaledPlots <- configuredData |> get_scaled_impact_plots() + ### Save + if(save) { + wbook0 |> addWorksheet(sheetName = "scaledImpacts_data") + wbook0 |> writeDataTable(sheet = "scaledImpacts_data", scaledData) + rm(name_i) + } ### End if(save) + + ### Add to return list, drop intermediate objects + saveList[["scaledImpactsPlots"]] <- list(data=scaledData, plots=scaledPlots) + rm(scaledData, scaledPlots) + } ### End if(doPlots) + ###### Save Outputs ###### ### Save the workbook, remove workbook @@ -566,12 +605,12 @@ get_fredi_sectorOptions <- function( rm(rename0, rename1, include0) ### Rename columns - rename0 <- c("sector", "variant", "impactType", "impactYear", "region") - rename1 <- c("sector_id", "variant_id", "impactType_id", "impactYear_id", "region_id") - rename2 <- c("sector_label", "variant_label", "impactType_label", "impactYear_label", "region_label") - df_x <- df_x |> rename_at(c(rename0), ~c(rename1)) - df_x <- df_x |> rename_at(c(rename2), ~c(rename0)) - rm(rename0, rename1, rename2) + # rename0 <- c("sector", "variant", "impactType", "impactYear", "region") + # rename1 <- c("sector_id", "variant_id", "impactType_id", "impactYear_id", "region_id") + # rename2 <- c("sector_label", "variant_label", "impactType_label", "impactYear_label", "region_label") + # df_x <- df_x |> rename_at(c(rename0), ~c(rename1)) + # df_x <- df_x |> rename_at(c(rename2), ~c(rename0)) + # rm(rename0, rename1, rename2) ### Return return(df_x) @@ -613,21 +652,17 @@ get_fredi_sectorOptions_results <- function( if(do_slr){ ### Load SLR data slrImp <- dataList[["slrImpacts"]] - slrImp |> glimpse(); df_slr |> glimpse() + # slrImp |> glimpse(); df_slr |> glimpse() ### Join df_slr with impacts - rename0 <- c("sector", "variant", "impactType", "impactYear", "region") - rename1 <- c("sector_id", "variant_id", "impactType_id", "impactYear_id", "region_id") - join0 <- rename1 |> c(stateCols) |> c("model_id", "modelType") |> unique() - slrImp <- slrImp |> rename_at(c(rename0, "model"), ~c(rename1, "model_label")) - df_slr <- df_slr |> rename_at(c("model"), ~c("model_id")) - slrImp <- slrImp |> select(-c("model_label")) - # slrImp |> glimpse(); df_slr |> glimpse() + slrImp <- slrImp |> select(-c("model")) + slrImp <- slrImp |> rename_at(c("model_id"), ~c("model")) + join0 <- c("sector", "variant", "impactType", "impactYear", "region") |> c(stateCols) |> c("modelType", "model") |> unique() df_slr <- df_slr |> left_join(slrImp, by=c(join0)) rm(join0, slrImp) ### Add driverValue - df_slr <- df_slr |> mutate(driverValue=model_id |> str_replace("cm", "") |> as.numeric()) + df_slr <- df_slr |> mutate(driverValue=model |> str_replace("cm", "") |> as.numeric()) # df_slr |> glimpse() ### Relocate columns @@ -669,7 +704,7 @@ get_fredi_sectorOptions_results <- function( df_gcm <- df_gcm |> relocate(all_of(select0)) rm(df_vals, select0, join0) ### Add year - df_gcm <- df_gcm |> mutate(year = impactYear |> na_if("N/A")) + df_gcm <- df_gcm |> mutate(year = impactYear |> na_if("NA")) df_gcm <- df_gcm |> mutate(year = year |> as.numeric()) ### Bind with initial results # df0 |> names() |> print(); df_gcm |> names() |> print() @@ -697,7 +732,6 @@ get_fredi_sectorOptions_results <- function( select0 <- c("scenario_id", "sector", "variant", "impactType", "impactYear", "region") |> c(stateCols) select0 <- select0 |> c("modelType", "model", "scaled_impacts", "modelUnit", "maxUnitValue", "driverValue", "year") mutate0 <- c("variant", "impactType", "impactYear") - # df0 <- df0 |> mutate_at(c(mutate0), function(y){y |> na_if("N/A") |> replace_na("NA")}) df0 <- df0 |> select(all_of(select0)) df0 <- df0 |> mutate(modelType = modelType |> toupper()) @@ -717,12 +751,13 @@ make_scaled_impact_plots <- function( margins = c(0, 0, .15, 0), marginUnit = "cm", theme = NULL - ) ### End list + ), ### End list + silent = TRUE ){ ###### Get from FrEDI Namespace ###### ### Other values - years <- df0[["impactYear"]] |> unique() - models <- df0[["modelType"]] |> unique() + years <- df0 |> pull(impactYear) |> unique() + models <- df0 |> pull(modelType) |> unique() ### Data frame to iterate over do_gcm <- "gcm" %in% tolower(models) do_slr <- "slr" %in% tolower(models) @@ -756,12 +791,12 @@ make_scaled_impact_plots <- function( ### Make plots plot_y <- df_y |> create_scaledImpact_plots( sector = x1, - modelType = .x, + type0 = .x, yCol = yCol, xCol = xCol_x, colorCol = colorCol, # byState = byState, - silent = TRUE, + silent = silent, options = options ) ### End create_scaledImpact_plots # plot_y |> names() |> print() @@ -946,202 +981,202 @@ save_scaled_impact_figures <- function( #' @export #' #' @examples -newSectors_config_test <- function( - newData = NULL, ### Data list with new data - refDataFile = "." |> file.path("data", "sysdata.rda"), ### Path to old data for comparison - outPath = ".", ### Path to save outputs - xslxName = "newSectorsConfig_testResults.xlsx", ### Name of test file - byState = FALSE, ### Whether results are by state (deprecated) - return = TRUE, ### Whether to return results - save = TRUE, ### Whether to save results - overwrite = TRUE ### If save is true, whether to overwrite file -){ - ###### Create Workbook ###### - if(save){ - outDir <- outPath |> file.path("data_tests") - outFile <- outDir |> file.path(xlsxName) - ### Check if outDir exists and, if not, create one - odExists <- outDir |> dir.exists() - if(!odExists){outDir |> dir.create(showWarnings = F)} - rm(odExists) - ### Create Excel workbook - wbook0 <- createWorkbook() - } ### End if(save) - - - ###### Initialize Save List ###### - saveList <- list() - - - ###### Data Names ###### - ### Names of objects to save - c_config0 <- "tests" - c_diff0 <- "tests_diffs" - c_impact0 <- "scaledImpacts_values" - c_plots0 <- "scaledImpacts_plots" - - - ###### Load Reference Data ###### - ### Load ref data - newEnv <- new.env() - refDataFile |> load(verbose = F, envir=newEnv) - # ls(envir=newEnv) |> print() - refData <- "rDataList" |> get(envir=newEnv, inherits = F) - # ls() |> print(); refData() |> names() |> print() - refFunList <- refData[["gcmImpFuncs"]] - rm(newEnv) - # return(refData) - - - ###### Format New Data ###### - newFunList <- newData[["gcmImpFuncs"]] - # return(refData) - - - ###### Table Info ###### - ### Create table of status, rename and drop some columns - ### Mutate values for changes_expected - levels0 <- c("No", "Maybe", "Yes") - mutate0 <- c("changes_expected") - df_status <- newData[["testDev"]] - df_status <- df_status |> rename_at(c("Changes.if.new.sector.added"), ~mutate0) - df_status <- df_status |> mutate_at(c(mutate0), factor, levels=levels0) - rm(mutate0, levels0) - - - ###### Compare New & Ref Data ###### - ###### ** Get Test Info ###### - ### Get test info for new and old data - newTests <- newData |> dataInfo_test(save=F, return=T) - refTests <- newData |> dataInfo_test(save=F, return=T) - ### Select appropriate columns and join old and new test info - join0 <- c("table") - sum0 <- c("num_cols", "num_rows") - rename0 <- c("numCols" , "numRows" ) - select0 <- join0 |> c("itemClass", sum0) - select1 <- join0 |> c(sum0) - suffix0 <- c("_new", "_ref") - ### Select columns - newTests <- newTests |> select(all_of(select0)) - refTests <- refTests |> select(all_of(select1)) - ### Rename columns - newTests <- newTests |> rename_at(c(sum0), ~rename0) - refTests <- refTests |> rename_at(c(sum0), ~rename0) - ### Join old and new - df_tests <- newTests |> left_join(refTests, by=c(join0), suffix=suffix0) - rm(join0, sum0, select0, select1, rename0); rm(newTests, refTests) - - - ###### ** Join Tests and Test Info ###### - ### Join df_tests with df_status - join0 <- c("Table.Name") - rename0 <- c("table") - ### Check number of rows before - dim0 <- c(nrow(df_status), nrow(df_tests)) - ### Rename columns and join columns - df_tests <- df_tests |> rename_at(c(rename0), ~join0) - df_status <- df_status |> left_join(df_tests, by=c(join0)) - ### Check number of rows before - dim1 <- c(nrow(df_status), nrow(df_tests)) - all0 <- (dim1 == dim0) |> all() - rm(join0, rename0, all0); rm(df_tests) - - - ###### ** Compare Values ###### - ### Could filter on `table_test` columns if different tests required in the future - ### When no changes are expected still get dimensions and check that values are identical - # df_status |> names() |> print() - df_status <- df_status |> mutate(sameDims = 1 * ((numCols_new == numCols_ref) & (numRows_new == numRows_ref))) - ### Check values - checkVals <- df_status |> nrow() |> seq_len() |> map(function( - i, - df1 = newData, - df2 = refData - ){ - ### Names - name_i <- df_status[["Table.Name"]][i] - df1_i <- df1[[name_i]] - df2_i <- df2[[name_i]] - - ### Check whether to check values - skip_i <- ("list" %in% class(df1_i)) | df1_i |> is.null() | df2_i |> is.null() - check_i <- !skip_i - ### Initialize return value - y_i <- NA - if(check_i) {y_i <- 1 * identical(df1_i, df2_i)} - return(y_i) - }) |> unlist() - # checkVals |> print() - df_status <- df_status |> mutate(sameVals = checkVals) - df_status <- df_status |> mutate(hasDiffs = 1 * (!sameDims | !sameVals)) - rm(checkVals) - - - ###### ** Arrange Test Results ###### - ### Arrange values and add to save list - arrange0 <- c("changes_expected", "hasDiffs", "sameDims", "sameVals", "Table.Name") - df_status <- df_status |> arrange_at(c(arrange0)) - saveList[[c_config0]] <- df_status - rm(arrange0) - - - ###### Create Workbook ###### - ### Create workbook if(save) - ### Add worksheet with test info - if(save){ - wbook0 <- createWorkbook() - sheet0 <- c_config0 - wbook0 |> addWorksheet(sheetName = sheet0) - wbook0 |> writeDataTable(sheet = sheet0, x = df_status) - rm(sheet0) - } ### End if(save) - - - ###### Print Test Results ###### - ### Filter to tables with differences and add to list and workbook - df_diff <- df_status |> filter(hasDiffs == 1) - saveList[[c_diff0]] <- df_diff - # df_diff |> glimpse() - - ### Iterate over names of tables with differences: - ### - Add tables with differences to list - ### - Write tables with differences to xlsx workbook - names0 <- df_diff[["Table.Name"]] - names0 |> walk(function( - name_i, - new0=newData[[name_i]], - ref0=refData[[name_i]] - ){ - ### Worksheet/list name - sheet0 <- name_i |> paste("diff", sep="_") - - ### Get difference - join0 <- new0 |> names() |> (function(y, z=ref0){y[(y %in% names(z))]})() - diff0 <- new0 |> anti_join(ref0, by=c(join0)) - rm(join0) - - ### Add table to list - saveList[[sheet0]] <- diff0 - - ### Add worksheet and write data table if(save) - if(save) { - wbook0 |> addWorksheet(sheetName = sheet0) - wbook0 |> writeDataTable(sheet = sheet0, diff0) - } ### End if(save) - }) ### End function(name_i), end walk - - - ###### Save Workbook ###### - if(save){ - "Saving new sector results" |> paste0("...") |> message() - wbook0 |> saveWorkbook(file=outFile, overwrite=overwrite) - rm(wbook0) - } ### End if(save) - - - ###### Return ###### - if(return) return(saveList) -} +# newSectors_config_test <- function( +# newData = NULL, ### Data list with new data +# refDataFile = "." |> file.path("data", "sysdata.rda"), ### Path to old data for comparison +# outPath = ".", ### Path to save outputs +# xslxName = "newSectorsConfig_testResults.xlsx", ### Name of test file +# byState = FALSE, ### Whether results are by state (deprecated) +# return = TRUE, ### Whether to return results +# save = TRUE, ### Whether to save results +# overwrite = TRUE ### If save is true, whether to overwrite file +# ){ +# ###### Create Workbook ###### +# if(save){ +# outDir <- outPath |> file.path("data_tests") +# outFile <- outDir |> file.path(xlsxName) +# ### Check if outDir exists and, if not, create one +# odExists <- outDir |> dir.exists() +# if(!odExists){outDir |> dir.create(showWarnings = F)} +# rm(odExists) +# ### Create Excel workbook +# wbook0 <- createWorkbook() +# } ### End if(save) +# +# +# ###### Initialize Save List ###### +# saveList <- list() +# +# +# ###### Data Names ###### +# ### Names of objects to save +# c_config0 <- "tests" +# c_diff0 <- "tests_diffs" +# c_impact0 <- "scaledImpacts_values" +# c_plots0 <- "scaledImpacts_plots" +# +# +# ###### Load Reference Data ###### +# ### Load ref data +# newEnv <- new.env() +# refDataFile |> load(verbose = F, envir=newEnv) +# # ls(envir=newEnv) |> print() +# refData <- "rDataList" |> get(envir=newEnv, inherits = F) +# # ls() |> print(); refData() |> names() |> print() +# refFunList <- refData[["gcmImpFuncs"]] +# rm(newEnv) +# # return(refData) +# +# +# ###### Format New Data ###### +# newFunList <- newData[["gcmImpFuncs"]] +# # return(refData) +# +# +# ###### Table Info ###### +# ### Create table of status, rename and drop some columns +# ### Mutate values for changes_expected +# levels0 <- c("No", "Maybe", "Yes") +# mutate0 <- c("changes_expected") +# df_status <- newData[["testDev"]] +# df_status <- df_status |> rename_at(c("Changes.if.new.sector.added"), ~mutate0) +# df_status <- df_status |> mutate_at(c(mutate0), factor, levels=levels0) +# rm(mutate0, levels0) +# +# +# ###### Compare New & Ref Data ###### +# ###### ** Get Test Info ###### +# ### Get test info for new and old data +# newTests <- newData |> dataInfo_test(save=F, return=T) +# refTests <- newData |> dataInfo_test(save=F, return=T) +# ### Select appropriate columns and join old and new test info +# join0 <- c("table") +# sum0 <- c("num_cols", "num_rows") +# rename0 <- c("numCols" , "numRows" ) +# select0 <- join0 |> c("itemClass", sum0) +# select1 <- join0 |> c(sum0) +# suffix0 <- c("_new", "_ref") +# ### Select columns +# newTests <- newTests |> select(all_of(select0)) +# refTests <- refTests |> select(all_of(select1)) +# ### Rename columns +# newTests <- newTests |> rename_at(c(sum0), ~rename0) +# refTests <- refTests |> rename_at(c(sum0), ~rename0) +# ### Join old and new +# df_tests <- newTests |> left_join(refTests, by=c(join0), suffix=suffix0) +# rm(join0, sum0, select0, select1, rename0); rm(newTests, refTests) +# +# +# ###### ** Join Tests and Test Info ###### +# ### Join df_tests with df_status +# join0 <- c("Table.Name") +# rename0 <- c("table") +# ### Check number of rows before +# dim0 <- c(nrow(df_status), nrow(df_tests)) +# ### Rename columns and join columns +# df_tests <- df_tests |> rename_at(c(rename0), ~join0) +# df_status <- df_status |> left_join(df_tests, by=c(join0)) +# ### Check number of rows before +# dim1 <- c(nrow(df_status), nrow(df_tests)) +# all0 <- (dim1 == dim0) |> all() +# rm(join0, rename0, all0); rm(df_tests) +# +# +# ###### ** Compare Values ###### +# ### Could filter on `table_test` columns if different tests required in the future +# ### When no changes are expected still get dimensions and check that values are identical +# # df_status |> names() |> print() +# df_status <- df_status |> mutate(sameDims = 1 * ((numCols_new == numCols_ref) & (numRows_new == numRows_ref))) +# ### Check values +# checkVals <- df_status |> nrow() |> seq_len() |> map(function( +# i, +# df1 = newData, +# df2 = refData +# ){ +# ### Names +# name_i <- df_status[["Table.Name"]][i] +# df1_i <- df1[[name_i]] +# df2_i <- df2[[name_i]] +# +# ### Check whether to check values +# skip_i <- ("list" %in% class(df1_i)) | df1_i |> is.null() | df2_i |> is.null() +# check_i <- !skip_i +# ### Initialize return value +# y_i <- NA +# if(check_i) {y_i <- 1 * identical(df1_i, df2_i)} +# return(y_i) +# }) |> unlist() +# # checkVals |> print() +# df_status <- df_status |> mutate(sameVals = checkVals) +# df_status <- df_status |> mutate(hasDiffs = 1 * (!sameDims | !sameVals)) +# rm(checkVals) +# +# +# ###### ** Arrange Test Results ###### +# ### Arrange values and add to save list +# arrange0 <- c("changes_expected", "hasDiffs", "sameDims", "sameVals", "Table.Name") +# df_status <- df_status |> arrange_at(c(arrange0)) +# saveList[[c_config0]] <- df_status +# rm(arrange0) +# +# +# ###### Create Workbook ###### +# ### Create workbook if(save) +# ### Add worksheet with test info +# if(save){ +# wbook0 <- createWorkbook() +# sheet0 <- c_config0 +# wbook0 |> addWorksheet(sheetName = sheet0) +# wbook0 |> writeDataTable(sheet = sheet0, x = df_status) +# rm(sheet0) +# } ### End if(save) +# +# +# ###### Print Test Results ###### +# ### Filter to tables with differences and add to list and workbook +# df_diff <- df_status |> filter(hasDiffs == 1) +# saveList[[c_diff0]] <- df_diff +# # df_diff |> glimpse() +# +# ### Iterate over names of tables with differences: +# ### - Add tables with differences to list +# ### - Write tables with differences to xlsx workbook +# names0 <- df_diff[["Table.Name"]] +# names0 |> walk(function( +# name_i, +# new0=newData[[name_i]], +# ref0=refData[[name_i]] +# ){ +# ### Worksheet/list name +# sheet0 <- name_i |> paste("diff", sep="_") +# +# ### Get difference +# join0 <- new0 |> names() |> (function(y, z=ref0){y[(y %in% names(z))]})() +# diff0 <- new0 |> anti_join(ref0, by=c(join0)) +# rm(join0) +# +# ### Add table to list +# saveList[[sheet0]] <- diff0 +# +# ### Add worksheet and write data table if(save) +# if(save) { +# wbook0 |> addWorksheet(sheetName = sheet0) +# wbook0 |> writeDataTable(sheet = sheet0, diff0) +# } ### End if(save) +# }) ### End function(name_i), end walk +# +# +# ###### Save Workbook ###### +# if(save){ +# "Saving new sector results" |> paste0("...") |> message() +# wbook0 |> saveWorkbook(file=outFile, overwrite=overwrite) +# rm(wbook0) +# } ### End if(save) +# +# +# ###### Return ###### +# if(return) return(saveList) +# } ### End function diff --git a/R/configTests_utils.R b/R/configTests_utils.R index 9f0d382..82366e2 100644 --- a/R/configTests_utils.R +++ b/R/configTests_utils.R @@ -15,13 +15,6 @@ fun_nCol <- function( ### Get numbers of columns or length of object nCol0 <- obj0 |> ncol() |> (function(x){(x |> is.null()) |> ifelse(NA, x)})() nCol0 <- case_when(do_df0 ~ nCol0, .default=obj0 |> length()) - # # val2 <- val2 |> is.null() |> ifelse(val3, val2) - # # val3 <- 0 |> as.integer() - # val3 <- NA - # # val1 |> print(); val2 |> print(); val3 |> print() - # ### Value to return - # y <- do_df0 |> if_else(true=val2, false=val3) - # return(y) return(nCol0) } ### End fun_nCol @@ -35,23 +28,11 @@ fun_nRow <- function(z, a, b){ ### Check if data frame or list do_df0 <- "data.frame" %in% class0 ### Get numbers of rows or length of object - nRow0 <- obj0 |> ncol() |> (function(x){(x |> is.null()) |> ifelse(NA, x)})() + nRow0 <- obj0 |> nrow() |> (function(x){(x |> is.null()) |> ifelse(NA, x)})() nRow0 <- case_when(do_df0 ~ nRow0, .default=obj0 |> length()) return(nRow0) } ### End fun_nRow -# fun_nRow <- function(z, a, b){ -# # z |> print() -# ### Check if data frame -# do_df0 <- "data.frame" %in% a[[z]] -# val2 <- b[[z]] |> nrow() -# val3 <- b[[z]] |> length() -# val2 <- val2 |> is.null() |> ifelse(val3, val2) -# # val1 |> print(); val2 |> print(); val3 |> print() -# y <- do_df0 |> if_else(true=val2, false=val3) -# return(y) -# } ### End fun_nRow - ### Calculating distinct rows or values fun_nUnq <- function(z, a, b){ ### Get values @@ -67,34 +48,8 @@ fun_nUnq <- function(z, a, b){ else {nUnq0 <- obj0 |> unique () |> length()} return(nUnq0) } ### End fun_nUnq -# fun_nUnq <- function(z, a, b){ -# ### Objects -# class_z <- a[[z]] -# obj_z <- b[[z]] -# do_df0 <- "data.frame" %in% class_z -# ### Values -# val1 <- do_df0 -# ### What to do for data frames -# if(do_df0) {val2 <- obj_z |> distinct() |> nrow()} -# else {val2 <- obj_z |> unique() |> length()} -# # val1 |> print(); val2 |> print(); val3 |> print() -# val3 <- val2 -# y <- if_else(val1, true=val2, false=val3) -# return(y) -# } ### End fun_nUnq ### Calculating columns with all NA vales -# fun_nNna <- function(z, a, b){ -# ### Values -# val1 <- "data.frame" %in% a[[z]] -# ### What to do for data frames -# if(val1) {val2 <- b[[z]] |> has_nonNA_values_df() } -# else {val2 <- b[[z]] |> has_nonNA_values_misc()} -# ### Other values -# val3 <- val2 -# y <- if_else(val1, val2, val3) -# return(y) -# } ### End fun_nNna fun_allNA <- function(z, a, b){ ### Get values name0 <- z @@ -111,22 +66,6 @@ fun_allNA <- function(z, a, b){ ### Function to check if column has at least one non NA value -# has_nonNA_values_df <- function(df0) { -# ### Calculate number of rows -# df1 <- tibble(numRows = df0 |> nrow()) -# ### Check whether values in x are NA -# df0 <- df0 |> is.na() -# ### Number of NA values -# df1 <- df1 |> mutate(numNA = df0 |> colSums() |> nrow() |> is.null() |> if_else(0, 1)) -# ### Whether all results are missing -# df1 <- df1 |> mutate(allNA = (numRows == numNA)) -# ### Filter to values with allNA -# df1 <- df1 |> filter(allNA) -# ### Get number of rows %>% -# nNonNA <- df1 |> nrow() -# ### Return -# return( ) -# } ### End has_nonNA_values_df has_allNA_values_df <- function(df0) { ### Calculate number of rows nRow <- df0 |> nrow() @@ -180,47 +119,14 @@ has_allNA_values_misc <- function(b, a) { ### Return return(allNA) } ### End has_nonNA_values_misc -# has_nonNA_values_misc <- function(b, a) { -# ### Get values -# name0 <- z -# class0 <- a -# obj0 <- b -# ### Check if list -# len0 <- obj0 |> length() -# if(isList0) { -# names_x <- x |> names() -# hasNames_x <- !(names_x |> is.null()) -# if(hasNames_x) {y <- names_x |> map(~ x[[.]] |> class()) |> unlist()} -# else {y <- x |> map(~ . |> class()) |> unlist()} -# skip_y <- ("function" %in% y) | ("list" %in% y) -# # skip_y |> print() -# ### If y has functions -# if(skip_y) {y <- FALSE} -# else { -# y0 <- x |> map(~ . |> unlist() |> is.na()) |> unlist() -# # y0 |> head |> print() -# y0 <- y0 |> all(na.rm=TRUE) -# y1 <- x |> map(~ .y |> length()) |> unlist() -# y <- y0 & (y1 > 1) -# } ### End else(skip_y) -# } ### End if(isList0) -# else {y <- x |> is.na() |> all(na.rm=TRUE)} -# ### Which observations -# which_x <- y |> which() -# ### Count NA values -# z <- y |> which() |> length() -# ### Return -# return(z) -# } ### End has_nonNA_values_misc ### Get region plot info (for scaled impact plots) get_region_plotInfo <- function( - df0, ### Data + df0, ### Data yCol = "scaled_impacts", - # byState = FALSE, # groupCols = c("sector", "variant", "impactType", "impactYear", "region", "model"), groupCols = c("sector", "variant", "impactType", "impactYear", "region", "state", "postal", "model", "maxUnitValue"), nCol = 4, @@ -233,15 +139,6 @@ get_region_plotInfo <- function( # fun_limitsByGroup <- utils::getFromNamespace("fun_limitsByGroup", "FrEDI") # get_column_values <- utils::getFromNamespace("get_column_values", "FrEDI") - ###### Grouping Columns ###### - ### Add state to grouping - # if(byState){ - # group0 <- c("state", "postal", "model") - # groupCols <- groupCols |> (function(x){x[!(x %in% group0)]}) - # groupCols <- groupCols |> c(group0) - # rm(group0) - # } ### End if(byType) - # groupCols |> print() ###### Get Value Ranges ###### # df0 |> glimpse() df_sectorInfo <- df0 |> fun_limitsByGroup( @@ -283,21 +180,21 @@ get_region_plotInfo <- function( ###### Get Value Lists & Lengths ###### ### Get number of sectors and calculate columns - doSectors <- "sector" %in% groupCols - doVariants <- "variant" %in% groupCols - doTypes <- "impactType" %in% groupCols - doYears <- "impactYear" %in% groupCols - doRegions <- "region" %in% groupCols - doStates <- "state" %in% groupCols + # doSectors <- "sector" %in% groupCols + # doVariants <- "variant" %in% groupCols + # doTypes <- "impactType" %in% groupCols + # doYears <- "impactYear" %in% groupCols + # doRegions <- "region" %in% groupCols + # doStates <- "state" %in% groupCols + # doModels <- "model" %in% groupCols # cCols <- c("sector", "variant", "impactType", "impactYear", "region") cCols <- groupCols[!(groupCols %in% c("postal"))] df_iter <- tibble(column = cCols) - df_iter <- df_iter |> - mutate(colSuffix = case_when( + df_iter <- df_iter |> mutate(colSuffix = case_when( column == "impactType" ~ "ImpTypes", column == "impactYear" ~ "ImpYears", .default = column |> str_to_title() |> paste0("s") - )) + )) ### End mutate df_iter <- df_iter |> mutate(cName = "c" |> paste0(colSuffix)) df_iter <- df_iter |> mutate(nName = "n" |> paste0(colSuffix)) df_iter <- df_iter |> mutate(factorCol = column |> paste0("_factor")) @@ -305,10 +202,10 @@ get_region_plotInfo <- function( ### Iterate over iteration column for(i in df_iter |> row_number()){ fCol_i <- df_iter[["factorCol"]][i] - cName_i <- df_iter[["cName"]][i] - nName_i <- df_iter[["nName"]][i] + cName_i <- df_iter[["cName" ]][i] + nName_i <- df_iter[["nName" ]][i] # fCol_i |> print(); cName_i |> print(); nName_i |> print(); - list0[[cName_i]] <- df_sectorInfo[[fCol_i]] |> levels() |> as.character() + list0[[cName_i]] <- df_sectorInfo |> pull(all_of(fCol_i)) |> levels() |> as.character() list0[[nName_i]] <- list0[[cName_i]] |> length() # list0[[cName_i]] |> print() rm(i, fCol_i, cName_i, nName_i) @@ -358,714 +255,17 @@ get_region_plotInfo <- function( ###### Return List ###### ### Return list - list0 <- list(df_iter = df_iter ) |> c(list0) - list0 <- list(minMax = df_minMax ) |> c(list0) - list0 <- list(sectorInfo = df_sectorInfo) |> c(list0) + list0[["df_iter" ]] <- df_iter + list0[["minMax" ]] <- df_minMax + list0[["sectorInfo"]] <- df_sectorInfo ### Return return(list0) } -### This function plots degrees of warming by sector, variant, impact year, and type -create_scaledImpact_plot <- function( - data, - sector0, - impType0, - impYear0, - region0, ### Region or state - # byState = FALSE, - infoList0, ### Dataframe with sector info...output from get_region_plotInfo - xCol = "driverValue", ### X-Column, - yCol = "scaled_impacts", ### Y-Column, - colorCol = "model", - xInfo = NULL , ### xScale...outputs of get_colScale - refPlot = FALSE, ### Whether to do a ref plot - nTicks = 5, - silent = TRUE, - options = list( - # title = "Impacts by Degrees of Warming", - # subtitle = NULL, - xTitle = expression("Degrees of Warming (°C)"), - yTitle = "Scaled Impacts", - lgdTitle = "Model", - margins = c(0, 0, .15, 0), - marginUnit = "cm", - theme = NULL - ) -){ - ###### Messaging ###### - print_msg <- !silent - if(print_msg){ "Running create_scaledImpact_plot()..." |> message()} - - ###### Get from FrEDI Namespace ###### - # get_colScale <- utils::getFromNamespace("get_colScale", "FrEDI") - - ###### Data ###### - df0 <- data |> filter(sector == sector0) - df0 <- df0 |> filter(impactType == impType0) - df0 <- df0 |> filter(impactYear == impYear0) - type0 <- df0[["model_type"]] |> unique() - # df0 |> glimpse() - - ###### By State ###### - byState <- df0[["state"]] |> unique() |> (function(x){!("N/A" %in% x)})() - stateCols <- c("state", "postal") - if(byState){df0 <- df0 |> filter(region == region0)} - - ###### Model Types ###### - # type0 %>% print - do_gcm <- "gcm" %in% (type0 |> tolower()) - do_slr <- "slr" %in% (type0 |> tolower()) - - ###### Sector Info ###### - info0 <- infoList0[["sectorInfo"]] |> filter(sector==sector0) - index0 <- info0[["sector_order"]][1] - row0 <- info0[["plotRow" ]][1] - col0 <- info0[["plotCol" ]][1] - - ###### Breaks info ###### - ###### ** X Breaks ###### - do_xInfo <- is.null(xInfo) - if(do_xInfo){ - if(xCol == "year"){ - x_limits <- c(2000, 2100) - x_breaks <- seq(x_limits[1] - 10, x_limits[2] + 10, by = 20) - x_denom <- 1 - } ### End if(xCol == "year") - else { - x_limits <- c(-1, 11) - x_breaks <- seq(0, 10, by=2) - x_denom <- 1 - } ### End else(xCol == "year") - } ### End if(do_xInfo) - else{ - x_scale <- xInfo[["scale" ]] - x_p10 <- xInfo[["p10" ]] - x_denom <- xInfo[["denom" ]] - x_breaks <- xInfo[["breaks"]] - x_limits <- xInfo[["limits"]] - } - ###### ** Y-Breaks ###### - y_info <- infoList0[["minMax"]] |> filter(plotRow == row0) - y_info <- y_info |> mutate(sector=sector0) - y_info <- y_info |> get_colScale(col0="summary_value", nTicks=nTicks) - ### Additional info - y_scale <- y_info[["scale" ]] - # y_scale |> names() |> print() - y_p10 <- y_info[["p10" ]] - y_denom <- y_info[["denom" ]] - y_breaks <- y_info[["breaks"]] - y_limits <- y_info[["limits"]] - y_label <- y_info[["label" ]] - ### Labeling - y_prelabel <- (y_label == "") |> ifelse("", ", ") - # y_label <- "" |> paste0("(", y_label, y_prelabel, ")") - y_label <- (y_label=="") |> ifelse("Scaled Impacts", paste0("(", y_label, ")")) - # y_p10 |> print(); y_denom |> print(); y_breaks |> print() - - ###### Mutate Data ###### - # "got here" |> print(); x_denom |> print(); y_denom |> print() - df0[[xCol]] <- df0[[xCol]] / x_denom - df0[[yCol]] <- df0[[yCol]] / y_denom - - - # ###### Plot Options ###### - ###### Defaults ###### - ### Defaults - # def_titles <- list(GCM="Scaled Impacts by Degrees of Warming", SLR="Scaled Impacts by GMSL (cm)") - # def_xTitles <- list(GCM=expression("Degrees of Warming (°C)") , SLR="GMSL (cm)") - # def_lgdLbls <- list(GCM="Region", SLR="Year") - def_titles <- list(GCM="Scaled Impacts by Degrees of Warming", SLR="Scaled Impacts by Year") - def_xTitles <- list(GCM=expression("Degrees of Warming (°C)") , SLR="Year") - def_lgdLbls <- list(GCM="Region", SLR="Region") - def_margins <- list(GCM=c(0, 0, .15, 0), SLR=c(0, .2, .15, 0)) - ### Values - title0 <- options[["title" ]] - xTitle <- options[["xTitle" ]] - yTitle <- options[["yTitle" ]] - lgdLbl <- options[["lgdTitle" ]] - lgdPos <- options[["lgdPos" ]] - heights <- options[["heights" ]] - margins <- options[["margins" ]] - mUnit <- options[["marginUnit"]] - theme0 <- options[["theme" ]] - ### Plot options - hasTitle <- !(is.null(title0 )) - hasXTitle <- !(is.null(xTitle )) - hasYTitle <- !(is.null(yTitle )) - hasLgdLbl <- !(is.null(lgdLbl )) - hasLgdPos <- !(is.null(lgdPos )) - hasHeights <- !(is.null(heights )) - hasMargins <- !(is.null(margins )) - hasMUnits <- !(is.null(mUnit )) - hasTheme <- !(is.null(theme0 )) - ### Defaults: Default Heights Below - def_title <- do_gcm |> ifelse(def_titles [["GCM"]], def_titles [["SLR"]]) - def_xTitle <- do_gcm |> ifelse(def_xTitles[["GCM"]], def_xTitles[["SLR"]]) - def_margin <- do_gcm |> ifelse(def_margins[["GCM"]], def_margins[["SLR"]]) - def_lgdLbl <- do_gcm |> ifelse(def_lgdLbls[["GCM"]], def_lgdLbls[["SLR"]]) - def_lgdPos <- "top" - def_yTitle <- "Scaled Impacts" - def_mUnit <- "cm" - def_theme <- NULL - ### Values: Height Values Below - if(!hasTitle ){title0 <- def_title } - if(!hasXTitle ){xTitle <- def_xTitle} - if(!hasYTitle ){yTitle <- def_yTitle} - if(!hasLgdLbl ){lgdLbl <- def_lgdLbl} - if(!hasMargins){margins <- def_margin} - if(!hasMUnits ){mUnit <- def_mUnit } - if(!hasTheme ){theme0 <- def_theme } - # xTitle |> print() - ###### Standardize column names ###### - # title0 <- byState |> ifelse(state0, region0) - title0 <- "Region: " |> paste0(region0) - - ###### Create the plot ###### - # colorCol |> print(); def_lgdLbl |> print() - # plot0 <- df0 |> ggplot(aes(x=.data[[xCol]], y=.data[[yCol]], color=.data[[colorCol]])) - ### Group values - groups0 <- c("sector", "variant", "impactType", "impactYear", "region", "model", "maxUnitValue", xCol) - facetCol <- byState |> ifelse("state", "region") - if(byState){groups0 <- groups0 |> c("state")} - df0 <- df0 |> group_by_at(c(groups0)) - rm(groups0) - - ### Points dataframe - if(do_slr){df_points0 <- df0 |> filter(year %in% x_breaks)} - else {df_points0 <- df0} - - ###### ** Initialize plot - ### Initialize plot - plot0 <- ggplot() - - ### Check if the plot needs to be made - allNA <- df0[[yCol]] |> is.na() |> all() - doPlot <- !allNA - if(doPlot){ - ### Determine the columns to use - if(byState) {regCol0 <- c("state" ); stateCol0 <- c("state")} - else {regCol0 <- c("region"); stateCol0 <- c()} - group0 <- c("sector", "variant", "impactType", "impactYear", "region") |> c(stateCol0) |> c("model") - - ###### ** Add geoms - if(do_slr){ - ### Factor model - # lvls0 <- df0[["driverValue"]] |> unique() |> sort(decreasing = T) - # lvls0 <- lvls0 |> paste("cm") - # df0 <- df0 |> mutate(model = model |> factor(levels = lvls0)) - # rm(lvls0) - ### Points data - plot0 <- df0 |> ggplot() - plot0 <- plot0 + geom_line( - data = df0, - aes( - x = .data[[xCol]], - y = .data[[yCol]], - color = .data[[regCol0]], - group = interaction(!!!syms(group0)), - linetype = .data[["variant"]] - ), ### End aes - alpha = 0.65 - ) ### End geom_line - - ### Add points - plot0 <- plot0 + geom_point( - data = df_points0, - aes( - x = .data[[xCol]], - y = .data[[yCol]], - color = .data[[regCol0]], - # group = interaction(!!!syms(group0)) - group = interaction(!!!syms(group0)), - shape = .data[["variant"]] - ), ### End aes - alpha = 0.65 - ) ### End geom_point - # rm(df0_2) - } else{ - ### Separate GCM values - ### Plot these values as lines - df0_1 <- df0 |> filter((maxUnitValue < 6 & driverValue <= maxUnitValue) | maxUnitValue >=6) - ### Plot these values as points - df0_2 <- df0 |> filter((maxUnitValue < 6 & driverValue >= maxUnitValue)) - ### Plot values as lines - plot0 <- plot0 + geom_line( - data = df0_1, - aes( - x = .data[[xCol]], - y = .data[[yCol]], - color = .data[[regCol0]], - group = interaction(!!!syms(group0)), - linetype = .data[["variant"]] - ), ### End aes - alpha = 0.65 - ) ### End geom_line - ### Plot values as points - plot0 <- plot0 + geom_point( - data = df0_2, - aes( - x = .data[[xCol]], - y = .data[[yCol]], - color = .data[[regCol0]], - # group = interaction(!!!syms(group0)) - group = interaction(!!!syms(group0)), - shape = .data[["variant"]] - ), ### End aes - alpha=0.65 - ) ### End geom_line - } - - ###### * Add geoms - # plot0 <- plot0 + geom_line(aes(linetype = .data[["variant"]]), alpha=0.5) - - ###### ** Add facet_grid - plot0 <- plot0 + facet_grid(model~.data[[regCol0]]) - # plot0 |> print() - - ###### ** Adjust legend title - if(hasLgdPos){plot0 <- plot0 + guides(color = guide_legend(title.position = lgdPos))} - plot0 <- plot0 + theme(legend.direction = "vertical", legend.box = "vertical") - - ###### ** Add and title - plot0 <- plot0 + ggtitle(title0) - - ###### ** Add scales - plot0 <- plot0 + scale_x_continuous(xTitle, breaks=x_breaks, limits=x_limits) - plot0 <- plot0 + scale_y_continuous(y_label) - plot0 <- plot0 + scale_linetype_discrete("Variant") - plot0 <- plot0 + scale_shape_discrete("Variant") - plot0 <- plot0 + scale_color_discrete("Region") - - } ### End if(doPlot) - - ###### ** Adjust appearance ###### - plot0 <- plot0 + theme(plot.title = element_text(hjust = 0.5, size=11)) - plot0 <- plot0 + theme(plot.subtitle = element_text(hjust = 0.5, size=10)) - plot0 <- plot0 + theme(axis.title.x = element_text(hjust = 0.5, size=9)) - plot0 <- plot0 + theme(axis.title.y = element_text(hjust = 0.5, size=9)) - plot0 <- plot0 + theme(legend.position = "bottom") - if(do_slr){plot0 <- plot0 + theme(axis.text.x = element_text(angle=90))} - - ###### Control Guides - plot0 <- plot0 + theme(legend.position = "bottom") - - ###### ** Add themes & margins ###### - ### Theme - if(hasTheme ){ - if(theme=="bw"){plot0 <- plot0 + theme_bw()} - else {plot0 <- plot0 + theme0} - } ### End if(hasTheme ) - ### Margins - if(hasMargins){ - plot0 <- plot0 + theme(plot.margin = margin( - t = margins[1], # Top margin - r = margins[2], # Right margin - b = margins[3], # Bottom margin - l = margins[4], # Left margin - unit = mUnit - )) - } ### End if(hasMargins) - - ###### Format Legend ###### - ### Add guide to legend - nLgdCols <- 7 - # nLgdCols <- nRegions - # nLgdCols |> print() - plot0 <- plot0 + guides(linetype = guide_legend(ncol=nLgdCols, order = 1)) - plot0 <- plot0 + guides(color = guide_legend(ncol=nLgdCols, order = 2)) - plot0 <- plot0 + theme(legend.box.just = "left") - plot0 <- plot0 + theme(legend.box = "vertical") - # plot0 <- plot0 + theme(legend.direction = "vertical") - plot0 <- plot0 + theme(legend.position = "bottom") - plot0 <- plot0 + theme(legend.title = element_text(size=10)) - plot0 <- plot0 + theme(legend.text = element_text(size=9 )) - plot0 <- plot0 + theme(legend.spacing.y = unit(0.05, "cm")) - # refPlot0 <- refPlot0 + theme(legend.box.margin = margin(t=0.05, r=0.05, b=0.05, l=0.05, unit='cm')) - - - ###### Return ###### - ### Return the plot - if(print_msg){ message("...Finished.")} - return(plot0) -} -### This function plots degrees of warming by sector, variant, impact year, and type -create_scaledImpact_plots <- function( - data, - sector, - xCol = "driverValue", - yCol = "scaled_impacts", - colorCol = "model", - modelType = "GCM", - # byState = FALSE, - nTicks = 5, - silent = TRUE, - options = list( - # title = "Scaled Impacts by Degrees of Warming", - # subtitle = NULL, - xTitle = expression("Degrees of Warming (°C)"), - yTitle = "Scaled Impacts", - lgdTitle = "Model", - nameBreak = 18, ### Sector name break - margins = c(0, 0, .15, 0), - marginUnit = "cm", - theme = NULL - ) -){ - ###### Messaging ###### - print_msg <- !silent - if(print_msg){ "Running create_scaledImpact_plots()..." |> message()} - ### Model Type - # modelType %>% print() - do_gcm <- "gcm" %in% (modelType |> tolower()) - do_slr <- "slr" %in% (modelType |> tolower()) - # modelType |> print(); do_gcm |> print(); do_slr |> print() - - ###### Get from FrEDI Namespace ###### - # get_colScale <- utils::getFromNamespace("get_colScale", "FrEDI") - - ###### Format Data ###### - ### Filter to sector and convert to data frame - # data |> glimpse() - # data[["sector"]] |> unique() |> print(); modelType |> print() - sector0 <- sector; rm(sector) - df0 <- data ; rm(data ) - df0 <- df0 |> filter(model_type == modelType) - df0 <- df0 |> filter(sector == sector0 ) - # df0 |> glimpse() - - ###### By State ###### - byState <- df0[["state"]] |> unique() |> (function(x){!("N/A" %in% x)})() - stateCols <- c("state", "postal") - # if(byState){stateCols <- c("state", "postal")} else{stateCols <- c()} - - ###### Plot Options ###### - ### Defaults - # def_titles <- list(GCM="Scaled Impacts by Degrees of Warming", SLR="Scaled Impacts by GMSL (cm)") - # def_xTitles <- list(GCM=expression("Degrees of Warming (°C)") , SLR="GMSL (cm)") - def_titles <- list(GCM="Scaled Impacts by Degrees of Warming", SLR="Scaled Impacts by Year") - def_xTitles <- list(GCM=expression("Degrees of Warming (°C)") , SLR="Year") - def_lgdLbls <- list(GCM="Model", SLR="Scenario") - def_margins <- list(GCM=c(0, 0, .15, 0), SLR=c(0, .2, .15, 0)) - ### Defaults: Default Heights Below - def_title <- do_gcm |> ifelse(def_titles [["GCM"]], def_titles [["SLR"]]) - def_xTitle <- do_gcm |> ifelse(def_xTitles[["GCM"]], def_xTitles[["SLR"]]) - def_margin <- do_gcm |> ifelse(def_margins[["GCM"]], def_margins[["SLR"]]) - def_lgdLbl <- do_gcm |> ifelse(def_lgdLbls[["GCM"]], def_lgdLbls[["SLR"]]) - # def_colCol <- "model" - def_lgdPos <- "top" - def_yTitle <- "Scaled Impacts" - def_mUnit <- "cm" - def_theme <- NULL - def_nameBrk <- 18 - ### Values - title0 <- options[["title" ]] - xTitle <- options[["xTitle" ]] - yTitle <- options[["yTitle" ]] - lgdLbl <- options[["lgdTitle" ]] - lgdPos <- options[["lgdPos" ]] - heights <- options[["heights" ]] - margins <- options[["margins" ]] - mUnit <- options[["marginUnit"]] - theme0 <- options[["theme" ]] - nameBrk <- options[["nameBreak" ]] - # xTitle |> print() - ### Plot options - hasTitle <- !(is.null(title0 )) - hasXTitle <- !(is.null(xTitle )) - hasYTitle <- !(is.null(yTitle )) - hasLgdLbl <- !(is.null(lgdLbl )) - hasLgdPos <- !(is.null(lgdPos )) - hasHeights <- !(is.null(heights)) - hasMargins <- !(is.null(margins)) - hasMUnits <- !(is.null(mUnit )) - hasTheme <- !(is.null(theme0 )) - hasNameBrk <- !(is.null(nameBrk)) - ### Values: Height Values Below - if(!hasTitle ){title0 <- def_title } - if(!hasXTitle ){xTitle <- def_xTitle } - if(!hasYTitle ){yTitle <- def_yTitle } - if(!hasLgdLbl ){lgdLbl <- def_lgdLbl } - if(!hasMargins){margins <- def_margin } - if(!hasMUnits ){mUnit <- def_mUnit } - if(!hasTheme ){theme0 <- def_theme } - if(!hasNameBrk){nameBrk <- def_nameBrk} - # title0 |> print(); def_xTitle |> print() - # xTitle |> print() - ### Update plot options - plotOpts0 <- list( - title = title0, - xTitle = xTitle, - yTitle = yTitle, - lgdTitle = lgdLbl, - margins = margins, - marginUnit = mUnit, - theme = theme0 - ) - - ###### Get Sector Info ###### - # infoList0 <- df0 |> get_region_plotInfo(yCol=yCol, byState=byState, silent=silent) - infoList0 <- df0 |> get_region_plotInfo(yCol=yCol, silent=silent) - df_info <- infoList0[["sectorInfo"]] - df_minMax <- infoList0[["minMax" ]] - df_iter <- infoList0[["df_iter" ]] - nCol <- infoList0[["nCol" ]] - nRow <- infoList0[["nRow" ]] - # nCol |> c(nRow) |> print() - ### Unique values - cSectors <- infoList0[["cSectors" ]] - cVariants <- infoList0[["cVariants"]] - cImpTypes <- infoList0[["cImpTypes"]] - cImpYears <- infoList0[["cImpYears"]] - cRegions <- infoList0[["cRegions" ]] - cStates <- infoList0[["cStates" ]] - ### Numbers - nSectors <- cSectors |> length() - nVariants <- cVariants |> length() - nImpTypes <- cImpTypes |> length() - nImpYears <- cImpYears |> length() - # nRegions <- cRegions |> length() - nStates <- cStates |> length() - # cSectors |> print(); cVariants |> print(); cImpTypes |> print(); cImpYears |> print(); cStates |> head() |> print(); cModels |> print(); - # c(nSectors, nVariants, nImpTypes, nImpYears, nRegions, nModels, nStates) |> print() - - ### Add maxUnitValue to df_iter - # join0 <- c("sector", "variant", "impactType", "impactYear", "region") |> c(stateCols) |> c("model") - # df_iter - - ###### Drop Data ###### - ### Join iteration with data and drop models - # join0 <- c("sector", "variant", "impactType", "impactYear", "region") |> c(stateCols) |> c("model") - join0 <- c("sector", "variant", "impactType", "impactYear", "region") |> c(stateCols) |> c("model") - join0 <- join0 |> c("maxUnitValue") - # if(byState){join0 <- join0 |> c("state", "postal")} - df0 <- df0 |> left_join(df_info, by=c(join0)) - df0 <- df0 |> filter(!is.na(nObs)) - # cModels <- df0[["model" ]] |> unique() - # cRegions <- df0[["region"]] |> unique() - cModels <- df_info[["model" ]] |> unique() - cRegions <- df_info[["region"]] |> unique() - nModels <- cModels |> length() - nRegions <- cRegions |> length() - rm(join0) - # nRegions |> print() - # df0[["region"]] |> unique() |> print() - # df0 <- df0 |> filter(sector %in% cSectors) - # df0 <- df0 |> filter(variant %in% cVariants) - # df0 <- df0 |> filter(impactType %in% cImpTypes) - # df0 <- df0 |> filter(impactYear %in% cImpYears) - df0 <- df0 |> filter(region %in% cRegions) - # df0 <- df0 |> filter(model %in% cModels) - - - ###### Factor Model ###### - for(i in df_iter |> row_number()){ - col_i <- df_iter[["column"]][i] - cCol_i <- df_iter[["cName" ]][i] - levels_i <- infoList0[[cCol_i]] - df0 <- df0 |> mutate_at(c(col_i), factor, levels=levels_i) - rm(i, col_i, cCol_i, levels_i) - } ### End for(i in df_iter |> row_number()) - - ### Factor models - if(do_slr){ - labs0 <- c(30, 50, 100, 150, 200, 250) |> paste0(" cm") - # lvls0 <- 1:(labs0 |> length()) - df0 <- df0 |> mutate(model = model |> factor(levels=labs0)) - } ### End if(do_slr) - - - ### Convert maxUnitValue to numeric - df0 <- df0 |> mutate_at(c("maxUnitValue"), as.character) - df0 <- df0 |> mutate_at(c("maxUnitValue"), as.numeric ) - - ###### Plot Title Info ###### - ### Default for now - # x_denom <- y_denom <- 1 - - ###### ** X Breaks ###### - if(xCol == "year"){ - x_limits <- c(2000, 2100) - x_breaks <- seq(x_limits[1] - 10, x_limits[2] + 10, by = 20) - x_denom <- 1 - x_info <- NULL - # x_info <- list() - # x_info[["denom" ]] <- x_denom - # x_info[["breaks"]] <- x_breaks - # x_info[["limits"]] <- x_limits - } ### End if(xCol == "year") - else { - x_limits <- c(-1, 11) - x_breaks <- seq(0, 10, by=2) - x_denom <- 1 - x_info <- NULL - } ### End else(xCol == "year") - - ###### ** Y-Breaks ###### - y_info <- infoList0[["minMax"]] #|> filter(plotRow == row0) - y_info <- y_info |> mutate(sector=sector0) - y_info <- y_info |> get_colScale(col0="summary_value", nTicks=nTicks) - # y_info <- y_info |> get_colScale(col0="summary_value", nTicks=nTicks) - ### Additional info - y_scale <- y_info[["scale" ]] - # y_scale |> names() |> print() - y_p10 <- y_info[["p10" ]] - y_denom <- y_info[["denom" ]] - y_breaks <- y_info[["breaks"]] - y_limits <- y_info[["limits"]] - y_label <- y_info[["label" ]] - # ### Labeling - y_prelabel <- (y_label == "") |> ifelse("", ", ") - # y_label <- "" |> paste0("(", y_label, y_prelabel, ")") - y_label <- y_label #|> paste0(y_prelabel, "$2015") - y_label <- "Scaled Impacts (" |> paste0(y_label, ")") - # y_p10 |> print(); y_denom |> print(); y_breaks |> print() - - - ###### State vs. Region Options ###### - ### What to iterate over - ### Number of iteration values - if(byState){cIter1 <- cRegions} else{cIter1 <- "All"} ### End else - nIter1 <- cIter1 |> length() - # nIter2 <- cIter2 |> length() - - # ###### Reference Plot ###### - # ### Reference plots - # refPlot0 <- df0 |> create_scaledImpact_plot( - # sector0 = sector0, - # # variant0 = cVariants[1], - # impType0 = cImpTypes[1], - # impYear0 = cImpYears[1], - # region0 = cRegions[1], - # byState = byState, - # infoList0 = infoList0, ### Dataframe with sector info...output from get_region_plotInfo - # xCol = xCol, ### X-Column, - # yCol = yCol, ### Y-Column, - # xInfo = x_info, ### xScale...outputs of get_colScale - # colorCol = colorCol, - # refPlot = TRUE, ### Whether to do a ref plot - # silent = silent, - # options = plotOpts0 - # ) - # # refPlot0 |> print() - # - # ###### Legend & Spacer ##### - # ### Add guide to legend - # # nLgdCols <- 4 - # nLgdCols <- nRegions - # # nLgdCols |> print() - # refPlot0 <- refPlot0 + guides(linetype = guide_legend(ncol=nLgdCols, order = 1)) - # refPlot0 <- refPlot0 + guides(color = guide_legend(ncol=nLgdCols, order = 2)) - # refPlot0 <- refPlot0 + theme(legend.box.just = "left") - # refPlot0 <- refPlot0 + theme(legend.title = element_text(size=10)) - # refPlot0 <- refPlot0 + theme(legend.text = element_text(size=9)) - # refPlot0 <- refPlot0 + theme(legend.spacing.y = unit(0.05, "cm")) - # # refPlot0 <- refPlot0 + theme(legend.box.margin = margin(t=0.05, r=0.05, b=0.05, l=0.05, unit='cm')) - # - # ###### Common Plot Elements ###### - nLgdCols <- nRegions - spacer0 <- ggplot() + theme_void() - # legend0 <- refPlot0 |> ggpubr::get_legend() - # # # "got here..." |> print() - # grobLgd0 <- ggarrange(plotlist=list(legend=legend0)) - - ###### Create Plot List ###### - ### Iterate over Impact Years - # cIter1 |> print() - listIter1 <- cIter1 |> map(function(iter1_i){ - listYears0 <- cImpYears |> map(function(impYear_j){ - listTypes_j <- cImpTypes |> map(function(impType_k){ - # iter1_i |> print(); impYear_j |> print(); impType_k |> print(); - ### Figure out min/max across all variants for an impact type to get the y-scale - region_k <- iter1_i - # "\t\t" |> paste0(c(iter1_i, impYear_j, impType_k, region_k) |> paste(collapse=", ")) |> message() - ###### Create the plot ###### - plot_k <- df0 |> create_scaledImpact_plot( - sector0 = sector0, - impType0 = impType_k, - impYear0 = impYear_j, - region0 = region_k, - # byState = byState, - infoList0 = infoList0, ### Dataframe with sector info...output from get_region_plotInfo - xCol = xCol, ### X-Column, - yCol = yCol, ### Y-Column, - colorCol = colorCol, - xInfo = x_info, ### xScale...outputs of get_colScale - refPlot = FALSE, ### Whether to do a ref plot - silent = silent, - options = plotOpts0 - ) - # plot_k |> print() - - ###### Annotate Plots ###### - ### Labels on top - ### Longest impact type: "Acute Myocardial Infarction" - typeTitle_k <- "Impact Type: " |> paste0(impType_k) - grobType_k <- text_grob(typeTitle_k, face="italic", size=11) - plotGrid_k <- plot_k - plotList_k <- list(spacer1=spacer0, plots=plotGrid_k, spacer2=spacer0) - # plotGrid_k <- ggarrange(plotlist=plotList_k, nrow=3, ncol=1, common.legend=T, legend="none", heights=c(0.01, 1, 0.01)) - # plotGrid_k <- ggarrange(plotlist=plotList_k, nrow=3, ncol=1, common.legend=T, legend="bottom", heights=c(0.01, 1, 0.1)) - plotGrid_k <- ggarrange(plotlist=plotList_k, nrow=3, ncol=1, heights=c(0.01, 1, 0.1)) - plotGrid_k <- plotGrid_k |> annotate_figure(top=grobType_k) - - ### Return - return(plotGrid_k) - }) - - ### Name the plots - # listTypes_j |> length() |> print(); cImpTypes |> print() - listTypes_j <- listTypes_j |> set_names(cImpTypes) - - ### Arrange plot list - # plotGrid_j <- ggarrange(plotlist=listTypes_j, ncol=1, nrow=nRow, common.legend=F, legend="none") - plotGrid_j <- ggarrange(plotlist=listTypes_j, ncol=1, nrow=nRow, common.legend=F) - - ### Add spacer to the top - # "got here2..." |> print() - yearTitle_j <- "Impact Year: " |> paste0(impYear_j) - grobYear_j <- text_grob(yearTitle_j, face="plain", size=13) - plotList_j <- list(spacer1=spacer0, plot=plotGrid_j) - plotGrid_j <- ggarrange(plotlist=plotList_j, nrow=2, ncol=1, common.legend=T, legend="none", heights=c(0.01, 1)) - plotGrid_j <- plotGrid_j |> annotate_figure(top=grobYear_j) - - ### Add Plot Title & Y Title - # plotList_j <- list(spacer1=spacer0, plot=plotGrid_j, spacer2=spacer0, legend=grobLgd0) - # plotList_j <- list(spacer1=spacer0, plot=plotGrid_j, legend=grobLgd0) - plotList_j <- list(spacer1=spacer0, plot=plotGrid_j, spacer2=spacer0) - # nModels |> print() - modMult <- (nModels - 1) %/% nLgdCols + 1 - # plotGrid_j <- ggarrange(plotlist=plotList_j, nrow=4, ncol=1, legend="none", heights=c(0.01, nImpTypes, 0.01, 0.2)) - # plotGrid_j <- ggarrange(plotlist=plotList_j, nrow=4, ncol=1, legend="none", heights=c(0.01, nImpTypes, 0.01, 0.2 * modMult)) - # plotGrid_j <- ggarrange(plotlist=plotList_j, nrow=3, ncol=1, legend="none", heights=c(0.01, nImpTypes, 0.2)) - plotGrid_j <- ggarrange(plotlist=plotList_j, nrow=3, ncol=1, legend="none", heights=c(0.01, nImpTypes, 0.01)) - title0_j <- sector0 - grobTit_j <- text_grob(title0_j, color="black", size = 14, face="bold", hjust=0.5) - plotGrid_j <- plotGrid_j |> annotate_figure(top=grobTit_j) - - plotYTit_j <- text_grob(yTitle, color = "black", rot = 90) - plotList_j <- list(spacer1=spacer0, plot=plotGrid_j, spacer2=spacer0) - plotGrid_j <- ggarrange(plotlist=plotList_j, nrow=1, legend="none", widths=c(0.01, nRegions, 0.01)) - plotGrid_j <- plotGrid_j |> annotate_figure(left=plotYTit_j) - # return(plotGrid_j) - - ###### Return Impact Type Plot ###### - return(plotGrid_j) - }) - ### Name the plots - listYears0 <- listYears0 |> set_names(cImpYears) - return(listYears0) - }) ### End iter1_i - ### Name the plots - listIter1 <- listIter1 |> set_names(cIter1) - - ###### Return ###### - ### Return the plot - if(print_msg) message("Finished.") - return(listIter1) -} + diff --git a/R/create_scaledImpact_plot.R b/R/create_scaledImpact_plot.R new file mode 100644 index 0000000..e225fbc --- /dev/null +++ b/R/create_scaledImpact_plot.R @@ -0,0 +1,318 @@ +### This function plots degrees of warming by sector, variant, impact year, and type +create_scaledImpact_plot <- function( + data, + sector0, + impType0, + impYear0, + region0, ### Region or state + # byState = FALSE, + infoList0, ### Dataframe with sector info...output from get_region_plotInfo + xCol = "driverValue", ### X-Column, + yCol = "scaled_impacts", ### Y-Column, + colorCol = "model", + xInfo = NULL , ### xScale...outputs of get_colScale + refPlot = FALSE, ### Whether to do a ref plot + nTicks = 5, + silent = TRUE, + options = list( + # title = "Impacts by Degrees of Warming", + # subtitle = NULL, + xTitle = expression("Degrees of Warming (°C)"), + yTitle = "Scaled Impacts", + lgdTitle = "Model", + margins = c(0, 0, .15, 0), + marginUnit = "cm", + theme = NULL + ) +){ + ###### Messaging ###### + print_msg <- !silent + if(print_msg){ "Running create_scaledImpact_plot()..." |> message()} + + ###### Get from FrEDI Namespace ###### + # get_colScale <- utils::getFromNamespace("get_colScale", "FrEDI") + + ###### Data ###### + df0 <- data |> filter(sector == sector0) + df0 <- df0 |> filter(impactType == impType0) + df0 <- df0 |> filter(impactYear == impYear0) + type0 <- df0[["modelType"]] |> unique() + # df0 |> glimpse() + + ###### By State ###### + byState <- df0[["state"]] |> unique() |> (function(x){!("N/A" %in% x)})() + stateCols <- c("state", "postal") + if(byState){df0 <- df0 |> filter(region == region0)} + + ###### Model Types ###### + # type0 %>% print + do_gcm <- "gcm" %in% (type0 |> tolower()) + do_slr <- "slr" %in% (type0 |> tolower()) + + ###### Sector Info ###### + info0 <- infoList0[["sectorInfo"]] |> filter(sector==sector0) + index0 <- info0[["sector_order"]][1] + row0 <- info0[["plotRow" ]][1] + col0 <- info0[["plotCol" ]][1] + + ###### Breaks info ###### + ###### ** X Breaks ###### + do_xInfo <- xInfo |> is.null() + if(do_xInfo){ + if(xCol == "year"){ + x_limits <- c(2000, 2100) + x_breaks <- seq(x_limits[1] - 10, x_limits[2] + 10, by = 20) + x_denom <- 1 + } ### End if(xCol == "year") + else { + x_limits <- c(-1, 11) + x_breaks <- seq(0, 10, by=2) + x_denom <- 1 + } ### End else(xCol == "year") + } ### End if(do_xInfo) + else{ + x_scale <- xInfo[["scale" ]] + x_p10 <- xInfo[["p10" ]] + x_denom <- xInfo[["denom" ]] + x_breaks <- xInfo[["breaks"]] + x_limits <- xInfo[["limits"]] + } + ###### ** Y-Breaks ###### + y_info <- infoList0[["minMax"]] |> filter(plotRow == row0) + y_info <- y_info |> mutate(sector=sector0) + y_info <- y_info |> get_colScale(col0="summary_value", nTicks=nTicks) + ### Additional info + y_scale <- y_info[["scale" ]] + # y_scale |> names() |> print() + y_p10 <- y_info[["p10" ]] + y_denom <- y_info[["denom" ]] + y_breaks <- y_info[["breaks"]] + y_limits <- y_info[["limits"]] + y_label <- y_info[["label" ]] + ### Labeling + y_prelabel <- (y_label == "") |> ifelse("", ", ") + y_label <- (y_label=="") |> ifelse("Scaled Impacts", paste0("(", y_label, ")")) + # y_p10 |> print(); y_denom |> print(); y_breaks |> print() + + ###### Mutate Data ###### + # "got here" |> print(); x_denom |> print(); y_denom |> print() + df0[[xCol]] <- df0[[xCol]] / x_denom + df0[[yCol]] <- df0[[yCol]] / y_denom + + + ###### Plot Options ###### + ###### Defaults ###### + ### Defaults + def_titles <- list(GCM="Scaled Impacts by Degrees of Warming", SLR="Scaled Impacts by Year") + def_xTitles <- list(GCM=expression("Degrees of Warming (°C)") , SLR="Year") + def_lgdLbls <- list(GCM="Region", SLR="Region") + def_margins <- list(GCM=c(0, 0, .15, 0), SLR=c(0, .2, .15, 0)) + ### Values + title0 <- options[["title" ]] + xTitle <- options[["xTitle" ]] + yTitle <- options[["yTitle" ]] + lgdLbl <- options[["lgdTitle" ]] + lgdPos <- options[["lgdPos" ]] + heights <- options[["heights" ]] + margins <- options[["margins" ]] + mUnit <- options[["marginUnit"]] + theme0 <- options[["theme" ]] + ### Plot options + hasTitle <- !(is.null(title0 )) + hasXTitle <- !(is.null(xTitle )) + hasYTitle <- !(is.null(yTitle )) + hasLgdLbl <- !(is.null(lgdLbl )) + hasLgdPos <- !(is.null(lgdPos )) + hasHeights <- !(is.null(heights )) + hasMargins <- !(is.null(margins )) + hasMUnits <- !(is.null(mUnit )) + hasTheme <- !(is.null(theme0 )) + ### Defaults: Default Heights Below + def_title <- do_gcm |> ifelse(def_titles [["GCM"]], def_titles [["SLR"]]) + def_xTitle <- do_gcm |> ifelse(def_xTitles[["GCM"]], def_xTitles[["SLR"]]) + def_margin <- do_gcm |> ifelse(def_margins[["GCM"]], def_margins[["SLR"]]) + def_lgdLbl <- do_gcm |> ifelse(def_lgdLbls[["GCM"]], def_lgdLbls[["SLR"]]) + def_lgdPos <- "top" + def_yTitle <- "Scaled Impacts" + def_mUnit <- "cm" + def_theme <- NULL + ### Values: Height Values Below + if(!hasTitle ){title0 <- def_title } + if(!hasXTitle ){xTitle <- def_xTitle} + if(!hasYTitle ){yTitle <- def_yTitle} + if(!hasLgdLbl ){lgdLbl <- def_lgdLbl} + if(!hasMargins){margins <- def_margin} + if(!hasMUnits ){mUnit <- def_mUnit } + if(!hasTheme ){theme0 <- def_theme } + # xTitle |> print() + ###### Standardize column names ###### + title0 <- "Region: " |> paste0(region0) + + ###### Create the plot ###### + ### Group values + # groups0 <- c("sector", "variant", "impactType", "impactYear", "region", "model", "maxUnitValue", xCol) + groups0 <- c("sector", "variant", "impactType", "impactYear", "region", "model", "maxUnitValue") + # xCol |> c(yCol) |> print() + # groups0 <- c("sector", "variant", "impactType", "impactYear", "region", "model", "maxUnitValue") + facetCol <- byState |> ifelse("state", "region") + if(byState){groups0 <- groups0 |> c("state")} + df0 <- df0 |> group_by_at(c(groups0)) + rm(groups0) + + ### Points dataframe + if(do_slr){df_points0 <- df0 |> filter(year %in% x_breaks)} + else {df_points0 <- df0} + + ###### ** Initialize plot + ### Initialize plot + plot0 <- ggplot() + + ### Check if the plot needs to be made + allNA <- df0[[yCol]] |> is.na() |> all() + doPlot <- !allNA + if(doPlot){ + ### Determine the columns to use + if(byState) {regCol0 <- c("state" ); stateCol0 <- c("state")} + else {regCol0 <- c("region"); stateCol0 <- c()} + group0 <- c("sector", "variant", "impactType", "impactYear", "region") |> c(stateCol0) |> c("model") |> unique() + # group0 |> print(); df0 |> glimpse(); xCol |> c(yCol) |> print() + # group0 <- groups0 |> c(stateCol0) |> c("model") |> unique() + ###### ** Add geoms + if(do_slr){ + ### Factor model + # lvls0 <- df0[["driverValue"]] |> unique() |> sort(decreasing = T) + # lvls0 <- lvls0 |> paste("cm") + # df0 <- df0 |> mutate(model = model |> factor(levels = lvls0)) + # rm(lvls0) + ### Points data + plot0 <- df0 |> ggplot() + plot0 <- plot0 + geom_line( + data = df0, + aes( + x = .data[[xCol]], + y = .data[[yCol]], + color = .data[[regCol0]], + linetype = .data[["variant"]], + group = interaction(!!!syms(group0)) + ), ### End aes + alpha = 0.65 + ) ### End geom_line + + ### Add points + plot0 <- plot0 + geom_point( + data = df_points0, + aes( + x = .data[[xCol]], + y = .data[[yCol]], + color = .data[[regCol0]], + shape = .data[["variant"]], + group = interaction(!!!syms(group0)) + ), ### End aes + alpha = 0.65 + ) ### End geom_point + # rm(df0_2) + } else{ + ### Separate GCM values + ### Plot these values as lines + df0_1 <- df0 |> filter((maxUnitValue < 6 & driverValue <= maxUnitValue) | maxUnitValue >=6) + ### Plot these values as points + df0_2 <- df0 |> filter((maxUnitValue < 6 & driverValue >= maxUnitValue)) + ### Plot values as lines + plot0 <- plot0 + geom_line( + data = df0_1, + aes( + x = .data[[xCol]], + y = .data[[yCol]], + color = .data[[regCol0]], + linetype = .data[["variant"]], + group = interaction(!!!syms(group0)) + ), ### End aes + alpha = 0.65 + ) ### End geom_line + ### Plot values as points + plot0 <- plot0 + geom_point( + data = df0_2, + aes( + x = .data[[xCol]], + y = .data[[yCol]], + color = .data[[regCol0]], + shape = .data[["variant"]], + group = interaction(!!!syms(group0)) + ), ### End aes + alpha=0.65 + ) ### End geom_line + } + + ###### * Add geoms + # plot0 <- plot0 + geom_line(aes(linetype = .data[["variant"]]), alpha=0.5) + + ###### ** Add facet_grid + plot0 <- plot0 + facet_grid(model~.data[[regCol0]]) + # plot0 |> print() + + ###### ** Add and title + plot0 <- plot0 + ggtitle(title0) + + ###### ** Add scales + plot0 <- plot0 + scale_x_continuous(xTitle, breaks=x_breaks, limits=x_limits) + plot0 <- plot0 + scale_y_continuous(y_label) + plot0 <- plot0 + scale_color_discrete("Region") + # plot0 <- plot0 + scale_linetype_discrete("Variant") + # plot0 <- plot0 + scale_shape_discrete("Variant") + + ###### ** Adjust legend title + if(hasLgdPos){plot0 <- plot0 + guides(color = guide_legend(title.position = lgdPos))} + plot0 <- plot0 + theme(legend.direction = "vertical", legend.box = "vertical") + + } ### End if(doPlot) + + ###### ** Adjust appearance ###### + plot0 <- plot0 + theme(plot.title = element_text(hjust = 0.5, size=11)) + plot0 <- plot0 + theme(plot.subtitle = element_text(hjust = 0.5, size=10)) + plot0 <- plot0 + theme(axis.title.x = element_text(hjust = 0.5, size=9 )) + plot0 <- plot0 + theme(axis.title.y = element_text(hjust = 0.5, size=9 )) + + if(do_slr){plot0 <- plot0 + theme(axis.text.x = element_text(angle=90))} + + ###### Control Guides + plot0 <- plot0 + theme(legend.position = "bottom") + + ###### ** Add themes & margins ###### + ### Theme + if(hasTheme ){ + if(theme=="bw"){plot0 <- plot0 + theme_bw()} + else {plot0 <- plot0 + theme0} + } ### End if(hasTheme ) + ### Margins + if(hasMargins){ + plot0 <- plot0 + theme(plot.margin = margin( + t = margins[1], # Top margin + r = margins[2], # Right margin + b = margins[3], # Bottom margin + l = margins[4], # Left margin + unit = mUnit + )) + } ### End if(hasMargins) + + ###### Format Legend ###### + ### Add guide to legend + nLgdCols <- 7 + # nLgdCols <- nRegions + # nLgdCols |> print() + plot0 <- plot0 + guides(linetype = guide_legend(ncol=nLgdCols, order = 1)) + plot0 <- plot0 + guides(color = guide_legend(ncol=nLgdCols, order = 2)) + plot0 <- plot0 + theme(legend.box.just = "left") + plot0 <- plot0 + theme(legend.box = "vertical") + # plot0 <- plot0 + theme(legend.direction = "vertical") + plot0 <- plot0 + theme(legend.position = "bottom") + plot0 <- plot0 + theme(legend.title = element_text(size=10)) + plot0 <- plot0 + theme(legend.text = element_text(size=9 )) + plot0 <- plot0 + theme(legend.spacing.y = unit(0.05, "cm")) + # refPlot0 <- refPlot0 + theme(legend.box.margin = margin(t=0.05, r=0.05, b=0.05, l=0.05, unit='cm')) + + + ###### Return ###### + ### Return the plot + if(print_msg){ message("...Finished.")} + return(plot0) +} \ No newline at end of file diff --git a/R/create_scaledImpact_plots.R b/R/create_scaledImpact_plots.R new file mode 100644 index 0000000..7b57b8e --- /dev/null +++ b/R/create_scaledImpact_plots.R @@ -0,0 +1,379 @@ +### This function plots degrees of warming by sector, variant, impact year, and type +create_scaledImpact_plots <- function( + data, + sector, + xCol = "driverValue", + yCol = "scaled_impacts", + colorCol = "model", + type0 = "GCM", + # byState = FALSE, + nTicks = 5, + silent = TRUE, + options = list( + # title = "Scaled Impacts by Degrees of Warming", + # subtitle = NULL, + xTitle = expression("Degrees of Warming (°C)"), + yTitle = "Scaled Impacts", + lgdTitle = "Model", + nameBreak = 18, ### Sector name break + margins = c(0, 0, .15, 0), + marginUnit = "cm", + theme = NULL + ) +){ + ###### Messaging ###### + print_msg <- !silent + if(print_msg){ "Running create_scaledImpact_plots()..." |> message()} + ### Model Type + # type0 %>% print() + do_gcm <- "gcm" %in% (type0 |> tolower()) + do_slr <- "slr" %in% (type0 |> tolower()) + # type0 |> print(); do_gcm |> print(); do_slr |> print() + + ###### Get from FrEDI Namespace ###### + # get_colScale <- utils::getFromNamespace("get_colScale", "FrEDI") + + ###### Format Data ###### + ### Filter to sector and convert to data frame + # data |> glimpse() + # data[["sector"]] |> unique() |> print(); type0 |> print() + sector0 <- sector; rm(sector) + df0 <- data ; rm(data ) + df0 <- df0 |> filter(modelType == type0) + df0 <- df0 |> filter(sector == sector0) + # df0 |> glimpse() + + ###### By State ###### + byState <- df0[["state"]] |> unique() |> (function(x){!("N/A" %in% x)})() + stateCols <- c("state", "postal") + # if(byState){stateCols <- c("state", "postal")} else{stateCols <- c()} + + ###### Plot Options ###### + ### Defaults + # def_titles <- list(GCM="Scaled Impacts by Degrees of Warming", SLR="Scaled Impacts by GMSL (cm)") + # def_xTitles <- list(GCM=expression("Degrees of Warming (°C)") , SLR="GMSL (cm)") + def_titles <- list(GCM="Scaled Impacts by Degrees of Warming", SLR="Scaled Impacts by Year") + def_xTitles <- list(GCM=expression("Degrees of Warming (°C)") , SLR="Year") + def_lgdLbls <- list(GCM="Model", SLR="Scenario") + def_margins <- list(GCM=c(0, 0, .15, 0), SLR=c(0, .2, .15, 0)) + ### Defaults: Default Heights Below + def_title <- do_gcm |> ifelse(def_titles [["GCM"]], def_titles [["SLR"]]) + def_xTitle <- do_gcm |> ifelse(def_xTitles[["GCM"]], def_xTitles[["SLR"]]) + def_margin <- do_gcm |> ifelse(def_margins[["GCM"]], def_margins[["SLR"]]) + def_lgdLbl <- do_gcm |> ifelse(def_lgdLbls[["GCM"]], def_lgdLbls[["SLR"]]) + # def_colCol <- "model" + def_lgdPos <- "top" + def_yTitle <- "Scaled Impacts" + def_mUnit <- "cm" + def_theme <- NULL + def_nameBrk <- 18 + ### Values + title0 <- options[["title" ]] + xTitle <- options[["xTitle" ]] + yTitle <- options[["yTitle" ]] + lgdLbl <- options[["lgdTitle" ]] + lgdPos <- options[["lgdPos" ]] + heights <- options[["heights" ]] + margins <- options[["margins" ]] + mUnit <- options[["marginUnit"]] + theme0 <- options[["theme" ]] + nameBrk <- options[["nameBreak" ]] + # xTitle |> print() + ### Plot options + hasTitle <- !(is.null(title0 )) + hasXTitle <- !(is.null(xTitle )) + hasYTitle <- !(is.null(yTitle )) + hasLgdLbl <- !(is.null(lgdLbl )) + hasLgdPos <- !(is.null(lgdPos )) + hasHeights <- !(is.null(heights)) + hasMargins <- !(is.null(margins)) + hasMUnits <- !(is.null(mUnit )) + hasTheme <- !(is.null(theme0 )) + hasNameBrk <- !(is.null(nameBrk)) + ### Values: Height Values Below + if(!hasTitle ){title0 <- def_title } + if(!hasXTitle ){xTitle <- def_xTitle } + if(!hasYTitle ){yTitle <- def_yTitle } + if(!hasLgdLbl ){lgdLbl <- def_lgdLbl } + if(!hasMargins){margins <- def_margin } + if(!hasMUnits ){mUnit <- def_mUnit } + if(!hasTheme ){theme0 <- def_theme } + if(!hasNameBrk){nameBrk <- def_nameBrk} + # title0 |> print(); def_xTitle |> print() + # xTitle |> print() + ### Update plot options + plotOpts0 <- list( + title = title0, + xTitle = xTitle, + yTitle = yTitle, + lgdTitle = lgdLbl, + margins = margins, + marginUnit = mUnit, + theme = theme0 + ) + + ###### Get Sector Info ###### + # infoList0 <- df0 |> get_region_plotInfo(yCol=yCol, byState=byState, silent=silent) + infoList0 <- df0 |> get_region_plotInfo(yCol=yCol, silent=silent) + df_info <- infoList0[["sectorInfo"]] + df_minMax <- infoList0[["minMax" ]] + df_iter <- infoList0[["df_iter" ]] + nCol <- infoList0[["nCol" ]] + nRow <- infoList0[["nRow" ]] + # nCol |> c(nRow) |> print() + ### Unique values + cSectors <- infoList0[["cSectors" ]] + cVariants <- infoList0[["cVariants"]] + cImpTypes <- infoList0[["cImpTypes"]] + cImpYears <- infoList0[["cImpYears"]] + cRegions <- infoList0[["cRegions" ]] + cStates <- infoList0[["cStates" ]] + ### Numbers + nSectors <- cSectors |> length() + nVariants <- cVariants |> length() + nImpTypes <- cImpTypes |> length() + nImpYears <- cImpYears |> length() + # nRegions <- cRegions |> length() + nStates <- cStates |> length() + # cSectors |> print(); cVariants |> print(); cImpTypes |> print(); cImpYears |> print(); cStates |> head() |> print(); cModels |> print(); + # c(nSectors, nVariants, nImpTypes, nImpYears, nRegions, nModels, nStates) |> print() + + ### Add maxUnitValue to df_iter + # join0 <- c("sector", "variant", "impactType", "impactYear", "region") |> c(stateCols) |> c("model") + # df_iter + + ###### Drop Data ###### + ### Join iteration with data and drop models + # join0 <- c("sector", "variant", "impactType", "impactYear", "region") |> c(stateCols) |> c("model") + join0 <- c("sector", "variant", "impactType", "impactYear", "region") |> c(stateCols) |> c("model") + join0 <- join0 |> c("maxUnitValue") + # if(byState){join0 <- join0 |> c("state", "postal")} + df0 <- df0 |> left_join(df_info, by=c(join0)) + df0 <- df0 |> filter(!(nObs |> is.na())) + # cModels <- df0[["model" ]] |> unique() + # cRegions <- df0[["region"]] |> unique() + cModels <- df_info[["model" ]] |> unique() + cRegions <- df_info[["region"]] |> unique() + nModels <- cModels |> length() + nRegions <- cRegions |> length() + rm(join0) + # nRegions |> print() + # df0[["region"]] |> unique() |> print() + # df0 <- df0 |> filter(sector %in% cSectors) + # df0 <- df0 |> filter(variant %in% cVariants) + # df0 <- df0 |> filter(impactType %in% cImpTypes) + # df0 <- df0 |> filter(impactYear %in% cImpYears) + df0 <- df0 |> filter(region %in% cRegions) + # df0 <- df0 |> filter(model %in% cModels) + + + ###### Factor Model ###### + for(i in df_iter |> row_number()){ + col_i <- df_iter[["column"]][i] + cCol_i <- df_iter[["cName" ]][i] + levels_i <- infoList0[[cCol_i]] + # if(col_i == "model" & do_slr){ + # col_i |> print(); cCol_i |> print(); levels_i |> print();df0 |> pull(all_of(col_i)) |> unique() |> print() + # c(30, 50, 100, 150, 200, 250) |> paste0("cm") + # } ### end if(col_i == "model") + df0 <- df0 |> mutate_at(c(col_i), factor, levels=levels_i) + rm(i, col_i, cCol_i, levels_i) + } ### End for(i in df_iter |> row_number()) + + ### Factor models + if(do_slr){ + # labs0 <- c(30, 50, 100, 150, 200, 250) |> paste0(" cm") + labs0 <- c(30, 50, 100, 150, 200, 250) |> paste0("cm") + # lvls0 <- 1:(labs0 |> length()) + df0 <- df0 |> mutate(model = model |> factor(levels=labs0)) + } ### End if(do_slr) + + + ### Convert maxUnitValue to numeric + df0 <- df0 |> mutate_at(c("maxUnitValue"), as.character) + df0 <- df0 |> mutate_at(c("maxUnitValue"), as.numeric ) + + ###### Plot Title Info ###### + ### Default for now + # x_denom <- y_denom <- 1 + + ###### ** X Breaks ###### + if(xCol == "year"){ + x_limits <- c(2000, 2100) + x_breaks <- seq(x_limits[1] - 10, x_limits[2] + 10, by = 20) + x_denom <- 1 + x_info <- NULL + # x_info <- list() + # x_info[["denom" ]] <- x_denom + # x_info[["breaks"]] <- x_breaks + # x_info[["limits"]] <- x_limits + } ### End if(xCol == "year") + else { + x_limits <- c(-1, 11) + x_breaks <- seq(0, 10, by=2) + x_denom <- 1 + x_info <- NULL + } ### End else(xCol == "year") + + ###### ** Y-Breaks ###### + y_info <- infoList0[["minMax"]] #|> filter(plotRow == row0) + y_info <- y_info |> mutate(sector=sector0) + y_info <- y_info |> get_colScale(col0="summary_value", nTicks=nTicks) + # y_info <- y_info |> get_colScale(col0="summary_value", nTicks=nTicks) + ### Additional info + y_scale <- y_info[["scale" ]] + # y_scale |> names() |> print() + y_p10 <- y_info[["p10" ]] + y_denom <- y_info[["denom" ]] + y_breaks <- y_info[["breaks"]] + y_limits <- y_info[["limits"]] + y_label <- y_info[["label" ]] + # ### Labeling + y_prelabel <- (y_label == "") |> ifelse("", ", ") + # y_label <- "" |> paste0("(", y_label, y_prelabel, ")") + y_label <- y_label #|> paste0(y_prelabel, "$2015") + y_label <- "Scaled Impacts (" |> paste0(y_label, ")") + # y_p10 |> print(); y_denom |> print(); y_breaks |> print() + + + ###### State vs. Region Options ###### + ### What to iterate over + ### Number of iteration values + if(byState){cIter1 <- cRegions} else{cIter1 <- "All"} ### End else + nIter1 <- cIter1 |> length() + # nIter2 <- cIter2 |> length() + + ###### Reference Plot ###### + # ### Reference plots + # refPlot0 <- df0 |> create_scaledImpact_plot( + # sector0 = sector0, + # # variant0 = cVariants[1], + # impType0 = cImpTypes[1], + # impYear0 = cImpYears[1], + # region0 = cRegions[1], + # byState = byState, + # infoList0 = infoList0, ### Dataframe with sector info...output from get_region_plotInfo + # xCol = xCol, ### X-Column, + # yCol = yCol, ### Y-Column, + # xInfo = x_info, ### xScale...outputs of get_colScale + # colorCol = colorCol, + # refPlot = TRUE, ### Whether to do a ref plot + # silent = silent, + # options = plotOpts0 + # ) + # # refPlot0 |> print() + + ###### Legend & Spacer ##### + # ### Add guide to legend + # # nLgdCols <- 4 + # nLgdCols <- nRegions + # # nLgdCols |> print() + # refPlot0 <- refPlot0 + guides(linetype = guide_legend(ncol=nLgdCols, order = 1)) + # refPlot0 <- refPlot0 + guides(color = guide_legend(ncol=nLgdCols, order = 2)) + # refPlot0 <- refPlot0 + theme(legend.box.just = "left") + # refPlot0 <- refPlot0 + theme(legend.title = element_text(size=10)) + # refPlot0 <- refPlot0 + theme(legend.text = element_text(size=9)) + # refPlot0 <- refPlot0 + theme(legend.spacing.y = unit(0.05, "cm")) + # # refPlot0 <- refPlot0 + theme(legend.box.margin = margin(t=0.05, r=0.05, b=0.05, l=0.05, unit='cm')) + + ###### Common Plot Elements ###### + nLgdCols <- nRegions + spacer0 <- ggplot() + theme_void() + # legend0 <- refPlot0 |> ggpubr::get_legend() + # # # "got here..." |> print() + # grobLgd0 <- ggarrange(plotlist=list(legend=legend0)) + + ###### Create Plot List ###### + ### Iterate over Impact Years + # cIter1 |> print() + listIter1 <- cIter1 |> map(function(iter1_i){ + listYears0 <- cImpYears |> map(function(impYear_j){ + listTypes_j <- cImpTypes |> map(function(impType_k){ + # iter1_i |> print(); impYear_j |> print(); impType_k |> print(); + ### Figure out min/max across all variants for an impact type to get the y-scale + region_k <- iter1_i + # region_k |> print + # "\t\t" |> paste0(c(region_k, impYear_j, impType_k) |> paste(collapse=", ")) |> message() + ###### Create the plot ###### + plot_k <- df0 |> create_scaledImpact_plot( + sector0 = sector0, + impType0 = impType_k, + impYear0 = impYear_j, + region0 = region_k, + # byState = byState, + infoList0 = infoList0, ### Dataframe with sector info...output from get_region_plotInfo + xCol = xCol, ### X-Column, + yCol = yCol, ### Y-Column, + colorCol = colorCol, + xInfo = x_info, ### xScale...outputs of get_colScale + refPlot = FALSE, ### Whether to do a ref plot + silent = silent, + options = plotOpts0 + ) + # "got here1" |> print() + # plot_k |> print() + + ###### Annotate Plots ###### + ### Labels on top + ### Longest impact type: "Acute Myocardial Infarction" + typeTitle_k <- "Impact Type: " |> paste0(impType_k) + grobType_k <- text_grob(typeTitle_k, face="italic", size=11) + # "got here2" |> print() + plotGrid_k <- plot_k + # "got here3" |> print() + plotList_k <- list(spacer1=spacer0, plots=plotGrid_k, spacer2=spacer0) + # "got here4" |> print() + plotGrid_k <- ggarrange(plotlist=plotList_k, nrow=3, ncol=1, heights=c(0.01, 1, 0.1)) + # "got here5" |> print() + plotGrid_k <- plotGrid_k |> annotate_figure(top=grobType_k) + + ### Return + return(plotGrid_k) + }) + + ### Name the plots + # listTypes_j |> length() |> print(); cImpTypes |> print() + listTypes_j <- listTypes_j |> set_names(cImpTypes) + + ### Arrange plot list + # plotGrid_j <- ggarrange(plotlist=listTypes_j, ncol=1, nrow=nRow, common.legend=F, legend="none") + plotGrid_j <- ggarrange(plotlist=listTypes_j, ncol=1, nrow=nRow, common.legend=F) + + ### Add spacer to the top + # "got here2..." |> print() + yearTitle_j <- "Impact Year: " |> paste0(impYear_j) + grobYear_j <- text_grob(yearTitle_j, face="plain", size=13) + plotList_j <- list(spacer1=spacer0, plot=plotGrid_j) + plotGrid_j <- ggarrange(plotlist=plotList_j, nrow=2, ncol=1, common.legend=T, legend="none", heights=c(0.01, 1)) + plotGrid_j <- plotGrid_j |> annotate_figure(top=grobYear_j) + + ### Add Plot Title & Y Title + plotList_j <- list(spacer1=spacer0, plot=plotGrid_j, spacer2=spacer0) + # nModels |> print() + modMult <- (nModels - 1) %/% nLgdCols + 1 + plotGrid_j <- ggarrange(plotlist=plotList_j, nrow=3, ncol=1, legend="none", heights=c(0.01, nImpTypes, 0.01)) + title0_j <- sector0 + grobTit_j <- text_grob(title0_j, color="black", size = 14, face="bold", hjust=0.5) + plotGrid_j <- plotGrid_j |> annotate_figure(top=grobTit_j) + + plotYTit_j <- text_grob(yTitle, color = "black", rot = 90) + plotList_j <- list(spacer1=spacer0, plot=plotGrid_j, spacer2=spacer0) + plotGrid_j <- ggarrange(plotlist=plotList_j, nrow=1, legend="none", widths=c(0.01, nRegions, 0.01)) + plotGrid_j <- plotGrid_j |> annotate_figure(left=plotYTit_j) + # return(plotGrid_j) + + ###### Return Impact Type Plot ###### + return(plotGrid_j) + }) + ### Name the plots + listYears0 <- listYears0 |> set_names(cImpYears) + return(listYears0) + }) ### End iter1_i + ### Name the plots + listIter1 <- listIter1 |> set_names(cIter1) + + ###### Return ###### + ### Return the plot + if(print_msg) message("Finished.") + return(listIter1) +} \ No newline at end of file diff --git a/R/utils_create_report_figures.R b/R/utils_create_report_figures.R index ece7a45..c10029f 100644 --- a/R/utils_create_report_figures.R +++ b/R/utils_create_report_figures.R @@ -49,7 +49,7 @@ sum_with_na <- function( ### Check for NA values df0 <- df0 |> mutate(is_NA = df0[[col0]] |> is.na()) # df0 <- df0 |> select(-c(all_of(col0))) - + ### Summarize by impact type group0 <- group0 |> c(threshCol) |> unique() sum0 <- c(col0, "is_NA") @@ -57,14 +57,14 @@ sum_with_na <- function( group_by_at (.vars = c(group0)) |> summarize_at(.vars = c(sum0), sum, na.rm = T) |> ungroup() - + ### Check NA values df0 <- df0 |> mutate(is_NA = case_when( is_NA < df0[[threshCol]] ~ 1, is_NA == df0[[threshCol]] ~ NA, .default = NA )) - + ### Multiply column df0[[col0]] <- df0[[col0]] * df0[["is_NA"]] # df0 <- df0 |> rename_at(.vars=c("yCol"), ~c(col0)) @@ -137,7 +137,7 @@ create_constant_temp_scenario <- function( df1 <- df1 |> mutate(temp_C = temp0) df0 <- df0 |> rbind(df1) rm(df1) - + ### Get other temp types and rename if(isConus){ df0 <- df0 |> mutate(temp_C_global = temp_C |> FrEDI::convertTemps(from="conus")) @@ -185,7 +185,7 @@ get_scenario_inputsList <- function( doTemp0 <- (cTemp0 %in% names0) |> all() doTemp1 <- (cTemp1 %in% names0) |> all() doTemp <- doTemp0 | doTemp1 - + doSlr <- (cSlr %in% names0) |> all() doGdp <- (cGdp %in% names0) |> all() doPop <- (cPop %in% names0) |> all() @@ -200,25 +200,25 @@ get_scenario_inputsList <- function( list0[["tempInput"]] <- temp0 rm("temp0") } ### End if(doTemp) - + if(doSlr){ slr0 <- df0 |> select(all_of(cSlr)) list0[["slrInput"]] <- slr0 rm("slr0") } ### End if(doSlr) - + if(doGdp){ gdp0 <- df0 |> select(all_of(cGdp)) list0[["gdpInput"]] <- gdp0 rm("gdp0") } ### End if(doGdp) - + if(doPop){ pop0 <- df0 |> select(all_of(cPop)) list0[["popInput"]] <- pop0 rm("pop0") } ### End if(doPop) - + ### Return return(list0) } ### End get_scenario_inputsList @@ -260,7 +260,8 @@ agg_fredi_scenario <- function( ### Run FrEDI group0 <- c("sector", "variant", "impactType", "impactYear") group0 <- group0 |> c("region", stateCols) - group0 <- group0 |> c("model_type", "model") + # group0 <- group0 |> c("model_type", "model") + group0 <- group0 |> c("modelType", "model") group0 <- group0 |> c("sectorprimary", "includeaggregate") group0 <- group0 |> c(drop0) df0 <- df0 |> FrEDI::aggregate_impacts(aggLevels = aggLevels, groupByCols = group0) @@ -293,7 +294,7 @@ run_scenario <- function( ) ### End run_fredi_scenario } ### End if(fredi) # "got here1" |> print(); df_x0 |> glimpse() - + ### Aggregate FrEDI agg0 <- !("none" %in% aggLevels) # agg0 |> print() @@ -306,11 +307,11 @@ run_scenario <- function( ) ### End run_fredi_scenario } ### End if(agg0) # "got here2" |> print(); df_x0 |> glimpse() - + ### Format other values mutate0 <- c("temp_C_conus", "temp_C_global", "slr_cm") df_x0 <- df_x0 |> mutate_at(vars(mutate0), as.numeric) - + ### Return return(df_x0) } ### End function run_scenario @@ -329,7 +330,7 @@ run_scenarios <- function( ### Unique scenarios scenarios0 <- df0[[col0]] |> unique() nScenarios <- scenarios0 |> length() - + ### Iterate over the scenarios list0 <- scenarios0 |> map(function(.x){ paste0("Running scenario ", which(scenarios0 == .x), "/" , nScenarios, "...") |> message() @@ -347,7 +348,7 @@ run_scenarios <- function( ### Bind values into a list # df0 <- list0 %>% (function(x){do.call(rbind, x)}) df0 <- list0 |> bind_rows() - + ### Return return(df0) } ### End run_scenarios @@ -377,7 +378,8 @@ sum_impacts_byDoW <- function( scenarios0 <- scenarios; rm("scenarios") df0 <- df0 |> filter(scenario %in% scenarios0) ### Filter to appropriate models - df0 <- df0 |> filter(model_type %in% models) + # df0 <- df0 |> filter(model_type %in% models) + df0 <- df0 |> filter(modelType %in% models) ### Filter to appropriate impact years years0 <- impactYears df0 <- df0 |> filter(impactYear %in% years0) @@ -411,7 +413,7 @@ sum_impacts_byDoW <- function( ### Select columns # select0 <- c("sector", "region", "model_type", "model", "summaryYear", "driverValue", "annual_impacts", adjCol) |> unique() # df0 <- df0 |> relocate(c(all_of(select0))) - + ### Glimpse results # df0 %>% glimpse ### Return @@ -442,7 +444,7 @@ sum_impacts_byDoW_years <- function( if(primary){df0 <- df0 |> filter(sectorprimary ==1)} ### Run scenarios nYears <- years |> length() - + ### Get list list0 <- years |> map(function(.x){ paste0("Summarizing values for ", which(years == .x), "/" , nYears, " years...") |> message() @@ -476,10 +478,10 @@ sum_impacts_byDoW_years <- function( get_fig7_slrDataObj <- function( drivers=TRUE, ### Whether to return drivers impacts=TRUE ### Whether to return impacts - ){ +){ ###### Initialize Return List ###### list0 <- list() - + ###### Get Data Objects from FrEDI ###### ### Sector Info ### Variant Info @@ -487,17 +489,17 @@ get_fig7_slrDataObj <- function( dfSectors <- "co_sectors" |> get_frediDataObj() dfVariant <- "co_variants" |> get_frediDataObj() slrRef <- "co_models" |> get_frediDataObj() - + ### SLR Driver values ### SLR Scaled impct values if(drivers){slrCm <- "slr_cm" |> get_frediDataObj()} if(impacts){slrImp <- "slrImpacts" |> get_frediDataObj(listSub="stateData")} - + ###### SLR Models ###### ### Format SLR Models slrRef <- slrRef |> filter(modelType=="slr") slrRef <- slrRef |> rename_at(vars("model_label"), ~c("model")) - + ###### Levels & Labels ###### ### Initial levels & labels slrLevels <- slrRef[["model_dot"]] @@ -510,7 +512,7 @@ get_fig7_slrDataObj <- function( ### Vector of model labels and number of models c_slrs <- slrLabels n_slrs <- c_slrs |> length() - + ###### Sectors Data ###### ### Format Sectors data select0 <- c("sector_id", "sector_label", "modelType") @@ -522,7 +524,7 @@ get_fig7_slrDataObj <- function( dfSectors <- dfSectors |> filter(tolower(model_type)=="slr") dfSectors <- dfSectors |> mutate_at(.vars=c(mutate0), as.character) rm(select0, rename0, rename1, mutate0) - + ###### Variants Data ###### ### Format Variants data select0 <- c("sector_id", "variant_id", "variant_label", "sectorprimary", "includeaggregate") @@ -531,11 +533,11 @@ get_fig7_slrDataObj <- function( dfVariant <- dfVariant |> select(c(all_of(select0))) dfVariant <- dfVariant |> rename_at(.vars=c(rename0), ~c(rename1)) rm(select0, rename0, rename1) - + ###### Sector-Variant Data ###### ### Create Sector-Variant data dfSectVar <- dfSectors |> left_join(dfVariant, by=c("sector_id")) - + ###### SLR Driver values ###### if(drivers){ ### Format SLR Driver values @@ -545,7 +547,7 @@ get_fig7_slrDataObj <- function( slrCm <- slrCm |> select(c(all_of(select0))) slrCm <- slrCm |> rename_at(.vars=c(rename0), ~c(rename1)) rm(select0, rename0, rename1) - + ### Add values for 0cm, 300 cm slrCm <- slrCm %>% (function(y){ y <- y |> mutate(model = model |> as.character()) @@ -553,19 +555,19 @@ get_fig7_slrDataObj <- function( y <- y |> rbind(y300) return(y) }) - + ### Mutate labels & levels slrCm <- slrCm |> mutate(model = model |> factor(levels=slrLevels, labels=slrLabels)) - + ### Arrange values arrange0 <- c("model", "year") slrCm <- slrCm |> arrange_at(.vars=c(arrange0)) rm(arrange0) - + ### Add to list list0 <- list0 |> c(list(slrCm=slrCm)) } ### End if(drivers) - + ###### SLR Impacts Data ###### if(impacts){ ### Format the impacts @@ -575,30 +577,30 @@ get_fig7_slrDataObj <- function( slrImp <- slrImp |> rename_at(.vars=c(rename0), ~c(rename1)) slrImp <- slrImp |> select(-c(all_of(drop0))) rm(rename0, rename1, drop0) - + ### Adjust names exclude0 <- c("year", "annual_impacts") mutate0 <- slrImp |> names() %>% (function(y1, y2=exclude0){y1[!(y1 %in% y2)]}) slrImp <- slrImp |> mutate_at(.vars=c(mutate0), as.character) slrImp <- slrImp |> mutate(model = model |> factor(levels=slrLevels, labels=slrLabels)) rm("exclude0", "mutate0") - + ### Join with sector-variant data drop0 <- c("sector_id", "variant_id") join0 <- c(drop0, "model_type") slrImp <- slrImp |> left_join(dfSectVar, by=c(join0)) slrImp <- slrImp |> select(-c(all_of(drop0))) rm(join0, drop0) - + ### Mutate other columns slrImp <- slrImp |> mutate(region = gsub("\\.", " ", region)) slrImp <- slrImp |> mutate(impactType = "N/A") slrImp <- slrImp |> mutate(impactYear = "Interpolation") slrImp <- slrImp |> mutate(model_type = model_type |> toupper()) - + ### Replace missing values slrImp <- slrImp |> mutate(annual_impacts = annual_impacts |> replace_na(0)) - + ### Mutate specific values slrImp <- slrImp %>% (function(y){ yLo <- y |> filter(model=="30 cm" ) |> mutate(annual_impacts=0) |> mutate(model="0 cm") @@ -606,20 +608,20 @@ get_fig7_slrDataObj <- function( y <- yLo |> rbind(y) |> rbind(yHi) return(y) }) - + ### Mutate labels & levels slrImp <- slrImp |> mutate(model = model |> as.character()) slrImp <- slrImp |> mutate(model = model |> factor(levels=slrLabels, labels=slrLabels)) - + ### Arrange values arrange0 <- c("sector", "variant", "impactType", "impactYear", "region", "model_type", "model", "year") slrImp <- slrImp |> arrange_at(.vars=c(arrange0)) rm(arrange0) - + ### Add to list list0 <- list0 |> c(list(slrImp=slrImp)) } ### End if impacts - + ###### Return ###### ### Add to list return(list0) @@ -645,27 +647,27 @@ get_fig7_slrImpacts <- function( ### - Combine CIRA impacts and SLR trajectories modelLabels <- slrDrivers[["model"]] |> levels() |> as.character() modelHeights <- modelLabels |> map(function(.x){str_split(string=.x, pattern="\\s")[[1]][1]}) |> unlist() |> as.numeric() - + ###### Format data ###### ### Add variables for plotting with plot_DOW_byModelType # slrImpacts <- slrImpacts |> mutate(impactYear = "Interpolation") - + ### Filter to includeaggregate==1, if(aggOnly){slrImpacts <- slrImpacts |> filter(includeaggregate==1)} - + ### Filter to primary==1 primary <- !bySector if(aggOnly){slrImpacts <- slrImpacts |> filter(sectorprimary==1)} - + ### Filter to appropriate categories and years if(!bySector){slrImpacts <- slrImpacts |> filter(year %in% years)} slrImpacts <- slrImpacts |> filter(model %in% modelLabels) - + ### Filter to national totals or calculate national totals slrImpacts <- slrImpacts |> filter(region!="National Total") c_regions <- slrImpacts[["region"]] |> unique() n_regions <- c_regions |> length() - + ### Change column names rename0 <- "model" rename1 <- "SLR_scenario" @@ -673,11 +675,11 @@ get_fig7_slrImpacts <- function( slrImpacts <- slrImpacts |> rename_at(.vars=c(rename0), ~c(rename1)) slrImpacts <- slrImpacts |> mutate(model = year |> factor()) rm(rename0, rename1) - + ### Initialize totals slrTotals <- slrImpacts rm(slrImpacts) - + ###### Summarize Impact Types ###### ### Summarize over impact types if(!bySector){ @@ -688,12 +690,12 @@ get_fig7_slrImpacts <- function( summarize(n=n(), .groups="keep") |> ungroup() # n_impTypes <- count_impTypes[["n"]] |> max() - + ### Join counts with totals join0 <- group0 slrTotals <- slrTotals |> left_join(count_impTypes, by = c(join0)) rm(join0, count_impTypes) - + ### Summarize # sum0 <- c("annual_impacts", "is_NA") # sum0 <- c(sumCol, "is_NA") @@ -704,11 +706,11 @@ get_fig7_slrImpacts <- function( threshCol = "n", ### Threshold to check against drop0 = TRUE ### ) %>% select(-c("n")) - + slrTotals <- slrTotals |> mutate(impactType = "All") # slrTotals |> names() |> print() } - + ###### National Totals ###### ### Calculate national totals group0 <- c("sector", "variant", "impactType", "impactYear", "model_type", "SLR_scenario", "model", "year") @@ -722,22 +724,22 @@ get_fig7_slrImpacts <- function( threshCol = "threshold", ### Threshold to check against drop0 = TRUE ### ) %>% select(-c("threshold")) - + slrTotals <- slrTotals |> mutate(region = "National Total") # slrTotals |> names() |> print() - + ###### #####Adjust Values ###### ### Adjust values # slrTotals[[adjCol]] <- slrTotals[["annual_impacts"]] * adjVal slrTotals[[adjCol]] <- slrTotals[[sumCol]] * adjVal - + # ### Add additional values & drop columns # drop0 <- c("variant", "impactType", "impactYear") # slrTotals <- slrTotals |> mutate(region = "National Total") # # slrTotals <- slrTotals |> mutate(impactType = "All") # slrTotals <- slrTotals |> select(-c(all_of(drop0))) # rm(drop0) - + ###### Format Results ###### ### Join with driver info rename0 <- c("slr_cm" , "year") @@ -751,14 +753,14 @@ get_fig7_slrImpacts <- function( slrTotals <- slrTotals |> rename_at(.vars=c(rename0), ~c(rename1)) slrTotals <- slrTotals |> relocate(c(all_of(select0))) rm(rename0, rename1, join0) - + ### Adjust column names if bySector if(bySector){ slrTotals <- slrTotals |> mutate(model=SLR_scenario) slrTotals <- slrTotals |> rename(year=summaryYear) slrTotals <- slrTotals |> select(-c("SLR_scenario")) } - + slrTotals |> glimpse() #|> print() ### Return return(slrTotals) @@ -789,13 +791,13 @@ plot_DoW_by_modelYear <- function( ### Model Type Checks do_gcm <- "gcm" == tolower(type0) do_slr <- "slr" == tolower(type0) - + ###### Filter Data ###### ### Filter to model type # df0 <- df0 |> filter(summaryYear==year0) if(do_gcm){df0 <- df0 |> filter(summaryYear==year0)} df0 <- df0 |> filter(model_type ==type0) - + ### Plot by model type plot0 <- df0 |> plot_DOW_byModelType( modelType = type0, @@ -805,7 +807,7 @@ plot_DoW_by_modelYear <- function( options = options, silent = silent ) ### End plot_DOW_byModelType - + ### Return return(plot0) } ### End plot_DoW_by_modelYear @@ -856,7 +858,7 @@ plot_DoW <- function( } ### if(do_slr) # "got here" |> print() # df_types |> glimpse() - + ### Initialize list to iterate over pList0 <- list(x1=df_types[["type"]], x2=df_types[["year"]]) ### Initialize list @@ -873,17 +875,17 @@ plot_DoW <- function( options = options, silent = silent ) ### End plot_DoW_by_modelYear - + # plot_y |> print() ### Return return(plot_y) }) - + ### Add list names # list0 |> print() labels0 <- df_types[["label"]] list0 <- list0 |> set_names(labels0) - + ### Return return(list0) } ### End plot_DoW @@ -916,13 +918,13 @@ plot_DoW_by_sector <- function( ### For GCMs if(do_gcm){ df_gcm <- "GCM" |> map(function(.x, years0=years){ - # df0 |> glimpse() - df1 <- df0 |> filter(model_type=="GCM") - sectors0 <- df1[["sector"]] |> unique() - df_x <- sectors0 |> map(function(.y){tibble(type=.x, sector=.y, year=years, label=.y |> paste0("_", years))}) - df_x <- df_x |> bind_rows() - return(df_x) - }) + # df0 |> glimpse() + df1 <- df0 |> filter(model_type=="GCM") + sectors0 <- df1[["sector"]] |> unique() + df_x <- sectors0 |> map(function(.y){tibble(type=.x, sector=.y, year=years, label=.y |> paste0("_", years))}) + df_x <- df_x |> bind_rows() + return(df_x) + }) df_gcm <- df_gcm |> bind_rows() df_types <- df_types |> rbind(df_gcm) rm(df_gcm) @@ -934,7 +936,7 @@ plot_DoW_by_sector <- function( df_types <- df_types |> rbind(df_slr) rm(df_slr, sectors0) } ### End if(do_slr) - + ### Get list list0 <- models |> map(function(.x){ paste0("Creating plots for model type ", .x, "...") |> message() @@ -944,7 +946,7 @@ plot_DoW_by_sector <- function( sectors_x <- types_x[["sector"]] # df_types |> glimpse() pList_x <- list(x1=types_x[["sector"]], x2=types_x[["year"]]) - + list_x <- pList_x %>% pmap(function(x1, x2){ x1 |> paste0("_", x2) |> print() df_y <- df0 |> filter(sector == x1) @@ -956,7 +958,7 @@ plot_DoW_by_sector <- function( #"look here" %>% print() #df_y |> glimpse() } ### End if(do_gcm) - + plot_y <- df_y |> plot_DOW_byImpactTypes( sector = x1, modelType = models, @@ -994,31 +996,31 @@ plot_slr_scenarios <- function( years0 <- seq(2000, 2300, by=25) slrDrivers <- slrDrivers |> filter(!(model %in% c("0 cm", "300 cm"))) dfPoints <- slrDrivers |> filter(year %in% years0) - - + + plot0 <- slrDrivers |> ggplot() + geom_line(aes(x=year, y=slr_cm, color = model)) + geom_point(data=dfPoints, aes(x=year, y=slr_cm, color = model, shape=model)) - + plot0 <- plot0 + scale_color_discrete(subTitle0) + scale_shape_discrete(subTitle0) + theme(legend.position = "bottom") - + plot0 <- plot0 + scale_x_continuous("Year") + scale_y_continuous("GMSL (cm)") - + # plot0 <- plot0 + # theme(panel.background = element_rect(fill="white")) + # theme(panel.grid = element_line(color="lightgrey")) + # theme(axis.line = element_line(color="darkgrey")) - + plot0 <- plot0 + ggtitle(title0, subTitle0) + theme(plot.title = element_text(hjust = 0.5, size=14)) + theme(plot.subtitle = element_text(hjust = 0.5, size=11)) - + ### Return return(plot0) } ### End plot_slr_scenarios @@ -1028,7 +1030,7 @@ create_default_tablePlot <- function(x=1){ ### Run FrEDI results0 <- FrEDI::run_fredi() # results0 |> glimpse() - + ### Filter to values used to report results0 <- results0 |> filter(model %in% c("Interpolation", "Average")) |> @@ -1036,13 +1038,13 @@ create_default_tablePlot <- function(x=1){ filter(sectorprimary == 1) |> filter(region == "National Total") results0 |> glimpse() - + ### Summarize results for specific years table0 <- results0 |> filter(year %in% seq(2010, 2090, by=10)) |> select(c("sector", "variant", "year", "annual_impacts")) |> spread(key="year", value="annual_impacts") - + ### Summarize results over all years totals0 <- results0 |> group_by_at(.vars=c("sector")) |> @@ -1051,14 +1053,14 @@ create_default_tablePlot <- function(x=1){ totals0 <- totals0|> arrange_at(.vars=c("annual_impacts")) |> mutate(order=row_number()) - + ### Factor results results0 <- results0 |> mutate(sector_order = sector |> factor(levels=totals0[["sector"]])) results0 <- results0 |> mutate(sector_factor = sector |> factor(levels=totals0[["sector"]])) ### Arrange arrange0 <- c("sector_factor", "variant", "year") results0 <- results0 |> arrange_at(.vars=c(arrange0)) - + ### Create plot plot0 <- results0 |> ggplot(aes(x=year, y=annual_impacts/10**12)) + @@ -1068,7 +1070,7 @@ create_default_tablePlot <- function(x=1){ scale_x_continuous("Year", breaks=seq(2010, 2090, by=20)) + guides(color=guide_legend(ncol=2), fill=guide_legend(ncol=2)) + theme(legend.position = "bottom") - + ### Create list returnList <- list() returnList[["table" ]] <- table0 diff --git a/R/utils_save_report_objects.R b/R/utils_save_report_objects.R index d9090e6..aee4e42 100644 --- a/R/utils_save_report_objects.R +++ b/R/utils_save_report_objects.R @@ -107,7 +107,7 @@ fun_appx_plot_height <- function(ntypes=1, nrows=1){ save_appendix_figures <- function( plotList, df0, ### Dataframe used to create plots - modelType = "GCM", ### Or SLR + type0 = "GCM", ### Or SLR fpath = ".", device = "pdf", res = 200, @@ -119,8 +119,9 @@ save_appendix_figures <- function( fdir <- fdir |> file.path("images") created0 <- fdir |> check_and_create_path(createDir=createDir) ### Prepare data - df0 <- df0 |> filter(model_type %in% modelType) - list0 <- plotList[[modelType]] + # df0 <- df0 |> filter(model_type %in% type0) + df0 <- df0 |> filter(modelType %in% type0) + list0 <- plotList[[type0]] ### Unique values names0 <- list0 |> names() sectors0 <- names0 |> map(function(.x){str_split(string=.x, pattern="_")[[1]][1]}) |> unlist() |> unique()