max/ourMELONS
1
0
Fork 0
Code Issues 1 Pull requests Projects Releases Packages Wiki Activity Actions

Renamed global environment, fixed assignments (#24)

Browse source
This commit is contained in:
Waldir Leoncio 2024-04-10 16:04:07 +02:00
parent ec959fcfb2
commit 99f28ba215
22 changed files with 154 additions and 130 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
R/addToSummary.R
View file

@ -7,7 +7,7 @@ addToSummary <- function(logml, partitionSummary, worstIndex) {
apu <- matlab2r::find(abs(partitionSummary[, 2] - logml) < 1e-5) apu <- matlab2r::find(abs(partitionSummary[, 2] - logml) < 1e-5)
if (isempty(apu)) { if (isempty(apu)) {
# Nyt l<>ydetty partitio ei ole viel<65> kirjattuna summaryyn. # Nyt l<>ydetty partitio ei ole viel<65> kirjattuna summaryyn.
npops <- length(unique(PARTITION)) npops <- length(unique(globals$PARTITION))
partitionSummary[worstIndex, 1] <- npops partitionSummary[worstIndex, 1] <- npops
partitionSummary[worstIndex, 2] <- logml partitionSummary[worstIndex, 2] <- logml
added <- 1 added <- 1

6
R/checkLogml.R
View file

@ -5,12 +5,12 @@ checkLogml <- function(priorTerm, adjprior, cliques, separators) {
# global SEPCOUNTS # global SEPCOUNTS
# global PARTITION # global PARTITION
npops <- length(unique(PARTITION)) npops <- length(unique(globals$PARTITION))
cliqcounts <- computeCounts(cliques, separators, npops)$cliqcounts cliqcounts <- computeCounts(cliques, separators, npops)$cliqcounts
sepcounts <- computeCounts(cliques, separators, npops)$sepcounts sepcounts <- computeCounts(cliques, separators, npops)$sepcounts
CLIQCOUNTS <- cliqcounts globals$CLIQCOUNTS <- cliqcounts
SEPCOUNTS <- sepcounts globals$SEPCOUNTS <- sepcounts
logml <- computeLogml(adjprior, priorTerm)$logml logml <- computeLogml(adjprior, priorTerm)$logml
spatialPrior <- computeLogml(adjprior, priorTerm)$spatialPrior spatialPrior <- computeLogml(adjprior, priorTerm)$spatialPrior

16
R/computeAllFreqs2.R
View file

@ -3,12 +3,12 @@
#' j 1/noalle(j) verran. #' j 1/noalle(j) verran.
#' @param noalle noalle #' @param noalle noalle
computeAllFreqs2 <- function(noalle) { computeAllFreqs2 <- function(noalle) {
COUNTS <- ifelse(isGlobalEmpty(COUNTS), vector(), COUNTS) globals$COUNTS <- ifelse(isGlobalEmpty(globals$COUNTS), vector(), globals$COUNTS)
SUMCOUNTS <- ifelse(isGlobalEmpty(SUMCOUNTS), vector(), COUNTS) globals$COUNTS <- ifelse(isGlobalEmpty(globals$COUNTS), vector(), globals$COUNTS)
max_noalle <- size(COUNTS, 1) max_noalle <- size(globals$COUNTS, 1)
nloci <- size(COUNTS, 2) nloci <- size(globals$COUNTS, 2)
npops <- size(COUNTS, 3) npops <- size(globals$COUNTS, 3)
sumCounts <- SUMCOUNTS + ones(size(SUMCOUNTS)) sumCounts <- globals$COUNTS + ones(size(globals$COUNTS))
sumCounts <- reshape(t(sumCounts), c(1, nloci, npops)) sumCounts <- reshape(t(sumCounts), c(1, nloci, npops))
sumCounts <- repmat(sumCounts, c(max_noalle, 1, 1)) sumCounts <- repmat(sumCounts, c(max_noalle, 1, 1))
@ -20,9 +20,9 @@ computeAllFreqs2 <- function(noalle) {
} }
prioriAlleelit <- repmat(prioriAlleelit, c(1, 1, npops)) prioriAlleelit <- repmat(prioriAlleelit, c(1, 1, npops))
counts <- ifelse( counts <- ifelse(
test = isGlobalEmpty(COUNTS), test = isGlobalEmpty(globals$COUNTS),
yes = prioriAlleelit, yes = prioriAlleelit,
no = COUNTS + prioriAlleelit no = globals$COUNTS + prioriAlleelit
) )
allFreqs <- counts / drop(sumCounts) allFreqs <- counts / drop(sumCounts)
return(allFreqs) return(allFreqs)

6
R/computeLogml.R
View file

@ -14,14 +14,14 @@ computeLogml <- function(counts, sumcounts, noalle, data, rowsFromInd) {
logml <- sum( logml <- sum(
sum( sum(
sum( sum(
GAMMA_LN[ globals$GAMMA_LN[
counts + 1 + counts + 1 +
repmat(rowsInG * (adjnoalle - 1), c(1, 1, npops)) repmat(rowsInG * (adjnoalle - 1), c(1, 1, npops))
] ]
) )
) )
) - ) -
npops * sum(sum(GAMMA_LN[1, adjnoalle])) - npops * sum(sum(globals$GAMMA_LN[1, adjnoalle])) -
sum(sum(GAMMA_LN[sumcounts + 1, 1])) sum(sum(globals$GAMMA_LN[sumcounts + 1, 1]))
return(logml) return(logml)
} }

6
R/computePersonalAllFreqs.R
View file

@ -8,11 +8,11 @@
#' @param allFreqs allFreqs #' @param allFreqs allFreqs
#' @param rowsFromInd rowsFromInd #' @param rowsFromInd rowsFromInd
computePersonalAllFreqs <- function(ind, data, allFreqs, rowsFromInd) { computePersonalAllFreqs <- function(ind, data, allFreqs, rowsFromInd) {
if (isGlobalEmpty(COUNTS)) { if (isGlobalEmpty(globals$COUNTS)) {
nloci <- npops <- 1 nloci <- npops <- 1
} else { } else {
nloci <- ifelse(is.na(dim(COUNTS)[2]), 1, dim(COUNTS)[2]) nloci <- ifelse(is.na(dim(globals$COUNTS)[2]), 1, dim(globals$COUNTS)[2])
npops <- ifelse(is.na(dim(COUNTS)[3]), 1, dim(COUNTS)[3]) npops <- ifelse(is.na(dim(globals$COUNTS)[3]), 1, dim(globals$COUNTS)[3])
} }
rows <- as.matrix(t(data))[computeRows(rowsFromInd, ind, 1), , drop = FALSE] rows <- as.matrix(t(data))[computeRows(rowsFromInd, ind, 1), , drop = FALSE]

8
R/computePopulationLogml.R
View file

@ -4,16 +4,16 @@ computePopulationLogml <- function(pops, adjprior, priorTerm) {
nr <- seq_len(nrow(adjprior)) nr <- seq_len(nrow(adjprior))
nc <- seq_len(ncol(adjprior)) nc <- seq_len(ncol(adjprior))
x <- size(baps.globals$COUNTS, 1) x <- size(globals$COUNTS, 1)
y <- size(baps.globals$COUNTS, 2) y <- size(globals$COUNTS, 2)
z <- length(pops) z <- length(pops)
# ======================================================== # # ======================================================== #
# Computation # # Computation #
# ======================================================== # # ======================================================== #
rep_adj <- repmat(adjprior, c(1, 1, z)) rep_adj <- repmat(adjprior, c(1, 1, z))
gamma_rep_counts <- matlab2r::gammaln(rep_adj + baps.globals$COUNTS[, , pops]) gamma_rep_counts <- matlab2r::gammaln(rep_adj + globals$COUNTS[, , pops])
gamma_sum_counts <- rowSums(matlab2r::gammaln(1 + baps.globals$SUMCOUNTS[pops, , drop = FALSE])) gamma_sum_counts <- rowSums(matlab2r::gammaln(1 + globals$SUMCOUNTS[pops, , drop = FALSE]))
gamma_rep_counts_sum <- colSums(colSums(reshape(gamma_rep_counts, c(x, y, z)))) gamma_rep_counts_sum <- colSums(colSums(reshape(gamma_rep_counts, c(x, y, z))))
gamma_rep_counts_reshaped <- squeeze(gamma_rep_counts_sum) gamma_rep_counts_reshaped <- squeeze(gamma_rep_counts_sum)
popLogml <- gamma_rep_counts_reshaped - gamma_sum_counts - priorTerm popLogml <- gamma_rep_counts_reshaped - gamma_sum_counts - priorTerm

2
R/fiksaaPartitioYksiloTasolle.R
View file

@ -10,7 +10,7 @@ fiksaaPartitioYksiloTasolle <- function(rows, rowsFromInd) {
kaikkiRivit <- rows[ind, 1]:rows[ind, 2] kaikkiRivit <- rows[ind, 1]:rows[ind, 2]
for (riviNumero in seq(rowsFromInd, length(kaikkiRivit), rowsFromInd)) { for (riviNumero in seq(rowsFromInd, length(kaikkiRivit), rowsFromInd)) {
rivi <- kaikkiRivit[riviNumero] rivi <- kaikkiRivit[riviNumero]
partitio2[rivi / rowsFromInd] <- PARTITION[ind] partitio2[rivi / rowsFromInd] <- globals$PARTITION[ind]
} }
} }
global_env <- as.environment(1L) global_env <- as.environment(1L)

2
R/findEmptyPop.R
View file

@ -1,7 +1,7 @@
findEmptyPop <- function(npops) { findEmptyPop <- function(npops) {
# % Palauttaa ensimm<6D>isen tyhj<68>n populaation indeksin. Jos tyhji<6A> # % Palauttaa ensimm<6D>isen tyhj<68>n populaation indeksin. Jos tyhji<6A>
# % populaatioita ei ole, palauttaa -1:n. # % populaatioita ei ole, palauttaa -1:n.
pops <- t(unique(PARTITION)) pops <- t(unique(globals$PARTITION))
if (length(pops) == npops) { if (length(pops) == npops) {
emptyPop <- -1 emptyPop <- -1
} else { } else {

12
R/getPopDistancesByKL.R
View file

@ -1,10 +1,10 @@
getPopDistancesByKL <- function(adjprior) { getPopDistancesByKL <- function(adjprior) {
# Laskee populaatioille etהisyydet # Laskee populaatioille etהisyydet
# kהyttהen KL-divergenssi? # kהyttהen KL-divergenssi?
COUNTS <- COUNTS[seq_len(nrow(adjprior)), seq_len(ncol(adjprior)), ] globals$COUNTS <- globals$COUNTS[seq_len(nrow(adjprior)), seq_len(ncol(adjprior)), ]
maxnoalle <- size(COUNTS, 1) maxnoalle <- size(globals$COUNTS, 1)
nloci <- size(COUNTS, 2) nloci <- size(globals$COUNTS, 2)
npops <- size(COUNTS, 3) npops <- size(globals$COUNTS, 3)
distances <- zeros(choose(npops, 2), 1) distances <- zeros(choose(npops, 2), 1)
d <- zeros(maxnoalle, nloci, npops) d <- zeros(maxnoalle, nloci, npops)
@ -16,8 +16,8 @@ getPopDistancesByKL <- function(adjprior) {
prior[1, nollia] <- 1 prior[1, nollia] <- 1
for (pop1 in 1:npops) { for (pop1 in 1:npops) {
d[, , pop1] <- (squeeze(COUNTS[, , pop1]) + prior) / repmat( d[, , pop1] <- (squeeze(globals$COUNTS[, , pop1]) + prior) / repmat(
sum(squeeze(COUNTS[, , pop1]) + prior), c(maxnoalle, ncol(prior)) sum(squeeze(globals$COUNTS[, , pop1]) + prior), c(maxnoalle, ncol(prior))
) )
} }
pointer <- 1 pointer <- 1

15
R/globals.R
View file

@ -1,10 +1,13 @@
baps.globals <- new.env(parent = emptyenv()) globals <- new.env(parent = emptyenv())
assign("COUNTS", array(0, dim = c(0, 0, 0)), envir = baps.globals) assign("COUNTS", array(0, dim = c(0, 0, 0)), envir = globals)
assign("SUMCOUNTS", array(0, dim = c(0, 0)), envir = baps.globals) assign("SUMCOUNTS", array(0, dim = c(0, 0)), envir = globals)
assign("PARTITION", array(1, dim = 0), envir = baps.globals) assign("PARTITION", array(1, dim = 0), envir = globals)
assign("POP_LOGML", array(1, dim = 0), envir = baps.globals) assign("POP_LOGML", array(1, dim = 0), envir = globals)
assign("LOGDIFF", array(1, dim = c(0, 0)), envir = baps.globals) assign("LOGDIFF", array(1, dim = c(0, 0)), envir = globals)
assign("CLOQCOUNTS", array(0, dim = c(0, 0)), envir = globals)
assign("SEPCOUNTS", array(0, dim = c(0, 0)), envir = globals)
assign("GAMMA_LN", array(0, dim = c(0, 0)), envir = globals)
# If handling globas break, try other ideas from # If handling globas break, try other ideas from
# https://stackoverflow.com/a/65252740/1169233 and # https://stackoverflow.com/a/65252740/1169233 and
# https://stackoverflow.com/questions/12598242/ # https://stackoverflow.com/questions/12598242/

8
R/greedyPopMix.R
View file

@ -89,11 +89,11 @@ greedyPopMix <- function(data, format, partitionCompare = NULL, verbose = TRUE
rows <- popnames_rowsFromInd$rows rows <- popnames_rowsFromInd$rows
rm(popnames_rowsFromInd) rm(popnames_rowsFromInd)
} }
groupPartition <- PARTITION groupPartition <- globals$PARTITION
fiksaaPartitioYksiloTasolle(rows, rowsFromInd) fiksaaPartitioYksiloTasolle(rows, rowsFromInd)
c$PARTITION <- PARTITION c$PARTITION <- globals$PARTITION
c$COUNTS <- COUNTS c$COUNTS <- globals$COUNTS
c$SUMCOUNTS <- SUMCOUNTS c$SUMCOUNTS <- globals$SUMCOUNTS
c$alleleCodes <- alleleCodes c$alleleCodes <- alleleCodes
c$adjprior <- adjprior c$adjprior <- adjprior
c$rowsFromInd <- rowsFromInd c$rowsFromInd <- rowsFromInd

20
R/indMix.R
View file

@ -93,16 +93,16 @@ indMix <- function(c, npops, counts = NULL, sumcounts = NULL, max_iter = 100L, d
counts <- sumcounts_counts_logml$counts counts <- sumcounts_counts_logml$counts
logml <- sumcounts_counts_logml$logml logml <- sumcounts_counts_logml$logml
assign("PARTITION", zeros(ninds, 1), baps.globals) assign("PARTITION", zeros(ninds, 1), globals)
for (i in seq_len(ninds)) { for (i in seq_len(ninds)) {
apu <- rows[i] apu <- rows[i]
baps.globals$PARTITION[i] <- initialPartition[apu[1]] globals$PARTITION[i] <- initialPartition[apu[1]]
} }
assign("COUNTS", counts, baps.globals) assign("COUNTS", counts, globals)
assign("SUMCOUNTS", sumcounts, baps.globals) assign("SUMCOUNTS", sumcounts, globals)
assign("POP_LOGML", computePopulationLogml(seq_len(npops), adjprior, priorTerm), baps.globals) assign("POP_LOGML", computePopulationLogml(seq_len(npops), adjprior, priorTerm), globals)
assign("LOGDIFF", matrix(-Inf, nrow = ninds, ncol = npops), baps.globals) assign("LOGDIFF", matrix(-Inf, nrow = ninds, ncol = npops), globals)
# PARHAAN MIXTURE-PARTITION ETSIMINEN # PARHAAN MIXTURE-PARTITION ETSIMINEN
nRoundTypes <- 7 nRoundTypes <- 7
@ -146,7 +146,7 @@ indMix <- function(c, npops, counts = NULL, sumcounts = NULL, max_iter = 100L, d
muutosNyt <- 0 muutosNyt <- 0
for (ind in inds) { for (ind in inds) {
i1 <- baps.globals$PARTITION[ind] i1 <- globals$PARTITION[ind]
muutokset_diffInCounts <- greedyMix_muutokset$new() muutokset_diffInCounts <- greedyMix_muutokset$new()
muutokset_diffInCounts <- muutokset_diffInCounts$laskeMuutokset( muutokset_diffInCounts <- muutokset_diffInCounts$laskeMuutokset(
ind, rows, data, adjprior, priorTerm, npops ind, rows, data, adjprior, priorTerm, npops
@ -195,7 +195,9 @@ indMix <- function(c, npops, counts = NULL, sumcounts = NULL, max_iter = 100L, d
} else if (round == 2) { # Populaation yhdist<73>minen toiseen. } else if (round == 2) { # Populaation yhdist<73>minen toiseen.
maxMuutos <- 0 maxMuutos <- 0
for (pop in seq_len(npops)) { for (pop in seq_len(npops)) {
muutokset_diffInCounts <- greedyMix_muutokset$new() muutokset_diffInCounts <- greedyMix_muutokset$new
# FIXME: wrong input
browser() # TEMP. Tip: browserText()
muutokset_diffInCounts <- muutokset_diffInCounts$laskeMuutokset2( muutokset_diffInCounts <- muutokset_diffInCounts$laskeMuutokset2(
pop, rows, data, adjprior, priorTerm pop, rows, data, adjprior, priorTerm
) )
@ -277,7 +279,7 @@ indMix <- function(c, npops, counts = NULL, sumcounts = NULL, max_iter = 100L, d
diffInCounts <- computeDiffInCounts( diffInCounts <- computeDiffInCounts(
t(rivit), size(COUNTS, 1), size(COUNTS, 2), data t(rivit), size(COUNTS, 1), size(COUNTS, 2), data
) )
i1 <- PARTITION(muuttuvat[1]) i1 <- PARTITION[muuttuvat[1]]
updateGlobalVariables3( updateGlobalVariables3(
muuttuvat, diffInCounts, adjprior, priorTerm, i2 muuttuvat, diffInCounts, adjprior, priorTerm, i2
) )

2
R/isGlobalEmpty.R
View file

@ -6,5 +6,5 @@
#' @importFrom stats sd #' @importFrom stats sd
#' @author Waldir Leoncio #' @author Waldir Leoncio
isGlobalEmpty <- function(g) { isGlobalEmpty <- function(g) {
return(sum(g) == 0 & sd(g) == 0) return(sum(g) == 0 && is.na(sd(g)))
} }

64
R/laskeMuutokset12345.R
View file

@ -291,10 +291,10 @@ admix1_muutokset <- R6Class(
#' @param omaFreqs own Freqs? #' @param omaFreqs own Freqs?
#' @param logml log maximum likelihood #' @param logml log maximum likelihood
laskeMuutokset4 = function(osuus, osuusTaulu, omaFreqs, logml) { laskeMuutokset4 = function(osuus, osuusTaulu, omaFreqs, logml) {
if (isGlobalEmpty(COUNTS)) { if (isGlobalEmpty(globals$COUNTS)) {
npops <- 1 npops <- 1
} else { } else {
npops <- ifelse(is.na(dim(COUNTS)[3]), 1, dim(COUNTS)[3]) npops <- ifelse(is.na(dim(globals$COUNTS)[3]), 1, dim(globals$COUNTS)[3])
} }
notEmpty <- which(osuusTaulu > 0.005) notEmpty <- which(osuusTaulu > 0.005)
muutokset <- zeros(npops) muutokset <- zeros(npops)
@ -342,10 +342,10 @@ greedyMix_muutokset <- R6Class(
#' @param adjprior adjprior #' @param adjprior adjprior
#' @param priorTerm priorTerm #' @param priorTerm priorTerm
laskeMuutokset = function(ind, globalRows, data, adjprior, priorTerm, npops) { laskeMuutokset = function(ind, globalRows, data, adjprior, priorTerm, npops) {
muutokset <- baps.globals$LOGDIFF[ind, ] muutokset <- globals$LOGDIFF[ind, ]
i1 <- baps.globals$PARTITION[ind] i1 <- globals$PARTITION[ind]
i1_logml <- baps.globals$POP_LOGML[i1] i1_logml <- globals$POP_LOGML[i1]
muutokset[i1] <- 0 muutokset[i1] <- 0
if (is.null(dim(globalRows))) { if (is.null(dim(globalRows))) {
@ -355,29 +355,29 @@ greedyMix_muutokset <- R6Class(
} }
diffInCounts <- computeDiffInCounts( diffInCounts <- computeDiffInCounts(
rows, size(baps.globals$COUNTS, 1), size(baps.globals$COUNTS, 2), data rows, size(globals$COUNTS, 1), size(globals$COUNTS, 2), data
) )
diffInSumCounts <- colSums(diffInCounts) diffInSumCounts <- colSums(diffInCounts)
baps.globals$COUNTS[, , i1] <- baps.globals$COUNTS[, , i1] - diffInCounts globals$COUNTS[, , i1] <- globals$COUNTS[, , i1] - diffInCounts
baps.globals$SUMCOUNTS[i1, ] <- baps.globals$SUMCOUNTS[i1, ] - diffInSumCounts globals$SUMCOUNTS[i1, ] <- globals$SUMCOUNTS[i1, ] - diffInSumCounts
new_i1_logml <- computePopulationLogml(i1, adjprior, priorTerm) new_i1_logml <- computePopulationLogml(i1, adjprior, priorTerm)
baps.globals$COUNTS[, , i1] <- baps.globals$COUNTS[, , i1] + diffInCounts globals$COUNTS[, , i1] <- globals$COUNTS[, , i1] + diffInCounts
baps.globals$SUMCOUNTS[i1, ] <- baps.globals$SUMCOUNTS[i1, ] + diffInSumCounts globals$SUMCOUNTS[i1, ] <- globals$SUMCOUNTS[i1, ] + diffInSumCounts
i2 <- matlab2r::find(muutokset == -Inf) # Etsit<69><74>n populaatiot jotka muuttuneet viime kerran j<>lkeen. (Searching for populations that have changed since the last time) i2 <- matlab2r::find(muutokset == -Inf) # Etsit<69><74>n populaatiot jotka muuttuneet viime kerran j<>lkeen. (Searching for populations that have changed since the last time)
i2 <- setdiff(i2, i1) i2 <- setdiff(i2, i1)
i2_logml <- baps.globals$POP_LOGML[i2] i2_logml <- globals$POP_LOGML[i2]
ni2 <- length(i2) ni2 <- length(i2)
baps.globals$COUNTS[, , i2] <- baps.globals$COUNTS[, , i2] + repmat(diffInCounts, c(1, 1, ni2)) globals$COUNTS[, , i2] <- globals$COUNTS[, , i2] + repmat(diffInCounts, c(1, 1, ni2))
baps.globals$SUMCOUNTS[i2, ] <- baps.globals$SUMCOUNTS[i2, ] + repmat(diffInSumCounts, c(ni2, 1)) globals$SUMCOUNTS[i2, ] <- globals$SUMCOUNTS[i2, ] + repmat(diffInSumCounts, c(ni2, 1))
new_i2_logml <- computePopulationLogml(i2, adjprior, priorTerm) new_i2_logml <- computePopulationLogml(i2, adjprior, priorTerm)
baps.globals$COUNTS[, , i2] <- baps.globals$COUNTS[, , i2] - repmat(diffInCounts, c(1, 1, ni2)) globals$COUNTS[, , i2] <- globals$COUNTS[, , i2] - repmat(diffInCounts, c(1, 1, ni2))
baps.globals$SUMCOUNTS[i2, ] <- baps.globals$SUMCOUNTS[i2, ] - repmat(diffInSumCounts, c(ni2, 1)) globals$SUMCOUNTS[i2, ] <- globals$SUMCOUNTS[i2, ] - repmat(diffInSumCounts, c(ni2, 1))
muutokset[i2] <- new_i1_logml[, ] - i1_logml + new_i2_logml[, ] - i2_logml muutokset[i2] <- new_i1_logml[, ] - i1_logml + new_i2_logml[, ] - i2_logml
baps.globals$LOGDIFF[ind, ] <- muutokset globals$LOGDIFF[ind, ] <- muutokset
return(list(muutokset = muutokset, diffInCounts = diffInCounts)) return(list(muutokset = muutokset, diffInCounts = diffInCounts))
}, },
#' @param i1 i1 #' @param i1 i1
@ -390,45 +390,45 @@ greedyMix_muutokset <- R6Class(
# % muutos logml:ss<73>, mik<69>li korin i1 kaikki yksil<69>t siirret<65><74>n # % muutos logml:ss<73>, mik<69>li korin i1 kaikki yksil<69>t siirret<65><74>n
# % koriin i. # % koriin i.
npops <- size(COUNTS, 3) npops <- size(globals$COUNTS, 3)
muutokset <- zeros(npops, 1) muutokset <- zeros(npops, 1)
i1_logml <- POP_LOGML[i1] i1_logml <- globals$POP_LOGML[i1]
inds <- matlab2r::find(PARTITION == i1) inds <- matlab2r::find(globals$PARTITION == i1)
ninds <- length(inds) ninds <- length(inds)
if (ninds == 0) { if (ninds == 0) {
diffInCounts <- zeros(size(COUNTS, 1), size(COUNTS, 2)) diffInCounts <- zeros(size(globals$COUNTS, 1), size(globals$COUNTS, 2))
return() return()
} }
rows <- list() rows <- list()
for (i in 1:ninds) { for (i in 1:ninds) {
ind <- inds(i) ind <- inds[i]
lisa <- globalRows(ind, 1):globalRows(ind, 2) lisa <- globalRows[ind, 1]:globalRows[ind, 2]
rows <- c(rows, t(lisa)) rows <- c(rows, t(lisa))
} }
diffInCounts <- computeDiffInCounts( diffInCounts <- computeDiffInCounts(
t(rows), size(COUNTS, 1), size(COUNTS, 2), data t(rows), size(globals$COUNTS, 1), size(globals$COUNTS, 2), data
) )
diffInSumCounts <- sum(diffInCounts) diffInSumCounts <- sum(diffInCounts)
COUNTS[, , i1] <- COUNTS[, , i1] - diffInCounts globals$COUNTS[, , i1] <- globals$COUNTS[, , i1] - diffInCounts
SUMCOUNTS[i1, ] <- SUMCOUNTS[i1, ] - diffInSumCounts globals$SUMCOUNTS[i1, ] <- globals$SUMCOUNTS[i1, ] - diffInSumCounts
new_i1_logml <- computePopulationLogml(i1, adjprior, priorTerm) new_i1_logml <- computePopulationLogml(i1, adjprior, priorTerm)
COUNTS[, , i1] <- COUNTS[, , i1] + diffInCounts globals$COUNTS[, , i1] <- globals$COUNTS[, , i1] + diffInCounts
SUMCOUNTS[i1, ] <- SUMCOUNTS[i1, ] + diffInSumCounts globals$SUMCOUNTS[i1, ] <- globals$SUMCOUNTS[i1, ] + diffInSumCounts
i2 <- c(1:i1 - 1, i1 + 1:npops) i2 <- c(1:i1 - 1, i1 + 1:npops)
i2_logml <- POP_LOGML[i2] i2_logml <- globals$POP_LOGML[i2]
COUNTS[, , i2] <- COUNTS[, , i2] + repmat(diffInCounts, c(1, 1, npops - 1)) globals$COUNTS[, , i2] <- globals$COUNTS[, , i2] + repmat(diffInCounts, c(1, 1, npops - 1))
SUMCOUNTS[i2, ] <- SUMCOUNTS[i2, ] + repmat(diffInSumCounts, c(npops - 1, 1)) globals$SUMCOUNTS[i2, ] <- globals$SUMCOUNTS[i2, ] + repmat(diffInSumCounts, c(npops - 1, 1))
new_i2_logml <- computePopulationLogml(i2, adjprior, priorTerm) new_i2_logml <- computePopulationLogml(i2, adjprior, priorTerm)
COUNTS[, , i2] <- COUNTS[, , i2] - repmat(diffInCounts, c(1, 1, npops - 1)) globals$COUNTS[, , i2] <- globals$COUNTS[, , i2] - repmat(diffInCounts, c(1, 1, npops - 1))
SUMCOUNTS[i2, ] <- SUMCOUNTS[i2, ] - repmat(diffInSumCounts, c(npops - 1, 1)) globals$SUMCOUNTS[i2, ] <- globals$SUMCOUNTS[i2, ] - repmat(diffInSumCounts, c(npops - 1, 1))
muutokset[i2] <- new_i1_logml - i1_logml + new_i2_logml - i2_logml muutokset[i2] <- new_i1_logml - i1_logml + new_i2_logml - i2_logml
return(list(muutokset = muutokset, diffInCounts = diffInCounts)) return(list(muutokset = muutokset, diffInCounts = diffInCounts))

14
R/poistaLiianPienet.R
View file

@ -9,7 +9,7 @@ poistaLiianPienet <- function(npops, rowsFromInd, alaraja) {
popSize <- zeros(1, npops) popSize <- zeros(1, npops)
if (npops > 0) { if (npops > 0) {
for (i in 1:npops) { for (i in 1:npops) {
popSize[i] <- length(which(PARTITION == i)) popSize[i] <- length(which(globals$PARTITION == i))
} }
} }
miniPops <- which(popSize < alaraja) miniPops <- which(popSize < alaraja)
@ -20,19 +20,19 @@ poistaLiianPienet <- function(npops, rowsFromInd, alaraja) {
outliers <- matrix(NA, 0, 0) outliers <- matrix(NA, 0, 0)
for (pop in miniPops) { for (pop in miniPops) {
inds <- which(PARTITION == pop) inds <- which(globals$PARTITION == pop)
cat("Removed individuals: ") cat("Removed individuals: ")
cat(as.character(inds)) cat(as.character(inds))
outliers <- matrix(c(outliers, inds), ncol = 1) outliers <- matrix(c(outliers, inds), ncol = 1)
} }
ninds <- length(PARTITION) ninds <- length(globals$PARTITION)
PARTITION[outliers] <- 0 globals$PARTITION[outliers] <- 0
korit <- unique(PARTITION(which(PARTITION > 0))) korit <- unique(globals$PARTITION(which(globals$PARTITION > 0)))
for (n in 1:length(korit)) { for (n in 1:length(korit)) {
kori <- korit[n] kori <- korit[n]
yksilot <- which(PARTITION == kori) yksilot <- which(globals$PARTITION == kori)
PARTITION[yksilot] == n globals$PARTITION[yksilot] == n
} }
# TODO: add COUNTS, SUMCOUNTS and PARTITION to return or use <- # TODO: add COUNTS, SUMCOUNTS and PARTITION to return or use <-

12
R/simulateAllFreqs.R
View file

@ -3,14 +3,14 @@
#' Add each allele to each locus in each population by j 1 / noalle(j). The Dirichlet distributions corresponding to the counts thus obtained simulate values for the allele frequencies of the populations. #' Add each allele to each locus in each population by j 1 / noalle(j). The Dirichlet distributions corresponding to the counts thus obtained simulate values for the allele frequencies of the populations.
#' @param noalle noalle #' @param noalle noalle
simulateAllFreqs <- function(noalle) { simulateAllFreqs <- function(noalle) {
if (isGlobalEmpty(COUNTS)) { if (isGlobalEmpty(globals$COUNTS)) {
max_noalle <- 0 max_noalle <- 0
nloci <- 0 nloci <- 0
npops <- 1 npops <- 1
} else { } else {
max_noalle <- size(COUNTS, 1) max_noalle <- size(globals$COUNTS, 1)
nloci <- size(COUNTS, 2) nloci <- size(globals$COUNTS, 2)
npops <- size(COUNTS, 3) npops <- size(globals$COUNTS, 3)
} }
prioriAlleelit <- zeros(max_noalle, nloci) prioriAlleelit <- zeros(max_noalle, nloci)
@ -21,9 +21,9 @@ simulateAllFreqs <- function(noalle) {
} }
prioriAlleelit <- repmat(prioriAlleelit, matrix(c(1, 1, npops), 1)) prioriAlleelit <- repmat(prioriAlleelit, matrix(c(1, 1, npops), 1))
counts <- ifelse( counts <- ifelse(
test = isGlobalEmpty(COUNTS), test = isGlobalEmpty(globals$COUNTS),
yes = prioriAlleelit, yes = prioriAlleelit,
no = COUNTS + prioriAlleelit no = globals$COUNTS + prioriAlleelit
) )
allfreqs <- zeros(size(counts)) allfreqs <- zeros(size(counts))

4
R/suoritaMuutos.R
View file

@ -4,10 +4,10 @@
#' @param osuus percentage? #' @param osuus percentage?
#' @param indeksi index #' @param indeksi index
suoritaMuutos <- function(osuusTaulu, osuus, indeksi) { suoritaMuutos <- function(osuusTaulu, osuus, indeksi) {
if (isGlobalEmpty(COUNTS)) { if (isGlobalEmpty(globals$COUNTS)) {
npops <- 1 npops <- 1
} else { } else {
npops <- ifelse(is.na(dim(COUNTS)[3]), 1, dim(COUNTS)[3]) npops <- ifelse(is.na(dim(globals$COUNTS)[3]), 1, dim(globals$COUNTS)[3])
} }
i1 <- indeksi %% npops i1 <- indeksi %% npops

20
R/updateGlobalVariables.R
View file

@ -1,21 +1,21 @@
updateGlobalVariables <- function(ind, i2, diffInCounts, adjprior, priorTerm) { updateGlobalVariables <- function(ind, i2, diffInCounts, adjprior, priorTerm) {
# % Suorittaa globaalien muuttujien muutokset, kun yksil<69> ind # % Suorittaa globaalien muuttujien muutokset, kun yksil<69> ind
# % on siirret<65><74>n koriin i2. # % on siirret<65><74>n koriin i2.
i1 <- PARTITION[ind] i1 <- globals$PARTITION[ind]
PARTITION[ind] <- i2 globals$PARTITION[ind] <- i2
COUNTS[, , i1] <- COUNTS[, , i1] - diffInCounts globals$COUNTS[, , i1] <- globals$COUNTS[, , i1] - diffInCounts
COUNTS[, , i2] <- COUNTS[, , i2] + diffInCounts globals$COUNTS[, , i2] <- globals$COUNTS[, , i2] + diffInCounts
SUMCOUNTS[i1, ] <- SUMCOUNTS[i1, ] - colSums(diffInCounts) globals$SUMCOUNTS[i1, ] <- globals$SUMCOUNTS[i1, ] - colSums(diffInCounts)
SUMCOUNTS[i2, ] <- SUMCOUNTS[i2, ] + colSums(diffInCounts) globals$SUMCOUNTS[i2, ] <- globals$SUMCOUNTS[i2, ] + colSums(diffInCounts)
POP_LOGML[c(i1, i2)] <- computePopulationLogml( globals$POP_LOGML[c(i1, i2)] <- computePopulationLogml(
c(i1, i2), adjprior, priorTerm c(i1, i2), adjprior, priorTerm
) )
LOGDIFF[, c(i1, i2)] <- -Inf globals$LOGDIFF[, c(i1, i2)] <- -Inf
inx <- c(matlab2r::find(PARTITION == i1), matlab2r::find(PARTITION == i2)) inx <- c(matlab2r::find(globals$PARTITION == i1), matlab2r::find(globals$PARTITION == i2))
LOGDIFF[inx, ] <- -Inf globals$LOGDIFF[inx, ] <- -Inf
} }
updateGlobalVariables2 <- function(i1, i2, diffInCounts, adjprior, priorTerm) { updateGlobalVariables2 <- function(i1, i2, diffInCounts, adjprior, priorTerm) {

2
R/viewPartition.R
View file

@ -1,5 +1,5 @@
viewPartition <- function(osuudet, popnames) { viewPartition <- function(osuudet, popnames) {
npops <- size(COUNTS, 3) npops <- size(globals$COUNTS, 3)
nind <- size(osuudet, 1) nind <- size(osuudet, 1)
# TODO: translate if necessary. Remove if this function won't be used # TODO: translate if necessary. Remove if this function won't be used

16
R/writeMixtureInfo.R
View file

@ -16,7 +16,7 @@ writeMixtureInfo <- function(
partitionSummary, popnames, fixedK, verbose partitionSummary, popnames, fixedK, verbose
) { ) {
ninds <- size(data, 1) / rowsFromInd ninds <- size(data, 1) / rowsFromInd
npops <- size(COUNTS, 3) npops <- size(globals$COUNTS, 3)
# Check that the names refer to individuals # Check that the names refer to individuals
# Tarkistetaan ett?nimet viittaavat yksil<69>ihin # Tarkistetaan ett?nimet viittaavat yksil<69>ihin
@ -64,13 +64,13 @@ writeMixtureInfo <- function(
) )
} }
cluster_count <- length(unique(PARTITION)) cluster_count <- length(unique(globals$PARTITION))
if (verbose) cat("Best Partition: ") if (verbose) cat("Best Partition: ")
if (fid != -1) { if (fid != -1) {
append(fid, c("Best Partition: ", "\n")) append(fid, c("Best Partition: ", "\n"))
} }
for (m in 1:cluster_count) { for (m in 1:cluster_count) {
indsInM <- matlab2r::find(PARTITION == m) indsInM <- matlab2r::find(globals$PARTITION == m)
length_of_beginning <- 11 + floor(log10(m)) length_of_beginning <- 11 + floor(log10(m))
cluster_size <- length(indsInM) cluster_size <- length(indsInM)
@ -158,7 +158,7 @@ writeMixtureInfo <- function(
} }
# %ninds = size(data,1)/rowsFromInd; # %ninds = size(data,1)/rowsFromInd;
changesInLogml <- t(LOGDIFF) changesInLogml <- t(globals$LOGDIFF)
for (ind in 1:ninds) { for (ind in 1:ninds) {
muutokset <- changesInLogml[, ind] muutokset <- changesInLogml[, ind]
if (names) { if (names) {
@ -183,9 +183,9 @@ writeMixtureInfo <- function(
append(fid, " KL-divergence matrix in PHYLIP format: ") append(fid, " KL-divergence matrix in PHYLIP format: ")
} }
COUNTS <- COUNTS[seq_len(nrow(adjprior)), seq_len(ncol(adjprior)), , drop = FALSE] globals$COUNTS <- globals$COUNTS[seq_len(nrow(adjprior)), seq_len(ncol(adjprior)), , drop = FALSE]
maxnoalle <- size(COUNTS, 1) maxnoalle <- size(globals$COUNTS, 1)
nloci <- size(COUNTS, 2) nloci <- size(globals$COUNTS, 2)
d <- zeros(maxnoalle, nloci, npops) d <- zeros(maxnoalle, nloci, npops)
prior <- adjprior prior <- adjprior
prior[matlab2r::find(prior == 1)] <- 0 prior[matlab2r::find(prior == 1)] <- 0
@ -195,7 +195,7 @@ writeMixtureInfo <- function(
prior[1, nollia] <- 1 prior[1, nollia] <- 1
for (pop1 in 1:npops) { for (pop1 in 1:npops) {
squeezed_COUNTS_prior <- squeeze(COUNTS[, , pop1]) + prior squeezed_COUNTS_prior <- squeeze(globals$COUNTS[, , pop1]) + prior
d[, , pop1] <- squeezed_COUNTS_prior / sum(squeezed_COUNTS_prior) d[, , pop1] <- squeezed_COUNTS_prior / sum(squeezed_COUNTS_prior)
} }
ekarivi <- as.character(npops) ekarivi <- as.character(npops)

16
R/writeMixtureInfoPop.R
View file

@ -14,7 +14,7 @@ writeMixtureInfoPop <- function(logml, rows, data, adjprior, priorTerm,
outPutFile, inputFile, partitionSummary, outPutFile, inputFile, partitionSummary,
popnames, fixedK) { popnames, fixedK) {
ninds <- size(rows, 1) ninds <- size(rows, 1)
npops <- size(COUNTS, 3) npops <- size(globals$COUNTS, 3)
names <- size(popnames, 1) == ninds # Tarkistetaan ett?nimet viittaavat yksilöihin names <- size(popnames, 1) == ninds # Tarkistetaan ett?nimet viittaavat yksilöihin
changesInLogml <- vector() changesInLogml <- vector()
if (!missing(outPutFile)) { if (!missing(outPutFile)) {
@ -32,13 +32,13 @@ writeMixtureInfoPop <- function(logml, rows, data, adjprior, priorTerm,
append(fid, c("Number of clusters in optimal partition:", ownNum2Str(npops), "\n")) append(fid, c("Number of clusters in optimal partition:", ownNum2Str(npops), "\n"))
append(fid, c("Log(marginal likelihood) of optimal partition:", ownNum2Str(logml), "\n\n")) append(fid, c("Log(marginal likelihood) of optimal partition:", ownNum2Str(logml), "\n\n"))
} }
cluster_count <- length(unique(PARTITION)) cluster_count <- length(unique(globals$PARTITION))
cat("Best Partition:\n") cat("Best Partition:\n")
if (exists("fid")) { if (exists("fid")) {
append(fid, c("Best partition:\n")) append(fid, c("Best partition:\n"))
} }
for (m in 1:cluster_count) { for (m in 1:cluster_count) {
indsInM <- find(PARTITION == m) indsInM <- find(globals$PARTITION == m)
length_of_beginning <- 11 + floor(log10(m)) length_of_beginning <- 11 + floor(log10(m))
cluster_size <- length(indsInM) cluster_size <- length(indsInM)
if (names) { if (names) {
@ -101,7 +101,7 @@ writeMixtureInfoPop <- function(logml, rows, data, adjprior, priorTerm,
if (exists("fid")) { if (exists("fid")) {
append(fid, c(ekarivi, "\n")) append(fid, c(ekarivi, "\n"))
} }
changesInLogml <- t(LOGDIFF) changesInLogml <- t(globals$LOGDIFF)
for (ind in 1:ninds) { for (ind in 1:ninds) {
muutokset <- changesInLogml[, ind] muutokset <- changesInLogml[, ind]
if (names) { if (names) {
@ -126,16 +126,16 @@ writeMixtureInfoPop <- function(logml, rows, data, adjprior, priorTerm,
append(fid, " \n") append(fid, " \n")
append(fid, "KL - divergence matrix in PHYLIP format:\n") append(fid, "KL - divergence matrix in PHYLIP format:\n")
} }
maxnoalle <- size(COUNTS, 1) maxnoalle <- size(globals$COUNTS, 1)
nloci <- size(COUNTS, 2) nloci <- size(globals$COUNTS, 2)
d <- zeros(maxnoalle, nloci, npops) d <- zeros(maxnoalle, nloci, npops)
prior <- adjprior prior <- adjprior
prior[find[prior == 1]] <- 0 prior[find[prior == 1]] <- 0
nollia <- find(all(prior == 0)) # Lokukset, joissa oli havaittu vain yht?alleelia. nollia <- find(all(prior == 0)) # Lokukset, joissa oli havaittu vain yht?alleelia.
prior[1, nollia] <- 1 prior[1, nollia] <- 1
for (pop1 in 1:npops) { for (pop1 in 1:npops) {
d[, , pop1] <- (squeeze(COUNTS[, , pop1]) + prior) / d[, , pop1] <- (squeeze(globals$COUNTS[, , pop1]) + prior) /
repmat(sum(squeeze(COUNTS[, , pop1]) + prior), c(maxnoalle, 1)) repmat(sum(squeeze(globals$COUNTS[, , pop1]) + prior), c(maxnoalle, 1))
} }
ekarivi <- as.character(npops) ekarivi <- as.character(npops)
cat(ekarivi, "\n") cat(ekarivi, "\n")

29
tests/testthat/test-greedyPopMix.R
View file

@ -11,14 +11,33 @@ test_that("Auxiliary functions work properly", {
expect_equal(findOutRowsFromInd(x, y, "Diploid"), z) expect_equal(findOutRowsFromInd(x, y, "Diploid"), z)
# Testing getPopDistancesByKL ------------------------------------------------ # Testing getPopDistancesByKL ------------------------------------------------
set.seed(5562143)
globals$COUNTS <- array(rpois(10 ^ 3, lambda = 10), dim = c(10, 10, 10))
x2 <- matrix(seq(4, 14, 2), 3) x2 <- matrix(seq(4, 14, 2), 3)
expect_equal( Z <- matrix(
getPopDistancesByKL(x2), c(
list( 5, 8, 0.004410383, 11, 10, 0.009386554, 2, 7, 0.010046641,
Z = matrix(c(c(1, 101:198), 2:100, rep(0, 99)), nrow = 99, ncol = 3), 3, 12, 0.011518562, 1, 4, 0.013682110, 14, 6, 0.027109229,
distances = as.matrix(rep(0, 4950)) 15, 13, 0.032833011, 16, 9, 0.045394132, 17, 18, 0.086729590
),
nrow = 9, ncol = 3, byrow = TRUE
) )
distances <- matrix(
c(
0.015767099, 0.020110943, 0.013682110, 0.010214691, 0.050375802,
0.019692440, 0.010294099, 0.053740306, 0.028410233, 0.034496635,
0.025356695, 0.015267764, 0.045409885, 0.010046641, 0.012797950,
0.065436956, 0.026308651, 0.019896390, 0.006193117, 0.011735103,
0.036077638, 0.011518562, 0.029233839, 0.010798344, 0.013262098,
0.034671122, 0.032833011, 0.024732472, 0.033976345, 0.040243817,
0.020374790, 0.024770297, 0.004410383, 0.024329842, 0.009386554,
0.052217370, 0.027109229, 0.038127778, 0.016888110, 0.024061302,
0.086729590, 0.038787638, 0.045394132, 0.005206076, 0.042606915
),
nrow = 45, ncol = 1,
byrow = TRUE
) )
expect_equal(getPopDistancesByKL(x2), list(Z = Z, distances = distances))
# Testing handlePopData ------------------------------------------------------ # Testing handlePopData ------------------------------------------------------
x3 <- matrix(c(9, 4, 1, 8, 5, 2, 1, 2, 3), 3) x3 <- matrix(c(9, 4, 1, 8, 5, 2, 1, 2, 3), 3)