From b9f4b809abf0c9f473acf06395e2eec0c5e9969a Mon Sep 17 00:00:00 2001 From: Gareth Jones Date: Thu, 28 Sep 2023 10:43:12 +0100 Subject: [PATCH 01/17] Adding purrr to imports, updating Shiny app to use raster of predictions, updating vignette to cover new map tab --- DESCRIPTION | 4 ++-- NAMESPACE | 2 ++ R/model_parse.R | 23 +++++++++++++++++++++++ R/shiny_priors.R | 40 ++++++++++++++++++++++++++++++++++++++-- vignettes/priors_app.Rmd | 32 ++++++++++++++++++++++++++------ 5 files changed, 91 insertions(+), 10 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 171da618..868b92b1 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -55,7 +55,8 @@ Imports: shinybusy, curl, promises, - fmesher + fmesher, + purrr Suggests: bookdown, knitr, @@ -67,4 +68,3 @@ Suggests: rcmdcheck Config/testthat/edition: 3 VignetteBuilder: knitr - diff --git a/NAMESPACE b/NAMESPACE index 49236911..6568fe30 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,6 +1,7 @@ # Generated by roxygen2: do not edit by hand export(clear_caches) +export(create_prediction_field) export(get_busy_spinner) export(get_tmpdir) export(get_tutorial_datapath) @@ -11,6 +12,7 @@ export(load_tutorial_data) export(mesh_builder) export(mesh_checker) export(mesh_to_spatial) +export(model_viewer) export(numbers_only) export(parse_model_output) export(plot_barchart) diff --git a/R/model_parse.R b/R/model_parse.R index a4e89dfa..97af9e36 100644 --- a/R/model_parse.R +++ b/R/model_parse.R @@ -43,3 +43,26 @@ parse_model_output <- function(model_output, measurement_data, model_type = "inl return(parse_model_output_bru(model_output = model_output, measurement_data = measurement_data)) } } + + +#' Create a prediction field from the parsed model output and the mesh +#' +#' @param var_a +#' @param var_b +#' @param mesh +#' +#' @return data.frame +#' @export +create_prediction_field <- function(var_a, var_b, mesh) { + 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)) + + z <- base::exp(base::as.numeric(A_proj %*% var_a[1:mesh$n]) + base::sum(var_b)) + base::data.frame(x = xy_grid[, 1], y = xy_grid[, 2], z = z) +} + + +create_raster <- function(dataframe, crs) { + raster::rasterFromXYZ(dataframe, crs = crs) +} \ No newline at end of file diff --git a/R/shiny_priors.R b/R/shiny_priors.R index 30564eb0..dfb5b462 100644 --- a/R/shiny_priors.R +++ b/R/shiny_priors.R @@ -157,9 +157,16 @@ priors_shiny <- function(spatial_data, shiny::selectInput(inputId = "plot_type", label = "Plot type:", choices = plot_choices, selected = plot_choices[1]), shiny::plotOutput(outputId = "plot_model_out") ), + shiny::tabPanel( + "Map", + shiny::selectInput(inputId = "select_run_map", label = "Select run:", choices = c()), + shiny::selectInput(inputId = "map_var_a", label = "Variable a:", choices = c()), + shiny::selectInput(inputId = "map_var_b", label = "Variable b:", choices = c()), + leaflet::leafletOutput(outputId = "map_out") + ), shiny::tabPanel( "Code", - shiny::selectInput(inputId = "select_run", label = "Select run:", choices = c()), + shiny::selectInput(inputId = "select_run_code", label = "Select run:", choices = c()), shiny::verbatimTextOutput(outputId = "code_out") ), shiny::tabPanel( @@ -200,8 +207,20 @@ priors_shiny <- function(spatial_data, names(model_vals$run_params) }) + model_summary_variables <- shiny::reactive({ + names(model_vals$model_outputs) + }) + shiny::observe({ - shiny::updateSelectInput(session = session, inputId = "select_run", choices = run_names()) + shiny::updateSelectInput(session = session, inputId = "select_run_map", choices = run_names()) + shiny::updateSelectInput(session = session, inputId = "select_run_code", choices = run_names()) + + if (!is.null(run_names())) { + run_name <- run_names()[1] + var_names <- names(model_vals$parsed_outputs[[run_name]]) + shiny::updateSelectInput(session = session, inputId = "map_var_a", choices = var_names) + shiny::updateSelectInput(session = session, inputId = "map_var_b", choices = var_names) + } }) shiny::observeEvent(input$features, { @@ -355,6 +374,23 @@ priors_shiny <- function(spatial_data, rownames = TRUE ) + map_plot <- shiny::eventReactive(input$select_run_map, ignoreNULL = FALSE, { + if (length(model_vals$parsed_outputs) == 0) { + return() + } + + data <- model_vals$parsed_outputs[[input$select_run_map]] + pred_field <- create_prediction_field(var_a = input$map_var_a, var_b = input$map_var_b, mesh = mesh) + create_raster(dataframe = pred_field, crs = sp::proj4string(spatial_data)) + }) + + output$map_out <- leaflet::renderLeaflet({ + m <- leaflet::leaflet() + m <- leaflet::addTiles(m, group = "OSM") + m <- leaflet::addRasterImage(m, map_plot(), opacity = 0.9, group = "Raster") + m + }) + model_plot <- shiny::eventReactive(input$plot_type, ignoreNULL = FALSE, { if (length(model_vals$parsed_outputs) == 0) { return() diff --git a/vignettes/priors_app.Rmd b/vignettes/priors_app.Rmd index 937c98b7..1f7a1dc0 100644 --- a/vignettes/priors_app.Rmd +++ b/vignettes/priors_app.Rmd @@ -41,13 +41,13 @@ utils::head(covid19_data) # Create the mesh -We can have a look at the mesh and change it interactively using the `mesh_builder` Shiny app. Using the app I came up with a mesh with the following parameters, we'll use this -and pass it into the Setting Priors Shiny app below. +We can have a look at the mesh and change it interactively using the `fdmr::mesh_builder` Shiny app. Using the app I came up with a mesh with the following parameters, we'll use this and pass it into the "Setting Priors Shiny app" below. ```{r createmesh, error=TRUE} initial_range <- diff(base::range(sp_data@data[, "LONG"])) / 3 max_edge <- initial_range / 2 -mesh <- INLA::inla.mesh.2d( + +mesh <- fmesher::fm_mesh_2d_inla( loc = sp_data@data[, c("LONG", "LAT")], max.edge = c(1, 2) * max_edge, offset = c(initial_range, initial_range), @@ -64,7 +64,7 @@ n_groups <- length(unique(covid19_data$week)) # Set coordinates on data -We will use the function `bru()` of package `inlabru` to fit the model. `bru` expects the coordinates of the data, thus we transform `covid19_data_bris` data set to a SpatialPointsDataFrame using the function `coordinates()` of the `sp` package. +We will use the function [`inlabru::bru`](https://inlabru-org.github.io/inlabru/reference/bru.html) function to fit the model which expects the coordinates of the data, thus we transform `covid19_data` data set to a [`SpatialPointsDataFrame`](https://www.rdocumentation.org/packages/sp/versions/2.0-0/topics/SpatialPointsDataFrame-class) using the [`sp::coordinates`](https://www.rdocumentation.org/packages/sp/versions/2.0-0/topics/coordinates) function. ```{r, error=TRUE, eval=FALSE} sp::coordinates(covid19_data) <- c("LONG", "LAT") @@ -74,10 +74,30 @@ sp::coordinates(covid19_data) <- c("LONG", "LAT") Now we have the filtered data we are ready to pass in the spatial -First start by selecting the variable to model. In this example we'll select `cases`, then select the features to add to the formula. At the bottom of the window you'll see the formula being constructed. -Click on the checkboxes to select your formula and then click the `Run Model` button to run the model see it's output plot on the right of the window. +## Selecting priors + +First start by selecting the variable to model. In this example we'll select `cases`, then select the features to add to the formula. At the bottom of the window you'll see the formula being constructed. Once you've setup the formula to your specifications click on the `Model` tab and click `Run`. Once the model run has finished you'll see a table of summarised model outputs. + +## Plotting model outputs + +Once the model has run you view plots of model outputs by clicking on the `Plot` tab. Each time you run a model with different sets or priors the parsed model output saved and can be compared with previous runs. + +## Plotting model ouputs on a map + +To plot model predictions on a map click on the `Map` tab. This will use the `fdmr::create_prediction_field` and `fdmr::create_raster` functions to first create a `data.frame` of model predictions and then create a raster image from this data. + +## Saving model outputs + By default the app will write out parameter sets and logs to the `fdmr/logs` directory in your home folder. If you want these logs to be written to a different folder, you can pass in the folder path to the `log_folder` argument. +We're now ready to run the app. To do this we'll call the `fdmr::interactive_priors` function, passing in + +- `sp_data` - the spatial data covering areas across the city of Bristol +- `covid19_data` - the COVID-19 data we want to model +- `mesh` - the mesh we created above + +data we want to use, the measurement data + ```{r eval=FALSE} fdmr::interactive_priors(spatial_data = sp_data, measurement_data = covid19_data, mesh=mesh, time_variable="week") ``` From cc989b0babd5e7b705302cc98d652ccd71fb42ce Mon Sep 17 00:00:00 2001 From: Gareth Jones Date: Thu, 28 Sep 2023 12:21:01 +0100 Subject: [PATCH 02/17] WIP: Correct getting of variable names, now getting no raster plotted, need to check this --- R/model_parse.R | 2 +- R/shiny_priors.R | 27 ++++++++++++++++++++++----- vignettes/priors_app.Rmd | 15 +++++++-------- 3 files changed, 30 insertions(+), 14 deletions(-) diff --git a/R/model_parse.R b/R/model_parse.R index 97af9e36..17ab6c43 100644 --- a/R/model_parse.R +++ b/R/model_parse.R @@ -58,7 +58,7 @@ create_prediction_field <- function(var_a, var_b, 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)) - z <- base::exp(base::as.numeric(A_proj %*% var_a[1:mesh$n]) + base::sum(var_b)) + z <- base::exp(base::as.numeric(A_proj %*% var_a[1:mesh$n]) + base::sum(var_b)) base::data.frame(x = xy_grid[, 1], y = xy_grid[, 2], z = z) } diff --git a/R/shiny_priors.R b/R/shiny_priors.R index dfb5b462..cdcc73eb 100644 --- a/R/shiny_priors.R +++ b/R/shiny_priors.R @@ -216,8 +216,10 @@ priors_shiny <- function(spatial_data, shiny::updateSelectInput(session = session, inputId = "select_run_code", choices = run_names()) if (!is.null(run_names())) { + # They'll all have the same variable names so we can just take the first run_name <- run_names()[1] var_names <- names(model_vals$parsed_outputs[[run_name]]) + shiny::updateSelectInput(session = session, inputId = "map_var_a", choices = var_names) shiny::updateSelectInput(session = session, inputId = "map_var_b", choices = var_names) } @@ -319,8 +321,10 @@ priors_shiny <- function(spatial_data, function(model_output) { # Run the model run_no(run_no() + 1) - model_vals$model_outputs[[run_no()]] <- model_output - model_vals$parsed_outputs[[run_no()]] <- parse_model_output( + run_label <- paste0("Run-", run_no()) + + model_vals$model_outputs[[run_label]] <- model_output + model_vals$parsed_outputs[[run_label]] <- parse_model_output( model_output = model_output, measurement_data = measurement_data ) @@ -335,7 +339,6 @@ priors_shiny <- function(spatial_data, "pg_ar1" = input$pg_ar1 ) - run_label <- paste0("Run-", run_no()) model_vals$run_params[[run_label]] <- run_params if (write_logs) { @@ -374,17 +377,31 @@ priors_shiny <- function(spatial_data, rownames = TRUE ) - map_plot <- shiny::eventReactive(input$select_run_map, ignoreNULL = FALSE, { + map_raster <- shiny::eventReactive(input$select_run_map, ignoreNULL = FALSE, { if (length(model_vals$parsed_outputs) == 0) { return() } data <- model_vals$parsed_outputs[[input$select_run_map]] - pred_field <- create_prediction_field(var_a = input$map_var_a, var_b = input$map_var_b, mesh = mesh) + + 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)) + + var_a <- data$mean_post[input$map_var_a] + var_b <- data$mean_post[input$map_var_b] + + z <- base::exp(base::as.numeric(A_proj %*% var_a[1:mesh$n]) + base::sum(var_b)) + pred_field <- base::data.frame(x = xy_grid[, 1], y = xy_grid[, 2], z = z) + # pred_field <- create_prediction_field(var_a = input$map_var_a, var_b = input$map_var_b, mesh = mesh) create_raster(dataframe = pred_field, crs = sp::proj4string(spatial_data)) }) output$map_out <- leaflet::renderLeaflet({ + if (is.null(map_plot())) { + return() + } + m <- leaflet::leaflet() m <- leaflet::addTiles(m, group = "OSM") m <- leaflet::addRasterImage(m, map_plot(), opacity = 0.9, group = "Raster") diff --git a/vignettes/priors_app.Rmd b/vignettes/priors_app.Rmd index 1f7a1dc0..79b9ad5b 100644 --- a/vignettes/priors_app.Rmd +++ b/vignettes/priors_app.Rmd @@ -92,11 +92,10 @@ By default the app will write out parameter sets and logs to the `fdmr/logs` dir We're now ready to run the app. To do this we'll call the `fdmr::interactive_priors` function, passing in -- `sp_data` - the spatial data covering areas across the city of Bristol -- `covid19_data` - the COVID-19 data we want to model -- `mesh` - the mesh we created above - -data we want to use, the measurement data +- `spatial_data = sp_data` - the spatial data covering areas across the city of Bristol +- `measurement_data = covid19_data` - the COVID-19 data we want to model +- `mesh = mesh` - the mesh we created above +- `time_variable = week` - the name of the time variable in the data ```{r eval=FALSE} fdmr::interactive_priors(spatial_data = sp_data, measurement_data = covid19_data, mesh=mesh, time_variable="week") @@ -106,6 +105,6 @@ fdmr::interactive_priors(spatial_data = sp_data, measurement_data = covid19_data The outputs of the model run by the app can be viewed in the `fdmr/logs` folder in your home directory. There you'll find three log files -1. `priors_exploration_applog_timestamp.txt` - holds general logging information and errors -2. `priors_exploration_parameters_timestamp.json` - holds the priors used in each model run -3. `priors_exploration_modelout_timestamp.rds` - holds the model output for each run +- `priors_exploration_applog_timestamp.txt` - holds general logging information and errors +- `priors_exploration_parameters_timestamp.json` - holds the priors used in each model run +- `priors_exploration_modelout_timestamp.rds` - holds the model output for each run From c312772987ee3f413c9c3020933cfa85c23074ff Mon Sep 17 00:00:00 2001 From: Gareth Jones Date: Thu, 28 Sep 2023 15:27:57 +0100 Subject: [PATCH 03/17] Raster projection working --- R/shiny_priors.R | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/R/shiny_priors.R b/R/shiny_priors.R index cdcc73eb..cf8ede50 100644 --- a/R/shiny_priors.R +++ b/R/shiny_priors.R @@ -377,7 +377,7 @@ priors_shiny <- function(spatial_data, rownames = TRUE ) - map_raster <- shiny::eventReactive(input$select_run_map, ignoreNULL = FALSE, { + map_raster <- shiny::reactive({ if (length(model_vals$parsed_outputs) == 0) { return() } @@ -388,23 +388,25 @@ priors_shiny <- function(spatial_data, 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)) - var_a <- data$mean_post[input$map_var_a] - var_b <- data$mean_post[input$map_var_b] + var_a <- data[[input$map_var_a]] + var_b <- data[[input$map_var_b]] z <- base::exp(base::as.numeric(A_proj %*% var_a[1:mesh$n]) + base::sum(var_b)) pred_field <- base::data.frame(x = xy_grid[, 1], y = xy_grid[, 2], z = z) # pred_field <- create_prediction_field(var_a = input$map_var_a, var_b = input$map_var_b, mesh = mesh) - create_raster(dataframe = pred_field, crs = sp::proj4string(spatial_data)) + raster <- create_raster(dataframe = pred_field, crs = sp::proj4string(spatial_data)) + + return(raster) }) output$map_out <- leaflet::renderLeaflet({ - if (is.null(map_plot())) { + if (is.null(map_raster())) { return() } m <- leaflet::leaflet() m <- leaflet::addTiles(m, group = "OSM") - m <- leaflet::addRasterImage(m, map_plot(), opacity = 0.9, group = "Raster") + m <- leaflet::addRasterImage(m, map_raster(), opacity = 0.9, group = "Raster") m }) From 99d9daa187e41251a98b78ffc5b0d28c034f1152 Mon Sep 17 00:00:00 2001 From: Gareth Jones Date: Thu, 28 Sep 2023 15:45:51 +0100 Subject: [PATCH 04/17] Ensure correct update and defaults of map vars --- R/shiny_priors.R | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/R/shiny_priors.R b/R/shiny_priors.R index cf8ede50..daf23966 100644 --- a/R/shiny_priors.R +++ b/R/shiny_priors.R @@ -220,8 +220,18 @@ priors_shiny <- function(spatial_data, run_name <- run_names()[1] var_names <- names(model_vals$parsed_outputs[[run_name]]) - shiny::updateSelectInput(session = session, inputId = "map_var_a", choices = var_names) - shiny::updateSelectInput(session = session, inputId = "map_var_b", choices = var_names) + selected_a <- NULL + selected_b <- NULL + if ("mean_post" %in% var_names) { + selected_a <- "mean_post" + } + + if ("fixed_mean" %in% var_names) { + selected_b <- "fixed_mean" + } + + shiny::updateSelectInput(session = session, inputId = "map_var_a", choices = var_names, selected = selected_a) + shiny::updateSelectInput(session = session, inputId = "map_var_b", choices = var_names, selected = selected_b) } }) From 7d6615692c3ab40be81647974ae5899730292947 Mon Sep 17 00:00:00 2001 From: Gareth Jones Date: Thu, 28 Sep 2023 16:27:12 +0100 Subject: [PATCH 05/17] Add note to changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 0bbdb067..40b89524 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -15,6 +15,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) ### Fixed From d51f46e45338c6081334850c271f242f9c243594 Mon Sep 17 00:00:00 2001 From: Gareth Jones Date: Thu, 28 Sep 2023 16:34:12 +0100 Subject: [PATCH 06/17] Tidy code back into function call --- R/shiny_priors.R | 16 ++-------------- 1 file changed, 2 insertions(+), 14 deletions(-) diff --git a/R/shiny_priors.R b/R/shiny_priors.R index daf23966..294a1d68 100644 --- a/R/shiny_priors.R +++ b/R/shiny_priors.R @@ -393,20 +393,8 @@ priors_shiny <- function(spatial_data, } data <- model_vals$parsed_outputs[[input$select_run_map]] - - 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)) - - var_a <- data[[input$map_var_a]] - var_b <- data[[input$map_var_b]] - - z <- base::exp(base::as.numeric(A_proj %*% var_a[1:mesh$n]) + base::sum(var_b)) - pred_field <- base::data.frame(x = xy_grid[, 1], y = xy_grid[, 2], z = z) - # pred_field <- create_prediction_field(var_a = input$map_var_a, var_b = input$map_var_b, mesh = mesh) - raster <- create_raster(dataframe = pred_field, crs = sp::proj4string(spatial_data)) - - return(raster) + pred_field <- create_prediction_field(var_a = data[[input$map_var_a]], var_b = data[[input$map_var_b]], mesh = mesh) + create_raster(dataframe = pred_field, crs = sp::proj4string(spatial_data)) }) output$map_out <- leaflet::renderLeaflet({ From d80d44e4394f1d11237d67e2373cd6e872fb4065 Mon Sep 17 00:00:00 2001 From: Gareth Jones Date: Fri, 6 Oct 2023 14:49:37 +0100 Subject: [PATCH 07/17] Adding fixed plot types per Xueqings changes --- NAMESPACE | 1 + R/model_parse.R | 45 +++++++++++++++++++++++++++++++++++++-------- R/shiny_priors.R | 43 +++++++++++++++++++++---------------------- 3 files changed, 59 insertions(+), 30 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 7972db2c..da245e92 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,6 +1,7 @@ # Generated by roxygen2: do not edit by hand export(clear_caches) +export(create_prediction_field) export(get_tmpdir) export(get_tutorial_datapath) export(interactive_priors) diff --git a/R/model_parse.R b/R/model_parse.R index 17ab6c43..afd9050e 100644 --- a/R/model_parse.R +++ b/R/model_parse.R @@ -9,7 +9,7 @@ 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))] - mean_post <- model_output$summary.random$f$mean + random_effect_fields <- model_output$summary.random$f$mean sd_post <- model_output$summary.random$f$sd fixed_mean <- model_output$summary.fixed$mean @@ -19,7 +19,7 @@ parse_model_output_bru <- function(model_output, measurement_data) { parsed_output <- list( fitted_mean_post = fitted_mean_post, fitted_sd_post = fitted_sd_post, - mean_post = mean_post, + random_effect_fields = random_effect_fields, sd_post = sd_post, fixed_mean = fixed_mean, dic = dic, @@ -47,22 +47,51 @@ parse_model_output <- function(model_output, measurement_data, model_type = "inl #' Create a prediction field from the parsed model output and the mesh #' -#' @param var_a -#' @param var_b -#' @param mesh +#' @param mesh INLA mesh +#' @param plot_type Type of plot to create, "predicted_mean_fields" etc +#' @param data_type Type of data, "poisson" etc +#' @param var_a Data for variable a, required for "predicted_mean_fields" and "random_effect_fields" +#' @param var_b Data for variable b, required for "predicted_mean_fields" #' #' @return data.frame #' @export -create_prediction_field <- function(var_a, var_b, mesh) { +create_prediction_field <- function(mesh, + plot_type = "predicted_mean_fields", + data_type = "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_data_types <- c("poisson", "gaussian") + if (!(data_type %in% valid_data_types)) { + stop("Invalid data type, select from ", valid_data_types) + } + + 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)) - z <- base::exp(base::as.numeric(A_proj %*% var_a[1:mesh$n]) + base::sum(var_b)) + if (plot_type == "predicted_mean_fields") { + if (data_type == "poisson") { + z <- base::exp(base::as.numeric(A_proj %*% var_a[1:mesh$n]) + base::sum(var_b)) + } else { + z <- base::as.numeric(A_proj %*% var_a[1:mesh$n]) + base::sum(var_b) + } + } else { + z <- var_a[1:mesh$n] + } + base::data.frame(x = xy_grid[, 1], y = xy_grid[, 2], z = z) } create_raster <- function(dataframe, crs) { raster::rasterFromXYZ(dataframe, crs = crs) -} \ No newline at end of file +} diff --git a/R/shiny_priors.R b/R/shiny_priors.R index 294a1d68..32344659 100644 --- a/R/shiny_priors.R +++ b/R/shiny_priors.R @@ -160,8 +160,8 @@ priors_shiny <- function(spatial_data, shiny::tabPanel( "Map", shiny::selectInput(inputId = "select_run_map", label = "Select run:", choices = c()), - shiny::selectInput(inputId = "map_var_a", label = "Variable a:", choices = c()), - shiny::selectInput(inputId = "map_var_b", label = "Variable b:", choices = c()), + shiny::selectInput(inputId = "map_plot_type", label = "Plot type", choices = c("Predicted mean fields", "Random effect fields"), selected = "Predicted mean fields"), + shiny::selectInput(inputId = "map_data_type", label = "Data type", choices = c("Poisson", "Gaussian"), selected = "Poisson"), leaflet::leafletOutput(outputId = "map_out") ), shiny::tabPanel( @@ -214,25 +214,6 @@ priors_shiny <- function(spatial_data, shiny::observe({ shiny::updateSelectInput(session = session, inputId = "select_run_map", choices = run_names()) shiny::updateSelectInput(session = session, inputId = "select_run_code", choices = run_names()) - - if (!is.null(run_names())) { - # They'll all have the same variable names so we can just take the first - run_name <- run_names()[1] - var_names <- names(model_vals$parsed_outputs[[run_name]]) - - selected_a <- NULL - selected_b <- NULL - if ("mean_post" %in% var_names) { - selected_a <- "mean_post" - } - - if ("fixed_mean" %in% var_names) { - selected_b <- "fixed_mean" - } - - shiny::updateSelectInput(session = session, inputId = "map_var_a", choices = var_names, selected = selected_a) - shiny::updateSelectInput(session = session, inputId = "map_var_b", choices = var_names, selected = selected_b) - } }) shiny::observeEvent(input$features, { @@ -393,7 +374,25 @@ priors_shiny <- function(spatial_data, } data <- model_vals$parsed_outputs[[input$select_run_map]] - pred_field <- create_prediction_field(var_a = data[[input$map_var_a]], var_b = data[[input$map_var_b]], mesh = mesh) + # c("Predicted mean fields", "Random effect fields") + data_type <- tolower(input$map_data_type) + if (input$map_plot_type == "Predicted mean fields") { + pred_field <- create_prediction_field( + mesh = mesh, + plot_type = "predicted_mean_fields", + data_type = data_type, + var_a = data[["mean_post"]], + var_b = data[[input$map_var_b]] + ) + } else { + pred_field <- create_prediction_field( + mesh = mesh, + plot_type = "random_effect_fields", + data_type = data_type, + var_a = data[[input$map_var_a]] + ) + } + create_raster(dataframe = pred_field, crs = sp::proj4string(spatial_data)) }) From f82ad3242d562ffdcbfe7328e15702f3359f738e Mon Sep 17 00:00:00 2001 From: Gareth Jones Date: Fri, 6 Oct 2023 15:27:39 +0100 Subject: [PATCH 08/17] Fixed plot and code output --- R/model_parse.R | 7 +++++-- R/shiny_priors.R | 6 +++--- 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/R/model_parse.R b/R/model_parse.R index afd9050e..f1104c69 100644 --- a/R/model_parse.R +++ b/R/model_parse.R @@ -10,9 +10,9 @@ parse_model_output_bru <- function(model_output, 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 @@ -20,6 +20,7 @@ parse_model_output_bru <- function(model_output, measurement_data) { 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, @@ -85,7 +86,9 @@ create_prediction_field <- function(mesh, z <- base::as.numeric(A_proj %*% var_a[1:mesh$n]) + base::sum(var_b) } } else { - z <- var_a[1:mesh$n] + # 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) diff --git a/R/shiny_priors.R b/R/shiny_priors.R index 32344659..1e7e0e51 100644 --- a/R/shiny_priors.R +++ b/R/shiny_priors.R @@ -382,14 +382,14 @@ priors_shiny <- function(spatial_data, plot_type = "predicted_mean_fields", data_type = data_type, var_a = data[["mean_post"]], - var_b = data[[input$map_var_b]] + var_b = data[["fixed_mean"]] ) } else { pred_field <- create_prediction_field( mesh = mesh, plot_type = "random_effect_fields", data_type = data_type, - var_a = data[[input$map_var_a]] + var_a = data[["mean_post"]] ) } @@ -453,7 +453,7 @@ priors_shiny <- function(spatial_data, return() } - params <- model_vals$run_params[[input$select_run]] + params <- model_vals$run_params[[input$select_run_code]] paste0( "spde <- INLA::inla.spde2.pcmatern( From 7d2984f2a4d2b764c74b0b04e002637e83469e13 Mon Sep 17 00:00:00 2001 From: Gareth Jones Date: Fri, 6 Oct 2023 15:32:02 +0100 Subject: [PATCH 09/17] Added text to vignette for new plot types --- vignettes/priors_app.Rmd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vignettes/priors_app.Rmd b/vignettes/priors_app.Rmd index 79b9ad5b..1c1067c9 100644 --- a/vignettes/priors_app.Rmd +++ b/vignettes/priors_app.Rmd @@ -84,7 +84,7 @@ Once the model has run you view plots of model outputs by clicking on the `Plot` ## Plotting model ouputs on a map -To plot model predictions on a map click on the `Map` tab. This will use the `fdmr::create_prediction_field` and `fdmr::create_raster` functions to first create a `data.frame` of model predictions and then create a raster image from this data. +To plot model predictions on a map click on the `Map` tab. This will use the `fdmr::create_prediction_field` and `fdmr::create_raster` functions to first create a `data.frame` of model predictions and then create a raster image from this data. You can select between two different plot types, the predicted mean fields or the random effect fields. You can also select Gaussian or Poisson data type. ## Saving model outputs From 891f3025b44cda49dda0d4c9bfb6d6632b543ca1 Mon Sep 17 00:00:00 2001 From: Gareth Jones Date: Fri, 6 Oct 2023 15:46:46 +0100 Subject: [PATCH 10/17] Remove model_viewer from namespace --- NAMESPACE | 1 - 1 file changed, 1 deletion(-) diff --git a/NAMESPACE b/NAMESPACE index da245e92..c38bd3f8 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -10,7 +10,6 @@ export(load_tutorial_data) export(mesh_builder) export(mesh_checker) export(mesh_to_spatial) -export(model_viewer) export(numbers_only) export(parse_model_output) export(plot_barchart) From d5d095bfeb0e47b161f6a85ee35b0dcc340c8bdc Mon Sep 17 00:00:00 2001 From: Gareth Jones Date: Sat, 7 Oct 2023 10:23:34 +0100 Subject: [PATCH 11/17] Add legend to map --- R/shiny_priors.R | 23 +++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/R/shiny_priors.R b/R/shiny_priors.R index 1e7e0e51..17614ff0 100644 --- a/R/shiny_priors.R +++ b/R/shiny_priors.R @@ -368,7 +368,7 @@ priors_shiny <- function(spatial_data, rownames = TRUE ) - map_raster <- shiny::reactive({ + prediction_field <- shiny::reactive({ if (length(model_vals$parsed_outputs) == 0) { return() } @@ -377,7 +377,7 @@ priors_shiny <- function(spatial_data, # c("Predicted mean fields", "Random effect fields") data_type <- tolower(input$map_data_type) if (input$map_plot_type == "Predicted mean fields") { - pred_field <- create_prediction_field( + create_prediction_field( mesh = mesh, plot_type = "predicted_mean_fields", data_type = data_type, @@ -385,15 +385,22 @@ priors_shiny <- function(spatial_data, var_b = data[["fixed_mean"]] ) } else { - pred_field <- create_prediction_field( + create_prediction_field( mesh = mesh, plot_type = "random_effect_fields", data_type = data_type, var_a = data[["mean_post"]] ) } + }) + + map_raster <- shiny::reactive({ + raster::rasterFromXYZ(prediction_field(), crs = crs) + }) - create_raster(dataframe = pred_field, crs = sp::proj4string(spatial_data)) + map_colours <- shiny::reactive({ + range <- prediction_field()[["z"]] + leaflet::colorNumeric(palette = "viridis", domain = range, reverse = FALSE) }) output$map_out <- leaflet::renderLeaflet({ @@ -401,10 +408,10 @@ priors_shiny <- function(spatial_data, return() } - m <- leaflet::leaflet() - m <- leaflet::addTiles(m, group = "OSM") - m <- leaflet::addRasterImage(m, map_raster(), opacity = 0.9, group = "Raster") - m + leaflet::leaflet() %>% + leaflet::addTiles(group = "OSM") %>% + leaflet::addRasterImage(map_raster(), colors = map_colours(), opacity = 0.9, group = "Raster") %>% + leaflet::addLegend(position = "topright", pal = map_colours(), values = prediction_field()[["z"]]) }) model_plot <- shiny::eventReactive(input$plot_type, ignoreNULL = FALSE, { From 57b78647f2c91eb16abd64d8dfcfbf5a8ba5d221 Mon Sep 17 00:00:00 2001 From: Gareth Jones Date: Sat, 7 Oct 2023 10:24:23 +0100 Subject: [PATCH 12/17] Adding checks for CRS or warning if none found --- R/shiny_priors.R | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/R/shiny_priors.R b/R/shiny_priors.R index 17614ff0..271042ed 100644 --- a/R/shiny_priors.R +++ b/R/shiny_priors.R @@ -22,6 +22,18 @@ priors_shiny <- function(spatial_data, stop("Please make sure you have set coordinates on spatial_data using sp::coordinates.") } + spatial_crs <- sp::proj4string(spatial_data) + mesh_crs <- mesh$crs$input + + if (is.na(mesh_crs) && is.na(spatial_crs)) { + warning("Cannot read CRS from mesh or spatial_data, using default CRS = +proj=longlat +datum=WGS84") + crs <- "+proj=longlat +datum=WGS84" + } else if (is.na(mesh_crs)) { + crs <- spatial_crs + } else { + crs <- mesh_crs + } + # Text for priors help prior_range_text <- "A length 2 vector, with (range0, Prange) specifying that P(ρ < ρ_0)=p_ρ, where ρ is the spatial range of the random field." From f72050b1ec373e88e3f11d488e4e25c498ce43e0 Mon Sep 17 00:00:00 2001 From: Gareth Jones Date: Sat, 7 Oct 2023 19:00:42 +0100 Subject: [PATCH 13/17] WIP: Checking colour selection --- R/shiny_priors.R | 101 ++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 82 insertions(+), 19 deletions(-) diff --git a/R/shiny_priors.R b/R/shiny_priors.R index 271042ed..8dc2d009 100644 --- a/R/shiny_priors.R +++ b/R/shiny_priors.R @@ -34,6 +34,9 @@ priors_shiny <- function(spatial_data, crs <- mesh_crs } + brewer_palettes <- RColorBrewer::brewer.pal.info + default_colours <- rownames(brewer_palettes[brewer_palettes$cat == "seq", ]) + # Text for priors help prior_range_text <- "A length 2 vector, with (range0, Prange) specifying that P(ρ < ρ_0)=p_ρ, where ρ is the spatial range of the random field." @@ -140,8 +143,17 @@ priors_shiny <- function(spatial_data, type = "tabs", shiny::tabPanel( "Features", - shiny::selectInput(inputId = "model_var", label = "Model variable", choices = features), - shiny::selectInput(inputId = "exposure_param", label = "Exposure param", choices = features), + shiny::fluidRow( + shiny::column( + 6, + shiny::selectInput(inputId = "model_var", label = "Model variable", choices = features), + shiny::selectInput(inputId = "exposure_param", label = "Exposure param", choices = features), + ), + shiny::column( + 6, + shiny::selectInput(inputId = "data_dist", label = "Data distribution", choices = c("Poisson", "Gaussian")), + ) + ), shiny::checkboxGroupInput(inputId = "features", label = "Features", choices = features), shiny::checkboxInput(inputId = "f_func", label = "Add f()", value = FALSE), shiny::actionButton(inputId = "clear", label = "Clear"), @@ -171,9 +183,28 @@ priors_shiny <- function(spatial_data, ), shiny::tabPanel( "Map", - shiny::selectInput(inputId = "select_run_map", label = "Select run:", choices = c()), - shiny::selectInput(inputId = "map_plot_type", label = "Plot type", choices = c("Predicted mean fields", "Random effect fields"), selected = "Predicted mean fields"), - shiny::selectInput(inputId = "map_data_type", label = "Data type", choices = c("Poisson", "Gaussian"), selected = "Poisson"), + shiny::fluidRow( + shiny::column( + 6, + shiny::selectInput(inputId = "map_plot_type", label = "Plot type", choices = c("Predicted mean fields", "Random effect fields"), selected = "Predicted mean fields"), + shiny::selectInput(inputId = "map_data_type", label = "Data type", choices = c("Poisson", "Gaussian"), selected = "Poisson"), + ), + shiny::column( + 6, + shiny::selectInput( + inputId = "colour_category", + label = "Palette type", + choices = c("Sequential", "Diverging", "Qualitative", "Viridis"), + selected = "Viridis" + ), + shiny::selectInput( + inputId = "colour_scheme", + label = "Color Scheme", + choices = default_colours, + selected = "viridis", + ), + ) + ), leaflet::leafletOutput(outputId = "map_out") ), shiny::tabPanel( @@ -297,20 +328,30 @@ priors_shiny <- function(spatial_data, formula_str() }) + data_distribution <- shiny::reactive({ + tolower(input$data_dist) + }) + shiny::observeEvent(input$run_model, ignoreNULL = TRUE, { exposure_param_local <- input$exposure_param formula_local <- inla_formula() measurement_data_local <- measurement_data + data_dist_local = data_distribution() + family_control <- NULL + if (data_dist_local == "poisson") { + family_control <- list(link = "log") + } + promise <- promises::future_promise( { # Without loading INLA here we get errors require("INLA") inlabru::bru(formula_local, data = measurement_data_local, - family = "poisson", + family = data_dist_local, E = measurement_data_local[[exposure_param_local]], - control.family = list(link = "log"), + control.family = family_control, options = list( verbose = FALSE ) @@ -380,19 +421,33 @@ priors_shiny <- function(spatial_data, rownames = TRUE ) - prediction_field <- shiny::reactive({ - if (length(model_vals$parsed_outputs) == 0) { - return() + category_colours <- shiny::reactive({ + if (input$colour_category == "Viridis") { + colours <- c("viridis", "magma", "inferno", "plasma") + } else { + palettes_mapping <- list("Sequential" = "seq", "Diverging" = "div", "Qualitative" = "qual") + chosen_cat <- palettes_mapping[input$colour_category] + colours <- rownames(subset(RColorBrewer::brewer.pal.info, category %in% chosen_cat)) } + colours + }) + + colour_scheme <- shiny::reactive({ + input$colour_scheme + }) + + shiny::observe({ + shiny::updateSelectInput(session, inputId = "colour_scheme", label = "Colours", choices = category_colours()) + }) + + prediction_field <- shiny::reactive({ data <- model_vals$parsed_outputs[[input$select_run_map]] - # c("Predicted mean fields", "Random effect fields") - data_type <- tolower(input$map_data_type) if (input$map_plot_type == "Predicted mean fields") { create_prediction_field( mesh = mesh, plot_type = "predicted_mean_fields", - data_type = data_type, + data_type = input$data_type, var_a = data[["mean_post"]], var_b = data[["fixed_mean"]] ) @@ -400,19 +455,22 @@ priors_shiny <- function(spatial_data, create_prediction_field( mesh = mesh, plot_type = "random_effect_fields", - data_type = data_type, + data_type = input$data_type, var_a = data[["mean_post"]] ) } }) + z_values <- shiny::reactive({ + prediction_field()[["z"]] + }) + map_raster <- shiny::reactive({ raster::rasterFromXYZ(prediction_field(), crs = crs) }) map_colours <- shiny::reactive({ - range <- prediction_field()[["z"]] - leaflet::colorNumeric(palette = "viridis", domain = range, reverse = FALSE) + leaflet::colorNumeric(palette = colour_scheme(), domain = z_values(), reverse = FALSE) }) output$map_out <- leaflet::renderLeaflet({ @@ -423,7 +481,7 @@ priors_shiny <- function(spatial_data, leaflet::leaflet() %>% leaflet::addTiles(group = "OSM") %>% leaflet::addRasterImage(map_raster(), colors = map_colours(), opacity = 0.9, group = "Raster") %>% - leaflet::addLegend(position = "topright", pal = map_colours(), values = prediction_field()[["z"]]) + leaflet::addLegend(position = "topright", pal = map_colours(), values = z_values()) }) model_plot <- shiny::eventReactive(input$plot_type, ignoreNULL = FALSE, { @@ -474,6 +532,11 @@ priors_shiny <- function(spatial_data, params <- model_vals$run_params[[input$select_run_code]] + family_control_str <- "NULL" + if (data_distribution() == "poisson") { + family_control_str <- "list(link = 'log')," + } + paste0( "spde <- INLA::inla.spde2.pcmatern( mesh = mesh, @@ -487,9 +550,9 @@ priors_shiny <- function(spatial_data, )", "\n\n", paste0("model_output <- inlabru::bru(formula, data = measurement_data, - family = 'poisson', + family = ", data_distribution(), ", E = measurement_data[[", input$exposure_param, "]], - control.family = list(link = 'log'), + control.family = ", family_control_str, " options = list( verbose = FALSE ) From de517b9a347c4cc6bf99712cc5bca5c1e88b5a1f Mon Sep 17 00:00:00 2001 From: Gareth Jones Date: Sat, 7 Oct 2023 19:40:03 +0100 Subject: [PATCH 14/17] Map and distribution selection working, need to fix colour palette selection --- R/model_parse.R | 12 ++++++------ R/shiny_priors.R | 26 +++++++++++--------------- 2 files changed, 17 insertions(+), 21 deletions(-) diff --git a/R/model_parse.R b/R/model_parse.R index f1104c69..be27793b 100644 --- a/R/model_parse.R +++ b/R/model_parse.R @@ -50,7 +50,7 @@ parse_model_output <- function(model_output, measurement_data, model_type = "inl #' #' @param mesh INLA mesh #' @param plot_type Type of plot to create, "predicted_mean_fields" etc -#' @param data_type Type of data, "poisson" etc +#' @param data_dist Type of data, "poisson" etc #' @param var_a Data for variable a, required for "predicted_mean_fields" and "random_effect_fields" #' @param var_b Data for variable b, required for "predicted_mean_fields" #' @@ -58,7 +58,7 @@ parse_model_output <- function(model_output, measurement_data, model_type = "inl #' @export create_prediction_field <- function(mesh, plot_type = "predicted_mean_fields", - data_type = "poisson", + data_dist = "poisson", var_a = NULL, var_b = NULL) { valid_plots <- c("predicted_mean_fields", "random_effect_fields") @@ -66,9 +66,9 @@ create_prediction_field <- function(mesh, stop("Invalid plot type, select from ", valid_plots) } - valid_data_types <- c("poisson", "gaussian") - if (!(data_type %in% valid_data_types)) { - stop("Invalid data type, select from ", valid_data_types) + 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)) { @@ -80,7 +80,7 @@ create_prediction_field <- function(mesh, A_proj <- INLA::inla.spde.make.A(mesh = mesh, loc = as.matrix(xy_grid)) if (plot_type == "predicted_mean_fields") { - if (data_type == "poisson") { + if (data_dist == "poisson") { z <- base::exp(base::as.numeric(A_proj %*% var_a[1:mesh$n]) + base::sum(var_b)) } else { z <- base::as.numeric(A_proj %*% var_a[1:mesh$n]) + base::sum(var_b) diff --git a/R/shiny_priors.R b/R/shiny_priors.R index 8dc2d009..c1800324 100644 --- a/R/shiny_priors.R +++ b/R/shiny_priors.R @@ -187,7 +187,7 @@ priors_shiny <- function(spatial_data, shiny::column( 6, shiny::selectInput(inputId = "map_plot_type", label = "Plot type", choices = c("Predicted mean fields", "Random effect fields"), selected = "Predicted mean fields"), - shiny::selectInput(inputId = "map_data_type", label = "Data type", choices = c("Poisson", "Gaussian"), selected = "Poisson"), + shiny::selectInput(inputId = "select_run_map", label = "Select run:", choices = c()) ), shiny::column( 6, @@ -199,9 +199,8 @@ priors_shiny <- function(spatial_data, ), shiny::selectInput( inputId = "colour_scheme", - label = "Color Scheme", + label = "Colour Scheme", choices = default_colours, - selected = "viridis", ), ) ), @@ -250,19 +249,11 @@ priors_shiny <- function(spatial_data, names(model_vals$run_params) }) - model_summary_variables <- shiny::reactive({ - names(model_vals$model_outputs) - }) - shiny::observe({ shiny::updateSelectInput(session = session, inputId = "select_run_map", choices = run_names()) shiny::updateSelectInput(session = session, inputId = "select_run_code", choices = run_names()) }) - shiny::observeEvent(input$features, { - print(paste0("You have chosen: ", input$features)) - }) - shiny::observeEvent(input$clear, { shiny::updateCheckboxGroupInput(session = session, inputId = "features", choices = features, selected = NULL) }) @@ -337,7 +328,7 @@ priors_shiny <- function(spatial_data, formula_local <- inla_formula() measurement_data_local <- measurement_data - data_dist_local = data_distribution() + data_dist_local <- data_distribution() family_control <- NULL if (data_dist_local == "poisson") { family_control <- list(link = "log") @@ -442,12 +433,16 @@ priors_shiny <- function(spatial_data, prediction_field <- shiny::reactive({ + if (length(model_vals$parsed_outputs) == 0) { + return() + } + data <- model_vals$parsed_outputs[[input$select_run_map]] if (input$map_plot_type == "Predicted mean fields") { create_prediction_field( mesh = mesh, plot_type = "predicted_mean_fields", - data_type = input$data_type, + data_dist = data_distribution(), var_a = data[["mean_post"]], var_b = data[["fixed_mean"]] ) @@ -455,7 +450,7 @@ priors_shiny <- function(spatial_data, create_prediction_field( mesh = mesh, plot_type = "random_effect_fields", - data_type = input$data_type, + data_dist = data_distribution(), var_a = data[["mean_post"]] ) } @@ -470,7 +465,8 @@ priors_shiny <- function(spatial_data, }) map_colours <- shiny::reactive({ - leaflet::colorNumeric(palette = colour_scheme(), domain = z_values(), reverse = FALSE) + # leaflet::colorNumeric(palette = colour_scheme(), domain = z_values(), reverse = FALSE) + leaflet::colorNumeric(palette = "viridis", domain = z_values(), reverse = FALSE) }) output$map_out <- leaflet::renderLeaflet({ From 68e59ad93c18eca90ab8ceb41c64e78f71828daa Mon Sep 17 00:00:00 2001 From: Gareth Jones Date: Sat, 7 Oct 2023 19:44:21 +0100 Subject: [PATCH 15/17] Fix colours and distribution in code --- R/shiny_priors.R | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/R/shiny_priors.R b/R/shiny_priors.R index c1800324..1f71513d 100644 --- a/R/shiny_priors.R +++ b/R/shiny_priors.R @@ -252,6 +252,7 @@ priors_shiny <- function(spatial_data, shiny::observe({ shiny::updateSelectInput(session = session, inputId = "select_run_map", choices = run_names()) shiny::updateSelectInput(session = session, inputId = "select_run_code", choices = run_names()) + shiny::updateSelectInput(session, inputId = "colour_scheme", label = "Colours", choices = category_colours()) }) shiny::observeEvent(input$clear, { @@ -427,10 +428,6 @@ priors_shiny <- function(spatial_data, input$colour_scheme }) - shiny::observe({ - shiny::updateSelectInput(session, inputId = "colour_scheme", label = "Colours", choices = category_colours()) - }) - prediction_field <- shiny::reactive({ if (length(model_vals$parsed_outputs) == 0) { @@ -465,8 +462,7 @@ priors_shiny <- function(spatial_data, }) map_colours <- shiny::reactive({ - # leaflet::colorNumeric(palette = colour_scheme(), domain = z_values(), reverse = FALSE) - leaflet::colorNumeric(palette = "viridis", domain = z_values(), reverse = FALSE) + leaflet::colorNumeric(palette = colour_scheme(), domain = z_values(), reverse = FALSE) }) output$map_out <- leaflet::renderLeaflet({ @@ -546,7 +542,7 @@ priors_shiny <- function(spatial_data, )", "\n\n", paste0("model_output <- inlabru::bru(formula, data = measurement_data, - family = ", data_distribution(), ", + family = '", data_distribution(), "', E = measurement_data[[", input$exposure_param, "]], control.family = ", family_control_str, " options = list( From bd9101f8f6096c9984f0e26d050764596b65ae20 Mon Sep 17 00:00:00 2001 From: Gareth Jones Date: Sat, 7 Oct 2023 19:54:03 +0100 Subject: [PATCH 16/17] Fix Iss152 - rename exposure variable --- R/shiny_priors.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/shiny_priors.R b/R/shiny_priors.R index 1f71513d..61ad934a 100644 --- a/R/shiny_priors.R +++ b/R/shiny_priors.R @@ -147,7 +147,7 @@ priors_shiny <- function(spatial_data, shiny::column( 6, shiny::selectInput(inputId = "model_var", label = "Model variable", choices = features), - shiny::selectInput(inputId = "exposure_param", label = "Exposure param", choices = features), + shiny::selectInput(inputId = "exposure_param", label = "Exposure (time variable)", choices = features), ), shiny::column( 6, From 0d3c93614c35f8ee3589888efa7031939473f331 Mon Sep 17 00:00:00 2001 From: Gareth Jones Date: Sun, 8 Oct 2023 10:47:33 +0100 Subject: [PATCH 17/17] Rename priors app to model_builder --- NAMESPACE | 2 +- R/shiny_priors.R | 14 +++++++------- _pkgdown.yml | 2 +- man/{interactive_priors.Rd => model_builder.Rd} | 6 +++--- man/{priors_shiny.Rd => model_builder_shiny.Rd} | 6 +++--- vignettes/Simulation_GaussianDat.Rmd | 4 ++-- vignettes/Simulation_PoissonDat.Rmd | 4 ++-- vignettes/priors.Rmd | 2 +- vignettes/priors_app.Rmd | 4 ++-- 9 files changed, 22 insertions(+), 22 deletions(-) rename man/{interactive_priors.Rd => model_builder.Rd} (88%) rename man/{priors_shiny.Rd => model_builder_shiny.Rd} (88%) diff --git a/NAMESPACE b/NAMESPACE index c38bd3f8..06ecddcc 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -4,12 +4,12 @@ export(clear_caches) export(create_prediction_field) export(get_tmpdir) export(get_tutorial_datapath) -export(interactive_priors) export(latlong_to_utm) export(load_tutorial_data) export(mesh_builder) export(mesh_checker) export(mesh_to_spatial) +export(model_builder) export(numbers_only) export(parse_model_output) export(plot_barchart) diff --git a/R/shiny_priors.R b/R/shiny_priors.R index 61ad934a..d6cb591d 100644 --- a/R/shiny_priors.R +++ b/R/shiny_priors.R @@ -10,11 +10,11 @@ #' #' @return shiny::app #' @keywords internal -priors_shiny <- function(spatial_data, - measurement_data, - time_variable, - mesh, - log_folder = NULL) { +model_builder_shiny <- function(spatial_data, + measurement_data, + time_variable, + mesh, + log_folder = NULL) { future::plan(future::multisession()) got_coords <- has_coords(spatial_data = spatial_data) @@ -567,6 +567,6 @@ priors_shiny <- function(spatial_data, #' #' @return shiny::app #' @export -interactive_priors <- function(spatial_data, measurement_data, time_variable, mesh, log_folder = NULL) { - shiny::runApp(priors_shiny(spatial_data = spatial_data, measurement_data = measurement_data, time_variable = time_variable, mesh = mesh, log_folder = log_folder)) +model_builder <- function(spatial_data, measurement_data, time_variable, mesh, log_folder = NULL) { + shiny::runApp(model_builder_shiny(spatial_data = spatial_data, measurement_data = measurement_data, time_variable = time_variable, mesh = mesh, log_folder = log_folder)) } diff --git a/_pkgdown.yml b/_pkgdown.yml index 77f6f652..91c10ff4 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -52,7 +52,7 @@ reference: contents: - plot_interactive_map - mesh_builder - - interactive_priors + - model_builder - title: Parsing model output desc: Functions to help parse model output and extract useful information contents: diff --git a/man/interactive_priors.Rd b/man/model_builder.Rd similarity index 88% rename from man/interactive_priors.Rd rename to man/model_builder.Rd index 48aaa935..720f11f8 100644 --- a/man/interactive_priors.Rd +++ b/man/model_builder.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/shiny_priors.R -\name{interactive_priors} -\alias{interactive_priors} +\name{model_builder} +\alias{model_builder} \title{Interactively set and see the result of different priors} \usage{ -interactive_priors( +model_builder( spatial_data, measurement_data, time_variable, diff --git a/man/priors_shiny.Rd b/man/model_builder_shiny.Rd similarity index 88% rename from man/priors_shiny.Rd rename to man/model_builder_shiny.Rd index eb4eaac0..dabf61a3 100644 --- a/man/priors_shiny.Rd +++ b/man/model_builder_shiny.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/shiny_priors.R -\name{priors_shiny} -\alias{priors_shiny} +\name{model_builder_shiny} +\alias{model_builder_shiny} \title{Interactively set and see the result of different priors} \usage{ -priors_shiny( +model_builder_shiny( spatial_data, measurement_data, time_variable, diff --git a/vignettes/Simulation_GaussianDat.Rmd b/vignettes/Simulation_GaussianDat.Rmd index 58e24441..286485e5 100644 --- a/vignettes/Simulation_GaussianDat.Rmd +++ b/vignettes/Simulation_GaussianDat.Rmd @@ -248,10 +248,10 @@ fdmr::mesh_builder(spatial_data = sp_data, obs_data = simdf) ``` ## Interactive priors Shiny app -`fdmr` provides a Priors Shiny app which allows you to interactively set and see the model fitting results of different priors. You can launch this app by passing the spatial and observation data to the `fdmr::interactive_priors` function. +`fdmr` provides a Priors Shiny app which allows you to interactively set and see the model fitting results of different priors. You can launch this app by passing the spatial and observation data to the `fdmr::model_builder` function. ```{r priorapp, eval=FALSE} -fdmr::interactive_priors(spatial_data = sp_data, +fdmr::model_builder(spatial_data = sp_data, measurement_data = simdf, mesh=mesh, time_variable="time") diff --git a/vignettes/Simulation_PoissonDat.Rmd b/vignettes/Simulation_PoissonDat.Rmd index 3f168283..1112d8c8 100644 --- a/vignettes/Simulation_PoissonDat.Rmd +++ b/vignettes/Simulation_PoissonDat.Rmd @@ -244,10 +244,10 @@ fdmr::mesh_builder(spatial_data = sp_data, obs_data = simdf) ``` ## Interactive priors Shiny app -`fdmr` provides a Priors Shiny app which allows you to interactively set and see the model fitting results of different priors. You can launch this app by passing the spatial and observation data to the `fdmr::interactive_priors` function. +`fdmr` provides a Priors Shiny app which allows you to interactively set and see the model fitting results of different priors. You can launch this app by passing the spatial and observation data to the `fdmr::model_builder` function. ```{r priorapp, eval=FALSE} -fdmr::interactive_priors(spatial_data = sp_data, +fdmr::model_builder(spatial_data = sp_data, measurement_data = simdf, mesh=mesh, time_variable="time") diff --git a/vignettes/priors.Rmd b/vignettes/priors.Rmd index 79a3d1f2..84d20bc2 100644 --- a/vignettes/priors.Rmd +++ b/vignettes/priors.Rmd @@ -551,5 +551,5 @@ mesh <- INLA::inla.mesh.2d( ``` ```{r eval=FALSE} -fdmr::interactive_priors(spatial_data=sp_data, measurement_data = covid19_data, mesh=mesh) +fdmr::model_builder(spatial_data=sp_data, measurement_data = covid19_data, mesh=mesh) ``` \ No newline at end of file diff --git a/vignettes/priors_app.Rmd b/vignettes/priors_app.Rmd index 1c1067c9..2018e107 100644 --- a/vignettes/priors_app.Rmd +++ b/vignettes/priors_app.Rmd @@ -90,7 +90,7 @@ To plot model predictions on a map click on the `Map` tab. This will use the `fd By default the app will write out parameter sets and logs to the `fdmr/logs` directory in your home folder. If you want these logs to be written to a different folder, you can pass in the folder path to the `log_folder` argument. -We're now ready to run the app. To do this we'll call the `fdmr::interactive_priors` function, passing in +We're now ready to run the app. To do this we'll call the `fdmr::model_builder` function, passing in - `spatial_data = sp_data` - the spatial data covering areas across the city of Bristol - `measurement_data = covid19_data` - the COVID-19 data we want to model @@ -98,7 +98,7 @@ We're now ready to run the app. To do this we'll call the `fdmr::interactive_pri - `time_variable = week` - the name of the time variable in the data ```{r eval=FALSE} -fdmr::interactive_priors(spatial_data = sp_data, measurement_data = covid19_data, mesh=mesh, time_variable="week") +fdmr::model_builder(spatial_data = sp_data, measurement_data = covid19_data, mesh=mesh, time_variable="week") ``` # Viewing model outputs and parameter sets