HMIS_Dashboard - REditorSupport/vscode-R GitHub Wiki

=========================================================

PACKAGES

=========================================================

library(shiny) library(httr) library(jsonlite) library(dplyr) library(tidyr) library(ggplot2) library(plotly) library(DT) library(forecast) library(leaflet) library(rmarkdown)

=========================================================

UI

=========================================================

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

=========================================================

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)
	}
)

}

=========================================================

RUN APP

=========================================================

shinyApp(ui, server)

⚠️ **GitHub.com Fallback** ⚠️