通过单击数据表行和操作按钮向数据框添加新行
Add a new row to a dataframe by clicking on a datatable row and actionbutton
我有闪亮的应用程序和下面的数据框。
当我点击一行时,我得到一个文本,其中显示 attribute_name
与 .
的相似性
如果我单击 Next
,我会得到相同 attribute_name
与下一个 candidate_2
的相似度。
我希望能够按 Add
actionbutton()
并将此 candidate_2
添加到 table 中的相关 selectInput()
。
例如,如果我单击 table 的第一行并按 Add
,那么单词 micro
将添加到第一行的 selectInput()
中。
基本上,每次我 select 一行并按 Add
actionbutton()
.
时,需要向数据帧 d
添加一个新行
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.
直接将项目添加到 select 输入
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())
)
})
}
)
编辑
关于您的评论,这是具有简化服务器逻辑的应用程序,并且 back/next 按钮在需要时被禁用:
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())
)
})
}
)
我有闪亮的应用程序和下面的数据框。
当我点击一行时,我得到一个文本,其中显示 attribute_name
与 .
如果我单击 Next
,我会得到相同 attribute_name
与下一个 candidate_2
的相似度。
我希望能够按 Add
actionbutton()
并将此 candidate_2
添加到 table 中的相关 selectInput()
。
例如,如果我单击 table 的第一行并按 Add
,那么单词 micro
将添加到第一行的 selectInput()
中。
基本上,每次我 select 一行并按 Add
actionbutton()
.
d
添加一个新行
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.
直接将项目添加到 select 输入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())
)
})
}
)
编辑
关于您的评论,这是具有简化服务器逻辑的应用程序,并且 back/next 按钮在需要时被禁用:
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())
)
})
}
)