gjdevtools.R

#' Release an R package to our local repository on ourserver
#'
#' from where it can then be installed (without this package) by
#' install.packages(pkg,repos='http://ourserver.com/R',type='source')
#' 
#' Modified from release function in devtools.
#' @param pkg package description see \link[devtools]{release}
#' @param check if TRUE, run checking, otherwise omit it. This is useful if 
#'   you've just checked your package and you're ready to release it.
#' @param user defaults to myuser
#' @param host defaults to ourserver
#' @param remoteroot file system path on remote machine to repository root
#' @return silently returns logical indicating build/upload success
#' @author jefferis
#' @seealso \code{\link[devtools]{release}}
#' @export
gjrelease<-function (pkg = '.', check = TRUE, 
    user='myuser', host="ourserver.com",
    remoteroot="/var/www/html/R") 
{
  pkg <- as.package(pkg)
  if (check) {
    check(pkg)
    cat("Was package check successful?")
    if (menu(c("Yes", "No")) == 2) 
      return(invisible())
  }
  try(print(show_news(pkg)))
  cat("Is package news up-to-date?")
  if (menu(c("Yes", "No")) == 2) 
    return(invisible())
  cat(readLines(file.path(pkg$path, "DESCRIPTION")), sep = "\n")
  cat("Is DESCRIPTION up-to-date?")
  if (menu(c("Yes", "No")) == 2) 
    return(invisible())
  cat("Have you pushed your git repository?")
  if (menu(c("Yes", "No","I still have't version controlled (shame on me!)")) == 2) 
    return(invisible())
  message("Building")
  built_path <- build(pkg, tempdir())
  message("and uploading to ",host)
  remotepath=file.path(remoteroot,'src','contrib',fsep='/')
  uploaded=scpUpload(built_path,user,host,remotepath)
  if(uploaded!=0){
    warning("Package upload failed")
    return(invisible(FALSE))
  }
  # Appears that we need to update PACKAGES files in two separate locations
  # update PACKAGES file in root directory (for available.packages)
  rootcmd = paste('cd',remoteroot,
      '&& R --quiet --vanilla -e',
      '"tools::write_PACKAGES(subdirs=TRUE,fields=c(\'Title\',\'Description\'))"')
  # update PACKAGES in source directory (for install.packages)
  srccmd = paste('cd',remotepath,
      '&& R --quiet --vanilla -e "tools::write_PACKAGES()"')
  packagelistupdated = runRemoteCommands(c(rootcmd,srccmd), user = user,
      host = host)
  if(packagelistupdated!=0){
    warning("Package list update failed")
    return(invisible(FALSE))
  }
  
  message("Preparing email")
  msg <- paste(
      "Hi chaps,\n",
      "\n",
      "I have just uploaded a new version of ", pkg$package, " to our lab repo.\n",
      "\n",
      "Update by doing this:\n",
      "  install.packages('",pkg$package,"',repos='http://ourserver.com/R',type='source'),\n",
      "and test (in a new R session) e.g.\n",
      "  library(",pkg$package,")\n",
      "\n",
      "Let me know if anything breaks and I will fix and add tests to ensure this doesn't happen again.\n",
      "Best,\n",
      "Greg", "\n", sep = "")
  
  # add package news if available
  tc=textConnection('news',open = 'w', local = TRUE)
  sink(tc)
  on.exit(sink())
  on.exit(close(tc),add = TRUE)
  t=try(print(show_news(pkg)))
  if(!inherits(t,'try-error'))
    msg=c(msg,paste(news,collapse="\n"),"\n")
  
  # actually make email
  subject <- paste(pkg$package, " ", pkg$version, sep = "")
  create.post(msg, subject = subject, address = "jlab")
  
  invisible(TRUE)
}

scpUpload<-function(localpath,user,host,remotepath,target){
  if(missing(target)) target=sprintf('%s@%s:%s',user,host,remotepath) 
  system(paste('scp',shQuote(path.expand(localpath)),target))
}

runRemoteCommands<-function(cmd,user,host){
  if(length(cmd)>1){
    return(all(sapply(cmd,runRemoteCommands,user,host)))
  }
  system(paste('ssh ',sep="",user,'@',host,' ',shQuote(cmd)))
}