[整洁星期二]2019-05-28

By vincent507cpu at 2019-05-30 • 1人收藏 • 605人看过

数据集:https://gitee.com/R4DS/tidytuesday_cn/tree/master/data/2019/2019-05-28


展示 1:from @allison_horst

For #tidytuesday this week, I explored the sweet deal metric (points:price ratio) across all wine types by country, for the 15 countries with the most observations in the dataset. Yeah Chilean wine


代码

https://github.com/allisonhorst/allison-tidy-tuesdays



#######
# Tidy Tuesday 5/28/2019
# Wine ratings
#######

# Attach packages
library(tidyverse)
library(extrafont)
library(ggdark)

# Get the data:
wine_ratings <- readr::read_csv("https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2019/2019-05-28/winemag-data-130k-v2.csv")

# A bunch of wrangling (much unnecessary) + exploration station:

# Find the points-to-price ratios:
wine_deal <- wine_ratings %>%
  select(points, price, title) %>% # Only keep these columns
  mutate(pp_ratio = points/price) %>% # Find the points:price ratio
  arrange(-pp_ratio) # Arrange by high-to-low ratio

# Checking counts for each wine type (don't really care):
wine_counts <- wine_ratings %>%
  group_by(title) %>%
  tally() %>%
  arrange(-n)

# Find the top 15 countries with them most reviews:
country_counts <- wine_ratings %>%
  group_by(country) %>%
  tally() %>%
  arrange(-n) %>%
  head(15) %>%
  select(country)

# Find the median point:price ratio for those 15 countries:
# Note: something is effed here. (not reproducible right now)
country_medians <- wine_deal %>%
  inner_join(wine_ratings) %>%
  inner_join(country_counts) %>%
  group_by(country) %>%
  summarize(
    med_ratio = median(pp_ratio, na.rm = TRUE)
  ) %>%
  arrange(-med_ratio)

# Join to have prices, number, ratio in single table, relevel by medians:
wine_all <- wine_deal %>%
  inner_join(wine_ratings) %>%
  inner_join(wine_counts) %>%
  inner_join(country_counts) %>%
  select(title, pp_ratio, country, variety,n) %>%
  drop_na(country) %>%
  mutate(country = as.factor(country)) %>% # Not necessary?
  mutate(country = fct_relevel(country, country_medians$country))

# Violin plot of points:price ratios by country
ggplot(wine_all, aes(x = reorder(country, desc(country)), y = pp_ratio)) +
  geom_violin(aes(color = country, fill = country), width = 1.0) +
  geom_boxplot(fill = NA, color = "white", width = 0.4, size = 0.3, outlier.color = NA) +
  labs(x = "Country\n",y = "\nPoints-per-price ratio (higher = better)", title = "Wine points:price ratio (sweet deal metric) by country", subtitle = "*For the 15 countries with the highest number of reviews in Kaggle dataset") +
  dark_mode(theme_minimal()) +
  theme(legend.position = "NA",
        text = element_text(family = "Muli"),
        plot.subtitle = element_text(size = 8, face = "italic")) +
  coord_flip()

ggsave("2019-05-28/wine_deals.png", width = 5, height = 4)



IMG_3397.JPG


示例 2:from @GriffinEvo

My #TidyTuesday contribution for the week - showing the relationship between score and price for wines, and highlighting 5 key wines (best <$100 [x2], worst >$100, most expemsive 100-pointer [x2]) #Rstats Code and notes available at griffinevo.github.io


代码

library('tidyverse')

wine_ratings <- readr::read_csv("https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2019/2019-05-28/winemag-data-130k-v2.csv")

ggplot(data = wine_ratings %>% 
                filter(country == c('US', 'France', 'Italy', 'Spain', 'Portugal', 'Chile'))) +  
  # Facet plots 
  facet_wrap(~ country, nrow = 2) +  
  # Main data
  geom_point(
    mapping = aes(x = points, y = price), 
    alpha = 0.3, color = rgb(140/255, 40/255, 50/255)) +  
  # Highlight 5 key wines - 
  #   most expensive 100-pointers
  #   best wines under $100
  #   worst wine over $100
  geom_point(data = filter(wine_ratings, 
      price > 900 & points == 100| price < 100 & points == 100| price > 100 & points < 82), 
    mapping = aes(x = points, y = price), color = 'black') +  
  # Label the winery and province
  geom_text(data = filter(wine_ratings, 
      price > 900 & points == 100| price < 100 & points == 100| price > 100 & points < 82), 
    mapping = aes(x = points, y = price, label = paste0(winery, ', ', province)), size = 2.9, 
    check_overlap = T, nudge_x = c(5,-9,-9,-8,-8), nudge_y = c(100, -100, -220, 300, 420)) +  # Base theme
  theme_linedraw() +  
  # Axis titles
  labs(x = 'Wine Enthusiast Rating (out of 100)', y = 'Price ($)') +  
  # Styling
  theme(    # Facet strip color
    strip.background = element_rect(fill = rgb(140/255, 40/255, 50/255)),
    strip.text = element_text(size = 12),    # Grid lines color
    panel.grid.major = element_line('grey60'),
    panel.grid.minor = element_line('grey69'),    # Titles further from axes
    axis.title.x = element_text(margin = margin(t = 15)),
    axis.title.y = element_text(margin = margin(r = 15)),  
    # Axes title and label size
    axis.title = element_text(size = 12), 
    axis.text  = element_text(size = 12)
  ) +  
  # Grid spacings
  scale_x_continuous(minor_breaks = seq(80, 100, 1)) + 
  scale_y_continuous(limits = c(0, 1500), minor_breaks = seq(0, 1500, 100))

IMG_3396.JPG


示例 3:from @spren9er

My #tidytuesday 22|2019 contribution: Analyzing words of 129,971 wine descriptions (and their pairwise correlation) #rstats #ggraph


代码

https://github.com/spren9er/tidytuesday/blob/master/tidytuesday_201922_wine_ratings.r


library(tidyverse)
library(tidytext)
library(widyr)
library(igraph)
library(ggraph)
library(viridis)

path <-
  paste0(
    'https://raw.githubusercontent.com/rfordatascience/tidytuesday/',
    'master/data/2019/2019-05-28/'
  )

wine_ratings <- read_csv(paste0(path, 'winemag-data-130k-v2.csv')) %>%
  rename(id = X1)

# common words to describe wine: https://www.words-to-use.com/words/wine/
wine_adjectives <- read_csv2('data/wine_adjectives.csv', col_names = c('word'))

theme_options <- theme(
  legend.title = element_text(
    size = 9, margin = margin(b = 5), face = 'bold'
  ),
  legend.text = element_text(size = 7),
  legend.margin = margin(t = 15, b = 15),
  legend.key.width = unit(10, 'points'),
  plot.title = element_text(
    margin = margin(b = 12), color = '#32b37f', size = 14, hjust = 0.5,
    face = 'bold'
  ),
  plot.subtitle = element_text(
    margin = margin(b = 15), size = 11, hjust = 0.5, face = 'bold'
  ),
  plot.caption = element_text(color = '#dadada', size = 6, hjust = 1.09),
  plot.margin = margin(t = 40, r = 20, b = 20, l = 20)
)

wine_words <- wine_ratings %>%
  unnest_tokens('word', description) %>%
  filter(word %in% wine_adjectives$word) %>%
  select(id, country, points, price, variety, word)

top_wine_words <- wine_words %>%
  group_by(word) %>%
  summarize(total = n()) %>%
  arrange(desc(total)) %>%
  head(120)

threshold <- 0.02

wine_word_correlations <- wine_words %>%
  filter(word %in% top_wine_words$word) %>%
  pairwise_cor(word, id, sort = TRUE) %>%
  filter(correlation > threshold) %>%
  arrange(desc(correlation))

wine_averages_per_word <- wine_words %>%
  filter(word %in% top_wine_words$word) %>%
  group_by(word) %>%
  summarize(
    total = n(),
    avg_points = mean(points, na.rm = TRUE),
    avg_price = mean(price, na.rm = TRUE)
  ) %>%
  rename(name = word) %>%
  arrange(desc(total))

graph <- wine_word_correlations %>%
  rename(weight = correlation) %>%
  mutate(alpha = cut(weight, c(threshold, 0.05, 1))) %>%
  graph_from_data_frame(vertices = wine_averages_per_word)

ggraph(graph, layout = 'fr', niter = 15000) +
  geom_edge_link(aes(edge_alpha = alpha), edge_width = 0.2) +
  geom_node_point(aes(size = total, color = avg_points)) +
  geom_node_text(
    aes(label = name), size = 3, repel = TRUE
  ) +
  scale_color_viridis(
    limits = c(84, 91.5),
    breaks = c(85.0, 87.5, 90.0, 92.5)
  ) +
  scale_size_area(
    breaks = c(250, 1000, 2500, 5000, 10000, 25000),
    labels = function(n) { format(n, big.mark = ',') }
  ) +
  scale_edge_alpha_manual(
    values = c(0.03, 0.4), labels = c('weak', 'strong')
  ) +
  labs(
    title = paste(
      'Words in',
      format(nrow(wine_ratings), big.mark = ','),
      'Wine Descriptions I.'
    ),
    subtitle = paste(
      '120 common words to describe wine and their correlation',
      '#tidytuesday 22 | 2019',
      sep = '   •   '
    ),
    caption = '© 2019 spren9er',
    color = 'Average Rating',
    size = 'Word Count',
    edge_alpha = 'Correlation'
  ) +
  theme_void() +
  theme_options +
  guides(
    edge_alpha = guide_legend(order = 1),
    size = guide_legend(order = 2)
  )

ggsave(
  'images/tidytuesday_201922_wine_ratings_most_common_words.png',
  width = 10, height = 8.5, dpi = 300
)

################################################################################

wine_words <- wine_ratings %>%
  unnest_tokens('word', description) %>%
  anti_join(stop_words, by = 'word') %>%
  filter(
    !str_detect(word, '^\\d+$'),
    !word %in% c('alongside', 'offers', 'feels')
  ) %>%
  select(id, country, points, price, variety, word)

top_wine_words <- wine_words %>%
  count(word, sort = TRUE) %>%
  head(150)

wine_word_correlations <- wine_words %>%
  filter(word %in% top_wine_words$word) %>%
  pairwise_cor(word, id, sort = TRUE) %>%
  filter(correlation > 0.0) %>%
  arrange(desc(correlation))

wine_averages_per_word <- wine_words %>%
  filter(word %in% top_wine_words$word) %>%
  group_by(word) %>%
  summarize(
    total = n(),
    avg_points = mean(points, na.rm = TRUE),
    avg_price = mean(price, na.rm = TRUE)
  ) %>%
  rename(name = word) %>%
  arrange(desc(total))

threshold <- 0.065

graph <- wine_word_correlations %>%
  filter(correlation > threshold) %>%
  rename(weight = correlation) %>%
  mutate(alpha = cut(weight, c(0, threshold, 0.13, 1))) %>%
  graph_from_data_frame(vertices = wine_averages_per_word)

ggraph(graph, layout = 'fr', niter = 15000) +
  geom_edge_link(aes(edge_alpha = alpha), edge_width = 0.2) +
  geom_node_point(aes(size = total, color = avg_points)) +
  geom_node_text(
    aes(label = name), size = 3, repel = TRUE
  ) +
  scale_color_viridis(
    limits = c(86, 90), breaks = c(86.0, 87.0, 88.0, 89.0, 90.0)
  ) +
  scale_size_area(
    breaks = c(5000, 10000, 25000, 50000),
    labels = function(n) { format(n, big.mark = ',') }
  ) +
  scale_edge_alpha_manual(
    values = c(0.03, 0.4), labels = c('weak', 'strong')
  ) +
  labs(
    title = paste(
      'Words in',
      format(nrow(wine_ratings), big.mark = ','),
      'Wine Descriptions II.'
    ),
    subtitle = paste(
      '150 most frequent words and their correlation',
      '#tidytuesday 22 | 2019',
      sep = '   •   '
    ),
    caption = '© 2019 spren9er',
    color = 'Average Rating',
    size = 'Word Count',
    edge_alpha = 'Correlation'
  ) +
  theme_void() +
  theme_options +
  guides(
    edge_alpha = guide_legend(order = 1),
    size = guide_legend(order = 2)
  )

ggsave(
  'images/tidytuesday_201922_wine_ratings_most_frequent_words.png',
  width = 10, height = 8.5, dpi = 300
)


IMG_3406.JPG

IMG_3407.JPG


示例 4:from @AmandaPlunkett

Happy #TidyTuesday ! Today's theme is

1 个回复 | 最后更新于 2019-05-30
2019-05-30   #1

登录后方可回帖

信息栏
数据人网是数据人学习、交流和分享的平台,专注于从数据中学习,努力发觉数据之洞见,积极利用数据之价值
Loading...