Extend runs of certain length

user_13277423 0
Viewed 150

I have a 640 x 2500 dataframe with numeric values and several NA values. My goal is to find a minimum of 75 consecutive NA values in each row. For each such run, I want to replace the previous and following 50 cells with NA values too.

Here's a scaled down example of one row: 

x <- c(1, 3, 4, 5, 4, 3, NA, NA, NA, NA, 6, 9, 3, 2, 4, 3)
#        run of four NA:  ^   ^   ^   ^

I want to detect the run of four consecutive NA, and then replace three values before and three values after the run with NA:

c(1, 3, 4, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 2, 4, 3) 
#           ^   ^   ^                   ^   ^   ^

I have tried to first identify the consecutive NAs with rle, but running rle(is.na(df)) gives the error 'x' must be a vector of an atomic type. This occurs even when I select a single row.

Unfortunately, I do not know what the next steps to take would be in converting the previous and following 50 cells to NA.

Would highly appreciate any help on this, thanks in advance.

run-length-encoding na r
3 Answers

Because you comment that in your data "some [rows] begin and end with several NAs", hopefully this better represents the real data:

  A  B  C  D  E  F  G  H  I  J
1 1  2  3 NA NA  6  7  8 NA 10
2 1 NA NA NA  5  6  7 NA NA NA
3 1  2  3  4 NA NA NA  8  9 10

Let's assume that the minimum run length of NA to be expanded with NA is 2, and that two values before and two values after the run should be replaced with NA. In this example, row 2 would represent the case you mentioned in comment.

First some data wrangling. I prefer to work with a data.table in long format. With data.table we have access to the useful constants .I and .N, and can easily create run IDs with rleid. 

# convert data.frame to data.table
library(data.table)
setDT(d)

# set minimum length of runs to be expanded
len = 2L

# set number of values to replace on each side of run
n = 2L

# number of columns of original data (for truncation of indices)
nc = ncol(d)

# create a row index to keep track of the original rows in the long format
d[ , ri := 1:.N]

# melt from wide to long format
d2 = melt(d, id.vars = "ri")

# order by row index
setorder(d2, ri)

Now the actual calculations on the runs and their indices:

d2[
  # check if the run is an "NA run" and has sufficient length 
  d2[ , if(anyNA(value) & .N >= len){

    # get indices before and after run, where values should be changed to NA  
    ix = c(.I[1] - n:1L, .I[.N] + 1L:n)

    # truncate indices to keep them within (original) rows 
    ix[ix >= 1 + (ri - 1) * nc & ix <= nc * ri]},

    # perform the calculation by row index and run index
    # grab replacement indices
    by = .(ri, rleid(is.na(value)))]$V1,

  # at replacement indices, set value to NA 
  value := NA]

If desired, cast back to wide format

dcast(d2, ri ~ variable, value.vars = "value")
#    ri  A  B  C  D  E  F  G  H  I  J
# 1:  1  1 NA NA NA NA NA NA  8 NA 10
# 2:  2 NA NA NA NA NA NA NA NA NA NA
# 3:  3  1  2 NA NA NA NA NA NA NA 10
user_18517120

Type coercion worked for me:

rle(as.logical(is.na(x[MyRow, ])))
user_132415450

Here is my solution for this. I wonder if there is a tidier solution than mine though.

library(data.table)
df <- matrix(nrow = 1,ncol = 16)
df[1,] <- c(1, 3, 4, 5, 4, 3, NA, NA, NA, NA, 6, 9, 3, 2, 4, 3)
df <- df %>%
  as.data.table() # dataset created

# A function to do what you need
NA_replacer <- function(x){
  Vector <- unlist(x) # pull the values into a vector

  NAs <- which(is.na(Vector)) # locate the positions of the NAs
  NAs_Position_1 <- cumsum(c(1, diff(NAs) - 1)) # Find those that are in sequential order
  NAs_Position_2 <- rle(NAs_Position_1) # Find their values

  NAs <- NAs[which(
    NAs_Position_1 == with(NAs_Position_2,
                           values[which(
                             lengths == 4)]))] # Locate the position of those NAs that are repeated exactly 4 times

  if(length(NAs == 4)){ # Check if there are a stretch of 4 WAs
    Vector[seq(NAs[1]-3,
               NAs[1]-1,1)] <- NA # this part deals with the 3 positions occuring before the first NA
    Vector[seq(NAs[length(NAs)]+1,
               NAs[length(NAs)]+3,1)] <- NA # this part deals with the 3 positions occuring after the last NA
  }
  Vector
}

> df # the original dataset
V1 V2 V3 V4 V5 V6 V7 V8 V9 V10 V11 V12 V13 V14 V15 V16
1:  1  3  4  5  4  3 NA NA NA  NA   6   9   3   2   4   3

# the transformed dataset
apply(df, 1, function(x) NA_replacer(x)) %>%
  as.data.table() %>%
  data.table::transpose()

V1 V2 V3 V4 V5 V6 V7 V8 V9 V10 V11 V12 V13 V14 V15 V16
1:  1  3  4 NA NA NA NA NA NA  NA  NA  NA  NA   2   4   3

As an aside, the speed is quite good for a hypothetical dataframe sized 640*2500 where a stretch of 75 or more NAs have to be located and the 50 values before and after must be replaced with an NA.

df <- matrix(nrow = 640,ncol = 2500)

for(i in 1:nrow(df)){
  df[i,] <- c(1:100,rep(NA,75),rep(1,2325))
}

NA_replacer <- function(x){
  Vector <- unlist(x) # pull the values into a vector

  NAs <- which(is.na(Vector)) # locate the positions of the NAs
  NAs_Position_1 <- cumsum(c(1, diff(NAs) - 1)) # Find those that are in sequential order
  NAs_Position_2 <- rle(NAs_Position_1) # Find their values

  NAs <- NAs[which(
    NAs_Position_1 == with(NAs_Position_2,
                           values[which(
                             lengths >= 75)]))] # Locate the position of those NAs that are repeated exactly 75 times or more than 75 times

  if(length(NAs >= 75)){ # Check if the condition is met
    Vector[seq(NAs[1]-50,
               NAs[1]-1,1)] <- NA # this part deals with the 50 positions occuring before the first NA
    Vector[seq(NAs[length(NAs)]+1,
               NAs[length(NAs)]+50,1)] <- NA # this part deals with the 50 positions occuring after the last NA
  }
  Vector
}

# Check how many NAs are present in the first row of the dataset prior to applying the function
which(is.na(df %>%
              as_tibble() %>%
              slice(1) %>%
              unlist())) %>% # run the code till here to get the indices of the NAs
  length() 

[1] 75

df <- apply(df, 1, function(x) NA_replacer(x)) %>%
  as.data.table() %>%
  data.table::transpose()

# Check how many NAs are present in the first row post applying the function
which(is.na(df %>%
              slice(1) %>%
              unlist())) %>% # run the code till here to get the indices of the NAs
  length()

[1] 175

system.time(df <- apply(df, 1, function(x) NA_replacer(x)) %>%
              as.data.table() %>%
              data.table::transpose())
user  system elapsed 
  0.216   0.002   0.220
user_119070160
Related