I'm trying to give access to a specific view of my shiny dashboard to an external application. Basically, I want to give them a url link with a filter parameter so that when they click on the link, my shiny dashboard opens up on the specific view with the filters applied. I came across some other posts regarding the same on SO
Externally link to specific tabPanel in Shiny App
I tried using the code to figure out the solution, but haven't been able to. This is what I currently have, what I'd like to have is something like
http://127.0.0.1:7687/?url=%22Plot%202%22&species=%22setosa%22
This should open up the Plot 2 tab of the dashboard and apply the relevant filters. Any help on this would be great. Thanks!
library(shiny)
library(DT)
# Define UI for application that draws a histogram
ui <- navbarPage(title = "Navigate", id = 'nav',
# Application title
tabPanel("Plot",
plotOutput("distPlot")
),
tabPanel("Plot 2",
selectInput("species", "Select Species", choices = c("setosa", "virginica"),
multiple = T, selected = NULL),
dataTableOutput("tbl1")
)
)
# Define server logic required to draw a histogram
server <- function(input, output, session) {
observe({
query <- parseQueryString(session$clientData$url_search)
if(!is.null(query$url)) {
url <- strsplit(query$url,"/")[[1]]
updateTabsetPanel(session, 'nav', url)
}
})
output$distPlot <- renderPlot({
hist(rnorm(100), col = 'darkgray', border = 'white')
})
output$tbl1 <- renderDataTable({
tmp <- iris
if(!is.null(input$species))
tmp <- iris[which(iris$Species %in% input$species), ]
datatable(tmp)
})
}
# Run the application
shinyApp(ui = ui, server = server)
Your observe should be the following:
observe({
query <- parseQueryString(session$clientData$url_search)
if(!is.null(query$url)) {
url <- strsplit(query$url,"\"")[[1]][2]
species <- strsplit(query$species, "\"")[[1]][2]
updateTabsetPanel(session, 'nav', url)
updateSelectInput(session, 'species',selected = species)
}
})
Related
I have two tables with a shared key. The first table is always displayed in the UI. I would like the user to be able to click a link in the table and then show a modal dialogue that is the second table filtered based on the link that was clicked.
Specific example: Show mtcars as a table, with clickable links for the gear column. When one is clicked, for instance a 4, a modal dialog appears that shows all the cars with 4 gears. If 3 was clicked, you'd get all cars with 3 gears.
It does not appear that there is anyway to pass an argument with shiny::actionLink(), which is what I assume I would want to use for the table links. I realize my example below does not correctly create the links, but without knowing how the 2nd step works (acting on the links) I've just left in some pseudo code as an example.
library(shiny)
library(tidyverse)
ui <- fluidPage(
# Application title
titlePanel("mtcars"),
mainPanel(
tableOutput("table")
)
)
server <- function(input, output) {
output$table <- renderTable({
mtcars %>%
mutate(gear = actionLink("gearinput", label = gear)) #I realize this does not work, just leaving here as pseudo code.
})
observeEvent(input$gearinput, {
showModal(modalDialog(
title = "Gear filter",
mtcars %>% filter(gear == input$gearinput)), #I can't figure out how to actually get the value based on the link clicked
)
})
}
# Run the application
shinyApp(ui = ui, server = server)
I'm not very familiar with dplyr so I switched to data.table.
We can add an onclick event to the actionLinks and provide the clicked gear to shiny via Shiny.setInputValue:
library(shiny)
# library(dplyr)
library(data.table)
DT <- copy(mtcars)
setDT(DT)
ui <- fluidPage(
titlePanel("mtcars"),
mainPanel(
tableOutput("table")
)
)
server <- function(input, output) {
output$table <- renderTable({
DT[, inputId := paste0("gear_input_", seq_len(.N))][, gear_links := as.character(actionLink(inputId = inputId, label = inputId, onclick = sprintf("Shiny.setInputValue(id = 'gear_click', value = %s);", gear))), by = inputId][, inputId := NULL]
}, sanitize.text.function = function(x){x})
observeEvent(input$gear_click, {
showModal(modalDialog(
title = "Gear filter",
tableOutput("filtered_table"),
size = "xl"
))
})
output$filtered_table <- renderTable({
req(input$gear_click)
DT[gear == input$gear_click][, c("gear_links", "vs") := NULL]
})
}
shinyApp(ui = ui, server = server)
You might want to change the labels of the links to gear - but this way it's more comprehensible.
Useful links regarding this:
r shiny table not rendering html
https://shiny.rstudio.com/articles/communicating-with-js.html
I am researching how to change elements 'navbarPage' and 'tabPanel' components after loading R Shiny reactive system. Here is a code
library(shiny)
# How to change these elements after loading R Shiny reactive system
str_title <- "Title"
str_window_title <- "Window title"
str_cars <- "Cars"
str_iris <- "Iris"
# UI
ui <- fluidPage(
navbarPage(
title = str_title,
windowTitle = str_window_title,
tabPanel(title = str_cars, fluidPage(fluidRow(dataTableOutput("dt_mtcars")))),
tabPanel(title = str_iris, fluidPage(fluidRow(dataTableOutput("dt_iris"))))
))
# SERVER
server <- function(input, output) {
output$dt_mtcars <- renderDataTable(datatable(mtcars))
output$dt_iris <- renderDataTable(datatable(iris))
}
# RUN APP
shinyApp(ui = ui, server = server)
The question is how to change values of 'title', 'window_title' for 'navbarPage' component, and 'title' for 'tabPanel' component AFTER loading the Shiny app. For example, add to these names the prefix 'New ' and have the values 'New Title', 'New Window title', 'New Cars', 'New Iris'.
Thanks for sharing your ideas!
I couldn't find a solution for windowTitle, but for the 3 others elements you can use a textOutput and reactive values to make the elements change.
Here is an example of changing the elements names after clicking on an action button.
EDIT : found a way to change windowTitle too, based on this answer
library(shiny)
library(DT)
# UI
ui <- fluidPage(
actionButton("btn", "Change components' names"),
#javascript code to change window title
tags$script(HTML('Shiny.addCustomMessageHandler("changetitle", function(x) {document.title=x});')),
navbarPage(
title = textOutput("str_title"),
windowTitle = "Window title",
tabPanel(title = textOutput("str_cars"), fluidPage(fluidRow(dataTableOutput("dt_mtcars")))),
tabPanel(title = textOutput("str_iris"), fluidPage(fluidRow(dataTableOutput("dt_iris"))))
))
# SERVER
server <- function(input, output, session) {
# initialize names
rv <- reactiveValues(str_title = "Title",
str_window_title = "Window title",
str_cars ="Cars",
str_iris = "Iris")
output$dt_mtcars <- renderDataTable(datatable(mtcars))
output$dt_iris <- renderDataTable(datatable(iris))
output$str_title <- renderText({
rv$str_title
})
output$str_window_title <- renderText({
rv$str_window_title
})
output$str_cars <- renderText({
rv$str_cars
})
output$str_iris <- renderText({
rv$str_iris
})
#change names when button is clicked
observeEvent(input$btn,{
print("Change names")
rv$str_title <- paste0(rv$str_title,"+")
rv$str_window_title <- paste0(rv$str_window_title,"+")
rv$str_cars <- paste0(rv$str_cars,"+")
rv$str_iris <- paste0(rv$str_iris,"+")
session$sendCustomMessage("changetitle", rv$str_window_title )
})
}
# RUN APP
shinyApp(ui = ui, server = server)
This is my first Shiny app, and I just got the basics working to where it allows the user to select from a dropdown menu of clients, then a dropdown menu of test codes to receive a plot of the results for the selected test.
I'd like the second dropdown menu to be updated with the available test codes for that client (all are not present for each client). Also, I would like to be able to hover over the point in the plot and receive more information from the row in the original dataframe.
I've looked into tooltips and the nearPoints() function, but I'm not sure if these can be used on this data since it is manipulated. I'm not sure if at this point it would be easier to import the data in a different way (it will ultimately need to accept either excel files or .csv). Thanks for any help that you would be able to provide, please let me know if there is any other supporting info I can give.
Here is my code:
library(shiny)
library(scales)
library(ggplot2)
labData <-
read.table("MockNLData.csv",
header=TRUE, sep=",")
#convert '<10' and '<20' results
labData$ModResult <- labData$Result
levels(labData$ModResult)[levels(labData$ModResult)=="<10"]
<- "0"
levels(labData$ModResult)[levels(labData$ModResult)=="<20"]
<- "0"
#convert results to scientific notation
SciNotResult <-
formatC(as.numeric(as.character(labData$ModResult)),
format="e", digits=2)
ui <- fluidPage(
headerPanel("Dilution History"),
sidebarLayout(
sidebarPanel(
selectInput(inputId="client", label="Select Client
Name", choices=levels(labData$Client.Name)
),
selectInput(inputId="test", label="Select Test Code",
choices=levels(labData$Analysis))
),
mainPanel(
plotOutput("line", hover="plot_hov"),
verbatimTextOutput("info"))
)
)
server <- function(input, output) {
#selected client into data frame
selDF <- reactive({labData[labData[,1]==input$client,]
})
#selected test code into data frame
subsetDF <- reactive({selDF()[selDF()[,5]==input$test,]
})
#points to be plotted
points <-
reactive({as.numeric(levels(subsetDF()$ModResult))
[subsetDF()$ModResult]
})
#plot
output$line <- renderPlot({
qplot(seq_along(points()), points(), xlab ="Index",
ylab ="Result")
})
#hover information
output$info <- renderText({
paste0("x=", input$plot_hov$x, "\ny=",
input$plot_hov$y)
})
}
shinyApp(ui = ui, server = server)
Here is what the data looks like:
MockNLData.csv
EDIT: I figured out updating the menu with updateSelectInput()
In the future, make sure you share a reproducible example :)
Since your code is not reproducible please find below something you can understand and adapt to your case.
On your first question, if I understand correctly, you want to programatically generate a dropdown (selectInput) which is perfectly do-able. *Inputs are, in essence, just HTML content which you can dynamically generate, just like your plots. You do so with uiOutput (in your ui) and renderUI in your server.
library(shiny)
ui <- fluidPage(
selectInput("dataset", "Select a dataset", choices = c("cars", "mtcars")),
uiOutput("column"), # dynamic column selector
verbatimTextOutput("selected_column")
)
server <- function(input, output, session){
data <- reactive({
if(input$dataset == "cars")
return(cars)
else
return(mtcars)
})
output$column <- renderUI({
# build your selectInput as you normally would
selectInput("column_selector", "Select a column", choices = colnames(data()))
})
output$selected_column <- renderPrint({
# use input$column_selector!
print(input$column_selector)
})
}
shinyApp(ui, server)
On your second question, what you want is an interactive plot. There are numerous packages that will let you do that in R and Shiny. Below are some examples, by no means a comprehensive list:
plotly which will also let you make your ggplot2 charts interactive
highcharter another great, well tested library
echarts4r ECharts for R.
billboarder billboard.js for R and Shiny
Below is an example using highcharter. They all follow the same principle within Shiny, an *Output function coupled with a render* function.
library(shiny)
library(highcharter)
ui <- fluidPage(
highchartOutput("chart")
)
server <- function(input, output, session){
output$chart <- renderHighchart({
hchart(mpg, "scatter", hcaes(x = displ, y = hwy, group = class))
})
}
shinyApp(ui, server)
EDIT
Following your question on the flashing error. You need to require (req) the required input. When launching the app below the error will flash, uncomment the req(input$y) line and it'll go away.
library(shiny)
ui <- fluidPage(
uiOutput("sel"),
plotOutput("plot")
)
server <- function(input, output){
output$sel <- renderUI({
numericInput("y", "N:", value = 200, min = 5, max = 1000, step = 100)
})
output$plot <- renderPlot({
# req(input$y)
hist(runif(input$y, 1, 10))
})
}
shinyApp(ui, server)
In essence, since your plot relies on a dynamically generating input for a fraction of second that input is not available as it is being rendered, using req prevents that.
What I understand from your problem above are:
You want to make next dropdown menu based on what the user have chosen from previous dropdown menu.
When the mouse over the point on the plot, it will show row value.
So, here i will give you reproducible example and i hope it is useful for you.
In this example I use Rabbit dataset from library MASS.
To filter data for next dropdown menu, I use filter from library
dplyr (See line 30).
I use reactive expression to manage next dropdown menu (See line
29).
I use nearPoints() to manage hover point (See line 55).
library(shiny)
library(MASS)
library(dplyr)
library(ggplot2)
ui <- fluidPage(
titlePanel("Rabbit dataset from MASS library"),
fluidRow(
column(4, selectInput("var",
"Animal:",
unique(sort(Rabbit$Animal)))),
column(4, uiOutput("selected_var")),
column(4, uiOutput("selected_var1")),
column(12, plotOutput("selected_var2", hover = "plot_hover")),
column(12, verbatimTextOutput("info"))
)
)
server <- function(input, output) {
###FILTER NEXT DROPDOWN MENU BASED ON PREVIOUS SELECTED BY USER
dataset3 <- reactive({
unique(Rabbit %>% filter(Animal == input$var) %>% select(Treatment))
})
output$selected_var <- renderUI({
selectInput("var1", "Treatment:", c(dataset3()))
})
dataset4 <- reactive({
Rabbit %>% filter(Animal == input$var) %>% filter(Treatment == input$var1) %>% select(Run)
})
output$selected_var1 <- renderUI({
selectInput("var2", "Run:", c(dataset4()))
})
####
output$selected_var2 <- renderPlot({
ggplot(Rabbit %>% filter(Animal == input$var) %>% filter(Treatment == input$var1) %>% filter(Run == input$var2), aes(x = BPchange, y = Dose)) + geom_point()
})
###HOVER POINT USING nearPoints()
output$info <- renderPrint({
nearPoints(Rabbit %>% filter(Animal == input$var) %>% filter(Treatment == input$var1) %>% filter(Run == input$var2), input$plot_hover)
})
}
shinyApp(ui = ui, server = server)
i'd like to reuse an input field in a tabbed shiny app. my code is below.
library(shiny)
ui <- navbarPage("Iris data browser",
tabPanel("Panel 1",
selectInput("species", "Species",
unique(iris$Species)),
sliderInput("sepal.length", "Sepal length",
4.3,7.9,4.5,.1),
tableOutput("table1")),
tabPanel("Panel 2",
selectInput("species", "Species",
unique(iris$Species)),
tableOutput("table2")))
server <- function(input, output) {
output$table1 <- renderTable({
iris[iris$Species == input$species & iris$Sepal.Length <= input$sepal.length,c("Sepal.Length","Sepal.Width")]
})
output$table2 <- renderTable({
iris[iris$Species == input$species,c("Petal.Length","Petal.Width")]
})
}
# Run the application
shinyApp(ui = ui, server = server)
i'd like to use the same selectInput() on both panels. the expected result is that when i change the input value in "Panel 1" it will take on the same value in "Panel 2" and vice versa. of course, the filtering should also be applied to the tables on both panels. additionally, the input for species is shared on both panels, but the slider for sepal length should only appear on panel 1. therefore, sidebarLayout() is no solution.
thanks!
Here is a solution that uses 2 selectInputs but links them so that they have the same choices selected. Explanation of changes is below the code:
library(shiny)
ui <- navbarPage("Iris data browser",
tabPanel("Panel 1",
selectInput("species1", "Species", choices=unique(iris$Species)),
sliderInput("sepal.length", "Sepal length",
4.3,7.9,4.5,.1),
tableOutput("table1")),
tabPanel("Panel 2",
selectInput("species2", "Species", choices=unique(iris$Species) ),
uiOutput("select2"),
tableOutput("table2")))
server <- function(session, input, output) {
Selected<-reactiveValues(Species=NULL)
observeEvent(input$species1, Selected$Species<-(input$species1))
observeEvent(input$species2, Selected$Species<-(input$species2))
observeEvent(Selected$Species, updateSelectInput(session, "species1", selected=Selected$Species))
observeEvent(Selected$Species, updateSelectInput(session, "species2", selected=Selected$Species))
output$table1 <- renderTable({
iris[iris$Species == Selected$Species & iris$Sepal.Length <= input$sepal.length,c("Sepal.Length","Sepal.Width")]
})
output$table2 <- renderTable({
iris[iris$Species == Selected$Species ,c("Petal.Length","Petal.Width")]
})
}
# Run the application
shinyApp(ui = ui, server = server)
1) In the ui I changed the inputIds to "species1" and "species2"
2) I added the session parameter to your server function.
3) I created a reactiveValues object called Selected with an element called Species to store the currently selected species, it starts out as NULL.
4) The first two observeEvents will fire when the user chooses a species and stores that choice in Selected$Species. It does not matter which selector is used and will always have the value selected last.
5) The next two observeEvents update the two selectInputs to have the the selected choice be Selected$Species so that when you change the value in one tab it will change in the other automatically. You need to use the session argument here which is why I added it earlier.
6) I changed the tables to filter based on Selected$Species
There are a few advantages of this system. It would be easy to add more tabs with more selecteInputs and just add new observeEvent statements for them. If you have a bunch of these it might be worth you while to look into shiny modules.
Here, the tables just use Selected$Species but if you wanted to you could add more logic and they could sometimes update and sometimes not if that made sense for your app. That allows you to produce complicated behavior -for example if some values don't make sense for one of your displays you could catch that ahead of time and alert the user or display something else.
Not ideal, but this is what I meant in the comments:
library(shiny)
ui <- navbarPage("Iris data browser",
position = "fixed-top",
tabPanel("SideMenu",
sidebarPanel(
#push it down 70px to avoid going under navbar
tags$style(type="text/css", "body {padding-top: 70px;}"),
selectInput("species", "Species",
unique(iris$Species)),
conditionalPanel("input.myTabs == 'Panel 2'",
sliderInput("sepal.length", "Sepal length",
4.3,7.9,4.5,.1))
)
),
mainPanel(
tabsetPanel(id = "myTabs",
tabPanel("Panel 1",
tableOutput("table1")),
tabPanel("Panel 2",
tableOutput("table2"))
)
)
)
server <- function(input, output) {
output$table1 <- renderTable({
iris[iris$Species == input$species,c("Sepal.Length","Sepal.Width")]
})
output$table2 <- renderTable({
iris[iris$Species == input$species,c("Petal.Length","Petal.Width")]
})
}
# Run the application
shinyApp(ui = ui, server = server)
I have a Shiny app that consists of two pages:
Page 1 displays a DataTable with summary information (ensembles).
Page 2 displays detailed pricing info (items) for a specific ensemble, which is selectable.
When the user clicks on a row on page 1, I want them to be taken to page 2, with the corresponding ensemble selected.
The below code creates the Shiny app and the two pages, but requires the user to switch pages and enter the ensemble number manually.
app.R
library(shiny)
## Create item pricing data
set.seed(1234)
init_items = function() {
item.id=1:1000
ensemble.id=rep(1:100,each=10)
cost=round(runif(1000,10,100), 2)
profit=round(cost*runif(1000,0.01,0.15), 2)
price=cost+profit
data.frame(item.id, ensemble.id, cost, price, profit)
}
items = init_items()
## Create ensemble pricing data
init_ensembles = function(items) {
items %>% group_by(ensemble.id) %>% summarize_each(funs(sum), cost, price, profit)
}
ensembles = init_ensembles(items)
## Attach dependencies
## https://github.com/timelyportfolio/functionplotR/issues/1#issuecomment-224369431
getdeps <- function() {
htmltools::attachDependencies(
htmltools::tagList(),
c(
htmlwidgets:::getDependency("datatables","DT")
)
)
}
# Define UI for application
ui <- shinyUI(
navbarPage("Linked Table Test",
tabPanel("Page 1", uiOutput("page1")),
tabPanel("Page 2", uiOutput("page2"), getdeps())
)
)
# Define server logic
server <- shinyServer(function(input, output, session) {
output$page1 <- renderUI({
inclRmd("./page1.Rmd")
})
output$page2 <- renderUI({
inclRmd("./page2.Rmd")
})
})
# Run the application
shinyApp(ui = ui, server = server)
page1.Rmd
# Ensembles
Click on an ensemble to display detailed pricing information.
```{r}
tags$div(
DT::renderDataTable(ensembles, rownames = FALSE)
)
```
page2.Rmd
# Items
```{r}
inputPanel(
numericInput("ensemble.id", label = "Ensemble ID:", 0, min(ensembles$ensemble.id), max(ensembles$ensemble.id))
)
tags$div(
renderText(paste0("Detailed pricing information for ensemble #",input$ensemble.id,":"))
)
tags$div(
DT::renderDataTable(items %>% filter(ensemble.id==input$ensemble.id) %>% select(-ensemble.id), rownames = FALSE)
)
```
This should give you the tools to do what you want:
library(shiny)
library(DT)
ui <- fluidPage(
tabsetPanel(
tabPanel("One",
DT::dataTableOutput("test1")
),
tabPanel("two",
numericInput("length","Length",0,0,10)
)))
server <- function(input, output, session) {
df <- reactive({
cbind(seq_len(nrow(mtcars)),mtcars)
})
output$test1 <- DT::renderDataTable({
df()
},rownames=FALSE,options=list(dom="t"),
callback=JS(
'table.on("click.dt", "tr", function() {
tabs = $(".tabbable .nav.nav-tabs li a");
var data=table.row(this).data();
document.getElementById("length").value=data[0];
Shiny.onInputChange("length",data[0]);
$(tabs[1]).click();
table.row(this).deselect();})'
))
}
shinyApp(ui = ui, server = server)
When you click a row in the datatable, it switches tabs, and changes the value of the numeric input to the value of the first column in the row you selected.
edit: you will probably have to put your datatables explicitly in the shiny app and not include them from a r markdown script, since I don't believe shiny objects in R Markdown have html Ids in a reliably readable way.
edit: I took your code and got it to work:
library(shiny)
library(dplyr)
## Create item pricing data
set.seed(1234)
init_items = function() {
item.id=1:1000
ensemble.id=rep(1:100,each=10)
cost=round(runif(1000,10,100), 2)
profit=round(cost*runif(1000,0.01,0.15), 2)
price=cost+profit
data.frame(item.id, ensemble.id, cost, price, profit)
}
items = init_items()
## Create ensemble pricing data
init_ensembles = function(items) {
items %>% group_by(ensemble.id) %>% summarize_each(funs(sum), cost, price, profit)
}
ensembles = init_ensembles(items)
## Attach dependencies
## https://github.com/timelyportfolio/functionplotR/issues/1#issuecomment-224369431
getdeps <- function() {
htmltools::attachDependencies(
htmltools::tagList(),
c(
htmlwidgets:::getDependency("datatables","DT")
)
)
}
# Define UI for application
ui <- shinyUI(fluidPage(
tabsetPanel(#id="Linked Table Test",
tabPanel("Page 1", DT::dataTableOutput("page1")),
tabPanel("Page 2", inputPanel(
numericInput("ensemble.id", label = "Ensemble ID:", 0, min(ensembles$ensemble.id), max(ensembles$ensemble.id))
),
textOutput("page2"), DT::dataTableOutput("table2"),getdeps())
)
))
# Define server logic
server <- shinyServer(function(input, output, session) {
output$page1 <- DT::renderDataTable(ensembles, rownames = FALSE,
callback=JS(
'table.on("click.dt", "tr", function() {
tabs = $(".tabbable .nav.nav-tabs li a");
var data=table.row(this).data();
document.getElementById("ensemble.id").value=data[0];
Shiny.onInputChange("ensemble.id",data[0]);
$(tabs[1]).click();
table.row(this).deselect();
})'
))
output$table2 <- DT::renderDataTable(items %>% filter(ensemble.id==input$ensemble.id) %>% select(-ensemble.id), rownames = FALSE)
output$page2 <- renderText({
print(input$ensemble.id)
paste0("Detailed pricing information for ensemble #",input$ensemble.id,":")
})
})
# Run the application
shinyApp(ui = ui, server = server)