hc_xy.RdHighcharter
hc_xy(
data,
type = "scatter",
map_data = NULL,
filters = NULL,
x = NULL,
y = NULL,
group = NULL,
isolate_legend_group = T,
category = NULL,
color = NULL,
color_type = "continuous",
color_palette = NULL,
map_join_by = NULL,
use_color_class = F,
download_map_data = T,
enable_navigation = TRUE,
n_color_breaks = 10,
n_colors = 4,
color_axis_type = "linear",
disable_inactive = F,
disable_opacity = 0,
element_id_text = NULL,
axis_scrollbars = NULL,
x_min_max = NULL,
y_min_max = NULL,
transparent_tooltip = F,
theme_name = "clean_unica",
theme_custom = NULL,
x_factor_reverse = F,
y_factor_reverse = F,
relevel_y_heatmap = F,
relevel_x_heatmap = F,
show_colors = T,
direction = 1,
opacity = 1,
name = NULL,
sort_y = F,
override_x_categories = NULL,
legend_font_size = NULL,
override_name = NULL,
use_fast = T,
order_method = "mean",
fit_type = "line",
fit_opacity = 1,
fit_predictions = NULL,
fits = NULL,
add_bcp_fits = F,
include_change_points = F,
include_bcp_probabilities = F,
adj = NULL,
w0 = NULL,
p0 = 0.2,
d = 10,
burnin = 500,
mcmc = 100,
use_table_tooltip = F,
zoom_type = c("xy"),
plot_symbol = "circle",
hc = NULL,
x_rtemis = NULL,
y_rtemis = NULL,
x_limits = NULL,
y_limits = NULL,
rt_model_args = NULL,
lag_opacity = 1,
lag_periods = NULL,
lag_chart_type = "line",
lag_color_palette = NULL,
lag_point_size = 1,
roll_periods = NULL,
roll_metrics = "mean",
roll_lag_periods = NULL,
roll_align = "right",
roll_weights = NULL,
roll_chart_type = "line",
roll_color_palette = NULL,
fill_by = NA,
roll_opacity = 1,
roll_point_size = 0,
keep_non_lag_variable = F,
use_beast = F,
beast_opacity = 1,
beast_type = "line",
beast_color_type = "continuous",
beast_color_palette = NULL,
beast_option = list(period = 23, burnin = 1000, sample = 1000, chainNumber = 10),
beast_minimum_data_points = 15,
enable_bayes_boot = F,
bb_size = NULL,
bb_image = NULL,
bb_chart_type = "line",
bb_color_type = "continuous",
bb_color_palette = NULL,
bb_point_size = 0,
bb_draws = 4000,
bb_resample_draws = 4000,
bb_opacity = 1,
use_weights = T,
prophet_opacity = 0.2,
prophet_color_palette = NULL,
prophet_growth = "linear",
prophet_prediction_period = NULL,
prediction_frequency = "day",
n.changepoints = 25,
changepoint.range = 0.8,
yearly.seasonality = "auto",
weekly.seasonality = "auto",
daily.seasonality = "auto",
holidays = NULL,
seasonality.mode = "additive",
seasonality.prior.scale = 10,
holidays.prior.scale = 10,
changepoint.prior.scale = 0.05,
mcmc.samples = 0,
interval.width = 0.8,
plot_dimensions = NULL,
target = NULL,
size = NULL,
file_path = NULL,
color_axis = NULL,
labels = NULL,
from = NULL,
to = NULL,
weight = NULL,
link = NULL,
image = NULL,
exclude_tooltip = F,
override_x_rt = T,
verbose = T,
override_legend_location = NULL,
override_x_label = NULL,
override_y_label = NULL,
override_series = NULL,
override_marker = NULL,
marker = NULL,
disable_marker = F,
marker_parameters = list(width = 40, height = 30),
layout_algorithm = "squarified",
is_sunburst = F,
tree_labels = list(list(level = 1, borderColor = "black", colorByPoint = TRUE,
colorVariation = list(key = "brightness", to = 1), borderWidth = 2, dataLabels =
list(enabled = TRUE, verticalAlign = "top", align = "left", style = list(fontSize =
"24x", fontWeight = "bold", allowOverlap = T))), list(level = 2, borderColor =
"black", colorByPoint = TRUE, colorVariation = list(key = "brightness", to = 1),
borderWidth = 0.1, dataLabels = list(enabled = T, style = list(fontWeight = "bold",
allowOverlap = T))), list(level = 3, borderColor = "black", colorByPoint = TRUE,
colorVariation = list(key = "brightness", to = 1), borderWidth = 0.1, dataLabels =
list(enabled = T, style = list(fontWeight = "bold", allowOverlap = T))), list(level =
4, borderColor = "black", colorByPoint = TRUE, colorVariation = list(key =
"brightness", to = 1), borderWidth = 0.1, dataLabels = list(enabled = T, style =
list(fontWeight = "bold", allowOverlap = T))), list(level = 5, borderColor = "black",
colorByPoint = TRUE, colorVariation = list(key = "brightness", to = 1),
borderWidth = 0.1, dataLabels = list(enabled = T, style = list(fontWeight = "bold",
allowOverlap = T))), list(level = 6, borderColor = "black", colorByPoint = TRUE,
colorVariation = list(key = "brightness", to = 1), borderWidth = 0.1, dataLabels =
list(enabled = T, style = list(fontWeight = "bold", allowOverlap = T))), list(level =
7, borderColor = "black", colorByPoint = TRUE, colorVariation = list(key =
"brightness", to = 1), borderWidth = 0.1, dataLabels = list(enabled = T, style =
list(fontWeight = "bold", allowOverlap = T)))),
low = NULL,
high = NULL,
facet = NULL,
data_tooltip = NULL,
chart_in_chart_height = 225,
chart_in_chart_width = 400,
data_tooltip_params = NULL,
drill = NULL,
motion = NULL,
motion_labels = NULL,
stacking = NULL,
data_x_lines = NULL,
data_y_lines = NULL,
tooltip = NULL,
share_tooltip = F,
annotations = NULL,
drilldown_params = NULL,
point_size = 3,
border_width = 1,
point_width = 8,
label_parameters = list(enabled = F, useHTML = T, format = "{point.name}"),
use_shadow = F,
disable_legend = F,
transformations = NULL,
use_stock = F,
boost = F,
responsive_layout = T,
invert_chart = F,
use_scrollbar = F,
use_navigator = F,
use_range_selector = F,
is_polar = F,
halo_size = 5,
facet_column_count = 3,
facet_height = 500,
row_height = NULL,
override_model_groups = F,
group_to_character = F,
override_x_text = NULL,
override_y_text = NULL,
override_x_format = NULL,
override_y_format = NULL,
disable_x = F,
disable_y = F,
override_tooltip = F,
title = NULL,
subtitle = NULL,
credits = NULL,
caption = NULL,
export = F,
use_point_select = F,
use_regression = F,
frame_widget = F,
frame_width = "100%",
frame_height = NULL,
frame_element = NULL,
frame_options = frameOptions(allowfullscreen = T),
prediction_periods = 0,
sequence_period_type = "day",
...
)if not NULL
538
chalk
darkunica
db
economist
elementary
ffx
flat
flatdark
ft
ggplot2
gridlight
handdrawn
merge
monokai
null
sandsignika
smpl
sparkline
superheroes
tufte
tufte2
hcrt
sparkline
sparkline_vb
override series layout with paramaters available here Series
override series layout with paramaters available here marker
options
sliceAndDice
squarified
stripes
strip
https://api.highcharts.com/highmaps/xAxis.title
https://api.highcharts.com/highmaps/yAxis.title
# load_packages -----------------------------------------------------------
library(asbviz)
library(tidyverse)
library(glue)
library(highcharter)
library(purrr)
library(forecast)
library(janitor)
library(nbastatR)
library(dplyr)
library(quantmod)
library(modelR2)
library(gapminder)
library(grDevices)
library(forecast)
library(rvest)
library(idbr)
library(purrr)
library(datos) # datos
library(ggplot2) # más gráficos
library(tidyr)
library(forcats) # para usar la función fct_inorder
library(scales)
library(ggridges)
library(lubridate)
library(stringr)
library(tidytext)
library(treemap)
library(economiccomplexity)
library(igraph)
library(Matrix)
library(ggraph)
library(countrycode)
library(tsbox)
# list_multiple_plots -----------------------------------------------------
price <- ggplot2::diamonds$price
hc_multiple_densities <-
list(density(price), as.numeric(price)) %>% hc_xy(facet_column_count = 1, title = "Plot")
hc_multiple_densities
# boxplot-jitter ----------------------------------------------------------
df <- tidyr::pivot_longer(iris, -Species)
hc_box_plot_jitter <-
df %>%
asbviz::hc_xy(x = "name",
y = "value",
type = "boxplot",
group = "Species") %>%
asbviz::hc_xy(
hc = .,
x = "name",
y = "value",
group = "Species",
data = df,
title = "Boxplot Jitter"
)
hc_box_plot_jitter
# basic-pie ---------------------------------------------------------------
hc_crappy_pie <-
count(iris, Species) %>%
hc_xy(
y = "n",
name = "Species",
type = "pie",
theme_custom = hc_theme(
chart = list(backgroundColor = NULL,
divBackgroundImage = "https://media.giphy.com/media/Yy26NRbpB9lDi/giphy.gif")
),
pie = list(depth = 70)
)
hc_crappy_pie
# basic-line --------------------------------------------------------------
tbl_temp_long <- citytemp %>%
gather(city, temp, -month) %>%
mutate(month = month %>% factor(
ordered = T,
levels = c(
"Jan",
"Feb",
"Mar",
"Apr",
"May",
"Jun",
"Jul",
"Aug",
"Sep",
"Oct",
"Nov",
"Dec"
)
))
hc_month_temp_column <-
tbl_temp_long %>%
hc_xy(
x = "month",
y = "temp",
group = "city",
type = "column",
hc = NULL,
)
hc_month_temp_column
hc_month_temp_column <- tbl_temp_long %>%
hc_xy(
x = "month",
y = "temp",
group = "city",
type = "scatter",
hc = hc_month_temp_column,
)
hc_month_temp_column
hc_month_temp_column_3d <-
tbl_temp_long %>%
hc_xy(
x = "month",
y = "temp",
group = "city",
type = "column",
invert_chart = T
) %>%
hc_chart(type = "column",
options3d = list(
enabled = TRUE,
beta = 15,
alpha = 15
))
hc_month_temp_column_3d
hc_temp_line <-
tbl_temp_long %>%
hc_xy(
x = "month",
y = "temp",
group = "city",
type = "line",
zoom_type = NULL,
override_y_text = list(text = "Temperature <b>in y Axis</b>", useHTML = TRUE),
override_x_text = list(text = "Month in x Axis"),
override_y_format = list(
opposite = TRUE,
minorTickInterval = "auto",
minorGridLineDashStyle = "LongDashDotDot",
showFirstLabel = FALSE,
showLastLabel = FALSE
)
) %>%
hc_yAxis(
title = list(text = "Temperature <b>in y Axis</b>", useHTML = TRUE),
opposite = TRUE,
minorTickInterval = "auto",
minorGridLineDashStyle = "LongDashDotDot",
showFirstLabel = FALSE,
showLastLabel = FALSE
) %>%
hc_yAxis(plotBands = list(
list(
from = 20,
to = 50,
color = hex_to_rgba("red", 0.1),
label = list(text = "This is a plotBand"),
# the zIndex is used to put the label text over the grid lines
zIndex = 1
)
)) %>%
hc_legend(
align = "left",
verticalAlign = "top",
layout = "vertical",
x = 0,
y = 100
) %>%
hc_tooltip(
crosshairs = TRUE,
backgroundColor = "#F0F0F0",
shared = TRUE,
borderWidth = 5
)
hc_temp_line
# bee-swarm ---------------------------------------------------------------
df_nba <- bref_players_stats(seasons = 2020:2022) %>% janitor::clean_names()
### grouped
hc_bee_2020_21_group <-
df_nba %>%
filter(slug_team_bref != "TOT") %>%
asbviz::hc_xy(
x = "slug_team_bref",
y = "minutes_totals",
group = "slug_position",
type = "beeswarm",
name = "name_player",
image = "url_player_headshot",
transformations = c("mean_y", "log_y"),
title = "Beeswarm",
subtitle = "2021 - Players Over 500 Minutes by Position Group",
facet = "year_season",
facet_column_count = 1,
color_palette = "lisa::Jean_MichelBasquiat_1",
color_type = "discrete",
caption = "Inverted",
credits = "right",
override_x_text = list(text = "Team"),
override_y_text = list(text = "Log10 Minutes Played"),
opacity = .75,
plot_symbol = NULL,
point_size = 3.5,
theme_name = "clean_unica",
invert_chart = F
)
hc_bee_2020_21_group
hc_bee_season <-
df_nba %>%
filter(minutes_totals >= 500) %>%
hc_xy(
x = "year_season",
y = "minutes_totals",
name = "name_player",
image = "url_player_photo",
group = "group_position",
marker = "url_player_headshot",
type = "beeswarm",
override_x_text = list(text = "Season"),
transformations = c("mean_y", "log_y"),
title = "Ungrouped Beeswarm",
subtitle = "2020 and 2021 Players with Over 500 Minutes",
disable_legend = F,
override_y_text = list(text = "minutes played")
)
df_minutes_teams <-
df_nba %>%
filter(slug_team_bref != "TOT") %>%
select(name_player, group_position, url_player_headshot, slug_team_bref, year_season, minutes) %>%
group_by(year_season, slug_team_bref) %>%
nest() %>%
ungroup()
df_summary <-
df_nba %>%
filter(slug_team_bref != "TOT") %>%
asbtools::tbl_summarise(
group_variables = c("year_season", "slug_team_bref"),
distinct_variables = "name_player",
calculation_variable = "minutes_totals",
amount_variables = "minutes_totals",
mean_variables = "minutes_totals",
median_variables = "minutes_totals",
top_variables = "name_player"
) %>%
select(-count)
tbl_cogs <- build_cognostics(df_summary)
tbl_cogs <- asbtools::tbl_edit(tbl_cogs)
df_summary <-
df_summary %>%
left_join(df_minutes_teams)
id_cols <- df_summary %>% select(-data) %>% names()
setwd("~")
hc_beeswarm_trelliscope <- asbviz::hc_xy_trelliscope(
data = df_summary,
data_column_name = "data",
id_columns = id_cols,
disable_y = T,
x = "year_season",
y = "minutes",
group = "group_position",
name = "name_player",
marker = "url_player_headshot",
theme_name = "clean_unica",
type = "beeswarm",
transformations = c("mean_y", "log_y"),
color_type = "discrete",
color_palette = "lisa::Jean_MichelBasquiat_1",
glue_title = "{year_season} {slug_team_bref} {count} Distinct Players",
data_cognostics = tbl_cogs,
trelliscope_title = "2020 to 2022 Minutes Played by Team and Season - Interactive Beeswarm Plot",
glue_credits = "Data from nbastatR via Basketball-Reference",
disable_legend = F,
override_y_text = list(text = "minutes played"),
trelliscope_path = "Desktop/abresler.github.io/trelliscopes/nba/minutes/beeswarm"
)
hc_beeswarm_trelliscope
# asbtools::push_website_changes_to_github()
## Crea
# basic-annotations -------------------------------------------------------
df <- tibble(x = 1:10,
y = 1:10)
annots <- list(labels = list(
list(point = list(
x = 5,
y = 5,
xAxis = 0,
yAxis = 0
), text = "Middle"),
list(point = list(
x = 1,
y = 1,
xAxis = 0,
yAxis = 0
), text = "Start")
))
hc_area_notations <-
df %>% hc_xy(
x = "x",
y = "y",
type = "area",
annotations = annots
)
hc_area_notations
# basic-treemap -----------------------------------------------------------
data <- tibble(
index1 = sample(LETTERS[1:5], 500, replace = T),
index2 = sample(LETTERS[6:10], 500, replace = T),
index3 = sample(LETTERS[11:15], 500, replace = T),
value = rpois(500, 5),
color_value = rpois(500, 5)
)
hc_tm_basic <- hc_xy(
data = data,
group = c("index1", "index2", "index3"),
size = "value",
color = "color_value",
type = "treemap",
use_point_select = F,
title = "TEST",
theme_name = "better_unica"
)
hc_tm_basic
# density -----------------------------------------------------------------
hc_iris_regular <-
hc_xy(
data = iris,
type = "density",
x = "Sepal.Length",
color_type = "discrete",
color_palette = "lisa::Jean_MichelBasquiat_1",
title = "Iris Sepal Width Density",
opacity = .5
)
hc_iris_regular
hc_iris_species_density <-
hc_xy(
data = iris,
type = "density",
x = "Sepal.Length",
group = "Species",
color_type = "discrete",
color_palette = "lisa::Jean_MichelBasquiat_1",
title = "Iris Speies Sepal Width Density",
opacity = .5
)
hc_iris_species_density
# range-selector ----------------------------------------------------------
hc_passenger_ts <-
AirPassengers %>%
hc_xy(use_stock = T, type = "spline") %>%
hc_rangeSelector(selected = 4) %>%
hc_navigator(
outlineColor = "gray",
outlineWidth = 2,
series = list(
color = "red",
lineWidth = 2,
type = "areaspline",
# you can change the type
fillColor = "rgba(255, 0, 0, 0.2)"
),
handles = list(backgroundColor = "yellow",
borderColor = "red")
)
hc_passenger_ts
hc_iris_xy <-
iris %>% hc_xy(
x = "Sepal.Length",
y = "Sepal.Width",
group = "Species",
opacity = 1,
isolate_legend_group = F,
theme_name = "better_unica",
color_type = "discrete",
color_palette = "lisa::Jean_MichelBasquiat_1"
)
hc_iris_xy
# rtemis color ------------------------------------------------------------
test_color <-
asbviz::n_colors(groups = 4, color_palette = "lisa::Jean_MichelBasquiat_1")
hc_xy_iris_gradient <-
tbl_rt_color_gradient(iris,
bind_name = F,
column = "Sepal.Width",
colors = test_color) %>%
asbviz::hc_xy(
x = "Sepal.Length",
y = "Sepal.Width",
color = "color",
theme_name = "better_unica",
disable_legend = T,
title = "Iris Color Gradient"
)
hc_xy_iris_gradient
iris_bar_gradient <-
iris %>%
arrange(desc(Sepal.Width)) %>%
asbviz::tbl_rt_color_gradient(bind_name = F,
column = "Sepal.Width",
colors = test_color) %>%
arrange(desc(sepal_width)) %>%
mutate(rank = 1:n()) %>%
asbviz::hc_xy(
x = "rank",
y = "Sepal.Width",
color = "color",
theme_name = "better_unica",
disable_legend = T,
title = "Iris Color Gradient",
type = "bar"
)
iris_bar_gradient
hc_iris_color_op <-
asbviz::tbl_rt_color_op(iris, "Sepal.Length", bind_name = F) %>%
asbviz::hc_xy(
x = "Sepal.Length",
y = "Sepal.Width",
color = "color",
theme_name = "better_unica",
disable_legend = T,
title = "Iris Color Op"
)
hc_iris_color_op
hc_iris_bar_op <-
asbviz::tbl_rt_color_op(iris, "Sepal.Length", bind_name = F) %>%
arrange(desc(sepal_length)) %>%
mutate(rank = 1:n()) %>%
asbviz::hc_xy(
x = "rank",
y = "sepal_length",
color = "color",
theme_name = "better_unica",
disable_legend = T,
title = "Iris Color Op",
type = "bar"
)
hc_iris_bar_op
# basic-scrool ------------------------------------------------------------
hc_ts_spline <- AirPassengers %>%
hc_xy(use_stock = T, type = "spline") %>%
hc_scrollbar(
barBackgroundColor = "gray",
barBorderRadius = 7,
barBorderWidth = 0,
buttonBackgroundColor = "gray",
buttonBorderWidth = 0,
buttonArrowColor = "yellow",
buttonBorderRadius = 7,
rifleColor = "yellow",
trackBackgroundColor = "white",
trackBorderWidth = 1,
trackBorderColor = "silver",
trackBorderRadius = 7
)
hc_ts_spline
# violin ------------------------------------------------------------------
hc_iris_violin <-
hc_xy(
data = as_tibble(iris),
type = "violin",
x = "Sepal.Width",
y = "Species",
override_y_text = "",
override_x_text = "",
color_palette = "palr::sst_pal",
title = "Distribution Violin",
theme_name = "clean_unica",
opacity = .5
)
hc_iris_violin
df_logs <-
game_logs(seasons = 2022) %>%
clean_names()
data <- df_logs %>%
filter(slug_team == "BKN")
hc_violin_nba <-
data %>%
hc_xy(
x = "minutes",
y = "name_player",
type = "violin",
theme_name = "better_unica",
color_palette = "palr::sst_pal",
title = "Nets Minutes",
override_y_text = list(text = ""),
invert_chart = T,
opacity = 1,
disable_legend = T
)
hc_violin_nba
# bullet-example ----------------------------------------------------------
df <- tibble(y = sample(5:10),
target = sample(5:10),
x = LETTERS[1:6])
hc_bullet <- df %>% hc_xy(
x = "x",
y = "y",
target = "target",
invert_chart = T,
type = "bullet",
override_series = list(
pointPadding = 0.25,
pointWidth = 15,
borderWidth = 0,
targetOptions = list(width = '200%')
)
) %>% hc_yAxis(
min = 0,
max = 10,
gridLineWidth = 0,
plotBands = list(
list(from = 0, to = 7, color = "#666"),
list(from = 7, to = 9, color = "#999"),
list(from = 9, to = 10, color = "#bbb")
)
)
hc_bullet
# gant-not-hc -------------------------------------------------------------
N <- 6
set.seed(1234)
df <- tibble(
start = sort(Sys.Date() + months(2 + sample(10:20, size = N))),
end = start + months(sample(1:3, size = N, replace = TRUE)),
name = c(
"Import",
"Tidy",
"Visualize",
"Model",
"Transform",
"Communicate"
),
id = tolower(name),
dependency = list(
NA,
"import",
"tidy",
"tidy",
"tidy",
c("visualize", "model", "transform")
),
completed = c(1, 1, 0.5, 0.6, 0.9, 0)
)
df <- mutate_if(df, is.Date, datetime_to_timestamp)
hc_gant_not_hc <- highchart(type = "gantt") %>%
hc_add_series(name = "Program",
data = df) %>%
hc_rangeSelector(enabled = TRUE) %>%
hc_navigator(
enabled = TRUE,
series = list(
type = 'gantt',
pointPlacement = 0.5,
pointPadding = 0.25
),
yAxis = list(
min = 0,
max = N,
reversed = TRUE,
categories = c()
)
) %>%
asbviz::hc_munge(theme_name = "better_unica")
hc_gant_not_hc
# fix_log_adjusted_axis ---------------------------------------------------
hc_diamonds_log_density_axis <-
ggplot2::diamonds %>%
mutate(price_log10 = log10(price)) %>%
arrange(desc(price_log10)) %>%
hc_xy(
x = "price_log10",
type = "density",
override_x_label = list(
formatter = JS(
"function(){
return '$' + Highcharts.numberFormat(Math.pow(10, this.value));
}"
)
)
)
hc_diamonds_log_density_axis
hc_diamonds_log_density_axis_group <-
ggplot2::diamonds %>%
mutate(price_log10 = log10(price)) %>%
arrange(desc(price_log10)) %>%
hc_xy(
x = "price_log10",
type = "density",
group = "clarity",
opacity = .6,
color_palette = "pals::kovesi.linear_bgy_10_95_c74",
invert_chart = T,
theme_name = "better_unica",
override_x_label = list(
formatter = JS(
"function(){
return '$' + Highcharts.numberFormat(Math.pow(10, this.value));
}"
)
)
)
hc_diamonds_log_density_axis_group
# treemap -----------------------------------------------------------------
## No Color Variable
data(GNI2014, package = "treemap")
data <- GNI2014 %>% as_tibble()
data(gapminder, package = "gapminder")
gapminder_2007 <-
gapminder::gapminder %>%
filter(year == max(year)) %>%
mutate(pop_mm = round(pop / 1e6))
hc_gapminder_tm <-
gapminder_2007 %>% hc_xy(
group = c("continent", "country"),
size = "pop_mm",
type = "treemap",
zoom_type = NULL,
title = "Treemap",
opacity = 1
)
hc_gapminder_tm
library(treemap)
hc_tm_gap_2 <-
GNI2014 %>%
hc_xy(
group = c("continent", "iso3"),
size = "GNI",
type = "treemap",
use_new_treemap = T,
allowDrillToNode = TRUE,
layoutAlgorithm = "squarified"
) %>%
hc_tooltip(pointFormat = "<b>{point.name}</b>:<br>
Pop: {point.value:,.0f}<br>
GNI: {point.valuecolor:,.0f}")
hc_tm_gap_2
data(GNI2014, package = "treemap")
data <- GNI2014 %>% as_tibble()
gapminder_2007 <-
gapminder::gapminder %>%
filter(year == max(year)) %>%
mutate(pop_mm = round(pop / 1e6))
### Color Variable
hc_gapminder_tm_new_labels <-
gapminder_2007 %>% hc_xy(
group = c("continent", "country"),
size = "pop_mm",
type = "treemap",
zoom_type = NULL,
color = "lifeExp",
color_palette = "gameofthrones::tully",
transformations = "log",
theme_name = "darkunica",
use_new_treemap = T,
title = "Treemap",
tree_labels = list(
list(
level = 1,
borderWidth = 10,
borderColor = "transparent",
colorByPoint = TRUE,
dataLabels = list(enabled = TRUE)
),
list(
level = 2,
borderWidth = 0,
borderColor = "transparent",
colorVariation = list(key = "brightness", to = 0.50),
dataLabels = list(enabled = TRUE)
)
)
)
hc_gapminder_tm_new_labels
# spline_density ----------------------------------------------------------
data <- data.frame(
normal = rnorm(10000, 5, 2), # 1000 random from normal dist
exponential = rexp(10000, 0.5), # 1000 random from exponential dist
uniform = runif(10000, 0, 10) # 1000 random from uniform dist
) %>% as_tibble()
# Data Manipulation
density <-
data %>%
gather(distribution, value, normal:uniform) %>%
mutate(value = value %>% round(1)) %>%
filter(value >= 0, value <= 12) %>%
group_by(distribution, value) %>%
summarise(points = n()) %>%
ungroup() %>% group_by(distribution) %>%
mutate(density = points / sum(points)) %>%
ungroup() %>%
select(-points)
hc_density_animation <- density %>%
hc_xy(
x = "value",
y = "density",
group = "distribution",
type = "spline",
override_y_text = list(text = "Probablity Density"),
title = "Probability Distributions: Uniform, Normal, and Exponential",
subtitle = "Emprical density plot for a 10,000 random sample from each of uniform, normal and exponential probability distributions.",
theme_name = "better_unica",
color_type = "discrete",
color_palette = "lisa::Jean_MichelBasquiat_1",
element_id_text = "fuck_this_shit",
override_y_label = list(
formatter = JS("function(){return(Math.round(this.value * 1000) / 10 + '%')}")
),
override_series = list(animation = list(
delay = sequence_time(4), duration = sequence_time(10)
))
)
hc_density_animation
# scroll_bars -------------------------------------------------------------
library(emo)
tbl_tweets <-
read_csv("https://gist.githubusercontent.com/abresler/190fd50e9bb7358ac690170134e9c0e5/raw/19fe8ec8ae0893745f11711e3f59bbce0915e779/tweets.csv")
emoji_csv <- "https://gist.githubusercontent.com/abresler/7b33bf0aed11bf91404084f6145c2fd8/raw/40054819548477b85c8758a5077fe50ac6efe91f/emoji.csv" %>% read_csv()
max_count <-
emoji_csv$n %>% max()
hc_emo_01 <-
emoji_csv %>%
mutate(color = "blue") %>%
hc_xy(
x = "emoji",
y = "n",
override_name = "Count",
type = "bar",
override_y_text = list(text = "Count",
align = "high"),
label_parameters = list(enabled = TRUE, style = list(fontWeight = "normal")),
override_y_label = list(format = "{value} tweets"),
transformations = c("log_y"),
axis_scrollbars = c("x"),
x_min_max = c(0, 30),
y_min_max = c(NA, max_count),
title = "#RStats Tweets Emoji Counts"
)
hc_emo_01
# emoji_scatter -----------------------------------------------------------
emoji_csv_xy <-
read_csv("https://gist.githubusercontent.com/abresler/77d10db2fbe4e617de667b70a02743cf/raw/9277c9237d48ec89f06dc9751233b7315d6bdc06/emoji2.csv")
hc_emo_scatter <- emoji_csv_xy %>%
hc_xy(
x = "favorite_count",
y = "retweet_count",
name = "emoji",
type = "scatter",
marker_parameters = list(radius = 0),
override_y_text = list(text = "Retweets"),
override_x_text = list(text = "Favorites"),
label_parameters = list(
enabled = TRUE,
format = "{point.name}",
allowOverlap = TRUE,
style = list(fontSize = 20),
y = 20
),
transformations = c("log_y", "log_x"),
disable_legend = T,
title = "#rstats Retweets by Favorites"
)
hc_emo_scatter
# stacked_column ----------------------------------------------------------
library(nbastatR)
df_nets <-
game_logs(seasons = 2022, league = "NBA") %>%
janitor::clean_names() %>%
filter(slug_team == "BKN")
hc_nets_stacked_game_minutes <-
df_nets %>%
fct_level_group(group = "name_player",
y = "minutes",
descending = F) %>%
hc_xy(
x = "date_game",
y = "minutes",
group = "name_player",
type = "column",
stacking = "percent",
borderWidth = 0,
groupPadding = 0,
theme_name = "better_unica",
isolate_legend_group = F,
pointPadding = 0,
color_palette = "pals::kovesi.linear_kry_5_98_c75",
disable_x = T,
disable_y = T,
)
hc_nets_stacked_game_minutes
# nested_data -------------------------------------------------------------
data(gapminder, package = "gapminder")
gp <- gapminder %>%
arrange(desc(year)) %>%
distinct(country, .keep_all = TRUE)
gp2 <- gapminder %>%
select(country, year, pop) %>%
nest(-country) %>%
mutate(
data = map(data, mutate_mapping, hcaes(x = year, y = pop), drop = TRUE),
data = map(data, list_parse)
) %>%
rename(ttdata = data)
gptot <- left_join(gp, gp2, by = "country")
hc_gap_chart_in_chart <-
hc_xy(
data = gptot,
x = "lifeExp",
y = "gdpPercap",
use_point_select = T,
transformations = "log_y",
size = "pop",
maxSize = 20,
name = "country",
group = "continent",
label_parameters = list(
enabled = TRUE,
format = "{point.name}",
style = list(
color = "black",
textOutline = "none",
fontWeight = "normal"
)
),
data_tooltip = "ttdata"
) %>%
hc_tooltip(
useHTML = TRUE,
headerFormat = "<b>{point.key}</b>",
pointFormatter = tooltip_chart(accesor = "ttdata")
)
hc_gap_chart_in_chart
### Donut
donutdata <- gp %>%
group_by(continent) %>%
summarise(pop = sum(pop / 1e6) * 1e6)
hchart(donutdata, "pie", hcaes(name = continent, y = pop), innerSize = 300)
donutdata2 <- gp %>%
select(continent, lifeExp, gdpPercap) %>%
nest(-continent) %>%
mutate(
data = map(data, mutate_mapping, hcaes(x = lifeExp, y = gdpPercap), drop = TRUE),
data = map(data, list_parse)
) %>%
rename(ttdata = data) %>%
left_join(donutdata)
hc <- hchart(donutdata2,
"pie",
hcaes(name = continent, y = pop),
innerSize = 375)
hc_donut_chart_in_chart <-
hc_xy(
data = donutdata2,
name = "continent",
y = "pop",
type = "pie",
innerSize = 375,
data_tooltip = "ttdata",
data_tooltip_params =
list(
chart = list(type = "scatter"),
credits = list(enabled = FALSE),
plotOptions = list(scatter = list(marker = list(radius = 2)))
),
positioner = JS(
"function () {
/* one of the most important parts! */
xp = this.chart.chartWidth/2 - this.label.width/2
yp = this.chart.chartHeight/2 - this.label.height/2
return { x: xp, y: yp };
}"
),
shadow = FALSE,
borderWidth = 0,
backgroundColor = "transparent",
hideDelay = 1000
) %>%
hc_tooltip(
useHTML = TRUE,
headerFormat = "<b>{point.key}</b>",
pointFormatter = tooltip_chart(
accesor = "ttdata",
hc_opts = list(
chart = list(type = "scatter"),
credits = list(enabled = FALSE),
plotOptions = list(scatter = list(marker = list(radius = 2)))
),
height = 225
),
positioner = JS(
"function () {
/* one of the most important parts! */
xp = this.chart.chartWidth/2 - this.label.width/2
yp = this.chart.chartHeight/2 - this.label.height/2
return { x: xp, y: yp };
}"
),
shadow = FALSE,
borderWidth = 0,
backgroundColor = "transparent",
hideDelay = 1000
)
hc_donut_chart_in_chart
# ridgeline ---------------------------------------------------------------
hc_iris_ridge_line <-
hc_xy(
data = iris,
x = "Sepal.Width",
group = "Species",
type = "ridgeline",
theme_name = "better_unica",
zIndex = 12:1,
lineWidth = 3,
title = "Ridgelines",
opacity = .5,
disable_x = F,
disable_y = T,
transformations = "log_x"
)
hc_iris_ridge_line
df_logs <-
game_logs(seasons = 2022)
df_nets <-
df_logs %>%
filter(slugTeam == "BKN") %>%
clean_names()
hc_nets_ridgeline <-
df_nets %>%
hc_xy(
x = "minutes",
group = "name_player",
type = "ridgeline",
theme_name = "better_unica",
zIndex = 12:1,
lineWidth = 3,
override_legend_location = NULL,
invert_chart = T,
title = "Interactive Ridgelines -- 2020-21 Nets Players Minutes",
opacity = 1,
color_palette = "ggthemes::Temperature Diverging"
)
hc_nets_ridgeline
df_logs <- df_logs %>% janitor::clean_names()
df_logs_long <-
df_logs %>%
select(year_season,
slug_team,
name_player,
name_team,
pts,
minutes) %>%
asbtools::tbl_pivot_longer(numeric_groups = "year_season", names_to = "metric")
tbl_data <- df_logs_long %>%
group_by(year_season, slug_team, name_team, metric) %>%
nest() %>%
ungroup()
df_summary <-
df_logs_long %>%
asbtools::tbl_summarise(
group_variables = c("year_season", "slug_team", "name_team", "metric"),
amount_variables = "value",
mean_variables = "value",
variance_variables = "value",
distinct_variables = "name_player",
top_variables = "name_player"
) %>%
select(-count)
tbl_cogs <- build_cognostics(df_summary)
tbl_cogs <- asbtools::tbl_edit(tbl_cogs)
df_summary <-
df_summary %>%
left_join(tbl_data)
id_cols <- df_summary %>% select(-data) %>% names()
setwd("~")
hc_ridgeline_trelliscope <-
asbviz::hc_xy_trelliscope(
data = df_summary,
x = "value",
group = "name_player",
type = "ridgeline",
theme_name = "better_unica",
zIndex = 12:1,
lineWidth = 3,
override_legend_location = NULL,
invert_chart = T,
opacity = 1,
color_type = "continuous",
color_palette = "ggthemes::Temperature Diverging",
glue_title = "{year_season} {name_team} for {metric} {value} in Total {metric}",
data_cognostics = tbl_cogs,
trelliscope_title = "Ridgeline Distribution plots of Key Metrics",
glue_credits = "Data from nbastatR via Basketball-Reference",
disable_legend = F,
data_column_name = "data",
id_columns = id_cols
)
hc_ridgeline_trelliscope
rm(hc_ridgeline_trelliscope)
## Trelliscope
# beast -------------------------------------------------------------------
df_logs <-
game_logs(seasons = 2022) %>%
clean_names()
players <-
df_logs %>%
group_by(name_player) %>%
summarise(games = n(),
mean_minutes = mean(minutes)) %>%
filter(games >= 20) %>%
filter(mean_minutes >= 20) %>%
sample_n(2) %>%
pull(name_player)
data <- df_logs %>%
filter(name_player %in% players) %>%
fct_level_group(group = "name_player",
y = "minutes",
descending = F)
hc_beast <-
hc_xy(
data = data,
x = "date_game",
y = "minutes",
group = "name_player",
marker = "url_player_headshot",
roll_periods = c(3, 15),
roll_lag_periods = 1,
lag_periods = c(1, 10),
theme_name = "better_unica",
use_beast = T
)
hc_beast
# packed_bubble -----------------------------------------------------------
data(gapminder, package = "gapminder")
gapminder <- subset(gapminder, year == max(year))
hc_packed_bubble <-
hc_xy(
data = gapminder,
name = "country",
group = "continent",
y = "pop",
type = "packedbubble",
zoom_type = c("x"),
opacity = 1,
label_parameters = list(
enabled = TRUE,
format = "{point.name}",
style = list(
color = "black",
textOutline = "none",
fontWeight = "normal"
)
)
)
hc_packed_bubble
q95 <- as.numeric(quantile(gapminder$pop, .95))
hc_packed_bubble_labeled <- hc_xy(
data = gapminder,
name = "country",
group = "continent",
y = "pop",
type = "packedbubble",
zoom_type = c("x"),
opacity = 1,
label_parameters = list(
enabled = TRUE,
format = "{point.name}",
style = list(
color = "black",
textOutline = "none",
fontWeight = "normal"
)
)
) %>%
hc_tooltip(useHTML = TRUE,
pointFormat = "<b>{point.name}:</b> {point.value}") %>%
hc_plotOptions(packedbubble = list(
maxSize = "150%",
zMin = 0,
layoutAlgorithm = list(
gravitationalConstant = 0.05,
splitSeries = TRUE,
# TRUE to group points
seriesInteraction = TRUE,
dragBetweenSeries = TRUE,
parentNodeLimit = TRUE
),
dataLabels = list(
enabled = TRUE,
format = "{point.name}",
filter = list(
property = "y",
operator = ">",
value = q95
),
style = list(
color = "black",
textOutline = "none",
fontWeight = "normal"
)
)
))
hc_packed_bubble_labeled
data <- gapminder %>%
group_by(continent) %>%
summarise(count = sum(pop, na.rm = T)) %>%
ungroup() %>%
arrange(desc(count))
hc_packed_gap_bubble <-
data %>%
tbl_rt_color_gradient(,
bind_name = F,
column = "count") %>%
hc_xy(
name = "continent",
y = "count",
type = "packedbubble",
color = "color",
zoom_type = c("x"),
label_parameters = list(
enabled = TRUE,
format = "{point.name}",
style = list(
color = "black",
textOutline = "none",
fontWeight = "normal"
)
)
)
hc_packed_gap_bubble
hc_packed_country_continent <-
hc_xy(
data = gapminder,
type = "packedbubble",
y = "gdpPercap",
group = "continent",
name = "country",
label_parameters = list(
enabled = TRUE,
format = "{point.name}",
shadow = T,
style = list(
color = "black",
textOutline = "none",
fontWeight = "normal"
)
),
title = "Per Capita GDP by Region and Country"
)
hc_packed_country_continent
# numeric_vectors ---------------------------------------------------------
hc_char_bar <- hc_xy(
data = mpg$manufacturer,
invert_chart = T,
enable_point_select = F
)
hc_char_bar
x <- rgamma(3000, 2, 4)
hc_numeric_count <- hc_xy(data = x, title = "A Numeric Vector")
hc_numeric_count
data(diamonds, package = "ggplot2")
hc_diamonds_cut <-
diamonds %>%
mutate(count = 1) %>%
tbl_ordered_factor(columns = "cut", weight = "count") %>%
hc_xy(data = .$cut, title = "Factor Counts")
hc_bar_count_cut <-
diamonds %>%
count(cut, name = "count", sort = T) %>%
tbl_ordered_factor(columns = "cut", weight = "count") %>%
asbviz::tbl_rt_color_op(column = "count") %>%
asbviz::hc_xy(
x = "cut",
y = "count",
invert_chart = T,
type = "bar",
color = "color",
override_x_text = list(text = ""),
disable_y = T,
label_parameters = list(
enabled = TRUE,
format = "{point.y}",
style = list(
color = "black",
textOutline = "none",
fontWeight = "normal"
)
),
disable_legend = T
)
hc_bar_count_cut
# financial symbols -------------------------------------------------------
library(quantmod)
goog <-
getSymbols(c("GOOG", "BACHF", "BABA"), auto.assign = T)
hc_xy(data = GOOG, title = "Evil")
df <- list(`GOOGLE` = GOOG, `Bank of China` = BACHF, `Fraudbaba` = BABA)
hc_stocks <-
asbviz::hc_xy(data = df, theme_name = "better_unica", facet_column_count = 1)
hc_stocks
hc_xy(data = BABA) %>%
hc_add_yAxis(nid = 1L,
title = list(text = "BABA"),
relative = 2) %>%
hc_add_series(GOOG[, "GOOG.Close"],
showInLegend = T)
# multiple_axis -----------------------------------------------------------
aapl <- quantmod::getSymbols("AAPL",
src = "yahoo",
from = "2020-01-01",
auto.assign = FALSE)
hc_aapl_multi <- hc_xy(aapl) %>%
hc_add_yAxis(nid = 1L,
title = list(text = "Prices"),
relative = 2) %>%
hc_add_series(aapl[, "AAPL.Volume"],
yAxis = 1,
type = "column",
showInLegend = FALSE) %>%
hc_add_yAxis(nid = 2L,
title = list(text = "Volume"),
relative = 1)
hc_aapl_multi
# multiline ---------------------------------------------------------------
data(gapminder, package = "gapminder")
hc_multi_line <-
gapminder %>%
asbviz::hc_xy(
x = "year",
y = "lifeExp",
type = "line",
facet = "continent",
facet_column_count = 1,
group = "country",
disable_legend = F
)
hc_multi_line
# lollipop ----------------------------------------------------------------
mtcars <- mtcars[order(mtcars$hp , decreasing = TRUE),]
d = mtcars %>%
rownames_to_column("car") %>%
as_tibble()
hc_facet_lol <-
hc_xy(
data = d,
x = "car",
y = "mpg",
facet = "cyl",
facet_column_count = 1,
type = "lollipop"
)
hc_facet_lol
hc_regular_lol <-
d %>%
tbl_rt_color_gradient(,
bind_name = F,
column = "hp") %>%
hc_xy(
x = "car",
y = "hp",
color = "color",
type = "lollipop",
override_y_label = list(format = "{value} HP"),
override_x_text = list(text = ""),
invert_chart = T,
disable_legend = T,
theme_name = "better_unica"
)
hc_regular_lol
# LABELS ------------------------------------------------------------------
hc_label_scatter <-
mtcars %>%
rownames_to_column() %>%
tbl_rt_color_gradient(,
bind_name = F,
column = "mpg") %>%
hc_xy(
x = "wt",
y = "mpg",
color = "color",
include_labels = T,
type = "scatter",
label_parameters = list(
align = "left",
crop = T,
enabled = T,
formatter = JS(
"function(){
return Highcharts.numberFormat(this.point.x, 0,'.', ',');
}"
)
),
theme_name = "better_unica"
)
hc_label_scatter
hc_scatter_fit <-
mtcars %>%
rownames_to_column() %>%
tbl_rt_color_gradient(,
bind_name = F,
column = "mpg") %>%
hc_xy(
x = "wt",
y = "mpg",
include_labels = T,
type = "scatter",
label_parameters = list(
align = "left",
crop = T,
enabled = T,
format = "{point.y}",
filter = list(
property = "y",
operator = ">",
value = 30
)
),
fits = c("LM", "RF"),
override_model_group = T
)
hc_label_scatter
hc_scatter_fit_group <-
mtcars %>%
rownames_to_column() %>%
hc_xy(
x = "wt",
y = "mpg",
group = "cyl",
include_labels = T,
type = "scatter",
label_parameters = list(
align = "left",
crop = T,
enabled = T,
useHTML = T,
format = "<h3>${point.y}</h3>"
),
fits = c("LM", "RF"),
theme_name = "better_unica"
)
hc_scatter_fit_group
hc_scatter_label_m <-
mtcars %>%
rownames_to_column() %>%
hc_xy(
x = "wt",
y = "mpg",
include_labels = T,
type = "scatter",
label_parameters = list(
crop = T,
useHTML = F,
enabled = T,
formatter = JS(
"function(){
return Highcharts.numberFormat(this.point.x, 2) + 'Millions';
}"
),
align = 'right',
color = '#FFFFFF',
x = -10
)
)
hc_scatter_label_m
hc_hm_label <-
mtcars %>%
hc_xy(
x = "vs",
y = "am",
group = "mpg",
include_labels = T,
type = "heatmap",
show_colors = F,
export = T,
label_parameters = list(
crop = T,
enabled = T,
formatter = JS(
"function(){
return Highcharts.numberFormat(this.point.x, 2) + 'M';
}"
),
align = 'center',
color = '#FFFFFF',
x = -10
)
)
hc_hm_label
# annotated_line_progress_bars --------------------------------------------
tbl_tweets <-
read_csv("https://gist.githubusercontent.com/abresler/09b36b29afd9fd50c93ee920c215e504/raw/33fc7227de38b3562b1408cdc404c2304e899161/dtweets.csv")
dtweets <- tbl_tweets %>%
filter(between(year(created_at), 2020, 2020)) %>%
mutate(created_at = as.Date(created_at)) %>%
select(created_at, text, favorite_count, retweet_count) %>%
arrange(created_at)
dtweets <- dtweets %>%
distinct(created_at, .keep_all = TRUE)
dtops <- dtweets %>%
top_n(5, favorite_count)
dtext <- dtweets %>%
select(created_at, text) %>%
mutate(text = str_extract(text, "[0-9]+.*"))
data <- dtweets %>%
select(created_at, Favorites = favorite_count, Retweets = retweet_count) %>%
gather(type, count, -created_at) %>%
arrange(created_at) %>%
left_join(dtext, by = "created_at")
top_annotations <- dtops %>%
mutate(created_at = datetime_to_timestamp(created_at)) %>%
select(x = created_at, y = favorite_count, text) %>%
df_to_annotations_labels()
hc_annotated_progress <-
data %>%
hc_xy(
type = "line",
x = "created_at" ,
y = "count",
group = "type",
zoom_type = NULL,
override_x_text = list(text = ""),
color_palette = "grDevices::PiYG",
use_table_tooltip = T,
override_y_text = list("Count"),
override_y_label = list(
formatter = JS(
"function(){
return '' + Highcharts.numberFormat(this.value, 0, '.', ',') + ' tweets';
}"
)
),
override_x_label = list(
staggerLines = 1,
formatter = JS(
"function () { return Highcharts.dateFormat('%B', this.value); }"
),
tickPositioner = JS(
"function () {
var positions = [],
tick = Math.floor(this.dataMin),
increment = 1000 * 3600 * 24 * 91.5; // 3 months
for (tick; tick <= this.dataMax; tick += increment) {
positions.push(tick);
}
if (positions.indexOf(this.dataMax) == -1) positions.push(this.dataMax);
return positions;
}"
)
),
annotations = list(
labelOptions = list(
shape = "connector",
align = "right",
justify = FALSE,
crop = TRUE,
style = list(fontSize = "0.8em", textOutline = "1px white")
),
labels = top_annotations
)
)
hc_annotated_progress
# step lines --------------------------------------------------------------
hc_iris_step_line <-
iris %>% hc_xy(
x = "Sepal.Length",
y = "Sepal.Width",
use_point_select = T,
group = "Species",
type = "line",
color_palette = "pals::kovesi.diverging_bwr_40_95_c42",
theme_name = "better_unica",
override_series = list(step = 'center')
)
hc_iris_step_line
# categories --------------------------------------------------------------
mpgg <-
ggplot2::mpg %>%
filter(!manufacturer %in% c("volkswagen", "chevrolet")) %>%
filter(class %in% c("compact", "midsize", "subcompact")) %>%
group_by(class, manufacturer) %>%
dplyr::summarise(count = n()) %>%
ungroup()
## Doesn't work
hc_category <-
mpgg %>%
hc_xy(
x = "manufacturer",
y = "count",
type = "bar",
category = "class",
label_parameters = list(
align = "left",
crop = T,
enabled = T,
useHTML = T,
format = "<h3>{point.y}</h3>"
)
)
hc_category
# axis_labels -------------------------------------------------------------
hc_axis_label <-
hc_xy(
data = highcharter::favorite_bars,
x = "bar",
y = "percent",
type = "bar",
override_y_text = "percentage of tastiness",
override_y_label = list(format = "{value}% FOOL"),
override_x_label = list(style = list(fontSize = "20px")),
label_parameters = list(
crop = T,
enabled = T,
formatter = JS(
"function(){
return Highcharts.numberFormat(this.point.y, 2) + '%';
}"
),
align = 'center',
color = '#FFFFFF',
x = -10
)
)
hc_axis_label
hc_reversed_axis_label <-
hc_xy(
data = highcharter::favorite_bars,
x = "bar",
y = "percent",
type = "bar",
gridLineWidth = 10,
verticalAlign = "center",
reversed = T,
allowDecimals = F,
title = "MY TITLE",
override_y_text = list(text = "THE percentage of tastiness",
style = list(fontSize = "30px")),
override_y_label = list(format = "{value}% FOOL",
style = list(fontSize = "30px"))
)
hc_reversed_axis_label
# map density ---------------------------------------------------------------------
hc_iris_map_density <- iris %>%
select_if(is.numeric) %>%
as_tibble() %>%
purrr::map(stats::density) %>%
hc_xy(facet_column_count = 1)
hc_iris_map_density
# hc_parameters -----------------------------------------------------------
## STACK
## https://api.highcharts.com/highcharts/series.area.softThreshold
hc_area_label <- mtcars %>%
hc_xy(
x = "am",
y = "mpg",
group = "cyl" ,
type = "area",
override_x_text = list(text = "Koh"),
override_y_text = list(text = "Wennie"),
theme_name = "538",
title = "A Heatmap",
color_palette = "fishualize::Cephalopholis_argus",
subtitle = "A",
caption = "caption",
credits = "credits",
lineWidth = 5,
point_width = 0,
softThreshold = F,
stack = 100,
skipKeyboardNavigation = T,
showCheckbox = T,
label_parameters = list(enabled = T)
)
hc_area_label
hc_stepped_area <-
mtcars %>%
asbviz::hc_xy(
x = "drat",
y = "mpg",
group = "cyl" ,
type = "area",
override_x_text = list(text = "Koh"),
override_y_text = list(text = "Wennie"),
theme_name = "better_unica",
title = "A Heatmap",
color_palette = "fishualize::Cephalopholis_argus",
subtitle = "A",
caption = "caption",
credits = "credits",
point_width = 0,
softThreshold = F,
skipKeyboardNavigation = T,
label_parameters = list(enabled = T),
trackByArea = T,
override_series = list(step = "right")
)
hc_stepped_area
# radials -----------------------------------------------------------------
df <-
read_csv("http://bl.ocks.org/bricedev/raw/458a01917183d98dff3c/sf.csv") %>%
janitor::clean_names()
df <- df %>%
mutate(
id = seq(nrow(df)),
date2 = as.Date(ymd(date)),
tmstmp = datetime_to_timestamp(date2),
month = month(ymd(date))
)
tbl_temp <-
df %>%
select(date2, max = max_temperature_c, min = min_temperature_c) %>%
gather(variable, temperature, -c(date2))
## line
hc_line_temp <-
tbl_temp %>%
asbviz::hc_xy(
x = "date2",
y = "temperature",
type = "line",
color_type = "continuous",
color_palette = "pals::kovesi.diverging_isoluminant_cjm_75_c23",
group = "variable",
override_y_label = list(format = "{value}?C"),
override_x_format = list(format = "{value: %b}")
) %>%
hc_xAxis(type = "datetime",
tickInterval = 30 * 24 * 3600 * 1000)
hc_line_temp
### COLUMN
hc_column_time <-
tbl_temp %>%
arrange(date2) %>%
hc_xy(
x = "date2",
y = "temperature",
type = "column",
color_type = "continuous",
color_palette = "pals::kovesi.diverging_isoluminant_cjm_75_c23",
group = "variable",
stacking = "normal",
override_y_label = list(format = "{value}?C"),
override_x_format = list(format = "{value: %b}")
) %>%
hc_xAxis(type = "datetime",
tickInterval = 30 * 24 * 3600 * 1000)
hc_column_time
## Column with All!
df_weather <-
df %>%
mutate(color = colorize(mean_temperature_c),
y = max_temperature_c - min_temperature_c) %>%
select(date2,
y,
color,
mean = mean_temperature_c,
max = max_temperature_c,
min = min_temperature_c) %>%
gather(variable, value, -c(date2, color)) %>%
mutate(variable = factor(
x = variable,
levels = c("min", "y", "mean", "max") %>% rev(),
ordered = T
))
hc_full_weather <-
df_weather %>%
hc_xy(
x = "date2",
y = "value",
type = "column",
color_type = "continuous",
color_palette = "pals::kovesi.diverging_isoluminant_cjm_75_c23",
group = "variable",
stacking = "normal",
override_y_label = list(format = "{value}?C"),
override_x_label = list(format = "{value: %b}"),
disable_legend = T
) %>%
hc_xAxis(type = "datetime",
tickInterval = 30 * 24 * 3600 * 1000)
hc_full_weather
hc_column_weather_radial <-
df_weather %>%
hc_xy(
x = "date2",
y = "value",
type = "column",
color_type = "continuous",
color_palette = "pals::kovesi.diverging_isoluminant_cjm_75_c23",
group = "variable",
stacking = "normal",
theme_name = "better_unica",
override_y_label = list(format = "{value}?C"),
override_x_label = list(format = "{value: %b}"),
disable_legend = F,
is_polar = T,
invert_chart = F,
use_fast = F,
title = "My Title"
)
hc_column_weather_radial
hc_bar_radial <- df_weather %>%
hc_xy(
x = "date2",
y = "value",
type = "bar",
color_type = "continuous",
color_palette = "pals::kovesi.diverging_isoluminant_cjm_75_c23",
group = "variable",
stacking = "normal",
theme_name = "better_unica",
override_y_label = list(format = "{value}?C"),
override_x_label = list(format = "{value: %b}"),
disable_legend = F,
is_polar = T
)
hc_bar_radial
hc_line_radial <-
df_weather %>%
hc_xy(
x = "date2",
y = "value",
type = "line",
theme_name = "better_unica",
color_type = "continuous",
color_palette = "pals::kovesi.diverging_isoluminant_cjm_75_c23",
group = "variable",
stacking = "normal",
override_y_label = list(format = "{value}?C"),
override_x_label = list(format = "{value: %b}"),
disable_legend = F,
is_polar = T
)
hc_line_radial
# nyt_heatmap -------------------------------------------------------------
hc_mt_hm <-
mtcars %>%
tibble::rownames_to_column(var = "car") %>%
as_tibble() %>%
tbl_ordered_factor(columns = "car", weight = "mpg") %>%
hc_xy(
x = "cyl",
y = "car",
group = "mpg" ,
type = "heatmap",
override_x_text = list(text = "Koh"),
override_y_text = list(text = "Wennie"),
theme_name = "better_unica",
title = "A Heatmap",
subtitle = "A",
caption = "caption",
credits = "credits",
opacity = .51,
label_parameters = list(enabled = T)
)
hc_mt_hm
# motion_heatmap ----------------------------------------------------------
years <- 10
nx <- 5
ny <- 6
df <- data_frame(year = rep(c(2016 + 1:years - 1), each = nx * ny),
xVar = rep(1:nx, times = years * ny),
yVar = rep(1:ny, times = years * nx))
glimpse(df)
df <- df %>%
group_by(xVar, yVar) %>%
mutate(heatVar = cumsum(rnorm(length(year)))) %>%
ungroup()
df_start <- df %>%
arrange(year) %>%
distinct(xVar, yVar, .keep_all = TRUE)
df_seqc <-
df %>%
group_by(xVar, yVar) %>%
do(sequence = list_parse(select(., value = heatVar)))
data <- left_join(df_start, df_seqc)
limits <-
(unlist(data$sequence)) %>% {
c(min(.), max(.))
}
hc_hm_pre_motion <-
df_start %>%
hc_xy(type = "heatmap",
x = "xVar",
y = "yVar",
group = "heatVar")
motion_labels <- unique(df$year)
hc_hm_motion <-
data %>%
clean_names() %>%
hc_xy(
type = "heatmap",
x = "x_var",
y = "y_var",
group = "heat_var",
motion = "sequence",
motion_labels = motion_labels
)
hc_hm_motion
# bayes_boot_range --------------------------------------------------------
df_logs <- nbastatR::game_logs(seasons = 2022) %>% janitor::clean_names()
players <-
df_logs %>%
group_by(name_player) %>%
summarise(count = n(),
mean_minutes = mean(minutes)) %>%
ungroup() %>%
filter(count >= 30, mean_minutes >= 15) %>%
pull(name_player)
data <-
df_logs %>%
filter(name_player %in% players) %>%
janitor::clean_names()
df <-
df_logs %>%
filter(name_player %in% c('Lonzo Ball', "Jarrett Allen", "Caris LeVert")) %>%
bayes_boot(grouping_variable = "name_player",
metric = "minutes",
widen_data = T)
df <- df %>%
mutate(position = c("G", "C", "G"))
hc_bb_range_minutes_no_group <-
df %>%
arrange(desc(mean)) %>%
tbl_color_group(group_column = "name_player", color_palette = "yarrr::basel") %>%
asbviz::tbl_ordered_factor(columns = "name_player", weight = "mean") %>%
hc_xy(
x = "name_player",
low = "hdi_low",
y = "mean",
sort_y = T,
high = "hdi_high",
color = "color",
type = "columnrange",
invert_chart = T,
theme_name = "538",
zoom_type = NULL
)
hc_bb_range_minutes_group <-
df %>%
arrange(desc(mean)) %>%
hc_xy(
x = "name_player",
low = "hdi_low",
group = "position",
y = "mean",
sort_y = T,
high = "hdi_high",
type = "columnrange",
invert_chart = T,
theme_name = "538",
zoom_type = NULL
)
# prophet -----------------------------------------------------------------
data <-
df_logs %>%
filter(name_player %in% c("Caris LeVert", "Jarrett Allen"))
hc_prophet_bb_beast_nba <-
data %>%
hc_xy(
x = "date_game",
y = "minutes",
marker = "url_player_headshot",
point_size = 5,
group = "name_player",
fits = c("lm", "ranger"),
theme_name = "better_unica",
title = "Prophet + rtemis + highcharter + rBeast + BayesBoot + nbastatR",
use_stock = F,
use_beast = T,
override_legend_location = NULL,
prediction_frequency = "months",
prophet_prediction_period = 10,
share_tooltip = T,
enable_bayes_boot = T,
lag_periods = c(1, 5),
roll_lag_periods = 1,
roll_periods = c(3)
)
hc_prophet_bb_beast_nba
hc_prophet_bb_beast_nba <-
hc_add_bayes_boot(
hc = hc_prophet_bb_beast_nba,
data = data,
x = "date_game",
y = "minutes",
group = "name_player"
)
hc_prophet_bb_beast_nba
# COLUMN RANGE ------------------------------------------------------------
url_file <-
"http://graphics8.nytimes.com/newsgraphics/2016/01/01/weather/assets/new-york_ny.csv"
data <- read_csv(url_file)
data <- mutate(data, dt = datetime_to_timestamp(date))
dtempgather <- data %>%
select(dt, date, starts_with("temp")) %>%
select(-temp_rec_high, -temp_rec_low) %>%
rename(temp_actual_max = temp_max,
temp_actual_min = temp_min) %>%
gather(key, value, -c(dt, date)) %>%
mutate(key = str_replace(key, "temp_", ""))
dtempspread <- dtempgather %>%
separate(key, c("serie", "type"), sep = "_") %>%
spread(type, value)
temps <-
dtempspread %>%
mutate(
serie = factor(serie, levels = c("rec", "avg", "actual")),
color = case_when(
serie == "rec" ~ "#ECEBE3",
serie == "avg" ~ "#C8B8B9",
serie == "actual" ~ "#A90048"
),
serie = fct_recode(
serie,
Record = "rec",
Normal = "avg",
Observed = "actual"
),
y = (min + min) / 2
)
### Override Color - no group
hc_color_weather_range <-
temps %>%
select(-color) %>%
mutate(month = month(date) %>% as.character()) %>%
hc_xy(
x = "date",
high = "max",
low = "min",
type = "columnrange",
group = "month",
disable_legend = T,
theme_name = "better_unica",
override_x_label = list(month = "%B"),
color_palette = "pals::kovesi.diverging_isoluminant_cjm_75_c24",
override_series = list(borderWidth = 0, pointWidth = 4),
override_y_text = list(text = "Temperature"),
override_model_groups = T,
share_tooltip = T,
opacity = .65
) %>%
hc_tooltip(
shared = TRUE,
useHTML = TRUE,
headerFormat = as.character(tags$small("{point.x: %b %d}", tags$br()))
)
hc_color_weather_range
hc_color_weather_range_grouped <-
temps %>%
hc_xy(
x = "date",
high = "max",
low = "min",
type = "columnrange",
color = "color",
theme_name = "better_unica",
group = "serie",
override_x_label = list(month = "%B"),
override_series = list(borderWidth = 0, pointWidth = 4),
override_y_text = list(text = "Temperature"),
share_tooltip = T,
opacity = .5,
) %>%
hc_tooltip(
shared = TRUE,
useHTML = TRUE,
headerFormat = as.character(tags$small("{point.x: %b %d}", tags$br()))
)
hc_color_weather_range_grouped
records <-
data %>%
select(dt, date, temp_rec_high, temp_rec_low) %>%
filter(temp_rec_high != "NULL" | temp_rec_low != "NULL") %>%
mutate_if(is.character, str_extract, "\\d+") %>%
mutate_if(is.character, as.numeric) %>%
gather(type, value, -c(dt, date)) %>%
filter(!is.na(value)) %>%
mutate(type = str_replace(type, "temp_rec_", ""),
type = paste("This year record", type))
pointsyles <- list(
symbol = "circle",
lineWidth = 1,
radius = 4,
fillColor = "#FFFFFF",
lineColor = NULL
)
head(records)
## Add more info
hc_color_weather_range_grouped <-
hc_color_weather_range_grouped %>%
highcharter::hc_add_series(records, "point", hcaes(x = dt, y = value, group = type),
marker = pointsyles)
hc_color_weather_range_grouped
#### ADD PRECIPITATION AS NEW AXIS
axis <-
create_yaxis(
naxis = 2,
heights = c(3, 1),
sep = 0.05,
turnopposite = FALSE,
showLastLabel = FALSE,
startOnTick = FALSE
)
axis
#'
#' Manually add titles (I know this can be more elegant) and options.
#'
axis[[1]]$title <- list(text = "Temperature")
axis[[1]]$labels <- list(format = "{value}?F")
axis[[2]]$title <- list(text = "Precipitation")
axis[[2]]$min <- 0
hc_color_weather_range_grouped<-
hc_yAxis_multiples(hc_color_weather_range_grouped, axis)
hc_color_weather_range_grouped
#' The two axes are ready, now we need to add the data. We will add 12 series
#' -one for each month- but we want to associate one legend for all these
#' 12 series, so we need to use `id` and `linkedTo` parameters and obviously.
#' That's why the id will be a `"p"` for the first element and then `NA` to
#' the other 11 elements and then linked those 11 elements to the first series
#' (`id = 'p'`).
precip <-
select(data, dt, precip_value, month)
hc_color_weather_range_grouped <-
hc_color_weather_range_grouped %>%
hc_add_series(
precip,
type = "area",
hcaes(dt, precip_value, group = month),
name = "Precipitation",
color = "#008ED0",
lineWidth = 1,
yAxis = 1,
fillColor = "#EBEAE2",
id = c("p", rep(NA, 11)),
linkedTo = c(NA, rep("p", 11))
)
#' The same way we'll add the normal precipitations by month.
#'
precipnormal <-
data %>%
select(dt, precip_normal, month) %>%
group_by(month) %>%
filter(row_number() %in% c(1, n())) %>%
ungroup() %>%
fill(precip_normal)
hc_color_weather_range_grouped <-
hc_color_weather_range_grouped %>%
hc_add_series(
precipnormal,
"line",
hcaes(x = dt, y = precip_normal, group = month),
name = "Normal Precipitation",
color = "#008ED0",
yAxis = 1,
id = c("np", rep(NA, 11)),
linkedTo = c(NA, rep("np", 11)),
lineWidth = 1
)
hc_color_weather_range_grouped
# item --------------------------------------------------------------------
df <-
tibble(
name = c(
"The Left",
"Social Democratic Party",
"Alliance 90/The Greens",
"Free Democratic Party",
"Christian Democratic Union",
"Christian Social Union in Bavaria",
"Alternative for Germany"
),
count = c(69, 153, 67, 80, 200, 46, 94),
col = c(
"#BE3075",
"#EB001F",
"#64A12D",
"#FFED00",
"#000000",
"#008AC5",
"#009EE0"
),
abbrv = c("DIE LINKE", "SPD", "GRÜNE", "FDP", "CDU", "CSU", "AfD")
)
hc_item_party <-
df %>% asbviz::hc_xy(
x = "abbrv",
y = "count",
type = "item",
group = "name",
showInLegend = TRUE,
size = "100%",
opacity = 1,
theme_name = "better_unica",
marker_parameters = list(symbol = "square"),
center = list("50%", "75%"),
startAngle = -100,
endAngle = 100
)
hc_item_party
hc_item_party_grouped <-
df %>%
hc_xy(
x = "abbrv",
y = "count",
type = "item",
group = "name",
showInLegend = TRUE,
size = "100%",
opacity = 1,
theme_name = "better_unica",
marker_parameters = list(symbol = "square"),
rows = 5,
startAngle = 0,
endAngle = 0
)
hc_item_party_grouped
hc_faceted_items <-
ggplot2::diamonds %>%
sample_n(10000) %>%
count(color, cut) %>%
mutate(group = cut) %>%
asbviz::hc_xy(
x = "cut",
y = "n",
type = "item",
group = "group",
showInLegend = TRUE,
size = "100%",
facet = "color",
facet_column_count = 1,
opacity = 1,
theme_name = "better_unica",
marker_parameters = list(symbol = "square"),
startAngle = -100,
endAngle = 100
)
hc_faceted_items
# streamgraph -------------------------------------------------------------
tbl_events <- tibble(
year = c(1930, 1941, 1990),
text = c("Start of Hollywood.",
"Start of TV.",
"Independents Rise.")
)
data_plotLine <-
tbl_events %>%
transmute(value = year,
label = purrr::map(text, ~ list(text = .x))) %>%
mutate(color = "#666",
width = 2,
zIndex = 5)
tbl_movies <-
ggplot2movies::movies %>%
select(year, Action:Short) %>%
gather(category, count, -year) %>%
group_by(year, category) %>%
summarise(count = sum(count))
hc_streamgraph_plotline <-
tbl_movies %>%
asbviz::hc_xy(
type = "area",
x = "year",
y = "count",
group = "category",
use_scrollbar = F,
point_size = 0,
point_width = 0,
border_width = 0,
data_x_lines = data_plotLine,
annotations = list(
labelOptions = list(backgroundColor = "rgba(255,255,255,0.5)",
verticalAlign = "top"),
labels = list(list(
point = list(
x = 50,
y = 5157,
xAxis = 0,
yAxis = 0
),
text = "Arbois"
))
)
)
hc_streamgraph_plotline
df <- ggplot2movies::movies %>%
select(year,
Action,
Animation,
Comedy,
Drama,
Documentary,
Romance,
Short) %>%
tidyr::gather(genre, value, -year) %>%
group_by(year, genre) %>%
summarise(n = sum(value)) %>%
ungroup()
hc_invereted_stream_graph <-
asbviz::hc_xy(
data = df,
x = "year",
y = "n",
group = "genre",
type = "streamgraph",
theme_name = "better_unica",
point_size = 0,
point_width = 0,
disable_y = T,
disable_x = T,
invert_chart = T,
color_palette = "pals::kovesi.diverging_isoluminant_cjm_75_c24",
title = "Inverted Streamgraph"
)
hc_invereted_stream_graph
# facets ------------------------------------------------------------------
hc_facet_iris <-
iris %>%
as_tibble() %>%
asbviz::tbl_color_group(
group_column = "Species",
color_palette = "lisa::Jean_MichelBasquiat_1",
color_type = "discrete"
) %>%
asbviz::hc_xy(
facet = "Species",
x = "Sepal.Length",
y = "Sepal.Width",
fits = c("PPR"),
facet_column_count = 2,
color = "color",
facet_height = 500
)
# annotations -------------------------------------------------------------
df <-
fundManageR::fred_symbols(c("W616RC1A027NBEA", "W650RG3A086NBEA")) %>% unnest()
annots <-
list(
labelOptions = list(
shape = "connector",
align = "right",
justify = FALSE,
crop = TRUE,
style = list(fontSize = "0.8em", textOutline = "1px white")
),
labels = list(
list(
point = list(
x = highcharter::datetime_to_timestamp(lubridate::ymd("1992-11-01")),
y = 60,
xAxis = 0,
yAxis = 0
),
text = "Start of Clinton Presidency"
),
list(
point = list(
x = highcharter::datetime_to_timestamp(lubridate::ymd("2000-11-01")),
y = 83,
xAxis = 0,
yAxis = 0
),
text = "End of Clinton Presidency"
),
list(
point = list(
x = highcharter::datetime_to_timestamp(lubridate::ymd("2008-11-01")),
y = 130,
xAxis = 0,
yAxis = 0
),
text = "Start of Obama Presidency"
),
list(
point = list(
x = highcharter::datetime_to_timestamp(lubridate::ymd("2016-11-01")),
y = 155,
xAxis = 0,
yAxis = 0
),
text = "End of Obama Presidency"
)
)
)
hc_beast_line_fred_public_safety <-
df %>%
rename(amount_billions = "value") %>%
janitor::clean_names() %>%
tbl_ordered_factor(weight = "amount_billions", columns = c("name_series")) %>%
hc_xy(
x = "date_data",
y = "amount_billions",
group = "name_series",
type = "areaspline",
name = "id_symbol",
annotations = annots,
opacity = .5,
override_legend_location = NULL,
color_type = "discrete",
color_palette = "lisa::Jean_MichelBasquiat_1",
override_model_groups = T,
stacking = "normal",
title = "U.S. Police Expenditures -- 1959 to 2018",
theme_name = "better_unica",
subtitle = "Data from U.S. BUREAU OF ECONOMIC ANALYSIS via FRED - @abresler analysis",
use_beast = T,
override_y_text = list(text = "$ (Billions) nominal USD")
)
annots <-
list(labels = list(
list(point = list(
x = 5,
y = 5,
xAxis = 0,
yAxis = 0
), text = "Middle"),
list(point = list(
x = 1,
y = 1,
xAxis = 0,
yAxis = 0
), text = "Start")
))
hc_beast_line_fred_public_safety
tourfrance <-
read_csv(
"https://raw.githubusercontent.com/jbkunst/blog/master/data/tour_france_state_8.txt"
)
hc_tour_area <-
tourfrance %>%
mutate(color = "red") %>%
hc_xy(
type = "area",
x = "distance",
y = "elevation",
color = "color",
opacity = 1,
theme_name = "better_unica",
override_y_text = list(text = "Distance"),
override_y_label = list(enabled = T, format = "{value} m"),
override_x_format = list(format = "{value} km"),
title = "Tour de Francia 2017, Etapa 8: <i>Dole - Station des Rousses</i>"
) %>%
hc_tooltip(headerFormat = "Distance: {point.x:.1f} km<br>",
pointFormat = "{point.y} m a. s. l.")
hc_tour_area
df1 <- read_csv(
'"x","y", "text"
27.98,255, "Arbois"
45.5,611,"Montrond"
63,651,"Mont-sur-Monnet"
84,789,"Bonlieu"
129.5,382,"Chassal"
159,443,"Saint-Claude"'
)
df2 <- read_csv(
'"x","y","text"
101.44,1026,"Col de la Joux"
138.5,748,"Côte de Viry"
176.4,1202,"Montée de la Combe<br>de Laisia Les Molunes"'
)
df3 <- read_csv(
'"x","y","text"
96.2,783,"6.1 km climb<br>4.6% on avg."
134.5,540,"7.6 km climb<br>5.2% on avg."
172.2,925,"11.7 km climb<br>6.4% on avg."
'
)
df1_p <- df_to_annotations_labels(df1)
df2_p <- df_to_annotations_labels(df2)
df3_p <- df_to_annotations_labels(df3)
hc_tour_area <-
hc_tour_area %>%
hc_annotations(
list(
labelOptions = list(
backgroundColor = 'rgba(255,255,255,0.5)',
verticalAlign = "top",
y = 15
),
labels = df1_p
),
list(labels = df2_p),
list(
labelOptions = list(
shape = "connector",
align = "right",
justify = FALSE,
crop = TRUE,
style = list(fontSize = "0.8em", textOutline = "1px white")
),
labels = df3_p
)
) %>%
hc_caption(
text = "Este gráfico utiliza la función Anotaciones de Highcharts para colocar
etiquetas en varios puntos de interés. Las etiquetas son <i>responsivas</i> y se ocultarán
para evitar la superposición en pantallas pequeñas."
)
hc_tour_area_2 <-
hc_xy(
data = tourfrance,
type = "area",
x = "distance",
y = "elevation",
opacity = .25,
override_y_text = list(text = "Distance"),
override_y_label = list(enabled = T, format = "{value} m"),
override_x_format = list(format = "{value} km"),
title = "Tour de Francia 2017, Etapa 8: <i>Dole - Station des Rousses</i>",
annotations = list(
labelOptions = list(
shape = "connector",
align = "right",
justify = FALSE,
crop = TRUE,
style = list(fontSize = "0.8em", textOutline = "1px white")
),
labels = list(
list(
point = list(
x = 28,
y = 255,
xAxis = 0,
yAxis = 0
),
text = "Arbois"
),
list(
point = list(
x = 159,
y = 443,
xAxis = 0,
yAxis = 0
),
text = "Saint-Claude"
)
)
)
)
hc_tour_area_2
# basics ------------------------------------------------------------------
df <- tibble(fruit = c("Apples", "Pears", "Banana", "Orange"),
n = c(1, 4, 3, 5)) %>%
mutate(color = generate_colors(4) %>% pull(color))
data <- tbl_color_group(data = df, group_column = "fruit")
hc_basic_bar <-
data %>%
hc_xy(
x = "fruit",
y = "n",
type = "bar",
color = "color",
override_x_text = list(text = ""),
override_y_text = list(text = ""),
disable_y = T,
theme_name = "better_unica",
disable_legend = T,
label_parameters = list(
enabled = TRUE,
format = "{point.y}",
style = list(
color = "black",
textOutline = "none",
fontWeight = "normal"
)
),
zoom_type = NULL
)
hc_basic_bar
## Line
tbl <-
tibble(name = "Tokyo",
value = sample(1:12),
month = month.abb) %>%
bind_rows(tibble(
name = "London",
value = sample(1:12) + 10,
month = month.abb
)) %>%
mutate(month = factor(month, levels = month.abb, ordered = T))
hc_line_combine <-
tbl %>%
hc_xy(
x = "month",
y = "value",
group = "name",
type = "line",
color_palette = "ggthemes::Classic Red-White-Black Light",
color_type = "continuous",
theme_name = "better_unica"
)
hc_line_combine
df <-
tibble(a = sample(1:12),
b = sample(1:12) + 10,
c = sample(1:12) + 20) %>%
mutate(index = 1:n()) %>%
gather(line, value, -index)
hc_line_basic <-
hc_xy(
data = df,
x = "index",
y = "value",
group = "line",
type = "line",
theme_name = "better_unica",
color_type = "continuous",
color_palette = "viridis::viridis"
)
hc_line_basic
# matrix ------------------------------------------------------------------
hc_volcano_matrix <- hc_xy(data = volcano, title = "Matrix")
hc_iris_matrix <-
as.matrix(iris %>% select_if(is.numeric)) %>% as.matrix() %>% t() %>% hc_xy(theme_name = "better_unica")
hc_iris_matrix
mtcars2 <- mtcars[1:20,]
x <- dist(mtcars2)
hc_dist_matrix <-
hc_xy(data = x,
title = "Distance Matrix",
theme_name = "better_unica")
hc_dist_matrix
# correlation -------------------------------------------------------------
hc_mt_corr <- cor(mtcars) %>%
hc_xy(title = "Correlation", theme_name = "better_unica")
hc_mt_corr
# color_axis --------------------------------------------------------------
hc_labeled_color_axis_xy_iris <-
iris %>%
clean_names() %>%
hc_xy(
data = . ,
x = "sepal_length",
y = "sepal_width",
color = NULL,
color_axis = list(min = "blue", max = "red"),
disable_legend = F,
override_tooltip = T,
labels = list(
list(html = "<p>Some <b>important</b><br>text</p>" ,
style = list(left = "150%",
top = "150%")),
list(html = "<p>Some <b>Other</b><br>text</p>" ,
style = list(left = "350%",
top = "150%"))
)
)
hc_labeled_color_axis_xy_iris
hc_mt_scatter_line_color <- hc_xy(
mtcars,
x = "wt",
y = "mpg",
color = "drat",
color_axis = list(min = "yellow", max = "red"),
size = "hp",
theme_name = "better_unica"
)
hc_mt_scatter_line_color
## Basic Scatter
hc_mt_group_scatter <- hc_xy(
data = mpg,
x = "displ",
y = "hwy",
opacity = 1,
theme_name = "better_unica",
group = "class"
)
hc_mt_group_scatter
### LABELS
df <- tibble(index = 1:12,
value = sample(1:12),
size = 1)
hc_line_basic_text <- hc_xy(
data = df,
type = "line",
x = "index",
y = "value",
labels = list(
list(html = "<p>Some <b>important</b><br>text</p>" ,
style = list(left = "150%",
top = "150%"))
)
)
hc_line_basic_text
hc_ts_area_basic <-
hc_xy(AirPassengers, use_stock = T, type = "area")
hc_ts_area_basic
# tilemaps ----------------------------------------------------------------
df <-
tibble(
x = c(1, 2, 2, 3, 4, 4, 5, 6, 6, 7, 7, 7, 8, 8, 8, 8, 8, 9, 9, 9),
y = c(6, 6, 7, 7, 7, 8, 8, 8, 9, 1, 2, 9, 1, 2, 4, 5, 9, 1, 2, 3),
value = c(
7,
7,
7,
7,
7,
7,
6.8,
6,
5.8,
11.7,
9.4,
6,
10.3,
8,
17.7,
2.8,
6.1,
9.9,
10.3,
8.7
),
name = c(
"point 1",
"point 2",
"point 3",
"point 4",
"point 5",
"point 6",
"point 7",
"point 8",
"point 9",
"point 10",
"point 11",
"point 12",
"point 13",
"point 14",
"point 15",
"point 16",
"point 17",
"point 18",
"point 19",
"point 20"
)
)
hc_basic_tilemap <- df %>% hc_xy(
x = "x",
y = "y",
type = "tilemap",
disable_x = T,
disable_y = T,
disable_legend = T
)
hc_basic_tilemap
hc_iris_tile_map <-
iris %>%
asbviz::hc_xy(
x = "Sepal.Length",
y = "Sepal.Width",
group = "Species",
type = "tilemap",
disable_x = T,
disable_y = T,
point_size = 1,
border_width = 1,
label_parameters = list(
enabled = T,
format = "{point.value}",
color = "#000000",
turboThreshold = 1000,
style = list(textOutline = F)
)
)
hc_iris_tile_map
url <-
"https://gist.githubusercontent.com/maartenzam/787498bbc07ae06b637447dbd430ea0a/raw/9a9dafafb44d8990f85243a9c7ca349acd3a0d07/worldtilegrid.csv"
data <- read_csv(url)
data <- rename_all(data, str_replace_all, "\\.", "_")
hc_region_tile_map <-
data %>%
mutate(y = -y) %>%
hc_xy(
x = "x",
y = "y",
group = "region",
name = "name",
type = "tilemap",
theme_name = "538",
override_series = list(
dataLabels = list(
enabled = TRUE,
format = "{point.alpha_2}",
color = "white",
style = list(textOutline = FALSE)
)
)
)
hc_region_tile_map
url <-
"https://gist.githubusercontent.com/maartenzam/787498bbc07ae06b637447dbd430ea0a/raw/9a9dafafb44d8990f85243a9c7ca349acd3a0d07/worldtilegrid.csv"
data <- read_csv(url)
data <- data %>%
rename_all(str_replace_all, "\\.", "_") %>%
select(x, y, name, region, alpha_2)
hc_tilemap_2 <- data %>%
mutate(y = -y) %>%
hc_xy(
x = "x",
y = "y",
name = "name",
group = "region",
type = "tilemap"
) %>%
hc_chart(type = "tilemap") %>%
hc_plotOptions(series = list(
dataLabels = list(
enabled = TRUE,
format = "{point.alpha_2}",
color = "white",
style = list(textOutline = FALSE)
)
)) %>%
hc_tooltip(headerFormat = "",
pointFormat = "<b>{point.name}</b> is in <b>{point.group}</b>") %>%
hc_xAxis(visible = FALSE) %>%
hc_yAxis(visible = FALSE) %>%
hc_size(height = 800)
hc_tilemap_2
# orgcharts ---------------------------------------------------------------
df <- tibble(
from = c("Brazil", "Brazil", "Poland"),
to = c("Portugal", "Spain", "England")
)
hc_org_country <-
df %>%
hc_xy(
type = "organization",
from = "from",
to = "to",
invert_chart = T
)
hc_org_country
hc_org_country_weighted <- tibble(
from = c("Brazil", "Brazil", "Poland"),
to = c("Portual", "Spain", "England"),
weight = c(10005, 2, 2)
) %>%
hc_xy(
type = "organization",
from = "from",
to = "to",
weight = "weight",
use_fast = F,
invert_chart = T
)
hc_org_country_weighted
# fits --------------------------------------------------------------------
data(penguins, package = "palmerpenguins")
penguins <- penguins[complete.cases(penguins),]
hchart(
penguins,
"scatter",
name = "Penguins",
# opacity = 0.35,
hcaes(x = flipper_length_mm, y = bill_length_mm),
regression = TRUE,
regressionSettings = list(
type = "polynomial",
dashStyle = "ShortDash",
color = "skyblue",
order = 3,
lineWidth = 5,
name = "%eq | r2: %r",
hideInLegend = FALSE
)
) %>%
hc_add_dependency("plugins/highcharts-regression.js")
## ASB Viz
hc_palmer_flipper_bill <-
hc_xy(
data = penguins,
theme_name = "better_unica",
x = "flipper_length_mm" ,
y = "bill_length_mm",
color_axis = list(min = "blue", max = "red"),
override_name = "Palmer Penguins",
fits = c("poly", "loess", "lm")
)
hc_palmer_flipper_bill
hc_diamond_price_fit <-
ggplot2::diamonds %>%
sample_n(500) %>%
hc_xy(
x = "carat",
y = "price" ,
group = "cut",
use_fast = F,
point_size = 1.5,
boost = T,
color_palette = "ggthemes::Classic Blue-Red 12",
theme_name = "better_unica",
fits = c("lm"),
override_model_groups = T
)
hc_diamond_price_fit
# heatmap -----------------------------------------------------------------
hc_diamond_heatmap <- ggplot2::diamonds %>%
group_by(cut, color) %>%
summarise(price = mean(price)) %>%
ungroup() %>%
hc_xy(
x = "color",
y = "cut",
group = "price",
type = "heatmap",
title = "A Heatmap of Price and Color"
)
hc_diamond_heatmap
# animation ---------------------------------------------------------------
df <-
fundManageR::fred_symbols(c("SPDYNCBRTINCHN", "SPDYNCBRTINUSA")) %>%
unnest()
hc_birthrate_line_roll <-
df %>%
asbviz::hc_xy(
x = "dateData",
y = "value",
group = "nameSeries",
override_y_text = list(text = "Births Per 1000"),
credits = "Data from FRED via fundManageR -- @abresler",
type = "spline",
fits = c("lm"),
roll_lag_periods = c(1),
roll_periods = 5,
theme_name = "better_unica",
color_type = "discrete",
color_palette = "lisa::PerArnoldi",
title = "US vs PRC Birthrates",
override_series = list(
shadow = T,
animation = list(delay = sequence_time(5), duration = sequence_time(20)),
jitter = list(x = 1, y = 1)
)
)
hc_birthrate_line_roll
hc_random_model_fits <-
tibble(value = rn(numbers = 10)) %>%
mutate(index = 1:n()) %>%
tbl_rt_color_gradient(column = "value") %>%
hc_xy(
x = "index",
y = "value",
color = "color",
type = "scatter",
fits = c("LM", "LOESS", "RF", "CART", "DN"),
theme_name = "clean_unica",
color_type = "discrete",
color_palette = "lisa::PerArnoldi",
override_series = list(
shadow = T,
animation = list(delay = sequence_time(5), duration = sequence_time(20)),
jitter = list(x = 1, y = 1)
)
)
hc_random_model_fits
mt_scatter_animate <-
mtcars %>%
hc_xy(
x = "disp",
y = "hp",
group = "am",
override_model_groups = F,
theme_name = "clean_unica",
color_type = "discrete",
color_palette = "lisa::PerArnoldi",
fits = c("lm", "cart"),
override_series = list(animation = list(
delay = sequence_time(5), duration = sequence_time(9.5)
))
)
mt_scatter_animate
# lists -------------------------------------------------------------------
hc_list_ts <-
list("Female" = fdeaths, "Male" = mdeaths) %>%
hc_xy(type = "line", facet_column_count = 1, title = NULL)
hc_list_ts
# motion ------------------------------------------------------------------
## Gapminder
data(gapminder, package = "gapminder")
glimpse(gapminder)
df <-
tbl_motion_group(
data = gapminder,
x = "lifeExp",
y = "gdpPercap",
size = "pop",
motion_groups = "country",
filter_variable = "year",
filter_type = "min"
)
hc_gap_motion <-
df %>%
hc_xy(
x = "lifeExp",
y = "gdpPercap",
name = "country",
group = "continent",
transformations = "log_y",
size = "pop",
type = "point",
motion = "data",
motion_labels = gapminder$year %>% unique()
)
hc_gap_motion
## Motion Scatter
### Motion Heatmap
years <- 10
nx <- 5
ny <- 6
df <- data_frame(
year = rep(c(2016 + 1:years - 1), each = nx * ny),
xVar = rep(1:nx, times = years * ny),
yVar = rep(1:ny, times = years * nx)
)
df <- df %>%
group_by(xVar, yVar) %>%
mutate(heatVar = cumsum(rnorm(length(year)))) %>%
ungroup()
df_start <- df %>%
arrange(year) %>%
distinct(xVar, yVar, .keep_all = TRUE)
df_seqc <-
df %>%
group_by(xVar, yVar) %>%
do(sequence = list_parse(select(., value = heatVar)))
data <- left_join(df_start, df_seqc)
hc_motion_hm <- hc_xy(
data = data,
x = "xVar",
y = "yVar",
group = "heatVar",
type = "heatmap",
motion = "sequence",
motion_labels = df$year %>% unique(),
title = "A Motion Heatmap"
)
hc_motion_hm
# density -----------------------------------------------------------------
x <- rnorm(10000)
dens <- ggplot2::mpg %>%
group_by(cyl) %>%
do(den = density(.$cty)) %>%
{
.$den
}
names(dens) <- ggplot2::mpg$cyl %>% unique()
hc_list_density <- hc_xy(dens, facet_column_count = 1)
hc_list_density
# hc_density --------------------------------------------------------------
reduce(
dens,
hc_add_series,
.init = highchart(),
type = "area",
fillOpacity = 0.25
) %>%
hc_add_theme(hc_theme_better_unica())
# correlations ------------------------------------------------------------
x <- cor(mtcars)
label_params <- list(
enabled = TRUE,
formatter = JS(
"function(){
return Highcharts.numberFormat(this.point.value, 2);
}"
)
)
hc_mt_corr_label <- x %>% hc_xy(label_parameters = label_params)
hc_mt_corr_label
# lines -------------------------------------------------------------------
data(economics_long, package = "ggplot2")
economics_long2 <- filter(economics_long,
variable %in% c("pop", "uempmed", "unemploy"))
hc_xy_econ_long_mean <-
hc_xy(
data = economics_long2,
x = "date",
y = "value01",
type = "line",
group = "variable",
roll_periods = 5
)
hc_xy_econ_long_mean
tbl <-
tibble(name = "Tokyo",
value = sample(1:12),
month = month.abb) %>%
bind_rows(tibble(
name = "London",
value = sample(1:12) + 10,
month = month.abb
)) %>%
mutate(month = factor(month, levels = month.abb, ordered = T))
hc_temp_line <-
hc_xy(
data = tbl,
x = "month",
y = "value",
type = "line",
group = "name",
override_x_categories = month.abb
)
hc_temp_line
# 3d ----------------------------------------------------------------------
hc_3d_line <- hc_xy(
data = tbl,
x = "month",
y = "value",
type = "column",
group = "name",
override_x_categories = month.abb,
theme_name = "better_unica",
) %>%
hc_chart(type = "column",
options3d = list(
enabled = TRUE,
beta = 15,
alpha = 15
))
hc_3d_line
# timeseries --------------------------------------------------------------
hc_male_deaths <-
hc_xy(data = mdeaths, title = "Male Deaths", type = "line")
hc_male_deaths
hc_line_tsbox_deaths <-
tsbox::ts_c(mdeaths, fdeaths) %>%
hc_xy(theme_name = "better_unica")
hc_line_tsbox_deaths
fc <-
forecast::forecast(fdeaths)
hc_deaths_forecast <-
hc_xy(
fc,
title = "Female Deaths",
type = "spline",
point_width = 0,
point_size = 0
)
hc_deaths_forecast
hc_ts_list <-
list(female = fdeaths, male = mdeaths) %>% hc_xy(type = "line")
hc_ts_list
hs_ts_forecast_list <-
list(female = forecast(fdeaths), male = forecast(mdeaths)) %>% hc_xy(type = "line")
hs_ts_forecast_list
m_stl <- stl(mdeaths, s.window = "periodic", robust = TRUE)
hc_stl_deaths <-
hc_xy(m_stl,
title = "STL",
type = "spline",
theme_name = "better_unica")
hc_stl_deaths
## ETS
fit <- ets(mdeaths)
hc_ets_death_fit <-
hc_xy(
fit,
title = "ETS",
point_size = 0,
point_width = 0,
border_width = 0,
theme_name = "clean_unica"
)
hc_ets_death_fit
hc_pacf <- hc_xy(pacf(mdeaths, plot = FALSE, lag.max = 24), theme_name = "ggplot2")
hc_pacf
# other -------------------------------------------------------------------
df_nba <-
nbastatR::game_logs(
seasons = 2022,
league = "NBA",
season_types = c("Regular Season")
)
d <- nbastatR::days_scores(game_dates = "2022-04-07")
data <-
df_nba %>%
filter(slugTeam %in% dataScoreLineScoreNBA$slugTeam) %>%
filter(pts != 0)
hc_nba_pts_min_marker <-
data %>%
hc_xy(
filters = "minutes >= 10",
type = "point",
x = "minutes",
y = "pts",
name = "namePlayer",
marker = "urlPlayerHeadshot",
marker_parameters = list(width = 30, height = 25),
group = "slugTeam",
title = "PTS by Minutes for {Sys.Date()} Teams",
fits = c("lm", "cart", "dn", "mars", "loess", "ppr"),
override_model_groups = T,
theme_name = "better_unica"
)
hc_nba_pts_min_marker
hc_nba_pts_min_marker_team_facet <-
data %>%
asbviz::hc_xy(
filters = "minutes >= 10",
type = "point",
x = "minutes",
y = "pts",
name = "namePlayer",
facet = "slugTeam",
facet_column_count = 1,
marker = "urlPlayerHeadshot",
marker_parameters = list(width = 30, height = 25),
title = "PTS by Minutes for {Sys.Date()} Teams",
fits = c("lm", "cart", "dn", "mars", "loess", "ppr"),
override_model_groups = T,
color_palette = "ggthemes::Classic Red-White-Black Light",
color_type = "continuous",
theme_name = "better_unica"
)
hc_nba_pts_min_marker_team_facet
hc_nba_pts_min_marker_team_scaled <-
data %>%
filter(minutes >= 10) %>%
pre_process_data(scale_data = T, center = T) %>%
hc_xy(
type = "point",
x = "minutes",
y = "pts",
name = "namePlayer",
marker = "urlPlayerHeadshot",
marker_parameters = list(width = 30, height = 25),
group = "slugTeam",
title = "PTS by Minutes for {Sys.Date()} Teams",
fits = c("lm", "cart", "dn", "mars", "loess", "ppr"),
override_model_groups = T,
theme_name = "better_unica"
)
# hc_trelliscope ----------------------------------------------------------
d <-
data %>%
bin_data(columns = c("fga"),
bins = 4) %>%
select("slugTeam",
"namePlayer",
"pts",
"minutes",
"fgaRange",
"urlPlayerHeadshot") %>%
group_by(slugTeam) %>%
nest() %>%
mutate(
mean_min = data %>% map_dbl( ~ mean(.$minutes)),
mean_pts = data %>% map_dbl( ~ mean(.$pts)),
count_players = data %>% map_dbl( ~ length(.$namePlayer))
) %>%
ungroup()
hc_bin_nba <- d %>%
hc_xy_trelliscope(
data_column_name = "data",
x = "minutes",
y = "pts",
type = "point",
marker = "urlPlayerHeadshot",
group = "fgaRange",
trelliscope_title = "NBA Test Trelli",
name = "namePlayer",
color_type = "continuous",
id_columns = c("slugTeam", "count_players", "mean_pts", "mean_min"),
sort_columns = "count_players",
transformations = c("lm", "loess", "mean_y"),
override_model_groups = T
)
hc_bin_nba
# treemap -----------------------------------------------------------------
data(mpg, package = "ggplot2")
mpgman <- mpg %>%
group_by(manufacturer) %>%
summarise(n = n(),
unique = length(unique(model))) %>%
arrange(-n, -unique) %>%
ungroup()
hc_treemap_mtcars <- mpgman %>%
hc_xy(group = "manufacturer", size = "n", type = "treemap")
hc_treemap_mtcars
# annotations -------------------------------------------------------------
df <-
tibble(x = 1:10,
y = 1:10)
ann_list <- list(labels = list(
list(point = list(
x = 5,
y = 5,
xAxis = 0,
yAxis = 0
), text = "Middle"),
list(point = list(
x = 1,
y = 1,
xAxis = 0,
yAxis = 0
), text = "Start")
))
hc_area_annotations <- df %>%
hc_xy(
x = "x",
y = "y",
type = "area",
annotations = ann_list
)
hc_area_annotations
# caption -----------------------------------------------------------------
hc_caption_bar <-
tibble(
fruit = c("Apples", "Pears", "Banana", "Orange"),
value = c(1, 4, 3, 5),
) %>%
hc_xy(
x = "fruit",
y = "value",
type = "column",
caption = "<b>The caption renders in the bottom, and is part of the exported
chart.</b><br><em>Lorem ipsum dolor sit amet, consectetur adipiscing elit,
sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim
ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip
ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate
velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat
cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est
laborum.</em>'",
reverse = T,
invert_chart = T
)
hc_caption_bar
# wordcloud ---------------------------------------------------------------
library(rvest)
texts <-
read_html("http://www.htmlwidgets.org/develop_intro.html") %>%
html_nodes("p") %>%
html_text()
texts <- texts %>%
sheldon::tokenize_text(simplify = T) %>%
flatten_chr()
hc_widget_wordcloud <-
tibble(word = texts) %>%
count(word, sort = T) %>%
hc_xy(
data = .,
type = "wordcloud",
name = "word",
size = "n"
)
hc_widget_wordcloud
# data_tooltip ------------------------------------------------------------
# chart-in-chart ----------------------------------------------------------
gp <-
gapminder::gapminder %>%
arrange(desc(year)) %>%
distinct(country, .keep_all = TRUE)
gpop <-
gapminder::gapminder %>% create_tooltip_data(x = "year", y = "pop", group = "country")
gptot <- left_join(gp, gpop, by = c("country" = "group"))
hc_basic_gapminder_xy <- gptot %>%
hc_xy(
x = "lifeExp",
y = "gdpPercap",
group = "continent",
size = "pop",
name = "country",
transformations = "log_y"
)
hc_basic_gapminder_xy
hc_basic_gapmidner_chart_in_chart <- gptot %>%
hc_xy(
x = "lifeExp",
y = "gdpPercap",
group = "continent",
color_palette = "pals::kovesi.diverging_isoluminant_cjm_75_c24",
size = "pop",
name = "country",
transformations = "log_y",
data_tooltip = "ttdata",
enable_point_select = T,
data_tooltip_params = list(
chart = list(type = "area"),
title = list(text = "point.name"),
subtitle = list(text = "Population"),
plotOptions = list(series = list(animation = 2000, name = "point.name"))
),
theme_name = "better_unica"
)
hc_basic_gapmidner_chart_in_chart
### Iris
data(iris)
iris <- tbl_df(iris)
iris <- mutate(iris, id = seq_along(Species))
iris_tt <- iris %>%
mutate(id = 1:n()) %>%
select(-Species) %>%
gather(x, y, -id) %>%
create_tooltip_data(x = "x", y = "y", group = "id")
irismini <-
iris %>%
select(-Species) %>%
gather(x, y, -id) %>%
mutate(x = str_replace(x, "\\.", "_"),
x = str_to_lower(x)) %>%
group_by(id) %>%
do(tooltipdata = list_parse2(select(., -id)))
iristot <- left_join(iris, irismini)
hc_iris_chart_in_chart <- hc_xy(
data = iristot,
x = "Sepal.Length",
y = "Sepal.Width",
group = "Species",
data_tooltip = "tooltipdata",
data_tooltip_params = list(
chart = list(type = "area"),
title = list(text = "point.name"),
hc_opts = list(xAxis = list(type = "category")),
plotOptions = list(series = list(animation = 2000, name = "point.name"))
)
)
hc_iris_chart_in_chart
# basic -------------------------------------------------------------------
df_nba <- game_logs(seasons = 2021)
teams_playing <-
dataScoreLineScoreNBA %>% pull(slugTeam) %>% sort()
df_teams <-
df_nba %>%
# filter(slugTeam %in% teams_playing) %>%
mutate(ptsPerMin = pts / minutes)
df_plot <-
df_teams %>%
group_by(slugTeam, namePlayer) %>%
summarise(
ptsPerMin = mean(ptsPerMin, na.rm = T),
minMean = mean(minutes, na.rm = T),
ptsMean = mean(pts, na.rm = T),
fgaMean = mean(fga, na.rm = T)
) %>%
ungroup() %>%
left_join(df_nba_player_dict %>% select(namePlayer, urlPlayerHeadshot),
by = "namePlayer")
hc_nba_pts_min_facet <- df_plot %>%
filter(minMean > 12) %>%
bin_data(columns = "minMean", bins = 4) %>%
asbviz::hc_xy(
group = "slugTeam",
x = "fgaMean",
y = "ptsMean",
facet = "minMeanRange",
name = "namePlayer",
image = "urlPlayerHeadshot",
facet_column_count = 1,
override_series = list(
shadow = T,
animation = list(duration = 2000),
jitter = list(x = 1, y = 1)
),
shadow = T,
transformations = "loess",
override_model_groups = T
)
hc_nba_pts_min_facet
hc_nba_pts_min <-
df_plot %>% left_join(df_nba_player_dict %>% select(namePlayer, urlPlayerHeadshot)) %>%
filter(minMean > 10) %>%
hc_xy(
x = "minMean",
y = "ptsMean",
group = "slugTeam",
name = "namePlayer",
halo_size = 30,
image = "urlPlayerHeadshot",
theme_name = "FT",
title = "2020-21 PTS by Minutes Over 10",
override_series = list(
shadow = T,
animation = list(duration = 2000),
jitter = list(x = 1, y = 1)
),
shadow = T,
transformations = c("loess", "lm", "mean_x", "mean_y"),
override_model_groups = T
)
hc_nba_pts_min
d2 <-
df_nba %>%
select(namePlayer, dateGame, pts) %>%
create_tooltip_data(x = "dateGame", y = "pts", group = "namePlayer") %>%
rename(namePlayer = group)
df <- df_plot %>% left_join(d2) %>% janitor::clean_names()
hc_nba_pts_min_chart_in_chart <-
df %>%
hc_xy(
data = ,
x = "min_mean",
y = "pts_per_min",
group = "slug_team",
name = "name_player",
filters = c("min_mean > 10"),
opacity = 1,
marker = "url_player_headshot",
data_tooltip = "ttdata",
enable_point_select = T,
data_tooltip_params = list(
chart = list(type = "spline"),
title = list(text = "point.name"),
xAxis = list(type = "category"),
# subtitle = list(text = "point.x"),
plotOptions = list(series = list(animation = 2000, name = "point.name"))
),
subtitle = "Data from nbastatR via nbastats API",
title = "2018-2019 PTS by Minutes Over 10",
override_series = list(
shadow = T,
animation = list(duration = 2000),
jitter = list(x = 1, y = 1)
),
shadow = T,
transformations = c("mean_x", "mean_y"),
fits = c("LM", "LOESS"),
override_y_label = list(
formatter = JS(
"function(){
return '' + Highcharts.numberFormat(this.value, 2, '.', ',');
}"
)
),
override_model_groups = T
)
hc_nba_pts_min_chart_in_chart
# other -------------------------------------------------------------------
data(gapminder, package = "gapminder")
gp <-
gapminder %>%
arrange(desc(year)) %>%
distinct(country, .keep_all = TRUE)
gp2 <- gapminder %>%
select(country, year, pop) %>%
nest(-country)
gp2
gp2 <-
gp2 %>%
mutate(
data = map(data, mutate_mapping, hcaes(x = year, y = pop), drop = TRUE),
data = map(data, list_parse)
) %>%
rename(ttdata = data)
gptot <- left_join(gp, gp2, by = "country")
donutdata <- gp %>%
group_by(continent) %>%
summarise(pop = sum(pop / 1e6) * 1e6) %>%
ungroup()
donutdata2 <-
gp %>%
select(continent, lifeExp, gdpPercap) %>%
nest(-continent) %>%
mutate(
data = map(data, mutate_mapping, hcaes(x = lifeExp, y = gdpPercap), drop = TRUE),
data = map(data, list_parse)
) %>%
rename(ttdata = data) %>%
left_join(donutdata)
hc_chart_in_chart_donut <- hc_xy(
data = donutdata2,
type = "pie",
name = "continent",
y = "pop",
innerSize = 375,
data_tooltip = "ttdata",
data_tooltip_params = list(
chart = list(type = "scatter"),
credits = list(enabled = FALSE),
title = list(text = "point.name"),
plotOptions = list(scatter = list(marker = list(radius = 2)))
)
)
hc_chart_in_chart_donut
df_gls <- game_logs(seasons = 2018:2022)
data <-
df_gls %>% filter(namePlayer %>% str_detect("Jarrett Allen"))
hc_nba_player_area_spline <-
data %>% hc_xy(
x = "dateGame",
y = "minutes",
name = "namePlayer",
type = "areaspline",
fillOpacity = .23
)
hc_nba_player_area_spline
hc_nba_player_line <- data %>% hc_xy(
x = "dateGame",
y = "minutes",
name = "namePlayer",
type = "line",
point_size = 0,
point_width = 0,
)
hc_nba_player_line
random_players <-
df_gls %>%
group_by(namePlayer) %>%
summarise(min = mean(minutes, na.rm = T),
games = n()) %>%
arrange(desc(min)) %>%
filter(min > 18, games >= 10) %>%
pull(namePlayer) %>%
sample(3)
data <-
df_gls %>% filter(namePlayer %in% random_players)
hc_xy_random_player_prophet <-
asbviz::hc_xy(
data = data,
x = "dateGame",
y = "pts",
type = 'scatter',
group = "namePlayer",
image = "urlPlayerHeadshot",
point_size = 3,
transformations = c("lm", "loess", "prophet"),
label_parameters = list(enabled = T, html = T),
title = "highcharter + Anomalize + Prophet NBA Test",
subtitle = "Data via nbastatR - 2017-18 Season",
prophet_prediction_period = 30,
prediction_frequency = "months",
border_width = 0,
enable_point_select = T,
override_model_groups = F
)
hc_xy_random_player_prophet
# events ------------------------------------------------------------------
sampled_players <- data$namePlayer %>% unique()
hc_events <-
data %>%
hc_xy(
x = "dateGame",
y = "minutes",
group = "namePlayer",
type = "area",
title = "{sampled_players} Career Minutes",
use_navigator = T,
series_override = list(point = list(events = list(
click = JS("function () {
alert(this.name + '<br>' + this.x);
}")
)))
)
hc_events
# column_ranges -----------------------------------------------------------
# color_override ----------------------------------------------------------
df <-
"https://cdn.jsdelivr.net/gh/highcharts/[email protected]/samples/data/range.json" %>%
jsonlite::fromJSON() %>%
as_tibble() %>%
purrr::set_names(c("datetimeTemp", "low", "high"))
df <- df %>%
mutate(datetimeTemp = (datetimeTemp / 1000) %>% as.POSIXct(origin = "1970-01-01"))
hc_area_spline <- df %>%
hc_xy(
x = "datetimeTemp",
y = "high",
type = "areaspline",
series_override = list(
color = '#FF0000',
negativeColor = '#0088FF',
name = "Temp",
pointPlacement = 'between',
shadow = T,
animation = list(duration = 10000)
)
)
hc_area_spline
hc_non_rt_fit <- df %>%
hc_xy(
x = "datetimeTemp",
y = "high",
type = "point",
series_override = list(
color = '#FF0000',
negativeColor = '#0088FF',
name = "Temp",
pointPlacement = 'between',
shadow = T,
animation = list(duration = 10000),
jitter = list(x = 2, y = .5)
),
regression = T,
override_tooltip = T,
use_regression = T,
regressionSettings = list(
type = "polynomial",
order = 5,
hideInLegend = F
)
)
hc_non_rt_fit
# panning -----------------------------------------------------------------
df_logs <-
game_logs(seasons = 2021:2022)
hc_scatter_pan_jarrett_allen <-
df_logs %>%
filter(namePlayer %in% c("Jarrett Allen")) %>%
hc_xy(
x = "dateGame",
y = "minutes",
type = "scatter",
title = "Jarrett Allen Career Minutes",
use_navigator = T,
marker = "urlPlayerHeadshot",
point_size = 1,
series_override = list(
borderWidth = 0,
description = "Something",
boostThreshold = 1000,
turboThreshold = 8000,
cursor = "pointer",
connectNulls = TRUE,
states = list(hover = list(enabled = T)),
stickyTracking = T,
allowPointSelect = T,
animation = list(duration = 9000),
getExtremesFromAll = T,
skipKeyboardNavigation = T
),
regression = T,
panKey = "shift",
panning = T,
use_regression = T,
regressionSettings = list(
type = "polynomial",
order = 5,
hideInLegend = F
)
)
hc_scatter_pan_jarrett_allen
hc_xy_background <- df_logs %>%
filter(namePlayer %in% c("Jarrett Allen")) %>%
hc_xy(
x = "dateGame",
y = "minutes",
type = "scatter",
title = "Jarrett Allen Career Minutes",
fits = c("LM", "CART", "LOESS"),
use_navigator = T,
image = "urlPlayerThumbnail",
point_size = 1,
series_override = list(
borderWidth = 0,
description = "Something",
boostThreshold = 1000,
turboThreshold = 8000,
cursor = "pointer",
connectNulls = TRUE,
states = list(hover = list(enabled = T)),
stickyTracking = T,
marker = list(width = 50, height = 50),
shadow = T,
allowPointSelect = T,
animation = list(duration = 9000),
getExtremesFromAll = T,
skipKeyboardNavigation = T
),
panKey = "shift",
panning = T,
backgroundColor = '#FFFFFF',
shadow = T,
plotShadow = T,
plotBackgroundImage = "https://ak-static.cms.nba.com/wp-content/uploads/headshots/nba/latest/260x190/1628386.png"
)
hc_xy_background
# PYRAMID -----------------------------------------------------------------
library(idbr)
idbr::idb_api_key("35f116582d5a89d11a47c7ffbfc2ba309133f09d")
yrs <- seq(1980, 2030, by = 1)
df <- map_df(c("male", "female"), function(sex) {
idbr::idb1("US", yrs, sex = sex) %>%
mutate(sex_label = sex)
}) %>%
janitor::clean_names()
df <- df %>%
mutate(population = pop * ifelse(sex_label == "male", -1, 1))
d <-
df %>%
group_by(sex_label, age) %>%
do(data = list(sequence = .$population)) %>%
ungroup() %>%
group_by(sex_label) %>%
do(data = .$data) %>%
mutate(name = sex_label)
year_no <- "2022"
hc_pyramid <- df %>%
filter(time == year_no) %>%
hc_xy(
x = "age",
y = "population",
type = "bar",
color_type = "discrete",
color_palette = "lisa::Jean_MichelBasquiat_1",
group = "sex_label",
stacking = "normal",
title = "US Age Pyramid: {year_no}"
) %>%
hc_plotOptions(bar = list(
groupPadding = 0,
pointPadding = 0,
borderWidth = 0
)) %>%
hc_tooltip(shared = TRUE) %>%
hc_yAxis(labels = list(
formatter = JS("function(){ return Math.abs(this.value) / 1000000 + 'M'; }")
),
tickInterval = 0.5e6) %>%
hc_tooltip(
shared = FALSE,
formatter = JS(
"function () { return '<b>' + this.series.name + ', age ' + this.point.category + '</b><br/>' + 'Population: ' + Highcharts.numberFormat(Math.abs(this.point.y), 0);}"
)
)
hc_pyramid
# sankey ------------------------------------------------------------------
UKvisits <- data.frame(
origin = c(
"France",
"Germany",
"USA",
"Irish Republic",
"Netherlands",
"Spain",
"Italy",
"Poland",
"Belgium",
"Australia",
"Other countries",
rep("UK", 5)
),
visit = c(
rep("UK", 11),
"Scotland",
"Wales",
"Northern Ireland",
"England",
"London"
),
weights = c(
c(12, 10, 9, 8, 6, 6, 5, 4, 4, 3, 33) / 100 * 31.8,
c(2.2, 0.9, 0.4, 12.8, 15.5)
)
) %>%
as_tibble()
sankey_params_labeled <- list(
allowPointSelect = T,
stickyTracking = T,
curveFactor = .25,
nodePadding = 40,
nodeWidth = 20,
linkOpacity = .7,
dataLabels = list(
formatter = JS(
"function(){
return Highcharts.numberFormat(this.point.weight, 2,'.', ',') + 'M';
}"
),
style = list(fontSize = "1em"),
crop = F,
useHTML = F,
x = 1,
zIndex = 10,
allowOverlap = T,
verticalAlign = "middle"
)
)
hc_sankey_diamonds <-
hc_xy(
data = ggplot2::diamonds,
group = c("cut", "color", "clarity"),
type = "sankey",
title = "DIAMONDS GROUP EXAMPLE",
sankey = sankey_params_labeled,
theme_name = "better_unica"
)
hc_sankey_diamonds
hc_sankey_diamonds <-
hc_sankey_diamonds %>%
hc_chart(spacingBottom = 50,
events = list(
render = JS(
"function() {
labels = ['column 1', 'column 2', 'column 3'];
const positions = [30, this.chartWidth / 2, this.chartWidth - 30];
if (this.customLabels) {
this.customLabels.forEach((customLabel, i) => {
customLabel.attr({
x: positions[i],
y: this.chartHeight - 20
});
});
} else {
this.customLabels = [];
labels.forEach((label, i) => {
this.customLabels.push(
this.renderer.text(labels[i])
.attr({
x: positions[i],
y: this.chartHeight - 20,
align: 'center'
})
.css({
fontSize: '1em',
color: 'white'
})
.add()
);
});
}
}"
)
))
hc_sankey_diamonds
sankey_params <- list(
allowPointSelect = T,
stickyTracking = T,
curveFactor = .25,
nodePadding = 20,
nodeWidth = 40,
linkOpacity = 1,
dataLabels = list(
style = list(fontSize = "7px"),
crop = T,
useHTML = F,
x = 1,
zIndex = 10,
allowOverlap = T,
verticalAlign = "middle"
)
)
## Add better params
hc_sankey_diamonds_better <- hc_xy(
data = ggplot2::diamonds,
group = c("cut", "color", "clarity"),
type = "sankey",
title = "DIAMONDS GROUP EXAMPLE",
sankey = sankey_params,
theme_name = "better_unica"
)
hc_sankey_diamonds_better
url <- paste0(
"https://cdn.rawgit.com/christophergandrud/networkD3/",
"master/JSONdata/energy.json"
)
energy <-
jsonlite::fromJSON(url)
dfnodes <-
energy$nodes %>%
as_tibble() %>%
mutate(id = row_number() - 1) %>%
as_tibble()
dfnodes <- dfnodes %>%
mutate(value = runif(
n = nrow(dfnodes),
min = 1,
max = 100
))
dflinks <- tbl_df(energy$links)
dflinks <-
dflinks %>%
left_join(dfnodes %>% dplyr::rename(from = value), by = c("source" = "id")) %>%
left_join(dfnodes %>% rename(to = value), by = c("target" = "id"))
hc_sankey_energy <- hc_xy(
data = dflinks,
from = "from",
to = "to",
weight = "value",
type = "sankey"
)
hc_sankey_energy
# wheel -------------------------------------------------------------------
hc_wheel_sankey <- hc_xy(
data = UKvisits,
from = "origin",
to = "visit",
weight = "weights",
type = "dependencywheel",
title = "Wheel!!",
sankey = sankey_params,
theme_name = "better_unica"
)
hc_wheel_sankey
# sanky -------------------------------------------------------------------
hc_regular_sankey <- hc_xy(
data = UKvisits,
from = "origin",
to = "visit",
sankey = sankey_params,
theme_name = "better_unica",
weight = "weights",
type = "sankey",
title = "SANKEY!!"
)
hc_regular_sankey
# survival ----------------------------------------------------------------
library(survival)
leukemia.surv <- survfit(Surv(time, status) ~ x, data = aml)
hc_xy(leukemia.surv)
# Plot the cumulative hazard function
lsurv2 <- survfit(Surv(time, status) ~ x, aml, type = 'fleming')
fit <- coxph(Surv(futime, fustat) ~ age, data = ovarian)
ovarian.surv <- survfit(fit, newdata = data.frame(age = 60))
hc_surv_range <- hc_xy(leukemia.surv, ranges = T)
hc_surv_range
hc_surv_no_range <- hc_xy(leukemia.surv, ranges = F)
hc_surv_no_range
# Network graph -----------------------------------------------------------
library(igraphdata)
data("karate")
df <- igraph::as_data_frame(karate, what = "edges")
hc_network_karate <- df %>% hc_xy(
type = "networkgraph",
from = "from",
to = "to",
weight = "weight",
layoutAlgorithm = list(enableSimulation = TRUE),
theme_name = "clean_unica",
title = "FUCK",
credits = "THIS",
subtitle = "bigtime",
)
hc_network_karate
hc_network_karate_no_anim <- df %>% hc_xy(
type = "networkgraph",
from = "from",
to = "to",
weight = "weight",
layoutAlgorithm = list(enableSimulation = F)
)
hc_network_karate_no_anim
hc_uk_network_no_anim <- hc_xy(
data = UKvisits,
from = "origin",
to = "visit",
weight = "weights",
type = "networkgraph"
)
hc_uk_network_no_anim
# 2020-05-30 --------------------------------------------------------------
# http://jkunst.com/blog/posts/2020-05-12-30diasdegraficos-parte-1/
conteo_clases <- count(millas, clase)
tbl_count_class <-
ggplot2::mpg %>%
count(class)
tbl_count_class %>%
hc_xy(
x = "class",
y = "n",
type = "column",
invert_chart = T,
override_legend_location = "proximate"
)
tbl_count_class <- tbl_count_class %>%
mutate(class = fct_inorder(class)) %>%
mutate(color = '#ffff00')
hc_color_column <-
hc_xy(
data = tbl_count_class,
x = "class",
y = "n",
type = "column",
title = "Count of car types in the data miles",
disable_legend = T,
invert_chart = T,
theme_name = "better_unica"
)
## Día 2: Lineslíneas
tbl_continents <-
gapminder::gapminder
continents <-
tbl_continents %>%
group_by(year, continent) %>%
summarise(
weighted_per_capita = weighted.mean(gdpPercap, pop),
weighted_life_exp = weighted.mean(lifeExp, pop)
) %>%
ungroup()
hc_lagged_line <-
continents %>%
ungroup() %>%
hc_xy(
type = "line",
group = "continent",
x = "year",
color_type = "continuous",
y = "weighted_life_exp",
theme_name = "better_unica",
lag_periods = 1
)
hc_lagged_line
tbl_2007 <-
gapminder %>% filter(year == 2007)
hc_scatter_per_capital <-
tbl_2007 %>%
hc_xy(
type = "scatter",
name = "country",
group = "continent",
x = "gdpPercap",
color_type = "discrete",
color_palette = "lisa::Jean_MichelBasquiat_1",
y = "lifeExp",
theme_name = "smpl",
title = "2007 Life Expectancy by Per Capita Income",
override_model_groups = T,
override_legend_location = "proximate",
fits = c("RF", "LOESS")
)
text <- "The graph shows us the relationship between
<b> GDP per capita </b> and <b> Life expectancy </ b> for countries in 2007.
It is observed that the large number of countries with low life expectancy belong
to the African continent, of which the majority has low GDP per capita. <br>
For <b> GDP per capita </b> a scale <i> logarithmic </i> due
to the asymmetry of this variable."
tbl_2007 %>%
hc_xy(
type = "scatter",
name = "country",
group = "continent",
x = "gdpPercap",
color_type = "discrete",
color_palette = "lisa::Jean_MichelBasquiat_1",
y = "lifeExp",
size = "pop",
theme_name = "smpl",
transformations = "log_x",
caption = text,
title = "2007 Life Expectancy by Per Capita Income",
override_model_groups = T,
override_legend_location = "proximate",
fits = c("RF", "LOESS")
)
datos::paises
hc_scatter_per_capita <-
hc_xy(
data = datos::paises,
x = "pib_per_capita",
y = "esperanza_de_vida",
group = "continente",
size = "poblacion",
maxSize = 30,
transformations = "log_x"
)
hc_scatter_per_capita
### DONUT
diamantes_cortes <- count(diamantes, corte)
diamantes_cortes <-
mutate(diamantes_cortes, porcentaje = percent(n / sum(n)))
tbl_diamonds_cut <-
ggplot2::diamonds %>% count(cut) %>%
mutate(percent = percent(n / sum(n)))
hc_diamond_cut <-
tbl_diamonds_cut %>%
hc_xy(
name = "cut",
y = "n",
size = "percent",
type = "pie",
label_parameters = list(format = "{point.name}<br>({point.size})", enabled = T),
innerSize = "80%"
)
hc_diamond_donut_chart_in_chart <- tbl_diamonds_cut %>%
hc_xy(
name = "cut",
y = "n",
size = "percent",
type = "pie",
label_parameters = list(format = "{point.name}<br>({point.size})", enabled = T),
innerSize = "80%"
) %>%
hc_tooltip(
useHTML = TRUE,
style = list(fontSize = "30px"),
headerFormat = "",
pointFormat = "<div style='text-align: center;'>Cut <b>{point.name}</b><br>{point.y} Cases<br>{point.percent} of total</div>",
positioner = JS(
"function () {
/* one of the most important parts! */
xp = this.chart.chartWidth/2 - this.label.width/2
yp = this.chart.chartHeight/2 - this.label.height/2
return { x: xp, y: yp };
}"
),
shadow = FALSE,
borderWidth = 0,
backgroundColor = "transparent",
hideDelay = 1000
)
#### RIDGE LINES
clima <-
datos::clima %>%
mutate(fecha = lubridate::ymd(paste(anio, mes, dia, paste = "-")),
mes_fecha = fct_inorder(months(fecha)))
hc_clima_ridgeline <-
hc_xy(
data = clima,
x = "temperatura",
group = "mes_fecha",
type = "ridgeline",
theme_name = "better_unica",
zIndex = 12:1,
lineWidth = 3,
title = "Ridgelines",
color_palette = "pals::jet",
opacity = 1,
disable_x = F,
disable_y = T,
invert_chart = T
)
## STREAM GRAPH
movies <- ggplot2movies::movies
films <-
movies %>%
select(year, Action:Short) %>%
gather(category, count, -year) %>%
group_by(year, category) %>%
summarise(count = sum(count))
hc_movies_streamgraph <-
hc_xy(
data = films,
type = "area",
x = "year",
y = "count",
group = "category",
color_palette = "viridis::inferno",
color_type = "continuous",
opacity = .5,
override_y_label = list(
formatter = JS(
"function(){
return '' + Highcharts.numberFormat(this.value, 0, '.', ',') + ' films';
}"
)
),
stacking = "normal",
override_series = list(
stacking = list(enbled = TRUE),
marker = list(symbol = "circle")
),
override_tooltip = F
) %>%
hc_tooltip(table = TRUE, sort = TRUE)
hc_movies_streamgraph
### PLOT LINES
events <- tibble(
year = c(1930, 1941, 1990),
text = c(
"Beginning was golden in Hollywood.",
"Start of TV",
"Beginning of the rise of independent cinema."
)
)
data_plot_line_x <-
events %>%
transmute(value = year,
label = map(text, ~ list(text = .x))) %>%
mutate(color = "#666",
width = 2,
zIndex = 5)
movie_caption <-
"Data from <b> IMDB </b> through the better_unicamovies package. <br>Most events were obtained from flash reading in <b> Wikipedia </b>"
hc_bad_ass_films <-
hc_xy(
data = films,
type = "area",
x = "year",
y = "count",
group = "category",
color_palette = "viridis::inferno",
color_type = "continuous",
opacity = 1,
theme_name = "clean_unica",
caption = movie_caption,
title = "Popularity of Movies by Type Over Time",
override_y_label = list(
formatter = JS(
"function(){
return '' + Highcharts.numberFormat(this.value, 0, '.', ',') + ' films';
}"
)
),
stacking = "normal",
data_x_lines = data_plot_line_x,
override_series = list(
stacking = list(enbled = TRUE),
marker = list(symbol = "circle")
),
override_tooltip = F
) %>%
hc_tooltip(table = TRUE, sort = TRUE)
tbl_mpg_count <- ggplot2::mpg %>%
count(class, cyl) %>%
arrange(-n) %>%
mutate(
class = fct_inorder(class),
class_n = as.numeric(class) - 1,
cyl = factor(cyl, c(4, 5, 6, 8))
)
### CATEGORIES
hc_mpg_category_count <-
tbl_mpg_count %>% hc_xy(
x = "class_n",
y = "n",
group = "cyl",
type = "column",
stacking = "normal",
color_type = "continuous",
color_palette = "pals::jet",
override_x_categories = levels(tbl_mpg_count %>% pull(class))
)
hc_mpg_category_count
# 2020-06-06_part_3 -------------------------------------------------------
tourfrance <-
read_csv(
"https://raw.githubusercontent.com/jbkunst/blog/master/data/tour_france_state_8.txt"
)
hc21 <-
hchart(tourfrance, "area", hcaes(distance, elevation), fillOpacity = 0.25) %>%
hc_title(text = "Tour de Francia 2017, Etapa 8: <i>Dole - Station des Rousses</i>") %>%
hc_subtitle(text = "Ejemplo obtendido de la documentación de HighchartsJS") %>%
hc_xAxis(labels = list(format = "{value} km"),
title = list(text = "Distancia")) %>%
hc_yAxis(labels = list(format = "{value} m"),
title = list(text = "Elevación")) %>%
hc_tooltip(headerFormat = "Distance: {point.x:.1f} km<br>",
pointFormat = "{point.y} m a. s. l.")
hc_tour_area <-
tourfrance %>% mutate(color = "navy") %>%
hc_xy(
type = "area",
opacity = .5,
x = "distance",
y = "elevation",
subtitle = "Example obtained from HighchartsJS documentation",
override_x_label = list(format = "{value} km"),
override_x_text = list(text = "Distance"),
override_y_label = list(format = "{value} m"),
override_y_text = list(text = "Elevation"),
title = "Tour de Francia 2017, Stage 8: <i>Dole - Station des Rousses</i>",
disable_legend = T
) %>%
hc_tooltip(headerFormat = "Distance: {point.x:.1f} km<br>",
pointFormat = "{point.y} m a. s. l.")
hc_tour_area
df1 <- read_csv(
'"x","y", "text"
27.98,255, "Arbois"
45.5,611,"Montrond"
63,651,"Mont-sur-Monnet"
84,789,"Bonlieu"
129.5,382,"Chassal"
159,443,"Saint-Claude"'
)
df2 <- read_csv(
'"x","y","text"
101.44,1026,"Col de la Joux"
138.5,748,"Côte de Viry"
176.4,1202,"Montée de la Combe<br>de Laisia Les Molunes"'
)
df3 <- read_csv(
'"x","y","text"
96.2,783,"6.1 km climb<br>4.6% on avg."
134.5,540,"7.6 km climb<br>5.2% on avg."
172.2,925,"11.7 km climb<br>6.4% on avg."
'
)
df1_p <- df_to_annotations_labels(df1)
df2_p <- df_to_annotations_labels(df2)
df3_p <- df_to_annotations_labels(df3)
hc_tour_area <-
hc_tour_area %>%
hc_annotations(
list(
labelOptions = list(
backgroundColor = 'rgba(255,255,255,0.5)',
verticalAlign = "top",
y = 15
),
labels = df1_p
),
list(labels = df2_p),
list(
labelOptions = list(
shape = "connector",
align = "right",
justify = FALSE,
crop = TRUE,
style = list(fontSize = "0.8em", textutline = "1px white")
),
labels = df3_p
)
)
hc_tour_area
#
# read_html("https://github.com/cienciadedatos/r4ds") %>%
# html_nodes("a.js-navigation-open") %>%
# html_text() %>%
# str_subset("[0-9]{2}.*.Rmd") %>%
# dput()
sections <- c(
"intro.Rmd",
"data-visualize.Rmd",
"workflow-basics.Rmd",
"transform.Rmd",
"workflow-scripts.Rmd",
"eda.Rmd",
"workflow-projects.Rmd",
"wrangle.Rmd",
"tibble.Rmd",
"import.Rmd",
"tidy.Rmd",
"relational-data.Rmd",
"strings.Rmd",
"factors.Rmd",
"datetimes.Rmd",
"program.Rmd",
"pipes.Rmd",
"functions.Rmd",
"vectors.Rmd",
"iteration.Rmd",
"model.Rmd",
"model-basics.Rmd",
"model-building.Rmd",
"model-many.Rmd",
"communicate.Rmd",
"rmarkdown.Rmd",
"communicate-plots.Rmd",
"formats.Rmd",
"workflow.Rmd"
)
r4ds <-
purrr::map_df(sections, function(section = "formats.Rmd") {
message(section)
url <-
glue("https://raw.githubusercontent.com/hadley/r4ds/master/{section}") %>% as.character()
read_lines_safe <- possibly(read_lines, tibble())
lines <-
read_lines_safe(url)
if (length(lines) == 0) {
return(tibble())
}
data_frame(section = section,
text = lines)
})
r4ds <- r4ds %>%
mutate(
section_number = as.numeric(str_extract(section, "[0-9]{2}")),
chapter = case_when(
section_number <= 1 ~ "1. Welcome",
section_number <= 8 ~ "2. Explore",
section_number <= 16 ~ "3. Manage data",
section_number <= 21 ~ "4. Program",
section_number <= 25 ~ "5. Model",
section_number <= 30 ~ "6. Communicate",
)
)
r4ds2 <-
r4ds %>%
unnest_tokens(word, text) %>%
mutate(
word = str_to_lower(word),
word = str_remove_all(word, "_"),
word = str_remove_all(word, "[0-9]+"),
word = str_remove_all(word, "[:punct:]+"),
word = str_trim(word)
) %>%
filter(word != "") %>%
anti_join(tibble(word = stopwords::stopwords(language = "en")), by = "word")
r4ds2 <-
r4ds2 %>%
count(section, word, sort = TRUE)
total_r4ds2 <-
r4ds2 %>%
group_by(section) %>%
dplyr::summarise(total = sum(n))
r4ds2 <- left_join(r4ds2, total_r4ds2)
r4ds2 <- r4ds2 %>%
bind_tf_idf(word, section, n)
r4ds2_top50 <- r4ds2 %>%
arrange(desc(tf_idf)) %>%
mutate(word = factor(word,
levels = rev(unique(word)))) %>%
group_by(section) %>%
top_n(50) %>%
ungroup()
r4ds2_top50 <-
r4ds2_top50 %>%
arrange(desc(tf_idf)) %>%
add_row(
section = "",
word = "R4DS",
tf_idf = max(r4ds2_top50$tf_idf) * 2
)
fntfmly <-
'-apple-system, BlinkMacSystemFont, "Segoe UI", Roboto, Helvetica, Arial, sans-serif, "Apple Color Emoji", "Segoe UI Emoji", "Segoe UI Symbol"'
hc_wordcloud_tf_idf <-
hc_xy(
data = r4ds2_top50,
type = "wordcloud",
name = "word",
size = "tf_idf",
color = "section",
override_series = list(
style = list(fontFamily = fntfmly, fontWeight = "bold"),
tooltip = list(pointHeader = "<b>{point.key}</b>",
pointFormat = "Section <b>{point.section}</b><br>TF-IDF: {point.size:0.4f}")
)
)
hc_wordcloud_tf_idf
hc_treemap_gap_base <-
tbl_2007 %>% hc_xy(
group = c("continent", "country"),
size = "pop",
type = "treemap",
is_sunburst = T,
title = "2007 Gapminder",
tree_labels = list(
list(
level = 1,
borderWidth = 0,
borderColor = "transparent",
colorByPoint = TRUE,
dataLabels = list(enabled = TRUE)
),
list(
level = 2,
borderWidth = 0,
borderColor = "transparent",
colorVariation = list(key = "brightness", to = 0.50),
dataLabels = list(enabled = TRUE)
)
)
)
hc_treemap_gap_base
hc_treemap_gm <-
tbl_2007 %>%
mutate(world = "world") %>%
hc_xy(
group = c("world", "continent", "country"),
size = "pop",
use_new_treemap = T,
type = "treemap",
is_sunburst = T,
tree_labels = list(
list(
level = 1,
borderWidth = 0,
color = "transparent",
borderColor = "transparent",
# colorByPoint = TRUE,
dataLabels = list(enabled = TRUE)
),
list(
level = 2,
borderWidth = 0,
borderColor = "transparent",
colorByPoint = TRUE,
dataLabels = list(enabled = TRUE)
),
list(
level = 3,
borderWidth = 0,
borderColor = "transparent",
colorVariation = list(key = "brightness", to = 0.50),
dataLabels = list(enabled = TRUE)
)
)
)
hc_treemap_gm
aeropuertos <-
read_csv(
"https://raw.githubusercontent.com/jpatokal/openflights/master/data/airports.dat",
col_names = FALSE
)
aeropuertos <- aeropuertos %>%
filter(X4 == "Chile") %>%
select(nombre = X2, lon = X8, lat = X7) %>%
filter(lat <= 0, lon >= -90)
hc24 <- hcmap("countries/cl/cl-all", showInLegend = FALSE) %>%
hc_add_series(
data = aeropuertos,
type = "mappoint",
name = "Aeropuertos de Chile",
tooltip = list(pointFormat = "{point.nombre} ({point.lat:0.2f}, {point.lon:0.2f})")
)
hc24
p25 <-
ggplot(datos::flores,
aes(x = Largo.Sepalo,
y = Especie)) +
geom_violin()
dflores <-
datos::flores %>%
distinct(Especie) %>%
mutate(y = as.numeric(Especie))
d25 <- as_tibble(layer_data(p25,
1)) %>%
select(x, y, violinwidth, size, ndensity) %>%
mutate_all(round, 3) %>%
mutate(y = as.numeric(y)) %>%
left_join(dflores, by = "y")
d25 <- d25 %>%
filter(row_number() %% 2 == 0)
hc25 <- hchart(
d25,
"arearange",
hcaes(
x,
low = y - violinwidth * size - 1,
high = y + violinwidth * size - 1,
group = Especie
)
) %>%
hc_yAxis(
categories = dflores$Especie,
type = "categorical",
endOnTick = FALSE,
startOnTick = FALSE,
title = list(text = "Especies")
) %>%
hc_xAxis(title = list(text = "Largo del Sépalo")) %>%
hc_tooltip(useHTML = TRUE,
pointFormat = "<span style='color:{point.color};'>●</span> {series.name}: <b>{point.x:,.4f}</b><br/>")
hc25
hc_iris_violin <-
hc_xy(
data = iris,
y = "Species",
x = "Sepal.Width",
type = "violin",
disable_x = T,
color_palette = "viridis::viridis"
)
hc_iris_violin
hc_iris_violin %>%
hc_tooltip(useHTML = TRUE,
pointFormat = "<span style='color:{point.color};'>●</span> {series.name}: <b>{point.x:,.4f}</b><b><br>Density Low:</b> {point.low:,.4f}<br/><b><br>Density High:</b> {point.high:,.4f}")
# crazy_neywork -----------------------------------------------------------
# install.packages("economiccomplexity")
library(economiccomplexity)
data(world_trade_avg_1998_to_2000)
glimpse(world_trade_avg_1998_to_2000)
world_trade_avg_1998_to_2000 <- world_trade_avg_1998_to_2000 %>%
filter(!country %in% c("ant", "rom", "scg", "fsm", "umi"))
bi <- balassa_index(world_trade_avg_1998_to_2000)
pro <- proximity(bi)
net <- projections(pro$proximity_country, pro$proximity_product)
dfaggregated_countries <- aggregate(
world_trade_avg_1998_to_2000$value,
by = list(country = world_trade_avg_1998_to_2000$country),
FUN = sum
)
aggregated_countries <-
setNames(dfaggregated_countries$x, dfaggregated_countries$country)
V(net$network_country)$size <-
aggregated_countries[match(V(net$network_country)$name, names(aggregated_countries))]
red <- net$network_country
g <- ggraph(red, layout = "auto") +
geom_edge_link(edge_colour = "#a8a8a8") +
geom_node_point(aes(size = size), color = "#86494d") +
geom_node_text(aes(label = name), size = 2, vjust = 2.2) +
ggtitle("Proximity Based Network Projection for Products") +
theme_void()
g
# igrapg_plot -------------------------------------------------------------
dfvertices <-
graphlayouts::layout_igraph_stress(net$network_country) %>%
as_tibble()
dfvertices <- dfvertices %>%
mutate(exportacion_millones = round(size / 1e6),
iso3c = toupper(name)) %>%
left_join(countrycode::codelist %>%
select(iso3c, iso2c, nombre = cldr.name.es_cl),
by = "iso3c")
dfvertices <- dfvertices %>%
ungroup() %>%
mutate(color = colorize(size / max(size), colors = scales::viridis_pal(option = "B")(10))) %>%
rowwise() %>%
mutate(marker = list(marker = list(fillColor = color))) %>%
select(-color)
# glimpse(dfvertices)
# glimpse(countrycode::codelist)
# aristas
dfaristas <- red %>%
get.edgelist() %>%
data.frame(stringsAsFactors = FALSE) %>%
tbl_df() %>%
setNames(c("from", "to"))
dfaristas <- dfaristas %>%
left_join(dfvertices %>% select(from = name, xf = x, yf = y),
by = "from")
dfaristas <- dfaristas %>%
left_join(dfvertices %>% select(to = name, xt = x, yt = y),
by = "to")
dfaristas2 <- red %>%
edge_attr() %>%
data.frame(stringsAsFactors = FALSE) %>%
tbl_df()
dfaristas <- bind_cols(dfaristas, dfaristas2)
dfaristas <- dfaristas %>%
mutate(id = row_number()) %>%
gather(key, value, -weight, -from, -to, -id) %>%
mutate(key = stringr::str_remove_all(key, "f|t")) %>%
group_by(id, key) %>%
mutate(id2 = row_number()) %>%
spread(key, value)
dfaristas_info <- dfaristas %>%
group_by(from, to, weight, id) %>%
summarise_at(vars(x, y), mean) %>%
ungroup() %>%
mutate(
weight = round(100 * weight, 2),
from_iso2 = countrycode::countrycode(from, origin = "iso3c", destination = "iso2c"),
to_iso2 = countrycode::countrycode(to, origin = "iso3c", destination = "iso2c")
)
dfaristas <- dfaristas %>%
select(x, y, id) %>%
ungroup()
hc20 <- highchart() %>%
# opciones generales
hc_plotOptions(series = list(
color = hex_to_rgba("gray", 0.2),
marker = list(enabled = FALSE),
states = list(inactive = list(opacity = 1))
)) %>%
hc_boost(enabled = FALSE) %>%
hc_chart(zoomType = "xy") %>%
hc_tooltip(useHTML = TRUE) %>%
hc_xAxis(visible = FALSE) %>%
hc_yAxis(visible = FALSE) %>%
hc_legend(verticalAlign = "top", align = "left") %>%
hc_title(text = "Red basada en proyección de proximidad") %>%
hc_subtitle(text = "Datos y análisis provisto en el paquete {economiccomplexity}<br>
El tamaño corresponde a la exportación promedio de cada país entre los años 98 y 2000") %>%
# vertices
hc_add_series(
dfvertices,
"bubble",
hcaes(x, y, size = size, colorValue = size),
tooltip = list(
headerFormat = "",
pointFormat = "
<center>
<b>{point.nombre}</b><br>
Exportaciones ${point.exportacion_millones} millones USD
<table style=\" height:20px;\">
<center>
<img src=\"https://www.countryflags.io/{point.iso2c}/shiny/64.png\" style=\"text-align: center\">
</center>
<table>
</center>"
),
name = "Países",
minSize = 5,
maxSize = 25,
marker = list(enabled = TRUE, fillOpacity = 1)
) %>%
# aristas
hc_add_series(
dfaristas,
"line",
hcaes(x, y, group = id),
showInLegend = FALSE,
enableMouseTracking = FALSE,
zIndex = -10
) %>%
# info aristas
hc_add_series(
dfaristas_info,
"scatter",
hcaes(x, y),
marker = list(radius = 1),
legend = list(
symbolHeight = 11,
symbolWidth = 11,
symbolRadius = 5
),
tooltip = list(
headerFormat = "",
pointFormat = "<center>
<b>Proximidad</b><br>
{point.weight}%<br>
<table style=\"height:20px!important\">
<tr>
<img src=\"https://www.countryflags.io/{point.from_iso2}/shiny/64.png\" width=\"50%\">
<img src=\"https://www.countryflags.io/{point.to_iso2}/shiny/64.png\" width=\"50%\">
</tr>
</table>
</center>"
),
name = "Información artistas"
)
hc20
# drilldown ---------------------------------------------------------------
data("GNI2014")
GNI2014
df1 <-
tbl_df(GNI2014) %>%
mutate_if(is.factor, as.character) %>%
group_by(name = continent,
id = continent,
drilldown = continent) %>%
summarise(y = sum(population)) %>%
arrange(desc(y))
df2 <-
tbl_df(GNI2014) %>%
arrange(desc(population)) %>%
group_by(id = continent) %>%
do(data = list_parse2(select(., name = country, value = population)))
hc_drilldown_fix <- df1 %>%
ungroup() %>%
tbl_color_group(group_column = "name", color_type = "continuous") %>%
hc_xy(
x = "name",
y = "y",
type = "bar",
color = "color",
disable_legend = T,
drilldown_params = list_parse(df2),
drill = "id"
)
hc_drilldown_fix
# boxplot -----------------------------------------------------------------
hc_iris_bp <- hc_xy(
data = iris,
x = "Species",
y = "Sepal.Length",
type = "boxplot",
title = "Boxplot",
subtitle = "Does it work?"
)
hc_iris_bp
hc_poke_bp <-
highcharter::pokemon %>%
hc_xy(
x = "type_1",
y = "height",
type = "boxplot",
transformations = c("log_y", "mean_y"),
color_pallette = NULL,
color_type = "continuous"
)
hc_poke_bp
df <- ToothGrowth %>% mutate(id = 1:n()) %>% as_tibble()
hc_tooth_bp_mean <- df %>%
hc_xy(
x = "dose",
y = "len",
group = "supp",
type = "boxplot",
transformations = c("log_y", "mean_y"),
color_pallette = NULL,
color_type = "continuous",
order_method = "mean"
)
hc_tooth_bp_mean
hc_tooth_bp_sum <- df %>%
hc_xy(
x = "dose",
y = "len",
group = "supp",
type = "boxplot",
transformations = c("log_y", "mean_y"),
color_pallette = NULL,
color_type = "continuous",
order_method = "sum"
)
hc_tooth_bp_sum
# other_hc_functions ------------------------------------------------------
hc_onlymt_fit <- mtcars %>%
hc_add_rt_fits(
x = "wt",
y = "mpg",
data = .,
fits = c("lm"),
title = "AAA",
theme_name = "better_unica",
group = "cyl"
) %>%
hc_munge(caption = "FUCKKKKKKKK",
theme_name = "538",
zoom_type = "x")
hc_onlymt_fit
# disable_inactive_series -------------------------------------------------
hc_iris_inactive <- iris %>%
hc_xy(
x = "Sepal.Length",
y = "Sepal.Width",
group = "Species",
fits = "lm",
override_model_groups = T,
color_palette = "lisa::Jean_MichelBasquiat_1",
color_type = "discrete"
) %>%
hc_disable_inactive_series()
# bayesian_change_point ---------------------------------------------------
df <- fundManageR::fred_symbols(symbols = c("DGS2", "DGS10"))
df <- df %>%
unnest() %>%
janitor::clean_names()
df <- df %>%
mutate(pct_yield = value * 100)
hc_bp_treasury <- hc_bcp(
hc = NULL,
data = df,
plot_actual = T,
type_actual = "scatter",
x = "date_data",
y = "pct_yield",
group = "id_symbol",
color_type = "discrete",
color_palette = "lisa::Jean_MichelBasquiat_1",
include_change_points = T
)
hc_bp_treasury
hc_bcp_plot <- hc_xy(
data = df,
type = "spline",
x = "date_data",
y = "pct_yield",
group = "id_symbol",
theme_name = "clean_unica",
color_type = "discrete",
color_palette = "lisa::Jean_MichelBasquiat_1",
add_bcp_fits = T,
include_change_points = T,
title = "2 and 10 Year Treasury Rates"
)
hc_bcp_plot
df <-
nbastatR::game_logs(seasons = 2020) %>%
janitor::clean_names() %>%
filter(name_player %in% c("Jarrett Allen", "Caris LeVert"))
hc_bcp_nets <- hc_xy(
data = df,
type = "scatter",
point_size = 10,
x = "number_game_player_season",
y = "minutes",
group = "name_player",
theme_name = "better_unica",
add_bcp_fits = T,
include_change_points = T,
marker = "url_player_headshot",
include_bcp_probabilities = T,
title = "Caris vs JA - 2019-20 - Bayesian Change Point Analysis",
subtitle = "Minutes Played",
override_x_text = list(text = "Game #")
)
hc_bcp_nets