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列，直到sum（df $ var）的总和不等于零时所有（-）减值都变为“ gone”。

Answer 1

可接受的答案效果很好，但我想我会添加一个将问题视为线性编程问题的方法。如果

您需要将问题扩展到大量商店或
您最终确定从商店a到商店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的约束。在正常的运输问题中，我们还需要与发送方和接收方之间的每个链接相关联的成本。这将是一个可以称为C的SxR矩阵。然后，我们将寻求最小化成本的解决方案，并使用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

^{由reprex package（v0.2.1）于2019-03-21创建}

Answer 2

这是一个整洁的解决方案。它依赖于每个sku的净值为零。

如果是这种情况，那么我们应该能够将所有捐赠的物品（负var中每个单位一行，按sku排序）与所有收到的物品（每行一行）对齐正var，按sku排序）。因此，前五个捐赠的苹果与前五个捐赠的苹果相匹配，依此类推。

然后，我们将每个供体和受者对之间的每个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 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

根据总变量填写列联表

3 个答案:

编辑：更正了符号并添加了`complete`以匹配OP解决方案

根据总变量填写列联表

3 个答案:

编辑：更正了符号并添加了complete以匹配OP解决方案

编辑：更正了符号并添加了`complete`以匹配OP解决方案