appiattisce l'elenco annidato con la media dei vettori

Question

Dire che ho un elenco annidato di vettori.

lst1 <- list(`A`=c(a=1,b=1), `B`=c(a=1), `C`=c(b=1), `D`=c(a=1,b=1,c=1)) 
lst2 <- list(`A`=c(b=1), `B`=c(a=1,b=1), `C`=c(a=1,c=1), `D`=c(a=1,c=1)) 
lstX <- list(lst1, lst2) 

Come visto, ciascun vettore A,B,C,D verificano due volte con a,b,c presente in diverse frequenze.

Come sarebbe il modo più efficiente di appiattire gli elenchi in modo che a,b,c venga sommato o una media su A,B,C,D attraverso gli elenchi annidati, come illustrato di seguito. La vera lista contiene diverse centinaia di migliaia di liste annidate.

#summed 
    a b c 
A 1 2 NA 
B 2 1 NA 
C 1 1 1 
D 2 1 2 

#averaged 
    a b c 
A 0.5 1 NA 
B 1 0.5 NA 
C 0.5 0.5 0.5 
D 1 0.5 1 

Answer 1

Ecco una soluzione semplice base di R (che tornerà 0 invece di NA s (non so se abbastanza buono)

temp <- unlist(lstX) 
res <- data.frame(do.call(rbind, strsplit(names(temp), "\\.")), value = temp) 

somme

xtabs(value ~ X1 + X2, res) 
# X2 
# X1 a b c 
# A 1 2 0 
# B 2 1 0 
# C 1 1 1 
# D 2 1 2 

Mezzi

xtabs(value ~ X1 + X2, res)/length(lstX) 
# X2 
# X1 a b c 
# A 0.5 1.0 0.0 
# B 1.0 0.5 0.0 
# C 0.5 0.5 0.5 
# D 1.0 0.5 1.0 

---

alternativa , soluzione più flessibile data.table

library(data.table) #V1.9.6+ 
temp <- unlist(lstX) 
res <- data.table(names(temp))[, tstrsplit(V1, "\\.")][, value := temp] 

Sum

dcast(res, V1 ~ V2, sum, value.var = "value", fill = NA) 
# V1 a b c 
# 1: A 1 2 NA 
# 2: B 2 1 NA 
# 3: C 1 1 1 
# 4: D 2 1 2 

Mezzi

dcast(res, V1 ~ V2, function(x) sum(x)/length(lstX), value.var = "value", fill = NA) 
# V1 a b c 
# 1: A 0.5 1.0 NA 
# 2: B 1.0 0.5 NA 
# 3: C 0.5 0.5 0.5 
# 4: D 1.0 0.5 1.0 

In generale, è possibile utilizzare praticamente qualsiasi funzione con dcast

Answer 2

Questa non è la risposta più breve, né il più veloce, ma siamo in grado di provare qualcosa di simile:

### Get all the vector names 
names <- lapply(lstX, function(l) lapply(l, names)) 
names <- unique(unlist(names)) 
names 
## [1] "a" "b" "c" 

## Check if a name is missing, for example 
setdiff(names, names(lstX[[1]][[1]])) 
## [1] "c" 


## Now we will check for every vectors within each list 
## and fill the missing names with NA and order the results 
lstX <- lapply(lstX, function(l) { 
    lapply(l, function(v) { 
    v[setdiff(names, names(v))] <- NA 
    v[order(names(v))] ## order by names to bind it without errors 
    }) 
}) 

lstX 
## [[1]] 
## [[1]]$A 
## a b c 
## 1 1 NA 

## [[1]]$B 
## a b c 
## 1 NA NA 

## [[1]]$C 
## a b c 
## NA 1 NA 

## [[1]]$D 
## a b c 
## 1 1 1 


## [[2]] 
## [[2]]$A 
## a b c 
## NA 1 NA 

## [[2]]$B 
## a b c 
## 1 1 NA 

## [[2]]$C 
## a b c 
## 1 NA 1 

## [[2]]$D 
## a b c 
## 1 NA 1 


### Now we can bind it 
matlist <- lapply(lstX, function(l) do.call(rbind, l)) 
matlist 
## [[1]] 
## a b c 
## A 1 1 NA 
## B 1 NA NA 
## C NA 1 NA 
## D 1 1 1 

## [[2]] 
## a b c 
## A NA 1 NA 
## B 1 1 NA 
## C 1 NA 1 
## D 1 NA 1 


mysum <- apply(simplify2array(matlist), c(1, 2), 
      function(x) ifelse(all(is.na(x)), NA, sum(x, na.rm = TRUE))) 
mysum 
## a b c 
## A 1 2 NA 
## B 2 1 NA 
## C 1 1 1 
## D 2 1 2 


### Average over list 
mysum/length(res) 
##  a b c 
## A 0.5 1.0 NA 
## B 1.0 0.5 NA 
## C 0.5 0.5 0.5 
## D 1.0 0.5 1.0 

EDIT

Grazie a @CathG, è possibile creare rapidamente matlist come questo

matlist <- lapply(lstX, function(x) { 
    t(sapply(x, function(y) { 
    y <- y[names] 
    names(y) <- names 
    y 
    })) 
}) 

Answer 3

Potremmo anche provare

library(data.table) 
DT1 <- rbindlist(lapply(do.call('c', lstX), 
      as.data.frame.list), fill=TRUE, idcol=TRUE) 
DT1[, lapply(.SD, sum, na.rm=TRUE), .id] 
# .id a b c 
#1: A 1 2 0 
#2: B 2 1 0 
#3: C 1 1 1 
#4: D 2 1 2 

DT1[, lapply(.SD, function(x) sum(x, na.rm=TRUE)/.N), .id] 
# .id a b c 
#1: A 0.5 1.0 0.0 
#2: B 1.0 0.5 0.0 
#3: C 0.5 0.5 0.5 
#4: D 1.0 0.5 1.0