Skip to content

Commit 17e3577

Browse files
feralaesferalaes
committed
Update STM01 to have mort rate instead of prob and added darthtools
1 parent 2ef17b6 commit 17e3577

File tree

2 files changed

+340
-526
lines changed

2 files changed

+340
-526
lines changed

‎R/Functions.R‎

Lines changed: 0 additions & 186 deletions
Original file line numberDiff line numberDiff line change
@@ -1,189 +1,3 @@
1-
#----------------------------------------------------------------------------#
2-
#### Function to convert probabilities to rates ####
3-
#----------------------------------------------------------------------------#
4-
#' Convert a probability to a rate
5-
#'
6-
#' \code{prob_to_rate} checks if a probability is between 0 and 1 and convert it to a rate.
7-
#'
8-
#' @param p probability
9-
#' @param t time/ frequency
10-
#' @return a number - converted rate
11-
#'
12-
prob_to_rate <- function(p, t = 1){
13-
if (sum(p > 1) >0 | sum(p < 0) > 0 ){
14-
print("probability not between 0 and 1")
15-
}
16-
r <- -log(1-p)/ t
17-
return(r)
18-
}
19-
20-
#----------------------------------------------------------------------------#
21-
#### Function to convert rates to probabilities ####
22-
#----------------------------------------------------------------------------#
23-
#' Convert a rate to a probability
24-
#'
25-
#' \code{rate_to_prob} convert a rate to a probability.
26-
#'
27-
#' @param r rate
28-
#' @param t time/ frequency
29-
#' @return a number - converted probability
30-
#'
31-
# Function to convert rates to probabilities
32-
rate_to_prob <- function(r, t = 1){
33-
p <- 1 - exp(- r * t)
34-
return(p)
35-
}
36-
37-
#---------------------------------------------------------------------------------------------#
38-
#### Function to convert convert probabilities to probabilities with a different frequency ####
39-
#---------------------------------------------------------------------------------------------#
40-
#' Convert a probability to a probability with a different frequency
41-
#'
42-
#' \code{rate_to_prob} convert a probability to a probability with a different frequency.
43-
#'
44-
#' @param p probability
45-
#' @param t time/ frequency
46-
#' @return a number - converted probability
47-
#'
48-
# Function to convert probabilities to probabilities with a different frequency
49-
ProbProb <- function(p, t = 1){
50-
p_new <- RateProb(ProbRate(p, t))
51-
return(p_new)
52-
}
53-
54-
#----------------------------------------------------------------------------#
55-
#### Function to check if transition probability array/matrix is valid ####
56-
#----------------------------------------------------------------------------#
57-
#' Check if transition array is valid
58-
#'
59-
#' \code{check_transition_probability} checks if transition probabilities are in \[0, 1\].
60-
#'
61-
#' @param a_P A transition probability array.
62-
#' @param err_stop Logical variable to stop model run if set up as TRUE. Default = FALSE.
63-
#' @param verbose Logical variable to indicate print out of messages.
64-
#' Default = FALSE
65-
#'
66-
#' @return
67-
#' This function stops if transition probability array is not valid and shows
68-
#' what are the entries that are not valid
69-
#' @import utils
70-
#' @export
71-
check_transition_probability <- function(a_P,
72-
err_stop = FALSE,
73-
verbose = FALSE) {
74-
75-
a_P <- as.array(a_P)
76-
77-
# Verify if a_P is 2D or 3D matrix
78-
n_dim <- length(dim(a_P))
79-
# If a_P is a 2D matrix, convert to a 3D array
80-
if (n_dim < 3){
81-
a_P <- array(a_P, dim = list(nrow(a_P), ncol(a_P), 1),
82-
dimnames = list(rownames(a_P), colnames(a_P), "Time independent"))
83-
}
84-
# Check which entries are not valid
85-
m_indices_notvalid <- arrayInd(which(a_P < 0 | a_P > 1),
86-
dim(a_P))
87-
88-
if(dim(m_indices_notvalid)[1] != 0){
89-
v_rows_notval <- rownames(a_P)[m_indices_notvalid[, 1]]
90-
v_cols_notval <- colnames(a_P)[m_indices_notvalid[, 2]]
91-
v_cycles_notval <- dimnames(a_P)[[3]][m_indices_notvalid[, 3]]
92-
93-
df_notvalid <- data.frame(`Transition probabilities not valid:` =
94-
matrix(paste0(paste(v_rows_notval, v_cols_notval, sep = "->"),
95-
"; at cycle ",
96-
v_cycles_notval), ncol = 1),
97-
check.names = FALSE)
98-
99-
if(err_stop) {
100-
stop("Not valid transition probabilities\n",
101-
paste(capture.output(df_notvalid), collapse = "\n"))
102-
}
103-
104-
if(verbose){
105-
warning("Not valid transition probabilities\n",
106-
paste(capture.output(df_notvalid), collapse = "\n"))
107-
}
108-
}
109-
}
110-
111-
#----------------------------------------------------------------------------#
112-
#### Function to check if sum of transition probabilities equal to one ####
113-
#----------------------------------------------------------------------------#
114-
#' Check if the sum of transition probabilities equal to one.
115-
#'
116-
#' \code{check_sum_of_transition_array} checks if each of the rows of the
117-
#' transition matrices sum to one.
118-
#'
119-
#' @param a_P A transition probability array.
120-
#' @param n_states Number of health states.
121-
#' @param n_t Number of cycles.
122-
#' @param err_stop Logical variable to stop model run if set up as TRUE.
123-
#' Default = TRUE.
124-
#' @param verbose Logical variable to indicate print out of messages.
125-
#' Default = TRUE
126-
#' @return
127-
#' The transition probability array and the cohort trace matrix.
128-
#' @import dplyr
129-
#' @export
130-
check_sum_of_transition_array <- function(a_P,
131-
n_states,
132-
n_t,
133-
err_stop = TRUE,
134-
verbose = TRUE) {
135-
136-
a_P <- as.array(a_P)
137-
d <- length(dim(a_P))
138-
# For matrix
139-
if (d == 2) {
140-
valid <- sum(rowSums(a_P))
141-
if (valid != n_states) {
142-
if(err_stop) {
143-
stop("This is not a valid transition Matrix")
144-
}
145-
146-
if(verbose){
147-
warning("This is not a valid transition Matrix")
148-
}
149-
}
150-
} else {
151-
# For array
152-
valid <- (apply(a_P, d, function(x) sum(rowSums(x))) == n_states)
153-
if (!isTRUE(all.equal(as.numeric(sum(valid)), as.numeric(n_t)))) {
154-
if(err_stop) {
155-
stop("This is not a valid transition Matrix")
156-
}
157-
158-
if(verbose){
159-
warning("This is not a valid transition Matrix")
160-
}
161-
}
162-
}
163-
}
164-
165-
#----------------------------------------------------------------------------#
166-
#### Function to get DARTH colors ####
167-
#----------------------------------------------------------------------------#
168-
#' Get DARTH colors
169-
#'
170-
#' \code{get_DARTH_cols} retrieves the color codes for DARTH colors.
171-
#'
172-
#' @return a string containing DARTH color codes
173-
#'
174-
get_DARTH_cols <- function() {
175-
# DARTH colors
176-
DARTHgreen <- '#009999'
177-
DARTHyellow <- '#FDAD1E'
178-
DARTHblue <- '#006699'
179-
DARTHlightgreen <- '#00adad'
180-
DARTHgray <- '#666666'
181-
DARTHcols <- c("H" = DARTHgreen, "S1" = DARTHblue,
182-
"S2" = DARTHyellow, "D" = DARTHgray)
183-
184-
return(DARTHcols)
185-
}
186-
1871
#----------------------------------------------------------------------------#
1882
#### Function to plot cohort trace ####
1893
#----------------------------------------------------------------------------#

0 commit comments

Comments
 (0)