sica-fondt/core/src/economy/sims/statistical/main.R

#!/usr/bin/env Rscript
#
# M3a — Statistical & quantitative sims
# Language: R (native stats ecosystem)
# Protocol: line-delimited JSON on stdin/stdout to hub.tcl

# -- BoundedPrediction output ---------------------------------------------

bounded_prediction <- function(value, lower, upper, confidence,
                               horizon, sim_type = "statistical") {
  stopifnot(lower <= value, value <= upper)
  stopifnot(confidence >= 0.0, confidence <= 10.0)
  list(
    value       = value,
    lower_bound = lower,
    upper_bound = upper,
    confidence  = confidence,
    time_horizon = horizon,
    sim_type    = sim_type,
    timestamp   = as.numeric(Sys.time()) * 1000
  )
}

# -- Geometric Brownian Motion (Monte Carlo) -------------------------------

gbm_paths <- function(S0, mu, sigma, dt, n_steps, n_paths) {
  Z <- matrix(rnorm(n_steps * n_paths), nrow = n_steps)
  log_returns <- (mu - 0.5 * sigma^2) * dt + sigma * sqrt(dt) * Z
  S <- matrix(S0, nrow = n_steps + 1, ncol = n_paths)
  for (t in seq_len(n_steps)) {
    S[t + 1, ] <- S[t, ] * exp(log_returns[t, ])
  }
  S
}

gbm_predict <- function(S0, mu, sigma, horizon_hours, n_paths = 10000L) {
  dt <- 1 / (252 * 24)
  n_steps <- as.integer(horizon_hours)
  paths <- gbm_paths(S0, mu, sigma, dt, n_steps, n_paths)
  final <- paths[n_steps + 1, ]
  bounded_prediction(
    value  = median(final),
    lower  = quantile(final, 0.025, names = FALSE),
    upper  = quantile(final, 0.975, names = FALSE),
    confidence = 9.50,
    horizon = paste0(horizon_hours, "h")
  )
}

# -- Heston stochastic volatility -----------------------------------------
# dS = mu*S*dt + sqrt(nu)*S*dW^S
# dnu = kappa*(theta - nu)*dt + xi*sqrt(nu)*dW^nu
# corr(dW^S, dW^nu) = rho
# Euler-Maruyama with full truncation (nu >= 0)

heston_paths <- function(S0, nu0, mu, kappa, theta, xi, rho,
                         dt, n_steps, n_paths) {
  S  <- matrix(S0,  nrow = n_steps + 1, ncol = n_paths)
  nu <- matrix(nu0, nrow = n_steps + 1, ncol = n_paths)

  for (t in seq_len(n_steps)) {
    Z1 <- rnorm(n_paths)
    Z2 <- rho * Z1 + sqrt(1 - rho^2) * rnorm(n_paths)

    nu_pos <- pmax(nu[t, ], 0)
    sqrt_nu <- sqrt(nu_pos)

    nu[t + 1, ] <- pmax(
      nu[t, ] + kappa * (theta - nu_pos) * dt + xi * sqrt_nu * sqrt(dt) * Z1,
      0
    )
    S[t + 1, ] <- S[t, ] * exp(
      (mu - 0.5 * nu_pos) * dt + sqrt_nu * sqrt(dt) * Z2
    )
  }
  list(S = S, nu = nu)
}

heston_predict <- function(S0, nu0, mu, kappa, theta, xi, rho,
                           horizon_hours, n_paths = 5000L) {
  dt <- 1 / (252 * 24)
  n_steps <- as.integer(horizon_hours)
  result <- heston_paths(S0, nu0, mu, kappa, theta, xi, rho,
                         dt, n_steps, n_paths)
  final_S <- result$S[n_steps + 1, ]
  final_nu <- result$nu[n_steps + 1, ]

  price_pred <- bounded_prediction(
    value  = median(final_S),
    lower  = quantile(final_S, 0.025, names = FALSE),
    upper  = quantile(final_S, 0.975, names = FALSE),
    confidence = 9.00,
    horizon = paste0(horizon_hours, "h")
  )
  vol_pred <- bounded_prediction(
    value  = median(sqrt(final_nu)),
    lower  = quantile(sqrt(pmax(final_nu, 0)), 0.025, names = FALSE),
    upper  = quantile(sqrt(pmax(final_nu, 0)), 0.975, names = FALSE),
    confidence = 8.50,
    horizon = paste0(horizon_hours, "h")
  )
  list(price = price_pred, volatility = vol_pred)
}

# -- Merton jump-diffusion ------------------------------------------------
# dS = (mu - lambda*k)*S*dt + sigma*S*dW + S*dJ
# J ~ Poisson(lambda*dt), jump size ~ LogNormal(mu_j, sigma_j)

merton_paths <- function(S0, mu, sigma, lambda, mu_j, sigma_j,
                         dt, n_steps, n_paths) {
  S <- matrix(S0, nrow = n_steps + 1, ncol = n_paths)
  k <- exp(mu_j + 0.5 * sigma_j^2) - 1

  for (t in seq_len(n_steps)) {
    Z <- rnorm(n_paths)
    N_jumps <- rpois(n_paths, lambda * dt)
    J <- ifelse(N_jumps > 0,
                exp(rnorm(n_paths, mu_j * N_jumps, sigma_j * sqrt(N_jumps))),
                1)
    S[t + 1, ] <- S[t, ] * exp(
      (mu - lambda * k - 0.5 * sigma^2) * dt + sigma * sqrt(dt) * Z
    ) * J
  }
  S
}

# -- HMM regime detection (3-state: Bull, Neutral, Bear) ------------------
# r_t | s_t ~ N(mu_{s_t}, sigma_{s_t}^2)
# Forward algorithm for online filtering

hmm_states <- c("bull", "neutral", "bear")

hmm_filter <- function(returns, mu_vec, sigma_vec, trans_mat, init_prob) {
  n <- length(returns)
  K <- length(mu_vec)
  alpha <- matrix(0, nrow = n, ncol = K)

  emit <- dnorm(returns[1], mu_vec, sigma_vec)
  alpha[1, ] <- init_prob * emit
  alpha[1, ] <- alpha[1, ] / sum(alpha[1, ])

  for (t in 2:n) {
    emit <- dnorm(returns[t], mu_vec, sigma_vec)
    for (j in seq_len(K)) {
      alpha[t, j] <- emit[j] * sum(alpha[t - 1, ] * trans_mat[, j])
    }
    alpha[t, ] <- alpha[t, ] / sum(alpha[t, ])
  }
  alpha
}

hmm_current_regime <- function(returns, mu_vec, sigma_vec, trans_mat,
                               init_prob) {
  alpha <- hmm_filter(returns, mu_vec, sigma_vec, trans_mat, init_prob)
  last_row <- alpha[nrow(alpha), ]
  state_idx <- which.max(last_row)
  bounded_prediction(
    value  = state_idx,
    lower  = state_idx,
    upper  = state_idx,
    confidence = round(max(last_row) * 10, 2),
    horizon = "current"
  )
}

# -- GARCH(1,1) volatility ------------------------------------------------

garch11_fit <- function(returns) {
  n <- length(returns)
  omega <- var(returns) * 0.05
  alpha <- 0.10
  beta  <- 0.85
  sigma2 <- numeric(n)
  sigma2[1] <- var(returns)

  for (t in 2:n) {
    sigma2[t] <- omega + alpha * returns[t - 1]^2 + beta * sigma2[t - 1]
  }
  list(sigma2 = sigma2, omega = omega, alpha = alpha, beta = beta)
}

garch_predict <- function(returns, horizon_hours) {
  fit <- garch11_fit(returns)
  last_var <- tail(fit$sigma2, 1)
  unconditional_var <- fit$omega / (1 - fit$alpha - fit$beta)
  forecast_var <- numeric(horizon_hours)
  forecast_var[1] <- last_var

  for (h in 2:horizon_hours) {
    forecast_var[h] <- fit$omega +
      (fit$alpha + fit$beta) * forecast_var[h - 1]
  }

  vol <- sqrt(mean(forecast_var))
  bounded_prediction(
    value  = vol,
    lower  = vol * 0.7,
    upper  = vol * 1.4,
    confidence = 8.50,
    horizon = paste0(horizon_hours, "h")
  )
}

# -- Sim state (mutable, updated by ticks and calibration) -----------------

sim_state <- new.env(parent = emptyenv())
sim_state$params <- list(
  S0    = 1800,
  mu    = 0.05,
  sigma = 0.60,
  nu0   = 0.36,
  kappa = 2.0,
  theta = 0.36,
  xi    = 0.50,
  rho   = -0.70,
  lambda = 5.0,
  mu_j   = -0.02,
  sigma_j = 0.05,
  hmm_mu    = c(0.001, 0.0, -0.001),
  hmm_sigma = c(0.01, 0.015, 0.025),
  hmm_trans = matrix(c(
    0.95, 0.03, 0.02,
    0.05, 0.90, 0.05,
    0.02, 0.03, 0.95
  ), nrow = 3, byrow = TRUE),
  hmm_init = c(1/3, 1/3, 1/3)
)
sim_state$price_history <- numeric(0)
sim_state$tick_count <- 0L

# -- Self-test when run directly -------------------------------------------

if (!interactive() && identical(commandArgs(trailingOnly = TRUE), character(0))) {
  cat("M3a Statistical Sim — R", paste(R.version$major, R.version$minor, sep = "."), "\n")

  cat("\nGBM Monte Carlo (24h, 1000 paths):\n")
  bp <- gbm_predict(1800, 0.05, 0.60, 24, 1000L)
  cat(sprintf("  price: %.2f [%.2f, %.2f] confidence: %.2f/10.00\n",
              bp$value, bp$lower_bound, bp$upper_bound, bp$confidence))

  cat("\nHeston SV (24h, 1000 paths):\n")
  hp <- heston_predict(1800, 0.36, 0.05, 2.0, 0.36, 0.50, -0.70, 24, 1000L)
  cat(sprintf("  price: %.2f [%.2f, %.2f]\n",
              hp$price$value, hp$price$lower_bound, hp$price$upper_bound))
  cat(sprintf("  vol:   %.4f [%.4f, %.4f]\n",
              hp$volatility$value, hp$volatility$lower_bound,
              hp$volatility$upper_bound))

  cat("\nHMM regime (synthetic returns):\n")
  set.seed(42)
  returns <- c(rnorm(50, 0.001, 0.01), rnorm(50, -0.001, 0.025))
  rp <- hmm_current_regime(returns,
                           c(0.001, 0.0, -0.001),
                           c(0.01, 0.015, 0.025),
                           matrix(c(0.95,0.03,0.02,
                                    0.05,0.90,0.05,
                                    0.02,0.03,0.95), 3, byrow = TRUE),
                           c(1/3, 1/3, 1/3))
  cat(sprintf("  regime: %s (confidence: %.2f/10.00)\n",
              hmm_states[rp$value], rp$confidence))

  cat("\nGARCH(1,1) vol forecast:\n")
  gp <- garch_predict(returns, 24)
  cat(sprintf("  vol: %.6f [%.6f, %.6f]\n",
              gp$value, gp$lower_bound, gp$upper_bound))

  cat("\nMerton jump-diffusion (24h, 1000 paths):\n")
  set.seed(42)
  mp <- merton_paths(1800, 0.05, 0.60, 5.0, -0.02, 0.05, 1/(252*24), 24, 1000L)
  final <- mp[25, ]
  cat(sprintf("  median: %.2f [%.2f, %.2f]\n",
              median(final), quantile(final, 0.025), quantile(final, 0.975)))

  cat("\nAll models operational.\n")
}