Interactive plotting in shiny using mouse clicks - r

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)

Related

Progress bar closes too soon with ggplot

I wonder if someone can explain the behavior of the progressBar().
I have trimmed my shiny app to the bare minimum to reproduce this post.
Now to the problem. When I select "AllRuns", the progress bar pops up and then goes away
before the graphic is displayed. But when I select "scatter", the progress bar nicely waits
until the scatter plot is displayed on the main panel. Is this a normal behavior?
How can I make the progress bar wait until the graphic displays when "AllRuns" is selected?
UPDATE The dataset can be read into R from google docs. it takes about 20 seconds to load into R.
library(shiny)
library(tidyverse)
library(DT)
library(data.table)
final <- fread("https://docs.google.com/spreadsheets/d/170235QwbmgQvr0GWmT-8yBsC7Vk6p_dmvYxrZNfsKqk/pub?output=csv")
runs<- c("AllRuns","scatter")
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput(inputId = "run",
label = "Chinook Runs",
choices = runs,
selected = "AllRuns"),
sliderInput(inputId = "Yearslider",
label="Years to plot",
sep="",
min=2000,
max=2014,
value=c(2010,2012))),
mainPanel(
plotOutput("plot")
)))
server <- function(input, output,session) {
session$onSessionEnded(function() {
stopApp()
})
plot_all <- reactive({
final[final$year >= input$Yearslider[1] & final$year <= input$Yearslider[2], ]
})
plotscatter <- reactive({
rnorm(100000)
})
dataInput <- reactive({
if (input$run == "AllRuns") {
plot_all()
}else{
plotscatter()
}
})
# Plot data
create_plots <- reactive({
withProgress(message="Creating graphic....",value = 0, {
n <- 10
for (i in 1:n) {
incProgress(1/n, detail = input$run)
Sys.sleep(0.1)
}
#Make the plots
theme_set(theme_classic())
switch(input$run,
"AllRuns" = ggplot(plot_all(),aes(SampleDate,Count,color = race2)) +
geom_point() + theme_bw() +
labs(x="",y="Number in thousands",title="All Salmon Runs combined"),
"scatter" = plot(plotscatter(),col="lightblue")
)
})#Progress bar closing brackets
})#create_plots closing brackets
output$plot <- renderPlot({
create_plots()
})
}
# Run the application
shinyApp(ui = ui, server = server)
It is simple that the progress bar is updated by the for-loop and the plot code only run after the for-loop. So the progress-bar reach the end, then plot code started. This kind of progress-bar would work if you are process something along with for-loop for example
list_of_files # assume you have a list of data file to read and process
max_progress <- length(list_of_files)
withProgress(message="Creating graphic....",value = 0, {
for (i in 1:max_progress) {
data <- read_csv(list_of_files[i])
... # doing something here
# once the processing code done next line of code will update the progress bar
incProgress(1/n, detail = input$run)
}
})
If you want to display loading one way to do it is using shinycssloaders::withSpinner() on the UI part which would show an animation of loading while UI is updating by server side.
The withProgress would be more useful when you have a list of items to process.
library(shiny)
library(tidyverse)
library(DT)
library(data.table)
library(shinycssloaders)
final <- fread("https://docs.google.com/spreadsheets/d/170235QwbmgQvr0GWmT-8yBsC7Vk6p_dmvYxrZNfsKqk/pub?output=csv")
runs<- c("AllRuns","scatter")
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput(inputId = "run",
label = "Chinook Runs",
choices = runs,
selected = "AllRuns"),
sliderInput(inputId = "Yearslider",
label="Years to plot",
sep="",
min=2000,
max=2014,
value=c(2010,2012))),
mainPanel(
withSpinner(plotOutput("plot"))
)))
server <- function(input, output,session) {
session$onSessionEnded(function() {
stopApp()
})
plot_all <- reactive({
final[final$year >= input$Yearslider[1] & final$year <= input$Yearslider[2], ]
})
plotscatter <- reactive({
rnorm(100000)
})
dataInput <- reactive({
if (input$run == "AllRuns") {
plot_all()
}else{
plotscatter()
}
})
# Plot data
create_plots <- reactive({
#Make the plots
theme_set(theme_classic())
switch(input$run,
"AllRuns" = ggplot(plot_all(),aes(SampleDate,Count,color = race2)) +
geom_point() + theme_bw() +
labs(x="",y="Number in thousands",title="All Salmon Runs combined"),
"scatter" = plot(plotscatter(),col="lightblue")
)
})#create_plots closing brackets
output$plot <- renderPlot({
create_plots()
})
}
# Run the application
shinyApp(ui = ui, server = server)

Get rownames of a reactive data frame in R shiny and create a date range slider

I have a dataframe with a time series as index. The data in the data frame are updated by a dashboard action (e.g. a download button) and therefore the dataframe is reactive. With a slider I want to be able to select only certain rows of the dataframe. The min max values of the slider therefore refer to the rownames of the reactive data frame. So far I am not able to get this implemented. Below the code. The if(0) part in the SERVER section is the one I am talking about. Any help appreciated.
require(shiny)
AquireData <- function(){
# In this function the data are created
df <- data.frame(replicate(3,sample(0:50,1000,rep=TRUE)))
rownames(df) <- seq(from = as.POSIXct("2012-05-15 07:00"),
to = as.POSIXct("2019-05-17 18:00"), by = "min")[0:dim(df)[1]]
names(df) <- c('A','B','C')
return (df)
}
ui <- fluidPage(
# App title
titlePanel("my dashboard"),
# define stuff for the sidebar (buttons, selectlists etc.). These items will
# be displayed for all panels
sidebarLayout(
sidebarPanel(
actionButton("Button_GetAndUpdate", "Update data"),
sliderInput("start_end_dates", "Date range", min =0, max=0, value=1)
),
# Main panel. Here you can display your graphs, plots and tables
mainPanel("observed data", tableOutput("rawdata"))
)
)
server <- function(input, output,session) {
# When the app is called an update of the data is drawn
df_data <- reactive({AquireData()})
# Check what the update button is doing. If its getting pressed pull and update
observeEvent (input$Button_GetAndUpdate,{df_data <<- reactive({AquireData()})})
# set date range slider values using the dates from the data frame index
if(0){
updateSliderInput(session, "start_end_dates",
label = "Date range",
min = as.POSIXct(min(rownames(df_data())),"%Y-%m-%d %H:%M:%S",tz=""),
max = as.POSIXct(max(rownames(df_data())),"%Y-%m-%d %H:%M:%S",tz="")
)
}
# get the head of the dataframe
data_head <- reactive({
input$Button_GetAndUpdate
isolate({
head(df_data())
})
})
output$rawdata <- renderTable({
data_head()
})
}
shinyApp(ui = ui, server = server)
runApp("Header_dashboard")
You could use shinyWidgets::sliderTextInput and shinyWidgets::updateSliderTextInput respectively instead of sliderInputfor this:
shinyWidgets::updateSliderTextInput(
session, "start_end_dates",
choices = rownames(df_data())
)
That means for your app:
require(shiny)
AquireData <- function(){
# In this function the data are created
df <- data.frame(replicate(3,sample(0:50,1000,rep=TRUE)))
rownames(df) <- seq(from = as.POSIXct("2012-05-15 07:00"),
to = as.POSIXct("2019-05-17 18:00"), by = "min")[0:dim(df)[1]]
names(df) <- c('A','B','C')
return (df)
}
ui <- fluidPage(
# App title
titlePanel("my dashboard"),
# define stuff for the sidebar (buttons, selectlists etc.). These items will
# be displayed for all panels
sidebarLayout(
sidebarPanel(
actionButton("Button_GetAndUpdate", "Update data"),
shinyWidgets::sliderTextInput(
"start_end_dates",
label = "Time range",
choices = c(as.POSIXct("2019-01-01 12:00:00"), as.POSIXct("2019-12-31 14:00:00")),
)
),
# Main panel. Here you can display your graphs, plots and tables
mainPanel("observed data", tableOutput("rawdata"))
)
)
server <- function(input, output,session) {
# When the app is called an update of the data is drawn
df_data <- reactive({AquireData()})
# Check what the update button is doing. If its getting pressed pull and update
observeEvent (input$Button_GetAndUpdate,{df_data <<- reactive({AquireData()})})
# set date range slider values using the dates from the data frame index
observe({
shinyWidgets::updateSliderTextInput(
session, "start_end_dates",
choices = rownames(df_data())
)
})
# get the head of the dataframe
data_head <- reactive({
input$Button_GetAndUpdate
isolate({
head(df_data())
})
})
output$rawdata <- renderTable({
data_head()
})
}
shinyApp(ui = ui, server = server)

Change plot based on click input in R shiny

For my app, I need the user to click an area on a plot, then the plot responds to that click and shows a new plot that is linked to that input click.
However, currently it runs, but the new plot only displays for 3 seconds and then goes back to the original plot. I found a similar example here. This plot updates based on a list of reactiveValues then draws those new points the user selected. I think if I find a way to modify it to draw the new plot immediatly after the clicked event it should work, but stuck on this part.
So ideally the below example will add the new point immediatly after beind clicked. In my case I will need to display the new plot until a new area of the plot is clicked.
Example from the link
library(shiny)
ui <- basicPage(
plotOutput("plot1", click = "plot_click"),
verbatimTextOutput("info"),
actionButton("updateplot", "Update Plot:")
)
server <- function(input, output) {
val <- reactiveValues(clickx = NULL, clicky = NULL)
observe({
input$plot_click
isolate({
val$clickx = c(val$clickx, input$plot_click$x)
val$clicky = c(val$clicky, input$plot_click$y)
})
}) #adding clicks to list
output$plot1 <- renderPlot({
plot(mtcars$wt, mtcars$mpg)
input$updateplot
isolate({
points(val$clickx, val$clicky)
})
})
output$info <- renderText({
paste0("x = ", val$clickx, ", y = ",val$clicky, "\n")
})
}
shinyApp(ui, server)
This example shows a main plot and upon click in the main plot it shows a sub plot. Once clicked again it shows again the main plot.
The idea is that a counter (trigger) is increased whenever a click happens. It is important to use req(.) in the observer, lest the observer fires again when the mouse button is released (in this case input$plot_click is set to NULL).
The renderPlot(.) then takes a dependency on this trigger and shows either the main or the sub plot.
Update. If you want to use info from the input$plot_click object you should save it as well, to avoid that it get NULL.
library(shiny)
library(ggplot2)
ui <- basicPage(
plotOutput("plot1", click = "plot_click")
)
server <- function(input, output) {
plot_data <- reactiveValues(trigger = 0, x = NA, y = NA)
observe({
req(input$plot_click)
isolate(plot_data$trigger <- plot_data$trigger + 1)
plot_data$x <- input$plot_click$x
plot_data$y <- input$plot_click$y
})
output$plot1 <- renderPlot({
if (plot_data$trigger %% 2 == 0) {
plot(1:10, main = "Main Plot")
} else {
ggplot() + geom_point(aes(x = plot_data$x, y = plot_data$y), size = 5, shape = 19)
}
})
}
shinyApp(ui, server)
Just drop the isolate in your renderPlot:
library(shiny)
ui <- basicPage(
plotOutput("plot1", click = "plot_click"),
verbatimTextOutput("info")
)
server <- function(input, output) {
val <- reactiveValues(clickx = NULL, clicky = NULL)
observe({
input$plot_click
isolate({
val$clickx = c(val$clickx, input$plot_click$x)
val$clicky = c(val$clicky, input$plot_click$y)
})
}) #adding clicks to list
output$plot1 <- renderPlot({
plot(mtcars$wt, mtcars$mpg)
points(val$clickx, val$clicky)
})
output$info <- renderText({
paste0("x = ", val$clickx, ", y = ",val$clicky, "\n")
})
}
shinyApp(ui, server)

R shiny: Hide NA before using plot click to return values in conditional panel

I am using plot_click to interrogate a graph in Shiny and would like the conditional panel to show 2 bits of information. However at the moment, the conditional panel shows 'NA' until i perform the plot click, how do i make this disappear?
library(ggplot2)
library(shiny)
# make some data
df <- data.frame(ID=c(1,2),x=c(33,7),y=c(50,16),name=c("Tom","Bill"),link=c("https://mylink.com","https://anotherlink.com"), stringsAsFactors=FALSE)
# Shiny app
ui <- basicPage(
plotOutput("plot", click = "plot_click"),
verbatimTextOutput("selection"),
conditionalPanel("!is.na(output.nametext)",
h4(textOutput("nametext")),
h4(textOutput("urltext")))
)
server <- function(input, output,session) {
output$plot <- renderPlot({
ggplot(data=df,aes(x=x,y=y))+
geom_point()+
scale_x_continuous(limits = c(0, 68))+
scale_y_continuous(limits = c(0, 52.5))
})
output$selection <- renderPrint({
nearPoints(df, input$plot_click)
})
info <- reactive({
t <- as.data.frame(nearPoints(df, input$plot_click))
s <- t[1,4]
u <- t[1,5]
list(s=s,u=u)
})
output$nametext <- renderText({info()$s})
output$urltext <- renderText({info()$u})
}
runApp(shinyApp(ui, server), launch.browser = TRUE)
in the conditionalPanel in the UI, i've tried !is.na(output.nametext), output.nametext != null, output.nametext==true, plot_click==true, plot_click!=null and more. None of them remove the NA that exists before i perform the click.
One solution would be to simply use:
output$nametext <- renderText({
if(!is.na(info()$s)){
info()$s
}
})
You could also use the space to inform the user he should click a point to see information:
output$urltext <- renderText({
if(!is.na(info()$s)){
info()$u
}else{
print("Click on a point to get additional information")
}
})

RStudio and Shiny: define a reactiveValues with a Reactive

I am having a dataframe that is build depending on user input, choosing different filters. I then want to create a bar plot from this custom dataframe where the user can click on to exclude bars from the plot. I basically followed this example:
https://gallery.shinyapps.io/106-plot-interaction-exclude/
However, when I try to define my reactiveValues value with my reactive, I can not define it and get an error. I am suspecting I can not define a reactiveValues with a reactive, is this right? How should I handle this then? Should I use reactives instead of reactiveValues?
Example code:
Server
server <- function(input, output) {
df <- reactive({
input$input1
})
vals2 <- reactive({
(df())
})
output$Id1 <- renderText({
vals2()
})
vals <- reactiveValues()
vals$bla <- df()
}
UI
library(shiny)
ui <- fluidPage(
fluidRow(
column(width= 4,
textInput(inputId = "input1", label = "Select number of rows", value = "10")
),
column(width = 12,
verbatimTextOutput(outputId = "Id1"),
verbatimTextOutput(outputId = "Id2")
)
)
)
Create your reactiveValues towards the beginning of your function and initialise is with a NULL
vals <- reactiveValues(bla = NULL)
You can then write to vals$bla from inside observeEvent, for instance when a button is pressed.
You can read from the reactiveValue, for instance to draw a plot in the form:
output$myPlot <- renderPlot( some function of values$bla )
EDIT updating to add my comment, create an observeEvent which watches your input1, when this changes it will execture the code within {} which will write to your reactiveValue.
observeEvent(input$input1, {
vals$bla <- input$input1
})

Resources