Nothing
##' -------------------------------------------------------- #
##' Author: Pauline (Poulcheria) Adamopoulou, padamopo@gmail.com
##' 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") {
vecdatch[i] <- shade.col
} 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 {
vecdatch[i] <- shade.col
}
}
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)) {
vecdatch[i] <- shade.col
}
ch <- vecdatch
dt$ch <- as.data.frame(ch)
return(dt)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.