max/ourMELONS
1
0
Fork 0
Code Issues 1 Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'testaaOnkoKunnollinenBapsData' into dev

Browse source
This commit is contained in:
Waldir Leoncio 2020-06-24 11:15:12 +02:00
commit 8e93e6305e
13 changed files with 693 additions and 464 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
NAMESPACE
View file

@ -8,6 +8,7 @@ export(computeIndLogml)
export(computePersonalAllFreqs)
export(computeRows)
export(etsiParas)
export(greedyMix)
export(inputdlg)
export(isfield)
export(laskeMuutokset4)
@ -16,6 +17,7 @@ export(noIndex)
export(ownNum2Str)
export(poistaLiianPienet)
export(proportion2str)
export(questdlg)
export(rand)
export(randdir)
export(repmat)
@ -27,5 +29,6 @@ export(strcmp)
export(suoritaMuutos)
export(times)
export(uigetfile)
export(uiputfile)
importFrom(methods,is)
importFrom(stats,runif)

660
R/greedyMix.R
View file

@ -1,268 +1,356 @@
# function greedyMix(tietue)
#' @title Clustering of individuals
#' @param tietue Record
#' @param format Format of the data ("BAPS", "GenePop" or "Preprocessed")
#' @param savePreProcessed Save the pre-processed data?
#' @export
greedyMix <- function(
tietue,
format = NULL,
savePreProcessed = NULL,
filePreProcessed = NULL
) {
# ASK: graphical components. Remove?
# check whether fixed k mode is selected
# h0 <- findobj('Tag','fixk_menu')
# fixedK = get(h0, 'userdata');
# % check whether fixed k mode is selected
# h0 = findobj('Tag','fixk_menu');
# fixedK = get(h0, 'userdata');
# if fixedK
# if ~(fixKWarning == 1) % call function fixKWarning
# return
# end
# end
# if fixedK
# if ~(fixKWarning == 1) % call function fixKWarning
# return
# end
# end
# % check whether partition compare mode is selected
# h1 = findobj('Tag','partitioncompare_menu');
# partitionCompare = get(h1, 'userdata');
# % check whether partition compare mode is selected
# h1 = findobj('Tag','partitioncompare_menu');
# partitionCompare = get(h1, 'userdata');
if (is(tietue, "list") | is(tietue, "character")) {
# ----------------------------------------------------------------------
# Defining type of file
# ----------------------------------------------------------------------
if (is.null(format)) {
input_type <- inputdlg(
paste(
'Specify the format of your data:\n',
'1) BAPS-format\n',
'2) GenePop-format\n',
'3) Preprocessed data\n'
)
)
# Converting from number into name
input_type_name <- switch(
input_type, 'BAPS-format', 'GenePop-format', 'Preprocessed data'
)
} else {
input_type_name <- paste0(format, "-format")
}
# ----------------------------------------------------------------------
# Treating BAPS-formatted files
# ----------------------------------------------------------------------
if (length(input_type_name) == 0) {
stop('Invalid alternative')
} else if (input_type_name == 'BAPS-format') {
if (!is(tietue, "character")) {
pathname_filename <- uigetfile("*.txt", "Loaddata in BAPS-format")
} else {
pathname_filename <- tietue
}
# ASK: remove?
# if ~isempty(partitionCompare)
# fprintf(1,'Data: %s\n',[pathname filename]);
# end
# if isequal(tietue,-1)
data <- read.delim(pathname_filename) # ASK: what is the delimiter?
# ninds <- testaaOnkoKunnollinenBapsData(data) #TESTAUS # TODO: trans
# if (ninds == 0) stop('Incorrect Data-file')
# input_type = questdlg('Specify the format of your data: ',...
# 'Specify Data Format', ...
# 'BAPS-format', 'GenePop-format', 'Preprocessed data', ...
# 'BAPS-format');
# ASK: remove?
# h0 = findobj('Tag','filename1_text');
# set(h0,'String',filename); clear h0;
cat(
'When using data which are in BAPS-format,',
'you can specify the sampling populations of the',
'individuals by giving two additional files:',
'one containing the names of the populations,',
'the other containing the indices of the first',
'individuals of the populations.'
)
input_pops <- inputdlg(
prompt = 'Do you wish to specify the sampling populations? [y/N]',
definput = 'N'
)
if (tolower(input_pops) %in% c('yes', 'y')) {
popfile <- uigetfile('*.txt', 'Load population names')
kysyToinen <- ifelse(popfile$name == 0, 0, 1)
if (kysyToinen == 1) {
indicesfile <- uigetfile('*.txt', 'Load population indices')
if (indicesfile == 0) {
popnames = ""
} else {
# popnames = initPopNames([namepath namefile],[indicespath indicesfile]) # TODO: translate this fun
}
} else {
popnames <- ""
}
} else {
popnames <- ""
}
# switch input_type
# [data, rowsFromInd, alleleCodes, noalle, adjprior, priorTerm] = handleData(data); # TODO: translate this function
# [Z,dist] = newGetDistances(data,rowsFromInd); # TODO: translate
if (is.null(savePreProcessed)) {
save_preproc <- questdlg(
quest = 'Do you wish to save pre-processed data?',
dlgtitle = 'Save pre-processed data?',
defbtn = 'y'
)
} else {
save_preproc <- savePreProcessed
}
if (save_preproc %in% c('y', 'yes', TRUE)) {
file_out <- uiputfile('.rda','Save pre-processed data as')
kokonimi <- paste0(file_out$path, file_out$name)
c <- list()
c$data <- data
c$rowsFromInd <- rowsFromInd
c$alleleCodes <- alleleCodes
c$noalle <- noalle
c$adjprior <- adjprior
c$priorTerm <- priorTerm
c$dist <- dist
c$popnames <- popnames
c$Z <- Z
save(c, file = kokonimi)
rm(c)
}
# ----------------------------------------------------------------------
# Treating GenePop-formatted files
# ----------------------------------------------------------------------
} else if (input_type_name == 'GenePop-format') {
if (!is(tietue, "character")) {
filename_pathname <- uigetfile(
filter = '*.txt',
title = 'Load data in GenePop-format'
)
if (filename_pathname$name == 0) stop("No name provided")
} else {
filename_pathname <- tietue
}
# case 'BAPS-format'
# waitALittle;
# [filename, pathname] = uigetfile('*.txt', 'Load data in BAPS-format');
# if filename==0
# return;
# end
# ASK: remove?
# if ~isempty(partitionCompare)
# fprintf(1,'Data: %s\n',[pathname filename]);
# end
# if ~isempty(partitionCompare)
# fprintf(1,'Data: %s\n',[pathname filename]);
# end
# kunnossa = testaaGenePopData([pathname filename]); # TODO: trans
# if (kunnossa == 0) stop("testaaGenePopData returned 0")
# [data,popnames]=lueGenePopData([pathname filename]); # TODO: trans
# data = load([pathname filename]);
# ninds = testaaOnkoKunnollinenBapsData(data); %TESTAUS
# if (ninds==0)
# disp('Incorrect Data-file.');
# return;
# end
# h0 = findobj('Tag','filename1_text');
# set(h0,'String',filename); clear h0;
# h0 = findobj('Tag','filename1_text');
# set(h0,'String',filename); clear h0;
# input_pops = questdlg(['When using data which are in BAPS-format, '...
# 'you can specify the sampling populations of the individuals by '...
# 'giving two additional files: one containing the names of the '...
# 'populations, the other containing the indices of the first '...
# 'individuals of the populations. Do you wish to specify the '...
# 'sampling populations?'], ...
# 'Specify sampling populations?',...
# 'Yes', 'No', 'No');
# if isequal(input_pops,'Yes')
# waitALittle;
# [namefile, namepath] = uigetfile('*.txt', 'Load population names');
# if namefile==0
# kysyToinen = 0;
# else
# kysyToinen = 1;
# end
# if kysyToinen==1
# waitALittle;
# [indicesfile, indicespath] = uigetfile('*.txt', 'Load population indices');
# if indicesfile==0
# popnames = [];
# else
# popnames = initPopNames([namepath namefile],[indicespath indicesfile]);
# end
# else
# popnames = [];
# end
# else
# popnames = [];
# end
# [data, rowsFromInd, alleleCodes, noalle, adjprior, priorTerm] = handleData(data); # TODO:trans
# [Z,dist] = newGetDistances(data,rowsFromInd); # TODO: trans
if (is.null(savePreProcessed)) {
save_preproc <- questdlg(
quest = 'Do you wish to save pre-processed data?',
dlgtitle = 'Save pre-processed data?',
defbtn = 'y'
)
} else {
save_preproc <- savePreProcessed
}
if (save_preproc %in% c('y', 'Yes', TRUE)) {
file_out <- uiputfile('.rda','Save pre-processed data as')
kokonimi <- paste0(file_out$path, file_out$name)
# FIXME: translate functions above so the objects below exist
c$data <- data
c$rowsFromInd <- rowsFromInd
c$alleleCodes <- alleleCodes
c$noalle <- noalle
c$adjprior <- adjprior
c$priorTerm <- priorTerm
c$dist <- dist
c$popnames <- popnames
c$Z <- Z
save(c, file = kokonimi)
rm(c)
}
# ----------------------------------------------------------------------
# Handling Pre-processed data
# ----------------------------------------------------------------------
} else if (input_type_name == 'Preprocessed data') {
file_in <- uigetfile(
filter = '*.txt',
title = 'Load pre-processed data in GenePop-format'
)
if (file_in$name == 0) stop("No name provided")
# [data, rowsFromInd, alleleCodes, noalle, adjprior, priorTerm] = handleData(data);
# [Z,dist] = newGetDistances(data,rowsFromInd);
# ASK: remove?
# h0 = findobj('Tag','filename1_text');
# set(h0,'String',filename); clear h0;
# if ~isempty(partitionCompare)
# fprintf(1,'Data: %s\n',[pathname filename]);
# end
# save_preproc = questdlg('Do you wish to save pre-processed data?',...
# 'Save pre-processed data?',...
# 'Yes','No','Yes');
# if isequal(save_preproc,'Yes');
# waitALittle;
# [filename, pathname] = uiputfile('*.mat','Save pre-processed data as');
# kokonimi = [pathname filename];
# c.data = data; c.rowsFromInd = rowsFromInd; c.alleleCodes = alleleCodes;
# c.noalle = noalle; c.adjprior = adjprior; c.priorTerm = priorTerm;
# c.dist = dist; c.popnames = popnames; c.Z = Z;
# % save(kokonimi,'c');
# save(kokonimi,'c','-v7.3'); % added by Lu Cheng, 08.06.2012
# clear c;
# end;
struct_array <- readRDS(paste0(file_in$path, file_in$name))
if (isfield(struct_array,'c')) { # Matlab versio
c <- struct_array$c
if (!isfield(c,'dist')) stop('Incorrect file format')
} else if (isfield(struct_array,'dist')) { #Mideva versio
c <- struct_array
} else {
stop('Incorrect file format')
}
data <- double(c$data)
rowsFromInd <- c$rowsFromInd
alleleCodes <- c$alleleCodes
noalle <- c$noalle
adjprior <- c$adjprior
priorTerm <- c$priorTerm
dist <- c$dist
popnames <- c$popnames
Z <- c$Z
rm(c)
}
} else {
data <- double(tietue$data)
rowsFromInd <- tietue$rowsFromInd
alleleCodes <- tietue$alleleCodes
noalle <- tietue$noalle
adjprior <- tietue$adjprior
priorTerm <- tietue$priorTerm
dist <- tietue$dist
popnames <- tietue$popnames
Z <- tietue$Z
rm(tietue)
}
# case 'GenePop-format'
# waitALittle;
# [filename, pathname] = uigetfile('*.txt', 'Load data in GenePop-format');
# if filename==0
# return;
# end
# if ~isempty(partitionCompare)
# fprintf(1,'Data: %s\n',[pathname filename]);
# end
# kunnossa = testaaGenePopData([pathname filename]);
# if kunnossa==0
# return
# end
# [data,popnames]=lueGenePopData([pathname filename]);
# ==========================================================================
# Declaring global variables
# ==========================================================================
PARTITION <- vector()
COUNTS <- vector()
SUMCOUNTS <- vector()
POP_LOGML <- vector()
clearGlobalVars <- vector()
# ==========================================================================
# h0 = findobj('Tag','filename1_text');
# set(h0,'String',filename); clear h0;
c$data <- data
c$noalle <- noalle
c$adjprior <- adjprior
c$priorTerm <- priorTerm
c$dist <- dist
c$Z <- Z
c$rowsFromInd <- rowsFromInd
# [data, rowsFromInd, alleleCodes, noalle, adjprior, priorTerm] = handleData(data);
# [Z,dist] = newGetDistances(data,rowsFromInd);
# save_preproc = questdlg('Do you wish to save pre-processed data?',...
# 'Save pre-processed data?',...
# 'Yes','No','Yes');
# if isequal(save_preproc,'Yes');
# waitALittle;
# [filename, pathname] = uiputfile('*.mat','Save pre-processed data as');
# kokonimi = [pathname filename];
# c.data = data; c.rowsFromInd = rowsFromInd; c.alleleCodes = alleleCodes;
# c.noalle = noalle; c.adjprior = adjprior; c.priorTerm = priorTerm;
# c.dist = dist; c.popnames = popnames; c.Z = Z;
# % save(kokonimi,'c');
# save(kokonimi,'c','-v7.3'); % added by Lu Cheng, 08.06.2012
# clear c;
# end;
ninds <- length(unique(data[, ncol(data)]))
ekat <- t(seq(1, ninds, rowsFromInd) * rowsFromInd)
c$rows <- c(ekat, ekat + rowsFromInd - 1)
# case 'Preprocessed data'
# waitALittle;
# [filename, pathname] = uigetfile('*.mat', 'Load pre-processed data');
# if filename==0
# return;
# end
# h0 = findobj('Tag','filename1_text');
# set(h0,'String',filename); clear h0;
# if ~isempty(partitionCompare)
# fprintf(1,'Data: %s\n',[pathname filename]);
# end
# partition compare
if (!is.null(partitionCompare)) {
nsamplingunits <- size(c$rows, 1)
partitions <- partitionCompare$partitions
npartitions <- size(partitions, 2)
partitionLogml <- zeros(1, npartitions)
for (i in seq_len(npartitions)) {
# number of unique partition lables
npops <- length(unique(partitions[, i]))
# struct_array = load([pathname filename]);
# if isfield(struct_array,'c') %Matlab versio
# c = struct_array.c;
# if ~isfield(c,'dist')
# disp('Incorrect file format');
# return
# end
# elseif isfield(struct_array,'dist') %Mideva versio
# c = struct_array;
# else
# disp('Incorrect file format');
# return;
# end
# data = double(c.data); rowsFromInd = c.rowsFromInd; alleleCodes = c.alleleCodes;
# noalle = c.noalle; adjprior = c.adjprior; priorTerm = c.priorTerm;
# dist = c.dist; popnames = c.popnames; Z = c.Z;
# clear c;
# otherwise
# return
# end
partitionInd <- zeros(ninds * rowsFromInd, 1)
partitionSample <- partitions[, i]
for (j in seq_len(nsamplingunits)) {
partitionInd[c$rows[j, 1]:c$rows[j, 2]] <- partitionSample[j]
}
# partitionLogml[i] = initialCounts(
# partitionInd,
# data[, seq_len(end - 1)],
# npops,
# c$rows,
# noalle,
# adjprior
# ) #TODO translate
}
# return the logml result
partitionCompare$logmls <- partitionLogml
# set(h1, 'userdata', partitionCompare) # ASK remove?
return()
}
# else
# data = double(tietue.data); rowsFromInd = tietue.rowsFromInd; alleleCodes = tietue.alleleCodes;
# noalle = tietue.noalle; adjprior = tietue.adjprior; priorTerm = tietue.priorTerm;
# dist = tietue.dist; popnames = tietue.popnames; Z = tietue.Z;
# clear tietue;
# end
# ASK remove (graphical part)?
# if (fixedK) {
# #logml_npops_partitionSummary <- indMix_fixK(c) # TODO translate?
# } else {
# #logml_npops_partitionSummary <- indMix(c) # TODO translate?
# }
# if (logml_npops_partitionSummary$logml == 1) return()
data <- data[, seq_len(ncol(data) - 1)]
# global PARTITION; global COUNTS;
# global SUMCOUNTS; global POP_LOGML;
# clearGlobalVars;
# ASK: remove?
# h0 = findobj('Tag','filename1_text'); inp = get(h0,'String');
# h0 = findobj('Tag','filename2_text');
# outp = get(h0,'String');
# c.data=data;
# c.noalle = noalle; c.adjprior = adjprior; c.priorTerm = priorTerm;
# c.dist=dist; c.Z=Z; c.rowsFromInd = rowsFromInd;
# changesInLogml <- writeMixtureInfo(
# logml, rowsFromInd, data, adjprior, priorTerm, outp, inp,
# popnames, fixedK
# ) # TODO translate
# ninds = length(unique(data(:,end)));
# ekat = (1:rowsFromInd:ninds*rowsFromInd)';
# c.rows = [ekat ekat+rowsFromInd-1];
# % partition compare
# if ~isempty(partitionCompare)
# nsamplingunits = size(c.rows,1);
# partitions = partitionCompare.partitions;
# npartitions = size(partitions,2);
# partitionLogml = zeros(1,npartitions);
# for i = 1:npartitions
# % number of unique partition lables
# npops = length(unique(partitions(:,i)));
# partitionInd = zeros(ninds*rowsFromInd,1);
# partitionSample = partitions(:,i);
# for j = 1:nsamplingunits
# partitionInd([c.rows(j,1):c.rows(j,2)]) = partitionSample(j);
# end
# partitionLogml(i) = ...
# initialCounts(partitionInd, data(:,1:end-1), npops, c.rows, noalle, adjprior);
# end
# % return the logml result
# partitionCompare.logmls = partitionLogml;
# set(h1, 'userdata', partitionCompare);
# return
# end
# if fixedK
# [logml, npops, partitionSummary]=indMix_fixK(c);
# else
# [logml, npops, partitionSummary]=indMix(c);
# end
# if logml==1
# return
# end
# data = data(:,1:end-1);
# h0 = findobj('Tag','filename1_text'); inp = get(h0,'String');
# h0 = findobj('Tag','filename2_text');
# outp = get(h0,'String');
# changesInLogml = writeMixtureInfo(logml, rowsFromInd, data, adjprior, priorTerm, ...
# outp,inp,partitionSummary, popnames, fixedK);
# viewMixPartition(PARTITION, popnames);
# talle = questdlg(['Do you want to save the mixture populations ' ...
# 'so that you can use them later in admixture analysis?'], ...
# 'Save results?','Yes','No','Yes');
# if isequal(talle,'Yes')
# waitALittle;
# [filename, pathname] = uiputfile('*.mat','Save results as');
# % -------------------------------------------
# % Added by Jing, 26.12.2005
# if (sum(filename)==0) || (sum(pathname)==0)
# % Cancel was pressed
# return;
# else
# % copy 'baps4_output.baps' into the text file with the same name.
# if exist('baps4_output.baps','file')
# copyfile('baps4_output.baps',[pathname filename '.txt'])
# delete('baps4_output.baps')
# end
# end;
# % -------------------------------------------
# c.PARTITION = PARTITION; c.COUNTS = COUNTS; c.SUMCOUNTS = SUMCOUNTS;
# c.alleleCodes = alleleCodes; c.adjprior = adjprior; c.popnames = popnames;
# c.rowsFromInd = rowsFromInd; c.data = data; c.npops = npops;
# c.noalle = noalle; c.mixtureType = 'mix';
# c.logml = logml; c.changesInLogml = changesInLogml;
# % save([pathname filename], 'c');
# save([pathname filename], 'c', '-v7.3'); % added by Lu Cheng, 08.06.2012
# else
# if exist('baps4_output.baps','file')
# delete('baps4_output.baps')
# end
# end
# viewMixPartition(PARTITION, popnames) # TODO translate function
talle <- questdlg(
quest = paste(
'Do you want to save the mixture populations',
'so that you can use them later in admixture analysis?'
),
dlgtitle = 'Save results?',
defbtn = 'y'
)
if (talle %in% c('Yes', 'y')) {
filename_pathname <- uiputfile('.mat','Save results as')
# ==========================================================================
cond <- (sum(filename_pathname$name) == 0) |
(sum(filename_pathname$path) == 0)
if (cond) {
# 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(
from = 'baps4_output.baps',
to = paste0(
filename_pathname$path, filename_pathname$name, '.txt'
)
)
file.remove('baps4_output.baps')
}
}
# ==========================================================================
c$PARTITION <- PARTITION
c$COUNTS <- COUNTS
c$SUMCOUNTS <- SUMCOUNTS
c$alleleCodes <- alleleCodes
c$adjprior <- adjprior
c$popnames <- popnames
c$rowsFromInd <- rowsFromInd
c$data <- data
c$npops <- npops
c$noalle <- noalle
c$mixtureType <- 'mix'
c$logml <- logml
c$changesInLogml <- changesInLogml
save(c, file = paste0(filename_pathname$path, filename_pathname$name))
} else {
if (file.exists('baps4_output.baps')) file.remove('baps4_output.baps')
}
}
# %-------------------------------------------------------------------------------------
# %-------------------------------------------------------------------------------------
@ -1495,21 +1583,6 @@
# apu = (apu(:,1)-1).*ninds - apu(:,1) ./ 2 .* (apu(:,1)-1) + (apu(:,2)-apu(:,1));
# dist2 = dist(apu);
# %--------------------------------------------------------
# function ninds = testaaOnkoKunnollinenBapsData(data)
# %Tarkastaa onko viimeisess?sarakkeessa kaikki
# %luvut 1,2,...,n johonkin n:<3A><>n asti.
# %Tarkastaa lis<69>ksi, ett?on v<>hint<6E><74>n 2 saraketta.
# if size(data,1)<2
# ninds = 0; return;
# end
# lastCol = data(:,end);
# ninds = max(lastCol);
# if ~isequal((1:ninds)',unique(lastCol))
# ninds = 0; return;
# end
# %--------------------------------------------------------------------------
# function [emptyPop, pops] = findEmptyPop(npops)
@ -1525,87 +1598,6 @@
# emptyPop = min(find(popDiff > 1));
# end
# %--------------------------------------------------------------------
# function kunnossa = testaaGenePopData(tiedostonNimi)
# % kunnossa == 0, jos data ei ole kelvollinen genePop data.
# % Muussa tapauksessa kunnossa == 1.
# kunnossa = 0;
# fid = fopen(tiedostonNimi);
# line1 = fgetl(fid); %ensimm<6D>inen rivi
# line2 = fgetl(fid); %toinen rivi
# line3 = fgetl(fid); %kolmas
# if (isequal(line1,-1) | isequal(line2,-1) | isequal(line3,-1))
# disp('Incorrect file format 1168'); fclose(fid);
# return
# end
# if (testaaPop(line1)==1 | testaaPop(line2)==1)
# disp('Incorrect file format 1172'); fclose(fid);
# return
# end
# if testaaPop(line3)==1
# %2 rivi t<>ll<6C>in lokusrivi
# nloci = rivinSisaltamienMjonojenLkm(line2);
# line4 = fgetl(fid);
# if isequal(line4,-1)
# disp('Incorrect file format 1180'); fclose(fid);
# return
# end
# if ~any(line4==',')
# % Rivin nelj?t<>ytyy sis<69>lt<6C><74> pilkku.
# disp('Incorrect file format 1185'); fclose(fid);
# return
# end
# pointer = 1;
# while ~isequal(line4(pointer),',') %Tiedet<65><74>n, ett?pys<79>htyy
# pointer = pointer+1;
# end
# line4 = line4(pointer+1:end); %pilkun j<>lkeinen osa
# nloci2 = rivinSisaltamienMjonojenLkm(line4);
# if (nloci2~=nloci)
# disp('Incorrect file format 1195'); fclose(fid);
# return
# end
# else
# line = fgetl(fid);
# lineNumb = 4;
# while (testaaPop(line)~=1 & ~isequal(line,-1))
# line = fgetl(fid);
# lineNumb = lineNumb+1;
# end
# if isequal(line,-1)
# disp('Incorrect file format 1206'); fclose(fid);
# return
# end
# nloci = lineNumb-2;
# line4 = fgetl(fid); %Eka rivi pop sanan j<>lkeen
# if isequal(line4,-1)
# disp('Incorrect file format 1212'); fclose(fid);
# return
# end
# if ~any(line4==',')
# % Rivin t<>ytyy sis<69>lt<6C><74> pilkku.
# disp('Incorrect file format 1217'); fclose(fid);
# return
# end
# pointer = 1;
# while ~isequal(line4(pointer),',') %Tiedet<65><74>n, ett?pys<79>htyy.
# pointer = pointer+1;
# end
# line4 = line4(pointer+1:end); %pilkun j<>lkeinen osa
# nloci2 = rivinSisaltamienMjonojenLkm(line4);
# if (nloci2~=nloci)
# disp('Incorrect file format 1228'); fclose(fid);
# return
# end
# end
# kunnossa = 1;
# fclose(fid);
# %------------------------------------------------------

41
R/questdlg.R Normal file
View file

@ -0,0 +1,41 @@
#' @title Prompt for multiple-choice
#' @param quest Question
#' @param dlgtitle Title of question
#' @param btn Vector of alternatives
#' @param defbtn Scalar with the name of the default option
#' @param accepted_ans Vector containing accepted answers
#' @description This function aims to loosely mimic the behavior of the
#' questdlg function on Matlab
#' @export
questdlg <- function(
quest,
dlgtitle = "",
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
# ==========================================================================
btn[match(tolower(defbtn), tolower(btn))] <- toupper(defbtn)
# ==========================================================================
# Creating prompt
# ==========================================================================
option_char <- paste0(' [', paste(btn, collapse = ', '), ']')
answer <- readline(paste0(quest, option_char, ": "))
# ==========================================================================
# Processing answer
# ==========================================================================
answer <- tolower(answer)
if (!(answer %in% tolower(c(btn, accepted_ans)))) {
if (answer != "") {
warning(
"'", answer, "' is not a valid alternative. Defaulting to ",
defbtn
)
}
answer <- defbtn
}
return(answer)
}

63
R/testaaGenePopData.R Normal file
View file

@ -0,0 +1,63 @@
#' @title Tests GenePop data
testaaGenePopData <- function(tiedostonNimi) {
# kunnossa == 0, jos data ei ole kelvollinen genePop data.
# Muussa tapauksessa kunnossa == 1.
kunnossa <- 0
if (file.exists(paste0(tiedostonNimi, ".rda"))) {
fid <- load(tiedostonNimi)
line1 <- readLines(fid)[1] # ensimmäinen rivi
line2 <- readLines(fid)[2] # toinen rivi
line3 <- readLines(fid)[3] # kolmas
} else {
fid <- line1 <- line2 <- line3 <- -1
}
if (line1 == -1 | line2 == -1 | line3 == -1) {
stop('Incorrect file format 1168')
}
if (testaaPop(line1) == 1 | testaaPop(line2) == 1) { # TODO: translate function
stop('Incorrect file format 1172')
}
if (testaaPop(line3) == 1) {
# 2 rivi t<>ll<6C>in lokusrivi
nloci <- rivinSisaltamienMjonojenLkm(line2) # TODO: translate function
line4 <- readLines(fid)[4]
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')
}
pointer <- 1
while (line4[pointer] != ',') { # Tiedet<65><74>n, ett?pys<79>htyy
pointer <- pointer + 1
}
line4 <- line4[(pointer + 1):nchar(line4)] # pilkun j<>lkeinen osa
nloci2 <- rivinSisaltamienMjonojenLkm(line4)
if (nloci2 != nloci) stop('Incorrect file format 1195')
} else {
line <- readLines(fid)[4]
lineNumb <- 4
while (testaaPop(line) != 1 & line != -1) {
line <- readLines(fid)[lineNumb]
lineNumb <- lineNumb + 1
}
if (line == -1) stop('Incorrect file format 1206')
nloci <- lineNumb - 2
line4 <- readLines(fid)[4] # Eka rivi pop sanan j<>lkeen
if (line4 == -1) stop('Incorrect file format 1212')
if (!grepl(',', line4)) {
# Rivin t<>ytyy sis<69>lt<6C><74> pilkku.
stop('Incorrect file format 1217')
}
pointer <- 1
while (line4[pointer] != ',') { # Tiedet<65><74>n, ett?pys<79>htyy
pointer <- pointer + 1
}
line4 <- line4[(pointer + 1):nchar(line4)] # pilkun j<>lkeinen osa
nloci2 <- rivinSisaltamienMjonojenLkm(line4)
if (nloci2 != nloci) stop('Incorrect file format 1228')
}
kunnossa <- 1
return(kunnossa)
}

21
R/testaaOnkoKunnollinenBapsData.R Normal file
View file

@ -0,0 +1,21 @@
#' @title TestBAPS data
#' @description Test if loaded BAPS data is proper
#' @param data dataset
#' @return ninds
#' @export
testaaOnkoKunnollinenBapsData <- function(data) {
# Tarkastaa onko viimeisess?sarakkeessa kaikki
# luvut 1,2,...,n johonkin n:<3A><>n asti.
# Tarkastaa lis<69>ksi, ett?on v<>hint<6E><74>n 2 saraketta.
if (size[data, 1] < 2) {
ninds <- 0
return(ninds)
}
lastCol <- data[, ncol(data)]
ninds <- max(lastCol)
if (t(1:ninds) != unique(lastCol)) {
ninds <- 0
return(ninds)
}
return(ninds)
}

10
R/uigetfile.R
View file

@ -2,13 +2,14 @@
#' @description Loosely mimics the functionality of the `uigetfile` function on
#' Matlab.
#' @references https://se.mathworks.com/help/matlab/ref/uigetfile.html
#' @param filter Filter listed files
#' @param title Pre-prompt message
#' @export
uigetfile <- function(title = "") {
uigetfile <- function(filter = "", title = "") {
# ==========================================================================
# Pre-prompt message
# ==========================================================================
cat(title)
message(title)
# ==========================================================================
# Reading file path and name
# ==========================================================================
@ -16,6 +17,11 @@ uigetfile <- function(title = "") {
paste0("Enter file path (leave empty for ", getwd(), "): ")
)
if (filepath == "") filepath <- getwd()
# ==========================================================================
# Presenting possible files
# ==========================================================================
message("Files present on that directory:")
print(list.files(path = filepath, pattern = filter, ignore.case = TRUE))
filename <- file.choose()
# ==========================================================================
# Organizing output

21
R/uiputfile.R Normal file
View file

@ -0,0 +1,21 @@
#' @title Save file
#' @param filter accepted file extension
#' @param title Title
#' @description This function intends to loosely mimic the behaviour of the
#' homonymous Matlab function.
#' @export
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(), '): '))
if (filename == "") filename <- 0
if (filepath == "") filepath <- getwd()
# ==========================================================================
# Processing output
# ==========================================================================
out <- list(name = filename, path = filepath)
return(out)
}

23
man/greedyMix.Rd Normal file
View file

@ -0,0 +1,23 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/greedyMix.R
\name{greedyMix}
\alias{greedyMix}
\title{Clustering of individuals}
\usage{
greedyMix(
tietue,
format = NULL,
savePreProcessed = NULL,
filePreProcessed = NULL
)
}
\arguments{
\item{tietue}{Record}
\item{format}{Format of the data ("BAPS", "GenePop" or "Preprocessed")}
\item{savePreProcessed}{Save the pre-processed data?}
}
\description{
Clustering of individuals
}

29
man/questdlg.Rd Normal file
View file

@ -0,0 +1,29 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/questdlg.R
\name{questdlg}
\alias{questdlg}
\title{Prompt for multiple-choice}
\usage{
questdlg(
quest,
dlgtitle = "",
btn = c("y", "n"),
defbtn = "n",
accepted_ans = c("y", "yes", "n", "no")
)
}
\arguments{
\item{quest}{Question}
\item{dlgtitle}{Title of question}
\item{btn}{Vector of alternatives}
\item{defbtn}{Scalar with the name of the default option}
\item{accepted_ans}{Vector containing accepted answers}
}
\description{
This function aims to loosely mimic the behavior of the
questdlg function on Matlab
}

11
man/testaaGenePopData.Rd Normal file
View file

@ -0,0 +1,11 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/testaaGenePopData.R
\name{testaaGenePopData}
\alias{testaaGenePopData}
\title{Tests GenePop data}
\usage{
testaaGenePopData(tiedostonNimi)
}
\description{
Tests GenePop data
}

4
man/uigetfile.Rd
View file

@ -4,9 +4,11 @@
\alias{uigetfile}
\title{Select a file for loading}
\usage{
uigetfile(title = "")
uigetfile(filter = "", title = "")
}
\arguments{
\item{filter}{Filter listed files}
\item{title}{Pre-prompt message}
}
\description{

17
man/uiputfile.Rd Normal file
View file

@ -0,0 +1,17 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/uiputfile.R
\name{uiputfile}
\alias{uiputfile}
\title{Save file}
\usage{
uiputfile(filter = ".rda", title = "Save file")
}
\arguments{
\item{filter}{accepted file extension}
\item{title}{Title}
}
\description{
This function intends to loosely mimic the behaviour of the
homonymous Matlab function.
}

252
tests/testthat/test-convertedBaseFunctions.R
View file

@ -1,163 +1,163 @@
context("Basic Matlab functions")
test_that("rand works properly", {
expect_equal(dim(rand()), c(1, 1))
expect_equal(dim(rand(1, 2)), c(1, 2))
expect_equal(dim(rand(3, 2)), c(3, 2))
expect_equal(dim(rand()), c(1, 1))
expect_equal(dim(rand(1, 2)), c(1, 2))
expect_equal(dim(rand(3, 2)), c(3, 2))
})
test_that("repmat works properly", {
mx0 <- c(1:4) # when converted to matrix, results in a column vector
mx1 <- matrix(5:8)
mx2 <- matrix(0:-3, 2)
expect_error(repmat(mx0))
expect_equal(repmat(mx0, 1), as.matrix(mx0))
expect_equal(
object = repmat(mx0, 2),
expected = unname(t(cbind(rbind(mx0, mx0), rbind(mx0, mx0))))
)
expect_equal(
object = repmat(mx1, 2),
expected = unname(cbind(rbind(mx1, mx1), rbind(mx1, mx1)))
)
expect_equal(
object = repmat(mx2, c(2, 3)),
expected = cbind(rbind(mx2, mx2), rbind(mx2, mx2), rbind(mx2, mx2))
)
expect_equal(
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))
)
mx0 <- c(1:4) # when converted to matrix, results in a column vector
mx1 <- matrix(5:8)
mx2 <- matrix(0:-3, 2)
expect_error(repmat(mx0))
expect_equal(repmat(mx0, 1), as.matrix(mx0))
expect_equal(
object = repmat(mx0, 2),
expected = unname(t(cbind(rbind(mx0, mx0), rbind(mx0, mx0))))
)
expect_equal(
object = repmat(mx1, 2),
expected = unname(cbind(rbind(mx1, mx1), rbind(mx1, mx1)))
)
expect_equal(
object = repmat(mx2, c(2, 3)),
expected = cbind(rbind(mx2, mx2), rbind(mx2, mx2), rbind(mx2, mx2))
)
expect_equal(
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", {
expect_equal(zeros(1), matrix(0, 1))
expect_equal(zeros(2), matrix(0, 2, 2))
expect_equal(zeros(2, 1), matrix(0, 2, 1))
expect_equal(zeros(1, 10), matrix(0, 1, 10))
expect_equal(zeros(3, 2, 4), array(0, c(3, 2, 4)))
expect_equal(ones(8), matrix(1, 8, 8))
expect_equal(ones(5, 2), matrix(1, 5, 2))
expect_equal(ones(2, 100), matrix(1, 2, 100))
expect_equal(ones(3, 2, 4, 2), array(1, c(3, 2, 4, 2)))
expect_equal(zeros(1), matrix(0, 1))
expect_equal(zeros(2), matrix(0, 2, 2))
expect_equal(zeros(2, 1), matrix(0, 2, 1))
expect_equal(zeros(1, 10), matrix(0, 1, 10))
expect_equal(zeros(3, 2, 4), array(0, c(3, 2, 4)))
expect_equal(ones(8), matrix(1, 8, 8))
expect_equal(ones(5, 2), matrix(1, 5, 2))
expect_equal(ones(2, 100), matrix(1, 2, 100))
expect_equal(ones(3, 2, 4, 2), array(1, c(3, 2, 4, 2)))
})
test_that("times works as expected", {
expect_equal(times(9, 6), as.matrix(54))
expect_equal(times(9, c(.8, 9)), as.matrix(c(7.2, 81)))
expect_equal(times(c(.8, 9), 5), as.matrix(c(4, 45)))
expect_equal(times(matrix(1:4, 2), 5), matrix(c(5, 10, 15, 20), 2))
expect_equal(times(5, matrix(1:4, 2)), matrix(c(5, 10, 15, 20), 2))
expect_equal(times(matrix(1:4, 2), c(10, 3)), matrix(c(10, 6, 30, 12), 2))
expect_equal(
object = times(matrix(1:4, 2), matrix(c(10, 3), 1)),
expected = matrix(c(10, 20, 9, 12), 2)
)
expect_equal(times(c(10, 3), matrix(1:4, 2)), matrix(c(10, 6, 30, 12), 2))
expect_equal(
object = times(matrix(c(10, -5, 3, 9), 2), matrix(1:4, 2)),
expected = matrix(c(10, -10, 9, 36), 2)
)
expect_equal(
object = times(matrix(c(-1.6, 5), 1), c(8, 1)),
expected = matrix(c(-12.8, -1.6, 40, 5), 2)
)
expect_equal(times(9, 6), as.matrix(54))
expect_equal(times(9, c(.8, 9)), as.matrix(c(7.2, 81)))
expect_equal(times(c(.8, 9), 5), as.matrix(c(4, 45)))
expect_equal(times(matrix(1:4, 2), 5), matrix(c(5, 10, 15, 20), 2))
expect_equal(times(5, matrix(1:4, 2)), matrix(c(5, 10, 15, 20), 2))
expect_equal(times(matrix(1:4, 2), c(10, 3)), matrix(c(10, 6, 30, 12), 2))
expect_equal(
object = times(matrix(1:4, 2), matrix(c(10, 3), 1)),
expected = matrix(c(10, 20, 9, 12), 2)
)
expect_equal(times(c(10, 3), matrix(1:4, 2)), matrix(c(10, 6, 30, 12), 2))
expect_equal(
object = times(matrix(c(10, -5, 3, 9), 2), matrix(1:4, 2)),
expected = matrix(c(10, -10, 9, 36), 2)
)
expect_equal(
object = times(matrix(c(-1.6, 5), 1), c(8, 1)),
expected = matrix(c(-12.8, -1.6, 40, 5), 2)
)
})
test_that("colon works as expected (hee hee)", {
expect_equal(colon(1, 4), 1:4)
expect_length(colon(4, 1), 0)
expect_equal(colon(1, 4), 1:4)
expect_length(colon(4, 1), 0)
})
test_that("size works as on MATLAB", {
sk <- 10
vk <- 1:4
mx <- matrix(1:6, 2)
ra <- array(1:24, c(2, 3, 4))
expect_equal(size(sk), 1)
expect_equal(size(vk), c(1, 4))
expect_equal(size(mx), c(2, 3))
expect_equal(size(ra), c(2, 3, 4))
expect_equal(size(sk, 199), 1)
expect_equal(size(vk, 199), 1)
expect_equal(size(mx, 199), 1)
expect_equal(size(ra, 199), 1)
expect_equal(size(vk, 2), 4)
expect_equal(size(mx, 2), 3)
expect_equal(size(ra, 2), 3)
expect_equal(size(ra, 3), 4)
sk <- 10
vk <- 1:4
mx <- matrix(1:6, 2)
ra <- array(1:24, c(2, 3, 4))
expect_equal(size(sk), 1)
expect_equal(size(vk), c(1, 4))
expect_equal(size(mx), c(2, 3))
expect_equal(size(ra), c(2, 3, 4))
expect_equal(size(sk, 199), 1)
expect_equal(size(vk, 199), 1)
expect_equal(size(mx, 199), 1)
expect_equal(size(ra, 199), 1)
expect_equal(size(vk, 2), 4)
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)))
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)))
})
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)
)
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))
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))
})
test_that("isempty works as expected", {
A <- array(dim=c(0, 2, 2))
B <- matrix(rep(NA, 4), 2)
C <- matrix(rep(0, 4), 2)
cat1 <- as.factor(c(NA, NA))
cat2 <- as.factor(c())
str1 <- matrix(rep("", 3))
expect_true(isempty(A))
expect_false(isempty(B))
expect_false(isempty(C))
expect_false(isempty(cat1))
expect_true(isempty(cat2))
expect_false(isempty(str1))
A <- array(dim=c(0, 2, 2))
B <- matrix(rep(NA, 4), 2)
C <- matrix(rep(0, 4), 2)
cat1 <- as.factor(c(NA, NA))
cat2 <- as.factor(c())
str1 <- matrix(rep("", 3))
expect_true(isempty(A))
expect_false(isempty(B))
expect_false(isempty(C))
expect_false(isempty(cat1))
expect_true(isempty(cat2))
expect_false(isempty(str1))
})
test_that("find works as expected", {
X <- matrix(c(1, 0, 2, 0, 1, 1, 0, 0, 4), 3, byrow=TRUE)
Y <- seq(1, 19, 2)
expect_equal(find(X), c(1, 5, 7, 8, 9))
expect_equal(find(!X), c(2, 3, 4, 6))
expect_equal(find(Y == 13), 7)
X <- matrix(c(1, 0, 2, 0, 1, 1, 0, 0, 4), 3, byrow=TRUE)
Y <- seq(1, 19, 2)
expect_equal(find(X), c(1, 5, 7, 8, 9))
expect_equal(find(!X), c(2, 3, 4, 6))
expect_equal(find(Y == 13), 7)
})
test_that("sortrows works as expected", {
mx <- matrix(c(3, 2, 2, 1, 1, 10, 0, pi), 4)
expect_equal(sortrows(mx), matrix(c(1, 2, 2, 3, pi, 10, 0, 1), 4))
expect_equal(sortrows(mx, 2), matrix(c(2, 3, 1, 2, 0, 1, pi, 10), 4))
expect_equal(sortrows(mx, 1:2), mx[order(mx[, 1], mx[, 2]), ])
mx <- matrix(c(3, 2, 2, 1, 1, 10, 0, pi), 4)
expect_equal(sortrows(mx), matrix(c(1, 2, 2, 3, pi, 10, 0, 1), 4))
expect_equal(sortrows(mx, 2), matrix(c(2, 3, 1, 2, 0, 1, pi, 10), 4))
expect_equal(sortrows(mx, 1:2), mx[order(mx[, 1], mx[, 2]), ])
})