install.packages("rsconnect")
library(rsconnect)
rsconnect::setAccountInfo(
name = "okellobwibo",
token = "77B22F5DFD02B29F82C0DFBB9AFC4AD3",
secret = "42Dy8rOzHddJLgSxi0YzexydkXjO1lLi5FT3kLVF"
)
#| label: deploy-app
#| eval: false # flip to TRUE to deploy from this doc
library(rsconnect)
app_dir <- "C:/Users/SamOkello/OneDrive - CARE International/Desktop/deploy/app"
deployApp(
appDir = app_dir,
appPrimaryDoc = "app.R",
appFiles = c("app.R"), # add "www","data" if you include them
account = "okellobwibo",
appName = "care-uganda-fy25-dashboard",
launch.browser = TRUE,
logLevel = "verbose"
)
---
# 2) `app/app.R` (your Shiny dashboard)
> Save as UTF-8. This is the revised app with currency/percent label helpers and robust date parsing. It ends with `shinyApp(ui, server)`.
```r
# app.R — CARE Uganda FY25 Partnerships Dashboard (Shiny)
options(shiny.maxRequestSize = 100 * 1024^2) # 100 MB uploads
library(shiny)
library(shinydashboard)
library(bslib)
library(tidyverse)
library(readxl)
library(janitor)
library(lubridate)
library(scales)
library(plotly)
library(DT)
library(treemapify)
library(writexl)
# ---------- Helpers ----------
parse_date_flexible <- function(x, year_anchor = "-01-01") {
n <- length(x)
out <- as.Date(rep(NA), origin = "1970-01-01")
xc <- as.character(x) |> trimws()
is_year_str <- grepl("^\\d{4}$", xc)
out[is_year_str] <- as.Date(paste0(xc[is_year_str], year_anchor))
if (is.numeric(x)) {
is_year_num <- !is.na(x) & is.finite(x) & (x %% 1 == 0) & x >= 1900 & x <= 2100
out[is_year_num] <- as.Date(paste0(as.integer(x[is_year_num]), year_anchor))
is_serial <- !is.na(x) & is.finite(x) & !is_year_num
out[is_serial] <- as.Date(x[is_serial], origin = "1899-12-30")
}
need <- is.na(out); if (any(need)) { y <- suppressWarnings(ymd(xc[need], quiet = TRUE)); out[need & !is.na(y)] <- y[!is.na(y)] }
need <- is.na(out); if (any(need)) { y <- suppressWarnings(mdy(xc[need], quiet = TRUE)); out[need & !is.na(y)] <- y[!is.na(y)] }
need <- is.na(out); if (any(need)) { y <- suppressWarnings(dmy(xc[need], quiet = TRUE)); out[need & !is.na(y)] <- y[!is.na(y)] }
out
}
standardize_category <- function(x){
x0 <- tolower(trimws(x))
case_when(
x0 %in% c("national ngo","ngo (national)","local ngo") ~ "National NGO",
x0 %in% c("ingo","international ngo") ~ "INGO",
x0 %in% c("cbo","community based organization","community-based organization") ~ "CBO",
x0 %in% c("cso","civil society organization","civil-society organization") ~ "CSO",
x0 %in% c("cooperative","co-op","coop") ~ "Cooperative",
x0 %in% c("private sector","private","company","ltd","limited","private_sector") ~ "Private Sector",
x0 %in% c("government","government agency","ministry","district","government_agency") ~ "Government Agency",
x0 %in% c("un","un agency","un-agency") ~ "UN Agency",
x0 %in% c("academic","research","university","academic/research","academic_research") ~ "Academic/Research",
x0 %in% c("bank","financial institution") ~ "Bank",
x0 %in% c("wro_wlo_wro","wro/wlo/wro","wro","wlo") ~ "WRO/WLO",
TRUE ~ str_to_title(x0)
)
}
standardize_district <- function(x){
x0 <- x %>% as.character() %>% stringr::str_squish() %>% str_to_title()
gsub(" District$", "", x0)
}
safe_div <- function(num, den){ ifelse(is.na(den) | den == 0, NA_real_, num/den) }
# Label helpers
dollar_lab <- label_dollar(accuracy = 1, prefix = "$")
pct_lab <- label_percent(accuracy = 1)
# ---------- UI ----------
header <- dashboardHeader(title = "CARE Uganda • Partnerships FY25")
sidebar <- dashboardSidebar(
fileInput("infile", "Upload FY25 Excel", accept = c(".xlsx",".xls")),
helpText("Columns: Partner ID, Partner_name, District_office location, Email address, Entity_start_date, Start_date_partnership, Phone, Category_partner, FY25_Budget, FY25_Expenses, No_contracts"),
hr(),
sliderInput("abs_cap", "Absorption cap (%) for visuals", min = 50, max = 500, value = 200, step = 10),
checkboxInput("filter_valid", "Only partners with valid budget > 0", TRUE),
selectInput("cat_filter", "Filter by category", choices = c("All"), selected = "All", multiple = TRUE),
selectInput("dist_filter", "Filter by district", choices = c("All"), selected = "All", multiple = TRUE),
hr(),
downloadButton("download_excel", "Download Cleaned Outputs")
)
body <- dashboardBody(
bslib::bs_theme_dependencies(bs_theme(version = 5)),
fluidRow(
valueBoxOutput("vb_partners", width = 2),
valueBoxOutput("vb_budget", width = 2),
valueBoxOutput("vb_expenses", width = 2),
valueBoxOutput("vb_abs", width = 2),
valueBoxOutput("vb_top5", width = 2),
valueBoxOutput("vb_hhi", width = 2)
),
fluidRow(
box(title = "Absorption Distribution", width = 6, status = "primary", solidHeader = TRUE,
plotlyOutput("plot_abs_hist", height = 320)),
box(title = "Budget by Category", width = 6, status = "primary", solidHeader = TRUE,
plotlyOutput("plot_budget_cat", height = 320))
),
fluidRow(
box(title = "Top 15 Partners by Budget", width = 6, status = "primary", solidHeader = TRUE,
plotlyOutput("plot_top15", height = 360)),
box(title = "Budget vs Absorption (bubble)", width = 6, status = "primary", solidHeader = TRUE,
plotlyOutput("plot_bubble", height = 360))
),
fluidRow(
box(title = "Absorption Bands (share of partners)", width = 6, status = "primary", solidHeader = TRUE,
plotlyOutput("plot_bands_share", height = 320)),
box(title = "Localization Share (Donut)", width = 6, status = "primary", solidHeader = TRUE,
plotlyOutput("plot_local_donut", height = 320))
),
fluidRow(
box(title = "Heatmap: Budget by District x Category", width = 6, status = "primary", solidHeader = TRUE,
plotlyOutput("plot_heatmap", height = 360)),
box(title = "Treemap: Category → Partner (Budget)", width = 6, status = "primary", solidHeader = TRUE,
plotlyOutput("plot_treemap", height = 360))
),
fluidRow(
box(title = "Tenure vs Absorption (with smoother)", width = 6, status = "primary", solidHeader = TRUE,
plotlyOutput("plot_tenure_abs", height = 360)),
box(title = "Timeline: Entity Founded vs CARE Start", width = 6, status = "primary", solidHeader = TRUE,
plotlyOutput("plot_timeline", height = 360))
),
fluidRow(
box(title = "Variance Waterfall (Expenses - Budget)", width = 12, status = "warning", solidHeader = TRUE,
plotlyOutput("plot_waterfall", height = 360))
),
fluidRow(
box(title = "Partner Scorecard", width = 12, status = "success", solidHeader = TRUE,
DTOutput("tbl_scorecard"))
),
fluidRow(
box(title = "Risk Flags", width = 12, status = "danger", solidHeader = TRUE,
DTOutput("tbl_risks"))
)
)
ui <- dashboardPage(header, sidebar, body, skin = "yellow")
# ---------- SERVER ----------
server <- function(input, output, session){
fy_end <- as.Date("2025-06-30")
raw_react <- reactive({
path <- req({
if (!is.null(input$infile$datapath)) input$infile$datapath
else if (file.exists("CARE_Uganda_Partnerships_FY25.xlsx")) "CARE_Uganda_Partnerships_FY25.xlsx"
else validate("Upload your FY25 Excel (left sidebar).")
})
readxl::read_excel(path) |> janitor::clean_names()
})
dat_base <- reactive({
raw <- raw_react() |> janitor::remove_empty(c("rows","cols"))
req_cols <- c("partner_id","partner_name","district_office_location","email_address",
"entity_start_date","start_date_partnership","phone","category_partner",
"fy25_budget","fy25_expenses","no_contracts")
miss <- setdiff(req_cols, names(raw))
validate(need(length(miss)==0, paste("Missing columns:", paste(miss, collapse=", "))))
dat <- raw |>
mutate(across(where(is.character), ~ stringr::str_squish(.x))) |>
transmute(
partner_id = as.character(partner_id),
partner_name = as.character(partner_name),
district_office_location = standardize_district(district_office_location),
email_address = tolower(as.character(email_address)),
entity_start_date = parse_date_flexible(entity_start_date),
start_date_partnership = parse_date_flexible(start_date_partnership),
phone = as.character(phone),
category_partner = standardize_category(category_partner),
fy25_budget = readr::parse_number(as.character(fy25_budget)),
fy25_expenses = readr::parse_number(as.character(fy25_expenses)),
no_contracts = as.integer(readr::parse_number(as.character(no_contracts)))
) |>
distinct()
dat |>
mutate(
absorption_rate = if_else(fy25_budget > 0, fy25_expenses / fy25_budget, NA_real_),
partner_tenure_yrs= if_else(!is.na(start_date_partnership),
time_length(interval(start_date_partnership, fy_end), "years"), NA_real_),
entity_age_yrs = if_else(!is.na(entity_start_date),
time_length(interval(entity_start_date, fy_end), "years"), NA_real_),
avg_contract_size = if_else(!is.na(no_contracts) & no_contracts > 0, fy25_budget/no_contracts, NA_real_),
underspend_flag = !is.na(absorption_rate) & absorption_rate < 0.70,
overspend_flag = !is.na(absorption_rate) & absorption_rate > 1.10
)
})
observe({
dat <- dat_base()
updateSelectInput(session, "cat_filter", choices = c("All", sort(unique(dat$category_partner))), selected = "All")
updateSelectInput(session, "dist_filter", choices = c("All", sort(unique(dat$district_office_location))), selected = "All")
})
dat_filt <- reactive({
d <- dat_base()
if (isTRUE(input$filter_valid)) d <- d |> filter(!is.na(fy25_budget) & fy25_budget > 0)
if (!is.null(input$cat_filter) && !"All" %in% input$cat_filter) d <- d |> filter(category_partner %in% input$cat_filter)
if (!is.null(input$dist_filter) && !"All" %in% input$dist_filter) d <- d |> filter(district_office_location %in% input$dist_filter)
cap <- input$abs_cap/100
d |> mutate(absorption_rate_capped = pmin(pmax(absorption_rate, 0), cap))
})
kpi_vals <- reactive({
d <- dat_filt()
tot_budget <- sum(d$fy25_budget, na.rm = TRUE)
tot_expenses <- sum(d$fy25_expenses, na.rm = TRUE)
overall_abs <- safe_div(tot_expenses, tot_budget)
share <- if (tot_budget>0) d$fy25_budget/tot_budget else rep(NA_real_, nrow(d))
hhi_100 <- sum((share*100)^2, na.rm = TRUE)
top5_share <- d |> arrange(desc(fy25_budget)) |> slice_head(n=5) |>
summarise(share = sum(fy25_budget, na.rm=TRUE)/tot_budget) |> pull(share)
local_cats <- c("National NGO","CBO","CSO","Cooperative","WRO/WLO")
local_budget_share <- safe_div(sum(d$fy25_budget[d$category_partner %in% local_cats], na.rm = TRUE), tot_budget)
list(
partners = nrow(d),
tot_budget = tot_budget, tot_expenses = tot_expenses,
overall_abs = overall_abs, top5_share = top5_share,
hhi_100 = hhi_100, local_share = local_budget_share
)
})
output$vb_partners <- renderValueBox({
valueBox(kpi_vals()$partners, "Partners", icon = icon("users"), color = "yellow")
})
output$vb_budget <- renderValueBox({
valueBox(dollar_lab(kpi_vals()$tot_budget), "FY25 Budget", icon = icon("wallet"), color = "blue")
})
output$vb_expenses <- renderValueBox({
valueBox(dollar_lab(kpi_vals()$tot_expenses), "FY25 Expenses", icon = icon("money-bill-wave"), color = "blue")
})
output$vb_abs <- renderValueBox({
valueBox(percent(kpi_vals()$overall_abs, 1), "Overall Absorption", icon = icon("chart-line"), color = "green")
})
output$vb_top5 <- renderValueBox({
valueBox(percent(kpi_vals()$top5_share, 1), "Top-5 Budget Share", icon = icon("layer-group"), color = "purple")
})
output$vb_hhi <- renderValueBox({
lvl <- cut(kpi_vals()$hhi_100, breaks = c(-Inf,1500,2500,Inf), labels = c("Low","Moderate","High"))
valueBox(sprintf("%s (%.0f)", as.character(lvl), kpi_vals()$hhi_100),
"HHI (0–10,000)", icon = icon("balance-scale"), color = "red")
})
# ---- Plots ----
output$plot_abs_hist <- renderPlotly({
d <- dat_filt() |> filter(!is.na(absorption_rate_capped))
p <- ggplot(d, aes(x = absorption_rate_capped)) +
geom_histogram(bins = 30) +
geom_vline(xintercept = c(0.70, 1.10), linetype = "dashed") +
scale_x_continuous(labels = pct_lab) +
labs(x="Absorption Rate (capped)", y="Count")
ggplotly(p)
})
output$plot_budget_cat <- renderPlotly({
d <- dat_filt() |>
group_by(category_partner) |>
summarise(budget = sum(fy25_budget, na.rm = TRUE), .groups = "drop") |>
arrange(budget)
p <- ggplot(d, aes(x = reorder(category_partner, budget), y = budget)) +
geom_col() + coord_flip() +
scale_y_continuous(labels = dollar_lab) +
labs(x="Category", y="Budget (USD)")
ggplotly(p)
})
output$plot_top15 <- renderPlotly({
d <- dat_filt() |> arrange(desc(fy25_budget)) |> slice_head(n=15)
p <- ggplot(d, aes(x = reorder(partner_name, fy25_budget), y = fy25_budget)) +
geom_col() + coord_flip() +
scale_y_continuous(labels = dollar_lab) +
labs(x="Partner", y="Budget (USD)")
ggplotly(p)
})
output$plot_bubble <- renderPlotly({
d <- dat_filt() |> filter(!is.na(absorption_rate_capped))
p <- ggplot(d, aes(x = fy25_budget, y = absorption_rate_capped,
size = pmax(no_contracts,1), color = category_partner,
text = paste0("<b>", partner_name, "</b><br>",
"Budget: ", dollar_lab(fy25_budget), "<br>",
"Absorption: ", percent(absorption_rate,1), "<br>",
"#Contracts: ", no_contracts))) +
geom_point(alpha = .8) +
geom_hline(yintercept = c(0.70, 1.10), linetype="dashed") +
scale_x_continuous(labels = dollar_lab) +
scale_y_continuous(labels = pct_lab) +
labs(x="FY25 Budget (USD)", y="Absorption Rate (capped)")
ggplotly(p, tooltip="text")
})
output$plot_bands_share <- renderPlotly({
d <- dat_filt() |>
mutate(band = case_when(
is.na(absorption_rate) ~ "No Data",
absorption_rate < 0.70 ~ "<70% (Underspend)",
absorption_rate <= 1.10 ~ "70–110% (On Track)",
TRUE ~ ">110% (Overspend)"
)) |>
count(category_partner, band, name = "n") |>
group_by(category_partner) |>
mutate(share = n/sum(n))
p <- ggplot(d, aes(x = category_partner, y = share, fill = band)) +
geom_col(position = "fill") + coord_flip() +
scale_y_continuous(labels = pct_lab) +
labs(x="Category", y="Share of partners", fill="Band")
ggplotly(p)
})
output$plot_local_donut <- renderPlotly({
d <- dat_filt()
local_cats <- c("National NGO","CBO","CSO","Cooperative","WRO/WLO")
donut <- tibble(
group = c("Local","Non-Local"),
value = c(sum(d$fy25_budget[d$category_partner %in% local_cats], na.rm = TRUE),
sum(d$fy25_budget[!d$category_partner %in% local_cats], na.rm = TRUE))
) |> mutate(pct = value/sum(value))
p <- ggplot(donut, aes(x = 2, y = value, fill = group, text = paste0(group, ": ", percent(pct,1)))) +
geom_col(width = 1, color="white") +
coord_polar(theta = "y") + xlim(0.5, 2.5) + theme_void()
ggplotly(p, tooltip="text")
})
output$plot_heatmap <- renderPlotly({
d <- dat_filt() |>
group_by(district_office_location, category_partner) |>
summarise(budget = sum(fy25_budget, na.rm = TRUE), .groups = "drop")
p <- ggplot(d, aes(x = category_partner, y = district_office_location, fill = budget,
text = paste0(district_office_location," × ",category_partner,"<br>Budget: ", dollar_lab(budget)))) +
geom_tile() + labs(x="Category", y="District") +
scale_fill_continuous(labels = dollar_lab)
ggplotly(p, tooltip="text")
})
output$plot_treemap <- renderPlotly({
d <- dat_filt() |> mutate(category_partner = fct_explicit_na(category_partner, na_level = "Unknown"))
p <- ggplot(d, aes(area = fy25_budget, fill = category_partner,
label = paste0(partner_name,"\n", dollar_lab(fy25_budget)))) +
treemapify::geom_treemap() +
treemapify::geom_treemap_text(colour = "white", place = "centre", reflow = TRUE)
ggplotly(p)
})
output$plot_tenure_abs <- renderPlotly({
d <- dat_filt() |> filter(!is.na(absorption_rate_capped), !is.na(partner_tenure_yrs))
p <- ggplot(d, aes(x = partner_tenure_yrs, y = absorption_rate_capped, color = category_partner)) +
geom_point(alpha = .8) +
geom_smooth(se = TRUE) +
scale_y_continuous(labels = pct_lab) +
labs(x="Tenure with CARE (years)", y="Absorption Rate (capped)")
ggplotly(p)
})
output$plot_timeline <- renderPlotly({
d <- dat_filt() |>
transmute(partner_name, category_partner, fy25_budget,
entity_year = year(entity_start_date),
care_year = year(start_date_partnership)) |>
pivot_longer(cols = c(entity_year, care_year), names_to = "type", values_to = "year") |>
mutate(type = recode(type, entity_year = "Entity Founded", care_year = "CARE Partnership Start"))
p <- ggplot(d, aes(x = year, y = reorder(partner_name, year))) +
geom_line(aes(group = partner_name), color="grey60") +
geom_point(aes(color = category_partner, shape = type, size = fy25_budget), alpha = .9) +
labs(x="Year", y="Partner")
ggplotly(p)
})
output$plot_waterfall <- renderPlotly({
d <- dat_filt() |> mutate(variance = fy25_expenses - fy25_budget) |>
filter(!is.na(variance)) |>
arrange(desc(abs(variance))) |>
slice_head(n = 20) |>
mutate(pos = variance >= 0)
p <- ggplot(d, aes(x = reorder(partner_name, variance), y = variance, fill = pos,
text = paste0(partner_name,"<br>Variance: ", dollar_lab(variance)))) +
geom_col() + coord_flip() +
scale_y_continuous(labels = dollar_lab) +
scale_fill_manual(values = c("TRUE"="#2E7D32","FALSE"="#C62828"), labels = c("Overspend","Underspend")) +
labs(x="Partner", y="Variance (USD)", fill="")
ggplotly(p, tooltip="text")
})
# ---- Tables ----
output$tbl_scorecard <- renderDT({
d <- dat_filt() |>
transmute(
PartnerID = partner_id,
Partner = partner_name,
Category = category_partner,
District = district_office_location,
EntityStart = as.character(entity_start_date),
CAREStart = as.character(start_date_partnership),
TenureYrs = round(partner_tenure_yrs, 1),
Contracts = no_contracts,
BudgetUSD = fy25_budget,
ExpensesUSD = fy25_expenses,
Absorption = absorption_rate
)
datatable(d, filter = "top", options = list(pageLength = 20, scrollX = TRUE)) |>
formatCurrency(c("BudgetUSD","ExpensesUSD"), currency = "$", digits = 0) |>
formatPercentage("Absorption", 1)
})
output$tbl_risks <- renderDT({
d <- dat_filt() |>
arrange(desc(fy25_budget)) |>
mutate(top5 = row_number() <= 5) |>
transmute(
Partner = partner_name,
Category = category_partner,
District = district_office_location,
BudgetUSD = fy25_budget,
ExpensesUSD = fy25_expenses,
Absorption = absorption_rate,
Underspend = underspend_flag,
Overspend = overspend_flag,
Top5Budget = top5
)
datatable(d, options = list(pageLength = 15, scrollX = TRUE)) |>
formatCurrency(c("BudgetUSD","ExpensesUSD"), "$", digits = 0) |>
formatPercentage("Absorption", 1)
})
# ---- Download cleaned outputs (Excel) ----
output$download_excel <- downloadHandler(
filename = function(){ "FY25_partnership_analysis.xlsx" },
content = function(file){
d <- dat_filt()
by_category <- d |> group_by(category_partner) |> summarise(
partners=n(), budget=sum(fy25_budget,na.rm=TRUE), expenses=sum(fy25_expenses,na.rm=TRUE),
absorption_rate = safe_div(expenses,budget), .groups="drop")
by_district <- d |> group_by(district_office_location) |> summarise(
partners=n(), budget=sum(fy25_budget,na.rm=TRUE), expenses=sum(fy25_expenses,na.rm=TRUE),
absorption_rate = safe_div(expenses,budget), .groups="drop")
by_tenure <- d |> mutate(tenure_band = case_when(
is.na(partner_tenure_yrs) ~ NA_character_,
partner_tenure_yrs < 1 ~ "<1y",
partner_tenure_yrs < 3 ~ "1–3y",
partner_tenure_yrs < 5 ~ "3–5y",
TRUE ~ "5y+"
)) |> group_by(tenure_band) |> summarise(
partners=n(), budget=sum(fy25_budget,na.rm=TRUE), expenses=sum(fy25_expenses,na.rm=TRUE),
absorption_rate=safe_div(expenses,budget), .groups="drop")
kpis <- tibble(
metric = c("Total partners","Total FY25 Budget","Total FY25 Expenses","Overall Absorption",
"Top-5 Budget Share","HHI (0-10,000)","Local Budget Share"),
value = c(nrow(d),
sum(d$fy25_budget,na.rm=TRUE),
sum(d$fy25_expenses,na.rm=TRUE),
safe_div(sum(d$fy25_expenses,na.rm=TRUE), sum(d$fy25_budget,na.rm=TRUE)),
d |> arrange(desc(fy25_budget)) |> slice_head(n=5) |> summarise(sum(fy25_budget,na.rm=TRUE)/sum(d$fy25_budget,na.rm=TRUE)) |> pull(1),
sum(((d$fy25_budget/sum(d$fy25_budget,na.rm=TRUE))*100)^2, na.rm=TRUE),
{
local_cats <- c("National NGO","CBO","CSO","Cooperative","WRO/WLO")
safe_div(sum(d$fy25_budget[d$category_partner %in% local_cats],na.rm=TRUE), sum(d$fy25_budget,na.rm=TRUE))
})
)
writexl::write_xlsx(
list(
"KPIs"=kpis, "Clean_Data"=d,
"By_Category"=by_category, "By_District"=by_district, "By_Tenure"=by_tenure
), path = file
)
}
)
}
shinyApp(ui, server)
/*
!.rsconnectignore
!deployment.qmd
!_quarto.yml
/*
!.rsconnectignore
!app.R
!www/
!data/