markov.coort.table {arvoRe}R Documentation

Usage

markov.coort.table(TheTree, markov.propertiesMAT, markov.termination, initial.coort = 10000, seed = FALSE, absorventstatedeath = 1)

Arguments

TheTree
markov.propertiesMAT
markov.termination
initial.coort
seed
absorventstatedeath

Examples

##---- Should be DIRECTLY executable !! ----
##-- ==>  Define data, use random,
##--    or do  help(data=index)  for the standard data sets.

## The function is currently defined as
function(TheTree, markov.propertiesMAT, markov.termination, initial.coort = 10000, seed = FALSE,
                                                                absorventstatedeath = 1) {

        # ajusta a semente escolhida pelo usuário
        if (seed != FALSE) {
                set.seed(seed)  
        }
                
        # Convert the tree to matrix format
        MatrixTheTree <- convert2matrix(TheTree)
        x <- MatrixTheTree$x                                                            # Structure matrix
        y <- MatrixTheTree$y                                                            # Node name matrix
        #~ typeMAT <- MatrixTheTree$typeMAT                                     # Node type matrix
        utilityMAT <- MatrixTheTree$utilityMAT                          # Node Cost matrix 
        effectivenessMAT <- MatrixTheTree$effectivenessMAT      # Node effectiveness matrix
        probMAT <- MatrixTheTree$probMAT                                        # Node probability matrix
        destinyMAT <- MatrixTheTree$destinyMAT                          # Terminal node destiny matrix
        
        num.col.x <- dim(x)[2]
        num.lin.x <- dim(x)[1]

        SummaryTreeTable <- subset(TheTree, Level == 2)
        col.pos <- as.numeric(SummaryTreeTable$Level)
        MARKOV.states <- as.numeric(SummaryTreeTable$Node.N) # MARKOV.states
        MARKOV.states.init.prob <- as.numeric(SummaryTreeTable$Prob) # MARKOV.states
        MARKOV.states.init.cost.rwd <- as.numeric(markov.propertiesMAT$Initial.cost) # MARKOV.states
        MARKOV.states.incr.cost.rwd <- as.numeric(markov.propertiesMAT$Incremental.cost) # MARKOV.states
        MARKOV.states.final.cost.rwd <- as.numeric(markov.propertiesMAT$Final.cost) # MARKOV.states
        MARKOV.states.init.effectiveness.rwd <- as.numeric(markov.propertiesMAT$Initial.effectiveness) # MARKOV.states
        MARKOV.states.incr.effectiveness.rwd <- as.numeric(markov.propertiesMAT$Incremental.effectiveness) # MARKOV.states
        MARKOV.states.final.effectiveness.rwd <- as.numeric(markov.propertiesMAT$Final.effectiveness) # MARKOV.states
        
        MARKOV.states.names <- SummaryTreeTable$Node.name
        
    # Aplica desconto nas payoffs de quem não volta para a árvore associada.
    MARKOV.discount.costs <- SummaryTreeTable$Payoff1
    MARKOV.discount.effectiveness <- SummaryTreeTable$Payoff2
        
        # listas para comportar matrizes associadas a cada Markov state
        MARKOV.states.arvores <- list()
        MARKOV.states.rotulos <- list()
        MARKOV.states.destino <- list()
        MARKOV.states.probs <- list()
        MARKOV.states.costs <- list()
        MARKOV.states.effectiveness <- list()
        
        # fragmenta a matriz da árvore em sub-árvores associadas a cada Markov state
        for (i in 1:length(MARKOV.states.names)) {
                MARKOV.state <- MARKOV.states[i]
                selected.lines <- which(x[,col.pos[i]] == MARKOV.state)
                
                sub.x <- x[selected.lines, col.pos[i]:num.col.x]
                sub.y <- y[selected.lines, col.pos[i]:num.col.x]
                sub.probMAT <- probMAT[selected.lines, col.pos[i]:num.col.x]
                sub.utilityMAT <- utilityMAT[selected.lines, col.pos[i]:num.col.x]
                sub.effectivenessMAT <- effectivenessMAT[selected.lines, col.pos[i]:num.col.x]
                #~ sub.typeMAT <- utilityMAT[selected.lines, col.pos[i]:num.col.x]
                sub.destiny <- destinyMAT[selected.lines]
                
                # se a fragmentação resulta em matriz linha, então é preciso definir que isso é
                # uma matriz... senão vira vetor e não funciona.
                if(length(selected.lines) == 1)  {
                        sub.x <- sub.x[!is.na(sub.x)]
                        n.mat <- length(sub.x) + 1
                        sub.x <- matrix(c(1, sub.x) , 1, n.mat)
                        sub.y <- matrix(sub.y[1], 1, n.mat)
                        sub.probMAT <- matrix(1.0, 1, n.mat)
                        sub.utilityMAT <- matrix(c(0,sub.utilityMAT), 1, n.mat)
                        sub.effectivenessMAT <- matrix(c(0,sub.effectivenessMAT), 1, n.mat)
                        #~ sub.typeMAT <- matrix(c("D",sub.typeMAT), 1, n.mat)
                } else {
                        sub.probMAT[,1] <- 1.0  # Agora o nodo raiz recebe prob = 1.
                }
                
                # ajusta custo e efetividade: serão acumulados através dos nodos.
                sub.utilityMAT <- apply(sub.utilityMAT, 1, sum)
                sub.effectivenessMAT <- apply(sub.effectivenessMAT, 1, sum)

                # abaixo se manda cada matriz de sub-árvore para suas listas.
                MARKOV.states.arvores[[i]] <- sub.x
                MARKOV.states.rotulos[[i]] <- sub.y
                MARKOV.states.destino[[i]] <- sub.destiny
                MARKOV.states.probs[[i]] <- sub.probMAT
                MARKOV.states.costs[[i]] <- sub.utilityMAT
                MARKOV.states.effectiveness[[i]] <- sub.effectivenessMAT
        }

        # ajusta nomes nas listas.
        names(MARKOV.states.arvores) <- c(as.array(as.character(MARKOV.states)))
        names(MARKOV.states.rotulos) <- names(MARKOV.states.arvores)
        names(MARKOV.states.destino) <- names(MARKOV.states.arvores)
        names(MARKOV.states.probs) <- names(MARKOV.states.arvores)
        names(MARKOV.states.costs) <- names(MARKOV.states.arvores)
        names(MARKOV.states.effectiveness) <- names(MARKOV.states.arvores)

        # ajuste para quem não retorna à árvore associada
    for (i in 1:length(MARKOV.states.names)) {
                MARKOV.states.costs[[as.character(MARKOV.states[i])]] <- MARKOV.states.costs[[as.character(MARKOV.states[i])]] -
                MARKOV.discount.costs[as.numeric(i)] + 
                MARKOV.discount.costs[as.numeric(MARKOV.states.destino[[as.character(MARKOV.states[i])]])]
                MARKOV.states.effectiveness[[as.character(MARKOV.states[i])]] <- MARKOV.states.effectiveness[[as.character(MARKOV.states[i])]] -
                MARKOV.discount.effectiveness[as.numeric(i)] + 
                MARKOV.discount.effectiveness[as.numeric(MARKOV.states.destino[[as.character(MARKOV.states[i])]])]
    }

        # Busca por estados absorventes
        if (absorventstatedeath == 1) {
                nodos.test.absorvent <- names(MARKOV.states.destino)
                absorventstate <- array(,0)
                
                for (i in nodos.test.absorvent) {
                        destinyofthisstate <- MARKOV.states.destino[[i]]        
                        checkdestiny <- ( destinyofthisstate == i )
                        if ( sum(checkdestiny) == length(destinyofthisstate) ) {
#                               cat("Ele é absorvente '", i, "' chamado '", MARKOV.states.rotulos[[i]][1,1],"'\n")
                                absorventstate <- c(absorventstate, i)
                        }
                }
        }
        
        # cria a tabela que comportará os individuos
        num.markov.states <- length(MARKOV.states)
        Coorte.Ind <- matrix(MARKOV.states[num.markov.states],1,initial.coort)  # Matriz com cada individuo
        Coorte.Cost <- matrix(0,1,initial.coort)        # Matriz com custo de cada individuo
        Coorte.Effec <- matrix(0,1,initial.coort)       # Matriz com a efetividade de cada individuo
        
        # sorteia a distribuição inicial
        init.distr.Prob <- cumsum(MARKOV.states.init.prob)
        sorteados <- runif(initial.coort,0,1)
        if (num.markov.states > 1) {
                for (i in (num.markov.states-1):1) {
                        positions <- which( sorteados <= init.distr.Prob[i] )
                        Coorte.Ind[1,positions] <- MARKOV.states[i]
                        Coorte.Cost[1,positions] <- MARKOV.states.init.cost.rwd[i]
                        Coorte.Effec[1,positions] <- MARKOV.states.init.effectiveness.rwd[i]
                }
        }
        
        # control variables
        .stop.sim <- TRUE
        .stage <- 1
        .stage.cost <- sum(Coorte.Cost)
        .stage.eff <- sum(Coorte.Effec)
        .stage.reward <- .stage.cost
        .total.cost <- .stage.cost
        .total.eff <- .stage.eff
        .total.reward <- .stage.cost    # ajusta a soma do ciclo zero para zero.

        while( ! eval( parse(text = markov.termination) ) ) {
                .stage <- .stage + 1
                Coorte.Ind.LINE <- matrix(MARKOV.states[num.markov.states],1,initial.coort)
                Coorte.Cost.LINE <- matrix(0,1,initial.coort)
                Coorte.Effec.LINE <- matrix(0,1,initial.coort)
                
                for (i in 1:num.markov.states ) {
                        positions <- which(Coorte.Ind[.stage - 1,] == MARKOV.states[i])
                        indvs <- length(positions)
                        if ( indvs != 0 ) {
                                arvore <- MARKOV.states.arvores[[as.character(MARKOV.states[i])]]
                                rotulos <- MARKOV.states.rotulos[[as.character(MARKOV.states[i])]]
                                destinos <- MARKOV.states.destino[[as.character(MARKOV.states[i])]]
                                probabilidades <- MARKOV.states.probs[[as.character(MARKOV.states[i])]]
                                custos <- MARKOV.states.costs[[as.character(MARKOV.states[i])]]
                                efetividades <- MARKOV.states.effectiveness[[as.character(MARKOV.states[i])]]
                                sorteado <- runif(indvs,0,1)
                                linprobs <- cumsum(apply(probabilidades, 1, prod)) # observa a probabilidade de cada ramo acontecer numa runif
                                valn <- length(linprobs)
                                linprobs.Matrix <- matrix(linprobs, indvs, valn, byrow = TRUE) # podemos ter problema de memória aqui!!!
                                resultado <- valn - apply(sorteado <= linprobs.Matrix, 1, sum) + 1
                                ans.dest <- destinos[resultado] # quantos vão para cada categoria
                                ans.cost <- custos[resultado]
                                ans.effectiveness <- efetividades[resultado]
                        }
                        Coorte.Ind.LINE[1,positions] <- ans.dest
                        Coorte.Cost.LINE[1,positions] <- ans.cost
                        Coorte.Effec.LINE[1,positions] <- ans.effectiveness
                }
                .stage.cost <- sum(Coorte.Cost.LINE)
                .stage.eff <- sum(Coorte.Effec.LINE)
                .stage.reward <- .stage.cost
                .total.cost <- .total.cost + .stage.cost
                .total.eff <- .total.eff + .stage.eff
                .total.reward <- .total.cost    # ajusta a soma do ciclo zero para zero.
                
                Coorte.Ind <- rbind(Coorte.Ind, Coorte.Ind.LINE)
                Coorte.Cost <- rbind(Coorte.Cost, Coorte.Cost.LINE)
                Coorte.Effec <- rbind(Coorte.Effec, Coorte.Effec.LINE)
        }
        
        # Definições para a soma de valores no final da simulação (the final reward)
        for (i in num.markov.states:1) {
                positions <- which( Coorte.Ind[.stage,] <= MARKOV.states[i] )
                Coorte.Cost[.stage,positions] <- MARKOV.states.final.cost.rwd[i] + Coorte.Cost[.stage,positions] 
                Coorte.Effec[.stage,positions] <- MARKOV.states.final.effectiveness.rwd[i] + Coorte.Effec[.stage,positions]
        }
                
        # Aplica NA para individuos dos estados absorventes considerados morte
        if (absorventstatedeath == 1) {
                SurvivalCurve <- replace(Coorte.Ind, which( Coorte.Ind == absorventstate), NA)
#               Coorte.Ind <- replace(Coorte.Ind, which( Coorte.Ind == absorventstate), NA)
#               Coorte.Cost <- replace(Coorte.Cost, which( SurvivalCurve == NA), NA)
                Coorte.Effec <- replace(Coorte.Effec, which( is.na(SurvivalCurve)), NA)
                SurvivalCurve <- apply(!is.na(SurvivalCurve), 1, sum)
                SurvivalCurve <- as.array(SurvivalCurve)
                names(SurvivalCurve) <- paste("Cycle ", 0:(length(SurvivalCurve)-1), sep = "")
        } else {
                SurvivalCurve <- rep( dim(Coorte.Ind)[2], dim(Coorte.Ind)[1])
                names(SurvivalCurve) <- paste("Cycle ", 0:(length(SurvivalCurve)-1), sep = "")
        }
        
        ans <- list(Path = Coorte.Ind, Cost = Coorte.Cost, Effectiveness = Coorte.Effec, Survival = SurvivalCurve)
        return(ans)     # And return the result
  }

[Package arvoRe version 0.1.7 Index]