spatial on rlabuonora.com

Flujo de trabajo en Git

Thu, 06 May 2021 00:00:00 +0000

Muchas veces usamos software sin entender totalmente como funciona. Cuando algo (inevitablemente) sale mal, creemos que nos merecemos los tormentos que sufrimos Read the Fucking Manual!

En este post uso una de las killer features de Git para seguir el ejemplo del capítulo de flujos de trabajo de Mastering Shiny. Esta feature son las branches (si bien otros SVNs tienen branches, Git las hace muy fáciles de usar).

Las branches permiten tener versiones independientes de el programa que estamos desarrollando. Esto me permite moverme fácilmente entre una versión y otra y experimentar interferir con el trabajo de otros miembros del equipo.

En este caso, trato de arreglar un bug, pero como mi idea original del problema se basa en un modelo mental incorrecto de la función que estoy usando, introduzco un montón de cambios innecesarios y/o contraproducentes en el proceso de aclarar ese malentendido en mi mente.

Trabajar en una branch de Git me permite experimentar y una vez que llego a la solución correcta quedarme solo con los cambios que necesito, y descartar todos los cambios que no eran necesarios para la solución final.

El ejemplo es una app con un selector para elegir la región y listar los registros del archivo de csv que pertenecen a esa región.

El ejemplo.

library(shiny)library(readr)sales <- readr::read_csv("https://raw.githubusercontent.com/hadley/mastering-shiny/master/sales-dashboard/sales_data_sample.csv")sales <- sales[c(    "TERRITORY", "ORDERDATE", "ORDERNUMBER", "PRODUCTCODE",    "QUANTITYORDERED", "PRICEEACH")]ui <- fluidPage(    selectInput("territory", "territory", choices = unique(sales$TERRITORY)),    tableOutput("selected"))server <- function(input, output, session) {    selected <- reactive(sales[sales$TERRITORY == input$territory, ])    output$selected <- renderTable(head(selected(), 10))}# Run the application shinyApp(ui = ui, server = server)

Si pegás el código en RStudio y corrés la app, ves que hay un montón de NAs. El problema está muy bien explicado en el capítulo de Hadley que mencioné antes.

Entramos al directorio de la app y chequeamos el estado de Git:

# Bashcd appgit statusgit log --oneline

## On branch master## nothing to commit, working tree clean## bff90c4 Initial commit

Solo está el commit inicial.

El problema está en esta expresión:

sales[sales$TERRITORY == input$territory, ]

Cuando sales$TERRITORY es NA, sales$TERRITORY == input$territory es NA y sales[NA] da una fila de NAs.

Vamos a usar subset para arreglarlo, pero primero hago un branch.

cd appgit checkout -b demasiados_nas

## Switched to a new branch 'demasiados_nas'

cd appcp app_1.R app.R

cd appgit statusgit diff

## On branch demasiados_nas## Changes not staged for commit:##   (use "git add <file>..." to update what will be committed)##   (use "git restore <file>..." to discard changes in working directory)##  modified:   app.R## ## no changes added to commit (use "git add" and/or "git commit -a")## diff --git a/app.R b/app.R## index 7ef3837..27c80bb 100644## --- a/app.R## +++ b/app.R## @@ -12,7 +12,7 @@ ui <- fluidPage(##      tableOutput("selected")##  )##  server <- function(input, output, session) {## -    selected <- reactive(sales[sales$TERRITORY == input$territory, ])## +    selected <- reactive(subset(sales, sales$TERRITORY == input$territory))##      output$selected <- renderTable(head(selected(), 10))##  }##

Acá hay más información sobre como leer esta salida. Muestra 7 líneas a partir de la línea 12. Las que empiezan con - son la versión anterior, y la que empieza con + la nueva. Commiteo el cambio y sigo.

cd appgit add app.Rgit commit -m "Usa subset en vez de =="

## [demasiados_nas 5a2006c] Usa subset en vez de ==##  1 file changed, 1 insertion(+), 1 deletion(-)

Pero ahora me encuentro con otro problema. Como dice Hadley, los NA son infecciosos. Eso implica que sales$TERRITORY == NA es siempre NA, por lo si elegimo NA en el dropdown vamos a subsetear por un vector de NA:

subset(sales, TERRITORY == NA)

## # A tibble: 0 x 6## # … with 6 variables: TERRITORY <chr>, ORDERDATE <chr>, ORDERNUMBER <dbl>,## #   PRODUCTCODE <chr>, QUANTITYORDERED <dbl>, PRICEEACH <dbl>

Para solucionar eso, podemos usar %in%:

subset(sales, TERRITORY %in% c("EMEA"))

## # A tibble: 1,407 x 6##    TERRITORY ORDERDATE       ORDERNUMBER PRODUCTCODE QUANTITYORDERED PRICEEACH##    <chr>     <chr>                 <dbl> <chr>                 <dbl>     <dbl>##  1 EMEA      5/7/2003 0:00         10121 S10_1678                 34      81.4##  2 EMEA      7/1/2003 0:00         10134 S10_1678                 41      94.7##  3 EMEA      11/11/2003 0:00       10180 S10_1678                 29      86.1##  4 EMEA      11/18/2003 0:00       10188 S10_1678                 48     100  ##  5 EMEA      1/15/2004 0:00        10211 S10_1678                 41     100  ##  6 EMEA      7/23/2004 0:00        10275 S10_1678                 45      92.8##  7 EMEA      9/30/2004 0:00        10299 S10_1678                 23     100  ##  8 EMEA      10/15/2004 0:00       10309 S10_1678                 41     100  ##  9 EMEA      11/24/2004 0:00       10341 S10_1678                 41     100  ## 10 EMEA      2/3/2005 0:00         10375 S10_1678                 21      34.9## # … with 1,397 more rows

Commiteamos el resultado.

cd appgit add app.Rgit commit -m "Usa %in% en vez de == en subset"

## [demasiados_nas 41b2365] Usa %in% en vez de == en subset##  1 file changed, 1 insertion(+), 1 deletion(-)

Y mergear a master

cd appgit checkout mastergit merge demasiados_nasgit log --all --decorate --oneline --graph

## Switched to branch 'master'## Updating bff90c4..41b2365## Fast-forward##  app.R | 2 +-##  1 file changed, 1 insertion(+), 1 deletion(-)## * 41b2365 (HEAD -> master, demasiados_nas) Usa %in% en vez de == en subset## * 5a2006c Usa subset en vez de ==## * bff90c4 Initial commit

Plot Twist

Bueno acá viene lo mejor, en el archivo original, NA no es NA de R, sino “NA” de North America. 🤦. Estuvimos todo el tiempo atrás de la pista incorrecta. En realidad sales no tiene NA en la variable TERRITORY.

La solución correcta es especificar los NAs en la llamada a read_csv, para que no confunda “NA” con NA.

sales <- readr::read_csv("https://raw.githubusercontent.com/hadley/mastering-shiny/master/sales-dashboard/sales_data_sample.csv", na = "")

Pero ahora tenemos toda nuestra app plagada de cambios que hicimos cuando no entendíamos el problema!

Vamos a usar Git para arreglar este problema. Usammos git reset para volver master dos commits para atrás. Así, master apunta al commit donde empezó el problema.

cd appgit reset --hard HEAD~2git checkout -b no_hay_nas_en_territory

## HEAD is now at bff90c4 Initial commit## Switched to a new branch 'no_hay_nas_en_territory'

Hacer los cambios

cd appgit statusgit diff

## On branch no_hay_nas_en_territory## Changes not staged for commit:##   (use "git add <file>..." to update what will be committed)##   (use "git restore <file>..." to discard changes in working directory)##  modified:   app.R## ## no changes added to commit (use "git add" and/or "git commit -a")## diff --git a/app.R b/app.R## index 7ef3837..387e0c9 100644## --- a/app.R## +++ b/app.R## @@ -1,7 +1,7 @@##  library(shiny)##  library(readr)##  ## -sales <- readr::read_csv("https://raw.githubusercontent.com/hadley/mastering-shiny/master/sales-dashboard/sales_data_sample.csv")## +sales <- readr::read_csv("https://raw.githubusercontent.com/hadley/mastering-shiny/master/sales-dashboard/sales_data_sample.csv", na = "")##  sales <- sales[c(##      "TERRITORY", "ORDERDATE", "ORDERNUMBER", "PRODUCTCODE",##      "QUANTITYORDERED", "PRICEEACH"

La línea que había que cambiar era la 7!

cd appgit add app.Rgit commit -m "Agrega argumento na a la llamada a read_csv"git log --all --decorate --oneline --graph

## [no_hay_nas_en_territory fbc196e] Agrega argumento na a la llamada a read_csv##  1 file changed, 1 insertion(+), 1 deletion(-)## * fbc196e (HEAD -> no_hay_nas_en_territory) Agrega argumento na a la llamada a read_csv## | * 41b2365 (demasiados_nas) Usa %in% en vez de == en subset## | * 5a2006c Usa subset en vez de ==## |/  ## * bff90c4 (master) Initial commit

Ahora tengo que mergeamos estos estos cambios con master.

cd appgit checkout mastergit merge no_hay_nas_en_territorygit log --all --decorate --oneline --graph

## Switched to branch 'master'## Updating bff90c4..fbc196e## Fast-forward##  app.R | 2 +-##  1 file changed, 1 insertion(+), 1 deletion(-)## * fbc196e (HEAD -> master, no_hay_nas_en_territory) Agrega argumento na a la llamada a read_csv## | * 41b2365 (demasiados_nas) Usa %in% en vez de == en subset## | * 5a2006c Usa subset en vez de ==## |/  ## * bff90c4 Initial commit

Feriados en Uruguay

Sat, 06 Feb 2021 00:00:00 +0000

El primero de Mayo conmemoramos el días de los trabajadores. Lamentablemente, este año nos cayó sábado, por lo que nos perdimos el día libre. En este post uso lubridate para visualizar este lamentable fenómeno de la vida labora de este país.

Wikipedia tiene una tabla con los feriados en Uruguay. Traté de scrapearla directo con rvest pero la última columna de la tabla da problemas así que copié los datos a mano.

library(tidyverse)feriados_tabla <- tibble::tribble(  ~fecha,       ~nombre,      "1 de enero", "Año Nuevo",  "6 de enero", "Día de los Niños",  "19 de abril", "Desembarco de los Treinta y Tres Orientales",  "1 de mayo",    "Día de los Trabajadores",  "18 de mayo",  "Batalla de Las Piedras",  "19 de junio", "Natalicio de Artigas",  "18 de julio", "Jura de la Constitución",  "25 de agosto","Declaratoria de la Independencia",   "12 de octubre", "Día de la Raza",  "2 de noviembre", "Día de los Difuntos",  "25 de diciembre", "Día de la Familia") %>%   # Sacamos " de" para que no moleste a lubridate  mutate(fecha = str_replace(fecha, " de", ""))

Parsear fechas (en español).

En Uruguay hay 11 feriados. Para convertirlas en fechas, usamos expand_grid para combinar las fechas con todos los años entre 2015 y 2030, y para parsear el texto de la fecha usamos readr::parse_date. La función wday nos da el día de la semana en que cae determinada fecha.

Para que parse_date entienda bien el texto de los meses (enero, febrero, etc.) especifico el argumento locale=locale("es"). Para que wday nos de el día de la semana de cada fecha, hay que setear la locale del sistema con Sys.setlocale.

library(lubridate)Sys.setlocale("LC_TIME", "Spanish_Spain.1252")

## [1] "Spanish_Spain.1252"

feriados <- expand_grid(t=2017:2032, fecha=feriados_tabla$fecha) %>%   left_join(feriados_tabla, by="fecha") %>%   mutate(fecha = paste(fecha, t)) %>%   mutate(fecha=parse_date(fecha, "%d %B %Y", locale=locale("es"))) %>%   mutate(wdia=wday(fecha, label=TRUE, abbr=FALSE)) %>%   mutate(wdia = stringr::str_to_title(wdia))

Visualización

Ahora una visualización bien simple para ver que nos deparan los próximos años:

feriados %>%   mutate(fin_de_semana = wdia %in% c("Sábado", "Domingo")) %>%   count(t, fin_de_semana) %>%   ggplot(aes(t, n, fill=fin_de_semana)) +   geom_col() +   scale_x_continuous(breaks=2017:2032) +   theme(legend.position = "bottom")

Parecería que después de dos años medios 2021 y 2022, en 2023 vamos a tener muy pocos feriados que caen fin de semana y 2024 va a ser nefasto. Quiero saber dos cosas: ¿cuáles son los feriados que caen juntos?

¿Cómo juegan los años bisiestos?

Los feriados van cambiando de a un día en los años normales y de a dos los años bisiestos:

feriados %>%   filter(nombre=="Año Nuevo")

## # A tibble: 16 x 4##        t fecha      nombre    wdia     ##    <int> <date>     <chr>     <chr>    ##  1  2017 2017-01-01 Año Nuevo Domingo  ##  2  2018 2018-01-01 Año Nuevo Lunes    ##  3  2019 2019-01-01 Año Nuevo Martes   ##  4  2020 2020-01-01 Año Nuevo Miércoles##  5  2021 2021-01-01 Año Nuevo Viernes  ##  6  2022 2022-01-01 Año Nuevo Sábado   ##  7  2023 2023-01-01 Año Nuevo Domingo  ##  8  2024 2024-01-01 Año Nuevo Lunes    ##  9  2025 2025-01-01 Año Nuevo Miércoles## 10  2026 2026-01-01 Año Nuevo Jueves   ## 11  2027 2027-01-01 Año Nuevo Viernes  ## 12  2028 2028-01-01 Año Nuevo Sábado   ## 13  2029 2029-01-01 Año Nuevo Lunes    ## 14  2030 2030-01-01 Año Nuevo Martes   ## 15  2031 2031-01-01 Año Nuevo Miércoles## 16  2032 2032-01-01 Año Nuevo Jueves

El primero de Enero cayó Viernes en 2016, y cómo 2016 fue bisiesto, en 2017 cayó domingo. En 2018 cayó Lunes, 2019 Martes, etc. El día de los Trabajadores es después del 29 de Febrero, por lo que los años bisiestos lo afectan diferente.

feriados %>%   filter(nombre=="Día de los Trabajadores")

## # A tibble: 16 x 4##        t fecha      nombre                  wdia     ##    <int> <date>     <chr>                   <chr>    ##  1  2017 2017-05-01 Día de los Trabajadores Lunes    ##  2  2018 2018-05-01 Día de los Trabajadores Martes   ##  3  2019 2019-05-01 Día de los Trabajadores Miércoles##  4  2020 2020-05-01 Día de los Trabajadores Viernes  ##  5  2021 2021-05-01 Día de los Trabajadores Sábado   ##  6  2022 2022-05-01 Día de los Trabajadores Domingo  ##  7  2023 2023-05-01 Día de los Trabajadores Lunes    ##  8  2024 2024-05-01 Día de los Trabajadores Miércoles##  9  2025 2025-05-01 Día de los Trabajadores Jueves   ## 10  2026 2026-05-01 Día de los Trabajadores Viernes  ## 11  2027 2027-05-01 Día de los Trabajadores Sábado   ## 12  2028 2028-05-01 Día de los Trabajadores Lunes    ## 13  2029 2029-05-01 Día de los Trabajadores Martes   ## 14  2030 2030-05-01 Día de los Trabajadores Miércoles## 15  2031 2031-05-01 Día de los Trabajadores Jueves   ## 16  2032 2032-05-01 Día de los Trabajadores Sábado

Esto implica que los años bisiestos cambian la distribución de feriados por día, y esta queda estable y se mueve hacia la derecha cada año hasta el próximo año bisiesto:

dias <- c("Domingo", "Lunes", "Martes",          "Miércoles", "Jueves", "Viernes",          "Sábado")feriados %>%   mutate(wdia=str_sub(wdia, 1, 3)) %>%   count(t, wdia) %>%   mutate(wdia=factor(wdia, levels=str_sub(dias, 1, 3))) %>%   ggplot(aes(wdia, n)) +  geom_col() +  facet_wrap(~t, ncol = 4) +   guides(fill="none")

Visualizando Homicidios

Tue, 28 Jul 2020 00:00:00 +0000

Este es mi primer post sobre tidy tuesday. Este proyecto, creado por Thomas Mock, publica un data set todo los martes y invita a los participantes a postear una visualización usándolo.

Para esta semana se publicaron tres juegos de datos provenientes de este blog post. La idea es mostrar el poder de ggplot para reproducir visualizaciones que encontró el autor por ahí.

Homicidios

El primer dataset tiene la tasa de homicidios en 6 países del G-8:

homicidios <- read_csv(here("static", "data", "tidytuesday","international_murders.csv"))head(homicidios)

## # A tibble: 6 x 4##   country count label code ##   <chr>   <dbl> <chr> <chr>## 1 US       3.2  3.2   us   ## 2 ITALY    0.71 0.71  it   ## 3 CANADA   0.5  0.5   ca   ## 4 UK       0.1  0.1   gb   ## 5 JAPAN    0    0     jp   ## 6 GERMANY  0.2  0.2   de

Este es el gráfico original:

grafico original

Revisando la fuente de los datos encontré esta app, sería interesante comparar a Uruguay en estos números, pero los datos no coinciden.

El diseño del gráfico es un bar chart, pero le agrega las banderas de los países y las tasas sobre las barras.

Este es el gráfico base con títulos:

# plot basicohomicidios %>%   ggplot(aes(country, count)) +  geom_col() +   labs(x="", y="# de homicidios con armas de fuego \n cada 100,000 habitantes",        caption = "Fuente: \nUNODC Homicide Statistics",       title = "Tasa de Homicidios en países del G-8.")

Como mapeamos el eje x a una columna de texto, ggplot la convierte a un factor. El orden en el que aparecen los países en el eje depende de los niveles del factor, por defecto es alfabético:

levels(factor(homicidios$country))

## [1] "CANADA"  "FRANCE"  "GERMANY" "ITALY"   "JAPAN"   "RUSSIA"  "UK"     ## [8] "US"

Esto es algo que puede confundir a alguien que no tiene experiencia trabajando con factores: el orden de los niveles es independiente del orden en que aparecen en el data frame.

En este caso, el orden del factor es alfabético (Canadá, Francia, etc.), y el data frame está ordenado por la tasa de homicidios (descendente): US, Italia, Canadá.

Para controlar el orden en el que aparecen los países ordenar las etiquetas, usamos una función muy útil de forcats: fct_inorder. Esta función reordena los niveles del factor para que coincida con el orden en el que aparecen en el data-frame:

homicidios_2 <- homicidios %>%   arrange(-count) %>%   mutate(country_ordenado = fct_inorder(country))levels(homicidios_2$country_ordenado)

## [1] "US"      "ITALY"   "CANADA"  "GERMANY" "UK"      "FRANCE"  "JAPAN"  ## [8] "RUSSIA"

Para la versión final, agrego las etiquetas del texto con geom_text (nudge_y me permite ajustar el texto un poco para que no toque las barras).

También descubrí ggflags, que nos da una función geom_flag con el aes country para especificar el país. La coordenada y de todas las banderas la fijo en -.4.

# install_github("rensa/ggflags")library(ggflags)library(ggthemes)# theme_economist# agrego texto sobre las columnas con geom_text y nudge_yplot <- homicidios %>%   arrange(-count) %>%   mutate(country = fct_inorder(country)) %>% # fct_inorder  ggplot(aes(country, count)) +   geom_col(fill="darkred") +   geom_flag(y = -.4, aes(country = code), size = 12) + # geom_flag  geom_text(aes(label = if_else(country == "RUSSIA", "S/D", as.character(count))),                 nudge_y = .15) + # nudge, label  scale_x_discrete(labels=NULL) + # remove labels from x-axis  labs(x="", y="# de homicidios con armas de fuego \n cada 100,000 habitantes",        caption = "Fuente: \nUNODC Homicide Statistics",       title = "Tasa de Homicidios en países del G-8") +   theme_economist() +  theme(    axis.line.x = element_blank(),    axis.ticks.x = element_blank(),    plot.caption = element_text(vjust = 170) # mover caption  )

plot

Un gráfico de barras anotado

Thu, 28 May 2020 00:00:00 +0000

En este posteo hago un gráfico de barras con anotaciones para mostrar un problema en el sistema de exámenes de las escuelas de Nueva York.

Diplopma Regents

Los exámenes Regents son una serie de tests estándar de temas de secundaria en el estado de Nueva York. Este set de datos muestra las notas de exámenes en varias materias. Lo que llama la atención es que hay un gran número de examenes con 65, la nota mínima de aprobación.

nyc_regents <-  read_csv(here("static", "data", "tidytuesday","nyc_regents.csv"))

## Parsed with column specification:## cols(##   score = col_double(),##   integrated_algebra = col_double(),##   global_history = col_double(),##   living_environment = col_double(),##   english = col_double(),##   us_history = col_double()## )

# reshapenyc_reshape <- nyc_regents %>%   gather(k="subject", v="tests", -score) %>%   group_by(score) %>%   summarize(tests = sum(tests, na.rm = TRUE))

## `summarise()` ungrouping output (override with `.groups` argument)

# plot basicog <- ggplot(nyc_reshape, aes(score, tests)) +   geom_col()# Textog +   labs(caption = "Fuente: New York City Department of Education",       title = "Salvar Raspando",       subtitle = "2010 Regents scores on Algebra, \nGlobal History, Biology, English & US History",        y = "", x = "")

## Warning: Removed 1 rows containing missing values (position_stack).

# Ejes# Scales en el grammar of graphics# Customizando los ejes con scale_x_* y scale_y_*# le pasamos una función a labels# expand es contraintuitivamente importante# labels, breaks, expandg +     labs(caption = "Source: New York City Department of Education",       title = "Scraping By",       subtitle = "2010 Regents scores on Algebra, \nGlobal History, Biology, English & US History",        y = "", x = "") +   scale_x_continuous(breaks = seq(0, 100, 5), expand = expand_scale(add = c(0, 0))) +   scale_y_continuous(position = "right",                      labels = scales::number_format(big.mark = ","), # function                     breaks = c(1e4, 2e4, 3e4))

## Warning: `expand_scale()` is deprecated; use `expansion()` instead.## Warning: Removed 1 rows containing missing values (position_stack).

# Themeg + labs(caption = "Fuente: New York City Department of Education",       title = "Salvar Raspando",       subtitle = "Notas 2010 Regents en Álgebra, \nHistoria, Biología, e Inglés",       y = "", x = "") +   scale_x_continuous(breaks = seq(0, 100, 5), expand = expand_scale(add = c(0, 0))) +   scale_y_continuous(position = "right",                      labels = scales::number_format(big.mark = ","), # function                     breaks = c(1e4, 2e4, 3e4)) +   theme_minimal() +   theme(    panel.grid.major.y = element_line(linetype = "dashed", color = "gray50"),    panel.grid.major.x = element_blank(),    panel.grid.minor = element_blank(),    axis.text.y = element_text(vjust = 1.5),    axis.text.x = element_text(vjust = 7),    plot.margin = margin(unit(c(20, 20, 20, 20), "cm"))  )

## Warning: `expand_scale()` is deprecated; use `expansion()` instead.## Warning: Removed 1 rows containing missing values (position_stack).

# color a las columnasggplot(nyc_reshape, aes(score, tests)) +   geom_col(color = "black", fill = "#C4843C") +   labs(caption = "Fuente: New York City Department of Education",       title = "Salvar Raspando",       subtitle = "Notas 2010 Regents en Álgebra, \nHistoria, Biología, e Inglés",       y = "", x = "") +   scale_x_continuous(breaks = seq(0, 100, 5), expand = expand_scale(add = c(0, 0))) +   scale_y_continuous(position = "right",                      labels = scales::number_format(big.mark = ","), # function                     breaks = c(1e4, 2e4, 3e4)) +   theme_minimal() +   theme(    panel.grid.major.y = element_line(linetype = "dashed", color = "gray50"),    panel.grid.major.x = element_blank(),    panel.grid.minor = element_blank(),    axis.text.y = element_text(vjust = 1.5),    axis.text.x = element_text(vjust = 7),    plot.margin = margin(unit(c(20, 20, 20, 20), "cm"))  )

## Warning: `expand_scale()` is deprecated; use `expansion()` instead.## Warning: Removed 1 rows containing missing values (position_stack).

# Todo juntonyc_regents %>%   gather(k="k", v="v", -score) %>%   group_by(score) %>%   summarize(v = sum(v, na.rm = TRUE)) %>%   ggplot(aes(score, v)) +  annotate("rect", xmin = 65, xmax=Inf, ymin=0, ymax=Inf, alpha = 0.6, fill = "grey80") +   annotate("text",            label = "Mìnimo para diploma Regents",           x = 45, y = 2.5e4) +   annotate("segment", arrow=arrow(type = "closed", length = unit(0.2, "cm")), x=50, y=2.8e4, xend=64, yend=3.2e4) +   geom_col(color = "black", fill = "#C4843C") +   theme_minimal() +   scale_x_continuous(breaks = seq(0, 100, 5), expand = expand_scale(add = c(0, 0))) +   scale_y_continuous(position = "right",                      labels = scales::number_format(big.mark = ","), # function                     breaks = c(1e4, 2e4, 3e4)) +   labs(caption = "Fuente: New York City Department of Education",       title = "Salvar Raspando",       subtitle = "Notas Regents 2010 en Álgebra, \nHistoria, Biología, e Inglés",       y = "", x = "") +  labs(y = "", x = "") +  theme(    panel.grid.major.y = element_line(linetype = "dashed", color = "gray50"),    panel.grid.major.x = element_blank(),    panel.grid.minor = element_blank(),    axis.text.y = element_text(vjust = 1.5),    axis.text.x = element_text(vjust = 7),    plot.margin = margin(unit(c(20, 20, 20, 20), "cm")) #   )

## `summarise()` ungrouping output (override with `.groups` argument)

## Warning: `expand_scale()` is deprecated; use `expansion()` instead.## Warning: Removed 1 rows containing missing values (position_stack).

El estilo de Metallica a lo largo de los discos

Sun, 26 Jan 2020 00:00:00 +0000

Para este post de #tidytuesday usé la API de spotify para bajar datos sobre la música de Metallica.

Este es el código para bajar los datos y la tapa de los discos:

library(spotifyr)library(tidyverse)library(lubridate)METALLICA_ID <- "2ye2Wgw4gimLv2eAKyk1NB"metallica_albums <- get_artist_albums(id=METALLICA_ID,                                      include_groups = "album",                                      limit = 50) %>%  slice(6, 11, 13, 17, 19, 21, 26, 30, 35, 39, 43) %>%   mutate(release_year = year(as_date(release_date)))metallica_albums$cover_url <- metallica_albums$images %>%   purrr::map("url") %>%   purrr::map(3)metallica_albums <- metallica_albums %>%   select(album_name=name, album_id=id, release_year, cover_url)   get_album_tracks <- function(album_id, album_name) {  # get track name, track id & album name (add all album.level data here)  album <- get_album(id=album_id)  tibble(track_name=album$tracks$items$name,         track_id   = album$tracks$items$id,         album_name = album_name)}get_track_info <- function(track_id, track_name, album_name) {  features <- get_track_audio_features(id=track_id)  mutate(features,          album_name = album_name,         track_name = track_name) %>%     select(album_name, track_name, danceability:tempo, duration_ms)}metallica_tracks <- metallica_albums %>%   pmap(function(...) {    current <- tibble(...)    get_album_tracks(current$album_id, current$album_name)  }) %>%   map(purrr::transpose) %>%   flatten %>%   map_df(function(x) {    get_track_info(x$track_id, x$track_name, x$album_name)  }) metallica_tracks_df <- metallica_tracks %>%   left_join(metallica_albums) %>%   mutate(track_name = str_remove(track_name, " - Remastered")) %>%   mutate(track_name = str_remove(track_name, "\\(Remastered\\)")) %>%  mutate(album_name = str_remove(album_name, "\\(Remastered\\)")) %>%   group_by(album_name) %>%   mutate(track_num = row_number()) %>%   arrange(release_year, track_num)dir.create('data')saveRDS(metallica_tracks_df, file="data/metallica.rds")download_cover <- function(url, release_year) {  file_name <- glue::glue("{release_year}.jpg")  dest <- file.path("covers", file_name)  download.file(url, destfile=dest)}dir.create('covers')purrr::walk2(metallica_albums$cover_url,            metallica_albums$release_year,             download_cover)

Y este es el código para crear el gráfico:

# Evolution of song tempolibrary(tidyverse)library(ggplot2)library(jpeg)library(grid)library(ggdark)library(showtext)library(ggrepel)theme_set(dark_theme_grey())# Agregar fuentefont_add_google("Metal Mania", "metal")showtext_auto()metallica <- readRDS("./data/metallica.rds")# metallica$track_name <- fct_inorder(factor(metallica$track_name))metallica$album_name <- fct_inorder(factor(metallica$album_name))fast_songs <- c("Holier Than Thou",                 "My Apocalypse",                 "The Four Horsemen")highligts <- metallica %>%   filter(track_name %in%  fast_songs)# Gráfico de base.tempo <- metallica %>%   ggplot(aes(album_name, tempo, group = 1)) +   scale_x_discrete(breaks = NULL, expand=c(0.1, 0)) +  scale_y_continuous(limits = c(60, 220)) +  geom_point() +  geom_text_repel(data = highligts,                   aes(label=track_name),                   nudge_y = 10,                  nudge_x = .2,                  color="white", size = 3) +  geom_smooth(se=FALSE) +   guides(color=FALSE) +   labs(title="Metallica",        subtitle = "New albums are almost as fast as the early ones.",        caption  = "Data: Spotify",       x="Album", y="Tempo (bpm)")# Agregar las tapas de los discos como imágenes.covers <- list.files('covers', full.names = TRUE) %>%   purrr::map(readJPEG) %>%   purrr::map(rasterGrob, interpolate=TRUE)y_coord_cover <-  60y_offset <- 10.5for (i in seq_along(covers)) {  tempo <- tempo +  annotation_custom(grob=covers[[i]], xmin=i-1+.5, xmax=i+.5, ymin=y_coord_cover, ymax=y_coord_cover+y_offset)}tempo +   theme(    text = element_text(family="metal"),    plot.title = element_text(hjust = .5),    plot.subtitle = element_text(hjust=.5)  ) +  ggsave("metallica_tempo.png")

Vacunas

Thu, 28 Nov 2019 00:00:00 +0000

Este es mi primer post sobre tidy tuesday. Este proyecto, creado por Thomas Mock, publica un data set todo los martes y invita a los participantes a postear una visualización usándolo.

Para esta semana se publicaron tres juegos de datos provenientes de este blog post. La idea es mostrar el poder de ggplot para reproducir visualizaciones que encontró el autor por ahí.

El efecto de la vacuna contra el sarampión

# Measels# devtools::install_github("rafalab/dslabs")library(dslabs)diseases <- dslabs::us_contagious_diseases# Research!jet.colors <- colorRampPalette(c("#F0FFFF", "cyan", "#007FFF", "yellow", "#FFBF00", "orange", "red", "#7F0000"), bias = 2.25)diseases %>%   filter(disease == "Measles") %>%   filter(!state %in% c("Hawaii", "Alaska")) %>%   mutate(rate = count / population * 10000 * 52 / weeks_reporting) %>%   mutate(state = reorder(state, desc(state))) %>%   ggplot(aes(year, state, fill=rate)) +   geom_tile(color = "white") +   scale_fill_gradientn(colors = jet.colors(16), na.value = "white", name = "Tasa") + ## research!  scale_x_continuous(expand = c(0, 0)) +   labs(x = "", y = "", title = "Sarampión", subtitle = "Enfermos cada 10000 habitantes") +  geom_vline(xintercept = 1963) +   annotate(geom = "text", x=1970, y = 50, label = "Introducción de la vacuna") +   theme_minimal() +   coord_cartesian(clip = 'off') +   theme(    legend.position = "bottom",  )

Personas y lugares en las novelas de Mario Vargas Llosa

Tue, 15 Oct 2019 00:00:00 +0000

spacyR es una interfaz para usar una librería de NLP de python -spacy- desde R. En este post exploro un poco como detectar nombres de personas y de lugares usando esta librería para analizar cuáles son los personajes principales y los lugares más mencionados en cada capítulo de Las Travesuras de la Niña Mala.

Corpus

A partir del texto de las novelas (en inglés), creo un data frame con una línea por fila y columnas con el texto y el capítulo al que corresponde cada línea.

bad_girl_url <- "https://raw.githubusercontent.com/rlabuonora/mvll_nlp/master/txt/bad_girl.txt"bad_girl_raw <- readLines(bad_girl_url, encoding = "UTF-8")bad_girl_lines <- tibble(text = bad_girl_raw) %>%  mutate(chapter = str_detect(text, "\\d{1,2}.?$"), # Detect 1, 2, 3 ..7         chapter = cumsum(chapter)) %>%  # cumsum o fill  tibble::rowid_to_column(var="doc_id")

Spacy

Una vez que importé el texto de la novela, uso spacy_parse para detectar las named entities. Una named entity es una entidad que aparece mencionada en el texto.

Spacy usa un algoritmo para detectar cuáles tokens en el texto pertenecen a una entidad y de que tipo de entidad se trata.

bad_girl_parsed <- spacy_parse(bad_girl_lines$text, lemma = FALSE, entity = TRUE, nounphrase = TRUE)ents <- entity_extract(bad_girl_parsed, type = "all") %>%   mutate(doc_id = as.numeric(str_extract(doc_id, "\\d{1,4}"))) %>%   left_join(select(bad_girl_lines, chapter, doc_id))head(ents)

##   doc_id sentence_id                  entity entity_type chapter## 1      1           1                       1    CARDINAL       1## 2     10           1       a_fabulous_summer        DATE       1## 3     10           2             Pérez_Prado      PERSON       1## 4     10           2                  twelve    CARDINAL       1## 5     10           2                Carnival      PERSON       1## 6     10           2 the_Lawn_Tennis_of_Lima     PRODUCT       1

El data frame ents tiene un doc_id que nos permite vincular estos resultados con el input original (donde tenemos a què capítulo pertence cada frase, el nombre de la entidad detectada, y el tipo de entidad detectada.)

Visualización

Para la visualizión del resultado, veamos cuáles son las entidades de tipo persona y lugar más nombradas en cada capítulo:

personas_por_capitulo <- ents %>%   filter(entity_type  == "PERSON") %>%   filter(!entity %in% c("’s")) %>% # sacar entidades mal clasificadas  group_by(chapter, entity) %>%   summarize(mentions = n()) %>%   arrange(chapter, -mentions) %>%   top_n(5, mentions) # Los 5 personajes más mencionadospersonas_por_capitulo %>%   ggplot(aes(entity, mentions, fill = entity)) +  geom_col() +  coord_flip() +  facet_wrap(~chapter, scales="free_y") +   guides(fill=FALSE) +  labs(y="Menciones", x="Personajes",        title = "Travesuras de la Niña Mala",       subtitle="Personajes más mencionados por capítulo")

Ahora hacemos lo mismo pero nos quedamos con las entidades de tipo GPE: (Geopolitical Entity).

lugares_por_capitulo <- ents %>%   filter(entity_type  == "GPE") %>% # GPE => Geopolitical Entity  filter(!entity %in% c("Salomón", "Alberta", "’s",                         "Mitsuko", "Elena")) %>% # Sacar ents mal clasificadas  group_by(chapter, entity) %>%   summarize(mentions = n()) %>%   arrange(chapter, -mentions) %>%   top_n(5, mentions)lugares_por_capitulo %>%   ggplot(aes(entity, mentions, fill = entity)) +  geom_col() +  coord_flip() +  facet_wrap(~chapter, scales="free_y") +   guides(fill=FALSE) +  labs(y="Menciones", x="Lugares",        title = "Travesuras de la Niña Mala",       subtitle="Lugares más mencionados por capítulo")

Prediciendo Precios de Propiedades

Sun, 16 Jun 2019 00:00:00 +0000

En este post estimo tres modelos de regresión para predecir el precio de venta de una propiedad inmobiliaria usando scikit-learn. Las columnas disponibles incluyen 80 columnas con información sobre la localización de las propiedades, su estructura y estado de conservación, su localización y la fecha y condiciones de la venta.

Dado que la variable objetivo es continua, uso 3 modelos de regresión: regresión lineal sin regularización, regresión Ridge y regresión Lasso.

# Importar módulosimport pandas as pdimport numpy as np# Leer los datos casas = pd.read_csv("../../public/data/precios_casas/train.csv")# Primeras filasprint(casas.head())

##    Id  MSSubClass MSZoning  ...  SaleType  SaleCondition SalePrice## 0   1          60       RL  ...        WD         Normal    208500## 1   2          20       RL  ...        WD         Normal    181500## 2   3          60       RL  ...        WD         Normal    223500## 3   4          70       RL  ...        WD        Abnorml    140000## 4   5          60       RL  ...        WD         Normal    250000## ## [5 rows x 81 columns]

Cantidad de filas y columnas:

print(casas.shape)

## (1460, 81)

Datos faltantes

Los datos faltantes son un problema habitual en este tipo de tarea. El primer paso para analizarlo es cuantificar cuantos casos tienen datos faltantes en cada columna:

print(casas.isnull().any().sum())

## 19

continuas = ["LotArea",      "GrLivArea",   "GarageArea",             "WoodDeckSF",   "OpenPorchSF", "EnclosedPorch",             "3SsnPorch",    "ScreenPorch",             "LowQualFinSF", "LotFrontage",             "1stFlrSF",     "2ndFlrSF"]

Análisis Exploratorio

Variable objetivo: SalePrice

La variable a predecir es el precio de venta de la propiedad. Es continua y no tiene missings. La propiedad promedio se vendió en $ 180.920, la más barata salió $ 34.900 y la más cara $755.000.

casas[["SalePrice"]].describe()

##            SalePrice## count    1460.000000## mean   180921.195890## std     79442.502883## min     34900.000000## 25%    129975.000000## 50%    163000.000000## 75%    214000.000000## max    755000.000000

Tiene distribución asimétrica, con la cola larga a la derecha (es más probable que una casa sea más cara que más barata que el promedio). Esta asimetría hace que sea conveniente normalizarla para modelarla.

Defino una función helper_curtosis para anotar los gráficos de asimetría:

def helper_curtosis(x):  # Texto sobre la curtosis de x  # para agregar al gráfico  sk = skew(x)  sk_pval = skewtest(x)[0]  return f'Curtosis:\n{sk:.2f} ({sk_pval:.3f})'

import matplotlib.pyplot as pltimport seaborn as snsimport scipy.stats as statsfrom scipy.stats import skew, skewtestfig, ax = plt.subplots(1, 2, figsize=(12,4))# SalePrice sin transformarx = casas["SalePrice"]sns.distplot(x, kde=False, fit=stats.norm, ax=ax[0])ax[0].text(400000, 0.000005, helper_curtosis(x), fontsize = 14)#ax[0].set_title("SalePrice")# SalePrice transformadalog1_x = np.log1p(casas["SalePrice"])sns.distplot(log1_x, kde=False, fit=stats.norm, ax=ax[1])ax[1].text(12.6, 0.6, helper_curtosis(log1_x), fontsize = 14)ax[1].set_xlabel("log(1+SalePrice)")_ = fig.suptitle("La transformación x = log(1+x) corrige la asimetría en SalePrice", fontsize=16)

El test de curtosis es una prueba estadística para determinar si la distibución es simétrica. En la variable original rechazamos que la distribución sea simétrica y en la transformada con log(1+x) no rechazamos la hipótesis nula de que la distribución es simétrica.

# Correlaciones con SalePricecorr_sales_price = casas.corr()["SalePrice"]# Solo las mayores que 0.63 ordenadas descendiendocorrs_altas = corr_sales_price[corr_sales_price > 0.4].sort_values(ascending = False)print(corrs_altas)

## SalePrice       1.000000## OverallQual     0.790982## GrLivArea       0.708624## GarageCars      0.640409## GarageArea      0.623431## TotalBsmtSF     0.613581## 1stFlrSF        0.605852## FullBath        0.560664## TotRmsAbvGrd    0.533723## YearBuilt       0.522897## YearRemodAdd    0.507101## GarageYrBlt     0.486362## MasVnrArea      0.477493## Fireplaces      0.466929## Name: SalePrice, dtype: float64

Calculamos las correlaciones de la variables objetivo con el resto de las variables para determinar en qué variables enfocarnos:

La calidad de la casa (OverallQual), el metraje (GrLivArea), la cantidad de autos que entran en el garage (GarageCars) y el metraje del garage (GarageArea) son las variables continuas más importantes.

Outliers

Hay dos propiedades que tienen valores atípicos.

# Marcar outliercasas["outlier"] = np.logical_and(casas["GrLivArea"] > 4000,                                   casas["SalePrice"] < 300000)# Scatterplotfig, ax = plt.subplots(1, 2, figsize=(12,4))_ = sns.scatterplot(x="GrLivArea", y="SalePrice", hue="outlier", data=casas, ax = ax[0])_ = plt.title("Dos propiedades baratas para su tamaño", fontsize = 16)_ = ax[1].set(xscale="log", yscale="log")_ = ax[1].set_xlabel("log") #, ylabel = "log")_ = sns.scatterplot(x="GrLivArea", y="SalePrice", hue="outlier", data=casas, ax = ax[1])_ = plt.title("Transformación logarítmica", fontsize = 16)

Variables numéricas discontinuas

Estas variables son numéricas pero representan cuentas (cantidad de baños, cantidad de cuartos, etc.).

# Cantidad de baños, cantidad de garagescuentas =   ["KitchenAbvGr", "BedroomAbvGr",              "Fireplaces",   "BsmtFullBath",             "TotRmsAbvGrd", "FullBath",             "HalfBath",     "YearBuilt"]   # Panel de (2, 3)dim_panel = (2, 4)fig, ax = plt.subplots(dim_panel[0], dim_panel[1], figsize=(12,8))ax[1,3].tick_params(labelbottom = False)fig.subplots_adjust(hspace=0.4, wspace=0.4)# Ordenar los nombres de las columnas (2, 3) para iterar fácilcols = np.reshape(np.array(cuentas)[:8], dim_panel) # tomo los primeros 6 para que entre en el panel            _ = [sns.countplot(x=cols[i, j], data=casas, ax = ax[i, j]) for i in range(dim_panel[0])                                                               for j in range(dim_panel[1])]plt.show()

Variables categóricas

Estas variables son categorías y las modelamos como dummies.

categoricas = ["LotShape",     "LandContour",   "BldgType",   "Foundation",               "Neighborhood", "Exterior1st",   "LandSlope",  "HouseStyle",                 "PavedDrive",   "SaleCondition", "RoofStyle",  "CentralAir",                    "LotShape",     "LandContour",   "MSZoning",   "SaleType",               "Street",       "Utilities",     "Heating",    "RoofMatl",               "Exterior2nd",  "LotConfig",                                                    "Alley",        "Electrical",   "BsmtFinType1", "BsmtFinType2",  # Tienen Nan               "GarageType",   "MiscFeature",   "MasVnrType",  "Fence"          # Tienen Nan              ]dim_panel = (5, 5)fig, ax = plt.subplots(dim_panel[0], dim_panel[1], figsize=(12,16))# Apagar los tick labels cuando son demasiadosapagar_ejes = [    (0, 2), (0, 3), (0, 4),     (1, 0), (1, 2), (1, 4),     (2, 0), (2, 2), (2, 3),    (3, 0), (3, 3), (3, 4),    (4, 0), (4, 1), (4, 3), (4, 4)]_ = [ax[plt].tick_params(labelbottom = False) for plt in apagar_ejes]# Fijar los espacios entre los subplotsfig.subplots_adjust(hspace=0.4, wspace=0.6)cols = np.reshape(np.array(categoricas)[:25], dim_panel)_ = [sns.countplot(x=cols[i, j], data=casas, ax = ax[i, j]) for i in range(dim_panel[0])                                                               for j in range(dim_panel[1])]                                                              plt.show()

Street, Utilities, Heating y RoofMatl tienen muy poca variación y pueden generar problemas en el modelo.

# Sacar las problematicascat_problemas = ["Street", "Utilities", "Heating", "RoofMatl"] #_ = [ categoricas.remove(col) for col in cat_problemas  ]cat_missing = ["MasVnrType",   "GarageType",                 #"Electrical",   "MiscFeature",               "BsmtFinType1", "BsmtFinType2",               "LotConfig",    "Exterior2nd",  "LandSlope",                "Alley",        "Fence" ]_ = [ categoricas.remove(col) for col in cat_missing  ]

Variables Categóricas Ordinales

El último tipo de columna son las variables categóricas ordinales (ej: calidad de la piscina). En estos casos, la variable aparece como texto, pero en realidad queremos modelarla como numérica, porque Calidad = 2 es más que Calidad = 1. Para eso tenemos que recodificar las columnas.

ordinales = ["OverallQual",  "OverallCond", "ExterQual",             "ExterCond",    "BsmtQual",    "BsmtCond",             "BsmtExposure", "HeatingQC",   "KitchenQual",             "Functional",   "FireplaceQu", "PoolQC",             "GarageFinish", "GarageCond",  "GarageQual",             "Fence"]

Llevamos las que tienen escalas de calidad (Ex, Gd, Fa, Po) a una escala común. Por ejemplo,cuando es missing la dejamos en 0. Si la calidad de la piscina es missing, es porque la propiedad no tiene piscina y está bien que quede en 0.

def cambiar_escala(df, col, escala):  # reemplazar missings  casas[col].fillna("MISSING", inplace = True)  # aplicar escala_ordinal  casas[col].replace(escala, inplace = True)

# Po < Fa < TA < Gd < ExESCALA_ORDINAL = { "MISSING": 0, "Po" : 1, "Fa" : 2,                    "TA" : 3,     "Gd" : 4, "Ex" : 5}ordinales_escala_comun = [ "ExterQual",   "ExterCond",                              "BsmtQual",    "BsmtCond",                                "HeatingQC",   "KitchenQual",                             "FireplaceQu", "PoolQC",                                  "GarageCond"  ]# cambiar casas inplace_ = [ cambiar_escala(casas, col, ESCALA_ORDINAL) for col in ordinales_escala_comun]

ESCALA_FUNCTIONAL = { "Sal" : 0, "Sev" : 1,                      "Maj2": 2, "Maj1": 3,                      "Mod" : 4, "Min2": 5,                      "Min1": 6, "Typ": 7                    }cambiar_escala(casas, "Functional", escala = ESCALA_FUNCTIONAL)

# Panel con las variables ordinales# TODO refactorear a una funcion con las de las cuentasdim_panel = (4, 4)fig, ax = plt.subplots(dim_panel[0], dim_panel[1], figsize=(16,18))# Fijar los espacios entre los subplotsfig.subplots_adjust(hspace=0.3, wspace=0.6)cols = np.reshape(np.array(ordinales), dim_panel)_ = [sns.countplot(x=cols[i, j], data=casas, ax = ax[i, j]) for i in range(dim_panel[0])                                                               for j in range(dim_panel[1])]plt.show()

Posibles problemas con PoolQC y Functional. BsmtCond y GarageCond.

Missing en PoolQC (1453) , FireplaceQu (690) , GarageCond (81) , GarageQual (81), GarageFinish (81), GarageType(81), BsmtExposure (38) , BsmtFinType1 (37), BsmtCond (37), BsmtQual (37).

ordinales_missing = ["PoolQC",       "FireplaceQu", "GarageCond",                     "GarageQual",                         "BsmtCond",                     "BsmtQual"]     ordinales_problemas = []   # Problematicasordinales_escala    = ["Fence", "BsmtExposure", "GarageFinish", "ExterCond"]   # Estos los saco pq no arme la escala_ = [ ordinales.remove(col) for col in ordinales_escala + ordinales_missing]

Para evitar problemas de multicolinealidad nos quedamos sólo con TotalBsmtSF

# Extraer X e y como arraysy = casas["SalePrice"]X = casas[ordinales + categoricas + continuas + cuentas ]columnas_con_missing = X.columns[X.isnull().any()]print(f'Columnas con missings para imputar: {columnas_con_missing}')

## Columnas con missings para imputar: Index(['Electrical', 'MiscFeature', 'LotFrontage'], dtype='object')

from sklearn.impute import SimpleImputerfrom sklearn.model_selection import train_test_splitfrom sklearn.linear_model import LinearRegression, Ridge, Lasso, RidgeCV, LassoCVfrom sklearn.compose import TransformedTargetRegressorfrom sklearn.metrics import mean_squared_error, r2_scorefrom sklearn.metrics import make_scorer, mean_absolute_errorfrom sklearn.model_selection import cross_val_scorefrom sklearn.compose import ColumnTransformerfrom sklearn.pipeline import Pipelinefrom sklearn.preprocessing import OneHotEncoder, StandardScaler, OrdinalEncoder, RobustScaler, FunctionTransformer, PolynomialFeaturestransform_categoricas = Pipeline(steps=[    # Imputar faltantes con el valor mas comun y despues hacer dummies    ('imp', SimpleImputer(strategy="most_frequent")),    ('onehot', OneHotEncoder(handle_unknown="ignore"))                                                 ])transform_continuas = Pipeline(steps = [    ('imp_cont', SimpleImputer(strategy='mean')),    ('trans', FunctionTransformer(np.log1p, validate=True)),    ('scale', StandardScaler())])transform_ordinales = Pipeline(steps = [   ('ord', OrdinalEncoder())])transform_polys = Pipeline(steps = [   ('polys', PolynomialFeatures(2))])# ColumnTransformer aplica las pipelines en paralelo y concatena las columnas resultantespreprocesador = ColumnTransformer(  transformers=[#     ('polys', transform_polys, ["GrLivArea"]),      ('cat', transform_categoricas, categoricas),      ('num', transform_continuas, continuas + cuentas),      ('ord',   transform_ordinales, ordinales)#     ('cnts', 'passthrough', cuentas )   ])

Modelos

Estimamos tres modelos: regresión lineal estándar, regresión Ridge y regresión Lasso. La diferencia entre los tres modelos es la forma de regularizar los coeficientes. En el caso de la regresión estándar, se minimiza la suma de cuadrados de los residuos: $\sum (y - \hat{y})^2$. Ridge y Lasso penalizan la norma del vector de coeficientes $\theta$. Esto evita el ovefitting a los datos que usamos para entrenar el modelo.

En el caso de la regresión Ridge, se agrega un término a la función de costos un término que incluye la norma $L_2$ del vector de coeficientes estimados. La regresión Lasso penaliza la norma $L_1$. Ambos métodos incluyen un parámetro $\alpha$ que pondera el costo de la norma del vector de coeficientes en la función de costos del modelo. Para determinar el valor de este parámetro, uso Cross-Validation con 5 folds.

Hay dos métricas posibles para evaluar los modelos de regresión: Mean Absolute y Mean Squared Error. El MSE penaliza más los outliers, pero no está medido en la misma unidad que la variable objetivo, por lo que vamos a usar el MAE, que si se mide en la unidad de la variable de destino (en este caso son dólares)

scorer = make_scorer(mean_absolute_error)X_prep = preprocesador.fit_transform(X) # TODO: este paso debería estar adentro del                                         #       pipeline pero no funciona

Regresión sin Regularización

reg = TransformedTargetRegressor(regressor=LinearRegression(),                                        func=np.log1p,                                        inverse_func=np.expm1)cv_linreg = cross_val_score(reg, X_prep, y, cv = 5, scoring = scorer)print(f'MAE Sin Reg: ${cv_linreg.mean():.2f}')

## MAE Sin Reg: $16604.95

Lasso

lassoCV = TransformedTargetRegressor(regressor=LassoCV(cv = 5),                                        func=np.log1p,                                        inverse_func=np.expm1)lassoCV_score = cross_val_score(lassoCV, X_prep, y, cv = 5, scoring = scorer)print(f'MAE Lasso: ${lassoCV_score.mean():.2f}')

## MAE Lasso: $15978.56

lassoCV.fit(X_prep, y)

## TransformedTargetRegressor(check_inverse=True, func=<ufunc 'log1p'>,##               inverse_func=<ufunc 'expm1'>,##               regressor=LassoCV(alphas=None, copy_X=True, cv=5, eps=0.001, fit_intercept=True,##     max_iter=1000, n_alphas=100, n_jobs=None, normalize=False,##     positive=False, precompute='auto', random_state=None,##     selection='cyclic', tol=0.0001, verbose=False),##               transformer=None)

print(f'Mejor Alpha: {lassoCV.regressor_.alpha_:.2f}')

## Mejor Alpha: 0.00

Ridge

ridgeCV = TransformedTargetRegressor(regressor=RidgeCV(cv = 5),                                        func=np.log1p,                                        inverse_func=np.expm1)ridgeCV_score = cross_val_score(ridgeCV, X_prep, y, cv = 5, scoring = scorer)print(f'MAE Ridge: ${ridgeCV_score.mean():.2f}')

## MAE Ridge: $16462.99

ridgeCV.fit(X_prep, y)

## TransformedTargetRegressor(check_inverse=True, func=<ufunc 'log1p'>,##               inverse_func=<ufunc 'expm1'>,##               regressor=RidgeCV(alphas=array([ 0.1,  1. , 10. ]), cv=5, fit_intercept=True,##     gcv_mode=None, normalize=False, scoring=None, store_cv_values=False),##               transformer=None)

print(f'Mejor Alpha: {ridgeCV.regressor_.alpha_}')

## Mejor Alpha: 10.0

Análisis de los Errores

fig, ax = plt.subplots(1, 3, figsize=(16, 4))reg.fit(X_prep, y)

## TransformedTargetRegressor(check_inverse=True, func=<ufunc 'log1p'>,##               inverse_func=<ufunc 'expm1'>,##               regressor=LinearRegression(copy_X=True, fit_intercept=True, n_jobs=None,##          normalize=False),##               transformer=None)

preds = reg.predict(X_prep)preds = pd.DataFrame({"preds":preds, "true":y})preds["residuals"] = preds["true"] - preds["preds"]_ = preds.plot(x = "preds", y = "residuals", kind = "scatter", ax = ax[0])_ = ax[0].set_title("Sin Regularización")preds = lassoCV.predict(X_prep)preds = pd.DataFrame({"preds":preds, "true":y})preds["residuals"] = preds["true"] - preds["preds"]_ = preds.plot(x = "preds", y = "residuals", kind = "scatter", ax = ax[1])_ = ax[1].set_title("Lasso")preds = ridgeCV.predict(X_prep)preds = pd.DataFrame({"preds":preds, "true":y})preds["residuals"] = preds["true"] - preds["preds"]_ = preds.plot(x = "preds", y = "residuals", kind = "scatter", ax = ax[2])_ = ax[2].set_title("Ridge")

Los errores de los tres modelos muestran que hay margen para mejora porque los errores de predicción son sistemáticamente altos para valores alto de la predicción. Agregar cuadrados de los features podría mejorar los resultados.

Conclusiones

Entrenamos 3 modelos y elegimos los hiperparámetros con un esquema de Cross-Validation con 5 folds. El mejor modelo es la regresión Lasso con $\alpha = 0.00045$, que permite predecir el precio de una vivienda con un error promedio de aproximadamente $ 15.100, menos del 10% de la media de la variable objetivo ($181.000). Dada la alta cantidad de columnas colineales en los regresores, era de esperar que Lasso funcionara mejor, porque tiende a hace que muchos de los coeficientes $\theta$ estimados sean 0.

Barrios ricos y pobres de Montevideo

Sat, 13 Apr 2019 00:00:00 +0000

Todas las ciudades tienen zonas ricas y zonas pobres. En Montevideo, las zonas costeras concentran los hogares de mayores ingresos (Carrasco, Punta Gorda, Malvín, Pocitos, etc.).

En este post armo un mapa para visualizar cuáles son los barrios con mayores ingresos en las ciudades de Uruguay.

## OGR data source with driver: ESRI Shapefile ## Source: "/Users/rlabuonora/Desktop/data_science/work/blog_2/public/shps/ine_seg_11", layer: "ine_seg_11"## with 4313 features## It has 13 fields

## [1] "en_US.UTF-8/UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8"

Las Zonas Censales

La información geográfica puede venir en formato raster o en formato shapefile. Un objeto raster es una grilla de números, y cada celda de la grilla está georeferenciada a una parte de la superficie de la tierra. Los shapefiles son una forma de almacenar datos de formas, que pueden representar entidades geográficas físicas o imaginarias (ríos, países, etc.)

El INE publica shapefiles con las formas de los segmentos censales que usa para muestrear la Encuesta de Hogares. En Uruguay hay nrow(ine_seg_11_sf) segmentos censales.

La librería sf tiene un montón de herramientas para trabajar con datos geográficos. La mejor fuente que conozco para aprender más es Geocomputation with R.

library(sf)# Cargar mapaine_seg_11_sf <- st_read('../../public/shps/ine_seg_11/ine_seg_11.shp')

## Reading layer `ine_seg_11' from data source `/Users/rlabuonora/Desktop/data_science/work/blog_2/public/shps/ine_seg_11/ine_seg_11.shp' using driver `ESRI Shapefile'## Simple feature collection with 4313 features and 13 fields## geometry type:  MULTIPOLYGON## dimension:      XY## bbox:           xmin: 366582.2 ymin: 6127919 xmax: 858252.1 ymax: 6671738## epsg (SRID):    NA## proj4string:    NA

# asignar crsst_crs(ine_seg_11_sf) <- "+proj=utm +zone=21 +south +ellps=WGS84 +datum=WGS84 +units=m +no_defs"ine_seg_11_sf <- st_transform(ine_seg_11_sf, crs=4326)class(ine_seg_11_sf)

## [1] "sf"         "data.frame"

plot(st_geometry(ine_seg_11_sf))

Calculamos las medianas

Para calcular el ingreso en cada segmento censal, usamos los datos de la Encuesta Continua de Hogares. Los microdatos incluyen el segmento censal de cada hogar y una estimación de su ingreso. dplyr hace muy fácil calcular la mediana del ingreso de los hogares encuestados:

Sys.setlocale("LC_ALL", "UTF-8")

## [1] "en_US.UTF-8/UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8"

medianas <- read_tsv("../../public/ech/H_2018_Terceros.dat") %>%   transmute(id       =as.character(numero),            depto_id = dpto,             depto = nomdpto,            localidad_id = as.numeric(locagr),            localidad = nom_locagr,            seccion_id = as.numeric(secc),            segmento_id = as.numeric(segm),            ingreso = YSVL) %>%   group_by(depto_id, seccion_id, segmento_id) %>%   summarize(mediana = median(ingreso))

Linkear los datos al mapa

Para visualizar todo en un mapa, hay que linkear los datos con el dataframe de los segmentos censales. Agregarle atributos no espaciales a un objeto sf es simple, ya que se comportan como data.frames y soportan las funciones del tidyverse, por lo que podemos usar left_join con depto_id, seccion_id y segmento_id como identificadores:

ine_seg_11_sf <- ine_seg_11_sf %>%   left_join(medianas, by=c("DEPTO" = "depto_id",                           "SECCION" = "seccion_id",                           "SEGMENTO" = "segmento_id"))

Elegir una localidad

Como queremos mapear los ingresos en cada ciudad, tenemos que encontrar una forma de seleccionar una zona del mapa. Para esto podemos usar filter y seleccionar los polígonos que pertenecen a cierta localidad`:

# Montevideo es la localidad 1020cod_loc <- "1020"mapa_loc <- filter(ine_seg_11_sf, CODLOC==cod_loc)plot(st_geometry(mapa_loc))

Agregar mapa de fondo

Este mapa funciona bien si conocemos la ciudad, pero para zonas geográficas no tan familiares puede ser conveniente agregar referencias como calles importantes o cuerpos de agua.

Para eso podemos usar google maps, que publica una API con mapas basadas en imágenes satelitales.Para consumir la API, es necesario registrarse y darles una tarjeta de crédito 👎 para obtener una clave. Acá. hay más info sobre como trabajar con API keys en R.

library(ggmap)# Leer la API key de variable de environmentAPI_KEY <- Sys.getenv("GOOGLE_API")# Loguearse a la APIregister_google(API_KEY)

Para bajar el mapa de Google Maps, necesitamos las coordenadas del mapa que vamos a dibujar. Para obtener estas coordenadas, subseteo el mapa original con el código de la localidad que quiero mapear y obtengo las coordenadas del mapa subseteado.

cod_loc <- "1020"mapa_loc <- filter(ine_seg_11_sf, CODLOC==cod_loc)bbox <- st_bbox(mapa_loc) %>%    setNames(c("left", "bottom", "right", "top"))mapa <- get_map(location=bbox)

Para poder dibujar este mapa con tmap, tengo que convertirlo a un Raster con la función ggmap_rast.

# https://gis.stackexchange.com/questions/155334/ggmap-clip-a-maplibrary(raster)library(tmap)ggmap_rast <- function(map) {  map_bbox <- attr(map, 'bb')   .extent <- extent(as.numeric(map_bbox[c(2,4,1,3)]))  my_map <- raster(.extent, nrow= nrow(map), ncol = ncol(map))  rgb_cols <- setNames(as.data.frame(t(col2rgb(map))), c('red','green','blue'))  red <- my_map  values(red) <- rgb_cols[['red']]  green <- my_map  values(green) <- rgb_cols[['green']]  blue <- my_map  values(blue) <- rgb_cols[['blue']]  stack(red,green,blue)}mapa_raster <- ggmap_rast(mapa)

Ahora que tengo el Raster, los polígonos de los segmentos censales y la estimación de las medianas, podemos hacer un mapa en capas con tmap:

tm_shape(mapa_raster) +   tm_rgb() +   tm_shape(mapa_loc) +  tm_fill(col="mediana",           style="quantile",          title = "Ingreso",          textNA = "S/D",          alpha = 0.75) +   tm_layout("Montevideo",             frame = FALSE,            legend.position = c("right", "bottom"),            legend.format = list(              "text.separator" = "-"            )) +  tm_legend(show=FALSE)

Scraping NBA data with rvest and purrr

Wed, 01 Aug 2018 00:00:00 +0000

The NBA does a great job releasing statistics on every aspect of the game. Most teams have analytics experts crunching those numbers for insights to get a competitive advantage.

In this post I go through the process of scraping data from basketball-reference.com using the R package rvest. We also do some data munging with purrr and string interpolation with glue.

NBA Reference

This website has statistics on every aspect of the game for a long time. In this post, I’ll focus on individual player stats (Field Goal Percentage, Average Minutes, etc.) from the 2000/2001 season up to 2017/2018.

If you follow this link, you can find the data for the 2017 season in an html table.

Html uses a special markup language to format the tables so that your browser can render it properly. Typically, an html table has this structure:

<table>  <th>Player</th>  <td>Data<td></table>

To get this into an R data frame, you can use rvest. The first step is to get all the html from the page using read_html.

library(rvest)nba_url <- "https://www.basketball-reference.com/leagues/NBA_2017_per_game.html"web_page <- read_html(nba_url)

Now we need to get the actual data from the table. html_table does just that:

data <- html_table(web_page)head(data[[1]])

##   Rk        Player Pos Age  Tm  G GS   MP  FG FGA  FG%  3P 3PA  3P%  2P## 1  1  Álex Abrines  SG  23 OKC 68  6 15.5 2.0 5.0 .393 1.4 3.6 .381 0.6## 2  2    Quincy Acy  PF  26 TOT 38  1 14.7 1.8 4.5 .412 1.0 2.4 .411 0.9## 3  2    Quincy Acy  PF  26 DAL  6  0  8.0 0.8 2.8 .294 0.2 1.2 .143 0.7## 4  2    Quincy Acy  PF  26 BRK 32  1 15.9 2.0 4.8 .425 1.1 2.6 .434 0.9## 5  3  Steven Adams   C  23 OKC 80 80 29.9 4.7 8.2 .571 0.0 0.0 .000 4.7## 6  4 Arron Afflalo  SG  31 SAC 61 45 25.9 3.0 6.9 .440 1.0 2.5 .411 2.0##   2PA  2P% eFG%  FT FTA  FT% ORB DRB TRB AST STL BLK TOV  PF  PTS## 1 1.4 .426 .531 0.6 0.7 .898 0.3 1.0 1.3 0.6 0.5 0.1 0.5 1.7  6.0## 2 2.1 .413 .521 1.2 1.6 .750 0.5 2.5 3.0 0.5 0.4 0.4 0.6 1.8  5.8## 3 1.7 .400 .324 0.3 0.5 .667 0.3 1.0 1.3 0.0 0.0 0.0 0.3 1.5  2.2## 4 2.2 .414 .542 1.3 1.8 .754 0.6 2.8 3.3 0.6 0.4 0.5 0.6 1.8  6.5## 5 8.2 .572 .571 2.0 3.2 .611 3.5 4.2 7.7 1.1 1.1 1.0 1.8 2.4 11.3## 6 4.4 .457 .514 1.4 1.5 .892 0.1 1.9 2.0 1.3 0.3 0.1 0.7 1.7  8.4

That was easy! html_table returns a list with all the tables in the web_page as a data_frame. What we want is the first element of that list.

data <- data[[1]]

Let’s inspect the data:

str(data)

## 'data.frame':    619 obs. of  30 variables:##  $ Rk    : chr  "1" "2" "2" "2" ...##  $ Player: chr  "Álex Abrines" "Quincy Acy" "Quincy Acy" "Quincy Acy" ...##  $ Pos   : chr  "SG" "PF" "PF" "PF" ...##  $ Age   : chr  "23" "26" "26" "26" ...##  $ Tm    : chr  "OKC" "TOT" "DAL" "BRK" ...##  $ G     : chr  "68" "38" "6" "32" ...##  $ GS    : chr  "6" "1" "0" "1" ...##  $ MP    : chr  "15.5" "14.7" "8.0" "15.9" ...##  $ FG    : chr  "2.0" "1.8" "0.8" "2.0" ...##  $ FGA   : chr  "5.0" "4.5" "2.8" "4.8" ...##  $ FG%   : chr  ".393" ".412" ".294" ".425" ...##  $ 3P    : chr  "1.4" "1.0" "0.2" "1.1" ...##  $ 3PA   : chr  "3.6" "2.4" "1.2" "2.6" ...##  $ 3P%   : chr  ".381" ".411" ".143" ".434" ......

Ok, so all the columns are read in as text. That’s natural, since all html pages are text, so we need to convert the data to the correct data types.

Most columns seem to be numeric, except Player Name which is a character vector, Player Position and Team which are factors.

One approach to correcting the data types is to use dplyr’s mutate:

library(dplyr)data_1 <- data %>%   mutate(Rk = as.numeric(Rk),         Pos = as.factor(Pos),         Age = as.numeric(Age))#       ...str(select(data_1, Rk, Pos, Age))

## 'data.frame':    619 obs. of  3 variables:##  $ Rk : num  1 2 2 2 3 4 5 6 7 8 ...##  $ Pos: Factor w/ 7 levels "C","PF","PF-C",..: 7 2 2 2 1 7 1 1 2 2 ...##  $ Age: num  23 26 26 26 23 31 28 28 31 27 ...

But there’s a better way. mutate_at applies a function to a list of columns.

data_2 <- data %>%   mutate_at(vars(Tm, Pos), factor)str(select(data_2, Tm, Pos))

## 'data.frame':    619 obs. of  2 variables:##  $ Tm : Factor w/ 32 levels "ATL","BOS","BRK",..: 21 30 7 3 21 26 19 18 27 12 ...##  $ Pos: Factor w/ 7 levels "C","PF","PF-C",..: 7 2 2 2 1 7 1 1 2 2 ...

The Columns need to be specified as a list of variables: vars(Tm, Pos). In this case, the function applied is factor.

Repeat for all the numeric variables using the : notation to select all the columns from G to PS.G.

data_3 <- data %>%  mutate_at(vars(G:`PTS`, Age), as.numeric)str(select(data_3, G:`PTS`, Age))

## 'data.frame':    619 obs. of  26 variables:##  $ G   : num  68 38 6 32 80 61 39 62 72 61 ...##  $ GS  : num  6 1 0 1 80 45 15 0 72 5 ...##  $ MP  : num  15.5 14.7 8 15.9 29.9 25.9 15 8.6 32.4 14.3 ...##  $ FG  : num  2 1.8 0.8 2 4.7 3 2.3 0.7 6.9 1.3 ...##  $ FGA : num  5 4.5 2.8 4.8 8.2 6.9 4.6 1.4 14.6 2.8 ...##  $ FG% : num  0.393 0.412 0.294 0.425 0.571 0.44 0.5 0.523 0.477 0.458 ...##  $ 3P  : num  1.4 1 0.2 1.1 0 1 0 0 0.3 0 ...##  $ 3PA : num  3.6 2.4 1.2 2.6 0 2.5 0.1 0 0.8 0 ...##  $ 3P% : num  0.381 0.411 0.143 0.434 0 0.411 0 NA 0.411 0 ...##  $ 2P  : num  0.6 0.9 0.7 0.9 4.7 2 2.3 0.7 6.6 1.3 ...##  $ 2PA : num  1.4 2.1 1.7 2.2 8.2 4.4 4.5 1.4 13.8 2.7 ...##  $ 2P% : num  0.426 0.413 0.4 0.414 0.572 0.457 0.511 0.523 0.48 0.461 ...##  $ eFG%: num  0.531 0.521 0.324 0.542 0.571 0.514 0.5 0.523 0.488 0.458 ...##  $ FT  : num  0.6 1.2 0.3 1.3 2 1.4 0.7 0.2 3.1 0.4 ......

But wait, what about the rest of the years? You probably heard about the DRY principe: Don’t Repeat Yourself. It’d be silly to write a whole script just to download data from another season, because most of the code would be the same. So we need to reuse our code to get data from the rest of the seasons.

To make our code more reusable, the first thing we need to do is build the url to get the html. We’ll use a super cool package called glue for that.

library(glue)name <- "Rafa"glue("Hello, {name}")

## Hello, Rafa

I’m sure you get the idea. It’s what programmer’s call string interpolation.

For loops are used to iterate over collections, so we can repeat some process without copying the code. With a for loop, we can generate a vector of urls for every season we’re interested in:

base_url <- "https://www.basketball-reference.com/leagues/"page <- "NBA_{year}_per_game.html"urls <- vector("double", length(2000:2017))for (year in 2000:2017) {  urls[[year-1999]] <- glue(base_url, page) ## year -1999 gives 1, 2, 3, ...}head(urls)

## [1] "https://www.basketball-reference.com/leagues/NBA_2000_per_game.html"## [2] "https://www.basketball-reference.com/leagues/NBA_2001_per_game.html"## [3] "https://www.basketball-reference.com/leagues/NBA_2002_per_game.html"## [4] "https://www.basketball-reference.com/leagues/NBA_2003_per_game.html"## [5] "https://www.basketball-reference.com/leagues/NBA_2004_per_game.html"## [6] "https://www.basketball-reference.com/leagues/NBA_2005_per_game.html"

Awesome! Now instead of creating a vector of urls, we’ll create a list of data frames, one for every season.

base_url <- "https://www.basketball-reference.com/leagues/"page <- "NBA_{year}_per_game.html"data <- list()for (year in 2015:2017) {  nba_url <- glue(base_url, page)   web_page <- read_html(nba_url)  data[[year-2014]] <- html_table(web_page)[[1]]}str(data)

## List of 3##  $ :'data.frame':    675 obs. of  30 variables:##   ..$ Rk    : chr [1:675] "1" "2" "3" "4" ...##   ..$ Player: chr [1:675] "Quincy Acy" "Jordan Adams" "Steven Adams" "Jeff Adrien" ...##   ..$ Pos   : chr [1:675] "PF" "SG" "C" "PF" ...##   ..$ Age   : chr [1:675] "24" "20" "21" "28" ...##   ..$ Tm    : chr [1:675] "NYK" "MEM" "OKC" "MIN" ...##   ..$ G     : chr [1:675] "68" "30" "70" "17" ...##   ..$ GS    : chr [1:675] "22" "0" "67" "0" ...##   ..$ MP    : chr [1:675] "18.9" "8.3" "25.3" "12.6" ...##   ..$ FG    : chr [1:675] "2.2" "1.2" "3.1" "1.1" ...##   ..$ FGA   : chr [1:675] "4.9" "2.9" "5.7" "2.6" ...##   ..$ FG%   : chr [1:675] ".459" ".407" ".544" ".432" ...##   ..$ 3P    : chr [1:675] "0.3" "0.3" "0.0" "0.0" ...##   ..$ 3PA   : chr [1:675] "0.9" "0.8" "0.0" "0.0" ......

Better iteration with map

Now our script does everything we want it to do. But there’s a wrinkle we have to iron out.

A lot of programming is about iteration, and every programming language supports for loops. R has a great way to make iteration cleaner with the purrr package. There’s a whole chapter on iteration in R for Data Science, which is a must read for anyone interested in R.

Our script has to repeat the same steps for every year from 2000 to 2017. That’s a job for map! map takes a list and applies a function to every element of the list.

For example, here we apply the head function to a list of data frames to get the first 6 lines of each one:

my_list <- list(mtcars, iris)purrr::map(my_list, head)

## [[1]]##                    mpg cyl disp  hp drat    wt  qsec vs am gear carb## Mazda RX4         21.0   6  160 110 3.90 2.620 16.46  0  1    4    4## Mazda RX4 Wag     21.0   6  160 110 3.90 2.875 17.02  0  1    4    4## Datsun 710        22.8   4  108  93 3.85 2.320 18.61  1  1    4    1## Hornet 4 Drive    21.4   6  258 110 3.08 3.215 19.44  1  0    3    1## Hornet Sportabout 18.7   8  360 175 3.15 3.440 17.02  0  0    3    2## Valiant           18.1   6  225 105 2.76 3.460 20.22  1  0    3    1## ## [[2]]##   Sepal.Length Sepal.Width Petal.Length Petal.Width Species## 1          5.1         3.5          1.4         0.2  setosa## 2          4.9         3.0          1.4         0.2  setosa## 3          4.7         3.2          1.3         0.2  setosa## 4          4.6         3.1          1.5         0.2  setosa## 5          5.0         3.6          1.4         0.2  setosa## 6          5.4         3.9          1.7         0.4  setosa

Instead of head, which is a predefined function, you can use your own functions:

my_list <- list(mtcars, iris)my_func <- function(data_frame) { print("Hello from my fun!")}purrr::map(my_list, my_func)

## [1] "Hello from my fun!"## [1] "Hello from my fun!"

## [[1]]## [1] "Hello from my fun!"## ## [[2]]## [1] "Hello from my fun!"

When applying map, you need to figure out our initial list to iterate over, and the function we want to apply to it’s elements in every iteration. The first part is easy, to get a list of seasons, we convert a numeric vector into a list like: as.list(2000:2017).

Now we need a function that takes one year and does the job for that year. Something like:

get_player_data <- function(year) {  base_url <- "https://www.basketball-reference.com/leagues/"  page <- "NBA_{year}_per_game.html"  # Download data  nba_url <- glue(base_url, page)   # extract the data frame from the table  web_page <- read_html(nba_url)  data <- html_table(web_page)[[1]]  # return a data frame  data}data.14 <- get_player_data(2014)head(data.14)

##   Rk       Player Pos Age  Tm  G GS   MP  FG FGA  FG%  3P 3PA  3P%  2P 2PA## 1  1   Quincy Acy  SF  23 TOT 63  0 13.4 1.0 2.2 .468 0.1 0.2 .267 1.0 2.0## 2  1   Quincy Acy  SF  23 TOR  7  0  8.7 0.9 2.0 .429 0.3 0.7 .400 0.6 1.3## 3  1   Quincy Acy  SF  23 SAC 56  0 14.0 1.1 2.3 .472 0.0 0.2 .200 1.0 2.1## 4  2 Steven Adams   C  20 OKC 81 20 14.8 1.1 2.3 .503 0.0 0.0      1.1 2.3## 5  3  Jeff Adrien  PF  27 TOT 53 12 18.1 2.7 5.2 .520 0.0 0.0      2.7 5.2## 6  3  Jeff Adrien  PF  27 CHA 25  0 10.2 0.9 1.6 .550 0.0 0.0      0.9 1.6##    2P% eFG%  FT FTA  FT% ORB DRB TRB AST STL BLK TOV  PF PTS## 1 .492 .482 0.6 0.8 .660 1.1 2.3 3.4 0.4 0.4 0.4 0.5 1.9 2.7## 2 .444 .500 0.7 1.1 .625 0.7 1.4 2.1 0.6 0.6 0.4 0.3 1.1 2.7## 3 .496 .480 0.5 0.8 .667 1.2 2.4 3.6 0.4 0.3 0.4 0.5 2.0 2.7## 4 .503 .503 1.0 1.7 .581 1.8 2.3 4.1 0.5 0.5 0.7 0.9 2.5 3.3## 5 .520 .520 1.4 2.2 .639 1.9 3.8 5.8 0.7 0.5 0.7 0.7 2.0 6.8## 6 .550 .550 0.5 1.0 .520 1.3 2.2 3.5 0.3 0.3 0.6 0.3 1.4 2.3

Pipes

Pipes are a well known feature in the tidyverse, so I won’t go into detail of how they work. We could turn our function into a set of pipes easily except for this line: data <- html_table(web_page)[[1]].

We’re actually calling two functions in that line: html_table with the web_page argument and [[ with 1 as an argument.

web_page <- read_html(nba_url)tbl_lst <- html_table(web_page)df <- `[[`(tbl_lst, 1)

So we can pipe it like this:

df_2 <- web_page %>%  html_table %>%  `[[`(1)

Finally, we re-write our get_player_data function as:

get_player_data <- function(year) {  base_url <- "https://www.basketball-reference.com/leagues/"  page <- "NBA_{year}_per_game.html"    glue(base_url, page) %>%     read_html %>%     html_table %>%     `[[`(1)}df.14 <- get_player_data(2014)head(df.14)

##   Rk       Player Pos Age  Tm  G GS   MP  FG FGA  FG%  3P 3PA  3P%  2P 2PA## 1  1   Quincy Acy  SF  23 TOT 63  0 13.4 1.0 2.2 .468 0.1 0.2 .267 1.0 2.0## 2  1   Quincy Acy  SF  23 TOR  7  0  8.7 0.9 2.0 .429 0.3 0.7 .400 0.6 1.3## 3  1   Quincy Acy  SF  23 SAC 56  0 14.0 1.1 2.3 .472 0.0 0.2 .200 1.0 2.1## 4  2 Steven Adams   C  20 OKC 81 20 14.8 1.1 2.3 .503 0.0 0.0      1.1 2.3## 5  3  Jeff Adrien  PF  27 TOT 53 12 18.1 2.7 5.2 .520 0.0 0.0      2.7 5.2## 6  3  Jeff Adrien  PF  27 CHA 25  0 10.2 0.9 1.6 .550 0.0 0.0      0.9 1.6##    2P% eFG%  FT FTA  FT% ORB DRB TRB AST STL BLK TOV  PF PTS## 1 .492 .482 0.6 0.8 .660 1.1 2.3 3.4 0.4 0.4 0.4 0.5 1.9 2.7## 2 .444 .500 0.7 1.1 .625 0.7 1.4 2.1 0.6 0.6 0.4 0.3 1.1 2.7## 3 .496 .480 0.5 0.8 .667 1.2 2.4 3.6 0.4 0.3 0.4 0.5 2.0 2.7## 4 .503 .503 1.0 1.7 .581 1.8 2.3 4.1 0.5 0.5 0.7 0.9 2.5 3.3## 5 .520 .520 1.4 2.2 .639 1.9 3.8 5.8 0.7 0.5 0.7 0.7 2.0 6.8## 6 .550 .550 0.5 1.0 .520 1.3 2.2 3.5 0.3 0.3 0.6 0.3 1.4 2.3

Good, now we’re all set for using map:

list_of_data_frames <- as.list(2000:2017) %>%   purrr::map(get_player_data)  str(list_of_data_frames)

## List of 18##  $ :'data.frame':    517 obs. of  30 variables:##   ..$ Rk    : chr [1:517] "1" "1" "1" "2" ...##   ..$ Player: chr [1:517] "Tariq Abdul-Wahad" "Tariq Abdul-Wahad" "Tariq Abdul-Wahad" "Shareef Abdur-Rahim" ...##   ..$ Pos   : chr [1:517] "SG" "SG" "SG" "SF" ...##   ..$ Age   : chr [1:517] "25" "25" "25" "23" ...##   ..$ Tm    : chr [1:517] "TOT" "ORL" "DEN" "VAN" ...##   ..$ G     : chr [1:517] "61" "46" "15" "82" ...##   ..$ GS    : chr [1:517] "56" "46" "10" "82" ...##   ..$ MP    : chr [1:517] "25.9" "26.2" "24.9" "39.3" ...##   ..$ FG    : chr [1:517] "4.5" "4.8" "3.4" "7.2" ...##   ..$ FGA   : chr [1:517] "10.6" "11.2" "8.7" "15.6" ...##   ..$ FG%   : chr [1:517] ".424" ".433" ".389" ".465" ...##   ..$ 3P    : chr [1:517] "0.0" "0.0" "0.1" "0.4" ...##   ..$ 3PA   : chr [1:517] "0.4" "0.5" "0.1" "1.2" ......

Another functional idiom: Reduce

Map takes list and returns a list. In our script, it takes a list of numbers as input and returns a list of data frames. We now need to roll all those data frames into a single data frame.

That’s what reduce does. It takes a list and applies a function to consequtive pairs. accumulating the results.

lst <- list(1, 2, 3, 4) purrr::reduce(lst, sum) # don't do this in real life!

## [1] 10

Of course, since R’s sum is vectorized you don’t ever need to do that,

Reduce works great with map:

lst <- list(1, 2, 3, 4) # Find the sum of the square root of 1, 2, 3, 4purrr::map(lst, sqrt) %>%   purrr::reduce(sum)

## [1] 6.146264

Another example: get the sum of the rows in a list of data frames:

list(mtcars, iris) %>%   purrr::map(nrow) %>%   purrr::reduce(sum)

## [1] 182

In our case, what we need it to use reduce with bind_rows, so we accumulate all the rows in our data_frame into a single one.

Putting all the pieces together in the final script:

library(glue)library(purrr)library(dplyr)library(rvest)# Download data table from basketball referenceget_player_data <- function(year) {    base_nba_url <- "https://www.basketball-reference.com/leagues/NBA_{year}_per_game.html"    glue(base_nba_url) %>%     read_html() %>%     html_table() %>%     `[[`(1) %>%     mutate(Year = year)}data <- as.list(2000:2018) %>%   purrr::map(get_player_data) %>%   purrr::reduce(bind_rows) %>%   mutate_at(vars(G:`PS/G`, Age), as.numeric) %>%   mutate_at(vars(Tm, Pos), factor)#saveRDS(data, file="~/Desktop/data_science/nba_data_00_18.rds")

What to do with the data

https://fastbreakdata.com/classifying-the-modern-nba-player-with-machine-learning-539da03bb824
https://www.reddit.com/r/nba/comments/6pp8jo/ocrethinking_basketball_positions_with_machine/
http://cs229.stanford.edu/proj2012/Wheeler-PredictingNBAPlayerPerformance.pdf
Effect of injury
Regression candidates in a team
PCA
player stats predict team offense and defense rating?
predict wins based on offense and defense rating

Un mapa de Montevideo con leaflet

Tue, 17 Jul 2018 00:00:00 +0000

R tiene abstracciones para trabajar con información geográfica sin entender a fondo los detalles de cómo se hacen las proyecciones cartográficas y qué son los sistemas de coordenadas.

La API de StreetView publica un mapa con bastante información del terreno como calles, ríos y lugares importantes obtenidos a partir de fotos satelitales. Este es el tipo de mapas que suelen usar aplicaciones como Uber o Google Maps. Leaflet facilita el consumo de la API para hacer mapas interactivos generando un widget HTML con controles para moverse y hacer zoom.

library(tidyverse)library(maptools)library(leaflet)library(dplyr)library(rgdal)library(shiny)mvd <- list(lng=-56.164532, lat=-34.901112)leaflet() %>%   setView(lng=mvd$lng, lat=mvd$lat, zoom=12) %>%   addTiles(group="Google")

Para hacer este mapa llamamos a leaflet::leaflet() sin argumentos, setView() para especificar las coordenadas y zoom iniciales y addTiles() para dibujar el mapa. Leaflet sigue las convenciones del tidyverse, por lo que podemos encadenar las llamadas a las funciones con %>%.

Hay otro tipo de mapas que representan algun tipo de entidad geográfica (un país o un barrio) mediante un polígono. La información para construir estos mapas no está disponible en las imágenes satelitales, porque las fronteras entre estas entidades no es visible. En Uruguay, el INE publica shapefiles con la información cartográfica de los departamentos de Uruguay, los barrios de Montevideo, etc.

Los shapefiles se publican con otros archivos que incluyen datos y otros atributos de las formas. readOGR() devuelve un objeto SpatialPolygonsDataFrame:

# leer shapefile (cuidado que incluyen los shpx, dbf, etc.)states <- readOGR("../../static/shps/barrios/ine_barrios_mvd_nbi85.shp",                  layer = "ine_barrios_mvd_nbi85", GDAL1_integer64_policy = TRUE)

## OGR data source with driver: ESRI Shapefile ## Source: "/Users/rlabuonora/Desktop/data_science/work/blog_2/static/shps/barrios/ine_barrios_mvd_nbi85.shp", layer: "ine_barrios_mvd_nbi85"## with 62 features## It has 3 fields

crswgs84 <- CRS("+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs")# proyeccion ineprj <- CRS("+proj=utm +zone=21 +south +ellps=WGS84 +datum=WGS84 +units=m +no_defs")# asignar proyproj4string(states) <- prj# transformar la proyecciónst <- spTransform(states, crswgs84)

El mapa que vamos a usar tiene un data_frame con tres columnas: un código para cada barrio, el nombre y el área. Estos datos estan en el archivo dbf que viene en el zip.

head(states@data)

##   AREA_KM     NOMBBARR NROBARRIO## 0   2.111 Ciudad Vieja         1## 1   1.297       Centro         2## 2   0.694   Barrio Sur         3## 3   2.279       Cordon         4## 4   0.798      Palermo         5## 5   0.766  Parque Rodo         6

Los shapefiles son útiles para dibujar choropleths, que pintan cada polígono con un color para mostrar alguna variable. Acá pintamos cada barrio según su área:

# Paleta de coloresqpal <- colorNumeric("YlOrRd", st@data$AREA_KM)leaflet(st) %>%  addPolygons(layerId=~NROBARRIO, color = "#444444", weight = 1, smoothFactor = 0.5,              opacity = 1.0, fillOpacity = 0.5,              fillColor = ~qpal(AREA_KM),              highlightOptions = highlightOptions(color = "white", weight = 2,                                                  bringToFront = TRUE), group="INE") %>%   addLegend(pal = qpal, values = ~AREA_KM)

Para hacer el choropleth necesitamos una función que nos de un color para cada valor de la variable que queremos visualizar. Eso es lo que hace qpal. Luego dibujamos el mapa con leaflet() y addPolygons().

Los shapefiles tienen las coordenadas de las formas que contienen, por lo que si especificamos la proyección usada podemos superponerlos con los mapas que publica StreetView:

leaflet(st) %>%  addPolygons(layerId=~NROBARRIO, color = "#444444", weight = 1, smoothFactor = 0.5,              opacity = 1.0, fillOpacity = 0.5,              fillColor = ~colorQuantile("YlOrRd", AREA_KM)(AREA_KM),              highlightOptions = highlightOptions(color = "white", weight = 2,                                                  bringToFront = TRUE), group="INE") %>%  addTiles(group="StreetView") %>%  addLayersControl(    overlayGroups = c("INE", "StreetView"),    options = layersControlOptions(collapsed = FALSE)  )

Especificar group=INE y group=StreetView permite agrupar estas capas del mapa para que addLayerControl las identifique para genera los dos checkboxes que permiten prender y apagar esas capas del mapa.