#' @title getKit
#' @author Oskar Hansson
#' @description Function to get kit information. Tidied up and slightly modified by Oyvind Bleka
#' @details Returns kit information
#' @param kit Short name of kit: See supported kits with getKit()
#' @param what Options: {"Index","Panel","Short.Name","Full.Name","Marker","Allele","Size","Virtual","Color","Repeat","Range","Offset","Gender"}
#' @param fileName Name of kit file used to extract kitinformation
#' @param folderName Name of folder containing the kit file 'fileName'. Using package folder if not specified.
#' @return res A data frame with kit information
#' @export
getKit <- function(kit=NULL, what=NA, fileName = "kit.txt", folderName=NULL) {
.separator <- .Platform$file.sep # Platform dependent path separator.
if(is.null(folderName)) {
packagePath <- path.package("euroformix", quiet = FALSE) # Get package path.
folderName <- paste(packagePath,"extdata",sep=.separator) #get folder containing the filename
}
filePath <- paste(folderName, fileName, sep=.separator) #get full pathname of kit file
.kitInfo <- read.delim(file=filePath, header = TRUE, sep = "\t", quote = "\"",dec = ".", fill = TRUE, stringsAsFactors=FALSE)
# Available kits. Must match else if construct.
kits<-unique(.kitInfo$Short.Name)
if (is.null(kit)) { # Check if NULL
res<-kits
} else { # String provided.
# Check if number or string.
if (is.numeric(kit)) {
index<-kit # Set index to number.
} else {
index<-match(toupper(kit),toupper(kits)) # Find matching kit index (case insensitive)
}
if (any(is.na(index))) { # No matching kit.
return(NA)
# Assign matching kit information.
} else {
currentKit <- .kitInfo[.kitInfo$Short.Name==kits[index], ]
res <- data.frame(Panel = currentKit$Panel,
Short.Name = currentKit$Short.Name,
Full.Name = currentKit$Full.Name,
Marker = currentKit$Marker,
Allele = currentKit$Allele,
Size = currentKit$Size,
Size.Min = currentKit$Size.Min,
Size.Max = currentKit$Size.Max,
Virtual = currentKit$Virtual,
Color = currentKit$Color,
Repeat = currentKit$Repeat,
Marker.Min = currentKit$Marker.Min,
Marker.Max = currentKit$Marker.Max,
Offset = currentKit$Offset,
Gender.Marker = currentKit$Gender.Marker,
stringsAsFactors = FALSE)
res$Marker <- factor(res$Marker, levels=unique(res$Marker))# Create useful factors.
}
}
# Kit is required.
if (!is.null(kit)) {
if(is.na(what)){ # Return all kit information.
return(res)
} else if (toupper(what) == "INDEX"){ # Return kit index.
return(index)
} else if (toupper(what) == "PANEL"){ # Return panel name.
return(unique(res$Panel))
} else if (toupper(what) == "SHORT.NAME"){ # Return short name.
return(unique(res$Short.Name))
} else if (toupper(what) == "FULL.NAME"){ # Return full name.
return(unique(res$Full.Name))
} else if (toupper(what) == "MARKER"){ # Return all markers.
return(as.vector(unique(res$Marker)))
} else if (toupper(what) == "ALLELE"){ # Return all alleles and markers.
res <- data.frame(Marker=res$Marker, Allele=res$Allele)
return(res)
} else if (toupper(what) == "SIZE"){
# Returns all alleles and their indicated normal size in base pair.
# Their normal size range is idicated in min and max columns.
# Grouped by marker.
res <- data.frame(Marker=res$Marker,Allele=res$Allele,Size=res$Size, Size.Min=res$Size.Min, Size.Max=res$Size.Max,stringsAsFactors=FALSE)
return(res)
} else if (toupper(what) == "VIRTUAL"){
# Returns all alleles (bins) with a flag if it is virtual
# 1 for virtual or 0 it it is a physical ladder fragment.
# Grouped per marker.
res <- data.frame(Marker=as.character(res$Marker), Allele=res$Allele,Virtual=res$Virtual, stringsAsFactors=FALSE)
return(res)
} else if (toupper(what) == "COLOR"){ # Return markers and their color as strings.
marker <- getKit(kit, what="Marker")
color <- NA
for(m in seq(along=marker)){
color[m] <- unique(res$Color[res$Marker == marker[m]])
}
res <- data.frame(Marker=marker,Color=color,stringsAsFactors=FALSE)
return(res)
} else if (toupper(what) == "REPEAT"){ # Return markers and their repeat unit length in base pair.
marker <- getKit(kit, what="Marker")
offset <- NA
repeatUnit <- NA
for(m in seq(along=marker)){
offset[m] <- unique(res$Offset[res$Marker == marker[m]])
repeatUnit[m] <- unique(res$Repeat[res$Marker == marker[m]])
}
res <- data.frame(Marker=marker, Offset=offset, Repeat=repeatUnit, stringsAsFactors=FALSE)
return(res)
} else if (toupper(what) == "RANGE"){ # Return markers and their range (min and max) in base pair.
marker <- getKit(kit, what="Marker")
markerMin <- NA
markerMax <- NA
color <- NA
for(m in seq(along=marker)){
markerMin[m] <- unique(res$Marker.Min[res$Marker == marker[m]])
markerMax[m] <- unique(res$Marker.Max[res$Marker == marker[m]])
color[m] <- unique(res$Color[res$Marker == marker[m]])
}
res <- data.frame(Marker=marker, Color=color, Marker.Min=markerMin, Marker.Max=markerMax,stringsAsFactors=FALSE)
res$Color <- factor(res$Color, levels=unique(res$Color)) # Create useful factors.
return(res)
} else if (toupper(what) == "OFFSET"){ # Return markers and their estimated offset in base pair.
marker <- getKit(kit, what="Marker")
offset <- NA
repeatUnit <- NA
for(m in seq(along=marker)){
offset[m] <- unique(res$Offset[res$Marker == marker[m]])
repeatUnit[m] <- unique(res$Repeat[res$Marker == marker[m]])
}
res <- data.frame(Marker=marker, Offset=offset, Repeat=repeatUnit,stringsAsFactors=FALSE)
return(res)
} else if (toupper(what) == "GENDER"){ # Return gender marker as string.
genderMarker <- as.character(unique(res$Marker[res$Gender.Marker == TRUE]))
if(length(genderMarker) > 1){
warning(paste("More than one gender marker returned for kit", kit))
}
return(genderMarker)
} else {
warning(paste(what, "not supported! \nwhat = {", options,"}"))
return(NA)
}
} else { # If kit is NULL return available kits.
return(res)
}
} #end function
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.