test-code/incremental.R

In ttrodrigz/onezero: Analysis tools for binary (0/1) data

library(tidyverse)
library(rlang)
library(collapse)
library(onezero)
library(glue)

x <- turf(FoodSample, Bisque:Ribeye, k = c(1, 3, 5, 7, 9))

best <-
    x %>%
    show_top_combos(n = 1) %>%
    filter(k == 5)

incremental(x = x, k = 8, combo = 11)

incremental(x = x, items = c("Bisque", "Chili", "Turkey", "Salmon", "PorkChop"))


incremental <- function(x, k, combo, items) {

    # Set up the turf output --------------------------------------------------

    # Only include the k sizes that are <= length of the number of items
    # If the items are specified directly then use them, if not, then the `k`
    # and `combos` are both needed

    turf.res <- x$turf

    # Items specified directly
    if (!missing(items)) {

        tgt.items <- items

        k <- length(tgt.items)

        tgt.res <-
            turf.res %>%
            filter(k == length(tgt.items)) %>%
            unnest(results)

        tgt.idx <-
            tgt.res %>%
            select(matches("^i")) %>%
            apply(1, \(x) all(x %in% tgt.items))

        tgt.res <- tgt.res[tgt.idx, ]

        if (nrow(tgt.res) == 0) {
            rlang::abort(
                glue("A combo of size {k} with the following items does not exist:\n{paste(tgt.items, collapse = ', ')}")
            )
        }

    } else {

        tgt.res <-
            turf.res %>%
            semi_join(tibble(k = k), by = "k") %>%
            unnest(results) %>%
            semi_join(tibble(combo = combo), by = "combo")

        if (nrow(tgt.res) == 0) {
            rlang::abort(
                glue("Combo #{combo} of size {k} does not exist.")
            )
        }

        tgt.items <-
            tgt.res %>%
            select(matches("^i")) %>%
            unlist() %>%
            unname()

    }


    n.items <- length(tgt.items)


    # Remove excess combinations ----------------------------------------------

    # Do not need k outside of number of target items
    k.range <- turf.res$k[between(turf.res$k, min(turf.res$k), n.items)]

    turf.res <- filter(turf.res, k %in% k.range)

    # Do not want combos that have items that are not included in the targets

    trim_fat <- function(indiv_turf_res, tgt_items = tgt.items) {

        idx <-
            indiv_turf_res %>%
            select(matches("^i")) %>%
            as.matrix() %>%
            apply(MARGIN = 1, FUN = function(x) all(x %in% tgt_items))

        indiv_turf_res[idx, ]

    }

    trim.res <- mutate(
        .data = turf.res,
        results = map(results, trim_fat)
    )


    # Do the incremental reach ------------------------------------------------

    out.list <- list()

    for (i in 1:nrow(trim.res)) {

        if (i == 1) {

            now <-
                trim.res %>%
                slice(i) %>%
                unnest(results) %>%
                slice_max(
                    order_by = tibble(reach, freq, shap),
                    n = 1,
                    with_ties = FALSE
                )

            out.list[[i]] <- now

        } else if (i < nrow(trim.res)) {

            # search the prior run to find the items that were used
            before <-
                out.list[[i-1]] %>%
                select(matches("^i")) %>%
                unlist() %>%
                unname()

            now <-
                trim.res %>%
                slice(i) %>%
                unnest(results)

            idx <-
                now %>%
                select(matches("^i")) %>%
                as.matrix() %>%
                apply(MARGIN = 1, FUN = function(x) all(before %in% x))

            out.list[[i]] <-
                now[idx, ] %>%
                slice_max(
                    order_by = tibble(reach, freq, shap),
                    n = 1,
                    with_ties = FALSE
                )

        } else {

            out.list[[i]] <-
                trim.res %>%
                slice(i) %>%
                unnest(results)
        }

    }

    out.df <- bind_rows(out.list)


    # Remap the items in order ------------------------------------------------

    items <-
        out.df %>%
        select(matches("^i")) %>%
        as.matrix()

    nr <- nrow(items)

    for (i in 2:nr) {

        before <- unname(items[i-1, , drop = TRUE])
        before <- before[!is.na(before)]
        now <- unname(items[i, , drop = TRUE])
        now <- now[!is.na(now)]

        reordered <- c(
            now[order(match(now, before))],
            rep(NA, times = ncol(items) - length(now))
        )

        items[i, ] <- reordered

    }

    out.df %>%
        select(-matches("^i")) %>%
        bind_cols(items) %>%
        mutate(
            inc_reach = reach - lag(reach),
            .after = reach
        )



}

incremental(x = x, k = 7, combo = 3)


x %>%
    pluck("turf") %>%
    filter(k == 7) %>%
    unnest(results) %>%
    arrange(desc(shap))

x <- turf(FoodSample, Bisque:Ribeye, k = c(1, 3, 5, 7, 8, 9, 10))

y <- incremental(x = x, combo = 1, k = 10)


y2 <-
    y %>%
    rowwise() %>%
    mutate(
        items = list(c(c_across(matches("^i_"))))
    ) %>%
    ungroup() %>%
    mutate(
        items = map(items, utilitybelt::drop_na_vec),
        before = lag(items),
        new = map2(
            .x = items,
            .y = before,
            .f = \(x, y) x[!x %in% y]
        )
    ) %>%
    select(k, reach, inc_reach, new) %>%
    mutate(new = map_chr(new, paste, collapse = "\n")) %>%
    mutate(new = fct_inorder(new)) %>%
    mutate(new = fct_rev(new))

y2 %>%
    mutate(reach_before = lag(reach)) %>%
    mutate(reach_before = replace_na(reach_before, 0)) %>%
    mutate(inc_reach = ifelse(is.na(inc_reach), reach, inc_reach)) %>%
    ggplot() +
    geom_segment(
        aes(
            x = reach_before,
            xend = reach,
            y = new,
            yend = new
        ),
        linewidth = 10,
        lineend = "butt",
        color = "indianred"
    ) +
    geom_text(
        aes(label = scales::percent(inc_reach, 0.1),
            x = reach, y = new),
        hjust = 0,
        nudge_x = 0.002,
        size = 3.25
    ) +
    theme_minimal() +
    scale_x_continuous(
        breaks = seq(0, 1, by = 0.05),
        labels = scales::percent,
        # expand = c(0.05, 0)
    ) +
    labs(
        x = "Reach",
        y = NULL,
        title = "Incremental Reach"
    )