From 317d281e70dd7da1fe392ae0aa33b3371bfbc264 Mon Sep 17 00:00:00 2001 From: Waldir Leoncio Date: Tue, 3 Mar 2020 10:50:27 +0100 Subject: [PATCH 1/6] Added isfield translation function --- R/isfield.R | 9 +++++++++ man/isfield.Rd | 20 ++++++++++++++++++++ 2 files changed, 29 insertions(+) create mode 100644 R/isfield.R create mode 100644 man/isfield.Rd diff --git a/R/isfield.R b/R/isfield.R new file mode 100644 index 0000000..ef818a2 --- /dev/null +++ b/R/isfield.R @@ -0,0 +1,9 @@ +#' @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 +isfield <- function(x, field) { + field %in% names(x) +} \ No newline at end of file diff --git a/man/isfield.Rd b/man/isfield.Rd new file mode 100644 index 0000000..a3ccd17 --- /dev/null +++ b/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 +} From 2f6ad882a92dea9473af4bf6c6e727e21a002b63 Mon Sep 17 00:00:00 2001 From: Waldir Leoncio Date: Tue, 3 Mar 2020 11:04:40 +0100 Subject: [PATCH 2/6] Added vectorizing capability and unit test --- R/isfield.R | 3 ++- tests/testthat/test-convertedBaseFunctions.R | 12 ++++++++++++ 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/R/isfield.R b/R/isfield.R index ef818a2..dc6404a 100644 --- a/R/isfield.R +++ b/R/isfield.R @@ -4,6 +4,7 @@ #' @param x list #' @param field name of field #' @references https://se.mathworks.com/help/matlab/ref/isfield.html +#' @export isfield <- function(x, field) { - field %in% names(x) + sapply(field, function(f) f %in% names(x)) } \ No newline at end of file diff --git a/tests/testthat/test-convertedBaseFunctions.R b/tests/testthat/test-convertedBaseFunctions.R index 7f75050..5683637 100644 --- a/tests/testthat/test-convertedBaseFunctions.R +++ b/tests/testthat/test-convertedBaseFunctions.R @@ -99,4 +99,16 @@ 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) + ) }) \ No newline at end of file From 4810df7fb979fb8920f8636ccb80a59eff2286c6 Mon Sep 17 00:00:00 2001 From: Waldir Leoncio Date: Tue, 3 Mar 2020 13:51:04 +0100 Subject: [PATCH 3/6] Added translated function + unit tests --- R/strcmp.R | 28 ++++++++++++++++++++ man/strcmp.Rd | 19 +++++++++++++ tests/testthat/test-convertedBaseFunctions.R | 17 ++++++++++++ 3 files changed, 64 insertions(+) create mode 100644 R/strcmp.R create mode 100644 man/strcmp.Rd diff --git a/R/strcmp.R b/R/strcmp.R new file mode 100644 index 0000000..c64cbce --- /dev/null +++ b/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) +} \ No newline at end of file diff --git a/man/strcmp.Rd b/man/strcmp.Rd new file mode 100644 index 0000000..b832fa9 --- /dev/null +++ b/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 +} diff --git a/tests/testthat/test-convertedBaseFunctions.R b/tests/testthat/test-convertedBaseFunctions.R index 5683637..b94ab16 100644 --- a/tests/testthat/test-convertedBaseFunctions.R +++ b/tests/testthat/test-convertedBaseFunctions.R @@ -111,4 +111,21 @@ test_that("isfield works as on Matlab", { 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)) }) \ No newline at end of file From 17282c423a8d8058f45ea0d40c2cc09640717c36 Mon Sep 17 00:00:00 2001 From: Waldir Leoncio Date: Tue, 3 Mar 2020 13:51:21 +0100 Subject: [PATCH 4/6] Fixes to documentation --- NAMESPACE | 2 ++ R/poistaLiianPienet.R | 5 ++--- man/admix1.Rd | 14 +++++++++++--- 3 files changed, 15 insertions(+), 6 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index aa5e19f..f304d20 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -8,6 +8,7 @@ export(computeIndLogml) export(computePersonalAllFreqs) export(computeRows) export(etsiParas) +export(isfield) export(laskeMuutokset4) export(learn_simple_partition) export(ownNum2Str) @@ -20,6 +21,7 @@ export(simulateAllFreqs) export(simulateIndividuals) export(simuloiAlleeli) export(size) +export(strcmp) export(suoritaMuutos) export(times) importFrom(stats,runif) diff --git a/R/poistaLiianPienet.R b/R/poistaLiianPienet.R index bc7f608..4ff581d 100644 --- a/R/poistaLiianPienet.R +++ b/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) { diff --git a/man/admix1.Rd b/man/admix1.Rd index 4f8c35a..d792b04 100644 --- a/man/admix1.Rd +++ b/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 } From 8ecc59a4e6beba31ed9e1a3df65d0099e3c49660 Mon Sep 17 00:00:00 2001 From: Waldir Leoncio Date: Tue, 3 Mar 2020 14:30:39 +0100 Subject: [PATCH 5/6] Translated BAPS::noIndex into R --- NAMESPACE | 1 + R/noIndex.R | 19 +++++++++++++++++++ man/noIndex.Rd | 18 ++++++++++++++++++ tests/testthat/test-admix1.R | 15 +++++++++++++++ 4 files changed, 53 insertions(+) create mode 100644 R/noIndex.R create mode 100644 man/noIndex.Rd diff --git a/NAMESPACE b/NAMESPACE index f304d20..afc1b39 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -11,6 +11,7 @@ export(etsiParas) export(isfield) export(laskeMuutokset4) export(learn_simple_partition) +export(noIndex) export(ownNum2Str) export(poistaLiianPienet) export(proportion2str) diff --git a/R/noIndex.R b/R/noIndex.R new file mode 100644 index 0000000..210ecd7 --- /dev/null +++ b/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) +} \ No newline at end of file diff --git a/man/noIndex.Rd b/man/noIndex.Rd new file mode 100644 index 0000000..bf7e5a3 --- /dev/null +++ b/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. +} diff --git a/tests/testthat/test-admix1.R b/tests/testthat/test-admix1.R index 453a1e1..ae33745 100644 --- a/tests/testthat/test-admix1.R +++ b/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]) }) \ No newline at end of file From 11bdefab7cb336233402402bd5ea54fb0d108b6e Mon Sep 17 00:00:00 2001 From: Waldir Leoncio Date: Tue, 3 Mar 2020 14:31:15 +0100 Subject: [PATCH 6/6] Fixed bugs in size() for non-sequential x --- R/size.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/size.R b/R/size.R index 001817b..219193e 100644 --- a/R/size.R +++ b/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)