coorNumCol <- function(tabCol, limitsX, bias_brokenX, compare=FALSE) {
if (compare) {
results <- coorNumVector(tabCol$mean.diff.scaled, limitsX, bias_brokenX, tabCol$name, tabCol$sd.diff.scaled)
names(results) <- c("brokenX", "mean.diff.coor", "marks.labels", "marks.x", "xline", "widths", "x1", "x2")
results.rel <- coorNumVector(tabCol$mean.diff.rel.scaled, limitsX, bias_brokenX, tabCol$name, tabCol$sd.diff.rel.scaled)
names(results.rel) <- c("brokenX.rel", "mean.diff.coor.rel", "marks.labels.rel", "marks.x.rel", "xline.rel", "widths.rel", "x1.rel", "x2.rel")
tabCol <- c(tabCol, results, results.rel)
} else {
results <- coorNumVector(tabCol$mean.scaled, limitsX, bias_brokenX, tabCol$name, tabCol$sd.scaled)
names(results) <- c("brokenX", "mean.coor", "marks.labels", "marks.x", "xline", "widths", "x1", "x2")
tabCol <- c(tabCol, results)
}
tabCol
}
coorNumVector <- function(num, limitsX, bias_brokenX, name, sd=NULL) {
ignoreMarks <- all(is.na(num))
if (!is.null(sd)) {
numL <- num - sd
numR <- num + sd
} else {
numL <- num
numR <- num
}
## determine whether broken X-axis are applied, and transform values accordingly
if (is.numeric(limitsX)) {
minmax <- limitsX
if (!ignoreMarks && min(numL, na.rm=TRUE)<limitsX[1]) {
if (!is.null(sd)) {
warning(paste("some mean values minus standard deviation of", name, "are less than the lower limit", limitsX[1], ", and are therefore truncated"), call. = FALSE)
} else {
warning(paste("some mean values of", name, "are less than the lower limit", limitsX[1], ", and are therefore truncated"), call. = FALSE)
}
num[num<limitsX[1]] <- limitsX[1]
numL[numL<limitsX[1]] <- limitsX[1]
numR[numR<limitsX[1]] <- limitsX[1]
}
if (!ignoreMarks && max(numR, na.rm=TRUE)>limitsX[2]) {
if (!is.null(sd)) {
warning(paste("some mean values plus standard deviation of", name, "are greather than the upper limit", limitsX[2], ", and are therefore truncated"), call. = FALSE)
} else {
warning(paste("some mean values of", name, "are greather than the upper limit", limitsX[2], ", and are therefore truncated"), call. = FALSE)
}
num[num>limitsX[2]] <- limitsX[2]
numL[numL>limitsX[2]] <- limitsX[2]
numR[numR>limitsX[2]] <- limitsX[2]
}
bias_brokenX <- 0
ignoreMarks <- FALSE
} else if (ignoreMarks) {
minmax <- c(0, 1)
} else {
minmax <- range(c(numL, numR), na.rm=TRUE)
}
isConstant <- minmax[1]==minmax[2]
if (!isConstant && minmax[2] > 0 && minmax[1] > (bias_brokenX * minmax[2])) {
## broken x-axis has positive values
brokenX <- 1
values <- num - minmax[1]
valuesL <- numL - minmax[1]
valuesR <- numR - minmax[1]
marks <- unique(c(0, pretty(minmax, 3)))
marks_coor <- marks - minmax[1]
minV <- 0
maxV <- minmax[2] - minmax[1]
} else if (!isConstant && minmax[1] < 0 && minmax[2] < (bias_brokenX * minmax[1])) {
## broken x-axis has negative values
brokenX <- -1
values <- num - minmax[2]
valuesL <- numL - minmax[2]
valuesR <- numR - minmax[2]
marks <- unique(c(pretty(minmax, 3), 0))
marks_coor <- marks - minmax[2]
minV <- minmax[1] - minmax[2]
maxV <- 0
} else {
## x-axis not broken
brokenX <- 0
values <- num
valuesL <- numL
valuesR <- numR
marks <- pretty(c(0, minmax), 4)
marks_coor <- marks
minV <- minmax[1]
maxV <- minmax[2]
}
## scale values to 0-1, and determine 0-1 value of the y-axis
if (minV < 0 && maxV > 0) {
xline <- -minV / (maxV - minV)
widths <- (values) / (maxV - minV)
x1 <- (valuesL - minV) / (maxV - minV)
x2 <- (valuesR - minV) / (maxV - minV)
marks_x <- (marks_coor - minV) / (maxV - minV)
} else if (brokenX==1) {
xline <- 0
widths <- 0.3 + (values) * 0.7 / (maxV - minV)
x1 <- 0.3 + (valuesL) * 0.7 / (maxV - minV)
x2 <- 0.3 + (valuesR) * 0.7 / (maxV - minV)
marks_x <- 0.3 + (marks_coor) * 0.7 / (maxV - minV)
} else if (brokenX==-1) {
xline <- 1
widths <- -0.3 + (values) * 0.7 / (maxV - minV)
x1 <- 0.7 + (valuesL) * 0.7 / (maxV - minV)
x2 <- 0.7 + (valuesR) * 0.7 / (maxV - minV)
marks_x <- 0.7 + (marks_coor) * 0.7 / (maxV - minV)
} else {
xline <- ifelse(maxV > 0, 0, 1)
widths <- (values) / max(abs(minV), abs(maxV))
x1 <- (valuesL) / max(abs(minV), abs(maxV)) + xline
x2 <- (valuesR) / max(abs(minV), abs(maxV)) + xline
marks_x <- (marks_coor) / max(abs(minV), abs(maxV)) + xline
}
widths[is.nan(widths)] <- minV
x1[is.nan(x1)] <- minV
x2[is.nan(x2)] <- minV
if (ignoreMarks) {
marks.labels <- integer(0)
marks.x <- integer(0)
} else {
marksVis <- marks_x >= ifelse(brokenX==1, 0.15, 0) &
marks_x <= ifelse(brokenX==-1, 0.85, 1)
marks_x[marks==0] <- xline
marksVis[marks==0] <- TRUE
marks.labels <- marks[marksVis]
marks.x <- marks_x[marksVis]
}
list(brokenX, values, marks.labels, marks.x, xline, widths, x1, x2)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.