R/Path_Strength-Support_Functions.R

In davidbuch/sconduct: A Suite of Functions for Generalized Path Analysis

# ---- Internal Functions ----
as_binary <- function(sociomatrix){
  return(matrix(as.numeric(as.logical(sociomatrix)),nrow = nrow(sociomatrix)))
}

check_input <- function(sociomatrix, path, source, target, p_norm){
  # Check sociomatrix
  if(!is.matrix(sociomatrix)){
    stop("'sociomatrix' must be class 'matrix'")
  }
  if(!is.numeric(sociomatrix)){
    stop("'sociomatrix' must be type 'numeric'")
  }
  dims <- dim(sociomatrix)
  if(dims[1] != dims[2]){
    stop("'sociomatrix' must be square")
  }
  actors <- 1:(dims[1]) # used in checking path
  
  # Check path or source & target, as necessary
  if(!is.null(path)){
    for(actor in path){
      if(!(actor %in% actors)){
        stop("All elements of 'path' must correspond to actor indices in 'sociomatrix'")
      }
    }
  }else{ # if there is no path provided, we use source and target nodes
    if(is.null(source) || is.null(target)){
      stop("Either a path of vertices or a source and target vertex must be provided")
    }
    if((length(source) != 1) || (length(target) != 1)){
      stop("'source' and 'target' must be unique")
    }
    if(!((source %in% actors) && (target %in% actors))){
      stop("'source' and 'target' must both correspond to vertex indices in 'sociomatrix'")
    }
  }
  
  # Check p_norm
  if(!(is.numeric(p_norm) && (length(p_norm) == 1))){
    stop("'p_norm' must be a unique numeric")
  }
  if(p_norm < 0){
    stop("'p_norm' must be nonnegative")
  }
}

# Dijkstra Function 
shortest_path <- function(distance_matrix, source, target, p_norm){
  if(p_norm == Inf){
    prev <- dijkstra_inf(distance_matrix, source - 1) + 1 #adjusting for Cpp indices
  } else {
    prev <- dijkstra((distance_matrix^p_norm), source - 1) + 1 #adjusting for Cpp indices
  }
  if(is.na(prev[target])){
    path <- NA # path is disconnected
  } else {
    # Now walk backwards through 'prev'
    on <- target
    path <- c(on)
    while(on != source){
      on <- prev[on]
      path <- c(on, path)
    }
  }
  return(path)
}

get_tie_strengths <- function(sociomatrix, path){
  if(is.na(path[1])){return(0)} # If path does not exist, tie_striength = 0
  tie_strength <- rep(0,(length(path) - 1))
  for(i in 1:(length(path)-1)){
    on <- path[i]; to <- path[i + 1];
    tie_strength[i] <-  sociomatrix[on,to]
  }
  return(tie_strength)
}