Merge pull request #235 from 4DModeller/devel

Release 0.1.1

.github/workflows/check-standard.yaml

@@ -3,8 +3,12 @@
 on:
   push:
     branches: [main, devel]
+    paths-ignore:
+      - "CHANGELOG.md"
   pull_request:
     branches: [main, devel]
+    paths-ignore:
+      - "CHANGELOG.md"
 
 name: R-CMD-check
 
@@ -16,8 +20,8 @@ jobs:
       fail-fast: false
       matrix:
         config:
-          - {os: macos-latest,   r: 'release'}
-          - {os: ubuntu-latest,   r: 'release'}
+          - { os: macos-latest, r: "release" }
+          - { os: ubuntu-latest, r: "release" }
     env:
       GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
       R_REMOTES_NO_ERRORS_FROM_WARNINGS: true

CHANGELOG.md

@@ -5,7 +5,28 @@ All notable changes to `fdmr` will be documented in this file.
 The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/),
 and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html).
 
-## [Unreleased]
+## [Unreleased](https://github.com/openghg/openghg/compare/0.1.1...HEAD)
+
+## [0.1.1] - 2023-11-01
+
+### Added
+
+- Added the ability to select a custom range for the colour map - [PR #218](https://github.com/4DModeller/fdmr/pull/218)
+
+### Fixed
+
+- Added check for `time_variable` being passed into model builder Shiny app - [PR #216](https://github.com/4DModeller/fdmr/pull/216)
+- Clear button not clearing all checkboxes in model builder Shiny app - [PR #215](https://github.com/4DModeller/fdmr/pull/215)
+- Corrected code in code pane of model builder Shiny app - [PR #208](https://github.com/4DModeller/fdmr/pull/208)
+- Code displayed in the Code tab of the mesh builder Shiny app couldn't be copied and pasted and used - [PR #233](https://github.com/4DModeller/fdmr/pull/233)
+
+### Changed
+
+- Allowed reversal of colour palette and added raster plot legend in map plotter - [PR #229](https://github.com/4DModeller/fdmr/pull/229)
+- Added markers option to mesh plotter - [PR #230](https://github.com/4DModeller/fdmr/pull/230)
+- Updated the interfaces of the Shiny apps to the use [bslib](https://rstudio.github.io/bslib/index.html) theming - [PR #236](https://github.com/4DModeller/fdmr/pull/236)
+
+## [0.1.0] - 2023-10-17
 
 ### Added
 
@@ -15,7 +36,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
 - Clearer documentation on types expected by the `mesh_builder` tool - [PR #101](https://github.com/4DModeller/fdmr/pull/101)
 - Checks on the data types being passed into the `mesh_builder` tool - [PR #101](https://github.com/4DModeller/fdmr/pull/101)
 - Ability to plot either polygon or point data on Leaflet map of `mesh_builder` tool - [PR #101](https://github.com/4DModeller/fdmr/pull/101)
-- The ability to plot model predictions on a `leaflet` map in the our [Interactive priors Shiny app](https://4dmodeller.github.io/fdmr/articles/priors_app.html) - [PR #147](https://github.com/4DModeller/fdmr/pull/147)
+- The ability to plot model predictions on a `leaflet` map in the our [Model builder Shiny app](https://4dmodeller.github.io/fdmr/articles/modelbuilder.html) - [PR #147](https://github.com/4DModeller/fdmr/pull/147)
 - A new Shiny app to parse and plot INLA model output, letting users easily view model parameters and predictions on a map - [PR #158](https://github.com/4DModeller/fdmr/pull/158)
 
 ### Fixed

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: fdmr
 Title: 4D Modeller project
-Version: 0.1.0
+Version: 0.1.1
 Authors@R: 
     c(person("Gareth", "Jones", , "[email protected]", role = c("aut", "cre"),
             comment = ""),
@@ -54,7 +54,8 @@ Imports:
     promises,
     fmesher,
     purrr,
-    shinyjs
+    shinyjs,
+    bslib
 Suggests: 
     bookdown,
     knitr,

R/model_parse.R

@@ -6,28 +6,28 @@
 #' @return list
 #' @keywords internal
 parse_model_output_bru <- function(model_output, measurement_data) {
-    fitted_mean_post <- model_output$summary.fitted.values$mean[seq_len(nrow(measurement_data))]
-    fitted_sd_post <- model_output$summary.fitted.values$sd[seq_len(nrow(measurement_data))]
+  fitted_mean_post <- model_output$summary.fitted.values$mean[seq_len(nrow(measurement_data))]
+  fitted_sd_post <- model_output$summary.fitted.values$sd[seq_len(nrow(measurement_data))]
 
-    random_effect_fields <- model_output$summary.random$f$mean
-    mean_post <- model_output$summary.random$f$mean
-    sd_post <- model_output$summary.random$f$sd
-    fixed_mean <- model_output$summary.fixed$mean
-    dic <- model_output$dic$dic
-    pars <- model_output$marginals.hyperpar
+  random_effect_fields <- model_output$summary.random$f$mean
+  mean_post <- model_output$summary.random$f$mean
+  sd_post <- model_output$summary.random$f$sd
+  fixed_mean <- model_output$summary.fixed$mean
+  dic <- model_output$dic$dic
+  pars <- model_output$marginals.hyperpar
 
-    parsed_output <- list(
-        fitted_mean_post = fitted_mean_post,
-        fitted_sd_post = fitted_sd_post,
-        random_effect_fields = random_effect_fields,
-        mean_post = mean_post,
-        sd_post = sd_post,
-        fixed_mean = fixed_mean,
-        dic = dic,
-        pars = pars
-    )
+  parsed_output <- list(
+    fitted_mean_post = fitted_mean_post,
+    fitted_sd_post = fitted_sd_post,
+    random_effect_fields = random_effect_fields,
+    mean_post = mean_post,
+    sd_post = sd_post,
+    fixed_mean = fixed_mean,
+    dic = dic,
+    pars = pars
+  )
 
-    return(parsed_output)
+  return(parsed_output)
 }
 
 
@@ -40,9 +40,9 @@ parse_model_output_bru <- function(model_output, measurement_data) {
 #' @return list
 #' @export
 parse_model_output <- function(model_output, measurement_data, model_type = "inlabru") {
-    if (model_type == "inlabru") {
-        return(parse_model_output_bru(model_output = model_output, measurement_data = measurement_data))
-    }
+  if (model_type == "inlabru") {
+    return(parse_model_output_bru(model_output = model_output, measurement_data = measurement_data))
+  }
 }
 
 
@@ -61,33 +61,33 @@ create_prediction_field <- function(mesh,
                                     data_dist = "poisson",
                                     var_a = NULL,
                                     var_b = NULL) {
-    valid_plots <- c("predicted_mean_fields", "random_effect_fields")
-    if (!(plot_type %in% valid_plots)) {
-        stop("Invalid plot type, select from ", valid_plots)
-    }
+  valid_plots <- c("predicted_mean_fields", "random_effect_fields")
+  if (!(plot_type %in% valid_plots)) {
+    stop("Invalid plot type, select from ", valid_plots)
+  }
 
-    data_dist <- tolower(data_dist)
-    valid_data_dists <- c("poisson", "gaussian")
-    if (!(data_dist %in% valid_data_dists)) {
-        stop("Invalid data type, select from ", valid_data_dists)
-    }
+  data_dist <- tolower(data_dist)
+  valid_data_dists <- c("poisson", "gaussian")
+  if (!(data_dist %in% valid_data_dists)) {
+    stop("Invalid data type, select from ", valid_data_dists)
+  }
 
-    if (plot_type == "predicted_mean_fields" && is.null(var_b)) {
-        stop("var_b must be provided for predicted_mean_fields plot")
-    }
+  if (plot_type == "predicted_mean_fields" && is.null(var_b)) {
+    stop("var_b must be provided for predicted_mean_fields plot")
+  }
 
-    mod_proj <- fmesher::fm_evaluator(mesh)
-    xy_grid <- base::expand.grid(mod_proj$x, mod_proj$y)
-    A_proj <- INLA::inla.spde.make.A(mesh = mesh, loc = as.matrix(xy_grid))
+  mod_proj <- fmesher::fm_evaluator(mesh)
+  xy_grid <- base::expand.grid(mod_proj$x, mod_proj$y)
+  A_proj <- INLA::inla.spde.make.A(mesh = mesh, loc = as.matrix(xy_grid))
 
-    if (plot_type == "predicted_mean_fields") {
-        z <- base::as.numeric(A_proj %*% var_a[1:mesh$n]) + base::sum(var_b)
-        if (data_dist == "poisson") z <- base::exp(z)
-    } else {
-        # We get an error here as we only have 265 items
-        # z <- var_a[1:mesh$n]
-        z <- base::as.numeric(A_proj %*% var_a[1:mesh$n])
-    }
+  if (plot_type == "predicted_mean_fields") {
+    z <- base::as.numeric(A_proj %*% var_a[1:mesh$n]) + base::sum(var_b)
+    if (data_dist == "poisson") z <- base::exp(z)
+  } else {
+    # We get an error here as we only have 265 items
+    # z <- var_a[1:mesh$n]
+    z <- base::as.numeric(A_proj %*% var_a[1:mesh$n])
+  }
 
-    base::data.frame(x = xy_grid[, 1], y = xy_grid[, 2], z = z)
+  base::data.frame(x = xy_grid[, 1], y = xy_grid[, 2], z = z)
 }

R/plot_mapping.R

@@ -11,6 +11,7 @@
 #' @param polygon_fill_colour Polygon fill colour
 #' @param polygon_line_colour Polygon surrounding line colour
 #' @param polygon_line_weight Polygon surrounding line weight
+#' @param reverse Reverse the colour palette if TRUE
 #'
 #' @return leaflet::leaflet
 #' @export
@@ -24,7 +25,8 @@ plot_map <- function(polygon_data = NULL,
                      polygon_fill_colour = "#E4572E",
                      polygon_line_colour = "grey",
                      polygon_line_weight = 1,
-                     polygon_fill_opacity = 0.6) {
+                     polygon_fill_opacity = 0.6,
+                     reverse = FALSE) {
   if (is.null(polygon_data) && is.null(raster_data)) {
     stop("Polygon or raster data must be given.")
   }
@@ -39,7 +41,7 @@ plot_map <- function(polygon_data = NULL,
 
   if (!is.null(polygon_data)) {
     if (!is.null(domain)) {
-      colours <- leaflet::colorNumeric(palette = palette, domain = domain, reverse = FALSE)
+      colours <- leaflet::colorNumeric(palette = palette, domain = domain, reverse = reverse)
       polygon_fill_colour <- ~ colours(domain)
       m <- leaflet::addLegend(m,
         pal = colours,
@@ -61,12 +63,20 @@ plot_map <- function(polygon_data = NULL,
   }
 
   if (!is.null(raster_data)) {
+    colours <- leaflet::colorNumeric(palette = palette, domain = raster::values(raster_data), na.color=rgb(0,0,0,0), reverse = reverse)
     m <- leaflet::addRasterImage(m,
       x = raster_data,
       opacity = 0.75,
       group = "Raster",
       layerId = "raster",
-      colors = palette,
+      colors = colours,
+    )
+    m <- leaflet::addLegend(m,
+                            pal = colours,
+                            values = raster::values(raster_data),
+                            opacity = 0.75,
+                            title = legend_title,
+                            na.label = ""
     )
     layers <- append(layers, "Raster")
   }

R/plot_mesh.R

@@ -5,10 +5,12 @@
 #' that can be converted to a data.frame with longitude and latitude columns
 #' @param longitude_column Longitude column in spatial_data
 #' @param latitude_column Latitude column in spatial_data name
+#' @param markers Markers to display on top of mesh. A named list with latitude, longitude and label names must be given.
+#' Expects longitude name to be longitude, latitude name to be latitude, label name to be label.
 #'
 #' @return leaflet::leaflet
 #' @export
-plot_mesh <- function(mesh, spatial_data = NULL, longitude_column = "LONG", latitude_column = "LAT") {
+plot_mesh <- function(mesh, spatial_data = NULL, longitude_column = "LONG", latitude_column = "LAT", markers = NULL) {
   expected_crs <- "+proj=longlat +datum=WGS84"
   crs_string <- fmesher::fm_proj4string(mesh)
 
@@ -24,7 +26,6 @@ plot_mesh <- function(mesh, spatial_data = NULL, longitude_column = "LONG", lati
 
   spatial_mesh <- fdmr::mesh_to_spatial(mesh = mesh, crs = expected_crs)
 
-
   plot_polygons <- FALSE
   plot_points <- FALSE
   if (!is.null(spatial_data)) {
@@ -68,6 +69,11 @@ plot_mesh <- function(mesh, spatial_data = NULL, longitude_column = "LONG", lati
     overlay_groups <- append(overlay_groups, "Spatial")
   }
 
+  if (!is.null(markers)) {
+    m <- leaflet::addMarkers(m, lng = markers$longitude, lat = markers$latitude, label = markers$label, group = "Markers")
+    overlay_groups <- append(overlay_groups, "Markers")
+  }
+
   m <- leaflet::addLayersControl(m,
     position = "topright",
     baseGroups = c("OSM"),