generate.pattern.codes <- function(nmb.pattern.codes, nmb.params, nmb.seuils)
{
pattern.codes <- list()
for (i in 1:nmb.pattern.codes)
{
tmp.code <- c()
while(length(tmp.code)==0 || list(tmp.code) %in% pattern.codes)
{
tmp.code <- sapply(1:nmb.params, function(i)
{
return(sample(1:nmb.seuils, 1))
})
}
pattern.codes[[i]] <- tmp.code
}
return(pattern.codes)
}
generate.position.from.pattern <- function(pattern.code, lower.value, upper.value, nmb.pos=2)
{
l <- length(pattern.code)
range.unit <- (upper.value - lower.value)/nmb.pos
m.list <- sapply(1:l, function(i)
{
pop.mean <- pattern.code[i]
pop.mean <- runif(1, (pop.mean-2/3)*range.unit, (pop.mean-1/2)*range.unit)
return(pop.mean)
})
sd.list <- sapply(1:l, function(i)
{
return(range.unit/l/3)
})
return(list(m.list,sd.list))
}
generate.pop.from.position <- function(pop.m.list, pop.sd.list, nmb.events,
lower.value, upper.value, limited=T)
{
new.pop <- matrix(nrow = nmb.events, ncol = length(pop.m.list))
l <- length(pop.m.list)
range.unit <- (upper.value - lower.value)/l
for(i in 1:l)
{
new.pop[,i] <- rtruncnorm(nmb.events, lower.value, upper.value, pop.m.list[[i]], pop.sd.list[[i]])
}
return(new.pop)
}
extract.position.from.pop <- function(pop, unused.columns = NULL) #POP : matrice, row = events, col = params
{
col.list <- 1:ncol(pop)
if(!is.null(unused.columns))
{
col.list <- col.list[-unused.columns]
}
m.list <- sapply(1:length(col.list), function(i)
{
return(trunc(mean(pop[,col.list[[i]]])*1000)/1000)
})
sd.list <- sapply(1:length(col.list), function(i)
{
val <- trunc(sd(pop[,col.list[[i]]])*1000)/1000
if(is.na(val))
{
val <- 0
}
return(val)
})
return(list(m.list, sd.list))
}
move.population <- function(pop, new.m.list, new.sd.list, m.ranges = list(0.1), sd.ranges = list(0.1), limited = T,
max.val = 4.5, min.val = -0.5, unused.columns = NULL)
{
col.list <- 1:ncol(pop)
if(!is.null(unused.columns))
{
col.list <- col.list[-unused.columns]
}
for(i in 1:length(col.list))
{
me <- 0
sd <- 0
id <- col.list[[i]]
##NEW M--------------------------------------------------------------------------------
if(length(m.ranges) == length(new.m.list))
{
me <- new.m.list[[i]] + runif(1, -m.ranges[[i]], m.ranges[[i]])
}
else
{
me <- new.m.list[[i]] + runif(1, -m.ranges[[1]], m.ranges[[1]])
}
##NEW SD-------------------------------------------------------------------------------
if(length(sd.ranges) == length(new.sd.list))
{
sd <- abs(new.sd.list[[i]] + runif(1, -sd.ranges[[i]], sd.ranges[[i]]))
}
else
{
sd <- abs(new.sd.list[[i]] + runif(1, -sd.ranges[[1]], sd.ranges[[1]]))
}
if(nrow(pop)==1)
{
sd <- 0
}
##RANDOMIZE POP------------------------------------------------------------------------
pop[,id] <- rtruncnorm(nrow(pop), min.val, max.val, me, sd)
}
return(pop)
}
reduce.population <- function(events, red.size) #red.size = % to remove
{
events.to.remove <- sample(events, as.integer(red.size/100*length(events)))
return(events.to.remove)
}
create.pop.from.pop <- function(pop, inc.size, unused.columns = NULL, limited = T, max.val = 4.5, min.val = -0.5) #inc.size = % to add
{
col.list <- 1:ncol(pop)
if(!is.null(unused.columns))
{
col.list <- col.list[-unused.columns]
}
new.pop <- matrix(nrow = as.integer(inc.size/100*nrow(pop)), ncol = ncol(pop))
pop.pos <- extract.position.from.pop(pop, unused.columns = unused.columns)
for(i in 1:length(col.list))
{
id <- col.list[[i]]
new.pop[,id] <- rtruncnorm(nrow(new.pop), min.val, max.val, pop.pos[[1]][[i]], pop.pos[[2]][[i]])
}
for(i in unused.columns)
{
new.pop[,i] <- pop[1,i]
}
return(new.pop)
}
list.to.matrix <- function(list.to.convert)
{
m <- matrix(nrow=length(list.to.convert), ncol=length(list.to.convert[[1]]))
for(i in 1:nrow(m))
{
for(j in 1:ncol(m))
{
m[i,j] <- list.to.convert[[i]][[j]]
}
}
return(m)
}
generate.pattern.codes.from.positions <- function(m.lists,
param.thresholds = 0.05) #Thresholds : error %
{
pattern.list <- list()
if(length(m.lists)>0)
{
m.matrix <- list.to.matrix(m.lists)
nmb.pop <- nrow(m.matrix)
nmb.params <- ncol(m.matrix)
tmp.pattern.list <- matrix(nrow = nmb.pop, ncol = nmb.params)
for(i in 1:nmb.params) #parcourt les parametres
{
values.order <- order(as.numeric(m.matrix[,i]))
sorted.values <- matrix(ncol=2, nrow=nmb.pop)
sorted.values[,1] <- sort(as.numeric(m.matrix[,i]))
for(j in 1:nmb.pop)
{
val <- 1
if(j>1)
{
val <- sorted.values[j-1,2]
if(abs(sorted.values[j,1]/sorted.values[j-1,1]-1) > param.thresholds)
{
val <- val+1
}
}
sorted.values[j,2] <- val
}
tmp.pattern.list[as.numeric(unlist(values.order)),i] <- sorted.values[,2]
}
pattern.list <- lapply(1:nrow(tmp.pattern.list), function(i)
{
return(as.vector(as.numeric(tmp.pattern.list[i,])))
})
}
return(pattern.list)
}
generate.fcs <- function(nmb.events, nmb.dim, nmb.populations, nmb.rare.populations, rare.pop.freq,
min.freq.list, max.freq.list, min.val=-0.5, max.val=4.5)
{
fcs <- NULL
if(rare.pop.freq<100)
{
if(sum(min.freq.list)<=100 && sum(max.freq.list)>=100)
{
pop.frequencies <- min.freq.list
freq.rep.order <- rev(order(max.freq.list-pop.frequencies))
nmb.free.pop <- nmb.populations
#==POP FREQUENCIES GENERATED HERE
while((100-sum(pop.frequencies))>1/1000000)
{
remaining.percentage <- trunc(1000000*(100-sum(pop.frequencies)))/1000000
diff.freq <- max.freq.list-pop.frequencies
for(i in 1:nmb.populations)
{
if(pop.frequencies[freq.rep.order[i]] < max.freq.list[[freq.rep.order[i]]] &&
remaining.percentage>0)
{
attributed.percentage <- min(remaining.percentage/nmb.free.pop,
diff.freq[freq.rep.order[i]])
pop.frequencies[freq.rep.order[i]] <- pop.frequencies[freq.rep.order[i]] +
attributed.percentage
remaining.percentage <- remaining.percentage - attributed.percentage
diff.freq <- max.freq.list-pop.frequencies
}
}
}
#==
pop.patterns.list <- generate.pattern.codes(nmb.populations, nmb.dim, 2)
pop.position.list <- lapply(1:nmb.populations, function(i)
{
return(generate.position.from.pattern(pop.patterns.list[[i]], min.val, max.val, 2))
})
file.mat <- NULL
event.id <- 0
for(current.pop in 1:nmb.populations)
{
pop.events <- max(1,as.integer(pop.frequencies[current.pop]*nmb.events/100))
event.id <- event.id+pop.events
if(event.id<nmb.events && current.pop==nmb.populations)
{
pop.events <- pop.events+(nmb.events-event.id)
}
pop.mat <- generate.pop.from.position(pop.position.list[[current.pop]][[1]],
pop.position.list[[current.pop]][[2]],
pop.events,lower.value = min.val, upper.value = max.val)
pop.mat <- cbind(pop.mat, 0)
pop.mat <- cbind(pop.mat, current.pop)
if(is.null(file.mat))
{
file.mat <- pop.mat
}
else
{
file.mat <- rbind(file.mat, pop.mat)
}
}
colnames(file.mat) <- c(rep("NA",times = nmb.dim),"time","Population")
for (current_dim in 1:nmb.dim)
{
colnames(file.mat)[current_dim] <- paste("PARAM_",current_dim, sep="")
}
fcs <- flowFrame(file.mat)
descR <- description(fcs)
lapply(c(1:dim(file.mat)[2]),function(x)
{
descR[[paste0("$P",x,"R")]] <<- 262144
})
nmb.grp <- min(nmb.events,1000)
descR[["TIMESTEP"]] <- 1/nmb.grp
for(e in 1:nmb.events)
{
file.mat[e,nmb.dim+1] <- descR[["TIMESTEP"]] * as.integer(e / (nmb.events/nmb.grp))
}
fcs <- flowFrame(file.mat, description = descR)
}
}
return(fcs)
}
create.pop.table.from.fcs.matrix <- function(fcs.mat, populations.list, used.markers, cluster.column, pop.max=200)
{
tmp.df <- NULL
tmp.mat <- NULL
if(!is.null(fcs.mat) && length(populations.list) > 0 && length(populations.list) < pop.max && !is.null(cluster.column))
{
pop.ids <- populations.list
col.id <- cluster.column
tmp.mat <- matrix(ncol=length(used.markers), nrow=length(pop.ids))
colnames(tmp.mat) <- c(colnames(fcs.mat)[used.markers])
lapply(1:length(pop.ids), function(j)
{
if(length(pop.ids[[j]])>0)
{
curr.pop.id <- unique(fcs.mat[pop.ids[[j]],col.id])
curr.pop <- fcs.mat[fcs.mat[,col.id]==curr.pop.id, used.markers]
if(length(pop.ids[[j]])==1)
{
curr.pop <- t(fcs.mat[fcs.mat[,col.id]==curr.pop.id, used.markers])
}
tmp.val <- extract.position.from.pop(curr.pop)
tmp.mat[j,] <<- as.numeric(unlist(unlist(tmp.val[[1]])))
}
})
rownames(tmp.mat) <- names(populations.list)
tmp.df <- expand.grid(Populations=names(pop.ids), Markers=colnames(fcs.mat)[used.markers])
tmp.df$value <- as.numeric(unlist(as.list(tmp.mat)))
}
return(list(tmp.df, tmp.mat))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.