1. 技术文章
  2. Add a new row to a dataframe by clicking on a datatable row and actionbutton

Add a new row to a dataframe by clicking on a datatable row and actionbutton

由 白昼怎懂夜的黑 提交于 2021-01-29 08:46:47

问题


I have the shiny app and the dataframes below.

When I click on a row I get a text which displays the similarity of this attribute_name with a .

If I click Next I get the similarity of the same attribute_name with the next candidate_2.

I want to be able to press the Add actionbutton() and add this candidate_2 to the related selectInput() in the table.

For example if I click on the 1st row of the table and press Add the word micro will be added in the selectInput() of the first row.

Basically what needed is to add a new row to the dataframe d everytime I select a row and press the Add actionbutton().

library(shinydashboard)
library(shinydashboardPlus)
library(DT)

attribute_name <- c("Jack", "Bob", "Jack", "Bob")
category_id <- c(7, 7, 7, 7)
candidate_phrase_lemma <- c("apple", "olive", "banana", "tomato")
d <- data.frame(
  attribute_name,
  category_id,
  candidate_phrase_lemma,
  stringsAsFactors = FALSE
)
names <- tapply(d$candidate_phrase_lemma, d$attribute_name, I)

candidate_1 <- c("Jack", "Bob", "Jack", "Bob")
candidate_2 <- c("phone", "camera", "micro", "pc")
similarity <- c(4, 5, 6, 7)
category_id <- c(7, 7, 7, 7)
e <- data.frame(candidate_1, candidate_2, similarity, category_id)

selector <- function(id, values, items = values) {
  options <- HTML(paste0(mapply(
    function(value, item) {
      as.character(tags$option(value = value, selected = "selected", item))
    }, values, items
  ), collapse = ""))
  as.character(
    tags$select(
      id = id, multiple = "multiple", options
    )
  )
}

nrows <- length(names)

initComplete <- c(
  "function(settings) {",
  sprintf("var nrows = %d;", nrows),
  "  var table = this.api().table();",
  "  function selectize(i) {",
  "    var $slct = $('#slct' + i);",
  "    $slct.select2({",
  "      width: '100%',",
  "      closeOnSelect: false",
  "    });",
  "    $slct.on('change', function(e) {",
  "      table.cell(i-1, 2).data($slct.val().length);",
  "    });",
  "  }",
  "  for(var i = 1; i <= nrows; i++) {",
  "    selectize(i);",
  "  }",
  "}"
)

js <- paste0(c(
  "Shiny.addCustomMessageHandler(",
  "  'addCandidate',",
  "  function(row_candidate) {",
  "    var i = row_candidate.row;",
  "    var candidate = row_candidate.candidate;",
  "    var $slct = $('#slct' + i);",
  "    if($slct.find(\"option[value='\" + candidate + \"']\").length === 0) {",
  "      var newOption = new Option(candidate, candidate, true, true);",
  "      $slct.append(newOption).trigger('change');",
  "    }",
  "  }",
  ");"
), collapse = "\n")

shinyApp(
  ui = dashboardPagePlus(
    tags$head(
      tags$link(rel = "stylesheet", href = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/css/select2.min.css"),
      tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/js/select2.min.js"),
      tags$style(HTML(
        ".select2-selection__choice {background-color: darkblue !important;}"
      )),
      tags$script(HTML(js))
    ),
    header = dashboardHeaderPlus(),
    sidebar = dashboardSidebar(),
    body = dashboardBody(
      DTOutput("table"),
      textOutput("celltext"),
      fluidRow(
        column(1, actionButton("dec", "Next")),
        column(1, actionButton("bc", "Back")),
        column(1, actionButton("addWord", "Add"))
      )
    )
  ),
  server = function(input, output, session) {
    Text <- reactiveVal()
    Data <- reactiveVal()
    Candidate <- reactiveVal()
    rnum <- reactiveVal(0)
    rnumm <- reactiveVal(0)
    
    output[["table"]] <- renderDT({
      dat <- data.frame(
        attributes = unique(as.character(d$attribute_name)),
        attributes_phrases = vapply(
          1:nrows,
          function(i) {
            selector(paste0("slct", i), names[[i]])
          },
          character(1)
        ),
        Count = lengths(names),
        stringsAsFactors = FALSE
      )
      datatable(
        data = dat,
        selection = list(target = "row", mode = "single"),
        escape = FALSE,
        rownames = FALSE,
        options = list(
          pageLength = 5,
          initComplete = JS(initComplete),
          preDrawCallback = JS(
            "function() { Shiny.unbindAll(this.api().table().node()); }"
          ),
          drawCallback = JS(
            "function() { Shiny.bindAll(this.api().table().node()); }"
          )
        )
      )
    }, server = FALSE)
    
    
    observeEvent(input[["table_rows_selected"]], {
      row <- input[["table_rows_selected"]]
      dat <- e[e[["candidate_1"]] %in% d[row, 1], ]
      Data(dat[order(dat[["similarity"]], decreasing = TRUE), ])
      Candidate(Data()[1, 2])
      Text(
        paste(
          "Similarity of", Data()[1, 1], 
          "to candidate", Candidate(), 
          "is", Data()[1, 3]
        )
      )
      rnum(1)
      rnumm(nrow(dat))
      output[["celltext"]] <- renderText({
        if (length(input[["table_rows_selected"]])) {
          Text()
        } else {
          ""
        }
      })
    })
    observeEvent(input[["dec"]], {
      if (rnum() < rnumm()) rnum(rnum() + 1)
      Candidate(Data()[rnum(), 2])
      Text(
        paste(
          "Similarity of", Data()[rnum(), 1], 
          "to candidate", Candidate(), 
          "is", Data()[rnum(), 3])
      )
    })
    observeEvent(input[["bc"]], {
      if (rnum() < rnumm()) rnum(rnum() - 1)
      Candidate(Data()[rnum(), 2])
      Text(
        paste(
          "Similarity of", Data()[rnum(), 1], 
          "to candidate", Candidate(), 
          "is", Data()[rnum(), 3])
      )
    })
    observeEvent(input[["addWord"]], {
      session$sendCustomMessage(
        "addCandidate",
        list(row = input[["table_rows_selected"]], candidate = Candidate())
      )
    })
  }
)

回答1:


Nice app. Below is my solution. I don't add a new row to the dataframe; I directly add an item to the select input via JavaScript.

library(shinydashboard)
library(shinydashboardPlus)
library(DT)

attribute_name <- c("Jack", "Bob", "Jack", "Bob")
category_id <- c(7, 7, 7, 7)
candidate_phrase_lemma <- c("apple", "olive", "banana", "tomato")
d <- data.frame(
  attribute_name,
  category_id,
  candidate_phrase_lemma,
  stringsAsFactors = FALSE
)
names <- tapply(d$candidate_phrase_lemma, d$attribute_name, I)

candidate_1 <- c("Jack", "Bob", "Jack", "Bob")
candidate_2 <- c("phone", "camera", "micro", "pc")
similarity <- c(4, 5, 6, 7)
category_id <- c(7, 7, 7, 7)
e <- data.frame(candidate_1, candidate_2, similarity, category_id)

selector <- function(id, values, items = values) {
  options <- HTML(paste0(mapply(
    function(value, item) {
      as.character(tags$option(value = value, selected = "selected", item))
    }, values, items
  ), collapse = ""))
  as.character(
    tags$select(
      id = id, multiple = "multiple", options
    )
  )
}

nrows <- length(names)

initComplete <- c(
  "function(settings) {",
  sprintf("var nrows = %d;", nrows),
  "  var table = this.api().table();",
  "  function selectize(i) {",
  "    var $slct = $('#slct' + i);",
  "    $slct.select2({",
  "      width: '100%',",
  "      closeOnSelect: false",
  "    });",
  "    $slct.on('change', function(e) {",
  "      table.cell(i-1, 2).data($slct.val().length);",
  "    });",
  "  }",
  "  for(var i = 1; i <= nrows; i++) {",
  "    selectize(i);",
  "  }",
  "}"
)

js <- paste0(c(
  "Shiny.addCustomMessageHandler(",
  "  'addCandidate',",
  "  function(row_candidate) {",
  "    var i = row_candidate.row;",
  "    var candidate = row_candidate.candidate;",
  "    var $slct = $('#slct' + i);",
  "    if($slct.find(\"option[value='\" + candidate + \"']\").length === 0) {",
  "      var newOption = new Option(candidate, candidate, true, true);",
  "      $slct.append(newOption).trigger('change');",
  "    }",
  "  }",
  ");"
), collapse = "\n")

shinyApp(
  ui = dashboardPagePlus(
    tags$head(
      tags$link(rel = "stylesheet", href = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/css/select2.min.css"),
      tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/js/select2.min.js"),
      tags$style(HTML(
        ".select2-selection__choice {background-color: darkblue !important;}"
      )),
      tags$script(HTML(js))
    ),
    header = dashboardHeaderPlus(),
    sidebar = dashboardSidebar(),
    body = dashboardBody(
      DTOutput("table"),
      textOutput("celltext"),
      fluidRow(
        column(1, actionButton("dec", "Next")),
        column(1, actionButton("addWord", "Add"))
      )
    )
  ),
  server = function(input, output, session) {
    Text <- reactiveVal()
    Data <- reactiveVal()
    Candidate <- reactiveVal()
    rnum <- reactiveVal(0)
    rnumm <- reactiveVal(0)
    
    output[["table"]] <- renderDT({
      dat <- data.frame(
        attributes = unique(as.character(d$attribute_name)),
        attributes_phrases = vapply(
          1:nrows,
          function(i) {
            selector(paste0("slct", i), names[[i]])
          },
          character(1)
        ),
        Count = lengths(names),
        stringsAsFactors = FALSE
      )
      datatable(
        data = dat,
        selection = list(target = "row", mode = "single"),
        escape = FALSE,
        rownames = FALSE,
        options = list(
          pageLength = 5,
          initComplete = JS(initComplete),
          preDrawCallback = JS(
            "function() { Shiny.unbindAll(this.api().table().node()); }"
          ),
          drawCallback = JS(
            "function() { Shiny.bindAll(this.api().table().node()); }"
          )
        )
      )
    }, server = FALSE)
    
    
    observeEvent(input[["table_rows_selected"]], {
      row <- input[["table_rows_selected"]]
      dat <- e[e[["candidate_1"]] %in% d[row, 1], ]
      Data(dat[order(dat[["similarity"]], decreasing = TRUE), ])
      Candidate(Data()[1, 2])
      Text(
        paste(
          "Similarity of", Data()[1, 1], 
          "to candidate", Candidate(), 
          "is", Data()[1, 3]
        )
      )
      rnum(1)
      rnumm(nrow(dat))
      output[["celltext"]] <- renderText({
        if (length(input[["table_rows_selected"]])) {
          Text()
        } else {
          ""
        }
      })
    })
    observeEvent(input[["dec"]], {
      if (rnum() < rnumm()) rnum(rnum() + 1)
      Candidate(Data()[rnum(), 2])
      Text(
        paste(
          "Similarity of", Data()[rnum(), 1], 
          "to candidate", Candidate(), 
          "is", Data()[rnum(), 3])
      )
    })
    observeEvent(input[["addWord"]], {
      session$sendCustomMessage(
        "addCandidate",
        list(row = input[["table_rows_selected"]], candidate = Candidate())
      )
    })
  }
)

EDIT: styling suggestion

shinyApp(
  ui = dashboardPagePlus(
    tags$head(
      tags$link(rel = "stylesheet", href = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/css/select2.min.css"),
      tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/js/select2.min.js"),
      tags$style(HTML(
        ".select2-selection__choice {background-color: darkblue !important;}"
      )),
      tags$script(HTML(js))
    ),
    header = dashboardHeaderPlus(),
    sidebar = dashboardSidebar(),
    body = dashboardBody(
      DTOutput("table"),
      conditionalPanel(
        condition = "input.table_rows_selected.length > 0",
        wellPanel(
          uiOutput("celltext"),
          splitLayout(
          actionButton("dec", "Next candidate"),
          actionButton("addWord", "Add this candidate"),
          cellWidths = "fit-content"
        )
        )
      )
    )
  ),
  server = function(input, output, session) {
    Text <- reactiveVal()
    Data <- reactiveVal()
    Candidate <- reactiveVal()
    rnum <- reactiveVal(0)
    rnumm <- reactiveVal(0)
    
    output[["table"]] <- renderDT({
      dat <- data.frame(
        attributes = unique(as.character(d$attribute_name)),
        attributes_phrases = vapply(
          1:nrows,
          function(i) {
            selector(paste0("slct", i), names[[i]])
          },
          character(1)
        ),
        Count = lengths(names),
        stringsAsFactors = FALSE
      )
      datatable(
        data = dat,
        selection = list(target = "row", mode = "single"),
        escape = FALSE,
        rownames = FALSE,
        options = list(
          pageLength = 5,
          initComplete = JS(initComplete),
          preDrawCallback = JS(
            "function() { Shiny.unbindAll(this.api().table().node()); }"
          ),
          drawCallback = JS(
            "function() { Shiny.bindAll(this.api().table().node()); }"
          )
        )
      )
    }, server = FALSE)
    
    
    observeEvent(input[["table_rows_selected"]], {
      row <- input[["table_rows_selected"]]
      dat <- e[e[["candidate_1"]] %in% d[row, 1], ]
      Data(dat[order(dat[["similarity"]], decreasing = TRUE), ])
      Candidate(Data()[1, 2])
      Text(
        paste(
          "Similarity of <em>", Data()[1, 1], "</em>", 
          "to candidate <em>", Candidate(), "</em>", 
          "is <strong>", Data()[1, 3], "</strong>"
        )
      )
      rnum(1)
      rnumm(nrow(dat))
      output[["celltext"]] <- renderUI({
        if (length(input[["table_rows_selected"]])) {
          HTML(Text())
        } else {
          ""
        }
      })
    })
    observeEvent(input[["dec"]], {
      if (rnum() < rnumm()) rnum(rnum() + 1)
      Candidate(Data()[rnum(), 2])
      Text(
        paste(
          "Similarity of <em>", Data()[rnum(), 1], "</em>", 
          "to candidate <em>", Candidate(), "</em>",
          "is <strong>", Data()[rnum(), 3], "</strong>"
        )
      )
    })
    observeEvent(input[["addWord"]], {
      session$sendCustomMessage(
        "addCandidate",
        list(row = input[["table_rows_selected"]], candidate = Candidate())
      )
    })
  }
)

EDIT

Regarding your comment, here is the app with a simplified server logic and the back/next buttons are disabled when needed:

library(shinyjs)

shinyApp(
  ui = dashboardPagePlus(
    tags$head(
      tags$link(rel = "stylesheet", href = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/css/select2.min.css"),
      tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/js/select2.min.js"),
      tags$style(HTML(
        ".select2-selection__choice {background-color: darkblue !important;}"
      )),
      tags$script(HTML(js))
    ),
    useShinyjs(),
    header = dashboardHeaderPlus(),
    sidebar = dashboardSidebar(),
    body = dashboardBody(
      DTOutput("table"),
      conditionalPanel(
        condition = "input.table_rows_selected.length > 0",
        wellPanel(
          uiOutput("celltext"),
          splitLayout(
            actionButton("bc", "Previous candidate"),
            actionButton("dec", "Next candidate"),
            actionButton("addWord", "Add this candidate", class = "btn-info"),
            cellWidths = "fit-content"
          )
        )
      )
    )
  ),
  server = function(input, output, session) {
    Text <- reactiveVal()
    Data <- reactiveVal()
    Candidate <- reactiveVal()
    rnum <- reactiveVal()

    output[["table"]] <- renderDT({
      dat <- data.frame(
        attributes = unique(as.character(d$attribute_name)),
        attributes_phrases = vapply(
          1:nrows,
          function(i) {
            selector(paste0("slct", i), names[[i]])
          },
          character(1)
        ),
        Count = lengths(names),
        stringsAsFactors = FALSE
      )
      datatable(
        data = dat,
        selection = list(target = "row", mode = "single"),
        escape = FALSE,
        rownames = FALSE,
        options = list(
          pageLength = 5,
          initComplete = JS(initComplete),
          preDrawCallback = JS(
            "function() { Shiny.unbindAll(this.api().table().node()); }"
          ),
          drawCallback = JS(
            "function() { Shiny.bindAll(this.api().table().node()); }"
          )
        )
      )
    }, server = FALSE)
    
    
    observeEvent(input[["table_rows_selected"]], {
      row <- input[["table_rows_selected"]]
      dat <- e[e[["candidate_1"]] %in% d[row, 1], ]
      Data(dat[order(dat[["similarity"]], decreasing = TRUE), ])
      rnum(1)
    })
    output[["celltext"]] <- renderUI({
      HTML(Text())
    })
    observeEvent(input[["dec"]], {
      rnum(rnum() + 1)
    })
    observeEvent(input[["bc"]], {
      rnum(rnum() - 1)
    })
    observeEvent(list(rnum(), Data()), {
      if(rnum() == 1){
        disable("bc")
      }else{
        enable("bc")
      }
      if(rnum() == nrows){
        disable("dec")
      }else{
        enable("dec")
      }
      Candidate(Data()[rnum(), 2])
      Text(
        paste(
          "Similarity of <em>", Data()[rnum(), 1], "</em>",
          "to candidate <em>", Candidate(), "</em>",
          "is <strong>", Data()[rnum(), 3], "</strong>"
        )
      )
    }, ignoreInit = TRUE)
    observeEvent(input[["addWord"]], {
      session$sendCustomMessage(
        "addCandidate",
        list(row = input[["table_rows_selected"]], candidate = Candidate())
      )
    })
  }
)


来源：https://stackoverflow.com/questions/65693747/add-a-new-row-to-a-dataframe-by-clicking-on-a-datatable-row-and-actionbutton

标签
r
Shiny
dt
易学教程内所有资源均来自网络或用户发布的内容，如有违反法律规定的内容欢迎反馈！
该文章没有解决你所遇到的问题?点击提问,说说你的问题,让更多的人一起探讨吧!