Version 23.06.0: Bug/161 leaflet map issues

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: MpiIsoApp
 Title: Pandora & IsoMemo spatiotemporal modeling
-Version: 23.05.4.3
+Version: 23.06.0
 Author: INWT Statistics GmbH
 Maintainer: INWT <marcus.gross@inwt-statistics.de>
 Description: Shiny App contains: a data explorer tab, an interactive map and a static map, which should present model results.
@@ -14,7 +14,7 @@ Imports:
     animation,
     coda,
     colourpicker,
-    DataTools (>= 23.05.2.6),
+    DataTools (>= 23.06.0),
     dplyr,
     DT (>= 0.4),
     futile.logger,

NEWS.md

@@ -1,5 +1,10 @@
 # MpiIsoApp development version
 
+## Version 23.06.0
+### Bug Fixes
+- _Interactive Map_:
+  - fix option to use a fixed point colour (#161)
+
 ## Version 23.05.4
 
 ### Updates

R/02-leafletExport.R

@@ -4,7 +4,7 @@
 leafletExportButton <- function(id) {
   ns <- NS(id)
 
-  tagList(actionButton(ns("exportLeaflet"), "Export Map"),
+  tagList(actionButton(ns("exportLeaflet"), "Export map"),
           div(
             id = ns("phantomjsHelp"),
             helpText(

R/02-leafletPointSettings.R

@@ -5,7 +5,7 @@ leafletPointSettingsUI <- function(id) {
   ns <- NS(id)
 
   tagList(
-    checkboxInput(ns("clusterPoints"), "Cluster data points"),
+    checkboxInput(ns("clusterPoints"), "Cluster points"),
     conditionalPanel(
       condition = "input.clusterPoints == false",
       ns = ns,
@@ -182,31 +182,31 @@ pointColourServer <- function(id, loadedData) {
                  colourValues <- reactiveValues()
 
                  observeEvent(input$showColourLegend, {
+                   logDebug("Update showColourLegend")
                    colourValues$showColourLegend <- input$showColourLegend
                  })
 
                  observeEvent(loadedData(), {
-                   if (!is.null(loadedData())) {
-                     selectedDefault <- ifelse("source" %in% colnames(loadedData()),
-                                               "source",
-                                               colnames(loadedData())[1])
+                   logDebug("Update loadedData()")
+                   if (is.null(loadedData())) {
+                     choices <- c("[Fixed]" = "")
                    } else {
-                     selectedDefault <- character(0)
+                     choices <- c("[Fixed]" = "", colnames(loadedData()))
                    }
 
                    updateSelectInput(
                      session = session,
                      "columnForPointColour",
-                     choices = colnames(loadedData()),
-                     selected = selectedDefault
+                     choices = choices
                    )
                    updateCheckboxInput(session = session,
                                        "showColourLegend",
                                        value = TRUE)
-                 })
 
-                 observeEvent(input$columnForPointColour, {
-                   colourValues$columnForPointColour <- input$columnForPointColour
+                   colourValues$columnForPointColour <- ""
+                   colourValues$pointColourPalette <- getColourCol(loadedData(), colName = "") %>%
+                     getColourPal(paletteName = input$paletteName,
+                                  isReversePalette = input$isReversePalette)
                  })
 
                  observeEvent(
@@ -216,30 +216,19 @@ pointColourServer <- function(id, loadedData) {
                      input$columnForPointColour
                    ),
                    {
-                     if (is.null(loadedData()) ||
-                         is.null(input$columnForPointColour))
-                       colourValues$pointColourPalette <- NULL
-
-                     if (!is.null(loadedData()) &&
-                         !is.null(input$columnForPointColour)) {
-                       colourColumn <- loadedData()[[input$columnForPointColour]]
-
-                       if (is.numeric(colourColumn)) {
-                         pal <- colorNumeric(
-                           palette = input$paletteName,
-                           domain = colourColumn,
-                           reverse = input$isReversePalette
-                         )
-                       } else {
-                         pal <- colorFactor(
-                           palette = input$paletteName,
-                           domain = colourColumn,
-                           reverse = input$isReversePalette
-                         )
-                       }
-
-                       colourValues$pointColourPalette <- pal
+                     logDebug("Update colourValues")
+                     if (is.null(input$columnForPointColour)) {
+                       colourValues$columnForPointColour <- ""
+                     } else {
+                       colourValues$columnForPointColour <- input$columnForPointColour
                      }
+
+                     colourValues$pointColourPalette <- getColourCol(
+                       loadedData(),
+                       colName = input$columnForPointColour
+                     ) %>%
+                       getColourPal(paletteName = input$paletteName,
+                                    isReversePalette = input$isReversePalette)
                    }
                  )
 
@@ -289,32 +278,29 @@ pointSizeServer <- function(id, loadedData) {
                  observe({
                    if (is.null(loadedData())) {
                      choices <- c("[Fixed]" = "")
-                     selectedDefault <- ""
                      showLegendVal <- FALSE
                    } else {
                      numCols <- numericColumns(loadedData())
                      if (length(numCols) == 0) {
                        choices <- c("[Fixed] (No numeric columns ...)" = "")
-                       selectedDefault <- ""
                        showLegendVal <- FALSE
                      } else {
                        choices <- c("[Fixed]" = "", numCols)
                      }
-                     selectedDefault <- ""
                      showLegendVal <- TRUE
                    }
 
                    updateSelectInput(
                      session = session,
                      "columnForPointSize",
                      choices = choices,
-                     selected = selectedDefault
+                     selected = ""
                    )
                    updateCheckboxInput(session = session, "showSizeLegend", value = showLegendVal)
 
                    radiusAndLegend <- getPointSize(
                      df = loadedData(),
-                     columnForPointSize = selectedDefault,
+                     columnForPointSize = "",
                      sizeFactor = input$sizeFactor
                    )
                    sizeValues$pointRadius <-
@@ -614,8 +600,9 @@ drawSymbolsOnMap <-
       return(map)
 
     # create colour for each point
+    colourCol <- getColourCol(isoData, colName = columnForColour)
     colourList <-
-      lapply(colourPal(isoData[[columnForColour]]), col2rgb)
+      lapply(colourPal(colourCol), col2rgb)
     colourVec <- sapply(1:nrow(isoData), function(i) {
       rgb(
         red = colourList[[i]][1],
@@ -669,7 +656,7 @@ cleanDataFromMap <- function(map) {
 #' @param pal colour palette
 #' @param values possible values that can be mapped, e.g. isoData$source
 setColorLegend <- function(map, showLegend, title, pal, values) {
-  if (showLegend && !is.null(pal)) {
+  if (showLegend && !is.null(pal) && !is.null(values)) {
     map <- map %>%
       addLegend("topleft",
                 pal = pal,
@@ -683,6 +670,38 @@ setColorLegend <- function(map, showLegend, title, pal, values) {
   map
 }
 
+getColourPal <- function(colourCol, paletteName, isReversePalette) {
+  if (is.null(colourCol)) return(NULL)
+
+  if (is.numeric(colourCol)) {
+    pal <- colorNumeric(
+      palette = paletteName,
+      domain = colourCol,
+      reverse = isReversePalette
+    )
+  } else {
+    pal <- colorFactor(
+      palette = paletteName,
+      domain = colourCol,
+      reverse = isReversePalette
+    )
+  }
+
+  pal
+}
+
+getColourCol <- function(dat, colName) {
+  if (is.null(colName) || is.null(dat)) return(NULL)
+
+  colourCol <- dat[[colName]]
+  if (is.null(colourCol)) {
+    # print error ?? into some new attr()?
+    colourCol <- rep("all", nrow(dat))
+  }
+
+  colourCol
+}
+
 # Point Size ----
 
 setSizeLegend <- function(map, showLegend, sizeLegend) {

R/02-leafletSettings.R

@@ -11,27 +11,27 @@ leafletSettingsUI <- function(id, title = "") {
       ns("LeafletType"),
       label = "Map type",
       choices = list(
-        `borders & names`= c(
-        "CartoDB Positron" = "CartoDB.Positron",
-        "OpenStreetMap Mapnik" = "OpenStreetMap.Mapnik",
-        "OpenStreetMap DE" = "OpenStreetMap.DE",
-        "OpenTopoMap" = "OpenTopoMap",
-        "Stamen TonerLite" = "Stamen.TonerLite",
-        "Esri" = "Esri",
-        "Esri WorldTopoMap" = "Esri.WorldTopoMap",
-        "Esri OceanBasemap" = "Esri.OceanBasemap"
+        `borders & names`= list(
+        "CartoDB.Positron",
+        "OpenStreetMap.Mapnik",
+        "OpenStreetMap.DE",
+        "OpenTopoMap",
+        "Stamen.TonerLite",
+        "Esri",
+        "Esri.WorldTopoMap",
+        "Esri.OceanBasemap"
       ),
-      `only borders`= c(
-        "CartoDB Positron No Labels" = "CartoDB.PositronNoLabels"
+      `only borders`= list(
+        "CartoDB.PositronNoLabels"
       ),
-      `plain maps`= c(
-        "Esri WorldImagery" = "Esri.WorldImagery",
-        "Esri WorldTerrain" = "Esri.WorldTerrain",
-        "Esri WorldShadedRelief" = "Esri.WorldShadedRelief",
-        "Esri WorldPhysical" = "Esri.WorldPhysical"
+      `plain maps`= list(
+        "Esri.WorldImagery",
+        "Esri.WorldTerrain",
+        "Esri.WorldShadedRelief",
+        "Esri.WorldPhysical"
       ),
-      `custom maps` = c(
-        "Stamen.Watercolor" = "Stamen.Watercolor"
+      `custom maps` = list(
+        "Stamen.Watercolor"
       )
     ),
     options = list(create = TRUE)
@@ -87,7 +87,7 @@ leafletSettingsUI <- function(id, title = "") {
              align = "right",
              actionButton(ns(
                "centerMapButton"
-             ), "Center map"))
+             ), "Center map", width = "100%"))
     ),
     conditionalPanel(
       condition = "input.fitBounds == true",

R/03-interactiveMap.R

@@ -246,7 +246,8 @@ interactiveMap <- function(input, output, session, isoData) {
         showLegend = leafletPointValues$showColourLegend,
         title = leafletPointValues$columnForPointColour,
         pal = leafletPointValues$pointColourPalette,
-        values = isoData()[[leafletPointValues$columnForPointColour]]
+        values = getColourCol(isoData(),
+                              colName = leafletPointValues$columnForPointColour)
       )
   })