[R-sig-eco] order of id's in ltraj object

[Clement Calenge]

On 03/09/2013 12:55 AM, Sebastian P. Luque wrote:
> Hi,
>
> I noticed that as.ltraj() reorders the id's alphanumerically.  However,
> I'd like to keep the order in the input data.frame or
> SpatialPointsDataFrame for plotting purposes.  Is there some way to
> achieve that, except for manipulating the structure of the ltraj object?

There is currently no way to do it, except for manipulating the 
structure of the ltraj object. However, I will submit a new version of 
the package in which the function as.ltraj does not reorder the id's or 
the burst automatically. It will be available on CRAN in a few days. 
Meanwhile, you can use the following function:

as.ltraj <- function(xy, date=NULL, id, burst=id, typeII = TRUE,
                      slsp =  c("remove", "missing"),
                      infolocs = data.frame(pkey = paste(id, date, 
sep=".")))
{
     ## Various verifications
     if (typeII) {
         if (!inherits(date,"POSIXct"))
             stop("For objects of type II,\n date should be of class 
\"POSIXct\"")
     } else {
         date <- 1:nrow(xy)
     }
     if (length(date) != nrow(xy))
         stop("date should be of the same length as xy")

     slsp <- match.arg(slsp)

     ## Length of infolocs, if provided
     if (!is.null(infolocs)) {
         if (nrow(infolocs)!=nrow(xy))
             stop("infolocs should have the same number of rows as xy")
     }


     ## length of id
     if (length(id)==1)
         id <- factor(rep(as.character(id), nrow(xy)))
     if (length(id)!=nrow(xy))
         stop("id should be of the same length as xy, or of length 1")

     ## checks that all levels are present in the data:
     if (min(table(id))==0)
         stop("some id's are not present in the data")

     ## length of burst
     if (length(burst)==1)
         burst <- factor(rep(as.character(burst), nrow(xy)))
     if (length(burst)!=nrow(xy))
         stop("burst should be of the same length as xy, or of length 1")
     ## checks that all levels are present in the data:
     if (min(table(burst))==0)
         stop("some bursts are not present in the data")

     ## Verification that there is only one burst per id
     id1 <- factor(id)
     burst1 <- factor(burst)
     if (!all(apply(table(id1,burst1)>0,2,sum)==1))
         stop("one burst level should belong to only one id level")

     x <- xy[,1]
     y <- xy[,2]
     res <- split(data.frame(x=x,y=y, date=date), burst)
     liid <- split(id, burst)
     if (!is.null(infolocs))
         linfol <- split(infolocs, burst)

     ## sort the dates
     if (!is.null(infolocs))
         linfol <- lapply(1:length(linfol),
                          function(j) 
linfol[[j]][order(res[[j]]$date),,drop=FALSE])
     res <- lapply(res, function(y) y[order(y$date),,drop=FALSE])

     ## Unique dates?
     rr <- any(unlist(lapply(res,
                             function(x) 
(length(unique(x$date))!=length(x$date)))))
     if (rr)
         stop("non unique dates for a given burst")

     ## Unique dates for a given id?
     x <- xy[,1]
     y <- xy[,2]
     resbb <- split(data.frame(x=x,y=y, date=date), id1)
     rr <- any(unlist(lapply(resbb,
                             function(x) 
(length(unique(x$date))!=length(x$date)))))
     if (rr)
         stop("non unique dates for a given id")


     ## Descriptive parameters
     foo <- function(x) {
         x1 <- x[-1, ]
         x2 <- x[-nrow(x), ]
         dist <- c(sqrt((x1$x - x2$x)^2 + (x1$y - x2$y)^2),NA)
         R2n <- (x$x - x$x[1])^2 + (x$y - x$y[1])^2
         dt <- c(unclass(x1$date) - unclass(x2$date), NA)
         dx <- c(x1$x - x2$x, NA)
         dy <- c(x1$y - x2$y, NA)
         abs.angle <- ifelse(dist<1e-07,NA,atan2(dy,dx))
         ## absolute angle = NA if dx==dy==0
         so <- cbind.data.frame(dx=dx, dy=dy, dist=dist,
                                dt=dt, R2n=R2n, abs.angle=abs.angle)
         return(so)
     }

     speed <- lapply(res, foo)
     res <- lapply(1:length(res), function(i) cbind(res[[i]],speed[[i]]))

     ## The relative angle
     ang.rel <- function(df,slspi=slsp) {
         ang1 <- df$abs.angle[-nrow(df)] # angle i-1
         ang2 <- df$abs.angle[-1] # angle i

         if(slspi=="remove"){
             dist <- c(sqrt((df[-nrow(df),"x"] - df[-1,"x"])^2 +
                            (df[-nrow(df),"y"] - df[-1,"y"])^2),NA)
             wh.na <- which(dist<1e-7)
             if(length(wh.na)>0){
                 no.na <- (1:length(ang1))[!(1:length(ang1)) %in% wh.na]
                 for (i in wh.na){
                     indx <- no.na[no.na<i]
                     ang1[i] <- ifelse(length(indx)==0,NA,ang1[max(indx)])
                 }
             }
         }
         res <- ang2-ang1
         res <- ifelse(res <= (-pi), 2*pi+res,res)
         res <- ifelse(res > pi, res -2*pi,res)
         return(c(NA,res))
     }

     ## Output
     rel.angle <- lapply(res, ang.rel)
     res <- lapply(1:length(res),
                   function(i) data.frame(res[[i]], 
rel.angle=rel.angle[[i]]))
     res <- lapply(1:length(res), function(i) {
         x <- res[[i]]
         attr(x, "id") <- as.character(liid[[i]][1])
         attr(x,"burst") <- levels(factor(burst))[i]
         return(x)
     })

     ## And possibly, the data.frame infolocs
     if (!is.null(infolocs)) {
         res <- lapply(1:length(res), function(i) {
             x <- res[[i]]
             y <- linfol[[i]]
             row.names(y) <- row.names(x)
             attr(x, "infolocs") <- y
             return(x)
         })
     }

     ## Output
     class(res) <- c("ltraj","list")
     attr(res,"typeII") <- typeII
     attr(res,"regular") <- is.regular(res)
     return(res)
}


Best,

Clément Calenge

-- 
Clément CALENGE
Cellule d'appui à l'analyse de données
Direction des Etudes et de la Recherche
Office national de la chasse et de la faune sauvage
Saint Benoist - 78610 Auffargis
tel. (33) 01.30.46.54.14