Merge branch 'testaaOnkoKunnollinenBapsData' into dev

NAMESPACE

@@ -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)

R/greedyMix.R

@@ -1,7 +1,17 @@
-# function greedyMix(tietue)
+#' @title Clustering of individuals
-
+#' @param tietue Record
-# 	% check whether fixed k mode is selected
+#' @param format Format of the data ("BAPS", "GenePop" or "Preprocessed")
-# 	h0 = findobj('Tag','fixk_menu');
+#' @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');
 
 	# if fixedK
@@ -14,255 +24,333 @@
 	# 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
+			}
 
-# 	if isequal(tietue,-1)
+			# ASK: remove?
-
-# 		input_type = questdlg('Specify the format of your data: ',...
-# 			'Specify Data Format', ...
-# 			'BAPS-format', 'GenePop-format', 'Preprocessed data', ...
-# 			'BAPS-format');
-
-# 		switch input_type
-
-# 			case 'BAPS-format'
-# 				waitALittle;
-# 				[filename, pathname] = uigetfile('*.txt', 'Load data in BAPS-format');
-# 				if filename==0
-# 					return;
-# 				end
-
 			# if ~isempty(partitionCompare)
 			# 	fprintf(1,'Data: %s\n',[pathname filename]);
 			# end
 
-# 				data = load([pathname filename]);
+			data <- read.delim(pathname_filename) # ASK: what is the delimiter?
-# 				ninds = testaaOnkoKunnollinenBapsData(data);  %TESTAUS
+			# ninds <- testaaOnkoKunnollinenBapsData(data)  #TESTAUS # TODO: trans
-# 				if (ninds==0)
+			# if (ninds == 0) stop('Incorrect Data-file')
-# 					disp('Incorrect Data-file.');
+
-# 					return;
+			# ASK: remove?
-# 				end
 			# 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 <- ""
+			}
 
-# 				input_pops = questdlg(['When using data which are in BAPS-format, '...
+			# [data, rowsFromInd, alleleCodes, noalle, adjprior, priorTerm] = handleData(data); # TODO: translate this function
-# 					'you can specify the sampling populations of the individuals by '...
+			# [Z,dist] = newGetDistances(data,rowsFromInd); # TODO: translate
-# 					'giving two additional files: one containing the names of the '...
+			if (is.null(savePreProcessed)) {
-# 					'populations, the other containing the indices of the first '...
+				save_preproc <- questdlg(
-# 					'individuals of the populations. Do you wish to specify the '...
+					quest = 'Do you wish to save pre-processed data?',
-# 					'sampling populations?'], ...
+					dlgtitle = 'Save pre-processed data?',
-# 					'Specify sampling populations?',...
+					defbtn = 'y'
-# 					'Yes', 'No', 'No');
+				)
-# 				if isequal(input_pops,'Yes')
+			} else {
-# 					waitALittle;
+				save_preproc <- savePreProcessed
-# 					[namefile, namepath] = uigetfile('*.txt', 'Load population names');
+			}
-# 					if namefile==0
+			if (save_preproc %in% c('y', 'yes', TRUE)) {
-# 						kysyToinen = 0;
+				file_out      <- uiputfile('.rda','Save pre-processed data as')
-# 					else
+				kokonimi      <- paste0(file_out$path, file_out$name)
-# 						kysyToinen = 1;
+				c             <- list()
-# 					end
+				c$data        <- data
-# 					if kysyToinen==1
+				c$rowsFromInd <- rowsFromInd
-# 						waitALittle;
+				c$alleleCodes <- alleleCodes
-# 						[indicesfile, indicespath] = uigetfile('*.txt', 'Load population indices');
+				c$noalle      <- noalle
-# 						if indicesfile==0
+				c$adjprior    <- adjprior
-# 							popnames = [];
+				c$priorTerm   <- priorTerm
-# 						else
+				c$dist        <- dist
-# 							popnames = initPopNames([namepath namefile],[indicespath indicesfile]);
+				c$popnames    <- popnames
-# 						end
+				c$Z           <- Z
-# 					else
+				save(c, file = kokonimi)
-# 						popnames = [];
+				rm(c)
-# 					end
+			}
-# 				else
+		# ----------------------------------------------------------------------
-# 					popnames = [];
+		# Treating GenePop-formatted files
-# 				end
+		# ----------------------------------------------------------------------
+		} 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
+			}
 
-# 				[data, rowsFromInd, alleleCodes, noalle, adjprior, priorTerm] = handleData(data);
+			# ASK: remove?
-# 				[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;
-
-# 			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
+			# kunnossa = testaaGenePopData([pathname filename]); # TODO: trans
-# 					return
+			# if (kunnossa == 0) stop("testaaGenePopData returned 0")
-# 				end
+			# [data,popnames]=lueGenePopData([pathname filename]); # TODO: trans
-# 				[data,popnames]=lueGenePopData([pathname filename]);
 
 # 			h0 = findobj('Tag','filename1_text');
 # 			set(h0,'String',filename); clear h0;
 
-# 				[data, rowsFromInd, alleleCodes, noalle, adjprior, priorTerm] = handleData(data);
+# 			[data, rowsFromInd, alleleCodes, noalle, adjprior, priorTerm] = handleData(data); # TODO:trans
-# 				[Z,dist] = newGetDistances(data,rowsFromInd);
+# 			[Z,dist] = newGetDistances(data,rowsFromInd); # TODO: trans
-# 				save_preproc = questdlg('Do you wish to save pre-processed data?',...
+			if (is.null(savePreProcessed)) {
-# 					'Save pre-processed data?',...
+				save_preproc <- questdlg(
-# 					'Yes','No','Yes');
+					quest = 'Do you wish to save pre-processed data?',
-# 				if isequal(save_preproc,'Yes');
+					dlgtitle = 'Save pre-processed data?',
-# 					waitALittle;
+					defbtn = 'y'
-# 					[filename, pathname] = uiputfile('*.mat','Save pre-processed data as');
+				)
-# 					kokonimi = [pathname filename];
+			} else {
-# 					c.data = data; c.rowsFromInd = rowsFromInd; c.alleleCodes = alleleCodes;
+				save_preproc <- savePreProcessed
-# 					c.noalle = noalle; c.adjprior = adjprior; c.priorTerm = priorTerm;
+			}
-# 					c.dist = dist; c.popnames = popnames; c.Z = Z;
+			if (save_preproc %in% c('y', 'Yes', TRUE)) {
-# 	%                 save(kokonimi,'c');
+				file_out      <- uiputfile('.rda','Save pre-processed data as')
-# 					save(kokonimi,'c','-v7.3'); % added by Lu Cheng, 08.06.2012
+				kokonimi      <- paste0(file_out$path, file_out$name)
-# 					clear c;
+				# FIXME: translate functions above so the objects below exist
-# 				end;
+				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")
 
-# 			case 'Preprocessed data'
+			# ASK: remove?
-# 				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
 
-# 				struct_array = load([pathname filename]);
+			struct_array <- readRDS(paste0(file_in$path, file_in$name))
-# 				if isfield(struct_array,'c')  %Matlab versio
+			if (isfield(struct_array,'c')) { # Matlab versio
-# 					c = struct_array.c;
+				c <- struct_array$c
-# 					if ~isfield(c,'dist')
+				if (!isfield(c,'dist')) stop('Incorrect file format')
-# 						disp('Incorrect file format');
+			} else if (isfield(struct_array,'dist')) { #Mideva versio
-# 						return
+				c <- struct_array
-# 					end
+			} else {
-# 				elseif isfield(struct_array,'dist')  %Mideva versio
+				stop('Incorrect file format')
-# 					c = struct_array;
+			}
-# 				else
+			data        <- double(c$data)
-# 					disp('Incorrect file format');
+			rowsFromInd <- c$rowsFromInd
-# 					return;
+			alleleCodes <- c$alleleCodes
-# 				end
+			noalle      <- c$noalle
-# 				data = double(c.data); rowsFromInd = c.rowsFromInd; alleleCodes = c.alleleCodes;
+			adjprior    <- c$adjprior
-# 				noalle = c.noalle; adjprior = c.adjprior; priorTerm = c.priorTerm;
+			priorTerm   <- c$priorTerm
-# 				dist = c.dist; popnames = c.popnames; Z = c.Z;
+			dist        <- c$dist
-# 				clear c;
+			popnames    <- c$popnames
-# 				otherwise
+			Z           <- c$Z
-# 				return
+			rm(c)
-# 		end
+		}
+	} 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)
+	}
 
-# 	else
+	# ==========================================================================
-# 		data = double(tietue.data); rowsFromInd = tietue.rowsFromInd; alleleCodes = tietue.alleleCodes;
+	# Declaring global variables
-# 		noalle = tietue.noalle; adjprior = tietue.adjprior; priorTerm = tietue.priorTerm;
+	# ==========================================================================
-# 		dist = tietue.dist; popnames = tietue.popnames; Z = tietue.Z;
+	PARTITION       <- vector()
-# 		clear tietue;
+	COUNTS          <- vector()
-# 	end
+	SUMCOUNTS       <- vector()
+	POP_LOGML       <- vector()
+	clearGlobalVars <- vector()
+	# ==========================================================================
 
+	c$data        <- data
+	c$noalle      <- noalle
+	c$adjprior    <- adjprior
+	c$priorTerm   <- priorTerm
+	c$dist        <- dist
+	c$Z           <- Z
+	c$rowsFromInd <- rowsFromInd
 
-# 	global PARTITION; global COUNTS;
+	ninds  <- length(unique(data[, ncol(data)]))
-# 	global SUMCOUNTS; global POP_LOGML;
+	ekat   <- t(seq(1, ninds, rowsFromInd) * rowsFromInd)
-# 	clearGlobalVars;
+	c$rows <- c(ekat, ekat + rowsFromInd - 1)
 
-# 	c.data=data;
+	# partition compare
-# 	c.noalle = noalle; c.adjprior = adjprior; c.priorTerm = priorTerm;
+	if (!is.null(partitionCompare)) {
-# 	c.dist=dist; c.Z=Z; c.rowsFromInd = rowsFromInd;
+		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]))
 
-# 	ninds = length(unique(data(:,end)));
+			partitionInd <- zeros(ninds * rowsFromInd, 1)
-# 	ekat = (1:rowsFromInd:ninds*rowsFromInd)';
+			partitionSample <- partitions[, i]
-# 	c.rows = [ekat ekat+rowsFromInd-1];
+			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()
+	}
 
-# 	% partition compare
+	# ASK remove (graphical part)?
-# 	if ~isempty(partitionCompare)
+	# if (fixedK) {
-# 		nsamplingunits = size(c.rows,1);
+	# 	#logml_npops_partitionSummary <- indMix_fixK(c) # TODO translate?
-# 		partitions = partitionCompare.partitions;
+	# } else {
-# 		npartitions = size(partitions,2);
+	# 	#logml_npops_partitionSummary <- indMix(c) # TODO translate?
-# 		partitionLogml = zeros(1,npartitions);
+	# }
-# 		for i = 1:npartitions
+	# if (logml_npops_partitionSummary$logml == 1) return()
-# 			% number of unique partition lables
-# 			npops = length(unique(partitions(:,i)));
 
-# 			partitionInd = zeros(ninds*rowsFromInd,1);
+	data <- data[, seq_len(ncol(data) - 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);
 
+	# ASK: remove?
 	# 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);
+	# changesInLogml <- writeMixtureInfo(
+	# 	logml, rowsFromInd, data, adjprior, priorTerm, outp, inp,
+	# 	popnames, fixedK
+	# ) # TODO translate
 
-# 	talle = questdlg(['Do you want to save the mixture populations ' ...
+	# viewMixPartition(PARTITION, popnames) # TODO translate function
-# 		'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
 
+	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);
-
 # 	%------------------------------------------------------
 
 

R/questdlg.R

@@ -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)
+}

R/testaaGenePopData.R

@@ -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)
+}

R/testaaOnkoKunnollinenBapsData.R

@@ -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)
+}

R/uigetfile.R

@@ -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

R/uiputfile.R

@@ -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)
+}

man/greedyMix.Rd

@@ -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
+}

man/questdlg.Rd

@@ -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
+}

man/testaaGenePopData.Rd

@@ -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
+}

man/uigetfile.Rd

@@ -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{

man/uiputfile.Rd

@@ -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.
+}