inst/app.R
In kismet303/lopo3000: LoPo 3000 Experimental package using RShiny for interactive LoPo
# Temp copy of origanl app.R for reference
## app.R ##
library(tidyverse)
.libPaths(c(normalizePath("./libs"), .libPaths()))
library(tern)
library(shiny)
library(shinyjs)
library(shinydashboard)
library(readxl)
library(shinyWidgets)
library(DT)
library(haven)
library(shinyBS)
library(dplyr)
library(jsonlite)
library(DBI)
global_path<<-"/opt/bee_tools/shiny/3.5.3/users/remusatp/Global/"
main_path<<-"/opt/bee_tools/shiny/3.5.3/users/remusatp/lopo3000/"
functionPath<<-paste0(main_path,"functions/")
#study<<-"YO39609"
#study<<-"WO39392"
study<<-"BP40657"
status<<-"Interim 1"
server_<-"BEE"
userff <- Sys.info()["user"]
source("functions/callB_func.R")
source("functions/execute_R_prog.R")
source("functions/filters.R")
options(shiny.sanitize.errors = TRUE)
########get study list#################
con_1 <- dbConnect(RSQLite::SQLite(), paste0(global_path,"userDB"))
getStudy_list <- function() {
res <- dbSendQuery(con_1, "SELECT * FROM UserDB where user ='remusatp' ")
study_list <- dbFetch(res)
dbClearResult(res)
return(study_list)
}
#####################################
######################################## UI PART ###########################################
############################################################################################
ui <- dashboardPage(
dashboardHeader(title = paste0(study,"(",status,")") ),
## Sidebar content
dashboardSidebar(
sidebarMenu(
menuItem("Home", tabName = "Home", icon = icon("dashboard")),
menuItem("Overview",tabName = "OVERVIEW", icon = icon("th")) ,
menuItem("LOPO", tabName = "LOPO", icon = icon("th"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "Home",
h2("Study Description") ,p(userff),
p(textOutput("description")),
h2("Path in BEE") ,
p(textOutput("study_path"))
),
tabItem(tabName = "OVERVIEW",
h1(paste0("Overview of Lopo for study ",study, "(",status,")") ) ,
valueBox( textOutput("num_of_table"), "Tables", icon = icon("list"), color = "aqua", width = 3,
href = NULL),
valueBox( textOutput("num_of_figure"), " Figures", icon = icon("chart-bar"), color = "aqua", width = 3,
href = NULL),
valueBox( textOutput("num_of_listing"), " Listings", icon = icon("align-justify"), color = "aqua", width = 3,
href = NULL),
valueBox("12", "ADAMs", icon = icon("plus-square"), color = "aqua", width = 3,
href = NULL)
) ,
tabItem(tabName = "LOPO",
## h1(study) ,
div(style="display: inline-block;vertical-align:top; width: 300px;",
awesomeCheckboxGroup(
inputId = "OutType",
label = "Type of Output",
choices = c("Table", "Listing", "Figure"),
inline = TRUE,
status = "danger"
)),
div(style="display: inline-block;vertical-align:top; width: 330px;",
pickerInput(
inputId = "DomainC",
label = "Select Domain",
choices = c( "AE", "Exposure", "Disposition", "Demography", "Deaths", "Con Med") ,
multiple = TRUE,
# selected = "NULL",
choicesOpt = list(
content = sprintf("<span class='label label-%s'>%s</span>",
c("danger", "success", "warning", "info", "default","primary"),
c( "AE", "Exposure", "Disposition", "Demography","Deaths", "Con Med")))
)),
div(style="display: inline-block;vertical-align: center; width:100px;",
tags$br(),
actionBttn(
inputId = "tabFilt",
label = "Filter",
color = "primary",
style = "simple",
size= "sm",
icon = icon("sliders"),
block = TRUE
),
bsTooltip("tabFilt", "Edit Filters",
"top", options = list(container = "body")),
" ",
bsModal("modalFilter", "Filters", "tabFilt", size = "large",
dataTableOutput("filtTable"))
),
useShinyjs(),
extendShinyjs(text = js_code ),
dataTableOutput('myLopo3000') ,
conditionalPanel(condition = "output.lopoExist == 'NO' ",
p("Lopo template must follow the standard you can find here"),
sidebarLayout(
sidebarPanel(
df<-fileInput('file1', 'Choose xlsx file', accept = c(".xls"))
),
mainPanel(
tableOutput('contents')
)
) ) )) ) )
############################################################################################
###################################### SERVER PART #########################################
server <- function(input, output, session){
output$lopoExist <- renderText('NO')
observe({
query <- parseQueryString(session$clientData$url_search)
if (!is.null(query[['study']])) {
study <- query[['study']]
}
if (!is.null(query[['server']])) {
server_ <- query[['server']]
}
s_path<-paste0(main_path,"Studies/",study,"/",study)
########Study Information#########
study_list<-getStudy_list()
study_desc<-study_list[study_list[,"STUDY"]==study , 10]
studyy_path<-study_list[study_list[,"STUDY"]==study , 7]
output$description <- renderText( { study_desc } )
output$study_path <- renderText( { studyy_path } )
##################################
lopoPath <- paste0("Studies/",study,"/",study)
if (server_ == "BEE") {
# source("functions/datatable_R.R")
}
if (server_ == "Entimice") {
source("functions/datatable_SAS.R")
}
if (checkLopo(lopoPath)=="OK") {
myLopo <- getLopo(study,lopoPath)
num_of_table<- count(myLopo[myLopo['outType']=="Table",],)
num_of_figure<-count(myLopo[myLopo['outType']=="Figure",],)
num_of_listing<-count(myLopo[myLopo['outType']=="Listing",],)
output$num_of_table <- renderText({paste0(num_of_table, "")})
output$num_of_figure <- renderText({paste0(num_of_figure, "")})
output$num_of_listing <- renderText({ paste0(num_of_listing, "")})
print(num_of_table)
#-----------------------------------------------------------------------------
# Filter outputs list
#-----------------------------------------------------------------------------
col_list<-c('See', 'Action' , 'Domain', 'Titles', 'Footnotes', 'Filters', 'GDS Template', 'Program ID','outType','CRUD','idbis')
myLopotmp<-myLopo
myLopotmp$CRUD<-"Edit - Delete"
values <- reactiveValues(dfWorking = myLopotmp)
result <- shiny::reactiveValues()
result$thedata <- myLopotmp[,col_list]
result$view.cols <- names(myLopotmp[,col_list])
result$edit.cols <- names(myLopotmp[,col_list])
result$edit.label.cols <- result$edit.cols
edit.cols <- names(myLopotmp[,col_list])
edit.label.cols <- names(myLopotmp[,col_list])
####================================================================================================####
#### Display an Interactif LOPO ####
####================================================================================================####
output$myLopo3000 <- renderDataTable( {
##values$dfWorking
if ( is.null(input$DomainC) && is.null(input$OutType) ) {
values$dfWorking[,col_list] }
else if (is.null(input$DomainC)) {
values$dfWorking[,col_list] %>% filter(outType %in% c( input$OutType))
}
else if (is.null(input$OutType)) {
values$dfWorking[,col_list] %>% filter(Domain %in% c( input$DomainC))
}
else {
values$dfWorking[,col_list] %>% filter(Domain %in% c( input$DomainC) ) %>% filter(outType %in% c( input$OutType) )
}
},
options = list(
dom = 't',
initComplete = JS(
"function(settings, json) {",
"$(this.api().table().header()).css({'background-color': 'lightgrey', 'color': '#000', 'font-size': '10px' });",
"$(this.api().table().body()).css({ 'font-size': '12px', 'text-align': 'center' });",
"}"),
searchHighlight = TRUE,
columnDefs = list(
list(targets=2,
render = JS(paste0( "function(data, type, row, meta) {",
"if (data == 'AE') {",
"return '<small class=\"badge pull-center bg-red\">' + data + ' </small>' }",
"else if (data == 'Disposition') {",
"return '<small class=\"badge pull-center bg-yellow\">' + data + ' </small>' }",
"else if (data == 'Exposure') {",
"return '<small class=\"badge pull-center bg-green\">' + data + ' </small>' }",
"else if (data == 'Demography') {",
"return '<small class=\"badge pull-center bg-teal\">' + data + ' </small>' }",
"else if (data == 'Con Med') {",
"return '<small class=\"badge pull-center bg-blue\">' + data + ' </small>' }",
"else if (data == 'Death') {",
"return '<small class=\"badge pull-center bg-grey\">' + data + ' </small>' }",
"else {",
"return '<small class=\"badge pull-center bg-violet\">' + data + ' </small>' }",
"}"))),
list(targets=9,
render = JS(paste0( "function(data, type, row, meta) {",
"return '",
"<table>",
"<td align=\"center\"> <button id=\"button_'+ row[10] +'\" class=\"btn btn-primary btn-xs \" style=\"font-size:7px \" onclick=\"Shiny.onInputChange("edit_button", this.id + "_" + Math.random())\">Edit</button> </td>",
"<td align=\"center\"> <button id=\"buttonss_'+ row[10] +'\" class=\"btn btn-danger btn-xs\" style=\"font-size:7px \" onclick=\"Shiny.onInputChange("del_button", this.id + "_" + Math.random())\">Delete</button> </td>",
"</table>' }"
))),
list(targets=10,visible=FALSE),
list(targets=0,
render = JS(paste0( "function(data, type, row, meta) {",
"if (data == 'NA') {",
"return ' <i id=\"buttonss_'+ row[10] +'\" class=\"far fa-times-circle text-danger \" style=\"font-size:30px \" ></i>' }",
"else {",
"return ' <i id=\"buttonsst_'+ row[10] +'\" class=\"far fa-file-alt text-success \" style=\"font-size:30px \" onclick=\"Shiny.onInputChange("see_button", this.id + "_" + Math.random())\"></i> ' }",
"}"))),
list(targets=1,
render = JS(paste0( "function(data, type, row, meta) {",
"if (data == 'PROG_OK') {",
"return ' <i id=\"buttonbb_'+ row[10] +'\" class=\"fas fa-arrow-alt-circle-right text-success \" style=\"font-size:30px \" onclick=\"Shiny.onInputChange("run_button", this.id + "_" + Math.random() )\"></i> ' }",
"else {",
"return ' <i id=\"buttonbbt_'+ row[10] +'\" class=\"fas fa-arrow-circle-up text-danger \" style=\"font-size:30px \" onclick=\"Shiny.onInputChange("create_button", this.id + "_" + Math.random() )\"></i>' }",
"}"))),
list(targets = c(1,0),width = '20px'),
list(targets = c(3,4),width = '150px'),
list(targets = c(2, 5,6,7,8,9),width = '50px'),
list(targets = c(10),width = '10px'),
list(targets = c(4,5,3),
render = JS("function(data, type, row, meta) {",
"return type === 'display' && data.length > 50 && data ?",
"'<p align=\"left\"><span title=\"' + data + '\">' + data.substr(0, 50) + '...</span></p>' : '<p align=\"left\">' + data + '</p>' ;",
"}") )
),
scrollY = 600,
scroller = TRUE,
scrollX = T,
pageLength = 25
) ,
extensions = c('Buttons','Responsive'), server=TRUE, selection='single', rownames=FALSE)
####================================================================================================####
#### End of Display an Interactif LOPO ####
####================================================================================================####
#-----------------------------------------------------------------------------
# button functionalities
#-----------------------------------------------------------------------------
observeEvent(input$see_button, {
selectedRow <- as.numeric(strsplit(input$see_button, "_")[[1]][2])
outputid<-selectedRow
js$browseURL(paste0("https://shiny.roche.com/3.5.3/users/remusatp/output3000/?outputid=",outputid,"&study=",study,"&server=",server_))
} )
observeEvent(input$run_button, {
selectedRow <- as.numeric(strsplit(input$run_button, "_")[[1]][2])
print(selectedRow)
execute_R_prog(study,lopoPath,selectedRow)
})
observeEvent(input$seeb, {
outputid <- as.numeric(strsplit(input$seeb, "_")[[1]][2])
js$browseURL(paste0("https://shiny.roche.com/3.5.3/users/remusatp/output3000/?outputid=",outputid,"&study=",study,"&server=",server_))
})
####Create single program onclick
observeEvent(input$create_button, {
s_path<-paste0(main_path,"Studies/",study,"/",study)
selectedRow <- as.numeric(strsplit(input$create_button, "_")[[1]][2])
metaOutput<-getOutput(study,s_path,selectedRow)
create_R_program(paste0("Studies/",study,"/program/"),metaOutput$`Program ID`,"test")
##check_prog_exisit(paste0("Studies/",study,"/program/",metaOutput$`Program ID`))
##if prog exisit , update database
showModal(modalDialog(
title = "Program created",
"Program have been created",
easyClose = TRUE
))
myLopo<-getLopo(studyl,lopoPath)
js$reset()
})
# Updates goButton's label and icon
updateActionButton(session, "goButton",
label = "New label",
icon = icon("calendar"))
################General Button related to lopo#################
####################################################################
###Create Program related to lopo output############################
####################################################################
source("functions/createRprog.R")
vect_prog_name<-myLopo$`Program ID`
progPath<-paste0("Studies/",study,"/program/")
observeEvent(input$Create, {
create_all_R_program(progPath,vect_prog_name)
showModal(modalDialog(
title = "Job Done",
"Program have been created",
easyClose = TRUE
))
})
source("functions/template_meta_titles.R")
source("functions/template_meta_footnotes.R")
observeEvent(input$Export, {
createTitleFile(study,"PROJECT A",userff,"IMC")
createFootnoteFile(study,"PROJECT A",userff,"IMC")
showModal(modalDialog(
title = "Job Done",
"Titles and footnote have been exported",
easyClose = TRUE
))
})
####################################################################
#####################Check and Edit Filters#########################
####################################################################
filters_path <<- paste0(main_path,"Studies/",study,"/meta/FILTERS")
tab <- getFilters(filters_path)
output$filtTable <- renderDataTable({ tab
}, options = list( dom='t'), editable = TRUE )
# edit a single cell
proxy5 = dataTableProxy('filtTable')
observeEvent(input$filtTable_cell_edit, {
info = input$filtTable_cell_edit
str(info) # check what info looks like (a data frame of 3 columns)
tab <<- editData(tab, input$filtTable_cell_edit )
###update database
con <- dbConnect(RSQLite::SQLite(), paste0("Studies/",study,"/meta/FILTERS"))
dbWriteTable(con, "FILTERS", tab, overwrite=TRUE)
#dbBind(update, tab) # send the updated data
# dbClearResult(update) # release the prepared statement
dbDisconnect(con)
})
##############################################################################################################################################################################
##############################################################################################################################################################################
##############################################################################################################################################################################
##############################################################################################################################################################################
####================================================================================================####
#### CRUD Functionalities ####
####================================================================================================####
##====================================================================##
##==============================##DELETE##==============================##
##====================================================================##
source("functions/CRUD.R")
observeEvent(input$del_button, {
selectedIDBIS <- as.numeric(strsplit(input$del_button, "_")[[1]][2])
deleteModal(selectedIDBIS,result)
})
observeEvent(input$buttonClicked,{
if (!is.null(input$buttonClicked)) {
values$dfWorking <- values$dfWorking[ values$dfWorking[,"idbis"] != input$buttonClicked ,]
##REMOVE ROW FROM DATABASE (LOPO)
con <- dbConnect(RSQLite::SQLite(), paste0("Studies/",studyl,"/",studyl))
query <- paste0('DELETE FROM ',studyl,' WHERE rowid = ', input$buttonClicked)
dbSendQuery(con, query)
dbDisconnect(con)
shiny::removeModal()
}
})
##====================================================================##
##==============================##EDIT##==============================##
##====================================================================##
valid.input.types <- c('dateInput', 'selectInput', 'numericInput',
'textInput', 'textAreaInput', 'passwordInput', 'selectInputMultiple')
inputTypes <- sapply(result$thedata[,edit.cols], FUN=function(x) {
switch(class(x),
list = 'selectInputMultiple',
character = 'textInput',
Date = 'dateInput',
factor = 'selectInput',
integer = 'numericInput',
numeric = 'numericInput')
})
input.types = c(Footnotes ='textAreaInput',Titles ='textAreaInput')
if(!missing(input.types)) {
if(!all(names(input.types) %in% edit.cols)) {
stop('input.types column not a valid editting column: ',
paste0(names(input.types)[!names(input.types) %in% edit.cols]))
}
if(!all(input.types %in% valid.input.types)) {
stop(paste0('input.types must only contain values of: ',
paste0(valid.input.types, collapse = ', ')))
}
inputTypes[names(input.types)] <- input.types
}
# Convert any list columns to characters before displaying
for(i in 1:ncol(result$thedata)) {
if(nrow(result$thedata) == 0) {
result$thedata[,i] <- character()
} else if(is.list(result$thedata[,i])) {
result$thedata[,i] <- sapply(result$thedata[,i], FUN = function(x) { paste0(x, collapse = ', ') })
}
}
getFields <- function(typeName, valuestmp ) {
fields <- list()
for(i in seq_along(edit.cols)) {
if(inputTypes[i] == 'dateInput') {
value <- ifelse(missing( valuestmp),
as.character(Sys.Date()),
as.character( valuestmp[,edit.cols[i]]))
fields[[i]] <- dateInput(paste0("myLopo", typeName, edit.cols[i]),
label=edit.label.cols[i],
value=value,
width=date.width)
} else if(inputTypes[i] == 'selectInputMultiple') {
value <- ifelse(missing( valuestmp), '', valuestmp[,edit.cols[i]])
if(is.list(value)) {
value <- value[[1]]
}
choices <- ''
if(!missing( valuestmp)) {
choices <- unique(unlist( valuestmp[,edit.cols[i]]))
}
if(!is.null(input.choices)) {
if(edit.cols[i] %in% names(input.choices)) {
choices <- input.choices[[edit.cols[i]]]
}
}
if(length(choices) == 1 & choices == '') {
warning(paste0('No choices available for ', edit.cols[i],
'. Specify them using the input.choices parameter'))
}
fields[[i]] <- selectInputMultiple(paste0("myLopo", typeName, edit.cols[i]),
label=edit.label.cols[i],
choices=choices,
selected=value,
width=select.width)
} else if(inputTypes[i] == 'selectInput') {
value <- ifelse(missing( valuestmp), '', as.character( valuestmp[,edit.cols[i]]))
fields[[i]] <- shiny::selectInput(paste0("myLopo", typeName, edit.cols[i]),
label=edit.label.cols[i],
choices=levels(result$thedata[,edit.cols[i]]),
selected=value,
width=select.width)
} else if(inputTypes[i] == 'numericInput') {
value <- ifelse(missing( valuestmp), 0, valuestmp[,edit.cols[i]])
fields[[i]] <- shiny::numericInput(paste0("myLopo", typeName, edit.cols[i]),
label=edit.label.cols[i],
value=value,
width=numeric.width)
} else if(inputTypes[i] == 'textAreaInput') {
value <- ifelse(missing( valuestmp), '', valuestmp[,edit.cols[i]])
fields[[i]] <- shiny::textAreaInput(paste0("myLopo", typeName, edit.cols[i]),
label=edit.label.cols[i],
value=value,
width=textarea.width, height=textarea.height)
} else if(inputTypes[i] == 'textInput') {
value <- ifelse(missing( valuestmp), '', valuestmp[,edit.cols[i]])
fields[[i]] <- shiny::textInput(paste0("myLopo", typeName, edit.cols[i]),
label=edit.label.cols[i],
value=value,
width=text.width)
} else if(inputTypes[i] == 'passwordInput') {
value <- ifelse(missing( valuestmp), '', valuestmp[,edit.cols[i]])
fields[[i]] <- shiny::passwordInput(paste0("myLopo", typeName, edit.cols[i]),
label=edit.label.cols[i],
value=value,
width=text.width)
} else {
stop('Invalid input type!')
}
}
return(fields)
}
#####EDit a line of LOPO#######
###1 Click on EDit button on a line
observeEvent(input$edit_button, {
input.types <- c(Footnotes ='textAreaInput',Titles ='textAreaInput')
selectedIDBIS <- as.numeric(strsplit(input$edit_button, "_")[[1]][2])
print(input$edit_button)
editModal(selectedIDBIS)
})
###2 Display a Modal to update(edit) the line of the LOPO
editModal <- function(selectedRow ) {
jscode_edit <- paste0( '
$("#lopo_update").on("click", function(){
Shiny.onInputChange("editClicked",', selectedRow , '+ "_" + Math.random()',');
})
')
#output[['myoutput_message']] <- renderText('')
fields <- getFields('_edit_', values=values$dfWorking[values$dfWorking[,"idbis"]==selectedRow,] )
showModal(modalDialog(title = "Edit",
shiny::div(shiny::textOutput('myoutput_message'), style='color:red'),
fields,
footer = column(shiny::modalButton('Cancel'),
shiny::actionButton("lopo_update", 'Save'),
width=12),
tags$script(HTML(jscode_edit)) ,
size = 'm', ##modal.size
easyClose = TRUE
))
}
###3 Update the databse when we click on the save button of the Modal
observeEvent(input$editClicked,{
if (!is.null(input$editClicked)) {
## selectedRow<-input$editClicked[[]]
selectedRow<-as.numeric(strsplit(input$editClicked, "_")[[1]][1])
print("kikou")
print(selectedRow)
print("kikou_Stop")
newdata <- result$thedata
newdata[newdata[,"idbis"]==selectedRow, names(newdata) != "idbis"] <- NA
###Update here with the correct row (idbis) newdata[,"idbis"]==row )
for(i in edit.cols) {
if(inputTypes[i] %in% c('selectInputMultiple')) {
newdata[[i]][newdata[,"idbis"]==selectedRow] <- list(input[[paste0('myLopo_edit_', i)]])
} else {
newdata[newdata[,"idbis"]==selectedRow,i] <- input[[paste0('myLopo_edit_', i)]]
}
}
data<-newdata[newdata[,"idbis"]==selectedRow, ]
values$dfWorking <- newdata
###Update LOPO DB###
con <- dbConnect(RSQLite::SQLite(), paste0("Studies/",study,"/",study))
query <- paste0("UPDATE ",study," SET ",
"Domain = '", as.character(data$Domain), "', ",
"Titles = '", as.character(data$Titles), "', ",
"Footnotes = '", as.character(data$Footnotes), "', ",
"Filters = '", as.character(data$Filters), "' ",
"WHERE rowid = ", selectedRow)
print(query)
dbSendQuery(con, query)
dbDisconnect(con)
###Close Modal ###
shiny::removeModal()
}
})
######################################################################
output$lopoExist <- renderText('YES')
}
#####LOPO Not yet CReated
else {
output$lopoExist <- renderText('NO')
#-----------------------------------------------------------------------------
# import a lopo
#-----------------------------------------------------------------------------
output$contents <- renderTable({
inFile <- input$file1
if(is.null(inFile))return(NULL)
file.rename(inFile$datapath,paste(inFile$datapath, ".xls", sep=""))
newLopo <-readxl::read_excel(paste(inFile$datapath, ".xls", sep=""), sheet="List of Planned Outputs (SMT)",skip = 6)
###remove empty rows (title and Footnote)
newLopo <- newLopo %>% filter_at(vars(Titles,Footnotes),any_vars(!is.na(.)))
newLopo$Study <- study
newLopo$Select = "Select"
newLopo$Action = "Action"
newLopo$idbis <- rownames(newLopo)
len_newLopo<-dim(newLopo)[1]
newLopo0<-newLopo
newLopo<-newLopo0[c(dim(newLopo)[2], 1:(dim(newLopo)[2]-1))]
#newLopo<-newLopo[1:25,]
newLopo[is.na(newLopo)] <- ''
newLopo$See = "NA"
newLopo$Run = "Run"
newLopo<-mutate(newLopo,outType=ifelse(substr(newLopo$`Outputs Produced`, 1, 1)=="t","Table",ifelse(substr(newLopo$`Outputs Produced`, 1, 1)=="l","Listing",ifelse(substr(newLopo$`Outputs Produced`, 1, 1)=="f","Figure","Other"))))
####Lopo as a SQL database ####
con <- dbConnect(RSQLite::SQLite(), lopoPath)
dbCreateTable(con, study, newLopo)
dbAppendTable(con, study, newLopo)
dbReadTable(con, study)
dbDisconnect(con)
####Create arelated Filters list ####
filterLopo<<-unique(newLopo$Filters)
source("functions/filters.R") ##load the main filter db
filts<-unique(df_filter[,"filts"])
f_ok <- c()
f_not_ok <- c()
for (f in filterLopo) {
f_split <- strsplit(f,"_")
for (fs in f_split[[1]] ) {
if (fs %in% filts) {
f_ok <- c(f_ok, fs)
}
else {
f_not_ok<- c(f_not_ok, fs)
}
}
}
#CASE 1 : The filter exists in the main database
df_ok<-df_filter[df_filter[,"filts"] %in% unique(f_ok), ]
#CASE 2 : The filter does'nt exist in the main database
df_not_ok<- data.frame( "filts" = unique(f_not_ok) )
df_not_ok$title<-""
df_not_ok$filter<-""
filter_tmp <- rbind(df_ok,df_not_ok)
# Create filter DB (study related)
con <- dbConnect(RSQLite::SQLite(), filters_path)
dbCreateTable(con, "FILTERS", filter_tmp)
dbAppendTable(con, "FILTERS", filter_tmp)
dbReadTable(con, "FILTERS")
dbDisconnect(con)
})
# data_path<-getDataPath(study,as.character(userff))
#######ACtion button to import Enimice data##################
# observeEvent(input$Import, {
# SAICE::initialize_connection(entimice_env = "PROD")
# adsl <- SAICE::read_entimice(file.path(paste0("root/clinical_studies/",data_path,'work/work/outdata_vad/adsl.sas7bdat')))
# output_list <- SAICE::get_entimice(paste0("root/clinical_studies/",data_path,"work/work/output"))
# program_list <- SAICE::get_entimice(paste0("root/clinical_studies/",data_path,"work/work/program"))
#log_list <- SAICE::get_entimice(paste0("root/clinical_studies/",data_path,"work/work/log"))
# SAICE::close_connection()
# })
#############################################################
}
outputOptions(output, 'lopoExist', suspendWhenHidden = FALSE)
#-----------------------------------------------------------------------------
# end of server
#-----------------------------------------------------------------------------
}) }
############################################################################################
shinyApp(ui, server)
kismet303/lopo3000 documentation built on Dec. 15, 2019, 12:31 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
# Temp copy of origanl app.R for reference
## app.R ##
library(tidyverse)
.libPaths(c(normalizePath("./libs"), .libPaths()))
library(tern)
library(shiny)
library(shinyjs)
library(shinydashboard)
library(readxl)
library(shinyWidgets)
library(DT)
library(haven)
library(shinyBS)
library(dplyr)
library(jsonlite)
library(DBI)
global_path<<-"/opt/bee_tools/shiny/3.5.3/users/remusatp/Global/"
main_path<<-"/opt/bee_tools/shiny/3.5.3/users/remusatp/lopo3000/"
functionPath<<-paste0(main_path,"functions/")
#study<<-"YO39609"
#study<<-"WO39392"
study<<-"BP40657"
status<<-"Interim 1"
server_<-"BEE"
userff <- Sys.info()["user"]
source("functions/callB_func.R")
source("functions/execute_R_prog.R")
source("functions/filters.R")
options(shiny.sanitize.errors = TRUE)
########get study list#################
con_1 <- dbConnect(RSQLite::SQLite(), paste0(global_path,"userDB"))
getStudy_list <- function() {
res <- dbSendQuery(con_1, "SELECT * FROM UserDB where user ='remusatp' ")
study_list <- dbFetch(res)
dbClearResult(res)
return(study_list)
}
#####################################
######################################## UI PART ###########################################
############################################################################################
ui <- dashboardPage(
dashboardHeader(title = paste0(study,"(",status,")") ),
## Sidebar content
dashboardSidebar(
sidebarMenu(
menuItem("Home", tabName = "Home", icon = icon("dashboard")),
menuItem("Overview",tabName = "OVERVIEW", icon = icon("th")) ,
menuItem("LOPO", tabName = "LOPO", icon = icon("th"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "Home",
h2("Study Description") ,p(userff),
p(textOutput("description")),
h2("Path in BEE") ,
p(textOutput("study_path"))
),
tabItem(tabName = "OVERVIEW",
h1(paste0("Overview of Lopo for study ",study, "(",status,")") ) ,
valueBox( textOutput("num_of_table"), "Tables", icon = icon("list"), color = "aqua", width = 3,
href = NULL),
valueBox( textOutput("num_of_figure"), " Figures", icon = icon("chart-bar"), color = "aqua", width = 3,
href = NULL),
valueBox( textOutput("num_of_listing"), " Listings", icon = icon("align-justify"), color = "aqua", width = 3,
href = NULL),
valueBox("12", "ADAMs", icon = icon("plus-square"), color = "aqua", width = 3,
href = NULL)
) ,
tabItem(tabName = "LOPO",
## h1(study) ,
div(style="display: inline-block;vertical-align:top; width: 300px;",
awesomeCheckboxGroup(
inputId = "OutType",
label = "Type of Output",
choices = c("Table", "Listing", "Figure"),
inline = TRUE,
status = "danger"
)),
div(style="display: inline-block;vertical-align:top; width: 330px;",
pickerInput(
inputId = "DomainC",
label = "Select Domain",
choices = c( "AE", "Exposure", "Disposition", "Demography", "Deaths", "Con Med") ,
multiple = TRUE,
# selected = "NULL",
choicesOpt = list(
content = sprintf("<span class='label label-%s'>%s</span>",
c("danger", "success", "warning", "info", "default","primary"),
c( "AE", "Exposure", "Disposition", "Demography","Deaths", "Con Med")))
)),
div(style="display: inline-block;vertical-align: center; width:100px;",
tags$br(),
actionBttn(
inputId = "tabFilt",
label = "Filter",
color = "primary",
style = "simple",
size= "sm",
icon = icon("sliders"),
block = TRUE
),
bsTooltip("tabFilt", "Edit Filters",
"top", options = list(container = "body")),
" ",
bsModal("modalFilter", "Filters", "tabFilt", size = "large",
dataTableOutput("filtTable"))
),
useShinyjs(),
extendShinyjs(text = js_code ),
dataTableOutput('myLopo3000') ,
conditionalPanel(condition = "output.lopoExist == 'NO' ",
p("Lopo template must follow the standard you can find here"),
sidebarLayout(
sidebarPanel(
df<-fileInput('file1', 'Choose xlsx file', accept = c(".xls"))
),
mainPanel(
tableOutput('contents')
)
) ) )) ) )
############################################################################################
###################################### SERVER PART #########################################
server <- function(input, output, session){
output$lopoExist <- renderText('NO')
observe({
query <- parseQueryString(session$clientData$url_search)
if (!is.null(query[['study']])) {
study <- query[['study']]
}
if (!is.null(query[['server']])) {
server_ <- query[['server']]
}
s_path<-paste0(main_path,"Studies/",study,"/",study)
########Study Information#########
study_list<-getStudy_list()
study_desc<-study_list[study_list[,"STUDY"]==study , 10]
studyy_path<-study_list[study_list[,"STUDY"]==study , 7]
output$description <- renderText( { study_desc } )
output$study_path <- renderText( { studyy_path } )
##################################
lopoPath <- paste0("Studies/",study,"/",study)
if (server_ == "BEE") {
# source("functions/datatable_R.R")
}
if (server_ == "Entimice") {
source("functions/datatable_SAS.R")
}
if (checkLopo(lopoPath)=="OK") {
myLopo <- getLopo(study,lopoPath)
num_of_table<- count(myLopo[myLopo['outType']=="Table",],)
num_of_figure<-count(myLopo[myLopo['outType']=="Figure",],)
num_of_listing<-count(myLopo[myLopo['outType']=="Listing",],)
output$num_of_table <- renderText({paste0(num_of_table, "")})
output$num_of_figure <- renderText({paste0(num_of_figure, "")})
output$num_of_listing <- renderText({ paste0(num_of_listing, "")})
print(num_of_table)
#-----------------------------------------------------------------------------
# Filter outputs list
#-----------------------------------------------------------------------------
col_list<-c('See', 'Action' , 'Domain', 'Titles', 'Footnotes', 'Filters', 'GDS Template', 'Program ID','outType','CRUD','idbis')
myLopotmp<-myLopo
myLopotmp$CRUD<-"Edit - Delete"
values <- reactiveValues(dfWorking = myLopotmp)
result <- shiny::reactiveValues()
result$thedata <- myLopotmp[,col_list]
result$view.cols <- names(myLopotmp[,col_list])
result$edit.cols <- names(myLopotmp[,col_list])
result$edit.label.cols <- result$edit.cols
edit.cols <- names(myLopotmp[,col_list])
edit.label.cols <- names(myLopotmp[,col_list])
####================================================================================================####
#### Display an Interactif LOPO ####
####================================================================================================####
output$myLopo3000 <- renderDataTable( {
##values$dfWorking
if ( is.null(input$DomainC) && is.null(input$OutType) ) {
values$dfWorking[,col_list] }
else if (is.null(input$DomainC)) {
values$dfWorking[,col_list] %>% filter(outType %in% c( input$OutType))
}
else if (is.null(input$OutType)) {
values$dfWorking[,col_list] %>% filter(Domain %in% c( input$DomainC))
}
else {
values$dfWorking[,col_list] %>% filter(Domain %in% c( input$DomainC) ) %>% filter(outType %in% c( input$OutType) )
}
},
options = list(
dom = 't',
initComplete = JS(
"function(settings, json) {",
"$(this.api().table().header()).css({'background-color': 'lightgrey', 'color': '#000', 'font-size': '10px' });",
"$(this.api().table().body()).css({ 'font-size': '12px', 'text-align': 'center' });",
"}"),
searchHighlight = TRUE,
columnDefs = list(
list(targets=2,
render = JS(paste0( "function(data, type, row, meta) {",
"if (data == 'AE') {",
"return '<small class=\"badge pull-center bg-red\">' + data + ' </small>' }",
"else if (data == 'Disposition') {",
"return '<small class=\"badge pull-center bg-yellow\">' + data + ' </small>' }",
"else if (data == 'Exposure') {",
"return '<small class=\"badge pull-center bg-green\">' + data + ' </small>' }",
"else if (data == 'Demography') {",
"return '<small class=\"badge pull-center bg-teal\">' + data + ' </small>' }",
"else if (data == 'Con Med') {",
"return '<small class=\"badge pull-center bg-blue\">' + data + ' </small>' }",
"else if (data == 'Death') {",
"return '<small class=\"badge pull-center bg-grey\">' + data + ' </small>' }",
"else {",
"return '<small class=\"badge pull-center bg-violet\">' + data + ' </small>' }",
"}"))),
list(targets=9,
render = JS(paste0( "function(data, type, row, meta) {",
"return '",
"<table>",
"<td align=\"center\"> <button id=\"button_'+ row[10] +'\" class=\"btn btn-primary btn-xs \" style=\"font-size:7px \" onclick=\"Shiny.onInputChange("edit_button", this.id + "_" + Math.random())\">Edit</button> </td>",
"<td align=\"center\"> <button id=\"buttonss_'+ row[10] +'\" class=\"btn btn-danger btn-xs\" style=\"font-size:7px \" onclick=\"Shiny.onInputChange("del_button", this.id + "_" + Math.random())\">Delete</button> </td>",
"</table>' }"
))),
list(targets=10,visible=FALSE),
list(targets=0,
render = JS(paste0( "function(data, type, row, meta) {",
"if (data == 'NA') {",
"return ' <i id=\"buttonss_'+ row[10] +'\" class=\"far fa-times-circle text-danger \" style=\"font-size:30px \" ></i>' }",
"else {",
"return ' <i id=\"buttonsst_'+ row[10] +'\" class=\"far fa-file-alt text-success \" style=\"font-size:30px \" onclick=\"Shiny.onInputChange("see_button", this.id + "_" + Math.random())\"></i> ' }",
"}"))),
list(targets=1,
render = JS(paste0( "function(data, type, row, meta) {",
"if (data == 'PROG_OK') {",
"return ' <i id=\"buttonbb_'+ row[10] +'\" class=\"fas fa-arrow-alt-circle-right text-success \" style=\"font-size:30px \" onclick=\"Shiny.onInputChange("run_button", this.id + "_" + Math.random() )\"></i> ' }",
"else {",
"return ' <i id=\"buttonbbt_'+ row[10] +'\" class=\"fas fa-arrow-circle-up text-danger \" style=\"font-size:30px \" onclick=\"Shiny.onInputChange("create_button", this.id + "_" + Math.random() )\"></i>' }",
"}"))),
list(targets = c(1,0),width = '20px'),
list(targets = c(3,4),width = '150px'),
list(targets = c(2, 5,6,7,8,9),width = '50px'),
list(targets = c(10),width = '10px'),
list(targets = c(4,5,3),
render = JS("function(data, type, row, meta) {",
"return type === 'display' && data.length > 50 && data ?",
"'<p align=\"left\"><span title=\"' + data + '\">' + data.substr(0, 50) + '...</span></p>' : '<p align=\"left\">' + data + '</p>' ;",
"}") )
),
scrollY = 600,
scroller = TRUE,
scrollX = T,
pageLength = 25
) ,
extensions = c('Buttons','Responsive'), server=TRUE, selection='single', rownames=FALSE)
####================================================================================================####
#### End of Display an Interactif LOPO ####
####================================================================================================####
#-----------------------------------------------------------------------------
# button functionalities
#-----------------------------------------------------------------------------
observeEvent(input$see_button, {
selectedRow <- as.numeric(strsplit(input$see_button, "_")[[1]][2])
outputid<-selectedRow
js$browseURL(paste0("https://shiny.roche.com/3.5.3/users/remusatp/output3000/?outputid=",outputid,"&study=",study,"&server=",server_))
} )
observeEvent(input$run_button, {
selectedRow <- as.numeric(strsplit(input$run_button, "_")[[1]][2])
print(selectedRow)
execute_R_prog(study,lopoPath,selectedRow)
})
observeEvent(input$seeb, {
outputid <- as.numeric(strsplit(input$seeb, "_")[[1]][2])
js$browseURL(paste0("https://shiny.roche.com/3.5.3/users/remusatp/output3000/?outputid=",outputid,"&study=",study,"&server=",server_))
})
####Create single program onclick
observeEvent(input$create_button, {
s_path<-paste0(main_path,"Studies/",study,"/",study)
selectedRow <- as.numeric(strsplit(input$create_button, "_")[[1]][2])
metaOutput<-getOutput(study,s_path,selectedRow)
create_R_program(paste0("Studies/",study,"/program/"),metaOutput$`Program ID`,"test")
##check_prog_exisit(paste0("Studies/",study,"/program/",metaOutput$`Program ID`))
##if prog exisit , update database
showModal(modalDialog(
title = "Program created",
"Program have been created",
easyClose = TRUE
))
myLopo<-getLopo(studyl,lopoPath)
js$reset()
})
# Updates goButton's label and icon
updateActionButton(session, "goButton",
label = "New label",
icon = icon("calendar"))
################General Button related to lopo#################
####################################################################
###Create Program related to lopo output############################
####################################################################
source("functions/createRprog.R")
vect_prog_name<-myLopo$`Program ID`
progPath<-paste0("Studies/",study,"/program/")
observeEvent(input$Create, {
create_all_R_program(progPath,vect_prog_name)
showModal(modalDialog(
title = "Job Done",
"Program have been created",
easyClose = TRUE
))
})
source("functions/template_meta_titles.R")
source("functions/template_meta_footnotes.R")
observeEvent(input$Export, {
createTitleFile(study,"PROJECT A",userff,"IMC")
createFootnoteFile(study,"PROJECT A",userff,"IMC")
showModal(modalDialog(
title = "Job Done",
"Titles and footnote have been exported",
easyClose = TRUE
))
})
####################################################################
#####################Check and Edit Filters#########################
####################################################################
filters_path <<- paste0(main_path,"Studies/",study,"/meta/FILTERS")
tab <- getFilters(filters_path)
output$filtTable <- renderDataTable({ tab
}, options = list( dom='t'), editable = TRUE )
# edit a single cell
proxy5 = dataTableProxy('filtTable')
observeEvent(input$filtTable_cell_edit, {
info = input$filtTable_cell_edit
str(info) # check what info looks like (a data frame of 3 columns)
tab <<- editData(tab, input$filtTable_cell_edit )
###update database
con <- dbConnect(RSQLite::SQLite(), paste0("Studies/",study,"/meta/FILTERS"))
dbWriteTable(con, "FILTERS", tab, overwrite=TRUE)
#dbBind(update, tab) # send the updated data
# dbClearResult(update) # release the prepared statement
dbDisconnect(con)
})
##############################################################################################################################################################################
##############################################################################################################################################################################
##############################################################################################################################################################################
##############################################################################################################################################################################
####================================================================================================####
#### CRUD Functionalities ####
####================================================================================================####
##====================================================================##
##==============================##DELETE##==============================##
##====================================================================##
source("functions/CRUD.R")
observeEvent(input$del_button, {
selectedIDBIS <- as.numeric(strsplit(input$del_button, "_")[[1]][2])
deleteModal(selectedIDBIS,result)
})
observeEvent(input$buttonClicked,{
if (!is.null(input$buttonClicked)) {
values$dfWorking <- values$dfWorking[ values$dfWorking[,"idbis"] != input$buttonClicked ,]
##REMOVE ROW FROM DATABASE (LOPO)
con <- dbConnect(RSQLite::SQLite(), paste0("Studies/",studyl,"/",studyl))
query <- paste0('DELETE FROM ',studyl,' WHERE rowid = ', input$buttonClicked)
dbSendQuery(con, query)
dbDisconnect(con)
shiny::removeModal()
}
})
##====================================================================##
##==============================##EDIT##==============================##
##====================================================================##
valid.input.types <- c('dateInput', 'selectInput', 'numericInput',
'textInput', 'textAreaInput', 'passwordInput', 'selectInputMultiple')
inputTypes <- sapply(result$thedata[,edit.cols], FUN=function(x) {
switch(class(x),
list = 'selectInputMultiple',
character = 'textInput',
Date = 'dateInput',
factor = 'selectInput',
integer = 'numericInput',
numeric = 'numericInput')
})
input.types = c(Footnotes ='textAreaInput',Titles ='textAreaInput')
if(!missing(input.types)) {
if(!all(names(input.types) %in% edit.cols)) {
stop('input.types column not a valid editting column: ',
paste0(names(input.types)[!names(input.types) %in% edit.cols]))
}
if(!all(input.types %in% valid.input.types)) {
stop(paste0('input.types must only contain values of: ',
paste0(valid.input.types, collapse = ', ')))
}
inputTypes[names(input.types)] <- input.types
}
# Convert any list columns to characters before displaying
for(i in 1:ncol(result$thedata)) {
if(nrow(result$thedata) == 0) {
result$thedata[,i] <- character()
} else if(is.list(result$thedata[,i])) {
result$thedata[,i] <- sapply(result$thedata[,i], FUN = function(x) { paste0(x, collapse = ', ') })
}
}
getFields <- function(typeName, valuestmp ) {
fields <- list()
for(i in seq_along(edit.cols)) {
if(inputTypes[i] == 'dateInput') {
value <- ifelse(missing( valuestmp),
as.character(Sys.Date()),
as.character( valuestmp[,edit.cols[i]]))
fields[[i]] <- dateInput(paste0("myLopo", typeName, edit.cols[i]),
label=edit.label.cols[i],
value=value,
width=date.width)
} else if(inputTypes[i] == 'selectInputMultiple') {
value <- ifelse(missing( valuestmp), '', valuestmp[,edit.cols[i]])
if(is.list(value)) {
value <- value[[1]]
}
choices <- ''
if(!missing( valuestmp)) {
choices <- unique(unlist( valuestmp[,edit.cols[i]]))
}
if(!is.null(input.choices)) {
if(edit.cols[i] %in% names(input.choices)) {
choices <- input.choices[[edit.cols[i]]]
}
}
if(length(choices) == 1 & choices == '') {
warning(paste0('No choices available for ', edit.cols[i],
'. Specify them using the input.choices parameter'))
}
fields[[i]] <- selectInputMultiple(paste0("myLopo", typeName, edit.cols[i]),
label=edit.label.cols[i],
choices=choices,
selected=value,
width=select.width)
} else if(inputTypes[i] == 'selectInput') {
value <- ifelse(missing( valuestmp), '', as.character( valuestmp[,edit.cols[i]]))
fields[[i]] <- shiny::selectInput(paste0("myLopo", typeName, edit.cols[i]),
label=edit.label.cols[i],
choices=levels(result$thedata[,edit.cols[i]]),
selected=value,
width=select.width)
} else if(inputTypes[i] == 'numericInput') {
value <- ifelse(missing( valuestmp), 0, valuestmp[,edit.cols[i]])
fields[[i]] <- shiny::numericInput(paste0("myLopo", typeName, edit.cols[i]),
label=edit.label.cols[i],
value=value,
width=numeric.width)
} else if(inputTypes[i] == 'textAreaInput') {
value <- ifelse(missing( valuestmp), '', valuestmp[,edit.cols[i]])
fields[[i]] <- shiny::textAreaInput(paste0("myLopo", typeName, edit.cols[i]),
label=edit.label.cols[i],
value=value,
width=textarea.width, height=textarea.height)
} else if(inputTypes[i] == 'textInput') {
value <- ifelse(missing( valuestmp), '', valuestmp[,edit.cols[i]])
fields[[i]] <- shiny::textInput(paste0("myLopo", typeName, edit.cols[i]),
label=edit.label.cols[i],
value=value,
width=text.width)
} else if(inputTypes[i] == 'passwordInput') {
value <- ifelse(missing( valuestmp), '', valuestmp[,edit.cols[i]])
fields[[i]] <- shiny::passwordInput(paste0("myLopo", typeName, edit.cols[i]),
label=edit.label.cols[i],
value=value,
width=text.width)
} else {
stop('Invalid input type!')
}
}
return(fields)
}
#####EDit a line of LOPO#######
###1 Click on EDit button on a line
observeEvent(input$edit_button, {
input.types <- c(Footnotes ='textAreaInput',Titles ='textAreaInput')
selectedIDBIS <- as.numeric(strsplit(input$edit_button, "_")[[1]][2])
print(input$edit_button)
editModal(selectedIDBIS)
})
###2 Display a Modal to update(edit) the line of the LOPO
editModal <- function(selectedRow ) {
jscode_edit <- paste0( '
$("#lopo_update").on("click", function(){
Shiny.onInputChange("editClicked",', selectedRow , '+ "_" + Math.random()',');
})
')
#output[['myoutput_message']] <- renderText('')
fields <- getFields('_edit_', values=values$dfWorking[values$dfWorking[,"idbis"]==selectedRow,] )
showModal(modalDialog(title = "Edit",
shiny::div(shiny::textOutput('myoutput_message'), style='color:red'),
fields,
footer = column(shiny::modalButton('Cancel'),
shiny::actionButton("lopo_update", 'Save'),
width=12),
tags$script(HTML(jscode_edit)) ,
size = 'm', ##modal.size
easyClose = TRUE
))
}
###3 Update the databse when we click on the save button of the Modal
observeEvent(input$editClicked,{
if (!is.null(input$editClicked)) {
## selectedRow<-input$editClicked[[]]
selectedRow<-as.numeric(strsplit(input$editClicked, "_")[[1]][1])
print("kikou")
print(selectedRow)
print("kikou_Stop")
newdata <- result$thedata
newdata[newdata[,"idbis"]==selectedRow, names(newdata) != "idbis"] <- NA
###Update here with the correct row (idbis) newdata[,"idbis"]==row )
for(i in edit.cols) {
if(inputTypes[i] %in% c('selectInputMultiple')) {
newdata[[i]][newdata[,"idbis"]==selectedRow] <- list(input[[paste0('myLopo_edit_', i)]])
} else {
newdata[newdata[,"idbis"]==selectedRow,i] <- input[[paste0('myLopo_edit_', i)]]
}
}
data<-newdata[newdata[,"idbis"]==selectedRow, ]
values$dfWorking <- newdata
###Update LOPO DB###
con <- dbConnect(RSQLite::SQLite(), paste0("Studies/",study,"/",study))
query <- paste0("UPDATE ",study," SET ",
"Domain = '", as.character(data$Domain), "', ",
"Titles = '", as.character(data$Titles), "', ",
"Footnotes = '", as.character(data$Footnotes), "', ",
"Filters = '", as.character(data$Filters), "' ",
"WHERE rowid = ", selectedRow)
print(query)
dbSendQuery(con, query)
dbDisconnect(con)
###Close Modal ###
shiny::removeModal()
}
})
######################################################################
output$lopoExist <- renderText('YES')
}
#####LOPO Not yet CReated
else {
output$lopoExist <- renderText('NO')
#-----------------------------------------------------------------------------
# import a lopo
#-----------------------------------------------------------------------------
output$contents <- renderTable({
inFile <- input$file1
if(is.null(inFile))return(NULL)
file.rename(inFile$datapath,paste(inFile$datapath, ".xls", sep=""))
newLopo <-readxl::read_excel(paste(inFile$datapath, ".xls", sep=""), sheet="List of Planned Outputs (SMT)",skip = 6)
###remove empty rows (title and Footnote)
newLopo <- newLopo %>% filter_at(vars(Titles,Footnotes),any_vars(!is.na(.)))
newLopo$Study <- study
newLopo$Select = "Select"
newLopo$Action = "Action"
newLopo$idbis <- rownames(newLopo)
len_newLopo<-dim(newLopo)[1]
newLopo0<-newLopo
newLopo<-newLopo0[c(dim(newLopo)[2], 1:(dim(newLopo)[2]-1))]
#newLopo<-newLopo[1:25,]
newLopo[is.na(newLopo)] <- ''
newLopo$See = "NA"
newLopo$Run = "Run"
newLopo<-mutate(newLopo,outType=ifelse(substr(newLopo$`Outputs Produced`, 1, 1)=="t","Table",ifelse(substr(newLopo$`Outputs Produced`, 1, 1)=="l","Listing",ifelse(substr(newLopo$`Outputs Produced`, 1, 1)=="f","Figure","Other"))))
####Lopo as a SQL database ####
con <- dbConnect(RSQLite::SQLite(), lopoPath)
dbCreateTable(con, study, newLopo)
dbAppendTable(con, study, newLopo)
dbReadTable(con, study)
dbDisconnect(con)
####Create arelated Filters list ####
filterLopo<<-unique(newLopo$Filters)
source("functions/filters.R") ##load the main filter db
filts<-unique(df_filter[,"filts"])
f_ok <- c()
f_not_ok <- c()
for (f in filterLopo) {
f_split <- strsplit(f,"_")
for (fs in f_split[[1]] ) {
if (fs %in% filts) {
f_ok <- c(f_ok, fs)
}
else {
f_not_ok<- c(f_not_ok, fs)
}
}
}
#CASE 1 : The filter exists in the main database
df_ok<-df_filter[df_filter[,"filts"] %in% unique(f_ok), ]
#CASE 2 : The filter does'nt exist in the main database
df_not_ok<- data.frame( "filts" = unique(f_not_ok) )
df_not_ok$title<-""
df_not_ok$filter<-""
filter_tmp <- rbind(df_ok,df_not_ok)
# Create filter DB (study related)
con <- dbConnect(RSQLite::SQLite(), filters_path)
dbCreateTable(con, "FILTERS", filter_tmp)
dbAppendTable(con, "FILTERS", filter_tmp)
dbReadTable(con, "FILTERS")
dbDisconnect(con)
})
# data_path<-getDataPath(study,as.character(userff))
#######ACtion button to import Enimice data##################
# observeEvent(input$Import, {
# SAICE::initialize_connection(entimice_env = "PROD")
# adsl <- SAICE::read_entimice(file.path(paste0("root/clinical_studies/",data_path,'work/work/outdata_vad/adsl.sas7bdat')))
# output_list <- SAICE::get_entimice(paste0("root/clinical_studies/",data_path,"work/work/output"))
# program_list <- SAICE::get_entimice(paste0("root/clinical_studies/",data_path,"work/work/program"))
#log_list <- SAICE::get_entimice(paste0("root/clinical_studies/",data_path,"work/work/log"))
# SAICE::close_connection()
# })
#############################################################
}
outputOptions(output, 'lopoExist', suspendWhenHidden = FALSE)
#-----------------------------------------------------------------------------
# end of server
#-----------------------------------------------------------------------------
}) }
############################################################################################
shinyApp(ui, server)
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.