I am working on an application in sinydashboard in which the user generates a random number on the click of a button. The random number corresponds to a row in a dataframe which I need to display on the dashboard using an infoBox. Each infoBox needs to persist on the screen until the user closes the application.
I tried generating a new output variable on each click in server.R, however I could not find a way of referencing it in ui.R. Minimal example below. I've not included generating a name for an output variable on each button click as that's not working at all.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(dashboardHeader(title = ""),
dashboardSidebar(),
dashboardBody(fluidRow(
box(
width = 3,
actionButton(inputId = "generateButton",
label = "Generate")
),
box(infoBoxOutput("rnum1"))
)))
server <- function(input, output) {
randomData <- data.frame("RN" = runif(100, 1, 100))
observeEvent(input$generateButton, {
randomNumber <- floor(runif(1, 1, 100))
dataRow <- randomData[randomNumber,]
# Display dataRow in a persistent infoBox
# in a way that 5 clicks will produce 5 boxes
# Number of clicks is not known in advance
output$rnum1 <- renderInfoBox({
infoBox("Number", dataRow)
})
})
}
shinyApp(ui = ui, server = server)
Maybe this is what you want, at leat this a draft. You'll need a reactive variable to store the already generated numbers to be able to have something persistent.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(dashboardHeader(title = ""),
dashboardSidebar(),
dashboardBody(actionButton(inputId = "generateButton",
label = "Generate")
,
uiOutput('infoBoxes'))
)
server <- function(input, output) {
randomData <- data.frame("RN" = runif(100, 1, 100))
rv <- reactiveValues()
observeEvent(input$generateButton, {
randomNumber <- floor(runif(1, 1, 100))
dataRow <- randomData[randomNumber,]
print(dataRow)
rv$persistent <- c(rv$persistent, dataRow)
# Display dataRow in a persistent infoBox
})
output$infoBoxes = renderUI({
if(length(rv$persistent) > 0 ) {
fluidRow(
Map(function(x) infoBox('title', rv$persistent[x]), 1:length(rv$persistent))
)
}
})
}
shinyApp(ui = ui, server = server)
Related
I have the following Shiny Application:
library(shiny)
library(shinyjs)
library(shinydashboard)
UI <- fluidPage(
actionButton("get_tweets", "Fetch tweets"),
numericInput("tweet_amount", "Set the amount of Tweets", 10, min = 10, max = 1000),
selectInput("tweet_name", "Select the tweeter", selected = NULL, choices = c("#RealDonaldTrump")),
#Set hidden buttons
hidden(
div(id="status_update",
verbatimTextOutput("status")
)
),
hidden(
div(id="tweet_fetcher",
verbatimTextOutput("status2")
)
)
)
Server <- function(input, output){
list = c(1,2,3)
get_connected <- reactive({
for(i in 1:length(list)){
Sys.sleep(2)
}
})
observeEvent(input$get_tweets, {
get_connected()
toggle("status_update")
output$status <- renderText({"You're now connected to the API"})
toggle("tweet_fetcher")
output$status2 <- renderText("Test")
})
}
shinyApp(ui = UI, server = Server)
Thing is that now I works. However, ideally I would like to make sure a button appears. Therefore I want to change:
output$status2 <- renderText("Test")
and this
verbatimTextOutput("status2") #actionButton("status2", "a_button")
This does not work. Any tips on what I should use if I want JS to let a button appear?
If i understand the question correctly you want to interchange
verbatimTextOutput("status2") with actionButton("status2", "a_button").
Then you should use renderUI():
Server side: output$status2 <- renderUI(actionButton("status2",
"a_button"))
UI side: uiOutput("status2")
Full app would read:
library(shiny)
library(shinyjs)
library(shinydashboard)
UI <- fluidPage(
actionButton("get_tweets", "Fetch tweets"),
numericInput("tweet_amount", "Set the amount of Tweets", 10, min = 10, max = 1000),
selectInput("tweet_name", "Select the tweeter", selected = NULL, choices = c("#RealDonaldTrump")),
#Set hidden buttons
hidden(
div(id="status_update",
verbatimTextOutput("status")
)
),
hidden(
div(id="tweet_fetcher",
uiOutput("status2")
)
)
)
Server <- function(input, output){
list = c(1,2,3)
get_connected <- reactive({
for(i in 1:length(list)){
Sys.sleep(2)
}
})
observeEvent(input$get_tweets, {
get_connected()
toggle("status_update")
output$status <- renderText({"You're now connected to the API"})
toggle("tweet_fetcher")
output$status2 <- renderUI(actionButton("status2", "a_button"))
})
}
shinyApp(ui = UI, server = Server)
I need to only display a BS modal when a button is pressed and and a condition on a variable is met.
This is a simple app that demonstrates what the challenge is. I need to display a BS modal when num_rows >= 500, and the submit button is fired, not just when the submit button is fired.
I am aware this could be done with a conditionalPanel using input.slider as one of the conditions, but in my real project it is much more complicated than this, and the BS modal/conditional panel needs to depend on both a button (user input) and a variable assigned in the server.
library(shiny)
library(shinyBS)
data = matrix(rnorm(1000*10, 0, 1), nrow = 1000)
ui <- fluidPage(
fluidRow(
column(width = 4,
sliderInput("slider", "Choose Number of Rows to Display", 0, 1000, value = NULL),
submitButton('Submit'),
bsModal("modalExample", "Yes/No", "submit", size = "small", wellPanel(
p(div(HTML("<strong>Warning: </strong> you have chosen to display a large
number of rows. Are you sure you want to proceed?"))),
actionButton("no_button", "Yes"),
actionButton("yes_button", "No")
))
),
column(width = 8,
tableOutput('data')
)
)
)
server <- shinyServer(function(input, output, server){
observe({
num_rows <- input$slider
if(num_rows >= 500){
#
# ACTIVATE MODAL PANEL
#
observeEvent(input$no_button, {
# Do not show table
})
observeEvent(input$yes_button, {
output$table <- renderTable(data)
})
} else{ # Display table normally if number of rows is less than 500
output$table <- renderTable(data)
}
})
})
shinyApp(ui, server)
Have a look at the following code. I disabled the action button if num_rows<500 with the package shinyjs. If num_rows>=500 the action button becomes available to trigger the popup. To update the number of rows selected with the slider you'll have to press the submit button every time. Hope this helps or gets you some ideas. For now I have not implemented your warning message (that did not work for me). Another issue: the slider and display for the pop up only work towards increasing number of rows, not decreasing afterwards. If you find a solution for that, pls share =)
library(shiny)
library(shinyBS)
library(shinyjs)
data = matrix(rnorm(1000*10, 0, 1), nrow = 1000)
data1=data[(1:500),]
head(data)
ui <- fluidPage(
fluidRow(
column(width = 4,
sliderInput("slider", "Choose Number of Rows to Display", 0, 1000, value = NULL),
submitButton('Submit'),
actionButton('Show','Show'),
useShinyjs(),
bsModal("modalExample",'Yes/No','Show', size = "large",tableOutput("tab")
# wellPanel(
# p(div(HTML("<strong>Warning: </strong> you have chosen to display a large
# number of rows. Are you sure you want to proceed?")
# )))
)),
column(width = 8,tableOutput('table'))))
server <- function(input, output)({
observe({
num_rows = input$slider
if(num_rows<500 &num_rows!=0) {
shinyjs::disable('Show')
output$table <- renderTable({
data = data1[(1:num_rows),]
print(head(data1))
data})
}else{
shinyjs::enable('Show')
output$tab = renderTable({
data = data[(1:num_rows),]
data}) }
})
})
shinyApp(ui, server)
My shiny app begins with a checkboxGroupInput which contains the names of three companies: A, B and C. It also has 3 hidden numeric inputs, each corresponding to a company. Potential investors may select the name of the company they wish to invest in and specifiy the amount they are willing to invest. When the name of a company is checked, the corresponding numeric input shows up. Also, when the company name is unchecked, the numeric input disappears.
The checkboxGroupInput is called company. The 3 numericInput fields are respectively called amountA, amountB and amountC and are all generated inside a uiOutput. They are hidden with the hidden function of shinyjs.
library(shiny)
library(shinyjs)
library(magrittr)
ui <- fluidPage(
useShinyjs(),
checkboxGroupInput(inputId = "company", label = "Select a company", choices = LETTERS[1:3]),
uiOutput(outputId = "amounts")
)
server <- function(input, output){
company_names <- LETTERS[1:3]
num_ids <- paste0("amount", LETTERS[1:3])
output$amounts <- renderUI({
num_inputs <- lapply(1:3, function(i){
numericInput(inputId = num_ids[i], label = paste0("Investment in ", company_names[i]), value = 0, min = 0, max = 5000)
}) %>% tagList
shinyjs::hidden(num_inputs)
})
observeEvent(eventExpr = input$company, handlerExpr = {
if(length(input$company) == 0){
for(i in num_ids){
shinyjs::hide(id = i)
}
} else {
for(i in input$company){
shinyjs::toggle(id = paste0("amount", i), condition = input$company)
}
}
})
}
shinyApp(ui = ui, server = server)
The problem with my app is that the intended dynamics between the checkboxGroupInput and the numericInput fields are not working as intended. For instance, once a numericInput is shown, it cannot be hidden anymore by unchecking the boxes. How can I handle this?
The code pasted above is fully functional. Thank you very much.
I fixed your code by explicitly show/hide the numericInput when the corresponding check box is selected/unselected. Also I change the observeEvent with observe to make sure that the observer reacts when none of the check boxes are selected.
library(shiny)
library(shinyjs)
library(magrittr)
ui <- fluidPage(
useShinyjs(),
checkboxGroupInput(inputId = "company", label = "Select a company", choices = LETTERS[1:3]),
uiOutput(outputId = "amounts")
)
server <- function(input, output){
company_names <- LETTERS[1:3]
num_ids <- paste0("amount", LETTERS[1:3])
output$amounts <- renderUI({
num_inputs <- lapply(1:3, function(i){
numericInput(inputId = num_ids[i], label = paste0("Investment in ", company_names[i]), value = 0, min = 0, max = 5000)
}) %>% tagList
shinyjs::hidden(num_inputs)
})
observe({
for(i in company_names){
if (i %in% input$company) {
shinyjs::show(id = paste0("amount", i))
} else {
shinyjs::hide(id = paste0("amount", i))
}
}
})
}
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)
I am doing a project where I use the shiny server and connect R to mongodb to fetch results from database and display it dynamically.
However, I face the following problem in it. I initially get the results from db and make a plot. After this plot is done, I want the user to make make two mouse clicks on the plot based on which it should take the two values as xlim and plot a zoomed version of the previous plot. However, I am not able to do it successfully.
Here is the code that I have written.
ui.R
library(shiny)
shinyUI(fluidPage(
titlePanel("LOAD AND PERFORMANCE DASHBOARD"),
sidebarLayout(
sidebarPanel(
fluidRow(
selectInput("select", label = h3("Select type of testing"),
choices = list("Performance Testing"=1, "Capacity Testing"=2)),
radioButtons("radio", label = h3("Select parameter to plot"),
choices = list("Disk" = 1, "Flit" = 2,"CPU" = 3,"Egress" =4,
"Memory" = 5))
)),
mainPanel(
plotOutput("plot",clickId="plot_click"),
textOutput("text1"),
plotOutput("plot2")
)
)
))
server.R
library(shiny)
library(rmongodb)
cursor <- vector()
shinyServer(function(input, output) {
initialize <- reactive({
mongo = mongo.create(host = "localhost")
})
calculate <- reactive({
if(input$radio==1)
xvalue <- mongo.distinct(mongo,ns = "mydb.vload", "disk")
else if(input$radio==2)
xvalue <- mongo.distinct(mongo,ns = "mydb.vload", "flit")
else if(input$radio==3)
xvalue <- mongo.distinct(mongo,ns = "mydb.vload", "cpu")
else if(input$radio==4)
xvalue <- mongo.distinct(mongo,ns = "mydb.vload", "egress")
else if(input$radio==5)
xvalue <- mongo.distinct(mongo,ns = "mydb.vload", "memory")
})
output$plot <- renderPlot({
initialize()
value <- calculate()
plot(value,xlab="Time",ylab="% Consumed")
lines(value)
cursor <- value
})
output$text1 <- renderText({
paste("You have selected",input$plot_click$x)
})
output$plot2 <- renderPlot({
plot(cursor[cursor<input$plot_click$x && cursor>first_click ],xlab="Time",ylab="% Consumed") lines(cursor)
first_click <- input$plot_click$x
})
})
Thanks in advance for the help :)
Here's a simple example that demonstrates the behavior you want, just run this code (or save as a file and source it). This code uses the new observeEvent function that debuted in Shiny 0.11, which just hit CRAN over the weekend.
The basic idea is that we track two reactive values, click1 and range. click1 represents the first mouse click, if any exists; and range represents the x-values of both mouse clicks. Clicking on the plot simply manipulates these two reactive values, and the plotting operation reads them.
library(shiny)
ui <- fluidPage(
h1("Plot click demo"),
plotOutput("plot", clickId = "plot_click"),
actionButton("reset", "Reset zoom")
)
server <- function(input, output, session) {
v <- reactiveValues(
click1 = NULL, # Represents the first mouse click, if any
range = NULL # After two clicks, this stores the range of x
)
# Handle clicks on the plot
observeEvent(input$plot_click, {
if (is.null(v$click1)) {
# We don't have a first click, so this is the first click
v$click1 <- input$plot_click
} else {
# We already had a first click, so this is the second click.
# Make a range from the previous click and this one.
v$range <- range(v$click1$x, input$plot_click$x)
# And clear the first click so the next click starts a new
# range.
v$click1 <- NULL
}
})
observeEvent(input$reset, {
# Reset both the range and the first click, if any.
v$range <- NULL
v$click1 <- NULL
})
output$plot <- renderPlot({
plot(cars, xlim = v$range)
if (!is.null(v$click1$x))
abline(v = v$click1$x)
})
}
shinyApp(ui, server)