Объединение сценария для замены медиан по группам в R - PullRequest
0 голосов
/ 13 сентября 2018

У меня есть набор данных

mydat <- 
structure(list(code = structure(c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L), .Label = c("52382MCK", 
"52499MCK"), class = "factor"), item = c(11709L, 11709L, 11709L, 
11709L, 11708L, 11708L, 11708L, 11710L, 11710L, 11710L, 11710L, 
11710L, 11710L, 11710L, 11710L, 11710L, 11710L, 11710L, 11710L, 
11710L, 11710L, 11710L, 11710L, 11710L, 11710L, 11710L, 11710L, 
11710L, 11202L, 11203L, 11203L, 11204L, 11204L, 11205L, 11205L
), sales = c(30L, 10L, 20L, 15L, 2L, 10L, 3L, 30L, 10L, 20L, 
15L, 2L, 10L, 3L, 30L, 10L, 20L, 15L, 2L, 10L, 3L, 30L, 10L, 
20L, 15L, 2L, 10L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L), action = c(0L, 
1L, 0L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 
1L, 0L, 0L, 0L, 0L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, 0L, 1L, 0L, 0L, 
1L, 1L)), row.names = c(NA, -35L), class = "data.frame")
# coerce to data.table
setDT(mydat)

с этим набором данных, выполняется несколько операций.

1. selecting scenario by groups.

Итак, есть столбец действий.Может иметь только два значения ноль (0) или одно (1).

Сценарии - это число нулевых категорий действия до первой категории действия и количество нулей после одной категории действия.

For example
52382МСК    11709

это сценарий, когда у нас есть 1 нулевая категория действий цв.до первой категории действия цв, и два нуля после первой категории действия цв.Примечание: возможно, сценарий, когда у нас есть 2 нулевой категории действий цв.перед первой категорией действий col, и 1 ноль после первой категории действий col.

mydat1

code    item    sales   action
52382МСК    11709   30  0
52382МСК    11709   10  1
52382МСК    11709   20  0
52382МСК    11709   15  0

, чтобы обнаружить этот сценарий, я использую этот сценарий / Этот сценарий очень хорошо работает, спасибо за @ Uwe

library(data.table)
library(magrittr)

max_zeros <- 3
zeros <- sapply(0:max_zeros, stringr::str_dup, string = "0")
names(zeros) <- as.character(nchar(zeros))
sc <- CJ(zeros.before = zeros, zeros.after = zeros)[
  , scenario.name := paste(nchar(zeros.before), nchar(zeros.after), sep = "-")][
    , action.pattern := sprintf("%s1+(?=%s)", zeros.before, zeros.after)][]
# special case: all zero
sc0 <- data.table(
  zeros.before = NA,
  zeros.after = NA, 
  scenario.name = "no1", 
  action.pattern = "^0+$")
sc <- rbind(sc0, sc)

, а затем

setDT(mydat)
class <- mydat[, .(scenario.name = sc$scenario.name[
  paste(action, collapse = "") %>% 
    stringr::str_count(sc$action.pattern) %>%
    is_greater_than(0) %>% 
    which() %>% 
    max()
  ]),
  by = .(code, item)][]

class
mydat[class, on = .(code, item)]

Итак, я получаю данные с классом сценария.

2.operation it is replace median.

Для каждого сценария вычисляется медиана по нулевой категории.

Iнеобходимо вычислить медиану по 1 предыдущей категории нулей по столбцу действий, т. е. которые идут перед одной категорией столбца действий, и по 2 нулям по столбцу действий, которые идут после одной категории.Медианная замена выполняется только для столбца первой категории действия столбцом продажи.если медиана больше, чем продажи, то не заменяйте ее.

Для этого я использую скрипт

sales_action <- function(DF, zeros_before, zeros_after) {
  library(data.table)
  library(magrittr)
  action_pattern <- 
    do.call(sprintf, 
            c(fmt = "%s1+(?=%s)", 
              stringr::str_dup("0", c(zeros_before, zeros_after)) %>% as.list()
            ))
  message("Action pattern used: ", action_pattern)
  setDT(DF)[, rn := .I]
  tmp <- DF[, paste(action, collapse = "") %>% 
              stringr::str_locate_all(action_pattern) %>% 
              as.data.table() %>% 
              lapply(function(x) rn[x]),
            by = .(code, item)][
              , end := end + zeros_after]
  DF[tmp, on = .(code, item, rn >= start, rn <= end), 
     med := as.double(median(sales[action == 0])), by = .EACHI][
       , output := as.double(sales)][action == 1, output := pmin(sales, med)][
         , c("rn", "med") := NULL][]
}

, а затем

sales_action(mydat, 1L, 2L)

, поэтому я получаюрезультат.

вопрос основан на следующем

Каждый раз, когда я должен вручную вводить сценарий с заменой на медиану

sales_action(mydat, 1L, 2L)
sales_action(mydat, 3L, 1L)
sales_action(mydat, 2L, 2L)

и т. д.

Как сделать так, чтобы замена медианы выполнялась для всех возможных сценариев автоматически, чтобы я не писал каждый раз sales_action (mydat, .L, .L)

Так пример вывода

code    i    tem    sales   action  output  pattern
52382MCK    11709   30        0       30    01+00
52382MCK    11709   10        1       10    01+00
52382MCK    11709   20        0       20    01+00
52382MCK    11709   15        0       15    01+00
52382MCK    1170    8         0        8    01+00
52382MCK    1170    10        1        8    01+00
52382MCK    1170    2         0        2    01+00
52382MCK    1170    15        0        15   01+00

1 Ответ

0 голосов
/ 14 сентября 2018

Если я правильно понимаю , ОП хочет проанализировать успешность действий по продажам, сравнив цифры sales во время действий со средними продажами периодов непосредственно до и после действия по продажам.

Есть несколько проблем:

  1. В группе code, item может быть более одного действия по продаже.
  2. Доступные данные могут охватывать меньше , чем запрашиваемые 3 три дня каждый до и после действия по продаже.

ИМХО, введение сценариев - это обходной путь для решения проблемы 2.

Подход ниже

  • определяет действия по продажам в каждой группе code, item,
  • выбирает до трех строк с нулевым действием до и до трех строк после каждого действия по продаже
  • вычисляет средние продажи этих строк, а
  • обновляет output, если показатель продаж внутри действия продаж превышает медиану окружающих строк нулевого действия.

Термин категория был придуман ОП для разграничения между периодами продаж (непрерывные полосы action == 1L) и периодами нулевого действия до и после.

library(data.table)
# coerce to data.table and create categories
setDT(mydat)[, cat := rleid(action), by = .(code, item)][]

# extract action categories, identify preceeding & succeeding zero action categories
mycat <- mydat[, .(action = first(action)), by = .(code, item, cat = cat)][
  , `:=`(before = cat - 1L, after = cat + 1L)][action == 1L]

mycat

       code  item cat action before after
1: 52382MCK 11709   2      1      1     3
2: 52382MCK 11708   2      1      1     3
3: 52382MCK 11710   2      1      1     3
4: 52382MCK 11710   4      1      3     5
5: 52382MCK 11710   6      1      5     7
6: 52499MCK 11203   2      1      1     3
7: 52499MCK 11205   1      1      0     2

Обратите внимание, что группа 52382MCK, 11710 включает три отдельных действия по продажам. before и after могут указывать на несуществующий cat, но это будет исправлено автоматически при последующих соединениях.

# compute median of surrouding zero action categories
action_cat_median <- 
  rbind(
    # get sales from up to 3 zero action rows before action category
    mydat[mycat, on = .(code, item, cat = before), 
          .(sales = tail(sales, 3), i.cat), by =.EACHI],
    # get sales from up to 3 zero action rows after action category
    mydat[mycat, on = .(code, item, cat = after), 
          .(sales = head(sales, 3), i.cat), by =.EACHI]
  )[
    # remove empty groups
    !is.na(sales)][
      # compute median for each action category
      , .(med = as.double(median(sales))), by = .(code, item, cat = i.cat)]

action_cat_median
       code  item cat  med
1: 52382MCK 11709   2 20.0
2: 52382MCK 11708   2  2.5
3: 52382MCK 11710   2 10.0
4: 52382MCK 11710   4 10.0
5: 52382MCK 11710   6 10.0
6: 52499MCK 11203   2  2.0
# prepare result
mydat[, output := as.double(sales)][
  # update join
  action_cat_median, on = .(code, item, cat), output := pmin(sales, med)]

Редактировать: В качестве альтернативы, вызов pmin() может быть заменен на неэквивалентное соединение , которое обновляет только те строки, где продажи превышают медиану:

# prepare result, alternative approach
mydat[, output := as.double(sales)][
  # non-equi update join
  action_cat_median, on = .(code, item, cat, output > med), output := med]


mydat
        code  item sales action cat output
 1: 52382MCK 11709    30      0   1   30.0
 2: 52382MCK 11709    10      1   2   10.0
 3: 52382MCK 11709    20      0   3   20.0
 4: 52382MCK 11709    15      0   3   15.0
 5: 52382MCK 11708     2      0   1    2.0
 6: 52382MCK 11708    10      1   2    2.5
 7: 52382MCK 11708     3      0   3    3.0
 8: 52382MCK 11710    30      0   1   30.0
 9: 52382MCK 11710    10      0   1   10.0
10: 52382MCK 11710    20      0   1   20.0
11: 52382MCK 11710    15      1   2   10.0
12: 52382MCK 11710     2      0   3    2.0
13: 52382MCK 11710    10      0   3   10.0
14: 52382MCK 11710     3      0   3    3.0
15: 52382MCK 11710    30      0   3   30.0
16: 52382MCK 11710    10      0   3   10.0
17: 52382MCK 11710    20      0   3   20.0
18: 52382MCK 11710    15      1   4   10.0
19: 52382MCK 11710     2      0   5    2.0
20: 52382MCK 11710    10      0   5   10.0
21: 52382MCK 11710     3      0   5    3.0
22: 52382MCK 11710    30      0   5   30.0
23: 52382MCK 11710    10      0   5   10.0
24: 52382MCK 11710    20      0   5   20.0
25: 52382MCK 11710    15      1   6   10.0
26: 52382MCK 11710     2      0   7    2.0
27: 52382MCK 11710    10      0   7   10.0
28: 52382MCK 11710     3      0   7    3.0
29: 52499MCK 11202     2      0   1    2.0
30: 52499MCK 11203     2      0   1    2.0
31: 52499MCK 11203     2      1   2    2.0
32: 52499MCK 11204     2      0   1    2.0
33: 52499MCK 11204     2      0   1    2.0
34: 52499MCK 11205     2      1   1    2.0
35: 52499MCK 11205     2      1   1    2.0
        code  item sales action cat output

Следующие строки были обновлены:

mydat[output != sales]
       code  item sales action cat output
1: 52382MCK 11708    10      1   2    2.5
2: 52382MCK 11710    15      1   2   10.0
3: 52382MCK 11710    15      1   4   10.0
4: 52382MCK 11710    15      1   6   10.0
...