如何在闪亮的反应式数据表中添加注释

Question

这个问题是我张贴的问题的延伸： 这个问题

我创建了一个包含3列的数据框：num，id和val。 我希望我的闪亮应用程序执行以下操作：

1. 数据框dat按num列过滤
2. 从dat （selectInput）的id列中选择一个值。
3. 在文本框中添加文本注释（textInput）
4. 点击一个动作按钮
5. 数据表中将创建一个称为注释的新列，文本注释将添加到id等于所选值的行的注释列中。

代码如下。 我不知道为什么它不起作用。

在此先多谢！

    library(shiny)
    library(DT)
    dat = data.frame(num=rep(1:2, each=5), id=rep(LETTERS[1:5],2), val=rnorm(10)) 
    ui = fluidPage(
        fluidRow(
            column(12, selectInput('selectNum', label='Select Num', 
                                 choices=1:10, selected='')),
            column(2, selectInput(inputId = 'selectID',
                                  label = 'Select ID2',
                                  choices = LETTERS[1:10],
                                  selected='',
                                  multiple=TRUE)),
            column(6, textInput(inputId = 'comment', 
                                label ='Please add comment in the text box:', 
                                value = "", width = NULL,
                                placeholder = NULL)),
            column(2, actionButton(inputId = "button", 
                                   label = "Add Comment"))
        ),
        fluidRow (
            column(12, DT::dataTableOutput('data') ) 
        )           
    )

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

     ## make df reactive

     df = reactive ({ dat %>% filter(num %in% input$selectNum) })
     df_current <- reactiveVal(df())

     observeEvent(input$button, {

      req(df_current())

      ## update df by adding comments
      df_new <- df_current()
      df_new[df_current()$id %in% input$selectID, "Comment"] <- input$comment

      df_current(df_new)

      })

      output$data <- DT::renderDataTable({

      req(df_current())

      DT::datatable(df_current(), 
          options = list(orderClasses = TRUE,
              lengthMenu = c(5, 10, 20), pageLength = 5))
     })

    shinyApp(ui=ui, server=server)

Answer 1

而不是使用一个反应/ eventReactive声明df ，它可能是更自然地跟踪在先前输入的评论Comment使用了reactiveVal对象列df 。 另请参见以下问题的答案： R Shiny：reactValues与react 。 如果你喜欢使用反应/ eventReactive语句df它可能是更好地与一个单独的对象合作，以存储以前输入的意见（而不是将它纳入了反应声明df ）。

library(shiny)
library(DT)
dat = data.frame(num=1:10, id=LETTERS[1:10], val=rnorm(10)) 
ui = fluidPage(
    fluidRow(
        column(12, selectInput('selectNum', label='Select Num', 
                choices=1:10)),
        column(2, selectInput(inputId = 'selectID',
                label = 'Select ID2',
                choices = LETTERS[1:10],
                selected='',
                multiple=TRUE)),
        column(6, textInput(inputId = 'comment', 
                label ='Please add comment in the text box:', 
                value = "", width = NULL,
                placeholder = NULL)),
        column(2, actionButton(inputId = "button", 
                label = "Add Comment"))
    ),
    fluidRow (
        column(12, DT::dataTableOutput('data') ) 
    )            
)

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

  ## make df reactive
  df_current <- reactiveVal(dat)

  observeEvent(input$button, {

        req(df_current(), input$selectID %in% dat$id)

        ## update df by adding comments
        df_new <- df_current()
        df_new[df_current()$id %in% input$selectID, "Comment"] <- input$comment

        df_current(df_new)

      })

  output$data <- DT::renderDataTable({

        req(df_current())

        ## filter df_current by 'selectNum'
        df_filtered <- df_current()[df_current()$num %in% input$selectNum, ]

        ## show comments if non-empty
        showComments <- is.null(df_filtered$Comment) || !all(is.na(df_filtered$Comment))

        DT::datatable(df_filtered, 
            options = list(orderClasses = TRUE,
                lengthMenu = c(5, 10, 20), pageLength = 5,
                columnDefs = list(
                    list(targets = ncol(df_filtered), visible = showComments)
                )
            )
        )

      })
}

shinyApp(ui=ui, server=server)

---

编辑：在经过编辑的server函数下面，该函数使用df_current <- reactive({...})而不是df_current <- reactiveVal({...})并定义一个单独的df_current <- reactiveVal({...})对象以跟踪注释。

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

  ## initialize separate reactive object for comments
  df_comments <- reactiveVal({
        data.frame(
            id = character(0), 
            Comment = character(0),
            stringsAsFactors = FALSE
        )
      })

  ## reactive object df
  df_current <- reactive({

        ## reactivity that df depends on
        ## currently df = dat does not change
        df <- dat

        ## merge with current comments
        if(nrow(df_comments()) > 0)
        df <- merge(df, df_comments(), by = "id", all.x = TRUE)

        return(df)

      })

  observeEvent(input$button, {

        req(input$selectID)

        ## update df_comments by adding comments
        df_comments_new <- rbind(df_comments(), 
            data.frame(id = input$selectID, Comment = input$comment)
        )

        ## if duplicated id's keep only most recent rows 
        df_comments_new <- df_comments_new[!duplicated(df_comments_new$id, fromLast = TRUE), , drop = FALSE]

        df_comments(df_comments_new)

      })

  output$data <- DT::renderDataTable({

        req(df_current())

        ## filter df_current by 'selectNum'
        df_filtered <- df_current()[df_current()$num %in% input$selectNum, ]

        ## show comments if non-empty
        showComments <- is.null(df_filtered$Comment) || !all(is.na(df_filtered$Comment))

        DT::datatable(df_filtered, 
            options = list(orderClasses = TRUE,
                lengthMenu = c(5, 10, 20), pageLength = 5,
                columnDefs = list(
                    list(targets = ncol(df_filtered), visible = showComments)
                )
            )
        )

      })
}

Answer 2

那里有一个有效的例子。

我认为问题是您正在尝试通过observeEvent更新值，根据文档所述，这不是很好。 ？observeEvent

每当您想执行响应事件的操作时，请使用observeEvent。 （请注意，“重新计算值”通常不算是执行操作-有关此信息，请参阅eventReactive。）

library(shiny)
library(DT)
dat = data.frame(num=1:10, id=LETTERS[1:10], val=rnorm(10)) 
ui = fluidPage(
  fluidRow(
    column(12, selectInput('selectNum', label='Select Num', 
                           choices=1:10, selected='')),
    column(2, selectInput(inputId = 'selectID',
                          label = 'Select ID2',
                          choices = LETTERS[1:10],
                          selected='',
                          multiple=TRUE)),
    column(6, textInput(inputId = 'comment', 
                        label ='Please add comment in the text box:', 
                        value = "", width = NULL,
                        placeholder = NULL)),
    column(2, actionButton(inputId = "button", 
                           label = "Add Comment"))
  ),
  fluidRow (
    column(12, DT::dataTableOutput('data') ) 
  )           
)

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

  ## make df reactive

  df_current = reactive({ 
    df = dat %>% filter(num %in% input$selectNum) 

    if(input$button != 0) {
      input$button    
      df[df$id %in% input$selectID, "Comment"] <- isolate(input$comment)
    }

    return(df)
    })


  output$data <- DT::renderDataTable({

    req(df_current())
    DT::datatable(df_current(), 
                  options = list(orderClasses = TRUE,
                                 lengthMenu = c(5, 10, 20), pageLength = 5))
  })
}
  shinyApp(ui=ui, server=server)

因此，您可以使用反应性值，也可以按照文档中所述使用eventReactive。