I want to create a Shiny App with a single tab navbar and the navbar has a logo and some download buttons. I used Shiny NavBar add additional info to create buttons using HTML, but I'd like the onClick function to be the same as the button I included as output$downloadData. Is it possible to mix and match R code and JS to have the button in the navbar be a downloadButton?
library(shiny)
# Define UI for application that draws a histogram
ui <- navbarPage(
# Application title
"Old Faithful Geyser Data",
# Sidebar with a slider input for number of bins
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30)
),
# I included download buttons here for functionality,
# these are the buttons I'd like in the top right
# Can I use onclick=downloadData or something within my HTML?
mainPanel(
downloadButton("downloadData", "CSV"),
downloadButton("downloadData2", "TXT"),
tableOutput("dist")
),
# Can I add R code to the HTML code so that onclick
# by button uses output$Downloaddata below?
tags$script(HTML("var header = $('.navbar> .container-fluid');
header.append('<div style=\"float:right; valign:middle\"><button onClick=downloadCSV(); style=\"valign:middle;\">Download CSV</button><button>Download SAS</button></div>');
console.log(header)"))
)
# Define server logic required to draw a histogram
server <- function(input, output) {
dummy <- data.frame(x = c(1,2,3), y = c(4,5,6))
output$dist <- renderTable({
dummy
})
output$downloadData <- downloadHandler(
filename = function() {
paste(dummy, ".csv", sep = "")
},
content = function(file) {
write.csv(dummy, file, row.names = FALSE)
}
)
output$downloadData2 <- downloadHandler(
filename = function() {
paste(dummy, ".csv", sep = "")
},
content = function(file) {
write.csv(dummy, file, row.names = FALSE)
}
)
}
# Run the application
shinyApp(ui = ui, server = server)
Related
I am trying to select only filtered rows using select all button that comes with select extension in shiny's DT package but it selects all the rows.
Here's the sample shiny app
Below is the reproducible code for the app:
library(DT)
data(mpg)
# Define UI for application
ui <- fluidPage(
# Application title
titlePanel("Select only filtered rows using selectall button"),
br(),
br(),
DT::dataTableOutput("table")
)
# Define server logic
server <- function(input, output) {
output$table <- DT::renderDataTable({
datatable(mpg, escape=F,
rownames=F,
filter = 'top',
# colnames = c("Data Type","Variable","Description", "Filename"),
class = "compact hover row-border",
extensions = c('Scroller','Select', 'Buttons'),
options = list(
select = list(style = "multi", items = "row"),
columnDefs = list(list(className = 'dt-center', targets = "_all")),
language = list(
info = 'Showing _START_ to _END_ of _TOTAL_ variables'),
deferRender = TRUE,
scrollY = 500,
scroller = TRUE,
dom = "Blfrtip",
buttons = c('selectAll', 'selectNone')
),
selection="none"
) }, server = F
)
}
# Run the application
shinyApp(ui = ui, server = server)
I think I may have to add some custom javascript to fix this but I am not good with it.
Can anyone help or give any suggestions.
Thanks
Somehow I managed to figure out the solution for my question. Posting it here, so it might help others. I got help from couple of places. Datatable document and stackoverflow
Using these helps, I extended my selectall button functionality and also extended it for deselectall button (deselect any filtered rows).
Here's the updated shiny app
Below is the updated code:
library(shiny)
library(DT)
data(mpg)
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("Select only filtered rows using selectall button"),
br(),
br(),
DT::dataTableOutput("table")
)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$table <- DT::renderDataTable({
datatable(mpg, escape=F,
rownames=F,
filter = 'top',
# colnames = c("Data Type","Variable","Description", "Filename"),
class = "compact hover row-border",
extensions = c('Scroller','Select', 'Buttons'),
options = list(
select = list(style = "multi", items = "row"),
columnDefs = list(list(className = 'dt-center', targets = "_all")),
language = list(
info = 'Showing _START_ to _END_ of _TOTAL_ variables'),
deferRender = TRUE,
scrollY = 500,
scroller = TRUE,
dom = "Blfrtip",
buttons = list(list(extend='selectAll',className='selectAll',
text="select all rows",
action=DT::JS("function () {
var table = $('.dataTable').DataTable();
table.rows({ search: 'applied'}).deselect();
table.rows({ search: 'applied'}).select();
}")
), list(extend='selectNone',
text="DeselectAll",
action=DT::JS("function () {
var table = $('.dataTable').DataTable();
table.rows({ search: 'applied'}).select();
table.rows({ search: 'applied'}).deselect();
}")
))
),
selection="none"
) }, server = F
)
}
# Run the application
shinyApp(ui = ui, server = server)
Hope this help others.
So pretty much as the title says, I am trying to create a dropdown in R shiny with several pickerInputs inside of them. I know it is necessary to use dropdown and not dropdownBttn because of the bootstrap compatibility issue. When I open the dropdown, I can see all my filters without any issues. Even when I click on one of the pickerInputs, the widget functions without any issues. However, when I try to click on another picker input or just to close the picker dropdown, the entire dropdown menu closes. As a user this would be really irritating. I know I could just use checkbox options or even another widget given the example below is only using the cars dataset but I want to be able to expand it to datasets where there may be greater than 4 choices and a pickerInput might be the best widget for filtering. I have included my code below for a workable example of the issue.
# *LIBRARIES* ----
library(shiny)
library(shinyWidgets)
library(shinydashboard)
# *UI* ----
ui <- shinyUI(
# Main Dashboard Page
dashboardPage(
skin = "green",
# Dashboard Header Settings ----
dashboardHeader(
title = "Dashboard Showcase",
# Notifications Bar ----
dropdownMenu(
type = "notifications",
icon = icon("warning")
),
dropdownMenu(
type = "messages",
icon = icon("envelope")
),
dropdownMenu(
type = "tasks",
icon = icon("clipboard")
)
),
# Dashboard Sidebar ----
dashboardSidebar(
# Tab Navigation Menu ----
sidebarMenu(
menuItem("Main Dashboard",
tabName = "tab1",
icon = icon("dashboard")
),
menuItem("Dynamic Graph",
tabName = "tab2",
icon = icon("chart-line")
)
)
),
# Dashboard Body ----
dashboardBody(
# Dropdown Filter selection ----
dropdown(
size = "lg",
icon = icon("filter"),
label = "Filters",
uiOutput("mainfilters")
),
# Creating Dynamic Tabs ----
tabItems(
tabItem(
tabName = "tab1",
class = "active"
),
tabItem(
tabName = "tab2"
)
)
)
)
)
# *SERVER* ----
server <- function(input, output){
# Data Initialization ----
mydata <- mtcars
# Filters ----
output$mainfilters <- renderUI({
list(
# Place your input filters in list form here
fluidRow(column(6,
pickerInput(
inputId = "gearfilter",
label = "Select Number of Gears",
choices = as.character(sort(unique(mydata$gear),
decreasing = FALSE
)
),
selected = as.character(unique(mydata$gear)),
multiple = TRUE,
options = list(
`actions-box` = TRUE
)
)
),
column(6,
pickerInput(
inputId = "cylinderfilter",
label = "Select Number of Cylinders",
choices = as.character(unique(mydata$cyl)),
selected = as.character(unique(mydata$cyl)),
multiple = TRUE,
# New updated options to use the live searching function of the widget.
options = pickerOptions(
actionsBox = TRUE,
selectedTextFormat = 'count>2',
liveSearch = T)
)
)
),
fluidRow(column(6,
pickerInput(
inputId = "vsfilter",
label = "Select Engine Type: ",
choices = as.character(unique(mydata$vs)),
selected = as.character(unique(mydata$vs)),
multiple = TRUE,
# Widget Options
options = pickerOptions(
actionsBox = TRUE
)
)
),
column(6,
pickerInput(
inputId = "trannyfilter",
label = "Select Transmission Type: ",
choices = as.character(unique(mydata$am)),
selected = as.character(unique(mydata$am)),
multiple = TRUE,
# Widget options
options = pickerOptions(
actionsBox = TRUE
)
)
)
)
)
})
# Data Cleaning ----
# Output Options ----
#outputOptions(x = output, name = "mainfilters", suspendWhenHidden = FALSE)
}
shinyApp(ui = ui, server = server)
Problem Statement:
I am trying to load interactive networks of STRING into a Shiny website using R
What I've Tried:
According to STRING, I can embed the interactive network but I need a couple of elements:
Javascript libary
<script type="text/javascript" src="http://string-db.org/javascript/combined_embedded_network_v2.0.2.js"></script>
Embed the div item
<div id="stringEmbedded"></div>
Call the specific protein with parameters e.g. TP53
getSTRING('https://string-db.org', {'ncbiTaxonId':'9606', 'identifiers':['TP53'], 'network_flavor':'confidence'})"
In theory, the produced network should be targetted to wherever the <div id="stringEmbedded"></div> is placed.
So I did this for Shiny:
library(shiny)
library(shinydashboard)
header <- dashboardHeader(title = "Test")
tags$head(HTML("<script type='text/javascript' src='http://string-db.org/javascript/combined_embedded_network_v2.0.2.js'></script>"))
sidebar <- dashboardSidebar(sidebarMenu(
menuItem("Item1", tabName = "dashboard", icon = icon("dashboard")),
menuItem("Item2", tabName = "widgets", icon = icon("th")),
sidebarSearchForm(textId = "searchText", buttonId = "searchButton",label = "Search...") #input$searchText and input$searchButton
))
body <-dashboardBody(
fluidRow(
tags$body(tags$script(HTML("getSTRING('https://string-db.org', {'ncbiTaxonId':'9606', 'identifiers':['TP53'], 'network_flavor':'confidence'})")),
fluidRow(
tabBox(
side = "left", height = "250px",
selected = "Tab3",
tabPanel("Tab1", tags$div(id="stringEmbedded")),
tabPanel("Tab2", "Tab content 2"),
tabPanel("Tab3", "Note that when side=right, the tab order is reversed.")
)
)
ui <- fluidPage(dashboardPage(header, sidebar, body))
server <- function(input, output) {}
shinyApp(ui = ui, server = server)
Following my comments from above, here is a minimal working example on how to embed a STRING gene network into a shiny app. I've made use of shinyjs which -- while not strictly necessary -- makes working with custom JS code easier.
library(shiny)
library(shinyjs)
jsCode <- "
shinyjs.loadStringData = function(gene) {
getSTRING('https://string-db.org', {
'ncbiTaxonId':'9606',
'identifiers': gene,
'network_flavor':'confidence'})
}"
ui <- fluidPage(
useShinyjs(),
extendShinyjs(text = jsCode),
tags$head(tags$script(src = "http://string-db.org/javascript/combined_embedded_network_v2.0.2.js")),
textInput("gene", "Gene symbol", value = "TP53"),
actionButton("button", "Show"),
h3("Network:"),
tags$div(id = "stringEmbedded")
)
server <- function(input, output, session) {
onclick("button", {
req(input$gene)
js$loadStringData(input$gene)
})
}
shinyApp(ui, server)
I don't know much of JavaScript, and I'm having a problem to override the default message in the Shiny R App, when I'm outputting table.
When table is empty, it's giving message "No data available in table" in the first row. I wanted to put some app-specific instructions instead.
I found that there's something like:
options = list(searching = FALSE,paging = FALSE) but don't know what option it would be to switch that text.
Also, I found JS code to reset the message (https://datatables.net/reference/option/language.zeroRecords),
but I wasn't able to attach this correctly to renderDataTable in Shiny.
I just don't know the correct syntax of incorporating JS into shiny, I tried
options = list(searching = FALSE,paging = FALSE, callback=DT:JS(
'
{
"language": {
"zeroRecords": "No records to display- custom text"
}
'
but it didn't work. I would appreciate some guidance on this.
Here's the whole code. Right now my attempts to replace the mesage are ignored:
library(ggplot2)
library(DT)
ui <- fluidPage(
titlePanel("Basic DataTable"),
# Create a new Row in the UI for selectInputs
fluidRow(
column(12,
selectInput("man",
"Manufacturer:",
c("All",
unique(as.character(mpg$manufacturer))))
)
),
# Create a new row for the table.
fluidRow(
DT::dataTableOutput("table")
)
)
server <-function(input, output) {
# Filter data based on selections
output$table <- DT::renderDataTable(DT::datatable({
data <- mpg
if (input$man != "All") {
data <- data[data$manufacturer == "dddddd",]
}
data
},options = list(searching = FALSE,paging = FALSE,callback=DT::JS(
'
{
"language": {
"zeroRecords": "No records to display- custom text"
}}
') )
))
}
shinyApp(ui = ui, server = server)
Do not use the callback, you can directly set the language -> zeroRecords attribute using the options parameter:
server <- function(input, output) {
# Filter data based on selections
output$table <- DT::renderDataTable(DT::datatable({
data <- mpg
if (input$man != "All") {
data <- data[data$manufacturer == "dddddd",]
}
data
}, options =
list(searching = FALSE,paging = FALSE,
language = list(
zeroRecords = "No records to display - custom text")
)))
}
This works for me.
I would like to have the address that is filled in by the autocomplete function in the javascript+html script to be added to a textInput() box in Shiny. Also, once I have submitted my form with that address I would like the autocompleted address to be reset. I have some experience in Shiny/R but none in Js. I'm fairly certain I need to add some lines in js to send information to Shiny but I'm not sure how. My script is below:
library(shiny)
library(googlesheets)
library(DT)
# Define the fields we want to save from the form
fields <- c("Title", "Description", "Order Type", "Existing", "Due Date", "Address")
gs_auth()
table <- "responses"
saveData <- function(data) {
# Grab the Google Sheet
sheet <- gs_title(table)
# Add the data as a new row
gs_add_row(sheet, input = data)
}
# Load all previous responses
# ---- This is one of the two functions we will change for every storage type ----
loadData <- function() {
# Grab the Google Sheet
sheet <- gs_title(table)
# Read the data
gs_read_csv(sheet)
}
# Shiny app with 3 fields that the user can submit data for
shinyApp(
ui = fluidPage(
titlePanel("Sign Form"),
fluidRow(
DT::dataTableOutput("responses", width = 300), tags$hr(),
column(3, textInput("Title", "Title", "")),
column(3, textInput("Description", "Description", "")),
column(3, selectInput("Order Type", label = ("Select Box"), choices = list("Installation",
"Installation/Maintenance",
"Replace Existing")))
),
fluidRow(
column(3,checkboxInput("Existing", "Is there an existing sign", FALSE)),
column(3, dateInput("Due Date", label = ('Date input'), format = "mm-dd-yyyy"))
),
fluidRow(
**column(3, textInput("Address","Address", includeHTML("www/autocomplete.html")))**
),
fluidRow(
column(3, actionButton("submit", "Submit"))
)
),
server = function(input, output, session) {
# Whenever a field is filled, aggregate all form data
formData <- reactive({
data <- sapply(fields, function(x) input[[x]])
data
})
# When the Submit button is clicked, save the form data
observeEvent(input$submit, {
saveData(formData())
})
# Show the previous responses
# (update with current response when Submit is clicked)
output$responses <- DT::renderDataTable({
input$submit
loadData()
})
}
)
The line with the autocomplete.html is where I would like some kind of textInput() that is populated when an end user fills in the address form
Here is the autocomplete.html file it is the example "Javascript + HTML"