R/viz.R

Defines functions gen_contour_levels cut_rainbow_color colored_annot_tracks_gg colored_tracks plot_line_color identifyPch panel.hist panel.cor panel.scatter pairsPlus

# spaced logarithmically between 0.01 and 100.logarithmic contours are denser near the center
gen_contour_levels <- function(x,y,z,xyscale,nlev=10)
{
  idx <- which((x %between% xyscale) & (y %between% xyscale))
  r <- range(z[idx])
  return(seq(r[1],r[2],length.out=nlev))
}

#' cut rainbow color
#'
#' @param x
#' @param nbcol
#'
#' @return
#' @export
#'
#' @examples
cut_rainbow_color <- function(x=rnorm(100),nbcol=100) {
  color = rev(rainbow(nbcol, start = 0/6, end = 4/6))
  cols  = cut(x, nbcol)
  color[cols]
}

#' colored_annot_tracks_gg
#' @description Colored annotated ggplot based plot of movement data
#'
#' @param tracks_list
#' @param X
#' @param Y
#' @param size
#' @param color
#'
#' @return
#' @export
#'
#' @examples
colored_annot_tracks_gg <- function(tracks_list,fields=c(lon,lat,size,color))
{
  library(ggplot2)
  df <- plyr::ldply(tracks_list)

  vars <- {
    nl <- as.list(seq_along(df))
    names(nl) <- names(df)
    eval(substitute(fields), nl, parent.frame())
  }

  ggplot(df, aes(x = vars[1], y = ,
                          size=, col = )) +
  geom_path(lwd = 1) + geom_point()
}

#' colored tracks plot
#'
#' @param tracks_list
#' @param X
#' @param Y
#'
#' @return
#' @export
#'
#' @examples
#' colored_tracks (Eagles,"Longitude","Latitude")
colored_tracks <- function(tracks_list, X="lon",Y="lat") {
  library(maps)
  #maps::map
  #plyr::ldply
  #alpha_col(2, 0.5) gives a transparent color (1,0,0,.5)
  if (is.null(names(tracks_list)))
    stop("list without names")

  ids <- names(tracks_list)
  df <- plyr::ldply(tracks_list)

  maps::map("world", xlim = range(df[,X],na.rm = T)+c(-.1,.1), ylim = range(df[,Y],na.rm = T)+c(-.1,.1),
            fill=TRUE, col="lightgrey", bor="grey")

  lapply(1:length(tracks_list), function(i){
    e <- tracks_list[[i]]
    lines(e[,X], e[,Y], pch=19, type="o",col=alpha_col(i, 0.5), cex=0.5)}
    )

  legend("bottomright", legend=ids, col=1:length(ids), pch=19, cex=0.8, bty="n")
  box()
}

#' Plot color lines
#'
#' @param x
#' @param y
#' @param fact a factor variable to be used for coloring
#' @param lwd line width
#' @param ... params to pass to the lines function
#'
#' @return
#' @export
#'
#' @examples
#' k <- 1:5
#' x <- seq(0,10,length.out =  100)
#' dsts <- lapply(1:length(k), function(i) cbind(x=x, distri=dchisq(x,k[i]),fact=i) )
#' dsts <- do.call(rbind,dsts)
#' plot_line_color(x=dsts[,1],y=dsts[,2],fact=dsts[,3]),legend_draw=T)
plot_line_color <- function(x,y,fact,type='n',lwd=2,legend_draw=F,...)
{
  plot(x,y,col=fact,pch=19,type=type)
  xy <- cbind(x,y)
  facts <- unique(fact)
  invisible(
    lapply(seq_along(fact), function(j) {
      xy2 <- subset(xy,fact==j)
      lines(xy2[ ,1],xy2[,2],col=j,lty=j,lwd=lwd,...)
    })
  )
  if (legend_draw)
    legend("topright",legend=facts,col=1:length(facts),lty=1:length(facts),
         bty = "n",bg="transparent")

  grid()
}


#' identify pch
#' @describeIn A function to use identify to select points, and overplot the
#' points with another symbol as they are selected
#' @param x
#' @param y
#' @param n
#' @param pch
#' @param ...
#'
#' @return
#' @export
#'
#' @examples
#' x= 4:6
#' plot(x, y, pch = 1, lty = 1, type = "o", ylim=c(-2,2), bty='L')
#' identifyPch(x,y)
identifyPch <- function(x, y = NULL, n = length(x), pch = 19, ...)
{
  xy <- xy.coords(x, y); x <- xy$x; y <- xy$y
  sel <- rep(FALSE, length(x)); res <- integer(0)
  while(sum(sel) < n) {
    ans <- identify(x[!sel], y[!sel], n = 1, plot = FALSE, ...)
    if(!length(ans)) break
    ans <- which(!sel)[ans]
    points(x[ans], y[ans], pch = pch)
    sel[ans] <- TRUE
    res <- c(res, ans)
  }
  res
}

#used by pairsplus
panel.hist <- function(x,right=FALSE,diagCol=5,linefun=mean, ...)
{
  usr <- par("usr"); on.exit(par(usr))
  par(usr = c(usr[1:2], 0, 1.5) )
  h <- hist(x,plot = FALSE)
  breaks <- h$breaks; nB <- length(breaks)
  y <- h$counts; y <- y/max(y)
  rect(breaks[-nB], 0, breaks[-1], y,col=diagCol,   ...)
  abline(v=linefun(x),col=2)
}

#used by pairsplus
panel.cor <- function(x, y, digits=2, prefix="", corcex=0.5,method="pearson", ...)
{
  usr <- par("usr"); on.exit(par(usr))
  par(usr = c(0, 1, 0, 1))
  r <- (cor(x, y,method=method,use="pairwise.complete.obs"))
  txt <- format(c(r, 0.123456789), digits=digits)[1]
  txt <- paste(prefix, txt, sep="")
  if(missing(corcex)) corcex <- 0.8/strwidth(txt)
  text(0.5, 0.5, txt, cex = corcex * sqrt(abs(r))+0.5)
}

#used by pairsplus
panel.scatter <- function(x,y,fitcurve='linear',fitcol=2,crossx=0,crossy=0,...) {
  points(x,y,...)

  if(fitcurve=='linear')
  {
    abline(lsfit(x,y),col=fitcol)

  } else if(fitcurve=='crosshairs') {

    abline(h=crossy,col=fitcol)
    abline(v=crossx,col=fitcol)

  } else if(fitcurve=='spline') {
    abline(smooth.spline(x,y),col=fitcol,...)
  }
}

#' pairs plot
#' @description fancy pairs plot of a dataframe. uses `pairs` internally.
#' @param x a numeric dataframe
#' @param diag.panel
#' @param diagCol
#' @param fitcurve
#' @param ...
#'
#' @return
#' @export
#'
#' @examples pairsPlus(cars)
pairsPlus<-function(x,diag.panel=panel.hist,diagCol=4,fitcurve='linear',...)
{pairs(x,diag.panel=diag.panel,upper.panel=panel.cor,lower.panel=panel.scatter,...)}
faridcher/futils documentation built on May 22, 2019, 12:42 p.m.