R/readallTPS.r

In zarquon42b/Morpho: Calculations and Visualisations Related to Geometric Morphometrics

#' 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)
  }