Plot inside of hoverinfo in Plotly - r

Question

I've a plotly bar chart with a hover event which plots another plot alongside the first one
Is there a way to have the second plot show up inside of the hoverinfo box ?
The code I used is as under:
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 dataset:
Race Percent
White 47
Unknown 0
Other 1.8
Latino Hispanic 17.5
Asian 8.9
African American 22.4
Sal data snippet:
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
The current output:
I want the second plot to appear in a small hoverinfo box