Как работать с данными о продольных симптомах в R, используя lag / lead и ifelse / case_when (или другое решение)?

Question

Сообщество Hi переполнения стека,

Я относительно новичок в R (9 месяцев), и это мой первый вопрос по переполнению стека с представлением и очень буду признателен за любую помощь. Я в основном использую Tidyverse, хотя я открыт для базовых решений R.

Проблема:

У меня ~ 21 000 строк данных о симптомах с> 10 переменными в день. Я хотел бы иметь возможность классифицировать «обострения» заболевания (в данном случае инфекции грудной клетки при заболевании легких), используя правила для определения начала и конца эпизода, чтобы впоследствии можно было рассчитать продолжительность эпизодов, тип эпизода ( это зависит от сочетания симптомов) и полученного лечения. Как и в любом наборе данных с участием пациентов, отсутствуют значения. Я приписал с самого последнего дня, если данные меньше, чем за 2 дня.

Приведенный ниже код является упрощенным, составленным примером, включающим только 1 симптом.

Правило обострения: начало обострения = 2 дня с ухудшением симптомов (> = 3) Разрешение обострения = 5 дней с нормальным дыханием (<= 2) </p>

В идеале я бы хотел иметь возможность определить все дни, когда обострение тоже происходит.

Вот данные:

#load packages
library(tidyverse)

#load data

id <- "A"

day <- c(1:50)

symptom <- c(2,2,2,2,2,2,2,2,2,2,2,3,2,2,2,2,NA,NA,NA,2,2,2,3,3,3,4,4,3,3,2,3,2,2,3,3,2,2,2,2,2,2,3,2,2,2,2,2,3,2,2)


df <- data.frame(id,day,symptom)

#Data Dictionary
#Symptom: 1 = Better than usual, 2 = Normal/usual, 3 = Worse than usual, 4 = Much worse than usual

Что я пробовал:

Я пытался приблизиться к этому, используя комбинацию lag () и lead () с условные операторы case_when () и ifelse ().

df %>% 
  mutate_at(vars("symptom"), #used for more variables within vars() argument
            .funs = list(lead1 = ~ lead(., n = 1),
                         lead2 = ~ lead(., n = 2),
                         lead3 = ~ lead(., n = 3),
                         lead4 = ~ lead(., n = 4),
                         lead5 = ~ lead(., n = 5),
                         lag1 = ~ lag(., n = 1),
                         lag2 = ~ lag(., n = 2),
                         lag3 = ~ lag(., n = 3))) %>%

  mutate(start = case_when(symptom <= 2 ~ 0,
                                        symptom >= 3 ~
                                        ifelse(symptom >= lag2 & symptom <= lag1,1,0)),

         end = case_when(symptom >=3 ~ 
                                      ifelse(lead1 <=2 &
                                             lead2 <=2 &
                                             lead3 <=2 &
                                             lead4 <=2 &
                                             lead5 <=2,1,0)))

Моя главная проблема - это сложность. Поскольку я встраиваю больше симптомов и правил, я должен ссылаться на различные переменные, в которых есть операторы ifelse () / case_when (). Я уверен, что есть более элегантное решение моей проблемы.

Другая проблема заключается в том, что во время «обострения» переменная exacerbation_start должна использоваться только в начале, а не во время эпизода. Точно так же для exacerbation_end это будет применимо только тогда, когда обострение уже происходит. Я пытался использовать операторы ifelse () для ссылки на обострение, но не смог заставить его работать и подчиняться желаемому правилу.

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

   id  day   symptom  start   end   exacerbation
1   A   1       2        0     0        0
2   A   2       2        0     0        0
3   A   3       2        0     0        0
4   A   4       2        0     0        0       
5   A   5       2        0     0        0        
6   A   6       2        0     0        0           
7   A   7       2        0     0        0          
8   A   8       2        0     0        0          
9   A   9       2        0     0        0           
10  A  10       2        0     0        0      
11  A  11       2        0     0        0          
12  A  12       3        0     0        0           
13  A  13       2        0     0        0    
14  A  14       2        0     0        0      
15  A  15       2        0     0        0          
16  A  16       2        0     0        0     
17  A  17      NA        0     0        0        
18  A  18      NA        0     0        0          
19  A  19      NA        0     0        0          
20  A  20       2        0     0        0       
21  A  21       2        0     0        0            
22  A  22       2        0     0        0       
23  A  23       3        0     0        0           
24  A  24       3        1     0        1                    
25  A  25       3        0     0        1              
26  A  26       4        0     0        1                  
27  A  27       4        0     0        1     
28  A  28       3        0     0        1          
29  A  29       3        0     0        1   
30  A  30       2        0     0        1 
31  A  31       3        0     0        1
32  A  32       2        0     0        1    
33  A  33       2        0     0        1   
34  A  34       3        0     0        1  
35  A  35       3        0     1        1  
36  A  36       2        0     0        0     
37  A  37       2        0     0        0 
38  A  38       2        0     0        0     
39  A  39       2        0     0        0  
40  A  40       2        0     0        0   
41  A  41       2        0     0        0 
42  A  42       3        0     0        0 
43  A  43       2        0     0        0
44  A  44       2        0     0        0 
45  A  45       2        0     0        0      
46  A  46       2        0     0        0   
47  A  47       2        0     0        0      
48  A  48       3        0     0        0   
49  A  49       2        0     0        0  
50  A  50       2        0     0        0 

Я с нетерпением жду ваших ответов!

РЕДАКТИРОВАТЬ

Я добавил еще 50 строк данных для имитации нескольких обострений и проблемы с правильной цензурой и NA. , Я также включил второго участника "B", чтобы увидеть, является ли это причиной проблем.

id <- c("A","A","A","A","A","A","A","A","A","A","A","A","A","A","A","A",
        "A","A","A","A","A","A","A","A","A","A","A","A","A","A","A","A",
        "A","A","A","A","A","A","A","A","A","A","A","A","A","A","A","A","A","A",
        "B","B","B","B","B","B","B","B","B","B","B","B","B","B","B","B",
        "B","B","B","B","B","B","B","B","B","B","B","B","B","B","B","B",
        "B","B","B","B","B","B","B","B","B","B","B","B","B","B","B","B","B","B")

day <- c(1:50,1:50)

symptom <- c(2,3,3,3,3,2,2,2,2,2,2,3,2,2,2,2,NA,NA,NA,2,2,2,3,3,3,4,4,3,3,2,3,2,2,3,3,2,2,2,2,2,2,3,2,2,2,2,2,3,2,2,           2,2,2,2,2,2,3,2,3,3,2,3,2,3,2,2,2,2,2,2,3,3,3,3,NA,NA,NA,2,2,2,3,2,2,2,2,2,3,2,2,3,NA,NA,NA,3,3,3,3,3,3,2)

df <- data.frame(id,day,symptom)

     id day symptom start end   exacerbation censor
1    A   1       2     0   0            0      0
2    A   2       3     1   0            1      0
3    A   3       3     0   0            1      0
4    A   4       3     0   0            1      0
5    A   5       3     0   1            1      0
6    A   6       2     0   0            0      0
7    A   7       2     0   0            0      0
8    A   8       2     0   0            0      0
9    A   9       2     0   0            0      0
10   A  10       2     0   0            0      0
11   A  11       2     0   0            0      0
12   A  12       3     0   0            0      0
13   A  13       2     0   0            0      0
14   A  14       2     0   0            0      0
15   A  15       2     0   0            0      0
16   A  16       2     0   0            0      0
17   A  17      NA     0   0            0      0
18   A  18      NA     0   0            0      0
19   A  19      NA     0   0            0      0
20   A  20       2     0   0            0      0
21   A  21       2     0   0            0      0
22   A  22       2     0   0            0      0
23   A  23       3     1   0            1      0
24   A  24       3     0   0            1      0
25   A  25       3     0   0            1      0
26   A  26       4     0   0            1      0
27   A  27       4     0   0            1      0
28   A  28       3     0   0            1      0
29   A  29       3     0   0            1      0
30   A  30       2     0   0            1      0
31   A  31       3     0   0            1      0
32   A  32       2     0   0            1      0
33   A  33       2     0   0            1      0
34   A  34       3     0   0            1      0
35   A  35       3     0   0            1      0
36   A  36       2     0   0            1      0
37   A  37       2     0   0            1      0
38   A  38       2     0   0            1      0
39   A  39       2     0   0            1      0
40   A  40       2     0   0            1      0
41   A  41       2     0   1            1      0
42   A  42       3     0   0            0      0
43   A  43       2     0   0            0      0
44   A  44       2     0   0            0      0
45   A  45       2     0   0            0      0
46   A  46       2     0   0            0      0
47   A  47       2     0   0            0      0
48   A  48       3     0   0            0      0
49   A  49       2     0   0            0      0
50   A  50       2     0   0            0      0
51   B   1       2     0   0            0      0
52   B   2       2     0   0            0      0
53   B   3       2     0   0            0      0
54   B   4       2     0   0            0      0
55   B   5       2     0   0            0      0
56   B   6       2     0   0            0      0
57   B   7       3     0   0            0      0
58   B   8       2     0   0            0      0
59   B   9       3     0   0            0      0
60   B  10       3     1   0            1      0
61   B  11       2     0   0            1      0
62   B  12       3     0   0            1      0
63   B  13       2     0   0            1      0
64   B  14       3     0   0            1      0
65   B  15       2     0   0            1      0
66   B  16       2     0   0            1      0
67   B  17       2     0   0            1      0
68   B  18       2     0   0            1      0
69   B  19       2     0   1            1      0
70   B  20       2     0   0            0      0
71   B  21       3     1   0            1      0
72   B  22       3     0   0            1      0
73   B  23       3     0   0            1      0
74   B  24       3     0   0            1      0
75   B  25      NA     0   0            0      1
76   B  26      NA     0   0            0      1
77   B  27      NA     0   0            0      1
78   B  28       2     0   0            0      1
79   B  29       2     0   0            0      1
80   B  30       2     0   0            0      1
81   B  31       3     0   0            0      1
82   B  32       2     0   0            0      1
83   B  33       2     0   0            0      1
84   B  34       2     0   0            0      1
85   B  35       2     0   0            0      1
86   B  36       2     0   0            0      1
87   B  37       3     0   0            0      0
88   B  38       2     0   0            0      0
89   B  39       2     0   0            0      0
90   B  40       3     0   0            0      0
91   B  41      NA     0   0            0      0
92   B  42      NA     0   0            0      0
93   B  43      NA     0   0            0      0
94   B  44       3     1   0            1      0
95   B  45       3     0   0            1      0
96   B  46       3     0   0            1      0
97   B  47       3     0   0            1      0
98   B  48       3     0   0            1      0
99   B  49       3     0   0            1      0
100  B  50       2     0   0            1      0
>

Answer 1

Я могу вернуться с менее запутанным подходом, но попробуйте это:

library(dplyr)
library(tidyr)

df %>%
  group_by(id,
           idx = with(
             rle(
               case_when(symptom <= 2 ~ 'normal', 
                         symptom >= 3 ~ 'worse',
                         TRUE ~ symptom %>% as.character)),
             rep(seq_along(lengths), lengths)
             )
           ) %>%
  mutate(
    trajectory = case_when(cumsum(symptom <= 2) == 5 ~ 2, cumsum(symptom >= 3) == 2 ~ 1)
    ) %>%
  group_by(id) %>% fill(trajectory) %>% 
  mutate(
    trajectory = replace_na(trajectory, 0),
    start = +(trajectory == 1 & lag(trajectory) == 2),
    end = +(trajectory == 2 & lag(trajectory) == 1),
    exacerbation = +(trajectory == 1 | start == 1 | end == 1)
  ) %>% 
  select(-idx, -trajectory) %>% as.data.frame

Вывод:

   id day symptom start end exacerbation
1   A   1       2     0   0            0
2   A   2       2     0   0            0
3   A   3       2     0   0            0
4   A   4       2     0   0            0
5   A   5       2     0   0            0
6   A   6       2     0   0            0
7   A   7       2     0   0            0
8   A   8       2     0   0            0
9   A   9       2     0   0            0
10  A  10       2     0   0            0
11  A  11       2     0   0            0
12  A  12       3     0   0            0
13  A  13       2     0   0            0
14  A  14       2     0   0            0
15  A  15       2     0   0            0
16  A  16       2     0   0            0
17  A  17      NA     0   0            0
18  A  18      NA     0   0            0
19  A  19      NA     0   0            0
20  A  20       2     0   0            0
21  A  21       2     0   0            0
22  A  22       2     0   0            0
23  A  23       3     0   0            0
24  A  24       3     1   0            1
25  A  25       3     0   0            1
26  A  26       4     0   0            1
27  A  27       4     0   0            1
28  A  28       3     0   0            1
29  A  29       3     0   0            1
30  A  30       2     0   0            1
31  A  31       3     0   0            1
32  A  32       2     0   0            1
33  A  33       2     0   0            1
34  A  34       3     0   0            1
35  A  35       3     0   0            1
36  A  36       2     0   0            1
37  A  37       2     0   0            1
38  A  38       2     0   0            1
39  A  39       2     0   0            1
40  A  40       2     0   1            1
41  A  41       2     0   0            0
42  A  42       3     0   0            0
43  A  43       2     0   0            0
44  A  44       2     0   0            0
45  A  45       2     0   0            0
46  A  46       2     0   0            0
47  A  47       2     0   0            0
48  A  48       3     0   0            0
49  A  49       2     0   0            0
50  A  50       2     0   0            0

Answer 2

Вот попытка более элегантного и масштабируемого способа написания вашего алгоритма:

Во-первых, вам не нужно вычислять вызовы lead и lag, прежде чем вы сможете использовать case_when. Следует отметить, что хорошей практикой является явное указание параметра TRUE для case_when. Вот некоторый код.

df2=df %>% 
  mutate(
    exacerbation_start = case_when(
      is.na(symptom) ~ NA_real_,
      symptom <= 2 ~ 0,
      symptom >= 3 & symptom >= lag(symptom, n=2) & symptom <= lag(symptom, n=1) ~ 1,
      TRUE ~ 0
    ),
    exacerbation_end = case_when(
      symptom >=3 ~ ifelse(lead(symptom, n=1) <=2 &
                             lead(symptom, n=2) <=2 & lead(symptom, n=3) <=2 &
                             lead(symptom, n=4) <=2 & lead(symptom, n=5) <=2,
                           1,0),
      TRUE ~ NA_real_
    )
  )
all.equal(df1,df2) #TRUE

В качестве альтернативы, если ваш алгоритм одинаков для всех симптомов, вы можете использовать пользовательские функции:

get_exacerbation_start = function(x){
  case_when( 
    is.na(x) ~ NA_real_, 
    x <= 2 ~ 0,
    x >= 3 & x >= lag(x, n=2) & x <= lag(x, n=1) ~ 1,
    TRUE ~ 0
  )
}
get_exacerbation_end = function(x){
  case_when(
    x >=3 ~ ifelse(x >=3 & lead(x, n=1) <=2 & 
                     lead(x, n=2) <=2 & lead(x, n=3) <=2 & 
                     lead(x, n=4) <=2 & lead(x, n=5) <=2,
                   1,0),
    TRUE ~ NA_real_
  )
}
df3=df %>% 
  mutate(
    exacerbation_start = get_exacerbation_start(symptom),
    exacerbation_end = get_exacerbation_end(symptom)
  )

all.equal(df1,df3) #also TRUE

Этот последний способ может быть даже более мощный с некоторыми mutate_at вызовами.

РЕДАКТИРОВАТЬ : после просмотра вашего редактирования, вот попытка получить период обострения. На мой взгляд, код довольно уродливый, я не уверен, что row_number должен был использоваться таким образом.

df_final=df %>% 
  transmute(
    id,day,symptom, 
    start = get_exacerbation_start(symptom),
    end = get_exacerbation_end(symptom),
    exacerbation = row_number()>=which(start==1)[1] & row_number()<=which(end==1)[1]
  )