.packageName <- "resper"
# \subsection{Original accept and reject algorithm}
# \label{sec:byrow-sample}
# 
# The following function runs the algorithm described in
# \cite{huber2003}. It picks the first row of the matrix and randomly
# selects a column, where the sample elements are weighted by the
# probability formula given above. If the last element of the sampling
# vector is selected (the one that has fills up the probability sum to
# one), the whole sample is rejected and restarted. This is accomplished
# by a \verb+repeat+ loop encapsulated by another \verb+repeat+ loop,
# and the Boolean variable \verb+accept+. The outermost loop is broken
# out of iff \verb+accept==TRUE+.
###  Algorithm from Figure 2    
ResperByrow <- function(mat) {
  reject <- 0
  repeat { # the outer loop; exited after proper sample
    # The accept flag is initialized to \verb+TRUE+, the row sums and 
    # dimension
    # are calculated, and the indices are initialized as a reference. These 
    # are
    # needed because the matrix is reduced to its minors later, to maintain 
    # the
    # reference from the column of a minor to the column of the matrix. Then
    # the inner loop is entered. This \verb+repeat+ loop can be broken out of
    # successfully (if a permutation is complete) or with a failure (if a
    # permutation failed to be sampled). If it is exited successfully, exit
    # this loop also, if not, increment the variable \verb+reject+, 
    # re-initialize and re-enter the inner loop.
    # The
    # variable \verb+reject+ records the number of failures. It is returned 
    # with the permutation in a
    # common data structure.
    accept <- TRUE
    at <- mat
    rt <- apply(at, 1, sum)
    n <- nrow(at)
    rownames(at) <- colnames(at) <- 1:n
    indizes <- 1:n
    perm <- NULL
    repeat { # the inner loop; exited on failed sample for retry
      # Failures within this loop can occur if the matrix includes
      # a zero row, or if the random sampling process selects the
      # ``column'' beyond the matrix.
      # 
      # If a column of the matrix is sampled, the vector of permutation is
      # extended by the selected column. Note that the column number has to
      # denote the column number of the original matrix, not of the current,
      # reduced, matrix. Therefore, the column numbers of the original matrix
      # are passed as colnames and referenced when the permanent is extended.
      ##  1:n doesn't change, even if n is changed
      ##  within the loop 
      for (i in 1:n) {
        ##  reject if any row with only zeros
        if (prod(rt)==0) {
          accept <- FALSE
          break
        ##  trap special case of 1 by 1 matrix  
        } else if (n==1) {
          elt <- 1
        } else {
          # First, create the vector of sample weights (permanent bounds of
          # all the minors), including
          # the extra element that completes the sum so that it
          # equals the permanent bound of the current matrix.
          # Then, sample and reject if this extra element is selected.
          Mrt <- HuberProbs(at, 1)
          elt <- sample(n+1, 1, prob=Mrt)
          if (elt==n+1) {
            accept <- FALSE
            break
          }
                            }
        ##  update permutation vector
        perm <- c(perm, indizes[elt])
        if (n > 1) {
          at <- at[-1, -elt]
          indizes <- indizes[-elt]
          if (is.matrix(at)) {
            ##  re-calculate row sums and dimension
            rt <- apply(at, 1, sum)
            n <- nrow(at)
            ##  trap special case of 1 by 1 matrix  
          } else {
            ##  don't reduce further, just
            ##  re-calculate row sums and dimension
            rt <- at
            n <- 1
          }   
        }
      }  
      break  #  proper permutation sampled
    }   
    if (accept) break else {
      reject <- reject+1
    }
  }
  list(perm=perm, reject=reject)
}
# \subsection{The separating accept and reject algorithm}
# \label{sec:clot-sample}
# This function uses an accept-reject algorithm that tries
# to break up the matrix into a block-diagonal structure.
# It selects a row whose elimination will bring the matrix
# closer to a block-diagonal structure, samples an appropriate
# cell from the 1s in the row (denoting the position to
# which the element corresponding to the row will be shifted), eliminates the 
# cell row and column from the matrix and
# reiterates the algorithm on the minor. The sampling
# weights are constructed by an envelope probability
# discovered by \cite{huber2003}, which guarantees that the
# sum of weights over all minors is less than or equal
# to the weight of the matrix itself. If the algorithm
# samples the ``less than'' part, it will reject and
# restart the current attempt.
# 
# The modified algorithm does not take the rows in the given order,
# but picks a row by certain criteria.
# 
# The first criterion addresses possible separators,
# that is, sets of few columns that, when removed,
# leave the matrix with a block diagonal structure.
# If one views the matrix as an adjacency matrix of
# a graph, the task is now to look for waists of the
# graph.
# 
# As one can rely on the matrix having a tube structure,
# a primitive algorithm is sufficient to look for
# waists in the corresponding graph.
# These columns are detected by counting the number
# of ones below the main diagonal.
# 
###  selection criteria for separator
firstcrit <- function(mat) {
  n <- nrow(mat)
  lowerdiag <- outer(1:n, 1:n, ">=")
  ##  the most desirable is the column _after_ the one
  ##  with the least ones from the main diagonal
  apply(cbind(rep(1,n), mat[,1:n-1])*
        ##  do not choose columns with 1s to the bottom
        ##  therefore heavy weight to bottom row
        array(rep(c(rep(1, n-1), n), n), dim=c(n,n)) *
        lowerdiag, 2, sum) 
}
# 
# If one aims to split a matrix into separate blocks,
# one would like the blocks to have the same size.
# Therefore, the second criterion favors
# the middle rows and therefore is a convex,
# symmetric function of the row index.
# 
secondcrit <- function(mat) {
    n <- nrow(mat)
    (1:n) * (n:1)/(n + 1)/(n + 1) * 8
}
# 
# The row with the minimal sum of first and second criterion is selected.
# 
selectrow <- function(mat) {
  which.min(firstcrit(mat)-secondcrit(mat))
}
# The main idea of speeding up the process is to
# select the rows to reduce the matrix such as to
# obtain minors with a block-diagonal structure.
# If a block-diagonal structure is detected, the
# algorithm calls itself recursively on the blocks
# and pastes the results together to get the whole
# permutation.
# 
# Again, this is not a function that works on
# general symmetric 0-1 matrices.
# Instead of globally searching for a block structure,
# it looks if subsequent rows have at least one zero
# in either column.
seps <- function(mat) {
    if (dim(mat)[1] < 3) 
        NULL
    else {
        n <- nrow(mat)
        sumoff <- c(sum(mat[2:n, 1] + mat[1, 2:n]), sapply(2:(n - 
            1), function(i) {
            sum(mat[1:i, (i + 1):n]) + sum(mat[(i + 1):n, 1:i])
        }))
        which(sumoff == 0)
    }
}
# 
# 
# The next row is selected according to the two criteria, and the column
# is sampled according to the weights obtained by equation \ref{eq:huber-g}. 
# If the element beyond the matrix rows is
# selected, the current sample is rejected and restarted.
ResperClotInner <- function(mat) {
  reject <- 0
  repeat {
    # The permutation structure is initialized as a two-column
    # matrix, the first column denoting the row indices and the
    # second the column indices. The outer wrapper function
    # converts these to a permutation vector.
    # 
    # The acceptance flag is initialized to \verb+TRUE+, the
    # row sums and dimension are calculated. The rownames and
    # the colnames are initialized to the indices if they are
    # not present. If there are rownames and colnames already,
    # do not overwrite them as the function can be called
    # recursively.
    # 
    # Then, sample, reject, and try again until a proper sample
    # is selected.
    perm <- c(NULL, NULL)
    accept <- TRUE
    n <- nrow(mat)
    if (is.null(colnames(mat))) {
      colnames(mat) <- 1:n
      rownames(mat) <- 1:n
    }
    at <- mat
    rt <- apply(at, 1, sum)
    repeat {
      # First, trap the special case where the matrix has only
      # one dimension. In this case, fill the permanent structure
      # with the last row and column index, and return successfully.
      if (n==1) {
        perm <- rbind(perm, as.numeric(c(rownames(at), colnames(at))))
        break
      }
      # If the matrix contains only ones, one can sample from
      # the unrestricted set of permutations.
      else if (prod(at)==1) {
        # In the unrestricted case, one can simply use R's \verb+sample()+
        # algorithm. which is used for the column index column of the
        # permutation structure, which is then updated row-wise by the
        # permutation of the current matrix.
        unrestricted <- array(as.numeric(c(rownames(at),
                                           sample(colnames(at),
                                                  size=ncol(at)))),
                              dim=c(nrow(at),2))
        perm <- rbind(perm, unrestricted) 
        ## exit successfully 
        break
      } 
      # If there is a block-diagonal structure, call
      # function recursively on the blocks.
      else if (length(seps <- seps(at))>0) {
        bstart <- c(1, seps+1)
        bend <- c(seps, n)
        for (i in (1:length(bstart))) {
          ## recursively call the function on the blocks
          a <- ResperClotInner(at[bstart[i]:bend[i],
                                    bstart[i]:bend[i], drop=FALSE])
          perm <- rbind(perm, a$perm)                          
          reject <- reject+a$reject
        }
        ##  exit successfully
        break 
      }  
      # The next test is on the main diagonal containing a 0. By virtue of the
      # tube structure of the original matrix, if any of its minors has a 0 in
      # the main diagonal, this minor necessarily contains a rectangular
      # submatrix of only 0s that includes either both the first row and the
      # last column or the last row and the first column. This is a sufficient 
      # condition for the permanent of this minor being 0 (a result cited in 
      # \cite{minc1978}), which in turn is reason enough to reject and 
      # restart.
      else if (prod(diag(at))==0) {
        accept <- FALSE
        break
      }
      #   Now that we've handled the special cases,
      #   let's treat the normal case.
      else {
        # The row is sampled according to the optimality
        # criteria. The column is sampled at random.
        # If the element beyond the matrix columns is
        # selected, the accept-reject algorithm rejects.
        i <- selectrow(at) 
        Mrt <- HuberProbs(at, i)
        j <- sample(n+1, 1, prob=Mrt)
        if (j==n+1) {
          accept <- FALSE
          break
        }        ##  update permutation structure
        perm <- rbind(perm, as.numeric(c(rownames(at)[i],
                                         colnames(at)[j])))
        at <- at[-i,-j, drop=FALSE]
        n <- n-1
        if (dim(at)[1]==0) break
      }    }
    if (accept) {
      break
      } 
    else {
      reject <- reject+1
    }
    
          }
  list(perm=perm, reject=reject)
}
# 
# Finally, a wrapper function is written that reduces the permanent data
# structure to a single permanent vector, as in the function for the
# Huber algorithm.
# 
ResperClot <- function(mat) {
  a <- ResperClotInner(mat)
  a$perm <- a$perm[order(a$perm[,1]), 2]
  a
}
# \subsection{Auxiliary functions}
# \label{sec:helper}
# 
# \subsection{The recursive function}
# \label{sec:recfun}
# The novelty introduced by Huber is the variation of a
# bound of the permanent from above \cite{bregman1973} that works as a 
# probability: The
# value of a function of a matrix is always at least as big as the sum
# of the values of the function of the minors, developed around a column
# of the matrix. It is the recursive function on the dimension $n$ of
# the matrix:
# \begin{eqnarray}
#   \label{eq:huberg}
#   G(n) :=
#   \begin{cases}
#      \text{e} & \text{for }n=1 \\
#       G(n-1)+1+0.5/G(n-1)+0.6/G(n-1)^2 & \text{for }n>1
#   \end{cases}
# \end{eqnarray}

HuberGInner <- function(n) {
    if (n == 1) 
        exp(1)
    else {
        gnm <- HubergGInner(n - 1)
        gnm + 1 + 0.5/gnm + 0.6/gnm/gnm
    }
}
 
# R does not like recursion too much, so a non-recursive version is
# employed here:
HuberGNonRecursive <- function(n) {
    for (i in 1:n) {
        if (i == 1) 
            gnm <- exp(1)
        else gnm <- gnm + 1 + 0.5/gnm + 0.6/gnm/gnm
    }
    gnm
}
# 
# A wrapper for the function is used that checks for valid entries:
# 
HuberGE <- function(n) {
    if (n > floor(n)) {
        stop("n must be of integer value")
    }
    else if (n < 0) {
        stop("n must be at least 1")
    }
    else if (n == 0) 
        0
    else {
        HuberGNonRecursive(n)/exp(1)
    }
}
# \subsection{The selection probability}
# \label{sec:selectprob}
# 
# The actual probability is given by
# \begin{eqnarray}
#   \label{eq:permboundary}
#   M(A) & := & \prod_i G(c_i) ,
# \end{eqnarray}
# where $c_i$ is
# the sum of the $i$th column (i.e. the number of ones in it).
# 
###  Formula (3)
PermBound <- function(mat) {
        prod(sapply(apply(mat, 2, sum), HuberGE))
}
# 
# As said, this is a probability because
# \begin{eqnarray}
#   \label{eq:probability}
#   M(A) \ge \sum_j a_{ij} M(A(\breve{\imath}, \breve{\jmath})) 
# \quad\forall\quad i.
# \end{eqnarray}
#  The \verb+drop=FALSE+ argument retains the array structure even if the 
# dimension of the matrix is 1 (see \cite{R-FAQ}). The vector of the above sum 
# elements is needed to sample a row for a given column. The function pastes 
# the difference of the sum of these elements from one to the end.
# 
HuberProbs <- function(at, i) {
    n <- nrow(at)
    Mrt <- sapply(1:n, function(j) {
        if (at[i, j] > 0) {
            PermBound(at[-i, -j, drop=FALSE])
        }
        else {
            0
        }
    })
    c(Mrt, PermBound(at) - sum(Mrt))
}
# The most important application of a tube matrix
# in this context is the one that determines
# permutability between elements that are close
# to each other. Therefore, a function is desirable that
# returns such a matrix from an ordered sequence
# $(t_i)_{i\in \{1,\ldots , n\}}$ and a lag $\Delta$.
# The rows and columns of the matrix
# correspond to the elements in the ordered seqence,
# and an element $a_{ij}$ is set to \verb+TRUE+
# exactly when $|t_i-t_j| < \Delta$. The Boolean entries
# in the matrix are converted to 0s and 1s when arithmetic
# functions are applied to them.
WithinDeltaMat <- function(seq, delta) {
  outer(seq, seq+delta, '<') & outer(seq+delta, seq, '>')
}

