Merge branch 'master' of https://github.com/pik-piam/mip into fix

.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'

.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

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:

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", , "[email protected]", role = c("aut", "cre")),
     person("Jan Philipp", "Dietrich", , "[email protected]", role = "aut"),

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)

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)
 }

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,

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=<value>)}.
+#' @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))
 }

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 <[email protected]
 
 To cite package **mip** in publications use:
 
-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 <https://doi.org/10.5281/zenodo.1158586>, R package version 0.149.2, <https://github.com/pik-piam/mip>.
+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 <https://doi.org/10.5281/zenodo.1158586>, R package version 0.151.1, <https://github.com/pik-piam/mip>.
 
 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},
 }