Tratar con la regresión de la variable de respuesta inusualmente limitada

Estoy intentando modelar una variable de respuesta que está teóricamente limitada entre -225 y +225. La variable es la puntuación total que obtuvieron los sujetos al jugar un juego. Aunque en teoría es posible que los sujetos obtengan un puntaje de +225. A pesar de esto porque el puntaje no solo dependía de las acciones de los sujetos, sino también de las acciones de otras acciones, el puntaje máximo de cualquiera fue 125 (este es el máximo de 2 jugadores que juegan entre sí), esto sucedió con una frecuencia muy alta. La puntuación más baja fue de +35.

Este límite de 125 está causando dificultad con una regresión lineal. Lo único que se me ocurre hacer es volver a escalar la respuesta para que esté entre 0 y 1 y usar una regresión beta. Si hago esto, aunque no estoy seguro, realmente puedo justificar decir que 125 es el límite superior (o 1 después de la transformación) ya que es posible obtener un puntaje de +225. Además, si hiciera esto, ¿cuál sería mi límite inferior, 35?

Gracias,

Jonathan

Aunque no estoy completamente seguro de cuál es su problema con la regresión lineal, en este momento estoy terminando un artículo sobre cómo analizar los resultados limitados. Como no estoy familiarizado con la regresión Beta, tal vez alguien más responda esa opción.

Por su pregunta, entiendo que obtiene predicciones fuera de los límites. En este caso, optaría por la regresión logística de cuantiles . La regresión cuantil es una alternativa muy clara a la regresión lineal regular. Puede mirar diferentes cuantiles y obtener una imagen mucho mejor de sus datos que lo que es posible con una regresión lineal regular. Tampoco tiene suposiciones con respecto a la distribución ¹ .

La transformación de una variable a menudo puede causar efectos divertidos en la regresión lineal, por ejemplo, usted tiene un significado en la transformación logística pero eso no se traduce en el valor regular. Este no es el caso con los cuantiles, la mediana siempre es la mediana, independientemente de la función de transformación. Esto le permite transformarse de un lado a otro sin distorsionar nada. El profesor Bottai sugirió este enfoque para los resultados limitados ² , es un método excelente si desea hacer predicciones individuales, pero tiene algunos problemas cuando no quiere ver las versiones beta e interpretarlas de una manera no logística. La fórmula es simple:

$logit(y) = log(\frac{y + \epsilon}{max(y) - y + \epsilon})$

Donde es su puntaje y es un número pequeño arbitrario .$y$$\epsilon$

Aquí hay un ejemplo que hice hace un tiempo cuando quería experimentar con él en R:

library(rms)
library(lattice)
library(cairoDevice)
library(ggplot2)

# Simulate some data
set.seed(10)
intercept <- 0
beta1 <- 0.5
beta2 <- 1
n = 1000
xtest <- rnorm(n,1,1)
gender <- factor(rbinom(n, 1, .4), labels=c("Male", "Female"))
random_noise  <- runif(n, -1,1)

# Add a ceiling and a floor to simulate a bound score
fake_ceiling <- 4
fake_floor <- -1

# Simulate the predictor
linpred <- intercept + beta1*xtest^3 + beta2*(gender == "Female") + random_noise

# Remove some extremes
extreme_roof <- fake_ceiling + abs(diff(range(linpred)))/2
extreme_floor <- fake_floor - abs(diff(range(linpred)))/2
linpred[ linpred > extreme_roof|
    linpred < extreme_floor ] <- NA

#limit the interval and give a ceiling and a floor effect similar to scores
linpred[linpred > fake_ceiling] <- fake_ceiling
linpred[linpred < fake_floor] <- fake_floor

# Just to give the graphs the same look
my_ylim <- c(fake_floor - abs(fake_floor)*.25, 
             fake_ceiling + abs(fake_ceiling)*.25)
my_xlim <- c(-1.5, 3.5)

# Plot
df <- data.frame(Outcome = linpred, xtest, gender)
ggplot(df, aes(xtest, Outcome, colour = gender)) + geom_point()

Esto proporciona la siguiente dispersión de datos, ya que puede ver que está claramente limitada e inconveniente :

###################################
# Calculate & plot the true lines #
###################################
x <- seq(min(xtest), max(xtest), by=.1)
y <- beta1*x^3+intercept
y_female <- y + beta2
y[y > fake_ceiling] <- fake_ceiling
y[y < fake_floor] <- fake_floor
y_female[y_female > fake_ceiling] <- fake_ceiling
y_female[y_female < fake_floor] <- fake_floor

tr_df <- data.frame(x=x, y=y, y_female=y_female)
true_line_plot <- xyplot(y  + y_female ~ x, 
                         data=tr_df,
                         type="l", 
                         xlim=my_xlim, 
                         ylim=my_ylim, 
                         ylab="Outcome", 
                         auto.key = list(
                           text = c("Male"," Female"),
                           columns=2))

##########################
# Test regression models #
##########################

# Regular linear regression
fit_lm <- Glm(linpred~rcs(xtest, 5)+gender, x=T, y=T)
boot_fit_lm <- bootcov(fit_lm, B=500)
p <- Predict(boot_fit_lm, xtest=seq(-2.5, 3.5, by=.001), gender=c("Male", "Female"))
lm_plot <- plot(p, 
             se=T, 
             col.fill=c("#9999FF", "#BBBBFF"), 
             xlim=my_xlim, ylim=my_ylim)

Esto da como resultado la siguiente imagen donde las hembras están claramente por encima del límite superior:

# Quantile regression - regular
fit_rq <- Rq(formula(fit_lm), x=T, y=T)
boot_rq <- bootcov(fit_rq, B=500)
# A little disturbing warning:
# In rq.fit.br(x, y, tau = tau, ...) : Solution may be nonunique

p <- Predict(boot_rq, xtest=seq(-2.5, 3.5, by=.001), gender=c("Male", "Female"))
rq_plot <- plot(p, 
             se=T, 
             col.fill=c("#9999FF", "#BBBBFF"), 
             xlim=my_xlim, ylim=my_ylim)

Esto da la siguiente trama con problemas similares:

# The logit transformations
logit_fn <- function(y, y_min, y_max, epsilon)
    log((y-(y_min-epsilon))/(y_max+epsilon-y))


antilogit_fn <- function(antiy, y_min, y_max, epsilon)
    (exp(antiy)*(y_max+epsilon)+y_min-epsilon)/
        (1+exp(antiy))

epsilon <- .0001
y_min <- min(linpred, na.rm=T)
y_max <- max(linpred, na.rm=T)

logit_linpred <- logit_fn(linpred, 
                            y_min=y_min,
                            y_max=y_max,
                            epsilon=epsilon)

fit_rq_logit <- update(fit_rq, logit_linpred ~ .)
boot_rq_logit <- bootcov(fit_rq_logit, B=500)

p <- Predict(boot_rq_logit, 
             xtest=seq(-2.5, 3.5, by=.001), 
             gender=c("Male", "Female"))

# Change back to org. scale
# otherwise the plot will be
# on the logit scale
transformed_p <- p
transformed_p$yhat <- antilogit_fn(p$yhat,
                                    y_min=y_min,
                                    y_max=y_max,
                                    epsilon=epsilon)
transformed_p$lower <- antilogit_fn(p$lower, 
                                     y_min=y_min,
                                     y_max=y_max,
                                     epsilon=epsilon)
transformed_p$upper <- antilogit_fn(p$upper, 
                                     y_min=y_min,
                                     y_max=y_max,
                                     epsilon=epsilon)

logit_rq_plot <- plot(transformed_p, 
             se=T, 
             col.fill=c("#9999FF", "#BBBBFF"), 
             xlim=my_xlim)

La regresión logística del cuantil que tiene una predicción acotada muy buena:

Aquí puede ver el problema con las Beta que, en la forma retransformada, difieren en diferentes regiones (como se esperaba):

# Some issues trying to display the gender factor
contrast(boot_rq_logit, list(gender=levels(gender), 
                             xtest=c(-1:1)), 
         FUN=function(x)antilogit_fn(x, epsilon))

   gender xtest Contrast   S.E.       Lower      Upper       Z      Pr(>|z|)
   Male   -1    -2.5001505 0.33677523 -3.1602179 -1.84008320  -7.42 0.0000  
   Female -1    -1.3020162 0.29623080 -1.8826179 -0.72141450  -4.40 0.0000  
   Male    0    -1.3384751 0.09748767 -1.5295474 -1.14740279 -13.73 0.0000  
*  Female  0    -0.1403408 0.09887240 -0.3341271  0.05344555  -1.42 0.1558  
   Male    1    -1.3308691 0.10810012 -1.5427414 -1.11899674 -12.31 0.0000  
*  Female  1    -0.1327348 0.07605115 -0.2817923  0.01632277  -1.75 0.0809  

Redundant contrasts are denoted by *

Confidence intervals are 0.95 individual intervals

Referencias

1. R. Koenker y G. Bassett Jr, "Cuantiles de regresión", Econometrica: revista de la Econometric Society, pp. 33-50, 1978.
2. M. Bottai, B. Cai y RE McKeown, "Regresión cuantil logística para resultados acotados", Estadísticas en medicina, vol. 29, no. 2, págs. 309–317, 2010.

Para los curiosos, las parcelas se crearon con este código:

# Just for making pretty graphs with the comparison plot
compareplot <- function(regr_plot, regr_title, true_plot){
  print(regr_plot, position=c(0,0.5,1,1), more=T)
  trellis.focus("toplevel")
  panel.text(0.3, .8, regr_title, cex = 1.2, font = 2)
  trellis.unfocus()
  print(true_plot, position=c(0,0,1,.5), more=F)
  trellis.focus("toplevel")
  panel.text(0.3, .65, "True line", cex = 1.2, font = 2)
  trellis.unfocus()
}

Cairo_png("Comp_plot_lm.png", width=10, height=14, pointsize=12)
compareplot(lm_plot, "Linear regression", true_line_plot)
dev.off()

Cairo_png("Comp_plot_rq.png", width=10, height=14, pointsize=12)
compareplot(rq_plot, "Quantile regression", true_line_plot)
dev.off()

Cairo_png("Comp_plot_logit_rq.png", width=10, height=14, pointsize=12)
compareplot(logit_rq_plot, "Logit - Quantile regression", true_line_plot)
dev.off()

Cairo_png("Scat. plot.png")
qplot(y=linpred, x=xtest, col=gender, ylab="Outcome")
dev.off()