R: более гибкие аннотации на графиках + блестящие - PullRequest
Новая
       30

R: более гибкие аннотации на графиках + блестящие

0 голосов
/ 25 апреля 2019

Я использую dygraphs в своем приложении Shiny для визуализации довольно сложных временных рядов. Я хочу иметь возможность:

1) построить несколько аннотаций с двумя метками @ «купить» и «продать». в идеале, используя значки и / или разные цвета и 2) контролировать, на каком временном ряду он будет построен.

В отношении пункта 1, я нашел этот ТАК ответ , который работает, но довольно неуклюже. Есть ли лучший (более аккуратный) способ достижения того же эффекта?

В отношении пункта 2, см. Код ниже - как я могу вместо этого нанести аннотации на Y-ряд? 

library(xts)
library(shiny)
library(shinydashboard)
library(dygraphs)
library(dplyr)

ui <- dashboardPage(
  dashboardHeader(),
  dashboardSidebar(),
  dashboardBody(
    dygraphOutput('plot1')
  )
)

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

  m_df <- data.frame(date=as.Date(zoo::as.yearmon(time(mdeaths))), Y=as.matrix(mdeaths)) %>% 
    mutate(action = c(
      rep(c(rep(NA, 7), 'Buy'), 4),
      rep(c(rep(NA, 7), 'Sell'), 5)
    ),
    label = ifelse(action == 'Buy', 'B',
                   ifelse(action == 'Sell', 'S', NA)))



  subdata <- reactive({
    if(!is.null(input$plot1_date_window)){
      subdata <- m_df[m_df$date >= as.Date(input$plot1_date_window[1]) & m_df$date <= as.Date(input$plot1_date_window[2]), ]
      subdata$cumsum <- cumsum(subdata$Y)
      subdata$Y <- NULL
    } else {
      subdata <- NULL
    }

    return(subdata)
  })

  subdata_d <- subdata %>% debounce(100)

  # tick_dataB <- m_df %>% select(date, action) %>%  filter(action == 'Buy')
  # tick_dataS <- m_df %>% select(date, action) %>%  filter(action == 'Sell')
  # buy_dates <- tick_dataB$date
  # sell_dates <- tick_dataS$date
  # buy_texts <- rep('B', length(tick_dataB$action))
  # sell_texts <- rep('S', length(tick_dataS$action))
  # buy_labels <- tick_dataB$action
  # sell_labels <- tick_dataS$action
  # 

  output$plot1 <- renderDygraph({
    input_xts <- xts(select(m_df, -c(date, action)), order.by = m_df$date)
    if(is.null(subdata_d())){
      final_xts <- input_xts
    } else {

      subdata_xts <- xts(select(subdata_d(), - date), order.by = subdata_d()$date)
      final_xts <- cbind(input_xts, subdata_xts)
    }

    p <- dygraph(final_xts) %>% dySeries(name="Y") %>%
      dyRangeSelector(retainDateWindow = TRUE) 


    if("cumsum" %in% names(final_xts)){
      p <- dySeries(p, name="cumsum", axis = "y2")
    }


    dates <- m_df %>% na.omit() %>% pull(date)
    texts <- m_df %>% na.omit() %>% pull(label)
    labels <- m_df %>% na.omit() %>% pull(action) 


    anno_code <- paste('p %>% ',
                       paste0("dyAnnotation('",
                              dates,
                              "', text = '",
                              texts,
                              "', tooltip = '",
                              labels,
                              "')",
                              collapse = " %>% "))

   eval(parse(text = anno_code))

  })

}

shinyApp(ui, server)

Код взят из моего другого вопроса, который я разместил здесь

...