I am fairly new with rshiny apps and I am trying to build an app which works fine but when I try to add a plot with brush and delete points functionality I run into errors.
Essentially, I am reading a csv file into a reactive function df_products_upload() that I use in some other functions (for plotting and to populate columns for user inputs) but when I call this function inside reacticeValues() to pass the data frame it fails me. I am trying to add brush and delete functionality to a plot (Plot1). I cant re-read the csv file just to input into this reactiveValues so it would work. The whole idea of reactive function dies if I have to keep reading csv file for every other function used in the app redundantly.
vals <- reactiveValues(
df1 <- df_products_upload(),
data=df1
)
############## plotting -1
output$plot1 <- renderPlot({
ggplot(vals$data, aes_string(x = input$column1, y = input$column2)) + geom_point()
})
observe({
df = brushedPoints(vals$data, brush = input$plot1_brush, allRows = TRUE)
vals$data = df[df$selected_== FALSE, ] ## Taking only those data points where the selected_ value is FALSE (alternatively ignoring rows with selected_ = TRUE status)
})
Can someone please suggest how do I go about it? what is the right logic to use reactive and reactiveValues inside each other if its possible at all. if not possible how do I get this plot to work with rest of the code. Clearly shiny doesn't like calling a reactive function inside reactiveValues(). I am having this trouble with the Plot1, code is at the bottom. you can use any csv to test the code, it will only complain about plot -3 where I have hard coded the column names, just change those while testing.
here is complete code:
library(DT)
library(shinydashboard)
library(ggplot2)
library(shinyFiles)
ui <- fluidPage(
# File upload button
shinyFilesButton(id = 'file', label= 'Choose file to upload',
title = 'Select file', multiple = FALSE),
#Shows data table on the main page
fluidRow(
column(12, DT::dataTableOutput('tabl'))
# dataTableOutput("tabl")
),
# h5('Select two Columns to Plot'),
uiOutput("Col1"),
uiOutput("Col2"),
#-----------------------------------------------------------
#Shows Plot button
fluidRow(
column(6, plotOutput('plot2', height = 500)),
column(6, plotOutput('plot3', height = 500))
),
fluidRow(
column(7, class = "row",
h4("Brush and click to exclude Point"),
plotOutput("plot1", height = 500,
# click = "plot1_click",
brush = brushOpts(
id = "plot1_brush"
# resetOnNew = TRUE
)
)
)
)
)
#------------------------------------------------------------------------
server <- function(input, output, session) {
###Read cvs file and convert julian Date to regular Date format
shinyFileChoose(input, 'file', roots= c(wd="/Users/mnoon/Desktop/projects/2018/rShinyApp_imageData"), filetypes= c('', 'csv'))
df_products_upload <- reactive({
inFile <- parseFilePaths(roots=c(wd='/Users/mnoon/Desktop/projects/2018/rShinyApp_imageData/'), input$file)
if (NROW(inFile)){
# return(NULL)
df <- read.csv(as.character(inFile$datapath), header = TRUE, sep = ",", stringsAsFactors = F)
# Convert Julian to Calendar date
df$Julian.Date <- as.Date((as.numeric(df$Julian.Date) - 2400000.5), origin=as.Date("1858-11-17"))
#Change Column name to 'Date'
names(df)[names(df) == 'Julian.Date'] <- 'Date'
df <- as.data.frame(df)
return(df)
}
})
###Previews data table on the main display window
output$tabl<- DT::renderDataTable({
df <- df_products_upload()
DT::datatable(df)
}, server = FALSE)
###The following set of functions populate the column selectors
output$Col1 <- renderUI({
df <-df_products_upload()
if (is.null(df)) return(NULL)
cols=names(df)
names(cols)=cols
selectInput("column1", "Select Column for X-axis", cols)
})
output$Col2 <- renderUI({
df <-df_products_upload()
if (is.null(df)) return(NULL)
cols=names(df)
names(cols)=cols
selectInput("column2", "Select Column for Y-axis", cols)
})
# -------------------------------------------------------------------
###plot2
# # # A scatterplot with certain points highlighted
# #
output$plot2 = renderPlot({
df2 <- df_products_upload()
df <- df2[,c(input$column1, input$column2)]
s1 = input$tabl_rows_current # rows on the current page
s2 = input$tabl_rows_all # rows on all pages (after being filtered)
req(input$column1)
##get xlim values for plot
xdiff <- (as.numeric(max(df[,1])) - as.numeric(min(df[,1])))
xd1 <- (as.numeric(max(df[,1]))) + 0.7*(xdiff)
xd2 <- (as.numeric(min(df[,1]))) - 0.7*(xdiff)
##get ylim values for plot
ydiff <- (ceiling(as.numeric(max(df[,2]))) - floor(as.numeric(min(df[,2]))))
yd1 <- (ceiling(as.numeric(max(df[,2])))) + 0.7*(ydiff)
yd2 <- (floor(as.numeric(min(df[,2])))) - 0.7*(ydiff)
######################## --- Plotting -2
par(mar = c(4, 4, 1, .1))
plot(df, pch = 21, xlim = c(xd2,xd1), ylim = c(yd2,yd1), xlab = input$column1, ylab = input$column2)
grid()
# solid dots (pch = 19) for current page
if (length(s1)) {
points(df[s1, , drop = FALSE], pch = 19, cex = 1.5)
}
# show red circles when performing searching
if (length(s2) > 0 && length(s2) < nrow(df)) {
points(df[s2, , drop = FALSE], pch = 21, cex = 2, col = 'red')
}
# dynamically change the legend text
s = input$tabl_search
txt = if (is.null(s) || s == '') 'Filtered data' else {
sprintf('Data matching "%s"', s)
}
legend(
'topright', c('Original data', 'Data on current page', txt),
pch = c(21, 19, 21), pt.cex = c(1, 1.5, 2), col = c(1, 1, 2),
y.intersp = 2, bty = 'n'
)
})
# -------------------------------------------------------------------
###plot3
########[Always plot these two columns - 'Right.Ascension..deg.', 'Declination..deg.']
output$plot3 = renderPlot({
df2 <- df_products_upload()
## Columns hard-coded (always plot these)
df3 = df2[, c('Right.Ascension..deg.', 'Declination..deg.' )]
s1 = input$tabl_rows_current # rows on the current page
s2 = input$tabl_rows_all # rows on all pages (after being filtered)
##get xlim values for plot
xdiff <- (as.numeric(max(df3[,"Right.Ascension..deg."])) - as.numeric(min(df3[,"Right.Ascension..deg."])))
xd1 <- (as.numeric(max(df3[,"Right.Ascension..deg."]))) + 0.2*(xdiff)
xd2 <- (as.numeric(min(df3[,"Right.Ascension..deg."]))) - 0.2*(xdiff)
##get ylim values for plot
yd1 <- (as.numeric(max(df3[,"Declination..deg."]))) - 0.1
yd2 <- (ceiling((as.numeric(min(df3[,"Declination..deg."])))))
########################## --- Plotting -3
par(mar = c(4, 4, 1, .1))
plot(df3, pch = 21, xlim = c(xd2,xd1), ylim = c(yd2,yd1), xlab = names(df3[1]), ylab = names(df3[2]))
# axis(1, )
grid()
# solid dots (pch = 19) for current page
if (length(s1)) {
points(df3[s1, , drop = FALSE], pch = 19, cex = 1.5)
}
# show red circles when performing searching
if (length(s2) > 0 && length(s2) < nrow(df3)) {
points(df3[s2, , drop = FALSE], pch = 21, cex = 2, col = 'red')
}
# dynamically change the legend text
s = input$tabl_search
txt = if (is.null(s) || s == '') 'Filtered data' else {
sprintf('Data matching "%s"', s)
}
legend(
'topright', c('Original data', 'Data on current page', txt),
pch = c(21, 19, 21), pt.cex = c(1, 1.5, 2), col = c(1, 1, 2),
y.intersp = 2, bty = 'n'
)
})
# -------------------------------------------------------------------
###plot1
# brush and delete with ggplot
vals <- reactiveValues(
df1 <- df_products_upload(),
data=df1
)
############## plotting -1
output$plot1 <- renderPlot({
ggplot(vals$data, aes_string(x = input$column1, y = input$column2)) + geom_point()
})
observe({
df = brushedPoints(vals$data, brush = input$plot1_brush, allRows = TRUE)
vals$data = df[df$selected_== FALSE, ] ## Taking only those data points where the selected_ value is FALSE (alternatively ignoring rows with selected_ = TRUE status)
})
}
#------------------------------------------------------------
shinyApp(ui, server)
Related
I want to calculate the distance of the segment between 2 clicked points, i already have a function with that launches a shiny dashboard that allows you to save the clicks and draw a line between the pairs. It is printing the dimension of the image in pixels. Any image can be used changing the image_path.
I want to know if there is a way to select the segments of each pair and calculate the distance between them in pixels and later convert it to cm.
library(shiny)
library(shinydashboard)
library(dplyr)
library(imager)
library(reactable)
click_length <- function(image_path = system.file("example_images", package = "ClickMetrics")){
app <- shinyApp(
ui <- dashboardPage(
skin = 'purple',
dashboardHeader(title = "ClickMetrics"),
dashboardSidebar(disable = TRUE),
dashboardBody(
fluidRow(
box(plotOutput("IMG",
height = 400,
click = "click_plot")),
box(
(selectInput("IMAGE",
"Images:",
list.files(path = image_path,
pattern = ".jpg",
full.names = TRUE,
include.dirs = FALSE)))
),
actionButton("clear","Clear Points"),
reactableOutput("INFO")
)
)
),
server <- function(input, output, session){
# Creating a reactive value that receives image input
img <- reactive({
f <- input$IMAGE
imager::load.image(f)
})
# Store reactive values for coordinates
CLICKS <- reactiveValues(
x = NULL,
y = NULL,
n = NULL,
pair = NULL
)
ns <- session$ns
observeEvent(eventExpr = input$click_plot$x, handlerExpr = { ## Adds the info about clicks
CLICKS$x <- append(CLICKS$x, input$click_plot$x)
CLICKS$y <- append(CLICKS$y, input$click_plot$y)
CLICKS$n <- append(CLICKS$n, length(CLICKS$x))
CLICKS$pair <-
append(CLICKS$pair,
as.integer(ceiling(length(CLICKS$x)/2)))
df <- data.frame(CLICKS$x, CLICKS$y, CLICKS$pair)
df <- split(df, CLICKS$pair)
print(dim(img())) # prints dimensions of the image
})
output$IMG <- renderPlot({
expr = {
img <- img()
par(mar = c(0.5, 0.5, 1.75, 0.5))
plot(img, axes = FALSE)
box(col = 'gray')
mtext(text = input$IMAGE,
side = 3,
line = 0.5,
adj = 0.5,
cex = 1.23)
if (!is.null(CLICKS$x) && length(CLICKS$x) > 0) {
points(x = CLICKS$x,
y = CLICKS$y,
pch = 19,
cex = 0.75,
col = "red")
text(x = CLICKS$x,
y = CLICKS$y,
label = CLICKS$n,
pos = 3)
n_par <- 2 * floor(length(CLICKS$x)/2)
tb_pairs <- cbind(
matrix(CLICKS$x[1:n_par], ncol = 2, byrow = TRUE),
matrix(CLICKS$y[1:n_par], ncol = 2, byrow = TRUE))
segments(x0 = tb_pairs[, 1],
x1 = tb_pairs[, 2],
y0 = tb_pairs[, 3],
y1 = tb_pairs[, 4],
col = "black")
}
}
})
output$INFO <- renderReactable({
df1 <- data.frame(round(CLICKS$x,2), round(CLICKS$y,2), CLICKS$pair)
reactable(df1)
})
observe({ # clear clicked points
if(input$clear>0){
session$reload()
}
})
})
runApp(app)
}
click_length()
I tried some examples using locator, but it does not work inside a shiny dashboard, which i need.
I am using the plotly parcoords to generate a parallel coordinate plot. Now, the idea is when the user drags the column axes and manually changes the order of the dimensions in the plot, I want to generate a text displaying some value based on that column order. But I am not sure how to do that. I am not even sure if that's possible at all. I know I have to use an observeEvent, but not exactly sure what to observe. I am quite new to R Shiny. Please help!
UI:
fluidRow(
textOutput(outputId = "PlotScoreText")),
fluidRow(
plotlyOutput("ParallelChart"))
Server:
observeEvent(input$ParallelChart, {
output$PlotScoreText <- renderText(getScoreText())})
output$ParallelChart <- renderPlotly({
getParallelChart()
})
getParallelChart <- function() {
p <- plot_ly(type = 'parcoords', line = list(color = 'blue'),
dimensions = list(
list(range = c(1,5),
constraintrange = c(1,2),
label = 'A', values = c(1,4)),
list(range = c(1,5),
tickvals = c(1.5,3,4.5),
label = 'B', values = c(3,1.5)),
list(range = c(1,5),
tickvals = c(1,2,4,5),
label = 'C', values = c(2,4),
ticktext = c('text 1', 'text 2', 'text 3', 'text 4')),
list(range = c(1,5),
label = 'D', values = c(4,2))
)
)
p
}
For example, after the above plot gets rendered, if the user drags dimension C to be in front of B, I want the observeEvent for the output$PlotScoreText to get triggered. Is there any way to do this?
We can use plotly's event_data() to access the current axes order (modifying the order results in a restyle event):
library(shiny)
library(plotly)
ui <- fluidPage(
fluidRow(textOutput(outputId = "PlotScoreText")),
fluidRow(textOutput(outputId = "renderTextOutput")),
fluidRow(plotlyOutput("ParallelChart"))
)
server <- function(input, output, session) {
output$ParallelChart <- renderPlotly({
p <- plot_ly(type = 'parcoords', line = list(color = 'blue'),
dimensions = list(
list(range = c(1,5),
constraintrange = c(1,2),
label = 'A', values = c(1,4)),
list(range = c(1,5),
tickvals = c(1.5,3,4.5),
label = 'B', values = c(3,1.5)),
list(range = c(1,5),
tickvals = c(1,2,4,5),
label = 'C', values = c(2,4),
ticktext = c('text 1', 'text 2', 'text 3', 'text 4')),
list(range = c(1,5),
label = 'D', values = c(4,2))
), source = "pcoords_events") %>%
event_register("plotly_restyle")
})
axesOrder <- reactiveVal(paste("Axes order:", paste(c(LETTERS[1:4]), collapse = ", ")))
observeEvent(event_data("plotly_restyle", source = "pcoords_events"), {
d <- event_data("plotly_restyle", source = "pcoords_events")
axesOrder(paste("Axes order:", paste(d[[1]]$dimensions[[1]]$label, collapse = ", ")))
})
output$PlotScoreText <- renderText({
axesOrder()
})
output$renderTextOutput <- renderText({
d <- event_data("plotly_restyle", source = "pcoords_events")
paste("renderTextOutput: Axes order:", paste(d[[1]]$dimensions[[1]]$label, collapse = ", "))
})
}
shinyApp(ui, server)
I have a project that I am building a shiny for. I need to create n maps (up to 99) based on an input. The same polygons will be displayed on each map and when a user clicks on a polygon it changes the polygons colour.
So far I can create the number of maps based on an input value but I am struggling to work out how to put the observeEvent in a loop for each map.
The below example works, but I would have to write out the two observeEvents 99 times.
Please help!
library(leaflet)
## create two square polygons
Sr1 <- Polygon(cbind(c(1, 2, 2, 1, 1), c(1, 1, 2, 2, 1)))
Sr2 <- Polygon(cbind(c(2, 3, 3, 2, 2), c(1, 1, 2, 2, 1)))
Srs1 <- Polygons(list(Sr1), "s1")
Srs2 <- Polygons(list(Sr2), "s2")
SpP <- SpatialPolygons(list(Srs1, Srs2), 1:2)
ui <- fluidPage(
sliderInput("nomaps", "Number of maps:",
min = 1, max = 5, value = 1
),
uiOutput("plots")
)
change_color <- function(map, id_to_remove, data, colour, new_group){
leafletProxy(map) %>%
removeShape(id_to_remove) %>% # remove previous occurrence
addPolygons(
data = data,
label = data$display,
layerId = data$ID,
group = new_group, # change group
fillColor = colour)
}
server <- function(input,output,session){
## Polygon data
rv <- reactiveValues(
df = SpatialPolygonsDataFrame(SpP, data = data.frame(
ID = c("1", "2"),
display = c("1", "1")
), match.ID = FALSE)
)
# initialization
output$map <- renderLeaflet({
leaflet(options = leafletOptions( zoomControl = FALSE, minZoom = 6.2, maxZoom = 6.2, dragging = FALSE))
})
observe({
data <- rv$df
lapply(1:input$nomaps, function(i) {
output[[paste("plot", i, sep = "_")]] <- renderLeaflet({
leaflet(options = leafletOptions( zoomControl = FALSE, minZoom = 6.2, maxZoom = 6.2, dragging = FALSE))%>%
addPolygons(
data = data,
label = data$display,
layerId = data$ID,
group = "unclicked_poly")
})
})
})
# Create plot tag list
output$plots <- renderUI({
plot_output_list <- lapply(1:input$nomaps, function(i) {
plotname <- paste("plot", i, sep = "_")
leafletOutput(plotname)
})
do.call(tagList, plot_output_list)
})
#first click
observeEvent(input$plot_1_shape_click, {
# execute only if the polygon has never been clicked
req(input$plot_1_shape_click$group == "unclicked_poly")
# filter data
data <- rv$df[rv$df$ID==input$plot_1_shape_click$id,]
change_color(map = "plot_1",
id_to_remove = input$plot_1_shape_click$id,
data = data,
colour = "yellow",
new_group = "clicked1_poly")
})
#back to normal
observeEvent(input$plot_1_shape_click, {
req(input$plot_1_shape_click$group == "clicked1_poly")
data <- rv$df[rv$df$ID==input$plot_1_shape_click$id,]
# back to normal
leafletProxy("plot_1") %>%
removeShape(input$plot_1_shape_click$id) %>% # remove previous occurrence
addPolygons(
data = data,
label = as.character(data$display),
layerId = data$ID,
group = "unclicked_poly") # back to initialize group
})
}
shinyApp(ui, server)
Try this
observe({
lapply(1:input$nomaps, function(i) {
observeEvent(input[[paste0("plot_", i,"_shape_click")]], {
# execute only if the polygon has never been clicked
selected.id <- input[[paste0("plot_", i,"_shape_click")]]
data <- rv$df[rv$df$ID==selected.id$id,]
if (selected.id$group == "unclicked_poly") {
change_color(map = paste0("plot_", i),
id_to_remove = selected.id$id,
data = data,
colour = "yellow",
new_group = "clicked1_poly")
} else {
leafletProxy(paste0("plot_", i)) %>%
removeShape(selected.id$id) %>% # remove previous occurrence
addPolygons(
data = data,
label = as.character(data$display),
layerId = data$ID,
group = "unclicked_poly") # back to initialize group
}
})
})
})
observe ({
lapply(1:input$nomaps, function(i) {
observeEvent(input[[paste0("plot_", i,"_shape_click",sep="")]], {
# execute only if the polygon has never been clicked
if (input[[paste0("plot_", i,"_shape_click",sep="")]]$group == "unclicked_poly") {
selected.id <- input[[paste0("plot_", i,"_shape_click",sep="")]]
data <- rv$df[rv$df$ID==selected.id$id,]
change_color(map = paste0("plot_", i, sep=""),
id_to_remove = selected.id$id,
data = data,
colour = "yellow",
new_group = "clicked1_poly")
} else {
selected.id <- input[[paste0("plot_", i,"_shape_click",sep="")]]
data <- rv$df[rv$df$ID==selected.id$id,]
leafletProxy(paste0("plot_", i, sep="")) %>%
removeShape(selected.id$id) %>% # remove previous occurrence
addPolygons(
data = data,
label = as.character(data$display),
layerId = data$ID,
group = "unclicked_poly") # back to initialize group
}
})
})
})
I'm trying to understand how ggvis works in the context of shiny and it's been a real headache. At this point I'm just trying to make something, anything interactive. Ideally I would like to be able to filter data points with sliders and be able to click on sectors and links to zoom and highlight respectively.
Ignoring the entire right bar, how would I be able to implement ggvis?
server.r
options(shiny.maxRequestSize=60*1024^2)
# Option to use scientific notation
options(scipen=999)
library(ggplot2)
library(ggvis)
shinyServer(function(input, output) {
inputData <- try(reactive({
inFile <- input$file1
if(is.null(inFile$datapath)){
return(iris)
}
newData <- read.csv(inFile$datapath, fill=TRUE)
newData
}))
output$choose_histVar <- renderUI({
newData <- inputData()
nameDataNew1<-c("ALL" ,"Earmarks", "Free-Cash")
if(class(nameDataNew1)!="try-error"){
selectInput("histVar", "1. Select Funding", as.list(nameDataNew1),
multiple = FALSE)
}
else{
selectInput("histVar", "1.Select Funding", NULL, multiple = FALSE)
}
})
# Use renderTable() function to render a table
output$summaryTable <- renderTable({ summary( try(inputData()) ) })
output$plot.hist <- renderPlot({
plotHistograms(data=try(inputData()), getCol=input$histVar,
getBin=input$bins)
})
output$plot.bar <- renderPlot({ plotcir(data)})
})
plotcir <- function(data) {
set.seed(999)
n = 1000
df = data.frame(factors = sample(letters[1:8], n, replace = TRUE),
x = rnorm(n), y = runif(n))
data.temp <- as.data.frame(df)
circos.par("track.height" = 0.1)
circos.initialize(factors = df$factors, x = df$x)
circos.track(factors = df$factors, y = df$y,
panel.fun = function(x, y) {
circos.text(CELL_META$xcenter, CELL_META$cell.ylim[2] + uy(5,
"mm"),
CELL_META$sector.index)
circos.axis(labels.cex = 0.6)
})
col = rep(c("#FF0000", "#00FF00"), 4)
circos.trackPoints(df$factors, df$x, df$y, col = col, pch = 16, cex = 0.5)
circos.text(-1, 0.5, "text", sector.index = "a", track.index = 1)
bgcol = rep(c("#EFEFEF", "#CCCCCC"), 4)
circos.trackHist(df$factors, df$x, bin.size = 0.2, bg.col = bgcol, col = NA)
circos.track(factors = df$factors, x = df$x, y = df$y,
panel.fun = function(x, y) {
ind = sample(length(x), 10)
x2 = x[ind]
y2 = y[ind]
od = order(x2)
circos.lines(x2[od], y2[od])
})
##vis <- reactive({})
circos.link("a", 0, "b", 0, h = 0.4)
circos.link("c", c(-0.5, 0.5), "d", c(-0.5,0.5), col = "red",
border = "blue", h = 0.2)
circos.link("e", 0, "g", c(-1,1), col = "green", border = "black", lwd = 2,
lty = 2)
}
ui.r
# Load libraries used in this Shiny App
library(shiny)
library(ggplot2)
library(circlize)
library(ggvis)
library(shinythemes)
shinyUI(fluidPage(
titlePanel(title = h2("The Wall", align="center")),
theme = shinytheme("cyborg"),
sidebarPanel(
fileInput('file1', 'The default dataset is df data. You may choose your own
CSV file'),
sliderInput('file1', 'Mission 1', value = 10, min = 0, max = 100, step = 1,
post = "%"),
sliderInput('file1', 'Mission 2', value = 0, min = 0, max = 100, step = 1,
post = "%"),
sliderInput('file1', 'Mission 3', value = 0, min = 0, max = 100, step = 1,
post = "%"),
sliderInput('file1', 'Mission 4', value = 0, min = 0, max = 100, step = 1,
post = "%"),
sliderInput('file1', 'Mission 5', value = 0, min = 0, max = 100, step = 1,
post = "%"),
uiOutput("choose_histVar"),
uiOutput("choose_xVar"),
uiOutput("choose_yVar"),
uiOutput("choose_cateVar"),
uiOutput("choose_barVar"),
p()
),
mainPanel(
h3('DOS - Augmented decisions'),
tabsetPanel(type="tab",
tabPanel( "Optimal",
plotOutput('plot.bar')
),
tabPanel("Histogram",
h4(checkboxInput("showHideHistograms", "Show/hide histograms",
value=FALSE)),
# Add a conditional panel to plot the histogram only when "Show
histogram" is checked
conditionalPanel(
condition = "input.showHideHistograms",
# Use plotOutput function to plot the output visualization
plotOutput('plot.hist')
)
)
),
p('')
)
))
I'm essentially trying to replicate the behavior of the graph on this site in a Shiny app.
That is, I want to create an interactive graph, where by hovering the mouse cursor over the graph, you move a "targeting line" along the x-axis. Then, according to the position of the targeting line, the y-values of the plot lines on the graph are displayed on the intersection point of the targeting line and the plot lines. (I was going to post an illustrative figure, but it appears I don't have enough reputation for that yet.)
I've managed to get the application to work. In my current implementation I'm using the hover option in plotOutput to get the location of the cursor on the plot, and then adding a targeting line using abline to a new plot. Along with points and text to add the y-values on the plot.
The issue I'm having is that the targeting line starts to severely lag behind the actual mouse cursor after moving around for a while. I think this is due to having to redraw the entire plot every time the mouse hovering position updates (currently every 500 ms when the cursor is moving, since I'm using hoverOpts(delayType = "throttle")). The rendering just isn't fast enough to keep up with the mouse movement. I was wondering if anybody has an idea on how to get around this problem.
Runnable code for an example of the Shiny app:
library(shiny)
trigWaves <- function(A = 1, ...) {
xval <- seq(0, 2*pi, len = 201)
sinx <- A * sin(xval); cosx <- A * cos(xval)
plot(x = xval, y = sinx, type = 'n', ylab = "f(x)", xlab = "x", ...)
abline(h = A * c(-1, 0, 1), lty = c(2, 1, 2), col = 'gray')
abline(v = pi * seq(0, 2, by = 0.5), lty = 2, col = 'gray')
lines(x = xval, y = sinx, col = 'red')
lines(x = xval, y = cosx, col = 'blue')
box()
invisible(list(x = xval, y = list(sin = sinx, cos = cosx)))
}
# Maximum selectable amplitude
Amax <- 5
runApp(
# Define UI for application
list(ui = pageWithSidebar(
# Application title
headerPanel("Read Function Values Interactively from a Plot"),
sidebarPanel(
sliderInput("amplitude",
"Amplitude:",
min = 1,
max = Amax,
value = 2,
step = 0.1)
),
mainPanel(
plotOutput("trigGraph",
hover =
hoverOpts(
id = "plothover",
delay = 500,
delayType = "throttle"
)
)
)
),
# Define server for application
server = function(input, output, session) {
A <- reactive(input$amplitude)
hoverx <- reactiveValues(initial = 2)
# Hover position
tx <- reactive({
# If no previous hover position found, return initial = 0
if (is.null(hoverx$prev)) return(hoverx$initial)
# Hover resets to NULL every time the plot is redrawn -
# If hover is null, then use the previously saved hover value.
if (is.null(input$plothover)) hoverx$prev else input$plothover$x
})
# Function to plot the 'reader line' and the function values
readLine <- reactive({
abline(v = tx(), col = 'gray'); box()
# Plot coordinates for values and points
pcoords <- list(x = rep(tx(), 2), y = A() * c(sin(tx()), cos(tx())))
points(pcoords, pch = 16, col = c("red", "blue")) # points on lines
text(pcoords, labels = round(pcoords$y, 2), pos = 4) # function values
})
# Render the final output graph
output$trigGraph <- renderPlot({
# Create base plot
trigWaves(A = A(), ylim = Amax * c(-1, 1))
readLine() # Add the reader line and function values
# Add a legend
legend(x = 3.5, y = 0.9 * Amax,
legend = c("sin(x)", "cos(x)"),
col = c("red", "blue"), lty = 1)
# Save the hover position used as the previous position
hoverx$prev <- tx()
})
}), display.mode= "showcase"
)
Six years later, JavaScript is still the way to go for a graph like this.
Here’s an overview of a couple of different R packages to achieve that,
including dygraphs and highcharts originally mentioned in the comments.
# Goal is to make an interactive crosshair plot with data from this.
trigWaves <- function(x, A = 1, ...) {
rbind(
data.frame(x, y = A * sin(x), f = "sin"),
data.frame(x, y = A * cos(x), f = "cos")
)
}
xs <- seq(0, 2 * pi, len = 201)
Amax <- 5 # Maximum amplitude -- determines plot range, too.
Plotting methods
dygraphs
library(dygraphs)
plot_dygraphs = function(data) {
# Unlike other packages, dygraphs wants wide data
wide <- data %>%
tidyr::pivot_wider(
names_from = f,
values_from = y
)
dygraph(wide) %>%
dyCrosshair("vertical") %>%
dyAxis("y", valueRange = c(-1, 1) * Amax)
}
highcharter
library(highcharter)
plot_highcharter = function(data) {
hchart(data, "line", hcaes(x, y, group = f)) %>%
hc_xAxis(crosshair = TRUE) %>%
hc_yAxis(min = -Amax, max = Amax)
}
plotly
library(plotly)
plot_plotly = function(data) {
plot_ly(data) %>%
add_lines(~ x, ~ y, color = ~ f) %>%
layout(
hovermode = "x",
spikedistance = -1,
xaxis = list(
showspikes = TRUE,
spikemode = "across"
),
yaxis = list(range = c(-1, 1) * Amax)
)
}
c3
library(c3)
plot_c3 = function(data) {
c3(data, "x", "y", group = "f") %>%
c3_line("line") %>%
yAxis(min = -Amax, max = Amax) %>%
point_options(show = FALSE)
}
Shiny app
All of the packages also integrate with Shiny. Here’s a demo app showcasing them:
library(shiny)
ui <- fluidPage(
sliderInput("amplitude", "Amplitude:", 0.1, Amax, 1, step = 0.1),
fluidRow(
column(6,
tags$h3("dygraphs"),
dygraphOutput("dygraphs"),
),
column(6,
tags$h3("highcharter"),
highchartOutput("highcharter"),
),
column(6,
tags$h3("plotly"),
plotlyOutput("plotly"),
),
column(6,
tags$h3("c3"),
c3Output("c3", height = "400px"), # All others have 400px default height
)
)
)
server <- function(input, output, session) {
waves <- reactive(trigWaves(xs, input$amplitude))
output$dygraphs <- renderDygraph({ plot_dygraphs(waves()) })
output$highcharter <- renderHighchart({ plot_highcharter(waves()) })
output$plotly <- renderPlotly({ plot_plotly(waves()) })
output$c3 <- renderC3({ plot_c3(waves()) })
}
shinyApp(ui, server)
See it live here: https://mikkmart.shinyapps.io/crosshair/