R/label_switch.R

In mixAR: Mixture Autoregressive Models

## Do not edit this file manually.
## It has been automatically generated from mixAR.org.

## Adaptation of the method in Celeux (2000)
## Input is a matrix with g columns, m is the number of iterations on which
## to compute initial mean and variance.

## If comparing probabilities, mu or sigma, output from bayes_mixAR can be used.
## If comparing AR coefficients, need first to adapt elements of interest in a matrix.

label_switch <- function(x, m){
    N <- nrow(x)
    g <- ncol(x)
    avg <- colMeans(x[1:m, ])
    s2 <- apply(x[1:m, ], 2, sd)

    perm <- rbind(c(1:g), allPerms(g)) ## Function from package permute
                                       ## Builds a matrix where each row is 1 perm
                                       ## of the labels
    true_perm <- matrix(nrow = N - m, ncol = g)
    for(i in (m+1):N){
        true_perm[i-m, ] <- c(1:g)

        ## Apply formulas from the theory
        d <- sum((x[i, ] - avg)^2 / s2)
        for(p in 2:nrow(perm)){
            dd <- sum((x[i, ] - avg[perm[p, ]])^2 / s2[perm[p, ]])
            if(dd < d){ ## Update "true" perm if new distance is smaller than current one
                d <- dd
                true_perm[i - m, ] <- perm[p, ]
            }
        }
        x[i, ] <- x[i, true_perm[i - m, ]]
        ## Finally calculate standard deviations of "corrected" chain
        avgg <- avg
        avg <- (i - 1)/i * avgg + 1/i * x[i, ]
        for(k in 1:g){
            s2[k] <- (i - 1) / i * s2[k] +
                (i - 1) / i *(avgg[k] - avg[k])^2 +
                1 / i * (x[i, k] - avg[k])^2
        }
    }
    list(x = x, true_perm = true_perm)
}

## todo: This could be exported to another package?
## as it is suitable for relabelling of ANY mixture.