How do I create columns which count another column with certain conditions? R

EDIT: Completely deleted everything and started over.

I really hope for your sake someone comes up with a less messy answer, but these functions should work.

FindFirstVector = function(TreatmentVector){
  #Which entries are equal to 0
  id = which(TreatmentVector == 0)
  #IDs of first zeros occuring (First day w.o. treatment)
  id1 = id[c(0,diff(id)) != 1]
  #Create vector of zeroes
  temp = rep(0,length(TreatmentVector))
  #Add 1 for the first zero
  temp[id1] = 1
  #Take cumulative sum
  cumsum(temp)
}


FindSecondVector = function(TreatmentVector){
  #Which entries are equal to 0
  id = which(TreatmentVector == 0)
  #IDs of first zeros occuring (First day w.o. treatment)
  id1 = id[c(0,diff(id)) != 1]
  #IDs of last zeros (Last day w.o. treatment)
  id2 = id[c(diff(id),2) > 1]
  #Amount of days w.o. treatment is then:
  d = id2 - id1 + 1
  #id3 is then the starting id of period of no treatment, if the period is longer
  #than 2 days. Then 2 is added, so start counting from day 3 of the period.
  id3 = id1[id2 - id1 + 1 > 2] + 2
  temp = rep(0,length(TreatmentVector))
  temp[id3] = 1
  cumsum(temp)
}


# Building third vector ---------------------------------------------------
FindThirdVector = function(TreatmentVector){
  #Which entries are equal to 0
  id = which(TreatmentVector == 0)
  #IDs of first zeros occuring (First day w.o. treatment)
  id1 = id[c(0,diff(id)) != 1]
  #IDs of last zeros (Last day w.o. treatment)
  id2 = id[c(diff(id),2) > 1]
  #Amount of days w.o. treatment is then:
  d = id2 - id1 + 1
  #id3 is then the starting id of period of no treatment, if the period is longer
  #than 2 days. Then 2 is added, so start counting from day 3 of the period.
  id3 = id1[id2 - id1 + 1 > 2] + 2
  #The id of the ending day of period w.o. treatment longer than 2 days.
  id4 = id2[id2 - id1 + 1 > 2]
  
  #d is the amount of days to add 1's
  d = id4-id3
  temp = rep(0,length(TreatmentVector))
  while(any(d!=0)){
    temp[id3 + d] = 1
    d = d - 1
    d[d<0] = 0
  }
  temp[id3 + d] = 1
  cumsum(temp)
}

Then you should find your three vectors by running:

FindFirstVector(dat$`treatment (type)`)
FindSecondVector(dat$`treatment (type)`)
FindThirdVector(dat$`treatment (type)`)

Here is a shorter (and in my opinion, cleaner) solution using dplyr. I'm not sure about the error you got with the other solution, but maybe this works better for you.

# Group by record_id
data = data %>% group_by(record_id)

# Define helper column
count_streak = function(v) accumulate(v, ~if_else(.y, .x + 1, 0), .init = 0)[-1]
data = data %>% mutate(interruption_streak = count_streak(`treatment (type)` == 0))

data = data %>%
  mutate(n_interruption_periods = cumsum(interruption_streak == 1),
         n_interruption_periods_3days = cumsum(interruption_streak == 3),
         n_interruption_days_3days = cumsum(interruption_streak >= 3))

We define a helper column interruption_streak that counts up with each day of the current interruption period. So on the first day of every interruption period, it is 1, and so on.

From this, we can calculate the other columns:

• n_interruption_periods is simply the cumulative count of days where an interruption period begins.
• n_interruption_periods_3days is the cumulative count of third days of interruption periods.
• n_interruption_days_3days is the cumulative count of days that are the third day or higher of an interruption period.

I hope this explanation made sense, otherwise feel free to ask.

I think we can modify the function I wrote in your last post to solve all your problems. Consider the following function.

conditional_count <- function(x, n, pfill = function(p0) integer(length(p0)), ifill = seq_along, iend = 30L) {
  len <- length(x); out <- integer(len)
  p0 <- which(x == 0L)
  if (n > 1L)
    p0 <- Reduce(function(idx, i) {
      lidx <- idx - i + 1L
      idx <- idx[lidx > 0L]; lidx <- lidx[lidx > 0L]
      idx[x[lidx] == 0L]
    }, seq_len(n)[-1L], p0)
  if (length(p0) < 1L)
    return(out)
  ub <- pmin(c(tail(p0, -1L), len), p0 + iend - 1L)
  rl <- ub - p0 + 1L
  pfill <- pfill(p0)
  res <- unlist(lapply(seq_along(rl), function(i) ifill(integer(rl[[i]])) + pfill[[i]]))
  pos <- inverse.rle(list(lengths = rl, values = p0)) + unlist(lapply(rl, seq_len)) - 1L
  `[<-`(out, pos, res)
}

Let p0 be the vector that contains the positions of all valid interruptions identified. pfill and ifill are two control functions for conditional_count. pfill controls how to fill in each position in the vector p0; ifill controls how to fill in the gap between two valid interruptions. The final sequence in-between two valid interruptions will be ifill + pfill. iend controls the desired length of the final sequence. See below the illustration (x is treatment (type))

ifill controls the numbers  at *:             *****   *****   (iend = 5L for example)
pfill controls the numbers  at ?:             ?       ?
p0 identifies                   :             v       v
x looks like                    :   1    2    0  ...  0  ... 

Using n = 1 as an example, your last problem simplifies to

conditional_count(x, 1L, function(p0) integer(length(p0)), seq_along, 30L)

ifill + pfill                              :       1 2 3 4 ...  1 2 3 4 ...
ifill is a sequence along the gap positions:       1 2 3 4 ...  1 2 3 4 ...
pfill is always 0 at all positions of p0   :       0            0       
p0 identifies                              :       v            v       
x looks like                               :   1 2 0 ........   0       

This problem simplifies to

conditional_count(x, 1L, function(p0) cumsum(p0 - head(c(-1L, p0), -1L) > 1L), function(x) integer(length(x)), Inf)

ifill + pfill                                  :       1 1 1 ...     2 2 ...
ifill is always 0 along the gap positions      :       0 0 0 ...     0 0 ...  (iend = Inf means filling in a sequence until the end of the gap)
pfill increases 1 at each starting streak of 0s:       1             2
p0 identifies                                  :       v v v         v v
x looks like                                   :   1 2 0 0 0 ....... 0 0 ...

conditional_count(x, 1L, seq_along, function(x) integer(length(x)), Inf)

ifill + pfill                            :       1 2 3 ...     4 5 ...
ifill is always 0 along the gap positions:       0 0 0 ...     0 0 ...  (iend = Inf means filling in a sequence until the end of the gap)
pfill increases 1 at each 0              :       1 2 3         4 5
p0 identifies                            :       v v v         v v
x looks like                             :   1 2 0 0 0 ....... 0 0 ...

The full script for this problem is

conditional_count <- function(x, n, pfill = function(p0) integer(length(p0)), ifill = seq_along, iend = 30L) {
  len <- length(x); out <- integer(len)
  p0 <- which(x == 0L)
  if (n > 1L)
    p0 <- Reduce(function(idx, i) {
      lidx <- idx - i + 1L
      idx <- idx[lidx > 0L]; lidx <- lidx[lidx > 0L]
      idx[x[lidx] == 0L]
    }, seq_len(n)[-1L], p0)
  if (length(p0) < 1L)
    return(out)
  ub <- pmin(c(tail(p0, -1L), len), p0 + iend - 1L)
  rl <- ub - p0 + 1L
  pfill <- pfill(p0)
  res <- unlist(lapply(seq_along(rl), function(i) ifill(integer(rl[[i]])) + pfill[[i]]))
  pos <- inverse.rle(list(lengths = rl, values = p0)) + unlist(lapply(rl, seq_len)) - 1L
  `[<-`(out, pos, res)
}

count_streak <- function(p0) cumsum(p0 - head(c(-1L, p0), -1L) > 1L)
integer_along <- function(x) integer(length(x))

df %>%
  mutate(
    n_interruption_periods = conditional_count(`treatment (type)`, 1L, count_streak, integer_along, Inf),
    n_interruption_periods_3days = conditional_count(`treatment (type)`, 3L, count_streak, integer_along, Inf),
    n_interruption_days_3days = conditional_count(`treatment (type)`, 3L, seq_along, integer_along, Inf)
  )

Output

   record_id start stop treatment (type) n_interruption_periods n_interruption_periods_3days n_interruption_days_3days
1     110101     0    1                1                      0                            0                         0
2     110101     1    2                1                      0                            0                         0
3     110101     2    3                1                      0                            0                         0
4     110101     3    4                0                      1                            0                         0
5     110101     4    5                0                      1                            0                         0
6     110101     5    6                0                      1                            1                         1
7     110101     6    7                0                      1                            1                         2
8     110101     7    8                2                      1                            1                         2
9     110101     8    9                2                      1                            1                         2
10    110101     9   10                2                      1                            1                         2
11    110101    10   11                0                      2                            1                         2
12    110101    11   12                0                      2                            1                         2
13    110101    12   13                0                      2                            2                         3
14    110101    13   14                0                      2                            2                         4
15    110101    14   15                0                      2                            2                         5
16    110101    15   16                0                      2                            2                         6
17    110101    16   17                3                      2                            2                         6
18    110101    17   18                3                      2                            2                         6
19    110101    18   19                0                      3                            2                         6
20    110101    19   20                3                      3                            2                         6
21    110101    20   21                3                      3                            2                         6
22    110101    21   22                3                      3                            2                         6
23    110101    22   23                0                      4                            2                         6
24    110101    23   24                2                      4                            2                         6
25    110101    24   25                2                      4                            2                         6
26    110101    25   26                2                      4                            2                         6
27    110101    26   27                0                      5                            2                         6
28    110101    27   28                0                      5                            2                         6
29    110101    28   29                0                      5                            3                         7
30    110101    29   30                1                      5                            3                         7
31    110101    30   31                1                      5                            3                         7
32    110101    31   32                1                      5                            3                         7
33    110101    32   33                1                      5                            3                         7
34    110101    33   34                1                      5                            3                         7
35    110101    34   35                1                      5                            3                         7
36    110101    35   36                1                      5                            3                         7
37    110101    36   37                1                      5                            3                         7
38    110101    37   38                1                      5                            3                         7
39    110101    38   39                1                      5                            3                         7
40    110101    39   40                1                      5                            3                         7
41    110101    40   41                1                      5                            3                         7
42    110101    41   42                1                      5                            3                         7
43    110101    42   43                1                      5                            3                         7
44    110101    43   44                1                      5                            3                         7
45    110101    44   45                1                      5                            3                         7
46    110101    45   46                1                      5                            3                         7
47    110101    46   47                1                      5                            3                         7
48    110101    47   48                1                      5                            3                         7
49    110101    48   49                1                      5                            3                         7
50    110101    49   50                1                      5                            3                         7
51    110101    50   51                1                      5                            3                         7
52    110101    51   52                1                      5                            3                         7
53    110101    52   53                1                      5                            3                         7
54    110101    53   54                1                      5                            3                         7
55    110101    54   55                1                      5                            3                         7
56    110101    55   56                1                      5                            3                         7
57    110101    56   57                1                      5                            3                         7
58    110101    57   58                1                      5                            3                         7
59    110101    58   59                1                      5                            3                         7
60    110101    59   60                1                      5                            3                         7