WIP: Modular validation in teal and teal_modules

[averissimo]

🐻 WIP 🐻: Beware that code may break!!

Pull Request

Fixes #1322

Unified validation framework that allows to create re-usable validation modules for teal framework as well as in modules

Changes description

• Replaces existing validation logic with low-level srv_module_check_XXXX
  • 🛈 Returns TRUE for no problem
  • 🛈 Returns renderable message (character or HTML)
• Factory to build validation SRV / UI based on checks from the previous bullet
  • Single checks
  • Combination of checks
  • 🛈 Module server created dynamically (code is inspectable.. see module_validate_datanames$server)
• 🏗️ Full support for sample app below
  • teal_transform_modules
  • teal_transform_decorators
  • Minimize duplicate messages Q: Should decorator show error from upstream teal_data (pre-decorated) in the UI? #1421
• Removal of qenv.error requirement from teal [Question]: qenv.error probably doesn't make sense anymore #1458

Caveats

• Error handling in parallel
  • Logic should be very narrow to avoid repeated messages for the same underlying problem (such as shiny.silent.errors vs. validation vs. generci conditions)
  • Workaround with stop_on_first = TRUE parameter for factory.

Sample App to test errors

options(
  teal.log_level = "ERROR",
  teal.show_js_log = TRUE,
  # teal.bs_theme = bslib::bs_theme(version = 5),
  shiny.bookmarkStore = "server"
)

devtools::load_all("../teal")
pkgload::load_all("../teal.code")

tm_decorated_plot <- function(label = "module", transformators = list(), decorators = list(), datanames = "all") {
  checkmate::assert_list(decorators, "teal_transform_module")
  module(
    label = label,
    ui = function(id, decorators) {
      ns <- NS(id)
      div(
        style = "margin-left: 0.5em; margin-right: 0.5em;",
        tags$em("(Encoding panel)", style = "margin-bottom: 0.5em; color: gray;"),
        div(
          style = "display: flex; gap: .2em;",
          selectInput(ns("dataname"), label = "Select dataname", choices = NULL, multiple = TRUE),
          selectInput(ns("x"), label = "Select x", choices = NULL, multiple = TRUE),
          selectInput(ns("y"), label = "Select y", choices = NULL, multiple = TRUE),
        ),
        ui_transform_teal_data(ns("decorate"), transformators = decorators),
        ui_module_validate(ns("validation")),
        tags$h4("Plot data description"),
        verbatimTextOutput(ns("description")),
        tags$h4("Main plot"),
        plotOutput(ns("plot")),
        tags$h4("Code"),
        verbatimTextOutput(ns("text"))
      )
    },
    server = function(id, data, decorators) {
      moduleServer(id, function(input, output, session) {
        observeEvent(data(), {
          dataname <- if (length(input$dataname)) input$dataname else names(data())[1]
          updateSelectInput(inputId = "dataname", choices = names(data()), selected = dataname)
        })

        observeEvent(input$dataname, {
          req(input$dataname)
          updateSelectInput(inputId = "x", choices = colnames(data()[[input$dataname]]))
          updateSelectInput(inputId = "y", choices = colnames(data()[[input$dataname]]))
        })

        dataname <- reactive(req(input$dataname))
        x <- reactive({
          req(input$x, input$x %in% colnames(data()[[dataname()]]))
          input$x
        })

        y <- reactive({
          req(input$y, input$y %in% colnames(data()[[dataname()]]))
          input$y
        })
        plot_data <- reactive({
          # todo: make sure it triggers once on init
          #       and once on change of its input and once on change in previous stages
          req(dataname(), x(), y())
          within(data(),
                 {
                   plot <- ggplot2::ggplot(dataname, ggplot2::aes(x = x, y = y)) +
                     ggplot2::geom_point()
                 },
                 dataname = as.name(dataname()),
                 x = as.name(x()),
                 y = as.name(y())
          )
        })

        extra_validation <- reactive(
          validate(
            need(
              try(req(dataname(), x(), y()), silent = TRUE),
              message = "(sample in-module usage) Please select dataname, x and y"
            )
          )
        )
        srv_module_validate_validation("validation", extra_validation)

        plot_data_decorated_no_print <- srv_transform_teal_data(
          "decorate",
          data = plot_data,
          transformators = decorators
        )
        plot_data_decorated <- reactive({
          within(req(plot_data_decorated_no_print()), expr = plot)
        })

        plot_r <- reactive({
          plot_data_decorated()[["plot"]]
        })

        output$description <- renderPrint(print(req(plot_data_decorated())))
        output$plot <- renderPlot(plot_r())
        output$text <- renderText({
          teal.code::get_code(req(plot_data_decorated()))
        })
      })
    },
    ui_args = list(decorators = decorators),
    server_args = list(decorators = decorators),
    datanames = datanames,
    transformators = transformators
  )
}

make_data <- function(datanames = c("ADSL", "ADTTE")) {
  data_obj <- teal.data::teal_data()
  if ("ADSL" %in% datanames) {
    data_obj <- within(data_obj, ADSL <- teal.data::rADSL)
  }
  if ("ADTTE" %in% datanames) {
    data_obj <- within(data_obj, ADTTE <- teal.data::rADTTE)
  }
  join_keys(data_obj) <- default_cdisc_join_keys[datanames]
  data_obj
}

data <- teal_data_module(
  once = FALSE,
  ui = function(id) {
    ns <- NS(id)
    tagList(
      selectizeInput(
        ns("errortype"),
        label = "Error Type",
        choices = c(
          "ok", "insufficient datasets", "no data",
          "qenv.error", "error in reactive", "validate error", "silent.shiny.error", "not a reactive"
        )
      )
    )
  },
  server = function(id, ...) {
    moduleServer(id, function(input, output, session) {
      logger::log_trace("example_module_transform2 initializing.")

      reactive({
        switch(req(input$errortype),
               ok = make_data(),
               `insufficient datasets` = make_data(datanames = "ADSL"),
               `no data` = teal_data(),
               qenv.error = within(teal_data(), stop("this is qenv.error in teal_data_module (from inside within())")),
               `error in reactive` = stop("error in a reactive in teal_data_module (manual stop call)"),
               `validate error` = validate(need(FALSE, "validate error in teal_data_module (with newline )")),
               `silent.shiny.error` = req(FALSE)
        )
      })
    })
  }
)

trans <- teal_transform_module(
  ui = function(id) {
    ns <- NS(id)
    tagList(
      selectizeInput(
        ns("errortype"),
        label = "Error Type",
        choices = c(
          "ok", "insufficient datasets", "no data",
          "qenv.error", "error in reactive", "validate error", "silent.shiny.error", "not a reactive"
        )
      )
    )
  },
  server = function(id, data) {
    moduleServer(id, function(input, output, session) {
      logger::log_trace("example_module_transform2 initializing.")
      reactive({
        # todo: make sure it triggers once on init
        #       and once on change of its input and once on change in previous stages
        new_data <- switch(input$errortype,
                           ok = data(),
                           `insufficient datasets` = data()["ADSL"],
                           `no data` = teal_data(),
                           qenv.error = within(teal_data(), stop("this is qenv.error in teal_transform_module")),
                           `error in reactive` = stop("error in a reactive in teal_transform_module"),
                           `validate error` = validate(need(FALSE, "validate error in teal_transform_module")),
                           `silent.shiny.error` = req(FALSE)
        )
        new_data
      })
    })
  }
)

empty_ui_trans <- teal_transform_module(
  ui = NULL,
  # server = function(id, data) moduleServer(id, function(input, output, session) reactive(stop("data")))
  server = function(id, data) moduleServer(id, function(input, output, session) data)
)


decor <- function(title_suffix = "Title") {
  teal_transform_module(
    label = sprintf("\"%s\" decorator", title_suffix),
    ui = function(id) {
      ns <- NS(id)
      tagList(
        selectizeInput(
          ns("action"),
          label = "Action type",
          choices = c(
            "nothing", "decorate", "no data",
            "qenv.error", "error in reactive",
            "validate error", "silent.shiny.error",
            "not a reactive"
          )
        )
      )
    },
    server = function(id, data) {
      moduleServer(id, function(input, output, session) {
        logger::log_trace("example_module_transform2 initializing.")
        reactive({
          switch(input$action,
                 "nothing" = data(),
                 "decorate" = data() |> within(plot <- plot + ggplot2::ggtitle(title), title = sprintf("%s %s", data()$plot$labels$title %||% "Decorated", title_suffix)),
                 "no data" = teal_data(),
                 "qenv.error" = within(teal_data(), stop("this is qenv.error in teal_transform_module")),
                 "error in reactive" = stop("error in a reactive in teal_transform_module"),
                 "validate error" = validate(need(FALSE, "Custom validate error in teal_transform_module")),
                 "silent.shiny.error" = req(FALSE)
          )
        })
      })
    }
  )
}

app <- teal::init(
  data = data,
  modules = list(
    tm_decorated_plot(
      "mod-2",
      transformators = list(empty_ui_trans, trans, trans),
      decorators = list(decor("title"), decor("(second) title")),
      datanames = c("ADSL", "ADTTE")
    ),
    tm_decorated_plot(
      "mod-2 (blank)",
      decorators = list(),
      datanames = c("ADSL", "ADTTE")
    ),
    tm_decorated_plot(
      "mod-2 (only decorators)",
      decorators = list(decor("title"), decor("(second) title")),
      datanames = c("ADSL", "ADTTE")
    ),
    tm_decorated_plot(
      "mod-2 (only trans)",
      transformators = list(empty_ui_trans, trans, trans),
      datanames = c("ADSL", "ADTTE")
    )

  ),
  filter = teal_slices(
    teal_slice("ADSL", "SEX"),
    teal_slice("ADSL", "AGE", selected = c(18L, 65L)),
    teal_slice("ADTTE", "PARAMCD", selected = "CRSD"),
    include_varnames = list(
      ADSL = c("SEX", "AGE")
    )
  )
)

runApp(app)

[averissimo]

Moved from deleted file

[averissimo]

No longer used internally, deleting unless there is some use case

[averissimo]

There are basically 2 types of data validation groups throughout teal

We could reduce complexity of code and define the 2 module_validate_xxx manually while still keeping with low-level srv_module_check_*** functions.

[averissimo]

Example of list generated by factory:

#> > module_validate_datanames
#> $ui
function(id) {
      div(
        id = NS(id, "validate_messages"),
        class = "teal_validated",
        tags$div(class = "messages", uiOutput(NS(id, "errors")))
      )
    }

#> $server
function (id, x, show_warn = reactive(FALSE), message_warn = "not defined", 
    modules, stop_on_first = TRUE) 
{
    checkmate::assert_string(id)
    moduleServer(id, function(input, output, session) {
        collection <- list()
        collection <- append(collection, srv_module_check_previous_state_warn(x, 
            show_warn, message_warn))
        collection <- append(collection, srv_module_check_datanames(id, 
            x, modules))
        validate_r <- reactive({
            message_collection <- Reduce(function(u, v) if (isTRUE(v()) || 
                is.null(v())) 
                u
            else append(u, list(v())), x = collection, init = list())
            message_collection
        })
        output$errors <- renderUI({
            error_class <- c("shiny.silent.error", "validation", 
                "error", "condition")
            if (length(validate_r()) > 0) {
                tagList(!!!lapply(validate_r()[1], function(.x) {
                  html_class <- if (isTRUE(attr(.x[1], "is_warning")) || 
                    isTRUE(attr(.x, "is_warning"))) {
                    "teal-output-warning teal-output-condition"
                  }
                  else {
                    "shiny-output-error teal-output-condition"
                  }
                  if (!checkmate::test_multi_class(.x, c("shiny.tag", 
                    "shiny.tag.list"))) {
                    html_class <- c(html_class, "prewrap-ws")
                    .x <- lapply(.x, tags$p)
                  }
                  tags$div(class = html_class, tags$div(.x))
                }))
            }
        })
        x
    })
}

[averissimo]

ℹ️ Updated example app

[averissimo]

Proposal:

• When error occurs in transformators the module UI shows, but it's blurred and disabled
  • This forces the user to focus on the problem while still keeping the UI in place
  • Alternatives:
    • place an overlay over module UI if blur effect is not desired (possibly via CSS filters or opacity)