Заполнить таблицу сопряженности на основе общей переменной

Question

У меня есть список магазинов, и у меня есть продукт (яблоки).Я запустил систему линейных уравнений, чтобы получить столбец 'var';это значение представляет количество яблок, которое вы получите или должны будете отдать другому магазину Я не могу понять, как сделать из него «действенный кадр данных».Я не могу найти правильные термины, чтобы правильно объяснить, что я хочу, поэтому надеюсь, что ниже поможет:

Данные:

df <- data.frame(store = c('a', 'b', 'c', 'd', 'e', 'f'), 
                 sku = c('apple', 'apple', 'apple', 'apple', 'apple', 'apple'), 
                 var = c(1,4,-6,-1,5,-3))

Вывод, который я хочу (или что-то подобное):

output <- data.frame(store = c('a', 'b', 'c', 'd', 'e', 'f'), sku = c('apple', 'apple', 'apple', 'apple', 'apple', 'apple'), var = c(1,4,-6,-1,5,-3), ship_to_a = c(0,0,1,0,0,0), ship_to_b = c(0,0,4,0,0,0), ship_to_c = c(0,0,0,0,0,0), ship_to_d = c(0,0,0,0,0,0), ship_to_e = c(0,0,1,1,0,3), ship_to_f = c(0,0,0,0,0,0))

Бонус: в идеале, я хотел бы заполнить ship_to_storeстолбцы, пока все (-) минус значения не исчезнут, когда сумма (df $ var) не будет считаться до нуля.

Answer 1

Вот решение Tidyverse.Это зависит от наличия чистого нуля каждого sku.

Если это так, то мы должны иметь возможность выстроить все пожертвованные предметы (по одной строке для каждой единицы в отрицательные значения var с, отсортированные по sku) со всеми полученными предметами (одна строка длякаждый положительный var, отсортированный по sku).Следовательно, первые 5 подаренных яблок сопоставляются с первыми 5 полученными яблоками и так далее.

Затем мы суммируем итоговую сумму для каждого sku между каждой парой доноров и получателей и распределяем так, чтобы каждый получатель получал столбец.

Редактирование: исправленный знак и добавление complete в соответствии с решением OP

library(tidyverse)
output <- bind_cols(

  # Donors, for whom var is negative
  df %>% filter(var < 0) %>% uncount(-var) %>% select(-var) %>%
    arrange(sku) %>% rename(donor = store),

  # Recipients, for whom var is positive
  df %>% filter(var > 0) %>% uncount(var) %>% 
    arrange(sku) %>% rename(recipient = store)) %>%

  # Summarize and spread by column
  count(donor, recipient, sku) %>%
  complete(donor, recipient, sku, fill = list(n = 0)) %>%
  mutate(recipient = paste0("ship_to_", recipient)) %>%
  spread(recipient, n, fill = 0)


> output
# A tibble: 6 x 8
  donor sku   ship_to_a ship_to_b ship_to_c ship_to_d ship_to_e ship_to_f
  <fct> <fct>     <dbl>     <dbl>     <dbl>     <dbl>     <dbl>     <dbl>
1 a     apple         0         0         0         0         0         0
2 b     apple         0         0         0         0         0         0
3 c     apple         1         4         0         0         1         0
4 d     apple         0         0         0         0         1         0
5 e     apple         0         0         0         0         0         0
6 f     apple         0         0         0         0         3         0

Answer 2

Принятый ответ работает хорошо, но я подумал, что добавлю ответ, который подходит к проблеме как к проблеме линейного программирования.Это было бы полезно, если

1. Вам нужно масштабировать проблему до большого количества магазинов, или
2. В итоге вы решаете, что между доставкой от магазина к магазину существуют реальные расхождения.f вместо хранилища a - хранилище b, и вам нужно решение с минимальными затратами

Структура вашей задачи - это задача линейного программирования, известная как проблема переноса.Ваш случай является чистым: 1. Перемещение товара от любого отправителя к любому получателю стоит одинаково и 2. Ваша система сбалансирована, поскольку спрос = предложение.

Самый простой способ подумать об ограниченияхна решение проблемы (я думаю) с точки зрения матрицы мест, которые отправляют товары по сравнению с теми, кто их получает.Мы можем сделать эту матрицу из вашего игрушечного примера:

# Load the data
df <- data.frame(store = c('a', 'b', 'c', 'd', 'e', 'f'), 
                 sku = c('apple', 'apple', 'apple', 'apple', 'apple', 'apple'), 
                 var = c(1,4,-6,-1,5,-3))
df
#>   store   sku var
#> 1     a apple   1
#> 2     b apple   4
#> 3     c apple  -6
#> 4     d apple  -1
#> 5     e apple   5
#> 6     f apple  -3

# Seeing the row-column constraints
sol.mat <- matrix(c(1,4,1,0,0,1,0,0,3), nrow = 3, byrow = TRUE)
rownames(sol.mat) <- -1 * df$var[df$var < 0]
colnames(sol.mat) <- df$var[df$var >= 0]
sol.mat
#>   1 4 5
#> 6 1 4 1
#> 1 0 0 1
#> 3 0 0 3

То, что эта матрица показывает нам, - то, что решение для предложенной вами системы удовлетворяет ограничениям, что все суммы строк равны сумме, которую нужно отправитькаждый магазин и все суммы столбцов равняются сумме, которая будет получена.Любое решение должно соответствовать этим критериям.Таким образом, если у нас есть S отправителей (строки) и R получателей (столбцы), у нас есть SxR неизвестные.Если мы называем каждое неизвестное x_ij, где i индексирует отправителя, а j получателя, мы получаем ограничения, которые (A) sum_j x_ij = S_i и (B) sum_i x_ij = R_j.В нормальной транспортной задаче у нас также будет стоимость, связанная с каждой ссылкой между отправителем и получателем.Это будет матрица SxR, которую мы можем назвать C. Затем мы будем искать решение, которое минимизирует затраты, и решать численно с помощью min sum_i sum_j x_ij * c_ij с учетом (A) и (B).

Тот факт, чтозатраты не фигурируют в вашем обсуждении, просто означает, что все маршруты стоят одинаковоМы все еще можем использовать эту же структуру проблемы, чтобы решить ее, используя существующие библиотеки R для линейного программирования.Я собираюсь использовать пакет lpSolve, который имеет функцию для решения именно такой проблемы, которая называется lp.transport.Ниже я пишу функцию-оболочку около lp.transport, которая принимает ваши известные значения и имена магазинов и определяет правильное решение.Функция также может принимать предоставленную пользователем матрицу затрат (SxR) и может возвращать вывод либо в компактной форме матрицы SxR, либо в качестве более крупной матрицы, на которую вы стремитесь:

get_transport_matrix <- function(vals, labels, costs = NULL, bigmat = TRUE) {
  if (sum(vals) != 0) {stop("Demand and Supply are Imbalanced!")}
  S <- -1 * vals[which(vals < 0)]
  names(S) <- labels[which(vals < 0)]
  R <- vals[which(vals >=0)]
  names(R) <- labels[which(vals >=0)]

  if (is.null(costs)) {
    costs.mat <- matrix(1, length(S), length(R))
  } else {
    costs.mat <- costs
  }

  solution <- lpSolve::lp.transport(costs.mat, direction = 'min',
                           row.signs = rep("=", length(S)),
                           row.rhs = S,
                           col.signs = rep("=", length(R)),
                           col.rhs = R)$solution

  rownames(solution) <- names(S)
  colnames(solution) <- names(R)

  if (!bigmat) {
    return(solution)
  } else {
    bigres <- matrix(0, length(vals), length(vals), 
                     dimnames = list(labels, labels))
    bigres[names(S), names(R)] <- solution
    colnames(bigres) <- paste0("ship_to_", colnames(bigres))
    return(bigres)
  }
}

Мы можем продемонстрироватьработать с данными вашей игрушки, чтобы увидеть, как это работает.Здесь я возвращаю только небольшую матрицу отправитель-получатель.Как мы видим, решение отличается от того, которое вы предоставили, но также действительно.

get_transport_matrix(df$var, df$store, bigmat = FALSE)
#>   a b e
#> c 0 1 5
#> d 0 1 0
#> f 1 2 0

Использование пакета линейного программирования легко масштабируется.Вот, например, мы решаем для 10 магазинов:

get_transport_matrix(c(-10:-1, 10:1), 
                     c(letters[1:10], letters[1:10]),
                     bigmat = FALSE)[1:6,]
#>   a b c d e f g h i j
#> a 0 0 0 0 0 0 4 3 2 1
#> b 0 0 0 0 4 5 0 0 0 0
#> c 0 0 0 6 2 0 0 0 0 0
#> d 0 0 6 1 0 0 0 0 0 0
#> e 0 4 2 0 0 0 0 0 0 0
#> f 0 5 0 0 0 0 0 0 0 0

Наконец, вывод функции по умолчанию представлен в формате большой матрицы, и вы можете просто cbind() передать его на свой фрейм данных, чтобы получить желаемый вывод:

cbind(df, get_transport_matrix(df$var, df$store))
#>   store   sku var ship_to_a ship_to_b ship_to_c ship_to_d ship_to_e
#> a     a apple   1         0         0         0         0         0
#> b     b apple   4         0         0         0         0         0
#> c     c apple  -6         0         1         0         0         5
#> d     d apple  -1         0         1         0         0         0
#> e     e apple   5         0         0         0         0         0
#> f     f apple  -3         1         2         0         0         0
#>   ship_to_f
#> a         0
#> b         0
#> c         0
#> d         0
#> e         0
#> f         0

^{Создано в 2019-03-21 с помощью пакета представитель (v0.2.1)}

Answer 3

Могу поспорить, есть более простые способы сделать это, но этот работает.
Функция fun выводит результат identical в ожидаемый.

fun <- function(DF){
  n <- nrow(DF)
  mat <- matrix(0, nrow = n, ncol = n)
  VAR <- DF[["var"]]
  neg <- which(DF[["var"]] < 0)
  for(k in neg){
    S <- 0
    Tot <- abs(DF[k, "var"])
    for(i in seq_along(VAR)){
      if(i != k){
        if(VAR[i] > 0){
          if(S + VAR[i] <= Tot){
            mat[k, i] <- VAR[i]
            S <- S + VAR[i]
            VAR[i] <- 0
          }else{
            mat[k, i] <- Tot - S
            S <- Tot
            VAR[i] <- VAR[i] - Tot + S
          }
        }
      }
    }
  }
  colnames(mat) <- paste0("ship_to_", DF[["store"]])
  cbind(DF, mat)
}

out <- fun(df)
identical(output, out)
#[1] TRUE