DataTable更新后重新绑定SelectInput

问题描述 投票：0回答：1

所以我目前正在尝试创建一个闪亮的应用程序，它允许用户选择与条目关联的类别，更改它，并将此更改直接写入相应的数据库中。为此，我使用 

RMySQL
和 
DT
库来配置每行上显示的选择输入以及可供选择的所有类别，以及“更新数据”按钮来确认更改并执行 SQL 查询来写入它们进入数据库。

但是，该应用程序似乎仅在启动应用程序后第一次使用“更新数据”按钮时才能工作。据我所知，它似乎与选择输入 ids 相关：它们是在 DataTable 初始化时首先定义的（例如“single_input6”与行“ID：6”相关联），然后以相同的方式重新创建单击“更新数据”按钮后更新数据表时的方式。但是，与这些输入关联的值与第一次单击“更新数据”按钮时选择的值保持相同。

可能是 id 仍然绑定到它们的初始值，或者初始 DataTable 没有被新的 DataTable 替换，因此仍然存在。但我不知道到底是什么导致了这个问题或如何解决它。

下面的图片显示了应用程序如何工作 (1.、2.)、不工作的地方 (3.) 以及是什么让我认为 id 未正确绑定 (4.) :

1.该应用程序首次启动

2.选择“Egyptien”作为行 ID：6 并单击“更新数据”后的应用程序

3.然后为行 ID 选择“Grec”：6 并单击“更新数据”（没有任何更改）后的应用程序

4。用于调试的控制台打印。第一个“Egyptien”是在2.图像更新时显示的，第二个“Egyptien”是在3.图像更新时显示的

以下是创建 MySQL 虚拟数据库的 SQL 查询，用作示例：

### Initialize the two MySQL Databases used in the code
# The Databases are not important in themselves but are handy to test and tinker what I need

CREATE TABLE Z_TEST (ID INT PRIMARY KEY NOT NULL, Divinite VARCHAR(20), ID_pantheon INT);
CREATE TABLE Z_TEST2 (id_pantheon INT PRIMARY KEY NOT NULL, nom_pantheon VARCHAR(20));

INSERT INTO Z_TEST VALUES 
(1, "Quetzalcoatl", 5), 
(2, "Odin", 3), 
(3, "Ra", 2),
(4, "Zeus", 1),
(5, "Tiamat", 4),
(6, "Isis", 0),
(7, "Hades", 0),
(8, "Thot", 0),
(9, "Thor", 0),
(10, "Persephone", 0),
(11, "Amatsu", 0);

INSERT INTO Z_TEST2 VALUES 
(1, "Grec"), 
(2, "Egyptien"), 
(3, "Nordique"),
(4, "Sumerien"),
(5, "Azteque"),
(6, "Japonais");


### Display each Database and their join

SELECT * FROM Z_TEST;
SELECT * FROM Z_TEST2;

SELECT ID, Divinite, Z_TEST.ID_pantheon, nom_pantheon FROM Z_TEST LEFT JOIN Z_TEST2 ON Z_TEST.ID_pantheon = Z_TEST2.id_pantheon;

这是用于 Shiny 应用程序的 R 代码：

### Libraries

{
  library(shiny)            # used to create the Shiny App
  library(bslib)            # used to create the Shiny App
  
  library(RMySQL)           # used to access the Database
  library(lares)            # used to import logins for the Database
  
  library(tidyverse)        # used for many things (mainly data manipulation)
  library(DT)               # used for creating interactive DataTable
  # library(DTedit)           # used for better editing of DataTable (judged not enought intuitive for the user)
}


### JS Module for keyboard shortcut (Not Important)
# Allows the use of arrow keys to move from cell to celle and the Enter key to confirm an edit

js <- c(
  "table.on('key', function(e, datatable, key, cell, originalEvent){",
  "  var targetName = originalEvent.target.localName;",
  "  if(key == 13 && targetName == 'body'){",
  "    $(cell.node()).trigger('dblclick.dt');",
  "  }",
  "});",
  "table.on('keydown', function(e){",
  "  var keys = [9,13,37,38,39,40];",
  "  if(e.target.localName == 'input' && keys.indexOf(e.keyCode) > -1){",
  "    $(e.target).trigger('blur');",
  "  }",
  "});",
  "table.on('key-focus', function(e, datatable, cell, originalEvent){",
  "  var targetName = originalEvent.target.localName;",
  "  var type = originalEvent.type;",
  "  if(type == 'keydown' && targetName == 'input'){",
  "    if([9,37,38,39,40].indexOf(originalEvent.keyCode) > -1){",
  "      $(cell.node()).trigger('dblclick.dt');",
  "    }",
  "  }",
  "});"
)


### Queries (Not Important)

QDisplay <- "
  SELECT ID, Divinite, Z_TEST.ID_pantheon, nom_pantheon 
  FROM Z_TEST LEFT JOIN Z_TEST2 ON Z_TEST.ID_pantheon = Z_TEST2.id_pantheon
"

QEdit <- "
  UPDATE Z_TEST
  SET %s = '%s'
  WHERE ID = %d
"

QRef <- "
  SELECT nom_pantheon FROM Z_TEST2
"

### --- YOU MUST EDIT THE FOLLOWING PART BEFORE RUNNING THE CODE --- ###

### Database Connection (Important)

# Connect to a MySQL Database using appropriate credentials, then close the connection
# IMPORTANT : Requires a config.yml file to be setup with corresponding credentials if you want to use the get_creds function as is
# Otherwise, you can simply replace the get_creds("cirrina_as")$[...] by putting the plain-text credentials in their place

mydbGetQuery <- function(Query) {
  
  DB <- dbConnect (
    MySQL(),
    dbname = get_creds("dummy_db")$dbname,
    host = get_creds("dummy_db")$host,
    user = get_creds("dummy_db")$user,
    password = get_creds("dummy_db")$password
  )
  data <- dbGetQuery(DB, Query)
  dbDisconnect(DB)
  
  return(data)
}


### Automatic generation of row Select Input (somewhat Important)

# Create levels to choose from in the Select Input
factorOptions <- function(select_factors) {
  a <- ""
  for (i in select_factors) {
    a <- paste0(a, '<option value="', i, '">', i, '</option>\n')}
  
  return(a)
}

# Create the Select Input with ID and corresponding entry from the joined table
mySelectInput <- function(selected_factor, select_factors) {
  b <- c()
  
  for (j in 1:length(selected_factor)) {
    b <- c(b, paste0('<select id="single_select', j, '"style="width: 100%;">\n', 
                     sprintf('<option value="%s" selected>%s</option>\n', selected_factor[j], selected_factor[j]), 
                     factorOptions(select_factors), '</select>'))
  }
  return(b)
}

# Get the reference levels for the Select Input 
panth_level <- mydbGetQuery(QRef) %>% as_tibble() %>% pull(nom_pantheon)


### Shiny App (Important)

shinyApp(
  ui = fluidPage(
    DTOutput('interactiveTable'),
    actionButton("updateButton", "Update Data")
  ),
  
  server = function(input, output, session) {
    
    # Fetch the underlying data
    panth_data <- reactiveVal()
    observe(panth_data(mydbGetQuery(QDisplay) %>% as_tibble()))
    
    # Initialize the DataTable
    output$interactiveTable <- renderDT({
      datatable(data = bind_cols(panth_data(), tibble(Test = mySelectInput(panth_data()$nom_pantheon, panth_level))), 
                selection = 'none', escape = FALSE, rownames = FALSE, editable = list(target = 'cell', disable = list(columns = c(0, 2))),
                callback = JS(js), extensions = "KeyTable", 
                options = list(
                  keys = TRUE,
                  preDrawCallback = JS('function(){Shiny.unbindAll(this.api().table().node());}'),
                  drawCallback = JS('function(){Shiny.bindAll(this.api().table().node());}')
                )
      )
    })
    
    # If the button is clicked, apply the changes made with the Select Input directly to the database
    # Note : for now, only the sixth row (ID : 6, Divinite : Isis) is made responsive to any change done with selectors
    # Changing the "6" of "single_select6" and "sprintf(QEdit, "ID_pantheon", i, 6)" for another number will make another entry
    # responsive instead
    
    observeEvent(input$updateButton, {
      # for debug
      print(input$single_select6)
      
      # Fetch the corresponding ID of the selected pantheon and update the database
      i <- mydbGetQuery(sprintf("SELECT id_pantheon FROM Z_TEST2 WHERE nom_pantheon = '%s'", as.character(input$single_select6)))$id_pantheon
      mydbGetQuery(sprintf(QEdit, "ID_pantheon", i, 6))
      
      # Update the Datable
      output$interactiveTable <- renderDT({
        updated_data <- mydbGetQuery(QDisplay) %>% as_tibble()
        datatable(data = bind_cols(updated_data, tibble(Test = mySelectInput(updated_data$nom_pantheon, panth_level))),
                  selection = 'none', escape = FALSE, rownames = FALSE, editable = list(target = 'cell', disable = list(columns = c(0, 2))),
                  callback = JS(js), extensions = "KeyTable", options = list(
                    keys = TRUE,
                    preDrawCallback = JS('function(){Shiny.unbindAll(this.api().table().node());}'),
                    drawCallback = JS('function(){Shiny.bindAll(this.api().table().node());}'))
        )
      })
    })
    
    
    ### Attempt to edit the Data everytime the input is modified rather than waiting for a Button input
    
    # observeEvent(input$single_select6, {
    #   print(input$single_select6)
    #   
    #   i <- mydbGetQuery(sprintf("SELECT id_pantheon FROM Z_TEST2 WHERE nom_pantheon = '%s'", as.character(input$single_select6)))$id_pantheon
    #   mydbGetQuery(sprintf(QEdit, "ID_pantheon", i,
    #                        # d6()[input$x6_cell_edit$row,]$ID
    #                        6
    #   ))
    #   
    #   output$x6 <- renderDT({
    #     updated_data <- mydbGetQuery(QDisplay) %>% as_tibble()
    #     datatable(data = bind_cols(updated_data, tibble(Test = test2(updated_data$nom_pantheon, d))),
    #               selection = 'none', escape = FALSE, rownames = FALSE, editable = list(target = 'cell', disable = list(columns = c(0, 2))),
    #               callback = JS(js), extensions = "KeyTable", options = list(keys = TRUE))
    #   })
    #   
    #   reset("single_select6")
    # })
  }
)

重要提示：

  • 必须首先创建 SQL 虚拟数据库，代码才能正常工作
  • 您必须编辑“mydbGetQuery”函数，将其中的凭据替换为 config.yml 文件中与 MySQL 数据库关联的凭据（如果您打算使用 
    lares
    ）或直接使用纯文本凭据（最简单的选项） )
  • 仅行 ID : 6、Divinite : Isis 可以通过更改选择输入值然后单击“更新数据”来更新。这是设计使然，首先调试单行。
  • 再次关闭并启动应用程序将使第一个新更新生效，然后再次返回相同的结果
javascript r shiny dt
1个回答
0
投票

感谢 Stéphane Laurent 的评论，我能够找到一段代码，允许我在每次单击“更新数据”按钮时解除绑定 id。将其添加到代码开头定义的“js”对象后（这实际上很重要，与我最初的想法相反），我得到了我想做的事情。

这是一些代码：

  "$('#updateButton').on('click', function() {",
  "  Shiny.unbindAll(table.table().node());",
  "});"

这是完整的代码：

### Libraries

{
  library(shiny)            # used to create the Shiny App
  library(bslib)            # used to create the Shiny App
  
  library(RMySQL)           # used to access the Database
  library(lares)            # used to import logins for the Database
  
  library(tidyverse)        # used for many things (mainly data manipulation)
  library(DT)               # used for creating interactive DataTable
  # library(DTedit)           # used for better editing of DataTable (judged not enought intuitive for the user)
}


### JS Module for keyboard shortcut (Not Important)
# Allows the use of arrow keys to move from cell to celle and the Enter key to confirm an edit

js <- c(
  "table.on('key', function(e, datatable, key, cell, originalEvent){",
  "  var targetName = originalEvent.target.localName;",
  "  if(key == 13 && targetName == 'body'){",
  "    $(cell.node()).trigger('dblclick.dt');",
  "  }",
  "});",
  "table.on('keydown', function(e){",
  "  var keys = [9,13,37,38,39,40];",
  "  if(e.target.localName == 'input' && keys.indexOf(e.keyCode) > -1){",
  "    $(e.target).trigger('blur');",
  "  }",
  "});",
  "table.on('key-focus', function(e, datatable, cell, originalEvent){",
  "  var targetName = originalEvent.target.localName;",
  "  var type = originalEvent.type;",
  "  if(type == 'keydown' && targetName == 'input'){",
  "    if([9,37,38,39,40].indexOf(originalEvent.keyCode) > -1){",
  "      $(cell.node()).trigger('dblclick.dt');",
  "    }",
  "  }",
  "});",
  "$('#updateButton').on('click', function() {",
  "  Shiny.unbindAll(table.table().node());",
  "});"
)


### Queries (Not Important)

QDisplay <- "
  SELECT ID, Divinite, Z_TEST.ID_pantheon, nom_pantheon 
  FROM Z_TEST LEFT JOIN Z_TEST2 ON Z_TEST.ID_pantheon = Z_TEST2.id_pantheon
"

QEdit <- "
  UPDATE Z_TEST
  SET %s = '%s'
  WHERE ID = %d
"

QRef <- "
  SELECT nom_pantheon FROM Z_TEST2
"

### --- YOU MUST EDIT THE FOLLOWING PART BEFORE RUNNING THE CODE --- ###

### Database Connection (Important)

# Connect to a MySQL Database using appropriate credentials, then close the connection
# IMPORTANT : Requires a config.yml file to be setup with corresponding credentials if you want to use the get_creds function as is
# Otherwise, you can simply replace the get_creds("cirrina_as")$[...] by putting the plain-text credentials in their place

mydbGetQuery <- function(Query) {
  
  DB <- dbConnect (
    MySQL(),
    dbname = get_creds("cirrina_as")$dbname,
    host = get_creds("cirrina_as")$host,
    user = get_creds("cirrina_as")$user,
    password = get_creds("cirrina_as")$password
  )
  data <- dbGetQuery(DB, Query)
  dbDisconnect(DB)
  
  return(data)
}


### Automatic generation of row Select Input (somewhat Important)

# Create levels to choose from in the Select Input
factorOptions <- function(select_factors) {
  a <- ""
  for (i in select_factors) {
    a <- paste0(a, '<option value="', i, '">', i, '</option>\n')}
  
  return(a)
}

# Create the Select Input with ID and corresponding entry from the joined table
mySelectInput <- function(selected_factor, select_factors) {
  b <- c()
  
  for (j in 1:length(selected_factor)) {
    b <- c(b, paste0('<select id="single_select', j, '"style="width: 100%;">\n', 
                     sprintf('<option value="%s" selected>%s</option>\n', selected_factor[j], selected_factor[j]), 
                     factorOptions(select_factors), '</select>'))
  }
  return(b)
}

# Get the reference levels for the Select Input 
panth_level <- mydbGetQuery(QRef) %>% as_tibble() %>% pull(nom_pantheon)


### Shiny App (Important)

shinyApp(
  ui = fluidPage(
    DTOutput('interactiveTable'),
    actionButton("updateButton", "Update Data")
  ),
  
  server = function(input, output, session) {
    
    # Fetch the underlying data
    panth_data <- reactiveVal()
    observe(panth_data(mydbGetQuery(QDisplay) %>% as_tibble()))
    
    # Initialize the DataTable
    output$interactiveTable <- renderDT({
      datatable(data = bind_cols(panth_data(), tibble(Test = mySelectInput(panth_data()$nom_pantheon, panth_level))), 
                selection = 'none', escape = FALSE, rownames = FALSE, editable = list(target = 'cell', disable = list(columns = c(0, 2))),
                callback = JS(js), extensions = "KeyTable", 
                options = list(
                  keys = TRUE,
                  preDrawCallback = JS('function(){Shiny.unbindAll(this.api().table().node());}'),
                  drawCallback = JS('function(){Shiny.bindAll(this.api().table().node());}')
                )
      )
    })
    
    # If the button is clicked, apply the changes made with the Select Input directly to the database
    # Note : for now, only the sixth row (ID : 6, Divinite : Isis) is made responsive to any change done with selectors
    # Changing the "6" of "single_select6" and "sprintf(QEdit, "ID_pantheon", i, 6)" for another number will make another entry
    # responsive instead
    
    observeEvent(input$updateButton, {
      # for debug
      print(input$single_select6)
      
      # Fetch the corresponding ID of the selected pantheon and update the database
      i <- mydbGetQuery(sprintf("SELECT id_pantheon FROM Z_TEST2 WHERE nom_pantheon = '%s'", as.character(input$single_select6)))$id_pantheon
      mydbGetQuery(sprintf(QEdit, "ID_pantheon", i, 6))
      
      # Update the Datable
      output$interactiveTable <- renderDT({
        updated_data <- mydbGetQuery(QDisplay) %>% as_tibble()
        datatable(data = bind_cols(updated_data, tibble(Test = mySelectInput(updated_data$nom_pantheon, panth_level))),
                  selection = 'none', escape = FALSE, rownames = FALSE, editable = list(target = 'cell', disable = list(columns = c(0, 2))),
                  callback = JS(js), extensions = "KeyTable", options = list(
                    keys = TRUE,
                    preDrawCallback = JS('function(){Shiny.unbindAll(this.api().table().node());}'),
                    drawCallback = JS('function(){Shiny.bindAll(this.api().table().node());}'))
        )
      })
    })
    
    
    ### Attempt to edit the Data everytime the input is modified rather than waiting for a Button input
    
    # observeEvent(input$single_select6, {
    #   print(input$single_select6)
    #   
    #   i <- mydbGetQuery(sprintf("SELECT id_pantheon FROM Z_TEST2 WHERE nom_pantheon = '%s'", as.character(input$single_select6)))$id_pantheon
    #   mydbGetQuery(sprintf(QEdit, "ID_pantheon", i,
    #                        # d6()[input$x6_cell_edit$row,]$ID
    #                        6
    #   ))
    #   
    #   output$x6 <- renderDT({
    #     updated_data <- mydbGetQuery(QDisplay) %>% as_tibble()
    #     datatable(data = bind_cols(updated_data, tibble(Test = test2(updated_data$nom_pantheon, d))),
    #               selection = 'none', escape = FALSE, rownames = FALSE, editable = list(target = 'cell', disable = list(columns = c(0, 2))),
    #               callback = JS(js), extensions = "KeyTable", options = list(keys = TRUE))
    #   })
    #   
    #   reset("single_select6")
    # })
  }
)
最新问题
© www.soinside.com 2019 - 2024. All rights reserved.