diff --git a/DESCRIPTION b/DESCRIPTION index 28a2166..5318cfa 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -38,10 +38,10 @@ Imports: patchwork, ggridges, magrittr, - cli -Depends: - R(>= 3.5.0), + cli, loadeR.java +Depends: + R(>= 3.5.0) Suggests: knitr, rmarkdown diff --git a/NAMESPACE b/NAMESPACE index c1b6608..3ffe985 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -13,7 +13,6 @@ export(agreement) export(climate_change_signal) export(common_dates) export(convert_vector_to_month_initials) -export(ens_trends) export(extract_raster) export(load_data) export(load_data_and_climate_change_signal) diff --git a/NEWS.md b/NEWS.md index 5c30184..945a2a0 100644 --- a/NEWS.md +++ b/NEWS.md @@ -10,21 +10,5 @@ output: --- ## CAVAanalytics 3.0.0 -Version 3.0.0 of CAVAanalytics bring several updates: -- the trends function was removed. Linear regression can now be applied to observation only by specifying trends=T in the observations function -- model agreement in the sign of climate change signal has been added. This substitute the calculation of trends for future projections -- temporal and spatiotemporal patterns can now be visualized by directly specifying temporal=T or spatiotemporal=T in plotting where allowed - -## CAVAanalytics 2.1.0 -Version 2.1.0 of CAVAanalytics bring several updates: - -- the country argument in load_data can now take an sf object -- the memory efficient functions (load_data_and_projections and so forth) can now take a country name or sf object in the country argument -- load_data_and_model_biases function has been added -- Better handling of messages and errors in the plotting function -- xarray option was removed from the load_data function. This is because CORDEX data is now stored in new THREDDS servers which allow fast ad multi-thread data download -- Improved facets layout in plotting results - -## CAVAanalytics 2.0.4 -first stable release +Version 3.0.0 of CAVAanalytics is the first stable release. Follow the tutorial to learn how to use it. diff --git a/R/climate_change_signal.R b/R/climate_change_signal.R index 315b9ef..4a6416a 100644 --- a/R/climate_change_signal.R +++ b/R/climate_change_signal.R @@ -373,7 +373,7 @@ climate_change_signal <- function(data, "SparRaster stack for ccs sd", "SpatRaster stack for individual members", "SpatRaster stack for ccs agreement", - "dataframe for spatially aggregated data" + "dataframe for spatially and annually aggregated data" ) )) diff --git a/R/load_data_and_climate_change_signal.R b/R/load_data_and_climate_change_signal.R index a72e873..a15e1f2 100644 --- a/R/load_data_and_climate_change_signal.R +++ b/R/load_data_and_climate_change_signal.R @@ -48,7 +48,7 @@ load_data_and_climate_change_signal <- frequency = F, bias.correction = F, domain = NULL, - threshold=0.6, + threshold = 0.6, n.sessions = 6) { # calculate number of chunks based on xlim and ylim if (missing(chunk.size) | missing(season)) { @@ -60,7 +60,9 @@ load_data_and_climate_change_signal <- ) } - + cli::cli_alert_warning( + "Interpolation may be required to merge the rasters. Be aware that interpolation can introduce slight discrepancies in the data, potentially affecting the consistency of results across different spatial segments." + ) country_shp = if (!is.null(country) & !inherits(country, "sf")) { @@ -89,6 +91,11 @@ load_data_and_climate_change_signal <- sf::st_set_crs(., NA) } + lon_range <- + c(sf::st_bbox(country_shp)[[1]], sf::st_bbox(country_shp)[[3]]) + lat_range <- + c(sf::st_bbox(country_shp)[[2]], sf::st_bbox(country_shp)[[4]]) + x_chunks <- seq(from = xlim[1], to = xlim[2], by = chunk.size) y_chunks <- seq(from = ylim[1], to = ylim[2], by = chunk.size) @@ -100,6 +107,12 @@ load_data_and_climate_change_signal <- ylim else y_chunks + + #making sure the whole area is loaded + if (x_chunks[length(x_chunks)] < lon_range[2]) + x_chunks[length(x_chunks) + 1] = lon_range[2] + if (y_chunks[length(y_chunks)] < lat_range[2]) + y_chunks[length(y_chunks) + 1] = lat_range[2] # create empty list to store output out_list <- list() @@ -163,44 +176,57 @@ load_data_and_climate_change_signal <- } } cli::cli_progress_step("Merging rasters") - # Extract the first, second, and third elements of each list in `out_list` + # Extract elements of each list in `out_list` rst_mean <- lapply(out_list, `[[`, 1) rst_sd <- lapply(out_list, `[[`, 2) rst_mbrs <- lapply(out_list, `[[`, 3) rst_agree <- lapply(out_list, `[[`, 4) - # Merge the extracted rasters using `Reduce` and set their names + df_temp <- + do.call(rbind, lapply(out_list, `[[`, 5)) %>% # spatial average of all chunks + dplyr::group_by(date, experiment, Var1, season) %>% + dplyr::summarise(value = median(value, na.rm = T)) + merge_rasters <- function(rst_list) { + # Determine the smallest (finest) resolution among all rasters + resolutions <- sapply(rst_list, function(r) + terra::res(r)) + common_res <- min(resolutions) + + # Resample all rasters to the common resolution + resampled_rasters <- lapply(rst_list, function(r) { + terra::resample(r, + terra::rast( + terra::ext(r), + resolution = common_res, + crs = terra::crs(r) + ), + method = "bilinear") + }) + + # Merge the resampled rasters + merged_raster <- + Reduce(function(x, y) + terra::merge(x, y), resampled_rasters) + + #Set names from the first raster in the list names <- names(rst_list[[1]]) - Reduce(function(...) - terra::merge(...), rst_list) %>% setNames(names) + setNames(merged_raster, names) } cli::cli_process_done() - rasters_mean <- tryCatch( - expr = merge_rasters(rst_mean), - warning = function(w) { - # Translate the warning into something more understandable - translated_warning <- - "Terra had to interpolate your SpatRasters to merge them. You can ignore this warning if you used sensible values for overalp and chunk_size arguments" - # ... handle the warning ... - # You can print the translated warning, log it, or perform any other action - cli::cli_alert_warning(translated_warning) - } - ) + rasters_mean <- merge_rasters(rst_mean) rasters_sd <- merge_rasters(rst_sd) rasters_mbrs <- merge_rasters(rst_mbrs) rasters_agree <- merge_rasters(rst_agree) - - invisible(structure( list( rasters_mean %>% terra::crop(., country_shp) %>% terra::mask(., country_shp), rasters_sd %>% terra::crop(., country_shp) %>% terra::mask(., country_shp), rasters_mbrs %>% terra::crop(., country_shp) %>% terra::mask(., country_shp), rasters_agree %>% terra::crop(., country_shp) %>% terra::mask(., country_shp), - NULL + df_temp ), class = "CAVAanalytics_ccs", components = list( @@ -208,7 +234,7 @@ load_data_and_climate_change_signal <- "SpatRaster for ensemble sd", "SpatRaster for individual members", "SpatRaster stack for ccs agreement", - "dataframe for spatially aggregated data" + "dataframe for spatially and annually aggregated data" ) )) diff --git a/R/load_data_and_model_biases.R b/R/load_data_and_model_biases.R index 6020792..08c2987 100644 --- a/R/load_data_and_model_biases.R +++ b/R/load_data_and_model_biases.R @@ -59,7 +59,9 @@ load_data_and_model_biases <- ) } - + cli::cli_alert_warning( + "Interpolation may be required to merge the rasters. Be aware that interpolation can introduce slight discrepancies in the data, potentially affecting the consistency of results across different spatial segments." + ) country_shp = if (!is.null(country) & !inherits(country, "sf")) { suppressMessages( @@ -87,6 +89,11 @@ load_data_and_model_biases <- sf::st_set_crs(., NA) } + lon_range <- + c(sf::st_bbox(country_shp)[[1]], sf::st_bbox(country_shp)[[3]]) + lat_range <- + c(sf::st_bbox(country_shp)[[2]], sf::st_bbox(country_shp)[[4]]) + x_chunks <- seq(from = xlim[1], to = xlim[2], by = chunk.size) y_chunks <- seq(from = ylim[1], to = ylim[2], by = chunk.size) x_chunks <- if (length(x_chunks) < 2) @@ -97,6 +104,12 @@ load_data_and_model_biases <- ylim else y_chunks + + #making sure the whole area is loaded + if (x_chunks[length(x_chunks)] < lon_range[2]) + x_chunks[length(x_chunks) + 1] = lon_range[2] + if (y_chunks[length(y_chunks)] < lat_range[2]) + y_chunks[length(y_chunks) + 1] = lat_range[2] # create empty list to store output out_list <- list() @@ -164,28 +177,37 @@ load_data_and_model_biases <- rst_mbrs <- lapply(out_list, `[[`, 2) # Merge the extracted rasters using `Reduce` and set their names merge_rasters <- function(rst_list) { + # Determine the smallest (finest) resolution among all rasters + resolutions <- sapply(rst_list, function(r) + terra::res(r)) + common_res <- min(resolutions) + + # Resample all rasters to the common resolution + resampled_rasters <- lapply(rst_list, function(r) { + terra::resample(r, + terra::rast( + terra::ext(r), + resolution = common_res, + crs = terra::crs(r) + ), + method = "bilinear") + }) + + # Merge the resampled rasters + merged_raster <- + Reduce(function(x, y) + terra::merge(x, y), resampled_rasters) + + #Set names from the first raster in the list names <- names(rst_list[[1]]) - Reduce(function(...) - terra::merge(...), rst_list) %>% setNames(names) + setNames(merged_raster, names) } cli::cli_process_done() - rasters_mean <- tryCatch( - expr = merge_rasters(rst_mean), - warning = function(w) { - # Translate the warning into something more understandable - translated_warning <- - "Terra had to interpolate your SpatRasters to merge them. You can ignore this warning if you used sensible values for overalp and chunk_size arguments" - # ... handle the warning ... - # You can print the translated warning, log it, or perform any other action - cli::cli_alert_warning(translated_warning) - } - ) + rasters_mean <- merge_rasters(rst_mean) rasters_mbrs <- merge_rasters(rst_mbrs) - - invisible(structure( list( rasters_mean %>% terra::crop(., country_shp) %>% terra::mask(., country_shp), diff --git a/R/load_data_and_projections.R b/R/load_data_and_projections.R index e3111f8..376198d 100644 --- a/R/load_data_and_projections.R +++ b/R/load_data_and_projections.R @@ -57,6 +57,9 @@ load_data_and_projections <- function(variable, ) } + cli::cli_alert_warning( + "Interpolation may be required to merge the rasters. Be aware that interpolation can introduce slight discrepancies in the data, potentially affecting the consistency of results across different spatial segments." + ) country_shp = if (!is.null(country) & !inherits(country, "sf")) { suppressMessages( @@ -84,6 +87,11 @@ load_data_and_projections <- function(variable, sf::st_set_crs(., NA) } + lon_range <- + c(sf::st_bbox(country_shp)[[1]], sf::st_bbox(country_shp)[[3]]) + lat_range <- + c(sf::st_bbox(country_shp)[[2]], sf::st_bbox(country_shp)[[4]]) + x_chunks <- seq(from = xlim[1], to = xlim[2], by = chunk.size) y_chunks <- seq(from = ylim[1], to = ylim[2], by = chunk.size) x_chunks <- if (length(x_chunks) < 2) @@ -94,6 +102,12 @@ load_data_and_projections <- function(variable, ylim else y_chunks + + #making sure the whole area is loaded + if (x_chunks[length(x_chunks)] < lon_range[2]) + x_chunks[length(x_chunks) + 1] = lon_range[2] + if (y_chunks[length(y_chunks)] < lat_range[2]) + y_chunks[length(y_chunks) + 1] = lat_range[2] # create empty list to store output out_list <- list() @@ -162,26 +176,43 @@ load_data_and_projections <- function(variable, rst_mean <- lapply(out_list, `[[`, 1) rst_sd <- lapply(out_list, `[[`, 2) rst_mbrs <- lapply(out_list, `[[`, 3) + df_temp <- + do.call(rbind, lapply(out_list, `[[`, 4)) %>% # spatial average of all chunks + dplyr::group_by(date, experiment, Var1, season) %>% + dplyr::summarise(value = median(value, na.rm = T)) # Merge the extracted rasters using `Reduce` and set their names + merge_rasters <- function(rst_list) { + # Determine the smallest (finest) resolution among all rasters + resolutions <- sapply(rst_list, function(r) + terra::res(r)) + common_res <- min(resolutions) + + # Resample all rasters to the common resolution + resampled_rasters <- lapply(rst_list, function(r) { + terra::resample(r, + terra::rast( + terra::ext(r), + resolution = common_res, + crs = terra::crs(r) + ), + method = "bilinear") + }) + + # Merge the resampled rasters + merged_raster <- + Reduce(function(x, y) + terra::merge(x, y), resampled_rasters) + + #Set names from the first raster in the list names <- names(rst_list[[1]]) - Reduce(function(...) - terra::merge(...), rst_list) %>% setNames(names) + setNames(merged_raster, names) } + cli::cli_process_done() - rasters_mean <- tryCatch( - expr = merge_rasters(rst_mean), - warning = function(w) { - # Translate the warning into something more understandable - translated_warning <- - "Terra had to interpolate your SpatRasters to merge them. You can ignore this warning if you used sensible values for overalp and chunk_size arguments" - # ... handle the warning ... - # You can print the translated warning, log it, or perform any other action - cli::cli_alert_warning(translated_warning) - } - ) + rasters_mean <- merge_rasters(rst_mean) rasters_sd <- merge_rasters(rst_sd) rasters_mbrs <- merge_rasters(rst_mbrs) @@ -191,7 +222,7 @@ load_data_and_projections <- function(variable, rasters_mean %>% terra::crop(., country_shp) %>% terra::mask(., country_shp), rasters_sd %>% terra::crop(., country_shp) %>% terra::mask(., country_shp), rasters_mbrs %>% terra::crop(., country_shp) %>% terra::mask(., country_shp), - NULL + df_temp ), class = "CAVAanalytics_projections", components = list( diff --git a/R/observations.R b/R/observations.R index 8e4eae6..4a4e2e1 100644 --- a/R/observations.R +++ b/R/observations.R @@ -271,24 +271,24 @@ observations <- list( data_list$obs_spat[[1]][[1]], data_list$obs_spat[[1]][[2]], - data_list$obs_temp + data_list$obs_temp[[1]] ), class = "CAVAanalytics_observations", components = list( "SpatRaster for trends coefficients", "SpatRaster for trends p.values", - "dataframe for spatially aggregated data" + "dataframe for annually aggregated data" ) )) } else { invisible(structure( list(data_list$rst_mean[[1]], - data_list$obs_temp), + data_list$obs_temp[[1]]), class = "CAVAanalytics_observations", components = list( "SpatRaster for observation mean", - "dataframe for spatially aggregated data" + "dataframe for annually aggregated data" ) )) @@ -366,7 +366,7 @@ observations <- class = "CAVAanalytics_observations", components = list( "SpatRaster for observation mean", - "dataframe for spatially aggregated data" + "dataframe for annually aggregated data" ) )) @@ -382,7 +382,7 @@ observations <- components = list( "SpatRaster for trends coefficients", "SpatRaster for trends p.values", - "dataframe for spatially aggregated data" + "dataframe for annually aggregated data" ) )) diff --git a/R/plotting.R b/R/plotting.R index 916c71f..7241211 100644 --- a/R/plotting.R +++ b/R/plotting.R @@ -12,7 +12,7 @@ #' @param bins logical. Whether to visualize colors as a gradient or in bins #' @param n.bins numeric. Controlling the number of bins when bins equal TRUE #' @param alpha numeric. Transparency of colors -#' @param spatiotemporal logical. Whether computed yearly data should be visualized without spatial and temporal aggregation. Frequencies are visualized +#' @param spatiotemporal logical. Whether computed yearly data should be visualized without spatial and temporal aggregation. Basically, frequencies are visualized #' @param temporal logical. Whether computed yearly data should be visualized temporally after spatial aggregation (median of all pixels) #' @return ggplot object @@ -52,7 +52,6 @@ plotting.CAVAanalytics_projections <- spatiotemporal = F, temporal = F, n.groups = 3) { - # check ------------------------------------------------------------------- stopifnot(is.logical(ensemble)) @@ -71,7 +70,7 @@ plotting.CAVAanalytics_projections <- p <- if (!temporal & !spatiotemporal) { if (ensemble & stat == "mean") { - spatial_prep(rst, 1, proj = T, stat, ensemble) %>% + spatial_prep(rst, 1, ccs_sign = F, stat, ensemble) %>% spatial_plot(., sign = F, ensemble, @@ -82,7 +81,7 @@ plotting.CAVAanalytics_projections <- plot_titles, legend_range) } else if (ensemble & stat == "sd") { - spatial_prep(rst, 2, proj = T, ensemble) %>% + spatial_prep(rst, 2, ccs_sign = F, stat, ensemble) %>% spatial_plot(., sign = F, ensemble, @@ -94,7 +93,7 @@ plotting.CAVAanalytics_projections <- legend_range) } else { # individual models - spatial_prep(rst, 3, proj = T, stat, ensemble) %>% + spatial_prep(rst, 3, ccs_sign = F, stat, ensemble) %>% spatial_plot(., sign = F, ensemble, @@ -107,9 +106,21 @@ plotting.CAVAanalytics_projections <- } } else if (temporal & !spatiotemporal) { # when temporal is TRUE - temporal_plot(rst, 4, ensemble, spatial.aggr = T, plot_titles, palette, legend_range) + temporal_plot(rst, + 4, + ensemble, + spatial.aggr = T, + plot_titles, + palette, + legend_range) } else { - spatiotemporal_plot(rst, 4, ensemble, plot_titles, palette, legend_range, n.groups) + spatiotemporal_plot(rst, + 4, + ensemble, + plot_titles, + palette, + legend_range, + n.groups) } cli::cli_progress_done() @@ -143,7 +154,7 @@ plotting.CAVAanalytics_ccs <- stopifnot(is.logical(temporal)) if (spatiotemporal) - cli::cli_abort("Feature not available for this object type") + cli::cli_abort("Feature not meaningful for this object type") # start code ------------------------------------------------------------------- cli::cli_progress_step("Plotting") @@ -151,11 +162,13 @@ plotting.CAVAanalytics_ccs <- p <- if (!temporal) { if (ensemble & stat == "mean") { - spatial_prep(data = rst, - index = 1, - proj = F, - stat, - ensemble) %>% + spatial_prep( + data = rst, + index = 1, + ccs_sign = T, + stat, + ensemble + ) %>% spatial_plot(., sign = T, ensemble, @@ -166,11 +179,13 @@ plotting.CAVAanalytics_ccs <- plot_titles, legend_range) } else if (ensemble & stat == "sd") { - spatial_prep(data = rst, - index = 2, - proj = F, - stat, - ensemble) %>% + spatial_prep( + data = rst, + index = 2, + ccs_sign = T, + stat, + ensemble + ) %>% spatial_plot(., sign = T, ensemble, @@ -182,11 +197,13 @@ plotting.CAVAanalytics_ccs <- legend_range) } else { # individual models - spatial_prep(data = rst, - index = 3, - proj = F, - stat, - ensemble) %>% + spatial_prep( + data = rst, + index = 3, + ccs_sign = T, + stat, + ensemble + ) %>% spatial_plot(., sign = F, ensemble, @@ -241,334 +258,6 @@ plotting.CAVAanalytics_observations <- temporal) cli::cli_abort("spatiotemporal and temporal cannot be both equal TRUE") - # intermediate functions -------------------------------------------------- - - - temporal_plot = function(data_list, index) { - cli::cli_alert_warning(" Arguments ensemble,bins,n.bins,alpha and legend_range are ignored") - rst <- do.call(rbind, data_list[[index]]) - p <- rst %>% - dplyr::group_by(date, experiment, season) %>% - dplyr::summarise(value = mean(value)) %>% - ggplot2::ggplot() + - ggplot2::geom_line( - ggplot2::aes(y = value, - x = date, - color = experiment), - linetype = "dotted", - alpha = 0.7, - linewidth = 0.7 - ) + - ggplot2::geom_smooth( - ggplot2::aes(y = value, - x = date, - color = experiment), - se = F, - linewidth = 0.8, - method = "gam", - formula = y ~ x - ) + - ggplot2::facet_wrap(~ season) + - ggplot2::scale_x_date(date_breaks = "4 years", date_labels = "%Y") + - ggplot2::theme_bw() + - ggplot2::theme( - legend.position = "none", - axis.text.x = ggplot2::element_text(angle = 45, hjust = 1), - panel.grid.major = ggplot2::element_blank(), - panel.grid.minor = ggplot2::element_blank() - ) + - ggplot2::labs(x = "Year", y = plot_titles) + - if (!is.null(palette)) { - ggplot2::scale_color_manual(values = palette) - } - - return(p) - } - - - spatiotemporal_plot = function(data_list, - index, - ...) { - cli::cli_alert_warning( - " Arguments bins,n.bins,alpha,palette and ensemble are ignored. Change number of group intervals with n.groups" - ) - rst <- do.call(rbind, data_list[[index]]) - - p <- - suppressMessages( - rst %>% - ridgeline( - rst, - group_col = 'date', - z_col = 'value', - num_grps = n.groups, - facet1 = 'season' - ) + - ggplot2::theme_bw() + - ggplot2::theme(legend.position = "none") + - ggplot2::labs(x = plot_titles) + - if (!is.null(legend_range)) { - ggplot2::xlim(legend_range[1], legend_range[2]) - } - - ) - - return(p) - - } - - spatial_plot <- - function(data_list, - index, - ...) { - cli::cli_alert_warning(" Argument ensemble is ignored") - rst <- data_list[[index]] - - # Convert SpatRaster to dataframe - rs_df <- - terra::as.data.frame(rst, xy = TRUE, na.rm = TRUE) %>% - tidyr::pivot_longer(cols = 3:ncol(.), - values_to = "value", - names_to = "long_name") %>% - # Extract scenario and time frame from column names - tidyr::separate_wider_delim( - long_name, - delim = "_", - names = c("scenario", "time_frame", "season") - ) %>% - # Replace "." with "-" in time frame - dplyr::mutate(., time_frame = stringr::str_replace(time_frame, "\\.", "-")) - - - # Set default colors for legend - palette <- - if (is.null(palette)) - c("blue", - "cyan", - "green", - "yellow", - "orange", - "red", - "black") - else - palette - - # Set default range for legend - legend_range <- - if (is.null(legend_range)) - c(range(rs_df$value, na.rm = TRUE)) - else - legend_range - - # Suppress warnings - options(warn = -1) - - # Get countries data - countries <- - rnaturalearth::ne_countries(scale = "large", returnclass = "sf") - p <- ggplot2::ggplot() + - ggplot2::geom_sf( - fill = 'white', - color = "black", - data = countries, - alpha = 0.5 - ) + - ggplot2::geom_raster(ggplot2::aes(x = x, y = y, fill = value), - data = rs_df, - alpha = alpha) + - ggplot2::geom_sf(fill = NA, - color = "black", - data = countries) + - { - if (!bins) { - ggplot2::scale_fill_gradientn( - colors = palette, - limits = legend_range, - na.value = "transparent", - n.breaks = 10, - guide = ggplot2::guide_colourbar( - ticks.colour = "black", - ticks.linewidth = 1, - title.position = "top", - title.hjust = 0.5, - label.hjust = 1 - ) - ) - } else { - ggplot2::scale_fill_stepsn( - colors = palette, - limits = legend_range, - na.value = "transparent", - n.breaks = ifelse(is.null(n.bins), 10, n.bins), - guide = ggplot2::guide_colourbar( - ticks.colour = "black", - ticks.linewidth = 1, - title.position = "top", - title.hjust = 0.5, - label.hjust = 1 - ) - ) - - } - - } + - ggplot2::coord_sf( - xlim = c(range(rs_df$x)[[1]] - 0.5, range(rs_df$x)[[2]] + 0.5), - ylim = c(range(rs_df$y)[[1]] - 0.5, range(rs_df$y)[[2]] + 0.5), - expand = F, - ndiscr = 500 - ) + - ggh4x::facet_nested(scenario ~ season) + - ggplot2::labs(fill = plot_titles, x = "", y = "") + - ggplot2::theme_bw() + - ggplot2::theme( - strip.text.y = ggplot2::element_blank(), - plot.background = ggplot2::element_blank(), - panel.background = ggplot2::element_blank(), - panel.border = ggplot2::element_blank(), - panel.grid.major = ggplot2::element_blank(), - panel.grid.minor = ggplot2::element_blank(), - axis.text.x = ggplot2::element_blank(), - axis.text.y = ggplot2::element_blank(), - axis.ticks = ggplot2::element_blank(), - axis.title = ggplot2::element_blank(), - legend.position = "right", - legend.key.height = ggplot2::unit(1, 'cm'), - legend.key.width = ggplot2::unit(0.3, 'cm'), - legend.box.spacing = ggplot2::unit(0.2, "pt") - ) - - return(p) - - - } - - - spatial_plot_trend <- function(data_list, - ...) { - cli::cli_alert_warning(" Argument ensemble is ignored") - - palette <- - if (is.null(palette)) - c("blue", - "cyan", - "green", - "yellow", - "orange", - "red", - "black") - else - palette - - # Set default range for legend - legend_range <- - if (is.null(legend_range)) - c(range(terra::values(data_list[[1]]), na.rm = TRUE)) # slope coef - else - legend_range - - # Get countries data - countries <- - rnaturalearth::ne_countries(scale = "large", returnclass = "sf") - - rs_df <- - purrr::map( - data_list[1:2], - ~ terra::as.data.frame(.x, xy = TRUE, na.rm = TRUE) %>% - tidyr::pivot_longer( - cols = 3:ncol(.), - values_to = "value", - names_to = "long_name", - ) %>% - tidyr::separate_wider_delim( - ., - long_name, - delim = "_", - names = c("scenario", "type", "time_frame", "season") - ) %>% - # Replace "." with "-" in time frame - dplyr::mutate(., time_frame = stringr::str_replace(time_frame, "\\.", "-")) - ) - - p <- ggplot2::ggplot() + - ggplot2::geom_sf( - fill = 'white', - color = "black", - data = countries, - alpha = 0.5 - ) + - ggplot2::geom_raster(ggplot2::aes(x = x, y = y, fill = value), - data = rs_df[[1]], - alpha = alpha) + - ggplot2::geom_sf(fill = NA, - color = "black", - data = countries) + - { - if (!bins) { - ggplot2::scale_fill_gradientn( - colors = palette, - limits = legend_range, - na.value = "transparent", - n.breaks = 10, - guide = ggplot2::guide_colourbar( - ticks.colour = "black", - ticks.linewidth = 1, - title.position = "top", - title.hjust = 0.5 - ) - ) - } else { - ggplot2::scale_fill_stepsn( - colors = palette, - limits = legend_range, - na.value = "transparent", - n.breaks = ifelse(is.null(n.bins), 10, n.bins), - guide = ggplot2::guide_colourbar( - ticks.colour = "black", - ticks.linewidth = 1, - title.position = "top", - title.hjust = 0.5 - ) - ) - } - } + - ggplot2::geom_point( - data = dplyr::filter(rs_df[[2]], value < 0.05), - size = 0.1, - alpha = 0.4, - color = "black", - ggplot2::aes(x, y) - ) + - ggplot2::coord_sf( - xlim = c(range(rs_df[[2]]$x)[[1]] - 0.5, range(rs_df[[2]]$x)[[2]] + 0.5), - ylim = c(range(rs_df[[2]]$y)[[1]] - 0.5, range(rs_df[[2]]$y)[[2]] + 0.5), - expand = F, - ndiscr = 500 - ) + - ggh4x::facet_nested(scenario ~ season) + - ggplot2::labs(fill = plot_titles, x = "", y = "") + - ggplot2::theme_bw() + - ggplot2::theme( - strip.text.y = ggplot2::element_blank(), - plot.background = ggplot2::element_blank(), - panel.background = ggplot2::element_blank(), - panel.border = ggplot2::element_blank(), - panel.grid.major = ggplot2::element_blank(), - panel.grid.minor = ggplot2::element_blank(), - axis.text.x = ggplot2::element_blank(), - axis.text.y = ggplot2::element_blank(), - axis.ticks = ggplot2::element_blank(), - axis.title = ggplot2::element_blank(), - legend.position = "right", - legend.key.height = ggplot2::unit(1, 'cm'), - legend.key.width = ggplot2::unit(0.3, 'cm'), - legend.box.spacing = ggplot2::unit(0.2, "pt") - ) - - return(p) - - } - # start of code ----------------------------------------------------------- cli::cli_progress_step("Plotting") @@ -576,27 +265,97 @@ plotting.CAVAanalytics_observations <- p <- if (length(rst) == 2) { # linear regression was not applied if (!temporal & !spatiotemporal) { - spatial_plot(rst, 1) + spatial_prep( + data = rst, + index = 1, + ccs_sign = F, + stat, + ensemble, + obs = T + ) %>% + spatial_plot(., + sign = F, + ensemble, + palette, + bins, + n.bins, + alpha, + plot_titles, + legend_range, + obs = T) } else { if (temporal) { - temporal_plot(rst, 2) + temporal_plot( + data = rst, + index = 2, + ensemble, + spatial.aggr = F, + plot_titles, + palette, + legend_range, + obs = T + ) } else { # spatiotemporal - spatiotemporal_plot(rst, 2) + spatiotemporal_plot(rst, + 2, + ensemble, + plot_titles, + palette, + legend_range, + n.groups, + obs = T) } } } else { # when linear regression is used if (!temporal & !spatiotemporal) { - spatial_plot_trend(rst) + spatial_prep( + data = rst, + index = 1, + ccs_sign = F, + stat, + ensemble, + obs = T, + trends = T + ) %>% + spatial_plot( + ., + sign = F, + ensemble, + palette, + bins, + n.bins, + alpha, + plot_titles, + legend_range, + obs = T, + trends = T + ) } else { # when spatiotemproal or temporal is TRUE if (temporal) { - temporal_plot(rst, 3) + temporal_plot( + data = rst, + index = 3, + ensemble, + spatial.aggr = F, + plot_titles, + palette, + legend_range, + obs = T + ) } else { # spatiotemporal - spatiotemporal_plot(rst, 3) + spatiotemporal_plot(rst, + 3, + ensemble, + plot_titles, + palette, + legend_range, + n.groups, + obs = T) } } @@ -641,16 +400,16 @@ plotting.CAVAanalytics_model_biases <- if (ensemble) { cli::cli_text( if (temporal) - "{cli::symbol$arrow_right} Visualizing the ensemble bias for spatially aggregated data" + "{cli::symbol$arrow_right} Visualizing annual time series for ensemble bias" else - "{cli::symbol$arrow_right} Visualizing the ensemble bias for temporally aggregated data" + "{cli::symbol$arrow_right} Visualizing spatial ensemble bias" ) } else { cli::cli_text( if (temporal) - "{cli::symbol$arrow_right} Visualizing individual member biases for spatially aggregated data" + "{cli::symbol$arrow_right} Visualizing annual time series individual member biases" else - "{cli::symbol$arrow_right} Visualizing individual member biases for temporally aggregated data" + "{cli::symbol$arrow_right} Visualizing individual member spatial biases" ) } diff --git a/R/utils.R b/R/utils.R index 4533214..3d9b33e 100644 --- a/R/utils.R +++ b/R/utils.R @@ -16,9 +16,9 @@ common_dates <- function(data) { #' make a raster #' -#' Make a spatRaster from a C4R list +#' Make a spatRaster from a C4R list #' -#' @param cl4.object A C4R list with the Data slot in two dimension +#' @param cl4.object A C4R list #' @param dimensions vector specifying which dimensions corresponds to lat and lon. The rest will be averaged #' @param shape.file sf object for which to crop and mask the spatRaster #' @param stat statistic to apply. Default is mean @@ -31,12 +31,12 @@ make_raster <- if (is.null(cl4.object$xyCoords$lon)) min(cl4.object$xyCoords$x) else - min(cl4.object$xyCoords$lon[1,]) + min(cl4.object$xyCoords$lon[1, ]) xmax <- if (is.null(cl4.object$xyCoords$lon)) max(cl4.object$xyCoords$x) else - max(cl4.object$xyCoords$lon[1,]) + max(cl4.object$xyCoords$lon[1, ]) ymin <- if (is.null(cl4.object$xyCoords$lat)) min(cl4.object$xyCoords$y) @@ -186,90 +186,6 @@ agreement = function(array3d, threshold) { } -#' @export - -# multivariate -ens_trends <- function(c4R) { - if (is.null(c4R$Members)) - cli::cli_abort( - c("x" = "This list does not seem to contain several members. Consider applying models_trends") - ) - - mbrs <- dim(c4R$Data)[1] - - if (length(dim(c4R$Data)) > 2) { - # in cases in which there is a spatial dimension - if (dim(c4R$Data)[1] > 100) - cli::cli_alert_warning("Check that your performed annual aggregation before using this function") - - cli::cli_progress_step( - " Applying multivariate linear regression to the ensemble. Global test statistics calculated assuming uncorrelated response (for faster computation). P-value calculated using 999 iterations via PIT-trap resampling." - ) - - global.lm <- apply(c4R$Data, c(3, 4), function(y) { - df <- reshape2::melt(y) %>% - tidyr::pivot_wider(values_from = "value", names_from = "Var1") %>% - dplyr::select(-Var2) %>% - mvabund::mvabund() - - df_var = data.frame(time = 1:nrow(df)) - mnlm <- mvabund::manylm(df ~ time, data = df_var) - out <- anova(mnlm, p.uni = "adjusted") - - sig.models <- - names(out$uni.p[2,][out$uni.p[2,] < 0.05]) # names of models with significance (p.value < 0.05) - colnames(mnlm$coefficients) <- paste0("X", 1:mbrs) - coef_res <- mnlm$coefficients[2, sig.models] - prop_res <- - if (length(coef_res) == 0) - 999 - else - sum(ifelse(coef_res >= 0, 1, -1)) # number of models, with significance, that shows an increaseor decraese. 999 assign to NA - cbind(prop_res, out$table[2, 4]) - - }) - return(global.lm) - } else { - # if we did spatial averages - if (dim(c4R$Data)[2] > 100) - cli::cli_alert_warning("Check that your performed annual aggregation before using this function") - df <- reshape2::melt(c4R$Data) %>% - tidyr::pivot_wider(values_from = "value", names_from = "Var1") %>% - dplyr::select(-Var2) %>% - mvabund::mvabund() - - df_var = data.frame(time = 1:nrow(df)) - mnlm <- mvabund::manylm(df ~ time, data = df_var) - out <- anova(mnlm, p.uni = "adjusted") - - sig.models <- - names(out$uni.p[2,][out$uni.p[2,] < 0.05]) # names of models with significance (p.value < 0.05) - colnames(mnlm$coefficients) <- paste0("X", 1:mbrs) - coef_res <- mnlm$coefficients[2, sig.models] - prop_res <- - if (length(coef_res) == 0) - 999 - else - sum(ifelse(coef_res >= 0, 1, -1)) # number of models, with significance, that shows an increase or decraese. 999 assign to NA - - df_tm_series <- reshape2::melt(c4R$Data) %>% - dplyr::select(-Var2) %>% - dplyr::group_by(Var1) %>% - dplyr::mutate(date = seq( - as.Date(c4R$Dates$start[[1]]), - as.Date(c4R$Dates$start[[length(c4R$Dates$start)]]), - by = "year" - )) %>% - dplyr::mutate(coef = prop_res, p.value = out$table[2, 4]) - - return(df_tm_series) - - } - cli::cli_process_done() - -} - - #' @export models_trends <- function(c4R, observation = F) { @@ -347,72 +263,76 @@ models_trends <- function(c4R, observation = F) { #' @export -ridgeline <- function(x, - num_grps = 10, - xlab = "Value", - ylab = "Group Intervals", - title = "", - legend_title = "z", - group_col, - z_col, - fill = NULL, - facet1 = NULL, - facet2 = NULL) { - if (missing(x)) { - stop("Empty dataframe x. Please give a proper input.") - } +ridgeline <- suppressWarnings({ + suppressMessages({ + function(x, + num_grps = 10, + xlab = "Value", + ylab = "Group Intervals", + title = "", + legend_title = "z", + group_col, + z_col, + fill = NULL, + facet1 = NULL, + facet2 = NULL) { + if (missing(x)) { + stop("Empty dataframe x. Please give a proper input.") + } - if (missing(group_col)) { - stop("Group column not specified. Use group_col to specify group.") - } + if (missing(group_col)) { + stop("Group column not specified. Use group_col to specify group.") + } - if (missing(z_col)) { - stop("Variable to plot is not specified. Use z_col to specify variable.") - } + if (missing(z_col)) { + stop("Variable to plot is not specified. Use z_col to specify variable.") + } - df <- x - ctgrp <- x <- NULL - grp <- df[, group_col] - z <- df[, z_col] - f <- df[, fill] - fc1 <- df[, facet1] - fc2 <- df[, facet2] - - - df2 <- data.frame( - grp = grp, - z = z, - f = f, - fc1 = fc1, - fc2 = fc2 - ) - df2$ctgrp <- cut(df2$grp, breaks = num_grps) - - - ggplot2::ggplot(df2, - ggplot2::aes(y = ctgrp)) + - ggridges::geom_density_ridges( - ggplot2::aes(x = z, fill = if (!is.null(fill)) - f - else - NULL), - scale = 1, - rel_min_height = 0.01, - alpha = .8, - color = "white" - ) + - ggplot2::scale_y_discrete(expand = c(0, 0)) + - ggplot2::scale_x_continuous(expand = c(0, 0)) + - ggplot2::ylab(ylab) + - ggplot2::xlab(xlab) + - if (!is.null(facet1) & !is.null(facet2)) { - ggplot2::facet_grid(fc1 ~ fc2) - } else if (!is.null(facet1) & is.null(facet2)) { - ggplot2::facet_grid(fc1 ~ .) - } else if (is.null(facet1) & !is.null(facet2)) { - ggplot2::facet_grid(fc2 ~ .) + df <- x + ctgrp <- x <- NULL + grp <- df[, group_col] + z <- df[, z_col] + f <- df[, fill] + fc1 <- df[, facet1] + fc2 <- df[, facet2] + + + df2 <- data.frame( + grp = grp, + z = z, + f = f, + fc1 = fc1, + fc2 = fc2 + ) + df2$ctgrp <- cut(df2$grp, breaks = num_grps) + + + ggplot2::ggplot(df2, + ggplot2::aes(y = ctgrp)) + + ggridges::geom_density_ridges( + ggplot2::aes(x = z, fill = if (!is.null(fill)) + f + else + NULL), + scale = 1, + rel_min_height = 0.01, + alpha = .8, + color = "white" + ) + + ggplot2::scale_y_discrete(expand = c(0, 0)) + + ggplot2::scale_x_continuous(expand = c(0, 0)) + + ggplot2::ylab(ylab) + + ggplot2::xlab(xlab) + + if (!is.null(facet1) & !is.null(facet2)) { + ggplot2::facet_grid(fc1 ~ fc2) + } else if (!is.null(facet1) & is.null(facet2)) { + ggplot2::facet_grid(fc1 ~ .) + } else if (is.null(facet1) & !is.null(facet2)) { + ggplot2::facet_grid(fc2 ~ .) + } } -} + }) +}) #' IPCC color palette #' @@ -420,10 +340,12 @@ ridgeline <- function(x, #' @param type character, one of tmp or pr. #' @param divergent logical. If TRUE, divergent palette are used. Useful in combination with legend.range to assign central colors in the palette to zero values #' @export -IPCC_palette <- function(type, divergent) { +IPCC_palette <- function(type, divergent) +{ stopifnot(is.logical(divergent)) match.arg(type, c("pr", "tmp")) - if (type == "pr" & divergent) { + if (type == "pr" & divergent) + { c( rgb(84, 48, 5, maxColorValue = 255), rgb(140, 81, 10, maxColorValue = 255), @@ -437,59 +359,69 @@ IPCC_palette <- function(type, divergent) { rgb(1, 102, 94, maxColorValue = 255), rgb(0, 60, 48, maxColorValue = 255) ) - } else if (type == "tmp" & divergent) { - c( - rgb(5, 48, 97, maxColorValue = 255), - rgb(33, 102, 172, maxColorValue = 255), - rgb(67, 147, 195, maxColorValue = 255), - rgb(146, 197, 222, maxColorValue = 255), - rgb(209, 229, 240, maxColorValue = 255), - "white", - rgb(253, 219, 199, maxColorValue = 255), - rgb(244 , 165, 130, maxColorValue = 255), - rgb(214, 96, 77, maxColorValue = 255), - rgb(178, 24, 43, maxColorValue = 255), - rgb(103, 0, 31, maxColorValue = 255) - ) + } else + if (type == "tmp" & divergent) + { + c( + rgb(5, 48, 97, maxColorValue = 255), + rgb(33, 102, 172, maxColorValue = 255), + rgb(67, 147, 195, maxColorValue = 255), + rgb(146, 197, 222, maxColorValue = 255), + rgb(209, 229, 240, maxColorValue = 255), + "white", + rgb(253, 219, 199, maxColorValue = 255), + rgb(244 , 165, 130, maxColorValue = 255), + rgb(214, 96, 77, maxColorValue = 255), + rgb(178, 24, 43, maxColorValue = 255), + rgb(103, 0, 31, maxColorValue = 255) + ) - } else if (type == "pr" & !divergent) { - c( - rgb(255, 255, 204, maxColorValue = 255), - rgb(237, 248, 177, maxColorValue = 255), - rgb(161, 218, 180, maxColorValue = 255), - rgb(65, 182, 196, maxColorValue = 255), - rgb(44, 127, 184, maxColorValue = 255), - rgb(37, 52, 148, maxColorValue = 255) + } else + if (type == "pr" & !divergent) + { + c( + rgb(255, 255, 204, maxColorValue = 255), + rgb(237, 248, 177, maxColorValue = 255), + rgb(161, 218, 180, maxColorValue = 255), + rgb(65, 182, 196, maxColorValue = 255), + rgb(44, 127, 184, maxColorValue = 255), + rgb(37, 52, 148, maxColorValue = 255) - ) - } else { - c( - rgb(255, 255, 178, maxColorValue = 255), - rgb(254, 204, 92, maxColorValue = 255), - rgb(253, 141, 60, maxColorValue = 255), - rgb(240, 59, 32, maxColorValue = 255), - rgb(189, 0, 38, maxColorValue = 255), - "#660000" - ) + ) + } else + { + c( + rgb(255, 255, 178, maxColorValue = 255), + rgb(254, 204, 92, maxColorValue = 255), + rgb(253, 141, 60, maxColorValue = 255), + rgb(240, 59, 32, maxColorValue = 255), + rgb(189, 0, 38, maxColorValue = 255), + "#660000" + ) - } + } } #' @export -convert_vector_to_month_initials <- function(month_vector) { +convert_vector_to_month_initials <- function(month_vector) +{ # Ensure the vector is treated as a sequence, including wrapping cases seq_length <- length(month_vector) - if (seq_length > 1) { + if (seq_length > 1) + { # For sequences like 12:3, generate a wrapping sequence expanded_vector <- - if (month_vector[1] > month_vector[seq_length]) { + if (month_vector[1] > month_vector[seq_length]) + { c(month_vector[1]:12, 1:month_vector[seq_length]) - } else { + } else + { month_vector[1]:month_vector[seq_length] } - } else { + } else + { expanded_vector <- month_vector } @@ -502,91 +434,161 @@ convert_vector_to_month_initials <- function(month_vector) { #' @export -spatial_prep = function(data, index, proj = F, stat, ensemble) { - if (ensemble) { - cli::cli_text( - paste0( - "{cli::symbol$arrow_right}", - " Visualizing ensemble ", - stat, - if (!proj) - " and agreement in the sign of change" - else - "" +spatial_prep = function(data, + index, + ccs_sign = F, + stat, + ensemble, + obs = F, + trends = F) { + if (!obs) { + if (ensemble) { + cli::cli_text( + paste0( + "{cli::symbol$arrow_right}", + " Visualizing ensemble ", + stat, + if (ccs_sign) + " and agreement in the sign of change" + else + "" + ) ) - ) - } else { - cli::cli_text( - paste0( - "{cli::symbol$arrow_right} Visualizing individual members, argument stat is ignored.", - if (!proj) - "To visualize model agreement set ensemble to F " - else - "" + } else { + cli::cli_text( + paste0( + "{cli::symbol$arrow_right} Visualizing individual members, argument stat is ignored.", + if (ccs_sign) + "To visualize model agreement set ensemble to F " + else + "" + ) ) - ) - } - - rsts = data[[index]] - - rs_df <- - terra::as.data.frame(rsts, xy = TRUE, na.rm = TRUE) %>% - tidyr::pivot_longer(cols = 3:ncol(.), - values_to = "value", - names_to = "long_name") %>% { - if (ensemble) { - # Extract scenario and time frame from column names - tidyr::separate_wider_delim( - ., - long_name, - delim = "_", - names = c("scenario", "time_frame", "season") - ) %>% - # Replace "." with "-" in time frame - dplyr::mutate(., time_frame = stringr::str_replace(time_frame, "\\.", "-")) - - } else { - # Extract Member, scenario and time frame from column names - tidyr::separate_wider_delim( - ., - long_name, - delim = "_", - names = c("member", "scenario", "time_frame", "season") - ) %>% - # Replace "." with "-" in time frame - dplyr::mutate(., time_frame = stringr::str_replace(time_frame, "\\.", "-")) + } - } - } - if (!proj) { - rs_df_sign <- - terra::as.data.frame(data[[4]], xy = TRUE, na.rm = TRUE) %>% + rs_df <- + terra::as.data.frame(data[[index]], xy = TRUE, na.rm = TRUE) %>% tidyr::pivot_longer(cols = 3:ncol(.), values_to = "value", - names_to = "long_name") %>% - # Extract scenario and time frame from column names - tidyr::separate_wider_delim( - ., - long_name, - delim = "_", - names = c("scenario", "time_frame", "season") - ) %>% - # Replace "." with "-" in time frame - dplyr::mutate(., time_frame = stringr::str_replace(time_frame, "\\.", "-")) + names_to = "long_name") %>% { + if (ensemble) + { + # Extract scenario and time frame from column names + tidyr::separate_wider_delim( + ., + long_name, + delim = "_", + names = c("scenario", "time_frame", "season") + ) %>% + # Replace "." with "-" in time frame + dplyr::mutate(., time_frame = stringr::str_replace(time_frame, "\\.", "-")) + + } else + { + # Extract Member, scenario and time frame from column names + tidyr::separate_wider_delim( + ., + long_name, + delim = "_", + names = c("member", "scenario", "time_frame", "season") + ) %>% + # Replace "." with "-" in time frame + dplyr::mutate(., time_frame = stringr::str_replace(time_frame, "\\.", "-")) + + } + } + + if (ccs_sign) { + rs_df_sign <- + terra::as.data.frame(data[[4]], xy = TRUE, na.rm = TRUE) %>% + tidyr::pivot_longer( + cols = 3:ncol(.), + values_to = "value", + names_to = "long_name" + ) %>% + # Extract scenario and time frame from column names + tidyr::separate_wider_delim( + ., + long_name, + delim = "_", + names = c("scenario", "time_frame", "season") + ) %>% + # Replace "." with "-" in time frame + dplyr::mutate(., time_frame = stringr::str_replace(time_frame, "\\.", "-")) - return(list(rs_df, rs_df_sign)) + return(list(rs_df, rs_df_sign)) + } else { + return(list(rs_df)) + } } else { - return(list(rs_df)) + # when obs is TRUE + if (!trends) { + cli::cli_text(paste0( + "{cli::symbol$arrow_right}", + " Visualizing observational dataset " + )) + + cli::cli_alert_warning(" Argument ensemble and stat are ignored") + rs_df <- + terra::as.data.frame(data[[index]], xy = TRUE, na.rm = TRUE) %>% + tidyr::pivot_longer( + cols = 3:ncol(.), + values_to = "value", + names_to = "long_name" + ) %>% + # Extract scenario and time frame from column names + tidyr::separate_wider_delim( + long_name, + delim = "_", + names = c("scenario", "time_frame", "season") + ) %>% + # Replace "." with "-" in time frame + dplyr::mutate(., time_frame = stringr::str_replace(time_frame, "\\.", "-")) + return(list(rs_df)) + + } else { + # linear regression for observations + cli::cli_text( + paste0( + "{cli::symbol$arrow_right}", + " Visualizing linear regression results for the observational dataset " + ) + ) + + cli::cli_alert_warning(" Argument ensemble and stat are ignored") + + rs_df <- + purrr::map( + data[1:2], + ~ terra::as.data.frame(.x, xy = TRUE, na.rm = TRUE) %>% + tidyr::pivot_longer( + cols = 3:ncol(.), + values_to = "value", + names_to = "long_name", + ) %>% + tidyr::separate_wider_delim( + ., + long_name, + delim = "_", + names = c("scenario", "type", "time_frame", "season") + ) %>% + # Replace "." with "-" in time frame + dplyr::mutate(., time_frame = stringr::str_replace(time_frame, "\\.", "-")) + ) + + return(rs_df) + } } } + #' @export spatial_plot = function(spatial_data, sign, @@ -596,7 +598,10 @@ spatial_plot = function(spatial_data, n.bins, alpha, plot_titles, - legend_range) { + legend_range, + obs = F, + trends = F) +{ # Suppress warnings options(warn = -1) @@ -616,114 +621,298 @@ spatial_plot = function(spatial_data, else legend_range - p <- ggplot2::ggplot() + - ggplot2::geom_sf( - fill = 'white', - color = "black", - data = countries, - alpha = 0.5 - ) + - ggplot2::geom_raster(ggplot2::aes(x = x, y = y, fill = value), - data = spatial_data[[1]], - alpha = alpha) + - ggplot2::geom_sf(fill = NA, - color = "black", - data = countries) + - { - if (!bins) { - ggplot2::scale_fill_gradientn( - colors = palette, - limits = legend_range, - na.value = "transparent", - n.breaks = 10, - guide = ggplot2::guide_colourbar( - ticks.colour = "black", - ticks.linewidth = 1, - title.position = "top", - title.hjust = 0.5 - ) - ) - } else { - ggplot2::scale_fill_stepsn( - colors = colors, - limits = legend_range, - na.value = "transparent", - n.breaks = ifelse(is.null(n.bins), 10, n.bins), - guide = ggplot2::guide_colourbar( - ticks.colour = "black", - ticks.linewidth = 1, - title.position = "top", - title.hjust = 0.5 + if (!obs) + { + p <- ggplot2::ggplot() + + ggplot2::geom_sf( + fill = 'white', + color = "black", + data = countries, + alpha = 0.5 + ) + + ggplot2::geom_raster(ggplot2::aes(x = x, y = y, fill = value), + data = spatial_data[[1]], + alpha = alpha) + + ggplot2::geom_sf(fill = NA, + color = "black", + data = countries) + { + if (!bins) + { + ggplot2::scale_fill_gradientn( + colors = palette, + limits = legend_range, + na.value = "transparent", + n.breaks = 10, + guide = ggplot2::guide_colourbar( + ticks.colour = "black", + ticks.linewidth = 1, + title.position = "top", + title.hjust = 0.5 + ) + ) + } else + { + ggplot2::scale_fill_stepsn( + colors = colors, + limits = legend_range, + na.value = "transparent", + n.breaks = ifelse(is.null(n.bins), 10, n.bins), + guide = ggplot2::guide_colourbar( + ticks.colour = "black", + ticks.linewidth = 1, + title.position = "top", + title.hjust = 0.5 + ) + ) + } + } + + ggplot2::coord_sf( + xlim = c( + range(spatial_data[[1]]$x)[[1]] - 0.5, + range(spatial_data[[1]]$x)[[2]] + 0.5 + ), + ylim = c( + range(spatial_data[[1]]$y)[[1]] - 0.5, + range(spatial_data[[1]]$y)[[2]] + 0.5 + ), + expand = F, + ndiscr = 500 + ) + { + if (ensemble) + { + ggh4x::facet_nested(scenario ~ season) + } else + { + ggh4x::facet_nested(scenario ~ season + member) + } + } + + ggplot2::labs(fill = plot_titles, x = "", y = "") + + ggplot2::theme_bw() + + ggplot2::theme( + plot.background = ggplot2::element_blank(), + panel.background = ggplot2::element_blank(), + panel.border = ggplot2::element_blank(), + panel.grid.major = ggplot2::element_blank(), + panel.grid.minor = ggplot2::element_blank(), + axis.text.x = ggplot2::element_blank(), + axis.text.y = ggplot2::element_blank(), + axis.ticks = ggplot2::element_blank(), + axis.title = ggplot2::element_blank(), + legend.position = if (ensemble) + "right" + else + "bottom", + legend.direction = if (ensemble) + "vertical" + else + "horizontal", + legend.key.height = if (ensemble) + ggplot2::unit(1.2, 'cm') + else + ggplot2::unit(0.3, 'cm'), + legend.key.width = if (ensemble) + ggplot2::unit(0.3, 'cm') + else + ggplot2::unit(2, 'cm'), + legend.box.spacing = ggplot2::unit(0, "pt"), + legend.text = if (ensemble) + NULL + else + ggplot2::element_text(angle = 45, hjust = 1) + ) + { + if (sign) + ggplot2::geom_point( + data = dplyr::filter(spatial_data[[2]], value == 1), + size = 0.1, + alpha = 0.4, + color = "black", + ggplot2::aes(x, y) ) - ) + } - } + - ggplot2::coord_sf( - xlim = c(range(spatial_data[[1]]$x)[[1]] - 0.5, - range(spatial_data[[1]]$x)[[2]] + 0.5), - ylim = c(range(spatial_data[[1]]$y)[[1]] - 0.5, - range(spatial_data[[1]]$y)[[2]] + 0.5), - expand = F, - ndiscr = 500 - ) + + + return(p) + + } else + { + # when obs is TRUE + + if (!trends) { - if (ensemble) { - ggh4x::facet_nested(scenario ~ season) - } else { - ggh4x::facet_nested(scenario ~ season + member) - } - } + - ggplot2::labs(fill = plot_titles, x = "", y = "") + - ggplot2::theme_bw() + - ggplot2::theme( - plot.background = ggplot2::element_blank(), - panel.background = ggplot2::element_blank(), - panel.border = ggplot2::element_blank(), - panel.grid.major = ggplot2::element_blank(), - panel.grid.minor = ggplot2::element_blank(), - axis.text.x = ggplot2::element_blank(), - axis.text.y = ggplot2::element_blank(), - axis.ticks = ggplot2::element_blank(), - axis.title = ggplot2::element_blank(), - legend.position = if (ensemble) - "right" - else - "bottom", - legend.direction = if (ensemble) - "vertical" - else - "horizontal", - legend.key.height = if (ensemble) - ggplot2::unit(1.2, 'cm') - else - ggplot2::unit(0.3, 'cm'), - legend.key.width = if (ensemble) - ggplot2::unit(0.3, 'cm') - else - ggplot2::unit(2, 'cm'), - legend.box.spacing = ggplot2::unit(0, "pt"), - legend.text = if (ensemble) - NULL - else - ggplot2::element_text(angle = 45, hjust = 1) - ) + + p <- ggplot2::ggplot() + + ggplot2::geom_sf( + fill = 'white', + color = "black", + data = countries, + alpha = 0.5 + ) + + ggplot2::geom_raster(ggplot2::aes(x = x, y = y, fill = value), + data = spatial_data[[1]], + alpha = alpha) + + ggplot2::geom_sf(fill = NA, + color = "black", + data = countries) + { + if (!bins) + { + ggplot2::scale_fill_gradientn( + colors = palette, + limits = legend_range, + na.value = "transparent", + n.breaks = 10, + guide = ggplot2::guide_colourbar( + ticks.colour = "black", + ticks.linewidth = 1, + title.position = "top", + title.hjust = 0.5, + label.hjust = 1 + ) + ) + } else + { + ggplot2::scale_fill_stepsn( + colors = palette, + limits = legend_range, + na.value = "transparent", + n.breaks = ifelse(is.null(n.bins), 10, n.bins), + guide = ggplot2::guide_colourbar( + ticks.colour = "black", + ticks.linewidth = 1, + title.position = "top", + title.hjust = 0.5, + label.hjust = 1 + ) + ) + + } + + } + + ggplot2::coord_sf( + xlim = c( + range(spatial_data[[1]]$x)[[1]] - 0.5, + range(spatial_data[[1]]$x)[[2]] + 0.5 + ), + ylim = c( + range(spatial_data[[1]]$y)[[1]] - 0.5, + range(spatial_data[[1]]$y)[[2]] + 0.5 + ), + expand = F, + ndiscr = 500 + ) + + ggh4x::facet_nested(scenario ~ season) + + ggplot2::labs(fill = plot_titles, x = "", y = "") + + ggplot2::theme_bw() + + ggplot2::theme( + strip.text.y = ggplot2::element_blank(), + plot.background = ggplot2::element_blank(), + panel.background = ggplot2::element_blank(), + panel.border = ggplot2::element_blank(), + panel.grid.major = ggplot2::element_blank(), + panel.grid.minor = ggplot2::element_blank(), + axis.text.x = ggplot2::element_blank(), + axis.text.y = ggplot2::element_blank(), + axis.ticks = ggplot2::element_blank(), + axis.title = ggplot2::element_blank(), + legend.position = "right", + legend.key.height = ggplot2::unit(1, 'cm'), + legend.key.width = ggplot2::unit(0.3, 'cm'), + legend.box.spacing = ggplot2::unit(0.2, "pt") + ) + + return(p) + } else { - if (sign) + # when linear regression is visualized + + p <- ggplot2::ggplot() + + ggplot2::geom_sf( + fill = 'white', + color = "black", + data = countries, + alpha = 0.5 + ) + + ggplot2::geom_raster(ggplot2::aes(x = x, y = y, fill = value), + data = spatial_data[[1]], + alpha = alpha) + + ggplot2::geom_sf(fill = NA, + color = "black", + data = countries) + { + if (!bins) + { + ggplot2::scale_fill_gradientn( + colors = palette, + limits = legend_range, + na.value = "transparent", + n.breaks = 10, + guide = ggplot2::guide_colourbar( + ticks.colour = "black", + ticks.linewidth = 1, + title.position = "top", + title.hjust = 0.5 + ) + ) + } else + { + ggplot2::scale_fill_stepsn( + colors = palette, + limits = legend_range, + na.value = "transparent", + n.breaks = ifelse(is.null(n.bins), 10, n.bins), + guide = ggplot2::guide_colourbar( + ticks.colour = "black", + ticks.linewidth = 1, + title.position = "top", + title.hjust = 0.5 + ) + ) + } + } + ggplot2::geom_point( - data = dplyr::filter(spatial_data[[2]], value == 1), + data = dplyr::filter(spatial_data[[2]], value < 0.05), size = 0.1, alpha = 0.4, color = "black", ggplot2::aes(x, y) + ) + + ggplot2::coord_sf( + xlim = c( + range(spatial_data[[2]]$x)[[1]] - 0.5, + range(spatial_data[[2]]$x)[[2]] + 0.5 + ), + ylim = c( + range(spatial_data[[2]]$y)[[1]] - 0.5, + range(spatial_data[[2]]$y)[[2]] + 0.5 + ), + expand = F, + ndiscr = 500 + ) + + ggh4x::facet_nested(scenario ~ season) + + ggplot2::labs(fill = plot_titles, x = "", y = "") + + ggplot2::theme_bw() + + ggplot2::theme( + strip.text.y = ggplot2::element_blank(), + plot.background = ggplot2::element_blank(), + panel.background = ggplot2::element_blank(), + panel.border = ggplot2::element_blank(), + panel.grid.major = ggplot2::element_blank(), + panel.grid.minor = ggplot2::element_blank(), + axis.text.x = ggplot2::element_blank(), + axis.text.y = ggplot2::element_blank(), + axis.ticks = ggplot2::element_blank(), + axis.title = ggplot2::element_blank(), + legend.position = "right", + legend.key.height = ggplot2::unit(1, 'cm'), + legend.key.width = ggplot2::unit(0.3, 'cm'), + legend.box.spacing = ggplot2::unit(0.2, "pt") ) - } + return(p) - return(p) -} + } + } +} #' @export temporal_plot = function(data, @@ -732,120 +921,191 @@ temporal_plot = function(data, spatial.aggr = F, plot_titles, palette, - legend_range) { - cli::cli_alert_warning(" Arguments stat, bins,n.bins and alpha are ignored") - - palette <- - if (is.null(palette)) - RColorBrewer::brewer.pal(min(length(unique(data[[index]]$experiment)), RColorBrewer::brewer.pal.info["Set2", "maxcolors"]), "Set2") - else - palette - - df.processed <- if (spatial.aggr) { + legend_range, + obs = F) +{ + df.processed <- if (spatial.aggr) + { + cli::cli_text(paste0( + "{cli::symbol$arrow_right}", + " Visualizing annual time series " + )) data[[index]] %>% dplyr::group_by(date, experiment, Var1, season) %>% dplyr::summarise(value = median(value)) # spatial aggregation - } else { + } else + { + cli::cli_text(paste0( + "{cli::symbol$arrow_right}", + " Visualizing annual anomaly time series " + )) data[[index]] } - if (ensemble) { - p <- df.processed %>% - dplyr::group_by(date, experiment, season) %>% - dplyr::summarise(sd = sd(value), - value = mean(value)) %>% - ggplot2::ggplot() + - ggplot2::geom_line( - ggplot2::aes(y = value, - x = date, - color = experiment), - linetype = "dotted", - alpha = 0.5, - linewidth = 0.9 - ) + - ggplot2::geom_smooth( - ggplot2::aes(y = value, - x = date, - color = experiment), - se = F, - linewidth = 1, - method = "gam", - formula = y ~ x - ) + - ggplot2::geom_ribbon( - ggplot2::aes( - y = value, - x = date, - ymin = value - sd, - ymax = value + sd, - fill = experiment - ), - alpha = 0.15, - show.legend = F - ) + - ggplot2::facet_wrap(season ~ .) + - ggplot2::scale_x_date(date_breaks = "4 years", date_labels = "%Y") + - ggplot2::theme_bw() + - ggplot2::theme( - legend.position = "bottom", - axis.text.x = ggplot2::element_text(angle = 45, hjust = 1), - legend.title = ggplot2::element_blank(), - panel.grid.major = ggplot2::element_blank(), - panel.grid.minor = ggplot2::element_blank() - ) + - ggplot2::labs(x = "Year", y = plot_titles) + - ggplot2::scale_color_manual(values = palette) + - ggplot2::scale_fill_manual(values = palette) + - if (!is.null(legend_range)) { - ggplot2::xlim(legend_range[1], legend_range[2]) - } - - return(p) + if (!obs) + { + palette <- + if (is.null(palette)) + RColorBrewer::brewer.pal(min(length(unique( + data[[index]]$experiment + )), RColorBrewer::brewer.pal.info["Set2", "maxcolors"]), + "Set2") + else + palette + cli::cli_alert_warning(" Arguments stat, bins,n.bins and alpha are ignored") + if (ensemble) + { + p <- df.processed %>% + dplyr::group_by(date, experiment, season) %>% + dplyr::summarise(sd = sd(value), + value = mean(value)) %>% + ggplot2::ggplot() + + ggplot2::geom_line( + ggplot2::aes(y = value, + x = date, + color = experiment), + linetype = "dotted", + alpha = 0.5, + linewidth = 0.9 + ) + + ggplot2::geom_smooth( + ggplot2::aes(y = value, + x = date, + color = experiment), + se = F, + linewidth = 1, + method = "gam", + formula = y ~ x + ) + + ggplot2::geom_ribbon( + ggplot2::aes( + y = value, + x = date, + ymin = value - sd, + ymax = value + sd, + fill = experiment + ), + alpha = 0.15, + show.legend = F + ) + + ggplot2::facet_wrap(season ~ .) + + ggplot2::scale_x_date(date_breaks = "4 years", date_labels = "%Y") + + ggplot2::theme_bw() + + ggplot2::theme( + legend.position = "bottom", + axis.text.x = ggplot2::element_text(angle = 45, hjust = 1), + legend.title = ggplot2::element_blank(), + panel.grid.major = ggplot2::element_blank(), + panel.grid.minor = ggplot2::element_blank() + ) + + ggplot2::labs(x = "Year", y = plot_titles) + + ggplot2::scale_color_manual(values = palette) + + ggplot2::scale_fill_manual(values = palette) + + if (!is.null(legend_range)) + { + ggplot2::ylim(legend_range[1], legend_range[2]) + } + + return(p) + + + } else + { + # individual models + p <- df.processed %>% + ggplot2::ggplot() + + ggplot2::geom_line( + ggplot2::aes(y = value, + x = date, + color = experiment), + linetype = "dotted", + alpha = 0.7 + ) + + ggplot2::geom_smooth( + ggplot2::aes(y = value, + x = date, + color = experiment), + se = F, + linewidth = 0.5, + method = "gam", + formula = y ~ x + ) + + ggplot2::facet_grid(season ~ Var1) + + ggplot2::scale_x_date(date_breaks = "4 years", date_labels = "%Y") + + ggplot2::theme_bw() + + ggplot2::theme( + legend.position = "bottom", + axis.text.x = ggplot2::element_text(angle = 45, hjust = 1), + legend.title = ggplot2::element_blank(), + panel.grid.major = ggplot2::element_blank(), + panel.grid.minor = ggplot2::element_blank() + ) + + ggplot2::labs(x = "Year", y = plot_titles) + + ggplot2::scale_color_manual(values = palette) + + ggplot2::scale_fill_manual(values = palette) + + if (!is.null(legend_range)) + { + ggplot2::ylim(legend_range[1], legend_range[2]) + } + + return(p) + } + } else + { + # when obs is TRUE + palette <- if (is.null(palette)) + "black" + else + palette - } else { - # individual models + cli::cli_alert_warning(" Arguments ensemble,bins,n.bins and alpha are ignored") p <- df.processed %>% + dplyr::group_by(date, experiment, season) %>% + dplyr::summarise(value = mean(value)) %>% ggplot2::ggplot() + ggplot2::geom_line( ggplot2::aes(y = value, x = date, color = experiment), linetype = "dotted", - alpha = 0.7 + alpha = 0.7, + linewidth = 0.7 ) + ggplot2::geom_smooth( ggplot2::aes(y = value, x = date, color = experiment), se = F, - linewidth = 0.5, + linewidth = 0.8, method = "gam", formula = y ~ x ) + - ggplot2::facet_grid(season ~ Var1) + + ggplot2::facet_wrap( ~ season) + ggplot2::scale_x_date(date_breaks = "4 years", date_labels = "%Y") + ggplot2::theme_bw() + ggplot2::theme( - legend.position = "bottom", + legend.position = "none", axis.text.x = ggplot2::element_text(angle = 45, hjust = 1), - legend.title = ggplot2::element_blank(), panel.grid.major = ggplot2::element_blank(), panel.grid.minor = ggplot2::element_blank() ) + ggplot2::labs(x = "Year", y = plot_titles) + ggplot2::scale_color_manual(values = palette) + - ggplot2::scale_fill_manual(values = palette) + - if (!is.null(legend_range)) { - ggplot2::xlim(legend_range[1], legend_range[2]) + if (!is.null(legend_range)) + { + ggplot2::ylim(legend_range[1], legend_range[2]) } return(p) + } + } + #' @export spatiotemporal_plot = function(data, @@ -854,60 +1114,120 @@ spatiotemporal_plot = function(data, plot_titles, palette, legend_range, - n.groups) { - cli::cli_alert_warning( - " Arguments bins, stat and alpha are ignored. Change number of group intervals with n.groups" - ) + n.groups, + obs = F) +{ + cli::cli_text(paste0("{cli::symbol$arrow_right}", + " Visualizing frequencies ")) + + if (!obs) + { + cli::cli_alert_warning( + " Arguments bins, stat and alpha are ignored. Change number of group intervals with n.groups" + ) - palette <- - if (is.null(palette)) - RColorBrewer::brewer.pal(min(length(unique(data[[index]]$experiment)), RColorBrewer::brewer.pal.info["Set2", "maxcolors"]), "Set2") - else - palette - if (ensemble) { - p <- - ridgeline( - data[[index]], - group_col = 'date', - z_col = 'value', - num_grps = n.groups, - fill = 'experiment', - facet1 = 'season' - ) + - ggplot2::theme_bw() + - ggplot2::theme(legend.position = "bottom", - legend.title = ggplot2::element_blank()) + - ggplot2::labs(x = plot_titles) + - ggplot2::scale_fill_manual(values = palette) + - if (!is.null(legend_range)) { - ggplot2::xlim(legend_range[1], legend_range[2]) - } + palette <- + if (is.null(palette)) + RColorBrewer::brewer.pal(min(length(unique( + data[[index]]$experiment + )), RColorBrewer::brewer.pal.info["Set2", "maxcolors"]), + "Set2") + else + palette - return(p) + if (ensemble) + { + p <- + suppressWarnings( + suppressMessages( + ridgeline( + data[[index]], + group_col = 'date', + z_col = 'value', + num_grps = n.groups, + fill = 'experiment', + facet1 = 'season' + ) + + ggplot2::theme_bw() + + ggplot2::theme( + legend.position = "bottom", + legend.title = ggplot2::element_blank() + ) + + ggplot2::labs(x = plot_titles) + + ggplot2::scale_fill_manual(values = palette) + + if (!is.null(legend_range)) + { + ggplot2::xlim(legend_range[1], legend_range[2]) + } + ) + ) + + return(p) + + } else + { + # when ensemble is FALSE for individual models and spatiotemporal + p <- + suppressWarnings( + suppressMessages( + ridgeline( + data[[index]], + group_col = 'date', + z_col = 'value', + num_grps = n.groups, + fill = 'experiment', + facet1 = 'Var1', + facet2 = 'season' + ) + + ggplot2::theme_bw() + + ggplot2::theme( + legend.position = "bottom", + legend.title = ggplot2::element_blank() + ) + + ggplot2::labs(x = plot_titles) + + ggplot2::scale_fill_manual(values = palette) + + if (!is.null(legend_range)) + { + ggplot2::xlim(legend_range[1], legend_range[2]) + } + ) + ) + + return(p) + + } + + } else + { + # when obs is TRUE + cli::cli_alert_warning( + " Arguments bins,palette, n.bins,alpha and ensemble are ignored. Change number of group intervals with n.groups" + ) - } else { - # when ensemble is FALSE for individual models and spatiotemporal p <- - ridgeline( - data[[index]], - group_col = 'date', - z_col = 'value', - num_grps = n.groups, - fill = 'experiment', - facet1 = 'Var1', - facet2 = 'season' - ) + - ggplot2::theme_bw() + - ggplot2::theme(legend.position = "bottom", - legend.title = ggplot2::element_blank()) + - ggplot2::labs(x = plot_titles) + - ggplot2::scale_fill_manual(values = palette) + - if (!is.null(legend_range)) { - ggplot2::xlim(legend_range[1], legend_range[2]) - } + suppressWarnings( + suppressMessages( + ridgeline( + data[[index]], + group_col = 'date', + z_col = 'value', + num_grps = n.groups, + facet1 = 'season' + ) + + ggplot2::theme_bw() + + ggplot2::theme(legend.position = "none") + + ggplot2::labs(x = plot_titles) + + if (!is.null(legend_range)) + { + ggplot2::xlim(legend_range[1], legend_range[2]) + } + ) + ) return(p) + } + } diff --git a/README.md b/README.md index 482244d..fcbbd0a 100644 --- a/README.md +++ b/README.md @@ -136,13 +136,13 @@ sudo apt-get install snapd # if not already installed sudo snap install docker -sudo docker pull docker.io/rso9192/cava:version2.1.0 +sudo docker pull docker.io/rso9192/cava:version3.0.0 sudo docker run --rm \ -p 8888:8787 \ -e PASSWORD=password \ -v /path/to/local/directory:/home \ - rso9192/cava:version2.1.0 + rso9192/cava:version3.0.0 ``` @@ -153,7 +153,7 @@ sudo docker run --rm \ -p 8888:8787 \ -e PASSWORD=password \ -v /home/Desktop/CAVA_results:/home \ - rso9192/cava:version2.1.0 + rso9192/cava:version3.0.0 ``` @@ -181,7 +181,7 @@ sudo docker run --rm \ -p 8888:8787 \ -e PASSWORD=password \ -v /mnt/c/Users/my_username/Desktop/CAVA_results:/home \ - rso9192/cava:version2.1.0 + rso9192/cava:version3.0.0 ``` Now open your favorite browser and type **http://localhost:8888/**. You should see a login page: enter the **username "rstudio"** and **password "password"** to login and that's it! You can now use CAVAanalytics through Rstudio server. @@ -193,7 +193,7 @@ If you are using a Mac, you first need to install [Docker desktop for Mac](https Then open a terminal and while Docker Desktop is open, run: ``` -sudo docker pull docker.io/rso9192/cava:version2.1.0 +sudo docker pull docker.io/rso9192/cava:version3.0.0 ``` At this point, you can run the Docker image with the below comand. @@ -203,7 +203,7 @@ sudo docker run --rm \ -p 8888:8787 \ -e PASSWORD=password \ -v /path/to/local/directory:/home \ - rso9192/cava:version2.1.0 + rso9192/cava:version3.0.0 ``` Remember to replace **/path/to/local/directory** with the local directory on your host machine where you want to save your plots or data. Now open your favorite browser and type **http://localhost:8888/**. You should see a login page: enter the **username "rstudio"** and **password "password"** to login and that's it! You can now use CAVAanalytics through Rstudio server. diff --git a/docs/articles/Introduction.html b/docs/articles/Introduction.html index b0228f1..a1740ba 100644 --- a/docs/articles/Introduction.html +++ b/docs/articles/Introduction.html @@ -203,7 +203,7 @@

Observations
 observations(kenya_exmp, season=list(1:12), uppert=35,trends=T) %>% 
-plotting(., plot_titles = "N.days > 35/year")
+plotting(., plot_titles = "N.days > 35/year", palette=IPCC_palette(type="tmp", divergent = T), legend_range = c(-3,3))

@@ -273,11 +273,19 @@

Projections= "N > 35 bc", palette=c("white", "orange", "red", "darkred"), legend_range = c(0, 180))

-

The results can also be visualized temporally.

+

The results can also be visualized for the annual time series (data +is spatially aggregated).

 plotting(proj_kenya_35bc, ensemble=T,  
-plot_titles = "N > 35 bc", temporal=T)
+plot_titles = "N > 35 bc", temporal=T, palette=c("blue", "red"))

+

and without spatial or temporal aggregation. In this case we are +looking at the frequency distribution of the yearly data across all +pixels

+
+plotting(proj_kenya_35bc, ensemble=T,  
+plot_titles = "N > 35 bc", spatiotemporal=T, palette=c("blue", "red"))
+

Climate change signal @@ -286,17 +294,36 @@

Climate change signal +
+ccs_kenya <- climate_change_signal(kenya_exmp, season=list(1:12))
+plotting(ccs_kenya, ensemble=F, plot_titles = "Mean tasmax change", 
+legend_range = c(-3, 3), 
+palette = c("blue", "cyan", "green", "white", "yellow" ,"orange", "red"))
+

+

+
+

Climate change signal +

+

While analyzing future periods can be useful, more often we +prioritize understanding delta changes, which represent the relative +increase or decrease in mean maximum temperatures compared to a +baseline. CAVAanalytics facilitates this analysis as well.

To notice that the function climate_change_signal also calculates the agreement in the sign of the change. Basically, with a threshold of 0.8, it means that if 80% of the models agree that the climate change signal is positive or negative, the pixel gets a score of 1. These results are visualized through a black dot.

-
+
 ccs_kenya <- climate_change_signal(kenya_exmp, season=list(1:6,7:12), threshold = 0.8)
+
 plotting(ccs_kenya, plot_titles = "Mean tasmax change", 
 legend_range = c(-3, 3), 
 palette = IPCC_palette(type = "tmp", divergent = T))

-

+

+
Anomalies can also be visualized for the annual time series

+
+plotting(ccs_kenya, plot_titles = "Annual anomalies", temporal=T, palette=c("blue", "red"))

+
diff --git a/docs/articles/Introduction_files/figure-html/unnamed-chunk-18-1.png b/docs/articles/Introduction_files/figure-html/unnamed-chunk-18-1.png index 394132a..065fdbf 100644 Binary files a/docs/articles/Introduction_files/figure-html/unnamed-chunk-18-1.png and b/docs/articles/Introduction_files/figure-html/unnamed-chunk-18-1.png differ diff --git a/docs/articles/Introduction_files/figure-html/unnamed-chunk-19-1.png b/docs/articles/Introduction_files/figure-html/unnamed-chunk-19-1.png index 5a5fb9e..93a63ba 100644 Binary files a/docs/articles/Introduction_files/figure-html/unnamed-chunk-19-1.png and b/docs/articles/Introduction_files/figure-html/unnamed-chunk-19-1.png differ diff --git a/docs/articles/Introduction_files/figure-html/unnamed-chunk-20-1.png b/docs/articles/Introduction_files/figure-html/unnamed-chunk-20-1.png index 1e0c3e5..394132a 100644 Binary files a/docs/articles/Introduction_files/figure-html/unnamed-chunk-20-1.png and b/docs/articles/Introduction_files/figure-html/unnamed-chunk-20-1.png differ diff --git a/docs/articles/Introduction_files/figure-html/unnamed-chunk-21-1.png b/docs/articles/Introduction_files/figure-html/unnamed-chunk-21-1.png new file mode 100644 index 0000000..6fe570e Binary files /dev/null and b/docs/articles/Introduction_files/figure-html/unnamed-chunk-21-1.png differ diff --git a/docs/articles/Introduction_files/figure-html/unnamed-chunk-9-1.png b/docs/articles/Introduction_files/figure-html/unnamed-chunk-9-1.png index 76d4a18..9ab9327 100644 Binary files a/docs/articles/Introduction_files/figure-html/unnamed-chunk-9-1.png and b/docs/articles/Introduction_files/figure-html/unnamed-chunk-9-1.png differ diff --git a/docs/articles/more_advanced.html b/docs/articles/more_advanced.html index 55b392a..1bf23cc 100644 --- a/docs/articles/more_advanced.html +++ b/docs/articles/more_advanced.html @@ -191,18 +191,6 @@

Real examplesplotting(hwvs, plot_titles = "N° of heat waves", ensemble = T, palette = c("white", "orange", "red", "darkred", "brown"))

-

and their temporal

-
-
-plotting(hwvs, plot_titles = "N° of heat waves", ensemble = T, temporal=T)
-

-

and spatiotemporal evolution. The option spatiotemporal allows users -to focus on spatial and temporal changes by temporal breaks controlled -by the n.groups argument.

-
-
-plotting(hwvs, plot_titles = "N° of heat waves", ensemble = T, spatiotemporal=T, n.groups=2)
-

diff --git a/docs/index.html b/docs/index.html index 294112f..8ca020f 100644 --- a/docs/index.html +++ b/docs/index.html @@ -199,13 +199,13 @@

Linux # if not already installed sudo snap install docker -sudo docker pull docker.io/rso9192/cava:version2.1.0 +sudo docker pull docker.io/rso9192/cava:version3.0.0 sudo docker run --rm \ -p 8888:8787 \ -e PASSWORD=password \ -v /path/to/local/directory:/home \ - rso9192/cava:version2.1.0 + rso9192/cava:version3.0.0

Replace /path/to/local/directory with the local directory on your host machine where you want to save your plots or data. For example, you can create a folder on your Desktop called CAVA_results. Then, you would run the above command as:

@@ -213,7 +213,7 @@
Linux -p 8888:8787 \ -e PASSWORD=password \ -v /home/Desktop/CAVA_results:/home \ - rso9192/cava:version2.1.0 + rso9192/cava:version3.0.0

Now open your favorite browser and type http://localhost:8888/. You should see a login page: enter the username “rstudio” and password “password” to login and that’s it! You can now use CAVAanalytics through Rstudio server.

@@ -229,7 +229,7 @@
Windows + rso9192/cava:version3.0.0

Now open your favorite browser and type http://localhost:8888/. You should see a login page: enter the username “rstudio” and password “password” to login and that’s it! You can now use CAVAanalytics through Rstudio server.

@@ -237,13 +237,13 @@
Mac

If you are using a Mac, you first need to install Docker desktop for Mac.

Then open a terminal and while Docker Desktop is open, run:

-
sudo docker pull docker.io/rso9192/cava:version2.1.0
+
sudo docker pull docker.io/rso9192/cava:version3.0.0

At this point, you can run the Docker image with the below comand.

sudo docker run --rm \
            -p 8888:8787 \
            -e PASSWORD=password \
            -v /path/to/local/directory:/home \
-           rso9192/cava:version2.1.0
+ rso9192/cava:version3.0.0

Remember to replace /path/to/local/directory with the local directory on your host machine where you want to save your plots or data. Now open your favorite browser and type http://localhost:8888/. You should see a login page: enter the username “rstudio” and password “password” to login and that’s it! You can now use CAVAanalytics through Rstudio server.

diff --git a/docs/news/index.html b/docs/news/index.html index 5b8f016..01c725e 100644 --- a/docs/news/index.html +++ b/docs/news/index.html @@ -74,27 +74,9 @@

CAVAanalytics 3.0.0

-

Version 3.0.0 of CAVAanalytics bring several updates:

-
-
-

CAVAanalytics 2.1.0

-

Version 2.1.0 of CAVAanalytics bring several updates:

-
-
-

CAVAanalytics 2.0.4

-

first stable release

+

Version 3.0.0 of CAVAanalytics is the first stable release. Follow the tutorial to learn how to use it.

- +