通过单击数据表行和操作按钮将新行添加到数据框 [英] Add a new row to a dataframe by clicking on a datatable row and actionbutton
本文介绍了通过单击数据表行和操作按钮将新行添加到数据框的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
我下面有闪亮的应用程序和数据框.
I have the shiny app and the dataframes below.
当我单击一行时，我得到一个文本，该文本显示此 attribute_name 与.
When I click on a row I get a text which displays the similarity of this attribute_name with a .
如果单击 Next ，我将获得与下一个 candidate_2 相同的 attribute_name 的相似性.
If I click Next I get the similarity of the same attribute_name with the next candidate_2.
我希望能够按 Add actionbutton()并将此 candidate_2 添加到相关的 selectInput().
I want to be able to press the Add actionbutton() and add this candidate_2 to the related selectInput() in the table.
例如，如果我单击表格的第一行并按 Add ，则会在 selectInput()中添加 micro 一词第一行的
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.
基本上，每次我选择一行并按 Add actionbutton()时，都需要向数据框 d 中添加新行.
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())
)
})
}
)
推荐答案
不错的应用.下面是我的解决方案.我没有在数据框中添加新行；我通过JavaScript直接在选择输入中添加了一个项目.
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())
)
})
}
)
样式建议
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())
)
})
}
)
这篇关于通过单击数据表行和操作按钮将新行添加到数据框的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
