I have a folder full of charts, generated from a previous step. All of them are PNG files.
I want to be able to choose anyone using Flexdashboard and load it.
As no shiny or server service is needed I tried Crosstalk package
library(crosstalk)
library(magrittr)
library(png)
df <- list.files("plots/", full.names = TRUE) %>%
as_tibble() %>%
magrittr::set_names("path")
shared_data <- SharedData$new(df, key = ~path)
p <- shared_data %>% readPNG(source = path)
bscols( filter_select(id = "file_id",
label = "CHOOSE",
sharedData = shared_data,
group = ~path),
p)
I am stuck on a very simple error i cannot solve as all paths are properly read from file:
Error in path.expand(source) : invalid 'path' argument
Tried to use knitr too:
bscols(filter_select("path", "CHOOSE", shared_data),
knitr::include_graphics(shared_data, ~path))
Error in makeGroupOptions(sharedData, group, allLevels) : argument "group" is missing, with no default
Maybe there is a simpler approach but crosstalk seemed a very simple one as it does not need shiny or any other component but a data frame.
This can be achieved more easily by using bsselectR
The library is 5 years old but works perfectly in my trial. It does not offer the same level of in-plot interaction as crosstalk but might be sufficient for the current purpose.
Below is the code snippet to add to R Markdown document. I've altered the sample code to allow for recursive directory walk.
The plots directory needs to be placed in the same directory as the R file.
```{r}
#
library(stringr)
library(bsselectR)
state_plots <- paste0(list.files("plots", full.names = TRUE, recursive = TRUE))
names(state_plots) <- str_replace_all(state_plots,
c("\\.png" = "",
"plots/" = ""))
bsselect(state_plots, type = "img", selected = "sns_heatmap",
live_search = TRUE, show_tick = TRUE)
```
Output :
Related
I am making a Shiny app to keep track of some things that need to be done at work. One component of the app is to send an email letting everyone know what they are responsible for doing that week. I originally wrote the code to do that in two separate pieces, an R markdown file to generate the emails, and an R script to iterate through a table that has user's names in it to generate a personalized email that includes the tasks for which they are responsible. Locally, this works fine. I have a button setup to run the R script, which then sources the R markdown code for each user and sends an email to each user. After deploying the app this no longer works. Debugging the Shiny app has proved tricky, but I'm guessing is has to do with the fact that the R script and R markdown file are not communicating with each other. I was wondering if I could solicit some advice on how to resolve this. Thank you in advance for any insight or advice, I only program a little for work and have been struggling to fix this. The code below is a simplified version of what I'm trying to use.
#DATA
email.addresses <- data.frame(user = as.character(c("Peyton Mannning", "John Elway")),
email.address = as.character(c("Peyton.manning#gmail.com", "john.elway#gmail.com")),
stringsAsFactors=FALSE)
email.complete <- data.frame(task = as.character(c("Do the dishes", "Mop the floor")), next.completion = as.Date("2020-12-10"), Responsible.Persons = as.character(c("Peyton Manning", "John Elway")))
#R script
library(lubridate)
library(blastula)
for (user in unique(email.addresses$User)){
email <- render_email("email markdown.Rmd")
email %>%
smtp_send(
from = "personal#email.net",
to = email.addresses$Email[email.addresses$User == user],
subject = paste("Cleaning Schedule for", floor_date(Sys.Date() - 1, "weeks") + 1, sep = " ", collapse = NULL),
credentials = creds_key(id = "gmail")
)
}
# markdown
```{r, results='asis', echo = FALSE}
email.complete.user <- email.complete[email.complete$Responsible.Persons == user,]
library(kableExtra)
library(dplyr)
email.complete.user %>%
kbl(row.names = FALSE, col.names = c("Task", "Completion Deadline", "Responsible User"), format = "html", table.attr = "style='width:100%;'", longtable = TRUE) %>%
kable_styling(bootstrap_options = c("striped", "hover", position = "left"), font_size = 20) %>%
kable_minimal()```
I am still relatively new at working in R shiny and I am trying to load several excel files into an R-shiny app. Part of the problem is that I need to be able to pull several files from a dropbox folder without specifying what the data file is called. So I need to be able to tell R to read in all the files from a dropbox folder. Also the files I am working with are in .xlsx format and I will need to read them into R as such.
I tried to do this first by using a folder on my computer desktop. I managed to get it to work using my local directory with the code below:
library(readxl)
library(tidyverse)
files <- list.files(path = "~/Desktop/data", pattern = "*.xlsx", full.names = TRUE) #read files from folder on desktop
df <- sapply(files, read_excel, simplify = FALSE) %>% #read files from the path, and bind them together
bind_rows()
I tried to adjust the code above to work with the drop_dir function in rdrop2. The code I tried is below:
library(rdrop2)
library(tidyverse)
library(readxl)
token <- drop_auth()
files <- drop_dir("!dropbox_folder", dtoken = token) #List all files in Dropbox folder MPD_03_Test
f <- files$path_display #list directory to dropbox
df <- sapply(f, read_excel, simplify = FALSE) %>% #runs the read function for all the files that are pulled
bind_rows() # .id="id creates a unique ID for each row and then binds them all together based on the ID.
When I run it the code is not loading the data files from the dropbox into R. When I run the dropbox code it just creates an empty object. Any help on where to go to figure this out will be greatly appreciated! Also I intend to use this as how I read data into and R-shiny app if that helps frame any suggestions you may have about how to approach my problem.
Thank You!
#MrGumble is correct in his comments. The files need to downloaded before being read. The drop_dir() function lists file paths on dropbox server and we can only read in data saved locally to our machine. If you have .csv files then this can be down in 1 step with the drop_read_csv() function. But since you have excel files these need to first to be downloaded explicitly with drop_download() and then read in with read_excel().
library(rdrop2)
library(tidyverse)
library(readxl)
#install.packages("xlsx")
library(xlsx)
token <- drop_auth()
#make a few excel file with iris dataset, save locally, and upload to dropbox root
iris_filenames <- paste0("iris", 1:3, ".xlsx")
walk(iris_filenames, ~write.xlsx(iris, file = .x, row.names = FALSE))
walk(iris_filenames, drop_upload)
#list all files on dropbox root and filter for only iris ones
iris_files_on_dropbox <- drop_dir(dtoken = token) %>%
filter(str_detect(name, 'iris'))
#make new filenames so we can see that the download worked correctly
#you could do overwrite = TRUE and not pass through new filenames
#see ?drop_download for all options
new_iris_filenames <- paste0("iris", 1:3, "-from-dropbox.xlsx")
#download the files first
walk2(iris_files_on_dropbox$name, new_iris_filenames, ~drop_download(path = .x, local_path = .y))
#then read them all in
df <- bind_rows(map(new_iris_filenames, read_xlsx))
Additionally, we can create our own custom function to do the download and reading in 1 step just as drop_read_csv() does by altering the source code for this function. All we need to do is change the read...() function from read.csv to read_excel and the reference to the dtoken default get_drop_token() to rdrop2:::get_drop_token() which is an un-exported function from the rdrop2 package so we need the three ':::'.
#source for drop_read_csv we can rewrite for excel files
# drop_read_csv <- function(file, dest = tempdir(), dtoken = get_dropbox_token(), ...) {
# localfile = paste0(dest, "/", basename(file))
# drop_download(file, localfile, overwrite = TRUE, dtoken = dtoken)
# utils::read.csv(localfile, ...)
# }
drop_read_excel <- function(file, dest = tempdir(), dtoken = rdrop2:::get_dropbox_token(), ...) {
localfile = paste0(dest, "/", basename(file))
drop_download(file, localfile, overwrite = TRUE, dtoken = dtoken)
readxl::read_excel(localfile, ...)
}
df2 <- bind_rows(map(iris_files_on_dropbox$name, drop_read_excel))
To work in a shiny app we first need to save the drop_auth token so we can authenticate while using the shiny app. Save this into your shiny app directory.
saveRDS(token, file = "token.rds")
Now here is a shiny app. When the 'go' button is clicked the iris excel files are downloaded and shown in the UI. We need to call drop_auth() in the global environment or global.R along with the custom drop_read_excel() function to use it.
library(shiny)
library(rdrop2)
library(tidyverse)
#saveRDS(token, file = "token.rds") into shiny app directory
#authenticate in global.R or outside of ui/server
drop_auth(rdstoken = "token.rds")
drop_read_excel <- function(file, dest = tempdir(), dtoken = rdrop2:::get_dropbox_token(), ...) {
localfile = paste0(dest, "/", basename(file))
drop_download(file, localfile, overwrite = TRUE, dtoken = dtoken)
readxl::read_excel(localfile, ...)
}
ui <- fluidPage(
actionButton("go", "go"),
tableOutput("table")
)
server <- function(input, output, session) {
df <- eventReactive(input$go, {
withProgress(message = 'Downloading from dropbox',
detail = 'This may take a while...', value = 0.5, {
iris_files_on_dropbox <- drop_dir() %>%
filter(str_detect(name, 'iris'))
setProgress(value = 0.75)
df <- bind_rows(map(iris_files_on_dropbox$name, drop_read_excel))
setProgress(value = 1)
})
return(df)
})
output$table <- renderTable({
df()
})
}
shinyApp(ui, server)
I've been trying to generate a sequence of graph plots inside rmarkdown html compiler...
```{r, include=T, echo=F, fig.height=4, fig.width=10,warning=FALSE}
Here direct is the directory where the files are listed from
"files" is the list of files objects in the transaction form needed for the read.transaction function argument
direct <- "......"
files <- list.files(path = ".....")
for (i in 1:length(files)) {
tr<-read.transactions(file = paste(as.character(direct),"/",files[i],sep = ""),format = "basket",sep = ",")
rules <- apriori(tr, parameter = list(supp=sup, conf=confid))
rules <- sort(rules, by='count', decreasing = TRUE)
plotr <- plot(rules, method = "graph", engine = "htmlwidget")
}
```
I have tried print(plotr), printing just plot(rules,...) and nothing seems to work.
The problem is when I knit the markdown, the plot of the different transaction files doesn't pop up in the html generated by the .Rmd file. Consider that this loop is inside a function that runs inside the chunk.
It would be nice if someone could help me try to solve this problem. If its worth for something, I am trying to generate a report that returns different plot rules based on the apriori algorithm applied to the different files.
If anyone has any idea how this could be solved would be a great help, thank you.
To put multiple htmlWidgets in one RMarkdown chunk you need to create a taglist. Here is an example:
---
title: "Example RMarkdown with multiple arulesViz htmlWidgets in one chunk"
output: html_document
---
```{r}
library(arulesViz)
data(Groceries)
rules <- apriori(Groceries, parameter=list(support=0.001, confidence=0.8))
widget_list <- lapply(1:10, FUN = function(i)
plot(sample(rules, size = 10), method = "graph", engine = "htmlwidget"))
htmltools::tagList(widget_list)
```
You can also use a regular loop to populate the list. More information on this issue can be found at https://github.com/rstudio/DT/issues/67
To hide the messages from library and apriori in the resulting document you can do this:
---
title: "Example RMarkdown with multiple arulesViz htmlWidgets in one chunk"
output: html_document
---
<!-- Hide the messages for library -->
```{r, echo = FALSE, results = FALSE, warning = FALSE, message = FALSE}
library(arulesViz)
```
<!-- verbose = FALSE hides the progress report for apriori -->
```{r}
library(arulesViz)
data(Groceries)
rules <- apriori(Groceries, parameter=list(support=0.001, confidence=0.8),
control = list(verbose = FALSE))
widget_list <- lapply(1:10, FUN = function(i)
plot(sample(rules, size = 10), method = "graph", engine = "htmlwidget"))
htmltools::tagList(widget_list)
```
UPDATE: Added code fixes and comments below and my popup is working...
Shiny beginner here and I've got a slow shiny leaflet app, so I've been using profvis to find the bottlenecks. Using readOGR to load in shapefile data is the major issue. So I've made one change--using read_sf--and things are much, much faster. All of my points and polygons are showing up fine, however my popups don't work now and I'm at a loss as to what could be going on.
Expected result: changing from readOGR to read_sf wouldn't make any difference in populating the popup with data.
Result: the labels are working fine, but the pop-ups aren't showing up at all.
Here's a stripped down version of the app.
ui <- fluidPage(
fluidRow(
column(3,
"",
tags$head(
tags$style(type='text/css',
".nav-tabs {font-size: 10px} ")),
tabsetPanel(id='lefttabsetPanel',selected='placestab',
tabPanel(value="placestab",title='PLACES',
tags$iframe(name="myiframe2",seamless="seamless",src="http://45.56.98.26:8080/exist/rest/db/madrid/xml/tds-placeography.xml",style='height:95vh; width:25vw')
)
))
,
column(9,
"",
tabsetPanel(id='my_tabsetPanel',
tabPanel('Global Map',
withSpinner(leafletOutput(outputId="mymap",height = "95vh"),color="#cd0000",type = 5)
)
)
)
)
)
server <- function(input,output, session){
# Core wrapping function
wrap.it <- function(x, len)
{
sapply(x, function(y) paste(strwrap(y, len),
collapse = "\n"),
USE.NAMES = FALSE)
}
### MAP 1
output$mymap <- renderLeaflet({
m <- leaflet() %>%
addMapPane("toplayer", zIndex=420) %>% addMapPane("layer2",zIndex=410)%>%
setView(lng=-3.6898447, lat=40.4142174, zoom=3 ) %>%
addTiles(options = providerTileOptions(noWrap = TRUE), group="Open") %>%
addCircleMarkers(data = placeography,options = pathOptions(pane = "toplayer"),label=placeography$placename, fillColor="white",stroke = 2, weight=3, color="black",fillOpacity = 1,opacity=1,radius =3,group = "Puntos de interés",
# THIS IS WHAT'S BREAKING WITH read_sf
popup = mapply(function(x, y) {
HTML(sprintf("<div class='leaflet-popup-scrolled' style='font-size:10px;max-width:200px;max-height:150px; '><b><a href='http://45.56.98.26:8080/exist/rest/db/madrid/xml/tds-placeography.xml#%s' target='myiframe2'>%s</a></b></div>", htmlEscape(x), y))},
placeography$placeref,placeography$placename, SIMPLIFY = F))%>%
addLayersControl(baseGroups = c("Open"), overlayGroups = c("Puntos de interés"),position = c("topright"),options = layersControlOptions(collapsed = FALSE))
})
}
library(shiny)
library(leaflet)
library(rgdal)
library(htmltools)
library(tigris)
library(data.table)
library(rmapshaper)
library(shinycssloaders)
library(sf)
#POPUPS WORKED FINE WITH READOGR
#placeography <- readOGR("shapefiles/places_points.shp")
#POPUPS NOT WORKING WITH READ_SF
#placeography <- read_sf("shapefiles/places_points.shp",quiet=TRUE)
#MOST POPUPS WORKING WITH THIS READ_SF
placeography <- read_sf("shapefiles/places_points.shp",quiet=TRUE, as_tibble = FALSE,stringsAsFactors=TRUE)
The shapefiles (places_points) are here: http://45.56.98.26/shapefiles/
UPDATE:
I was able to halfway solve this problem (and it works for the example above) by "using stringsAsFactors = TRUE":
placeography <- read_sf("shapefiles/places_points.shp",quiet=TRUE,as_tibble = FALSE,stringsAsFactors = TRUE)
Unfortunately, one of my labels (not included in the example above--see below) also uses a geojoin--it required an extra step to fix:
placeographyareas<-read_sf("shapefiles/places_areas.shp",quiet=TRUE,as_tibble = FALSE,stringsAsFactors = FALSE)
histpeople<- read.csv("http://45.56.98.26/tds-data/readingmadrid-people-places-hist.csv",header=TRUE,stringsAsFactors = FALSE)
placeographyareashistpeople<- geo_join(placeographyareas,histpeople,"placeref","placeref", how = "left")
#FIX: CONVERT TO FACTOR AFTER JOIN
placeographyareashistpeople$placeref <- as.factor(placeographyareashistpeople$placeref)
I'm getting this warning on the geojoin:
Warning: Column placeref joining factor and character vector, coercing into character vector
And my popup doesn't show up. Changing "stringsAsFactors=TRUE" for histpeople doesn't work, either. Still hoping to better understand the differences between sf_read and readOGR, so I can troubleshoot this issue better. Thanks!
Just in case anyone else ever encounters this sort of problem when switching from readOGR to read_sf.... I bumbled into a solution to this popup issue through the process of elimination and updated the question above with comments to explain where I made the changes.
For most of my popups, just adding "stringsAsFactors = TRUE" to read_sf sorted out the issue (the default for read_sf is the opposite of readOGR). In the case of my more complex popup that was the product of a further geojoin, I needed to change the placeref column back to a factor after the join:
as.factor(placeographyareashistpeople$placeref).
See above for working code.
I wrote a shiny app which will be used for searching and downloading a quite large dataset. The app works and is nearly done, but some functionalities do not work as I want:
I tried several ways of adding a function in order to download the chosen data as .csv-file. All of them failed and I was only able to download all data instead of the displayed ones.
I was not able to include a function to round data and show some columns as percentage instead of numbers. The formatRound() function within datatable() works well and I would like to use it, but the problem is that I was not able to include it in the server function. Since the user should get the whole number (with all numbers also behind the comma) for his or her work, the data should only be rounded when displayed. If I would be able to fix the rounding, the percentage problem will also be solved, since I would use the similar function formatPercentage().
I made an example using the mtcars-data and removed all wrong or not-working codes for the download and rounding problem. Any hints how I could solve my problem would be extremely appreciated! Thanks in advance!
EDIT3: Rounding problem solved with the code below thanks to #Claud H. The download function exports an empty file (no file-type) named download. Do you have any idea where the error is?
EDIT4: problems solved thanks to #Claud H. I changed mt_cars_filtered()[, c(input$results_columns_selected)]into mt_cars_filtered()[, input$indicator]. Also, I didn't know first that I had to open the web browser to download the data.
library(tidyverse)
library(shiny)
library(shinythemes)
library(DT)
library(ggthemes)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(width=3,
h3("title", align = 'center'),
checkboxGroupInput("cylinder", "Cylinder", choices = c(4,6), selected = c(4)),
checkboxGroupInput('indicator', label = 'Indicators', choices = colnames(mtcars)[1:7],
selected = colnames(mtcars)[c(1:7)]),
fluidRow(p(class = 'text-center', downloadButton('download', label = 'Download')))),
mainPanel(
tabsetPanel(
tabPanel('Table',
DT::dataTableOutput('results'))
)
)
))
server <- function(input, output){
mtcars_filtered <- reactive({
mtcars %>%
filter(cyl %in% input$cylinder)
})
# Output Table
output$results <- DT::renderDataTable({
columns = input$indicator
mtcars_filtered()[, columns, drop = FALSE] %>%
datatable(style = 'bootstrap', selection = list(target = 'column'), options = list(paging = FALSE, dom = 't')) %>%
formatRound(input$indicator[grep('t', input$indicator)], 2)
})
# Download Data
output$download <- downloadHandler(
filename = function() { paste('filename', '.csv', sep = '') },
content = function(file) {
write.csv(mtcars_filtered()[,input$indicator], file, row.names = FALSE)
})
}
shinyApp(ui = ui, server = server)
Suggest looking at ?"%>%" from magrittr package
Also, check this and this answers on SO.
Your table should be fine with this kind of syntax
output$results <- DT::renderDataTable({
columns = input$indicator
mtcars_filtered()[, columns, drop = FALSE] %>%
datatable() %>%
formatCurrency( input your code here) %>%
formatPercentage( and so on ... )
}, style = 'bootstrap', options = list(paging = FALSE, dom = 't'))
Also, I didnt quite get the question about downloading. If you want to download a data FROM server, use downloadHandler() function. Something like:
output$save_data <- downloadHandler(
filename = function() { paste("filename", '.csv', sep = '') },
content = function(file) {
write.csv(mydata(), file, row.names = FALSE)
})
and downloadButton("save_data", "download") in ui.R
edit: as per your changes, download isn't working because you got wrong columns selected: there is no table called tableId, and you need to take the columns from the table called results:
write.csv(mtcars_filtered()[, c(input$results_columns_selected)], file, row.names = FALSE)
as of rounding problem, you can use your indicator variable to see if column is selected input$indicator %in% c('drat', 'qsec', 'wt') then use subsetting to select only columns with TRUE, if there are any: formatRound(input$indicator[input$indicator %in% c('drat', 'qsec', 'wt')], 2)
edit2
Seems I've understood everything you wanted to do right.
To select columns in the downloadHandler function based on your checkboxes , use indicator variable to filter it:
mtcars_filtered()[, input$indicator]
Otherwise, if you want to select them from the table itself with the mouse clicks, use input$results_columns_selected, like this:
mtcars_filtered()[, c(input$results_columns_selected)]