Sixth R Visuzalization (Shiny App)
library(shiny)
library(dplyr)
##
## Attaching package: 'dplyr'
## The following objects are masked from 'package:stats':
##
## filter, lag
## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, union
library(readr)
library(sf)
## Linking to GEOS 3.13.0, GDAL 3.8.5, PROJ 9.5.1; sf_use_s2() is TRUE
library(tigris)
## To enable caching of data, set `options(tigris_use_cache = TRUE)`
## in your R script or .Rprofile.
library(ggplot2)
library(scales)
##
## Attaching package: 'scales'
## The following object is masked from 'package:readr':
##
## col_factor
library(plotly)
##
## Attaching package: 'plotly'
## The following object is masked from 'package:ggplot2':
##
## last_plot
## The following object is masked from 'package:stats':
##
## filter
## The following object is masked from 'package:graphics':
##
## layout
library(stringr)
library(tidyr)
options(tigris_use_cache = TRUE)
#importing data
payments_df <- read.csv("data/open_payments_subset_2024.csv")
pop_df <- read.csv("data/state_population_2024.csv")
payment_category_col <- "Nature_of_Payment_or_Transfer_of_Value"
#getting payment per state metric
payment_per_state <- payments_df %>%
group_by(Recipient_State) %>%
summarize(
total_payment = sum(Total_Amount_of_Payment_USDollars, na.rm = TRUE),
.groups = "drop"
) %>%
#renaming to match my previous convention
rename(STUSPS = Recipient_State)
#creating shapes for the states
states_sf <- states(cb = TRUE, year = 2023) %>%
#move AK and HI
shift_geometry() %>%
#get only states
filter(STUSPS %in% state.abb)
#creating the map base that will be clickable later
map_base <- states_sf %>%
#joining states by abbreviations
left_join(payment_per_state, by = "STUSPS") %>%
#join population by full state name
left_join(pop_df, by = c("NAME" = "state_name")) %>%
mutate(
payment_per_capita = total_payment / population,
#can change this if I want later when I add all the data
payment_per_10000 = payment_per_capita * 10000,
)
#calculating share of national payment
national_total_payment <- sum(map_base$total_payment)
#aggregating data early to avoid delays in the app
cat_col <- rlang::sym(payment_category_col)
state_category_summary <- payments_df %>%
group_by(Recipient_State, !!cat_col) %>%
summarize(
total_payment = sum(Total_Amount_of_Payment_USDollars, na.rm = TRUE),
.groups = "drop"
)
ui <- fluidPage(
titlePanel("Open Payments: Healthcare Provider Compensation Data"),
#explains how to use the map
fluidRow(
column(
width = 12,
wellPanel(
h4("How to use this dashboard"),
p("Click on a state in the map to see its payment statistics and a breakdown of payment categories below.")
)
),
fluidRow(
column(
width = 12,
plotlyOutput("map_plot", height = "500px"),
column(
width = 12,
wellPanel(
h4("Selected State Summary"),
htmlOutput("summary_box")
)
)
)
),
tags$hr(),
fluidRow(
column(
width = 12,
h3(textOutput("bar_title")),
plotOutput("category_bar", height = "400px")
)
)
)
)
server <- function(input, output, session) {
#create the output summary for the state_summary box
output$summary_box <- renderUI({
dat <- state_summary()
if (nrow(dat) == 0) return(HTML("<em>No state selected.</em>"))
state_name <- dat$NAME[1]
st <- dat$STUSPS[1]
total <- dat$total_payment[1]
pop <- dat$population[1]
per_10k <- dat$payment_per_10000[1]
share <- total / national_total_payment
HTML(paste0(
"<b>", state_name, " (", st, ")</b><br>",
"Total payments: ", scales::dollar(total, accuracy = 1), "<br>",
"Population: ", scales::comma(pop), "<br>",
"Payments per 10,000 residents: $", formatC(per_10k, format = "f", digits = 2), "<br>",
"Share of national payments: ", scales::percent(share, accuracy = 0.1)
))
})
#track which state is selected from the map; default is VA (the best state)
selected_state <- reactiveVal("VA")
#observe clicks from the map
observeEvent(
event_data("plotly_click", source = "map"),
{
click <- event_data("plotly_click", source = "map")
if (!is.null(click$key)) {
selected_state(click$key)
}
}
)
map_data_reactive <- reactive({
map_base %>%
mutate(
hover_label = paste0(
"<b>", NAME, "</b>",
"<br>Total payments: ", dollar(total_payment, accuracy = 1),
"<br>Population: ", comma(population),
"<br>$", formatC(payment_per_10000, format = "f", digits = 2),
" per 10,000 residents"
)
)
})
#render the plotly map
output$map_plot <- renderPlotly({
map_data <- map_data_reactive()
p <- ggplot(map_data) +
geom_sf(aes(
fill = payment_per_10000,
key = STUSPS
), color = "white", size = 0.15) +
scale_fill_distiller(
palette = "Greens",
direction = 1,
labels = dollar_format(accuracy = 0.1),
na.value = "grey90"
) +
labs(
title = "Open Payments per 10,000 Residents (2024)",
subtitle = "Click a state to view details below",
fill = "Dollars per 10,000"
) +
theme_void() +
theme(
legend.position = "right",
plot.title = element_text(hjust = 0.5, size = 16, face = "bold"),
plot.subtitle = element_text(hjust = 0.5)
)
#decided to get rid of the hovering and display the data once the state is clicked on
ggplotly(p, tooltip = NULL, source = "map")
})
#once you select a state, it should show you the summary data
state_summary <- reactive({
this_state <- selected_state()
map_base %>% filter(STUSPS == this_state)
})
#summmary data shown
output$stat_total <- renderText({
dat <- state_summary()
dollar(dat$total_payment, accuracy = 1)
})
output$stat_share <- renderText({
dat <- state_summary()
share <- dat$total_payment / national_total_payment
percent(share, accuracy = 0.1)
})
output$stat_per_10000 <- renderText({
dat <- state_summary()
paste0(
"$", formatC(dat$payment_per_10000, format = "f", digits = 2),
" per 10,000"
)
})
#creating bar chart that appears after clicks
output$category_bar <- renderPlot({
this_state <- selected_state()
state_name <- map_base$NAME[map_base$STUSPS == this_state]
state_cats <- state_category_summary %>%
filter(Recipient_State == this_state) %>%
#renaming columns so they don't take up too much space on the bar chart
mutate(
!!cat_col := dplyr::recode(
!!cat_col,
"Compensation for services other than consulting, including serving as faculty or as a speaker at a venue other than a continuing education program" =
"Teaching or Speaking Fees",
"Space rental or facility fees (teaching hospital only)" =
"Space Rental or Facility Fees"
)
) %>%
arrange(desc(total_payment))
ggplot(state_cats, aes(
x = reorder(!!cat_col, total_payment),
y = total_payment
)) +
geom_col(fill = "steelblue") +
coord_flip() +
scale_y_continuous(labels = scales::dollar_format(accuracy = 1)) +
labs(
title = paste0("Payment Category Breakdown – ", state_name, " (", this_state, ")"),
x = "Payment Category",
y = "Total Payments (USD)"
) +
theme_minimal()
})
}
shinyApp(ui, server)
Shiny applications not supported in static R Markdown documents