Related
I am trying to make use of tabnet with tidymodels and the Titanic dataset. Here is my code:
pacman::p_load(tidyverse,
tidymodels,
tabnet,
torch,
doParallel,
reprex)
data(Titanic)
Titanic <- as.data.frame(Titanic)
#partition data
set.seed(1711)
titanic_split <- initial_split(Titanic, prop = 0.75, strata = Survived)
titanic_train <- training(titanic_split)
titanic_test <- testing(titanic_split)
#create cross-validation folds of training data
set.seed(1712)
folds <- vfold_cv(titanic_train,
folds = 3,
strata = Survived)
# define recipes for different models
titanic_rec <- recipe(formula = Survived ~ ., data = titanic_train) %>%
update_role(Survived, new_role = "outcome") %>%
step_zv() %>%
step_novel(all_nominal_predictors()) %>%
step_dummy(all_nominal_predictors(), one_hot = TRUE) %>%
step_YeoJohnson()
juice(prep(titanic_rec))
#define model
tab_spec <- tabnet(
mode = "classification",
epochs = 1, batch_size = 16384, decision_width = tune(), attention_width = tune(),
num_steps = tune(), penalty = 0.000001, virtual_batch_size = 512, momentum = 0.6,
feature_reusage = 1.5, learn_rate = tune()
) %>%
set_engine("torch", verbose= T)
wf <- workflow() %>%
add_model(tab_spec) %>%
add_recipe(titanic_rec)
grid <-
wf %>%
extract_parameter_set_dials() %>%
update(
decision_width = decision_width(range = c(20, 40)),
attention_width = attention_width(range = c(20, 40)),
num_steps = num_steps(range = c(4, 6)),
learn_rate = learn_rate(range = c(-2.5, -1))
) %>%
grid_max_entropy(size = 8)
auc_metric <- metric_set(yardstick::roc_auc)
auc_ctrl <- control_race(
verbose_elim = TRUE)
auc_results <- wf %>%
tune_grid(
resamples = folds,
control = auc_ctrl,
grid = grid)
This works like a charm . If i try however to use paraller processing I´m getting an error:
cl7 <- makePSOCKcluster(7)
registerDoParallel(cl7)
auc_results <- wf %>%
tune_grid(
resamples = folds,
control = auc_ctrl,
grid = grid)
Warning message:
All models failed. Run show_notes(.Last.tune.result) for more information.
Upon running shoe_notes i get the following : unique notes:
Error in UseMethod("filter"): no applicable method for 'filter' applied to an object of class "NULL"
Anyone knows how to fix this ?
I am working with the R programming language.
I have the following 8 plots have been made beforehand and saved as HTML files in my working directory:
library(plotly)
Red_A <- data.frame(var1 = rnorm(100,100,100), var2 = rnorm(100,100,100)) %>%
plot_ly(x = ~var1, y = ~var2, marker = list(color = "red")) %>%
layout(title = 'Red A')
Red_B <- data.frame(var1 = rnorm(100,100,100), var2 = rnorm(100,100,100)) %>%
plot_ly(x = ~var1, y = ~var2, marker = list(color = "red")) %>%
layout(title = 'Red B')
Blue_A <- data.frame(var1 = rnorm(100,100,100), var2 = rnorm(100,100,100)) %>%
plot_ly(x = ~var1, y = ~var2, marker = list(color = "blue")) %>%
layout(title = 'Blue A')
Blue_B <- data.frame(var1 = rnorm(100,100,100), var2 = rnorm(100,100,100)) %>%
plot_ly(x = ~var1, y = ~var2, marker = list(color = "red")) %>%
layout(title = 'Blue B')
htmlwidgets::saveWidget(as_widget(Red_A), "Red_A.html")
htmlwidgets::saveWidget(as_widget(Red_B), "Red_B.html")
htmlwidgets::saveWidget(as_widget(Blue_A), "Blue_A.html")
htmlwidgets::saveWidget(as_widget(Blue_B), "Blue_B.html")
My Question: Using this template over here (https://testing-apps.shinyapps.io/flexdashboard-shiny-biclust/) - I would like to make a flexdashboard that allows the user to select (from two dropdown menus) a "color" and a "letter" - and then render one of the corresponding graphs (e.g. col = Red & letter = B -> "Red B"). I would then like to be able to save the final product itself as an HTML file. This would look something like this:
I tried to write the Rmarkdown Code for this problem by adapting the tutorial:
---
title: "Plotly Graph Selector"
output:
flexdashboard::flex_dashboard:
orientation: columns
vertical_layout: fill
runtime: shiny
---
Inputs {.sidebar}
selectInput("Letter", label = h3("Letter"),
choices = list("A" = 1, "B" = 2),
selected = 1)
selectInput("Color", label = h3("Color"),
choices = list("Red" = 1, "Blue" = 2),
selected = 1)
How can I continue with this?
Note
I know that it is possible to load HTML files into a dashboard that have been made beforehand, e.g.
# https://stackoverflow.com/questions/73467711/directly-loading-html-files-in-r
<object class="one" type="text/html" data="Red_A.html"></object>
<object class="one" type="text/html" data="Red_B.html"></object>
<object class="one" type="text/html" data="Blue_A.html"></object>
<object class="one" type="text/html" data="Blue_B.html"></object>
You could use iframe with renderUI to render the HTML files locally using addResourcePath with the location of your files. With paste0 and paste your could dynamically create the html files to select them. Here is some reproducible code:
---
title: "Plotly Graph Selector"
output:
flexdashboard::flex_dashboard:
orientation: columns
vertical_layout: fill
self_contained: false
runtime: shiny
---
```{r global, include=FALSE}
```
Inputs {.sidebar}
-----------------------------------------------------------------------
```{r}
selectInput("Letter", label = h3("Letter"),
choices = c("A", "B"),
selected = "A")
selectInput("Color", label = h3("Color"),
choices = c("Red", "Blue"),
selected = "Red")
```
Row
-----------------------------------------------------------------------
```{r}
addResourcePath("Downloads", "~/Downloads")
renderUI({
color <- input$Color
letter <- input$Letter
tags$iframe(
seamless="seamless",
src=paste0("Downloads/", paste0(paste(color, letter, sep = "_"), ".html")),
width = 600,
height = 400)
})
```
Output:
If you want to remove the border around the plot, you could add frameBorder = "0" in your iframe call like this:
```{r}
addResourcePath("Downloads", "~/Downloads")
renderUI({
color <- input$Color
letter <- input$Letter
tags$iframe(
seamless="seamless",
src=paste0("Downloads/", paste0(paste(color, letter, sep = "_"), ".html")),
width = 600,
height = 400,
frameBorder = "0")
})
```
Output:
Using getwd() with basename like this:
```{r}
addResourcePath(basename(getwd()), getwd())
renderUI({
color <- input$Color
letter <- input$Letter
tags$iframe(
seamless="seamless",
src=paste0(basename(getwd()), "/", paste0(paste(color, letter, sep = "_"), ".html")),
width = 600,
height = 400,
frameBorder = "0")
})
```
I am using the R programming language. I am trying to take different types of graphs (bar graphs, pie charts) and put them on the same page. I generated some fake data and made several graphs - then I put them together (see : Combining Different Types of Graphs Together (R))
library(dplyr)
library(ggplot2)
library(cowplot)
library(gridExtra)
library(plotly)
date= seq(as.Date("2014/1/1"), as.Date("2016/1/1"),by="day")
var <- rnorm(731,10,10)
group <- sample( LETTERS[1:4], 731, replace=TRUE, prob=c(0.25, 0.22, 0.25, 0.25) )
data = data.frame(date, var, group)
data$year = as.numeric(format(data$date,'%Y'))
data$year = as.factor(data$year)
###Pie
Pie_2014 <- data %>%
filter((data$year == "2014")) %>%
group_by(group) %>%
summarise(n = n())
Pie_2014_graph = ggplot(Pie_2014, aes(x="", y=n, fill=group)) +
geom_bar(stat="identity", width=1) +
coord_polar("y", start=0) +ggtitle( "Pie Chart 2014")
Pie_2015 <- data %>%
filter((data$year == "2015")) %>%
group_by(group) %>%
summarise(n = n())
Pie_2015_graph = ggplot(Pie_2015, aes(x="", y=n, fill=group)) +
geom_bar(stat="identity", width=1) +
coord_polar("y", start=0) +ggtitle( "Pie Chart 2015")
Pie_total = data %>%
group_by(group) %>%
summarise(n = n())
Pie_total_graph = ggplot(Pie_total, aes(x="", y=n, fill=group)) +
geom_bar(stat="identity", width=1) +
coord_polar("y", start=0) +ggtitle( "Pie Chart Average")
###bars
Bar_years = data %>%
group_by(year, group) %>%
summarise(mean = mean(var))
Bar_years_plot = ggplot(Bar_years, aes(fill=group, y=mean, x=year)) +
geom_bar(position="dodge", stat="identity") + ggtitle("Bar Plot All Years")
Bar_total = data %>%
group_by(group) %>%
summarise(mean = n())
Bar_total_plot = ggplot(Bar_total, aes(x=group, y=mean, fill=group)) +
geom_bar(stat="identity")+theme_minimal() + ggtitle("Bar Plot Average")
#assembling the graphs can be done two different ways
#first way
g1 <- grid.arrange(Pie_2014_graph, Pie_2015_graph , Pie_total_graph, nrow = 1)
g2 <- grid.arrange(Bar_total_plot, Bar_years_plot, nrow = 1)
g = grid.arrange(g1, g2, ncol = 1)
#second way
# arrange subplots in rows
top_row <- plot_grid(Pie_2014_graph, Pie_2015_graph, Pie_total_graph)
middle_row <- plot_grid(Bar_years_plot, Bar_total_plot)
# arrange our new rows into combined plot
p <- plot_grid(top_row, middle_row, nrow = 2)
p
From here, I am trying to use the plotly::ggplotly() command to make the above output "interactive" (move the mouse over the graphs and see labels). I know that this works for individual plots:
ggplotly(Bar_years_plot)
However, this command does not seem to work with the "cowplot" and the "gridExtra" outputs:
#gridExtra version:
ggplotly(g)
Error in UseMethod("ggplotly", p) :
no applicable method for 'ggplotly' applied to an object of class "c('gtable', 'gTree', 'grob', 'gDesc')"
#cowplot version: (produces empty plot)
ggplotly(p)
Warning messages:
1: In geom2trace.default(dots[[1L]][[1L]], dots[[2L]][[1L]], dots[[3L]][[1L]]) :
geom_GeomDrawGrob() has yet to be implemented in plotly.
If you'd like to see this geom implemented,
Please open an issue with your example code at
https://github.com/ropensci/plotly/issues
2: In geom2trace.default(dots[[1L]][[1L]], dots[[2L]][[1L]], dots[[3L]][[1L]]) :
geom_GeomDrawGrob() has yet to be implemented in plotly.
If you'd like to see this geom implemented,
Please open an issue with your example code at
https://github.com/ropensci/plotly/issues
Does anyone know if there is a quick way to use the ggplotly() function for objects created with "gridExtra" or "cowplot"?
I know that with a bit of work, it might be possible using "htmltools":
library(htmltools)
doc <- htmltools::tagList(
div(Pie_2014_graph, style = "float:left;width:50%;"),
div(Pie_2015_graph,style = "float:left;width:50%;"),
div(Pie_total_graph, style = "float:left;width:50%;"),
div(Bar_years_plot, style = "float:left;width:50%;"),
div(Bar_total_plot, style = "float:left;width:50%;"))
save_html(html = doc, file = "out.html")
But I am not sure how to do this.
Can someone please show me how to make the collections of graphs interactive either using ggplotly() or with htmltools()?
Thanks.
You should apply ggplotly() to the individual graphs, not the collection graphs.
For example:
Pie_2014_graph = ggplotly(ggplot(Pie_2014, aes(x="", y=n, fill=group)) +
geom_bar(stat="identity", width=1) +
coord_polar("y", start=0) +ggtitle( "Pie Chart 2014") )
Creating a leaflet map. First step, specify the label. The code used on leaflet github puts
%>% lapply(htmltool::HTML)
after the sprintf() function. However, making it is creating the label as a type:"list" resulting in the error: "Error in sum(sapply(label, function(x) { : invalid 'type' (list) of argument"
So to try and get around this I just load the htmltools library and use the code
HTML(sprintf(...))
Doing this works and runs the map, however, the labels show up as small boxes with no information (see picture link below)
I can't tell if this is something to do with the code inside sprintf() or if this has to do with HTML().
The weird thing is that the %>% lapply method was working just fine, but something happened and now its giving the error mentioned above
Image with the small label shown as little white box
labels.dest2 <- sprintf("<div style = 'overflow-wrap: anywhere;'><strong>%s <br/>%s Destinations</div><br/>%s Euclidean Miles from LAX on average<br/>%s minutes between OD tweets </div><br/>%s Miles from LAX on average</div><br/>%s minutes from LAX on average</div>",
puma.spdf$NAME,
puma.spdf$Dest_pt_count,
puma.spdf$Avg_Euc_Dist_Mi,
puma.spdf$Avg_tweetTime,
puma.spdf$Avg_RtDist_Mi,
puma.spdf$Avg_RtTime_min) %>% lapply(htmltools::HTML)
leaflet() %>% addTiles() %>% etc...
FULL CODE HERE
## Map with OD data and travel stats ##
labels.dest2 <- HTML(sprintf("<div style = 'overflow-wrap: anywhere;'> <strong>%s <br/>%g Destinations</div><br/>%s Euclidean Miles from LAX on average<br/>%s minutes between OD tweets </div><br/>%s Miles from LAX on average</div><br/>%s minutes from LAX on average</div>",
puma.spdf$NAME,
puma.spdf$Dest_pt_count,
puma.spdf$Avg_Euc_Dist_Mi,
puma.spdf$Avg_tweetTime,
puma.spdf$Avg_RtDist_Mi,
puma.spdf$Avg_RtTime_min))
leaflet() %>% addTiles() %>%
setView(lng=-118.243683, lat=34.1, zoom = 9.35) %>%
addEasyButton(easyButton(
icon="fa-crosshairs", title = "Default View",
onClick=JS("function(btn, map) {var groupLayer = map.layerManager.getLayerGroup('Destinations (red)'); map.fitBounds(groupLayer.getBounds());}"))) %>%
addProviderTiles(providers$CartoDB.Positron,
group = "Grey") %>%
addProviderTiles(providers$OpenStreetMap.BlackAndWhite,
group = "OSM") %>%
# Add Polygons
# Destination data
addPolygons(data = puma.spdf,
group = "Destination Density",
fillColor = ~pal.dest(Dest_pt_count),
weight = 1,
opacity = 90,
color = "white",
dashArray = "3",
fillOpacity = 0.5,
highlight = highlightOptions(weight = 2,
color = "#666",
dashArray = "",
fillOpacity = 0.7,
bringToFront = TRUE,
sendToBack = TRUE),
label = labels.dest2,
labelOptions = labelOptions(style = list("font-weight" = "normal", padding = "3px 8px"),
textsize = "15px",
direction = "auto")) %>%
addLegend(values=puma.spdf$Dest_pt_count,
group = "Destination Density",
pal=pal.dest,
title="Destination Density (Dest per PUMA)",
position = "bottomright") %>%
# Add Points
addCircleMarkers(data = D.spdf,
radius = 2,
color = "red",
group = "Destinations (red)",
fillOpacity = 0.5) %>%
addCircleMarkers(data = O.spdf,
radius = 2,
color = "green",
group = "Origins (green)") %>%
# Add Layer Controls
addLayersControl(
baseGroups = c("OSM (default)", "Grey"),
overlayGroups = c("Destinations (red)", "Origins (green)","Destination Density"),
options = layersControlOptions(collapsed = FALSE)
)
The problem was that the first column puma.spdf$NAME was not part of the dataset and was throwing off the string.. check to make sure all the variables you want to show are actually part of the dataset.
All good souls, help needed. I am creating a leaflet map and cannot resolve a strange issue with labels. I created labels with few variables and the labels render ok if the first variable is numeric, but they fail if the first is a string - any idea what's the issue?
Let's start with a dummy spdf:
library(htmltools)
library(sp)
library(leaflet)
df <- new("SpatialPointsDataFrame", data = structure(list(PMID = c(184397, 184397), SPACEID = c("184397_1", "184397_2")), .Names = c("PMID", "SPACEID"), row.names = 1:2, class = "data.frame"), coords.nrs = numeric(0), coords = structure(c(-0.14463936, -0.14468822, 51.50726534, 51.50730171), .Dim = c(2L, 2L), .Dimnames = list(c("1", "2"), c("x", "y"))), bbox = structure(c(-0.14468822, 51.50726534, -0.14463936, 51.50730171), .Dim = c(2L, 2L), .Dimnames = list(c("x", "y"), c("min", "max"))), proj4string = new("CRS", projargs = "+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0"))
now we (m)apply a simple HTML line (the original used the df rows but it is not needed and can be simplified to
df#data$HT<-mapply(function(x,y){htmltools::HTML(sprintf("<h2>%s</h2> %s",x,y))},1,"L", SIMPLIFY = F)
and this one will work fine. But if the order is reversed - instead of (1,"L") we change to ("L",1) - it fails:
df#data$HT<-mapply(function(x,y){htmltools::HTML(sprintf("<h2>%s</h2> %s",x,y))},"L",1, SIMPLIFY = F)
in the first case the map contains correct labels and in the other one it produces empty label
leaflet() %>%
addTiles() %>%
addMarkers(data = df, label = ~ HT)
if I use label = ~as.character(HT) it shall produce a verbatim HTML tag, but not the label. What's wrong with it?
After playing around the code, I found that replacing mapply() with map2() in the purrr package does the trick here. I am not totally sure why this is the case. Both Slav and I confirmed that this solution is working on our machines.
library(sp)
library(leaflet)
library(htmltools)
library(purrr)
df#data$HT1 <- map2(1, "L", ~htmltools::HTML(sprintf("<h2>%s</h2> %s",.x,.y)))
df#data$HT2 <- map2("L", 1, ~htmltools::HTML(sprintf("<h2>%s</h2> %s",.x,.y)))
leaflet()%>%
addProviderTiles("OpenStreetMap.Mapnik") %>%
addLabelOnlyMarkers(data = df, label = ~HT2,
labelOptions = labelOptions(noHide = TRUE, direction = 'center',
textOnly = FALSE, textsize = "15px"))