Dataframe Is Subseted by Row Number and Not by Cell Value After Clicking on Dt::Datatable

  • Home
  • Languages
  • R
  • Dataframe Is Subseted by Row Number and Not by Cell Value After Clicking on Dt::Datatable

Dataframe is subseted by row number and not by cell value after clicking on dt::datatable

Try this

  output$TABLE2 <- DT::renderDataTable({
    req(input$TABLE_cells_selected)
    owner_selected <- ckall2$owner[input$TABLE_cells_selected[[1]]]
    down2 <- subset(down2, owner %in% owner_selected)
  })

Subset a dataframe by single cell selection of DT::datatable

To make your code work you have to add selection = list(target = "cell") as an argument of your datatable call. The way you used it inside {} you create a variable with name selection which however has no effect on the datatable:

library(shiny)
library(shinydashboard)
library(DT)

ui <- dashboardPage(
  dashboardHeader(),
  dashboardSidebar(),
  dashboardBody(
    dataTableOutput("TABLE"),
    dataTableOutput("TABLE2"),
  )
)
server <- (function(input, output, session) {
  output$TABLE <- renderDataTable({
    server <- TRUE
    datatable(ckall,
      filter = "top", editable = "cell", class = "hover cell-border stripe",
      caption = "Kimball & Cheyenne Counties AOI",
      extensions = "Buttons",
      options = list(
        dom = "Bfrtip", scrollX = T,
        buttons = c("copy", "csv", "excel")
      ),
      selection = list(target = "cell"),
    )
  })
  output$TABLE2 <- DT::renderDataTable({
    req(input$TABLE_cells_selected)
    ckall[input$TABLE_cells_selected[, 1], input$TABLE_cells_selected[, 2], drop = F]
  })
})

shinyApp(ui, server)

Sample Image

Update a dataset after putting a new value in the dt::datatable

As far as I get it the filter for the datatable columns gets deactivated when a column contains only one value, i.e. that's not specific to NAs. The same occurs if you replace the NAs by empty strings or e.g. an a. Unfortunately I wasn't able to find anything on this behavior in the documentation.

However, to activate the filter after you edited a cell you could follow the example app referenced in Section 2.4 of the docs. Following the example you could add an observeEvent to update your dataset d to take account of the editing. Additionally to ensure that the datatable gets updated I made renderDataTable reactive on input$TABLE_cell_edit. After doing so that datatable gets updated after an edit and the filter gets activated automatically:

library(shiny)
library(shinydashboard)
library(DT)
d <- structure(list(owner = c(
  "7 MILL IRON RANCH LLC", "7/S LAND & CATTLE COMPANY LLC",
  "AHL/KENNETH L(TRUSTEE & JOHN E AHL ETAL"
), acres = c(
  1900.6207117,
  654.7908393, 641.3866548
), n = c(5L, 2L, 1L), landman = c(
  NA_character_,
  NA_character_, NA_character_
)), row.names = c(NA, -3L), class = c(
  "tbl_df",
  "tbl", "data.frame"
))

#d$landman <- letters[1:3]

ui <- dashboardPage(
  dashboardHeader(),
  dashboardSidebar(),
  dashboardBody(
    dataTableOutput("TABLE"),
  )
)

server <- (function(input, output, session) {
  observeEvent(input$TABLE_cell_edit, {
    d <<- editData(d, input$TABLE_cell_edit, 'TABLE')
  })
  
  output$TABLE <- renderDataTable({
    input$TABLE_cell_edit
    
    datatable(d,
      filter = "top", editable = "cell", class = "hover cell-border stripe",
      caption = "Owners wit more than 500 aggregated accrs",
      extensions = "Buttons",
      options = list(
        dom = "Bfrtip",
        buttons = c("copy", "csv", "excel")
      )
    )
  })
})

shinyApp(ui, server)

Sample Image

How to get a specific column value when using Datatables Selected_Row

input$foo_rows_selected stores the row index of the selected rows. To get the value of a specific column for the selected row, simply subset the data frame.

output$selected_var <- renderText({ 
    master_playeridlist[input$players_rows_selected, "id"] 
})

Subset a data table based on cell selection of another datatable

See code below. You were trying to subset the data versus creating a new dataframe(which from above sounds like what you want) + you want to use [tablename]_cell_clicked which has a row, column, value list versus [tablename]_cells_selected.

library(shiny)
library(DT)
data("mtcars")

ui <- shinyUI(
  fluidRow(
    DT::dataTableOutput("myDatatable"),
    DT::dataTableOutput("myDatatable2"),
    DT::dataTableOutput("myDatatable3")

  )

)

server <- shinyServer(function(input, output, session) {

  dat1 <- reactive({
    matrix(iris[,5])
  })

  dat2 <- reactive({
    matrix(iris[c(25,78,67,45,90,66,78,9,8),5])
  })

  dat3 <- reactive({
    temp <- data.frame(results = c(input$myDatatable_cell_clicked$value, input$myDatatable2_cell_clicked$value))
  })

  output$myDatatable <- DT::renderDataTable(dat1(), 
                                            selection=list( target="cell"),
                                            server = FALSE,
                                            rownames=FALSE)
  output$myDatatable2 <- DT::renderDataTable(dat2(), 
                                             selection=list(mode="single", target="cell"),
                                             server = FALSE,
                                             rownames=FALSE)
  output$myDatatable3 <- DT::renderDataTable(dat3(), 
                                             server = FALSE,
                                             rownames=FALSE)
})

shinyApp(ui, server)

**Updated based on OP's clarification

library(shiny)
library(DT)
data("mtcars")

ui <- shinyUI(
  fluidRow(
    DT::dataTableOutput("myDatatable"),
    DT::dataTableOutput("myDatatable2"),
    DT::dataTableOutput("myDatatable3")

  )

)

server <- shinyServer(function(input, output, session) {

  dat1 <- reactive({
    matrix(iris[,5])
  })

  dat2 <- reactive({
    matrix(iris[c(25,78,67,45,90,66,78,9,8),5])
  })

  dat3 <- reactive({

    dat1row <- input$myDatatable_cells_selected
    dat2row <- c(25,78,67,45,90,66,78,9,8)[c(input$myDatatable2_cell_clicked$row)]

    temp <- iris[c(dat1row, dat2row),]
  })

  output$myDatatable <- DT::renderDataTable(dat1(), 
                                            selection=list( target="cell"),
                                            server = FALSE,
                                            rownames=FALSE)
  output$myDatatable2 <- DT::renderDataTable(dat2(), 
                                             selection=list(mode="single", target="cell"),
                                             server = FALSE,
                                             rownames=FALSE)
  output$myDatatable3 <- DT::renderDataTable(dat3(), 
                                             server = FALSE,
                                             rownames=FALSE)
})

shinyApp(ui, server)

Select a DT row and then change the value of one cell of this row based on widget selection input and actionButton() in a shiny app

First, we can save the rendered table inside a reactiveValues object along with the row that was selected:

rv <- reactiveValues(df = Input, row_selected = NULL)

Second, every time the edit button get's pressed, the row selected is saved and de data updated using walk2 to loop through all the columns.

  observeEvent(input$edit,{
    
    if (!is.null(input$TBL1_rows_selected)) {
      cols_to_edit <- c('sectype', 'sectick', 'PurDate', 'selDate', 'aminv')
      colnms <- c('Security Type', 'Ticker', 'Purchase Date', 'Sale Date', 'Amount Invested')
      "remember the row selected"
      rv$row_selected <- input$TBL1_rows_selected
      
      walk2(cols_to_edit, colnms, ~{rv$df[input$TBL1_rows_selected, ..2] <<- input[[..1]]}) 
      
    }
  
    })

App:

library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(DT)
library(tidyverse)

Input <- structure(list(`Security Type` = c("Stock", "Stock", "Load Fund"), Ticker = c("XOM", "NFLX", "AMCPX"), `Purchase Date` = structure(c(
  16070,
  17084, 17084
), class = "Date"), `Sale Date` = structure(c(
  18627,
  NA, 18545
), class = "Date"), `Amount Invested` = c(
  "$10,000",
  "$8,000", "$10,000"
)), class = c(
  "spec_tbl_df", "tbl_df", "tbl",
  "data.frame"
), row.names = c(NA, -3L))

ui = tags$body(class = "skin-blue sidebar-mini control-sidebar-open", dashboardPage(
  options = list(sidebarExpandOnHover = TRUE),
  header = dashboardHeader(title = "Investment Advisor Monitoring - Insider Trading", titleWidth = 450),
  sidebar = dashboardSidebar(
    minified = F, collapsed = F,
    selectInput(
      "sectype", "Security Type",
      c(unique(Input$`Security Type`))
    ),
    selectInput(
      "sectick", "Ticker",
      c(unique(Input$Ticker))
    ),
    dateInput("PurDate", "Purchase Date", value = as.Date("2013-12-31")),
    dateInput("selDate", "Sale Date", value = as.Date("2019-01-31")),
    selectInput(
      "aminv", "Amount Invested",
      c(unique(Input$`Amount Invested`))
    ),
    actionButton("edit", "Edit")
    
    
  ),
  body = dashboardBody(
    h3("Results"),
    tabsetPanel(
      id = "tabs",
      tabPanel(
        "InsiderTraining",
        dataTableOutput("TBL1")
      )
    )
  ),
  controlbar = dashboardControlbar(width = 300),
  title = "DashboardPage"
))

server = function(input, output) {
  # I want to remember the row that was selected 
  rv <- reactiveValues(df = Input, row_selected = NULL)
  
  
  
  observeEvent(input$edit,{
    
    if (!is.null(input$TBL1_rows_selected)) {
      cols_to_edit <- c('sectype', 'sectick', 'PurDate', 'selDate', 'aminv')
      colnms <- c('Security Type', 'Ticker', 'Purchase Date', 'Sale Date', 'Amount Invested')
      "remember the row selected"
      rv$row_selected <- input$TBL1_rows_selected
      
      walk2(cols_to_edit, colnms, ~{rv$df[input$TBL1_rows_selected, ..2] <<- input[[..1]]}) 
      
    }
  
    })
  
  
  output$TBL1 <- DT::renderDataTable({
    DT::datatable(rv$df, selection = list(target = "row",  selected = rv$row_selected))
  })
  
}

shinyApp(ui,server)

Sample Image

Change the value of a data frame when is clicked in a datatable

I have modified your code. I am guessing this is what you want:

    library(shiny)
    library(shinydashboard)
    library(DT)

    from <- c("A","B","C")
    content <- c("Mensaje 1","Mensaje2","Mensaje leido")
    leido <- c(FALSE,FALSE,TRUE)
    messages <- data.frame(from,content,leido)

    ui <- dashboardPage(
      dashboardHeader(title = "Dynamic sidebar"),
      dashboardSidebar(
        sidebarMenuOutput("mensajes")
      ),
      dashboardBody( DT::dataTableOutput("tablaMensajes"))
    )

    server = function(input, output, session){

      output$tablaMensajes <- DT::renderDataTable({
        messages
      })

      output$mensajes <- renderMenu({
        msgs <- apply(messages[which(messages$leido == FALSE),], 1, function(row) {
          messageItem(from = row[["from"]], message = row[["content"]],href = paste0("javascript:mensaje('",row[["content"]],"')"))
        })
        dropdownMenu(type = "messages", .list = msgs)
      })

      observe({
        if(! is.null(input$tablaMensajes_rows_selected)){
          #browser()
          messages
          s<-input$tablaMensajes_rows_selected
          messages[s,"leido"] <<- TRUE
          output$mensajes <- renderMenu({
            msgs <- apply(messages[which(messages$leido == FALSE),], 1, function(row) {
              messageItem(from = row[["from"]], message = row[["content"]],href = paste0("javascript:mensaje('",row[["content"]],"')"))
            })
            dropdownMenu(type = "messages", .list = msgs)
          })

          output$tablaMensajes <- DT::renderDataTable({
            messages
          })

        }
      })

    }

    shinyApp(ui,server)

**[EDIT]:**

To remove subscript out of bound error I have edited the above code to add conditions if the no rows with false value is present then the message should be be empty. 

library(shiny)
library(shinydashboard)
library(DT)

from <- c("A","B","C")
content <- c("Mensaje 1","Mensaje2","Mensaje leido")
leido <- c(FALSE,FALSE,TRUE)
messages <- data.frame(from,content,leido)

ui <- dashboardPage(
  dashboardHeader(title = "Dynamic sidebar"),
  dashboardSidebar(
    sidebarMenuOutput("mensajes")
  ),
  dashboardBody( DT::dataTableOutput("tablaMensajes"))
)

server = function(input, output, session){

  output$tablaMensajes <- DT::renderDataTable({
    messages
  })

  output$mensajes <- renderMenu({
    if(nrow(messages[which(messages$leido == FALSE),]) >0) {
      msgs <- apply(messages[which(messages$leido == FALSE),], 1, function(row) {
        messageItem(from = row[["from"]], message = row[["content"]],href = paste0("javascript:mensaje('",row[["content"]],"')"))
      }) 
    }else{
      msgs = NULL
    }

    dropdownMenu(type = "messages", .list = msgs)
  })

  observe({
    if(! is.null(input$tablaMensajes_rows_selected)){
      #browser()
      messages
      s<-input$tablaMensajes_rows_selected
      messages[s,"leido"] <<- TRUE
      output$mensajes <- renderMenu({
        if(nrow(messages[which(messages$leido == FALSE),]) >0) {
        msgs <- apply(messages[which(messages$leido == FALSE),], 1, function(row) {
          messageItem(from = row[["from"]], message = row[["content"]],href = paste0("javascript:mensaje('",row[["content"]],"')"))
        })
        }else{
          msgs = NULL
        }
        dropdownMenu(type = "messages", .list = msgs)
      })

      output$tablaMensajes <- DT::renderDataTable({
        messages
      })

    }
  })

}

shinyApp(ui,server)

Hope it helps!

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

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.

Sample Image

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

Sample Image

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

Display multiple strings in a cell of a datatable that can be removed by clicking on them

We can do that with a selectizeInput:

Sample Image

library(shiny)
library(DT)

js <- c(
  "function(settings){",
  "  $('#mselect').selectize();",
  "}"
)

ui <- fluidPage(
  br(),
  DTOutput("table"),
  div(
    style = "display: none;",
    selectInput("id", "label", c("x", "y"))
  )
)

Related Topics

R: "Make" Not Found When Installing a R-Package from Local Tar.Gz

Adding a Legend to an Rgl 3D Plot

How to Pop Up the Graphics Window from Rscript

Recode Numeric Values in R

Passing Variable with Line Types to Ggplot Linetype

What Does the %<>% Operator Mean in R

Filtering a Dataframe Showing Only Duplicates

Combining Grid.Table and Base Package Plots in R Figure

How to Get Last Data for Each Id/Date

Ggplot2: Have Common Facet Bar in Outer Facet Panel in 3-Way Plot

How to Shift X Axis Positions of Two Geoms Relative to Each Other

Add Error Bars to a Barplot

Preventing Incosistent Spacing/Bar Widths in Geom_Bar with Many Bars

Get Most Frequent String from a Data Frame Column

Lapply with Anonymous Function Call to Svytable Results in Object 'X' Not Found

Equivalent of Which in Scraping

Error When Mapping in Ggmap with API Key (403 Forbidden)

Adding Grouped Mean Values to Column in Data Frame


Leave a reply



Submit