diff --git a/DESCRIPTION b/DESCRIPTION index 20ade91..8e8ffb6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -40,4 +40,4 @@ RoxygenNote: 7.2.1 Suggests: testthat (>= 2.1.0) Imports: - methods, ape, vcfR, Rsamtools, adegenet, matlab2r + methods, ape, vcfR, Rsamtools, adegenet, matlab2r, R6 diff --git a/NAMESPACE b/NAMESPACE index 43dbeb2..a7ddd55 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -15,7 +15,6 @@ export(greedyPopMix) export(handleData) export(handlePopData) export(initPopNames) -export(laskeMuutokset4) export(learn_partition_modified) export(learn_simple_partition) export(linkage) @@ -40,6 +39,7 @@ export(testaaOnkoKunnollinenBapsData) export(testaaPop) export(writeMixtureInfo) export(writeMixtureInfoPop) +importFrom(R6,R6Class) importFrom(Rsamtools,scanBam) importFrom(adegenet,.readExt) importFrom(adegenet,read.genepop) diff --git a/R/etsiParas.R b/R/etsiParas.R index 8757e38..80ee063 100644 --- a/R/etsiParas.R +++ b/R/etsiParas.R @@ -8,7 +8,8 @@ etsiParas <- function(osuus, osuusTaulu, omaFreqs, logml) { ready <- 0 while (ready != 1) { - muutokset <- laskeMuutokset4(osuus, osuusTaulu, omaFreqs, logml) + muutokset <- admix1_muutokset$new() + muutokset <- muutokset$laskeMuutokset4(osuus, osuusTaulu, omaFreqs, logml) # Work around R's base::max() limitation on complex numbers if (any(vapply(muutokset, class, vector("character", 1)) == "complex")) { diff --git a/R/indMix.R b/R/indMix.R index e7a51ee..883d19a 100644 --- a/R/indMix.R +++ b/R/indMix.R @@ -142,8 +142,9 @@ indMix <- function(c, npops, dispText = TRUE) { for (ind in inds) { i1 <- PARTITION[ind] - muutokset_diffInCounts <- laskeMuutokset( - # FIXME: using 100-length global variables instead of the ones in this function + muutokset_diffInCounts <- greedyMix_muutokset$new() + # FIXME: using 100-length global variables instead of the ones in this function + muutokset_diffInCounts <- muutokset_diffInCounts$laskeMuutokset( ind, rows, data, adjprior, priorTerm ) muutokset <- muutokset_diffInCounts$muutokset @@ -190,7 +191,8 @@ indMix <- function(c, npops, dispText = TRUE) { } else if (round == 2) { # Populaation yhdist�minen toiseen. maxMuutos <- 0 for (pop in 1:npops) { - muutokset_diffInCounts <- laskeMuutokset2( + muutokset_diffInCounts <- greedyMix_muutokset$new() + muutokset_diffInCounts <- muutokset_diffInCounts$laskeMuutokset2( pop, rows, data, adjprior, priorTerm ) muutokset <- muutokset_diffInCounts$muutokset @@ -244,7 +246,8 @@ indMix <- function(c, npops, dispText = TRUE) { npops2 <- 2 # Moneenko osaan jaetaan } T2 <- cluster_own(Z2, npops2) - muutokset <- laskeMuutokset3( + muutokset_diffInCounts <- greedyMix_muutokset$new() + muutokset <- muutokset_diffInCounts$laskeMuutokset3( T2, inds2, rows, data, adjprior, priorTerm, pop ) isoin <- matlab2r::max(muutokset)[[1]] @@ -326,8 +329,8 @@ indMix <- function(c, npops, dispText = TRUE) { while (length(inds) > 0 & i < length(inds)) { i <- i + 1 ind <- inds[i] - - muutokset_diffInCounts <- laskeMuutokset( + muutokset_diffInCounts <- greedyMix_muutokset$new() + muutokset_diffInCounts <- muutokset_diffInCounts$laskeMuutokset( ind, rows, data, adjprior, priorTerm ) muutokset <- muutokset_diffInCounts$muutokset @@ -411,8 +414,8 @@ indMix <- function(c, npops, dispText = TRUE) { Z2 <- linkage(t(dist2)) T2 <- cluster_own(Z2, 2) muuttuvat <- inds2[matlab2r::find(T2 == 1)] - - muutokset <- laskeMuutokset3( + muutokset <- greedyMix_muutokset$new() + muutokset <- muutokset$laskeMuutokset3( T2, inds2, rows, data, adjprior, priorTerm, pop ) totalMuutos <- muutokset(1, emptyPop) @@ -436,7 +439,8 @@ indMix <- function(c, npops, dispText = TRUE) { while (muutettu == 1) { muutettu <- 0 # Siirret��n yksil�it� populaatioiden v�lill� - muutokset <- laskeMuutokset5( + muutokset <- greedyMix_muutokset$new() + muutokset <- muutokset$laskeMuutokset5( inds2, rows, data, adjprior, priorTerm, pop, emptyPop ) diff --git a/R/laskeMuutokset12345.R b/R/laskeMuutokset12345.R index be783bd..7cffc86 100644 --- a/R/laskeMuutokset12345.R +++ b/R/laskeMuutokset12345.R @@ -1,161 +1,153 @@ -#' @title Calculate changes (?) +#' @title Calculate changes (spatial mixture class) +spatialMixture_muutokset <- R6Class( + classname = "spatialMixture_muutokset", + public = list( + #' @param ind ind + #' @param rowsFromInd rowsFromInd + #' @param data data + #' @param adjprior adjprior + #' @param priorTerm priorTerm + #' @param logml logml + #' @param cliques cliques + #' @param separators separators + laskeMuutokset = function( + ind, rowsFromInd, data, adjprior, priorTerm, logml, cliques, separators + ) { + stop("Not yet implemented") # TODO: implement + } + ) +) + +#' @title Calculate changes (admix1 class) #' @description Palauttaa npops*npops taulun, jonka alkio (i,j) kertoo, mik?on #' muutos logml:ss? mikäli populaatiosta i siirretään osuuden verran #' todennäköisyysmassaa populaatioon j. Mikäli populaatiossa i ei ole mitään #' siirrettävää, on vastaavassa kohdassa rivi nollia. -#' @param osuus Percentages? -#' @param omaFreqs own Freqs? -#' @param osuusTaulu Percentage table? -#' @param logml log maximum likelihood -#' @export -laskeMuutokset4 <- function(osuus, osuusTaulu, omaFreqs, logml) { - if (isGlobalEmpty(COUNTS)) { - npops <- 1 - } else { - npops <- ifelse(is.na(dim(COUNTS)[3]), 1, dim(COUNTS)[3]) - } - notEmpty <- which(osuusTaulu > 0.005) - muutokset <- zeros(npops) - empties <- !notEmpty - - for (i1 in notEmpty) { - osuusTaulu[i1] <- osuusTaulu[i1] - osuus - for (i2 in c(colon(1, i1 - 1), colon(i1 + 1, npops))) { - osuusTaulu[i2] <- osuusTaulu[i2] + osuus - loggis <- computeIndLogml(omaFreqs, osuusTaulu) - - # Work around Matlab OOB bug - if (i1 > nrow(muutokset)) { - muutokset <- rbind(muutokset, muutokset * 0) - } - if (i2 > ncol(muutokset)) { - muutokset <- cbind(muutokset, muutokset * 0) +#' @importFrom R6 R6Class +admix1_muutokset <- R6Class( + classname = "admix1_muutokset", + public = list( + #' @param osuus Percentages? + #' @param osuusTaulu Percentage table? + #' @param omaFreqs own Freqs? + #' @param logml log maximum likelihood + laskeMuutokset4 = function(osuus, osuusTaulu, omaFreqs, logml) { + if (isGlobalEmpty(COUNTS)) { + npops <- 1 + } else { + npops <- ifelse(is.na(dim(COUNTS)[3]), 1, dim(COUNTS)[3]) } + notEmpty <- which(osuusTaulu > 0.005) + muutokset <- zeros(npops) + empties <- !notEmpty - muutokset[i1, i2] <- loggis - logml - osuusTaulu[i2] <- osuusTaulu[i2] - osuus + for (i1 in notEmpty) { + osuusTaulu[i1] <- osuusTaulu[i1] - osuus + for (i2 in c(colon(1, i1 - 1), colon(i1 + 1, npops))) { + osuusTaulu[i2] <- osuusTaulu[i2] + osuus + loggis <- computeIndLogml(omaFreqs, osuusTaulu) + + # Work around Matlab OOB bug + if (i1 > nrow(muutokset)) { + muutokset <- rbind(muutokset, muutokset * 0) + } + if (i2 > ncol(muutokset)) { + muutokset <- cbind(muutokset, muutokset * 0) + } + + muutokset[i1, i2] <- loggis - logml + osuusTaulu[i2] <- osuusTaulu[i2] - osuus + } + osuusTaulu[i1] <- osuusTaulu[i1] + osuus + } + return(muutokset) } - osuusTaulu[i1] <- osuusTaulu[i1] + osuus - } - return(muutokset) -} - -# Palauttaa npops*1 taulun, jossa i:s alkio kertoo, mik� olisi -# muutos logml:ss�, mik�li yksil� ind siirret��n koriin i. -# diffInCounts on poistettava COUNTS:in siivusta i1 ja lis�tt�v� -# COUNTS:in siivuun i2, mik�li muutos toteutetaan. -# -# Lis�ys 25.9.2007: -# Otettu k�ytt��n globaali muuttuja LOGDIFF, johon on tallennettu muutokset -# logml:ss� siirrett�ess� yksil�it� toisiin populaatioihin. -laskeMuutokset <- function(ind, globalRows, data, adjprior, priorTerm) { - npops <- size(COUNTS, 3) - muutokset <- LOGDIFF[ind, ] - - i1 <- PARTITION[ind] - i1_logml <- POP_LOGML[i1] - muutokset[i1] <- 0 - - rows <- globalRows[ind, 1]:globalRows[ind, 2] - diffInCounts <- computeDiffInCounts( - rows, size(COUNTS, 1), size(COUNTS, 2), data ) - diffInSumCounts <- colSums(diffInCounts) +) - COUNTS[, , i1] <- COUNTS[, , i1] - diffInCounts - SUMCOUNTS[i1, ] <- SUMCOUNTS[i1, ] - diffInSumCounts - new_i1_logml <- computePopulationLogml(i1, adjprior, priorTerm) - COUNTS[, , i1] <- COUNTS[, , i1] + diffInCounts - SUMCOUNTS[i1, ] <- SUMCOUNTS[i1, ] + diffInSumCounts +#' @title Calculate changes (greedyMix class) +#' @description Palauttaa npops*1 taulun, jossa i:s alkio kertoo, mik� olisi +#' muutos logml:ss�, mik�li yksil� ind siirret��n koriin i. +#' diffInCounts on poistettava COUNTS:in siivusta i1 ja lis�tt�v� +#' COUNTS:in siivuun i2, mik�li muutos toteutetaan. +#' +#' Lis�ys 25.9.2007: +#' Otettu k�ytt��n globaali muuttuja LOGDIFF, johon on tallennettu muutokset +#' logml:ss� siirrett�ess� yksil�it� toisiin populaatioihin. +greedyMix_muutokset <- R6Class( + classname = "greedyMix_muutokset", + public = list( + #' @param ind ind + #' @param globalRows globalRows + #' @param data data + #' @param adjprior adjprior + #' @param priorTerm priorTerm + laskeMuutokset = function(ind, globalRows, data, adjprior, priorTerm) { + npops <- size(COUNTS, 3) + muutokset <- LOGDIFF[ind, ] - i2 <- matlab2r::find(muutokset == -Inf) # Etsit��n populaatiot jotka muuttuneet viime kerran j�lkeen. (Searching for populations that have changed since the last time) - i2 <- setdiff(i2, i1) - i2_logml <- POP_LOGML[i2] + i1 <- PARTITION[ind] + i1_logml <- POP_LOGML[i1] + muutokset[i1] <- 0 - ni2 <- length(i2) + rows <- globalRows[ind, 1]:globalRows[ind, 2] + diffInCounts <- computeDiffInCounts( + rows, size(COUNTS, 1), size(COUNTS, 2), data + ) + diffInSumCounts <- colSums(diffInCounts) - COUNTS[, , i2] <- COUNTS[, , i2] + repmat(diffInCounts, c(1, 1, ni2)) - SUMCOUNTS[i2, ] <- SUMCOUNTS[i2, ] + repmat(diffInSumCounts, c(ni2, 1)) - new_i2_logml <- computePopulationLogml(i2, adjprior, priorTerm) - COUNTS[, , i2] <- COUNTS[, , i2] - repmat(diffInCounts, c(1, 1, ni2)) - SUMCOUNTS[i2, ] <- SUMCOUNTS[i2, ] - repmat(diffInSumCounts, c(ni2, 1)) + COUNTS[, , i1] <- COUNTS[, , i1] - diffInCounts + SUMCOUNTS[i1, ] <- SUMCOUNTS[i1, ] - diffInSumCounts + new_i1_logml <- computePopulationLogml(i1, adjprior, priorTerm) + COUNTS[, , i1] <- COUNTS[, , i1] + diffInCounts + SUMCOUNTS[i1, ] <- SUMCOUNTS[i1, ] + diffInSumCounts - muutokset[i2] <- new_i1_logml - i1_logml + new_i2_logml - i2_logml - LOGDIFF[ind, ] <- muutokset - return(list(muutokset = muutokset, diffInCounts = diffInCounts)) -} + i2 <- matlab2r::find(muutokset == -Inf) # Etsit��n populaatiot jotka muuttuneet viime kerran j�lkeen. (Searching for populations that have changed since the last time) + i2 <- setdiff(i2, i1) + i2_logml <- POP_LOGML[i2] -laskeMuutokset2 <- function(i1, globalRows, data, adjprior, priorTerm) { - # % Palauttaa npops*1 taulun, jossa i:s alkio kertoo, mik� olisi - # % muutos logml:ss�, mik�li korin i1 kaikki yksil�t siirret��n - # % koriin i. + ni2 <- length(i2) - npops <- size(COUNTS, 3) - muutokset <- zeros(npops, 1) + COUNTS[, , i2] <- COUNTS[, , i2] + repmat(diffInCounts, c(1, 1, ni2)) + SUMCOUNTS[i2, ] <- SUMCOUNTS[i2, ] + repmat(diffInSumCounts, c(ni2, 1)) + new_i2_logml <- computePopulationLogml(i2, adjprior, priorTerm) + COUNTS[, , i2] <- COUNTS[, , i2] - repmat(diffInCounts, c(1, 1, ni2)) + SUMCOUNTS[i2, ] <- SUMCOUNTS[i2, ] - repmat(diffInSumCounts, c(ni2, 1)) - i1_logml <- POP_LOGML[i1] + muutokset[i2] <- new_i1_logml - i1_logml + new_i2_logml - i2_logml + LOGDIFF[ind, ] <- muutokset + return(list(muutokset = muutokset, diffInCounts = diffInCounts)) + }, + #' @param i1 i1 + #' @param globalRows globalRows + #' @param data data + #' @param adjprior adjprior + #' @param priorTerm priorTerm + laskeMuutokset2 = function(i1, globalRows, data, adjprior, priorTerm) { + # % Palauttaa npops*1 taulun, jossa i:s alkio kertoo, mik� olisi + # % muutos logml:ss�, mik�li korin i1 kaikki yksil�t siirret��n + # % koriin i. - inds <- matlab2r::find(PARTITION == i1) - ninds <- length(inds) + npops <- size(COUNTS, 3) + muutokset <- zeros(npops, 1) - if (ninds == 0) { - diffInCounts <- zeros(size(COUNTS, 1), size(COUNTS, 2)) - return() - } + i1_logml <- POP_LOGML[i1] - rows <- list() - for (i in 1:ninds) { - ind <- inds(i) - lisa <- globalRows(ind, 1):globalRows(ind, 2) - rows <- c(rows, t(lisa)) - } + inds <- matlab2r::find(PARTITION == i1) + ninds <- length(inds) - diffInCounts <- computeDiffInCounts( - t(rows), size(COUNTS, 1), size(COUNTS, 2), data - ) - diffInSumCounts <- sum(diffInCounts) + if (ninds == 0) { + diffInCounts <- zeros(size(COUNTS, 1), size(COUNTS, 2)) + return() + } - COUNTS[, , i1] <- COUNTS[, , i1] - diffInCounts - SUMCOUNTS[i1, ] <- SUMCOUNTS[i1, ] - diffInSumCounts - new_i1_logml <- computePopulationLogml(i1, adjprior, priorTerm) - COUNTS[, , i1] <- COUNTS[, , i1] + diffInCounts - SUMCOUNTS[i1, ] <- SUMCOUNTS[i1, ] + diffInSumCounts - - i2 <- c(1:i1 - 1, i1 + 1:npops) - i2_logml <- POP_LOGML[i2] - - COUNTS[, , i2] <- COUNTS[, , i2] + repmat(diffInCounts, c(1, 1, npops - 1)) - SUMCOUNTS[i2, ] <- SUMCOUNTS[i2, ] + repmat(diffInSumCounts, c(npops - 1, 1)) - new_i2_logml <- computePopulationLogml(i2, adjprior, priorTerm) - COUNTS[, , i2] <- COUNTS[, , i2] - repmat(diffInCounts, c(1, 1, npops - 1)) - SUMCOUNTS[i2, ] <- SUMCOUNTS[i2, ] - repmat(diffInSumCounts, c(npops - 1, 1)) - - muutokset[i2] <- new_i1_logml - i1_logml + new_i2_logml - i2_logml - return(list(muutokset = muutokset, diffInCounts = diffInCounts)) -} - - -laskeMuutokset3 <- function(T2, inds2, globalRows, data, adjprior, priorTerm, i1 -) { - # Palauttaa length(unique(T2))*npops taulun, jossa (i,j):s alkio - # kertoo, mik� olisi muutos logml:ss�, jos populaation i1 osapopulaatio - # inds2(matlab2r::find(T2==i)) siirret��n koriin j. - - npops <- size(COUNTS, 3) - npops2 <- length(unique(T2)) - muutokset <- zeros(npops2, npops) - - i1_logml <- POP_LOGML[i1] - for (pop2 in 1:npops2) { - inds <- inds2[matlab2r::find(T2 == pop2)] - ninds <- length(inds) - if (ninds > 0) { rows <- list() for (i in 1:ninds) { - ind <- inds[i] - lisa <- globalRows[ind, 1]:globalRows[ind, 2] + ind <- inds(i) + lisa <- globalRows(ind, 1):globalRows(ind, 2) rows <- c(rows, t(lisa)) } + diffInCounts <- computeDiffInCounts( t(rows), size(COUNTS, 1), size(COUNTS, 2), data ) @@ -168,61 +160,121 @@ laskeMuutokset3 <- function(T2, inds2, globalRows, data, adjprior, priorTerm, i1 SUMCOUNTS[i1, ] <- SUMCOUNTS[i1, ] + diffInSumCounts i2 <- c(1:i1 - 1, i1 + 1:npops) - i2_logml <- t(POP_LOGML[i2]) + i2_logml <- POP_LOGML[i2] COUNTS[, , i2] <- COUNTS[, , i2] + repmat(diffInCounts, c(1, 1, npops - 1)) SUMCOUNTS[i2, ] <- SUMCOUNTS[i2, ] + repmat(diffInSumCounts, c(npops - 1, 1)) - new_i2_logml <- t(computePopulationLogml(i2, adjprior, priorTerm)) + new_i2_logml <- computePopulationLogml(i2, adjprior, priorTerm) COUNTS[, , i2] <- COUNTS[, , i2] - repmat(diffInCounts, c(1, 1, npops - 1)) SUMCOUNTS[i2, ] <- SUMCOUNTS[i2, ] - repmat(diffInSumCounts, c(npops - 1, 1)) - muutokset[pop2, 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)) + }, + #' @param T2 T2 + #' @param inds2 inds2 + #' @param globalRows globalRows + #' @param data data + #' @param adjprior adjprior + #' @param priorTerm priorTerm + #' @param i1 i1 + laskeMuutokset3 = function( + T2, inds2, globalRows, data, adjprior, priorTerm, i1 + ) { + # Palauttaa length(unique(T2))*npops taulun, jossa (i,j):s alkio + # kertoo, mik� olisi muutos logml:ss�, jos populaation i1 osapopulaatio + # inds2(matlab2r::find(T2==i)) siirret��n koriin j. + + npops <- size(COUNTS, 3) + npops2 <- length(unique(T2)) + muutokset <- zeros(npops2, npops) + + i1_logml <- POP_LOGML[i1] + for (pop2 in 1:npops2) { + inds <- inds2[matlab2r::find(T2 == pop2)] + ninds <- length(inds) + if (ninds > 0) { + rows <- list() + for (i in 1:ninds) { + ind <- inds[i] + lisa <- globalRows[ind, 1]:globalRows[ind, 2] + rows <- c(rows, t(lisa)) + } + diffInCounts <- computeDiffInCounts( + t(rows), size(COUNTS, 1), size(COUNTS, 2), data + ) + diffInSumCounts <- sum(diffInCounts) + + COUNTS[, , i1] <- COUNTS[, , i1] - diffInCounts + SUMCOUNTS[i1, ] <- SUMCOUNTS[i1, ] - diffInSumCounts + new_i1_logml <- computePopulationLogml(i1, adjprior, priorTerm) + COUNTS[, , i1] <- COUNTS[, , i1] + diffInCounts + SUMCOUNTS[i1, ] <- SUMCOUNTS[i1, ] + diffInSumCounts + + i2 <- c(1:i1 - 1, i1 + 1:npops) + i2_logml <- t(POP_LOGML[i2]) + + COUNTS[, , i2] <- COUNTS[, , i2] + repmat(diffInCounts, c(1, 1, npops - 1)) + SUMCOUNTS[i2, ] <- SUMCOUNTS[i2, ] + repmat(diffInSumCounts, c(npops - 1, 1)) + new_i2_logml <- t(computePopulationLogml(i2, adjprior, priorTerm)) + COUNTS[, , i2] <- COUNTS[, , i2] - repmat(diffInCounts, c(1, 1, npops - 1)) + SUMCOUNTS[i2, ] <- SUMCOUNTS[i2, ] - repmat(diffInSumCounts, c(npops - 1, 1)) + + muutokset[pop2, i2] <- new_i1_logml - i1_logml + new_i2_logml - i2_logml + } + } + return(muutokset) + }, + #' @param inds inds + #' @param globalRows globalRows + #' @param data data + #' @param adjprior adjprior + #' @param priorTerm priorTerm + #' @param i1 i1 + #' @param i2 i2 + laskeMuutokset5 = function(inds, globalRows, data, adjprior, priorTerm, i1, i2) { + # Palauttaa length(inds)*1 taulun, jossa i:s alkio kertoo, mik� olisi + # muutos logml:ss�, mik�li yksil� i vaihtaisi koria i1:n ja i2:n v�lill�. + + ninds <- length(inds) + muutokset <- zeros(ninds, 1) + + i1_logml <- POP_LOGML[i1] + i2_logml <- POP_LOGML[i2] + + for (i in 1:ninds) { + ind <- inds[i] + if (PARTITION[ind] == i1) { + pop1 <- i1 # mist� + pop2 <- i2 # mihin + } else { + pop1 <- i2 + pop2 <- i1 + } + rows <- globalRows[ind, 1]:globalRows[ind, 2] + diffInCounts <- computeDiffInCounts( + rows, size(COUNTS, 1), size(COUNTS, 2), data + ) + diffInSumCounts <- sum(diffInCounts) + + + + COUNTS[, , pop1] <- COUNTS[, , pop1] - diffInCounts + SUMCOUNTS[pop1, ] <- SUMCOUNTS[pop1, ] - diffInSumCounts + COUNTS[, , pop2] <- COUNTS[, , pop2] + diffInCounts + SUMCOUNTS[pop2, ] <- SUMCOUNTS[pop2, ] + diffInSumCounts + + new_logmls <- computePopulationLogml(c(i1, i2), adjprior, priorTerm) + muutokset[i] <- sum(new_logmls) + + COUNTS[, , pop1] <- COUNTS[, , pop1] + diffInCounts + SUMCOUNTS[pop1, ] <- SUMCOUNTS[pop1, ] + diffInSumCounts + COUNTS[, , pop2] <- COUNTS[, , pop2] - diffInCounts + SUMCOUNTS[pop2, ] <- SUMCOUNTS[pop2, ] - diffInSumCounts + } + + muutokset <- muutokset - i1_logml - i2_logml + return(muutokset) } - } - return(muutokset) -} - -laskeMuutokset5 <- function(inds, globalRows, data, adjprior, priorTerm, i1, i2) { - # Palauttaa length(inds)*1 taulun, jossa i:s alkio kertoo, mik� olisi - # muutos logml:ss�, mik�li yksil� i vaihtaisi koria i1:n ja i2:n v�lill�. - - ninds <- length(inds) - muutokset <- zeros(ninds, 1) - - i1_logml <- POP_LOGML[i1] - i2_logml <- POP_LOGML[i2] - - for (i in 1:ninds) { - ind <- inds[i] - if (PARTITION[ind] == i1) { - pop1 <- i1 # mist� - pop2 <- i2 # mihin - } else { - pop1 <- i2 - pop2 <- i1 - } - rows <- globalRows[ind, 1]:globalRows[ind, 2] - diffInCounts <- computeDiffInCounts( - rows, size(COUNTS, 1), size(COUNTS, 2), data - ) - diffInSumCounts <- sum(diffInCounts) - - - - COUNTS[, , pop1] <- COUNTS[, , pop1] - diffInCounts - SUMCOUNTS[pop1, ] <- SUMCOUNTS[pop1, ] - diffInSumCounts - COUNTS[, , pop2] <- COUNTS[, , pop2] + diffInCounts - SUMCOUNTS[pop2, ] <- SUMCOUNTS[pop2, ] + diffInSumCounts - - new_logmls <- computePopulationLogml(c(i1, i2), adjprior, priorTerm) - muutokset[i] <- sum(new_logmls) - - COUNTS[, , pop1] <- COUNTS[, , pop1] + diffInCounts - SUMCOUNTS[pop1, ] <- SUMCOUNTS[pop1, ] + diffInSumCounts - COUNTS[, , pop2] <- COUNTS[, , pop2] - diffInCounts - SUMCOUNTS[pop2, ] <- SUMCOUNTS[pop2, ] - diffInSumCounts - } - - muutokset <- muutokset - i1_logml - i2_logml - return(muutokset) -} + ) +) diff --git a/R/laskeVarmuus.R b/R/laskeVarmuus.R new file mode 100644 index 0000000..cbc3a56 --- /dev/null +++ b/R/laskeVarmuus.R @@ -0,0 +1,13 @@ +laskeVarmuus <- function( + rowsFromInd, data, adjprior, priorTerm, logml, cliques, separators, ninds +) { + varmuus <- zeros(ninds, 1) + for (ind in 1:ninds) { + muutokset <- spatialMixture_muutokset$new() + muutokset <- muutokset$laskeMuutokset( + ind, rowsFromInd, data, adjprior, priorTerm, logml, cliques, separators + ) + varmuus[ind] <- 1 / sum(exp(muutokset)) + } + return(varmuus) +} diff --git a/man/admix1_muutokset.Rd b/man/admix1_muutokset.Rd new file mode 100644 index 0000000..8b5d119 --- /dev/null +++ b/man/admix1_muutokset.Rd @@ -0,0 +1,58 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/laskeMuutokset12345.R +\name{admix1_muutokset} +\alias{admix1_muutokset} +\title{Calculate changes (admix1 class)} +\description{ +Palauttaa npops*npops taulun, jonka alkio (i,j) kertoo, mik?on +muutos logml:ss? mikäli populaatiosta i siirretään osuuden verran +todennäköisyysmassaa populaatioon j. Mikäli populaatiossa i ei ole mitään +siirrettävää, on vastaavassa kohdassa rivi nollia. +} +\section{Methods}{ +\subsection{Public methods}{ +\itemize{ +\item \href{#method-admix1_muutokset-laskeMuutokset4}{\code{admix1_muutokset$laskeMuutokset4()}} +\item \href{#method-admix1_muutokset-clone}{\code{admix1_muutokset$clone()}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-admix1_muutokset-laskeMuutokset4}{}}} +\subsection{Method \code{laskeMuutokset4()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{admix1_muutokset$laskeMuutokset4(osuus, osuusTaulu, omaFreqs, logml)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{osuus}}{Percentages?} + +\item{\code{osuusTaulu}}{Percentage table?} + +\item{\code{omaFreqs}}{own Freqs?} + +\item{\code{logml}}{log maximum likelihood} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-admix1_muutokset-clone}{}}} +\subsection{Method \code{clone()}}{ +The objects of this class are cloneable with this method. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{admix1_muutokset$clone(deep = FALSE)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{deep}}{Whether to make a deep clone.} +} +\if{html}{\out{
}} +} +} +} diff --git a/man/greedyMix_muutokset.Rd b/man/greedyMix_muutokset.Rd new file mode 100644 index 0000000..b720e58 --- /dev/null +++ b/man/greedyMix_muutokset.Rd @@ -0,0 +1,163 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/laskeMuutokset12345.R +\name{greedyMix_muutokset} +\alias{greedyMix_muutokset} +\title{Calculate changes (greedyMix class)} +\description{ +Palauttaa npops*1 taulun, jossa i:s alkio kertoo, mik� olisi +muutos logml:ss�, mik�li yksil� ind siirret��n koriin i. +diffInCounts on poistettava COUNTS:in siivusta i1 ja lis�tt�v� +COUNTS:in siivuun i2, mik�li muutos toteutetaan. + +Lis�ys 25.9.2007: +Otettu k�ytt��n globaali muuttuja LOGDIFF, johon on tallennettu muutokset +logml:ss� siirrett�ess� yksil�it� toisiin populaatioihin. +} +\section{Methods}{ +\subsection{Public methods}{ +\itemize{ +\item \href{#method-greedyMix_muutokset-laskeMuutokset}{\code{greedyMix_muutokset$laskeMuutokset()}} +\item \href{#method-greedyMix_muutokset-laskeMuutokset2}{\code{greedyMix_muutokset$laskeMuutokset2()}} +\item \href{#method-greedyMix_muutokset-laskeMuutokset3}{\code{greedyMix_muutokset$laskeMuutokset3()}} +\item \href{#method-greedyMix_muutokset-laskeMuutokset5}{\code{greedyMix_muutokset$laskeMuutokset5()}} +\item \href{#method-greedyMix_muutokset-clone}{\code{greedyMix_muutokset$clone()}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-greedyMix_muutokset-laskeMuutokset}{}}} +\subsection{Method \code{laskeMuutokset()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{greedyMix_muutokset$laskeMuutokset(ind, globalRows, data, adjprior, priorTerm)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{ind}}{ind} + +\item{\code{globalRows}}{globalRows} + +\item{\code{data}}{data} + +\item{\code{adjprior}}{adjprior} + +\item{\code{priorTerm}}{priorTerm} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-greedyMix_muutokset-laskeMuutokset2}{}}} +\subsection{Method \code{laskeMuutokset2()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{greedyMix_muutokset$laskeMuutokset2(i1, globalRows, data, adjprior, priorTerm)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{i1}}{i1} + +\item{\code{globalRows}}{globalRows} + +\item{\code{data}}{data} + +\item{\code{adjprior}}{adjprior} + +\item{\code{priorTerm}}{priorTerm} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-greedyMix_muutokset-laskeMuutokset3}{}}} +\subsection{Method \code{laskeMuutokset3()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{greedyMix_muutokset$laskeMuutokset3( + T2, + inds2, + globalRows, + data, + adjprior, + priorTerm, + i1 +)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{T2}}{T2} + +\item{\code{inds2}}{inds2} + +\item{\code{globalRows}}{globalRows} + +\item{\code{data}}{data} + +\item{\code{adjprior}}{adjprior} + +\item{\code{priorTerm}}{priorTerm} + +\item{\code{i1}}{i1} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-greedyMix_muutokset-laskeMuutokset5}{}}} +\subsection{Method \code{laskeMuutokset5()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{greedyMix_muutokset$laskeMuutokset5( + inds, + globalRows, + data, + adjprior, + priorTerm, + i1, + i2 +)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{inds}}{inds} + +\item{\code{globalRows}}{globalRows} + +\item{\code{data}}{data} + +\item{\code{adjprior}}{adjprior} + +\item{\code{priorTerm}}{priorTerm} + +\item{\code{i1}}{i1} + +\item{\code{i2}}{i2} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-greedyMix_muutokset-clone}{}}} +\subsection{Method \code{clone()}}{ +The objects of this class are cloneable with this method. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{greedyMix_muutokset$clone(deep = FALSE)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{deep}}{Whether to make a deep clone.} +} +\if{html}{\out{
}} +} +} +} diff --git a/man/laskeMuutokset4.Rd b/man/laskeMuutokset4.Rd deleted file mode 100644 index db7a2f2..0000000 --- a/man/laskeMuutokset4.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/laskeMuutokset12345.R -\name{laskeMuutokset4} -\alias{laskeMuutokset4} -\title{Calculate changes (?)} -\usage{ -laskeMuutokset4(osuus, osuusTaulu, omaFreqs, logml) -} -\arguments{ -\item{osuus}{Percentages?} - -\item{osuusTaulu}{Percentage table?} - -\item{omaFreqs}{own Freqs?} - -\item{logml}{log maximum likelihood} -} -\description{ -Palauttaa npops*npops taulun, jonka alkio (i,j) kertoo, mik?on -muutos logml:ss? mikäli populaatiosta i siirretään osuuden verran -todennäköisyysmassaa populaatioon j. Mikäli populaatiossa i ei ole mitään -siirrettävää, on vastaavassa kohdassa rivi nollia. -} diff --git a/man/spatialMixture_muutokset.Rd b/man/spatialMixture_muutokset.Rd new file mode 100644 index 0000000..ca75f0b --- /dev/null +++ b/man/spatialMixture_muutokset.Rd @@ -0,0 +1,74 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/laskeMuutokset12345.R +\name{spatialMixture_muutokset} +\alias{spatialMixture_muutokset} +\title{Calculate changes (spatial mixture class)} +\description{ +Calculate changes (spatial mixture class) + +Calculate changes (spatial mixture class) +} +\section{Methods}{ +\subsection{Public methods}{ +\itemize{ +\item \href{#method-spatialMixture_muutokset-laskeMuutokset}{\code{spatialMixture_muutokset$laskeMuutokset()}} +\item \href{#method-spatialMixture_muutokset-clone}{\code{spatialMixture_muutokset$clone()}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-spatialMixture_muutokset-laskeMuutokset}{}}} +\subsection{Method \code{laskeMuutokset()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{spatialMixture_muutokset$laskeMuutokset( + ind, + rowsFromInd, + data, + adjprior, + priorTerm, + logml, + cliques, + separators +)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{ind}}{ind} + +\item{\code{rowsFromInd}}{rowsFromInd} + +\item{\code{data}}{data} + +\item{\code{adjprior}}{adjprior} + +\item{\code{priorTerm}}{priorTerm} + +\item{\code{logml}}{logml} + +\item{\code{cliques}}{cliques} + +\item{\code{separators}}{separators} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-spatialMixture_muutokset-clone}{}}} +\subsection{Method \code{clone()}}{ +The objects of this class are cloneable with this method. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{spatialMixture_muutokset$clone(deep = FALSE)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{deep}}{Whether to make a deep clone.} +} +\if{html}{\out{
}} +} +} +} diff --git a/tests/testthat/test-admix1.R b/tests/testthat/test-admix1.R index 782ead3..27d5491 100644 --- a/tests/testthat/test-admix1.R +++ b/tests/testthat/test-admix1.R @@ -147,9 +147,9 @@ test_that("suoritaMuutos works like on Matlab", { }) test_that("laskeMuutokset4 works like on Matlab", { - mx1 <- t(c(.4, 7)) + x <- admix1_muutokset$new() expect_equivalent( - object = laskeMuutokset4(2, mx1, c(8, 2), 3), + object = x$laskeMuutokset4(2, t(c(.4, 7)), c(8, 2), 3), expected = t(c(0, .3742)), tol = .0001 )