I'm trying to create a line chart with many series (more than 50) using the highcharter package in R.
When I use fewer series (less than 40) my tooltip works correctly, but when the number of series increase, the tooltip stops displaying the category of the x-axis and starts simply counting from zero to the number of ticks. Here is the code to reproduce:
library(dplyr)
library(highcharter)
test1<-data.frame(Value=rnorm(300,0,1),Type=rep(c('A','B','C'),each=100),Period=rep(seq(as.Date('2020-01-01'),as.Date('2020-04-09'),by=1),3))
test2<-data.frame(Value=rnorm(500,0,1),Type=rep(as.character(1:50),each=10),Period=rep(seq(as.Date('2020-01-01'),as.Date('2020-01-10'),by=1),50))
category1<-unique(format(test1$Period,'%d/%b/%y'))
category2<-unique(format(test2$Period,'%d/%b/%y'))
hchart(test1,type='line',hcaes(x=as.character(Period),y=Value,group=Type)) %>%
hc_xAxis(type='category',categories=as.list(category1),title='',labels=list(rotation=-30)) %>%
hc_legend(align='left',maxHeight=100) %>%
hc_plotOptions(line=list(marker=list(enabled=F))) %>%
hc_tooltip(shared=T,
formatter=JS("function() {
var s = '';
$.each(this.points, function(i, point) {
if (point.y !== 0) {
s += '<br><b>'+ point.series.name +': </b>'+ Highcharts.numberFormat(point.y,2,',','.');
}
});
return this.x + s;
}"))
hchart(test2,type='line',hcaes(x=as.character(Period),y=Value,group=Type)) %>%
hc_xAxis(type='category',categories=as.list(category2),title='',labels=list(rotation=-30)) %>%
hc_legend(align='left',maxHeight=100) %>%
hc_plotOptions(line=list(marker=list(enabled=F))) %>%
hc_tooltip(shared=T,
formatter=JS("function() {
var s = '';
$.each(this.points, function(i, point) {
if (point.y !== 0) {
s += '<br><b>'+ point.series.name +': </b>'+ Highcharts.numberFormat(point.y,2,',','.');
}
});
return this.x + s;
}"))
And here are the outputs:
I don't know if this is a limitation because of the volume of information, but it is a strange behavior that I could not solve.
I am writing a report in R Markdown, it contains multiple animated highcharts.
The animations work fine, however they all run when the html page loads (after knitting), instead of when the user scrolls to it, so essentially the animation is pointless as the user never sees it.
An example of an animated chart is at the bottom of this question.
Is there a way to make it animate when it appears? All the examples I have found use jsfiddle and I am using R Markdown.
Many thanks
library(dplyr)
library(stringr)
library(purrr)
n <- 5
set.seed(123)
df <- data.frame(x = seq_len(n) - 1) %>%
mutate(
y = 10 + x + 10 * sin(x),
y = round(y, 1),
z = (x*y) - median(x*y),
e = 10 * abs(rnorm(length(x))) + 2,
e = round(e, 1),
low = y - e,
high = y + e,
value = y,
name = sample(fruit[str_length(fruit) <= 5], size = n),
color = rep(colors, length.out = n),
segmentColor = rep(colors2, length.out = n)
)
hcs <- c("line") %>%
map(create_hc)
hcs
Ok, I worked out how to do it myself, going to post the answer here in case someone stumbles across this post in the future.
First of all, I found NOTHING on how to do this in R.
So, I decided to do this in JS, AFTER I had knitted the R Markdown document to HTML, as it wouldn't work in R Markdown.
Once it is a HTML file, open it in TextEdit or Notepad, and add the following code just before one of the charts:
<script>
(function (H) {
var pendingRenders = [];
// https://stackoverflow.com/questions/123999/how-to-tell-if-a-dom-element-is-visible-in-the-current-viewport/7557433#7557433
function isElementInViewport(el) {
var rect = el.getBoundingClientRect();
return (
rect.top >= 0 &&
rect.left >= 0 &&
rect.bottom <= (
window.innerHeight ||
document.documentElement.clientHeight
) &&
rect.right <= (
window.innerWidth ||
document.documentElement.clientWidth
)
);
}
H.wrap(H.Series.prototype, 'render', function deferRender(proceed) {
var series = this,
renderTo = this.chart.container.parentNode;
// It is appeared, render it
if (isElementInViewport(renderTo) || !series.options.animation) {
proceed.call(series);
// It is not appeared, halt renering until appear
} else {
pendingRenders.push({
element: renderTo,
appear: function () {
proceed.call(series);
}
});
}
});
function recalculate() {
pendingRenders.forEach(function (item) {
if (isElementInViewport(item.element)) {
item.appear();
H.erase(pendingRenders, item);
}
});
}
if (window.addEventListener) {
['DOMContentLoaded', 'load', 'scroll', 'resize']
.forEach(function (eventType) {
addEventListener(eventType, recalculate, false);
});
}
}(Highcharts));
</script>
The charts then animate when you scroll to them, rather than when you open the HTML file.
Note: The JSFIDDLE I got the code from was from here:
https://jsfiddle.net/gh/get/library/pure/highcharts/highcharts/tree/master/samples/highcharts/studies/appear/
This question already has answers here:
if/else constructs inside and outside functions
(2 answers)
Closed 5 years ago.
I constructed the function, but the R gives me the error. But I does not know what I did wrongly.
Error: unexpected '}' in "}"
Vect_fun=function(x,a) {
if(a=1)
{
y= mean(x,na.rm=TRUE)
}
else{
if(a=2)
{
y= na.aggregate(x)
}
else {
y=x[!is.na(x)]
}
}
y
}
Use double equal sign to comparing.
Vect_fun = function(x, a) {
if (a == 1) {
y = mean(x, na.rm = TRUE)
}
else {
if (a == 2) {
y = na.aggregate(x)
}
else {
y = x[!is.na(x)]
}
}
y
}
Your formatting is off in addition to needing to use the proper == operator, and else if
You should indent at each level so it's easier to read, and you need to use == for logical operators. Also, else{ if(){ }} is messy. Use else if{ }
Vect_fun <- function(x,a) {
if (a == 1) {
y = mean(x, na.rm = TRUE)
} else if (a == 2) {
y = na.aggregate(x)
return(y)
} else {
y = x[!is.na(x)]
}
return(y)
}
Hi I have a function called basic_plot(), which will generate a plot if the variable plot_function = TRUE else it return a NULL. it is as follows
plot_function = TRUE;
basic_plot = function() {
if(plot_function) {
par(mfrow = c(1,3))
plot(1:10,1:10,type = "o")
plot(10:1,1:10,type = "o")
plot(1:10,rep(5,10),type = "o")
} else {
NULL;
}
}
basic_plot();
should generate a plot with tree panels populated with some lines. This function along with the variable it depends on is embedded with in some other code. What I would like to know is how I can tell an if() statement if the plot has been drawn? for example
if(is.null(basic_plot())) {
print("I haven't drawn the plot yet")
} else {
print("I have drawn the plot and want to do more stuff.")
}
The problem with the above is if a function plots a graph it is considered a null. so this will never know when I draw the plot e.g
plot_function = TRUE;
is.null(basic_plot())
[1] TRUE
plot_function = FALSE;
is.null(basic_plot())
[1] TRUE
The true application for this is with in a shiny app but actually thought this could be a generic R query. I cannot return anything other than generate the plot in the basic_plot() function (avoiding the obvious return something after the plot is drawn). I am hoping for an alternative function to is.null() such as has this function does something or not?
Cheers,
C
In your function basic_plot the plot(1:10,rep(5,10),type = "o") command does not assign anything to the function, so it is still NULL
For example below will assign TRUE to your function.
plot_function = TRUE;
basic_plot = function() {
if(plot_function) {
par(mfrow = c(1,3))
plot(1:10,1:10,type = "o")
plot(10:1,1:10,type = "o")
plot(1:10,rep(5,10),type = "o")
TRUE
} else {
NULL;
}
}
basic_plot();
For storing plots as an object, recordPlot() is used:
myplot<-recordPlot()
Simple answer: return either TRUE or FALSE in your function:
basic_plot = function() {
if(plot_function) {
par(mfrow = c(1,3))
plot(1:10,1:10,type = "o")
plot(10:1,1:10,type = "o")
plot(1:10,rep(5,10),type = "o")
return(TRUE) # Now the function will plot, then return TRUE
} else {
return(FALSE) # Now the function will return FALSE instead of NULL
}
}
# We can make this a function too
check_plot <- function() {
if(basic_plot()) {
print("I have drawn the plot and want to do more stuff.")
} else {
print("I haven't drawn the plot yet")
}
}
# Now we can simply check:
plot_function <- TRUE
check_plot()
plot_function <- FALSE
check_plot()
# Note: it is generally bad practice to use global variables like this!
I am having a very odd problem in R. The question was to make a function for global and semi global allignment. Appropriate algorithms were made which are able to "print out" the correct allignment. However "returning" the alginment seems to be a problem for the semi global algorithm.
Below are the functions for both alignments which both contain two functions: one computing the score matrix and the other outputs the alignment. As you can see, the output function for semi global was inspired by the global one but although it is able to print out values A and B, when returning A and B a value NULL is returned.
It came to my attention that when making defining A and B, they also contain a NULL part which seen by printing the structures of A and B at the end. This is also the case in the global alignment but does not seem to be a problem here.
Global Alignment Algorithm
########### GLOBAL ALLIGNMENT ALGORITHM ############
GA_score = function(v,w,score.gap=-3,score.match=8,score.mismatch=-5){
v = strsplit(v,split="")[[1]]
w = strsplit(w,split="")[[1]]
S = matrix(0,nrow=(length(v)+1),ncol = (length(w)+1) )
S[1,1] = 0
for(j in 2:dim(S)[2]){
S[1,j] = score.gap*(j-1)
}
for(i in 2:dim(S)[1]){
S[i,1] = score.gap*(i-1)
for(j in 2:dim(S)[2]){
if(v[i-1]==w[j-1]){diag = S[i-1,j-1] + score.match} else {diag = S[i-1,j-1] + score.mismatch}
down = S[i-1,j] + score.gap
right = S[i,j-1] + score.gap
S[i,j] = max(diag,down,right)
}
}
return(S)
}
GA_output = function(v,w,S,score.gap=-3,score.match=8,score.mismatch=-5){
v = strsplit(v,split="")[[1]]
w = strsplit(w,split="")[[1]]
A=c()
B=c()
GA_rec = function(A,B,S,i,j,v,w,score.gap,score.match,score.mismatch){
if (i==1 | j==1){
if(i>1){
for(i1 in seq(i-1,1,-1)){
A = c(v[i1],A)
B = c("-",B)
}
}
if(j>1){
for(j1 in seq(j-1,1,-1)){
A = c("-",A)
B = c(w[j1],B)
}
}
return(list(v=A,w=B))
}
if(v[i-1]==w[j-1] ){diag = score.match} else {diag=score.mismatch}
if (S[i,j] == (S[i-1,j-1] + diag)){
A.temp = c(v[i-1],A)
B.temp = c(w[j-1],B)
GA_rec(A.temp,B.temp,S,i-1,j-1,v,w,score.gap,score.match,score.mismatch)
}
else if (S[i,j] == (S[i-1,j] + score.gap)){
A.temp <- c(v[i-1],A)
B.temp <- c("-",B)
GA_rec(A.temp,B.temp,S,i-1,j,v,w,score.gap,score.match,score.mismatch)
}
else {
A.temp = c("-",A)
B.temp = c(w[j-1],B)
GA_rec(A.temp,B.temp,S,i,j-1,v,w,score.gap,score.match,score.mismatch)
}
}
return( GA_rec(A,B,S,length(v)+1,length(w)+1,v,w,score.gap,score.match,score.mismatch))
}
Semi-Global Alignment Algorithm
########### SEMI GLOBAL ALLIGNMENT ALGORITHM ############
SGA_score = function(sequence1,sequence2,score.gap=-1,score.match=1,score.mismatch=-1){
v=sequence2
w=sequence1
v = strsplit(v,split="")[[1]]
w = strsplit(w,split="")[[1]]
S = matrix(0,nrow=length(v)+1,ncol=length(w)+1)
for(i in 1:(length(w)+1)){
for( j in 1:(length(v)+1)){
if (i==1|j==1){S[i,j]=0}
else{
if((i==length(w)+1) | (j==length(v)+1)){
from.top = S[i,j-1]
from.left = S[i-1,j]
}
else{
from.top = max(S[i,j-1]+score.gap) # Max is artifact from max(0,... )
from.left = max(S[i-1,j]+score.gap)
}
if(w[i-1] == v[j-1]){
from.diag = S[i-1,j-1]+score.match
}
else{
from.diag = S[i-1,j-1]+score.mismatch
}
S[i,j] = max(from.top,from.left,from.diag)
}
}
}
return(S)
}
SGA_output = function(v,w,S,score.gap=-1,score.match=1,score.mismatch=-1){
v = strsplit(v,split="")[[1]]
w = strsplit(w,split="")[[1]]
A=c()
B=c()
print(str(A))
print(str(B))
SGA_rec = function(A,B,S,i,j,v,w,score.gap,score.match,score.mismatch){
if (i==1 | j==1){
if(i>1){
for(i1 in seq(i-1,1,-1)){
A = c(v[i1],A)
B = c("-",B)
}
}
if(j>1){
for(j1 in seq(j-1,1,-1)){
A = c("-",A)
B = c(w[j1],B)
}
}
print(A)
print(B)
out = list(v=A,w=B)
#print(out)
print(str(A))
print(str(B))
print(str(out))
return(out)
}
if(v[i-1]==w[j-1] ){diag = score.match} else {diag=score.mismatch}
if (S[i,j] == (S[i-1,j-1] + diag)){
A.temp = c(v[i-1],A)
B.temp = c(w[j-1],B)
SGA_rec(A.temp,B.temp,S,i-1,j-1,v,w,score.gap,score.match,score.mismatch)
}
#####
if ( j==length(w)+1) { # Are we in last row?
score.temp = score.gap
score.gap=0
}
else{score.temp=score.gap}
if(S[i,j] == (S[i-1,j] + score.gap)){
A.temp <- c(v[i-1],A)
B.temp <- c("-",B)
score.gap = score.temp
SGA_rec(A.temp,B.temp,S,i-1,j,v,w,score.gap,score.match,score.mismatch)
}
score.gap=score.temp
####
if(i==length(v)+1){
score.temp=score.gap
score.gap=0
}
else{score.temp=score.gap}
if(S[i,j] == (S[i,j-1] + score.gap)){
A.temp = c("-",A)
B.temp = c(w[j-1],B)
score.gap=score.temp
SGA_rec(A.temp,B.temp,S,i,j-1,v,w,score.gap,score.match,score.mismatch)
}
}
return(SGA_rec(A,B,S,length(v)+1,length(w)+1,v,w,score.gap,score.match,score.mismatch))
}
S1 = SGA_score("ACGTCAT","TCATGCA")
S1
align = SGA_output("ACGTCAT","TCATGCA",S1)
align
I am surpised that the global alignment works but the semi global one doesn't, even tough they both have this NULL part (can someone maybe explain what this is? Has it something to do with internal objects in a function?) and the semi global knows what A and B is.
Any help is greatly appreciated!
SGA_rec seems to be missing a return value. You need an else {return(<something>)) after the last if.
Illustration:
fun <- function() if (FALSE) 1
x <- fun()
x
#NULL
Read help("NULL") to learn what it means.