├── .gitignore ├── 01-get-started ├── DESCRIPTION ├── Readme.md ├── app.R └── rsconnect │ └── shinyapps.io │ └── jbkunst │ └── 01-get-sarted.dcf ├── 02-proxy-functions ├── DESCRIPTION ├── Readme.md ├── app.R └── rsconnect │ └── shinyapps.io │ └── jbkunst │ └── 02-proxy-functions.dcf ├── 03-events-v2 ├── DESCRIPTION ├── Readme.md ├── app.R └── rsconnect │ └── shinyapps.io │ └── jbkunst │ └── 03-events-v2.dcf ├── 03-events ├── DESCRIPTION ├── Readme.md ├── app.R └── rsconnect │ └── shinyapps.io │ └── jbkunst │ └── 03-events.dcf ├── 04-shinydashboard-n-spakrlines ├── DESCRIPTION ├── Readme.md ├── global.R ├── rsconnect │ └── shinyapps.io │ │ └── jbkunst │ │ └── 04-shinydashboard-n-spakrlines.dcf ├── server.R └── ui.R ├── 05-arma ├── DESCRIPTION ├── Readme.md ├── app.R └── rsconnect │ └── shinyapps.io │ └── jbkunst │ └── 05-arma.dcf ├── 06-maps-performance ├── DESCRIPTION ├── Readme.md ├── app.R └── rsconnect │ └── shinyapps.io │ └── jbkunst │ └── 06-maps-performance.dcf ├── 07-nyt-temp ├── .gitignore ├── DESCRIPTION ├── LICENSE ├── Readme.md ├── global.R ├── nyt-temp.Rproj ├── rsconnect │ └── shinyapps.io │ │ └── jbkunst │ │ └── 07-nyt-temp.dcf ├── server.R └── ui.R ├── 08-idb-viz ├── .gitignore ├── README.md ├── countries.rds ├── download_data.R ├── global.R ├── idb-viz.Rproj ├── rsconnect │ └── shinyapps.io │ │ └── jbkunst │ │ └── 08-idb-viz.dcf ├── server.R ├── ui.R └── www │ └── custom.css ├── 09-piramid-census ├── ..geojson ├── .gitignore ├── DESCRIPTION ├── Readme.md ├── censusdata.rds ├── countries.json ├── dataapp.RData ├── dataappmin.RData ├── download_prepare_data.R ├── global.R ├── piramid-census.Rproj ├── rsconnect │ └── shinyapps.io │ │ └── jbkunst │ │ └── 09-piramid-census.dcf ├── server.R └── ui.R ├── deploy_apps.R └── highcharter-shiny.Rproj /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | *debug.log -------------------------------------------------------------------------------- /01-get-started/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Title: Hello Word with highcharter 2 | Author: Joshua Kunst 3 | AuthorUrl: https://jkunst.com/ 4 | License: MIT 5 | DisplayMode: Showcase 6 | Tags: proxy 7 | Type: Shiny -------------------------------------------------------------------------------- /01-get-started/Readme.md: -------------------------------------------------------------------------------- 1 | This small Shiny application show how to integrate highcharter in Shiny web 2 | appliaction. 3 | 4 | The main function are `highchartOutput` and `renderHighchart` and work the 5 | same way like other widgets like DT, Plotly o recharts4r. 6 | -------------------------------------------------------------------------------- /01-get-started/app.R: -------------------------------------------------------------------------------- 1 | # Load packages 2 | library(shiny) 3 | library(shinythemes) 4 | library(highcharter) 5 | 6 | ui <- fluidPage( 7 | theme = shinytheme("paper"), 8 | fluidRow( 9 | column(width = 6, highchartOutput("chart1")), 10 | column(width = 6, highchartOutput("chart2")), 11 | ) 12 | 13 | ) 14 | 15 | server <- function(input, output) { 16 | 17 | output$chart1 <- renderHighchart({ 18 | 19 | highcharts_demo() 20 | 21 | }) 22 | 23 | output$chart2 <- renderHighchart({ 24 | 25 | hchart(iris, "scatter", hcaes(Sepal.Length, Sepal.Width, group = Species)) 26 | 27 | }) 28 | 29 | 30 | } 31 | 32 | shinyApp(ui, server) 33 | -------------------------------------------------------------------------------- /01-get-started/rsconnect/shinyapps.io/jbkunst/01-get-sarted.dcf: -------------------------------------------------------------------------------- 1 | name: 01-get-sarted 2 | title: 3 | username: 4 | account: jbkunst 5 | server: shinyapps.io 6 | hostUrl: https://api.shinyapps.io/v1 7 | appId: 4200762 8 | bundleId: 4655743 9 | url: https://jbkunst.shinyapps.io/01-get-sarted/ 10 | when: 1622336125.87287 11 | lastSyncTime: 1622336125.87287 12 | -------------------------------------------------------------------------------- /02-proxy-functions/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Title: Proxy functions 2 | Author: Joshua Kunst 3 | AuthorUrl: https://jkunst.com/ 4 | License: MIT 5 | DisplayMode: Showcase 6 | Tags: getting-started 7 | Type: Shiny -------------------------------------------------------------------------------- /02-proxy-functions/Readme.md: -------------------------------------------------------------------------------- 1 | Proxy functions allow you modify the highcharter widget without redraw 2 | the entire chart. 3 | 4 | The functions implemented are: 5 | 6 | - `hcpxy_add_series` To add a new series to an existing highcharter widget. 7 | - `hcpxy_remove_series` Remove specific series of a highcharter widget. 8 | - `hcpxy_update` Change general chart options of a widget. 9 | - `hcpxy_update_series` Change series options of a widget. 10 | - `hcpxy_add_point` To add a specific point from a specific series. 11 | - `hcpxy_remove_point` To remove a specific point from a specific series. 12 | - `hcpxy_loading` To enable or disable the the loading icon over the widget. 13 | 14 | To use this function you need a widget in your `ui`, let's say: 15 | 16 | ```r 17 | ui <- fluidPage( 18 | ..., 19 | highchartOutput("widget"), 20 | ... 21 | ) 22 | ``` 23 | 24 | If you need to modify the widget associated to `highchartOutput("widget")` 25 | you need to create a proxy object indicating the id, in this case `"widget"`. 26 | It's important to use the argument `session` to define the server. 27 | 28 | ```r 29 | server <- function(input, output, session){ 30 | 31 | # some where in you server, probably in a observeEvent 32 | 33 | observeEvent(input$idbutton, { 34 | 35 | highchartProxy("widget") %>% 36 | # modify options 37 | hcpxy_update( 38 | title = list(text = "A new title"), 39 | chart = list(inverted = FALSE, polar = FALSE), 40 | xAxis = list(gridLineWidth = 1), 41 | yAxis = list(endOnTick = FALSE), 42 | chart = list(inverted = FALSE, polar = TRUE) 43 | ) %>% 44 | # add data 45 | hc_add_series(df, "line", hcaes(x, y), id = "ts", name = "A real time value") 46 | }) 47 | 48 | } 49 | ``` 50 | 51 | Don't forget to check the code example. -------------------------------------------------------------------------------- /02-proxy-functions/app.R: -------------------------------------------------------------------------------- 1 | library(highcharter) 2 | library(shiny) 3 | library(shinythemes) 4 | library(dplyr) 5 | 6 | langs <- getOption("highcharter.lang") 7 | 8 | langs$loading <- "" 9 | 10 | options(highcharter.lang = langs) 11 | 12 | options(highcharter.theme = hc_theme_smpl()) 13 | 14 | column <- purrr::partial(shiny::column, width = 6) 15 | 16 | ui <- fluidPage( 17 | theme = shinytheme("paper"), 18 | tags$style(HTML(".btn { margin-bottom: 5px;}")), 19 | tags$hr(), 20 | actionButton("reset", "Reset charts", class = "btn-danger"), 21 | tags$hr(), 22 | fluidRow( 23 | column( 24 | actionButton("addpnts", "Add Series"), 25 | highchartOutput("hc_nd") 26 | ), 27 | column( 28 | actionButton("set_data", "Update all series data"), 29 | highchartOutput("hc_set_data") 30 | ), 31 | column( 32 | actionButton("mkpreds", "Add Series linkedTo existing one"), 33 | highchartOutput("hc_ts") 34 | ), 35 | column( 36 | actionButton("loading", "Loading"), 37 | highchartOutput("hc_ld") 38 | ), 39 | column( 40 | actionButton("remove", "Remove series"), 41 | highchartOutput("hc_rm") 42 | ), 43 | column( 44 | actionButton("remove_all", "Remove all series"), 45 | highchartOutput("hc_rm_all") 46 | ), 47 | column( 48 | actionButton("update1", "Update options"), 49 | actionButton("update2", "Update options 2"), 50 | highchartOutput("hc_opts") 51 | ), 52 | column( 53 | actionButton("update3", "Update series data"), 54 | actionButton("update4", "Update series options"), 55 | highchartOutput("hc_opts2") 56 | ), 57 | column( 58 | fluidRow( 59 | column(radioButtons("item_choice", label = NULL, inline = TRUE, choices = c("rectangle", "parliment", "circle"))), 60 | column(sliderInput("item_rows", NULL, min = 0, max = 5, value = 0, step = 1, ticks = FALSE)) 61 | ), 62 | highchartOutput("hc_opts3") 63 | ), 64 | column( 65 | actionButton("addpoint", "Add point"), 66 | actionButton("addpoint_w_shift", "Add point with shift"), 67 | actionButton("rmpoint", "Remove point"), 68 | highchartOutput("hc_addpoint") 69 | ), 70 | column( 71 | fluidRow( 72 | column(selectInput("selectpoint", label = NULL, choices = 1:3, selected = NULL)), 73 | column(actionButton("action", label = "Change")) 74 | ), 75 | highchartOutput("hc_selectpoint") 76 | ), 77 | 78 | ) 79 | ) 80 | 81 | server <- function(input, output, session){ 82 | 83 | # add multiples series ---------------------------------------------------- 84 | output$hc_nd <- renderHighchart({ 85 | input$reset 86 | 87 | d <- datasets::iris %>% 88 | mutate(across(where(is.numeric), ~ round(.x + runif(1), 4))) %>% 89 | sample_n(30) %>% 90 | select(Sepal.Length, Sepal.Width) 91 | 92 | hchart( 93 | d, "point", 94 | hcaes(x = Sepal.Length, y = Sepal.Width), 95 | showInLegend = TRUE, 96 | name = "Random Points" 97 | ) %>% 98 | hc_title(text = "Chart with some points") 99 | }) 100 | 101 | observeEvent(input$addpnts, { 102 | d <- datasets::iris %>% 103 | mutate(across(where(is.numeric), ~ round(.x + runif(1), 4))) %>% 104 | sample_n(10) 105 | 106 | highchartProxy("hc_nd") %>% 107 | hcpxy_add_series( 108 | data = d, 109 | "scatter", 110 | hcaes(x = Sepal.Length, y = Sepal.Width, group = Species) 111 | ) 112 | }) 113 | 114 | output$hc_set_data <- renderHighchart({ 115 | 116 | input$reset 117 | 118 | df <- data.frame( 119 | month = month.abb, 120 | A = runif(12, 20, 40), 121 | B = runif(12, 30, 50), 122 | C = runif(12, 40, 60), 123 | D = runif(12, 50, 70) 124 | ) 125 | df <- tidyr::pivot_longer(df, A:D, names_to = "name", values_to = "value") 126 | 127 | hchart(df, "column", hcaes(month, value, group = name)) %>% 128 | hc_xAxis(title = list(text = "")) %>% 129 | hc_yAxis(title = list(text = "")) 130 | }) 131 | 132 | observeEvent(input$set_data, { 133 | 134 | df <- data.frame( 135 | month = month.abb, 136 | A = runif(12, 20, 40), 137 | B = runif(12, 30, 50), 138 | C = runif(12, 40, 60), 139 | D = runif(12, 50, 70) 140 | ) 141 | df <- tidyr::pivot_longer(df, A:D, names_to = "name", values_to = "value") 142 | 143 | highchartProxy("hc_set_data") %>% 144 | hcpxy_set_data( 145 | type = "column", 146 | data = df, 147 | mapping = hcaes(month, value, group = name), 148 | redraw = TRUE 149 | ) 150 | 151 | }) 152 | 153 | # add series to linked one ------------------------------------------------ 154 | output$hc_ts <- renderHighchart({ 155 | input$reset 156 | hchart(AirPassengers, name = "Passengers", id = "data") 157 | }) 158 | 159 | observeEvent(input$mkpreds, { 160 | highchartProxy("hc_ts") %>% 161 | hcpxy_add_series( 162 | forecast::forecast(AirPassengers), name = "Supermodel", 163 | showInLegend = FALSE, linkedTo = "data") 164 | }) 165 | 166 | # loading example --------------------------------------------------------- 167 | output$hc_ld <- renderHighchart({ 168 | input$reset 169 | d <- cars %>% 170 | sample_n(10) %>% 171 | setNames(c("x", "y")) 172 | hchart(d, "scatter", hcaes(x, y)) 173 | }) 174 | 175 | observeEvent(input$loading, { 176 | 177 | highchartProxy("hc_ld") %>% 178 | hcpxy_loading(action = "show") 179 | 180 | Sys.sleep(1) 181 | 182 | dat <- cars %>% 183 | sample_n(10) %>% 184 | setNames(c("x", "y")) 185 | 186 | highchartProxy("hc_ld") %>% 187 | hcpxy_set_data( 188 | type = "scatter", 189 | data = dat, 190 | mapping = hcaes(x, y), 191 | redraw = TRUE 192 | ) 193 | 194 | Sys.sleep(1) 195 | 196 | highchartProxy("hc_ld") %>% 197 | hcpxy_loading(action = "hide") %>% 198 | hcpxy_update_series() 199 | 200 | }) 201 | 202 | # remove one series ------------------------------------------------------- 203 | output$hc_rm <- renderHighchart({ 204 | input$reset 205 | hchart(ggplot2::mpg %>% count(year, class), "column", hcaes(class, n, group = year), id = c("y1999", "y2008")) 206 | }) 207 | 208 | observeEvent(input$remove, { 209 | 210 | highchartProxy("hc_rm") %>% 211 | hcpxy_remove_series(id = "y1999") 212 | 213 | }) 214 | 215 | # remove all series ------------------------------------------------------- 216 | output$hc_rm_all <- renderHighchart({ 217 | input$reset 218 | hchart( 219 | ggplot2::mpg %>% select(displ, cty, cyl), 220 | "scatter", 221 | hcaes(x = displ, y = cty, group = cyl) 222 | ) 223 | }) 224 | 225 | observeEvent(input$remove_all, { 226 | 227 | highchartProxy("hc_rm_all") %>% 228 | hcpxy_remove_series(all = TRUE) 229 | 230 | }) 231 | 232 | # update chart options ---------------------------------------------------- 233 | output$hc_opts <- renderHighchart({ 234 | input$reset 235 | highchart() %>% 236 | hc_title(text = "The first title") %>% 237 | hc_add_series(data = highcharter::citytemp$london, name = "London", type = "column", colorByPoint = TRUE) %>% 238 | hc_add_series(data = highcharter::citytemp$tokyo, name = "Tokio", type = "line") %>% 239 | hc_xAxis(categories = highcharter::citytemp$month) 240 | 241 | }) 242 | 243 | observeEvent(input$update1, { 244 | 245 | highchartProxy("hc_opts") %>% 246 | hcpxy_update( 247 | title = list(text = "A new title"), 248 | chart = list(inverted = FALSE, polar = FALSE), 249 | xAxis = list(gridLineWidth = 1), 250 | yAxis = list(endOnTick = FALSE) 251 | ) 252 | 253 | }) 254 | 255 | observeEvent(input$update2, { 256 | 257 | highchartProxy("hc_opts") %>% 258 | hcpxy_update( 259 | title = list(text = "I´m a polar chart"), 260 | chart = list(inverted = FALSE, polar = TRUE) 261 | ) 262 | 263 | }) 264 | 265 | # update series options --------------------------------------------------- 266 | output$hc_opts2 <- renderHighchart({ 267 | input$reset 268 | highchart() %>% 269 | hc_add_series( 270 | data = highcharter::citytemp$london, 271 | id = "london", 272 | name = "London", 273 | type = "column" 274 | # colorByPoint = TRUE 275 | ) %>% 276 | hc_add_series( 277 | data = highcharter::citytemp$tokyo, 278 | id = "tokyo", 279 | name = "Tokyo", 280 | type = "line", 281 | zIndex = 0 282 | # colorByPoint = TRUE 283 | ) %>% 284 | hc_xAxis(categories = highcharter::citytemp$month) 285 | 286 | }) 287 | 288 | observeEvent(input$update3, { 289 | 290 | highchartProxy("hc_opts2") %>% 291 | hcpxy_update_series( 292 | id = "london", 293 | data = round(highcharter::citytemp$london + rnorm(12), 1) 294 | ) 295 | 296 | }) 297 | 298 | observeEvent(input$update4, { 299 | 300 | highchartProxy("hc_opts2") %>% 301 | hcpxy_update_series( 302 | id = "london", 303 | type = sample(c('line', 'column', 'spline', 'area', 'areaspline', 'scatter', 'lollipop', 'bubble'), 1), 304 | name = paste("London ", sample(1:10, 1)), 305 | colorByPoint = sample(c(TRUE, FALSE), 1), 306 | dataLabels = list(enabled = sample(c(TRUE, FALSE), 1)) 307 | ) 308 | 309 | }) 310 | 311 | # update series options 3 ------------------------------------------------- 312 | output$hc_opts3 <- renderHighchart({ 313 | 314 | input$reset 315 | 316 | d_cut_count <- ggplot2::diamonds %>% 317 | sample_n(250) %>% 318 | count(cut) 319 | 320 | hchart( 321 | d_cut_count, 322 | "item", 323 | hcaes(name = cut, y = n), 324 | name = "Cuts", 325 | id = "serieid" 326 | ) 327 | 328 | }) 329 | 330 | observeEvent(input$item_rows, { 331 | 332 | highchartProxy("hc_opts3") %>% 333 | hcpxy_update_series( 334 | id = "serieid", 335 | rows = input$item_rows 336 | ) 337 | 338 | }) 339 | 340 | observeEvent(input$item_choice, { 341 | 342 | hcpxy <- highchartProxy("hc_opts3") 343 | 344 | if(input$item_choice == "parliment") { 345 | hcpxy %>% 346 | hcpxy_update_series( 347 | id = "serieid", 348 | center = list('50%', '88%'), 349 | size = '170%', 350 | startAngle = -100, 351 | endAngle = 100 352 | ) 353 | } else if (input$item_choice == "rectangle") { 354 | hcpxy %>% 355 | hcpxy_update_series( 356 | id = "serieid", 357 | startAngle = NULL, 358 | endAngle = NULL 359 | ) 360 | } else if (input$item_choice == "circle") { 361 | hcpxy %>% 362 | hcpxy_update_series( 363 | id = "serieid", 364 | center = list('50%', '50%'), 365 | size = '100%', 366 | startAngle = 0, 367 | endAngle = 360 368 | ) 369 | } 370 | 371 | }) 372 | # add point --------------------------------------------------------------- 373 | output$hc_addpoint <- renderHighchart({ 374 | input$reset 375 | 376 | df <- tibble::tibble( 377 | x = datetime_to_timestamp(Sys.time() - lubridate::seconds(10:1)), 378 | y = rnorm(length(x)) 379 | ) 380 | 381 | highchart() %>% 382 | hc_xAxis(type = "datetime") %>% 383 | hc_add_series(df, "line", hcaes(x, y), id = "ts", name = "A real time value") %>% 384 | hc_navigator(enabled = TRUE) 385 | 386 | }) 387 | 388 | observeEvent(input$addpoint, { 389 | 390 | highchartProxy("hc_addpoint") %>% 391 | hcpxy_add_point( 392 | id = "ts", 393 | point = list(x = datetime_to_timestamp(Sys.time()), y = rnorm(1)) 394 | ) 395 | 396 | }) 397 | 398 | observeEvent(input$addpoint_w_shift, { 399 | 400 | highchartProxy("hc_addpoint") %>% 401 | hcpxy_add_point( 402 | id = "ts", 403 | point = list(x = datetime_to_timestamp(Sys.time()), y = rnorm(1)), 404 | shift = TRUE 405 | ) 406 | 407 | }) 408 | 409 | observeEvent(input$rmpoint, { 410 | 411 | highchartProxy("hc_addpoint") %>% 412 | hcpxy_remove_point( 413 | id = "ts", 414 | i = 0 415 | ) 416 | 417 | }) 418 | 419 | # mark selected point ----------------------------------------------------- 420 | output$hc_selectpoint <- renderHighchart({ 421 | input$reset 422 | 423 | hc <- highchart() %>% 424 | hc_add_series( 425 | data.frame(x = 1:3, y = sample(1:3 + 4)), 426 | "scatter", 427 | id = "seriea", 428 | name = "First Series", 429 | hcaes(x, y) 430 | ) %>% 431 | hc_add_series( 432 | data.frame(x = 1:3, y = sample(1:3)), 433 | "scatter", 434 | id = "serieb", 435 | name = "Another Series", 436 | hcaes(x, y) 437 | ) %>% 438 | hc_title(text = NULL) 439 | hc 440 | }) 441 | 442 | observeEvent(input$action, { 443 | 444 | indx_0_based <- as.numeric(input$selectpoint) - 1 445 | 446 | highchartProxy("hc_selectpoint") %>% 447 | hcpxy_update_series(id = "seriea", selected = FALSE) %>% 448 | hcpxy_update_point( 449 | id = "seriea", 450 | id_point = indx_0_based, 451 | x = runif(1, 1, 3), 452 | y = runif(1, 1, 3), 453 | selected = sample(c(TRUE, FALSE), size = 1), 454 | marker = list( 455 | radius = sample(3:8, size = 1), 456 | fillColor = sample(c("yellow", "green", "red", "orange"), size = 1) 457 | ) 458 | ) 459 | 460 | }) 461 | 462 | } 463 | 464 | shinyApp(ui, server) 465 | -------------------------------------------------------------------------------- /02-proxy-functions/rsconnect/shinyapps.io/jbkunst/02-proxy-functions.dcf: -------------------------------------------------------------------------------- 1 | name: 02-proxy-functions 2 | title: 3 | username: 4 | account: jbkunst 5 | server: shinyapps.io 6 | hostUrl: https://api.shinyapps.io/v1 7 | appId: 4200771 8 | bundleId: 4725392 9 | url: https://jbkunst.shinyapps.io/02-proxy-functions/ 10 | when: 1623896157.33027 11 | lastSyncTime: 1623896157.33027 12 | asMultiple: FALSE 13 | asStatic: FALSE 14 | -------------------------------------------------------------------------------- /03-events-v2/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Title: Shiny Events Demo 2 | Author: Martin John Hadley, @martinjhnhadley 3 | License: MIT 4 | DisplayMode: Showcase 5 | Type: Shiny -------------------------------------------------------------------------------- /03-events-v2/Readme.md: -------------------------------------------------------------------------------- 1 | Using `hc_add_event_point` and `hc_add_event_series` it is possible extract click and mouse over events from a Highchart within a Shiny app. To extract this information from the chart, `input$` variables are created as follows: 2 | 3 | ``` 4 | paste0("highchart_output", "_", "eventType") 5 | ``` 6 | 7 | In the example app below, there are two variables added to the `input$` object: 8 | 9 | - `input$plot_hc_click` 10 | - `input$plot_hc_mouseOver` 11 | -------------------------------------------------------------------------------- /03-events-v2/app.R: -------------------------------------------------------------------------------- 1 | library(highcharter) 2 | library(shiny) 3 | 4 | shinyApp( 5 | ui = fluidPage( 6 | wellPanel("mouseOver and click points for additional information"), 7 | uiOutput("click_ui"), 8 | uiOutput("mouseOver_ui"), 9 | highchartOutput("plot_hc") 10 | ), 11 | server = function(input, output) { 12 | df <- data.frame(x = 1:5, y = 1:5, otherInfo = letters[11:15]) 13 | 14 | output$plot_hc <- renderHighchart({ 15 | highchart() %>% 16 | hc_add_series(df, "scatter") %>% 17 | hc_add_event_point(event = "click") %>% 18 | hc_add_event_point(event = "mouseOver") 19 | }) 20 | 21 | observeEvent(input$plot_hc, print(paste("plot_hc", input$plot_hc))) 22 | 23 | output$click_ui <- renderUI({ 24 | if (is.null(input$plot_hc_click)) { 25 | return() 26 | } 27 | 28 | wellPanel("Coordinates of clicked point: ", input$plot_hc_click$x, input$plot_hc_click$y) 29 | }) 30 | 31 | output$mouseOver_ui <- renderUI({ 32 | if (is.null(input$plot_hc_mouseOver)) { 33 | return() 34 | } 35 | 36 | wellPanel("Coordinates of mouseOvered point: ", input$plot_hc_mouseOver$x, input$plot_hc_mouseOver$y) 37 | }) 38 | } 39 | ) -------------------------------------------------------------------------------- /03-events-v2/rsconnect/shinyapps.io/jbkunst/03-events-v2.dcf: -------------------------------------------------------------------------------- 1 | name: 03-events-v2 2 | title: 03-events-v2 3 | username: 4 | account: jbkunst 5 | server: shinyapps.io 6 | hostUrl: https://api.shinyapps.io/v1 7 | appId: 4216321 8 | bundleId: 4666684 9 | url: https://jbkunst.shinyapps.io/03-events-v2/ 10 | when: 1622596003.43549 11 | lastSyncTime: 1622596003.43549 12 | asMultiple: FALSE 13 | asStatic: FALSE 14 | -------------------------------------------------------------------------------- /03-events/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Title: Events functions helpers 2 | Author: Joshua Kunst 3 | AuthorUrl: https://jkunst.com/ 4 | License: MIT 5 | DisplayMode: Showcase 6 | Type: Shiny -------------------------------------------------------------------------------- /03-events/Readme.md: -------------------------------------------------------------------------------- 1 | Highcharter have some helpers function to know what point is selected by the 2 | user. 3 | 4 | For example, let's say you have some app with a `renderHighcharter("chart")` in 5 | the ui. To know what point is selected you need to use `hc_add_event_point` 6 | and specify the event `"click"` or `"mouseOver"`. Then is possible check 7 | the value using `input$chart_click` or `input$chart_mouseOver` depending the 8 | type of event selected in `hc_add_event_point`. 9 | -------------------------------------------------------------------------------- /03-events/app.R: -------------------------------------------------------------------------------- 1 | library(shiny) 2 | library(shinythemes) 3 | library(highcharter) 4 | library(dplyr) 5 | 6 | options(highcharter.theme = hc_theme_smpl()) 7 | 8 | data(pokemon) 9 | 10 | pokemon <- pokemon %>% 11 | filter(id <= 151) 12 | 13 | pkmn_type_color <- pokemon %>% 14 | distinct(type_1, color_1) 15 | 16 | scales::show_col(pkmn_type_color$color_1, borders = FALSE) 17 | 18 | pokemon <- pokemon %>% 19 | mutate(type_1 = factor(type_1, levels = pull(pkmn_type_color, type_1))) %>% 20 | select(id, pokemon, attack, defense, type_1) 21 | 22 | pokemon 23 | 24 | hc <- hchart( 25 | pokemon, 26 | "scatter", 27 | hcaes(x = attack, y = defense, group = type_1, name = pokemon), 28 | color = pull(pkmn_type_color, color_1) 29 | ) 30 | 31 | hc 32 | 33 | ui <- fluidPage( 34 | theme = shinytheme("paper"), 35 | h3("Highcharter as Shiny Inputs"), 36 | fluidRow( 37 | column(6, h4("Point Event"), highchartOutput("hcpkmn")), 38 | column(3, h5("MouseOver"), verbatimTextOutput("hc_1_input1")), 39 | column(3, h5("Click"), verbatimTextOutput("hc_1_input2")) 40 | ), 41 | fluidRow( 42 | column(6, h4("Series Event"), highchartOutput("hcpkmn2")), 43 | column(3, h5("MouseOver"), verbatimTextOutput("hc_2_input1")), 44 | column(3, h6("Click"), verbatimTextOutput("hc_2_input2")) 45 | ) 46 | ) 47 | 48 | server <- function(input, output) { 49 | 50 | output$hcpkmn <- renderHighchart({ 51 | 52 | hc %>% 53 | hc_plotOptions(series = list(cursor = "pointer")) %>% 54 | hc_add_event_point(event = "mouseOver") %>% 55 | hc_add_event_point(event = "click") 56 | 57 | }) 58 | 59 | output$hc_1_input1 <- renderPrint({ input$hcpkmn_mouseOver }) 60 | 61 | output$hc_1_input2 <- renderPrint({ input$hcpkmn_click }) 62 | 63 | output$hcpkmn2 <- renderHighchart({ 64 | 65 | hc %>% 66 | hc_plotOptions(series = list(cursor = "pointer")) %>% 67 | hc_add_event_series(event = "mouseOver") %>% 68 | hc_add_event_series(event = "click") 69 | 70 | }) 71 | 72 | output$hc_2_input1 <- renderPrint({ input$hcpkmn2_mouseOver }) 73 | 74 | output$hc_2_input2 <- renderPrint({ input$hcpkmn2_click }) 75 | 76 | } 77 | 78 | shinyApp(ui = ui, server = server) 79 | 80 | 81 | -------------------------------------------------------------------------------- /03-events/rsconnect/shinyapps.io/jbkunst/03-events.dcf: -------------------------------------------------------------------------------- 1 | name: 03-events 2 | title: 03-events 3 | username: 4 | account: jbkunst 5 | server: shinyapps.io 6 | hostUrl: https://api.shinyapps.io/v1 7 | appId: 4204424 8 | bundleId: 4661894 9 | url: https://jbkunst.shinyapps.io/03-events/ 10 | when: 1622490463.81778 11 | lastSyncTime: 1622490463.81778 12 | asMultiple: FALSE 13 | asStatic: FALSE 14 | -------------------------------------------------------------------------------- /04-shinydashboard-n-spakrlines/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Title: Highcharter widgets in valueBoxes 2 | Author: Joshua Kunst 3 | AuthorUrl: https://jkunst.com/ 4 | License: MIT 5 | DisplayMode: Showcase 6 | Type: Shiny -------------------------------------------------------------------------------- /04-shinydashboard-n-spakrlines/Readme.md: -------------------------------------------------------------------------------- 1 | This is an example showing how highcharter widgets can be put inside in a 2 | valueBoxes from the packages shinydashboard or bs4dash. You can see more details 3 | in https://jkunst.com/blog/posts/2020-06-26-valuebox-and-sparklines/. 4 | 5 | -------------------------------------------------------------------------------- /04-shinydashboard-n-spakrlines/global.R: -------------------------------------------------------------------------------- 1 | library(shiny) 2 | library(shinydashboard) 3 | library(highcharter) 4 | library(shinyjs) 5 | 6 | set.seed(123) 7 | 8 | N <- 20 9 | 10 | x <- cumsum(rnorm(N)) + 0.5 * cumsum(runif(N)) 11 | x <- round(200*x) 12 | 13 | df <- data.frame( 14 | x = sort(as.Date(Sys.time() - lubridate::days(1:N))), 15 | y = abs(x) 16 | ) 17 | 18 | valueBoxSpark <- function(value, title, sparkobj = NULL, subtitle, info = NULL, 19 | icon = NULL, color = "aqua", width = 4, href = NULL){ 20 | 21 | shinydashboard:::validateColor(color) 22 | 23 | if (!is.null(icon)) 24 | shinydashboard:::tagAssert(icon, type = "i") 25 | 26 | info_icon <- tags$small( 27 | tags$i( 28 | class = "fa fa-info-circle fa-lg", 29 | title = info, 30 | `data-toggle` = "tooltip", 31 | style = "color: rgba(255, 255, 255, 0.75);" 32 | ), 33 | # bs3 pull-right 34 | # bs4 float-right 35 | class = "pull-right float-right" 36 | ) 37 | 38 | boxContent <- div( 39 | class = paste0("small-box bg-", color), 40 | div( 41 | class = "inner", 42 | tags$small(title), 43 | if (!is.null(sparkobj)) info_icon, 44 | h3(value), 45 | if (!is.null(sparkobj)) sparkobj, 46 | p(subtitle) 47 | ), 48 | # bs3 icon-large 49 | # bs4 icon 50 | if (!is.null(icon)) div(class = "icon-large icon", icon, style = "z-index; 0") 51 | ) 52 | 53 | if (!is.null(href)) 54 | boxContent <- a(href = href, boxContent) 55 | 56 | div( 57 | class = if (!is.null(width)) paste0("col-sm-", width), 58 | boxContent 59 | ) 60 | } 61 | -------------------------------------------------------------------------------- /04-shinydashboard-n-spakrlines/rsconnect/shinyapps.io/jbkunst/04-shinydashboard-n-spakrlines.dcf: -------------------------------------------------------------------------------- 1 | name: 04-shinydashboard-n-spakrlines 2 | title: 3 | username: 4 | account: jbkunst 5 | server: shinyapps.io 6 | hostUrl: https://api.shinyapps.io/v1 7 | appId: 4204460 8 | bundleId: 4655723 9 | url: https://jbkunst.shinyapps.io/04-shinydashboard-n-spakrlines/ 10 | when: 1622335594.88708 11 | lastSyncTime: 1622335594.88708 12 | -------------------------------------------------------------------------------- /04-shinydashboard-n-spakrlines/server.R: -------------------------------------------------------------------------------- 1 | shinyServer(function(input, output, session) { 2 | 3 | output$vbox <- renderValueBox({ 4 | 5 | hc <- hchart(df, "area", hcaes(x, y), name = "lines of code") %>% 6 | hc_size(height = 100) %>% 7 | hc_credits(enabled = FALSE) %>% 8 | hc_add_theme(hc_theme_sparkline_vb()) 9 | 10 | valueBoxSpark( 11 | value = "1,345", 12 | title = toupper("Lines of code written"), 13 | sparkobj = hc, 14 | subtitle = tagList(HTML("↑"), "25% Since last day"), 15 | info = "This is the lines of code I've written in the past 20 days! That's a lot, right?", 16 | icon = icon("code"), 17 | width = 4, 18 | color = "teal", 19 | href = NULL 20 | ) 21 | 22 | 23 | }) 24 | 25 | output$vbox2 <- renderValueBox({ 26 | 27 | hc2 <- hchart(df, "line", hcaes(x, y), name = "Distance") %>% 28 | hc_size(height = 100) %>% 29 | hc_credits(enabled = FALSE) %>% 30 | hc_add_theme(hc_theme_sparkline_vb()) 31 | 32 | valueBoxSpark( 33 | value = "1,345 KM", 34 | title = toupper("Distance Traveled"), 35 | sparkobj = hc2, 36 | subtitle = tagList(HTML("↑"), "25% Since last month"), 37 | info = "This is the lines of code I've written in the past 20 days! That's a lot, right?", 38 | icon = icon("plane"), 39 | width = 4, 40 | color = "red", 41 | href = NULL 42 | ) 43 | 44 | }) 45 | 46 | output$vbox3 <- renderValueBox({ 47 | 48 | hc3 <- hchart(df, "column", hcaes(x, y), name = "Daily amount") %>% 49 | hc_size(height = 100) %>% 50 | hc_credits(enabled = FALSE) %>% 51 | hc_add_theme(hc_theme_sparkline_vb()) 52 | 53 | valueBoxSpark( 54 | value = "1,3 Hrs.", 55 | title = toupper("Thinking time"), 56 | sparkobj = hc3, 57 | subtitle = tagList(HTML("↑"), "5% Since last year"), 58 | info = "This is the lines of code I've written in the past 20 days! That's a lot, right?", 59 | icon = icon("hourglass-half"), 60 | width = 4, 61 | color = "yellow", 62 | href = NULL 63 | ) 64 | 65 | 66 | }) 67 | 68 | output$chart1 <- renderHighchart({ 69 | 70 | highcharts_demo() %>% 71 | hc_add_theme(hc_theme_hcrt()) 72 | 73 | }) 74 | 75 | output$chart2 <- renderHighchart({ 76 | 77 | highcharts_demo() %>% 78 | hc_add_theme(hc_theme_smpl()) 79 | 80 | }) 81 | 82 | }) -------------------------------------------------------------------------------- /04-shinydashboard-n-spakrlines/ui.R: -------------------------------------------------------------------------------- 1 | dashboardPage( 2 | dashboardHeader(), 3 | dashboardSidebar(collapsed = TRUE), 4 | dashboardBody( 5 | fluidRow( 6 | valueBoxOutput("vbox"), 7 | valueBoxOutput("vbox2"), 8 | valueBoxOutput("vbox3"), 9 | 10 | box(highchartOutput("chart1")), 11 | box(highchartOutput("chart2")) 12 | 13 | ) 14 | ) 15 | ) -------------------------------------------------------------------------------- /05-arma/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Title: ARMA model simulation 2 | Author: Joshua Kunst 3 | AuthorUrl: https://jkunst.com/ 4 | License: MIT 5 | DisplayMode: Showcase 6 | Type: Shiny -------------------------------------------------------------------------------- /05-arma/Readme.md: -------------------------------------------------------------------------------- 1 | This is a good example how shiny with highcharter can be used in a learning 2 | enviorment. The app show how a time series model is generated point by point 3 | given the parameters. -------------------------------------------------------------------------------- /05-arma/app.R: -------------------------------------------------------------------------------- 1 | library(shiny) 2 | library(shinythemes) 3 | library(highcharter) 4 | library(stats) 5 | 6 | options(highcharter.theme = hc_theme_smpl()) 7 | 8 | LAG_MAX <- 10 9 | STR_OBS <- 20 10 | NOBS <- 5000 11 | AR <- 0.75 12 | MA <- 0.20 13 | SEED <- 123 14 | DURATION <- 100 # needs to be <= than min refresh interval 15 | 16 | # start chart 17 | set.seed(SEED) 18 | 19 | ts_aux <- arima.sim(model = list(ar = AR, ma = MA), n = STR_OBS) 20 | 21 | teoACF <- as.numeric(ARMAacf(ar = AR, ma = MA, lag.max = LAG_MAX, pacf = FALSE)) 22 | smpACF <- as.numeric(acf(ts_aux, lag.max = LAG_MAX, plot = FALSE)$acf) 23 | 24 | hc_afc <- highchart() %>% 25 | hc_chart(type = "column") %>% 26 | hc_yAxis(min = -1, max = 1) %>% 27 | hc_add_series(data = smpACF, id = "sacf", name = "Estimated", color = "#428bca") %>% 28 | hc_add_series(data = teoACF, id = "tacf", name = "Theoretical") %>% 29 | hc_tooltip( 30 | table = TRUE, 31 | headerFormat = "Lag {point.key}", 32 | valueDecimals = 3 33 | ) %>% 34 | hc_plotOptions( 35 | series = list( 36 | pointWidth = 5, 37 | animation = list(duration = DURATION), 38 | marker = list(symbol = "circle") 39 | ) 40 | ) 41 | 42 | hc_afc 43 | 44 | ui <- fluidPage( 45 | theme = shinytheme("paper"), 46 | fluidRow( 47 | column(12, tags$h3("ARMA model simulation")) 48 | ), 49 | fluidRow( 50 | column(4, sliderInput("ar", "AR", -.9, .9, value = AR, 0.05, width = "100%")), 51 | column(4, sliderInput("ma", "MA", -.9, .9, value = MA, 0.05, width = "100%")), 52 | column(4, sliderInput("interval", "Refresh (secs.)", 0.5, 2, value = 1, step = 0.5, width = "100%")), 53 | ), 54 | fluidRow( 55 | column(12, uiOutput("model")) 56 | ), 57 | fluidRow( 58 | column(8, highchartOutput("ts")), 59 | column(4, highchartOutput("acf")) 60 | ) 61 | ) 62 | 63 | server <- function(input, output, session) { 64 | 65 | value <- reactiveVal(STR_OBS) 66 | 67 | ts <- reactive({ 68 | 69 | value(STR_OBS) 70 | 71 | # input <- list(ar = 0.9, ma = 0.1, nobs = 200) 72 | set.seed(SEED) 73 | ts <- arima.sim(model = list(ar = input$ar, ma = input$ma), n = NOBS) 74 | 75 | }) 76 | 77 | output$model <- renderUI({ 78 | 79 | arp <- ifelse(input$ar != 0, paste0(input$ar, " \\times X_{t-1}"), "") 80 | map <- ifelse(input$ma != 0, paste0(" + ", input$ma, " \\times \\epsilon_{t-1}"), "") 81 | 82 | mod <- paste0("X_{t} = ", arp, ifelse(input$ar != 0, " + ", ""), "\\epsilon_t", map) 83 | mod <- paste0("$$", mod, "$$") 84 | 85 | tags$p(withMathJax(mod)) 86 | 87 | }) 88 | 89 | output$ts <- renderHighchart({ 90 | 91 | ts <- ts() 92 | 93 | df <- data.frame(x = 1:STR_OBS, y = head(ts, STR_OBS)) 94 | 95 | hchart( 96 | df, "line", 97 | id = "ts", 98 | color = "#428bca", 99 | name = "Time series", 100 | marker = list(enabled = FALSE), 101 | animation = list(duration = DURATION), 102 | tooltip = list(valueDecimals = 3) 103 | ) %>% 104 | hc_navigator( 105 | enabled = TRUE, 106 | series = list(type = "line"), 107 | xAxis = list(labels = list(enabled = FALSE)) 108 | ) %>% 109 | hc_yAxis_multiples( 110 | # default axis 111 | list(title = list(text = "")), 112 | list( 113 | title = list(text = ""), 114 | linkedTo = 0, 115 | opposite = TRUE, 116 | tickPositioner = JS("function(min,max){ 117 | var data = this.chart.yAxis[0].series[0].processedYData; 118 | //last point 119 | return [Math.round(1000 * data[data.length-1])/1000]; 120 | }") 121 | ) 122 | ) 123 | 124 | }) 125 | 126 | output$acf <- renderHighchart({ 127 | 128 | hc_afc 129 | 130 | }) 131 | 132 | observeEvent(ts(), { 133 | 134 | # if ts change redraw the teo ACF 135 | ts <- ts() 136 | 137 | teoACF <- as.numeric(ARMAacf(ar = input$ar, ma = input$ma, lag.max = LAG_MAX, pacf = FALSE)) 138 | 139 | smpACF <- as.numeric(acf(head(ts, STR_OBS), lag.max = LAG_MAX, plot = FALSE)$acf) 140 | 141 | highchartProxy("acf") %>% 142 | hcpxy_update_series(id = "tacf", data = teoACF) %>% 143 | hcpxy_update_series(id = "sacf", data = smpACF) 144 | 145 | }) 146 | 147 | observe({ 148 | 149 | interval <- max(as.numeric(input$interval), 0.25) 150 | 151 | invalidateLater(1000 * interval, session) 152 | 153 | # animation <- ifelse(interval < 0.5, FALSE, TRUE) 154 | animation <- TRUE 155 | 156 | value_to_add <- isolate(value()) + 1 157 | 158 | value(value_to_add) 159 | 160 | ts <- ts() 161 | 162 | smpACF <- as.numeric(acf(head(ts, value_to_add), lag.max = LAG_MAX, plot = FALSE)$acf) 163 | 164 | highchartProxy("acf") %>% 165 | hcpxy_update_series(id = "sacf", data = smpACF) 166 | 167 | highchartProxy("ts") %>% 168 | hcpxy_add_point(id = "ts", point = list(x = value_to_add, y = ts[value_to_add]), animation = animation) 169 | 170 | }) 171 | 172 | } 173 | 174 | # Run the application 175 | shinyApp(ui = ui, server = server) 176 | -------------------------------------------------------------------------------- /05-arma/rsconnect/shinyapps.io/jbkunst/05-arma.dcf: -------------------------------------------------------------------------------- 1 | name: 05-arma 2 | title: 3 | username: 4 | account: jbkunst 5 | server: shinyapps.io 6 | hostUrl: https://api.shinyapps.io/v1 7 | appId: 2712465 8 | bundleId: 4661402 9 | url: https://jbkunst.shinyapps.io/05-arma/ 10 | when: 1622478555.44005 11 | lastSyncTime: 1622478555.44005 12 | asMultiple: FALSE 13 | asStatic: FALSE 14 | -------------------------------------------------------------------------------- /06-maps-performance/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Title: Improving a map performance 2 | Author: Joshua Kunst 3 | AuthorUrl: http://jkunst.com 4 | License: GPL-3 5 | DisplayMode: Showcase 6 | -------------------------------------------------------------------------------- /06-maps-performance/Readme.md: -------------------------------------------------------------------------------- 1 | This app show how use the highcharts map collections in an efficient way. This 2 | is preloading the map using the highchart predefined maps. For example 3 | this example uses a high resolution map which is loaded one time. To do this 4 | you need use the `tags$script(stc = link_to_map)` in your user interface 5 | definition. 6 | 7 | ```r 8 | tags$script(src = "https://code.highcharts.com/mapdata/custom/world-robinson-highres.js") 9 | ``` 10 | 11 | Then, in your server: 12 | 13 | ```r 14 | mapdata <- JS("Highcharts.maps['custom/world-robinson-highres']") 15 | 16 | highchart(type = "map") %>% 17 | hc_add_series(mapData = mapdata, data = data, joinBy = c("hc-key")) 18 | ``` 19 | 20 | You can see other predefined maps in https://code.highcharts.com/mapdata/. -------------------------------------------------------------------------------- /06-maps-performance/app.R: -------------------------------------------------------------------------------- 1 | library(shiny) 2 | library(shinythemes) 3 | library(highcharter) 4 | library(dplyr) 5 | 6 | geojson <- download_map_data("custom/world-robinson-highres") 7 | 8 | data <- get_data_from_map(geojson) %>% 9 | select(`hc-key`) 10 | 11 | ui <- fluidPage( 12 | theme = shinytheme("paper"), 13 | tags$script(src = "https://code.highcharts.com/mapdata/custom/world-robinson-highres.js"), 14 | fluidRow( 15 | tags$hr(), 16 | column( 17 | 12, 18 | selectInput("sel", NULL, c("Preloaded map" = "preload", "Sending map" = "send")), 19 | actionButton("action", "Generate map") 20 | ), 21 | tags$hr(), 22 | column(12, highchartOutput("hcmap")) 23 | ) 24 | ) 25 | 26 | server <- function(input, output) { 27 | 28 | output$hcmap <- renderHighchart({ 29 | 30 | input$action 31 | 32 | data <- mutate(data, value = round(100 * runif(nrow(data)), 2)) 33 | 34 | if(input$sel == "preload") { 35 | mapdata <- JS("Highcharts.maps['custom/world-robinson-highres']") 36 | } else { 37 | mapdata <- geojson 38 | } 39 | 40 | highchart(type = "map") %>% 41 | hc_add_series( 42 | mapData = mapdata, 43 | data = data, 44 | joinBy = c("hc-key"), 45 | borderWidth = 0 46 | ) %>% 47 | hc_chart(zoomType = "xy") %>% 48 | hc_colorAxis(stops = color_stops()) 49 | 50 | }) 51 | 52 | } 53 | 54 | shinyApp(ui, server) -------------------------------------------------------------------------------- /06-maps-performance/rsconnect/shinyapps.io/jbkunst/06-maps-performance.dcf: -------------------------------------------------------------------------------- 1 | name: 06-maps-performance 2 | title: 3 | username: 4 | account: jbkunst 5 | server: shinyapps.io 6 | hostUrl: https://api.shinyapps.io/v1 7 | appId: 4204516 8 | bundleId: 4655728 9 | url: https://jbkunst.shinyapps.io/06-maps-performance/ 10 | when: 1622335750.00112 11 | lastSyncTime: 1622335750.00112 12 | -------------------------------------------------------------------------------- /07-nyt-temp/.gitignore: -------------------------------------------------------------------------------- 1 | # History files 2 | .Rhistory 3 | .Rapp.history 4 | 5 | # Session Data files 6 | .RData 7 | 8 | # Example code in package build process 9 | *-Ex.R 10 | 11 | # Output files from R CMD build 12 | /*.tar.gz 13 | 14 | # Output files from R CMD check 15 | /*.Rcheck/ 16 | 17 | # RStudio files 18 | .Rproj.user/ 19 | 20 | # produced vignettes 21 | vignettes/*.html 22 | vignettes/*.pdf 23 | 24 | # OAuth2 token, see https://github.com/hadley/httr/releases/tag/v0.3 25 | .httr-oauth 26 | 27 | # knitr and R markdown default cache directories 28 | /*_cache/ 29 | /cache/ 30 | 31 | # Temporary files created by R markdown 32 | *.utf8.md 33 | *.knit.md 34 | .Rproj.user 35 | -------------------------------------------------------------------------------- /07-nyt-temp/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Title: NYTimes temperature app 2 | Author: Joshua Kunst 3 | AuthorUrl: https://jkunst.com/ 4 | License: MIT 5 | DisplayMode: Showcase 6 | Type: Shiny -------------------------------------------------------------------------------- /07-nyt-temp/LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2016 Joshua Kunst 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /07-nyt-temp/Readme.md: -------------------------------------------------------------------------------- 1 | This app show the flexibility of higcharts and highcharter. This application 2 | is inspired ~almost copied~ from NYTimes: 3 | [_How Much Warmer Was Your City in 2015?_](http://www.nytimes.com/interactive/2016/02/19/us/2015-year-in-weather-temperature-precipitation.html). For weather radials, 4 | inspiration comes from [weather-radials.com](http://www.weather-radials.com/). -------------------------------------------------------------------------------- /07-nyt-temp/global.R: -------------------------------------------------------------------------------- 1 | library(shiny) 2 | library(shinythemes) 3 | library(highcharter) 4 | library(readr) 5 | library(dplyr) 6 | library(tidyr) 7 | library(stringr) 8 | library(forcats) 9 | library(purrr) 10 | library(rmarkdown) 11 | 12 | options(highcharter.theme = hc_theme_smpl()) 13 | 14 | langs <- getOption("highcharter.lang") 15 | langs$loading <- "" 16 | options(highcharter.lang = langs) 17 | 18 | url_base <- "http://graphics8.nytimes.com/newsgraphics/2016/01/01/weather" 19 | 20 | cities <- file.path(url_base, "656641daa55247f6c606970a6b7e702e3fd4dcb8/cities_loc_new.csv") %>% 21 | read_csv( 22 | col_types = cols( 23 | station = col_character(), 24 | state_fullname = col_character(), 25 | name = col_character(), 26 | state = col_character(), 27 | latitude = col_double(), 28 | longitude = col_double(), 29 | id = col_character() 30 | ) 31 | ) %>% 32 | sample_frac(1) %>% 33 | mutate(text = paste0(name, ", ", state)) 34 | 35 | citiesv <- setNames(cities$id, cities$text) 36 | -------------------------------------------------------------------------------- /07-nyt-temp/nyt-temp.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | -------------------------------------------------------------------------------- /07-nyt-temp/rsconnect/shinyapps.io/jbkunst/07-nyt-temp.dcf: -------------------------------------------------------------------------------- 1 | name: 07-nyt-temp 2 | title: 3 | username: 4 | account: jbkunst 5 | server: shinyapps.io 6 | hostUrl: https://api.shinyapps.io/v1 7 | appId: 4204521 8 | bundleId: 4655732 9 | url: https://jbkunst.shinyapps.io/07-nyt-temp/ 10 | when: 1622335824.59838 11 | lastSyncTime: 1622335824.59838 12 | -------------------------------------------------------------------------------- /07-nyt-temp/server.R: -------------------------------------------------------------------------------- 1 | # input <- list(city = sample(citiesv, 1)) 2 | shinyServer(function(input, output) { 3 | 4 | data <- reactive({ 5 | 6 | highchartProxy("hc1") %>% 7 | hcpxy_loading(action = "show") 8 | 9 | highchartProxy("hc2") %>% 10 | hcpxy_loading(action = "show") 11 | 12 | url_file <- file.path(url_base, "assets", sprintf("%s.csv", input$city)) 13 | 14 | # url_file <- "http://graphics8.nytimes.com/newsgraphics/2016/01/01/weather/assets/new-york_ny.csv" 15 | message(url_file) 16 | 17 | data <- read_csv( 18 | url_file, 19 | col_types = cols( 20 | date = col_date(format = ""), 21 | month = col_double(), 22 | temp_max = col_double(), 23 | temp_min = col_double(), 24 | temp_rec_max = col_logical(), 25 | temp_rec_min = col_logical(), 26 | temp_avg_max = col_double(), 27 | temp_avg_min = col_double(), 28 | temp_rec_high = col_logical(), 29 | temp_rec_low = col_logical(), 30 | precip_value = col_double(), 31 | precip_actual = col_double(), 32 | precip_normal = col_double(), 33 | precip_rec = col_character(), 34 | snow_rec = col_character(), 35 | annual_average_temperature = col_double(), 36 | departure_from_normal = col_double(), 37 | total_precipitation = col_double(), 38 | precipitation_departure_from_normal = col_double() 39 | ) 40 | ) %>% 41 | mutate(dt = datetime_to_timestamp(date)) 42 | 43 | data 44 | 45 | }) 46 | 47 | temps <- reactive({ 48 | 49 | data <- data() 50 | 51 | dtempgather <- data %>% 52 | select(dt, date, starts_with("temp")) %>% 53 | select(-temp_rec_high, -temp_rec_low) %>% 54 | rename(temp_actual_max = temp_max, 55 | temp_actual_min = temp_min) %>% 56 | gather(key, value, -date, -dt) %>% 57 | mutate(key = str_replace(key, "temp_", ""), 58 | value = as.numeric(value)) 59 | 60 | dtempspread <- dtempgather %>% 61 | separate(key, c("serie", "type"), sep = "_") %>% 62 | spread(type, value) %>% 63 | filter(!is.na(max) | !is.na(min)) 64 | 65 | temps <- dtempspread %>% 66 | mutate(serie = factor(serie, levels = c("rec", "avg", "actual")), 67 | serie = fct_recode(serie, Record = "rec", Normal = "avg", Observed = "actual")) 68 | 69 | temps 70 | 71 | }) 72 | 73 | records <- reactive({ 74 | 75 | data <- data() 76 | 77 | records <- data %>% 78 | select(dt, date, temp_rec_high, temp_rec_low) %>% 79 | filter(temp_rec_high != "NULL" | temp_rec_low != "NULL") %>% 80 | mutate_if(is.character, str_extract, "\\d+") %>% 81 | mutate_if(is.character, as.numeric) %>% 82 | gather(type, value, -date, -dt) %>% 83 | filter(!is.na(value)) %>% 84 | mutate(type = str_replace(type, "temp_rec_", ""), 85 | type = paste("This year record", type)) 86 | 87 | records 88 | 89 | }) 90 | 91 | precip_day <- reactive({ 92 | 93 | data <- data() 94 | 95 | precip_day <- data %>% 96 | mutate(temp_day = temp_min + (temp_max - temp_min)/2) %>% 97 | select(date, dt, temp_day, month, precip_value) %>% 98 | group_by(month) %>% 99 | mutate(precip_day = c(0, diff(precip_value))) %>% 100 | ungroup() %>% 101 | filter(precip_day > 0 | row_number() == 1 | row_number() == n()) 102 | 103 | precip_day 104 | 105 | }) 106 | 107 | precip <- reactive({ 108 | 109 | data <- data() 110 | 111 | precip <- select(data, dt, date, precip_value, month) 112 | 113 | precip 114 | 115 | }) 116 | 117 | precipnormal <- reactive({ 118 | 119 | data <- data() 120 | 121 | precipnormal <- data %>% 122 | select(date, dt, precip_normal, month) %>% 123 | group_by(month) %>% 124 | filter(row_number() %in% c(1, n())) %>% 125 | ungroup() %>% 126 | fill(precip_normal) 127 | 128 | precipnormal 129 | 130 | }) 131 | 132 | output$hc1 <- renderHighchart({ 133 | 134 | temps <- temps() 135 | records <- records() 136 | precip <- precip() 137 | precipnormal <- precipnormal() 138 | precip_day <- precip_day() 139 | 140 | hc <- highchart() %>% 141 | hc_xAxis(type = "datetime", showLastLabel = FALSE, 142 | dateTimeLabelFormats = list(month = "%B")) %>% 143 | hc_tooltip(shared = TRUE, useHTML = TRUE, 144 | headerFormat = as.character(tags$small("{point.x: %b %d}", tags$br()))) %>% 145 | hc_plotOptions(series = list(borderWidth = 0, pointWidth = 4)) 146 | 147 | colors <- c("#ECEBE3", "#C8B8B9", "#A90048") 148 | colors <- colors[which(levels(temps$serie) %in% unique(temps$serie))] 149 | 150 | hc <- hc %>% 151 | hc_add_series(temps, type = "columnrange", 152 | hcaes(dt, low = min, high = max, group = serie), 153 | color = colors) 154 | 155 | if(nrow(records) > 0) { 156 | 157 | pointsyles <- list( 158 | symbol = "circle", 159 | lineWidth= 1, 160 | radius= 4, 161 | fillColor= "#FFFFFF", 162 | lineColor= NULL 163 | ) 164 | 165 | hc <- hc %>% 166 | hc_add_series(records, "point", hcaes(x = dt, y = value, group = type), 167 | marker = pointsyles) 168 | } 169 | 170 | axis <- create_yaxis( 171 | naxis = 2, 172 | heights = c(3,1), 173 | sep = 0.05, 174 | turnopposite = FALSE, 175 | showLastLabel = FALSE, 176 | startOnTick = FALSE) 177 | 178 | axis[[1]]$title <- list(text = "Temperature") 179 | axis[[1]]$labels <- list(format = "{value}°F") 180 | 181 | axis[[2]]$title <- list(text = "Precipitation") 182 | axis[[2]]$min <- 0 183 | 184 | hc <- hc_yAxis_multiples(hc, axis) 185 | 186 | hc <- hc %>% 187 | hc_add_series(precip, type = "area", hcaes(dt, precip_value, group = month), 188 | name = "Precipitation", color = "#008ED0", lineWidth = 1, 189 | yAxis = 1, fillColor = "#EBEAE2", 190 | id = c("p", rep(NA, 11)), linkedTo = c(NA, rep("p", 11))) %>% 191 | hc_add_series(precipnormal, "line", hcaes(x = dt, y = precip_normal, group = month), 192 | name = "Normal Precipitation", color = "#008ED0", yAxis = 1, 193 | id = c("np", rep(NA, 11)), linkedTo = c(NA, rep("np", 11)), 194 | lineWidth = 1) 195 | 196 | hc 197 | 198 | }) 199 | 200 | output$hc2 <- renderHighchart({ 201 | 202 | temps <- temps() 203 | precip_day <- precip_day() 204 | 205 | temps1 <- filter(temps, serie == "Observed") 206 | temps2 <- filter(temps, serie != "Observed") 207 | 208 | colors <- c("#ECEBE3", "#C8B8B9") 209 | colors <- colors[which(levels(temps2$serie) %in% unique(temps2$serie))] 210 | colors <- hex_to_rgba(colors, 0.9) 211 | 212 | hchart(temps2, "columnrange", hcaes(date, low = min, high = max, group = serie), 213 | color = colors) %>% 214 | hc_add_series(temps1, "columnrange", hcaes(date, low = min, high = max, color = max), 215 | name = "Observed", color = "#FCAF13") %>% 216 | hc_add_series(precip_day, "line", hcaes(dt, y = temp_day, size = precip_day), 217 | name = "precipitation", 218 | zIndex = 4, color = hex_to_rgba("#008ED0", 0.2), lineWidth = 0, 219 | marker = list(radius = 8)) %>% 220 | hc_chart(polar = TRUE) %>% 221 | hc_plotOptions(series = list(borderWidth = 0, pointWidth = 0.01)) %>% 222 | hc_yAxis(endOnTick = FALSE, showFirstLabel = FALSE, showLastLabel = FALSE) %>% 223 | hc_xAxis(type = "datetime", showLastLabel = FALSE, 224 | dateTimeLabelFormats = list(month = "%B")) %>% 225 | hc_tooltip(shared = TRUE, useHTML = TRUE, 226 | headerFormat = as.character(tags$small("{point.x: %b %d}", tags$br()))) 227 | 228 | }) 229 | 230 | }) 231 | -------------------------------------------------------------------------------- /07-nyt-temp/ui.R: -------------------------------------------------------------------------------- 1 | shinyUI( 2 | fluidPage( 3 | theme = shinytheme("paper"), 4 | tags$br(), 5 | fluidRow( 6 | column(4, offset = 4, selectInput("city", NULL, choices = citiesv, selectize = TRUE, width = "100%")) 7 | ), 8 | fluidRow( 9 | column(7, highchartOutput("hc1", height = 600)), 10 | column(5, highchartOutput("hc2", height = 600)) 11 | ) 12 | ) 13 | ) 14 | -------------------------------------------------------------------------------- /08-idb-viz/.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | 6 | 7 | data/ -------------------------------------------------------------------------------- /08-idb-viz/README.md: -------------------------------------------------------------------------------- 1 | Hola -------------------------------------------------------------------------------- /08-idb-viz/countries.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/highcharter-shiny/d16a3dbff568a2270515f66d285e8eb58c200c48/08-idb-viz/countries.rds -------------------------------------------------------------------------------- /08-idb-viz/download_data.R: -------------------------------------------------------------------------------- 1 | library(tidyverse) 2 | library(idbr) 3 | library(countrycode) 4 | idb_api_key("35f116582d5a89d11a47c7ffbfc2ba309133f09d") 5 | 6 | library(idbr) 7 | data(variables5, package = "idbr") 8 | data(codelist, package = "countrycode") 9 | 10 | YRS <- 1990:2050 11 | 12 | codelist <- tbl_df(codelist) 13 | codelist 14 | 15 | iso2c <- as.character(na.omit(codelist$iso2c)) 16 | 17 | iso2c_valid <- map_chr(sample(iso2c), function(x){ # x <- "AL" 18 | message(x) 19 | try({ 20 | get_idb(x, year = 1990) 21 | return(x) 22 | }) 23 | }) 24 | 25 | iso2c_valid <- iso2c_valid[nchar(iso2c_valid) == 2] 26 | 27 | codelist %>% 28 | select(-starts_with("cldr"), -starts_with("un")) %>% 29 | glimpse() 30 | 31 | countries <- codelist %>% 32 | filter(iso2c %in% iso2c_valid) %>% 33 | select(iso2c, iso3c, country = country.name.en) 34 | 35 | saveRDS(countries, here::here("08-idb-viz/countries.rds")) 36 | -------------------------------------------------------------------------------- /08-idb-viz/global.R: -------------------------------------------------------------------------------- 1 | # packages ---------------------------------------------------------------- 2 | library(shiny) 3 | library(shinydashboard) 4 | library(tidyverse) 5 | library(highcharter) 6 | library(htmltools) 7 | library(shinyWidgets) 8 | library(idbr) 9 | 10 | # parameters & helpers ---------------------------------------------------- 11 | idb_api_key("35f116582d5a89d11a47c7ffbfc2ba309133f09d") 12 | 13 | langs <- getOption("highcharter.lang") 14 | 15 | langs$loading <- "" 16 | 17 | options(highcharter.lang = langs) 18 | 19 | options(highcharter.theme = hc_theme_smpl()) 20 | 21 | countries <- readRDS("countries.rds") 22 | 23 | opts <- countries %>% 24 | sample_frac(1) %>% 25 | select(country, iso2c) %>% 26 | deframe() 27 | 28 | BRKS <- seq(0, 100, length.out = 10 + 1) 29 | YRS <- seq(1985, 2025, by = 1) 30 | 31 | data_from_fips <- function(iso2 = "CL") { 32 | 33 | data <- get_idb( 34 | iso2, 35 | year = YRS, 36 | age = 1:100, 37 | # variables = c("AGE", "POP"), 38 | sex = c("both") 39 | ) 40 | 41 | datag <- data %>% 42 | mutate(agec = cut(age, breaks = BRKS, include.lowest = TRUE)) %>% 43 | group_by(year, agec) %>% 44 | summarise( 45 | pop = sum(pop), 46 | age_median = round(median(age)), 47 | .groups = "drop" 48 | ) %>% 49 | ungroup() %>% 50 | arrange(desc(age_median)) %>% 51 | mutate( 52 | birth_year = year - age_median, 53 | agec = fct_inorder(agec) 54 | ) %>% 55 | select(year, pop, agec, age_median) %>% 56 | arrange(year, age_median) %>% 57 | mutate( 58 | agec = fct_inorder(agec), 59 | agec = fct_rev(agec) 60 | ) 61 | 62 | # datag %>% count(agec) 63 | 64 | datag <- datag %>% 65 | select(x = year, y = pop, agec) 66 | 67 | datag 68 | 69 | } 70 | 71 | dstart <- data_from_fips() 72 | 73 | COLORS <- viridisLite::inferno(length(BRKS) - 1, begin = 0.1, end = .9) %>% 74 | hex_to_rgba() %>% 75 | rev() 76 | 77 | COLORS <- dstart %>% 78 | distinct(agec) %>% 79 | mutate(color = COLORS) %>% 80 | deframe() 81 | 82 | hc <- hchart(dstart, "area", hcaes(x = x, y = y, group = agec)) %>% 83 | hc_colors(as.character(rev(COLORS))) %>% 84 | hc_xAxis( 85 | title = list(text = "Year"), 86 | crosshair = list(color = "yellow", label = list(enabled = TRUE, format = "{value}")) 87 | ) %>% 88 | hc_yAxis( 89 | title = list(text = "Population"), 90 | crosshair = list(label = list(enabled = TRUE, format = "{value:,.0f}")) 91 | ) %>% 92 | hc_plotOptions( 93 | series = list( 94 | showInLegend = FALSE, 95 | stacking = "normal", 96 | lineColor = "white", 97 | lineWidth = 0.5, 98 | # pointStart = min(YRS), 99 | # pointInterval = unique(diff(YRS)), 100 | marker = list(symbol = "circle", size = 0.1, enabled = FALSE, lineWidth = 0) 101 | ) 102 | ) %>% 103 | hc_add_event_series(event = "mouseOver") 104 | 105 | hc 106 | 107 | dstart2 <- dstart %>% 108 | filter(agec == "[0,10]") %>% 109 | select(-agec) 110 | 111 | hc_agec <- hchart(dstart2, "line", hcaes(x = x, y = y), id = 0) %>% 112 | hc_xAxis(title = list(text = "Year")) %>% 113 | hc_yAxis(title = list(text = "Population"), min = 0) 114 | 115 | hc_agec 116 | -------------------------------------------------------------------------------- /08-idb-viz/idb-viz.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | -------------------------------------------------------------------------------- /08-idb-viz/rsconnect/shinyapps.io/jbkunst/08-idb-viz.dcf: -------------------------------------------------------------------------------- 1 | name: 08-idb-viz 2 | title: 3 | username: 4 | account: jbkunst 5 | server: shinyapps.io 6 | hostUrl: https://api.shinyapps.io/v1 7 | appId: 4204443 8 | bundleId: 4662892 9 | url: https://jbkunst.shinyapps.io/08-idb-viz/ 10 | when: 1622516409.66582 11 | lastSyncTime: 1622516409.66582 12 | asMultiple: FALSE 13 | asStatic: FALSE 14 | -------------------------------------------------------------------------------- /08-idb-viz/server.R: -------------------------------------------------------------------------------- 1 | # input <- list(country = "Cameroon", area_chart_mouseOver = list(name = "(10,20]")) 2 | 3 | shinyServer(function(input, output) { 4 | 5 | output$area_chart <- renderHighchart(hc) 6 | 7 | output$agec_chart <- renderHighchart(hc_agec) 8 | 9 | datag <- reactive({ 10 | 11 | highchartProxy("area_chart") %>% 12 | hcpxy_loading(action = "show") 13 | 14 | datag <- data_from_fips(input$country) 15 | 16 | }) 17 | 18 | observeEvent(input$country, { 19 | 20 | datag <- datag() 21 | 22 | highchartProxy("area_chart") %>% 23 | hcpxy_set_data( 24 | "area", 25 | datag, 26 | hcaes(x = x, y = y, group = agec), #hcaes(year, pop, group = agec), 27 | redraw = FALSE 28 | ) 29 | 30 | Sys.sleep(1) 31 | 32 | highchartProxy("area_chart") %>% 33 | hcpxy_loading(action = "hide") %>% 34 | hcpxy_redraw() 35 | 36 | 37 | }) 38 | 39 | observeEvent(input$area_chart_mouseOver, { 40 | 41 | datag <- datag() 42 | 43 | print(input$area_chart_mouseOver) 44 | 45 | mouseOver_agec <- input$area_chart_mouseOver$name 46 | 47 | dagec <- datag %>% 48 | filter(agec == mouseOver_agec) %>% 49 | select(-agec) 50 | 51 | highchartProxy("agec_chart") %>% 52 | hcpxy_update( 53 | subtitle = list(text = mouseOver_agec) 54 | ) %>% 55 | hcpxy_update_series( 56 | id = 0, 57 | data = list_parse2(dagec), 58 | color = COLORS[[mouseOver_agec]], 59 | name = mouseOver_agec 60 | ) 61 | 62 | }) 63 | 64 | }) 65 | -------------------------------------------------------------------------------- /08-idb-viz/ui.R: -------------------------------------------------------------------------------- 1 | dashboardPage( 2 | dashboardHeader(disable = TRUE), 3 | dashboardSidebar(disable = TRUE), 4 | dashboardBody( 5 | tags$head(tags$link(rel = "stylesheet", type = "text/css", href = "custom.css")), 6 | fluidRow( 7 | column( 8 | width = 4, 9 | offset = 4, 10 | selectInput("country", NULL, choices = opts, selectize = TRUE, width = "100%"), 11 | ) 12 | ), 13 | fluidRow( 14 | column( 15 | width = 7, 16 | highchartOutput("area_chart") 17 | ), 18 | column( 19 | 5, 20 | column( 21 | 12, 22 | highchartOutput("agec_chart") 23 | ) 24 | ) 25 | ) 26 | ) 27 | ) -------------------------------------------------------------------------------- /08-idb-viz/www/custom.css: -------------------------------------------------------------------------------- 1 | .small-box { 2 | background-color: white !important; 3 | } 4 | 5 | .small-box>.inner { 6 | color: #666666; !important; 7 | } 8 | 9 | .content-wrapper, .right-side { 10 | background-color: white !important; 11 | } -------------------------------------------------------------------------------- /09-piramid-census/..geojson: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/highcharter-shiny/d16a3dbff568a2270515f66d285e8eb58c200c48/09-piramid-census/..geojson -------------------------------------------------------------------------------- /09-piramid-census/.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | -------------------------------------------------------------------------------- /09-piramid-census/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Title: Piramid Census 2 | Author: Joshua Kunst 3 | AuthorUrl: https://jkunst.com/ 4 | License: MIT 5 | DisplayMode: Showcase 6 | Type: Shiny -------------------------------------------------------------------------------- /09-piramid-census/Readme.md: -------------------------------------------------------------------------------- 1 | This apps show how you can use the highcharter widgets like inputs elements. 2 | For example, clicking in a point, line, country triggers 3 | an event, a change in an input. The app uses idbr package by [Kyle Walke](http://walkerke.github.io/). 4 | 5 | The key parts to get this feature are: 6 | 7 | 1. Define a Javascript function to use the `Shiny.onInputChange`, the parameter 8 | for this functions are the name of te input to listen in the server and the 9 | value of this input. In this example the name of the input is `hcworldinput` 10 | and `this.name`. This last argument is a special value in highcharter to get 11 | the name of the series or point. 12 | 13 | 2. Use the previous function in a highcharter widget in the event that it's 14 | required, for example, hover, click, etc. 15 | 16 | 3. Then use `input$hcworldinput` in the server side of the app. 17 | 18 | ``` 19 | fn <- "function(){ 20 | console.log(this.name); 21 | Shiny.onInputChange('hcworldinput', this.name) 22 | }" 23 | 24 | hc %>% 25 | hc_plotOptions( 26 | series = list( 27 | cursor = "pointer", 28 | point = list( 29 | events = list(click = JS(fn) 30 | ) 31 | ) 32 | ) 33 | ) 34 | ``` -------------------------------------------------------------------------------- /09-piramid-census/censusdata.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/highcharter-shiny/d16a3dbff568a2270515f66d285e8eb58c200c48/09-piramid-census/censusdata.rds -------------------------------------------------------------------------------- /09-piramid-census/dataapp.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/highcharter-shiny/d16a3dbff568a2270515f66d285e8eb58c200c48/09-piramid-census/dataapp.RData -------------------------------------------------------------------------------- /09-piramid-census/dataappmin.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/highcharter-shiny/d16a3dbff568a2270515f66d285e8eb58c200c48/09-piramid-census/dataappmin.RData -------------------------------------------------------------------------------- /09-piramid-census/download_prepare_data.R: -------------------------------------------------------------------------------- 1 | rm(list = ls()) 2 | # library("idbr") # devtools::install_github('walkerke/idbr') 3 | # library("purrr") 4 | # library("stringr") 5 | # library("rvest") 6 | # library("dplyr") 7 | # library("highcharter") 8 | # library("ggplot2") 9 | # library("matrixStats") 10 | # library("geojsonio") 11 | 12 | dfcodes <- "http://www.geohive.com/earth/gen_codes.aspx" %>% 13 | read_html() %>% 14 | html_table(fill = TRUE) %>% 15 | .[[2]] %>% 16 | tbl_df() %>% 17 | setNames(str_to_id(names(.))) %>% 18 | filter(!is.na(iso_3_letter), iso_3_letter != "") 19 | 20 | yrs <- 2000:2020 21 | 22 | filename <- "censusdata.rds" 23 | 24 | if (file.exists(filename)) { 25 | 26 | df <- readRDS(filename) 27 | 28 | } else { 29 | 30 | # http://api.census.gov/ 31 | idb_api_key("35f116582d5a89d11a47c7ffbfc2ba309133f09d") 32 | 33 | df <- dfcodes$fips %>% 34 | map_df(function(x){ 35 | # x <- sample(dfcodes$fips, size = 1) 36 | message(x) 37 | try(return(rbind( 38 | idb1(x, yrs, sex = "male"), 39 | idb1(x, yrs, sex = "female") 40 | ))) 41 | data_frame(FIPS = x) 42 | 43 | }) 44 | 45 | df <- df %>% 46 | filter(!is.na(time)) %>% 47 | mutate(SEX = ifelse(SEX == 1, "male", "female")) 48 | 49 | names(df) <- tolower(names(df)) 50 | 51 | saveRDS(df, "censusdata.rds") 52 | 53 | } 54 | 55 | df 56 | dfcodes 57 | 58 | data("worldgeojson") 59 | 60 | dfwgj <- map_df(worldgeojson$features, function(x){ 61 | data_frame( 62 | iso3 = x$properties$iso3, 63 | namem = x$properties$name 64 | ) 65 | }) 66 | 67 | 68 | # this will conatain median age by country and year to show in the map 69 | df <- df %>% 70 | left_join(dfcodes %>% select(fips, iso3 = iso_3_letter, entity), by = "fips") %>% 71 | left_join(dfwgj, by = "iso3") 72 | 73 | df <- df %>% filter(!is.na(namem)) 74 | 75 | df2 <- df %>% 76 | group_by(iso3, name = namem, time) %>% 77 | do({ 78 | data_frame( 79 | wage = weightedMedian( 80 | c(.$age[.$sex == "male"], .$age[.$sex == "female"]), 81 | c(.$pop[.$sex == "male"], .$pop[.$sex == "female"])) 82 | ) 83 | }) %>% 84 | ungroup() %>% 85 | mutate(wage = round(wage, 3)) 86 | 87 | 88 | 89 | # world <- geojsonio::geojson_read("countries.json") 90 | # save(df, df2, df3, yrs, file = "dataapp.RData") 91 | 92 | df <- df %>% select(iso3, name = namem, time, pop, age, sex) 93 | 94 | save(df, 95 | df2, 96 | yrs, 97 | file = "dataappmin.RData") 98 | 99 | -------------------------------------------------------------------------------- /09-piramid-census/global.R: -------------------------------------------------------------------------------- 1 | library(shiny) 2 | library(purrr) 3 | library(dplyr) 4 | library(rlist) 5 | library(highcharter) 6 | library(viridisLite) 7 | library(shinythemes) 8 | 9 | load("dataappmin.RData") 10 | # data("worldgeojson") 11 | 12 | options(highcharter.theme = hc_theme_smpl()) 13 | 14 | input <- list(yr = sample(yrs, size = 1), hcworldinput = "Canada") 15 | 16 | slider <- sliderInput( 17 | "yr", 18 | NULL, 19 | value = min(yrs), 20 | min = min(yrs), 21 | max = max(yrs), 22 | round = TRUE, 23 | ticks = FALSE, 24 | step = 1, 25 | width = "100%", 26 | animate = animationOptions(interval = 1000) 27 | ) -------------------------------------------------------------------------------- /09-piramid-census/piramid-census.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | -------------------------------------------------------------------------------- /09-piramid-census/rsconnect/shinyapps.io/jbkunst/09-piramid-census.dcf: -------------------------------------------------------------------------------- 1 | name: 09-piramid-census 2 | title: 3 | username: 4 | account: jbkunst 5 | server: shinyapps.io 6 | hostUrl: https://api.shinyapps.io/v1 7 | appId: 4204524 8 | bundleId: 4655741 9 | url: https://jbkunst.shinyapps.io/09-piramid-census/ 10 | when: 1622336049.30647 11 | lastSyncTime: 1622336049.30647 12 | -------------------------------------------------------------------------------- /09-piramid-census/server.R: -------------------------------------------------------------------------------- 1 | shinyServer(function(input, output) { 2 | 3 | options(highcharter.theme = hc_theme_smpl()) 4 | 5 | 6 | output$hcworld <- renderHighchart({ 7 | 8 | fn <- "function(){ 9 | console.log(this.name); 10 | Shiny.onInputChange('hcworldinput', this.name) 11 | }" 12 | 13 | df2aux <- filter(df2, time == 2016) 14 | 15 | hcmap(map = "custom/world-robinson-highres", data = df2aux, value = "wage", joinBy = c("iso-a3", "iso3"), name = "Median age", download_map_data = TRUE) %>% 16 | hc_title(text = "Median age by country, 2016") %>% 17 | hc_colorAxis(min = 10, max = 60, stops = color_stops(n = 10, substring(viridis(30, option = "B"), 0, 7))) %>% 18 | hc_mapNavigation(enabled = TRUE, align = "right", buttonOptions = list(verticalAlign = "bottom")) %>% 19 | hc_plotOptions(series = list(cursor = "pointer", point = list(events = list(click = JS(fn))))) 20 | 21 | }) 22 | 23 | output$hcpopiramid <- renderHighchart({ 24 | 25 | nme <- ifelse(is.null(input$hcworldinput), "United States of America", input$hcworldinput) 26 | 27 | cod <- df2 %>% filter(name == nme) %>% .$iso3 %>% .[1] 28 | dfp <- df %>% filter(time == input$yr, iso3 == cod) 29 | 30 | xaxis <- list(categories = sort(unique(dfp$age)), 31 | reversed = FALSE, tickInterval = 5, 32 | labels = list(step = 10)) 33 | 34 | highchart() %>% 35 | hc_chart(type = "bar") %>% 36 | hc_title(text = sprintf("Population pyramid for %s, %s", nme, input$yr )) %>% 37 | hc_plotOptions(series = list(stacking = "normal", animation = FALSE), 38 | bar = list(groupPadding = 0, pointPadding = 0, borderWidth = 0)) %>% 39 | hc_legend(enabled = FALSE) %>% 40 | hc_tooltip(shared = FALSE, 41 | formatter = JS("function () { return '' + this.series.name + ', age ' + this.point.category + '
' + 'Population: ' + Highcharts.numberFormat(Math.abs(this.point.y), 0);}") 42 | ) %>% 43 | hc_yAxis(visible = FALSE) %>% 44 | hc_xAxis( 45 | xaxis, 46 | list.merge(xaxis, list(opposite = TRUE, linkedTo = 0)) 47 | ) %>% 48 | hc_add_series(data = dfp %>% filter(sex == "male") %>% .$pop %>% {-1*.}, name = "male") %>% 49 | hc_add_series(data = dfp %>% filter(sex == "female") %>% .$pop, name = "female") 50 | 51 | }) 52 | 53 | output$hctss <- renderHighchart({ 54 | 55 | nme <- ifelse(is.null(input$hcworldinput), "Canada", input$hcworldinput) 56 | 57 | med <- df2 %>% 58 | filter(time == 2016, name == nme) %>% 59 | .$wage 60 | 61 | cntries <- df2 %>% 62 | filter(time == 2016, wage > med - 1, wage < med + 1) %>% 63 | .$name 64 | 65 | df2aux <- df2 %>% 66 | filter(name %in% cntries) 67 | 68 | fn <- "function(){ 69 | console.log(this.name); 70 | Shiny.onInputChange('hcworldinput', this.name) 71 | }" 72 | 73 | hctss <- highchart() %>% 74 | hc_chart(type = "spline") %>% 75 | hc_title(text = "Median age by years") %>% 76 | # hc_yAxis(min = 10, max = 60) %>% 77 | hc_plotOptions( 78 | series = list( 79 | states = list( 80 | hover = list( 81 | enabled = TRUE, 82 | halo = list( 83 | size = 0 84 | ) 85 | ) 86 | ), 87 | animation = FALSE, 88 | showInLegend = FALSE, 89 | cursor = "pointer", 90 | events = list( 91 | click = JS(fn) 92 | ) 93 | ), 94 | point = list( 95 | events = list( 96 | click = JS(fn) 97 | ) 98 | ) 99 | ) %>% 100 | hc_xAxis(categories = yrs) 101 | 102 | for (nm in (unique(df2aux$name))) { 103 | 104 | hctss <- hctss %>% 105 | hc_add_series(data = df2aux %>% filter(name == nm) %>% .$wage, 106 | color = "rgba(118, 192, 193, 0.8)", zIndex = -3, 107 | name = nm, marker = list( radius = 0)) 108 | } 109 | 110 | ds <- df2aux %>% filter(name == nme) %>% .$wage 111 | ds <- map(ds, function(x) x) 112 | tmp <- ds[which(input$yr == yrs)][[1]] 113 | ds[[which(input$yr == yrs)]] <- list(y = tmp, marker = list(symbol = "circle", color = "white", radius = 5, 114 | fillColor = "#014d64", lineWidth = 3)) 115 | 116 | hctss <- hctss %>% 117 | hc_add_series(data = ds, color = "#014d64", zIndex = 1, name = nme, lineWidth = 4, 118 | marker = list(symbol = "circle", radius = 1)) 119 | 120 | hctss 121 | 122 | 123 | }) 124 | 125 | 126 | }) 127 | -------------------------------------------------------------------------------- /09-piramid-census/ui.R: -------------------------------------------------------------------------------- 1 | shinyUI( 2 | fluidPage( 3 | theme = shinytheme("paper"), 4 | fluidRow(column(10, offset = 1, slider)), 5 | fluidRow(column(10, offset = 1, highchartOutput("hcworld"))), 6 | fluidRow( 7 | column(offset = 1, 5, highchartOutput("hcpopiramid")), 8 | column(5, highchartOutput("hctss")) 9 | ) 10 | ) 11 | ) 12 | -------------------------------------------------------------------------------- /deploy_apps.R: -------------------------------------------------------------------------------- 1 | library(tidyverse) 2 | 3 | # remotes::install_github("jbkunst/highcharter", force = TRUE) 4 | 5 | apps <- dir(here::here(), full.names = TRUE) %>% 6 | str_subset("highcharter-shiny.Rproj", negate = TRUE) %>% 7 | str_subset("deploy_apps.R", negate = TRUE) 8 | 9 | walk(apps, function(app = "D:/Git/highcharter-shiny/01-get-sarted"){ 10 | 11 | message(app) 12 | 13 | try(fs::dir_delete(fs::path(app, "rsconnect"))) 14 | 15 | rsconnect::deployApp(appDir = app, logLevel = "normal") 16 | 17 | }) 18 | 19 | -------------------------------------------------------------------------------- /highcharter-shiny.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | --------------------------------------------------------------------------------