I made time series graph with dygraph package:
library(forecast)
library(dygraphs)
hw <- HoltWinters(ldeaths)
p <- predict(hw, n.ahead = 36, prediction.interval = TRUE)
all <- cbind(ldeaths, p)
f <- forecast(unemp.mod)
dygraph(all, "Deaths from Lung Disease (UK)") %>%
dySeries("ldeaths", label = "Actual") %>%
dySeries(c("p.lwr", "p.fit", "p.upr"), label = "Predicted")
Now I try to add confidence intervals to predictions:
gen_array <- function(forecast_obj){
actuals <- forecast_obj$x
lower <- forecast_obj$lower[,2]
upper <- forecast_obj$upper[,2]
point_forecast <- forecast_obj$mean
cbind(actuals, lower, upper, point_forecast)
}
dygraph(all, main = "graph_title") %>%
dyRangeSelector() %>%
dyRangeSelector(height = 40,
dateWindow = c("2011-04-01", "2019-4-01")) %>%
dySeries(name = "actuals", label = "actual") %>%
dySeries(c("lower","point_forecast","upper"), label = "Predicted") %>%
dyLegend(show = "always", hideOnMouseOut = FALSE) %>%
dyHighlight(highlightCircleSize = 5,
highlightSeriesOpts = list(strokeWidth = 2)) %>%
dyOptions(axisLineColor = "navy", gridLineColor = "grey")
But I get errors:
Error in dySeries(., name = "actuals", label = "actual") :
One or more of the specified series were not found. Valid series names are: ldeaths, p.fit, p.upr, p.lwr
How I can fix it?
Related
I made time series graph with dygraph package:
library(forecast)
library(dygraphs)
hw <- HoltWinters(ldeaths)
p <- predict(hw, n.ahead = 36, prediction.interval = TRUE)
all <- cbind(ldeaths, p)
f <- forecast(unemp.mod)
dygraph(all, "Deaths from Lung Disease (UK)") %>%
dySeries("ldeaths", label = "Actual") %>%
dySeries(c("p.lwr", "p.fit", "p.upr"), label = "Predicted")
And now I modify with new time series model:
p = ldeaths %>%
auto.arima() %>%
forecast(h=20)
low = data.frame(p$lower)
up = data.frame(p$upper)
m = data.frame(p$mean)
comb = cbind(low, up, m)
comb = comb[, -c(1,3)]
colnames(comb)[1] <- 'p.lwr'
colnames(comb)[2] <- 'p.upr'
colnames(comb)[3] <- 'p.fit'
dygraph(comb, "Deaths from Lung Disease (UK)") %>%
dySeries("ldeaths", label = "Actual") %>%
dySeries(c("p.lwr", "p.fit", "p.upr"), label = "Predicted")
I get error:
Error in dySeries(., "ldeaths", label = "Actual") :
One or more of the specified series were not found. Valid series names are: p.upr, p.fit
How I can fix this please? I want actual, predicted and confidence interval please.
I have created a dendrogram with heatmaply with a dendrogram object from the dendextend package. I was wondering if there is a way to change the order of the columns: vs, am, carb, wt, drat, gear, etc. For example, I want to sort them alphabetically. Is this possible?
library(heatmaply)
library(tidyverse)
library(RColorBrewer)
library(dendextend)
custom_colors <- c("#B6E2D3", "#887BB0", "#FFD53D", "#EF7C8E", "#A1F7A1", "#EFE7BC", "#C26DBC", "#14C2DD",
"#5CD85A", "#AB6B51", "#39918C", "#FFA384", "#57DDF3", "#D0B49F", "#EEB5EB", "#74BDCB")
dend_example <- mtcars %>% dist %>% hclust(method = "ward.D2") %>%
as.dendrogram %>% color_branches(k=5) %>% color_labels
heatmaply_mtcars<- heatmaply(mtcars, hclustfun = hclust, hclust_method = "ward.D2",
Rowv = dend_example,
main = "mtcars",
show_dendrogram = c(TRUE, FALSE),
showticklabels = c(TRUE, TRUE),
scale_fill_gradient_fun = ggplot2::scale_fill_gradient2(high = "#025492"),
file = "heatmaply_mtcars.html",
column_text_angle = 30,
colorbar_thickness = 50)
I included a column dendrogram within heatmaply with the colv argument. The column dendrogram was rotated with the rotate function from the package dendextend:
dend_example <- mtcars %>% dist %>% hclust(method = "ward.D2") %>%
as.dendrogram %>% color_branches(k=5) %>% color_labels
column_dend <- t(mtcars) %>% dist %>% hclust(method = "ward.D2") %>%
as.dendrogram
column_dend <- column_dend %>% rotate(c(vector_with_labels))
heatmaply_mtcars<- heatmaply(mtcars, hclustfun = hclust, hclust_method = "ward.D2",
Rowv = dend_example,
Colv = column_dend,
main = "mtcars",
show_dendrogram = c(TRUE, FALSE),
showticklabels = c(TRUE, TRUE),
scale_fill_gradient_fun = ggplot2::scale_fill_gradient2(high = "#025492"),
file = "heatmaply_mtcars.html",
column_text_angle = 30,
colorbar_thickness = 50)
I probably have very complex question related to leaflet, I am trying to plot multile countries of Europe (data downloaded from GADM), and then create a network matrix for countries, however france contain island and for some reasons computation of weight matrix work, however when creating a dataframe of it, it cannon be created (when france is dropped data6 it works)
Is there a way how to delete that island from France data, or are there pager pages where can one get and easily plot countries like in my example?
also when france is dropped and map is created in leaflet there is a weird horizontal line, can it be somehow erased?
example down here (seem very long, but that is because of many country geodata)
library(leaflet)
library(ggplot2)
library(sf)
library(spdep)
library(leaflet.minicharts)
library(leafletCN)
# Regions of each country selected
URL <- "https://biogeo.ucdavis.edu/data/gadm3.6/Rsp/gadm36_DEU_1_sp.rds"
data <- readRDS(url(URL))
URL2 <- "https://biogeo.ucdavis.edu/data/gadm3.6/Rsp/gadm36_CZE_1_sp.rds"
data2 <- readRDS(url(URL2))
URL3 <- "https://biogeo.ucdavis.edu/data/gadm3.6/Rsp/gadm36_POL_1_sp.rds"
data3 <- readRDS(url(URL3))
URL4 <- "https://biogeo.ucdavis.edu/data/gadm3.6/Rsp/gadm36_SVK_1_sp.rds"
data4 <- readRDS(url(URL4))
URL5 <- "https://biogeo.ucdavis.edu/data/gadm3.6/Rsp/gadm36_AUT_1_sp.rds"
data5 <- readRDS(url(URL5))
URL6 <- "https://biogeo.ucdavis.edu/data/gadm3.6/Rsp/gadm36_FRA_1_sp.rds"
data6 <- readRDS(url(URL6))
URL7 <- "https://biogeo.ucdavis.edu/data/gadm3.6/Rsp/gadm36_HUN_1_sp.rds"
data7 <- readRDS(url(URL7))
URL8 <- "https://biogeo.ucdavis.edu/data/gadm3.6/Rsp/gadm36_BEL_1_sp.rds"
data8 <- readRDS(url(URL8))
URL9 <- "https://biogeo.ucdavis.edu/data/gadm3.6/Rsp/gadm36_NLD_1_sp.rds"
data9 <- readRDS(url(URL9))
URL10 <- "https://biogeo.ucdavis.edu/data/gadm3.6/Rsp/gadm36_CHE_1_sp.rds"
data10 <- readRDS(url(URL10))
# Country borders of all countries
B_URL <- "https://biogeo.ucdavis.edu/data/gadm3.6/Rsp/gadm36_DEU_0_sp.rds"
Bdata <- readRDS(url(B_URL))
B_URL2 <- "https://biogeo.ucdavis.edu/data/gadm3.6/Rsp/gadm36_CZE_0_sp.rds"
Bdata2 <- readRDS(url(B_URL2))
B_URL3 <- "https://biogeo.ucdavis.edu/data/gadm3.6/Rsp/gadm36_POL_0_sp.rds"
Bdata3 <- readRDS(url(B_URL3))
B_URL4 <- "https://biogeo.ucdavis.edu/data/gadm3.6/Rsp/gadm36_SVK_0_sp.rds"
Bdata4 <- readRDS(url(B_URL4))
B_URL5 <- "https://biogeo.ucdavis.edu/data/gadm3.6/Rsp/gadm36_AUT_0_sp.rds"
Bdata5 <- readRDS(url(B_URL5))
B_URL6 <- "https://biogeo.ucdavis.edu/data/gadm3.6/Rsp/gadm36_FRA_0_sp.rds"
Bdata6 <- readRDS(url(B_URL6))
B_URL7 <- "https://biogeo.ucdavis.edu/data/gadm3.6/Rsp/gadm36_HUN_0_sp.rds"
Bdata7 <- readRDS(url(B_URL7))
B_URL8 <- "https://biogeo.ucdavis.edu/data/gadm3.6/Rsp/gadm36_BEL_0_sp.rds"
Bdata8 <- readRDS(url(B_URL8))
B_URL9 <- "https://biogeo.ucdavis.edu/data/gadm3.6/Rsp/gadm36_NLD_0_sp.rds"
Bdata9 <- readRDS(url(B_URL9))
B_URL10 <- "https://biogeo.ucdavis.edu/data/gadm3.6/Rsp/gadm36_CHE_0_sp.rds"
Bdata10 <- readRDS(url(B_URL10))
# Trying to perform network base on QUEEN AND ROOK
A <- rbind(data, data2, data3, data4, data5,data6, data7, data8, data9, data10)
queen_data <- poly2nb(A, queen = F)
queen_data <- nb2listw(queen_data, style = "W", zero.policy = TRUE)
# Creating dataframe for plot purposes
data_df <- data.frame(coordinates(A))
colnames(data_df) <- c("long", "lat")
n = length(attributes(queen_data$neighbours)$region.id)
DA = data.frame(
from = rep(1:n,sapply(queen_data$neighbours,length)),
to = unlist(queen_data$neighbours),
weight = unlist(queen_data$weights)
)
DA = cbind(DA, data_df[DA$from,], data_df[DA$to,])
colnames(DA)[4:7] = c("long","lat","long_to","lat_to")
leaflet() %>% addProviderTiles("CartoDB.Positron") %>%
addPolygons(data=data, weight = 1, fill = F, color = "red") %>%
addPolygons(data=data2, weight = 1, fill = F, color = "red") %>%
addPolygons(data=data3, weight = 1, fill = F, color = "red") %>%
addPolygons(data=data4, weight = 1, fill = F, color = "red") %>%
addPolygons(data=data5, weight = 1, fill = F, color = "red") %>%
addPolygons(data=data7, weight = 1, fill = F, color = "red") %>%
addPolygons(data=data8, weight = 1, fill = F, color = "red") %>%
addPolygons(data=data9, weight = 1, fill = F, color = "red") %>%
addPolygons(data=data10, weight = 1, fill = F, color = "red") %>%
addPolygons(data=Bdata, weight = 3, fill = F, color = "black") %>%
addPolygons(data=Bdata2, weight = 3, fill = F, color = "black") %>%
addPolygons(data=Bdata3, weight = 3, fill = F, color = "black") %>%
addPolygons(data=Bdata4, weight = 3, fill = F, color = "black") %>%
addPolygons(data=Bdata5, weight = 3, fill = F, color = "black") %>%
addPolygons(data=Bdata6, weight = 3, fill = F, color = "black") %>%
addPolygons(data=Bdata7, weight = 3, fill = F, color = "black") %>%
addPolygons(data=Bdata8, weight = 3, fill = F, color = "black") %>%
addPolygons(data=Bdata9, weight = 3, fill = F, color = "black") %>%
addPolygons(data=Bdata10, weight = 3, fill = F, color = "black") %>%
addCircles(lng = data_df$long, lat = data_df$lat, weight = 9) %>%
#addCircles(lng = data_df2$long, lat = data_df2$lat) %>%
addFlows(lng0 = DA$long, lat0 = DA$lat,lng1 = DA$long_to, lat1 = DA$lat_to,
dir = 0, maxThickness= 0.85)
I came up with mechanical solution where we would mechaniccaliy force data.frame to have same number of rows, however this approach is not good.
A <- rbind(data, data2, data3, data4, data5, data6, data7, data8, data9, data10)
queen_data <- poly2nb(A, queen = T)
queen_data <- nb2listw(queen_data, zero.policy = T)
plot(A)
plot(queen_data, coordinates(A), add = T, col = "red")
# Creating dataframe for plot purposes
data_df <- data.frame(coordinates(A))
colnames(data_df) <- c("long", "lat")
n = length(attributes(queen_data$neighbours)$region.id)
weights = unlist(queen_data$weights)
data_df[DA$from,] %>% dim()
da_to = data_df[DA$to,]
da_to[709, c(1, 2)] = NA
weight[709] = NA
DA = data.frame(
from = rep(1:n,sapply(queen_data$neighbours,length)),
to = unlist(queen_data$neighbours),
weight = weight
)
DA = cbind(DA, data_df[DA$from,], da_to)
colnames(DA)[4:7] = c("long","lat","long_to","lat_to")
final plot should look like plot(A) plot(queen_data, coordinates(A), add = T, col = "red") and when plotting this DA dataframe leaflet it is NOT the same and therefore not right.
The code output is a plot that I would like it be responsive, to adjust according to window dimension.
Using just ggplot gives me the result desired but I want to use the interactive tooltip of plotly, but when I do the figure is not responsive.
Is there any fix that it could work ? The code is bellow. I really appreciate any help !
library(dplyr)
library(ggplot2)
library(lubridate)
library(plotly)
df <- data.frame(matrix(c("2017-09-04","2017-09-05","2017-09-06","2017-09-07","2017-09-08",103,104,105,106,107,17356,18022,17000,20100,15230),ncol = 3, nrow = 5))
colnames(df) <- c("DATE","ORDER_ID","SALES")
df$DATE <- as.Date(df$DATE, format = "%Y-%m-%d")
df$SALES <- as.numeric(as.character(df$SALES))
df$ORDER_ID <- as.numeric(as.character(df$ORDER_ID))
TOTALSALES <- df %>% select(ORDER_ID,DATE,SALES) %>% mutate(weekday = wday(DATE, label=TRUE)) %>% mutate(DATE=as.Date(DATE)) %>% filter(!wday(DATE) %in% c(1, 7) & !(DATE %in% as.Date(c('2017-01-02','2017-02-27','2017-02-28','2017-04-14'))) ) %>% group_by(day=floor_date(DATE,"day")) %>% summarise(sales=sum(SALES)) %>% data.frame()
TOTALSALES <- ggplot(TOTALSALES ,aes(x=day,y=sales,text=paste('Vendas (R$):', format(sales,digits=9, decimal.mark=",",nsmall=2,big.mark = "."),'<br>Data: ',format(day,"%d/%m/%Y"))))+ geom_point(colour = "black", size = 1)+stat_smooth() +labs(title='TOTAL SALES',x='dias',y='valor')+ scale_x_date(date_minor_breaks = "1 week")
m <- list(
l = 120,
r = 2,
b = 2,
t = 50,
pad = 4
)
TOTALSALES <- ggplotly(TOTALSALES,tooltip = c("text")) %>% config(displayModeBar = F) %>% layout(autosize = F, width = 1000, height = 500, margin = m,xaxis = list(
zeroline = F
),
yaxis = list(
hoverformat = '.2f'
))
TOTALSALES
I have an reactive ggvis scatterplot (layer_points) in shiny.
Now i want to add an horizontal line and vertical line in the plot to resemble the median of the x/y axis.
i know how to calculate it, but not how to display it in same plot.
my code so far:
vis <- reactive({
# Lables for axes
xvar_name <- names(axis_vars)[axis_vars == input$xvar]
yvar_name <- names(axis_vars)[axis_vars == input$yvar]
xvar <- prop("x", as.symbol(input$xvar))
yvar <- prop("y", as.symbol(input$yvar))
gegevens %>%
ggvis(x = xvar, y = yvar) %>%
layer_points(size := 50, size.hover := 200,
fillOpacity := 0.2, fillOpacity.hover := 0.5,
stroke = ~bron, key := ~Project.ID) %>%
add_tooltip(gegevens_tooltip, "hover") %>%
add_axis("x", title = xvar_name, format='d', grid = FALSE) %>%
add_axis("y", title = yvar_name, format='d', grid = FALSE) %>%
add_legend("stroke", title = "Gegevens van:", values = c("A", "B")) %>%
scale_numeric("x", trans = "log", expand=0) %>%
scale_numeric("y", trans = "log", expand=0) %>%
scale_nominal("stroke", domain = c("A", "B"),
range = c("blue", "#aaa")) %>%
set_options(width = 600, height = 600)
})
vis %>% bind_shiny("plot1")
to calculate the median i use:
output$defects <- renderText ({
d <- median(gegevens()$Total.Defects.Delivered)
paste("de mediaan voor totaal aantal Defects is:", d)
})
Lots of thanks for helping.
Seems i misunderstood your example, but i got it working, just after i posted i couldn't. Well here is the solution:
vis <- reactive({
# Lables for axes
xvar_name <- names(axis_vars)[axis_vars == input$xvar]
yvar_name <- names(axis_vars)[axis_vars == input$yvar]
xvar <- prop("x", as.symbol(input$xvar))
yvar <- prop("y", as.symbol(input$yvar))
gegevens %>%
ggvis(x = xvar, y = yvar) %>%
layer_points(size := 50, size.hover := 200,
fillOpacity := 0.2, fillOpacity.hover := 0.5,
stroke = ~bron, key := ~Project.ID) %>%
add_tooltip(gegevens_tooltip, "hover") %>%
add_axis("x", title = xvar_name, format='d', grid = FALSE, properties = axis_props(labels = list(angle = 90, align = "left"))) %>%
add_axis("y", title = yvar_name, format='d', grid = FALSE) %>%
add_legend("stroke", title = "Gegevens van:", values = c("A", "B")) %>%
scale_numeric("x", trans = "log", expand=0) %>%
scale_numeric("y", trans = "log", expand=0) %>%
scale_nominal("stroke", domain = c("A", "B"),
range = c("blue", "#aaa")) %>%
set_options(width = 600, height = 600) %>%
layer_paths(data = gegevens, x = median(gegevens()$kolomname.i.want.the.median.from)), y = yvar ) %>%
layer_paths(data = gegevens, x = xvar, y = median(gegevens()$kolomname.i.want.the.median.from))
})
this gives me an cross in my plot by calculating the median of x and y, even if the user changes the original input. of course i need to find out how to get "kolomname.i.want.the.median.from" to be the x-/ or y-value.
but i now know how to get the lines in, and that was the question.
So thank you aosmith for the right direction.