Merge pull request #53 from simon-smart88/dag_update

Dag update

Dockerfile

@@ -19,8 +19,7 @@ RUN apt-get update && apt-get install -y \
     libhdf5-dev \
     patch
 
-# install R packages 
-RUN R -e "install.packages('INLA',repos=c(getOption('repos'),INLA='https://inla.r-inla-download.org/R/testing'), dep=TRUE)"
+# install R packages
 RUN R -e "install.packages('devtools')"
 ARG DISAGAPP_VER=unknown
 RUN R -e "devtools::install_github('simon-smart88/disagapp')"

R/helper_functions.R

@@ -49,6 +49,7 @@ spurious <- function(x) {
   fmesher::fm_as_sfc(x)
   geodata::worldclim_country(x)
   geosphere::centroid(x)
+  leaflet.extras::removeDrawToolbar(x)
   leafem::addMouseCoordinates(x)
   markdown::html_format(x)
   openxlsx::read.xlsx(x)

R/pred_transfer_f.R

@@ -102,7 +102,7 @@ covs_prep <- terra::rast(covs_prep)
 if (common$meta$prep_final$resolution == "High resolution"){
 
   # generate the prediction
-  transfer <- disaggregation::predict_model(common$fit, newdata = covs_prep)
+  transfer <- disaggregation::predict_model(common$fit, new_data = covs_prep)
 
   # convert to cases
   transfer$agg <- agg
@@ -117,7 +117,7 @@ if (common$meta$prep_final$resolution == "Low resolution"){
   agg_lores <- terra::aggregate(agg, fact = common$meta$prep_resolution$factor, fun = "sum")
 
   # generate the prediction
-  transfer <- disaggregation::predict_model(common$fit, newdata = covs_prep_lores)
+  transfer <- disaggregation::predict_model(common$fit, new_data = covs_prep_lores)
 
   # convert to cases
   transfer$agg <- agg_lores

inst/shiny/modules/fit_fit.R

@@ -138,27 +138,19 @@ fit_fit_module_server <- function(id, common, parent_session, map) {
   })
 
 
+  plot_data <- reactive({
+    gargoyle::watch("fit_fit")
+    disaggregation::plot_disag_model_data(common$fit)
+    })
+
+
     output$model_plot <- plotly::renderPlotly({
-      gargoyle::watch("fit_fit")
-      req(common$fit$sd_out)
-
-      parameter <- sd <- obs <- pred <- NULL
-      posteriors <- as.data.frame(summary(common$fit$sd_out, select = "fixed"))
-      posteriors <- dplyr::mutate(posteriors, name = rownames(posteriors))
-      names(posteriors) <- c("mean", "sd", "parameter")
-      posteriors$fixed <- grepl("slope", posteriors$parameter)
-      posteriors$type <- ifelse(posteriors$fixed, "Slope", "Other")
-
-      # Check name lengths match before substituting.
-      lengths_match <- terra::nlyr(common$fit$data$covariate_rasters) == sum(posteriors$fixed)
-      if(lengths_match){
-        posteriors$parameter[grepl("slope", posteriors$parameter)] <- names(common$fit$data$covariate_rasters)
-      }
+      req(plot_data())
+
+      posteriors <- plot_data()$posteriors
 
-      # Unique types for faceting
       unique_types <- unique(posteriors$type)
 
-      # Create subplots for each type
       plots <- lapply(unique_types, function(type) {
         subset_data <- posteriors[posteriors$type == type, ]
 
@@ -187,43 +179,22 @@ fit_fit_module_server <- function(id, common, parent_session, map) {
 
 
     output$obs_pred_plot <- plotly::renderPlotly({
-      gargoyle::watch("fit_fit")
-      req(common$fit)
-      report <- common$fit$obj$report()
-
-      # Form of the observed and predicted results depends on the likelihood function used
-      if( common$fit$model_setup$family == "gaussian") {
-        observed_data = report$polygon_response_data/report$reportnormalisation
-        predicted_data = report$reportprediction_rate
-        title <- "In sample performance: incidence rate"
-      } else if( common$fit$model_setup$family == "binomial") {
-        observed_data =  common$fit$data$polygon_data$response / common$fit$data$polygon_data$N
-        predicted_data = report$reportprediction_rate
-        title <- "In sample performance: prevalence rate"
-      } else if( common$fit$model_setup$family == "poisson") {
-        observed_data = report$polygon_response_data/report$reportnormalisation
-        predicted_data = report$reportprediction_rate
-        title <- "In sample performance: incidence rate"
-      }
-
-      data <- data.frame(obs = observed_data, pred = predicted_data)
+      req(plot_data())
+      data <- plot_data()$data
+      title <- plot_data()$title
 
-      title <- "Observed vs Predicted"
-
-      # Define range for the identity line
       x_range <- range(data$obs, data$pred)
       identity_line <- data.frame(x = x_range, y = x_range)
 
-      # Create scatter plot and add identity line
-      obspred_plot <- plotly::plot_ly(data, x = ~obs, y = ~pred, type = "scatter", mode = "markers") |>
-        plotly::add_lines(data = identity_line, x = ~x, y = ~y, line = list(color = "blue")) |>
+      obspred_plot <- plotly::plot_ly(data, x = ~obs, y = ~pred, type = 'scatter', mode = 'markers') %>%
+        plotly::add_lines(data = identity_line, x = ~x, y = ~y, line = list(color = 'blue')) %>%
+
         plotly::layout(title = list(text = title, x = 0.5),
                xaxis = list(title = "Observed", showline = TRUE, zeroline = FALSE),
                yaxis = list(title = "Predicted", showline = TRUE, zeroline = FALSE),
                margin = list(t = 100),
                showlegend = FALSE)
 
-      # Display the plot
       obspred_plot
     })
 

inst/shiny/modules/pred_transfer.Rmd

@@ -133,7 +133,7 @@ Decrease covariate resolution and generate the transferred predictions
 transfer_covariates_prepared_lores <- terra::aggregate(transfer_covariates_prepared, fact = {{meta$prep_resolution$factor}}, fun = "mean")
 transfer_aggregation_lores <- terra::aggregate(transfer_aggregation, fact = {{meta$prep_resolution$factor}}, fun = "sum")
 
-transfer_predictions <- disaggregation::predict_model(fitted_model, newdata = transfer_covariates_prepared)
+transfer_predictions <- disaggregation::predict_model(fitted_model, new_data = transfer_covariates_prepared)
 transfer_predictions$cases <- transfer_predictions$prediction * transfer_aggregation 
 
 plot(transfer_predictions)
@@ -145,7 +145,7 @@ Generate the transferred predictions
 ```
 
 ```{r, echo = {{all(c(pred_transfer_knit, pred_transfer_hires))}}, include = {{all(c(pred_transfer_knit, pred_transfer_hires))}}}
-transfer_predictions <- disaggregation::predict_model(fitted_model, newdata = transfer_covariates_prepared)
+transfer_predictions <- disaggregation::predict_model(fitted_model, new_data = transfer_covariates_prepared)
 transfer_predictions$cases <- transfer_predictions$prediction * transfer_aggregation 
 
 plot(transfer_predictions)

inst/shiny/modules/prep_final.R

@@ -79,8 +79,8 @@ prep_final_module_server <- function(id, common, parent_session, map) {
                                                  aggregation_raster = common$agg_prep,
                                                  id_var = as.character(input$id_var),
                                                  response_var = as.character(input$resp_var),
-                                                 na.action = input$na_action,
-                                                 makeMesh = FALSE)},
+                                                 na_action = input$na_action,
+                                                 make_mesh = FALSE)},
                              error = function(x){ common$logger |> writeLog(type = "error",
                                paste0("An error occurred whilst preparing the data: ", x))})
     } else {
@@ -89,8 +89,8 @@ prep_final_module_server <- function(id, common, parent_session, map) {
                                                   aggregation_raster = common$agg_prep_lores,
                                                   id_var = as.character(input$id_var),
                                                   response_var = as.character(input$resp_var),
-                                                  na.action = input$na_action,
-                                                  makeMesh = FALSE)},
+                                                  na_action = input$na_action,
+                                                  make_mesh = FALSE)},
                              error = function(x){ common$logger |> writeLog(type = "error",
                                 paste0("An error occurred whilst preparing the data: ", x))})
     }
@@ -118,17 +118,17 @@ prep_final_module_server <- function(id, common, parent_session, map) {
     save = function() {list(
       ### Manual save start
       ### Manual save end
-      id_var = input$id_var, 
-      resp_var = input$resp_var, 
-      resolution = input$resolution, 
+      id_var = input$id_var,
+      resp_var = input$resp_var,
+      resolution = input$resolution,
       na_action = input$na_action)
     },
     load = function(state) {
       ### Manual load start
       ### Manual load end
-      updateSelectInput(session, "id_var", selected = state$id_var) 
-      updateSelectInput(session, "resp_var", selected = state$resp_var) 
-      updateSelectInput(session, "resolution", selected = state$resolution) 
+      updateSelectInput(session, "id_var", selected = state$id_var)
+      updateSelectInput(session, "resp_var", selected = state$resp_var)
+      updateSelectInput(session, "resolution", selected = state$resolution)
       shinyWidgets::updateMaterialSwitch(session, "na_action", value = state$na_action)
     }
   ))

inst/shiny/modules/prep_final.Rmd

@@ -9,8 +9,8 @@ prepared_data <- disaggregation::prepare_data(polygon_shapefile = shape,
                                      aggregation_raster = aggregation_prepared,
                                      id_var = "{{prep_id_var}}",
                                      response_var = "{{prep_resp_var}}",
-                                     na.action = {{prep_na_action}},
-                                     makeMesh = FALSE)
+                                     na_action = {{prep_na_action}},
+                                     make_mesh = FALSE)
 
 prepared_data$mesh <- mesh
 

inst/shiny/modules/prep_mesh.R

@@ -42,7 +42,7 @@ prep_mesh_module_server <- function(id, common, parent_session, map) {
     # FUNCTION CALL ####
     common$logger |> writeLog(type = "starting", "Starting to build the mesh")
     results$resume()
-    common$tasks$prep_mesh$invoke(common$shape, mesh.args = list(max.edge = input$mesh_edge,
+    common$tasks$prep_mesh$invoke(common$shape, mesh_args = list(max.edge = input$mesh_edge,
                                                               cut = input$mesh_cut,
                                                               offset = input$offset))
 
@@ -71,15 +71,15 @@ prep_mesh_module_server <- function(id, common, parent_session, map) {
     save = function() {list(
       ### Manual save start
       ### Manual save end
-      mesh_edge = input$mesh_edge, 
-      mesh_cut = input$mesh_cut, 
+      mesh_edge = input$mesh_edge,
+      mesh_cut = input$mesh_cut,
       mesh_offset = input$mesh_offset)
     },
     load = function(state) {
       ### Manual load start
       ### Manual load end
-      updateSliderInput(session, "mesh_edge", value = state$mesh_edge) 
-      updateSliderInput(session, "mesh_cut", value = state$mesh_cut) 
+      updateSliderInput(session, "mesh_edge", value = state$mesh_edge)
+      updateSliderInput(session, "mesh_cut", value = state$mesh_cut)
       updateSliderInput(session, "mesh_offset", value = state$mesh_offset)
     }
   ))

inst/shiny/modules/prep_mesh.Rmd

@@ -3,7 +3,7 @@ Build the spatial mesh
 ```
 
 ```{r, echo = {{prep_mesh_knit}}, include = {{prep_mesh_knit}}}
-mesh <- disaggregation::build_mesh(shape, mesh.args = list(max.edge = {{prep_mesh_edge}}, 
+mesh <- disaggregation::build_mesh(shape, mesh_args = list(max.edge = {{prep_mesh_edge}}, 
                                                       cut = {{prep_mesh_cut}},
                                                       offset = {{prep_mesh_offset}}))
 ```