Skip to content

Commit b8c2a8e

Browse files
kbromankbroman
committed
Add function plot_ci() for plotting confidence intervals
- Taken directly from broman::ciplot(). - Should add an example to the vignette as mentioned in Issue #199.
1 parent 992b969 commit b8c2a8e

11 files changed

Lines changed: 431 additions & 8 deletions

File tree

‎DESCRIPTION‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
Package: qtl2
2-
Version: 0.39-3
3-
Date: 2026-05-01
2+
Version: 0.39-4
3+
Date: 2026-05-04
44
Title: Quantitative Trait Locus Mapping in Experimental Crosses
55
Description: Provides a set of tools to perform quantitative
66
trait locus (QTL) analysis in experimental crosses. It is a
@@ -43,5 +43,5 @@ LazyData: true
4343
Encoding: UTF-8
4444
ByteCompile: true
4545
LinkingTo: Rcpp, RcppEigen
46-
RoxygenNote: 7.3.3
4746
Roxygen: list(markdown=TRUE)
47+
Config/roxygen2/version: 8.0.0

‎NAMESPACE‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -133,6 +133,7 @@ export(n_phenocovar)
133133
export(n_typed)
134134
export(pheno_names)
135135
export(phenocovar_names)
136+
export(plot_ci)
136137
export(plot_coef)
137138
export(plot_coefCC)
138139
export(plot_compare_geno)

‎NEWS.md‎

Lines changed: 6 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,9 @@
1-
## qtl2 0.39-3 (2026-05-01)
1+
## qtl2 0.39-4 (2026-05-04)
2+
3+
### New features
4+
5+
- Added function `plot_ci()` for plotting a set of confidence
6+
intervals, such as for the QTL effects at a fixed QTL position.
27

38
### Minor changes
49

‎R/plot_ci.R‎

Lines changed: 149 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,149 @@
1+
# plot_ci
2+
#'
3+
#' Effect plot with multiple CIs for different groups
4+
#'
5+
#' Plot a set of confidence intervals.
6+
#'
7+
#' @param est Vector of estimates
8+
#' @param se Vector of standard errors
9+
#' @param lo Vector of lower values for the intervals
10+
#' @param hi Vector of upper values for the intervals
11+
#' @param SEmult SE multiplier to create intervals
12+
#' @param labels Labels for the groups (vector of character strings)
13+
#'
14+
#' @param rotate If TRUE, have group as y-axis; default (FALSE) has
15+
#' group on x-axis.
16+
#'
17+
#' @param ... Optional graphics arguments
18+
#'
19+
#' @details
20+
#' Provide either `se` or both `lo` and `hi`. In the case that `se` is
21+
#' used, the intervals will be `est` +/- `SEmult * se`.
22+
#'
23+
#' If `labels` is not provided, group names are taken from the `names(est)`.
24+
#' If that is also missing, we use capital letters.
25+
#'
26+
#' You can control the CI line widths with `ci_lwd` and the color of
27+
#' the CI segments with `ci_col`. You can control the width of the
28+
#' segments at the top and bottom with `ci_endseg`.
29+
#'
30+
#' @importFrom graphics axis points segments
31+
#' @export
32+
#'
33+
#' @return
34+
#' None.
35+
#'
36+
#' @examples
37+
#' iron <- read_cross2(system.file("extdata", "iron.zip", package="qtl2"))
38+
#' iron <- iron[,"9"] # only chr 9
39+
#' map <- insert_pseudomarkers(iron$gmap, step=1)
40+
#' probs <- calc_genoprob(iron, map, error_prob=0.002)
41+
#' pr <- pull_genoprobpos(probs, map, chr="9", pos=56.6)
42+
#' out_fit1 <- fit1(pr, iron$pheno[,"spleen"], se=TRUE, zerosum=FALSE)
43+
#' plot_ci(out_fit1$coef[1:3], out_fit1$SE[1:3],
44+
#' xlab="Genotype chr 9 @ 56.6 cM", ylab="Spleen phenotype")
45+
#'
46+
#' @seealso [plot_coef()], [plot_pxg()]
47+
#'
48+
#' @keywords
49+
#' graphics
50+
plot_ci <-
51+
function(est, se=NULL, lo=NULL, hi=NULL, SEmult=2,
52+
labels=NULL, rotate=FALSE, ...)
53+
{
54+
if(is.null(se) && is.null(lo) && is.null(hi)) {
55+
se <- rep(0, length(est))
56+
}
57+
if(!is.null(se) && (!is.null(lo) || !is.null(hi))) {
58+
warning("Provide either se or both lo and hi; se is being used")
59+
}
60+
if(!is.null(se)) {
61+
stopifnot(length(se) == length(est))
62+
63+
lo <- est - se*SEmult
64+
hi <- est + se*SEmult
65+
} else {
66+
stopifnot(length(lo) == length(est), length(hi) == length(est))
67+
}
68+
69+
if(is.null(labels)) {
70+
labels <- names(est)
71+
}
72+
if(is.null(labels)) {
73+
labels <- rep(LETTERS, length(est))[seq_along(est)]
74+
}
75+
stopifnot(length(labels) == length(est))
76+
77+
# this is to deal with varying inputs
78+
hide_ciplot <-
79+
function(est, lo, hi, rotate=FALSE,
80+
vlines=NULL, vlines.col="white", vlines.lwd=1,
81+
hlines=NULL, hlines.col="white", hlines.lwd=1,
82+
xat=NULL, xlim=NULL, xaxs="r", xlab=NULL,
83+
yat=NULL, ylim=NULL, yaxs="r", ylab=NULL,
84+
las=1, pch=21, bg="slateblue", ci_col="black",
85+
ci_lwd=2, ci_endseg=0.05, labels=NULL, main="",
86+
mgp.x=NULL, mgp.y=NULL, mgp=NULL, ...)
87+
88+
{
89+
n_group <- length(est)
90+
group <- seq_len(n_group)
91+
92+
if(!rotate) {
93+
xlim <- c(0.5, n_group+0.5)
94+
vlines <- 1:n_group
95+
vlines.col <- "gray70"
96+
vlines.lwd <- 4
97+
xat <- NA
98+
if(is.null(xlab)) xlab <- ""
99+
100+
if(is.null(ylim)) ylim <- range(c(lo, hi, est))
101+
102+
# deal with vlines/lines ** FIX ME **
103+
104+
qtl2_grayplot(group, est,
105+
vlines=vlines, vlines.col=vlines.col, vlines.lwd=vlines.lwd,
106+
hlines=hlines, hlines.col=hlines.col, hlines.lwd=hlines.lwd,
107+
xat=xat, xlim=xlim, xaxs=xaxs, xlab=xlab,
108+
yat=yat, ylim=ylim, yaxs=yaxs, ylab=ylab, las=las, type="n",
109+
main=main, mgp=mgp, mgp.x=mgp.x, mgp.y=mgp.y, ...)
110+
axis(side=1, at=vlines, labels, las=las, tick=FALSE, mgp=c(0,0.2,0))
111+
112+
segments(group, lo, group, hi, col=ci_col, lwd=ci_lwd)
113+
segments(group-ci_endseg, lo, group+ci_endseg, lo, col=ci_col, lwd=ci_lwd)
114+
segments(group-ci_endseg, hi, group+ci_endseg, hi, col=ci_col, lwd=ci_lwd)
115+
116+
points(group, est, pch=pch, bg=bg, ...)
117+
118+
}
119+
else {
120+
ylim <- c(0.5, n_group+0.5)
121+
hlines <- 1:n_group
122+
hlines.col <- "gray70"
123+
hlines.lwd <- 4
124+
yat <- NA
125+
if(is.null(ylab)) ylab <- ""
126+
127+
if(is.null(xlim)) xlim <- range(c(lo, hi, est))
128+
129+
qtl2_grayplot(est, group,
130+
vlines=vlines, vlines.col=vlines.col, vlines.lwd=vlines.lwd,
131+
hlines=hlines, hlines.col=hlines.col, hlines.lwd=hlines.lwd,
132+
xat=xat, xlim=xlim, xaxs=xaxs, xlab=xlab,
133+
yat=yat, ylim=ylim, yaxs=yaxs, ylab=ylab,
134+
v_over_h=TRUE, las=las, type="n", main=main,
135+
mgp=mgp, mgp.x=mgp.x, mgp.y=mgp.y, ...)
136+
axis(side=2, at=hlines, labels, las=las, tick=FALSE, mgp=c(0,0.3,0))
137+
138+
segments(lo, group, hi, group, col=ci_col, lwd=ci_lwd)
139+
segments(lo, group-ci_endseg, lo, group+ci_endseg, col=ci_col, lwd=ci_lwd)
140+
segments(hi, group-ci_endseg, hi, group+ci_endseg, col=ci_col, lwd=ci_lwd)
141+
142+
points(est, group, pch=pch, bg=bg, ...)
143+
}
144+
145+
}
146+
147+
hide_ciplot(est=est, lo=lo, hi=hi, rotate=rotate, labels=labels, ...)
148+
invisible()
149+
}

‎R/plot_coef.R‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -39,7 +39,7 @@
3939
#' `columns=1:8` and using the Collaborative Cross colors,
4040
#' [CCcolors].
4141
#'
42-
#' @seealso [CCcolors], [plot_scan1()], [plot_snpasso()]
42+
#' @seealso [CCcolors], [plot_scan1()], [plot_snpasso()], [plot_ci()]
4343
#'
4444
#' @section Hidden graphics parameters:
4545
#' A number of graphics parameters can be passed via `...`. For

‎R/plot_pxg.R‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -39,7 +39,7 @@
3939
#' for vertical grid lines. These are not included as formal
4040
#' parameters in order to avoid cluttering the function definition.
4141
#'
42-
#' @seealso [plot_coef()]
42+
#' @seealso [plot_coef()], [plot_ci()]
4343
#'
4444
#' @examples
4545
#' # read data

‎R/qtl2_grayplot.R‎

Lines changed: 196 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,196 @@
1+
# grayplot
2+
#
3+
# Scatterplot with a gray background
4+
#
5+
# Like the plot function, but using a gray background just
6+
# for the plot region.
7+
#
8+
# @param x Coordinates of points in the plot
9+
#
10+
# @param y Coordinates of points in the plot (optional)
11+
#
12+
# @param ... Optional graphics arguments
13+
#
14+
# @param type Plot type (points, lines, etc.)
15+
#
16+
# @param hlines Locations of horizontal grid lines; use `hlines=NA` to prevent horizontal grid lines
17+
#
18+
# @param hlines.col Colors of horizontal grid lines
19+
#
20+
# @param hlines.lty Line type of horizontal grid lines
21+
#
22+
# @param hlines.lwd Line width of horizontal grid lines
23+
#
24+
# @param vlines Locations of vertical grid lines; use `vlines=NA` to prevent vertical grid lines
25+
#
26+
# @param vlines.col Colors of vertical grid lines
27+
#
28+
# @param vlines.lty Line type of vertical grid lines
29+
#
30+
# @param vlines.lwd Line width of vertical grid lines
31+
#
32+
# @param xat Locations for x-axis labels; `xat=NA` indicates no labels
33+
#
34+
# @param yat Locations for y-axis labels; `yat=NA` indicates no labels
35+
#
36+
# @param bgcolor Background color
37+
#
38+
# @param pch point type
39+
# @param bg Background color in points
40+
# @param col Color of outer circle in points
41+
#
42+
# @param v_over_h If `TRUE`, place vertical grid lines on top of
43+
# the horizontal ones.
44+
#
45+
# @details
46+
# Calls `plot()` with `type="n"`, then [graphics::rect()] to
47+
# get the background, and then [graphics::points()]. Additional
48+
# arguments you can include: `mgp.x` and `mgp.y` (like `mgp`, for
49+
# controlling parameters of axis labels, but separate for x- and
50+
# y-axis).
51+
#
52+
# @importFrom graphics title rect axis abline points
53+
#
54+
# @return
55+
# None.
56+
#
57+
# @examples
58+
# \dontshow{set.seed(97536917)}
59+
# x <- rnorm(100)
60+
# y <- x+rnorm(100, 0, 0.7)
61+
# grayplot(x, y, col="slateblue", pch=16)
62+
# at <- seq(-3, 3)
63+
# grayplot(x, y, col="violetred", pch=16, hlines=at, vlines=at)
64+
# grayplot(x, col="Orchid", pch=16, bgcolor="gray80",
65+
# hlines=seq(-4, 4, by=0.5), hlines.lwd=c(3,1),
66+
# vlines=seq(0, 100, by=5), vlines.lwd=c(3,1,1,1))
67+
#
68+
# @seealso
69+
# [dotplot()], [timeplot()], [graphics::par()], [graphics::rect()], [graphics::points()]
70+
#
71+
# @keywords
72+
# graphics
73+
qtl2_grayplot <-
74+
function(x, y=NULL, ..., type="p", hlines=NULL, hlines.col="white", hlines.lty=1, hlines.lwd=1,
75+
vlines=NULL, vlines.col="white", vlines.lty=1, vlines.lwd=1,
76+
xat=NULL, yat=NULL, bgcolor="gray90",
77+
pch=21, bg="lightblue", col="black",
78+
v_over_h=FALSE)
79+
{
80+
if(missing(x) || is.null(x)) stop("x unspecified")
81+
82+
# this is to deal with varying inputs (did "..." include xaxt or not?)
83+
hidegrayplot <-
84+
function(x, y, ..., type="p", hlines=NULL, hlines.col, hlines.lty, hlines.lwd,
85+
vlines=NULL, vlines.col, vlines.lty, vlines.lwd,
86+
xat=pretty(x), yat=pretty(y), bgcolor="gray90", xaxt="n", yaxt="n",
87+
col.lab=par("col.lab"),
88+
xlim=NULL, ylim=NULL,
89+
xlab, ylab, xname, yname,
90+
las=1, mgp=c(2.1, 0.5, 0), mgp.x=NULL, mgp.y=NULL,
91+
pch=21, bg="lightblue", col="black",
92+
v_over_h=FALSE)
93+
{
94+
if(is.null(mgp.x)) mgp.x <- mgp
95+
if(is.null(mgp.y)) mgp.y <- mgp
96+
97+
if(is.null(y)) {
98+
if(missing(xlab)) xlab <- "Index"
99+
if(missing(ylab)) ylab <- xname
100+
y <- x
101+
x <- seq(along=x)
102+
}
103+
else {
104+
if(missing(xlab)) xlab <- xname
105+
if(missing(ylab)) ylab <- yname
106+
}
107+
108+
if(is.null(ylim))
109+
ylim <- range(y, na.rm=TRUE)
110+
if(is.null(hlines)) {
111+
if(!is.null(yat))
112+
hlines <- yat
113+
else
114+
hlines <- pretty(ylim)
115+
}
116+
else if(length(hlines)==1 && is.na(hlines))
117+
hlines <- NULL
118+
119+
if(is.null(xlim))
120+
xlim <- range(x, na.rm=TRUE)
121+
if(is.null(vlines)) {
122+
if(!is.null(xat))
123+
vlines <- xat
124+
else
125+
vlines <- pretty(xlim)
126+
}
127+
else if(length(vlines)==1 && is.na(vlines))
128+
vlines <- NULL
129+
130+
# blank plot
131+
plot(x, y, ..., type="n", xaxt="n", yaxt="n", xlab="", ylab="",
132+
xlim=xlim, ylim=ylim)
133+
134+
# axis titles
135+
graphics::title(xlab=xlab, mgp=mgp.x, col.lab=col.lab)
136+
graphics::title(ylab=ylab, mgp=mgp.y, col.lab=col.lab)
137+
138+
# add gray rectangle
139+
u <- par("usr")
140+
graphics::rect(u[1], u[3], u[2], u[4], col=bgcolor, border="black")
141+
142+
# x axis: if adding white lines, skip the tick marks and move the numbers closer
143+
if(!(!is.null(xat) && length(xat)==1 && is.na(xat))) { # if a single NA, skip x-axis
144+
if(!is.null(xat)) {
145+
if(!is.null(vlines))
146+
graphics::axis(side=1, at=xat, mgp=mgp.x, tick=FALSE, las=las)
147+
else
148+
graphics::axis(side=1, at=xat, las=las)
149+
}
150+
else {
151+
if(!is.null(vlines))
152+
graphics::axis(side=1, mgp=mgp.x, tick=FALSE, las=las)
153+
else
154+
graphics::axis(side=1, las=las)
155+
}
156+
}
157+
158+
# y axis: like the x-axis
159+
if(!(!is.null(yat) && length(yat)==1 && is.na(yat))) { # if a single NA, skip y-axis
160+
if(!is.null(yat)) {
161+
if(!is.null(hlines))
162+
graphics::axis(side=2, at=yat, mgp=mgp.y, tick=FALSE, las=las)
163+
else
164+
graphics::axis(side=2, at=yat, las=las)
165+
}
166+
else {
167+
if(!is.null(hlines))
168+
graphics::axis(side=2, mgp=mgp.y, tick=FALSE, las=las)
169+
else
170+
graphics::axis(side=2, las=las)
171+
}
172+
}
173+
174+
if(!is.null(vlines) && !v_over_h)
175+
graphics::abline(v=vlines, col=vlines.col, lty=vlines.lty, lwd=vlines.lwd)
176+
if(!is.null(hlines))
177+
graphics::abline(h=hlines, col=hlines.col, lty=hlines.lty, lwd=hlines.lwd)
178+
if(!is.null(vlines) && v_over_h)
179+
graphics::abline(v=vlines, col=vlines.col, lty=vlines.lty, lwd=vlines.lwd)
180+
181+
graphics::points(x, y, ..., pch=pch, bg=bg, col=col, type=type)
182+
183+
# add black border again
184+
graphics::abline(v=u[1:2], h=u[3:4])
185+
}
186+
187+
hidegrayplot(x=x, y=y, ..., type=type, hlines=hlines, hlines.col=hlines.col,
188+
hlines.lty=hlines.lty, hlines.lwd=hlines.lwd,
189+
vlines=vlines, vlines.col=vlines.col,
190+
vlines.lty=vlines.lty, vlines.lwd=vlines.lwd,
191+
xat=xat, yat=yat, bgcolor=bgcolor,
192+
pch=pch, bg=bg, col=col,
193+
xname=substitute(x), yname=substitute(y),
194+
v_over_h=v_over_h)
195+
invisible()
196+
}

0 commit comments

Comments
 (0)