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())
)
})
}
)
