---
title: "Choosing weights for likelihood smoothing"
output:
  rmarkdown::html_vignette:
    toc: true
    toc_depth: 2
    number_sections: true
bibliography: "../inst/REFERENCES.bib"
author: "Andreï V. Kostyrka, University of Luxembourg"
date: "Created: 2025-04-29, last modified: 2024-04-29, compiled: `r Sys.Date()`"
abstract: "This vignette demonstrates how the choice of SEL weights for smoothing the likelihood affects the final result."
keywords: "local likelihood, bandwidth selection, semi-parametric efficiency"
vignette: >
  %\VignetteIndexEntry{Choosing weights for empirical likelihood smoothing}
  %\VignetteEngine{knitr::rmarkdown}
  %\VignetteEncoding{UTF-8}
---

```{r, include = FALSE}
knitr::knit_hooks$set(pngquant = knitr::hook_pngquant)
knitr::opts_chunk$set(
  dev = "png",
  dev.args = list(type = if (Sys.info()["sysname"] == "Darwin") "quartz" else "cairo-png"),
  fig.width = 640 / 72,
  fig.height = 480 / 72,
  dpi = 72,
  fig.retina = 1,
  collapse = TRUE,
  comment = "#>",
  pngquant = "--speed=1 --quality=50-60"
)
```

```{r setup}
library(smoothemplik)
```



## Kernel methods

There are many approaches to choosing the smoothing weights for conditional empirical likelihood, and there is no consensus on the optimality of one or another weighting scheme.

Recall that in the SEL approach, the empirical likelihood of the data in the observed sample is maximised subject to the constraint $\mathbb{E}(\rho(Z, \theta) \mid X) = 0$. Assume for simplicity that the dimension of the moment function $\rho$ is 1. The optimisation problem is therefore finding the optimal discrete distribution that enforces a sample analogue of this conditional moment restriction for any parameter $\theta$:
\[
\max_{0 < p_{ij} < 1} \sum_{i=1}^n \sum_{j=1}^n w_{ij} \log p_{ij},
\]
where $\sum_j p_{ij} = 1$ for $i=1,\ldots,n$ and $\sum_j p_{ij}\rho(Z_j, \theta) = 0$ for $i=1,\ldots,n$.

The solution to this problem has a closed form:
\[
\hat p_{ij} = \frac{w_{ij}}{1 + \hat\lambda_i (\theta) \rho(Z_j, \theta)},
\]
where the Lagrange multipliers $\hat\lambda_i$ are the solution to the equality $\sum_{j=1}^n \frac{w_{ij} \rho(Z_j, \theta)}{1 + \lambda_i(\theta) \rho(Z_j, \theta)} = 0$ (the first-order condition for maximising the weighted empirical likelihood), found numerically.

Typically, $w_{ij}$ are kernel weights. They can be obtained in a plethora of approaches:

1. Directly apply popular kernels to the conditioning variables $X$;
2. Transform $X$ coordinate-wise via any probability-integral-like transformation (empirical CDF, Gaussian CDF etc.) to map them into the $[0, 1]^{\dim X}$ hyper-cubel;
3. For each $X$, find its $k$ nearest neighbours, rank them by proximity, and apply the kernel function to the ranks of the nearest  observations.
4. Choose the adaptive nearest-neighbour bandwidth $b_n(X_i) = b_i$ such that there be exactly $k$ nearest neighbours in the vicinity defined by the kernel, without any rank transformation.

Theoretically, approaches (3) and (4) should work the best because it ensures that there are enough observations for smoothing, and that there is neither over- or under-smoothing. The latter two phenomena are a problem:

* If the SEL bandwidth is too large, then, identification is lost because the conditional moment restriction becomes an unconditional one (‘the average residual is zero’), and the model parameters cannot be estimated.
* If SEL bandwidth is too narrow, then, there is not enough smoothing of the likelihood; since the log-empirical-likelihood ratio is unbounded from below, the values of the SELR statistic can become arbitrarily small. In addition, too small a bandwidth limits the parameter space severely because for the SELR statistic to be finite, there must be at least one pair of opposite-sign residuals. This is known as the spanning condition, which means that the convex hull of the data must contain the zero,.

Consider kernel weights of the form
\[
w_{ij} := k\left( \frac{X_i - X_j}{b} \right),
\]
where $k$ is a kernel function that is zero outside $[-1, 1]$, integrates to one, and is symmetric and non-negative within that interval. The most popular kernel functions are uniform, triangular (Bartlett), quadratic (Epanechnikov), quartic, and Gaussian.

### Fixed bandwidth

Using a fixed bandwidth for SEL smoothing is the simplest choice, yet it can be sub-optimal for many reasons. 
In the regions where the observations are dense, the empirical likelihood may be over-smoothed, whereas in low-density regions, it may be undersmoothed, creating problems for the spanning condition.

The obvious ‘crutch’ to fix the spanning condition failure is the use of some sort of extrapolation of the SELR function outside the convex hull.
The present package offers three options for the `EL()` function: `chull.fail = "taylor"` that extrapolates its branches quadratically following a Taylor expansion after a cut-off point, or `chull.fail = "wald"` that replaces the SELR function halfway between the outermost observations with a smooth transition to a Wald approximation, or `chull.fail = "none"` for returning `-Inf`. This option is experimental; envisioned are such options as 2nd- or 4th-order log-approximation. Adjusted EL (AEL) and Balanced AEL (BAEL) can be invoked with `chull.fail = "adjusted"` (@chen2008adjusted), `chull.fail = "adjusted2"` (@liu2010adjusted improvement), and `chull.fail = "balanced"` (@emerson2009calibration).

```{r}
x  <- c(-3, -2, 2, 3, 4)
ct <- c(10, 4:1)
grid.full <- c(seq(-3.5, 5.5, length.out = 201))
grid.keep <- grid.full <= -2.5 | grid.full >= 3.5
selr0 <- sapply(grid.full, function(m) -2*EL0(x, m, ct)$logelr)
selr1 <- -2*ExEL1(x, mu = grid.full, ct = ct, exel.control = list(xlim = c(-2.5, 3.5)))
selr2 <- -2*ExEL2(x, mu = grid.full, ct = ct, exel.control = list(xlim = c(-2.5, 3.5)))
plot(grid.full, selr0, ylim = c(0, 120), xlim = c(-3.5, 4.5), bty = "n",
     main = "-2 * weighted log-EL", ylab = "", type = "l")
points(grid.full[grid.keep], selr1[grid.keep], col = 4, pch = 0, cex = 0.75)
points(grid.full[grid.keep], selr2[grid.keep], col = 2, pch = 2, cex = 0.75)
rug(x, lwd = 2)
abline(v = c(-2.5, 3.5), lty = 3)
legend("top", c("Taylor", "Wald"), title = "Extrapolation type", col = c(4, 2),
       pch = c(0, 2), bty = "n")
```

These extrapolations may certainly remedy the predicament of having negative infinity for the log-ELR statistic, which does not get accepted by most numerical optimisers -- but they should not be relied upon.
It is normal to have ‘bad’ values for ‘bad’ guesses during the optimisation process, but at the initial value and at the optimum, the spanning condition should hold.

### Rank weights


### Nearest-neigbour weights

This bandwidth is also known as the ‘baloon’ / sample-point adaptive bandwidth.
Define a function that chooses such a bandwidth that there be `ceiling(d/n)` nearest neighbours for each observation, where `d` is the span in `(0, 1)`. It is assumed that the kernel in question has bounded support and is zero outside $[-1, 1]$. This version works for multiple dimensions as well.

```{r}
pickMinBW <- function(X, d = 2 / sqrt(NROW(X)), tol = 1e-12) {
  X <- as.matrix(X)
  n <- nrow(X)
  p <- ncol(X)
  k <- ceiling(d * n)
  k <- max(1, min(k, n - 1))

  # has.ms <- requireNamespace("matrixStats", quietly = TRUE)
  b <- sapply(seq_len(n), function(i) {
    # L_inf distances from X_i
    A  <- abs(sweep(X, 2, X[i, ], "-", check.margin = FALSE))
    # Di <- if (has.ms) matrixStats::rowMaxs(A) else do.call(pmax, as.data.frame(A))
    Di <- do.call(pmax, as.data.frame(A))
    Di[i] <- Inf  # Exclude self
    if (k < n - 1) {
      return(sort(Di, partial = k + 1)[k + 1])
    } else {
      return(sort(Di, partial = n - 1)[n - 1])
    }
  })
  b * (1 - tol)
}
```

## Simulation in 1 dimension

```{r}
n <- 50
set.seed(1)
X <- sort(rchisq(n, df = 3))
Y <- 1 + X + (rchisq(n, df = 3) - 3) * (1 + X)
mod0 <- lm(Y ~ X)
vhat0 <- kernelSmooth(X, mod0$residuals^2, bw = max(diff(X))*1.2, kernel = "epanechnikov")
mod1 <- lm(Y ~ X, weights = 1 / vhat0)
plot(X, Y, bty = "n")
abline(c(1, 1), lty = 2)
abline(mod0, col = 1); abline(mod1, col = 2)
cbind(OLS = mod0$coefficients, WOLS = mod1$coefficients)
```

These values are relatively far away from the truth.

Define four smoothing matrices:
```{r}
bw0 <- bw.CV(X, kernel = "epanechnikov")
bw0 <- max(bw0, max(diff(X))*1.1)
wF <- kernelWeights(X, bw = bw0, kernel = "epanechnikov")

# Assuming Gaussian CDF, which is not true
Xs <- scale(X)
XP <- pnorm(Xs)
wP <- kernelWeights(XP, bw = bw.CV(XP), kernel = "epanechnikov")
rowMeans(wP > 0) - 1/n

bw.adapt <- pickMinBW(X, d = 0.16)
plot(X, bw.adapt, bty = "n", main = "Adaptive bandwidth ensuring 15% non-zero weights",
     ylim = c(0, max(bw.adapt)))
wA <- kernelWeights(X, bw = bw.adapt, kernel = "epanechnikov")
rowMeans(wA > 0) - 1/n

rX <- rank(X)
wNN <- kernelWeights(rX/max(rX), bw = 0.09, kernel = "epanechnikov")
rowMeans(wNN > 0) - 1/n
```



```{r}
g  <- function(theta, ...) Y - theta[1] - theta[2]*X

wF <- wF / rowSums(wF)
wP <- wP / rowSums(wP)
wNN <- wNN / rowSums(wNN)
wA <- wA / rowSums(wA)

g1 <- function(theta) smoothEmplik(rho = g, theta = theta, data = NULL, sel.weights = wF, minus = TRUE, type = "EuL")
g2 <- function(theta) smoothEmplik(rho = g, theta = theta, data = NULL, sel.weights = wP, minus = TRUE, type = "EuL")
g3 <- function(theta) smoothEmplik(rho = g, theta = theta, data = NULL, sel.weights = wNN, minus = TRUE, type = "EuL")
g4 <- function(theta) smoothEmplik(rho = g, theta = theta, data = NULL, sel.weights = wA, minus = TRUE, type = "EuL")
  
th1  <- optim(mod1$coefficients, g1, method = "BFGS", control = list(ndeps = rep(1e-5, 2), reltol = 1e-5))
th2  <- optim(mod1$coefficients, g2, method = "BFGS", control = list(ndeps = rep(1e-5, 2), reltol = 1e-5))
th3  <- optim(mod1$coefficients, g3, method = "BFGS", control = list(ndeps = rep(1e-5, 2), reltol = 1e-5))
th4  <- optim(mod1$coefficients, g4, method = "BFGS", control = list(ndeps = rep(1e-5, 2), reltol = 1e-5))

cbind(WOLS = mod1$coefficients, Fixed = th1$par, PIT = th2$par, NNeighb = th3$par, Adapt = th4$par)
```


## Simulation in 3 dimensions

```{r}
n <- 200
set.seed(1)
X <- matrix(rchisq(n*3, df = 3), ncol = 3)
Y <- 1 + rowSums(X) + (rchisq(n, df = 3) - 3) * (1 + rowSums(X))
mod0 <- lm(Y ~ X)
vhat0 <- kernelSmooth(X, mod0$residuals^2, PIT = TRUE, bw = 0.2,
                      kernel = "epanechnikov", no.dedup = TRUE)
mod1 <- lm(Y ~ X, weights = 1 / vhat0)
cbind(OLS = mod0$coefficients, WOLS = mod1$coefficients)
```

These values are also far away from the truth.

Construct the same four smoothing matrices:
```{r}
bw0 <- 1
atleast2 <- FALSE
while(!atleast2) {
 wF <- kernelWeights(X, bw = bw0, kernel = "epanechnikov")
 bw0 <- bw0 * 1.1
 atleast2 <- min(rowSums(wF > 0)) > 1
}
rowMeans(wF > 0) - 1/n
min(rowSums(wF > 0))

Xs <- scale(X)
XP <- apply(Xs, 2, pnorm)
wP <- kernelWeights(XP, bw = bw.rot(XP)*2, kernel = "epanechnikov")
rowMeans(wP > 0) - 1/n
min(rowSums(wP > 0))

bw.adapt <- pickMinBW(X, d = 0.16)
plot(rowMeans(X), bw.adapt, bty = "n", main = "Adaptive bandwidth ensuring 15% non-zero weights",
     ylim = c(0, max(bw.adapt)))
wA <- kernelWeights(X, bw = bw.adapt, kernel = "epanechnikov")
rowMeans(wA > 0) - 1/n
min(rowSums(wA > 0))
```



```{r}
g  <- function(theta, ...) Y - drop(cbind(1, X) %*% theta)

wF <- wF / rowSums(wF)
wP <- wP / rowSums(wP)
wA <- wA / rowSums(wA)

g1 <- function(theta) smoothEmplik(rho = g, theta = theta, data = NULL, sel.weights = wF,
                                   minus = TRUE, type = "EuL")
g2 <- function(theta) smoothEmplik(rho = g, theta = theta, data = NULL, sel.weights = wP,
                                   minus = TRUE, type = "EuL")
g4 <- function(theta) smoothEmplik(rho = g, theta = theta, data = NULL, sel.weights = wA,
                                   minus = TRUE, type = "EuL")
```

To save speed (30 seconds), we do not run the following fragment; the results are provided below.
```{r}
# th1  <- optim(mod1$coefficients, g1, method = "BFGS", control = list(ndeps = rep(1e-5, 4)))
# th2  <- optim(mod1$coefficients, g2, method = "BFGS", control = list(ndeps = rep(1e-5, 4)))
# th4  <- optim(mod1$coefficients, g4, method = "BFGS", control = list(ndeps = rep(1e-5, 4)))

# round(cbind(True = rep(1, 4), WOLS = mod1$coefficients, Fixed = th1$par, PIT = th2$par, Adapt = th4$par), 3)
#             True  WOLS Fixed    PIT Adapt
# (Intercept)    1 0.166 2.755  3.668 0.110
# X1             1 0.059 0.132  0.241 0.790
# X2             1 0.991 1.036  0.694 0.929
# X3             1 0.752 0.625 -0.161 0.863
```


## Conclusion

This simulation emphasises the importance of careful bandwidth choice in efficient estimation via smoothing the empirical or Euclidean likelihood.
Nearest-neighbour methods work well, whereas adaptive-bandwidth methods are comparable to them, but also possess lucrative theoretical proofs such as integrability.

## References

<div id="refs"></div>
