Эффективно изменять элементы данных на основе соседних элементов

Позвольте мне углубиться. Представьте, что у вас есть данные, которые выглядят так:

 df <- data.frame(one = c(1, 1, NA, 13), 
                  two = c(2, NA,10, 14), 
                three = c(NA,NA,11, NA), 
                 four = c(4, 9, 12, NA))

Это дает нам:

df
#   one two three four
# 1   1   2    NA    4
# 2   1  NA    NA    9
# 3  NA  10    11   12
# 4  13  14    NA   NA

Каждая строка представляет собой измерения в неделю 1, 2, 3 и 4 соответственно. Предположим, что числа представляют собой некоторую накопленную меру с момента последнего измерения. Например, в строке 1 "4" в столбце "четыре" представляет собой кумулятивное значение недели 3 и 4.

Теперь я хочу "выровнять" эти числа (не стесняйтесь исправить мою терминологию здесь), равномерно распределяя измерения на все недели до измерения, если в предшествующие недели измерения не проводились. Например, строка 1 должна читать

 1 2 2 2

так как 4 в исходных данных представляет собой совокупное значение 2 недели (неделя "три" и "четыре" ), а 4/2 равно 2.

Конечный конечный результат должен выглядеть следующим образом:

df
#  one two three four
# 1   1   2    2    2
# 2   1   3    3    3
# 3   5   5   11   12
# 4  13  14   NA   NA

Я немного борюсь с тем, как наилучшим образом подойти к этому. Одним из возможных вариантов решения было бы получить индексы всех отсутствующих значений, затем подсчитать длину прогонов (НС, возникающих несколько раз), и использовать это, чтобы каким-то образом заполнить значения. Однако мои реальные данные велики, и я думаю, что такая стратегия может занять много времени. Есть ли более простой и эффективный способ?

ОТВЕТЫ

Ответ 1

Базовое решение R должно было бы сначала идентифицировать индексы, которые необходимо заменить, а затем определить группировки этих индексов, окончательно назначив сгруппированные значения с помощью функции ave:

clean <- function(x) {
  to.rep <- which(is.na(x) | c(FALSE, head(is.na(x), -1)))
  groups <- cumsum(c(TRUE, head(!is.na(x[to.rep]), -1)))
  x[to.rep] <- ave(x[to.rep], groups, FUN=function(y) {
    rep(tail(y, 1) / length(y), length(y))
  })
  return(x)
}
t(apply(df, 1, clean))
#      one two three four
# [1,]   1   2     2    2
# [2,]   1   3     3    3
# [3,]   5   5    11   12
# [4,]  13  14    NA   NA

Если эффективность важна (на ваш вопрос это подразумевается), то решение Rcpp может быть хорошим вариантом:

library(Rcpp)
cppFunction(
"NumericVector cleanRcpp(NumericVector x) {
  const int n = x.size();
  NumericVector y(x);
  int consecNA = 0;
  for (int i=0; i < n; ++i) {
    if (R_IsNA(x[i])) {
      ++consecNA;
    } else if (consecNA > 0) {
      const double replacement = x[i] / (consecNA + 1);
      for (int j=i-consecNA; j <= i; ++j) {
        y[j] = replacement;
      }
      consecNA = 0;
    } else {
      consecNA = 0;
    }
  }
  return y;
}")
t(apply(df, 1, cleanRcpp))
#      one two three four
# [1,]   1   2     2    2
# [2,]   1   3     3    3
# [3,]   5   5    11   12
# [4,]  13  14    NA   NA

Мы можем сравнить производительность на более крупном экземпляре (матрица 10000 x 100):

set.seed(144)
mat <- matrix(sample(c(1:3, NA), 1000000, replace=TRUE), nrow=10000)
all.equal(apply(mat, 1, clean), apply(mat, 1, cleanRcpp))
# [1] TRUE
system.time(apply(mat, 1, clean))
#    user  system elapsed 
#   4.918   0.035   4.992 
system.time(apply(mat, 1, cleanRcpp))
#    user  system elapsed 
#   0.093   0.016   0.120

В этом случае решение Rcpp обеспечивает примерно 40-кратное ускорение по сравнению с базовой реализацией R.

Ответ 2

Здесь базовое R-решение, которое почти так же быстро, как josilber Rcpp:

spread_left <- function(df) {
    nc <- ncol(df)
    x <- rev(as.vector(t(as.matrix(cbind(df, -Inf)))))
    ii <- cumsum(!is.na(x))
    f <- tabulate(ii)
    v <- x[!duplicated(ii)]
    xx <- v[ii]/f[ii]
    xx[xx == -Inf] <- NA
    m <- matrix(rev(xx), ncol=nc+1, byrow=TRUE)[,seq_len(nc)]
    as.data.frame(m)
}
spread_left(df)
#   one two three four
# 1   1   2     2    2
# 2   1   3     3    3
# 3   5   5    11   12
# 4  13  14    NA   NA

Ему удается быть относительно быстро, вектурируя все и полностью избегая дорогостоящих вызовов apply(). (Недостатком является то, что он также относительно запутан, чтобы увидеть, как он работает, сделайте debug(spread_left), а затем примените его к небольшому data.frame df в OP.

Ниже приведены эталоны для всех опубликованных в настоящее время решений:

library(rbenchmark)
set.seed(144)
mat <- matrix(sample(c(1:3, NA), 1000000, replace=TRUE), nrow=10000)
df <- as.data.frame(mat)

## First confirm that it produces the same results
identical(spread_left(df), as.data.frame(t(apply(mat, 1, clean)))) 
# [1] TRUE

## Then compare its speed
benchmark(josilberR     = t(apply(mat, 1, clean)),
          josilberRcpp  = t(apply(mat, 1, cleanRcpp)),
          Josh          = spread_left(df),
          Henrik        = t(apply(df, 1, fn)),
          replications = 10)
#           test replications elapsed relative user.self sys.self
# 4       Henrik           10   38.81   25.201     38.74     0.08
# 3         Josh           10    2.07    1.344      1.67     0.41
# 1    josilberR           10   57.42   37.286     57.37     0.05
# 2 josilberRcpp           10    1.54    1.000      1.44     0.11

Ответ 3

Другая возможность base. Сначала я создаю переменную группировки (grp), по которой затем выполняется "распространение" с помощью ave.

fn <- function(x){
  grp <- rev(cumsum(!is.na(rev(x))))
  res <- ave(x, grp, FUN = function(y) sum(y, na.rm = TRUE) / length(y))
  res[grp == 0] <- NA
  res
}

t(apply(df, 1, fn))
#      one two three four
# [1,]   1   2     2    2
# [2,]   1   3     3    3
# [3,]   5   5    11   12
# [4,]  13  14    NA   NA

Ответ 4

Я думал, что если NA относительно редки, возможно, лучше сделать изменения по ссылке. (Я предполагаю, что так работает подход Rcpp.) Вот как это можно сделать в data.table, заимствуя функцию @Henrik почти дословно и преобразовывая в длинный формат:

require(data.table) # 1.9.5
fill_naseq <- function(df){

    # switch to long format
    DT  <- data.table(id=(1:nrow(df))*ncol(df),df)
    mDT <- setkey(melt(DT,id.vars="id"),id)
    mDT[,value := as.numeric(value)]

    mDT[,badv  := is.na(value)]     
    mDT[
      # subset to rows that need modification
      badv|shift(badv),
      # apply @Henrik function, more or less
      value:={
        g = ave(!badv,id,FUN=function(x)rev(cumsum(rev(x))))+id
        ave(value,g,FUN=function(x){n = length(x); x[n]/n})
    }]

    # revert to wide format
    (setDF(dcast(mDT,id~variable)[,id:=NULL]))
}

identical(fill_naseq(df),spread_left(df)) # TRUE

Чтобы показать наилучший сценарий для этого подхода, я смоделировал так, что NA очень редки:

nr = 1e4
nc = 100
nafreq = 1/1e4

mat <- matrix(sample(
  c(NA,1:3),
  nr*nc, 
  replace=TRUE,
  prob=c(nafreq,rep((1-nafreq)/3,3))
),nrow=nr)
df  <- as.data.frame(mat)

benchmark(F=fill_naseq(df),Josh=spread_left(df),replications=10)[1:5]
#   test replications elapsed relative user.self
# 1    F           10    3.82    1.394      3.72
# 2 Josh           10    2.74    1.000      2.70
# I don't have Rcpp installed and so left off josilber even faster approach

Итак, он все еще медленнее. Однако, если данные хранятся в длинном формате, перестройка не понадобится:

DT  <- data.table(id=(1:nrow(df))*ncol(df),df)
mDT <- setkey(melt(DT,id.vars="id"),id)
mDT[,value := as.numeric(value)]

fill_naseq_long <- function(mDT){
    mDT[,badv := is.na(value)]
    mDT[badv|shift(badv),value:={
      g = ave(!badv,id,FUN=function(x)rev(cumsum(rev(x))))+id
      ave(value,g,FUN=function(x){n = length(x); x[n]/n})
    }]
    mDT
}

benchmark(
  F2=fill_naseq_long(mDT),F=fill_naseq(df),Josh=spread_left(df),replications=10)[1:5]
#   test replications elapsed relative user.self
# 2    F           10    3.98    8.468      3.81
# 1   F2           10    0.47    1.000      0.45
# 3 Josh           10    2.72    5.787      2.69

Теперь это немного быстрее. И кто не любит хранить свои данные в длинном формате? Это также имеет преимущество в работе, даже если у нас нет такого количества наблюдений на "id".