Skip to content

Commit

Permalink
Merge pull request #92 from dfe-analytical-services/88-page-3-explore…
Browse files Browse the repository at this point in the history 
…-options-for-the-characteristics-page-to-put-more-graphs-on-same-page

88 page 3 explore options for the characteristics page to put more graphs on same page
  • Loading branch information
@johalastrahol
johalastrahol authored Nov 5, 2024
2 parents 664c4a3 + 0d45b38 commit fb093f1
Show file tree
Hide file tree
Showing 3 changed files with 282 additions and 51 deletions.
325 changes: 278 additions & 47 deletions R/dashboard_modules/04-learner_characteristics.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -21,6 +21,20 @@ characteristics_no_total <- chars_parquet %>%
filter(characteristic != "Total")
chars_choices <- (data_choices(data = characteristics_no_total, column = "characteristic_type"))

# create lists for ordering the bar charts
chars_parquet_age <- chars_parquet %>% filter(characteristic_type == "Age" & characteristic != "Total")
chars_age_choices <- data_choices(data = chars_parquet_age, column = "characteristic")

chars_parquet_sex <- chars_parquet %>% filter(characteristic_type == "Sex" & characteristic != "Total")
chars_sex_choices <- data_choices(data = chars_parquet_sex, column = "characteristic")

chars_parquet_lldd <- chars_parquet %>% filter(characteristic_type ==
"Learner with learning difficulties or disabilities (LLDD)" & characteristic != "Total")
chars_lldd_choices <- data_choices(data = chars_parquet_lldd, column = "characteristic")

chars_parquet_ethnicity <- chars_parquet %>% filter(characteristic_type == "Ethnicity" & characteristic != "Total")
chars_ethnicity_choices <- data_choices(data = chars_parquet_ethnicity, column = "characteristic")

# Main module code ============================================================

learner_characteristics_ui <- function(id) {
Expand Down Expand Up @@ -53,12 +67,6 @@ learner_characteristics_ui <- function(id) {
choices = c(chars_measure_choices),
selected = "Starts"
),
selectInput(
inputId = NS(id, "characteristic_type"),
label = "Select type of characteristic",
choices = c(chars_choices),
selected = "Age"
),
)
),

Expand All @@ -67,8 +75,14 @@ learner_characteristics_ui <- function(id) {
id = "provider_learner_characteristics",
## plot tab ------------------------------------------------------------
nav_panel(
"Graphic",
plotlyOutput(NS(id, ("tree_map_plot")))
"Charts",
layout_columns(
col_widths = c(3, 3, 3, 3),
girafeOutput(NS(id, "age_bar_plot")),
girafeOutput(NS(id, "sex_bar_plot")),
girafeOutput(NS(id, "lldd_bar_plot")),
girafeOutput(NS(id, "ethnicity_bar_plot")),
)
),
## table tab ------------------------------------------------------------
nav_panel(
Expand Down Expand Up @@ -108,6 +122,7 @@ learner_characteristics_server <- function(id) {
shiny::moduleServer(id, function(input, output, session) {
# Drop downs ==============================================================
# Using the server to power to the provider dropdown for increased speed

updateSelectizeInput(
session = session,
inputId = "provider",
Expand All @@ -123,7 +138,7 @@ learner_characteristics_server <- function(id) {
chars_filtered <- chars_filtered %>% filter(provider_name == input$provider)
chars_filtered <- chars_filtered %>% filter(year == input$year)
chars_filtered <- chars_filtered %>% filter(measure == input$measure)
chars_filtered <- chars_filtered %>% filter(characteristic_type == input$characteristic_type)

# and sort into the right order

chars_filtered$characteristic_type <- factor(chars_filtered$characteristic_type,
Expand Down Expand Up @@ -157,63 +172,279 @@ learner_characteristics_server <- function(id) {
chars_filtered %>% collect()
})

# Treemap plot
# plot

output$tree_map_plot <- renderPlotly({
output$age_bar_plot <- renderGirafe({
# Message when there are none of the measure at all
validate(need(nrow(chars_reactive_table()) > 0, paste0("No ", input$measure, " for these selections.")))
validate(need(nrow(chars_reactive_table()) > 0, paste0("No ", firstlow(input$measure), " for these selections.")))

# Message when all groups are low, and treemap cannot be displayed
# Message when all groups are low, and chart cannot be displayed
# But can still be seen in the table
validate(need(
nrow(filter(chars_reactive_table(), count != "low" & characteristic != "Total")) > 0,
paste0("All groups have low numbers.")
nrow(filter(chars_reactive_table(), characteristic_type == "Age" & count != "low" &
characteristic != "Total")) > 0, paste0("All age groups have low numbers.")
))

# defines the font for the hover text
hfont <- list(
size = 20,
color = "white"
girafe(
ggobj =
chars_reactive_table() %>%
filter(characteristic_type == "Age" & characteristic != "Total") %>%
# need data in all categories else columns expand if missing data
mutate(count = ifelse(count == "low", "0", count)) %>%
ggplot(aes(
x = characteristic,
y = as.numeric(count),
tooltip = paste0(characteristic, ": ", dfeR::comma_sep(as.numeric(count)), " ", firstlow(input$measure)),
data_id = characteristic
)) +
geom_col_interactive(
fill = afcolours::af_colours(n = 4)[1],
position = position_dodge(preserve = "single")
) +
coord_flip() +
labs(title = "Age") +
xlab("") +
ylab("") +
scale_y_continuous(labels = dfeR::comma_sep) +
scale_x_discrete(
labels = function(x) str_wrap(x, width = 10),
limit = rev(chars_age_choices)
) +
ggplot2::theme_minimal() +
ggplot2::theme(
legend.position = "top",
legend.title = element_blank(),
panel.grid = element_blank(),
panel.grid.minor = element_blank(),
panel.grid.major.x = element_blank(),
plot.title = element_text(family = "Arial", face = "bold", size = 20, hjust = 0),
axis.text.x = element_text(family = "Arial", size = 15),
axis.text.y = element_text(family = "Arial", size = 20)
),
options = list(
# Set styling for bars on hover and when selected
ggiraph::opts_hover(
css = "cursor:pointer;stroke:black;stroke-width:5px;fill:#ffdd00;"
),
ggiraph::opts_selection(
type = "single", css = "fill:#12436D;stroke:#12436D;"
),
ggiraph::opts_toolbar(
saveaspng = FALSE,
hidden = c("lasso_select", "lasso_deselect")
)
),
fonts = list(sans = "Arial")
)
})

output$sex_bar_plot <- renderGirafe({
# Message when there are none of the measure at all - blank - only shown for age
validate(need(nrow(chars_reactive_table()) > 0, ""))

# Message when all groups are low, and chart cannot be displayed
# But can still be seen in the table
validate(need(
nrow(filter(chars_reactive_table(), characteristic_type == "Sex" & count != "low" &
characteristic != "Total")) > 0,
"Males and females both have low numbers."
))

girafe(
ggobj =
chars_reactive_table() %>%
filter(characteristic_type == "Sex" & characteristic != "Total") %>%
# need data in all categories else columns expand if missing data
mutate(count = ifelse(count == "low", "0", count)) %>%
ggplot(aes(x = "", y = as.numeric(count), fill = characteristic)) +
geom_col_interactive(aes(
tooltip = paste0(characteristic, ": ", dfeR::comma_sep(as.numeric(count)), " ", firstlow(input$measure)),
data_id = characteristic
), color = "white", size = 2, ) +
coord_polar(theta = "y", start = 0) +
scale_fill_manual(breaks = c("Male", "Female"), values = afcolours::af_colours("duo")) +
scale_y_discrete(limit = rev(chars_sex_choices)) +
labs(title = "Sex") +
xlab("") +
ylab("") +
# scale_y_continuous(labels = dfeR::comma_sep) +
ggplot2::theme_void() +
ggplot2::theme(
legend.position = "bottom",
legend.title = element_blank(),
legend.text = element_text(family = "Arial", size = 15),
plot.title = element_text(family = "Arial", face = "bold", size = 20, hjust = 0)
),
options = list(
# Set styling for bars on hover and when selected
ggiraph::opts_hover(
css = "cursor:pointer;stroke:black;stroke-width:5px;fill:#ffdd00;"
),
ggiraph::opts_selection(
type = "single", css = "fill:afcolours::af_colours;stroke:afcolours::af_colours;"
),
ggiraph::opts_toolbar(
saveaspng = FALSE,
hidden = c("lasso_select", "lasso_deselect")
)
),
fonts = list(sans = "Arial")
)
# defines the background for the hover text
hlabel <- list(
bgcolor = c("#12436D", "#28A197", "#801650", "#F46A25", "#3D3D3D", "#A285D1"),
bordercolor = "transparent",
font = hfont
})



output$lldd_bar_plot <- renderGirafe({
# Message when there are none of the measure at all - blank - only shown for age
validate(need(nrow(chars_reactive_table()) > 0, ""))

# Message when all groups are low, and chart cannot be displayed
# But can still be seen in the table
validate(need(
nrow(filter(chars_reactive_table(), characteristic_type ==
"Learner with learning difficulties or disabilities (LLDD)" &
count != "low" & characteristic != "Total")) > 0, "All LLDD groups have low numbers."
))

girafe(
ggobj =
chars_reactive_table() %>%
filter(characteristic_type == "Learner with learning difficulties or disabilities (LLDD)" &
characteristic != "Total") %>%
# need data in all categories else columns expand if missing data
mutate(count = ifelse(count == "low", "0", count)) %>%
ggplot(aes(
x = characteristic,
y = as.numeric(count),
tooltip = paste0(
characteristic, ": ", dfeR::comma_sep(as.numeric(count)), " ",
firstlow(input$measure)
),
data_id = characteristic
)) +
geom_col_interactive(
fill = afcolours::af_colours(n = 4)[1],
position = position_dodge(preserve = "single")
) +
coord_flip() +
labs(title = "Learner with learning difficulties\nor disabilities (LLDD)") +
xlab("") +
ylab("") +
scale_y_continuous(labels = dfeR::comma_sep) +
scale_x_discrete(
labels = function(x) str_wrap(x, width = 10),
limit = rev(chars_lldd_choices)
) +
ggplot2::theme_minimal() +
ggplot2::theme(
legend.position = "top",
legend.title = element_blank(),
panel.grid = element_blank(),
panel.grid.minor = element_blank(),
panel.grid.major.x = element_blank(),
plot.title = element_text(family = "Arial", face = "bold", size = 20, hjust = 0),
axis.text.x = element_text(family = "Arial", size = 15),
axis.text.y = element_text(family = "Arial", size = 20)
),
options = list(
# Set styling for bars on hover and when selected
ggiraph::opts_hover(
css = "cursor:pointer;stroke:black;stroke-width:5px;fill:#ffdd00;"
),
ggiraph::opts_selection(
type = "single", css = "fill:#12436D;stroke:#12436D;"
),
ggiraph::opts_toolbar(
saveaspng = FALSE,
hidden = c("lasso_select", "lasso_deselect")
)
),
fonts = list(sans = "Arial")
)
})

chars_reactive_table() %>%
filter(characteristic != "Total") %>%
filter(count != "low") %>%
plot_ly(
labels = ~ stringr::str_wrap(characteristic, width = 5),
parents = NA,
values = ~ as.numeric(count),
type = "treemap",
marker = (list(
colors = c("#12436D", "#28A197", "#801650", "#F46A25", "#3D3D3D", "#A285D1"),
sizemode = "area"
)),
textfont = list(color = "white", size = 30),
hoverinfo = "text",
hoverlabel = hlabel,
hovertext = ~ paste0(
stringr::str_wrap(characteristic, width = 15), "\n\n",
comma_sep(as.numeric(count)), " ", firstlow(measure)

output$ethnicity_bar_plot <- renderGirafe({
# Message when there are none of the measure at all - blank - only shown for age
validate(need(nrow(chars_reactive_table()) > 0, ""))

# Message when all groups are low, and chart cannot be displayed
# But can still be seen in the table
validate(need(
nrow(filter(chars_reactive_table(), characteristic_type == "Ethnicity" & count != "low" &
characteristic != "Total")) > 0, "All ethnic groups have low numbers."
))

girafe(
ggobj =
chars_reactive_table() %>%
filter(characteristic_type == "Ethnicity" & characteristic != "Total") %>%
# need data in all categories else columns expand if missing data
mutate(count = ifelse(count == "low", "0", count)) %>%
# shorten name of category to fit better
mutate(characteristic = if_else(nchar(as.character(characteristic)) > 10,
substr(characteristic, 1, 5),
characteristic
)) %>%
ggplot(aes(
x = characteristic,
y = as.numeric(count),
tooltip = paste0(
characteristic, ": ", dfeR::comma_sep(as.numeric(count)), " ",
firstlow(input$measure)
),
data_id = characteristic
)) +
geom_col_interactive(
fill = afcolours::af_colours(n = 4)[1],
position = position_dodge2(preserve = "single")
) +
coord_flip() +
labs(title = "Ethnicity") +
xlab("") +
ylab("") +
scale_y_continuous(labels = dfeR::comma_sep) +
scale_x_discrete(limit = rev(if_else(nchar(as.character(chars_ethnicity_choices)) > 10,
substr(chars_ethnicity_choices, 1, 5), chars_ethnicity_choices
))) +
ggplot2::theme_minimal() +
ggplot2::theme(
legend.position = "top",
legend.title = element_blank(),
panel.grid = element_blank(),
panel.grid.minor = element_blank(),
panel.grid.major.x = element_blank(),
plot.title = element_text(family = "Arial", face = "bold", size = 20, hjust = 0),
axis.text.x = element_text(family = "Arial", size = 15),
axis.text.y = element_text(family = "Arial", size = 20)
),
options = list(
# Set styling for bars on hover and when selected
ggiraph::opts_hover(
css = "cursor:pointer;stroke:black;stroke-width:5px;fill:#ffdd00;"
),
ggiraph::opts_selection(
type = "single", css = "fill:#12436D;stroke:#12436D;"
),
ggiraph::opts_toolbar(
saveaspng = FALSE,
hidden = c("lasso_select", "lasso_deselect")
)
) %>%
layout(hoverlabel = list(align = "left")) %>%
config(displaylogo = FALSE, displayModeBar = FALSE)
),
fonts = list(sans = "Arial")
)
})



# table

# Message when there are none of the measure at all, and no table
output$chars_table <- renderTable({
# Message when there are none of the measure at all
validate(need(nrow(chars_reactive_table()) > 0, paste0("No ", firstlow(input$measure), " for these selections.")))

chars_reactive_table_tidied <- chars_reactive_table() %>%
mutate(count = comma_sep(as.numeric(count)))
mutate(count = if_else(count != "low", as.character(dfeR::comma_sep(as.numeric(count))), count))

colnames(chars_reactive_table_tidied) <-
c(
Expand Down
2 changes: 1 addition & 1 deletion global.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -26,9 +26,9 @@ shhh(library(afcolours))
shhh(library(reactable))
shhh(library(ggplot2))
shhh(library(ggiraph))
shhh(library(treemapify))
shhh(library(leaflet))
shhh(library(plotly))
shhh(library(ggrepel))

## Data and string manipulation -----------------------------------------------
shhh(library(arrow))
Expand Down
Loading

0 comments on commit fb093f1

Please sign in to comment.