admin管理员组文章数量:1403468
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)
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)
1 Answer
Reset to default 1Not 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)
本文标签： Manually adjust annotation label coordinates in R plotlyStack Overflow
版权声明：本文标题：Manually adjust annotation label coordinates in R plotly - Stack Overflow 内容由网友自发贡献，该文观点仅代表作者本人， 转载请联系作者并注明出处：http://www.betaflare.com/web/1744409234a2604866.html， 本站仅提供信息存储空间服务，不拥有所有权，不承担相关法律责任。如发现本站有涉嫌抄袭侵权/违法违规的内容，一经查实，本站将立刻删除。
发表评论