Information loss

Question

Let's imagine we have some binary random variable $Y$ and some other continuous variable $X\in\mathbb{R}$ and we have some sample of size $n$.

Suppose we want to determine the relationship between $Y$ and $X$ in some sense. Given that $Y$ is binary, we first round all values of $X$ in some neighbourhood to a single value. This gives us $\bar{X}$. For example, $\{2.2,2.7,2.9,3.8\}$ would become $\{2.0,2.5,2.5,3.5\}$ if we chose to round down to the nearest half integer. Then for each distinct $\bar{X}$ we could define the $\bar{Y}$, the average $Y$ in that neighbourhood. We could then use, for example, a spline to flexibly model the relationship between $\bar{Y}$ and $\bar{X}$.

Is there some reasonable way to measure the information loss of the approximate relationship compared to the original relationship? I would assume the information lost would be at least a function of the extent of the aggregation.

I was thinking an approach would be to evaluate upper and lower bounds of the entropy i.e. the entropy with no rounding (lower bound) and with everything rounded to a single value (upper bound). Then, for a given choice of rounding, one could check where the entropy sits in that range.

Answer 1

I agree that your approach of bounding the entropy would work. See the this page on Information Gain

However, I don't agree that this is a good method of finding the "relationship between X and Y". For that question, I recommend a logistic regression. You can also get an idea of the information gained in the regression by looking at AIC. It is a different, although related measure of the information gained in a model.

R code is below.

# simulate data
set.seed(1976)
x <- rnorm(100, 3, 1)
logitp <- -5 + 2*x + rnorm(100, 0, 0.2)
p <- plogis(logitp)
y <- rbinom(100, size = 1, p)

plot(x, p, col = "blue")
points(x, y, col = "red")

# group the data
xgroup <- cut(x, breaks = 0:6)
ygroup <- c(by(y, xgroup, mean))
xgroup_centers <- seq(0.5, 5.5, by = 1)

plot(xgroup_centers, ygroup)

# parent entropy
p <- table(y)/length(y)
Hp <- -sum(p*log2(p))

# binned entropy
entropy <- function(x, breaks, y)
{
  xgroup <- cut(x, breaks = breaks)
  sum(apply(table(xgroup, y) / rowSums(table(xgroup, y)), 1, function(z) -sum(z*log2(z), na.rm=TRUE)) * table(xgroup)/length(xgroup))
}

# information gained
Hp - entropy(x, seq(0, 6, length = 3), y)
Hp - entropy(x, seq(0, 6, length = 5), y)
Hp - entropy(x, seq(0, 6, length = 10), y)
Hp - entropy(x, seq(0, 6, length = 20), y)

# fit logistic regression to raw data
glm0 <- glm(y ~ 1, data = data.frame(y=y, x=x), family = binomial(link="logit"))
# AIc 124.2
summary(glm0)

glm1 <- glm(y ~ x, data = data.frame(y=y, x=x), family = binomial(link="logit"))
# AIC 74.5
summary(glm1)

```