Merge branch 'master' of https://github.com/rohan-shah/mpMap2

Conflicts:
	DESCRIPTION
	DESCRIPTION.in

.gitignore

@@ -1,2 +1 @@
 /man
-/NAMESPACE

CMakeLists.txt

@@ -11,6 +11,7 @@ if(USE_BOOST)
 	set(Boost_USE_STATIC_RUNTIME    OFF)
 	#Find boost packages
 	find_package(Boost 1.50.0 REQUIRED COMPONENTS graph regex)
+	add_definitions(-DBOOST_NO_AUTO_PTR)
 endif()
 
 list(APPEND CMAKE_MODULE_PATH ${PROJECT_SOURCE_DIR}/src)
@@ -21,7 +22,7 @@ add_subdirectory(src)
 
 add_custom_target(copyPackage ALL)	
 set(HEADERS alleleDataErrors.h combineGenotypes.h estimateRFCheckFunnels.h estimateRFSpecificDesign.h generateGenotypes.h intercrossingAndSelfingGenerations.h orderFunnel.h recodeHetsAsNA.h checkHets.h crc32.h estimateRF.h funnelsToUniqueValues.h getFunnel.h markerPatternsToUniqueValues.h recodeFoundersFinalsHets.h sortPedigreeLineNames.h unitTypes.hpp fourParentPedigreeRandomFunnels.h matrixChunks.h rawSymmetricMatrix.h dspMatrix.h impute.h arsa.h)
-set(RFILES biparentalDominant.R combineGenotypes.R detailedPedigree-class.R estimateRF.R expand.R f2Pedigree.R formGroups.R fourParentPedigreeRandomFunnels.R fourParentPedigreeSingleFunnel.R fullHetData.R geneticData-class.R hetData-class.R lg-class.R map-class.R mapFunctions.R markers.R mpcross-class.R mpcross.R multiparentSNP.R multiparentSNPPrototype.R nFounders.R nLines.R nMarkers.R pedigree-class.R pedigree.R pedigreeGraph-class.R pedigreeGraph.R pedigreeToGraph.R print.R Rcpp_exceptions.R removeHets.R rf-class.R rilPedigree.R roxygen.R show.R simulateMPCross.R subset.R twoParentPedigree.R validation.R rawSymmetricMatrix.R orderCross.R eightWayPedigreeRandomFunnels.R impute.R sixteenParentPedigreeRandomFunnels.R eightWayPedigreeSingleFunnel.R imputeFounders.R estimateMap.R jitterMap.R founders.R finals.R hetData.R fixedNumberOfFounderAlleles.R compressedProbabilities.R backcrossPedigree.R eightWayPedigreeImproperFunnels.R reorderPedigree.R testDistortion.R lineNames.R selfing.R as.mpInterval.R computeGenotypeProbabilities.R)
+set(RFILES biparentalDominant.R combineGenotypes.R detailedPedigree-class.R estimateRF.R expand.R f2Pedigree.R formGroups.R fourParentPedigreeRandomFunnels.R fourParentPedigreeSingleFunnel.R fullHetData.R geneticData-class.R hetData-class.R lg-class.R map-class.R mapFunctions.R markers.R mpcross-class.R mpcross.R multiparentSNP.R multiparentSNPPrototype.R nFounders.R nLines.R nMarkers.R pedigree-class.R pedigree.R pedigreeGraph-class.R pedigreeGraph.R pedigreeToGraph.R print.R Rcpp_exceptions.R removeHets.R rf-class.R rilPedigree.R roxygen.R show.R simulateMPCross.R subset.R twoParentPedigree.R validation.R rawSymmetricMatrix.R orderCross.R eightWayPedigreeRandomFunnels.R impute.R sixteenParentPedigreeRandomFunnels.R eightWayPedigreeSingleFunnel.R imputeFounders.R estimateMap.R jitterMap.R founders.R finals.R hetData.R fixedNumberOfFounderAlleles.R compressedProbabilities.R backcrossPedigree.R eightWayPedigreeImproperFunnels.R reorderPedigree.R testDistortion.R lineNames.R selfing.R as.mpInterval.R computeGenotypeProbabilities.R purdyToPedigree.R)
 #Copy package to binary directory. This works differently on windows and linux
 if(WIN32)
 	if("${CMAKE_GENERATOR}" STREQUAL "NMake Makefiles")

DESCRIPTION

@@ -2,7 +2,7 @@ Package: mpMap2
 Type: Package
 Title: Multi-parent RIL genetic analysis
 Version: 0.0.2
-Date: 2016-09-28
+Date: 2017-01-24
 Author: Rohan Shah and Emma Huang
 Maintainer: Rohan Shah <[email protected]>
 Description: Tools for constructing linkage maps, reconstructing haplotypes,
@@ -74,6 +74,7 @@ Collate:
     'pedigreeGraph.R'
     'pedigreeToGraph.R'
     'print.R'
+    'purdyToPedigree.R'
     'removeHets.R'
     'reorderPedigree.R'
     'rilPedigree.R'

DESCRIPTION.in

@@ -2,7 +2,7 @@ Package: mpMap2
 Type: Package
 Title: Multi-parent RIL genetic analysis
 Version: 0.0.2
-Date: 2016-09-28
+Date: 2017-01-24
 Author: Rohan Shah and Emma Huang
 Maintainer: Rohan Shah <[email protected]>
 Description: Tools for constructing linkage maps, reconstructing haplotypes,

NAMESPACE

@@ -0,0 +1,66 @@
+# Generated by roxygen2: do not edit by hand
+
+export("lineNames<-")
+export("selfing<-")
+export(as.mpInterval)
+export(backcrossPedigree)
+export(biparentalDominant)
+export(clusterOrderCross)
+export(computeGenotypeProbabilities)
+export(detailedPedigree)
+export(eightParentPedigreeImproperFunnels)
+export(eightParentPedigreeRandomFunnels)
+export(eightParentPedigreeSingleFunnel)
+export(estimateMap)
+export(estimateRF)
+export(f2Pedigree)
+export(finals)
+export(fixedNumberOfFounderAlleles)
+export(formGroups)
+export(founders)
+export(fourParentPedigreeRandomFunnels)
+export(fourParentPedigreeSingleFunnel)
+export(haldane)
+export(haldaneToRf)
+export(hetData)
+export(impute)
+export(imputeFounders)
+export(jitterMap)
+export(kosambi)
+export(kosambiToRf)
+export(lineNames)
+export(linesByNames)
+export(markers)
+export(mpcross)
+export(mpcrossMapped)
+export(multiparentSNP)
+export(nFounders)
+export(nLines)
+export(nMarkers)
+export(orderCross)
+export(pedigree)
+export(pedigreeToGraph)
+export(purdyToPedigree)
+export(removeHets)
+export(rfToHaldane)
+export(rfToKosambi)
+export(rilPedigree)
+export(selfing)
+export(simulateMPCross)
+export(sixteenParentPedigreeRandomFunnels)
+export(sixteenParentPedigreeRandomFunnelsPrototype)
+export(testDistortion)
+export(twoParentPedigree)
+exportClasses(pedigreeGraph)
+exportMethods(plot)
+exportMethods(subset)
+import(igraph)
+import(methods)
+import(qtl)
+importClassesFrom(Matrix,dppMatrix)
+importClassesFrom(Matrix,dspMatrix)
+importClassesFrom(Matrix,index)
+importFrom(methods,setClass)
+importFrom(nnls,nnls)
+importFrom(pryr,address)
+useDynLib(mpMap2)

R/computeGenotypeProbabilities.R

@@ -1,5 +1,5 @@
 #' @export
-computeGenotypeProbabilities <- function(mpcrossMapped, homozygoteMissingProb = 1, heterozygoteMissingProb = 1)
+computeGenotypeProbabilities <- function(mpcrossMapped, homozygoteMissingProb = 1, heterozygoteMissingProb = 1, errorProb = 0, extraPositions = list())
 {
 	isNewMpcrossMappedArgument(mpcrossMapped)
 	if(homozygoteMissingProb < 0 || homozygoteMissingProb > 1)
@@ -10,12 +10,44 @@ computeGenotypeProbabilities <- function(mpcrossMapped, homozygoteMissingProb =
 	{
 		stop("Input heterozygoteMissingProb must be a value between 0 and 1")
 	}
+	map <- mpcrossMapped@map
+	allMarkerNames <- unlist(lapply(map, names))
+
+	#Input extraPositions can be a list or a function
+	if(class(extraPositions) != "list" && class(extraPositions) != "function")
+	{
+		stop("Input extraPositions must be a list or a function that generates a list")
+	}
+	if(class(extraPositions) == "function")
+	{
+		extraPositions <- extraPositions(mpcrossMapped)
+	}
+	if(!all(names(extraPositions) %in% names(map)))
+	{
+		stop("Input extraPositions must be a list, with entries named after chromosomes")
+	}
+	for(chromosome in names(extraPositions))
+	{
+		extraChr <- extraPositions[[chromosome]]
+		if(any(names(extraChr) %in% allMarkerNames))
+		{
+			stop("Extra locations in extraPositions cannot be named after markers")
+		}
+		if(!is.numeric(extraChr))
+		{
+			stop("Input extraPositions must be a list, with entries which are numeric vectors")
+		}
+		if(is.null(names(extraChr)))
+		{
+			stop("Vectors in input extraPositions must have names")
+		}
+		extraPositions[[chromosome]] <- sort(extraChr)
+	}
 	for(i in 1:length(mpcrossMapped@geneticData))
 	{
-		results <- .Call("computeGenotypeProbabilities", mpcrossMapped@geneticData[[i]], mpcrossMapped@map, homozygoteMissingProb, heterozygoteMissingProb, PACKAGE="mpMap2")
+		results <- .Call("computeGenotypeProbabilities", mpcrossMapped@geneticData[[i]], mpcrossMapped@map, homozygoteMissingProb, heterozygoteMissingProb, errorProb, extraPositions, PACKAGE="mpMap2")
 		resultsMatrix <- results$data
 		founderNames <- rownames(mpcrossMapped@geneticData[[i]]@founders)
-		colnames(resultsMatrix) <- colnames(mpcrossMapped@geneticData[[i]]@finals)
 		if(mpcrossMapped@geneticData[[i]]@pedigree@selfing == "infinite")
 		{
 			rownames(resultsMatrix) <- unlist(lapply(rownames(mpcrossMapped@geneticData[[i]]@finals), function(lineName) paste0(lineName, " - ", founderNames)))
@@ -25,7 +57,9 @@ computeGenotypeProbabilities <- function(mpcrossMapped, homozygoteMissingProb =
 			nAlleles <- nrow(resultsMatrix) / nrow(mpcrossMapped@geneticData[[i]]@finals)
 			rownames(resultsMatrix) <- unlist(lapply(rownames(mpcrossMapped@geneticData[[i]]@finals), function(lineName) paste0(lineName, " - ", 1:nAlleles)))
 		}
-		mpcrossMapped@geneticData[[i]]@probabilities <- new("probabilities", data = resultsMatrix, key = results$key)
+		class(results$map) <- "map"
+		names(results$map) <- names(map)
+		mpcrossMapped@geneticData[[i]]@probabilities <- new("probabilities", data = resultsMatrix, key = results$key, map = results$map)
 	}
 	return(mpcrossMapped)
 }

R/geneticData-class.R

@@ -1,5 +1,6 @@
 #' @include hetData-class.R
 #' @include pedigree-class.R
+#' @include map-class.R
 checkGeneticData <- function(object)
 {
 	errors <- c()
@@ -131,13 +132,9 @@ checkGeneticData <- function(object)
 	#Check imputed slot
 	if(!is.null(object@imputed))
 	{
-		if(!identical(dim(object@imputed@data), dim(object@finals)))
+		if(!identical(rownames(object@imputed@data), rownames(object@finals)))
 		{
-			return("Dimensions of slot imputed@data must be the same as those of slot finals")
-		}
-		if(!identical(dimnames(object@imputed@data), dimnames(object@finals)))
-		{
-			return("Row and column names of slot imputed@data must be the same as those of slot finals")
+			return("Row names of slot imputed@data must be the same as those of slot finals")
 		}
 		errors <- validObject(object@imputed)
 		if(length(errors) > 0) return(errors)
@@ -154,10 +151,6 @@ checkGeneticData <- function(object)
 		{
 			return("Number of rows of probabilities@data must be consistent with probabilities@key and nrow(finals)")
 		}
-		if(!identical(colnames(object@probabilities@data), markers(object)))
-		{
-			return("Object probabilities@data had the wrong column names")
-		}
 		errors <- validObject(object@probabilities)
 		if(length(errors) > 0) return(errors)
 	}
@@ -177,12 +170,25 @@ checkImputedData <- function(object)
 	{
 		return("Slot key must have three columns")
 	}
+	allMapMarkers <- unlist(lapply(object@map, names))
+	names(allMapMarkers) <- NULL
+	if(!isTRUE(all.equal(allMapMarkers, colnames(object@data))))
+	{
+		return("Slot data must have marker names that match the markers in slot map")
+	}
 	if(!.Call("checkImputedBounds", object, PACKAGE="mpMap2"))
 	{
 		return("Slot imputed@data must contain values in imputed@key")
 	}
+	tmp <- unlist(lapply(object@map, names))
+	names(tmp) <- NULL
+	if(!identical(colnames(object@data), tmp))
+	{
+		return("Column names of imputed object did not match the associated map")
+	}
+	return(TRUE)
 }
-.imputed <- setClass("imputed", slots=list(data = "matrix", key = "matrix"), validity = checkImputedData)
+.imputed <- setClass("imputed", slots=list(data = "matrix", key = "matrix", map = "map"), validity = checkImputedData)
 setClassUnion("imputedOrNULL", c("imputed", "NULL"))
 checkProbabilities <- function(object)
 {
@@ -198,8 +204,15 @@ checkProbabilities <- function(object)
 	{
 		return("Slot key must have three columns")
 	}
+	tmp <- unlist(lapply(object@map, names))
+	names(tmp) <- NULL
+	if(!identical(colnames(object@data), tmp))
+	{
+		return("Column names of probabilities object did not match the associated map")
+	}
+	return(TRUE)
 }
-.probabilities <- setClass("probabilities", slots=list(data = "matrix", key = "matrix"), validity = checkProbabilities)
+.probabilities <- setClass("probabilities", slots=list(data = "matrix", key = "matrix", map = "map"), validity = checkProbabilities)
 setClassUnion("probabilitiesOrNULL", c("probabilities", "NULL"))
 .geneticData <- setClass("geneticData", slots=list(finals = "matrix", founders = "matrix", hetData = "hetData", pedigree = "pedigree", imputed = "imputedOrNULL", probabilities = "probabilitiesOrNULL"), validity = checkGeneticData)
 checkGeneticDataList <- function(object)

R/imputeFounders.R

@@ -1,5 +1,23 @@
 #' @export
-imputeFounders <- function(mpcrossMapped, homozygoteMissingProb = 1, heterozygoteMissingProb = 1, errorProb = 0)
+generateGridPositions <- function(spacing)
+{
+	retFunction <- function(object)
+	{
+		result <- lapply(as.list(names(object@map)), function(chrName)
+			{
+				x <- object@map[[chrName]]
+				range <- range(x)
+				positions <- seq(range[1], range[2], by = spacing)
+				names(positions) <- paste0("Chr", chrName, "Loc", 1:length(positions))
+				positions
+			})
+		names(result) <- names(object@map)
+		result
+	}
+	return(retFunction)
+}
+#' @export
+imputeFounders <- function(mpcrossMapped, homozygoteMissingProb = 1, heterozygoteMissingProb = 1, errorProb = 0, extraPositions = list())
 {
 	isNewMpcrossMappedArgument(mpcrossMapped)
 	if(homozygoteMissingProb < 0 || homozygoteMissingProb > 1)
@@ -14,12 +32,46 @@ imputeFounders <- function(mpcrossMapped, homozygoteMissingProb = 1, heterozygot
 	{
 		stop("Input errorProb must be non-negative and smaller than 1")
 	}
+	map <- mpcrossMapped@map
+	allMarkerNames <- unlist(lapply(map, names))
+
+	#Input extraPositions can be a list or a function
+	if(class(extraPositions) != "list" && class(extraPositions) != "function")
+	{
+		stop("Input extraPositions must be a list or a function that generates a list")
+	}
+	if(class(extraPositions) == "function")
+	{
+		extraPositions <- extraPositions(mpcrossMapped)
+	}
+	if(!all(names(extraPositions) %in% names(map)))
+	{
+		stop("Input extraPositions must be a list, with entries named after chromosomes")
+	}
+	for(chromosome in names(extraPositions))
+	{
+		extraChr <- extraPositions[[chromosome]]
+		if(any(names(extraChr) %in% allMarkerNames))
+		{
+			stop("Extra locations in extraPositions cannot be named after markers")
+		}
+		if(!is.numeric(extraChr))
+		{
+			stop("Input extraPositions must be a list, with entries which are numeric vectors")
+		}
+		if(is.null(names(extraChr)))
+		{
+			stop("Vectors in input extraPositions must have names")
+		}
+		extraPositions[[chromosome]] <- sort(extraChr)
+	}
 	for(i in 1:length(mpcrossMapped@geneticData))
 	{
-		results <- .Call("imputeFounders", mpcrossMapped@geneticData[[i]], mpcrossMapped@map, homozygoteMissingProb, heterozygoteMissingProb, errorProb, PACKAGE="mpMap2")
+		results <- .Call("imputeFounders", mpcrossMapped@geneticData[[i]], mpcrossMapped@map, homozygoteMissingProb, heterozygoteMissingProb, errorProb, extraPositions, PACKAGE="mpMap2")
 		resultsMatrix <- results$data
-		dimnames(resultsMatrix) <- dimnames(mpcrossMapped@geneticData[[i]]@finals)
-		mpcrossMapped@geneticData[[i]]@imputed <- new("imputed", data = resultsMatrix, key = results$key)
+		class(results$map) <- "map"
+		names(results$map) <- names(map)
+		mpcrossMapped@geneticData[[i]]@imputed <- new("imputed", data = resultsMatrix, key = results$key, map = results$map)
 	}
 	return(mpcrossMapped)
 }