#' csv_upload UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd
#'
#' @importFrom shiny NS tagList
mod_upload_ui <- function(id){
ns <- NS(id)
tagList(
fluidPage(
includeMarkdown(app_sys("app/www/docs/upload_instructions.md")),
hr(),
textOutput(ns("user_message")),
fluidRow(
uiOutput(ns("ask_for_libreview_csv")),
fileInput(ns("ask_filename_notes"), label = "Choose Notes File", accept = ".csv")),
uiOutput(ns("ask_to_write_db")),uiOutput(ns("ask_to_write_final")),
hr(),
fileInput(ns("ask_filename_nutrisense"), label = "Choose Nutrisense File", accept = ".csv"),
plotOutput(ns("modChart")),
hr(),
h1("Experiments"),
wellPanel(dataTableOutput(ns("experimentsTable"))),
hr(),
wellPanel(dataTableOutput(ns("glucoseTable"))),
hr(),
h1("Notes Table"),
wellPanel(dataTableOutput(ns("notesTable")))
)
)
}
#' csv_upload Server Functions
#'
#' @param con database connection
#' @importFrom cgmrdb classify_notes_to_experiment
#' @noRd
mod_upload_server <- function(id, con, user){
moduleServer( id, function(input, output, session){
ns <- session$ns
experiments_mapping <- DBI::dbReadTable(con, "experiments_mapping")
# Current User ----
current_user <- reactive({
this_user <- user$f$get_signed_in()
validate(need(!is.null(this_user), "Not signed in"))
user <- user_find_id(con,
list(firebase_id = this_user$response$uid))
message("Current User:", print_user(user))
return(user)
})
# Ask Filepath ----
output$ask_for_libreview_csv<- renderUI({
file_selection(item_id = ns("libreview_upload"), label = "Libreview CSV", accept = ".csv")
}
)
## filepath_notes ----
filepath_notes<- reactive({
validate(
need(input$ask_filename_notes,"Please select a Notes CSV file")
)
input$ask_filename_notes}
)
## filepath_nutrisense ----
filepath_nutrisense<- reactive({
validate(
need(input$ask_filename_nutrisense,"Please select a Nutrisense CSV file")
)
input$ask_filename_nutrisense}
)
# glucose_df_raw : Read Raw ----
glucose_df_raw <- reactive({
validate(
need(input$libreview_upload, "Upload a file please")
)
new_df <- cgmr::libreview_csv_df(file=input$libreview_upload$datapath)
}
)
## libreview_name ----
libreview_name <- reactive({
user_feedback(output=output, sprintf("You uploaded %s glucose values",nrow(glucose_df())))
glucose_df_raw()[["name"]]
})
## glucose_df ----
glucose_df <- reactive({
ID = current_user()$user_id
g_df <- glucose_df_raw()[["glucose_raw"]] %>%
transmute(
`time` = `timestamp`,
scan = glucose_scan,
hist = glucose_historic,
strip = strip_glucose,
value = hist,
food = notes,
user_id = ID
)
return(g_df)
}
)
## nutrisense_df ----
glucose_df_nutrisense_raw <-
reactive(cgmr::glucose_df_from_nutrisense(filepath = filepath_nutrisense()$datapath))
# notes_df_csv ----
notes_df_csv<- reactive({
ID = current_user()$user_id
notes <- NULL
try(notes <- cgmr::notes_df_from_csv(file = filepath_notes()$datapath,
user_id = ID))
validate(
need(!is.null(notes), "Bad Notes Format; please upload a properly-formatted Notes CSV")
)
user_feedback(output, msg = sprintf("Uploaded %s new notes for User %s", nrow(notes), ID))
return(notes)
}
)
## notes_df_libreview ----
notes_df_libreview <- reactive(cgmr::notes_df_from_glucose_table(glucose_df()))
## notes_df ----
notes_df <- reactive({
return(bind_rows(notes_df_csv(),notes_df_libreview()))
}
)
# output$modChart ----
output$modChart <- renderPlot({
plot_glucose(glucose_df(),sprintf("Glucose Results for %s",libreview_name()))
}
)
# output$ask_to_write_db ----
output$ask_to_write_db <- renderUI({
validate(
need(!is.null(glucose_df()),sprintf("Please upload a CSV file"))
)
actionButton(NS(id,"write_db"),
label = "Write to Database")
})
# output$ask_to_write_final ----
output$ask_to_write_final <- renderUI({
validate(
need(!is.null(glucose_df()),sprintf("Please confirm you're ready to write to the database"))
)
actionButton(NS(id,"write_final"),
label = "Write to Final")
})
# input$write_final ----
observeEvent(input$write_final, {
if(input$write_final) {
user_feedback(output, "Please log in")
ID = current_user()$user_id
message("ready to do final write")
write_notes <- experiments_times()
write_glucose <- glucose_df()
notes_result <- db_replace_records(con, ID, "notes_records", write_notes)
glucose_result <- db_replace_records(con, ID, "glucose_records", write_glucose)
message(sprintf("wrote %s glucose records; %s notes_records\n", glucose_result, notes_result))
}
})
# input$write_db ----
observeEvent(input$write_db, {
if(input$write_db) {
user_feedback(output, "Please log in")
ID = current_user()$user_id
message("write_db")
user_feedback(output,
msg = sprintf('Thinking about writing %s rows to %s database now\n
User ID = %s',
nrow(glucose_df_raw()[["glucose_raw"]]),
class(con),
ID))
new_raw_table <- bind_cols(user_id = ID,
glucose_df_raw()[["glucose_raw"]])
# todo pull this code to cgmr: convert the raw table to a glucose record
notes_from_raw_glucose <- cgmr::notes_df_from_glucose_table(glucose_df(), user_id = ID)
message(sprintf("Found notes in glucose file %s\n", notes_from_raw_glucose[,"Comment"]))
response <-
db_write_table(con=con,
table_name = "raw_glucose",
table_df = new_raw_table)
user_feedback(output,
msg = sprintf("Wrote User %s with Response = \n %s",
ID,
response))
validate(
need(!is.null(notes_df_csv()), "Upload a Notes CSV to write Notes file")
)
new_raw_notes_table <- notes_df_csv()
combined_raw_notes_table <- bind_rows(new_raw_notes_table, notes_from_raw_glucose)
print(combined_raw_notes_table)
notes_response <-
db_write_notes_table(con = con,
table_name = "raw_notes",
table_df = combined_raw_notes_table,
user_id = ID)
user_feedback(output,
msg = sprintf("Glucose=%s\nNotes=%s",
response,
notes_response))
}
})
# experiments ----
experiments_times <- reactive({
notes_table <- notes_df() %>% select(-TZ)
notes_table$Comment <- cgmrdb::classify_notes_to_experiment(notes_table$Comment, experiments_mapping)
message(sprintf("notes_table: %s\n", head(notes_table$Comment,5)))
return(notes_table %>% filter(Comment != "other"))
})
# output$glucoseTable ----
output$glucoseTable <- renderDataTable({
glucose_df_raw()[["glucose_raw"]]
},
options = list(pageLength = 5)
)
# output$notesTable ----
output$notesTable <- renderDataTable(
notes_df(),
options = list(pageLength = 5)
)
# output$experiments ----
output$experimentsTable <- renderDataTable(
experiments_times(),
options = list(pageLength = 5)
)
cgm_data <- list(con = reactive(con),
glucose_records = glucose_df,
notes_records = notes_df_csv)
return(cgm_data
) # This whole module returns a reactive glucose_df
})
}
#' @title Feedback to User
#' @description A generic way to send feedback to the user. Assumes a `user_message` tag in the UI.
#' If the message is NULL, return 'No Value Found'.
#' @param output output
#' @param msg character message to display
#' @return renderText object
user_feedback <- function(output, msg = "Thank You For Listening") {
message("user feedback")
message(msg)
output$user_message <-
renderText(if (rlang::is_empty(msg)) "No Value Found"
else msg)
}
#' @title Make a File Selection Object
#' @param item_id character string NS id for UI
#' @param label character string name on label
#' @return file selection object
file_selection <- function(item_id, label = "Which File?", ...){
selected <- fileInput(inputId = item_id, label = label, ...)
return(selected)
}
## To be copied in the UI
# mod_upload_ui("csv_upload_ui_1")
## To be copied in the server
# mod_upload_server("csv_upload_ui_1")
#' @description Demo for mod_filter
#' @noRd
#'
demo_upload <- function() {
ui <- fluidPage(firebase::useFirebase(),
firebase::firebaseUIContainer(),
mod_upload_ui("csv_upload_ui_1"))
#sample_glucose <- cgmr::glucose_df_from_libreview_csv()
server <- function(input, output, session) {
con <- db_connection()
f <- firebase_setup()
user <- UserObject(con, firebase_obj = f)
message("demo:", print_user(user))
g <- mod_upload_server("csv_upload_ui_1", con = con, user = user)
# message(sprintf("g = %s", str(g$con())))
onStop(function(){message("gracefully exiting from mod_upload...")
DBI::dbDisconnect(con)})
}
shinyApp(ui, server)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.