R/mod_working_data_table.R

In becky-work/MouseCageApp: INCA

#' working_data_table UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd 
#'
#' @importFrom shiny NS tagList  
mod_working_data_table_ui <- function(id, time_selection = NA){
## don't need this; going to render directly in app_server
  ns <- NS(id)
  tagList(
    box(title = 'Choose light on and off times',
        pickerInput(inputId = ns('light_on_time'),
                    label = 'What time was the light turned on?\n(When did light start?)',
                    choices = time_selection,
                    selected = c('07:00'),
                    multiple = FALSE,
                    #options = list(style = 'background-color:#FFF68F;') # I cant get this to work will need to set css
                    #choicesOpt=list(rep_len('background:#FFF68F;',length(time_selection)))
        ),
        pickerInput(inputId = ns('light_off_time'),
                    label = 'What time was the light turned off?\n(When did dark start?)',
                    choices = time_selection,
                    selected = c('19:00'),
                    multiple = FALSE,
                    #choicesOpt = list(style = rep_len('background:#8DEEEE;',length(time_selection)))
        ),
        prettyCheckbox(inputId = ns("done_selecting_times"),
                       label = "Finished with setting light on/off?",
                       value = FALSE, # default to not finished
                       icon = icon("check"),
                       status = "success",
                       animation = "rotate"),
        
    )

)
}
    
#' working_data_table Server Functions
#'
#' @noRd 
mod_working_data_table_server <- function(id, file_data = NA){
  moduleServer( id, function(input, output, session){
    ns <- session$ns
    
    if(is.null(file_data[1])|is.null(file_data[2])|is.na(file_data[1])|is.na(file_data[2])){
      cat('\n no uploaded files\n')
      return(NULL)
    }
    
    ## need file data, light on and off
    req(file_data)
    req(input$light_on_time)
    req(input$light_off_time)
    
    add_times <- eventReactive(input$done_selecting_times,{
      if(input$done_selecting_times == FALSE){
        cat('\nWaiting for time selections (checkbox not checked)\n')
        return(NULL)
      }
      
      withProgress(message = 'Working on files', value = 0, {
        cat('\n adding in time selections\n')
      ## join the files
      meta <- data.frame(file_data['meta_file'])
      prom <- data.frame(file_data['cage_file'])
      
      # need to fix column names because it appends name to colnames when data.frame(list())
      colnames(meta) <- gsub('meta_file.','',colnames(meta))
      colnames(prom) <- gsub('cage_file.','',colnames(prom))
      ## a check
      # cat('meta',colnames(meta),'\n')
      # cat('prom',colnames(prom),'\n')
      
      incProgress(1/3, detail = "joining files")
      
      # this will also need to be adjusted due to user inputs
      prom_df <- left_join(prom, meta, by = c('subject_id', 'cage_id','start_day')) %>%
        # fix column names for my sanity
        janitor::clean_names()
      
      # don't know what to do with this
      #cage_settings <- prom_df %>% select(contains('date_time'),contains('enviro'),contains('subject_id'))
      
      prom_df <- prom_df %>%
        # remove cage settings I get direction
        select(!contains('enviro')) %>%
        # remove unneeded date columns
        select(-c('date_time_1', 'day')) %>%
        # create new subject_id using mouse id
        mutate(subject_id = paste(mouse_id, 'Cage',cage_id, sep = '_'))
      
      incProgress(2/3, detail = "adding light phases")
      ### add in light phases
      
      # add_time_to_cage_df <- eventReactive(input$done_selecting_times,{
      #   if(input$done_selecting_times == FALSE){
      #     cat('\nNot Finished with time selections (checkbox not checked)\n')
      #     return(NA)
      #   }
      #   
      start_light <- hms::as_hms(paste0(input$light_on_time,':00'))
      end_light <- hms::as_hms(paste0(input$light_off_time,':00'))

      p_df <- prom_df %>%
        # identify if cage is light or dark, calling it light phase so it's obvious that it's about the light
        mutate(light_phase = ifelse((hms::as_hms(dt) >= start_light) & (hms::as_hms(dt) < end_light), 'light','dark')) %>%
        # name the phases e.g. light phase 2
        # This is hokey but it works
        group_by(subject_id, var) %>% arrange(dt) %>%
        mutate(i = ifelse(light_phase == lag(light_phase), 0, 1),
               i = ifelse(is.na(i), 0, i)) %>%
        group_by(subject_id, var, light_phase) %>% arrange(light_phase, dt) %>%
        mutate(i1 = cumsum(i),
               add_one_to = ifelse(i1 == 0, light_phase, NA)) %>%
        ungroup()
      
      # pull out which light/dark that the cage started in i started with 0 so the cumsum is off by one
      #### NOTE: might want to leave it as light 0 dark 1 light 1 dark 2 etc so you know easily which phase the cage started in. Just remove the i1+1 part in the next step for this
      a <- p_df %>% select(subject_id, add_one_to) %>%
        na.omit() %>% unique() %>%
        mutate(p = paste(subject_id, add_one_to))
      
      cage_df <- p_df %>%
        mutate(i1 = ifelse(paste(subject_id, light_phase) %in% a$p , i1 + 1, i1),
               phase_num = paste(light_phase, i1)) %>% select(-c(i1, add_one_to)) %>%
        rename(phase_change = i) %>%
        ## THIS IS IMPORTANT for the plotting background to work
        arrange(subject_id, dt)
      incProgress(3/3, detail = "Finished")
      })
      return(cage_df)
  })
    return(add_times())
  })
}
    
## To be copied in the UI
# mod_working_data_table_ui("working_data_table_ui_1")
    
## To be copied in the server
# mod_working_data_table_server("working_data_table_ui_1")