r - future_promise not unblocking the main shiny app session - Stack Overflow

admin管理员组

文章数量:1317898

Goal

I have a teacher UI in my shiny app where a teacher can select any student ID from a selectizeInput. Based on the current student info in the Firestore database, data is fetched and a ggiraph plot is drawn. The points in the plot are clickable that launch modals containing further information.

Example

I am following the FUTURE_PROMISE() section of this article. I have an async function used in a module that is used in the shiny app.

Issue

Unlike the example in the article, the time pauses in my app and the modal does not launch until the plot is generated. What am I doing wrong here?

Code

Note that this app uses frbs and frstore packages that require firebase project credentials. I created a temporary DB but sharing the credentials here may still not be a good idea.

app.R

library(shiny)
library(bslib)
library(frbs)
library(frstore)
library(systemfonts)
library(ggplot2)
library(ggiraph)
library(ggimage)
library(future)
library(promises)

# Async Plan-------------
plan(
  strategy = multisession,
  workers = 3
)

# UI----------
ui <- page_fluid(
  textOutput("time"),
  selectizeInput("user_select_map", "Student ID:",
                 choices = c("stu1", "stu2"),
                 options = list(
                   onInitialize = I('function() { this.setValue(""); }')
                 )),
  uiOutput("plot"),
  actionButton("launch", "Launch Modal")
)

# Server---------
server <- function(input, output, session) {

  #### Sign In ####
  PROJECT_NAME <- reactive(frstore_project_id())
  accessToken <- reactive({
    admin_account <- frbs_sign_in(Sys.getenv("ADMIN_EMAIL"), Sys.getenv("PASS"))
    admin_account$idToken
  })

  #### Show Time ####
  output$time <- renderText({
    invalidateLater(1000)
    format(Sys.time(), "%H:%M:%S")
  })

  #### Launch a Modal ####
  observeEvent(input$launch, {
    showModal(
      modalDialog(title = "MODAL")
    )
  })

  #### Render Plot ####
  output$plot <- renderUI({
    tagList(
      div(
        id = paste0("stu_idmap"),
        tags$h4(input$user_select_map),
        mod_plot_promises_ui("stu_progress")
      )
    )
  })

  #### Async Plotting Module ####
  mod_plot_promises_server(
    "stu_progress",
    accessToken,
    reactive(input$user_select_map),
    this_email,
    session
  )
}

shinyApp(ui, server)

mod_plot_promises

collection_paths_e <- c("assign1", "assign2", "assign3",
                        "done1", "done2", "done3")

mod_plot_promises_ui <- function(id){
  ns <- NS(id)
  tagList(
    girafeOutput(ns("student_progress"))
  )
}


mod_plot_promises_server <- function(id, accessToken, student_email, this_email,
                                                     parent_session
){
  moduleServer( id, function(input, output, session){
    ns <- session$ns

    event_names_list_stu <- reactivePoll(
      10000,
      session,
      checkFunc = function() {
        get_all_event_names_for_a_student(collection_paths_e, student_email(), accessToken())
      },
      valueFunc = function() {
        get_all_event_names_for_a_student(collection_paths_e, student_email(), accessToken())
      }
    )

    # Reactive value to store the plot promise
    progress_map_promise <- reactiveVal()

    observeEvent(event_names_list_stu(), {
      create_inst_progress_visual_async(
          event_names_list_stu(),
          accessToken(),
          student_email()
        ) %>%
        then(\(result){
          cli::cat_line("Yeay")
          progress_map_promise(result)
        }) %>%
        catch(\(error){
          cli::cat_line("Ouch")
          progress_map_promise(
                girafe(
                  ggobj = ggplot() +
                    annotate("text", x = 0.5, y = 0.5,
                             label = "Error loading plot",
                             size = 5, hjust = 0.5) +
                    theme_void()
                )
          )
        })
    })

    output$student_progress <- renderGirafe({
      progress_map_promise()
    })
  })
}

Plotting function

create_inst_progress_visual_async <- function(event_names_list_stu, accessToken, this_email){
  promises::future_promise(
    packages = c("ggplot2", "ggiraph", "dplyr", "httr2", "frstore", "ggimage", "systemfonts"),
    seed = TRUE,
    expr = {
    my_green <- "darkgreen"
    another_grey <- "#D3D3D3"
    infoc <- "#f7d782"
    my_black <- "black"
    base_font <- "queensides"
    tryCatch({
      if (!("queensides" %in% systemfonts::system_fonts()$family)) {
        systemfonts::register_font(
          name = "queensides",
          plain = here::here("www/Queensides-3z7Ey.ttf")
        )
      }

    # Status--------------
    num_events <- 3L
    eventz <- sapply(1:num_events, function(x) paste0("Event ", x))
    assigns <- sapply(1:num_events, function(x) paste0("assign", x))
    dones <- sapply(1:num_events, function(x) paste0("done", x))

    stu_enames <- event_names_list_stu
    status <- vector(mode = "character", length = num_events)

    for (i in 1:num_events){
      assi_done <- stu_enames[c(paste0("assign", i), paste0("done", i))]
      if ((assi_done[1] == "no name") & (assi_done[2] == "no name")){
        status[i] <- "Not Assigned"
      } else if ((assi_done[1] != "no name") & (assi_done[2] != "no name")){
        status[i] <- "Complete"
      } else if ((assi_done[1] != "no name") & (assi_done[2] == "no name")){
        status[i] <- "Outstanding"
      }
    }

      # Plot data----------------
      if (is.null(status)){
        dat <- NULL
      } else {
        x_pos <- seq(3, length.out = num_events)
        scaling_factor <- ifelse(num_events > 5, 30, 20)
        y_pos <- seq(0, 1, length.out = num_events) * scaling_factor
        events <- eventz
        # }

        dat <- tibble::tibble(
          x_pos = x_pos,
          y_pos = y_pos,
          events = events,
          Status = status
        )
        dat <- dat |>
          dplyr::mutate(
            imagee = dplyr::case_match(
              Status,
              "Complete" ~ 'checkmark-circle',
              c("Not Assigned") ~ 'ellipse',
              "Outstanding" ~ 'alert-circle'
            ),
            filll = dplyr::case_match(
              Status,
              "Complete" ~ my_green,
              c("Not Assigned") ~ another_grey,
              "Outstanding" ~ infoc
            ),
            colorr = dplyr::case_match(
              Status,
              c("Not Assigned") ~ "white",
              "Complete" ~ my_black,
              "Outstanding" ~ "brown" #"red"
            ),
            text_position = ifelse(dplyr::row_number() %% 2 == 0, -2.5, 3.5)
          )
      }

      # Plot
      if (is.null(dat)) {
        p <- ggplot() +
          annotate("text", x = 0.5, y = 0.5, label = "No data yet", size = 5, hjust = 0.5) +
          theme_void() +
          theme(plot.margin = margin(0, 0, 0, 0))

        return(
          list(
            status = status,
            progress_plot = girafe(ggobj = p, width_svg = 5, height_svg = 3)
          )
        )
      } else {

        p <- ggplot(data = dat, aes(x_pos, y_pos)) +
          geom_path(color = "#D3D3D3", linewidth = 1.5) +
          geom_point(data = dat |>
                       dplyr::filter(Status %in% c("Complete", "Outstanding")),

                     size = 10, aes(color = I(colorr))) +
          geom_icon(aes(image = imagee, color = I(filll)), size = 0.08) +
          geom_point_interactive(data = dat |>
                                   dplyr::filter(Status %in% c("Not Assigned", "Outstanding")
                                   ),
                                 aes(tooltip = events,
                                     data_id = events),
                                 size = 12, alpha = 0) + # Transparent points for interaction
          geom_text(aes(label = events),
                    color = "#041C2C",
                    size = 6,
                    nudge_x = 0.3,
                    nudge_y = 0,
                    family = base_font
          ) +
          theme_void(base_family = base_font) +
          theme(plot.margin = margin(t = 20, unit = "pt"),
                text = element_text(family = base_font)) +
          coord_cartesian(clip = "off")

        # list(
        #   status = status,
        #   dat = dat,
        #   progress_plot = girafe(ggobj = p, options = list(
        #     opts_selection(type = "single", css = "cursor:pointer;")
        #   ))
        # )
        girafe(ggobj = p, options = list(
          opts_selection(type = "single", css = "cursor:pointer;")
        ))
      }
    }, error = function(e){
      p <- ggplot() +
        annotate("text", x = 0.5, y = 0.5, label = "Failed to fetch data", size = 5, hjust = 0.5) +
        theme_void() +
        theme(plot.margin = margin(0, 0, 0, 0))
      # list(
      #   status = "Failed to get status",
      #   dat = "dat",
      #   progress_plot = girafe(ggobj = p, options = list(
      #     opts_selection(type = "single", css = "cursor:pointer;")
      #   ))
      # )
      girafe(ggobj = p, options = list(
        opts_selection(type = "single", css = "cursor:pointer;")
      ))
    }
    )
    })
}

本文标签： rfuturepromise not unblocking the main shiny app sessionStack Overflow