search

Trackage / trip

trip package development
http://trackage.github.io/trip/
12 stars 2 forks source link

continuous time export to KML #24

Closed mdsumner closed 5 years ago

mdsumner commented 6 years ago

Here's a better attempt

library(trip)
library(XML)

library(trip)

obj <- walrus818
proj4string(obj) <- "+proj=longlat +datum=WGS84"
id.name <- obj@TOR.columns[2]
tripids <- unique(obj[[id.name]])
ntrips <- length(tripids)

kml_xsd <- "http://schemas.opengis.net/kml/2.2.0/ogckml22.xsd"  # get("kml_xsd", envir = plotKML.opts)
xmlns <- "http://www.opengis.net/kml/2.2/" ## get("kml_url", envir = plotKML.opts)
kml.out <- XML::newXMLNode("kml", attrs=c(version="1.0"), namespaceDefinitions = c("xsd"=kml_xsd, "xmlns"=xmlns))
kml_open <- TRUE
h2 <- newXMLNode("Document", parent = kml.out)
file.name <- "killme.kml"
folder.name <- "."
h3 <- newXMLNode("name", folder.name, parent = h2)
kml_visibility = TRUE
h4 <- newXMLNode("visibility", as.numeric(kml_visibility), parent = h2)
h5 <- newXMLNode("open", as.numeric(kml_open), parent = h2)

extrude <- FALSE

## aesthetics
## obj@data[,"colour"]

obj <- spTransform(obj, "+init=epsg:4326")

# Parsing the call for aesthetics
#aes <- kml_aes(obj, ...)   
aes <- list(labels = tripids, colour = viridis::viridis(ntrips), width = 1, altitudeMode = 0, 
            balloon = FALSE)
# Read the relevant aesthetics:
lines_names <- aes[["labels"]]  
colours <- aes[["colour"]]   
width <- aes[["width"]]
altitudeMode <- aes[["altitudeMode"]]
balloon <- aes[["balloon"]]

# object ID names:
lv <- levels(as.factor(obj@data[[id.name]]))
line.colours <- colours ## hex2kml(rainbow(n=2+length(lv)))  ## brewer.pal can't do many colours so choose this bad one for now
## names of the coordinate columns:
nc <- replicate(length(lv), attr(obj@coords, "dimname")[[2]], simplify = FALSE)
## strip times:
xt <- obj[[obj@TOR.columns[1L]]]

## Format the time slot for writing to KML:
# if(missing(dtime)) {
when <- format(xt, "%Y-%m-%dT%H:%M:%SZ")
dtime = 0
# } else {
#   ## Begin end times:
# TimeSpan.begin <- format(xt, "%Y-%m-%dT%H:%M:%SZ")
#  TimeSpan.end <- format(as.POSIXct(unclass(xt) + dtime, origin="1970-01-01"), "%Y-%m-%dT%H:%M:%SZ")
#}

# Name of the object
pl1 = newXMLNode("Folder", parent=kml.out[["Document"]])

# Insert metadata:
# if(!is.null(metadata)){
#   md.txt <- kml_metadata(metadata, asText = TRUE)
#   txt <- sprintf('<description><![CDATA[%s]]></description>', md.txt)
#   parseXMLAndAdd(txt, parent=pl1)
# }

# Sorting lines
# =============

current.line.coords <- NULL
ldist <- NULL
coords <- NULL

objxy <- split(obj, as.character(obj[[id.name]]))[unique(as.character(obj[[id.name]]))] ## don't fall for lex-sort trap
for (i.line in 1:length(lv)) {  # for each line

  cfd <- coordinates(objxy[[i.line]])
  # convert to line objects (this assumes that the points are sorted chronologically!)
  # line length:
  ldist[[i.line]] <- sum(trackDistance(cfd, longlat=TRUE) )
  current.line.coords[[i.line]] <- cbind(cfd, 0)

  #current.line.coords[[i.line]][,3] <- current.line.coords[[i.line]][,3] * z.scale
  # parse coordinates:
  coords[[i.line]] <- paste(current.line.coords[[i.line]][, 1], ',', current.line.coords[[i.line]][, 2], ',', current.line.coords[[i.line]][,3], collapse='\n ', sep = "")
}

# Styles - lines:
# ======
#message("Writing to KML...")
txts <- sprintf('<Style id="line_%s"><LineStyle><color>%s</color><width>%.1f</width></LineStyle><BalloonStyle><text>$[description]</text></BalloonStyle></Style>', 1:length(lv), line.colours[1:length(lv)], width[1:length(lv)])
parseXMLAndAdd(txts, parent=pl1)

# Styles - points:
# ======
nt <- unlist(lapply(current.line.coords, nrow))
LabelScale <- 0.4
nx <- 0
## get("home_url", envir = plotKML.opts)
start.icon = file.path("http://plotkml.r-forge.r-project.org", "3Dballyellow.png")
end.icon = file.path("http://plotkml.r-forge.r-project.org", "golfhole.png")
for (i.line in 1:length(lv)) { 
  # for each line:
  nx <- nx + nt[i.line]
  n1 <- nx - nt[i.line]
  txtsp <- sprintf('<Style id="pnt_%s"><IconStyle><color>%s</color><scale>%.1f</scale><Icon><href>%s</href></Icon></IconStyle></Style>', (n1+1):(nx-1), colours[(n1+1):(nx-1)], rep(LabelScale, nt[i.line]-1), rep(start.icon, nt[i.line]-1))
  parseXMLAndAdd(txtsp, parent=pl1)
  # the last point:
  txtspl <- sprintf('<Style id="pnt_%s"><IconStyle><color>%s</color><scale>%.1f</scale><Icon><href>%s</href></Icon></IconStyle></Style>', nx, colours[nx], LabelScale*2.5, end.icon)
  parseXMLAndAdd(txtspl, parent=pl1)
}   

# Writing observed vertices
# =============

# for each line:  
nx <- 0
html.table <- NULL
for (i.line in 1:length(lv)) {
  pl2 = newXMLNode("Folder", parent=pl1)
  pl3 <- newXMLNode("name", lv[i.line], parent = pl2)
  #browser()
  nx <- nx + nt[i.line]
  n1 <- nx - nt[i.line]
  # Parse point coordinates:
  ## TH: I do not know how to make the following code more compact.
  if(length(html.table)>0 & all(dtime==0)){  # with attributes / point temporal support  
    txtl <- sprintf('<Placemark><styleUrl>#pnt_%s</styleUrl><description><![CDATA[%s]]></description><TimeStamp><when>%s</when></TimeStamp><Point><extrude>%.0f</extrude><altitudeMode>%s</altitudeMode><coordinates>%.5f,%.5f,%.0f</coordinates></Point></Placemark>', 
                    (n1+1):nx, html.table[(n1+1):nx], when[(n1+1):nx], rep(as.integer(extrude), nt[i.line]), rep(altitudeMode, nt[i.line]), current.line.coords[[i.line]][,1], current.line.coords[[i.line]][,2], current.line.coords[[i.line]][,3])
  }
  else {
    if(length(html.table)>0 & any(!dtime==0)){  # with attributes / block temporal support 
      txtl <- sprintf('<Placemark><styleUrl>#pnt_%s</styleUrl><description><![CDATA[%s]]></description><TimeStamp><begin>%s</begin><end>%s</end></TimeStamp><Point><extrude>%.0f</extrude><altitudeMode>%s</altitudeMode><coordinates>%.5f,%.5f,%.0f</coordinates></Point></Placemark>', (n1+1):nx, html.table[(n1+1):nx], TimeSpan.begin[(n1+1):nx], TimeSpan.end[(n1+1):nx], rep(as.integer(extrude), nt[i.line]), rep(altitudeMode, nt[i.line]), current.line.coords[[i.line]][,1], current.line.coords[[i.line]][,2], current.line.coords[[i.line]][,3])
    }
    else {
      if(is.null(html.table) & any(!dtime==0)){   # no attributes / block temporal support 
        txtl <- sprintf('<Placemark><styleUrl>#pnt_%s</styleUrl><TimeStamp><begin>%s</begin><end>%s</end></TimeStamp><Point><extrude>%.0f</extrude><altitudeMode>%s</altitudeMode><coordinates>%.5f,%.5f,%.0f</coordinates></Point></Placemark>', (n1+1):nx, TimeSpan.begin[(n1+1):nx], TimeSpan.end[(n1+1):nx], rep(as.integer(extrude), nt[i.line]), rep(altitudeMode, nt[i.line]), current.line.coords[[i.line]][,1], current.line.coords[[i.line]][,2], current.line.coords[[i.line]][,3])
      }
      else {  # no attributes / point temporal support 
        txtl <- sprintf('<Placemark><styleUrl>#pnt_%s</styleUrl><TimeStamp><when>%s</when></TimeStamp><Point><extrude>%.0f</extrude><altitudeMode>%s</altitudeMode><coordinates>%.5f,%.5f,%.0f</coordinates></Point></Placemark>', (n1+1):nx, when[(n1+1):nx], rep(as.integer(extrude), nt[i.line]), rep(altitudeMode, nt[i.line]), current.line.coords[[i.line]][,1], current.line.coords[[i.line]][,2], current.line.coords[[i.line]][,3])
      }}}

  parseXMLAndAdd(txtl, parent=pl2)
}

# Writing Lines
# =============
#txtl <- sprintf('<Placemark><name>length: %.2f</name><styleUrl>#line_%s</styleUrl><LineString><altitudeMode>%s</altitudeMode><coordinates>%s</coordinates></LineString></Placemark>', unlist(ldist), 1:length(lv), rep(altitudeMode, length(lv)), paste(unlist(coords)))
xsegs <- trip::explode(obj)
coords_segs <-   unlist(lapply(xsegs@lines, function(a) lapply(a@Lines, slot, "coords")), recursive = FALSE)
coords_txt <- lapply(coords_segs, function(x) paste(t(cbind(x, 0)), collapse = ","))  ## will need the get Z and/or M for sf
tripID <- xsegs[["id"]]
linesegID <- unlist(lapply(split(tripID, tripID), seq_along))
segbegin <- format(xsegs[["starttime"]], "%Y-%m-%dT%H:%M:%S+00:00")
segend <- format(xsegs[["endtime"]], "%Y-%m-%dT%H:%M:%S+00:00")

txtl <- sprintf('<Placemark><name>%s</name><styleUrl>#line_%s</styleUrl><TimeSpan><begin>%s</begin><end>%s</end></TimeSpan><LineString><altitudeMode>%s</altitudeMode><coordinates>%s</coordinates></LineString></Placemark>', 
                paste(tripID, linesegID, sep = "_") ,
                "$line_1",
                segbegin,
                segend,
                "clampToGround", 
                paste(unlist(coords_txt)))

parseXMLAndAdd(txtl, parent=pl1)

saveXML(kml.out, file.name)
mdsumner commented 6 years ago

This is a bit complicated, so going to try just making line strings with id and colour and that'll do. Here's the latest code

library(trip)
d <- read.csv("etc")

## date-time
d$gmt <- as.POSIXct(strptime(paste(d$UTC_Date, d$UTC_Time), "%d/%m/%Y %H:%M:%S"), tz = "GMT")

## sort by tag, then time
d <- d[order(d$Tag_ID, d$gmt), ]

## some of the times are not changed with tag-id (should investigate)
library(dplyr)
d <- d %>% group_by(Tag_ID) %>% mutate(bad = c(TRUE, !diff(unclass(gmt)) > 0)) %>% 
  dplyr::filter(!bad) %>% ungroup()

## convert to Spatial
tr <- d
coordinates(tr) <- c("Longitude", "Latitude")
proj4string(tr) <- CRS("+init=epsg:4326")  ##lonlat WGS84 metadata string

## convert to trip (nominate date-time, tag id)
tr <- trip(tr, c("gmt", "Tag_ID"))

library(XML)

library(trip)

obj <- tr
id.name <- obj@TOR.columns[2]
tripids <- unique(obj[[id.name]])
ntrips <- length(tripids)

kml_xsd <- "http://schemas.opengis.net/kml/2.2.0/ogckml22.xsd"  # get("kml_xsd", envir = plotKML.opts)
xmlns <- "http://www.opengis.net/kml/2.2/" ## get("kml_url", envir = plotKML.opts)
kml.out <- XML::newXMLNode("kml", attrs=c(version="1.0"), namespaceDefinitions = c("xsd"=kml_xsd, "xmlns"=xmlns))
kml_open <- TRUE
h2 <- newXMLNode("Document", parent = kml.out)
file.name <- "killme.kml"
folder.name <- "."
h3 <- newXMLNode("name", folder.name, parent = h2)
kml_visibility = TRUE
h4 <- newXMLNode("visibility", as.numeric(kml_visibility), parent = h2)
h5 <- newXMLNode("open", as.numeric(kml_open), parent = h2)

extrude <- FALSE

## aesthetics
## obj@data[,"colour"]

obj <- spTransform(obj, "+init=epsg:4326")

# Parsing the call for aesthetics
#aes <- kml_aes(obj, ...)   
aes <- list(labels = tripids, colour = viridis::viridis(ntrips), width = 1, altitudeMode = 0, 
            balloon = FALSE)
# Read the relevant aesthetics:
lines_names <- aes[["labels"]]  
colours <- aes[["colour"]]   
width <- aes[["width"]]
altitudeMode <- aes[["altitudeMode"]]
balloon <- aes[["balloon"]]

# object ID names:
lv <- levels(as.factor(obj@data[[id.name]]))
line.colours <- colours ## hex2kml(rainbow(n=2+length(lv)))  ## brewer.pal can't do many colours so choose this bad one for now
## names of the coordinate columns:
nc <- replicate(length(lv), attr(obj@coords, "dimname")[[2]], simplify = FALSE)
## strip times:
xt <- obj[[obj@TOR.columns[1L]]]

## Format the time slot for writing to KML:
# if(missing(dtime)) {
when <- format(xt, "%Y-%m-%dT%H:%M:%SZ")
dtime = 0
# } else {
#   ## Begin end times:
# TimeSpan.begin <- format(xt, "%Y-%m-%dT%H:%M:%SZ")
#  TimeSpan.end <- format(as.POSIXct(unclass(xt) + dtime, origin="1970-01-01"), "%Y-%m-%dT%H:%M:%SZ")
#}

# Name of the object
pl1 = newXMLNode("Folder", parent=kml.out[["Document"]])

# Insert metadata:
# if(!is.null(metadata)){
#   md.txt <- kml_metadata(metadata, asText = TRUE)
#   txt <- sprintf('<description><![CDATA[%s]]></description>', md.txt)
#   parseXMLAndAdd(txt, parent=pl1)
# }

# Sorting lines
# =============

current.line.coords <- NULL
ldist <- NULL
coords <- NULL

objxy <- split(obj, as.character(obj[[id.name]]))[unique(as.character(obj[[id.name]]))] ## don't fall for lex-sort trap
for (i.line in 1:length(lv)) {  # for each line

  cfd <- coordinates(objxy[[i.line]])
  # convert to line objects (this assumes that the points are sorted chronologically!)
  # line length:
  ldist[[i.line]] <- sum(trackDistance(cfd, longlat=TRUE) )
  current.line.coords[[i.line]] <- cbind(cfd, 0)

  #current.line.coords[[i.line]][,3] <- current.line.coords[[i.line]][,3] * z.scale
  # parse coordinates:
  coords[[i.line]] <- paste(current.line.coords[[i.line]][, 1], ',', current.line.coords[[i.line]][, 2], ',', current.line.coords[[i.line]][,3], collapse='\n ', sep = "")
}

# Styles - lines:
# ======
#message("Writing to KML...")
txts <- sprintf('<Style id="line_%s"><LineStyle><color>%s</color><width>%.1f</width></LineStyle><BalloonStyle><text>$[description]</text></BalloonStyle></Style>', 1:length(lv), line.colours[1:length(lv)], width[1:length(lv)])
parseXMLAndAdd(txts, parent=pl1)

# Styles - points:
# ======
nt <- unlist(lapply(current.line.coords, nrow))
LabelScale <- 0.4
nx <- 0
## get("home_url", envir = plotKML.opts)
start.icon = file.path("http://plotkml.r-forge.r-project.org", "3Dballyellow.png")
end.icon = file.path("http://plotkml.r-forge.r-project.org", "golfhole.png")
for (i.line in 1:length(lv)) { 
  # for each line:
  nx <- nx + nt[i.line]
  n1 <- nx - nt[i.line]
  txtsp <- sprintf('<Style id="pnt_%s"><IconStyle><color>%s</color><scale>%.1f</scale><Icon><href>%s</href></Icon></IconStyle></Style>', (n1+1):(nx-1), colours[(n1+1):(nx-1)], rep(LabelScale, nt[i.line]-1), rep(start.icon, nt[i.line]-1))
  parseXMLAndAdd(txtsp, parent=pl1)
  # the last point:
  txtspl <- sprintf('<Style id="pnt_%s"><IconStyle><color>%s</color><scale>%.1f</scale><Icon><href>%s</href></Icon></IconStyle></Style>', nx, colours[nx], LabelScale*2.5, end.icon)
  parseXMLAndAdd(txtspl, parent=pl1)
}   

# Writing observed vertices
# =============

# # for each line:  
# nx <- 0
# html.table <- NULL
# for (i.line in 1:length(lv)) {
#   pl2 = newXMLNode("Folder", parent=pl1)
#   pl3 <- newXMLNode("name", lv[i.line], parent = pl2)
#   #browser()
#   nx <- nx + nt[i.line]
#   n1 <- nx - nt[i.line]
#   # Parse point coordinates:
#   ## TH: I do not know how to make the following code more compact.
#   if(length(html.table)>0 & all(dtime==0)){  # with attributes / point temporal support  
#     txtl <- sprintf('<Placemark><styleUrl>#pnt_%s</styleUrl><description><![CDATA[%s]]></description><TimeStamp><when>%s</when></TimeStamp><Point><extrude>%.0f</extrude><altitudeMode>%s</altitudeMode><coordinates>%.5f,%.5f,%.0f</coordinates></Point></Placemark>', 
#                     (n1+1):nx, html.table[(n1+1):nx], when[(n1+1):nx], rep(as.integer(extrude), nt[i.line]), rep(altitudeMode, nt[i.line]), current.line.coords[[i.line]][,1], current.line.coords[[i.line]][,2], current.line.coords[[i.line]][,3])
#   }
#   else {
#     if(length(html.table)>0 & any(!dtime==0)){  # with attributes / block temporal support 
#       txtl <- sprintf('<Placemark><styleUrl>#pnt_%s</styleUrl><description><![CDATA[%s]]></description><TimeStamp><begin>%s</begin><end>%s</end></TimeStamp><Point><extrude>%.0f</extrude><altitudeMode>%s</altitudeMode><coordinates>%.5f,%.5f,%.0f</coordinates></Point></Placemark>', (n1+1):nx, html.table[(n1+1):nx], TimeSpan.begin[(n1+1):nx], TimeSpan.end[(n1+1):nx], rep(as.integer(extrude), nt[i.line]), rep(altitudeMode, nt[i.line]), current.line.coords[[i.line]][,1], current.line.coords[[i.line]][,2], current.line.coords[[i.line]][,3])
#     }
#     else {
#       if(is.null(html.table) & any(!dtime==0)){   # no attributes / block temporal support 
#         txtl <- sprintf('<Placemark><styleUrl>#pnt_%s</styleUrl><TimeStamp><begin>%s</begin><end>%s</end></TimeStamp><Point><extrude>%.0f</extrude><altitudeMode>%s</altitudeMode><coordinates>%.5f,%.5f,%.0f</coordinates></Point></Placemark>', (n1+1):nx, TimeSpan.begin[(n1+1):nx], TimeSpan.end[(n1+1):nx], rep(as.integer(extrude), nt[i.line]), rep(altitudeMode, nt[i.line]), current.line.coords[[i.line]][,1], current.line.coords[[i.line]][,2], current.line.coords[[i.line]][,3])
#       }
#       else {  # no attributes / point temporal support 
#         txtl <- sprintf('<Placemark><styleUrl>#pnt_%s</styleUrl><TimeStamp><when>%s</when></TimeStamp><Point><extrude>%.0f</extrude><altitudeMode>%s</altitudeMode><coordinates>%.5f,%.5f,%.0f</coordinates></Point></Placemark>', (n1+1):nx, when[(n1+1):nx], rep(as.integer(extrude), nt[i.line]), rep(altitudeMode, nt[i.line]), current.line.coords[[i.line]][,1], current.line.coords[[i.line]][,2], current.line.coords[[i.line]][,3])
#       }}}
#   
#   parseXMLAndAdd(txtl, parent=pl2)
# }

# Writing Lines
# =============
#txtl <- sprintf('<Placemark><name>length: %.2f</name><styleUrl>#line_%s</styleUrl><LineString><altitudeMode>%s</altitudeMode><coordinates>%s</coordinates></LineString></Placemark>', unlist(ldist), 1:length(lv), rep(altitudeMode, length(lv)), paste(unlist(coords)))
xsegs <- trip::explode(obj)
coords_segs <-   unlist(lapply(xsegs@lines, function(a) lapply(a@Lines, slot, "coords")), recursive = FALSE)
coords_txt <- lapply(coords_segs, function(x) paste(t(cbind(x, 0)), collapse = ","))  ## will need the get Z and/or M for sf
tripID <- xsegs[["id"]]
linesegID <- unlist(lapply(split(tripID, tripID), seq_along))
segbegin <- format(xsegs[["starttime"]], "%Y-%m-%dT%H:%M:%S+00:00")
segend <- format(xsegs[["endtime"]], "%Y-%m-%dT%H:%M:%S+00:00")
color <- sample(viridis::viridis(length(unique(xsegs$id)))[factor(xsegs$id)])
#color <- tolower(gsub("^#", "", color))

## convert to GBR
#color <- unlist(lapply(strsplit(color, ""), function(x) paste(x[c(5, 6, 3, 4, 1, 2, 7, 8)], collapse = "", sep = "")))

txtl <- sprintf('<Placemark><name>%s</name><styleUrl>#line_%s</styleUrl><Style> <LineStyle>  <color>%s</color></LineStyle> </Style><TimeSpan><begin>%s</begin><end>%s</end></TimeSpan><LineString><altitudeMode>%s</altitudeMode><coordinates>%s</coordinates></LineString></Placemark>', 
                paste(tripID, linesegID, sep = "_") ,
                "line_1",
                color,
                segbegin,
                segend,
                "clampToGround", 
                paste(unlist(coords_txt)))

parseXMLAndAdd(txtl, parent=pl1)

saveXML(kml.out, file.name)
mdsumner commented 6 years ago

waay simpler

library(trip)
library(glue)
outputfilename <- "all.kmz"
## from here on is standard, as long as "obj" is a trip object
obj <- trip(d, c("gmt", "tag"))

xsegs <- trip::explode(obj)
coords_segs <-   unlist(lapply(xsegs@lines, function(a) lapply(a@Lines, slot, "coords")), recursive = FALSE)
coordinates <- unlist(lapply(coords_segs, function(x) paste(apply(cbind(x, 0), 1, paste, collapse = ","), collapse = "\n")))  ## will need the get Z and/or M for sf
tripID <- xsegs[["id"]]
linesegID <- unlist(lapply(split(tripID, tripID), seq_along))
time_begin <- format(xsegs[["starttime"]], "%Y-%m-%dT%H:%M:%S+00:00")
time_end <- format(xsegs[["endtime"]], "%Y-%m-%dT%H:%M:%S+00:00")
aaggbbrr <- function(x) {
  unlist(lapply(strsplit(x, ""), function(x) paste(x[7], x[8], x[5], x[6], x[3], x[4], x[1], x[2], collapse = "", sep = "")))
}

line_colour <- aaggbbrr(tolower(viridis::viridis(length(unique(tripID)))[factor(tripID)]))

template_document <- '<kml xmlns:xsd="http://schemas.opengis.net/kml/2.2.0/ogckml22.xsd" xmlns:xmlns="http://www.opengis.net/kml/2.2/" version="1.0">
<Document>
<name>ellie24</name>
<visibility>1</visibility>
<open>1</open>
<Folder>

%s
</Folder>
</Document>
</kml>
'

template_line <- '
<Placemark> 
<TimeSpan><begin>{time_begin}</begin><end>{time_end}</end></TimeSpan>
<LineString>
<altitudeMode>clampToGround</altitudeMode>
<coordinates>
{coordinates}
</coordinates>
</LineString>

<Style> 
<LineStyle>  
<color>{line_colour}</color>
</LineStyle> 
</Style>
</Placemark>
'

line <- glue(template_line)
doc <- sprintf(template_document, paste(line, collapse = "\n"))

writeLines(doc, "doc.kml")
zip(outputfilename, "doc.kml")
unlink("doc.kml")
mdsumner commented 5 years ago

Now incorporated into write_track_kml.