## GUIDE TO AUTH2 Authentication in R Shiny (or other online apps)
## 
## Mark Edmondson 2015-02-16 - @HoloMarkeD | http://markedmondson.me
##
## v 0.1
##
##
## Go to the Google API console and activate the APIs you need. https://code.google.com/apis/console/?pli=1
## Get your client ID, and client secret for use below, and put in the URL of your app in the redirect URIs
##  e.g. I put in https://mark.shinyapps.io/ga-effect/ for the GA Effect app, 
## and http://127.0.0.1:6423 for local testing (start the Shiny App by using this command to force the port: runApp(port=6423)
##
## I then have an auth.r file I source which is below
##

## auth.r
CLIENT_ID      <-  "YOUR CLIENT ID"
CLIENT_SECRET  <-  "YOUR CLIENT SECRET"
CLIENT_URL     <-  'https://your-url-that-picks-up-return-token.com'
# CLIENT_URL     <-  'http://127.0.0.1:6423'  # I comment this out for deployment, in for local testing

### Authentication functions

## generate the URL the user clicks on.  
## The redirect URL is then returned to with the extra 'code' and 'state' URL parameters appended to it.
ShinyGetTokenURL <- function(client.id     = CLIENT_ID,
                             client.secret = CLIENT_SECRET,
                             redirect.uri  = CLIENT_URL) {

  url <- paste('https://accounts.google.com/o/oauth2/auth?',
               'scope=https%3A%2F%2Fwww.googleapis.com%2Fauth%2Fanalytics+',  ## plus any other scopes you need
               'https%3A%2F%2Fwww.googleapis.com%2Fauth%2Fanalytics.readonly&',
               'state=securitytoken&',
               'redirect_uri=', redirect.uri, '&',
               'response_type=code&',
               'client_id=', client.id, '&',
               'approval_prompt=auto&',
               'access_type=online', sep='', collapse='');
  return(url)
}

## gets the token from Google once you have the code that is in the return URL
ShinyGetToken <- function(code,
                          client.id     = CLIENT_ID,
                          client.secret = CLIENT_SECRET,
                          redirect.uri  = CLIENT_URL){
  
  token <- MErga.authenticate(client.id = client.id,
                              client.secret = client.secret,
                              code = code,
                              redirect.uri = redirect.uri);

  return(token)
}

## posts your code to google to get the current refresh
MErga.authenticate <- function(client.id, client.secret, code, redirect.uri) {
  opts <- list(verbose = FALSE);
  raw.data <- postForm('https://accounts.google.com/o/oauth2/token',
                       .opts = opts,
                       code = code,
                       client_id = client.id,
                       client_secret = client.secret,
                       redirect_uri = redirect.uri,
                       grant_type = 'authorization_code',
                       style = 'POST');
  
  token.data <- fromJSON(raw.data);
  now <- as.numeric(Sys.time());
  token <- c(token.data, timestamp = c('first'=now, 'refresh'=now));
  
  return(token);
}
#### end auth.r

#### Then in Shiny these are the appropriate server.r and ui.r functions
##
## server.r
#
shinyServer(function(input, output, session) {

  ### Authentication Functions ########################################################
  ##
  ##   AuthCode() - checks for presence of code in URL
  ##   AccessToken() - creates a token once a code is available
  ##   ShinyMakeGAProfileTable - the table of profiles taken from API
  ##   output$AuthGAURL - creates the authentication URL
  ##   output$GAProfile - table of the profiles belonging to user
  
  AuthCode  <- reactive({
  
   ## gets all the parameters in the URL. Your authentication code should be one of them
    pars <- parseQueryString(session$clientData$url_search) 
    
    if(length(pars$code) > 0){
      return(pars$code)
    } 
  })
  
  AccessToken <- reactive({ 
    validate(
      need(AuthCode(), "Authenticate To See")
      )
      access_token <- ShinyGetToken(code = AuthCode())
    
      token <- access_token$access_token
  })
  
  output$AuthGAURL <- renderUI({
    a("Click Here to Authorise Your Google Analytics Access", href=ShinyGetTokenURL())
  })
  
  ShinyMakeGAProfileTable <- reactive({

    token <- AccessToken()

  ### ... do your call to the Google API with the token .. etc.
  })

## end server.r

## ui.r just provides the URL for users to click

## ui.r

# ...

uiOutput("AuthGAURL")

# ...
## end  ui.r
 

library(dplyr)
library(magrittr)
library(lubridate)
library(bit64)
library(stringr)

lns <- readLines("~/.rstudio-desktop/history_database") %>% str_split(pattern=":",n=2)
hist_db <- data_frame(epoch=as.integer64(sapply(lns,"[[",1)),history=sapply(lns,"[[",2))

hist_db %<>% mutate(nice_date = as.POSIXct(epoch/1000,origin = "1970-01-01",tz = "EET"))
hist_db %<>% mutate(day = ceiling_date(nice_date,unit = "day")-days(1))

hist_db %<>% select(-epoch)

dd <- hist_db$day %>% unique %>% sort

ff <- "~/R/hist_nice.txt"
cat("R history","\n",rep("-",80),"\n",file=ff,sep="")

for(i in 1:length(dd)) {
    cat("\n\n",format(dd[i]),"\n",rep("-",80),"\n",file=ff,sep="",append=TRUE)        
    hist_db %>% filter(day==dd[i]) %>% select(nice_date,history) %>% arrange(nice_date) %>% 
        write.table(ff,sep="\t", quote=F, row.names=FALSE, col.names=FALSE, append=TRUE)
}

#reorder the factor level in order so we can cleanly see the RBIs and their varibility among these sluggers
hrs$nameyear <- factor(hrs$nameyear, levels=hrs[order(hrs$RBI), "nameyear"])
#create a flipped bar plot and gradient fill the bars with the corresponding HRs
ggplot(data=hrs, aes(x=nameyear, y=RBI, fill=HR)) + geom_bar(stat="identity") +
  coord_flip() + scale_fill_gradient(low="gray50", high="red")

meanhits <- mean(Batting$H, na.rm=TRUE)
batting <- Batting %>% filter(lgID %in% c("AL","NL"), H >= meanhits )
hrs <- Batting %>% filter(HR > hr_4_std &  lgID %in% c("AL","NL")) %>% select(playerID,yearID, HR, RBI)
names <- Master %>% mutate(name = paste(nameFirst, nameLast)) %>%  select(playerID, name)
hrs <- merge(hrs, names, by = "playerID")
hrs$nameyear <- factor(paste0(hrs$name, ",","", hrs$year))

# Function to download OSF file:
getOSFfile <- function(
  code,  #Either "https://osf.io/XXXXX/" or just the code
  dir = getwd(), # Output location
  method = c("downloader","httr","curl") # First one is chosen
){
  # Check if input is code:
  if (!grepl("osf\\.io",code)){
    URL <- sprintf("https://osf.io/%s/",code)
  } else URL <- code
  
  # Scan page:
  Page <- RCurl::getURL(URL)
  
  # Extract download link(s):
  Link <- regmatches(Page, regexpr("(?<=download: \\').*?\\?action=download(?=\\')", Page, perl = TRUE))
  
  # Stop if no download link:
  if (length(Link)==0){
    stop("No download link found")
  }
  # (just in case) if more than one, warning:
  if (length(Link)>1){
    warning("Multiple download links found, only first is used")
    Link <- Link[1]
  }
  
  # Full link:
  Link <- paste0("https://osf.io/",Link)
  
  # Estract file name:
  FileName <- gsub("(^.*files/)|(\\/\\?action=download$)","",Link)
  FullPath <- paste0(dir,"/",FileName)
  
  # Download file:
  if (method[[1]]=="httr"){
    library("httr")
    httr::GET(Link, httr::write_disk(FullPath, overwrite = TRUE))
  } else if (method[[1]]=="downloader"){
    library("downloader")
    downloader:::download(Link, destfile = FullPath, quiet=TRUE)
  } else if (method[[1]]=="curl"){
    system(sprintf("curl -J -L %s > %s", Link, FullPath), ignore.stderr = TRUE) 
  }  
  
  # Return location of file:
  return(FullPath)
}

padNA <- function (mydata, rowsneeded, first = TRUE) 
{
  temp1 = colnames(mydata)
  rowsneeded = rowsneeded - nrow(mydata)
  temp2 = setNames(
    data.frame(matrix(rep(NA, length(temp1) * rowsneeded), 
                      ncol = length(temp1))), temp1)
  if (isTRUE(first)) rbind(mydata, temp2)
  else rbind(temp2, mydata)
}

dotnames <- function(...) {
  vnames <- as.list(substitute(list(...)))[-1L]
  vnames <- unlist(lapply(vnames,deparse), FALSE, FALSE)
  vnames
}

Cbind <- function(..., first = TRUE) {
  Names <- dotnames(...)
  datalist <- setNames(list(...), Names)
  nrows <- max(sapply(datalist, function(x) 
    ifelse(is.null(dim(x)), length(x), nrow(x))))
  datalist <- lapply(seq_along(datalist), function(x) {
    z <- datalist[[x]]
    if (is.null(dim(z))) {
      z <- setNames(data.frame(z), Names[x])
    } else {
      if (is.null(colnames(z))) {
        colnames(z) <- paste(Names[x], sequence(ncol(z)), sep = "_")
      } else {
        colnames(z) <- paste(Names[x], colnames(z), sep = "_")
      }
    }
    padNA(z, rowsneeded = nrows, first = first)
  })
  do.call(cbind, datalist)
}

vertices2RNeo4j <- function(graph, vertex.table, label=NULL){
  require(RNeo4j)
  if(!(is.null(label))){
    names(vertex.table)[names(vertex.table) == label] <- ".label"
    vertex.table <- vertex.table[, c(".label", setdiff(names(vertex.table), ".label"))]
  }
  arg.names <- names(vertex.table)
  transposed.df <- as.data.frame(t(vertex.table), stringsAsFactors = F)
  v.list <- lapply(transposed.df, function(item){
    arg.list <-  as.list(item)
    names(arg.list) <- arg.names
    arg.list <- c(list(graph = graph), arg.list)
    do.call("createNode", arg.list)
  }) 
  names(v.list) <- lapply(v.list, function(node) node$ID)
  v.list
}
edges2RNeo4j <- function(graph, edge.table, vertex.list, type){
  require(RNeo4j)
  el.names <- names(edge.table)
  transposed.df <- as.data.frame(t(edge.table), stringsAsFactors=F)
  e.list <- lapply(transposed.df, function(rel){
    names(rel) <- el.names
    #I'll need some error checking to check presence of the edges, though I can do that with graph.data.frame
    arg.list <- list(.fromNode = vertex.list[[rel["from"]]],
                     .relType = as.character(rel[type]),
                     .toNode = vertex.list[[rel["to"]]])
    property.list <- as.list(rel[setdiff(names(rel), c("from", type, "to"))])
    arg.list <- c(arg.list, property.list)
    do.call("createRel", arg.list)
  })
  edge.names <- apply(edge.table[, c("from", "to")], 1, function(edge){
    paste(edge, collapse="->")
  })
  names(e.list) <- edge.names
  e.list
}

# ggplot2 をベースにしたペアプロットのサンプル
install.packages("GGally")
library(GGally)
airquality$Month <- as.factor(airquality$Month)
airquality <- airquality[, colnames(airquality) != "Day"]
ggpairs(na.omit(airquality), lower=list(continuous="smooth"), colour="Month", params=list(corSize=6,labelSize=10))

library(RCurl)
library(XML)
library(plyr)

#' get the Qualys SSL Labs rating for a domain+cert
#' 
#' @param site domain to test SSL configuration of
#' @param ip address of \code{site} (will resolve it and take\cr
#'  first response if not specified, but that may not always work as you expect)
#' @param hide.results ["on"|"off"] should the results show up in the SSL Labs history (default "on")
#' @param pause timeout between tries (default 5s)
#' @param curl.opts options to pass to \code{getURL} i.e. proxy setting
#' @return data frame of results
#' 


get_rating <- function(site="rud.is", ip="", hide.results="on", pause=5, curl.opts=list()) {
  
  # try to resolve IP if not specified; if no IP can be found, return
  # a "NA" data frame
  
  if (ip == "") {
    tmp <- nsl(site)
    if (is.null(tmp)) { return(data.frame(site=site, ip=NA, Certificate=NA, 
                                          Protocol.Support=NA, Key.Exchange=NA, Cipher.Strength=NA)) }
    ip <- tmp
  }
  
  # need to let it actually process the certificate if not already cached
  
  rating.dat <- getURL(sprintf("https://www.ssllabs.com/ssltest/analyze.html?d=%s&s=%s&ignoreMismatch=on&hideResults=%s", site, ip, hide.results), .opts=curl.opts)
  while(!grepl("(Overall Rating|Assessment failed)", rating.dat)) {    
    Sys.sleep(pause)
    rating.dat <- getURL(sprintf("https://www.ssllabs.com/ssltest/analyze.html?d=%s&s=%s&ignoreMismatch=on&hideResults=%s", site, ip, hide.results), .opts=curl.opts)
  }
  
  if (grepl("Assessment failed", rating.dat)) {
    return(data.frame(site=site, ip=NA, Certificate=NA, 
                      Protocol.Support=NA, Key.Exchange=NA, Cipher.Strength=NA))
  }
  
  x <- htmlTreeParse(rating.dat, useInternalNodes = TRUE)
  
  # sometimes there is a <span ...> tag in the <div>, which will result in an
  # empty list() object being returned. we check for that and handle it
  # appropriately.
  
  rating <- xmlValue(x[["//div[starts-with(@class,'rating_')]/text()"]])
  if (class(rating) == "list") {
    rating <- xmlValue(x[["//div[starts-with(@class,'rating_')]/span/text()"]])
  }
  
  # extract the XML objects for the ratings labels & values
  
  labs <- getNodeSet(x,"//div[@class='chartBody']/div[@class='chartRow']/div[@class='chartLabel']")
  vals <- getNodeSet(x,"//div[@class='chartBody']/div[@class='chartRow']/div[starts-with(@class,'chartValue')]")
  
  # convert them to vectors
  
  labs <- xpathSApply(labs[[1]], "//div[@class='chartLabel']/text()", xmlValue)
  vals <- xpathSApply(vals[[1]], "//div[starts-with(@class,'chartValue')]/text()", xmlValue)
  
  # make them into a data frame
  
  rating.result <- data.frame(site=site, ip=ip, rating=rating, rbind(vals), row.names=NULL)
  colnames(rating.result) <- c("site", "ip", "rating", gsub(" ", "\\.", labs))
  
  return(rating.result)
  
}

sites <- c("rud.is", "stackoverflow.com", "er-ant.com")
ratings <- ldply(sites, get_rating)
ratings
##                site              ip rating Certificate Protocol.Support Key.Exchange Cipher.Strength
## 1            rud.is  184.106.97.102      B         100               70           80              90
## 2 stackoverflow.com 198.252.206.140      A         100               90           80              90
## 3        er-ant.com            <NA>   <NA>        <NA>             <NA>         <NA>            <NA>

one <- seq(1:10)
two <- rnorm(10)
three <- runif(10, 1, 2)
four <- -10:-1

df <- data.frame(one, two, three)
df2 <- data.frame(one, two, three, four)

str(df)

names.df <- colnames(df)
names.df.2 <- c("one", "two", "three")

#install.packages("dplyr")
library(dplyr)

select_(df2, names.df)           # no - only first variable name
select_(df2, names.df.2)         # no - only first variable name
select(df2, one_of(names.df))    # success
select(df2, one_of(names.df.2))  # success