inst/debiApp/global.r

In MartinGoros/debi: Dashboard Application for Biostatistics Group

####
# Author: Martin W. Goros
# UT Health San Antonio

require(shinydashboard)
require(plyr)
require(data.table)
require(dplyr)
require(shiny)
require(shinythemes)
require(RCurl)
require(httr)
require(shinyjs)
require(DT)
require(shinyBS)
require(ggplot2)
require(rvest)
require(redcapAPI)
require(ggvis)
require(knitr)
require(plotly)

colors <- c("#5ec97b","#297FB8","#8D44AD","#2D3E50","#F1C50E","#D25400","#7E8C8D","#19BC9D")

# connect-----------------------------------------------------------------------
rc_url <- as.character(read.table(paste0(getwd(),"/REDCap.txt"))[1,])   
rc_token <- as.character(read.table(paste0(getwd(),"/REDCap.txt"))[2,]) 
REDCap.crt <- 'filename.cert'                                           


# read redcap data--------------------------------------------------------------
read_redcap <- function(redcap_url,secret_token){
    out <- RCurl::postForm(uri=redcap_url,
                    token=secret_token,
                    content="record",
                    type="flat",
                    format="csv",
                    .opts=curlOptions(ssl.verifypeer=FALSE))

    if(any(out[1]!="\n")){
      tf <- tempfile()
      write(out,file=tf)
      dataout <- read.csv(tf)
      return(dataout)
    }else{
      return(NULL)
    }
}

# format data frame to redcap data format---------------------------------------
# this function comes from the following source:
# https://github.com/etb/my-R-code/blob/master/R-pull-and-push-from-and-to-REDCap.R
ParseRtoREDCap <- function(df) {
    ## Replace NA with "", converting column types as needed
    df[] <- lapply(df, function(X) {
                if(any(is.na(X))) {X[is.na(X)] <- ""; X} else {X}
            })

    ## Print integers in first column as 2-digit character strings
    ## (DO NOTE: Hardwiring the number of printed digits here is probably
    ## inadvisable, though needed to _exactly_ reconstitute RAW.API.)
    df[[1]] <- sprintf("%1.0f", df[[1]])

    ## Separately build header and table body, then suture them together
    l1 <- paste(names(df), collapse=",")
    l2 <- capture.output(write.table(df, sep=",", col.names=FALSE,
                                     row.names=FALSE))
    out <- paste0(c(l1, l2, ""), collapse="\n")

    ## Reattach attributes
    att <- list("Content-Type" = structure(c("text/html", "utf-8"),
                .Names = c("", "charset")))
    attributes(out) <- att
    out
}

# get user name from system-----------------------------------------------------
# this function comes from the following source:
# https://stackoverflow.com/questions/27927155/access-logged-in-name-in-r-shiny
GetUserName <- function() {
  # Returns user name  
  x <- Sys.info()[["user"]]

  # if blank try other methods
  if (is.null(x) | x == "") {
    # On windows machines
    Sys.getenv("USERNAME")
  } else {
    # from helpfiles for Unix
    Sys.getenv("LOGNAME")
  }

  # unknown error
  if (identical(x, "unknown")) {
    warning("unknown")
  }

  return(tolower(x))
}

# custom dropdown menu to log off-----------------------------------------------
# this function comes from the following source:
# https://stackoverflow.com/questions/40851634/shiny-dashboard-header-modify-dropdown
dropdownMenuCustom <- function (..., type = c("messages", "notifications", "tasks"),badgeStatus = "primary", icon = NULL, .list = NULL){
  type <- match.arg(type)
  if (!is.null(badgeStatus)) shinydashboard:::validateStatus(badgeStatus)
  items <- c(list(...), .list)
  lapply(items, shinydashboard:::tagAssert, type = "li")
  dropdownClass <- paste0("dropdown ", type, "-menu")
  if (is.null(icon)) {
    icon <- switch(type, messages = shiny::icon("envelope"), 
                   notifications = shiny::icon("warning"), tasks = shiny::icon("tasks"))
  }
  numItems <- length(items)
  if (is.null(badgeStatus)) {
    badge <- NULL
  }
  else {
    badge <- span(class = paste0("label label-", badgeStatus), 
                  numItems)
  }
  tags$li(
    class = dropdownClass, 
    a(
      href = "#", 
      class = "dropdown-toggle", 
      `data-toggle` = "dropdown", 
      icon, 
      badge
    ), 
    tags$ul(
      class = "dropdown-menu", 
      tags$li(
                class = "header", 
                paste("User: ", GetUserName())
            ),
      tags$li(
        tags$ul(class = "menu", items)
      )
    )
  )
}

# Function to write to data base------------------------------------------------
SaveDataPhase <- function(jobid,jobphase,jobnote,jobdate,modifier){
  job_phase_i <- nrow(subset(job_phase,record_id==jobid))+1
  data1 <- data.frame(record_id=jobid,
                      redcap_repeat_instrument='job_phase',
                      redcap_repeat_instance=job_phase_i,
                      job_phase=jobphase,
                      job_phase_date=paste0(jobdate," ",format(Sys.time(), "%H:%M:%S")),
                      job_phase_comment=jobnote,
                      modifier_job_phase=modifier,
                      job_phase_complete=2)
  job_phase.OUT <- ParseRtoREDCap(data1)
  return(job_phase.OUT)
}

SaveDataHours <- function(jobid,jobhours,notehours,hoursdate,modifier){
  work_i <- nrow(subset(work,record_id==jobid))+1
  data2 <- data.frame(record_id=jobid,
                      work_description=notehours,
                      redcap_repeat_instrument='work',
                      redcap_repeat_instance=work_i,
                      hours=jobhours,
                      billable=1,
                      contribution_date=paste0(hoursdate," ",format(Sys.time(), "%H:%M:%S")),
                      modifier_work=modifier,
                      work_complete=2)
   work.OUT <- ParseRtoREDCap(data2)
   return(work.OUT)
}

# run program to receive new data-----------------------------------------------
source("DEBiAdmin.r")

### END ###