populate selectise from server side

DESCRIPTION

@@ -27,7 +27,6 @@ Imports:
     dplyr,
     DT,
     glue,
-    here,
     omopgenerics (>= 0.2.3),
     purrr,
     rlang,
@@ -45,6 +44,7 @@ Suggests:
     duckdb,
     ggplot2,
     gt,
+    here,
     htmlwidgets,
     knitr,
     omock,
@@ -56,8 +56,8 @@ Suggests:
     sortable,
     testthat (>= 3.1.5),
     utils,
-    zip,
-    webshot2
+    webshot2,
+    zip
 VignetteBuilder: knitr
 Config/testthat/edition: 3
 Config/testthat/parallel: true

NAMESPACE

@@ -3,10 +3,12 @@
 export(exportStaticApp)
 export(exportSummarisedResult)
 export(filterData)
+export(getChoices)
 export(importSummarisedResult)
 export(launchDynamicApp)
 export(tidyData)
 export(visTable)
+importFrom(omopgenerics,emptySummarisedResult)
 importFrom(omopgenerics,exportSummarisedResult)
 importFrom(omopgenerics,importSummarisedResult)
 importFrom(rlang,.data)

R/appStatic.R

@@ -261,11 +261,3 @@ subs <- function(x, pat, subst) {
   }
   return(x)
 }
-emptySummarisedResult <- function() {
-  omopgenerics::emptySummarisedResult(settings = dplyr::tibble(
-    result_id = integer(),
-    result_type = character(),
-    package_name = character(),
-    package_version = character()
-  ))
-}

R/buttons.R

@@ -1,18 +1,5 @@
 
 selector <- function(id, lab, cho, sel, mult) {
-  if(stringr::str_detect(id, "variable_name") ||
-     stringr::str_detect(id, "summarise_large_scale_characteristics_grouping_concept_id")){
-    'shiny::selectizeInput(
-    inputId = "{id}",
-    label = "{lab}",
-    choices = NULL,
-    selected = NULL,
-    multiple = {mult},
-    options = list(plugins = "remove_button")
-  )' |>
-      glue::glue() |>
-      as.character()
-  } else {
   'shiny::selectizeInput(
     inputId = "{id}",
     label = "{lab}",
@@ -23,7 +10,6 @@ selector <- function(id, lab, cho, sel, mult) {
   )' |>
     glue::glue() |>
     as.character()
-  }
 }
 downloadTable <- function(id, lab, type = NULL) {
 

R/choices.R

@@ -2,6 +2,7 @@
 #' Get the different options that a summarised_result have.
 #'
 #' @param result A `<summarised_result>` object.
+#' @param flatten Whether to flatten to a single list or not.
 #'
 #' @return A named list with the options
 #' @export
@@ -16,22 +17,32 @@
 #'
 #' getChoices(result)
 #'
-getChoices <- function(result) {
+getChoices <- function(result, flatten = FALSE) {
   # initial checks
-  result <- omopgenerics::validateResultArguemnt(result)
+  result <- omopgenerics::validateResultArgument(result)
+  omopgenerics::assertLogical(flatten, length = 1)
 
   # get choices
   settings <- getPossibleSettings(result)
   grouping <-getPossibleGrouping(result)
   variables <- getPossibleVariables(result)
-  choices <- names(variables) |>
-    purrr::set_names() |>
-    purrr::map(\(x) list(
-      settings = settings[[x]],
-      grouping = grouping[[x]],
-      variable_name = variables[[x]]$variable_name,
-      estimate_name = variables[[x]]$estimate_name
-    ))
+
+  if (flatten) {
+    choices <- c(
+      correctNames(settings, "settings"),
+      correctNames(grouping, "grouping"),
+      correctNames(variables)
+    )
+  } else {
+    choices <- names(variables) |>
+      purrr::set_names() |>
+      purrr::map(\(x) list(
+        settings = settings[[x]],
+        grouping = grouping[[x]],
+        variable_name = variables[[x]]$variable_name,
+        estimate_name = variables[[x]]$estimate_name
+      ))
+  }
 
   return(choices)
 }
@@ -82,3 +93,13 @@ getPossibilities <- function(x, split = FALSE) {
     purrr::map(getPos, split = split)
   return(x)
 }
+correctNames <- function(x, prefix = "") {
+  if (prefix == "") {
+    sub <- "_"
+  } else {
+    sub <- paste0("_", prefix, "_")
+  }
+  x <- unlist(x, recursive = FALSE)
+  names(x) <- gsub(".", sub, names(x), fixed = TRUE)
+  return(x)
+}

R/createServer.R

@@ -1,41 +1,37 @@
 
 createServer <- function(resultTypes, data) {
-  selectiseServer <- c(
-    '# fill selectise variables ----')
-
-    # shiny::observe({
-    #   choices <- omopViewer::getChoices([data])
-    # })
-  #   "updateSelectizeInput(session, ",
-  #   '"',
-  #   rt, "_variable_name", '"',
-  #   ", ",
-  #   "choices = unique(visOmopResults::filterSettings(data, result_type ==",
-  #   '"',
-  #   rt,
-  #   '"',
-  #   ")$variable_name)", ", ",
-  #   "selected = unique(visOmopResults::filterSettings(data, result_type ==",
-  #   '"',
-  #   rt,
-  #   '"',
-  #   ")$variable_name)",
-  #   ", ",
-  #   "server = TRUE)"
-  # )
-
-  purrr::map_chr(resultTypes, \(x) {
-    c(glue::glue("# {x} -----"),
-      glue::glue("## raw {x} -----"),
-      rawServer(x, data),
-      glue::glue("## tidy {x} -----"),
-      tidyServer(x, data),
-      glue::glue("## formatted {x} -----"),
-      formattedServer(x, data),
-      glue::glue("## plot {x} -----"),
-      plotsServer(x, data),
-      "\n"
-    ) |>
-      paste0(collapse = "\n")
-  })
+  c(
+    selectiseServer(resultTypes, data),
+    purrr::map_chr(resultTypes, \(x) {
+      c(glue::glue("# {x} -----"),
+        glue::glue("## raw {x} -----"),
+        rawServer(x, data),
+        glue::glue("## tidy {x} -----"),
+        tidyServer(x, data),
+        glue::glue("## formatted {x} -----"),
+        formattedServer(x, data),
+        glue::glue("## plot {x} -----"),
+        plotsServer(x, data),
+        "\n"
+      ) |>
+        paste0(collapse = "\n")
+    })
+  )
+}
+selectiseServer <- function(resultTypes, data) {
+  if (length(resultTypes) == 0) return(character())
+  c(
+    '# fill selectise variables ----',
+    paste0('shiny::observe({
+      choices <- omopViewer::getChoices(', data, ', flatten = TRUE)
+      for (k in seq_along(choices)) {
+        shiny::updateSelectizeInput(
+          session,
+          inputId = names(choices)[k],
+          choices = choices[[k]],
+          selected = choices[[k]]
+        )
+      }
+    })')
+  )
 }

R/filterData.R

@@ -12,8 +12,15 @@
 filterData <- function(result,
                        resultType,
                        input) {
+  # initial check
+  result <- omopgenerics::validateResultArguemnt(result)
+  omopgenerics::assertCharacter(resultType)
+
+  # filter result type
   result <- result |>
     visOmopResults::filterSettings(.data$result_type == .env$resultType)
+  if (nrow(result) == 0) return(emptySummarisedResult())
+
   if (length(input) == 0) {
     inputs <- character()
   } else {
@@ -37,6 +44,8 @@ filterData <- function(result,
   result <- result |>
       dplyr::filter(.data$result_id %in% set$result_id)
 
+  if (nrow(result) == 0) return(emptySummarisedResult())
+
   # filter grouping
   cols <- c(
     "cdm_name", "group_name", "group_level", "strata_name", "strata_level",

R/reexports.R

@@ -6,3 +6,7 @@ omopgenerics::importSummarisedResult
 #' @importFrom omopgenerics exportSummarisedResult
 #' @export
 omopgenerics::exportSummarisedResult
+
+#' @importFrom omopgenerics emptySummarisedResult
+#' @export
+omopgenerics::emptySummarisedResult()

R/sidebar.R

@@ -29,7 +29,7 @@ getSidebarInformation <- function(tab) {
 getSidebarChoices <- function(choi, tit, prefix) {
   if (length(choi) == 0) return(NULL)
   selectors <- purrr::map_chr(names(choi), \(x) selector(
-    paste0(prefix, "_", x), formatTit(x), cast(choi[[x]]), cast(choi[[x]]), TRUE
+    paste0(prefix, "_", x), formatTit(x), 'NULL', 'NULL', TRUE
   )) |>
     paste0(collapse = ",\n")
   'bslib::accordion_panel(