Actividad Extra 2

Actividad Extra 2.

Instalar paquetes y llamar librerias

library(tidyverse)

## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr     1.1.4     ✔ readr     2.1.5
## ✔ forcats   1.0.0     ✔ stringr   1.5.1
## ✔ ggplot2   3.5.2     ✔ tibble    3.3.0
## ✔ lubridate 1.9.3     ✔ tidyr     1.3.1
## ✔ purrr     1.1.0     
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors

library(gplots)

## 
## Attaching package: 'gplots'
## 
## The following object is masked from 'package:stats':
## 
##     lowess

library(plm)

## 
## Attaching package: 'plm'
## 
## The following objects are masked from 'package:dplyr':
## 
##     between, lag, lead

library(DataExplorer)
library(forecast)

## Registered S3 method overwritten by 'quantmod':
##   method            from
##   as.zoo.data.frame zoo

library(lavaan)

## This is lavaan 0.6-19
## lavaan is FREE software! Please report any bugs.

library(lavaanPlot)
library(dplyr)
library(lmtest)

## Loading required package: zoo
## 
## Attaching package: 'zoo'
## 
## The following objects are masked from 'package:base':
## 
##     as.Date, as.Date.numeric

library(readxl)

Paso 1. Generar conjunto de Datos Panel. Bases de datos.

# Base de datos de hogares
db1 <- read_excel("/Users/sebastianespi/Downloads/hogares.xlsx")
ddf1 <- pdata.frame (db1, index=c('HogarID','Año'))

#Base de datos de ecosistema
db2<- read.csv("/Users/sebastianespi/Downloads/ecosistema.csv")

PASO 2. Prubea de Heterogenidad

plotmeans(Ingreso ~ HogarID, main = "Heterogenidad entre casas", data=db1)

Paso 3. Prueba de efectos Fijos y aleatorios

Modelo 1. Regresion Agrupada

# Modelo 1
pooled <- plm (Ingreso~ Satisfacción, data = ddf1, model="pooling")
summary(pooled)

## Pooling Model
## 
## Call:
## plm(formula = Ingreso ~ Satisfacción, data = ddf1, model = "pooling")
## 
## Balanced Panel: n = 100, T = 10, N = 1000
## 
## Residuals:
##      Min.   1st Qu.    Median   3rd Qu.      Max. 
## -20196.53  -5106.46   -575.98   5095.02  23468.66 
## 
## Coefficients:
##              Estimate Std. Error t-value  Pr(>|t|)    
## (Intercept)  10597.75     976.80  10.850 < 2.2e-16 ***
## Satisfacción  2890.77     166.68  17.343 < 2.2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Total Sum of Squares:    6.8145e+10
## Residual Sum of Squares: 5.2364e+10
## R-Squared:      0.23158
## Adj. R-Squared: 0.23081
## F-statistic: 300.772 on 1 and 998 DF, p-value: < 2.22e-16

# Modelo 2
within <- plm(Ingreso ~ Satisfacción, data = ddf1, model="within")
summary(within)

## Oneway (individual) effect Within Model
## 
## Call:
## plm(formula = Ingreso ~ Satisfacción, data = ddf1, model = "within")
## 
## Balanced Panel: n = 100, T = 10, N = 1000
## 
## Residuals:
##       Min.    1st Qu.     Median    3rd Qu.       Max. 
## -15591.951  -3123.123    -74.284   3010.168  13134.979 
## 
## Coefficients:
##              Estimate Std. Error t-value  Pr(>|t|)    
## Satisfacción  1698.14     132.73  12.794 < 2.2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Total Sum of Squares:    2.3013e+10
## Residual Sum of Squares: 1.9469e+10
## R-Squared:      0.15403
## Adj. R-Squared: 0.05993
## F-statistic: 163.687 on 1 and 899 DF, p-value: < 2.22e-16

# Prueba F 
pFtest(within,pooled)

## 
##  F test for individual effects
## 
## data:  Ingreso ~ Satisfacción
## F = 15.343, df1 = 99, df2 = 899, p-value < 2.2e-16
## alternative hypothesis: significant effects

# Modelo 3
walhus <- plm (Ingreso ~ Satisfacción, data = ddf1, model="random", random.method = "walhus")
summary(walhus)

## Oneway (individual) effect Random Effect Model 
##    (Wallace-Hussain's transformation)
## 
## Call:
## plm(formula = Ingreso ~ Satisfacción, data = ddf1, model = "random", 
##     random.method = "walhus")
## 
## Balanced Panel: n = 100, T = 10, N = 1000
## 
## Effects:
##                    var  std.dev share
## idiosyncratic 23574420     4855  0.45
## individual    28789336     5366  0.55
## theta: 0.7249
## 
## Residuals:
##      Min.   1st Qu.    Median   3rd Qu.      Max. 
## -16507.33  -3220.23   -147.96   3184.91  15215.46 
## 
## Coefficients:
##              Estimate Std. Error z-value  Pr(>|z|)    
## (Intercept)  16632.69     925.15  17.978 < 2.2e-16 ***
## Satisfacción  1831.41     131.69  13.907 < 2.2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Total Sum of Squares:    2.6429e+10
## Residual Sum of Squares: 2.2139e+10
## R-Squared:      0.16233
## Adj. R-Squared: 0.16149
## Chisq: 193.404 on 1 DF, p-value: < 2.22e-16

# Metodo Ameniya
amemiya <- plm (Ingreso ~ Satisfacción, data = ddf1, model= "random", random.method="amemiya")
summary(amemiya)

## Oneway (individual) effect Random Effect Model 
##    (Amemiya's transformation)
## 
## Call:
## plm(formula = Ingreso ~ Satisfacción, data = ddf1, model = "random", 
##     random.method = "amemiya")
## 
## Balanced Panel: n = 100, T = 10, N = 1000
## 
## Effects:
##                    var  std.dev share
## idiosyncratic 21631698     4651 0.393
## individual    33418160     5781 0.607
## theta: 0.7534
## 
## Residuals:
##      Min.   1st Qu.    Median   3rd Qu.      Max. 
## -16370.54  -3188.47   -210.78   3188.52  14905.18 
## 
## Coefficients:
##              Estimate Std. Error z-value  Pr(>|z|)    
## (Intercept)  16777.35     953.98  17.587 < 2.2e-16 ***
## Satisfacción  1806.01     130.63  13.825 < 2.2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Total Sum of Squares:    2.5757e+10
## Residual Sum of Squares: 2.1617e+10
## R-Squared:      0.16074
## Adj. R-Squared: 0.1599
## Chisq: 191.14 on 1 DF, p-value: < 2.22e-16

# Metodo nearlove
nerlove <- plm(Ingreso~ Satisfacción, data = ddf1, model="random", random.method = "nerlove")
summary(nerlove)

## Oneway (individual) effect Random Effect Model 
##    (Nerlove's transformation)
## 
## Call:
## plm(formula = Ingreso ~ Satisfacción, data = ddf1, model = "random", 
##     random.method = "nerlove")
## 
## Balanced Panel: n = 100, T = 10, N = 1000
## 
## Effects:
##                    var  std.dev share
## idiosyncratic 19468528     4412 0.351
## individual    35940737     5995 0.649
## theta: 0.7733
## 
## Residuals:
##      Min.   1st Qu.    Median   3rd Qu.      Max. 
## -16275.51  -3113.76   -212.49   3188.29  14690.19 
## 
## Coefficients:
##              Estimate Std. Error z-value  Pr(>|z|)    
## (Intercept)  16869.92     981.37  17.190 < 2.2e-16 ***
## Satisfacción  1789.76     129.95  13.773 < 2.2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Total Sum of Squares:    2.5332e+10
## Residual Sum of Squares: 2.1286e+10
## R-Squared:      0.15972
## Adj. R-Squared: 0.15888
## Chisq: 189.701 on 1 DF, p-value: < 2.22e-16

# Comparar r2 ajustada de los 3 modelos y eligir el mayor

phtest(walhus,within)

## 
##  Hausman Test
## 
## data:  Ingreso ~ Satisfacción
## chisq = 64.632, df = 1, p-value = 9.03e-16
## alternative hypothesis: one model is inconsistent

# Si el P-value es <0.05 usamos efectos fijos (within)

# Por lo tanto nos quedamos con el modelo de efectos fijos

Tema 2. Series de Tiempo: Mapas

Instalar paquetes y librerias

#install.packages("remotes")
#library(remotes)
# install.packages("devtools")
# devtools::install_github("diegovalle/mxmaps")
# 1
library(mxmaps)
library(forecast) # para el arima

ddf2 <-df_mxstate_2020

df_mxstate_2020$value <-ddf2$pop # remplazar aqui con tus valores

mxstate_choropleth(df_mxstate_2020)

Importar la base de datos

df3 <- read_excel("/Users/sebastianespi/Downloads/population.xlsx")

Generar la Serie de Tiempo

df4 <- df3 %>% filter(state== "TX")
ts <- ts(df4$population, start=1900, frequency = 1) # serie de tiempo anual
arima <-auto.arima(ts)

pronostico <-forecast(arima, level=c(95), h=31)
pronostico

##      Point Forecast    Lo 95    Hi 95
## 2020       29398472 29199487 29597457
## 2021       29806827 29463665 30149990
## 2022       30215183 29742956 30687410
## 2023       30623538 30024100 31222977
## 2024       31031894 30303359 31760429
## 2025       31440249 30579246 32301253
## 2026       31848605 30851090 32846119
## 2027       32256960 31118581 33395339
## 2028       32665316 31381587 33949044
## 2029       33073671 31640070 34507272
## 2030       33482027 31894047 35070007
## 2031       33890382 32143561 35637204
## 2032       34298738 32388674 36208801
## 2033       34707093 32629456 36784730
## 2034       35115449 32865983 37364914
## 2035       35523804 33098330 37949278
## 2036       35932160 33326573 38537746
## 2037       36340515 33550788 39130242
## 2038       36748871 33771046 39726695
## 2039       37157226 33987418 40327034
## 2040       37565581 34199972 40931191
## 2041       37973937 34408774 41539100
## 2042       38382292 34613887 42150698
## 2043       38790648 34815371 42765925
## 2044       39199003 35013284 43384723
## 2045       39607359 35207682 44007036
## 2046       40015714 35398618 44632810
## 2047       40424070 35586145 45261995
## 2048       40832425 35770311 45894540
## 2049       41240781 35951163 46530399
## 2050       41649136 36128748 47169524

plot(pronostico, main="Poblacion en Texas")

Tema 3. Modelos de Ecuaciones Estructurales

modelo2 <-
  '#Regresiones
  # Variables latentes
  Calidad.Suelo =~ SPH + NC + OM
  Calidad.Agua =~ CL + DO + WPH
  Salud.Ecosistema =~ SD + BM + EP
  # Varianza y covarianza 
  Calidad.Suelo ~~ Calidad.Agua 
  Salud.Ecosistema ~~ Calidad.Suelo + Calidad.Agua 
  # Intercepto
  '

Generar el Diagrama

db3 <- scale(db2)
db4 <- cfa(modelo2, db3)

## Warning: lavaan->lav_object_post_check():  
##    covariance matrix of latent variables is not positive definite ; use 
##    lavInspect(fit, "cov.lv") to investigate.

summary(df4)

##     state                year        population      
##  Length:120         Min.   :1900   Min.   : 3055000  
##  Class :character   1st Qu.:1930   1st Qu.: 5823500  
##  Mode  :character   Median :1960   Median : 9514500  
##                     Mean   :1960   Mean   :11825205  
##                     3rd Qu.:1989   3rd Qu.:16866230  
##                     Max.   :2019   Max.   :28995881

lavaanPlot(db4, coef=TRUE, cov=TRUE)