Related
I am quite new to R shiny and I am trying to build a small shiny app but I don't know where I went wrong.
I am trying to get multiple user input via text area to filter my table output. Moreover, i want to control the columns to show in the table as well. Code is running fine for showing the columns but it is working only with one input value in the text area, it is not working with multiple user inputs.
I want to filter the table output with multiple user inputs as well.
For example for this code snippet it should return table when I write "honda,audi,bmw" in the text area input.
library(shiny)
library(shinyWidgets)
library(DT)
df <-mtcars
#ui
shinyApp(
ui = fluidPage(
titlePanel("Trial 1"),
sidebarLayout(
sidebarPanel(
#to take multiple user input
textAreaInput(
"text_input",
label = "Write multiple input separated by comma"
),
#to slect the columns to be added
pickerInput(
inputId = "somevalue",
label = "Columns to add",
choices = colnames(df),
options = list(`actions-box` = TRUE),
multiple = TRUE
),
#action button tot show the table
actionBttn(
"show_table",
label = "Show",
size = "sm",
color = "default",
block = TRUE
),
),
mainPanel(
tabsetPanel(type = "tabs",
tabPanel("Table", DT::dataTableOutput("table")),
tabPanel("Summary", verbatimTextOutput("summary"))
)
)
)
),
server = function(input, output,session) {
data <- observeEvent(input$show_table,{
text_input <- trimws(strsplit(input$text_input, ",")[[1]])
output$summary <- renderPrint({
summary(data())
})
output$table <- DT::renderDT({
df_sub <- df[df$make %chin% input$text_input, input$somevalue]
#df_sub = df[ ,input$somevalue]
datatable(df_sub,
caption = "PLease enter the changes by double clicking the cell",
editable = 'cell')
})
})
}
)
There isn't a 'make' variable in the data. I guess you refer to the first word of the row name as the make of the car. Then the strings you entered could be matched with the make of the car.
server = function(input, output,session) {
data <- observeEvent(input$show_table,{
brand <- word(rownames(df), 1)
text_input <- strsplit(input$text_input, ",")[[1]]
df_sub <- df[brand %in% text_input, input$somevalue]
output$summary <- renderPrint({
summary(df_sub)
})
output$table <- DT::renderDT({
datatable(df_sub,
caption = "PLease enter the changes by double clicking the cell",
editable = 'cell')
})
output$test <- renderText({
text_input
})
})}
I have this code:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
shinyApp(
ui = dashboardPage(
header = dashboardHeader(userOutput("user")),
sidebar = dashboardSidebar(shinyjs::useShinyjs(),uiOutput("sidebarpanel")),
body = dashboardBody(uiOutput("body")),
title = "DashboardPage"
),
server = function(input, output) {
output$user <- renderUser({
dashboardUser(
name = "Divad Nojnarg",
image = "https://adminlte.io/themes/AdminLTE/dist/img/user2-160x160.jpg",
title = "shinydashboardPlus",
subtitle = "Author",
footer = p("The footer", class = "text-center"),
fluidRow(
actionButton("personalInfo","Personal Info")
)
)
})
observeEvent(input$personalInfo, {
output$body <- renderUI({h4("Personal Info Dahsboard (no menuItem)")})
})
output$sidebarpanel <- renderUI({
sidebarMenu(id="tabs",
menuItem("Dashboard 1", tabName = "dashboard1", icon = icon("dashboard"))
,menuItem("Dashboard 2", tabName = "dashboard2", icon = icon("dashboard"))
)
})
output$body <- renderUI({
tabItems(
tabItem(tabName ="dashboard1",
fluidRow(box(width = 12, h4("Dashboard 1 (menuItem)"))))
,tabItem(tabName ="dashboard2",
fluidRow(box(width = 12, h4("Dashboard 2 (menuItem)"))))
)
})
}
)
I would like to do two things:
First: When I click on "Personal Info" button, then, prevent the menuItem to be shadowed (I assume I need to remove the class "selected" or "active" or something like that)
Second: I want to fix this: After pressing "Personal Info" button, the menuItems do not work:
As already shown in my earlier answer here we can use a hidden menuItem to modify the body content independent from the visibly selected menuItem.
Furthermore, I'd recommend to stop using renderUI in this scenario. In general it is slower to re-render a UI element instead of updating an existing element (here we can switch to the hidden menuItem via updateTabItems - however, this applies also to e.g. using updateSelectInput instead of renderUI({selectInput(...)})). In this context you should also question whether you really need the to create the dashboardUser on the server side.
If you really need a server side generated dashboardSidebar you still should not use renderUI - There are the renderMenu() / sidebarMenuOutput() functions available for this. Please see the related docs here.
library(shiny)
library(shinyjs)
library(shinydashboard)
library(shinydashboardPlus)
shinyApp(
ui = dashboardPage(
header = dashboardHeader(userOutput("user")),
sidebar = dashboardSidebar(shinyjs::useShinyjs(),
sidebarMenu(id="tabs",
menuItem("Tab 1", tabName = "tab1", icon = icon("dashboard")),
menuItem("Tab 2", tabName = "tab2", icon = icon("dashboard")),
hidden(menuItem("Personal Tab", tabName = "personal_tab", icon = icon("dashboard")))
)),
body = dashboardBody(useShinyjs(),
tabItems(
tabItem(tabName ="tab1",
fluidRow(box(width = 12, h4("Tab 1 (menuItem)")))),
tabItem(tabName ="tab2",
fluidRow(box(width = 12, h4("Tab 2 (menuItem)")))),
tabItem(tabName ="personal_tab",
fluidRow(box(width = 12, h4("Personal Info Dahsboard (no menuItem)"))))
)
),
title = "DashboardPage"
),
server = function(input, output, session) {
output$user <- renderUser({
dashboardUser(
name = "Divad Nojnarg",
image = "https://adminlte.io/themes/AdminLTE/dist/img/user2-160x160.jpg",
title = "shinydashboardPlus",
subtitle = "Author",
footer = p("The footer", class = "text-center"),
fluidRow(
actionButton("personalInfo","Personal Info")
)
)
})
observeEvent(input$personalInfo, {
shinydashboard::updateTabItems(session, inputId = "tabs", selected = "personal_tab")
})
}
)
Below is a sample code which takes two inputs: 1) input file and 2) input number of rows. Upon clicking the "Analyze" button the output from the server command return to the "Table" in "Results" tabset. This is a simple example where the command will be executed quickly and switches to the "Results" tabsetpanel.
The below withProgress code only shows the progress bar for the set time and disappears and then the actual code is executed. I would like to show a "Status Message" or "Progress Bar" when the "Analyze" is hit and show as long as the command is run. As long as the progress bar is running the current user (other users can use the app) cannot perform any action from the side bar. Because in the real app, sidebar has more menuItems which does similar tasks like this and each task has a Analyze button. If the user is allowed to browse to sidebar pages and hit Analyze then the app will have overload of performing multiple tasks. Ideally the progress bar functionality should we used with multiple actionButtons.
I read the blogs about async but unable to put right code in the right place. any help is appreciated with a bounty!!
library(shiny)
library(shinydashboard)
sidebar <- dashboardSidebar(width = 200,
sidebarMenu(id = "tabs",
menuItem(
"File", tabName = "tab1", icon = icon("fas fa-file")
)))
body <- tabItem(tabName = "tab1",
h2("Input File"),
fluidRow(
tabPanel(
"Upload file",
value = "upload_file",
fileInput(
inputId = "uploadFile",
label = "Upload Input file",
multiple = FALSE,
accept = c(".txt")
),
checkboxInput('header', label = 'Header', TRUE)
),
box(
title = "Filter X rows",
width = 7,
status = "info",
tabsetPanel(
id = "input_tab",
tabPanel(
"Parameters",
numericInput(
"nrows",
label = "Entire number of rows",
value = 5,
max = 10
),
actionButton("run", "Analyze")
),
tabPanel(
"Results",
value = "results",
navbarPage(NULL,
tabPanel(
"Table", DT::dataTableOutput("res_table"),
icon = icon("table")
)),
downloadButton("downList", "Download")
)
)
)
))
ui <-
shinyUI(dashboardPage(
dashboardHeader(title = "TestApp", titleWidth = 150),
sidebar,dashboardBody(tabItems(body))
))
server <- function(input, output, session) {
file_rows <- reactiveVal()
observeEvent(input$run, {
withProgress(session, min = 1, max = 15, {
setProgress(message = 'Analysis in progress',
detail = 'This may take a while...')
for (i in 1:15) {
setProgress(value = i)
Sys.sleep(0.5)
}
})
system(paste(
"cat",
input$uploadFile$datapath,
"|",
paste0("head -", input$nrows) ,
">",
"out.txt"
),
intern = TRUE)
head_rows <- read.delim("out.txt")
file_rows(head_rows)
})
observeEvent(file_rows(), {
updateTabsetPanel(session, "input_tab", "results")
output$res_table <-
DT::renderDataTable(DT::datatable(
file_rows(),
options = list(
searching = TRUE,
pageLength = 10,
rownames(NULL),
scrollX = T
)
))
})
output$downList <- downloadHandler(
filename = function() {
paste0("output", ".txt")
}, content = function(file) {
write.table(file_rows(), file, row.names = FALSE)
}
)
}
shinyApp(ui = ui, server = server)
Here is a solution based on the (absolutely under-star-ed) library(ipc).
I came across this library due to a question of #Dean Attali, where Joe Cheng mentioned it.
The quick-start guide of the ipc-package gives an example of what you are asking for: AsyncProgress.
Furthermore it provides an example on how to kill a future using AsyncInterruptor.
However, I haven't been able to test it yet.
I worked around the cancel-problem by using #Dean Attali's great package shinyjs to simply start a new session and ignore the old Future (You might be able to improve this, by using AsyncInterruptor).
But nevertheless, I gave your code a Future, dropped your system() cmd because I'm currently running R on Windows and found a way to disable (tribute to #Dean Attali) the analyze button session-wise by giving it session-dependant names:
library(shiny)
library(shinydashboard)
library(ipc)
library(promises)
library(future)
library(shinyjs)
library(datasets)
library(V8)
plan(multiprocess)
header <- dashboardHeader(title = "TestApp", titleWidth = 150)
sidebar <- dashboardSidebar(width = 200,
sidebarMenu(id = "tabs",
menuItem(
"File", tabName = "tab1", icon = icon("fas fa-file")
)))
body <- dashboardBody(useShinyjs(),
fluidRow(column(
12, tabItem(
tabName = "tab1",
h2("Input File"),
textOutput("shiny_session"),
tabPanel(
"Upload file",
value = "upload_file",
fileInput(
inputId = "uploadFile",
label = "Upload Input file",
multiple = FALSE,
accept = c(".txt")
),
checkboxInput('header', label = 'Header', TRUE)
),
box(
title = "Filter X rows",
width = 7,
status = "info",
tabsetPanel(
id = "input_tab",
tabPanel(
"Parameters",
numericInput(
"nrows",
label = "Entire number of rows",
value = 5,
max = 10
),
column(1, uiOutput("sessionRun")),
column(1, uiOutput("sessionCancel"))
),
tabPanel(
"Results",
value = "results",
navbarPage(NULL,
tabPanel(
"Table", DT::dataTableOutput("res_table"),
icon = icon("table")
)),
downloadButton("downList", "Download")
)
)
)
)
)))
ui <- shinyUI(dashboardPage(
header = header,
sidebar = sidebar,
body = body,
title = "TestApp"
))
server <- function(input, output, session) {
output$shiny_session <-
renderText(paste("Shiny session:", session$token))
file_rows <- reactiveVal()
run_btn_id <- paste0("run_", session$token)
cancel_btn_id <- paste0("cancel_", session$token)
output$sessionRun <- renderUI({
actionButton(run_btn_id, "Analyze")
})
output$sessionCancel <- renderUI({
actionButton(cancel_btn_id, "Cancel")
})
paste("Shiny session:", session$token)
observeEvent(input[[run_btn_id]], {
file_rows(NULL)
shinyjs::disable(id = run_btn_id)
progress <- AsyncProgress$new(message = 'Analysis in progress',
detail = 'This may take a while...')
row_cnt <- isolate(input$nrows)
get_header <- isolate(input$header)
future({
fileCon <- file("out.txt", "w+", blocking = TRUE)
linesCnt <- nrow(iris)
for (i in seq(linesCnt)) {
Sys.sleep(0.1)
progress$inc(1 / linesCnt)
writeLines(as.character(iris$Species)[i],
con = fileCon,
sep = "\n")
}
close(fileCon)
head_rows <- read.delim("out.txt", nrows = row_cnt, header=get_header)
progress$close() # Close the progress bar
return(head_rows)
}) %...>% file_rows
return(NULL) # Return something other than the future so we don't block the UI
})
observeEvent(input[[cancel_btn_id]],{
session$reload()
})
observeEvent(file_rows(), {
shinyjs::enable(id = run_btn_id)
updateTabsetPanel(session, "input_tab", "results")
output$res_table <-
DT::renderDataTable(DT::datatable(
req(file_rows()),
options = list(
searching = TRUE,
pageLength = 10,
rownames(NULL),
scrollX = T
)
))
})
output$downList <- downloadHandler(
filename = function() {
paste0("output", ".txt")
},
content = function(file) {
write.table(file_rows(), file, row.names = FALSE)
}
)
}
shinyApp(ui = ui, server = server)
App running:
This question has been answered on a different forum
For future reference, if anyone comes across this question, here's the full answer (I did not come up with this answer, it's by Joe Cheng)
This seems to be the main piece of code you're asking about:
observeEvent(input$run, {
withProgress(session, min = 1, max = 15, {
setProgress(message = 'Analysis in progress',
detail = 'This may take a while...')
for (i in 1:15) {
setProgress(value = i)
Sys.sleep(0.5)
}
})
system(paste(
"cat",
input$uploadFile$datapath,
"|",
paste0("head -", input$nrows) ,
">",
"out.txt"
),
intern = TRUE)
head_rows <- read.delim("out.txt")
file_rows(head_rows)
})
With futures/promises, you need to clearly decide what operations happen inside of the Shiny process, and what operations happen in the future process. In this case, here are the steps that we want to happen, in order:
Show progress message (Shiny process)
Read reactives: input$uploadFile$datapath, input$nrows (Shiny)
Write all but the last nrows to out.txt (future process)
Read out.txt (Could be either, let's say future)
Dismiss progress (Shiny)
Assign result to file_rows (Shiny)
Here's what that looks like:
observeEvent(input$run, {
prog <- Progress$new(session)
prog$set(message = "Analysis in progress",
detail = "This may take a while...",
value = NULL)
path <- input$uploadFile$datapath
nrows <- input$nrows
future({
readLines(path) %>% head(-nrows) %>% writeLines("out.txt")
read.delim("out.txt")
}) %...>%
file_rows() %>%
finally(~prog$close())
})
As long as the future/promise pipeline is the last expression in the observeEvent (which it is in this case, as file_rows() and finally(...) are part of the pipeline) then Shiny will hold off on processing any messages on behalf of the user.
There are two things this solution doesn't address.
Progress messages take a step back; not only are we forced to use the Progress$new() syntax instead of the cleaner withProgress(), but we lost the ability to report on the progress percentage. You can try the new ipc package for a solution to that problem.
This doesn't stop the user from clicking around in the UI; it won't do anything while the async operation is executing, but when the operation is done those interactions will have accumulated in a queue and will be handled in the order that they arrived. If you'd like to actually disable the UI entirely so that they're not able to do anything at all, there's not currently a built-in way to do that in Shiny. Although come to think of it, you might try replacing the use of Progress with showModal(modalDialog(title = "Analysis in progress", "This may take a while...", footer=NULL)); I think that will at least stop mouse clicks.
I working on a project where I have to create a form in shiny. I currently have a datatable in the UI which has email in the form of hyperlink. Once the hyperlink is clicked the modal window opens where I have another UI which shows the various fields to be filled. I have a save button here that should update my DB in the backend once the button is clicked.
The problem I am facing is that I am unable to reference each email to that particular modal window and my update query updates all the records in the DB. Is there a way to pass all the record details that has been clicked into the modal window??
What I basically need to know is how to update the record that I have clicked on and for which the pop up window is opened??
I am attaching the UI.R and server.R for use.
enter code here
ui.R
library(shiny)
library(DT)
library(shinyBS)
fluidPage(
fluidRow(
actionButton(inputId = "view",label = "Hi")),
#actionButton(inputId = "savepage1", label = "Save"),
DT::dataTableOutput('my_table'),
bsModal("FormModal", "My Modal", "",textOutput('mytext'),uiOutput("form1"),
actionButton("savepage2","Save"),DT::dataTableOutput("table1"),size = "large")
)
enter code here
server.R
library(shinyBS)
server <- function(session, input, output){
uedata<-c("","Prime","Optimus") ##add source data here
output$form1<-renderUI({
tagList(
column(width=6,selectInput("samplevalue","Select Custom Source*",choices=c("Please select",samplevaluedata))),
column(width=6,textInput("sampletext",label = "Enter Text",value = NULL,placeholder = NULL)))
})
on_click_js = "Shiny.onInputChange('mydata', '%s');
$('#FormModal').modal('show')"
convert_to_link = function(x) {
as.character(tags$a(href = "#", onclick = sprintf(on_click_js,x), x))
}
observeEvent(input$view,{
session$sendCustomMessage(type = "unbinding_table_elements", "my_table")
output$my_table <- DT::renderDataTable({
a=dbGetQuery(hcltcprod,paste0("select name,mobile,email,assignedto from public.tempnew order by 3;"))
a <- data.frame(a,row.names = NULL)
a$email <- sapply(a$email,convert_to_link)
a1 <- datatable(a,
escape = F,
options = list(paging = FALSE, ordering = FALSE, searching = FALSE, rownames = FALSE,
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node());}'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
a1
})
})
observeEvent(input$my_table_cell_clicked, {
print(Sys.time())
})
observe({
if(input$savepage2==0)
return()
isolate({
for(i in 1:nrow(a))
dbGetQuery(hcltcprod,paste0("update public.tempnew set s_text='",input$samplevalue,"',s_value='",input$sampletext,"' where mobile in ('",a$email,"');"))
})
})
}
As your example is connected to database and you didnt provide sample data I will go with mtcars dataset. Building on the example in the link you can view the selected data using the following:
rm(list = ls())
library(DT)
library(shiny)
library(shinyBS)
library(shinyjs)
library(shinydashboard)
# This function will create the buttons for the datatable, they will be unique
shinyInput <- function(FUN, len, id, ...) {inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))}
inputs
}
ui <- dashboardPage(
dashboardHeader(title = "Simple App"),
dashboardSidebar(
sidebarMenu(id = "tabs",
menuItem("Menu Item 1", tabName = "one", icon = icon("dashboard"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "one",h2("Datatable Modal Popup"),
DT::dataTableOutput('my_table'),uiOutput("popup")
)
)
)
)
server <- function(input, output, session) {
my_data <- reactive({
testdata <- mtcars
as.data.frame(cbind(View = shinyInput(actionButton, nrow(testdata),'button_', label = "View", onclick = 'Shiny.onInputChange(\"select_button\", this.id)' ),testdata))
})
output$my_table <- DT::renderDataTable(my_data(),selection = 'single',options = list(searching = FALSE,pageLength = 10),server = FALSE, escape = FALSE,rownames= FALSE)
# Here I created a reactive to save which row was clicked which can be stored for further analysis
SelectedRow <- eventReactive(input$select_button,{
as.numeric(strsplit(input$select_button, "_")[[1]][2])
})
# This is needed so that the button is clicked once for modal to show, a bug reported here
# https://github.com/ebailey78/shinyBS/issues/57
observeEvent(input$select_button, {
toggleModal(session, "modalExample", "open")
})
DataRow <- eventReactive(input$select_button,{
my_data()[SelectedRow(),2:ncol(my_data())]
})
output$popup <- renderUI({
bsModal("modalExample", paste0("Data for Row Number: ",SelectedRow()), "", size = "large",
column(12,
DT::renderDataTable(DataRow())
)
)
})
}
shinyApp(ui, server)
I want to do some operations on the server side based on whether the box is collapsed or not. Is it possible to know on the server side if a box in shiny dashboard is collapsed or not?
[EDIT]:
After going through the link provided by warmoverflow and going through the following link I came up with the following code:
ui.R
library(shiny)
library(shinydashboard)
library(shinyjs)
ui <- shinyUI( dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
useShinyjs(),
extendShinyjs(text = jscode),
box(id="box1", title = "BOX 1", collapsible = TRUE, collapsed = TRUE ),
box(id="box2", title = "BOX2", collapsible = TRUE, collapsed = TRUE),
# a shiny element to display unformatted text
verbatimTextOutput("results"),
verbatimTextOutput("results1"),
# # javascript code to send data to shiny server
tags$script("
document.getElementsByClassName('btn btn-box-tool')[0].onclick = function() {
var number = document.getElementsByClassName('box-body')[0].style.display;
Shiny.onInputChange('mydata', number);
};
"),
tags$script("
document.getElementsByClassName('btn btn-box-tool')[1].onclick = function() {
var number = document.getElementsByClassName('box-body')[1].style.display;
Shiny.onInputChange('mydata1', number);
};
"),
actionButton("Collapse", "CollapseAll")
)
))
server.R
library(shiny)
library(shinydashboard)
library(shinyjs)
jscode <- "
shinyjs.collapse = function(boxid) {
$('#' + boxid).closest('.box').find('[data-widget=collapse]').click();
}
"
server <- shinyServer(function(input, output, session) {
output$results = renderPrint({
input$mydata
})
output$results1 = renderPrint({
input$mydata1
})
observeEvent(input$Collapse,{
if(input$mydata == "none" || input$mydata == "")
{
js$collapse("box1")
}
if(input$mydata1 == "none" || input$mydata == "")
{
js$collapse("box2")
}
})
})
I was wondering if there is a better way to do this. Instead of adding tags$script for each of the box is it possible to make changes to the code such that we can find out all the box that are not collapsed?
From your question, I'm not sure if you just want to collapse all expanded boxes or do something else. You can solve the first using a conditional statement in the JS code. Similarly, you can implement a button to expand all boxes using negation (if (!.....)).
library(shiny)
library(shinydashboard)
library(shinyjs)
jscode <- "
shinyjs.collapse = function(boxid) {
if (document.getElementById(boxid).parentElement.className.includes('collapsed-box')) {
$('#' + boxid).closest('.box').find('[data-widget=collapse]').click();
}
}"
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
useShinyjs(),
extendShinyjs(text = jscode),
box(id="box1", title = "BOX1", collapsible = TRUE, collapsed = FALSE ),
box(id="box2", title = "BOX2", collapsible = TRUE, collapsed = FALSE),
# a shiny element to display unformatted text
actionButton("Collapse", "CollapseAll")
))
server <- shinyServer(function(input, output, session) {
observeEvent(input$Collapse,{
for (i in 1:2) {
js$collapse(paste0('box',i))
}
})
})
shinyApp(ui = ui, server = server)