R/similarity_var.R

In ianjonsen/foieGras: Fit Continuous-Time State-Space and Latent Variable Models for Quality Control of Argos Satellite (and Other) Telemetry Data and for Estimating Changes in Animal Movement

##' @title Add similarity var value to a \code{sim_fit} object
##' 
##' @description Calculate the similarity between a single path generated by 
##' sim_fit and the observed path used in the SSM fit. In this context, 
##' similarity is calculated using the mean, median, variance, standard 
##' deviation, sum, min, or max of a user-supplied variable appended to the 
##' observed and simulated tracks.  
##' 
##' @param track a dataframe containing longitude and latitudes of the observed
##' path used in the SSM fit
##' @param sim_track a dataframe containing the longitude and latitude of a single 
##' simulated path from sim_fit
##' @param FUN the function used to summarise the user-supplied variable
##' 
##' @return a single value representing the similarity between the two paths
##' 
##' @keywords internal
##' 
##' @export
similarity_var <- function(track, sim_track, var, FUN = "mean", ...){
  
  stopifnot("var can only have 1 or 2 variables" = length(var) <= 2)
  
  switch(
      FUN,
      mean = {
        st <- ot <- c()
        st[1] <- sim_track %>%
          summarise(mean(.data[[var[1]]], ...))
        ot[1] <- track %>%
          summarise(mean(.data[[var[1]]], ...))

        if(length(var) == 2) {
          st[2] <- sim_track %>%
            summarise(mean(.data[[var[2]]], ...))
          ot[2] <- track %>%
            summarise(mean(.data[[var[2]]], ...))
        } 
      },
      median = {
        st <- ot <- c()
        st[1] <- sim_track %>%
          summarise(median(.data[[var[1]]], ...))
        ot[1] <- track %>%
          summarise(median(.data[[var[1]]], ...))
        
        if(length(var) == 2) {
          st[2] <- sim_track %>%
            summarise(median(.data[[var[2]]], ...))
          ot[2] <- track %>%
            summarise(median(.data[[var[2]]], ...))
        } 
      },
      sum = {
        st <- ot <- c()
        st[1] <- sim_track %>%
          summarise(sum(.data[[var[1]]], ...))
        ot[1] <- track %>%
          summarise(sum(.data[[var[1]]], ...))
        
        if(length(var) == 2) {
          st[2] <- sim_track %>%
            summarise(sum(.data[[var[2]]], ...))
          ot[2] <- track %>%
            summarise(sum(.data[[var[2]]], ...))
        }
      },
      var = {
        st <- ot <- c()
        st[1] <- sim_track %>%
          summarise(var(.data[[var[1]]], ...))
        ot[1] <- track %>%
          summarise(var(.data[[var[1]]], ...))
        
        if(length(var) == 2) {
          st[2] <- sim_track %>%
            summarise(var(.data[[var[2]]], ...))
          ot[2] <- track %>%
            summarise(var(.data[[var[2]]], ...))
        }
      },
      sd = {
        st <- ot <- c()
        st[1] <- sim_track %>%
          summarise(sd(.data[[var[1]]], ...))
        ot[1] <- track %>%
          summarise(sd(.data[[var[1]]], ...))
        
        if(length(var) == 2) {
          st[2] <- sim_track %>%
            summarise(sd(.data[[var[2]]], ...))
          ot[2] <- track %>%
            summarise(sd(.data[[var[2]]], ...))
        }
      },
      min = {
        st <- ot <- c()
        st[1] <- sim_track %>%
          summarise(min(.data[[var[1]]], ...))
        ot[1] <- track %>%
          summarise(min(.data[[var[1]]], ...))
        
        if(length(var) == 2) {
          st[2] <- sim_track %>%
            summarise(min(.data[[var[2]]], ...))
          ot[2] <- track %>%
            summarise(min(.data[[var[2]]], ...))
        }
      },
      max = {
        st <- ot <- c()
        st[1] <- sim_track %>%
          summarise(max(.data[[var[1]]], ...))
        ot[1] <- track %>%
          summarise(max(.data[[var[1]]], ...))
        
        if(length(var) == 2) {
          st[2] <- sim_track %>%
            summarise(max(.data[[var[2]]], ...))
          ot[2] <- track %>%
            summarise(max(.data[[var[2]]], ...))
        }
      }
    )
  
  ot <- as.numeric(ot)
  st <- as.numeric(st)
  
  if(length(var) == 1) {
    return((ot[1] - st[1]) / ot[1])
  } else {
    return(((ot[1] - st[1]) / ot[1]) +
             ((ot[2] - st[2]) / ot[2]))
  }
  
}