R/coercion.R

Defines functions as_moveHMM.track_xy as_moveHMM as_telemetry.track_xyt as_telemetry as_ltraj.track_xyt as_ltraj.track_xy as_ltraj as_move.track_xyt as_move as_sf_lines.track_xy as_sf_lines as_sf_points.steps_xy as_sf_points.track_xy as_sf_points as_sp.steps_xy as_sp.track_xy as_sp

Documented in as_ltraj as_ltraj.track_xy as_ltraj.track_xyt as_move as_moveHMM as_moveHMM.track_xy as_move.track_xyt as_sf_lines as_sf_points as_sf_points.steps_xy as_sp as_sp.steps_xy as_telemetry as_telemetry.track_xyt

#' Coerce a track to other formats.
#'
#' Several other packages provides methods to analyze movement data, and `amt` provides coercion methods to some packages.
#'
#' @template track_xy_star
#' @param id `[numeric,character,factor]` \cr Animal id(s).
#' @template dots_none
#' @name coercion
#' @return An object of the class to which coercion is performed to.
#' @export
as_sp <- function(x, ...) {
  UseMethod("as_sp", x)
}

#' @export
as_sp.track_xy <- function(x, ...) {
  sf::as_Spatial(as_sf_points(x))
}

#' @export
#' @param end `[logical(1)=TRUE]` \cr For steps, should the end or start points be used?
#' @rdname coercion
as_sp.steps_xy <- function(x, end = TRUE, ...) {
  sf::as_Spatial(as_sf_points(x, end = end, ...))
}

#' Coerces a track to points
#'
#' Coerces a track to points from the `sf` package.
#'
#' @template track_xy_star
#' @template dots_none
#' @name as_sf_points
#' @return A data `data.frame` with a `sfc`-column
#' @export

as_sf_points <- function(x, ...) {
  UseMethod("as_sf_points", x)
}

#' @export
as_sf_points.track_xy <- function(x, ...) {

  p <- sf::st_as_sf(x, coords = c("x_", "y_"))
  p <- sf::st_set_crs(p, if (!is.null(attributes(x)$crs_))
    attributes(x)$crs_ else sf::NA_crs_)
  p
}

#' @rdname as_sf_points
#' @export
#' @param end `[logical(1)=TRUE]` \cr For steps, should the end or start points be used?
as_sf_points.steps_xy <- function(x, end = TRUE, ...) {

  p <- if (end) {
    sf::st_as_sf(x, coords = c("x2_", "y2_"))
  } else {
    sf::st_as_sf(x, coords = c("x1_", "y1_"))
  }
  p <- sf::st_set_crs(p, if (!is.null(attributes(x)$crs_))
    attributes(x)$crs_ else sf::NA_crs_)
  p
}

# as_sf_lines ----------------------------------------------------------------

#' Export track to lines
#'
#' Exports a track to (multi)lines from the `sf` package.
#'
#' @template track_xy_star
#' @template dots_none
#' @return A `tibble` with a `sfc`-column
#' @export
as_sf_lines <- function(x, ...) {
  UseMethod("as_sf_lines", x)
}

#' @export
as_sf_lines.track_xy <- function(x, ...) {

  # > 1 points
  if (nrow(x) < 2) {
    stop("> 2 locations are required for a line.")
  }

  # bursts
  if ("burst_" %in% names(x)) {
    if (any(table(x$burst_) <= 1)) {
      message("Some bursts consist of only 1 point, these will be ignored")
      x <- amt::filter_min_n_burst(x, 2)
    }
    l <- lapply(split(x, x$burst_), function(x)
      cbind(x$x_, x$y_))
    l <- sf::st_sf(sf::st_sfc(sf::st_multilinestring(l)))
  } else {
    l <- cbind(x$x_, x$y_)
    l <- sf::st_sf(sf::st_sfc(sf::st_linestring(l)))
  }

  l <- sf::st_set_crs(l,  if (!is.null(attributes(x)$crs_)) attributes(x)$crs_ else sf::NA_crs_)
  l
}



# as_move() ---------------------------------------------------------------

#' @export
#' @rdname coercion

as_move <- function(x, ...) {
  UseMethod("as_move", x)
}

#' @export
#' @rdname coercion
as_move.track_xyt <- function(x, id = "id", ...){

  # is a grouping present
  has_id = TRUE

  # Check if id is present
  if (!id %in% names(x)) {
    id <- "unnamed"
    has_id <- FALSE
  }

  # Check for duplicates (group by id)
  any_duplicates <- if (has_id) {
    any(sapply(split(x, x[[id]]), function(y) any(duplicated(y$t_))))
  } else {
    any(duplicated(x$t_))
  }

  if (any_duplicates) {
    warning("data contains duplicates. By default 1st entery is kept, and subsequent duplicates are removed. If this is not wanted, please remove duplicates from original input object")

    x <- if (has_id) {
      do.call(rbind, lapply(split(x, x$t_), function(y)
        y[!duplicated(y$t_), ]))

    } else {
      x[!duplicated(x$t_), ]
    }
  }

  # Create a move object
  move::move(
    x = x$x_,
    y= x$y_,
    time = x$t_,
    data = data.frame(x[!names(x) %in% c("x_","y_","t_")]),
    proj = if (is.numeric(get_crs(x))) sp::CRS(paste0("+init=epsg:", get_crs(x)))
    else as(get_crs(x), "CRS"),
    animal = if (has_id) as.character(x[[id]]) else "unnamed")
}



# as_ltraj ----------------------------------------------------------------

#' @export
#' @rdname coercion

as_ltraj <- function(x, ...) {
  UseMethod("as_ltraj", x)
}

#' @export
#' @rdname coercion
as_ltraj.track_xy <- function(x, id = "animal_1", ...) {
  if (is.null(list(...)[["id"]])) {
    adehabitatLT::as.ltraj(coords(x), typeII = FALSE, id = "animal_1", ...)
  } else {
    adehabitatLT::as.ltraj(coords(x), typeII = FALSE, ...)
  }
}

#' @export
#' @rdname coercion
as_ltraj.track_xyt <- function(x, ...) {
  if (is.null(list(...)[["id"]])) {
    adehabitatLT::as.ltraj(coords(x), date = x$t_, typeII = TRUE, id = "animal_1", ...)
  } else {
    adehabitatLT::as.ltraj(coords(x), date = x$t_, typeII = TRUE, ...)
  }
}


# as_telemetry -----------------------------------------------------------------
#' @export
#' @rdname coercion
as_telemetry <- function(x, ...) {
  UseMethod("as_telemetry", x)
}

#' @export
#' @rdname coercion
as_telemetry.track_xyt <- function(x, ...) {
  if (!amt::has_crs(x)) {
    stop("track needs to have a crs.")
  }
  x <- transform_coords(x, 4326)

  dat_ctmm <- data.frame(
    lon = x$x_, lat = x$y_, timestamp = x$t_,
    individual.local.identifier = 1
  )

  if ("dop" %in% colnames(x))
    dat_ctmm$dop <- x[["dop"]]
  else if ("DOP" %in% colnames(x))
    dat_ctmm$dop <- x[["DOP"]]
  else if ("hdop" %in% colnames(x))
    dat_ctmm$hdop <- x[["hdop"]]
  else if ("HDOP" %in% colnames(x))
    dat_ctmm$hdop <- x[["HDOP"]]

  suppressMessages(
    ctmm::as.telemetry(
      dat_ctmm
    )
  )
}


# as_moveHMM --------------------------------------------------------------
#' @export
#' @rdname coercion

as_moveHMM <- function(x, ...) {
  UseMethod("as_moveHMM", x)
}

#' @export
#' @rdname coercion
as_moveHMM.track_xy <- function(x, ...) {
  if (grepl("+proj=longlat", attr(x, "crs")$wkt)) {
    moveHMM::prepData(as.data.frame(x), type = "LL", coordNames = c("x_", "y_"))
  } else {
    message("Assuming projected CRS")
    moveHMM::prepData(as.data.frame(x), type = "UTM", coordNames = c("x_", "y_"))
  }
}

Try the amt package in your browser

Any scripts or data that you put into this service are public.

amt documentation built on Jan. 18, 2022, 5:06 p.m.