Merge branch 'admix1' into dev

NAMESPACE

@@ -8,8 +8,10 @@ export(computeIndLogml)
 export(computePersonalAllFreqs)
 export(computeRows)
 export(etsiParas)
+export(isfield)
 export(laskeMuutokset4)
 export(learn_simple_partition)
+export(noIndex)
 export(ownNum2Str)
 export(poistaLiianPienet)
 export(proportion2str)
@@ -20,6 +22,7 @@ export(simulateAllFreqs)
 export(simulateIndividuals)
 export(simuloiAlleeli)
 export(size)
+export(strcmp)
 export(suoritaMuutos)
 export(times)
 importFrom(stats,runif)

R/isfield.R

@@ -0,0 +1,10 @@
+#' @title Checks if a list contains a field
+#' @description This function tries to replicate the behavior of the `isfield`
+#' function in Matlab
+#' @param x list
+#' @param field name of field
+#' @references https://se.mathworks.com/help/matlab/ref/isfield.html
+#' @export
+isfield <- function(x, field) {
+    sapply(field, function(f) f %in% names(x))
+}

R/noIndex.R

@@ -0,0 +1,19 @@
+#' @title No index
+#' @description Checks that the data contains no index column.
+#' @details As input, this function takes two variables from a mixture/admixture
+#' result structure.
+#' @return puredata: a data contains no index column.
+#' @export
+noIndex <- function  (data, noalle) {
+    limit <- ifelse(is(noalle, "matrix"), ncol(noalle), length(noalle))
+    if (size(data, 2) == limit + 1) {
+        if (is(data, "matrix")) {
+            puredata <- data[, -ncol(data)] # remove the index column
+        } else {
+            puredata <- data[-length(data)]
+        }
+    } else {
+        puredata <- data
+    }
+    return(puredata)
+}

R/poistaLiianPienet.R

@@ -10,9 +10,8 @@
 #' @param SUMCOUNTS SUMCOUNTS
 #' @export
 poistaLiianPienet <- function (npops, rowsFromInd, alaraja,
-    PARTITION = matrix(NA, 0, 0), COUNTS = matrix(NA, 0, 0),
-    SUMCOUNTS = NA) {
-
+        PARTITION = matrix(NA, 0, 0), COUNTS = matrix(NA, 0, 0),
+        SUMCOUNTS = NA) {
     popSize <- zeros(1,npops)
     if (npops > 0) {
         for (i in 1:npops) {

R/size.R

@@ -2,7 +2,7 @@
 #' @description This functions tries to replicate the behavior of the base function "size" in Matlab
 #' @param x object to be evaluated
 #' @param d dimension of object to be evaluated
-#' @note On MATLAB, size(1, 100) returns 1. As a matter of fact, if the user 
+#' @note On MATLAB, size(1, 100) returns 1. As a matter of fact, if the user
 #' calls for a dimension which x doesn't have `size()` always returns 1. R's
 #' default behavior is more reasonable in those cases (i.e., returning NA),
 #' but since the point of this function is to replicate MATLAB behaviors
@@ -25,12 +25,12 @@ size <- function(x, d) {
         n_dim <- ifelse(is.null(dim(x)), 1, length(dim(x)))
         if (missing(d)) {
             if (n_dim == 1) {
-                out <- range(x)
+                out <- c(1, length(x))
             } else {
                 out <- dim(x)
             }
         } else {
-            out <- ifelse(n_dim == 1, range(x)[d], dim(x)[d])
+            out <- ifelse(n_dim == 1, c(1, length(x))[d], dim(x)[d])
             if (is.na(out)) out <- 1  # for MATLAB compatibility
         }
         return(out)

R/strcmp.R

@@ -0,0 +1,28 @@
+#' @title Compare two character elements
+#' @description Logical test if two character elements are identical
+#' @param s1 first character element (string, vector or matrix)
+#' @param s2 second character element (string, vector or matrix)
+#' @return a logical element of the same type as the input
+#' @export
+strcmp <- function(s1, s2) {
+    if (length(s1) == 1 & length(s2) == 1) {
+        # Both are scalars, comparison is straightforward
+        return(identical(s1, s2))
+    } else if (length(s1) == 1 & length(s2) > 1) {
+        # s1 is a scalar and s2 is a vector or a matrix
+        checks <- sapply(s2, function(s) s1 %in% s)
+        if (is(s2, "matrix")) checks <- matrix(checks, nrow(s2))
+    } else if (length(s1) > 1 & length(s2) == 1) {
+        # s1 is a vector/matrix, s2 is a scalar
+        checks <- sapply(s1, function(s) s2 %in% s)
+        if (is(s1, "matrix")) checks <- matrix(checks, nrow(s1))
+    } else {
+        # s1 and s2 are vectors/matrices
+        if (identical(dim(s1), dim(s2))) {
+            checks <- as.matrix(s4 == s5)
+        } else {
+            stop("Inputs must be the same size or either one can be a scalar.")
+        }
+    }
+    return(checks)
+}

man/admix1.Rd

@@ -4,14 +4,22 @@
 \alias{admix1}
 \title{Admixture analysis}
 \usage{
-admix1(tietue)
+admix1(
+  tietue,
+  PARTITION = matrix(NA, 0, 0),
+  COUNTS = matrix(NA, 0, 0),
+  SUMCOUNTS = NA
+)
 }
 \arguments{
-\item{tietue}{record}
+\item{tietue}{a named record list}
 }
 \description{
 Admixture analysis
 }
 \details{
-If the record == -1, the mixture results file is loaded. Otherwise, will the required variables be retrieved from the record fields?
+If the record == -1, the mixture results file is loaded. Otherwise,
+will the required variables be retrieved from the record fields?
+`tietue`should contain the following elements: PARTITION, COUNTS, SUMCOUNTS,
+alleleCodes, adjprior, popnames, rowsFromInd, data, npops, noalle
 }

man/isfield.Rd

@@ -0,0 +1,20 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/isfield.R
+\name{isfield}
+\alias{isfield}
+\title{Checks if a list contains a field}
+\usage{
+isfield(x, field)
+}
+\arguments{
+\item{x}{list}
+
+\item{field}{name of field}
+}
+\description{
+This function tries to replicate the behavior of the `isfield`
+function in Matlab
+}
+\references{
+https://se.mathworks.com/help/matlab/ref/isfield.html
+}

man/noIndex.Rd

@@ -0,0 +1,18 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/noIndex.R
+\name{noIndex}
+\alias{noIndex}
+\title{No index}
+\usage{
+noIndex(data, noalle)
+}
+\value{
+puredata: a data contains no index column.
+}
+\description{
+Checks that the data contains no index column.
+}
+\details{
+As input, this function takes two variables from a mixture/admixture
+result structure.
+}

man/strcmp.Rd

@@ -0,0 +1,19 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/strcmp.R
+\name{strcmp}
+\alias{strcmp}
+\title{Compare two character elements}
+\usage{
+strcmp(s1, s2)
+}
+\arguments{
+\item{s1}{first character element (string, vector or matrix)}
+
+\item{s2}{second character element (string, vector or matrix)}
+}
+\value{
+a logical element of the same type as the input
+}
+\description{
+Logical test if two character elements are identical
+}

tests/testthat/test-admix1.R

@@ -232,4 +232,19 @@ test_that("computeAllFreqs2 works as expected", {
 test_that("poistaLiianPienet works as expected", {
     expect_equal(poistaLiianPienet(100, matrix(1:4, 2), 0), 100)
     expect_equal(poistaLiianPienet(100, matrix(1:4, 2), -5), 100)
+})
+
+test_that("noIndex works properly", {
+    abcd_vec <- letters[1:4]
+    abcd_mat <- matrix(abcd_vec, 2)
+    abcdef_mat <- matrix(letters[1:6], 2)
+    efg_vec <- letters[5:7]
+    expect_equal(noIndex(abcd_vec, 1:6), abcd_vec)
+    expect_equal(noIndex(abcd_vec, 1:3), abcd_vec[-4])
+    expect_equal(noIndex(abcd_vec, 1:2), abcd_vec)
+    expect_equal(noIndex(abcd_vec, efg_vec), abcd_vec[-4])
+    expect_equal(noIndex(abcd_mat, 1), abcd_mat[, 1])
+    expect_equal(noIndex(abcd_mat, 2), abcd_mat[, 1])
+    expect_equal(noIndex(abcdef_mat, 1:2), abcdef_mat[, 1:2])
+    expect_equal(noIndex(abcdef_mat, abcd_mat), abcdef_mat[, 1:2])
 })

tests/testthat/test-convertedBaseFunctions.R

@@ -99,4 +99,33 @@ test_that("reshape reshapes properly", {
     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)))
+})
+
+test_that("isfield works as on Matlab", {
+    S <- list()
+    S$x <- rnorm(100)
+    S$y <- sin(S$x)
+    S$title <- "y = sin(x)"
+    expect_true(isfield(S, "title"))
+    expect_equivalent(
+        object = isfield(S, c("x", "y", "z", "title", "error")),
+        expected = c(TRUE, TRUE, FALSE, TRUE, FALSE)
+    )
+})
+
+test_that("strcmp works as expected", {
+    yes <- 'Yes'
+    no <- 'No'
+    ja <- 'Yes'
+    expect_false(strcmp(yes, no))
+    expect_true(strcmp(yes, ja))
+    s1 <- 'upon'
+    s2 <- matrix(c('Once', 'upon', 'a', 'time'), 2, byrow=TRUE)
+    s3 <- c('Once', 'upon', 'a', 'time')
+    s4 <- matrix(c("A", "bc", "def", "G"), 2, byrow=TRUE)
+    s5 <- matrix(c("B", "c", "def", "G"), 2, byrow=TRUE)
+    expect_equal(strcmp(s1, s2), matrix(c(FALSE, FALSE, TRUE, FALSE), 2))
+    expect_equivalent(strcmp(s1, s3), c(FALSE, TRUE, FALSE, FALSE))
+    expect_error(strcmp(s2, s3))
+    expect_equal(strcmp(s4, s5), matrix(c(FALSE, TRUE, FALSE, TRUE), 2))
 })