Improving search result relevancy on Wikipedia with BM25 ranking

SELECT
  LEFT(`timestamp`, 8) AS date,
  event_subTest AS test_group,
  `timestamp` AS ts,
  event_uniqueId AS event_id,
  event_mwSessionId AS session_id,
  event_searchSessionId AS search_id,
  event_pageViewId AS page_id,
  event_searchToken AS cirrus_id,
  CAST(event_query AS CHAR CHARACTER SET utf8) AS query,
  event_hitsReturned AS n_results_returned,
  event_msToDisplayResults AS load_time,
  CASE WHEN event_action = 'searchResultPage' THEN 'SERP' ELSE 'click' END AS action,
  event_position AS position_clicked
FROM TestSearchSatisfaction2_15700292
WHERE
  LEFT(`timestamp`, 8) >= '20160830' AND LEFT(`timestamp`, 8) <= '20160910'
  AND event_source = 'fulltext'
  AND LEFT(event_subTest, 4) = 'bm25'
  AND (
    (event_action = 'searchResultPage' AND event_hitsReturned IS NOT NULL AND event_msToDisplayResults IS NOT NULL)
    OR
    (event_action = 'click' AND event_position IS NOT NULL AND event_position > -1)
  )
ORDER BY date, wiki, session_id, search_id, page_id, action DESC, timestamp;

# Install packages used in the report:
install.packages(c("devtools", "tidyverse", "binom"))
devtools::install_github("hadley/ggplot2")
# ^ development version of ggplot2 includes subtitles
devtools::install_github("wikimedia/wikimedia-discovery-polloi")
# ^ for converting 100000 into 100K via polloi::compress()

# Load packages that we will be using in this report:
library(tidyverse) # for ggplot2, dplyr, tidyr, broom, etc.
library(binom) # for Bayesian confidence intervals of proportions

overlapping_results <- function(x) {
  if (all(is.na(x))) {
    return(diag(length(x)))
  }
  input <- strsplit(stringr::str_replace_all(x, "[\\[\\]]", ""), ",")
  output <- vapply(input, function(y) {
    temp <- vapply(input, function(z) { length(intersect(z, y)) }, 0L)
    # Normalize by diving by number of possible matches
    # e.g. if two queries have two results each that are
    #      exactly the same, that's worth more than if
    #      two queries have 20 results each but have
    #      only three in common
    temp <- temp/pmin(rep(length(y), length(input)), vapply(input, length, 0L))
    temp[is.na(x)] <- 0L
    return(temp)
  }, rep(0.0, length(input)))
  diag(output) <- 1L
  return(output)
}

cluster_queries <- function(queries, results, linkage = c("complete", "single", "average"), threshold = NULL, debug = FALSE) {
  if (length(queries) < 2) {
    return(1)
  }
  input <- data.frame(query = queries, stringsAsFactors = FALSE)
  x <- do.call(rbind, lapply(input$query, function(x) {
    # Compute for each x in input$query the normalized edit distance from x to input$query:
    normalized_distances <- adist(tolower(x), tolower(input$query), fixed = TRUE)/pmax(nchar(x), nchar(input$query))
    # Return:
    return(normalized_distances)
  }))
  # Decrease distance of queries that share results:
  overlaps <- overlapping_results(results)
  x <- x * (10^(-overlaps))
  # ^ if two queries have the exact same results, we make the new
  #   edit distance 0.1 of what their original edit distance is
  # Create distance object:
  y <- x[lower.tri(x, diag = FALSE)]
  d <- structure(
    y, Size = length(queries), Labels = queries, Diag = FALSE, Upper = FALSE,
    method = "levenshtein", class = "dist", call = match.call()
  )
  clustering_tree <- hclust(d, method = linkage[1])
  # When using average linkage, we may end up with funky trees
  #   that cannot be properly cut. So this logic helps against
  #   errors and yieds NAs instead.
  clusters <- tryCatch(
    cutree(clustering_tree, h = threshold),
    error = function(e) { return(NA) })
  if (all(is.na(clusters))) {
    clusters <- rep(clusters, nrow(input))
    names(clusters) <- input$query
  }
  output <- left_join(
    input,
    data.frame(query = names(clusters),
               cluster = as.numeric(clusters),
               stringsAsFactors = FALSE),
    by = "query")
  if (debug) {
    return(
      list(
        original_distances = x / (10^(-overlaps)),
        overlaps = overlaps,
        modified_distances = d,
        output = output,
        hc = clustering_tree
      )
    )
  }
  return(output$cluster)
}

# PaulScore Calculation
query_score <- function(positions, F) {
   if (length(positions) == 1 || all(is.na(positions))) {
    # no clicks were made
    return(0)
   } else {
     positions <- positions[!is.na(positions)] # when operating on 'events' dataset, SERP events won't have positions
  return(sum(F^positions))
   }
}
# Bootstrapping
bootstrap_mean <- function(x, m, seed = NULL) {
  if (!is.null(seed)) {
    set.seed(seed)
  }
  n <- length(x)
  return(replicate(m, mean(x[sample.int(n, n, replace = TRUE)])))
}

# Correct for when user uses pagination or uses back button to go back to SERP after visiting a result.
# Start by assigning the same page_id to different SERPs that have exactly the same query:
temp <- events %>%
  filter(action == "SERP") %>%
  group_by(session_id, search_id, query) %>%
  mutate(new_page_id = min(page_id)) %>%
  ungroup %>%
  select(c(page_id, new_page_id)) %>%
  distinct
# We also need to do the same for associated click events:
events <- left_join(events, temp, by = "page_id"); rm(temp)
# Find out which SERPs are duplicated:
temp <- events %>%
  filter(action == "SERP") %>%
  arrange(new_page_id, ts) %>%
  mutate(dupe = duplicated(new_page_id, fromLast = FALSE)) %>%
  select(c(event_id, dupe))
events <- left_join(events, temp, by = "event_id"); rm(temp)
events$dupe[events$action == "click"] <- FALSE
# Remove duplicate SERPs and re-sort:
events <- events[!events$dupe & !is.na(events$new_page_id), ] %>%
  select(-c(page_id, dupe)) %>%
  rename(page_id = new_page_id) %>%
  arrange(date, session_id, search_id, page_id, desc(action), ts)

# Summarize on a page-by-page basis:
searches <- events %>%
  group_by(`test group` = test_group, session_id, search_id, page_id) %>%
  filter("SERP" %in% action) %>% # filter out searches where we have clicks but not SERP events
  summarize(ts = ts[1], query = query[1],
            results = ifelse(n_results_returned[1] > 0, "some", "zero"),
            clickthrough = "click" %in% action,
            `first clicked result's position` = ifelse(clickthrough, position_clicked[2], NA),
            `result page IDs` = result_pids[1],
            `Query score (F=0.1)` = query_score(position_clicked, 0.1),
            `Query score (F=0.5)` = query_score(position_clicked, 0.5),
            `Query score (F=0.9)` = query_score(position_clicked, 0.9)) %>%
  arrange(ts)
# Cluster queries
safe_clust <- function(search_id, page_ids, queries, results, threshold, linkage) {
  clusters <- cluster_queries(queries, results, linkage, threshold)
  if (length(clusters) != length(page_ids)) {
    stop("Number of cluster labels does not match number of searches for search session ", unlist(search_id)[1])
  } else {
    return(clusters)
  }
}

searches <- searches %>%
  group_by(`test group`, session_id, search_id) %>%
  mutate(
    cluster_single = safe_clust(search_id, page_id, query, `result page IDs`, 0.301, "single"),
    cluster_average = safe_clust(search_id, page_id, query, `result page IDs`, 0.433, "average"),
    cluster_complete = safe_clust(search_id, page_id, query, `result page IDs`, 0.45, "complete")
  )

most_common <- function(x) {
  if (all(is.na(x))) {
    return(as.character(NA))
  } else {
     return(names(sort(table(x), decreasing = TRUE))[1])
  }
}

summarize_reformulations <- function(grouped_data) {
  return({
    grouped_data %>%
      # Count number of similar searches made in a single search session
      # (multiple search sessions per MW session allowed)
      summarize(
        reformulations = n() - 1,
        clickthrough = any(clickthrough),
        results = ifelse("some" %in% results, "some", "zero"),
        `most popular position clicked first` = most_common(`first clicked result's position`),
        `Cluster score (F=0.1)` = mean(`Query score (F=0.1)`, na.rm = TRUE),
        `Cluster score (F=0.5)` = mean(`Query score (F=0.5)`, na.rm = TRUE),
        `Cluster score (F=0.9)` = mean(`Query score (F=0.9)`, na.rm = TRUE)
      ) %>%
      ungroup
  })
}

set.seed(0) # for reproducibility
query_reformulations_single <- searches %>%
  group_by(`test group`, session_id, search_id, cluster = cluster_single) %>%
  summarize_reformulations
query_reformulations_complete <- searches %>%
  group_by(`test group`, session_id, search_id, cluster = cluster_complete) %>%
  summarize_reformulations
query_reformulations_average <- searches %>%
  ungroup %>%
  filter(!is.na(cluster_average)) %>%
  group_by(`test group`, session_id, search_id, cluster = cluster_average) %>%
  summarize_reformulations
query_reformulations <- bind_rows(
  "Queries grouped via average linkage" = query_reformulations_average,
  "Queries grouped via complete linkage" = query_reformulations_complete,
  "Queries grouped via single linkage" = query_reformulations_single,
  .id = "linkage")
rm(query_reformulations_average, query_reformulations_complete, query_reformulations_single)

# Calculate proportions of searches with 0, 1, 2, 3+ query reformulations
query_reformulations %>%
  mutate(`query reformulations` = forcats::fct_lump(factor(reformulations), 3, other_level = "3+")) %>%
  group_by(linkage, `test group`, `query reformulations`) %>%
  tally %>%
  mutate(proportion = n/sum(n)) %>%
  ggplot(aes(x = `query reformulations`, y = proportion, fill = `test group`)) +
  geom_bar(stat = "identity", position = "dodge") +
  scale_y_continuous(labels = scales::percent_format()) +
  scale_fill_brewer("Test Group", palette = "Set1", guide = guide_legend(ncol = 2)) +
  facet_wrap(~ linkage, ncol = 3) +
  labs(y = "Proportion of searches", x = "Approximate number of query reformulations per search session",
       title = "Number of query reformulations by test group and linkage",
       subtitle = "Queries were grouped via hierarchical clustering using average/complete/single linkage and edit distance adjusted by search results in common") +
  theme_minimal(base_family = "Lato") +
  theme(legend.position = "bottom",
        strip.background = element_rect(fill = "gray90"),
        panel.border = element_rect(color = "gray30", fill = NA))

# Calculate proportion of searches where user reformulated their query
reformulation_counts <- query_reformulations %>%
  group_by(linkage, `test group`) %>%
  summarize(`searches with query reformulations` = sum(reformulations > 0),
            searches = n(),
            proportion = `searches with query reformulations`/searches) %>%
  ungroup
reformulation_counts <- cbind(
  reformulation_counts,
  as.data.frame(
    binom:::binom.bayes(
      reformulation_counts$`searches with query reformulations`,
      n = reformulation_counts$searches)[, c("mean", "lower", "upper")]
  )
)

reformulation_counts %>%
  ggplot(aes(x = 1, y = mean, color = `test group`)) +
  geom_hline(aes(yintercept = mean), linetype = "dashed", color = RColorBrewer::brewer.pal(3, "Set1")[1],
             data = filter(reformulation_counts, `test group` == "Control Group (tf–idf)")) +
  geom_pointrange(aes(ymin = lower, ymax = upper), position = position_dodge(width = 1)) +
  scale_y_continuous(labels = scales::percent_format(),
                     breaks = seq(.10, .24, 0.01),
                     minor_breaks = seq(.10, .24, 0.005),
                     expand = c(0.01, 0.01)) +
  scale_color_brewer("Test Group", palette = "Set1", guide = guide_legend(ncol = 2)) +
  facet_wrap(~ linkage, ncol = 3) +
  geom_text(aes(label = sprintf("%.1f%%", 100 * proportion), y = upper + 0.0025, vjust = "bottom"),
            position = position_dodge(width = 1)) +
  labs(y = "% of searches with query reformulations", x = NULL,
       title = "Searches with reformulated queries by test group (and linkage)",
       subtitle = "Queries were grouped via hierarchical clustering using average/complete/single linkage and edit distance adjusted by search results in common") +
  theme_minimal(base_family = "Lato") +
  theme(legend.position = "bottom",
        panel.grid.major.x = element_blank(),
        panel.grid.minor.x = element_blank(),
        axis.ticks.x = element_blank(),
        axis.text.x = element_blank(),
        strip.background = element_rect(fill = "gray90"),
        panel.border = element_rect(color = "gray30", fill = NA))

zrr_pages <- searches %>%
  group_by(`test group`, results) %>%
  tally %>%
  spread(results, n) %>%
  mutate(`zero results rate` = zero/(some + zero)) %>%
  ungroup
zrr_pages <- cbind(zrr_pages, as.data.frame(binom:::binom.bayes(zrr_pages$zero, n = zrr_pages$some + zrr_pages$zero)[, c("mean", "lower", "upper")]))

zrr_pages %>%
  ggplot(aes(x = `test group`, y = `mean`, color = `test group`)) +
  geom_hline(
    yintercept = zrr_pages$`mean`[zrr_pages$`test group` == "Control Group (tf–idf)"],
    linetype = "dashed", color = "gray50") +
  geom_pointrange(aes(ymin = lower, ymax = upper)) +
  scale_x_discrete(limits = rev(levels(events$test_group))) +
  scale_y_continuous(labels = scales::percent_format()) +
  scale_color_brewer("Test Group", palette = "Set1", guide = FALSE) +
  labs(x = NULL, y = "Zero Results Rate",
       title = "Proportion of searches that did not yield any results, by test group",
       subtitle = "With 95% credible intervals. Dashed line represents the baseline (ZRR of the control group).") +
  geom_text(aes(label = sprintf("%.2f%%", 100 * `zero results rate`),
                vjust = "bottom", hjust = "center"), nudge_x = 0.1) +
  coord_flip() +
  theme_minimal(base_family = "Lato")

set.seed(0) # for reproducibility
paulscores <- searches %>%
  ungroup %>%
  filter(results == "some") %>%
  select(c(`test group`, `Query score (F=0.1)`, `Query score (F=0.5)`, `Query score (F=0.9)`)) %>%
  gather(`F value`, `Query score`, -`test group`) %>%
  mutate(`F value` = sub("^Query score \\(F=(0\\.[159])\\)$", "F = \\1", `F value`)) %>%
  group_by(`test group`, `F value`) %>%
  summarize(
    PaulScore = mean(`Query score`),
    Interval = paste0(quantile(bootstrap_mean(`Query score`, 1000), c(0.025, 0.975)), collapse = ",")
  ) %>%
  extract(Interval, into = c("Lower", "Upper"), regex = "(.*),(.*)", convert = TRUE)

paulscores %>%
  ggplot(aes(x = `F value`, y = PaulScore, color = `test group`)) +
  geom_pointrange(aes(ymin = Lower, ymax = Upper), position = position_dodge(width = 0.7)) +
  scale_color_brewer("Test Group", palette = "Set1", guide = guide_legend(ncol = 2)) +
  labs(x = NULL, y = "PaulScore(F)",
       title = "PaulScore(F) by test group and value of F",
       subtitle = "With bootstrapped 95% confidence intervals. Dashed line indicates baseline (control group) for comparing test groups.") +
  geom_text(aes(label = sprintf("%.3f", PaulScore), y = Upper + 0.01, vjust = "bottom"),
            position = position_dodge(width = 0.7)) +
  theme_minimal(base_family = "Lato") +
  theme(legend.position = "bottom") +
  annotate("segment",
           x = (0:2) + 0.6, xend = (1:3) + 0.4,
           y = paulscores$PaulScore[paulscores$`test group` == "Control Group (tf–idf)"],
           yend = paulscores$PaulScore[paulscores$`test group` == "Control Group (tf–idf)"],
           color = RColorBrewer::brewer.pal(3, "Set1")[1],
           linetype = "dashed")

engagement_overall <- searches %>%
  filter(results == "some") %>%
  group_by(`test group`) %>%
  summarize(clickthroughs = sum(clickthrough > 0),
            searches = n(), ctr = clickthroughs/searches) %>%
  ungroup
engagement_overall <- cbind(
  engagement_overall,
  as.data.frame(
    binom:::binom.bayes(
      engagement_overall$clickthroughs,
      n = engagement_overall$searches)[, c("mean", "lower", "upper")]
    )
  )

engagement_overall %>%
  ggplot(aes(x = 1, y = mean, color = `test group`)) +
  geom_hline(aes(yintercept = mean), linetype = "dashed", color = RColorBrewer::brewer.pal(3, "Set1")[1],
             data = filter(engagement_overall, `test group` == "Control Group (tf–idf)")) +
  geom_pointrange(aes(ymin = lower, ymax = upper), position = position_dodge(width = 1)) +
  scale_color_brewer("Test Group", palette = "Set1", guide = guide_legend(ncol = 2)) +
  scale_y_continuous(labels = scales::percent_format(), expand = c(0.01, 0.01)) +
  labs(x = NULL, y = "Clickthrough rate",
       title = "Engagement with search results by test group") +
  geom_text(aes(label = sprintf("%.1f%%", 100 * ctr), y = upper + 0.0025, vjust = "bottom"),
            position = position_dodge(width = 1)) +
  theme_minimal(base_family = "Lato") +
  theme(legend.position = "bottom")

# Figure out engagement (clickthroughs) on a per-search ("query cluster") basis:
per_search_engagement <- query_reformulations %>%
  filter(results == "some") %>%
  group_by(`test group`, linkage,
           search = paste(search_id, cluster),
           reformulated = reformulations > 0) %>%
  summarize(clickthroughs = sum(clickthrough), `non-ZR searches` = n())

engagement <- per_search_engagement %>%
  group_by(`test group`, linkage,
           reformulated = ifelse(reformulated, "reformulated query", "did not reformulate query")) %>%
  summarize(clickthroughs = sum(clickthroughs > 0),
            searches = n(), ctr = clickthroughs/searches) %>%
  ungroup
engagement <- cbind(
  engagement,
  as.data.frame(
    binom:::binom.bayes(
      engagement$clickthroughs,
      n = engagement$searches)[, c("mean", "lower", "upper")]
    )
  )

engagement %>%
  ggplot(aes(x = 1, y = mean, color = `test group`)) +
  geom_hline(aes(yintercept = mean), linetype = "dashed", color = RColorBrewer::brewer.pal(3, "Set1")[1],
             data = filter(engagement, `test group` == "Control Group (tf–idf)")) +
  geom_pointrange(aes(ymin = lower, ymax = upper), position = position_dodge(width = 1)) +
  facet_grid(reformulated ~ linkage, scales = "free_y") +
  scale_color_brewer("Test Group", palette = "Set1", guide = guide_legend(ncol = 2)) +
  scale_y_continuous(labels = scales::percent_format(), expand = c(0.01, 0.01)) +
  labs(x = NULL, y = "Clickthrough rate",
       title = "Engagement with search results by test group and presence of query reformulation",
       subtitle = "Queries were grouped via hierarchical clustering using average/complete/single linkage and edit distance adjusted by search results in common") +
  geom_text(aes(label = sprintf("%.1f%%", 100 * ctr), y = upper + 0.005, vjust = "bottom"),
            position = position_dodge(width = 1)) +
  theme_minimal(base_family = "Lato") +
  theme(legend.position = "bottom",
        panel.grid.major.x = element_blank(),
        panel.grid.minor.x = element_blank(),
        axis.ticks.x = element_blank(),
        axis.text.x = element_blank(),
        strip.background = element_rect(fill = "gray90"),
        panel.border = element_rect(color = "gray30", fill = NA))

safe_ordinals <- function(x) {
  return(vapply(x, toOrdinal::toOrdinal, ""))
}
first_clicked <- searches %>%
  filter(results == "some" & clickthrough & !is.na(`first clicked result's position`)) %>%
  mutate(`first clicked result's position` = ifelse(`first clicked result's position` < 4, safe_ordinals(`first clicked result's position` + 1), "5th or higher")) %>%
  group_by(`test group`, `first clicked result's position`) %>%
  tally %>%
  mutate(total = sum(n), prop = n/total) %>%
  ungroup
set.seed(0)
temp <- as.data.frame(binom:::binom.bayes(first_clicked$n, n = first_clicked$total, tol = .Machine$double.eps^0.1)[, c("mean", "lower", "upper")])
first_clicked <- cbind(first_clicked, temp); rm(temp)

first_clicked %>%
  ggplot(aes(x = 1, y = mean, color = `test group`)) +
  geom_hline(
    aes(yintercept = mean), 
    linetype = "dashed", color = RColorBrewer::brewer.pal(3, "Set1")[1],
    data = filter(first_clicked, `test group` == "Control Group (tf–idf)")
  ) +
  geom_pointrange(aes(ymin = lower, ymax = upper), position = position_dodge(width = 1)) +
  geom_text(aes(label = sprintf("%.1f", 100 * prop), y = upper + 0.0025, vjust = "bottom"),
            position = position_dodge(width = 1)) +
  scale_y_continuous(labels = scales::percent_format(),
                     expand = c(0, 0.005), breaks = seq(0, 1, 0.01)) +
  scale_color_brewer("Test Group", palette = "Set1", guide = guide_legend(ncol = 2)) +
  facet_wrap(~ `first clicked result's position`, scale = "free_y", nrow = 1) +
  labs(x = NULL, y = "Proportion of searches",
       title = "Position of the first clicked result",
       subtitle = "With 95% credible intervals") +
  theme_minimal(base_family = "Lato") +
  theme(legend.position = "bottom",
        panel.grid.major.x = element_blank(),
        panel.grid.minor.x = element_blank(),
        axis.ticks.x = element_blank(),
        axis.text.x = element_blank(),
        strip.background = element_rect(fill = "gray90"),
        panel.border = element_rect(color = "gray30", fill = NA))