Skip to content

Commit ecc5994

Browse files
yannrichetyannrichet
committed
fix contour & fillcontour. add support for two colors
1 parent 6cb952c commit ecc5994

File tree

6 files changed

+196
-122
lines changed

6 files changed

+196
-122
lines changed

‎R/Utils.R‎

Lines changed: 17 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -28,9 +28,12 @@ translude <- function(col, alpha = 0.6) {
2828
##========================================================
2929

3030
#' @import grDevices
31-
col.levels <- function(color,nlevels){
32-
if (length(nlevels)!=1) # if nlevels is in fact levels
33-
nlevels <- length(nlevels)-1
31+
col.levels <- function(color, levels, fill=FALSE){
32+
if (length(levels)!=1) # if nlevels is in fact levels
33+
nlevels <- length(levels)
34+
else nlevels <- levels
35+
if (fill) nlevels <- nlevels + 1
36+
3437
col.rgb=col2rgb(color)
3538
col.hsv=rgb2hsv(r=col.rgb[1],g=col.rgb[2],b=col.rgb[3])
3639
col = hsv(h=col.hsv[1],s=seq(f=0,t=col.hsv[2],l=nlevels),v=col.hsv[3])
@@ -43,7 +46,12 @@ col.levels <- function(color,nlevels){
4346
##========================================================
4447

4548
#' @import grDevices
46-
cols.levels <- function(color1,color2,nlevels) {
49+
cols.levels <- function(color1,color2,levels, fill=FALSE) {
50+
if (length(levels)!=1) # if nlevels is in fact levels
51+
nlevels <- length(levels)
52+
else nlevels <- levels
53+
if (fill) nlevels <- nlevels + 1
54+
4755
col1.rgb=col2rgb(color1)
4856
col2.rgb=col2rgb(color2)
4957
col1.hsv=rgb2hsv(r=col1.rgb[1],g=col1.rgb[2],b=col1.rgb[3])
@@ -67,6 +75,7 @@ cols.levels <- function(color1,color2,nlevels) {
6775
##
6876
##========================================================
6977

78+
#' be careful that fade(.., alpha=0) means total fading, while fade(.., alpha=1) means no fading
7079
#' @import grDevices
7180
fade <- function(color = "red",
7281
alpha = seq(from = 0, to = 1, length.out = 5),
@@ -104,6 +113,10 @@ fade <- function(color = "red",
104113

105114
}
106115

116+
fades <- function(colors = c('red','blue'),
117+
alpha = 0.5)
118+
Vectorize(function(col)fade(col,alpha = alpha,plot=FALSE))(colors)
119+
107120
##========================================================
108121
## try to find a good formatted value for a numeric vector
109122
## x using a vector of diff range drx

‎R/contourview.R‎

Lines changed: 37 additions & 36 deletions
Original file line numberDiff line numberDiff line change
@@ -35,7 +35,7 @@ contourview.function <- function(fun, vectorized=FALSE,
3535
npoints = 21,
3636
levels = 10,
3737
lty_levels = 3,
38-
col_levels = if (!is.null(col) & length(col)==1) col.levels(col,levels-1) else col.levels("blue",levels-1),
38+
col_levels = if (!is.null(col) & length(col)==1) col.levels(col,levels-1) else if (!is.null(col) & length(col)==2) cols.levels(col[1],col[2],levels-1) else col.levels("blue",levels-1),
3939
col = NULL,
4040
col_fading_interval = 0.5,
4141
mfrow = NULL,
@@ -56,9 +56,9 @@ contourview.function <- function(fun, vectorized=FALSE,
5656
}
5757

5858
if (length(levels)==1) {
59-
levels = pretty(range(unlist(EvalInterval.function(fun,Xlim,vectorized,D)),na.rm=TRUE), levels)
60-
if (length(col_levels) != length(levels)-1)
61-
col_levels = col.levels(col_levels,levels)
59+
levels = pretty(range(unlist(EvalInterval.function(fun,X=Xlim,vectorized,dim=D)),na.rm=TRUE), levels)
60+
if (length(col_levels) != length(levels))
61+
col_levels = col.levels(col_levels,length(levels))
6262
}
6363

6464
if (D == 1) stop("for a model with dim 1, use 'sectionview'")
@@ -463,7 +463,7 @@ contourview.km <- function(km_model, type = "UK",
463463
npoints = 21,
464464
levels = pretty(km_model@y, 10),
465465
col_points = if (!is.null(col) & length(col)==1) col else "red",
466-
col_levels = if (!is.null(col) & length(col)==1) col.levels(col,levels) else col.levels("blue",levels),
466+
col_levels = if (!is.null(col) & length(col)==1) col.levels(col,levels) else if (!is.null(col) & length(col)==2) cols.levels(col[1],col[2],levels-1) else col.levels("blue",levels),
467467
col = NULL,
468468
conf_level = 0.5,
469469
conf_fading = 0.5,
@@ -475,7 +475,7 @@ contourview.km <- function(km_model, type = "UK",
475475
add = FALSE,
476476
...) {
477477
if (length(levels)==1) {
478-
levels = pretty(km_model@y, levels)
478+
levels = pretty(c(km_model@y+2*sqrt(km_model@covariance@sd2), km_model@y-2*sqrt(km_model@covariance@sd2)), levels)
479479
if (length(col_levels) != length(levels)-1)
480480
col_levels = col.levels(col_levels,levels)
481481
}
@@ -523,13 +523,6 @@ contourview.km <- function(km_model, type = "UK",
523523
mfrow = mfrow, Xlab = Xlab, ylab = ylab,
524524
Xlim = rx, title = title, add = add, ...)
525525

526-
# plot design points
527-
contourview.matrix(X = X_doe, y = y_doe,
528-
dim = D, center = center, axis = axis,
529-
col_points = col_points,
530-
bg_fading = bg_fading,
531-
mfrow = mfrow, Xlim = rx, add=TRUE)
532-
533526
# plot confidence bands
534527
for (l in conf_level) {
535528
contourview.function(fun = function(x) {
@@ -541,6 +534,13 @@ contourview.km <- function(km_model, type = "UK",
541534
col_fading_interval=conf_fading,
542535
mfrow = mfrow, Xlim = rx, add = TRUE)
543536
}
537+
538+
# plot design points
539+
contourview.matrix(X = X_doe, y = y_doe,
540+
dim = D, center = center, axis = axis,
541+
col_points = col_points,
542+
bg_fading = bg_fading,
543+
mfrow = mfrow, Xlim = rx, add=TRUE)
544544
}
545545

546546
#' @param libKriging_model an object of class \code{"Kriging"}, \code{"NuggetKriging"} or \code{"NoiseKriging"}.
@@ -554,7 +554,7 @@ contourview_libKriging <- function(libKriging_model,
554554
npoints = 21,
555555
levels = pretty( libKriging_model$y() , 10),
556556
col_points = if (!is.null(col) & length(col)==1) col else "red",
557-
col_levels = if (!is.null(col) & length(col)==1) col.levels(col,levels) else col.levels("blue",levels),
557+
col_levels = if (!is.null(col) & length(col)==1) col.levels(col,levels) else if (!is.null(col) & length(col)==2) cols.levels(col[1],col[2],levels-1) else col.levels("blue",levels),
558558
col = NULL,
559559
conf_level = 0.5,
560560
conf_fading = 0.5,
@@ -566,7 +566,8 @@ contourview_libKriging <- function(libKriging_model,
566566
add = FALSE,
567567
...) {
568568
if (length(levels)==1) {
569-
levels = pretty(libKriging_model$y(), levels)
569+
levels = pretty(c(libKriging_model$y()-2*sqrt(libKriging_model$sigma2()),
570+
libKriging_model$y()+2*sqrt(libKriging_model$sigma2())), levels)
570571
if (length(col_levels) != length(levels)-1)
571572
col_levels = col.levels(col_levels,levels)
572573
}
@@ -617,13 +618,6 @@ contourview_libKriging <- function(libKriging_model,
617618
mfrow = mfrow, Xlab = Xlab, ylab = ylab,
618619
Xlim = rx, title = title, add = add, ...)
619620

620-
# plot design points
621-
contourview.matrix(X = X_doe, y = y_doe,
622-
dim = D, center = center, axis = axis,
623-
col_points = col_points,
624-
bg_fading = bg_fading,
625-
mfrow = mfrow, Xlim = rx, add=TRUE)
626-
627621
# plot confidence bands
628622
for (l in conf_level) {
629623
contourview.function(fun = function(x) {
@@ -635,6 +629,13 @@ contourview_libKriging <- function(libKriging_model,
635629
col_fading_interval=conf_fading,
636630
mfrow = mfrow, Xlim = rx, add = TRUE)
637631
}
632+
633+
# plot design points
634+
contourview.matrix(X = X_doe, y = y_doe,
635+
dim = D, center = center, axis = axis,
636+
col_points = col_points,
637+
bg_fading = bg_fading,
638+
mfrow = mfrow, Xlim = rx, add=TRUE)
638639
}
639640

640641
#' @param Kriging_model an object of class \code{"Kriging"}.
@@ -666,7 +667,7 @@ contourview.Kriging <- function(Kriging_model,
666667
npoints = 21,
667668
levels = pretty( Kriging_model$y() , 10),
668669
col_points = if (!is.null(col) & length(col)==1) col else "red",
669-
col_levels = if (!is.null(col) & length(col)==1) col.levels(col,levels) else col.levels("blue",levels),
670+
col_levels = if (!is.null(col) & length(col)==1) col.levels(col,levels) else if (!is.null(col) & length(col)==2) cols.levels(col[1],col[2],levels-1) else col.levels("blue",levels),
670671
col = NULL,
671672
conf_level = 0.5,
672673
conf_fading = 0.5,
@@ -725,7 +726,7 @@ contourview.NuggetKriging <- function(NuggetKriging_model,
725726
npoints = 21,
726727
levels = pretty( NuggetKriging_model$y() , 10),
727728
col_points = if (!is.null(col) & length(col)==1) col else "red",
728-
col_levels = if (!is.null(col) & length(col)==1) col.levels(col,levels) else col.levels("blue",levels),
729+
col_levels = if (!is.null(col) & length(col)==1) col.levels(col,levels) else if (!is.null(col) & length(col)==2) cols.levels(col[1],col[2],levels-1) else col.levels("blue",levels),
729730
col = NULL,
730731
conf_level = 0.5,
731732
conf_fading = 0.5,
@@ -784,7 +785,7 @@ contourview.NoiseKriging <- function(NoiseKriging_model,
784785
npoints = 21,
785786
levels = pretty( NoiseKriging_model$y() , 10),
786787
col_points = if (!is.null(col) & length(col)==1) col else "red",
787-
col_levels = if (!is.null(col) & length(col)==1) col.levels(col,levels) else col.levels("blue",levels),
788+
col_levels = if (!is.null(col) & length(col)==1) col.levels(col,levels) else if (!is.null(col) & length(col)==2) cols.levels(col[1],col[2],levels-1) else col.levels("blue",levels),
788789
col = NULL,
789790
conf_level = 0.5,
790791
conf_fading = 0.5,
@@ -840,7 +841,7 @@ contourview.glm <- function(glm_model,
840841
npoints = 21,
841842
levels = pretty( glm_model$fitted.values , 10),
842843
col_points = if (!is.null(col) & length(col)==1) col else "red",
843-
col_levels = if (!is.null(col) & length(col)==1) col.levels(col,levels) else col.levels("blue",levels),
844+
col_levels = if (!is.null(col) & length(col)==1) col.levels(col,levels) else if (!is.null(col) & length(col)==2) cols.levels(col[1],col[2],levels-1) else col.levels("blue",levels),
844845
col = NULL,
845846
conf_level = 0.5,
846847
conf_fading = 0.5,
@@ -903,15 +904,6 @@ contourview.glm <- function(glm_model,
903904
mfrow = mfrow, Xlab = Xlab, ylab = ylab,
904905
Xlim = rx, title = title, add = add, ...)
905906

906-
# plot design points
907-
contourview.matrix(X = X_doe, y = y_doe,
908-
dim = D, center = center, axis = axis,
909-
col_points = col_points,
910-
bg_fading = bg_fading,
911-
mfrow = mfrow,
912-
Xlim = rx,
913-
add=TRUE)
914-
915907
# plot confidence bands
916908
for (l in conf_level) {
917909
contourview.function(fun = function(x) {
@@ -925,6 +917,15 @@ contourview.glm <- function(glm_model,
925917
col_fading_interval=conf_fading,
926918
mfrow = mfrow, Xlim = rx, add = TRUE)
927919
}
920+
921+
# plot design points
922+
contourview.matrix(X = X_doe, y = y_doe,
923+
dim = D, center = center, axis = axis,
924+
col_points = col_points,
925+
bg_fading = bg_fading,
926+
mfrow = mfrow,
927+
Xlim = rx,
928+
add=TRUE)
928929
}
929930

930931

@@ -955,7 +956,7 @@ contourview.list <- function(modelFit_model,
955956
npoints = 21,
956957
levels = pretty( modelFit_model$data$Y , 10),
957958
col_points = if (!is.null(col) & length(col)==1) col else "red",
958-
col_levels = if (!is.null(col) & length(col)==1) col.levels(col,levels) else col.levels("blue",levels),
959+
col_levels = if (!is.null(col) & length(col)==1) col.levels(col,levels) else if (!is.null(col) & length(col)==2) cols.levels(col[1],col[2],levels-1) else col.levels("blue",levels),
959960
col = NULL,
960961
bg_fading = 1,
961962
mfrow = NULL,

0 commit comments

Comments
 (0)