Nothing
server <- function(input, output, session) {
# output$sidebarAspect <- renderUI({
# tags$style(HTML(paste0(".main-sidebar{width: ", input$sidebarwidth,"%;}")))
# })
# register entrance and exit time entries
observe({
dd <- data.frame(id=session$token, start=as.character(Sys.time()),end=NA,app="compareGroups") # canviar a compareGroups/compareGroups_datarus segons si es fa el deploy a regicor o isubirana
googlesheets4::sheet_append(sheet_id, dd)
})
onStop(
function(){
dd <- data.frame(id=session$token, start=NA,end=as.character(Sys.time()),app="compareGroups") # canviar a compareGroups/compareGroups_datarus segons si es fa el deploy a regicor o isubirana
#print(dd)
googlesheets4::sheet_append(sheet_id, dd)
#print("xxxx")
}
)
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") | input$plotresptype=='Survival')
hide("perc")
else
show("perc")
if (!inherits(dd[,input$plotselevars],"Surv"))
updateRadioGroupButtons(session, "plotresptype", choices=c("None","Group","Survival"),selected=input$plotresptype) #@@
else
updateRadioGroupButtons(session, "plotresptype", choices=c("None","Group"),selected=input$plotresptype) #@@
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....)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.