HHI Explained
This app helps explain the meaning of the Herfindahl–Hirschman Index (HHI), which is an index from 0 to 1 that helps explain the level of concentration in a market.
#| '!! shinylive warning !!': |
#| shinylive does not work in self-contained HTML documents.
#| Please set `embed-resources: false` in your metadata.
#| standalone: true
#| viewerHeight: 800
library(shiny)
library(echarts4r)
library(dplyr)
library(bslib)
generate_market_shares <- function(target_hhi, n_companies) {
if (n_companies <= 0) {
return(list(
shares = numeric(0),
n_companies = 0,
actual_hhi = 0,
min_hhi = 0,
max_hhi = 0,
is_achievable = FALSE
))
}
if (n_companies == 1) {
return(list(
shares = 1,
n_companies = 1,
actual_hhi = 1,
min_hhi = 1,
max_hhi = 1,
is_achievable = (target_hhi >= 0.99)
))
}
min_hhi <- 1 / n_companies
max_hhi <- 1.0
is_achievable <- (target_hhi >= min_hhi - 0.001 &&
target_hhi <= max_hhi + 0.001)
if (!is_achievable) {
shares <- rep(1 / n_companies, n_companies)
return(list(
shares = shares,
n_companies = n_companies,
actual_hhi = min_hhi,
min_hhi = min_hhi,
max_hhi = max_hhi,
is_achievable = FALSE
))
}
if (target_hhi <= min_hhi + 0.001) {
shares <- rep(1 / n_companies, n_companies)
} else if (target_hhi >= 0.999) {
shares <- c(0.9999, rep(0.0001 / (n_companies - 1), n_companies - 1))
} else if (n_companies == 2) {
discriminant <- 2 * target_hhi - 1
if (discriminant >= 0) {
s1 <- (1 + sqrt(discriminant)) / 2
shares <- c(s1, 1 - s1)
} else {
shares <- c(0.5, 0.5)
}
} else {
hhi_normalized <- (target_hhi - min_hhi) / (max_hhi - min_hhi)
exponent <- 0.2 + hhi_normalized * 4
ranks <- 1:n_companies
shares <- (1 / ranks)^exponent
shares <- shares / sum(shares)
for (iteration in 1:2000) {
current_hhi <- sum(shares^2)
error <- current_hhi - target_hhi
if (abs(error) < 0.00001) {
break
}
learning_rate <- 0.1 * (0.9^(iteration %/% 100))
if (error > 0) {
transfer <- min(shares[1] * learning_rate, abs(error) * 0.5)
shares[1] <- shares[1] - transfer
shares[n_companies] <- shares[n_companies] + transfer
} else {
transfer <- min(shares[n_companies] * learning_rate, abs(error) * 0.5)
if (shares[n_companies] > transfer) {
shares[1] <- shares[1] + transfer
shares[n_companies] <- shares[n_companies] - transfer
}
}
shares <- pmax(shares, 0.00001)
shares <- shares / sum(shares)
}
}
list(
shares = shares,
n_companies = n_companies,
actual_hhi = sum(shares^2),
min_hhi = min_hhi,
max_hhi = max_hhi,
is_achievable = TRUE
)
}
ui <- page_sidebar(
theme = bs_theme(
version = 5,
bg = "#ffffff",
fg = "#000000",
primary = "#6c757d"
),
sidebar = sidebar(
open = "always",
h4("Market Parameters"),
sliderInput(
"n_companies",
"Number of Companies:",
min = 1,
max = 10,
value = 5,
step = 1
),
sliderInput(
"hhi_target",
"HHI Level:",
min = 0,
max = 1,
value = 0.30,
step = 0.01
),
hr(style = "border-color: #dee2e6;"),
h5("Quick Scenarios"),
actionButton(
"scenario1",
"Perfect Competition",
class = "btn-outline-secondary btn-sm w-100 mb-2"
),
actionButton(
"scenario2",
"Moderate Market",
class = "btn-outline-secondary btn-sm w-100 mb-2"
),
actionButton(
"scenario3",
"Concentrated Market",
class = "btn-outline-secondary btn-sm w-100 mb-2"
),
actionButton(
"scenario4",
"Duopoly",
class = "btn-outline-secondary btn-sm w-100"
)
),
layout_column_wrap(
width = 1 / 3,
value_box(
"HHI Level",
textOutput("hhi_display"),
theme = "white",
style = "border: 1px solid #dee2e6;"
),
value_box(
"Companies",
textOutput("num_companies_display"),
theme = "white",
style = "border: 1px solid #dee2e6;"
),
value_box(
"Market Type",
textOutput("market_status_display"),
theme = "white",
style = "border: 1px solid #dee2e6;"
)
),
uiOutput("hhi_warning"),
card(
card_header("Market Share Distribution"),
echarts4rOutput("pieChart", height = "400px"),
style = "border: 1px solid #dee2e6;"
)
)
server <- function(input, output, session) {
marketData <- reactive({
result <- generate_market_shares(input$hhi_target, input$n_companies)
if (length(result$shares) > 0 && result$n_companies > 0) {
companies_df <- data.frame(
company = LETTERS[1:result$n_companies],
share = result$shares * 100
)
} else {
companies_df <- data.frame()
}
list(
target_hhi = input$hhi_target,
actual_hhi = result$actual_hhi,
n_companies = result$n_companies,
min_hhi = result$min_hhi,
max_hhi = result$max_hhi,
is_achievable = result$is_achievable,
data = companies_df
)
})
output$hhi_display <- renderText(sprintf("%.2f", input$hhi_target))
output$num_companies_display <- renderText(as.character(input$n_companies))
output$market_status_display <- renderText({
if (input$hhi_target < 0.15) {
"Competitive"
} else if (input$hhi_target < 0.25) {
"Moderate"
} else {
"Concentrated"
}
})
output$hhi_warning <- renderUI({
data <- marketData()
if (!data$is_achievable) {
div(
class = "alert alert-danger",
style = "border: 1px solid #f8d7da;",
sprintf(
"With %d companies, HHI must be between %.2f and %.2f.",
data$n_companies,
data$min_hhi,
data$max_hhi
)
)
}
})
output$pieChart <- renderEcharts4r({
data <- marketData()
if (nrow(data$data) == 0) {
data.frame(x = 1, y = 1) |>
e_charts() |>
e_title(
text = "Set parameters to view distribution",
left = "center",
top = "center"
)
} else {
colors <- c(
"#3498db",
"#e74c3c",
"#2ecc71",
"#9b59b6",
"#f39c12",
"#1abc9c",
"#34495e",
"#e67e22",
"#95a5a6",
"#16a085"
)
data$data |>
arrange(desc(share)) |>
e_charts(company) |>
e_pie(
share,
radius = c("40%", "70%"),
label = list(
formatter = "{b}\n{d}%",
fontSize = 14,
fontWeight = "bold"
)
) |>
e_tooltip(
trigger = "item",
formatter = htmlwidgets::JS(
"
function(params) {
return params.name + '<br/>' +
'Market Share: ' + params.value.toFixed(1) + '%<br/>' +
'Proportion: ' + params.percent.toFixed(1) + '%';
}
"
)
) |>
e_legend(right = 10, top = "middle", orient = "vertical") |>
e_color(colors[1:nrow(data$data)])
}
})
observeEvent(input$scenario1, {
updateSliderInput(session, "n_companies", value = 10)
updateSliderInput(session, "hhi_target", value = 0.10)
})
observeEvent(input$scenario2, {
updateSliderInput(session, "n_companies", value = 7)
updateSliderInput(session, "hhi_target", value = 0.20)
})
observeEvent(input$scenario3, {
updateSliderInput(session, "n_companies", value = 5)
updateSliderInput(session, "hhi_target", value = 0.35)
})
observeEvent(input$scenario4, {
updateSliderInput(session, "n_companies", value = 2)
updateSliderInput(session, "hhi_target", value = 0.65)
})
}
shinyApp(ui = ui, server = server)