Remplir le tableau de contingence en fonction de la variable totale

Je parie qu'il existe des moyens plus simples de le faire, mais celui-ci fonctionne.
La fonction fun génère un résultat identique à celui attendu.

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

Voici une solution tidyverse. Il repose sur l'existence d'un zéro net de chaque sku.

Si tel est le cas, alors nous devrions être en mesure d'aligner tous les éléments donnés (une ligne pour chaque unité dans les var s négatifs, triés par sku) avec tous les éléments reçus (un ligne pour chaque var positive, triée par sku). Par conséquent, les 5 premières pommes données sont appariées aux 5 premières pommes reçues, et ainsi de suite.

Ensuite, nous totalisons le total pour chaque sku entre chaque paire donateur et receveur et répartissons de manière à ce que chaque destinataire reçoive une colonne.

Modifier: signe corrigé et ajouté complet code> pour correspondre à la solution 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

La réponse acceptée fonctionne bien mais j'ai pensé en ajouter une qui aborde le problème comme un problème de programmation linéaire. Cela serait utile si

1. Vous devez étendre le problème à un grand nombre de magasins ou
2. Vous finissez par décider qu'il existe de véritables différences de coût entre l'expédition du magasin a au magasin f et le magasin a au magasin b et vous voulez une solution à coût minimal

La structure de votre problème est un problème de programmation linéaire connu sous le nom de problème de transport. Le vôtre est un cas bien rangé où: 1. il en coûte le même prix pour déplacer un bien de n'importe quel expéditeur vers n'importe quel destinataire et 2. votre système est équilibré dans la mesure où demande = offre.

La façon la plus simple de penser Les contraintes sur la solution du problème sont (je pense) en termes de matrice des lieux qui envoient des marchandises par rapport à ceux qui les reçoivent. Nous pouvons faire cette matrice à partir de votre exemple de jouet:

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

Ce que cette matrice nous montre, c'est que la solution du système que vous avez proposé satisfait les contraintes que toutes les sommes de ligne sont égales le montant à envoyer de chaque magasin et toutes les sommes de la colonne égalent le montant à recevoir. Toute solution doit répondre à ces critères. Ainsi, si nous avons S expéditeurs (les lignes) et R récepteurs (les colonnes), nous avons des inconnues SxR. Si nous appelons chaque inconnu x_ij où i indexe l'expéditeur et j le récepteur, nous avons les contraintes que (A) sum_j x_ij = S_i et (B) sum_i x_ij = R_j . Dans un problème de transport normal, nous aurions également un coût associé à chaque lien entre un émetteur et un destinataire. Ce sera une matrice SxR, que nous pouvons appeler C. On chercherait alors la solution qui minimise les coûts, et on résoudrait numériquement avec min sum_i sum_j x_ij * c_ij , sous réserve de (A) et (B) .

Le fait que les coûts ne figurent pas dans votre discussion signifie simplement que tous les itinéraires coûtent le même prix. Nous pouvons toujours utiliser cette même structure du problème pour résoudre une solution en utilisant les bibliothèques existantes que R a pour la programmation linéaire. Je vais utiliser le package lpSolve qui a une fonction pour résoudre précisément ce genre de problème appelé lp.transport . Ci-dessous j'écris un fonction wrapper autour de lp.transport qui prend vos valeurs connues et les noms de magasin et détermine une solution valide. La fonction peut également prendre une matrice de coût fournie par l'utilisateur (SxR), et peut renvoyer la sortie sous la forme compacte d'une matrice SxR ou sous la forme de la matrice plus grande que vous recherchez:

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

Nous pouvons faire une démonstration de la fonction avec vos données de jouet pour voir comment cela fonctionne. Ici, je ne renvoie que la petite matrice émetteur-récepteur. Comme nous pouvons le voir, la solution est différente de celle que vous avez fournie mais également valide.

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

L'utilisation d'un package de programmation linéaire évolue facilement. Ici par exemple, nous résolvons pour 10 magasins:

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)
  }
}

Enfin, la sortie par défaut de la fonction est dans un format grande matrice et vous pouvez simplement cbind () à votre dataframe pour obtenir la sortie souhaitée:

# 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

^{Créé le 21/03/2019 par le package reprex (v0.2.1)}