Добавление эффектов наведения на кусочки круговой диаграммы - PullRequest
Новая
       23

Добавление эффектов наведения на кусочки круговой диаграммы

0 голосов
/ 03 декабря 2018

Я все еще пытаюсь изменить свой код из , добавляя / удаляя следы в зависимости от события в onclick .

Я хочу добавить эффект наведения на фрагменты моей круговой диаграммы.Я думал сделать это с написанием модификатора CSS на hover.Насколько я понял, срезы моего графика - это класс .slice: 

jshover <- "
    $(document).ready(function(){
    $(.slice).hover(function(){
    $(this).css('background-color', 'yellow');
    }, function(){
    $(this).css('background-color', 'pink');
    })

К сожалению, это не похоже на работу.Ниже вы можете найти весь мой кусок кода: 

require(shiny)
require(shinydashboard)
require(shinyjs)
require(shinythemes)
require(shinyWidgets)
library(data.table)
library(plotly)
require(htmltools)

js <- "
$(document).ready(function(){
$(document).on('click', function(){
Shiny.setInputValue('click_on_doc', true, {priority: 'event'});
Shiny.setInputValue('.clientValue-plotly_click-A', 'null');
})
})"

jshover <- "
$(document).ready(function(){
$(.slice).hover(function(){
$(this).css('background-color', 'yellow');
}, function(){
$(this).css('background-color', 'pink');
})
});"

sidebar <- dashboardSidebar(
  sidebarMenu(
    menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
    menuItem("Widgets", icon = icon("th"), tabName = "widgets",
             badgeLabel = "new", badgeColor = "green")
  )
)

body <- dashboardBody(
  tabItems(
    tabItem(tabName = "dashboard",
            h2("Dashboard tab content"),
            tags$head(tags$script(HTML(js))),
            tags$head(tags$script(src="https://d3js.org/d3.v5.min.js")),
            tags$script(HTML(jshover)),
              fluidRow(column(12, plotly::plotlyOutput("myplot", height = "800px")))
    ),

    tabItem(tabName = "widgets",
            h2("Widgets tab content")
    )
  )
)

# Define UI
ui <- dashboardPage(
  dashboardHeader(title = "Simple tabs"),
  sidebar,
  body
)

# Server logic
server <- function(input, output, session) {
  testdata <- data.frame("Orga" = c("Li", "La", "Le", "Lu", "De", "Va", "Xul", "Jin"),
                         "Dachorga" = c("Bla", "Bla", "Blu", "Blu", "Blub", "Blub", "Lol", "Lol"),
                         "Umsatz.Orga" = c(20000, 10000, 12000, 3000, 100, 2400, 205000, 95000))
  testdata <- data.table(testdata)
  testdata_agg <- testdata[, sum(Umsatz.Orga), by=Dachorga]

  plot <- testdata_agg %>%
    group_by(Dachorga) %>%
    plot_ly(labels = ~Dachorga, values = ~V1, hoverinfo = 'label+percent+value') %>%
    add_pie(hole = 0.6) %>%
    layout(title = "Donut charts using Plotly",  showlegend = F,
           xaxis = list(showgrid = FALSE, zeroline = FALSE, showticklabels = FALSE),
           yaxis = list(showgrid = FALSE, zeroline = FALSE, showticklabels = FALSE))

  click <- reactiveVal(FALSE)
  myline <- reactiveVal(0)

  observe({
    event <- !is.null(event_data("plotly_click"))
    click(event)
    myline(event_data("plotly_click")$pointNumber)
  })

  observeEvent(input$click_on_doc, {
    click(FALSE)
  })  

  output$myplot <- renderPlotly({
    if (click()) {
      p <- add_pie(plot, data = testdata[Dachorga == testdata_agg$Dachorga[myline()+1]], labels = ~Orga, 
                   values = ~Umsatz.Orga, hole = 0.5, 
                   hoverinfo = 'label+percent+value', domain = list(
                     x = c(0.1, 0.9),
                     y = c(0.1, 0.9)),
                   marker = list(hover = list(color = "white")))
    }else{
      p <- plot
    }
    p
  })
}

# Complete app with UI and server components
shinyApp(ui, server)

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

Заранее спасибо.

...