server <- function(input, output, session) {
# output$sidebarAspect <- renderUI({
# tags$style(HTML(paste0(".main-sidebar{width: ", input$sidebarwidth,"%;}")))
# })
output$xxx <- renderPrint({
# cat("summary(rv$dataset)\n")
# print(summary(rv$dataset))
# cat("-----------------\n")
# cat("summary(rv$datasetorig)\n")
# print(summary(rv$datasetorig))
# cat("-----------------\n")
# cat("summary(rv$datasetorigfiltered)\n")
# print(summary(rv$datasetorigfiltered))
# print(input$sepSNPs)
input$rightPanel
})
output$github <- renderUser({
div(style="margin-top:5px;border:1px solid #3C8DBC;",
HTML(
'<a title="github" href="https://github.com/isubirana/compareGroups" target="_blank" class="btn btn-social-icon">
<i style="background-color:#3C8DBC; color:white;" class="fab fa-github"></i>
</a>'
)
)
})
observe({
type <- if(is.null(input$type)) 1 else as.character(input$type)
showci <- if(is.null(input$showci)) FALSE else input$showci
conflevel <- if(is.null(input$conflevel)) 0.95 else input$conflevel
if (!showci)
vv <- switch(type,"1"="%","2"="N (%)","3"="N")
else
vv <- paste0("% [",conflevel,"%CI]")
updateTextInput(session,"extralabelperc",value=vv)
})
observe({
sdtype <- if(is.null(input$sdtype)) 1 else as.character(input$sdtype)
showci <- if(is.null(input$showci)) FALSE else input$showci
conflevel <- if(is.null(input$conflevel)) 0.95 else input$conflevel
if (!showci)
vv <- switch(sdtype,"1"="Mean (SD)","2"="Mean\u00B1SD")
else
vv <- paste0("Mean [",conflevel,"%CI]")
updateTextInput(session,"extralabelmean",value=vv)
})
observe({
qtype1 <- if(is.null(input$qtype1)) "1" else as.character(input$qtype1)
qtype2 <- if(is.null(input$qtype2)) "1" else as.character(input$qtype2)
Q1 <- if(is.null(input$Q1)) 25 else input$Q1
Q3 <- if(is.null(input$Q3)) 25 else input$Q3
showci <- if(is.null(input$showci)) FALSE else input$showci
conflevel <- if(is.null(input$conflevel)) 0.95 else input$conflevel
if (!showci)
vv <- paste0("Median ",switch(qtype1,"1"="[","2"="("),Q1,switch(qtype2,"1"=";","2"=",","3"="-"),Q3,switch(qtype1,"1"="]","2"=")"))
else
vv <- paste0("Median [",conflevel,"%CI]")
updateTextInput(session,"extralabelmedian",value=vv)
})
observe({
timemax <- if(is.null(input$timemax)) NA else input$timemax
showci <- if(is.null(input$showci)) FALSE else input$showci
conflevel <- if(is.null(input$conflevel)) 0.95 else input$conflevel
if (!showci)
vv <- paste("Incidence")
else
vv <- paste0("Incidence [",conflevel,"%CI]")
if (!is.na(timemax)) vv <- paste0(vv," at time=",round(timemax,1))
updateTextInput(session,"extralabelsurv",value=vv)
})
observeEvent(input$varinfotabbtn, {
showModal(modalDialog(
easyClose = TRUE,
title = "Variable names / labels",
tableOutput("varinfotab")
))
})
observe_helpers(withMathJax = TRUE) # needed to use shinyhelper package
observeEvent(input$changeselevarsok,{
if (!is.null(rv$selevars) & length(rv$selevars)>0)
shinyjs::show("dropdownDescriptives")
else
shinyjs::hide("dropdownDescriptives")
})
# right panel
observeEvent(input$leftmenu,{
if (input$leftmenu=='Home'){
if (input$rightPanel){ # close right panel
updateControlbar("rightPanel")
}
}else{
if (!input$rightPanel){ # open right panel
updateControlbar("rightPanel")
}
}
})
## when data is loaded show the rest of menuItems
observeEvent(rv$datasetorig, {
if (NROW(rv$datasetorig)==0){
shinyjs::hide(selector = "ul li:eq(22)") # filter data
shinyjs::hide(selector = "ul li:eq(23)") # recode variables
shinyjs::hide(selector = "ul li:eq(24)") # table: variables
shinyjs::hide(selector = "ul li:eq(28)") # settings
shinyjs::hide(selector = "ul li:eq(33)") # display
shinyjs::hide(selector = "ul li:eq(38)") # plots: variables
shinyjs::hide(selector = "ul li:eq(39)") # plots: groups
shinyjs::hide(selector = "ul li:eq(40)") # snps: variables
shinyjs::hide(selector = "ul li:eq(41)") # snps: groups
shinyjs::hide(selector = "ul li:eq(42)") # snps: options
shinyjs::hide("TableHeader")
shinyjs::hide("PlotHeader")
shinyjs::hide("SNPsHeader")
shinyjs::hide("dropdownData")
# updateTabItems(session, "leftmenu", selected = "LoadData")
}else{
shinyjs::show(selector = "ul li:eq(22)") # filter data
shinyjs::show(selector = "ul li:eq(23)") # recode variables
shinyjs::show(selector = "ul li:eq(24)") # table: variables
shinyjs::show(selector = "ul li:eq(28)") # settings
shinyjs::show(selector = "ul li:eq(33)") # display
shinyjs::show(selector = "ul li:eq(38)") # plots: variables
shinyjs::show(selector = "ul li:eq(39)") # plots: groups
shinyjs::show(selector = "ul li:eq(40)") # snps: variables
shinyjs::show(selector = "ul li:eq(41)") # snps: groups
shinyjs::show(selector = "ul li:eq(42)") # snps: options
shinyjs::show("TableHeader")
shinyjs::show("PlotHeader")
shinyjs::show("SNPsHeader")
shinyjs::show("dropdownData")
# updateTabItems(session, "leftmenu", selected = "DescribedVariables")
}
})
observe({
if (!is.null(input$resptype) && input$resptype=='None'){
shinyjs::hide(selector = "ul li:eq(32)")
} else {
if (is.null(input$computeratio) && is.null(input$resptype)){
shinyjs::hide(selector = "ul li:eq(32)")
} else {
if (input$computeratio || input$resptype=='Survival')
shinyjs::show(selector = "ul li:eq(32)")
else
shinyjs::hide(selector = "ul li:eq(32)")
}
}
})
observe({
if (input$leftmenu=="Home"){
rv$DataHeaderColor <- "white"
rv$TableHeaderColor <- "white"
rv$PlotHeaderColor <- "white"
rv$SNPsHeaderColor <- "white"
hide("showDataPanel"); hide("dropdownData")
hide("descrTableBox"); hide("dropdownDescriptives")
hide("showPlotPanel"); hide("dropdownPlot")
hide("showSNPsPanel"); hide("dropdownSNPs")
show("homePanel")
}
if (input$leftmenu%in%c("LoadData","FilterData","RecodeVars")){
rv$DataHeaderColor <- "#357CA5"
rv$TableHeaderColor <- "white"
rv$PlotHeaderColor <- "white"
rv$SNPsHeaderColor <- "white"
hide("homePanel")
hide("descrTableBox"); hide("dropdownDescriptives")
hide("showPlotPanel"); hide("dropdownPlot")
hide("showSNPsPanel"); hide("dropdownSNPs")
show("showDataPanel")
if (NROW(rv$datasetorig)>0)
{show("dropdownData")}
else
{hide("dropdownData")}
}
if (input$leftmenu%in%c("Variables","DescribedVariables","ResponseVariable","StrataVariable",
"Type","Hide","Subset","ORHR",
"Show","Format","Decimals","Labels")){
rv$DataHeaderColor <- "white"
rv$TableHeaderColor <- "#357CA5"
rv$PlotHeaderColor <- "white"
rv$SNPsHeaderColor <- "white"
hide("homePanel")
hide("showDataPanel"); hide("dropdownData")
hide("showPlotPanel"); hide("dropdownPlot")
hide("showSNPsPanel"); hide("dropdownSNPs")
show("descrTableBox")
if (inherits(create(),"createTable"))
{show("dropdownDescriptives")}
else
{hide("dropdownDescriptives")}
}
if (input$leftmenu%in%c("PlotVariables","PlotGroups")){
rv$DataHeaderColor <- "white"
rv$TableHeaderColor <- "white"
rv$PlotHeaderColor <- "#357CA5"
rv$SNPsHeaderColor <- "white"
hide("homePanel")
hide("showDataPanel"); hide("dropdownData")
hide("descrTableBox"); hide("dropdownDescriptives")
hide("showSNPsPanel"); hide("dropdownSNPs")
show("showPlotPanel");
if (rv$plotcreated)
{show("dropdownPlot")}
else
{hide("dropdownPlot")}
}
if (input$leftmenu%in%c("SNPsVariables","SNPsGroups","SNPsOptions")){
rv$DataHeaderColor <- "white"
rv$TableHeaderColor <- "white"
rv$PlotHeaderColor <- "white"
rv$SNPsHeaderColor <- "#357CA5"
hide("homePanel")
hide("showDataPanel"); hide("dropdownData")
hide("descrTableBox"); hide("dropdownDescriptives")
hide("showPlotPanel"); hide("dropdownPlot")
show("showSNPsPanel")
if (inherits(createSNPs(),"compareSNPs"))
{show("dropdownSNPs")}
else
{hide("dropdownSNPs")}
}
})
onclick("DataHeader",{
rv$DataHeaderColor <- "#357CA5"
rv$TableHeaderColor <- "white"
rv$PlotHeaderColor <- "white"
rv$SNPsHeaderColor <- "white"
hide("leftPanel")
hide("homePanel")
hide("descrTableBox"); hide("dropdownDescriptives")
hide("showPlotPanel"); hide("dropdownPlot")
hide("showSNPsPanel"); hide("dropdownSNPs")
show("showDataPanel")
if (NROW(rv$datasetorig)>0)
{show("dropdownData")}
else
{hide("dropdownData")}
})
onclick("TableHeader",{
rv$DataHeaderColor <- "white"
rv$TableHeaderColor <- "#357CA5"
rv$PlotHeaderColor <- "white"
rv$SNPsHeaderColor <- "white"
hide("leftPanel")
hide("homePanel")
hide("showDataPanel"); hide("dropdownData")
hide("showPlotPanel"); hide("dropdownPlot")
hide("showSNPsPanel"); hide("dropdownSNPs")
show("descrTableBox")
if (inherits(create(),"createTable"))
{show("dropdownDescriptives")}
else
{hide("dropdownDescriptives")}
})
onclick("PlotHeader",{
rv$DataHeaderColor <- "white"
rv$TableHeaderColor <- "white"
rv$PlotHeaderColor <- "#357CA5"
rv$SNPsHeaderColor <- "white"
hide("leftPanel")
hide("homePanel")
hide("showDataPanel"); hide("dropdownData")
hide("descrTableBox"); hide("dropdownDescriptives")
hide("showSNPsPanel"); hide("dropdownSNPs")
show("showPlotPanel")
if (rv$plotcreated)
{show("dropdownPlot")}
else
{hide("dropdownPlot")}
})
onclick("SNPsHeader",{
rv$DataHeaderColor <- "white"
rv$TableHeaderColor <- "white"
rv$PlotHeaderColor <- "white"
rv$SNPsHeaderColor <- "#357CA5"
hide("leftPanel")
hide("homePanel")
hide("showDataPanel"); hide("dropdownData")
hide("descrTableBox"); hide("dropdownDescriptives")
hide("showPlotPanel"); hide("dropdownPlot")
show("showSNPsPanel")
if (inherits(createSNPs(),"compareSNPs"))
{show("dropdownSNPs")}
else
{hide("dropdownSNPs")}
})
output$DataHeaderText <- renderUI({
cc <- rv$DataHeaderColor
HTML(paste0("<i style='margin-left:10px; color:",cc,"' class='fa fa-database'></i><format style='color:",cc,"; font-weight:bold; padding-left:10px; font-size:20px'>Data</format>"))
})
output$TableHeaderText <- renderUI({
cc <- rv$TableHeaderColor
HTML(paste0("<i style='margin-left:10px; color:",cc,"' class='fa fa-table'></i><format style='color:",cc,"; font-weight:bold; padding-left:10px; font-size:20px'>Descriptive Table</format>"))
})
output$PlotHeaderText <- renderUI({
cc <- rv$PlotHeaderColor
HTML(paste0("<i style='margin-left:10px; color:",cc,"' class='fa fa-chart-bar'></i><format style='color:",cc,"; font-weight:bold; padding-left:10px; font-size:20px'>Plots</format>"))
})
output$SNPsHeaderText <- renderUI({
cc <- rv$SNPsHeaderColor
HTML(paste0("<i style='margin-left:10px; color:",cc,"' class='fa fa-dna'></i><format style='color:",cc,"; font-weight:bold; padding-left:10px; font-size:20px'>SNPs</format>"))
})
##### hide show load data options #####
observe({
if (input$exampledata!='Own data'){
shinyjs::hide("ownPanel")
shinyjs::hide("files")
shinyjs::show("loadok")
} else {
shinyjs::show("files")
if (is.null(input$files)){
shinyjs::hide("ownPanel")
shinyjs::hide("loadok")
}else{
shinyjs::show("ownPanel")
shinyjs::show("loadok")
}
}
})
observe({
if (input$datatype!='*.xls') return(NULL)
tablenames <- try(readxl::excel_sheets(input$files$datapath), silent=TRUE)
if (inherits(tablenames, "try-error")) return(NULL)
names(tablenames)<-tablenames
updateSelectInput(session, "tablenames", choices=tablenames)
})
output$previewtxtdown <- downloadHandler(
filename = function() input$files$name,
content = function(ff){
file.copy(input$files$datapath, ff)
}
)
## init some input values when pressing loadok button
## reactive Values
rv<-reactiveValues()
rv$dataset <- rv$datasetorig <- rv$datasetorigfiltered <- data.frame()
rv$recodedvars <- character()
rv$changemethodcount<-0
observeEvent(input$changemethod,{
rv$changemethodcount<-rv$changemethodcount+1
})
rv$changestratacount<-0
observeEvent(input$changestrata,{
rv$changestratacount<-rv$changestratacount+1
})
rv$changevarsubsetcount<-0
observeEvent(input$changevarsubset,{
rv$changevarsubsetcount<-rv$changevarsubsetcount+1
})
rv$changedescdigitscount<-0
observeEvent(input$changedescdigits,{
rv$changedescdigitscount<-rv$changedescdigitscount+1
})
rv$changeratiodigitscount<-0
observeEvent(input$changeratiodigits,{
rv$changeratiodigitscount<-rv$changeratiodigitscount+1
})
rv$changeshowcount<-0
observeEvent(input$changeshow,{
rv$changeshowcount<-rv$changeshowcount+1
})
rv$changeformatcount<-0
observeEvent(input$changeformat,{
rv$changeformatcount<-rv$changeformatcount+1
})
rv$changehidecount<-0
observeEvent(input$changehide,{
rv$changehidecount<-rv$changehidecount+1
})
rv$changepvalsdigitscount<-0
observeEvent(input$changepvalsdigits,{
rv$changepvalsdigitscount<-rv$changepvalsdigitscount+1
})
rv$changerespcount<-0
observeEvent(input$changeresp,{
rv$changerespcount<-rv$changerespcount+1
})
rv$changeselevarsokcount<-0
observeEvent(input$changeselevarsok,{
rv$changeselevarsokcount<-rv$changeselevarsokcount+1
})
rv$changeglobalsubsetcount<-0
observeEvent(input$changeglobalsubset,{
rv$changeglobalsubsetcount<-rv$changeglobalsubsetcount+1
})
rv$changeratiocatcount<-0
observeEvent(input$changeratiocat,{
rv$changeratiocatcount<-rv$changeratiocatcount+1
})
rv$changefactratiocount<-0
observeEvent(input$changefactratio,{
rv$changefactratiocount<-rv$changefactratiocount+1
})
rv$initial<-FALSE
observeEvent(rv$dataset,{
# if (!is.null(dataset())) rv$initial<<-TRUE
if (nrow(rv$dataset)>0) rv$initial<-TRUE else rv$initial<-FALSE
})
rv$plotcreated <- FALSE
rv$DataHeaderColor <- rv$TableHeaderColor <- rv$PlotHeaderColor <- rv$SNPsHeaderColor <- "white"
## udpate dataset when selecting rows on-line from DT
observeEvent(input$valuesext_rows_all,{
ll <- lapply(rv$dataset, attr, which="label", exact=TRUE)
ll <- unlist(ifelse(sapply(ll, is.null), names(rv$dataset), ll))
rv$dataset <- rv$datasetorig[input$valuesext_rows_all,,drop=FALSE]
for (j in 1:ncol(rv$dataset)) attr(rv$dataset[,j],"label") <- ll[j]
})
## recode variables
observeEvent(input$newvarok,{
if (input$newvarlabel=='')
updateTextInput(session, "newvarlabel", value=input$newvarname)
if (input$newvarname==''){
shinyjs::alert("Enter the variable name")
return(NULL)
}
if (input$newvarexpr==''){
shinyjs::alert("Write an R code to compute the variable")
return(NULL)
}
expr <- input$newvarexpr
dataset <- rv$datasetorig
var <- try(eval(parse(text=paste("with(dataset,{", expr,"})"))), silent=TRUE)
if (inherits(var, "try-error")){
shinyjs::alert("Error in evaluating the R code")
return(NULL)
}
# attr(var, "label") <- input$newvarlabel
rv$datasetorig[,input$newvarname] <- var
attr(rv$datasetorig[,input$newvarname], "label") <- input$newvarlabel
rv$datasetorigfiltered <- rv$datasetorig
rv$dataset <- rv$datasetorig
rv$recodedvars <- c(rv$recodedvars, input$newvarname)
})
# convert to factor
observeEvent(rv$dataset,{
if (nrow(rv$dataset)==0) return(invisible(NULL))
vv <- names(rv$dataset)[sapply(rv$dataset, function(x) !is.Surv(x) & is.numeric(x))]
updateSelectInput(session, "vartofactor", choices=vv, selected=input$vartofactor)
})
observeEvent(input$vartofactorbtn, {
if (nrow(rv$dataset)==0) return(invisible(NULL))
lab <- attr(rv$dataset[,input$vartofactor], "label")
rv$dataset[,input$vartofactor] <- as.factor(rv$dataset[,input$vartofactor])
attr(rv$dataset[,input$vartofactor], "label") <- lab
})
observeEvent(input$removenewvarok,{
updateTextInput(session, "newvarname", value="")
updateTextInput(session, "newvarlabel", value="")
updateTextAreaInput(session, "newvarexpr", value="")
})
# observeEvent(input$changeselevarsok,{
observe({
input$selevars
input$selevarsAll
input$selevarsNone
rv$selevars <- input$selevars
})
observeEvent(input$changemethod,{
if (!is.null(rv$method)){
if (!is.null(input$varselemethodALL) && input$varselemethodALL)
rv$method[1:length(rv$method)]<<-ifelse(input$method=='Normal',1,
ifelse(input$method=='Non-normal',2,
ifelse(input$method=='Categorical',3,NA)))
else
if (length(input$varselemethod)>0)
rv$method[input$varselemethod]<<-ifelse(input$method=='Normal',1,
ifelse(input$method=='Non-normal',2,
ifelse(input$method=='Categorical',3,NA)))
}
})
observeEvent(input$changedescdigits,{
if (!is.null(rv$descdigits)){
if (!is.null(input$varseledescdigitsALL) && input$varseledescdigitsALL)
rv$descdigits[1:length(rv$descdigits)]<-ifelse(input$descdigits==-1,NA,input$descdigits)
else
if (length(input$varseledescdigits)>0)
rv$descdigits[input$varseledescdigits]<-ifelse(input$descdigits==-1,NA,input$descdigits)
}
})
observeEvent(input$changeratiodigits,{
if (!is.null(rv$ratiodigits)){
if (!is.null(input$varseleratiodigitsALL) && input$varseleratiodigitsALL)
rv$ratiodigits[1:length(rv$ratiodigits)]<-ifelse(input$ratiodigits==-1,NA,input$ratiodigits)
else
if (length(input$varseleratiodigits)>0)
rv$ratiodigits[input$varseleratiodigits]<-ifelse(input$ratiodigits==-1,NA,input$ratiodigits)
}
})
observeEvent(input$changeratiocat,{
if (length(input$varselerefratio)>0 && !is.null(input$refratiocat)){
catval<-as.numeric(strsplit(input$refratiocat,":")[[1]][1])
rv$refratiocat[input$varselerefratio]<-catval
#rv$refratiocat<-refratiocat
}
})
observeEvent(input$changefactratio,{
if (!is.null(rv$factratio)){
if (!is.null(input$varselefactratioALL) && input$varselefactratioALL)
rv$factratio[1:length(rv$factratio)]<-input$factratio
else
if (length(input$varselefactratio)>0)
rv$factratio[input$varselefactratio]<-input$factratio
}
})
observeEvent(input$changehide,{
if (length(input$varselehide)>0 && !is.null(input$hidecat) && !is.null(rv$xhide)){
catval<-as.numeric(strsplit(input$hidecat,":")[[1]][1])
rv$xhide[input$varselehide]<-catval
}
})
observeEvent(input$changevarsubset,{
if (is.null(rv$varsubset)) return(NULL)
if (length(input$varselevarsubset)>0) rv$varsubset[input$varselevarsubset]<-input$varsubset
rv$varsubset<-ifelse(rv$varsubset=='',NA,rv$varsubset)
})
## help modal
rv$count <- 1
observeEvent(input$dec,{
rv$count<-rv$count-1
})
observeEvent(input$inc,{
rv$count<-rv$count+1
})
observeEvent(input$helpcg,{
shinyjs::toggle("mycarouselPanel")
})
## toggles
# iniciate the table
observeEvent(input$collapseInput,{
if (rv$changeselevarsokcount==0)
shinyjs::click("changeselevarsok")
})
###############
## read data ##
###############
# guess format by extension
observeEvent(input$files, {
extension <- tools::file_ext(input$files$name)
if (extension=="sav")
{updateSelectInput(session, "datatype", selected='*.sav'); return(NULL)}
if (extension%in%c("xlsx","xls"))
{updateSelectInput(session, "datatype", selected='*.xls'); return(NULL)}
if (extension%in%c("rda","rds","RData"))
{updateSelectInput(session, "datatype", selected='*.rda'); return(NULL)}
if (extension%in%c("dta"))
{updateSelectInput(session, "datatype", selected='*.dta'); return(NULL)}
updateSelectInput(session, "datatype", selected='*.txt')
})
observeEvent(input$resetbtn,{
on.exit({shinyjs::hide("resetbtnPanel")})
# reset all inputs!!!
rv$selevars<-rv$method<-rv$descdigits<-rv$ratiodigits<-rv$refratiocat<-rv$factratio<-rv$xhide<-rv$varsubset<-NULL
rv$initial<-FALSE
rv$datasetorig <- rv$dataset <- rv$datasetorigfiltered <- data.frame()
shinyjs::reset("LoadDataPanel")
shinyjs::reset("ResponseVariablePanel")
shinyjs::reset("StrataVariablePanel")
shinyjs::reset("TypePanel")
shinyjs::reset("HidePanel")
shinyjs::reset("SubsetPanel")
shinyjs::reset("RatioPanel")
shinyjs::reset("ShowPanel")
shinyjs::reset("FormatPanel")
shinyjs::reset("DecimalsPanel")
shinyjs::reset("LabelsPanel")
shinyjs::reset("SavePanel")
shinyjs::reset("PlotGroupsPanel")
shinyjs::reset("PlotVariablesPanel")
shinyjs::reset("SNPsGroupsPanel")
shinyjs::reset("SNPsVariablesPanel")
shinyjs::show("LoadDataPanel")
})
# read data
observeEvent(input$loadok,{
# remove all elements
rm(list=ls(),envir=.cGroupsWUIEnv)
## begin to read!
progress <- shiny::Progress$new(session, min=1, max=3)
progress$set(message = "Reading data",value=1)
on.exit(progress$close())
rv$selevars<<-rv$method<<-rv$descdigits<<-rv$ratiodigits<<-rv$refratiocat<<-rv$factratio<<-rv$xhide<<-rv$varsubset<<-NULL
rv$initial<<-FALSE
if (input$exampledata!='Own data'){ # read examples...
datasetname<-input$exampledata
if (input$exampledata=='REGICOR'){
data(regicor)
dataset <- regicor
}
if (input$exampledata=='SNPS'){
# data(SNPs,package="SNPassoc")
data(SNPs)
dataset <- SNPs
}
} else { # read own data
inFile<-input$files
if (is.null(inFile)){
return(invisible(NULL))
}
# read TXT
if (input$datatype=='*.txt'){
if (is.null(input$quote))
quote<-'"'
else{
if (input$quote==1)
quote<-""
if (input$quote==2)
quote<-'"'
if (input$quote==3)
quote<-"'"
}
if (input$sep=='o')
sepchar<-input$sepother
else
sepchar<-input$sep
if (input$encoding=='default')
dataset<- try(read.table(inFile$datapath,header=input$header,sep=sepchar,quote=quote,dec=input$dechar,na.strings=input$missvalue,skip=input$skip),silent=TRUE)
else
dataset<- try(read.table(inFile$datapath,header=input$header,sep=sepchar,quote=quote,dec=input$dechar,na.strings=input$missvalue,skip=input$skip,encoding=input$encoding),silent=TRUE)
if (inherits(dataset,"try-error")){
alert("Error in reading data")
return(invisible(NULL))
}
if (!is.data.frame(dataset)){
alert("Data is not a data frame")
return(invisible(NULL))
}
}
# read SPSS
if (input$datatype=='*.sav'){
dataset <- try(read_sav(inFile$datapath), silent=TRUE)
if (inherits(dataset,"try-error")){
alert("Error in reading data")
return(invisible(NULL))
}
if (!inherits(dataset, "data.frame")){
alert("Data is not a data frame")
return(invisible(NULL))
}
# fix data
dataset <- as_factor(dataset)
dataset <- as.data.frame(dataset)
# vl<-attr(dataset,"variable.labels")
for (i in 1:ncol(dataset)){
vari.label <- if (is.null(attr(dataset[,i],"label",exact=TRUE))) "" else attr(dataset[,i],"label",exact=TRUE)
# if (inherits(dataset[,i], "labelled")){
# value.labels <- attr(dataset[,i],"labels",exact=TRUE)
# dataset[,i] <- factor(dataset[,i], levels=value.labels, labels=names(value.labels))
# class(dataset[,i]) <- class(dataset[,i])[class(dataset[,i])!='labelled']
# }
attr(dataset[,i],"label") <- vari.label
}
}
# read STATA
if (input$datatype=='*.dta'){
dataset <- try(read_stata(inFile$datapath), silent=TRUE)
if (inherits(dataset,"try-error")){
alert("Error in reading data")
return(invisible(NULL))
}
if (!inherits(dataset, "data.frame")){
alert("Data is not a data frame")
return(invisible(NULL))
}
# fix data
dataset <- as.data.frame(dataset)
# vl<-attr(dataset,"variable.labels")
for (i in 1:ncol(dataset)){
vari.label <- if (is.null(attr(dataset[,i],"label",exact=TRUE))) "" else attr(dataset[,i],"label",exact=TRUE)
if (inherits(dataset[,i], "labelled")){
value.labels <- attr(dataset[,i],"labels",exact=TRUE)
dataset[,i] <- factor(dataset[,i], levels=value.labels, labels=names(value.labels))
class(dataset[,i]) <- class(dataset[,i])[class(dataset[,i])!='labelled']
}
attr(dataset[,i],"label") <- vari.label
}
}
# read R
if (input$datatype=='*.rda'){
datasetname <- try(load(inFile$datapath),silent=TRUE)
if (inherits(datasetname,"try-error")){
alert("Error in reading data")
return(invisible(NULL))
}
dataset <- get(datasetname)
if (!is.data.frame(dataset)){
alert("Data is not a data frame")
return(invisible(NULL))
}
}
# read EXCEL
if (input$datatype=='*.xls'){
if (is.null(input$tablenames))
return(invisible(NULL))
dataset<-try(readxl::read_excel(path=inFile$datapath, sheet=input$tablenames, skip=input$skipexcel, col_names=input$headerexcel, na=input$missvalueexcel), silent=TRUE)
if (inherits(dataset,"try-error")){
alert("Data set could not be loaded.\nCheck if the file belongs to Excel format.")
return(invisible(NULL))
}
dataset <- as.data.frame(dataset) # to remove tibble class.
if (input$stringToFactorexcel) # convert to factor
for (i in seq_along(dataset))
if (is.character(dataset[,i])){
lab.i <- attr(dataset[,i], "label", exact=TRUE)
dataset[,i] <- factor(dataset[,i])
attr(dataset[,i],"label") <- lab.i
}
}
}
if (!inherits(dataset, "data.frame") || nrow(dataset)==0){
alert("Dataset could not be loaded.\nCheck the file format and/or the options.")
return(invisible(NULL))
}
# iniciate selevars
rv$selevars<-names(dataset)
# iniciate method
res<-try(compareGroups(~.,dataset,max.xlev=Inf,max.ylev=Inf,method=NA),silent=TRUE)
if (inherits(res, "try-error")){
rv$methods <- structure(rep(1,ncol(dataset)), names=names(dataset))
} else {
method<-sapply(res,function(x) paste(attr(x,"method"),collapse=" "))
method<-ifelse(method=="continuous normal",1,
ifelse(method=="continuous non-normal",2,3))
names(method)<-attr(res,"varnames.orig")
rv$method<<-method
}
# iniciate descdigits
rv$descdigits <- structure(rep(NA,ncol(dataset)), names=names(dataset))
# iniciate ratiodigits
rv$ratiodigits <- structure(rep(NA,ncol(dataset)), names=names(dataset))
# iniciate reference category for OR/HR of categorical row-variables
rv$refratiocat <- structure(rep(1,ncol(dataset)), names=names(dataset))
# iniciate factor to be multiplied for continuous variables in computing OR/HR
rv$factratio <- structure(rep(1,ncol(dataset)), names=names(dataset))
# iniciate hide
rv$xhide <- structure(rep(NA,ncol(dataset)), names=names(dataset))
# iniciate variable subset
rv$varsubset <- structure(rep(NA,ncol(dataset)), names=names(dataset))
# iniciate recoded vars names
rv$recodedvars <- character()
# iniciate selected variables (by default all)
updateSelectInput(session, "selevars", selected=names(dataset), choices=names(dataset))
updateSelectInput(session, "plotselevars", selected=names(dataset), choices=names(dataset))
updateSelectInput(session, "snpsselevars", selected=names(dataset), choices=names(dataset))
# return data
rv$datasetorig <- dataset
rv$dataset <- dataset
rv$datasetorigfiltered <- dataset
# when data is loaded, hide the LoadDataPanel
shinyjs::hide("LoadDataPanel")
shinyjs::show("resetbtnPanel")
})
# if datasetorig is changed (means that new variable is created or data is reload) then dataset it must be reset too!!!
observeEvent(rv$datasetorig,{
rv$dataset <- rv$datasetorig
})
# when filter is applied dataset must be updated
observeEvent(rv$datasetorigfiltered,{
rv$dataset <- rv$datasetorigfiltered
})
###############################
###### Filter data ############
###############################
observeEvent(input$filterdataok,{
filterexpr <- input$filterexpr
if (compareGroups:::trim(filterexpr)==""){ # no filter (recover original dataset)
rv$datasetorigfiltered <- rv$datasetorig
}
if (nrow(rv$datasetorig)==0) return(NULL)
filterexpr <- paste0("subset(rv$datasetorig,",filterexpr,")")
ans <- try(eval(parse(text=filterexpr)), silent=TRUE)
if (inherits(ans, "try-error")){
alert("Expression could not be evaluated. Check the variable names or the syntax.")
return(NULL)
}
rv$datasetorigfiltered <- ans
})
observeEvent(input$removefilterdataok,{
updateTextAreaInput(session, "filterexpr", value="")
})
###############################
#### LOAD OPTIONS #############
###############################
output$loadoptions<-renderUI({
inFile<-input$files
if (is.null(input$datatype))
return(invisible(NULL))
if (input$datatype!='*.xls' && input$datatype!='*.txt'){
return(invisible(NULL))
} else {
# EXCELL
if (input$datatype=='*.xls'){
if (is.null(inFile))
return(invisible(NULL))
tablenames <- try(readxl::excel_sheets(inFile$datapath), silent=TRUE)
if (inherits(tablenames,"try-error") || length(tablenames)==0)
return(invisible(NULL))
names(tablenames)<-tablenames
return(
div(
selectInput("tablenames", "Choose the table to read:", choices = tablenames, selectize=FALSE),
checkboxInput('headerexcel', 'Has column headers', TRUE),
numericInput("skipexcel", "Number of rows to skip", value=0),
textInput("missvalueexcel", HTML("Missing Data String (e.g. <i>NA</i>)"), ""),
checkboxInput("stringToFactorexcel", "Convert string variables to factor", value=TRUE)
)
)
} else {
# TXT
if (input$datatype=='*.txt'){
return(
wellPanel(
HTML('<p style="font-style:Bold; font-size:18px">TEXT Options</p>'),
checkboxInput('header', 'Has column headers', TRUE),
numericInput("skip", "Number of rows to skip", value=0),
textInput("missvalue", HTML("Missing Data String (e.g. <i>NA</i>)"), ""),
selectInput('sep', 'Column Separator', c(Comma=',', Semicolon=';', Tab='\t', Other='o'), ','),
conditionalPanel(
condition = "input.sep == 'o'",
textInput("sepother", "Specify separator character","")
),
selectInput('dechar', 'Decimal point character', c('Comma'=',', 'Dot'='.'), '.'),
selectInput('quote', 'Values in Quotes?', c("None"=1, "Double"=2, "Single"=3), 2),
radioButtons("encoding", "Encoding", c('default'='default','latin1'='latin1','utf8'='utf8'),'default',inline=TRUE)
)
)
}
}
}
})
###################
### create table ##
###################
create<-reactive({
# if (is.null(input$loadok)) return(NULL)
rv$changeglobalsubsetcount
# rv$changeselevarsokcount
input$changeselevarsok
rv$changerespcount
rv$changepvalsdigitscount
rv$changehidecount
rv$changefactratiocount
rv$changeformatcount
rv$changeshowcount
rv$changeratiocatcount
rv$changemethodcount
rv$changestratacount
rv$changevarsubsetcount
rv$changedescdigitscount
rv$changeratiodigitscount
input$udpateSelection
progress <- shiny::Progress$new(session, min=0, max=4)
progress$set(message = "Creating bivariate table",value=1)
on.exit(progress$close())
isolate({
dd<-rv$dataset
validate(need(dd, "Data not loaded"))
validate(need(!is.null(rv$selevars) && length(rv$selevars)>0,"No variables selected"))
# form
if (is.null(input$resptype) || input$resptype=='None'){
form<-as.formula(paste("~",paste(paste0("`",rv$selevars,"`"),collapse="+"),sep=""))
} else {
if (input$resptype=='Survival'){
# statusval<-as.numeric(strsplit(input$statuscat,":")[[1]][1])
# cens<-as.integer(dd[,input$varselestatus])==statusval
statusval <- paste(input$statuscat, collapse=";")
cens <- as.integer(dd[,input$varselestatus]%in%input$statuscat)
validate(need(length(input$statuscat)>=1, "you must select at least one category"))
times<-dd[,input$varseletime]
dd$"respsurv"<-Surv(times,cens)
# attr(dd$"respsurv","label")<-paste("[ ",input$varseletime,"; ",input$varselestatus,"=", levels(as.factor(dd[,input$varselestatus]))[statusval],"]")
attr(dd$"respsurv","label")<-paste("[ ",input$varseletime,"; ",input$varselestatus,"=", statusval,"]")
form<-as.formula(paste("respsurv~",paste(paste0("`",rv$selevars,"`"),collapse="+"),sep=""))
} else {
form<-as.formula(paste(input$gvar,"~",paste(paste0("`",rv$selevars,"`"),collapse="+"),sep=""))
}
}
computeratio<-if (is.null(input$computeratio) || input$resptype=='Survival') TRUE else input$computeratio
pvaldigits<-if (is.null(input$pvaldigits)) 3 else input$pvaldigits
# variables subset
varsubset <- rv$varsubset
if (is.null(rv$varsubset))
selec.list <- "NA"
else {
varsubset <- varsubset[!is.na(varsubset)]
if (length(varsubset)==0)
selec.list <- "NA"
else
selec.list <- paste0("list(", paste(paste(names(varsubset),"=",varsubset), collapse=", "),")")
}
# hide.no
if (length(input$hideno)==0 || input$hideno=='')
hideno<-NA
else
hideno<-unlist(strsplit(input$hideno,","))
# ref
refno<-hideno
refy<-if (is.null(input$gvarcat)) 1 else as.numeric(input$gvarcat)
res<-compareGroups(form,dd,max.xlev=Inf,max.ylev=Inf,method=rv$method,compute.ratio=FALSE)
refratiocat<-as.vector(rv$refratiocat[attr(res,"varnames.orig")])
factratio<-as.vector(rv$factratio[attr(res,"varnames.orig")])
# method
method<-as.vector(rv$method[attr(res,"varnames.orig")])
xhide<-as.vector(rv$xhide[attr(res,"varnames.orig")])
descdigits<-as.vector(rv$descdigits[attr(res,"varnames.orig")])
ratiodigits<-as.vector(rv$ratiodigits[attr(res,"varnames.orig")])
alpha<-if (is.null(input$alpha)) 0.05 else input$alpha
mindis<-if (is.null(input$mindis)) 0.05 else input$mindis
# quartiles, sd, ...
Q1<-if (is.null(input$Q1)) 25 else input$Q1
Q3<-if (is.null(input$Q3)) 75 else input$Q3
qtype1<-if (is.null(input$qtype1)) 1 else input$qtype1
qtype2<-if (is.null(input$qtype2)) 1 else input$qtype2
type<-if (is.null(input$type)) NA else input$type
sdtype<-if (is.null(input$sdtype)) 1 else input$sdtype
showpoverall<-if (is.null(input$showpoverall)) TRUE else input$showpoverall
showptrend<-if (is.null(input$showptrend)) FALSE else input$showptrend
showratio<-if (is.null(input$showratio)) FALSE else input$showratio
showpratio<-if (is.null(input$showpratio)) showratio else input$showpratio
showall<-if (is.null(input$showall)) TRUE else input$showall
shown<-if (is.null(input$shown)) FALSE else input$shown
showdesc<-if (is.null(input$showdesc)) TRUE else input$showdesc
showpmul<-if (is.null(input$showpmul)) FALSE else input$showpmul
pcorrected<-if (is.null(input$pcorrected)) 0.05 else input$pcorrected
includemiss<-if (is.null(input$includemiss)) FALSE else input$includemiss
simplify<-if (is.null(input$simplify)) TRUE else input$simplify
Dateformat<-if (is.null(input$Dateformat)) "d-mon-Y" else input$Dateformat
byrow <- if (is.null(input$byrow)) FALSE else switch(input$byrow, rows=TRUE, columns=FALSE, total=NA)
conflevel <- if (is.null(input$conflevel)) 0.95 else input$conflevel/100
showci <- if (is.null(input$showci)) FALSE else input$showci
riskratio <- if (is.null(input$riskratio)) FALSE else input$riskratio=="RR"
oddsratiomethod <- if (is.null(input$oddsratiomethod)) "midp" else input$oddsratiomethod
riskratiomethod <- if (is.null(input$riskratiomethod)) "wald" else input$riskratiomethod
timemax <- if (is.null(input$timemax)) NA else input$timemax
if(is.null(input$extralabels) || !input$extralabels){
extra.labels <- NA
} else {
extra.labels <- c(input$extralabelmean,input$extralabelmedian,input$extralabelperc,input$extralabelsurv)
}
# compareGroups
cmd.res <- paste0("compareGroups(form,dd,max.xlev=Inf,max.ylev=Inf,method=method,timemax=timemax,include.miss=includemiss,ref.no='no',
ref=refratiocat,Q1=Q1/100,Q3=Q3/100,simplify=simplify,compute.ratio=computeratio,
fact.ratio=factratio,ref.y=refy,min.dis=mindis,alpha=alpha,p.corrected=pcorrected,
Date.format=Dateformat,byrow=byrow,conf.level=conflevel,riskratio = riskratio,
riskratio.method=riskratiomethod,oddsratio.method=oddsratiomethod,
selec=",selec.list,")")
res <- eval(parse(text=cmd.res))
# createTable
restab<-createTable(res,show.p.overall=showpoverall,show.p.trend=showptrend,show.ratio=showratio,
show.p.ratio=showpratio,show.all=showall,show.n=shown,show.desc=showdesc,
hide.no=hideno,hide=xhide,type=type,sd.type=sdtype,q.type=c(qtype1,qtype2),
digits=descdigits,digits.ratio=ratiodigits,digits.p=pvaldigits,
show.p.mul=showpmul,show.ci=showci,extra.labels=extra.labels)
# strataTable
if (!is.null(input$stratatype) && input$stratatype!="None"){
cg <- attr(restab, "x", exact = TRUE)[[1]]
Xext <- attr(cg, "Xext", exact = TRUE)
strata <- input$svar
strata.var <- factor(Xext[,strata])
global.subset <- attr(cg, "subset")
if (!is.null(global.subset))
global.subset <- paste0(" & (",global.subset,")")
else
global.subset <- ""
x.list <- lapply(levels(strata.var), function(i){
subset.i <- paste0("as.factor(",strata,")=='",i,"'",global.subset)
cg.i <- eval(parse(text=paste0("update(cg, subset=",subset.i,", simplify=FALSE)")))
x.i <- update(restab, x=cg.i)
x.i
})
strata.names <- levels(strata.var)
restab <- do.call(cbind, structure(x.list, names=strata.names))
}
})
# return
return(restab)
})
#########################
### create compareSNPs ##
#########################
createSNPs<-reactive({
if (input$snpsvarchange==0 & input$snpsgroupschange==0 & input$snpsoptionschange==0) return(invisible(NULL))
isolate({
withProgress(message = 'Creating SNPs table', value = 1, {
dd<-rv$dataset
validate(need(dd, "Data not loaded"))
validate(need(length(input$snpsselevars)>0, "No variables selected"))
if (is.null(input$snpsresptype) || input$snpsresptype=='None')
form<-as.formula(paste("~",paste(paste0("`",input$snpsselevars,"`"),collapse="+"),sep=""))
else
form<-as.formula(paste(input$snpsgvar,"~",paste(paste0("`",input$snpsselevars,"`"),collapse="+"),sep=""))
restabSNPs<-try(compareSNPs(form, dd, sep = input$sepSNPs), silent=TRUE)
incProgress(1, detail = "")
validate(need(restabSNPs, "Error: Some variables could not be converted to SNPs. Check the selected variables and the allele separator."))
return(restabSNPs)
})
})
})
####################
### values table ###
####################
## values summary
output$valuestable <- renderText({
dd<-rv$dataset
validate(need(dd, "Data not loaded"))
input$changemethod
input$changeselevarsok
input$maxvalues
input$htmlsizeinfotab
isolate({
validate(need(!is.null(rv$selevars) && length(rv$selevars)>0, "no variables selected"))
dd<-dd[,rv$selevars,drop=FALSE]
method<-rv$method[rv$selevars]
method<-ifelse(method==1,'Normal',ifelse(method==2,'Non-normal','Categorical'))
values<-n<-NULL
varnames.orig<-names(dd)
for (i in 1:ncol(dd)){
x.i<-dd[,i]
if (is.character(x.i)){
vari.label <- attr(x.i, "label", exact=TRUE)
x.i <- factor(x.i)
attr(x.i, "label") <- vari.label
}
n<-c(n,sum(!is.na(x.i)))
if (is.factor(x.i)){
if (nlevels(x.i)>input$maxvalues){
vv<-paste("'",levels(x.i),"'",sep="")
cc<-1:nlevels(x.i)
vv<-c(paste("-",vv[1:(input$maxvalues-1)],sep=""),"...",paste("-",vv[length(vv)],sep=""))
cc<-c(cc[1:(input$maxvalues-1)],"",cc[length(cc)])
values<-c(values,paste(paste(cc,vv,sep=""),collapse="<br/> "))
}else
values<-c(values,paste(paste(1:nlevels(x.i),paste("'",levels(x.i),"'",sep=""),sep="-"),collapse="<br/> "))
} else{
if (all(is.na(x.i)))
values<-c(values,"-")
else
values<-c(values,paste(compareGroups:::format2(range(x.i,na.rm=TRUE)),collapse="; "))
}
}
vari.labels <- sapply(dd,function(dd.i) if (is.null(attr(dd.i, "label", exact=TRUE))) "" else attr(dd.i, "label", exact=TRUE))
ans<-data.frame("Name"=varnames.orig,"Label"=vari.labels,"Method"=sub("continuous ","",method),"N"=n,"Values"=values)
nrows <- nrow(ans)
ans <- kable(ans, format="html", row.names=FALSE, escape=FALSE)
ans <- kableExtra::kable_styling(ans,position="left",font_size=input$htmlsizeinfotab, bootstrap_options = c("condensed","striped","bordered"),full_width = FALSE)
ans <- kableExtra::row_spec(ans, 0, background=grey(0.3),color="white")
# ans <- kableExtra::row_spec(ans, 1:nrows,extra_css = "border-bottom:1px solid black;border-top:1px solid black")
ans <- kableExtra::row_spec(ans, which((1:nrows)%%2==0), background=grey(0.85))
})
return(ans)
})
## values extended
output$valuesext <- DT::renderDataTable({
# dd <- rv$datasetorigfiltered
dd <- rv$datasetorig
if (NROW(dd)==0) return(invisible(NULL))
validate(need(dd, "Data not loaded"))
withProgress(message="Displaying data table", min=0, max=1, {
which.Surv <- sapply(dd, is.Surv)
if (any(which.Surv)){
dataAlertContent <- paste("Variables",paste(names(dd)[which.Surv], collapse=","),"not shown since they are of class survival")
closeAlert(session, "dataAlertMessage")
createAlert(session, "dataAlert", "dataAlertMessage", title="", content=dataAlertContent, append = FALSE, style="warning")
dd <- dd[!which.Surv]
}
nn <- names(dd)
ll <- sapply(seq_along(nn), function(i){
if (!is.null(attr(dd[,i],"label", exact=TRUE)))
return(attr(dd[,i],"label", exact=TRUE))
else
return(nn[i])
})
nn <- names(dd)
if (length(rv$recodedvars)>0 && any(rv$recodedvars%in%nn))
nn[nn%in%rv$recodedvars] <- paste0("<format style='color:red'>",nn[nn%in%rv$recodedvars],"</format>")
if (!is.null(input$showlabels) && input$showlabels){
if (!identical(ll,names(dd))) nn <- paste0(nn,"<format style='color:grey;font-size:75%'><br><i>",ll,"</i></format>")
}
ans <- DT::datatable(dd,
escape=FALSE,
filter = "top",
rownames= FALSE,
colnames=nn,
extensions = list("ColReorder" = NULL,
"Buttons" = NULL,
"FixedColumns" = list(leftColumns=1)),
options = list(
initComplete = JS(
"function(settings, json) {",
paste0("$(this.api().table().header()).css({'font-size': '",input$valueextsize,"%'});"),
"}"),
# language = list(url = '//cdn.datatables.net/plug-ins/1.10.11/i18n/Catalan.json'),
scrollX = TRUE,
dom = 'BRrltpi',
autoWidth=TRUE,
lengthMenu = list(c(10, 50, -1), c('10', '50', 'All')),
ColReorder = TRUE,
buttons =
list(
# 'copy',
# 'print',
list(
extend = 'collection',
buttons = c('csv', 'excel', 'pdf'),
text = 'Download'
),
I('colvis')
)
))
ans <- formatStyle(ans,columns=0:ncol(dd),`font-size`=paste0(input$valueextsize,"%"))
incProgress(amount=1)
ans
})
})
output$valuesextui <- renderUI({
valueextwidth <- if (is.null(input$valueextwidth)) "100%" else paste0(input$valueextwidth,"%")
DT::dataTableOutput("valuesext", width=valueextwidth)
})
output$typeout <- renderUI({
if (!rv$initial) return(invisible(NULL))
return(
div(
uiOutput("selemethod"),
uiOutput("selemethodNA")
)
)
})
############################
##### html createTable #####
############################
output$htmltab <- renderText({
restab<-create()
if (is.null(restab))
return(invisible(NULL))
input$changeLabels
isolate({
captionlabel<-input$captionlabel
if (!is.null(captionlabel) && captionlabel=='NULL')
captionlabel<-NULL
header.labels<-c('all'=input$alllabel,'p.overall'=input$poveralllabel,'p.trend'=input$ptrendlabel,'p.ratio'=input$pratiolabel,'N'=input$Nlabel)
})
position <- if (is.null(input$position)) "center" else input$position
withProgress(message = 'Visualizing the table', value=0, {
ans <- export2md(restab,header.labels=header.labels,caption=captionlabel, format="html",
width=paste0(input$htmlwidthrestab,"cm"),header.color=input$header.color,header.background=input$header.background,
size=input$htmlsizerestab,background=input$strip.color,strip=input$strip,first.strip=TRUE,position=position)
incProgress(1, detail="")
ans
})
})
############################
##### print compareSNPs ####
############################
output$restabSNPs <- renderPrint({
createSNPs()
})
##############################
##### summary createTable ####
##############################
output$sumtab <- renderText({
progress <- shiny::Progress$new(session, min=1, max=3)
progress$set(message = "Creating info table",value=0)
on.exit(progress$close())
restab<-create()
if (is.null(restab))
return(invisible(NULL))
export2md(restab, format="html", which.table="avail",width=paste0(input$htmlwidthrestab,"cm"),header.color=input$header.color,
header.background=input$header.background,size=input$htmlsizerestab)
})
##############################
##### varinfo ####
##############################
output$varinfotab <- renderTable({
progress <- shiny::Progress$new(session, min=1, max=3)
progress$set(message = "Creating var info table",value=0)
on.exit(progress$close())
restab<-create()
if (is.null(restab))
return(invisible(NULL))
if (inherits(restab, "cbind.createTable")) # stratified table
ans <- varinfo(restab[[1]])[[1]]
else
ans <- varinfo(restab)[[1]]
colnames(ans) <- c("Name", "Label")
ans
})
##########################################
##### select variables to be analyzed ####
##########################################
# when data is loaded update selevars to all variables
observe({
if (NROW(rv$dataset)==0)
return(NULL)
dd<-rv$dataset
nn<-names(dd)
updateSelectInput(session, "selevars", choices=nn, selected=input$selevars)
updateSelectInput(session, "plotselevars", choices=nn, selected=input$plotselevars)
updateSelectInput(session, "snpsselevars", choices=nn, selected=input$snpsselevars)
})
observeEvent(input$selevarsAll,{
dd<-rv$dataset
nn<-names(dd)
updateSelectInput(session, "selevars", selected=nn)
})
observeEvent(input$selevarsNone,{
updateSelectInput(session, "selevars", selected=".xxx")
})
observeEvent(input$snpsselevarsAll,{
dd<-rv$dataset
nn<-names(dd)
updateSelectInput(session, "snpsselevars", selected=nn)
})
observeEvent(input$snpsselevarsNone,{
updateSelectInput(session, "snpsselevars", selected=".xxx")
})
################################
##### select strata variable ###
################################
observe({
dd <- rv$dataset
if (NROW(dd)==0) return(NULL)
ww <- sapply(dd, function(x) length(unique(na.omit(x)))<=input$maxstrata)
vlist <- names(ww)[ww]
updateSelectInput(session, "svar", choices=vlist, selected=input$svar)
})
################################
##### select group variable ####
################################
observe({
dd <- rv$dataset
if (NROW(dd)==0) return(NULL)
ww <- sapply(dd, function(x) length(unique(na.omit(x)))<=input$maxgroups)
vlist <- names(ww)[ww]
updateSelectInput(session, "gvar", choices=vlist, selected=input$gvar)
})
observeEvent(input$gvar, {
dd <- rv$dataset
if (NROW(dd)==0) return(NULL)
var <- dd[,input$gvar]
if (length(unique(na.omit(var)))==2){
shinyjs::show("computeratio")
shinyjs::show("ResponseVariableORPanelBtn")
shinyjs::show("ResponseVariableORPanel")
updateCheckboxInput(session, "computeratio", value=TRUE)
} else {
shinyjs::hide("computeratio")
shinyjs::hide("ResponseVariableORPanelBtn")
shinyjs::hide("ResponseVariableORPanel")
updateCheckboxInput(session, "computeratio", value=FALSE)
}
})
# select category for OR reference (only when two categories).
output$vargroupcat <- renderUI({
dd<-rv$dataset
if (is.null(dd)){
return(invisible(NULL))
}
if (is.null(input$gvar))
return(invisible(NULL))
vv<-dd[,input$gvar]
if (nlevels(vv)!=2)
return(NULL)
vlist<-paste(1:nlevels(vv),levels(vv),sep=":")
names(vlist)<-vlist
conditionalPanel(
condition = "input.computeratio == true",
selectInput("gvarcat", "OR ref. cat:", choices = vlist, selectize=FALSE)
)
})
observe({
dd<-rv$dataset
if (NROW(dd)==0){
return(invisible(NULL))
}
if (length(input$gvar)==0 || input$gvar=='')
return(invisible(NULL))
vv<-as.factor(dd[,input$gvar])
if (nlevels(vv)!=2)
return(NULL)
vlist<-1:nlevels(vv)
names(vlist) <- levels(vv)
updateSelectInput(session, "gvarcat", choices=vlist)
})
observeEvent(input$ResponseVariableORPanelBtn,{
shinyjs::toggle("ResponseVariableORPanel", anim=TRUE)
})
########################
##### select method ####
########################
observeEvent(rv$selevars,{
updatePickerInput(session, "varselemethod", choices=rv$selevars, selected = input$varselemethod)
})
# when table is not created (no variables selected or whatever, hide some panels)
observe({
if (is.null(create())){
shinyjs::hide("TypePanel")
shinyjs::hide("HidePanel")
shinyjs::hide("SubsetPanel")
shinyjs::hide("ShowPanel")
shinyjs::hide("RatioPanel")
shinyjs::hide("FormatPanel")
shinyjs::hide("DecimalsPanel")
}else{
shinyjs::show("TypePanel")
shinyjs::show("HidePanel")
shinyjs::show("SubsetPanel")
shinyjs::show("ShowPanel")
shinyjs::show("RatioPanel")
shinyjs::show("FormatPanel")
shinyjs::show("DecimalsPanel")
}
})
####################################
##### select descriptive digits ####
####################################
observe({
updatePickerInput(session, "varseledescdigits", choices=rv$selevars, selected=input$varseledescdigits)
})
##############################
##### select ratio digits ####
##############################
observe({
updatePickerInput(session, "varseleratiodigits", choices=rv$selevars, selected=input$varseleratiodigits)
})
##########################
##### variable subset ####
##########################
observe({
updatePickerInput(session, "varselevarsubset", choices=rv$selevars, selected=input$varselevarsubset)
})
observeEvent(input$removechangevarsubset,{
updateTextAreaInput(session,"varsubset",value="")
})
###############################################################
##### select reference category in OR/HR for row-variables ####
###############################################################
observe({
dd<-rv$dataset
if (NROW(dd)==0) return(NULL)
if (is.null(rv$selevars) || length(rv$selevars)==0) return(NULL)
input$changemethod
method<-rv$method
res<-compareGroups(~.,max.xlev=Inf,max.ylev=Inf,dd,method=method,min.dis=if (is.null(input$mindis)) 5 else input$mindis,alpha=if (is.null(input$alpha)) 0.05 else input$alpha)
method.temp<-sapply(res,function(x) paste(attr(x,"method"),collapse=" "))
method.temp<-ifelse(method.temp=="continuous normal", 1, ifelse(method.temp=="continuous non-normal", 2, 3))
names(method.temp)<-attr(res,"varnames.orig")
vlist<-names(method.temp)
vlist<-vlist[method.temp==3]
names(vlist)<-vlist
vlist<-intersect(vlist,rv$selevars)
if (length(vlist)==0) return(invisible(NULL))
updateSelectInput(session, "varselerefratio", choices = vlist, selected=input$varselerefratio)
})
observe({
dd<-rv$dataset
if (NROW(dd)==0) return(invisible(NULL))
if (is.null(rv$selevars) || length(rv$selevars)==0) return(invisible(NULL))
if (is.null(input$varselerefratio) || input$varselerefratio=="No categorical variables") return(invisible(NULL))
vv<-as.factor(dd[,input$varselerefratio])
vlist<-1:nlevels(vv)
names(vlist)<-paste(vlist,levels(vv),sep=":")
updateSelectInput(session, "refratiocat", choices=vlist, selected=input$refratiocat)
})
#########################################
##### select factor to compute OR/HR ####
#########################################
observe({
updatePickerInput(session, "varselefactratio", choices=rv$selevars, selected=input$varselefactratio)
})
#################################
##### select hide category ######
#################################
observe({
dd<-rv$dataset
if (NROW(dd)==0) return(invisible(NULL))
input$changemethod
if (is.null(rv$selevars) || length(rv$selevars)==0) return(NULL)
method<-rv$method
res<-compareGroups(~.,max.xlev=Inf,max.ylev=Inf,dd,method=method,min.dis=if (is.null(input$mindis)) 5 else input$mindis,alpha=if (is.null(input$alpha)) 0.05 else input$alpha)
method.temp<-sapply(res,function(x) paste(attr(x,"method"),collapse=" "))
method.temp<-ifelse(method.temp=="continuous normal",1, ifelse(method.temp=="continuous non-normal", 2, 3))
names(method.temp)<-attr(res,"varnames.orig")
vlist<-names(method.temp)
vlist<-vlist[method.temp==3]
names(vlist)<-vlist
vlist<-intersect(vlist,rv$selevars)
if (length(vlist)==0) return(invisible(NULL))
updateSelectInput(session, "varselehide", choices = vlist, selected=input$varselehide)
})
observe({
dd<-rv$dataset
if (NROW(dd)==0) return(invisible(NULL))
if (is.null(rv$selevars) || length(rv$selevars)==0) return(invisible(NULL))
if (is.null(input$varselehide)) return(invisible(NULL))
vv<-as.factor(dd[,input$varselehide])
vlist<-c(NA,1:nlevels(vv))
names(vlist)<-paste(vlist,c("<<None>>",levels(vv)),sep=":")
updateSelectInput(session, "hidecat", choices=vlist, selected=input$hidecat)
})
#################################
##### select time variable ######
#################################
observe({
dd <- rv$dataset
if (NROW(dd)==0) return(NULL)
ww <- sapply(dd, is.numeric)
if (!any(ww)) return(NULL)
vlist <- names(dd)[ww]
updateSelectInput(session, "varseletime", choices=vlist, selected=input$varseletime)
})
#################################
##### select status variable ####
#################################
observe({
dd <- rv$dataset
if (NROW(dd)==0) return(NULL)
ww1 <- sapply(dd, function(x) is.numeric(x) && length(unique(na.omit(x)))<=10) # maxim 10 valors diferents
ww2 <- sapply(dd, function(x) is.factor(x) || is.character(x))
ww <- ww1 | ww2
if (!any(ww)) return(NULL)
vlist <- names(dd)[ww]
updateSelectInput(session, "varselestatus", choices=vlist, selected=input$varselestatus) #vlist[1])
})
######################################
##### select death category/ies ######
######################################
observe({
dd <- rv$dataset
if (NROW(dd)==0) return(NULL)
if (is.na(input$varselestatus) || length(input$varselestatus)==0 || input$varselestatus=="") return(NULL)
if (!input$varselestatus%in%names(dd)) return(NULL)
var <- dd[,input$varselestatus]
if (!is.factor(var)) var <- factor(var)
vlist <- levels(var)
updateSelectInput(session, "statuscat", choices=vlist, selected=input$statuscat)
})
######################################
####### show #########################
######################################
# if show.ratio compute OR
observeEvent(input$showratio,{
if (input$showratio){
updateCheckboxInput(session, "computeratio", value=TRUE)
}
})
########################
##### labels ###########
########################
observeEvent(input$refreshLabels,{
updateTextInput(session, "alllabel", value="[ALL]")
updateTextInput(session, "poveralllabel", value="p.overall")
updateTextInput(session, "ptrendlabel", value="p.trend")
updateTextInput(session, "pratiolabel", value="p.ratio")
updateTextInput(session, "Nlabel", value="N")
updateTextInput(session, "captionlabel", value="NULL")
})
########################
####### values #########
########################
output$values <- renderUI({
validate(need(rv$initial, "Data not loaded"))
div(
dropdownButton(inputId="valuessumoptionsaction",label="View options",circle=FALSE,status="info",
div(id="valuessumoptions",
fluidRow(
column(4,numericInput("maxvalues", "Maximum number of categories to display:", min=3, max=100, value=10, step=1)),
column(8,sliderInput("htmlsizeinfotab", "Resize", min=4, max=30, value=16))
)
)
),
br(),
htmlOutput('valuestable')
)
})
########################
####### table ##########
########################
output$table <- renderUI({
validate(need(rv$initial, "Data not loaded"))
htmlOutput('htmltab')
})
########################
###### plot ############
########################
##### select response #############
observe({
dd <- rv$dataset
if (NROW(dd)==0) return(NULL)
ww <- sapply(dd, function(x) length(unique(na.omit(x)))<=input$plotmaxgroups)
vlist <- names(ww)[ww]
updateSelectInput(session, "plotgvar", choices=vlist)
})
observe({
dd <- rv$dataset
if (NROW(dd)==0) return(NULL)
ww <- sapply(dd, is.numeric)
if (!any(ww)) return(NULL)
vlist <- names(dd)[ww]
updateSelectInput(session, "plotvarseletime", choices=vlist)
})
observe({
dd <- rv$dataset
if (NROW(dd)==0) return(NULL)
ww1 <- sapply(dd, function(x) is.numeric(x) && length(unique(na.omit(x)))<=10)
ww2 <- sapply(dd, function(x) is.factor(x) || is.character(x))
ww <- ww1 | ww2
if (!any(ww)) return(NULL)
vlist <- names(dd)[ww]
updateSelectInput(session, "plotvarselestatus", choices=vlist, selected=vlist[1])
})
observe({
dd <- rv$dataset
if (NROW(dd)==0) return(NULL)
if (is.na(input$plotvarselestatus) || length(input$plotvarselestatus)==0 || input$plotvarselestatus=="") return(NULL)
if (!input$plotvarselestatus%in%names(dd)) return(NULL)
var <- dd[,input$plotvarselestatus]
if (!is.factor(var)) var <- factor(var)
vlist <- levels(var)
updateSelectInput(session, "plotstatuscat", choices=vlist)
})
observe({
dd <- rv$dataset
if (NROW(dd)==0) return(NULL)
vlist <- names(dd)
updateSelectInput(session, "plotselevars", choices=vlist)
})
########################
######## snps ##########
########################
observe({
dd <- rv$dataset
if (NROW(dd)==0) return(NULL)
ww <- sapply(dd, function(x) length(unique(na.omit(x)))<=input$snpsmaxgroups)
vlist <- names(ww)[ww]
updateSelectInput(session, "snpsgvar", choices=vlist, selected=input$snpsgvar)
})
########################
##### plot #############
########################
observe({
if (!is.null(input$collapseInput) && input$collapseInput=="collapseResponse"){
if (!is.null(input$ResponseTabsetPanel) && input$ResponseTabsetPanel=="Response"){
if (rv$changerespcount==0) return(NULL)
isolate({
if (!is.null(input$resptype) && input$resptype != 'None')
shinyjs::show("bivar")
else
shinyjs::hide("bivar")
})
}
}
})
observe({
ct <- create()
if (is.null(input$varPlot)) return(NULL)
if (is.null(ct)) return(NULL)
cg <- attr(ct,"x")[[1]]
mm <- lapply(cg, attr, which="method")
orig.names <- attr(cg, "varnames.orig")
categ <- sapply(mm, function(mm.i) "categorical"%in%mm.i)
categ.vars <- orig.names[categ]
if (input$varPlot%in%categ.vars)
shinyjs::show("perc")
else
shinyjs::hide("perc")
})
output$plot <- renderPlot({
rv$plotcreated <- FALSE
if (input$plotvarchange==0 & input$plotgroupschange==0) return(invisible(NULL))
input$udpateSelection
input$perc
isolate({
dd <- rv$dataset
validate(need(dd, "Data not loaded yet"))
validate(need(input$plotselevars, "Select one variable"))
perc<-if (is.null(input$perc)) FALSE else input$perc
if (!inherits(dd[,input$plotselevars],"factor"))
hide("perc")
else
show("perc")
if (!inherits(dd[,input$plotselevars],"Surv"))
updateRadioGroupButtons(session, "plotresptype", choices=c("None","Group","Survival"))
else
updateRadioGroupButtons(session, "plotresptype", choices=c("None","Group"))
withProgress(message = 'Making plot', value = 0, {
if (is.null(input$plotresptype) || input$plotresptype=='None')
form <- paste0("~",input$plotselevars)
if (!is.null(input$plotresptype) && input$plotresptype=='Group')
form <- paste0(input$plotgvar,"~",input$plotselevars)
if (!is.null(input$plotresptype) && input$plotresptype=='Survival'){
times<-dd[,input$plotvarseletime]
validate(need(length(input$plotstatuscat)>=1, "you must select at least one category"))
cens <- as.integer(dd[,input$plotvarselestatus]%in%input$plotstatuscat)
dd$"respsurv"<-Surv(times,cens)
form <- paste0("respsurv ~ ",input$plotselevars)
}
if (!is.Surv(dd[,input$plotselevars]) & is.numeric(dd[,input$plotselevars])){
if (length(unique(dd[,input$plotselevars]))<5) showModal(modalDialog("Variable contains less than 5 unique values.\nConsider to convert it to factor"))
validate(need(length(unique(dd[,input$plotselevars]))>=5, ""))
}
cg <- compareGroups(as.formula(form), dd)
print(cg)
plot(cg,bivar=TRUE,perc=perc)
# shinyjs::show("downPlotOptionsPanel")
incProgress(1,detail="")
})
rv$plotcreated <- TRUE
if (!is.Surv(dd[,input$plotselevars]) & is.numeric(dd[,input$plotselevars]) & length(unique(dd[,input$plotselevars]))<5) rv$plotcreated <- FALSE
})
})
####################################
############ HELP ################
####################################
# output$helpload<-renderUI(HTML(hlp['LOAD']))
# output$helpselect<-renderUI(HTML(hlp['SELECT']))
# output$helptype<-renderUI(HTML(hlp['Type']))
# output$helpresponse<-renderUI(HTML(hlp['Response']))
# output$helpstratas<-renderUI(HTML(hlp['Stratas']))
# output$helphide<-renderUI(HTML(hlp['Hide']))
# output$helpsubset<-renderUI(HTML(hlp['Subset']))
# output$helpratio<-renderUI(HTML(hlp['OR/HR']))
# output$helpshow<-renderUI(HTML(hlp['Show']))
# output$helpformat<-renderUI(HTML(hlp['Format']))
# output$helpdecimals<-renderUI(HTML(hlp['Decimals']))
# output$helplabel<-renderUI(HTML(hlp['Label']))
# output$helpsave<-renderUI(HTML(hlp['SAVE']))
# output$helpabout<-renderUI(HTML(hlp['HELPCG']))
# output$helpwui<-renderUI(HTML(hlp['HELPWUI']))
# output$helpsecurity<-renderUI(HTML(hlp['DATASECURITY']))
# output$helpsummary<-renderUI(HTML(hlp['SUMMARY']))
# output$helpvalues<-renderUI(HTML(hlp['VALUES']))
# output$helptable<-renderUI(HTML(hlp['TABLE']))
# output$helpplot<-renderUI(HTML(hlp['PLOT']))
# output$helpsnps<-renderUI(HTML(hlp['SNPs']))
####################################
##### DOWNLOAD RESULTS #############
####################################
####### table #########
output$actiondownloadtable <- downloadHandler(
filename = function(){
extension <- ifelse(input$downloadtabletype=="Word","docx",tolower(input$downloadtabletype))
extension <- ifelse(input$downloadtabletype=="Excel","xlsx",extension)
paste("tableOuput",extension,sep=".")
},
content = function(ff) {
input$changeLabels
isolate({
header.labels<-c("all"=input$alllabel,"p.overall"=input$poveralllabel,"p.trend"=input$ptrendlabel,"p.ratio"=input$pratiolabel,"N"=input$Nlabel)
captionlabel<-input$captionlabel
if (!is.null(captionlabel) && captionlabel=='NULL')
captionlabel<-NULL
})
withProgress(message = 'Downloading descriptive table', value = 0, {
restab<-create()
if (is.null(restab)) return(invisible(NULL))
if (input$downloadtabletype=='CSV'){
if (inherits(restab,"cbind.createTable")) return(NULL)
export2csv(restab,file=ff,sep=input$sepcsv,header.labels=header.labels)
}
if (input$downloadtabletype=='PDF'){
sizepdf <- switch(input$sizepdf,
"tiny" = 6,
"scriptsize" = 8,
"footnotesize" = 10,
"small" = 10.95,
"normalsize" = 12,
"large" = 14.4,
"Large" = 17.28,
"LARGE" = 20.74,
"huge" = 24.88,
"Huge" = 24.88)
export2pdf(restab,file=ff, size=sizepdf, landscape=input$landscape, header.labels=header.labels, caption=captionlabel,
width=paste0(input$htmlwidthrestab,'cm'), strip=input$strip, first.strip=TRUE, background=input$strip.color,
header.color=input$header.color,header.background=input$header.background)
}
if (input$downloadtabletype=='HTML'){
ans <- export2md(restab,format='html',header.labels=header.labels,caption=captionlabel,
width=paste0(input$htmlwidthrestab,'cm'),header.color=input$header.color,header.background=input$header.background,
size=input$htmlsizerestab,background=input$strip.color,strip=input$strip,first.strip=TRUE)
write(ans, file=ff)
}
if (input$downloadtabletype=='TXT'){
sink(ff)
print(restab,header.labels=header.labels)
sink()
}
if (input$downloadtabletype=='Word'){
export2word(restab, file=ff, header.labels=header.labels,caption=captionlabel,
header.color=input$header.color,header.background=input$header.background,
size=input$htmlsizerestab,background=input$strip.color,strip=input$strip,first.strip=TRUE)
}
if (input$downloadtabletype=='Excel'){
if (inherits(restab,"cbind.createTable")) return(NULL)
export2xls(restab, file=ff,header.labels=header.labels)
}
incProgress(1, detail = "")
})
}
)
observe({
if (is.null(input$downloadtabletype)) return(NULL)
rv$changestratacount
isolate({
if (!is.null(input$stratatype) && input$stratatype!='None' && input$downloadtabletype%in%c('Excel','CSV')){
createAlert(session, "downloadtablealert", "downloadtablealertMessage", title = "Warning:",
content = "Stratified tables cannot be downloaded under the specified format", append = FALSE, style = "warning")
shinyjs::disable("actiondownloadtable")
} else {
closeAlert(session, "downloadtablealertMessage")
shinyjs::enable("actiondownloadtable")
}
})
})
####### SNPs table #########
output$actiondownloadSNPtable <- downloadHandler(
filename = function() "tableSNPOuput.txt",
content = function(ff) {
restabSNPs<-createSNPs()
if (is.null(restabSNPs))
return(invisible(NULL))
sink(ff)
print(restabSNPs)
sink()
}
)
output$actiondownloadplot <- downloadHandler(
filename = function() paste("figure",tolower(input$downloadplottype),sep="."),
content = function(ff) {
ext<-input$downloadplottype
dd <- rv$dataset
validate(need(dd, "Data not loaded yet"))
validate(need(input$plotselevars, "Select one variable"))
perc<-if (is.null(input$perc)) FALSE else input$perc
withProgress(message = 'Making plot', value = 0, {
if (is.null(input$plotresptype) || input$plotresptype=='None')
form <- paste0("~",input$plotselevars)
if (!is.null(input$plotresptype) && input$plotresptype=='Group')
form <- paste0(input$plotgvar,"~",input$plotselevars)
if (!is.null(input$plotresptype) && input$plotresptype=='Survival'){
times<-dd[,input$plotvarseletime]
validate(need(length(input$plotstatuscat)>=1, "you must select at least one category"))
cens <- as.integer(dd[,input$plotvarselestatus]%in%input$plotstatuscat)
dd$"respsurv"<-Surv(times,cens)
form <- paste0("respsurv ~ ",input$plotselevars)
}
cg <- compareGroups(form, dd)
plot(cg,type=ext,file="./www/figure_",bivar=TRUE,perc=perc)
file.rename(paste0("./www/figure_",input$plotselevars,".",ext),ff)
incProgress(1,detail="")
})
}
)
}
# setwd(wd)
####### TO DO ##########
# Refresh app when changing dataset !!!! (gvar....)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.