Эффективно изменять элементы данных на основе соседних элементов
Позвольте мне углубиться. Представьте, что у вас есть данные, которые выглядят так:
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".
