Plotly

Question

我有一个带有悬停事件的情节条形图，其中绘制了另一个与第一个情节并列的情节

有没有办法让第二个图显示在hoverinfo框内？

我使用的代码如下：

UI

library(shiny)
library(plotly)
library(shinythemes)
library(dplyr)
library(png)

ui <- fluidPage(

  theme = shinytheme("spacelab"),


  h2("Coupled hover-events in plotly charts using Shiny"),


  tags$hr(),

  fluidRow(
    column(6, plotlyOutput(outputId = "ageplot", height = "600px")),
    column(6, plotlyOutput(outputId = "raceplot", height = "600px"))),

  tags$hr(),
  tags$blockquote("Hover over age plot for race and gender information")
  )

SERVER：

server <- function(input, output){


  patdata <- read.csv("Sal.csv")
  boston_race<-read.csv("bostonrace.csv")

  patdata$Race<-ifelse(patdata$Race=="RACE_UNKNOWN", "Unknown",ifelse(patdata$Race=="BLACK_AFRICAN_AMERICAN", "African American",ifelse(patdata$Race=="RACE_LATINO_HISPANIC", "Latino Hispanic",
                                                                                                                                                             ifelse(patdata$Race=="WHITE", "White",ifelse(patdata$Race=="ASIAN", "Asian",
                                                                                                                                                                                                                 ifelse(patdata$Race=="RACE_OTHER", "Other","Unknown"))))))

  patdata$Date<-as.Date(patdata$CreateDate, format = "%m/%d/%Y")
  patdata$agegroup<- ifelse(patdata$Age>=0 &patdata$Age<=19,"<20",
                                   ifelse(patdata$Age>=20 &patdata$Age<=29,"20-29", 
                                          ifelse(patdata$Age>=30 &patdata$Age<=39,"30-39",
                                                 ifelse(patdata$Age>=40 &patdata$Age<=49,"40-49",
                                                        ifelse(patdata$Age>=50,"50+","Invalid Age")))))


  patdata$dp<- ifelse(patdata$Age>=0 &patdata$Age<=19,0,
                            ifelse(patdata$Age>=20 &patdata$Age<=29,1, 
                                   ifelse(patdata$Age>=30 &patdata$Age<=39,2,
                                          ifelse(patdata$Age>=40 &patdata$Age<=49,3,
                                                 ifelse(patdata$Age>=50,4,NA)))))

  patdata$dp<-as.numeric(patdata$dp)

  patdata_age<- subset(patdata, select="agegroup")
  patdata_age<-as.data.frame(table(patdata_age))
  selection<-patdata_age




  output$ageplot <- renderPlotly({
    colnames(selection)<-c("agegroup","Freq")
    selection$y<-round((patdata_age$Freq*100/sum(patdata_age$Freq)))
    plot_ly(source = "source",selection, x = ~agegroup, y = selection$y, type = 'bar',
            marker = list(color = 'rgb(255,140,0)',    
                          # marker = list(color,alpha = d),
                          line = list(color = 'rgb(8,48,107)', width = 1.5))) %>%
      layout(title = paste0("Age-group distribution of patients "),xaxis = list(title = 'age group'),
             yaxis = list(title = paste0('Percentage of Patients')),titlefont=list(size=13),
             annotations = list(x = ~agegroup, y = selection$y, text = paste0(selection$y, "%"),
                                xanchor = 'center', yanchor = 'bottom',
                                showarrow = FALSE))



  })


  output$raceplot <- renderPlotly({


    eventdata <- event_data("plotly_hover", source = "source")
    validate(need(!is.null(eventdata), "Hover over the age plot to populate this race plot"))


    datapoint <- as.numeric(eventdata$pointNumber)[1]
    sel<-patdata  %>% filter(dp %in% datapoint)


    raceselection<-subset(sel,select="Race")
    raceselection<-as.data.frame(table(raceselection))
    colnames(raceselection)<-c("Race","Freq")
    raceselection$y<-round((raceselection$Freq*100/sum(raceselection$Freq)))

    raceall<-merge(raceselection,boston_race)


    raceall$Race<- as.character(raceall$Race)
    raceall$Percent<-round(raceall$Percent,0)





    plot_ly(raceall, x = ~Race, y = ~Percent, type = 'bar', name = 'Total Population',marker = list(color = 'rgb(255,140,0)',
                                                                                                    line = list(color = 'rgb(8,48,107)', width = 1))
    ) %>%
      add_trace(y = ~y, name = 'Patient Population',marker = list(color = 'rgb(49,130,189)',
                                                                  line = list(color = 'rgb(8,48,107)', width = 1))) %>%
      layout(yaxis = list(title = 'Population Percent'), barmode = 'group',
             title = paste0("Patient Race comparison"))




  })


}

boston_race数据集：

Race    Percent
White   47
Unknown 0
Other   1.8
Latino Hispanic 17.5
Asian   8.9
African American    22.4

Sal数据摘录：

CreateDate  Age Race
1/6/1901    20  RACE_LATINO_HISPANIC
1/21/1901   37  BLACK_AFRICAN_AMERICAN
1/21/1901   51  WHITE
1/31/1901   58  WHITE
2/2/1901    24  ASIAN
2/4/1901    31  WHITE
2/7/1901    29  WHITE
2/7/1901    19  WHITE
2/11/1901   7   BLACK_AFRICAN_AMERICAN
2/12/1901   41  ASIAN
2/13/1901   22  WHITE
2/19/1901   3   RACE_LATINO_HISPANIC
2/24/1901   19  WHITE
3/7/1901    26  WHITE
3/12/1901   21  RACE_UNKNOWN
3/17/1901   39  RACE_LATINO_HISPANIC
3/18/1901   71  WHITE
3/20/1901   65  WHITE
4/10/1901   19  WHITE
4/18/1901   31  WHITE
4/23/1901   63  WHITE
4/24/1901   20  WHITE
4/29/1901   19  WHITE
4/30/1901   27  WHITE
5/2/1901    23  WHITE
5/12/1901   21  WHITE
5/16/1901   26  RACE_LATINO_HISPANIC
5/20/1901   54  BLACK_AFRICAN_AMERICAN
5/20/1901   2   WHITE
5/20/1901   9   RACE_LATINO_HISPANIC
5/21/1901   28  WHITE
5/29/1901   2   BLACK_AFRICAN_AMERICAN
5/30/1901   0   WHITE
6/3/1901    21  WHITE
6/9/1901    10  ASIAN
6/9/1901    37  WHITE

当前输出：

我希望第二张图出现在一个小的hoverinfo框中