R/htbPlotHis.R
In keimochizuki/htb: Read and Analyze Neural Activities Acquired by TEMPO System
Defines functions
htbGetPop
htbPlotHis
Documented in
htbPlotHis
#' Drawer of raster/histograms
#'
#' Draws a raster/histogram from htbRas and/or htbHis objects.
#'
#' [htbPlotHis()] plots rastergrams and histograms from
#' provided `htbRas` and/or `htbHis` objects.
#' Multiple set of objects can be provided to
#' `his` and `ras` arguments as lists of
#' `htbHis` and `htbRas` objects, respectively,
#' which are then plotted as panels horizontally aligned
#' in the same one plot.
#' Since this function has become somewhat hypertrophic,
#' a decomposition of the function is intended in the near future.
#'
#' @param his A list of `htbHis` object(s).
#' @param ras A list of `htbRas` object(s).
#' @param index Integers. Indices of conditions to be plotted.
#' @param prop Numeric vector of length three.
#' The three values respectively determine
#' 1) the proportion of height (from the top) occupied by rastergrams,
#' 2) the proportion of height (from the bottom) occupied by histograms,
#' and 3) approximate number of raster lines.
#' These parameters are then used to automatically set
#' the magnification of vertical axis for plotting.
#' @param xlim A list of numeric vectors all of which are length two.
#' Each element determines the xlim (`c(from, to)`)
#' of the corresponding panel included in the plot.
#' If not provided, original temporal limits used when creating
#' `htbRas` object (and further `htbHis` object) are used.
#' @param ylim A numeric vector of length two.
#' Since the vertical axis is kept unchanged for the panels
#' drawn in one [htbPlotHis()] call,
#' only a pair of two values (`c(from, to)`) is needed for `ylim`
#' (unlike the case of `xlim`).
#' Normally you don't need to explicitly designate this argument
#' so that the function automatically set an appropriate range.
#' @param histy A string. The type of the histogram drawing.
#' Default `l` draws histograms as lines,
#' which will suit the case when you have two or more conditions
#' to be drawn altogether in a same graph.
#' On the other hand, `h` will draw traditional building-like
#' filled histograms (that surely overlap with each other
#' and deteriorate the readability).
#' @param hiscol Strings. The colors of the histograms.
#' If not provided, the same set of colors were inherited from `rascol`.
#' If neither `hiscol` nor `rascol` is provided,
#' colors are automatically generated by [htb.colors()].
#' @param hislty Strings. The line types of the histograms.
#' @param hislwd Numerics. The line widths of the histograms.
#' @param hispch Either integers or strings.
#' The pointing characters used in the histogram legend.
#' @param hisname Strings. The names of the histograms used in the histogram legend.
#' @param hiscex Numerics. The magnification of points used in the histogram legend.
#' @param hisbty A string. The box type of the histogram legend.
#' @param hisleg A string. The keyword to locate the histogram legend
#' used as `legend` argument in [graphics::legend()].
#' If `NULL`, the histogram legend will not be drawn.
#' @param sdty A string. The type of the SD (or SE) ranges to draw
#' when plotting population histograms.
#' Default `n` omits SD information.
#' On the other hand, `l` draws it as upper and lower limits
#' (mean +/- SD) using parallelling lines using [graphics::lines()].
#' Also, `p` draws it by [graphics::polygon()] ,
#' resulting in belts with some widths.
#' Another option `b` results in a similar plot but draws it by
#' repetitive vertical lines with [graphics::segments()]
#' (like, so to say, centipede graphs, but be careful
#' not to search this word directly if you have acaraphobia.)
#' which will suit the case when you have two or more conditions
#' to be drawn altogether in a same graph.
#' On the other hand, `h` will draw traditional building-like
#' filled histograms (that surely overlap with each other
#' and deteriorate the readability).
#' @param sdcol Strings. The colors of the SD ranges.
#' If not provided, automatically generated by [htb.colors()].
#' @param sdlty Strings. The line types of the SD lines.
#' @param sdlwd Numerics. The line widths of the SD lines.
#' @param rasty A string. The type of the rastergrams.
#' Default `p` plots rasters by symbols pointed by [graphics::points()].
#' On the other hand, `l` draws them as vertical ticks
#' drawn by [graphics::segments()].
#' @param rascol Strings. The colors of the rastergrams.
#' If not provided, the same set of colors were inherited from `hiscol`.
#' If neither `hiscol` nor `rascol` is provided,
#' colors are automatically generated by [htb.colors()].
#' @param raspch A string. The point types of the rastergrams.
#' @param rassp A numeric. Amount of blank space inserted
#' between rastergrams of different conditions.
#' The value is treated as a number of blank lines
#' (i.e., multiplied by the height of one line in the rastergram).
#' @param nlines Numerics. Number of raster lines.
#' @param evcol Strings. The colors of the rastergrams.
#' If not provided,
#' colors are automatically generated by [grDevices::rainbow()].
#' @param evpch A numeric or string. The point types of the event dot
#' designated in the same code to the standard [graphics::points()].
#' @param evname Strings. The names of the task eventss used in the event legend.
#' @param evcex A numeric. The magnification of event points.
#' @param evbty A string. The box type of the event legend.
#' @param evleg A string. The keyword to locate the event legend
#' used as `legend` argument in [graphics::legend()].
#' If `NULL`, the event legend will not be drawn.
#' @param sqlim A numeric vector of length two.
#' When not `NULL`, a square shading is drawn
#' at designated xlim range (`c(from, to)`).
#' @param sqpanel An integer vector of length two
#' that indicates the panels from/to which the shading is drawn.
#' @param sqcol A string. The color of the shading area.
#' @param vlat A numeric. Location to which a vertical line
#' is drawn in *EACH* of the existing panels
#' (normally used to denote horizontal origins of each panel).
#' @param vlcol A string. The color of the vertical line(s).
#' @param vllty A string. The line types of the vertical line(s).
#' @param xlab A string. The label on the horizontal axis.
#' @param ylab A string. The label on the vertical axis.
#' @param bty A string. The box type of the whole plot.
#' @param las An integer. The direction of the axis labelling
#' used in [graphics::par()].
#' @param ... Other arguments passed to htbPlotWindow().
#'
#' @return Numerics. Amout of horizontal shifts of the panels
#' that can be used in additional graphical drawings.
#'
#' @examples
#' alignment <- list(CUEON_L = c(-1500, 2000), CUEON_R = c(-1500, 2000))
#' incld <- list(TRIALSTART = c(-2000, 0), TRIALEND = c(0, 2000))
#' excld <- list(ERROR = c(0, 2000))
#'
#' \dontrun{
#' db_sp <- htbGetDb("spike.htb")
#' db_ev <- htbGetDb("event.htb")
#' ras <- htbGetRas(db_sp, db_ev, alignment,
#' incld = incld, excld = excld)
#' his <- htbGetHis(ras)
#' htbPlotHis(his)
#' }
#'
#' @keywords hplot
#'
#' @export
htbPlotHis <- function(
his = NULL,
ras = NULL,
index = NULL,
prop = c(0.8, 0.4, 50),
xlim = NULL,
ylim = NULL,
histy = "l",
hiscol = NULL,
hislty = "solid",
hislwd = 2,
hispch = 15,
hisname = NULL,
hiscex = 0.5,
hisbty = "o",
hisleg = "bottomright",
sdty = "n",
sdcol = NULL,
sdlty = "22",
sdlwd = 1,
rasty = "p",
rascol = NULL,
raspch = ".",
rassp = 2,
nlines = NULL,
evcol = NULL,
evpch = 15,
evname = NULL,
evcex = 0.5,
evbty = "o",
evleg = "topright",
sqlim = NULL,
sqpanel = c(1, 1),
sqcol = "gray90",
vlat = NULL,
vlcol = "gray30",
vllty = "solid",
xlab = "Time [ms]",
ylab = NULL,
bty = "l",
las = 1,
...
) {
if ((!is.null(his)) && (class(his) %in% c("htbHis", "htbRoc"))) {
his <- list(his)
}
if ((!is.null(ras)) && (class(ras) == "htbRas")) {
ras <- list(ras)
}
if (!is.null(index)) {
if (!is.null(his)) {
his <- lapply(X = his, FUN = htbExtractCond, index)
}
if (!is.null(ras)) {
ras <- lapply(X = ras, FUN = htbExtractCond, index)
}
}
npanel <- max(length(his), length(ras))
if (npanel == 0) {
stop("htbPlotHis: Neither his/ras provided")
}
ncond_his <- sapply(X = his, FUN = function(z) { length(z$da$y) })
ncond_ras <- sapply(X = ras, FUN = function(z) { length(z$da) })
ntrl_ras <- lapply(X = ras, FUN = function(z) {
sapply(X = z$da, FUN = length) })
if (!is.null(ras)) {
rassptotal <- (ncond_ras - 1) * rassp
if (is.null(nlines)) {
nlines <- mapply(FUN = function(ncond, yspt) {
table(rep(1:ncond, length.out = prop[3] - yspt))
}, ncond_ras, rassptotal, SIMPLIFY = FALSE)
} else if (any(nlines == "all")) {
nlines <- ntrl_ras
prop[3] <- max(sapply(X = nlines, FUN = sum) + rassptotal)
}
nlines <- rep(nlines, length.out = npanel)
nlines <- mapply(FUN = function(a, b) {
pmin(a, b) }, nlines, ntrl_ras, SIMPLIFY = FALSE)
}
if (is.null(hiscol) && !is.null(rascol)) {
hiscol <- rascol
} else if (is.null(rascol) && !is.null(hiscol)) {
rascol <- hiscol
}
reppar <- function(tmpp, tmpn) {
if (!is.list(tmpp)) {
tmpp <- list(tmpp)
}
mapply(FUN = function(x, y) {
rep(x, length.out = y)
}, rep(tmpp, length.out = npanel), tmpn, SIMPLIFY = FALSE)
}
if (!is.null(his)) {
if (is.null(hiscol)) {
hiscol <- lapply(X = ncond_his, FUN = htb.colors)
}
hiscol <- reppar(hiscol, ncond_his)
hislty <- reppar(hislty, ncond_his)
hislwd <- reppar(hislwd, ncond_his)
if (is.null(sdcol)) {
sdcol <- hiscol
}
sdcol <- reppar(sdcol, ncond_his)
sdlty <- reppar(sdlty, ncond_his)
sdlwd <- reppar(sdlwd, ncond_his)
}
if (!is.null(ras)) {
if (is.null(rascol)) {
rascol <- lapply(X = ncond_ras, FUN = htb.colors)
}
rascol <- reppar(rascol, ncond_ras)
}
if (is.null(xlim)) {
xlim <- list()
for (i in 1:npanel) {
hp <- lapply(X = his[[i]]$param, FUN="[[", "xlim")
rp <- lapply(X = ras[[i]]$param, FUN="[[", "xlim")
xlim[[i]] <- range(unlist(rp), unlist(hp), na.rm = TRUE)
}
} else if (!is.list(xlim)) {
xlim <- list(xlim)
}
xlim <- rep(xlim, length.out = npanel)
if (is.null(ras)) {
prop[1] <- 1
}
if (is.null(his)) {
prop[2] <- 1
}
if (!is.null(his)) {
h <- unlist(mapply(FUN = function(tmphis, tmpxlim) {
i <- (tmphis$da$x >= tmpxlim[1]) & (tmphis$da$x <= tmpxlim[2])
y <- sapply(X = tmphis$da$y, FUN="[", i)
if ((sdty != "n") && any(names(tmphis$da) == "s")) {
s <- sapply(X = tmphis$da$s, FUN="[", i)
y <- c(y - s, y + s)
}
return(y)
}, his, xlim))
}
if (is.null(ylim)) {
if (!is.null(his)) {
ylim <- c(0, max(h, na.rm = TRUE))
} else if (prop[2] == 1) {
ylim <- c(0, max(sapply(X = nlines, FUN = sum) + rassptotal))
} else {
ylim <- c(0, 1)
}
} else if (ylim[1] == "auto") {
ylim <- range(h, na.rm = TRUE)
}
ylim[2] <- ylim[1] + diff(ylim) / prop[1]
ysep <- diff(ylim) * prop[2] / prop[3]
if (is.null(evname)) {
evname <- lapply(X = ras, FUN = function(z) { names(z$ev) })
evname <- unique(unlist(evname))
}
if (is.null(ylab) && !is.null(his)) {
ylab <- his[[1]]$param[[1]]$type
}
if (rasty=="p") {
raster <- function(x, y, pch = raspch, ...) {
graphics::points(x = x, y = y, pch = pch, ...) }
} else if (rasty=="l") {
#raster <- function(x, y, ...) {
raster <- function(x, y, pch = raspch, ...) {
graphics::segments(x0 = x, y0 = y, x1 = x, y1 = y-ysep, lend = "butt", ...) }
}
xshift <- htbPlotWindow(xlim = xlim, ylim = ylim, xlab = xlab, ylab = ylab,
sqlim = sqlim, sqpanel = sqpanel, sqcol = sqcol,
vlat = NULL, # Leave vertical lines later
bty = bty, las = las, ...)
usr <- graphics::par("usr")
n_ev <- 0
xs_ev <- list()
ys_ev <- list()
uni_ev <- NULL
for (i in 1:npanel) {
tmpras <- ras[[i]]
tmphis <- his[[i]]
da <- tmpras$da
ev <- tmpras$ev
param <- tmpras$param
if (!is.null(tmpras)) {
tmpy <- usr[4]
for (j in seq(along = da)) {
if (nlines[[i]][j] != 0) {
xs <- unlist(da[[j]][1:nlines[[i]][j]])
ys <- rep(seq(tmpy, tmpy - (nlines[[i]][j] - 1) * ysep, by = -ysep),
sapply(X = da[[j]][1:nlines[[i]][j]], FUN = length))
k <- (xs >= xlim[[i]][1]) & (xs <= xlim[[i]][2])
xs <- xs[k] + xshift[i]
ys <- ys[k]
raster(x = xs, y = ys, col = rascol[[i]][j])
}
tmpy <- tmpy - (nlines[[i]][j] + rassp) * ysep
}
if ((!is.null(ev)) && (sum(nlines[[i]]) != 0)) {
for (j in evname) {
if (!is.null(ev[[j]])) {
xs <- unlist(mapply(FUN = function(x, n) {
x[1:n] }, ev[[j]], nlines[[i]]))
ys <- seq(usr[4], usr[4] - (sum(nlines[[i]]) - 1) * ysep, by = -ysep) -
rep(seq(0, along = da), nlines[[i]]) * rassp * ysep
k <- (xs >= xlim[[i]][1]) & (xs <= xlim[[i]][2])
if (sum(k, na.rm = TRUE) == 0) {
next
}
n_ev <- n_ev + 1
xs_ev[[n_ev]] <- xs[k] + xshift[i]
ys_ev[[n_ev]] <- ys[k]
uni_ev[n_ev] <- j
}
}
}
}
if (!is.null(tmphis)) {
xs <- tmphis$da$x
k <- (xs >= xlim[[i]][1]) & (xs <= xlim[[i]][2])
xs <- xs[k] + xshift[i]
for (j in rev(seq(along = tmphis$da$y))) {
ys <- tmphis$da$y[[j]][k]
if (sdty %in% c("l", "b", "p")) {
ss <- tmphis$da$s[[j]][k]
ypm <- list(ys + ss, pmax(ys - ss, 0))
if (!is.null(ss)) {
if (sdty == "l") {
lapply(X = ypm, FUN=function(y) {
graphics::lines(xs, y, col = sdcol[[i]][j], lty = sdlty[[i]][j], lwd = sdlwd[[i]][j]) })
} else if (sdty == "b") {
graphics::segments(xs, ypm[[1]], y1 = ypm[[2]],
col = sdcol[[i]][j], lty = sdlty[[i]][j], lwd = sdlwd[[i]][j])
} else if (sdty == "p") {
graphics::polygon(c(xs, rev(xs)), c(ypm[[1]], rev(ypm[[2]])),
border = NA, col = sdcol[[i]][j])
}
}
}
if (histy == "h") {
b <- tmphis$param[[j]]$bin
graphics::rect(xs - b/2, 0, xs + b/2, ys, col = hiscol[[i]][j], border = hiscol[[i]][j])
} else {
graphics::lines(xs, ys, col = hiscol[[i]][j], lty = hislty[[i]][j], lwd = hislwd[[i]][j])
}
}
}
}
if (n_ev > 0) {
if (is.null(evcol)) {
evcol <- grDevices::rainbow(length(uni_ev))
} else {
evcol <- rep(evcol, length.out = n_ev)
}
raster(unlist(xs_ev), unlist(ys_ev), cex = evcex, pch = evpch,
col = rep(evcol, sapply(X = xs_ev, FUN = length)))
if (!is.null(evleg)) {
graphics::legend(x = evleg, legend = uni_ev, col = evcol,
pch = evpch, cex = evcex, bty = evbty, bg = "white", inset = 0.02)
}
}
if (!is.null(hisleg)) {
if (is.null(hisname) && (npanel == 1)) {
hisname <- sapply(X = his[[1]]$param, FUN = "[[", "title")
}
if (length(hisname) > 0) {
graphics::legend(x = hisleg, legend = hisname, col = hiscol[[1]],
pch = hispch, cex = hiscex, bty = hisbty, bg = "white", inset = 0.02)
}
}
if (!is.null(vlat)) {
if (!is.list(vlat)) {
vlat <- list(vlat)
}
vlpanel <- rep(seq(along = vlat), sapply(X = vlat, FUN = length))
vlat <- unlist(vlat)
nvl <- length(vlat)
vlcol <- rep(vlcol, length.out = nvl)
vllty <- rep(vllty, length.out = nvl)
graphics::segments(vlat + xshift[vlpanel], usr[3], y1 = usr[4],
col = vlcol, lty = vllty)
}
invisible(xshift)
}
htbGetPop <- function(
obj,
type = c("sd", "se"),
...
) {
obj <- obj[sapply(X = obj, FUN = length) != 0]
pop <- obj[[1]]
type <- type[1]
if (class(pop) == "htbHis") {
tmpx <- lapply(X = obj, FUN = function(tmphis) { tmphis$da$x })
if (!all(diff(sapply(X = tmpx, FUN = length)) == 0)) {
stop("htbGetPop: Numbers of time points differ between elements")
}
tmpx <- do.call(cbind, tmpx)
if (!all(apply(X = tmpx, MARGIN = 1, FUN = diff) == 0)) {
stop("htbGetPop: Time points differ between elements")
}
pop$da$s <- list()
for (i in seq(along = pop$da$y)) {
tmpy <- lapply(X = obj, FUN = function(tmphis) { tmphis$da$y[[i]] })
if (!all(diff(sapply(X = tmpy, FUN=length)) == 0)) {
stop("htbGetPop: Numbers of sample differ between elements")
}
tmpy <- do.call(cbind, tmpy)
tmpy <- tmpy[, !is.na(tmpy[1,]), drop = FALSE]
if (ncol(tmpy) == 0) {
pop$da$y[[i]] <- rep(NA, length(pop$da$x))
pop$da$s[[i]] <- rep(NA, length(pop$da$x))
next
} else {
pop$da$y[[i]] <- rowMeans(tmpy, na.rm = TRUE)
pop$da$s[[i]] <- apply(X = tmpy, MARGIN = 1, FUN = stats::sd, na.rm = TRUE) /
switch(type, sd = 1, se = sqrt(ncol(tmpy)))
}
}
names(pop$da$s) <- names(pop$da$y)
}
return(pop)
}
keimochizuki/htb documentation built on June 9, 2025, 10:03 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions htbGetPop htbPlotHis
Documented in htbPlotHis
#' Drawer of raster/histograms
#'
#' Draws a raster/histogram from htbRas and/or htbHis objects.
#'
#' [htbPlotHis()] plots rastergrams and histograms from
#' provided `htbRas` and/or `htbHis` objects.
#' Multiple set of objects can be provided to
#' `his` and `ras` arguments as lists of
#' `htbHis` and `htbRas` objects, respectively,
#' which are then plotted as panels horizontally aligned
#' in the same one plot.
#' Since this function has become somewhat hypertrophic,
#' a decomposition of the function is intended in the near future.
#'
#' @param his A list of `htbHis` object(s).
#' @param ras A list of `htbRas` object(s).
#' @param index Integers. Indices of conditions to be plotted.
#' @param prop Numeric vector of length three.
#' The three values respectively determine
#' 1) the proportion of height (from the top) occupied by rastergrams,
#' 2) the proportion of height (from the bottom) occupied by histograms,
#' and 3) approximate number of raster lines.
#' These parameters are then used to automatically set
#' the magnification of vertical axis for plotting.
#' @param xlim A list of numeric vectors all of which are length two.
#' Each element determines the xlim (`c(from, to)`)
#' of the corresponding panel included in the plot.
#' If not provided, original temporal limits used when creating
#' `htbRas` object (and further `htbHis` object) are used.
#' @param ylim A numeric vector of length two.
#' Since the vertical axis is kept unchanged for the panels
#' drawn in one [htbPlotHis()] call,
#' only a pair of two values (`c(from, to)`) is needed for `ylim`
#' (unlike the case of `xlim`).
#' Normally you don't need to explicitly designate this argument
#' so that the function automatically set an appropriate range.
#' @param histy A string. The type of the histogram drawing.
#' Default `l` draws histograms as lines,
#' which will suit the case when you have two or more conditions
#' to be drawn altogether in a same graph.
#' On the other hand, `h` will draw traditional building-like
#' filled histograms (that surely overlap with each other
#' and deteriorate the readability).
#' @param hiscol Strings. The colors of the histograms.
#' If not provided, the same set of colors were inherited from `rascol`.
#' If neither `hiscol` nor `rascol` is provided,
#' colors are automatically generated by [htb.colors()].
#' @param hislty Strings. The line types of the histograms.
#' @param hislwd Numerics. The line widths of the histograms.
#' @param hispch Either integers or strings.
#' The pointing characters used in the histogram legend.
#' @param hisname Strings. The names of the histograms used in the histogram legend.
#' @param hiscex Numerics. The magnification of points used in the histogram legend.
#' @param hisbty A string. The box type of the histogram legend.
#' @param hisleg A string. The keyword to locate the histogram legend
#' used as `legend` argument in [graphics::legend()].
#' If `NULL`, the histogram legend will not be drawn.
#' @param sdty A string. The type of the SD (or SE) ranges to draw
#' when plotting population histograms.
#' Default `n` omits SD information.
#' On the other hand, `l` draws it as upper and lower limits
#' (mean +/- SD) using parallelling lines using [graphics::lines()].
#' Also, `p` draws it by [graphics::polygon()] ,
#' resulting in belts with some widths.
#' Another option `b` results in a similar plot but draws it by
#' repetitive vertical lines with [graphics::segments()]
#' (like, so to say, centipede graphs, but be careful
#' not to search this word directly if you have acaraphobia.)
#' which will suit the case when you have two or more conditions
#' to be drawn altogether in a same graph.
#' On the other hand, `h` will draw traditional building-like
#' filled histograms (that surely overlap with each other
#' and deteriorate the readability).
#' @param sdcol Strings. The colors of the SD ranges.
#' If not provided, automatically generated by [htb.colors()].
#' @param sdlty Strings. The line types of the SD lines.
#' @param sdlwd Numerics. The line widths of the SD lines.
#' @param rasty A string. The type of the rastergrams.
#' Default `p` plots rasters by symbols pointed by [graphics::points()].
#' On the other hand, `l` draws them as vertical ticks
#' drawn by [graphics::segments()].
#' @param rascol Strings. The colors of the rastergrams.
#' If not provided, the same set of colors were inherited from `hiscol`.
#' If neither `hiscol` nor `rascol` is provided,
#' colors are automatically generated by [htb.colors()].
#' @param raspch A string. The point types of the rastergrams.
#' @param rassp A numeric. Amount of blank space inserted
#' between rastergrams of different conditions.
#' The value is treated as a number of blank lines
#' (i.e., multiplied by the height of one line in the rastergram).
#' @param nlines Numerics. Number of raster lines.
#' @param evcol Strings. The colors of the rastergrams.
#' If not provided,
#' colors are automatically generated by [grDevices::rainbow()].
#' @param evpch A numeric or string. The point types of the event dot
#' designated in the same code to the standard [graphics::points()].
#' @param evname Strings. The names of the task eventss used in the event legend.
#' @param evcex A numeric. The magnification of event points.
#' @param evbty A string. The box type of the event legend.
#' @param evleg A string. The keyword to locate the event legend
#' used as `legend` argument in [graphics::legend()].
#' If `NULL`, the event legend will not be drawn.
#' @param sqlim A numeric vector of length two.
#' When not `NULL`, a square shading is drawn
#' at designated xlim range (`c(from, to)`).
#' @param sqpanel An integer vector of length two
#' that indicates the panels from/to which the shading is drawn.
#' @param sqcol A string. The color of the shading area.
#' @param vlat A numeric. Location to which a vertical line
#' is drawn in *EACH* of the existing panels
#' (normally used to denote horizontal origins of each panel).
#' @param vlcol A string. The color of the vertical line(s).
#' @param vllty A string. The line types of the vertical line(s).
#' @param xlab A string. The label on the horizontal axis.
#' @param ylab A string. The label on the vertical axis.
#' @param bty A string. The box type of the whole plot.
#' @param las An integer. The direction of the axis labelling
#' used in [graphics::par()].
#' @param ... Other arguments passed to htbPlotWindow().
#'
#' @return Numerics. Amout of horizontal shifts of the panels
#' that can be used in additional graphical drawings.
#'
#' @examples
#' alignment <- list(CUEON_L = c(-1500, 2000), CUEON_R = c(-1500, 2000))
#' incld <- list(TRIALSTART = c(-2000, 0), TRIALEND = c(0, 2000))
#' excld <- list(ERROR = c(0, 2000))
#'
#' \dontrun{
#' db_sp <- htbGetDb("spike.htb")
#' db_ev <- htbGetDb("event.htb")
#' ras <- htbGetRas(db_sp, db_ev, alignment,
#' incld = incld, excld = excld)
#' his <- htbGetHis(ras)
#' htbPlotHis(his)
#' }
#'
#' @keywords hplot
#'
#' @export
htbPlotHis <- function(
his = NULL,
ras = NULL,
index = NULL,
prop = c(0.8, 0.4, 50),
xlim = NULL,
ylim = NULL,
histy = "l",
hiscol = NULL,
hislty = "solid",
hislwd = 2,
hispch = 15,
hisname = NULL,
hiscex = 0.5,
hisbty = "o",
hisleg = "bottomright",
sdty = "n",
sdcol = NULL,
sdlty = "22",
sdlwd = 1,
rasty = "p",
rascol = NULL,
raspch = ".",
rassp = 2,
nlines = NULL,
evcol = NULL,
evpch = 15,
evname = NULL,
evcex = 0.5,
evbty = "o",
evleg = "topright",
sqlim = NULL,
sqpanel = c(1, 1),
sqcol = "gray90",
vlat = NULL,
vlcol = "gray30",
vllty = "solid",
xlab = "Time [ms]",
ylab = NULL,
bty = "l",
las = 1,
...
) {
if ((!is.null(his)) && (class(his) %in% c("htbHis", "htbRoc"))) {
his <- list(his)
}
if ((!is.null(ras)) && (class(ras) == "htbRas")) {
ras <- list(ras)
}
if (!is.null(index)) {
if (!is.null(his)) {
his <- lapply(X = his, FUN = htbExtractCond, index)
}
if (!is.null(ras)) {
ras <- lapply(X = ras, FUN = htbExtractCond, index)
}
}
npanel <- max(length(his), length(ras))
if (npanel == 0) {
stop("htbPlotHis: Neither his/ras provided")
}
ncond_his <- sapply(X = his, FUN = function(z) { length(z$da$y) })
ncond_ras <- sapply(X = ras, FUN = function(z) { length(z$da) })
ntrl_ras <- lapply(X = ras, FUN = function(z) {
sapply(X = z$da, FUN = length) })
if (!is.null(ras)) {
rassptotal <- (ncond_ras - 1) * rassp
if (is.null(nlines)) {
nlines <- mapply(FUN = function(ncond, yspt) {
table(rep(1:ncond, length.out = prop[3] - yspt))
}, ncond_ras, rassptotal, SIMPLIFY = FALSE)
} else if (any(nlines == "all")) {
nlines <- ntrl_ras
prop[3] <- max(sapply(X = nlines, FUN = sum) + rassptotal)
}
nlines <- rep(nlines, length.out = npanel)
nlines <- mapply(FUN = function(a, b) {
pmin(a, b) }, nlines, ntrl_ras, SIMPLIFY = FALSE)
}
if (is.null(hiscol) && !is.null(rascol)) {
hiscol <- rascol
} else if (is.null(rascol) && !is.null(hiscol)) {
rascol <- hiscol
}
reppar <- function(tmpp, tmpn) {
if (!is.list(tmpp)) {
tmpp <- list(tmpp)
}
mapply(FUN = function(x, y) {
rep(x, length.out = y)
}, rep(tmpp, length.out = npanel), tmpn, SIMPLIFY = FALSE)
}
if (!is.null(his)) {
if (is.null(hiscol)) {
hiscol <- lapply(X = ncond_his, FUN = htb.colors)
}
hiscol <- reppar(hiscol, ncond_his)
hislty <- reppar(hislty, ncond_his)
hislwd <- reppar(hislwd, ncond_his)
if (is.null(sdcol)) {
sdcol <- hiscol
}
sdcol <- reppar(sdcol, ncond_his)
sdlty <- reppar(sdlty, ncond_his)
sdlwd <- reppar(sdlwd, ncond_his)
}
if (!is.null(ras)) {
if (is.null(rascol)) {
rascol <- lapply(X = ncond_ras, FUN = htb.colors)
}
rascol <- reppar(rascol, ncond_ras)
}
if (is.null(xlim)) {
xlim <- list()
for (i in 1:npanel) {
hp <- lapply(X = his[[i]]$param, FUN="[[", "xlim")
rp <- lapply(X = ras[[i]]$param, FUN="[[", "xlim")
xlim[[i]] <- range(unlist(rp), unlist(hp), na.rm = TRUE)
}
} else if (!is.list(xlim)) {
xlim <- list(xlim)
}
xlim <- rep(xlim, length.out = npanel)
if (is.null(ras)) {
prop[1] <- 1
}
if (is.null(his)) {
prop[2] <- 1
}
if (!is.null(his)) {
h <- unlist(mapply(FUN = function(tmphis, tmpxlim) {
i <- (tmphis$da$x >= tmpxlim[1]) & (tmphis$da$x <= tmpxlim[2])
y <- sapply(X = tmphis$da$y, FUN="[", i)
if ((sdty != "n") && any(names(tmphis$da) == "s")) {
s <- sapply(X = tmphis$da$s, FUN="[", i)
y <- c(y - s, y + s)
}
return(y)
}, his, xlim))
}
if (is.null(ylim)) {
if (!is.null(his)) {
ylim <- c(0, max(h, na.rm = TRUE))
} else if (prop[2] == 1) {
ylim <- c(0, max(sapply(X = nlines, FUN = sum) + rassptotal))
} else {
ylim <- c(0, 1)
}
} else if (ylim[1] == "auto") {
ylim <- range(h, na.rm = TRUE)
}
ylim[2] <- ylim[1] + diff(ylim) / prop[1]
ysep <- diff(ylim) * prop[2] / prop[3]
if (is.null(evname)) {
evname <- lapply(X = ras, FUN = function(z) { names(z$ev) })
evname <- unique(unlist(evname))
}
if (is.null(ylab) && !is.null(his)) {
ylab <- his[[1]]$param[[1]]$type
}
if (rasty=="p") {
raster <- function(x, y, pch = raspch, ...) {
graphics::points(x = x, y = y, pch = pch, ...) }
} else if (rasty=="l") {
#raster <- function(x, y, ...) {
raster <- function(x, y, pch = raspch, ...) {
graphics::segments(x0 = x, y0 = y, x1 = x, y1 = y-ysep, lend = "butt", ...) }
}
xshift <- htbPlotWindow(xlim = xlim, ylim = ylim, xlab = xlab, ylab = ylab,
sqlim = sqlim, sqpanel = sqpanel, sqcol = sqcol,
vlat = NULL, # Leave vertical lines later
bty = bty, las = las, ...)
usr <- graphics::par("usr")
n_ev <- 0
xs_ev <- list()
ys_ev <- list()
uni_ev <- NULL
for (i in 1:npanel) {
tmpras <- ras[[i]]
tmphis <- his[[i]]
da <- tmpras$da
ev <- tmpras$ev
param <- tmpras$param
if (!is.null(tmpras)) {
tmpy <- usr[4]
for (j in seq(along = da)) {
if (nlines[[i]][j] != 0) {
xs <- unlist(da[[j]][1:nlines[[i]][j]])
ys <- rep(seq(tmpy, tmpy - (nlines[[i]][j] - 1) * ysep, by = -ysep),
sapply(X = da[[j]][1:nlines[[i]][j]], FUN = length))
k <- (xs >= xlim[[i]][1]) & (xs <= xlim[[i]][2])
xs <- xs[k] + xshift[i]
ys <- ys[k]
raster(x = xs, y = ys, col = rascol[[i]][j])
}
tmpy <- tmpy - (nlines[[i]][j] + rassp) * ysep
}
if ((!is.null(ev)) && (sum(nlines[[i]]) != 0)) {
for (j in evname) {
if (!is.null(ev[[j]])) {
xs <- unlist(mapply(FUN = function(x, n) {
x[1:n] }, ev[[j]], nlines[[i]]))
ys <- seq(usr[4], usr[4] - (sum(nlines[[i]]) - 1) * ysep, by = -ysep) -
rep(seq(0, along = da), nlines[[i]]) * rassp * ysep
k <- (xs >= xlim[[i]][1]) & (xs <= xlim[[i]][2])
if (sum(k, na.rm = TRUE) == 0) {
next
}
n_ev <- n_ev + 1
xs_ev[[n_ev]] <- xs[k] + xshift[i]
ys_ev[[n_ev]] <- ys[k]
uni_ev[n_ev] <- j
}
}
}
}
if (!is.null(tmphis)) {
xs <- tmphis$da$x
k <- (xs >= xlim[[i]][1]) & (xs <= xlim[[i]][2])
xs <- xs[k] + xshift[i]
for (j in rev(seq(along = tmphis$da$y))) {
ys <- tmphis$da$y[[j]][k]
if (sdty %in% c("l", "b", "p")) {
ss <- tmphis$da$s[[j]][k]
ypm <- list(ys + ss, pmax(ys - ss, 0))
if (!is.null(ss)) {
if (sdty == "l") {
lapply(X = ypm, FUN=function(y) {
graphics::lines(xs, y, col = sdcol[[i]][j], lty = sdlty[[i]][j], lwd = sdlwd[[i]][j]) })
} else if (sdty == "b") {
graphics::segments(xs, ypm[[1]], y1 = ypm[[2]],
col = sdcol[[i]][j], lty = sdlty[[i]][j], lwd = sdlwd[[i]][j])
} else if (sdty == "p") {
graphics::polygon(c(xs, rev(xs)), c(ypm[[1]], rev(ypm[[2]])),
border = NA, col = sdcol[[i]][j])
}
}
}
if (histy == "h") {
b <- tmphis$param[[j]]$bin
graphics::rect(xs - b/2, 0, xs + b/2, ys, col = hiscol[[i]][j], border = hiscol[[i]][j])
} else {
graphics::lines(xs, ys, col = hiscol[[i]][j], lty = hislty[[i]][j], lwd = hislwd[[i]][j])
}
}
}
}
if (n_ev > 0) {
if (is.null(evcol)) {
evcol <- grDevices::rainbow(length(uni_ev))
} else {
evcol <- rep(evcol, length.out = n_ev)
}
raster(unlist(xs_ev), unlist(ys_ev), cex = evcex, pch = evpch,
col = rep(evcol, sapply(X = xs_ev, FUN = length)))
if (!is.null(evleg)) {
graphics::legend(x = evleg, legend = uni_ev, col = evcol,
pch = evpch, cex = evcex, bty = evbty, bg = "white", inset = 0.02)
}
}
if (!is.null(hisleg)) {
if (is.null(hisname) && (npanel == 1)) {
hisname <- sapply(X = his[[1]]$param, FUN = "[[", "title")
}
if (length(hisname) > 0) {
graphics::legend(x = hisleg, legend = hisname, col = hiscol[[1]],
pch = hispch, cex = hiscex, bty = hisbty, bg = "white", inset = 0.02)
}
}
if (!is.null(vlat)) {
if (!is.list(vlat)) {
vlat <- list(vlat)
}
vlpanel <- rep(seq(along = vlat), sapply(X = vlat, FUN = length))
vlat <- unlist(vlat)
nvl <- length(vlat)
vlcol <- rep(vlcol, length.out = nvl)
vllty <- rep(vllty, length.out = nvl)
graphics::segments(vlat + xshift[vlpanel], usr[3], y1 = usr[4],
col = vlcol, lty = vllty)
}
invisible(xshift)
}
htbGetPop <- function(
obj,
type = c("sd", "se"),
...
) {
obj <- obj[sapply(X = obj, FUN = length) != 0]
pop <- obj[[1]]
type <- type[1]
if (class(pop) == "htbHis") {
tmpx <- lapply(X = obj, FUN = function(tmphis) { tmphis$da$x })
if (!all(diff(sapply(X = tmpx, FUN = length)) == 0)) {
stop("htbGetPop: Numbers of time points differ between elements")
}
tmpx <- do.call(cbind, tmpx)
if (!all(apply(X = tmpx, MARGIN = 1, FUN = diff) == 0)) {
stop("htbGetPop: Time points differ between elements")
}
pop$da$s <- list()
for (i in seq(along = pop$da$y)) {
tmpy <- lapply(X = obj, FUN = function(tmphis) { tmphis$da$y[[i]] })
if (!all(diff(sapply(X = tmpy, FUN=length)) == 0)) {
stop("htbGetPop: Numbers of sample differ between elements")
}
tmpy <- do.call(cbind, tmpy)
tmpy <- tmpy[, !is.na(tmpy[1,]), drop = FALSE]
if (ncol(tmpy) == 0) {
pop$da$y[[i]] <- rep(NA, length(pop$da$x))
pop$da$s[[i]] <- rep(NA, length(pop$da$x))
next
} else {
pop$da$y[[i]] <- rowMeans(tmpy, na.rm = TRUE)
pop$da$s[[i]] <- apply(X = tmpy, MARGIN = 1, FUN = stats::sd, na.rm = TRUE) /
switch(type, sd = 1, se = sqrt(ncol(tmpy)))
}
}
names(pop$da$s) <- names(pop$da$y)
}
return(pop)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.