Restyled files
Ran through styler::style_dir() in the R and tests directories in preparation for #23.
This commit is contained in:
Waldir Leoncio
parent
a9c7211465
commit
fca9caa731
101 changed files with 3856 additions and 3869 deletions
|
|
@ -19,7 +19,7 @@ addAlleles <- function(data, ind, line, divider) {
|
|||
|
||||
k <- 1
|
||||
merkki <- substring(line, k, k)
|
||||
while (merkki != ',') {
|
||||
while (merkki != ",") {
|
||||
k <- k + 1
|
||||
merkki <- substring(line, k, k)
|
||||
}
|
||||
|
|
@ -33,7 +33,7 @@ addAlleles <- function(data, ind, line, divider) {
|
|||
}
|
||||
|
||||
if (length(alleeliTaulu) != nloci) {
|
||||
stop('Incorrect data format.')
|
||||
stop("Incorrect data format.")
|
||||
}
|
||||
|
||||
for (j in seq_len(nloci)) {
|
||||
|
|
|
|||
76
R/admix1.R
76
R/admix1.R
|
|
@ -9,7 +9,7 @@
|
|||
#' @export
|
||||
admix1 <- function(tietue) {
|
||||
if (!is.list(tietue)) {
|
||||
message('Load mixture result file. These are the files in this directory:')
|
||||
message("Load mixture result file. These are the files in this directory:")
|
||||
print(list.files())
|
||||
pathname_filename <- file.choose()
|
||||
if (!file.exists(pathname_filename)) {
|
||||
|
|
@ -18,8 +18,8 @@ admix1 <- function(tietue) {
|
|||
" does not exist. Check spelling and location."
|
||||
)
|
||||
} else {
|
||||
cat('---------------------------------------------------\n');
|
||||
message('Reading mixture result from: ', pathname_filename, '...')
|
||||
cat("---------------------------------------------------\n")
|
||||
message("Reading mixture result from: ", pathname_filename, "...")
|
||||
}
|
||||
Sys.sleep(0.0001) # TODO: remove
|
||||
|
||||
|
|
@ -28,21 +28,21 @@ admix1 <- function(tietue) {
|
|||
# set(h0,'String',filename); clear h0;
|
||||
|
||||
struct_array <- load(pathname_filename)
|
||||
if (isfield(struct_array, 'c')) { #Matlab versio
|
||||
if (isfield(struct_array, "c")) { # Matlab versio
|
||||
c <- struct_array$c
|
||||
if (!isfield(c, 'PARTITION') | !isfield(c,'rowsFromInd')) {
|
||||
stop('Incorrect file format')
|
||||
if (!isfield(c, "PARTITION") | !isfield(c, "rowsFromInd")) {
|
||||
stop("Incorrect file format")
|
||||
}
|
||||
} else if (isfield(struct_array, 'PARTITION')) { #Mideva versio
|
||||
} else if (isfield(struct_array, "PARTITION")) { # Mideva versio
|
||||
c <- struct_array
|
||||
if (!isfield(c,'rowsFromInd')) stop('Incorrect file format')
|
||||
if (!isfield(c, "rowsFromInd")) stop("Incorrect file format")
|
||||
} else {
|
||||
stop('Incorrect file format')
|
||||
stop("Incorrect file format")
|
||||
}
|
||||
|
||||
if (isfield(c, 'gene_lengths') &
|
||||
strcmp(c$mixtureType, 'linear_mix') |
|
||||
strcmp(c$mixtureType, 'codon_mix')) { # if the mixture is from a linkage model
|
||||
if (isfield(c, "gene_lengths") &
|
||||
strcmp(c$mixtureType, "linear_mix") |
|
||||
strcmp(c$mixtureType, "codon_mix")) { # if the mixture is from a linkage model
|
||||
# Redirect the call to the linkage admixture function.
|
||||
# call function noindex to remove the index column
|
||||
c$data <- noIndex(c$data, c$noalle)
|
||||
|
|
@ -86,12 +86,14 @@ admix1 <- function(tietue) {
|
|||
nloci <- size(COUNTS, 2)
|
||||
ninds <- size(data, 1) / rowsFromInd
|
||||
|
||||
answers <- inputdlg('Input number of iterations', definput=50)
|
||||
if (isempty(answers)) return()
|
||||
answers <- inputdlg("Input number of iterations", definput = 50)
|
||||
if (isempty(answers)) {
|
||||
return()
|
||||
}
|
||||
iterationCount <- as.numeric(answers[1, 1]) # maybe [[]]?
|
||||
|
||||
answers <- inputdlg(
|
||||
prompt = 'Input number of reference individuals from each population',
|
||||
prompt = "Input number of reference individuals from each population",
|
||||
definput = 50
|
||||
)
|
||||
if (isempty(answers)) {
|
||||
|
|
@ -101,10 +103,12 @@ admix1 <- function(tietue) {
|
|||
}
|
||||
|
||||
answers <- inputdlg(
|
||||
prompt = 'Input number of iterations for reference individuals',
|
||||
prompt = "Input number of iterations for reference individuals",
|
||||
definput = 10
|
||||
)
|
||||
if (isempty(answers)) return()
|
||||
if (isempty(answers)) {
|
||||
return()
|
||||
}
|
||||
iterationCountRef <- as.numeric(answers[1, 1])
|
||||
|
||||
# First calculate log-likelihood ratio for all individuals:
|
||||
|
|
@ -146,12 +150,12 @@ admix1 <- function(tietue) {
|
|||
|
||||
# Analyze further only individuals who have log-likelihood ratio larger than 3:
|
||||
to_investigate <- t(find(likelihood > 3))
|
||||
cat('Possibly admixed individuals:\n')
|
||||
cat("Possibly admixed individuals:\n")
|
||||
for (i in 1:length(to_investigate)) {
|
||||
cat(as.character(to_investigate[i]))
|
||||
}
|
||||
cat(' ')
|
||||
cat('Populations for possibly admixed individuals:\n')
|
||||
cat(" ")
|
||||
cat("Populations for possibly admixed individuals:\n")
|
||||
admix_populaatiot <- unique(PARTITION[to_investigate])
|
||||
for (i in 1:length(admix_populaatiot)) {
|
||||
cat(as.character(admix_populaatiot[i]))
|
||||
|
|
@ -174,7 +178,7 @@ admix1 <- function(tietue) {
|
|||
|
||||
proportionsIt <- zeros(ninds, npops)
|
||||
for (iterationNum in 1:iterationCount) {
|
||||
cat('Iter:', as.character(iterationNum))
|
||||
cat("Iter:", as.character(iterationNum))
|
||||
allfreqs <- simulateAllFreqs(noalle) # Allele frequencies on this iteration.
|
||||
|
||||
for (ind in to_investigate) {
|
||||
|
|
@ -220,7 +224,7 @@ admix1 <- function(tietue) {
|
|||
# disp('each population.');
|
||||
|
||||
# allfreqs = simulateAllFreqs(noalle); # Simuloidaan alleelifrekvenssisetti
|
||||
allfreqs <- computeAllFreqs2(noalle); # Koitetaan tällaista.
|
||||
allfreqs <- computeAllFreqs2(noalle) # Koitetaan tällaista.
|
||||
|
||||
|
||||
# Initialize the data structures, which are required in taking the missing
|
||||
|
|
@ -249,7 +253,7 @@ admix1 <- function(tietue) {
|
|||
# part = learn_simple_partition(ordered, 0.05);
|
||||
part <- learn_partition_modified(ordered)
|
||||
aux <- sortrows(cbind(part, ordering), 2)
|
||||
part = aux[, 1]
|
||||
part <- aux[, 1]
|
||||
missing_level_partition[inds] <- part
|
||||
n_levels <- length(unique(part))
|
||||
n_missing_levels[i] <- n_levels
|
||||
|
|
@ -263,9 +267,7 @@ admix1 <- function(tietue) {
|
|||
# with potentially admixed individuals:
|
||||
refTaulu <- zeros(npops, 100, 3)
|
||||
for (pop in t(admix_populaatiot)) {
|
||||
|
||||
for (level in 1:n_missing_levels[pop]) {
|
||||
|
||||
potential_inds_in_this_pop_and_level <-
|
||||
find(
|
||||
PARTITION == pop & missing_level_partition == level &
|
||||
|
|
@ -281,8 +283,8 @@ admix1 <- function(tietue) {
|
|||
)
|
||||
|
||||
cat(
|
||||
'Analysing the reference individuals from pop', pop,
|
||||
'(level', level, ').'
|
||||
"Analysing the reference individuals from pop", pop,
|
||||
"(level", level, ")."
|
||||
)
|
||||
refProportions <- zeros(nrefIndsInPop, npops)
|
||||
for (iter in 1:iterationCountRef) {
|
||||
|
|
@ -370,11 +372,11 @@ admix1 <- function(tietue) {
|
|||
tulostaAdmixtureTiedot(proportionsIt, uskottavuus, alaRaja, iterationCount) # TODO: textual outputs. probably not necessary. translate nonetheless
|
||||
viewPartition(proportionsIt, popnames) # TODO: adapt
|
||||
|
||||
talle = inputdlg('Do you want to save the admixture results? [Y/n]', 'y')
|
||||
if (talle %in% c('y', 'Y', 'yes', 'Yes')) {
|
||||
talle <- inputdlg("Do you want to save the admixture results? [Y/n]", "y")
|
||||
if (talle %in% c("y", "Y", "yes", "Yes")) {
|
||||
# waitALittle;
|
||||
filename <- inputdlg(
|
||||
'Save results as (file name):', 'admixture_results.rda'
|
||||
"Save results as (file name):", "admixture_results.rda"
|
||||
)
|
||||
|
||||
|
||||
|
|
@ -382,22 +384,22 @@ admix1 <- function(tietue) {
|
|||
# Cancel was pressed
|
||||
return()
|
||||
} else { # copy 'baps4_output.baps' into the text file with the same name.
|
||||
if (file.exists('baps4_output.baps')) {
|
||||
file.copy('baps4_output.baps', paste0(filename, '.txt'))
|
||||
file.remove('baps4_output.baps')
|
||||
if (file.exists("baps4_output.baps")) {
|
||||
file.copy("baps4_output.baps", paste0(filename, ".txt"))
|
||||
file.remove("baps4_output.baps")
|
||||
}
|
||||
}
|
||||
|
||||
if (!is(tietue, "list")) {
|
||||
c$proportionsIt <- proportionsIt
|
||||
c$pvalue <- uskottavuus # Added by Jing
|
||||
c$mixtureType <- 'admix' # Jing
|
||||
c$admixnpops <- npops;
|
||||
c$mixtureType <- "admix" # Jing
|
||||
c$admixnpops <- npops
|
||||
save(c, file = filename)
|
||||
} else {
|
||||
tietue$proportionsIt <- proportionsIt
|
||||
tietue$pvalue <- uskottavuus; # Added by Jing
|
||||
tietue$mixtureType <- 'admix'
|
||||
tietue$pvalue <- uskottavuus # Added by Jing
|
||||
tietue$mixtureType <- "admix"
|
||||
tietue$admixnpops <- npops
|
||||
save(tietue, file = filename)
|
||||
}
|
||||
|
|
|
|||
|
|
@ -17,4 +17,3 @@ calculatePopLogml <- function(points, fii) {
|
|||
log_gamma(0.5)
|
||||
return(val)
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -7,16 +7,16 @@ cluster_own <- function(Z, nclust) {
|
|||
T <- zeros(m, 1)
|
||||
# % maximum number of clusters based on inconsistency
|
||||
if (m <= maxclust) {
|
||||
T = t((1:m))
|
||||
T <- t((1:m))
|
||||
} else if (maxclust == 1) {
|
||||
T <- ones(m, 1)
|
||||
} else {
|
||||
clsnum <- 1
|
||||
for (k in (m - maxclust + 1):(m - 1)) {
|
||||
i = Z[k, 1] # left tree
|
||||
i <- Z[k, 1] # left tree
|
||||
if (i <= m) { # original node, no leafs
|
||||
T[i] = clsnum
|
||||
clsnum = clsnum + 1
|
||||
T[i] <- clsnum
|
||||
clsnum <- clsnum + 1
|
||||
} else if (i < (2 * m - maxclust + 1)) { # created before cutoff, search down the tree
|
||||
T <- clusternum(Z, T, i - m, clsnum)
|
||||
clsnum <- clsnum + 1
|
||||
|
|
|
|||
|
|
@ -29,7 +29,9 @@ computePersonalAllFreqs <- function(ind, data, allFreqs, rowsFromInd) {
|
|||
data = as.matrix(t(allFreqs))[rows[all, loc], loc],
|
||||
nrow = npops
|
||||
),
|
||||
error = function(e) return(NA)
|
||||
error = function(e) {
|
||||
return(NA)
|
||||
}
|
||||
)
|
||||
} else {
|
||||
omaFreqs[, pointer] <- ones(npops, 1)
|
||||
|
|
|
|||
|
|
@ -11,7 +11,9 @@ computeRows <- function(rowsFromInd, inds, ninds) {
|
|||
# Special treatment for vectors because R has col vectors by default,
|
||||
# whereas Matlab has row vectors by default.
|
||||
inds <- t(inds)
|
||||
if (ninds == 0) return(matrix(, 1, 0))
|
||||
if (ninds == 0) {
|
||||
return(matrix(, 1, 0))
|
||||
}
|
||||
}
|
||||
rows <- inds[, rep(1, rowsFromInd)]
|
||||
rows <- rows * rowsFromInd
|
||||
|
|
@ -20,4 +22,3 @@ computeRows <- function(rowsFromInd, inds, ninds) {
|
|||
rows <- matrix(t(rows), c(1, rowsFromInd * ninds))
|
||||
return(t(rows))
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
#' @title Print a separator line
|
||||
dispLine <- function() {
|
||||
cat('---------------------------------------------------\n')
|
||||
cat("---------------------------------------------------\n")
|
||||
}
|
||||
|
|
@ -9,7 +9,9 @@ fgetl <- function(file) {
|
|||
# ==========================================================================
|
||||
# Validation
|
||||
# ==========================================================================
|
||||
if (length(file) <= 1) return(-1)
|
||||
if (length(file) <= 1) {
|
||||
return(-1)
|
||||
}
|
||||
# ==========================================================================
|
||||
# Returning file minus the first line
|
||||
# ==========================================================================
|
||||
|
|
|
|||
52
R/indMix.R
52
R/indMix.R
|
|
@ -14,7 +14,7 @@ indMix <- function(c, npops, dispText=TRUE) {
|
|||
priorTerm <- c$priorTerm
|
||||
rowsFromInd <- c$rowsFromInd
|
||||
|
||||
if (isfield(c, 'dist')) {
|
||||
if (isfield(c, "dist")) {
|
||||
dist <- c$dist
|
||||
Z <- c$Z
|
||||
}
|
||||
|
|
@ -25,9 +25,9 @@ indMix <- function(c, npops, dispText=TRUE) {
|
|||
dispText <- 1
|
||||
npopstext <- matrix()
|
||||
ready <- FALSE
|
||||
teksti <- 'Input upper bound to the number of populations (possibly multiple values)'
|
||||
teksti <- "Input upper bound to the number of populations (possibly multiple values)"
|
||||
while (!ready) {
|
||||
npopstextExtra <- inputdlg(teksti, 1, '20')
|
||||
npopstextExtra <- inputdlg(teksti, 1, "20")
|
||||
if (isempty(npopstextExtra)) { # Painettu Cancel:ia
|
||||
warnings("Empty value provided")
|
||||
return()
|
||||
|
|
@ -35,8 +35,8 @@ indMix <- function(c, npops, dispText=TRUE) {
|
|||
npopstextExtra <- npopstextExtra[[1]]
|
||||
if (length(npopstextExtra) >= 255) {
|
||||
npopstextExtra <- npopstextExtra[1:255]
|
||||
npopstext <- c(npopstext, ' ', npopstextExtra)
|
||||
teksti <- 'The input field length limit (255 characters) was reached. Input more values: '
|
||||
npopstext <- c(npopstext, " ", npopstextExtra)
|
||||
teksti <- "The input field length limit (255 characters) was reached. Input more values: "
|
||||
} else {
|
||||
npopstext <- as.numeric(strsplit(as.character(npopstextExtra), " ")[[1]])
|
||||
ready <- TRUE
|
||||
|
|
@ -77,9 +77,9 @@ indMix <- function(c, npops, dispText=TRUE) {
|
|||
if (dispText) {
|
||||
dispLine()
|
||||
cat(
|
||||
'Run ', as.character(run), '/', as.character(nruns),
|
||||
', maximum number of populations ', as.character(npops),
|
||||
'.\n',
|
||||
"Run ", as.character(run), "/", as.character(nruns),
|
||||
", maximum number of populations ", as.character(npops),
|
||||
".\n",
|
||||
sep = ""
|
||||
)
|
||||
}
|
||||
|
|
@ -114,8 +114,8 @@ indMix <- function(c, npops, dispText=TRUE) {
|
|||
if (dispText) {
|
||||
message(
|
||||
paste0(
|
||||
'\nMixture analysis started with initial ',
|
||||
as.character(npops), ' populations.'
|
||||
"\nMixture analysis started with initial ",
|
||||
as.character(npops), " populations."
|
||||
)
|
||||
)
|
||||
}
|
||||
|
|
@ -125,16 +125,14 @@ indMix <- function(c, npops, dispText=TRUE) {
|
|||
muutoksia <- 0
|
||||
|
||||
if (dispText) {
|
||||
message(paste('\nPerforming steps:', as.character(roundTypes)))
|
||||
message(paste("\nPerforming steps:", as.character(roundTypes)))
|
||||
}
|
||||
|
||||
for (n in 1:length(roundTypes)) {
|
||||
|
||||
round <- roundTypes[n]
|
||||
kivaluku <- 0
|
||||
|
||||
if (kokeiltu[round] == 1) { # Askelta kokeiltu viime muutoksen j<>lkeen
|
||||
|
||||
} else if (round == 0 | round == 1) { # Yksil<69>n siirt<72>minen toiseen populaatioon.
|
||||
inds <- 1:ninds
|
||||
aputaulu <- cbind(inds, rand(ninds, 1))
|
||||
|
|
@ -161,7 +159,7 @@ indMix <- function(c, npops, dispText=TRUE) {
|
|||
muutoksia <- 1
|
||||
if (muutosNyt == 0) {
|
||||
muutosNyt <- 1
|
||||
if (dispText) message('Action 1')
|
||||
if (dispText) message("Action 1")
|
||||
}
|
||||
kokeiltu <- zeros(nRoundTypes, 1)
|
||||
kivaluku <- kivaluku + 1
|
||||
|
|
@ -215,7 +213,7 @@ indMix <- function(c, npops, dispText=TRUE) {
|
|||
)
|
||||
logml <- logml + maxMuutos
|
||||
if (dispText) {
|
||||
cat('Action 2')
|
||||
cat("Action 2")
|
||||
}
|
||||
if (logml > worstLogml) {
|
||||
temp_addToSum <- addToSummary(
|
||||
|
|
@ -231,8 +229,6 @@ indMix <- function(c, npops, dispText=TRUE) {
|
|||
} else {
|
||||
kokeiltu[round] <- 1
|
||||
}
|
||||
|
||||
|
||||
} else if (round == 3 || round == 4) { # Populaation jakaminen osiin.
|
||||
maxMuutos <- 0
|
||||
ninds <- size(rows, 1)
|
||||
|
|
@ -281,9 +277,9 @@ indMix <- function(c, npops, dispText=TRUE) {
|
|||
logml <- logml + maxMuutos
|
||||
if (dispText) {
|
||||
if (round == 3) {
|
||||
cat('Action 3')
|
||||
cat("Action 3")
|
||||
} else {
|
||||
cat('Action 4')
|
||||
cat("Action 4")
|
||||
}
|
||||
}
|
||||
if (logml > worstLogml) {
|
||||
|
|
@ -297,7 +293,6 @@ indMix <- function(c, npops, dispText=TRUE) {
|
|||
worstIndex <- min_MATLAB(partitionSummary[, 2])[[2]]
|
||||
}
|
||||
}
|
||||
|
||||
} else {
|
||||
kokeiltu[round] <- 1
|
||||
}
|
||||
|
|
@ -362,9 +357,9 @@ indMix <- function(c, npops, dispText=TRUE) {
|
|||
muutoksia <- 1 # Ulompi kirjanpito.
|
||||
if (dispText) {
|
||||
if (round == 5) {
|
||||
cat('Action 5')
|
||||
cat("Action 5")
|
||||
} else {
|
||||
cat('Action 6')
|
||||
cat("Action 6")
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
@ -392,7 +387,6 @@ indMix <- function(c, npops, dispText=TRUE) {
|
|||
}
|
||||
}
|
||||
rm(partition, sumcounts, counts, poplogml)
|
||||
|
||||
} else if (round == 7) {
|
||||
emptyPop <- findEmptyPop(npops)
|
||||
j <- 0
|
||||
|
|
@ -413,7 +407,7 @@ indMix <- function(c, npops, dispText=TRUE) {
|
|||
poplogml <- POP_LOGML
|
||||
logdiff <- LOGDIFF
|
||||
|
||||
dist2 <- laskeOsaDist(inds2, dist, ninds);
|
||||
dist2 <- laskeOsaDist(inds2, dist, ninds)
|
||||
Z2 <- linkage(t(dist2))
|
||||
T2 <- cluster_own(Z2, 2)
|
||||
muuttuvat <- inds2[find(T2 == 1)]
|
||||
|
|
@ -486,7 +480,7 @@ indMix <- function(c, npops, dispText=TRUE) {
|
|||
}
|
||||
if (muutoksiaNyt == 0) {
|
||||
if (dispText) {
|
||||
cat('Action 7')
|
||||
cat("Action 7")
|
||||
}
|
||||
muutoksiaNyt <- 1
|
||||
}
|
||||
|
|
@ -501,13 +495,11 @@ indMix <- function(c, npops, dispText=TRUE) {
|
|||
LOGDIFF <- logdiff
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
if (muutoksiaNyt == 0) {
|
||||
kokeiltu[round] <- 1
|
||||
}
|
||||
|
||||
}
|
||||
}
|
||||
# FIXME: muutoksia is never 0, so vaihe never equals 5 and ready 1
|
||||
|
|
@ -542,9 +534,9 @@ indMix <- function(c, npops, dispText=TRUE) {
|
|||
npops <- poistaTyhjatPopulaatiot(npops)
|
||||
POP_LOGML <- computePopulationLogml(1:npops, adjprior, priorTerm)
|
||||
if (dispText) {
|
||||
print(paste('Found partition with', as.character(npops), 'populations.'))
|
||||
print(paste('Log(ml) =', as.character(logml)))
|
||||
print(' ')
|
||||
print(paste("Found partition with", as.character(npops), "populations."))
|
||||
print(paste("Log(ml) =", as.character(logml)))
|
||||
print(" ")
|
||||
}
|
||||
|
||||
if (logml > logmlBest) {
|
||||
|
|
|
|||
|
|
@ -8,10 +8,10 @@ initPopNames <- function(nameFile, indexFile) {
|
|||
|
||||
indices <- load(indexFile)
|
||||
|
||||
fid = load(nameFile)
|
||||
fid <- load(nameFile)
|
||||
if (fid == -1) {
|
||||
# File didn't exist
|
||||
stop('Loading of the population names was unsuccessful')
|
||||
stop("Loading of the population names was unsuccessful")
|
||||
}
|
||||
line <- readLines(fid)[1]
|
||||
counter <- 1
|
||||
|
|
@ -23,9 +23,9 @@ initPopNames <- function(nameFile, indexFile) {
|
|||
}
|
||||
|
||||
if (length(names) != length(indices)) {
|
||||
cat('The number of population names must be equal to the number of')
|
||||
cat('entries in the file specifying indices of the first individuals')
|
||||
cat('of each population.')
|
||||
cat("The number of population names must be equal to the number of")
|
||||
cat("entries in the file specifying indices of the first individuals")
|
||||
cat("of each population.")
|
||||
}
|
||||
|
||||
popnames <- cell(length(names), 2)
|
||||
|
|
|
|||
|
|
@ -11,7 +11,8 @@ inputdlg <- function(prompt, dims=1, definput=NULL) {
|
|||
input_chr <- readline(paste0(prompt, ": "))
|
||||
if (input_chr == "") input_chr <- definput
|
||||
input_chr_or_num <- tryCatch(
|
||||
as.numeric(input_chr), warning = function(w) input_chr
|
||||
as.numeric(input_chr),
|
||||
warning = function(w) input_chr
|
||||
)
|
||||
return(input_chr_or_num)
|
||||
}
|
||||
|
|
@ -5,7 +5,7 @@
|
|||
#' @note Recognized whitespace characters are ` ` and `\\t`.
|
||||
#' @author Waldir Leoncio
|
||||
isspace <- function(A) {
|
||||
A_split <- unlist(strsplit(A, ''))
|
||||
TF <- A_split %in% c(' ', '\t')
|
||||
A_split <- unlist(strsplit(A, ""))
|
||||
TF <- A_split %in% c(" ", "\t")
|
||||
return(as.numeric(TF))
|
||||
}
|
||||
|
|
@ -1,23 +1,22 @@
|
|||
kldiv2str <- function(div) {
|
||||
mjono <- ' '
|
||||
mjono <- " "
|
||||
if (abs(div) < 100) {
|
||||
# Ei tarvita e-muotoa
|
||||
mjono[6] <- as.character((floor(div * 1000)) %% 10)
|
||||
mjono[5] <- as.character((floor(div * 100)) %% 10)
|
||||
mjono[4] <- as.character((floor(div * 10)) %% 10)
|
||||
mjono[3] <- '.'
|
||||
mjono[3] <- "."
|
||||
mjono[2] <- as.character((floor(div)) %% 10)
|
||||
arvo <- (floor(div / 10)) %% 10
|
||||
if (arvo > 0) {
|
||||
mjono[1] <- as.character(arvo)
|
||||
}
|
||||
|
||||
} else {
|
||||
suurinYks <- floor(log10(div))
|
||||
mjono[6] <- as.character(suurinYks)
|
||||
mjono[5] <- 'e'
|
||||
mjono[5] <- "e"
|
||||
mjono[4] <- palautaYks(abs(div), suurinYks - 1)
|
||||
mjono[3] <- '.'
|
||||
mjono[3] <- "."
|
||||
mjono[2] <- palautaYks(abs(div), suurinYks)
|
||||
}
|
||||
return(mjono)
|
||||
|
|
|
|||
|
|
@ -103,7 +103,7 @@ laskeMuutokset2 <- function(i1, globalRows, data, adjprior, priorTerm) {
|
|||
return()
|
||||
}
|
||||
|
||||
rows = list()
|
||||
rows <- list()
|
||||
for (i in 1:ninds) {
|
||||
ind <- inds(i)
|
||||
lisa <- globalRows(ind, 1):globalRows(ind, 2)
|
||||
|
|
@ -144,10 +144,10 @@ laskeMuutokset3 <- function(T2, inds2, globalRows, data, adjprior, priorTerm, i1
|
|||
npops2 <- length(unique(T2))
|
||||
muutokset <- zeros(npops2, npops)
|
||||
|
||||
i1_logml = POP_LOGML[i1]
|
||||
i1_logml <- POP_LOGML[i1]
|
||||
for (pop2 in 1:npops2) {
|
||||
inds <- inds2[find(T2 == pop2)]
|
||||
ninds <- length(inds);
|
||||
ninds <- length(inds)
|
||||
if (ninds > 0) {
|
||||
rows <- list()
|
||||
for (i in 1:ninds) {
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ learn_simple_partition <- function(ordered_points, fii) {
|
|||
# One cluster:
|
||||
val <- calculatePopLogml(ordered_points, fii)
|
||||
bestValue <- val
|
||||
best_type <- 'single'
|
||||
best_type <- "single"
|
||||
|
||||
# Two clusters:
|
||||
for (i in 1:(npoints - 1)) {
|
||||
|
|
@ -20,7 +20,7 @@ learn_simple_partition <- function(ordered_points, fii) {
|
|||
total <- val_1 + val_2
|
||||
if (total > bestValue) {
|
||||
bestValue <- total
|
||||
best_type <- 'double'
|
||||
best_type <- "double"
|
||||
best_i <- i
|
||||
}
|
||||
}
|
||||
|
|
@ -34,24 +34,24 @@ learn_simple_partition <- function(ordered_points, fii) {
|
|||
total <- val_1 + val_2 + val_3
|
||||
if (total > bestValue) {
|
||||
bestValue <- total
|
||||
best_type <- 'triple'
|
||||
best_type <- "triple"
|
||||
best_i <- i
|
||||
best_j <- j
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
part = matrix(0, npoints, 1)
|
||||
part <- matrix(0, npoints, 1)
|
||||
|
||||
switch(best_type,
|
||||
'single' = {
|
||||
"single" = {
|
||||
part <- matrix(1, npoints, 1)
|
||||
},
|
||||
'double' = {
|
||||
"double" = {
|
||||
part[1:best_i] <- 1
|
||||
part[(best_i + 1):length(part)] <- 2
|
||||
},
|
||||
'triple' = {
|
||||
"triple" = {
|
||||
part[1:best_i] <- 1
|
||||
part[(best_i + 1):best_j] <- 2
|
||||
part[(best_j + 1):length(part)] <- 3
|
||||
|
|
|
|||
18
R/linkage.R
18
R/linkage.R
|
|
@ -10,15 +10,15 @@
|
|||
#' @param method either 'si', 'av', 'co' 'ce' or 'wa'
|
||||
#' @note This is also a base Matlab function. The reason why the source code is also present here is unclear.
|
||||
#' @export
|
||||
linkage <- function(Y, method = 'co') {
|
||||
linkage <- function(Y, method = "co") {
|
||||
# TODO: compare R output with MATLAB output
|
||||
k <- size(Y)[1]
|
||||
n <- size(Y)[2]
|
||||
m <- (1 + sqrt(1 + 8 * n)) / 2
|
||||
if ((k != 1) | (m != trunc(m))) {
|
||||
stop(
|
||||
'The first input has to match the output',
|
||||
'of the PDIST function in size.'
|
||||
"The first input has to match the output",
|
||||
"of the PDIST function in size."
|
||||
)
|
||||
}
|
||||
method <- tolower(substr(method, 1, 2)) # simplify the switch string.
|
||||
|
|
@ -26,7 +26,7 @@ linkage <- function(Y, method = 'co') {
|
|||
Z <- zeros(m - 1, 3) # allocate the output matrix.
|
||||
N <- zeros(1, 2 * m - 1)
|
||||
N[1:m] <- 1
|
||||
n <- m; # since m is changing, we need to save m in n.
|
||||
n <- m # since m is changing, we need to save m in n.
|
||||
R <- 1:n
|
||||
for (s in 1:(n - 1)) {
|
||||
X <- as.matrix(as.vector(Y), ncol = 1)
|
||||
|
|
@ -70,15 +70,15 @@ linkage <- function(Y, method = 'co') {
|
|||
# I <- I[I > 0 & I <= length(Y)]
|
||||
# J <- J[J > 0 & J <= length(Y)]
|
||||
switch(method,
|
||||
'si' = Y[I] <- apply(cbind(Y[I], Y[J]), 1, min), # single linkage
|
||||
'av' = Y[I] <- Y[I] + Y[J], # average linkage
|
||||
'co' = Y[I] <- apply(cbind(Y[I], Y[J]), 1, max), #complete linkage
|
||||
'ce' = {
|
||||
"si" = Y[I] <- apply(cbind(Y[I], Y[J]), 1, min), # single linkage
|
||||
"av" = Y[I] <- Y[I] + Y[J], # average linkage
|
||||
"co" = Y[I] <- apply(cbind(Y[I], Y[J]), 1, max), # complete linkage
|
||||
"ce" = {
|
||||
K <- N[R[i]] + N[R[j]] # centroid linkage
|
||||
Y[I] <- (N[R[i]] * Y[I] + N[R[j]] * Y[J] -
|
||||
(N[R[i]] * N[R[j]] * v^2) / K) / K
|
||||
},
|
||||
'wa' = Y[I] <- ((N[R[U]] + N[R[i]]) * Y[I] + (N[R[U]] + N[R[j]]) *
|
||||
"wa" = Y[I] <- ((N[R[U]] + N[R[i]]) * Y[I] + (N[R[U]] + N[R[j]]) *
|
||||
Y[J] - N[R[U]] * v) / (N[R[i]] + N[R[j]] + N[R[U]])
|
||||
)
|
||||
J <- c(J, i * (m - (i + 1) / 2) - m + j)
|
||||
|
|
|
|||
|
|
@ -11,7 +11,6 @@
|
|||
#' @examples
|
||||
#' msa <- system.file("ext", "seqs.fa", package = "rBAPS")
|
||||
#' snp.matrix <- load_fasta(msa)
|
||||
#'
|
||||
#' @author Gerry Tonkin-Hill, Waldir Leoncio
|
||||
#' @seealso rhierbaps::load_fasta
|
||||
#' @importFrom ape read.FASTA as.DNAbin
|
||||
|
|
|
|||
|
|
@ -5,28 +5,28 @@
|
|||
#' @export
|
||||
logml2String <- function(logml) {
|
||||
# Palauttaa logml:n string-esityksen.
|
||||
mjono = ' '
|
||||
mjono <- " "
|
||||
|
||||
if (logml == -Inf) {
|
||||
mjono[7] <- '-'
|
||||
mjono[7] <- "-"
|
||||
return(mjono)
|
||||
}
|
||||
|
||||
if (abs(logml) < 10000) {
|
||||
# Ei tarvita e-muotoa
|
||||
mjono[7] <- palautaYks(abs(logml), -1)
|
||||
mjono[6] <- '.'
|
||||
mjono[6] <- "."
|
||||
mjono[5] <- palautaYks(abs(logml), 0)
|
||||
mjono[4] <- palautaYks(abs(logml), 1)
|
||||
mjono[3] <- palautaYks(abs(logml), 2)
|
||||
mjono[2] <- palautaYks(abs(logml), 3)
|
||||
pointer <- 2
|
||||
while (mjono[pointer] == '0' & pointer < 7) {
|
||||
mjono[pointer] <- ' '
|
||||
while (mjono[pointer] == "0" & pointer < 7) {
|
||||
mjono[pointer] <- " "
|
||||
pointer <- pointer + 1
|
||||
}
|
||||
if (logml < 0) {
|
||||
mjono[pointer - 1] <- '-'
|
||||
mjono[pointer - 1] <- "-"
|
||||
}
|
||||
} else {
|
||||
suurinYks <- 4
|
||||
|
|
@ -35,21 +35,21 @@ logml2String <- function(logml) {
|
|||
}
|
||||
if (suurinYks < 10) {
|
||||
mjono[7] <- as.character(suurinYks)
|
||||
mjono[6] <- 'e'
|
||||
mjono[6] <- "e"
|
||||
mjono[5] <- palautaYks(abs(logml), suurinYks - 1)
|
||||
mjono[4] <- '.'
|
||||
mjono[4] <- "."
|
||||
mjono[3] <- palautaYks(abs(logml), suurinYks)
|
||||
if (logml < 0) {
|
||||
mjono[2] <- '-'
|
||||
mjono[2] <- "-"
|
||||
}
|
||||
} else if (suurinYks >= 10) {
|
||||
mjono[6:7] <- as.character(suurinYks)
|
||||
mjono[5] <- 'e'
|
||||
mjono[5] <- "e"
|
||||
mjono[4] <- palautaYks(abs(logml), suurinYks - 1)
|
||||
mjono[3] <- '.'
|
||||
mjono[3] <- "."
|
||||
mjono[2] <- palautaYks(abs(logml), suurinYks)
|
||||
if (logml < 0) {
|
||||
mjono[1] <- '-'
|
||||
mjono[1] <- "-"
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -13,8 +13,8 @@ lueNimi <- function(line) {
|
|||
# Palauttaa line:n alusta sen osan, joka on ennen pilkkua.
|
||||
n <- 1
|
||||
merkki <- substring(line, n, n)
|
||||
nimi <- ''
|
||||
while (merkki != ',') {
|
||||
nimi <- ""
|
||||
while (merkki != ",") {
|
||||
nimi <- c(nimi, merkki)
|
||||
n <- n + 1
|
||||
merkki <- substring(line, n, n)
|
||||
|
|
|
|||
|
|
@ -19,10 +19,8 @@
|
|||
#' It is also advised to do a dry-run with `output = "clean"` and only switching
|
||||
#' to `output = "save"` when you are confident that no important code will be
|
||||
#' lost (for shorter functions, a careful visual inspection should suffice).
|
||||
matlab2r <- function(
|
||||
filename, output = "diff", improve_formatting=TRUE, change_assignment=TRUE,
|
||||
append=FALSE
|
||||
) {
|
||||
matlab2r <- function(filename, output = "diff", improve_formatting = TRUE, change_assignment = TRUE,
|
||||
append = FALSE) {
|
||||
# TODO: this function is too long! Split into subfunctions
|
||||
# (say, by rule and/or section)
|
||||
# ======================================================== #
|
||||
|
|
|
|||
|
|
@ -12,9 +12,9 @@ ownNum2Str <- function(number) {
|
|||
next_four <- (number - first_three) / 1000
|
||||
first_three <- abs(first_three)
|
||||
if (first_three < 10) {
|
||||
first_three <- paste0('00', as.character(first_three))
|
||||
first_three <- paste0("00", as.character(first_three))
|
||||
} else if (first_three < 100) {
|
||||
first_three <- paste0('0', as.character(first_three))
|
||||
first_three <- paste0("0", as.character(first_three))
|
||||
} else {
|
||||
first_three <- as.character(first_three)
|
||||
}
|
||||
|
|
@ -24,11 +24,11 @@ ownNum2Str <- function(number) {
|
|||
next_four <- (number - first_four) / 10000
|
||||
first_four <- abs(first_four)
|
||||
if (first_four < 10) {
|
||||
first_four <- paste0('000', as.character(first_four))
|
||||
first_four <- paste0("000", as.character(first_four))
|
||||
} else if (first_four < 100) {
|
||||
first_four <- paste0('00', as.character(first_four))
|
||||
first_four <- paste0("00", as.character(first_four))
|
||||
} else if (first_four < 1000) {
|
||||
first_four <- paste0('0', as.character(first_four))
|
||||
first_four <- paste0("0", as.character(first_four))
|
||||
} else {
|
||||
first_four <- as.character(first_four)
|
||||
}
|
||||
|
|
|
|||
|
|
@ -22,9 +22,9 @@ poistaLiianPienet <- function (npops, rowsFromInd, alaraja) {
|
|||
outliers <- matrix(NA, 0, 0)
|
||||
for (pop in miniPops) {
|
||||
inds <- which(PARTITION == pop)
|
||||
cat('Removed individuals: ')
|
||||
cat("Removed individuals: ")
|
||||
cat(as.character(inds))
|
||||
outliers = matrix(c(outliers, inds), ncol=1)
|
||||
outliers <- matrix(c(outliers, inds), ncol = 1)
|
||||
}
|
||||
|
||||
ninds <- length(PARTITION)
|
||||
|
|
|
|||
|
|
@ -6,15 +6,15 @@
|
|||
#' @export
|
||||
proportion2str <- function(prob) {
|
||||
if (abs(prob) < 1e-3) {
|
||||
str <- '0.00'
|
||||
str <- "0.00"
|
||||
} else if (abs(prob - 1) < 1e-3) {
|
||||
str <- '1.00'
|
||||
str <- "1.00"
|
||||
} else {
|
||||
prob <- round(100 * prob)
|
||||
if (prob < 10) {
|
||||
str <- paste0('0.0', as.character(prob))
|
||||
str <- paste0("0.0", as.character(prob))
|
||||
} else {
|
||||
str <- paste0('0.', as.character(prob))
|
||||
str <- paste0("0.", as.character(prob))
|
||||
}
|
||||
}
|
||||
return(str)
|
||||
|
|
|
|||
12
R/questdlg.R
12
R/questdlg.R
|
|
@ -7,13 +7,11 @@
|
|||
#' @description This function aims to loosely mimic the behavior of the
|
||||
#' questdlg function on Matlab
|
||||
#' @export
|
||||
questdlg <- function(
|
||||
quest,
|
||||
questdlg <- function(quest,
|
||||
dlgtitle = "",
|
||||
btn = c('y', 'n'),
|
||||
defbtn = 'n',
|
||||
accepted_ans = c('y', 'yes', 'n', 'no')
|
||||
) {
|
||||
btn = c("y", "n"),
|
||||
defbtn = "n",
|
||||
accepted_ans = c("y", "yes", "n", "no")) {
|
||||
message(dlgtitle)
|
||||
# ==========================================================================
|
||||
# Replacing the default option with a capitalized version on btn
|
||||
|
|
@ -22,7 +20,7 @@ questdlg <- function(
|
|||
# ==========================================================================
|
||||
# Creating prompt
|
||||
# ==========================================================================
|
||||
option_char <- paste0(' [', paste(btn, collapse = ', '), ']')
|
||||
option_char <- paste0(" [", paste(btn, collapse = ", "), "]")
|
||||
answer <- readline(paste0(quest, option_char, ": "))
|
||||
# ==========================================================================
|
||||
# Processing answer
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@
|
|||
randdir <- function(counts, nc) {
|
||||
svar <- zeros(nc, 1)
|
||||
for (i in 1:nc) {
|
||||
svar[i, 1] = randga(counts[i, 1], 1)
|
||||
svar[i, 1] <- randga(counts[i, 1], 1)
|
||||
}
|
||||
svar <- svar / sum(svar)
|
||||
return(svar)
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ selvitaDigitFormat <- function(line) {
|
|||
# 2 vai 3 numeron avulla.
|
||||
n <- 1
|
||||
merkki <- substring(line, n, n)
|
||||
while (merkki != ',') {
|
||||
while (merkki != ",") {
|
||||
n <- n + 1
|
||||
merkki <- substring(line, n, n)
|
||||
}
|
||||
|
|
|
|||
|
|
@ -17,28 +17,28 @@ testaaGenePopData <- function(tiedostonNimi) {
|
|||
}
|
||||
|
||||
if (line1 == -1 | line2 == -1 | line3 == -1) {
|
||||
stop('Incorrect file format 1168')
|
||||
stop("Incorrect file format 1168")
|
||||
}
|
||||
if (testaaPop(line1) == 1 | testaaPop(line2) == 1) {
|
||||
stop('Incorrect file format 1172')
|
||||
stop("Incorrect file format 1172")
|
||||
}
|
||||
if (testaaPop(line3) == 1) {
|
||||
# 2 rivi t<>ll<6C>in lokusrivi (2 rows then locus row)
|
||||
nloci <- rivinSisaltamienMjonojenLkm(line2)
|
||||
line4 <- fid[4]
|
||||
if (line4 == -1) stop('Incorrect file format 1180')
|
||||
if (!grepl(',', line4)) {
|
||||
if (line4 == -1) stop("Incorrect file format 1180")
|
||||
if (!grepl(",", line4)) {
|
||||
# Rivin nelj?t<>ytyy sis<69>lt<6C><74> pilkku.
|
||||
stop('Incorrect file format 1185')
|
||||
stop("Incorrect file format 1185")
|
||||
}
|
||||
pointer <- 1
|
||||
while (substring(line4, pointer, pointer) != ',') {
|
||||
while (substring(line4, pointer, pointer) != ",") {
|
||||
# Tiedet<65><74>n, ett?pys<79>htyy
|
||||
pointer <- pointer + 1
|
||||
}
|
||||
line4 <- substring(line4, pointer + 1) # pilkun j<>lkeinen osa (the part after the comma)
|
||||
nloci2 <- rivinSisaltamienMjonojenLkm(line4)
|
||||
if (nloci2 != nloci) stop('Incorrect file format 1195')
|
||||
if (nloci2 != nloci) stop("Incorrect file format 1195")
|
||||
} else {
|
||||
line <- fid[4]
|
||||
lineNumb <- 4
|
||||
|
|
@ -46,22 +46,22 @@ testaaGenePopData <- function(tiedostonNimi) {
|
|||
line <- fid[lineNumb + 1]
|
||||
lineNumb <- lineNumb + 1
|
||||
}
|
||||
if (line == -1) stop('Incorrect file format 1206')
|
||||
if (line == -1) stop("Incorrect file format 1206")
|
||||
nloci <- lineNumb - 2
|
||||
line4 <- fid[lineNumb + 1] # Eka rivi pop sanan j<>lkeen
|
||||
if (line4 == -1) stop('Incorrect file format 1212')
|
||||
if (!grepl(',', line4)) {
|
||||
if (line4 == -1) stop("Incorrect file format 1212")
|
||||
if (!grepl(",", line4)) {
|
||||
# Rivin t<>ytyy sis<69>lt<6C><74> pilkku. (The line must contain a comma)
|
||||
stop('Incorrect file format 1217')
|
||||
stop("Incorrect file format 1217")
|
||||
}
|
||||
pointer <- 1
|
||||
while (substring(line4, pointer, pointer) != ',') {
|
||||
while (substring(line4, pointer, pointer) != ",") {
|
||||
# Tiedet<65><74>n, ett?pys<79>htyy
|
||||
pointer <- pointer + 1
|
||||
}
|
||||
line4 <- substring(line4, pointer + 1) # pilkun j<>lkeinen osa (the part after the comma)
|
||||
nloci2 <- rivinSisaltamienMjonojenLkm(line4)
|
||||
if (nloci2 != nloci) stop('Incorrect file format 1228')
|
||||
if (nloci2 != nloci) stop("Incorrect file format 1228")
|
||||
}
|
||||
kunnossa <- 1
|
||||
return(kunnossa)
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ testaaPop <- function(rivi) {
|
|||
pal <- 0
|
||||
} else {
|
||||
rivi_start <- substring(rivi, 1, 3)
|
||||
pal <- ifelse(rivi_start %in% c('Pop', 'pop', 'POP'), 1, 0)
|
||||
pal <- ifelse(rivi_start %in% c("Pop", "pop", "POP"), 1, 0)
|
||||
}
|
||||
return(pal)
|
||||
}
|
||||
|
|
@ -9,8 +9,8 @@ uiputfile <- function(filter = ".rda", title = "Save file") {
|
|||
# Processing input
|
||||
# ==========================================================================
|
||||
message(title)
|
||||
filename <- readline(paste0('File name (end with ', filter, '): '))
|
||||
filepath <- readline(paste0('File path (leave empty for ', getwd(), '): '))
|
||||
filename <- readline(paste0("File name (end with ", filter, "): "))
|
||||
filepath <- readline(paste0("File path (leave empty for ", getwd(), "): "))
|
||||
if (filename == "") filename <- 0
|
||||
if (filepath == "") filepath <- getwd()
|
||||
# ==========================================================================
|
||||
|
|
|
|||
|
|
@ -38,9 +38,7 @@ updateGlobalVariables2 <- function(i1, i2, diffInCounts, adjprior, priorTerm) {
|
|||
LOGDIFF[inx, ] <- -Inf
|
||||
}
|
||||
|
||||
updateGlobalVariables3 <- function(
|
||||
muuttuvat, diffInCounts, adjprior, priorTerm, i2
|
||||
) {
|
||||
updateGlobalVariables3 <- function(muuttuvat, diffInCounts, adjprior, priorTerm, i2) {
|
||||
# % Suorittaa globaalien muuttujien p<>ivitykset, kun yksil<69>t 'muuttuvat'
|
||||
# % siirret<65><74>n koriin i2. Ennen siirtoa yksil<69>iden on kuuluttava samaan
|
||||
# % koriin.
|
||||
|
|
|
|||
|
|
@ -1,5 +1,4 @@
|
|||
viewPartition <- function(osuudet, popnames) {
|
||||
|
||||
npops <- size(COUNTS, 3)
|
||||
nind <- size(osuudet, 1)
|
||||
|
||||
|
|
@ -79,17 +78,17 @@ viewPartition <- function(osuudet, popnames) {
|
|||
}
|
||||
|
||||
korjaus <- function(letter) {
|
||||
if (any(letter %in% c('i', 'j', 'l', 'I'))) {
|
||||
if (any(letter %in% c("i", "j", "l", "I"))) {
|
||||
extra <- 0.022
|
||||
} else if (any(letter == 'r')) {
|
||||
} else if (any(letter == "r")) {
|
||||
extra <- 0.016
|
||||
} else if (any(letter == 'k')) {
|
||||
} else if (any(letter == "k")) {
|
||||
extra <- 0.009
|
||||
} else if (any(letter == 'f')) {
|
||||
} else if (any(letter == "f")) {
|
||||
extra <- 0.013
|
||||
} else if (any(letter == 't')) {
|
||||
} else if (any(letter == "t")) {
|
||||
extra <- 0.014
|
||||
} else if (any(letter == 'w')) {
|
||||
} else if (any(letter == "w")) {
|
||||
extra <- -0.003
|
||||
} else {
|
||||
extra <- 0
|
||||
|
|
@ -98,7 +97,7 @@ korjaus <- function(letter) {
|
|||
}
|
||||
|
||||
giveColors <- function(n) {
|
||||
if (n > 36) stop('Maximum number of colors 36')
|
||||
if (n > 36) stop("Maximum number of colors 36")
|
||||
colors <- matrix(
|
||||
data = c(
|
||||
1, 0, 0, 0, 1, 0, 0, 0, 1, 1, 1, 0, 1, 0, 1, 0, 1, 1,
|
||||
|
|
@ -114,7 +113,7 @@ giveColors <- function(n) {
|
|||
ncol = 3,
|
||||
byrow = TRUE
|
||||
)
|
||||
colors = colors[1:n, ]
|
||||
colors <- colors[1:n, ]
|
||||
# red; green; blue; yellow
|
||||
# RGB format: [red green blue]
|
||||
return(colors)
|
||||
|
|
|
|||
|
|
@ -11,9 +11,7 @@
|
|||
#' @param popnames popnames
|
||||
#' @param fixedK fixedK
|
||||
#' @export
|
||||
writeMixtureInfo <- function(
|
||||
logml, rowsFromInd, data, adjprior, priorTerm, outPutFile, inputFile, partitionSummary, popnames, fixedK
|
||||
) {
|
||||
writeMixtureInfo <- function(logml, rowsFromInd, data, adjprior, priorTerm, outPutFile, inputFile, partitionSummary, popnames, fixedK) {
|
||||
changesInLogml <- list()
|
||||
ninds <- size(data, 1) / rowsFromInd
|
||||
npops <- size(COUNTS, 3)
|
||||
|
|
@ -25,45 +23,45 @@ writeMixtureInfo <- function(
|
|||
} else {
|
||||
fid <- -1
|
||||
# TODO: replace sink with option that will record input and output
|
||||
sink('baps4_output.baps', split=TRUE) # save in text anyway.
|
||||
sink("baps4_output.baps", split = TRUE) # save in text anyway.
|
||||
}
|
||||
|
||||
dispLine()
|
||||
cat('RESULTS OF INDIVIDUAL LEVEL MIXTURE ANALYSIS:')
|
||||
cat(c('Data file: ', inputFile))
|
||||
cat('Model: independent')
|
||||
cat(c('Number of clustered individuals: ', ownNum2Str(ninds)))
|
||||
cat(c('Number of groups in optimal partition: ', ownNum2Str(npops)))
|
||||
cat(c('Log(marginal likelihood) of optimal partition: ', ownNum2Str(logml)))
|
||||
cat(' ')
|
||||
cat("RESULTS OF INDIVIDUAL LEVEL MIXTURE ANALYSIS:")
|
||||
cat(c("Data file: ", inputFile))
|
||||
cat("Model: independent")
|
||||
cat(c("Number of clustered individuals: ", ownNum2Str(ninds)))
|
||||
cat(c("Number of groups in optimal partition: ", ownNum2Str(npops)))
|
||||
cat(c("Log(marginal likelihood) of optimal partition: ", ownNum2Str(logml)))
|
||||
cat(" ")
|
||||
if (fid != -1) {
|
||||
append(fid, 'RESULTS OF INDIVIDUAL LEVEL MIXTURE ANALYSIS:\n')
|
||||
append(fid, c('Data file: ', inputFile, '\n'))
|
||||
append(fid, "RESULTS OF INDIVIDUAL LEVEL MIXTURE ANALYSIS:\n")
|
||||
append(fid, c("Data file: ", inputFile, "\n"))
|
||||
append(
|
||||
fid,
|
||||
c('Number of clustered individuals: ', ownNum2Str(ninds), '\n')
|
||||
c("Number of clustered individuals: ", ownNum2Str(ninds), "\n")
|
||||
)
|
||||
append(
|
||||
fid,
|
||||
c(
|
||||
'Number of groups in optimal partition: ',
|
||||
ownNum2Str(npops), '\n'
|
||||
"Number of groups in optimal partition: ",
|
||||
ownNum2Str(npops), "\n"
|
||||
)
|
||||
)
|
||||
append(
|
||||
fid,
|
||||
c(
|
||||
'Log(marginal likelihood) of optimal partition: ',
|
||||
"Log(marginal likelihood) of optimal partition: ",
|
||||
ownNum2Str(logml),
|
||||
'\n'
|
||||
"\n"
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
cluster_count <- length(unique(PARTITION))
|
||||
cat('Best Partition: ')
|
||||
cat("Best Partition: ")
|
||||
if (fid != -1) {
|
||||
append(fid, c('Best Partition: ', '\n'))
|
||||
append(fid, c("Best Partition: ", "\n"))
|
||||
}
|
||||
for (m in 1:cluster_count) {
|
||||
indsInM <- find(PARTITION == m)
|
||||
|
|
@ -72,23 +70,23 @@ writeMixtureInfo <- function(
|
|||
|
||||
if (names) {
|
||||
text <- c(
|
||||
'Cluster ',
|
||||
"Cluster ",
|
||||
as.character(m),
|
||||
': {',
|
||||
": {",
|
||||
as.character(popnames[[indsInM[1]]])
|
||||
)
|
||||
for (k in 2:cluster_size) {
|
||||
text <- c(text, ', ', as.character(popnames[[indsInM[k]]]))
|
||||
text <- c(text, ", ", as.character(popnames[[indsInM[k]]]))
|
||||
}
|
||||
} else {
|
||||
text <- c(
|
||||
'Cluster ', as.character(m), ': {', as.character(indsInM[1])
|
||||
"Cluster ", as.character(m), ": {", as.character(indsInM[1])
|
||||
)
|
||||
for (k in 2:cluster_size) {
|
||||
text <- c(text, ', ', as.character(indsInM[k]))
|
||||
text <- c(text, ", ", as.character(indsInM[k]))
|
||||
}
|
||||
}
|
||||
text <- c(text, '}')
|
||||
text <- c(text, "}")
|
||||
while (length(text) > 58) {
|
||||
# Take one line and display it.
|
||||
new_line <- takeLine(text, 58)
|
||||
|
|
@ -96,7 +94,7 @@ writeMixtureInfo <- function(
|
|||
cat(new_line)
|
||||
if (fid != -1) {
|
||||
append(fid, new_line)
|
||||
append(fid,'\n')
|
||||
append(fid, "\n")
|
||||
}
|
||||
if (length(text) > 0) {
|
||||
text <- c(blanks(length_of_beginning), text)
|
||||
|
|
@ -108,31 +106,31 @@ writeMixtureInfo <- function(
|
|||
cat(text)
|
||||
if (fid != -1) {
|
||||
append(fid, text)
|
||||
append(fid,'\n')
|
||||
append(fid, "\n")
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if (npops > 1) {
|
||||
cat(' ')
|
||||
cat(' ')
|
||||
cat(" ")
|
||||
cat(" ")
|
||||
cat(
|
||||
'Changes in log(marginal likelihood)',
|
||||
' if indvidual i is moved to group j:'
|
||||
"Changes in log(marginal likelihood)",
|
||||
" if indvidual i is moved to group j:"
|
||||
)
|
||||
if (fid != -1) {
|
||||
append(fid, ' ')
|
||||
append(fid, '\n')
|
||||
append(fid, ' ')
|
||||
append(fid, '\n')
|
||||
append(fid, " ")
|
||||
append(fid, "\n")
|
||||
append(fid, " ")
|
||||
append(fid, "\n")
|
||||
append(
|
||||
fid,
|
||||
c(
|
||||
'Changes in log(marginal likelihood)',
|
||||
'if indvidual i is moved to group j:'
|
||||
"Changes in log(marginal likelihood)",
|
||||
"if indvidual i is moved to group j:"
|
||||
)
|
||||
)
|
||||
append(fid, '\n')
|
||||
append(fid, "\n")
|
||||
}
|
||||
|
||||
if (names) {
|
||||
|
|
@ -145,9 +143,9 @@ writeMixtureInfo <- function(
|
|||
maxSize <- max(maxSize, 5)
|
||||
erotus <- maxSize - 5
|
||||
alku <- blanks(erotus)
|
||||
ekarivi <- c(alku, ' ind', blanks(6 + erotus))
|
||||
ekarivi <- c(alku, " ind", blanks(6 + erotus))
|
||||
} else {
|
||||
ekarivi <- ' ind '
|
||||
ekarivi <- " ind "
|
||||
}
|
||||
for (i in 1:cluster_count) {
|
||||
ekarivi <- c(ekarivi, ownNum2Str(i), blanks(8 - floor(log10(i))))
|
||||
|
|
@ -155,7 +153,7 @@ writeMixtureInfo <- function(
|
|||
cat(ekarivi)
|
||||
if (fid != -1) {
|
||||
append(fid, ekarivi)
|
||||
append(fid, '\n')
|
||||
append(fid, "\n")
|
||||
}
|
||||
|
||||
# %ninds = size(data,1)/rowsFromInd;
|
||||
|
|
@ -165,30 +163,30 @@ writeMixtureInfo <- function(
|
|||
|
||||
if (names) {
|
||||
nimi <- as.character(popnames[ind])
|
||||
rivi <- c(blanks(maxSize - length(nimi)), nimi, ':')
|
||||
rivi <- c(blanks(maxSize - length(nimi)), nimi, ":")
|
||||
} else {
|
||||
rivi <- c(blanks(4 - floor(log10(ind))), ownNum2Str(ind), ':')
|
||||
rivi <- c(blanks(4 - floor(log10(ind))), ownNum2Str(ind), ":")
|
||||
}
|
||||
for (j in 1:npops) {
|
||||
rivi <- c(rivi, ' ', logml2String(omaRound(muutokset[j])))
|
||||
rivi <- c(rivi, " ", logml2String(omaRound(muutokset[j])))
|
||||
}
|
||||
cat(rivi)
|
||||
if (fid != -1) {
|
||||
append(fid, rivi)
|
||||
append(fid, '\n')
|
||||
append(fid, "\n")
|
||||
}
|
||||
}
|
||||
|
||||
cat(' ')
|
||||
cat(' ')
|
||||
cat('KL-divergence matrix in PHYLIP format:')
|
||||
cat(" ")
|
||||
cat(" ")
|
||||
cat("KL-divergence matrix in PHYLIP format:")
|
||||
|
||||
dist_mat <- zeros(npops, npops)
|
||||
if (fid != -1) {
|
||||
append(fid, ' ')
|
||||
append(fid, ' ')
|
||||
append(fid, c('KL-divergence matrix in PHYLIP format:'))
|
||||
append(fid, '\n')
|
||||
append(fid, " ")
|
||||
append(fid, " ")
|
||||
append(fid, c("KL-divergence matrix in PHYLIP format:"))
|
||||
append(fid, "\n")
|
||||
}
|
||||
|
||||
maxnoalle <- size(COUNTS, 1)
|
||||
|
|
@ -206,7 +204,7 @@ writeMixtureInfo <- function(
|
|||
cat(ekarivi)
|
||||
if (fid != -1) {
|
||||
append(fid, ekarivi)
|
||||
append(fid, '\n')
|
||||
append(fid, "\n")
|
||||
}
|
||||
|
||||
for (pop1 in 1:npops) {
|
||||
|
|
@ -227,38 +225,38 @@ writeMixtureInfo <- function(
|
|||
|
||||
dist_mat <- dist_mat + t(dist_mat) # make it symmetric
|
||||
for (pop1 in 1:npops) {
|
||||
rivi <- c('Cluster_', as.character(pop1), ' ')
|
||||
rivi <- c("Cluster_", as.character(pop1), " ")
|
||||
for (pop2 in 1:npops) {
|
||||
rivi <- c(rivi, kldiv2str(dist_mat[pop1, pop2]), ' ')
|
||||
rivi <- c(rivi, kldiv2str(dist_mat[pop1, pop2]), " ")
|
||||
}
|
||||
cat(rivi)
|
||||
if (fid != -1) {
|
||||
append(fid, rivi)
|
||||
append(fid, '\n')
|
||||
append(fid, "\n")
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
cat(' ')
|
||||
cat(' ');
|
||||
cat(" ")
|
||||
cat(" ")
|
||||
cat(
|
||||
'List of sizes of 10 best visited partitions',
|
||||
'and corresponding log(ml) values'
|
||||
"List of sizes of 10 best visited partitions",
|
||||
"and corresponding log(ml) values"
|
||||
)
|
||||
|
||||
if (fid != -1) {
|
||||
append(fid, ' ')
|
||||
append(fid, '\n')
|
||||
append(fid, ' ')
|
||||
append(fid, '\n')
|
||||
append(fid, " ")
|
||||
append(fid, "\n")
|
||||
append(fid, " ")
|
||||
append(fid, "\n")
|
||||
append(
|
||||
fid,
|
||||
c(
|
||||
'List of sizes of 10 best visited partitions',
|
||||
'and corresponding log(ml) values'
|
||||
"List of sizes of 10 best visited partitions",
|
||||
"and corresponding log(ml) values"
|
||||
)
|
||||
)
|
||||
append(fid, '\n')
|
||||
append(fid, "\n")
|
||||
}
|
||||
|
||||
partitionSummary <- sortrows(partitionSummary, 2)
|
||||
|
|
@ -272,28 +270,28 @@ writeMixtureInfo <- function(
|
|||
for (part in 1:vikaPartitio) {
|
||||
line <- c(
|
||||
as.character(partitionSummary[part, 1]),
|
||||
' ',
|
||||
" ",
|
||||
as.character(partitionSummary(part, 2))
|
||||
)
|
||||
cat(line)
|
||||
if (fid != -1) {
|
||||
append(fid, line)
|
||||
append(fid, '\n')
|
||||
append(fid, "\n")
|
||||
}
|
||||
}
|
||||
|
||||
if (!fixedK) {
|
||||
cat(' ')
|
||||
cat(' ')
|
||||
cat('Probabilities for number of clusters')
|
||||
cat(" ")
|
||||
cat(" ")
|
||||
cat("Probabilities for number of clusters")
|
||||
|
||||
if (fid != -1) {
|
||||
append(fid, ' ')
|
||||
append(fid, '\n')
|
||||
append(fid, ' ')
|
||||
append(fid, '\n')
|
||||
append(fid, c('Probabilities for number of clusters'))
|
||||
append(fid, '\n')
|
||||
append(fid, " ")
|
||||
append(fid, "\n")
|
||||
append(fid, " ")
|
||||
append(fid, "\n")
|
||||
append(fid, c("Probabilities for number of clusters"))
|
||||
append(fid, "\n")
|
||||
}
|
||||
|
||||
npopsTaulu <- unique(partitionSummary[, 1])
|
||||
|
|
@ -315,12 +313,12 @@ writeMixtureInfo <- function(
|
|||
for (i in 1:len) {
|
||||
if (probs[i] > 1e-5) {
|
||||
line <- c(
|
||||
as.character(npopsTaulu[i]), ' ', as.character(probs[i])
|
||||
as.character(npopsTaulu[i]), " ", as.character(probs[i])
|
||||
)
|
||||
cat(line)
|
||||
if (fid != -1) {
|
||||
append(fid, line)
|
||||
append(fid, '\n')
|
||||
append(fid, "\n")
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -21,7 +21,6 @@ running the hierBAPS algorithm.
|
|||
\examples{
|
||||
msa <- system.file("ext", "seqs.fa", package = "rBAPS")
|
||||
snp.matrix <- load_fasta(msa)
|
||||
|
||||
}
|
||||
\seealso{
|
||||
rhierbaps::load_fasta
|
||||
|
|
|
|||
|
|
@ -118,14 +118,14 @@ test_that("isfield works as on Matlab", {
|
|||
})
|
||||
|
||||
test_that("strcmp works as expected", {
|
||||
yes <- 'Yes'
|
||||
no <- 'No'
|
||||
ja <- 'Yes'
|
||||
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')
|
||||
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))
|
||||
|
|
@ -197,8 +197,8 @@ test_that("fix works as expected", {
|
|||
})
|
||||
|
||||
test_that("isspace works as expected", {
|
||||
chr <- '123 Main St.'
|
||||
X <- '\t a b\tcde f'
|
||||
chr <- "123 Main St."
|
||||
X <- "\t a b\tcde f"
|
||||
expect_identical(isspace(chr), c(0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0))
|
||||
expect_identical(isspace(X), c(1, 1, 0, 1, 0, 1, 0, 0, 0, 1, 0))
|
||||
})
|
||||
|
|
@ -236,7 +236,7 @@ test_that("setdiff works as expected", {
|
|||
)
|
||||
C <- data.frame(
|
||||
Var1 = c(2, 4),
|
||||
Var2 = c('B', 'D'),
|
||||
Var2 = c("B", "D"),
|
||||
Var3 = c(TRUE, TRUE)
|
||||
)
|
||||
row.names(C) <- c(2L, 4L)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue