Merge pull request #68 from orichters/smallfix

fix legend titles, units, total plots

.buildlibrary

@@ -1,8 +1,9 @@
-ValidationKey: '28082950'
+ValidationKey: '28109640'
 AcceptedWarnings:
 - 'Warning: package ''.*'' was built under R version'
 - 'Warning: namespace ''.*'' is not available and has been replaced'
 - '''.*'' is needed for checks on size reduction of PDFs'
+- was deprecated in ggplot2
 AcceptedNotes:
 - unable to verify current time
 - File .mip/R/onLoad\.R.:\W+\.onLoad calls:\W+packageStartupMessage

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.144.2
-date-released: '2023-04-28'
+version: 0.144.3
+date-released: '2023-05-03'
 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.144.2
-Date: 2023-04-28
+Version: 0.144.3
+Date: 2023-05-03
 Authors@R: c(
     person("David", "Klein", , "dklein@pik-potsdam.de", role = c("aut", "cre")),
     person("Jan Philipp", "Dietrich", , "dietrich@pik-potsdam.de", role = "aut"),

R/mipArea.R

@@ -107,7 +107,7 @@ mipArea <- function(x, stack_priority = c("variable", "region"), total = TRUE, s
   # if there are three facet dimensions that have more than one element combine the two
   # smallest ones into the first one to be able to create a 2-D facet_grid later on
   if (length(facets) == 3) {
-    x[, facets[1]] <- interaction(x[[facets[1]]], x[[facets[2]]])
+    x[, facets[1]] <- paste(x[[facets[2]]], x[[facets[1]]])
   }
 
   # if not provided by user calculate total by summing over dimToStack
@@ -195,11 +195,11 @@ mipArea <- function(x, stack_priority = c("variable", "region"), total = TRUE, s
   # add total to plot as black line
   if (is.quitte(total)) {
     p <- p + geom_line(data = totalX, aes_(~period, ~value, linetype = as.formula(paste("~", dimToStack))),
-                       color = "#000000", size = 1)
+                       color = "#000000", linewidth = 1)
     p <- p + scale_linetype_discrete(labels = "Total", name = "")
     if (!is.null(hist)) {
       p <- p + geom_line(data = totalH, aes_(~period, ~value, linetype = as.formula(paste("~", dimToStack))),
-                         color = "#000000", size = 1, alpha = 0.3)
+                         color = "#000000", linewidth = 1, alpha = 0.3)
     }
   }
 

R/mipLineHistorical.R

@@ -44,7 +44,7 @@
 #'
 
 mipLineHistorical <- function(x,x_hist=NULL,color.dim="identifier",linetype.dim=NULL,facet.dim="region",funnel.dim=NULL,
-                              ylab=NULL,xlab="Year",title=NULL,color.dim.name="Model output",ybreaks=NULL,ylim=0,
+                              ylab=NULL,xlab="Year",title=NULL,color.dim.name=NULL,ybreaks=NULL,ylim=0,
                               ylog=NULL, size=14, scales="fixed", leg.proj=FALSE, plot.priority=c("x","x_hist","x_proj"),
                               ggobject=TRUE,paper_style=FALSE,xlim=NULL,facet.ncol=3,legend.ncol=1,hlines=NULL,hlines.labels=NULL,
                               color.dim.manual=NULL, color.dim.manual.hist=NULL) {
@@ -58,7 +58,7 @@ mipLineHistorical <- function(x,x_hist=NULL,color.dim="identifier",linetype.dim=
   if(all(is.na(x$scenario))) x$scenario <- ""
   if(all(is.na(x$model))) x$model <- ""
   if (! "identifier" %in% names(x)) x$identifier <- identifierModelScen(x)
-  color.dim.name <- paste(c(color.dim.name, attr(x$identifier, "deletedinfo")), collapse = " ")
+  if (is.null(color.dim.name)) color.dim.name <- c(attr(x$identifier, "deletedinfo"), "Model output")[[1]]
 
   ## main data object
   a <- x
@@ -125,14 +125,14 @@ mipLineHistorical <- function(x,x_hist=NULL,color.dim="identifier",linetype.dim=
 
   # internal functions for plotting of different types of data
   priority_x <- function(p){
-    p <- p + geom_line(data=a[a$id=="x",], aes_string(x="period",y="value",color=color.dim,linetype=linetype.dim),size=1)
+    p <- p + geom_line(data=a[a$id=="x",], aes_string(x="period",y="value",color=color.dim,linetype=linetype.dim),linewidth=1)
     p <- p + geom_point(data=a[a$id=="x",], aes_string(x="period",y="value",color=color.dim),size=1.5)
     return(p)
   }
 
   priority_x_hist <- function(p,MarkerSize=2.5){
     if(any(a$id=="x_hist")) {
-      p <- p + geom_line(data=a[a$id=="x_hist",], aes_string(x="period",y="value",color="model"),size=1, alpha=0.3)
+      p <- p + geom_line(data=a[a$id=="x_hist",], aes_string(x="period",y="value",color="model"),linewidth=1, alpha=0.3)
       #plot for creating the legend
       p <- p + geom_point(data=a[a$id=="x_hist",], aes_string(x="period",y="value",color="model",fill="model"),size=0)
       #plot the data without legend
@@ -147,20 +147,20 @@ mipLineHistorical <- function(x,x_hist=NULL,color.dim="identifier",linetype.dim=
         #plot for creating the legend
         p <- p + geom_line(data=a[a$id=="x_proj" & a$period<=ymax,],
                            aes_string(x="period",y="value",group="identifier", color="identifier",linetype=linetype.dim,alpha="identifier"),
-                           size=0)
+                           linewidth=0)
         #plot the data
         p <- p + geom_line(data=a[a$id=="x_proj" & a$period<=ymax,],
                            aes_string(x="period",y="value",group="identifier", color="identifier",linetype=linetype.dim),
-                           size=0.8, alpha=.7,show.legend = TRUE)
+                           linewidth=0.8, alpha=.7,show.legend = TRUE)
       } else {
         #plot for creating the legend
         p <- p + geom_line(data=a[a$id=="x_proj" & a$period<=ymax,],
                            aes_string(x="period",y="value",group="identifier",linetype=linetype.dim,alpha="model"),
-                           size=0, color="white")
+                           linewidth=0, color="white")
         #plot the data
         p <- p + geom_line(data=a[a$id=="x_proj" & a$period<=ymax,],
                            aes_string(x="period",y="value",group="identifier",linetype=linetype.dim),
-                           size=0.8, alpha=.5, color="#A1A194",show.legend = TRUE)
+                           linewidth=0.8, alpha=.5, color="#A1A194",show.legend = TRUE)
       }
     }
     return(p)
@@ -257,9 +257,9 @@ mipLineHistorical <- function(x,x_hist=NULL,color.dim="identifier",linetype.dim=
     #alpha: add colors for projection depending on leg.proj
     p <- p + scale_color_manual(color.dim.name,values = color_set, breaks=model_output,labels=sub("\\."," ",model_output),guide=guide_legend(order=1,title.position = "top", ncol=legend.ncol))
     p <- p + scale_fill_manual("Historical data",values = color_set[historical],breaks=historical,
-                               guide=guide_legend(override.aes = list(colour=color_set[historical],shape="+",linetype=0,size=5),order=2,title.position = "top", ncol=legend.ncol))
-    if(leg.proj) p <- p + scale_alpha_manual("Other projections",values = seq(0.1,1,length.out = length(projection)),breaks=projection,labels=sub("\\."," ",projection),guide=guide_legend(override.aes = list(colour=color_set[projection],shape=NULL,linetype=1,size=1,alpha=0.5),order=3,title.position = "top", ncol=legend.ncol))
-    else p <- p + scale_alpha_manual("Other projections",values = seq(0.1,1,length.out = length(projection)),breaks=projection,labels=sub("\\."," ",projection),guide=guide_legend(override.aes = list(colour="#A1A194",shape=NULL,linetype=1,size=1,alpha=0.5),order=3,title.position = "top", ncol=legend.ncol))
+                               guide=guide_legend(override.aes = list(colour=color_set[historical],shape="+",linetype=0,linewidth=5),order=2,title.position = "top", ncol=legend.ncol))
+    if(leg.proj) p <- p + scale_alpha_manual("Other projections",values = seq(0.1,1,length.out = length(projection)),breaks=projection,labels=sub("\\."," ",projection),guide=guide_legend(override.aes = list(colour=color_set[projection],shape=NULL,linetype=1,linewidth=1,alpha=0.5),order=3,title.position = "top", ncol=legend.ncol))
+    else p <- p + scale_alpha_manual("Other projections",values = seq(0.1,1,length.out = length(projection)),breaks=projection,labels=sub("\\."," ",projection),guide=guide_legend(override.aes = list(colour="#A1A194",shape=NULL,linetype=1,linewidth=1,alpha=0.5),order=3,title.position = "top", ncol=legend.ncol))
     p <- p + guides(linetype=guide_legend(order=4,title.position="top",ncol=legend.ncol))
 
     return(p)
@@ -322,7 +322,7 @@ mipLineHistorical <- function(x,x_hist=NULL,color.dim="identifier",linetype.dim=
   ## legend for the model output
   if(lsh$col1>0){
     l1 <- ggplot(data=a[a$id=="x",])
-    l1 <- l1 + geom_line(aes_(x=~period,y=~value,color=~identifier),size=1)
+    l1 <- l1 + geom_line(aes_(x=~period,y=~value,color=~identifier),linewidth=1)
     l1 <- l1 + geom_point(aes_(x=~period,y=~value,color=~identifier),size=1.5)
     l1 <- l1 + scale_color_manual(values=color_set[1:lsh$col1],
                                   breaks=interaction(unlist(a[a$id=="x","model"]),unlist(a[a$id=="x","scenario"])),
@@ -335,7 +335,7 @@ mipLineHistorical <- function(x,x_hist=NULL,color.dim="identifier",linetype.dim=
   ## legend for the historical data
   if(lsh$col2>0 & "x_hist" %in% levels(a$id)){
     l2 <- ggplot(data=a[a$id=="x_hist",])
-    l2 <- l2 + geom_line(aes_(x=~period,y=~value,color=~model),size=1,alpha=.15)
+    l2 <- l2 + geom_line(aes_(x=~period,y=~value,color=~model),linewidth=1,alpha=.15)
     l2 <- l2 + geom_point(aes_(x=~period,y=~value,color=~model),size=3.5,shape="+")
     l2 <- l2 + scale_color_manual(values=as.vector(color_set[(lsh$col1+1):(lsh$col1+lsh$col2)]),name="Historical data")
     l2 <- l2 + theme_legend()
@@ -346,7 +346,7 @@ mipLineHistorical <- function(x,x_hist=NULL,color.dim="identifier",linetype.dim=
   if(lsh$col3>0 & "x_proj" %in% levels(a$id)){
     if(leg.proj){
       l3 <- ggplot(data=a[a$id=="x_proj",])
-      l3 <- l3 + geom_line(aes_(x=~period,y=~value,color=~identifier),size=1,alpha=.7)
+      l3 <- l3 + geom_line(aes_(x=~period,y=~value,color=~identifier),linewidth=1,alpha=.7)
       l3 <- l3 + scale_color_manual(values=color_set[(lsh$col1+lsh$col2+1):(lsh$col1+lsh$col2+lsh$col3)],
                                     breaks=interaction(unlist(a[a$id=="x_proj","model"]),unlist(a[a$id=="x_proj","scenario"])),
                                     labels=shorten_legend(interaction(unlist(a[a$id=="x_proj","model"]),unlist(a[a$id=="x_proj","scenario"]),sep=" "),lsh$nchar[3]),
@@ -355,7 +355,7 @@ mipLineHistorical <- function(x,x_hist=NULL,color.dim="identifier",linetype.dim=
       leg[["other"]] <- g_legend(l3)
     } else{
         l3 <- ggplot(data=a[a$id=="x_proj",])
-        l3 <- l3 + geom_line(aes_(x=~period,y=~value,color=~model),size=1,alpha=.5)
+        l3 <- l3 + geom_line(aes_(x=~period,y=~value,color=~model),linewidth=1,alpha=.5)
         l3 <- l3 + scale_color_manual(values=rep("#A1A194",lsh$col3),
                                       breaks=unique(unlist(a[a$id=="x_proj","model"])),
                                       labels=shorten_legend(unique(unlist(a[a$id=="x_proj","model"])),lsh$nchar[3]),

R/showAreaAndBarPlots.R

@@ -84,7 +84,11 @@ showAreaAndBarPlots <- function(
     tot <- NULL
   }
 
-  d <- data %>%
+  dnohist <- data %>%
+    filter(data$scenario != "historical") %>%
+    droplevels()
+  if (! "identifier" %in% names(dnohist)) dnohist$identifier <- identifierModelScen(dnohist)
+  d <- dnohist %>%
     filter(.data$variable %in% .env$vars, .data$scenario != "historical") %>%
     droplevels()
   warnMissingVars(d, vars)
@@ -146,24 +150,23 @@ showAreaAndBarPlots <- function(
 
   # Add black lines in area plots from variable tot if provided.
   if (!is.null(tot)) {
-    dMainTot <- data %>%
+    dMainTot <- dnohist %>%
       filter(
         .data$region == .env$mainReg,
-        .data$variable == .env$tot,
-        .data$scenario != "historical") %>%
+        .data$variable == .env$tot) %>%
       droplevels()
     p1 <- p1 +
       geom_line(
         data = dMainTot,
         mapping = aes(.data$period, .data$value),
         size = 1.3
       )
-    dRegiTot <- data %>%
+    dRegiTot <- dnohist %>%
       filter(
         .data$region != .env$mainReg,
-        .data$variable == .env$tot,
-        .data$scenario != "historical") %>%
+        .data$variable == .env$tot) %>%
       droplevels()
+    dRegiTot$scenario <- dRegiTot$identifier
     p4 <- p4 +
       geom_line(
         data = dRegiTot,

R/showLinePlots.R

@@ -9,6 +9,7 @@
 #' @param vars A character vector. Usually just a single string. The variables
 #'   to be plotted. If \code{NULL} all rows from \code{data} are plotted.
 #' @param scales A single string. choose either \code{"free_y"} or \code{"fixed"}.
+#' @param color.dim.name name for the color-dimension used in the legend
 #' @inheritParams showAreaAndBarPlots
 #' @return \code{NULL} is returned invisible.
 #' @section Example Plots:
@@ -23,7 +24,7 @@
 #' @importFrom rlang .data .env
 #' @importFrom dplyr bind_rows
 showLinePlots <- function(
-    data, vars = NULL, scales = "free_y",
+    data, vars = NULL, scales = "free_y", color.dim.name = NULL,
     mainReg = getOption("mip.mainReg")
 ) {
 
@@ -87,6 +88,7 @@ showLinePlots <- function(
         ylab = label,
         scales = scales,
         plot.priority = c("x_hist", "x", "x_proj"),
+        color.dim.name = color.dim.name,
         color.dim.manual.hist = color.dim.manual.hist[mainHistModels]
       )
   }
@@ -100,6 +102,7 @@ showLinePlots <- function(
         scales = scales,
         plot.priority = c("x_hist", "x", "x_proj"),
         facet.ncol = 3,
+        color.dim.name = color.dim.name,
         color.dim.manual.hist = color.dim.manual.hist[regiHistModels]
       )
   }

R/showLinePlotsWithTarget.R

@@ -19,7 +19,7 @@
 #' @export
 #' @importFrom rlang .data .env
 showLinePlotsWithTarget <- function(
-  data, vars, scales = "free_y"
+  data, vars, scales = "free_y", color.dim.name = NULL
 ) {
 
   data <- as.quitte(data)
@@ -54,7 +54,8 @@ showLinePlotsWithTarget <- function(
       ylab = label,
       scales = scales,
       plot.priority = c("x_hist", "x", "x_proj"),
-      facet.ncol = 3
+      facet.ncol = 3,
+      color.dim.name = color.dim.name
     ) +
     geom_hline(
       data = dTar,

R/showMultiLinePlots.R

@@ -61,7 +61,7 @@ showMultiLinePlots <- function(
     return(invisible(NULL))
   }
 
-  label <- paste0("[", paste0(levels(d$unit), collapse = ","), "]")
+  label <- paste0("(", paste0(levels(d$unit), collapse = ","), ")")
 
   p1 <- dMainScen %>%
     ggplot(aes(.data$period, .data$value)) +

R/showMultiLinePlotsByVariable.R

@@ -91,8 +91,8 @@ showMultiLinePlotsByVariable <- function(
     return(invisible(NULL))
   }
 
-  label <- paste0("[", paste0(levels(d$unit), collapse = ","), "]")
-  xLabel <- paste0(xVar, " [", paste0(levels(d$unit.x), collapse = ","), "]")
+  label <- paste0("(", paste0(levels(d$unit), collapse = ","), ")")
+  xLabel <- paste0(xVar, " (", paste0(levels(d$unit.x), collapse = ","), ")")
 
   p1 <- dMainScen %>%
     ggplot(aes(.data$value.x, .data$value)) +

R/utils.R

@@ -112,10 +112,10 @@ identifierModelScen <- function(x) {
   x <- droplevels(quitte::as.quitte(x))
   if (nlevels(x$model) > 1 && nlevels(x$scenario) == 1) {
     x$identifier <- x$model
-    attr(x$identifier, "deletedinfo") <- levels(x$scenario)[[1]]
+    attr(x$identifier, "deletedinfo") <- paste("Scenario:", levels(x$scenario)[[1]])
   } else if (nlevels(x$model) == 1) {
     x$identifier <- x$scenario
-    attr(x$identifier, "deletedinfo") <- levels(x$model)[[1]]
+    attr(x$identifier, "deletedinfo") <- paste("Model:", levels(x$model)[[1]])
   } else {
     x$identifier <- as.factor(paste(x$model, x$scenario))
   }

README.md

@@ -1,6 +1,6 @@
 # Comparison of multi-model runs
 
-R package **mip**, version **0.144.2**
+R package **mip**, version **0.144.3**
 
 [![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 <dklein@pik-potsdam.d
 
 To cite package **mip** in publications use:
 
-Klein D, Dietrich J, Baumstark L, Humpenoeder F, Stevanovic M, Wirth S, Führlich P, Richters O (2023). _mip: Comparison of multi-model runs_. doi: 10.5281/zenodo.1158586 (URL: https://doi.org/10.5281/zenodo.1158586), R package version 0.144.2, <URL: https://github.com/pik-piam/mip>.
+Klein D, Dietrich J, Baumstark L, Humpenoeder F, Stevanovic M, Wirth S, Führlich P, Richters O (2023). _mip: Comparison of multi-model runs_. doi: 10.5281/zenodo.1158586 (URL: https://doi.org/10.5281/zenodo.1158586), R package version 0.144.3, <URL: 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},
   year = {2023},
-  note = {R package version 0.144.2},
+  note = {R package version 0.144.3},
   doi = {10.5281/zenodo.1158586},
   url = {https://github.com/pik-piam/mip},
 }

tests/testthat/test-identifierModelScen.R

@@ -8,20 +8,20 @@ test_that("shorten_legend works", {
 
   d <- droplevels(dplyr::filter(qe, !!sym("model") == levels(qe$model)[[1]]))
   d$identifier <- identifierModelScen(d)
-  expect_identical(attr(d$identifier, "deletedinfo"), levels(qe$model)[[1]])
+  expect_identical(attr(d$identifier, "deletedinfo"), paste("Model:", levels(qe$model)[[1]]))
   attr(d$identifier, "deletedinfo") <- NULL
   expect_identical(d$identifier, d$scenario)
 
   d <- droplevels(dplyr::filter(qe, !!sym("scenario") == levels(qe$scenario)[[1]]))
   d$identifier <- identifierModelScen(d)
-  expect_identical(attr(d$identifier, "deletedinfo"), levels(qe$scenario)[[1]])
+  expect_identical(attr(d$identifier, "deletedinfo"), paste("Scenario:", levels(qe$scenario)[[1]]))
   attr(d$identifier, "deletedinfo") <- NULL
   expect_identical(d$identifier, d$model)
 
   d <- droplevels(dplyr::filter(qe, !!sym("scenario") == levels(qe$scenario)[[1]],
                                     !!sym("model") == levels(qe$model)[[1]]))
   d$identifier <- identifierModelScen(d)
-  expect_identical(attr(d$identifier, "deletedinfo"), levels(qe$model)[[1]])
+  expect_identical(attr(d$identifier, "deletedinfo"), paste("Model:", levels(qe$model)[[1]]))
   attr(d$identifier, "deletedinfo") <- NULL
   expect_identical(d$identifier, d$scenario)
 })