tests/testthat/test_moveCoercion.R
In roland-h/trajaggr: Meaningful Aggregation of Trajectory Data in R
#test_file(paste(getwd(),"/tests/testthat/test_moveCoercion.R", sep=""))
#===============================================================================
#
# JUST RUN THIS TEST FILE
#
#===============================================================================
require(sp)
#require(testthat)
#test_file(paste(getwd(),"/tests/testthat/test_moveCoercion.R", sep=""))
#-------------------------------------------------------------------------------
print(Sys.time())
# devtools::use_data(leroy, leroy) # ok
# devtools::use_data(leroy_bursts_unique, leroy_bursts_unique) # ok
# devtools::use_data(leroy_bursts_rep, leroy_bursts_rep) # ok
# devtools::use_data(leroy_shift, leroy_shift) # ok
# devtools::use_data(leroyMoveStack, leroyMoveStack) # ok
#require(move)
#require(spacetime) # STIDF()
#require(trajectories) # Track()
# #???
# #require(xts)
# #require(circular) # --> summary(moveobject)
#require(testthat)
# ####
#
# #!!! nur wenn ich skript direkt ausführen möchte:
# #(sonst automatisch!)
# require(testthat)
#
# #!!! nur wenn ich skript direkt ausführen möchte:
# #(sonst automatisch)
# source("/home/harry/BSc_Thesis_Traj/R/R_wd/Exploring_PkgCreation/trajcoer_test/trajcoert01/R/moveCoercion.R")
#
#
# !!!
# #Load example data
# #movebank_BCl_Ocelot_ExData.RData for direct use (development)
# load("/home/harry/BSc_Thesis_Traj/R/R_wd/Exploring_PkgCreation/trajcoer_test/trajcoert01/tests/testthat/movebank_BCl_Ocelot_ExData.RData")
# ##move_leroy_extendedOffExData.RData
# ##load("/home/harry/BSc_Thesis_Traj/R/R_wd/Exploring_PkgCreation/trajcoer_test/trajcoert01/tests/testthat/move_leroy_extendedOffExData.RData")
# # !!! # move_pkg_ExData.RData
# load(paste(getwd(), "/tests/testthat/", "move_pkg_ExData.RData", sep=""))
#
# ####
#####
# Load example data from package move
# leroy <- move::move(system.file("extdata", "leroy.csv.gz", package = "move"))
#####
# !!!!!
# Load test data --> testthat needs this data for tests! (Achtung pfad !?)
# Achtung: bobbyMove etc eignet sich nicht für finales package wg copyright !?!?!
# --> TODO ! ??? !
#load("move_pkg_ExData.RData")
#load("movebank_BCl_Ocelot_ExData.RData")
#load("move_leroy_extendedOffExData.RData")
#####
########################
###save
#(leroy, leroyBursts1, leroyBursts2, leroyBursts3, file="move_leroy_extendedOffExData.RData")
#(bobbyMove, bclOcelotMoveStack, file="movebank_BCl_Ocelot_ExData.RData")
#load("movebank_BCl_Ocelot_ExData.RData")
##load(paste("/home/harry/BSc_Thesis_Traj/R/R_wd/Exploring_PkgCreation/trajcoer_test/trajcoert01",
## "/tests/testthat/", "movebank_BCl_Ocelot_ExData.RData", sep=""), verbose = TRUE)
#load(paste(getwd(), "/tests/testthat/", "movebank_BCl_Ocelot_ExData.RData", sep=""), verbose = TRUE)
load("move_pkg_ExData.RData", verbose=T)
#load(paste(getwd(), "/tests/testthat/", "move_pkg_ExData.RData", sep=""), verbose = TRUE)
#load("/home/harry/BSc_Thesis_Traj/R/R_wd/Exploring_PkgCreation/trajcoer_test/trajcoert01/tests/testthat/move_pkg_ExData.RData")
# Loading objects: leroy leroy_bursts_unique leroy_bursts_rep ricky martesPennantiMoveStack leroy_shift leroyMoveStack
data(vulture_moveStack)
#length(vulture_moveStack[[2]])
#length(vulture_moveStack@burstId)
#####
#===============================================================================
#
# PREPARATION
#
#===============================================================================
# TODO /delete
# Creation of further move objects for testing relating to NA values and infolocs
# # delete:
# bclOcelotMoveStack_4TrColl <- bclOcelotMoveStack
# bclOcelotMoveStack_4TrCollTrackIdchar <- as.character(bclOcelotMoveStack_4TrColl@trackId)
# bclOcelotMoveStack_4TrCollTrackIdchar[c(6:10)] <- "Moteado_2"
# bclOcelotMoveStack_4TrCollTrackIdchar[c(2260:2288)] <- "Estrella_2"
# bclOcelotMoveStack_4TrCollTrackIdFact <- as.factor(bclOcelotMoveStack_4TrCollTrackIdchar)
# bclOcelotMoveStack_4TrColl@trackId <- bclOcelotMoveStack_4TrCollTrackIdFact
# class(bclOcelotMoveStack_4TrColl) # MoveStack
# --> macht Problem: idData passt nicht zu trackIds !!!
# --> delete
exMoveStack <- move::moveStack(list(leroy,ricky))
#identical(exMoveStack, martesPennantiMoveStack)#T
#str(exMoveStack)
# # Create another MoveBurst
v_X1_Move <- vulture_moveStack[[1]]
#datesX1 <- as.Date(v_move_1@timestamps)
#datesX1_1 <- datesX1 == datesX1[1]
#day1 <- which(datesX1_1)
day1 <- which(as.Date(v_X1_Move@timestamps) == as.Date(v_X1_Move@timestamps[1]))
#v_X1_Move@data$ground_speed[w]
#sort(v_X1_Move@data$ground_speed[w])
#w_fly <- which(v_X1_Move@data$ground_speed[day1] > 5)
#behav <- vector(mode = "character", length = length(w))
behav <- rep("on_ground", length(day1))
#length(behav)
#behav[w_fly] <- "flying"
behav[which(v_X1_Move@data$ground_speed[day1] > 5)] <- "flying_high"
v_X1_1_Move <- v_X1_Move[day1]
v_X1_1_mb <- move::burst(v_X1_1_Move, f = behav[1:length(behav) - 1])
#length(v_X1_1_mb)
# !!
#v_X1_1_mb_Tracks <- as.Tracks(v_X1_1_mb)
#v_X1_1_mb_Tracks@tracksData
#-------------------------------------------------------------------------------
#===============================================================================
#
# CREATION OF A LIST OF "move" OBJECTS TO BE TESTED
#
#===============================================================================
movePkgObjectsList <- list(vulture_moveStack,
vulture_moveStack[[1]],
v_X1_1_mb,
leroy,
leroy_bursts_unique,
leroy_bursts_rep,
leroy_shift,
leroyMoveStack,
##, ### ??
martesPennantiMoveStack,
##, ### to be deleted (because of file size)
ricky,
##, ### to be deleted, from load("...RData")
#bobbyMove,
#bclOcelotMoveStack,
##, ### additionally created
exMoveStack# identical to martesPennantiMoveStack
##, ### additionally created and to be deleted...
#bclOcelotMoveStack_4TrColl
)
movePkgObjNamesList <- list("vulture_moveStack",
"vulture_moveStack[[1]]",
"v_X1_1_mb",
"leroy",
"leroy_bursts_unique",
"leroy_bursts_rep",
"leroy_shift",
"leroyMoveStack",
##, ### ??
"martesPennantiMoveStack",
###, ### to be deleted (because of file size)
"ricky",
###, ### to be deleted, from load("...RData")
#"bobbyMove",
#"bclOcelotMoveStack",
##, ### additionally created
"exMoveStack"
##, ### additionally created and to be deleted...
#"bclOcelotMoveStack_4TrColl"
)
stopifnot(length(movePkgObjNamesList) == length(movePkgObjectsList))
# !!!ACHTUNG: delete
#movePkgObjectsList <- list(ricky)
#movePkgObjNamesList <- list("ricky")
#===============================================================================
#===============================================================================
#
#
# TESTING ...
#
#
#===============================================================================
#===============================================================================
for (i in 1:length(movePkgObjectsList)) {
#delete
#ltr <- ltrajObjectsList[[1]]
#ltrName <- ltrajObjNamesList[[1]]
moveObj <- movePkgObjectsList[[i]]
moveObjName <- movePkgObjNamesList[[i]]
#delete
# moveObj <- bclOcelotMoveStack
# moveObjName <- "bclOcelotMoveStack"
#===============================================================================
#-------------------------------------------------------------------------------
#
# TESTING COERCION FROM MOVE TO TRACK
#
#-------------------------------------------------------------------------------
#===============================================================================
if (is(moveObj, "Move")) {
#===============================================================================
#
context(paste("moveCoercion.R: TEST COERCION FROM MOVE (", moveObjName,
") TO TRACK OBJECT:", sep = ""))
#
#===============================================================================
test_that(paste("Test coercion of object ", moveObjName, " to Track object:", sep=""), {
##
# Test as(moveObj,"Track") (Move object from example data to Track object)
myTrack <- as(moveObj, "Track")
# Test classes
expect_that(moveObj, is_a("Move"))
expect_that(myTrack, is_a("Track"))
# Test length
expect_that(length(moveObj), is_identical_to(length(myTrack)))
# Test data
expect_that(moveObj@data[,1], is_identical_to(myTrack@data[,1]))
expect_that(moveObj@data, is_identical_to(myTrack@data))
# Test time
#expect_that(moveObj@timestamps, is_equivalent_to(zoo::index(myTrack@time))) # ignores attributes
expect_true(all.equal(moveObj@timestamps, zoo::index(myTrack@time), check.attributes = F))
#expect_that(moveObj@timestamps, is_identical_to(index(myTrack@time))) # Diff: attributes: < Length mismatch: comparison on first 1 components >
myTime <- zoo::index(myTrack@time)
attr(myTime, "tclass") <- NULL
expect_that(moveObj@timestamps, is_identical_to(myTime))
## delete
#expect_that(moveObj@timestamps, is_identical_to(
# as.POSIXct(strptime(as.POSIXct(zoo::index(myTrack@time)),
# format = format(as.POSIXct(zoo::index(myTrack@time))))))) # Diff: attributes: < Length mismatch: comparison on first 1 components >
#moveObj@timestamps[1:5]
#as.POSIXct(strptime(as.character(zoo::index(myTrack@time)),
# format = format(as.POSIXct(zoo::index(myTrack@time)))))[1:5]
#as.POSIXct(strptime(as.character(zoo::index(myTrack@time)),
# format = format(zoo::index(myTrack@time))[1]))
#format = format(zoo::index(myTrack@time))[1]
### ???
# Test geometry
#expect_that(geometry(moveObj), is_equivalent_to(geometry(myTrack))) # ignores attributes
#expect_that(geometry(moveObj), is_identical_to(geometry(myTrack))) # ignores attributes
expect_that(geometry(moveObj), is_identical_to(geometry(myTrack@sp)))
})
} # Finish if (is(obj, Move))
#===============================================================================
#-------------------------------------------------------------------------------
#
# TESTING COERCION FROM MOVESTACK TO TRACKS AND TRACKSCOLLECTION
#
#-------------------------------------------------------------------------------
#===============================================================================
if (is(moveObj, "MoveStack")) {
#===============================================================================
#
context(paste("moveCoercion.R: TEST COERCION FROM MOVESTACK (", moveObjName,
") TO TRACKS OBJECT:", sep = ""))
#
#===============================================================================
test_that(paste("Test coercion of object ", moveObjName, " to Tracks object:", sep=""), {
# ??? !!!
# delete
#moveObj <- martesPennantiMoveStack
#moveObj <- vulture_moveStack
#Tr_alternativ <- moveStackToTracks(moveObj)
# Test as(moveObj,"Tracks") (MoveStack object to Tracks object)
myTracks <- as(moveObj, "Tracks")
# # ??? !!!
# #delete
# expect_that(Tr_alternativ, is_equivalent_to(myTracks)) # T
# #attr(moveObj@coords, "dimnames")[[2]] # [1] "location.long" "location.lat"
# #attr(myTracks@tracks[[1]]@sp@coords, "dimnames")[[2]] # [1] "location.long" "location.lat"
# #attr(Tr_alternativ@tracks[[1]]@sp@coords, "dimnames")[[2]] # [1] "coords.x1" "coords.x2"
# # row.names in @data identisch!?
# #attr(moveObj@idData, "row.names") #
# #attr(myTracks@tracksData, "row.names") #
# #attr(Tr_alternativ@tracksData, "row.names") #
# # ...
# #expect_that(Tr_alternativ, equals(myTracks)) #
# #expect_that(Tr_alternativ, is_identical_to(myTracks))
# # TODO Problems in names, dimnames, ? factor?, rownames?,
#
#
# # Test names (TrackNames)
# #expect_that(names(Tr_alternativ@tracks), is_identical_to(names(myTracks@tracks)))
# # TrackNames: Leroy vs. Track1_Leroy --> was ist besser???
# # But in general names are ok!
#
# # Test row.names
# expect_that(row.names(Tr_alternativ@tracks[[1]]@data),
# is_identical_to(row.names(myTracks@tracks[[1]]@data)))
# #expect_that(row.names(Tr_alternativ@tracksData),
# # is_identical_to(row.names(myTracks@tracksData)))
# # --> not identical, wegen konsequenzen aus names (s.o.)
# # But in general names are ok!
#
# #!!! --> (bisher) keine (gravierenden) Unterschiede in Tests
# # --> !?!?! Tests nicht gut genug? What about factor data, dimnames, ...?
# myTracks <- Tr_alternativ
# Test classes
expect_that(moveObj, is_a("MoveStack"))
expect_that(myTracks, is_a("Tracks"))
# Test length
trackIds <- unique(moveObj@trackId)
nrTrId1 <-
length(moveObj@trackId[moveObj@trackId == trackIds[1]])
nrTrId2 <-
length(moveObj@trackId[moveObj@trackId == trackIds[2]])
expect_that(length(moveObj),
is_identical_to(sum(myTracks@tracksData$n)))
expect_that(nrTrId1, is_identical_to(myTracks@tracksData$n[1]))
expect_that(nrTrId1, is_identical_to(length(myTracks@tracks[[1]])))
expect_that(nrTrId2, is_identical_to(myTracks@tracksData$n[2]))
expect_that(nrTrId2, is_identical_to(length(myTracks@tracks[[2]])))
expect_that(length(unique(moveObj@trackId)),
is_identical_to(length(myTracks@tracks)))
# Test data
expect_that(moveObj@data[1,1],
is_identical_to(myTracks@tracks[[1]]@data[1,1]))
expect_that(moveObj@data[1:2, ],
is_identical_to(myTracks@tracks[[1]]@data[1:2, ]))
# Further data testing needs helping objects:
# delete: warum, wo kommen diese attribute her??? --> Tracks()
dataList <- lapply(myTracks@tracks, function(x) x@data)
dataTrcs <- do.call(rbind, dataList)
expect_that(moveObj@data, is_equivalent_to(dataTrcs))
#expect_that(moveObj@data, is_identical_to(dataTrcs)) # Diff: rownames
##
# Test time (time reordered in case of as(..., "xts")!)
expect_that(as.numeric(moveObj@timestamps),
is_equivalent_to(unlist(lapply(myTracks@tracks,
function(x) zoo::index(x@time))))) # ignores attributes
#expect_that(as.numeric(moveObj@timestamps),
# is_identical_to(unlist(sapply(myTracks@tracks, function(x) index(x@time)))))
# --> Diff: names for target but not for current
expect_that(moveObj@timestamps[1],
is_equivalent_to(zoo::index(myTracks@tracks[[1]]@time)[1])) # ignores attributes
#expect_that(moveObj@timestamps[1],
# is_equivalent_to(zoo::index(as(myTracks@tracks[[1]], "xts")[1]))) # ignores attributes
expect_true(all.equal(moveObj@timestamps[1], zoo::index(as(myTracks@tracks[[1]], "xts")[1]),
check.attributes = F))
#expect_that(moveObj@timestamps[1], is_identical_to(index(as(myTracks, "xts")[1])))
# --> Diff: Attributes: < Length mismatch: comparison on first 1 components >
# not always equivalent if different Track objects are tracked synchron at similar / overlapping periods
tracks_len_time <- length(unlist(lapply(myTracks@tracks, function(x) zoo::index(x@time)))) # 1838
moveStack_len_time <- length(moveObj[[1]]@timestamps)
#expect_that(moveObj@timestamps[moveStack_len_time],
# is_equivalent_to(zoo::index(as(myTracks, "xts")[tracks_len_time]))) # ignores attributes
#expect_that(moveObj@timestamps[moveStack_len_time],
# is_identical_to(zoo::index(as(myTracks, "xts")[tracks_len_time])))
myTime <- zoo::index(as(myTracks, "xts")[tracks_len_time])
attr(myTime, "tclass") <- NULL
#expect_that(moveObj@timestamps[moveStack_len_time], equals(myTime))
myTime <- zoo::index(as(myTracks[1], "xts"))
attr(myTime, "tclass") <- NULL
expect_that(moveObj[[1]]@timestamps, equals(myTime))
#expect_that(moveObj@timestamps[moveStack_len_time], is_identical_to(myTime)) # nicht immer !?!
# delete: problem bei: leroyMoveStack, martesPennantiMoveStack
myl <- lapply(myTracks@tracks, function(x) zoo::index(x@time))
v <- myl[[1]]
if (length(myl) > 1){
for (i in 2:length(myl)) { v <- c(v, myl[[i]]) }
}
timez <- attr(moveObj@timestamps, "tzone")
attr(v, "tzone") <- timez
expect_that(moveObj@timestamps, is_equivalent_to(v))
expect_equal(moveObj@timestamps, v)
##
# Test geometry
expect_that(geometry(moveObj),
is_equivalent_to(geometry(as(myTracks, "Spatial")))) # ignores attributes
#expect_that(geometry(moveObj), is_identical_to(geometry(as(myTracks, "Spatial"))))
# --> Attributes dimnames
#Test tracksData
moveColNames <- colnames(moveObj@idData)
#myTrColNames <- colnames(myTracks@tracksData)
expect_that(moveObj@idData, is_equivalent_to(myTracks@tracksData[ , moveColNames]))
#expect_that(moveObj@idData, is_identical_to(myTracks@tracksData[ , moveColNames]))
# --> row.names adjusted related to Track names
#delete:
#attr(moveObj@idData, "row.names")
#attr(myTracks@tracksData, "row.names")
})
#===============================================================================
#
context(paste("moveCoercion.R: TEST COERCION FROM MOVESTACK (", moveObjName,
") TO TRACKSCOLLECTION OBJECT:", sep = ""))
#
#===============================================================================
test_that(paste("Test coercion of object ", moveObjName, " to TracksCollection object:", sep=""), {
# !!!
# Changed order of current und target : myTrColl ..is_ident... to moveObj
# !!!
#moveObj <- bclOcelotMoveStack
#moveObj <- martesPennantiMoveStack
#moveObj <- vulture_moveStack
#TrColl_alternativ <- moveStackToTracksColl(moveObj)
# Test as(moveObj,"TracksCollection") (MoveStack object to TracksCollection object)
myTrColl <- as(moveObj, "TracksCollection")
# expect_that(TrColl_alternativ, is_equivalent_to(myTrColl)) # T
# #expect_that(TrColl_alternativ, is_identical_to(myTrColl)) # F
# #Attributes: < Component “tracksCollection”: Names: 2 string mismatches
# # ...bbox und coords dimnames !?!? und weiteres (Ausgabe erscheint abgeschniten?!?)?
#
# # Test names (TrackNames, TracksNames)
# # Just equivalent because (still) different TracksNames
# expect_that(sapply(TrColl_alternativ@tracksCollection, function(x) names(x@tracks)),
# is_equivalent_to(sapply(myTrColl@tracksCollection, function(x) names(x@tracks))))
# #expect_that(names(TrColl_alternativ@tracksCollection),
# # is_equivalent_to(names(myTrColl@tracksCollection)))
# # But in general names are ok!
#
# # Test row.names
# expect_that(row.names(TrColl_alternativ@tracksCollection[[1]]@tracks[[1]]@data),
# is_identical_to(row.names(myTrColl@tracksCollection[[1]]@tracks[[1]]@data)))
# #expect_that(row.names(TrColl_alternativ@tracksCollectionData),
# # is_identical_to(row.names(myTrColl@tracksCollectionData))) # wie oben bei names!!!
# expect_that(row.names(TrColl_alternativ@tracksCollection[[1]]@tracksData),
# is_identical_to(row.names(myTrColl@tracksCollection[[1]]@tracksData)))
# # # But in general names are ok!
#
# ## Achtung TODO or delete: in new approach with move::split not identical /
# ## equivalent any more...!!! ??? !!!
# ## Factors in TracksData: u.U. mehr Levles/Factors als Ausprägungen
# ##str(TrColl_alternativ@tracksCollection[[1]]@tracksData) #--> ok!
# #for (i in seq_along(TrColl_alternativ@tracksCollection)) {
# # for (j in seq_along(TrColl_alternativ@tracksCollection[[i]]@tracksData))
# # if (is.factor(TrColl_alternativ@tracksCollection[[i]]@tracksData[[j]])) {
# # expect_that(length(levels(TrColl_alternativ@tracksCollection[[i]]@tracksData[[j]])),
# # is_identical_to(
# # length(unique(TrColl_alternativ@tracksCollection[[i]]@tracksData[[j]]))))
# # }
# #}
#
#
# #!!! --> (bisher) keine (gravierenden) Unterschiede in Tests
# # --> !?!?! Tests nicht gut genug? What about factor data, dimnames, ...?
# myTrColl <- TrColl_alternativ
# Test classes
expect_that(moveObj, is_a("MoveStack"))
expect_that(myTrColl, is_a("TracksCollection"))
# Test length
trackIds <- unique(moveObj@trackId)
nrTrId1 <-
length(moveObj@trackId[moveObj@trackId == trackIds[1]])
nrTrId2 <-
length(moveObj@trackId[moveObj@trackId == trackIds[2]])
expect_that(sum(sapply(myTrColl@tracksCollection,
function(x) x@tracksData$n)),
is_identical_to(length(moveObj)))
#delete
#expect_that(length(moveObj),
# is_identical_to(sum(sapply(myTrColl@tracksCollection,
# function(x) x@tracksData$n))))
expect_that(myTrColl@tracksCollection[[1]]@tracksData$n[1],
is_identical_to(nrTrId1))
expect_that(length(myTrColl@tracksCollection[[1]]@tracks[[1]]),
is_identical_to(nrTrId1))
expect_that(myTrColl@tracksCollection[[2]]@tracksData$n,
is_identical_to(nrTrId2))
expect_that(length(myTrColl@tracksCollection[[2]]@tracks[[1]]),
is_identical_to(nrTrId2))
expect_that(length(myTrColl@tracksCollection),
is_identical_to(length(unique(moveObj@trackId))))
expect_that(nrow(myTrColl@tracksCollectionData),
is_identical_to(length(unique(moveObj@trackId))))
# !!! delete: Order of cur , target changed
#expect_that(nrTrId1,
## is_identical_to(
# myTrColl@tracksCollection[[1]]@tracksData$n[1]))
#expect_that(nrTrId1,
# is_identical_to(
# length(myTrColl@tracksCollection[[1]]@tracks[[1]])))
#expect_that(nrTrId2,
# is_identical_to(
# myTrColl@tracksCollection[[2]]@tracksData$n))
#expect_that(nrTrId2,
# is_identical_to(
# length(myTrColl@tracksCollection[[2]]@tracks[[1]])))
#expect_that(length(unique(moveObj@trackId)),
# is_identical_to(length(myTrColl@tracksCollection)))
#expect_that(length(unique(moveObj@trackId)),
# is_identical_to(nrow(myTrColl@tracksCollectionData)))
# ...
# Test data
expect_that(myTrColl@tracksCollection[[1]]@tracks[[1]]@data[1,1],
is_identical_to(moveObj@data[1,1]))
#expect_that(moveObj@data[1,1],
# is_identical_to(
# myTrColl@tracksCollection[[1]]@tracks[[1]]@data[1,1]))
# Further data testing needs helping objects:
origDataColnames <- colnames(moveObj@data)
myTrColl_df <- as(myTrColl, "data.frame")
myTrColl_df_clean <-
myTrColl_df[!is.na(myTrColl_df[origDataColnames[1]]),
origDataColnames]
#expect_that(myTrColl_df_clean,
# is_identical_to(moveObj@data))
# --> not due to row.names
expect_that(myTrColl_df_clean,
is_equivalent_to(moveObj@data))
#expect_that(moveObj@data,
# is_equivalent_to(myTrColl_df_clean))
#expect_that(moveObj@data, is_identical_to(myTrColl_df_clean)) # Diff: rownames
#attr(moveObj@data, "row.names") # numeric 1:2288
#attr(myTrColl_df_clean, "row.names")# "Tracks_Estrella.Track1_Estrella.361"
# werden bei TracksColl() gesetzt!
##
# Test time (time reordered in case of as(..., "xts")!)
expect_that(
unlist(lapply(myTrColl@tracksCollection, function(x) {
zoo::index(x@tracks[[1]]@time) })),
is_equivalent_to(as.numeric(moveObj@timestamps)))
#expect_that(as.numeric(moveObj@timestamps),
# is_equivalent_to(
# unlist(lapply(myTrColl@tracksCollection, function(x) {
# zoo::index(x@tracks[[1]]@time) })))) # ignores attributes
#expect_that(as.numeric(moveObj@timestamps), is_identical_to(unlist(sapply(myTrColl@tracksCollection, function(x) zoo::index(x@tracks[[1]]@time))))) # Diff: names for target but not for current
#names(zoo::index(myTrColl@tracksCollection[[1]]@tracks[[1]]@time)) # --> NULL ??
#names(moveObj@timestamps)#, "row.names")# --> NULL ??
#expect_that(zoo::index(as(myTrColl, "xts")[1]),
# is_equivalent_to(moveObj@timestamps[1])) # ignores attributes
#expect_that(zoo::index(as(myTrColl[1], "xts")),
# is_equivalent_to(moveObj[[1]]@timestamps)) # ignores attributes
expect_true(all.equal(zoo::index(as(myTrColl[1], "xts")),
moveObj[[1]]@timestamps, check.attributes = F)) # ignores attributes
#expect_that(moveObj@timestamps[1],
# is_equivalent_to(zoo::index(as(myTrColl, "xts")[1]))) # ignores attributes
#expect_that(moveObj@timestamps[1], is_identical_to(zoo::index(as(myTrColl, "xts")[1]))) # Diff: Attributes: < Length mismatch: comparison on first 1 components >
#trColl_len_time <- length(unlist(lapply(
# myTrColl@tracksCollection, function(x) {
# zoo::index(x@tracks[[1]]@time) }))) # 1838
#moveStack_len_time <- length(moveObj@timestamps)
#expect_that(zoo::index(as(myTrColl, "xts")[trColl_len_time]),
# is_equivalent_to(moveObj@timestamps[moveStack_len_time])) # ignores attributes
#expect_that(moveObj@timestamps[moveStack_len_time],
# is_equivalent_to(zoo::index(as(myTrColl, "xts")[trColl_len_time]))) # ignores attributes
#myl <- sapply(myTrColl@tracksCollection,
# function(x) index(x@tracks[[1]]@time))
#v <- myl[[1]]
#if (length(myl) > 1) {
# for (i in 2:length(myl)) { v <- c(v, myl[[i]]) }
#}
myl <- lapply(myTrColl@tracksCollection,
function(x) zoo::index(x@tracks[[1]]@time))
v <- myl[[1]]
if (length(myl) > 1) {
for (i in 2:length(myl)) { v <- c(v, myl[[i]]) }
}
timez <- attr(moveObj@timestamps, "tzone")
attr(v, "tzone") <- timez
expect_that(v, is_equivalent_to(moveObj@timestamps))
expect_equal(v, moveObj@timestamps)
#expect_that(moveObj@timestamps, is_equivalent_to(v))
#expect_equal(moveObj@timestamps, v)
##
# Test geometry
expect_that(geometry(as(myTrColl, "Spatial")),
is_equivalent_to(geometry(moveObj))) # ignores attributes
#expect_that(geometry(moveObj),
# is_equivalent_to(geometry(as(myTrColl, "Spatial")))) # ignores attributes
#expect_equal(geometry(moveObj), geometry(as(myTrColl, "Spatial"))) # ...
#expect_that(geometry(moveObj), is_identical_to(as(myTrColl, "Spatial"))) # ...
#Test tracksData
moveColNames <- colnames(moveObj@idData)
#myTrColNames <- colnames(myTracks@tracksData)
expect_that(myTrColl@tracksCollectionData[ , moveColNames], is_equivalent_to(moveObj@idData))
#expect_that(myTrColl@tracksCollectionData[ , moveColNames], is_identical_to(moveObj@idData))
# --> row.names adjusted related to Track names
#expect_that(moveObj@idData, is_equivalent_to(myTracks@tracksData[ , moveColNames]))
#expect_that(moveObj@idData, is_identical_to(myTracks@tracksData[ , moveColNames]))
})
} # Finish if (is(obj, MoveStack))
#===============================================================================
#-------------------------------------------------------------------------------
#
# TESTING COERCION FROM MOVEBURST TO TRACK AND TRACKS
#
#-------------------------------------------------------------------------------
#===============================================================================
if (is(moveObj, "MoveBurst")) {
#===============================================================================
#
context(paste("moveCoercion.R: TEST COERCION FROM MOVEBURST (", moveObjName,
") TO TRACK OBJECT:", sep = ""))
#
#===============================================================================
test_that(paste("Test coercion of object ", moveObjName, " to Track object:", sep=""), {
##
# Test as(MoveBurst, "Track") (MoveBurst object to Track object)
myTrackFromBursts <- as(moveObj, "Track")
# Test classes
expect_that(moveObj, is_a("MoveBurst"))
expect_that(myTrackFromBursts, is_a("Track"))
# Test length
expect_that(length(moveObj), is_identical_to(length(myTrackFromBursts)))
expect_that(length(moveObj@burstId),
is_identical_to(nrow(myTrackFromBursts@connections)))
# Test data
expect_that(moveObj@data[,1], is_identical_to(myTrackFromBursts@data[,1]))
expect_that(moveObj@data, is_identical_to(myTrackFromBursts@data))
# Test time
#expect_that(moveObj@timestamps,
# is_equivalent_to(zoo::index(myTrackFromBursts@time))) # ignores attributes
#expect_true(all.equal(moveObj@timestamps,
# zoo::index(myTrackFromBursts@time), check.attributes = F)) # ignores attributes
expect_true(all.equal(zoo::index(myTrackFromBursts@time),
moveObj@timestamps, check.attributes = F)) # ignores attributes
#expect_that(moveObj@timestamps, is_identical_to(zoo::index(myTrackFromBursts@time))) # Diff: attributes: < Length mismatch: comparison on first 1 components >
##
# Test geometry
expect_that(geometry(moveObj),
is_equivalent_to(geometry(myTrackFromBursts))) # ignores attributes
expect_that(geometry(moveObj), is_identical_to(geometry(myTrackFromBursts@sp))) # Diff: Attributes
expect_equal(geometry(moveObj), geometry(myTrackFromBursts@sp))
expect_that(geometry(moveObj),
is_equivalent_to(geometry(myTrackFromBursts@sp)))
})
#===============================================================================
#
context(paste("moveCoercion.R: TEST COERCION FROM MOVEBURST (", moveObjName,
") TO TRACKS OBJECT:", sep = ""))
#
#===============================================================================
test_that(paste("Test coercion of object ", moveObjName, " to Tracks object:", sep=""), {
#Alternativer Ansatz
#moveObj <- leroy_bursts_rep
#moveObjName <- "leroy_bursts_rep"
#moveObj <- v_X1_1_mb
#moveObjName <- "v_X1_1_mb"
nrOfBursts <- switch(moveObjName, leroy_bursts_rep = 5, leroy_bursts_unique = 4,
v_X1_1_mb = 3)
seqOfBursts <- switch(moveObjName,
leroy_bursts_rep = factor(c("A", "B", "C", "A", "C")),
leroy_bursts_unique = factor(c("part_1", "part_2", "part_3", "part_4")),
v_X1_1_mb = factor(c("on_ground", "flying_high", "on_ground")))
nrOfBurstTypes <- length(unique(move::burst(moveObj)))
######################
# Test as(MoveBurst, "Tracks") (MoveBurst object from example data to Tracks object)
# Burst IDs might not be unique. That means that a burst type may appear several times.
#str(leroy_bursts_rep)
#moveObjName <- "leroy_bursts_unique"
#moveObj <- leroy_bursts_unique
#length(moveObj) # 919
#length(moveObj@burstId) # 918
#uniqueBurstId <- unique(moveObj@burstId) # length = 4
#sum(myTracksOfBursts@tracksData$n) # 922
#nrOfBurstTypes <- 3
#nrOfBursts <- 5
#######################
# ALternative (alter / erster Ansatz):
# Approaches differ just in implementation and not in results
#TrOfMoveBurst_alternativ <- moveBurstToTracks(moveObj)
#TrOfMoveBurst_alternativ@tracksData
#row.names(TrOfMoveBurst_alternativ@tracksData)
# Test as(moveObj,"Tracks") (MoveBurst object to Tracks object)
myTracksOfBursts <- as(moveObj,"Tracks")
# expect_that(TrOfMoveBurst_alternativ, is_equivalent_to(myTracksOfBursts))
# #expect_that(TrOfMoveBurst_alternativ, equals(myTracksOfBursts))
# #expect_that(TrOfMoveBurst_alternativ, is_identical_to(myTracksOfBursts))
# # --> Fehler in as.POSIXct.numeric(current) : 'origin' must be supplied
# # --> !!? wieso nur hier und nicht bei den anderen coercions???
#
# # Test names
# # Achtung uNterschied: 1.Impl: names verändert --> e.g. "Burst1_part_1"
# # ... 2. impl. (zuerst: names = burstIds) aber burstIds könne mehrfach auftreten,
# # daher muss ich die anpassen..!
# expect_that(names(TrOfMoveBurst_alternativ@tracks), is_identical_to(names(myTracksOfBursts@tracks)))
# expect_that(TrOfMoveBurst_alternativ@tracksData$burstId, is_identical_to(seqOfBursts))
#
# # Test row.names
# expect_that(row.names(TrOfMoveBurst_alternativ@tracks[[1]]@data),
# is_identical_to(row.names(myTracksOfBursts@tracks[[1]]@data)))
# expect_that(row.names(TrOfMoveBurst_alternativ@tracksData),
# is_identical_to(row.names(myTracksOfBursts@tracksData))) # wie oben bei names!!!
# expect_that(TrOfMoveBurst_alternativ@tracksData$burstId, is_identical_to(seqOfBursts))
############
# !!!!!!!!!!!!
# This decides which approach is further tested..!!!
# !!! ???
#myTracksOfBursts <- TrOfMoveBurst_alternativ
###########
# Test classes
expect_that(moveObj, is_a("MoveBurst"))
expect_that(myTracksOfBursts, is_a("Tracks"))
# Test length
expect_that(length(moveObj),
equals(sum(myTracksOfBursts@tracksData$n)
- nrOfBursts + 1))
expect_that(length(moveObj@burstId),
is_identical_to(sum(sapply(myTracksOfBursts@tracks, function(x) {
nrow(x@connections)
}))))
expect_that(nrOfBurstTypes,
equals(
length(unique(myTracksOfBursts@tracksData$burst))))
expect_that(nrOfBursts,
equals(length(myTracksOfBursts@tracksData$burst)))
expect_that(nrOfBursts,
equals(length(myTracksOfBursts@tracks)))
# Test data
expect_that(moveObj@data[1,1],
is_identical_to(myTracksOfBursts@tracks[[1]]@data[1,1]))
expect_that(moveObj@data[nrow(moveObj@data),1],
is_identical_to(
myTracksOfBursts@tracks[[nrOfBursts]]@data
[nrow(myTracksOfBursts@tracks[nrOfBursts][[1]]@data),1]))
origDataLength <- length(moveObj@data)
expect_that(moveObj@data[nrow(moveObj@data),origDataLength],
is_identical_to(
myTracksOfBursts@tracks[[nrOfBursts]]@data
[nrow(myTracksOfBursts@tracks[nrOfBursts][[1]]@data),
origDataLength]))
expect_that(moveObj@data[1,],
is_identical_to(myTracksOfBursts@tracks[[1]]@data[1,]))
# Test time
#expect_that(moveObj@timestamps[1],
# is_equivalent_to(zoo::index(myTracksOfBursts@tracks[[1]]@time[1]))) # ignores attributes
expect_true(all.equal(moveObj@timestamps[1],
zoo::index(myTracksOfBursts@tracks[[1]]@time[1]), check.attributes = F)) # ignores attributes
expect_that(as.numeric(moveObj@timestamps),
is_equivalent_to(
unique(unlist(sapply(myTracksOfBursts@tracks, function(x) {
zoo::index(x@time)
}))))) # ignores attributes
myl <- sapply(myTracksOfBursts@tracks, function(x) zoo::index(x@time))
v <- myl[[1]]
if (length(myl) > 1) {
for (i in 2:length(myl)) { v <- c(v, myl[[i]]) }
}
v_unique <- unique(v)
timez <- attr(moveObj@timestamps, "tzone")
attr(v_unique, "tzone") <- timez
expect_that(moveObj@timestamps, is_equivalent_to(v_unique))
# Test geometry
expect_that(class(geometry(moveObj)),
is_identical_to(
class(geometry(as(myTracksOfBursts, "Spatial")))))
expect_that(bbox(moveObj),
is_equivalent_to(bbox(as(myTracksOfBursts, "Spatial")))) # ignores attributes
tr_x_coords <- unlist(sapply(
myTracksOfBursts@tracks, function(x) x@sp@coords[ ,1]))
tr_y_coords <- unlist(sapply(
myTracksOfBursts@tracks, function(x) x@sp@coords[ ,2]))
names(tr_x_coords) <- names(tr_y_coords) <- NULL
expect_that(unique(moveObj@coords[ ,1]),
is_identical_to(
unique(unlist(sapply(myTracksOfBursts@tracks, function(x) {
x@sp@coords[ ,1]
})))))
expect_that(unique(moveObj@coords[ ,2]),
is_identical_to(
unique(unlist(sapply(myTracksOfBursts@tracks, function(x) {
x@sp@coords[ ,2]
})))))
# Test burst names in tracksData
expect_that(myTracksOfBursts@tracksData[ , "burstId"], is_identical_to(seqOfBursts))
})
} # Finish if (is(moveObj, "MoveBurst"))
} # Finish for loop
print(Sys.time())
roland-h/trajaggr documentation built on Jan. 19, 2021, 1:02 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
#test_file(paste(getwd(),"/tests/testthat/test_moveCoercion.R", sep=""))
#===============================================================================
#
# JUST RUN THIS TEST FILE
#
#===============================================================================
require(sp)
#require(testthat)
#test_file(paste(getwd(),"/tests/testthat/test_moveCoercion.R", sep=""))
#-------------------------------------------------------------------------------
print(Sys.time())
# devtools::use_data(leroy, leroy) # ok
# devtools::use_data(leroy_bursts_unique, leroy_bursts_unique) # ok
# devtools::use_data(leroy_bursts_rep, leroy_bursts_rep) # ok
# devtools::use_data(leroy_shift, leroy_shift) # ok
# devtools::use_data(leroyMoveStack, leroyMoveStack) # ok
#require(move)
#require(spacetime) # STIDF()
#require(trajectories) # Track()
# #???
# #require(xts)
# #require(circular) # --> summary(moveobject)
#require(testthat)
# ####
#
# #!!! nur wenn ich skript direkt ausführen möchte:
# #(sonst automatisch!)
# require(testthat)
#
# #!!! nur wenn ich skript direkt ausführen möchte:
# #(sonst automatisch)
# source("/home/harry/BSc_Thesis_Traj/R/R_wd/Exploring_PkgCreation/trajcoer_test/trajcoert01/R/moveCoercion.R")
#
#
# !!!
# #Load example data
# #movebank_BCl_Ocelot_ExData.RData for direct use (development)
# load("/home/harry/BSc_Thesis_Traj/R/R_wd/Exploring_PkgCreation/trajcoer_test/trajcoert01/tests/testthat/movebank_BCl_Ocelot_ExData.RData")
# ##move_leroy_extendedOffExData.RData
# ##load("/home/harry/BSc_Thesis_Traj/R/R_wd/Exploring_PkgCreation/trajcoer_test/trajcoert01/tests/testthat/move_leroy_extendedOffExData.RData")
# # !!! # move_pkg_ExData.RData
# load(paste(getwd(), "/tests/testthat/", "move_pkg_ExData.RData", sep=""))
#
# ####
#####
# Load example data from package move
# leroy <- move::move(system.file("extdata", "leroy.csv.gz", package = "move"))
#####
# !!!!!
# Load test data --> testthat needs this data for tests! (Achtung pfad !?)
# Achtung: bobbyMove etc eignet sich nicht für finales package wg copyright !?!?!
# --> TODO ! ??? !
#load("move_pkg_ExData.RData")
#load("movebank_BCl_Ocelot_ExData.RData")
#load("move_leroy_extendedOffExData.RData")
#####
########################
###save
#(leroy, leroyBursts1, leroyBursts2, leroyBursts3, file="move_leroy_extendedOffExData.RData")
#(bobbyMove, bclOcelotMoveStack, file="movebank_BCl_Ocelot_ExData.RData")
#load("movebank_BCl_Ocelot_ExData.RData")
##load(paste("/home/harry/BSc_Thesis_Traj/R/R_wd/Exploring_PkgCreation/trajcoer_test/trajcoert01",
## "/tests/testthat/", "movebank_BCl_Ocelot_ExData.RData", sep=""), verbose = TRUE)
#load(paste(getwd(), "/tests/testthat/", "movebank_BCl_Ocelot_ExData.RData", sep=""), verbose = TRUE)
load("move_pkg_ExData.RData", verbose=T)
#load(paste(getwd(), "/tests/testthat/", "move_pkg_ExData.RData", sep=""), verbose = TRUE)
#load("/home/harry/BSc_Thesis_Traj/R/R_wd/Exploring_PkgCreation/trajcoer_test/trajcoert01/tests/testthat/move_pkg_ExData.RData")
# Loading objects: leroy leroy_bursts_unique leroy_bursts_rep ricky martesPennantiMoveStack leroy_shift leroyMoveStack
data(vulture_moveStack)
#length(vulture_moveStack[[2]])
#length(vulture_moveStack@burstId)
#####
#===============================================================================
#
# PREPARATION
#
#===============================================================================
# TODO /delete
# Creation of further move objects for testing relating to NA values and infolocs
# # delete:
# bclOcelotMoveStack_4TrColl <- bclOcelotMoveStack
# bclOcelotMoveStack_4TrCollTrackIdchar <- as.character(bclOcelotMoveStack_4TrColl@trackId)
# bclOcelotMoveStack_4TrCollTrackIdchar[c(6:10)] <- "Moteado_2"
# bclOcelotMoveStack_4TrCollTrackIdchar[c(2260:2288)] <- "Estrella_2"
# bclOcelotMoveStack_4TrCollTrackIdFact <- as.factor(bclOcelotMoveStack_4TrCollTrackIdchar)
# bclOcelotMoveStack_4TrColl@trackId <- bclOcelotMoveStack_4TrCollTrackIdFact
# class(bclOcelotMoveStack_4TrColl) # MoveStack
# --> macht Problem: idData passt nicht zu trackIds !!!
# --> delete
exMoveStack <- move::moveStack(list(leroy,ricky))
#identical(exMoveStack, martesPennantiMoveStack)#T
#str(exMoveStack)
# # Create another MoveBurst
v_X1_Move <- vulture_moveStack[[1]]
#datesX1 <- as.Date(v_move_1@timestamps)
#datesX1_1 <- datesX1 == datesX1[1]
#day1 <- which(datesX1_1)
day1 <- which(as.Date(v_X1_Move@timestamps) == as.Date(v_X1_Move@timestamps[1]))
#v_X1_Move@data$ground_speed[w]
#sort(v_X1_Move@data$ground_speed[w])
#w_fly <- which(v_X1_Move@data$ground_speed[day1] > 5)
#behav <- vector(mode = "character", length = length(w))
behav <- rep("on_ground", length(day1))
#length(behav)
#behav[w_fly] <- "flying"
behav[which(v_X1_Move@data$ground_speed[day1] > 5)] <- "flying_high"
v_X1_1_Move <- v_X1_Move[day1]
v_X1_1_mb <- move::burst(v_X1_1_Move, f = behav[1:length(behav) - 1])
#length(v_X1_1_mb)
# !!
#v_X1_1_mb_Tracks <- as.Tracks(v_X1_1_mb)
#v_X1_1_mb_Tracks@tracksData
#-------------------------------------------------------------------------------
#===============================================================================
#
# CREATION OF A LIST OF "move" OBJECTS TO BE TESTED
#
#===============================================================================
movePkgObjectsList <- list(vulture_moveStack,
vulture_moveStack[[1]],
v_X1_1_mb,
leroy,
leroy_bursts_unique,
leroy_bursts_rep,
leroy_shift,
leroyMoveStack,
##, ### ??
martesPennantiMoveStack,
##, ### to be deleted (because of file size)
ricky,
##, ### to be deleted, from load("...RData")
#bobbyMove,
#bclOcelotMoveStack,
##, ### additionally created
exMoveStack# identical to martesPennantiMoveStack
##, ### additionally created and to be deleted...
#bclOcelotMoveStack_4TrColl
)
movePkgObjNamesList <- list("vulture_moveStack",
"vulture_moveStack[[1]]",
"v_X1_1_mb",
"leroy",
"leroy_bursts_unique",
"leroy_bursts_rep",
"leroy_shift",
"leroyMoveStack",
##, ### ??
"martesPennantiMoveStack",
###, ### to be deleted (because of file size)
"ricky",
###, ### to be deleted, from load("...RData")
#"bobbyMove",
#"bclOcelotMoveStack",
##, ### additionally created
"exMoveStack"
##, ### additionally created and to be deleted...
#"bclOcelotMoveStack_4TrColl"
)
stopifnot(length(movePkgObjNamesList) == length(movePkgObjectsList))
# !!!ACHTUNG: delete
#movePkgObjectsList <- list(ricky)
#movePkgObjNamesList <- list("ricky")
#===============================================================================
#===============================================================================
#
#
# TESTING ...
#
#
#===============================================================================
#===============================================================================
for (i in 1:length(movePkgObjectsList)) {
#delete
#ltr <- ltrajObjectsList[[1]]
#ltrName <- ltrajObjNamesList[[1]]
moveObj <- movePkgObjectsList[[i]]
moveObjName <- movePkgObjNamesList[[i]]
#delete
# moveObj <- bclOcelotMoveStack
# moveObjName <- "bclOcelotMoveStack"
#===============================================================================
#-------------------------------------------------------------------------------
#
# TESTING COERCION FROM MOVE TO TRACK
#
#-------------------------------------------------------------------------------
#===============================================================================
if (is(moveObj, "Move")) {
#===============================================================================
#
context(paste("moveCoercion.R: TEST COERCION FROM MOVE (", moveObjName,
") TO TRACK OBJECT:", sep = ""))
#
#===============================================================================
test_that(paste("Test coercion of object ", moveObjName, " to Track object:", sep=""), {
##
# Test as(moveObj,"Track") (Move object from example data to Track object)
myTrack <- as(moveObj, "Track")
# Test classes
expect_that(moveObj, is_a("Move"))
expect_that(myTrack, is_a("Track"))
# Test length
expect_that(length(moveObj), is_identical_to(length(myTrack)))
# Test data
expect_that(moveObj@data[,1], is_identical_to(myTrack@data[,1]))
expect_that(moveObj@data, is_identical_to(myTrack@data))
# Test time
#expect_that(moveObj@timestamps, is_equivalent_to(zoo::index(myTrack@time))) # ignores attributes
expect_true(all.equal(moveObj@timestamps, zoo::index(myTrack@time), check.attributes = F))
#expect_that(moveObj@timestamps, is_identical_to(index(myTrack@time))) # Diff: attributes: < Length mismatch: comparison on first 1 components >
myTime <- zoo::index(myTrack@time)
attr(myTime, "tclass") <- NULL
expect_that(moveObj@timestamps, is_identical_to(myTime))
## delete
#expect_that(moveObj@timestamps, is_identical_to(
# as.POSIXct(strptime(as.POSIXct(zoo::index(myTrack@time)),
# format = format(as.POSIXct(zoo::index(myTrack@time))))))) # Diff: attributes: < Length mismatch: comparison on first 1 components >
#moveObj@timestamps[1:5]
#as.POSIXct(strptime(as.character(zoo::index(myTrack@time)),
# format = format(as.POSIXct(zoo::index(myTrack@time)))))[1:5]
#as.POSIXct(strptime(as.character(zoo::index(myTrack@time)),
# format = format(zoo::index(myTrack@time))[1]))
#format = format(zoo::index(myTrack@time))[1]
### ???
# Test geometry
#expect_that(geometry(moveObj), is_equivalent_to(geometry(myTrack))) # ignores attributes
#expect_that(geometry(moveObj), is_identical_to(geometry(myTrack))) # ignores attributes
expect_that(geometry(moveObj), is_identical_to(geometry(myTrack@sp)))
})
} # Finish if (is(obj, Move))
#===============================================================================
#-------------------------------------------------------------------------------
#
# TESTING COERCION FROM MOVESTACK TO TRACKS AND TRACKSCOLLECTION
#
#-------------------------------------------------------------------------------
#===============================================================================
if (is(moveObj, "MoveStack")) {
#===============================================================================
#
context(paste("moveCoercion.R: TEST COERCION FROM MOVESTACK (", moveObjName,
") TO TRACKS OBJECT:", sep = ""))
#
#===============================================================================
test_that(paste("Test coercion of object ", moveObjName, " to Tracks object:", sep=""), {
# ??? !!!
# delete
#moveObj <- martesPennantiMoveStack
#moveObj <- vulture_moveStack
#Tr_alternativ <- moveStackToTracks(moveObj)
# Test as(moveObj,"Tracks") (MoveStack object to Tracks object)
myTracks <- as(moveObj, "Tracks")
# # ??? !!!
# #delete
# expect_that(Tr_alternativ, is_equivalent_to(myTracks)) # T
# #attr(moveObj@coords, "dimnames")[[2]] # [1] "location.long" "location.lat"
# #attr(myTracks@tracks[[1]]@sp@coords, "dimnames")[[2]] # [1] "location.long" "location.lat"
# #attr(Tr_alternativ@tracks[[1]]@sp@coords, "dimnames")[[2]] # [1] "coords.x1" "coords.x2"
# # row.names in @data identisch!?
# #attr(moveObj@idData, "row.names") #
# #attr(myTracks@tracksData, "row.names") #
# #attr(Tr_alternativ@tracksData, "row.names") #
# # ...
# #expect_that(Tr_alternativ, equals(myTracks)) #
# #expect_that(Tr_alternativ, is_identical_to(myTracks))
# # TODO Problems in names, dimnames, ? factor?, rownames?,
#
#
# # Test names (TrackNames)
# #expect_that(names(Tr_alternativ@tracks), is_identical_to(names(myTracks@tracks)))
# # TrackNames: Leroy vs. Track1_Leroy --> was ist besser???
# # But in general names are ok!
#
# # Test row.names
# expect_that(row.names(Tr_alternativ@tracks[[1]]@data),
# is_identical_to(row.names(myTracks@tracks[[1]]@data)))
# #expect_that(row.names(Tr_alternativ@tracksData),
# # is_identical_to(row.names(myTracks@tracksData)))
# # --> not identical, wegen konsequenzen aus names (s.o.)
# # But in general names are ok!
#
# #!!! --> (bisher) keine (gravierenden) Unterschiede in Tests
# # --> !?!?! Tests nicht gut genug? What about factor data, dimnames, ...?
# myTracks <- Tr_alternativ
# Test classes
expect_that(moveObj, is_a("MoveStack"))
expect_that(myTracks, is_a("Tracks"))
# Test length
trackIds <- unique(moveObj@trackId)
nrTrId1 <-
length(moveObj@trackId[moveObj@trackId == trackIds[1]])
nrTrId2 <-
length(moveObj@trackId[moveObj@trackId == trackIds[2]])
expect_that(length(moveObj),
is_identical_to(sum(myTracks@tracksData$n)))
expect_that(nrTrId1, is_identical_to(myTracks@tracksData$n[1]))
expect_that(nrTrId1, is_identical_to(length(myTracks@tracks[[1]])))
expect_that(nrTrId2, is_identical_to(myTracks@tracksData$n[2]))
expect_that(nrTrId2, is_identical_to(length(myTracks@tracks[[2]])))
expect_that(length(unique(moveObj@trackId)),
is_identical_to(length(myTracks@tracks)))
# Test data
expect_that(moveObj@data[1,1],
is_identical_to(myTracks@tracks[[1]]@data[1,1]))
expect_that(moveObj@data[1:2, ],
is_identical_to(myTracks@tracks[[1]]@data[1:2, ]))
# Further data testing needs helping objects:
# delete: warum, wo kommen diese attribute her??? --> Tracks()
dataList <- lapply(myTracks@tracks, function(x) x@data)
dataTrcs <- do.call(rbind, dataList)
expect_that(moveObj@data, is_equivalent_to(dataTrcs))
#expect_that(moveObj@data, is_identical_to(dataTrcs)) # Diff: rownames
##
# Test time (time reordered in case of as(..., "xts")!)
expect_that(as.numeric(moveObj@timestamps),
is_equivalent_to(unlist(lapply(myTracks@tracks,
function(x) zoo::index(x@time))))) # ignores attributes
#expect_that(as.numeric(moveObj@timestamps),
# is_identical_to(unlist(sapply(myTracks@tracks, function(x) index(x@time)))))
# --> Diff: names for target but not for current
expect_that(moveObj@timestamps[1],
is_equivalent_to(zoo::index(myTracks@tracks[[1]]@time)[1])) # ignores attributes
#expect_that(moveObj@timestamps[1],
# is_equivalent_to(zoo::index(as(myTracks@tracks[[1]], "xts")[1]))) # ignores attributes
expect_true(all.equal(moveObj@timestamps[1], zoo::index(as(myTracks@tracks[[1]], "xts")[1]),
check.attributes = F))
#expect_that(moveObj@timestamps[1], is_identical_to(index(as(myTracks, "xts")[1])))
# --> Diff: Attributes: < Length mismatch: comparison on first 1 components >
# not always equivalent if different Track objects are tracked synchron at similar / overlapping periods
tracks_len_time <- length(unlist(lapply(myTracks@tracks, function(x) zoo::index(x@time)))) # 1838
moveStack_len_time <- length(moveObj[[1]]@timestamps)
#expect_that(moveObj@timestamps[moveStack_len_time],
# is_equivalent_to(zoo::index(as(myTracks, "xts")[tracks_len_time]))) # ignores attributes
#expect_that(moveObj@timestamps[moveStack_len_time],
# is_identical_to(zoo::index(as(myTracks, "xts")[tracks_len_time])))
myTime <- zoo::index(as(myTracks, "xts")[tracks_len_time])
attr(myTime, "tclass") <- NULL
#expect_that(moveObj@timestamps[moveStack_len_time], equals(myTime))
myTime <- zoo::index(as(myTracks[1], "xts"))
attr(myTime, "tclass") <- NULL
expect_that(moveObj[[1]]@timestamps, equals(myTime))
#expect_that(moveObj@timestamps[moveStack_len_time], is_identical_to(myTime)) # nicht immer !?!
# delete: problem bei: leroyMoveStack, martesPennantiMoveStack
myl <- lapply(myTracks@tracks, function(x) zoo::index(x@time))
v <- myl[[1]]
if (length(myl) > 1){
for (i in 2:length(myl)) { v <- c(v, myl[[i]]) }
}
timez <- attr(moveObj@timestamps, "tzone")
attr(v, "tzone") <- timez
expect_that(moveObj@timestamps, is_equivalent_to(v))
expect_equal(moveObj@timestamps, v)
##
# Test geometry
expect_that(geometry(moveObj),
is_equivalent_to(geometry(as(myTracks, "Spatial")))) # ignores attributes
#expect_that(geometry(moveObj), is_identical_to(geometry(as(myTracks, "Spatial"))))
# --> Attributes dimnames
#Test tracksData
moveColNames <- colnames(moveObj@idData)
#myTrColNames <- colnames(myTracks@tracksData)
expect_that(moveObj@idData, is_equivalent_to(myTracks@tracksData[ , moveColNames]))
#expect_that(moveObj@idData, is_identical_to(myTracks@tracksData[ , moveColNames]))
# --> row.names adjusted related to Track names
#delete:
#attr(moveObj@idData, "row.names")
#attr(myTracks@tracksData, "row.names")
})
#===============================================================================
#
context(paste("moveCoercion.R: TEST COERCION FROM MOVESTACK (", moveObjName,
") TO TRACKSCOLLECTION OBJECT:", sep = ""))
#
#===============================================================================
test_that(paste("Test coercion of object ", moveObjName, " to TracksCollection object:", sep=""), {
# !!!
# Changed order of current und target : myTrColl ..is_ident... to moveObj
# !!!
#moveObj <- bclOcelotMoveStack
#moveObj <- martesPennantiMoveStack
#moveObj <- vulture_moveStack
#TrColl_alternativ <- moveStackToTracksColl(moveObj)
# Test as(moveObj,"TracksCollection") (MoveStack object to TracksCollection object)
myTrColl <- as(moveObj, "TracksCollection")
# expect_that(TrColl_alternativ, is_equivalent_to(myTrColl)) # T
# #expect_that(TrColl_alternativ, is_identical_to(myTrColl)) # F
# #Attributes: < Component “tracksCollection”: Names: 2 string mismatches
# # ...bbox und coords dimnames !?!? und weiteres (Ausgabe erscheint abgeschniten?!?)?
#
# # Test names (TrackNames, TracksNames)
# # Just equivalent because (still) different TracksNames
# expect_that(sapply(TrColl_alternativ@tracksCollection, function(x) names(x@tracks)),
# is_equivalent_to(sapply(myTrColl@tracksCollection, function(x) names(x@tracks))))
# #expect_that(names(TrColl_alternativ@tracksCollection),
# # is_equivalent_to(names(myTrColl@tracksCollection)))
# # But in general names are ok!
#
# # Test row.names
# expect_that(row.names(TrColl_alternativ@tracksCollection[[1]]@tracks[[1]]@data),
# is_identical_to(row.names(myTrColl@tracksCollection[[1]]@tracks[[1]]@data)))
# #expect_that(row.names(TrColl_alternativ@tracksCollectionData),
# # is_identical_to(row.names(myTrColl@tracksCollectionData))) # wie oben bei names!!!
# expect_that(row.names(TrColl_alternativ@tracksCollection[[1]]@tracksData),
# is_identical_to(row.names(myTrColl@tracksCollection[[1]]@tracksData)))
# # # But in general names are ok!
#
# ## Achtung TODO or delete: in new approach with move::split not identical /
# ## equivalent any more...!!! ??? !!!
# ## Factors in TracksData: u.U. mehr Levles/Factors als Ausprägungen
# ##str(TrColl_alternativ@tracksCollection[[1]]@tracksData) #--> ok!
# #for (i in seq_along(TrColl_alternativ@tracksCollection)) {
# # for (j in seq_along(TrColl_alternativ@tracksCollection[[i]]@tracksData))
# # if (is.factor(TrColl_alternativ@tracksCollection[[i]]@tracksData[[j]])) {
# # expect_that(length(levels(TrColl_alternativ@tracksCollection[[i]]@tracksData[[j]])),
# # is_identical_to(
# # length(unique(TrColl_alternativ@tracksCollection[[i]]@tracksData[[j]]))))
# # }
# #}
#
#
# #!!! --> (bisher) keine (gravierenden) Unterschiede in Tests
# # --> !?!?! Tests nicht gut genug? What about factor data, dimnames, ...?
# myTrColl <- TrColl_alternativ
# Test classes
expect_that(moveObj, is_a("MoveStack"))
expect_that(myTrColl, is_a("TracksCollection"))
# Test length
trackIds <- unique(moveObj@trackId)
nrTrId1 <-
length(moveObj@trackId[moveObj@trackId == trackIds[1]])
nrTrId2 <-
length(moveObj@trackId[moveObj@trackId == trackIds[2]])
expect_that(sum(sapply(myTrColl@tracksCollection,
function(x) x@tracksData$n)),
is_identical_to(length(moveObj)))
#delete
#expect_that(length(moveObj),
# is_identical_to(sum(sapply(myTrColl@tracksCollection,
# function(x) x@tracksData$n))))
expect_that(myTrColl@tracksCollection[[1]]@tracksData$n[1],
is_identical_to(nrTrId1))
expect_that(length(myTrColl@tracksCollection[[1]]@tracks[[1]]),
is_identical_to(nrTrId1))
expect_that(myTrColl@tracksCollection[[2]]@tracksData$n,
is_identical_to(nrTrId2))
expect_that(length(myTrColl@tracksCollection[[2]]@tracks[[1]]),
is_identical_to(nrTrId2))
expect_that(length(myTrColl@tracksCollection),
is_identical_to(length(unique(moveObj@trackId))))
expect_that(nrow(myTrColl@tracksCollectionData),
is_identical_to(length(unique(moveObj@trackId))))
# !!! delete: Order of cur , target changed
#expect_that(nrTrId1,
## is_identical_to(
# myTrColl@tracksCollection[[1]]@tracksData$n[1]))
#expect_that(nrTrId1,
# is_identical_to(
# length(myTrColl@tracksCollection[[1]]@tracks[[1]])))
#expect_that(nrTrId2,
# is_identical_to(
# myTrColl@tracksCollection[[2]]@tracksData$n))
#expect_that(nrTrId2,
# is_identical_to(
# length(myTrColl@tracksCollection[[2]]@tracks[[1]])))
#expect_that(length(unique(moveObj@trackId)),
# is_identical_to(length(myTrColl@tracksCollection)))
#expect_that(length(unique(moveObj@trackId)),
# is_identical_to(nrow(myTrColl@tracksCollectionData)))
# ...
# Test data
expect_that(myTrColl@tracksCollection[[1]]@tracks[[1]]@data[1,1],
is_identical_to(moveObj@data[1,1]))
#expect_that(moveObj@data[1,1],
# is_identical_to(
# myTrColl@tracksCollection[[1]]@tracks[[1]]@data[1,1]))
# Further data testing needs helping objects:
origDataColnames <- colnames(moveObj@data)
myTrColl_df <- as(myTrColl, "data.frame")
myTrColl_df_clean <-
myTrColl_df[!is.na(myTrColl_df[origDataColnames[1]]),
origDataColnames]
#expect_that(myTrColl_df_clean,
# is_identical_to(moveObj@data))
# --> not due to row.names
expect_that(myTrColl_df_clean,
is_equivalent_to(moveObj@data))
#expect_that(moveObj@data,
# is_equivalent_to(myTrColl_df_clean))
#expect_that(moveObj@data, is_identical_to(myTrColl_df_clean)) # Diff: rownames
#attr(moveObj@data, "row.names") # numeric 1:2288
#attr(myTrColl_df_clean, "row.names")# "Tracks_Estrella.Track1_Estrella.361"
# werden bei TracksColl() gesetzt!
##
# Test time (time reordered in case of as(..., "xts")!)
expect_that(
unlist(lapply(myTrColl@tracksCollection, function(x) {
zoo::index(x@tracks[[1]]@time) })),
is_equivalent_to(as.numeric(moveObj@timestamps)))
#expect_that(as.numeric(moveObj@timestamps),
# is_equivalent_to(
# unlist(lapply(myTrColl@tracksCollection, function(x) {
# zoo::index(x@tracks[[1]]@time) })))) # ignores attributes
#expect_that(as.numeric(moveObj@timestamps), is_identical_to(unlist(sapply(myTrColl@tracksCollection, function(x) zoo::index(x@tracks[[1]]@time))))) # Diff: names for target but not for current
#names(zoo::index(myTrColl@tracksCollection[[1]]@tracks[[1]]@time)) # --> NULL ??
#names(moveObj@timestamps)#, "row.names")# --> NULL ??
#expect_that(zoo::index(as(myTrColl, "xts")[1]),
# is_equivalent_to(moveObj@timestamps[1])) # ignores attributes
#expect_that(zoo::index(as(myTrColl[1], "xts")),
# is_equivalent_to(moveObj[[1]]@timestamps)) # ignores attributes
expect_true(all.equal(zoo::index(as(myTrColl[1], "xts")),
moveObj[[1]]@timestamps, check.attributes = F)) # ignores attributes
#expect_that(moveObj@timestamps[1],
# is_equivalent_to(zoo::index(as(myTrColl, "xts")[1]))) # ignores attributes
#expect_that(moveObj@timestamps[1], is_identical_to(zoo::index(as(myTrColl, "xts")[1]))) # Diff: Attributes: < Length mismatch: comparison on first 1 components >
#trColl_len_time <- length(unlist(lapply(
# myTrColl@tracksCollection, function(x) {
# zoo::index(x@tracks[[1]]@time) }))) # 1838
#moveStack_len_time <- length(moveObj@timestamps)
#expect_that(zoo::index(as(myTrColl, "xts")[trColl_len_time]),
# is_equivalent_to(moveObj@timestamps[moveStack_len_time])) # ignores attributes
#expect_that(moveObj@timestamps[moveStack_len_time],
# is_equivalent_to(zoo::index(as(myTrColl, "xts")[trColl_len_time]))) # ignores attributes
#myl <- sapply(myTrColl@tracksCollection,
# function(x) index(x@tracks[[1]]@time))
#v <- myl[[1]]
#if (length(myl) > 1) {
# for (i in 2:length(myl)) { v <- c(v, myl[[i]]) }
#}
myl <- lapply(myTrColl@tracksCollection,
function(x) zoo::index(x@tracks[[1]]@time))
v <- myl[[1]]
if (length(myl) > 1) {
for (i in 2:length(myl)) { v <- c(v, myl[[i]]) }
}
timez <- attr(moveObj@timestamps, "tzone")
attr(v, "tzone") <- timez
expect_that(v, is_equivalent_to(moveObj@timestamps))
expect_equal(v, moveObj@timestamps)
#expect_that(moveObj@timestamps, is_equivalent_to(v))
#expect_equal(moveObj@timestamps, v)
##
# Test geometry
expect_that(geometry(as(myTrColl, "Spatial")),
is_equivalent_to(geometry(moveObj))) # ignores attributes
#expect_that(geometry(moveObj),
# is_equivalent_to(geometry(as(myTrColl, "Spatial")))) # ignores attributes
#expect_equal(geometry(moveObj), geometry(as(myTrColl, "Spatial"))) # ...
#expect_that(geometry(moveObj), is_identical_to(as(myTrColl, "Spatial"))) # ...
#Test tracksData
moveColNames <- colnames(moveObj@idData)
#myTrColNames <- colnames(myTracks@tracksData)
expect_that(myTrColl@tracksCollectionData[ , moveColNames], is_equivalent_to(moveObj@idData))
#expect_that(myTrColl@tracksCollectionData[ , moveColNames], is_identical_to(moveObj@idData))
# --> row.names adjusted related to Track names
#expect_that(moveObj@idData, is_equivalent_to(myTracks@tracksData[ , moveColNames]))
#expect_that(moveObj@idData, is_identical_to(myTracks@tracksData[ , moveColNames]))
})
} # Finish if (is(obj, MoveStack))
#===============================================================================
#-------------------------------------------------------------------------------
#
# TESTING COERCION FROM MOVEBURST TO TRACK AND TRACKS
#
#-------------------------------------------------------------------------------
#===============================================================================
if (is(moveObj, "MoveBurst")) {
#===============================================================================
#
context(paste("moveCoercion.R: TEST COERCION FROM MOVEBURST (", moveObjName,
") TO TRACK OBJECT:", sep = ""))
#
#===============================================================================
test_that(paste("Test coercion of object ", moveObjName, " to Track object:", sep=""), {
##
# Test as(MoveBurst, "Track") (MoveBurst object to Track object)
myTrackFromBursts <- as(moveObj, "Track")
# Test classes
expect_that(moveObj, is_a("MoveBurst"))
expect_that(myTrackFromBursts, is_a("Track"))
# Test length
expect_that(length(moveObj), is_identical_to(length(myTrackFromBursts)))
expect_that(length(moveObj@burstId),
is_identical_to(nrow(myTrackFromBursts@connections)))
# Test data
expect_that(moveObj@data[,1], is_identical_to(myTrackFromBursts@data[,1]))
expect_that(moveObj@data, is_identical_to(myTrackFromBursts@data))
# Test time
#expect_that(moveObj@timestamps,
# is_equivalent_to(zoo::index(myTrackFromBursts@time))) # ignores attributes
#expect_true(all.equal(moveObj@timestamps,
# zoo::index(myTrackFromBursts@time), check.attributes = F)) # ignores attributes
expect_true(all.equal(zoo::index(myTrackFromBursts@time),
moveObj@timestamps, check.attributes = F)) # ignores attributes
#expect_that(moveObj@timestamps, is_identical_to(zoo::index(myTrackFromBursts@time))) # Diff: attributes: < Length mismatch: comparison on first 1 components >
##
# Test geometry
expect_that(geometry(moveObj),
is_equivalent_to(geometry(myTrackFromBursts))) # ignores attributes
expect_that(geometry(moveObj), is_identical_to(geometry(myTrackFromBursts@sp))) # Diff: Attributes
expect_equal(geometry(moveObj), geometry(myTrackFromBursts@sp))
expect_that(geometry(moveObj),
is_equivalent_to(geometry(myTrackFromBursts@sp)))
})
#===============================================================================
#
context(paste("moveCoercion.R: TEST COERCION FROM MOVEBURST (", moveObjName,
") TO TRACKS OBJECT:", sep = ""))
#
#===============================================================================
test_that(paste("Test coercion of object ", moveObjName, " to Tracks object:", sep=""), {
#Alternativer Ansatz
#moveObj <- leroy_bursts_rep
#moveObjName <- "leroy_bursts_rep"
#moveObj <- v_X1_1_mb
#moveObjName <- "v_X1_1_mb"
nrOfBursts <- switch(moveObjName, leroy_bursts_rep = 5, leroy_bursts_unique = 4,
v_X1_1_mb = 3)
seqOfBursts <- switch(moveObjName,
leroy_bursts_rep = factor(c("A", "B", "C", "A", "C")),
leroy_bursts_unique = factor(c("part_1", "part_2", "part_3", "part_4")),
v_X1_1_mb = factor(c("on_ground", "flying_high", "on_ground")))
nrOfBurstTypes <- length(unique(move::burst(moveObj)))
######################
# Test as(MoveBurst, "Tracks") (MoveBurst object from example data to Tracks object)
# Burst IDs might not be unique. That means that a burst type may appear several times.
#str(leroy_bursts_rep)
#moveObjName <- "leroy_bursts_unique"
#moveObj <- leroy_bursts_unique
#length(moveObj) # 919
#length(moveObj@burstId) # 918
#uniqueBurstId <- unique(moveObj@burstId) # length = 4
#sum(myTracksOfBursts@tracksData$n) # 922
#nrOfBurstTypes <- 3
#nrOfBursts <- 5
#######################
# ALternative (alter / erster Ansatz):
# Approaches differ just in implementation and not in results
#TrOfMoveBurst_alternativ <- moveBurstToTracks(moveObj)
#TrOfMoveBurst_alternativ@tracksData
#row.names(TrOfMoveBurst_alternativ@tracksData)
# Test as(moveObj,"Tracks") (MoveBurst object to Tracks object)
myTracksOfBursts <- as(moveObj,"Tracks")
# expect_that(TrOfMoveBurst_alternativ, is_equivalent_to(myTracksOfBursts))
# #expect_that(TrOfMoveBurst_alternativ, equals(myTracksOfBursts))
# #expect_that(TrOfMoveBurst_alternativ, is_identical_to(myTracksOfBursts))
# # --> Fehler in as.POSIXct.numeric(current) : 'origin' must be supplied
# # --> !!? wieso nur hier und nicht bei den anderen coercions???
#
# # Test names
# # Achtung uNterschied: 1.Impl: names verändert --> e.g. "Burst1_part_1"
# # ... 2. impl. (zuerst: names = burstIds) aber burstIds könne mehrfach auftreten,
# # daher muss ich die anpassen..!
# expect_that(names(TrOfMoveBurst_alternativ@tracks), is_identical_to(names(myTracksOfBursts@tracks)))
# expect_that(TrOfMoveBurst_alternativ@tracksData$burstId, is_identical_to(seqOfBursts))
#
# # Test row.names
# expect_that(row.names(TrOfMoveBurst_alternativ@tracks[[1]]@data),
# is_identical_to(row.names(myTracksOfBursts@tracks[[1]]@data)))
# expect_that(row.names(TrOfMoveBurst_alternativ@tracksData),
# is_identical_to(row.names(myTracksOfBursts@tracksData))) # wie oben bei names!!!
# expect_that(TrOfMoveBurst_alternativ@tracksData$burstId, is_identical_to(seqOfBursts))
############
# !!!!!!!!!!!!
# This decides which approach is further tested..!!!
# !!! ???
#myTracksOfBursts <- TrOfMoveBurst_alternativ
###########
# Test classes
expect_that(moveObj, is_a("MoveBurst"))
expect_that(myTracksOfBursts, is_a("Tracks"))
# Test length
expect_that(length(moveObj),
equals(sum(myTracksOfBursts@tracksData$n)
- nrOfBursts + 1))
expect_that(length(moveObj@burstId),
is_identical_to(sum(sapply(myTracksOfBursts@tracks, function(x) {
nrow(x@connections)
}))))
expect_that(nrOfBurstTypes,
equals(
length(unique(myTracksOfBursts@tracksData$burst))))
expect_that(nrOfBursts,
equals(length(myTracksOfBursts@tracksData$burst)))
expect_that(nrOfBursts,
equals(length(myTracksOfBursts@tracks)))
# Test data
expect_that(moveObj@data[1,1],
is_identical_to(myTracksOfBursts@tracks[[1]]@data[1,1]))
expect_that(moveObj@data[nrow(moveObj@data),1],
is_identical_to(
myTracksOfBursts@tracks[[nrOfBursts]]@data
[nrow(myTracksOfBursts@tracks[nrOfBursts][[1]]@data),1]))
origDataLength <- length(moveObj@data)
expect_that(moveObj@data[nrow(moveObj@data),origDataLength],
is_identical_to(
myTracksOfBursts@tracks[[nrOfBursts]]@data
[nrow(myTracksOfBursts@tracks[nrOfBursts][[1]]@data),
origDataLength]))
expect_that(moveObj@data[1,],
is_identical_to(myTracksOfBursts@tracks[[1]]@data[1,]))
# Test time
#expect_that(moveObj@timestamps[1],
# is_equivalent_to(zoo::index(myTracksOfBursts@tracks[[1]]@time[1]))) # ignores attributes
expect_true(all.equal(moveObj@timestamps[1],
zoo::index(myTracksOfBursts@tracks[[1]]@time[1]), check.attributes = F)) # ignores attributes
expect_that(as.numeric(moveObj@timestamps),
is_equivalent_to(
unique(unlist(sapply(myTracksOfBursts@tracks, function(x) {
zoo::index(x@time)
}))))) # ignores attributes
myl <- sapply(myTracksOfBursts@tracks, function(x) zoo::index(x@time))
v <- myl[[1]]
if (length(myl) > 1) {
for (i in 2:length(myl)) { v <- c(v, myl[[i]]) }
}
v_unique <- unique(v)
timez <- attr(moveObj@timestamps, "tzone")
attr(v_unique, "tzone") <- timez
expect_that(moveObj@timestamps, is_equivalent_to(v_unique))
# Test geometry
expect_that(class(geometry(moveObj)),
is_identical_to(
class(geometry(as(myTracksOfBursts, "Spatial")))))
expect_that(bbox(moveObj),
is_equivalent_to(bbox(as(myTracksOfBursts, "Spatial")))) # ignores attributes
tr_x_coords <- unlist(sapply(
myTracksOfBursts@tracks, function(x) x@sp@coords[ ,1]))
tr_y_coords <- unlist(sapply(
myTracksOfBursts@tracks, function(x) x@sp@coords[ ,2]))
names(tr_x_coords) <- names(tr_y_coords) <- NULL
expect_that(unique(moveObj@coords[ ,1]),
is_identical_to(
unique(unlist(sapply(myTracksOfBursts@tracks, function(x) {
x@sp@coords[ ,1]
})))))
expect_that(unique(moveObj@coords[ ,2]),
is_identical_to(
unique(unlist(sapply(myTracksOfBursts@tracks, function(x) {
x@sp@coords[ ,2]
})))))
# Test burst names in tracksData
expect_that(myTracksOfBursts@tracksData[ , "burstId"], is_identical_to(seqOfBursts))
})
} # Finish if (is(moveObj, "MoveBurst"))
} # Finish for loop
print(Sys.time())
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.