diff --git a/.buildlibrary b/.buildlibrary index e7ccef3..41420f7 100644 --- a/.buildlibrary +++ b/.buildlibrary @@ -1,4 +1,4 @@ -ValidationKey: '29744512' +ValidationKey: '30203379' AcceptedWarnings: - 'Warning: package ''.*'' was built under R version' - 'Warning: namespace ''.*'' is not available and has been replaced' diff --git a/.pre-commit-config.yaml b/.pre-commit-config.yaml index 62f13da..7ccf77e 100644 --- a/.pre-commit-config.yaml +++ b/.pre-commit-config.yaml @@ -15,7 +15,7 @@ repos: - id: mixed-line-ending - repo: https://github.com/lorenzwalthert/precommit - rev: 7910e0323d7213f34275a7a562b9ef0fde8ce1b9 # frozen: v0.4.2 + rev: bae853d82da476eee0e0a57960ee6b741a3b3fb7 # frozen: v0.4.3 hooks: - id: parsable-R - id: deps-in-desc diff --git a/CITATION.cff b/CITATION.cff index 9d8d7b9..178206e 100644 --- a/CITATION.cff +++ b/CITATION.cff @@ -2,8 +2,8 @@ cff-version: 1.2.0 message: If you use this software, please cite it using the metadata from this file. type: software title: 'mip: Comparison of multi-model runs' -version: 0.149.2 -date-released: '2024-08-01' +version: 0.151.1 +date-released: '2024-09-23' abstract: Package contains generic functions to produce comparison plots of multi-model runs. authors: diff --git a/DESCRIPTION b/DESCRIPTION index 522af62..784d24f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Type: Package Package: mip Title: Comparison of multi-model runs -Version: 0.149.2 -Date: 2024-08-01 +Version: 0.151.1 +Date: 2024-09-23 Authors@R: c( person("David", "Klein", , "dklein@pik-potsdam.de", role = c("aut", "cre")), person("Jan Philipp", "Dietrich", , "dietrich@pik-potsdam.de", role = "aut"), diff --git a/NAMESPACE b/NAMESPACE index 03bbedf..c885850 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -195,6 +195,7 @@ importFrom(stats,na.omit) importFrom(stats,reshape) importFrom(stats,runif) importFrom(stringr,str_extract) +importFrom(stringr,str_match_all) importFrom(tidyr,all_of) importFrom(tidyr,crossing) importFrom(tidyr,drop_na) diff --git a/R/extractVariableGroups.R b/R/extractVariableGroups.R index d159058..a2d6995 100644 --- a/R/extractVariableGroups.R +++ b/R/extractVariableGroups.R @@ -6,16 +6,18 @@ #' @param x a vector of variable names #' @param keepOrigNames if set, the returned list contains the original variables #' (to the value of which the grouped ones have to sum up) as names instead of -#' made up group names, if they exist. The current implementation goes up to two levels (++) deep. +#' made up group names, if they exist. +#' @param sorted boolean, indicating whether the variables within each group should be returned alp #' @return a named list of variable groups with group name as name and vector of entities as content #' @author Anastasis Giannousakis, David Klein, Jan Philipp Dietrich #' @seealso \code{\link{plotstyle.add}} +#' @importFrom stringr str_match_all #' @examples #' x <- c("a|+|1|+|aa","a|+|2|abc","a|+|1|+|bb","a|+|1|+|cc","a|+|3|+|aa","a|+|3|+|bb") #' mip::extractVariableGroups(x) #' @export -extractVariableGroups <- function(x,keepOrigNames=FALSE) { +extractVariableGroups <- function(x, keepOrigNames=FALSE, sorted = FALSE) { spltM<-function(y) { return(strsplit(y,"\\|")) @@ -33,17 +35,18 @@ extractVariableGroups <- function(x,keepOrigNames=FALSE) { gsub("\\|[\\+]{1,}","",sub(" \\(.*.\\)$","",allVars))),silent = T) if (keepOrigNames & length(ind) > 0) try(name<-allVars[[ind]],silent = T) name <- as.character(name) - out[[name]] <- c(out[[name]],x[j]) + out[[name]] <- c(out[[name]],x[j]) } } return(out) } - if (any(grepl("\\|\\+\\|",x))) { + if (any(grepl("\\|\\++\\|",x))) { + maxplus <- max(nchar(unlist(str_match_all(x, "\\++")), keepNA = FALSE)) out <- list() - for(i in 1:10) { + for(i in seq(maxplus)) { sep <- paste0("|",paste(rep("+",i),collapse=""),"|") matches <- grep(sep,x,fixed=TRUE, value = TRUE) - if(length(matches)==0) break() + if(length(matches)==0) next() ext <- ifelse(i>1,paste0(" ",i),"") out <- c(out,tmp(matches,sep=sep,ext=ext,allVars = x,keepOrigNames)) } @@ -64,5 +67,9 @@ extractVariableGroups <- function(x,keepOrigNames=FALSE) { } } } + if (isTRUE(sorted)) { + out <- out[order(names(out))] + out <- lapply(out, sort) + } return(out) } diff --git a/R/showLinePlots.R b/R/showLinePlots.R index 6094e78..7b2134b 100644 --- a/R/showLinePlots.R +++ b/R/showLinePlots.R @@ -16,6 +16,7 @@ #' Set to \code{NULL} (default) for all available data. #' @param color.dim.manual optional vector with manual colors replacing default #' colors of color.dim, default is \code{NULL}. +#' @param vlines period used for vertical line #' @inheritParams showAreaAndBarPlots #' @return \code{NULL} is returned invisible. #' @section Example Plots: @@ -39,7 +40,8 @@ showLinePlots <- function( color.dim.name = NULL, mainReg = getOption("mip.mainReg"), color.dim.manual = NULL, - histModelsExclude = NULL + histModelsExclude = NULL, + vlines = NULL ) { data <- as.quitte(data) %>% @@ -119,6 +121,9 @@ showLinePlots <- function( color.dim.manual = color.dim.manual, color.dim.manual.hist = color.dim.manual.hist[mainHistModels] ) + if (! is.null(vlines)) { + p1 <- p1 + geom_vline(xintercept = vlines, linetype = 3) + } } if (NROW(dRegiScen) == 0) { p2 <- ggplot() + theme_minimal() @@ -134,6 +139,9 @@ showLinePlots <- function( color.dim.manual = color.dim.manual, color.dim.manual.hist = color.dim.manual.hist[regiHistModels] ) + if (! is.null(vlines)) { + p2 <- p2 + geom_vline(xintercept = vlines, linetype = 3) + } } # If a legend of the plots can be used as common legend for both plots, diff --git a/R/showMultiLinePlotsByVariable.R b/R/showMultiLinePlotsByVariable.R index 09b3b1e..188731a 100644 --- a/R/showMultiLinePlotsByVariable.R +++ b/R/showMultiLinePlotsByVariable.R @@ -21,6 +21,8 @@ #' to set globally. #' @param yearsByVariable A numeric vector. The years to be marked in the plots. #' As default it uses the value globally set by \code{options(mip.yearsBarPlot=)}. +#' @param logscale A string such as "x", "y" or "xy". Each axis mentioned in this string +#' is displayed in logarithmic scale (base 10) instead of linear. #' @inheritParams showMultiLinePlots #' @return \code{NULL} is returned invisible. #' @section Example Plots: @@ -49,109 +51,118 @@ showMultiLinePlotsByVariable <- function( nrowNum = 1, mainReg = getOption("mip.mainReg"), histRefModel = getOption("mip.histRefModel"), - yearsByVariable = getOption("mip.yearsBarPlot") + yearsByVariable = getOption("mip.yearsBarPlot"), + logscale = "" ) { + # validate function arguments + stopifnot(is.character(vars)) + stopifnot(is.character(xVar) && length(xVar) == 1) + stopifnot(is.character(scales) && length(scales) == 1) + stopifnot(is.character(logscale) && length(logscale) == 1) + stopifnot(identical(showHistorical, TRUE) || identical(showHistorical, FALSE)) + stopifnot(is.null(yearsByVariable) || is.numeric(yearsByVariable)) + checkGlobalOptionsProvided(c("mainReg", "histRefModel")) + stopifnot(is.character(mainReg) && length(mainReg) == 1) + stopifnot(is.character(histRefModel) && !is.null(names(histRefModel))) - data <- as.quitte(data) - # Validate function arguments. - stopifnot(is.character(vars)) - stopifnot(is.character(xVar) && length(xVar) == 1) - stopifnot(is.character(scales) && length(scales) == 1) - stopifnot(identical(showHistorical, TRUE) || identical(showHistorical, FALSE)) - stopifnot(is.null(yearsByVariable) || is.numeric(yearsByVariable)) - checkGlobalOptionsProvided(c("mainReg", "histRefModel")) - stopifnot(is.character(mainReg) && length(mainReg) == 1) - stopifnot(is.character(histRefModel) && !is.null(names(histRefModel))) + # keep and match relevant variables + data <- as.quitte(data) + dy <- data %>% + filter(.data$variable %in% .env$vars) + dx <- data %>% + filter(.data$variable %in% .env$xVar) %>% + filter(.data$scenario != "historical" | .data$model == .env$histRefModel[.env$xVar]) + d <- dy %>% + left_join(dx, by = c("scenario", "region", "period"), suffix = c("", ".x") ) %>% + drop_na(.data$value, .data$value.x) %>% + filter(if (grepl("x", logscale)) .data$value.x > 0 else TRUE) %>% # if logscale x, drop zeroes + filter(if (grepl("y", logscale)) .data$value > 0 else TRUE) %>% # if logscale y, drop zeroes + arrange(.data$period) %>% droplevels() - dy <- data %>% - filter(.data$variable %in% .env$vars) - dx <- data %>% - filter(.data$variable %in% .env$xVar) %>% - filter(.data$scenario != "historical" | .data$model == .env$histRefModel[.env$xVar]) - d <- dy %>% - left_join(dx, by = c("scenario", "region", "period"), suffix = c("", ".x")) %>% - drop_na(.data$value, .data$value.x) %>% - arrange(.data$period) %>% - droplevels() - dMainScen <- d %>% - filter(.data$region == .env$mainReg, .data$scenario != "historical") %>% - droplevels() - dMainHist <- d %>% - filter(.data$region == .env$mainReg, .data$scenario == "historical") %>% - droplevels() - dRegiScen <- d %>% - filter(.data$region != .env$mainReg, .data$scenario != "historical") %>% - droplevels() - dRegiHist <- d %>% - filter(.data$region != .env$mainReg, .data$scenario == "historical") %>% - droplevels() - regions <- levels(dRegiScen$region) + # prepare plotting + label <- paste0("(", paste0(levels(d$unit), collapse = ","), ")") + xLabel <- paste0(xVar, " (", paste0(levels(d$unit.x), collapse = ","), ")") - warnMissingVars(dMainScen, vars) - if (NROW(dMainScen) == 0) { - warning("Nothing to plot.", call. = FALSE) - return(invisible(NULL)) - } + logscaleRange <- function(dataValues) c(floor(log10(min(dataValues))*10)/10, ceiling(log10(max(dataValues))*10)/10) + logscaleBreaks <- function(dataValues) { + majorBreaks <- 10^seq(floor(log10(min(dataValues))), ceiling(log10(max(dataValues))), 1) # 10 100 1000 + minorBreaks <- as.vector(outer(1:9, head(majorBreaks,-1), "*")) # 10 20 .. 90 100 200 .. 900 + if(diff(logscaleRange(dataValues)) < 3) majorBreaks <- minorBreaks + return(list(majorBreaks, minorBreaks)) + } - label <- paste0("(", paste0(levels(d$unit), collapse = ","), ")") - xLabel <- paste0(xVar, " (", paste0(levels(d$unit.x), collapse = ","), ")") - - if (showGlobal) { - p1 <- dMainScen %>% - ggplot(aes(.data$value.x, .data$value)) + - geom_line(aes(linetype = .data$scenario)) + - facet_wrap(vars(.data$variable), scales = scales, nrow = nrowNum) + - theme_minimal() + - expand_limits(y = 0) + - ylab(label) + xlab(xLabel) - } - p2 <- dRegiScen %>% - ggplot(aes(.data$value.x, .data$value, color = .data$region)) + - geom_line(aes(linetype = .data$scenario)) + - facet_wrap(vars(.data$variable), scales = scales, nrow = nrowNum) + - theme_minimal() + - scale_color_manual(values = plotstyle(regions)) + - expand_limits(y = 0) + - ylab(label) + xlab(xLabel) - - if (showHistorical) { - stopifnot(xVar %in% names(histRefModel)) - if (showGlobal) { - p1 <- p1 + - geom_point(data = dMainHist, aes(shape = .data$model)) + - geom_line(data = dMainHist, aes(group = paste0(.data$model, .data$region)), alpha = 0.5) - } - p2 <- p2 + - geom_point(data = dRegiHist, aes(shape = .data$model)) + - geom_line(data = dRegiHist, aes(group = paste0(.data$model, .data$region)), alpha = 0.5) - } - # Add markers for certain years. - if (length(yearsByVariable) > 0) { - if (showGlobal) { - p1 <- p1 + - geom_point( - data = dMainScen %>% - filter(.data$period %in% .env$yearsByVariable) %>% - mutate(year = factor(.data$period)), - mapping = aes(.data$value.x, .data$value, shape = .data$year)) - } - p2 <- p2 + - geom_point( - data = dRegiScen %>% - filter(.data$period %in% .env$yearsByVariable) %>% - mutate(year = factor(.data$period)), - mapping = aes(.data$value.x, .data$value, shape = .data$year)) - } + plotOptions <- function(dataOptions) + dataOptions %>% ggplot(aes(.data$value.x, .data$value)) + + geom_line(aes(linetype = .data$scenario)) + + facet_wrap(vars(.data$variable), scales = scales, nrow = nrowNum) + + theme_minimal() + + ylab(label) + + xlab(xLabel) + + list( + # year markers + if(length(yearsByVariable) > 0) + geom_point(mapping = aes(.data$value.x, .data$value, shape = .data$year), + data = dataOptions %>% + filter(.data$period %in% .env$yearsByVariable) %>% + mutate(year = factor(.data$period))), + # logscale + if(grepl("x", logscale)) + logscaleBreaks(dataOptions$value.x) %>% { scale_x_log10(breaks = first(.), minor_breaks = last(.)) }, + if(grepl("y", logscale)) + logscaleBreaks(dataOptions$value) %>% { scale_y_log10(breaks = first(.), minor_breaks = last(.)) }, + # axis limits + if(grepl("x", logscale)) expand_limits(x = 10^logscaleRange(dataOptions$value.x)), + if(grepl("y", logscale)) expand_limits(y = 10^logscaleRange(dataOptions$value)) + else expand_limits(y = 0) + ) - # Show plots. - if (showGlobal) { - print(p1) - cat("\n\n") - } - print(p2) - cat("\n\n") + + # plot global or main region data + if (showGlobal) { + dMainScen <- d %>% filter(.data$region == .env$mainReg, .data$scenario != "historical") %>% droplevels() + warnMissingVars(dMainScen, vars) + if (NROW(dMainScen) == 0) { + warning("Nothing to plot.", call. = FALSE) + return(invisible(NULL)) + } + plotGlobal <- dMainScen %>% plotOptions() + } - return(invisible(NULL)) + + # plot other regions + dRegiScen <- d %>% filter(.data$region != .env$mainReg, .data$scenario != "historical") %>% droplevels() + regions <- levels(dRegiScen$region) + plotRegi <- dRegiScen %>% plotOptions() + + aes(color = .data$region) + + scale_color_manual(values = plotstyle(regions)) + + + # add historical data + if (showHistorical) { + stopifnot(xVar %in% names(histRefModel)) + + plotOptionsHist <- function(dataHist) + geom_point(data = dataHist, aes(shape = .data$model)) + + geom_line(data = dataHist, aes(group = paste0(.data$model, .data$region)), alpha = 0.5) + + if (showGlobal) { + dMainHist <- d %>% filter(.data$region == .env$mainReg, .data$scenario == "historical") %>% droplevels() + plotGlobal <- plotGlobal + plotOptionsHist(dMainHist) + } + + dRegiHist <- d %>% filter(.data$region != .env$mainReg, .data$scenario == "historical") %>% droplevels() + plotRegi <- plotRegi + plotOptionsHist(dRegiHist) + } + + + # show plots + if (showGlobal) { + print(plotGlobal) + cat("\n\n") + } + print(plotRegi) + cat("\n\n") + return(invisible(NULL)) } diff --git a/README.md b/README.md index 1adc79f..d3d8a19 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # Comparison of multi-model runs -R package **mip**, version **0.149.2** +R package **mip**, version **0.151.1** [![CRAN status](https://www.r-pkg.org/badges/version/mip)](https://cran.r-project.org/package=mip) [![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.1158586.svg)](https://doi.org/10.5281/zenodo.1158586) [![R build status](https://github.com/pik-piam/mip/workflows/check/badge.svg)](https://github.com/pik-piam/mip/actions) [![codecov](https://codecov.io/gh/pik-piam/mip/branch/master/graph/badge.svg)](https://app.codecov.io/gh/pik-piam/mip) [![r-universe](https://pik-piam.r-universe.dev/badges/mip)](https://pik-piam.r-universe.dev/builds) @@ -47,7 +47,7 @@ In case of questions / problems please contact David Klein , R package version 0.149.2, . +Klein D, Dietrich J, Baumstark L, Humpenoeder F, Stevanovic M, Wirth S, Führlich P, Richters O, Rüter T (2024). _mip: Comparison of multi-model runs_. doi:10.5281/zenodo.1158586 , R package version 0.151.1, . A BibTeX entry for LaTeX users is @@ -56,7 +56,7 @@ A BibTeX entry for LaTeX users is title = {mip: Comparison of multi-model runs}, author = {David Klein and Jan Philipp Dietrich and Lavinia Baumstark and Florian Humpenoeder and Miodrag Stevanovic and Stephen Wirth and Pascal Führlich and Oliver Richters and Tonn Rüter}, year = {2024}, - note = {R package version 0.149.2}, + note = {R package version 0.151.1}, url = {https://github.com/pik-piam/mip}, doi = {10.5281/zenodo.1158586}, } diff --git a/man/extractVariableGroups.Rd b/man/extractVariableGroups.Rd index 21ce02e..9329599 100644 --- a/man/extractVariableGroups.Rd +++ b/man/extractVariableGroups.Rd @@ -4,14 +4,16 @@ \alias{extractVariableGroups} \title{extractVariableGroups} \usage{ -extractVariableGroups(x, keepOrigNames = FALSE) +extractVariableGroups(x, keepOrigNames = FALSE, sorted = FALSE) } \arguments{ \item{x}{a vector of variable names} \item{keepOrigNames}{if set, the returned list contains the original variables (to the value of which the grouped ones have to sum up) as names instead of -made up group names, if they exist. The current implementation goes up to two levels (++) deep.} +made up group names, if they exist.} + +\item{sorted}{boolean, indicating whether the variables within each group should be returned alp} } \value{ a named list of variable groups with group name as name and vector of entities as content diff --git a/man/showLinePlots.Rd b/man/showLinePlots.Rd index 62b3f3f..8d90ed2 100644 --- a/man/showLinePlots.Rd +++ b/man/showLinePlots.Rd @@ -12,7 +12,8 @@ showLinePlots( color.dim.name = NULL, mainReg = getOption("mip.mainReg"), color.dim.manual = NULL, - histModelsExclude = NULL + histModelsExclude = NULL, + vlines = NULL ) } \arguments{ @@ -37,6 +38,8 @@ colors of color.dim, default is \code{NULL}.} \item{histModelsExclude}{A character vector with historical models to exclude. Set to \code{NULL} (default) for all available data.} + +\item{vlines}{period used for vertical line} } \value{ \code{NULL} is returned invisible. diff --git a/man/showMultiLinePlotsByVariable.Rd b/man/showMultiLinePlotsByVariable.Rd index 2d3a04a..3e476e7 100644 --- a/man/showMultiLinePlotsByVariable.Rd +++ b/man/showMultiLinePlotsByVariable.Rd @@ -14,7 +14,8 @@ showMultiLinePlotsByVariable( nrowNum = 1, mainReg = getOption("mip.mainReg"), histRefModel = getOption("mip.histRefModel"), - yearsByVariable = getOption("mip.yearsBarPlot") + yearsByVariable = getOption("mip.yearsBarPlot"), + logscale = "" ) } \arguments{ @@ -45,6 +46,9 @@ to set globally.} \item{yearsByVariable}{A numeric vector. The years to be marked in the plots. As default it uses the value globally set by \code{options(mip.yearsBarPlot=)}.} + +\item{logscale}{A string such as "x", "y" or "xy". Each axis mentioned in this string +is displayed in logarithmic scale (base 10) instead of linear.} } \value{ \code{NULL} is returned invisible. diff --git a/tests/testthat/test-extractVariableGroups.R b/tests/testthat/test-extractVariableGroups.R index 2051cf7..62d032d 100644 --- a/tests/testthat/test-extractVariableGroups.R +++ b/tests/testthat/test-extractVariableGroups.R @@ -35,5 +35,20 @@ test_that("check that extractVariableGroups correctly extracts variable groups", expect_identical(extractVariableGroups(x1,keepOrigNames = TRUE),res2) expect_warning(extractVariableGroups(gsub("\\|[\\+]{1,}","",x1))) expect_identical(extractVariableGroups(gsub("\\|[\\+]{1,}","",x1[!grepl(")$",x1)])),res3) - + + x4 <- c("B", "B|+|G", "A|++|C", "A|++|B", "A", "C|++++++++++++++++|A", "C") + res4 <- list("B" = "B|+|G", "A 2" = c("A|++|C", "A|++|B"), "C 16" = "C|++++++++++++++++|A") + res4sorted <- list("A 2" = c("A|++|B", "A|++|C"), "B" = "B|+|G", "C 16" = "C|++++++++++++++++|A") + expect_identical(extractVariableGroups(x4, sorted = FALSE), res4) + expect_identical(extractVariableGroups(x4, sorted = TRUE), res4sorted) + + x5 <- c("A|+|FE", "A|FE|+|B", "A|FE|+|A", "A|FE|++|D", "A|FE|++|C") + res5 <- list("A" = "A|+|FE", "A|FE" = c("A|FE|+|B", "A|FE|+|A"), "A|FE 2" = c("A|FE|++|D", "A|FE|++|C")) + expect_identical(extractVariableGroups(x5, keepOrigNames = FALSE, sorted = FALSE), res5) + res5keep <- list("A" = "A|+|FE", "A|+|FE" = c("A|FE|+|B", "A|FE|+|A"), "A|+|FE" = c("A|FE|++|D", "A|FE|++|C")) + expect_identical(extractVariableGroups(x5, keepOrigNames = TRUE), res5keep) + res5sorted <- list("A" = "A|+|FE", "A|FE" = c("A|FE|+|A", "A|FE|+|B"), "A|FE 2" = c("A|FE|++|C", "A|FE|++|D")) + expect_identical(extractVariableGroups(x5, keepOrigNames = FALSE, sorted = FALSE), res5) + res5keepSorted <- list("A" = "A|+|FE", "A|+|FE" = c("A|FE|+|A", "A|FE|+|B"), "A|+|FE" = c("A|FE|++|C", "A|FE|++|D")) + expect_identical(extractVariableGroups(x5, keepOrigNames = TRUE, sorted = TRUE), res5keepSorted) })