Finding values below a threshold

Question

I am wondering if it's possible to avoid looping. I want to make the function faster. The function is to find how many times a particular value is lower in the overall data. For example:

Value <- c(0,10,5,1,0,0,11,0,0,7,3,2,5) # length =13

The 1st value is 0 and 0 is NOT lower in any of the values. Therefore the value I would like to return from the function would be 0.

Something like this:

sum(Values < 0) 
0

The 2nd value is 10:

sum(Values < 10)
11

I make a function something like below:

fun_num <- function(Value){
  gg <- vector()
  for (i in seq_along(Value)){
    x <- Value[i]
    y <- sum(Value < x)
    gg[i] <- y
  }
  return(gg)
}

Applying the function:

fun_num(Value)

[1]  0 11  8  5  0  0 12  0  0 10  7  6  8

Just wondering, is there a way to speed this function up using sapply and avoid using for loop?

Answer 1

This should suffice

fun_2 <- function(x) sapply(x, function(y) sum(x < y))
fun_2(Value)
# [1]  0 11  8  5  0  0 12  0  0 10  7  6  8

P.S. sapply/lapply are the same loops, just masked and a little bit faster.

Or if your data is very large we can do it a lot faster using data.table, aggregating the data and counting:

require(data.table)
fun_3 <- function(Value) {
  d <- data.table(x = Value) # creates 1 column data.table
  # setkey(d, x) # not needed here keyby sets the key
  d <- d[, .N, keyby = x] # calculate count of each unique x value
  # and sorts the results
  d[, a := c(0, cumsum(N)[-.N])] # calculate lagged cumsum from N (counts)
  # a represents element count that is smaller than x
  d[.(Value), a] # using datatable-keys-fast-subset get a(result) for each Value
}

set.seed(42)
Value2 <- sample.int(1e5)

system.time(r2 <- fun_2(Value2)) # 36.64 
system.time(r3 <- fun_3(Value2)) # 0.03 
all.equal(r2, r3)
# [1] TRUE

OR with base R:

fun_4 <- function(x) {
  xorder <- order(x)
  xsorted <- x[xorder]
  xsdifs <- c(0, diff(xsorted))
  m <- seq_along(xsdifs) - 1L
  m[xsdifs == 0L] <- 0L
  m <- cummax(m)
  m[order(xorder)]
}

For reverse (Value > x):

fun_2r <- function(x) sapply(x, function(y) sum(x > y))
fun_3r <- function(Value) {
  d <- data.table(x = Value)
  d <- d[, .N, keyby = x]
  setorder(d, -x)
  d[, a := c(0, cumsum(N)[-.N])]
  setkey(d, x) # need to reset key for sub setting,
  # because reordering d removes it
  d[.(Value), a]
}

Answer 2

Consider also colSums wrapping outer where you compare the vector with itself:

less_than <- function (vec)
      colSums(outer(vec, vec, function (x, y) x < y))

less_than(Value)
# [1]  0 11  8  5  0  0 12  0  0 10  7  6  8