Question

我已编写此代码，以便为动态创建的元素的输入添加书签。

正如您所看到的，我已经设法通过第一个表（output $ othertable）来实现了，但是没有使用output $ ratings来实现。这是因为renderUI吗？

我找到了这个https://github.com/rstudio/shiny/pull/2139，所以我安装了最新的package来克服这个问题。

不幸的是，这不是解决方案。

任何想法？

library(shiny)
library(shinydashboard)
library(htmlwidgets) 
library(data.table) 

ui <- function(request){dashboardPage(

  skin="blue",

  dashboardHeader(
    title="sth",
    titleWidth = 300),

  dashboardSidebar(
    width = 300,
    sidebarMenu(
      menuItem(
        "Gathering Information",
        tabName = "gatheringinformation",
        icon=icon("github")
      )
      )),


  dashboardBody(

      tabItem(tabName = "gatheringinformation",
              h2("Gathering Information"),

              bookmarkButton(),
              fluidRow(
                box(
                  width = 4, 
                  title = "Inputs",
                  status= "primary",
                  solidHeader = TRUE,
                  h5("Please specify the number of alternatives, criteria and experts"),

                  numericInput("alternatives", h3("Alternatives"), 
                               value = "1"),
                  numericInput("criteria", h3("Criteria"), 
                               value = "1"),
                  numericInput("experts", h3("Experts"), 
                               value = "1")  
                ),

      box(title = "Alternatives", 
          width = 4,
          status = "primary", 
          solidHeader = TRUE,
          collapsible = TRUE,
          div(style = 'overflow-x: scroll'),
          splitLayout(tableOutput("othertable"))

      ),

      box(title = "View Data", 
          width = 12,
          status = "primary", 
          solidHeader = TRUE,
          collapsible = TRUE,
          div(style = 'overflow-x: scroll'),
          splitLayout(uiOutput("ratings"))

      ))


                        )))}
              ####################################
              ############   SERVER   ############
              ####################################

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


  onBookmark(function(state) {
    for (i in 1:input$alternatives){
      state$values$alternativestable[i] <- input[[paste0("data_alternatives_r",i,"c1")]]}
    for (i in 1:input$criteria){
      state$values$criteriatable[i] <- input[[paste0("data_criteria_r",i,"c1")]]}

    someData <- rep(NaN, input$alternatives*input$criteria*input$experts);  
    state$values$viewdatatable<-array(someData, c(input$alternatives, input$criteria, input$experts))

    for (i in 1:input$experts){
      for (m in 1:input$criteria){
        for (n in 1:input$alternatives){
          state$values$viewdatatable[n,m,i] <- input[[paste0("t",i,"r",n,"c",m)]]
          l<-state$values$viewdatatable[n,m,i]<-input[[paste0("t1r1c1")]]
        }}
    }
  })

  onRestore(function(state) {

    for (i in 1:input$alternatives){
      Y <- state$values$alternativestable[i]
      updateNumericInput(session, paste0("data_alternatives_r",i,"c1"), value = Y)
    }

    for (i in 1:input$experts){
      for (m in 1:input$criteria){
        for (n in 1:input$alternatives){
          Y <- state$values$viewdatatable[n,m,i]
          updateNumericInput(session, paste0("t",i,"r",n,"c",m), value = Y)

        }}}



  })

  isolate({
    output$othertable <- 
      renderTable({
        text.inputs.col1 <- paste0("<input id='data_alternatives_r", 1:input$alternatives, "c", 1, "' class='shiny-bound-input' type='text' value=''>")
        df_data_alternatives <- data.frame(text.inputs.col1)
        colnames(df_data_alternatives) <- paste0("Alternatives")
        df_data_alternatives
      },sanitize.text.function = function(x) x)})
  isolate({
  output$ratings <- renderUI({lapply(1:input$experts,function(j){
    renderTable({
      num.inputs.col1 <- paste0("<input id='t",j, "r", 1:input$alternatives, "c", 1, "' class='shiny-bound-input' type='number' value='1'>")
      #num.inputs.col2 <- paste0("<input id='t",j, "r", 1:input$alternatives, "c", 2, "' class='shiny-bound-input' type='number' value='1'>")
      df <- data.frame(num.inputs.col1)
      if (input$criteria >= 2){
        for (i in 2:input$criteria){
          num.inputs.coli <- paste0("<input id='t",j, "r", 1:input$alternatives, "c", i, "' class='shiny-bound-input' type='number' value='1'>")
          df <- cbind(df,num.inputs.coli)
        }
      }
      colnames(df) <- paste0("Criteria ",as.numeric(1:input$criteria))
      rownames(df) <- paste0("Alternative ",as.numeric(1:input$alternatives))
      df
    },align = 'c',rownames = TRUE,caption = paste("Expert " ,j), caption.placement = getOption("xtable.caption.placement", "top"), sanitize.text.function = function(x) x)})})
})
}
# Run the application 
shinyApp(ui = ui, server = server,enableBookmarking = "url")

Answer 1

经过一些测试，我发现延迟呼叫updateNumericInput可以解决问题。显然，在调用相应的numericInput函数时，update元素尚未呈现。这意味着state的一部分将丢失。

我在shinyjs::delay回调函数周围使用了onRestore，该回调函数根据状态恢复ui。回调将等待200毫秒，然后触发updateNumericInput

## in server - onRestore
shinyjs::delay(200, {

  for (i in 1:input$experts){
    for (m in 1:input$criteria){
      for (n in 1:input$alternatives){
        Y <- state$values$viewdatatable[n,m,i]
        updateNumericInput(session, paste0("t",i,"r",n,"c",m), value = Y)

      }}}
})

这似乎给renderUI提供了足够的时间在调用updateNumericInput之前呈现表。如果您想应用此修复程序，请不要忘记在用户界面的某个地方使用shinyjs::useShinyjs()。

RenderUI的闪亮书签问题

1 个答案: