Question

我正在构建一个Shiny应用程序，该应用程序应从Plotly图上的可拖动点获取用户输入。与我可以找到的示例不同，我的交互式绘图具有3个轴-这是一个显示成分的三元绘图。

如何观察Plotly三元图中用户可拖动点的xyz坐标？具体来说，有没有办法在图的xyz坐标系中而不是xy提取形状锚？ / p>

在回答previous question之后，我得以将一个很接近的局部解决方案拼凑在一起（下面是reprex）。

App screenshot: Dynamic plot input & point coordinate output

蓝色圆圈是用户可拖动的。起始构图/坐标为（1 / 3、1 / 3、1 / 3）。（先前的解决方案）1利用形状锚在x-y坐标空间中重新定位形状。请注意，蓝色圆圈太低。 [从三元（x-y-z）到笛卡尔（x-y）坐标的转换使用函数ggtern::tlr2xy()。]我不明白为什么会这样。此外，缩放/平移三元图时，蓝点相对于屏幕而不是轴保持在原处。

代表：

library(shiny)
library(tidyverse)
library(plotly)
library(ggtern)

dd <- data.frame(Normal = 1/3, Ice = 1/3, Extreme = 1/3)
en <- data.frame(pop = c("tj", "go"),
                 Normal = c(0.75, 0.65),
                 Ice = c(0.18, 0.28),
                 Extreme = c(0.07, 0.07))

ui <- fluidPage(
  # Application title
  titlePanel("Draggable point on ternary plot"),

  # Sidebar with a slider input for number of bins 
    mainPanel(
      fluidRow(plotlyOutput("ternly")),
      h3("current point coordinates:"),
      fluidRow(textOutput("coords_xy")),
      fluidRow(textOutput("coords_tlr")),
      width = 12
    )
)

server <- function(input, output) {

  rv <- reactiveValues(  # reactive values store ternary coordinates for point
    t = dd$Normal,
    l = dd$Ice,
    r = dd$Extreme, # add 3rd dimension
    x = ggtern::tlr2xy(dd %>% `colnames<-`(c("x", "y", "z")),
                       coord = ggtern::coord_tern(Tlim = c(0,1), Llim = c(0,1), Rlim = c(0,1), expand = FALSE),
                       scale = FALSE)[1, "x"],
    y = ggtern::tlr2xy(dd %>% `colnames<-`(c("x", "y", "z")),
                       coord = ggtern::coord_tern(Tlim = c(0,1), Llim = c(0,1), Rlim = c(0,1), expand = FALSE),
                       scale = FALSE)[1, "y"]
  )

  observe({  # observer watches where the user drags the point, updating 'rv'
    ed <- event_data("plotly_relayout")
    shape_anchors <- ed[grepl("^shapes.*anchor$", names(ed))]
    if (length(shape_anchors) != 2) return()

    pts_xy <- as.numeric(shape_anchors)
    rv$x <- pts_xy[1]
    rv$y <- pts_xy[2]

    pts_tlr <- as.data.frame(matrix(pts_xy, nrow = 1)) %>%
      `colnames<-`(c("x", "y")) %>%
      ggtern::xy2tlr(., coord = ggtern::coord_tern(Tlim = c(0,1), Llim = c(0,1), Rlim = c(0,1), expand = FALSE),
                     scale = FALSE)
    rv$t <- pts_tlr[2] # Normal
    rv$l <- pts_tlr[1] # Ice
    rv$r <- pts_tlr[3] # Extreme
  })

  output$coords_xy <- renderText({
    paste("x:", round(rv$x, 2), "y:", round(rv$y, 2))
  })

  output$coords_tlr <- renderText({
    paste("Normal:", round(rv$t, 2), "Ice:", round(rv$l, 2), "Extreme:",
          round(rv$r, 2))
  })

  output$ternly <- renderPlotly({
    circles <- list(
      type = "circle",
      # anchor circles at (Normal, Ice, Extreme)
      xanchor = rv$x,
      yanchor = rv$y,
      # give each circle a 2 pixel diameter
      x0 = -4, x1 = 4,
      y0 = -4, y1 = 4,
      xsizemode = "pixel", 
      ysizemode = "pixel",
      # other visual properties
      fillcolor = "blue",
      line = list(color = "transparent")
    )

    b <- plot_ly(type = "scatterternary", mode = "markers") %>%
    add_trace(data = en,  # these are two fixed position points (works!)
              name = "Observed",
              type = "scatterternary",
              mode = "markers",
              a = ~Normal, b = ~Ice, c = ~Extreme,
              marker = list(
                  symbol = 0,
                  color = "darkgrey",
                  size = 10,
                  line = list('width' = 3, 'color' = "transparent")),
              text = ~paste0(ifelse(pop == "tj",
                                    "Tjärnö\n", "Göteborg\n"),
                             "Normal: ", round(Normal*100, 2), "%\n",
                             "Ice: ", round(Ice*100, 2), "%\n",
                             "Extreme: ", round(Extreme*100, 2), "%\n"),
              hoverinfo = "text",
              inherit = FALSE) %>%
      layout(shapes = circles,  # this is the draggable point
             ternary = list(
               sum = 1,
               aaxis = list(title = 'Normal', size = 18, color = "darkblue",
                            gridcolor = "darkblue", gridwidth = 1.25, fixedrange = TRUE),
               baxis = list(title = 'Ice', color = "cornflowerblue",
                            gridcolor = "cornflowerblue", gridwidth = 1.25, fixedrange = TRUE),
               caxis = list(title = 'Extreme Ice', color = "grey",
                            gridcolor = "grey", gridwidth = 1.25, fixedrange = TRUE))) %>%
      config(edits = list(shapePosition = TRUE), displaylogo = FALSE,
         collaborate = FALSE)
    b
  })
}

# Run the application 
shinyApp(ui = ui, server = server)

从Plotly三元+ R / Shiny中的可拖动形状中提取XYZ坐标

0 个答案: