R/get_gbi.R

In ropensci/spatsoc: Group Animal Relocation Data by Spatial and Temporal Relationship

#' Generate group by individual matrix
#'
#'
#' \code{get_gbi} generates a group by individual matrix. The function accepts a
#' \code{data.table} with individual identifiers and a group column. The group
#' by individual matrix can then be used to build a network using
#' \code{\link[asnipe:get_network]{asnipe::get_network}}.
#'
#' The \code{DT} must be a \code{data.table}. If your data is a
#' \code{data.frame}, you can convert it by reference using
#' \code{\link[data.table:setDT]{data.table::setDT}}.
#'
#' The \code{group} argument expects the name of a column which corresponds to
#' an integer group identifier (generated by \code{\link{spatsoc}}'s grouping
#' functions).
#'
#' The \code{id} argument expects the name of a column which corresponds to the
#' individual identifier.
#'
#' @return \code{get_gbi} returns a group by individual matrix (columns
#'   represent individuals and rows represent groups).
#'
#'   Note that \code{get_gbi} is identical in function for turning the outputs
#'   of \code{spatsoc} into social networks as
#'   \code{\link[asnipe:get_group_by_individual]{asnipe::get_group_by_individual}}
#'   but is more efficient thanks to
#'   \code{\link[data.table:dcast.data.table]{data.table::dcast}}.
#'
#' @inheritParams group_pts
#' @param group Character string of group column (generated from one of
#'   spatsoc's spatial grouping functions)
#' @export
#'
#' @seealso \code{\link{group_pts}} \code{\link{group_lines}}
#'   \code{\link{group_polys}}
#' @family Social network tools
#'
#' @examples
#' # Load data.table
#' library(data.table)
#' \dontshow{data.table::setDTthreads(1)}
#'
#' # Read example data
#' DT <- fread(system.file("extdata", "DT.csv", package = "spatsoc"))
#'
#' # Cast the character column to POSIXct
#' DT[, datetime := as.POSIXct(datetime, tz = 'UTC')]
#' DT[, yr := year(datetime)]
#'
#' # EPSG code for example data
#' utm <- 'EPSG:32736'
#'
#' group_polys(DT, area = FALSE, hrType = 'mcp',
#'             hrParams = list(percent = 95),
#'             projection = utm, id = 'ID', coords = c('X', 'Y'),
#'             splitBy = 'yr')
#'
#' gbiMtrx <- get_gbi(DT = DT, group = 'group', id = 'ID')
#'
get_gbi <-
  function(DT = NULL,
           group = 'group',
           id = NULL) {

    if (is.null(DT)) {
      stop('input DT required')
    }

    if (is.null(group)) {
      stop('group field required')
    }

    if (is.null(id)) {
      stop('ID field required')
    }

    if (any(!(c(group, id) %in% colnames(DT)))) {
      stop(paste0(
        as.character(paste(setdiff(
          c(group, id),
          colnames(DT)
        ), collapse = ', ')),
        ' field(s) provided are not present in input DT'
      ))
    }


    if (anyNA(DT[[group]])) {
      warning('DT contains NA(s) in group column, these rows will be dropped')
    }




    uDT <-
      stats::na.omit(unique(DT[, .SD, .SDcols = c(group, id)]),
              cols = group)

    cDT <-
      data.table::dcast(
        uDT,
        formula = stats::reformulate(id, group),
        fun.aggregate = length,
        value.var = group
      )

    ids <- colnames(cDT)[!grepl(group, colnames(cDT))]

    m <- as.matrix(cDT[, .SD, .SDcols = ids])

    rownames(m) <- cDT[[group]]
    return(m)
  }