Apply it to your data 1
Nils Skogestig
2025-02-08
Click here for the data. Goal: Predict future price of IKEA furniture
Import data
ikea <- readr::read_csv('https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2020/2020-11-03/ikea.csv')## New names:
## Rows: 3694 Columns: 14
## ── Column specification
## ──────────────────────────────────────────────────────── Delimiter: "," chr
## (7): name, category, old_price, link, other_colors, short_description, d... dbl
## (6): ...1, item_id, price, depth, height, width lgl (1): sellable_online
## ℹ Use `spec()` to retrieve the full column specification for this data. ℹ
## Specify the column types or set `show_col_types = FALSE` to quiet this message.
## • `` -> `...1`skimr::skim(ikea)| Name | ikea |
| Number of rows | 3694 |
| Number of columns | 14 |
| _______________________ | |
| Column type frequency: | |
| character | 7 |
| logical | 1 |
| numeric | 6 |
| ________________________ | |
| Group variables | None |
Variable type: character
| skim_variable | n_missing | complete_rate | min | max | empty | n_unique | whitespace |
|---|---|---|---|---|---|---|---|
| name | 0 | 1 | 3 | 27 | 0 | 607 | 0 |
| category | 0 | 1 | 4 | 36 | 0 | 17 | 0 |
| old_price | 0 | 1 | 4 | 13 | 0 | 365 | 0 |
| link | 0 | 1 | 52 | 163 | 0 | 2962 | 0 |
| other_colors | 0 | 1 | 2 | 3 | 0 | 2 | 0 |
| short_description | 0 | 1 | 3 | 63 | 0 | 1706 | 0 |
| designer | 0 | 1 | 3 | 1261 | 0 | 381 | 0 |
Variable type: logical
| skim_variable | n_missing | complete_rate | mean | count |
|---|---|---|---|---|
| sellable_online | 0 | 1 | 0.99 | TRU: 3666, FAL: 28 |
Variable type: numeric
| skim_variable | n_missing | complete_rate | mean | sd | p0 | p25 | p50 | p75 | p100 | hist |
|---|---|---|---|---|---|---|---|---|---|---|
| …1 | 0 | 1.00 | 1846.50 | 1066.51 | 0 | 923.25 | 1846.5 | 2769.75 | 3693 | ▇▇▇▇▇ |
| item_id | 0 | 1.00 | 48632396.79 | 28887094.10 | 58487 | 20390574.00 | 49288078.0 | 70403572.75 | 99932615 | ▇▇▇▇▇ |
| price | 0 | 1.00 | 1078.21 | 1374.65 | 3 | 180.90 | 544.7 | 1429.50 | 9585 | ▇▁▁▁▁ |
| depth | 1463 | 0.60 | 54.38 | 29.96 | 1 | 38.00 | 47.0 | 60.00 | 257 | ▇▃▁▁▁ |
| height | 988 | 0.73 | 101.68 | 61.10 | 1 | 67.00 | 83.0 | 124.00 | 700 | ▇▂▁▁▁ |
| width | 589 | 0.84 | 104.47 | 71.13 | 1 | 60.00 | 80.0 | 140.00 | 420 | ▇▅▂▁▁ |
data <- ikea %>%
# Handle missing values
filter(!is.na(height), !is.na(width), !is.na(depth)) %>%
# Convert all character variables to factors for machine learning compatibility
mutate(across(where(is.character), as.factor)) %>%
mutate(across(is.logical, as.factor)) %>%
# Handle multiple designers by splitting them into separate rows
separate_rows(designer, sep = "/") %>%
# Remove unnecessary columns
select(-...1, -link, -old_price, -designer, -name) %>%
# Log transform price to address skewness
mutate(price = log(price))## Warning: There was 1 warning in `mutate()`.
## ℹ In argument: `across(is.logical, as.factor)`.
## Caused by warning:
## ! Use of bare predicate functions was deprecated in tidyselect 1.1.0.
## ℹ Please use wrap predicates in `where()` instead.
## # Was:
## data %>% select(is.logical)
##
## # Now:
## data %>% select(where(is.logical))Explore Data - Identifying good predictors
# Step 1: Prepare data by binarising data
binarized_table <- data %>%
select(-item_id, -short_description) %>%
binarize()
binarized_table %>% glimpse()## Rows: 2,714
## Columns: 35
## $ category__Bar_furniture <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1…
## $ category__Beds <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `category__Bookcases_&_shelving_units` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `category__Cabinets_&_cupboards` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ category__Café_furniture <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ category__Chairs <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `category__Chests_of_drawers_&_drawer_units` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `category__Children's_furniture` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ category__Nursery_furniture <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ category__Outdoor_furniture <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `category__Sofas_&_armchairs` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `category__Tables_&_desks` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `category__TV_&_media_furniture` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ category__Wardrobes <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `category__-OTHER` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `price__-Inf_5.84354441703136` <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1…
## $ price__5.84354441703136_6.75693238924755 <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ price__6.75693238924755_7.52023455647463 <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ price__7.52023455647463_Inf <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ sellable_online__TRUE <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1…
## $ `sellable_online__-OTHER` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ other_colors__No <dbl> 0, 1, 1, 1, 1, 1, 1, 1, 1…
## $ other_colors__Yes <dbl> 1, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `depth__-Inf_40` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ depth__40_48 <dbl> 0, 0, 1, 1, 1, 1, 1, 1, 1…
## $ depth__48_66 <dbl> 1, 1, 0, 0, 0, 0, 0, 0, 0…
## $ depth__66_Inf <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `height__-Inf_74` <dbl> 0, 1, 0, 0, 0, 0, 0, 0, 0…
## $ height__74_95 <dbl> 0, 0, 1, 1, 1, 1, 1, 0, 0…
## $ height__95_180.75 <dbl> 1, 0, 0, 0, 0, 0, 0, 1, 1…
## $ height__180.75_Inf <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `width__-Inf_60` <dbl> 1, 0, 1, 1, 1, 1, 1, 1, 1…
## $ width__60_100 <dbl> 0, 1, 0, 0, 0, 0, 0, 0, 0…
## $ width__100_180 <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ width__180_Inf <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0…# Correlate
corr_tbl <- binarized_table %>%
correlate(price__7.52023455647463_Inf)
corr_tbl## # A tibble: 35 × 3
## feature bin correlation
## <fct> <chr> <dbl>
## 1 price 7.52023455647463_Inf 1
## 2 width 180_Inf 0.610
## 3 depth 66_Inf 0.418
## 4 width -Inf_60 -0.356
## 5 category Sofas_&_armchairs 0.343
## 6 price -Inf_5.84354441703136 -0.335
## 7 price 6.75693238924755_7.52023455647463 -0.333
## 8 price 5.84354441703136_6.75693238924755 -0.332
## 9 category Wardrobes 0.302
## 10 height -Inf_74 -0.283
## # ℹ 25 more rows# Step 3: Plot Correlation Funnel
corr_tbl %>%
plot_correlation_funnel()## Warning: ggrepel: 12 unlabeled data points (too many overlaps). Consider
## increasing max.overlaps
Product Category
data %>%
ggplot(aes(price, as.factor(category))) +
geom_boxplot()
category <- data %>%
select(price, category)
# Calculate average price per category
category_avg_price <- category %>%
group_by(category) %>%
summarise(avg_price = mean(price, na.rm = TRUE)) %>%
ungroup()
# Plot bar chart of average prices per category
ggplot(category_avg_price, aes(x = reorder(category, avg_price), y = avg_price)) +
geom_bar(stat = "identity", fill = "skyblue", color = "black") +
labs(title = "Average Price per Product Category",
x = "Product Category",
y = "Average Price (log-transformed)") +
theme_minimal() +
theme(axis.text.x = element_text(angle = 45, hjust = 1))
# Other colors available?
data %>%
ggplot(aes(price, as.factor(other_colors))) +
geom_boxplot()
Products sold online?
data %>%
ggplot(aes(price, sellable_online)) +
geom_boxplot()
Description correlation to price?
Graph below show the correlation of the short description of the products and their short description.
data %>%
# Ensure short_description is character type
mutate(short_description = as.character(short_description)) %>%
# Tokenize short descriptions
unnest_tokens(output = word, input = short_description) %>%
# Calculate average price per word
group_by(word) %>%
summarise(price = mean(price, na.rm = TRUE),
n = n()) %>%
ungroup() %>%
# Filter meaningful words
filter(n > 10, !str_detect(word, "\\d")) %>%
slice_max(order_by = price, n = 20) %>%
# Plot
ggplot(aes(price, fct_reorder(word, price))) +
geom_point() +
labs(y = "Words in Short Description",
x = "Average Price when Word is Included")