Nothing
#' Import landmarks and outlines from TPS files
#'
#' Imports outlines and landmarks from files generated by tpsdig2
#'
#'
#' @param file A TPS-file generated by tpsdig2
#' @param scale logical: if TRUE the data will be scaled according to the SCALE entry.
#' @return
#' \item{ID }{Specimen IDs read from TPS file}
#' \item{LM }{list of landmarks contained in the TPS-file}
#' \item{outlines }{a list containing sublists for each specimen with all
#' the outlines read from TPS file}
#' \item{SCALE}{vector containing the scale factors for each landmark config.}
#' @note currently only landmarks, ID and outlines are read from the TPS-file
#' @author Stefan Schlager
#' @seealso \code{\link{read.lmdta}}, \code{\link{read.pts}}
#' @references http://life.bio.sunysb.edu/ee/rohlf/software.html
#'
#' @export
readallTPS <- function(file,scale=TRUE)
{
out=list()
exOut <- FALSE
noutline <- 0
input <- readLines(file)
### get Landmark infos
LM <- grep("LM=",input)
LMstring <- input[LM]
nLM <- sapply(LMstring,strsplit,split="=")
nLM <- unlist(nLM)
nLM <- as.integer(nLM[-which(nLM == "LM")])
nobs <- length(nLM)
### get ID infos
ID <- grep("ID=",input)
IDstring <- input[ID]
nID <- sapply(IDstring,function(x){x <- gsub("=","_",x)})
nID <- gsub(" ","",unlist(nID))
#nID <- nID[-which(nID == "ID")]
##nobs <- length(nID)
out$ID <- nID
### get outline infos
outline <- grep("OUTLINES=",input)
if (length(outline) > 0)
{
exOut <- TRUE
outlinestring <- input[outline]
noutline <- sapply(outlinestring,strsplit,split="=")
noutline <- unlist(noutline)
noutline <- as.integer(noutline[-which(noutline == "OUTLINES")])
LMoutline <- (sapply(outline,function(x){x <- max(which(LM < x))}))
}
### extract Landmarks
LMdata <- list()
for ( i in 1:nobs)
{
if (nLM[i] > 0)
{
LMdata[[i]] <- as.numeric(unlist(strsplit(unlist(input[c((LM[i]+1):(LM[i]+nLM[i]))]),split=" ")))
LMdata[[i]] <- matrix(LMdata[[i]],nLM[i],2,byrow = TRUE)
}
else
LMdata[[i]] <- NA
}
names(LMdata) <- nID
out$LM <- LMdata
### get scale
SCALE <- grep("SCALE=",input)
if (length(SCALE)) {
SCALEstring <- input[SCALE]
nSCALE <- sapply(SCALEstring,function(x){x <- gsub("SCALE=","",x)})
nSCALE <- as.numeric(nSCALE)
#nID <- nID[-which(nID == "ID")]
##nobs <- length(nID)
out$SCALE <- nSCALE
if (scale) {
out$LM <- lapply(1:length(out$LM),function(x) x <- out$LM[[x]]*out$SCALE[x])
names(out$LM) <- nID
}
}
### extract outlines
if (exOut)
{
outlineData <- list()
for ( i in 1:nobs)
{
if (i %in% LMoutline)
{
i1 <- grep(i,LMoutline)
outlinetmp <- list()
ptr <- outline[i1]+1
j <- 1
while (j <= noutline[i1])
{
tmpnr <- as.integer(unlist(strsplit(input[ptr],split="="))[2])
#printmpnr)
outlinetmp[[j]] <- matrix(as.numeric(unlist(strsplit(input[(ptr+1):(ptr+tmpnr)],split=" "))),tmpnr,2,byrow=TRUE)
ptr <- ptr+tmpnr+1
j <- j+1
}
outlineData[[i]] <- outlinetmp
}
else
outlineData[[i]] <- NA
}
names(outlineData) <- nID
out$outlines <- outlineData
}
cat(paste("Read",nobs,"datasets with",sum(noutline),"outlines\n"))
return(out)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.