Question

让我先描述我的应用程序如何工作，然后再描述我面临的两个主要两个问题以及其他一些较小的问题。请让我知道如何重新格式化以帮助其他人轻松找到它。另外，如果您看到其他优化，我将不胜感激！

此应用是更大的应用的一部分，因此第一步的按钮位置和模块顺序看起来很奇怪。

步骤

单击“加载”选项卡上的“加载UI”-将动态加载模块 ui box（）和“ vis”标签中每个“ IDS”的服务器。
每个IDS box（）都可以排序并返回订单

大问题

shinycssloaders :: withSpinner（）函数弄乱了每个框中输出的间距。
shinycssloaders :: withspinner（）函数不显示加载程序。
动态加载UI时，sortable :: sortable_js（）函数最初不会返回框的顺序。我必须重新排序它们才能使其正常工作。

小问题

当我动态生成UI时，我认为它在代码上运行了太多次。
我想知道以下警告消息。它与绘图中的event_data有关。

Warning: The 'plotly_click' event tied a source ID of 'src_id2' is not registered. In order to obtain this event data, please add `event_register(p, 'plotly_click')` to the plot (`p`) that you wish to obtain event data from.

每当我创建ggplot实例时，我也会收到以下警告。我需要将“键”传递给ggplot或plotly，但我不知道如何将其传递给plotly。

Warning: Ignoring unknown aesthetics: key

请在下面查看有效的REPEX。

library(shiny)
library(shinydashboard)
library(tidyverse)
library(plotly)
library(DT)
library(shinycssloaders)
library(sortable)

# VARIABLES ---------------------------------------------------------------

IDS <- c("id1", "id2", "id3")

DATA <- mtcars %>%  rownames_to_column("car") %>% as_tibble() 

# MOD UI ----------------------------------------------------------------------

uiLoad <- function(id){

 ns <- NS(id)
   fluidRow(
     actionButton(ns("loadUi"), label = "Load UI")
   )

}

uiBox <- function(id){
 tags$div(id = id,  class = "col-sm-12",
   box(title = id, collapsible = T, width = 12,
     tabBox(width = 12,
            tabPanel("Vis1",
                     uiVis(id)
            )
     )
   )
 )
}

uiVis <- function(id){

 ns <- NS(id)

 fluidPage(
   fluidRow(
     withSpinner(plotlyOutput(ns("gf")), type = 5, color = '#324155'),
     # plotlyOutput(ns("gf")),
     tags$hr(),
     withSpinner(dataTableOutput(ns("tbl")), type = 5, color = '#324155'),
     # dataTableOutput(ns("tbl")),
     tags$hr(),
     withSpinner(verbatimTextOutput(ns("txt")), type = 5, color = '#324155')
     # verbatimTextOutput(ns("txt"))
   )
 )


}

# MOD SERVER ------------------------------------------------------------------

modLoad <- function(input, output, session, load.go){

 observeEvent(input$loadUi, {
   load.go(TRUE)
 },ignoreInit = T)

}

modVis <- function(input, output, session, id2){

 src <- paste0("src_",id2)

 rv <- reactiveVal()

 data <- reactive({
   DATA %>% 
     mutate(out = ifelse(car %in% rv(), T, F))
 })

 eventClick <- reactive(event_data("plotly_click", source = src)) %>% debounce(500)
 observeEvent(eventClick(), {
   d <- eventClick()
   if(is_empty(d)) return()
   if (!is.null(d)) {
     x <- c(rv(), d %>% filter(!is.na(key)) %>% pull(key)) %>% unique()
     rv(x)
   }
 }, ignoreInit = T)

 eventSelect <- reactive(event_data("plotly_selected", source = src)) %>% debounce(500)
 observeEvent(eventSelect(), {
   d <- eventSelect()
   if(is_empty(d)) return()
   if (!is.null(d)) {
     x <- c(rv(), d %>% filter(!is.na(key)) %>% pull(key)) %>% unique()
     rv(x)
   }
 }, ignoreInit = T)

 output$gf <- renderPlotly({

   p <- ggplot() +
     geom_point(data = data(),
                aes_string(
                  x =  "mpg",
                  y = "hp",
                  key = "car",
                  color = "out",
                  shape = "out"
                )) +
     scale_shape_manual(values = c(1, 4)) +
     scale_alpha_manual(values = c(1, .4))


   p <- p %>% ggplotly(source = src) %>%
     layout(dragmode = "lasso") %>%
     layout(legend = list(x = 1.1, y = .9))

   return(p)

 })

 output$tbl <- renderDT({
   data() %>% filter(!(car %in% rv()))
 })

 output$txt <- renderText(rv())

}

##UI ----
ui <- dashboardPage(skin = "blue", title = "USMNT Session Planner (v2020.2)",
                       header = dashboardHeader(
                         title = "Test App"
                       ),
                       sidebar = dashboardSidebar(
                         sidebarMenu(
                           id = "tabs",
                           menuItem("Load", tabName = "load"),
                           menuItem("Vis", tabName = 'vis')
                         )
                       ),
                       body = dashboardBody(
                         tabItems(
                           tabItem("load",
                                   fluidPage(
                                     uiLoad("load")
                                   )
                           ),
                           tabItem('vis',
                                   fluidPage(
                                     column(width = 3, box(title = "Box Order",width = 12, verbatimTextOutput("boxOrder"))),
                                     column(width = 9,
                                       tags$div(id = 'id_placeholder')
                                     ),
                                     sortable_js(
                                       css_id = "id_placeholder",
                                       options = sortable_options(
                                         onSort = sortable_js_capture_input(input_id = "boxOrder"),
                                         onLoad = sortable_js_capture_input(input_id = "boxOrder")
                                       )
                                     )
                                   )
                           )
                         )
                       )
)


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

 load.go <- reactiveVal(FALSE)

 mod.list <- reactiveValues()

 callModule(modLoad, "load", load.go)

 observeEvent(load.go(), {

   if (!load.go()) return()
   updateTabItems(session, "tabs", selected = "vis")

   for (i in length(IDS):1){
     insertUI(immediate = TRUE, selector = "#id_placeholder",where = "afterBegin", ui = uiBox(id = IDS[i]))
     mod.list[[IDS[i]]] <- callModule(module = modVis, id = IDS[i], id2 = IDS[i])
   }

 }, ignoreInit = T)

 output$boxOrder <- renderPrint({

   str_split(input$boxOrder, "\n",simplify = T)[,1]

 })

}

shinyApp(ui, server)

软件包“ shinycssloaders”和“ sortable”的闪亮动态InsertUI问题

0 个答案: