futils: Farid utility functions

#' modulus
#'
#' @param a
#' @param b
#'
#' @return
#' @export
#'
#' @examples
#' a <- c(-90,90,-400,400,5)
#' b <- c(360,-360,360,-360,2)
#' all("%%"(a,b) == modulus(a,b))
#' all("%/%"(a,b) == quotient(a,b))
modulus <- function(a,b){
  a-floor(a/b)*b
}
#' quotient
#'
#' @param a
#' @param b
#'
#' @return
#' @export
#'
#' @examples
quotient <- function(a,b){
  floor(a/b)
}

#' call python code
#'
#' @return
#' @export
#'
#' @examples
#' call_python
call_python <- function() {
  rlog <- system.file("pictures/Rlogo.jpg",package = "rgdal")
  shp_exp <- "D:/shp_export"
  pscript <- system.file("python/arcgis_gp.py",package = "futils")

  arguments <- sprintf('"%1$s" "%2$s" "%3$s"',
                      normalizePath(pscript),
                      normalizePath(rlogo),
                      normalizePath(shp_exp))
  system.time(system2('python', args=arguments))
}


#' string join
#'
#' @param a
#' @param b
#'
#' @return
#' @export
#'
#' @examples
#' "new" %++% " string"
`%++%` <- function(a, b) {paste(a, b, sep = "")}

#' treat formula input
#'
#' @param x
#'
#' @return
#' @export
#'
#' @examples
#' x <- 1:5
#' y <- 5:1
#' plot_formula(y~x)
plot_formula <- function(x)
{
  if (is.language(x)) {
    if (inherits(x, "formula") && length(x) == 3) {
      ylab <- deparse(x[[2L]])
      xlab <- deparse(x[[3L]])
      y <- eval(x[[2L]], environment(x))
      x <- eval(x[[3L]], environment(x))
      plot(y,x)
    }
    else stop("invalid first argument")
  }
}

#' replacement function
#'
#' @param x
#' @param value
#'
#' @return
#' @export
#'
#' @examples
#' xx <- c(NA,1:5)
#' second(xx) <- 3
`second<-` <- function(x,value){
  x[2] <- value
  x
}

#' remove nulls from list
#'
#' @param x list with nulls
#'
#' @return list without nulls
#' @export
#'
#' @examples
rm_list_nulls <- function(x) {
  x <- Filter(Negate(is.null), x)
  lapply(x, function(x) if (is.list(x)) Recall(x) else x)
}

#' get column index
#' @description This functions gets the column indices of a dataframe by column names. it also works
#' even if you don't surround the column names with double quotation.
#' @param x
#' @param select
#'
#' @return
#' @export
#'
#' @examples
#' get_col_idx(cheetah,c("time","lat"))
#' get_col_idx(cheetah,c(time,lat))
get_col_idx <- function(x, select)
{
  vars <- if (missing(select))
    Stop("Must specify select")
  else {
    nl <- as.list(seq_along(x))
    names(nl) <- names(x)
    eval(substitute(select), nl, parent.frame())
  }

  if (inherits(vars,"character"))
  {
    # order is not maintained
    vars <- which(names(x) %in% select)
  }

  return(vars)
}

#' between infix operator
#'
#' @param x numerical vector
#' @param rng range
#'
#' @return logical vector
#' @export
#'
#' @examples
#' rnorm(10) %between% c(0,1)
`%between%`<-function(x,rng) {x>=rng[1] & x<=rng[2]}

#' if null then
#' @description it's an infix function
#' @param a a call to a function or expression
#' @param b if a is NULL b is returned
#'
#' @return
#' @export
#'
#' @examples
#' NULL %||% 2
`%||%` <- function(a, b) {if (!is.null(a)) a else b}

#' hijack function
#'
#' @param FUN function to hijack
#' @param ...
#'
#' @return hijacked function
#' @export
#'
#' @examples
#' .data.frame <- hijack(data.frame, stringsAsFactors = FALSE)
#' dat <- .data.frame(x1 = 1:3, x2 = c("a", "b", "c"))
#' str(dat)
#' .data.frame(x1 = 1:3, x2 = c("a", "b", "c"), stringsAsFactors = TRUE)
hijack <- function (FUN, ...) {
  .FUN <- FUN
  args <- list(...)
  invisible(lapply(seq_along(args), function(i) {
    formals(.FUN)[[names(args)[i]]] <<- args[[i]]
  }))
  .FUN
}

#' Recycle vectors
#'
#' @param ... atomic vectors
#'
#' @return
#' @export
#'
#' @examples
#' a <- 1:10
#' b <- 1:3
#' recycle_args(a,b)
recycle_args <- function(...){
  dots <- list(...)
  max_length <- max(sapply(dots, length))
  lapply(dots, rep, length.out = max_length)
}

#' Package Info
#' @description install packages that are locally from
#' "D:/Uni/thesis/R_Code/_Packages/R/src/contrib". github packges are installed from
#' "D:/Uni/thesis/R_Code/_Packages/github"
#' @param pname Package name
#' @param github whether to install packages downloaded from github
#'
#' @return no return value
#' @export
#'
#' @examples
#' install("glmnet")
install <- function(pname, github=FALSE)
{
  #p <- getOption("repos")
  p <- "file:D:/Uni/Thesis/R_Code/_Packages/R"
  if(!github)
  {
    install.packages(pname,type="source",repos = p)
  }
  else
  {
    p2 <- paste0(dirname(getOption("repos")),"/github")
    fa <- file.access(paste(p2,"/",pname,".zip",sep=''))
    if (fa ==-1)
      fa <- file.access(paste(p2,"/",pname,"-master", ".zip",sep=''))
      if(fa==-1)
        stop("Zip Package Not Found!")
      else
        pname <- paste(pname,"-master",sep = '')

    #t <- tempfile()
    cat("Unzipping...\n")
    a <- unzip(paste(p2,"/",pname,".zip",sep='') ,exdir = p2)
    #q <- dirname(a)[1]

    install.packages(paste(p2,"/",pname,sep=''), type = "source",repos=NULL)
    cat("Cleaning...")
    unlink(paste(p2,"/",pname,sep=''), recursive = TRUE)
  }
}


#' Package Info
#' @description Prints out package version, vignettes, data and demos
#' @param pname package name to be queried
#'
#' @return prints out the package information
#' @export
#'
#' @examples
#' pinfo("futils")
pinfo <- function(pname){
  pname <- deparse(substitute(pname))
  v<-vignette(package=pname)
  cat("vignette:\n")
  print(v$results[,3])

  v<-data(package=pname)
  cat("data:\n")
  print(v$results[,3])

  v<- demo(package = pname)
  cat("demo:\n")
  print(v$results[,3])

  cat("version:\n")
  print(packageVersion(pname))

  #cat("citation:\n")
  #print(citation(pname))

}

# improved list of objects
.ls.objects <- function (pos = 1, pattern, order.by,
                         decreasing=FALSE, head=FALSE, n=5) {
  napply <- function(names, fn) sapply(names, function(x)
    fn(get(x, pos = pos)))
  names <- ls(pos = pos, pattern = pattern)
  obj.class <- napply(names, function(x) as.character(class(x))[1])
  obj.mode <- napply(names, mode)
  obj.type <- ifelse(is.na(obj.class), obj.mode, obj.class)
  obj.prettysize <- napply(names, function(x) {
    capture.output(format(utils::object.size(x), units = "auto")) })
  obj.size <- napply(names, object.size)
  obj.dim <- t(napply(names, function(x)
    as.numeric(dim(x))[1:2]))
  vec <- is.na(obj.dim)[, 1] & (obj.type != "function")
  obj.dim[vec, 1] <- napply(names, length)[vec]
  out <- data.frame(obj.type, obj.size, obj.prettysize, obj.dim)
  names(out) <- c("Type", "Size", "PrettySize", "Rows", "Columns")
  if (!missing(order.by))
    out <- out[order(out[[order.by]], decreasing=decreasing), ]
  if (head)
    out <- head(out, n)
  out
}

#' @export
lsos <- function(..., n=10) {
  .ls.objects(..., order.by="Size", decreasing=TRUE, head=TRUE, n=n)
}


#' Pseudo-Inverse of Matrix
#' @description
#' This is the modified version of ginv function in MASS package.
#' It produces MATLAB like pseudo-inverse of a matrix
#' @param X The matrix to compute the pseudo-inverse
#' @param tol The default is the same as MATLAB pinv function
#'
#' @return The pseudo inverse of the matrix
#' @export
#'
#' @examples
#' A <- matrix(1:6,3,2)
#' pinv(A)
pinv <- function (X, tol = max(dim(X)) * max(X) * .Machine$double.eps)
{
  if (length(dim(X)) > 2L || !(is.numeric(X) || is.complex(X)))
    stop("'X' must be a numeric or complex matrix")
  if (!is.matrix(X))
    X <- as.matrix(X)
  Xsvd <- svd(X)
  if (is.complex(X))
    Xsvd$u <- Conj(Xsvd$u)
  Positive <- any(Xsvd$d > max(tol * Xsvd$d[1L], 0))
  if (Positive)
    Xsvd$v %*% (1 / Xsvd$d * t(Xsvd$u))
  else
    array(0, dim(X)[2L:1L])
}

#' Feature Normalize
#'
#' @param X The dataframe or matrix to normalize
#'
#' @return The normalized object with mean 0 and sd 1.
#' @export
#' @details This function Normalizes the features in X
#'  and returns a normalized version of X where
#'  the mean value of each feature is 0 and the standard deviation
#'  is 1. This is often a good preprocessing step to do when
#'  working with learning algorithms.
#' @examples
#' A <- matrix(1:6,3,2)
#' scale(A) == featureNormalize(A)$X_norm
featureNormalize  <- function(X) {
  mu <- colMeans(X)
  #vectorized multivariate apply
  X_norm <- matrix(mapply(`-`,t(X),mu),dim(X) ,byrow = TRUE)
  sigma <- apply(X,2,sd)
  X_norm <- matrix(mapply(`/`,t(X_norm),sigma),dim(X) ,byrow = TRUE)
  list(X_norm = X_norm, mu = mu, sigma = sigma)
}


#' install_if_not
#'
#' @param pkgs
#'
#' @return
#' @export
#'
#' @examples
install_if_not <- function(pkgs=c("lubridate","ggplot2"))
{
  new.packages <- pkgs[!(pkgs %in% installed.packages()[,"Package"])]
  if(length(new.packages))
    install.packages(new.packages)
}