Как сгенерировать N самых разнородных комбинаций в R - PullRequest
Новая
       101

Как сгенерировать N самых разнородных комбинаций в R

0 голосов
/ 17 мая 2018

У меня есть набор из 6 цветовых кодов (x), набор из N особей, каждый из которых должен быть помечен уникальным цветовым кодом, и четыре места на каждом животном, каждое из которых может нести свой цвет. У меня 6 разных цветов.

Итак, коды для двух отдельных могут быть;
1. красный, синий, синий, белый
2. белый, желтый, розовый, желтый

Однако, поскольку цвет в каждой позиции может упасть, я хотел бы создать избыточную схему маркировки , которая позволила бы по-прежнему отличать человека от других, даже после того, как он потерял цвет в одном (или даже двух?) местах.

Несмотря на то, что 6 цветов и 4 позиции дают 1296 комбинаций, мне трудно выбрать N самых разных комбинаций:

Воспроизводимый пример: 

library(gtools)
x     <- c("white", "red", "green", "blue", "pink", "yellow")
Perms <- permutations(n=6,r=4,v=x,repeats.allowed=T)
print(nrow(Perms))
head(Perms)

Обратите внимание, что первые 6 комбинаций различаются по цвету только на 1 позиции - потеря этого кода на> 1 человека будет означать, что их больше нельзя будет различить!

Итак, для значений N от 50 до 150, как выбрать N наиболее разнородных комбинаций ?

Спасибо!

Ответы [ 3 ]

0 голосов
/ 17 мая 2018

Воспроизводимый пример предложения LAP выше. Обратите внимание, что из-за зависимости от случайной выборки это все еще не гарантирует, что не будет пар кодов, которые отличаются только в одной позиции. Тем не менее, это хорошее начало - спасибо LAP! 

# install.packages("gtools")
library(gtools)
library(vwr)

## Available colours
x <- c("W", "R", "G", "B", "P", "Y")

## Generate all possible colour combinations, for 6 colours & 4 positions
body <- data.frame(permutations(n=6,r=4,v=x,repeats.allowed=T), stringsAsFactors = F) ; colnames(body) <- c("Head","Thorax","L_gaster","R_gaster")

## concatenate each colour-code to a sequence without spaces, etc
m    <- paste( body$Head, body$Thorax, body$L_gaster, body$R_gaster, sep="")


## 
set.seed(1)
COLONY_SIZE <- 50    ## How many adult workers in the colony excluding the queen
N_Attempts  <- 1000  ## How many alternative solutions to generate - the more the better, but it takes longer

## prepare data-containers
Summary <- NULL
LvList <- list()

for (TRY in 1:N_Attempts)
{print(paste(TRY,"of",N_Attempts))
  y <- sample(m, COLONY_SIZE)     ## randomly sample COLONY_SIZE codes
  ## measure pairwise Levenshtein distances for all pair combinations
  Matrix <- sapply(y, function(x) levenshtein.distance(x, y))
  diag(Matrix) <- NA              ## eliminate self-self measure (distance = 0)
  Matrix[lower.tri(Matrix)] <- NA ## dist i-j = dist j-i
  ## store solution
  LvList[[TRY]] <- Matrix         
  ## summarize each solution using three metrics:
  ## (i) the average pair distance (higher is better)
  ## (ii) the number of 'close' code pairs (those with the minimum distance of 1 - lower is better)
  ## (iii) the maximum number of 'close' code *pairs across all codes (lower is better)
  Summary <- rbind(Summary, data.frame(Mean_Distance          = mean(Matrix, na.rm=T),
                                       N_close_pairs         = sum(Matrix[!is.na(Matrix)]==1),
                                       N_close_pairs_per_ant = max(rowSums( Matrix==1, na.rm=T)) ))
}


## ***Find the solution with the fewest pairs wiRth the lowest distance***

Summary$Mean_Distance_Rank          <- rank(Summary$Mean_Distance)
Summary$N_close_pairs_Rank         <- rank(-Summary$N_close_pairs)
Summary$N_close_pairs_per_ant_Rank <- rank(-Summary$N_close_pairs_per_ant)
Summary$Rank_Total <- Summary$Mean_Distance_Rank + Summary$N_close_pairs_Rank + Summary$N_close_pairs_per_ant_Rank

solution <- rownames( LvList[[which.max(Summary$Rank_Total)]] )

## Highlight candidate solutions
Colour <- rep(rgb(0,0,0,0.1,1),nrow(Summary) )
Colour [which.max(Summary$Rank_Total) ] <- "red"
pairs(Summary[,c("Mean_Distance","N_close_pairs","N_close_pairs_per_ant")], col=Colour, bg=Colour, pch=21, cex=1.4) 


## format into a table
SOLUTION <- data.frame(Code=1:COLONY_SIZE, t(as.data.frame(sapply(solution, strsplit, "")))) 
colnames(SOLUTION)[2:5] <-  c("Head","Thorax","L_gaster","R_gaster")
0 голосов
/ 20 мая 2018

Вот лучший подход, который не опирается на слепую выборку, а вместо этого представляет сходство между каждой парой кодов как ребром в сети, а затем использует функцию igraph large_ivs для поиска самых разнородных пар кодов: 

rm(list=ls())

library(gtools)
library(igraph)

##
outputfolder <- "XXXXXXXXXX"
dir.create(outputfolder,showWarnings = F)
setwd(outputfolder)

## Available colours
x <- c("W", "R", "G", "B", "P", "Y")

## Generate all possible colour combinations, for 6 colours & 4 positions
body <- data.frame(permutations(n=6,r=4,v=x,repeats.allowed=T), stringsAsFactors = F) ; colnames(body) <- c("Head","Thorax","L_gaster","R_gaster")
write.table(body,file="Paint_marks_full_list.txt",col.names=T,row.names=F,quote=F,append=F)

## Generate edge list
edge_list <- data.frame(comb_1=character(),comb_2=character(),similarity=character())
if (!file.exists("Edge_list.txt")){
  write.table(edge_list,file="Edge_list.txt",col.names=T,row.names=F,quote=F,append=F)
}else{
  edge_list <- read.table("Edge_list.txt",header=T,stringsAsFactors = F)
}
if (nrow(edge_list)>0){
  last_i <- edge_list[nrow(edge_list),"comb_1"]
  last_j <- edge_list[nrow(edge_list),"comb_2"]
}

if (!(last_i==(nrow(body)-1)&last_j==nrow(body))){
  for (i in last_i:(nrow(body)-1)){
    print(paste("Combination",i))
    for (j in (i+1):nrow(body)){
      if (i>last_i|j>last_j){
        simil <- length(which(body[i,]==body[j,]))
        if (simil>0){
          write.table(data.frame(comb_1=i,comb_2=j,similarity=simil),file="Edge_list.txt",col.names=F,row.names=F,quote=F,append=T)
        }

      }
    }
  }

}

######let's make 3 graphs with edges representing overlap between combinations ###
##First graph, in which ANY overlap between two combinations is seen as an edge. Will be used to produce list of paint combination with no overlap
net1 <- graph.data.frame(edge_list[c("comb_1","comb_2")],directed=F)

##Second graph, in which only overlaps of 2 or more spots is seen as an edge. Will be used to produce list of paint combinations with no more than 1 spot in common
net2 <- graph.data.frame(edge_list[which(edge_list$similarity>=2),c("comb_1","comb_2")],directed=F)

##Third graph, in which only overlaps of 3 or more spots is seen as an edge. Will be used to produce list of paint combinations with no more than 2 spots in common
net3 <- graph.data.frame(edge_list[which(edge_list$similarity>=3),c("comb_1","comb_2")],directed=F)


#######Now let's use the ivs function to get independent vertex sets, i.e., set of vertices with no connections between any of them
no_overlap_list <- largest_ivs(net1)
max_one_spot_overlap_list <- largest_ivs(net2)
max_two_spots_overlap_list <- largest_ivs(net3)
0 голосов
/ 17 мая 2018

Я не могу окончательно ответить на ваш вопрос, но у меня есть идея, которая может вам помочь.

Построить строковые коды с первой буквой каждого цвета: 

library(gtools)
x     <- c("w", "r", "g", "b", "p", "y")
Perms <- permutations(n=6,r=4,v=x,repeats.allowed=T)
m <- apply(Perms, 1, paste, collapse = "")

> head(m)
[1] "bbbb" "bbbg" "bbbp" "bbbr" "bbbw" "bbby"

Образец n Коды: 

set.seed(1)
n <- 50
y <- sample(m, n)

Создать n * n матрицу из Левенштейновых расстояний : 

library(vwr)
lvmat <- sapply(y, function(x) levenshtein.distance(x, y))

> lvmat[1:5, 1:5]
     grrp pgpg rprr yprw gggp
grrp    0    4    3    3    2
pgpg    4    0    4    4    3
rprr    3    4    0    2    4
yprw    3    4    2    0    4
gggp    2    3    4    4    0

Теперь вы можете максимизировать sum(lvmat), может быть, с помощью начальной загрузки или того, что плавает на вашей лодке, чтобы получить образец большинства разнородных комбинаций.

...