Related
For the first time I really can't find this answer here already, so I hope you all can help me, I'm sure there is a pretty easy fix.
I am making a Shiny volcano plot with clickable points to give me a table with the data about that point. If I use a trans function (that I found here, thank you helpful stranger) within scale_y_continuous() in my plot, points in the scaled region are no longer clickable. How can I scale the axis this way and still be able to have the clickable points?
My code, with some fake data that has the same problem:
## Read in necessary libraries, function, and data
library(shiny)
library(ggplot2)
library(dplyr)
library(scales)
reverselog_trans <- function(base = exp(1)) {
trans <- function(x) -log(x, base)
inv <- function(x) base^(-x)
trans_new(paste0("reverselog-", format(base)), trans, inv,
log_breaks(base = base),
domain = c(1e-100, Inf))
}
pretend_data <- tibble(data=1:5, estimate = runif(5, min = -1, max = 2), plot = c(1e-50, 2e-35, 5e-1, 1, 50))
# Define UI for application that draws a volcano plot
ui <- fluidPage(
# Application title
titlePanel("Pretend Plot"),
plotOutput("plot", click = "plot_click"),
tableOutput("data")
)
# Define server logic required to draw a volcano plot
server <- function(input, output, session) {
output$plot <- renderPlot({
ggplot(data = pretend_data, aes(x=estimate, y=plot)) +
geom_vline(xintercept=c(-1, 1), linetype=3) +
geom_hline(yintercept=0.01, linetype=3) +
geom_point() +
scale_y_continuous(trans = reverselog_trans(10))
}, res = 96)
output$data <- renderTable({
req(input$plot_click)
nearPoints(pretend_data, input$plot_click)
})
}
# Run the application
shinyApp(ui = ui, server = server)
The problem is that input$plot_click returns the coordinates on the transformed scale. nearPoints tries then to match those to the original scale which does not work.
You have a couple of options though:
Transform the data yourself and adapt y axis ticks via scale_y_continuous
Adapt pretend_data in the nearPoints call.
Option 1
This requires that you control y axis tick marks yourself and would need some more fiddling to get the exact same reuslts as in your example.
pretend_data_traf <- pretend_data %>%
mutate(plot = reverselog_trans(10)$transform(plot))
# Define UI for application that draws a volcano plot
ui <- fluidPage(
# Application title
titlePanel("Pretend Plot"),
plotOutput("plot", click = "plot_click"),
tableOutput("data")
)
# Define server logic required to draw a volcano plot
server <- function(input, output, session) {
output$plot <- renderPlot({
ggplot(data = pretend_data_traf, aes(x=estimate, y=plot)) +
geom_vline(xintercept=c(-1, 1), linetype=3) +
geom_hline(yintercept=0.01, linetype=3) +
geom_point() +
## would need to define breaks = to get same tick mark positions
scale_y_continuous(labels = reverselog_trans(10)$inverse)
}, res = 96)
output$data <- renderTable({
req(input$plot_click)
nearPoints(pretend_data_traf, input$plot_click)
})
}
# Run the application
shinyApp(ui = ui, server = server)
Option 2
pretend_data_traf <- pretend_data %>%
mutate(plot = reverselog_trans(10)$transform(plot))
# Define UI for application that draws a volcano plot
ui <- fluidPage(
# Application title
titlePanel("Pretend Plot"),
plotOutput("plot", click = "plot_click"),
tableOutput("data")
)
# Define server logic required to draw a volcano plot
server <- function(input, output, session) {
output$plot <- renderPlot({
ggplot(data = pretend_data, aes(x=estimate, y=plot)) +
geom_vline(xintercept=c(-1, 1), linetype=3) +
geom_hline(yintercept=0.01, linetype=3) +
geom_point() +
scale_y_continuous(trans = reverselog_trans(10))
}, res = 96)
output$data <- renderTable({
req(input$plot_click)
nearPoints(pretend_data_traf, input$plot_click) %>%
mutate(plot = reverselog_trans(10)$inverse(plot))
})
}
# Run the application
shinyApp(ui = ui, server = server)
I tried to fetch streaming data from mosquito test server for creating a real time line chart. I checked some examples of real time chart, but I couldn't seem to achieve the same objective. The chart is updated real time but it always refreshes.
Here is the script I edited from one example:
library(shiny)
library(magrittr)
library(mqtt)
library(jsonlite)
ui <- shinyServer(fluidPage(
plotOutput("plot")
))
server <- shinyServer(function(input, output, session){
myData <- data.frame()
# Function to get new observations
get_new_data <- function(){
d <- character()
mqtt::topic_subscribe(host = "test.mosquitto.org", port = 1883L, client_id = "dcR", topic = "IoTDemoData",
message_callback =
function(id, topic, payload, qos, retain) {
if (topic == "IoTDemoData") {
d <<- readBin(payload, "character")
# print(received_payload)
# received_payload <- fromJSON(received_payload)
# print(d)
return("quit")
}
}
)
d <- fromJSON(d)
d <- as.data.frame(d)
return(d)
# data <- rnorm(5) %>% rbind %>% data.frame
# return(data)
}
# Initialize my_data
myData <- get_new_data()
# Function to update my_data
update_data <- function(){
myData <<- rbind(get_new_data(), myData)
}
# Plot the 30 most recent values
output$plot <- renderPlot({
invalidateLater(1000, session)
update_data()
print(myData)
plot(temperature ~ 1, data=myData[1:30,], ylim=c(-20, -10), las=1, type="l")
})
})
shinyApp(ui=ui,server=server)
I have been struggling with creating real time chart for days. If anyone can point out the problem why the line chart is always refreshed and the solution, it will be highly appreciated!
Below are the revised working script based on Florian's answer:
library(shiny)
library(mqtt)
library(jsonlite)
library(ggplot2)
ui <- shinyServer(fluidPage(
plotOutput("mqttData")
))
server <- shinyServer(function(input, output, session){
myData <- reactiveVal()
get_new_data <- function(){
d <- character()
mqtt::topic_subscribe(host = "localhost", port = 1883L, client_id = "dcR", topic = "IoTDemoData",
message_callback =
function(id, topic, payload, qos, retain) {
if (topic == "IoTDemoData") {
d <<- readBin(payload, "character")
return("quit")
}
}
)
d <- fromJSON(d)
d <- as.data.frame(d)
return(d)
}
observe({
invalidateLater(1000, session)
isolate({
# fetch the new data
new_data <- get_new_data()
# If myData is empty, we initialize it with just the new data.
if(is.null(myData()))
myData(new_data)
else # row bind the new data to the existing data, and set that as the new value.
myData(rbind(myData(),new_data))
})
})
output$mqttData <- renderPlot({
ggplot(mapping = aes(x = c(1:nrow(myData())), y = myData()$temperature)) +
geom_line() +
labs(x = "Second", y = "Celsius")
})
})
shinyApp(ui=ui,server=server)
However, after adding a second plot, the flickering began. When I commented out one of the plots, the plot works great without the need to refresh.
library(shiny)
library(mqtt)
library(jsonlite)
library(ggplot2)
ui <- shinyServer(fluidPage(
plotOutput("mqttData"),
plotOutput("mqttData_RH")
))
server <- shinyServer(function(input, output, session){
myData <- reactiveVal()
get_new_data <- function(){
d <- character()
mqtt::topic_subscribe(host = "test.mosquitto.org", port = 1883L, client_id = "dcR", topic = "IoTDemoData",
# mqtt::topic_subscribe(host = "localhost", port = 1883L, client_id = "dcR", topic = "IoTDemoData",
message_callback =
function(id, topic, payload, qos, retain) {
if (topic == "IoTDemoData") {
d <<- readBin(payload, "character")
return("quit")
}
}
)
d <- fromJSON(d)
d <- as.data.frame(d)
d$RH <- as.numeric(as.character( d$RH))
return(d)
}
observe({
invalidateLater(10000, session)
isolate({
# fetch the new data
new_data <- get_new_data()
# If myData is empty, we initialize it with just the new data.
if(is.null(myData()))
myData(new_data)
else # row bind the new data to the existing data, and set that as the new value.
myData(rbind(myData(),new_data))
})
})
output$mqttData <- renderPlot({
ggplot(mapping = aes(x = c(1:nrow(myData())), y = myData()$temperature)) +
geom_line() +
labs(x = "Second", y = "Celsius")
})
output$mqttData_RH <- renderPlot({
ggplot(mapping = aes(x = c(1:nrow(myData())), y = myData()$RH)) +
geom_line() +
labs(x = "Second", y = "RH %")
})
})
shinyApp(ui=ui,server=server)
One solution I found plot the charts in one renderPlot object. The flickering reduces.
output$mqttData <- renderPlot({
myData() %>%
gather('Var', 'Val', c(temperature, RH)) %>%
ggplot(aes(timestamp,Val, group = 1))+geom_line()+facet_grid(Var ~ ., scales="free_y")
})
However, I wonder if there is way to plot the charts separately without flickering / refreshing.
I found one github example put data to ggplot2 using pipe %>% (https://github.com/mokjpn/R_IoT) and modified it to plot separated charts.
library(shiny)
library(ggplot2)
library(tidyr)
# Dashboard-like layout
ui <- shinyServer(fluidPage(
fluidRow(
column(
6,
plotOutput("streaming_data_1")
),
column(
6,
plotOutput("streaming_data_2")
)
),
fluidRow(
column(
6,
plotOutput("streaming_data_3")
),
column(
6,
plotOutput("streaming_data_4")
)
)
))
server <- shinyServer(function(input, output, session){
myData <- reactiveVal()
# show the first and last timestamp in the streaming charts
realtime_graph_x_labels <- reactiveValues(first = "",last ="")
get_new_data <- function(){
epochTimeStamp <- as.character(as.integer(Sys.time()))
sensor_1 <- -runif(1,min = 10, max = 30)
sensor_2 <- runif(1,min = 0,max = 100)
sensor_3 <- runif(1,min = 0,max = 100000)
sensor_4 <- runif(1,min = 0,max = 10)
newData <- data.frame(ts = epochTimeStamp, val_1 = sensor_1, val_2 = sensor_2, val_3 = sensor_3, val_4 = sensor_4)
return(newData)
}
observe({
invalidateLater(1000, session)
isolate({
# fetch the new data
new_data <- get_new_data()
# If myData is empty, we initialize it with just the new data.
if(is.null(myData()))
{
myData(new_data)
realtime_graph_x_labels$first <- as.character(head(myData()$ts,1))
}
else # row bind the new data to the existing data, and set that as the new value.
myData(rbind(myData(),new_data))
realtime_graph_x_labels$last <- as.character(tail(myData()$ts,1))
})
})
# When displaying two charts, there is no flickering / refreshing, which is desired
output$streaming_data_1 <- renderPlot({
myData() %>%
ggplot(aes(ts,val_1, group = 1))+geom_line() +
scale_x_discrete(breaks = c(realtime_graph_x_labels$first, realtime_graph_x_labels$last), labels = c(realtime_graph_x_labels$first, realtime_graph_x_labels$last)) +
labs(title ="Sensor 1") +
theme(plot.margin = unit(c(1,4,1,1),"lines"))
})
output$streaming_data_2<- renderPlot({
myData() %>%
ggplot(aes(ts,val_2, group = 1))+geom_line() +
scale_x_discrete(breaks = c(realtime_graph_x_labels$first, realtime_graph_x_labels$last), labels = c(realtime_graph_x_labels$first, realtime_graph_x_labels$last)) +
labs(title ="Sensor 2") +
theme(plot.margin = unit(c(1,4,1,1),"lines"))
})
# When adding the 3rd chart, every charts start to flicker / refresh when ploting new value
output$streaming_data_3<- renderPlot({
myData() %>%
ggplot(aes(ts,val_3, group = 1))+geom_line() +
scale_x_discrete(breaks = c(realtime_graph_x_labels$first, realtime_graph_x_labels$last), labels = c(realtime_graph_x_labels$first, realtime_graph_x_labels$last)) +
labs(title ="Sensor 3") +
theme(plot.margin = unit(c(1,4,1,1),"lines"))
})
output$streaming_data_4<- renderPlot({
myData() %>%
ggplot(aes(ts,val_4, group = 1))+geom_line() +
scale_x_discrete(breaks = c(realtime_graph_x_labels$first, realtime_graph_x_labels$last), labels = c(realtime_graph_x_labels$first, realtime_graph_x_labels$last)) +
labs(title ="Sensor 4") +
theme(plot.margin = unit(c(1,4,1,1),"lines"))
})
})
shinyApp(ui=ui,server=server)
The solution works when there are only two charts and starts flickering / refreshing when adding the 3rd.
One possible cause may be that 1000ms is too short for the data to finish processing. Try invalidateLater(10000, session) for example, and see what happens.
I was unable to install mqtt with my R version, so I am unable to reproduce your behavior. However, I looked at your code and I think there is something you could do different to improve your code: Writing data to the global environment with <<- is usually not a good idea. What might be better suited is a reactiveVal, in which you can store data, and on which other functions take a dependency. So in the example below, I have created a reactiveVal and a corresponding observer that updates the reactiveVal every 1000ms.
Below is a working example, where I replaced the contents of your function with a simple one-liner for illustration purposes.
Hope this helps!
set.seed(1)
library(shiny)
ui <- fluidPage(
plotOutput("plotx")
)
server <- function(input, output, session){
# A reactiveVal that holds our data
myData <- reactiveVal()
# Our function to get new data
get_new_data <- function(){
data.frame(a=sample(seq(20),1),b=sample(seq(20),1))
}
# Observer that updates the data every 1000ms.
observe({
# invalidate every 1000ms
invalidateLater(1000, session)
isolate({
# fetch the new data
new_data <- get_new_data()
# If myData is empty, we initialize it with just the new data.
if(is.null(myData()))
myData(new_data)
else # row bind the new data to the existing data, and set that as the new value.
myData(rbind(myData(),new_data))
})
})
# Plot a histrogram
output$plotx <- renderPlot({
hist(myData()$a)
})
}
shinyApp(ui=ui,server=server)
EDIT based on new reproducible example. Seems like it just takes some time to create all the plots. You can add
tags$style(type="text/css", ".recalculating {opacity: 1.0;}")
to your app to prevent them from flickering. Working example:
library(shiny)
library(ggplot2)
library(tidyr)
# Dashboard-like layout
ui <- shinyServer(fluidPage(
tags$style(type="text/css", ".recalculating {opacity: 1.0;}"),
fluidRow(
column(
6,
plotOutput("streaming_data_1")
),
column(
6,
plotOutput("streaming_data_2")
)
),
fluidRow(
column(
6,
plotOutput("streaming_data_3")
),
column(
6,
plotOutput("streaming_data_4")
)
)
))
server <- shinyServer(function(input, output, session){
myData <- reactiveVal()
# show the first and last timestamp in the streaming charts
realtime_graph_x_labels <- reactiveValues(first = "",last ="")
get_new_data <- function(){
epochTimeStamp <- as.character(as.integer(Sys.time()))
sensor_1 <- -runif(1,min = 10, max = 30)
sensor_2 <- runif(1,min = 0,max = 100)
sensor_3 <- runif(1,min = 0,max = 100000)
sensor_4 <- runif(1,min = 0,max = 10)
newData <- data.frame(ts = epochTimeStamp, val_1 = sensor_1, val_2 = sensor_2, val_3 = sensor_3, val_4 = sensor_4)
return(newData)
}
observe({
invalidateLater(1000, session)
isolate({
# fetch the new data
new_data <- get_new_data()
# If myData is empty, we initialize it with just the new data.
if(is.null(myData()))
{
myData(new_data)
realtime_graph_x_labels$first <- as.character(head(myData()$ts,1))
}
else # row bind the new data to the existing data, and set that as the new value.
myData(rbind(myData(),new_data))
realtime_graph_x_labels$last <- as.character(tail(myData()$ts,1))
})
})
# When displaying two charts, there is no flickering / refreshing, which is desired
output$streaming_data_1 <- renderPlot({
myData() %>%
ggplot(aes(ts,val_1, group = 1))+geom_line() +
scale_x_discrete(breaks = c(realtime_graph_x_labels$first, realtime_graph_x_labels$last), labels = c(realtime_graph_x_labels$first, realtime_graph_x_labels$last)) +
labs(title ="Sensor 1") +
theme(plot.margin = unit(c(1,4,1,1),"lines"))
})
output$streaming_data_2<- renderPlot({
myData() %>%
ggplot(aes(ts,val_2, group = 1))+geom_line() +
scale_x_discrete(breaks = c(realtime_graph_x_labels$first, realtime_graph_x_labels$last), labels = c(realtime_graph_x_labels$first, realtime_graph_x_labels$last)) +
labs(title ="Sensor 2") +
theme(plot.margin = unit(c(1,4,1,1),"lines"))
})
# When adding the 3rd chart, every charts start to flicker / refresh when ploting new value
output$streaming_data_3<- renderPlot({
myData() %>%
ggplot(aes(ts,val_3, group = 1))+geom_line() +
scale_x_discrete(breaks = c(realtime_graph_x_labels$first, realtime_graph_x_labels$last), labels = c(realtime_graph_x_labels$first, realtime_graph_x_labels$last)) +
labs(title ="Sensor 3") +
theme(plot.margin = unit(c(1,4,1,1),"lines"))
})
output$streaming_data_4<- renderPlot({
myData() %>%
ggplot(aes(ts,val_4, group = 1))+geom_line() +
scale_x_discrete(breaks = c(realtime_graph_x_labels$first, realtime_graph_x_labels$last), labels = c(realtime_graph_x_labels$first, realtime_graph_x_labels$last)) +
labs(title ="Sensor 4") +
theme(plot.margin = unit(c(1,4,1,1),"lines"))
})
})
shinyApp(ui=ui,server=server)
I have made three reactive layers in my graph. In the reproducible example below, the graph starts with function1 drawn. If I check function2, shiny recalculates and redraws function1 and function2. Then if I tick function3, all 3 functions are recalculated and redrawn.
Say the functions I want to run are very long inferences that take several minutes each.
How can I make it so that when I check (or uncheck) one function, shiny does not recalculate and redraw all checked functions?
In the code below, I have included print statements which show that each reactive is run each time renderPlot is called (which is when input$fun changes).
library(shiny)
library(ggplot2)
x <- seq(0, 10, by=0.1)
runApp(shinyApp(
ui = shinyUI(fluidPage(
titlePanel("Test Shiny"),
sidebarLayout(
sidebarPanel(
checkboxGroupInput("fun", label = "Function",
choices = list("function1: x^2" = 1,
"function2: x^2 + x" = 2,
"function3: x^2 - x" = 3),
selected = c(1))
),
mainPanel(
plotOutput("plot")
)
)
)),
server = shinyServer(function(input, output) {
fn1 <- reactive({
print("we are in fn1 <- reactive({})")
if (1 %in% input$fun ) {
geom_line(mapping = aes(x, y=x^2), color="blue") }
})
fn2 <- reactive({
print("we are in fn2 <- reactive({})")
if (2 %in% input$fun) {
geom_line(mapping = aes(x, y=x^2 + x), color="red") }
})
fn3 <- reactive({
print("we are in fn3 <- reactive({})")
if (3 %in% input$fun) {
geom_line(mapping = aes(x, y=x^2 - x), color="green") }
})
output$plot <- renderPlot({
cat("\n we are in output$plot <- renderPlot({}) \n")
ggplot() + fn1() + fn2() + fn3()
})
})
))
I can achieve this efficiency using single checkboxes (checkboxInput) but I would prefer not to use single checkboxes. Single checkboxes don’t look as good, unless there is a way to make them look more like checkbox Group Inputs?
I have been trying to work this out and searching SO for some time. I would be very grateful for any help with this!!!
EDIT
Here is some code in response to #Jimbou ’s shiny code using base R plot() and lines(). Please see my comment below the shiny code #Jimbou provided.
output$plot <- renderPlot({
cat("\n we are in output$plot <- renderPlot({}) \n")
plot(NULL, xlim = c(0,10), ylim = c(0,100))
if(1 %in% input$fun) {
print("we are in if(1 %in% input$fun){} ")
lines(x=x, y=x^2, col=2)
}
if(2 %in% input$fun) {
print("we are in if(2 %in% input$fun){} ")
lines(x=x, y=x^2 + x, col=3)
}
if(3 %in% input$fun) {
print("we are in if(3 %in% input$fun){} ")
lines(x=x, y=x^2 - x, col=4)
}
})
I think the closest you can get is to delay the processing of your layers until you click an action button to explicitly tell the server when to start processing the plot.
library(shiny)
library(ggplot2)
x <- seq(0, 10, by=0.1)
runApp(shinyApp(
ui = shinyUI(fluidPage(
titlePanel("Test Shiny"),
sidebarLayout(
sidebarPanel(
checkboxGroupInput("fun", label = "Function",
choices = list("function1: x^2" = 1,
"function2: x^2 + x" = 2,
"function3: x^2 - x" = 3),
selected = c(1)),
actionButton(inputId = "btn_update_plot",
label = "Update Plot")
),
mainPanel(
plotOutput("plot")
)
)
)),
server = shinyServer(function(input, output) {
p <- eventReactive(
input$btn_update_plot,
{
ggp = ggplot()
if (1 %in% input$fun )
{
ggp <- ggp + geom_line(mapping = aes(x, y=x^2), color="blue")
}
if (2 %in% input$fun)
{
ggp <- ggp + geom_line(mapping = aes(x, y=x^2 + x), color="red")
}
if (3 %in% input$fun)
{
ggp <- ggp + geom_line(mapping = aes(x, y=x^2 - x), color="green")
}
ggp
}
)
output$plot <- renderPlot({
print("we are in output$plot <- renderPlot({})")
p()
})
})
))
Here a solution using the base R plotting functionality with lines.
library(shiny)
library(ggplot2)
x <- seq(0, 10, by=0.1)
runApp(shinyApp(
ui = shinyUI(fluidPage(
titlePanel("Test Shiny"),
sidebarLayout(
sidebarPanel(
checkboxGroupInput("fun", label = "Function",
choices = list("function1: x^2" = 1,
"function2: x^2 + x" = 2,
"function3: x^2 - x" = 3),
selected = c(1))
),
mainPanel(
plotOutput("plot")
)
)
)),
server = shinyServer(function(input, output) {
output$plot <- renderPlot({
plot(NULL, xlim = c(0,10), ylim = c(0,100))
if(1 %in% input$fun) lines(x=x, y=x^2, col=2)
if(2 %in% input$fun) lines(x=x, y=x^2 + x, col=3)
if(3 %in% input$fun) lines(x=x, y=x^2 - x, col=4)
})
})
))
I have thought about a way to do this. In the code below, the checkboxGroupInput has options “function1”, “function2” or “function3” as before. If “function1” and “function2” are checked, and then the user checks “function3”, only function3 will be calculated. In the code in the original post, shiny would compute all three functions.
Any change in the checkboxGroupInput will invalidate all 3 of these reactive expressions
fn1 <- reactive({...}),
fn2 <- reactive({...}),
fn3 <- reactive({...})
causing them to be re-run.
However in the new code below, each reactive expression above (if it has already been checked) returns a cached value via another reactive expression
I have included print statements to show that checking or unchecking one box in the checkboxGroupInput (“function1”, “function2” or “function3”) will not cause Shiny to recalculate all the checked functions as shiny would have done in my original code above
I mentioned using single checkboxes before, so I have also included an example of a single checkbox, “relation4”, to show that using a single checkbox, checkboxInput(), does not cause other reactives to re-running unnecessarily
NB watch what is printed to the console
library(shiny)
library(ggplot2)
runApp(shinyApp(
ui = shinyUI(fluidPage(
titlePanel("Test Shiny"),
sidebarLayout(
sidebarPanel(
checkboxGroupInput("fun", label = "Function",
choices = list("function1: x^2" = 1,
"function2: x^2 + x" = 2,
"function3: x^2 - x" = 3),
selected = c(1)),
h5("A single checkbox"),
checkboxInput("relation4", label = "relation4", value = FALSE)
),
mainPanel(
plotOutput("plot")
)
)
)),
server = shinyServer(function(input, output) {
x <- seq(0, 10, by=0.1)
fn1.geom <- reactive({
print("we are in fn1.geom <- reactive({})")
geom_line(mapping = aes(x, y=x^2), color="blue")
})
fn1 <- reactive({
print("we are in fn1 <- reactive({})")
if (1 %in% input$fun ) {
fn1.geom()}
})
fn2.geom <- reactive({
print("we are in fn2.geom <- reactive({})")
geom_line(mapping = aes(x, y=x^2 + x), color="red")
})
fn2 <- reactive({
print("we are in fn2 <- reactive({})")
if (2 %in% input$fun) {
fn2.geom()}
})
fn3.geom <- reactive({
print("we are in fn3.geom <- reactive({})")
geom_line(mapping = aes(x, y=x^2 - x), color="green")
})
fn3 <- reactive({
print("we are in fn3 <- reactive({})")
if (3 %in% input$fun) {
fn3.geom() }
})
# using single checkbox input (checkboxInput() above)
relation4.geom <- reactive({
print("we are in relation4.geom <- reactive({})")
list( geom_line(mapping = aes(x, y=x), color="orange"),
geom_line(mapping = aes(x, y=6*x), color="purple"),
geom_line(mapping = aes(x, y=11*x), color="violet") )
})
relation4 <- reactive({
print("we are in relation4 <- reactive({})")
if (input$relation4) {
relation4.geom()
}
})
output$plot <- renderPlot({
cat("\n we are in output$plot <- renderPlot({}) \n")
ggplot() + fn1() + fn2() + fn3() + relation4()
})
})
))
I would really appreciate some help with the following code:
library(shiny)
library(rhandsontable)
library(tidyr)
dataa <- as.data.frame(cbind(rnorm(100, sd=2), rchisq(100, df = 0, ncp = 2.), rnorm(100)))
ldataa <- gather(dataa, key="variable", value = "value")
thresholds <- as.data.frame(cbind(1,1,1))
ui <- fluidPage(fluidRow(
plotOutput(outputId = "plot", click="plot_click")),
fluidRow(rHandsontableOutput("hot"))
)
server <- function(input, output) {
values <- reactiveValues(
df=thresholds
)
observeEvent(input$plot_click, {
values$trsh <- input$plot_click$x
})
observeEvent(input$hot_select, {
values$trsh <- 1
})
output$hot = renderRHandsontable({
rhandsontable(values$df, readOnly = F, selectCallback = TRUE)
})
output$plot <- renderPlot({
if (!is.null(input$hot_select)) {
x_val = colnames(dataa)[input$hot_select$select$c]
dens.plot <- ggplot(ldataa) +
geom_density(data=subset(ldataa,variable==x_val), aes(x=value), adjust=0.8) +
geom_rug(data=subset(ldataa,variable==x_val), aes(x=value)) +
geom_vline(xintercept = 1, linetype="longdash", alpha=0.3) +
geom_vline(xintercept = values$trsh)
dens.plot
}
})
}
shinyApp(ui = ui, server = server)
I have a plot and a handsontable object in the app.
Clicking on whichever cell loads a corresponding plot, with a threshold value. Clicking the plot changes the position of one of the vertical lines.
I would like to get the x value from clicking the plot into the corresponding cell, and I would like to be able to set the position of the vertical line by typing in a value in the cell too.
I'm currently a bit stuck with how I should feed back values into a reactiveValue dataframe.
Many thanks in advance.
This works as I imagined:
(The trick was to fill right columns of "df" with input$plot_click$x by indexing them with values$df[,input$hot_select$select$c].)
library(shiny)
library(rhandsontable)
library(tidyr)
dataa <- as.data.frame(cbind(rnorm(100, sd=2), rchisq(100, df = 0, ncp = 2.), rnorm(100)))
ldataa <- gather(dataa, key="variable", value = "value")
thresholds <- as.data.frame(cbind(1,1,1))
ui <- fluidPage(fluidRow(
plotOutput(outputId = "plot", click="plot_click")),
fluidRow(rHandsontableOutput("hot"))
)
server <- function(input, output) {
values <- reactiveValues(
df=thresholds
)
observeEvent(input$plot_click, {
values$df[,input$hot_select$select$c] <- input$plot_click$x
})
output$hot = renderRHandsontable({
rhandsontable(values$df, readOnly = F, selectCallback = TRUE)
})
output$plot <- renderPlot({
if (!is.null(input$hot_select)) {
x_val = colnames(dataa)[input$hot_select$select$c]
dens.plot <- ggplot(ldataa) +
geom_density(data=subset(ldataa,variable==x_val), aes(x=value), adjust=0.8) +
geom_rug(data=subset(ldataa,variable==x_val), aes(x=value)) +
geom_vline(xintercept = 1, linetype="longdash", alpha=0.3) +
geom_vline(xintercept = values$df[,input$hot_select$select$c])
dens.plot
}
})
}
shinyApp(ui = ui, server = server)
Update your reactiveValue dataframe from inside of an observeEvent, where you are watching for whichever event is useful, i.e. a click or something.
observeEvent(input$someInput{
values$df <- SOMECODE})
I have a shiny app, example shown below that should be reproducible where I am trying to show a ggplot2 scatterplot with points which can be excluded as shown in this example here. I am also using modules, which might be part of this issue here.
https://gallery.shinyapps.io/106-plot-interaction-exclude/
I keep getting this "Error in eval: object 'xaxis' not found" message. Any ideas? I put the module code up front then the rest of the code for the app.R file.
library(ggplot2)
library(scales)
library(shiny)
library(shinydashboard)
###### MODULE CODE ###############
scatter_graphUI <- function(id, tab_panel_name, height = "500px") {
ns <- NS(id)
tabPanel(tab_panel_name,
plotOutput(ns("scatter_1"), height = height, click = "plot1_click", brush =
brushOpts(id = "plot1_brush")),
actionButton(ns("exclude_toggle"), "Toggle points"),
actionButton(ns("exclude_reset"), "Reset")
)
}
scatter_graph <- function(input, output, session, scatter_data, col_select) {
scatter_data_df <- reactive({
mtcars
})
vals <- reactiveValues()
data_df <- reactive({
scatter_df <- scatter_data_df()
main_df <- scatter_df[,col_select]
vals$keeprows = rep(TRUE,nrow(main_df))
main_df
})
output$scatter_1 <- renderPlot({
graph_df <- data_df()
# Plot the kept and excluded points as two separate data sets
keep <- graph_df[ vals$keeprows,]
exclude <- graph_df[!vals$keeprows,]
final_df <- keep
title = paste(colnames(final_df)[1], "vs", colnames(final_df)[2])
line_method = "quad"
axis_text = 12
title_text = 16
split_colors = TRUE
colors = c("red","black")
# create red points for negative x axis returns if split_colors is TRUE
if (split_colors == TRUE) {
final_df[,"color"] <- ifelse(final_df[,2,drop=F]<0,colors[1],colors[2])
} else {
final_df[,"color"] <- ifelse(final_df[,2,drop=F]<0,colors[2],colors[2])
}
# create a generic graphing final_df
colnames(final_df) <- c("xaxis","yaxis","color")
# setup the graph
gg <- ggplot(final_df, aes(x = xaxis, y = yaxis)) + geom_point(color = final_df[,"color"])
gg <- gg + geom_point(data = exclude, shape = 21, fill = NA, color = "black", alpha = 0.25) +
coord_cartesian(xlim = c(1.5, 5.5), ylim = c(5,35))
if (line_method == "loess") {
gg <- gg + stat_smooth(span = 0.9)
} else if (line_method == "quad") {
gg <- gg + stat_smooth(method = "lm", formula = y ~ poly(x, 2), size = 1)
} else if (line_method == "linear") {
gg <- gg + stat_smooth(method = "lm")
} else {
}
gg <- gg + theme_bw()
gg <- gg + labs(x = colnames(final_df)[2], y = colnames(final_df)[3], title = title)
gg
})
# Toggle points that are clicked
observeEvent(input$plot1_click, {
main_df <- data_df()
res <- nearPoints(main_df, input$plot1_click, allRows = TRUE)
vals$keeprows <- xor(vals$keeprows, res$selected_)
})
# Toggle points that are brushed, when button is clicked
observeEvent(input$exclude_toggle, {
main_df <- data_df()
res <- brushedPoints(main_df, input$plot1_brush, allRows = TRUE)
vals$keeprows <- xor(vals$keeprows, res$selected_)
})
# Reset all points
observeEvent(input$exclude_reset, {
main_df <- data_df()
vals$keeprows <- rep(TRUE, nrow(main_df))
})
}
########################################
##### REST OF APP CODE ######
header <- dashboardHeader(
title = 'Test Dashboard'
)
body <- dashboardBody(
tabItems(
tabItem(tabName = "scatter_eval",
tabBox(
title = "Scatter",
selected = "Selected",
height = "600px", side = "right",
scatter_graphUI("selected_scatter", "Selected")
)
)
)
)
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Scatter Evaluation", icon = icon("th"), tabName = "scatter_eval")
)
)
ui <- dashboardPage(skin = "blue",
header,
sidebar,
body
)
server <- function(input, output, session) {
callModule(scatter_graph, id ="selected_scatter", scatter_data = reactive(selected_scatter_data()),
col_select = c(1,2))
}
shinyApp(ui = ui, server = server)
########
The issue is the two lines:
gg <- ggplot(final_df, aes(x = xaxis, y = yaxis)) + geom_point(color = final_df[,"color"])
gg <- gg + geom_point(data = exclude, shape = 21, fill = NA, color = "black", alpha = 0.25) +
coord_cartesian(xlim = c(1.5, 5.5), ylim = c(5,35))
Because you have not set a new aes for the exclude object, it inherits the aes from your ggplot call. It therefore needs to find a column named xaxis and yaxis in the exclude dataset. Since you only renamed final_df, it throws this error.
A graph is displayed when you change:
colnames(final_df) <- c("xaxis","yaxis","color")
to:
colnames(final_df) <- c("xaxis","yaxis","color")
colnames(exclude) <- c("xaxis","yaxis")