-
Notifications
You must be signed in to change notification settings - Fork 4
/
app_5.R
317 lines (253 loc) · 15.6 KB
/
app_5.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
library(ggplot2)
library(shiny)
library(dplyr)
library(DT)
# read in data
dogs <- read.csv("dogs.csv")
top_dogs <- dogs %>% filter(x2020_rank < 25) %>%
arrange(breed)
# define UI
ui <- fluidPage(theme = shinythemes::shinytheme("united"),
# use shiny feedback
shinyFeedback::useShinyFeedback(),
# navbar page layout with pages at top
navbarPage("Dog Breed Explorer",
# page 1
tabPanel("Explore dog breeds",
# sidebar layout
sidebarLayout(
# sidebar
sidebarPanel(
h2("Breed Characteristics"),
# INPPUT: checkbox for dog sizes
shinyWidgets::checkboxGroupButtons(
inputId = "size",
size = "sm",
label = h4("Size of dog"),
choices = c("X-Small","Small","Medium","Large", "X-Large"),
selected = c("X-Small","Small","Medium","Large", "X-Large"),
individual = TRUE,
status = "primary",
checkIcon = list(
yes = icon("square-check"),
no = icon("square")
)),
# INPUT: drop down options for dog coat type
selectInput("coat", label = h4("Type of coat"),
choices = unique(dogs$coat_type),
selected = unique(dogs$coat_type),
multiple = TRUE),
h2("Personality traits"),
h5("Scored from 1:5, with 5 indicating the HIGHEST level e.g. most friendly, most playful"),
br(), # blank row
# INPUT: sliders for personality traits
# HTML styling for colour of barstags$head(tags$style(
shinyWidgets::setSliderColor(c("Orange ", "Orange", "Orange", "Orange"), c(1, 2, 3, 4)),
# sliders
sliderInput("openness_level",
label = "Opennness with strangers",
min = 1,
max = 5,
value = c(1,5)),
sliderInput("playfulness_level",
label = "Playfulness",
min = 1,
max = 5,
value = c(1,5)),
sliderInput("energy_level",
label = "Energy levels",
min = 1,
max = 5,
value = c(1,5)),
sliderInput("barking_level",
label = "Barking tendencies",
min = 1,
max = 5,
value = c(1,5)),
# action button to initiate filtering
shinyWidgets::actionBttn("goButton", "Filter dogs!",
color = "success",
style = "pill")
),
# main panel
mainPanel(
h3("Most popular dogs"),
# OUTPUT: datatable showing most popular dogs within criteria
dataTableOutput("rank_table")
))),
# page 2
tabPanel("Compare dog breeds",
# sidebar layout
sidebarLayout(
sidebarPanel(
h2("Select Dog Breed(s)"),
# INPUT: drop down for different breeds
selectInput("breed", label = h4("Select dog breed(s)"),
choices = unique(dogs$breed),
selected =unique(dogs$breed)[c(25,83)], # 2 selected as default
multiple = TRUE) # multiple selections possible
),
# main panel
mainPanel(
tabsetPanel(
# OUTPUT: radar plot of personality traits for given breed(s)
tabPanel("Personality", plotOutput("radar_pers", height = "800px", width="900px")),
# OUTPUT: bar plot of other traits for given breed(s)
tabPanel("Other characteristics", plotOutput("bar_characteristics", height = "600px")),
# OUTPUT: line plot of popularity for given breed(s) over time
tabPanel("Popularity over time", plotOutput("popularity", height = "600px"))
)))),
# page 3
tabPanel("Size vs Trait Explorer",
fluidRow(width=12,
column(width=6,
selectInput("trait_selection", label="Select a trait to visualise against breed size",
choices = names(dogs[,c(6:8, 14:21)])),
plotly::plotlyOutput("trait_bubble", height = "500px", width = "600px")),
column(width=6,
h4("Click a point to see the chosen breed below:"),
htmlOutput("dog_pic")))),
# page 4
tabPanel("About",
fluidRow(
column(width=7,
h4("This app was created by Kaitlyn Hair as an example app for an", em("Introduction to R Shiny"), " workshop at",
tags$a(href="https://esmarconf.org/", strong("ESMARConf2023")),
br(),
br(),
"All materials relating to this workshop can materials can be found on ", tags$a(href="https://github.com/kaitlynhair/dog_breed_explorer", strong("this Github repository")),
br(),
br(),
"This app was motivated by a ", tags$a(href="https://github.com/rfordatascience/tidytuesday", strong("#TidyTuesday dogs dataset")), "from February 2022.",
br(),
br(),
"This idea was also inspired by Kaitlyn's English Cocker Spaniel Alfie, who happens to be an extremely good boy (most of the time)!", icon("paw")),
),
column(width = 5,
img(src='alfie.jpg', align = "centre", width="500px"))))
))
# server
server <- function(input, output) {
# create datatable with dog popularity rankings
output$rank_table <- DT::renderDataTable({
# Take a dependency on input$goButton
input$goButton
# creating a dataframe with the input filters applied
df <- dogs %>%
filter(openness_to_strangers >= isolate(input$openness_level[1])) %>%
filter(openness_to_strangers <= isolate(input$openness_level[2])) %>%
filter(energy_level >= isolate(input$energy_level[1])) %>%
filter(energy_level <= isolate(input$energy_level[2])) %>%
filter(barking_level >= isolate(input$barking_level[1])) %>%
filter(barking_level <= isolate(input$barking_level[2])) %>%
filter(playfulness_level >= isolate(input$playfulness_level[1])) %>%
filter(playfulness_level <= isolate(input$playfulness_level[2])) %>%
filter(size_category %in% isolate(input$size)) %>%
filter(coat_type %in% isolate(input$coat)) %>%
select(breed, x2020_rank, image) %>%
arrange(x2020_rank) %>%
rename(rank = x2020_rank) %>%
select(rank, breed, image) %>%
mutate(image = paste0("<img src=", "'", image, "'", " height='72'></img>"))
# rendering a datatable using that data
DT::datatable(df, rownames = FALSE, options = list(pageLength = 10), escape=FALSE) # escape is false to allow HTML code in images
})
# reactive dataframe with selected dogs
selected_dogs <- reactive({
dogs <- dogs %>%
filter(breed %in% input$breed)
})
output$popularity <-renderPlot({
selected_dogs() %>%
select(breed, contains("_rank")) %>%
tidyr::pivot_longer(-breed, names_to ="Year", values_to="Popularity Ranking") %>%
mutate(Year = gsub("x", "", Year)) %>%
mutate(Year = gsub("_rank", "", Year)) %>%
select(breed, Year, `Popularity Ranking`) %>%
rename(Breed = breed) %>%
ggplot(aes(x=Year, y=`Popularity Ranking`, group=Breed, colour=Breed)) +
geom_line(linewidth=3) +
scale_y_reverse() +
theme_minimal() +
theme(text = element_text(size = 16)) +
scale_colour_manual(values = c(rgb(0.2,0.5,0.5,0.9), rgb(0.8,0.2,0.5,0.9) , rgb(0.7,0.5,0.1,0.9))
)
})
# render radar plot with personality traits
output$radar_pers <-renderPlot({
# select relevant columns of reactive dataframe
data <- selected_dogs()[,c(1,6:8, 14:21)]
# user feedback
smaller_than_4 <- length(input$breed) < 4
shinyFeedback::feedbackWarning("breed", !smaller_than_4, "Please select three or fewer breeds to compare!")
# make breed the row name
rownames(data) <- paste0(data$breed)
data <- data %>%
select(-breed)
# add two lines to dataframe - with 11 columns
# all values for first line should be max value in radar
# all values for second line should be min value in radar
data <- rbind(rep(5,11) , rep(0,11), data)
# check data
head(data)
# Color vector
colors_border=c( rgb(0.2,0.5,0.5,0.9), rgb(0.8,0.2,0.5,0.9) , rgb(0.7,0.5,0.1,0.9) )
colors_in=c( rgb(0.2,0.5,0.5,0.4), rgb(0.8,0.2,0.5,0.4) , rgb(0.7,0.5,0.1,0.4) )
# plot with default options:
fmsb::radarchart(data , axistype=1 ,
#custom polygon
pcol=colors_border , pfcol=colors_in , plwd=4 , plty=1,
#custom the grid
cglcol="grey", cglty=1, axislabcol="grey", caxislabels=seq(1,5,1), cglwd=0.8,
#custom labels
vlcex=0.8
) +
theme_minimal() +
theme(text = element_text(size = 16))
legend(x=0.8, y=0.8, legend = rownames(data[-c(1,2),]), bty = "n", pch=20 , col=colors_in , text.col = "grey", cex=1.2, pt.cex=3)
})
# render bar plot with characteristics
output$bar_characteristics <-renderPlot({
selected_dogs()[,c(1,5,9:11)] %>% # select relevant columns
mutate(size_category = gsub("Medium", 3, size_category)) %>% #convert text to numerical values
mutate(size_category = gsub("X-Large", 5, size_category)) %>%
mutate(size_category = gsub("X-Small", 1, size_category)) %>%
mutate(size_category = gsub("Large", 4, size_category)) %>%
mutate(size_category = gsub("Small", 2, size_category)) %>%
mutate(size_category = as.numeric(size_category)) %>%
tidyr::pivot_longer(-breed, names_to="characteristic", values_to="score") %>%
ggplot(aes(x=characteristic, y=score, fill=breed)) +
geom_line(aes(group = characteristic), linewidth=2) +
geom_point(aes(color = breed), size=7, alpha=0.7) +
coord_flip() +
theme_minimal() +
labs(y = "Lower -> Higher Scores", x= "") +
theme(text = element_text(size = 16)) +
scale_colour_manual(values = c(rgb(0.2,0.5,0.5,0.9), rgb(0.8,0.2,0.5,0.9) , rgb(0.7,0.5,0.1,0.9))
)
})
output$trait_bubble <- plotly::renderPlotly({
# create bubble plot
# tidy evaluation here to pass the input$trait_selection argument for x
p <- ggplot(top_dogs, aes(fill = breed,
x=.data[[input$trait_selection]], y=avg_weight_kg)) +
geom_point(alpha=0.5, size=5) +
viridis::scale_color_viridis(discrete=TRUE, guide=FALSE) +
xlab(snakecase::to_title_case(input$trait_selection)) + ylab("Weight (kg)") + theme_light() +
theme(legend.position = "none")
# use plotly for interactivity
plotly::ggplotly(p) %>% plotly::event_register('plotly_click')
})
# generate output image based on clicked bubble plot selection
observeEvent(plotly::event_data("plotly_click"), {
point <- plotly::event_data("plotly_click")
dogs_selected <- top_dogs %>%
filter(avg_weight_kg == paste0(point$y)) %>%
mutate(image = paste0("<img src=", "'", image, "'", " height='250'></img>"))
output$dog_pic <- renderText(
dogs_selected$image
)
})
}
# Run the application
shinyApp(ui = ui, server = server)