Flagging system: Check for changing values in a data frame

Question

I've written the following code to check if a value in a data frame changes. I'm looking at the last 5 values. If there was no change at all I want my code to return 1, if a single one (or multiple) of the last 5 are different to the value that is being checked return 0. Finally I want the returned values in a new column in my data frame.

Here's my code so far. It works but I think there is a nicer (and more clean) way to do it.

mydata <- data.frame("id" = 1:100, "ta" = c(sample(x = c(-5:20), size = 94, replace = T), rep(1,6))) # include a repetition to check if code works
nums <- mydata$id # create a dummy for iteration
qc_dummy <- vector(mode = "list", length = length(nums)) # create a dummy vector for the values computed in the for loop

for(i in 1:length(nums)) {
  qc_dummy[[i]] <- ifelse(mydata[nums[i], 2] - mydata[nums[i-1], 2] == 0, 
                          ifelse(mydata[nums[i], 2] - mydata[nums[i-2], 2] == 0,
                                 ifelse(mydata[nums[i], 2] - mydata[nums[i-3], 2] == 0,
                                        ifelse(mydata[nums[i], 2] - mydata[nums[i-4], 2] == 0,
                                               ifelse(mydata[nums[i], 2] - mydata[nums[i-5], 2] == 0, 1, 0) ,0), 0) ,0) ,0) 
}
mydata$qc1 <- as.vector(c(0,unlist(qc_dummy))) # first value of list is skipped by unlist (logi(0)) -> add 0

Answer 1

I reduced the example data, for easier viewing

# new example data:
mydata <- data.frame(ta = 1:13)
mydata[2:3, 1] <- 1L
mydata[6:12, 1] <- 2L

n <- 3 # how many equal values we need

require(data.table)
setDT(mydata) # convert to data.table
mydata
mydata[, mathcPrev := fifelse((ta - shift(ta, 1)) == 0L, T, F, F)]
mydata[, g := cumsum(!mathcPrev)] # grouping value, if value has changed
mydata[, count := cumsum(mathcPrev), by = g]
mydata[, qc2 := fifelse(count >= n, 1L, 0L)]
mydata
#     ta mathcPrev g count qc2
#  1:  1     FALSE 1     0   0
#  2:  1      TRUE 1     1   0
#  3:  1      TRUE 1     2   0
#  4:  4     FALSE 2     0   0
#  5:  5     FALSE 3     0   0
#  6:  2     FALSE 4     0   0
#  7:  2      TRUE 4     1   0
#  8:  2      TRUE 4     2   0
#  9:  2      TRUE 4     3   1
# 10:  2      TRUE 4     4   1
# 11:  2      TRUE 4     5   1
# 12:  2      TRUE 4     6   1
# 13: 13     FALSE 5     0   0

So, the idea is to create index mathcPrev, that shows if this value matches previous, and then we can count how many equal values we have in a row.

Answer 2

To my understanding you want a new column qc1 that takes value 1 if the current element matches the previous 5 elements and takes value 0 otherwise.

This feels like a great application of run-length encoding. I'll borrow the great example data from @minem:

mydata <- data.frame(ta = 1:13)
mydata[2:3, 1] <- 1L
mydata[6:12, 1] <- 2L
mydata$ta
#  [1]  1  1  1  4  5  2  2  2  2  2  2  2 13

The run-length encoding tells us how many times each value is repeated in a row:

rle(mydata$ta)
# Run Length Encoding
#   lengths: int [1:5] 3 1 1 7 1
#   values : int [1:5] 1 4 5 2 13

We read from this output that we have 5 runs: 1 repeated 3 times, 4 repeated 1 time, 5 repeated 1 time, 2 repeated 7 times, and 13 repeated 1 time. For each run, we know the first 5 values won't be preceded by 5 identical elements (0 in the output), while elements 6 and onward will (1 in the output). So the number of 0s at the beginning of each run is:

with(rle(mydata$ta), pmin(lengths, 5))
# [1] 3 1 1 5 1

And the number of 1s at the end of each run is:

with(rle(mydata$ta), pmax(lengths-5, 0))
# [1] 0 0 0 2 0

So we just need to interleave these two vectors within a call to rep to yield your eventual one-liner for this operation:

mydata$qc1 <- with(rle(mydata$ta),
                   rep(rep(0:1, length(values)), c(rbind(pmin(lengths, 5), pmax(lengths-5, 0)))))
mydata
#    ta qc1
# 1   1   0
# 2   1   0
# 3   1   0
# 4   4   0
# 5   5   0
# 6   2   0
# 7   2   0
# 8   2   0
# 9   2   0
# 10  2   0
# 11  2   1
# 12  2   1
# 13 13   0

If you were planning to do this with a bunch of different window sizes, then a function would make the most sense, which would take the window size as an argument. Here I'll split up the calculation into smaller pieces for readability:

window.repeat <- function(vals, window.size) {
  r <- rle(vals)
  num.run <- length(r$values)
  run.0s <- with(r, pmin(lengths, window.size))
  run.1s <- with(r, pmax(lengths-window.size, 0))
  rep(rep(0:1, num.run), c(rbind(run.0s, run.1s)))
}

Now we could, for instance, label each element with whether it had 2 or more repeats before it:

mydata$qc1 <- window.repeat(mydata$ta, 2)
mydata
#    ta qc1
# 1   1   0
# 2   1   0
# 3   1   1
# 4   4   0
# 5   5   0
# 6   2   0
# 7   2   0
# 8   2   1
# 9   2   1
# 10  2   1
# 11  2   1
# 12  2   1
# 13 13   0

Answer 3

If you are willing to use additional packages, then this could be cleanly handled by performing a rolling apply on your vector. For instance, you could compute if the rolling minimum of your vector with window length 6 equals the rolling maximum with the same window length:

library(RcppRoll)
as.numeric(roll_min(mydata$ta, 6) == roll_max(mydata$ta, 6))
# [1] 0 0 0 0 0 1 1 0

All we need to do is add 0 for the first 5 elements (which have been removed from this calculation), yielding our one-liner:

mydata$qc1 <- c(rep(0, 5), roll_min(mydata$ta, 6) == roll_max(mydata$ta, 6))
mydata
#    ta qc1
# 1   1   0
# 2   1   0
# 3   1   0
# 4   4   0
# 5   5   0
# 6   2   0
# 7   2   0
# 8   2   0
# 9   2   0
# 10  2   0
# 11  2   1
# 12  2   1
# 13 13   0

You could also wrap this into a function to allow variable window sizes:

window.repeat <- function(vals, window.size) {
  c(rep(0, window.size), roll_min(vals, window.size+1) == roll_max(vals, window.size+1))
}