R/transformPermCoding.R

In statcomp: Statistical Complexity and Information Measures for Time Series Analysis

# ----------------------------------------------------------------------------
# Generate vector for transforming opd-original to any given ordinal pattern distribution!
# ----------------------------------------------------------------------------
# the "natural" coding scheme of my function is generate_kellerperm_matrix_Olivares!
# INPUTS: 
# ndemb: Embedding dimension for time series
# target_pattern: either a character vector specifying the target pattern, 
# or a numeric matrix, which contains a self-constructed permutation coding scheme!
# OUTPUT: a numeric vector that contains the indices for changing the ordering for the ordinal pattern distribution!

#' @title A function to generate a vector from an index-transformation vector from a permutation coding scheme
#' @export
#' @description Generates a position vector to change the ordinal pattern distribution in the default permutation coding scheme (i.e. generated by ordinal_pattern_distribution(x, ndemb)) into a user-specified coding scheme. This is a required input for the function changePermCodingOPD.
#' @usage transformPermCoding(target_pattern, ndemb)
#' @param target_pattern A numeric matrix that specifies the pattern to be transformed into the position vector. 
#' @param ndemb Embedding dimension of the ordinal patterns (i.e. sliding window size). Should be chosen such as length(x) >> ndemb
#' @details 
#' This function returns a character vector to transform the output of ordinal_pattern_distribution (permutation coding as of Keller and Sinn, 2005) into a user-specified permutation coding scheme.
#' For example, pattern #5 in "lehmerperm" (ndemb = 5) is given by the ranks c(0, 1, 4, 2, 3). This corresponds to pattern #41 in the (original) Keller coding scheme, as given by transformPermCoding(target_pattern = "lehmerperm", ndemb = 5)[5].
#' @return A numeric vector of length factorial(ndemb), which contains the positions of the corresponding patterns in the Keller Coding scheme. 
#' @references Olivares, F., Plastino, A. and Rosso, O.A., 2012. Ambiguities in Bandt-Pompe's methodology for local entropic quantifiers. Physica A: Statistical Mechanics and its Applications, 391(8), pp.2518-2526.
#' @author Sebastian Sippel
#' @examples
#' transformPermCoding(target_pattern = "lehmerperm", ndemb = 4)
transformPermCoding <- function(target_pattern, ndemb) {
  
  if (is.numeric(target_pattern) && is.matrix(target_pattern) && (dim(target_pattern) == c(factorial(ndemb), ndemb))) {
    pattern = target_pattern
  } else {
    print("A valid option for 'target_pattern' must be supplied!")
    return(NA)
  }
  transform_vec = sapply(1:factorial(ndemb), FUN=function(i) which(ordinal_pattern_distribution(pattern[i,], ndemb=dim(pattern)[2]) == 1))
  return(transform_vec)
}




# Generate NEW pattern coding schemes:
# ----------------------------------------------------------------------------
#' @title A function to create new pattern-coding schemes for the Fisher Information.
#' @export
#' @description Adjusts and reorders a pattern ordering matrix.
#' @usage adjust_pattern(pattern_matrix, adjustment)
#' @param pattern_matrix A numeric matrix that specifies the pattern to be transformed into the position vector. ATTENTION: Pattern should be in the ranks permutation notation, otherwise does not really make sense.
#' @param adjustment A character vector, either adjustment = "jumps" or adjustment = "bitflips" that denotes the sorting type
#' @details 
#' This function reorders permutations based on "jumps" or based on "bitflips".
#' @return A numeric matrix that contains the permutation matrix.
#' @references Sebastian Sippel, 2014. Master Thesis. University of Bayreuth.
#' @author Sebastian Sippel
adjust_pattern <- function(pattern_matrix, adjustment = "jumps") {
  if (adjustment == "jumps") {
    patterns_njumps = njumps(pattern_matrix)
    sort.idx = sort.int(x=patterns_njumps, decreasing=F, index.return=T)$ix
  } else if  (adjustment == "bitflips") {
    # sort based on patterns_nbitflips:
    patterns_nbitflips <- findinversions(pattern_matrix)
    sort.idx = sort.int(x=patterns_nbitflips, decreasing=F, index.return=T)$ix
  }
  return(t(sapply(sort.idx, FUN=function(idx) pattern_matrix[idx,])))
}



# -------------------------------
# FOR INTERNAL USE
# -------------------------------
#' @title A function to convert a "ranks-based" permutation notation to an "index-based" permutation scheme.
#' @export
#' @description Converts permutations denoted by ranks to permutations denoted by indices and back.
#' @usage rank_to_permutation(pattern, permutation.notation)
#' @param pattern A numeric vector that denotes a permutation pattern.
#' @param permutation.notation The permutation notation that should be used. Could be "Olivares.2012" or "Keller.2005".
#' @details 
#' This function converts ranks to indices and back.
#' @return A numeric vector, which contains the transformed permutation.
#' @references Sebastian Sippel (2014). Master Thesis. University of Bayreuth.
#' @author Sebastian Sippel
rank_to_permutation <- function(pattern, permutation.notation = "Olivares.2012") {
  
  n = length(pattern)
  
  if (permutation.notation == "Olivares.2012") {
    pattern_sorted = sort(pattern, decreasing = F)
    idx = sapply(X=1:n, FUN=function(i) which(pattern==pattern_sorted[i]) - 1)
  } else if (permutation.notation == "Keller.2005") {
    pattern_sorted = sort(pattern, decreasing = T)
    idx = sapply(X=1:n, FUN=function(i) n - which(pattern==pattern_sorted[i]))
  }
  return(idx)
}
# "backwards compatibility":
# -----------------------------
# rank.to.permutation is completely backwards compatible.
# checked, 12.01.2016, Sebastian Sippel
# lehmerperm = generateCodingScheme(target_pattern="lehmerperm", ndemb=4)
# lehmerperm_ranks = t(apply(X=lehmerperm, MARGIN=1, FUN=rank.to.permutation))
# lehmerperm_backwards = t(apply(X=lehmerperm_ranks, MARGIN=1, FUN=rank.to.permutation))
# any(!(lehmerperm == lehmerperm_backwards))


# Generate Lehmer matrix following Olivares et al 2012:
#' @title A function to generate the Lehmer permutation ordering.
#' @export
#' @description Generates all permutations of a given embedding dimension, ordered according to the Lehmer coding scheme.
#' @usage generate_lehmerperm_matrix(ndemb)
#' @param ndemb The embedding dimension.
#' @details 
#' This function converts ranks to indices and back.
#' @return A numeric matrix that contains the Lehmer permutation pattern.
#' @references http://www.keithschwarz.com/interesting/code/?dir=factoradic-permutation
#' @author Sebastian Sippel
generate_lehmerperm_matrix <- function(ndemb) {
  return(t(sapply(1:factorial(ndemb), FUN=function(x) lehmerperm(N=ndemb, M = x) - 1)))
}