I'm trying to add like an information box on hover on title of the highcharter graph. When the user hovers over title, it should show some information about the graph. Can this be achieved using Highcharter in R ?
Thank You! Here is a sample code to which I want to add hover property for title.
library(dplyr)
library(stringr)
library(purrr)
n <- 5
set.seed(123)
colors <- c("#d35400", "#2980b9", "#2ecc71", "#f1c40f", "#2c3e50", "#7f8c8d")
colors2 <- c("#000004", "#3B0F70", "#8C2981", "#DE4968", "#FE9F6D", "#FCFDBF")
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)
)
create_hc <- function(t) {
dont_rm_high_and_low <- c("arearange", "areasplinerange",
"columnrange", "errorbar")
is_polar <- str_detect(t, "polar")
t <- str_replace(t, "polar", "")
if(!t %in% dont_rm_high_and_low) df <- df %>% select(-e, -low, -high)
highchart() %>%
hc_title(text = paste(ifelse(is_polar, "polar ", ""), t, '\u2370'),
style = list(fontSize = "15px")) %>%
hc_chart(type = t,
polar = is_polar) %>%
hc_xAxis(categories = df$name) %>%
hc_add_series(df, name = "Fruit Consumption", showInLegend = FALSE)
}
hcs <- c("line") %>%
map(create_hc)
Related
I am trying to use plotly to scatter the results of applying kmeans to dataframe and I want to color the scattered points based on the results of the kmeans. I am following this this link to use plotly but plotly is not coloring the scattered plots as I would like. Here is my code.
library(plotly)
library(data.table)
library(tidyverse)
# generate the data
sample1_x <- rnorm(n = 1000, mean = 0, sd = 1)
sample1_y <- rnorm(n = 1000, mean = 1, sd = 1)
sample2_x <- rnorm(n = 1000, mean = 5, sd = 1)
sample2_y <- rnorm(n = 1000, mean = 3, sd = 1)
# store the data in dataframes
df1 <- data.frame(sample1_x, sample1_y)
df2 <- data.frame(sample2_x, sample2_y)
df <- rbind(as.data.table(df1), as.data.table(df2), use.names = FALSE)
clusts <- kmeans(df, 2, 5)
clusts <- array(unlist(clusts), dim = c(2000, 1, 1))
df <- df %>%
add_column(clusters = clusts)
# rename the columns
colnames(df)[1: 2] <- c("col1", "col2")
# plot
fig <- plot_ly(data = df,
x = ~col1, y = ~col2,
color = ~clusters,
colors = c("red", "blue"),
type = "scatter", mode = "markers")
fig
is what plotly is returning, but what I want is .
The problem is that your clusters column is an <array> instead of a <num>.
set.seed(1)
df <- data.frame(col1 = c(rnorm(1000, 0), rnorm(1000, 5)),
col2 = c(rnorm(1000, 1), rnorm(1000, 3)))
setDT(df)
clusts <- kmeans(df, 2, 5)
df[, clusters := clusts$cluster]
plot_ly(data = df,
x = ~col1, y = ~col2,
color = ~clusters,
colors = c("red", "blue"),
type = "scatter", mode = "markers")
I think I'm basically looking for an R plotly equivalent to this python plotly post:
I have a XY data.frame that I'd like to plot using R's plotly, where each point belongs to either one of two types ("a"/"b"), and nested within each type is a group, and the group assignment is redundant.
My purpose is to color code the points according to the group frequency, where each type uses a different color scale.
Here's the data.frame:
library(dplyr)
set.seed(1)
df <- rbind(data.frame(type = "a", group = paste0("a", sample(1000, 500, replace = T))) %>%
cbind(as.data.frame(MASS::mvrnorm(n = 1000,mu = c(-5,-5),Sigma = matrix(c(5, 3, 4, 4), ncol=2)))),
data.frame(type = "b", group = paste0("b", sample(500, 50, replace = T))) %>%
cbind(as.data.frame(MASS::mvrnorm(n = 500,mu = c(5,5),Sigma = matrix(c(5, 3, 4, 4), ncol=2))))) %>%
dplyr::rename(x = V1, y = V2)
Here I compute the frequency of each group, for each type, and then add two artificial points per each type, with the global minimum and maximum frequency (f), so that the color scales use a comment numeric scale:
freq.df <- rbind(dplyr::group_by(dplyr::filter(df, type == "a"), type, group) %>%
dplyr::tally() %>%
dplyr::mutate(f = 100*n/sum(n)) %>%
dplyr::select(-n),
dplyr::group_by(dplyr::filter(df, type == "b"), type, group) %>%
dplyr::tally() %>%
dplyr::mutate(f = 100*n/sum(n)) %>%
dplyr::select(-n)) %>%
dplyr::ungroup() %>%
rbind(data.frame(type = c(rep("a", 2), rep("b", 2)), group = c(rep("a", 2), rep("b", 2)), f = rep(c(min(.$f), max(.$f)), 2), stringsAsFactors = F))
And now joining freq.df to df:
df <- df %>% dplyr::left_join(freq.df)
Here's how I'm trying to plot it:
plotly::plot_ly(marker = list(size = 3), type = 'scatter', mode = "markers", color = dplyr::filter(df, type == "a")$f, colors = viridis::viridis_pal(option = "D")(3), x = dplyr::filter(df, type == "a")$x, y = dplyr::filter(df, type == "a")$y) %>%
plotly::add_trace(marker = list(size = 3),type = 'scatter', mode = "markers",color = dplyr::filter(df, type == "b")$f,colors = viridis::viridis_pal(option = "A")(3), x = dplyr::filter(df, type == "b")$x,y=dplyr::filter(df,type == "b")$y) %>%
plotly::layout(xaxis = list(zeroline = F, showticklabels = F, showgrid = F),yaxis = list(zeroline = F,showticklabels = F, showgrid = F))
Which only gives me the colorbar of first color scale (viridis's cividis):
Any idea how to get both colorbars (viridis's cividis and viridis's magma) appear side by side?
In the below reproducible example Code 1, the user stratifies data and selects which variable to stratify the data by, Value_1 or Value_2; and also selects to view the stratification as a table or as a plot. Code 1 works as intended, and the stratification range label is a static "Range" (as shown in the table left-most column header and in the plot x-axis label, and as shown in the images at the bottom).
I am making the range label dynamic (reactive), because in the fuller App this example derives from the user has many variables to choose from for stratification.
In Code 2 below showing an amplified custom function stratData(), I have succeeded in making the table left-most column header for stratification ranges reactive, but I haven't yet figured out how to make the plot x-axis label for stratification ranges similarly reactive. Just replace the stratData() in Code 1 with the stratData() in Code 2 (and comment-out the plot code under renderPlot() to avoid seeing the error) to see how this is working (or not).
How could the plot x-axis label reflect the same reactivity as the table left-most column header?
Code 1:
library(ggplot2)
library(shiny)
library(tidyverse)
library(shinyWidgets)
ui <-
fluidPage(
uiOutput("strat_values"),
radioButtons(
inputId = 'stratsView',
label = NULL,
choices = list("Table view" = 1,"Plot view" = 2),
selected = 1,
inline = TRUE
),
conditionalPanel(condition = "input.stratsView == 1",h5(strong("Stratified data:")), tableOutput("stratData")),
conditionalPanel(condition = "input.stratsView == 2",h5(strong("Stratified data:")), plotOutput("stratPlot"))
)
server <- function(input, output, session) {
dat <- reactive({
data.frame(
ID = c(1,1,2,2,2,2,3,3,3,3),
Period = c("2020-03", "2020-04", "2020-01", "2020-02", "2020-03", "2020-04", "2020-01", "2020-02", "2020-03", "2020-04"),
Values_1 = c(-6, 26, 36, 46, 56, 86, 100, 10, 20, 30),
Values_2 = c(-3, 13, 18, 23, 28, 43, 50, 5, 10, 15)
)
})
output$strat_values <- renderUI({
selectInput("strat_values",
"Variable to range-spread (col 1):",
choices = c("Values_1","Values_2"),
selected = c("Values_1"))
})
stratData <- function(){
req(input$strat_values)
filter_exp1 <- parse(text=paste0("Period", "==", "'","2020-04", "'"))
dat_1 <- reactive({dat() %>% filter(eval(filter_exp1))})
breaks <- seq(min(dat_1()[[input$strat_values]]), max(dat_1()[[input$strat_values]]), length.out = 6)
tmp <- dat() %>%
filter(eval(filter_exp1)) %>%
mutate(Range = cut(!!sym(input$strat_values), breaks=breaks, include.lowest=TRUE, right = TRUE, dig.lab = 5)) %>%
group_by(Range)
tmp <- tmp %>%
summarise(Count = n(),Values = sum(!!sym("Values_2"))) %>%
complete(Range, fill = list(Count = 0,Values = 0)) %>%
ungroup %>%
mutate(Count_pct = Count/sum(Count)*100, Values_pct = Values/sum(Values)*100) %>%
dplyr::select(everything(), Count, Count_pct, Values, Values_pct) %>%
bind_rows(summarise_all(., ~(if(is.numeric(.)) sum(.) else "Total")))
Count <- tmp %>% pull(Count)
Range <- tmp %>% pull(Range)
list(data = tmp,
Range = Range[-length(Range)],
Count = as.data.frame(Count[-length(Count)]))
}
output$stratData <- renderTable({stratData()$data})
output$stratPlot <- renderPlot({
x <- factor(stratData()$Range, levels = c(stratData()$Range))
y <- as.matrix(stratData()$Count)
ggplot(stratData()$Count,aes(x,y)) +
geom_bar(stat="identity") +
labs(x = "Ranges") +
geom_text(aes(y = y + sign(y)/4,label = y))
})
}
shinyApp(ui, server)
Code 2:
stratData <- function(){
req(input$strat_values)
filter_exp1 <- parse(text=paste0("Period", "==", "'","2020-04", "'"))
dat_1 <- reactive({dat() %>% filter(eval(filter_exp1))})
breaks <- seq(min(dat_1()[[input$strat_values]]), max(dat_1()[[input$strat_values]]), length.out = 6)
tmp <- dat() %>%
filter(eval(filter_exp1)) %>%
mutate(sumvar = cut(!!sym(input$strat_values), breaks=breaks, include.lowest=TRUE, right = TRUE, dig.lab = 5)) %>%
group_by(sumvar)
tmp <- tmp %>%
summarise(Count = n(),Values = sum(!!sym("Values_2"))) %>%
complete(sumvar, fill = list(Count = 0,Values = 0)) %>%
ungroup %>%
mutate(Count_pct = Count/sum(Count)*100, Values_pct = Values/sum(Values)*100) %>%
dplyr::select(everything(), Count, Count_pct, Values, Values_pct) %>%
bind_rows(summarise_all(., ~(if(is.numeric(.)) sum(.) else "Total")))
names(tmp)[1] <- paste(input$strat_values, " Range")
Count <- tmp %>% pull(Count)
# Range <- tmp %>% pull(Range)
list(data = tmp,
# Range = Range[-length(Range)],
Count = as.data.frame(Count[-length(Count)]))
}
Resolved code:
Now with OP code correction and reflecting Stefan's comment for plot axis label reactivity; posting revised stratData() custom function where only one line was fixed (commented below) and the renderPlot() function where Stefan's axis-label solution is also commented:
stratData <- function(){
req(input$strat_values)
filter_exp1 <- parse(text=paste0("Period", "==", "'","2020-04", "'"))
dat_1 <- reactive({dat() %>% filter(eval(filter_exp1))})
breaks <- seq(min(dat_1()[[input$strat_values]]), max(dat_1()[[input$strat_values]]), length.out = 6)
tmp <- dat() %>%
filter(eval(filter_exp1)) %>%
mutate(Range = cut(!!sym(input$strat_values), breaks=breaks, include.lowest=TRUE, right = TRUE, dig.lab = 5)) %>%
group_by(Range)
tmp <- tmp %>%
summarise(Count = n(),Values = sum(!!sym("Values_2"))) %>%
complete(Range, fill = list(Count = 0,Values = 0)) %>%
ungroup %>%
mutate(Count_pct = Count/sum(Count)*100, Values_pct = Values/sum(Values)*100) %>%
dplyr::select(everything(), Count, Count_pct, Values, Values_pct) %>%
bind_rows(summarise_all(., ~(if(is.numeric(.)) sum(.) else "Total")))
names(tmp)[1] <- paste(input$strat_values, " Ranges")
Count <- tmp %>% pull(Count)
Range <- tmp %>% pull(var = 1) # var = 1 pulls left-most column from tmp dataframe
list(data = tmp,
Range = Range[-length(Range)],
Count = as.data.frame(Count[-length(Count)]))
}
output$stratPlot <- renderPlot({
x <- factor(stratData()$Range, levels = c(stratData()$Range))
y <- as.matrix(stratData()$Count)
ggplot(stratData()$Count,aes(x,y)) +
geom_bar(stat="identity") +
labs(x = paste(input$strat_values, " Ranges")) + # < Added line this per Stefan comment
geom_text(aes(y = y + sign(y)/4,label = y),
position = position_nudge(y = 0),
size = 5)
})
I'm trying to do a semi circle donut with highcharter library but I only know how to do a pie chart. I know that with JS you can do it by adding "startAngle" and "endAngle" but I want to know how to do it with R:
A <- c("a", "b", "c", "d")
B <- c(4, 6, 9, 2)
C <- c(23, 26, 13, 15)
df <- data.frame(A, B, C)
highchart() %>%
hc_chart(type = "pie") %>%
hc_add_series_labels_values(labels = df$A, values = df$B)%>%
hc_tooltip(crosshairs = TRUE, borderWidth = 5, sort = TRUE, shared = TRUE, table = TRUE,
pointFormat = paste('<b>{point.percentage:.1f}%</b>')
) %>%
hc_title(text = "ABC",
margin = 20,
style = list(color = "#144746", useHTML = TRUE))
Thank you!
You can do something like this though not using Highcharts library.
library(tidyverse)
library(ggforce)
library(scales)
library(ggplot2)
# -------------------------------------------------------------------------
A <- c("a", "b", "c", "d")
B <- c(4, 6, 9, 2)
C <- c(23, 26, 13, 15)
df <- data.frame(A, B, C)
# Ensure A is a factor (we'll be using it to fill the pie)
df$A <- factor(df$A)
# compute the individual proportion in this case using var C
df$prop <- df$C/sum(df$C)
# compute the cumulative proportion and use that to plot ymax
df$p_end <- cumsum(df$prop)
# generate a y-min between 0 and 1 less value than p_end (using p_end)
df$p_start <- c(0, head(df$p_end ,-1))
# -------------------------------------------------------------------------
# plot
df %>%
mutate_at(c("p_start", "p_end"), rescale, to=pi*c(-.5,.5), from=0:1) %>%
ggplot +
geom_arc_bar(aes(x0 = 0, y0 = 0, r0 = .5, r = 1, start = p_start, end = p_end, fill=A)) +
coord_fixed() +xlab("X_label") + ylab("Y_lablel") + guides(fill=guide_legend(title="Legend Title"))
Output
Hope that helps.
Try adding startAngle = -90, endAngle = 90 inside hc_add_series_labels_values.
Note as per the warning hc_add_series_labels_values is deprecated so suggest using hc_add_series.
highchart() %>%
hc_add_series(type = "pie", data = df, hcaes(x = A, y = B), startAngle = -90, endAngle = 90) %>%
hc_tooltip(pointFormat = '<b>{point.percentage:.1f}%</b>') %>%
hc_title(text = "ABC",
margin = 20,
style = list(color = "#144746", useHTML = TRUE))
I'm trying to use formattable awesome package and get a table with percentages and color scaled on multiple columns.
Here is the code
set.seed(123)
df <- data.frame(id = 1:10,
a = rnorm(10), b = rnorm(10), c = rnorm(10))
df$a <- percent(df$a)
df$b <- percent(df$b)
df$c <- percent(df$c)
table_with_percent_but_color_not_scaled <- formattable(df, list(a = color_tile("transparent", "pink")
, b= color_tile("transparent", "pink")
, c= color_tile("transparent", "pink")))
table_with_color_scaled_but_not_percent <- formattable(df, list(area(col = 2:4) ~ color_tile("transparent","pink")))
Problem is that table_with_color_scaled_but_not_percent don't keep the percentage format :
and table_with_percent_but_color_not_scaled don't keep the same scale for coloring the colors:
Ideally I would like to use the area functionality, since my df number of columns and name will change in my final code.
Any idea ?
Thanks!
I had the same problem a while back and had to create my own formatter. Here's the formatter with code used to create a table similar to yours. Just adjust the tags inside the style.
library(tidyverse)
library(formattable)
colorbar <- function(color = "lightgray", fun = "comma", digits = 0) {
fun <- match.fun(fun)
formatter("span", x ~ fun(x, digits = digits),
style = function(y) style(
display = "inline-block",
direction = "rtl",
"border-radius" = "4px",
"padding-right" = "2px",
"background-color" = csscolor(color),
width = percent(proportion(as.numeric(y), na.rm = TRUE))
)
)
}
set.seed(123)
df <- data.frame(id = as.factor(1:10),
a = rnorm(10), b = rnorm(10), c = rnorm(10)) %>%
mutate_if(is.numeric, percent)
tbl <- df %>%
formattable(list(area(col = 2:4) ~ colorbar(color = "pink", fun = "percent", digits = 2))) %>%
as.htmlwidget()
If you have questions, let me know!