Извлечение координат XYZ из перетаскиваемой фигуры в Plotly ternary + R / Shiny

Question

Я создаю блестящее приложение, которое должно принимать пользовательский ввод из перетаскиваемой точки на графике Plotly.В отличие от примеров, которые я могу найти, у моего интерактивного графика есть 3 оси - это тройной график, показывающий композицию.

Как мне наблюдать координаты xyz перетаскиваемой пользователем точки на трехслойном графике Plotly? В частности, есть ли способ извлечения якорей формы в системе координат xyz графика, а не в xy?

После ответа на предыдущий вопрос я смог объединитьсячастичное решение, которое приближается (представлены ниже).

Снимок экрана приложения: динамический ввод графика и вывод координат точки

Синий круг можно перетаскивать пользователем.Исходная композиция / координаты (1/3, 1/3, 1/3).(Предыдущее решение) 1 использует якоря формы для изменения положения в координатном пространстве XY.Обратите внимание, что синий круг сидит слишком низко.[В переводе троичных (xyz) в декартовых (xy) координат используется функция 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)