Nothing
inst/shiny/server/srv-tab-simulate.R
In nph: Planning and Analysing Survival Studies under Non-Proportional Hazards
##########################
# Simulate tab server
# Create ---------------------------------------------------------------------
# Initial definitions --------------------------------------------------------
## Treatment group parameters --------------------------------------------------
# Number of subgroups ----------------------------------------------------------
observe({
isolate({
output$s_T_subgr_p <-renderTable({
if (input$s_T_subgr<1) return("Number of subgroups should be > 0")
if (input$s_T_subgr>=10) return("Number of subgroups should be < 10")
num.inputs.col1 <- paste0("<input id='s_T_p", 1:input$s_T_subgr,
"' class='shiny-bound-input' ",
"type='number' max = 1 min = 0 step = 0.1 value=",
1/input$s_T_subgr, " />")
out = as.data.frame(t(num.inputs.col1),
row.names = "Subgroup proportions")
names(out) = paste0("S", 1:input$s_T_subgr)
out
},
sanitize.text.function = function(x) x,
# rownames = TRUE,
width = '100%')
output$s_T_subgr_labels <-renderTable({
if (input$s_T_subgr<1) return("Number of subgroups should be > 0")
if (input$s_T_subgr>=10) return("Number of subgroups should be < 10")
num.inputs.col1 <- paste0("<div class='form-group shiny-input-container' style='width: 20%;'><input id='s_T_label",
1:input$s_T_subgr,
"' class='shiny-bound-input' ",
"type='text' value='Subgr",
1:input$s_T_subgr, "' /></div>")
out = as.data.frame(t(num.inputs.col1),
row.names = "Subgroup labels")
names(out) = paste0("S", 1:input$s_T_subgr)
out
},
sanitize.text.function = function(x) x,
# rownames = TRUE,
width = '100%')
})
})
s_T_p <- reactive({
unlist(lapply(1:input$s_T_subgr, function(i){
input[[paste0("s_T_p", i)]]
}))
})
s_T_labels <- reactive({
unlist(lapply(1:input$s_T_subgr, function(i){
input[[paste0("s_T_label", i)]]
}))
})
# output$s_T_p <- renderText(s_T_p())
# Number of time intervals -----------------------------------------------------
observe({
isolate({
output$s_T_time <-renderTable({
if (input$s_T_timepoints<1) return("Number of timepoints should be > 0")
if (input$s_T_timepoints>=10) return("Number of timepoints should be < 10")
num.inputs.col1 <-
c("<input id='s_T_time0' class='shiny-bound-input' type='number' max = 999999 min = 0 step = 0 value=0 disabled=true>",
paste0("<input id='s_T_time", 1:input$s_T_timepoints,
"' class='shiny-bound-input' ",
"type='number' max = 999999 min = 0 step = 1 value=",
(1:input$s_T_timepoints)*3000, ">"))
out = as.data.frame(t(num.inputs.col1),
row.names = "Subgroup proportions")
names(out) = paste0("T", 0:input$s_T_timepoints)
out
}, sanitize.text.function = function(x) x,
# rownames = TRUE,
width = '100%')
})
})
s_T_times <- reactive({
unlist(lapply(0:input$s_T_timepoints, function(i){
input[[paste0("s_T_time", i)]]
}))
})
# output$s_T_times <- renderText(s_T_times())
### lambdaMat1 -----------------------------------------------------------------
s_T_grid_Mat1 <- reactive({
grid_comb. = expand.grid(1:input$s_T_timepoints, 1:input$s_T_subgr)
paste0("T_Mat1_s", grid_comb.$Var1, "t", grid_comb.$Var2)
})
observe({
isolate({
output$s_T_lambdaMat1 <-renderTable({
if(is.null(s_T_grid_Mat1())) return(NULL)
num.inputs.col1 <-
paste0("<input id='s_", s_T_grid_Mat1(),
"' class='shiny-bound-input' ",
" type='number' max = 999 min = 0 step = 1 value=",
18, ">")
out = as.data.frame(matrix(num.inputs.col1, nrow = input$s_T_subgr))
t1=paste0("s_T_time", (1:input$s_T_timepoints)-1)
t2=paste0("s_T_time", (1:input$s_T_timepoints))
names(out) = unlist(lapply(1:input$s_T_timepoints, function(i)
paste0(input[[t1[i]]], "-", input[[t2[i]]])))
# names(out) = paste0("T", 1:input$s_T_timepoints)
rownames(out) = paste0("S", 1:input$s_T_subgr)
out
}, sanitize.text.function = function(x) x,
rownames = TRUE,
width = 'auto')
})
})
s_T_lambdaMat1 <- reactive({
mm = unlist(lapply(1:length(s_T_grid_Mat1()), function(i){
input[[paste0("s_", s_T_grid_Mat1()[i])]]
}))
if(is.null(mm)) return(NULL)
if(length(mm)%%input$s_T_subgr != 0) return(NULL) # Catch error when mm is not ready to be in the matrix
matrix(fu(mm), nrow = input$s_T_subgr)
})
output$s_T_lambdaMat1_print <- renderTable({
if(is.null(s_T_grid_Mat1())) return(NULL)
s_T_lambdaMat1()
}, digits = 6)
### lambdaMat2 -----------------------------------------------------------------
s_T_grid_Mat2 <- reactive({
grid_comb. = expand.grid(1:input$s_T_timepoints, 1:input$s_T_subgr)
paste0("T_Mat2_s", grid_comb.$Var1, "t", grid_comb.$Var2)
})
observe({
isolate({
output$s_T_lambdaMat2 <-renderTable({
if(is.null(s_T_grid_Mat2())) return(NULL)
num.inputs.col1 <-
paste0("<input id='s_", s_T_grid_Mat2(),
"' class='shiny-bound-input' ",
" type='number' max = 999 min = 0 step = 1 value=",
18, ">")
out = as.data.frame(matrix(num.inputs.col1, nrow = input$s_T_subgr))
t1=paste0("s_T_time", (1:input$s_T_timepoints)-1)
t2=paste0("s_T_time", (1:input$s_T_timepoints))
names(out) = unlist(lapply(1:input$s_T_timepoints, function(i)
paste0(input[[t1[i]]], "-", input[[t2[i]]])))
rownames(out) = paste0("S", 1:input$s_T_subgr)
out
}, sanitize.text.function = function(x) x,
rownames = TRUE,
width = 'auto')
})
})
s_T_lambdaMat2 <- reactive({
mm = unlist(lapply(1:length(s_T_grid_Mat2()), function(i){
input[[paste0("s_", s_T_grid_Mat2()[i])]]
}))
if(is.null(mm)) return(NULL)
if(length(mm)%%input$s_T_subgr != 0) return(NULL) # Catch error when mm is not ready to be in the matrix
matrix(fu(mm), nrow = input$s_T_subgr)
})
output$s_T_lambdaMat2_print <- renderTable({
if(is.null(s_T_grid_Mat2())) return(NULL)
s_T_lambdaMat2()
}, digits = 6)
### lambdaProgMat --------------------------------------------------------------
s_T_grid_Prog <- reactive({
grid_comb. = expand.grid(1:input$s_T_timepoints, 1:input$s_T_subgr)
paste0("T_Prog_s", grid_comb.$Var1, "t", grid_comb.$Var2)
})
observe({
isolate({
output$s_T_lambdaProgMat <-renderTable({
if(is.null(s_T_grid_Prog())) return(NULL)
num.inputs.col1 <-
paste0("<input id='s_", s_T_grid_Prog(),
"' class='shiny-bound-input' ",
" type='number' max = 999 min = 0 step = 1 value=",
18, ">")
out = as.data.frame(matrix(num.inputs.col1, nrow = input$s_T_subgr))
t1=paste0("s_T_time", (1:input$s_T_timepoints)-1)
t2=paste0("s_T_time", (1:input$s_T_timepoints))
names(out) = unlist(lapply(1:input$s_T_timepoints, function(i)
paste0(input[[t1[i]]], "-", input[[t2[i]]])))
rownames(out) = paste0("S", 1:input$s_T_subgr)
out
}, sanitize.text.function = function(x) x,
rownames = TRUE,
width = 'auto')
})
})
s_T_lambdaProgMat <- reactive({
mm = unlist(lapply(1:length(s_T_grid_Prog()), function(i){
input[[paste0("s_", s_T_grid_Prog()[i])]]
}))
if(is.null(mm)) return(NULL)
if(length(mm)%%input$s_T_subgr != 0) return(NULL) # Catch error when mm is not ready to be in the matrix
matrix(fu(mm), nrow = input$s_T_subgr)
})
output$s_T_lambdaProgMat_print <- renderTable({
if(is.null(s_T_grid_Prog())) return(NULL)
s_T_lambdaProgMat()
}, digits = 6)
## Control group parameters --------------------------------------------------
# Number of subgroups ----------------------------------------------------------
observe({
isolate({
output$s_C_subgr_p <-renderTable({
if (input$s_C_subgr<1) return("Number of subgroups should be > 0")
if (input$s_C_subgr>=10) return("Number of subgroups should be < 10")
num.inputs.col1 <- paste0("<input id='s_C_p", 1:input$s_C_subgr,
"' class='shiny-bound-input' ",
"type='number' max = 1 min = 0 step = 0.1 value=",
1/input$s_C_subgr, " />")
out = as.data.frame(t(num.inputs.col1),
row.names = "Subgroup proportions")
names(out) = paste0("S", 1:input$s_C_subgr)
out
},
sanitize.text.function = function(x) x,
# rownames = TRUE,
width = '100%')
output$s_C_subgr_labels <-renderTable({
if (input$s_C_subgr<1) return("Number of subgroups should be > 0")
if (input$s_C_subgr>=10) return("Number of subgroups should be < 10")
num.inputs.col1 <- paste0("<input id='s_C_label", 1:input$s_C_subgr,
"' class='shiny-bound-input' ",
"type='text' value='Subgr",
1:input$s_C_subgr, "' />")
out = as.data.frame(t(num.inputs.col1),
row.names = "Subgroup labels")
names(out) = paste0("S", 1:input$s_C_subgr)
out
},
sanitize.text.function = function(x) x,
width = '100%')
})
})
s_C_p <- reactive({
unlist(lapply(1:input$s_C_subgr, function(i){
input[[paste0("s_C_p", i)]]
}))
})
s_C_labels <- reactive({
unlist(lapply(1:input$s_T_subgr, function(i){
input[[paste0("s_C_label", i)]]
}))
})
### lambdaMat1 -----------------------------------------------------------------
s_C_grid_Mat1 <- reactive({
grid_comb. = expand.grid(1:input$s_T_timepoints, 1:input$s_C_subgr)
paste0("C_Mat1_s", grid_comb.$Var1, "t", grid_comb.$Var2)
})
observe({
isolate({
output$s_C_lambdaMat1 <-renderTable({
if(is.null(s_C_grid_Mat1())) return(NULL)
num.inputs.col1 <-
paste0("<input id='s_", s_C_grid_Mat1(),
"' class='shiny-bound-input' ",
" type='number' max = 999 min = 0 step = 1 value=",
18, ">")
out = as.data.frame(matrix(num.inputs.col1, nrow = input$s_C_subgr))
t1=paste0("s_T_time", (1:input$s_T_timepoints)-1)
t2=paste0("s_T_time", (1:input$s_T_timepoints))
names(out) = unlist(lapply(1:input$s_T_timepoints, function(i)
paste0(input[[t1[i]]], "-", input[[t2[i]]])))
# names(out) = paste0("T", 1:input$s_T_timepoints)
rownames(out) = paste0("S", 1:input$s_C_subgr)
out
}, sanitize.text.function = function(x) x,
rownames = TRUE,
width = 'auto')
})
})
s_C_lambdaMat1 <- reactive({
input$s_C_lM1_s1t1
mm = unlist(lapply(1:length(s_C_grid_Mat1()), function(i){
input[[paste0("s_", s_C_grid_Mat1()[i])]]
}))
if(is.null(mm)) return(NULL)
if(length(mm)%%input$s_C_subgr != 0) return(NULL) # Catch error when mm is not ready to be in the matrix
matrix(fu(mm), nrow = input$s_C_subgr)
})
output$s_C_lambdaMat1_print <- renderTable({
if(is.null(s_C_grid_comb())) return(NULL)
s_C_lambdaMat1()
})
### lambdaMat2 -----------------------------------------------------------------
s_C_grid_Mat2 <- reactive({
grid_comb. = expand.grid(1:input$s_T_timepoints, 1:input$s_C_subgr)
paste0("C_Mat2_s", grid_comb.$Var1, "t", grid_comb.$Var2)
})
observe({
isolate({
output$s_C_lambdaMat2 <-renderTable({
if(is.null(s_C_grid_Mat2())) return(NULL)
num.inputs.col1 <-
paste0("<input id='s_", s_C_grid_Mat2(),
"' class='shiny-bound-input' ",
" type='number' max = 999 min = 0 step = 1 value=",
18, ">")
out = as.data.frame(matrix(num.inputs.col1, nrow = input$s_C_subgr))
t1=paste0("s_T_time", (1:input$s_T_timepoints)-1)
t2=paste0("s_T_time", (1:input$s_T_timepoints))
names(out) = unlist(lapply(1:input$s_T_timepoints, function(i)
paste0(input[[t1[i]]], "-", input[[t2[i]]])))
# names(out) = paste0("T", 1:input$s_T_timepoints)
rownames(out) = paste0("S", 1:input$s_C_subgr)
out
}, sanitize.text.function = function(x) x,
rownames = TRUE,
width = 'auto')
})
})
s_C_lambdaMat2 <- reactive({
mm = unlist(lapply(1:length(s_C_grid_Mat2()), function(i){
input[[paste0("s_", s_C_grid_Mat2()[i])]]
}))
if(is.null(mm)) return(NULL)
if(length(mm)%%input$s_C_subgr != 0) return(NULL) # Catch error when mm is not ready to be in the matrix
matrix(fu(mm), nrow = input$s_C_subgr)
})
output$s_C_lambdaMat2_print <- renderTable({
if(is.null(s_C_grid_Mat2())) return(NULL)
s_C_lambdaMat2()
})
### lambdaProgMat --------------------------------------------------------------
s_C_grid_Prog <- reactive({
grid_comb. = expand.grid(1:input$s_T_timepoints, 1:input$s_C_subgr)
paste0("C_Prog_s", grid_comb.$Var1, "t", grid_comb.$Var2)
})
observe({
isolate({
output$s_C_lambdaProgMat <-renderTable({
if(is.null(s_C_grid_Prog())) return(NULL)
num.inputs.col1 <-
paste0("<input id='s_", s_C_grid_Prog(),
"' class='shiny-bound-input' ",
" type='number' max = 999 min = 0 step = 1 value=",
18, ">")
out = as.data.frame(matrix(num.inputs.col1, nrow = input$s_C_subgr))
t1=paste0("s_T_time", (1:input$s_T_timepoints)-1)
t2=paste0("s_T_time", (1:input$s_T_timepoints))
names(out) = unlist(lapply(1:input$s_T_timepoints, function(i)
paste0(input[[t1[i]]], "-", input[[t2[i]]])))
# names(out) = paste0("T", 1:input$s_T_timepoints)
rownames(out) = paste0("S", 1:input$s_C_subgr)
out
}, sanitize.text.function = function(x) x,
rownames = TRUE,
width = 'auto')
})
})
s_C_lambdaProgMat <- reactive({
mm = unlist(lapply(1:length(s_C_grid_Prog()), function(i){
input[[paste0("s_", s_C_grid_Prog()[i])]]
}))
if(is.null(mm)) return(NULL)
if(length(mm)%%input$s_C_subgr != 0) return(NULL) # Catch error when mm is not ready to be in the matrix
matrix(fu(mm), nrow = input$s_C_subgr)
})
output$s_C_lambdaProgMat_print <- renderTable({
if(is.null(s_C_grid_Prog())) return(NULL)
s_C_lambdaProgMat()
}, digits = 8)
### Analysis -------------------------------------------------------------------
#Calculation of the hazard and survival functions.
#The hazard rates per day before and after PD and the hazard for PD are defined in lambdaMat1, lambdaMat2 and lambdaProgMat
#The matrices contain one row per subgroup and one column per time interval
B5 <- reactive({
pop_hazVFfun(
Tint = s_T_times(),
lambdaMat1 = s_T_lambdaMat1(),
lambdaMat2 = s_T_lambdaMat2(),
lambdaProgMat = s_T_lambdaProgMat(),
p = s_T_p(),
timezero = FALSE
)
})
K5 <- reactive({
pop_hazVFfun(
Tint = s_T_times(),
lambdaMat1 = s_C_lambdaMat1(),
lambdaMat2 = s_C_lambdaMat2(),
lambdaProgMat = s_C_lambdaProgMat(),
p = s_C_p(),
timezero = TRUE
) #Setting timezero=TRUE here means we have the same delayed onset for switchers after progression as we have initially for patients in the treatment group.
})
# Create Plot ------------------------------------------------------------------
react_panplot = eventReactive(input$s_calculate,{
print(plot_shhr(A = K5(), B = B5()))
})
output$panplot = renderPlot(react_panplot())
output$ctrl_plot = renderPlot({
plot_diagram(A = K5(),
B = K5(),
s_C_labels(),
s_C_labels(),
which = "Control")
})
output$trt_plot = renderPlot({
plot_diagram(A = B5(),
B = B5(),
s_T_labels(),
s_T_labels(),
which = "Experimental")
})
# Calculate medians ------------------------------------------------------------
k_median = reactive({
K = K5()
pos_below = suppressWarnings(min(K$t[(K$S <= 0.5)]) + 1)
pos_avobe = max(K$t[(K$S >= 0.5)]) + 1
dd = K$S[pos_avobe] - K$S[pos_below]
((pos_avobe-1)*abs(K$S[pos_below] - 0.5) + (pos_below-1)*abs(K$S[pos_avobe] - 0.5))/dd
})
b_median = reactive({
K = B5()
pos_below = suppressWarnings(min(K$t[(K$S <= 0.5)]) + 1)
pos_avobe = max(K$t[(K$S >= 0.5)]) + 1
dd = K$S[pos_avobe] - K$S[pos_below]
((pos_avobe-1)*abs(K$S[pos_below] - 0.5) + (pos_below-1)*abs(K$S[pos_avobe] - 0.5))/dd
})
median_table = eventReactive(input$s_calculate,
data.frame(group = c("Experimental", "Control"),
median = c(b_median(), k_median()))
)
output$median_table = renderTable({
median_table()
},
caption = "<h4 style='text-align:center;color:black;'><b>Median survival times by treatment group</b></h4>",
caption.placement = getOption("xtable.caption.placement", "top"),
caption.width = getOption("xtable.caption.width", NULL))
# Download code ----------------------------------------------------------------
output$s_downloadCode <- downloadHandler(
filename = paste('nph-simulate-rcode.r'),
content = function(file) {
input1 = list()
input1$times = 1
input1$lambda = 2
a = sprintf(
"################################################################################
## nph package - Reproducible R code from shiny app.
library('nph')
times = %s # Define timebreaks for intervals
# Create piecewise constant hazard objects for Treatment and Control arms
# The lambda matrices are given in terms of the median survival times,
# Therefore we use the nph::m2r function to translate from median to rate
TRT <- pop_pchaz(
Tint = times,
lambdaMat1 = %s,
lambdaMat2 = %s,
lambdaProgMat = %s,
p = %s,
timezero = FALSE,
discrete_approximation = TRUE
)
CRL <- pop_pchaz(
Tint = times,
lambdaMat1 = %s,
lambdaMat2 = %s,
lambdaProgMat = %s,
p = %s,
timezero = TRUE,
discrete_approximation = TRUE
)
print(TRT)
print(CRL)
# Creat state diagrams
TRT_subgr_labels = %s
CRL_subgr_labels = %s
plot_diagram(A = TRT,
B = CRL,
A_subgr_labels = TRT_subgr_labels,
B_subgr_labels = CRL_subgr_labels,
which = 'Control')
plot_diagram(A = TRT,
B = CRL,
A_subgr_labels = TRT_subgr_labels,
B_subgr_labels = CRL_subgr_labels,
which = 'Experimental')
# Create Survival, Hazard and hazard ratio plots
plot_shhr(A = TRT, B = CRL)
",
sprintf("c(%s)", paste0(s_T_times(), collapse = ", ")), # The time intervals
sprintf("m2r(matrix(c(%s), nrow = %s, ncol = %s))", paste0(m2r(s_T_lambdaMat1()), collapse = ", "), input$s_T_subgr, input$s_T_timepoints),
sprintf("m2r(matrix(c(%s), nrow = %s, ncol = %s))", paste0(m2r(s_T_lambdaMat2()), collapse = ", "), input$s_T_subgr, input$s_T_timepoints),
sprintf("m2r(matrix(c(%s), nrow = %s, ncol = %s))", paste0(m2r(s_T_lambdaProgMat()), collapse = ", "), input$s_T_subgr, input$s_T_timepoints),
sprintf("c(%s)", paste0(s_T_p(), collapse = ", ")), # The proportions in the subgroups for treatment arm
sprintf("m2r(matrix(c(%s), nrow = %s, ncol = %s))", paste0(m2r(s_T_lambdaMat1()), collapse = ", "), input$s_T_subgr, input$s_T_timepoints),
sprintf("m2r(matrix(c(%s), nrow = %s, ncol = %s))", paste0(m2r(s_T_lambdaMat2()), collapse = ", "), input$s_T_subgr, input$s_T_timepoints),
sprintf("m2r(matrix(c(%s), nrow = %s, ncol = %s))", paste0(m2r(s_T_lambdaProgMat()), collapse = ", "), input$s_T_subgr, input$s_T_timepoints),
sprintf("c(%s)", paste0(s_C_p(), collapse = ", ")), # The proportions in the subgroups for control arm
sprintf("c(%s)", paste0(paste0("'", s_T_labels(), "'"), collapse = ", ")), # The proportions in the subgroups for control arm
sprintf("c(%s)", paste0(paste0("'", s_C_labels(), "'"), collapse = ", ")) # The proportions in the subgroups for control arm
)
owd <- setwd(tempdir())
on.exit(setwd(owd))
capture.output(cat(a), file = paste0("test.R"))
# tidy_file(file = "test.R", width.cutoff = 80) # this is to format nicely the R code https://yihui.name/formatr/
styler::style_file(path = "test.R", scope = "indention") # this is to format nicely the R code
out <- paste0("test.R")
file.rename(out, file)
}
)
Try the nph package in your browser
Any scripts or data that you put into this service are public.
nph documentation built on May 17, 2022, 1:06 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
##########################
# Simulate tab server
# Create ---------------------------------------------------------------------
# Initial definitions --------------------------------------------------------
## Treatment group parameters --------------------------------------------------
# Number of subgroups ----------------------------------------------------------
observe({
isolate({
output$s_T_subgr_p <-renderTable({
if (input$s_T_subgr<1) return("Number of subgroups should be > 0")
if (input$s_T_subgr>=10) return("Number of subgroups should be < 10")
num.inputs.col1 <- paste0("<input id='s_T_p", 1:input$s_T_subgr,
"' class='shiny-bound-input' ",
"type='number' max = 1 min = 0 step = 0.1 value=",
1/input$s_T_subgr, " />")
out = as.data.frame(t(num.inputs.col1),
row.names = "Subgroup proportions")
names(out) = paste0("S", 1:input$s_T_subgr)
out
},
sanitize.text.function = function(x) x,
# rownames = TRUE,
width = '100%')
output$s_T_subgr_labels <-renderTable({
if (input$s_T_subgr<1) return("Number of subgroups should be > 0")
if (input$s_T_subgr>=10) return("Number of subgroups should be < 10")
num.inputs.col1 <- paste0("<div class='form-group shiny-input-container' style='width: 20%;'><input id='s_T_label",
1:input$s_T_subgr,
"' class='shiny-bound-input' ",
"type='text' value='Subgr",
1:input$s_T_subgr, "' /></div>")
out = as.data.frame(t(num.inputs.col1),
row.names = "Subgroup labels")
names(out) = paste0("S", 1:input$s_T_subgr)
out
},
sanitize.text.function = function(x) x,
# rownames = TRUE,
width = '100%')
})
})
s_T_p <- reactive({
unlist(lapply(1:input$s_T_subgr, function(i){
input[[paste0("s_T_p", i)]]
}))
})
s_T_labels <- reactive({
unlist(lapply(1:input$s_T_subgr, function(i){
input[[paste0("s_T_label", i)]]
}))
})
# output$s_T_p <- renderText(s_T_p())
# Number of time intervals -----------------------------------------------------
observe({
isolate({
output$s_T_time <-renderTable({
if (input$s_T_timepoints<1) return("Number of timepoints should be > 0")
if (input$s_T_timepoints>=10) return("Number of timepoints should be < 10")
num.inputs.col1 <-
c("<input id='s_T_time0' class='shiny-bound-input' type='number' max = 999999 min = 0 step = 0 value=0 disabled=true>",
paste0("<input id='s_T_time", 1:input$s_T_timepoints,
"' class='shiny-bound-input' ",
"type='number' max = 999999 min = 0 step = 1 value=",
(1:input$s_T_timepoints)*3000, ">"))
out = as.data.frame(t(num.inputs.col1),
row.names = "Subgroup proportions")
names(out) = paste0("T", 0:input$s_T_timepoints)
out
}, sanitize.text.function = function(x) x,
# rownames = TRUE,
width = '100%')
})
})
s_T_times <- reactive({
unlist(lapply(0:input$s_T_timepoints, function(i){
input[[paste0("s_T_time", i)]]
}))
})
# output$s_T_times <- renderText(s_T_times())
### lambdaMat1 -----------------------------------------------------------------
s_T_grid_Mat1 <- reactive({
grid_comb. = expand.grid(1:input$s_T_timepoints, 1:input$s_T_subgr)
paste0("T_Mat1_s", grid_comb.$Var1, "t", grid_comb.$Var2)
})
observe({
isolate({
output$s_T_lambdaMat1 <-renderTable({
if(is.null(s_T_grid_Mat1())) return(NULL)
num.inputs.col1 <-
paste0("<input id='s_", s_T_grid_Mat1(),
"' class='shiny-bound-input' ",
" type='number' max = 999 min = 0 step = 1 value=",
18, ">")
out = as.data.frame(matrix(num.inputs.col1, nrow = input$s_T_subgr))
t1=paste0("s_T_time", (1:input$s_T_timepoints)-1)
t2=paste0("s_T_time", (1:input$s_T_timepoints))
names(out) = unlist(lapply(1:input$s_T_timepoints, function(i)
paste0(input[[t1[i]]], "-", input[[t2[i]]])))
# names(out) = paste0("T", 1:input$s_T_timepoints)
rownames(out) = paste0("S", 1:input$s_T_subgr)
out
}, sanitize.text.function = function(x) x,
rownames = TRUE,
width = 'auto')
})
})
s_T_lambdaMat1 <- reactive({
mm = unlist(lapply(1:length(s_T_grid_Mat1()), function(i){
input[[paste0("s_", s_T_grid_Mat1()[i])]]
}))
if(is.null(mm)) return(NULL)
if(length(mm)%%input$s_T_subgr != 0) return(NULL) # Catch error when mm is not ready to be in the matrix
matrix(fu(mm), nrow = input$s_T_subgr)
})
output$s_T_lambdaMat1_print <- renderTable({
if(is.null(s_T_grid_Mat1())) return(NULL)
s_T_lambdaMat1()
}, digits = 6)
### lambdaMat2 -----------------------------------------------------------------
s_T_grid_Mat2 <- reactive({
grid_comb. = expand.grid(1:input$s_T_timepoints, 1:input$s_T_subgr)
paste0("T_Mat2_s", grid_comb.$Var1, "t", grid_comb.$Var2)
})
observe({
isolate({
output$s_T_lambdaMat2 <-renderTable({
if(is.null(s_T_grid_Mat2())) return(NULL)
num.inputs.col1 <-
paste0("<input id='s_", s_T_grid_Mat2(),
"' class='shiny-bound-input' ",
" type='number' max = 999 min = 0 step = 1 value=",
18, ">")
out = as.data.frame(matrix(num.inputs.col1, nrow = input$s_T_subgr))
t1=paste0("s_T_time", (1:input$s_T_timepoints)-1)
t2=paste0("s_T_time", (1:input$s_T_timepoints))
names(out) = unlist(lapply(1:input$s_T_timepoints, function(i)
paste0(input[[t1[i]]], "-", input[[t2[i]]])))
rownames(out) = paste0("S", 1:input$s_T_subgr)
out
}, sanitize.text.function = function(x) x,
rownames = TRUE,
width = 'auto')
})
})
s_T_lambdaMat2 <- reactive({
mm = unlist(lapply(1:length(s_T_grid_Mat2()), function(i){
input[[paste0("s_", s_T_grid_Mat2()[i])]]
}))
if(is.null(mm)) return(NULL)
if(length(mm)%%input$s_T_subgr != 0) return(NULL) # Catch error when mm is not ready to be in the matrix
matrix(fu(mm), nrow = input$s_T_subgr)
})
output$s_T_lambdaMat2_print <- renderTable({
if(is.null(s_T_grid_Mat2())) return(NULL)
s_T_lambdaMat2()
}, digits = 6)
### lambdaProgMat --------------------------------------------------------------
s_T_grid_Prog <- reactive({
grid_comb. = expand.grid(1:input$s_T_timepoints, 1:input$s_T_subgr)
paste0("T_Prog_s", grid_comb.$Var1, "t", grid_comb.$Var2)
})
observe({
isolate({
output$s_T_lambdaProgMat <-renderTable({
if(is.null(s_T_grid_Prog())) return(NULL)
num.inputs.col1 <-
paste0("<input id='s_", s_T_grid_Prog(),
"' class='shiny-bound-input' ",
" type='number' max = 999 min = 0 step = 1 value=",
18, ">")
out = as.data.frame(matrix(num.inputs.col1, nrow = input$s_T_subgr))
t1=paste0("s_T_time", (1:input$s_T_timepoints)-1)
t2=paste0("s_T_time", (1:input$s_T_timepoints))
names(out) = unlist(lapply(1:input$s_T_timepoints, function(i)
paste0(input[[t1[i]]], "-", input[[t2[i]]])))
rownames(out) = paste0("S", 1:input$s_T_subgr)
out
}, sanitize.text.function = function(x) x,
rownames = TRUE,
width = 'auto')
})
})
s_T_lambdaProgMat <- reactive({
mm = unlist(lapply(1:length(s_T_grid_Prog()), function(i){
input[[paste0("s_", s_T_grid_Prog()[i])]]
}))
if(is.null(mm)) return(NULL)
if(length(mm)%%input$s_T_subgr != 0) return(NULL) # Catch error when mm is not ready to be in the matrix
matrix(fu(mm), nrow = input$s_T_subgr)
})
output$s_T_lambdaProgMat_print <- renderTable({
if(is.null(s_T_grid_Prog())) return(NULL)
s_T_lambdaProgMat()
}, digits = 6)
## Control group parameters --------------------------------------------------
# Number of subgroups ----------------------------------------------------------
observe({
isolate({
output$s_C_subgr_p <-renderTable({
if (input$s_C_subgr<1) return("Number of subgroups should be > 0")
if (input$s_C_subgr>=10) return("Number of subgroups should be < 10")
num.inputs.col1 <- paste0("<input id='s_C_p", 1:input$s_C_subgr,
"' class='shiny-bound-input' ",
"type='number' max = 1 min = 0 step = 0.1 value=",
1/input$s_C_subgr, " />")
out = as.data.frame(t(num.inputs.col1),
row.names = "Subgroup proportions")
names(out) = paste0("S", 1:input$s_C_subgr)
out
},
sanitize.text.function = function(x) x,
# rownames = TRUE,
width = '100%')
output$s_C_subgr_labels <-renderTable({
if (input$s_C_subgr<1) return("Number of subgroups should be > 0")
if (input$s_C_subgr>=10) return("Number of subgroups should be < 10")
num.inputs.col1 <- paste0("<input id='s_C_label", 1:input$s_C_subgr,
"' class='shiny-bound-input' ",
"type='text' value='Subgr",
1:input$s_C_subgr, "' />")
out = as.data.frame(t(num.inputs.col1),
row.names = "Subgroup labels")
names(out) = paste0("S", 1:input$s_C_subgr)
out
},
sanitize.text.function = function(x) x,
width = '100%')
})
})
s_C_p <- reactive({
unlist(lapply(1:input$s_C_subgr, function(i){
input[[paste0("s_C_p", i)]]
}))
})
s_C_labels <- reactive({
unlist(lapply(1:input$s_T_subgr, function(i){
input[[paste0("s_C_label", i)]]
}))
})
### lambdaMat1 -----------------------------------------------------------------
s_C_grid_Mat1 <- reactive({
grid_comb. = expand.grid(1:input$s_T_timepoints, 1:input$s_C_subgr)
paste0("C_Mat1_s", grid_comb.$Var1, "t", grid_comb.$Var2)
})
observe({
isolate({
output$s_C_lambdaMat1 <-renderTable({
if(is.null(s_C_grid_Mat1())) return(NULL)
num.inputs.col1 <-
paste0("<input id='s_", s_C_grid_Mat1(),
"' class='shiny-bound-input' ",
" type='number' max = 999 min = 0 step = 1 value=",
18, ">")
out = as.data.frame(matrix(num.inputs.col1, nrow = input$s_C_subgr))
t1=paste0("s_T_time", (1:input$s_T_timepoints)-1)
t2=paste0("s_T_time", (1:input$s_T_timepoints))
names(out) = unlist(lapply(1:input$s_T_timepoints, function(i)
paste0(input[[t1[i]]], "-", input[[t2[i]]])))
# names(out) = paste0("T", 1:input$s_T_timepoints)
rownames(out) = paste0("S", 1:input$s_C_subgr)
out
}, sanitize.text.function = function(x) x,
rownames = TRUE,
width = 'auto')
})
})
s_C_lambdaMat1 <- reactive({
input$s_C_lM1_s1t1
mm = unlist(lapply(1:length(s_C_grid_Mat1()), function(i){
input[[paste0("s_", s_C_grid_Mat1()[i])]]
}))
if(is.null(mm)) return(NULL)
if(length(mm)%%input$s_C_subgr != 0) return(NULL) # Catch error when mm is not ready to be in the matrix
matrix(fu(mm), nrow = input$s_C_subgr)
})
output$s_C_lambdaMat1_print <- renderTable({
if(is.null(s_C_grid_comb())) return(NULL)
s_C_lambdaMat1()
})
### lambdaMat2 -----------------------------------------------------------------
s_C_grid_Mat2 <- reactive({
grid_comb. = expand.grid(1:input$s_T_timepoints, 1:input$s_C_subgr)
paste0("C_Mat2_s", grid_comb.$Var1, "t", grid_comb.$Var2)
})
observe({
isolate({
output$s_C_lambdaMat2 <-renderTable({
if(is.null(s_C_grid_Mat2())) return(NULL)
num.inputs.col1 <-
paste0("<input id='s_", s_C_grid_Mat2(),
"' class='shiny-bound-input' ",
" type='number' max = 999 min = 0 step = 1 value=",
18, ">")
out = as.data.frame(matrix(num.inputs.col1, nrow = input$s_C_subgr))
t1=paste0("s_T_time", (1:input$s_T_timepoints)-1)
t2=paste0("s_T_time", (1:input$s_T_timepoints))
names(out) = unlist(lapply(1:input$s_T_timepoints, function(i)
paste0(input[[t1[i]]], "-", input[[t2[i]]])))
# names(out) = paste0("T", 1:input$s_T_timepoints)
rownames(out) = paste0("S", 1:input$s_C_subgr)
out
}, sanitize.text.function = function(x) x,
rownames = TRUE,
width = 'auto')
})
})
s_C_lambdaMat2 <- reactive({
mm = unlist(lapply(1:length(s_C_grid_Mat2()), function(i){
input[[paste0("s_", s_C_grid_Mat2()[i])]]
}))
if(is.null(mm)) return(NULL)
if(length(mm)%%input$s_C_subgr != 0) return(NULL) # Catch error when mm is not ready to be in the matrix
matrix(fu(mm), nrow = input$s_C_subgr)
})
output$s_C_lambdaMat2_print <- renderTable({
if(is.null(s_C_grid_Mat2())) return(NULL)
s_C_lambdaMat2()
})
### lambdaProgMat --------------------------------------------------------------
s_C_grid_Prog <- reactive({
grid_comb. = expand.grid(1:input$s_T_timepoints, 1:input$s_C_subgr)
paste0("C_Prog_s", grid_comb.$Var1, "t", grid_comb.$Var2)
})
observe({
isolate({
output$s_C_lambdaProgMat <-renderTable({
if(is.null(s_C_grid_Prog())) return(NULL)
num.inputs.col1 <-
paste0("<input id='s_", s_C_grid_Prog(),
"' class='shiny-bound-input' ",
" type='number' max = 999 min = 0 step = 1 value=",
18, ">")
out = as.data.frame(matrix(num.inputs.col1, nrow = input$s_C_subgr))
t1=paste0("s_T_time", (1:input$s_T_timepoints)-1)
t2=paste0("s_T_time", (1:input$s_T_timepoints))
names(out) = unlist(lapply(1:input$s_T_timepoints, function(i)
paste0(input[[t1[i]]], "-", input[[t2[i]]])))
# names(out) = paste0("T", 1:input$s_T_timepoints)
rownames(out) = paste0("S", 1:input$s_C_subgr)
out
}, sanitize.text.function = function(x) x,
rownames = TRUE,
width = 'auto')
})
})
s_C_lambdaProgMat <- reactive({
mm = unlist(lapply(1:length(s_C_grid_Prog()), function(i){
input[[paste0("s_", s_C_grid_Prog()[i])]]
}))
if(is.null(mm)) return(NULL)
if(length(mm)%%input$s_C_subgr != 0) return(NULL) # Catch error when mm is not ready to be in the matrix
matrix(fu(mm), nrow = input$s_C_subgr)
})
output$s_C_lambdaProgMat_print <- renderTable({
if(is.null(s_C_grid_Prog())) return(NULL)
s_C_lambdaProgMat()
}, digits = 8)
### Analysis -------------------------------------------------------------------
#Calculation of the hazard and survival functions.
#The hazard rates per day before and after PD and the hazard for PD are defined in lambdaMat1, lambdaMat2 and lambdaProgMat
#The matrices contain one row per subgroup and one column per time interval
B5 <- reactive({
pop_hazVFfun(
Tint = s_T_times(),
lambdaMat1 = s_T_lambdaMat1(),
lambdaMat2 = s_T_lambdaMat2(),
lambdaProgMat = s_T_lambdaProgMat(),
p = s_T_p(),
timezero = FALSE
)
})
K5 <- reactive({
pop_hazVFfun(
Tint = s_T_times(),
lambdaMat1 = s_C_lambdaMat1(),
lambdaMat2 = s_C_lambdaMat2(),
lambdaProgMat = s_C_lambdaProgMat(),
p = s_C_p(),
timezero = TRUE
) #Setting timezero=TRUE here means we have the same delayed onset for switchers after progression as we have initially for patients in the treatment group.
})
# Create Plot ------------------------------------------------------------------
react_panplot = eventReactive(input$s_calculate,{
print(plot_shhr(A = K5(), B = B5()))
})
output$panplot = renderPlot(react_panplot())
output$ctrl_plot = renderPlot({
plot_diagram(A = K5(),
B = K5(),
s_C_labels(),
s_C_labels(),
which = "Control")
})
output$trt_plot = renderPlot({
plot_diagram(A = B5(),
B = B5(),
s_T_labels(),
s_T_labels(),
which = "Experimental")
})
# Calculate medians ------------------------------------------------------------
k_median = reactive({
K = K5()
pos_below = suppressWarnings(min(K$t[(K$S <= 0.5)]) + 1)
pos_avobe = max(K$t[(K$S >= 0.5)]) + 1
dd = K$S[pos_avobe] - K$S[pos_below]
((pos_avobe-1)*abs(K$S[pos_below] - 0.5) + (pos_below-1)*abs(K$S[pos_avobe] - 0.5))/dd
})
b_median = reactive({
K = B5()
pos_below = suppressWarnings(min(K$t[(K$S <= 0.5)]) + 1)
pos_avobe = max(K$t[(K$S >= 0.5)]) + 1
dd = K$S[pos_avobe] - K$S[pos_below]
((pos_avobe-1)*abs(K$S[pos_below] - 0.5) + (pos_below-1)*abs(K$S[pos_avobe] - 0.5))/dd
})
median_table = eventReactive(input$s_calculate,
data.frame(group = c("Experimental", "Control"),
median = c(b_median(), k_median()))
)
output$median_table = renderTable({
median_table()
},
caption = "<h4 style='text-align:center;color:black;'><b>Median survival times by treatment group</b></h4>",
caption.placement = getOption("xtable.caption.placement", "top"),
caption.width = getOption("xtable.caption.width", NULL))
# Download code ----------------------------------------------------------------
output$s_downloadCode <- downloadHandler(
filename = paste('nph-simulate-rcode.r'),
content = function(file) {
input1 = list()
input1$times = 1
input1$lambda = 2
a = sprintf(
"################################################################################
## nph package - Reproducible R code from shiny app.
library('nph')
times = %s # Define timebreaks for intervals
# Create piecewise constant hazard objects for Treatment and Control arms
# The lambda matrices are given in terms of the median survival times,
# Therefore we use the nph::m2r function to translate from median to rate
TRT <- pop_pchaz(
Tint = times,
lambdaMat1 = %s,
lambdaMat2 = %s,
lambdaProgMat = %s,
p = %s,
timezero = FALSE,
discrete_approximation = TRUE
)
CRL <- pop_pchaz(
Tint = times,
lambdaMat1 = %s,
lambdaMat2 = %s,
lambdaProgMat = %s,
p = %s,
timezero = TRUE,
discrete_approximation = TRUE
)
print(TRT)
print(CRL)
# Creat state diagrams
TRT_subgr_labels = %s
CRL_subgr_labels = %s
plot_diagram(A = TRT,
B = CRL,
A_subgr_labels = TRT_subgr_labels,
B_subgr_labels = CRL_subgr_labels,
which = 'Control')
plot_diagram(A = TRT,
B = CRL,
A_subgr_labels = TRT_subgr_labels,
B_subgr_labels = CRL_subgr_labels,
which = 'Experimental')
# Create Survival, Hazard and hazard ratio plots
plot_shhr(A = TRT, B = CRL)
",
sprintf("c(%s)", paste0(s_T_times(), collapse = ", ")), # The time intervals
sprintf("m2r(matrix(c(%s), nrow = %s, ncol = %s))", paste0(m2r(s_T_lambdaMat1()), collapse = ", "), input$s_T_subgr, input$s_T_timepoints),
sprintf("m2r(matrix(c(%s), nrow = %s, ncol = %s))", paste0(m2r(s_T_lambdaMat2()), collapse = ", "), input$s_T_subgr, input$s_T_timepoints),
sprintf("m2r(matrix(c(%s), nrow = %s, ncol = %s))", paste0(m2r(s_T_lambdaProgMat()), collapse = ", "), input$s_T_subgr, input$s_T_timepoints),
sprintf("c(%s)", paste0(s_T_p(), collapse = ", ")), # The proportions in the subgroups for treatment arm
sprintf("m2r(matrix(c(%s), nrow = %s, ncol = %s))", paste0(m2r(s_T_lambdaMat1()), collapse = ", "), input$s_T_subgr, input$s_T_timepoints),
sprintf("m2r(matrix(c(%s), nrow = %s, ncol = %s))", paste0(m2r(s_T_lambdaMat2()), collapse = ", "), input$s_T_subgr, input$s_T_timepoints),
sprintf("m2r(matrix(c(%s), nrow = %s, ncol = %s))", paste0(m2r(s_T_lambdaProgMat()), collapse = ", "), input$s_T_subgr, input$s_T_timepoints),
sprintf("c(%s)", paste0(s_C_p(), collapse = ", ")), # The proportions in the subgroups for control arm
sprintf("c(%s)", paste0(paste0("'", s_T_labels(), "'"), collapse = ", ")), # The proportions in the subgroups for control arm
sprintf("c(%s)", paste0(paste0("'", s_C_labels(), "'"), collapse = ", ")) # The proportions in the subgroups for control arm
)
owd <- setwd(tempdir())
on.exit(setwd(owd))
capture.output(cat(a), file = paste0("test.R"))
# tidy_file(file = "test.R", width.cutoff = 80) # this is to format nicely the R code https://yihui.name/formatr/
styler::style_file(path = "test.R", scope = "indention") # this is to format nicely the R code
out <- paste0("test.R")
file.rename(out, file)
}
)
Try the nph package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.