# ============================================================================= # Agnostic Fundamental Analysis -- current default: v7c (v3b + monthly winsorizing) # Common Task Framework submission (defines main(chars, features, daily_ret)) # # Builds on Bartram & Grinblatt (2018, JFE), "Agnostic Fundamental Analysis Works": # 1. Each month t, regress market cap V on ~35 firm-level accounting items # (dollar levels, with intercept) by OLS, separately within each asset-size # tercile (small / mid / large by total assets), with Fama-French 12 sector # intercepts. Fitted value P = peer-implied fair value. # (Alternatives via CONFIG: FF12 sector sub-models, or one pooled model as in B&G.) # 2. Mispricing M = (P - V) / V (B&G eq. 1; positive = underpriced) # 3. Sort into quintiles on M; long Q5 (underpriced), short Q1 (overpriced), # equal-weighted, rebalanced monthly. # # Everything used at month t is known at t: regressions are cross-sectional # within month t, and winsorizing cut-offs use data up to and including t. # All tunable choices live in CONFIG. # # CTF Admin Modifications (2026-10-05): # -------------------------------------- # 1. Reworded the trailing comment on line 50 to remove an apostrophe. # Reason: the pipeline syntax check reads an apostrophe in a trailing # comment as an unclosed string and rejects the file. The code itself # is unchanged. # ============================================================================= library(data.table) # ---- Configuration ------------------------------------------------------------- CONFIG <- list( version = "v7c", method = "ols", # "ols" | "enet" (elastic net via glmnet, lambda by monthly CV) enet_alpha = 0.5, # enet: 0 = ridge, 1 = lasso enet_lambda = "min", # enet: "min" = lowest CV error | "1se" = more shrinkage enet_folds = 10, # enet: CV folds across firms (fold = id mod folds; deterministic) sector_scheme = "assets3", # sub-models: "ff12" sectors | "assets3" asset-size terciles | "none" pooled sector_intercepts = TRUE, # add FF12 sector dummies to every regression hybrid_sector_models = FALSE, # v4: sectors with enough firms get their own model # (with size intercepts); others keep the base model sector_size_buckets = 5, # v4: within-sector asset quantile buckets for size intercepts scale = "levels", # "levels" = OLS on dollar levels (B&G) | "assets" = divide the # whole equation by total assets (WLS, weights 1/assets^2) loo = FALSE, # leave-one-out fair value: value each firm from its peers only loo_max_h = 0.95, # with loo: firms with leverage h_ii above this get no valuation neutralize_reversal = FALSE, # sort on the part of M not explained by the previous month return include_financials = TRUE, # B&G exclude SIC 6000-6999 financials_model = FALSE, # v12: financials (SIC 6000-6999) get their own regression; # size terciles are formed among non-financials only min_firms_per_param = 5, # sector model only if n >= this x (number of regressors) min_price = 5, # B&G: price >= $5 extra_lag_months = 0, # data is already lagged 4 months by JKP winsor = c(0.05, 0.95),# B&G: item/assets at 5/95%; NULL = off winsor_window = "monthly", # "monthly" = month-t cross-section | "expanding" = all data up to t (B&G) coverage_min = 0.80, # use an item in a regression only if >= 80% of firms report it n_groups = 5, # quintiles (B&G) sort_within = "all", # "all" | "sector" (sector-neutral) | "size" (within asset terciles) leg_weighting = "ew", # "ew" | "vw" within long and short legs output = "test" # "test" = ctff_test rows only | "all" ) # ---- Accounting items (selected by rule, not by performance) -------------------- # Rule: every reported accounting amount available in the data, one version each, # converted to firm-level dollars (B&G use firm-level dollar items). Excluded: # market-based items (enterprise value, CRSP dividends), model outputs (intrinsic # value), and items that are exact sums of other items. ITEMS_DIRECT <- c(assets = "assets", sales = "sales", ni = "net_income", be = "book_equity") ITEMS_AT <- c("gp", "opex", "ebitda", "ebit", "xido", "spi", "nri", "rd", "cop", "niq", "ocf", "capx", "fincf", "div", "eqbb", "eqis", "dltnetis", "dstnetis", "oaccruals", "taccruals", "cash", "nwc", "noa", "aliq") # x_at * assets ITEMS_MEV <- c("bev", "debtlt", "debtst", "pstk", "ppen") # x_mev * enterprise value ZERO_FILL <- c("rd", "xint") # missing usually means "none": set to 0 + missing indicator ITEMS <- c(names(ITEMS_DIRECT), ITEMS_AT, ITEMS_MEV, "xint") RATIO_COLS <- setNames(paste0("r_", setdiff(ITEMS, "assets")), setdiff(ITEMS, "assets")) # x / assets needed_columns <- function() { c("id", "eom", "sic", "prc", "ctff_test", "ret_exc_lead1m", "ret_1_0", "market_equity", "enterprise_value", "ope_me", unname(ITEMS_DIRECT), paste0(ITEMS_AT, "_at"), paste0(ITEMS_MEV, "_mev")) } # ---- Fama-French 12 industries from SIC ------------------------------------------ ff12 <- function(sic) { s <- suppressWarnings(as.integer(sic)) fcase( is.na(s), "Other", (s >= 100 & s <= 999) | (s >= 2000 & s <= 2399) | (s >= 2700 & s <= 2749) | (s >= 2770 & s <= 2799) | (s >= 3100 & s <= 3199) | (s >= 3940 & s <= 3989), "NoDur", (s >= 2500 & s <= 2519) | (s >= 2590 & s <= 2599) | (s >= 3630 & s <= 3659) | (s >= 3710 & s <= 3711) | s == 3714 | s == 3716 | (s >= 3750 & s <= 3751) | s == 3792 | (s >= 3900 & s <= 3939) | (s >= 3990 & s <= 3999), "Durbl", (s >= 2520 & s <= 2589) | (s >= 2600 & s <= 2699) | (s >= 2750 & s <= 2769) | (s >= 3000 & s <= 3099) | (s >= 3200 & s <= 3569) | (s >= 3580 & s <= 3629) | (s >= 3700 & s <= 3709) | (s >= 3712 & s <= 3713) | s == 3715 | (s >= 3717 & s <= 3749) | (s >= 3752 & s <= 3791) | (s >= 3793 & s <= 3799) | (s >= 3830 & s <= 3839) | (s >= 3860 & s <= 3899), "Manuf", (s >= 1200 & s <= 1399) | (s >= 2900 & s <= 2999), "Enrgy", (s >= 2800 & s <= 2829) | (s >= 2840 & s <= 2899), "Chems", (s >= 3570 & s <= 3579) | (s >= 3660 & s <= 3692) | (s >= 3694 & s <= 3699) | (s >= 3810 & s <= 3829) | (s >= 7370 & s <= 7379), "BusEq", s >= 4800 & s <= 4899, "Telcm", s >= 4900 & s <= 4949, "Utils", (s >= 5000 & s <= 5999) | (s >= 7200 & s <= 7299) | (s >= 7600 & s <= 7699), "Shops", (s >= 2830 & s <= 2839) | s == 3693 | (s >= 3840 & s <= 3859) | (s >= 8000 & s <= 8099), "Hlth", s >= 6000 & s <= 6999, "Money", default = "Other" ) } # ---- Step 1: data preparation ------------------------------------------------------ prepare_data <- function(chars, cfg) { # select the needed columns before copying (chars has ~410 columns in the CTF run) dt <- as.data.table(as.data.frame(chars)[, intersect(needed_columns(), names(chars)), drop = FALSE]) dt[, ctff_test := as.character(ctff_test) %in% c("1", "TRUE", "true", "True")] dt[, eom := as.Date(eom)] dt[, sector := ff12(sic)] if (!cfg$include_financials) dt <- dt[sector != "Money"] # Firm-level dollar amounts for (v in names(ITEMS_DIRECT)) set(dt, j = v, value = dt[[ITEMS_DIRECT[[v]]]]) for (v in ITEMS_AT) set(dt, j = v, value = dt[[paste0(v, "_at")]] * dt$assets) for (v in ITEMS_MEV) set(dt, j = v, value = dt[[paste0(v, "_mev")]] * dt$enterprise_value) dt[, xint := ebitda - ope_me * market_equity] # interest = EBITDA - (EBITDA - XINT) # Optional extra lag: accounting items from k months earlier (same firm) if (cfg$extra_lag_months > 0) { dt[, ym := year(eom) * 12L + month(eom)] lagged <- dt[, c("id", "ym", ITEMS), with = FALSE][, ym := ym + cfg$extra_lag_months] dt[, (ITEMS) := NULL] dt <- merge(dt, lagged, by = c("id", "ym"), all.x = TRUE) dt[, ym := NULL] } # Sample screens (B&G): positive assets and market cap, price >= $5 dt[, eligible := !is.na(market_equity) & market_equity > 0 & !is.na(assets) & assets > 0 & !is.na(prc) & abs(prc) >= cfg$min_price] # Accounting-size groups: monthly terciles of total assets among eligible firms. # Grouping on assets (a regressor), not market cap (the dependent variable), # avoids selecting the sample on V. if (isTRUE(cfg$financials_model)) { # Banks and insurers have very large balance sheets relative to market value and # do not report items such as working capital or capex. Pooled with industrials # they distort the asset breakpoints and push items below the coverage rule for # every large firm, so they get their own group (and regression). dt[eligible == TRUE & sector != "Money", size3 := c("Small", "Mid", "Large")[pmax(1L, as.integer(ceiling(ecdf(assets)(assets) * 3)))], by = eom] dt[eligible == TRUE & sector == "Money", size3 := "Financials"] } else { dt[eligible == TRUE, size3 := c("Small", "Mid", "Large")[pmax(1L, as.integer(ceiling(ecdf(assets)(assets) * 3)))], by = eom] } # Work with ratios to assets (scale-free) for winsorizing and imputation ratio_items <- setdiff(ITEMS, "assets") for (v in ratio_items) set(dt, j = paste0("r_", v), value = dt[[v]] / dt$assets) setorder(dt, eom, id) dt[] } # ---- Step 2: winsorize item/assets ratios (B&G p.129) ----------------------------- # Cut-offs at month t come from all eligible observations dated <= t ("expanding") # or from month t only ("monthly"). No future data is used either way. # Expanding-window type-7 quantiles (same arithmetic as stats::quantile), month by # month. Each item's history is sorted once; every month we mark that month's values # as "in" and keep counts per block of sorted positions, so finding the k-th # smallest value costs ~sqrt(N) instead of re-sorting all past data every month. expanding_cuts <- function(vals, month_id, n_months, probs, min_n = 20L) { N <- length(vals) cuts <- matrix(c(-Inf, Inf), n_months, 2, byrow = TRUE) if (N < min_n) return(cuts) o <- order(vals); sv <- vals[o] # sorted history rk <- integer(N); rk[o] <- seq_len(N) # sorted position of each value bs <- as.integer(ceiling(sqrt(N))); nb <- as.integer(ceiling(N / bs)) blk_cnt <- integer(nb) # values "in" per block inserted <- logical(N) kth <- function(k) { # k-th smallest value "in" so far cs <- cumsum(blk_cnt); b <- which(cs >= k)[1] before <- if (b > 1L) cs[b - 1L] else 0L s <- (b - 1L) * bs + 1L; e <- min(b * bs, N) sv[s - 1L + which(inserted[s:e])[k - before]] } om <- order(month_id); rk <- rk[om] # group values by month (integer sort) cnt <- tabulate(month_id, n_months); ends <- cumsum(cnt) n <- 0L for (j in seq_len(n_months)) { if (cnt[j]) { r <- rk[(ends[j] - cnt[j] + 1L):ends[j]] inserted[r] <- TRUE blk_cnt <- blk_cnt + tabulate((r - 1L) %/% bs + 1L, nb) n <- n + length(r) } if (n >= min_n) { index <- 1 + (n - 1) * probs lo <- floor(index); hi <- ceiling(index) qs <- vapply(lo, kth, numeric(1)); xhi <- vapply(hi, kth, numeric(1)) i <- which(index > lo & xhi != qs); h <- (index - lo)[i] qs[i] <- (1 - h) * qs[i] + h * xhi[i] cuts[j, ] <- qs } } cuts } winsorize_ratios <- function(dt, cfg) { if (is.null(cfg$winsor)) return(dt) months <- sort(unique(dt$eom)) # Month index as plain integers, computed once (match() on Date objects converts # them to text, which is very slow on a million rows) mi <- match(as.integer(dt$eom), as.integer(months)) for (v in setdiff(ITEMS, "assets")) { rv <- paste0("r_", v) ok <- dt$eligible & is.finite(dt[[rv]]) if (cfg$winsor_window == "expanding") { cuts <- expanding_cuts(dt[[rv]][ok], mi[ok], length(months), cfg$winsor) } else { by_month <- split(dt[[rv]][ok], factor(mi[ok], levels = seq_along(months))) cuts <- matrix(c(-Inf, Inf), length(months), 2, byrow = TRUE) for (j in seq_along(months)) { x <- by_month[[j]] if (length(x) >= 20) cuts[j, ] <- quantile(x, cfg$winsor, names = FALSE, type = 7) } } lo <- cuts[mi, 1]; hi <- cuts[mi, 2] set(dt, j = rv, value = pmin(pmax(dt[[rv]], lo), hi)) } dt } # ---- Step 3: fair-value regression for one group (sector-month or month) ------------ # Returns fitted fair values P, hat values h (diagonal of the hat matrix), and the # number of regressors used. Items reported by < coverage_min of the group are # dropped; remaining gaps are filled with the group median ratio x/assets. # Elastic net version of the fair-value regression (method = "enet"). Same # regressors as OLS; glmnet standardizes them within each regression, adds an # unpenalized intercept, and leaves the sector intercepts unpenalized. The penalty # lambda is chosen by K-fold cross-validation across the firms in the same group and # month (predicting held-out firms' market caps), so it uses no future data. Folds # are assigned by firm id, so results are reproducible without a random seed. # Hat values are not defined for the elastic net (h = NA). fit_enet <- function(X, me, cfg, ids) { if (!requireNamespace("glmnet", quietly = TRUE)) stop("method = 'enet' requires the glmnet package") X <- X[, apply(X, 2, function(x) var(x) > 0), drop = FALSE] # drop constant columns pf <- ifelse(startsWith(colnames(X), "sector_"), 0, 1) nf <- min(cfg$enet_folds, max(3L, nrow(X) %/% 10L)) fold <- if (is.null(ids)) rep_len(seq_len(nf), nrow(X)) else as.integer(ids %% nf) + 1L fold <- match(fold, sort(unique(fold))) # folds numbered 1..K cv <- glmnet::cv.glmnet(X, me, alpha = cfg$enet_alpha, foldid = fold, penalty.factor = pf, standardize = TRUE) s <- if (identical(cfg$enet_lambda, "1se")) "lambda.1se" else "lambda.min" list(P = as.numeric(predict(cv, newx = X, s = s)), h = rep(NA_real_, length(me)), p = sum(as.numeric(coef(cv, s = s)) != 0)) # nonzero coefficients incl. intercept } # Inputs: R = matrix of item/assets ratios (one column per item), plus assets, # market cap and sector for the firms in the group. fit_group <- function(R, assets, me, sector, cfg, bucket = NULL, ids = NULL) { X <- list(assets = assets) for (v in names(RATIO_COLS)) { r <- R[, v] miss <- !is.finite(r) if (v %in% ZERO_FILL) { r[miss] <- 0 X[[v]] <- r * assets if (any(miss) && !all(miss)) X[[paste0(v, "_missing")]] <- as.numeric(miss) } else if (mean(!miss) >= cfg$coverage_min) { if (any(miss)) r[miss] <- median(r[!miss]) X[[v]] <- r * assets } } if (isTRUE(cfg$sector_intercepts)) { # sector-specific valuation levels secs <- sort(unique(sector)) for (s in secs[-1]) X[[paste0("sector_", s)]] <- as.numeric(sector == s) } if (!is.null(bucket)) { # size intercepts (v4 sector models) bks <- sort(unique(bucket)) for (b in bks[-1]) X[[paste0("size_", b)]] <- as.numeric(bucket == b) } if (identical(cfg$method, "enet")) return(fit_enet(do.call(cbind, X), me, cfg, ids)) X <- cbind(1, do.call(cbind, X)) # Asset scaling: V/A = X/A b + e/A, i.e. the same valuation equation estimated by # WLS with weights 1/A^2, so mega-caps no longer dominate the squared errors. # Fair value is still X b (= A x fitted ratio); h_ii is the weighted leverage. s <- if (identical(cfg$scale, "assets")) assets else rep(1, length(me)) qx <- qr(X / s) P <- qr.fitted(qx, me / s) * s Q <- qr.Q(qx)[, seq_len(qx$rank), drop = FALSE] list(P = P, h = rowSums(Q^2), p = qx$rank) } # Group sub-models (FF12 sectors or asset-size terciles) with fallback to the pooled # monthly model when a group has too few firms per regressor (a near-saturated # regression absorbs the residual, i.e. the very mispricing we want to measure). # The pooled model is only estimated in months where some group needs it. estimate_fair_value <- function(dt, cfg) { est <- dt[eligible == TRUE] R <- as.matrix(est[, RATIO_COLS, with = FALSE]); colnames(R) <- names(RATIO_COLS) A <- est$assets; ME <- est$market_equity; SEC <- est$sector; ID <- est$id grp <- switch(cfg$sector_scheme, assets3 = est$size3, ff12 = est$sector, NULL) P <- h <- rep(NA_real_, nrow(est)); model <- rep(NA_character_, nrow(est)) n_reg <- rep(NA_integer_, nrow(est)) fit <- function(i) fit_group(R[i, , drop = FALSE], A[i], ME[i], SEC[i], cfg, ids = ID[i]) fits <- list() month_rows <- split(seq_len(nrow(est)), as.integer(est$eom)) for (idx in month_rows) { m <- est$eom[idx[1]] need_pooled <- is.null(grp) if (!is.null(grp)) { for (s in sort(unique(grp[idx]))) { sidx <- idx[grp[idx] == s] f <- fit(sidx) fit_ok <- length(sidx) >= cfg$min_firms_per_param * f$p if (fit_ok) { P[sidx] <- f$P; h[sidx] <- f$h; model[sidx] <- s; n_reg[sidx] <- f$p } else need_pooled <- TRUE fits[[length(fits) + 1]] <- list(eom = m, sector = s, n = length(sidx), p = f$p, used = fit_ok) } } if (need_pooled) { # fallback for groups that failed f <- fit(idx) fb <- is.na(model[idx]); fidx <- idx[fb] P[fidx] <- f$P[fb]; h[fidx] <- f$h[fb]; model[fidx] <- "pooled"; n_reg[fidx] <- f$p fits[[length(fits) + 1]] <- list(eom = m, sector = "ALL", n = length(idx), p = f$p, used = TRUE) } if (isTRUE(cfg$hybrid_sector_models)) { # v4: own model for big sectors for (s in sort(unique(SEC[idx]))) { sidx <- idx[SEC[idx] == s] if (length(sidx) < cfg$min_firms_per_param * 20) next # cannot qualify; skip the fit a <- A[sidx] # within-sector asset buckets bucket <- pmax(1L, as.integer(ceiling(ecdf(a)(a) * cfg$sector_size_buckets))) f <- fit_group(R[sidx, , drop = FALSE], a, ME[sidx], SEC[sidx], cfg, bucket = bucket, ids = ID[sidx]) fit_ok <- length(sidx) >= cfg$min_firms_per_param * f$p if (fit_ok) { P[sidx] <- f$P; h[sidx] <- f$h; model[sidx] <- paste0("sector:", s); n_reg[sidx] <- f$p } fits[[length(fits) + 1]] <- list(eom = m, sector = paste0("sector:", s), n = length(sidx), p = f$p, used = fit_ok) } } } if (isTRUE(cfg$loo)) { # Leave-one-out: the residual from a fit without firm i equals e_i / (1 - h_ii), # so P_i(-i) = V_i - (V_i - P_i) / (1 - h_ii). Firms with h_ii near 1 cannot be # valued from peers (no other firms span their accounting) and are dropped. keep <- h <= cfg$loo_max_h P <- ifelse(keep, ME - (ME - P) / (1 - h), NA_real_) cat(sprintf("[%s] leave-one-out: %.2f%% of firm-months dropped (h_ii > %.2f)\n", cfg$version, 100 * mean(!keep), cfg$loo_max_h)) } est[, `:=`(P = P, h = h, model = model, n_reg = n_reg)] est[, M := (P - market_equity) / market_equity] # B&G eq. (1) list(est = est, fits = rbindlist(fits)) } # ---- Step 4: portfolio weights ----------------------------------------------------- # Class approach (code_7_9.R pf_sort): percentile via ecdf, group = ceiling(pct * n). build_portfolio <- function(est, cfg) { by_cols <- switch(cfg$sort_within, sector = c("eom", "sector"), size = c("eom", "size3"), "eom") est[, signal := M] if (isTRUE(cfg$neutralize_reversal)) { # Within each month (and sort group), regress the rank of M on the rank of last # month's return and keep the residual, so a stock that just jumped is not # labelled "overpriced" merely because its price moved before its accounting. est[!is.na(M), signal := { rm <- frank(M) / .N rr <- frank(ret_1_0, na.last = "keep") / .N rr[is.na(rr)] <- mean(rr, na.rm = TRUE) if (all(is.na(rr)) || var(rr) == 0) rm else rm - cov(rm, rr) / var(rr) * (rr - mean(rr)) }, by = by_cols] } # firms without a valuation (M missing) get no portfolio group and zero weight est[!is.na(M), pf := pmax(1L, as.integer(ceiling(ecdf(signal)(signal) * cfg$n_groups))), by = by_cols] est[, leg := fcase(!is.na(pf) & pf == cfg$n_groups, 1, !is.na(pf) & pf == 1L, -1, default = 0)] if (cfg$leg_weighting == "vw") { est[leg != 0, w := leg * market_equity / sum(market_equity), by = .(eom, leg)] } else { est[leg != 0, w := leg / .N, by = .(eom, leg)] } est[leg == 0, w := 0] est } # ---- Full pipeline (used by main() and by the research scripts) ------------------- run_model <- function(chars, cfg = CONFIG) { t0 <- Sys.time() dt <- prepare_data(chars, cfg) dt <- winsorize_ratios(dt, cfg) fv <- estimate_fair_value(dt, cfg) est <- build_portfolio(fv$est, cfg) # Every input row gets a weight (0 if ineligible or not in Q1/Q5) out <- merge(dt[, .(id, eom, sector, size3, ctff_test, ret_exc_lead1m, market_equity)], est[, .(id, eom, P, h, M, model, n_reg, pf, w)], by = c("id", "eom"), all.x = TRUE) out[is.na(w), w := 0] cat(sprintf("[%s] run_model done: %d rows, %d months, %.1f min\n", cfg$version, nrow(out), uniqueN(out$eom), as.numeric(difftime(Sys.time(), t0, units = "mins")))) list(panel = out, fits = fv$fits) } # ---- CTF entry point ------------------------------------------------------------- main <- function(chars, features, daily_ret) { res <- run_model(chars, CONFIG)$panel if (CONFIG$output == "test") res <- res[ctff_test == TRUE] data.frame(id = as.integer(res$id), eom = as.Date(res$eom), w = as.numeric(res$w)) }