Manually adjust annotation label coordinates in R plotly
In a Shiny app with R plotly, how can I manually control the position of annotation labels by specifying x and y coordinates (using rhandsontable)? Additionally, is it possible to add arrows that adjust based on the updated coordinates? Below I provide simple example, without annotations.
library(shiny)
library(plotly)
library(rhandsontable)
ui <- fluidPage(
titlePanel("Plotly Scatterplot with Movable Labels and Arrows"),
sidebarLayout(
sidebarPanel(
rHandsontableOutput("table"),
checkboxInput("show_arrows", "Show Arrows", value = TRUE)
),
mainPanel(
plotlyOutput("scatterplot")
)
)
)
server <- function(input, output, session) {
dot_data <- data.frame(
id = 1:5,
label = c("A", "B", "C", "D", "E"),
x_dot = c(1, 2, 3, 4, 5),
y_dot = c(2, 3, 4, 5, 6)
)
label_data <- reactiveVal(data.frame(
id = 1:5,
label = c("A", "B", "C", "D", "E"),
x_label = c(1, 2, 3, 4, 5),
y_label = c(2, 3, 4, 5, 6)
))
output$table <- renderRHandsontable({
rhandsontable(label_data(), stretchH = "all", height = 300)
})
observeEvent(input$table, {
new_data <- hot_to_r(input$table)
label_data(new_data)
})
output$scatterplot <- renderPlotly({
data <- label_data()
plot <- plot_ly() %>%
add_trace(
data = dot_data,
x = ~x_dot,
y = ~y_dot,
type = "scatter",
mode = "markers",
marker = list(size = 10, color = "blue")
)
plot
})
}
# Run the application
shinyApp(ui = ui, server = server)
Solution
Not really sure, what the ShowArrow button should do - so I provided two options.
1
uses red line shapes which can be controlled via the showArrows button
library(shiny)
library(plotly)
library(rhandsontable)
ui <- fluidPage(
titlePanel("Plotly Scatterplot with Movable Labels and Arrows"),
sidebarLayout(
sidebarPanel(
rHandsontableOutput("table"),
checkboxInput("show_arrows", "Show Arrows", value = TRUE)
),
mainPanel(
plotlyOutput("scatterplot")
)
)
)
server <- function(input, output, session) {
dot_data <- data.frame(
id = 1:5,
label = c("A", "B", "C", "D", "E"),
x_dot = c(1, 2, 3, 4, 5),
y_dot = c(2, 3, 4, 5, 6)
)
label_data <- reactiveVal(data.frame(
id = 1:5,
label = c("A", "B", "C", "D", "E"),
x_label = c(1.5, 2.5, 3.5, 4.5, 5.5),
y_label = c(2.5, 3.5, 4.5, 5.5, 6.5)
))
output$table <- renderRHandsontable({
rhandsontable(label_data(), stretchH = "all", height = 300) %>%
hot_col("id", readOnly = TRUE) %>%
hot_col("label", readOnly = TRUE) %>%
hot_col("x_label", format = "0.0") %>%
hot_col("y_label", format = "0.0")
})
observeEvent(input$table, {
new_data <- hot_to_r(input$table)
label_data(new_data)
})
output$scatterplot <- renderPlotly({
data <- label_data()
# Create base plot with markers
plot <- plot_ly() %>%
add_trace(
data = dot_data,
x = ~x_dot,
y = ~y_dot,
type = "scatter",
mode = "markers",
marker = list(size = 10, color = "blue"),
hoverinfo = "text",
text = ~label,
showlegend = FALSE
) %>%
add_trace( # Add labels
x = data$x_label,
y = data$y_label,
type = "scatter",
mode = "text",
text = data$label,
textposition = "middle center",
textfont = list(size = 12),
hoverinfo = "none",
showlegend = FALSE
) %>%
layout(
xaxis = list(title = "X Axis"),
yaxis = list(title = "Y Axis"),
title = "Points with Adjustable Labels",
hovermode = "closest"
)
if(input$show_arrows) {
plot <- plot %>% layout(shapes = lapply(1:nrow(data), function(i) {
list(
type = "line",
x0 = dot_data$x_dot[i],
y0 = dot_data$y_dot[i],
x1 = data$x_label[i],
y1 = data$y_label[i],
line = list(color = "red", width = 2),
layer = "below"
)
}))
}
plot
})
}
shinyApp(ui = ui, server = server)
2
uses annotations where showArrow is tied to the button showarrow = input$show_arrows
library(shiny)
library(plotly)
library(rhandsontable)
ui <- fluidPage(
titlePanel("Plotly Scatterplot with Movable Labels and Arrows"),
sidebarLayout(
sidebarPanel(
rHandsontableOutput("table"),
checkboxInput("show_arrows", "Show Arrows", value = TRUE)
),
mainPanel(
plotlyOutput("scatterplot")
)
)
)
server <- function(input, output, session) {
dot_data <- data.frame(
id = 1:5,
label = c("A", "B", "C", "D", "E"),
x_dot = c(1, 2, 3, 4, 5),
y_dot = c(2, 3, 4, 5, 6)
)
label_data <- reactiveVal(data.frame(
id = 1:5,
label = c("A", "B", "C", "D", "E"),
x_label = c(1.5, 2.5, 3.5, 4.5, 5.5),
y_label = c(2.5, 3.5, 4.5, 5.5, 6.5)
))
output$table <- renderRHandsontable({
rhandsontable(label_data(), stretchH = "all", height = 300) %>%
hot_col("id", readOnly = TRUE) %>%
hot_col("label", readOnly = TRUE) %>%
hot_col("x_label", format = "0.0") %>%
hot_col("y_label", format = "0.0")
})
observeEvent(input$table, {
new_data <- hot_to_r(input$table)
label_data(new_data)
})
output$scatterplot <- renderPlotly({
data <- label_data()
# Create base plot with markers
plot <- plot_ly() %>%
add_trace(
data = dot_data,
x = ~x_dot,
y = ~y_dot,
type = "scatter",
mode = "markers",
marker = list(size = 10, color = "blue"),
hoverinfo = "text",
text = ~label,
showlegend = FALSE
) %>%
layout(
xaxis = list(title = "X Axis"),
yaxis = list(title = "Y Axis"),
title = "Points with Adjustable Labels",
hovermode = "closest"
)
plot <- plot %>% layout(annotations = lapply(1:nrow(data), function(i) {
list(
x = dot_data$x_dot[i],
y = dot_data$y_dot[i],
text = data$label[i],
showarrow = input$show_arrows,
arrowhead = 2,
arrowsize = 1,
ax = data$x_label[i],
ay = data$y_label[i],
axref = "x",
ayref = "y",
xref = "x",
yref = "y",
font = list(size = 12),
bgcolor = "white",
bordercolor = "black",
borderwidth = 1
)
}))
plot
})
}
shinyApp(ui = ui, server = server)
- Issues integrating shinychat into a modular R Shiny app
- barplot multiple aggregation
- Start a PowerShell script in R via system2()
- plot from sankeyNetwork in networkD3 does not show output (issue is not number of unique nodes)
- "Target position can only be set for new windows" in chromote in R
- Extract the correct data type in a PDF table
- Time conversion in R
- Comparing the values of a certain number previous rows with the current row
- Run a single test function in R's testthat
- rpart package installation in R
- An efficient way to assign value based on a min-max range and category
- Change output of the `purrr::map` function
- osmdata_sf returns failed to perform HTTP request curl::curl_fetch_memory() error in R?
- Comparing nls() to nls2() - what am I doing wrong
- How to add "variables grid" below ggplot
- How can I use predefined code snippets outside of code chunks in Quarto within RStudio/Posit?
- Wrap text for collapse rows in KableExtra for a long table in R
- Implementation of Breusch-Pagan test for random effects in plm with unbalanced panels
- Finding a value of a dataset in different ones
- Replicate matrix
- Unexpected results after converting raster data from geographic to projected coordinate system using the terra package
- How to remove rows by condition in R?
- How do I add an alias for magrittr pipe from R in vscode
- Package ‘neuralnet’ in R, rectified linear unit (ReLU) activation function?
- Reticulate with pywin32, a dependency of xlwings, not found when sourcing python script from R
- Sub-subtitle in a graph made with `ggplot2`
- How can I execute a statement and ignore warnings with tryCatch?
- Enumerate events where n consecutive values are not NA
- Serialize/deserialize a column with R and DuckDB
- How can I structure my sapflow data to analyze using "TREX" package in R?