R - Новая переменная фактора, основанная на предыдущей строке и других столбцах. Оптимизация Ifelse

Question

Я искал arround SO и другие блоги по науке о данных и программированию, но я не нашел ответа для своей конкретной потребности. Поэтому, если вы обнаружите, что этот вопрос дублируется, пожалуйста, будьте любезны и укажите мне источник информации и закройте / удалите этот вопрос.

Мои реальные данные будут иметь несколько тысяч строк, поэтому я отображаю здесь только небольшой набор вымышленных данных, очень похожих на мои исходные данные:

Data <- data.frame(
  ID = c(1,1,1,1,2,2,2,2,3,3),
  Year = c(2014,2015,2016,2017,2007,2008,2009,2010,2016,2017),
  CmSm = c(1,2,1,0,1,0,0,1,1,0),
  Index = c(1,2,3,4,1,2,3,4,1,2)
)

Набор данных, который я хотел бы получить в конце:

Dataout <- data.frame(
     ID = c(1,1,1,1,2,2,2,2,3,3),
     Year = c(2014,2015,2016,2017,2007,2008, 2009,2010,2016,2017),
     CmSm = c(1,2,1,0,1,0,0,1,1,0),
     Index = c(1,2,3,4,1,2,3,4,1,2),
     Cassification = c("New", "Existing", "Existing", "Lost", "New", "Lost","","Returning", "New","Lost")
 )

Моя лучшая попытка на данный момент выглядит следующим образом:

Dataout$Status <- ave( Dataout$CmSm, 
 Dataout$ID, 
 FUN = function(x) ifelse( Dataout$Index == 1, "New", ifelse( x[-1] == 0 & x > 0, "Returning", ifelse( x[-1] == 0 & x == 0, "", ifelse( x[-1] > 0 & x == 0, "Lost", "Existing" ) ) ) ) )

Однако у этой попытки есть 2 проблемы:

1. Неправильно классифицируется;

2. Когда я использую этот код в моих исходных данных с тысячами и тысячами строк, R выполняет 15 минут вычислений и не получает никаких результатов (я думаю, что ifelse не помогает ...), а не упомянуть, что память, выделенная для процесса, смехотворно высока.

Объяснение рассматриваемой проблемы и правила классификации:

Учитывая список идентификаторов элементов, год и индекс идентификатора элемента, я хотел бы классифицировать эти элементы по следующим категориям: «Новый», «Существующий», «Возвращение», «Потерянный» и «» или ноль или нет. Правила для этой классификации следующие (CmSm-1 представляет непосредственное предыдущее значение относительно текущего значения CmSm):

Если индекс == 1, то «новый».

Если индекс> 1, то:

если CmSm-1 == 0 и CmSm> 0, то «Возвращается».

Если CmSm-1 == 0 и CmSm == 0, то "" -> это напоминает случай, когда у объекта не было зарегистрированных событий.

Если CmSm-1> 0 и CmSm> 0, то «Существующий».

Если CmSm-1> 0 и CmSm == 0, то «потерян».

Пожалуйста, дайте мне знать, если вы нашли мое объяснение правил запутанным, чтобы у меня была возможность уточнить их для вас.

Заранее благодарю за любую помощь, которую вы можете оказать. Ура!

Answer 1

Вот еще одно базовое решение R. Он также использует логические индексы, такие как решение @LAP.

Я воссоздаю Dataout, поскольку интерес представляет столбец.

Dataout <- data.frame(
    ID = c(1,1,1,1,2,2,2,2,3,3),
    Year = c(2014,2015,2016,2017,2007,2008, 2009,2010,2016,2017),
    CmSm = c(1,2,1,0,1,0,0,1,1,0),
    Index = c(1,2,3,4,1,2,3,4,1,2),
    Cassification = c("New", "Existing", "Existing", "Lost", "New", "Lost","","Returning", "New","Lost"),
    stringsAsFactors = FALSE
)


inx <- Data$Index == 1
inxCmSm <- Data$CmSm == 0
inxCmSm1 <- c(FALSE, inxCmSm[-length(inxCmSm)])

Data$Status <- ""
Data$Status[inx] <- "New"
Data$Status[!inx & inxCmSm1 & !inxCmSm] <- "Returning"
Data$Status[!inx & !inxCmSm1 & !inxCmSm] <- "Existing"
Data$Status[!inx & !inxCmSm1 & inxCmSm] <- "Lost"

identical(Data$Status, Dataout$Cassification)
#[1] TRUE

Answer 2

library(dplyr)
Data %>% 
  mutate(Classification = case_when(
    Index == 1 ~ "New",
    lag(CmSm) == 0 & CmSm > 0 ~ "Returning",
    lag(CmSm) > 0 & CmSm > 0 ~ "Existing",
    lag(CmSm) > 0 & CmSm == 0 ~ "Lost",
    lag(CmSm) == 0 & CmSm == 0 ~ ""
  ))

   ID Year CmSm Index Classification
1   1 2014    1     1            New
2   1 2015    2     2       Existing
3   1 2016    1     3       Existing
4   1 2017    0     4           Lost
5   2 2007    1     1            New
6   2 2008    0     2           Lost
7   2 2009    0     3               
8   2 2010    1     4      Returning
9   3 2016    1     1            New
10  3 2017    0     2           Lost

Answer 3

Это хороший случай для case_when из dplyr:

Data %>% 
  group_by(ID) %>% 
  mutate(Status = case_when(Index == 1 ~ "New",
                            lag(CmSm) == 0 & CmSm > 0 ~ "Returning",
                            lag(CmSm) == 0 & CmSm == 0 ~ "",
                            lag(CmSm) > 0 & CmSm > 0 ~ "Existing",
                            lag(CmSm) > 0 & CmSm == 0 ~ "Lost")
         )

Результат:

# A tibble: 10 x 5
# Groups:   ID [3]
      ID  Year  CmSm Index Status   
   <dbl> <dbl> <dbl> <dbl> <chr>    
 1     1  2014     1     1 New      
 2     1  2015     2     2 Existing 
 3     1  2016     1     3 Existing 
 4     1  2017     0     4 Lost     
 5     2  2007     1     1 New      
 6     2  2008     0     2 Lost     
 7     2  2009     0     3 ""       
 8     2  2010     1     4 Returning
 9     3  2016     1     1 New      
10     3  2017     0     2 Lost   

Answer 4

Почему бы просто не использовать отдельные векторизованные условные шаги?

library(dplyr)

Data$Classification <- NA
Data$Classification[Data$Index == 1] <- "New"
Data$Classification[Data$Index > 1 & lag(Data$CmSm) == 0 & Data$CmSm > 0] <- "Returning"
Data$Classification[Data$Index > 1 & lag(Data$CmSm) == 0 & Data$CmSm == 0] <- ""
Data$Classification[Data$Index > 1 & lag(Data$CmSm) > 0 & Data$CmSm > 0] <- "Existing"
Data$Classification[Data$Index > 1 & lag(Data$CmSm) > 0 & Data$CmSm == 0] <- "Lost"

> Data
   ID Year CmSm Index Classification
1   1 2014    1     1            New
2   1 2015    2     2       Existing
3   1 2016    1     3       Existing
4   1 2017    0     4           Lost
5   2 2007    1     1            New
6   2 2008    0     2           Lost
7   2 2009    0     3               
8   2 2010    1     4      Returning
9   3 2016    1     1            New
10  3 2017    0     2           Lost

Это бонус к быстроте как в аду.

Микробенчмарк этого против case_when:

Unit: milliseconds
   expr      min       lq     mean   median       uq      max neval cld
    LAP 1.173902 1.208178 1.580413 1.253404 1.313137 17.07946   100  a 
 h3rm4n 5.538701 5.732692 7.310704 5.913030 6.138168 50.67234   100   b