tableHTML in Shiny app - can't handle NULL - shiny

I'm trying to output a table via tableHTML that depends on some input in a Shiny app. In the example below, I want the table to depend on the radio button. I'm getting an error saying "Error: no function to return from, jumping to top level", so it seems it doesn't like my two return-statements. Any ideas how to go about this?
library(shiny)
library(tableHTML)
ui = fluidPage(
fluidRow(
radioButtons("radio", label = h3("Data on/off"),
choices = list("On", "Off"),
selected = "Off"),
tableHTML_output("mytable")
)
)
server = function(input, output) {
output$mytable <- render_tableHTML({
if ((input$radio == "On")) {
return(tableHTML(mtcars))
}
else {
return(NULL)
}
})
}
shinyApp(ui, server)
The above works when replacing tableHTML_output by tableOutput and render_tableHTML by renderTable and removing the tableHMTL() function.

It seems a package related issue.
Since we are dealing with plain html, we can use shiny::htmlOutput.
library(shiny)
library(tableHTML)
ui <- fluidPage(
fluidRow(
radioButtons("radio",
label = h3("Data on/off"),
choices = list("On", "Off"),
selected = "On"
),
htmlOutput("mytable")
)
)
server <- function(input, output) {
html_table <- eventReactive(input$radio, {
table <- if (input$radio == "On") {
tableHTML(mtcars)
}
return(table)
})
output$mytable <- renderText(
html_table()
)
}
shinyApp(ui, server)
Another workaround is to have two render_tableHTML inside an observeEvent like this:
library(shiny)
library(tableHTML)
ui <- fluidPage(
fluidRow(
radioButtons("radio",
label = h3("Data on/off"),
choices = list("On", "Off"),
selected = "Off"
),
tableHTML_output("mytable")
)
)
server <- function(input, output) {
observeEvent(input$radio, {
if (input$radio == "On") {
output$mytable <- render_tableHTML({
tableHTML(mtcars)
})
} else {
output$mytable <- render_tableHTML({
NULL
})
}
})
}
shinyApp(ui, server)

Related

Shiny: subsetting a table from a textInput with multiple values

I have a simple Shiny app. The user enters a code eg: a1, b1, c1 etc in the textInput.
When only one code is listed it works great, but if the user writes two or more codes separated by a comma it doesn't.
How can the user input as many codes as they like?
library(shiny)
ui <- fluidPage(
titlePanel(""),
sidebarLayout(
sidebarPanel(
textInput(inputId = "textBox",
label = "Code Search",
placeholder = "Enter codes here seperated by a comma"),
actionButton("textSearchButton", "Generate the Table")
),
fluidRow(
tableOutput("dtOut")
)
)
)
server <- function(input, output) {
df <- data.frame(Code = paste0(letters, 1),
Description = "Something here",
Value = "Some value")
outputFunc <- function(code, df){
# # Dummy data
# code <- c('a1', 'b1', 'c1')
outTbl <- df[df$Code %in% code,]
return(list(outTbl))
}
textSearch <- eventReactive(input$textSearchButton, {
outputFunc(input$textBox, df)
})
output$dtOut <- renderTable({
textSearch()[[1]]
})
}
shinyApp(ui, server)
I simplified your code a bit:
library(shiny)
ui <- fluidPage(
titlePanel(""),
sidebarLayout(
sidebarPanel(
textInput(inputId = "textBox",
label = "Code Search",
placeholder = "Enter codes here seperated by a comma"),
actionButton("textSearchButton", "Generate the Table")
),
fluidRow(
tableOutput("dtOut")
)
)
)
server <- function(input, output) {
df <- eventReactive(input$textSearchButton, {
# outputFunc(input$textBox, df)
req(input$textBox)
codes <- unlist(strsplit(input$textBox, ", "))
return(data.frame(Code = codes,
Description = "Something here",
Value = "Some value"))
})
output$dtOut <- renderTable({
df()
})
}
shinyApp(ui, server)
Does it respond to your need ?

In shiny How to create a DT table, where i can add rows and delete the rows simultaneously

I have tried this in different ways and achieved one task, either add or delete., but i couldn't get complete solution in one, i might be missing some small concept somewhere.. I am adding the code , please help me complete my basic app.
library(shiny)
library(DT)
x<- data.frame(v1 = NA,
v2 = NA
),
ui = shinyUI(
fluidPage(
sidebarLayout(
sidebarPanel(
textInput("v1","v1","a"),
numericInput("V2","V2","1"),
# Row selection
numericInput(inputId = "row.selection", label = "Select row to be
deleted", min = 1, max = 100, value = "")
# Add button
actionButton(inputId = "add.button", label = "Add", icon =
icon("plus")),
# Delete button
actionButton(inputId = "delete.button", label = "Delete", icon =
icon("minus")),
),
mainPanel(
dataTableOutput('table')
)
)
)
),
Server side code
server = function(input, output, session) {
values <- reactiveValues()
values$df <- x
newEntry <- observe({
cat("newEntry\n")
if(input$add.button > 0) {
newRow <- data.frame(input$v1, input$v2)
isolate(values$df <- rbind(values$df,newRow))
}
})
deleteEntry <- observe({
cat("deleteEntry\n")
if(input$delete.button > 0) {
if(is.na(isolate(input$row.selection))){
values$df <- isolate(values$df[-nrow(values$df), ])
} else {
values$df <- isolate(values$df[-input$row.selection, ])
}
}
})
output$table = renderDataTable({
values$df
})
}
Try to use observeEvent rather than obser with actionbutton
and also, you have uppercase and lowercase issue with input$v2 (should be input$V2)
Try this modified code:
library(shiny)
library(DT)
x<- data.frame(v1 = NA,
v2 = NA
)
ui = shinyUI(
fluidPage(
sidebarLayout(
sidebarPanel(
textInput("v1","v1","a"),
numericInput("V2","V2","1"),
# Row selection
numericInput(inputId = "row.selection", label = "Select row to be
deleted", min = 1, max = 100, value = ""),
# Add button
actionButton(inputId = "add.button", label = "Add", icon =
icon("plus")),
# Delete button
actionButton(inputId = "delete.button", label = "Delete", icon =
icon("minus"))
),
mainPanel(
dataTableOutput('table')
)
)
)
)
server = function(input, output, session) {
values <- reactiveValues()
values$df <- x
observeEvent(input$add.button,{
cat("addEntry\n")
print(input$v1)
print(input$V2)
newRow <- data.frame(input$v1, input$V2)
colnames(newRow)<-colnames(values$df)
values$df <- rbind(values$df,newRow)
print(nrow(values$df))
})
observeEvent(input$delete.button,{
cat("deleteEntry\n")
if(is.na(input$row.selection)){
values$df <- values$df[-nrow(values$df), ]
} else {
values$df <- values$df[-input$row.selection, ]
}
})
output$table = renderDataTable({
values$df
})
}
shinyApp(ui,server)
Just run all the code above, and it should work properly.

To enable and disable sidebar toggle button using a action button

I am looking for a code snippet using which, I can enable/disable sidebar toggle button in shinydashboard header.
library(shiny)
library(shinydashboard)
library(shinyjs)
ui <- shinyUI(dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
useShinyjs()
)
))
server <- shinyServer(function(input, output, session) {
addClass(selector = "body", class = "sidebar-collapse") # Hide Side Bar
})
shinyApp(ui = ui, server = server)
Let me know if anybody can help???
If you use the shinyjs package, you can show or hide the sidebar toggle with a quick line of JavaScript.
library(shiny)
library(shinydashboard)
library(shinyjs)
ui <- shinyUI(dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
useShinyjs(),
actionButton("hide","Hide toggle"),
actionButton("show","Show toggle")
)
))
server <- shinyServer(function(input, output, session) {
observeEvent(input$hide,{
shinyjs::runjs("document.getElementsByClassName('sidebar-toggle')[0].style.visibility = 'hidden';")
})
observeEvent(input$show,{
shinyjs::runjs("document.getElementsByClassName('sidebar-toggle')[0].style.visibility = 'visible';")
})
})
shinyApp(ui = ui, server = server)
The JavaScript itself just refers to the first element with class sidebar-toggle (i.e. the menu button), and toggles the visibility depending on which button the user presses.
I have found a solution to this...If someone is stuck with same problem, can refer to below solution:
library(shiny)
library(shinydashboard)
library(shinyjs)
ui <- shinyUI(dashboardPage(
dashboardHeader(),
dashboardSidebar( tags$head(
tags$script(
HTML(#code for hiding sidebar tabs
"Shiny.addCustomMessageHandler('manipulateMenuItem1', function(message)
{
var aNodeList = document.getElementsByTagName('a');
for (var i = 0; i < aNodeList.length; i++)
{
if(aNodeList[i].getAttribute('data-toggle') == message.toggle && aNodeList[i].getAttribute('role') == message.role)
{
if(message.action == 'hide')
{
aNodeList[i].setAttribute('style', 'display: none;');
}
else
{
aNodeList[i].setAttribute('style', 'display: block;');
};
};
}
});"
)
)
)
),
dashboardBody(
useShinyjs(),
actionButton("h1","Hide toggle"),
actionButton("h2","Show toggle")
)
))
server <- shinyServer(function(input, output, session) {
observeEvent(input$h1,{
session$sendCustomMessage(type = "manipulateMenuItem1", message = list(action = "hide",toggle = "offcanvas", role = "button"))
})
observeEvent(input$h2,{
session$sendCustomMessage(type = "manipulateMenuItem1", message = list(action = "show",toggle = "offcanvas", role = "button"))
})
})
shinyApp(ui = ui, server = server)

toggle across tabs in shinyjs

im trying to invoke js across different tabs in shiny like the code below
library(shiny)
library(shinyjs)
ui <- tagList(
useShinyjs(),
navbarPage(
"shinyjs with navbarPage",
tabPanel("tab1",
actionLink(inputId = 'link',label = 'Fast Forward')
),
tabPanel("tab2",
actionButton("button", "Click me"),
textInput(inputId = "hello", label='',value = "Hello!")
)
)
)
server <- function(input, output, session) {
observeEvent(input$link, {
runjs('$("#link").click();')
})
observeEvent(input$button,{
toggle("hello")
})
}
shinyApp(ui, server)
the command is not going through, what could be the problem?
Try with this modified server part:
server <- function(input, output, session) {
observeEvent(input$link, {
runjs("$('a[data-value=\"tab2\"]').tab('show');")
})
observeEvent(input$button,{
toggle("hello")
})
}
i found the mistake.
i wrote
runjs('$("#link").click();')
instead of
runjs('$("#button").click();')

Shinydashboard: Know in the server side if a box is collapsed or not

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)