Tarea 1

Crear un nuevo dataframe que sea un subconjunto del dataframe original de dfFires. El subconjunto debe contener todos los incendios del Estado de Idaho y las columnas deben ser limitadas para que sólo estén presentes las columnas YEAR_, CAUSE y TOTALACRES. Cambie el nombre de las columnas. Agrupe los datos por CAUSE y YEAR_ y luego resuma por el total de acres quemados. Trazar los resultados.

library(readr)

dfFires <- read_csv("StudyArea.csv", 
                    locale = locale(encoding = "UTF-8"),
                    col_types = cols(UNIT = col_character()), 
                    col_names = TRUE)

knitr::kable(head(dfFires, 5))

FID	ORGANIZATI	UNIT	SUBUNIT	SUBUNIT2	FIRENAME	CAUSE	YEAR_	STARTDATED	CONTRDATED	OUTDATED	STATE	STATE_FIPS	TOTALACRES
0	FWS	81682	USCADBR	San Diego Bay National Wildlife Refuge	PUMP HOUSE	Human	2001	1/1/01 0:00	1/1/01 0:00	NA	California	6	0.1
1	FWS	81682	USCADBR	San Diego Bay National Wildlife Refuge	I5	Human	2002	5/3/02 0:00	5/3/02 0:00	NA	California	6	3.0
2	FWS	81682	USCADBR	San Diego Bay National Wildlife Refuge	SOUTHBAY	Human	2002	6/1/02 0:00	6/1/02 0:00	NA	California	6	0.5
3	FWS	81682	USCADBR	San Diego Bay National Wildlife Refuge	MARINA	Human	2001	7/12/01 0:00	7/12/01 0:00	NA	California	6	0.1
4	FWS	81682	USCADBR	San Diego Bay National Wildlife Refuge	HILL	Human	1994	9/13/94 0:00	9/13/94 0:00	NA	California	6	1.0

library(dplyr)

## 
## Attaching package: 'dplyr'

## The following objects are masked from 'package:stats':
## 
##     filter, lag

## The following objects are masked from 'package:base':
## 
##     intersect, setdiff, setequal, union

library(ggplot2)
Sys.setlocale("LC_ALL", "es_ES.UTF-8")

## [1] "LC_CTYPE=es_ES.UTF-8;LC_NUMERIC=C;LC_TIME=es_ES.UTF-8;LC_COLLATE=es_ES.UTF-8;LC_MONETARY=es_ES.UTF-8;LC_MESSAGES=C.UTF-8;LC_PAPER=C.UTF-8;LC_NAME=C;LC_ADDRESS=C;LC_TELEPHONE=C;LC_MEASUREMENT=C.UTF-8;LC_IDENTIFICATION=C"

# Crear un nuevo dataframe que sea un subconjunto de dfFires
dfFires_Idaho <- dfFires %>%
  filter(STATE == "Idaho") %>%
  select(YEAR = YEAR_, CAUSE, TOTALACRES)

# Agrupar por CAUSE y YEAR y sumar los TOTALACRES
dfFires_Summary <- dfFires_Idaho %>%
  group_by(CAUSE, YEAR) %>%
  summarise(TotalAcresBurned = sum(TOTALACRES))

## `summarise()` has grouped output by 'CAUSE'. You can override using the
## `.groups` argument.

# Trazar los resultados
ggplot(dfFires_Summary, aes(x = YEAR, y = TotalAcresBurned, fill = CAUSE)) +
  geom_bar(stat = "identity", position = "dodge") +
  theme_minimal() +
  labs(title = "Total de hectáreas quemadas por causa y año en Idaho",
       x = "Año",
       y = "Total de hectáreas quemadas")

El grafico anterior muestra el total de hectáreas quemadas en Idaho por año y causa, por lo que se puede concluir que entre el año 2000 y 2010 se quemaron mas hectareas por causa natural.

Resuelva la Tarea 1.1 de la Sección 1 de Python utilizando R.

library(dplyr)
library(ggplot2)
url2<-'https://raw.githubusercontent.com/lihkirun/AppliedStatisticMS/main/DataVisualizationRPython/Lectures/Python/PythonDataSets/athlete_events.csv'
library(readr)
df_olympics <- read_csv(url2, col_types = list(UNIT = col_character()), col_names = TRUE)

## Warning: The following named parsers don't match the column names: UNIT

knitr::kable(head(df_olympics, 5))

ID	Name	Sex	Age	Height	Weight	Team	NOC	Games	Year	Season	City	Sport	Event	Medal
1	A Dijiang	M	24	180	80	China	CHN	1992 Summer	1992	Summer	Barcelona	Basketball	Basketball Men’s Basketball	NA
2	A Lamusi	M	23	170	60	China	CHN	2012 Summer	2012	Summer	London	Judo	Judo Men’s Extra-Lightweight	NA
3	Gunnar Nielsen Aaby	M	24	NA	NA	Denmark	DEN	1920 Summer	1920	Summer	Antwerpen	Football	Football Men’s Football	NA
4	Edgar Lindenau Aabye	M	34	NA	NA	Denmark/Sweden	DEN	1900 Summer	1900	Summer	Paris	Tug-Of-War	Tug-Of-War Men’s Tug-Of-War	Gold
5	Christine Jacoba Aaftink	F	21	185	82	Netherlands	NED	1988 Winter	1988	Winter	Calgary	Speed Skating	Speed Skating Women’s 500 metres	NA

df_2016_medals <- df_olympics %>%
  filter(Year == 2016, !is.na(Medal))

# Identificar los cinco deportes con más medallas
top_sports <- df_2016_medals %>%
  count(Sport, sort = TRUE) %>%
  top_n(5, n)

# Filtrar el dataframe por estos deportes
df_2016_top_sports <- df_2016_medals %>%
  filter(Sport %in% top_sports$Sport)

ggplot(df_2016_top_sports, aes(x = Sport, fill = Medal)) +
  geom_bar() +
  labs(title = "Medals in Top 5 Sports in 2016", x = "Sport", y = "Count of Medals")

El gráfico de barras anterior muestra la cantidad de medallas obtenidas en los cinco deportes principales en 2016, con las barras coloreadas según el tipo de medalla, por lo que se concluye que los deportes que obtuvieron mas medallas fueron atletismo y natacion y el deporte que menos obtuvo medallas fue Hockey.

ggplot(df_2016_top_sports, aes(x = Age)) +
  geom_histogram(binwidth = 1, fill = "blue", color = "black") +
  facet_wrap(~Sport) +
  labs(title = "Age Distribution of Medal Winners in Top 5 Sports in 2016", x = "Age", y = "Count")

El grafico anterior contiene un conjunto de histogramas que muestran la distribución de edades de los ganadores de medallas en los cinco deportes principales en 2016, con cada deporte presentado en un histograma separado, concluyendo que los deportistas que mas ganaron medallas estaban entre las edades de 20 y 25 años para atletismo y natacion.

library(dplyr)
library(ggplot2)

n_teams <- 10 

df_2016_top_sports %>%
  count(Team, Sport) %>%
  group_by(Team) %>%
  summarize(TotalMedals = sum(n)) %>%
  top_n(n_teams, TotalMedals) %>%
  ggplot(aes(x = reorder(Team, -TotalMedals), y = TotalMedals)) +
  geom_bar(stat = "identity", fill = "blue") +
  coord_flip() +
  labs(title = paste("Top", n_teams, "National Teams with Most Medals in Top 5 Sports in 2016"),
       x = "Team",
       y = "Count of Medals")

El gráfico de barras muestra los 10 equipos nacionales con la mayor cantidad de medallas en los cinco deportes principales en 2016, con las barras ordenadas de mayor a menor según el recuento total de medallas, siendo EE.UU el equipo con mas medallas y Brasil el equipo que menos medallas obtuvo.

df_2016_top_sports %>%
  group_by(Sport, Sex) %>%
  summarize(AverageWeight = mean(Weight, na.rm = TRUE)) %>%
  ggplot(aes(x = Sport, y = AverageWeight, fill = Sex)) +
  geom_bar(stat = "identity", position = position_dodge()) +
  labs(title = "Average Weight of Medal Winners by Gender in Top 5 Sports in 2016", x = "Sport", y = "Average Weight (kg)")

## `summarise()` has grouped output by 'Sport'. You can override using the
## `.groups` argument.

El gráfico de barras muestra el peso promedio de los ganadores de medallas, separado por género, en los cinco deportes principales en 2016. Cada deporte tendrá dos barras (una para cada género), facilitando la comparación visual entre géneros dentro de cada deporte, siendo los hombres los que mas medallas ganan en cada disciplina

#Tarea 1.2 Considere el conjunto de datos us_state_population.tsv utilizado en la sección de Python, para la creación del mapa coroplético de Estados Unidos. Repita el procedimiento planteado en cada ítem de esta sección para obtener el nuevo dataframe con las nuevas columnas Year y Population. Realice unión y separación utilizando las columnas State y Code.

library(readr)
url='https://raw.githubusercontent.com/lihkir/Uninorte/main/AppliedStatisticMS/DataVisualizationRPython/Lectures/Python/PythonDataSets/us_state_population.tsv'

df_us <- read_tsv(url, show_col_types = FALSE)


if (!require(tidyr)) install.packages("tidyr")

## Loading required package: tidyr

# Cargar el paquete tidyr
library(tidyr)

# Transformar el dataframe
df_us_long <- df_us %>%
  pivot_longer(
    cols = c(`2010`, `2011`, `2012`, `2013`, `2014`, `2015`, `2016`, `2017`, `2018`), 
    names_to = "Year",
    values_to = "Population"
  ) %>%
  mutate(
    Year = as.numeric(Year),             # Convertir el año a numérico
    Population = as.numeric(Population)  # Convertir la población a numérico
  )

# Ver el dataframe resultante
print(df_us_long)

## # A tibble: 459 × 4
##    State   Code   Year Population
##    <chr>   <chr> <dbl>      <dbl>
##  1 Alabama AL     2010    4785448
##  2 Alabama AL     2011    4798834
##  3 Alabama AL     2012    4815564
##  4 Alabama AL     2013    4830460
##  5 Alabama AL     2014    4842481
##  6 Alabama AL     2015    4853160
##  7 Alabama AL     2016    4864745
##  8 Alabama AL     2017    4875120
##  9 Alabama AL     2018    4887871
## 10 Alaska  AK     2010     713906
## # ℹ 449 more rows

if (!require(tidyr)) install.packages("tidyr")
library(tidyr)

df_us_wide <- pivot_wider(df_us_long, names_from = Year, values_from = Population)

# Mostrar las primeras filas del dataframe transformado
knitr::kable(head(df_us_wide))

State	Code	2010	2011	2012	2013	2014	2015	2016	2017	2018
Alabama	AL	4785448	4798834	4815564	4830460	4842481	4853160	4864745	4875120	4887871
Alaska	AK	713906	722038	730399	737045	736307	737547	741504	739786	737438
Arizona	AZ	6407774	6473497	6556629	6634999	6733840	6833596	6945452	7048876	7171646
Arkansas	AR	2921978	2940407	2952109	2959549	2967726	2978407	2990410	3002997	3013825
California	CA	37320903	37641823	37960782	38280824	38625139	38953142	39209127	39399349	39557045
Colorado	CO	5048281	5121771	5193721	5270482	5351218	5452107	5540921	5615902	5695564

library(dplyr)

# Asumiendo que tu dataframe se llama df_us
df_us_combined <- df_us_wide %>%
  mutate(StateCode = paste(State, "(", Code, ")", sep = "")) %>%
  select(StateCode, everything())

# Mostrar las primeras filas del dataframe modificado
head(df_us_combined)

## # A tibble: 6 × 12
##   StateCode  State Code  `2010` `2011` `2012` `2013` `2014` `2015` `2016` `2017`
##   <chr>      <chr> <chr>  <dbl>  <dbl>  <dbl>  <dbl>  <dbl>  <dbl>  <dbl>  <dbl>
## 1 Alabama(A… Alab… AL    4.79e6 4.80e6 4.82e6 4.83e6 4.84e6 4.85e6 4.86e6 4.88e6
## 2 Alaska(AK) Alas… AK    7.14e5 7.22e5 7.30e5 7.37e5 7.36e5 7.38e5 7.42e5 7.40e5
## 3 Arizona(A… Ariz… AZ    6.41e6 6.47e6 6.56e6 6.63e6 6.73e6 6.83e6 6.95e6 7.05e6
## 4 Arkansas(… Arka… AR    2.92e6 2.94e6 2.95e6 2.96e6 2.97e6 2.98e6 2.99e6 3.00e6
## 5 Californi… Cali… CA    3.73e7 3.76e7 3.80e7 3.83e7 3.86e7 3.90e7 3.92e7 3.94e7
## 6 Colorado(… Colo… CO    5.05e6 5.12e6 5.19e6 5.27e6 5.35e6 5.45e6 5.54e6 5.62e6
## # ℹ 1 more variable: `2018` <dbl>

# Ejemplo de separación
df_us_separated <- df_us_combined %>%
  separate(StateCode, into = c("State", "Code"), sep = "\\(", remove = FALSE) %>%
  mutate(Code = sub("\\)", "", Code))

# Mostrar las primeras filas del dataframe modificado
head(df_us_separated)

## # A tibble: 6 × 12
##   StateCode  State Code  `2010` `2011` `2012` `2013` `2014` `2015` `2016` `2017`
##   <chr>      <chr> <chr>  <dbl>  <dbl>  <dbl>  <dbl>  <dbl>  <dbl>  <dbl>  <dbl>
## 1 Alabama(A… Alab… AL    4.79e6 4.80e6 4.82e6 4.83e6 4.84e6 4.85e6 4.86e6 4.88e6
## 2 Alaska(AK) Alas… AK    7.14e5 7.22e5 7.30e5 7.37e5 7.36e5 7.38e5 7.42e5 7.40e5
## 3 Arizona(A… Ariz… AZ    6.41e6 6.47e6 6.56e6 6.63e6 6.73e6 6.83e6 6.95e6 7.05e6
## 4 Arkansas(… Arka… AR    2.92e6 2.94e6 2.95e6 2.96e6 2.97e6 2.98e6 2.99e6 3.00e6
## 5 Californi… Cali… CA    3.73e7 3.76e7 3.80e7 3.83e7 3.86e7 3.90e7 3.92e7 3.94e7
## 6 Colorado(… Colo… CO    5.05e6 5.12e6 5.19e6 5.27e6 5.35e6 5.45e6 5.54e6 5.62e6
## # ℹ 1 more variable: `2018` <dbl>

#Tarea 1.3 Utilice lo aprendido en esta sección para realizar una predicción a 7 días, del valor de las acciones de Tecnoglass. Esto es. Debe realizar

library(forecast)

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

library(tseries)
library(ggplot2)
library(knitr)

# Cargar datos
url3 <- 'https://raw.githubusercontent.com/lihkir/Data/main/TGLS.csv'
df_TG <- read.csv(url3)
df_TG$Date <- as.Date(df_TG$Date, format="%Y-%m-%d")

# Crear una serie de tiempo con la columna 'Close'
ts_TG <- ts(df_TG$Close, frequency = 252)  # 252 días de trading al año

# Medidas de tendencia central y variabilidad
summary(ts_TG)

##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   2.290   7.960   9.840   9.477  10.910  15.060

# Boxplot por año
df_TG$Year <- format(df_TG$Date, "%Y")
ggplot(df_TG, aes(x = Year, y = Close)) + geom_boxplot()

La serie de tiempo analizada muestra un rango de valores de 2.29 a 15.06, con una mediana de 9.84 y un promedio ligeramente más bajo de 9.477. Esto indica una concentración de precios alrededor de 9.84, aunque el promedio es un poco menor debido a la influencia de valores bajos en la serie. La dispersión de los datos se refleja en los cuartiles, con el 25% de los valores por debajo de 7.96 y el 75% por debajo de 10.91, lo que sugiere una distribución de precios con una variación moderada.

acf(ts_TG)

pacf(ts_TG)

adf.test(ts_TG)

## 
##  Augmented Dickey-Fuller Test
## 
## data:  ts_TG
## Dickey-Fuller = -2.6642, Lag order = 13, p-value = 0.2971
## alternative hypothesis: stationary

El Test de Dickey-Fuller Aumentado, utilizado para evaluar la estacionariedad de la serie, arroja un valor estadístico de -2.6642 y un valor p de 0.2971. Dado que el valor p es superior al umbral convencional de 0.05, no hay suficiente evidencia para rechazar la hipótesis nula de no estacionariedad. Esto indica que la serie de tiempo podría tener una tendencia o una raíz unitaria, aspectos importantes a considerar en el modelado y análisis de series de tiempo.

aic_values <- data.frame(order = character(), AIC = numeric())
for(p in 0:5) {
  for(d in 0:2) {
    for(q in 0:5) {
      model <- try(arima(ts_TG, order = c(p, d, q), method = "ML"), silent = TRUE)
      if (class(model) != "try-error") {
        aic_values <- rbind(aic_values, data.frame(order = paste(p, d, q, sep = "-"), AIC = AIC(model)))
      }
    }
  }
}

## Warning in arima(ts_TG, order = c(p, d, q), method = "ML"): possible
## convergence problem: optim gave code = 1

## Warning in arima(ts_TG, order = c(p, d, q), method = "ML"): possible
## convergence problem: optim gave code = 1

## Warning in arima(ts_TG, order = c(p, d, q), method = "ML"): possible
## convergence problem: optim gave code = 1

## Warning in arima(ts_TG, order = c(p, d, q), method = "ML"): possible
## convergence problem: optim gave code = 1

## Warning in log(s2): NaNs produced

## Warning in log(s2): NaNs produced

## Warning in log(s2): NaNs produced

## Warning in log(s2): NaNs produced

## Warning in log(s2): NaNs produced

## Warning in log(s2): NaNs produced

## Warning in log(s2): NaNs produced

## Warning in arima(ts_TG, order = c(p, d, q), method = "ML"): possible
## convergence problem: optim gave code = 1

## Warning in log(s2): NaNs produced

## Warning in arima(ts_TG, order = c(p, d, q), method = "ML"): possible
## convergence problem: optim gave code = 1

## Warning in log(s2): NaNs produced

## Warning in arima(ts_TG, order = c(p, d, q), method = "ML"): possible
## convergence problem: optim gave code = 1

## Warning in arima(ts_TG, order = c(p, d, q), method = "ML"): possible
## convergence problem: optim gave code = 1

## Warning in arima(ts_TG, order = c(p, d, q), method = "ML"): possible
## convergence problem: optim gave code = 1

# Ordenar por AIC y seleccionar el mejor modelo
aic_values <- aic_values[order(aic_values$AIC),]
best_order <- as.numeric(strsplit(aic_values[1, "order"], "-")[[1]])
best_model <- arima(ts_TG, order = best_order, method = "ML")
summary(best_model)

## 
## Call:
## arima(x = ts_TG, order = best_order, method = "ML")
## 
## Coefficients:
##           ar1
##       -0.0691
## s.e.   0.0213
## 
## sigma^2 estimated as 0.04202:  log likelihood = 364.7,  aic = -725.4
## 
## Training set error measures:
##                        ME      RMSE      MAE         MPE     MAPE     MASE
## Training set -0.001283192 0.2049447 0.120993 -0.05478491 1.436976 0.997053
##                     ACF1
## Training set 0.001525261

# Predicciones con el mejor modelo manual
forecast_manual <- forecast(best_model, h = 7)
plot(forecast_manual)

accuracy(forecast_manual)

##                        ME      RMSE      MAE         MPE     MAPE       MASE
## Training set -0.001283192 0.2049447 0.120993 -0.05478491 1.436976 0.07229024
##                     ACF1
## Training set 0.001525261

El código anterior automatiza la selección del mejor modelo ARIMA para un conjunto de datos de series de tiempo, basándose en el criterio AIC, y luego realiza y evalúa las predicciones de ese modelo. Las estadísticas sugieren que el modelo de pronóstico se ajusta razonablemente bien a los datos de entrenamiento, con un sesgo muy bajo y una precisión aceptable. La baja autocorrelación en los residuos también es un buen indicador de la calidad del ajuste del modelo.

TAREA 3

Dina Monterroza Barrios

2023-11-21

Tarea 1