Budget vs Actual — Variance Analysis

suppressPackageStartupMessages(library(DT))
suppressPackageStartupMessages(library(htmlwidgets))
suppressPackageStartupMessages(library(arrow))
suppressPackageStartupMessages(library(knitr))
suppressPackageStartupMessages(library(rmarkdown))
suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(tidyr))
suppressPackageStartupMessages(library(ggplot2))
suppressPackageStartupMessages(library(stringr))
suppressPackageStartupMessages(library(lubridate))
suppressPackageStartupMessages(library(broom))
suppressPackageStartupMessages(library(Matrix))
suppressPackageStartupMessages(library(cluster))
suppressPackageStartupMessages(library(data.table))

fmt_money <- function(x) {
  format(round(as.numeric(x), 0), big.mark = ",", scientific = FALSE, trim = TRUE)
}

fmt_pct <- function(x) {
  ifelse(is.na(x), "n/a", sprintf("%+.1f%%", x))
}

compute_shared <- function(df, params, col_map = list()) {
  # === SHARED EXPORTS ===
  #   initial_rows/final_rows/rows_removed  $ row accounting
  #   n_missing_item / n_missing_value      $ preprocessing counts
  #   li_name/budget_name/actual_name       $ humanized user column names
  #   agg               $ data.frame(line_item, budget, actual, variance,
  #                       variance_pct, abs_variance, contribution_pct,
  #                       status, zero_budget) — one row per line item,
  #                       ordered by |variance| desc
  #   n_items           $ integer — distinct line items
  #   n_zero_budget     $ integer — items with a zero budget baseline
  #   total_budget / total_actual / total_variance / total_variance_pct
  #   total_abs_variance $ numeric — sum of |variance| across items
  #   overall_status    $ "over budget" | "under budget" | "on budget"
  #   n_over / n_under / n_on            $ integer classification counts
  #   biggest_item / biggest_variance    $ the single largest dollar swing
  #   variance_by_item_df / variance_detail_df / top_drivers_df
  #   metrics / json_output
  # === /SHARED EXPORTS ===

initial_rows <- nrow(df)
  li_name     <- humanize_semantic("line_item", col_map)[1]
  budget_name <- humanize_semantic("budget", col_map)[1]
  actual_name <- humanize_semantic("actual", col_map)[1]
  for (need in c("line_item", "budget", "actual")) {
    if (!need %in% names(df)) {
      stop(sprintf("Required column &#x27;%s' is not mapped.",
                   humanize_semantic(need, col_map)[1]))
    }
  }

item <- trimws(as.character(df$line_item))
  keep_item <- !is.na(item) & item != ""
  n_missing_item <- sum(!keep_item)
  df <- df[keep_item, , drop = FALSE]
  item <- item[keep_item]

coerce_money <- function(v, cname) {
    if (is.numeric(v)) return(v)
    conv <- suppressWarnings(as.numeric(gsub("[,$ ]", "", as.character(v))))
    n_orig <- sum(!is.na(v) & trimws(as.character(v)) != "")
    if (n_orig == 0 || sum(!is.na(conv)) < 0.95 * n_orig) {
      stop(sprintf(
        "Column &#x27;%s' is not numeric enough to use as a money amount — fewer than 95%% of its values could be read as numbers.",
        cname))
    }
    conv
  }
  budget <- coerce_money(df$budget, budget_name)
  actual <- coerce_money(df$actual, actual_name)

keep_val <- !is.na(budget) & !is.na(actual)
  n_missing_value <- sum(!keep_val)
  item   <- item[keep_val]
  budget <- budget[keep_val]
  actual <- actual[keep_val]

  final_rows <- length(item)
  rows_removed <- initial_rows - final_rows
  if (final_rows < 3) {
    stop(sprintf(
      "Only %d usable rows remain after cleaning &#x27;%s', '%s', and '%s' — need at least 3.",
      final_rows, li_name, budget_name, actual_name))
  }

raw <- data.frame(line_item = item, budget = budget, actual = actual,
                    stringsAsFactors = FALSE)
  agg <- raw %>%
    group_by(line_item) %>%
    summarise(budget = sum(budget), actual = sum(actual), .groups = "drop") %>%
    as.data.frame(stringsAsFactors = FALSE)

  n_items <- nrow(agg)
  if (n_items < 2) {
    stop(sprintf(
      "Only %d distinct line item found in &#x27;%s' — variance analysis needs at least 2.",
      n_items, li_name))
  }

agg$variance <- agg$actual - agg$budget
  agg$zero_budget <- agg$budget == 0
  agg$variance_pct <- ifelse(agg$zero_budget, NA_real_,
                             100 * agg$variance / abs(agg$budget))
  agg$abs_variance <- abs(agg$variance)

classify <- function(variance, variance_pct, zero_budget) {
    if (zero_budget) {
      if (variance == 0) return("on budget")
      return(if (variance > 0) "over budget" else "under budget")
    }
    if (abs(variance_pct) <= 1) return("on budget")
    if (variance > 0) "over budget" else "under budget"
  }
  agg$status <- mapply(classify, agg$variance, agg$variance_pct, agg$zero_budget)

total_abs_variance <- sum(agg$abs_variance)
  agg$contribution_pct <- if (total_abs_variance > 0)
    round(100 * agg$abs_variance / total_abs_variance, 1) else 0

agg <- agg[order(-agg$abs_variance), , drop = FALSE]
  rownames(agg) <- NULL

total_budget <- sum(agg$budget)
  total_actual <- sum(agg$actual)
  total_variance <- total_actual - total_budget
  total_variance_pct <- if (total_budget != 0)
    100 * total_variance / abs(total_budget) else NA_real_
  overall_status <- if (total_budget != 0 && !is.na(total_variance_pct) &&
                        abs(total_variance_pct) <= 1) {
    "on budget"
  } else if (total_variance > 0) "over budget"
  else if (total_variance < 0) "under budget" else "on budget"

  n_over  <- sum(agg$status == "over budget")
  n_under <- sum(agg$status == "under budget")
  n_on    <- sum(agg$status == "on budget")
  n_zero_budget <- sum(agg$zero_budget)

valid_idx <- which(!is.na(agg$abs_variance))
  top_i <- valid_idx[which.max(agg$abs_variance[valid_idx])]
  biggest_item <- agg$line_item[top_i]
  biggest_variance <- agg$variance[top_i]

variance_detail_df <- data.frame(
    line_item    = agg$line_item,
    budget       = fmt_money(agg$budget),
    actual       = fmt_money(agg$actual),
    variance     = fmt_money(agg$variance),
    variance_pct = fmt_pct(agg$variance_pct),
    status       = agg$status,
    stringsAsFactors = FALSE
  )
  rownames(variance_detail_df) <- NULL

drv <- head(agg, 10)
  top_drivers_df <- data.frame(
    line_item        = drv$line_item,
    variance         = fmt_money(drv$variance),
    variance_pct     = fmt_pct(drv$variance_pct),
    contribution_pct = drv$contribution_pct,
    stringsAsFactors = FALSE
  )
  rownames(top_drivers_df) <- NULL

  metrics <- list(
    `Line Items`     = n_items,
    `Total Budget`   = round(total_budget, 0),
    `Total Actual`   = round(total_actual, 0),
    `Total Variance` = round(total_variance, 0),
    `Over Budget`    = as.integer(n_over),
    `Under Budget`   = as.integer(n_under)
  )

  pct_txt <- if (!is.na(total_variance_pct))
    sprintf("%+.1f%%", total_variance_pct) else "n/a"
  json_output <- list(
    answer = paste0(
      "Actuals totalled ", fmt_money(total_actual), " against a budget of ",
      fmt_money(total_budget), " — an overall variance of ",
      fmt_money(total_variance), " (", pct_txt, "), i.e. ", overall_status,
      " for the period. The single biggest swing was ", biggest_item,
      " at ", fmt_money(biggest_variance), ". Of ",
      format(n_items, big.mark = ","), " line items, ", n_over,
      " came in over budget, ", n_under, " under, and ", n_on,
      " on budget(within +/-1%). Whether each swing is favorable depends on ",
      "whether the line is revenue-like or cost-like — read the direction ",
      "against your own chart of accounts."
    ),
    cards = lapply(
      c("tldr", "overview", "preprocessing", "variance_by_item",
        "variance_table", "biggest_drivers"),
      function(cid) list(id = cid, metrics = metrics)
    )
  )

  list(
    initial_rows = initial_rows, final_rows = final_rows,
    rows_removed = rows_removed,
    n_missing_item = n_missing_item, n_missing_value = n_missing_value,
    li_name = li_name, budget_name = budget_name, actual_name = actual_name,
    agg = agg, n_items = n_items, n_zero_budget = n_zero_budget,
    total_budget = total_budget, total_actual = total_actual,
    total_variance = total_variance, total_variance_pct = total_variance_pct,
    total_abs_variance = total_abs_variance, overall_status = overall_status,
    n_over = n_over, n_under = n_under, n_on = n_on,
    biggest_item = biggest_item, biggest_variance = biggest_variance,
    variance_by_item_df = variance_by_item_df,
    variance_detail_df = variance_detail_df,
    top_drivers_df = top_drivers_df,
    metrics = metrics, json_output = json_output
  )
}

# Card: tldr (tldr)
card_tldr <- function(shared, df, params) {
  pct_txt <- if (!is.na(shared$total_variance_pct))
    sprintf("%+.1f%%", shared$total_variance_pct) else "n/a"
  swing_dir <- if (shared$biggest_variance > 0) "over"
               else if (shared$biggest_variance < 0) "under" else "on"
  text <- paste0(
    "Actuals came in at ", fmt_money(shared$total_actual), " against a ",
    shared$budget_name, " of ", fmt_money(shared$total_budget), " — an ",
    "overall variance of ", fmt_money(shared$total_variance), " (", pct_txt,
    "), ", shared$overall_status, " for the period. The single biggest ",
    "dollar swing is ", shared$biggest_item, ", ", swing_dir, " by ",
    fmt_money(abs(shared$biggest_variance)), ". Across ",
    format(shared$n_items, big.mark = ","), " line items, ", shared$n_over,
    " are over budget, ", shared$n_under, " are under, and ", shared$n_on,
    " landed on budget(within +/-1%). Direction alone is neutral here — ",
    "over on a revenue line is good, over on a cost line is not."
  )
  list(
    title = "Executive Summary",
    description = paste0("Budget vs actual across ",
                         format(shared$n_items, big.mark = ","), " line items"),
    metrics = shared$metrics,
    text = text
  )
}