datatable row focus after editing - r

I'm using the datatables package in a shiny app and its working well, but when i edit a cell/value the focus changes from the current row to the first row. The table is long so having to scroll back to the row being edited is a problem. Is there a way of selecting a certain row? then I can return to the row being edited after the table reloads.
Here's the code for the datatable render in shiny. Any suggestions please?
output$book_table <- DT::renderDT(RVTables$book %>%
filter(deal == as.numeric(input$deal_choice)),
selection = 'single',
editable = TRUE,
rownames = FALSE,
options = list(
autoWidth = TRUE,
ordering = FALSE,
pageLength = 12,
scrollX = TRUE,
scrollY = TRUE,
bLengthChange = FALSE,
searching = FALSE
)
)
edit:
I found a way of selecting a row, but I can't dynamically update it.
row_edit<-3
output$book_table <- DT::renderDT(RVTables$book %>%
filter(deal == as.numeric(input$deal_choice)),
selection = list(mode='single',selected=row_edit)
editable = TRUE,
rownames = FALSE,
options = list(
autoWidth = TRUE,
ordering = FALSE,
pageLength = 12,
scrollX = TRUE,
scrollY = TRUE,
bLengthChange = FALSE,
searching = FALSE
)
)
and using a global assignment in the edit event also hasn't worked:
row_edit<<- 22
EDIT
Here's a sample app to show what I'm trying to do.
Edit row 42 for example an see how the next row highlighted is back on the first page, which is annoying if you want to edit a single value multiple times to see the effect.
library(shiny)
library(shinyjs)
library(tidyverse)
library(DT) #load after shiny
data_input <- data.frame(ID=seq(1,50),
weight=sample(50:65,50,replace = TRUE),
height=sample(150:225,50,replace = TRUE)
)
#shiny---
shinyApp(
#ui----
ui= fluidPage(
fluidRow(
br(),
column(2,
actionButton("increase_weight","increase weight"),
uiOutput("show_row_selected"),
uiOutput("last_row_selected")
),
column(4,DT::DTOutput("data_table"))
)
),
server=function(input,output,session){
#save data frame as a reactive value
RV <- reactiveValues(
data=data_input
)
#try to save last row selected----
row_select <- reactive({
#case when code below fails, use row 3 to illustrate code
3
#uncomment code below and run to see error
# case_when(
# #valid row selected
# length(input$data_table_rows_selected)>0 ~ as.numeric(input$data_table_rows_selected),
# #after update, row object is empty to use last selected row
# #this is now recursive and app fails - "evaluation nested too deeply: infinite recursion...."
# length(input$data_table_rows_selected)==0 ~ row_select()
# )
})
#render data frame for output
output$data_table <- DT::renderDT(RV$data,
selection = list(mode="single",selected=row_select()),
editable = TRUE,
rownames = FALSE,
options=list(
autoWidth=TRUE,
scrollX = TRUE,
ordering=FALSE,
pageLength=12,
scrollY = TRUE,
bLengthChange= FALSE,
searching=FALSE
)
)
#edit a single cell----
observeEvent(input$data_table_cell_edit, {
info <- input$data_table_cell_edit
edit_row <- info$row
edit_col <- info$col+1 # column index offset by 1
edit_value <- info$value
#find leg to be edited
ID <- edit_row
RV$data[ID,edit_col] <-as.numeric(edit_value)
})
#increase weight by one----
observeEvent(input$increase_weight, {
edit_row <- input$data_table_rows_selected
RV$data[edit_row,"weight"] <- RV$data[edit_row,"weight"]+1
})
#show current row selected----
output$show_row_selected <- renderText({
paste0("row selected: ",as.character(as.numeric(input$data_table_rows_selected)))
})
#show last row selected----
output$last_row_selected <- renderText({
paste0("row selected: ",as.character(row_select()))
})
})

With help from this question, here's some code which works.
library(shiny)
library(shinyjs)
library(tidyverse)
library(DT) #load after shiny
data_input <- data.frame(ID=seq(1,50),
weight=sample(50:65,50,replace = TRUE),
height=sample(150:225,50,replace = TRUE)
)
#shiny---
shinyApp(
#ui----
ui= fluidPage(
fluidRow(
br(),
column(2,
actionButton("increase_weight","increase weight"),
uiOutput("show_row_selected")
),
column(4,DT::DTOutput("data_table"))
)
),
server=function(input,output,session){
#save data frame as a reactive value
RV <- reactiveValues(
data=data_input
)
previousSelection <- NULL
previousPage <- NULL
#render data table
output$data_table <- DT::renderDataTable({
DT::datatable(
RV$data,
editable = TRUE,
selection = list(mode = "single", target = "row", selected = previousSelection),
options = list(
autoWidth=TRUE,
scrollX = TRUE,
pageLength = 10,
displayStart = previousPage))
})
#edit a single cell----
observeEvent(input$data_table_cell_edit, {
info <- input$data_table_cell_edit
edit_row <- info$row
edit_col <- info$col
edit_value <- info$value
previousSelection <<- input$data_table_rows_selected
previousPage <<- input$data_table_rows_current[1] - 1
#find leg to be edited
RV$data[edit_row,edit_col] <-as.numeric(edit_value)
})
#increase weight by one----
observeEvent(input$increase_weight, {
edit_row <- input$data_table_rows_selected
previousSelection <<- input$data_table_rows_selected
previousPage <<- input$data_table_rows_current[1] - 1
RV$data[edit_row,"weight"] <- RV$data[edit_row,"weight"]+1
})
#show current row selected----
output$show_row_selected <- renderText({
paste0("row selected: ",as.character(as.numeric(input$data_table_rows_selected)))
})
})

Related

Having isolated or non-reactive columns inside of a reactive dataframe

I have a reactive dataframe (called selected_df()) in which I am trying to consolidate information from input$tableID_cells_selected and another dataframe.
The second reactive dataframe, called storage_df(), is 1 row and 2 columns. It collects the background color and text labels from action buttons that are pressed, and then that data stays static in storage_df() until a different button is pressed.
selected_df() then collects the info about whatever button was last pressed from storage_df() when a cell in the table is selected (or whenever input$plate_cells_selected is updated), and shows these data in the same row.
The problem is that the selected_df() must reference storage_df() inside of the reactive environment, so it updates all of the values in the cond_selected and color_selected columns from selected_df(). I don't want to have those old values from storage_df() updated and replaced with whatever new values exist in storage_df(). I want those old rows of selected_df() to keep those old values, and for the new rows of selected_df() to have the new values of storage_df(). So basically, storage)df() is updated upon button click, as it is reactive, but the references to storage_df() made by selected_df() would not be reactive.
I have a gif here that will hopefully explain what I am trying to do, in case this is confusing. This is a previous attempt but it is the closest that I have gotten to success. In the gif, the color and cond columns of selected_df() are set such as follows for example: cond_selected = isolate(paste0(rep(storage_df()[[1,2]]))), so that value changes when a new button is pressed. The first three rows of column cond_selected within selected_df() should ideally stay gse1, while the latter three rows should be cox8a. As you can see, this is not what happens.
In other words, this is what I have in these columns at the end of this gif:
And this is what I want in these columns:
With my latest attempt (included in my MRE). I thought if I were to only try to update the values of the last added row, as I think the selected_df() might be appended whenever a new cell is selected, then that might work. However, the app crashes and only gives this warning, which it usually gave because selected_df() had no rows before a cell was selected:
Warning: Error in [: subscript out of bounds
Also, here is my MRE and latest attempt, and what I currently need help trying to figure out:
library(shiny)
library(colourpicker)
library(dplyr)
library(DT)
library(glue)
library(shinyWidgets)
####Create the matrix and organization for the 96 well plate####
plate96 <- function(id) {
div(
style = "position: relative; height: 500px",
tags$style(HTML('
.wells {
transform: translateX(50%);
}
.wells table.dataTable tr:nth-child(9) td { /*for the row 9, need to make it not look like a row*/
border-bottom: unset;
}
.wells tbody tr td:not(:first-of-type) {
border: 1px solid black;
height: 15px;
width: 15px;
padding: 15px;
font-size: 0;
}
')),
div(
style = "position: absolute; left: 50%; transform: translateX(-100%);",
div(
class = "wells",
DTOutput(id, width = "90%", height= "100%")
)
)
)
}
####Create the matrix and organization for the 96 well plate####
renderPlate96 = function(id, colors = rep("white", 108)) {
plate <- matrix(1:108,
nrow = 9,
ncol = 12,
byrow = TRUE,
dimnames = list(LETTERS[1:9], 1:12))
colnames (plate) = stringr::str_pad(colnames(plate), 2, "left", "0")
return(plate_return1 <-
datatable(
plate,
options = list(dom = 't', ordering = F),
selection = list(mode = 'multiple',
target = "cell"),
class = 'cell-border compact'
) %>%
formatStyle(
1:12,
cursor = 'pointer',
backgroundColor = styleEqual(1:108, colors, default = NULL)
)
)
}
storage_df <- (data.frame(
matrix(ncol = 2, nrow = 1),
color_selected = NA,
cond_selected = NA
))
# app code
ui <- fluidPage(
plate96("plate"),
tags$b("Wells Selected:"),
verbatimTextOutput("plateWells_selected"),
br(),
helpText("Step 1: Add in a couple of buttons"),
numericInput("num_conds",
label = h3("Enter the number of treatments/ conditions"),
min = 1,
max = 20,
value = 1),
htmlOutput("cond_buttons", align = 'center'),
helpText("Step 2: Type in any name for a condition for the buttons"),
uiOutput("boxes_conds"),
helpText("Step 3: Choose any color for the buttons"),
uiOutput("cond_colors"),
helpText("Step 4: Select cells from the table above"),
DT::dataTableOutput("selected_table"),
DT::dataTableOutput("storage_table"),
)
server <- function(input, output, session){
### ★★ ↓↓↓↓ PROBLEM AREA ↓↓↓↓ ★★ ###
####Storage data.frame for when the buttons are clicked####
observeEvent(input$num_conds, {
lapply(1:input$num_conds, function(x){
observeEvent(input[[paste0("cond_buttons",x)]], {
newdf <- tibble(
color_selected = input[[paste0("colors",x)]],
cond_selected = input[[paste0("condID",x)]]
)
storage_df(newdf)
})
})
})
storage_df <- reactiveVal(tibble::tribble(
~color_selected, ~cond_selected
))
output$storage_table <- renderDataTable(
req(storage_df()),
options = list(paging = FALSE,
ordering = FALSE,
scrollx = FALSE,
searching = FALSE,
stringsAsFactors = FALSE
)
)
####Create a DT that stores the values of the cells selected in the plate####
selected_df <- reactive(data.frame(rows = req(input$plate_cells_selected[,1]),
columns = req(input$plate_cells_selected[,2]),
color_selected = 0,
cond_selected = 0,
stringsAsFactors = FALSE),
)
####Take out this portion of the code if trying to reproduce my GIF###
observeEvent(input$plate_cells_selected, {
selected_df() %>% mutate(selected_df(), color_selected = replace(color_selected, color_selected== '0', isolate(paste0(rep(storage_df()[[1,1]]))))
)})
####Take out this portion of the code if trying to reproduce my GIF###
output$selected_table <- renderDataTable(
req(selected_df()),
options = list(paging = FALSE,
ordering = FALSE,
scrollx = FALSE,
searching = FALSE,
lengthChange = FALSE
)
)
### ★★ ↑↑↑↑ PROBLEM AREA ↑↑↑↑ ★★ ###
#....#
#Past here isn't as important to the question...#
####Input for user browse and data upload####
output$contents <- renderTable({ req(input$data) })
#####Slider for frames per second####
output$value <- renderPrint({ input$Frames })
#####Check boxes for no-movement cell exclusion####
output$value <- renderPrint({ input$emptyWell_checkbox })
#####Number output for number of conditions#####
output$value <- renderPrint({ input$num_conds })
#### Condition boxes for UI text input####
output$boxes_conds <- renderUI({
num_conds = as.integer(input$num_conds)
lapply(1:num_conds, function(i) {
cond_names <- textInput(paste0("condID", i),
label = paste0("Treatment/ Conditions: ", i),
placeholder = "Enter condition..."
)
})
})
#### Color selection for UI input####
output$cond_colors <- renderUI({
num_conds = as.integer(input$num_conds)
lapply(1:num_conds, function(i) {
colourInput(paste0("colors", i),
label = (paste0("Select a color for condition ", i)),
show = c("both"),
value = "black",
palette = c("limited"),
)
})
})
#### Create action buttons for conditions to be selected####
output$cond_buttons <- renderUI({
num_conds = as.integer(input$num_conds)
lapply(1:num_conds, function(i) {
bg = input[[paste0("colors", i)]]
style = paste0(
collapse = " ",
glue("background-color:{bg};
color:#ffffff;
border-color:#000000")
)
label = input[[paste0("condID", i)]]
actionButton(paste0("cond_buttons", i),
label = label,
style = style,
)
})
})
####Create the 96 well plate image####
output$plate <- renderDT({
renderPlate96()
})
output$plateWells_selected <- renderPrint({
input$plate_cells_selected
})
}
shinyApp(ui = ui, server = server)
UPDATE UPON REQUEST
Here is a portion of the code needed to reproduce what you see in the GIF. This is not my latest attempt and is not what I need help with troubleshooting, this is merely to give what I used to make the GIF that explains what I want. Just replace the similar version of the code with this in my MRE and take out the mutate function. The mutate function to remove has been marked by comments in my MRE.
####Create a DT that stores the values of the cells selected in the plate####
selected_df <- reactive(data.frame(rows = req(input$plate_cells_selected[,1]),
columns = req(input$plate_cells_selected[,2]),
color_selected = isolate(paste0(rep(storage_df()[[1,1]]))),
cond_selected = isolate(paste0(rep(storage_df()[[1,2]]))),
stringsAsFactors = FALSE)
)
UPDATE, REPONSE TO YBS
Try this
# app code
ui <- fluidPage(
plate96("plate"),
tags$b("Wells Selected:"),
verbatimTextOutput("plateWells_selected"),
br(),
helpText("Step 1: Add in a couple of buttons"),
numericInput("num_conds",
label = h3("Enter the number of treatments/ conditions"),
min = 1,
max = 20,
value = 1),
htmlOutput("cond_buttons", align = 'center'),
helpText("Step 2: Type in any name for a condition for the buttons"),
uiOutput("boxes_conds"),
helpText("Step 3: Choose any color for the buttons"),
uiOutput("cond_colors"),
helpText("Step 4: Select cells from the table above"),
DTOutput("selected_table"),
DTOutput("storage_table"),
)
server <- function(input, output, session){
### ★★ ↓↓↓↓ PROBLEM AREA ↓↓↓↓ ★★ ###
# storage_df <- reactiveVal(tibble::tribble(
# ~color_selected, ~cond_selected
# ))
storage_df <- reactiveVal(storage)
####Storage data.frame for when the buttons are clicked####
observeEvent(input$num_conds, {
lapply(1:input$num_conds, function(x){
observeEvent(input[[paste0("cond_buttons",x)]], {
newdf <- data.frame(
color_selected = input[[paste0("colors",x)]],
cond_selected = input[[paste0("condID",x)]]
)
storage_df(newdf)
}, ignoreInit = TRUE)
})
})
output$storage_table <- renderDataTable(
req(storage_df()),
options = list(paging = FALSE,
ordering = FALSE,
scrollx = FALSE,
searching = FALSE,
stringsAsFactors = FALSE
)
)
selected <- reactiveValues(df=NULL,cum=NULL)
df1 <- data.frame()
observeEvent(input$plate_cells_selected, {
n = dim(req(input$plate_cells_selected))[1]
df1 <<- data.frame(rows = req(input$plate_cells_selected[,1]), columns = req(input$plate_cells_selected[,2]))
###Create a DT that stores the values of the cells selected in the plate####
selected$cum <- rbind(selected$df,data.frame(rows = input$plate_cells_selected[n,1],
columns = input$plate_cells_selected[n,2],
color_selected = storage_df()[1,1], cond_selected = storage_df()[1,2]))
}, ignoreNULL=FALSE)
observeEvent(selected$cum, {
n1 = dim(df1)[1]
n2 = dim(selected$cum)[1]
if (n1 > n2) { ## add a row
df <- selected$cum
}else df <- left_join(df1, selected$cum, by=c("rows","columns"))
selected$df <- df[!duplicated(df[,1:2]),]
#print(selected$df)
})
####Create a DT that stores the values of the cells selected in the plate####
# selected_df <- reactive(data.frame(rows = req(input$plate_cells_selected[,1]),
# columns = req(input$plate_cells_selected[,2]),
# stringsAsFactors = FALSE) %>% mutate(color_selected = c(0), cond_selected = c(0))
# )
output$selected_table <- renderDT(
#selected_df(),
selected$df,
options = list(paging = FALSE,
ordering = FALSE,
scrollx = FALSE,
searching = FALSE,
lengthChange = FALSE
)
)
### ★★ ↑↑↑↑ PROBLEM AREA ↑↑↑↑ ★★ ###
#....#
#Past here isn't as important to the question...#
####Input for user browse and data upload####
output$contents <- renderTable({ req(input$data) })
#####Slider for frames per second####
output$value <- renderPrint({ input$Frames })
#####Check boxes for no-movement cell exclusion####
output$value <- renderPrint({ input$emptyWell_checkbox })
#####Number output for number of conditions#####
output$value <- renderPrint({ input$num_conds })
#### Condition boxes for UI text input####
output$boxes_conds <- renderUI({
num_conds = as.integer(input$num_conds)
lapply(1:num_conds, function(i) {
cond_names <- textInput(paste0("condID", i),
label = paste0("Treatment/ Conditions: ", i),
placeholder = "Enter condition..."
)
})
})
#### Color selection for UI input####
output$cond_colors <- renderUI({
num_conds = as.integer(input$num_conds)
lapply(1:num_conds, function(i) {
colourInput(paste0("colors", i),
label = (paste0("Select a color for condition ", i)),
show = c("both"),
value = "black",
palette = c("limited"),
)
})
})
#### Create action buttons for conditions to be selected####
output$cond_buttons <- renderUI({
num_conds = as.integer(input$num_conds)
lapply(1:num_conds, function(i) {
bg = input[[paste0("colors", i)]]
style = paste0(
collapse = " ",
glue("background-color:{bg};
color:#ffffff;
border-color:#000000")
)
label = input[[paste0("condID", i)]]
actionButton(paste0("cond_buttons", i),
label = label,
style = style,
)
})
})
####Create the 96 well plate image####
output$plate <- renderDT({
renderPlate96()
})
output$plateWells_selected <- renderPrint({
input$plate_cells_selected
})
}
shinyApp(ui = ui, server = server)

How to use the data rendered in output through DT::renderDataTable for plotting

I have created a datatable with renderDT and reactive functions, in order to change the table with selectInputs. Now I want to plot a geom_line graphic with the datatable created and have a reactive dashboard that have to change with the same selectInputs, but I don't know how. If you have some ideas please share. In addition I want to have no default selection in my selectInputs.
Here is the code:
library(shiny)
library(DT)
library(dplyr)
library(shinyWidgets)
library(tidyverse)
library(lubridate)
library(timetk)
library(ggplot2)
library(rJava)
library(xlsx)
library(graphics)
data_1 <-mtcars
# User Interface
ui <- fluidPage(
titlePanel("My dashboard"),
sidebarLayout(
sidebarPanel(
selectInput('filter_gear', 'gear', choices = NULL, selected = NULL, multiple = FALSE, selectize = FALSE, width = NULL, size = NULL),
selectInput('filter_carb', 'carb', choices = NULL, selected = NULL, multiple = FALSE, selectize = FALSE, width = NULL, size = NULL),
selectInput('filter_cyl', 'cyl', choices = NULL, selected = NULL, multiple = FALSE, selectize = FALSE, width = NULL, size = NULL)
),
mainPanel(
tabsetPanel(id="mydash", type= "tabs",
tabPanel("Plot", plotOutput("fig"), plotOutput("fig2"), plotOutput("fig3")),
tabPanel("Tables", p(DTOutput('databasedf')))
)
)
)
)
server <- function(input, output, session) {
filterdf <- reactive({
filterdf <- data_1
filterdf <- droplevels.data.frame(filterdf)
return(filterdf)
})
filtergear <- reactive({
unique(as.character(filterdf()$gear))
})
observeEvent(filtergear(), {
updateSelectInput(session,
"filter_gear",
choices = filtergear(),
selected = sort(filtergear()))
})
# # Subset dynamically the previous reactive filter #
datasub1 <- reactive({
data_1[data_1$gear %in% input$filter_gear,]
})
filtercarb <- reactive({
unique(as.character(datasub1()$carb))
})
observeEvent(filtercarb(), {
updateSelectInput(session,
"filter_carb",
choices = sort(filtercarb()),
selected = sort(filtercarb()))
})
# Subset dynamically the previous reactive filter #
datasub2 <- reactive({
# browser()
data_1[data_1$carb %in% input$filter_carb,]
})
filtercyl <- reactive({
unique(as.character(datasub2()$cyl))
})
observeEvent(filtercyl(), {
updateSelectInput(session,
"filter_cyl",
choices = sort(filtercyl()),
selected = sort(filtercyl()))
})
output$databasedf <- DT::renderDT({
# Subset for plotly reactivity
Filter1 <- droplevels.data.frame(data_1)
Filter2 <- filter(Filter1,
Filter1$gear %in% input$filter_gear,
Filter1$carb %in% input$filter_carb,
Filter1$cyl %in% input$filter_cyl)
# Plot
datatable(Filter2,
filter="none",
selection="none",
escape=FALSE,
rownames = FALSE,
# colnames = c("", ""),
autoHideNavigation = TRUE,
style = 'bootstrap4',
options = list(searching = FALSE, # remove search option
ordering = FALSE, # remove sort option
paging = FALSE, # remove paging
info = FALSE # remove bottom information
)) %>%
formatStyle(columns = 1, fontWeight = 'bold', `text-align` = 'left') # text to bold and lign left in first column
})
output$fig <-renderPlot({
plt <- addDataFrame(Filter2, sheet, col.names=TRUE, row.names=TRUE, startRow=1, startColumn=1)
fig <- plt %>% ggplot() + geom_line(aes(x=hp, y=mean(mpg), color=am)) })
}
shinyApp(ui, server)
I defined Filter2 outside renderDT to allow renderPlot find it. I left plt commented. I tried to leave the app without major changes. The req s before ggplot are to avoid an error at the start (because the inputs are not updated yet with the select options).
library(shiny)
library(DT)
library(dplyr)
library(shinyWidgets)
library(tidyverse)
library(lubridate)
library(timetk)
library(ggplot2)
library(rJava)
library(xlsx)
library(graphics)
data_1 <- mtcars
# User Interface
ui <- fluidPage(
titlePanel("My dashboard"),
sidebarLayout(
sidebarPanel(
selectInput('filter_gear', 'gear', choices = NULL, selected = NULL, multiple = FALSE, selectize = FALSE, width = NULL, size = NULL),
selectInput('filter_carb', 'carb', choices = NULL, selected = NULL, multiple = FALSE, selectize = FALSE, width = NULL, size = NULL),
selectInput('filter_cyl', 'cyl', choices = NULL, selected = NULL, multiple = FALSE, selectize = FALSE, width = NULL, size = NULL)
),
mainPanel(
tabsetPanel(id="mydash", type= "tabs",
tabPanel("Plot", plotOutput("fig"), plotOutput("fig2"), plotOutput("fig3")),
tabPanel("Tables", p(DTOutput('databasedf')))
)
)
)
)
server <- function(input, output, session) {
filterdf <- reactive({
filterdf <- data_1
filterdf <- droplevels.data.frame(filterdf)
return(filterdf)
})
filtergear <- reactive({
unique(as.character(filterdf()$gear))
})
observeEvent(filtergear(), {
updateSelectInput(session,
"filter_gear",
choices = filtergear(),
selected = sort(filtergear()))
})
# # Subset dynamically the previous reactive filter #
datasub1 <- reactive({
data_1[data_1$gear %in% input$filter_gear,]
})
filtercarb <- reactive({
unique(as.character(datasub1()$carb))
})
observeEvent(filtercarb(), {
updateSelectInput(session,
"filter_carb",
choices = sort(filtercarb()),
selected = sort(filtercarb()))
})
# Subset dynamically the previous reactive filter #
datasub2 <- reactive({
# browser()
data_1[data_1$carb %in% input$filter_carb,]
})
filtercyl <- reactive({
unique(as.character(datasub2()$cyl))
})
observeEvent(filtercyl(), {
updateSelectInput(session,
"filter_cyl",
choices = sort(filtercyl()),
selected = sort(filtercyl()))
})
Filter2 <- reactive({
# Subset for plotly reactivity
Filter1 <- droplevels.data.frame(data_1)
filter(Filter1,
Filter1$gear %in% input$filter_gear,
Filter1$carb %in% input$filter_carb,
Filter1$cyl %in% input$filter_cyl)
})
output$databasedf <- DT::renderDT({
datatable(Filter2(),
filter="none",
selection="none",
escape=FALSE,
rownames = FALSE,
# colnames = c("", ""),
#autoHideNavigation = TRUE,
style = 'bootstrap4',
options = list(searching = FALSE, # remove search option
ordering = FALSE, # remove sort option
paging = FALSE, # remove paging
info = FALSE # remove bottom information
)) %>%
formatStyle(columns = 1, fontWeight = 'bold', `text-align` = 'left') # text to bold and lign left in first column
})
output$fig <-renderPlot({
req(input$filter_gear)
req(input$filter_carb)
req(input$filter_cyl)
#plt <- addDataFrame(reac_filter$Filter2, sheet, col.names=TRUE, row.names=TRUE, startRow=1, startColumn=1)
ggplot() + geom_line(aes(x=hp, y=mean(mpg), color=am),data = Filter2()) })
}
shinyApp(ui, server)

Add DT extensions using Shiny and selectinput

Trying to add in the following information to a datatable in Shiny, and getting errors when using the selectinput:
Error: incorrect number of dimensions
library(DT)
library(readr)
library(jsonlite)
library(data.table)
gumdad <- fromJSON("data/boxes.json")
# Define UI for app ----
ui <- fluidPage(
# App title ----
titlePanel("Box Scores"),
#FILTERS
selectInput("season",
"Season:",
c("All",
unique(as.character(gumdad$season)))),
# Main panel for displaying outputs ----
mainPanel(
# Output: Table----
DT::dataTableOutput('tableone')
)
)
# Define server logic ----
server <- function(input, output) {
output$tableone = renderDataTable({
data <- datatable(gumdad, extensions = 'Buttons', rownames = FALSE, escape = FALSE, selection = 'none',
colnames = c('Season', 'Date', 'Opponent', 'Result', 'UNC', 'Opp', 'OT', 'Location', 'Type','Box Score'),
options = list(buttons = c('copy', 'csv'), paging = FALSE, dom = 'Bfrtip')
)
if (input$season != "All") {
data <- data[data$season == input$season,]
}
return(data)
})
gumdad$box <- sapply(gumdad$box, function(x)
toString(tags$a(href=paste0("https://boxscorexxx.com/", x), "Box Score")))
}
shinyApp(ui = ui, server = server)
How can I used the selectInput while customizing the datatable with the correct dimensions?
In your code, data is not a dataframe, this is a datatable. It's not possible to subset it like this: data[data$season == input$season,]. Subset gumdad instead:
output$tableone = renderDT({
data <- gumdad
if (input$season != "All") {
data <- data[data$season == input$season,]
}
datatable(data, extensions = 'Buttons', rownames = FALSE, escape = FALSE, selection = 'none',
colnames = c('Season', 'Date', 'Opponent', 'Result', 'UNC', 'Opp', 'OT', 'Location', 'Type','Box Score'),
options = list(buttons = c('copy', 'csv'), paging = FALSE, dom = 'Bfrtip')
)
})
Also note that you should use renderDT instead of renderDatatable (or use DT::renderDatatable, which is the same as renderDT).

Shiny DT appearance messed up when selected rows used as reactive values

The tables displayed through the DataTables interface from DT package appear messy (e.g. disordered elements, strange looking pagination ...) when using reactive values which their input come from the rows selected in the first table. Using R version 3.4.3, and shiny 1.1.0 and DT 0.4 which both are sourced from CRAN.
The minimal code:
library(shiny)
library(DT)
ui <- fluidPage(
DT::dataTableOutput("dt"),
actionButton("go", "Go"),
wellPanel(DT::dataTableOutput("selected"))
)
server <- function(input, output, session) {
output$dt <- DT::renderDataTable({
DT::datatable(
mtcars,
style = 'bootstrap',
filter = 'top',
rownames = FALSE,
extensions = 'Buttons',
selection = list(mode = 'single'),
options = list(
pageLength = 10,
dom = '<"top"ifl>t<"bottom"Bp>',
buttons = c('copy', 'csv', 'excel'),
searchHighlight = TRUE
)
)
})
rv <- reactiveValues(val = FALSE)
observeEvent(input$go, {
rv$val <- input$go
})
observeEvent(input$dt_rows_selected, {
rv$val <- FALSE
})
output$selected <- DT::renderDataTable({
if (rv$val == FALSE)
return()
reactive({
validate(need(input$dt_rows_selected != "", "Select a row."))
mtcars[input$dt_rows_selected, ]
}) -> .mtcars
isolate({
DT::datatable(
.mtcars(),
style = 'bootstrap',
filter = 'top',
rownames = FALSE,
extensions = 'Buttons',
selection = list(mode = 'single'),
options = list(
pageLength = 10,
dom = '<"top"ifl>t<"bottom"Bp>',
buttons = c('copy', 'csv', 'excel'),
searchHighlight = TRUE
)
) -> table
})
table
})
}
shinyApp(ui, server)
It looks decent without the second table:
The issue is caused by the part style = 'bootstrap' which does not work well with return(NULL). Replacing if (rv$val == FALSE) return() with req(rv$val) in the output has solved the problem. Has taken the reference here.

Fetch Data Table records post selecting Drop down and Keying Text Columns in Data table using R

How can we get data for data table records post clicking of Update Table action button, post selecting drop down columns and text input from User? Any change in Drop down selection should refresh the Data table records immediately essentially making it as reactive.
library(shiny)
library(shinyjs)
library(DT)
library(data.table)
shinyInput <- function(FUN, len, id, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))
}
inputs
}
mydata = data.frame(id=letters[1:5], val=sample(10,5,T))
lengthofData <- nrow(mydata)
mydata[["Constraint Type"]] <- c(shinyInput(inputId = "constraintType",
selectInput,
lengthofData,
"d",
label = "",
choices = c(">", "<")
))
mydata[["Constraint Value"]] <- c(shinyInput(textInput, lengthofData, "t", label = ""))
ui = fluidPage(dataTableOutput("table"),
actionButton("goButton", "Update Table"),
dataTableOutput("newtable"))
server = function(input,output){
output$table <- renderDataTable( df(),server = FALSE,
escape = FALSE,
selection = 'none',
options = list(
sDom = '<"top">lrt<"bottom">ip',
rowCallback = JS("function(r,d) {$(r).attr('height', '10px')}"),
#columnDefs = list(list(width = '200px', targets = "_all")),
scrollY = '50vh',
paging = TRUE,
autoWidth = TRUE
))
newTableData <- reactive({
return(mydata)
})
df <- eventReactive(input$goButton, {
mydata
}, ignoreNULL = FALSE)
output$newtable <- renderDataTable({
DT::datatable(newTableData(),rownames = FALSE,
extensions = c('Responsive', 'Buttons'))
})
}
shinyApp(ui,server)
Screen shot for UI

Resources