Skip to content

[Bug]: decoration error state changes with first good run #1511

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
3 tasks done
averissimo opened this issue Apr 8, 2025 · 2 comments · May be fixed by #1515
Open
3 tasks done

[Bug]: decoration error state changes with first good run #1511

averissimo opened this issue Apr 8, 2025 · 2 comments · May be fixed by #1515
Assignees
Labels
bug Something isn't working core

Comments

@averissimo
Copy link
Contributor

What happened?

In 2 different ways after returning to an error state after being in a good one

  1. Error messages in decorators are inconsistent
    • Shown warning for 2^nd, 3^rd, ... saying that "previous decorator failed" (in initial state no warning were shown)
  2. Code and plot are not updated to error state
    • Last known good state is shown

(see below on how to reproduce it):

Image

How to reproduce either:
  1. After selecting both x and y
  2. Force an error state by removing x and y
  3. Observe:
    1. Error messages are different from initial state
    2. Plot is still sown
Example App
options(
  teal.log_level = "ERROR",
  teal.show_js_log = TRUE,
  # teal.bs_theme = bslib::bs_theme(version = 5),
  shiny.bookmarkStore = "server"
)

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

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
}


decor <- teal_transform_module(
  label = "X-axis decorator",
  ui = function(id) {
    ns <- NS(id)
    tags$em("A decorator")
  },
  server = function(id, data) {
    moduleServer(id, function(input, output, session) {
      logger::log_trace("example_module_transform2 initializing.")
      reactive(data() |> within(plot <- plot + ggplot2::ggtitle("Decorated Title")))
    })
  }
)

teal::init(
  data = make_data(),
  modules = list(
    tm_decorated_plot(
      "mod-2",
      # transformators = list(empty_ui_trans, trans, trans),
      decorators = list(decor, decor),
      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()

sessionInfo()

Relevant log output

Code of Conduct

  • I agree to follow this project's Code of Conduct.

Contribution Guidelines

  • I agree to follow this project's Contribution Guidelines.

Security Policy

  • I agree to follow this project's Security Policy.
@averissimo averissimo added bug Something isn't working core labels Apr 8, 2025
@averissimo averissimo self-assigned this Apr 8, 2025
@averissimo
Copy link
Contributor Author

This is due to the srv_transform_teal_data being designed for "transformators" that assume top-level data is good.

From my perspective, we want to keep UI consistency, so that the same state presents the same-ish UI.

Proposal (live on 1322_validation@main branch -- commit a3b3afd and the previous ones)

Disable transformations if top-level data() reactive is not a teal_data object

In the example app, it's not until "encoding" produces a valid teal_data object

  • This should never be the case for "transformators" as the top-level data() is defined in init() or in teal_data_module
  • Showing an info box explaining why it is disabled (currently done in pure CSS)

Image

Sample app for `1322_validation@main`
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)

@m7pr
Copy link
Contributor

m7pr commented Apr 9, 2025

@averissimo looks really solid

@averissimo averissimo linked a pull request Apr 14, 2025 that will close this issue
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Labels
bug Something isn't working core
Projects
None yet
Development

Successfully merging a pull request may close this issue.

2 participants