Question

我尝试在R中创建一个类似的收件箱。我有一个消息数据框，我在DT libray和messageItem shinydashboard库的表中显示它。我希望当你点击表格中的一条消息时，将“leido”值改为TRUE。

我有这段代码

数据框

from <- c("A","B","C")
content <- c("Mensaje 1","Mensaje2","Mensaje leido")
leido <- c(FALSE,FALSE,TRUE)
messages <- data.frame(from,content,leido)

消息的DT :: datatableoutput

output$tablaMensajes <- DT::renderDataTable({
    messages
})

消息项输出

output$mensajes <- renderMenu({
    msgs <- apply(messages[which(messages$leido == FALSE),], 1, function(row) {
        messageItem(from = row[["from"]], message = row[["content"]],href = paste0("javascript:mensaje('",row[["content"]],"')"))
    })
     dropdownMenu(type = "messages", .list = msgs)
})

我在点击一行时发出一个观察事件，这会改变单元格的值，但当我在另一行中进行了更改时，更改不会保存。

观察事件

observe({
    if(! is.null(input$tablaMensajes_rows_selected)){
        messages
        s<-input$tablaMensajes_rows_selected
        messages[s,"leido"] = TRUE
        output$mensajes <- renderMenu({
        msgs <- apply(messages[which(messages$leido == FALSE),], 1, function(row) {
                messageItem(from = row[["from"]], message = row[["content"]],href = paste0("javascript:mensaje('",row[["content"]],"')"))
            })
            dropdownMenu(type = "messages", .list = msgs)
        })


    }
})

Answer 1

我修改了你的代码。我猜这是你想要的：

    library(shiny)
    library(shinydashboard)
    library(DT)

    from <- c("A","B","C")
    content <- c("Mensaje 1","Mensaje2","Mensaje leido")
    leido <- c(FALSE,FALSE,TRUE)
    messages <- data.frame(from,content,leido)

    ui <- dashboardPage(
      dashboardHeader(title = "Dynamic sidebar"),
      dashboardSidebar(
        sidebarMenuOutput("mensajes")
      ),
      dashboardBody( DT::dataTableOutput("tablaMensajes"))
    )


    server = function(input, output, session){

      output$tablaMensajes <- DT::renderDataTable({
        messages
      })


      output$mensajes <- renderMenu({
        msgs <- apply(messages[which(messages$leido == FALSE),], 1, function(row) {
          messageItem(from = row[["from"]], message = row[["content"]],href = paste0("javascript:mensaje('",row[["content"]],"')"))
        })
        dropdownMenu(type = "messages", .list = msgs)
      })

      observe({
        if(! is.null(input$tablaMensajes_rows_selected)){
          #browser()
          messages
          s<-input$tablaMensajes_rows_selected
          messages[s,"leido"] <<- TRUE
          output$mensajes <- renderMenu({
            msgs <- apply(messages[which(messages$leido == FALSE),], 1, function(row) {
              messageItem(from = row[["from"]], message = row[["content"]],href = paste0("javascript:mensaje('",row[["content"]],"')"))
            })
            dropdownMenu(type = "messages", .list = msgs)
          })


          output$tablaMensajes <- DT::renderDataTable({
            messages
          })


        }
      })

    }

    shinyApp(ui,server)


**[EDIT]:**

To remove subscript out of bound error I have edited the above code to add conditions if the no rows with false value is present then the message should be be empty. 

library(shiny)
library(shinydashboard)
library(DT)

from <- c("A","B","C")
content <- c("Mensaje 1","Mensaje2","Mensaje leido")
leido <- c(FALSE,FALSE,TRUE)
messages <- data.frame(from,content,leido)

ui <- dashboardPage(
  dashboardHeader(title = "Dynamic sidebar"),
  dashboardSidebar(
    sidebarMenuOutput("mensajes")
  ),
  dashboardBody( DT::dataTableOutput("tablaMensajes"))
)


server = function(input, output, session){

  output$tablaMensajes <- DT::renderDataTable({
    messages
  })


  output$mensajes <- renderMenu({
    if(nrow(messages[which(messages$leido == FALSE),]) >0) {
      msgs <- apply(messages[which(messages$leido == FALSE),], 1, function(row) {
        messageItem(from = row[["from"]], message = row[["content"]],href = paste0("javascript:mensaje('",row[["content"]],"')"))
      }) 
    }else{
      msgs = NULL
    }

    dropdownMenu(type = "messages", .list = msgs)
  })

  observe({
    if(! is.null(input$tablaMensajes_rows_selected)){
      #browser()
      messages
      s<-input$tablaMensajes_rows_selected
      messages[s,"leido"] <<- TRUE
      output$mensajes <- renderMenu({
        if(nrow(messages[which(messages$leido == FALSE),]) >0) {
        msgs <- apply(messages[which(messages$leido == FALSE),], 1, function(row) {
          messageItem(from = row[["from"]], message = row[["content"]],href = paste0("javascript:mensaje('",row[["content"]],"')"))
        })
        }else{
          msgs = NULL
        }
        dropdownMenu(type = "messages", .list = msgs)
      })


      output$tablaMensajes <- DT::renderDataTable({
        messages
      })


    }
  })

}

shinyApp(ui,server)

希望它有所帮助！

单击数据表时更改数据框的值

1 个答案: