Skip to content

Commit

Permalink
feature: add design.survey
Browse files Browse the repository at this point in the history
  • Loading branch information
@cyk0315
cyk0315 committed Feb 7, 2024
1 parent d14e315 commit 5fd098f
Show file tree
Hide file tree
Showing 7 changed files with 138 additions and 62 deletions.
3 changes: 3 additions & 0 deletions NAMESPACE
View file
Original file line number Diff line number Diff line change
Expand Up @@ -164,6 +164,9 @@ importFrom(survey,svycoxph)
importFrom(survey,svydesign)
importFrom(survey,svyglm)
importFrom(survey,svykm)
importFrom(survey,svymean)
importFrom(survey,svytable)
importFrom(survey,svyvar)
importFrom(survival,Surv)
importFrom(survival,cluster)
importFrom(survival,concordance)
Expand Down
72 changes: 51 additions & 21 deletions R/forestcox.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -69,6 +69,7 @@ forestcoxUI<-function(id,label='forestplot'){
#' @param data_label Reactive data label
#' @param data_varStruct Reactive List of variable structure, Default: NULL
#' @param nfactor.limit nlevels limit in factor variable, Default: 10
#' @param design.survey reactive survey data. default: NULL
#' @return Shiny module server for forestcox
#' @details Shiny module server for forestcox
#' @examples
Expand Down Expand Up @@ -116,7 +117,7 @@ forestcoxUI<-function(id,label='forestplot'){
#' @importFrom rvg dml
#' @importFrom officer read_pptx add_slide ph_with ph_location

forestcoxServer<-function(id,data,data_label,data_varStruct=NULL,nfactor.limit=10){
forestcoxServer<-function(id,data,data_label,data_varStruct=NULL,nfactor.limit=10,design.survey = NULL){
moduleServer(
id,
function(input, output, session) {
Expand Down Expand Up @@ -152,7 +153,9 @@ forestcoxServer<-function(id,data,data_label,data_varStruct=NULL,nfactor.limit=1
factor_list <- mklist(data_varStruct(), factor_vars)

conti_vars <- setdiff(names(data()), factor_vars)

if (!is.null(design.survey)) {
conti_vars <- setdiff(conti_vars, c(names(design.survey()$allprob), names(design.survey()$strata), names(design.survey()$cluster)))
}
conti_vars_positive <- conti_vars[unlist(data[, lapply(.SD, function(x) {
min(x, na.rm = T) >= 0
}), .SDcols = conti_vars])]
Expand Down Expand Up @@ -219,29 +222,42 @@ forestcoxServer<-function(id,data,data_label,data_varStruct=NULL,nfactor.limit=1

tbsub<-reactive({
label <- data_label()
data<-data()
req(input$dep)
req(input$day)
req(input$subvar)
req(input$group)
if(is.null(design.survey)){

data<-data()
}else{
data<-design.survey()$variables
}




group.tbsub<-input$group
var.event <- input$dep
var.day <- input$day
req(input$time)

vs <- input$subvar
var.time<-input$time

isgroup<-ifelse(group.tbsub %in% vlist()$group_vars,1,0)

#data[[var.event]] <- as.numeric(as.vector(data[[var.event]]))
data <- data[!(var.day < var.time[1])]
data[[var.event]] <- ifelse(data[[var.day]] >= var.time[2] & data[[var.event]] == "1", 0, as.numeric(as.vector(data[[var.event]])))
data[[var.day]] <- ifelse(data[[var.day]] >= var.time[2], var.time[2], data[[var.day]])
data[[var.event]] <- as.numeric(as.vector(data[[var.event]]))

if(is.null(design.survey)){

coxdata<-data
}else{
coxdata<-design.survey()
coxdata$variables<-data
}

form <- as.formula(paste("Surv(", var.day, ",", var.event, ") ~ ", group.tbsub, sep = ""))
vs <- input$subvar
tbsub <- TableSubgroupMultiCox(form, var_subgroups = vs,var_cov = setdiff(input$cov, vs), data=data, time_eventrate = var.time[2] , line = F, decimal.hr = 3, decimal.percent = 1)


tbsub <- TableSubgroupMultiCox(form, var_subgroups = vs,var_cov = setdiff(input$cov, vs), data=coxdata, time_eventrate = var.time[2] , line = F, decimal.hr = 3, decimal.percent = 1)
#data[[var.event]] <- ifelse(data[[var.day]] > 365 * 5 & data[[var.event]] == 1, 0, as.numeric(as.vector(data[[var.event]])))
#tbsub <- TableSubgroupMultiCox(form, var_subgroups = vs, data=data, time_eventrate = 365 , line = F, decimal.hr = 3, decimal.percent = 1)
len<-nrow(label[variable==group.tbsub])
Expand All @@ -251,28 +267,46 @@ forestcoxServer<-function(id,data,data_label,data_varStruct=NULL,nfactor.limit=1
tbsub<-tbsub[,c(1,4:8)]
return(tbsub)
}
if(is.null(design.survey)){
ev.ov <- data[!is.na(get(group.tbsub)), sum(as.numeric(as.vector(get(var.event))),na.rm=TRUE), keyby = get(group.tbsub)][, V1]
nn.ov <- data[!is.na(get(group.tbsub)), .N, keyby = get(group.tbsub)][, N]

}else{
ev.ov <- round(svytable(as.formula(paste0("~", var.event, "+", group.tbsub)), design = coxdata)[2, ], 1)
nn.ov <- round(svytable(as.formula(paste0("~", group.tbsub)), design = coxdata), 1)

}
ov <- data.table(t(c("OverAll", paste0(ev.ov, "/", nn.ov, " (", round(ev.ov/nn.ov * 100, 1), "%)"))))

if(!is.null(vs)){
lapply(vs,
function(x){
cc<-data.table(matrix(ncol=len+1))
cc[[1]]<-x

dd.bind<-' '
getlev<-data.table(get=levels(data[[x]]))
for( y in levels(data[[group.tbsub]])){

if(is.null(design.survey)){
ev <- data[!is.na(get(x)) & get(group.tbsub) == y, sum(as.numeric(as.vector(get(var.event))),na.rm=TRUE), keyby = get(x)]
nn <- data[!is.na(get(x)) & get(group.tbsub) == y, .N, keyby = get(x)]
vv<-data.table(get=ev[,get],paste0(ev[, V1], "/", nn[, N], " (", round(ev[, V1]/ nn[, N] * 100, 1), "%)"))
ee<-merge(data.table(get=levels(ev[,get])),vv,all.x = TRUE)
dd.bind<-cbind(dd.bind,ee[,V2])
}else{
svy<-svytable(as.formula(paste0("~", var.event, "+", x)), design = subset(coxdata, !is.na(get(x)) & get(group.tbsub) == y))
ev <- round(svy[2, ], 1)
nn <- round(svytable(as.formula(paste0("~", x)), design = subset(coxdata, !is.na(get(x)) & get(group.tbsub) == y)), 1)
vv <- data.table(get=colnames(svy),paste0(ev, "/", nn, " (", round(ev/ nn * 100, 1), "%)"))
ee<-merge(getlev,vv,all.x=TRUE)
dd.bind<-cbind(dd.bind,ee[,V2])
}
}
names(cc) <- names(dd.bind)
rbind(cc, dd.bind)
}) %>% rbindlist -> ll

ev.ov <- data[, sum(as.numeric(as.vector(get(var.event))),na.rm=TRUE), keyby = get(group.tbsub)][, V1]
nn.ov <- data[, .N, keyby = get(group.tbsub)][, N]

ov <- data.table(t(c("OverAll", paste0(ev.ov, "/", nn.ov, " (", round(ev.ov/nn.ov * 100, 1), "%)"))))

names(ov) <- names(ll)
cn <- rbind(ov, ll)
Expand All @@ -285,11 +319,7 @@ forestcoxServer<-function(id,data,data_label,data_varStruct=NULL,nfactor.limit=1
colnames(tbsub)[1:(2+2*len)] <- c("Subgroup", paste0("N(%): ", label[variable == group.tbsub, val_label]), paste0( var.time[2],"-",input$day," KM rate(%): ", label[variable == group.tbsub, val_label]), "HR")

}else{
ev.ov <- data[, sum(as.numeric(as.vector(get(var.event))),na.rm=TRUE), keyby = get(group.tbsub)][, V1]
nn.ov <- data[, .N, keyby = get(group.tbsub)][, N]

ov <- data.table(t(c("OverAll", paste0(ev.ov, "/", nn.ov, " (", round(ev.ov/nn.ov * 100, 1), "%)"))))
cn<-ov
cn<-ov
names(cn)[-1] <- label[variable == group.tbsub, val_label]
tbsub <- cbind(Variable = paste0(tbsub[,1]," ",rownames(tbsub)), cn[, -1], tbsub[, c(label[variable == group.tbsub,level], names(tbsub)[4:6], 'P value','P for interaction')])

Expand Down Expand Up @@ -327,7 +357,7 @@ forestcoxServer<-function(id,data,data_label,data_varStruct=NULL,nfactor.limit=1
data <- data.table::setDT(tbsub())
len<-ncol(data)

ll<-ifelse(isgroup,nrow(label[variable==group.tbsub]),0)
ll<-ifelse(group.tbsub %in% vlist()$group_vars,nrow(label[variable==group.tbsub]),0)
data[HR==0|Lower==0,':='(HR=NA,Lower=NA,Upper=NA)]
data<-mutate(data,HR=round(log(as.numeric(HR)),2),
Lower=round(log(as.numeric(Lower)),2),Upper=round(log(as.numeric(Upper)),2))
Expand Down
98 changes: 69 additions & 29 deletions R/forestglm.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -65,6 +65,7 @@ forestglmUI<-function(id,label='forestplot'){
}



#' @title forestglmServer:shiny module server for forestglm
#' @description Shiny module server for forestglm
#' @param id id
Expand All @@ -73,6 +74,7 @@ forestglmUI<-function(id,label='forestplot'){
#' @param family family, "gaussian" or "binomial"
#' @param data_varStruct Reactive List of variable structure, Default: NULL
#' @param nfactor.limit nlevels limit in factor variable, Default: 10
#' @param design.survey reactive survey data. default: NULL
#' @return Shiny module server for forestglm
#' @details Shiny module server for forestglm
#' @examples
Expand Down Expand Up @@ -116,16 +118,18 @@ forestglmUI<-function(id,label='forestplot'){
#' }
#' @seealso
#' \code{\link[data.table]{setDT}}
#' \code{\link[survey]{surveysummary}}, \code{\link[survey]{svytable}}
#' \code{\link[forestploter]{forest_theme}}, \code{\link[forestploter]{forest}}
#' \code{\link[rvg]{dml}}
#' \code{\link[officer]{read_pptx}}, \code{\link[officer]{add_slide}}, \code{\link[officer]{ph_with}}, \code{\link[officer]{ph_location}}
#' @rdname forestglmServer
#' @export
#' @importFrom data.table setDT
#' @importFrom survey svymean svyvar svytable
#' @importFrom forestploter forest_theme forest
#' @importFrom rvg dml
#' @importFrom officer read_pptx add_slide ph_with ph_location
forestglmServer<-function(id,data,data_label,family,data_varStruct=NULL,nfactor.limit=10){
forestglmServer<-function(id,data,data_label,family,data_varStruct=NULL,nfactor.limit=10,design.survey=NULL){
moduleServer(
id,
function(input, output, session) {
Expand Down Expand Up @@ -160,7 +164,9 @@ forestglmServer<-function(id,data,data_label,family,data_varStruct=NULL,nfactor.
factor_list <- mklist(data_varStruct(), factor_vars)

conti_vars <- setdiff(names(data()), factor_vars)

if (!is.null(design.survey)) {
conti_vars <- setdiff(conti_vars, c(names(design.survey()$allprob), names(design.survey()$strata), names(design.survey()$cluster)))
}
conti_vars_positive <- conti_vars[unlist(data[, lapply(.SD, function(x) {
min(x, na.rm = T) >= 0
}), .SDcols = conti_vars])]
Expand All @@ -173,10 +179,13 @@ forestglmServer<-function(id,data,data_label,family,data_varStruct=NULL,nfactor.
class01_factor <- unlist(data[, lapply(.SD, function(x) {
identical(levels(x), c("0", "1"))
}), .SDcols = factor_vars])

isNA_factor <- unlist(data[, lapply(.SD, function(x) {
return (sum(is.na(x))!=0)
}) ])
validate(
need(length(class01_factor) >= 1, "No categorical variables coded as 0, 1 in data")
)
isNA_vars<-names(data)[isNA_factor]
factor_01vars <- factor_vars[class01_factor]

factor_01_list <- mklist(data_varStruct(), factor_01vars)
Expand All @@ -185,25 +194,25 @@ forestglmServer<-function(id,data,data_label,family,data_varStruct=NULL,nfactor.
group_list <- mklist(data_varStruct(), group_vars)
group2_vars<-factor_vars[nclass_factor==2]
except_vars <- factor_vars[nclass_factor > nfactor.limit | nclass_factor == 1 | nclass_factor == nrow(data())]

return(list(
factor_vars = factor_vars, factor_list = factor_list, conti_vars = conti_vars, conti_list = conti_list, conti_vars_positive = conti_vars_positive,
group2_vars= group2_vars,factor_01vars = factor_01vars, factor_01_list = factor_01_list, group_vars = group_vars, group_list = group_list, except_vars = except_vars
isNA_vars=isNA_vars,group2_vars= group2_vars,factor_01vars = factor_01vars, factor_01_list = factor_01_list, group_vars = group_vars, group_list = group_list, except_vars = except_vars
))
})
dep<-reactive({
if(family=='binomial'){
return(vlist()$factor_01vars)
return(setdiff(vlist()$factor_01vars,vlist()$isNA_vars))
}
return(names(data()))
return(setdiff(names(data()),vlist()$isNA_vars))
})

output$group_tbsub<-renderUI({
selectInput(session$ns('group'), 'Group', choices = vlist()$group2_vars, selected = vlist()$group2_vars[1])
req(input$dep)
selectInput(session$ns('group'), 'Group', choices = vlist()$group2_vars, selected = setdiff(vlist()$group2_vars,input$dep)[1])
})
output$dep_tbsub<-renderUI({
req(input$group)
selectInput(session$ns('dep'), 'Outcome', choices = dep(), selected = setdiff(dep(),input$group)[1])

selectInput(session$ns('dep'), 'Outcome', choices = dep(), selected = dep()[1])
})
output$subvar_tbsub<-renderUI({
req(input$group)
Expand All @@ -220,36 +229,55 @@ forestglmServer<-function(id,data,data_label,family,data_varStruct=NULL,nfactor.

tbsub<-reactive({
label <- data_label()
data<-data()
req(input$dep)
req(input$group)

group.tbsub<-input$group
var.event <- input$dep
group.tbsub<-input$group
if(is.null(design.survey)){
data<-data()
data[[var.event]] <- as.numeric(as.vector(data[[var.event]]))
coxdata<-data
}else{
data<-design.survey()$variables
data[[var.event]] <- as.numeric(as.vector(data[[var.event]]))
coxdata<-design.survey()
coxdata$variables<-data
}


data[[var.event]] <- as.numeric(as.vector(data[[var.event]]))


form <- as.formula(paste( var.event, " ~ ", group.tbsub, sep = ""))
req(input$subvar)
vs <- input$subvar

#data[[var.event]] <- ifelse(data[[var.day]] > 365 * 5 & data[[var.event]] == 1, 0, as.numeric(as.vector(data[[var.event]])))
tbsub <- TableSubgroupMultiGLM(form, var_subgroups = vs,var_cov = setdiff(input$cov, vs), data=data,family=family)
#tbsub <- TableSubgroupMultiGLM(form, var_subgroups = vs, data=data,family=family)
tbsub <- TableSubgroupMultiGLM(form, var_subgroups = vs,var_cov = setdiff(input$cov, vs), data=coxdata,family=family)
#tbsub <- TableSubgroupMultiGLM(form, var_subgroups = vs, data=coxdata,family=family)
len<-nrow(label[variable==group.tbsub])
data<-data.table::setDT(data)
if(family=='gaussian'){
setnames(tbsub,'Point.Estimate','Beta')
meanvar<-data[, .(round(mean(get(var.event),na.rm=TRUE),2),round(var(get(var.event),na.rm=TRUE),2))]%>%mutate(mean=paste(V1,'±',V2))
meanvar<-rbind(meanvar[,3],
if(is.null(design.survey)){
meanvar<-data[, .(round(mean(get(var.event),na.rm=TRUE),2),round(var(get(var.event),na.rm=TRUE),2))]%>%mutate(mean=paste(V1,'±',V2))
meanvar<-meanvar[,3]
}else{
ss<-paste('~',var.event)
meanvar<-data.table(mean=paste(round(ftable(survey::svymean(as.formula(ss),coxdata))[,1],2),'±',round(ftable(survey::svyvar(as.formula(ss),coxdata))[,1],2)))
}
meanvar<-rbind(meanvar,
lapply(vs,
function(x){
cc<-data.table(mean=NA)
for( y in levels(data[[x]])){
if(is.null(design.survey)){
ev <- data[!is.na(get(x)) & get(x) == y, .(round(mean(get(var.event),na.rm=TRUE),2),round(var(get(var.event),na.rm=TRUE),2))]%>%
mutate(mean=paste(V1,'±',V2))
cc<-rbind(cc,ev[,3])
}else{
sub<-subset(coxdata, !is.na(get(x)) & get(group.tbsub) == y)
ss<-paste('~',var.event)
ev<-data.table(mean=paste(round(ftable(survey::svymean(as.formula(ss),sub))[,1],2),'±',round(ftable(survey::svyvar(as.formula(ss),sub))[,1],2)))
cc<-rbind(cc,ev)

}
}
cc
})%>%rbindlist
Expand All @@ -258,6 +286,15 @@ forestglmServer<-function(id,data,data_label,family,data_varStruct=NULL,nfactor.
colnames(tbsub)[1]<-'Subgroup'
return(tbsub)
}
if(is.null(design.survey)){
ev.ov <- data[!is.na(get(group.tbsub)), sum(as.numeric(as.vector(get(var.event))),na.rm=TRUE), keyby = get(group.tbsub)][, V1]
nn.ov <- data[!is.na(get(group.tbsub)), .N, keyby = get(group.tbsub)][, N]
}else{
ev.ov <- round(survey::svytable(as.formula(paste0("~", var.event, "+", group.tbsub)), design = coxdata)[2, ], 1)
nn.ov <- round(survey::svytable(as.formula(paste0("~", group.tbsub)), design = coxdata), 1)

}
ov <- data.table(t(c("OverAll", paste0(ev.ov, "/", nn.ov, " (", round(ev.ov/nn.ov * 100, 1), "%)"))))

if(!is.null(vs)){
lapply(vs,
Expand All @@ -266,21 +303,27 @@ forestglmServer<-function(id,data,data_label,family,data_varStruct=NULL,nfactor.
cc[[1]]<-x

dd.bind<-' '
getlev<-data.table(get=levels(data[[x]]))
for( y in levels(data[[group.tbsub]])){
if(is.null(design.survey)){
ev <- data[!is.na(get(x)) & get(group.tbsub) == y, sum(as.numeric(as.vector(get(var.event))),na.rm=TRUE), keyby = get(x)]
nn <- data[!is.na(get(x)) & get(group.tbsub) == y, .N, keyby = get(x)]
vv<-data.table(get=ev[,get],paste0(ev[, V1], "/", nn[, N], " (", round(ev[, V1]/ nn[, N] * 100, 1), "%)"))
ee<-merge(data.table(get=levels(ev[,get])),vv,all.x = TRUE)
dd.bind<-cbind(dd.bind,ee[,V2])
}else{
svy<-survey::svytable(as.formula(paste0("~", var.event, "+", x)), design = subset(coxdata, !is.na(get(x)) & get(group.tbsub) == y))
ev <- round(svy[2, ], 1)
nn <- round(survey::svytable(as.formula(paste0("~", x)), design = subset(coxdata, !is.na(get(x)) & get(group.tbsub) == y)), 1)
vv <- data.table(get=colnames(svy),paste0(ev, "/", nn, " (", round(ev/ nn * 100, 1), "%)"))
ee<-merge(getlev,vv,all.x=TRUE)
dd.bind<-cbind(dd.bind,ee[,V2])
}
}
names(cc) <- names(dd.bind)
rbind(cc, dd.bind)
}) %>% rbindlist -> ll

ev.ov <- data[, sum(as.numeric(as.vector(get(var.event))),na.rm=TRUE), keyby = get(group.tbsub)][, V1]
nn.ov <- data[, .N, keyby = get(group.tbsub)][, N]

ov <- data.table(t(c("OverAll", paste0(ev.ov, "/", nn.ov, " (", round(ev.ov/nn.ov * 100, 1), "%)"))))

names(ov) <- names(ll)
cn <- rbind(ov, ll)
Expand All @@ -293,10 +336,6 @@ forestglmServer<-function(id,data,data_label,family,data_varStruct=NULL,nfactor.
colnames(tbsub)[1:(1+len)] <- c("Subgroup", paste0("N(%): ", label[variable == group.tbsub, val_label]))

}else{
ev.ov <- data[, sum(as.numeric(as.vector(get(var.event))),na.rm=TRUE), keyby = get(group.tbsub)][, V1]
nn.ov <- data[, .N, keyby = get(group.tbsub)][, N]

ov <- data.table(t(c("OverAll", paste0(ev.ov, "/", nn.ov, " (", round(ev.ov/nn.ov * 100, 1), "%)"))))
cn<-ov
names(cn)[-1] <- label[variable == group.tbsub, val_label]
tbsub <- cbind(Variable = paste0(tbsub[,1]," ",rownames(tbsub)), cn[, -1], tbsub[, c( names(tbsub)[4:6], 'P value','P for interaction')])
Expand Down Expand Up @@ -331,6 +370,7 @@ forestglmServer<-function(id,data,data_label,family,data_varStruct=NULL,nfactor.
}

data <- data.table::setDT(tbsub())
group.tbsub<-input$group
if(family=='gaussian'){
r<-'Beta'
ll<-1
Expand Down
Loading

0 comments on commit 5fd098f

Please sign in to comment.