Merge branch 'computeAllFreqs2' into dev

NAMESPACE

@@ -3,6 +3,7 @@
 export(admix1)
 export(calculatePopLogml)
 export(colon)
+export(computeAllFreqs2)
 export(computeIndLogml)
 export(computePersonalAllFreqs)
 export(computeRows)

R/admix1.R

@@ -5,7 +5,7 @@
 admix1 <- function(tietue) {
     if (!is.list(tietue)) {
 #         c(filename, pathname) = uigetfile('*.mat', 'Load mixture result file');
-#         if (filename==0 & pathname==0), return; 
+#         if (filename==0 & pathname==0), return;
 #         else
 #             disp('---------------------------------------------------');
 #             disp(['Reading mixture result from: ',[pathname filename],'...']);
@@ -13,7 +13,7 @@ admix1 <- function(tietue) {
 #         pause(0.0001);
 #         h0 = findobj('Tag','filename1_text');
 #         set(h0,'String',filename); clear h0;
-        
+
 #         struct_array = load([pathname filename]);
 #         if isfield(struct_array,'c')  #Matlab versio
 #             c = struct_array.c;
@@ -31,7 +31,7 @@ admix1 <- function(tietue) {
 #             disp('Incorrect file format');
 #             return;
 #         end
-        
+
 #         if isfield(c, 'gene_lengths') && ...
 #                 (strcmp(c.mixtureType,'linear_mix') | ...
 #                 strcmp(c.mixtureType,'codon_mix')) # if the mixture is from a linkage model
@@ -40,7 +40,7 @@ admix1 <- function(tietue) {
 #             linkage_admix(c);
 #             return
 #         end
-        
+
 #         PARTITION = c.PARTITION; COUNTS = c.COUNTS; SUMCOUNTS = c.SUMCOUNTS;
 #         alleleCodes = c.alleleCodes; adjprior = c.adjprior; popnames = c.popnames;
 #         rowsFromInd = c.rowsFromInd; data = c.data; npops = c.npops; noalle = c.noalle;
@@ -148,7 +148,7 @@ admix1 <- function(tietue) {
 #     for iterationNum = 1:iterationCount
 #         disp(['Iter: ' num2str(iterationNum)]);
 #         allfreqs = simulateAllFreqs(noalle);   # Allele frequencies on this iteration.
-        
+
 #         for ind=to_investigate
 #             #disp(num2str(ind));
 #             omaFreqs = computePersonalAllFreqs(ind, data, allfreqs, rowsFromInd);
@@ -172,7 +172,7 @@ admix1 <- function(tietue) {
 #                     PARTITION(ind)=isoimman_indeksi;
 #                 end
 #                 logml = computeIndLogml(omaFreqs, osuusTaulu);
-                
+
 #                 for osuus = [0.5 0.25 0.05 0.01]
 #                     [osuusTaulu, logml] = etsiParas(osuus, osuusTaulu, omaFreqs, logml);
 #                 end
@@ -227,23 +227,23 @@ admix1 <- function(tietue) {
 #     for pop = admix_populaatiot'
 
 #         for level = 1:n_missing_levels(pop)
-            
+
 #             potential_inds_in_this_pop_and_level = ...
 #                 find(PARTITION==pop & missing_level_partition==level &...
 #                 likelihood>3);  # Potential admix individuals here.
-            
+
 #             if ~isempty(potential_inds_in_this_pop_and_level)
-            
+
 #                 #refData = simulateIndividuals(nrefIndsInPop,rowsFromInd,allfreqs);
 #                 refData = simulateIndividuals(nrefIndsInPop, rowsFromInd, allfreqs, ...
 #                     pop, missing_levels(pop,level));
-            
+
 #                 disp(['Analysing the reference individuals from pop ' num2str(pop) ' (level ' num2str(level) ').']);
 #                 refProportions = zeros(nrefIndsInPop,npops);
 #                 for iter = 1:iterationCountRef
 #                     #disp(['Iter: ' num2str(iter)]);
 #                     allfreqs = simulateAllFreqs(noalle);
-                
+
 #                     for ind = 1:nrefIndsInPop
 #                         omaFreqs = computePersonalAllFreqs(ind, refData, allfreqs, rowsFromInd);
 #                         osuusTaulu = zeros(1,npops);
@@ -312,7 +312,7 @@ admix1 <- function(tietue) {
 #         end
 #     end
 
-#     tulostaAdmixtureTiedot(proportionsIt, uskottavuus, alaRaja, iterationCount); 
+#     tulostaAdmixtureTiedot(proportionsIt, uskottavuus, alaRaja, iterationCount);
 
 #     viewPartition(proportionsIt, popnames);
 
@@ -335,7 +335,7 @@ admix1 <- function(tietue) {
 
 
 #         if (~isstruct(tietue))
-#             c.proportionsIt = proportionsIt; 
+#             c.proportionsIt = proportionsIt;
 #             c.pvalue = uskottavuus; # Added by Jing
 #             c.mixtureType = 'admix'; # Jing
 #             c.admixnpops = npops;
@@ -355,7 +355,7 @@ admix1 <- function(tietue) {
 
 # function [npops] = poistaLiianPienet(npops, rowsFromInd, alaraja)
 # % Muokkaa tulokset muotoon, jossa outlier yksilöt on
-# % poistettu. Tarkalleen ottaen poistaa ne populaatiot, 
+# % poistettu. Tarkalleen ottaen poistaa ne populaatiot,
 # % joissa on vähemmän kuin 'alaraja':n verran yksilöit?
 
 # global PARTITION;
@@ -400,30 +400,4 @@ admix1 <- function(tietue) {
 # global COUNTS; COUNTS = [];
 # global SUMCOUNTS; SUMCOUNTS = [];
 # global PARTITION; PARTITION = [];
-# global POP_LOGML; POP_LOGML = [];
+# global POP_LOGML; POP_LOGML = [];
-
-# %--------------------------------------------------------
-
-
-# function allFreqs = computeAllFreqs2(noalle)
-# % Lisää a priori jokaista alleelia
-# % joka populaation joka lokukseen j 1/noalle(j) verran.
-
-# global COUNTS;
-# global SUMCOUNTS;
-
-# max_noalle = size(COUNTS,1);
-# nloci = size(COUNTS,2);
-# npops = size(COUNTS,3);
-
-# sumCounts = SUMCOUNTS+ones(size(SUMCOUNTS));
-# sumCounts = reshape(sumCounts', [1, nloci, npops]);
-# sumCounts = repmat(sumCounts, [max_noalle, 1 1]);
-
-# prioriAlleelit = zeros(max_noalle,nloci);
-# for j=1:nloci
-#     prioriAlleelit(1:noalle(j),j) = 1/noalle(j);
-# end
-# prioriAlleelit = repmat(prioriAlleelit, [1,1,npops]);
-# counts = COUNTS + prioriAlleelit;
-# allFreqs = counts./sumCounts;

R/computeAllFreqs2.R

@@ -0,0 +1,29 @@
+#' @title Compute all freqs - version 2
+#' @description Lisää a priori jokaista alleelia joka populaation joka lokukseen
+#' j 1/noalle(j) verran.
+#' @param noalle noalle
+#' @param COUNTS counts
+#' @param SUMCOUNTS sumcounts
+#' @export
+computeAllFreqs2 <- function (noalle, COUNTS = matrix(NA, 0, 0),
+    SUMCOUNTS = NA) {
+
+    max_noalle <- size(COUNTS, 1)
+    nloci <- size(COUNTS,2)
+    npops <- size(COUNTS,3)
+
+    sumCounts <- SUMCOUNTS + ones(size(SUMCOUNTS))
+    sumCounts <- reshape(t(sumCounts), c(1, nloci, npops))
+    sumCounts <- repmat(sumCounts, c(max_noalle, 1, 1))
+
+    prioriAlleelit <- zeros(max_noalle, nloci)
+    if (nloci > 0) {
+        for (j in 1:nloci) {
+            prioriAlleelit[1:noalle[j], j] <- 1 / noalle[j]
+        }
+    }
+    prioriAlleelit <- repmat(prioriAlleelit, c(1, 1, npops))
+    counts <- COUNTS + prioriAlleelit
+    allFreqs <- counts / sumCounts
+    return(allFreqs)
+}

R/repmat.R

@@ -3,15 +3,16 @@
 #' @details This function was created to replicate the behavior of a homonymous
 #' function on Matlab
 #' @param mx matrix
-#' @param n either a scalar with the number of replications in both rows and columns or a 2-length vector with individual repetitions.
+#' @param n either a scalar with the number of replications in both rows and
+#' columns or a <= 3-length vector with individual repetitions.
 #' @return matrix replicated over `ncol(mx) * n` columns and `nrow(mx) * n` rows
 #' @note The Matlab implementation of this function accepts `n` with length > 2.
-#' 
+#'
 #' It should also be noted that a concatenated vector in R, e.g. `c(5, 2)`, becomes a column vector when coerced to matrix, even though it may look like a row vector at first glance. This is important to keep in mind when considering the expected output of this function. Vectors in R make sense to be seen as column vectors, given R's Statistics-oriented paradigm where variables are usually disposed as columns in a dataset.
 #' @export
 repmat <- function (mx, n) {
     # Validation
-    if (length(n) > 2) warning("Extra dimensions of n ignored")
+    if (length(n) > 3) warning("Extra dimensions of n ignored")
     if (length(n) == 1) n <- rep(n, 2)
     if (class(mx) != "matrix") mx <- as.matrix(mx)
 
@@ -23,6 +24,9 @@ repmat <- function (mx, n) {
         for (i in seq(n[1] - 1)) out <- rbind(out, mx_col)
     }
 
+    # Replicating 3rd dimension
+    if (!is.na(n[3]) & n[3] > 1) out <- array(out, c(dim(out), n[3]))
+
     # Output
-    return(unname(as.matrix(out)))
+    return(unname(as.array(out)))
 }

R/reshape.R

@@ -0,0 +1,24 @@
+#' @title Reshape array
+#' @description Reshapes a matrix according to a certain number of dimensions
+#' @param A input matrix
+#' @param sz vector containing the dimensions of the output vector
+#' @details This function replicates the functionality of the `reshape()`
+#' function on Matlab. This function is basically a fancy wrapper for the
+#' `array()` function in R, but is useful because it saves the user translation
+#' time. Moreover, it introduces validation code that alter the behavior of
+#' `array()` and makes it more similar to `replicate()`.
+#' @note The Matlab function also accepts as input the dismemberment of sz as
+#' scalars.
+reshape <- function(A, sz) {
+    # Validation
+    if (prod(sz) != prod(dim(A))) {
+        stop("To RESHAPE the number of elements must not change.")
+    }
+    if (length(sz) == 1) {
+        stop("Size vector must have at least two elements.")
+    }
+
+    # Reshaping A
+    A <- array(A, sz)
+    return(A)
+}

man/computeAllFreqs2.Rd

@@ -0,0 +1,19 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/computeAllFreqs2.R
+\name{computeAllFreqs2}
+\alias{computeAllFreqs2}
+\title{Compute all freqs - version 2}
+\usage{
+computeAllFreqs2(noalle, COUNTS = matrix(NA, 0, 0), SUMCOUNTS = sum(COUNTS))
+}
+\arguments{
+\item{noalle}{noalle}
+
+\item{COUNTS}{counts}
+
+\item{SUMCOUNTS}{sumcounts}
+}
+\description{
+Lisää a priori jokaista alleelia joka populaation joka lokukseen
+j 1/noalle(j) verran.
+}

man/reshape.Rd

@@ -0,0 +1,27 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/reshape.R
+\name{reshape}
+\alias{reshape}
+\title{Reshape array}
+\usage{
+reshape(A, sz)
+}
+\arguments{
+\item{A}{input matrix}
+
+\item{sz}{vector containing the dimensions of the output vector}
+}
+\description{
+Reshapes a matrix according to a certain number of dimensions
+}
+\details{
+This function replicates the functionality of the `reshape()`
+function on Matlab. This function is basically a fancy wrapper for the
+`array()` function in R, but is useful because it saves the user translation
+time. Moreover, it introduces validation code that alter the behavior of
+`array()` and makes it more similar to `replicate()`.
+}
+\note{
+The Matlab function also accepts as input the dismemberment of sz as
+scalars.
+}

man/simulateAllFreqs.Rd

@@ -4,7 +4,7 @@
 \alias{simulateAllFreqs}
 \title{Simulate All Frequencies}
 \usage{
-simulateAllFreqs(noalle, COUNTS = matrix())
+simulateAllFreqs(noalle, COUNTS = matrix(NA, 0, 0))
 }
 \arguments{
 \item{noalle}{noalle}

tests/testthat/test-admix1.R

@@ -114,7 +114,7 @@ test_that("computeIndLogml works like on Matlab", {
     expect_equivalent(computeIndLogml(1, 0), -Inf)
     expect_equivalent(computeIndLogml(0, 0), -Inf)
     expect_equivalent(computeIndLogml(-pi, -8), 3.2242, tol = .0001)
-    expect_equivalent(computeIndLogml(2:3, 2), 2.3026, tol = .0001)    
+    expect_equivalent(computeIndLogml(2:3, 2), 2.3026, tol = .0001)
     expect_equivalent(computeIndLogml(matrix(8:5, 2), 100), 14.316, tol = .001)
     expect_equivalent(
         object    = computeIndLogml(matrix(8:5, 2), matrix(c(1, 3), 1)),
@@ -223,4 +223,8 @@ test_that("simulateAllFreqs works as expected", {
         object = suppressWarnings(simulateAllFreqs(matrix(1:4, 2))),
         expected = empty_mt
     )
+})
+
+test_that("computeAllFreqs2 works as expected", {
+    expect_equivalent(computeAllFreqs2(10), matrix(NA, 0, 0))
 })

tests/testthat/test-convertedBaseFunctions.R

@@ -28,6 +28,10 @@ test_that("repmat works properly", {
         object = repmat(mx2, c(4, 1)),
         expected = rbind(mx2, mx2, mx2, mx2)
     )
+    expect_equal(
+        object = repmat(mx2, c(1, 1, 2)),
+        expected = array(mx2, c(2, 2, 2))
+    )
 })
 
 test_that("zeros and ones work as expected", {
@@ -84,4 +88,15 @@ test_that("size works as on MATLAB", {
     expect_equal(size(mx, 2), 3)
     expect_equal(size(ra, 2), 3)
     expect_equal(size(ra, 3), 4)
+})
+
+test_that("reshape reshapes properly", {
+    mx <- matrix(1:4, 2)
+    ra <- array(1:12, c(2, 3, 2))
+    expect_equal(reshape(mx, c(1, 4)), matrix(1:4, 1))
+    expect_equal(reshape(mx, c(2, 2)), mx)
+    expect_equal(reshape(mx, c(1, 1, 4)), array(mx, c(1, 1, 4)))
+    expect_error(reshape(mx, c(1, 2, 3)))
+    expect_error(reshape(ra, c(1, 2, 3)))
+    expect_equal(reshape(ra, c(3, 2, 2)), array(ra, c(3, 2, 2)))
 })