Bar Chart Drill down

I have created bar chart but its a simple bar chart. I want to show data year-wise and then if we click on any bar of year then show the data in months of that particular year. how can i show drill-down through high chart function.

library(shiny)
MyDat <- read.csv("E:/Milind/Book1.csv")

MD1=aggregate(MyDat$Count, by=list(Years=MyDat$Year), FUN=sum) # Group_by
RS<-data.frame(Years=MD1$Years,Count=MD1$x) #Give column name
NS<-data.frame(MyDat[order(MyDat$Year),]) #Sort data
TP<-data.frame(MyDat[which(MyDat$Year==2018),])#Filter data

header <- dashboardHeader(disable = TRUE)
body <- dashboardBody(
highchartOutput("Working")
)
sidebar <- dashboardSidebar(disable = TRUE)
ui <- dashboardPage(header, sidebar, body)

server <- function(input, output, session) {
output$Working <- renderHighchart({
RS%>%
hchart('column', hcaes(x =Years, y =Count),pointWidth = 40)
})

}

shinyApp(ui, server)

Hi,

Welcome to the RStudio community!

Have you seen this vignette on the Highcharter's website? I think it explains all you need.

Hope this helps,
PJ

1 Like

Thank you so much. it's helpful for me but in that code when we pass the data to drill_down through mutate it's complicated form understanding. will you please tell me how can i pass the moths and count column to drill down..

Hi,

The mutate function is part of the dplyr package from the Tidyverse. This is an alternative way of writing the flow of your R code and provides a great set of tools for powerful data manipulations while enhancing the readability of your code.

It can indeed look a bit daunting at first (it was for me too), but it's very handy once you get the hang of it. Most functions from tidyverse have an R counterpart that you could use. In case of the mutate, it's just updating a specific column.

library(dplyr)

myData = data.frame(x = 1:10, y = LETTERS[1:10])

#Using plain R
myResult = myData
myResult[, "x"] = myResult[, "x"] + 1
myResult[myResult$x > 5, "y"] = "Z"
myResult
#>     x y
#> 1   2 A
#> 2   3 B
#> 3   4 C
#> 4   5 D
#> 5   6 Z
#> 6   7 Z
#> 7   8 Z
#> 8   9 Z
#> 9  10 Z
#> 10 11 Z

#Using mutate from dplyr
myResult = myData %>% 
  mutate(x = x + 1, y = ifelse(x > 5, "Z", x))
myResult
#>     x y
#> 1   2 2
#> 2   3 3
#> 3   4 4
#> 4   5 5
#> 5   6 Z
#> 6   7 Z
#> 7   8 Z
#> 8   9 Z
#> 9  10 Z
#> 10 11 Z

Created on 2020-07-30 by the reprex package (v0.3.0)

It's not very clear for me what your data looks like, as you have not provided me a reprex. A reprex consists of the minimal code and data needed to recreate the issue/question you're having. You can find instructions how to build and share one here:

So if you give a a bit more detail and code on the issue, I'll try and help you further.

PJ

when drill down it will not showing months at x axix.


library(shiny)
library(shinydashboard)
library(highcharter)
library(tidyverse)
library(RMySQL)
library(shinyWidgets)

OpenPositiondb<-data.frame(dput)
print(OpenPositiondb)

Last_Year<-as.integer(format(Sys.Date(), "%Y"))
Last_Year<-Last_Year-1

ui <- dashboardPage(dashboardHeader(title=HTML("Analytic view - Recruitment"),titleWidth = 280),
dashboardSidebar(disable = TRUE),
dashboardBody(fluidPage(fluidRow(
box(title = fluidRow(
column(10,align = "left", "Open Positions"),
column(2,align = "right",
div(
style = "display: inline-block;padding-left:190px;color:black;",
dropdown(
# tags$h5("List of Input"),
sliderTextInput(inputId = "Positions",
label ="Years",
grid = TRUE,
force_edges = TRUE,
choices = unique(OpenPositiondb$YYYY),
selected =c(Last_Year,as.integer(format(Sys.Date(), "%Y"))),
),
selectInput("Open_PositionsThemes",label = "Themes",choices =c("Theme1","Theme2"),selected = 1),
tags$head(tags$style(HTML(".selectize-input {height: 10px;wigth: 10px;font-size: 15px;text-align:left;}"))),
tags$head(tags$style(HTML(".selectize-dropdown-content {font-size: 15px;text-align:left; }"))),

                               tags$style(".fa-gear {color:black}"),
                               style = "simple",
                               icon = icon("gear"),
                               size = "md",
                               right = T,
                               status = "default",
                               width = "150px",
                               align="left",
                               animate = animateOptions(
                                 enter = animations$fading_entrances$fadeInLeftBig,
                                 exit = animations$fading_exits$fadeOutRightBig)
                             )
                           )),
                  ),solidHeader = T,
                  width = 6,collapsible = T,
                  highchartOutput("Open_Positions", height="240px"))
                )
              )
            )
          )

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

output$Open_Positions <- renderHighchart({
Theme1<-c("#a35d6a","#c26565","#68b0ab","#8fc0a9","#c8d5b9")
Theme2<-c("#b9ac92","#ffa931","#fecb89","#ffa36c","#fbe6d4")

gapminder<-data.frame(OpenPositiondb)

gapminder2007 <- gapminder 

gapminder_column <- gapminder2007 %>%
  filter(YYYY %in% input$Positions)%>%
  group_by(YYYY) %>% 
  summarise(
    Count = sum(Count)
  )

#gapminder_column$YYYY<-as.character(gapminder_column$YYYY)

gapminder_drilldown <- gapminder2007 %>% 
  group_nest(YYYY) %>% 
  mutate(
    id = YYYY,
    type = "column",
    # in the drilldown we'll give the mapping via creating the columns
    data = map(data, mutate, name = month.abb, y  = Count),
    data = map(data, list_parse)
  ) 
print(gapminder_drilldown)
x <- c("Open Position : ")
y <- c("{point.Count}")

tt <- tooltip_table(x, y)
if(input$Open_PositionsThemes=="Theme1")
{
  hchart(
    gapminder_column,
    "column",
    hcaes(x = YYYY, y = Count, drilldown = YYYY),
    name = "Year wise",
    colorByPoint = TRUE
  ) %>% 
    hc_drilldown(
      allowPointDrilldown = TRUE,
      series = list_parse(gapminder_drilldown)
    ) %>% 
    hc_tooltip(
      pointFormat = tt, # "{point.name} {point.pop}"
      useHTML = TRUE,
      valueDecimals = 0
    ) %>% 
    hc_yAxis(
      title = list(text = "Open positions"),
      type = "logarithmic",
      minorTickInterval = 'auto'
    ) %>% 
    hc_xAxis(
      title = ""
    )%>%
    hc_exporting(enabled = TRUE,filename = "Open-Positions")%>%
    hc_colors(Theme1) 
}
else
{
  hchart(
    gapminder_column,
    "column",
    hcaes(x = YYYY, y = Count, drilldown = YYYY),
    name = "Year wise",
    colorByPoint = TRUE
  ) %>% 
    hc_drilldown(
      allowPointDrilldown = TRUE,
      series = list_parse(gapminder_drilldown)
    ) %>% 
    hc_tooltip(
      pointFormat = tt, # "{point.name} {point.pop}"
      useHTML = TRUE,
      valueDecimals = 0
    ) %>% 
    hc_yAxis(
      title = list(text = "Open positions"),
      type = "logarithmic",
      minorTickInterval = 'auto'
    ) %>% 
    hc_xAxis(
      title = ""
    )%>%
    hc_exporting(enabled = TRUE,filename = "Open-Positions")%>%
    hc_colors(Theme2) 
}

})

}
shinyApp(ui, server)

Hi,

Although you provided me with code, it's still not a reprex I can run because it's missing data :slight_smile: I have no access to the dput data frame, and thus can't run your code

Use the df_paste function from datapasta to provide some data here. You can see an example how to convert a dataframe to something you can copy paste to this website here:

library(datapasta)

#R dataframe
testData = data.frame(x = 1:5, y = letters[1:5])

#Paste for reprex
df_paste(testData)
#> data.frame(
#>   stringsAsFactors = FALSE,
#>                  x = c(1L, 2L, 3L, 4L, 5L),
#>                  y = c("a", "b", "c", "d", "e")
#> )

Created on 2020-08-14 by the reprex package (v0.3.0)

Note that if your data frame is large, you have to filter it so not generate too much text. A reprex needs to recreate the issue, but the data itself can be nonsensical.

PJ

Sorry for not provided data. i have added data in this code.

library(shiny)
library(shinydashboard)
library(highcharter)
library(tidyverse)
library(RMySQL)
library(shinyWidgets)
library(reprex)

reconstruct<-structure(list(YYYY = c(2018L, 2018L, 2018L, 2018L, 2018L, 2018L,
2018L, 2018L, 2018L, 2018L, 2018L, 2018L, 2019L, 2019L, 2019L,
2019L, 2019L, 2019L, 2019L, 2019L, 2019L, 2019L, 2019L, 2019L,
2020L, 2020L, 2020L, 2020L, 2020L, 2020L, 2020L, 2020L, 2020L,
2020L, 2020L, 2020L), MMM = c("January", "February", "March",
"April", "May", "June", "July", "August", "September", "October",
"November", "December", "January", "February", "March", "April",
"May", "June", "July", "August", "September", "October", "November",
"December", "January", "February", "March", "April", "May", "June",
"July", "August", "September", "October", "November", "December"
), Count = c(0L, 0L, 0L, 15L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L, 0L, 0L, 0L, 0L, 12L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L, 0L, 0L, 10L, 0L, 0L, 0L, 0L, 0L), c_year = c("C 2018", "C 2018",
"C 2018", "C 2018", "C 2018", "C 2018", "C 2018", "C 2018", "C 2018",
"C 2018", "C 2018", "C 2018", "C 2019", "C 2019", "C 2019", "C 2019",
"C 2019", "C 2019", "C 2019", "C 2019", "C 2019", "C 2019", "C 2019",
"C 2019", "C 2020", "C 2020", "C 2020", "C 2020", "C 2020", "C 2020",
"C 2020", "C 2020", "C 2020", "C 2020", "C 2020", "C 2020")), class = "data.frame", row.names = c(NA,
-36L))

OpenPositiondb<-data.frame(reconstruct)
Last_Year <- as.integer(format(Sys.Date(), "%Y"))
Last_Year <- Last_Year - 1

ui <-
dashboardPage(
dashboardHeader(
title = HTML("Analytic view - Recruitment"),
titleWidth = 280
),
dashboardSidebar(disable = TRUE),
dashboardBody(fluidPage(fluidRow(
box(
title = fluidRow(
column(10, align = "left", "Open Positions"),
column(
2,
align = "right",
div(
style = "display: inline-block;padding-left:190px;color:black;",
dropdown(
# tags$h5("List of Input"),
sliderTextInput(
inputId = "Positions",
label = "Years",
grid = TRUE,
force_edges = TRUE,
choices = unique(OpenPositiondb$YYYY),
selected = c(Last_Year, as.integer(format(Sys.Date(
), "%Y"))),
),
selectInput(
"Open_PositionsThemes",
label = "Themes",
choices = c("Theme1", "Theme2"),
selected = 1
),
tags$head(tags$style(
HTML(
".selectize-input {height: 10px;wigth: 10px;font-size: 15px;text-align:left;}"
)
)),
tags$head(tags$style(
HTML(
".selectize-dropdown-content {font-size: 15px;text-align:left; }"
)
)),

            tags$style(".fa-gear {color:black}"),
            style = "simple",
            icon = icon("gear"),
            size = "md",
            right = T,
            status = "default",
            width = "150px",
            align = "left",
            animate = animateOptions(
              enter = animations$fading_entrances$fadeInLeftBig,
              exit = animations$fading_exits$fadeOutRightBig
            )
          )
        )
      ),
    ),
    solidHeader = T,
    width = 6,
    collapsible = T,
    highchartOutput("Open_Positions", height = "240px")
  )
)))

)

server <- function(input, output, session) {
output$Open_Positions <- renderHighchart({
Theme1 <- c("#a35d6a", "#c26565", "#68b0ab", "#8fc0a9", "#c8d5b9")
Theme2 <- c("#b9ac92", "#ffa931", "#fecb89", "#ffa36c", "#fbe6d4")

gapminder <- data.frame(OpenPositiondb)

gapminder2007 <- gapminder

gapminder_column <- gapminder2007 %>%
  filter(YYYY %in% input$Positions) %>%
  group_by(YYYY) %>%
  summarise(Count = sum(Count))

#gapminder_column$YYYY<-as.character(gapminder_column$YYYY)

gapminder_drilldown <- gapminder2007 %>%
  group_nest(YYYY) %>%
  mutate(
    id = YYYY,
    type = "column",
    # in the drilldown we'll give the mapping via creating the columns
    data = map(data, mutate, name = MMM, y  = Count),
    data = map(data, list_parse)
  )
x <- c("Open Position : ")
y <- c("{point.Count}")

tt <- tooltip_table(x, y)
if (input$Open_PositionsThemes == "Theme1")
{
  hchart(
    gapminder_column,
    "column",
    hcaes(
      x = YYYY,
      y = Count,
      drilldown = YYYY
    ),
    name = "Year wise",
    colorByPoint = TRUE
  ) %>%
    hc_drilldown(allowPointDrilldown = TRUE,
                 series = list_parse(gapminder_drilldown)) %>%
    hc_tooltip(
      pointFormat = tt,
      # "{point.name} {point.pop}"
      useHTML = TRUE,
      valueDecimals = 0
    ) %>%
    hc_yAxis(
      title = list(text = "Open positions"),
      type = "logarithmic",
      minorTickInterval = 'auto'
    ) %>%
    hc_xAxis(title = "") %>%
    hc_exporting(enabled = TRUE, filename = "Open-Positions") %>%
    hc_colors(Theme1)
}
else
{
  hchart(
    gapminder_column,
    "column",
    hcaes(
      x = YYYY,
      y = Count,
      drilldown = YYYY
    ),
    name = "Year wise",
    colorByPoint = TRUE
  ) %>%
    hc_drilldown(allowPointDrilldown = TRUE,
                 series = list_parse(gapminder_drilldown)) %>%
    hc_tooltip(
      pointFormat = tt,
      # "{point.name} {point.pop}"
      useHTML = TRUE,
      valueDecimals = 0
    ) %>%
    hc_yAxis(
      title = list(text = "Open positions"),
      type = "logarithmic",
      minorTickInterval = 'auto'
    ) %>%
    hc_xAxis(title = "") %>%
    hc_exporting(enabled = TRUE, filename = "Open-Positions") %>%
    hc_colors(Theme2)
}

})

}
shinyApp(ui, server)

Hello,

Thanks for taking the time creating a reprex. Your efforts were rewarded as it now only took me a few minutes to find the solution and test it :slight_smile:

I'm not going to copy paste all code, since I only had to make one change. I just modified the hc_xAxis() function:

#Abbreviated months ...
 hc_xAxis(title = "", categories = month.abb)

#OR full month names
 hc_xAxis(title = "", categories = month.name)

The trick was to add the categories argument to the hc_xAxis function.

Both month.abb and month.name are buit-in vectors of (abbreviated) month names in R, but you could have supplied your own vector of course. I read how to do it on the highcharts website xAsis reference.

image

Grtz,
PJ

This topic was automatically closed 54 days after the last reply. New replies are no longer allowed.

If you have a query related to it or one of the replies, start a new topic and refer back with a link.