Related
In the code below, I generate some random data. I want to pass it to a function to plot but want to be able to control the looks through parameters. For e.g. I want to control the line colors, but mschart outputs red and blue lines. This is not what I want. I want it programmatically set like the rest of the chart (title , x axis etc).
#### GENERATE RAW AND RANDOM DATA
DT<-data.table(x=1:10,y=1:10, group=c(1))
DT<-rbind(DT,data.table(x=1:10,y=(1:10)**2, group=c(2)))
generate_chart <-
function(DT,x, y, group_by_col, xlab, ylab, title, num_format,color_list)
{
rr_chart <-
ms_linechart(DT,
x = x,
y = y,
group = group_by_col)
groups<-unique(DT[,get(group_by_col),] )
#TRY TO GENERATE LIST FOR COLORS from what is input
l<-list()
for(i in 1:length(groups)){
l[[groups[i]]]<-color_list[i]
}
# Standatd code where the list above is used to color the data
rr_chart <-
chart_ax_x(
rr_chart,
minor_tick_mark = 'none',
major_tick_mark = 'none'
) %>% chart_labels(title = title,
xlab = xlab,
ylab = ylab) %>% chart_ax_y(num_fmt = num_format) %>% chart_data_stroke(
l
)
rr_chart <- set_theme(rr_chart, crm_chart_theme)
}
# call function
x<-generate_chart(DT,x="x", y="y", group_by_col="group", xlab="xxxx", ylab="yyyy", title="Title", num_format="#0.0",color_list=c('red','black'))
#Add to slide
# blank because of missing template
The elements of your color list l need proper names. They must be the names attributed to the two lines (1 and 2 in your example). Adding names(l) <- 1:2 to your code now the line colors can be programmatically set.
library(mschart)
library(data.table)
library(dplyr)
generate_chart <- function(DT, x, y, group_by_col, xlab, ylab, title,
num_format, color_list) {
rr_chart <- ms_linechart(DT, x=x, y=y, group=group_by_col)
groups <- unique(DT[,get(group_by_col),] )
l <- list()
for (i in 1:length(groups)) {
l[[groups[i]]] <- color_list[i]
}
# Set Names for elements of the color list
names(l) <- 1:2
###
rr_chart <-
chart_ax_x(rr_chart, minor_tick_mark = 'none', major_tick_mark = 'none') %>%
chart_labels(title = title, xlab = xlab, ylab = ylab) %>%
chart_ax_y(num_fmt = num_format) %>%
chart_data_stroke( values=l )
rr_chart <- set_theme(rr_chart, crm_chart_theme)
}
DT <- data.table(x=1:10, y=1:10, group=c(1))
DT <- rbind(DT,data.table(x=1:10, y=(1:10)**2, group=c(2)))
x <- generate_chart(DT, x="x", y="y", group_by_col="group",
xlab="xxxx", ylab="yyyy", title="Title",
num_format="#0.0", color_list=c('red','black'))
print(x, preview=T)
I get 0 values on the y Axis while plotting a discreteBarChart inside renderChart(), However, the highest value of yAxis appears (not 0) but also with some wierd format and commmas (see 2nd screenshot down named Chart Plot)
I want to plot 2 columns in rCharts, the x Axis is a character (countryname) and the yAxis is numeric (Collective_Turnover)
I created this variable (Collective_Turnover) from the data, it is the sum of the Net_Turnover
I tried to put as.numeric() before it, but still, getting 0 on the yAxis
data$countryname= as.character(data$countryname)
output$top10countries <-renderChart({
topcountries <-
arrange(data%>%
group_by(as.character(countryname)) %>%
summarise(
Collective_Turnover= sum(as.numeric(`Net turnover`))
), desc(Collective_Turnover))
colnames(topcountries )[colnames(topcountries )=="as.character(countryname)"] <- "Country"
topcountries <- subset(topcountries [1:10,], select = c(Country, Collective_Turnover))
p <- nPlot(Collective_Turnover~Country, data = topcountries , type = "discreteBarChart", dom = "top10countries")
p$params$width <- 1000
p$params$height <- 200
p$xAxis(staggerLabels = TRUE)
# p$yAxis(axisLabel = "CollectiveTO", width = 50)
return(p)
})
The output of topcountries in R is a table like this:
that is arranged in descending order...
and the plot that i get is this:
The ticks labels are truncated because they are too long. You need to set the left margin and a padding. To get rid of the commas, use a number formatter.
dat <- data.frame(
Country = c("Russian", "Italy", "Spain"),
x = c(12748613.6, 5432101.2, 205789.7)
)
p <- nPlot(x ~ Country, data = dat, type = "discreteBarChart")
p$yAxis(tickPadding = 15, tickFormat = "#! function(d) {return d3.format('.1')(d)} !#")
p$chart(margin = list(left = 100))
p
I was wondering if anyone knows of a package that allows partial row labeling of heatmaps. I am currently using pheatmap() to construct my heatmaps, but I can use any package that has this functionality.
I have plots with many rows of differentially expressed genes and I would like to label a subset of them. There are two main things to consider (that I can think of):
The placement of the text annotation depends on the height of the row. If the rows are too narrow, then the text label will be ambiguous without some sort of pointer.
If multiple adjacent rows are significant (i.e. will be labelled), then these will need to be offset, and again, a pointer will be needed.
Below is an example of a partial solution that really only gets maybe halfway there, but I hope illustrates what I'd like to be able to do.
set.seed(1)
require(pheatmap)
require(RColorBrewer)
require(grid)
### Data to plot
data_mat <- matrix(sample(1:10000, 300), nrow = 50, ncol = 6)
rownames(data_mat) <- paste0("Gene", 1:50)
colnames(data_mat) <- c(paste0("A", 1:3), paste0("B", 1:3))
### Set how many genes to annotate
### TRUE - make enough labels that some overlap
### FALSE - no overlap
tooMany <- T
### Select a few genes to annotate
if (tooMany) {
sigGenes_v <- paste0("Gene", c(5,20,26,42,47,16,28))
newMain_v <- "Too Many Labels"
} else {
sigGenes_v <- paste0("Gene", c(5,20,26,42))
newMain_v <- "OK Labels"
}
### Make color list
colors_v <- brewer.pal(8, "Dark2")
colors_v <- colors_v[c(1:length(sigGenes_v), 8)]
names(colors_v) <- c(sigGenes_v, "No")
annColors_lsv <- list("Sig" = colors_v)
### Column Metadata
colMeta_df <- data.frame(Treatment = c(rep("A", 3), rep("B", 3)),
Replicate = c(rep(1:3, 2)),
stringsAsFactors = F,
row.names = colnames(data_mat))
### Row metadata
rowMeta_df <- data.frame(Sig = rep("No", 50),
stringsAsFactors = F,
row.names = rownames(data_mat))
for (gene_v in sigGenes_v) rowMeta_df[rownames(rowMeta_df) == gene_v, "Sig"] <- gene_v
### Heatmap
heat <- pheatmap(data_mat,
annotation_row = rowMeta_df,
annotation_col = colMeta_df,
annotation_colors = annColors_lsv,
cellwidth = 10,
main = "Original Heat")
### Get order of genes after clustering
genesInHeatOrder_v <- heat$tree_row$labels[heat$tree_row$order]
whichSigInHeatOrder_v <- which(genesInHeatOrder_v %in% sigGenes_v)
whichSigInHeatOrderLabels_v <- genesInHeatOrder_v[whichSigInHeatOrder_v]
sigY <- 1 - (0.02 * whichSigInHeatOrder_v)
### Change title
whichMainGrob_v <- which(heat$gtable$layout$name == "main")
heat$gtable$grobs[[whichMainGrob_v]] <- textGrob(label = newMain_v,
gp = gpar(fontsize = 16))
### Remove rows
whichRowGrob_v <- which(heat$gtable$layout$name == "row_names")
heat$gtable$grobs[[whichRowGrob_v]] <- textGrob(label = whichSigInHeatOrderLabels_v,
y = sigY,
vjust = 1)
grid.newpage()
grid.draw(heat)
Here are a few outputs:
original heatmap:
ok labels:
ok labels, with flags:
too many labels
too many labels, with flags
The "with flags" outputs are the desired final results.
I just saved these as images from the Rstudio plot viewer. I recognize that I could save them as pdfs and provide a larger file size to get rid of the label overlap, but then the individual cells would be larger than I want.
Based on your code, you seem fairly comfortable with gtables & grobs. A (relatively) straightforward way to achieve the look you want is to zoom in on the row label grob, & make some changes there:
replace unwanted labels with "";
evenly spread out labels within the available space;
add line segments joining the old and new label positions.
I wrote a wrapper function for this, which works as follows:
# heat refers to the original heatmap produced from the pheatmap() function
# kept.labels should be a vector of labels you wish to show
# repel.degree is a number in the range [0, 1], controlling how much the
# labels are spread out from one another
add.flag(heat,
kept.labels = sigGenes_v,
repel.degree = 0)
add.flag(heat,
kept.labels = sigGenes_v,
repel.degree = 0.5)
add.flag(heat,
kept.labels = sigGenes_v,
repel.degree = 1)
Function (explanations in annotations):
add.flag <- function(pheatmap,
kept.labels,
repel.degree) {
# repel.degree = number within [0, 1], which controls how much
# space to allocate for repelling labels.
## repel.degree = 0: spread out labels over existing range of kept labels
## repel.degree = 1: spread out labels over the full y-axis
heatmap <- pheatmap$gtable
new.label <- heatmap$grobs[[which(heatmap$layout$name == "row_names")]]
# keep only labels in kept.labels, replace the rest with ""
new.label$label <- ifelse(new.label$label %in% kept.labels,
new.label$label, "")
# calculate evenly spaced out y-axis positions
repelled.y <- function(d, d.select, k = repel.degree){
# d = vector of distances for labels
# d.select = vector of T/F for which labels are significant
# recursive function to get current label positions
# (note the unit is "npc" for all components of each distance)
strip.npc <- function(dd){
if(!"unit.arithmetic" %in% class(dd)) {
return(as.numeric(dd))
}
d1 <- strip.npc(dd$arg1)
d2 <- strip.npc(dd$arg2)
fn <- dd$fname
return(lazyeval::lazy_eval(paste(d1, fn, d2)))
}
full.range <- sapply(seq_along(d), function(i) strip.npc(d[i]))
selected.range <- sapply(seq_along(d[d.select]), function(i) strip.npc(d[d.select][i]))
return(unit(seq(from = max(selected.range) + k*(max(full.range) - max(selected.range)),
to = min(selected.range) - k*(min(selected.range) - min(full.range)),
length.out = sum(d.select)),
"npc"))
}
new.y.positions <- repelled.y(new.label$y,
d.select = new.label$label != "")
new.flag <- segmentsGrob(x0 = new.label$x,
x1 = new.label$x + unit(0.15, "npc"),
y0 = new.label$y[new.label$label != ""],
y1 = new.y.positions)
# shift position for selected labels
new.label$x <- new.label$x + unit(0.2, "npc")
new.label$y[new.label$label != ""] <- new.y.positions
# add flag to heatmap
heatmap <- gtable::gtable_add_grob(x = heatmap,
grobs = new.flag,
t = 4,
l = 4
)
# replace label positions in heatmap
heatmap$grobs[[which(heatmap$layout$name == "row_names")]] <- new.label
# plot result
grid.newpage()
grid.draw(heatmap)
# return a copy of the heatmap invisibly
invisible(heatmap)
}
In the following shiny app, the plotly package is used to create an interactive correlation heat map. When individual tiles are clicked, the corresponding scatter plot appears. One can then download the individual scatters by clicking download plot as png. But is there a way to download all the possible scatter plots at once without having to click each individual tile and save each individual one? Thank you
library(plotly)
library(shiny)
# compute a correlation matrix
correlation <- round(cor(mtcars), 3)
nms <- names(mtcars)
ui <- fluidPage(
mainPanel(
plotlyOutput("heat"),
plotlyOutput("scatterplot")
),
verbatimTextOutput("selection")
)
server <- function(input, output, session) {
output$heat <- renderPlotly({
plot_ly(x = nms, y = nms, z = correlation,
key = correlation, type = "heatmap", source = "heatplot") %>%
layout(xaxis = list(title = ""),
yaxis = list(title = ""))
})
output$selection <- renderPrint({
s <- event_data("plotly_click")
if (length(s) == 0) {
"Click on a cell in the heatmap to display a scatterplot"
} else {
cat("You selected: \n\n")
as.list(s)
}
})
output$scatterplot <- renderPlotly({
s <- event_data("plotly_click", source = "heatplot")
if (length(s)) {
vars <- c(s[["x"]], s[["y"]])
d <- setNames(mtcars[vars], c("x", "y"))
yhat <- fitted(lm(y ~ x, data = d))
plot_ly(d, x = ~x) %>%
add_markers(y = ~y) %>%
add_lines(y = ~yhat) %>%
layout(xaxis = list(title = s[["x"]]),
yaxis = list(title = s[["y"]]),
showlegend = FALSE)
} else {
plotly_empty()
}
})
}
shinyApp(ui, server)
You can use webshot to capture a static image of Plotly's HTML output using the instructions here: https://plot.ly/r/static-image-export/
An example for loop below generates random scatter plots from mtcars.
library(plotly)
library(webshot)
## You'll need to run the function the first time if you dont't have phantomjs installed
#webshot::install_phantomjs()
ColumnOptions <- colnames(mtcars)
for (i in seq_len(5)){
xCol <- sample(ColumnOptions,1)
yCol <- sample(ColumnOptions,1)
ThisFileName <- paste0("Scatter_",xCol,"_vs_",yCol,".png")
plot_ly(x = mtcars[[xCol]], y = mtcars[[yCol]], type = "scatter", mode = "markers") %>%
export(., file = ThisFileName)
}
However, if you're going to be potentially doing this dozens of times, the amount of computation required to go through the following steps really adds up.
Generate a JSON plotly object from R
Use htmlwidgets/htmltoolsto generate a self-contained HTML web page
Render that HTML as a browser would see it with an external program --webshot
Use webshot to render an image of that HTML and save it as a PNG
This isn't really a reflection of plotly being slow, but to make an analogy it's kind've like using an airplane to travel half a mile -- the plane gets you there, but if you need to make that trip more than a few times you should probably consider a car.
The plotly loop above takes 27 seconds to render 5 PNG images, but the alternative method below using ggplot2 takes 1.2 seconds.
library(ggplot2)
ColumnOptions <- colnames(mtcars)
for (i in seq_len(5)){
xCol <- sample(ColumnOptions,1)
yCol <- sample(ColumnOptions,1)
ThisFileName <- paste0("ggplot2_Scatter_",xCol,"_vs_",yCol,".png")
ggplot() +
geom_point(aes(x = mtcars[[xCol]], y = mtcars[[yCol]])) +
labs(x = xCol, y = yCol) -> ThisPlot
ggsave(plot = ThisPlot, filename = ThisFileName)
}
I am trying to create a Shiny app to explore a data frame with 4 variables/columns (A, B, C, D) and 10,000 rows. There is an input field where users must select 2 of the 4 variables/columns. Once they have done so, then a scatterplot is shown on the right. The scatterplot is a Plotly object with hexagon binning summarizing the values of the 10,000 rows between the two user-selected variables/columns.
At this point, the user can select a "Go!" button, which causes an orange dot corresponding to the first row of those 2 variables/columns to be superimposed onto the Plotly object. The user can sequentially select "Go!" and then the orange dot corresponding to the second, third, fourth, etc. row will be superimposed onto the Plotly object. The name of the row ID is output above the scatterplot matrix.
For the most part, the app is working. There are only 2 things I am trying to improve upon:
1) I would like the user to be able to select new pairs in the input field. This works for the most part. However, there is one specific situation where this will cause the app to close suddenly. It happens after an orange point has been overlaid onto the scatterplot. If the user then erases the two input pairs, the app suddenly closes. I would like the user to be able to erase both input pair values and input two new pair values without the app closing even after orange points have been plotted to the scatterplot.
2) I notice that the output of the row ID lags somewhat after the orange dot is plotted. I wonder why this happens since I output the row ID before plotting the orange dot in the script. I would prefer for there to be less of a lag, but am uncertain how to approach that.
Any suggestions on how to solve either of these two issues would be greatly appreciated! My MWE showing this issue is below.
library(plotly)
library(GGally)
library(hexbin)
library(htmlwidgets)
library(tidyr)
library(shiny)
library(dplyr)
library(data.table)
library(ggplot2)
library(tibble)
myPairs <- c("A", "B", "C", "D")
ui <- shinyUI(fluidPage(
titlePanel("title panel"),
sidebarLayout(position = "left",
sidebarPanel(
selectizeInput("selPair", "Pairs:", choices = myPairs, multiple = TRUE, options = list(maxItems = 2)),
actionButton("goButton", "Go!"),
width = 3
),
mainPanel(
verbatimTextOutput("info"),
plotlyOutput("scatMatPlot")
)
)
))
server <- shinyServer(function(input, output, session) {
# Create data and subsets of data based on user selection of pairs
dat <- data.frame(ID = paste0("ID", 1:10000), A = rnorm(10000), B = rnorm(10000), C = rnorm(10000), D = rnorm(10000))
pairNum <- reactive(input$selPair)
group1 <- reactive(pairNum()[1])
group2 <- reactive(pairNum()[2])
sampleIndex <- reactive(which(colnames(dat) %in% c(group1(), group2())))
# Create data subset based on two letters user chooses
datSel <- eventReactive(sampleIndex(), {
datSel <- dat[, c(1, sampleIndex())]
datSel$ID <- as.character(datSel$ID)
datSel <- as.data.frame(datSel)
datSel
})
sampleIndex1 <- reactive(which(colnames(datSel()) %in% c(group1())))
sampleIndex2 <- reactive(which(colnames(datSel()) %in% c(group2())))
# Create background Plotly graph with hex binning all 100 rows of the two user-selected columns
ggPS <- eventReactive(datSel(), {
minVal = min(datSel()[,-1])
maxVal = max(datSel()[,-1])
maxRange = c(minVal, maxVal)
xbins=7
buffer = (maxRange[2]-maxRange[1])/xbins/2
x = unlist(datSel()[,(sampleIndex1())])
y = unlist(datSel()[,(sampleIndex2())])
h <- hexbin(x=x, y=y, xbins=xbins, shape=1, IDs=TRUE, xbnds=maxRange, ybnds=maxRange)
hexdf <- data.frame (hcell2xy (h), hexID = h#cell, counts = h#count)
attr(hexdf, "cID") <- h#cID
p <- ggplot(hexdf, aes(x=x, y=y, fill = counts, hexID=hexID)) + geom_hex(stat="identity") + geom_abline(intercept = 0, color = "red", size = 0.25) + coord_cartesian(xlim = c(maxRange[1]-1*buffer, maxRange[2]+buffer), ylim = c(maxRange[1]-1*buffer, maxRange[2]+buffer)) + coord_equal(ratio=1) + labs(x = colnames(datSel()[sampleIndex1()]), y = colnames(datSel()[sampleIndex2()]))
ggPS <- ggplotly(p)
ggPS})
# Output hex bin plot created just above
output$scatMatPlot <- renderPlotly({
# Each time user pushes Go! button, the next row of the data frame is selected
datInput <- eventReactive(input$goButton, {
g <- datSel()$ID[input$goButton]
# Output ID of selected row
output$info <- renderPrint({
g
})
# Get x and y values of seleced row
currGene <- datSel()[which(datSel()$ID==g),]
currGene1 <- unname(unlist(currGene[,sampleIndex1()]))
currGene2 <- unname(unlist(currGene[,sampleIndex2()]))
c(currGene1, currGene2)
})
# Send x and y values of selected row into onRender() function
observe({
session$sendCustomMessage(type = "points", datInput())
})
# Use onRender() function to draw x and y values of seleced row as orange point
ggPS() %>% onRender("
function(el, x, data) {
noPoint = x.data.length;
Shiny.addCustomMessageHandler('points', function(drawPoints) {
if (x.data.length > noPoint){
Plotly.deleteTraces(el.id, x.data.length-1);
}
var Traces = [];
var trace = {
x: drawPoints.slice(0, drawPoints.length/2),
y: drawPoints.slice(drawPoints.length/2, drawPoints.length),
mode: 'markers',
marker: {
color: 'orange',
size: 7
},
hoverinfo: 'none'
};
Traces.push(trace);
Plotly.addTraces(el.id, Traces);
});}")
})
})
shinyApp(ui, server)
As #HubertL mentioned, it's better to avoid nesting reactive functions. Your app will probably run more smoothely if you change that.
About your first problem, req and validate are probably the best way to go. These functions check if the user inputs are valid and deal with the invalid ones.
I've adjusted your code a bit following these sugetions, but you still can change it more. If you take a closer look to ggPS you may notice that it only uses datSel() so you could turn it into a function.
library(plotly)
library(GGally)
library(hexbin)
library(htmlwidgets)
library(tidyr)
library(shiny)
library(dplyr)
library(data.table)
library(ggplot2)
library(tibble)
myPairs <- c("A", "B", "C", "D")
ui <- shinyUI(fluidPage(
titlePanel("title panel"),
sidebarLayout(
position = "left",
sidebarPanel(
selectizeInput("selPair", "Pairs:", choices = myPairs, multiple = TRUE,
options = list(maxItems = 2)),
actionButton("goButton", "Go!"),
width = 3
),
mainPanel(
verbatimTextOutput("info"),
plotlyOutput("scatMatPlot")
)
)
))
server <- shinyServer(function(input, output, session) {
# Create data and subsets of data based on user selection of pairs
dat <- data.frame(
ID = paste0("ID", 1:10000), A = rnorm(10000),
B = rnorm(10000), C = rnorm(10000), D = rnorm(10000),
stringsAsFactors = FALSE
)
# Create data subset based on two letters user chooses
datSel <- eventReactive(input$selPair, {
validate(need(length(input$selPair) == 2, "Select a pair."))
dat[c("ID", input$selPair)]
}, ignoreNULL = FALSE)
# Create background Plotly graph with hex binning all 100 rows of the two user-selected columns
ggPS <- eventReactive(datSel(), {
minVal = min(datSel()[,-1])
maxVal = max(datSel()[,-1])
maxRange = c(minVal, maxVal)
xbins=7
buffer = (maxRange[2]-maxRange[1])/xbins/2
x = unlist(datSel()[input$selPair[1]])
y = unlist(datSel()[input$selPair[2]])
h <- hexbin(x=x, y=y, xbins=xbins, shape=1, IDs=TRUE,
xbnds=maxRange, ybnds=maxRange)
hexdf <- data.frame (hcell2xy (h), hexID = h#cell, counts = h#count)
attr(hexdf, "cID") <- h#cID
p <- ggplot(hexdf, aes(x=x, y=y, fill = counts, hexID=hexID)) +
geom_hex(stat="identity") + geom_abline(intercept = 0, color = "red", size = 0.25) +
coord_cartesian(xlim = c(maxRange[1]-1*buffer, maxRange[2]+buffer),
ylim = c(maxRange[1]-1*buffer, maxRange[2]+buffer)) +
coord_equal(ratio = 1) +
labs(x = input$selPair[1], y = input$selPair[2])
ggPS <- ggplotly(p)
ggPS
})
# Output ID of selected row
output$info <- renderPrint({ datSel()$ID[req(input$goButton)] })
# Output hex bin plot created just above
output$scatMatPlot <- renderPlotly({
# Use onRender() function to draw x and y values of seleced row as orange point
ggPS() %>% onRender("
function(el, x, data) {
noPoint = x.data.length;
Shiny.addCustomMessageHandler('points', function(drawPoints) {
if (x.data.length > noPoint){
Plotly.deleteTraces(el.id, x.data.length-1);
}
var Traces = [];
var trace = {
x: drawPoints.slice(0, drawPoints.length/2),
y: drawPoints.slice(drawPoints.length/2, drawPoints.length),
mode: 'markers',
marker: {
color: 'orange',
size: 7
},
hoverinfo: 'none'
};
Traces.push(trace);
Plotly.addTraces(el.id, Traces);
});}")
})
observe({
# Get x and y values of seleced row
currGene <- datSel()[input$goButton, -1]
# Send x and y values of selected row into onRender() function
session$sendCustomMessage(type = "points", unname(unlist(currGene)))
})
})
shinyApp(ui, server)