Shiny: Selecting groups using selectizeInput - r

I have this vision where I have a selector and a user can click the group to select all items in that group. For example, please see this
When you click input box X2 or X4, I would like for the user to be able to click "Western" to select both California and Washington.
Ideally, I would like for the user to be able to select multiple regions, as well as be able to customize their selections (i.e choose "Western" region and look at some data. Then unselect "Washington" to focus on "California" and look at more data.
I'm thinking that if this isn't possible in a simple way, I should just have the regions as choices and use updateSelectInput() to update the selected values, when the user has selected a region.
Thank you for the help.

Afaik using selectizeInput you'll have to rely on a nested/dependent selection of multiple inputs to get something similar to your expected behavior.
Once it’s heading towards hierarchical selection I really like using library(d3Tree) as an alternative approach.
Here is a modified version (adapted to your states link) of one of the d3Tree examples:
library(shiny)
library(d3Tree)
library(DT)
library(data.table)
library(datasets)
DT <- unique(data.table(state.region, state.division, state.name, state.area))
variables <- names(DT)
rootName <- "us.states"
ui <- fluidPage(fluidRow(
column(
7,
column(8, style = "margin-top: 8px;",
selectizeInput(
"Hierarchy",
"Tree Hierarchy",
choices = variables,
multiple = TRUE,
selected = variables,
options = list(plugins = list('drag_drop', 'remove_button'))
)),
column(4, tableOutput("clickView")),
d3treeOutput(
outputId = "d3",
width = '1200px',
height = '475px'
),
column(12, DT::dataTableOutput("filterStatementsOut"))
),
column(5, style = "margin-top: 10px;", DT::dataTableOutput('filteredTableOut'))
))
server <- function(input, output, session) {
network <- reactiveValues(click = data.frame(name = NA, value = NA, depth = NA, id = NA))
observeEvent(input$d3_update, {
network$nodes <- unlist(input$d3_update$.nodesData)
activeNode <- input$d3_update$.activeNode
if (!is.null(activeNode))
network$click <- jsonlite::fromJSON(activeNode)
})
output$clickView <- renderTable({
req({as.data.table(network$click)})
}, caption = 'Last Clicked Node', caption.placement = 'top')
filteredTable <- eventReactive(network$nodes, {
if (is.null(network$nodes)) {
DT
} else{
filterStatements <- tree.filter(network$nodes, DT)
filterStatements$FILTER <- gsub(pattern = rootName, replacement = variables[1], x = filterStatements$FILTER)
network$filterStatements <- filterStatements
DT[eval(parse(text = paste0(network$filterStatements$FILTER, collapse = " | ")))]
}
})
output$d3 <- renderD3tree({
if (is.null(input$Hierarchy)) {
selectedCols <- variables
} else{
selectedCols <- input$Hierarchy
}
d3tree(
data = list(
root = df2tree(struct = DT[, ..selectedCols][, dummy.col := ''], rootname = rootName),
layout = 'collapse'
),
activeReturn = c('name', 'value', 'depth', 'id'),
height = 18
)
})
output$filterStatementsOut <- renderDataTable({
req({network$filterStatements})
}, caption = 'Generated filter statements', server = FALSE)
output$filteredTableOut <- DT::renderDataTable({
# browser()
filteredTable()
}, caption = 'Filtered table', server = FALSE, options = list(pageLength = 20))
}
shinyApp(ui = ui, server = server)
Result:
Edit:
Please also see the more convenient alternative implementation: library(collapsibleTree)

Related

Save edited and reactive Shiny table in R

I'm currently building a Shiny dashboard in R and I'm currently building a mechanism that would allow some user to comment some datatable inside it, and I got this mechanism done and sorted (as you can see on the code below). My problem is when I add the comments and refresh the page, the comments go away (as they should). Is there any way to save the datatable and keep the changes saved for any user to see, even after I refresh the dashboard page?
Thanks if you read this far :)
Please find a reproducible example below:
library(shiny)
library(DT)
dt <- data.table(
ID = c('Order 1','Order 2', 'Order 3', 'Order 4'),
Name = c('John','Peter','Anna','Richard')
)
ui <- fluidPage(
fluidRow(
column(2, pickerInput(inputId = 'selectID',
label = 'Select order ID to comment on:',
choices = c('Order 1','Order 2', 'Order 3', 'Order 4'),
selected='',
multiple=FALSE)),
column(2, textInput(inputId = 'comment',
label ='Please add comment in the text box:',
value = "", width = NULL,
placeholder = NULL))
,
column(1, actionButton(inputId = "button",
label = "Add Comment",
size = "extra-small",
style = "margin-top:25px"
)
)
),
fluidRow(
column(12,
dataTableOutput('data')
)
)
)
server <- function(input, output, session){
dt_comments <- reactiveVal({
data.table(
ID = character(0),
Comment = character(0),
stringsAsFactors = FALSE
)
})
dt_current <- reactive({
dt <- dt
## merge with current comments
if(nrow(dt_comments()) > 0)
dt <- merge(dt, dt_comments(), by = "ID", all.x = TRUE)
return(dt)
})
observeEvent(input$button, {
req(input$selectID)
## update df_comments by adding comments
dt_comments_new <- rbind(dt_comments(),
data.table(ID = input$selectID, Comment = input$comment)
)
## if duplicated id's keep only most recent rows
dt_comments_new <- dt_comments_new[!duplicated(dt_comments_new$ID, fromLast = TRUE), , drop = FALSE]
dt_comments(dt_comments_new)
})
output$data <- DT::renderDataTable({
req(dt_current())
dt2 <- dt_current()
## show comments if non-empty
showComments <- is.null(dt2$Comment) || !all(is.na(dt2$Comment))
DT::datatable(dt2,
editable = TRUE,
options = list(
columnDefs = list(
list(targets = ncol(dt2), visible = showComments)
)
)
)
})
}
shinyApp(ui = ui, server = server)

R Shiny dataTableOutput - prevent column from showing full text column

I have code to present a table in my R Shiny application. There is a character column where the value within a given cell can be a large number of characters. I use the following code to create the table:
output$data_table <- DT::renderDataTable({
req(data_go_go())
data_go_go()
},rownames = FALSE,filter = "top")
Then display the table with:
DT::dataTableOutput("data_table")
This code results in the following table:
You can see the string in the last column is causing the table to extend very far to the right. Is there a way I can prevent the column from displaying the entire string, and let it display the whole text if you hover over the particular cell?
Here is one option, borrowed heavily from this SO answer written by Stéphane Laurent (R shiny DT hover shows detailed table)
library(shiny)
library(DT)
g = data.frame(
TermID = c("GO:0099536", "GO:0009537", "GO:0007268"),
TermLabel = rep("synaptic signaling",times=3),
Reference= c(907,878,869),
Genes=c(78,74,72),
FoldEnrichment=c(13.69,17.11,14.22),
AdjPValue = c(0,0,0),
`Gene Info` = "Gene Information",
GenesDetail= replicate(paste0(sample(c(" ", letters),100,replace=TRUE), collapse=""),n=3)
)
callback <- c(
"table.on('mouseover', 'td', function(){",
" var index = table.cell(this).index();",
" Shiny.setInputValue('cell', index, {priority: 'event'});",
"});"
)
ui <- fluidPage(DTOutput("geneTable"))
server <- function(input, output, session){
output[["geneTable"]] <- renderDT({
datatable(g[,1:7],callback = JS(callback))
})
filteredData <- eventReactive(input[["cell"]], {
if(input[["cell"]]$column == 7){
return(g[input[["cell"]]$row + 1, "GenesDetail", drop = FALSE])
}
})
output[["tblfiltered"]] <- renderDT({
datatable(filteredData(),fillContainer = TRUE, options=list(dom='t'),rownames = F)
})
observeEvent(filteredData(), {
showModal(modalDialog(
DTOutput("tblfiltered"), size = "l",easyClose = TRUE)
)
})
}
shinyApp(ui, server)
The easiest way is to use the ellipsis plugin:
library(DT)
dat <- data.frame(
A = c("fnufnufroufrcnoonfrncacfnouafc", "fanunfrpn frnpncfrurnucfrnupfenc"),
B = c("DZDOPCDNAL DKODKPODPOKKPODZKPO", "AZERTYUIOPQSDFGHJKLMWXCVBN")
)
datatable(
dat,
plugins = "ellipsis",
options = list(
columnDefs = list(list(
targets = c(1,2),
render = JS("$.fn.dataTable.render.ellipsis( 17, false )")
))
)
)

Update reactiveValues in Shiny R

I understand similar questions have been asked and I've tried virtually every solution with no luck.
In my application, I've allowed the user to modify individual cells of a DT::datatable. The source of the datatable is a reactive data frame.
After the user makes changes to the clientside datatable, the datatable source is remains unchanged. This is an issue as later on, when I allow the user to add rows to the data table, the row is added onto the source datatable where the clientside datatable then reflects this change. However, this means that if the user makes a change to a cell in the clientside datatable, when the user adds a row to the same table, the change made by the user will be forgotten as it was never made to the source.
I've tried many ways to update the underlying/serverside datatable with no luck. editData keeps giving me errors/NA. I also have tried indexing the serverside table and placing the changed value inside of it, with no luck. I'll post my code below with some comments for specifics..
library(shiny)
library(DT)
library(data.table)
source('~/camo/camo/R/settings.R')
source('~/camo/camo/etl.R')
# Define UI ----
ui <- fluidPage(
titlePanel("PAlpha"),
mainPanel(
fluidRow(
tabsetPanel(id = 'tpanel',
type = "tabs",
tabPanel("Alpha", plotOutput("plot1")),
tabPanel("Beta", plotOutput("plot2")),
tabPanel("Charlie", plotOutput("plot3")),
tabPanel("Delta", plotOutput("plot4")))
),
fluidRow(
splitLayout(
dateInput("sdate", "Start Date"),
dateInput("edate", "End Date"),
textInput("gmin", "Global Minimum"),
textInput("gmax", "Global Maximum")
)
),
fluidRow(
splitLayout(
textInput("groupInp", NULL, placeholder = "New Group"),
actionButton("addGrpBtn", "Add Group"),
textInput("tickerInp", NULL, placeholder = "New Ticker"),
actionButton("addTickerBtn", "Add Ticker")
)
),
fluidRow(
splitLayout(
DT::dataTableOutput('groupsTable'),
DT::dataTableOutput('groupTickers')
),
verbatimTextOutput("print")
)
)
)
# Define server logic ----
server <- function(input, output) {
port_proxy <- dataTableProxy('groupsTable')
rv <- reactiveValues(
portfolio = data.frame('Group' = c('Portfolio'), 'Minimum Weight' = c(0), 'Maximum Weight' = c(0), 'Type' = c('-')),
groups = list(group1 = data.frame('Group' = c('Ticker'), 'Minimum Weight' = c(0), 'Maximum Weight' = c(0), 'Type' = c('-'))),
deletedRows = NULL,
deletedRowIndices = list()
)
output$groupsTable <- DT::renderDataTable(
# Add the delete button column
deleteButtonColumn(rv$portfolio, 'delete_button')
)
output$print <- renderPrint({
rv$portfolio
})
############## LISTENERS ################
observeEvent(input$deletePressed, {
rowNum <- parseDeleteEvent(input$deletePressed)
dataRow <- rv$portfolio[rowNum,]
# Put the deleted row into a data frame so we can undo
# Last item deleted is in position 1
rv$deletedRows <- rbind(dataRow, rv$deletedRows)
rv$deletedRowIndices <- append(rv$deletedRowIndices, rowNum, after = 0)
# Delete the row from the data frame
rv$portfolio <- rv$portfolio[-rowNum,]
})
observeEvent(input$addGrpBtn, {
row <- data.frame('Group' = c(input$groupInp),
'Minimum Weight' = c(0),
'Maximum Weight' = c(0),
'Type' = c('-'))
rv$portfolio <- addRowAt(rv$portfolio, row, nrow(rv$portfolio))
})
observeEvent(input$groupsTable_cell_edit,{
info <- str(input$groupsTable_cell_edit)
i <- info$row
j <- info$col
v <- info$value
rv$portfolio <- editData(rv$portfolio, input$groupsTable_cell_edit) # doesn't work see below
# Warning in DT::coerceValue(v, data[i, j, drop = TRUE]) :
# New value(s) "test" not in the original factor levels: "Portfolio"; will be coerced to NA.
# rv$portfolio[i,j] <- input$groupsTable_cell_edit$value
# rv$portfolio[i,j] <- v #doesn't work
})
}
addRowAt <- function(df, row, i) {
# Slow but easy to understand
if (i > 1) {
rbind(df[1:(i - 1), ], row, df[-(1:(i - 1)), ])
} else {
rbind(row, df)
}
}
deleteButtonColumn <- function(df, id, ...) {
# function to create one action button as string
f <- function(i) {
# https://shiny.rstudio.com/articles/communicating-with-js.html
as.character(actionLink(paste(id, i, sep="_"), label = 'Delete', icon = icon('trash'),
onclick = 'Shiny.setInputValue(\"deletePressed\", this.id, {priority: "event"})'))
}
deleteCol <- unlist(lapply(seq_len(nrow(df)), f))
# Return a data table
DT::datatable(cbind(' ' = deleteCol, df),
# Need to disable escaping for html as string to work
escape = FALSE,
editable = 'cell',
selection = 'single',
rownames = FALSE,
class = 'compact',
options = list(
# Disable sorting for the delete column
dom = 't',
columnDefs = list(list(targets = 1, sortable = FALSE))
))
}
parseDeleteEvent <- function(idstr) {
res <- as.integer(sub(".*_([0-9]+)", "\\1", idstr))
if (! is.na(res)) res
}
# Run the app ----
shinyApp(ui = ui, server = server)
As far as I have looked, there is no ready-to-go solution available. You could try to use rhandsontable. It does not provide all the functionality of the DT table, however it allows for the editing. Last time I tried using it there were some minor issues in some edge cases. (Trying to save different data type or something similar.)
Alternatively you can do the stuff manually, along these lines. This is the minimal working example of editing the underlying data frame. Currently I overwrite it every time the user clicks on the table, you would need to change that to handle normal user behavior. It is meant merely as a proof of concept.
library(DT)
library(shiny)
ui <- fluidPage(
DT::dataTableOutput("test")
)
myDF <- iris[1:10,]
js <- c("table.on('click.dt','tr', function() {",
" var a = table.data();",
" var data = []",
" for (i=0; i!=a.length; i++) {",
" data = data.concat(a[i]) ",
" };",
"Shiny.setInputValue('dataChange', data)",
"})")
server <- function(input, output) {
output$test <- DT::renderDataTable(
myDF,
editable='cell',
callback=JS(js)
)
observeEvent(input$dataChange, {
res <- cbind.data.frame(split(input$dataChange, rep(1:6, times=length(input$dataChange)/6)),
stringsAsFactors=F)
colNumbers <- res[,1]
res <- res[,2:ncol(res)]
colnames(res) <- colnames(myDF)
myDF <<- res
print(myDF)
})
}
shinyApp(ui = ui, server = server)

Shiny: Using selections from timevis to highlight rows in data table

I am building a shiny app with a timeline and a data table. What I would like to have happen is when the user clicks on an item in the timeline, the corresponding data in the table is highlighted.
I have come up with a solution for this, but it seems very hacky and R is giving me warning messages. Basically what I have done is created a flag in the data table that is 1 if that item is selected and 0 if it's not, then I format the row based on that flag. When I create the "selected" field, I get a warning because initially nothing is selected and mutate doesn't like the fact that input$timeline_selected is NULL. Also for some reason when I try to add the rownames = FALSE argument to datatable all the data in the table is filtered out (not sure what is happening there).
Anyway, I'm wondering if there is a better way to do this perhaps with HTML or CSS. I've tried looking, but I can't figure out how to do it.
Eventually I would also like to know how to highlight the rows in the data table if the user hovers over the item in the timeline rather than selects it.
library(shiny)
library(DT)
library(dplyr)
dataBasic <- data.frame(
id = 1:4,
content = c("Item one", "Item two" ,"Ranged item", "Item four"),
start = c("2016-01-10", "2016-01-11", "2016-01-20", "2016-02-14"),
end = c(NA, NA, "2016-02-04", NA)
)
ui <- fluidPage(
column(wellPanel(timevisOutput("timeline")
), width = 7
),
column(wellPanel(dataTableOutput(outputId = "table")
), width = 5)
)
server <- function(input, output){
# Create timeline
output$timeline <- renderTimevis({
config <- list(
orientation = "top",
multiselect = TRUE
)
timevis(dataBasic, options = config)
})
output$table <- DT::renderDataTable({
input$timeline_data %>%
mutate(selected = if_else(id %in% input$timeline_selected, 1, 0)) %>%
datatable(options = list(pageLength = 10,
columnDefs = list(list(targets = 5, visible = FALSE))
)
) %>%
formatStyle("selected", target = "row", backgroundColor = styleEqual(c(0, 1), c("transparent", "#0092FF"))
)
})
}
shinyApp(ui = ui, server = server)
Using Your Code
Your method certainly works -- it's similar to this answer. You could prevent some of the error messages by using if...else and a validation statment:
output$table <- DT::renderDataTable({
validate(need(!is.null(input$timeline_data), ""))
if(is.null(input$timeline_selected)) {
input$timeline_data %>%
datatable(
rownames = FALSE,
options = list(pageLength = 10))
} else {
input$timeline_data %>%
mutate(selected = if_else(id %in% input$timeline_selected, 1, 0)) %>%
datatable(rownames = FALSE,
options = list(pageLength = 10,
columnDefs = list(list(targets = 4, visible = FALSE))
)
) %>%
formatStyle("selected", target = "row", backgroundColor = styleEqual(c(0, 1), c("transparent", "#0092FF"))
)
}
})
I believe your issue with adding rownames = FALSE is because columnDefs uses JS indexing instead of R indexing. R indexes start at 1, whereas JS indexes start at 0.
When rownames = TRUE, your table has column indexes 0-5, where rownames is column 0 and selected is the column 5. So columnDefs works. However, when rownames = FALSE, you only have column indexes 0-4, so targets = 5 is outside the index range of your table. If you change your code to targets = 4, then you will again be specifying the selected column in columnDefs.
Other Options
Here's two other options using JS:
Generate the table on the server-side, as based on this answer. This may be a better option for large data objects.
Generate the table on the client-side as based on this answer. With a smaller object, this seems to update more smoothly.
An example app with both tables is below.
Example Code
library(shiny)
library(DT)
library(dplyr)
library(timevis)
dataBasic <- data.frame(
id = 1:4,
content = c("Item one", "Item two" ,"Ranged item", "Item four"),
start = c("2016-01-10", "2016-01-11", "2016-01-20", "2016-02-14"),
end = c(NA, NA, "2016-02-04", NA)
)
ui <- fluidPage(
column(wellPanel(timevisOutput("timeline")
), width = 7
),
column(
wellPanel(
h3("Client-Side Table"),
DT::dataTableOutput("client_table"),
h3("Server-Side Table"),
DT::dataTableOutput("server_table")
), width = 5)
)
server <- function(input, output, session){
# Create timeline
output$timeline <- renderTimevis({
config <- list(
orientation = "top",
multiselect = TRUE
)
timevis(dataBasic, options = config)
})
## client-side ##
# based on: https://stackoverflow.com/a/42165876/8099834
output$client_table <- DT::renderDataTable({
# if timeline has been selected, add JS drawcallback to datatable
# otherwise, just return the datatable
if(!is.null(input$timeline_selected)) {
# subtract one: JS starts index at 0, but R starts index at 1
index <- as.numeric(input$timeline_selected) - 1
js <- paste0("function(row, data) {
$(this
.api()
.row(", index, ")
.node())
.css({'background-color': 'lightblue'});}")
datatable(dataBasic,
rownames = FALSE,
options = list(pageLength = 10,
drawCallback=JS(js)))
} else {
datatable(dataBasic,
rownames = FALSE,
options = list(pageLength = 10))
}
}, server = FALSE)
## server-side ##
# based on: https://stackoverflow.com/a/49176615/8099834
output$server_table <- DT::renderDataTable({
# create the datatable
dt <- datatable(dataBasic,
rownames = FALSE,
options = list(pageLength = 10))
# if timeline has been selected, add row background colors with formatstyle
if(!is.null(input$timeline_selected)) {
index <- as.numeric(input$timeline_selected)
background <- JS(paste0("value == '",
index,
"' ? 'lightblue' : value != 'else' ? 'white' : ''"))
dt <- dt %>%
formatStyle(
'id',
target = 'row',
backgroundColor = background)
}
# return the datatable
dt
})
}
shinyApp(ui = ui, server = server)

R Shiny dynamic DT Datatable remember filters/sorting

I'm building a R Shiny app with a dynamic datatable, using the DT package. Users are able to select two columns within a data.frame that contains more columns.
When users select a column, the datatable is updated and all filters/sorting are reset to default within the datatable object. How can I let the application remember filters and sorting when the given column is not replaced by the user?
Minimal working example below:
library(shiny)
library(DT)
library(data.table)
server <- function(input, output) {
df <- data.frame(
name = rep('a',20),
dimA = 1:20,
dimB = 21:40,
dimC = 41:60
)
observe({
columns <- c('name', input$dim1ID, input$dim2ID)
dfDt <- df[names(df) %in% columns]
output$dtDataTable = DT::renderDataTable(
server = FALSE,
expr = datatable(
dfDt,
filter = 'top',
rownames = FALSE,
selection = 'none',
options = list(sDom = '<"top">rt<"bottom">ip')
)
)
})
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
## Dimension 1
selectInput(
inputId = "dim1ID",
label = "Dimensie 1",
choices = c('dimA', 'dimB', 'dimC'),
selected = 'dimA'
),
## Dimension 2
selectInput(
inputId = "dim2ID",
label = "Dimensie 2",
choices = c('dimA', 'dimB', 'dimC'),
selected = 'dimB'
)
),
mainPanel(DT::dataTableOutput('dtDataTable'))
)
)
shinyApp(ui = ui, server = server)
This can be done using the DataTables Information, in particular the "state" information (input$tableId_state) which contains the order information of the current table, and input$tableId_search_columns which contains the filtering information by columns. If the columns are fixed (ie in the example above "Dimensie 1" and "Dimensie 2" would always be at the same place), it is much simpler to "remember" which one was ordered (unlike the original example where they are alphabetically reordered when the table is created). For instance based on the above example, the following will work if you sort the "A" column and change the right column from "B" to "C" and back:
library(shiny)
library(DT)
library(data.table)
server <- function(input, output) {
df <- data.frame(
name = rep('a',20),
dimA = 1:20,
dimB = 21:40,
dimC = 41:60
)
values <- reactiveValues(
prevDim1 = "",
prevDim2 = "",
options = list(sDom = '<"top">rt<"bottom">ip',
stateSave = TRUE,
order = list())
)
observeEvent(input$dtDataTable_state$order, {
values$options$order <- input$dtDataTable_state$order
})
observeEvent({
input$dim1ID
input$dim2ID
},{
columns <- c('name', input$dim1ID, input$dim2ID)
dfDt <- df[names(df) %in% columns]
if(length(values$options$order) != 0 && ((values$prevDim1 != input$dim1ID && values$options$order[[1]][[1]] == 1) | (values$prevDim2 != input$dim2ID && values$options$order[[1]][[1]] == 2)) ){
values$options$order = list()
}
values$prevDim1 <- input$dim1ID
values$prevDim2 <- input$dim2ID
output$dtDataTable = DT::renderDataTable(
server = FALSE,
expr = datatable(
dfDt,
filter = 'top',
rownames = FALSE,
selection = 'none',
options = values$options
)
)
})
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
## Dimension 1
selectInput(
inputId = "dim1ID",
label = "Dimensie 1",
choices = c('dimA', 'dimB', 'dimC'),
selected = 'dimA'
),
## Dimension 2
selectInput(
inputId = "dim2ID",
label = "Dimensie 2",
choices = c('dimA', 'dimB', 'dimC'),
selected = 'dimB'
)
),
mainPanel(DT::dataTableOutput('dtDataTable'))
)
)
shinyApp(ui = ui, server = server)

Resources