Окончательное редактирование : Это решение основано на data.table и может использовать цикл в конце.Тем не менее, вы можете продолжать копировать и вставлять, чтобы это работало.Решение основано главным образом на этом невероятно быстром решении:
search_dt <- dt[sku1 == searchSKU]
current_parts <- names(search_dt[, .SD, .SDcols = part_names])[which(search_dt[, .SD, .SDcols = part_names]>0)]
steal_dt <- dt[rowTally <= searchRowTally]
#returns SKUs which are 0 for the parts we already have
steal_dt <- steal_dt[steal_dt[, j = rowSums(.SD) == 0, .SDcols = current_parts]]
franken_rob <- cbind(search_dt, steal_dt)
Я все еще не уверен в некоторых критериях.Я предполагаю, что, поскольку FrankenBot собран, каждый последующий SKU не может быть в предыдущих частях.Другими словами, SKU3 не имеет ничего общего с SKU1 и SKU2.
Вывод решения [Я отредактировал его еще раз ...] {и еще один ...}:
# A tibble: 15 x 8
sku1 sku2 sku3 propSums Parts Robots dollarsPerRobot totalUnitSales
<int> <int> <int> <dbl> <dbl> <dbl> <dbl> <dbl>
1 1 2 5 0.982 6 3 1.47 339139.
2 1 2 10 0.941 6 3 1.32 339139.
3 1 4 NA 0.834 5 2 1.84 333842.
4 1 5 NA 0.535 3 2 2.03 339139.
5 1 10 NA 0.494 3 2 1.80 339139.
6 2 5 NA 0.621 4 2 0.858 476404.
7 2 6 NA 0.746 5 2 0.320 839456.
8 2 10 NA 0.579 4 2 0.631 839456.
9 4 8 NA 0.787 5 2 1.48 333842.
10 5 8 NA 0.488 3 2 1.67 390051.
11 5 9 NA 0.631 4 2 0.737 476404.
12 6 8 NA 0.614 4 2 1.13 390051.
13 6 9 NA 0.756 5 2 0.199 777343.
14 8 10 NA 0.447 3 2 1.44 390051.
15 9 10 NA 0.590 4 2 0.510 777343.
код решения:
library(data.table)
# generate data -----------------------------------------------------------
set.seed(1)
n = 10
cols = 6 #added
part_names = paste0('p', c(1:cols), '_prop')
a = runif(n* cols, min=0, max=0.2)
a[a<0.12] = 0
A <- data.table(matrix(a, nrow=n, ncol=cols,byrow = TRUE))
A[, `:=`(rowTally1 = rowSums(.SD != 0),
sku1 = .I
,totalDollarSales1 = runif(n=n, min=1*10^2, max=1*10^6)
,totalUnitSales1 = runif(n=n, min=1*10^2, max=1*10^6))]
A[, dollarsPerRobot1:=totalDollarSales1/totalUnitSales1]
setnames(A, c(paste0('V',1:cols)), part_names)
setcolorder(A, 'sku1')
non_part_names<- setdiff(names(A), c('sku1',part_names))
non_part_names<- stringr::str_sub(non_part_names, 1, -2)
search_fun <- function (search_dt, steal_dt, searchSKU, b_loop = FALSE, sale_range = NULL) {
sku_count<- length(grep('sku', names(search_dt)))
skus <- paste0('sku', 1:(sku_count+1))
non_parts<- paste0(non_part_names, rep(1:(sku_count+1), each = length(non_part_names)))
blank_table <- setnames(data.table(matrix(nrow = 0, ncol = length(search_dt) + 1 + length(non_part_names))),c(skus,part_names, non_parts))
if (length(searchSKU) != sku_count) {
stop('not enough SKUs to go around')
}
for (i in 1:length(searchSKU)) {
search_dt <- search_dt[get(paste0('sku', i)) == searchSKU[i]]
}
current_parts <- names(search_dt[, .SD, .SDcols = part_names])[which(search_dt[, .SD, .SDcols = part_names]>0)]
search_dt[, (setdiff(part_names, current_parts)) := NULL, ]
# Could be made faster if sku1s were filtered out to whichever ones were is sku.N
# Right now it still looks through skus that may have already been filtered out.
if (!is.null(sale_range)) {
if (length(sale_range) != 2) {
warning('Sale range needs to be length two with sale_range[1] = lower range and sale_range[2] = upper range')
} else {
steal_dt <- steal_dt[between(totalUnitSales1, sale_range[1] * search_dt$totalUnitSales1, search_dt$totalUnitSales1 * sale_range[2])]
}
}
if (b_loop) {
steal_dt <- steal_dt[sku1 > searchSKU[sku_count]]
}
steal_dt <- steal_dt[steal_dt[, j = rowSums(.SD) == 0, .SDcols = current_parts]]
if (nrow(steal_dt) == 0) {
return(blank_table)
}
steal_dt[, (current_parts) := NULL]
setnames(steal_dt,
c('sku1', paste0(non_part_names, '1')) ,
c(paste0('sku',sku_count+1),
paste0(non_part_names, sku_count+1))
)
franken_rob <- cbind(search_dt, steal_dt)
setcolorder(franken_rob, c(skus, part_names))
return(franken_rob)
}
searchRowTally <- 3
dt_search <- A
#this is done outside the function because there can be a lot of looping otherwise
dt_steal <- dt_search[rowTally1 <= searchRowTally]
#Near-instant with 80,000 rows and 26 columns
search_fun(dt_search, dt_steal, dt_search$sku1[5])
search_fun(dt_search, dt_steal, dt_search$sku1[5], b_loop = TRUE)
search_fun(dt_search, dt_steal, dt_search$sku1[5], sale_range = c(0.8, 1.2))
search_fun(dt_search, dt_steal, dt_search$sku1[5], b_loop = TRUE, sale_range = c(0.8, 1.2))
#Not doable with 80,000 rows, but still nice
rbindlist(lapply(1:(n-1), function (i) search_fun(dt_search, dt_steal, dt_search$sku1[i], b_loop = TRUE)))
rbindlist(lapply(1:(n-1), function (i) search_fun(dt_search, dt_steal, dt_search$sku1[i], b_loop = TRUE, sale_range = c(0.8, 1.2))))
#much more likely that the first regression would be a single value
# frank_1 <- search_fun(dt_search, dt_steal, dt_search$sku1[5], FALSE)
frank_1 <- rbindlist(lapply(1:(n-1), function (i) search_fun(dt_search, dt_steal, dt_search$sku1[i], TRUE)))
#This takes every n-1 of each sku1 group.
frank_2 <- frank_1[frank_1[, head(.I, -1), by = sku1]$V1]
# frank_2 <- frank_1[, j = if(.N!=1) .SD, by = sku1]
dt_steal2 <- dt_steal[sku1 %in% base::unique(frank_1$sku2)]
frank_2 = rbindlist(lapply(1:nrow(frank_2), function (i) search_fun(frank_2, dt_steal2, melt(frank_2[i, .SD, .SDcols = grep('sku', names(frank_2))])[[2]], TRUE)))
frank_3 <- frank_2[frank_2[, head(.I, -1), by = sku2]$V1]
dt_steal3 <- dt_steal2[sku1 %in% base::unique(frank_2$sku3)]
frank_3 = rbindlist(lapply(1:nrow(frank_3), function (i) search_fun(frank_3, dt_steal3, melt(frank_3[i, .SD, .SDcols = grep('sku', names(frank_3))])[[2]], TRUE)))
# start combindine our lists
franken_rob <- frank_1[!frank_2, on = c('sku1', 'sku2')]
franken_rob[, j= sku3:= integer()]
setcolorder(franken_rob, c('sku1','sku2','sku3'))
franken_rob <- rbind(frank_2, franken_rob, fill = TRUE)
#do above for frank_n times)
franken_rob[, `:=`(propSums=rowSums(.SD),
Parts = rowSums(.SD > 0))
, .SDcols = part_names]
franken_rob[, Robots:= rowSums(.SD > 0, na.rm = TRUE), .SDcols = grep('sku', names(franken_rob))]
franken_rob[, dollarsPerRobot := rowSums(.SD, na.rm = TRUE) / Robots, .SDcols = grep ('dollarsPerRobot', names(franken_rob))]
franken_rob[, totalUnitSales := do.call(pmin, c(.SD, list(na.rm = TRUE))), .SDcols = grep('totalUnitSales', names(franken_rob))]
franken_rob[, (part_names) := NULL]
franken_rob
tibble::as_tibble(franken_rob[, c(1:3, 16, 17, 18, 19,20)])
Редактировать : мне не хватает представителя, чтобы комментировать - при попытке решения data.table с 80 000 строк и 26 столбцов он пытается выделить вектор размером 2,3 ГБ, когда rowTally <= 13.Однако, когда я изменяю это значение на 3, получается 1,1 миллиона строк и фильтруется до 0,3 миллиона строк.Это супер декартово
Оригинал : вот решение dplyr, которое, кажется, работает с 80000 строк и 26 столбцов.Хитрость заключалась в том, чтобы выяснить, какие столбцы имели ненулевой результат для подмножества sku.С этими столбцами я вернулся к исходному df и отфильтровал.
Есть также строка, закомментированная для UnitSales, находящейся в некотором диапазоне.
set.seed(1)
n = 10
cols = 6 #added
part_names = paste0('p', c(1:cols), '_prop') #added
a = runif(n * cols, min=0, max=0.2) #changed from n to n * cols
a[a<0.12] = 0
A = as.data.frame(matrix(a,
nrow=n,
ncol=cols, #changed to cols
byrow = TRUE))
A$rowTally <- rowSums(A != 0)
A$sku <- seq(from = 1, to = n)
A$totalDollarSales <- runif(n=n, min=1*10^2, max=1*10^6)
A$totalUnitSales <- runif(n=n, min=1*10^2, max=1*10^6)
names(A) <- c(part_names, "rowTally", "sku", "totalDollarSales", "totalUnitSales")
A <- A[c("sku", part_names, "rowTally", "totalDollarSales", "totalUnitSales")]
A$dollarsPerRobot <- A$totalDollarSales/A$totalUnitSales
library(dplyr)
df <- as_tibble(A)%>%
mutate(propSum = rowSums(.[, part_names]))
search_sku <- 5
skuRowTally <- 3
search_df <- df%>%
filter(sku == search_sku)
current_parts <- search_df%>%
select(part_names)%>%
select_if(~sum(.)> 0)%>%
names()
non_current_parts <- search_df%>%
select(part_names)%>%
select_if(~sum(.) == 0)%>%
names()
df%>%
filter(rowTally <= skuRowTally,
sku != search_sku
# , between(totalUnitSales, 0.7 * search_df$totalUnitSales, 1.3 * search_df$totalUnitSales)
)%>%
filter_at(vars(current_parts), all_vars(. == 0))%>%
filter_at(vars(non_current_parts), any_vars(. != 0))%>%
rowwise()%>%
transmute(sku_search = search_sku,
sku = sku,
propSum = propSum + search_df$propSum,
minLB = min(totalUnitSales, search_df$totalUnitSales),
weightedPrice = (dollarsPerRobot + search_df$dollarsPerRobot) / 2,
total_parts = rowTally + search_df$rowTally,
complete_robot = if_else(total_parts == cols, 'COMPLETE', 'incomplete')
)%>%
ungroup()
frankensteinRobot <- function (df, sku1, skuTally) {
# df <- as_tibble(df)%>%
# mutate(propSum = rowSums(.[, part_names]))
#part_name and cols would also need to be passed to make this
#completely stand alone.
search_sku <- sku1
skuRowTally <- skuTally
search_df <- df%>%
filter(sku == search_sku)
current_parts <- search_df%>%
select(part_names)%>%
select_if(~sum(.)> 0)%>%
names()
non_current_parts <- search_df%>%
select(part_names)%>%
select_if(~sum(.) == 0)%>%
names()
df%>%
filter(rowTally <= skuRowTally,
sku > search_sku
# , between(totalUnitSales, 0.7 * search_df$totalUnitSales, 1.3 * search_df$totalUnitSales)
)%>%
filter_at(vars(current_parts), all_vars(. == 0))%>%
filter_at(vars(non_current_parts), any_vars(. != 0))%>%
rowwise()%>%
transmute(sku_search = search_sku,
sku = sku,
propSum = propSum + search_df$propSum,
minLB = min(totalUnitSales, search_df$totalUnitSales),
weightedPrice = (dollarsPerRobot + search_df$dollarsPerRobot) / 2,
total_parts = rowTally + search_df$rowTally,
complete_robot = if_else(total_parts == cols, 'COMPLETE', 'incomplete')
)%>%
ungroup()
}
A<- as_tibble(A)%>%
mutate(propSum = rowSums(.[, part_names]))
#I tried running 1:n with 80,000 rows. It wasn't pretty
bind_rows(lapply(1:n, function(x) frankensteinRobot(A, x, 3)))
edit: вот попытка решения для data.table.У этого есть некоторые сходства, но вместо того, чтобы делать это как петлю, это один способ обойти.Если бы я мог выяснить, как получить ваше основное состояние не соответствующих частей, это, вероятно, не будет слишком потертым.Прямо сейчас узким местом является память, и это потому, что я не могу пересекаться, чтобы работать с моим списком списков.
results[
apply(results[, .(current_parts, rbt_missing_curr_parts)], 1, function(x) length(intersect(x[[1]], x[[2]]))==0)
]
Основной код:
library(data.table)
dt <- as.data.table(A)
dt[
,j = `:=`(propSum = rowSums(.SD),
current_parts = list(which(.SD > 0)),
missing_parts = list(which(.SD == 0)))
,.SDcols = part_names,
by = sku]
#could subset here as dt[1:100, ...] which would allow bigger datasets
dt_missing_parts <- dt[, .( sku, propSum, current_parts, rowTally, missing_parts, dollarsPerRobot, up_range = 1.3 *totalUnitSales, low_range = 0.7 * totalUnitSales)]
results<- dt_missing_parts[dt[rowTally <= round(cols / 2)],
j = .(i.sku, sku,
propSum = propSum + i.propSum,
dollarsPerRobot = (dollarsPerRobot + i.dollarsPerRobot) / 2,
totalUnitSales = pmin(totalUnitSales, i.totalUnitSales),
rbt_missing_curr_parts = i.current_parts,
current_parts,
rpt_missing_missing_parts= i.missing_parts,
missing_parts,
total_parts = rowTally + i.rowTally),
on = .(sku > sku
#more conditions would be great
# ,low_range < totalUnitSales
# ,up_range > totalUnitSales
),
allow.cartesian = TRUE,
nomatch = 0L,
by = .I
]
results
results[
apply(results[, .(current_parts, rbt_missing_curr_parts)], 1, function(x) length(intersect(x[[1]], x[[2]]))==0)
]