r - 带有日期输入或下拉列表的闪亮可编辑 DT 表

Question

需要帮助，我有一个包含两行的表，即 date_time 和 Risk，我想要做的是用户可以直接在输出表 Shiny 上进行编辑，其中：

1. for Row Date_time 可以直接用 dateInput() 输入
2. 行风险可以通过带有选项 c('high', 'medium', 'low') 的下拉列表输入

这可能吗？

非常感谢您的帮助

library(tidyverse)
library(shiny)
library(DT)



mydata = data.frame(
  date_time = as.Date(c('30-12-2000', '30-12-1999', '30-12-1998'), format = '%d-%m-%Y'),
  risk = c('high', 'medium', 'low')
)

mydata_t <- t(mydata)


ui <- fluidPage(
  
  DTOutput(outputId = "final_tbl")
)

server <- function(input, output){
  df1 <- reactiveValues(data=NULL)
  dat <- reactive({
    mydata_t
  })
  
  observe({
    df1$data <- dat()
  })
  
  output$final_tbl <- renderDT({
    
    df1$data %>%
      datatable(editable = list(target = "cell", disable = list(columns = c(0))), options = list(paging = FALSE, searching = FALSE))
    
  })
  
  observeEvent(input$final_tbl_cell_edit, {
    info = input$final_tbl_cell_edit
    str(info)
    i = info$row
    j = info$col
    v = info$value
    
    
    df1$data[i, j] <<- (DT::coerceValue(v, df1$data[i, j]))
    ## I don't know what to write in here

  })
  
}

shinyApp(ui, server)

更新 ：

我修改了脚本参考示例，它现在可以工作了......谢谢

library(shiny)
library(DT)
library(dplyr)



data = data.frame(
  Observation = c('A', 'B', 'C', 'D', 'E', 'F', 'G')
)
  
  

if (interactive()) {
  ui <- fluidPage(
    DT::dataTableOutput('interface_table'),
    br(),
    actionButton("do", "Apply"),
    br(),
    hr(),
    tabsetPanel(
      tabPanel("contents", DT::dataTableOutput('contents')),
      tabPanel("it_contents", DT::dataTableOutput('it_contents'))
    ),
    br()    
  )
  
  server <- function(input, output, session) {
    
    output$contents <- DT::renderDataTable(
      data)
    
  
  
  # create a character vector of shiny inputs
  shinyInput <- function(FUN, len, id, ...) {
    inputs <- numeric(len)
    for (i in seq_len(len)) {
      inputs[i] <- as.character(FUN(paste0(id, i), label = NULL, ...))
    }
    inputs
  }
  
  # obtain the values of inputs
  shinyValue <- function(id, len) {
    unlist(lapply(seq_len(len), function(i) {
      value <- input[[paste0(id, i)]]
      if (is.null(value)) NA else value
    }))
  }
  
  
  
  it_df <- reactive({
    data.frame(
      Observation = c('A', 'B', 'C', 'D', 'E', 'F', 'G'),
      date_time = shinyInput(textInput, nrow(data),
                        "date1", value = NULL, width = "150px", placeholder = 'yyyy-mm-dd'),
      risk = shinyInput(selectInput, nrow(data),
                        'select_risk', choices = c('high', 'medium', 'low' ), width = "100px"),
      Nmonth = shinyInput(numericInput, nrow(data),
                        'number_month', value = 12,
                        width = '100%', min = 0, max = 12),
      stringsAsFactors = FALSE
    )
  })
  
  
  output$interface_table <- DT::renderDataTable(
    it_df(), rownames = FALSE, escape = FALSE, options = list(
      autoWidth = TRUE, scrollX = TRUE, #scrollY = '400px',
      dom = 't', ordering = FALSE,
      preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
      drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } '))
  )
  
  it_data <- reactive({
    if (input$do > 0) {
      dat <- data.frame(
        Observation = c('A', 'B', 'C', 'D', 'E', 'F', 'G'),
        year = substr(shinyValue('date1', nrow(data)), start = 1, stop = 4),
        date_time=shinyValue('date1', nrow(data)),
        risk = shinyValue('select_risk', nrow(data)),
        Nmonth = shinyValue('number_month', nrow(data)),
        weight = (12/ shinyValue('number_month', nrow(data)))
        
      )
      return(dat)
    }
    else { return() }
  })
  
  output$it_contents <- DT::renderDataTable(
    it_data(),  options = list( dom = 't', ordering = FALSE),
    rownames = TRUE, selection = 'none')
  }
}


shinyApp(ui, server)

标签： rshiny