Mélanger le vecteur dans R, mais les éléments identiques doivent avoir une distance minimale

Donc, fondamentalement, nous devons échantillonner conditionnellement un élément du vecteur x qui n'a pas été sélectionné dans les min.dist-1 . En utilisant la réduction de Purrr, nous pouvons y parvenir:

shuffler <- function(x, min.dist=2){
    while(any(unlist(lapply(unique(tl<-tail(l<-shuffle(x, min.dist=min.dist), 2*min.dist)), function(x) diff(which(tl==x))<=min.dist)))){}
    l
}

shuffler <- function(x, min.dist=2){
    while(!length(unique(print(tail(l<-shuffle(x, min.dist=min.dist), min.dist+1))))==min.dist+1){}
    l
}

table(print(shuffler(rep(LETTERS[1:5], 3),2)))
 [1] "A" "B" "C" "E" "B" "C" "D" "A" "C" "D" "A" "E" "B" "D" "E"

A B C D E 
3 3 3 3 3 

table(print(shuffler(rep(LETTERS[1:5], 3),2)))
[1] "D" "C" "C"
[1] "C" "C" "E"
[1] "C" "A" "C"
[1] "D" "B" "D"
[1] "B" "E" "D"
 [1] "C" "A" "E" "D" "A" "B" "C" "E" "A" "B" "D" "C" "B" "E" "D"

A B C D E 
3 3 3 3 3 

Emballé dans une fonction

shuffle <- function(x, min.dist=2){
    stopifnot(min.dist < length(unique(x)))
    reduce(integer(length(x)-1), function(.x, ...){
        # whether the value is in the tail of the aggregated vector
        in.tail <- x %in% tail(.x, min.dist)
        # whether a value still hasn't reached the max frequency
        freq.got <- x %in% names(t<-table(x[x%in%.x]) > table(.x))[t]
        # whether a value isn't in the aggregated vector
        yet <- !x %in% .x
        # the if is there basically to account for the cases when we don't have enough vars to space out the vectors
         c(.x, if(any((!in.tail & freq.got) | yet )) sample(x[(!in.tail & freq.got) | yet ], 1) else  x[which(freq.got)[1]] )
    }, .init=sample(x,1))
}

shuffle <- function(x, min.dist=2){
    stopifnot(min.dist < length(unique(x)))
    reduce(integer(length(x)-1), ~ c(.x, sample(x[!x %in% tail(.x, min.dist) &( x %in% names(t <- table(x[x%in%.x]) > table(.x))[t] | !x %in% .x)], 1)), .init=sample(x,1))
}
> table(shuffle(rep(LETTERS[1:5], 3),2))

A B C D E 
3 3 3 3 3 
> table(shuffle(rep(LETTERS[1:5], 3),2))
Error in sample.int(length(x), size, replace, prob) : 
  invalid first argument

après @ 27Ï • 9 commentaire:

> shuffle(x, 3)
 [1] "A" "C" "B" "D" "E" "A" "B" "C" "E" "D" "A" "B" "C" "E" "A"
> shuffle(x, 3)
 [1] "A" "B" "D" "E" "C" "A" "B" "D" "E" "C" "A" "D" "E" "C" "A"
> shuffle(x, 4)
 [1] "C" "E" "D" "A" "B" "C" "E" "D" "A" "B" "C" "E" "D" "A" "B"
> shuffle(x, 4)
 [1] "A" "B" "D" "E" "C" "A" "B" "D" "E" "C" "A" "B" "D" "E" "C"
> shuffle(x, 2)
 [1] "E" "A" "D" "E" "B" "D" "A" "E" "C" "D" "A" "E" "C" "A" "B"
> shuffle(x, 2)
 [1] "B" "A" "D" "C" "B" "A" "E" "B" "A" "E" "B" "C" "D" "A" "E"

MISE À JOUR

Après quelques essais et erreurs, en regardant le fait que vous n'aurez pas toujours assez d'éléments pour espacer la liste min.dist J'ai trouvé une solution, ce code est le plus expliqué parmi ceux ci-dessus:

shuffle <- function(x, min.dist=2){
    stopifnot(min.dist < length(unique(x)))
    reduce(integer(length(x)-1), ~c(.x, sample(x[!x %in% tail(.x, min.dist)], 1)), .init=sample(x,1))
}

maintenant la table(shuffle(rep(LETTERS[1:5], 3),2)) retournera toujours 3 pour toutes les variables et nous pouvons dire avec une certaine certitude que dans le vecteur les variables sont espacées d'une distance minimale de 2 . la seule façon de garantir qu'aucun élément n'est dupliqué est d'utiliser min.dist=length(unique(x))-1 sinon il y aura des instances où au maximum r < min.dist éléments ne sont pas distancés min.dist de leur dernier occurrences, et si de tels éléments existent, ils seront dans le sous-ensemble length(x) + 1 - 1:min.dist du vecteur résultant.

Juste pour être complètement sûr en utilisant une boucle pour vérifier si la queue du vecteur de sortie a des valeurs uniques: (supprimez l'instruction d'impression que je l'ai utilisée juste à des fins de démonstration)

[1] "A" "E" "D" "B" "A" "D" "E" "C" "D" "A" "C" "E" "B" "A" "E"

Mise à jour:

min.dist <- 2
reduce(integer(length(x)-1), ~c(.x, sample(x[!x %in% tail(.x, min.dist)], 1)), .init=sample(x,1))

cette nouvelle version fait un test rigoureux pour savoir si les éléments dans la queue du vecteur sont min.dist , la version précédente fonctionne pour min.dist=2 , cependant cette nouvelle version fait de meilleurs tests.

J'espère que cette réponse fonctionne bien pour vous. C'est fait avec la base R, mais ça marche. Je quitte l'impression si vous souhaitez vérifier ligne par ligne:

x <- rep(LETTERS[1:5], 3)  # Create example vector


shuffle <- function(x, min_dist=3){
  #init variables   
  result<-c() # result vector
  count<-0
  vec_use<-x
  vec_keep<-c()
  for(i in 1:length(x)){
#    print(paste0("iteration =", i))
    if (count>min_dist){
      valback<-vec_keep[1]
#      print(paste0("value to be returned:",  valback))
      ntimes_valback<-(table(vec_keep)[valback])
      vec_use<- c(vec_use,rep(valback,ntimes_valback))
#      print(paste0("vec_use after giving back valbak =", valback))
#      print(paste0(vec_use,","))
      vec_keep <- vec_keep[!vec_keep %in% valback]
#      print(paste0("vec_keep after removing valback =", valback))
#      print(paste0(vec_keep,","))
    }
    val<-sample(vec_use,1)
#    print(paste0("val = ",val))#remove value
    vec_keep<- c(vec_keep,x[x %in% val])
    vec_keep<-vec_keep[1:(length(vec_keep)-1)]#removing 1 letter
#    print(paste0("vec_keep ="))
#    print(paste0(vec_keep,","))
    vec_use <- vec_use[!vec_use %in% val]
#    print(paste0("vec_use ="))
#    print(paste0(vec_use,","))
    result[i]<-val
    count<-count+1
    }
  return(result)
}
shuffle(x)
"C" "D" "B" "E" "C" "A" "B" "D" "E" "A" "C" "D" "B" "E" "C"

Si vos données sont volumineuses, il est peut-être (beaucoup) plus rapide de s'appuyer sur la probabilité pour faire ce genre de tâche.

Voici un exemple:

library(microbenchmark)

x = rep(c(letters, LETTERS), 10)
length(x)
#> [1] 520

microbenchmark(prob_shuffler(x, 1), shuffler_am(x, 1), shuffler_csf(x, 1), times = 10)
#> Unit: microseconds
#>                 expr       min        lq       mean    median        uq        max neval
#>  prob_shuffler(x, 1)    87.001   111.501    155.071   131.801   192.401    264.401    10
#>    shuffler_am(x, 1) 17218.100 18041.900  20324.301 18740.351 22296.301  26495.200    10
#>   shuffler_csf(x, 1) 86771.401 88550.501 118185.581 95582.001 98781.601 341826.701    10

microbenchmark(prob_shuffler(x, 2), shuffler_am(x, 2), shuffler_csf(x, 2), times = 10)
#> Unit: microseconds
#>                 expr     min        lq       mean    median        uq        max neval
#>  prob_shuffler(x, 2)   140.1   195.201   236.3312   245.252   263.202    354.101    10
#>    shuffler_am(x, 2) 18886.2 19526.901 22967.6409 21021.151 26758.800  29133.400    10
#>   shuffler_csf(x, 2) 86078.1 92209.901 97151.0609 97612.251 99850.101 107981.401    10

microbenchmark(prob_shuffler(x, 3), shuffler_am(x, 3), shuffler_csf(x, 3), times = 10)
#> Unit: microseconds
#>                 expr       min        lq        mean     median       uq        max neval
#>  prob_shuffler(x, 3)   318.001   450.402    631.5312    573.352    782.2   1070.401    10
#>    shuffler_am(x, 3) 19003.501 19622.300  23314.4808  20784.551  28281.5  32885.101    10
#>   shuffler_csf(x, 3) 87692.701 96152.202 101233.5411 100925.201 108034.7 113814.901    10

Même si le while en boucle semble convergence effrayante, dans la pratique est rapide. Bien sûr, plus la probabilité d'avoir deux caractères à min.dist distance min.dist , plus la convergence est rapide.

Les solutions actuelles de @Abdessabour Mtk et @Carles Sans Fuentes fonctionnent mais, en fonction de la taille des données d'entrée, deviennent rapidement trop lentes. Voici une référence:

prob_shuffler = function(x, min.dist = 2){
    n = length(x)
    res = sample(x)
    OK = FALSE
    
    # We loop until we have a solution
    while(!OK){
        OK = TRUE
        for(i in 1:min.dist){
            # We check if identical elements are 'i' steps away
            pblm = res[1:(n-i)] == res[-(1:i)]
            if(any(pblm)){
                if(sum(pblm) >= (n - i)/2){
                    # back to square 1
                    res = sample(x)
                } else {
                    # we pair each identical element with 
                    # an extra one
                    extra = sample(which(!pblm), sum(pblm))
                    id_reshuffle = c(which(pblm), extra)
                    res[id_reshuffle] = sample(res[id_reshuffle])
                }

                # We recheck from the beginning
                OK = FALSE
                break
            }
        }
    }

    res
}

Nous pouvons remarquer deux choses: a) en toute logique, la vitesse de prob_shuffler dépend de min.dist tandis que les autres méthodes pas tellement, b) prob_shuffler est environ 100 fois plus rapide pour seulement 520 observations (et il évolue).

Bien sûr, si la probabilité d'avoir deux caractères identiques à la liste min.dist . Est extrêmement élevée, les méthodes récursives devraient être plus rapides. Mais dans la plupart des cas pratiques, la méthode des probabilités est plus rapide.