Skip to content

Commit

Permalink
tweaks to fix rmd and update test to use complete analysis
Browse files Browse the repository at this point in the history
  • Loading branch information
@simon-smart88
simon-smart88 committed Aug 23, 2024
1 parent e5f4928 commit 4d5c836
Show file tree
Hide file tree
Showing 5 changed files with 101 additions and 50 deletions.
1 change: 0 additions & 1 deletion .gitignore
View file
Original file line number Diff line number Diff line change
Expand Up @@ -33,6 +33,5 @@ inst/shiny/install*
_modules
_shiny
.Renviron
lie*.csv
lie*.rds
.httr-oauth
12 changes: 12 additions & 0 deletions inst/extdata/test_data/lie.csv
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,12 @@
"","area","response"
"1","Triesen",1
"2","Schellenberg",2
"3","Gamprin",3
"4","Triesenberg",4
"5","Eschen",5
"6","Ruggell",6
"7","Mauren",7
"8","Schaan",8
"9","Balzers",9
"10","Planken",10
"11","Vaduz",11
46 changes: 24 additions & 22 deletions inst/shiny/modules/fit_fit.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -119,7 +119,9 @@ fit_fit_module_server <- function(id, common, parent_session, map) {
common$meta$fit_fit$iterations <- as.numeric(input$iterations)
common$meta$fit_fit$field <- input$field
common$meta$fit_fit$iid <- input$iid
common$meta$fit_fit$priors <- input$priors
if (input$priors){
common$meta$fit_fit$priors <- TRUE
}
common$meta$fit_fit$mean_intercept <- as.numeric(input$mean_intercept)
common$meta$fit_fit$sd_intercept <- as.numeric(input$sd_intercept)
common$meta$fit_fit$mean_slope <- as.numeric(input$mean_slope)
Expand All @@ -141,16 +143,16 @@ fit_fit_module_server <- function(id, common, parent_session, map) {
req(common$fit$sd_out)

parameter <- sd <- obs <- pred <- NULL
posteriors <- as.data.frame(summary(common$fit$sd_out, select = 'fixed'))
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')
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)
posteriors$parameter[grepl("slope", posteriors$parameter)] <- names(common$fit$data$covariate_rasters)
}

# Unique types for faceting
Expand All @@ -163,13 +165,13 @@ fit_fit_module_server <- function(id, common, parent_session, map) {
plotly::plot_ly(subset_data,
y = ~parameter,
x = ~mean,
type = 'scatter',
mode = 'markers',
marker = list(color = 'black'),
type = "scatter",
mode = "markers",
marker = list(color = "black"),
error_x = list(array = ~sd, color = "blue")) |>
plotly::layout(title = list(text = type, x = 0.5),
xaxis = list(title = 'SD', showline = TRUE, zeroline = FALSE),
yaxis = list(title = 'Parameter', showline = TRUE, zeroline = FALSE,
xaxis = list(title = "SD", showline = TRUE, zeroline = FALSE),
yaxis = list(title = "Parameter", showline = TRUE, zeroline = FALSE,
range = c(-1, nrow(subset_data))),
margin = list(t = 100))
})
Expand All @@ -190,18 +192,18 @@ fit_fit_module_server <- function(id, common, parent_session, map) {
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') {
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') {
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') {
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'
title <- "In sample performance: incidence rate"
}

data <- data.frame(obs = observed_data, pred = predicted_data)
Expand All @@ -213,11 +215,11 @@ fit_fit_module_server <- function(id, common, parent_session, map) {
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),
xaxis = list(title = "Observed", showline = TRUE, zeroline = FALSE),
yaxis = list(title = "Predicted", showline = TRUE, zeroline = FALSE),
margin = list(t = 100),
showlegend = FALSE)

Expand Down Expand Up @@ -286,7 +288,7 @@ fit_fit_module_rmd <- function(common) {
fit_iterations = common$meta$fit_fit$iterations,
fit_field = common$meta$fit_fit$field,
fit_iid = common$meta$fit_fit$iid,
fit_priors_knit = common$meta$fit_fit$priors,
fit_priors_knit = !is.null(common$meta$fit_fit$priors),
fit_priors = common$meta$fit_fit$priors,
fit_mean_intercept = common$meta$fit_fit$mean_intercept,
fit_sd_intercept = common$meta$fit_fit$sd_intercept,
Expand Down
6 changes: 4 additions & 2 deletions inst/shiny/modules/pred_pred.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -86,7 +86,9 @@ pred_pred_module_server <- function(id, common, parent_session, map) {
}
# METADATA ####
common$meta$pred_pred$used <- TRUE
common$meta$pred_pred$uncertain <- input$uncertain
if (input$uncertain){
common$meta$pred_pred$uncertain <- input$uncertain
}
if (is.null(input$iid)){
common$meta$pred_pred$iid <- FALSE
}
Expand Down Expand Up @@ -172,7 +174,7 @@ pred_pred_module_map <- function(map, common) {
raster_map(map, common, common$pred[[tolower(variable)]], variable)
}
}
if (common$meta$pred_pred$uncertain){
if (!is.null(common$meta$pred_pred$uncertain)){
raster_map(map, common, common$pred$uncertainty$predictions_ci$`lower CI`, "Lower credible interval")
raster_map(map, common, common$pred$uncertainty$predictions_ci$`upper CI`, "Upper credible interval")
}
Expand Down
86 changes: 61 additions & 25 deletions tests/testthat/test-downloads.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -20,68 +20,104 @@ test_that("{shinytest2} recording: e2e_empty_markdown", {
})

# this is very temperamental
test_that("{shinytest2} recording: e2e_markdown_from_uploads", {
test_that("{shinytest2} recording: e2e_markdown_from_complete_analysis", {

skip_on_ci()

app <- shinytest2::AppDriver$new(app_dir = system.file("shiny", package = "disagapp"), name = "e2e_markdown_from_uploads", timeout = 60000)
app <- shinytest2::AppDriver$new(app_dir = system.file("shiny", package = "disagapp"), name = "e2e_complete_analysis", timeout = 120000)

app$set_inputs(tabs = "resp")
app$set_inputs(respSel = "resp_shape")
app$upload_file("resp_shape-shape" = shpdf$datapath)
app$set_inputs("resp_shape-resp_var" = "inc")
app$click("resp_shape-run")
app$set_inputs(respSel = "resp_download")
app$upload_file("resp_download-spread" = df_path)
app$set_inputs(`resp_download-area_column` = "area")
app$set_inputs(`resp_download-response_column` = "response")
app$set_inputs(`resp_download-country` = "Liechtenstein")
app$click("resp_download-run")

common <- app$get_value(export = "common")
expect_is(common$shape, "sf")

app$set_inputs(tabs = "cov")
app$set_inputs(covSel = "cov_upload")
app$upload_file("cov_upload-cov" = covdf$datapath)
app$click("cov_upload-run")
app$set_inputs(covSel = "cov_bioclim")
app$set_inputs(`cov_bioclim-variables` = c("Mean temperature", "Total precipitation"))
app$click(selector = "#cov_bioclim-run")
app$wait_for_value(input = "cov_bioclim-complete")

app$set_inputs(main = "Save")
save_file <- app$get_download("core_save-save_session", filename = save_path)
common <- readRDS(save_file)
common$covs <- unwrap_terra(common$covs)
expect_length(common$covs, 2)

app$set_inputs(tabs = "agg")
app$set_inputs(aggSel = "agg_upload")
app$upload_file("agg_upload-agg" = aggdf$datapath)
app$click("agg_upload-run")
app$set_inputs(aggSel = "agg_worldpop")
app$set_inputs("agg_worldpop-method" = "Unconstrained")
app$set_inputs("agg_worldpop-country" = "Liechtenstein")
app$click(selector = "#agg_worldpop-run")
app$wait_for_value(input = "agg_worldpop-complete")

app$set_inputs(main = "Save")
save_file <- app$get_download("core_save-save_session", filename = save_path)
common <- readRDS(save_file)
common$agg <- unwrap_terra(common$agg)
expect_is(common$agg, "SpatRaster")

app$set_inputs(tabs = "prep")
app$set_inputs(prepSel = "prep_mesh")
app$set_inputs("prep_mesh-mesh_edge" = c(0.1, 0.3))
app$set_inputs("prep_mesh-mesh_offset" = c(0.1, 0.3))
app$click(selector = "#prep_mesh-run")
app$wait_for_value(input = "prep_mesh-complete")
app$set_inputs(main = "Save")
save_file <- app$get_download("core_save-save_session", filename = save_path)
common <- readRDS(save_file)
expect_is(common$mesh, "inla.mesh")

app$set_inputs(tabs = "prep")
app$set_inputs(prepSel = "prep_summary")
app$click("prep_summary-run")
app$set_inputs("prep_summary-resample_layer" = "EVI.tif")
app$set_inputs("prep_summary-resample_layer" = "Mean temperature")
app$click("prep_summary-resample")

app$set_inputs(prepSel = "prep_scale")
app$click("prep_scale-run")

app$set_inputs(tabs = "prep")
app$set_inputs(prepSel = "prep_final")
app$set_inputs("prep_final-id_var" = "ID_2")
app$set_inputs("prep_final-resp_var" = "inc")
app$set_inputs(`prep_final-id_var` = "shapeName")
app$click("prep_final-run")

app$set_inputs(main = "Save")
save_file <- app$get_download("core_save-save_session", filename = save_path)
common <- readRDS(save_file)
common$covs_prep <- unwrap_terra(common$covs_prep)
expect_length(common$covs_prep, 1)
expect_is(common$covs_prep, "SpatRaster")
expect_is(common$prep, "disag_data")

app$set_inputs(tabs = "fit")
app$click("fit_fit-run")
app$set_inputs(main = "Save")
save_file <- app$get_download("core_save-save_session", filename = save_path)
common <- readRDS(save_file)
expect_is(common$fit, "disag_model")

app$set_inputs(tabs = "pred")
app$set_inputs(predSel = "pred_pred")
app$click("pred_pred-run")
app$set_inputs(main = "Save")
save_file <- app$get_download("core_save-save_session", filename = save_path)
common <- readRDS(save_file)
common$pred$`prediction (rate)` <- unwrap_terra(common$pred$`prediction (rate)`)
expect_is(common$pred$`prediction (rate)`, "SpatRaster")

app$set_inputs(tabs = "rep")
app$set_inputs(repSel = "rep_markdown")
sess_file <- app$get_download("rep_markdown-dlRMD")
expect_false(is.null(sess_file))
lines <- readLines(sess_file)

target_line <- grep("shapefile_directory <- ", lines)
lines[target_line] <- 'shapefile_directory <- system.file("extdata", "shapes", package="disagapp")'
target_line <- grep("covariate_directory <- ", lines)
lines[target_line] <- 'covariate_directory <- system.file("extdata", "covariates", package="disagapp")'
target_line <- grep("aggregation_directory <- ", lines)
lines[target_line] <- 'aggregation_directory <- system.file("extdata", "aggregation", package="disagapp")'

target_line <- grep("response_directory <- ", lines)
lines[target_line] <- 'response_directory <- system.file("extdata", "test_data", package="disagapp")'
writeLines(lines, sess_file)

rmarkdown::render(sess_file)
html_file <- gsub("Rmd", "html", sess_file)
expect_gt(file.info(html_file)$size, 1000)
Expand Down

0 comments on commit 4d5c836

Please sign in to comment.