Continuous Hinge Function

alt_smoothers.R

tanh_hinge <- function(x, x0, a, b0, b1, delta) {
  xdiff <- x - x0
  return(a + b0 * xdiff + (b1 - b0) * delta * (xdiff + delta * log(2 * cosh(xdiff/delta)) / 2))
}

erf_hinge <- function(x, x0, a, b0, b1, delta) {
  xdiff <- x - x0
  # Use pnorm to approximate erf
  transition <- 0.5 * (1 + 2 * pnorm(xdiff/(delta * sqrt(2))) - 1)
  return(a + b0 * xdiff + (b1 - b0) * delta * transition * xdiff)
}

smoothstep_hinge <- function(x, x0, a, b0, b1, delta) {
  xdiff <- x - x0
  t <- pmin(pmax(0.5 * (xdiff/delta + 1), 0), 1)
  # Hermite polynomial interpolation for smoothstep
  transition <- t * t * (3 - 2 * t)
  return(a + (b0 * (1 - transition) + b1 * transition) * xdiff)
}

nurbs_hinge <- function(x, x0, a, b0, b1, delta) {
  xdiff <- x - x0
  r <- xdiff/delta
  t <- 0.5 * (1 + r/sqrt(1 + r^2))
  return(a + b0 * xdiff + (b1 - b0) * xdiff * t)
}

quad_spline_hinge <- function(x, x0, a, b0, b1, delta) {
  xdiff <- x - x0
  
  # Create a transition function with compact support
  t <- pmin(pmax(xdiff/delta + 0.5, 0), 1)
  # Create a C₁ continuous curve
  mask <- (t > 0) & (t < 1)
  transition <- ifelse(mask, t^2 * (3 - 2*t), ifelse(t <= 0, 0, 1))
  
  return(a + b0 * xdiff + (b1 - b0) * xdiff * transition)
}

comp_smoother.png

comp_smoother.R

library(ggplot2)
library(reshape2)

compare_hinges <- function(x0 = 0, a = 0, b0 = -0.5, b1 = 0.5, delta = 1, xlim = c(-5, 5)) {
  x_seq <- seq(xlim[1], xlim[2], length.out = 500)
  
  # Calculate values for each hinge type
  y_logistic <- logistic_hinge(x_seq, x0, a, b0, b1, delta)
  y_tanh <- tanh_hinge(x_seq, x0, a, b0, b1, delta)
  y_erf <- erf_hinge(x_seq, x0, a, b0, b1, delta)
  y_smoothstep <- smoothstep_hinge(x_seq, x0, a, b0, b1, delta)
  y_nurbs <- nurbs_hinge(x_seq, x0, a, b0, b1, delta)
  
  # Create asymptotic lines
  y_left <- a + b0 * (x_seq - x0)
  y_right <- a + b1 * (x_seq - x0)
  
  # Create data frame
  df <- data.frame(
    x = rep(x_seq, 7),
    y = c(y_logistic, y_tanh, y_erf, y_smoothstep, y_nurbs, y_left, y_right),
    type = factor(rep(c("Logistic", "Tanh", "Error function", "Smoothstep", 
                        "NURBS-inspired", "Left asymptote", "Right asymptote"), 
                      each = length(x_seq)))
  )
  
  # Plot
  ggplot(df, aes(x = x, y = y, color = type, linetype = type)) +
    geom_line(linewidth = 1) +
    scale_color_manual(values = c("red", "blue", "green", "purple", "orange", "gray", "gray")) +
    scale_linetype_manual(values = c(rep("solid", 5), rep("dashed", 2))) +
    geom_point(data = data.frame(x = x0, y = a), 
              aes(x = x, y = y), color = "black", size = 3, inherit.aes = FALSE) +
    labs(title = "Comparison of Smooth Hinge Functions",
         subtitle = paste0("Parameters: x0=", x0, ", a=", a, 
                          ", b0=", b0, ", b1=", b1, ", delta=", delta),
         x = "x", y = "y") +
    theme_minimal() +
    theme(legend.title = element_blank())
}

Continuous Hinger.md

To go with Andrew's https://statmodeling.stat.columbia.edu/2017/05/19/continuous-hinge-function-bayesian-modeling/

Also includes alternate smoothers outside of logistic.

Used Claude (but verified).

continuous_hinge.R

#' Logistic Hinge Function
#'
#' A smooth function connecting two linear segments with controlled transition
#'
#' @param x Numeric vector of input values
#' @param x0 The x-coordinate of the hinge point
#' @param a The y-coordinate of the hinge point
#' @param b0 The slope of the first linear segment (for x < x0)
#' @param b1 The slope of the second linear segment (for x > x0)
#' @param delta The smoothness parameter controlling the transition width
#'
#' @return Numeric vector of output values
#' @export
#'
#' @examples
#' curve(logistic_hinge(x, 0, 0, -0.5, 0.5, 1), from = -5, to = 5)
logistic_hinge <- function(x, x0, a, b0, b1, delta) {
  # Vectorized implementation with numerical stability
  xdiff <- x - x0
  
  # Use log1p_exp for numerical stability
  log1p_exp <- function(z) {
    # For large z, exp(z) + 1 ≈ exp(z)
    # For small z, direct calculation is fine
    ifelse(z > 18, z, log1p(exp(z)))
  }
  
  return(a + b0 * xdiff + (b1 - b0) * delta * log1p_exp(xdiff / delta))
}

#' Plot Logistic Hinge Function
#'
#' Creates a comparison plot of the logistic hinge against its asymptotic lines
#'
#' @param x0 The x-coordinate of the hinge point
#' @param a The y-coordinate of the hinge point
#' @param b0 The slope of the first linear segment
#' @param b1 The slope of the second linear segment
#' @param delta The smoothness parameter
#' @param xlim The x-axis limits for the plot
#' @param title Optional plot title
#'
#' @return A ggplot object
#' @export
#'
#' @import ggplot2
plot_logistic_hinge <- function(x0 = 0, a = 0, b0 = -0.5, b1 = 0.5, 
                               delta = 1, xlim = c(-5, 5), 
                               title = "Logistic Hinge Function") {
  require(ggplot2)
  
  # Create sequence of x values
  x_seq <- seq(xlim[1], xlim[2], length.out = 500)
  
  # Calculate hinge function values
  y_hinge <- logistic_hinge(x_seq, x0, a, b0, b1, delta)
  
  # Calculate asymptotic lines
  y_left <- a + b0 * (x_seq - x0)
  y_right <- a + b1 * (x_seq - x0)
  
  # Create data frame for plotting
  plot_data <- data.frame(
    x = rep(x_seq, 3),
    y = c(y_hinge, y_left, y_right),
    curve_type = factor(rep(c("Smooth Hinge", "Left Asymptote", "Right Asymptote"), 
                           each = length(x_seq)))
  )
  
  # Create plot
  p <- ggplot(plot_data, aes(x = x, y = y, color = curve_type, linetype = curve_type)) +
    geom_line(linewidth = 1) +  # Changed from size to linewidth
    scale_color_manual(values = c("red", "blue", "blue")) +
    scale_linetype_manual(values = c("solid", "dashed", "dashed")) +
    geom_point(data = data.frame(x = x0, y = a), 
              aes(x = x, y = y), color = "black", size = 3, inherit.aes = FALSE) +
    labs(title = title,
         subtitle = paste0("Parameters: x0=", x0, ", a=", a, 
                          ", b0=", b0, ", b1=", b1, ", delta=", delta),
         x = "x", y = "y") +
    theme_minimal() +
    theme(legend.title = element_blank())
  
  return(p)
}

# Example usage
library(ggplot2)

# Basic example
plot_logistic_hinge()

# Multiple delta values to show the effect of smoothness
delta_comparison <- function() {
  p1 <- plot_logistic_hinge(delta = 0.1, title = "Sharp Transition (delta = 0.1)")
  p2 <- plot_logistic_hinge(delta = 1, title = "Moderate Transition (delta = 1)")
  p3 <- plot_logistic_hinge(delta = 3, title = "Smooth Transition (delta = 3)")
  
  # Combine plots using gridExtra
  require(gridExtra)
  grid.arrange(p1, p2, p3, ncol = 1)
}

delta_comparison()

# Real-world example: Modeling hockey stick growth pattern
hockey_stick_growth <- function() {
  # Simulate data with hockey stick pattern (slow then fast growth)
  set.seed(123)
  x <- seq(1, 100, by = 1)
  true_y <- logistic_hinge(x, x0 = 50, a = 30, b0 = 0.3, b1 = 1.2, delta = 5)
  y <- true_y + rnorm(length(x), mean = 0, sd = 3)
  
  # Create data frame
  df <- data.frame(x = x, y = y)
  
  # Fit the logistic hinge model
  fit_hinge <- function(params) {
    x0 <- params[1]
    a <- params[2]
    b0 <- params[3]
    b1 <- params[4]
    delta <- params[5]
    
    pred <- logistic_hinge(df$x, x0, a, b0, b1, delta)
    sum((df$y - pred)^2)  # Return sum of squared errors
  }
  
  # Optimization
  result <- optim(c(40, 25, 0.2, 1, 10), fit_hinge, 
                  method = "L-BFGS-B",
                  lower = c(1, 0, 0, 0, 0.1),
                  upper = c(100, 100, 5, 5, 20))
  
  # Extract parameters
  params <- result$par
  names(params) <- c("x0", "a", "b0", "b1", "delta")
  print(params)
  
  # Plot result
  ggplot(df, aes(x = x, y = y)) +
    geom_point(alpha = 0.5) +
    geom_line(aes(y = true_y), color = "blue", linetype = "dashed") +
    geom_line(aes(y = logistic_hinge(x, params[1], params[2], params[3], 
                                    params[4], params[5])),
              color = "red", size = 1) +
    labs(title = "Hockey Stick Growth Pattern",
         subtitle = "Fitting a logistic hinge function to data",
         x = "Time", y = "Value") +
    theme_minimal()
}

hockey_stick_growth()

# Example: Economic threshold modeling
economic_threshold <- function() {
  # Simulate data with an economic threshold effect
  # (e.g., effect of minimum wage on employment)
  set.seed(456)
  
  x <- seq(5, 25, by = 0.5)  # e.g., minimum wage level
  true_y <- logistic_hinge(x, x0 = 15, a = 10, b0 = 0.2, b1 = -0.5, delta = 1.5)
  y <- true_y + rnorm(length(x), mean = 0, sd = 0.5)
  
  df <- data.frame(x = x, y = y)
  
  # Plot
  ggplot(df, aes(x = x, y = y)) +
    geom_point() +
    geom_smooth(method = "lm", formula = y ~ x, se = FALSE, 
                color = "green", linetype = "dotted") +
    geom_line(aes(y = true_y), color = "blue", linetype = "dashed") +
    geom_vline(xintercept = 15, linetype = "dashed", color = "gray") +
    labs(title = "Economic Threshold Effect",
         subtitle = "Note how a linear model (dotted green) would miss the effect",
         x = "Policy Level", y = "Outcome") +
    theme_minimal()
}

economic_threshold()

hinge.png