Version 24.05.0: Feat/202 contour maps (#210)

* option to use simple contour map, some formatting

* update news.md

DESCRIPTION

@@ -1,8 +1,11 @@
 Package: MpiIsoApp
 Title: Pandora & IsoMemo spatiotemporal modeling
-Version: 24.04.0
-Author: INWT Statistics GmbH
-Maintainer: INWT <marcus.gross@inwt-statistics.de>
+Version: 24.05.0
+Authors@R: c(
+            person("Marcus", "Gross", email = "marcus.gross@inwt-statistics.de", role = c("cre", "aut")),
+            person("Antonia", "Runge", email = "antonia.runge@inwt-statistics.de", role = c("aut"))
+            )
+Maintainer: INWT Statistics GmbH <antonia.runge@inwt-statistics.de>
 Description: Shiny App contains: a data explorer tab, an interactive map and a static map, which should present model results.
 License: GPL (>= 3)
 Encoding: UTF-8

NAMESPACE

@@ -129,6 +129,7 @@ importFrom(graphics,Axis)
 importFrom(graphics,axis)
 importFrom(graphics,box)
 importFrom(graphics,boxplot)
+importFrom(graphics,contour)
 importFrom(graphics,filled.contour)
 importFrom(graphics,hist)
 importFrom(graphics,image)

NEWS.md

@@ -1,3 +1,9 @@
+# MpiIsoApp 24.05.0
+
+## New Features
+- _OperatoR tab_:
+  - option to create contour maps from saved maps (#202)
+
 # MpiIsoApp 24.04.0
 
 ## New Features

R/00-Namespace.R

@@ -12,7 +12,7 @@
 #' @importFrom geometry convhulln inhulln
 #' @importFrom ggplot2 ggplot theme theme_light coord_cartesian geom_point theme_light theme labs
 #'  geom_errorbar aes_ element_blank element_text position_dodge aes geom_boxplot xlab ylab
-#' @importFrom graphics axis filled.contour hist plot points title boxplot par image lines
+#' @importFrom graphics axis contour filled.contour hist plot points title boxplot par image lines
 #'  polygon text .filled.contour Axis box layout lcm plot.new plot.window rect legend strwidth text
 #' @importFrom grDevices cm.colors colorRampPalette col2rgb chull dev.off jpeg png pdf pdfFonts
 #'  recordPlot replayPlot rgb svg tiff

R/01-plotMap.R

@@ -62,6 +62,7 @@
 #' @param nMin Number of minima to compare, only for spread model
 #' @param minDist Distance between minima/maxima, only for spread model
 #' @param showMinOnMap Show minima on map yes/no, only for spread model if maptype = "Minima/Maxima"
+#' @inheritParams filled.contour2
 #'
 #' @export
 plotMap <- function(model,
@@ -71,6 +72,7 @@ plotMap <- function(model,
                     rangex = range(model$data$Longitude, na.rm = TRUE),
                     rangey = range(model$data$Latitude, na.rm = TRUE),
                     rangez = NULL,
+                    contourType = c("filled.contour", "contour"),
                     limitz = NULL, resolution = 100, interior = TRUE,
                     ncol = 10, colors = "RdYlGn", reverseColors = FALSE,
                     colorsP = NULL,
@@ -112,7 +114,7 @@ plotMap <- function(model,
                     minDist = 250,
                     showMinOnMap = FALSE){
   options(scipen=999)
-
+  contourType <- match.arg(contourType)
   minRangeFactor <- 0.75
   if((diff(rangex) / diff(rangey)) < minRangeFactor){
     rangex[1] <- max(-180, mean(rangex) - minRangeFactor / 2 * diff(rangey))
@@ -578,6 +580,7 @@ plotMap <- function(model,
       XPred$Est <- exp(as.vector(z2))
     }
     filled.contour2(longitudes, latitudes, z = z2,
+                    contourType = contourType,
                     cex.axis = 1.5, cex.main = 1.5, cex.lab = 1.5,
                     xlim = rangex, ylim = rangey,
                     zlim = range(z2, finite = TRUE),
@@ -789,6 +792,7 @@ plotMap <- function(model,
 
 
   filled.contour2(longitudes, latitudes, z = matrix(XPredPlot$Est, ncol = resolution),
+                  contourType = contourType,
                   xlim = rangex, ylim = rangey, levels = levels, zlim = rangez,
                   col = colors,
                   showScale = showScale,
@@ -989,7 +993,6 @@ plotMap <- function(model,
 #' @param pointLabels point size labels
 #' @param pointColLabels point colour labels
 #' @param fontSize font size
-#' @param showScale show colour scale
 #' @param showModel show model
 #' @param fontType font type
 #' @param fontCol font color
@@ -1014,6 +1017,7 @@ plotMap <- function(model,
 #' @param clusterCol Cluster colors
 #' @param pointDat data frame of points to add to plot
 #' @param plotRetNull return predictions
+#' @inheritParams filled.contour2
 #'
 #' @export
 plotMap3D <- function(model,
@@ -1024,6 +1028,7 @@ plotMap3D <- function(model,
                       rangex = range(model$data$Longitude, na.rm = TRUE),
                       rangey = range(model$data$Latitude, na.rm = TRUE),
                       rangez = NULL,
+                      contourType = c("filled.contour", "contour"),
                       limitz = "none",
                       centerMap = "Europe",
                       addU = 0,
@@ -1066,7 +1071,8 @@ plotMap3D <- function(model,
                       clusterCol = "Set1",
                       pointDat = NULL,
                       plotRetNull = FALSE){
-  options(scipen=999)
+  options(scipen = 999)
+  contourType <- match.arg(contourType)
   minRangeFactor <- 0.75
   if((diff(rangex) / diff(rangey)) < minRangeFactor){
     rangex[1] <- max(-180, mean(rangex) - minRangeFactor / 2 * diff(rangey))
@@ -1514,6 +1520,7 @@ plotMap3D <- function(model,
   }
 
   filled.contour2(longitudes, latitudes, z = matrix(XPredPlot$Est, ncol = resolution),
+                  contourType = contourType,
                   xlim = rangex, ylim = rangey, levels = levels,
                   col = colors,
                   showScale = showScale,
@@ -1721,7 +1728,6 @@ plotMap3D <- function(model,
 #' @param rangex range of longitude values (x axis limits)
 #' @param rangey range of latitude values (y axis limits)
 #' @param rangez range of estimated values (z axis limits)
-#' @param showScale show colour scale
 #' @param centerMap center of map, one of "Europe" and "Pacific"
 #' @param showValues boolean show values in plot?
 #' @param simValues if showValues: list of simulated values
@@ -1744,15 +1750,18 @@ plotMap3D <- function(model,
 #' @param AxisSize axis title font size
 #' @param AxisLSize axis label font size
 #' @param pointDat data frame of points to add to plot
+#' @inheritParams filled.contour2
 #'
 #' @export
 plotDS <- function(XPred,
                    estType = "mean",
                    estQuantile = 0.95,
-                   type = "similarity", independent = "",
+                   type = "similarity",
+                   independent = "",
                    rangex = range(XPred$Longitude, na.rm = TRUE),
                    rangey = range(XPred$Latitude, na.rm = TRUE),
                    rangez = range(XPred$Est, na.rm = TRUE),
+                   contourType = c("filled.contour", "contour"),
                    showModel = TRUE,
                    showScale = TRUE,
                    ncol = 10, colors = "RdYlGn",
@@ -1778,10 +1787,11 @@ plotDS <- function(XPred,
                    AxisSize = 1,
                    AxisLSize = 1,
                    pointDat = NULL){
-  options(scipen=999)
+  options(scipen = 999)
+  contourType <- match.arg(contourType)
   RadiusBatch <-  RadiusBatch / 111
   minRangeFactor <- 0.75
-  if((diff(rangex) / diff(rangey)) < minRangeFactor){
+  if ((diff(rangex) / diff(rangey)) < minRangeFactor) {
     rangex[1] <- max(-180, mean(rangex) - minRangeFactor / 2 * diff(rangey))
     rangex[2] <- min(180, mean(rangex) + minRangeFactor / 2 * diff(rangey))
   }
@@ -1937,7 +1947,9 @@ plotDS <- function(XPred,
   }
 
   filled.contour2(unique(XPredPlot$Longitude), unique(XPredPlot$Latitude),
-                  z = z, xlim = rangex, ylim = rangey, levels = levels,
+                  z = z,
+                  contourType = contourType,
+                  xlim = rangex, ylim = rangey, levels = levels,
                   col = colors,
                   showScale = showScale,
                   cex.axis = 1.5, cex.main = 1.5, cex.lab = 1.5,
@@ -2044,14 +2056,45 @@ plotDS <- function(XPred,
   return(list(XPred = XPred))
 }
 
-filled.contour2 <- function (x = seq(0, 1, length.out = nrow(z)),
-                             y = seq(0, 1, length.out = ncol(z)), z, xlim = range(x, finite = TRUE),
-                             ylim = range(y, finite = TRUE), zlim = range(z, finite = TRUE),
-                             levels = pretty(zlim, nlevels), nlevels = 20, showScale = TRUE,
-                             color.palette = cm.colors, col = color.palette(length(levels) - 1),
-                             plot.title, plot.axes, key.title, key.axes, asp = NA, xaxs = "i",
-                             yaxs = "i", las = 1, axes = TRUE, frame.plot = axes, ...)
+#' Filled Countour 2
+#' Wrapper for contour plot
+#'
+#' @param x x values
+#' @param y y values
+#' @param z z values
+#' @param contourType one of "filled.contour" or "contour"
+#' @param xlim x limits
+#' @param ylim y limits
+#' @param zlim z limits
+#' @param levels levels
+#' @param nlevels number of levels
+#' @param showScale show colour scale
+#' @param color.palette color palette
+#' @param col colors
+#' @param plot.title plot title
+#' @param plot.axes plot axes
+#' @param key.title key title
+#' @param key.axes key axes
+#' @param asp aspect ratio
+#' @param xaxs x axis style
+#' @param yaxs y axis style
+#' @param las label style
+#' @param axes show axes
+#' @param frame.plot frame plot
+#' @param ... additional arguments
+filled.contour2 <- function(x = seq(0, 1, length.out = nrow(z)),
+                            y = seq(0, 1, length.out = ncol(z)),
+                            z,
+                            contourType = c("filled.contour", "contour"),
+                            xlim = range(x, finite = TRUE),
+                            ylim = range(y, finite = TRUE), zlim = range(z, finite = TRUE),
+                            levels = pretty(zlim, nlevels), nlevels = 20, showScale = TRUE,
+                            color.palette = cm.colors, col = color.palette(length(levels) - 1),
+                            plot.title, plot.axes, key.title, key.axes, asp = NA, xaxs = "i",
+                            yaxs = "i", las = 1, axes = TRUE, frame.plot = axes, ...)
 {
+  contourType <- match.arg(contourType)
+
   if (missing(z)) {
     if (!missing(x)) {
       if (is.list(x)) {
@@ -2072,72 +2115,90 @@ filled.contour2 <- function (x = seq(0, 1, length.out = nrow(z)),
   }
   if (any(diff(x) <= 0) || any(diff(y) <= 0))
     stop("increasing 'x' and 'y' values expected")
+
+  # setup layout
   mar.orig <- (par.orig <- par(c("mar", "las", "mfrow")))$mar
   on.exit(par(par.orig))
-  w <- (3 + mar.orig[2L]) * par("csi") * 2.54
-  if(showScale){
-    layout(matrix(c(2, 1), ncol = 2L), widths = c(1, lcm(w)))
-  }
+
   par(las = las)
+  pin1 <- par("pin")
+
+  ratioLim <- abs(diff(ylim)) / abs(diff(xlim))
+
+  if (showScale && contourType == "filled.contour") {
+    # set up colour legend
+    w <- (3 + mar.orig[2L]) * par("csi") * 2.54
+    layout(matrix(c(2, 1), ncol = 2L), widths = c(1, lcm(w)))
+
   mar <- mar.orig
   mar[4L] <- mar[2L]
   mar[2L] <- 1
   par(mar = mar)
-  pin1 <- par("pin")
+
   a = (pin1[1] + par("mai")[2] + par("mai")[4])
   b = (pin1[2] + par("mai")[1] + par("mai")[3])
-
-  ratio <- abs(diff(ylim)) / abs(diff(xlim))
-
   ratioXY <- (a / b)
 
-  if (abs(diff(xlim)) / abs(diff(ylim)) >= ratioXY){
-
-    par(plt = c(0.1, 0.5, 0.525 - ratio * ratioXY / 2 * 0.875,
-                0.525 + ratio * ratioXY / 2 * 0.875))
+  if ((1 / ratioLim) >= ratioXY) {
+    par(plt = getPlotRegion(bottom = 0.5, ratioLim = ratioLim, ratioXY = ratioXY))
   }
-  if (abs(diff(xlim)) / abs(diff(ylim)) < ratioXY){
+  if ((1 / ratioLim) < ratioXY) {
     par(plt = c(0.15, 0.5, 0.15, 0.9))
   }
 
+  # create colour legend
   plot.new()
   plot.window(xlim = c(0, 1), ylim = range(levels), xaxs = "i",
               yaxs = "i")
+
   rect(0, levels[-length(levels)], 1, levels[-1L], col = col)
+
   if (missing(key.axes)) {
     if (axes)
-      if(max(abs(z), na.rm = TRUE) < 10000) {
+      if (max(abs(z), na.rm = TRUE) < 10000) {
         axis(4)
       } else {
         axis(4, cex.axis = 0.7)
       }
   }
   else key.axes
+
   box()
+
   if (!missing(key.title))
     key.title
+  }
+
+  # set up (filled.)contour
   mar <- mar.orig
   mar[4L] <- 1
   par(mar = mar)
+
   a = (pin1[1] + par("mai")[2] + par("mai")[4])
   b = (pin1[2] + par("mai")[1] + par("mai")[3])
-
-  ratio <- abs(diff(ylim)) / abs(diff(xlim))
-
   ratioXY <- (a / b)
-  if (abs(diff(xlim)) / abs(diff(ylim)) >= ratioXY){
 
-    par(plt = c(0.1, 0.975, 0.525 - ratio * ratioXY / 2 * 0.875,
-                0.525 + ratio * ratioXY / 2 * 0.875))
+  if ((1 / ratioLim) >= ratioXY) {
+    par(plt = getPlotRegion(bottom = 0.975, ratioLim = ratioLim, ratioXY = ratioXY))
   }
-  if (abs(diff(xlim)) / abs(diff(ylim)) < ratioXY){
-    add <- 1 / ratioXY / 2 * 0.75 / ratio
-    par(plt = c(0.975 - 2 * add,
-                0.975, 0.15, 0.9))
+  if ((1 / ratioLim) < ratioXY) {
+    add <- 1 / ratioXY / 2 * 0.75 / ratioLim
+    par(plt = c(0.975 - 2 * add, 0.975, 0.15, 0.9))
   }
+
+  # create (filled.)contour
   plot.new()
-  plot.window(xlim, ylim, "", xaxs = xaxs, yaxs = yaxs, asp = asp)
-  .filled.contour(x, y, z, levels, col)
+  if (contourType == "contour") {
+    # contour plot ----
+    contour(x = x, y = y, z = z, nlevels = length(levels), col = col,
+            xlim = xlim, ylim = ylim, xaxs = xaxs, yaxs = yaxs, asp = asp)
+  } else {
+    # filled.contour plot ----
+    plot.window(xlim, ylim, "", xaxs = xaxs, yaxs = yaxs, asp = asp)
+    .filled.contour(x, y, z, levels, col)
+  }
+
+  # set plot axis and background
   if (missing(plot.axes)) {
     if (axes) {
       title(main = "", xlab = "", ylab = "")
@@ -2146,15 +2207,20 @@ filled.contour2 <- function (x = seq(0, 1, length.out = nrow(z)),
     }
   }
   else plot.axes
+
   if (frame.plot)
     box()
+
   if (missing(plot.title))
     title(...)
   else plot.title
-  invisible()
 
+  invisible()
 }
 
+getPlotRegion <- function(left = 0.1, bottom = 0.975, ratioLim = 1, ratioXY = 1) {
+  c(left, bottom, 0.525 - ratioLim * ratioXY / 2 * 0.875, 0.525 + ratioLim * ratioXY / 2 * 0.875)
+}
 
 north.arrow = function(x, y, h, c, adj) {
   polygon(c(x, x, x + h/2), c(y - h, y, y - (1 + sqrt(3)/2) * h),
@@ -2642,19 +2708,21 @@ combineSimilarityMaps <- function(XPredList,
 }
 
 createDifferenceMap <- function(XPred1, XPred2, operation = "-") {
-  if(class(XPred2) == "numeric" & class(XPred1) != "numeric"){
+  if (inherits(XPred2, "numeric") && !inherits(XPred1, "numeric")) {
     XPredNew <- XPred1
     XPredNew$Est <- XPred2[1]
     XPredNew$Sd <- XPred2[2]
     XPred2 <- XPredNew
   }
-  if(class(XPred1) == "numeric" & class(XPred2) != "numeric"){
+
+  if (inherits(XPred1, "numeric") && !inherits(XPred2, "numeric")) {
     XPredNew <- XPred2
     XPredNew$Est <- XPred1[1]
     XPredNew$Sd <- XPred1[2]
     XPred1 <- XPredNew
   }
-  if((class(XPred1) == "numeric" & class(XPred2) == "numeric")){
+
+  if (inherits(XPred1, "numeric") && inherits(XPred2, "numeric")) {
     lo <- seq(-180, 180, by = 0.5)
     la <- seq(-90, 90, by = 0.5)
     coord <- expand.grid(lo, la)