R/graph.R

In toporanga: Topological Sort-Based Hierarchy Inference

construct_graph<-function(mtx,agents,order){
  rownames(mtx)<-colnames(mtx)<-agents
  ans<-list(m=mtx)
  ans$o<-agents[order]
  class(ans)<-"toporanga_graph"
  return(ans)
}

#' Parameters of agents from a graph
#'
#' Pull numerical descriptors of a toporanga graph.
#' @param g \code{toporanga_graph} object generated from tally.
#' @returns A \code{data.frame} object.
#' Each of its rows corresponds to one agent.
#' This agent's ID is listed in the \code{Agent} column.
#' \code{Superiors} counts the number of agents which are upstream from a given agent, while \code{Subordinates} counts those downstream.
#' This numbers correspond to a rank when when there is only one unique toposort of the dominance graph, and provide a graceful degradation if not.
#' In particular they do not depend on random seed or the default toposort stored in the graph object.
#' Thus, subordinate count is a recommended outcome if a single dominance score of an agent is desired.
#' The \code{Order} column notes the aforementioned default toposort, which can be re-sampled with the \code{sample_toposort}.
#' Additional columns may appear depending on meta-data in the graph object, in particular epoch parameters when using \code{epoch} argument of \code{toporanga} function.
#' @export
parameters<-function(g){
  stopifnot(inherits(g,"toporanga_graph"))
  g$m->m
  #Transitive closure
  dm<-.Call(C_fw,m*1)
  dim(dm)<-dim(m)
  ans<-data.frame(
    Agent=colnames(m),
    Superiors=rowSums(dm),
    Subordinates=colSums(dm)
  )
  if(!is.null(g$o)){
    rownames(ans)<-ans$Agent
    ans[g$o,]->ans
    ans$Order<-seq_len(nrow(ans))
  }
  for(mp in c("Epoch","StartEvent","EndEvent","StartTime","EndTime"))
    if(!is.null(g[[mp]])) ans[[mp]]<-g[[mp]]
  
  rownames(ans)<-NULL
  ans
}

reduce<-function(m){
  ag<-rownames(m)
  #Transitive reduction
  rm<-matrix(.Call(C_tc,m),ncol(m))
  dimnames(rm)<-list(Opposition=ag,Winning=ag)
  rm
}

closure<-function(m){
  ag<-rownames(m)
  #Transitive closure
  rm<-matrix(.Call(C_fw,m*1)>0,ncol(m))
  dimnames(rm)<-list(Opposition=ag,Winning=ag)
  rm
}

#' Export dominance graph into Graphviz dot format
#'
#' Produces a string vector with the dot code that can be used to plot dominance graph with Graphviz or transfer topology to other software.
#' @param x a \code{toporanga_graph} to be exported.
#' @param reduce if \code{TRUE}, a transitive reduction is applied to the graph, making it retain the order topology but removing all redundant edges.
#' @param con if given, code is pushed to the given connection instead of returned; this can simply be a file name.
#' @param ... ignored.
#' @returns Graphviz dot code of the graph, invisibly when \code{con} is given.
#' @export
dot<-function(x,con,...,reduce=TRUE){
  stopifnot(inherits(x,"toporanga_graph"))
  m<-x$m
  if(reduce) m<-reduce(m)
  rownames(m)->ag
  data.frame(
   a=ag[as.numeric(col(m))],
   b=ag[as.numeric(row(m))],
   w=as.numeric(m)
  )->Q
  Q[Q$w>0,]->Q
  c(
    "digraph {",
    sprintf('\t"%s" -> "%s";',Q$a,Q$b),
    "}"
  )->Q
  if(!missing(con)){
    writeLines(Q,con=con)
    return(invisible(Q))
  }
  Q
}

#' @export
print.toporanga_graph<-function(x,...){
  stopifnot(inherits(x,"toporanga_graph"))
  cat("\n\tToporanga dominance graph\n\n")
  
  mm<-x$m
  if(!is.null(x$o)){
    mm<-mm[x$o,x$o]
    paste("Order: ",paste(x$o,collapse=" > "),collapse="")->os
    cat(paste(strwrap(os,indent=1,exdent=4),collapse="\n"))
    cat("\n\n")
  }
  
  ag<-colnames(mm)
  mm<-reduce(mm)
  sb<-apply(mm,2,function(x) ag[x])
  fmt<-function(x)
    if(length(x)>0) sprintf("> %s",paste(x,collapse=", ")) else " ."
  
  sprintf("%s %s",names(sb),sapply(sb,fmt))->edg
  unlist(lapply(edg,strwrap,indent=2,exdent=4))->edg
  cat(paste(edg,collapse="\n"))
  cat("\n\n")
  
  invisible(x)
}

gl<-function(m){
  ag<-colnames(m)
  stats::setNames(lapply(ag,function(x) ag[m[,x]]),ag)->G
  G
}

check_dag<-function(m){
  G<-gl(m)
  for(e in names(G)){
    gs<-G[[e]]
    while(TRUE){
      gsn<-sort(unique(c(gs,unlist(G[gs]))))
      done<-identical(gsn,gs);
      gs<-gsn;
      if(done) break;
    }
    if(e%in%gs){
      message(e," is in subs of ",e);
      return(FALSE)
    } 
  }
  return(TRUE)
}

#' @export
as.matrix.toporanga_graph<-function(x,...,reduction=FALSE,closure=FALSE){
  stopifnot(inherits(x,"toporanga_graph"))
  if(reduction&&closure)
   stop("Cannot do transitive closure and reduction at the same time")
  m<-x$m
  ag<-colnames(m)
  if(reduction) return(reduce(m))
  if(closure) return(closure(m))
  dimnames(m)<-list(Opposing=ag,Winning=ag)
  m
}

#' @export
as.data.frame.toporanga_graph<-function(x,...,stringsAsFactors=FALSE,reduction=FALSE,closure=FALSE){
  stopifnot(inherits(x,"toporanga_graph"))
  ag<-colnames(x$m)
  mm<-x$m
  if(reduction&&closure)
   stop("Cannot do transitive closure and reduction at the same time")
  if(reduction) mm<-reduce(mm)
  if(closure) mm<-closure(mm)
  ans<-data.frame(
    Winning=ag[as.numeric(col(mm))],
    Opposing=ag[as.numeric(row(mm))],
    stringsAsFactors=stringsAsFactors)
  ans<-ans[as.logical(mm),]
  rownames(ans)<-NULL
  ans
}


#' Extract all possible toposorts of a graph
#'
#' Some toporanga graphs can be topologically sorted in many ways, but \code{arrange} will generate only one, random order.
#' This function allows to list all of them.
#' Use \code{sample_toposort} to fairly sample a single toposort.
#' @param x a \code{toporanga_graph} object.
#' @param limit maximal number of permutations returned; function errors when exhausted.
#' @param ... ignored.
#' @returns A list of possible orderings, in a form of vectors of agent IDs.
#' @export
all_toposorts<-function(x,...,limit=Inf){
  stopifnot(inherits(x,"toporanga_graph"))
  ag<-colnames(x$m)
  mm<-x$m

  at_rec<-function(h,m){
    which(rowSums(m)==0)->heads
    if(length(heads)==0) return(h)
    unlist(lapply(heads,function(head)
     at_rec(colnames(m)[head],m[-head,-head,drop=FALSE])
    ),recursive=FALSE)->tails
    if(length(tails)>limit)
      stop("Toposort enumeration limit exhausted")
    stats::setNames(lapply(tails,function(tail) c(h,tail)),NULL)
  }
  at_rec(c(),mm)
  
}

#' Switch default toposorts of a graph to a random one
#'
#' Some toporanga graphs can be topologically sorted in many ways, but \code{arrange} will generate only one, random order.
#' This function allows one to switch it to an another, randomly sampled one.
#' Use \code{all_toposorts} to calculate all possible orderings.
#' @param x a toporanga graph.
#' @returns The same graph, with a fairly re-sampled default order.
#' @export
sample_toposort<-function(x){
  stopifnot(inherits(x,"toporanga_graph"))
  ag<-colnames(x$m)
  mm<-x$m

  at_rec<-function(h,m){
    which(rowSums(m)==0)->heads
    if(length(heads)==0) return(h)
    head<-if(length(heads)==1) heads else sample(heads,1)
    tail<-at_rec(colnames(m)[head],m[-head,-head,drop=FALSE])
    c(h,tail)
  }
  at_rec(c(),mm)->no

  x$m<-x$m[no,no]
  x$o<-no
  return(x)
}