R/mod_drop_interface.R

In joeheywood/tnsinp: Tennis Input

#' drop_interface UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd 
#'
#' @importFrom shiny NS tagList 
#' @importFrom rdrop2 drop_upload drop_dir drop_get
mod_drop_interface_ui <- function(id){
  ns <- NS(id)
  tagList(
    textOutput(ns("drop"))
 
  )
}
    
#' drop_interface Server Function
#'
#' @noRd 
mod_drop_interface_server <- function(input, output, session){
  ns <- session$ns
  dropdir <- "tennis_matches"
  
  drop <- reactiveValues()
  drop$corners <- c()
  drop$ytbid <- drop$p1nm <- drop$p2nm <- ""
  drop$fetch <- ""
  drop$shotsdf <- data.frame()
  drop$scoredf <- data.frame()
  drop$saved_matches <- c()
  drop$loaded <- FALSE
  drop$matchesdf <- data.frame()
  drop$plytop <- ""
  drop$plybtm <- ""
  drop$save <- FALSE
  
  observe({ # saving data
    mt <- isolate(drop$matchesdf)
    corners <- drop$corners
    ytid <- drop$ytbid
    p1nm <- drop$p1nm
    p2nm <- drop$p2nm
    svtop <- drop$svtop
    shtdf <- drop$shotsdf 
    scdf <- drop$scoredf 
    ptp <- drop$plytop
    pbt <- drop$plybtm
    print(paste0("Top: ", ptp))
    req(length(corners) == 8)
    req(drop$save == TRUE)
    print("SAVING DATA")
    meta <- data.frame(ytid = ytid, p1nm = p1nm, p2nm = p2nm)
    meta <- unique(rbind(mt, meta))
    mtafl <- file.path(tempdir(), "meta.rda")
    save(meta, file = mtafl)
    drop_upload(mtafl, path = dropdir)
    
    save(corners, ytid, p1nm, p2nm, svtop, shtdf, scdf, ptp, pbt, file = "debug.Rda")
    file_name <- paste0(ytid, ".Rda")
    file_path <- file.path(tempdir(), file_name)
    #save(corners, ytid, p1nm, p2nm, svtop, shtdf, scdf, file = file_path)
    save(corners, ytid, p1nm, p2nm, svtop, shtdf, scdf, ptp, pbt, file = file_path)
    drop_upload(file_path, path = dropdir)
    drop$save <- FALSE
    
  })
  
  
  observe({
    ftch <- drop$fetch# vd$fetch
    req(ftch)
    req(nchar(ftch) > 0)
    lcl <- file.path(tempdir(), ftch)
    drop_get(paste0("tennis_matches/", ftch), lcl, overwrite = TRUE)
    load(lcl)
    scrdf <- isolate(drop$scoredf)
    if(nrow(scdf) == 0) {
      ptp <- ifelse(svtop == TRUE, p1nm, p2nm)
      pbt <- ifelse(svtop == TRUE, p2nm, p1nm)
    }
    
    drop$corners <- corners
    drop$ytbid <- ytid
    drop$p1nm <- p1nm
    drop$p2nm <- p2nm
    drop$shotsdf <- shtdf
    drop$scoredf <- scdf
    drop$svtop <- svtop
    drop$plytop <- ptp
    drop$plybtm <- pbt
    drop$loaded <- TRUE
    drop$fetch <- ""
    print("LOADING DATA")
    
  })
  
  observe({
    gg <- drop_dir(dropdir)
    if("meta.rda" %in% gg$name) {
      lcl <- file.path(tempdir(), "meta.rda")
      drop_get("tennis_matches/meta.rda", lcl, overwrite = TRUE)
      load(lcl)
      mtchs <- gg$name[grepl(".Rda", gg$name)]
      mtchs <- gsub(".Rda", "", mtchs)
      
      drop$matchesdf <- meta[which(meta$ytid %in% mtchs), ]
      
    }
    drop$saved_matches <- gg$name[grepl(".Rda", gg$name)]
  })
  
  
  ### function to add to some kind of metadata table
 
  drop
}
    
## To be copied in the UI
# mod_drop_interface_ui("drop_interface_ui_1")
    
## To be copied in the server
# callModule(mod_drop_interface_server, "drop_interface_ui_1")