# R/export.internal.R In MmgraphR: Graphing for Markov, Hidden Markov, and Mixture Transition Distribution Models

#### Documented in trmat.depmix.fitted

##' -------------------------------------------------------- #
##' Date:            2018-06-05
##'
##' Description:
##' Internal functions exported by main functions
##'
##'
##'	Contents:
##' is.wholenumber 			: is whole number
##'												(taken from the examples of function:integer in package:base
##'	trmat.depmix.fitted	: extract the  probability transition matrix
##'												from an object of class 'depmix.fitted'
##'	is.max							:	is maximum
##'	is.min							:	is minimum
##'	paths								:	create paths to be used
##'	smax								:	state maximum
##'	smin								:	state minimum
##' sum1								:	check if sum of each row of matrix equals 1
##'	tmax								:	total maximum
##'	tmin								:	total minimum
##'
##' -------------------------------------------------------- #
## is.wholenumber
is.wholenumber <- function(x, tol = .Machine\$double.eps^0.5){
abs(x - round(x)) < tol
}
## trmat.depmix.fitted
trmat.depmix.fitted <- function(d) {
M <- attributes(d)\$nstates
Mat <- matrix(0, M, M)
for (i in 1:M) {
for (j in 1:M) {
Mat[i, j] <- (attributes(d)\$transition[[i]])@parameters\$coefficients[j]
}
}
return(Mat)
}
## is.max
is.max <- function(M, l, dt) {
ml <- M ^ l
k <- 0
for (j in 0:(ml - 1)) {
for (i in (1:M)) {
if (dt\$w[i + k] == max(dt\$w[(j * M + 1):((j + 1) * M)])) {
dt\$mx[i + k] <- "TRUE"
} else {
dt\$mx[i + k] <- "FALSE"
}
}
k <- k + M
}
return(dt)
}
## is.min
is.min <- function(M, l, dt) {
ml <- M ^ l
k <- 0
for (j in 0:(ml-1)) {
for (i in (1:M)) {
if (dt\$w[i + k] == min(dt\$w[(j * M + 1):((j + 1) * M)])) {
dt\$mn[i + k] <- "TRUE"
} else {
dt\$mn[i + k] <- "FALSE"
}
}
k <- k + M
}
return(dt)
}
## paths
paths <- function(M, l) {
ml <- M ^ l
pathsmatrix <- matrix(0, ml * M, l + 1)
pathsmatrix[, l + 1] <- rep(1:M, ml)
if (l >= 1) {
for (j in 1:l) {
pathsmatrix[, j] <- rep(1:M, M ^ (l - j), each = M ^ j)
}
}
return(as.data.frame(pathsmatrix))
}
## smax
smax <- function(M, l, dt, shade.col) {
ml <- M ^ l
vecdatch <- as.vector(dt\$ch)
for (i in 1:(ml * M)) {
if (dt\$mx[i] == "FALSE") {
} else {
vecdatch[i] <- as.vector(dt\$ch)[i]
}
}
ch <- vecdatch
dt\$ch <- as.data.frame(ch)
return(dt)
}
## smin
smin <- function(M, l, dt, shade.col) {
ml <- M ^ l
vecdatch <- as.vector(dt\$ch)
for (i in 1:(ml * M)) {
if (dt\$mn[i] == "TRUE") {
vecdatch[i] <- as.vector(dt\$ch)[i]
} else {
}
}
ch <- vecdatch
dt\$ch <- as.data.frame(ch)
return(dt)
}
## sum1
sum1 <- function(d) {
nr <- nrow(d)
sm1 <- matrix(rep(0, nr))
for (i in 1:nr) {
sm1[i] <- sum(d[i, ])
}
if (any(sm1 != 1)) {
return(FALSE)
} else {
return(TRUE)
}
}
## tmax
tmax <- function(M, l, dt, shade.col, num) {
ml <- M ^ l
dt <- dt[order(dt\$w, decreasing = TRUE), ]
vecdatch <- as.vector(dt\$ch)
for (i in (num + 1):(ml * M)) {
vecdatch [ i ] <- shade.col
}
ch <- vecdatch
dt\$ch <- as.data.frame(ch)
return(dt)
}
## tmin
tmin <- function(M, l, dt, shade.col, num) {
ml <- M ^ l
dt <- dt[order(dt\$w, decreasing = FALSE), ]
vecdatch <- as.vector(dt\$ch)
for ( i in (num + 1):(ml * M)) {