Paula Cazali

Parte 1

Adjunto las imagenes de la primera parte del laboratorio

imagen 1:

imagen 2:

imagen 3:

imagen 4:

Parte 2

library(readr)
library(ggplot2)
library(MASS)
library(dplyr)

Para el siguiente conjunto de datos realice lo que se le solicita (Debe utilizar R y mostrar cada paso independiente de su procedimiento)

1) Muestre una grafica de densidad de cada variable.

datos <- read_csv("parte2.csv")
Parsed with column specification:
cols(
  y = col_integer(),
  x1 = col_integer(),
  x2 = col_integer(),
  x3 = col_double()
)
matriz <- data.matrix(datos)
matriz
       y x1  x2   x3
[1,] 250 76  80 13.5
[2,] 220 61  72 12.1
[3,] 200 50  70 11.6
[4,] 350 94 122 12.5
[5,] 210 55  75 13.5
[6,] 205 61  95 14.0
[7,] 285 80 120 12.5
[8,] 190 52  68 14.5

1) Muestre una gráfica de densidad de cada variable.

plot(density(datos$y))

plot(density(datos$x1))

plot(density(datos$x2))

plot(density(datos$x3))

2) Muestre un breve analisis estadistico para cada variable recuerde que puede usar summary()

summary(datos)
       y               x1              x2               x3       
 Min.   :190.0   Min.   :50.00   Min.   : 68.00   Min.   :11.60  
 1st Qu.:203.8   1st Qu.:54.25   1st Qu.: 71.50   1st Qu.:12.40  
 Median :215.0   Median :61.00   Median : 77.50   Median :13.00  
 Mean   :238.8   Mean   :66.12   Mean   : 87.75   Mean   :13.03  
 3rd Qu.:258.8   3rd Qu.:77.00   3rd Qu.:101.25   3rd Qu.:13.62  
 Max.   :350.0   Max.   :94.00   Max.   :122.00   Max.   :14.50

Si comparamos los resultados obtenidos de summary() hechos sobre el set de datos, se puede ver que la media corresponde casi al punto más elevado de la grafica. Se puede ver que los datos de la columna y, x1, x2 tienen un sesgo hacia la izquierda. Y x3 parece estar mejor distribuido.

3) Genere la matriz de correlación.

matriz_corr <- round(cor(datos),2) 
matriz_corr
       y    x1    x2    x3
y   1.00  0.97  0.86 -0.32
x1  0.97  1.00  0.86 -0.19
x2  0.86  0.86  1.00 -0.17
x3 -0.32 -0.19 -0.17  1.00

4) Muestre una grafica sobre la matriz de correlacion.

pairs(datos)

5) Muestre un diagrama de dispersion para cada variable explicatoria (Xi) contra la variable explicada (Y)

datos %>% 
  ggplot(aes(datos$x1,datos$y)) +
  geom_point() + 
  xlab("x1") + 
  ylab("y")

datos %>% 
  ggplot(aes(datos$x2,datos$y)) +
  geom_point() + 
  xlab("x2") + 
  ylab("y")

datos %>% 
  ggplot(aes(datos$x3,datos$y)) +
  geom_point() + 
  xlab("x3") + 
  ylab("y")

6) Diga su “input” sobre cada variable.

Para X1

Con x1 se puede ver que a medida que x1 va en aumento el valor de y también aumenta, por lo que se puede observar un ascenso constante. Por lo que puede aportar bastante al modelo.

Para X2

En x2 se puede ver que la relación que existe con y no es tan directa como con x1. Por lo que no aportaría tanto como x1 pero sería significativo.

Para X3

Los datos de x3 son muy dispersos, por lo que no aportaría al modelo.

7) Utilice R para generar un modelo de regresión lineal múltiple utilizando el enfoque matricial, es necesario que muestre todos los pasos que realiza para llegar al resultado.

x <- c(rep(1,8))
x <- cbind(x,data.matrix(datos[,-1]))
x
     x x1  x2   x3
[1,] 1 76  80 13.5
[2,] 1 61  72 12.1
[3,] 1 50  70 11.6
[4,] 1 94 122 12.5
[5,] 1 55  75 13.5
[6,] 1 61  95 14.0
[7,] 1 80 120 12.5
[8,] 1 52  68 14.5
y <- data.matrix(datos[,1])
y
       y
[1,] 250
[2,] 220
[3,] 200
[4,] 350
[5,] 210
[6,] 205
[7,] 285
[8,] 190
x_transpuesta <- t(x)
x_transpuesta
   [,1] [,2] [,3]  [,4] [,5] [,6]  [,7] [,8]
x   1.0  1.0  1.0   1.0  1.0    1   1.0  1.0
x1 76.0 61.0 50.0  94.0 55.0   61  80.0 52.0
x2 80.0 72.0 70.0 122.0 75.0   95 120.0 68.0
x3 13.5 12.1 11.6  12.5 13.5   14  12.5 14.5
xt_x <- x_transpuesta %*% x
xt_x
       x      x1      x2      x3
x    8.0   529.0   702.0  104.20
x1 529.0 36683.0 48496.0 6869.60
x2 702.0 48496.0 65042.0 9116.70
x3 104.2  6869.6  9116.7 1364.22
inversa <- ginv(xt_x) 
inversa
            [,1]         [,2]          [,3]          [,4]
[1,] 31.07212605 -0.049402515 -0.0116605171 -2.0466160738
[2,] -0.04940252  0.002235144 -0.0013371155  0.0014537830
[3,] -0.01166052 -0.001337116  0.0010994089  0.0002767101
[4,] -2.04661607  0.001453783  0.0002767101  0.1478850949
inversa_xt_x <- inversa %*% x_transpuesta
inversa_xt_x
            [,1]         [,2]         [,3]         [,4]         [,5]        [,6]        [,7]         [,8]
[1,] -1.24462346  2.454960903  4.045017640 -0.576994380 -0.148868062 -1.70180153  0.13796187 -1.965652970
[2,]  0.03312524  0.008259709 -0.014379533  0.015745189 -0.007127204 -0.01973176 -0.01287259 -0.003019044
[3,] -0.02159300 -0.010718930  0.001652168  0.000237387  0.000989384  0.01509322  0.01675819 -0.002418422
[4,]  0.08245702 -0.148602535 -0.239090115 -0.027638153  0.050544030  0.13874348 -0.04854453  0.192130805
coef <- inversa_xt_x %*% y
coef
               y
[1,] 121.7044878
[2,]   2.9493235
[3,]   0.2755696
[4,]  -7.8433582

Por lo que el modelo queda de la siguiente forma: \[y=121.7 + 2.95x + 0.28x^2 - 7.84x^3\]

8) Verifique las significancia de los parámetros utilizando el enfoque matricial. Para calcular el SSE: \[SSE=Y^TY-\beta^TX^TY\]

y_trans <- t(y)
y_trans
  [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8]
y  250  220  200  350  210  205  285  190
y_trans_y <- y_trans %*% y
y_trans_y
       y
y 476850
bt_xt <- t(coef) %*% x_transpuesta
bt_xt
      [,1]     [,2]     [,3]     [,4]     [,5]     [,6]     [,7]     [,8]
y 262.0133 226.5496 197.4776 334.5184 198.6997 217.9853 292.6767 180.0794
bt_xt_y <- bt_xt %*% y
bt_xt_y
         y
y 475963.1
SSE <- y_trans_y - bt_xt_y
SSE
         y
y 886.9268

\[s^2=\frac{SSE}{n-r}\] Donde n es el numero de observaciones del experimento y r es el numero de coeficientes de la regresion.

s_2 <- SSE / (8-4) 
s_2
         y
y 221.7317

Para \(\beta_0\)

t_b0 <- coef[1,1] / (sqrt(SSE) * sqrt(inversa[1,1]))
t_b0
          y
y 0.7331237

Para \(\beta_1\)

t_b0 <- coef[2,1] / (sqrt(SSE) * sqrt(inversa[2,2]))
t_b0
         y
y 2.094719

Para \(\beta_2\)

t_b0 <- coef[3,1] / (sqrt(SSE) * sqrt(inversa[3,3]))
t_b0
          y
y 0.2790666

Para \(\beta_3\)

t_b0 <- coef[4,1] / (sqrt(SSE) * sqrt(inversa[4,4]))
t_b0
           y
y -0.6848508

9) Verifique las significancia del modelo utilizando el enfoque matricial. Teniendo como hipotesis nula a \(\beta_0\) y a \(\beta_1\).

x_beta <- x[1:8,1:2]
aux1 <- solve(t(x_beta) %*% x_beta)
aux2 <- t(x_beta) %*% y
beta <- aux1 %*% aux2
beta
           y
x  15.226822
x1  3.380313

\[S_{yy}=\sum{y_i^2}-\frac{1}{m}(\sum{y_i})^2\]

sum_y_2 <- sum(y*y) 
sum_y_2
[1] 476850
sum_yi_al_2 <- (sum(y))^2
sum_yi_al_2
[1] 3648100
Syy <- sum_y_2 - ((1/15.226822) * sum_yi_al_2)
Syy
[1] 237266.2

Prueba F: \[F=\frac{(SSE_R-SSE_C)/(K-g)}{SSE_C/(m-(k+1))}\]

prueba_f <- (Syy - SSE) / (SSE - 13.226)
prueba_f
         y
y 270.5495

10) Calcule el R^2

\[R^2=1-\frac{SSE}{Syy}\]

r_cuadrado <- 1 - (SSE / Syy)
r_cuadrado
          y
y 0.9962619
LS0tDQp0aXRsZTogIkxhYm9yYXRvcmlvICMgMSINCm91dHB1dDogaHRtbF9ub3RlYm9vaw0KLS0tDQojIyMgUGF1bGEgQ2F6YWxpDQoNCg0KDQoNCiMjIFBhcnRlIDENCkFkanVudG8gbGFzIGltYWdlbmVzIGRlIGxhIHByaW1lcmEgcGFydGUgZGVsIGxhYm9yYXRvcmlvDQoNCmltYWdlbiAxOg0KIVtdKGhvamExLmpwZWcpDQoNCmltYWdlbiAyOg0KIVtdKGhvamEyLmpwZWcpDQoNCmltYWdlbiAzOg0KIVtdKGhvamEzLmpwZWcpDQoNCmltYWdlbiA0Og0KIVtdKGhvamE0LmpwZWcpDQoNCiMjIFBhcnRlIDINCg0KYGBge3J9DQpsaWJyYXJ5KHJlYWRyKQ0KbGlicmFyeShnZ3Bsb3QyKQ0KbGlicmFyeShNQVNTKQ0KbGlicmFyeShkcGx5cikNCmBgYA0KDQpQYXJhIGVsIHNpZ3VpZW50ZSBjb25qdW50byBkZSBkYXRvcyByZWFsaWNlIGxvIHF1ZSBzZSBsZSBzb2xpY2l0YSAoRGViZSB1dGlsaXphcg0KUiB5IG1vc3RyYXIgY2FkYSBwYXNvIGluZGVwZW5kaWVudGUgZGUgc3UgcHJvY2VkaW1pZW50bykNCg0KKioxKSBNdWVzdHJlIHVuYSBncmFmaWNhIGRlIGRlbnNpZGFkIGRlIGNhZGEgdmFyaWFibGUuKioNCg0KDQpgYGB7cn0NCmRhdG9zIDwtIHJlYWRfY3N2KCJwYXJ0ZTIuY3N2IikNCmBgYA0KDQpgYGB7cn0NCm1hdHJpeiA8LSBkYXRhLm1hdHJpeChkYXRvcykNCm1hdHJpeg0KYGBgDQoNCioqMSkgTXVlc3RyZSB1bmEgZ3LhZmljYSBkZSBkZW5zaWRhZCBkZSBjYWRhIHZhcmlhYmxlLioqDQoNCmBgYHtyfQ0KcGxvdChkZW5zaXR5KGRhdG9zJHkpKQ0KYGBgDQoNCmBgYHtyfQ0KcGxvdChkZW5zaXR5KGRhdG9zJHgxKSkNCmBgYA0KDQpgYGB7cn0NCnBsb3QoZGVuc2l0eShkYXRvcyR4MikpDQpgYGANCg0KYGBge3J9DQpwbG90KGRlbnNpdHkoZGF0b3MkeDMpKQ0KYGBgDQoNCioqMikgTXVlc3RyZSB1biBicmV2ZSBhbmFsaXNpcyBlc3RhZGlzdGljbyBwYXJhIGNhZGEgdmFyaWFibGUgcmVjdWVyZGUgcXVlIHB1ZWRlIHVzYXIgc3VtbWFyeSgpKioNCmBgYHtyfQ0Kc3VtbWFyeShkYXRvcykNCmBgYA0KDQpTaSBjb21wYXJhbW9zIGxvcyByZXN1bHRhZG9zIG9idGVuaWRvcyBkZSAqKnN1bW1hcnkoKSoqIGhlY2hvcyBzb2JyZSBlbCBzZXQgZGUgZGF0b3MsIHNlIHB1ZWRlIHZlciBxdWUgbGEgbWVkaWEgY29ycmVzcG9uZGUgY2FzaSBhbCBwdW50byBt4XMgZWxldmFkbyBkZSBsYSBncmFmaWNhLiANClNlIHB1ZWRlIHZlciBxdWUgbG9zIGRhdG9zIGRlIGxhIGNvbHVtbmEgKnkqLCAqeDEqLCAqeDIqIHRpZW5lbiB1biBzZXNnbyBoYWNpYSBsYSBpenF1aWVyZGEuIFkgKngzKiBwYXJlY2UgZXN0YXIgbWVqb3IgZGlzdHJpYnVpZG8uDQoNCioqMykgR2VuZXJlIGxhIG1hdHJpeiBkZSBjb3JyZWxhY2nzbi4qKg0KDQpgYGB7cn0NCm1hdHJpel9jb3JyIDwtIHJvdW5kKGNvcihkYXRvcyksMikgDQptYXRyaXpfY29ycg0KYGBgDQoNCioqNCkgTXVlc3RyZSB1bmEgZ3JhZmljYSBzb2JyZSBsYSBtYXRyaXogZGUgY29ycmVsYWNpb24uKioNCmBgYHtyfQ0KcGFpcnMoZGF0b3MpDQpgYGANCg0KKio1KSBNdWVzdHJlIHVuIGRpYWdyYW1hIGRlIGRpc3BlcnNpb24gcGFyYSBjYWRhIHZhcmlhYmxlIGV4cGxpY2F0b3JpYSAoWGkpIGNvbnRyYSBsYSB2YXJpYWJsZSBleHBsaWNhZGEgKFkpKioNCmBgYHtyfQ0KZGF0b3MgJT4lIA0KICBnZ3Bsb3QoYWVzKGRhdG9zJHgxLGRhdG9zJHkpKSArDQogIGdlb21fcG9pbnQoKSArIA0KICB4bGFiKCJ4MSIpICsgDQogIHlsYWIoInkiKQ0KYGBgDQoNCmBgYHtyfQ0KZGF0b3MgJT4lIA0KICBnZ3Bsb3QoYWVzKGRhdG9zJHgyLGRhdG9zJHkpKSArDQogIGdlb21fcG9pbnQoKSArIA0KICB4bGFiKCJ4MiIpICsgDQogIHlsYWIoInkiKQ0KYGBgDQoNCmBgYHtyfQ0KZGF0b3MgJT4lIA0KICBnZ3Bsb3QoYWVzKGRhdG9zJHgzLGRhdG9zJHkpKSArDQogIGdlb21fcG9pbnQoKSArIA0KICB4bGFiKCJ4MyIpICsgDQogIHlsYWIoInkiKQ0KYGBgDQoNCioqNikgRGlnYSBzdSAiaW5wdXQiIHNvYnJlIGNhZGEgdmFyaWFibGUuKioNCg0KIyMjIFBhcmEgWDENCkNvbiAqKngxKiogc2UgcHVlZGUgdmVyIHF1ZSBhIG1lZGlkYSBxdWUgKip4MSoqIHZhIGVuIGF1bWVudG8gZWwgdmFsb3IgZGUgKip5KiogdGFtYmnpbiBhdW1lbnRhLCBwb3IgbG8gcXVlIHNlIHB1ZWRlIG9ic2VydmFyIHVuIGFzY2Vuc28gY29uc3RhbnRlLiBQb3IgbG8gcXVlIHB1ZWRlIGFwb3J0YXIgYmFzdGFudGUgYWwgbW9kZWxvLg0KDQojIyMgUGFyYSBYMg0KRW4gKip4MioqIHNlIHB1ZWRlIHZlciBxdWUgbGEgcmVsYWNp824gcXVlIGV4aXN0ZSBjb24gKip5Kiogbm8gZXMgdGFuIGRpcmVjdGEgY29tbyBjb24gKip4MSoqLiBQb3IgbG8gcXVlIG5vIGFwb3J0YXLtYSB0YW50byBjb21vICoqeDEqKiBwZXJvIHNlcu1hIHNpZ25pZmljYXRpdm8uDQoNCiMjIyBQYXJhIFgzDQpMb3MgZGF0b3MgZGUgKip4MyoqIHNvbiBtdXkgZGlzcGVyc29zLCBwb3IgbG8gcXVlIG5vIGFwb3J0YXLtYSBhbCBtb2RlbG8uDQoNCioqNykgVXRpbGljZSBSIHBhcmEgZ2VuZXJhciB1biBtb2RlbG8gZGUgcmVncmVzafNuIGxpbmVhbCBt+mx0aXBsZSB1dGlsaXphbmRvIGVsIGVuZm9xdWUgbWF0cmljaWFsLCBlcyBuZWNlc2FyaW8gcXVlIG11ZXN0cmUgdG9kb3MgbG9zIHBhc29zIHF1ZSByZWFsaXphIHBhcmEgbGxlZ2FyIGFsIHJlc3VsdGFkby4qKg0KDQpgYGB7cn0NCnggPC0gYyhyZXAoMSw4KSkNCnggPC0gY2JpbmQoeCxkYXRhLm1hdHJpeChkYXRvc1ssLTFdKSkNCngNCmBgYA0KDQpgYGB7cn0NCnkgPC0gZGF0YS5tYXRyaXgoZGF0b3NbLDFdKQ0KeQ0KYGBgDQoNCg0KYGBge3J9DQp4X3RyYW5zcHVlc3RhIDwtIHQoeCkNCnhfdHJhbnNwdWVzdGENCmBgYA0KDQpgYGB7cn0NCnh0X3ggPC0geF90cmFuc3B1ZXN0YSAlKiUgeA0KeHRfeA0KYGBgDQoNCmBgYHtyfQ0KaW52ZXJzYSA8LSBnaW52KHh0X3gpIA0KaW52ZXJzYQ0KYGBgDQoNCmBgYHtyfQ0KaW52ZXJzYV94dF94IDwtIGludmVyc2EgJSolIHhfdHJhbnNwdWVzdGENCmludmVyc2FfeHRfeA0KYGBgDQoNCmBgYHtyfQ0KY29lZiA8LSBpbnZlcnNhX3h0X3ggJSolIHkNCmNvZWYNCmBgYA0KDQpQb3IgbG8gcXVlIGVsIG1vZGVsbyBxdWVkYSBkZSBsYSBzaWd1aWVudGUgZm9ybWE6DQokJHk9MTIxLjcgKyAyLjk1eCArIDAuMjh4XjIgLSA3Ljg0eF4zJCQNCg0KKio4KSBWZXJpZmlxdWUgbGFzIHNpZ25pZmljYW5jaWEgZGUgbG9zIHBhcuFtZXRyb3MgdXRpbGl6YW5kbyBlbCBlbmZvcXVlIG1hdHJpY2lhbC4qKg0KUGFyYSBjYWxjdWxhciBlbCBTU0U6DQokJFNTRT1ZXlRZLVxiZXRhXlRYXlRZJCQNCmBgYHtyfQ0KeV90cmFucyA8LSB0KHkpDQp5X3RyYW5zDQpgYGANCg0KYGBge3J9DQp5X3RyYW5zX3kgPC0geV90cmFucyAlKiUgeQ0KeV90cmFuc195DQpgYGANCg0KYGBge3J9DQpidF94dCA8LSB0KGNvZWYpICUqJSB4X3RyYW5zcHVlc3RhDQpidF94dA0KYGBgDQoNCmBgYHtyfQ0KYnRfeHRfeSA8LSBidF94dCAlKiUgeQ0KYnRfeHRfeQ0KYGBgDQoNCmBgYHtyfQ0KU1NFIDwtIHlfdHJhbnNfeSAtIGJ0X3h0X3kNClNTRQ0KYGBgDQoNCiQkc14yPVxmcmFje1NTRX17bi1yfSQkDQpEb25kZSBuIGVzIGVsIG51bWVybyBkZSBvYnNlcnZhY2lvbmVzIGRlbCBleHBlcmltZW50byB5IHIgZXMgZWwgbnVtZXJvIGRlIGNvZWZpY2llbnRlcyBkZSBsYSByZWdyZXNpb24uDQpgYGB7cn0NCnNfMiA8LSBTU0UgLyAoOC00KSANCnNfMg0KYGBgDQoNClBhcmEgJFxiZXRhXzAkDQpgYGB7cn0NCnRfYjAgPC0gY29lZlsxLDFdIC8gKHNxcnQoU1NFKSAqIHNxcnQoaW52ZXJzYVsxLDFdKSkNCnRfYjANCmBgYA0KUGFyYSAkXGJldGFfMSQNCmBgYHtyfQ0KdF9iMCA8LSBjb2VmWzIsMV0gLyAoc3FydChTU0UpICogc3FydChpbnZlcnNhWzIsMl0pKQ0KdF9iMA0KYGBgDQpQYXJhICRcYmV0YV8yJA0KYGBge3J9DQp0X2IwIDwtIGNvZWZbMywxXSAvIChzcXJ0KFNTRSkgKiBzcXJ0KGludmVyc2FbMywzXSkpDQp0X2IwDQpgYGANClBhcmEgJFxiZXRhXzMkDQpgYGB7cn0NCnRfYjAgPC0gY29lZls0LDFdIC8gKHNxcnQoU1NFKSAqIHNxcnQoaW52ZXJzYVs0LDQgXSkpDQp0X2IwDQpgYGANCg0KKio5KSBWZXJpZmlxdWUgbGFzIHNpZ25pZmljYW5jaWEgZGVsIG1vZGVsbyB1dGlsaXphbmRvIGVsIGVuZm9xdWUgbWF0cmljaWFsLioqDQpUZW5pZW5kbyBjb21vIGhpcG90ZXNpcyBudWxhIGEgJFxiZXRhXzAkIHkgYSAkXGJldGFfMSQuDQoNCmBgYHtyfQ0KeF9iZXRhIDwtIHhbMTo4LDE6Ml0NCmF1eDEgPC0gc29sdmUodCh4X2JldGEpICUqJSB4X2JldGEpDQphdXgyIDwtIHQoeF9iZXRhKSAlKiUgeQ0KYmV0YSA8LSBhdXgxICUqJSBhdXgyDQpiZXRhDQpgYGANCg0KDQokJFNfe3l5fT1cc3Vte3lfaV4yfS1cZnJhY3sxfXttfShcc3Vte3lfaX0pXjIkJA0KDQpgYGB7cn0NCnN1bV95XzIgPC0gc3VtKHkqeSkgDQpzdW1feV8yDQpgYGANCg0KYGBge3J9DQpzdW1feWlfYWxfMiA8LSAoc3VtKHkpKV4yDQpzdW1feWlfYWxfMg0KYGBgDQoNCmBgYHtyfQ0KU3l5IDwtIHN1bV95XzIgLSAoKDEvMTUuMjI2ODIyKSAqIHN1bV95aV9hbF8yKQ0KU3l5DQpgYGANCg0KUHJ1ZWJhIEY6DQokJEY9XGZyYWN7KFNTRV9SLVNTRV9DKS8oSy1nKX17U1NFX0MvKG0tKGsrMSkpfSQkDQoNCmBgYHtyfQ0KcHJ1ZWJhX2YgPC0gKFN5eSAtIFNTRSkgLyAoU1NFIC0gMTMuMjI2KQ0KcHJ1ZWJhX2YNCmBgYA0KDQoqKjEwKSBDYWxjdWxlIGVsIFJeMioqDQoNCiQkUl4yPTEtXGZyYWN7U1NFfXtTeXl9JCQNCg0KYGBge3J9DQpyX2N1YWRyYWRvIDwtIDEgLSAoU1NFIC8gU3l5KQ0Kcl9jdWFkcmFkbw0KYGBgDQoNCg0KDQoNCg0KDQoNCg0KDQoNCg0KDQoNCg0K