library(tidyverse)
## Warning: package 'purrr' was built under R version 4.3.3
library(broom) # tidy model results
## Warning: package 'broom' was built under R version 4.3.3
library(umap) # dimension reduction
library(plotly)
library(janitor)
## Warning: package 'janitor' was built under R version 4.3.3
#interactive visualization
employed <- read_csv("https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2021/2021-02-23/employed.csv")
1 convert data to standarized form
employed_grouped <- employed %>%
filter(!is.na(employ_n)) %>%
group_by(occupation = paste(industry, minor_occupation), race_gender) %>%
summarise(n = sum(employ_n)) %>%
ungroup()
employed_tidy <-employed_grouped %>%
# remove total category
filter(race_gender != "TOTAL") %>%
# Add total column
left_join(employed_grouped %>%
filter(race_gender == "TOTAL") %>%
select(occupation, total = n)) %>%
# Get pct in total
mutate(pct =n / total) %>%
# Remove outliers
filter(total > 1000) %>%
select(-n)
employed_tidy
## # A tibble: 1,160 × 4
## occupation race_gender total pct
## <chr> <chr> <dbl> <dbl>
## 1 Agriculture and related Construction and extractio… Asian 7.3 e4 0.0274
## 2 Agriculture and related Construction and extractio… Black or A… 7.3 e4 0.0822
## 3 Agriculture and related Construction and extractio… Men 7.3 e4 0.973
## 4 Agriculture and related Construction and extractio… White 7.3 e4 0.863
## 5 Agriculture and related Construction and extractio… Women 7.3 e4 0.0274
## 6 Agriculture and related Farming, fishing, and fore… Asian 5.74e6 0.0139
## 7 Agriculture and related Farming, fishing, and fore… Black or A… 5.74e6 0.0342
## 8 Agriculture and related Farming, fishing, and fore… Men 5.74e6 0.789
## 9 Agriculture and related Farming, fishing, and fore… White 5.74e6 0.911
## 10 Agriculture and related Farming, fishing, and fore… Women 5.74e6 0.211
## # ℹ 1,150 more rows
employed_standard <- employed_tidy %>%
# Standardize
group_by(race_gender) %>%
mutate(pct = pct %>% scale() %>% as.numeric()) %>%
ungroup() %>%
mutate(total = total %>% log() %>% scale() %>% as.numeric())
employed_standard
## # A tibble: 1,160 × 4
## occupation race_gender total pct
## <chr> <chr> <dbl> <dbl>
## 1 Agriculture and related Construction and extractio… Asian -1.30 -0.539
## 2 Agriculture and related Construction and extractio… Black or A… -1.30 -0.405
## 3 Agriculture and related Construction and extractio… Men -1.30 1.31
## 4 Agriculture and related Construction and extractio… White -1.30 0.725
## 5 Agriculture and related Construction and extractio… Women -1.30 -1.30
## 6 Agriculture and related Farming, fishing, and fore… Asian 0.819 -0.928
## 7 Agriculture and related Farming, fishing, and fore… Black or A… 0.819 -1.21
## 8 Agriculture and related Farming, fishing, and fore… Men 0.819 0.510
## 9 Agriculture and related Farming, fishing, and fore… White 0.819 1.38
## 10 Agriculture and related Farming, fishing, and fore… Women 0.819 -0.503
## # ℹ 1,150 more rows
4 Select optimal number of clusters
kclust <- tibble(k = 1:9) %>%
mutate(kclust = map(.x = k, .f = ~ kmeans(occupation_demo_tbl %>%
select(-occupation), centers = .x, nstart = 20)),
glanced = map(.x =kclust, .f = glance))
kclust %>%
unnest(glanced) %>%
ggplot(aes(k, tot.withinss)) +
geom_point() +
geom_line()
final_cluster <- kmeans(occupation_demo_tbl %>%
select(-occupation), centers = 5, nstart = 20)
augment(final_cluster, occupation_demo_tbl) %>%
ggplot(aes(total, asian, color = .cluster)) +
geom_point()
5 Reduce dimension using UMAP
umap_results <- occupation_demo_tbl %>%
select(-occupation) %>%
umap()
umap_results_tbl <- umap_results$layout %>%
as.tibble() %>%
bind_cols(occupation_demo_tbl %>% select(occupation))
## Warning: `as.tibble()` was deprecated in tibble 2.0.0.
## ℹ Please use `as_tibble()` instead.
## ℹ The signature and semantics have changed, see `?as_tibble`.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.
## Warning: The `x` argument of `as_tibble.matrix()` must have unique column names if
## `.name_repair` is omitted as of tibble 2.0.0.
## ℹ Using compatibility `.name_repair`.
## ℹ The deprecated feature was likely used in the tibble package.
## Please report the issue at <https://github.com/tidyverse/tibble/issues>.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.
umap_results_tbl
## # A tibble: 232 × 3
## V1 V2 occupation
## <dbl> <dbl> <chr>
## 1 -2.90 -8.72 Agriculture and related Construction and extraction occupations
## 2 -3.27 6.93 Agriculture and related Farming, fishing, and forestry occupat…
## 3 0.116 -4.80 Agriculture and related Installation, maintenance, and repair …
## 4 7.60 0.416 Agriculture and related Manage-ment, business, and financial o…
## 5 -2.60 7.04 Agriculture and related Management, business, and financial op…
## 6 4.20 -4.29 Agriculture and related Office and administrative support occu…
## 7 0.159 -4.80 Agriculture and related Production occupations
## 8 1.54 -4.91 Agriculture and related Professional and related occupations
## 9 -2.61 -8.59 Agriculture and related Protective service occupations
## 10 -2.50 -8.56 Agriculture and related Sales and related occupations
## # ℹ 222 more rows
umap_results_tbl %>%
ggplot(aes(V1, V2, text = occupation)) +
geom_point()
Visualize clusters by adding k-means results
kmeans_umap_tbl <- final_cluster %>%
augment(occupation_demo_tbl) %>%
select(occupation, .cluster) %>%
# Add umap results
left_join(umap_results_tbl) %>%
# Add employment info
left_join(employed_tidy %>%
select(-total)%>%
pivot_wider(names_from = race_gender, values_from = pct) %>% janitor::clean_names())
kmeans_umap_tbl
## # A tibble: 232 × 9
## occupation .cluster V1 V2 asian black_or_african_ame…¹ men white
## <chr> <fct> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 Agricultur… 4 -2.90 -8.72 0.0274 0.0822 0.973 0.863
## 2 Agricultur… 3 -3.27 6.93 0.0139 0.0342 0.789 0.911
## 3 Agricultur… 4 0.116 -4.80 0.0155 0.0309 0.985 0.918
## 4 Agricultur… 4 7.60 0.416 0.00992 0.00794 0.739 0.967
## 5 Agricultur… 3 -2.60 7.04 0.00997 0.00882 0.741 0.962
## 6 Agricultur… 4 4.20 -4.29 0.0233 0.0155 0.159 0.938
## 7 Agricultur… 4 0.159 -4.80 0.0332 0.104 0.815 0.820
## 8 Agricultur… 4 1.54 -4.91 0.0339 0.0373 0.675 0.902
## 9 Agricultur… 4 -2.61 -8.59 0 0.0682 0.864 0.875
## 10 Agricultur… 4 -2.50 -8.56 0 0.0213 0.585 0.968
## # ℹ 222 more rows
## # ℹ abbreviated name: ¹black_or_african_american
## # ℹ 1 more variable: women <dbl>
g <- kmeans_umap_tbl %>%
# Create text table
mutate(text_label = str_glue("Occupation: {occupation}
Cluster: {.cluster}
Asian. {asian %>% scales::percent(1)}
women: {women %>% scales::percent(1)}")) %>%
# Plot
ggplot(aes(V1, V2, color = .cluster, text = text_label)) +
geom_point()
g %>% plotly::ggplotly(tooltip = "text")
