R/mod_point.R

In joeheywood/tnsinp: Tennis Input

#' point UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd 
#'
#' @importFrom shiny NS tagList 
mod_point_ui <- function(id){
  ns <- NS(id)
  tagList(
    div(id = ns("pointdiv"),
        class = "thirty", 
		h4("Point"),
		textOutput(ns("pnt")),
		textOutput(ns("topbottm")),
		textOutput(ns("serving"))
		# what to include here? shot number - who's hitting?
    )
 
  )
}
    
#' point Server Function
#'
#' @noRd 
mod_point_server <- function(input, output, session, sht){
  ns <- session$ns
  pnt <- reactiveValues()
  pnt$corners <- c()
  # pnt$server <- ""
  pnt$serveno <- 1
  pnt$playertop <-  TRUE #  
  pnt$plytop <- "pt"
  pnt$plybtm <- "pb"
  pnt$pntdf <- data.frame()
  pnt$pntdf2 <- data.frame()
  pnt$id <- 0
  pnt$shotnum <- 0
  pnt$refresh <- FALSE
  pnt$call <- ""
  pnt$lastshot <- data.frame()
  
  
  observe({
    sht$corners <- pnt$corners
    sht$balltop <- pnt$playertop
  })
  
  output$serving <- renderText({
      if(pnt$playertop == TRUE) {
          paste0(pnt$plytop, " serving")
      } else {
          paste0(pnt$plybtm, " serving")
      }
  })
  
  
  output$topbottm <- renderText({
      paste0(pnt$plytop, " top.")
  })
  
  ### reset shot to serve
  
  
  observe({
      ref <- pnt$refresh
      req(ref == TRUE)
      pnt$serveno <- 1
      pnt$pntdf <- data.frame()
      pnt$id <- 0
      pnt$shotnum <- 0
      sht$balltop <- pnt$playertop
      print("setting balltop?")
      pnt$refresh <- FALSE
      
  })
  
  observe({
      shotobj <- input$shotobj
      crnrs <- isolate(pnt$corners)
      snm <- isolate(pnt$shotnum)
      svn <- isolate(pnt$serveno)
      blt <- isolate(sht$balltop)
      
      ## top is +ve if player at top, and *4? if serving
      req(length(shotobj$htr$lf) > 1) 
      if(shotobj$shtx == 2) {  
          tp <- 1
          if(blt == FALSE) tp <- tp * -1
          tpp <- tp
          if(snm == 0) tp <- tp * 3
          
          x <- shotobj$htr
          if((x$lf$y*tpp) >= (x$rf$y*tpp)) {
              obj <- x$lf
          } else {
              obj <- x$rf
          }
          h <- py_get_plus_1ft(crnrs, obj$x, obj$y, tp)
          hjs <- toJSON(h)
          jjs <- paste0( "shot.draw_cline(", hjs, ");") 
          runjs(jjs)
      }
      if(shotobj$shtx == 6) {
          pnt$shotnum <- snm + 1
          sht$hit <- FALSE
          send_to_df(shotobj)
          sht$balltop <- ifelse(blt == TRUE, FALSE, TRUE)
          bltp <- ifelse(blt == TRUE, "(TOP)", "(BOTTOM)")
          output$pnt <- renderText({ 
              paste0("Shot # ", snm + 1, bltp) 
          })
      }
  })
  
  send_to_df <- function(o) { # complete object gathered from js program
      crnrs <- isolate(pnt$corners)
      
      bltp <- isolate(sht$balltop)
      shtnm <- isolate(pnt$shotnum)
      pdf <- isolate(pnt$pntdf)
      ptop <- isolate(pnt$plytop)
      pbtm <- isolate(pnt$plybtm)
      
      htr <- ifelse(bltp == TRUE, ptop, pbtm)
      rcvr <- ifelse(bltp == TRUE, pbtm, ptop)
      # save(o, crnrs, file = "debug.Rda")
      
      p <- py_convert_obj(crnrs, o)
      df <- data.frame(
          rhitrfx = o$htr$rf$x,
          rhitrfy = o$htr$rf$y,
          rhitlfx = o$htr$lf$x,
          rhitlfy = o$htr$lf$y,
          rrcvrfx = o$rcvr$rf$x,
          rrcvrfy = o$rcvr$rf$y,
          rrcvlfx = o$rcvr$lf$x,
          rrcvlfy = o$rcvr$lf$y,
          rbncx = o$bounce$x,
          rbncy = o$bounce$y,
          rcngx = o$contact$ground$x,
          rcngy = o$contact$ground$y[[1]],
          rcnax = o$contact$air$x,
          rcnay = o$contact$air$y,
          
          phitrfx = p$hr$x,
          phitrfy = p$hr$y,
          phitlfx = p$hl$x,
          phitlfy = p$hl$y,
          
          prcvrfx = p$rr$x,
          ptrcvrrfy = p$rr$y,
          ptrcvrlfx = p$rl$x,
          ptrcvrlfy = p$rl$y,
          
          pcngx = p$cn$x,
          pcngy = p$cn$y,
          
          pbncx = p$bn$x,
          pbncy = p$bn$y,
          htr = htr,
          rcvr = rcvr
      )
      
    pnt$lastshot <- df
    pnt$pntdf <- rbind(df, pdf) 
  }
  
  
  observe({
      call <- input$call 
      sn <- isolate(pnt$shotnum)
      svno <- isolate(pnt$serveno)
      bltp <- isolate(sht$balltop)
      ptop <- isolate(pnt$plytop)
      pbtm <- isolate(pnt$plybtm)
      htr <- ifelse(bltp == TRUE, ptop, pbtm)
      rcv <- ifelse(bltp == TRUE, pbtm, ptop)
      req(call %in% c("net", "out", "miss", "netcord"))
      pnt$call <- call
      
      pdf <- isolate(pnt$pntdf)
      if(call %in% c("net", "out")) {
          print(sn)
          print(svno)
          if(sn == 1 & svno == 1) {
              pnt$serveno <- 2
              output$pnt <- renderText({"SECOND SERVE"})
              
          } else {
              # tail
              pdf$pointwinner <- htr
              output$pnt <- renderText({
                  paste0(call, " - ", htr, " WINS")
              })
              pnt$shotnum <- 0
              pnt$serveno <- 1
          }
          
      } else if(call == "miss") {
          pdf$pointwinner <- rcv
          output$pnt <- renderText({
              paste0("WINNER ", rcv, " WINS")
          })
          pnt$shotnum <- 0
          pnt$serveno <- 1
      } else if(call == "netcord") {
          print("NET!")
          if(sn == 1 & svno == 1) {
              pnt$serveno <- 1
              pnt$shotnum <- 0
              output$pnt <- renderText({"LET. First serve"})
          }
      }
      
      
      
      pnt$pntdf <- pdf
      sht$balltop <- pnt$playertop
      pnt$call <- ""
      runjs("clear_canv();")
  })
  
  observe({
      ht <- sht$hit
      sn <- isolate(pnt$shotnum)
      req(ht == TRUE)
      pnt$shotnum <- sn + 1
      output$pnt <- renderText({ 
          paste0("Shot # ", sn + 1) 
      })
      sht$hit <- FALSE
      
  })
  
  # observe({
  #     shot <- sht$shot
  #     bltp <- isolate(sht$balltop)
  #     shtnm <- isolate(pnt$shotnum)
  #     pdf <- isolate(pnt$pntdf)
  #     ptop <- isolate(pnt$plytop)
  #     pbtm <- isolate(pnt$plybtm)
  #     htr <- ifelse(bltp == TRUE, ptop, pbtm)
  #     pdf <- isolate(pnt$pntdf)
  #     req(bltp %in% c(TRUE, FALSE))
  #     req("h" %in% names(shot))
  #     # sht$balltop <- !bltp
  #     
  #     df <- data.frame(
  #         hitx = shot$h$x,
  #         hity = shot$h$y,
  #         rcvx = shot$r$x,
  #         rcvy = shot$r$y,
  #         bncx = shot$ball$x,
  #         bncy = shot$ball$y,
  #         cntx = shot$cntct$x,
  #         cnty = shot$cntct$y,
  #         cnttm = shot$h$rtm,
  #         bnctm = shot$ball$rtm,
  #         hght = shot$hght,
  #         shotnm = shtnm,
  #         htr = htr
  #     )
  #     output$pnt <- renderText({ "Shot received" })
  #     bltp <- ifelse(bltp == TRUE, FALSE, TRUE)
  #     sht$balltop <- bltp
  #     pnt$pntdf <- rbind(pdf, df)
  # })
  
  pnt
}
    
## To be copied in the UI
# mod_point_ui("point_ui_1")
    
## To be copied in the server
# callModule(mod_point_server, "point_ui_1")