Añadir aplicación shiny

BDAccess/app.R

@@ -0,0 +1,338 @@
+library(shiny)
+library(rhandsontable)
+
+print(getwd())
+print(file)
+source("../sqlFunctions.R", encoding = "UTF-8")
+
+DF<-data.frame("NHC"="","Samples"="")
+samples<-data.frame("UMID"="","UM"="")
+CLINICS<-data.frame("UMID"="","UM"="")
+cnag<-data.frame("UMID"="","UM"="")
+rna<-data.frame("UMID"="","UM"="")
+
+# Cargar dependencias
+sqlInitialize(ruta="../ruta_database.R")
+
+
+ui <- fluidPage(
+
+    # Application title
+    titlePanel("BDAccess"),
+    
+    sidebarLayout(
+            sidebarPanel(
+                selectInput("dbtype", "", selected="UM", choices=c("UM", "OV")),
+                checkboxInput(inputId = "backup", label="Backup", value=F),
+                actionButton("butdbtype", "Carrega BD"),
+                hr(),
+                fileInput(inputId = "file_query", label = "Plantilla", multiple = F),
+                actionButton("impNHC", "Importa NHC"),
+                actionButton("goButton", "Genera UMID"),
+                hr(),
+                actionButton("filltemplate", "Plantilla"),
+                hr(),
+                actionButton("synctemplate", "Sincronizar")
+            ),
+    
+            mainPanel(
+                tabsetPanel(
+                    tabPanel("NHC", rHandsontableOutput("hot")),
+                    tabPanel("Samples",rHandsontableOutput("samples")),
+                    tabPanel("CLINICS",rHandsontableOutput("CLINICS")),
+                    tabPanel("CNAG",rHandsontableOutput("cnag")),
+                    tabPanel("RNADNA",rHandsontableOutput("rna")),
+                )
+            )
+    )
+)
+
+# Define server logic required to draw a histogram
+server <- function(input, output) {
+    
+    values <- reactiveValues()
+    values[["DF"]]<-DF
+    values[["samples"]]<-samples
+    values[["CLINICS"]]<-CLINICS
+    values[["cnag"]]<-cnag
+    values[["rna"]]<-rna
+    values[["Excel"]]<-""
+    
+    observeEvent(input$butdbtype, {
+        dta<<-odbcConnectAccess2007(access.file = file, 
+                                    pwd = .rs.askForPassword("Enter password:"))
+        print(dta)
+        if (input$backup == T){
+            sqlBackUp()   
+        }
+    })
+    
+    # observe({
+    #     if (!is.null(input$file_access)){ 
+    #         # Inicializar conexión
+    #         dta<<-odbcConnectAccess2007(access.file = file, 
+    #                                    pwd = .rs.askForPassword("Enter password:"))
+    #         print(dta)
+    #         sqlBackUp()
+    #     }
+    # })
+    
+    observe({
+        if (!is.null(input$file_query)){
+            ## Importamos los NHC de las muestras nuevas
+            values[["Excel"]]<-read.xlsx(input$file_query$datapath, sheet = "NHC") %>% pull(NHC) %>% as.character()
+        }
+    })
+    observeEvent(input$impNHC, {
+        values[["DF"]]$NHC<-values[["Excel"]]
+    })
+
+    ## Handsontable
+    observe({
+        if (!is.null(input$hot)) {
+            DF = hot_to_r(input$hot)
+        } else {
+            if (is.null(values[["DF"]])){
+                DF <- DF
+            }
+            else{
+                DF <- values[["DF"]]
+            }
+        }
+        values[["DF"]] <- DF
+    })
+    
+    output$hot <- renderRHandsontable({
+        if (!is.null(DF)){
+            rhandsontable(values[["DF"]], stretchH = "all", readOnly = F, useTypes = T)   
+        }
+    })
+    
+    observe({
+        print(1)
+        if (!is.null(input$samples)) {
+            samples = hot_to_r(input$samples)
+        } else {
+            if (is.null(values[["samples"]])){
+                samples <- samples
+            }
+            else{
+                samples <- values[["samples"]]
+            }
+        }
+        values[["samples"]] <- samples
+    })
+    
+    output$samples <- renderRHandsontable({
+        if (!is.null(samples)){
+            rhandsontable(values[["samples"]], stretchH = "all", readOnly = F, useTypes = T)   
+        }
+    })
+    
+    observe({
+        if (!is.null(input$CLINICS)) {
+            CLINICS = hot_to_r(input$CLINICS)
+        } else {
+            if (is.null(values[["CLINICS"]])){
+                CLINICS <- CLINICS
+            }
+            else{
+                CLINICS <- values[["CLINICS"]]
+            }
+        }
+        values[["CLINICS"]] <- CLINICS
+    })
+    
+    output$CLINICS <- renderRHandsontable({
+        if (!is.null(CLINICS)){
+            rhandsontable(values[["CLINICS"]], stretchH = "all", readOnly = F, useTypes = T)   
+        }
+    })
+    
+    observe({
+        if (!is.null(input$cnag)) {
+            cnag = hot_to_r(input$cnag)
+        } else {
+            if (is.null(values[["cnag"]])){
+                cnag <- cnag
+            }
+            else{
+                cnag <- values[["cnag"]]
+            }
+        }
+        values[["cnag"]] <- cnag
+    })
+    
+    output$cnag <- renderRHandsontable({
+        if (!is.null(cnag)){
+            rhandsontable(values[["cnag"]], stretchH = "all", readOnly = F, useTypes = T)   
+        }
+    })
+    
+    observe({
+        if (!is.null(input$rna)) {
+            rna = hot_to_r(input$rna)
+        } else {
+            if (is.null(values[["rna"]])){
+                rna <- rna
+            }
+            else{
+                rna <- values[["rna"]]
+            }
+        }
+        values[["rna"]] <- rna
+    })
+    
+    output$rna <- renderRHandsontable({
+        if (!is.null(rna)){
+            rhandsontable(values[["rna"]], stretchH = "all", readOnly = F, useTypes = T)   
+        }
+    })
+    
+    observeEvent(input$goButton, {
+        print(dta)
+        sqlGenOVID(nhcs = values[["DF"]]$NHC, sinc=T)
+        values[["DF"]]<-merge(values[["DF"]], sqlFetch(dta, "UMID"))
+        print(values[["DF"]])
+    })
+
+    observeEvent(input$filltemplate,{
+        today=T
+        
+        upd.umid<-sqlFetch(dta, "UMID") %>% filter(NHC %in% values[["DF"]]$NHC)
+        ## Generar código para las nuevas muestras
+        samples<-sqlFetch(dta, "MUESTRAS")
+        if(sum(grepl(paste0("UM",Sys.time() %>% format("%y")), samples$CODIGO)) > 0){
+            next.samp<-gsub(paste0("UM",Sys.time() %>% format("%y")),"", samples$CODIGO) %>% as.numeric %>% max(na.rm=T)+1  
+        }else{
+            next.samp<-1
+        }
+        last.samp<-next.samp+(length(values[["DF"]]$NHC)-1)
+        new.samp<-sprintf("UM%s%02d",Sys.time() %>% format("%y"),next.samp:last.samp)
+        new.samp.df<-data.frame("NHC"=values[["DF"]]$NHC, "CODIGO"=new.samp) %>% merge(sqlFetch(dta,"UMID"), all.x=T) %>% arrange(CODIGO)
+        samples.exp<-merge(samples %>% slice(0), new.samp.df %>% select(-NHC), all=T) %>% select(colnames(samples)) %>% arrange(CODIGO)
+        if (today==TRUE){
+            samples.exp$FECHA_RECEPCION<-format(Sys.Date(), "%d/%m/%y")
+        }
+        
+        nhc.table<-values[["DF"]]
+        
+        if (any(sapply(nhc.table$Samples, function(x) "cnag" %in% strsplit(x,",")[[1]]) == T)){
+            nhcs.cnag<-nhc.table[sapply(nhc.table$Samples, function(x) "cnag" %in% strsplit(x,",")[[1]]),"NHC"]
+            umid.cnag<-sqlFetch(dta, "UMID") %>% filter(NHC %in% nhcs.cnag) %>% pull(UMID)
+            sample.cnag<-samples.exp %>% filter(UMID %in% umid.cnag) %>% pull(CODIGO)
+            cnag.exp<-merge(data.frame("UMID"=umid.cnag, "CODIGO"=sample.cnag), sqlFetch(dta, "CNAG") %>% slice(0), all=T)
+            if (today==TRUE){
+                cnag.exp$FECHA_ENVIO<-format(Sys.Date(), "%d/%m/%y")
+            }
+        }else{
+            cnag.exp<-sqlFetch(dta, "CNAG") %>% slice(0) %>% 
+                mutate(across(lubridate::is.POSIXct, as.character))
+            }
+        if (any(sapply(nhc.table$Samples, function(x) "rna" %in% strsplit(x,",")[[1]]) == T)){
+            nhcs.rna<-nhc.table[sapply(nhc.table$Samples, function(x) "rna" %in% strsplit(x,",")[[1]]),"NHC"]
+            umid.rna<-sqlFetch(dta, "UMID") %>% filter(NHC %in% nhcs.rna) %>% pull(UMID)
+            sample.rna<-samples.exp %>% filter(UMID %in% umid.rna) %>% pull(CODIGO)
+            rna.exp<-merge(data.frame("UMID"=umid.rna, "CODIGO"=sample.rna), sqlFetch(dta, "RNADNA") %>% slice(0)%>% 
+                               mutate(across(lubridate::is.POSIXct, as.character)), all=T)
+        }else{
+            rna.exp<-sqlFetch(dta, "RNADNA") %>% slice(0) %>% 
+                mutate(across(lubridate::is.POSIXct, as.character))
+            }
+        
+        ## Importar los datos clínicos de pacientes existentes y generar nueva entrada par los nuevos
+        upd.clinics<-sqlFetch(dta, "CLINICOS")
+        umid.new<-sqlFetch(dta, "UMID") %>% filter(NHC %in% values[["DF"]]$NHC)
+        upd.clinics<-merge(umid.new,upd.clinics, all.x=T, by="UMID")
+        upd.clinics$NHC<-as.character(upd.clinics$NHC)
+        for (i in colnames(upd.clinics)[sapply(upd.clinics, lubridate::is.POSIXct)]){upd.clinics[,i]<-as.Date(upd.clinics[,i])}
+        
+        values[["samples"]]<-samples.exp
+        values[["CLINICS"]]<-upd.clinics
+        values[["cnag"]]<-cnag.exp
+        values[["rna"]]<-rna.exp
+        
+        print(values[["rna"]] %>% sapply(class))
+        
+    })
+    
+    observeEvent(input$synctemplate,{
+        
+        # conn=dta, filetemp="queryOV.xlsx", sinc.samples=F, sinc.clinics=F, dbtype=NULL
+        
+        ## Nuevas entradas en MUESTRAS
+        nsamples<-values[["samples"]] %>% nrow
+        upd.samples<-values[["samples"]]
+        if (nrow(upd.samples) > 0){rownames(upd.samples)<-(nsamples+1):(nsamples+nrow(upd.samples)) %>% as.character}
+        
+        if (nrow(upd.samples) > 0){
+            upd.samples$FECHA_RECEPCION<-lubridate::parse_date_time(upd.samples$FECHA_RECEPCION, c("d/m/Y","d/m/y")) %>% as.Date()
+            upd.samples$TIPO<-as.character(upd.samples$TIPO)
+            upd.samples$OBS<-as.character(upd.samples$OBS)
+            ### !! Atención, esto cambia la base de datos:
+            print(upd.samples)
+            sqlSave(dta, upd.samples, tablename="MUESTRAS", append = T, varTypes = c("FECHA_RECEPCION"="Date"), rownames = F)
+            print("Tabla MUESTRAS sincronizada.")
+        }
+    
+        ## Entradas modificadas en CLINICOS
+        upd.clinics<-values[["CLINICS"]]
+        umid.mod<-upd.clinics$UMID[upd.clinics$UMID %in% (sqlFetch(dta, "CLINICOS") %>% pull(UMID))]
+        rnames<-sqlFetch(dta, "CLINICOS") %>% filter(UMID %in% umid.mod) %>% rownames
+        clinics.mod<-upd.clinics %>% filter(UMID %in% umid.mod) %>% select(-NHC)
+        rownames(clinics.mod)<-rnames
+        
+        ### !! Atención, esto cambia la base de datos:
+        fechas<-colnames(clinics.mod)[grepl("date|MET_DX|DoB", colnames(clinics.mod), ignore.case = T)]
+        for (i in fechas){
+            clinics.mod[,i]<-lubridate::parse_date_time(clinics.mod[,i], c("d/m/Y","d/m/y")) %>% as.Date()
+        }
+        sqlUpdate(dta, clinics.mod,"CLINICOS", index="UMID")
+        print("Tabla CLINICOS modificada.")
+        
+        ## Nuevas entradas en CLINICOS
+        nsamples.clin<-sqlFetch(dta, "CLINICOS") %>% nrow
+        umid.new<-upd.clinics$UMID[!upd.clinics$UMID %in% (sqlFetch(dta, "CLINICOS") %>% pull(UMID))]
+        clinics.new<-upd.clinics %>% filter(UMID %in% umid.new) %>% select(-NHC)
+        if (length(umid.new) > 0){rownames(clinics.new)<-(nsamples.clin+1):(nsamples.clin+nrow(clinics.new)) %>% as.character}
+        
+        ### !! Atención, esto cambia la base de datos:
+        fechas<-colnames(clinics.new)[grepl("date|MET_DX|DoB", colnames(clinics.new), ignore.case = T)]
+        varTypes<-rep("Date",length(fechas))
+        names(varTypes)<-fechas
+        for (i in fechas){
+            clinics.new[,i]<-lubridate::parse_date_time(clinics.new[,i], c("d/m/Y","d/m/y")) %>% as.Date()
+        }
+        sqlSave(dta, clinics.new, tablename="CLINICOS", append = T, varTypes = varTypes, rownames = F)
+        print("Tabla CLINICOS sincronizada.")
+        
+        ## Nuevas entradas en CNAG
+        if (nrow(values[["cnag"]]) > 0){
+            cnag.sync<-values[["cnag"]]
+            fechas<-colnames(cnag.sync)[sqlFetch(dta, "CNAG") %>% sapply(lubridate::is.POSIXct)]
+            varTypes<-rep("Date",length(fechas))
+            names(varTypes)<-fechas
+            print(fechas)
+            for (i in fechas){
+                cnag.sync[,i]<-lubridate::parse_date_time(cnag.sync[,i], c("d/m/Y","d/m/y")) %>% as.Date()
+            }
+            sqlSave(dta, cnag.sync, tablename="CNAG", append = T, varTypes = varTypes, rownames = F)
+        }
+        
+        ## Nuevas entradas en RNADNA
+        if (nrow(values[["rna"]]) > 0){
+            rna.sync<-values[["rna"]]
+            fechas<-colnames(rna.sync)[sqlFetch(dta, "RNADNA") %>% sapply(lubridate::is.POSIXct)]
+            varTypes<-rep("Date",length(fechas))
+            names(varTypes)<-fechas
+            for (i in fechas){
+                rna.sync[,i]<-lubridate::parse_date_time(rna.sync[,i], c("d/m/Y","d/m/y")) %>% as.Date()
+            }
+            sqlSave(dta, rna.sync, tablename="RNADNA", append = T, varTypes = varTypes, rownames = F)
+        }
+    })
+    
+}
+
+# Run the application 
+shinyApp(ui = ui, server = server)