Перетаскиваемые точки в сюжете -R Subplot - PullRequest
Новая
       17

Перетаскиваемые точки в сюжете -R Subplot

0 голосов
/ 18 апреля 2020

Я знаю, что можно построить график с перетаскиваемыми точками ( здесь ). Можно ли расширить эту функциональность до сюжета, который является частью подзаговора?

То, что я проверил:

  • Я просмотрел chs книги r-plotly . 16-17 пару раз, но решение не выскочило на меня.
  • Этот вопрос очень похож, но описанное исправление не решает проблему.
  • Точно так же, этот отчет github также о почти идентичной проблеме, но, опять же, исправление там не решает проблему.

Для последние два пункта: если я реализую предложенные исправления (см. MWE ниже), точки по-прежнему не перетаскиваются. Вместо этого, щелкнув по соответствующему графику, можно увеличивать и уменьшать масштаб графика.

Быстрое MWE на основе примера книги r-plotly (не работает): 

library(plotly)
library(purrr)
library(shiny)

ui <- fluidPage(
  fluidRow(
    column(5, verbatimTextOutput("summary")),
    column(7, plotlyOutput("p"))
  )
)

server <- function(input, output, session) {

  rv <- reactiveValues( 
    x = mtcars$mpg,
    y = mtcars$wt
  )
  grid <- reactive({
    data.frame(x = seq(min(rv$x), max(rv$x), length = 10))
  })

  model <- reactive({
    d <- data.frame(x = rv$x, y = rv$y)
    lm(y ~ x, d)
  })

  output$p <- renderPlotly({
    # creates a list of circle shapes from x/y data
    circles <- map2(rv$x, rv$y, 
      ~list(
        type = "circle",
        # anchor circles at (mpg, wt)
        xanchor = .x,
        yanchor = .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")
      )
    )

    # plot the shapes and fitted line
    g1 <- plot_ly(source="testGr") %>%   # to cover all the bases (github report)
      add_lines(x = grid()$x, y = predict(model(), grid()), color = I("red")) %>%
      layout(shapes = circles) %>%
      config(edits = list(shapePosition = TRUE))

    g2 <- plot_ly(source="testGr") %>%   # to cover all the bases (github report)
      add_lines(x = seq(1:10), y = 7)

    s <- subplot(g1, g2, nrows=2)
    s$x$source <- "testGr"             # manual override, to make double sure (SO question + github report)
    s
  })

  output$summary <- renderPrint({
    summary(model())
  })

  # update x/y reactive values in response to changes in shape anchors
  observe({
    ed <- event_data("plotly_relayout", source="testGr")  # refers to source names set above
    shape_anchors <- ed[grepl("^shapes.*anchor$", names(ed))]
    if (length(shape_anchors) != 2) return()
    row_index <- unique(readr::parse_number(names(shape_anchors)) + 1)
    pts <- as.numeric(shape_anchors)
    rv$x[row_index] <- pts[1]
    rv$y[row_index] <- pts[2]
  })

}

shinyApp(ui, server)

Для контекста: я могу Не удаляйте рассматриваемый граф из подплота, потому что у меня есть подсветка событий по составным частям подплота, которые необходимо сохранить (или, в конечном итоге, поместить так, чтобы они сохранились).

...