Skip to content

Commit 57c1b4f

Browse files
gaelsogaelso
committed
Cosmetic changes and improve labels for the app
1 parent cbd6b60 commit 57c1b4f

5 files changed

Lines changed: 193 additions & 99 deletions

File tree

‎R/fct_arenalyse.R‎

Lines changed: 108 additions & 84 deletions
Original file line numberDiff line numberDiff line change
@@ -11,12 +11,16 @@
1111
#' result variables, language, etc.).}
1212
#' \item{schema_summary}{Data dictionary describing all input dimensions.}
1313
#' \item{report_dimensions}{Available reporting dimensions.}
14-
#' \item{OLAP_<entity>}{Wide-format OLAP table for the target entity.}
14+
#' \item{MAU_<entity>}{Minimal Area Unit tables for the target entity.}
1515
#' }
1616
#' @param .entity Character scalar. Name of the entity to analyse (e.g.
1717
#' \code{"tree"}, \code{"plot"}).
1818
#' @param .dim Character vector. Names of the reporting dimensions to include
1919
#' (e.g. \code{c("plot_forest_type", "plot_province")}).
20+
#' @param .cm Compute mode, One of `"fast"` or `"safe"`. `"fast"` computes all
21+
#' measures in a single survey summary call; `"safe"` computes each measure
22+
#' separately and keeps partial results when some measures fail. Defaults to
23+
#' `"fast"`.
2024
#' @param .pb_ss A Shiny session for [shinyWidgets::updateProgressBar()].
2125
#' Default `NULL`.
2226
#' @param .pb_id The widget ID for [shinyWidgets::updateProgressBar()].
@@ -35,14 +39,17 @@
3539
#' @importFrom rlang .data
3640
#'
3741
#' @export
38-
fct_arenalyse <- function(.zip, .entity, .dim, .pb_ss = NULL, .pb_id = NULL) {
42+
fct_arenalyse <- function(.zip, .entity, .dim, .cm = c("fast", "safe"), .pb_ss = NULL, .pb_id = NULL) {
3943

4044
## !!! FOR TESTING ONLY
4145
# .zip <- fct_readzip2(.path = "inst/extdata/OLAP_Shiny_demo.zip")$data
46+
# .zip <- fct_readzip2(.path = "~/syncwork/FAO-2026/support/support-arenalytics/MAU_Shiny_(png_nfi_2024_upperplant) 2.zip")$data
4247
# .entity <- .zip$chain_summary$analysis$entity
4348
# .dim <- .zip$chain_summary$analysis$dimensions
4449
# .dim
45-
# pb_ss = NULL ; .pb_id = NULL
50+
# .dim <- "cluster_forest_type"
51+
# .dim <- "stratum_calc"
52+
# .cm = "fast" ; .pb_ss = NULL ; .pb_id = NULL
4653
## !!!
4754

4855
## ++ ##
@@ -60,6 +67,8 @@ fct_arenalyse <- function(.zip, .entity, .dim, .pb_ss = NULL, .pb_id = NULL) {
6067

6168
## 0. Coerce inputs ------
6269
log_step(paste0("Preparing analysis for entity '", .entity, "'."), value = 5)
70+
.cm <- match.arg(.cm)
71+
6372
.zip$chain_summary$resultVariables <- tibble::as_tibble(
6473
.zip$chain_summary$resultVariables
6574
)
@@ -81,6 +90,13 @@ fct_arenalyse <- function(.zip, .entity, .dim, .pb_ss = NULL, .pb_id = NULL) {
8190
.zip = .zip, .entity = .entity, .entity_prefix = entity_prefix
8291
)
8392
log_step("Entity metadata loaded.", value = 15)
93+
94+
old_survey_opt <- options(
95+
survey.ultimate.cluster = FALSE,
96+
survey.adjust.domain.lonely = TRUE,
97+
survey.lonely.psu = "adjust"
98+
)
99+
on.exit(options(old_survey_opt), add = TRUE)
84100
## ++ ##
85101

86102
## 3. Analysis configuration ------
@@ -136,7 +152,7 @@ fct_arenalyse <- function(.zip, .entity, .dim, .pb_ss = NULL, .pb_id = NULL) {
136152
}
137153

138154
## ++ ##
139-
log_step("Filtering OLAP rows and preparing analysis table.", value = 25)
155+
log_step("Filtering MAU rows and preparing analysis table.", value = 25)
140156
## ++ ##
141157

142158
df_data <- wt |>
@@ -298,98 +314,106 @@ fct_arenalyse <- function(.zip, .entity, .dim, .pb_ss = NULL, .pb_id = NULL) {
298314
}
299315

300316
## 9. Survey estimation ------
301-
# t0 <- Sys.time()
302-
#
303-
# out_mean_test <- design |>
304-
# dplyr::group_by(dplyr::across(dplyr::all_of(dims))) |>
305-
# dplyr::summarise(
306-
# dplyr::across(
307-
# .cols = dplyr::any_of(measures),
308-
# .fns = list(~srvyr::survey_mean(
309-
# .x, na.rm = FALSE, vartype = c("se", "ci"),
310-
# proportion = FALSE, level = chain$analysis$pValue, df = Inf
311-
# ))
312-
# )
313-
# ) |>
314-
# ## srvyr list-output suffix: _1 -> _1_ (placeholder, resolved in step 11)
315-
# dplyr::rename_with(
316-
# ~stringr::str_replace(.x, "_1$", "_1_"), dplyr::ends_with("_1")
317-
# )
318-
# message(
319-
# "survey_mean(): ", round(difftime(Sys.time(), t0, units = "secs"), 1), "s"
320-
# )
321-
322317
## !!! TESTING MAP OVER MEASURES TO INC PROGRESS BAR
323318
t0 <- Sys.time()
324319

325-
read_errors <- character(0)
326-
measure_n <- length(measures)
320+
if (.cm == "fast") {
321+
log_step("Computing survey means in fast mode.", value = 50)
322+
Sys.sleep(0.1)
323+
log_step("Wait! Executing the {survey} package...", value = 50)
324+
325+
out_mean <- design |>
326+
dplyr::group_by(dplyr::across(dplyr::all_of(dims))) |>
327+
dplyr::summarise(
328+
dplyr::across(
329+
.cols = dplyr::any_of(measures),
330+
.fns = list(~srvyr::survey_mean(
331+
.x, na.rm = FALSE, vartype = c("se", "ci"),
332+
proportion = FALSE, level = chain$analysis$pValue, df = Inf
333+
))
334+
)
335+
) |>
336+
dplyr::rename_with(
337+
~stringr::str_replace(.x, "_1$", "_1_"), dplyr::ends_with("_1")
338+
)
327339

328-
## ++ ##
329-
out_mean <- purrr::imap(measures, function(m, idx) {
330-
331-
tt <- tryCatch(
332-
{
333-
design |>
334-
dplyr::group_by(dplyr::across(dplyr::all_of(dims))) |>
335-
dplyr::summarise(
336-
dplyr::across(
337-
.cols = dplyr::any_of(m),
338-
.fns = list(~srvyr::survey_mean(
339-
.x, na.rm = FALSE, vartype = c("se", "ci"),
340-
proportion = FALSE, level = chain$analysis$pValue, df = Inf
341-
))
340+
## Add test for NULL or NA in all measures (unlikely)
341+
check_na <- out_mean |> dplyr::select(dplyr::where(~all(is.na(.))))
342+
check_na <- ncol(check_na) == 4 * length(measures)
343+
344+
check_null <- ncol(out_mean) == length(dims)
345+
346+
if (check_na | check_null) stop("All measures NA or NULL")
347+
348+
} else {
349+
read_errors <- character(0)
350+
measure_n <- length(measures)
351+
352+
log_step("Computing survey means in safe mode.", value = 50)
353+
Sys.sleep(0.1)
354+
log_step("Wait! Executing the {survey} package...", value = 50)
355+
356+
## ++ ##
357+
out_mean <- purrr::imap(measures, function(m, idx) {
358+
tt <- tryCatch(
359+
{
360+
design |>
361+
dplyr::group_by(dplyr::across(dplyr::all_of(dims))) |>
362+
dplyr::summarise(
363+
dplyr::across(
364+
.cols = dplyr::any_of(m),
365+
.fns = list(~srvyr::survey_mean(
366+
.x, na.rm = FALSE, vartype = c("se", "ci"),
367+
proportion = FALSE, level = chain$analysis$pValue, df = Inf
368+
))
369+
)
370+
) |>
371+
## srvyr suffix: _1 -> _1_ (placeholder, resolved in step 11)
372+
dplyr::rename_with(
373+
~stringr::str_replace(.x, "_1$", "_1_"), dplyr::ends_with("_1")
342374
)
343-
) |>
344-
## srvyr suffix: _1 -> _1_ (placeholder, resolved in step 11)
345-
dplyr::rename_with(
346-
~stringr::str_replace(.x, "_1$", "_1_"), dplyr::ends_with("_1")
347-
)
348-
},
349-
warning = function(w) {
350-
msg <- conditionMessage(w)
351-
message(sprintf(
352-
"[%s] WARNING computing %s \u2014 %s",
353-
format(Sys.time(), "%Y-%m-%d %H:%M:%S"), m, msg
354-
))
355-
read_errors[[m]] <<- msg # <<- writes to the enclosing map() env
356-
NULL
357-
#invokeRestart("muffleWarning") # log and resume; do not abort
358-
},
359-
error = function(e) {
360-
msg <- conditionMessage(e)
361-
message(sprintf(
362-
"[%s] ERROR computing %s \u2014 %s",
363-
format(Sys.time(), "%Y-%m-%d %H:%M:%S"), m, msg
364-
))
365-
read_errors[[m]] <<- msg # <<- writes to the enclosing map() env
366-
NULL
375+
},
376+
warning = function(w) {
377+
msg <- conditionMessage(w)
378+
message(sprintf(
379+
"[%s] WARNING computing %s \u2014 %s",
380+
format(Sys.time(), "%Y-%m-%d %H:%M:%S"), m, msg
381+
))
382+
read_errors[[m]] <<- msg
383+
NULL
384+
},
385+
error = function(e) {
386+
msg <- conditionMessage(e)
387+
message(sprintf(
388+
"[%s] ERROR computing %s \u2014 %s",
389+
format(Sys.time(), "%Y-%m-%d %H:%M:%S"), m, msg
390+
))
391+
read_errors[[m]] <<- msg
392+
NULL
393+
}
394+
)
395+
396+
if (!is.null(tt)) {
397+
log_step(
398+
paste0("Processed measure ", idx, "/", measure_n, ": ", m, "."),
399+
value = 50 + (idx / max(measure_n, 1)) * 35
400+
)
367401
}
368-
)
369402

370-
if (!is.null(tt)) {
371-
log_step(
372-
paste0("Processed measure ", idx, "/", measure_n, ": ", m, "."),
373-
value = 50 + (idx / max(measure_n, 1)) * 35
374-
)
375-
}
403+
tt
404+
})
405+
## ++ ##
376406

377-
tt
407+
out_mean <- purrr::compact(out_mean)
378408

379-
}) ## End res_list
380-
## ++ ##
409+
if (length(out_mean) == 0) {
410+
stop("No measures were successfully computed. Check warnings and errors for details.")
411+
}
381412

382-
## Handle cases where output is all NULL
383-
out_mean <- purrr::compact(out_mean)
413+
out_mean <- purrr::reduce(out_mean, dplyr::left_join, by = dims)
384414

385-
if (length(out_mean) == 0) {
386-
stop(
387-
"No measures were successfully computed. Check warnings and errors for
388-
details."
389-
)
390-
}
415+
} ## End IF out_mean calc
391416

392-
out_mean <- purrr::reduce(out_mean, dplyr::left_join, by = dims)
393417
log_step(
394418
paste(
395419
"survey_mean() completed in: ",

‎R/fct_find_label.R‎

Lines changed: 32 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,32 @@
1+
#' Find labels in a schema-like table using the selected language
2+
#'
3+
#' @param .df A data frame containing a name column and label columns.
4+
#' @param .name Character vector of names to look up.
5+
#' @param .lang Language code used to build the preferred label column.
6+
#' @param .name_col Column containing the keys to match. Default `"name"`.
7+
#'
8+
#' @return A character vector of labels aligned with `.name`.
9+
#'
10+
#' @noRd
11+
fct_find_label <- function(.df, .name, .lang = "en", .name_col = "name") {
12+
13+
.df <- tibble::as_tibble(.df)
14+
label_col <- paste0("label_", .lang)
15+
16+
if (!label_col %in% names(.df)) {
17+
label_col <- if ("label" %in% names(.df)) "label" else NULL
18+
}
19+
20+
if (is.null(label_col)) {
21+
return(.name)
22+
}
23+
24+
lookup_df <- .df |>
25+
dplyr::filter(.data[[.name_col]] %in% .name) |>
26+
dplyr::select(name = dplyr::all_of(.name_col), label = dplyr::all_of(label_col))
27+
28+
lookup <- stats::setNames(as.character(lookup_df$label), lookup_df$name)
29+
labels <- unname(lookup[.name])
30+
31+
dplyr::coalesce(dplyr::na_if(labels, ""), .name)
32+
}

‎R/fct_varinfo.R‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -89,6 +89,9 @@ fct_varinfo <- function(.zip, .entity, .entity_prefix = "MAU_"){
8989
source = dplyr::coalesce(dplyr::na_if(.data$source, ""), .data$source_rv)
9090
) |>
9191
dplyr::select(-dplyr::ends_with("_rv")) |>
92+
dplyr::mutate(
93+
label = stringr::str_remove(.data$label, " \\(C\\)$")
94+
) |>
9295
dplyr::mutate(
9396
dimension_baseunit = dplyr::if_else(.data$parentEntity == .entity, FALSE, TRUE),
9497
report_type = dplyr::if_else(.data$name == "weight", NA_character_, .data$report_type)

‎R/mod_tool_UI2.R‎

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -350,6 +350,17 @@ mod_tool_UI2 <- function(id, i18n, .tr){
350350
`selected-text-format` = "count > 3"
351351
)
352352
),
353+
shinyWidgets::pickerInput(
354+
ns("analysis_table_dims"),
355+
"Dimension column order",
356+
choices = NULL,
357+
selected = NULL,
358+
multiple = TRUE,
359+
options = list(
360+
`actions-box` = TRUE,
361+
`selected-text-format` = "count > 3"
362+
)
363+
),
353364
downloadButton(
354365
ns("analysis_table_download"),
355366
"Download full table (CSV)"

0 commit comments

Comments
 (0)