R/tally.R

In toporanga: Topological Sort-Based Hierarchy Inference

list_tally<-function(tally){
  stopifnot(inherits(tally,"toporanga_tally"))
  
  if(!is.null(tally$l))
    return(tally$l)
  
  if(!is.null(tally$m)){
    ll<-unique(sort(rownames(tally$m)))
    ans<-data.frame(
      a=factor(rownames(tally$m)[col(tally$m)],levels=ll),
      b=factor(rownames(tally$m)[row(tally$m)],levels=ll),
      w=as.numeric(tally$m)
    )
    ans[ans$w>0,]->ans
    rownames(ans)<-NULL
    return(ans)
  }
  
  stop("Not implemented yet")
}

matrix_tally<-function(tally){
  stopifnot(inherits(tally,"toporanga_tally"))
  
  if(!is.null(tally$m))
    return(tally$m)
  
  if(!is.null(tally$l)){
    l<-tally$l
    agents<-levels(l$a)
    c<-length(agents)
    matrix(0,c,c)->ans
    rownames(ans)<-colnames(ans)<-agents
    ans[cbind(as.character(l$b),as.character(l$a))]<-l$w
    return(ans)
  }
  
  stop("Not implemented yet")
}

#' @export
print.toporanga_tally<-function(x,...){
  m<-as.matrix(x)
  cat(sprintf("\n\tToporanga tally for %d agents\n\n",ncol(m)))
  print(m)
  cat("\n")
  invisible(x)
}

#' @export
as.matrix.toporanga_tally<-function(x,...){
  stopifnot(inherits(x,"toporanga_tally"))
  m<-matrix_tally(x)
  n<-ncol(m)
  ag<-colnames(m)
  dimnames(m)<-list(Opposing=ag,Winning=ag)
  m
}

#' @export
as.data.frame.toporanga_tally<-function(x,...,stringsAsFactors=FALSE){
  stopifnot(inherits(x,"toporanga_tally"))
  l<-list_tally(x)
  data.frame(
    Winning=as.character(l$a),
    Opposing=as.character(l$b),
    Weight=l$w,
    stringsAsFactors=stringsAsFactors)
}

#' Convert tally weights into margin weights
#'
#' When we have \eqn{w(A\rightarrow B)=a} and \eqn{w(B\rightarrow A)=b<a}, this function will change \eqn{w(A\rightarrow B)} to \eqn{a-b} and \eqn{w(B\rightarrow A)} to \eqn{0}.
#' @param tally a \code{toporanga_tally} object in which weights are going to be converted to margins.
#' @returns A modified \code{toporanga_tally} object.
#' @export
marginise<-function(tally){
  m<-matrix_tally(tally)
  m<-m-t(m)
  m[m<0]<-0
  list(m=m)->ans
  class(ans)<-"toporanga_tally"
  ans
}

#' Zero the opposing tally weights
#'
#' When we have \eqn{w(A\rightarrow B)=a} and \eqn{w(B\rightarrow A)=b<a}, this function will retain \eqn{w(A\rightarrow B)=a} and change \eqn{w(B\rightarrow A)} into \eqn{0}.
#' @param tally a \code{toporanga_tally} object in which opposing weights are going to be zeroed.
#' @param quench whether to remove tied-up weights.
#' @returns A modified \code{toporanga_tally} object.
#' @export
zero_opposition<-function(tally,quench=FALSE){
  m<-matrix_tally(tally)
  if(quench){
   m[m<=t(m)]<-0
  }else{
   m[m<t(m)]<-0
  }
  list(m=m)->ans
  class(ans)<-"toporanga_tally"
  ans
}


#' Normalise tally weights
#'
#' When we have \eqn{w(A\rightarrow B)=a} and \eqn{w(B\rightarrow A)=b}, this function will normalise both to sum to 1, i.e. divide by \eqn{a+b}.
#' This way dominance matters more than engagement in conflicts between particular agents; in particular, an agent that frequently loses in typical events but always dominate over the otherwise dominating agent will come on top with normalised weights, while remain near the bottom otherwise.
#' @param tally a \code{toporanga_tally} object in which weights are going to be normalised.
#' @returns A modified \code{toporanga_tally} object.
#' @export
normalise<-function(tally){
  m<-matrix_tally(tally)
  div<-m+t(m)
  div[div==0]<-1
  m/div->m
  diag(m)<-0
  list(m=m)->ans
  class(ans)<-"toporanga_tally"
  ans
}


#' Create tally from an event log
#'
#' Collects a log of domination events into a \code{toporanga_tally} object which can be fed to other functions in the package.
#' @param winning vector of IDs of winning agents.
#' @param opposing vector of IDs of opposing agents.
#' @param weight optional weight of the event; set to 1 for each event if not given.
#' @param agents optional vector ofg IDs of all agents; allows for ghost agents that are in the set but are not involved in any event.
#' @param ... ignored.
#' @returns A \code{toporanga_tally} object.
#' @export
tally_log<-function(winning,opposing,weight,...,agents){
  winning<-as.character(winning)
  opposing<-as.character(opposing)
  stopifnot(all(!is.na(winning)))
  stopifnot(all(!is.na(opposing)))
  if(!missing(weight) && any(is.na(weight))) stop("Cannot accept NAs in weights")
  if(!missing(agents) && any(is.na(agents))) stop("Cannot accept NAs in agents")
  stopifnot(length(winning)==length(opposing))
  ne<-length(winning)

  if(ne==0){
    if(missing(agents)) agents<-character(0)
    if(length(agents)<2) stop("Tally has to have at least two agents")
    fl<-factor(c(),levels=agents)
    ans<-list(l=data.frame(a=fl,b=fl,w=numeric(0)))
    class(ans)<-"toporanga_tally"
    return(ans)
  }

  if(any(winning==opposing)){
    sort(unique(winning[winning==opposing]))->sa
    stop(sprintf("Log contains agent(s) winning with themselves: %s",paste(sa,collapse=', ')))
  }
  
  if(missing(weight)) weight<-rep(1,ne)
  stopifnot(length(weight)==ne)
  stopifnot(all(weight>=0))

  agents_found<-sort(unique(c(winning,opposing)))
  if(!missing(agents)){
    if(!all(agents_found%in%agents))
      stop(
        sprintf("Event log includes agents not given by agents argument: %s",
          paste(setdiff(agents_found,agents),collapse=", ")
        )
      )
    agents<-unique(agents)
  }else{
    agents<-agents_found
  }
  winning<-factor(winning,levels=agents)
  opposing<-factor(opposing,levels=agents)

  paste(as.numeric(winning),as.numeric(opposing),sep="~")->ec

  data.frame(a=winning,b=opposing,w=weight)->ans
  do.call(rbind,lapply(split(ans,ec),function(x){
    sum(x$w)->w
    x[1,]->x
    x$w<-w
    x
  }))->ans
  rownames(ans)<-NULL
  ans<-list(
    l=ans
  )
  class(ans)<-"toporanga_tally"
  ans
}

random_tally<-function(c=5,sat=0.7){
  expand.grid(1:c,1:c)->a
  a[sample(nrow(a),sat*nrow(a)),]->a
  a$w<-stats::runif(nrow(a))
  a[a[,1]!=a[,2],]->a
  tally_log(a[,1],a[,2],a$w)
  
}

#' Create tally from a raw matrix
#'
#' Creates a \code{toporanga_tally} objects from a matrix representing counts of domination events between pairs of agents.
#' @param x matrix to convert.
#' It must be square, have zero diagonal, non-negative values and identical column and row names or lack of both ("1".."n" is gonna be inferred in this case).
#' @returns \code{toporanga_tally} object.
#' @note If in doubt, use \code{tally_log} instead of this function.
#' @export
tally_from_matrix<-function(x){
  stopifnot(is.matrix(x))
  stopifnot(nrow(x)==ncol(x))
  stopifnot(all(is.numeric(x)))
  stopifnot(all(diag(x)==0))
  stopifnot(all(x>=0))
  if(is.null(colnames(x))) colnames(x)<-seq_len(ncol(x))
  if(is.null(rownames(x))) rownames(x)<-seq_len(nrow(x))
  stopifnot(identical(colnames(x),rownames(x)))
  ans<-list(
    m=x
  )
  class(ans)<-"toporanga_tally"
  ans
}