I am trying to make a reproducible way to calculate the colour contrast of various colours for graphics on a webpage. I found the following function: https://rdrr.io/github/m-clark/visibly/src/R/color_contrast_checker.R, which does exactly what I want for a comparison between two colours.
I want to be able to give this function a foreground and background colour which are effectively lists of hex codes that can be looped through so the function calculates the colour contrast for all combinations of all colours within the two lists. I have tried to give the function a list of colours in a dataframe and use a for loop to repeat the function several times but have had no luck. I think the function isn't designed to take more than 1 element i.e. 1x foreground and 1x background colour but I am a bit of a novice with functions and for loops in R. Does anyone know how I could achieve this thanks?
Below is example code that has not had any success:
library(gplots)
library(jsonlite)
library(dplyr)
background_col_list<-as.character(c("#6A86B8","#DFE3EB","#E57D3A","#BBB332"))
foreground_col_list<-as.character(c("#6A86B8","#DFE3EB","#E57D3A","#BBB332"))
result.df <- expand.grid(as.character(foreground_col_list),as.character(background_col_list))
result.df<-result.df %>%
mutate_all(as.character)
color_contrast_checker <- function(foreground, background) {
#initial checks
if ((is.null(foreground) | rlang::is_empty(foreground)) |
(is.null(background) | rlang::is_empty(background)))
stop('Need both foreground and background colors')
if (!is.character(foreground) | !is.character(background))
stop(strwrap('Elements must be character string as a named R color or
hex (e.g. "#ffffff")'))
#note: alpha returned by col2hex will be ignored
if (foreground %in% colors()){
foreground <- col2hex(foreground)
} else {
if (!nchar(foreground) %in% c(7, 9) | !grepl('^#', foreground))
stop(strwrap('foreground must be an R color, e.g. see colors(),
or a hex of the form #ff5500'))
}
if (background %in% colors()) {
background <- col2hex(background)
} else {
if (!nchar(background) %in% c(7, 9) | !grepl('^#', background))
stop(strwrap('background must be an R color, e.g. see colors(),
or a hex of the form #ff5500'))
}
#remove pound sign
foreground <- substr(foreground, start = 2, stop = nchar(foreground))
background <- substr(background, start = 2, stop = nchar(background))
url <- paste0('https://webaim.org/resources/contrastchecker/?fcolor=',
foreground,
'&bcolor=',
background,
'&api')
result <- suppressWarnings({readLines(url)})
if (!requireNamespace('jsonlite', quietly = TRUE)) {
result <- strsplit(
gsub(result, pattern = '\\{|\\}|\"', replacement = ''),
',')
return(result[[1]])
}
data.frame(jsonlite::fromJSON(result))
}
for (value in result.df) {
color_contrast_checker(foreground=result.df$Var1, background=result.df$Var2) #Var1 & Var2 column names of result.df df that contains list of hex codes
}
#Have also tried:
for (i in 1:length(unique(background_col_list))) {
color_contrast_checker(background_col_list, foreground_col_list)
}
The simplest option in base R would be results = apply(result.df, 1, function(x) color_contrast_checker(x[1], x[2])) which you can then transform in more a readable output (e.g. do.call(rbind, results)).
However, this function is a bit slow - you can implement the check yourself pretty easily in R.
First, we check what W3C uses as contrast ratio:
contrast ratio
(L1 + 0.05) / (L2 + 0.05), where
L1 is the relative luminance of the lighter of the colors, and
L2 is the relative luminance of the darker of the colors.
Then we check what W3C defines as relative luminance:
For the sRGB colorspace, the relative luminance of a color is defined as L = 0.2126 * R + 0.7152 * G + 0.0722 * B
So at this point all you need to do is calculate the relative luminance of each color, then their ratio, and check whether they pass any of the thresholds required:
WCAG 2.0 level AA requires a contrast ratio of at least 4.5:1 for normal text and 3:1 for large text. WCAG 2.1 requires a contrast ratio of at least 3:1 for graphics and user interface components (such as form input borders). WCAG Level AAA requires a contrast ratio of at least 7:1 for normal text and 4.5:1 for large text.
In code:
# Transform colors to RGB values, and RGB values to relative luminance
result.df$L_background = apply(col2rgb(result.df[,1]), 2, function(x)
0.2126 * x[1] + 0.7152 * x[2] + 0.0722 * x[3])
result.df$L_foreground = apply(col2rgb(result.df[,2]), 2, function(x)
0.2126 * x[1] + 0.7152 * x[2] + 0.0722 * x[3])
# Apply the contrast ratio formula (max luminance is brighter, min is darker)
result.df$L_ratio = apply(result.df[,3:4], 1, function(x)
(max(x) + 0.05)/(min(x) + 0.05))
# Check against standard thresholds
result.df$WCAG2_0_AA_pass = result.df$L_ratio > 4.5
result.df$WCAG2_1_pass = result.df$L_ratio > 3
result.df$WCAG_AAA_pass = result.df$L_ratio > 7
This is relatively fast for checks that are not huge. There may be a vectorized solution somewhere.
Related
I am trying to exercise a simulation of Sierpinski triangle in R with affine transformation and Iterated Function System (IFS). And hopefully, I can further exercise how the simulation of Barnsley's fern can also be done. For those who know Chinese, this video is my starting point of this exercise.
Here is a short introduction of the simulation process:
Create an equilateral triangle, name the vertices A, B, C
Create a random initial point lying inside the triangle ABC
Sample A, B, C with equal chances
If the outcome is A, then move the initial point to the midpoint of A and itself
Repeat step 3, and move the last point to the midpoint of the outcome point and itself.
By doing this repeatedly, we should see the path of the points looks like a Sierpinski triangle.
I wonder how the assignment of variable works inside a self-defined function. I would like to create an object (a matrix or a dataframe) to store the path of simulated points and keep updating the object to keep track of how the points move.
the following is my current codes:
# create the triangle
triangle <- matrix(c(A = c(-1,0),
B = c(1, 0),
C = c(0, sqrt(3))),
byrow = TRUE, nrow = 3, ncol = 2)
colnames(triangle) <- c("X", "Y") # axis name
rownames(triangle) <- c("A", "B", "C")
# sample an initial point inside the triangle ABC
sampleInit <- function(){
X <- runif(1, min = -1, max = 1)
Y <- runif(1, min = 0, max = sqrt(3))
if( (Y >= 0) && (Y <= (sqrt(3)*X + sqrt(3))) && (Y <= -sqrt(3)*X+sqrt(3)) ){
return(cbind(X, Y))
} else {
sampleInit()
}
}
### graph: plot the triangle and the initial point together
graphics.off()
plot(triangle, xlim = c(-1, 1), ylim = c(0, sqrt(3)))
par(new = TRUE)
plot(sampleInit(), xlim = c(-1, 1), ylim = c(0, sqrt(3)), col = "red")
### a three-sided dice: determine the direction to move along
diceRoll <- function(){
return(sample(c("A", "B", "C"), size = 1, prob = c(1/3, 1/3, 1/3)))
}
## path
stepTrace <- as.data.frame(sampleInit())
move <- function(diceOutCome, stepTrace){
lastStep <- tail(stepTrace, 1)
if(diceOutCome == "A"){
X <- (-1 + lastStep[,1])/2
Y <- (0 + lastStep[,2])/2
} else if(diceOutCome == "B"){
X <- (1 + lastStep[,1])/2
Y <- (0 + lastStep[,2])/2
} else if(diceOutCome == "C"){
X <- (0 + lastStep[,1])/2
Y <- (sqrt(3) + lastStep[,2])/2
}
lastStep <- cbind(X, Y)
stepTrace <- rbind(stepTrace, lastStep)
}
move(diceRoll(), stepTrace)
View(stepTrace)
Sorry for the long story and not jumping to the key question directly. My question is that stepTrace (the object I would like to store the path) didn't get updated as I execute the last two lines.
What I imagined was the assignment process in move() updates the dataframe stepTrace, however it turns out it doesn't. I check my code in the debugger, and found out that stepTrace did get updated inside the function call, but it didn't pass the new assigned value outside the function call. That's why I would like to ask how does the assignment process works in R. What is the difference between the this kind of process and other general purpose languages such as Java? (What I imagined to do this exercise in Java would not encounter this kind of assignment issue. Correct me if I am wrong since I am still new to Java)
Similar problems bother me when I tried to assign variables inside a loop. I know there is a base function assign that helps to resolve is issue, but I just don't know what is the mechanism behind it.
I tried to google my question, but I am not sure which keyword I should use, and I didn't find direct answers to my question. Any comment, keyword or external resource to the documentation is appreciated!
In short, your move function does what you want, but it is not advisable to write it like that. In its current form, stepTrace is updated in the function's local environment, but not in the global environment, where your stepTrace lives. They are not the same stepTrace. To fix it, you can run stepTrace <- move(diceRoll(), stepTrace), but beware of the second circle. For a cleaner approach, remove the last stepTrace assignment from move.
From ?return: If the end of a function is reached without calling return, the value of the last evaluated expression is returned.
Consider the following examples:
x <- 5
a <- b <- c <- d <- 1
f1 <- function(x) x + 1
f2 <- function(x) return(x + 1)
f3 <- function(x) x <- x + 1
f4 <- function(x) x <<- x + 1
f1(1)
f2(1)
f3(1) # your problem
f4(1) # x gets replaced with x in f4, 2 in global environment.
a <- b <- c <- d <- 1
a <- f1(1)
b <- f2(1)
c <- f3(1)
d <- f4(1)
f3 and f4 are generally considered bad practice because of side effects, i.e. they (can) modify a non-local variable, f2 might trigger a discussion. For f3, see the result of
c(f3(1))
#> [1] 2
Given our experiment of calling f3(1) by itself, we'd expect a vector of length 0 (?). Consider removing any assignment as the last operation within your functions, and avoid naming your function arguments the same as the objects you intend to change.
#DonaldSeinen explained how to fix your code in his answer. I'll try to point you to documentation for more details.
First, you don't need to go to external documentation. An Introduction to R and The R Language Definition manuals are included in R distributions. The Introduction describes what's going on in lots of detail in section 10.7, "Scope". There's a different description in the Language Definition in section 3.5, "Scope of Variables".
Some people find the language in those manuals to be too technical. An easier to read external reference that gets it right is Wickham's Advanced R, readable online at https://adv-r.hadley.nz/. Scoping is discussed in chapters 6 and 7, especially sections 6.4 and 7.2.
When plotting the ratio between two variables, their relative order is often of no concern, yet depending on which variable is in the numerator, its relative size is constrained either to (0,1) or (1, Inf), which is somewhat unintuitive and breaks symmetry. I want to plot ratios "symmetrically", without resorting to symmetric log-scale, by having a y-axis that goes like 1/4, 1/3, 1/2, 1, 2, 3, 4 or, equivalently, 4^-1, 3^-1, 2^-1, 1, 2, 3, 4 in regular intervals. I've come up with the following:
symmult <- function(x){
isf <- is.finite(x) & (x>0)
xf <- x[isf]
xf <- ifelse(xf>=1,
xf-1,
1-(1/xf))
x[isf] <- xf
x[!isf] <- NA
x[!is.finite(x)] <- NA
return(x)
}
symmultinv <- function(x){
isf <- is.finite(x)
xf <- x[isf]
xf <- ifelse(x[isf]>=0,
x[isf]+1,
-1/(x[isf]-1))
x[isf] <- xf
x[!isf] <- NA
x[!is.finite(x)] <- NA
return(x)
}
sym_mult_trans = function(){trans_new("sym_mult", symmult, symmultinv )}
x <- c(-4:-2, 1:4)
x[x<1] <- 1/abs(x[x<1])
ggplot() +
geom_point(aes(x=x, y=x)) +
scale_y_continuous(trans="sym_mult")
The transformation works, but I cannot get the axis labels etc. to work for any 0<x<1, without setting them manually. Any help would be greatly appreciated.
You can create bespoke 'breaks' and 'format' functions that you can use inside trans_new (or pass to scale_y_continuous directly via its breaks and labels parameters).
For the breaks function, remember it will take as input a length-two numeric vector representing the range of the y axis. You must then convert this to a number of appropriate breaks. Here, if the minimum of the range is less than one, we take its reciprocal, find the pretty breaks between one and that number, then take the reciprocal of the output. We concatenate that onto pretty breaks between 1 and our range maximum:
# Define breaks function
symmult_breaks <- function(x) {
c(1 / extended_breaks(5)(c(1/x[x < 1], 1)),
extended_breaks(5)(c(1, x[x >= 1])))
}
For the labelling function, remember, it needs to take as input the vector of numbers produced by our breaks function. We can paste a 1/ in front of the reciprocal of numbers less than one, but leave numbers of 1 or more unaltered:
# Define labelling function
symmult_labs <- function(x) {
labs <- character(length(x))
labs[x >= 1] <- as.character(x[x >= 1])
labs[x < 1] <- paste("1", as.character(1/x[x < 1]), sep = "/")
labs
}
So your full new transformation becomes:
# Use our four functions to define the whole transformation:
sym_mult_trans <- function() {
trans_new(name = "sym_mult",
transform = symmult,
inverse = symmultinv,
breaks = symmult_breaks,
format = symmult_labs)
}
And your plot becomes:
ggplot() +
geom_point(aes(x = x, y = x)) +
scale_y_continuous(trans = "sym_mult")
I need to scan nearly a million datapoints and determine if they lay under or above a threshold. I have the threshold defined globally and I have a simple predefined function
function.lower.penalty <- function(i,j){ if( i < j ){
#if gate condition is met, flip the gate flag:
n <- 1 }else{n<-0} return(n) }
that I call with mapply, which will write a 0/1 flag column in my dataframe:
df[, paste0("outside.highpass")] <- mapply(function.lower.penalty,i="somesignal.found.in.df", j="*some.threshold.found.in.df*" )
This is pretty straightforward, I can flag dozens of signals with their respective thresholds like this in a second big dataframe. Also, given how the threshold is written, the code will either flag the signals as below/above the threshold (meaning I got also a function.higher.penalty).
Now I was asked to make a more complex threshold that has the shape of a multisegmented line.
What is the fastest way to flag datapoints given that you have only the corner points of the multisegmented line (I can guess them according to how they painted the line) visible here.
Until now I had a predefined threshold (gray 0.2) and used mapply to scan the signal drawn on the x-axis. I just used a function to return 0 or 1 if datapoint was smaller or bigger than the threshold. Now I need a multisegmented line like the one drawn in red to do the same job.
Edit: Using the suggestion from det I was able to flag datapoints in the dataframe. However, it seems that some datapoints close to the defined line are wrongly assinged, see here. I am wondering as how to work around it or if this is a drawing error?
You can create function which returns picewise linear function based on points:
picewiseLinear <- function(x.var, y.var){
stopifnot(length(x.var) == length(y.var), sum(duplicated(x.var)) == 0)
p <- order(x.var)
x.var <- x.var[p]
y.var <- y.var[p]
k <- diff(y.var) / diff(x.var)
l <- -1 * k * head(x.var, -1) + head(y.var, -1)
function(x){
ind <- findInterval(x, x.var)
if(!all(between(ind, 1, length(x.var) - 1))) stop("wrong input")
x * k[ind] + l[ind]
}
}
For example:
point_df <- tribble(
~x, ~y,
3, 0,
5, 2,
3, 3,
5, 4
)
f <- picewiseLinear(point_df$y, point_df$x)
(on your picture you have picewise linear function but looked on x as dependent variable)
and on example dataset you get something like this:
set.seed(123)
tibble(
x = runif(1000, 0, 6),
y = runif(1000, 0, 4)
) %>%
mutate(color = ifelse(x > f(y), "red", "blue")) %>%
ggplot(aes(x, y)) +
geom_point(aes(color = color)) +
scale_color_identity() +
geom_path(data = point_df)
I have generated a pixel-based image by encoding each input character to a certain color in the image. For example, in input txt <- "ABACDAAFFEDDADFAFAED" i plotted 'A' as a red pixel, 'B' as purple, 'C' by blue and 'D' by some other color. I used R for it. Here is the answer from where I have taken help for this
Generate pixel based image in R from character array
Now, I want to update this for handling a case as well where I have a character presents 2 or three times consecutively and I want to give it a different color. For example txt <- "ABBACDAABBBEDDADCACABBDB", i want to give
A- red, AA maroon, AAA dark red.
B-green, BB- Pink, BBB-yellow,
C-light brown, CC brown, CCC dark brown etc.
I still want to give 1 pixel to each char but for consecutive 2 or 3 appearances color those 2 or 3 pixels with a different color. I am unable to code a reasonable solution for it in R. Your help will be appreciated. Thanks
I changed the function to support multiple character :
library(png)
library(tiff)
library(abind)
# function which plots the image
createImage <- function(txt,charToColorMap,destinationFile,format=c('png','tiff'),debugPlot=FALSE,unused.char='#'){
if(nchar(unused.char) != 1){
stop('unused.char must be a single character, and you should be sure that it will never be present in your text')
}
# helper function which finds all the divisors of a number
divisors <- function(x){
y <- seq_len(x)
y[ x%%y == 0 ]
}
# split the string in charaters
chars <- strsplit(txt,'')[[1]]
# find the most "squared" rectangle that contains all the characters without padding
d <- divisors(length(chars))
y <- d[length(d) %/% 2]
x <- length(chars) / y
# create an array with 4 matrices (or planes) one for each RGBA channel
RGBAmx <- col2rgb(charToColorMap,alpha=TRUE) / 255
colorIndexes <- match(chars,names(charToColorMap))
######################################
# MULTIPLE CHAR
######################################
# check if color map contains multiple character names
multiple <- names(charToColorMap)[nchar(names(charToColorMap)) > 1]
multiple <- multiple[order(nchar(multiple),decreasing=TRUE)]
txtForMultiple <- txt
for(m in multiple){
idxs <- gregexpr(pattern=m,text=txtForMultiple,fixed=TRUE)[[1]]
charRanges <- unlist(lapply(idxs,seq,length.out=nchar(m)))
colorIndexes[charRanges] <- which(names(charToColorMap)==m)[1]
tmp <- strsplit(txtForMultiple,'')[[1]]
tmp[charRanges] <- unused.char
txtForMultiple <- paste(tmp,collapse='')
}
#########################################################
colorIndexesR <- matrix(RGBAmx['red',colorIndexes],nrow=y,ncol=x,byrow = TRUE)
colorIndexesG <- matrix(RGBAmx['green',colorIndexes],nrow=y,ncol=x,byrow = TRUE)
colorIndexesB <- matrix(RGBAmx['blue',colorIndexes],nrow=y,ncol=x,byrow = TRUE)
colorIndexesA <- matrix(RGBAmx['alpha',colorIndexes],nrow=y,ncol=x,byrow = TRUE)
planes <- abind(colorIndexesR,colorIndexesG,colorIndexesB,colorIndexesA,along=3)
# write the PNG image
if(format[1] == 'png'){
writePNG(planes,destinationFile)
}else if(format[1] == 'tiff'){
writeTIFF(planes,destinationFile)
}else{
stop('usupported format')
}
# for debug purpose only we plot the image...
if(debugPlot){
mx <- matrix(colorIndexes,nrow=y,ncol=x,byrow = TRUE)
image(z=t(mx[nrow(mx):1,]),col=charToColorMap)
}
invisible()
}
Usage example ('AAA' set to white) :
charToColorMap <- c(A='red',B='blue',C='green',D='black',E='yellow',F='orange',AAA='white')
txt <- "ABACAAAFFEDDADFAFAED"
# please note that unused.char will be used to mark the characters of txt already analyzed
# during the multi-char handling, so it must not be present in txt
createImage(txt,charToColorMap,destinationFile = "test.png",debugPlot=TRUE,unused.char='#')
Result (zoom 800 %):
I need to create a stacked barplot from data of the form c² = a² + b². a² and b² are normalized by c² such that a and b add up to 1. The data I have requires specific formats so that a and b need to be lists. Below is a simplest reproducible example given those specific formats:
A = list(-2,-1,1,2)
B = list(1,2,3,4)
numA = as.numeric(A)
numB = as.numeric(B)
C = numA*numA + numB*numB
data = matrix(c(numA*numA/C,numB*numB/C),byrow=TRUE,ncol=4)
barplot(data,col=c('black','grey'))
However, when the numA is negative I would like the color to be black, but when numA is positive I would like it to be red. I have created the vector for the colors with the following code
my_cols = c()
for (i in seq_along(A)) {
if (A[[i]] < 0) {
color = 'red'
} else {
color = 'black'}
my_cols <- append(my_cols,c(color,'grey'))
}
but trying
barplot(data,col=my_cols)
simply takes the first two colours and assigns them to all the bars. Is there a way to do what I need in R?