# 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,...)}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.