Related
I'm a bit stuck on this issue. I have this data obtained from a likert survey (so I make everything a factor):
df1<-data.frame(A=c(1,2,2,3,4,5,1,1,2,3),
B=c(4,4,2,3,4,2,1,5,2,2),
C=c(3,3,3,3,4,2,5,1,2,3),
D=c(1,2,5,5,5,4,5,5,2,3),
E=c(1,4,2,3,4,2,5,1,2,3),
dummy1=c("yes","yes","no","no","no","no","yes","no","yes","yes"),
dummy2=c("high","low","low","low","high","high","high","low","low","high"))
df1[colnames(df1)] <- lapply(df1[colnames(df1)], factor)
I then create a list of dataframes to be used in each plot:
vals <- colnames(df1)[1:5]
dummies <- colnames(df1)[-(1:5)]
step1 <- lapply(dummies, function(x) df1[, c(vals, x)])
step2 <- lapply(step1, function(x) split(x, x[, 6]))
names(step2) <- dummies
tbls <- unlist(step2, recursive=FALSE)
tbls<-lapply(tbls, function(x) x[(names(x) %in% names(df1[c(1:5)]))])
This is the plotting function I made (I used the likert package)
plot_likert <- function(x){
y<-deparse(substitute(x))
y<-sub("\\$", " - ",y)
p<-plot(likert(x),
type ="bar",center=3,
group.order=names(x))+
labs(x = "Theme", subtitle=paste("Number of observations:",nrow(x)))+
guides(fill=guide_legend("Rank"))+
ggtitle(paste("How do they rank? -",gsub("\\.",": ",y)))
png(filename=paste("Ranking -",y,".png"), width = 3000, height = 2000, res=300)
print(p)
dev.off()
}
So that now I can make the plot by writing:
plot_likert(tbls$dummy1.no)
Finally, I apply the function over the whole table by using
lapply(tbls,function(x) {
y<-deparse(substitute(x))
y<-sub("\\$", " - ",y)
plot(likert(x),
type ="bar",center=3,
group.order=names(x))+
labs(x = "Theme", subtitle=paste("Number of observations:",nrow(x)))+
guides(fill=guide_legend("Rank"))+
ggtitle(paste("How do these themes rank? -",gsub("\\.",": ",y)))
}) -> list_plots
But now I don't know how to save each graph in the list as a separate .png file! I managed to put everything in a pdf like this, but it's not what I actually want:
ggsave(
filename = "plots.pdf",
plot = marrangeGrob(list_plots, nrow=1, ncol=1),
width = 15, height = 9
)
Do you have any suggestions on how to fix this? Also, if you have anything to add about my function/procedure overall, everything is welcome! I'm still quite new to R.
Thanks in advance
we can use:
sapply(1:length(list_plots), function(i) ggsave(
filename = paste0("plots ",i,".pdf"),
plot = list_plots[[i]],
width = 15, height = 9
))
For names: see https://stackoverflow.com/a/73370416/5224236
mynames <- sapply(names(tbls), function(x) {
paste("How do they rank? -",gsub("\\.",": ",x))
})
myfilenames <- names(tbls)
plot_likert <- function(x, myname, myfilename){
p <- plot(likert(x),
type ="bar",center=3,
group.order=names(x))+
labs(x = "Theme", subtitle=paste("Number of observations:",nrow(x)))+
guides(fill=guide_legend("Rank"))+
ggtitle(myname)
p
}
list_plots <- lapply(1:length(tbls),function(i) {
plot_likert(tbls[[i]], mynames[i], myfilenames[i])
})
I have sample file with csv that describe some stock exchange indexes. I have already managed to:
Create for loop statement to tidy the data in a way that I have those data as DFs in a list.
In each index I calculated using loop OLSSlope, Log values, Percent Change, STDSlope etc.
Create XTS objects that are stored inside list.
I want to write such for loop/ lapply code that will take each xts object inside list, create plot using (dygraph) library and then save this graph in an output file. So that the goal is to have graph for each index that is inside this list of xts objects. I don't have problem with creating one graph for one object but to make it universal inside loop. Code for graph that I want is:
wig20tr_d_xts <- xts(x = wig20tr_d$Zamkniecie,
order.by = wig20tr_d$Date)
wig20tr_d_ols <- xts(x = wig20tr_d$OLSSlope,
order.by = wig20tr_d$Date)
wig20tr_d_stdup <- xts(x = wig20tr_d$OneSTDup,
order.by = wig20tr_d$Date)
wig20tr_d_stduptwo <- xts(x = wig20tr_d$TwoSTDup,
order.by = wig20tr_d$Date)
wig20tr_d_stddown <- xts(x = wig20tr_d$OneSTDdown,
order.by = wig20tr_d$Date)
wig20tr_d_stddowntwo <- xts(x = wig20tr_d$TwoSTDdown,
order.by = wig20tr_d$Date)
wig20 <- cbind(wig20tr_d_xts, wig20tr_d_ols, wig20tr_d_stdup, wig20tr_d_stduptwo, wig20tr_d_stddown, wig20tr_d_stddowntwo)
wig20_graph <- dygraph(wig20, main = "WIG 20 TR", ylab = "Total return in zł") %>%
dySeries("wig20tr_d_xts", color = "black") %>%
dySeries("wig20tr_d_ols", strokeWidth = 2, strokePattern = "dashed", color = "blue") %>%
dySeries("wig20tr_d_stdup", color = "green") %>%
dySeries("wig20tr_d_stduptwo", color = "green") %>%
dySeries("wig20tr_d_stddown", color = "red") %>%
dySeries("wig20tr_d_stddowntwo", color = "red") %>%
dyRangeSelector() %>%
dyUnzoom() %>%
dyOptions(axisLineColor = "navy",
gridLineColor = "lightblue") %>%
dyCrosshair(direction = "vertical")
wig20_graph
htmltools::save_html(wig20_graph, file = "C:/DATA_output/wig20_graph.html")
As you can see I use this addition to the graph:
dyCrosshair <- function(dygraph,
direction = c("both", "horizontal", "vertical")) {
dyPlugin(
dygraph = dygraph,
name = "Crosshair",
path = system.file("plugins/crosshair.js",
package = "dygraphs"),
options = list(direction = match.arg(direction))
)
}
Loop to create list of xts objects is like this:
for(i in 1:length(xts_list)){
df <- xts_list[i]
df <- as.data.frame(df)
colnames(df) <- c("Date", "Zamkniecie", "Trend", "OLSSlope", "LogClose", "LogCloseOLS", "LogCloseOLSSlope", "PercentChange", "LogChange", "OneSTDup", "OneSTDdown", "TwoSTDup", "TwoSTDdown")
time_series <- xts(x = df$Zamkniecie,
order.by = df$Date)
ols <- xts(x = df$OLSSlope,
order.by = df$Date)
stdup <- xts(x = df$OneSTDup,
order.by = df$Date)
stduptwo <- xts(x = df$TwoSTDup,
order.by = df$Date)
stddown <- xts(x = df$OneSTDdown,
order.by = df$Date)
stddowntwo <- xts(x = df$TwoSTDdown,
order.by = df$Date)
time_series_full <- cbind(time_series, ols, stdup, stduptwo, stddown, stddowntwo)
xts_list[[i]] <- time_series_full
print(i)
}
I have problem with adding part with graph inside this last for loop. So that the HTML graph would be named after the index. In this example the index is wig20tr_d
I wish to plot a time series with dygraph inside a markdown document. I can select the time series from a list and plot it with plot() function but it does not work on the same way with dygraph function
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"))
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)
}
selectInput("I", label = "category_I:",
choices = names(ts))
renderPlot({
plot(ts[[input$I]])
})
This works fine, but it doesn´t work when I try to plot with dygraph()
renderPlot({
dygraph(ts[[input$I]])
})
You should use dygraphs::renderDygraph instead of renderPlot
dygraphs::renderDygraph({
dygraph(ts[[input$I]])
})
I'd like to implement a cross-talk functionality between a table and plot in both directions:
select the row in the table which will be reflected in the plot
select a dot in the plot which will be reflected in the table. Same idea as here.
I've managed to implement a script, which works beautifully if I make scatter plot with ggplot() and table (both objects cross-talk!). However, when used EnhancedVolcano() and table I got the following error:
Error in EnhancedVolcano(toptable = data_shared, lab = "disp", x = "qsec", :
qsec is not numeric!
If I replace data_shared variable with df_orig, no error is raised, but there is no cross-talking between objects :(
Does this mean that SharedData$new() doesn't recognize numeric values as numeric? How to fix this error?
Any help is highly appreciated.
Thank you
Toy example:
library(plotly) # '4.9.1'
library(DT) # '0.11'
library(crosstalk) # ‘1.0.0’
library(EnhancedVolcano) # ‘1.4.0’
# Input
data1 = mtcars #dim(data1) # 32 11
data_shared = SharedData$new(data1) #, key = c("qsec", "hp"))
# df_orig = data_shared$origData()
# V-Plot
vp =EnhancedVolcano( toptable = data_shared,
lab = 'disp',
x = 'qsec',
y = 'hp',
xlab ='testX',
ylab = 'testY')
bscols(
ggplotly(vp + aes(x= qsec, y= -log10(hp/1000))),
datatable(data_shared, style="bootstrap", class="compact", width="100%",
options=list(deferRender=FALSE, dom='t')))
Same script, which works with ggplot():
data1 = mtcars #dim(data1) # 32 11
data_shared = SharedData$new(data1)
vp = ggplot(data = data_shared, mapping = aes(qsec, hp)) +
geom_point()
bscols(
ggplotly(vp) ,
datatable(data_shared, style="bootstrap", class="compact", width="100%",
options=list(deferRender=FALSE, dom='t')))
Note: Related (same) question was posted at BioStars, and the package author posted an answer, with author's permission copying an answer here:
Hi,
Thanks - that's very useful code and I may add it to the main package vignette, eventually.
I tried it here on my computer and I was able to get it working in my browser, but some components of the original plot seem to have been lost. I think that you just need to convert your column, 'qsec', to numerical values.
Re-using an example from my Vignette, here is a perfectly reproducible example:
library("pasilla")
pasCts <- system.file("extdata", "pasilla_gene_counts.tsv",
package="pasilla", mustWork=TRUE)
pasAnno <- system.file("extdata", "pasilla_sample_annotation.csv",
package="pasilla", mustWork=TRUE)
cts <- as.matrix(read.csv(pasCts,sep="\t",row.names="gene_id"))
coldata <- read.csv(pasAnno, row.names=1)
coldata <- coldata[,c("condition","type")]
rownames(coldata) <- sub("fb", "", rownames(coldata))
cts <- cts[, rownames(coldata)]
library("DESeq2")
dds <- DESeqDataSetFromMatrix(countData = cts,
colData = coldata,
design = ~ condition)
featureData <- data.frame(gene=rownames(cts))
mcols(dds) <- DataFrame(mcols(dds), featureData)
dds <- DESeq(dds)
res <- results(dds)
library(EnhancedVolcano)
p1 <- EnhancedVolcano(res,
lab = rownames(res),
x = "log2FoldChange",
y = "pvalue",
pCutoff = 10e-4,
FCcutoff = 2,
xlim = c(-5.5, 5.5),
ylim = c(0, -log10(10e-12)),
pointSize = c(ifelse(res$log2FoldChange>2, 8, 1)),
labSize = 4.0,
shape = c(6, 6, 19, 16),
title = "DESeq2 results",
subtitle = "Differential expression",
caption = "FC cutoff, 1.333; p-value cutoff, 10e-4",
legendPosition = "right",
legendLabSize = 14,
col = c("grey30", "forestgreen", "royalblue", "red2"),
colAlpha = 0.9,
drawConnectors = TRUE,
hline = c(10e-8),
widthConnectors = 0.5)
p1 <- p1 +
ggplot2::coord_cartesian(xlim=c(-6, 6)) +
ggplot2::scale_x_continuous(
breaks=seq(-6,6, 1))
library(plotly)
library(DT)
library(crosstalk)
bscols(
ggplotly(p1 + aes(x= log2FoldChange, y= -log10(pvalue))),
datatable(
data.frame(res),
style="bootstrap",
class="compact", width="100%",
options=list(deferRender=FALSE, dom='t')))
Unfortunately, plotly and/or bscols don't like the use of bquote(), so, one cannot have the fancy axes names that I use in EnhancedVolcano:
... + xlab(bquote(~Log[2] ~ "fold change")) + ylab(bquote(~-Log[10] ~ italic(P)))
When i try to add these, it throws an error.
Kevin
tried to modify few things in volcano function, got following error:
Error in as.data.frame.default(toptable) :
cannot coerce class ‘c("SharedData", "R6")’ to a data.frame
not sure yet, how to fix it.
I have two data frame as below:
PickUP <- data.frame(pickuplong = c(-73.93909 ,-73.94189 ,-73.93754,-73.91638,-73.92792 ,-73.88634), pickuplat =c(40.84408,40.83841,40.85311,40.84966,40.86284,40.85628))
Dropoff <- data.frame(pickuplong = c(-73.93351 ,-73.93909 ,-73.93909 ,-73.80747,-73.95722,-73.91880), pickuplat =c(40.76621,40.84408,40.85311,40.69951,40.68877,40.75917), Droplong =c(-73.91300,-73.96259 ,-73.94870,-73.93860,-73.93633, -73.90690), Droplat =c(40.77777,40.77488 ,40.78493,40.84463,40.75977,40.77013))
I try to find the pickup coordinations (longtitude and latitude) in the pickup data frame which are repeated in dropoff dataframe. I have the below code but I got the error on this:
library(sp)
library(rgdal)
library(leaflet)
library(mapview)
library(dplyr)
a <- semi_join(Dropoff , PickUP , by = c("pickuplong","pickuplat"))
a$ID <- 1:nrow(a)
Dropoff_p <- a[, c("ID", "Pickup_longitude", "Pickup_latitude")]
Dropoff_d <- a[, c("ID", "Dropoff_longitude", "Dropoff_latitude")]
coordinates(Dropoff_p) <- ~Pickup_longitude + Pickup_latitude
coordinates(Dropoff_d) <- ~Dropoff_longitude + Dropoff_latitude
proj4string(Dropoff_p) <- CRS("+init=epsg:4326")
proj4string(Dropoff_d) <- CRS("+init=epsg:4326")
map_p <- mapview(Dropoff_p, color = "red")
map_d <- mapview(Dropoff_d, color = "blue")
map_p + map_d
My error is:
Error in $<-.data.frame (tmp, "ID", value = c(1L, 0L)) :
replacement has 2 rows, data has 0 Error during wrapup: cannot open the
connection
When subsetting the data frame, you have to use the same column names. I changed the column name in the Dropoff_p, Dropoff_d, coordinates(Dropoff_p), and proj4string(Dropoff_d), and then your script works.
In addition, the mapview package just has a new update. If you want, you can update your mapview to version 2.0.1. You can also add col.regions = "red" and col.regions = "blue" because it seems like under the new version the color argument will only change the outline of a point. To change the fill color, use col.regions.
library(sp)
library(rgdal)
library(leaflet)
library(mapview)
library(dplyr)
a <- semi_join(Dropoff , PickUP , by = c("pickuplong","pickuplat"))
a$ID <- 1:nrow(a)
Dropoff_p <- a[, c("ID", "pickuplong", "pickuplat")]
Dropoff_d <- a[, c("ID", "Droplong", "Droplat")]
coordinates(Dropoff_p) <- ~pickuplong + pickuplat
coordinates(Dropoff_d) <- ~Droplong + Droplat
proj4string(Dropoff_p) <- CRS("+init=epsg:4326")
proj4string(Dropoff_d) <- CRS("+init=epsg:4326")
map_p <- mapview(Dropoff_p, color = "red", col.regions = "red")
map_d <- mapview(Dropoff_d, color = "blue", col.regions = "blue")
map_p + map_d