Tarea 1: modelo de regresión lineal simple

Instrucciones:

Realizar un html en R con el título de ejercicios de análisis de regresión lineal simple, en cada ejercicio, además de lo que se solicita, integrar los siguientes puntos a revisar en el proceso de análisis de regresión lineal simple:

  1. Estimación del modelo de regresión
  2. Summary e Interpretación del modelo estimado
  3. Coeficiente de determinación
  4. Predicción (Estimación) de la variable de respuesta para nuevos valores de la variable independiente.
  5. Intervalos de confianza para los valores esperados
  6. Intervalos de confianza para las predicciones
  7. Propiedades de los residuales
  8. Verificación de supuestos
  1. Validación grafica
  2. Análisis de puntos atípicos
  3. Validación con pruebas de hipótesis
  1. Anova del modelo
  2. Prueba de hipótesis para los parámetros

Problema 1

Las ejercitadoras elípticas se están convirtiendo en una de las máquinas de ejercicio más populares. Su movimiento de bajo impacto es suave y estable, lo que las vuelve la elección preferida por las personas con problemas en rodillas y tobillos. Sin embargo, elegir la ejercitadora adecuada puede resultar un proceso difícil. El precio y la calidad son factores importantes en cualquier decisión de compra. ¿Están asociados los precios altos con las ejercitadoras elípticas de alta calidad? Consumer Reports realizó amplias pruebas para desarrollar una clasificación general basada en facilidad de uso, ergonomía, construcción y rango de ejercicio. A continuación, se muestran los datos de precio (Price) y calificación (Rating) de ocho ejercitadoras elípticas probadas, de las cuales se detallan marca y modelo (Brand and Model) (Consumer Reports,febrero de 2008).

  1. Trace un diagrama de dispersión con estos datos empleando el precio como variable independiente.
  2. Una tienda de equipo para ejercitarse que vende principalmente equipo caro puso un letrero sobre el área de exhibición que dice: “Calidad: usted obtiene lo que paga.” Con base en su análisis de los datos, ¿considera usted que el letrero refleja de manera justa la relación precio-calidad de las ejercitadoras elípticas?
  3. Utilice la ecuación de regresión estimada para predecir la clasificación de una ejercitadora elíptica con un precio de $1500.

A continuación se desarrolla un análisis completo de regresión lineal simple donde la variable independiente es el Price (precio en dólares) y la variable respuesta es Rating (calificación). El objetivo es evaluar si “usted obtiene lo que paga” y predecir la calificación para un precio dado.

Datos

ellipticals <- data.frame(
  Brand = c("Precor 5.31","Keys Fitness CG2","Octane Fitness Q37e","LifeFitness X1 Basic",
            "NordicTrack AudioStrider 990","Schwinn 430","Vision Fitness X6100","ProForm XP 520 Razor"),
  Price = c(3700,2500,2800,1900,1000,800,1700,600),
  Rating = c(87,84,82,74,73,69,68,55)
)

knitr::kable(ellipticals, caption = "Datos: Price y Rating")
Datos: Price y Rating
Brand Price Rating
Precor 5.31 3700 87
Keys Fitness CG2 2500 84
Octane Fitness Q37e 2800 82
LifeFitness X1 Basic 1900 74
NordicTrack AudioStrider 990 1000 73
Schwinn 430 800 69
Vision Fitness X6100 1700 68
ProForm XP 520 Razor 600 55

Diagrama de dispersión

library(ggplot2)
ggplot(ellipticals, aes(x = Price, y = Rating, label = Brand)) +
  geom_point(size = 3) +
  geom_smooth(method = "lm", se = TRUE) +
  geom_text(vjust = -1, size = 3) +
  labs(title = "Dispersión: Rating vs Price",
       x = "Price ($)",
       y = "Rating")
## `geom_smooth()` using formula = 'y ~ x'
## Warning: The following aesthetics were dropped during statistical transformation: label.
## ℹ This can happen when ggplot fails to infer the correct grouping structure in
##   the data.
## ℹ Did you forget to specify a `group` aesthetic or to convert a numerical
##   variable into a factor?

str(ellipticals)
## 'data.frame':    8 obs. of  3 variables:
##  $ Brand : chr  "Precor 5.31" "Keys Fitness CG2" "Octane Fitness Q37e" "LifeFitness X1 Basic" ...
##  $ Price : num  3700 2500 2800 1900 1000 800 1700 600
##  $ Rating: num  87 84 82 74 73 69 68 55
summary(ellipticals)
##     Brand               Price          Rating     
##  Length:8           Min.   : 600   Min.   :55.00  
##  Class :character   1st Qu.: 950   1st Qu.:68.75  
##  Mode  :character   Median :1800   Median :73.50  
##                     Mean   :1875   Mean   :74.00  
##                     3rd Qu.:2575   3rd Qu.:82.50  
##                     Max.   :3700   Max.   :87.00

1. Estimación del modelo de regresión

modelo <- lm(Rating ~ Price, data=ellipticals)
modelo
## 
## Call:
## lm(formula = Rating ~ Price, data = ellipticals)
## 
## Coefficients:
## (Intercept)        Price  
##   58.158492     0.008449

Interpretación: El modelo estimado es Rating = 58.158 + 0.00845*Price. Esto indica que por cada dólar adicional en el precio, se espera que el Rating aumente en aproximadamente 0.00845 puntos. El intercepto de 58.158 representa la calificación esperada cuando el precio es cero.“)

2. Summary e interpretación del modelo estimado

summary(modelo)
## 
## Call:
## lm(formula = Rating ~ Price, data = ellipticals)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -8.2278 -2.9447 -0.0132  4.2417  6.3927 
## 
## Coefficients:
##              Estimate Std. Error t value Pr(>|t|)    
## (Intercept) 58.158492   4.014418  14.487 6.78e-06 ***
## Price        0.008449   0.001885   4.482  0.00418 ** 
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 5.383 on 6 degrees of freedom
## Multiple R-squared:   0.77,  Adjusted R-squared:  0.7317 
## F-statistic: 20.09 on 1 and 6 DF,  p-value: 0.004184

Interpretación: El coeficiente de Price (\(\beta_{1} = 0.00845\)) es estadísticamente significativo \(p = 0.00418 < 0.05\), rechazando \(H_{0}: \beta_{1} = 0\). Existe evidencia de que el precio influye significativamente en la calificación. El modelo explica el 77% de la variabilidad en Rating \(R^2 = 0.77\)

3. Coeficiente de determinación (R²)

summary(modelo)$r.squared
## [1] 0.7700035
summary(modelo)$adj.r.squared
## [1] 0.7316707

Interpretación: El \(R^2\) de 0.77 indica que el 77% de la variabilidad en las calificaciones de las elípticas es explicada por su precio. El \(R^2\) ajustado de 0.7317 considera el número de predictores y sigue siendo alto, confirmando una buena capacidad explicativa del modelo.”

4. Predicción para nuevos valores

nuevo <- data.frame(Price = 1500)
predict(modelo, newdata=nuevo)
##       1 
## 70.8317

Interpretación: Para una elíptica de $1500, se predice una calificación de 70.83 puntos.

5. Intervalos de confianza para los valores esperados

predict(modelo, newdata=nuevo, interval="confidence")
##       fit     lwr      upr
## 1 70.8317 65.8637 75.79969

Interpretación: Con 95% de confianza, la calificación promedio para todas las elípticas de $1500 se encuentra entre 65.86 y 75.80 puntos.”

6. Intervalos de confianza para las predicciones individuales

predict(modelo, newdata=nuevo, interval="prediction")
##       fit      lwr      upr
## 1 70.8317 56.75361 84.90979

Interpretación: Para una elíptica específica de $1500, se espera con 95% de confianza que su calificación esté entre 56.75 y 84.91 puntos.

7. Propiedades de los residuales

head(modelo$residuals)
##          1          2          3          4          5          6 
## -2.4190681  4.7194972  0.1848559 -0.2112201  6.3927039  4.0824647
sum(modelo$residuals)
## [1] 3.552714e-15
mean(modelo$residuals)
## [1] 0

Interpretación: La suma de residuales \(3.55e-15 ≈ 0\) y media (0) confirman que cumplen con la propiedad fundamental de tener media cero, validando una condición del modelo de regresión.”

8. Verificación de supuestos

a) Validación gráfica

par(mfrow=c(2,2))
plot(modelo)

par(mfrow=c(1,1))

Interpretación: Los gráficos de diagnóstico confirman el cumplimiento de los supuestos del modelo no se observan patrones no lineales, los residuos se distribuyen normalmente y mantienen varianza constante.”

b) Análisis de puntos atípicos

library(car)
## Loading required package: carData
ooks_ellipticals <- cooks.distance(modelo)
outlierTest(modelo) 
## No Studentized residuals with Bonferroni p < 0.05
## Largest |rstudent|:
##    rstudent unadjusted p-value Bonferroni p
## 8 -2.607448           0.047817      0.38254
influenceIndexPlot(modelo) 

influencePlot(modelo) 

##      StudRes       Hat     CookD
## 1 -0.6234518 0.5334151 0.2473878
## 5  1.4669597 0.2188841 0.2529477
## 8 -2.6074481 0.3243409 0.8298305

Interpretación: No hay evidencia suficiente para considerar la observación 8 como valor atípico estadísticamente significativo después de ajustar por comparaciones múltiples

c) Validación con pruebas de hipótesis

Prueba de Shapiro.test

\(H_{0}: los\ residuales\ provienen\ de\ una\ distribución\ normal\) \(H_{1}: los\ residuales\ no\ provienen\ de\ una\ distribución\ normal\)

library(lmtest)
## Loading required package: zoo
## 
## Attaching package: 'zoo'
## The following objects are masked from 'package:base':
## 
##     as.Date, as.Date.numeric
shapiro.test(modelo$residuals)
## 
##  Shapiro-Wilk normality test
## 
## data:  modelo$residuals
## W = 0.96152, p-value = 0.8245

Interpretación: Shapiro-Wilk \(p = 0.8245 > 0.05\) no rechaza \(H_{0} : 0.9305 + 0.38,6*uservicios\) H₀: residuales normales. Breusch-Pagan (p = 0.05279 > 0.05) no rechaza H₀: homocedasticidad. Se cumplen los supuestos.”

Prueba de Homocedasticidad de Breusch-Pagan

\(H_{0}:la\ homocedastcidad\ de\ los\ residuales\ esta\ presente\)

\(H_{1}: la\ heterocerastidad\ de\ los\ residuales\ esta\ presente\)

bptest(modelo)
## 
##  studentized Breusch-Pagan test
## 
## data:  modelo
## BP = 3.7505, df = 1, p-value = 0.05279

Interpretación: Con un valor \(p=0.05279 > 0.05\) , no se rechaza la hipótesis nula \(H_{0}\) de homocedasticidad. No hay evidencia estadística suficiente para concluir que exista heterocedasticidad en los residuales del modelo \(BP = 3.7505, gl = 1\). Se asume que la varianza de los residuales es constante.

Prueba de Durbin-Watson

\(H_{0}: No\ hay\ correlación\)

\(H_{0}: Si\ hay\ correlación\)

dwtest(modelo)
## 
##  Durbin-Watson test
## 
## data:  modelo
## DW = 1.1985, p-value = 0.03471
## alternative hypothesis: true autocorrelation is greater than 0

Interpretación: El resultado de la prueba de Durbin-Watson \(DW = 1.1985, p = 0.03471 < 0.05\) indica que se rechaza la hipótesis nula. Existe evidencia estadística de autocorrelación positiva significativa en los residuales del modelo, lo que viola el supuesto de independencia.”

9. ANOVA del modelo

\(H_{0}: \beta_{1} = 0\) \(H_{1}: \beta_{1} \neq 0\)

anova(modelo)
## Analysis of Variance Table
## 
## Response: Rating
##           Df Sum Sq Mean Sq F value   Pr(>F)   
## Price      1 582.12  582.12  20.087 0.004184 **
## Residuals  6 173.88   28.98                    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Interpretación: ANOVA muestra que el modelo es significativo globalmente \(F = 20.087, p = 0.004184 < 0.05\), rechazando \(H_{0}\). El precio explica significativamente la variabilidad en Rating.

10. Prueba de hipótesis para los parámetros

\(H_{0}: \beta_{0} = 0\) \(H_{1}: \beta_{0} \neq 0\)

coef(summary(modelo))
##                 Estimate  Std. Error   t value     Pr(>|t|)
## (Intercept) 58.158491723 4.014417863 14.487404 6.779790e-06
## Price        0.008448804 0.001885098  4.481891 4.183939e-03

Interpretación: Existe evidencia estadística sólida para afirmar que tanto el intercepto como el efecto del Price sobre el Rating son significativos. Se rechazan ambas hipótesis nulas: que el intercepto es cero \(p = 6.78e-06\) y que la pendiente Price es cero \(p = 0.00418\). El modelo final debe incluir ambos términos.

Conclusión

El análisis estadístico refleja adecuadamente la relación precio-calidad en el mercado de ejercitadoras elípticas. Los resultados demuestran una relación positiva y estadísticamente significativa entre estas variables, donde precios más altos se asocian consistentemente con mejores calificaciones de calidad. El modelo de regresión explica una proporción sustancial 77% de la variabilidad en las calificaciones, respaldado por supuestos estadísticos válidos. los consumidores pueden esperar que una mayor inversión se traduzca en una mejor calidad del producto en este segmento específico del mercado.

Problema 2

Un gerente de ventas obtuvo los siguientes datos sobre ventas anuales (Annual Sales) y años de experiencia (Years of Experience) de 10 vendedores (Salesperson). a) Trace un diagrama de dispersión con estos datos tomando como variable independiente los años de experiencia. b) Obtenga una ecuación de regresión estimada que pueda utilizarse para predecir las ventas anuales proporcionando los años de experiencia. c) Utilice la ecuación de regresión estimada para predecir las ventas anuales de un vendedor con 9 años de experiencia.

Datos

sales_data <- data.frame(
  Salesperson = 1:10,
  Experience = c(1, 3, 4, 4, 6, 8, 10, 10, 11, 13),
  Sales = c(80, 97, 92, 102, 103, 111, 119, 123, 117, 136)
)

# Mostrar los datos
knitr::kable(sales_data, caption = "Datos: Ventas Anuales vs. Años de Experiencia")
Datos: Ventas Anuales vs. Años de Experiencia
Salesperson Experience Sales
1 1 80
2 3 97
3 4 92
4 4 102
5 6 103
6 8 111
7 10 119
8 10 123
9 11 117
10 13 136

Diagrama de dispersión

library(ggplot2)
ggplot(sales_data, aes(x = Experience, y = Sales)) +
  geom_point(size = 3, color = "pink") +
  geom_smooth(method = "lm", se = TRUE, color = "lightblue") +
  labs(title = "Diagrama de Dispersión: Ventas vs. Experiencia",
       x = "Años de Experiencia",
       y = "Ventas Anuales ($1000s)") +
  theme_minimal()
## `geom_smooth()` using formula = 'y ~ x'

##1. Estimación del modelo de regresión

modelo_ventas <- lm(Sales ~ Experience, data = sales_data)
modelo_ventas
## 
## Call:
## lm(formula = Sales ~ Experience, data = sales_data)
## 
## Coefficients:
## (Intercept)   Experience  
##          80            4

Interpretación: La ecuación \(\hat{Y} = 80 + 4 \cdot Experience\) muestra que por cada año adicional de experiencia, las ventas aumentan en promedio 4 mil dólares. \(80 + (4*9) = 116\) Un vendedor con 9 años de experiencia tendría ventas estimadas de 116 mil dólares.

2. Summary e interpretación del modelo

summary(modelo_ventas)
## 
## Call:
## lm(formula = Sales ~ Experience, data = sales_data)
## 
## Residuals:
##    Min     1Q Median     3Q    Max 
##  -7.00  -3.25  -1.00   3.75   6.00 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept)  80.0000     3.0753   26.01 5.12e-09 ***
## Experience    4.0000     0.3868   10.34 6.61e-06 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 4.61 on 8 degrees of freedom
## Multiple R-squared:  0.9304, Adjusted R-squared:  0.9217 
## F-statistic: 106.9 on 1 and 8 DF,  p-value: 6.609e-06

Interpretación: La ecuación \(\hat{Y}_{ventas} = 80.00 + 4.00 \cdot Experience\) muestra que por cada año adicional de experiencia, las ventas aumentan en promedio 4000. El modelo es altamente significativo \(p= 6.61e-06\) y explica el 93% de la variabilidad en ventas.

3. Coeficiente de determinación

summary(modelo_ventas)$r.squared
## [1] 0.9303849
summary(modelo_ventas)$adj.r.squared
## [1] 0.921683

Interpretación: El \(R^2\) de 0.9304 indica que el 93.04% de la variabilidad en las ventas anuales es explicada por los años de experiencia. El \(R^2\) ajustado de 0.9217 confirma la alta capacidad predictiva del modelo.

4. Predicción para nuevos valores

nuevo_vendedor <- data.frame(Experience = 9)
predict(modelo_ventas, newdata = nuevo_vendedor)
##   1 
## 116

Para un vendedor con 9 años de experiencia, se predicen ventas anuales de 116,000. Esto se calcula como: \(80,000 + (4,000 * 9) = 116,000\)

5. Intervalos de confianza para valores esperados

predict(modelo_ventas, newdata = nuevo_vendedor, interval = "confidence")
##   fit      lwr      upr
## 1 116 112.1943 119.8057

Interpretación: Con 95% de confianza, el promedio de ventas anuales para todos los vendedores con 9 años de experiencia se encuentra entre \(112,194\ y\ 119,806\)

6. Intervalos de predicción para observaciones individuales

predict(modelo_ventas, newdata = nuevo_vendedor, interval = "prediction")
##   fit      lwr      upr
## 1 116 104.7092 127.2908

Para un vendedor individual con 9 años de experiencia, se espera con 95% de confianza que sus ventas anuales estén entre \(104,709\ y\ 127,291\)

7. Propiedades de los residuales

mean(modelo_ventas$residuals)
## [1] -8.881784e-17
sum(modelo_ventas$residuals)
## [1] -4.440892e-16

Interpretación:

La media de los residuales es casi cero \(-8.88e-17 ≈ 0\), lo que confirma que no hay sesgo sistemático en las predicciones del modelo.

8. Verificación de supuestos

a) Validación gráfica

par(mfrow=c(2,2))
plot(modelo_ventas)

par(mfrow=c(1,1))

Interpretación: Los gráficos indican que se cumplen los supuestos de regresión linealidad, normalidad, homocedasticidad y el modelo es adecuado.”

b) Análisis de puntos atípicos

library(car)
cooks_ventas <- cooks.distance(modelo_ventas)
outlierTest(modelo_ventas)
## No Studentized residuals with Bonferroni p < 0.05
## Largest |rstudent|:
##    rstudent unadjusted p-value Bonferroni p
## 9 -2.010637           0.084286      0.84286
influenceIndexPlot(modelo_ventas) 

influencePlot(modelo_ventas)

##      StudRes       Hat     CookD
## 1  -1.092127 0.3535211 0.3184474
## 4   1.540232 0.1633803 0.1977229
## 9  -2.010637 0.2126761 0.3955659
## 10  1.092127 0.3535211 0.3184474

Interpretación: No hay evidencia estadística para considerar la observación 9 como valor atípico significativo. El p-valor no alcanza significancia ni antes ni después del ajuste de Bonferroni

c) Validación con pruebas de hipótesis

Prueba de Shapiro.test

\(H_{0}: los\ residuales\ provienen\ de\ una\ distribución\ normal\) \(H_{1}: los\ residuales\ no\ provienen\ de\ una\ distribución\ normal\)

library(lmtest)
shapiro.test(modelo_ventas$residuals)
## 
##  Shapiro-Wilk normality test
## 
## data:  modelo_ventas$residuals
## W = 0.93759, p-value = 0.5265

Interpretación: Shapiro-Wilk \(p = 0.5265 > 0.05\) no rechaza \(H_{0}\): residuales normales. Breusch-Pagan (\(p = 0.8677 > 0.05\)) no rechaza \(H_{0}\): homocedasticidad. Se cumplen los supuestos.

Prueba de Homocedasticidad de Breusch-Pagan

\(H_{0}:la\ homocedastcidad\ de\ los\ residuales\ esta\ presente\)

\(H_{1}: la\ heterocerastidad\ de\ los\ residuales\ esta\ presente\)

bptest(modelo_ventas)
## 
##  studentized Breusch-Pagan test
## 
## data:  modelo_ventas
## BP = 0.02775, df = 1, p-value = 0.8677

Interpretación: El modelo de regresión \(\hat{Y}_{rating} = 58.1585 + 0.0084 \cdot Price\) es estadísticamente significativo \(p = 0.00418\) y explica el 77% de la variabilidad en el rating \(R^2= 0.77\). Por cada dólar de aumento en el precio, el rating aumenta 0.0084 puntos.

Prueba de Durbin-Watson

\(H_{0}: No\ hay\ correlación\)

\(H_{0}: Si\ hay\ correlación\)

dwtest(modelo_ventas)
## 
##  Durbin-Watson test
## 
## data:  modelo_ventas
## DW = 3.2235, p-value = 0.9708
## alternative hypothesis: true autocorrelation is greater than 0

Interpretación: El resultado de la prueba de Durbin-Watson \(DW = 3.2235, p = 0.9708 > 0.05\) indica que no se rechaza la hipótesis nula. No existe evidencia estadística de autocorrelación positiva en los residuales del modelo, por lo que se cumple el supuesto de independencia de los errores.

9. ANOVA del modelo

\(H_{0}: \beta_{1} = 0\) \(H_{1}: \beta_{1} \neq 0\)

anova(modelo_ventas)
## Analysis of Variance Table
## 
## Response: Sales
##            Df Sum Sq Mean Sq F value    Pr(>F)    
## Experience  1   2272 2272.00  106.92 6.609e-06 ***
## Residuals   8    170   21.25                      
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Interpretación: El ANOVA muestra que el modelo es altamente significativo \(F = 106.92, p = 6.609e-06 < 0.05\). Se rechaza \(H_{0}: \beta_{1} = 0\). La experiencia explica significativamente la variabilidad en las ventas, con una suma de cuadrados de 2272 frente a 170 de los residuales.”

10. Prueba de hipótesis para los parámetros

\(H_{0}: \beta_{0} = 0\) \(H_{1}: \beta_{0} \neq 0\)

coef(summary(modelo_ventas))
##             Estimate Std. Error  t value     Pr(>|t|)
## (Intercept)       80  3.0753449 26.01334 5.120023e-09
## Experience         4  0.3868435 10.34010 6.609029e-06

Interpretación: Se rechaza \(H_{0}: \beta_{0} = 0\). El intercepto (\(\beta_{0} = 80\)) y la pendiente (\(\beta_{1} = 4\)) son significativamente diferentes de cero, confirmando que la experiencia es un predictor significativo de las ventas.

Problema 3

Con frecuencia, los viajeros de las aerolíneas empacan tanto como pueden en su maleta para evitar las tarifas por sobreequipaje. Encontrar una maleta rodante durable, con gran capacidad y fácil de mover puede ser difícil. La tabla siguiente muestra los resultados de pruebas realizadas por Consumer Reports en 10 maletas rodantes; las puntuaciones (Score) más altas indican mejores resultados en las pruebas en general (sitio web Consumer Reports, octubre de 2008). La tabla incluye marca (Brand) y precio (Price) de las maletas.

a)Trace un diagrama de dispersión utilizando el precio como la variable independiente. b)¿Qué indica el diagrama de dispersión del inciso a) acerca de la relación entre las dos variables? c)Proporcione una interpretación para la pendiente de la ecuación de regresión estimada. d)La maleta de la marca Eagle Creek Hovercraft tiene un precio de $225. Usando la ecuación de regresión estimada desarrollada en el inciso c), prediga la puntuación para esta maleta.

Datos

maletas <- data.frame(
  Brand = c("Briggs & Riley","Hartman","Heys","Kenneth Cole Reaction","Liz Claiborne",
            "Samsonite","Titan","TravelPro","Tumi","Victorinox"),
  Price = c(325, 350, 67, 120, 85, 180, 360, 156, 595, 400),
  Score = c(72, 74, 54, 54, 64, 57, 66, 67, 87, 77)
)

knitr::kable(maletas, caption = "Datos: Price y Score (maletas rodantes)")
Datos: Price y Score (maletas rodantes)
Brand Price Score
Briggs & Riley 325 72
Hartman 350 74
Heys 67 54
Kenneth Cole Reaction 120 54
Liz Claiborne 85 64
Samsonite 180 57
Titan 360 66
TravelPro 156 67
Tumi 595 87
Victorinox 400 77

Diagrama de dispersión

ggplot(maletas, aes(x = Price, y = Score, label = Brand)) +
  geom_point(size = 3) +
  geom_smooth(method = "lm", se = TRUE) +
  geom_text(vjust = -0.8, size = 3) +
  labs(title = "Dispersión: Score vs Price",
       x = "Price ($)",
       y = "Score")
## `geom_smooth()` using formula = 'y ~ x'
## Warning: The following aesthetics were dropped during statistical transformation: label.
## ℹ This can happen when ggplot fails to infer the correct grouping structure in
##   the data.
## ℹ Did you forget to specify a `group` aesthetic or to convert a numerical
##   variable into a factor?

1. Estimación del modelo de regresión

modelo3 <- lm(Score ~ Price, data = maletas)
modelo3
## 
## Call:
## lm(formula = Score ~ Price, data = maletas)
## 
## Coefficients:
## (Intercept)        Price  
##    52.31050      0.05644

Interpretación: El modelo de regresión estimado \(\hat{Y} = 52.3105 + 0.05644 \cdot Price\) muestra que por cada dólar de aumento en el precio, la puntuación aumenta en 0.05644 puntos. El intercepto de 52.3105 indica la puntuación esperada cuando el precio es cero.

2. Summary

sm3 <- summary(modelo3)
sm3
## 
## Call:
## lm(formula = Score ~ Price, data = maletas)
## 
## Residuals:
##    Min     1Q Median     3Q    Max 
## -6.630 -4.336  1.226  2.068  6.892 
## 
## Coefficients:
##              Estimate Std. Error t value Pr(>|t|)    
## (Intercept) 52.310495   3.017956  17.333 1.25e-07 ***
## Price        0.056442   0.009768   5.778 0.000415 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 4.968 on 8 degrees of freedom
## Multiple R-squared:  0.8067, Adjusted R-squared:  0.7826 
## F-statistic: 33.39 on 1 and 8 DF,  p-value: 0.0004153

Interpretación: El análisis confirma una relación significativa entre precio y calidad \(p = 0.000415\). La ecuación \(\hat{Y} = 52.31 + 0.056 \cdot Price\) muestra que mayor precio se asocia con mejor puntuación. El modelo explica el 80.7% de la variabilidad \(R^2 = 0.807\). Para una maleta de $225, se predice una puntuación de 65 puntos.

3. Coeficiente de determinación

summary(modelo3)$r.squared
## [1] 0.806713
summary(modelo3)$adj.r.squared
## [1] 0.7825522

Interpretación: El coeficiente de determinación \(R^2 = 0.8067\) indica que el precio explica el 80.67% de la variabilidad en las puntuaciones de calidad. El \(R^2\) ajustado de 0.7826 confirma la robustez del modelo.

4. Predicción de la variable de respuesta para nuevos valores

nuevo3 <- data.frame(Price = 225)
pred_3 <- predict(modelo3, newdata = nuevo3)
pred_3
##        1 
## 65.01003

Interpretación:

Para una maleta de 225, el modelo predice una puntuación de \(\hat{Y} = 65.01\) puntos. Esto se obtiene de \(52.3105 + 0.05644 \times 225 = 65.01\).

5. Intervalos de confianza para los valores esperados

predict(modelo3, newdata = nuevo3, interval = "confidence", level = 0.95)
##        fit      lwr      upr
## 1 65.01003 61.28321 68.73686

Interpretación: Con 95% de confianza, la puntuación media esperada para maletas de 225 se encuentra entre \(61.28 y 68.74\) puntos. Esto significa que el valor promedio verdadero está dentro de este intervalo.

6. Intervalos de confianza para las predicciones individuales

predict(modelo3, newdata = nuevo3, interval = "prediction", level = 0.95)
##        fit      lwr      upr
## 1 65.01003 52.96248 77.05759

Interpretación: Para una maleta individual de \$225, se predice con 95\% de confianza que su puntuación estará entre \(52.96 y 77.06\) puntos. Este intervalo es más amplio que el de la media, ya que incluye la variabilidad individual.

7. Propiedades de los residuales

residuales3 <- modelo3$residuals
head(residuales3)
##         1         2         3         4         5         6 
##  1.345725  1.934665 -2.092136 -5.083583  6.891901 -5.470127
sum(residuales3)  
## [1] -2.220446e-15
mean(residuales3)  
## [1] -2.220446e-16
sd(residuales3)
## [1] 4.684039

Interpretación: Los residuales tienen media \(\bar{\varepsilon} = -2.22 \times 10^{-16} \approx 0\) y desviación estándar \(s_{\varepsilon} = 4.68\), cumpliendo la propiedad fundamental de media cero. La suma de residuales es \(-2.22 \times 10^{-15} \approx 0\), validando el ajuste del modelo.

8. Verificación de supuestos

a) Validación gráfica

par(mfrow = c(2,2))
plot(modelo3)

par(mfrow = c(1,1))

b) Análisis de puntos atípicos

library(car)
cooks3 <- cooks.distance(modelo3)
outlierTest(modelo3) 
## No Studentized residuals with Bonferroni p < 0.05
## Largest |rstudent|:
##   rstudent unadjusted p-value Bonferroni p
## 5 1.772613            0.11958           NA
influenceIndexPlot(modelo3) 

influencePlot(modelo3) 

##      StudRes       Hat      CookD
## 3 -0.4616318 0.2497136 0.03933185
## 5  1.7726129 0.2235794 0.35685531
## 7 -1.5583377 0.1357735 0.16185708
## 9  0.3038965 0.5240251 0.05734414

c) Validación con pruebas de hipótesis

Prueba de Shapiro.test

\(H_{0}: los\ residuales\ provienen\ de\ una\ distribución\ normal\) \(H_{1}: los\ residuales\ no\ provienen\ de\ una\ distribución\ normal\)

library(lmtest)
shapiro.test(residuales3)
## 
##  Shapiro-Wilk normality test
## 
## data:  residuales3
## W = 0.92836, p-value = 0.432

Interpretación: Dado que el valor \(p=0.432 > 0.05\), no se rechaza la hipótesis nula \(H_{0}\)). No hay evidencia suficiente para concluir que los residuales no siguen una distribución normal. Los residuales cumplen con el supuesto de normalidad requerido para el modelo de regresión.

Prueba de Homocedasticidad de Breusch-Pagan

\(H_{0}:la\ homocedastcidad\ de\ los\ residuales\ esta\ presente\)

\(H_{1}: la\ heterocerastidad\ de\ los\ residuales\ esta\ presente\)

bptest(modelo3)
## 
##  studentized Breusch-Pagan test
## 
## data:  modelo3
## BP = 2.3117, df = 1, p-value = 0.1284

Interpretación: El resultado de la prueba de Breusch-Pagan \(BP = 2.3117, p = 0.1284 > 0.05\) i ndica que no se rechaza la hipótesis nula. No existe evidencia estadística de heterocedasticidad en los residuales del modelo, por lo que se cumple el supuesto de homocedasticidad.

Prueba de Durbin-Watson

\(H_{0}: No\ hay\ correlación\)

\(H_{0}: Si\ hay\ correlación\)

dwtest(modelo3)
## 
##  Durbin-Watson test
## 
## data:  modelo3
## DW = 2.55, p-value = 0.8244
## alternative hypothesis: true autocorrelation is greater than 0

Interpretación: El resultado de la prueba de Durbin-Watson \(DW = 2.55, p = 0.8244 > 0.05\) indica que no se rechaza la hipótesis nula. No existe evidencia estadística de autocorrelación en los residuales del modelo, por lo que se cumple el supuesto de independencia de los errores.

9. ANOVA del modelo

\(H_{0}: \beta_{1} = 0\) \(H_{1}: \beta_{1} \neq 0\)

anova(modelo3)
## Analysis of Variance Table
## 
## Response: Score
##           Df Sum Sq Mean Sq F value    Pr(>F)    
## Price      1 824.14  824.14  33.389 0.0004153 ***
## Residuals  8 197.46   24.68                      
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Interpretación: El resultado del ANOVA \(F = 33.39, p = 0.0004153 < 0.05\) indica que se rechaza la hipótesis nula. Existe evidencia estadística de que el precio es un predictor significativo de la puntuación en el modelo de regresión lineal.

10. Prueba de hipótesis para los parámetros

\(H_{0}: \beta_{0} = 0\) \(H_{1}: \beta_{0} \neq 0\)

 coef(summary(modelo3))
##               Estimate  Std. Error   t value     Pr(>|t|)
## (Intercept) 52.3104954 3.017956211 17.333086 1.250589e-07
## Price        0.0564424 0.009767923  5.778342 4.153032e-04

Interpretación: El resultado para el intercepto \(t = 17.333, p = 1.25e-07 < 0.05\) indica que se rechaza \(H_{0}\). Existe evidencia estadística de que el intercepto es significativamente diferente de cero en el modelo.

El resultado para la pendiente \(t = 5.778, p = 0.000415 < 0.05\) indica que se rechaza \(H_{0}\). Existe evidencia estadística de que la variable precio tiene un efecto significativo sobre la puntuación de las maletas.

Problema 4

Para el Internal Revenue Service (Servicio de Administración Tributaria de Estados Unidos), el carácter razonable de las deducciones declaradas por un contribuyente depende de su ingreso bruto ajustado. Deducciones grandes que comprenden donaciones de caridad o por atención médica son más apropiadas para contribuyentes que tengan un ingreso bruto ajustado grande. Si las deducciones de una persona son mayores que las deducciones declaradas promedio correspondientes a un determinado nivel de ingresos, aumentan las posibilidades de que se le realice una auditoría. Los datos (en miles de dólares)

sobre ingreso bruto ajustado y el monto promedio o razonable de deducciones declaradas se listan a continuación.

  1. Trace un diagrama de dispersión con estos datos empleando como variable independiente el ingreso bruto ajustado.
  2. Calcule el monto razonable de deducciones declaradas de un contribuyente cuyo ingreso bruto ajustado es de 52 500. Si éste tiene deducciones declaradas por 20 400, ¿estará justificada una auditoria? Explique.

Datos

datos4 <- data.frame(
  Ingreso = c(22, 27, 32, 48, 65, 85, 120),
  Deducciones = c(9.6, 9.6, 10.1, 11.1, 13.5, 17.7, 25.5)
)

knitr::kable(datos4, caption = "Datos: Ingreso bruto ajustado vs Deducciones razonables")
Datos: Ingreso bruto ajustado vs Deducciones razonables
Ingreso Deducciones
22 9.6
27 9.6
32 10.1
48 11.1
65 13.5
85 17.7
120 25.5

Diagrama de dispersión

library(ggplot2)

ggplot(datos4, aes(x = Ingreso, y = Deducciones)) +
  geom_point(size = 3, color = "blue") +
  geom_smooth(method = "lm", se = TRUE, color = "red") +
  labs(title = "Dispersión: Deducciones vs Ingreso bruto ajustado",
       x = "Ingreso bruto ajustado (miles $)",
       y = "Deducciones razonables (miles $)")
## `geom_smooth()` using formula = 'y ~ x'

1. Estimación del modelo

modelo4 <- lm(Deducciones ~ Ingreso, data = datos4)
modelo4
## 
## Call:
## lm(formula = Deducciones ~ Ingreso, data = datos4)
## 
## Coefficients:
## (Intercept)      Ingreso  
##      4.6768       0.1613

Interpretación: El modelo de regresión estimado \(\hat{Y}_{deducciones} = 4.6768 + 0.1613 \cdot Ingreso\) muestra que por cada mil dólares de aumento en el ingreso bruto ajustado, las deducciones declaradas aumentan en 0.1613 miles de dólares ($161.30). El intercepto de 4.6768 indica las deducciones esperadas cuando el ingreso bruto ajustado es cero.

2. Summary

summary(modelo4)
## 
## Call:
## lm(formula = Deducciones ~ Ingreso, data = datos4)
## 
## Residuals:
##       1       2       3       4       5       6       7 
##  1.3744  0.5679  0.2613 -1.3196 -1.6619 -0.6881  1.4660 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept)  4.67675    1.03339   4.526 0.006251 ** 
## Ingreso      0.16131    0.01568  10.285 0.000149 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 1.372 on 5 degrees of freedom
## Multiple R-squared:  0.9549, Adjusted R-squared:  0.9458 
## F-statistic: 105.8 on 1 and 5 DF,  p-value: 0.0001493

Interpretación: El modelo de regresión es altamente significativo \(F = 105.8\), \(p = 0.000149\). Ambos coeficientes son estadísticamente significativos: Intercepto: \(t = 4.526\), \(p = 0.006\) es diferente de cero Pendiente (Ingreso): \(t = 10.285\), \(p = 0.000149\) Relación significativa

El \(R^2 = 0.9549\) indica que el ingreso explica el 95.49% de la variabilidad en las deducciones.

3. Coeficiente de determinación

summary(modelo4)$r.squared
## [1] 0.9548689
summary(modelo4)$adj.r.squared
## [1] 0.9458427

Interpretación:

El \(R^2 = 0.9549\) indica que el ingreso bruto ajustado explica el 95.49% de la variabilidad en las deducciones. El \(R^2\) ajustado de 0.9458 confirma lo robusto del modelo quiere decir que la relación es real

4. Predicción para nuevos valores

nuevo4 <- data.frame(Ingreso = 52.5)
pred_point_4 <- predict(modelo4, newdata = nuevo4)
pred_point_4
##        1 
## 13.14553

Interpretación: \(\hat{Y}_{deducciones} = 4.6768 + 0.1613 \times 52.5 = 13.14553\) miles de dólares Para un contribuyente con ingreso bruto ajustado de 52,500, se predice un monto razonable de deducciones de 13,145.53

5. Intervalos de confianza para valores esperados

predict(modelo4, newdata = nuevo4, interval = "confidence")
##        fit      lwr      upr
## 1 13.14553 11.80064 14.49042

Interpretación: Con 95% de confianza, el monto promedio razonable de deducciones para contribuyentes con ingreso de 52,500 se encuentra entre 11,800.64 y $14,490.42. El valor declarado de $20,400 está muy por encima de este intervalo, lo que refuerza la justificación para una auditoría.

6. Intervalos de confianza para predicciones individuales

predict(modelo4, newdata = nuevo4, interval = "prediction")
##        fit      lwr      upr
## 1 13.14553 9.372015 16.91905

Interpretación:

Para un contribuyente específico con ingreso de 52,500, se predice con 95% de confianza que sus deducciones razonables estarán entre 9,372.02 y 16,919.05. El valor declarado de $20,400 está fuera de este intervalo, lo que indica que es estadísticamente inusual y justifica una auditoría.

7. Propiedades de los residuales

head(modelo4$residuals)
##          1          2          3          4          5          6 
##  1.3744266  0.5678758  0.2613251 -1.3196373 -1.6619097 -0.6881127
sum(modelo4$residuals)
## [1] -6.661338e-16
mean(modelo4$residuals)
## [1] -9.516197e-17

Interpretación: La suma de residuales \(-6.66 \times 10^{-16} \approx 0\) y la media de residuales \(-9.52 \times 10^{-17} \approx 0\) confirman que cumplen con la propiedad fundamental de tener media cero, validando el ajuste del modelo de regresión.

8. Verificación de supuestos

a) Validación gráfica

par(mfrow=c(2,2))
plot(modelo4)

par(mfrow=c(1,1))

b) Análisis de puntos atípicos

library(car)
cooks.distance(modelo4)
##           1           2           3           4           5           6 
## 0.313210849 0.040838940 0.006779376 0.099106154 0.154096088 0.054225356 
##           7 
## 3.305645384
outlierTest(modelo4)
## No Studentized residuals with Bonferroni p < 0.05
## Largest |rstudent|:
##   rstudent unadjusted p-value Bonferroni p
## 7 2.886681           0.044712      0.31298
influencePlot(modelo4)

##     StudRes       Hat     CookD
## 1  1.272477 0.3030297 0.3132108
## 5 -1.454574 0.1512253 0.1540961
## 7  2.886681 0.6618163 3.3056454

Interpretación: La observación 7 presenta alta influencia \(Cook's D = 3.31\) y alto leverage \(Hat = 0.66\), siendo un punto potencialmente influyente. El outlierTest no identifica valores atípicos estadísticamente significativos después del ajuste de Bonferroni. La observación 1 también muestra influencia moderada \(Cook's D = 0.31\) pero dentro de rangos aceptables.

c) Validación con pruebas de hipótesis

Prueba de Shapiro.test

\(H_{0}: los\ residuales\ provienen\ de\ una\ distribución\ normal\) \(H_{1}: los\ residuales\ no\ provienen\ de\ una\ distribución\ normal\)

library(lmtest)
shapiro.test(modelo4$residuals)
## 
##  Shapiro-Wilk normality test
## 
## data:  modelo4$residuals
## W = 0.92061, p-value = 0.4741

Interpretación: El valor \(p = 0.4741 > 0.05\) indica que no se rechaza \(H_{0}\). No hay evidencia suficiente para afirmar que los residuales no siguen una distribución normal, por lo que se cumple el supuesto de normalidad.

Prueba de Homocedasticidad de Breusch-Pagan

\(H_{0}:la\ homocedastcidad\ de\ los\ residuales\ esta\ presente\)

\(H_{1}: la\ heterocerastidad\ de\ los\ residuales\ esta\ presente\)

bptest(modelo4)
## 
##  studentized Breusch-Pagan test
## 
## data:  modelo4
## BP = 0.84206, df = 1, p-value = 0.3588

Interpretación: El valor \(p = 0.3588 > 0.05\) indica que no se rechaza \(H_{0}\). No hay evidencia de heterocedasticidad, por lo que los residuales presentan varianza constante homocedasticidad.

Prueba de Durbin-Watson

\(H_{0}: No\ hay\ correlación\)

\(H_{0}: Si\ hay\ correlación\)

dwtest(modelo4)
## 
##  Durbin-Watson test
## 
## data:  modelo4
## DW = 0.95149, p-value = 0.00691
## alternative hypothesis: true autocorrelation is greater than 0

Interpretación: El valor \(p = 0.00691 < 0.05\) indica que se rechaza \(H_{0}\). Existe evidencia de autocorrelación positiva en los residuales (DW = 0.951), lo que viola el supuesto de independencia de los errores.

9. ANOVA del modelo

\(H_{0}: \beta_{1} = 0\) \(H_{1}: \beta_{1} \neq 0\)

anova(modelo4)
## Analysis of Variance Table
## 
## Response: Deducciones
##           Df  Sum Sq Mean Sq F value    Pr(>F)    
## Ingreso    1 199.008 199.008  105.79 0.0001493 ***
## Residuals  5   9.406   1.881                      
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Interpretación: El resultado del ANOVA \(F = 20.09\), \(p = 0.004184\) indica que se rechaza \(H_0: \beta_1 = 0\).” Existe evidencia estadística significativa de que el precio es un predictor relevante de la calificación.

10. Prueba de hipótesis para los parámetros

\(H_{0}: \beta_{0} = 0\) \(H_{1}: \beta_{0} \neq 0\)

 coef(summary(modelo4))
##              Estimate Std. Error  t value     Pr(>|t|)
## (Intercept) 4.6767502 1.03339428  4.52562 0.0062505498
## Ingreso     0.1613101 0.01568349 10.28535 0.0001493479

Interpretación: El modelo \(\\hat{Y} = 4.68 + 0.161 \\cdot Ingreso\) es altamente significativo \(p = 0.000149\) y explica el 95.5% de la variabilidad. Para ingreso de 52,500, deducciones de 20,400 exceden lo esperado $13,145, justificando auditoría.

Ayudas

https://www.datacamp.com/tutorial/adjusted-r-squared https://blog.minitab.com/es/como-interpretar-los-resultados-del-analisis-de-regresion-valores-p-y-coeficientes