Añadir aplicación shiny
This commit is contained in:
Costa
+338
@@ -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)
|
||||||
Reference in New Issue
Block a user