В маркетинге очень популярен когортный анализ. Его популярность вызвана, скорее всего, легкостью алгоритма и вычислений. Никаких серьезных математических концепций в основе нет, элементарная математика, выполняемая в excel. С точки зрения получения инсайтов гораздо интереснее анализ дожития.
Тем не менее, считаем, что есть такая задача и ее надо решить. Искать какие-либо пакеты и готовые функции неинтересно математика проста, параметров настройки масса. Ниже возможный пример реализации (без особой фиксации на скорость исполнения), всего кода на пару десятков строк.
Является продолжением серии предыдущих публикаций.
Немного кода
При создании тестового набора мы можем особо не акцентироваться на временнх зонах, все равно данные случайные.
# генерируем данные на 15 недельset.seed(42)events_dt <- tibble(user_id = 1000:9000) %>% mutate(birthday = Sys.Date() + as.integer(rexp(n(), 1/10))) %>% rowwise() %>% mutate(timestamp = list(as_datetime(birthday) + 24*60*60 * ( rexp(10^3, rate = 1/runif(1, 2, 25))))) %>% ungroup() %>% unnest(timestamp) %>% # режем длинные хвосты в прошлом и в будущем filter(timestamp >= quantile(timestamp, probs = 0.1), timestamp <= quantile(timestamp, probs = 0.95)) %>% mutate(date = as_date(timestamp)) %>% select(user_id, date) %>% setDT(key = c("user_id", "date")) %>% # оставим только уникальные по датам события unique()
Посмотрим на получившееся интегральное распределение
ggplot(events_dt, aes(date)) + geom_histogram()
Шаг 1. Формируем справочник пользователей
В настоящем примере справочник будет тривиальным и содержит
только "дату рождения", т.е. дату, когда мы первый раз встретились
с ним. Установка ключей для data.table объекта
приводит к физической сортировке данных в порядке появления
ключей.
users_dict <- events_dt[, .(birthday = head(date, 1)), by = user_id] %>% # для последующей сортировки оставим дату начала недели .[, week_start := floor_date(.BY[[1]], unit = "week"), by = birthday] %>% # переведем даты рождения в номера когорт .[, cohort := stri_c( lubridate::isoyear(.BY[[1]]), sprintf("%02d", lubridate::isoweek(.BY[[1]])), sep = "/"), by = week_start]# посмотрим на распределение дат, нам нужен разброс для красивой картинкиas_tibble(janitor::tabyl(users_dict, birthday))
Шаг 2. Подготовим разметку в терминах когортного анализа
Совсем за скоростью пока не гонимся.
Составим справочник когорт. Для сокращения преобразований и обеспечения последующей сортировки.
cohort_dict <- unique(users_dict[, .(cohort, week_start)])cohort_tbl <- users_dict[events_dt, on = "user_id"] %>% # посчитаем удаленность событий от даты рождения в терминах недель .[, rel_week := floor(as.numeric(difftime(date, birthday, units = "week")))] %>% # оставим только 10 недель .[rel_week <= 9] %>% # редуцируем до уникальных пользователей unique(by = c("user_id", "cohort", "rel_week")) %>% # считаем агрегаты в терминах когорт и недель .[, .N, by = .(cohort, rel_week)] %>% .[, rate := N/max(N), by = cohort]
Шаг 3. Визуализируем
Вариант 1. ggplot
# вариант ggplotdata_tbl <- cohort_tbl %>% # вернем числовые показатели когорт для сортировки left_join(cohort_dict)data_tbl %>% mutate(cohort_group = forcats::fct_reorder(cohort, week_start, .desc = TRUE)) %>% ggplot(mapping = aes(x = rel_week, y = cohort_group, fill = rate)) + geom_tile() + geom_text(aes(label = N), colour = "darkgray") + labs(x = "Недели существования когорты", y = "Неделя появления когорты", fill = "Количество\nпользователей", title = "graph_title") + scale_fill_viridis_c(option = "inferno") + scale_x_continuous(breaks = scales::breaks_width(1)) + theme_minimal() + theme(panel.grid = element_blank())
Вариант 2. gt
Для оформления используем тот факт, что у нас всегда по две строки на когорту и они отсортированы в нужном порядке.
# подготовим табличку-подложкуdata_tbl <- cohort_tbl %>% pivot_longer(cols = c(N, rate)) %>% pivot_wider(names_from = rel_week, values_from = value) %>% # вернем числовые показатели когорт для сортировки left_join(cohort_dict) %>% arrange(week_start, desc(name))odd_rows <- seq(1, to = nrow(data_tbl), by = 2)even_rows <- seq(2, to = nrow(data_tbl), by = 2)tab <- data_tbl %>% mutate(cohort = if_else(rep(c(TRUE, FALSE), length.out = nrow(.)), cohort, "")) %>% select(-name, -week_start) %>% gt(rowname_col = "cohort") %>% fmt_percent(columns = matches("[0-9]+"), rows = odd_rows, decimals = 0, pattern = "<big>{x}</big>") %>% fmt_missing(columns = everything(), missing_text = "---") %>% tab_stubhead(label = "Неделя появления когорты") %>% tab_spanner(label = "Неделя существования когорты", columns = everything()) %>% tab_header(title = "Развертка") %>% data_color(columns = everything(), colors = scales::col_numeric(palette = "inferno", domain = c(0, 1), alpha = 0.6, na.color = "lightgray")) %>% tab_options( table.font.size = "smaller", data_row.padding = px(1), table.width = pct(75) ) %>% tab_style( style = list( cell_fill(color = "white"), cell_text(style = "italic"), cell_borders(sides = "bottom") ), locations = cells_body( columns = everything(), rows = even_rows) ) %>% tab_style( style = list( cell_borders(sides = "top") ), locations = cells_body( columns = everything(), rows = odd_rows) )tab
Каркас приведен, прочее каждый может модифицировать под себя.
Предыдущая публикация R и работа со временем. Что за кулисами?.
