Supprimer rapidement les variables à variance nulle d'un data.frame
J'ai un grand data.frame généré par un processus indépendant de ma volonté, qui peut contenir ou non des variables à variance nulle (c'est-à-dire que toutes les observations sont identiques). J'aimerais construire un modèle prédictif basé sur ces données, et ces variables sont évidemment inutiles.
Voici la fonction que j'utilise actuellement pour supprimer ces variables du fichier data.frame. Il est actuellement basé sur apply, et je me demandais s’il existe des moyens évidents d’accélérer cette fonction afin qu’elle fonctionne rapidement sur de très grands ensembles de données, avec un grand nombre (400 ou 500) de variables.
set.seed(1)
dat <- data.frame(
A=factor(rep("X",10),levels=c('X','Y')),
B=round(runif(10)*10),
C=rep(10,10),
D=c(rep(10,9),1),
E=factor(rep("A",10)),
F=factor(rep(c("I","J"),5)),
G=c(rep(10,9),NA)
)
zeroVar <- function(data, useNA = 'ifany') {
out <- apply(data, 2, function(x) {length(table(x, useNA = useNA))})
which(out==1)
}
Et voici le résultat du processus:
> dat
A B C D E F G
1 X 3 10 10 A I 10
2 X 4 10 10 A J 10
3 X 6 10 10 A I 10
4 X 9 10 10 A J 10
5 X 2 10 10 A I 10
6 X 9 10 10 A J 10
7 X 9 10 10 A I 10
8 X 7 10 10 A J 10
9 X 6 10 10 A I 10
10 X 1 10 1 A J NA
> dat[,-zeroVar(dat)]
B D F G
1 3 10 I 10
2 4 10 J 10
3 6 10 I 10
4 9 10 J 10
5 2 10 I 10
6 9 10 J 10
7 9 10 I 10
8 7 10 J 10
9 6 10 I 10
10 1 1 J NA
> dat[,-zeroVar(dat, useNA = 'no')]
B D F
1 3 10 I
2 4 10 J
3 6 10 I
4 9 10 J
5 2 10 I
6 9 10 J
7 9 10 I
8 7 10 J
9 6 10 I
10 1 1 J
N'utilisez pas table() - très lent pour de telles choses. Une option est length(unique(x)):
foo <- function(dat) {
out <- lapply(dat, function(x) length(unique(x)))
want <- which(!out > 1)
unlist(want)
}
system.time(replicate(1000, zeroVar(dat)))
system.time(replicate(1000, foo(dat)))
Ce qui est un ordre de grandeur plus rapide que le vôtre sur l'exemple de jeu de données tout en produisant une sortie similaire:
> system.time(replicate(1000, zeroVar(dat)))
user system elapsed
3.334 0.000 3.335
> system.time(replicate(1000, foo(dat)))
user system elapsed
0.324 0.000 0.324
La solution de Simon ici est également rapide sur cet exemple:
> system.time(replicate(1000, which(!unlist(lapply(dat,
+ function(x) 0 == var(if (is.factor(x)) as.integer(x) else x))))))
user system elapsed
0.392 0.000 0.395
mais vous devrez voir s'ils s'adaptent à la taille réelle du problème.
Vous pouvez également vouloir examiner la fonction nearZeroVar() dans le paquet caret.
Si vous avez un événement sur 1000, il peut être judicieux de supprimer ces données (mais cela dépend du modèle). nearZeroVar() peut le faire.
N'utilisez simplement pas table - il est extrêmement lent sur les vecteurs numériques car il les convertit en chaînes. Je voudrais probablement utiliser quelque chose comme
var0 <- unlist(lapply(df, function(x) 0 == var(if (is.factor(x)) as.integer(x) else x)))
Il sera TRUE pour 0-variance, NA pour les colonnes avec des NA et FALSE pour une variance non nulle
Utilisez le package Caret et la fonction nearZeroVar
require(caret)
NZV<- nearZeroVar(dataset, saveMetrics = TRUE)
NZV[NZV[,"zeroVar"] > 0, ]
NZV[NZV[,"zeroVar"] + NZV[,"nzv"] > 0, ]
Pourquoi ne pas utiliser factor pour compter le nombre d'éléments uniques et boucler avec sapply:
dat[sapply(dat, function(x) length(levels(factor(x)))>1)]
B D F
1 3 10 I
2 4 10 J
3 6 10 I
4 9 10 J
5 2 10 I
6 9 10 J
7 9 10 I
8 7 10 J
9 6 10 I
10 1 1 J
Les NA sont exclus par défaut, mais cela peut être changé avec le paramètre exclude de factor:
dat[sapply(dat, function(x) length(levels(factor(x,exclude=NULL)))>1)]
B D F G
1 3 10 I 10
2 4 10 J 10
3 6 10 I 10
4 9 10 J 10
5 2 10 I 10
6 9 10 J 10
7 9 10 I 10
8 7 10 J 10
9 6 10 I 10
10 1 1 J NA
Eh bien, économisez du temps de codage:
Rgames: foo
[,1] [,2] [,3]
[1,] 1 1e+00 1
[2,] 1 2e+00 1
[3,] 1 3e+00 1
[4,] 1 4e+00 1
[5,] 1 5e+00 1
[6,] 1 6e+00 2
[7,] 1 7e+00 3
[8,] 1 8e+00 1
[9,] 1 9e+00 1
[10,] 1 1e+01 1
Rgames: sd(foo)
[1] 0.000000e+00 3.027650e+00 6.749486e-01
Warning message:
sd(<matrix>) is deprecated.
Use apply(*, 2, sd) instead.
Pour éviter les ronds arrondis en virgule flottante, prenez ce vecteur de sortie, que j'appellerai "bar", et exécutez quelque chose comme bar[bar< 2*.Machine$double.eps] <- 0. Enfin, votre cadre de données dat[,as.logical(bar)] devrait faire l'affaire.
Vérifiez cette fonction personnalisée. Je ne l'ai pas essayé sur des trames de données contenant plus de 100 variables.
remove_low_variance_cols <- function(df, threshold = 0) {
n <- Sys.time() #See how long this takes to run
remove_cols <- df %>%
select_if(is.numeric) %>%
map_dfr(var) %>%
gather() %>%
filter(value <= threshold) %>%
spread(key, value) %>%
names()
if(length(remove_cols)) {
print("Removing the following columns: ")
print(remove_cols)
}else {
print("There are no low variance columns with this threshold")
}
#How long did this script take?
print(paste("Time Consumed: ", Sys.time() - n, "Secs."))
return(df[, setdiff(names(df), remove_cols)])
}
Je pense qu'avoir une variance nulle équivaut à être constant et que l'on peut se déplacer sans aucune opération arithmétique. Je m'attendrais à ce que range () surpasse var (), mais je n'ai pas vérifié cela:
removeConstantColumns <- function(a_dataframe, verbose=FALSE) {
notConstant <- function(x) {
if (is.factor(x)) x <- as.integer(x)
return (0 != diff(range(x, na.rm=TRUE)))
}
bkeep <- sapply(a_dataframe, notConstant)
if (verbose) {
cat('removeConstantColumns: '
, ifelse(all(bkeep)
, 'nothing'
, paste(names(a_dataframe)[!bkeep], collapse=',')
, ' removed', '\n')
}
return (a_dataframe[, bkeep])
}