让用户在 R Shiny 中编辑数据表变量名称

Question

我正在构建一个 R Shiny 应用程序，用户在其中选择数据表中的列，然后该应用程序返回所选变量的列表。我希望用户能够更改应用程序中变量/列的名称。

我使用 DT 制作了这个交互式表格。我从 this post 上的 Stéphane Laurent 的回答中获得了更改列标题的代码。

虽然列选择和可编辑列名在 DT 表中都可以正常工作，但问题是更改变量名只会编辑显示的表，而原始数据框仍保留其原始列名。我希望当用户在应用程序中编辑变量名称时，它会更改实际数据框中的变量名称。我如何做到这一点？

每次用户更改列名时，我都在考虑使用 observeEvent() 来更改列名，但由于 Stéphane Laurent 给出的方法使用 JS，我不太确定该怎么做。

(screenshot of the app here; 我已经更改了 2 个选定列的列名，但原始数据框尚未更新。)

library(shiny)
library(DT)

getlist <- function(df, colnums){
  data <- df
  if(length(colnums)==1){
    column_names <- colnames(data)[colnums]
  } else{
    selected_data <- data[,colnums]
    column_names <- colnames(selected_data)
  }
  return(column_names)
}

callback <- c(
  "table.on('dblclick.dt', 'thead th', function(e) {",
  "  var $th = $(this);",
  "  var index = $th.index();",
  "  var colname = $th.text(), newcolname = colname;",
  "  var $input = $('<input type=\"text\">')",
  "  $input.val(colname);",
  "  $th.empty().append($input);",
  "  $input.on('change', function(){",
  "    newcolname = $input.val();",
  "    if(newcolname != colname){",
  "      $(table.column(index).header()).text(newcolname);",
  "    }",
  "    $input.remove();",
  "  }).on('blur', function(){",
  "    $(table.column(index).header()).text(newcolname);",
  "    $input.remove();",
  "  });",
  "});"
)


ui <- fluidPage(
  
  DTOutput("table"),
  textOutput('preview'),
  tableOutput('table2')
  
)

server <- function(input, output){
  
  data <- reactiveVal(iris)

  output[["table"]] <- renderDT({
    datatable(data(), selection = list(target = 'column'), options= list(ordering = FALSE, pageLength = 25), callback = JS(callback))
  })  
  
  #selected columns of the tables
  vlist <- reactive(c(getlist(data(),input$table_columns_selected)))
  
  #display list of selected variables
  output$preview <- renderText(paste(c('Selected variables :', vlist()), collapse=' '))
  
  output$table2 <- renderTable({data()})
  
}

shinyApp(ui, server)

Answer 1

您可以使用Shiny.setInputValue() 将消息从JS 发送到shiny 并生成输入值。我使用它来将新旧列名从 JS 函数发送到 input$change_colname。然后您可以使用observeEvent 更新您的数据。在您的情况下，我将使用用于渲染 table 和 table2 的不同对象，因为现在 table 在列名更改后随着基础 data() 的更新而重新渲染：

library(shiny)
library(DT)

getlist <- function(df, colnums){
  data <- df
  if(length(colnums)==1){
    column_names <- colnames(data)[colnums]
  } else{
    selected_data <- data[,colnums]
    column_names <- colnames(selected_data)
  }
  return(column_names)
}

callback <- c(
  "table.on('dblclick.dt', 'thead th', function(e) {",
  "  var $th = $(this);",
  "  var index = $th.index();",
  "  var colname = $th.text(), newcolname = colname;",
  "  var $input = $('<input type=\"text\">')",
  "  $input.val(colname);",
  "  $th.empty().append($input);",
  "  $input.on('change', function(){",
  "    newcolname = $input.val();",
  "    if(newcolname != colname){",
  "      $(table.column(index).header()).text(newcolname);",
  "      Shiny.setInputValue('change_colname', [colname, newcolname]);",
  "    }",
  "    $input.remove();",
  "  }).on('blur', function(){",
  "    $(table.column(index).header()).text(newcolname);",
  "    $input.remove();",
  "  });",
  "});"
)


ui <- fluidPage(
  
  DTOutput("table"),
  textOutput('preview'),
  tableOutput('table2')
  
)

server <- function(input, output){
  
  data <- reactiveVal(iris)
  vlist <- reactiveVal()
  
  output[["table"]] <- renderDT({
    datatable(data(), selection = list(target = 'column'), options= list(ordering = FALSE, pageLength = 25), callback = JS(callback))
  })  
  
  #selected columns of the tables
  observeEvent(input$table_columns_selected, {
    vlist(getlist(data(),input$table_columns_selected))
  })
  
  # update column names
  observeEvent(input$change_colname, {
    old_colnames <- vlist()
    old_colnames[old_colnames == input$change_colname[1]] <- input$change_colname[2]
    vlist(old_colnames)
    
    # update the data
    old_data <- data()
    colnames(old_data)[colnames(old_data) == input$change_colname[1]] <-
      input$change_colname[2]
    data(old_data)
  })
  
  #display list of selected variables
  output$preview <- renderText(paste(c('Selected variables :', vlist()), collapse=' '))
  
  output$table2 <- renderTable({data()})
  
  output$changed_var <- renderPrint({input$change_colname})
  
}

shinyApp(ui, server)