Capítulo 4. Caso práctico: Lesiones en urgencias
Este trabajo se ha traducido utilizando IA. Agradecemos tus opiniones y comentarios: translation-feedback@oreilly.com
Introducción
En los tres últimos capítulos te he presentado un montón de conceptos nuevos. Así que, para ayudarte a asimilarlos, ahora recorreremos una aplicación Shiny más rica que explora un divertido conjunto de datos y reúne muchas de las ideas que has visto hasta ahora. Empezaremos haciendo un pequeño análisis de datos fuera de Shiny, y luego lo convertiremos en una aplicación, empezando de forma sencilla y añadiendo progresivamente más detalles.
En este capítulo, complementaremos Shiny con vroom (para la lectura rápida de archivos) y el tidyverse (para el análisis general de datos):
library(shiny)library(vroom)library(tidyverse)
Los datos
En vamos a explorar los datos del Sistema Nacional de Vigilancia Electrónica de Lesiones (NEISS), recogidos por la Comisión de Seguridad de los Productos de Consumo. Se trata de un estudio a largo plazo que registra todos los accidentes atendidos en una muestra representativa de hospitales de Estados Unidos. Es un conjunto de datos interesante de explorar porque todo el mundo está ya familiarizado con el ámbito, y cada observación va acompañada de una breve narración que explica cómo se produjo el accidente. Puedes obtener más información sobre este conjunto de datos en GitHub.
En este capítulo, voy a centrarme sólo en los datos de 2017. Esto mantiene los datos lo suficientemente pequeños (~10 MB) como para que sean fáciles de almacenar en Git (junto con el resto del libro), lo que significa que no necesitamos pensar en estrategias sofisticadas para importar los datos rápidamente (volveremos a ellas más adelante en el libro). Puedes ver el código que utilicé para crear el extracto de este capítulo en GitHub.
Si quieres pasar los datos a tu propio ordenador, ejecuta este código:
dir.create("neiss")#> Warning in dir.create("neiss"): 'neiss' already existsdownload<-function(name){url<-"https://github.com/hadley/mastering-shiny/raw/master/neiss/"download.file(paste0(url,name),paste0("neiss/",name),quiet=TRUE)}download("injuries.tsv.gz")download("population.tsv")download("products.tsv")
El principal conjunto de datos que utilizaremos es injuries, que contiene unas 250.000 observaciones:
injuries<-vroom::vroom("neiss/injuries.tsv.gz")injuries#> # A tibble: 255,064 x 10#> trmt_date age sex race body_part diag location prod_code weight#> <date> <dbl> <chr> <chr> <chr> <chr> <chr> <dbl> <dbl>#> 1 2017-01-01 71 male white Upper Tru… Contusion… Other Publ… 1807 77.7#> 2 2017-01-01 16 male white Lower Arm Burns, Th… Home 676 77.7#> 3 2017-01-01 58 male white Upper Tru… Contusion… Home 649 77.7#> 4 2017-01-01 21 male white Lower Tru… Strain, S… Home 4076 77.7#> 5 2017-01-01 54 male white Head Inter Org… Other Publ… 1807 77.7#> 6 2017-01-01 21 male white Hand Fracture Home 1884 77.7#> # … with 255,058 more rows, and 1 more variable: narrative <chr>
Cada fila representa un único accidente con 10 variables:
trmt_date-
La fecha en que la persona fue atendida en el hospital (no cuando ocurrió el accidente).
age,sex, yrace-
Información demográfica sobre la persona que sufrió el accidente.
body_part-
El lugar de la lesión en el cuerpo (como el tobillo o la oreja);
locationes el lugar donde se produjo el accidente (como la casa o la escuela). diag-
El diagnóstico básico de la lesión (como fractura o laceración).
prod_code-
El producto principal asociado a la lesión.
weight-
El peso estadístico que da el número estimado de personas que sufrirían esta lesión si este conjunto de datos se escalara a toda la población de EEUU.
narrative-
Una breve historia sobre cómo ocurrió el accidente.
Lo emparejaremos con otros dos marcos de datos para obtener un contexto adicional: products nos permite buscar el nombre del producto a partir del código del producto, y population nos indica la población total de EEUU en 2017 para cada combinación de edad y sexo:
products<-vroom::vroom("neiss/products.tsv")products#> # A tibble: 38 x 2#> prod_code title#> <dbl> <chr>#> 1 464 knives, not elsewhere classified#> 2 474 tableware and accessories#> 3 604 desks, chests, bureaus or buffets#> 4 611 bathtubs or showers#> 5 649 toilets#> 6 676 rugs or carpets, not specified#> # … with 32 more rowspopulation<-vroom::vroom("neiss/population.tsv")population#> # A tibble: 170 x 3#> age sex population#> <dbl> <chr> <dbl>#> 1 0 female 1924145#> 2 0 male 2015150#> 3 1 female 1943534#> 4 1 male 2031718#> 5 2 female 1965150#> 6 2 male 2056625#> # … with 164 more rows
Exploración
Antes de que cree la aplicación, exploremos un poco los datos. Empezaremos examinando un producto con una historia interesante: 649, "inodoros". Primero sacaremos las lesiones asociadas a este producto:
selected<-injuries%>%filter(prod_code==649)nrow(selected)#> [1] 2993
A continuación realizaremos algunos resúmenes básicos sobre la localización, la parte del cuerpo y el diagnóstico de las lesiones relacionadas con el uso del retrete. Ten en cuenta que he ponderado por la variable weight para que los recuentos puedan interpretarse como lesiones totales estimadas en todo EEUU:
selected%>%count(location,wt=weight,sort=TRUE)#> # A tibble: 6 x 2#> location n#> <chr> <dbl>#> 1 Home 99603.#> 2 Other Public Property 18663.#> 3 Unknown 16267.#> 4 School 659.#> 5 Street Or Highway 16.2#> 6 Sports Or Recreation Place 14.8selected%>%count(body_part,wt=weight,sort=TRUE)#> # A tibble: 24 x 2#> body_part n#> <chr> <dbl>#> 1 Head 31370.#> 2 Lower Trunk 26855.#> 3 Face 13016.#> 4 Upper Trunk 12508.#> 5 Knee 6968.#> 6 N.S./Unk 6741.#> # … with 18 more rowsselected%>%count(diag,wt=weight,sort=TRUE)#> # A tibble: 20 x 2#> diag n#> <chr> <dbl>#> 1 Other Or Not Stated 32897.#> 2 Contusion Or Abrasion 22493.#> 3 Inter Organ Injury 21525.#> 4 Fracture 21497.#> 5 Laceration 18734.#> 6 Strain, Sprain 7609.#> # … with 14 more rows
Como cabría esperar, las lesiones relacionadas con los retretes ocurren con mayor frecuencia en el hogar. Las partes del cuerpo más frecuentemente implicadas posiblemente sugieren que se trata de caídas (ya que la cabeza y la cara no suelen estar implicadas en el uso rutinario del inodoro), y los diagnósticos parecen bastante variados.
También podemos explorar el patrón según la edad y el sexo. Aquí tenemos suficientes datos como para que una tabla no sea tan útil, así que hago un gráfico, como el de la Figura 4-1, que hace más evidentes los patrones:
summary<-selected%>%count(age,sex,wt=weight)summary#> # A tibble: 208 x 3#> age sex n#> <dbl> <chr> <dbl>#> 1 0 female 4.76#> 2 0 male 14.3#> 3 1 female 253.#> 4 1 male 231.#> 5 2 female 438.#> 6 2 male 632.#> # … with 202 more rowssummary%>%ggplot(aes(age,n,colour=sex))+geom_line()+labs(y="Estimated number of injuries")
Figura 4-1. Número estimado de lesiones causadas por inodoros, desglosado por edad y sexo.
Vemos un pico en los chicos jóvenes que alcanza su punto máximo a los 3 años, y luego un aumento (sobre todo en las mujeres) a partir de la mediana edad, y un descenso gradual después de los 80 años. Sospecho que el pico se debe a que los chicos suelen ir al baño de pie, y que el aumento en las mujeres se debe a la osteoporosis (es decir, sospecho que las mujeres y los hombres se lesionan al mismo ritmo, pero que son más las mujeres que acaban en urgencias porque tienen mayor riesgo de fracturas).
Un problema para interpretar este patrón es que sabemos que hay menos personas mayores que jóvenes, por lo que la población disponible para sufrir lesiones es menor. Podemos controlar esto comparando el número de personas lesionadas con la población total y calculando una tasa de lesiones. Aquí utilizo una tasa por 10.000:
summary<-selected%>%count(age,sex,wt=weight)%>%left_join(population,by=c("age","sex"))%>%mutate(rate=n/population*1e4)summary#> # A tibble: 208 x 5#> age sex n population rate#> <dbl> <chr> <dbl> <dbl> <dbl>#> 1 0 female 4.76 1924145 0.0247#> 2 0 male 14.3 2015150 0.0708#> 3 1 female 253. 1943534 1.30#> 4 1 male 231. 2031718 1.14#> 5 2 female 438. 1965150 2.23#> 6 2 male 632. 2056625 3.07#> # … with 202 more rows
Al trazar la tasa, como se muestra en la Figura 4-2, se obtiene una tendencia sorprendentemente diferente después de los 50 años: la diferencia entre hombres y mujeres es mucho menor, y ya no se observa una disminución. Esto se debe a que las mujeres tienden a vivir más que los hombres, por lo que a edades más avanzadas simplemente hay más mujeres vivas que pueden lesionarse con los inodoros:
summary%>%ggplot(aes(age,rate,colour=sex))+geom_line(na.rm=TRUE)+labs(y="Injuries per 10,000 people")
Figura 4-2. Tasa estimada de lesiones por 10.000 personas, desglosada por edad y sexo.
(Ten en cuenta que las tasas sólo llegan hasta los 80 años porque no he podido encontrar datos de población para edades superiores a 80 años).
Por último, podemos echar un vistazo a algunas de las narraciones. Hojearlas es una forma informal de comprobar nuestras hipótesis y generar nuevas ideas para seguir explorando. Aquí extraigo una muestra aleatoria de 10:
selected%>%sample_n(10)%>%pull(narrative)#> [1] "68YOF STRAINED KNEE MOVING FROM TOILET TO POWER CHAIR AT HOME. DX:...#> [2] "97YOM LWR BACK PAIN - MISSED TOILET SEAT, FELL FLOOR AT NH"#> [3] "54 YOF DX ALCOHOL INTOXICATION - PT STATES SHE FELL OFF TOILET."#> [4] "85YOF-STAFF AT NH STATES PT WAS TRANSITIONIN TO TOILET FROM WHEELCH...#> [5] "FOREHEAD LACERATION. 64 YOM FELL AND HIT HIS HEAD ON TOILET."#> [6] "70YOM-STAFF STATES PT FELL OFF TOILET ONTO CONCRETE FLOOR AT *** AR...#> [7] "40YOF WAS INTOXICATED AND FELL OFF THE TOILET STRUCK HEAD ON THE WA...#> [8] "66 Y/O F FELL FROM COMMODE ONTO FLOOR AND FRACTURED CLAVICLE"#> [9] "25YOF SYNCOPAL EPS W ON TOILET FELL HIT RS OF HEAD REPORTLY LOC UNK...#> [10] "4 YO M W/LAC TO FOREHEAD SLIPPED IN BATHROOM HIT ON TOILET FLUSH HA...
Habiendo hecho esta exploración para un producto, estaría muy bien que pudiéramos hacerlo fácilmente para otros productos, sin tener que volver a escribir el código. Así que ¡hagamos una aplicación Shiny!
Prototipo
Cuando construye una aplicación compleja, recomiendo encarecidamente empezar de la forma más sencilla posible, para que puedas confirmar que la mecánica básica funciona antes de empezar a hacer algo más complicado. Aquí empezaré con una entrada (el código del producto), tres tablas y un gráfico.
Al diseñar un primer prototipo, el reto está en hacerlo "lo más sencillo posible". Existe una tensión entre conseguir que lo básico funcione rápidamente y planificar el futuro de la aplicación. Cualquiera de los dos extremos puede ser malo: si diseñas de forma demasiado limitada, pasarás mucho tiempo reelaborando tu aplicación; si diseñas de forma demasiado rigurosa, pasarás mucho tiempo escribiendo código que luego acabará en el suelo de la sala de desguace. Para ayudar a conseguir el equilibrio adecuado, a menudo hago algunos bocetos a lápiz y papel para explorar rápidamente la interfaz de usuario y el gráfico reactivo antes de comprometerme con el código.
Aquí decidí tener 1 fila para las entradas (aceptando que probablemente añadiré más entradas antes de terminar esta aplicación), 1 fila para las tres tablas (dando a cada tabla 4 columnas, 1/3 de la anchura de 12 columnas), y luego 1 fila para el gráfico:
prod_codes<-setNames(products$prod_code,products$title)ui<-fluidPage(fluidRow(column(6,selectInput("code","Product",choices=prod_codes))),fluidRow(column(4,tableOutput("diag")),column(4,tableOutput("body_part")),column(4,tableOutput("location"))),fluidRow(column(12,plotOutput("age_sex"))))
Aún no hemos hablado de fluidRow() y column(), pero deberías ser capaz de adivinar lo que hacen por el contexto, y volveremos a hablar de ellos en "Multifila". Observa también el uso de setNames() en selectInput() choices : muestra el nombre del producto en la interfaz de usuario y devuelve el código del producto al servidor.
La función servidor es relativamente sencilla. Primero convierto las variables estáticas selected y summary en expresiones reactivas. Se trata de un patrón general razonable: creas variables en tus análisis de datos para descomponer el análisis en pasos y evitar volver a calcular las cosas varias veces, y las expresiones reactivas desempeñan el mismo papel en las aplicaciones Shiny.
A menudo es una buena idea dedicar un poco de tiempo a limpiar tu código de análisis antes de empezar tu aplicación Shiny, para que puedas pensar en estos problemas en código R normal antes de añadir la complejidad adicional de la reactividad:
server<-function(input,output,session){selected<-reactive(injuries%>%filter(prod_code==input$code))output$diag<-renderTable(selected()%>%count(diag,wt=weight,sort=TRUE))output$body_part<-renderTable(selected()%>%count(body_part,wt=weight,sort=TRUE))output$location<-renderTable(selected()%>%count(location,wt=weight,sort=TRUE))summary<-reactive({selected()%>%count(age,sex,wt=weight)%>%left_join(population,by=c("age","sex"))%>%mutate(rate=n/population*1e4)})output$age_sex<-renderPlot({summary()%>%ggplot(aes(age,n,colour=sex))+geom_line()+labs(y="Estimated number of injuries")},res=96)}
Ten en cuenta que crear el reactivo summary no es estrictamente necesario aquí, ya que sólo lo utiliza un único consumidor reactivo. Pero es una buena práctica mantener separados el cálculo y el trazado, ya que facilita la comprensión del flujo de la aplicación y facilitará su generalización en el futuro.
En la Figura 4-3 se muestra una captura de pantalla de la aplicación resultante. Puedes ver el código fuente en GitHub.
Figura 4-3. Primer prototipo de la aplicación de exploración NEISS. Ver en directo en https://hadley.shinyapps.io/ms-prototype.
Mesas polacas
Ahora que tenemos los componentes básicos en su sitio y funcionando, podemos mejorar progresivamente nuestra app. El primer problema de esta aplicación es que muestra mucha información en las tablas, cuando probablemente sólo queramos lo más destacado. Para solucionarlo, primero tenemos que averiguar cómo truncar las tablas. He optado por hacerlo con una combinación de funciones forcats: Convierto la variable en un factor, la ordeno por la frecuencia de los niveles, y luego agrupo todos los niveles después de los cinco primeros:
injuries%>%mutate(diag=fct_lump(fct_infreq(diag),n=5))%>%group_by(diag)%>%summarise(n=as.integer(sum(weight)))#> # A tibble: 6 x 2#> diag n#> * <fct> <int>#> 1 Other Or Not Stated 1806436#> 2 Fracture 1558961#> 3 Laceration 1432407#> 4 Strain, Sprain 1432556#> 5 Contusion Or Abrasion 1451987#> 6 Other 1929147
Como sabía cómo hacerlo, escribí una pequeña función para automatizar esto para cualquier variable. Los detalles no son realmente importantes aquí, pero volveremos a ellos en el Capítulo 12. También podrías resolver el problema con copiar y pegar, así que no te preocupes si el código parece totalmente extraño:
count_top<-function(df,var,n=5){df%>%mutate({{var}}:=fct_lump(fct_infreq({{var}}),n=n))%>%group_by({{var}})%>%summarise(n=as.integer(sum(weight)))}
Luego lo utilizo en la función del servidor:
output$diag<-renderTable(count_top(selected(),diag),width="100%")output$body_part<-renderTable(count_top(selected(),body_part),width="100%")output$location<-renderTable(count_top(selected(),location),width="100%")
Hice otro cambio para mejorar la estética de la aplicación: Forcé a todas las tablas a ocupar la anchura máxima (es decir, a llenar la columna en la que aparecen). Esto hace que el resultado sea más agradable estéticamente porque reduce la cantidad devariaciones incidentales.
En la Figura 4-4 se muestra una captura de pantalla de la aplicación resultante. Puedes ver el código fuente en GitHub.
Figura 4-4. La segunda iteración de la aplicación mejora la visualización mostrando sólo las filas más frecuentes en las tablas resumen. Puedes verlo en directo en https://hadley.shinyapps.io/ms-polish-tables.
Tasa frente a recuento
Así que hasta ahora, sólo estamos mostrando un único gráfico, pero nos gustaría dar al usuario la posibilidad de elegir entre visualizar el número de lesiones o la tasa estandarizada por población. Primero añado un control a la IU. Aquí he optado por utilizar un selectInput() porque hace explícitos ambos estados, y sería fácil añadir nuevos estados en el futuro:
fluidRow(column(8,selectInput("code","Product",choices=setNames(products$prod_code,products$title),width="100%")),column(2,selectInput("y","Y axis",c("rate","count")))),
(Yo utilizo por defecto rate porque creo que es más seguro; no necesitas comprender la distribución de la población para interpretar correctamente el gráfico).
Luego condiciono esa entrada al generar la trama:
output$age_sex<-renderPlot({if(input$y=="count"){summary()%>%ggplot(aes(age,n,colour=sex))+geom_line()+labs(y="Estimated number of injuries")}else{summary()%>%ggplot(aes(age,rate,colour=sex))+geom_line(na.rm=TRUE)+labs(y="Injuries per 10,000 people")}},res=96)
En la Figura 4-5 se muestra una captura de pantalla de la aplicación resultante. Puedes ver el código fuente en GitHub.
Figura 4-5. En esta iteración, damos al usuario la posibilidad de cambiar entre mostrar el recuento y la tasa estandarizada de población en el eje y. Puedes verlo en directo en https://hadley.shinyapps.io/ms-rate-vs-count.
Narrativa
Por último, en quiero proporcionar alguna forma de acceder a las narraciones, porque son muy interesantes y ofrecen una manera informal de contrastar las hipótesis que se te ocurren al mirar los gráficos. En el código R, muestreo varias narrativas a la vez, pero no hay razón para hacerlo en una aplicación en la que puedes explorar de forma interactiva.
La solución consta de dos partes. Primero añadimos una nueva fila a la parte inferior de la IU. Utilizo un botón de acción para activar una nueva historia, y pongo la narración en un textOutput():
fluidRow(column(2,actionButton("story","Tell me a story")),column(10,textOutput("narrative")))
En la Figura 4-6 se muestra una captura de pantalla de la aplicación resultante. Puedes ver el código fuente en GitHub.
Figura 4-6. La iteración final añade la posibilidad de extraer una narración aleatoria de las filas seleccionadas. Puedes verlo en directo en https://hadley.shinyapps.io/ms-narrative.
A continuación, utilizo eventReactive() para crear una reactiva que sólo se actualice cuando se haga clic en el botón o cambien los datos subyacentes:
narrative_sample<-eventReactive(list(input$story,selected()),selected()%>%pull(narrative)%>%sample(1))output$narrative<-renderText(narrative_sample())
Ejercicios
-
¿Qué ocurre si volteas
fct_infreq()yfct_lump()en el código que reduce las tablas resumen? -
Añade un control de entrada que permita al usuario decidir cuántas filas mostrar en las tablas resumen.
-
Proporciona una forma de recorrer sistemáticamente cada narración con botones de avance y retroceso.
Avanzada: Haz que la lista de narraciones sea "circular", de modo que avanzar desde la última narración te lleve a la primera.
Resumen
Ahora que ya conoces los fundamentos de las aplicaciones Shiny, los siete capítulos siguientes te proporcionarán un conjunto de técnicas importantes. Una vez que hayas leído el siguiente capítulo sobre el flujo de trabajo, te recomiendo que hojees los capítulos restantes para que te hagas una idea de lo que cubren, y luego vuelvas a sumergirte en ellos cuando necesites las técnicas para una aplicación.
Get Dominar el brillo now with the O’Reilly learning platform.
O’Reilly members experience books, live events, courses curated by job role, and more from O’Reilly and nearly 200 top publishers.
