HMIS_Dashboard - REditorSupport/vscode-R GitHub Wiki
library(shiny) library(httr) library(jsonlite) library(dplyr) library(tidyr) library(ggplot2) library(plotly) library(DT) library(forecast) library(leaflet) library(rmarkdown)
ui <- fluidPage(
titlePanel("🏥 Surgical HMIS Intelligence Dashboard (DHIS2)"),
sidebarLayout(
sidebarPanel(
h4("🔐 DHIS2 Login"),
# FIX 1: Added proper IDs "username" and "password"
textInput("..", "Username"),
passwordInput("..", "Password"),
actionButton("load", "Connect & Load 2025 Data",
class = "btn-primary"),
uiOutput("status_msg"),
hr(),
strong("📅 Period: January–December 2025"),
hr(),
h4("📄 Scientific Paper"),
textInput("paper_title", "Title", "Surgical HMIS Analysis Report"),
textInput("author", "Author", "MoH Analyst"),
actionButton("generate_paper", "Generate Paper"),
downloadButton("download_paper", "⬇ Download Paper")
),
mainPanel(
tabsetPanel(
tabPanel("Overview", DTOutput("table")),
tabPanel("Descriptive", verbatimTextOutput("desc")),
tabPanel("Trend", plotlyOutput("trend")),
tabPanel("Surgery Mix", plotlyOutput("mix")),
tabPanel("Anesthesia", plotlyOutput("anesthesia")),
tabPanel("Waiting", plotlyOutput("waiting")),
tabPanel("Infection", plotlyOutput("infection")),
tabPanel("Forecast", plotlyOutput("forecast")),
tabPanel("Ranking", DTOutput("ranking")),
tabPanel("Anomalies", plotlyOutput("anomalies")),
tabPanel("Correlation", plotlyOutput("correlation")),
tabPanel("Map", leafletOutput("map"))
)
)
)
)
server <- function(input, output, session) {
# -------------------------------------------------------
# FIX 2: Store data in a reactiveVal so API is called
# only ONCE when button is clicked, not on every
# render call
# -------------------------------------------------------
hmis_data <- reactiveVal(NULL)
name_lookup <- reactiveVal(NULL) # id -> human name map
output$status_msg <- renderUI(NULL)
# =======================================================
# LOAD DATA ON BUTTON CLICK
# =======================================================
observeEvent(input$load, {
req(input$username, input$password)
auth <- authenticate("....", ".......")
base_url <- "https://aggregate.moh.gov.rw/api"
dataset_id <- "iynGsJrWbuY"
# ---- Show spinner ----
output$status_msg <- renderUI(
tags$p("⏳ Connecting to DHIS2…", style = "color:orange")
)
# --------------------------------------------------
# STEP 1 – METADATA (get element IDs + names)
# --------------------------------------------------
meta_res <- tryCatch(
GET(
paste0(base_url, "/dataSets/", iynGsJrWbuY,
"?fields=dataSetElements[dataElement[id,name]]"),
auth
),
error = function(e) NULL
)
if (is.null(meta_res) || status_code(meta_res) != 200) {
output$status_msg <- renderUI(
tags$p("❌ Metadata fetch failed. Check credentials / VPN.",
style = "color:red")
)
return()
}
meta <- content(meta_res, "parsed", simplifyVector = TRUE)
# Build id→name lookup
elems <- meta$dataSetElements
ids <- sapply(elems, function(x) x$dataElement$id)
names_vec <- sapply(elems, function(x) x$dataElement$name)
lookup <- setNames(names_vec, ids)
name_lookup(lookup)
dx <- paste(ids, collapse = ";")
# --------------------------------------------------
# FIX 3: Correct period strings (Jan–Dec 2025)
# DHIS2 monthly format = "YYYYMM"
# --------------------------------------------------
months <- sprintf("2025%02d", 1:5) # "202501" … "202512"
pe <- paste(months, collapse = ";")
# --------------------------------------------------
# FIX 4: Add orgUnit dimension (required by analytics)
# Using the Rwanda national level OU
# --------------------------------------------------
ou <- "ImspTQPwCqd" # ← replace with your actual top-level OU uid
# Tip: find yours at:
# GET https://aggregate.moh.gov.rw/api/organisationUnits?level=1&fields=id,name
analytics_url <- paste0(
base_url, "/analytics.json",
"?dimension=dx:", dx,
"&dimension=pe:", pe,
"&dimension=ou:", ou,
"&displayProperty=NAME" # returns human-readable names in headers
)
data_res <- tryCatch(
GET(analytics_url, auth),
error = function(e) NULL
)
if (is.null(data_res) || status_code(data_res) != 200) {
output$status_msg <- renderUI(
tags$p(
paste0("❌ Analytics API failed (HTTP ",
if (!is.null(data_res)) status_code(data_res) else "?",
"). Check OU uid or date range."),
style = "color:red"
)
)
return()
}
parsed <- content(data_res, "parsed", simplifyVector = TRUE)
if (is.null(parsed$rows) || length(parsed$rows) == 0) {
output$status_msg <- renderUI(
tags$p("⚠️ Connected but no data returned for 2025.
The dataset may have no values yet for this period.",
style = "color:darkorange")
)
return()
}
# --------------------------------------------------
# FIX 5: Build df safely using header names
# --------------------------------------------------
headers <- parsed$headers$name # e.g. c("dx","pe","ou","value")
df <- as.data.frame(parsed$rows, stringsAsFactors = FALSE)
colnames(df) <- headers
# Rename to friendly names regardless of header order
colnames(df)[colnames(df) == "dx"] <- "DataElement"
colnames(df)[colnames(df) == "pe"] <- "Period"
colnames(df)[colnames(df) == "ou"] <- "OrgUnit"
colnames(df)[colnames(df) == "value"] <- "Value"
df$Value <- as.numeric(df$Value)
# Replace IDs with human names using displayProperty=NAME
# (DHIS2 returns names directly when displayProperty=NAME is set)
# If names come back as IDs, use lookup:
if (all(nchar(df$DataElement) == 11)) { # still UIDs
df$DataElement <- lookup[df$DataElement]
}
hmis_data(df)
write.csv(df, "hmis_surgical_2025.csv", row.names = FALSE)
output$status_msg <- renderUI(
tags$p(
paste0("✅ Loaded ", nrow(df), " records."),
style = "color:green"
)
)
})
# -------------------------------------------------------
# Helper: gate all outputs on data being available
# -------------------------------------------------------
df_ready <- reactive({
req(hmis_data())
hmis_data()
})
# =======================================================
# TABLE
# =======================================================
output$table <- renderDT({
datatable(df_ready(), options = list(pageLength = 15))
})
# =======================================================
# DESCRIPTIVE
# =======================================================
output$desc <- renderPrint({
df <- df_ready()
cat("===== SURGICAL HMIS SUMMARY 2025 =====\n")
cat("Total records :", nrow(df), "\n")
cat("Data elements :", n_distinct(df$DataElement), "\n")
cat("Org units :", n_distinct(df$OrgUnit), "\n")
cat("Periods :", paste(sort(unique(df$Period)), collapse=", "), "\n\n")
cat("--- Value stats ---\n")
print(summary(df$Value))
})
# =======================================================
# TREND
# =======================================================
output$trend <- renderPlotly({
df <- df_ready()
ts_data <- df %>%
group_by(Period) %>%
summarise(Value = sum(Value, na.rm = TRUE), .groups = "drop") %>%
arrange(Period)
ggplotly(
ggplot(ts_data, aes(Period, Value, group = 1)) +
geom_line(color = "steelblue", linewidth = 1) +
geom_point(color = "steelblue", size = 2) +
labs(title = "Monthly Surgical Activity 2025",
x = "Period (YYYYMM)", y = "Total Volume") +
theme_minimal() +
theme(axis.text.x = element_text(angle = 45, hjust = 1))
)
})
# =======================================================
# SURGERY MIX
# =======================================================
output$mix <- renderPlotly({
df <- df_ready()
mix <- df %>%
group_by(DataElement) %>%
summarise(Value = sum(Value, na.rm = TRUE), .groups = "drop") %>%
arrange(desc(Value))
plot_ly(mix,
x = ~reorder(DataElement, -Value),
y = ~Value,
type = "bar",
marker = list(color = "steelblue")) %>%
layout(title = "Surgery Mix by Data Element",
xaxis = list(title = "", tickangle = -40),
yaxis = list(title = "Volume"))
})
# =======================================================
# FIX 6: Anesthesia – match on real element names
# Change the grep pattern to match YOUR data element
# names (run Overview tab first to see exact names)
# =======================================================
output$anesthesia <- renderPlotly({
df <- df_ready()
ana <- df %>%
filter(grepl("anaesthe|anesthes|anaesth", tolower(DataElement))) %>%
group_by(DataElement) %>%
summarise(Value = sum(Value, na.rm = TRUE), .groups = "drop")
if (nrow(ana) == 0) {
return(plotly_empty() %>%
layout(title = "No anesthesia-related elements found.\nCheck element names in Overview tab."))
}
plot_ly(ana, labels = ~DataElement, values = ~Value, type = "pie") %>%
layout(title = "Anesthesia Type Distribution")
})
# =======================================================
# FIX 7: Waiting – flexible pattern
# =======================================================
output$waiting <- renderPlotly({
df <- df_ready()
wait <- df %>%
filter(grepl("wait|liste|queue", tolower(DataElement))) %>%
group_by(DataElement) %>%
summarise(Value = sum(Value, na.rm = TRUE), .groups = "drop")
if (nrow(wait) == 0) {
return(plotly_empty() %>%
layout(title = "No waiting-list elements found.\nCheck element names in Overview tab."))
}
plot_ly(wait, x = ~DataElement, y = ~Value, type = "bar") %>%
layout(title = "Surgical Waiting List")
})
# =======================================================
# FIX 8: Infection – flexible pattern
# =======================================================
output$infection <- renderPlotly({
df <- df_ready()
inf <- df %>%
filter(grepl("infect|ssi|sepsis|wound", tolower(DataElement))) %>%
group_by(Period) %>%
summarise(Value = sum(Value, na.rm = TRUE), .groups = "drop") %>%
arrange(Period)
if (nrow(inf) == 0) {
return(plotly_empty() %>%
layout(title = "No infection-related elements found.\nCheck element names in Overview tab."))
}
plot_ly(inf, x = ~Period, y = ~Value,
type = "scatter", mode = "lines+markers") %>%
layout(title = "Surgical Site Infection Trend")
})
# =======================================================
# FIX 9: Forecast – needs ≥6 periods; warns if too few
# =======================================================
output$forecast <- renderPlotly({
df <- df_ready()
ts_data <- df %>%
group_by(Period) %>%
summarise(Value = sum(Value, na.rm = TRUE), .groups = "drop") %>%
arrange(Period)
n <- nrow(ts_data)
if (n < 6) {
return(plotly_empty() %>%
layout(title = paste0(
"Forecast needs ≥6 months of data. Currently only ",
n, " period(s) available."
)))
}
ts_obj <- ts(ts_data$Value, frequency = 12)
model <- tryCatch(auto.arima(ts_obj), error = function(e) NULL)
if (is.null(model)) {
return(plotly_empty() %>% layout(title = "ARIMA model failed."))
}
fc <- forecast(model, h = 6)
x_hist <- seq_len(n)
x_fore <- seq(n + 1, n + 6)
plot_ly() %>%
add_lines(x = x_hist, y = as.numeric(ts_obj),
name = "Actual", line = list(color = "steelblue")) %>%
add_lines(x = x_fore, y = as.numeric(fc$mean),
name = "Forecast", line = list(color = "red", dash = "dash")) %>%
add_ribbons(x = x_fore,
ymin = as.numeric(fc$lower[, 2]),
ymax = as.numeric(fc$upper[, 2]),
name = "95% CI",
fillcolor = "rgba(255,0,0,0.1)",
line = list(color = "transparent")) %>%
layout(title = "6-Month Surgical Volume Forecast",
xaxis = list(title = "Month index"),
yaxis = list(title = "Volume"))
})
# =======================================================
# RANKING
# =======================================================
output$ranking <- renderDT({
df <- df_ready()
rank <- df %>%
group_by(OrgUnit) %>%
summarise(Total = sum(Value, na.rm = TRUE), .groups = "drop") %>%
arrange(desc(Total)) %>%
mutate(Rank = row_number())
datatable(rank, options = list(pageLength = 15))
})
# =======================================================
# ANOMALIES
# =======================================================
output$anomalies <- renderPlotly({
df <- df_ready()
anom <- df %>%
group_by(OrgUnit) %>%
summarise(Value = sum(Value, na.rm = TRUE), .groups = "drop") %>%
mutate(
z = (Value - mean(Value, na.rm = TRUE)) / sd(Value, na.rm = TRUE),
anomaly = abs(z) > 2,
color = ifelse(anomaly, "Anomaly", "Normal")
)
plot_ly(anom,
x = ~OrgUnit,
y = ~Value,
color = ~color,
colors = c("Normal" = "steelblue", "Anomaly" = "red"),
type = "bar") %>%
layout(title = "Facility-level Anomaly Detection (|z| > 2)",
xaxis = list(tickangle = -40))
})
# =======================================================
# CORRELATION
# =======================================================
output$correlation <- renderPlotly({
df <- df_ready()
wide <- df %>%
group_by(DataElement, OrgUnit) %>%
summarise(Value = sum(Value, na.rm = TRUE), .groups = "drop") %>%
pivot_wider(names_from = DataElement, values_from = Value,
values_fill = 0)
num_cols <- wide %>% select(-OrgUnit)
if (ncol(num_cols) < 2) {
return(plotly_empty() %>%
layout(title = "Need ≥2 data elements for correlation."))
}
corr <- cor(num_cols, use = "pairwise.complete.obs")
plot_ly(
x = colnames(corr),
y = rownames(corr),
z = corr,
type = "heatmap",
colorscale = "RdBu",
zmin = -1, zmax = 1
) %>%
layout(title = "Correlation Matrix of Surgical Indicators")
})
# =======================================================
# MAP (basic tiles; extend with facility coords if available)
# =======================================================
output$map <- renderLeaflet({
leaflet() %>%
addTiles() %>%
setView(lng = 29.87, lat = -1.94, zoom = 8) # Rwanda centre
})
# =======================================================
# PAPER GENERATION
# =======================================================
paper_file <- reactiveVal(NULL)
observeEvent(input$generate_paper, {
df <- df_ready()
rmd <- tempfile(fileext = ".Rmd")
out <- tempfile(fileext = ".html")
top5 <- df %>%
group_by(DataElement) %>%
summarise(Total = sum(Value, na.rm = TRUE), .groups = "drop") %>%
arrange(desc(Total)) %>%
head(5)
writeLines(c(
"---",
paste0("title: '", input$paper_title, "'"),
paste0("author: '", input$author, "'"),
"date: '`r Sys.Date()`'",
"output: html_document",
"---",
"",
"## 1. Introduction",
"This report summarises surgical HMIS data extracted from DHIS2 for 2025.",
"",
"## 2. Summary Statistics",
paste("- Total records:", nrow(df)),
paste("- Data elements:", n_distinct(df$DataElement)),
paste("- Org units:", n_distinct(df$OrgUnit)),
paste("- Periods covered:", paste(sort(unique(df$Period)), collapse = ", ")),
paste("- Mean value:", round(mean(df$Value, na.rm = TRUE), 2)),
paste("- Median value:", round(median(df$Value, na.rm = TRUE), 2)),
"",
"## 3. Top 5 Surgical Indicators",
knitr::kable(top5, format = "markdown"),
"",
"## 4. Conclusion",
"Further disaggregation by facility and procedure type is recommended."
), rmd)
tryCatch({
rmarkdown::render(rmd, output_file = out, quiet = TRUE)
paper_file(out)
showNotification("✅ Paper generated successfully!", type = "message")
}, error = function(e) {
showNotification(paste("❌ Paper generation failed:", e$message), type = "error")
})
})
output$download_paper <- downloadHandler(
filename = function() paste0("HMIS_Surgical_", Sys.Date(), ".html"),
content = function(file) {
req(paper_file())
file.copy(paper_file(), file)
}
)
}
shinyApp(ui, server)