образования бен в R data.frame

Question

У меня есть data.frame с двумя колоннами:

category quantity 
a   20 
b   30 
c   100 
d   10 
e   1 
f   23 
g   3 
h   200 

мне нужно написать функцию с двумя параметрами: dataframe, bin_size, который запускает cumsum над колонной величиной, делает разделение следующей строки, если cumsum превышает bin_size и добавляет номер рабочего места в качестве дополнительного столбца.

Скажем, введя этот:

function(dataframe, 50) 

в приведенном выше примере должен дать мне:

category quantity cumsum bin_nbr 
a   20  20   1 
b   30  50   1 
c   50  50   2 
c   50  50   3 
d   10  10   4 
e   1   11   4 
f   23   34   4 
g   3   37   4 
h   13  50   4 
h   50  50   5 
h   50  50   6 
h   50  50   7 
h   37  37   8 

Объяснение:

row a + b sum up to 50 --> bin_nbr 1 
row c is 100 -> split into 2 rows @ 50 -> bin nbr 2, bin_nbr 3 
row d,e,f,g sum up to 37 -> bin_nbr 4 
I need another 13 from row h to fill in bin_nbr 4 to 50 
The rest of the remaining quantity from h will be spitted into 4 bins -> bin_nbr 5, 6, 7, 8 

Answer 1

Я не мог думать о чистом виде для этого используйте apply/data.table и т. д., так как у вас есть зависимость между рядами и кадр данных изменяющегося размера. Возможно, вы можете сделать это итеративно/рекурсивным образом, но я чувствовал, что было бы быстрее выяснить, как написать цикл. Одна из проблем заключается в том, что трудно узнать конечный размер вашего объекта, поэтому это, вероятно, будет медленным. Вы можете немного смягчить проблему, переключившись с df на матрицу (код должен работать нормально, кроме битов преобразования), если производительность является проблемой в этом приложении.

fun <- function(df, binsize){ 
    df$cumsum <- cumsum(df$quantity) 
    df$bin <- 1 
    i <- 1 
    repeat { 
    if((extra <- (df[i, "cumsum"] - binsize)) > 0) { # Bin finished halfway through 
     top <- if(i > 1L) df[1L:(i - 1L), ] else df[0L, ] 
     mid <- transform(df[i, ], quantity=quantity-extra, cumsum=cumsum-extra) 
     bot <- transform(df[i, ], quantity=extra, cumsum=extra, bin=bin + 1L) 
     end <- if(i >= nrow(df)) df[0L, ] else df[(i + 1L):nrow(df), ] 
     end <- transform(end, cumsum=cumsum(end$quantity) + extra, bin=bin + 1L) 
     df <- rbind(top, mid, bot, end) 
    } else if (extra == 0 && nrow(df) > i) { # Bin finished cleanly 
     df[(i + 1L):nrow(df), ]$cumsum <- df[(i + 1L):nrow(df), ]$cumsum - binsize 
     df[(i + 1L):nrow(df), ]$bin <- df[(i + 1L):nrow(df), ]$bin + 1L 
    } 
    if(nrow(df) < (i <- i + 1)) break 
    } 
    rownames(df) <- seq(len=nrow(df)) 
    df 
} 
fun(df, binsize) 

# category quantity cumsum bin 
# 1   a  20  20 1 
# 2   b  30  50 1 
# 3   c  50  50 2 
# 4   c  50  50 3 
# 5   d  10  10 4 
# 6   e  1  11 4 
# 7   f  23  34 4 
# 8   g  3  37 4 
# 9   h  13  50 4 
# 10  h  50  50 5 
# 11  h  50  50 6 
# 12  h  50  50 7 
# 13  h  37  37 8 

Answer 2

Другим решение с петлей:

DF <- read.table(text="category quantity 
a   20 
b   30 
c   100 
d   10 
e   1 
f   23 
g   3 
h   200", header=TRUE) 

bin_size <- 50 
n_bin <- ceiling(sum(DF$quantity)/bin_size) 

DF$bin <- findInterval(cumsum(DF$quantity)-1, c(0, seq_len(n_bin)*50)) 
DF$cumsum <- cumsum(DF$quantity) 

result <- lapply(seq_along(DF[,1]), function(i, df) { 
    if (i==1) { 
    d <- df[i, "bin"] 
    } else { 
    d <- df[i, "bin"]-df[i-1, "bin"] 
    } 
    if (d > 1) {  
    res <- data.frame(
     category = df[i, "category"], 
     bin_nbr = df[i, "bin"]-seq_len(d+1)+1 
    )   
    res[,"quantity"] <- bin_size 
    if (i!=1) { 
     res[nrow(res),"quantity"] <- df[i-1, "bin"]*bin_size-df[i-1, "cumsum"] 
    } else { 
     res[nrow(res),"quantity"] <- 0 
    } 
    res[1,"quantity"] <- df[i, "quantity"]-sum(res[-1,"quantity"]) 
    return(res[res$quantity > 0,]) 
    } else { 
    return(data.frame(
     category = df[i, "category"], 
     quantity = df[i, "quantity"], 
     bin_nbr = df[i, "bin"] 
    )) 
    } 
}, df=DF) 

res <- do.call(rbind, result) 
res <- res[order(res$category, res$bin_nbr),] 
library(plyr) 
res <- ddply(res, .(bin_nbr), transform, cumsum=cumsum(quantity)) 
res 

# category quantity bin_nbr cumsum 
# 1   a  20  1  20 
# 2   b  30  1  50 
# 3   c  50  2  50 
# 4   c  50  3  50 
# 5   d  10  4  10 
# 6   e  1  4  11 
# 7   f  23  4  34 
# 8   g  3  4  37 
# 9   h  13  4  50 
# 10  h  50  5  50 
# 11  h  50  6  50 
# 12  h  50  7  50 
# 13  h  37  8  37 

Answer 3

Это составляет слияние границ бин с данными, которые дают это зацикливание решения:

library(zoo) 

fun <- function(DF, binsize = 50) { 
    nr <- nrow(DF) 
    DF2 <- data.frame(cumsum = seq(0, sum(DF$quantity), binsize) + binsize, bin_nbr = 1:nr) 
    DF.cs <- transform(DF, cumsum = cumsum(DF$quantity)) 
    m <- na.locf(merge(DF.cs, DF2, all = TRUE), fromLast = TRUE) 
    m$bin_nbr <- as.numeric(m$bin_nbr) 
    cs <- as.numeric(m$cumsum) 
    m$quantity <- c(cs[1], diff(cs)) 
    m$cumsum <- ave(m$quantity, m$bin_nbr, FUN = cumsum) 
    na.omit(m)[c("category", "quantity", "cumsum", "bin_nbr")] 
} 

дает:

> fun(DF) 
    category quantity cumsum bin_nbr 
1   a  20  20  1 
2   b  30  50  1 
3   c  50  50  2 
4   c  50  50  3 
5   d  10  10  4 
6   e  1  11  4 
7   f  23  34  4 
8   g  3  37  4 
9   h  13  50  4 
10  h  50  50  5 
11  h  50  50  6 
12  h  50  50  7 
13  h  37  37  8 

Примечание: Для целей воспроизведения результат выше, это вход мы использовали:

Lines <- "category quantity 
a   20 
b   30 
c   100 
d   10 
e   1 
f   23 
g   3 
h   200 
" 
DF <- read.table(text = Lines, header = TRUE, as.is = TRUE) 

ПЕРЕСМОТР ошибка в коде была исправлена.