diff --git a/DESCRIPTION b/DESCRIPTION index e8f330f3..c47e1184 100644 --- a/DESCRIPTION +++ b/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 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, diff --git a/NEWS.md b/NEWS.md index 656d7c11..fcad7f77 100644 --- a/NEWS.md +++ b/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 diff --git a/R/02-leafletExport.R b/R/02-leafletExport.R index 74906424..f1e0ff6d 100644 --- a/R/02-leafletExport.R +++ b/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( diff --git a/R/02-leafletPointSettings.R b/R/02-leafletPointSettings.R index e1d0fe71..ac5c6f0b 100644 --- a/R/02-leafletPointSettings.R +++ b/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,18 +278,15 @@ 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 } @@ -308,13 +294,13 @@ pointSizeServer <- function(id, loadedData) { 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) { diff --git a/R/02-leafletSettings.R b/R/02-leafletSettings.R index 8f71a6b3..9fe42b9a 100644 --- a/R/02-leafletSettings.R +++ b/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", diff --git a/R/03-interactiveMap.R b/R/03-interactiveMap.R index 04b67a53..9ffeaef2 100644 --- a/R/03-interactiveMap.R +++ b/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) ) })