How can I distribute a vector of numbers by a vector of percentages, round the result, and always get the same total that I started with in R?

user_13493686 0
Viewed 122

Question Summary

I want to multiply a vector of numbers (the Sum_By_Group column) by a vector of percentages (the Percent column) to distribute the total number for the group into each ID, round the result, and end up with the same total number that I started with. In other words, I want the Distribution_Post_Round column to be the same as the Sum_By_Group column.

Below is an example of the issue that I am running into. In Group A, I multiply Percent by Sum_By_Group and finish with 3 in ID 1, 3 in ID 2, and 1 in ID 5 for a total of 7. The Sum_By_Group column and Distribution_Post_Round column are the same for Group A and this is what I want. In Group B, I multiply Percent by Sum_By_Group and finish with 1 in ID 8 and 1 in ID 10 for a total of 2. I want the Distribution_Post_Round column to be 3 for Group B.

Is there a way to do this without using loops, subsetting data frames, and then rejoining the data frames together?

Example

library(dplyr)
df = data.frame('Group' = c(rep('A', 7), rep('B', 5)),
                  'ID' = c(1:12),
                  'Percent' = c(0.413797750, 0.385366840, 0.014417571, 0.060095668, 0.076399650,
                                0.019672573, 0.030249949, 0.381214519, 0.084121796, 0.438327886,
                                0.010665749, 0.085670050),
                  'Sum_By_Group' = c(rep(7,7), rep(3, 5)))
df$Distribute_By_ID = round(df$Percent * df$Sum_By_Group, 0)
df_round = aggregate(Distribute_By_ID ~ Group, data = df, sum)
names(df_round)[names(df_round) == 'Distribute_By_ID'] = 'Distribution_Post_Round'
df = left_join(df, df_round, by = 'Group')
df
  Group ID    Percent Sum_By_Group Distribute_By_ID Distribution_Post_Round
      A  1 0.41379775            7                3                       7
      A  2 0.38536684            7                3                       7
      A  3 0.01441757            7                0                       7
      A  4 0.06009567            7                0                       7
      A  5 0.07639965            7                1                       7
      A  6 0.01967257            7                0                       7
      A  7 0.03024995            7                0                       7
      B  8 0.38121452            3                1                       2
      B  9 0.08412180            3                0                       2
      B 10 0.43832789            3                1                       2
      B 11 0.01066575            3                0                       2
      B 12 0.08567005            3                0                       2

Thank you so much for your help. Please let me know if additional clarification is needed.

percentage dataframe aggregate r rounding
3 Answers

Wow, who knew someone had already written a package that includes a function to solve this... kudos to that team https://cran.r-project.org/web/packages/sfsmisc/index.html

Since you seem to be willing to use dplyr hopefully this additional package will be worth it because it certainly makes a solution elegant.

# https://stackoverflow.com/questions/61667720
library(dplyr)

df = data.frame('Group' = c(rep('A', 7), rep('B', 5)),
                'ID' = c(1:12),
                'Percent' = c(0.413797750, 0.385366840, 0.014417571, 0.060095668, 0.076399650,
                              0.019672573, 0.030249949, 0.381214519, 0.084121796, 0.438327886,
                              0.010665749, 0.085670050),
                'Sum_By_Group' = c(rep(7,7), rep(3, 5)))

glimpse(df)
#> Rows: 12
#> Columns: 4
#> $ Group        <chr> "A", "A", "A", "A", "A", "A", "A", "B", "B", "B", "B", "…
#> $ ID           <int> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12
#> $ Percent      <dbl> 0.41379775, 0.38536684, 0.01441757, 0.06009567, 0.076399…
#> $ Sum_By_Group <dbl> 7, 7, 7, 7, 7, 7, 7, 3, 3, 3, 3, 3

df %>% 
  group_by(Group) %>% 
  mutate(Distribute_By_ID = sfsmisc::roundfixS(Percent * Sum_By_Group))
#> # A tibble: 12 x 5
#> # Groups:   Group [2]
#>    Group    ID Percent Sum_By_Group Distribute_By_ID
#>    <chr> <int>   <dbl>        <dbl>            <dbl>
#>  1 A         1  0.414             7                3
#>  2 A         2  0.385             7                3
#>  3 A         3  0.0144            7                0
#>  4 A         4  0.0601            7                0
#>  5 A         5  0.0764            7                1
#>  6 A         6  0.0197            7                0
#>  7 A         7  0.0302            7                0
#>  8 B         8  0.381             3                1
#>  9 B         9  0.0841            3                0
#> 10 B        10  0.438             3                2
#> 11 B        11  0.0107            3                0
#> 12 B        12  0.0857            3                0

Created on 2020-05-07 by the reprex package (v0.3.0)

user_91900340 
df %>%
  mutate(dividend = floor(Percent*Sum_By_Group),
         remainder= Percent*Sum_By_Group-dividend) %>%
  group_by(Group) %>%
  arrange(desc(remainder),.by_group=TRUE) %>%
  mutate(delivered=sum(dividend),
         rownumber=1:n(),
         lastdelivery=if_else(rownumber<=Sum_By_Group-delivered,1,0),
         Final=dividend+lastdelivery) %>%
  ungroup()

# A tibble: 12 x 10
   Group    ID Percent Sum_By_Group dividend remainder delivered rownumber lastdelivery Final
   <fct> <int>   <dbl>        <dbl>    <dbl>     <dbl>     <dbl>     <int>        <dbl> <dbl>
 1 A         1  0.414             7        2    0.897          4         1            1     3
 2 A         2  0.385             7        2    0.698          4         2            1     3
 3 A         5  0.0764            7        0    0.535          4         3            1     1
 4 A         4  0.0601            7        0    0.421          4         4            0     0
 5 A         7  0.0302            7        0    0.212          4         5            0     0
 6 A         6  0.0197            7        0    0.138          4         6            0     0
 7 A         3  0.0144            7        0    0.101          4         7            0     0
 8 B        10  0.438             3        1    0.315          2         1            1     2
 9 B        12  0.0857            3        0    0.257          2         2            0     0
10 B         9  0.0841            3        0    0.252          2         3            0     0
11 B         8  0.381             3        1    0.144          2         4            0     1
12 B        11  0.0107            3        0    0.0320         2         5            0     0

This is my solution, without any other dependencies relying on Hare quota : I distributed all the integer "seats", then I distributed the remaining "seats" in the order of remainders. The column "Final" is then OK.

Note : It seems to give the same results than the other solution with a package

user_118046560

Formulating this as an integer optimization problem:

library(CVXR)
A <- as.data.frame.matrix(t(model.matrix(~0+Group, df)))
prop <- df$Percent * df$Sum_By_Group
x <- Variable(nrow(df), integer=TRUE)
sums <- df$Sum_By_Group[!duplicated(df$Group)]
p <- Problem(Minimize(sum_squares(x - prop)), list(A %*% x == sums))
result <- solve(p)

df$Distribute_By_ID <- as.integer(round(result$getValue(x)))

output:

   Group ID    Percent Sum_By_Group
1      A  1 0.41379775            7
2      A  2 0.38536684            7
3      A  3 0.01441757            7
4      A  4 0.06009567            7
5      A  5 0.07639965            7
6      A  6 0.01967257            7
7      A  7 0.03024995            7
8      B  8 0.38121452            3
9      B  9 0.08412180            3
10     B 10 0.43832789            3
11     B 11 0.01066575            3
12     B 12 0.08567005            3
user_19894800
Related