Below is the code to develop sparkline in R. Wanted to check if we can change the color . I mean the negative values to be black and positive values to be red
library(shiny)
library(DT)
library(data.table)
library(sparkline)
## Create demo data sets
my_mtcars <- data.table(mtcars, keep.rownames = TRUE)
names(my_mtcars)[1] <- 'car_id'
set.seed(0)
data_for_sparklines <- data.table(car_id = rep(my_mtcars$car_id, 5),
category = 1:5,
value = c(runif(80),-runif(80)))
sparkline_html <- data_for_sparklines[, .(sparkbar = spk_chr(value, type = 'bar',barColor = "black")), by = 'car_id']
my_mtcars <- merge(my_mtcars, sparkline_html, by = 'car_id')
spk_add_deps(datatable(my_mtcars, escape = FALSE))
Related
I am trying to add sparklines to multiple columns of a Data Table in R. I am able to get a single Sparkline column to render correctly, but when I try to render a sparkline in a second column based on different underlying data than the first, the same sparkline is displayed in the second column. I imagine there is some snippet of code needed in the fnDrawCalback option, but I have not been able to find much out there addressing my issue.
Here is a reproducible example for both a single sparkline (works) and a two sparklines (just repeats the first sparkline in both columns)
# create data with single sparkline column
library(sparkline)
library(DT)
spark_data <- data.frame(
id = c('spark1', 'spark2'),
spark = c(
spk_chr(values = 1:3, elementId = 'spark1'),
spk_chr(values = 3:1, elementId = 'spark2')
)
)
tbl <- datatable(spark_data, escape = F,
rownames = F
, options = list(fnDrawCallback = htmlwidgets::JS('function(){
HTMLWidgets.staticRender();
}'))
)
spk_add_deps(tbl)
# create data with two sparkline columns
library(sparkline)
library(DT)
spark_data <- data.frame(
id = c('spark1', 'spark2'),
spark = c(
spk_chr(values = 1:3, elementId = 'spark1'),
spk_chr(values = 3:1, elementId = 'spark2')
),
second_spark = c(spk_chr(values = 3:1, elementId = 'spark1'),
spk_chr(values = 1:3, elementId = 'spark2'))
)
tbl <- datatable(spark_data, escape = F,
rownames = F
, options = list(fnDrawCallback = htmlwidgets::JS('function(){
HTMLWidgets.staticRender();
}'))
)
spk_add_deps(tbl)
I am following this R tutorial here (towards the end of the page) : https://glin.github.io/reactable/articles/examples.html. I would like to make an interactive map that allows you to filter points on the map - i.e. when you click on the table rows, points on the map appear and disappear.
I decided to generate my own data for this problem. I am following the last part where they make a map/table:
library(leaflet)
library(htmltools)
library(crosstalk)
library(reactable)
library(htmlwidgets)
myFun <- function(n = 5000) {
a <- do.call(paste0, replicate(5, sample(LETTERS, n, TRUE), FALSE))
paste0(a, sprintf("%04d", sample(9999, n, TRUE)), sample(LETTERS, n, TRUE))
}
id = 1:1000
long = 2.2945 + rnorm( 1000, 0.1085246 , 0.1)
lat = 48.8584 + rnorm( 1000, 0.009036273 , 0.1)
my_data_1 = data.frame(id, lat, long, var1 = myFun(1000), var2 = myFun(1000), var3 = myFun(1000) )
Then, I manipulated the data according
brew_sp <- SharedData$new(my_data_1, group = "breweries")
brew_data <- as_tibble(my_data_1) %>%
select(var1, var2, var3) %>%
SharedData$new(group = "breweries")
I then tried to make the map (I added a small change to the map):
map <- leaflet(brew_sp) %>%
addTiles() %>%
addMarkers(clusterOption=markerClusterOptions())
And then the table:
tbl <- reactable(
brew_data ,
selection = "multiple",
filterable = TRUE,
searchable = TRUE,
onClick = "select",
rowStyle = list(cursor = "pointer"),
minRows = 10
)
Then, I put them together and saved the result - this worked fine:
final_file = htmltools::browsable(
htmltools::tagList(map, tbl)
)
htmltools::save_html(tagList(map, tbl), file = "sample.html")
However, here is the problem:
I noticed that when I click on only one of the rows, I notice that everything else still appears on the map. Shouldn't all the other points disappear when only one item is selected?
Could someone show me how to make this map/table look the same way it appears in the tutorial?
Thank you!
I have a shiny app that renders a DT table that has formatted numeric values. The table contains data that is both percentages and data that represents currency. The data is not tidy in that the table is effectively transposed with each row representing a feature and each column being an observation. Ultimately, my goal is to encode logic that anytime a cell has a negative value (the first character of the string is a '-'), the cell is colored red. Here is my reproducible example:
library(tidyverse)
library(DT)
example_df <- data.frame(
x = c("$1", "-2%", "$3"),
y = c("$10", "10%", "$20")
)
determine_cell_color <- function(x) {
if (str_sub(x, 1, 1) == "-") {
return("red")
}
else {
return("white")
}
}
# how to get an individual cell to be a different color
# if first character in string value is '-'
example_df %>%
datatable() %>%
formatStyle(target = 'row', backgroundColor = styleEqual(~determine_cell_color))
This approach can be generalized to many more columns. The main idea is to style one column with another column, the only downside is that it doubles the number of cols in the data frame. Fortunately we can hide those columns.
library(tidyverse)
library(DT)
example_df <- data.frame(
x = c("$1", "-2%", "$3"),
y = c("$10", "10%", "$20"),
z = c("$10", "-10%", "$20"),
w = c("-$10", "-10%", "$20")
)
pattern <- names(example_df) %>% str_c(collapse = "|")
determine_cell_color <- function(vector) {
str_detect(vector, "-") %>% as.numeric()
}
example_df <- example_df %>% mutate(across(matches(pattern), determine_cell_color, .names = "cell_color_{.col}"))
DT <- datatable(example_df, options = list(
columnDefs = list(list(targets = (ncol(example_df) / 2 + 1):ncol(example_df), visible = FALSE))
))
walk(str_subset(names(example_df), "^.$"), ~ {
DT <<- DT %>% formatStyle(
.x, str_c("cell_color_", .x),
backgroundColor = styleEqual(c(1, 0), c("red", "white"))
)
})
DT
Created on 2022-01-07 by the reprex package (v2.0.1)
I wish to plot hierarchical time series which are contained inside a list as per the code bellow:
libraries and data creation
title: "prueba shiny"
runtime: shiny
output: html_document
---
library(dplyr)
library(tidyr)
library(dygraphs)
library(tseries)
df <- data.frame(date = c(as.yearmon(2018,1),as.yearmon(2018,1),as.yearmon(2018,2),as.yearmon(2018,2),
as.yearmon(2018,1),as.yearmon(2018,1),as.yearmon(2018,2),as.yearmon(2018,2)), sales = c(1,2,3,4),
cat_I = c("drink","drink","food","food","drink","drink","food","food"),
cat_II = c("cola","fanta","tomatoes","bananas","cola","fanta","tomatoes","bananas"))
cat <- data.frame(I = c("drink","drink","food","food"),
II = c("cola","fanta","tomatoes","bananas"))
creaition of individual time series for each end product (ts):
ts <- list()
for(s in unique(cat$II)){
aux <- df %>% filter(cat_II==s) %>%
as.data.frame()
ts[[s]] <- ts(aux$sales,start=c(2018,1),frequency = 12)
}
creation of a hierarchical list for endpoint products (ts_I_II) and grouped by categories
aux <- with(cat,split(II,I))
ts_I_II <- lapply(aux, function(x) ts[x])
catI_sales <- list()
for (s in unique(cat$I)){
catI_sales[[s]] <- do.call(cbind,ts_I_II[[s]])
}
desired plots:
1 - first plot contains all time series inside a category
aux <- do.call(cbind,ts_I_II$drink)
dygraph(aux, main = "sales by cat_II") %>% dyOptions(colors = RColorBrewer::brewer.pal(5, "Set2"))
2 - second plot is the end product time series
dygraph(ts_I_II$drink$cola, main = "sales by cat_II") %>% dyOptions(colors = RColorBrewer::brewer.pal(5, "Set2"))
I wish to create both plots by selecting the categories from a selectInput. I tried something like this without success:
selectInput("I", label = "category_I:",
choices = unique(cat$I), selected = cat$I[1])
selectInput("II", label = "II", choices = unique(cat$II))
plotOutput(outputId = "dy")
data <- reactive({
ts_I_II$input$II})
output$dy <- renderPlot({
dygraph(data)
selectInput("II", label = "category_II:",
choices = names(ts))
dygraphs::renderDygraph({
dygraph(ts[[input$II]])
})
selectInput("I", label = "category_I:",
choices = names(catI_sales))
dygraphs::renderDygraph({
dygraph(catI_sales[[input$I]])
})
I'm trying to get two distributions in one graph with the googlevis function gvisAreaChart but it is not working as I want:
library(googleVis)
df <- data.frame(a=rnorm(n = 400,mean = .1,sd = .01),b=rnorm(n = 400,mean = .13,sd = .01))
dfplot <- rbind(data.frame(x=density(df$a)$x,y=density(df$a)$y,var=rep("a",512)),data.frame(x=density(df$b)$x,y=density(df$b)$y,var=rep("b",512)))
plot(gvisAreaChart(dfplot,xvar = 'x',yvar='y'))
I would like to give the two distributions different colors and also when they overlap. I know this is possible in ggplot but I'm looking for a solution with googleVis because it works better with Shiny.
Thanks.
EDIT: Found very cumbersome workaround:
dfplot <- data.table(x=seq(0,by = .001))
df <- data.table(a=rnorm(n = 400,mean = .1,sd = .01),b=rnorm(n = 400,mean = .13,sd = .01))
dfa <- data.table(x=round(density(df$a)$x,3),y1=density(df$a)$y,var=rep("a",512))
dfb <- data.table(x=round(density(df$b)$x,3),y2=density(df$b)$y,var=rep("b",512))
dfa[duplicated(x),test:=TRUE];dfa<-dfa[is.na(test)]
dfb[duplicated(x),test:=TRUE];dfb<-dfb[is.na(test)]
setkey(dfplot,x);setkey(dfa,x);setkey(dfb,x)
merge <- merge(dfplot,dfa,all.x=T,all.y=F,allow.cartesian=T)
merge <- merge(merge,dfb,all.x=T,all.y=F,allow.cartesian=T)
merge <- merge[,max:=pmax(y1,y2,na.rm=T)]
merge <- merge[!is.na(max)]
merge<-subset(merge,select = c('x','y1','y2'))
plot(gvisAreaChart(merge,xvar = 'x',yvar=c('y1','y2')))
unfortunately I am not that familiar with googleVis, but hopefully you can accept the solution with rCharts
rm(list = ls())
library(shiny)
library(rCharts)
df <- data.frame(a=rnorm(n = 400,mean = .1,sd = .01),b=rnorm(n = 400,mean = .13,sd = .01))
dfplot <- rbind(data.frame(x=density(df$a)$x,y=density(df$a)$y,var=rep("a",512)),data.frame(x=density(df$b)$x,y=density(df$b)$y,var=rep("b",512)))
hPlot(x = "x", y = "y", group = "var", data = dfplot, type = "area")